gcc/f/expr.c

   1 /* expr.c -- Implementation File (module.c template V1.0)
   2    Copyright (C) 1995, 1996, 1997, 1998, 2001, 2002
   3    Free Software Foundation, Inc.
   4    Contributed by James Craig Burley.
   5
   6 This file is part of GNU Fortran.
   7
   8 GNU Fortran is free software; you can redistribute it and/or modify
   9 it under the terms of the GNU General Public License as published by
  10 the Free Software Foundation; either version 2, or (at your option)
  11 any later version.
  12
  13 GNU Fortran is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GNU Fortran; see the file COPYING.  If not, write to
  20 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  21 02111-1307, USA.
  22
  23    Related Modules:
  24       None.
  25
  26    Description:
  27       Handles syntactic and semantic analysis of Fortran expressions.
  28
  29    Modifications:
  30 */
  31
  32 /* Include files. */
  33
  34 #include "proj.h"
  35 #include "expr.h"
  36 #include "bad.h"
  37 #include "bld.h"
  38 #include "com.h"
  39 #include "global.h"
  40 #include "implic.h"
  41 #include "intrin.h"
  42 #include "info.h"
  43 #include "lex.h"
  44 #include "malloc.h"
  45 #include "src.h"
  46 #include "st.h"
  47 #include "symbol.h"
  48 #include "str.h"
  49 #include "target.h"
  50 #include "where.h"
  51 #include "real.h"
  52
  53 /* Externals defined here. */
  54
  55
  56 /* Simple definitions and enumerations. */
  57
  58 typedef enum
  59   {
  60     FFEEXPR_exprtypeUNKNOWN_,
  61     FFEEXPR_exprtypeOPERAND_,
  62     FFEEXPR_exprtypeUNARY_,
  63     FFEEXPR_exprtypeBINARY_,
  64     FFEEXPR_exprtype_
  65   } ffeexprExprtype_;
  66
  67 typedef enum
  68   {
  69     FFEEXPR_operatorPOWER_,
  70     FFEEXPR_operatorMULTIPLY_,
  71     FFEEXPR_operatorDIVIDE_,
  72     FFEEXPR_operatorADD_,
  73     FFEEXPR_operatorSUBTRACT_,
  74     FFEEXPR_operatorCONCATENATE_,
  75     FFEEXPR_operatorLT_,
  76     FFEEXPR_operatorLE_,
  77     FFEEXPR_operatorEQ_,
  78     FFEEXPR_operatorNE_,
  79     FFEEXPR_operatorGT_,
  80     FFEEXPR_operatorGE_,
  81     FFEEXPR_operatorNOT_,
  82     FFEEXPR_operatorAND_,
  83     FFEEXPR_operatorOR_,
  84     FFEEXPR_operatorXOR_,
  85     FFEEXPR_operatorEQV_,
  86     FFEEXPR_operatorNEQV_,
  87     FFEEXPR_operator_
  88   } ffeexprOperator_;
  89
  90 typedef enum
  91   {
  92     FFEEXPR_operatorprecedenceHIGHEST_ = 1,
  93     FFEEXPR_operatorprecedencePOWER_ = 1,
  94     FFEEXPR_operatorprecedenceMULTIPLY_ = 2,
  95     FFEEXPR_operatorprecedenceDIVIDE_ = 2,
  96     FFEEXPR_operatorprecedenceADD_ = 3,
  97     FFEEXPR_operatorprecedenceSUBTRACT_ = 3,
  98     FFEEXPR_operatorprecedenceLOWARITH_ = 3,
  99     FFEEXPR_operatorprecedenceCONCATENATE_ = 3,
 100     FFEEXPR_operatorprecedenceLT_ = 4,
 101     FFEEXPR_operatorprecedenceLE_ = 4,
 102     FFEEXPR_operatorprecedenceEQ_ = 4,
 103     FFEEXPR_operatorprecedenceNE_ = 4,
 104     FFEEXPR_operatorprecedenceGT_ = 4,
 105     FFEEXPR_operatorprecedenceGE_ = 4,
 106     FFEEXPR_operatorprecedenceNOT_ = 5,
 107     FFEEXPR_operatorprecedenceAND_ = 6,
 108     FFEEXPR_operatorprecedenceOR_ = 7,
 109     FFEEXPR_operatorprecedenceXOR_ = 8,
 110     FFEEXPR_operatorprecedenceEQV_ = 8,
 111     FFEEXPR_operatorprecedenceNEQV_ = 8,
 112     FFEEXPR_operatorprecedenceLOWEST_ = 8,
 113     FFEEXPR_operatorprecedence_
 114   } ffeexprOperatorPrecedence_;
 115
 116 #define FFEEXPR_operatorassociativityL2R_ TRUE
 117 #define FFEEXPR_operatorassociativityR2L_ FALSE
 118 #define FFEEXPR_operatorassociativityPOWER_ FFEEXPR_operatorassociativityR2L_
 119 #define FFEEXPR_operatorassociativityMULTIPLY_ FFEEXPR_operatorassociativityL2R_
 120 #define FFEEXPR_operatorassociativityDIVIDE_ FFEEXPR_operatorassociativityL2R_
 121 #define FFEEXPR_operatorassociativityADD_ FFEEXPR_operatorassociativityL2R_
 122 #define FFEEXPR_operatorassociativitySUBTRACT_ FFEEXPR_operatorassociativityL2R_
 123 #define FFEEXPR_operatorassociativityCONCATENATE_ FFEEXPR_operatorassociativityL2R_
 124 #define FFEEXPR_operatorassociativityLT_ FFEEXPR_operatorassociativityL2R_
 125 #define FFEEXPR_operatorassociativityLE_ FFEEXPR_operatorassociativityL2R_
 126 #define FFEEXPR_operatorassociativityEQ_ FFEEXPR_operatorassociativityL2R_
 127 #define FFEEXPR_operatorassociativityNE_ FFEEXPR_operatorassociativityL2R_
 128 #define FFEEXPR_operatorassociativityGT_ FFEEXPR_operatorassociativityL2R_
 129 #define FFEEXPR_operatorassociativityGE_ FFEEXPR_operatorassociativityL2R_
 130 #define FFEEXPR_operatorassociativityNOT_ FFEEXPR_operatorassociativityL2R_
 131 #define FFEEXPR_operatorassociativityAND_ FFEEXPR_operatorassociativityL2R_
 132 #define FFEEXPR_operatorassociativityOR_ FFEEXPR_operatorassociativityL2R_
 133 #define FFEEXPR_operatorassociativityXOR_ FFEEXPR_operatorassociativityL2R_
 134 #define FFEEXPR_operatorassociativityEQV_ FFEEXPR_operatorassociativityL2R_
 135 #define FFEEXPR_operatorassociativityNEQV_ FFEEXPR_operatorassociativityL2R_
 136
 137 typedef enum
 138   {
 139     FFEEXPR_parentypeFUNCTION_,
 140     FFEEXPR_parentypeSUBROUTINE_,
 141     FFEEXPR_parentypeARRAY_,
 142     FFEEXPR_parentypeSUBSTRING_,
 143     FFEEXPR_parentypeFUNSUBSTR_,/* Ambig: check for colon after first expr. */
 144     FFEEXPR_parentypeEQUIVALENCE_,      /* Ambig: ARRAY_ or SUBSTRING_. */
 145     FFEEXPR_parentypeANY_,      /* Allow basically anything. */
 146     FFEEXPR_parentype_
 147   } ffeexprParenType_;
 148
 149 typedef enum
 150   {
 151     FFEEXPR_percentNONE_,
 152     FFEEXPR_percentLOC_,
 153     FFEEXPR_percentVAL_,
 154     FFEEXPR_percentREF_,
 155     FFEEXPR_percentDESCR_,
 156     FFEEXPR_percent_
 157   } ffeexprPercent_;
 158
 159 /* Internal typedefs. */
 160
 161 typedef struct _ffeexpr_expr_ *ffeexprExpr_;
 162 typedef bool ffeexprOperatorAssociativity_;
 163 typedef struct _ffeexpr_stack_ *ffeexprStack_;
 164
 165 /* Private include files. */
 166
 167
 168 /* Internal structure definitions. */
 169
 170 struct _ffeexpr_expr_
 171   {
 172     ffeexprExpr_ previous;
 173     ffelexToken token;
 174     ffeexprExprtype_ type;
 175     union
 176       {
 177         struct
 178           {
 179             ffeexprOperator_ op;
 180             ffeexprOperatorPrecedence_ prec;
 181             ffeexprOperatorAssociativity_ as;
 182           }
 183         operator;
 184         ffebld operand;
 185       }
 186     u;
 187   };
 188
 189 struct _ffeexpr_stack_
 190   {
 191     ffeexprStack_ previous;
 192     mallocPool pool;
 193     ffeexprContext context;
 194     ffeexprCallback callback;
 195     ffelexToken first_token;
 196     ffeexprExpr_ exprstack;
 197     ffelexToken tokens[10];     /* Used in certain cases, like (unary)
 198                                    open-paren. */
 199     ffebld expr;                /* For first of
 200                                    complex/implied-do/substring/array-elements
 201                                    / actual-args expression. */
 202     ffebld bound_list;          /* For tracking dimension bounds list of
 203                                    array. */
 204     ffebldListBottom bottom;    /* For building lists. */
 205     ffeinfoRank rank;           /* For elements in an array reference. */
 206     bool constant;              /* TRUE while elements seen so far are
 207                                    constants. */
 208     bool immediate;             /* TRUE while elements seen so far are
 209                                    immediate/constants. */
 210     ffebld next_dummy;          /* Next SFUNC dummy arg in arg list. */
 211     ffebldListLength num_args;  /* Number of dummy args expected in arg list. */
 212     bool is_rhs;                /* TRUE if rhs context, FALSE otherwise. */
 213     ffeexprPercent_ percent;    /* Current %FOO keyword. */
 214   };
 215
 216 struct _ffeexpr_find_
 217   {
 218     ffelexToken t;
 219     ffelexHandler after;
 220     int level;
 221   };
 222
 223 /* Static objects accessed by functions in this module. */
 224
 225 static ffeexprStack_ ffeexpr_stack_;    /* Expression stack for semantic. */
 226 static ffelexToken ffeexpr_tokens_[10]; /* Scratchpad tokens for syntactic. */
 227 static ffestrOther ffeexpr_current_dotdot_;     /* Current .FOO. keyword. */
 228 static long ffeexpr_hollerith_count_;   /* ffeexpr_token_number_ and caller. */
 229 static int ffeexpr_level_;      /* Level of DATA implied-DO construct. */
 230 static bool ffeexpr_is_substr_ok_;      /* If OPEN_PAREN as binary "op" ok. */
 231 static struct _ffeexpr_find_ ffeexpr_find_;
 232
 233 /* Static functions (internal). */
 234
 235 static ffelexHandler ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr,
 236                                               ffelexToken t);
 237 static ffelexHandler ffeexpr_cb_close_paren_ambig_ (ffelexToken ft,
 238                                                     ffebld expr,
 239                                                     ffelexToken t);
 240 static ffelexHandler ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t);
 241 static ffelexHandler ffeexpr_cb_close_paren_c_ (ffelexToken ft,
 242                                                 ffebld expr, ffelexToken t);
 243 static ffelexHandler ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr,
 244                                           ffelexToken t);
 245 static ffelexHandler ffeexpr_cb_close_paren_ci_ (ffelexToken ft,
 246                                                  ffebld expr, ffelexToken t);
 247 static ffelexHandler ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr,
 248                                            ffelexToken t);
 249 static ffelexHandler ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr,
 250                                           ffelexToken t);
 251 static ffelexHandler ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr,
 252                                             ffelexToken t);
 253 static ffelexHandler ffeexpr_cb_comma_i_2_ (ffelexToken ft, ffebld expr,
 254                                             ffelexToken t);
 255 static ffelexHandler ffeexpr_cb_comma_i_3_ (ffelexToken ft, ffebld expr,
 256                                             ffelexToken t);
 257 static ffelexHandler ffeexpr_cb_comma_i_4_ (ffelexToken ft, ffebld expr,
 258                                             ffelexToken t);
 259 static ffelexHandler ffeexpr_cb_comma_i_5_ (ffelexToken t);
 260 static ffelexHandler ffeexpr_cb_end_loc_ (ffelexToken ft, ffebld expr,
 261                                           ffelexToken t);
 262 static ffelexHandler ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr,
 263                                              ffelexToken t);
 264 static ffelexHandler ffeexpr_cb_end_notloc_1_ (ffelexToken t);
 265 static ffesymbol ffeexpr_check_impctrl_ (ffesymbol s);
 266 static void ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
 267                                   ffebld dovar, ffelexToken dovar_t);
 268 static void ffeexpr_update_impdo_ (ffebld expr, ffebld dovar);
 269 static void ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar);
 270 static ffeexprContext ffeexpr_context_outer_ (ffeexprStack_ s);
 271 static ffeexprExpr_ ffeexpr_expr_new_ (void);
 272 static void ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t);
 273 static bool ffeexpr_isdigits_ (const char *p);
 274 static ffelexHandler ffeexpr_token_first_lhs_ (ffelexToken t);
 275 static ffelexHandler ffeexpr_token_first_lhs_1_ (ffelexToken t);
 276 static ffelexHandler ffeexpr_token_first_rhs_ (ffelexToken t);
 277 static ffelexHandler ffeexpr_token_first_rhs_1_ (ffelexToken t);
 278 static ffelexHandler ffeexpr_token_first_rhs_2_ (ffelexToken t);
 279 static ffelexHandler ffeexpr_token_first_rhs_3_ (ffelexToken t);
 280 static ffelexHandler ffeexpr_token_first_rhs_4_ (ffelexToken t);
 281 static ffelexHandler ffeexpr_token_first_rhs_5_ (ffelexToken t);
 282 static ffelexHandler ffeexpr_token_first_rhs_6_ (ffelexToken t);
 283 static ffelexHandler ffeexpr_token_namelist_ (ffelexToken t);
 284 static void ffeexpr_expr_kill_ (ffeexprExpr_ e);
 285 static void ffeexpr_exprstack_push_ (ffeexprExpr_ e);
 286 static void ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e);
 287 static void ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e);
 288 static void ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e);
 289 static void ffeexpr_reduce_ (void);
 290 static ffebld ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op,
 291                                       ffeexprExpr_ r);
 292 static ffebld ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l,
 293                                       ffeexprExpr_ op, ffeexprExpr_ r);
 294 static ffebld ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l,
 295                                             ffeexprExpr_ op, ffeexprExpr_ r);
 296 static ffebld ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l,
 297                                       ffeexprExpr_ op, ffeexprExpr_ r);
 298 static ffebld ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op,
 299                                       ffeexprExpr_ r);
 300 static ffebld ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l,
 301                                       ffeexprExpr_ op, ffeexprExpr_ r);
 302 static ffebld ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l,
 303                                       ffeexprExpr_ op, ffeexprExpr_ r);
 304 static ffebld ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l,
 305                                        ffeexprExpr_ op, ffeexprExpr_ r);
 306 static ffebld ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r);
 307 static ffebld ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op,
 308                                          ffeexprExpr_ r);
 309 static ffebld ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l,
 310                                       ffeexprExpr_ op, ffeexprExpr_ r);
 311 static ffebld ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l,
 312                                          ffeexprExpr_ op, ffeexprExpr_ r);
 313 static ffelexHandler ffeexpr_find_close_paren_ (ffelexToken t,
 314                                                 ffelexHandler after);
 315 static ffelexHandler ffeexpr_nil_finished_ (ffelexToken t);
 316 static ffelexHandler ffeexpr_nil_rhs_ (ffelexToken t);
 317 static ffelexHandler ffeexpr_nil_period_ (ffelexToken t);
 318 static ffelexHandler ffeexpr_nil_end_period_ (ffelexToken t);
 319 static ffelexHandler ffeexpr_nil_swallow_period_ (ffelexToken t);
 320 static ffelexHandler ffeexpr_nil_real_ (ffelexToken t);
 321 static ffelexHandler ffeexpr_nil_real_exponent_ (ffelexToken t);
 322 static ffelexHandler ffeexpr_nil_real_exp_sign_ (ffelexToken t);
 323 static ffelexHandler ffeexpr_nil_number_ (ffelexToken t);
 324 static ffelexHandler ffeexpr_nil_number_exponent_ (ffelexToken t);
 325 static ffelexHandler ffeexpr_nil_number_exp_sign_ (ffelexToken t);
 326 static ffelexHandler ffeexpr_nil_number_period_ (ffelexToken t);
 327 static ffelexHandler ffeexpr_nil_number_per_exp_ (ffelexToken t);
 328 static ffelexHandler ffeexpr_nil_number_real_ (ffelexToken t);
 329 static ffelexHandler ffeexpr_nil_num_per_exp_sign_ (ffelexToken t);
 330 static ffelexHandler ffeexpr_nil_number_real_exp_ (ffelexToken t);
 331 static ffelexHandler ffeexpr_nil_num_real_exp_sn_ (ffelexToken t);
 332 static ffelexHandler ffeexpr_nil_binary_ (ffelexToken t);
 333 static ffelexHandler ffeexpr_nil_binary_period_ (ffelexToken t);
 334 static ffelexHandler ffeexpr_nil_binary_end_per_ (ffelexToken t);
 335 static ffelexHandler ffeexpr_nil_binary_sw_per_ (ffelexToken t);
 336 static ffelexHandler ffeexpr_nil_quote_ (ffelexToken t);
 337 static ffelexHandler ffeexpr_nil_apostrophe_ (ffelexToken t);
 338 static ffelexHandler ffeexpr_nil_apos_char_ (ffelexToken t);
 339 static ffelexHandler ffeexpr_nil_name_rhs_ (ffelexToken t);
 340 static ffelexHandler ffeexpr_nil_name_apos_ (ffelexToken t);
 341 static ffelexHandler ffeexpr_nil_name_apos_name_ (ffelexToken t);
 342 static ffelexHandler ffeexpr_nil_percent_ (ffelexToken t);
 343 static ffelexHandler ffeexpr_nil_percent_name_ (ffelexToken t);
 344 static ffelexHandler ffeexpr_nil_substrp_ (ffelexToken t);
 345 static ffelexHandler ffeexpr_finished_ (ffelexToken t);
 346 static ffebld ffeexpr_finished_ambig_ (ffelexToken t, ffebld expr);
 347 static ffelexHandler ffeexpr_token_lhs_ (ffelexToken t);
 348 static ffelexHandler ffeexpr_token_rhs_ (ffelexToken t);
 349 static ffelexHandler ffeexpr_token_binary_ (ffelexToken t);
 350 static ffelexHandler ffeexpr_token_period_ (ffelexToken t);
 351 static ffelexHandler ffeexpr_token_end_period_ (ffelexToken t);
 352 static ffelexHandler ffeexpr_token_swallow_period_ (ffelexToken t);
 353 static ffelexHandler ffeexpr_token_real_ (ffelexToken t);
 354 static ffelexHandler ffeexpr_token_real_exponent_ (ffelexToken t);
 355 static ffelexHandler ffeexpr_token_real_exp_sign_ (ffelexToken t);
 356 static ffelexHandler ffeexpr_token_number_ (ffelexToken t);
 357 static ffelexHandler ffeexpr_token_number_exponent_ (ffelexToken t);
 358 static ffelexHandler ffeexpr_token_number_exp_sign_ (ffelexToken t);
 359 static ffelexHandler ffeexpr_token_number_period_ (ffelexToken t);
 360 static ffelexHandler ffeexpr_token_number_per_exp_ (ffelexToken t);
 361 static ffelexHandler ffeexpr_token_number_real_ (ffelexToken t);
 362 static ffelexHandler ffeexpr_token_num_per_exp_sign_ (ffelexToken t);
 363 static ffelexHandler ffeexpr_token_number_real_exp_ (ffelexToken t);
 364 static ffelexHandler ffeexpr_token_num_real_exp_sn_ (ffelexToken t);
 365 static ffelexHandler ffeexpr_token_binary_period_ (ffelexToken t);
 366 static ffelexHandler ffeexpr_token_binary_end_per_ (ffelexToken t);
 367 static ffelexHandler ffeexpr_token_binary_sw_per_ (ffelexToken t);
 368 static ffelexHandler ffeexpr_token_quote_ (ffelexToken t);
 369 static ffelexHandler ffeexpr_token_apostrophe_ (ffelexToken t);
 370 static ffelexHandler ffeexpr_token_apos_char_ (ffelexToken t);
 371 static ffelexHandler ffeexpr_token_name_lhs_ (ffelexToken t);
 372 static ffelexHandler ffeexpr_token_name_arg_ (ffelexToken t);
 373 static ffelexHandler ffeexpr_token_name_rhs_ (ffelexToken t);
 374 static ffelexHandler ffeexpr_token_name_apos_ (ffelexToken t);
 375 static ffelexHandler ffeexpr_token_name_apos_name_ (ffelexToken t);
 376 static ffelexHandler ffeexpr_token_percent_ (ffelexToken t);
 377 static ffelexHandler ffeexpr_token_percent_name_ (ffelexToken t);
 378 static ffelexHandler ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr,
 379                                                ffelexToken t);
 380 static ffelexHandler ffeexpr_token_elements_ (ffelexToken ft, ffebld expr,
 381                                               ffelexToken t);
 382 static ffelexHandler ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr,
 383                                                  ffelexToken t);
 384 static ffelexHandler ffeexpr_token_substring_ (ffelexToken ft, ffebld expr,
 385                                                ffelexToken t);
 386 static ffelexHandler ffeexpr_token_substring_1_ (ffelexToken ft, ffebld expr,
 387                                                  ffelexToken t);
 388 static ffelexHandler ffeexpr_token_substrp_ (ffelexToken t);
 389 static ffelexHandler ffeexpr_token_intrincheck_ (ffelexToken t);
 390 static ffelexHandler ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr,
 391                                                ffelexToken t);
 392 static ffelexHandler ffeexpr_token_anything_ (ffelexToken ft, ffebld expr,
 393                                               ffelexToken t);
 394 static void ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
 395             ffelexToken decimal, ffelexToken fraction, ffelexToken exponent,
 396                     ffelexToken exponent_sign, ffelexToken exponent_digits);
 397 static ffesymbol ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin);
 398 static ffesymbol ffeexpr_sym_impdoitem_ (ffesymbol s, ffelexToken t);
 399 static ffesymbol ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t);
 400 static ffesymbol ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t);
 401 static ffesymbol ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t);
 402 static ffesymbol ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t);
 403 static ffesymbol ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t);
 404 static ffesymbol ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t);
 405 static ffesymbol ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t);
 406 static ffesymbol ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t);
 407 static ffesymbol ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t);
 408 static ffesymbol ffeexpr_declare_parenthesized_ (ffelexToken t,
 409                                                  bool maybe_intrin,
 410                                              ffeexprParenType_ *paren_type);
 411 static ffesymbol ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t);
 412
 413 /* Internal macros. */
 414
 415 #define ffeexpr_paren_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
 416 #define ffeexpr_sym_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
 417 \f
 418 /* ffeexpr_collapse_convert -- Collapse convert expr
 419
 420    ffebld expr;
 421    ffelexToken token;
 422    expr = ffeexpr_collapse_convert(expr,token);
 423
 424    If the result of the expr is a constant, replaces the expr with the
 425    computed constant.  */
 426
 427 ffebld
 428 ffeexpr_collapse_convert (ffebld expr, ffelexToken t)
 429 {
 430   ffebad error = FFEBAD;
 431   ffebld l;
 432   ffebldConstantUnion u;
 433   ffeinfoBasictype bt;
 434   ffeinfoKindtype kt;
 435   ffetargetCharacterSize sz;
 436   ffetargetCharacterSize sz2;
 437
 438   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
 439     return expr;
 440
 441   l = ffebld_left (expr);
 442
 443   if (ffebld_op (l) != FFEBLD_opCONTER)
 444     return expr;
 445
 446   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
 447     {
 448     case FFEINFO_basictypeANY:
 449       return expr;
 450
 451     case FFEINFO_basictypeINTEGER:
 452       sz = FFETARGET_charactersizeNONE;
 453       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
 454         {
 455 #if FFETARGET_okINTEGER1
 456         case FFEINFO_kindtypeINTEGER1:
 457           switch (ffeinfo_basictype (ffebld_info (l)))
 458             {
 459             case FFEINFO_basictypeINTEGER:
 460               switch (ffeinfo_kindtype (ffebld_info (l)))
 461                 {
 462 #if FFETARGET_okINTEGER2
 463                 case FFEINFO_kindtypeINTEGER2:
 464                   error = ffetarget_convert_integer1_integer2
 465                     (ffebld_cu_ptr_integer1 (u),
 466                      ffebld_constant_integer2 (ffebld_conter (l)));
 467                   break;
 468 #endif
 469
 470 #if FFETARGET_okINTEGER3
 471                 case FFEINFO_kindtypeINTEGER3:
 472                   error = ffetarget_convert_integer1_integer3
 473                     (ffebld_cu_ptr_integer1 (u),
 474                      ffebld_constant_integer3 (ffebld_conter (l)));
 475                   break;
 476 #endif
 477
 478 #if FFETARGET_okINTEGER4
 479                 case FFEINFO_kindtypeINTEGER4:
 480                   error = ffetarget_convert_integer1_integer4
 481                     (ffebld_cu_ptr_integer1 (u),
 482                      ffebld_constant_integer4 (ffebld_conter (l)));
 483                   break;
 484 #endif
 485
 486                 default:
 487                   assert ("INTEGER1/INTEGER bad source kind type" == NULL);
 488                   break;
 489                 }
 490               break;
 491
 492             case FFEINFO_basictypeREAL:
 493               switch (ffeinfo_kindtype (ffebld_info (l)))
 494                 {
 495 #if FFETARGET_okREAL1
 496                 case FFEINFO_kindtypeREAL1:
 497                   error = ffetarget_convert_integer1_real1
 498                     (ffebld_cu_ptr_integer1 (u),
 499                      ffebld_constant_real1 (ffebld_conter (l)));
 500                   break;
 501 #endif
 502
 503 #if FFETARGET_okREAL2
 504                 case FFEINFO_kindtypeREAL2:
 505                   error = ffetarget_convert_integer1_real2
 506                     (ffebld_cu_ptr_integer1 (u),
 507                      ffebld_constant_real2 (ffebld_conter (l)));
 508                   break;
 509 #endif
 510
 511 #if FFETARGET_okREAL3
 512                 case FFEINFO_kindtypeREAL3:
 513                   error = ffetarget_convert_integer1_real3
 514                     (ffebld_cu_ptr_integer1 (u),
 515                      ffebld_constant_real3 (ffebld_conter (l)));
 516                   break;
 517 #endif
 518
 519 #if FFETARGET_okREAL4
 520                 case FFEINFO_kindtypeREAL4:
 521                   error = ffetarget_convert_integer1_real4
 522                     (ffebld_cu_ptr_integer1 (u),
 523                      ffebld_constant_real4 (ffebld_conter (l)));
 524                   break;
 525 #endif
 526
 527                 default:
 528                   assert ("INTEGER1/REAL bad source kind type" == NULL);
 529                   break;
 530                 }
 531               break;
 532
 533             case FFEINFO_basictypeCOMPLEX:
 534               switch (ffeinfo_kindtype (ffebld_info (l)))
 535                 {
 536 #if FFETARGET_okCOMPLEX1
 537                 case FFEINFO_kindtypeREAL1:
 538                   error = ffetarget_convert_integer1_complex1
 539                     (ffebld_cu_ptr_integer1 (u),
 540                      ffebld_constant_complex1 (ffebld_conter (l)));
 541                   break;
 542 #endif
 543
 544 #if FFETARGET_okCOMPLEX2
 545                 case FFEINFO_kindtypeREAL2:
 546                   error = ffetarget_convert_integer1_complex2
 547                     (ffebld_cu_ptr_integer1 (u),
 548                      ffebld_constant_complex2 (ffebld_conter (l)));
 549                   break;
 550 #endif
 551
 552 #if FFETARGET_okCOMPLEX3
 553                 case FFEINFO_kindtypeREAL3:
 554                   error = ffetarget_convert_integer1_complex3
 555                     (ffebld_cu_ptr_integer1 (u),
 556                      ffebld_constant_complex3 (ffebld_conter (l)));
 557                   break;
 558 #endif
 559
 560 #if FFETARGET_okCOMPLEX4
 561                 case FFEINFO_kindtypeREAL4:
 562                   error = ffetarget_convert_integer1_complex4
 563                     (ffebld_cu_ptr_integer1 (u),
 564                      ffebld_constant_complex4 (ffebld_conter (l)));
 565                   break;
 566 #endif
 567
 568                 default:
 569                   assert ("INTEGER1/COMPLEX bad source kind type" == NULL);
 570                   break;
 571                 }
 572               break;
 573
 574             case FFEINFO_basictypeLOGICAL:
 575               switch (ffeinfo_kindtype (ffebld_info (l)))
 576                 {
 577 #if FFETARGET_okLOGICAL1
 578                 case FFEINFO_kindtypeLOGICAL1:
 579                   error = ffetarget_convert_integer1_logical1
 580                     (ffebld_cu_ptr_integer1 (u),
 581                      ffebld_constant_logical1 (ffebld_conter (l)));
 582                   break;
 583 #endif
 584
 585 #if FFETARGET_okLOGICAL2
 586                 case FFEINFO_kindtypeLOGICAL2:
 587                   error = ffetarget_convert_integer1_logical2
 588                     (ffebld_cu_ptr_integer1 (u),
 589                      ffebld_constant_logical2 (ffebld_conter (l)));
 590                   break;
 591 #endif
 592
 593 #if FFETARGET_okLOGICAL3
 594                 case FFEINFO_kindtypeLOGICAL3:
 595                   error = ffetarget_convert_integer1_logical3
 596                     (ffebld_cu_ptr_integer1 (u),
 597                      ffebld_constant_logical3 (ffebld_conter (l)));
 598                   break;
 599 #endif
 600
 601 #if FFETARGET_okLOGICAL4
 602                 case FFEINFO_kindtypeLOGICAL4:
 603                   error = ffetarget_convert_integer1_logical4
 604                     (ffebld_cu_ptr_integer1 (u),
 605                      ffebld_constant_logical4 (ffebld_conter (l)));
 606                   break;
 607 #endif
 608
 609                 default:
 610                   assert ("INTEGER1/LOGICAL bad source kind type" == NULL);
 611                   break;
 612                 }
 613               break;
 614
 615             case FFEINFO_basictypeCHARACTER:
 616               error = ffetarget_convert_integer1_character1
 617                 (ffebld_cu_ptr_integer1 (u),
 618                  ffebld_constant_character1 (ffebld_conter (l)));
 619               break;
 620
 621             case FFEINFO_basictypeHOLLERITH:
 622               error = ffetarget_convert_integer1_hollerith
 623                 (ffebld_cu_ptr_integer1 (u),
 624                  ffebld_constant_hollerith (ffebld_conter (l)));
 625               break;
 626
 627             case FFEINFO_basictypeTYPELESS:
 628               error = ffetarget_convert_integer1_typeless
 629                 (ffebld_cu_ptr_integer1 (u),
 630                  ffebld_constant_typeless (ffebld_conter (l)));
 631               break;
 632
 633             default:
 634               assert ("INTEGER1 bad type" == NULL);
 635               break;
 636             }
 637
 638           /* If conversion operation is not implemented, return original expr.  */
 639           if (error == FFEBAD_NOCANDO)
 640             return expr;
 641
 642           expr = ffebld_new_conter_with_orig
 643             (ffebld_constant_new_integer1_val
 644              (ffebld_cu_val_integer1 (u)), expr);
 645           break;
 646 #endif
 647
 648 #if FFETARGET_okINTEGER2
 649         case FFEINFO_kindtypeINTEGER2:
 650           switch (ffeinfo_basictype (ffebld_info (l)))
 651             {
 652             case FFEINFO_basictypeINTEGER:
 653               switch (ffeinfo_kindtype (ffebld_info (l)))
 654                 {
 655 #if FFETARGET_okINTEGER1
 656                 case FFEINFO_kindtypeINTEGER1:
 657                   error = ffetarget_convert_integer2_integer1
 658                     (ffebld_cu_ptr_integer2 (u),
 659                      ffebld_constant_integer1 (ffebld_conter (l)));
 660                   break;
 661 #endif
 662
 663 #if FFETARGET_okINTEGER3
 664                 case FFEINFO_kindtypeINTEGER3:
 665                   error = ffetarget_convert_integer2_integer3
 666                     (ffebld_cu_ptr_integer2 (u),
 667                      ffebld_constant_integer3 (ffebld_conter (l)));
 668                   break;
 669 #endif
 670
 671 #if FFETARGET_okINTEGER4
 672                 case FFEINFO_kindtypeINTEGER4:
 673                   error = ffetarget_convert_integer2_integer4
 674                     (ffebld_cu_ptr_integer2 (u),
 675                      ffebld_constant_integer4 (ffebld_conter (l)));
 676                   break;
 677 #endif
 678
 679                 default:
 680                   assert ("INTEGER2/INTEGER bad source kind type" == NULL);
 681                   break;
 682                 }
 683               break;
 684
 685             case FFEINFO_basictypeREAL:
 686               switch (ffeinfo_kindtype (ffebld_info (l)))
 687                 {
 688 #if FFETARGET_okREAL1
 689                 case FFEINFO_kindtypeREAL1:
 690                   error = ffetarget_convert_integer2_real1
 691                     (ffebld_cu_ptr_integer2 (u),
 692                      ffebld_constant_real1 (ffebld_conter (l)));
 693                   break;
 694 #endif
 695
 696 #if FFETARGET_okREAL2
 697                 case FFEINFO_kindtypeREAL2:
 698                   error = ffetarget_convert_integer2_real2
 699                     (ffebld_cu_ptr_integer2 (u),
 700                      ffebld_constant_real2 (ffebld_conter (l)));
 701                   break;
 702 #endif
 703
 704 #if FFETARGET_okREAL3
 705                 case FFEINFO_kindtypeREAL3:
 706                   error = ffetarget_convert_integer2_real3
 707                     (ffebld_cu_ptr_integer2 (u),
 708                      ffebld_constant_real3 (ffebld_conter (l)));
 709                   break;
 710 #endif
 711
 712 #if FFETARGET_okREAL4
 713                 case FFEINFO_kindtypeREAL4:
 714                   error = ffetarget_convert_integer2_real4
 715                     (ffebld_cu_ptr_integer2 (u),
 716                      ffebld_constant_real4 (ffebld_conter (l)));
 717                   break;
 718 #endif
 719
 720                 default:
 721                   assert ("INTEGER2/REAL bad source kind type" == NULL);
 722                   break;
 723                 }
 724               break;
 725
 726             case FFEINFO_basictypeCOMPLEX:
 727               switch (ffeinfo_kindtype (ffebld_info (l)))
 728                 {
 729 #if FFETARGET_okCOMPLEX1
 730                 case FFEINFO_kindtypeREAL1:
 731                   error = ffetarget_convert_integer2_complex1
 732                     (ffebld_cu_ptr_integer2 (u),
 733                      ffebld_constant_complex1 (ffebld_conter (l)));
 734                   break;
 735 #endif
 736
 737 #if FFETARGET_okCOMPLEX2
 738                 case FFEINFO_kindtypeREAL2:
 739                   error = ffetarget_convert_integer2_complex2
 740                     (ffebld_cu_ptr_integer2 (u),
 741                      ffebld_constant_complex2 (ffebld_conter (l)));
 742                   break;
 743 #endif
 744
 745 #if FFETARGET_okCOMPLEX3
 746                 case FFEINFO_kindtypeREAL3:
 747                   error = ffetarget_convert_integer2_complex3
 748                     (ffebld_cu_ptr_integer2 (u),
 749                      ffebld_constant_complex3 (ffebld_conter (l)));
 750                   break;
 751 #endif
 752
 753 #if FFETARGET_okCOMPLEX4
 754                 case FFEINFO_kindtypeREAL4:
 755                   error = ffetarget_convert_integer2_complex4
 756                     (ffebld_cu_ptr_integer2 (u),
 757                      ffebld_constant_complex4 (ffebld_conter (l)));
 758                   break;
 759 #endif
 760
 761                 default:
 762                   assert ("INTEGER2/COMPLEX bad source kind type" == NULL);
 763                   break;
 764                 }
 765               break;
 766
 767             case FFEINFO_basictypeLOGICAL:
 768               switch (ffeinfo_kindtype (ffebld_info (l)))
 769                 {
 770 #if FFETARGET_okLOGICAL1
 771                 case FFEINFO_kindtypeLOGICAL1:
 772                   error = ffetarget_convert_integer2_logical1
 773                     (ffebld_cu_ptr_integer2 (u),
 774                      ffebld_constant_logical1 (ffebld_conter (l)));
 775                   break;
 776 #endif
 777
 778 #if FFETARGET_okLOGICAL2
 779                 case FFEINFO_kindtypeLOGICAL2:
 780                   error = ffetarget_convert_integer2_logical2
 781                     (ffebld_cu_ptr_integer2 (u),
 782                      ffebld_constant_logical2 (ffebld_conter (l)));
 783                   break;
 784 #endif
 785
 786 #if FFETARGET_okLOGICAL3
 787                 case FFEINFO_kindtypeLOGICAL3:
 788                   error = ffetarget_convert_integer2_logical3
 789                     (ffebld_cu_ptr_integer2 (u),
 790                      ffebld_constant_logical3 (ffebld_conter (l)));
 791                   break;
 792 #endif
 793
 794 #if FFETARGET_okLOGICAL4
 795                 case FFEINFO_kindtypeLOGICAL4:
 796                   error = ffetarget_convert_integer2_logical4
 797                     (ffebld_cu_ptr_integer2 (u),
 798                      ffebld_constant_logical4 (ffebld_conter (l)));
 799                   break;
 800 #endif
 801
 802                 default:
 803                   assert ("INTEGER2/LOGICAL bad source kind type" == NULL);
 804                   break;
 805                 }
 806               break;
 807
 808             case FFEINFO_basictypeCHARACTER:
 809               error = ffetarget_convert_integer2_character1
 810                 (ffebld_cu_ptr_integer2 (u),
 811                  ffebld_constant_character1 (ffebld_conter (l)));
 812               break;
 813
 814             case FFEINFO_basictypeHOLLERITH:
 815               error = ffetarget_convert_integer2_hollerith
 816                 (ffebld_cu_ptr_integer2 (u),
 817                  ffebld_constant_hollerith (ffebld_conter (l)));
 818               break;
 819
 820             case FFEINFO_basictypeTYPELESS:
 821               error = ffetarget_convert_integer2_typeless
 822                 (ffebld_cu_ptr_integer2 (u),
 823                  ffebld_constant_typeless (ffebld_conter (l)));
 824               break;
 825
 826             default:
 827               assert ("INTEGER2 bad type" == NULL);
 828               break;
 829             }
 830
 831           /* If conversion operation is not implemented, return original expr.  */
 832           if (error == FFEBAD_NOCANDO)
 833             return expr;
 834
 835           expr = ffebld_new_conter_with_orig
 836             (ffebld_constant_new_integer2_val
 837              (ffebld_cu_val_integer2 (u)), expr);
 838           break;
 839 #endif
 840
 841 #if FFETARGET_okINTEGER3
 842         case FFEINFO_kindtypeINTEGER3:
 843           switch (ffeinfo_basictype (ffebld_info (l)))
 844             {
 845             case FFEINFO_basictypeINTEGER:
 846               switch (ffeinfo_kindtype (ffebld_info (l)))
 847                 {
 848 #if FFETARGET_okINTEGER1
 849                 case FFEINFO_kindtypeINTEGER1:
 850                   error = ffetarget_convert_integer3_integer1
 851                     (ffebld_cu_ptr_integer3 (u),
 852                      ffebld_constant_integer1 (ffebld_conter (l)));
 853                   break;
 854 #endif
 855
 856 #if FFETARGET_okINTEGER2
 857                 case FFEINFO_kindtypeINTEGER2:
 858                   error = ffetarget_convert_integer3_integer2
 859                     (ffebld_cu_ptr_integer3 (u),
 860                      ffebld_constant_integer2 (ffebld_conter (l)));
 861                   break;
 862 #endif
 863
 864 #if FFETARGET_okINTEGER4
 865                 case FFEINFO_kindtypeINTEGER4:
 866                   error = ffetarget_convert_integer3_integer4
 867                     (ffebld_cu_ptr_integer3 (u),
 868                      ffebld_constant_integer4 (ffebld_conter (l)));
 869                   break;
 870 #endif
 871
 872                 default:
 873                   assert ("INTEGER3/INTEGER bad source kind type" == NULL);
 874                   break;
 875                 }
 876               break;
 877
 878             case FFEINFO_basictypeREAL:
 879               switch (ffeinfo_kindtype (ffebld_info (l)))
 880                 {
 881 #if FFETARGET_okREAL1
 882                 case FFEINFO_kindtypeREAL1:
 883                   error = ffetarget_convert_integer3_real1
 884                     (ffebld_cu_ptr_integer3 (u),
 885                      ffebld_constant_real1 (ffebld_conter (l)));
 886                   break;
 887 #endif
 888
 889 #if FFETARGET_okREAL2
 890                 case FFEINFO_kindtypeREAL2:
 891                   error = ffetarget_convert_integer3_real2
 892                     (ffebld_cu_ptr_integer3 (u),
 893                      ffebld_constant_real2 (ffebld_conter (l)));
 894                   break;
 895 #endif
 896
 897 #if FFETARGET_okREAL3
 898                 case FFEINFO_kindtypeREAL3:
 899                   error = ffetarget_convert_integer3_real3
 900                     (ffebld_cu_ptr_integer3 (u),
 901                      ffebld_constant_real3 (ffebld_conter (l)));
 902                   break;
 903 #endif
 904
 905 #if FFETARGET_okREAL4
 906                 case FFEINFO_kindtypeREAL4:
 907                   error = ffetarget_convert_integer3_real4
 908                     (ffebld_cu_ptr_integer3 (u),
 909                      ffebld_constant_real4 (ffebld_conter (l)));
 910                   break;
 911 #endif
 912
 913                 default:
 914                   assert ("INTEGER3/REAL bad source kind type" == NULL);
 915                   break;
 916                 }
 917               break;
 918
 919             case FFEINFO_basictypeCOMPLEX:
 920               switch (ffeinfo_kindtype (ffebld_info (l)))
 921                 {
 922 #if FFETARGET_okCOMPLEX1
 923                 case FFEINFO_kindtypeREAL1:
 924                   error = ffetarget_convert_integer3_complex1
 925                     (ffebld_cu_ptr_integer3 (u),
 926                      ffebld_constant_complex1 (ffebld_conter (l)));
 927                   break;
 928 #endif
 929
 930 #if FFETARGET_okCOMPLEX2
 931                 case FFEINFO_kindtypeREAL2:
 932                   error = ffetarget_convert_integer3_complex2
 933                     (ffebld_cu_ptr_integer3 (u),
 934                      ffebld_constant_complex2 (ffebld_conter (l)));
 935                   break;
 936 #endif
 937
 938 #if FFETARGET_okCOMPLEX3
 939                 case FFEINFO_kindtypeREAL3:
 940                   error = ffetarget_convert_integer3_complex3
 941                     (ffebld_cu_ptr_integer3 (u),
 942                      ffebld_constant_complex3 (ffebld_conter (l)));
 943                   break;
 944 #endif
 945
 946 #if FFETARGET_okCOMPLEX4
 947                 case FFEINFO_kindtypeREAL4:
 948                   error = ffetarget_convert_integer3_complex4
 949                     (ffebld_cu_ptr_integer3 (u),
 950                      ffebld_constant_complex4 (ffebld_conter (l)));
 951                   break;
 952 #endif
 953
 954                 default:
 955                   assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
 956                   break;
 957                 }
 958               break;
 959
 960             case FFEINFO_basictypeLOGICAL:
 961               switch (ffeinfo_kindtype (ffebld_info (l)))
 962                 {
 963 #if FFETARGET_okLOGICAL1
 964                 case FFEINFO_kindtypeLOGICAL1:
 965                   error = ffetarget_convert_integer3_logical1
 966                     (ffebld_cu_ptr_integer3 (u),
 967                      ffebld_constant_logical1 (ffebld_conter (l)));
 968                   break;
 969 #endif
 970
 971 #if FFETARGET_okLOGICAL2
 972                 case FFEINFO_kindtypeLOGICAL2:
 973                   error = ffetarget_convert_integer3_logical2
 974                     (ffebld_cu_ptr_integer3 (u),
 975                      ffebld_constant_logical2 (ffebld_conter (l)));
 976                   break;
 977 #endif
 978
 979 #if FFETARGET_okLOGICAL3
 980                 case FFEINFO_kindtypeLOGICAL3:
 981                   error = ffetarget_convert_integer3_logical3
 982                     (ffebld_cu_ptr_integer3 (u),
 983                      ffebld_constant_logical3 (ffebld_conter (l)));
 984                   break;
 985 #endif
 986
 987 #if FFETARGET_okLOGICAL4
 988                 case FFEINFO_kindtypeLOGICAL4:
 989                   error = ffetarget_convert_integer3_logical4
 990                     (ffebld_cu_ptr_integer3 (u),
 991                      ffebld_constant_logical4 (ffebld_conter (l)));
 992                   break;
 993 #endif
 994
 995                 default:
 996                   assert ("INTEGER3/LOGICAL bad source kind type" == NULL);
 997                   break;
 998                 }
 999               break;
1000
1001             case FFEINFO_basictypeCHARACTER:
1002               error = ffetarget_convert_integer3_character1
1003                 (ffebld_cu_ptr_integer3 (u),
1004                  ffebld_constant_character1 (ffebld_conter (l)));
1005               break;
1006
1007             case FFEINFO_basictypeHOLLERITH:
1008               error = ffetarget_convert_integer3_hollerith
1009                 (ffebld_cu_ptr_integer3 (u),
1010                  ffebld_constant_hollerith (ffebld_conter (l)));
1011               break;
1012
1013             case FFEINFO_basictypeTYPELESS:
1014               error = ffetarget_convert_integer3_typeless
1015                 (ffebld_cu_ptr_integer3 (u),
1016                  ffebld_constant_typeless (ffebld_conter (l)));
1017               break;
1018
1019             default:
1020               assert ("INTEGER3 bad type" == NULL);
1021               break;
1022             }
1023
1024           /* If conversion operation is not implemented, return original expr.  */
1025           if (error == FFEBAD_NOCANDO)
1026             return expr;
1027
1028           expr = ffebld_new_conter_with_orig
1029             (ffebld_constant_new_integer3_val
1030              (ffebld_cu_val_integer3 (u)), expr);
1031           break;
1032 #endif
1033
1034 #if FFETARGET_okINTEGER4
1035         case FFEINFO_kindtypeINTEGER4:
1036           switch (ffeinfo_basictype (ffebld_info (l)))
1037             {
1038             case FFEINFO_basictypeINTEGER:
1039               switch (ffeinfo_kindtype (ffebld_info (l)))
1040                 {
1041 #if FFETARGET_okINTEGER1
1042                 case FFEINFO_kindtypeINTEGER1:
1043                   error = ffetarget_convert_integer4_integer1
1044                     (ffebld_cu_ptr_integer4 (u),
1045                      ffebld_constant_integer1 (ffebld_conter (l)));
1046                   break;
1047 #endif
1048
1049 #if FFETARGET_okINTEGER2
1050                 case FFEINFO_kindtypeINTEGER2:
1051                   error = ffetarget_convert_integer4_integer2
1052                     (ffebld_cu_ptr_integer4 (u),
1053                      ffebld_constant_integer2 (ffebld_conter (l)));
1054                   break;
1055 #endif
1056
1057 #if FFETARGET_okINTEGER3
1058                 case FFEINFO_kindtypeINTEGER3:
1059                   error = ffetarget_convert_integer4_integer3
1060                     (ffebld_cu_ptr_integer4 (u),
1061                      ffebld_constant_integer3 (ffebld_conter (l)));
1062                   break;
1063 #endif
1064
1065                 default:
1066                   assert ("INTEGER4/INTEGER bad source kind type" == NULL);
1067                   break;
1068                 }
1069               break;
1070
1071             case FFEINFO_basictypeREAL:
1072               switch (ffeinfo_kindtype (ffebld_info (l)))
1073                 {
1074 #if FFETARGET_okREAL1
1075                 case FFEINFO_kindtypeREAL1:
1076                   error = ffetarget_convert_integer4_real1
1077                     (ffebld_cu_ptr_integer4 (u),
1078                      ffebld_constant_real1 (ffebld_conter (l)));
1079                   break;
1080 #endif
1081
1082 #if FFETARGET_okREAL2
1083                 case FFEINFO_kindtypeREAL2:
1084                   error = ffetarget_convert_integer4_real2
1085                     (ffebld_cu_ptr_integer4 (u),
1086                      ffebld_constant_real2 (ffebld_conter (l)));
1087                   break;
1088 #endif
1089
1090 #if FFETARGET_okREAL3
1091                 case FFEINFO_kindtypeREAL3:
1092                   error = ffetarget_convert_integer4_real3
1093                     (ffebld_cu_ptr_integer4 (u),
1094                      ffebld_constant_real3 (ffebld_conter (l)));
1095                   break;
1096 #endif
1097
1098 #if FFETARGET_okREAL4
1099                 case FFEINFO_kindtypeREAL4:
1100                   error = ffetarget_convert_integer4_real4
1101                     (ffebld_cu_ptr_integer4 (u),
1102                      ffebld_constant_real4 (ffebld_conter (l)));
1103                   break;
1104 #endif
1105
1106                 default:
1107                   assert ("INTEGER4/REAL bad source kind type" == NULL);
1108                   break;
1109                 }
1110               break;
1111
1112             case FFEINFO_basictypeCOMPLEX:
1113               switch (ffeinfo_kindtype (ffebld_info (l)))
1114                 {
1115 #if FFETARGET_okCOMPLEX1
1116                 case FFEINFO_kindtypeREAL1:
1117                   error = ffetarget_convert_integer4_complex1
1118                     (ffebld_cu_ptr_integer4 (u),
1119                      ffebld_constant_complex1 (ffebld_conter (l)));
1120                   break;
1121 #endif
1122
1123 #if FFETARGET_okCOMPLEX2
1124                 case FFEINFO_kindtypeREAL2:
1125                   error = ffetarget_convert_integer4_complex2
1126                     (ffebld_cu_ptr_integer4 (u),
1127                      ffebld_constant_complex2 (ffebld_conter (l)));
1128                   break;
1129 #endif
1130
1131 #if FFETARGET_okCOMPLEX3
1132                 case FFEINFO_kindtypeREAL3:
1133                   error = ffetarget_convert_integer4_complex3
1134                     (ffebld_cu_ptr_integer4 (u),
1135                      ffebld_constant_complex3 (ffebld_conter (l)));
1136                   break;
1137 #endif
1138
1139 #if FFETARGET_okCOMPLEX4
1140                 case FFEINFO_kindtypeREAL4:
1141                   error = ffetarget_convert_integer4_complex4
1142                     (ffebld_cu_ptr_integer4 (u),
1143                      ffebld_constant_complex4 (ffebld_conter (l)));
1144                   break;
1145 #endif
1146
1147                 default:
1148                   assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
1149                   break;
1150                 }
1151               break;
1152
1153             case FFEINFO_basictypeLOGICAL:
1154               switch (ffeinfo_kindtype (ffebld_info (l)))
1155                 {
1156 #if FFETARGET_okLOGICAL1
1157                 case FFEINFO_kindtypeLOGICAL1:
1158                   error = ffetarget_convert_integer4_logical1
1159                     (ffebld_cu_ptr_integer4 (u),
1160                      ffebld_constant_logical1 (ffebld_conter (l)));
1161                   break;
1162 #endif
1163
1164 #if FFETARGET_okLOGICAL2
1165                 case FFEINFO_kindtypeLOGICAL2:
1166                   error = ffetarget_convert_integer4_logical2
1167                     (ffebld_cu_ptr_integer4 (u),
1168                      ffebld_constant_logical2 (ffebld_conter (l)));
1169                   break;
1170 #endif
1171
1172 #if FFETARGET_okLOGICAL3
1173                 case FFEINFO_kindtypeLOGICAL3:
1174                   error = ffetarget_convert_integer4_logical3
1175                     (ffebld_cu_ptr_integer4 (u),
1176                      ffebld_constant_logical3 (ffebld_conter (l)));
1177                   break;
1178 #endif
1179
1180 #if FFETARGET_okLOGICAL4
1181                 case FFEINFO_kindtypeLOGICAL4:
1182                   error = ffetarget_convert_integer4_logical4
1183                     (ffebld_cu_ptr_integer4 (u),
1184                      ffebld_constant_logical4 (ffebld_conter (l)));
1185                   break;
1186 #endif
1187
1188                 default:
1189                   assert ("INTEGER4/LOGICAL bad source kind type" == NULL);
1190                   break;
1191                 }
1192               break;
1193
1194             case FFEINFO_basictypeCHARACTER:
1195               error = ffetarget_convert_integer4_character1
1196                 (ffebld_cu_ptr_integer4 (u),
1197                  ffebld_constant_character1 (ffebld_conter (l)));
1198               break;
1199
1200             case FFEINFO_basictypeHOLLERITH:
1201               error = ffetarget_convert_integer4_hollerith
1202                 (ffebld_cu_ptr_integer4 (u),
1203                  ffebld_constant_hollerith (ffebld_conter (l)));
1204               break;
1205
1206             case FFEINFO_basictypeTYPELESS:
1207               error = ffetarget_convert_integer4_typeless
1208                 (ffebld_cu_ptr_integer4 (u),
1209                  ffebld_constant_typeless (ffebld_conter (l)));
1210               break;
1211
1212             default:
1213               assert ("INTEGER4 bad type" == NULL);
1214               break;
1215             }
1216
1217           /* If conversion operation is not implemented, return original expr.  */
1218           if (error == FFEBAD_NOCANDO)
1219             return expr;
1220
1221           expr = ffebld_new_conter_with_orig
1222             (ffebld_constant_new_integer4_val
1223              (ffebld_cu_val_integer4 (u)), expr);
1224           break;
1225 #endif
1226
1227         default:
1228           assert ("bad integer kind type" == NULL);
1229           break;
1230         }
1231       break;
1232
1233     case FFEINFO_basictypeLOGICAL:
1234       sz = FFETARGET_charactersizeNONE;
1235       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1236         {
1237 #if FFETARGET_okLOGICAL1
1238         case FFEINFO_kindtypeLOGICAL1:
1239           switch (ffeinfo_basictype (ffebld_info (l)))
1240             {
1241             case FFEINFO_basictypeLOGICAL:
1242               switch (ffeinfo_kindtype (ffebld_info (l)))
1243                 {
1244 #if FFETARGET_okLOGICAL2
1245                 case FFEINFO_kindtypeLOGICAL2:
1246                   error = ffetarget_convert_logical1_logical2
1247                     (ffebld_cu_ptr_logical1 (u),
1248                      ffebld_constant_logical2 (ffebld_conter (l)));
1249                   break;
1250 #endif
1251
1252 #if FFETARGET_okLOGICAL3
1253                 case FFEINFO_kindtypeLOGICAL3:
1254                   error = ffetarget_convert_logical1_logical3
1255                     (ffebld_cu_ptr_logical1 (u),
1256                      ffebld_constant_logical3 (ffebld_conter (l)));
1257                   break;
1258 #endif
1259
1260 #if FFETARGET_okLOGICAL4
1261                 case FFEINFO_kindtypeLOGICAL4:
1262                   error = ffetarget_convert_logical1_logical4
1263                     (ffebld_cu_ptr_logical1 (u),
1264                      ffebld_constant_logical4 (ffebld_conter (l)));
1265                   break;
1266 #endif
1267
1268                 default:
1269                   assert ("LOGICAL1/LOGICAL bad source kind type" == NULL);
1270                   break;
1271                 }
1272               break;
1273
1274             case FFEINFO_basictypeINTEGER:
1275               switch (ffeinfo_kindtype (ffebld_info (l)))
1276                 {
1277 #if FFETARGET_okINTEGER1
1278                 case FFEINFO_kindtypeINTEGER1:
1279                   error = ffetarget_convert_logical1_integer1
1280                     (ffebld_cu_ptr_logical1 (u),
1281                      ffebld_constant_integer1 (ffebld_conter (l)));
1282                   break;
1283 #endif
1284
1285 #if FFETARGET_okINTEGER2
1286                 case FFEINFO_kindtypeINTEGER2:
1287                   error = ffetarget_convert_logical1_integer2
1288                     (ffebld_cu_ptr_logical1 (u),
1289                      ffebld_constant_integer2 (ffebld_conter (l)));
1290                   break;
1291 #endif
1292
1293 #if FFETARGET_okINTEGER3
1294                 case FFEINFO_kindtypeINTEGER3:
1295                   error = ffetarget_convert_logical1_integer3
1296                     (ffebld_cu_ptr_logical1 (u),
1297                      ffebld_constant_integer3 (ffebld_conter (l)));
1298                   break;
1299 #endif
1300
1301 #if FFETARGET_okINTEGER4
1302                 case FFEINFO_kindtypeINTEGER4:
1303                   error = ffetarget_convert_logical1_integer4
1304                     (ffebld_cu_ptr_logical1 (u),
1305                      ffebld_constant_integer4 (ffebld_conter (l)));
1306                   break;
1307 #endif
1308
1309                 default:
1310                   assert ("LOGICAL1/INTEGER bad source kind type" == NULL);
1311                   break;
1312                 }
1313               break;
1314
1315             case FFEINFO_basictypeCHARACTER:
1316               error = ffetarget_convert_logical1_character1
1317                 (ffebld_cu_ptr_logical1 (u),
1318                  ffebld_constant_character1 (ffebld_conter (l)));
1319               break;
1320
1321             case FFEINFO_basictypeHOLLERITH:
1322               error = ffetarget_convert_logical1_hollerith
1323                 (ffebld_cu_ptr_logical1 (u),
1324                  ffebld_constant_hollerith (ffebld_conter (l)));
1325               break;
1326
1327             case FFEINFO_basictypeTYPELESS:
1328               error = ffetarget_convert_logical1_typeless
1329                 (ffebld_cu_ptr_logical1 (u),
1330                  ffebld_constant_typeless (ffebld_conter (l)));
1331               break;
1332
1333             default:
1334               assert ("LOGICAL1 bad type" == NULL);
1335               break;
1336             }
1337
1338           /* If conversion operation is not implemented, return original expr.  */
1339           if (error == FFEBAD_NOCANDO)
1340             return expr;
1341
1342           expr = ffebld_new_conter_with_orig
1343             (ffebld_constant_new_logical1_val
1344              (ffebld_cu_val_logical1 (u)), expr);
1345           break;
1346 #endif
1347
1348 #if FFETARGET_okLOGICAL2
1349         case FFEINFO_kindtypeLOGICAL2:
1350           switch (ffeinfo_basictype (ffebld_info (l)))
1351             {
1352             case FFEINFO_basictypeLOGICAL:
1353               switch (ffeinfo_kindtype (ffebld_info (l)))
1354                 {
1355 #if FFETARGET_okLOGICAL1
1356                 case FFEINFO_kindtypeLOGICAL1:
1357                   error = ffetarget_convert_logical2_logical1
1358                     (ffebld_cu_ptr_logical2 (u),
1359                      ffebld_constant_logical1 (ffebld_conter (l)));
1360                   break;
1361 #endif
1362
1363 #if FFETARGET_okLOGICAL3
1364                 case FFEINFO_kindtypeLOGICAL3:
1365                   error = ffetarget_convert_logical2_logical3
1366                     (ffebld_cu_ptr_logical2 (u),
1367                      ffebld_constant_logical3 (ffebld_conter (l)));
1368                   break;
1369 #endif
1370
1371 #if FFETARGET_okLOGICAL4
1372                 case FFEINFO_kindtypeLOGICAL4:
1373                   error = ffetarget_convert_logical2_logical4
1374                     (ffebld_cu_ptr_logical2 (u),
1375                      ffebld_constant_logical4 (ffebld_conter (l)));
1376                   break;
1377 #endif
1378
1379                 default:
1380                   assert ("LOGICAL2/LOGICAL bad source kind type" == NULL);
1381                   break;
1382                 }
1383               break;
1384
1385             case FFEINFO_basictypeINTEGER:
1386               switch (ffeinfo_kindtype (ffebld_info (l)))
1387                 {
1388 #if FFETARGET_okINTEGER1
1389                 case FFEINFO_kindtypeINTEGER1:
1390                   error = ffetarget_convert_logical2_integer1
1391                     (ffebld_cu_ptr_logical2 (u),
1392                      ffebld_constant_integer1 (ffebld_conter (l)));
1393                   break;
1394 #endif
1395
1396 #if FFETARGET_okINTEGER2
1397                 case FFEINFO_kindtypeINTEGER2:
1398                   error = ffetarget_convert_logical2_integer2
1399                     (ffebld_cu_ptr_logical2 (u),
1400                      ffebld_constant_integer2 (ffebld_conter (l)));
1401                   break;
1402 #endif
1403
1404 #if FFETARGET_okINTEGER3
1405                 case FFEINFO_kindtypeINTEGER3:
1406                   error = ffetarget_convert_logical2_integer3
1407                     (ffebld_cu_ptr_logical2 (u),
1408                      ffebld_constant_integer3 (ffebld_conter (l)));
1409                   break;
1410 #endif
1411
1412 #if FFETARGET_okINTEGER4
1413                 case FFEINFO_kindtypeINTEGER4:
1414                   error = ffetarget_convert_logical2_integer4
1415                     (ffebld_cu_ptr_logical2 (u),
1416                      ffebld_constant_integer4 (ffebld_conter (l)));
1417                   break;
1418 #endif
1419
1420                 default:
1421                   assert ("LOGICAL2/INTEGER bad source kind type" == NULL);
1422                   break;
1423                 }
1424               break;
1425
1426             case FFEINFO_basictypeCHARACTER:
1427               error = ffetarget_convert_logical2_character1
1428                 (ffebld_cu_ptr_logical2 (u),
1429                  ffebld_constant_character1 (ffebld_conter (l)));
1430               break;
1431
1432             case FFEINFO_basictypeHOLLERITH:
1433               error = ffetarget_convert_logical2_hollerith
1434                 (ffebld_cu_ptr_logical2 (u),
1435                  ffebld_constant_hollerith (ffebld_conter (l)));
1436               break;
1437
1438             case FFEINFO_basictypeTYPELESS:
1439               error = ffetarget_convert_logical2_typeless
1440                 (ffebld_cu_ptr_logical2 (u),
1441                  ffebld_constant_typeless (ffebld_conter (l)));
1442               break;
1443
1444             default:
1445               assert ("LOGICAL2 bad type" == NULL);
1446               break;
1447             }
1448
1449           /* If conversion operation is not implemented, return original expr.  */
1450           if (error == FFEBAD_NOCANDO)
1451             return expr;
1452
1453           expr = ffebld_new_conter_with_orig
1454             (ffebld_constant_new_logical2_val
1455              (ffebld_cu_val_logical2 (u)), expr);
1456           break;
1457 #endif
1458
1459 #if FFETARGET_okLOGICAL3
1460         case FFEINFO_kindtypeLOGICAL3:
1461           switch (ffeinfo_basictype (ffebld_info (l)))
1462             {
1463             case FFEINFO_basictypeLOGICAL:
1464               switch (ffeinfo_kindtype (ffebld_info (l)))
1465                 {
1466 #if FFETARGET_okLOGICAL1
1467                 case FFEINFO_kindtypeLOGICAL1:
1468                   error = ffetarget_convert_logical3_logical1
1469                     (ffebld_cu_ptr_logical3 (u),
1470                      ffebld_constant_logical1 (ffebld_conter (l)));
1471                   break;
1472 #endif
1473
1474 #if FFETARGET_okLOGICAL2
1475                 case FFEINFO_kindtypeLOGICAL2:
1476                   error = ffetarget_convert_logical3_logical2
1477                     (ffebld_cu_ptr_logical3 (u),
1478                      ffebld_constant_logical2 (ffebld_conter (l)));
1479                   break;
1480 #endif
1481
1482 #if FFETARGET_okLOGICAL4
1483                 case FFEINFO_kindtypeLOGICAL4:
1484                   error = ffetarget_convert_logical3_logical4
1485                     (ffebld_cu_ptr_logical3 (u),
1486                      ffebld_constant_logical4 (ffebld_conter (l)));
1487                   break;
1488 #endif
1489
1490                 default:
1491                   assert ("LOGICAL3/LOGICAL bad source kind type" == NULL);
1492                   break;
1493                 }
1494               break;
1495
1496             case FFEINFO_basictypeINTEGER:
1497               switch (ffeinfo_kindtype (ffebld_info (l)))
1498                 {
1499 #if FFETARGET_okINTEGER1
1500                 case FFEINFO_kindtypeINTEGER1:
1501                   error = ffetarget_convert_logical3_integer1
1502                     (ffebld_cu_ptr_logical3 (u),
1503                      ffebld_constant_integer1 (ffebld_conter (l)));
1504                   break;
1505 #endif
1506
1507 #if FFETARGET_okINTEGER2
1508                 case FFEINFO_kindtypeINTEGER2:
1509                   error = ffetarget_convert_logical3_integer2
1510                     (ffebld_cu_ptr_logical3 (u),
1511                      ffebld_constant_integer2 (ffebld_conter (l)));
1512                   break;
1513 #endif
1514
1515 #if FFETARGET_okINTEGER3
1516                 case FFEINFO_kindtypeINTEGER3:
1517                   error = ffetarget_convert_logical3_integer3
1518                     (ffebld_cu_ptr_logical3 (u),
1519                      ffebld_constant_integer3 (ffebld_conter (l)));
1520                   break;
1521 #endif
1522
1523 #if FFETARGET_okINTEGER4
1524                 case FFEINFO_kindtypeINTEGER4:
1525                   error = ffetarget_convert_logical3_integer4
1526                     (ffebld_cu_ptr_logical3 (u),
1527                      ffebld_constant_integer4 (ffebld_conter (l)));
1528                   break;
1529 #endif
1530
1531                 default:
1532                   assert ("LOGICAL3/INTEGER bad source kind type" == NULL);
1533                   break;
1534                 }
1535               break;
1536
1537             case FFEINFO_basictypeCHARACTER:
1538               error = ffetarget_convert_logical3_character1
1539                 (ffebld_cu_ptr_logical3 (u),
1540                  ffebld_constant_character1 (ffebld_conter (l)));
1541               break;
1542
1543             case FFEINFO_basictypeHOLLERITH:
1544               error = ffetarget_convert_logical3_hollerith
1545                 (ffebld_cu_ptr_logical3 (u),
1546                  ffebld_constant_hollerith (ffebld_conter (l)));
1547               break;
1548
1549             case FFEINFO_basictypeTYPELESS:
1550               error = ffetarget_convert_logical3_typeless
1551                 (ffebld_cu_ptr_logical3 (u),
1552                  ffebld_constant_typeless (ffebld_conter (l)));
1553               break;
1554
1555             default:
1556               assert ("LOGICAL3 bad type" == NULL);
1557               break;
1558             }
1559
1560           /* If conversion operation is not implemented, return original expr.  */
1561           if (error == FFEBAD_NOCANDO)
1562             return expr;
1563
1564           expr = ffebld_new_conter_with_orig
1565             (ffebld_constant_new_logical3_val
1566              (ffebld_cu_val_logical3 (u)), expr);
1567           break;
1568 #endif
1569
1570 #if FFETARGET_okLOGICAL4
1571         case FFEINFO_kindtypeLOGICAL4:
1572           switch (ffeinfo_basictype (ffebld_info (l)))
1573             {
1574             case FFEINFO_basictypeLOGICAL:
1575               switch (ffeinfo_kindtype (ffebld_info (l)))
1576                 {
1577 #if FFETARGET_okLOGICAL1
1578                 case FFEINFO_kindtypeLOGICAL1:
1579                   error = ffetarget_convert_logical4_logical1
1580                     (ffebld_cu_ptr_logical4 (u),
1581                      ffebld_constant_logical1 (ffebld_conter (l)));
1582                   break;
1583 #endif
1584
1585 #if FFETARGET_okLOGICAL2
1586                 case FFEINFO_kindtypeLOGICAL2:
1587                   error = ffetarget_convert_logical4_logical2
1588                     (ffebld_cu_ptr_logical4 (u),
1589                      ffebld_constant_logical2 (ffebld_conter (l)));
1590                   break;
1591 #endif
1592
1593 #if FFETARGET_okLOGICAL3
1594                 case FFEINFO_kindtypeLOGICAL3:
1595                   error = ffetarget_convert_logical4_logical3
1596                     (ffebld_cu_ptr_logical4 (u),
1597                      ffebld_constant_logical3 (ffebld_conter (l)));
1598                   break;
1599 #endif
1600
1601                 default:
1602                   assert ("LOGICAL4/LOGICAL bad source kind type" == NULL);
1603                   break;
1604                 }
1605               break;
1606
1607             case FFEINFO_basictypeINTEGER:
1608               switch (ffeinfo_kindtype (ffebld_info (l)))
1609                 {
1610 #if FFETARGET_okINTEGER1
1611                 case FFEINFO_kindtypeINTEGER1:
1612                   error = ffetarget_convert_logical4_integer1
1613                     (ffebld_cu_ptr_logical4 (u),
1614                      ffebld_constant_integer1 (ffebld_conter (l)));
1615                   break;
1616 #endif
1617
1618 #if FFETARGET_okINTEGER2
1619                 case FFEINFO_kindtypeINTEGER2:
1620                   error = ffetarget_convert_logical4_integer2
1621                     (ffebld_cu_ptr_logical4 (u),
1622                      ffebld_constant_integer2 (ffebld_conter (l)));
1623                   break;
1624 #endif
1625
1626 #if FFETARGET_okINTEGER3
1627                 case FFEINFO_kindtypeINTEGER3:
1628                   error = ffetarget_convert_logical4_integer3
1629                     (ffebld_cu_ptr_logical4 (u),
1630                      ffebld_constant_integer3 (ffebld_conter (l)));
1631                   break;
1632 #endif
1633
1634 #if FFETARGET_okINTEGER4
1635                 case FFEINFO_kindtypeINTEGER4:
1636                   error = ffetarget_convert_logical4_integer4
1637                     (ffebld_cu_ptr_logical4 (u),
1638                      ffebld_constant_integer4 (ffebld_conter (l)));
1639                   break;
1640 #endif
1641
1642                 default:
1643                   assert ("LOGICAL4/INTEGER bad source kind type" == NULL);
1644                   break;
1645                 }
1646               break;
1647
1648             case FFEINFO_basictypeCHARACTER:
1649               error = ffetarget_convert_logical4_character1
1650                 (ffebld_cu_ptr_logical4 (u),
1651                  ffebld_constant_character1 (ffebld_conter (l)));
1652               break;
1653
1654             case FFEINFO_basictypeHOLLERITH:
1655               error = ffetarget_convert_logical4_hollerith
1656                 (ffebld_cu_ptr_logical4 (u),
1657                  ffebld_constant_hollerith (ffebld_conter (l)));
1658               break;
1659
1660             case FFEINFO_basictypeTYPELESS:
1661               error = ffetarget_convert_logical4_typeless
1662                 (ffebld_cu_ptr_logical4 (u),
1663                  ffebld_constant_typeless (ffebld_conter (l)));
1664               break;
1665
1666             default:
1667               assert ("LOGICAL4 bad type" == NULL);
1668               break;
1669             }
1670
1671           /* If conversion operation is not implemented, return original expr.  */
1672           if (error == FFEBAD_NOCANDO)
1673             return expr;
1674
1675           expr = ffebld_new_conter_with_orig
1676             (ffebld_constant_new_logical4_val
1677              (ffebld_cu_val_logical4 (u)), expr);
1678           break;
1679 #endif
1680
1681         default:
1682           assert ("bad logical kind type" == NULL);
1683           break;
1684         }
1685       break;
1686
1687     case FFEINFO_basictypeREAL:
1688       sz = FFETARGET_charactersizeNONE;
1689       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1690         {
1691 #if FFETARGET_okREAL1
1692         case FFEINFO_kindtypeREAL1:
1693           switch (ffeinfo_basictype (ffebld_info (l)))
1694             {
1695             case FFEINFO_basictypeINTEGER:
1696               switch (ffeinfo_kindtype (ffebld_info (l)))
1697                 {
1698 #if FFETARGET_okINTEGER1
1699                 case FFEINFO_kindtypeINTEGER1:
1700                   error = ffetarget_convert_real1_integer1
1701                     (ffebld_cu_ptr_real1 (u),
1702                      ffebld_constant_integer1 (ffebld_conter (l)));
1703                   break;
1704 #endif
1705
1706 #if FFETARGET_okINTEGER2
1707                 case FFEINFO_kindtypeINTEGER2:
1708                   error = ffetarget_convert_real1_integer2
1709                     (ffebld_cu_ptr_real1 (u),
1710                      ffebld_constant_integer2 (ffebld_conter (l)));
1711                   break;
1712 #endif
1713
1714 #if FFETARGET_okINTEGER3
1715                 case FFEINFO_kindtypeINTEGER3:
1716                   error = ffetarget_convert_real1_integer3
1717                     (ffebld_cu_ptr_real1 (u),
1718                      ffebld_constant_integer3 (ffebld_conter (l)));
1719                   break;
1720 #endif
1721
1722 #if FFETARGET_okINTEGER4
1723                 case FFEINFO_kindtypeINTEGER4:
1724                   error = ffetarget_convert_real1_integer4
1725                     (ffebld_cu_ptr_real1 (u),
1726                      ffebld_constant_integer4 (ffebld_conter (l)));
1727                   break;
1728 #endif
1729
1730                 default:
1731                   assert ("REAL1/INTEGER bad source kind type" == NULL);
1732                   break;
1733                 }
1734               break;
1735
1736             case FFEINFO_basictypeREAL:
1737               switch (ffeinfo_kindtype (ffebld_info (l)))
1738                 {
1739 #if FFETARGET_okREAL2
1740                 case FFEINFO_kindtypeREAL2:
1741                   error = ffetarget_convert_real1_real2
1742                     (ffebld_cu_ptr_real1 (u),
1743                      ffebld_constant_real2 (ffebld_conter (l)));
1744                   break;
1745 #endif
1746
1747 #if FFETARGET_okREAL3
1748                 case FFEINFO_kindtypeREAL3:
1749                   error = ffetarget_convert_real1_real3
1750                     (ffebld_cu_ptr_real1 (u),
1751                      ffebld_constant_real3 (ffebld_conter (l)));
1752                   break;
1753 #endif
1754
1755 #if FFETARGET_okREAL4
1756                 case FFEINFO_kindtypeREAL4:
1757                   error = ffetarget_convert_real1_real4
1758                     (ffebld_cu_ptr_real1 (u),
1759                      ffebld_constant_real4 (ffebld_conter (l)));
1760                   break;
1761 #endif
1762
1763                 default:
1764                   assert ("REAL1/REAL bad source kind type" == NULL);
1765                   break;
1766                 }
1767               break;
1768
1769             case FFEINFO_basictypeCOMPLEX:
1770               switch (ffeinfo_kindtype (ffebld_info (l)))
1771                 {
1772 #if FFETARGET_okCOMPLEX1
1773                 case FFEINFO_kindtypeREAL1:
1774                   error = ffetarget_convert_real1_complex1
1775                     (ffebld_cu_ptr_real1 (u),
1776                      ffebld_constant_complex1 (ffebld_conter (l)));
1777                   break;
1778 #endif
1779
1780 #if FFETARGET_okCOMPLEX2
1781                 case FFEINFO_kindtypeREAL2:
1782                   error = ffetarget_convert_real1_complex2
1783                     (ffebld_cu_ptr_real1 (u),
1784                      ffebld_constant_complex2 (ffebld_conter (l)));
1785                   break;
1786 #endif
1787
1788 #if FFETARGET_okCOMPLEX3
1789                 case FFEINFO_kindtypeREAL3:
1790                   error = ffetarget_convert_real1_complex3
1791                     (ffebld_cu_ptr_real1 (u),
1792                      ffebld_constant_complex3 (ffebld_conter (l)));
1793                   break;
1794 #endif
1795
1796 #if FFETARGET_okCOMPLEX4
1797                 case FFEINFO_kindtypeREAL4:
1798                   error = ffetarget_convert_real1_complex4
1799                     (ffebld_cu_ptr_real1 (u),
1800                      ffebld_constant_complex4 (ffebld_conter (l)));
1801                   break;
1802 #endif
1803
1804                 default:
1805                   assert ("REAL1/COMPLEX bad source kind type" == NULL);
1806                   break;
1807                 }
1808               break;
1809
1810             case FFEINFO_basictypeCHARACTER:
1811               error = ffetarget_convert_real1_character1
1812                 (ffebld_cu_ptr_real1 (u),
1813                  ffebld_constant_character1 (ffebld_conter (l)));
1814               break;
1815
1816             case FFEINFO_basictypeHOLLERITH:
1817               error = ffetarget_convert_real1_hollerith
1818                 (ffebld_cu_ptr_real1 (u),
1819                  ffebld_constant_hollerith (ffebld_conter (l)));
1820               break;
1821
1822             case FFEINFO_basictypeTYPELESS:
1823               error = ffetarget_convert_real1_typeless
1824                 (ffebld_cu_ptr_real1 (u),
1825                  ffebld_constant_typeless (ffebld_conter (l)));
1826               break;
1827
1828             default:
1829               assert ("REAL1 bad type" == NULL);
1830               break;
1831             }
1832
1833           /* If conversion operation is not implemented, return original expr.  */
1834           if (error == FFEBAD_NOCANDO)
1835             return expr;
1836
1837           expr = ffebld_new_conter_with_orig
1838             (ffebld_constant_new_real1_val
1839              (ffebld_cu_val_real1 (u)), expr);
1840           break;
1841 #endif
1842
1843 #if FFETARGET_okREAL2
1844         case FFEINFO_kindtypeREAL2:
1845           switch (ffeinfo_basictype (ffebld_info (l)))
1846             {
1847             case FFEINFO_basictypeINTEGER:
1848               switch (ffeinfo_kindtype (ffebld_info (l)))
1849                 {
1850 #if FFETARGET_okINTEGER1
1851                 case FFEINFO_kindtypeINTEGER1:
1852                   error = ffetarget_convert_real2_integer1
1853                     (ffebld_cu_ptr_real2 (u),
1854                      ffebld_constant_integer1 (ffebld_conter (l)));
1855                   break;
1856 #endif
1857
1858 #if FFETARGET_okINTEGER2
1859                 case FFEINFO_kindtypeINTEGER2:
1860                   error = ffetarget_convert_real2_integer2
1861                     (ffebld_cu_ptr_real2 (u),
1862                      ffebld_constant_integer2 (ffebld_conter (l)));
1863                   break;
1864 #endif
1865
1866 #if FFETARGET_okINTEGER3
1867                 case FFEINFO_kindtypeINTEGER3:
1868                   error = ffetarget_convert_real2_integer3
1869                     (ffebld_cu_ptr_real2 (u),
1870                      ffebld_constant_integer3 (ffebld_conter (l)));
1871                   break;
1872 #endif
1873
1874 #if FFETARGET_okINTEGER4
1875                 case FFEINFO_kindtypeINTEGER4:
1876                   error = ffetarget_convert_real2_integer4
1877                     (ffebld_cu_ptr_real2 (u),
1878                      ffebld_constant_integer4 (ffebld_conter (l)));
1879                   break;
1880 #endif
1881
1882                 default:
1883                   assert ("REAL2/INTEGER bad source kind type" == NULL);
1884                   break;
1885                 }
1886               break;
1887
1888             case FFEINFO_basictypeREAL:
1889               switch (ffeinfo_kindtype (ffebld_info (l)))
1890                 {
1891 #if FFETARGET_okREAL1
1892                 case FFEINFO_kindtypeREAL1:
1893                   error = ffetarget_convert_real2_real1
1894                     (ffebld_cu_ptr_real2 (u),
1895                      ffebld_constant_real1 (ffebld_conter (l)));
1896                   break;
1897 #endif
1898
1899 #if FFETARGET_okREAL3
1900                 case FFEINFO_kindtypeREAL3:
1901                   error = ffetarget_convert_real2_real3
1902                     (ffebld_cu_ptr_real2 (u),
1903                      ffebld_constant_real3 (ffebld_conter (l)));
1904                   break;
1905 #endif
1906
1907 #if FFETARGET_okREAL4
1908                 case FFEINFO_kindtypeREAL4:
1909                   error = ffetarget_convert_real2_real4
1910                     (ffebld_cu_ptr_real2 (u),
1911                      ffebld_constant_real4 (ffebld_conter (l)));
1912                   break;
1913 #endif
1914
1915                 default:
1916                   assert ("REAL2/REAL bad source kind type" == NULL);
1917                   break;
1918                 }
1919               break;
1920
1921             case FFEINFO_basictypeCOMPLEX:
1922               switch (ffeinfo_kindtype (ffebld_info (l)))
1923                 {
1924 #if FFETARGET_okCOMPLEX1
1925                 case FFEINFO_kindtypeREAL1:
1926                   error = ffetarget_convert_real2_complex1
1927                     (ffebld_cu_ptr_real2 (u),
1928                      ffebld_constant_complex1 (ffebld_conter (l)));
1929                   break;
1930 #endif
1931
1932 #if FFETARGET_okCOMPLEX2
1933                 case FFEINFO_kindtypeREAL2:
1934                   error = ffetarget_convert_real2_complex2
1935                     (ffebld_cu_ptr_real2 (u),
1936                      ffebld_constant_complex2 (ffebld_conter (l)));
1937                   break;
1938 #endif
1939
1940 #if FFETARGET_okCOMPLEX3
1941                 case FFEINFO_kindtypeREAL3:
1942                   error = ffetarget_convert_real2_complex3
1943                     (ffebld_cu_ptr_real2 (u),
1944                      ffebld_constant_complex3 (ffebld_conter (l)));
1945                   break;
1946 #endif
1947
1948 #if FFETARGET_okCOMPLEX4
1949                 case FFEINFO_kindtypeREAL4:
1950                   error = ffetarget_convert_real2_complex4
1951                     (ffebld_cu_ptr_real2 (u),
1952                      ffebld_constant_complex4 (ffebld_conter (l)));
1953                   break;
1954 #endif
1955
1956                 default:
1957                   assert ("REAL2/COMPLEX bad source kind type" == NULL);
1958                   break;
1959                 }
1960               break;
1961
1962             case FFEINFO_basictypeCHARACTER:
1963               error = ffetarget_convert_real2_character1
1964                 (ffebld_cu_ptr_real2 (u),
1965                  ffebld_constant_character1 (ffebld_conter (l)));
1966               break;
1967
1968             case FFEINFO_basictypeHOLLERITH:
1969               error = ffetarget_convert_real2_hollerith
1970                 (ffebld_cu_ptr_real2 (u),
1971                  ffebld_constant_hollerith (ffebld_conter (l)));
1972               break;
1973
1974             case FFEINFO_basictypeTYPELESS:
1975               error = ffetarget_convert_real2_typeless
1976                 (ffebld_cu_ptr_real2 (u),
1977                  ffebld_constant_typeless (ffebld_conter (l)));
1978               break;
1979
1980             default:
1981               assert ("REAL2 bad type" == NULL);
1982               break;
1983             }
1984
1985           /* If conversion operation is not implemented, return original expr.  */
1986           if (error == FFEBAD_NOCANDO)
1987             return expr;
1988
1989           expr = ffebld_new_conter_with_orig
1990             (ffebld_constant_new_real2_val
1991              (ffebld_cu_val_real2 (u)), expr);
1992           break;
1993 #endif
1994
1995 #if FFETARGET_okREAL3
1996         case FFEINFO_kindtypeREAL3:
1997           switch (ffeinfo_basictype (ffebld_info (l)))
1998             {
1999             case FFEINFO_basictypeINTEGER:
2000               switch (ffeinfo_kindtype (ffebld_info (l)))
2001                 {
2002 #if FFETARGET_okINTEGER1
2003                 case FFEINFO_kindtypeINTEGER1:
2004                   error = ffetarget_convert_real3_integer1
2005                     (ffebld_cu_ptr_real3 (u),
2006                      ffebld_constant_integer1 (ffebld_conter (l)));
2007                   break;
2008 #endif
2009
2010 #if FFETARGET_okINTEGER2
2011                 case FFEINFO_kindtypeINTEGER2:
2012                   error = ffetarget_convert_real3_integer2
2013                     (ffebld_cu_ptr_real3 (u),
2014                      ffebld_constant_integer2 (ffebld_conter (l)));
2015                   break;
2016 #endif
2017
2018 #if FFETARGET_okINTEGER3
2019                 case FFEINFO_kindtypeINTEGER3:
2020                   error = ffetarget_convert_real3_integer3
2021                     (ffebld_cu_ptr_real3 (u),
2022                      ffebld_constant_integer3 (ffebld_conter (l)));
2023                   break;
2024 #endif
2025
2026 #if FFETARGET_okINTEGER4
2027                 case FFEINFO_kindtypeINTEGER4:
2028                   error = ffetarget_convert_real3_integer4
2029                     (ffebld_cu_ptr_real3 (u),
2030                      ffebld_constant_integer4 (ffebld_conter (l)));
2031                   break;
2032 #endif
2033
2034                 default:
2035                   assert ("REAL3/INTEGER bad source kind type" == NULL);
2036                   break;
2037                 }
2038               break;
2039
2040             case FFEINFO_basictypeREAL:
2041               switch (ffeinfo_kindtype (ffebld_info (l)))
2042                 {
2043 #if FFETARGET_okREAL1
2044                 case FFEINFO_kindtypeREAL1:
2045                   error = ffetarget_convert_real3_real1
2046                     (ffebld_cu_ptr_real3 (u),
2047                      ffebld_constant_real1 (ffebld_conter (l)));
2048                   break;
2049 #endif
2050
2051 #if FFETARGET_okREAL2
2052                 case FFEINFO_kindtypeREAL2:
2053                   error = ffetarget_convert_real3_real2
2054                     (ffebld_cu_ptr_real3 (u),
2055                      ffebld_constant_real2 (ffebld_conter (l)));
2056                   break;
2057 #endif
2058
2059 #if FFETARGET_okREAL4
2060                 case FFEINFO_kindtypeREAL4:
2061                   error = ffetarget_convert_real3_real4
2062                     (ffebld_cu_ptr_real3 (u),
2063                      ffebld_constant_real4 (ffebld_conter (l)));
2064                   break;
2065 #endif
2066
2067                 default:
2068                   assert ("REAL3/REAL bad source kind type" == NULL);
2069                   break;
2070                 }
2071               break;
2072
2073             case FFEINFO_basictypeCOMPLEX:
2074               switch (ffeinfo_kindtype (ffebld_info (l)))
2075                 {
2076 #if FFETARGET_okCOMPLEX1
2077                 case FFEINFO_kindtypeREAL1:
2078                   error = ffetarget_convert_real3_complex1
2079                     (ffebld_cu_ptr_real3 (u),
2080                      ffebld_constant_complex1 (ffebld_conter (l)));
2081                   break;
2082 #endif
2083
2084 #if FFETARGET_okCOMPLEX2
2085                 case FFEINFO_kindtypeREAL2:
2086                   error = ffetarget_convert_real3_complex2
2087                     (ffebld_cu_ptr_real3 (u),
2088                      ffebld_constant_complex2 (ffebld_conter (l)));
2089                   break;
2090 #endif
2091
2092 #if FFETARGET_okCOMPLEX3
2093                 case FFEINFO_kindtypeREAL3:
2094                   error = ffetarget_convert_real3_complex3
2095                     (ffebld_cu_ptr_real3 (u),
2096                      ffebld_constant_complex3 (ffebld_conter (l)));
2097                   break;
2098 #endif
2099
2100 #if FFETARGET_okCOMPLEX4
2101                 case FFEINFO_kindtypeREAL4:
2102                   error = ffetarget_convert_real3_complex4
2103                     (ffebld_cu_ptr_real3 (u),
2104                      ffebld_constant_complex4 (ffebld_conter (l)));
2105                   break;
2106 #endif
2107
2108                 default:
2109                   assert ("REAL3/COMPLEX bad source kind type" == NULL);
2110                   break;
2111                 }
2112               break;
2113
2114             case FFEINFO_basictypeCHARACTER:
2115               error = ffetarget_convert_real3_character1
2116                 (ffebld_cu_ptr_real3 (u),
2117                  ffebld_constant_character1 (ffebld_conter (l)));
2118               break;
2119
2120             case FFEINFO_basictypeHOLLERITH:
2121               error = ffetarget_convert_real3_hollerith
2122                 (ffebld_cu_ptr_real3 (u),
2123                  ffebld_constant_hollerith (ffebld_conter (l)));
2124               break;
2125
2126             case FFEINFO_basictypeTYPELESS:
2127               error = ffetarget_convert_real3_typeless
2128                 (ffebld_cu_ptr_real3 (u),
2129                  ffebld_constant_typeless (ffebld_conter (l)));
2130               break;
2131
2132             default:
2133               assert ("REAL3 bad type" == NULL);
2134               break;
2135             }
2136
2137           /* If conversion operation is not implemented, return original expr.  */
2138           if (error == FFEBAD_NOCANDO)
2139             return expr;
2140
2141           expr = ffebld_new_conter_with_orig
2142             (ffebld_constant_new_real3_val
2143              (ffebld_cu_val_real3 (u)), expr);
2144           break;
2145 #endif
2146
2147 #if FFETARGET_okREAL4
2148         case FFEINFO_kindtypeREAL4:
2149           switch (ffeinfo_basictype (ffebld_info (l)))
2150             {
2151             case FFEINFO_basictypeINTEGER:
2152               switch (ffeinfo_kindtype (ffebld_info (l)))
2153                 {
2154 #if FFETARGET_okINTEGER1
2155                 case FFEINFO_kindtypeINTEGER1:
2156                   error = ffetarget_convert_real4_integer1
2157                     (ffebld_cu_ptr_real4 (u),
2158                      ffebld_constant_integer1 (ffebld_conter (l)));
2159                   break;
2160 #endif
2161
2162 #if FFETARGET_okINTEGER2
2163                 case FFEINFO_kindtypeINTEGER2:
2164                   error = ffetarget_convert_real4_integer2
2165                     (ffebld_cu_ptr_real4 (u),
2166                      ffebld_constant_integer2 (ffebld_conter (l)));
2167                   break;
2168 #endif
2169
2170 #if FFETARGET_okINTEGER3
2171                 case FFEINFO_kindtypeINTEGER3:
2172                   error = ffetarget_convert_real4_integer3
2173                     (ffebld_cu_ptr_real4 (u),
2174                      ffebld_constant_integer3 (ffebld_conter (l)));
2175                   break;
2176 #endif
2177
2178 #if FFETARGET_okINTEGER4
2179                 case FFEINFO_kindtypeINTEGER4:
2180                   error = ffetarget_convert_real4_integer4
2181                     (ffebld_cu_ptr_real4 (u),
2182                      ffebld_constant_integer4 (ffebld_conter (l)));
2183                   break;
2184 #endif
2185
2186                 default:
2187                   assert ("REAL4/INTEGER bad source kind type" == NULL);
2188                   break;
2189                 }
2190               break;
2191
2192             case FFEINFO_basictypeREAL:
2193               switch (ffeinfo_kindtype (ffebld_info (l)))
2194                 {
2195 #if FFETARGET_okREAL1
2196                 case FFEINFO_kindtypeREAL1:
2197                   error = ffetarget_convert_real4_real1
2198                     (ffebld_cu_ptr_real4 (u),
2199                      ffebld_constant_real1 (ffebld_conter (l)));
2200                   break;
2201 #endif
2202
2203 #if FFETARGET_okREAL2
2204                 case FFEINFO_kindtypeREAL2:
2205                   error = ffetarget_convert_real4_real2
2206                     (ffebld_cu_ptr_real4 (u),
2207                      ffebld_constant_real2 (ffebld_conter (l)));
2208                   break;
2209 #endif
2210
2211 #if FFETARGET_okREAL3
2212                 case FFEINFO_kindtypeREAL3:
2213                   error = ffetarget_convert_real4_real3
2214                     (ffebld_cu_ptr_real4 (u),
2215                      ffebld_constant_real3 (ffebld_conter (l)));
2216                   break;
2217 #endif
2218
2219                 default:
2220                   assert ("REAL4/REAL bad source kind type" == NULL);
2221                   break;
2222                 }
2223               break;
2224
2225             case FFEINFO_basictypeCOMPLEX:
2226               switch (ffeinfo_kindtype (ffebld_info (l)))
2227                 {
2228 #if FFETARGET_okCOMPLEX1
2229                 case FFEINFO_kindtypeREAL1:
2230                   error = ffetarget_convert_real4_complex1
2231                     (ffebld_cu_ptr_real4 (u),
2232                      ffebld_constant_complex1 (ffebld_conter (l)));
2233                   break;
2234 #endif
2235
2236 #if FFETARGET_okCOMPLEX2
2237                 case FFEINFO_kindtypeREAL2:
2238                   error = ffetarget_convert_real4_complex2
2239                     (ffebld_cu_ptr_real4 (u),
2240                      ffebld_constant_complex2 (ffebld_conter (l)));
2241                   break;
2242 #endif
2243
2244 #if FFETARGET_okCOMPLEX3
2245                 case FFEINFO_kindtypeREAL3:
2246                   error = ffetarget_convert_real4_complex3
2247                     (ffebld_cu_ptr_real4 (u),
2248                      ffebld_constant_complex3 (ffebld_conter (l)));
2249                   break;
2250 #endif
2251
2252 #if FFETARGET_okCOMPLEX4
2253                 case FFEINFO_kindtypeREAL4:
2254                   error = ffetarget_convert_real4_complex4
2255                     (ffebld_cu_ptr_real4 (u),
2256                      ffebld_constant_complex4 (ffebld_conter (l)));
2257                   break;
2258 #endif
2259
2260                 default:
2261                   assert ("REAL4/COMPLEX bad source kind type" == NULL);
2262                   break;
2263                 }
2264               break;
2265
2266             case FFEINFO_basictypeCHARACTER:
2267               error = ffetarget_convert_real4_character1
2268                 (ffebld_cu_ptr_real4 (u),
2269                  ffebld_constant_character1 (ffebld_conter (l)));
2270               break;
2271
2272             case FFEINFO_basictypeHOLLERITH:
2273               error = ffetarget_convert_real4_hollerith
2274                 (ffebld_cu_ptr_real4 (u),
2275                  ffebld_constant_hollerith (ffebld_conter (l)));
2276               break;
2277
2278             case FFEINFO_basictypeTYPELESS:
2279               error = ffetarget_convert_real4_typeless
2280                 (ffebld_cu_ptr_real4 (u),
2281                  ffebld_constant_typeless (ffebld_conter (l)));
2282               break;
2283
2284             default:
2285               assert ("REAL4 bad type" == NULL);
2286               break;
2287             }
2288
2289           /* If conversion operation is not implemented, return original expr.  */
2290           if (error == FFEBAD_NOCANDO)
2291             return expr;
2292
2293           expr = ffebld_new_conter_with_orig
2294             (ffebld_constant_new_real4_val
2295              (ffebld_cu_val_real4 (u)), expr);
2296           break;
2297 #endif
2298
2299         default:
2300           assert ("bad real kind type" == NULL);
2301           break;
2302         }
2303       break;
2304
2305     case FFEINFO_basictypeCOMPLEX:
2306       sz = FFETARGET_charactersizeNONE;
2307       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2308         {
2309 #if FFETARGET_okCOMPLEX1
2310         case FFEINFO_kindtypeREAL1:
2311           switch (ffeinfo_basictype (ffebld_info (l)))
2312             {
2313             case FFEINFO_basictypeINTEGER:
2314               switch (ffeinfo_kindtype (ffebld_info (l)))
2315                 {
2316 #if FFETARGET_okINTEGER1
2317                 case FFEINFO_kindtypeINTEGER1:
2318                   error = ffetarget_convert_complex1_integer1
2319                     (ffebld_cu_ptr_complex1 (u),
2320                      ffebld_constant_integer1 (ffebld_conter (l)));
2321                   break;
2322 #endif
2323
2324 #if FFETARGET_okINTEGER2
2325                 case FFEINFO_kindtypeINTEGER2:
2326                   error = ffetarget_convert_complex1_integer2
2327                     (ffebld_cu_ptr_complex1 (u),
2328                      ffebld_constant_integer2 (ffebld_conter (l)));
2329                   break;
2330 #endif
2331
2332 #if FFETARGET_okINTEGER3
2333                 case FFEINFO_kindtypeINTEGER3:
2334                   error = ffetarget_convert_complex1_integer3
2335                     (ffebld_cu_ptr_complex1 (u),
2336                      ffebld_constant_integer3 (ffebld_conter (l)));
2337                   break;
2338 #endif
2339
2340 #if FFETARGET_okINTEGER4
2341                 case FFEINFO_kindtypeINTEGER4:
2342                   error = ffetarget_convert_complex1_integer4
2343                     (ffebld_cu_ptr_complex1 (u),
2344                      ffebld_constant_integer4 (ffebld_conter (l)));
2345                   break;
2346 #endif
2347
2348                 default:
2349                   assert ("COMPLEX1/INTEGER bad source kind type" == NULL);
2350                   break;
2351                 }
2352               break;
2353
2354             case FFEINFO_basictypeREAL:
2355               switch (ffeinfo_kindtype (ffebld_info (l)))
2356                 {
2357 #if FFETARGET_okREAL1
2358                 case FFEINFO_kindtypeREAL1:
2359                   error = ffetarget_convert_complex1_real1
2360                     (ffebld_cu_ptr_complex1 (u),
2361                      ffebld_constant_real1 (ffebld_conter (l)));
2362                   break;
2363 #endif
2364
2365 #if FFETARGET_okREAL2
2366                 case FFEINFO_kindtypeREAL2:
2367                   error = ffetarget_convert_complex1_real2
2368                     (ffebld_cu_ptr_complex1 (u),
2369                      ffebld_constant_real2 (ffebld_conter (l)));
2370                   break;
2371 #endif
2372
2373 #if FFETARGET_okREAL3
2374                 case FFEINFO_kindtypeREAL3:
2375                   error = ffetarget_convert_complex1_real3
2376                     (ffebld_cu_ptr_complex1 (u),
2377                      ffebld_constant_real3 (ffebld_conter (l)));
2378                   break;
2379 #endif
2380
2381 #if FFETARGET_okREAL4
2382                 case FFEINFO_kindtypeREAL4:
2383                   error = ffetarget_convert_complex1_real4
2384                     (ffebld_cu_ptr_complex1 (u),
2385                      ffebld_constant_real4 (ffebld_conter (l)));
2386                   break;
2387 #endif
2388
2389                 default:
2390                   assert ("COMPLEX1/REAL bad source kind type" == NULL);
2391                   break;
2392                 }
2393               break;
2394
2395             case FFEINFO_basictypeCOMPLEX:
2396               switch (ffeinfo_kindtype (ffebld_info (l)))
2397                 {
2398 #if FFETARGET_okCOMPLEX2
2399                 case FFEINFO_kindtypeREAL2:
2400                   error = ffetarget_convert_complex1_complex2
2401                     (ffebld_cu_ptr_complex1 (u),
2402                      ffebld_constant_complex2 (ffebld_conter (l)));
2403                   break;
2404 #endif
2405
2406 #if FFETARGET_okCOMPLEX3
2407                 case FFEINFO_kindtypeREAL3:
2408                   error = ffetarget_convert_complex1_complex3
2409                     (ffebld_cu_ptr_complex1 (u),
2410                      ffebld_constant_complex3 (ffebld_conter (l)));
2411                   break;
2412 #endif
2413
2414 #if FFETARGET_okCOMPLEX4
2415                 case FFEINFO_kindtypeREAL4:
2416                   error = ffetarget_convert_complex1_complex4
2417                     (ffebld_cu_ptr_complex1 (u),
2418                      ffebld_constant_complex4 (ffebld_conter (l)));
2419                   break;
2420 #endif
2421
2422                 default:
2423                   assert ("COMPLEX1/COMPLEX bad source kind type" == NULL);
2424                   break;
2425                 }
2426               break;
2427
2428             case FFEINFO_basictypeCHARACTER:
2429               error = ffetarget_convert_complex1_character1
2430                 (ffebld_cu_ptr_complex1 (u),
2431                  ffebld_constant_character1 (ffebld_conter (l)));
2432               break;
2433
2434             case FFEINFO_basictypeHOLLERITH:
2435               error = ffetarget_convert_complex1_hollerith
2436                 (ffebld_cu_ptr_complex1 (u),
2437                  ffebld_constant_hollerith (ffebld_conter (l)));
2438               break;
2439
2440             case FFEINFO_basictypeTYPELESS:
2441               error = ffetarget_convert_complex1_typeless
2442                 (ffebld_cu_ptr_complex1 (u),
2443                  ffebld_constant_typeless (ffebld_conter (l)));
2444               break;
2445
2446             default:
2447               assert ("COMPLEX1 bad type" == NULL);
2448               break;
2449             }
2450
2451           /* If conversion operation is not implemented, return original expr.  */
2452           if (error == FFEBAD_NOCANDO)
2453             return expr;
2454
2455           expr = ffebld_new_conter_with_orig
2456             (ffebld_constant_new_complex1_val
2457              (ffebld_cu_val_complex1 (u)), expr);
2458           break;
2459 #endif
2460
2461 #if FFETARGET_okCOMPLEX2
2462         case FFEINFO_kindtypeREAL2:
2463           switch (ffeinfo_basictype (ffebld_info (l)))
2464             {
2465             case FFEINFO_basictypeINTEGER:
2466               switch (ffeinfo_kindtype (ffebld_info (l)))
2467                 {
2468 #if FFETARGET_okINTEGER1
2469                 case FFEINFO_kindtypeINTEGER1:
2470                   error = ffetarget_convert_complex2_integer1
2471                     (ffebld_cu_ptr_complex2 (u),
2472                      ffebld_constant_integer1 (ffebld_conter (l)));
2473                   break;
2474 #endif
2475
2476 #if FFETARGET_okINTEGER2
2477                 case FFEINFO_kindtypeINTEGER2:
2478                   error = ffetarget_convert_complex2_integer2
2479                     (ffebld_cu_ptr_complex2 (u),
2480                      ffebld_constant_integer2 (ffebld_conter (l)));
2481                   break;
2482 #endif
2483
2484 #if FFETARGET_okINTEGER3
2485                 case FFEINFO_kindtypeINTEGER3:
2486                   error = ffetarget_convert_complex2_integer3
2487                     (ffebld_cu_ptr_complex2 (u),
2488                      ffebld_constant_integer3 (ffebld_conter (l)));
2489                   break;
2490 #endif
2491
2492 #if FFETARGET_okINTEGER4
2493                 case FFEINFO_kindtypeINTEGER4:
2494                   error = ffetarget_convert_complex2_integer4
2495                     (ffebld_cu_ptr_complex2 (u),
2496                      ffebld_constant_integer4 (ffebld_conter (l)));
2497                   break;
2498 #endif
2499
2500                 default:
2501                   assert ("COMPLEX2/INTEGER bad source kind type" == NULL);
2502                   break;
2503                 }
2504               break;
2505
2506             case FFEINFO_basictypeREAL:
2507               switch (ffeinfo_kindtype (ffebld_info (l)))
2508                 {
2509 #if FFETARGET_okREAL1
2510                 case FFEINFO_kindtypeREAL1:
2511                   error = ffetarget_convert_complex2_real1
2512                     (ffebld_cu_ptr_complex2 (u),
2513                      ffebld_constant_real1 (ffebld_conter (l)));
2514                   break;
2515 #endif
2516
2517 #if FFETARGET_okREAL2
2518                 case FFEINFO_kindtypeREAL2:
2519                   error = ffetarget_convert_complex2_real2
2520                     (ffebld_cu_ptr_complex2 (u),
2521                      ffebld_constant_real2 (ffebld_conter (l)));
2522                   break;
2523 #endif
2524
2525 #if FFETARGET_okREAL3
2526                 case FFEINFO_kindtypeREAL3:
2527                   error = ffetarget_convert_complex2_real3
2528                     (ffebld_cu_ptr_complex2 (u),
2529                      ffebld_constant_real3 (ffebld_conter (l)));
2530                   break;
2531 #endif
2532
2533 #if FFETARGET_okREAL4
2534                 case FFEINFO_kindtypeREAL4:
2535                   error = ffetarget_convert_complex2_real4
2536                     (ffebld_cu_ptr_complex2 (u),
2537                      ffebld_constant_real4 (ffebld_conter (l)));
2538                   break;
2539 #endif
2540
2541                 default:
2542                   assert ("COMPLEX2/REAL bad source kind type" == NULL);
2543                   break;
2544                 }
2545               break;
2546
2547             case FFEINFO_basictypeCOMPLEX:
2548               switch (ffeinfo_kindtype (ffebld_info (l)))
2549                 {
2550 #if FFETARGET_okCOMPLEX1
2551                 case FFEINFO_kindtypeREAL1:
2552                   error = ffetarget_convert_complex2_complex1
2553                     (ffebld_cu_ptr_complex2 (u),
2554                      ffebld_constant_complex1 (ffebld_conter (l)));
2555                   break;
2556 #endif
2557
2558 #if FFETARGET_okCOMPLEX3
2559                 case FFEINFO_kindtypeREAL3:
2560                   error = ffetarget_convert_complex2_complex3
2561                     (ffebld_cu_ptr_complex2 (u),
2562                      ffebld_constant_complex3 (ffebld_conter (l)));
2563                   break;
2564 #endif
2565
2566 #if FFETARGET_okCOMPLEX4
2567                 case FFEINFO_kindtypeREAL4:
2568                   error = ffetarget_convert_complex2_complex4
2569                     (ffebld_cu_ptr_complex2 (u),
2570                      ffebld_constant_complex4 (ffebld_conter (l)));
2571                   break;
2572 #endif
2573
2574                 default:
2575                   assert ("COMPLEX2/COMPLEX bad source kind type" == NULL);
2576                   break;
2577                 }
2578               break;
2579
2580             case FFEINFO_basictypeCHARACTER:
2581               error = ffetarget_convert_complex2_character1
2582                 (ffebld_cu_ptr_complex2 (u),
2583                  ffebld_constant_character1 (ffebld_conter (l)));
2584               break;
2585
2586             case FFEINFO_basictypeHOLLERITH:
2587               error = ffetarget_convert_complex2_hollerith
2588                 (ffebld_cu_ptr_complex2 (u),
2589                  ffebld_constant_hollerith (ffebld_conter (l)));
2590               break;
2591
2592             case FFEINFO_basictypeTYPELESS:
2593               error = ffetarget_convert_complex2_typeless
2594                 (ffebld_cu_ptr_complex2 (u),
2595                  ffebld_constant_typeless (ffebld_conter (l)));
2596               break;
2597
2598             default:
2599               assert ("COMPLEX2 bad type" == NULL);
2600               break;
2601             }
2602
2603           /* If conversion operation is not implemented, return original expr.  */
2604           if (error == FFEBAD_NOCANDO)
2605             return expr;
2606
2607           expr = ffebld_new_conter_with_orig
2608             (ffebld_constant_new_complex2_val
2609              (ffebld_cu_val_complex2 (u)), expr);
2610           break;
2611 #endif
2612
2613 #if FFETARGET_okCOMPLEX3
2614         case FFEINFO_kindtypeREAL3:
2615           switch (ffeinfo_basictype (ffebld_info (l)))
2616             {
2617             case FFEINFO_basictypeINTEGER:
2618               switch (ffeinfo_kindtype (ffebld_info (l)))
2619                 {
2620 #if FFETARGET_okINTEGER1
2621                 case FFEINFO_kindtypeINTEGER1:
2622                   error = ffetarget_convert_complex3_integer1
2623                     (ffebld_cu_ptr_complex3 (u),
2624                      ffebld_constant_integer1 (ffebld_conter (l)));
2625                   break;
2626 #endif
2627
2628 #if FFETARGET_okINTEGER2
2629                 case FFEINFO_kindtypeINTEGER2:
2630                   error = ffetarget_convert_complex3_integer2
2631                     (ffebld_cu_ptr_complex3 (u),
2632                      ffebld_constant_integer2 (ffebld_conter (l)));
2633                   break;
2634 #endif
2635
2636 #if FFETARGET_okINTEGER3
2637                 case FFEINFO_kindtypeINTEGER3:
2638                   error = ffetarget_convert_complex3_integer3
2639                     (ffebld_cu_ptr_complex3 (u),
2640                      ffebld_constant_integer3 (ffebld_conter (l)));
2641                   break;
2642 #endif
2643
2644 #if FFETARGET_okINTEGER4
2645                 case FFEINFO_kindtypeINTEGER4:
2646                   error = ffetarget_convert_complex3_integer4
2647                     (ffebld_cu_ptr_complex3 (u),
2648                      ffebld_constant_integer4 (ffebld_conter (l)));
2649                   break;
2650 #endif
2651
2652                 default:
2653                   assert ("COMPLEX3/INTEGER bad source kind type" == NULL);
2654                   break;
2655                 }
2656               break;
2657
2658             case FFEINFO_basictypeREAL:
2659               switch (ffeinfo_kindtype (ffebld_info (l)))
2660                 {
2661 #if FFETARGET_okREAL1
2662                 case FFEINFO_kindtypeREAL1:
2663                   error = ffetarget_convert_complex3_real1
2664                     (ffebld_cu_ptr_complex3 (u),
2665                      ffebld_constant_real1 (ffebld_conter (l)));
2666                   break;
2667 #endif
2668
2669 #if FFETARGET_okREAL2
2670                 case FFEINFO_kindtypeREAL2:
2671                   error = ffetarget_convert_complex3_real2
2672                     (ffebld_cu_ptr_complex3 (u),
2673                      ffebld_constant_real2 (ffebld_conter (l)));
2674                   break;
2675 #endif
2676
2677 #if FFETARGET_okREAL3
2678                 case FFEINFO_kindtypeREAL3:
2679                   error = ffetarget_convert_complex3_real3
2680                     (ffebld_cu_ptr_complex3 (u),
2681                      ffebld_constant_real3 (ffebld_conter (l)));
2682                   break;
2683 #endif
2684
2685 #if FFETARGET_okREAL4
2686                 case FFEINFO_kindtypeREAL4:
2687                   error = ffetarget_convert_complex3_real4
2688                     (ffebld_cu_ptr_complex3 (u),
2689                      ffebld_constant_real4 (ffebld_conter (l)));
2690                   break;
2691 #endif
2692
2693                 default:
2694                   assert ("COMPLEX3/REAL bad source kind type" == NULL);
2695                   break;
2696                 }
2697               break;
2698
2699             case FFEINFO_basictypeCOMPLEX:
2700               switch (ffeinfo_kindtype (ffebld_info (l)))
2701                 {
2702 #if FFETARGET_okCOMPLEX1
2703                 case FFEINFO_kindtypeREAL1:
2704                   error = ffetarget_convert_complex3_complex1
2705                     (ffebld_cu_ptr_complex3 (u),
2706                      ffebld_constant_complex1 (ffebld_conter (l)));
2707                   break;
2708 #endif
2709
2710 #if FFETARGET_okCOMPLEX2
2711                 case FFEINFO_kindtypeREAL2:
2712                   error = ffetarget_convert_complex3_complex2
2713                     (ffebld_cu_ptr_complex3 (u),
2714                      ffebld_constant_complex2 (ffebld_conter (l)));
2715                   break;
2716 #endif
2717
2718 #if FFETARGET_okCOMPLEX4
2719                 case FFEINFO_kindtypeREAL4:
2720                   error = ffetarget_convert_complex3_complex4
2721                     (ffebld_cu_ptr_complex3 (u),
2722                      ffebld_constant_complex4 (ffebld_conter (l)));
2723                   break;
2724 #endif
2725
2726                 default:
2727                   assert ("COMPLEX3/COMPLEX bad source kind type" == NULL);
2728                   break;
2729                 }
2730               break;
2731
2732             case FFEINFO_basictypeCHARACTER:
2733               error = ffetarget_convert_complex3_character1
2734                 (ffebld_cu_ptr_complex3 (u),
2735                  ffebld_constant_character1 (ffebld_conter (l)));
2736               break;
2737
2738             case FFEINFO_basictypeHOLLERITH:
2739               error = ffetarget_convert_complex3_hollerith
2740                 (ffebld_cu_ptr_complex3 (u),
2741                  ffebld_constant_hollerith (ffebld_conter (l)));
2742               break;
2743
2744             case FFEINFO_basictypeTYPELESS:
2745               error = ffetarget_convert_complex3_typeless
2746                 (ffebld_cu_ptr_complex3 (u),
2747                  ffebld_constant_typeless (ffebld_conter (l)));
2748               break;
2749
2750             default:
2751               assert ("COMPLEX3 bad type" == NULL);
2752               break;
2753             }
2754
2755           /* If conversion operation is not implemented, return original expr.  */
2756           if (error == FFEBAD_NOCANDO)
2757             return expr;
2758
2759           expr = ffebld_new_conter_with_orig
2760             (ffebld_constant_new_complex3_val
2761              (ffebld_cu_val_complex3 (u)), expr);
2762           break;
2763 #endif
2764
2765 #if FFETARGET_okCOMPLEX4
2766         case FFEINFO_kindtypeREAL4:
2767           switch (ffeinfo_basictype (ffebld_info (l)))
2768             {
2769             case FFEINFO_basictypeINTEGER:
2770               switch (ffeinfo_kindtype (ffebld_info (l)))
2771                 {
2772 #if FFETARGET_okINTEGER1
2773                 case FFEINFO_kindtypeINTEGER1:
2774                   error = ffetarget_convert_complex4_integer1
2775                     (ffebld_cu_ptr_complex4 (u),
2776                      ffebld_constant_integer1 (ffebld_conter (l)));
2777                   break;
2778 #endif
2779
2780 #if FFETARGET_okINTEGER2
2781                 case FFEINFO_kindtypeINTEGER2:
2782                   error = ffetarget_convert_complex4_integer2
2783                     (ffebld_cu_ptr_complex4 (u),
2784                      ffebld_constant_integer2 (ffebld_conter (l)));
2785                   break;
2786 #endif
2787
2788 #if FFETARGET_okINTEGER3
2789                 case FFEINFO_kindtypeINTEGER3:
2790                   error = ffetarget_convert_complex4_integer3
2791                     (ffebld_cu_ptr_complex4 (u),
2792                      ffebld_constant_integer3 (ffebld_conter (l)));
2793                   break;
2794 #endif
2795
2796 #if FFETARGET_okINTEGER4
2797                 case FFEINFO_kindtypeINTEGER4:
2798                   error = ffetarget_convert_complex4_integer4
2799                     (ffebld_cu_ptr_complex4 (u),
2800                      ffebld_constant_integer4 (ffebld_conter (l)));
2801                   break;
2802 #endif
2803
2804                 default:
2805                   assert ("COMPLEX4/INTEGER bad source kind type" == NULL);
2806                   break;
2807                 }
2808               break;
2809
2810             case FFEINFO_basictypeREAL:
2811               switch (ffeinfo_kindtype (ffebld_info (l)))
2812                 {
2813 #if FFETARGET_okREAL1
2814                 case FFEINFO_kindtypeREAL1:
2815                   error = ffetarget_convert_complex4_real1
2816                     (ffebld_cu_ptr_complex4 (u),
2817                      ffebld_constant_real1 (ffebld_conter (l)));
2818                   break;
2819 #endif
2820
2821 #if FFETARGET_okREAL2
2822                 case FFEINFO_kindtypeREAL2:
2823                   error = ffetarget_convert_complex4_real2
2824                     (ffebld_cu_ptr_complex4 (u),
2825                      ffebld_constant_real2 (ffebld_conter (l)));
2826                   break;
2827 #endif
2828
2829 #if FFETARGET_okREAL3
2830                 case FFEINFO_kindtypeREAL3:
2831                   error = ffetarget_convert_complex4_real3
2832                     (ffebld_cu_ptr_complex4 (u),
2833                      ffebld_constant_real3 (ffebld_conter (l)));
2834                   break;
2835 #endif
2836
2837 #if FFETARGET_okREAL4
2838                 case FFEINFO_kindtypeREAL4:
2839                   error = ffetarget_convert_complex4_real4
2840                     (ffebld_cu_ptr_complex4 (u),
2841                      ffebld_constant_real4 (ffebld_conter (l)));
2842                   break;
2843 #endif
2844
2845                 default:
2846                   assert ("COMPLEX4/REAL bad source kind type" == NULL);
2847                   break;
2848                 }
2849               break;
2850
2851             case FFEINFO_basictypeCOMPLEX:
2852               switch (ffeinfo_kindtype (ffebld_info (l)))
2853                 {
2854 #if FFETARGET_okCOMPLEX1
2855                 case FFEINFO_kindtypeREAL1:
2856                   error = ffetarget_convert_complex4_complex1
2857                     (ffebld_cu_ptr_complex4 (u),
2858                      ffebld_constant_complex1 (ffebld_conter (l)));
2859                   break;
2860 #endif
2861
2862 #if FFETARGET_okCOMPLEX2
2863                 case FFEINFO_kindtypeREAL2:
2864                   error = ffetarget_convert_complex4_complex2
2865                     (ffebld_cu_ptr_complex4 (u),
2866                      ffebld_constant_complex2 (ffebld_conter (l)));
2867                   break;
2868 #endif
2869
2870 #if FFETARGET_okCOMPLEX3
2871                 case FFEINFO_kindtypeREAL3:
2872                   error = ffetarget_convert_complex4_complex3
2873                     (ffebld_cu_ptr_complex4 (u),
2874                      ffebld_constant_complex3 (ffebld_conter (l)));
2875                   break;
2876 #endif
2877
2878                 default:
2879                   assert ("COMPLEX4/COMPLEX bad source kind type" == NULL);
2880                   break;
2881                 }
2882               break;
2883
2884             case FFEINFO_basictypeCHARACTER:
2885               error = ffetarget_convert_complex4_character1
2886                 (ffebld_cu_ptr_complex4 (u),
2887                  ffebld_constant_character1 (ffebld_conter (l)));
2888               break;
2889
2890             case FFEINFO_basictypeHOLLERITH:
2891               error = ffetarget_convert_complex4_hollerith
2892                 (ffebld_cu_ptr_complex4 (u),
2893                  ffebld_constant_hollerith (ffebld_conter (l)));
2894               break;
2895
2896             case FFEINFO_basictypeTYPELESS:
2897               error = ffetarget_convert_complex4_typeless
2898                 (ffebld_cu_ptr_complex4 (u),
2899                  ffebld_constant_typeless (ffebld_conter (l)));
2900               break;
2901
2902             default:
2903               assert ("COMPLEX4 bad type" == NULL);
2904               break;
2905             }
2906
2907           /* If conversion operation is not implemented, return original expr.  */
2908           if (error == FFEBAD_NOCANDO)
2909             return expr;
2910
2911           expr = ffebld_new_conter_with_orig
2912             (ffebld_constant_new_complex4_val
2913              (ffebld_cu_val_complex4 (u)), expr);
2914           break;
2915 #endif
2916
2917         default:
2918           assert ("bad complex kind type" == NULL);
2919           break;
2920         }
2921       break;
2922
2923     case FFEINFO_basictypeCHARACTER:
2924       if ((sz = ffebld_size (expr)) == FFETARGET_charactersizeNONE)
2925         return expr;
2926       kt = ffeinfo_kindtype (ffebld_info (expr));
2927       switch (kt)
2928         {
2929 #if FFETARGET_okCHARACTER1
2930         case FFEINFO_kindtypeCHARACTER1:
2931           switch (ffeinfo_basictype (ffebld_info (l)))
2932             {
2933             case FFEINFO_basictypeCHARACTER:
2934               if ((sz2 = ffebld_size (l)) == FFETARGET_charactersizeNONE)
2935                 return expr;
2936               assert (kt == ffeinfo_kindtype (ffebld_info (l)));
2937               assert (sz2 == ffetarget_length_character1
2938                       (ffebld_constant_character1
2939                        (ffebld_conter (l))));
2940               error
2941                 = ffetarget_convert_character1_character1
2942                 (ffebld_cu_ptr_character1 (u), sz,
2943                  ffebld_constant_character1 (ffebld_conter (l)),
2944                  ffebld_constant_pool ());
2945               break;
2946
2947             case FFEINFO_basictypeINTEGER:
2948               switch (ffeinfo_kindtype (ffebld_info (l)))
2949                 {
2950 #if FFETARGET_okINTEGER1
2951                 case FFEINFO_kindtypeINTEGER1:
2952                   error
2953                     = ffetarget_convert_character1_integer1
2954                       (ffebld_cu_ptr_character1 (u),
2955                        sz,
2956                        ffebld_constant_integer1 (ffebld_conter (l)),
2957                        ffebld_constant_pool ());
2958                   break;
2959 #endif
2960
2961 #if FFETARGET_okINTEGER2
2962                 case FFEINFO_kindtypeINTEGER2:
2963                   error
2964                     = ffetarget_convert_character1_integer2
2965                       (ffebld_cu_ptr_character1 (u),
2966                        sz,
2967                        ffebld_constant_integer2 (ffebld_conter (l)),
2968                        ffebld_constant_pool ());
2969                   break;
2970 #endif
2971
2972 #if FFETARGET_okINTEGER3
2973                 case FFEINFO_kindtypeINTEGER3:
2974                   error
2975                     = ffetarget_convert_character1_integer3
2976                       (ffebld_cu_ptr_character1 (u),
2977                        sz,
2978                        ffebld_constant_integer3 (ffebld_conter (l)),
2979                        ffebld_constant_pool ());
2980                   break;
2981 #endif
2982
2983 #if FFETARGET_okINTEGER4
2984                 case FFEINFO_kindtypeINTEGER4:
2985                   error
2986                     = ffetarget_convert_character1_integer4
2987                       (ffebld_cu_ptr_character1 (u),
2988                        sz,
2989                        ffebld_constant_integer4 (ffebld_conter (l)),
2990                        ffebld_constant_pool ());
2991                   break;
2992 #endif
2993
2994                 default:
2995                   assert ("CHARACTER1/INTEGER bad source kind type" == NULL);
2996                   break;
2997                 }
2998               break;
2999
3000             case FFEINFO_basictypeLOGICAL:
3001               switch (ffeinfo_kindtype (ffebld_info (l)))
3002                 {
3003 #if FFETARGET_okLOGICAL1
3004                 case FFEINFO_kindtypeLOGICAL1:
3005                   error
3006                     = ffetarget_convert_character1_logical1
3007                       (ffebld_cu_ptr_character1 (u),
3008                        sz,
3009                        ffebld_constant_logical1 (ffebld_conter (l)),
3010                        ffebld_constant_pool ());
3011                   break;
3012 #endif
3013
3014 #if FFETARGET_okLOGICAL2
3015                 case FFEINFO_kindtypeLOGICAL2:
3016                   error
3017                     = ffetarget_convert_character1_logical2
3018                       (ffebld_cu_ptr_character1 (u),
3019                        sz,
3020                        ffebld_constant_logical2 (ffebld_conter (l)),
3021                        ffebld_constant_pool ());
3022                   break;
3023 #endif
3024
3025 #if FFETARGET_okLOGICAL3
3026                 case FFEINFO_kindtypeLOGICAL3:
3027                   error
3028                     = ffetarget_convert_character1_logical3
3029                       (ffebld_cu_ptr_character1 (u),
3030                        sz,
3031                        ffebld_constant_logical3 (ffebld_conter (l)),
3032                        ffebld_constant_pool ());
3033                   break;
3034 #endif
3035
3036 #if FFETARGET_okLOGICAL4
3037                 case FFEINFO_kindtypeLOGICAL4:
3038                   error
3039                     = ffetarget_convert_character1_logical4
3040                       (ffebld_cu_ptr_character1 (u),
3041                        sz,
3042                        ffebld_constant_logical4 (ffebld_conter (l)),
3043                        ffebld_constant_pool ());
3044                   break;
3045 #endif
3046
3047                 default:
3048                   assert ("CHARACTER1/LOGICAL bad source kind type" == NULL);
3049                   break;
3050                 }
3051               break;
3052
3053             case FFEINFO_basictypeHOLLERITH:
3054               error
3055                 = ffetarget_convert_character1_hollerith
3056                 (ffebld_cu_ptr_character1 (u),
3057                  sz,
3058                  ffebld_constant_hollerith (ffebld_conter (l)),
3059                  ffebld_constant_pool ());
3060               break;
3061
3062             case FFEINFO_basictypeTYPELESS:
3063               error
3064                 = ffetarget_convert_character1_typeless
3065                 (ffebld_cu_ptr_character1 (u),
3066                  sz,
3067                  ffebld_constant_typeless (ffebld_conter (l)),
3068                  ffebld_constant_pool ());
3069               break;
3070
3071             default:
3072               assert ("CHARACTER1 bad type" == NULL);
3073             }
3074
3075           expr
3076             = ffebld_new_conter_with_orig
3077             (ffebld_constant_new_character1_val
3078              (ffebld_cu_val_character1 (u)),
3079              expr);
3080           break;
3081 #endif
3082
3083         default:
3084           assert ("bad character kind type" == NULL);
3085           break;
3086         }
3087       break;
3088
3089     default:
3090       assert ("bad type" == NULL);
3091       return expr;
3092     }
3093
3094   ffebld_set_info (expr, ffeinfo_new
3095                    (bt,
3096                     kt,
3097                     0,
3098                     FFEINFO_kindENTITY,
3099                     FFEINFO_whereCONSTANT,
3100                     sz));
3101
3102   if ((error != FFEBAD)
3103       && ffebad_start (error))
3104     {
3105       assert (t != NULL);
3106       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3107       ffebad_finish ();
3108     }
3109
3110   return expr;
3111 }
3112
3113 /* ffeexpr_collapse_paren -- Collapse paren expr
3114
3115    ffebld expr;
3116    ffelexToken token;
3117    expr = ffeexpr_collapse_paren(expr,token);
3118
3119    If the result of the expr is a constant, replaces the expr with the
3120    computed constant.  */
3121
3122 ffebld
3123 ffeexpr_collapse_paren (ffebld expr, ffelexToken t UNUSED)
3124 {
3125   ffebld r;
3126   ffeinfoBasictype bt;
3127   ffeinfoKindtype kt;
3128   ffetargetCharacterSize len;
3129
3130   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3131     return expr;
3132
3133   r = ffebld_left (expr);
3134
3135   if (ffebld_op (r) != FFEBLD_opCONTER)
3136     return expr;
3137
3138   bt = ffeinfo_basictype (ffebld_info (r));
3139   kt = ffeinfo_kindtype (ffebld_info (r));
3140   len = ffebld_size (r);
3141
3142   expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
3143                                       expr);
3144
3145   ffebld_set_info (expr, ffeinfo_new
3146                    (bt,
3147                     kt,
3148                     0,
3149                     FFEINFO_kindENTITY,
3150                     FFEINFO_whereCONSTANT,
3151                     len));
3152
3153   return expr;
3154 }
3155
3156 /* ffeexpr_collapse_uplus -- Collapse uplus expr
3157
3158    ffebld expr;
3159    ffelexToken token;
3160    expr = ffeexpr_collapse_uplus(expr,token);
3161
3162    If the result of the expr is a constant, replaces the expr with the
3163    computed constant.  */
3164
3165 ffebld
3166 ffeexpr_collapse_uplus (ffebld expr, ffelexToken t UNUSED)
3167 {
3168   ffebld r;
3169   ffeinfoBasictype bt;
3170   ffeinfoKindtype kt;
3171   ffetargetCharacterSize len;
3172
3173   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3174     return expr;
3175
3176   r = ffebld_left (expr);
3177
3178   if (ffebld_op (r) != FFEBLD_opCONTER)
3179     return expr;
3180
3181   bt = ffeinfo_basictype (ffebld_info (r));
3182   kt = ffeinfo_kindtype (ffebld_info (r));
3183   len = ffebld_size (r);
3184
3185   expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
3186                                       expr);
3187
3188   ffebld_set_info (expr, ffeinfo_new
3189                    (bt,
3190                     kt,
3191                     0,
3192                     FFEINFO_kindENTITY,
3193                     FFEINFO_whereCONSTANT,
3194                     len));
3195
3196   return expr;
3197 }
3198
3199 /* ffeexpr_collapse_uminus -- Collapse uminus expr
3200
3201    ffebld expr;
3202    ffelexToken token;
3203    expr = ffeexpr_collapse_uminus(expr,token);
3204
3205    If the result of the expr is a constant, replaces the expr with the
3206    computed constant.  */
3207
3208 ffebld
3209 ffeexpr_collapse_uminus (ffebld expr, ffelexToken t)
3210 {
3211   ffebad error = FFEBAD;
3212   ffebld r;
3213   ffebldConstantUnion u;
3214   ffeinfoBasictype bt;
3215   ffeinfoKindtype kt;
3216
3217   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3218     return expr;
3219
3220   r = ffebld_left (expr);
3221
3222   if (ffebld_op (r) != FFEBLD_opCONTER)
3223     return expr;
3224
3225   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3226     {
3227     case FFEINFO_basictypeANY:
3228       return expr;
3229
3230     case FFEINFO_basictypeINTEGER:
3231       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3232         {
3233 #if FFETARGET_okINTEGER1
3234         case FFEINFO_kindtypeINTEGER1:
3235           error = ffetarget_uminus_integer1 (ffebld_cu_ptr_integer1 (u),
3236                               ffebld_constant_integer1 (ffebld_conter (r)));
3237           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3238                                         (ffebld_cu_val_integer1 (u)), expr);
3239           break;
3240 #endif
3241
3242 #if FFETARGET_okINTEGER2
3243         case FFEINFO_kindtypeINTEGER2:
3244           error = ffetarget_uminus_integer2 (ffebld_cu_ptr_integer2 (u),
3245                               ffebld_constant_integer2 (ffebld_conter (r)));
3246           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3247                                         (ffebld_cu_val_integer2 (u)), expr);
3248           break;
3249 #endif
3250
3251 #if FFETARGET_okINTEGER3
3252         case FFEINFO_kindtypeINTEGER3:
3253           error = ffetarget_uminus_integer3 (ffebld_cu_ptr_integer3 (u),
3254                               ffebld_constant_integer3 (ffebld_conter (r)));
3255           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3256                                         (ffebld_cu_val_integer3 (u)), expr);
3257           break;
3258 #endif
3259
3260 #if FFETARGET_okINTEGER4
3261         case FFEINFO_kindtypeINTEGER4:
3262           error = ffetarget_uminus_integer4 (ffebld_cu_ptr_integer4 (u),
3263                               ffebld_constant_integer4 (ffebld_conter (r)));
3264           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3265                                         (ffebld_cu_val_integer4 (u)), expr);
3266           break;
3267 #endif
3268
3269         default:
3270           assert ("bad integer kind type" == NULL);
3271           break;
3272         }
3273       break;
3274
3275     case FFEINFO_basictypeREAL:
3276       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3277         {
3278 #if FFETARGET_okREAL1
3279         case FFEINFO_kindtypeREAL1:
3280           error = ffetarget_uminus_real1 (ffebld_cu_ptr_real1 (u),
3281                                  ffebld_constant_real1 (ffebld_conter (r)));
3282           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3283                                            (ffebld_cu_val_real1 (u)), expr);
3284           break;
3285 #endif
3286
3287 #if FFETARGET_okREAL2
3288         case FFEINFO_kindtypeREAL2:
3289           error = ffetarget_uminus_real2 (ffebld_cu_ptr_real2 (u),
3290                                  ffebld_constant_real2 (ffebld_conter (r)));
3291           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3292                                            (ffebld_cu_val_real2 (u)), expr);
3293           break;
3294 #endif
3295
3296 #if FFETARGET_okREAL3
3297         case FFEINFO_kindtypeREAL3:
3298           error = ffetarget_uminus_real3 (ffebld_cu_ptr_real3 (u),
3299                                  ffebld_constant_real3 (ffebld_conter (r)));
3300           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3301                                            (ffebld_cu_val_real3 (u)), expr);
3302           break;
3303 #endif
3304
3305 #if FFETARGET_okREAL4
3306         case FFEINFO_kindtypeREAL4:
3307           error = ffetarget_uminus_real4 (ffebld_cu_ptr_real4 (u),
3308                                  ffebld_constant_real4 (ffebld_conter (r)));
3309           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
3310                                            (ffebld_cu_val_real4 (u)), expr);
3311           break;
3312 #endif
3313
3314         default:
3315           assert ("bad real kind type" == NULL);
3316           break;
3317         }
3318       break;
3319
3320     case FFEINFO_basictypeCOMPLEX:
3321       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3322         {
3323 #if FFETARGET_okCOMPLEX1
3324         case FFEINFO_kindtypeREAL1:
3325           error = ffetarget_uminus_complex1 (ffebld_cu_ptr_complex1 (u),
3326                               ffebld_constant_complex1 (ffebld_conter (r)));
3327           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3328                                         (ffebld_cu_val_complex1 (u)), expr);
3329           break;
3330 #endif
3331
3332 #if FFETARGET_okCOMPLEX2
3333         case FFEINFO_kindtypeREAL2:
3334           error = ffetarget_uminus_complex2 (ffebld_cu_ptr_complex2 (u),
3335                               ffebld_constant_complex2 (ffebld_conter (r)));
3336           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3337                                         (ffebld_cu_val_complex2 (u)), expr);
3338           break;
3339 #endif
3340
3341 #if FFETARGET_okCOMPLEX3
3342         case FFEINFO_kindtypeREAL3:
3343           error = ffetarget_uminus_complex3 (ffebld_cu_ptr_complex3 (u),
3344                               ffebld_constant_complex3 (ffebld_conter (r)));
3345           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3346                                         (ffebld_cu_val_complex3 (u)), expr);
3347           break;
3348 #endif
3349
3350 #if FFETARGET_okCOMPLEX4
3351         case FFEINFO_kindtypeREAL4:
3352           error = ffetarget_uminus_complex4 (ffebld_cu_ptr_complex4 (u),
3353                               ffebld_constant_complex4 (ffebld_conter (r)));
3354           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
3355                                         (ffebld_cu_val_complex4 (u)), expr);
3356           break;
3357 #endif
3358
3359         default:
3360           assert ("bad complex kind type" == NULL);
3361           break;
3362         }
3363       break;
3364
3365     default:
3366       assert ("bad type" == NULL);
3367       return expr;
3368     }
3369
3370   ffebld_set_info (expr, ffeinfo_new
3371                    (bt,
3372                     kt,
3373                     0,
3374                     FFEINFO_kindENTITY,
3375                     FFEINFO_whereCONSTANT,
3376                     FFETARGET_charactersizeNONE));
3377
3378   if ((error != FFEBAD)
3379       && ffebad_start (error))
3380     {
3381       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3382       ffebad_finish ();
3383     }
3384
3385   return expr;
3386 }
3387
3388 /* ffeexpr_collapse_not -- Collapse not expr
3389
3390    ffebld expr;
3391    ffelexToken token;
3392    expr = ffeexpr_collapse_not(expr,token);
3393
3394    If the result of the expr is a constant, replaces the expr with the
3395    computed constant.  */
3396
3397 ffebld
3398 ffeexpr_collapse_not (ffebld expr, ffelexToken t)
3399 {
3400   ffebad error = FFEBAD;
3401   ffebld r;
3402   ffebldConstantUnion u;
3403   ffeinfoBasictype bt;
3404   ffeinfoKindtype kt;
3405
3406   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3407     return expr;
3408
3409   r = ffebld_left (expr);
3410
3411   if (ffebld_op (r) != FFEBLD_opCONTER)
3412     return expr;
3413
3414   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3415     {
3416     case FFEINFO_basictypeANY:
3417       return expr;
3418
3419     case FFEINFO_basictypeINTEGER:
3420       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3421         {
3422 #if FFETARGET_okINTEGER1
3423         case FFEINFO_kindtypeINTEGER1:
3424           error = ffetarget_not_integer1 (ffebld_cu_ptr_integer1 (u),
3425                               ffebld_constant_integer1 (ffebld_conter (r)));
3426           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3427                                         (ffebld_cu_val_integer1 (u)), expr);
3428           break;
3429 #endif
3430
3431 #if FFETARGET_okINTEGER2
3432         case FFEINFO_kindtypeINTEGER2:
3433           error = ffetarget_not_integer2 (ffebld_cu_ptr_integer2 (u),
3434                               ffebld_constant_integer2 (ffebld_conter (r)));
3435           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3436                                         (ffebld_cu_val_integer2 (u)), expr);
3437           break;
3438 #endif
3439
3440 #if FFETARGET_okINTEGER3
3441         case FFEINFO_kindtypeINTEGER3:
3442           error = ffetarget_not_integer3 (ffebld_cu_ptr_integer3 (u),
3443                               ffebld_constant_integer3 (ffebld_conter (r)));
3444           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3445                                         (ffebld_cu_val_integer3 (u)), expr);
3446           break;
3447 #endif
3448
3449 #if FFETARGET_okINTEGER4
3450         case FFEINFO_kindtypeINTEGER4:
3451           error = ffetarget_not_integer4 (ffebld_cu_ptr_integer4 (u),
3452                               ffebld_constant_integer4 (ffebld_conter (r)));
3453           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3454                                         (ffebld_cu_val_integer4 (u)), expr);
3455           break;
3456 #endif
3457
3458         default:
3459           assert ("bad integer kind type" == NULL);
3460           break;
3461         }
3462       break;
3463
3464     case FFEINFO_basictypeLOGICAL:
3465       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3466         {
3467 #if FFETARGET_okLOGICAL1
3468         case FFEINFO_kindtypeLOGICAL1:
3469           error = ffetarget_not_logical1 (ffebld_cu_ptr_logical1 (u),
3470                               ffebld_constant_logical1 (ffebld_conter (r)));
3471           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
3472                                         (ffebld_cu_val_logical1 (u)), expr);
3473           break;
3474 #endif
3475
3476 #if FFETARGET_okLOGICAL2
3477         case FFEINFO_kindtypeLOGICAL2:
3478           error = ffetarget_not_logical2 (ffebld_cu_ptr_logical2 (u),
3479                               ffebld_constant_logical2 (ffebld_conter (r)));
3480           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
3481                                         (ffebld_cu_val_logical2 (u)), expr);
3482           break;
3483 #endif
3484
3485 #if FFETARGET_okLOGICAL3
3486         case FFEINFO_kindtypeLOGICAL3:
3487           error = ffetarget_not_logical3 (ffebld_cu_ptr_logical3 (u),
3488                               ffebld_constant_logical3 (ffebld_conter (r)));
3489           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
3490                                         (ffebld_cu_val_logical3 (u)), expr);
3491           break;
3492 #endif
3493
3494 #if FFETARGET_okLOGICAL4
3495         case FFEINFO_kindtypeLOGICAL4:
3496           error = ffetarget_not_logical4 (ffebld_cu_ptr_logical4 (u),
3497                               ffebld_constant_logical4 (ffebld_conter (r)));
3498           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
3499                                         (ffebld_cu_val_logical4 (u)), expr);
3500           break;
3501 #endif
3502
3503         default:
3504           assert ("bad logical kind type" == NULL);
3505           break;
3506         }
3507       break;
3508
3509     default:
3510       assert ("bad type" == NULL);
3511       return expr;
3512     }
3513
3514   ffebld_set_info (expr, ffeinfo_new
3515                    (bt,
3516                     kt,
3517                     0,
3518                     FFEINFO_kindENTITY,
3519                     FFEINFO_whereCONSTANT,
3520                     FFETARGET_charactersizeNONE));
3521
3522   if ((error != FFEBAD)
3523       && ffebad_start (error))
3524     {
3525       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3526       ffebad_finish ();
3527     }
3528
3529   return expr;
3530 }
3531
3532 /* ffeexpr_collapse_add -- Collapse add expr
3533
3534    ffebld expr;
3535    ffelexToken token;
3536    expr = ffeexpr_collapse_add(expr,token);
3537
3538    If the result of the expr is a constant, replaces the expr with the
3539    computed constant.  */
3540
3541 ffebld
3542 ffeexpr_collapse_add (ffebld expr, ffelexToken t)
3543 {
3544   ffebad error = FFEBAD;
3545   ffebld l;
3546   ffebld r;
3547   ffebldConstantUnion u;
3548   ffeinfoBasictype bt;
3549   ffeinfoKindtype kt;
3550
3551   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3552     return expr;
3553
3554   l = ffebld_left (expr);
3555   r = ffebld_right (expr);
3556
3557   if (ffebld_op (l) != FFEBLD_opCONTER)
3558     return expr;
3559   if (ffebld_op (r) != FFEBLD_opCONTER)
3560     return expr;
3561
3562   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3563     {
3564     case FFEINFO_basictypeANY:
3565       return expr;
3566
3567     case FFEINFO_basictypeINTEGER:
3568       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3569         {
3570 #if FFETARGET_okINTEGER1
3571         case FFEINFO_kindtypeINTEGER1:
3572           error = ffetarget_add_integer1 (ffebld_cu_ptr_integer1 (u),
3573                                ffebld_constant_integer1 (ffebld_conter (l)),
3574                               ffebld_constant_integer1 (ffebld_conter (r)));
3575           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3576                                         (ffebld_cu_val_integer1 (u)), expr);
3577           break;
3578 #endif
3579
3580 #if FFETARGET_okINTEGER2
3581         case FFEINFO_kindtypeINTEGER2:
3582           error = ffetarget_add_integer2 (ffebld_cu_ptr_integer2 (u),
3583                                ffebld_constant_integer2 (ffebld_conter (l)),
3584                               ffebld_constant_integer2 (ffebld_conter (r)));
3585           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3586                                         (ffebld_cu_val_integer2 (u)), expr);
3587           break;
3588 #endif
3589
3590 #if FFETARGET_okINTEGER3
3591         case FFEINFO_kindtypeINTEGER3:
3592           error = ffetarget_add_integer3 (ffebld_cu_ptr_integer3 (u),
3593                                ffebld_constant_integer3 (ffebld_conter (l)),
3594                               ffebld_constant_integer3 (ffebld_conter (r)));
3595           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3596                                         (ffebld_cu_val_integer3 (u)), expr);
3597           break;
3598 #endif
3599
3600 #if FFETARGET_okINTEGER4
3601         case FFEINFO_kindtypeINTEGER4:
3602           error = ffetarget_add_integer4 (ffebld_cu_ptr_integer4 (u),
3603                                ffebld_constant_integer4 (ffebld_conter (l)),
3604                               ffebld_constant_integer4 (ffebld_conter (r)));
3605           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3606                                         (ffebld_cu_val_integer4 (u)), expr);
3607           break;
3608 #endif
3609
3610         default:
3611           assert ("bad integer kind type" == NULL);
3612           break;
3613         }
3614       break;
3615
3616     case FFEINFO_basictypeREAL:
3617       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3618         {
3619 #if FFETARGET_okREAL1
3620         case FFEINFO_kindtypeREAL1:
3621           error = ffetarget_add_real1 (ffebld_cu_ptr_real1 (u),
3622                                   ffebld_constant_real1 (ffebld_conter (l)),
3623                                  ffebld_constant_real1 (ffebld_conter (r)));
3624           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3625                                            (ffebld_cu_val_real1 (u)), expr);
3626           break;
3627 #endif
3628
3629 #if FFETARGET_okREAL2
3630         case FFEINFO_kindtypeREAL2:
3631           error = ffetarget_add_real2 (ffebld_cu_ptr_real2 (u),
3632                                   ffebld_constant_real2 (ffebld_conter (l)),
3633                                  ffebld_constant_real2 (ffebld_conter (r)));
3634           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3635                                            (ffebld_cu_val_real2 (u)), expr);
3636           break;
3637 #endif
3638
3639 #if FFETARGET_okREAL3
3640         case FFEINFO_kindtypeREAL3:
3641           error = ffetarget_add_real3 (ffebld_cu_ptr_real3 (u),
3642                                   ffebld_constant_real3 (ffebld_conter (l)),
3643                                  ffebld_constant_real3 (ffebld_conter (r)));
3644           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3645                                            (ffebld_cu_val_real3 (u)), expr);
3646           break;
3647 #endif
3648
3649 #if FFETARGET_okREAL4
3650         case FFEINFO_kindtypeREAL4:
3651           error = ffetarget_add_real4 (ffebld_cu_ptr_real4 (u),
3652                                   ffebld_constant_real4 (ffebld_conter (l)),
3653                                  ffebld_constant_real4 (ffebld_conter (r)));
3654           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
3655                                            (ffebld_cu_val_real4 (u)), expr);
3656           break;
3657 #endif
3658
3659         default:
3660           assert ("bad real kind type" == NULL);
3661           break;
3662         }
3663       break;
3664
3665     case FFEINFO_basictypeCOMPLEX:
3666       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3667         {
3668 #if FFETARGET_okCOMPLEX1
3669         case FFEINFO_kindtypeREAL1:
3670           error = ffetarget_add_complex1 (ffebld_cu_ptr_complex1 (u),
3671                                ffebld_constant_complex1 (ffebld_conter (l)),
3672                               ffebld_constant_complex1 (ffebld_conter (r)));
3673           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3674                                         (ffebld_cu_val_complex1 (u)), expr);
3675           break;
3676 #endif
3677
3678 #if FFETARGET_okCOMPLEX2
3679         case FFEINFO_kindtypeREAL2:
3680           error = ffetarget_add_complex2 (ffebld_cu_ptr_complex2 (u),
3681                                ffebld_constant_complex2 (ffebld_conter (l)),
3682                               ffebld_constant_complex2 (ffebld_conter (r)));
3683           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3684                                         (ffebld_cu_val_complex2 (u)), expr);
3685           break;
3686 #endif
3687
3688 #if FFETARGET_okCOMPLEX3
3689         case FFEINFO_kindtypeREAL3:
3690           error = ffetarget_add_complex3 (ffebld_cu_ptr_complex3 (u),
3691                                ffebld_constant_complex3 (ffebld_conter (l)),
3692                               ffebld_constant_complex3 (ffebld_conter (r)));
3693           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3694                                         (ffebld_cu_val_complex3 (u)), expr);
3695           break;
3696 #endif
3697
3698 #if FFETARGET_okCOMPLEX4
3699         case FFEINFO_kindtypeREAL4:
3700           error = ffetarget_add_complex4 (ffebld_cu_ptr_complex4 (u),
3701                                ffebld_constant_complex4 (ffebld_conter (l)),
3702                               ffebld_constant_complex4 (ffebld_conter (r)));
3703           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
3704                                         (ffebld_cu_val_complex4 (u)), expr);
3705           break;
3706 #endif
3707
3708         default:
3709           assert ("bad complex kind type" == NULL);
3710           break;
3711         }
3712       break;
3713
3714     default:
3715       assert ("bad type" == NULL);
3716       return expr;
3717     }
3718
3719   ffebld_set_info (expr, ffeinfo_new
3720                    (bt,
3721                     kt,
3722                     0,
3723                     FFEINFO_kindENTITY,
3724                     FFEINFO_whereCONSTANT,
3725                     FFETARGET_charactersizeNONE));
3726
3727   if ((error != FFEBAD)
3728       && ffebad_start (error))
3729     {
3730       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3731       ffebad_finish ();
3732     }
3733
3734   return expr;
3735 }
3736
3737 /* ffeexpr_collapse_subtract -- Collapse subtract expr
3738
3739    ffebld expr;
3740    ffelexToken token;
3741    expr = ffeexpr_collapse_subtract(expr,token);
3742
3743    If the result of the expr is a constant, replaces the expr with the
3744    computed constant.  */
3745
3746 ffebld
3747 ffeexpr_collapse_subtract (ffebld expr, ffelexToken t)
3748 {
3749   ffebad error = FFEBAD;
3750   ffebld l;
3751   ffebld r;
3752   ffebldConstantUnion u;
3753   ffeinfoBasictype bt;
3754   ffeinfoKindtype kt;
3755
3756   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3757     return expr;
3758
3759   l = ffebld_left (expr);
3760   r = ffebld_right (expr);
3761
3762   if (ffebld_op (l) != FFEBLD_opCONTER)
3763     return expr;
3764   if (ffebld_op (r) != FFEBLD_opCONTER)
3765     return expr;
3766
3767   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3768     {
3769     case FFEINFO_basictypeANY:
3770       return expr;
3771
3772     case FFEINFO_basictypeINTEGER:
3773       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3774         {
3775 #if FFETARGET_okINTEGER1
3776         case FFEINFO_kindtypeINTEGER1:
3777           error = ffetarget_subtract_integer1 (ffebld_cu_ptr_integer1 (u),
3778                                ffebld_constant_integer1 (ffebld_conter (l)),
3779                               ffebld_constant_integer1 (ffebld_conter (r)));
3780           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3781                                         (ffebld_cu_val_integer1 (u)), expr);
3782           break;
3783 #endif
3784
3785 #if FFETARGET_okINTEGER2
3786         case FFEINFO_kindtypeINTEGER2:
3787           error = ffetarget_subtract_integer2 (ffebld_cu_ptr_integer2 (u),
3788                                ffebld_constant_integer2 (ffebld_conter (l)),
3789                               ffebld_constant_integer2 (ffebld_conter (r)));
3790           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3791                                         (ffebld_cu_val_integer2 (u)), expr);
3792           break;
3793 #endif
3794
3795 #if FFETARGET_okINTEGER3
3796         case FFEINFO_kindtypeINTEGER3:
3797           error = ffetarget_subtract_integer3 (ffebld_cu_ptr_integer3 (u),
3798                                ffebld_constant_integer3 (ffebld_conter (l)),
3799                               ffebld_constant_integer3 (ffebld_conter (r)));
3800           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3801                                         (ffebld_cu_val_integer3 (u)), expr);
3802           break;
3803 #endif
3804
3805 #if FFETARGET_okINTEGER4
3806         case FFEINFO_kindtypeINTEGER4:
3807           error = ffetarget_subtract_integer4 (ffebld_cu_ptr_integer4 (u),
3808                                ffebld_constant_integer4 (ffebld_conter (l)),
3809                               ffebld_constant_integer4 (ffebld_conter (r)));
3810           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3811                                         (ffebld_cu_val_integer4 (u)), expr);
3812           break;
3813 #endif
3814
3815         default:
3816           assert ("bad integer kind type" == NULL);
3817           break;
3818         }
3819       break;
3820
3821     case FFEINFO_basictypeREAL:
3822       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3823         {
3824 #if FFETARGET_okREAL1
3825         case FFEINFO_kindtypeREAL1:
3826           error = ffetarget_subtract_real1 (ffebld_cu_ptr_real1 (u),
3827                                   ffebld_constant_real1 (ffebld_conter (l)),
3828                                  ffebld_constant_real1 (ffebld_conter (r)));
3829           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3830                                            (ffebld_cu_val_real1 (u)), expr);
3831           break;
3832 #endif
3833
3834 #if FFETARGET_okREAL2
3835         case FFEINFO_kindtypeREAL2:
3836           error = ffetarget_subtract_real2 (ffebld_cu_ptr_real2 (u),
3837                                   ffebld_constant_real2 (ffebld_conter (l)),
3838                                  ffebld_constant_real2 (ffebld_conter (r)));
3839           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3840                                            (ffebld_cu_val_real2 (u)), expr);
3841           break;
3842 #endif
3843
3844 #if FFETARGET_okREAL3
3845         case FFEINFO_kindtypeREAL3:
3846           error = ffetarget_subtract_real3 (ffebld_cu_ptr_real3 (u),
3847                                   ffebld_constant_real3 (ffebld_conter (l)),
3848                                  ffebld_constant_real3 (ffebld_conter (r)));
3849           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3850                                            (ffebld_cu_val_real3 (u)), expr);
3851           break;
3852 #endif
3853
3854 #if FFETARGET_okREAL4
3855         case FFEINFO_kindtypeREAL4:
3856           error = ffetarget_subtract_real4 (ffebld_cu_ptr_real4 (u),
3857                                   ffebld_constant_real4 (ffebld_conter (l)),
3858                                  ffebld_constant_real4 (ffebld_conter (r)));
3859           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
3860                                            (ffebld_cu_val_real4 (u)), expr);
3861           break;
3862 #endif
3863
3864         default:
3865           assert ("bad real kind type" == NULL);
3866           break;
3867         }
3868       break;
3869
3870     case FFEINFO_basictypeCOMPLEX:
3871       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3872         {
3873 #if FFETARGET_okCOMPLEX1
3874         case FFEINFO_kindtypeREAL1:
3875           error = ffetarget_subtract_complex1 (ffebld_cu_ptr_complex1 (u),
3876                                ffebld_constant_complex1 (ffebld_conter (l)),
3877                               ffebld_constant_complex1 (ffebld_conter (r)));
3878           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3879                                         (ffebld_cu_val_complex1 (u)), expr);
3880           break;
3881 #endif
3882
3883 #if FFETARGET_okCOMPLEX2
3884         case FFEINFO_kindtypeREAL2:
3885           error = ffetarget_subtract_complex2 (ffebld_cu_ptr_complex2 (u),
3886                                ffebld_constant_complex2 (ffebld_conter (l)),
3887                               ffebld_constant_complex2 (ffebld_conter (r)));
3888           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3889                                         (ffebld_cu_val_complex2 (u)), expr);
3890           break;
3891 #endif
3892
3893 #if FFETARGET_okCOMPLEX3
3894         case FFEINFO_kindtypeREAL3:
3895           error = ffetarget_subtract_complex3 (ffebld_cu_ptr_complex3 (u),
3896                                ffebld_constant_complex3 (ffebld_conter (l)),
3897                               ffebld_constant_complex3 (ffebld_conter (r)));
3898           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3899                                         (ffebld_cu_val_complex3 (u)), expr);
3900           break;
3901 #endif
3902
3903 #if FFETARGET_okCOMPLEX4
3904         case FFEINFO_kindtypeREAL4:
3905           error = ffetarget_subtract_complex4 (ffebld_cu_ptr_complex4 (u),
3906                                ffebld_constant_complex4 (ffebld_conter (l)),
3907                               ffebld_constant_complex4 (ffebld_conter (r)));
3908           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
3909                                         (ffebld_cu_val_complex4 (u)), expr);
3910           break;
3911 #endif
3912
3913         default:
3914           assert ("bad complex kind type" == NULL);
3915           break;
3916         }
3917       break;
3918
3919     default:
3920       assert ("bad type" == NULL);
3921       return expr;
3922     }
3923
3924   ffebld_set_info (expr, ffeinfo_new
3925                    (bt,
3926                     kt,
3927                     0,
3928                     FFEINFO_kindENTITY,
3929                     FFEINFO_whereCONSTANT,
3930                     FFETARGET_charactersizeNONE));
3931
3932   if ((error != FFEBAD)
3933       && ffebad_start (error))
3934     {
3935       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3936       ffebad_finish ();
3937     }
3938
3939   return expr;
3940 }
3941
3942 /* ffeexpr_collapse_multiply -- Collapse multiply expr
3943
3944    ffebld expr;
3945    ffelexToken token;
3946    expr = ffeexpr_collapse_multiply(expr,token);
3947
3948    If the result of the expr is a constant, replaces the expr with the
3949    computed constant.  */
3950
3951 ffebld
3952 ffeexpr_collapse_multiply (ffebld expr, ffelexToken t)
3953 {
3954   ffebad error = FFEBAD;
3955   ffebld l;
3956   ffebld r;
3957   ffebldConstantUnion u;
3958   ffeinfoBasictype bt;
3959   ffeinfoKindtype kt;
3960
3961   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3962     return expr;
3963
3964   l = ffebld_left (expr);
3965   r = ffebld_right (expr);
3966
3967   if (ffebld_op (l) != FFEBLD_opCONTER)
3968     return expr;
3969   if (ffebld_op (r) != FFEBLD_opCONTER)
3970     return expr;
3971
3972   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3973     {
3974     case FFEINFO_basictypeANY:
3975       return expr;
3976
3977     case FFEINFO_basictypeINTEGER:
3978       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3979         {
3980 #if FFETARGET_okINTEGER1
3981         case FFEINFO_kindtypeINTEGER1:
3982           error = ffetarget_multiply_integer1 (ffebld_cu_ptr_integer1 (u),
3983                                ffebld_constant_integer1 (ffebld_conter (l)),
3984                               ffebld_constant_integer1 (ffebld_conter (r)));
3985           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3986                                         (ffebld_cu_val_integer1 (u)), expr);
3987           break;
3988 #endif
3989
3990 #if FFETARGET_okINTEGER2
3991         case FFEINFO_kindtypeINTEGER2:
3992           error = ffetarget_multiply_integer2 (ffebld_cu_ptr_integer2 (u),
3993                                ffebld_constant_integer2 (ffebld_conter (l)),
3994                               ffebld_constant_integer2 (ffebld_conter (r)));
3995           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3996                                         (ffebld_cu_val_integer2 (u)), expr);
3997           break;
3998 #endif
3999
4000 #if FFETARGET_okINTEGER3
4001         case FFEINFO_kindtypeINTEGER3:
4002           error = ffetarget_multiply_integer3 (ffebld_cu_ptr_integer3 (u),
4003                                ffebld_constant_integer3 (ffebld_conter (l)),
4004                               ffebld_constant_integer3 (ffebld_conter (r)));
4005           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
4006                                         (ffebld_cu_val_integer3 (u)), expr);
4007           break;
4008 #endif
4009
4010 #if FFETARGET_okINTEGER4
4011         case FFEINFO_kindtypeINTEGER4:
4012           error = ffetarget_multiply_integer4 (ffebld_cu_ptr_integer4 (u),
4013                                ffebld_constant_integer4 (ffebld_conter (l)),
4014                               ffebld_constant_integer4 (ffebld_conter (r)));
4015           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
4016                                         (ffebld_cu_val_integer4 (u)), expr);
4017           break;
4018 #endif
4019
4020         default:
4021           assert ("bad integer kind type" == NULL);
4022           break;
4023         }
4024       break;
4025
4026     case FFEINFO_basictypeREAL:
4027       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4028         {
4029 #if FFETARGET_okREAL1
4030         case FFEINFO_kindtypeREAL1:
4031           error = ffetarget_multiply_real1 (ffebld_cu_ptr_real1 (u),
4032                                   ffebld_constant_real1 (ffebld_conter (l)),
4033                                  ffebld_constant_real1 (ffebld_conter (r)));
4034           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
4035                                            (ffebld_cu_val_real1 (u)), expr);
4036           break;
4037 #endif
4038
4039 #if FFETARGET_okREAL2
4040         case FFEINFO_kindtypeREAL2:
4041           error = ffetarget_multiply_real2 (ffebld_cu_ptr_real2 (u),
4042                                   ffebld_constant_real2 (ffebld_conter (l)),
4043                                  ffebld_constant_real2 (ffebld_conter (r)));
4044           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
4045                                            (ffebld_cu_val_real2 (u)), expr);
4046           break;
4047 #endif
4048
4049 #if FFETARGET_okREAL3
4050         case FFEINFO_kindtypeREAL3:
4051           error = ffetarget_multiply_real3 (ffebld_cu_ptr_real3 (u),
4052                                   ffebld_constant_real3 (ffebld_conter (l)),
4053                                  ffebld_constant_real3 (ffebld_conter (r)));
4054           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
4055                                            (ffebld_cu_val_real3 (u)), expr);
4056           break;
4057 #endif
4058
4059 #if FFETARGET_okREAL4
4060         case FFEINFO_kindtypeREAL4:
4061           error = ffetarget_multiply_real4 (ffebld_cu_ptr_real4 (u),
4062                                   ffebld_constant_real4 (ffebld_conter (l)),
4063                                  ffebld_constant_real4 (ffebld_conter (r)));
4064           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
4065                                            (ffebld_cu_val_real4 (u)), expr);
4066           break;
4067 #endif
4068
4069         default:
4070           assert ("bad real kind type" == NULL);
4071           break;
4072         }
4073       break;
4074
4075     case FFEINFO_basictypeCOMPLEX:
4076       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4077         {
4078 #if FFETARGET_okCOMPLEX1
4079         case FFEINFO_kindtypeREAL1:
4080           error = ffetarget_multiply_complex1 (ffebld_cu_ptr_complex1 (u),
4081                                ffebld_constant_complex1 (ffebld_conter (l)),
4082                               ffebld_constant_complex1 (ffebld_conter (r)));
4083           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
4084                                         (ffebld_cu_val_complex1 (u)), expr);
4085           break;
4086 #endif
4087
4088 #if FFETARGET_okCOMPLEX2
4089         case FFEINFO_kindtypeREAL2:
4090           error = ffetarget_multiply_complex2 (ffebld_cu_ptr_complex2 (u),
4091                                ffebld_constant_complex2 (ffebld_conter (l)),
4092                               ffebld_constant_complex2 (ffebld_conter (r)));
4093           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
4094                                         (ffebld_cu_val_complex2 (u)), expr);
4095           break;
4096 #endif
4097
4098 #if FFETARGET_okCOMPLEX3
4099         case FFEINFO_kindtypeREAL3:
4100           error = ffetarget_multiply_complex3 (ffebld_cu_ptr_complex3 (u),
4101                                ffebld_constant_complex3 (ffebld_conter (l)),
4102                               ffebld_constant_complex3 (ffebld_conter (r)));
4103           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
4104                                         (ffebld_cu_val_complex3 (u)), expr);
4105           break;
4106 #endif
4107
4108 #if FFETARGET_okCOMPLEX4
4109         case FFEINFO_kindtypeREAL4:
4110           error = ffetarget_multiply_complex4 (ffebld_cu_ptr_complex4 (u),
4111                                ffebld_constant_complex4 (ffebld_conter (l)),
4112                               ffebld_constant_complex4 (ffebld_conter (r)));
4113           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
4114                                         (ffebld_cu_val_complex4 (u)), expr);
4115           break;
4116 #endif
4117
4118         default:
4119           assert ("bad complex kind type" == NULL);
4120           break;
4121         }
4122       break;
4123
4124     default:
4125       assert ("bad type" == NULL);
4126       return expr;
4127     }
4128
4129   ffebld_set_info (expr, ffeinfo_new
4130                    (bt,
4131                     kt,
4132                     0,
4133                     FFEINFO_kindENTITY,
4134                     FFEINFO_whereCONSTANT,
4135                     FFETARGET_charactersizeNONE));
4136
4137   if ((error != FFEBAD)
4138       && ffebad_start (error))
4139     {
4140       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4141       ffebad_finish ();
4142     }
4143
4144   return expr;
4145 }
4146
4147 /* ffeexpr_collapse_divide -- Collapse divide expr
4148
4149    ffebld expr;
4150    ffelexToken token;
4151    expr = ffeexpr_collapse_divide(expr,token);
4152
4153    If the result of the expr is a constant, replaces the expr with the
4154    computed constant.  */
4155
4156 ffebld
4157 ffeexpr_collapse_divide (ffebld expr, ffelexToken t)
4158 {
4159   ffebad error = FFEBAD;
4160   ffebld l;
4161   ffebld r;
4162   ffebldConstantUnion u;
4163   ffeinfoBasictype bt;
4164   ffeinfoKindtype kt;
4165
4166   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4167     return expr;
4168
4169   l = ffebld_left (expr);
4170   r = ffebld_right (expr);
4171
4172   if (ffebld_op (l) != FFEBLD_opCONTER)
4173     return expr;
4174   if (ffebld_op (r) != FFEBLD_opCONTER)
4175     return expr;
4176
4177   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
4178     {
4179     case FFEINFO_basictypeANY:
4180       return expr;
4181
4182     case FFEINFO_basictypeINTEGER:
4183       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4184         {
4185 #if FFETARGET_okINTEGER1
4186         case FFEINFO_kindtypeINTEGER1:
4187           error = ffetarget_divide_integer1 (ffebld_cu_ptr_integer1 (u),
4188                                ffebld_constant_integer1 (ffebld_conter (l)),
4189                               ffebld_constant_integer1 (ffebld_conter (r)));
4190           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
4191                                         (ffebld_cu_val_integer1 (u)), expr);
4192           break;
4193 #endif
4194
4195 #if FFETARGET_okINTEGER2
4196         case FFEINFO_kindtypeINTEGER2:
4197           error = ffetarget_divide_integer2 (ffebld_cu_ptr_integer2 (u),
4198                                ffebld_constant_integer2 (ffebld_conter (l)),
4199                               ffebld_constant_integer2 (ffebld_conter (r)));
4200           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
4201                                         (ffebld_cu_val_integer2 (u)), expr);
4202           break;
4203 #endif
4204
4205 #if FFETARGET_okINTEGER3
4206         case FFEINFO_kindtypeINTEGER3:
4207           error = ffetarget_divide_integer3 (ffebld_cu_ptr_integer3 (u),
4208                                ffebld_constant_integer3 (ffebld_conter (l)),
4209                               ffebld_constant_integer3 (ffebld_conter (r)));
4210           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
4211                                         (ffebld_cu_val_integer3 (u)), expr);
4212           break;
4213 #endif
4214
4215 #if FFETARGET_okINTEGER4
4216         case FFEINFO_kindtypeINTEGER4:
4217           error = ffetarget_divide_integer4 (ffebld_cu_ptr_integer4 (u),
4218                                ffebld_constant_integer4 (ffebld_conter (l)),
4219                               ffebld_constant_integer4 (ffebld_conter (r)));
4220           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
4221                                         (ffebld_cu_val_integer4 (u)), expr);
4222           break;
4223 #endif
4224
4225         default:
4226           assert ("bad integer kind type" == NULL);
4227           break;
4228         }
4229       break;
4230
4231     case FFEINFO_basictypeREAL:
4232       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4233         {
4234 #if FFETARGET_okREAL1
4235         case FFEINFO_kindtypeREAL1:
4236           error = ffetarget_divide_real1 (ffebld_cu_ptr_real1 (u),
4237                                   ffebld_constant_real1 (ffebld_conter (l)),
4238                                  ffebld_constant_real1 (ffebld_conter (r)));
4239           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
4240                                            (ffebld_cu_val_real1 (u)), expr);
4241           break;
4242 #endif
4243
4244 #if FFETARGET_okREAL2
4245         case FFEINFO_kindtypeREAL2:
4246           error = ffetarget_divide_real2 (ffebld_cu_ptr_real2 (u),
4247                                   ffebld_constant_real2 (ffebld_conter (l)),
4248                                  ffebld_constant_real2 (ffebld_conter (r)));
4249           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
4250                                            (ffebld_cu_val_real2 (u)), expr);
4251           break;
4252 #endif
4253
4254 #if FFETARGET_okREAL3
4255         case FFEINFO_kindtypeREAL3:
4256           error = ffetarget_divide_real3 (ffebld_cu_ptr_real3 (u),
4257                                   ffebld_constant_real3 (ffebld_conter (l)),
4258                                  ffebld_constant_real3 (ffebld_conter (r)));
4259           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
4260                                            (ffebld_cu_val_real3 (u)), expr);
4261           break;
4262 #endif
4263
4264 #if FFETARGET_okREAL4
4265         case FFEINFO_kindtypeREAL4:
4266           error = ffetarget_divide_real4 (ffebld_cu_ptr_real4 (u),
4267                                   ffebld_constant_real4 (ffebld_conter (l)),
4268                                  ffebld_constant_real4 (ffebld_conter (r)));
4269           expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
4270                                            (ffebld_cu_val_real4 (u)), expr);
4271           break;
4272 #endif
4273
4274         default:
4275           assert ("bad real kind type" == NULL);
4276           break;
4277         }
4278       break;
4279
4280     case FFEINFO_basictypeCOMPLEX:
4281       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4282         {
4283 #if FFETARGET_okCOMPLEX1
4284         case FFEINFO_kindtypeREAL1:
4285           error = ffetarget_divide_complex1 (ffebld_cu_ptr_complex1 (u),
4286                                ffebld_constant_complex1 (ffebld_conter (l)),
4287                               ffebld_constant_complex1 (ffebld_conter (r)));
4288           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
4289                                         (ffebld_cu_val_complex1 (u)), expr);
4290           break;
4291 #endif
4292
4293 #if FFETARGET_okCOMPLEX2
4294         case FFEINFO_kindtypeREAL2:
4295           error = ffetarget_divide_complex2 (ffebld_cu_ptr_complex2 (u),
4296                                ffebld_constant_complex2 (ffebld_conter (l)),
4297                               ffebld_constant_complex2 (ffebld_conter (r)));
4298           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
4299                                         (ffebld_cu_val_complex2 (u)), expr);
4300           break;
4301 #endif
4302
4303 #if FFETARGET_okCOMPLEX3
4304         case FFEINFO_kindtypeREAL3:
4305           error = ffetarget_divide_complex3 (ffebld_cu_ptr_complex3 (u),
4306                                ffebld_constant_complex3 (ffebld_conter (l)),
4307                               ffebld_constant_complex3 (ffebld_conter (r)));
4308           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
4309                                         (ffebld_cu_val_complex3 (u)), expr);
4310           break;
4311 #endif
4312
4313 #if FFETARGET_okCOMPLEX4
4314         case FFEINFO_kindtypeREAL4:
4315           error = ffetarget_divide_complex4 (ffebld_cu_ptr_complex4 (u),
4316                                ffebld_constant_complex4 (ffebld_conter (l)),
4317                               ffebld_constant_complex4 (ffebld_conter (r)));
4318           expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
4319                                         (ffebld_cu_val_complex4 (u)), expr);
4320           break;
4321 #endif
4322
4323         default:
4324           assert ("bad complex kind type" == NULL);
4325           break;
4326         }
4327       break;
4328
4329     default:
4330       assert ("bad type" == NULL);
4331       return expr;
4332     }
4333
4334   ffebld_set_info (expr, ffeinfo_new
4335                    (bt,
4336                     kt,
4337                     0,
4338                     FFEINFO_kindENTITY,
4339                     FFEINFO_whereCONSTANT,
4340                     FFETARGET_charactersizeNONE));
4341
4342   if ((error != FFEBAD)
4343       && ffebad_start (error))
4344     {
4345       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4346       ffebad_finish ();
4347     }
4348
4349   return expr;
4350 }
4351
4352 /* ffeexpr_collapse_power -- Collapse power expr
4353
4354    ffebld expr;
4355    ffelexToken token;
4356    expr = ffeexpr_collapse_power(expr,token);
4357
4358    If the result of the expr is a constant, replaces the expr with the
4359    computed constant.  */
4360
4361 ffebld
4362 ffeexpr_collapse_power (ffebld expr, ffelexToken t)
4363 {
4364   ffebad error = FFEBAD;
4365   ffebld l;
4366   ffebld r;
4367   ffebldConstantUnion u;
4368   ffeinfoBasictype bt;
4369   ffeinfoKindtype kt;
4370
4371   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4372     return expr;
4373
4374   l = ffebld_left (expr);
4375   r = ffebld_right (expr);
4376
4377   if (ffebld_op (l) != FFEBLD_opCONTER)
4378     return expr;
4379   if (ffebld_op (r) != FFEBLD_opCONTER)
4380     return expr;
4381
4382   if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER)
4383   || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT))
4384     return expr;
4385
4386   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
4387     {
4388     case FFEINFO_basictypeANY:
4389       return expr;
4390
4391     case FFEINFO_basictypeINTEGER:
4392       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4393         {
4394         case FFEINFO_kindtypeINTEGERDEFAULT:
4395           error = ffetarget_power_integerdefault_integerdefault
4396             (ffebld_cu_ptr_integerdefault (u),
4397              ffebld_constant_integerdefault (ffebld_conter (l)),
4398              ffebld_constant_integerdefault (ffebld_conter (r)));
4399           expr = ffebld_new_conter_with_orig
4400             (ffebld_constant_new_integerdefault_val
4401              (ffebld_cu_val_integerdefault (u)), expr);
4402           break;
4403
4404         default:
4405           assert ("bad integer kind type" == NULL);
4406           break;
4407         }
4408       break;
4409
4410     case FFEINFO_basictypeREAL:
4411       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4412         {
4413         case FFEINFO_kindtypeREALDEFAULT:
4414           error = ffetarget_power_realdefault_integerdefault
4415             (ffebld_cu_ptr_realdefault (u),
4416              ffebld_constant_realdefault (ffebld_conter (l)),
4417              ffebld_constant_integerdefault (ffebld_conter (r)));
4418           expr = ffebld_new_conter_with_orig
4419             (ffebld_constant_new_realdefault_val
4420              (ffebld_cu_val_realdefault (u)), expr);
4421           break;
4422
4423         case FFEINFO_kindtypeREALDOUBLE:
4424           error = ffetarget_power_realdouble_integerdefault
4425             (ffebld_cu_ptr_realdouble (u),
4426              ffebld_constant_realdouble (ffebld_conter (l)),
4427              ffebld_constant_integerdefault (ffebld_conter (r)));
4428           expr = ffebld_new_conter_with_orig
4429             (ffebld_constant_new_realdouble_val
4430              (ffebld_cu_val_realdouble (u)), expr);
4431           break;
4432
4433 #if FFETARGET_okREALQUAD
4434         case FFEINFO_kindtypeREALQUAD:
4435           error = ffetarget_power_realquad_integerdefault
4436             (ffebld_cu_ptr_realquad (u),
4437              ffebld_constant_realquad (ffebld_conter (l)),
4438              ffebld_constant_integerdefault (ffebld_conter (r)));
4439           expr = ffebld_new_conter_with_orig
4440             (ffebld_constant_new_realquad_val
4441              (ffebld_cu_val_realquad (u)), expr);
4442           break;
4443 #endif
4444         default:
4445           assert ("bad real kind type" == NULL);
4446           break;
4447         }
4448       break;
4449
4450     case FFEINFO_basictypeCOMPLEX:
4451       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4452         {
4453         case FFEINFO_kindtypeREALDEFAULT:
4454           error = ffetarget_power_complexdefault_integerdefault
4455             (ffebld_cu_ptr_complexdefault (u),
4456              ffebld_constant_complexdefault (ffebld_conter (l)),
4457              ffebld_constant_integerdefault (ffebld_conter (r)));
4458           expr = ffebld_new_conter_with_orig
4459             (ffebld_constant_new_complexdefault_val
4460              (ffebld_cu_val_complexdefault (u)), expr);
4461           break;
4462
4463 #if FFETARGET_okCOMPLEXDOUBLE
4464         case FFEINFO_kindtypeREALDOUBLE:
4465           error = ffetarget_power_complexdouble_integerdefault
4466             (ffebld_cu_ptr_complexdouble (u),
4467              ffebld_constant_complexdouble (ffebld_conter (l)),
4468              ffebld_constant_integerdefault (ffebld_conter (r)));
4469           expr = ffebld_new_conter_with_orig
4470             (ffebld_constant_new_complexdouble_val
4471              (ffebld_cu_val_complexdouble (u)), expr);
4472           break;
4473 #endif
4474
4475 #if FFETARGET_okCOMPLEXQUAD
4476         case FFEINFO_kindtypeREALQUAD:
4477           error = ffetarget_power_complexquad_integerdefault
4478             (ffebld_cu_ptr_complexquad (u),
4479              ffebld_constant_complexquad (ffebld_conter (l)),
4480              ffebld_constant_integerdefault (ffebld_conter (r)));
4481           expr = ffebld_new_conter_with_orig
4482             (ffebld_constant_new_complexquad_val
4483              (ffebld_cu_val_complexquad (u)), expr);
4484           break;
4485 #endif
4486
4487         default:
4488           assert ("bad complex kind type" == NULL);
4489           break;
4490         }
4491       break;
4492
4493     default:
4494       assert ("bad type" == NULL);
4495       return expr;
4496     }
4497
4498   ffebld_set_info (expr, ffeinfo_new
4499                    (bt,
4500                     kt,
4501                     0,
4502                     FFEINFO_kindENTITY,
4503                     FFEINFO_whereCONSTANT,
4504                     FFETARGET_charactersizeNONE));
4505
4506   if ((error != FFEBAD)
4507       && ffebad_start (error))
4508     {
4509       ffebad_here (0, ffelex_token_where_line (t),
4510                    ffelex_token_where_column (t));
4511       ffebad_finish ();
4512     }
4513
4514   return expr;
4515 }
4516
4517 /* ffeexpr_collapse_concatenate -- Collapse concatenate expr
4518
4519    ffebld expr;
4520    ffelexToken token;
4521    expr = ffeexpr_collapse_concatenate(expr,token);
4522
4523    If the result of the expr is a constant, replaces the expr with the
4524    computed constant.  */
4525
4526 ffebld
4527 ffeexpr_collapse_concatenate (ffebld expr, ffelexToken t)
4528 {
4529   ffebad error = FFEBAD;
4530   ffebld l;
4531   ffebld r;
4532   ffebldConstantUnion u;
4533   ffeinfoKindtype kt;
4534   ffetargetCharacterSize len;
4535
4536   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4537     return expr;
4538
4539   l = ffebld_left (expr);
4540   r = ffebld_right (expr);
4541
4542   if (ffebld_op (l) != FFEBLD_opCONTER)
4543     return expr;
4544   if (ffebld_op (r) != FFEBLD_opCONTER)
4545     return expr;
4546
4547   switch (ffeinfo_basictype (ffebld_info (expr)))
4548     {
4549     case FFEINFO_basictypeANY:
4550       return expr;
4551
4552     case FFEINFO_basictypeCHARACTER:
4553       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4554         {
4555 #if FFETARGET_okCHARACTER1
4556         case FFEINFO_kindtypeCHARACTER1:
4557           error = ffetarget_concatenate_character1 (ffebld_cu_ptr_character1 (u),
4558                              ffebld_constant_character1 (ffebld_conter (l)),
4559                              ffebld_constant_character1 (ffebld_conter (r)),
4560                                    ffebld_constant_pool (), &len);
4561           expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
4562                                       (ffebld_cu_val_character1 (u)), expr);
4563           break;
4564 #endif
4565
4566 #if FFETARGET_okCHARACTER2
4567         case FFEINFO_kindtypeCHARACTER2:
4568           error = ffetarget_concatenate_character2 (ffebld_cu_ptr_character2 (u),
4569                              ffebld_constant_character2 (ffebld_conter (l)),
4570                              ffebld_constant_character2 (ffebld_conter (r)),
4571                                    ffebld_constant_pool (), &len);
4572           expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val
4573                                       (ffebld_cu_val_character2 (u)), expr);
4574           break;
4575 #endif
4576
4577 #if FFETARGET_okCHARACTER3
4578         case FFEINFO_kindtypeCHARACTER3:
4579           error = ffetarget_concatenate_character3 (ffebld_cu_ptr_character3 (u),
4580                              ffebld_constant_character3 (ffebld_conter (l)),
4581                              ffebld_constant_character3 (ffebld_conter (r)),
4582                                    ffebld_constant_pool (), &len);
4583           expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val
4584                                       (ffebld_cu_val_character3 (u)), expr);
4585           break;
4586 #endif
4587
4588 #if FFETARGET_okCHARACTER4
4589         case FFEINFO_kindtypeCHARACTER4:
4590           error = ffetarget_concatenate_character4 (ffebld_cu_ptr_character4 (u),
4591                              ffebld_constant_character4 (ffebld_conter (l)),
4592                              ffebld_constant_character4 (ffebld_conter (r)),
4593                                    ffebld_constant_pool (), &len);
4594           expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val
4595                                       (ffebld_cu_val_character4 (u)), expr);
4596           break;
4597 #endif
4598
4599         default:
4600           assert ("bad character kind type" == NULL);
4601           break;
4602         }
4603       break;
4604
4605     default:
4606       assert ("bad type" == NULL);
4607       return expr;
4608     }
4609
4610   ffebld_set_info (expr, ffeinfo_new
4611                    (FFEINFO_basictypeCHARACTER,
4612                     kt,
4613                     0,
4614                     FFEINFO_kindENTITY,
4615                     FFEINFO_whereCONSTANT,
4616                     len));
4617
4618   if ((error != FFEBAD)
4619       && ffebad_start (error))
4620     {
4621       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4622       ffebad_finish ();
4623     }
4624
4625   return expr;
4626 }
4627
4628 /* ffeexpr_collapse_eq -- Collapse eq expr
4629
4630    ffebld expr;
4631    ffelexToken token;
4632    expr = ffeexpr_collapse_eq(expr,token);
4633
4634    If the result of the expr is a constant, replaces the expr with the
4635    computed constant.  */
4636
4637 ffebld
4638 ffeexpr_collapse_eq (ffebld expr, ffelexToken t)
4639 {
4640   ffebad error = FFEBAD;
4641   ffebld l;
4642   ffebld r;
4643   bool val;
4644
4645   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4646     return expr;
4647
4648   l = ffebld_left (expr);
4649   r = ffebld_right (expr);
4650
4651   if (ffebld_op (l) != FFEBLD_opCONTER)
4652     return expr;
4653   if (ffebld_op (r) != FFEBLD_opCONTER)
4654     return expr;
4655
4656   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4657     {
4658     case FFEINFO_basictypeANY:
4659       return expr;
4660
4661     case FFEINFO_basictypeINTEGER:
4662       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4663         {
4664 #if FFETARGET_okINTEGER1
4665         case FFEINFO_kindtypeINTEGER1:
4666           error = ffetarget_eq_integer1 (&val,
4667                                ffebld_constant_integer1 (ffebld_conter (l)),
4668                               ffebld_constant_integer1 (ffebld_conter (r)));
4669           expr = ffebld_new_conter_with_orig
4670             (ffebld_constant_new_logicaldefault (val), expr);
4671           break;
4672 #endif
4673
4674 #if FFETARGET_okINTEGER2
4675         case FFEINFO_kindtypeINTEGER2:
4676           error = ffetarget_eq_integer2 (&val,
4677                                ffebld_constant_integer2 (ffebld_conter (l)),
4678                               ffebld_constant_integer2 (ffebld_conter (r)));
4679           expr = ffebld_new_conter_with_orig
4680             (ffebld_constant_new_logicaldefault (val), expr);
4681           break;
4682 #endif
4683
4684 #if FFETARGET_okINTEGER3
4685         case FFEINFO_kindtypeINTEGER3:
4686           error = ffetarget_eq_integer3 (&val,
4687                                ffebld_constant_integer3 (ffebld_conter (l)),
4688                               ffebld_constant_integer3 (ffebld_conter (r)));
4689           expr = ffebld_new_conter_with_orig
4690             (ffebld_constant_new_logicaldefault (val), expr);
4691           break;
4692 #endif
4693
4694 #if FFETARGET_okINTEGER4
4695         case FFEINFO_kindtypeINTEGER4:
4696           error = ffetarget_eq_integer4 (&val,
4697                                ffebld_constant_integer4 (ffebld_conter (l)),
4698                               ffebld_constant_integer4 (ffebld_conter (r)));
4699           expr = ffebld_new_conter_with_orig
4700             (ffebld_constant_new_logicaldefault (val), expr);
4701           break;
4702 #endif
4703
4704         default:
4705           assert ("bad integer kind type" == NULL);
4706           break;
4707         }
4708       break;
4709
4710     case FFEINFO_basictypeREAL:
4711       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4712         {
4713 #if FFETARGET_okREAL1
4714         case FFEINFO_kindtypeREAL1:
4715           error = ffetarget_eq_real1 (&val,
4716                                   ffebld_constant_real1 (ffebld_conter (l)),
4717                                  ffebld_constant_real1 (ffebld_conter (r)));
4718           expr = ffebld_new_conter_with_orig
4719             (ffebld_constant_new_logicaldefault (val), expr);
4720           break;
4721 #endif
4722
4723 #if FFETARGET_okREAL2
4724         case FFEINFO_kindtypeREAL2:
4725           error = ffetarget_eq_real2 (&val,
4726                                   ffebld_constant_real2 (ffebld_conter (l)),
4727                                  ffebld_constant_real2 (ffebld_conter (r)));
4728           expr = ffebld_new_conter_with_orig
4729             (ffebld_constant_new_logicaldefault (val), expr);
4730           break;
4731 #endif
4732
4733 #if FFETARGET_okREAL3
4734         case FFEINFO_kindtypeREAL3:
4735           error = ffetarget_eq_real3 (&val,
4736                                   ffebld_constant_real3 (ffebld_conter (l)),
4737                                  ffebld_constant_real3 (ffebld_conter (r)));
4738           expr = ffebld_new_conter_with_orig
4739             (ffebld_constant_new_logicaldefault (val), expr);
4740           break;
4741 #endif
4742
4743 #if FFETARGET_okREAL4
4744         case FFEINFO_kindtypeREAL4:
4745           error = ffetarget_eq_real4 (&val,
4746                                   ffebld_constant_real4 (ffebld_conter (l)),
4747                                  ffebld_constant_real4 (ffebld_conter (r)));
4748           expr = ffebld_new_conter_with_orig
4749             (ffebld_constant_new_logicaldefault (val), expr);
4750           break;
4751 #endif
4752
4753         default:
4754           assert ("bad real kind type" == NULL);
4755           break;
4756         }
4757       break;
4758
4759     case FFEINFO_basictypeCOMPLEX:
4760       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4761         {
4762 #if FFETARGET_okCOMPLEX1
4763         case FFEINFO_kindtypeREAL1:
4764           error = ffetarget_eq_complex1 (&val,
4765                                ffebld_constant_complex1 (ffebld_conter (l)),
4766                               ffebld_constant_complex1 (ffebld_conter (r)));
4767           expr = ffebld_new_conter_with_orig
4768             (ffebld_constant_new_logicaldefault (val), expr);
4769           break;
4770 #endif
4771
4772 #if FFETARGET_okCOMPLEX2
4773         case FFEINFO_kindtypeREAL2:
4774           error = ffetarget_eq_complex2 (&val,
4775                                ffebld_constant_complex2 (ffebld_conter (l)),
4776                               ffebld_constant_complex2 (ffebld_conter (r)));
4777           expr = ffebld_new_conter_with_orig
4778             (ffebld_constant_new_logicaldefault (val), expr);
4779           break;
4780 #endif
4781
4782 #if FFETARGET_okCOMPLEX3
4783         case FFEINFO_kindtypeREAL3:
4784           error = ffetarget_eq_complex3 (&val,
4785                                ffebld_constant_complex3 (ffebld_conter (l)),
4786                               ffebld_constant_complex3 (ffebld_conter (r)));
4787           expr = ffebld_new_conter_with_orig
4788             (ffebld_constant_new_logicaldefault (val), expr);
4789           break;
4790 #endif
4791
4792 #if FFETARGET_okCOMPLEX4
4793         case FFEINFO_kindtypeREAL4:
4794           error = ffetarget_eq_complex4 (&val,
4795                                ffebld_constant_complex4 (ffebld_conter (l)),
4796                               ffebld_constant_complex4 (ffebld_conter (r)));
4797           expr = ffebld_new_conter_with_orig
4798             (ffebld_constant_new_logicaldefault (val), expr);
4799           break;
4800 #endif
4801
4802         default:
4803           assert ("bad complex kind type" == NULL);
4804           break;
4805         }
4806       break;
4807
4808     case FFEINFO_basictypeCHARACTER:
4809       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4810         {
4811 #if FFETARGET_okCHARACTER1
4812         case FFEINFO_kindtypeCHARACTER1:
4813           error = ffetarget_eq_character1 (&val,
4814                              ffebld_constant_character1 (ffebld_conter (l)),
4815                             ffebld_constant_character1 (ffebld_conter (r)));
4816           expr = ffebld_new_conter_with_orig
4817             (ffebld_constant_new_logicaldefault (val), expr);
4818           break;
4819 #endif
4820
4821 #if FFETARGET_okCHARACTER2
4822         case FFEINFO_kindtypeCHARACTER2:
4823           error = ffetarget_eq_character2 (&val,
4824                              ffebld_constant_character2 (ffebld_conter (l)),
4825                             ffebld_constant_character2 (ffebld_conter (r)));
4826           expr = ffebld_new_conter_with_orig
4827             (ffebld_constant_new_logicaldefault (val), expr);
4828           break;
4829 #endif
4830
4831 #if FFETARGET_okCHARACTER3
4832         case FFEINFO_kindtypeCHARACTER3:
4833           error = ffetarget_eq_character3 (&val,
4834                              ffebld_constant_character3 (ffebld_conter (l)),
4835                             ffebld_constant_character3 (ffebld_conter (r)));
4836           expr = ffebld_new_conter_with_orig
4837             (ffebld_constant_new_logicaldefault (val), expr);
4838           break;
4839 #endif
4840
4841 #if FFETARGET_okCHARACTER4
4842         case FFEINFO_kindtypeCHARACTER4:
4843           error = ffetarget_eq_character4 (&val,
4844                              ffebld_constant_character4 (ffebld_conter (l)),
4845                             ffebld_constant_character4 (ffebld_conter (r)));
4846           expr = ffebld_new_conter_with_orig
4847             (ffebld_constant_new_logicaldefault (val), expr);
4848           break;
4849 #endif
4850
4851         default:
4852           assert ("bad character kind type" == NULL);
4853           break;
4854         }
4855       break;
4856
4857     default:
4858       assert ("bad type" == NULL);
4859       return expr;
4860     }
4861
4862   ffebld_set_info (expr, ffeinfo_new
4863                    (FFEINFO_basictypeLOGICAL,
4864                     FFEINFO_kindtypeLOGICALDEFAULT,
4865                     0,
4866                     FFEINFO_kindENTITY,
4867                     FFEINFO_whereCONSTANT,
4868                     FFETARGET_charactersizeNONE));
4869
4870   if ((error != FFEBAD)
4871       && ffebad_start (error))
4872     {
4873       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4874       ffebad_finish ();
4875     }
4876
4877   return expr;
4878 }
4879
4880 /* ffeexpr_collapse_ne -- Collapse ne expr
4881
4882    ffebld expr;
4883    ffelexToken token;
4884    expr = ffeexpr_collapse_ne(expr,token);
4885
4886    If the result of the expr is a constant, replaces the expr with the
4887    computed constant.  */
4888
4889 ffebld
4890 ffeexpr_collapse_ne (ffebld expr, ffelexToken t)
4891 {
4892   ffebad error = FFEBAD;
4893   ffebld l;
4894   ffebld r;
4895   bool val;
4896
4897   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4898     return expr;
4899
4900   l = ffebld_left (expr);
4901   r = ffebld_right (expr);
4902
4903   if (ffebld_op (l) != FFEBLD_opCONTER)
4904     return expr;
4905   if (ffebld_op (r) != FFEBLD_opCONTER)
4906     return expr;
4907
4908   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4909     {
4910     case FFEINFO_basictypeANY:
4911       return expr;
4912
4913     case FFEINFO_basictypeINTEGER:
4914       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4915         {
4916 #if FFETARGET_okINTEGER1
4917         case FFEINFO_kindtypeINTEGER1:
4918           error = ffetarget_ne_integer1 (&val,
4919                                ffebld_constant_integer1 (ffebld_conter (l)),
4920                               ffebld_constant_integer1 (ffebld_conter (r)));
4921           expr = ffebld_new_conter_with_orig
4922             (ffebld_constant_new_logicaldefault (val), expr);
4923           break;
4924 #endif
4925
4926 #if FFETARGET_okINTEGER2
4927         case FFEINFO_kindtypeINTEGER2:
4928           error = ffetarget_ne_integer2 (&val,
4929                                ffebld_constant_integer2 (ffebld_conter (l)),
4930                               ffebld_constant_integer2 (ffebld_conter (r)));
4931           expr = ffebld_new_conter_with_orig
4932             (ffebld_constant_new_logicaldefault (val), expr);
4933           break;
4934 #endif
4935
4936 #if FFETARGET_okINTEGER3
4937         case FFEINFO_kindtypeINTEGER3:
4938           error = ffetarget_ne_integer3 (&val,
4939                                ffebld_constant_integer3 (ffebld_conter (l)),
4940                               ffebld_constant_integer3 (ffebld_conter (r)));
4941           expr = ffebld_new_conter_with_orig
4942             (ffebld_constant_new_logicaldefault (val), expr);
4943           break;
4944 #endif
4945
4946 #if FFETARGET_okINTEGER4
4947         case FFEINFO_kindtypeINTEGER4:
4948           error = ffetarget_ne_integer4 (&val,
4949                                ffebld_constant_integer4 (ffebld_conter (l)),
4950                               ffebld_constant_integer4 (ffebld_conter (r)));
4951           expr = ffebld_new_conter_with_orig
4952             (ffebld_constant_new_logicaldefault (val), expr);
4953           break;
4954 #endif
4955
4956         default:
4957           assert ("bad integer kind type" == NULL);
4958           break;
4959         }
4960       break;
4961
4962     case FFEINFO_basictypeREAL:
4963       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4964         {
4965 #if FFETARGET_okREAL1
4966         case FFEINFO_kindtypeREAL1:
4967           error = ffetarget_ne_real1 (&val,
4968                                   ffebld_constant_real1 (ffebld_conter (l)),
4969                                  ffebld_constant_real1 (ffebld_conter (r)));
4970           expr = ffebld_new_conter_with_orig
4971             (ffebld_constant_new_logicaldefault (val), expr);
4972           break;
4973 #endif
4974
4975 #if FFETARGET_okREAL2
4976         case FFEINFO_kindtypeREAL2:
4977           error = ffetarget_ne_real2 (&val,
4978                                   ffebld_constant_real2 (ffebld_conter (l)),
4979                                  ffebld_constant_real2 (ffebld_conter (r)));
4980           expr = ffebld_new_conter_with_orig
4981             (ffebld_constant_new_logicaldefault (val), expr);
4982           break;
4983 #endif
4984
4985 #if FFETARGET_okREAL3
4986         case FFEINFO_kindtypeREAL3:
4987           error = ffetarget_ne_real3 (&val,
4988                                   ffebld_constant_real3 (ffebld_conter (l)),
4989                                  ffebld_constant_real3 (ffebld_conter (r)));
4990           expr = ffebld_new_conter_with_orig
4991             (ffebld_constant_new_logicaldefault (val), expr);
4992           break;
4993 #endif
4994
4995 #if FFETARGET_okREAL4
4996         case FFEINFO_kindtypeREAL4:
4997           error = ffetarget_ne_real4 (&val,
4998                                   ffebld_constant_real4 (ffebld_conter (l)),
4999                                  ffebld_constant_real4 (ffebld_conter (r)));
5000           expr = ffebld_new_conter_with_orig
5001             (ffebld_constant_new_logicaldefault (val), expr);
5002           break;
5003 #endif
5004
5005         default:
5006           assert ("bad real kind type" == NULL);
5007           break;
5008         }
5009       break;
5010
5011     case FFEINFO_basictypeCOMPLEX:
5012       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5013         {
5014 #if FFETARGET_okCOMPLEX1
5015         case FFEINFO_kindtypeREAL1:
5016           error = ffetarget_ne_complex1 (&val,
5017                                ffebld_constant_complex1 (ffebld_conter (l)),
5018                               ffebld_constant_complex1 (ffebld_conter (r)));
5019           expr = ffebld_new_conter_with_orig
5020             (ffebld_constant_new_logicaldefault (val), expr);
5021           break;
5022 #endif
5023
5024 #if FFETARGET_okCOMPLEX2
5025         case FFEINFO_kindtypeREAL2:
5026           error = ffetarget_ne_complex2 (&val,
5027                                ffebld_constant_complex2 (ffebld_conter (l)),
5028                               ffebld_constant_complex2 (ffebld_conter (r)));
5029           expr = ffebld_new_conter_with_orig
5030             (ffebld_constant_new_logicaldefault (val), expr);
5031           break;
5032 #endif
5033
5034 #if FFETARGET_okCOMPLEX3
5035         case FFEINFO_kindtypeREAL3:
5036           error = ffetarget_ne_complex3 (&val,
5037                                ffebld_constant_complex3 (ffebld_conter (l)),
5038                               ffebld_constant_complex3 (ffebld_conter (r)));
5039           expr = ffebld_new_conter_with_orig
5040             (ffebld_constant_new_logicaldefault (val), expr);
5041           break;
5042 #endif
5043
5044 #if FFETARGET_okCOMPLEX4
5045         case FFEINFO_kindtypeREAL4:
5046           error = ffetarget_ne_complex4 (&val,
5047                                ffebld_constant_complex4 (ffebld_conter (l)),
5048                               ffebld_constant_complex4 (ffebld_conter (r)));
5049           expr = ffebld_new_conter_with_orig
5050             (ffebld_constant_new_logicaldefault (val), expr);
5051           break;
5052 #endif
5053
5054         default:
5055           assert ("bad complex kind type" == NULL);
5056           break;
5057         }
5058       break;
5059
5060     case FFEINFO_basictypeCHARACTER:
5061       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5062         {
5063 #if FFETARGET_okCHARACTER1
5064         case FFEINFO_kindtypeCHARACTER1:
5065           error = ffetarget_ne_character1 (&val,
5066                              ffebld_constant_character1 (ffebld_conter (l)),
5067                             ffebld_constant_character1 (ffebld_conter (r)));
5068           expr = ffebld_new_conter_with_orig
5069             (ffebld_constant_new_logicaldefault (val), expr);
5070           break;
5071 #endif
5072
5073 #if FFETARGET_okCHARACTER2
5074         case FFEINFO_kindtypeCHARACTER2:
5075           error = ffetarget_ne_character2 (&val,
5076                              ffebld_constant_character2 (ffebld_conter (l)),
5077                             ffebld_constant_character2 (ffebld_conter (r)));
5078           expr = ffebld_new_conter_with_orig
5079             (ffebld_constant_new_logicaldefault (val), expr);
5080           break;
5081 #endif
5082
5083 #if FFETARGET_okCHARACTER3
5084         case FFEINFO_kindtypeCHARACTER3:
5085           error = ffetarget_ne_character3 (&val,
5086                              ffebld_constant_character3 (ffebld_conter (l)),
5087                             ffebld_constant_character3 (ffebld_conter (r)));
5088           expr = ffebld_new_conter_with_orig
5089             (ffebld_constant_new_logicaldefault (val), expr);
5090           break;
5091 #endif
5092
5093 #if FFETARGET_okCHARACTER4
5094         case FFEINFO_kindtypeCHARACTER4:
5095           error = ffetarget_ne_character4 (&val,
5096                              ffebld_constant_character4 (ffebld_conter (l)),
5097                             ffebld_constant_character4 (ffebld_conter (r)));
5098           expr = ffebld_new_conter_with_orig
5099             (ffebld_constant_new_logicaldefault (val), expr);
5100           break;
5101 #endif
5102
5103         default:
5104           assert ("bad character kind type" == NULL);
5105           break;
5106         }
5107       break;
5108
5109     default:
5110       assert ("bad type" == NULL);
5111       return expr;
5112     }
5113
5114   ffebld_set_info (expr, ffeinfo_new
5115                    (FFEINFO_basictypeLOGICAL,
5116                     FFEINFO_kindtypeLOGICALDEFAULT,
5117                     0,
5118                     FFEINFO_kindENTITY,
5119                     FFEINFO_whereCONSTANT,
5120                     FFETARGET_charactersizeNONE));
5121
5122   if ((error != FFEBAD)
5123       && ffebad_start (error))
5124     {
5125       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5126       ffebad_finish ();
5127     }
5128
5129   return expr;
5130 }
5131
5132 /* ffeexpr_collapse_ge -- Collapse ge expr
5133
5134    ffebld expr;
5135    ffelexToken token;
5136    expr = ffeexpr_collapse_ge(expr,token);
5137
5138    If the result of the expr is a constant, replaces the expr with the
5139    computed constant.  */
5140
5141 ffebld
5142 ffeexpr_collapse_ge (ffebld expr, ffelexToken t)
5143 {
5144   ffebad error = FFEBAD;
5145   ffebld l;
5146   ffebld r;
5147   bool val;
5148
5149   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5150     return expr;
5151
5152   l = ffebld_left (expr);
5153   r = ffebld_right (expr);
5154
5155   if (ffebld_op (l) != FFEBLD_opCONTER)
5156     return expr;
5157   if (ffebld_op (r) != FFEBLD_opCONTER)
5158     return expr;
5159
5160   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5161     {
5162     case FFEINFO_basictypeANY:
5163       return expr;
5164
5165     case FFEINFO_basictypeINTEGER:
5166       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5167         {
5168 #if FFETARGET_okINTEGER1
5169         case FFEINFO_kindtypeINTEGER1:
5170           error = ffetarget_ge_integer1 (&val,
5171                                ffebld_constant_integer1 (ffebld_conter (l)),
5172                               ffebld_constant_integer1 (ffebld_conter (r)));
5173           expr = ffebld_new_conter_with_orig
5174             (ffebld_constant_new_logicaldefault (val), expr);
5175           break;
5176 #endif
5177
5178 #if FFETARGET_okINTEGER2
5179         case FFEINFO_kindtypeINTEGER2:
5180           error = ffetarget_ge_integer2 (&val,
5181                                ffebld_constant_integer2 (ffebld_conter (l)),
5182                               ffebld_constant_integer2 (ffebld_conter (r)));
5183           expr = ffebld_new_conter_with_orig
5184             (ffebld_constant_new_logicaldefault (val), expr);
5185           break;
5186 #endif
5187
5188 #if FFETARGET_okINTEGER3
5189         case FFEINFO_kindtypeINTEGER3:
5190           error = ffetarget_ge_integer3 (&val,
5191                                ffebld_constant_integer3 (ffebld_conter (l)),
5192                               ffebld_constant_integer3 (ffebld_conter (r)));
5193           expr = ffebld_new_conter_with_orig
5194             (ffebld_constant_new_logicaldefault (val), expr);
5195           break;
5196 #endif
5197
5198 #if FFETARGET_okINTEGER4
5199         case FFEINFO_kindtypeINTEGER4:
5200           error = ffetarget_ge_integer4 (&val,
5201                                ffebld_constant_integer4 (ffebld_conter (l)),
5202                               ffebld_constant_integer4 (ffebld_conter (r)));
5203           expr = ffebld_new_conter_with_orig
5204             (ffebld_constant_new_logicaldefault (val), expr);
5205           break;
5206 #endif
5207
5208         default:
5209           assert ("bad integer kind type" == NULL);
5210           break;
5211         }
5212       break;
5213
5214     case FFEINFO_basictypeREAL:
5215       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5216         {
5217 #if FFETARGET_okREAL1
5218         case FFEINFO_kindtypeREAL1:
5219           error = ffetarget_ge_real1 (&val,
5220                                   ffebld_constant_real1 (ffebld_conter (l)),
5221                                  ffebld_constant_real1 (ffebld_conter (r)));
5222           expr = ffebld_new_conter_with_orig
5223             (ffebld_constant_new_logicaldefault (val), expr);
5224           break;
5225 #endif
5226
5227 #if FFETARGET_okREAL2
5228         case FFEINFO_kindtypeREAL2:
5229           error = ffetarget_ge_real2 (&val,
5230                                   ffebld_constant_real2 (ffebld_conter (l)),
5231                                  ffebld_constant_real2 (ffebld_conter (r)));
5232           expr = ffebld_new_conter_with_orig
5233             (ffebld_constant_new_logicaldefault (val), expr);
5234           break;
5235 #endif
5236
5237 #if FFETARGET_okREAL3
5238         case FFEINFO_kindtypeREAL3:
5239           error = ffetarget_ge_real3 (&val,
5240                                   ffebld_constant_real3 (ffebld_conter (l)),
5241                                  ffebld_constant_real3 (ffebld_conter (r)));
5242           expr = ffebld_new_conter_with_orig
5243             (ffebld_constant_new_logicaldefault (val), expr);
5244           break;
5245 #endif
5246
5247 #if FFETARGET_okREAL4
5248         case FFEINFO_kindtypeREAL4:
5249           error = ffetarget_ge_real4 (&val,
5250                                   ffebld_constant_real4 (ffebld_conter (l)),
5251                                  ffebld_constant_real4 (ffebld_conter (r)));
5252           expr = ffebld_new_conter_with_orig
5253             (ffebld_constant_new_logicaldefault (val), expr);
5254           break;
5255 #endif
5256
5257         default:
5258           assert ("bad real kind type" == NULL);
5259           break;
5260         }
5261       break;
5262
5263     case FFEINFO_basictypeCHARACTER:
5264       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5265         {
5266 #if FFETARGET_okCHARACTER1
5267         case FFEINFO_kindtypeCHARACTER1:
5268           error = ffetarget_ge_character1 (&val,
5269                              ffebld_constant_character1 (ffebld_conter (l)),
5270                             ffebld_constant_character1 (ffebld_conter (r)));
5271           expr = ffebld_new_conter_with_orig
5272             (ffebld_constant_new_logicaldefault (val), expr);
5273           break;
5274 #endif
5275
5276 #if FFETARGET_okCHARACTER2
5277         case FFEINFO_kindtypeCHARACTER2:
5278           error = ffetarget_ge_character2 (&val,
5279                              ffebld_constant_character2 (ffebld_conter (l)),
5280                             ffebld_constant_character2 (ffebld_conter (r)));
5281           expr = ffebld_new_conter_with_orig
5282             (ffebld_constant_new_logicaldefault (val), expr);
5283           break;
5284 #endif
5285
5286 #if FFETARGET_okCHARACTER3
5287         case FFEINFO_kindtypeCHARACTER3:
5288           error = ffetarget_ge_character3 (&val,
5289                              ffebld_constant_character3 (ffebld_conter (l)),
5290                             ffebld_constant_character3 (ffebld_conter (r)));
5291           expr = ffebld_new_conter_with_orig
5292             (ffebld_constant_new_logicaldefault (val), expr);
5293           break;
5294 #endif
5295
5296 #if FFETARGET_okCHARACTER4
5297         case FFEINFO_kindtypeCHARACTER4:
5298           error = ffetarget_ge_character4 (&val,
5299                              ffebld_constant_character4 (ffebld_conter (l)),
5300                             ffebld_constant_character4 (ffebld_conter (r)));
5301           expr = ffebld_new_conter_with_orig
5302             (ffebld_constant_new_logicaldefault (val), expr);
5303           break;
5304 #endif
5305
5306         default:
5307           assert ("bad character kind type" == NULL);
5308           break;
5309         }
5310       break;
5311
5312     default:
5313       assert ("bad type" == NULL);
5314       return expr;
5315     }
5316
5317   ffebld_set_info (expr, ffeinfo_new
5318                    (FFEINFO_basictypeLOGICAL,
5319                     FFEINFO_kindtypeLOGICALDEFAULT,
5320                     0,
5321                     FFEINFO_kindENTITY,
5322                     FFEINFO_whereCONSTANT,
5323                     FFETARGET_charactersizeNONE));
5324
5325   if ((error != FFEBAD)
5326       && ffebad_start (error))
5327     {
5328       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5329       ffebad_finish ();
5330     }
5331
5332   return expr;
5333 }
5334
5335 /* ffeexpr_collapse_gt -- Collapse gt expr
5336
5337    ffebld expr;
5338    ffelexToken token;
5339    expr = ffeexpr_collapse_gt(expr,token);
5340
5341    If the result of the expr is a constant, replaces the expr with the
5342    computed constant.  */
5343
5344 ffebld
5345 ffeexpr_collapse_gt (ffebld expr, ffelexToken t)
5346 {
5347   ffebad error = FFEBAD;
5348   ffebld l;
5349   ffebld r;
5350   bool val;
5351
5352   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5353     return expr;
5354
5355   l = ffebld_left (expr);
5356   r = ffebld_right (expr);
5357
5358   if (ffebld_op (l) != FFEBLD_opCONTER)
5359     return expr;
5360   if (ffebld_op (r) != FFEBLD_opCONTER)
5361     return expr;
5362
5363   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5364     {
5365     case FFEINFO_basictypeANY:
5366       return expr;
5367
5368     case FFEINFO_basictypeINTEGER:
5369       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5370         {
5371 #if FFETARGET_okINTEGER1
5372         case FFEINFO_kindtypeINTEGER1:
5373           error = ffetarget_gt_integer1 (&val,
5374                                ffebld_constant_integer1 (ffebld_conter (l)),
5375                               ffebld_constant_integer1 (ffebld_conter (r)));
5376           expr = ffebld_new_conter_with_orig
5377             (ffebld_constant_new_logicaldefault (val), expr);
5378           break;
5379 #endif
5380
5381 #if FFETARGET_okINTEGER2
5382         case FFEINFO_kindtypeINTEGER2:
5383           error = ffetarget_gt_integer2 (&val,
5384                                ffebld_constant_integer2 (ffebld_conter (l)),
5385                               ffebld_constant_integer2 (ffebld_conter (r)));
5386           expr = ffebld_new_conter_with_orig
5387             (ffebld_constant_new_logicaldefault (val), expr);
5388           break;
5389 #endif
5390
5391 #if FFETARGET_okINTEGER3
5392         case FFEINFO_kindtypeINTEGER3:
5393           error = ffetarget_gt_integer3 (&val,
5394                                ffebld_constant_integer3 (ffebld_conter (l)),
5395                               ffebld_constant_integer3 (ffebld_conter (r)));
5396           expr = ffebld_new_conter_with_orig
5397             (ffebld_constant_new_logicaldefault (val), expr);
5398           break;
5399 #endif
5400
5401 #if FFETARGET_okINTEGER4
5402         case FFEINFO_kindtypeINTEGER4:
5403           error = ffetarget_gt_integer4 (&val,
5404                                ffebld_constant_integer4 (ffebld_conter (l)),
5405                               ffebld_constant_integer4 (ffebld_conter (r)));
5406           expr = ffebld_new_conter_with_orig
5407             (ffebld_constant_new_logicaldefault (val), expr);
5408           break;
5409 #endif
5410
5411         default:
5412           assert ("bad integer kind type" == NULL);
5413           break;
5414         }
5415       break;
5416
5417     case FFEINFO_basictypeREAL:
5418       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5419         {
5420 #if FFETARGET_okREAL1
5421         case FFEINFO_kindtypeREAL1:
5422           error = ffetarget_gt_real1 (&val,
5423                                   ffebld_constant_real1 (ffebld_conter (l)),
5424                                  ffebld_constant_real1 (ffebld_conter (r)));
5425           expr = ffebld_new_conter_with_orig
5426             (ffebld_constant_new_logicaldefault (val), expr);
5427           break;
5428 #endif
5429
5430 #if FFETARGET_okREAL2
5431         case FFEINFO_kindtypeREAL2:
5432           error = ffetarget_gt_real2 (&val,
5433                                   ffebld_constant_real2 (ffebld_conter (l)),
5434                                  ffebld_constant_real2 (ffebld_conter (r)));
5435           expr = ffebld_new_conter_with_orig
5436             (ffebld_constant_new_logicaldefault (val), expr);
5437           break;
5438 #endif
5439
5440 #if FFETARGET_okREAL3
5441         case FFEINFO_kindtypeREAL3:
5442           error = ffetarget_gt_real3 (&val,
5443                                   ffebld_constant_real3 (ffebld_conter (l)),
5444                                  ffebld_constant_real3 (ffebld_conter (r)));
5445           expr = ffebld_new_conter_with_orig
5446             (ffebld_constant_new_logicaldefault (val), expr);
5447           break;
5448 #endif
5449
5450 #if FFETARGET_okREAL4
5451         case FFEINFO_kindtypeREAL4:
5452           error = ffetarget_gt_real4 (&val,
5453                                   ffebld_constant_real4 (ffebld_conter (l)),
5454                                  ffebld_constant_real4 (ffebld_conter (r)));
5455           expr = ffebld_new_conter_with_orig
5456             (ffebld_constant_new_logicaldefault (val), expr);
5457           break;
5458 #endif
5459
5460         default:
5461           assert ("bad real kind type" == NULL);
5462           break;
5463         }
5464       break;
5465
5466     case FFEINFO_basictypeCHARACTER:
5467       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5468         {
5469 #if FFETARGET_okCHARACTER1
5470         case FFEINFO_kindtypeCHARACTER1:
5471           error = ffetarget_gt_character1 (&val,
5472                              ffebld_constant_character1 (ffebld_conter (l)),
5473                             ffebld_constant_character1 (ffebld_conter (r)));
5474           expr = ffebld_new_conter_with_orig
5475             (ffebld_constant_new_logicaldefault (val), expr);
5476           break;
5477 #endif
5478
5479 #if FFETARGET_okCHARACTER2
5480         case FFEINFO_kindtypeCHARACTER2:
5481           error = ffetarget_gt_character2 (&val,
5482                              ffebld_constant_character2 (ffebld_conter (l)),
5483                             ffebld_constant_character2 (ffebld_conter (r)));
5484           expr = ffebld_new_conter_with_orig
5485             (ffebld_constant_new_logicaldefault (val), expr);
5486           break;
5487 #endif
5488
5489 #if FFETARGET_okCHARACTER3
5490         case FFEINFO_kindtypeCHARACTER3:
5491           error = ffetarget_gt_character3 (&val,
5492                              ffebld_constant_character3 (ffebld_conter (l)),
5493                             ffebld_constant_character3 (ffebld_conter (r)));
5494           expr = ffebld_new_conter_with_orig
5495             (ffebld_constant_new_logicaldefault (val), expr);
5496           break;
5497 #endif
5498
5499 #if FFETARGET_okCHARACTER4
5500         case FFEINFO_kindtypeCHARACTER4:
5501           error = ffetarget_gt_character4 (&val,
5502                              ffebld_constant_character4 (ffebld_conter (l)),
5503                             ffebld_constant_character4 (ffebld_conter (r)));
5504           expr = ffebld_new_conter_with_orig
5505             (ffebld_constant_new_logicaldefault (val), expr);
5506           break;
5507 #endif
5508
5509         default:
5510           assert ("bad character kind type" == NULL);
5511           break;
5512         }
5513       break;
5514
5515     default:
5516       assert ("bad type" == NULL);
5517       return expr;
5518     }
5519
5520   ffebld_set_info (expr, ffeinfo_new
5521                    (FFEINFO_basictypeLOGICAL,
5522                     FFEINFO_kindtypeLOGICALDEFAULT,
5523                     0,
5524                     FFEINFO_kindENTITY,
5525                     FFEINFO_whereCONSTANT,
5526                     FFETARGET_charactersizeNONE));
5527
5528   if ((error != FFEBAD)
5529       && ffebad_start (error))
5530     {
5531       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5532       ffebad_finish ();
5533     }
5534
5535   return expr;
5536 }
5537
5538 /* ffeexpr_collapse_le -- Collapse le expr
5539
5540    ffebld expr;
5541    ffelexToken token;
5542    expr = ffeexpr_collapse_le(expr,token);
5543
5544    If the result of the expr is a constant, replaces the expr with the
5545    computed constant.  */
5546
5547 ffebld
5548 ffeexpr_collapse_le (ffebld expr, ffelexToken t)
5549 {
5550   ffebad error = FFEBAD;
5551   ffebld l;
5552   ffebld r;
5553   bool val;
5554
5555   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5556     return expr;
5557
5558   l = ffebld_left (expr);
5559   r = ffebld_right (expr);
5560
5561   if (ffebld_op (l) != FFEBLD_opCONTER)
5562     return expr;
5563   if (ffebld_op (r) != FFEBLD_opCONTER)
5564     return expr;
5565
5566   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5567     {
5568     case FFEINFO_basictypeANY:
5569       return expr;
5570
5571     case FFEINFO_basictypeINTEGER:
5572       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5573         {
5574 #if FFETARGET_okINTEGER1
5575         case FFEINFO_kindtypeINTEGER1:
5576           error = ffetarget_le_integer1 (&val,
5577                                ffebld_constant_integer1 (ffebld_conter (l)),
5578                               ffebld_constant_integer1 (ffebld_conter (r)));
5579           expr = ffebld_new_conter_with_orig
5580             (ffebld_constant_new_logicaldefault (val), expr);
5581           break;
5582 #endif
5583
5584 #if FFETARGET_okINTEGER2
5585         case FFEINFO_kindtypeINTEGER2:
5586           error = ffetarget_le_integer2 (&val,
5587                                ffebld_constant_integer2 (ffebld_conter (l)),
5588                               ffebld_constant_integer2 (ffebld_conter (r)));
5589           expr = ffebld_new_conter_with_orig
5590             (ffebld_constant_new_logicaldefault (val), expr);
5591           break;
5592 #endif
5593
5594 #if FFETARGET_okINTEGER3
5595         case FFEINFO_kindtypeINTEGER3:
5596           error = ffetarget_le_integer3 (&val,
5597                                ffebld_constant_integer3 (ffebld_conter (l)),
5598                               ffebld_constant_integer3 (ffebld_conter (r)));
5599           expr = ffebld_new_conter_with_orig
5600             (ffebld_constant_new_logicaldefault (val), expr);
5601           break;
5602 #endif
5603
5604 #if FFETARGET_okINTEGER4
5605         case FFEINFO_kindtypeINTEGER4:
5606           error = ffetarget_le_integer4 (&val,
5607                                ffebld_constant_integer4 (ffebld_conter (l)),
5608                               ffebld_constant_integer4 (ffebld_conter (r)));
5609           expr = ffebld_new_conter_with_orig
5610             (ffebld_constant_new_logicaldefault (val), expr);
5611           break;
5612 #endif
5613
5614         default:
5615           assert ("bad integer kind type" == NULL);
5616           break;
5617         }
5618       break;
5619
5620     case FFEINFO_basictypeREAL:
5621       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5622         {
5623 #if FFETARGET_okREAL1
5624         case FFEINFO_kindtypeREAL1:
5625           error = ffetarget_le_real1 (&val,
5626                                   ffebld_constant_real1 (ffebld_conter (l)),
5627                                  ffebld_constant_real1 (ffebld_conter (r)));
5628           expr = ffebld_new_conter_with_orig
5629             (ffebld_constant_new_logicaldefault (val), expr);
5630           break;
5631 #endif
5632
5633 #if FFETARGET_okREAL2
5634         case FFEINFO_kindtypeREAL2:
5635           error = ffetarget_le_real2 (&val,
5636                                   ffebld_constant_real2 (ffebld_conter (l)),
5637                                  ffebld_constant_real2 (ffebld_conter (r)));
5638           expr = ffebld_new_conter_with_orig
5639             (ffebld_constant_new_logicaldefault (val), expr);
5640           break;
5641 #endif
5642
5643 #if FFETARGET_okREAL3
5644         case FFEINFO_kindtypeREAL3:
5645           error = ffetarget_le_real3 (&val,
5646                                   ffebld_constant_real3 (ffebld_conter (l)),
5647                                  ffebld_constant_real3 (ffebld_conter (r)));
5648           expr = ffebld_new_conter_with_orig
5649             (ffebld_constant_new_logicaldefault (val), expr);
5650           break;
5651 #endif
5652
5653 #if FFETARGET_okREAL4
5654         case FFEINFO_kindtypeREAL4:
5655           error = ffetarget_le_real4 (&val,
5656                                   ffebld_constant_real4 (ffebld_conter (l)),
5657                                  ffebld_constant_real4 (ffebld_conter (r)));
5658           expr = ffebld_new_conter_with_orig
5659             (ffebld_constant_new_logicaldefault (val), expr);
5660           break;
5661 #endif
5662
5663         default:
5664           assert ("bad real kind type" == NULL);
5665           break;
5666         }
5667       break;
5668
5669     case FFEINFO_basictypeCHARACTER:
5670       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5671         {
5672 #if FFETARGET_okCHARACTER1
5673         case FFEINFO_kindtypeCHARACTER1:
5674           error = ffetarget_le_character1 (&val,
5675                              ffebld_constant_character1 (ffebld_conter (l)),
5676                             ffebld_constant_character1 (ffebld_conter (r)));
5677           expr = ffebld_new_conter_with_orig
5678             (ffebld_constant_new_logicaldefault (val), expr);
5679           break;
5680 #endif
5681
5682 #if FFETARGET_okCHARACTER2
5683         case FFEINFO_kindtypeCHARACTER2:
5684           error = ffetarget_le_character2 (&val,
5685                              ffebld_constant_character2 (ffebld_conter (l)),
5686                             ffebld_constant_character2 (ffebld_conter (r)));
5687           expr = ffebld_new_conter_with_orig
5688             (ffebld_constant_new_logicaldefault (val), expr);
5689           break;
5690 #endif
5691
5692 #if FFETARGET_okCHARACTER3
5693         case FFEINFO_kindtypeCHARACTER3:
5694           error = ffetarget_le_character3 (&val,
5695                              ffebld_constant_character3 (ffebld_conter (l)),
5696                             ffebld_constant_character3 (ffebld_conter (r)));
5697           expr = ffebld_new_conter_with_orig
5698             (ffebld_constant_new_logicaldefault (val), expr);
5699           break;
5700 #endif
5701
5702 #if FFETARGET_okCHARACTER4
5703         case FFEINFO_kindtypeCHARACTER4:
5704           error = ffetarget_le_character4 (&val,
5705                              ffebld_constant_character4 (ffebld_conter (l)),
5706                             ffebld_constant_character4 (ffebld_conter (r)));
5707           expr = ffebld_new_conter_with_orig
5708             (ffebld_constant_new_logicaldefault (val), expr);
5709           break;
5710 #endif
5711
5712         default:
5713           assert ("bad character kind type" == NULL);
5714           break;
5715         }
5716       break;
5717
5718     default:
5719       assert ("bad type" == NULL);
5720       return expr;
5721     }
5722
5723   ffebld_set_info (expr, ffeinfo_new
5724                    (FFEINFO_basictypeLOGICAL,
5725                     FFEINFO_kindtypeLOGICALDEFAULT,
5726                     0,
5727                     FFEINFO_kindENTITY,
5728                     FFEINFO_whereCONSTANT,
5729                     FFETARGET_charactersizeNONE));
5730
5731   if ((error != FFEBAD)
5732       && ffebad_start (error))
5733     {
5734       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5735       ffebad_finish ();
5736     }
5737
5738   return expr;
5739 }
5740
5741 /* ffeexpr_collapse_lt -- Collapse lt expr
5742
5743    ffebld expr;
5744    ffelexToken token;
5745    expr = ffeexpr_collapse_lt(expr,token);
5746
5747    If the result of the expr is a constant, replaces the expr with the
5748    computed constant.  */
5749
5750 ffebld
5751 ffeexpr_collapse_lt (ffebld expr, ffelexToken t)
5752 {
5753   ffebad error = FFEBAD;
5754   ffebld l;
5755   ffebld r;
5756   bool val;
5757
5758   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5759     return expr;
5760
5761   l = ffebld_left (expr);
5762   r = ffebld_right (expr);
5763
5764   if (ffebld_op (l) != FFEBLD_opCONTER)
5765     return expr;
5766   if (ffebld_op (r) != FFEBLD_opCONTER)
5767     return expr;
5768
5769   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5770     {
5771     case FFEINFO_basictypeANY:
5772       return expr;
5773
5774     case FFEINFO_basictypeINTEGER:
5775       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5776         {
5777 #if FFETARGET_okINTEGER1
5778         case FFEINFO_kindtypeINTEGER1:
5779           error = ffetarget_lt_integer1 (&val,
5780                                ffebld_constant_integer1 (ffebld_conter (l)),
5781                               ffebld_constant_integer1 (ffebld_conter (r)));
5782           expr = ffebld_new_conter_with_orig
5783             (ffebld_constant_new_logicaldefault (val), expr);
5784           break;
5785 #endif
5786
5787 #if FFETARGET_okINTEGER2
5788         case FFEINFO_kindtypeINTEGER2:
5789           error = ffetarget_lt_integer2 (&val,
5790                                ffebld_constant_integer2 (ffebld_conter (l)),
5791                               ffebld_constant_integer2 (ffebld_conter (r)));
5792           expr = ffebld_new_conter_with_orig
5793             (ffebld_constant_new_logicaldefault (val), expr);
5794           break;
5795 #endif
5796
5797 #if FFETARGET_okINTEGER3
5798         case FFEINFO_kindtypeINTEGER3:
5799           error = ffetarget_lt_integer3 (&val,
5800                                ffebld_constant_integer3 (ffebld_conter (l)),
5801                               ffebld_constant_integer3 (ffebld_conter (r)));
5802           expr = ffebld_new_conter_with_orig
5803             (ffebld_constant_new_logicaldefault (val), expr);
5804           break;
5805 #endif
5806
5807 #if FFETARGET_okINTEGER4
5808         case FFEINFO_kindtypeINTEGER4:
5809           error = ffetarget_lt_integer4 (&val,
5810                                ffebld_constant_integer4 (ffebld_conter (l)),
5811                               ffebld_constant_integer4 (ffebld_conter (r)));
5812           expr = ffebld_new_conter_with_orig
5813             (ffebld_constant_new_logicaldefault (val), expr);
5814           break;
5815 #endif
5816
5817         default:
5818           assert ("bad integer kind type" == NULL);
5819           break;
5820         }
5821       break;
5822
5823     case FFEINFO_basictypeREAL:
5824       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5825         {
5826 #if FFETARGET_okREAL1
5827         case FFEINFO_kindtypeREAL1:
5828           error = ffetarget_lt_real1 (&val,
5829                                   ffebld_constant_real1 (ffebld_conter (l)),
5830                                  ffebld_constant_real1 (ffebld_conter (r)));
5831           expr = ffebld_new_conter_with_orig
5832             (ffebld_constant_new_logicaldefault (val), expr);
5833           break;
5834 #endif
5835
5836 #if FFETARGET_okREAL2
5837         case FFEINFO_kindtypeREAL2:
5838           error = ffetarget_lt_real2 (&val,
5839                                   ffebld_constant_real2 (ffebld_conter (l)),
5840                                  ffebld_constant_real2 (ffebld_conter (r)));
5841           expr = ffebld_new_conter_with_orig
5842             (ffebld_constant_new_logicaldefault (val), expr);
5843           break;
5844 #endif
5845
5846 #if FFETARGET_okREAL3
5847         case FFEINFO_kindtypeREAL3:
5848           error = ffetarget_lt_real3 (&val,
5849                                   ffebld_constant_real3 (ffebld_conter (l)),
5850                                  ffebld_constant_real3 (ffebld_conter (r)));
5851           expr = ffebld_new_conter_with_orig
5852             (ffebld_constant_new_logicaldefault (val), expr);
5853           break;
5854 #endif
5855
5856 #if FFETARGET_okREAL4
5857         case FFEINFO_kindtypeREAL4:
5858           error = ffetarget_lt_real4 (&val,
5859                                   ffebld_constant_real4 (ffebld_conter (l)),
5860                                  ffebld_constant_real4 (ffebld_conter (r)));
5861           expr = ffebld_new_conter_with_orig
5862             (ffebld_constant_new_logicaldefault (val), expr);
5863           break;
5864 #endif
5865
5866         default:
5867           assert ("bad real kind type" == NULL);
5868           break;
5869         }
5870       break;
5871
5872     case FFEINFO_basictypeCHARACTER:
5873       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5874         {
5875 #if FFETARGET_okCHARACTER1
5876         case FFEINFO_kindtypeCHARACTER1:
5877           error = ffetarget_lt_character1 (&val,
5878                              ffebld_constant_character1 (ffebld_conter (l)),
5879                             ffebld_constant_character1 (ffebld_conter (r)));
5880           expr = ffebld_new_conter_with_orig
5881             (ffebld_constant_new_logicaldefault (val), expr);
5882           break;
5883 #endif
5884
5885 #if FFETARGET_okCHARACTER2
5886         case FFEINFO_kindtypeCHARACTER2:
5887           error = ffetarget_lt_character2 (&val,
5888                              ffebld_constant_character2 (ffebld_conter (l)),
5889                             ffebld_constant_character2 (ffebld_conter (r)));
5890           expr = ffebld_new_conter_with_orig
5891             (ffebld_constant_new_logicaldefault (val), expr);
5892           break;
5893 #endif
5894
5895 #if FFETARGET_okCHARACTER3
5896         case FFEINFO_kindtypeCHARACTER3:
5897           error = ffetarget_lt_character3 (&val,
5898                              ffebld_constant_character3 (ffebld_conter (l)),
5899                             ffebld_constant_character3 (ffebld_conter (r)));
5900           expr = ffebld_new_conter_with_orig
5901             (ffebld_constant_new_logicaldefault (val), expr);
5902           break;
5903 #endif
5904
5905 #if FFETARGET_okCHARACTER4
5906         case FFEINFO_kindtypeCHARACTER4:
5907           error = ffetarget_lt_character4 (&val,
5908                              ffebld_constant_character4 (ffebld_conter (l)),
5909                             ffebld_constant_character4 (ffebld_conter (r)));
5910           expr = ffebld_new_conter_with_orig
5911             (ffebld_constant_new_logicaldefault (val), expr);
5912           break;
5913 #endif
5914
5915         default:
5916           assert ("bad character kind type" == NULL);
5917           break;
5918         }
5919       break;
5920
5921     default:
5922       assert ("bad type" == NULL);
5923       return expr;
5924     }
5925
5926   ffebld_set_info (expr, ffeinfo_new
5927                    (FFEINFO_basictypeLOGICAL,
5928                     FFEINFO_kindtypeLOGICALDEFAULT,
5929                     0,
5930                     FFEINFO_kindENTITY,
5931                     FFEINFO_whereCONSTANT,
5932                     FFETARGET_charactersizeNONE));
5933
5934   if ((error != FFEBAD)
5935       && ffebad_start (error))
5936     {
5937       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5938       ffebad_finish ();
5939     }
5940
5941   return expr;
5942 }
5943
5944 /* ffeexpr_collapse_and -- Collapse and expr
5945
5946    ffebld expr;
5947    ffelexToken token;
5948    expr = ffeexpr_collapse_and(expr,token);
5949
5950    If the result of the expr is a constant, replaces the expr with the
5951    computed constant.  */
5952
5953 ffebld
5954 ffeexpr_collapse_and (ffebld expr, ffelexToken t)
5955 {
5956   ffebad error = FFEBAD;
5957   ffebld l;
5958   ffebld r;
5959   ffebldConstantUnion u;
5960   ffeinfoBasictype bt;
5961   ffeinfoKindtype kt;
5962
5963   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5964     return expr;
5965
5966   l = ffebld_left (expr);
5967   r = ffebld_right (expr);
5968
5969   if (ffebld_op (l) != FFEBLD_opCONTER)
5970     return expr;
5971   if (ffebld_op (r) != FFEBLD_opCONTER)
5972     return expr;
5973
5974   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5975     {
5976     case FFEINFO_basictypeANY:
5977       return expr;
5978
5979     case FFEINFO_basictypeINTEGER:
5980       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5981         {
5982 #if FFETARGET_okINTEGER1
5983         case FFEINFO_kindtypeINTEGER1:
5984           error = ffetarget_and_integer1 (ffebld_cu_ptr_integer1 (u),
5985                                ffebld_constant_integer1 (ffebld_conter (l)),
5986                               ffebld_constant_integer1 (ffebld_conter (r)));
5987           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5988                                         (ffebld_cu_val_integer1 (u)), expr);
5989           break;
5990 #endif
5991
5992 #if FFETARGET_okINTEGER2
5993         case FFEINFO_kindtypeINTEGER2:
5994           error = ffetarget_and_integer2 (ffebld_cu_ptr_integer2 (u),
5995                                ffebld_constant_integer2 (ffebld_conter (l)),
5996                               ffebld_constant_integer2 (ffebld_conter (r)));
5997           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5998                                         (ffebld_cu_val_integer2 (u)), expr);
5999           break;
6000 #endif
6001
6002 #if FFETARGET_okINTEGER3
6003         case FFEINFO_kindtypeINTEGER3:
6004           error = ffetarget_and_integer3 (ffebld_cu_ptr_integer3 (u),
6005                                ffebld_constant_integer3 (ffebld_conter (l)),
6006                               ffebld_constant_integer3 (ffebld_conter (r)));
6007           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6008                                         (ffebld_cu_val_integer3 (u)), expr);
6009           break;
6010 #endif
6011
6012 #if FFETARGET_okINTEGER4
6013         case FFEINFO_kindtypeINTEGER4:
6014           error = ffetarget_and_integer4 (ffebld_cu_ptr_integer4 (u),
6015                                ffebld_constant_integer4 (ffebld_conter (l)),
6016                               ffebld_constant_integer4 (ffebld_conter (r)));
6017           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6018                                         (ffebld_cu_val_integer4 (u)), expr);
6019           break;
6020 #endif
6021
6022         default:
6023           assert ("bad integer kind type" == NULL);
6024           break;
6025         }
6026       break;
6027
6028     case FFEINFO_basictypeLOGICAL:
6029       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6030         {
6031 #if FFETARGET_okLOGICAL1
6032         case FFEINFO_kindtypeLOGICAL1:
6033           error = ffetarget_and_logical1 (ffebld_cu_ptr_logical1 (u),
6034                                ffebld_constant_logical1 (ffebld_conter (l)),
6035                               ffebld_constant_logical1 (ffebld_conter (r)));
6036           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6037                                         (ffebld_cu_val_logical1 (u)), expr);
6038           break;
6039 #endif
6040
6041 #if FFETARGET_okLOGICAL2
6042         case FFEINFO_kindtypeLOGICAL2:
6043           error = ffetarget_and_logical2 (ffebld_cu_ptr_logical2 (u),
6044                                ffebld_constant_logical2 (ffebld_conter (l)),
6045                               ffebld_constant_logical2 (ffebld_conter (r)));
6046           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6047                                         (ffebld_cu_val_logical2 (u)), expr);
6048           break;
6049 #endif
6050
6051 #if FFETARGET_okLOGICAL3
6052         case FFEINFO_kindtypeLOGICAL3:
6053           error = ffetarget_and_logical3 (ffebld_cu_ptr_logical3 (u),
6054                                ffebld_constant_logical3 (ffebld_conter (l)),
6055                               ffebld_constant_logical3 (ffebld_conter (r)));
6056           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6057                                         (ffebld_cu_val_logical3 (u)), expr);
6058           break;
6059 #endif
6060
6061 #if FFETARGET_okLOGICAL4
6062         case FFEINFO_kindtypeLOGICAL4:
6063           error = ffetarget_and_logical4 (ffebld_cu_ptr_logical4 (u),
6064                                ffebld_constant_logical4 (ffebld_conter (l)),
6065                               ffebld_constant_logical4 (ffebld_conter (r)));
6066           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6067                                         (ffebld_cu_val_logical4 (u)), expr);
6068           break;
6069 #endif
6070
6071         default:
6072           assert ("bad logical kind type" == NULL);
6073           break;
6074         }
6075       break;
6076
6077     default:
6078       assert ("bad type" == NULL);
6079       return expr;
6080     }
6081
6082   ffebld_set_info (expr, ffeinfo_new
6083                    (bt,
6084                     kt,
6085                     0,
6086                     FFEINFO_kindENTITY,
6087                     FFEINFO_whereCONSTANT,
6088                     FFETARGET_charactersizeNONE));
6089
6090   if ((error != FFEBAD)
6091       && ffebad_start (error))
6092     {
6093       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6094       ffebad_finish ();
6095     }
6096
6097   return expr;
6098 }
6099
6100 /* ffeexpr_collapse_or -- Collapse or expr
6101
6102    ffebld expr;
6103    ffelexToken token;
6104    expr = ffeexpr_collapse_or(expr,token);
6105
6106    If the result of the expr is a constant, replaces the expr with the
6107    computed constant.  */
6108
6109 ffebld
6110 ffeexpr_collapse_or (ffebld expr, ffelexToken t)
6111 {
6112   ffebad error = FFEBAD;
6113   ffebld l;
6114   ffebld r;
6115   ffebldConstantUnion u;
6116   ffeinfoBasictype bt;
6117   ffeinfoKindtype kt;
6118
6119   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6120     return expr;
6121
6122   l = ffebld_left (expr);
6123   r = ffebld_right (expr);
6124
6125   if (ffebld_op (l) != FFEBLD_opCONTER)
6126     return expr;
6127   if (ffebld_op (r) != FFEBLD_opCONTER)
6128     return expr;
6129
6130   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6131     {
6132     case FFEINFO_basictypeANY:
6133       return expr;
6134
6135     case FFEINFO_basictypeINTEGER:
6136       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6137         {
6138 #if FFETARGET_okINTEGER1
6139         case FFEINFO_kindtypeINTEGER1:
6140           error = ffetarget_or_integer1 (ffebld_cu_ptr_integer1 (u),
6141                                ffebld_constant_integer1 (ffebld_conter (l)),
6142                               ffebld_constant_integer1 (ffebld_conter (r)));
6143           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6144                                         (ffebld_cu_val_integer1 (u)), expr);
6145           break;
6146 #endif
6147
6148 #if FFETARGET_okINTEGER2
6149         case FFEINFO_kindtypeINTEGER2:
6150           error = ffetarget_or_integer2 (ffebld_cu_ptr_integer2 (u),
6151                                ffebld_constant_integer2 (ffebld_conter (l)),
6152                               ffebld_constant_integer2 (ffebld_conter (r)));
6153           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6154                                         (ffebld_cu_val_integer2 (u)), expr);
6155           break;
6156 #endif
6157
6158 #if FFETARGET_okINTEGER3
6159         case FFEINFO_kindtypeINTEGER3:
6160           error = ffetarget_or_integer3 (ffebld_cu_ptr_integer3 (u),
6161                                ffebld_constant_integer3 (ffebld_conter (l)),
6162                               ffebld_constant_integer3 (ffebld_conter (r)));
6163           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6164                                         (ffebld_cu_val_integer3 (u)), expr);
6165           break;
6166 #endif
6167
6168 #if FFETARGET_okINTEGER4
6169         case FFEINFO_kindtypeINTEGER4:
6170           error = ffetarget_or_integer4 (ffebld_cu_ptr_integer4 (u),
6171                                ffebld_constant_integer4 (ffebld_conter (l)),
6172                               ffebld_constant_integer4 (ffebld_conter (r)));
6173           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6174                                         (ffebld_cu_val_integer4 (u)), expr);
6175           break;
6176 #endif
6177
6178         default:
6179           assert ("bad integer kind type" == NULL);
6180           break;
6181         }
6182       break;
6183
6184     case FFEINFO_basictypeLOGICAL:
6185       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6186         {
6187 #if FFETARGET_okLOGICAL1
6188         case FFEINFO_kindtypeLOGICAL1:
6189           error = ffetarget_or_logical1 (ffebld_cu_ptr_logical1 (u),
6190                                ffebld_constant_logical1 (ffebld_conter (l)),
6191                               ffebld_constant_logical1 (ffebld_conter (r)));
6192           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6193                                         (ffebld_cu_val_logical1 (u)), expr);
6194           break;
6195 #endif
6196
6197 #if FFETARGET_okLOGICAL2
6198         case FFEINFO_kindtypeLOGICAL2:
6199           error = ffetarget_or_logical2 (ffebld_cu_ptr_logical2 (u),
6200                                ffebld_constant_logical2 (ffebld_conter (l)),
6201                               ffebld_constant_logical2 (ffebld_conter (r)));
6202           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6203                                         (ffebld_cu_val_logical2 (u)), expr);
6204           break;
6205 #endif
6206
6207 #if FFETARGET_okLOGICAL3
6208         case FFEINFO_kindtypeLOGICAL3:
6209           error = ffetarget_or_logical3 (ffebld_cu_ptr_logical3 (u),
6210                                ffebld_constant_logical3 (ffebld_conter (l)),
6211                               ffebld_constant_logical3 (ffebld_conter (r)));
6212           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6213                                         (ffebld_cu_val_logical3 (u)), expr);
6214           break;
6215 #endif
6216
6217 #if FFETARGET_okLOGICAL4
6218         case FFEINFO_kindtypeLOGICAL4:
6219           error = ffetarget_or_logical4 (ffebld_cu_ptr_logical4 (u),
6220                                ffebld_constant_logical4 (ffebld_conter (l)),
6221                               ffebld_constant_logical4 (ffebld_conter (r)));
6222           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6223                                         (ffebld_cu_val_logical4 (u)), expr);
6224           break;
6225 #endif
6226
6227         default:
6228           assert ("bad logical kind type" == NULL);
6229           break;
6230         }
6231       break;
6232
6233     default:
6234       assert ("bad type" == NULL);
6235       return expr;
6236     }
6237
6238   ffebld_set_info (expr, ffeinfo_new
6239                    (bt,
6240                     kt,
6241                     0,
6242                     FFEINFO_kindENTITY,
6243                     FFEINFO_whereCONSTANT,
6244                     FFETARGET_charactersizeNONE));
6245
6246   if ((error != FFEBAD)
6247       && ffebad_start (error))
6248     {
6249       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6250       ffebad_finish ();
6251     }
6252
6253   return expr;
6254 }
6255
6256 /* ffeexpr_collapse_xor -- Collapse xor expr
6257
6258    ffebld expr;
6259    ffelexToken token;
6260    expr = ffeexpr_collapse_xor(expr,token);
6261
6262    If the result of the expr is a constant, replaces the expr with the
6263    computed constant.  */
6264
6265 ffebld
6266 ffeexpr_collapse_xor (ffebld expr, ffelexToken t)
6267 {
6268   ffebad error = FFEBAD;
6269   ffebld l;
6270   ffebld r;
6271   ffebldConstantUnion u;
6272   ffeinfoBasictype bt;
6273   ffeinfoKindtype kt;
6274
6275   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6276     return expr;
6277
6278   l = ffebld_left (expr);
6279   r = ffebld_right (expr);
6280
6281   if (ffebld_op (l) != FFEBLD_opCONTER)
6282     return expr;
6283   if (ffebld_op (r) != FFEBLD_opCONTER)
6284     return expr;
6285
6286   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6287     {
6288     case FFEINFO_basictypeANY:
6289       return expr;
6290
6291     case FFEINFO_basictypeINTEGER:
6292       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6293         {
6294 #if FFETARGET_okINTEGER1
6295         case FFEINFO_kindtypeINTEGER1:
6296           error = ffetarget_xor_integer1 (ffebld_cu_ptr_integer1 (u),
6297                                ffebld_constant_integer1 (ffebld_conter (l)),
6298                               ffebld_constant_integer1 (ffebld_conter (r)));
6299           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6300                                         (ffebld_cu_val_integer1 (u)), expr);
6301           break;
6302 #endif
6303
6304 #if FFETARGET_okINTEGER2
6305         case FFEINFO_kindtypeINTEGER2:
6306           error = ffetarget_xor_integer2 (ffebld_cu_ptr_integer2 (u),
6307                                ffebld_constant_integer2 (ffebld_conter (l)),
6308                               ffebld_constant_integer2 (ffebld_conter (r)));
6309           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6310                                         (ffebld_cu_val_integer2 (u)), expr);
6311           break;
6312 #endif
6313
6314 #if FFETARGET_okINTEGER3
6315         case FFEINFO_kindtypeINTEGER3:
6316           error = ffetarget_xor_integer3 (ffebld_cu_ptr_integer3 (u),
6317                                ffebld_constant_integer3 (ffebld_conter (l)),
6318                               ffebld_constant_integer3 (ffebld_conter (r)));
6319           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6320                                         (ffebld_cu_val_integer3 (u)), expr);
6321           break;
6322 #endif
6323
6324 #if FFETARGET_okINTEGER4
6325         case FFEINFO_kindtypeINTEGER4:
6326           error = ffetarget_xor_integer4 (ffebld_cu_ptr_integer4 (u),
6327                                ffebld_constant_integer4 (ffebld_conter (l)),
6328                               ffebld_constant_integer4 (ffebld_conter (r)));
6329           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6330                                         (ffebld_cu_val_integer4 (u)), expr);
6331           break;
6332 #endif
6333
6334         default:
6335           assert ("bad integer kind type" == NULL);
6336           break;
6337         }
6338       break;
6339
6340     case FFEINFO_basictypeLOGICAL:
6341       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6342         {
6343 #if FFETARGET_okLOGICAL1
6344         case FFEINFO_kindtypeLOGICAL1:
6345           error = ffetarget_xor_logical1 (ffebld_cu_ptr_logical1 (u),
6346                                ffebld_constant_logical1 (ffebld_conter (l)),
6347                               ffebld_constant_logical1 (ffebld_conter (r)));
6348           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6349                                         (ffebld_cu_val_logical1 (u)), expr);
6350           break;
6351 #endif
6352
6353 #if FFETARGET_okLOGICAL2
6354         case FFEINFO_kindtypeLOGICAL2:
6355           error = ffetarget_xor_logical2 (ffebld_cu_ptr_logical2 (u),
6356                                ffebld_constant_logical2 (ffebld_conter (l)),
6357                               ffebld_constant_logical2 (ffebld_conter (r)));
6358           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6359                                         (ffebld_cu_val_logical2 (u)), expr);
6360           break;
6361 #endif
6362
6363 #if FFETARGET_okLOGICAL3
6364         case FFEINFO_kindtypeLOGICAL3:
6365           error = ffetarget_xor_logical3 (ffebld_cu_ptr_logical3 (u),
6366                                ffebld_constant_logical3 (ffebld_conter (l)),
6367                               ffebld_constant_logical3 (ffebld_conter (r)));
6368           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6369                                         (ffebld_cu_val_logical3 (u)), expr);
6370           break;
6371 #endif
6372
6373 #if FFETARGET_okLOGICAL4
6374         case FFEINFO_kindtypeLOGICAL4:
6375           error = ffetarget_xor_logical4 (ffebld_cu_ptr_logical4 (u),
6376                                ffebld_constant_logical4 (ffebld_conter (l)),
6377                               ffebld_constant_logical4 (ffebld_conter (r)));
6378           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6379                                         (ffebld_cu_val_logical4 (u)), expr);
6380           break;
6381 #endif
6382
6383         default:
6384           assert ("bad logical kind type" == NULL);
6385           break;
6386         }
6387       break;
6388
6389     default:
6390       assert ("bad type" == NULL);
6391       return expr;
6392     }
6393
6394   ffebld_set_info (expr, ffeinfo_new
6395                    (bt,
6396                     kt,
6397                     0,
6398                     FFEINFO_kindENTITY,
6399                     FFEINFO_whereCONSTANT,
6400                     FFETARGET_charactersizeNONE));
6401
6402   if ((error != FFEBAD)
6403       && ffebad_start (error))
6404     {
6405       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6406       ffebad_finish ();
6407     }
6408
6409   return expr;
6410 }
6411
6412 /* ffeexpr_collapse_eqv -- Collapse eqv expr
6413
6414    ffebld expr;
6415    ffelexToken token;
6416    expr = ffeexpr_collapse_eqv(expr,token);
6417
6418    If the result of the expr is a constant, replaces the expr with the
6419    computed constant.  */
6420
6421 ffebld
6422 ffeexpr_collapse_eqv (ffebld expr, ffelexToken t)
6423 {
6424   ffebad error = FFEBAD;
6425   ffebld l;
6426   ffebld r;
6427   ffebldConstantUnion u;
6428   ffeinfoBasictype bt;
6429   ffeinfoKindtype kt;
6430
6431   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6432     return expr;
6433
6434   l = ffebld_left (expr);
6435   r = ffebld_right (expr);
6436
6437   if (ffebld_op (l) != FFEBLD_opCONTER)
6438     return expr;
6439   if (ffebld_op (r) != FFEBLD_opCONTER)
6440     return expr;
6441
6442   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6443     {
6444     case FFEINFO_basictypeANY:
6445       return expr;
6446
6447     case FFEINFO_basictypeINTEGER:
6448       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6449         {
6450 #if FFETARGET_okINTEGER1
6451         case FFEINFO_kindtypeINTEGER1:
6452           error = ffetarget_eqv_integer1 (ffebld_cu_ptr_integer1 (u),
6453                                ffebld_constant_integer1 (ffebld_conter (l)),
6454                               ffebld_constant_integer1 (ffebld_conter (r)));
6455           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6456                                         (ffebld_cu_val_integer1 (u)), expr);
6457           break;
6458 #endif
6459
6460 #if FFETARGET_okINTEGER2
6461         case FFEINFO_kindtypeINTEGER2:
6462           error = ffetarget_eqv_integer2 (ffebld_cu_ptr_integer2 (u),
6463                                ffebld_constant_integer2 (ffebld_conter (l)),
6464                               ffebld_constant_integer2 (ffebld_conter (r)));
6465           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6466                                         (ffebld_cu_val_integer2 (u)), expr);
6467           break;
6468 #endif
6469
6470 #if FFETARGET_okINTEGER3
6471         case FFEINFO_kindtypeINTEGER3:
6472           error = ffetarget_eqv_integer3 (ffebld_cu_ptr_integer3 (u),
6473                                ffebld_constant_integer3 (ffebld_conter (l)),
6474                               ffebld_constant_integer3 (ffebld_conter (r)));
6475           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6476                                         (ffebld_cu_val_integer3 (u)), expr);
6477           break;
6478 #endif
6479
6480 #if FFETARGET_okINTEGER4
6481         case FFEINFO_kindtypeINTEGER4:
6482           error = ffetarget_eqv_integer4 (ffebld_cu_ptr_integer4 (u),
6483                                ffebld_constant_integer4 (ffebld_conter (l)),
6484                               ffebld_constant_integer4 (ffebld_conter (r)));
6485           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6486                                         (ffebld_cu_val_integer4 (u)), expr);
6487           break;
6488 #endif
6489
6490         default:
6491           assert ("bad integer kind type" == NULL);
6492           break;
6493         }
6494       break;
6495
6496     case FFEINFO_basictypeLOGICAL:
6497       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6498         {
6499 #if FFETARGET_okLOGICAL1
6500         case FFEINFO_kindtypeLOGICAL1:
6501           error = ffetarget_eqv_logical1 (ffebld_cu_ptr_logical1 (u),
6502                                ffebld_constant_logical1 (ffebld_conter (l)),
6503                               ffebld_constant_logical1 (ffebld_conter (r)));
6504           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6505                                         (ffebld_cu_val_logical1 (u)), expr);
6506           break;
6507 #endif
6508
6509 #if FFETARGET_okLOGICAL2
6510         case FFEINFO_kindtypeLOGICAL2:
6511           error = ffetarget_eqv_logical2 (ffebld_cu_ptr_logical2 (u),
6512                                ffebld_constant_logical2 (ffebld_conter (l)),
6513                               ffebld_constant_logical2 (ffebld_conter (r)));
6514           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6515                                         (ffebld_cu_val_logical2 (u)), expr);
6516           break;
6517 #endif
6518
6519 #if FFETARGET_okLOGICAL3
6520         case FFEINFO_kindtypeLOGICAL3:
6521           error = ffetarget_eqv_logical3 (ffebld_cu_ptr_logical3 (u),
6522                                ffebld_constant_logical3 (ffebld_conter (l)),
6523                               ffebld_constant_logical3 (ffebld_conter (r)));
6524           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6525                                         (ffebld_cu_val_logical3 (u)), expr);
6526           break;
6527 #endif
6528
6529 #if FFETARGET_okLOGICAL4
6530         case FFEINFO_kindtypeLOGICAL4:
6531           error = ffetarget_eqv_logical4 (ffebld_cu_ptr_logical4 (u),
6532                                ffebld_constant_logical4 (ffebld_conter (l)),
6533                               ffebld_constant_logical4 (ffebld_conter (r)));
6534           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6535                                         (ffebld_cu_val_logical4 (u)), expr);
6536           break;
6537 #endif
6538
6539         default:
6540           assert ("bad logical kind type" == NULL);
6541           break;
6542         }
6543       break;
6544
6545     default:
6546       assert ("bad type" == NULL);
6547       return expr;
6548     }
6549
6550   ffebld_set_info (expr, ffeinfo_new
6551                    (bt,
6552                     kt,
6553                     0,
6554                     FFEINFO_kindENTITY,
6555                     FFEINFO_whereCONSTANT,
6556                     FFETARGET_charactersizeNONE));
6557
6558   if ((error != FFEBAD)
6559       && ffebad_start (error))
6560     {
6561       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6562       ffebad_finish ();
6563     }
6564
6565   return expr;
6566 }
6567
6568 /* ffeexpr_collapse_neqv -- Collapse neqv expr
6569
6570    ffebld expr;
6571    ffelexToken token;
6572    expr = ffeexpr_collapse_neqv(expr,token);
6573
6574    If the result of the expr is a constant, replaces the expr with the
6575    computed constant.  */
6576
6577 ffebld
6578 ffeexpr_collapse_neqv (ffebld expr, ffelexToken t)
6579 {
6580   ffebad error = FFEBAD;
6581   ffebld l;
6582   ffebld r;
6583   ffebldConstantUnion u;
6584   ffeinfoBasictype bt;
6585   ffeinfoKindtype kt;
6586
6587   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6588     return expr;
6589
6590   l = ffebld_left (expr);
6591   r = ffebld_right (expr);
6592
6593   if (ffebld_op (l) != FFEBLD_opCONTER)
6594     return expr;
6595   if (ffebld_op (r) != FFEBLD_opCONTER)
6596     return expr;
6597
6598   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6599     {
6600     case FFEINFO_basictypeANY:
6601       return expr;
6602
6603     case FFEINFO_basictypeINTEGER:
6604       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6605         {
6606 #if FFETARGET_okINTEGER1
6607         case FFEINFO_kindtypeINTEGER1:
6608           error = ffetarget_neqv_integer1 (ffebld_cu_ptr_integer1 (u),
6609                                ffebld_constant_integer1 (ffebld_conter (l)),
6610                               ffebld_constant_integer1 (ffebld_conter (r)));
6611           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6612                                         (ffebld_cu_val_integer1 (u)), expr);
6613           break;
6614 #endif
6615
6616 #if FFETARGET_okINTEGER2
6617         case FFEINFO_kindtypeINTEGER2:
6618           error = ffetarget_neqv_integer2 (ffebld_cu_ptr_integer2 (u),
6619                                ffebld_constant_integer2 (ffebld_conter (l)),
6620                               ffebld_constant_integer2 (ffebld_conter (r)));
6621           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6622                                         (ffebld_cu_val_integer2 (u)), expr);
6623           break;
6624 #endif
6625
6626 #if FFETARGET_okINTEGER3
6627         case FFEINFO_kindtypeINTEGER3:
6628           error = ffetarget_neqv_integer3 (ffebld_cu_ptr_integer3 (u),
6629                                ffebld_constant_integer3 (ffebld_conter (l)),
6630                               ffebld_constant_integer3 (ffebld_conter (r)));
6631           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6632                                         (ffebld_cu_val_integer3 (u)), expr);
6633           break;
6634 #endif
6635
6636 #if FFETARGET_okINTEGER4
6637         case FFEINFO_kindtypeINTEGER4:
6638           error = ffetarget_neqv_integer4 (ffebld_cu_ptr_integer4 (u),
6639                                ffebld_constant_integer4 (ffebld_conter (l)),
6640                               ffebld_constant_integer4 (ffebld_conter (r)));
6641           expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6642                                         (ffebld_cu_val_integer4 (u)), expr);
6643           break;
6644 #endif
6645
6646         default:
6647           assert ("bad integer kind type" == NULL);
6648           break;
6649         }
6650       break;
6651
6652     case FFEINFO_basictypeLOGICAL:
6653       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6654         {
6655 #if FFETARGET_okLOGICAL1
6656         case FFEINFO_kindtypeLOGICAL1:
6657           error = ffetarget_neqv_logical1 (ffebld_cu_ptr_logical1 (u),
6658                                ffebld_constant_logical1 (ffebld_conter (l)),
6659                               ffebld_constant_logical1 (ffebld_conter (r)));
6660           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6661                                         (ffebld_cu_val_logical1 (u)), expr);
6662           break;
6663 #endif
6664
6665 #if FFETARGET_okLOGICAL2
6666         case FFEINFO_kindtypeLOGICAL2:
6667           error = ffetarget_neqv_logical2 (ffebld_cu_ptr_logical2 (u),
6668                                ffebld_constant_logical2 (ffebld_conter (l)),
6669                               ffebld_constant_logical2 (ffebld_conter (r)));
6670           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6671                                         (ffebld_cu_val_logical2 (u)), expr);
6672           break;
6673 #endif
6674
6675 #if FFETARGET_okLOGICAL3
6676         case FFEINFO_kindtypeLOGICAL3:
6677           error = ffetarget_neqv_logical3 (ffebld_cu_ptr_logical3 (u),
6678                                ffebld_constant_logical3 (ffebld_conter (l)),
6679                               ffebld_constant_logical3 (ffebld_conter (r)));
6680           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6681                                         (ffebld_cu_val_logical3 (u)), expr);
6682           break;
6683 #endif
6684
6685 #if FFETARGET_okLOGICAL4
6686         case FFEINFO_kindtypeLOGICAL4:
6687           error = ffetarget_neqv_logical4 (ffebld_cu_ptr_logical4 (u),
6688                                ffebld_constant_logical4 (ffebld_conter (l)),
6689                               ffebld_constant_logical4 (ffebld_conter (r)));
6690           expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6691                                         (ffebld_cu_val_logical4 (u)), expr);
6692           break;
6693 #endif
6694
6695         default:
6696           assert ("bad logical kind type" == NULL);
6697           break;
6698         }
6699       break;
6700
6701     default:
6702       assert ("bad type" == NULL);
6703       return expr;
6704     }
6705
6706   ffebld_set_info (expr, ffeinfo_new
6707                    (bt,
6708                     kt,
6709                     0,
6710                     FFEINFO_kindENTITY,
6711                     FFEINFO_whereCONSTANT,
6712                     FFETARGET_charactersizeNONE));
6713
6714   if ((error != FFEBAD)
6715       && ffebad_start (error))
6716     {
6717       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6718       ffebad_finish ();
6719     }
6720
6721   return expr;
6722 }
6723
6724 /* ffeexpr_collapse_symter -- Collapse symter expr
6725
6726    ffebld expr;
6727    ffelexToken token;
6728    expr = ffeexpr_collapse_symter(expr,token);
6729
6730    If the result of the expr is a constant, replaces the expr with the
6731    computed constant.  */
6732
6733 ffebld
6734 ffeexpr_collapse_symter (ffebld expr, ffelexToken t UNUSED)
6735 {
6736   ffebld r;
6737   ffeinfoBasictype bt;
6738   ffeinfoKindtype kt;
6739   ffetargetCharacterSize len;
6740
6741   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6742     return expr;
6743
6744   if ((r = ffesymbol_init (ffebld_symter (expr))) == NULL)
6745     return expr;                /* A PARAMETER lhs in progress. */
6746
6747   switch (ffebld_op (r))
6748     {
6749     case FFEBLD_opCONTER:
6750       break;
6751
6752     case FFEBLD_opANY:
6753       return r;
6754
6755     default:
6756       return expr;
6757     }
6758
6759   bt = ffeinfo_basictype (ffebld_info (r));
6760   kt = ffeinfo_kindtype (ffebld_info (r));
6761   len = ffebld_size (r);
6762
6763   expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
6764                                       expr);
6765
6766   ffebld_set_info (expr, ffeinfo_new
6767                    (bt,
6768                     kt,
6769                     0,
6770                     FFEINFO_kindENTITY,
6771                     FFEINFO_whereCONSTANT,
6772                     len));
6773
6774   return expr;
6775 }
6776
6777 /* ffeexpr_collapse_funcref -- Collapse funcref expr
6778
6779    ffebld expr;
6780    ffelexToken token;
6781    expr = ffeexpr_collapse_funcref(expr,token);
6782
6783    If the result of the expr is a constant, replaces the expr with the
6784    computed constant.  */
6785
6786 ffebld
6787 ffeexpr_collapse_funcref (ffebld expr, ffelexToken t UNUSED)
6788 {
6789   return expr;                  /* ~~someday go ahead and collapse these,
6790                                    though not required */
6791 }
6792
6793 /* ffeexpr_collapse_arrayref -- Collapse arrayref expr
6794
6795    ffebld expr;
6796    ffelexToken token;
6797    expr = ffeexpr_collapse_arrayref(expr,token);
6798
6799    If the result of the expr is a constant, replaces the expr with the
6800    computed constant.  */
6801
6802 ffebld
6803 ffeexpr_collapse_arrayref (ffebld expr, ffelexToken t UNUSED)
6804 {
6805   return expr;
6806 }
6807
6808 /* ffeexpr_collapse_substr -- Collapse substr expr
6809
6810    ffebld expr;
6811    ffelexToken token;
6812    expr = ffeexpr_collapse_substr(expr,token);
6813
6814    If the result of the expr is a constant, replaces the expr with the
6815    computed constant.  */
6816
6817 ffebld
6818 ffeexpr_collapse_substr (ffebld expr, ffelexToken t)
6819 {
6820   ffebad error = FFEBAD;
6821   ffebld l;
6822   ffebld r;
6823   ffebld start;
6824   ffebld stop;
6825   ffebldConstantUnion u;
6826   ffeinfoKindtype kt;
6827   ffetargetCharacterSize len;
6828   ffetargetIntegerDefault first;
6829   ffetargetIntegerDefault last;
6830
6831   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6832     return expr;
6833
6834   l = ffebld_left (expr);
6835   r = ffebld_right (expr);      /* opITEM. */
6836
6837   if (ffebld_op (l) != FFEBLD_opCONTER)
6838     return expr;
6839
6840   kt = ffeinfo_kindtype (ffebld_info (l));
6841   len = ffebld_size (l);
6842
6843   start = ffebld_head (r);
6844   stop = ffebld_head (ffebld_trail (r));
6845   if (start == NULL)
6846     first = 1;
6847   else
6848     {
6849       if ((ffebld_op (start) != FFEBLD_opCONTER)
6850           || (ffeinfo_basictype (ffebld_info (start)) != FFEINFO_basictypeINTEGER)
6851           || (ffeinfo_kindtype (ffebld_info (start))
6852               != FFEINFO_kindtypeINTEGERDEFAULT))
6853         return expr;
6854       first = ffebld_constant_integerdefault (ffebld_conter (start));
6855     }
6856   if (stop == NULL)
6857     last = len;
6858   else
6859     {
6860       if ((ffebld_op (stop) != FFEBLD_opCONTER)
6861       || (ffeinfo_basictype (ffebld_info (stop)) != FFEINFO_basictypeINTEGER)
6862           || (ffeinfo_kindtype (ffebld_info (stop))
6863               != FFEINFO_kindtypeINTEGERDEFAULT))
6864         return expr;
6865       last = ffebld_constant_integerdefault (ffebld_conter (stop));
6866     }
6867
6868   /* Handle problems that should have already been diagnosed, but
6869      left in the expression tree.  */
6870
6871   if (first <= 0)
6872     first = 1;
6873   if (last < first)
6874     last = first + len - 1;
6875
6876   if ((first == 1) && (last == len))
6877     {                           /* Same as original. */
6878       expr = ffebld_new_conter_with_orig (ffebld_constant_copy
6879                                           (ffebld_conter (l)), expr);
6880       ffebld_set_info (expr, ffeinfo_new
6881                        (FFEINFO_basictypeCHARACTER,
6882                         kt,
6883                         0,
6884                         FFEINFO_kindENTITY,
6885                         FFEINFO_whereCONSTANT,
6886                         len));
6887
6888       return expr;
6889     }
6890
6891   switch (ffeinfo_basictype (ffebld_info (expr)))
6892     {
6893     case FFEINFO_basictypeANY:
6894       return expr;
6895
6896     case FFEINFO_basictypeCHARACTER:
6897       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6898         {
6899 #if FFETARGET_okCHARACTER1
6900         case FFEINFO_kindtypeCHARACTER1:
6901           error = ffetarget_substr_character1 (ffebld_cu_ptr_character1 (u),
6902                 ffebld_constant_character1 (ffebld_conter (l)), first, last,
6903                                    ffebld_constant_pool (), &len);
6904           expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
6905                                       (ffebld_cu_val_character1 (u)), expr);
6906           break;
6907 #endif
6908
6909 #if FFETARGET_okCHARACTER2
6910         case FFEINFO_kindtypeCHARACTER2:
6911           error = ffetarget_substr_character2 (ffebld_cu_ptr_character2 (u),
6912                 ffebld_constant_character2 (ffebld_conter (l)), first, last,
6913                                    ffebld_constant_pool (), &len);
6914           expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val
6915                                       (ffebld_cu_val_character2 (u)), expr);
6916           break;
6917 #endif
6918
6919 #if FFETARGET_okCHARACTER3
6920         case FFEINFO_kindtypeCHARACTER3:
6921           error = ffetarget_substr_character3 (ffebld_cu_ptr_character3 (u),
6922                 ffebld_constant_character3 (ffebld_conter (l)), first, last,
6923                                    ffebld_constant_pool (), &len);
6924           expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val
6925                                       (ffebld_cu_val_character3 (u)), expr);
6926           break;
6927 #endif
6928
6929 #if FFETARGET_okCHARACTER4
6930         case FFEINFO_kindtypeCHARACTER4:
6931           error = ffetarget_substr_character4 (ffebld_cu_ptr_character4 (u),
6932                 ffebld_constant_character4 (ffebld_conter (l)), first, last,
6933                                    ffebld_constant_pool (), &len);
6934           expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val
6935                                       (ffebld_cu_val_character4 (u)), expr);
6936           break;
6937 #endif
6938
6939         default:
6940           assert ("bad character kind type" == NULL);
6941           break;
6942         }
6943       break;
6944
6945     default:
6946       assert ("bad type" == NULL);
6947       return expr;
6948     }
6949
6950   ffebld_set_info (expr, ffeinfo_new
6951                    (FFEINFO_basictypeCHARACTER,
6952                     kt,
6953                     0,
6954                     FFEINFO_kindENTITY,
6955                     FFEINFO_whereCONSTANT,
6956                     len));
6957
6958   if ((error != FFEBAD)
6959       && ffebad_start (error))
6960     {
6961       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6962       ffebad_finish ();
6963     }
6964
6965   return expr;
6966 }
6967
6968 /* ffeexpr_convert -- Convert source expression to given type
6969
6970    ffebld source;
6971    ffelexToken source_token;
6972    ffelexToken dest_token;  // Any appropriate token for "destination".
6973    ffeinfoBasictype bt;
6974    ffeinfoKindtype kt;
6975    ffetargetCharactersize sz;
6976    ffeexprContext context;  // Mainly LET or DATA.
6977    source = ffeexpr_convert(source,source_token,dest_token,bt,kt,sz,context);
6978
6979    If the expression conforms, returns the source expression.  Otherwise
6980    returns source wrapped in a convert node doing the conversion, or
6981    ANY wrapped in convert if there is a conversion error (and issues an
6982    error message).  Be sensitive to the context for certain aspects of
6983    the conversion.  */
6984
6985 ffebld
6986 ffeexpr_convert (ffebld source, ffelexToken source_token, ffelexToken dest_token,
6987                  ffeinfoBasictype bt, ffeinfoKindtype kt, ffeinfoRank rk,
6988                  ffetargetCharacterSize sz, ffeexprContext context)
6989 {
6990   bool bad;
6991   ffeinfo info;
6992   ffeinfoWhere wh;
6993
6994   info = ffebld_info (source);
6995   if ((bt != ffeinfo_basictype (info))
6996       || (kt != ffeinfo_kindtype (info))
6997       || (rk != 0)              /* Can't convert from or to arrays yet. */
6998       || (ffeinfo_rank (info) != 0)
6999       || (sz != ffebld_size_known (source)))
7000 #if 0   /* Nobody seems to need this spurious CONVERT node. */
7001       || ((context != FFEEXPR_contextLET)
7002           && (bt == FFEINFO_basictypeCHARACTER)
7003           && (sz == FFETARGET_charactersizeNONE)))
7004 #endif
7005     {
7006       switch (ffeinfo_basictype (info))
7007         {
7008         case FFEINFO_basictypeLOGICAL:
7009           switch (bt)
7010             {
7011             case FFEINFO_basictypeLOGICAL:
7012               bad = FALSE;
7013               break;
7014
7015             case FFEINFO_basictypeINTEGER:
7016               bad = !ffe_is_ugly_logint ();
7017               break;
7018
7019             case FFEINFO_basictypeCHARACTER:
7020               bad = ffe_is_pedantic ()
7021                 || !(ffe_is_ugly_init ()
7022                      && (context == FFEEXPR_contextDATA));
7023               break;
7024
7025             default:
7026               bad = TRUE;
7027               break;
7028             }
7029           break;
7030
7031         case FFEINFO_basictypeINTEGER:
7032           switch (bt)
7033             {
7034             case FFEINFO_basictypeINTEGER:
7035             case FFEINFO_basictypeREAL:
7036             case FFEINFO_basictypeCOMPLEX:
7037               bad = FALSE;
7038               break;
7039
7040             case FFEINFO_basictypeLOGICAL:
7041               bad = !ffe_is_ugly_logint ();
7042               break;
7043
7044             case FFEINFO_basictypeCHARACTER:
7045               bad = ffe_is_pedantic ()
7046                 || !(ffe_is_ugly_init ()
7047                      && (context == FFEEXPR_contextDATA));
7048               break;
7049
7050             default:
7051               bad = TRUE;
7052               break;
7053             }
7054           break;
7055
7056         case FFEINFO_basictypeREAL:
7057         case FFEINFO_basictypeCOMPLEX:
7058           switch (bt)
7059             {
7060             case FFEINFO_basictypeINTEGER:
7061             case FFEINFO_basictypeREAL:
7062             case FFEINFO_basictypeCOMPLEX:
7063               bad = FALSE;
7064               break;
7065
7066             case FFEINFO_basictypeCHARACTER:
7067               bad = TRUE;
7068               break;
7069
7070             default:
7071               bad = TRUE;
7072               break;
7073             }
7074           break;
7075
7076         case FFEINFO_basictypeCHARACTER:
7077           bad = (bt != FFEINFO_basictypeCHARACTER)
7078             && (ffe_is_pedantic ()
7079                 || (bt != FFEINFO_basictypeINTEGER)
7080                 || !(ffe_is_ugly_init ()
7081                      && (context == FFEEXPR_contextDATA)));
7082           break;
7083
7084         case FFEINFO_basictypeTYPELESS:
7085         case FFEINFO_basictypeHOLLERITH:
7086           bad = ffe_is_pedantic ()
7087             || !(ffe_is_ugly_init ()
7088                  && ((context == FFEEXPR_contextDATA)
7089                      || (context == FFEEXPR_contextLET)));
7090           break;
7091
7092         default:
7093           bad = TRUE;
7094           break;
7095         }
7096
7097       if (!bad && ((rk != 0) || (ffeinfo_rank (info) != 0)))
7098         bad = TRUE;
7099
7100       if (bad && (bt != FFEINFO_basictypeANY) && (kt != FFEINFO_kindtypeANY)
7101           && (ffeinfo_basictype (info) != FFEINFO_basictypeANY)
7102           && (ffeinfo_kindtype (info) != FFEINFO_kindtypeANY)
7103           && (ffeinfo_where (info) != FFEINFO_whereANY))
7104         {
7105           if (ffebad_start (FFEBAD_BAD_TYPES))
7106             {
7107               if (dest_token == NULL)
7108                 ffebad_here (0, ffewhere_line_unknown (),
7109                              ffewhere_column_unknown ());
7110               else
7111                 ffebad_here (0, ffelex_token_where_line (dest_token),
7112                              ffelex_token_where_column (dest_token));
7113               assert (source_token != NULL);
7114               ffebad_here (1, ffelex_token_where_line (source_token),
7115                            ffelex_token_where_column (source_token));
7116               ffebad_finish ();
7117             }
7118
7119           source = ffebld_new_any ();
7120           ffebld_set_info (source, ffeinfo_new_any ());
7121         }
7122       else
7123         {
7124           switch (ffeinfo_where (info))
7125             {
7126             case FFEINFO_whereCONSTANT:
7127               wh = FFEINFO_whereCONSTANT;
7128               break;
7129
7130             case FFEINFO_whereIMMEDIATE:
7131               wh = FFEINFO_whereIMMEDIATE;
7132               break;
7133
7134             default:
7135               wh = FFEINFO_whereFLEETING;
7136               break;
7137             }
7138           source = ffebld_new_convert (source);
7139           ffebld_set_info (source, ffeinfo_new
7140                            (bt,
7141                             kt,
7142                             0,
7143                             FFEINFO_kindENTITY,
7144                             wh,
7145                             sz));
7146           source = ffeexpr_collapse_convert (source, source_token);
7147         }
7148     }
7149
7150   return source;
7151 }
7152
7153 /* ffeexpr_convert_expr -- Convert source expr to conform to dest expr
7154
7155    ffebld source;
7156    ffebld dest;
7157    ffelexToken source_token;
7158    ffelexToken dest_token;
7159    ffeexprContext context;
7160    source = ffeexpr_convert_expr(source,source_token,dest,dest_token,context);
7161
7162    If the expressions conform, returns the source expression.  Otherwise
7163    returns source wrapped in a convert node doing the conversion, or
7164    ANY wrapped in convert if there is a conversion error (and issues an
7165    error message).  Be sensitive to the context, such as LET or DATA.  */
7166
7167 ffebld
7168 ffeexpr_convert_expr (ffebld source, ffelexToken source_token, ffebld dest,
7169                       ffelexToken dest_token, ffeexprContext context)
7170 {
7171   ffeinfo info;
7172
7173   info = ffebld_info (dest);
7174   return ffeexpr_convert (source, source_token, dest_token,
7175                           ffeinfo_basictype (info),
7176                           ffeinfo_kindtype (info),
7177                           ffeinfo_rank (info),
7178                           ffebld_size_known (dest),
7179                           context);
7180 }
7181
7182 /* ffeexpr_convert_to_sym -- Convert source expression to conform to symbol
7183
7184    ffebld source;
7185    ffesymbol dest;
7186    ffelexToken source_token;
7187    ffelexToken dest_token;
7188    source = ffeexpr_convert_to_sym(source,source_token,dest,dest_token);
7189
7190    If the expressions conform, returns the source expression.  Otherwise
7191    returns source wrapped in a convert node doing the conversion, or
7192    ANY wrapped in convert if there is a conversion error (and issues an
7193    error message).  */
7194
7195 ffebld
7196 ffeexpr_convert_to_sym (ffebld source, ffelexToken source_token,
7197                         ffesymbol dest, ffelexToken dest_token)
7198 {
7199   return ffeexpr_convert (source, source_token, dest_token, ffesymbol_basictype (dest),
7200     ffesymbol_kindtype (dest), ffesymbol_rank (dest), ffesymbol_size (dest),
7201                           FFEEXPR_contextLET);
7202 }
7203
7204 /* Initializes the module.  */
7205
7206 void
7207 ffeexpr_init_2 ()
7208 {
7209   ffeexpr_stack_ = NULL;
7210   ffeexpr_level_ = 0;
7211 }
7212
7213 /* ffeexpr_lhs -- Begin processing left-hand-side-context expression
7214
7215    Prepares cluster for delivery of lexer tokens representing an expression
7216    in a left-hand-side context (A in A=B, for example).  ffebld is used
7217    to build expressions in the given pool.  The appropriate lexer-token
7218    handling routine within ffeexpr is returned.  When the end of the
7219    expression is detected, mycallbackroutine is called with the resulting
7220    single ffebld object specifying the entire expression and the first
7221    lexer token that is not considered part of the expression.  This caller-
7222    supplied routine itself returns a lexer-token handling routine.  Thus,
7223    if necessary, ffeexpr can return several tokens as end-of-expression
7224    tokens if it needs to scan forward more than one in any instance.  */
7225
7226 ffelexHandler
7227 ffeexpr_lhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
7228 {
7229   ffeexprStack_ s;
7230
7231   ffebld_pool_push (pool);
7232   s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
7233   s->previous = ffeexpr_stack_;
7234   s->pool = pool;
7235   s->context = context;
7236   s->callback = callback;
7237   s->first_token = NULL;
7238   s->exprstack = NULL;
7239   s->is_rhs = FALSE;
7240   ffeexpr_stack_ = s;
7241   return (ffelexHandler) ffeexpr_token_first_lhs_;
7242 }
7243
7244 /* ffeexpr_rhs -- Begin processing right-hand-side-context expression
7245
7246    return ffeexpr_rhs(malloc_pool_image(),mycallbackroutine);  // to lexer.
7247
7248    Prepares cluster for delivery of lexer tokens representing an expression
7249    in a right-hand-side context (B in A=B, for example).  ffebld is used
7250    to build expressions in the given pool.  The appropriate lexer-token
7251    handling routine within ffeexpr is returned.  When the end of the
7252    expression is detected, mycallbackroutine is called with the resulting
7253    single ffebld object specifying the entire expression and the first
7254    lexer token that is not considered part of the expression.  This caller-
7255    supplied routine itself returns a lexer-token handling routine.  Thus,
7256    if necessary, ffeexpr can return several tokens as end-of-expression
7257    tokens if it needs to scan forward more than one in any instance.  */
7258
7259 ffelexHandler
7260 ffeexpr_rhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
7261 {
7262   ffeexprStack_ s;
7263
7264   ffebld_pool_push (pool);
7265   s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
7266   s->previous = ffeexpr_stack_;
7267   s->pool = pool;
7268   s->context = context;
7269   s->callback = callback;
7270   s->first_token = NULL;
7271   s->exprstack = NULL;
7272   s->is_rhs = TRUE;
7273   ffeexpr_stack_ = s;
7274   return (ffelexHandler) ffeexpr_token_first_rhs_;
7275 }
7276
7277 /* ffeexpr_cb_close_paren_ -- OPEN_PAREN expr
7278
7279    Pass it to ffeexpr_rhs as the callback routine.
7280
7281    Makes sure the end token is close-paren and swallows it, else issues
7282    an error message and doesn't swallow the token (passing it along instead).
7283    In either case wraps up subexpression construction by enclosing the
7284    ffebld expression in a paren.  */
7285
7286 static ffelexHandler
7287 ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr, ffelexToken t)
7288 {
7289   ffeexprExpr_ e;
7290
7291   if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7292     {
7293       /* Oops, naughty user didn't specify the close paren! */
7294
7295       if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7296         {
7297           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7298           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7299                        ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7300           ffebad_finish ();
7301         }
7302
7303       e = ffeexpr_expr_new_ ();
7304       e->type = FFEEXPR_exprtypeOPERAND_;
7305       e->u.operand = ffebld_new_any ();
7306       ffebld_set_info (e->u.operand, ffeinfo_new_any ());
7307       ffeexpr_exprstack_push_operand_ (e);
7308
7309       return
7310         (ffelexHandler) ffeexpr_find_close_paren_ (t,
7311                                                    (ffelexHandler)
7312                                                    ffeexpr_token_binary_);
7313     }
7314
7315   if (expr->op == FFEBLD_opIMPDO)
7316     {
7317       if (ffest_ffebad_start (FFEBAD_IMPDO_PAREN))
7318         {
7319           ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7320                        ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7321           ffebad_finish ();
7322         }
7323     }
7324   else
7325     {
7326       expr = ffebld_new_paren (expr);
7327       ffebld_set_info (expr, ffeinfo_use (ffebld_info (ffebld_left (expr))));
7328     }
7329
7330   /* Now push the (parenthesized) expression as an operand onto the
7331      expression stack. */
7332
7333   e = ffeexpr_expr_new_ ();
7334   e->type = FFEEXPR_exprtypeOPERAND_;
7335   e->u.operand = expr;
7336   e->u.operand = ffeexpr_collapse_paren (e->u.operand, ft);
7337   e->token = ffeexpr_stack_->tokens[0];
7338   ffeexpr_exprstack_push_operand_ (e);
7339
7340   return (ffelexHandler) ffeexpr_token_binary_;
7341 }
7342
7343 /* ffeexpr_cb_close_paren_ambig_ -- OPEN_PAREN expr
7344
7345    Pass it to ffeexpr_rhs as the callback routine.
7346
7347    We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
7348    with the next token in t.  If the next token is possibly a binary
7349    operator, continue processing the outer expression.  If the next
7350    token is COMMA, then the expression is a unit specifier, and
7351    parentheses should not be added to it because it surrounds the
7352    I/O control list that starts with the unit specifier (and continues
7353    on from here -- we haven't seen the CLOSE_PAREN that matches the
7354    OPEN_PAREN, it is up to the callback function to expect to see it
7355    at some point).  In this case, we notify the callback function that
7356    the COMMA is inside, not outside, the parens by wrapping the expression
7357    in an opITEM (with a NULL trail) -- the callback function presumably
7358    unwraps it after seeing this kludgey indicator.
7359
7360    If the next token is CLOSE_PAREN, then we go to the _1_ state to
7361    decide what to do with the token after that.
7362
7363    15-Feb-91  JCB  1.1
7364       Use an extra state for the CLOSE_PAREN case to make READ &co really
7365       work right.  */
7366
7367 static ffelexHandler
7368 ffeexpr_cb_close_paren_ambig_ (ffelexToken ft, ffebld expr, ffelexToken t)
7369 {
7370   ffeexprCallback callback;
7371   ffeexprStack_ s;
7372
7373   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7374     {                           /* Need to see the next token before we
7375                                    decide anything. */
7376       ffeexpr_stack_->expr = expr;
7377       ffeexpr_tokens_[0] = ffelex_token_use (ft);
7378       ffeexpr_tokens_[1] = ffelex_token_use (t);
7379       return (ffelexHandler) ffeexpr_cb_close_paren_ambig_1_;
7380     }
7381
7382   expr = ffeexpr_finished_ambig_ (ft, expr);
7383
7384   /* Let the callback function handle the case where t isn't COMMA. */
7385
7386   /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
7387      that preceded the expression starts a list of expressions, and the expr
7388      hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
7389      node.  The callback function should extract the real expr from the head
7390      of this opITEM node after testing it. */
7391
7392   expr = ffebld_new_item (expr, NULL);
7393
7394   ffebld_pool_pop ();
7395   callback = ffeexpr_stack_->callback;
7396   ffelex_token_kill (ffeexpr_stack_->first_token);
7397   s = ffeexpr_stack_->previous;
7398   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
7399   ffeexpr_stack_ = s;
7400   return (ffelexHandler) (*callback) (ft, expr, t);
7401 }
7402
7403 /* ffeexpr_cb_close_paren_ambig_1_ -- OPEN_PAREN expr CLOSE_PAREN
7404
7405    See ffeexpr_cb_close_paren_ambig_.
7406
7407    We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
7408    with the next token in t.  If the next token is possibly a binary
7409    operator, continue processing the outer expression.  If the next
7410    token is COMMA, the expression is a parenthesized format specifier.
7411    If the next token is not EOS or SEMICOLON, then because it is not a
7412    binary operator (it is NAME, OPEN_PAREN, &c), the expression is
7413    a unit specifier, and parentheses should not be added to it because
7414    they surround the I/O control list that consists of only the unit
7415    specifier.  If the next token is EOS or SEMICOLON, the statement
7416    must be disambiguated by looking at the type of the expression -- a
7417    character expression is a parenthesized format specifier, while a
7418    non-character expression is a unit specifier.
7419
7420    Another issue is how to do the callback so the recipient of the
7421    next token knows how to handle it if it is a COMMA.  In all other
7422    cases, disambiguation is straightforward: the same approach as the
7423    above is used.
7424
7425    EXTENSION: in COMMA case, if not pedantic, use same disambiguation
7426    as for EOS/SEMICOLON case; f2c allows "READ (cilist) [[,]iolist]"
7427    and apparently other compilers do, as well, and some code out there
7428    uses this "feature".
7429
7430    19-Feb-91  JCB  1.1
7431       Extend to allow COMMA as nondisambiguating by itself.  Remember
7432       to not try and check info field for opSTAR, since that expr doesn't
7433       have a valid info field.  */
7434
7435 static ffelexHandler
7436 ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t)
7437 {
7438   ffeexprCallback callback;
7439   ffeexprStack_ s;
7440   ffelexHandler next;
7441   ffelexToken orig_ft = ffeexpr_tokens_[0];     /* In case callback clobbers
7442                                                    these. */
7443   ffelexToken orig_t = ffeexpr_tokens_[1];
7444   ffebld expr = ffeexpr_stack_->expr;
7445
7446   switch (ffelex_token_type (t))
7447     {
7448     case FFELEX_typeCOMMA:      /* Subexpr is parenthesized format specifier. */
7449       if (ffe_is_pedantic ())
7450         goto pedantic_comma;    /* :::::::::::::::::::: */
7451       /* Fall through. */
7452     case FFELEX_typeEOS:        /* Ambiguous; use type of expr to
7453                                    disambiguate. */
7454     case FFELEX_typeSEMICOLON:
7455       if ((expr == NULL) || (ffebld_op (expr) == FFEBLD_opANY)
7456           || (ffebld_op (expr) == FFEBLD_opSTAR)
7457           || (ffeinfo_basictype (ffebld_info (expr))
7458               != FFEINFO_basictypeCHARACTER))
7459         break;                  /* Not a valid CHARACTER entity, can't be a
7460                                    format spec. */
7461       /* Fall through. */
7462     default:                    /* Binary op (we assume; error otherwise);
7463                                    format specifier. */
7464
7465     pedantic_comma:             /* :::::::::::::::::::: */
7466
7467       switch (ffeexpr_stack_->context)
7468         {
7469         case FFEEXPR_contextFILENUMAMBIG:
7470           ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
7471           break;
7472
7473         case FFEEXPR_contextFILEUNITAMBIG:
7474           ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
7475           break;
7476
7477         default:
7478           assert ("bad context" == NULL);
7479           break;
7480         }
7481
7482       ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
7483       next = (ffelexHandler) ffeexpr_cb_close_paren_ (orig_ft, expr, orig_t);
7484       ffelex_token_kill (orig_ft);
7485       ffelex_token_kill (orig_t);
7486       return (ffelexHandler) (*next) (t);
7487
7488     case FFELEX_typeOPEN_PAREN:/* Non-binary op; beginning of I/O list. */
7489     case FFELEX_typeNAME:
7490       break;
7491     }
7492
7493   expr = ffeexpr_finished_ambig_ (orig_ft, expr);
7494
7495   /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
7496      that preceded the expression starts a list of expressions, and the expr
7497      hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
7498      node.  The callback function should extract the real expr from the head
7499      of this opITEM node after testing it. */
7500
7501   expr = ffebld_new_item (expr, NULL);
7502
7503   ffebld_pool_pop ();
7504   callback = ffeexpr_stack_->callback;
7505   ffelex_token_kill (ffeexpr_stack_->first_token);
7506   s = ffeexpr_stack_->previous;
7507   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
7508   ffeexpr_stack_ = s;
7509   next = (ffelexHandler) (*callback) (orig_ft, expr, orig_t);
7510   ffelex_token_kill (orig_ft);
7511   ffelex_token_kill (orig_t);
7512   return (ffelexHandler) (*next) (t);
7513 }
7514
7515 /* ffeexpr_cb_close_paren_c_ -- OPEN_PAREN expr (possible complex)
7516
7517    Pass it to ffeexpr_rhs as the callback routine.
7518
7519    Makes sure the end token is close-paren and swallows it, or a comma
7520    and handles complex/implied-do possibilities, else issues
7521    an error message and doesn't swallow the token (passing it along instead).  */
7522
7523 static ffelexHandler
7524 ffeexpr_cb_close_paren_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
7525 {
7526   /* First check to see if this is a possible complex entity.  It is if the
7527      token is a comma. */
7528
7529   if (ffelex_token_type (t) == FFELEX_typeCOMMA)
7530     {
7531       ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
7532       ffeexpr_stack_->expr = expr;
7533       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7534                                 FFEEXPR_contextPAREN_, ffeexpr_cb_comma_c_);
7535     }
7536
7537   return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
7538 }
7539
7540 /* ffeexpr_cb_comma_c_ -- OPEN_PAREN expr COMMA expr
7541
7542    Pass it to ffeexpr_rhs as the callback routine.
7543
7544    If this token is not a comma, we have a complex constant (or an attempt
7545    at one), so handle it accordingly, displaying error messages if the token
7546    is not a close-paren.  */
7547
7548 static ffelexHandler
7549 ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
7550 {
7551   ffeexprExpr_ e;
7552   ffeinfoBasictype lty = (ffeexpr_stack_->expr == NULL)
7553     ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (ffeexpr_stack_->expr));
7554   ffeinfoBasictype rty = (expr == NULL)
7555     ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (expr));
7556   ffeinfoKindtype lkt;
7557   ffeinfoKindtype rkt;
7558   ffeinfoKindtype nkt;
7559   bool ok = TRUE;
7560   ffebld orig;
7561
7562   if ((ffeexpr_stack_->expr == NULL)
7563       || (ffebld_op (ffeexpr_stack_->expr) != FFEBLD_opCONTER)
7564       || (((orig = ffebld_conter_orig (ffeexpr_stack_->expr)) != NULL)
7565           && (((ffebld_op (orig) != FFEBLD_opUMINUS)
7566                && (ffebld_op (orig) != FFEBLD_opUPLUS))
7567               || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
7568       || ((lty != FFEINFO_basictypeINTEGER)
7569           && (lty != FFEINFO_basictypeREAL)))
7570     {
7571       if ((lty != FFEINFO_basictypeANY)
7572           && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
7573         {
7574           ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
7575                      ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
7576           ffebad_string ("Real");
7577           ffebad_finish ();
7578         }
7579       ok = FALSE;
7580     }
7581   if ((expr == NULL)
7582       || (ffebld_op (expr) != FFEBLD_opCONTER)
7583       || (((orig = ffebld_conter_orig (expr)) != NULL)
7584           && (((ffebld_op (orig) != FFEBLD_opUMINUS)
7585                && (ffebld_op (orig) != FFEBLD_opUPLUS))
7586               || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
7587       || ((rty != FFEINFO_basictypeINTEGER)
7588           && (rty != FFEINFO_basictypeREAL)))
7589     {
7590       if ((rty != FFEINFO_basictypeANY)
7591           && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
7592         {
7593           ffebad_here (0, ffelex_token_where_line (ft),
7594                        ffelex_token_where_column (ft));
7595           ffebad_string ("Imaginary");
7596           ffebad_finish ();
7597         }
7598       ok = FALSE;
7599     }
7600
7601   ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7602
7603   /* Push the (parenthesized) expression as an operand onto the expression
7604      stack. */
7605
7606   e = ffeexpr_expr_new_ ();
7607   e->type = FFEEXPR_exprtypeOPERAND_;
7608   e->token = ffeexpr_stack_->tokens[0];
7609
7610   if (ok)
7611     {
7612       if (lty == FFEINFO_basictypeINTEGER)
7613         lkt = FFEINFO_kindtypeREALDEFAULT;
7614       else
7615         lkt = ffeinfo_kindtype (ffebld_info (ffeexpr_stack_->expr));
7616       if (rty == FFEINFO_basictypeINTEGER)
7617         rkt = FFEINFO_kindtypeREALDEFAULT;
7618       else
7619         rkt = ffeinfo_kindtype (ffebld_info (expr));
7620
7621       nkt = ffeinfo_kindtype_max (FFEINFO_basictypeCOMPLEX, lkt, rkt);
7622       ffeexpr_stack_->expr = ffeexpr_convert (ffeexpr_stack_->expr,
7623                        ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
7624                  FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
7625                                               FFEEXPR_contextLET);
7626       expr = ffeexpr_convert (expr,
7627                        ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
7628                  FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
7629                               FFEEXPR_contextLET);
7630     }
7631   else
7632     nkt = FFEINFO_kindtypeANY;
7633
7634   switch (nkt)
7635     {
7636 #if FFETARGET_okCOMPLEX1
7637     case FFEINFO_kindtypeREAL1:
7638       e->u.operand = ffebld_new_conter (ffebld_constant_new_complex1
7639               (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7640       ffebld_set_info (e->u.operand,
7641                        ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7642                                   FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7643                                     FFETARGET_charactersizeNONE));
7644       break;
7645 #endif
7646
7647 #if FFETARGET_okCOMPLEX2
7648     case FFEINFO_kindtypeREAL2:
7649       e->u.operand = ffebld_new_conter (ffebld_constant_new_complex2
7650               (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7651       ffebld_set_info (e->u.operand,
7652                        ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7653                                   FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7654                                     FFETARGET_charactersizeNONE));
7655       break;
7656 #endif
7657
7658 #if FFETARGET_okCOMPLEX3
7659     case FFEINFO_kindtypeREAL3:
7660       e->u.operand = ffebld_new_conter (ffebld_constant_new_complex3
7661               (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7662       ffebld_set_info (e->u.operand,
7663                        ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7664                                   FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7665                                     FFETARGET_charactersizeNONE));
7666       break;
7667 #endif
7668
7669 #if FFETARGET_okCOMPLEX4
7670     case FFEINFO_kindtypeREAL4:
7671       e->u.operand = ffebld_new_conter (ffebld_constant_new_complex4
7672               (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7673       ffebld_set_info (e->u.operand,
7674                        ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7675                                   FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7676                                     FFETARGET_charactersizeNONE));
7677       break;
7678 #endif
7679
7680     default:
7681       if (ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
7682                         ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX))
7683         {
7684           ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7685                      ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7686           ffebad_finish ();
7687         }
7688       /* Fall through. */
7689     case FFEINFO_kindtypeANY:
7690       e->u.operand = ffebld_new_any ();
7691       ffebld_set_info (e->u.operand, ffeinfo_new_any ());
7692       break;
7693     }
7694   ffeexpr_exprstack_push_operand_ (e);
7695
7696   /* Now, if the token is a close parenthese, we're in great shape so return
7697      the next handler. */
7698
7699   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7700     return (ffelexHandler) ffeexpr_token_binary_;
7701
7702   /* Oops, naughty user didn't specify the close paren! */
7703
7704   if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7705     {
7706       ffebad_here (0, ffelex_token_where_line (t),
7707                    ffelex_token_where_column (t));
7708       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7709                    ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7710       ffebad_finish ();
7711     }
7712
7713   return
7714     (ffelexHandler) ffeexpr_find_close_paren_ (t,
7715                                                (ffelexHandler)
7716                                                ffeexpr_token_binary_);
7717 }
7718
7719 /* ffeexpr_cb_close_paren_ci_ -- OPEN_PAREN expr (possible complex or
7720                                     implied-DO construct)
7721
7722    Pass it to ffeexpr_rhs as the callback routine.
7723
7724    Makes sure the end token is close-paren and swallows it, or a comma
7725    and handles complex/implied-do possibilities, else issues
7726    an error message and doesn't swallow the token (passing it along instead).  */
7727
7728 static ffelexHandler
7729 ffeexpr_cb_close_paren_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
7730 {
7731   ffeexprContext ctx;
7732
7733   /* First check to see if this is a possible complex or implied-DO entity.
7734      It is if the token is a comma. */
7735
7736   if (ffelex_token_type (t) == FFELEX_typeCOMMA)
7737     {
7738       switch (ffeexpr_stack_->context)
7739         {
7740         case FFEEXPR_contextIOLIST:
7741         case FFEEXPR_contextIMPDOITEM_:
7742           ctx = FFEEXPR_contextIMPDOITEM_;
7743           break;
7744
7745         case FFEEXPR_contextIOLISTDF:
7746         case FFEEXPR_contextIMPDOITEMDF_:
7747           ctx = FFEEXPR_contextIMPDOITEMDF_;
7748           break;
7749
7750         default:
7751           assert ("bad context" == NULL);
7752           ctx = FFEEXPR_contextIMPDOITEM_;
7753           break;
7754         }
7755
7756       ffeexpr_stack_->tokens[0] = ffelex_token_use (ft);
7757       ffeexpr_stack_->expr = expr;
7758       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7759                                           ctx, ffeexpr_cb_comma_ci_);
7760     }
7761
7762   ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
7763   return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
7764 }
7765
7766 /* ffeexpr_cb_comma_ci_ -- OPEN_PAREN expr COMMA expr
7767
7768    Pass it to ffeexpr_rhs as the callback routine.
7769
7770    If this token is not a comma, we have a complex constant (or an attempt
7771    at one), so handle it accordingly, displaying error messages if the token
7772    is not a close-paren.  If we have a comma here, it is an attempt at an
7773    implied-DO, so start making a list accordingly.  Oh, it might be an
7774    equal sign also, meaning an implied-DO with only one item in its list.  */
7775
7776 static ffelexHandler
7777 ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
7778 {
7779   ffebld fexpr;
7780
7781   /* First check to see if this is a possible complex constant.  It is if the
7782      token is not a comma or an equals sign, in which case it should be a
7783      close-paren. */
7784
7785   if ((ffelex_token_type (t) != FFELEX_typeCOMMA)
7786       && (ffelex_token_type (t) != FFELEX_typeEQUALS))
7787     {
7788       ffeexpr_stack_->tokens[1] = ffeexpr_stack_->tokens[0];
7789       ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
7790       return (ffelexHandler) ffeexpr_cb_comma_c_ (ft, expr, t);
7791     }
7792
7793   /* Here we have either EQUALS or COMMA, meaning we are in an implied-DO
7794      construct.  Make a list and handle accordingly. */
7795
7796   ffelex_token_kill (ffeexpr_stack_->tokens[0]);
7797   fexpr = ffeexpr_stack_->expr;
7798   ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7799   ffebld_append_item (&ffeexpr_stack_->bottom, fexpr);
7800   return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
7801 }
7802
7803 /* ffeexpr_cb_comma_i_ -- OPEN_PAREN expr
7804
7805    Pass it to ffeexpr_rhs as the callback routine.
7806
7807    Handle first item in an implied-DO construct.  */
7808
7809 static ffelexHandler
7810 ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr, ffelexToken t)
7811 {
7812   if (ffelex_token_type (t) != FFELEX_typeCOMMA)
7813     {
7814       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7815         {
7816           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7817           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7818                    ffelex_token_where_column (ffeexpr_stack_->first_token));
7819           ffebad_finish ();
7820         }
7821       ffebld_end_list (&ffeexpr_stack_->bottom);
7822       ffeexpr_stack_->expr = ffebld_new_any ();
7823       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7824       if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7825         return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7826       return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7827     }
7828
7829   return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
7830 }
7831
7832 /* ffeexpr_cb_comma_i_1_ -- OPEN_PAREN expr
7833
7834    Pass it to ffeexpr_rhs as the callback routine.
7835
7836    Handle first item in an implied-DO construct.  */
7837
7838 static ffelexHandler
7839 ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr, ffelexToken t)
7840 {
7841   ffeexprContext ctxi;
7842   ffeexprContext ctxc;
7843
7844   switch (ffeexpr_stack_->context)
7845     {
7846     case FFEEXPR_contextDATA:
7847     case FFEEXPR_contextDATAIMPDOITEM_:
7848       ctxi = FFEEXPR_contextDATAIMPDOITEM_;
7849       ctxc = FFEEXPR_contextDATAIMPDOCTRL_;
7850       break;
7851
7852     case FFEEXPR_contextIOLIST:
7853     case FFEEXPR_contextIMPDOITEM_:
7854       ctxi = FFEEXPR_contextIMPDOITEM_;
7855       ctxc = FFEEXPR_contextIMPDOCTRL_;
7856       break;
7857
7858     case FFEEXPR_contextIOLISTDF:
7859     case FFEEXPR_contextIMPDOITEMDF_:
7860       ctxi = FFEEXPR_contextIMPDOITEMDF_;
7861       ctxc = FFEEXPR_contextIMPDOCTRL_;
7862       break;
7863
7864     default:
7865       assert ("bad context" == NULL);
7866       ctxi = FFEEXPR_context;
7867       ctxc = FFEEXPR_context;
7868       break;
7869     }
7870
7871   switch (ffelex_token_type (t))
7872     {
7873     case FFELEX_typeCOMMA:
7874       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7875       if (ffeexpr_stack_->is_rhs)
7876         return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7877                                             ctxi, ffeexpr_cb_comma_i_1_);
7878       return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7879                                           ctxi, ffeexpr_cb_comma_i_1_);
7880
7881     case FFELEX_typeEQUALS:
7882       ffebld_end_list (&ffeexpr_stack_->bottom);
7883
7884       /* Complain if implied-DO variable in list of items to be read.  */
7885
7886       if ((ctxc == FFEEXPR_contextIMPDOCTRL_) && !ffeexpr_stack_->is_rhs)
7887         ffeexpr_check_impdo_ (ffeexpr_stack_->expr,
7888                               ffeexpr_stack_->first_token, expr, ft);
7889
7890       /* Set doiter flag for all appropriate SYMTERs.  */
7891
7892       ffeexpr_update_impdo_ (ffeexpr_stack_->expr, expr);
7893
7894       ffeexpr_stack_->expr = ffebld_new_impdo (ffeexpr_stack_->expr, NULL);
7895       ffebld_set_info (ffeexpr_stack_->expr,
7896                        ffeinfo_new (FFEINFO_basictypeNONE,
7897                                     FFEINFO_kindtypeNONE,
7898                                     0,
7899                                     FFEINFO_kindNONE,
7900                                     FFEINFO_whereNONE,
7901                                     FFETARGET_charactersizeNONE));
7902       ffebld_init_list (&(ffebld_right (ffeexpr_stack_->expr)),
7903                         &ffeexpr_stack_->bottom);
7904       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7905       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7906                                           ctxc, ffeexpr_cb_comma_i_2_);
7907
7908     default:
7909       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7910         {
7911           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7912           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7913                    ffelex_token_where_column (ffeexpr_stack_->first_token));
7914           ffebad_finish ();
7915         }
7916       ffebld_end_list (&ffeexpr_stack_->bottom);
7917       ffeexpr_stack_->expr = ffebld_new_any ();
7918       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7919       if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7920         return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7921       return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7922     }
7923 }
7924
7925 /* ffeexpr_cb_comma_i_2_ -- OPEN_PAREN expr-list EQUALS expr
7926
7927    Pass it to ffeexpr_rhs as the callback routine.
7928
7929    Handle start-value in an implied-DO construct.  */
7930
7931 static ffelexHandler
7932 ffeexpr_cb_comma_i_2_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7933 {
7934   ffeexprContext ctx;
7935
7936   switch (ffeexpr_stack_->context)
7937     {
7938     case FFEEXPR_contextDATA:
7939     case FFEEXPR_contextDATAIMPDOITEM_:
7940       ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7941       break;
7942
7943     case FFEEXPR_contextIOLIST:
7944     case FFEEXPR_contextIOLISTDF:
7945     case FFEEXPR_contextIMPDOITEM_:
7946     case FFEEXPR_contextIMPDOITEMDF_:
7947       ctx = FFEEXPR_contextIMPDOCTRL_;
7948       break;
7949
7950     default:
7951       assert ("bad context" == NULL);
7952       ctx = FFEEXPR_context;
7953       break;
7954     }
7955
7956   switch (ffelex_token_type (t))
7957     {
7958     case FFELEX_typeCOMMA:
7959       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7960       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7961                                           ctx, ffeexpr_cb_comma_i_3_);
7962       break;
7963
7964     default:
7965       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7966         {
7967           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7968           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7969                    ffelex_token_where_column (ffeexpr_stack_->first_token));
7970           ffebad_finish ();
7971         }
7972       ffebld_end_list (&ffeexpr_stack_->bottom);
7973       ffeexpr_stack_->expr = ffebld_new_any ();
7974       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7975       if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7976         return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7977       return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7978     }
7979 }
7980
7981 /* ffeexpr_cb_comma_i_3_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7982
7983    Pass it to ffeexpr_rhs as the callback routine.
7984
7985    Handle end-value in an implied-DO construct.  */
7986
7987 static ffelexHandler
7988 ffeexpr_cb_comma_i_3_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7989 {
7990   ffeexprContext ctx;
7991
7992   switch (ffeexpr_stack_->context)
7993     {
7994     case FFEEXPR_contextDATA:
7995     case FFEEXPR_contextDATAIMPDOITEM_:
7996       ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7997       break;
7998
7999     case FFEEXPR_contextIOLIST:
8000     case FFEEXPR_contextIOLISTDF:
8001     case FFEEXPR_contextIMPDOITEM_:
8002     case FFEEXPR_contextIMPDOITEMDF_:
8003       ctx = FFEEXPR_contextIMPDOCTRL_;
8004       break;
8005
8006     default:
8007       assert ("bad context" == NULL);
8008       ctx = FFEEXPR_context;
8009       break;
8010     }
8011
8012   switch (ffelex_token_type (t))
8013     {
8014     case FFELEX_typeCOMMA:
8015       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
8016       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8017                                           ctx, ffeexpr_cb_comma_i_4_);
8018       break;
8019
8020     case FFELEX_typeCLOSE_PAREN:
8021       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
8022       return (ffelexHandler) ffeexpr_cb_comma_i_4_ (NULL, NULL, t);
8023       break;
8024
8025     default:
8026       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
8027         {
8028           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8029           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
8030                    ffelex_token_where_column (ffeexpr_stack_->first_token));
8031           ffebad_finish ();
8032         }
8033       ffebld_end_list (&ffeexpr_stack_->bottom);
8034       ffeexpr_stack_->expr = ffebld_new_any ();
8035       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
8036       if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
8037         return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
8038       return (ffelexHandler) ffeexpr_cb_comma_i_5_;
8039     }
8040 }
8041
8042 /* ffeexpr_cb_comma_i_4_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
8043                                [COMMA expr]
8044
8045    Pass it to ffeexpr_rhs as the callback routine.
8046
8047    Handle incr-value in an implied-DO construct.  */
8048
8049 static ffelexHandler
8050 ffeexpr_cb_comma_i_4_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
8051 {
8052   switch (ffelex_token_type (t))
8053     {
8054     case FFELEX_typeCLOSE_PAREN:
8055       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
8056       ffebld_end_list (&ffeexpr_stack_->bottom);
8057       {
8058         ffebld item;
8059
8060         for (item = ffebld_left (ffeexpr_stack_->expr);
8061              item != NULL;
8062              item = ffebld_trail (item))
8063           if (ffebld_op (ffebld_head (item)) == FFEBLD_opANY)
8064             goto replace_with_any;      /* :::::::::::::::::::: */
8065
8066         for (item = ffebld_right (ffeexpr_stack_->expr);
8067              item != NULL;
8068              item = ffebld_trail (item))
8069           if ((ffebld_head (item) != NULL)      /* Increment may be NULL. */
8070               && (ffebld_op (ffebld_head (item)) == FFEBLD_opANY))
8071             goto replace_with_any;      /* :::::::::::::::::::: */
8072       }
8073       break;
8074
8075     default:
8076       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
8077         {
8078           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8079           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
8080                    ffelex_token_where_column (ffeexpr_stack_->first_token));
8081           ffebad_finish ();
8082         }
8083       ffebld_end_list (&ffeexpr_stack_->bottom);
8084
8085     replace_with_any:           /* :::::::::::::::::::: */
8086
8087       ffeexpr_stack_->expr = ffebld_new_any ();
8088       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
8089       break;
8090     }
8091
8092   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
8093     return (ffelexHandler) ffeexpr_cb_comma_i_5_;
8094   return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
8095 }
8096
8097 /* ffeexpr_cb_comma_i_5_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
8098                                [COMMA expr] CLOSE_PAREN
8099
8100    Pass it to ffeexpr_rhs as the callback routine.
8101
8102    Collects token following implied-DO construct for callback function.  */
8103
8104 static ffelexHandler
8105 ffeexpr_cb_comma_i_5_ (ffelexToken t)
8106 {
8107   ffeexprCallback callback;
8108   ffeexprStack_ s;
8109   ffelexHandler next;
8110   ffelexToken ft;
8111   ffebld expr;
8112   bool terminate;
8113
8114   switch (ffeexpr_stack_->context)
8115     {
8116     case FFEEXPR_contextDATA:
8117     case FFEEXPR_contextDATAIMPDOITEM_:
8118       terminate = TRUE;
8119       break;
8120
8121     case FFEEXPR_contextIOLIST:
8122     case FFEEXPR_contextIOLISTDF:
8123     case FFEEXPR_contextIMPDOITEM_:
8124     case FFEEXPR_contextIMPDOITEMDF_:
8125       terminate = FALSE;
8126       break;
8127
8128     default:
8129       assert ("bad context" == NULL);
8130       terminate = FALSE;
8131       break;
8132     }
8133
8134   ffebld_pool_pop ();
8135   callback = ffeexpr_stack_->callback;
8136   ft = ffeexpr_stack_->first_token;
8137   expr = ffeexpr_stack_->expr;
8138   s = ffeexpr_stack_->previous;
8139   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
8140                   sizeof (*ffeexpr_stack_));
8141   ffeexpr_stack_ = s;
8142   next = (ffelexHandler) (*callback) (ft, expr, t);
8143   ffelex_token_kill (ft);
8144   if (terminate)
8145     {
8146       ffesymbol_drive_sfnames (ffeexpr_check_impctrl_);
8147       --ffeexpr_level_;
8148       if (ffeexpr_level_ == 0)
8149         ffe_terminate_4 ();
8150     }
8151   return (ffelexHandler) next;
8152 }
8153
8154 /* ffeexpr_cb_end_loc_ -- Handle end of %LOC subexpression
8155
8156    Makes sure the end token is close-paren and swallows it, else issues
8157    an error message and doesn't swallow the token (passing it along instead).
8158    In either case wraps up subexpression construction by enclosing the
8159    ffebld expression in a %LOC.  */
8160
8161 static ffelexHandler
8162 ffeexpr_cb_end_loc_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
8163 {
8164   ffeexprExpr_ e;
8165
8166   /* First push the (%LOC) expression as an operand onto the expression
8167      stack. */
8168
8169   e = ffeexpr_expr_new_ ();
8170   e->type = FFEEXPR_exprtypeOPERAND_;
8171   e->token = ffeexpr_stack_->tokens[0];
8172   e->u.operand = ffebld_new_percent_loc (expr);
8173   ffebld_set_info (e->u.operand,
8174                    ffeinfo_new (FFEINFO_basictypeINTEGER,
8175                                 ffecom_pointer_kind (),
8176                                 0,
8177                                 FFEINFO_kindENTITY,
8178                                 FFEINFO_whereFLEETING,
8179                                 FFETARGET_charactersizeNONE));
8180 #if 0                           /* ~~ */
8181   e->u.operand = ffeexpr_collapse_percent_loc (e->u.operand, ft);
8182 #endif
8183   ffeexpr_exprstack_push_operand_ (e);
8184
8185   /* Now, if the token is a close parenthese, we're in great shape so return
8186      the next handler. */
8187
8188   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
8189     {
8190       ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8191       return (ffelexHandler) ffeexpr_token_binary_;
8192     }
8193
8194   /* Oops, naughty user didn't specify the close paren! */
8195
8196   if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
8197     {
8198       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8199       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
8200                    ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
8201       ffebad_finish ();
8202     }
8203
8204   ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8205   return
8206     (ffelexHandler) ffeexpr_find_close_paren_ (t,
8207                                                (ffelexHandler)
8208                                                ffeexpr_token_binary_);
8209 }
8210
8211 /* ffeexpr_cb_end_notloc_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
8212
8213    Should be CLOSE_PAREN, and make sure expr isn't a %(VAL,REF,DESCR).  */
8214
8215 static ffelexHandler
8216 ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr, ffelexToken t)
8217 {
8218   ffeexprExpr_ e;
8219   ffebldOp op;
8220
8221   /* If expression is itself a %(VAL,REF,DESCR), complain and strip off all
8222      such things until the lowest-level expression is reached.  */
8223
8224   op = ffebld_op (expr);
8225   if ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
8226       || (op == FFEBLD_opPERCENT_DESCR))
8227     {
8228       if (ffebad_start (FFEBAD_NESTED_PERCENT))
8229         {
8230           ffebad_here (0, ffelex_token_where_line (ft),
8231                        ffelex_token_where_column (ft));
8232           ffebad_finish ();
8233         }
8234
8235       do
8236         {
8237           expr = ffebld_left (expr);
8238           op = ffebld_op (expr);
8239         }
8240       while ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
8241              || (op == FFEBLD_opPERCENT_DESCR));
8242     }
8243
8244   /* Push the expression as an operand onto the expression stack. */
8245
8246   e = ffeexpr_expr_new_ ();
8247   e->type = FFEEXPR_exprtypeOPERAND_;
8248   e->token = ffeexpr_stack_->tokens[0];
8249   switch (ffeexpr_stack_->percent)
8250     {
8251     case FFEEXPR_percentVAL_:
8252       e->u.operand = ffebld_new_percent_val (expr);
8253       break;
8254
8255     case FFEEXPR_percentREF_:
8256       e->u.operand = ffebld_new_percent_ref (expr);
8257       break;
8258
8259     case FFEEXPR_percentDESCR_:
8260       e->u.operand = ffebld_new_percent_descr (expr);
8261       break;
8262
8263     default:
8264       assert ("%lossage" == NULL);
8265       e->u.operand = expr;
8266       break;
8267     }
8268   ffebld_set_info (e->u.operand, ffebld_info (expr));
8269 #if 0                           /* ~~ */
8270   e->u.operand = ffeexpr_collapse_percent_ ? ? ? (e->u.operand, ft);
8271 #endif
8272   ffeexpr_exprstack_push_operand_ (e);
8273
8274   /* Now, if the token is a close parenthese, we're in great shape so return
8275      the next handler. */
8276
8277   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
8278     return (ffelexHandler) ffeexpr_cb_end_notloc_1_;
8279
8280   /* Oops, naughty user didn't specify the close paren! */
8281
8282   if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
8283     {
8284       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8285       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
8286                    ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
8287       ffebad_finish ();
8288     }
8289
8290   ffebld_set_op (e->u.operand, FFEBLD_opPERCENT_LOC);
8291
8292   switch (ffeexpr_stack_->context)
8293     {
8294     case FFEEXPR_contextACTUALARG_:
8295       ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8296       break;
8297
8298     case FFEEXPR_contextINDEXORACTUALARG_:
8299       ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8300       break;
8301
8302     case FFEEXPR_contextSFUNCDEFACTUALARG_:
8303       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8304       break;
8305
8306     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8307       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8308       break;
8309
8310     default:
8311       assert ("bad context?!?!" == NULL);
8312       break;
8313     }
8314
8315   ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8316   return
8317     (ffelexHandler) ffeexpr_find_close_paren_ (t,
8318                                                (ffelexHandler)
8319                                                ffeexpr_cb_end_notloc_1_);
8320 }
8321
8322 /* ffeexpr_cb_end_notloc_1_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
8323    CLOSE_PAREN
8324
8325    Should be COMMA or CLOSE_PAREN, else change back to %LOC.  */
8326
8327 static ffelexHandler
8328 ffeexpr_cb_end_notloc_1_ (ffelexToken t)
8329 {
8330   switch (ffelex_token_type (t))
8331     {
8332     case FFELEX_typeCOMMA:
8333     case FFELEX_typeCLOSE_PAREN:
8334       switch (ffeexpr_stack_->context)
8335         {
8336         case FFEEXPR_contextACTUALARG_:
8337         case FFEEXPR_contextSFUNCDEFACTUALARG_:
8338           break;
8339
8340         case FFEEXPR_contextINDEXORACTUALARG_:
8341           ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
8342           break;
8343
8344         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8345           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
8346           break;
8347
8348         default:
8349           assert ("bad context?!?!" == NULL);
8350           break;
8351         }
8352       break;
8353
8354     default:
8355       if (ffebad_start (FFEBAD_INVALID_PERCENT))
8356         {
8357           ffebad_here (0,
8358                        ffelex_token_where_line (ffeexpr_stack_->first_token),
8359                    ffelex_token_where_column (ffeexpr_stack_->first_token));
8360           ffebad_string (ffelex_token_text (ffeexpr_stack_->tokens[1]));
8361           ffebad_finish ();
8362         }
8363
8364       ffebld_set_op (ffeexpr_stack_->exprstack->u.operand,
8365                      FFEBLD_opPERCENT_LOC);
8366
8367       switch (ffeexpr_stack_->context)
8368         {
8369         case FFEEXPR_contextACTUALARG_:
8370           ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8371           break;
8372
8373         case FFEEXPR_contextINDEXORACTUALARG_:
8374           ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8375           break;
8376
8377         case FFEEXPR_contextSFUNCDEFACTUALARG_:
8378           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8379           break;
8380
8381         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8382           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8383           break;
8384
8385         default:
8386           assert ("bad context?!?!" == NULL);
8387           break;
8388         }
8389     }
8390
8391   ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8392   return
8393     (ffelexHandler) ffeexpr_token_binary_ (t);
8394 }
8395
8396 /* Process DATA implied-DO iterator variables as this implied-DO level
8397    terminates.  At this point, ffeexpr_level_ == 1 when we see the
8398    last right-paren in "DATA (A(I),I=1,10)/.../".  */
8399
8400 static ffesymbol
8401 ffeexpr_check_impctrl_ (ffesymbol s)
8402 {
8403   assert (s != NULL);
8404   assert (ffesymbol_sfdummyparent (s) != NULL);
8405
8406   switch (ffesymbol_state (s))
8407     {
8408     case FFESYMBOL_stateNONE:   /* Used as iterator already. Now let symbol
8409                                    be used as iterator at any level at or
8410                                    innermore than the outermost of the
8411                                    current level and the symbol's current
8412                                    level. */
8413       if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
8414         {
8415           ffesymbol_signal_change (s);
8416           ffesymbol_set_maxentrynum (s, ffeexpr_level_);
8417           ffesymbol_signal_unreported (s);
8418         }
8419       break;
8420
8421     case FFESYMBOL_stateSEEN:   /* Seen already in this or other implied-DO.
8422                                    Error if at outermost level, else it can
8423                                    still become an iterator. */
8424       if ((ffeexpr_level_ == 1)
8425           && ffebad_start (FFEBAD_BAD_IMPDCL))
8426         {
8427           ffebad_string (ffesymbol_text (s));
8428           ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
8429           ffebad_finish ();
8430         }
8431       break;
8432
8433     case FFESYMBOL_stateUNCERTAIN:      /* Iterator. */
8434       assert (ffeexpr_level_ <= ffesymbol_maxentrynum (s));
8435       ffesymbol_signal_change (s);
8436       ffesymbol_set_state (s, FFESYMBOL_stateNONE);
8437       ffesymbol_signal_unreported (s);
8438       break;
8439
8440     case FFESYMBOL_stateUNDERSTOOD:
8441       break;                    /* ANY. */
8442
8443     default:
8444       assert ("Sasha Foo!!" == NULL);
8445       break;
8446     }
8447
8448   return s;
8449 }
8450
8451 /* Issue diagnostic if implied-DO variable appears in list of lhs
8452    expressions (as in "READ *, (I,I=1,10)").  */
8453
8454 static void
8455 ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
8456                       ffebld dovar, ffelexToken dovar_t)
8457 {
8458   ffebld item;
8459   ffesymbol dovar_sym;
8460   int itemnum;
8461
8462   if (ffebld_op (dovar) != FFEBLD_opSYMTER)
8463     return;                     /* Presumably opANY. */
8464
8465   dovar_sym = ffebld_symter (dovar);
8466
8467   for (itemnum = 1; list != NULL; list = ffebld_trail (list), ++itemnum)
8468     {
8469       if (((item = ffebld_head (list)) != NULL)
8470           && (ffebld_op (item) == FFEBLD_opSYMTER)
8471           && (ffebld_symter (item) == dovar_sym))
8472         {
8473           char itemno[20];
8474
8475           sprintf (&itemno[0], "%d", itemnum);
8476           if (ffebad_start (FFEBAD_DOITER_IMPDO))
8477             {
8478               ffebad_here (0, ffelex_token_where_line (list_t),
8479                            ffelex_token_where_column (list_t));
8480               ffebad_here (1, ffelex_token_where_line (dovar_t),
8481                            ffelex_token_where_column (dovar_t));
8482               ffebad_string (ffesymbol_text (dovar_sym));
8483               ffebad_string (itemno);
8484               ffebad_finish ();
8485             }
8486         }
8487     }
8488 }
8489
8490 /* Decorate any SYMTERs referencing the DO variable with the "doiter"
8491    flag.  */
8492
8493 static void
8494 ffeexpr_update_impdo_ (ffebld list, ffebld dovar)
8495 {
8496   ffesymbol dovar_sym;
8497
8498   if (ffebld_op (dovar) != FFEBLD_opSYMTER)
8499     return;                     /* Presumably opANY. */
8500
8501   dovar_sym = ffebld_symter (dovar);
8502
8503   ffeexpr_update_impdo_sym_ (list, dovar_sym);  /* Recurse! */
8504 }
8505
8506 /* Recursive function to update any expr so SYMTERs have "doiter" flag
8507    if they refer to the given variable.  */
8508
8509 static void
8510 ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar)
8511 {
8512   tail_recurse:                 /* :::::::::::::::::::: */
8513
8514   if (expr == NULL)
8515     return;
8516
8517   switch (ffebld_op (expr))
8518     {
8519     case FFEBLD_opSYMTER:
8520       if (ffebld_symter (expr) == dovar)
8521         ffebld_symter_set_is_doiter (expr, TRUE);
8522       break;
8523
8524     case FFEBLD_opITEM:
8525       ffeexpr_update_impdo_sym_ (ffebld_head (expr), dovar);
8526       expr = ffebld_trail (expr);
8527       goto tail_recurse;        /* :::::::::::::::::::: */
8528
8529     default:
8530       break;
8531     }
8532
8533   switch (ffebld_arity (expr))
8534     {
8535     case 2:
8536       ffeexpr_update_impdo_sym_ (ffebld_left (expr), dovar);
8537       expr = ffebld_right (expr);
8538       goto tail_recurse;        /* :::::::::::::::::::: */
8539
8540     case 1:
8541       expr = ffebld_left (expr);
8542       goto tail_recurse;        /* :::::::::::::::::::: */
8543
8544     default:
8545       break;
8546     }
8547
8548   return;
8549 }
8550
8551 /* ffeexpr_context_outer_ -- Determine context of stack entry, skipping PARENs
8552
8553    if (ffeexpr_context_outer_(ffeexpr_stack_) == FFEEXPR_contextIF)
8554        // After zero or more PAREN_ contexts, an IF context exists  */
8555
8556 static ffeexprContext
8557 ffeexpr_context_outer_ (ffeexprStack_ s)
8558 {
8559   assert (s != NULL);
8560
8561   for (;;)
8562     {
8563       switch (s->context)
8564         {
8565         case FFEEXPR_contextPAREN_:
8566         case FFEEXPR_contextPARENFILENUM_:
8567         case FFEEXPR_contextPARENFILEUNIT_:
8568           break;
8569
8570         default:
8571           return s->context;
8572         }
8573       s = s->previous;
8574       assert (s != NULL);
8575     }
8576 }
8577
8578 /* ffeexpr_percent_ -- Look up name in list of %FOO possibilities
8579
8580    ffeexprPercent_ p;
8581    ffelexToken t;
8582    p = ffeexpr_percent_(t);
8583
8584    Returns the identifier for the name, or the NONE identifier.  */
8585
8586 static ffeexprPercent_
8587 ffeexpr_percent_ (ffelexToken t)
8588 {
8589   const char *p;
8590
8591   switch (ffelex_token_length (t))
8592     {
8593     case 3:
8594       switch (*(p = ffelex_token_text (t)))
8595         {
8596         case FFESRC_CASE_MATCH_INIT ('L', 'l', match_3l, no_match_3):
8597           if ((ffesrc_char_match_noninit (*++p, 'O', 'o'))
8598               && (ffesrc_char_match_noninit (*++p, 'C', 'c')))
8599             return FFEEXPR_percentLOC_;
8600           return FFEEXPR_percentNONE_;
8601
8602         case FFESRC_CASE_MATCH_INIT ('R', 'r', match_3r, no_match_3):
8603           if ((ffesrc_char_match_noninit (*++p, 'E', 'e'))
8604               && (ffesrc_char_match_noninit (*++p, 'F', 'f')))
8605             return FFEEXPR_percentREF_;
8606           return FFEEXPR_percentNONE_;
8607
8608         case FFESRC_CASE_MATCH_INIT ('V', 'v', match_3v, no_match_3):
8609           if ((ffesrc_char_match_noninit (*++p, 'A', 'a'))
8610               && (ffesrc_char_match_noninit (*++p, 'L', 'l')))
8611             return FFEEXPR_percentVAL_;
8612           return FFEEXPR_percentNONE_;
8613
8614         default:
8615         no_match_3:             /* :::::::::::::::::::: */
8616           return FFEEXPR_percentNONE_;
8617         }
8618
8619     case 5:
8620       if (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "DESCR",
8621                             "descr", "Descr") == 0)
8622         return FFEEXPR_percentDESCR_;
8623       return FFEEXPR_percentNONE_;
8624
8625     default:
8626       return FFEEXPR_percentNONE_;
8627     }
8628 }
8629
8630 /* ffeexpr_type_combine -- Binop combine types, check for mythical new COMPLEX
8631
8632    See prototype.
8633
8634    If combining the two basictype/kindtype pairs produces a COMPLEX with an
8635    unsupported kind type, complain and use the default kind type for
8636    COMPLEX.  */
8637
8638 void
8639 ffeexpr_type_combine (ffeinfoBasictype *xnbt, ffeinfoKindtype *xnkt,
8640                       ffeinfoBasictype lbt, ffeinfoKindtype lkt,
8641                       ffeinfoBasictype rbt, ffeinfoKindtype rkt,
8642                       ffelexToken t)
8643 {
8644   ffeinfoBasictype nbt;
8645   ffeinfoKindtype nkt;
8646
8647   nbt = ffeinfo_basictype_combine (lbt, rbt);
8648   if ((nbt == FFEINFO_basictypeCOMPLEX)
8649       && ((lbt == nbt) || (lbt == FFEINFO_basictypeREAL))
8650       && ((rbt == nbt) || (rbt == FFEINFO_basictypeREAL)))
8651     {
8652       nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
8653       if (ffe_is_pedantic_not_90 () && (nkt == FFEINFO_kindtypeREALDOUBLE))
8654         nkt = FFEINFO_kindtypeNONE;     /* Force error. */
8655       switch (nkt)
8656         {
8657 #if FFETARGET_okCOMPLEX1
8658         case FFEINFO_kindtypeREAL1:
8659 #endif
8660 #if FFETARGET_okCOMPLEX2
8661         case FFEINFO_kindtypeREAL2:
8662 #endif
8663 #if FFETARGET_okCOMPLEX3
8664         case FFEINFO_kindtypeREAL3:
8665 #endif
8666 #if FFETARGET_okCOMPLEX4
8667         case FFEINFO_kindtypeREAL4:
8668 #endif
8669           break;                /* Fine and dandy. */
8670
8671         default:
8672           if (t != NULL)
8673             {
8674               ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
8675                             ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX);
8676               ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8677               ffebad_finish ();
8678             }
8679           nbt = FFEINFO_basictypeNONE;
8680           nkt = FFEINFO_kindtypeNONE;
8681           break;
8682
8683         case FFEINFO_kindtypeANY:
8684           nkt = FFEINFO_kindtypeREALDEFAULT;
8685           break;
8686         }
8687     }
8688   else
8689     {                           /* The normal stuff. */
8690       if (nbt == lbt)
8691         {
8692           if (nbt == rbt)
8693             nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
8694           else
8695             nkt = lkt;
8696         }
8697       else if (nbt == rbt)
8698         nkt = rkt;
8699       else
8700         {                       /* Let the caller do the complaining. */
8701           nbt = FFEINFO_basictypeNONE;
8702           nkt = FFEINFO_kindtypeNONE;
8703         }
8704     }
8705
8706   /* Always a good idea to avoid aliasing problems.  */
8707
8708   *xnbt = nbt;
8709   *xnkt = nkt;
8710 }
8711
8712 /* ffeexpr_token_first_lhs_ -- First state for lhs expression
8713
8714    Return a pointer to this function to the lexer (ffelex), which will
8715    invoke it for the next token.
8716
8717    Record line and column of first token in expression, then invoke the
8718    initial-state lhs handler.  */
8719
8720 static ffelexHandler
8721 ffeexpr_token_first_lhs_ (ffelexToken t)
8722 {
8723   ffeexpr_stack_->first_token = ffelex_token_use (t);
8724
8725   /* When changing the list of valid initial lhs tokens, check whether to
8726      update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
8727      READ (expr) <token> case -- it assumes it knows which tokens <token> can
8728      be to indicate an lhs (or implied DO), which right now is the set
8729      {NAME,OPEN_PAREN}.
8730
8731      This comment also appears in ffeexpr_token_lhs_. */
8732
8733   switch (ffelex_token_type (t))
8734     {
8735     case FFELEX_typeOPEN_PAREN:
8736       switch (ffeexpr_stack_->context)
8737         {
8738         case FFEEXPR_contextDATA:
8739           ffe_init_4 ();
8740           ffeexpr_level_ = 1;   /* Level of DATA implied-DO construct. */
8741           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8742           return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8743                         FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
8744
8745         case FFEEXPR_contextDATAIMPDOITEM_:
8746           ++ffeexpr_level_;     /* Level of DATA implied-DO construct. */
8747           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8748           return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8749                         FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
8750
8751         case FFEEXPR_contextIOLIST:
8752         case FFEEXPR_contextIMPDOITEM_:
8753           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8754           return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8755                             FFEEXPR_contextIMPDOITEM_, ffeexpr_cb_comma_i_);
8756
8757         case FFEEXPR_contextIOLISTDF:
8758         case FFEEXPR_contextIMPDOITEMDF_:
8759           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8760           return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8761                           FFEEXPR_contextIMPDOITEMDF_, ffeexpr_cb_comma_i_);
8762
8763         case FFEEXPR_contextFILEEXTFUNC:
8764           assert (ffeexpr_stack_->exprstack == NULL);
8765           return (ffelexHandler) ffeexpr_token_first_lhs_1_;
8766
8767         default:
8768           break;
8769         }
8770       break;
8771
8772     case FFELEX_typeNAME:
8773       switch (ffeexpr_stack_->context)
8774         {
8775         case FFEEXPR_contextFILENAMELIST:
8776           assert (ffeexpr_stack_->exprstack == NULL);
8777           return (ffelexHandler) ffeexpr_token_namelist_;
8778
8779         case FFEEXPR_contextFILEEXTFUNC:
8780           assert (ffeexpr_stack_->exprstack == NULL);
8781           return (ffelexHandler) ffeexpr_token_first_lhs_1_;
8782
8783         default:
8784           break;
8785         }
8786       break;
8787
8788     default:
8789       switch (ffeexpr_stack_->context)
8790         {
8791         case FFEEXPR_contextFILEEXTFUNC:
8792           assert (ffeexpr_stack_->exprstack == NULL);
8793           return (ffelexHandler) ffeexpr_token_first_lhs_1_;
8794
8795         default:
8796           break;
8797         }
8798       break;
8799     }
8800
8801   return (ffelexHandler) ffeexpr_token_lhs_ (t);
8802 }
8803
8804 /* ffeexpr_token_first_lhs_1_ -- NAME
8805
8806    return ffeexpr_token_first_lhs_1_;  // to lexer
8807
8808    Handle NAME as an external function (USEROPEN= VXT extension to OPEN
8809    statement).  */
8810
8811 static ffelexHandler
8812 ffeexpr_token_first_lhs_1_ (ffelexToken t)
8813 {
8814   ffeexprCallback callback;
8815   ffeexprStack_ s;
8816   ffelexHandler next;
8817   ffelexToken ft;
8818   ffesymbol sy = NULL;
8819   ffebld expr;
8820
8821   ffebld_pool_pop ();
8822   callback = ffeexpr_stack_->callback;
8823   ft = ffeexpr_stack_->first_token;
8824   s = ffeexpr_stack_->previous;
8825
8826   if ((ffelex_token_type (ft) != FFELEX_typeNAME)
8827       || (ffesymbol_attrs (sy = ffeexpr_declare_unadorned_ (ft, FALSE))
8828           & FFESYMBOL_attrANY))
8829     {
8830       if ((ffelex_token_type (ft) != FFELEX_typeNAME)
8831           || !(ffesymbol_attrs (sy) & FFESYMBOL_attrsANY))
8832         {
8833           ffebad_start (FFEBAD_EXPR_WRONG);
8834           ffebad_here (0, ffelex_token_where_line (ft),
8835                        ffelex_token_where_column (ft));
8836           ffebad_finish ();
8837         }
8838       expr = ffebld_new_any ();
8839       ffebld_set_info (expr, ffeinfo_new_any ());
8840     }
8841   else
8842     {
8843       expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
8844                                 FFEINTRIN_impNONE);
8845       ffebld_set_info (expr, ffesymbol_info (sy));
8846     }
8847
8848   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
8849                   sizeof (*ffeexpr_stack_));
8850   ffeexpr_stack_ = s;
8851
8852   next = (ffelexHandler) (*callback) (ft, expr, t);
8853   ffelex_token_kill (ft);
8854   return (ffelexHandler) next;
8855 }
8856
8857 /* ffeexpr_token_first_rhs_ -- First state for rhs expression
8858
8859    Record line and column of first token in expression, then invoke the
8860    initial-state rhs handler.
8861
8862    19-Feb-91  JCB  1.1
8863       Allow ASTERISK in PARENFILEUNIT_ case, but only on second level only
8864       (i.e. only as in READ(*), not READ((*))).  */
8865
8866 static ffelexHandler
8867 ffeexpr_token_first_rhs_ (ffelexToken t)
8868 {
8869   ffesymbol s;
8870
8871   ffeexpr_stack_->first_token = ffelex_token_use (t);
8872
8873   switch (ffelex_token_type (t))
8874     {
8875     case FFELEX_typeASTERISK:
8876       switch (ffeexpr_stack_->context)
8877         {
8878         case FFEEXPR_contextFILEFORMATNML:
8879           ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8880           /* Fall through.  */
8881         case FFEEXPR_contextFILEUNIT:
8882         case FFEEXPR_contextDIMLIST:
8883         case FFEEXPR_contextFILEFORMAT:
8884         case FFEEXPR_contextCHARACTERSIZE:
8885           if (ffeexpr_stack_->previous != NULL)
8886             break;              /* Valid only on first level. */
8887           assert (ffeexpr_stack_->exprstack == NULL);
8888           return (ffelexHandler) ffeexpr_token_first_rhs_1_;
8889
8890         case FFEEXPR_contextPARENFILEUNIT_:
8891           if (ffeexpr_stack_->previous->previous != NULL)
8892             break;              /* Valid only on second level. */
8893           assert (ffeexpr_stack_->exprstack == NULL);
8894           return (ffelexHandler) ffeexpr_token_first_rhs_1_;
8895
8896         case FFEEXPR_contextACTUALARG_:
8897           if (ffeexpr_stack_->previous->context
8898               != FFEEXPR_contextSUBROUTINEREF)
8899             {
8900               ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8901               break;
8902             }
8903           assert (ffeexpr_stack_->exprstack == NULL);
8904           return (ffelexHandler) ffeexpr_token_first_rhs_3_;
8905
8906         case FFEEXPR_contextINDEXORACTUALARG_:
8907           ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8908           break;
8909
8910         case FFEEXPR_contextSFUNCDEFACTUALARG_:
8911           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8912           break;
8913
8914         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8915           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8916           break;
8917
8918         default:
8919           break;
8920         }
8921       break;
8922
8923     case FFELEX_typeOPEN_PAREN:
8924       switch (ffeexpr_stack_->context)
8925         {
8926         case FFEEXPR_contextFILENUMAMBIG:
8927           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8928                                               FFEEXPR_contextPARENFILENUM_,
8929                                               ffeexpr_cb_close_paren_ambig_);
8930
8931         case FFEEXPR_contextFILEUNITAMBIG:
8932           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8933                                               FFEEXPR_contextPARENFILEUNIT_,
8934                                               ffeexpr_cb_close_paren_ambig_);
8935
8936         case FFEEXPR_contextIOLIST:
8937         case FFEEXPR_contextIMPDOITEM_:
8938           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8939                                               FFEEXPR_contextIMPDOITEM_,
8940                                               ffeexpr_cb_close_paren_ci_);
8941
8942         case FFEEXPR_contextIOLISTDF:
8943         case FFEEXPR_contextIMPDOITEMDF_:
8944           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8945                                               FFEEXPR_contextIMPDOITEMDF_,
8946                                               ffeexpr_cb_close_paren_ci_);
8947
8948         case FFEEXPR_contextFILEFORMATNML:
8949           ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8950           break;
8951
8952         case FFEEXPR_contextACTUALARG_:
8953           ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8954           break;
8955
8956         case FFEEXPR_contextINDEXORACTUALARG_:
8957           ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8958           break;
8959
8960         case FFEEXPR_contextSFUNCDEFACTUALARG_:
8961           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8962           break;
8963
8964         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8965           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8966           break;
8967
8968         default:
8969           break;
8970         }
8971       break;
8972
8973     case FFELEX_typeNUMBER:
8974       switch (ffeexpr_stack_->context)
8975         {
8976         case FFEEXPR_contextFILEFORMATNML:
8977           ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8978           /* Fall through.  */
8979         case FFEEXPR_contextFILEFORMAT:
8980           if (ffeexpr_stack_->previous != NULL)
8981             break;              /* Valid only on first level. */
8982           assert (ffeexpr_stack_->exprstack == NULL);
8983           return (ffelexHandler) ffeexpr_token_first_rhs_2_;
8984
8985         case FFEEXPR_contextACTUALARG_:
8986           ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8987           break;
8988
8989         case FFEEXPR_contextINDEXORACTUALARG_:
8990           ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8991           break;
8992
8993         case FFEEXPR_contextSFUNCDEFACTUALARG_:
8994           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8995           break;
8996
8997         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8998           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8999           break;
9000
9001         default:
9002           break;
9003         }
9004       break;
9005
9006     case FFELEX_typeNAME:
9007       switch (ffeexpr_stack_->context)
9008         {
9009         case FFEEXPR_contextFILEFORMATNML:
9010           assert (ffeexpr_stack_->exprstack == NULL);
9011           s = ffesymbol_lookup_local (t);
9012           if ((s != NULL) && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST))
9013             return (ffelexHandler) ffeexpr_token_namelist_;
9014           ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
9015           break;
9016
9017         default:
9018           break;
9019         }
9020       break;
9021
9022     case FFELEX_typePERCENT:
9023       switch (ffeexpr_stack_->context)
9024         {
9025         case FFEEXPR_contextACTUALARG_:
9026         case FFEEXPR_contextINDEXORACTUALARG_:
9027         case FFEEXPR_contextSFUNCDEFACTUALARG_:
9028         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9029           return (ffelexHandler) ffeexpr_token_first_rhs_5_;
9030
9031         case FFEEXPR_contextFILEFORMATNML:
9032           ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
9033           break;
9034
9035         default:
9036           break;
9037         }
9038
9039     default:
9040       switch (ffeexpr_stack_->context)
9041         {
9042         case FFEEXPR_contextACTUALARG_:
9043           ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
9044           break;
9045
9046         case FFEEXPR_contextINDEXORACTUALARG_:
9047           ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
9048           break;
9049
9050         case FFEEXPR_contextSFUNCDEFACTUALARG_:
9051           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
9052           break;
9053
9054         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9055           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
9056           break;
9057
9058         case FFEEXPR_contextFILEFORMATNML:
9059           ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
9060           break;
9061
9062         default:
9063           break;
9064         }
9065       break;
9066     }
9067
9068   return (ffelexHandler) ffeexpr_token_rhs_ (t);
9069 }
9070
9071 /* ffeexpr_token_first_rhs_1_ -- ASTERISK
9072
9073    return ffeexpr_token_first_rhs_1_;  // to lexer
9074
9075    Return STAR as expression.  */
9076
9077 static ffelexHandler
9078 ffeexpr_token_first_rhs_1_ (ffelexToken t)
9079 {
9080   ffebld expr;
9081   ffeexprCallback callback;
9082   ffeexprStack_ s;
9083   ffelexHandler next;
9084   ffelexToken ft;
9085
9086   expr = ffebld_new_star ();
9087   ffebld_pool_pop ();
9088   callback = ffeexpr_stack_->callback;
9089   ft = ffeexpr_stack_->first_token;
9090   s = ffeexpr_stack_->previous;
9091   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
9092   ffeexpr_stack_ = s;
9093   next = (ffelexHandler) (*callback) (ft, expr, t);
9094   ffelex_token_kill (ft);
9095   return (ffelexHandler) next;
9096 }
9097
9098 /* ffeexpr_token_first_rhs_2_ -- NUMBER
9099
9100    return ffeexpr_token_first_rhs_2_;  // to lexer
9101
9102    Return NULL as expression; NUMBER as first (and only) token, unless the
9103    current token is not a terminating token, in which case run normal
9104    expression handling.  */
9105
9106 static ffelexHandler
9107 ffeexpr_token_first_rhs_2_ (ffelexToken t)
9108 {
9109   ffeexprCallback callback;
9110   ffeexprStack_ s;
9111   ffelexHandler next;
9112   ffelexToken ft;
9113
9114   switch (ffelex_token_type (t))
9115     {
9116     case FFELEX_typeCLOSE_PAREN:
9117     case FFELEX_typeCOMMA:
9118     case FFELEX_typeEOS:
9119     case FFELEX_typeSEMICOLON:
9120       break;
9121
9122     default:
9123       next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9124       return (ffelexHandler) (*next) (t);
9125     }
9126
9127   ffebld_pool_pop ();
9128   callback = ffeexpr_stack_->callback;
9129   ft = ffeexpr_stack_->first_token;
9130   s = ffeexpr_stack_->previous;
9131   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
9132                   sizeof (*ffeexpr_stack_));
9133   ffeexpr_stack_ = s;
9134   next = (ffelexHandler) (*callback) (ft, NULL, t);
9135   ffelex_token_kill (ft);
9136   return (ffelexHandler) next;
9137 }
9138
9139 /* ffeexpr_token_first_rhs_3_ -- ASTERISK
9140
9141    return ffeexpr_token_first_rhs_3_;  // to lexer
9142
9143    Expect NUMBER, make LABTOK (with copy of token if not inhibited after
9144    confirming, else NULL).  */
9145
9146 static ffelexHandler
9147 ffeexpr_token_first_rhs_3_ (ffelexToken t)
9148 {
9149   ffelexHandler next;
9150
9151   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
9152     {                           /* An error, but let normal processing handle
9153                                    it. */
9154       next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9155       return (ffelexHandler) (*next) (t);
9156     }
9157
9158   /* Special case: when we see "*10" as an argument to a subroutine
9159      reference, we confirm the current statement and, if not inhibited at
9160      this point, put a copy of the token into a LABTOK node.  We do this
9161      instead of just resolving the label directly via ffelab and putting it
9162      into a LABTER simply to improve error reporting and consistency in
9163      ffestc.  We put NULL in the LABTOK if we're still inhibited, so ffestb
9164      doesn't have to worry about killing off any tokens when retracting. */
9165
9166   ffest_confirmed ();
9167   if (ffest_is_inhibited ())
9168     ffeexpr_stack_->expr = ffebld_new_labtok (NULL);
9169   else
9170     ffeexpr_stack_->expr = ffebld_new_labtok (ffelex_token_use (t));
9171   ffebld_set_info (ffeexpr_stack_->expr,
9172                    ffeinfo_new (FFEINFO_basictypeNONE,
9173                                 FFEINFO_kindtypeNONE,
9174                                 0,
9175                                 FFEINFO_kindNONE,
9176                                 FFEINFO_whereNONE,
9177                                 FFETARGET_charactersizeNONE));
9178
9179   return (ffelexHandler) ffeexpr_token_first_rhs_4_;
9180 }
9181
9182 /* ffeexpr_token_first_rhs_4_ -- ASTERISK NUMBER
9183
9184    return ffeexpr_token_first_rhs_4_;  // to lexer
9185
9186    Collect/flush appropriate stuff, send token to callback function.  */
9187
9188 static ffelexHandler
9189 ffeexpr_token_first_rhs_4_ (ffelexToken t)
9190 {
9191   ffebld expr;
9192   ffeexprCallback callback;
9193   ffeexprStack_ s;
9194   ffelexHandler next;
9195   ffelexToken ft;
9196
9197   expr = ffeexpr_stack_->expr;
9198   ffebld_pool_pop ();
9199   callback = ffeexpr_stack_->callback;
9200   ft = ffeexpr_stack_->first_token;
9201   s = ffeexpr_stack_->previous;
9202   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
9203   ffeexpr_stack_ = s;
9204   next = (ffelexHandler) (*callback) (ft, expr, t);
9205   ffelex_token_kill (ft);
9206   return (ffelexHandler) next;
9207 }
9208
9209 /* ffeexpr_token_first_rhs_5_ -- PERCENT
9210
9211    Should be NAME, or pass through original mechanism.  If NAME is LOC,
9212    pass through original mechanism, otherwise must be VAL, REF, or DESCR,
9213    in which case handle the argument (in parentheses), etc.  */
9214
9215 static ffelexHandler
9216 ffeexpr_token_first_rhs_5_ (ffelexToken t)
9217 {
9218   ffelexHandler next;
9219
9220   if (ffelex_token_type (t) == FFELEX_typeNAME)
9221     {
9222       ffeexprPercent_ p = ffeexpr_percent_ (t);
9223
9224       switch (p)
9225         {
9226         case FFEEXPR_percentNONE_:
9227         case FFEEXPR_percentLOC_:
9228           break;                /* Treat %LOC as any other expression. */
9229
9230         case FFEEXPR_percentVAL_:
9231         case FFEEXPR_percentREF_:
9232         case FFEEXPR_percentDESCR_:
9233           ffeexpr_stack_->percent = p;
9234           ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
9235           return (ffelexHandler) ffeexpr_token_first_rhs_6_;
9236
9237         default:
9238           assert ("bad percent?!?" == NULL);
9239           break;
9240         }
9241     }
9242
9243   switch (ffeexpr_stack_->context)
9244     {
9245     case FFEEXPR_contextACTUALARG_:
9246       ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
9247       break;
9248
9249     case FFEEXPR_contextINDEXORACTUALARG_:
9250       ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
9251       break;
9252
9253     case FFEEXPR_contextSFUNCDEFACTUALARG_:
9254       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
9255       break;
9256
9257     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9258       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
9259       break;
9260
9261     default:
9262       assert ("bad context?!?!" == NULL);
9263       break;
9264     }
9265
9266   next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9267   return (ffelexHandler) (*next) (t);
9268 }
9269
9270 /* ffeexpr_token_first_rhs_6_ -- PERCENT NAME(VAL,REF,DESCR)
9271
9272    Should be OPEN_PAREN, or pass through original mechanism.  */
9273
9274 static ffelexHandler
9275 ffeexpr_token_first_rhs_6_ (ffelexToken t)
9276 {
9277   ffelexHandler next;
9278   ffelexToken ft;
9279
9280   if (ffelex_token_type (t) == FFELEX_typeOPEN_PAREN)
9281     {
9282       ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
9283       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
9284                                           ffeexpr_stack_->context,
9285                                           ffeexpr_cb_end_notloc_);
9286     }
9287
9288   switch (ffeexpr_stack_->context)
9289     {
9290     case FFEEXPR_contextACTUALARG_:
9291       ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
9292       break;
9293
9294     case FFEEXPR_contextINDEXORACTUALARG_:
9295       ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
9296       break;
9297
9298     case FFEEXPR_contextSFUNCDEFACTUALARG_:
9299       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
9300       break;
9301
9302     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9303       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
9304       break;
9305
9306     default:
9307       assert ("bad context?!?!" == NULL);
9308       break;
9309     }
9310
9311   ft = ffeexpr_stack_->tokens[0];
9312   next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9313   next = (ffelexHandler) (*next) (ft);
9314   ffelex_token_kill (ft);
9315   return (ffelexHandler) (*next) (t);
9316 }
9317
9318 /* ffeexpr_token_namelist_ -- NAME
9319
9320    return ffeexpr_token_namelist_;  // to lexer
9321
9322    Make sure NAME was a valid namelist object, wrap it in a SYMTER and
9323    return.  */
9324
9325 static ffelexHandler
9326 ffeexpr_token_namelist_ (ffelexToken t)
9327 {
9328   ffeexprCallback callback;
9329   ffeexprStack_ s;
9330   ffelexHandler next;
9331   ffelexToken ft;
9332   ffesymbol sy;
9333   ffebld expr;
9334
9335   ffebld_pool_pop ();
9336   callback = ffeexpr_stack_->callback;
9337   ft = ffeexpr_stack_->first_token;
9338   s = ffeexpr_stack_->previous;
9339   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
9340   ffeexpr_stack_ = s;
9341
9342   sy = ffesymbol_lookup_local (ft);
9343   if ((sy == NULL) || (ffesymbol_kind (sy) != FFEINFO_kindNAMELIST))
9344     {
9345       ffebad_start (FFEBAD_EXPR_WRONG);
9346       ffebad_here (0, ffelex_token_where_line (ft),
9347                    ffelex_token_where_column (ft));
9348       ffebad_finish ();
9349       expr = ffebld_new_any ();
9350       ffebld_set_info (expr, ffeinfo_new_any ());
9351     }
9352   else
9353     {
9354       expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
9355                                 FFEINTRIN_impNONE);
9356       ffebld_set_info (expr, ffesymbol_info (sy));
9357     }
9358   next = (ffelexHandler) (*callback) (ft, expr, t);
9359   ffelex_token_kill (ft);
9360   return (ffelexHandler) next;
9361 }
9362
9363 /* ffeexpr_expr_kill_ -- Kill an existing internal expression object
9364
9365    ffeexprExpr_ e;
9366    ffeexpr_expr_kill_(e);
9367
9368    Kills the ffewhere info, if necessary, then kills the object.  */
9369
9370 static void
9371 ffeexpr_expr_kill_ (ffeexprExpr_ e)
9372 {
9373   if (e->token != NULL)
9374     ffelex_token_kill (e->token);
9375   malloc_kill_ks (ffe_pool_program_unit (), e, sizeof (*e));
9376 }
9377
9378 /* ffeexpr_expr_new_ -- Make a new internal expression object
9379
9380    ffeexprExpr_ e;
9381    e = ffeexpr_expr_new_();
9382
9383    Allocates and initializes a new expression object, returns it.  */
9384
9385 static ffeexprExpr_
9386 ffeexpr_expr_new_ ()
9387 {
9388   ffeexprExpr_ e;
9389
9390   e = (ffeexprExpr_) malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR expr",
9391                                     sizeof (*e));
9392   e->previous = NULL;
9393   e->type = FFEEXPR_exprtypeUNKNOWN_;
9394   e->token = NULL;
9395   return e;
9396 }
9397
9398 /* Verify that call to global is valid, and register whatever
9399    new information about a global might be discoverable by looking
9400    at the call.  */
9401
9402 static void
9403 ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t)
9404 {
9405   int n_args;
9406   ffebld list;
9407   ffebld item;
9408   ffesymbol s;
9409
9410   assert ((ffebld_op (*expr) == FFEBLD_opSUBRREF)
9411           || (ffebld_op (*expr) == FFEBLD_opFUNCREF));
9412
9413   if (ffebld_op (ffebld_left (*expr)) != FFEBLD_opSYMTER)
9414     return;
9415
9416   if (ffesymbol_retractable ())
9417     return;
9418
9419   s = ffebld_symter (ffebld_left (*expr));
9420   if (ffesymbol_global (s) == NULL)
9421     return;
9422
9423   for (n_args = 0, list = ffebld_right (*expr);
9424        list != NULL;
9425        list = ffebld_trail (list), ++n_args)
9426     ;
9427
9428   if (ffeglobal_proc_ref_nargs (s, n_args, t))
9429     {
9430       ffeglobalArgSummary as;
9431       ffeinfoBasictype bt;
9432       ffeinfoKindtype kt;
9433       bool array;
9434       bool fail = FALSE;
9435
9436       for (n_args = 0, list = ffebld_right (*expr);
9437            list != NULL;
9438            list = ffebld_trail (list), ++n_args)
9439         {
9440           item = ffebld_head (list);
9441           if (item != NULL)
9442             {
9443               bt = ffeinfo_basictype (ffebld_info (item));
9444               kt = ffeinfo_kindtype (ffebld_info (item));
9445               array = (ffeinfo_rank (ffebld_info (item)) > 0);
9446               switch (ffebld_op (item))
9447                 {
9448                 case FFEBLD_opLABTOK:
9449                 case FFEBLD_opLABTER:
9450                   as = FFEGLOBAL_argsummaryALTRTN;
9451                   break;
9452
9453 #if 0
9454                   /* No, %LOC(foo) is just like any INTEGER(KIND=7)
9455                      expression, so don't treat it specially.  */
9456                 case FFEBLD_opPERCENT_LOC:
9457                   as = FFEGLOBAL_argsummaryPTR;
9458                   break;
9459 #endif
9460
9461                 case FFEBLD_opPERCENT_VAL:
9462                   as = FFEGLOBAL_argsummaryVAL;
9463                   break;
9464
9465                 case FFEBLD_opPERCENT_REF:
9466                   as = FFEGLOBAL_argsummaryREF;
9467                   break;
9468
9469                 case FFEBLD_opPERCENT_DESCR:
9470                   as = FFEGLOBAL_argsummaryDESCR;
9471                   break;
9472
9473                 case FFEBLD_opFUNCREF:
9474 #if 0
9475                   /* No, LOC(foo) is just like any INTEGER(KIND=7)
9476                      expression, so don't treat it specially.  */
9477                   if ((ffebld_op (ffebld_left (item)) == FFEBLD_opSYMTER)
9478                       && (ffesymbol_specific (ffebld_symter (ffebld_left (item)))
9479                           == FFEINTRIN_specLOC))
9480                     {
9481                       as = FFEGLOBAL_argsummaryPTR;
9482                       break;
9483                     }
9484 #endif
9485                   /* Fall through.  */
9486                 default:
9487                   if (ffebld_op (item) == FFEBLD_opSYMTER)
9488                     {
9489                       as = FFEGLOBAL_argsummaryNONE;
9490
9491                       switch (ffeinfo_kind (ffebld_info (item)))
9492                         {
9493                         case FFEINFO_kindFUNCTION:
9494                           as = FFEGLOBAL_argsummaryFUNC;
9495                           break;
9496
9497                         case FFEINFO_kindSUBROUTINE:
9498                           as = FFEGLOBAL_argsummarySUBR;
9499                           break;
9500
9501                         case FFEINFO_kindNONE:
9502                           as = FFEGLOBAL_argsummaryPROC;
9503                           break;
9504
9505                         default:
9506                           break;
9507                         }
9508
9509                       if (as != FFEGLOBAL_argsummaryNONE)
9510                         break;
9511                     }
9512
9513                   if (bt == FFEINFO_basictypeCHARACTER)
9514                     as = FFEGLOBAL_argsummaryDESCR;
9515                   else
9516                     as = FFEGLOBAL_argsummaryREF;
9517                   break;
9518                 }
9519             }
9520           else
9521             {
9522               array = FALSE;
9523               as = FFEGLOBAL_argsummaryNONE;
9524               bt = FFEINFO_basictypeNONE;
9525               kt = FFEINFO_kindtypeNONE;
9526             }
9527
9528           if (! ffeglobal_proc_ref_arg (s, n_args, as, bt, kt, array, t))
9529             fail = TRUE;
9530         }
9531       if (! fail)
9532         return;
9533     }
9534
9535   *expr = ffebld_new_any ();
9536   ffebld_set_info (*expr, ffeinfo_new_any ());
9537 }
9538
9539 /* Check whether rest of string is all decimal digits.  */
9540
9541 static bool
9542 ffeexpr_isdigits_ (const char *p)
9543 {
9544   for (; *p != '\0'; ++p)
9545     if (! ISDIGIT (*p))
9546       return FALSE;
9547   return TRUE;
9548 }
9549
9550 /* ffeexpr_exprstack_push_ -- Push an arbitrary expression object onto the stack
9551
9552    ffeexprExpr_ e;
9553    ffeexpr_exprstack_push_(e);
9554
9555    Pushes the expression onto the stack without any analysis of the existing
9556    contents of the stack.  */
9557
9558 static void
9559 ffeexpr_exprstack_push_ (ffeexprExpr_ e)
9560 {
9561   e->previous = ffeexpr_stack_->exprstack;
9562   ffeexpr_stack_->exprstack = e;
9563 }
9564
9565 /* ffeexpr_exprstack_push_operand_ -- Push an operand onto the stack, reduce?
9566
9567    ffeexprExpr_ e;
9568    ffeexpr_exprstack_push_operand_(e);
9569
9570    Pushes the expression already containing an operand (a constant, variable,
9571    or more complicated expression that has already been fully resolved) after
9572    analyzing the stack and checking for possible reduction (which will never
9573    happen here since the highest precedence operator is ** and it has right-
9574    to-left associativity).  */
9575
9576 static void
9577 ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e)
9578 {
9579   ffeexpr_exprstack_push_ (e);
9580 #ifdef WEIRD_NONFORTRAN_RULES
9581   if ((ffeexpr_stack_->exprstack != NULL)
9582       && (ffeexpr_stack_->exprstack->expr->type == FFEEXPR_exprtypeBINARY_)
9583       && (ffeexpr_stack_->exprstack->expr->u.operator.prec
9584           == FFEEXPR_operatorprecedenceHIGHEST_)
9585       && (ffeexpr_stack_->exprstack->expr->u.operator.as
9586           == FFEEXPR_operatorassociativityL2R_))
9587     ffeexpr_reduce_ ();
9588 #endif
9589 }
9590
9591 /* ffeexpr_exprstack_push_unary_ -- Push a unary operator onto the stack
9592
9593    ffeexprExpr_ e;
9594    ffeexpr_exprstack_push_unary_(e);
9595
9596    Pushes the expression already containing a unary operator.  Reduction can
9597    never happen since unary operators are themselves always R-L; that is, the
9598    top of the expression stack is not an operand, in that it is either empty,
9599    has a binary operator at the top, or a unary operator at the top.  In any
9600    of these cases, reduction is impossible.  */
9601
9602 static void
9603 ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e)
9604 {
9605   if ((ffe_is_pedantic ()
9606        || ffe_is_warn_surprising ())
9607       && (ffeexpr_stack_->exprstack != NULL)
9608       && (ffeexpr_stack_->exprstack->type != FFEEXPR_exprtypeOPERAND_)
9609       && (ffeexpr_stack_->exprstack->u.operator.prec
9610           <= FFEEXPR_operatorprecedenceLOWARITH_)
9611       && (e->u.operator.prec <= FFEEXPR_operatorprecedenceLOWARITH_))
9612     {
9613       /* xgettext:no-c-format */
9614       ffebad_start_msg ("Two arithmetic operators in a row at %0 and %1 -- use parentheses",
9615                         ffe_is_pedantic ()
9616                         ? FFEBAD_severityPEDANTIC
9617                         : FFEBAD_severityWARNING);
9618       ffebad_here (0,
9619                   ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
9620                ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
9621       ffebad_here (1,
9622                    ffelex_token_where_line (e->token),
9623                    ffelex_token_where_column (e->token));
9624       ffebad_finish ();
9625     }
9626
9627   ffeexpr_exprstack_push_ (e);
9628 }
9629
9630 /* ffeexpr_exprstack_push_binary_ -- Push a binary operator onto the stack, reduce?
9631
9632    ffeexprExpr_ e;
9633    ffeexpr_exprstack_push_binary_(e);
9634
9635    Pushes the expression already containing a binary operator after checking
9636    whether reduction is possible.  If the stack is not empty, the top of the
9637    stack must be an operand or syntactic analysis has failed somehow.  If
9638    the operand is preceded by a unary operator of higher (or equal and L-R
9639    associativity) precedence than the new binary operator, then reduce that
9640    preceding operator and its operand(s) before pushing the new binary
9641    operator.  */
9642
9643 static void
9644 ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e)
9645 {
9646   ffeexprExpr_ ce;
9647
9648   if (ffe_is_warn_surprising ()
9649       /* These next two are always true (see assertions below).  */
9650       && (ffeexpr_stack_->exprstack != NULL)
9651       && (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_)
9652       /* If the previous operator is a unary minus, and the binary op
9653          is of higher precedence, might not do what user expects,
9654          e.g. "-2**2" is "-(2**2)", i.e. "-4", not "(-2)**2", which would
9655          yield "4".  */
9656       && (ffeexpr_stack_->exprstack->previous != NULL)
9657       && (ffeexpr_stack_->exprstack->previous->type == FFEEXPR_exprtypeUNARY_)
9658       && (ffeexpr_stack_->exprstack->previous->u.operator.op
9659           == FFEEXPR_operatorSUBTRACT_)
9660       && (e->u.operator.prec
9661           < ffeexpr_stack_->exprstack->previous->u.operator.prec))
9662     {
9663       /* xgettext:no-c-format */
9664       ffebad_start_msg ("Operator at %0 has lower precedence than that at %1 -- use parentheses", FFEBAD_severityWARNING);
9665       ffebad_here (0,
9666          ffelex_token_where_line (ffeexpr_stack_->exprstack->previous->token),
9667       ffelex_token_where_column (ffeexpr_stack_->exprstack->previous->token));
9668       ffebad_here (1,
9669                    ffelex_token_where_line (e->token),
9670                    ffelex_token_where_column (e->token));
9671       ffebad_finish ();
9672     }
9673
9674 again:
9675   assert (ffeexpr_stack_->exprstack != NULL);
9676   assert (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_);
9677   if ((ce = ffeexpr_stack_->exprstack->previous) != NULL)
9678     {
9679       assert (ce->type != FFEEXPR_exprtypeOPERAND_);
9680       if ((ce->u.operator.prec < e->u.operator.prec)
9681           || ((ce->u.operator.prec == e->u.operator.prec)
9682               && (e->u.operator.as == FFEEXPR_operatorassociativityL2R_)))
9683         {
9684           ffeexpr_reduce_ ();
9685           goto again;   /* :::::::::::::::::::: */
9686         }
9687     }
9688
9689   ffeexpr_exprstack_push_ (e);
9690 }
9691
9692 /* ffeexpr_reduce_ -- Reduce highest operator w/operands on stack
9693
9694    ffeexpr_reduce_();
9695
9696    Converts operand binop operand or unop operand at top of stack to a
9697    single operand having the appropriate ffebld expression, and makes
9698    sure that the expression is proper (like not trying to add two character
9699    variables, not trying to concatenate two numbers).  Also does the
9700    requisite type-assignment.  */
9701
9702 static void
9703 ffeexpr_reduce_ ()
9704 {
9705   ffeexprExpr_ operand;         /* This is B in -B or A+B. */
9706   ffeexprExpr_ left_operand;    /* When operator is binary, this is A in A+B. */
9707   ffeexprExpr_ operator;        /* This is + in A+B. */
9708   ffebld reduced;               /* This is +(A,B) in A+B or u-(B) in -B. */
9709   ffebldConstant constnode;     /* For checking magical numbers (where mag ==
9710                                    -mag). */
9711   ffebld expr;
9712   ffebld left_expr;
9713   bool submag = FALSE;
9714
9715   operand = ffeexpr_stack_->exprstack;
9716   assert (operand != NULL);
9717   assert (operand->type == FFEEXPR_exprtypeOPERAND_);
9718   operator = operand->previous;
9719   assert (operator != NULL);
9720   assert (operator->type != FFEEXPR_exprtypeOPERAND_);
9721   if (operator->type == FFEEXPR_exprtypeUNARY_)
9722     {
9723       expr = operand->u.operand;
9724       switch (operator->u.operator.op)
9725         {
9726         case FFEEXPR_operatorADD_:
9727           reduced = ffebld_new_uplus (expr);
9728           if (ffe_is_ugly_logint ())
9729             reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
9730           reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
9731           reduced = ffeexpr_collapse_uplus (reduced, operator->token);
9732           break;
9733
9734         case FFEEXPR_operatorSUBTRACT_:
9735           submag = TRUE;        /* Ok to negate a magic number. */
9736           reduced = ffebld_new_uminus (expr);
9737           if (ffe_is_ugly_logint ())
9738             reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
9739           reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
9740           reduced = ffeexpr_collapse_uminus (reduced, operator->token);
9741           break;
9742
9743         case FFEEXPR_operatorNOT_:
9744           reduced = ffebld_new_not (expr);
9745           if (ffe_is_ugly_logint ())
9746             reduced = ffeexpr_reduced_ugly1log_ (reduced, operator, operand);
9747           reduced = ffeexpr_reduced_bool1_ (reduced, operator, operand);
9748           reduced = ffeexpr_collapse_not (reduced, operator->token);
9749           break;
9750
9751         default:
9752           assert ("unexpected unary op" != NULL);
9753           reduced = NULL;
9754           break;
9755         }
9756       if (!submag
9757           && (ffebld_op (expr) == FFEBLD_opCONTER)
9758           && (ffebld_conter_orig (expr) == NULL)
9759           && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
9760         {
9761           ffetarget_integer_bad_magical (operand->token);
9762         }
9763       ffeexpr_stack_->exprstack = operator->previous;   /* Pops unary-op operand
9764                                                            off stack. */
9765       ffeexpr_expr_kill_ (operand);
9766       operator->type = FFEEXPR_exprtypeOPERAND_;        /* Convert operator, but
9767                                                            save */
9768       operator->u.operand = reduced;    /* the line/column ffewhere info. */
9769       ffeexpr_exprstack_push_operand_ (operator);       /* Push it back on
9770                                                            stack. */
9771     }
9772   else
9773     {
9774       assert (operator->type == FFEEXPR_exprtypeBINARY_);
9775       left_operand = operator->previous;
9776       assert (left_operand != NULL);
9777       assert (left_operand->type == FFEEXPR_exprtypeOPERAND_);
9778       expr = operand->u.operand;
9779       left_expr = left_operand->u.operand;
9780       switch (operator->u.operator.op)
9781         {
9782         case FFEEXPR_operatorADD_:
9783           reduced = ffebld_new_add (left_expr, expr);
9784           if (ffe_is_ugly_logint ())
9785             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9786                                               operand);
9787           reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9788                                             operand);
9789           reduced = ffeexpr_collapse_add (reduced, operator->token);
9790           break;
9791
9792         case FFEEXPR_operatorSUBTRACT_:
9793           submag = TRUE;        /* Just to pick the right error if magic
9794                                    number. */
9795           reduced = ffebld_new_subtract (left_expr, expr);
9796           if (ffe_is_ugly_logint ())
9797             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9798                                               operand);
9799           reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9800                                             operand);
9801           reduced = ffeexpr_collapse_subtract (reduced, operator->token);
9802           break;
9803
9804         case FFEEXPR_operatorMULTIPLY_:
9805           reduced = ffebld_new_multiply (left_expr, expr);
9806           if (ffe_is_ugly_logint ())
9807             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9808                                               operand);
9809           reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9810                                             operand);
9811           reduced = ffeexpr_collapse_multiply (reduced, operator->token);
9812           break;
9813
9814         case FFEEXPR_operatorDIVIDE_:
9815           reduced = ffebld_new_divide (left_expr, expr);
9816           if (ffe_is_ugly_logint ())
9817             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9818                                               operand);
9819           reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9820                                             operand);
9821           reduced = ffeexpr_collapse_divide (reduced, operator->token);
9822           break;
9823
9824         case FFEEXPR_operatorPOWER_:
9825           reduced = ffebld_new_power (left_expr, expr);
9826           if (ffe_is_ugly_logint ())
9827             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9828                                               operand);
9829           reduced = ffeexpr_reduced_power_ (reduced, left_operand, operator,
9830                                             operand);
9831           reduced = ffeexpr_collapse_power (reduced, operator->token);
9832           break;
9833
9834         case FFEEXPR_operatorCONCATENATE_:
9835           reduced = ffebld_new_concatenate (left_expr, expr);
9836           reduced = ffeexpr_reduced_concatenate_ (reduced, left_operand, operator,
9837                                                   operand);
9838           reduced = ffeexpr_collapse_concatenate (reduced, operator->token);
9839           break;
9840
9841         case FFEEXPR_operatorLT_:
9842           reduced = ffebld_new_lt (left_expr, expr);
9843           if (ffe_is_ugly_logint ())
9844             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9845                                               operand);
9846           reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9847                                              operand);
9848           reduced = ffeexpr_collapse_lt (reduced, operator->token);
9849           break;
9850
9851         case FFEEXPR_operatorLE_:
9852           reduced = ffebld_new_le (left_expr, expr);
9853           if (ffe_is_ugly_logint ())
9854             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9855                                               operand);
9856           reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9857                                              operand);
9858           reduced = ffeexpr_collapse_le (reduced, operator->token);
9859           break;
9860
9861         case FFEEXPR_operatorEQ_:
9862           reduced = ffebld_new_eq (left_expr, expr);
9863           if (ffe_is_ugly_logint ())
9864             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9865                                               operand);
9866           reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
9867                                             operand);
9868           reduced = ffeexpr_collapse_eq (reduced, operator->token);
9869           break;
9870
9871         case FFEEXPR_operatorNE_:
9872           reduced = ffebld_new_ne (left_expr, expr);
9873           if (ffe_is_ugly_logint ())
9874             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9875                                               operand);
9876           reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
9877                                             operand);
9878           reduced = ffeexpr_collapse_ne (reduced, operator->token);
9879           break;
9880
9881         case FFEEXPR_operatorGT_:
9882           reduced = ffebld_new_gt (left_expr, expr);
9883           if (ffe_is_ugly_logint ())
9884             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9885                                               operand);
9886           reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9887                                              operand);
9888           reduced = ffeexpr_collapse_gt (reduced, operator->token);
9889           break;
9890
9891         case FFEEXPR_operatorGE_:
9892           reduced = ffebld_new_ge (left_expr, expr);
9893           if (ffe_is_ugly_logint ())
9894             reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9895                                               operand);
9896           reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9897                                              operand);
9898           reduced = ffeexpr_collapse_ge (reduced, operator->token);
9899           break;
9900
9901         case FFEEXPR_operatorAND_:
9902           reduced = ffebld_new_and (left_expr, expr);
9903           if (ffe_is_ugly_logint ())
9904             reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9905                                                  operand);
9906           reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9907                                             operand);
9908           reduced = ffeexpr_collapse_and (reduced, operator->token);
9909           break;
9910
9911         case FFEEXPR_operatorOR_:
9912           reduced = ffebld_new_or (left_expr, expr);
9913           if (ffe_is_ugly_logint ())
9914             reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9915                                                  operand);
9916           reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9917                                             operand);
9918           reduced = ffeexpr_collapse_or (reduced, operator->token);
9919           break;
9920
9921         case FFEEXPR_operatorXOR_:
9922           reduced = ffebld_new_xor (left_expr, expr);
9923           if (ffe_is_ugly_logint ())
9924             reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9925                                                  operand);
9926           reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9927                                             operand);
9928           reduced = ffeexpr_collapse_xor (reduced, operator->token);
9929           break;
9930
9931         case FFEEXPR_operatorEQV_:
9932           reduced = ffebld_new_eqv (left_expr, expr);
9933           if (ffe_is_ugly_logint ())
9934             reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9935                                                  operand);
9936           reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9937                                             operand);
9938           reduced = ffeexpr_collapse_eqv (reduced, operator->token);
9939           break;
9940
9941         case FFEEXPR_operatorNEQV_:
9942           reduced = ffebld_new_neqv (left_expr, expr);
9943           if (ffe_is_ugly_logint ())
9944             reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9945                                                  operand);
9946           reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9947                                             operand);
9948           reduced = ffeexpr_collapse_neqv (reduced, operator->token);
9949           break;
9950
9951         default:
9952           assert ("bad bin op" == NULL);
9953           reduced = expr;
9954           break;
9955         }
9956       if ((ffebld_op (left_expr) == FFEBLD_opCONTER)
9957           && (ffebld_conter_orig (expr) == NULL)
9958       && ffebld_constant_is_magical (constnode = ffebld_conter (left_expr)))
9959         {
9960           if ((left_operand->previous != NULL)
9961               && (left_operand->previous->type != FFEEXPR_exprtypeOPERAND_)
9962               && (left_operand->previous->u.operator.op
9963                   == FFEEXPR_operatorSUBTRACT_))
9964             {
9965               if (left_operand->previous->type == FFEEXPR_exprtypeUNARY_)
9966                 ffetarget_integer_bad_magical_precedence (left_operand->token,
9967                                                           left_operand->previous->token,
9968                                                           operator->token);
9969               else
9970                 ffetarget_integer_bad_magical_precedence_binary
9971                   (left_operand->token,
9972                    left_operand->previous->token,
9973                    operator->token);
9974             }
9975           else
9976             ffetarget_integer_bad_magical (left_operand->token);
9977         }
9978       if ((ffebld_op (expr) == FFEBLD_opCONTER)
9979           && (ffebld_conter_orig (expr) == NULL)
9980           && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
9981         {
9982           if (submag)
9983             ffetarget_integer_bad_magical_binary (operand->token,
9984                                                   operator->token);
9985           else
9986             ffetarget_integer_bad_magical (operand->token);
9987         }
9988       ffeexpr_stack_->exprstack = left_operand->previous;       /* Pops binary-op
9989                                                                    operands off stack. */
9990       ffeexpr_expr_kill_ (left_operand);
9991       ffeexpr_expr_kill_ (operand);
9992       operator->type = FFEEXPR_exprtypeOPERAND_;        /* Convert operator, but
9993                                                            save */
9994       operator->u.operand = reduced;    /* the line/column ffewhere info. */
9995       ffeexpr_exprstack_push_operand_ (operator);       /* Push it back on
9996                                                            stack. */
9997     }
9998 }
9999
10000 /* ffeexpr_reduced_bool1_ -- Wrap up reduction of NOT operator
10001
10002    reduced = ffeexpr_reduced_bool1_(reduced,op,r);
10003
10004    Makes sure the argument for reduced has basictype of
10005    LOGICAL or (ugly) INTEGER.  If
10006    argument has where of CONSTANT, assign where CONSTANT to
10007    reduced, else assign where FLEETING.
10008
10009    If these requirements cannot be met, generate error message.  */
10010
10011 static ffebld
10012 ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10013 {
10014   ffeinfo rinfo, ninfo;
10015   ffeinfoBasictype rbt;
10016   ffeinfoKindtype rkt;
10017   ffeinfoRank rrk;
10018   ffeinfoKind rkd;
10019   ffeinfoWhere rwh, nwh;
10020
10021   rinfo = ffebld_info (ffebld_left (reduced));
10022   rbt = ffeinfo_basictype (rinfo);
10023   rkt = ffeinfo_kindtype (rinfo);
10024   rrk = ffeinfo_rank (rinfo);
10025   rkd = ffeinfo_kind (rinfo);
10026   rwh = ffeinfo_where (rinfo);
10027
10028   if (((rbt == FFEINFO_basictypeLOGICAL)
10029        || (ffe_is_ugly_logint () && (rbt == FFEINFO_basictypeINTEGER)))
10030       && (rrk == 0))
10031     {
10032       switch (rwh)
10033         {
10034         case FFEINFO_whereCONSTANT:
10035           nwh = FFEINFO_whereCONSTANT;
10036           break;
10037
10038         case FFEINFO_whereIMMEDIATE:
10039           nwh = FFEINFO_whereIMMEDIATE;
10040           break;
10041
10042         default:
10043           nwh = FFEINFO_whereFLEETING;
10044           break;
10045         }
10046
10047       ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
10048                            FFETARGET_charactersizeNONE);
10049       ffebld_set_info (reduced, ninfo);
10050       return reduced;
10051     }
10052
10053   if ((rbt != FFEINFO_basictypeLOGICAL)
10054       && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
10055     {
10056       if ((rbt != FFEINFO_basictypeANY)
10057           && ffebad_start (FFEBAD_NOT_ARG_TYPE))
10058         {
10059           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10060           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10061           ffebad_finish ();
10062         }
10063     }
10064   else
10065     {
10066       if ((rkd != FFEINFO_kindANY)
10067           && ffebad_start (FFEBAD_NOT_ARG_KIND))
10068         {
10069           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10070           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10071           ffebad_string ("an array");
10072           ffebad_finish ();
10073         }
10074     }
10075
10076   reduced = ffebld_new_any ();
10077   ffebld_set_info (reduced, ffeinfo_new_any ());
10078   return reduced;
10079 }
10080
10081 /* ffeexpr_reduced_bool2_ -- Wrap up reduction of boolean operators
10082
10083    reduced = ffeexpr_reduced_bool2_(reduced,l,op,r);
10084
10085    Makes sure the left and right arguments for reduced have basictype of
10086    LOGICAL or (ugly) INTEGER.  Determine common basictype and
10087    size for reduction (flag expression for combined hollerith/typeless
10088    situations for later determination of effective basictype).  If both left
10089    and right arguments have where of CONSTANT, assign where CONSTANT to
10090    reduced, else assign where FLEETING.  Create CONVERT ops for args where
10091    needed.  Convert typeless
10092    constants to the desired type/size explicitly.
10093
10094    If these requirements cannot be met, generate error message.  */
10095
10096 static ffebld
10097 ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10098                         ffeexprExpr_ r)
10099 {
10100   ffeinfo linfo, rinfo, ninfo;
10101   ffeinfoBasictype lbt, rbt, nbt;
10102   ffeinfoKindtype lkt, rkt, nkt;
10103   ffeinfoRank lrk, rrk;
10104   ffeinfoKind lkd, rkd;
10105   ffeinfoWhere lwh, rwh, nwh;
10106
10107   linfo = ffebld_info (ffebld_left (reduced));
10108   lbt = ffeinfo_basictype (linfo);
10109   lkt = ffeinfo_kindtype (linfo);
10110   lrk = ffeinfo_rank (linfo);
10111   lkd = ffeinfo_kind (linfo);
10112   lwh = ffeinfo_where (linfo);
10113
10114   rinfo = ffebld_info (ffebld_right (reduced));
10115   rbt = ffeinfo_basictype (rinfo);
10116   rkt = ffeinfo_kindtype (rinfo);
10117   rrk = ffeinfo_rank (rinfo);
10118   rkd = ffeinfo_kind (rinfo);
10119   rwh = ffeinfo_where (rinfo);
10120
10121   ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10122
10123   if (((nbt == FFEINFO_basictypeLOGICAL)
10124        || (ffe_is_ugly_logint () && (nbt == FFEINFO_basictypeINTEGER)))
10125       && (lrk == 0) && (rrk == 0))
10126     {
10127       switch (lwh)
10128         {
10129         case FFEINFO_whereCONSTANT:
10130           switch (rwh)
10131             {
10132             case FFEINFO_whereCONSTANT:
10133               nwh = FFEINFO_whereCONSTANT;
10134               break;
10135
10136             case FFEINFO_whereIMMEDIATE:
10137               nwh = FFEINFO_whereIMMEDIATE;
10138               break;
10139
10140             default:
10141               nwh = FFEINFO_whereFLEETING;
10142               break;
10143             }
10144           break;
10145
10146         case FFEINFO_whereIMMEDIATE:
10147           switch (rwh)
10148             {
10149             case FFEINFO_whereCONSTANT:
10150             case FFEINFO_whereIMMEDIATE:
10151               nwh = FFEINFO_whereIMMEDIATE;
10152               break;
10153
10154             default:
10155               nwh = FFEINFO_whereFLEETING;
10156               break;
10157             }
10158           break;
10159
10160         default:
10161           nwh = FFEINFO_whereFLEETING;
10162           break;
10163         }
10164
10165       ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10166                            FFETARGET_charactersizeNONE);
10167       ffebld_set_info (reduced, ninfo);
10168       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10169               l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10170                                                  FFEEXPR_contextLET));
10171       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10172               r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10173                                                   FFEEXPR_contextLET));
10174       return reduced;
10175     }
10176
10177   if ((lbt != FFEINFO_basictypeLOGICAL)
10178       && (!ffe_is_ugly_logint () || (lbt != FFEINFO_basictypeINTEGER)))
10179     {
10180       if ((rbt != FFEINFO_basictypeLOGICAL)
10181           && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
10182         {
10183           if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10184               && ffebad_start (FFEBAD_BOOL_ARGS_TYPE))
10185             {
10186               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10187               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10188               ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10189               ffebad_finish ();
10190             }
10191         }
10192       else
10193         {
10194           if ((lbt != FFEINFO_basictypeANY)
10195               && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
10196             {
10197               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10198               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10199               ffebad_finish ();
10200             }
10201         }
10202     }
10203   else if ((rbt != FFEINFO_basictypeLOGICAL)
10204            && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
10205     {
10206       if ((rbt != FFEINFO_basictypeANY)
10207           && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
10208         {
10209           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10210           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10211           ffebad_finish ();
10212         }
10213     }
10214   else if (lrk != 0)
10215     {
10216       if ((lkd != FFEINFO_kindANY)
10217           && ffebad_start (FFEBAD_BOOL_ARG_KIND))
10218         {
10219           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10220           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10221           ffebad_string ("an array");
10222           ffebad_finish ();
10223         }
10224     }
10225   else
10226     {
10227       if ((rkd != FFEINFO_kindANY)
10228           && ffebad_start (FFEBAD_BOOL_ARG_KIND))
10229         {
10230           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10231           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10232           ffebad_string ("an array");
10233           ffebad_finish ();
10234         }
10235     }
10236
10237   reduced = ffebld_new_any ();
10238   ffebld_set_info (reduced, ffeinfo_new_any ());
10239   return reduced;
10240 }
10241
10242 /* ffeexpr_reduced_concatenate_ -- Wrap up reduction of concatenate operator
10243
10244    reduced = ffeexpr_reduced_concatenate_(reduced,l,op,r);
10245
10246    Makes sure the left and right arguments for reduced have basictype of
10247    CHARACTER and kind of SCALAR, FUNCTION, or STATEMENT FUNCTION.  Assign
10248    basictype of CHARACTER and kind of SCALAR to reduced.  Calculate effective
10249    size of concatenation and assign that size to reduced.  If both left and
10250    right arguments have where of CONSTANT, assign where CONSTANT to reduced,
10251    else assign where FLEETING.
10252
10253    If these requirements cannot be met, generate error message using the
10254    info in l, op, and r arguments and assign basictype, size, kind, and where
10255    of ANY.  */
10256
10257 static ffebld
10258 ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10259                               ffeexprExpr_ r)
10260 {
10261   ffeinfo linfo, rinfo, ninfo;
10262   ffeinfoBasictype lbt, rbt, nbt;
10263   ffeinfoKindtype lkt, rkt, nkt;
10264   ffeinfoRank lrk, rrk;
10265   ffeinfoKind lkd, rkd, nkd;
10266   ffeinfoWhere lwh, rwh, nwh;
10267   ffetargetCharacterSize lszm, lszk, rszm, rszk, nszk;
10268
10269   linfo = ffebld_info (ffebld_left (reduced));
10270   lbt = ffeinfo_basictype (linfo);
10271   lkt = ffeinfo_kindtype (linfo);
10272   lrk = ffeinfo_rank (linfo);
10273   lkd = ffeinfo_kind (linfo);
10274   lwh = ffeinfo_where (linfo);
10275   lszk = ffeinfo_size (linfo);  /* Known size. */
10276   lszm = ffebld_size_max (ffebld_left (reduced));
10277
10278   rinfo = ffebld_info (ffebld_right (reduced));
10279   rbt = ffeinfo_basictype (rinfo);
10280   rkt = ffeinfo_kindtype (rinfo);
10281   rrk = ffeinfo_rank (rinfo);
10282   rkd = ffeinfo_kind (rinfo);
10283   rwh = ffeinfo_where (rinfo);
10284   rszk = ffeinfo_size (rinfo);  /* Known size. */
10285   rszm = ffebld_size_max (ffebld_right (reduced));
10286
10287   if ((lbt == FFEINFO_basictypeCHARACTER) && (rbt == FFEINFO_basictypeCHARACTER)
10288       && (lkt == rkt) && (lrk == 0) && (rrk == 0)
10289       && (((lszm != FFETARGET_charactersizeNONE)
10290            && (rszm != FFETARGET_charactersizeNONE))
10291           || (ffeexpr_context_outer_ (ffeexpr_stack_)
10292               == FFEEXPR_contextLET)
10293           || (ffeexpr_context_outer_ (ffeexpr_stack_)
10294               == FFEEXPR_contextSFUNCDEF)))
10295     {
10296       nbt = FFEINFO_basictypeCHARACTER;
10297       nkd = FFEINFO_kindENTITY;
10298       if ((lszk == FFETARGET_charactersizeNONE)
10299           || (rszk == FFETARGET_charactersizeNONE))
10300         nszk = FFETARGET_charactersizeNONE;     /* Ok only in rhs of LET
10301                                                    stmt. */
10302       else
10303         nszk = lszk + rszk;
10304
10305       switch (lwh)
10306         {
10307         case FFEINFO_whereCONSTANT:
10308           switch (rwh)
10309             {
10310             case FFEINFO_whereCONSTANT:
10311               nwh = FFEINFO_whereCONSTANT;
10312               break;
10313
10314             case FFEINFO_whereIMMEDIATE:
10315               nwh = FFEINFO_whereIMMEDIATE;
10316               break;
10317
10318             default:
10319               nwh = FFEINFO_whereFLEETING;
10320               break;
10321             }
10322           break;
10323
10324         case FFEINFO_whereIMMEDIATE:
10325           switch (rwh)
10326             {
10327             case FFEINFO_whereCONSTANT:
10328             case FFEINFO_whereIMMEDIATE:
10329               nwh = FFEINFO_whereIMMEDIATE;
10330               break;
10331
10332             default:
10333               nwh = FFEINFO_whereFLEETING;
10334               break;
10335             }
10336           break;
10337
10338         default:
10339           nwh = FFEINFO_whereFLEETING;
10340           break;
10341         }
10342
10343       nkt = lkt;
10344       ninfo = ffeinfo_new (nbt, nkt, 0, nkd, nwh, nszk);
10345       ffebld_set_info (reduced, ninfo);
10346       return reduced;
10347     }
10348
10349   if ((lbt != FFEINFO_basictypeCHARACTER) && (rbt != FFEINFO_basictypeCHARACTER))
10350     {
10351       if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10352           && ffebad_start (FFEBAD_CONCAT_ARGS_TYPE))
10353         {
10354           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10355           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10356           ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10357           ffebad_finish ();
10358         }
10359     }
10360   else if (lbt != FFEINFO_basictypeCHARACTER)
10361     {
10362       if ((lbt != FFEINFO_basictypeANY)
10363           && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
10364         {
10365           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10366           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10367           ffebad_finish ();
10368         }
10369     }
10370   else if (rbt != FFEINFO_basictypeCHARACTER)
10371     {
10372       if ((rbt != FFEINFO_basictypeANY)
10373           && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
10374         {
10375           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10376           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10377           ffebad_finish ();
10378         }
10379     }
10380   else if ((lrk != 0) || (lszm == FFETARGET_charactersizeNONE))
10381     {
10382       if ((lkd != FFEINFO_kindANY)
10383           && ffebad_start (FFEBAD_CONCAT_ARG_KIND))
10384         {
10385           const char *what;
10386
10387           if (lrk != 0)
10388             what = "an array";
10389           else
10390             what = "of indeterminate length";
10391           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10392           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10393           ffebad_string (what);
10394           ffebad_finish ();
10395         }
10396     }
10397   else
10398     {
10399       if (ffebad_start (FFEBAD_CONCAT_ARG_KIND))
10400         {
10401           const char *what;
10402
10403           if (rrk != 0)
10404             what = "an array";
10405           else
10406             what = "of indeterminate length";
10407           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10408           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10409           ffebad_string (what);
10410           ffebad_finish ();
10411         }
10412     }
10413
10414   reduced = ffebld_new_any ();
10415   ffebld_set_info (reduced, ffeinfo_new_any ());
10416   return reduced;
10417 }
10418
10419 /* ffeexpr_reduced_eqop2_ -- Wrap up reduction of EQ and NE operators
10420
10421    reduced = ffeexpr_reduced_eqop2_(reduced,l,op,r);
10422
10423    Makes sure the left and right arguments for reduced have basictype of
10424    INTEGER, REAL, COMPLEX, or CHARACTER.  Determine common basictype and
10425    size for reduction.  If both left
10426    and right arguments have where of CONSTANT, assign where CONSTANT to
10427    reduced, else assign where FLEETING.  Create CONVERT ops for args where
10428    needed.  Convert typeless
10429    constants to the desired type/size explicitly.
10430
10431    If these requirements cannot be met, generate error message.  */
10432
10433 static ffebld
10434 ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10435                         ffeexprExpr_ r)
10436 {
10437   ffeinfo linfo, rinfo, ninfo;
10438   ffeinfoBasictype lbt, rbt, nbt;
10439   ffeinfoKindtype lkt, rkt, nkt;
10440   ffeinfoRank lrk, rrk;
10441   ffeinfoKind lkd, rkd;
10442   ffeinfoWhere lwh, rwh, nwh;
10443   ffetargetCharacterSize lsz, rsz;
10444
10445   linfo = ffebld_info (ffebld_left (reduced));
10446   lbt = ffeinfo_basictype (linfo);
10447   lkt = ffeinfo_kindtype (linfo);
10448   lrk = ffeinfo_rank (linfo);
10449   lkd = ffeinfo_kind (linfo);
10450   lwh = ffeinfo_where (linfo);
10451   lsz = ffebld_size_known (ffebld_left (reduced));
10452
10453   rinfo = ffebld_info (ffebld_right (reduced));
10454   rbt = ffeinfo_basictype (rinfo);
10455   rkt = ffeinfo_kindtype (rinfo);
10456   rrk = ffeinfo_rank (rinfo);
10457   rkd = ffeinfo_kind (rinfo);
10458   rwh = ffeinfo_where (rinfo);
10459   rsz = ffebld_size_known (ffebld_right (reduced));
10460
10461   ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10462
10463   if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10464        || (nbt == FFEINFO_basictypeCOMPLEX) || (nbt == FFEINFO_basictypeCHARACTER))
10465       && (lrk == 0) && (rrk == 0))
10466     {
10467       switch (lwh)
10468         {
10469         case FFEINFO_whereCONSTANT:
10470           switch (rwh)
10471             {
10472             case FFEINFO_whereCONSTANT:
10473               nwh = FFEINFO_whereCONSTANT;
10474               break;
10475
10476             case FFEINFO_whereIMMEDIATE:
10477               nwh = FFEINFO_whereIMMEDIATE;
10478               break;
10479
10480             default:
10481               nwh = FFEINFO_whereFLEETING;
10482               break;
10483             }
10484           break;
10485
10486         case FFEINFO_whereIMMEDIATE:
10487           switch (rwh)
10488             {
10489             case FFEINFO_whereCONSTANT:
10490             case FFEINFO_whereIMMEDIATE:
10491               nwh = FFEINFO_whereIMMEDIATE;
10492               break;
10493
10494             default:
10495               nwh = FFEINFO_whereFLEETING;
10496               break;
10497             }
10498           break;
10499
10500         default:
10501           nwh = FFEINFO_whereFLEETING;
10502           break;
10503         }
10504
10505       if ((lsz != FFETARGET_charactersizeNONE)
10506           && (rsz != FFETARGET_charactersizeNONE))
10507         lsz = rsz = (lsz > rsz) ? lsz : rsz;
10508
10509       ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
10510                    0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
10511       ffebld_set_info (reduced, ninfo);
10512       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10513                                       l->token, op->token, nbt, nkt, 0, lsz,
10514                                                  FFEEXPR_contextLET));
10515       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10516                                       r->token, op->token, nbt, nkt, 0, rsz,
10517                                                   FFEEXPR_contextLET));
10518       return reduced;
10519     }
10520
10521   if ((lbt == FFEINFO_basictypeLOGICAL)
10522       && (rbt == FFEINFO_basictypeLOGICAL))
10523     {
10524       /* xgettext:no-c-format */
10525       if (ffebad_start_msg ("Use .EQV./.NEQV. instead of .EQ./.NE. at %0 for LOGICAL operands at %1 and %2",
10526                             FFEBAD_severityFATAL))
10527         {
10528           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10529           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10530           ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10531           ffebad_finish ();
10532         }
10533     }
10534   else if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10535       && (lbt != FFEINFO_basictypeCOMPLEX) && (lbt != FFEINFO_basictypeCHARACTER))
10536     {
10537       if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10538           && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
10539         {
10540           if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10541               && ffebad_start (FFEBAD_EQOP_ARGS_TYPE))
10542             {
10543               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10544               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10545               ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10546               ffebad_finish ();
10547             }
10548         }
10549       else
10550         {
10551           if ((lbt != FFEINFO_basictypeANY)
10552               && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
10553             {
10554               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10555               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10556               ffebad_finish ();
10557             }
10558         }
10559     }
10560   else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10561            && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
10562     {
10563       if ((rbt != FFEINFO_basictypeANY)
10564           && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
10565         {
10566           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10567           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10568           ffebad_finish ();
10569         }
10570     }
10571   else if (lrk != 0)
10572     {
10573       if ((lkd != FFEINFO_kindANY)
10574           && ffebad_start (FFEBAD_EQOP_ARG_KIND))
10575         {
10576           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10577           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10578           ffebad_string ("an array");
10579           ffebad_finish ();
10580         }
10581     }
10582   else
10583     {
10584       if ((rkd != FFEINFO_kindANY)
10585           && ffebad_start (FFEBAD_EQOP_ARG_KIND))
10586         {
10587           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10588           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10589           ffebad_string ("an array");
10590           ffebad_finish ();
10591         }
10592     }
10593
10594   reduced = ffebld_new_any ();
10595   ffebld_set_info (reduced, ffeinfo_new_any ());
10596   return reduced;
10597 }
10598
10599 /* ffeexpr_reduced_math1_ -- Wrap up reduction of + - unary operators
10600
10601    reduced = ffeexpr_reduced_math1_(reduced,op,r);
10602
10603    Makes sure the argument for reduced has basictype of
10604    INTEGER, REAL, or COMPLEX.  If the argument has where of CONSTANT,
10605    assign where CONSTANT to
10606    reduced, else assign where FLEETING.
10607
10608    If these requirements cannot be met, generate error message.  */
10609
10610 static ffebld
10611 ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10612 {
10613   ffeinfo rinfo, ninfo;
10614   ffeinfoBasictype rbt;
10615   ffeinfoKindtype rkt;
10616   ffeinfoRank rrk;
10617   ffeinfoKind rkd;
10618   ffeinfoWhere rwh, nwh;
10619
10620   rinfo = ffebld_info (ffebld_left (reduced));
10621   rbt = ffeinfo_basictype (rinfo);
10622   rkt = ffeinfo_kindtype (rinfo);
10623   rrk = ffeinfo_rank (rinfo);
10624   rkd = ffeinfo_kind (rinfo);
10625   rwh = ffeinfo_where (rinfo);
10626
10627   if (((rbt == FFEINFO_basictypeINTEGER) || (rbt == FFEINFO_basictypeREAL)
10628        || (rbt == FFEINFO_basictypeCOMPLEX)) && (rrk == 0))
10629     {
10630       switch (rwh)
10631         {
10632         case FFEINFO_whereCONSTANT:
10633           nwh = FFEINFO_whereCONSTANT;
10634           break;
10635
10636         case FFEINFO_whereIMMEDIATE:
10637           nwh = FFEINFO_whereIMMEDIATE;
10638           break;
10639
10640         default:
10641           nwh = FFEINFO_whereFLEETING;
10642           break;
10643         }
10644
10645       ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
10646                            FFETARGET_charactersizeNONE);
10647       ffebld_set_info (reduced, ninfo);
10648       return reduced;
10649     }
10650
10651   if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10652       && (rbt != FFEINFO_basictypeCOMPLEX))
10653     {
10654       if ((rbt != FFEINFO_basictypeANY)
10655           && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10656         {
10657           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10658           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10659           ffebad_finish ();
10660         }
10661     }
10662   else
10663     {
10664       if ((rkd != FFEINFO_kindANY)
10665           && ffebad_start (FFEBAD_MATH_ARG_KIND))
10666         {
10667           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10668           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10669           ffebad_string ("an array");
10670           ffebad_finish ();
10671         }
10672     }
10673
10674   reduced = ffebld_new_any ();
10675   ffebld_set_info (reduced, ffeinfo_new_any ());
10676   return reduced;
10677 }
10678
10679 /* ffeexpr_reduced_math2_ -- Wrap up reduction of + - * / operators
10680
10681    reduced = ffeexpr_reduced_math2_(reduced,l,op,r);
10682
10683    Makes sure the left and right arguments for reduced have basictype of
10684    INTEGER, REAL, or COMPLEX.  Determine common basictype and
10685    size for reduction (flag expression for combined hollerith/typeless
10686    situations for later determination of effective basictype).  If both left
10687    and right arguments have where of CONSTANT, assign where CONSTANT to
10688    reduced, else assign where FLEETING.  Create CONVERT ops for args where
10689    needed.  Convert typeless
10690    constants to the desired type/size explicitly.
10691
10692    If these requirements cannot be met, generate error message.  */
10693
10694 static ffebld
10695 ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10696                         ffeexprExpr_ r)
10697 {
10698   ffeinfo linfo, rinfo, ninfo;
10699   ffeinfoBasictype lbt, rbt, nbt;
10700   ffeinfoKindtype lkt, rkt, nkt;
10701   ffeinfoRank lrk, rrk;
10702   ffeinfoKind lkd, rkd;
10703   ffeinfoWhere lwh, rwh, nwh;
10704
10705   linfo = ffebld_info (ffebld_left (reduced));
10706   lbt = ffeinfo_basictype (linfo);
10707   lkt = ffeinfo_kindtype (linfo);
10708   lrk = ffeinfo_rank (linfo);
10709   lkd = ffeinfo_kind (linfo);
10710   lwh = ffeinfo_where (linfo);
10711
10712   rinfo = ffebld_info (ffebld_right (reduced));
10713   rbt = ffeinfo_basictype (rinfo);
10714   rkt = ffeinfo_kindtype (rinfo);
10715   rrk = ffeinfo_rank (rinfo);
10716   rkd = ffeinfo_kind (rinfo);
10717   rwh = ffeinfo_where (rinfo);
10718
10719   ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10720
10721   if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10722        || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
10723     {
10724       switch (lwh)
10725         {
10726         case FFEINFO_whereCONSTANT:
10727           switch (rwh)
10728             {
10729             case FFEINFO_whereCONSTANT:
10730               nwh = FFEINFO_whereCONSTANT;
10731               break;
10732
10733             case FFEINFO_whereIMMEDIATE:
10734               nwh = FFEINFO_whereIMMEDIATE;
10735               break;
10736
10737             default:
10738               nwh = FFEINFO_whereFLEETING;
10739               break;
10740             }
10741           break;
10742
10743         case FFEINFO_whereIMMEDIATE:
10744           switch (rwh)
10745             {
10746             case FFEINFO_whereCONSTANT:
10747             case FFEINFO_whereIMMEDIATE:
10748               nwh = FFEINFO_whereIMMEDIATE;
10749               break;
10750
10751             default:
10752               nwh = FFEINFO_whereFLEETING;
10753               break;
10754             }
10755           break;
10756
10757         default:
10758           nwh = FFEINFO_whereFLEETING;
10759           break;
10760         }
10761
10762       ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10763                            FFETARGET_charactersizeNONE);
10764       ffebld_set_info (reduced, ninfo);
10765       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10766               l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10767                                                  FFEEXPR_contextLET));
10768       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10769               r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10770                                                   FFEEXPR_contextLET));
10771       return reduced;
10772     }
10773
10774   if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10775       && (lbt != FFEINFO_basictypeCOMPLEX))
10776     {
10777       if ((rbt != FFEINFO_basictypeINTEGER)
10778       && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
10779         {
10780           if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10781               && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
10782             {
10783               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10784               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10785               ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10786               ffebad_finish ();
10787             }
10788         }
10789       else
10790         {
10791           if ((lbt != FFEINFO_basictypeANY)
10792               && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10793             {
10794               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10795               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10796               ffebad_finish ();
10797             }
10798         }
10799     }
10800   else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10801            && (rbt != FFEINFO_basictypeCOMPLEX))
10802     {
10803       if ((rbt != FFEINFO_basictypeANY)
10804           && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10805         {
10806           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10807           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10808           ffebad_finish ();
10809         }
10810     }
10811   else if (lrk != 0)
10812     {
10813       if ((lkd != FFEINFO_kindANY)
10814           && ffebad_start (FFEBAD_MATH_ARG_KIND))
10815         {
10816           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10817           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10818           ffebad_string ("an array");
10819           ffebad_finish ();
10820         }
10821     }
10822   else
10823     {
10824       if ((rkd != FFEINFO_kindANY)
10825           && ffebad_start (FFEBAD_MATH_ARG_KIND))
10826         {
10827           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10828           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10829           ffebad_string ("an array");
10830           ffebad_finish ();
10831         }
10832     }
10833
10834   reduced = ffebld_new_any ();
10835   ffebld_set_info (reduced, ffeinfo_new_any ());
10836   return reduced;
10837 }
10838
10839 /* ffeexpr_reduced_power_ -- Wrap up reduction of ** operator
10840
10841    reduced = ffeexpr_reduced_power_(reduced,l,op,r);
10842
10843    Makes sure the left and right arguments for reduced have basictype of
10844    INTEGER, REAL, or COMPLEX.  Determine common basictype and
10845    size for reduction (flag expression for combined hollerith/typeless
10846    situations for later determination of effective basictype).  If both left
10847    and right arguments have where of CONSTANT, assign where CONSTANT to
10848    reduced, else assign where FLEETING.  Create CONVERT ops for args where
10849    needed.  Note that real**int or complex**int
10850    comes out as int = real**int etc with no conversions.
10851
10852    If these requirements cannot be met, generate error message using the
10853    info in l, op, and r arguments and assign basictype, size, kind, and where
10854    of ANY.  */
10855
10856 static ffebld
10857 ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10858                         ffeexprExpr_ r)
10859 {
10860   ffeinfo linfo, rinfo, ninfo;
10861   ffeinfoBasictype lbt, rbt, nbt;
10862   ffeinfoKindtype lkt, rkt, nkt;
10863   ffeinfoRank lrk, rrk;
10864   ffeinfoKind lkd, rkd;
10865   ffeinfoWhere lwh, rwh, nwh;
10866
10867   linfo = ffebld_info (ffebld_left (reduced));
10868   lbt = ffeinfo_basictype (linfo);
10869   lkt = ffeinfo_kindtype (linfo);
10870   lrk = ffeinfo_rank (linfo);
10871   lkd = ffeinfo_kind (linfo);
10872   lwh = ffeinfo_where (linfo);
10873
10874   rinfo = ffebld_info (ffebld_right (reduced));
10875   rbt = ffeinfo_basictype (rinfo);
10876   rkt = ffeinfo_kindtype (rinfo);
10877   rrk = ffeinfo_rank (rinfo);
10878   rkd = ffeinfo_kind (rinfo);
10879   rwh = ffeinfo_where (rinfo);
10880
10881   if ((rbt == FFEINFO_basictypeINTEGER)
10882       && ((lbt == FFEINFO_basictypeREAL)
10883           || (lbt == FFEINFO_basictypeCOMPLEX)))
10884     {
10885       nbt = lbt;
10886       nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDEFAULT);
10887       if (nkt != FFEINFO_kindtypeREALDEFAULT)
10888         {
10889           nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDOUBLE);
10890           if (nkt != FFEINFO_kindtypeREALDOUBLE)
10891             nkt = FFEINFO_kindtypeREALDOUBLE;   /* Highest kt we can power! */
10892         }
10893       if (rkt == FFEINFO_kindtypeINTEGER4)
10894         {
10895           /* xgettext:no-c-format */
10896           ffebad_start_msg ("Unsupported operand for ** at %1 -- converting to default INTEGER",
10897                             FFEBAD_severityWARNING);
10898           ffebad_here (0, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10899           ffebad_finish ();
10900         }
10901       if (rkt != FFEINFO_kindtypeINTEGERDEFAULT)
10902         {
10903           ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10904                                                       r->token, op->token,
10905                 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0,
10906                                                 FFETARGET_charactersizeNONE,
10907                                                       FFEEXPR_contextLET));
10908           rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10909         }
10910     }
10911   else
10912     {
10913       ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10914
10915 #if 0   /* INTEGER4**INTEGER4 works now. */
10916       if ((nbt == FFEINFO_basictypeINTEGER)
10917           && (nkt != FFEINFO_kindtypeINTEGERDEFAULT))
10918         nkt = FFEINFO_kindtypeINTEGERDEFAULT;   /* Highest kt we can power! */
10919 #endif
10920       if (((nbt == FFEINFO_basictypeREAL)
10921            || (nbt == FFEINFO_basictypeCOMPLEX))
10922           && (nkt != FFEINFO_kindtypeREALDEFAULT))
10923         {
10924           nkt = ffeinfo_kindtype_max (nbt, nkt, FFEINFO_kindtypeREALDOUBLE);
10925           if (nkt != FFEINFO_kindtypeREALDOUBLE)
10926             nkt = FFEINFO_kindtypeREALDOUBLE;   /* Highest kt we can power! */
10927         }
10928       /* else Gonna turn into an error below. */
10929     }
10930
10931   if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10932        || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
10933     {
10934       switch (lwh)
10935         {
10936         case FFEINFO_whereCONSTANT:
10937           switch (rwh)
10938             {
10939             case FFEINFO_whereCONSTANT:
10940               nwh = FFEINFO_whereCONSTANT;
10941               break;
10942
10943             case FFEINFO_whereIMMEDIATE:
10944               nwh = FFEINFO_whereIMMEDIATE;
10945               break;
10946
10947             default:
10948               nwh = FFEINFO_whereFLEETING;
10949               break;
10950             }
10951           break;
10952
10953         case FFEINFO_whereIMMEDIATE:
10954           switch (rwh)
10955             {
10956             case FFEINFO_whereCONSTANT:
10957             case FFEINFO_whereIMMEDIATE:
10958               nwh = FFEINFO_whereIMMEDIATE;
10959               break;
10960
10961             default:
10962               nwh = FFEINFO_whereFLEETING;
10963               break;
10964             }
10965           break;
10966
10967         default:
10968           nwh = FFEINFO_whereFLEETING;
10969           break;
10970         }
10971
10972       ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10973                            FFETARGET_charactersizeNONE);
10974       ffebld_set_info (reduced, ninfo);
10975       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10976               l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10977                                                  FFEEXPR_contextLET));
10978       if (rbt != FFEINFO_basictypeINTEGER)
10979         ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10980               r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10981                                                     FFEEXPR_contextLET));
10982       return reduced;
10983     }
10984
10985   if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10986       && (lbt != FFEINFO_basictypeCOMPLEX))
10987     {
10988       if ((rbt != FFEINFO_basictypeINTEGER)
10989       && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
10990         {
10991           if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10992               && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
10993             {
10994               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10995               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10996               ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10997               ffebad_finish ();
10998             }
10999         }
11000       else
11001         {
11002           if ((lbt != FFEINFO_basictypeANY)
11003               && ffebad_start (FFEBAD_MATH_ARG_TYPE))
11004             {
11005               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11006               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11007               ffebad_finish ();
11008             }
11009         }
11010     }
11011   else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
11012            && (rbt != FFEINFO_basictypeCOMPLEX))
11013     {
11014       if ((rbt != FFEINFO_basictypeANY)
11015           && ffebad_start (FFEBAD_MATH_ARG_TYPE))
11016         {
11017           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11018           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11019           ffebad_finish ();
11020         }
11021     }
11022   else if (lrk != 0)
11023     {
11024       if ((lkd != FFEINFO_kindANY)
11025           && ffebad_start (FFEBAD_MATH_ARG_KIND))
11026         {
11027           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11028           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11029           ffebad_string ("an array");
11030           ffebad_finish ();
11031         }
11032     }
11033   else
11034     {
11035       if ((rkd != FFEINFO_kindANY)
11036           && ffebad_start (FFEBAD_MATH_ARG_KIND))
11037         {
11038           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11039           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11040           ffebad_string ("an array");
11041           ffebad_finish ();
11042         }
11043     }
11044
11045   reduced = ffebld_new_any ();
11046   ffebld_set_info (reduced, ffeinfo_new_any ());
11047   return reduced;
11048 }
11049
11050 /* ffeexpr_reduced_relop2_ -- Wrap up reduction of LT, LE, GE, and GT operators
11051
11052    reduced = ffeexpr_reduced_relop2_(reduced,l,op,r);
11053
11054    Makes sure the left and right arguments for reduced have basictype of
11055    INTEGER, REAL, or CHARACTER.  Determine common basictype and
11056    size for reduction.  If both left
11057    and right arguments have where of CONSTANT, assign where CONSTANT to
11058    reduced, else assign where FLEETING.  Create CONVERT ops for args where
11059    needed.  Convert typeless
11060    constants to the desired type/size explicitly.
11061
11062    If these requirements cannot be met, generate error message.  */
11063
11064 static ffebld
11065 ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
11066                          ffeexprExpr_ r)
11067 {
11068   ffeinfo linfo, rinfo, ninfo;
11069   ffeinfoBasictype lbt, rbt, nbt;
11070   ffeinfoKindtype lkt, rkt, nkt;
11071   ffeinfoRank lrk, rrk;
11072   ffeinfoKind lkd, rkd;
11073   ffeinfoWhere lwh, rwh, nwh;
11074   ffetargetCharacterSize lsz, rsz;
11075
11076   linfo = ffebld_info (ffebld_left (reduced));
11077   lbt = ffeinfo_basictype (linfo);
11078   lkt = ffeinfo_kindtype (linfo);
11079   lrk = ffeinfo_rank (linfo);
11080   lkd = ffeinfo_kind (linfo);
11081   lwh = ffeinfo_where (linfo);
11082   lsz = ffebld_size_known (ffebld_left (reduced));
11083
11084   rinfo = ffebld_info (ffebld_right (reduced));
11085   rbt = ffeinfo_basictype (rinfo);
11086   rkt = ffeinfo_kindtype (rinfo);
11087   rrk = ffeinfo_rank (rinfo);
11088   rkd = ffeinfo_kind (rinfo);
11089   rwh = ffeinfo_where (rinfo);
11090   rsz = ffebld_size_known (ffebld_right (reduced));
11091
11092   ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
11093
11094   if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
11095        || (nbt == FFEINFO_basictypeCHARACTER))
11096       && (lrk == 0) && (rrk == 0))
11097     {
11098       switch (lwh)
11099         {
11100         case FFEINFO_whereCONSTANT:
11101           switch (rwh)
11102             {
11103             case FFEINFO_whereCONSTANT:
11104               nwh = FFEINFO_whereCONSTANT;
11105               break;
11106
11107             case FFEINFO_whereIMMEDIATE:
11108               nwh = FFEINFO_whereIMMEDIATE;
11109               break;
11110
11111             default:
11112               nwh = FFEINFO_whereFLEETING;
11113               break;
11114             }
11115           break;
11116
11117         case FFEINFO_whereIMMEDIATE:
11118           switch (rwh)
11119             {
11120             case FFEINFO_whereCONSTANT:
11121             case FFEINFO_whereIMMEDIATE:
11122               nwh = FFEINFO_whereIMMEDIATE;
11123               break;
11124
11125             default:
11126               nwh = FFEINFO_whereFLEETING;
11127               break;
11128             }
11129           break;
11130
11131         default:
11132           nwh = FFEINFO_whereFLEETING;
11133           break;
11134         }
11135
11136       if ((lsz != FFETARGET_charactersizeNONE)
11137           && (rsz != FFETARGET_charactersizeNONE))
11138         lsz = rsz = (lsz > rsz) ? lsz : rsz;
11139
11140       ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
11141                    0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
11142       ffebld_set_info (reduced, ninfo);
11143       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11144                                       l->token, op->token, nbt, nkt, 0, lsz,
11145                                                  FFEEXPR_contextLET));
11146       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11147                                       r->token, op->token, nbt, nkt, 0, rsz,
11148                                                   FFEEXPR_contextLET));
11149       return reduced;
11150     }
11151
11152   if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
11153       && (lbt != FFEINFO_basictypeCHARACTER))
11154     {
11155       if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
11156           && (rbt != FFEINFO_basictypeCHARACTER))
11157         {
11158           if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
11159               && ffebad_start (FFEBAD_RELOP_ARGS_TYPE))
11160             {
11161               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11162               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11163               ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11164               ffebad_finish ();
11165             }
11166         }
11167       else
11168         {
11169           if ((lbt != FFEINFO_basictypeANY)
11170               && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
11171             {
11172               ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11173               ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11174               ffebad_finish ();
11175             }
11176         }
11177     }
11178   else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
11179            && (rbt != FFEINFO_basictypeCHARACTER))
11180     {
11181       if ((rbt != FFEINFO_basictypeANY)
11182           && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
11183         {
11184           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11185           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11186           ffebad_finish ();
11187         }
11188     }
11189   else if (lrk != 0)
11190     {
11191       if ((lkd != FFEINFO_kindANY)
11192           && ffebad_start (FFEBAD_RELOP_ARG_KIND))
11193         {
11194           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11195           ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11196           ffebad_string ("an array");
11197           ffebad_finish ();
11198         }
11199     }
11200   else
11201     {
11202       if ((rkd != FFEINFO_kindANY)
11203           && ffebad_start (FFEBAD_RELOP_ARG_KIND))
11204         {
11205           ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11206           ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11207           ffebad_string ("an array");
11208           ffebad_finish ();
11209         }
11210     }
11211
11212   reduced = ffebld_new_any ();
11213   ffebld_set_info (reduced, ffeinfo_new_any ());
11214   return reduced;
11215 }
11216
11217 /* ffeexpr_reduced_ugly1_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
11218
11219    reduced = ffeexpr_reduced_ugly1_(reduced,op,r);
11220
11221    Sigh.  */
11222
11223 static ffebld
11224 ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
11225 {
11226   ffeinfo rinfo;
11227   ffeinfoBasictype rbt;
11228   ffeinfoKindtype rkt;
11229   ffeinfoRank rrk;
11230   ffeinfoKind rkd;
11231   ffeinfoWhere rwh;
11232
11233   rinfo = ffebld_info (ffebld_left (reduced));
11234   rbt = ffeinfo_basictype (rinfo);
11235   rkt = ffeinfo_kindtype (rinfo);
11236   rrk = ffeinfo_rank (rinfo);
11237   rkd = ffeinfo_kind (rinfo);
11238   rwh = ffeinfo_where (rinfo);
11239
11240   if ((rbt == FFEINFO_basictypeTYPELESS)
11241       || (rbt == FFEINFO_basictypeHOLLERITH))
11242     {
11243       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11244                               r->token, op->token, FFEINFO_basictypeINTEGER,
11245                                           FFEINFO_kindtypeINTEGERDEFAULT, 0,
11246                                                  FFETARGET_charactersizeNONE,
11247                                                  FFEEXPR_contextLET));
11248       rinfo = ffebld_info (ffebld_left (reduced));
11249       rbt = FFEINFO_basictypeINTEGER;
11250       rkt = FFEINFO_kindtypeINTEGERDEFAULT;
11251       rrk = 0;
11252       rkd = FFEINFO_kindENTITY;
11253       rwh = ffeinfo_where (rinfo);
11254     }
11255
11256   if (rbt == FFEINFO_basictypeLOGICAL)
11257     {
11258       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11259                               r->token, op->token, FFEINFO_basictypeINTEGER,
11260                                           FFEINFO_kindtypeINTEGERDEFAULT, 0,
11261                                                  FFETARGET_charactersizeNONE,
11262                                                  FFEEXPR_contextLET));
11263     }
11264
11265   return reduced;
11266 }
11267
11268 /* ffeexpr_reduced_ugly1log_ -- Deal with TYPELESS and HOLLERITH
11269
11270    reduced = ffeexpr_reduced_ugly1log_(reduced,op,r);
11271
11272    Sigh.  */
11273
11274 static ffebld
11275 ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
11276 {
11277   ffeinfo rinfo;
11278   ffeinfoBasictype rbt;
11279   ffeinfoKindtype rkt;
11280   ffeinfoRank rrk;
11281   ffeinfoKind rkd;
11282   ffeinfoWhere rwh;
11283
11284   rinfo = ffebld_info (ffebld_left (reduced));
11285   rbt = ffeinfo_basictype (rinfo);
11286   rkt = ffeinfo_kindtype (rinfo);
11287   rrk = ffeinfo_rank (rinfo);
11288   rkd = ffeinfo_kind (rinfo);
11289   rwh = ffeinfo_where (rinfo);
11290
11291   if ((rbt == FFEINFO_basictypeTYPELESS)
11292       || (rbt == FFEINFO_basictypeHOLLERITH))
11293     {
11294       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11295                            r->token, op->token, FFEINFO_basictypeLOGICAL, 0,
11296                                              FFEINFO_kindtypeLOGICALDEFAULT,
11297                                                  FFETARGET_charactersizeNONE,
11298                                                  FFEEXPR_contextLET));
11299       rinfo = ffebld_info (ffebld_left (reduced));
11300       rbt = FFEINFO_basictypeLOGICAL;
11301       rkt = FFEINFO_kindtypeLOGICALDEFAULT;
11302       rrk = 0;
11303       rkd = FFEINFO_kindENTITY;
11304       rwh = ffeinfo_where (rinfo);
11305     }
11306
11307   return reduced;
11308 }
11309
11310 /* ffeexpr_reduced_ugly2_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
11311
11312    reduced = ffeexpr_reduced_ugly2_(reduced,l,op,r);
11313
11314    Sigh.  */
11315
11316 static ffebld
11317 ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
11318                         ffeexprExpr_ r)
11319 {
11320   ffeinfo linfo, rinfo;
11321   ffeinfoBasictype lbt, rbt;
11322   ffeinfoKindtype lkt, rkt;
11323   ffeinfoRank lrk, rrk;
11324   ffeinfoKind lkd, rkd;
11325   ffeinfoWhere lwh, rwh;
11326
11327   linfo = ffebld_info (ffebld_left (reduced));
11328   lbt = ffeinfo_basictype (linfo);
11329   lkt = ffeinfo_kindtype (linfo);
11330   lrk = ffeinfo_rank (linfo);
11331   lkd = ffeinfo_kind (linfo);
11332   lwh = ffeinfo_where (linfo);
11333
11334   rinfo = ffebld_info (ffebld_right (reduced));
11335   rbt = ffeinfo_basictype (rinfo);
11336   rkt = ffeinfo_kindtype (rinfo);
11337   rrk = ffeinfo_rank (rinfo);
11338   rkd = ffeinfo_kind (rinfo);
11339   rwh = ffeinfo_where (rinfo);
11340
11341   if ((lbt == FFEINFO_basictypeTYPELESS)
11342       || (lbt == FFEINFO_basictypeHOLLERITH))
11343     {
11344       if ((rbt == FFEINFO_basictypeTYPELESS)
11345           || (rbt == FFEINFO_basictypeHOLLERITH))
11346         {
11347           ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11348                               l->token, op->token, FFEINFO_basictypeINTEGER,
11349                                           FFEINFO_kindtypeINTEGERDEFAULT, 0,
11350                                                 FFETARGET_charactersizeNONE,
11351                                                      FFEEXPR_contextLET));
11352           ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11353                            r->token, op->token, FFEINFO_basictypeINTEGER, 0,
11354                                              FFEINFO_kindtypeINTEGERDEFAULT,
11355                                                 FFETARGET_charactersizeNONE,
11356                                                       FFEEXPR_contextLET));
11357           linfo = ffebld_info (ffebld_left (reduced));
11358           rinfo = ffebld_info (ffebld_right (reduced));
11359           lbt = rbt = FFEINFO_basictypeINTEGER;
11360           lkt = rkt = FFEINFO_kindtypeINTEGERDEFAULT;
11361           lrk = rrk = 0;
11362           lkd = rkd = FFEINFO_kindENTITY;
11363           lwh = ffeinfo_where (linfo);
11364           rwh = ffeinfo_where (rinfo);
11365         }
11366       else
11367         {
11368           ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
11369                                  l->token, ffebld_right (reduced), r->token,
11370                                                        FFEEXPR_contextLET));
11371           linfo = ffebld_info (ffebld_left (reduced));
11372           lbt = ffeinfo_basictype (linfo);
11373           lkt = ffeinfo_kindtype (linfo);
11374           lrk = ffeinfo_rank (linfo);
11375           lkd = ffeinfo_kind (linfo);
11376           lwh = ffeinfo_where (linfo);
11377         }
11378     }
11379   else
11380     {
11381       if ((rbt == FFEINFO_basictypeTYPELESS)
11382           || (rbt == FFEINFO_basictypeHOLLERITH))
11383         {
11384           ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
11385                                   r->token, ffebld_left (reduced), l->token,
11386                                                        FFEEXPR_contextLET));
11387           rinfo = ffebld_info (ffebld_right (reduced));
11388           rbt = ffeinfo_basictype (rinfo);
11389           rkt = ffeinfo_kindtype (rinfo);
11390           rrk = ffeinfo_rank (rinfo);
11391           rkd = ffeinfo_kind (rinfo);
11392           rwh = ffeinfo_where (rinfo);
11393         }
11394       /* else Leave it alone. */
11395     }
11396
11397   if (lbt == FFEINFO_basictypeLOGICAL)
11398     {
11399       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11400                               l->token, op->token, FFEINFO_basictypeINTEGER,
11401                                           FFEINFO_kindtypeINTEGERDEFAULT, 0,
11402                                                  FFETARGET_charactersizeNONE,
11403                                                  FFEEXPR_contextLET));
11404     }
11405
11406   if (rbt == FFEINFO_basictypeLOGICAL)
11407     {
11408       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11409                               r->token, op->token, FFEINFO_basictypeINTEGER,
11410                                           FFEINFO_kindtypeINTEGERDEFAULT, 0,
11411                                                 FFETARGET_charactersizeNONE,
11412                                                   FFEEXPR_contextLET));
11413     }
11414
11415   return reduced;
11416 }
11417
11418 /* ffeexpr_reduced_ugly2log_ -- Deal with TYPELESS and HOLLERITH
11419
11420    reduced = ffeexpr_reduced_ugly2log_(reduced,l,op,r);
11421
11422    Sigh.  */
11423
11424 static ffebld
11425 ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
11426                            ffeexprExpr_ r)
11427 {
11428   ffeinfo linfo, rinfo;
11429   ffeinfoBasictype lbt, rbt;
11430   ffeinfoKindtype lkt, rkt;
11431   ffeinfoRank lrk, rrk;
11432   ffeinfoKind lkd, rkd;
11433   ffeinfoWhere lwh, rwh;
11434
11435   linfo = ffebld_info (ffebld_left (reduced));
11436   lbt = ffeinfo_basictype (linfo);
11437   lkt = ffeinfo_kindtype (linfo);
11438   lrk = ffeinfo_rank (linfo);
11439   lkd = ffeinfo_kind (linfo);
11440   lwh = ffeinfo_where (linfo);
11441
11442   rinfo = ffebld_info (ffebld_right (reduced));
11443   rbt = ffeinfo_basictype (rinfo);
11444   rkt = ffeinfo_kindtype (rinfo);
11445   rrk = ffeinfo_rank (rinfo);
11446   rkd = ffeinfo_kind (rinfo);
11447   rwh = ffeinfo_where (rinfo);
11448
11449   if ((lbt == FFEINFO_basictypeTYPELESS)
11450       || (lbt == FFEINFO_basictypeHOLLERITH))
11451     {
11452       if ((rbt == FFEINFO_basictypeTYPELESS)
11453           || (rbt == FFEINFO_basictypeHOLLERITH))
11454         {
11455           ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11456                               l->token, op->token, FFEINFO_basictypeLOGICAL,
11457                                           FFEINFO_kindtypeLOGICALDEFAULT, 0,
11458                                                 FFETARGET_charactersizeNONE,
11459                                                      FFEEXPR_contextLET));
11460           ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11461                               r->token, op->token, FFEINFO_basictypeLOGICAL,
11462                                           FFEINFO_kindtypeLOGICALDEFAULT, 0,
11463                                                 FFETARGET_charactersizeNONE,
11464                                                       FFEEXPR_contextLET));
11465           linfo = ffebld_info (ffebld_left (reduced));
11466           rinfo = ffebld_info (ffebld_right (reduced));
11467           lbt = rbt = FFEINFO_basictypeLOGICAL;
11468           lkt = rkt = FFEINFO_kindtypeLOGICALDEFAULT;
11469           lrk = rrk = 0;
11470           lkd = rkd = FFEINFO_kindENTITY;
11471           lwh = ffeinfo_where (linfo);
11472           rwh = ffeinfo_where (rinfo);
11473         }
11474       else
11475         {
11476           ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
11477                                  l->token, ffebld_right (reduced), r->token,
11478                                                        FFEEXPR_contextLET));
11479           linfo = ffebld_info (ffebld_left (reduced));
11480           lbt = ffeinfo_basictype (linfo);
11481           lkt = ffeinfo_kindtype (linfo);
11482           lrk = ffeinfo_rank (linfo);
11483           lkd = ffeinfo_kind (linfo);
11484           lwh = ffeinfo_where (linfo);
11485         }
11486     }
11487   else
11488     {
11489       if ((rbt == FFEINFO_basictypeTYPELESS)
11490           || (rbt == FFEINFO_basictypeHOLLERITH))
11491         {
11492           ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
11493                                   r->token, ffebld_left (reduced), l->token,
11494                                                        FFEEXPR_contextLET));
11495           rinfo = ffebld_info (ffebld_right (reduced));
11496           rbt = ffeinfo_basictype (rinfo);
11497           rkt = ffeinfo_kindtype (rinfo);
11498           rrk = ffeinfo_rank (rinfo);
11499           rkd = ffeinfo_kind (rinfo);
11500           rwh = ffeinfo_where (rinfo);
11501         }
11502       /* else Leave it alone. */
11503     }
11504
11505   if (lbt == FFEINFO_basictypeLOGICAL)
11506   {
11507           ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11508                                   l->token, op->token, FFEINFO_basictypeINTEGER,
11509                                   FFEINFO_kindtypeINTEGERDEFAULT, 0,
11510                                   FFETARGET_charactersizeNONE,
11511                                   FFEEXPR_contextLET));
11512   }
11513
11514   if (rbt == FFEINFO_basictypeLOGICAL)
11515   {
11516           ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11517                                   r->token, op->token, FFEINFO_basictypeINTEGER,
11518                                   FFEINFO_kindtypeINTEGERDEFAULT, 0,
11519                                   FFETARGET_charactersizeNONE,
11520                                   FFEEXPR_contextLET));
11521   }
11522
11523   return reduced;
11524 }
11525
11526 /* Fumble through tokens until a nonmatching CLOSE_PAREN, EOS, or SEMICOLON
11527    is found.
11528
11529    The idea is to process the tokens as they would be done by normal
11530    expression processing, with the key things being telling the lexer
11531    when hollerith/character constants are about to happen, until the
11532    true closing token is found.  */
11533
11534 static ffelexHandler
11535 ffeexpr_find_close_paren_ (ffelexToken t,
11536                            ffelexHandler after)
11537 {
11538   ffeexpr_find_.after = after;
11539   ffeexpr_find_.level = 1;
11540   return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11541 }
11542
11543 static ffelexHandler
11544 ffeexpr_nil_finished_ (ffelexToken t)
11545 {
11546   switch (ffelex_token_type (t))
11547     {
11548     case FFELEX_typeCLOSE_PAREN:
11549       if (--ffeexpr_find_.level == 0)
11550         return (ffelexHandler) ffeexpr_find_.after;
11551       return (ffelexHandler) ffeexpr_nil_binary_;
11552
11553     case FFELEX_typeCOMMA:
11554     case FFELEX_typeCOLON:
11555     case FFELEX_typeEQUALS:
11556     case FFELEX_typePOINTS:
11557       return (ffelexHandler) ffeexpr_nil_rhs_;
11558
11559     default:
11560       if (--ffeexpr_find_.level == 0)
11561         return (ffelexHandler) ffeexpr_find_.after (t);
11562       return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11563     }
11564 }
11565
11566 static ffelexHandler
11567 ffeexpr_nil_rhs_ (ffelexToken t)
11568 {
11569   switch (ffelex_token_type (t))
11570     {
11571     case FFELEX_typeQUOTE:
11572       if (ffe_is_vxt ())
11573         return (ffelexHandler) ffeexpr_nil_quote_;
11574       ffelex_set_expecting_hollerith (-1, '\"',
11575                                       ffelex_token_where_line (t),
11576                                       ffelex_token_where_column (t));
11577       return (ffelexHandler) ffeexpr_nil_apostrophe_;
11578
11579     case FFELEX_typeAPOSTROPHE:
11580       ffelex_set_expecting_hollerith (-1, '\'',
11581                                       ffelex_token_where_line (t),
11582                                       ffelex_token_where_column (t));
11583       return (ffelexHandler) ffeexpr_nil_apostrophe_;
11584
11585     case FFELEX_typePERCENT:
11586       return (ffelexHandler) ffeexpr_nil_percent_;
11587
11588     case FFELEX_typeOPEN_PAREN:
11589       ++ffeexpr_find_.level;
11590       return (ffelexHandler) ffeexpr_nil_rhs_;
11591
11592     case FFELEX_typePLUS:
11593     case FFELEX_typeMINUS:
11594       return (ffelexHandler) ffeexpr_nil_rhs_;
11595
11596     case FFELEX_typePERIOD:
11597       return (ffelexHandler) ffeexpr_nil_period_;
11598
11599     case FFELEX_typeNUMBER:
11600       ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
11601       if (ffeexpr_hollerith_count_ > 0)
11602         ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
11603                                         '\0',
11604                                         ffelex_token_where_line (t),
11605                                         ffelex_token_where_column (t));
11606       return (ffelexHandler) ffeexpr_nil_number_;
11607
11608     case FFELEX_typeNAME:
11609     case FFELEX_typeNAMES:
11610       return (ffelexHandler) ffeexpr_nil_name_rhs_;
11611
11612     case FFELEX_typeASTERISK:
11613     case FFELEX_typeSLASH:
11614     case FFELEX_typePOWER:
11615     case FFELEX_typeCONCAT:
11616     case FFELEX_typeREL_EQ:
11617     case FFELEX_typeREL_NE:
11618     case FFELEX_typeREL_LE:
11619     case FFELEX_typeREL_GE:
11620       return (ffelexHandler) ffeexpr_nil_rhs_;
11621
11622     default:
11623       return (ffelexHandler) ffeexpr_nil_finished_ (t);
11624     }
11625 }
11626
11627 static ffelexHandler
11628 ffeexpr_nil_period_ (ffelexToken t)
11629 {
11630   switch (ffelex_token_type (t))
11631     {
11632     case FFELEX_typeNAME:
11633     case FFELEX_typeNAMES:
11634       ffeexpr_current_dotdot_ = ffestr_other (t);
11635       switch (ffeexpr_current_dotdot_)
11636         {
11637         case FFESTR_otherNone:
11638           return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11639
11640         case FFESTR_otherTRUE:
11641         case FFESTR_otherFALSE:
11642         case FFESTR_otherNOT:
11643           return (ffelexHandler) ffeexpr_nil_end_period_;
11644
11645         default:
11646           return (ffelexHandler) ffeexpr_nil_swallow_period_;
11647         }
11648       break;                    /* Nothing really reaches here. */
11649
11650     case FFELEX_typeNUMBER:
11651       return (ffelexHandler) ffeexpr_nil_real_;
11652
11653     default:
11654       return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11655     }
11656 }
11657
11658 static ffelexHandler
11659 ffeexpr_nil_end_period_ (ffelexToken t)
11660 {
11661   switch (ffeexpr_current_dotdot_)
11662     {
11663     case FFESTR_otherNOT:
11664       if (ffelex_token_type (t) != FFELEX_typePERIOD)
11665         return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11666       return (ffelexHandler) ffeexpr_nil_rhs_;
11667
11668     case FFESTR_otherTRUE:
11669     case FFESTR_otherFALSE:
11670       if (ffelex_token_type (t) != FFELEX_typePERIOD)
11671         return (ffelexHandler) ffeexpr_nil_binary_ (t);
11672       return (ffelexHandler) ffeexpr_nil_binary_;
11673
11674     default:
11675       assert ("Bad [nil] unary dotdot in ffeexpr_current_dotdot_" == NULL);
11676       exit (0);
11677       return NULL;
11678     }
11679 }
11680
11681 static ffelexHandler
11682 ffeexpr_nil_swallow_period_ (ffelexToken t)
11683 {
11684   if (ffelex_token_type (t) != FFELEX_typePERIOD)
11685     return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11686   return (ffelexHandler) ffeexpr_nil_rhs_;
11687 }
11688
11689 static ffelexHandler
11690 ffeexpr_nil_real_ (ffelexToken t)
11691 {
11692   char d;
11693   const char *p;
11694
11695   if (((ffelex_token_type (t) != FFELEX_typeNAME)
11696        && (ffelex_token_type (t) != FFELEX_typeNAMES))
11697       || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11698                                      'D', 'd')
11699              || ffesrc_char_match_init (d, 'E', 'e')
11700              || ffesrc_char_match_init (d, 'Q', 'q')))
11701            && ffeexpr_isdigits_ (++p)))
11702     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11703
11704   if (*p == '\0')
11705     return (ffelexHandler) ffeexpr_nil_real_exponent_;
11706   return (ffelexHandler) ffeexpr_nil_binary_;
11707 }
11708
11709 static ffelexHandler
11710 ffeexpr_nil_real_exponent_ (ffelexToken t)
11711 {
11712   if ((ffelex_token_type (t) != FFELEX_typePLUS)
11713       && (ffelex_token_type (t) != FFELEX_typeMINUS))
11714     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11715
11716   return (ffelexHandler) ffeexpr_nil_real_exp_sign_;
11717 }
11718
11719 static ffelexHandler
11720 ffeexpr_nil_real_exp_sign_ (ffelexToken t)
11721 {
11722   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11723     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11724   return (ffelexHandler) ffeexpr_nil_binary_;
11725 }
11726
11727 static ffelexHandler
11728 ffeexpr_nil_number_ (ffelexToken t)
11729 {
11730   char d;
11731   const char *p;
11732
11733   if (ffeexpr_hollerith_count_ > 0)
11734     ffelex_set_expecting_hollerith (0, '\0',
11735                                     ffewhere_line_unknown (),
11736                                     ffewhere_column_unknown ());
11737
11738   switch (ffelex_token_type (t))
11739     {
11740     case FFELEX_typeNAME:
11741     case FFELEX_typeNAMES:
11742       if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11743                                    'D', 'd')
11744            || ffesrc_char_match_init (d, 'E', 'e')
11745            || ffesrc_char_match_init (d, 'Q', 'q'))
11746           && ffeexpr_isdigits_ (++p))
11747         {
11748           if (*p == '\0')
11749             {
11750               ffeexpr_find_.t = ffelex_token_use (t);
11751               return (ffelexHandler) ffeexpr_nil_number_exponent_;
11752             }
11753           return (ffelexHandler) ffeexpr_nil_binary_;
11754         }
11755       break;
11756
11757     case FFELEX_typePERIOD:
11758       ffeexpr_find_.t = ffelex_token_use (t);
11759       return (ffelexHandler) ffeexpr_nil_number_period_;
11760
11761     case FFELEX_typeHOLLERITH:
11762       return (ffelexHandler) ffeexpr_nil_binary_;
11763
11764     default:
11765       break;
11766     }
11767   return (ffelexHandler) ffeexpr_nil_binary_ (t);
11768 }
11769
11770 /* Expects ffeexpr_find_.t.  */
11771
11772 static ffelexHandler
11773 ffeexpr_nil_number_exponent_ (ffelexToken t)
11774 {
11775   ffelexHandler nexthandler;
11776
11777   if ((ffelex_token_type (t) != FFELEX_typePLUS)
11778       && (ffelex_token_type (t) != FFELEX_typeMINUS))
11779     {
11780       nexthandler
11781         = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
11782       ffelex_token_kill (ffeexpr_find_.t);
11783       return (ffelexHandler) (*nexthandler) (t);
11784     }
11785
11786   ffelex_token_kill (ffeexpr_find_.t);
11787   return (ffelexHandler) ffeexpr_nil_number_exp_sign_;
11788 }
11789
11790 static ffelexHandler
11791 ffeexpr_nil_number_exp_sign_ (ffelexToken t)
11792 {
11793   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11794     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11795
11796   return (ffelexHandler) ffeexpr_nil_binary_;
11797 }
11798
11799 /* Expects ffeexpr_find_.t.  */
11800
11801 static ffelexHandler
11802 ffeexpr_nil_number_period_ (ffelexToken t)
11803 {
11804   ffelexHandler nexthandler;
11805   char d;
11806   const char *p;
11807
11808   switch (ffelex_token_type (t))
11809     {
11810     case FFELEX_typeNAME:
11811     case FFELEX_typeNAMES:
11812       if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11813                                    'D', 'd')
11814            || ffesrc_char_match_init (d, 'E', 'e')
11815            || ffesrc_char_match_init (d, 'Q', 'q'))
11816           && ffeexpr_isdigits_ (++p))
11817         {
11818           if (*p == '\0')
11819             return (ffelexHandler) ffeexpr_nil_number_per_exp_;
11820           ffelex_token_kill (ffeexpr_find_.t);
11821           return (ffelexHandler) ffeexpr_nil_binary_;
11822         }
11823       nexthandler
11824         = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
11825       ffelex_token_kill (ffeexpr_find_.t);
11826       return (ffelexHandler) (*nexthandler) (t);
11827
11828     case FFELEX_typeNUMBER:
11829       ffelex_token_kill (ffeexpr_find_.t);
11830       return (ffelexHandler) ffeexpr_nil_number_real_;
11831
11832     default:
11833       break;
11834     }
11835   ffelex_token_kill (ffeexpr_find_.t);
11836   return (ffelexHandler) ffeexpr_nil_binary_ (t);
11837 }
11838
11839 /* Expects ffeexpr_find_.t.  */
11840
11841 static ffelexHandler
11842 ffeexpr_nil_number_per_exp_ (ffelexToken t)
11843 {
11844   if ((ffelex_token_type (t) != FFELEX_typePLUS)
11845       && (ffelex_token_type (t) != FFELEX_typeMINUS))
11846     {
11847       ffelexHandler nexthandler;
11848
11849       nexthandler
11850         = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
11851       ffelex_token_kill (ffeexpr_find_.t);
11852       return (ffelexHandler) (*nexthandler) (t);
11853     }
11854
11855   ffelex_token_kill (ffeexpr_find_.t);
11856   return (ffelexHandler) ffeexpr_nil_num_per_exp_sign_;
11857 }
11858
11859 static ffelexHandler
11860 ffeexpr_nil_number_real_ (ffelexToken t)
11861 {
11862   char d;
11863   const char *p;
11864
11865   if (((ffelex_token_type (t) != FFELEX_typeNAME)
11866        && (ffelex_token_type (t) != FFELEX_typeNAMES))
11867       || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11868                                      'D', 'd')
11869              || ffesrc_char_match_init (d, 'E', 'e')
11870              || ffesrc_char_match_init (d, 'Q', 'q')))
11871            && ffeexpr_isdigits_ (++p)))
11872     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11873
11874   if (*p == '\0')
11875     return (ffelexHandler) ffeexpr_nil_number_real_exp_;
11876
11877   return (ffelexHandler) ffeexpr_nil_binary_;
11878 }
11879
11880 static ffelexHandler
11881 ffeexpr_nil_num_per_exp_sign_ (ffelexToken t)
11882 {
11883   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11884     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11885   return (ffelexHandler) ffeexpr_nil_binary_;
11886 }
11887
11888 static ffelexHandler
11889 ffeexpr_nil_number_real_exp_ (ffelexToken t)
11890 {
11891   if ((ffelex_token_type (t) != FFELEX_typePLUS)
11892       && (ffelex_token_type (t) != FFELEX_typeMINUS))
11893     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11894   return (ffelexHandler) ffeexpr_nil_num_real_exp_sn_;
11895 }
11896
11897 static ffelexHandler
11898 ffeexpr_nil_num_real_exp_sn_ (ffelexToken t)
11899 {
11900   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11901     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11902   return (ffelexHandler) ffeexpr_nil_binary_;
11903 }
11904
11905 static ffelexHandler
11906 ffeexpr_nil_binary_ (ffelexToken t)
11907 {
11908   switch (ffelex_token_type (t))
11909     {
11910     case FFELEX_typePLUS:
11911     case FFELEX_typeMINUS:
11912     case FFELEX_typeASTERISK:
11913     case FFELEX_typeSLASH:
11914     case FFELEX_typePOWER:
11915     case FFELEX_typeCONCAT:
11916     case FFELEX_typeOPEN_ANGLE:
11917     case FFELEX_typeCLOSE_ANGLE:
11918     case FFELEX_typeREL_EQ:
11919     case FFELEX_typeREL_NE:
11920     case FFELEX_typeREL_GE:
11921     case FFELEX_typeREL_LE:
11922       return (ffelexHandler) ffeexpr_nil_rhs_;
11923
11924     case FFELEX_typePERIOD:
11925       return (ffelexHandler) ffeexpr_nil_binary_period_;
11926
11927     default:
11928       return (ffelexHandler) ffeexpr_nil_finished_ (t);
11929     }
11930 }
11931
11932 static ffelexHandler
11933 ffeexpr_nil_binary_period_ (ffelexToken t)
11934 {
11935   switch (ffelex_token_type (t))
11936     {
11937     case FFELEX_typeNAME:
11938     case FFELEX_typeNAMES:
11939       ffeexpr_current_dotdot_ = ffestr_other (t);
11940       switch (ffeexpr_current_dotdot_)
11941         {
11942         case FFESTR_otherTRUE:
11943         case FFESTR_otherFALSE:
11944         case FFESTR_otherNOT:
11945           return (ffelexHandler) ffeexpr_nil_binary_sw_per_;
11946
11947         default:
11948           return (ffelexHandler) ffeexpr_nil_binary_end_per_;
11949         }
11950       break;                    /* Nothing really reaches here. */
11951
11952     default:
11953       return (ffelexHandler) ffeexpr_nil_binary_ (t);
11954     }
11955 }
11956
11957 static ffelexHandler
11958 ffeexpr_nil_binary_end_per_ (ffelexToken t)
11959 {
11960   if (ffelex_token_type (t) != FFELEX_typePERIOD)
11961     return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11962   return (ffelexHandler) ffeexpr_nil_rhs_;
11963 }
11964
11965 static ffelexHandler
11966 ffeexpr_nil_binary_sw_per_ (ffelexToken t)
11967 {
11968   if (ffelex_token_type (t) != FFELEX_typePERIOD)
11969     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11970   return (ffelexHandler) ffeexpr_nil_binary_;
11971 }
11972
11973 static ffelexHandler
11974 ffeexpr_nil_quote_ (ffelexToken t)
11975 {
11976   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11977     return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11978   return (ffelexHandler) ffeexpr_nil_binary_;
11979 }
11980
11981 static ffelexHandler
11982 ffeexpr_nil_apostrophe_ (ffelexToken t)
11983 {
11984   assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
11985   return (ffelexHandler) ffeexpr_nil_apos_char_;
11986 }
11987
11988 static ffelexHandler
11989 ffeexpr_nil_apos_char_ (ffelexToken t)
11990 {
11991   char c;
11992
11993   if ((ffelex_token_type (t) == FFELEX_typeNAME)
11994       || (ffelex_token_type (t) == FFELEX_typeNAMES))
11995     {
11996       if ((ffelex_token_length (t) == 1)
11997           && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]),
11998                                       'B', 'b')
11999               || ffesrc_char_match_init (c, 'O', 'o')
12000               || ffesrc_char_match_init (c, 'X', 'x')
12001               || ffesrc_char_match_init (c, 'Z', 'z')))
12002         return (ffelexHandler) ffeexpr_nil_binary_;
12003     }
12004   if ((ffelex_token_type (t) == FFELEX_typeNAME)
12005       || (ffelex_token_type (t) == FFELEX_typeNAMES))
12006     return (ffelexHandler) ffeexpr_nil_rhs_ (t);
12007   return (ffelexHandler) ffeexpr_nil_substrp_ (t);
12008 }
12009
12010 static ffelexHandler
12011 ffeexpr_nil_name_rhs_ (ffelexToken t)
12012 {
12013   switch (ffelex_token_type (t))
12014     {
12015     case FFELEX_typeQUOTE:
12016     case FFELEX_typeAPOSTROPHE:
12017       ffelex_set_hexnum (TRUE);
12018       return (ffelexHandler) ffeexpr_nil_name_apos_;
12019
12020     case FFELEX_typeOPEN_PAREN:
12021       ++ffeexpr_find_.level;
12022       return (ffelexHandler) ffeexpr_nil_rhs_;
12023
12024     default:
12025       return (ffelexHandler) ffeexpr_nil_binary_ (t);
12026     }
12027 }
12028
12029 static ffelexHandler
12030 ffeexpr_nil_name_apos_ (ffelexToken t)
12031 {
12032   if (ffelex_token_type (t) == FFELEX_typeNAME)
12033     return (ffelexHandler) ffeexpr_nil_name_apos_name_;
12034   return (ffelexHandler) ffeexpr_nil_binary_ (t);
12035 }
12036
12037 static ffelexHandler
12038 ffeexpr_nil_name_apos_name_ (ffelexToken t)
12039 {
12040   switch (ffelex_token_type (t))
12041     {
12042     case FFELEX_typeAPOSTROPHE:
12043     case FFELEX_typeQUOTE:
12044       return (ffelexHandler) ffeexpr_nil_finished_;
12045
12046     default:
12047       return (ffelexHandler) ffeexpr_nil_finished_ (t);
12048     }
12049 }
12050
12051 static ffelexHandler
12052 ffeexpr_nil_percent_ (ffelexToken t)
12053 {
12054   switch (ffelex_token_type (t))
12055     {
12056     case FFELEX_typeNAME:
12057     case FFELEX_typeNAMES:
12058       ffeexpr_stack_->percent = ffeexpr_percent_ (t);
12059       ffeexpr_find_.t = ffelex_token_use (t);
12060       return (ffelexHandler) ffeexpr_nil_percent_name_;
12061
12062     default:
12063       return (ffelexHandler) ffeexpr_nil_rhs_ (t);
12064     }
12065 }
12066
12067 /* Expects ffeexpr_find_.t.  */
12068
12069 static ffelexHandler
12070 ffeexpr_nil_percent_name_ (ffelexToken t)
12071 {
12072   ffelexHandler nexthandler;
12073
12074   if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
12075     {
12076       nexthandler
12077         = (ffelexHandler) ffeexpr_nil_rhs_ (ffeexpr_find_.t);
12078       ffelex_token_kill (ffeexpr_find_.t);
12079       return (ffelexHandler) (*nexthandler) (t);
12080     }
12081
12082   ffelex_token_kill (ffeexpr_find_.t);
12083   ++ffeexpr_find_.level;
12084   return (ffelexHandler) ffeexpr_nil_rhs_;
12085 }
12086
12087 static ffelexHandler
12088 ffeexpr_nil_substrp_ (ffelexToken t)
12089 {
12090   if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
12091     return (ffelexHandler) ffeexpr_nil_binary_ (t);
12092
12093   ++ffeexpr_find_.level;
12094   return (ffelexHandler) ffeexpr_nil_rhs_;
12095 }
12096
12097 /* ffeexpr_finished_ -- Reduce expression stack to one expr, finish
12098
12099    ffelexToken t;
12100    return ffeexpr_finished_(t);
12101
12102    Reduces expression stack to one (or zero) elements by repeatedly reducing
12103    the top operator on the stack (or, if the top element on the stack is
12104    itself an operator, issuing an error message and discarding it).  Calls
12105    finishing routine with the expression, returning the ffelexHandler it
12106    returns to the caller.  */
12107
12108 static ffelexHandler
12109 ffeexpr_finished_ (ffelexToken t)
12110 {
12111   ffeexprExpr_ operand;         /* This is B in -B or A+B. */
12112   ffebld expr;
12113   ffeexprCallback callback;
12114   ffeexprStack_ s;
12115   ffebldConstant constnode;     /* For detecting magical number. */
12116   ffelexToken ft;               /* Temporary copy of first token in
12117                                    expression. */
12118   ffelexHandler next;
12119   ffeinfo info;
12120   bool error = FALSE;
12121
12122   while (((operand = ffeexpr_stack_->exprstack) != NULL)
12123          && ((operand->previous != NULL) || (operand->type != FFEEXPR_exprtypeOPERAND_)))
12124     {
12125       if (operand->type == FFEEXPR_exprtypeOPERAND_)
12126         ffeexpr_reduce_ ();
12127       else
12128         {
12129           if (ffest_ffebad_start (FFEBAD_MISSING_OPERAND_FOR_OPERATOR))
12130             {
12131               ffebad_here (0, ffelex_token_where_line (t),
12132                            ffelex_token_where_column (t));
12133               ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
12134               ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
12135               ffebad_finish ();
12136             }
12137           ffeexpr_stack_->exprstack = operand->previous;        /* Pop the useless
12138                                                                    operator. */
12139           ffeexpr_expr_kill_ (operand);
12140         }
12141     }
12142
12143   assert ((operand == NULL) || (operand->previous == NULL));
12144
12145   ffebld_pool_pop ();
12146   if (operand == NULL)
12147     expr = NULL;
12148   else
12149     {
12150       expr = operand->u.operand;
12151       info = ffebld_info (expr);
12152       if ((ffebld_op (expr) == FFEBLD_opCONTER)
12153           && (ffebld_conter_orig (expr) == NULL)
12154           && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
12155         {
12156           ffetarget_integer_bad_magical (operand->token);
12157         }
12158       ffeexpr_expr_kill_ (operand);
12159       ffeexpr_stack_->exprstack = NULL;
12160     }
12161
12162   ft = ffeexpr_stack_->first_token;
12163
12164 again:                          /* :::::::::::::::::::: */
12165   switch (ffeexpr_stack_->context)
12166     {
12167     case FFEEXPR_contextLET:
12168     case FFEEXPR_contextSFUNCDEF:
12169       error = (expr == NULL)
12170         || (ffeinfo_rank (info) != 0);
12171       break;
12172
12173     case FFEEXPR_contextPAREN_:
12174       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12175         break;
12176       switch (ffeinfo_basictype (info))
12177         {
12178         case FFEINFO_basictypeHOLLERITH:
12179         case FFEINFO_basictypeTYPELESS:
12180           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12181              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12182                                   FFEEXPR_contextLET);
12183           break;
12184
12185         default:
12186           break;
12187         }
12188       break;
12189
12190     case FFEEXPR_contextPARENFILENUM_:
12191       if (ffelex_token_type (t) != FFELEX_typeCOMMA)
12192         ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
12193       else
12194         ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
12195       goto again;               /* :::::::::::::::::::: */
12196
12197     case FFEEXPR_contextPARENFILEUNIT_:
12198       if (ffelex_token_type (t) != FFELEX_typeCOMMA)
12199         ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
12200       else
12201         ffeexpr_stack_->context = FFEEXPR_contextFILEUNIT;
12202       goto again;               /* :::::::::::::::::::: */
12203
12204     case FFEEXPR_contextACTUALARGEXPR_:
12205     case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
12206       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12207               : ffeinfo_basictype (info))
12208         {
12209         case FFEINFO_basictypeHOLLERITH:
12210         case FFEINFO_basictypeTYPELESS:
12211           if (!ffe_is_ugly_args ()
12212               && ffebad_start (FFEBAD_ACTUALARG))
12213             {
12214               ffebad_here (0, ffelex_token_where_line (ft),
12215                            ffelex_token_where_column (ft));
12216               ffebad_finish ();
12217             }
12218           break;
12219
12220         default:
12221           break;
12222         }
12223       error = (expr != NULL) && (ffeinfo_rank (info) != 0);
12224       break;
12225
12226     case FFEEXPR_contextACTUALARG_:
12227     case FFEEXPR_contextSFUNCDEFACTUALARG_:
12228       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12229               : ffeinfo_basictype (info))
12230         {
12231         case FFEINFO_basictypeHOLLERITH:
12232         case FFEINFO_basictypeTYPELESS:
12233 #if 0                           /* Should never get here. */
12234           expr = ffeexpr_convert (expr, ft, ft,
12235                                   FFEINFO_basictypeINTEGER,
12236                                   FFEINFO_kindtypeINTEGERDEFAULT,
12237                                   0,
12238                                   FFETARGET_charactersizeNONE,
12239                                   FFEEXPR_contextLET);
12240 #else
12241           assert ("why hollerith/typeless in actualarg_?" == NULL);
12242 #endif
12243           break;
12244
12245         default:
12246           break;
12247         }
12248       switch ((expr == NULL) ? FFEBLD_opANY : ffebld_op (expr))
12249         {
12250         case FFEBLD_opSYMTER:
12251         case FFEBLD_opPERCENT_LOC:
12252         case FFEBLD_opPERCENT_VAL:
12253         case FFEBLD_opPERCENT_REF:
12254         case FFEBLD_opPERCENT_DESCR:
12255           error = FALSE;
12256           break;
12257
12258         default:
12259           error = (expr != NULL) && (ffeinfo_rank (info) != 0);
12260           break;
12261         }
12262       {
12263         ffesymbol s;
12264         ffeinfoWhere where;
12265         ffeinfoKind kind;
12266
12267         if (!error
12268             && (expr != NULL)
12269             && (ffebld_op (expr) == FFEBLD_opSYMTER)
12270             && ((s = ffebld_symter (expr)), (where = ffesymbol_where (s)),
12271                 (where == FFEINFO_whereINTRINSIC)
12272                 || (where == FFEINFO_whereGLOBAL)
12273                 || ((where == FFEINFO_whereDUMMY)
12274                     && ((kind = ffesymbol_kind (s)),
12275                         (kind == FFEINFO_kindFUNCTION)
12276                         || (kind == FFEINFO_kindSUBROUTINE))))
12277             && !ffesymbol_explicitwhere (s))
12278           {
12279             ffebad_start (where == FFEINFO_whereINTRINSIC
12280                           ? FFEBAD_NEED_INTRINSIC : FFEBAD_NEED_EXTERNAL);
12281             ffebad_here (0, ffelex_token_where_line (ft),
12282                          ffelex_token_where_column (ft));
12283             ffebad_string (ffesymbol_text (s));
12284             ffebad_finish ();
12285             ffesymbol_signal_change (s);
12286             ffesymbol_set_explicitwhere (s, TRUE);
12287             ffesymbol_signal_unreported (s);
12288           }
12289       }
12290       break;
12291
12292     case FFEEXPR_contextINDEX_:
12293     case FFEEXPR_contextSFUNCDEFINDEX_:
12294       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12295         break;
12296       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12297               : ffeinfo_basictype (info))
12298         {
12299         case FFEINFO_basictypeNONE:
12300           error = FALSE;
12301           break;
12302
12303         case FFEINFO_basictypeLOGICAL:
12304           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12305              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12306                                   FFEEXPR_contextLET);
12307           /* Fall through. */
12308         case FFEINFO_basictypeREAL:
12309         case FFEINFO_basictypeCOMPLEX:
12310           if (ffe_is_pedantic ())
12311             {
12312               error = TRUE;
12313               break;
12314             }
12315           /* Fall through. */
12316         case FFEINFO_basictypeHOLLERITH:
12317         case FFEINFO_basictypeTYPELESS:
12318           error = FALSE;
12319           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12320              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12321                                   FFEEXPR_contextLET);
12322           break;
12323
12324         case FFEINFO_basictypeINTEGER:
12325           /* Specifically, allow INTEGER(KIND=2), aka INTEGER*8, through
12326              unmolested.  Leave it to downstream to handle kinds.  */
12327           break;
12328
12329         default:
12330           error = TRUE;
12331           break;
12332         }
12333       break;                    /* expr==NULL ok for substring; element case
12334                                    caught by callback. */
12335
12336     case FFEEXPR_contextRETURN:
12337       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12338         break;
12339       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12340               : ffeinfo_basictype (info))
12341         {
12342         case FFEINFO_basictypeNONE:
12343           error = FALSE;
12344           break;
12345
12346         case FFEINFO_basictypeLOGICAL:
12347           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12348              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12349                                   FFEEXPR_contextLET);
12350           /* Fall through. */
12351         case FFEINFO_basictypeREAL:
12352         case FFEINFO_basictypeCOMPLEX:
12353           if (ffe_is_pedantic ())
12354             {
12355               error = TRUE;
12356               break;
12357             }
12358           /* Fall through. */
12359         case FFEINFO_basictypeINTEGER:
12360         case FFEINFO_basictypeHOLLERITH:
12361         case FFEINFO_basictypeTYPELESS:
12362           error = FALSE;
12363           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12364              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12365                                   FFEEXPR_contextLET);
12366           break;
12367
12368         default:
12369           error = TRUE;
12370           break;
12371         }
12372       break;
12373
12374     case FFEEXPR_contextDO:
12375       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12376         break;
12377       switch (ffeinfo_basictype (info))
12378         {
12379         case FFEINFO_basictypeLOGICAL:
12380           error = !ffe_is_ugly_logint ();
12381           if (!ffeexpr_stack_->is_rhs)
12382             break;              /* Don't convert lhs variable. */
12383           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12384                                   ffeinfo_kindtype (ffebld_info (expr)), 0,
12385                                   FFETARGET_charactersizeNONE,
12386                                   FFEEXPR_contextLET);
12387           break;
12388
12389         case FFEINFO_basictypeHOLLERITH:
12390         case FFEINFO_basictypeTYPELESS:
12391           if (!ffeexpr_stack_->is_rhs)
12392             {
12393               error = TRUE;
12394               break;            /* Don't convert lhs variable. */
12395             }
12396           break;
12397
12398         case FFEINFO_basictypeINTEGER:
12399         case FFEINFO_basictypeREAL:
12400           break;
12401
12402         default:
12403           error = TRUE;
12404           break;
12405         }
12406       if (!ffeexpr_stack_->is_rhs
12407           && (ffebld_op (expr) != FFEBLD_opSYMTER))
12408         error = TRUE;
12409       break;
12410
12411     case FFEEXPR_contextDOWHILE:
12412     case FFEEXPR_contextIF:
12413       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12414         break;
12415       switch (ffeinfo_basictype (info))
12416         {
12417         case FFEINFO_basictypeINTEGER:
12418           error = FALSE;
12419           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12420              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12421                                   FFEEXPR_contextLET);
12422           /* Fall through. */
12423         case FFEINFO_basictypeLOGICAL:
12424         case FFEINFO_basictypeHOLLERITH:
12425         case FFEINFO_basictypeTYPELESS:
12426           error = FALSE;
12427           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12428              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12429                                   FFEEXPR_contextLET);
12430           break;
12431
12432         default:
12433           error = TRUE;
12434           break;
12435         }
12436       break;
12437
12438     case FFEEXPR_contextASSIGN:
12439     case FFEEXPR_contextAGOTO:
12440       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12441               : ffeinfo_basictype (info))
12442         {
12443         case FFEINFO_basictypeINTEGER:
12444           error = (ffeinfo_kindtype (info) != ffecom_label_kind ());
12445           break;
12446
12447         case FFEINFO_basictypeLOGICAL:
12448           error = !ffe_is_ugly_logint ()
12449             || (ffeinfo_kindtype (info) != ffecom_label_kind ());
12450           break;
12451
12452         default:
12453           error = TRUE;
12454           break;
12455         }
12456       if ((expr == NULL) || (ffeinfo_rank (info) != 0)
12457           || (ffebld_op (expr) != FFEBLD_opSYMTER))
12458         error = TRUE;
12459       break;
12460
12461     case FFEEXPR_contextCGOTO:
12462     case FFEEXPR_contextFORMAT:
12463     case FFEEXPR_contextDIMLIST:
12464     case FFEEXPR_contextFILENUM:        /* See equiv code in _ambig_. */
12465       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12466         break;
12467       switch (ffeinfo_basictype (info))
12468         {
12469         case FFEINFO_basictypeLOGICAL:
12470           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12471              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12472                                   FFEEXPR_contextLET);
12473           /* Fall through. */
12474         case FFEINFO_basictypeREAL:
12475         case FFEINFO_basictypeCOMPLEX:
12476           if (ffe_is_pedantic ())
12477             {
12478               error = TRUE;
12479               break;
12480             }
12481           /* Fall through. */
12482         case FFEINFO_basictypeINTEGER:
12483         case FFEINFO_basictypeHOLLERITH:
12484         case FFEINFO_basictypeTYPELESS:
12485           error = FALSE;
12486           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12487              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12488                                   FFEEXPR_contextLET);
12489           break;
12490
12491         default:
12492           error = TRUE;
12493           break;
12494         }
12495       break;
12496
12497     case FFEEXPR_contextARITHIF:
12498       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12499         break;
12500       switch (ffeinfo_basictype (info))
12501         {
12502         case FFEINFO_basictypeLOGICAL:
12503           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12504              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12505                                   FFEEXPR_contextLET);
12506           if (ffe_is_pedantic ())
12507             {
12508               error = TRUE;
12509               break;
12510             }
12511           /* Fall through. */
12512         case FFEINFO_basictypeHOLLERITH:
12513         case FFEINFO_basictypeTYPELESS:
12514           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12515              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12516                                   FFEEXPR_contextLET);
12517           /* Fall through. */
12518         case FFEINFO_basictypeINTEGER:
12519         case FFEINFO_basictypeREAL:
12520           error = FALSE;
12521           break;
12522
12523         default:
12524           error = TRUE;
12525           break;
12526         }
12527       break;
12528
12529     case FFEEXPR_contextSTOP:
12530       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12531         break;
12532       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12533               : ffeinfo_basictype (info))
12534         {
12535         case FFEINFO_basictypeINTEGER:
12536           error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12537           break;
12538
12539         case FFEINFO_basictypeCHARACTER:
12540           error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT);
12541           break;
12542
12543         case FFEINFO_basictypeHOLLERITH:
12544         case FFEINFO_basictypeTYPELESS:
12545           error = FALSE;
12546           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12547              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12548                                   FFEEXPR_contextLET);
12549           break;
12550
12551         case FFEINFO_basictypeNONE:
12552           error = FALSE;
12553           break;
12554
12555         default:
12556           error = TRUE;
12557           break;
12558         }
12559       if ((expr != NULL) && ((ffebld_op (expr) != FFEBLD_opCONTER)
12560                              || (ffebld_conter_orig (expr) != NULL)))
12561         error = TRUE;
12562       break;
12563
12564     case FFEEXPR_contextINCLUDE:
12565       error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12566         || (ffeinfo_basictype (info) != FFEINFO_basictypeCHARACTER)
12567         || (ffebld_op (expr) != FFEBLD_opCONTER)
12568         || (ffebld_conter_orig (expr) != NULL);
12569       break;
12570
12571     case FFEEXPR_contextSELECTCASE:
12572       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12573         break;
12574       switch (ffeinfo_basictype (info))
12575         {
12576         case FFEINFO_basictypeINTEGER:
12577         case FFEINFO_basictypeCHARACTER:
12578         case FFEINFO_basictypeLOGICAL:
12579           error = FALSE;
12580           break;
12581
12582         case FFEINFO_basictypeHOLLERITH:
12583         case FFEINFO_basictypeTYPELESS:
12584           error = FALSE;
12585           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12586              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12587                                   FFEEXPR_contextLET);
12588           break;
12589
12590         default:
12591           error = TRUE;
12592           break;
12593         }
12594       break;
12595
12596     case FFEEXPR_contextCASE:
12597       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12598         break;
12599       switch ((expr == NULL) ? FFEINFO_basictypeINTEGER
12600               : ffeinfo_basictype (info))
12601         {
12602         case FFEINFO_basictypeINTEGER:
12603         case FFEINFO_basictypeCHARACTER:
12604         case FFEINFO_basictypeLOGICAL:
12605           error = FALSE;
12606           break;
12607
12608         case FFEINFO_basictypeHOLLERITH:
12609         case FFEINFO_basictypeTYPELESS:
12610           error = FALSE;
12611           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12612              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12613                                   FFEEXPR_contextLET);
12614           break;
12615
12616         default:
12617           error = TRUE;
12618           break;
12619         }
12620       if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12621         error = TRUE;
12622       break;
12623
12624     case FFEEXPR_contextCHARACTERSIZE:
12625     case FFEEXPR_contextKINDTYPE:
12626     case FFEEXPR_contextDIMLISTCOMMON:
12627       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12628         break;
12629       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12630               : ffeinfo_basictype (info))
12631         {
12632         case FFEINFO_basictypeLOGICAL:
12633           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12634              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12635                                   FFEEXPR_contextLET);
12636           /* Fall through. */
12637         case FFEINFO_basictypeREAL:
12638         case FFEINFO_basictypeCOMPLEX:
12639           if (ffe_is_pedantic ())
12640             {
12641               error = TRUE;
12642               break;
12643             }
12644           /* Fall through. */
12645         case FFEINFO_basictypeINTEGER:
12646         case FFEINFO_basictypeHOLLERITH:
12647         case FFEINFO_basictypeTYPELESS:
12648           error = FALSE;
12649           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12650              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12651                                   FFEEXPR_contextLET);
12652           break;
12653
12654         default:
12655           error = TRUE;
12656           break;
12657         }
12658       if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12659         error = TRUE;
12660       break;
12661
12662     case FFEEXPR_contextEQVINDEX_:
12663       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12664         break;
12665       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12666               : ffeinfo_basictype (info))
12667         {
12668         case FFEINFO_basictypeNONE:
12669           error = FALSE;
12670           break;
12671
12672         case FFEINFO_basictypeLOGICAL:
12673           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12674              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12675                                   FFEEXPR_contextLET);
12676           /* Fall through. */
12677         case FFEINFO_basictypeREAL:
12678         case FFEINFO_basictypeCOMPLEX:
12679           if (ffe_is_pedantic ())
12680             {
12681               error = TRUE;
12682               break;
12683             }
12684           /* Fall through. */
12685         case FFEINFO_basictypeINTEGER:
12686         case FFEINFO_basictypeHOLLERITH:
12687         case FFEINFO_basictypeTYPELESS:
12688           error = FALSE;
12689           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12690              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12691                                   FFEEXPR_contextLET);
12692           break;
12693
12694         default:
12695           error = TRUE;
12696           break;
12697         }
12698       if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12699         error = TRUE;
12700       break;
12701
12702     case FFEEXPR_contextPARAMETER:
12703       if (ffeexpr_stack_->is_rhs)
12704         error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12705           || (ffebld_op (expr) != FFEBLD_opCONTER);
12706       else
12707         error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12708           || (ffebld_op (expr) != FFEBLD_opSYMTER);
12709       break;
12710
12711     case FFEEXPR_contextINDEXORACTUALARG_:
12712       if (ffelex_token_type (t) == FFELEX_typeCOLON)
12713         ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
12714       else
12715         ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
12716       goto again;               /* :::::::::::::::::::: */
12717
12718     case FFEEXPR_contextINDEXORACTUALARGEXPR_:
12719       if (ffelex_token_type (t) == FFELEX_typeCOLON)
12720         ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
12721       else
12722         ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
12723       goto again;               /* :::::::::::::::::::: */
12724
12725     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
12726       if (ffelex_token_type (t) == FFELEX_typeCOLON)
12727         ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
12728       else
12729         ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
12730       goto again;               /* :::::::::::::::::::: */
12731
12732     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
12733       if (ffelex_token_type (t) == FFELEX_typeCOLON)
12734         ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
12735       else
12736         ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
12737       goto again;               /* :::::::::::::::::::: */
12738
12739     case FFEEXPR_contextIMPDOCTRL_:
12740       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12741         break;
12742       if (!ffeexpr_stack_->is_rhs
12743           && (ffebld_op (expr) != FFEBLD_opSYMTER))
12744         error = TRUE;
12745       switch (ffeinfo_basictype (info))
12746         {
12747         case FFEINFO_basictypeLOGICAL:
12748           if (! ffe_is_ugly_logint ())
12749             error = TRUE;
12750           if (! ffeexpr_stack_->is_rhs)
12751             break;
12752           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12753                                   ffeinfo_kindtype (info), 0,
12754                                   FFETARGET_charactersizeNONE,
12755                                   FFEEXPR_contextLET);
12756           break;
12757
12758         case FFEINFO_basictypeINTEGER:
12759         case FFEINFO_basictypeHOLLERITH:
12760         case FFEINFO_basictypeTYPELESS:
12761           break;
12762
12763         case FFEINFO_basictypeREAL:
12764           if (!ffeexpr_stack_->is_rhs
12765               && ffe_is_warn_surprising ()
12766               && !error)
12767             {
12768               ffebad_start (FFEBAD_DO_REAL);    /* See error message!!! */
12769               ffebad_here (0, ffelex_token_where_line (ft),
12770                            ffelex_token_where_column (ft));
12771               ffebad_string (ffelex_token_text (ft));
12772               ffebad_finish ();
12773             }
12774           break;
12775
12776         default:
12777           error = TRUE;
12778           break;
12779         }
12780       break;
12781
12782     case FFEEXPR_contextDATAIMPDOCTRL_:
12783       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12784         break;
12785       if (ffeexpr_stack_->is_rhs)
12786         {
12787           if ((ffebld_op (expr) != FFEBLD_opCONTER)
12788               && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12789             error = TRUE;
12790         }
12791       else if ((ffebld_op (expr) != FFEBLD_opSYMTER)
12792                || (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12793         error = TRUE;
12794       switch (ffeinfo_basictype (info))
12795         {
12796         case FFEINFO_basictypeLOGICAL:
12797           if (! ffeexpr_stack_->is_rhs)
12798             break;
12799           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12800                                   ffeinfo_kindtype (info), 0,
12801                                   FFETARGET_charactersizeNONE,
12802                                   FFEEXPR_contextLET);
12803           /* Fall through.  */
12804         case FFEINFO_basictypeINTEGER:
12805           if (ffeexpr_stack_->is_rhs
12806               && (ffeinfo_kindtype (ffebld_info (expr))
12807                   != FFEINFO_kindtypeINTEGERDEFAULT))
12808             expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12809                                     FFEINFO_kindtypeINTEGERDEFAULT, 0,
12810                                     FFETARGET_charactersizeNONE,
12811                                     FFEEXPR_contextLET);
12812           break;
12813
12814         case FFEINFO_basictypeHOLLERITH:
12815         case FFEINFO_basictypeTYPELESS:
12816           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12817              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12818                                   FFEEXPR_contextLET);
12819           break;
12820
12821         case FFEINFO_basictypeREAL:
12822           if (!ffeexpr_stack_->is_rhs
12823               && ffe_is_warn_surprising ()
12824               && !error)
12825             {
12826               ffebad_start (FFEBAD_DO_REAL);    /* See error message!!! */
12827               ffebad_here (0, ffelex_token_where_line (ft),
12828                            ffelex_token_where_column (ft));
12829               ffebad_string (ffelex_token_text (ft));
12830               ffebad_finish ();
12831             }
12832           break;
12833
12834         default:
12835           error = TRUE;
12836           break;
12837         }
12838       break;
12839
12840     case FFEEXPR_contextIMPDOITEM_:
12841       if (ffelex_token_type (t) == FFELEX_typeEQUALS)
12842         {
12843           ffeexpr_stack_->is_rhs = FALSE;
12844           ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
12845           goto again;           /* :::::::::::::::::::: */
12846         }
12847       /* Fall through. */
12848     case FFEEXPR_contextIOLIST:
12849     case FFEEXPR_contextFILEVXTCODE:
12850       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12851               : ffeinfo_basictype (info))
12852         {
12853         case FFEINFO_basictypeHOLLERITH:
12854         case FFEINFO_basictypeTYPELESS:
12855           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12856              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12857                                   FFEEXPR_contextLET);
12858           break;
12859
12860         default:
12861           break;
12862         }
12863       error = (expr == NULL)
12864         || ((ffeinfo_rank (info) != 0)
12865             && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12866                 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12867                 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12868                     == FFEBLD_opSTAR)));        /* Bad if null expr, or if
12869                                                    array that is not a SYMTER
12870                                                    (can't happen yet, I
12871                                                    think) or has a NULL or
12872                                                    STAR (assumed) array
12873                                                    size. */
12874       break;
12875
12876     case FFEEXPR_contextIMPDOITEMDF_:
12877       if (ffelex_token_type (t) == FFELEX_typeEQUALS)
12878         {
12879           ffeexpr_stack_->is_rhs = FALSE;
12880           ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
12881           goto again;           /* :::::::::::::::::::: */
12882         }
12883       /* Fall through. */
12884     case FFEEXPR_contextIOLISTDF:
12885       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12886               : ffeinfo_basictype (info))
12887         {
12888         case FFEINFO_basictypeHOLLERITH:
12889         case FFEINFO_basictypeTYPELESS:
12890           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12891              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12892                                   FFEEXPR_contextLET);
12893           break;
12894
12895         default:
12896           break;
12897         }
12898       error
12899         = (expr == NULL)
12900           || ((ffeinfo_basictype (info) == FFEINFO_basictypeCHARACTER)
12901               && (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT))
12902             || ((ffeinfo_rank (info) != 0)
12903                 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12904                     || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12905                     || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12906                         == FFEBLD_opSTAR)));    /* Bad if null expr,
12907                                                    non-default-kindtype
12908                                                    character expr, or if
12909                                                    array that is not a SYMTER
12910                                                    (can't happen yet, I
12911                                                    think) or has a NULL or
12912                                                    STAR (assumed) array
12913                                                    size. */
12914       break;
12915
12916     case FFEEXPR_contextDATAIMPDOITEM_:
12917       error = (expr == NULL)
12918         || (ffebld_op (expr) != FFEBLD_opARRAYREF)
12919         || ((ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR)
12920             && (ffeinfo_where (info) != FFEINFO_whereFLEETING_IADDR));
12921       break;
12922
12923     case FFEEXPR_contextDATAIMPDOINDEX_:
12924       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12925         break;
12926       switch (ffeinfo_basictype (info))
12927         {
12928         case FFEINFO_basictypeLOGICAL:
12929           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12930              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12931                                   FFEEXPR_contextLET);
12932           /* Fall through. */
12933         case FFEINFO_basictypeREAL:
12934         case FFEINFO_basictypeCOMPLEX:
12935           if (ffe_is_pedantic ())
12936             {
12937               error = TRUE;
12938               break;
12939             }
12940           /* Fall through. */
12941         case FFEINFO_basictypeINTEGER:
12942         case FFEINFO_basictypeHOLLERITH:
12943         case FFEINFO_basictypeTYPELESS:
12944           error = FALSE;
12945           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12946              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12947                                   FFEEXPR_contextLET);
12948           break;
12949
12950         default:
12951           error = TRUE;
12952           break;
12953         }
12954       if ((ffeinfo_where (info) != FFEINFO_whereCONSTANT)
12955           && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12956         error = TRUE;
12957       break;
12958
12959     case FFEEXPR_contextDATA:
12960       if (expr == NULL)
12961         error = TRUE;
12962       else if (ffeexpr_stack_->is_rhs)
12963         error = (ffebld_op (expr) != FFEBLD_opCONTER);
12964       else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12965         error = FALSE;
12966       else
12967         error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12968       break;
12969
12970     case FFEEXPR_contextINITVAL:
12971       error = (expr == NULL) || (ffebld_op (expr) != FFEBLD_opCONTER);
12972       break;
12973
12974     case FFEEXPR_contextEQUIVALENCE:
12975       if (expr == NULL)
12976         error = TRUE;
12977       else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12978         error = FALSE;
12979       else
12980         error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12981       break;
12982
12983     case FFEEXPR_contextFILEASSOC:
12984     case FFEEXPR_contextFILEINT:
12985       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12986               : ffeinfo_basictype (info))
12987         {
12988         case FFEINFO_basictypeINTEGER:
12989           /* Maybe this should be supported someday, but, right now,
12990              g77 can't generate a call to libf2c to write to an
12991              integer other than the default size.  */
12992           error = ((! ffeexpr_stack_->is_rhs)
12993                    && ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12994           break;
12995
12996         default:
12997           error = TRUE;
12998           break;
12999         }
13000       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13001         error = TRUE;
13002       break;
13003
13004     case FFEEXPR_contextFILEDFINT:
13005       switch ((expr == NULL) ? FFEINFO_basictypeNONE
13006               : ffeinfo_basictype (info))
13007         {
13008         case FFEINFO_basictypeINTEGER:
13009           error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
13010           break;
13011
13012         default:
13013           error = TRUE;
13014           break;
13015         }
13016       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13017         error = TRUE;
13018       break;
13019
13020     case FFEEXPR_contextFILELOG:
13021       switch ((expr == NULL) ? FFEINFO_basictypeNONE
13022               : ffeinfo_basictype (info))
13023         {
13024         case FFEINFO_basictypeLOGICAL:
13025           error = FALSE;
13026           break;
13027
13028         default:
13029           error = TRUE;
13030           break;
13031         }
13032       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13033         error = TRUE;
13034       break;
13035
13036     case FFEEXPR_contextFILECHAR:
13037       switch ((expr == NULL) ? FFEINFO_basictypeNONE
13038               : ffeinfo_basictype (info))
13039         {
13040         case FFEINFO_basictypeCHARACTER:
13041           error = FALSE;
13042           break;
13043
13044         default:
13045           error = TRUE;
13046           break;
13047         }
13048       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13049         error = TRUE;
13050       break;
13051
13052     case FFEEXPR_contextFILENUMCHAR:
13053       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
13054         break;
13055       switch (ffeinfo_basictype (info))
13056         {
13057         case FFEINFO_basictypeLOGICAL:
13058           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13059              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13060                                   FFEEXPR_contextLET);
13061           /* Fall through. */
13062         case FFEINFO_basictypeREAL:
13063         case FFEINFO_basictypeCOMPLEX:
13064           if (ffe_is_pedantic ())
13065             {
13066               error = TRUE;
13067               break;
13068             }
13069           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13070              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13071                                   FFEEXPR_contextLET);
13072           break;
13073
13074         case FFEINFO_basictypeINTEGER:
13075         case FFEINFO_basictypeCHARACTER:
13076           error = FALSE;
13077           break;
13078
13079         default:
13080           error = TRUE;
13081           break;
13082         }
13083       break;
13084
13085     case FFEEXPR_contextFILEDFCHAR:
13086       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
13087         break;
13088       switch (ffeinfo_basictype (info))
13089         {
13090         case FFEINFO_basictypeCHARACTER:
13091           error
13092             = (ffeinfo_kindtype (info)
13093                != FFEINFO_kindtypeCHARACTERDEFAULT);
13094           break;
13095
13096         default:
13097           error = TRUE;
13098           break;
13099         }
13100       if (!ffeexpr_stack_->is_rhs
13101           && (ffebld_op (expr) == FFEBLD_opSUBSTR))
13102         error = TRUE;
13103       break;
13104
13105     case FFEEXPR_contextFILEUNIT:       /* See equiv code in _ambig_. */
13106       switch ((expr == NULL) ? FFEINFO_basictypeNONE
13107               : ffeinfo_basictype (info))
13108         {
13109         case FFEINFO_basictypeLOGICAL:
13110           if ((error = (ffeinfo_rank (info) != 0)))
13111             break;
13112           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13113              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13114                                   FFEEXPR_contextLET);
13115           /* Fall through. */
13116         case FFEINFO_basictypeREAL:
13117         case FFEINFO_basictypeCOMPLEX:
13118           if ((error = (ffeinfo_rank (info) != 0)))
13119             break;
13120           if (ffe_is_pedantic ())
13121             {
13122               error = TRUE;
13123               break;
13124             }
13125           /* Fall through. */
13126         case FFEINFO_basictypeINTEGER:
13127         case FFEINFO_basictypeHOLLERITH:
13128         case FFEINFO_basictypeTYPELESS:
13129           if ((error = (ffeinfo_rank (info) != 0)))
13130             break;
13131           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13132              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13133                                   FFEEXPR_contextLET);
13134           break;
13135
13136         case FFEINFO_basictypeCHARACTER:
13137           switch (ffebld_op (expr))
13138             {                   /* As if _lhs had been called instead of
13139                                    _rhs. */
13140             case FFEBLD_opSYMTER:
13141               error
13142                 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
13143               break;
13144
13145             case FFEBLD_opSUBSTR:
13146               error = (ffeinfo_where (ffebld_info (expr))
13147                        == FFEINFO_whereCONSTANT_SUBOBJECT);
13148               break;
13149
13150             case FFEBLD_opARRAYREF:
13151               error = FALSE;
13152               break;
13153
13154             default:
13155               error = TRUE;
13156               break;
13157             }
13158           if (!error
13159            && ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
13160                || ((ffeinfo_rank (info) != 0)
13161                    && ((ffebld_op (expr) != FFEBLD_opSYMTER)
13162                      || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
13163                   || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
13164                       == FFEBLD_opSTAR)))))     /* Bad if
13165                                                    non-default-kindtype
13166                                                    character expr, or if
13167                                                    array that is not a SYMTER
13168                                                    (can't happen yet, I
13169                                                    think), or has a NULL or
13170                                                    STAR (assumed) array
13171                                                    size. */
13172             error = TRUE;
13173           break;
13174
13175         default:
13176           error = TRUE;
13177           break;
13178         }
13179       break;
13180
13181     case FFEEXPR_contextFILEFORMAT:
13182       switch ((expr == NULL) ? FFEINFO_basictypeNONE
13183               : ffeinfo_basictype (info))
13184         {
13185         case FFEINFO_basictypeINTEGER:
13186           error = (expr == NULL)
13187             || ((ffeinfo_rank (info) != 0) ?
13188                 ffe_is_pedantic ()      /* F77 C5. */
13189                 : (bool) (ffeinfo_kindtype (info) != ffecom_label_kind ()))
13190             || (ffebld_op (expr) != FFEBLD_opSYMTER);
13191           break;
13192
13193         case FFEINFO_basictypeLOGICAL:
13194         case FFEINFO_basictypeREAL:
13195         case FFEINFO_basictypeCOMPLEX:
13196           /* F77 C5 -- must be an array of hollerith.  */
13197           error
13198             = ffe_is_pedantic ()
13199               || (ffeinfo_rank (info) == 0);
13200           break;
13201
13202         case FFEINFO_basictypeCHARACTER:
13203           if ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
13204               || ((ffeinfo_rank (info) != 0)
13205                   && ((ffebld_op (expr) != FFEBLD_opSYMTER)
13206                       || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
13207                       || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
13208                           == FFEBLD_opSTAR))))  /* Bad if
13209                                                    non-default-kindtype
13210                                                    character expr, or if
13211                                                    array that is not a SYMTER
13212                                                    (can't happen yet, I
13213                                                    think), or has a NULL or
13214                                                    STAR (assumed) array
13215                                                    size. */
13216             error = TRUE;
13217           else
13218             error = FALSE;
13219           break;
13220
13221         default:
13222           error = TRUE;
13223           break;
13224         }
13225       break;
13226
13227     case FFEEXPR_contextLOC_:
13228       /* See also ffeintrin_check_loc_.  */
13229       if ((expr == NULL)
13230           || (ffeinfo_kind (info) != FFEINFO_kindENTITY)
13231           || ((ffebld_op (expr) != FFEBLD_opSYMTER)
13232               && (ffebld_op (expr) != FFEBLD_opSUBSTR)
13233               && (ffebld_op (expr) != FFEBLD_opARRAYREF)))
13234         error = TRUE;
13235       break;
13236
13237     default:
13238       error = FALSE;
13239       break;
13240     }
13241
13242   if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
13243     {
13244       ffebad_start (FFEBAD_EXPR_WRONG);
13245       ffebad_here (0, ffelex_token_where_line (ft),
13246                    ffelex_token_where_column (ft));
13247       ffebad_finish ();
13248       expr = ffebld_new_any ();
13249       ffebld_set_info (expr, ffeinfo_new_any ());
13250     }
13251
13252   callback = ffeexpr_stack_->callback;
13253   s = ffeexpr_stack_->previous;
13254   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
13255                   sizeof (*ffeexpr_stack_));
13256   ffeexpr_stack_ = s;
13257   next = (ffelexHandler) (*callback) (ft, expr, t);
13258   ffelex_token_kill (ft);
13259   return (ffelexHandler) next;
13260 }
13261
13262 /* ffeexpr_finished_ambig_ -- Check validity of ambiguous unit/form spec
13263
13264    ffebld expr;
13265    expr = ffeexpr_finished_ambig_(expr);
13266
13267    Replicates a bit of ffeexpr_finished_'s task when in a context
13268    of UNIT or FORMAT.  */
13269
13270 static ffebld
13271 ffeexpr_finished_ambig_ (ffelexToken ft, ffebld expr)
13272 {
13273   ffeinfo info = ffebld_info (expr);
13274   bool error;
13275
13276   switch (ffeexpr_stack_->context)
13277     {
13278     case FFEEXPR_contextFILENUMAMBIG:   /* Same as FILENUM in _finished_. */
13279       switch ((expr == NULL) ? FFEINFO_basictypeNONE
13280               : ffeinfo_basictype (info))
13281         {
13282         case FFEINFO_basictypeLOGICAL:
13283           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13284              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13285                                   FFEEXPR_contextLET);
13286           /* Fall through. */
13287         case FFEINFO_basictypeREAL:
13288         case FFEINFO_basictypeCOMPLEX:
13289           if (ffe_is_pedantic ())
13290             {
13291               error = TRUE;
13292               break;
13293             }
13294           /* Fall through. */
13295         case FFEINFO_basictypeINTEGER:
13296         case FFEINFO_basictypeHOLLERITH:
13297         case FFEINFO_basictypeTYPELESS:
13298           error = FALSE;
13299           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13300              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13301                                   FFEEXPR_contextLET);
13302           break;
13303
13304         default:
13305           error = TRUE;
13306           break;
13307         }
13308       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13309         error = TRUE;
13310       break;
13311
13312     case FFEEXPR_contextFILEUNITAMBIG:  /* Same as FILEUNIT in _finished_. */
13313       if ((expr != NULL) && (ffebld_op (expr) == FFEBLD_opSTAR))
13314         {
13315           error = FALSE;
13316           break;
13317         }
13318       switch ((expr == NULL) ? FFEINFO_basictypeNONE
13319               : ffeinfo_basictype (info))
13320         {
13321         case FFEINFO_basictypeLOGICAL:
13322           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13323              FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13324                                   FFEEXPR_contextLET);
13325           /* Fall through. */
13326         case FFEINFO_basictypeREAL:
13327         case FFEINFO_basictypeCOMPLEX:
13328           if (ffe_is_pedantic ())
13329             {
13330               error = TRUE;
13331               break;
13332             }
13333           /* Fall through. */
13334         case FFEINFO_basictypeINTEGER:
13335         case FFEINFO_basictypeHOLLERITH:
13336         case FFEINFO_basictypeTYPELESS:
13337           error = (ffeinfo_rank (info) != 0);
13338           expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13339              FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13340                                   FFEEXPR_contextLET);
13341           break;
13342
13343         case FFEINFO_basictypeCHARACTER:
13344           switch (ffebld_op (expr))
13345             {                   /* As if _lhs had been called instead of
13346                                    _rhs. */
13347             case FFEBLD_opSYMTER:
13348               error
13349                 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
13350               break;
13351
13352             case FFEBLD_opSUBSTR:
13353               error = (ffeinfo_where (ffebld_info (expr))
13354                        == FFEINFO_whereCONSTANT_SUBOBJECT);
13355               break;
13356
13357             case FFEBLD_opARRAYREF:
13358               error = FALSE;
13359               break;
13360
13361             default:
13362               error = TRUE;
13363               break;
13364             }
13365           break;
13366
13367         default:
13368           error = TRUE;
13369           break;
13370         }
13371       break;
13372
13373     default:
13374       assert ("bad context" == NULL);
13375       error = TRUE;
13376       break;
13377     }
13378
13379   if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
13380     {
13381       ffebad_start (FFEBAD_EXPR_WRONG);
13382       ffebad_here (0, ffelex_token_where_line (ft),
13383                    ffelex_token_where_column (ft));
13384       ffebad_finish ();
13385       expr = ffebld_new_any ();
13386       ffebld_set_info (expr, ffeinfo_new_any ());
13387     }
13388
13389   return expr;
13390 }
13391
13392 /* ffeexpr_token_lhs_ -- Initial state for lhs expression
13393
13394    Return a pointer to this function to the lexer (ffelex), which will
13395    invoke it for the next token.
13396
13397    Basically a smaller version of _rhs_; keep them both in sync, of course.  */
13398
13399 static ffelexHandler
13400 ffeexpr_token_lhs_ (ffelexToken t)
13401 {
13402
13403   /* When changing the list of valid initial lhs tokens, check whether to
13404      update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
13405      READ (expr) <token> case -- it assumes it knows which tokens <token> can
13406      be to indicate an lhs (or implied DO), which right now is the set
13407      {NAME,OPEN_PAREN}.
13408
13409      This comment also appears in ffeexpr_token_first_lhs_. */
13410
13411   switch (ffelex_token_type (t))
13412     {
13413     case FFELEX_typeNAME:
13414     case FFELEX_typeNAMES:
13415       ffeexpr_tokens_[0] = ffelex_token_use (t);
13416       return (ffelexHandler) ffeexpr_token_name_lhs_;
13417
13418     default:
13419       return (ffelexHandler) ffeexpr_finished_ (t);
13420     }
13421 }
13422
13423 /* ffeexpr_token_rhs_ -- Initial state for rhs expression
13424
13425    Return a pointer to this function to the lexer (ffelex), which will
13426    invoke it for the next token.
13427
13428    The initial state and the post-binary-operator state are the same and
13429    both handled here, with the expression stack used to distinguish
13430    between them.  Binary operators are invalid here; unary operators,
13431    constants, subexpressions, and name references are valid.  */
13432
13433 static ffelexHandler
13434 ffeexpr_token_rhs_ (ffelexToken t)
13435 {
13436   ffeexprExpr_ e;
13437
13438   switch (ffelex_token_type (t))
13439     {
13440     case FFELEX_typeQUOTE:
13441       if (ffe_is_vxt ())
13442         {
13443           ffeexpr_tokens_[0] = ffelex_token_use (t);
13444           return (ffelexHandler) ffeexpr_token_quote_;
13445         }
13446       ffeexpr_tokens_[0] = ffelex_token_use (t);
13447       ffelex_set_expecting_hollerith (-1, '\"',
13448                                       ffelex_token_where_line (t),
13449                                       ffelex_token_where_column (t));
13450       /* Don't have to unset this one. */
13451       return (ffelexHandler) ffeexpr_token_apostrophe_;
13452
13453     case FFELEX_typeAPOSTROPHE:
13454       ffeexpr_tokens_[0] = ffelex_token_use (t);
13455       ffelex_set_expecting_hollerith (-1, '\'',
13456                                       ffelex_token_where_line (t),
13457                                       ffelex_token_where_column (t));
13458       /* Don't have to unset this one. */
13459       return (ffelexHandler) ffeexpr_token_apostrophe_;
13460
13461     case FFELEX_typePERCENT:
13462       ffeexpr_tokens_[0] = ffelex_token_use (t);
13463       return (ffelexHandler) ffeexpr_token_percent_;
13464
13465     case FFELEX_typeOPEN_PAREN:
13466       ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
13467       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
13468                                           FFEEXPR_contextPAREN_,
13469                                           ffeexpr_cb_close_paren_c_);
13470
13471     case FFELEX_typePLUS:
13472       e = ffeexpr_expr_new_ ();
13473       e->type = FFEEXPR_exprtypeUNARY_;
13474       e->token = ffelex_token_use (t);
13475       e->u.operator.op = FFEEXPR_operatorADD_;
13476       e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
13477       e->u.operator.as = FFEEXPR_operatorassociativityADD_;
13478       ffeexpr_exprstack_push_unary_ (e);
13479       return (ffelexHandler) ffeexpr_token_rhs_;
13480
13481     case FFELEX_typeMINUS:
13482       e = ffeexpr_expr_new_ ();
13483       e->type = FFEEXPR_exprtypeUNARY_;
13484       e->token = ffelex_token_use (t);
13485       e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
13486       e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
13487       e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
13488       ffeexpr_exprstack_push_unary_ (e);
13489       return (ffelexHandler) ffeexpr_token_rhs_;
13490
13491     case FFELEX_typePERIOD:
13492       ffeexpr_tokens_[0] = ffelex_token_use (t);
13493       return (ffelexHandler) ffeexpr_token_period_;
13494
13495     case FFELEX_typeNUMBER:
13496       ffeexpr_tokens_[0] = ffelex_token_use (t);
13497       ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
13498       if (ffeexpr_hollerith_count_ > 0)
13499         ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
13500                                         '\0',
13501                                         ffelex_token_where_line (t),
13502                                         ffelex_token_where_column (t));
13503       return (ffelexHandler) ffeexpr_token_number_;
13504
13505     case FFELEX_typeNAME:
13506     case FFELEX_typeNAMES:
13507       ffeexpr_tokens_[0] = ffelex_token_use (t);
13508       switch (ffeexpr_stack_->context)
13509         {
13510         case FFEEXPR_contextACTUALARG_:
13511         case FFEEXPR_contextINDEXORACTUALARG_:
13512         case FFEEXPR_contextSFUNCDEFACTUALARG_:
13513         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
13514           return (ffelexHandler) ffeexpr_token_name_arg_;
13515
13516         default:
13517           return (ffelexHandler) ffeexpr_token_name_rhs_;
13518         }
13519
13520     case FFELEX_typeASTERISK:
13521     case FFELEX_typeSLASH:
13522     case FFELEX_typePOWER:
13523     case FFELEX_typeCONCAT:
13524     case FFELEX_typeREL_EQ:
13525     case FFELEX_typeREL_NE:
13526     case FFELEX_typeREL_LE:
13527     case FFELEX_typeREL_GE:
13528       if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
13529         {
13530           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13531           ffebad_finish ();
13532         }
13533       return (ffelexHandler) ffeexpr_token_rhs_;
13534
13535 #if 0
13536     case FFELEX_typeEQUALS:
13537     case FFELEX_typePOINTS:
13538     case FFELEX_typeCLOSE_ANGLE:
13539     case FFELEX_typeCLOSE_PAREN:
13540     case FFELEX_typeCOMMA:
13541     case FFELEX_typeCOLON:
13542     case FFELEX_typeEOS:
13543     case FFELEX_typeSEMICOLON:
13544 #endif
13545     default:
13546       return (ffelexHandler) ffeexpr_finished_ (t);
13547     }
13548 }
13549
13550 /* ffeexpr_token_period_ -- Rhs PERIOD
13551
13552    Return a pointer to this function to the lexer (ffelex), which will
13553    invoke it for the next token.
13554
13555    Handle a period detected at rhs (expecting unary op or operand) state.
13556    Must begin a floating-point value (as in .12) or a dot-dot name, of
13557    which only .NOT., .TRUE., and .FALSE. are truly valid.  Other sort-of-
13558    valid names represent binary operators, which are invalid here because
13559    there isn't an operand at the top of the stack.  */
13560
13561 static ffelexHandler
13562 ffeexpr_token_period_ (ffelexToken t)
13563 {
13564   switch (ffelex_token_type (t))
13565     {
13566     case FFELEX_typeNAME:
13567     case FFELEX_typeNAMES:
13568       ffeexpr_current_dotdot_ = ffestr_other (t);
13569       switch (ffeexpr_current_dotdot_)
13570         {
13571         case FFESTR_otherNone:
13572           if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
13573             {
13574               ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13575                            ffelex_token_where_column (ffeexpr_tokens_[0]));
13576               ffebad_finish ();
13577             }
13578           ffelex_token_kill (ffeexpr_tokens_[0]);
13579           return (ffelexHandler) ffeexpr_token_rhs_ (t);
13580
13581         case FFESTR_otherTRUE:
13582         case FFESTR_otherFALSE:
13583         case FFESTR_otherNOT:
13584           ffeexpr_tokens_[1] = ffelex_token_use (t);
13585           return (ffelexHandler) ffeexpr_token_end_period_;
13586
13587         default:
13588           if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
13589             {
13590               ffebad_here (0, ffelex_token_where_line (t),
13591                            ffelex_token_where_column (t));
13592               ffebad_finish ();
13593             }
13594           ffelex_token_kill (ffeexpr_tokens_[0]);
13595           return (ffelexHandler) ffeexpr_token_swallow_period_;
13596         }
13597       break;                    /* Nothing really reaches here. */
13598
13599     case FFELEX_typeNUMBER:
13600       ffeexpr_tokens_[1] = ffelex_token_use (t);
13601       return (ffelexHandler) ffeexpr_token_real_;
13602
13603     default:
13604       if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
13605         {
13606           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13607                        ffelex_token_where_column (ffeexpr_tokens_[0]));
13608           ffebad_finish ();
13609         }
13610       ffelex_token_kill (ffeexpr_tokens_[0]);
13611       return (ffelexHandler) ffeexpr_token_rhs_ (t);
13612     }
13613 }
13614
13615 /* ffeexpr_token_end_period_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
13616
13617    Return a pointer to this function to the lexer (ffelex), which will
13618    invoke it for the next token.
13619
13620    Expecting a period to close a .NOT, .TRUE, or .FALSE at rhs (unary op
13621    or operator) state.  If period isn't found, issue a diagnostic but
13622    pretend we saw one.  ffeexpr_current_dotdot_ must already contained the
13623    dotdot representation of the name in between the two PERIOD tokens.  */
13624
13625 static ffelexHandler
13626 ffeexpr_token_end_period_ (ffelexToken t)
13627 {
13628   ffeexprExpr_ e;
13629
13630   if (ffelex_token_type (t) != FFELEX_typePERIOD)
13631     {
13632       if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
13633         {
13634           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13635                        ffelex_token_where_column (ffeexpr_tokens_[0]));
13636           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13637           ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
13638           ffebad_finish ();
13639         }
13640     }
13641
13642   ffelex_token_kill (ffeexpr_tokens_[1]);       /* Kill "NOT"/"TRUE"/"FALSE"
13643                                                    token. */
13644
13645   e = ffeexpr_expr_new_ ();
13646   e->token = ffeexpr_tokens_[0];
13647
13648   switch (ffeexpr_current_dotdot_)
13649     {
13650     case FFESTR_otherNOT:
13651       e->type = FFEEXPR_exprtypeUNARY_;
13652       e->u.operator.op = FFEEXPR_operatorNOT_;
13653       e->u.operator.prec = FFEEXPR_operatorprecedenceNOT_;
13654       e->u.operator.as = FFEEXPR_operatorassociativityNOT_;
13655       ffeexpr_exprstack_push_unary_ (e);
13656       if (ffelex_token_type (t) != FFELEX_typePERIOD)
13657         return (ffelexHandler) ffeexpr_token_rhs_ (t);
13658       return (ffelexHandler) ffeexpr_token_rhs_;
13659
13660     case FFESTR_otherTRUE:
13661       e->type = FFEEXPR_exprtypeOPERAND_;
13662       e->u.operand
13663         = ffebld_new_conter (ffebld_constant_new_logicaldefault (TRUE));
13664       ffebld_set_info (e->u.operand,
13665       ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
13666                    0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13667       ffeexpr_exprstack_push_operand_ (e);
13668       if (ffelex_token_type (t) != FFELEX_typePERIOD)
13669         return (ffelexHandler) ffeexpr_token_binary_ (t);
13670       return (ffelexHandler) ffeexpr_token_binary_;
13671
13672     case FFESTR_otherFALSE:
13673       e->type = FFEEXPR_exprtypeOPERAND_;
13674       e->u.operand
13675         = ffebld_new_conter (ffebld_constant_new_logicaldefault (FALSE));
13676       ffebld_set_info (e->u.operand,
13677       ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
13678                    0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13679       ffeexpr_exprstack_push_operand_ (e);
13680       if (ffelex_token_type (t) != FFELEX_typePERIOD)
13681         return (ffelexHandler) ffeexpr_token_binary_ (t);
13682       return (ffelexHandler) ffeexpr_token_binary_;
13683
13684     default:
13685       assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL);
13686       exit (0);
13687       return NULL;
13688     }
13689 }
13690
13691 /* ffeexpr_token_swallow_period_ -- Rhs PERIOD NAME(not NOT, TRUE, or FALSE)
13692
13693    Return a pointer to this function to the lexer (ffelex), which will
13694    invoke it for the next token.
13695
13696    A diagnostic has already been issued; just swallow a period if there is
13697    one, then continue with ffeexpr_token_rhs_.  */
13698
13699 static ffelexHandler
13700 ffeexpr_token_swallow_period_ (ffelexToken t)
13701 {
13702   if (ffelex_token_type (t) != FFELEX_typePERIOD)
13703     return (ffelexHandler) ffeexpr_token_rhs_ (t);
13704
13705   return (ffelexHandler) ffeexpr_token_rhs_;
13706 }
13707
13708 /* ffeexpr_token_real_ -- Rhs PERIOD NUMBER
13709
13710    Return a pointer to this function to the lexer (ffelex), which will
13711    invoke it for the next token.
13712
13713    After a period and a string of digits, check next token for possible
13714    exponent designation (D, E, or Q as first/only character) and continue
13715    real-number handling accordingly.  Else form basic real constant, push
13716    onto expression stack, and enter binary state using current token (which,
13717    if it is a name not beginning with D, E, or Q, will certainly result
13718    in an error, but that's not for this routine to deal with).  */
13719
13720 static ffelexHandler
13721 ffeexpr_token_real_ (ffelexToken t)
13722 {
13723   char d;
13724   const char *p;
13725
13726   if (((ffelex_token_type (t) != FFELEX_typeNAME)
13727        && (ffelex_token_type (t) != FFELEX_typeNAMES))
13728       || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13729                                      'D', 'd')
13730              || ffesrc_char_match_init (d, 'E', 'e')
13731              || ffesrc_char_match_init (d, 'Q', 'q')))
13732            && ffeexpr_isdigits_ (++p)))
13733     {
13734 #if 0
13735       /* This code has been removed because it seems inconsistent to
13736          produce a diagnostic in this case, but not all of the other
13737          ones that look for an exponent and cannot recognize one.  */
13738       if (((ffelex_token_type (t) == FFELEX_typeNAME)
13739            || (ffelex_token_type (t) == FFELEX_typeNAMES))
13740           && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
13741         {
13742           char bad[2];
13743
13744           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13745           ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
13746                        ffelex_token_where_column (ffeexpr_tokens_[0]));
13747           bad[0] = *(p - 1);
13748           bad[1] = '\0';
13749           ffebad_string (bad);
13750           ffebad_finish ();
13751         }
13752 #endif
13753       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13754                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13755                                  NULL, NULL, NULL);
13756
13757       ffelex_token_kill (ffeexpr_tokens_[0]);
13758       ffelex_token_kill (ffeexpr_tokens_[1]);
13759       return (ffelexHandler) ffeexpr_token_binary_ (t);
13760     }
13761
13762   /* Just exponent character by itself?  In which case, PLUS or MINUS must
13763      surely be next, followed by a NUMBER token. */
13764
13765   if (*p == '\0')
13766     {
13767       ffeexpr_tokens_[2] = ffelex_token_use (t);
13768       return (ffelexHandler) ffeexpr_token_real_exponent_;
13769     }
13770
13771   ffeexpr_make_float_const_ (d, NULL, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13772                              t, NULL, NULL);
13773
13774   ffelex_token_kill (ffeexpr_tokens_[0]);
13775   ffelex_token_kill (ffeexpr_tokens_[1]);
13776   return (ffelexHandler) ffeexpr_token_binary_;
13777 }
13778
13779 /* ffeexpr_token_real_exponent_ -- Rhs PERIOD NUMBER NAME(D, E, or Q)
13780
13781    Return a pointer to this function to the lexer (ffelex), which will
13782    invoke it for the next token.
13783
13784    Ensures this token is PLUS or MINUS, preserves it, goes to final state
13785    for real number (exponent digits).  Else issues diagnostic, assumes a
13786    zero exponent field for number, passes token on to binary state as if
13787    previous token had been "E0" instead of "E", for example.  */
13788
13789 static ffelexHandler
13790 ffeexpr_token_real_exponent_ (ffelexToken t)
13791 {
13792   if ((ffelex_token_type (t) != FFELEX_typePLUS)
13793       && (ffelex_token_type (t) != FFELEX_typeMINUS))
13794     {
13795       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13796         {
13797           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
13798                        ffelex_token_where_column (ffeexpr_tokens_[2]));
13799           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13800           ffebad_finish ();
13801         }
13802
13803       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13804                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13805                                  NULL, NULL, NULL);
13806
13807       ffelex_token_kill (ffeexpr_tokens_[0]);
13808       ffelex_token_kill (ffeexpr_tokens_[1]);
13809       ffelex_token_kill (ffeexpr_tokens_[2]);
13810       return (ffelexHandler) ffeexpr_token_binary_ (t);
13811     }
13812
13813   ffeexpr_tokens_[3] = ffelex_token_use (t);
13814   return (ffelexHandler) ffeexpr_token_real_exp_sign_;
13815 }
13816
13817 /* ffeexpr_token_real_exp_sign_ -- Rhs PERIOD NUMBER NAME(D,E,Q) PLUS/MINUS
13818
13819    Return a pointer to this function to the lexer (ffelex), which will
13820    invoke it for the next token.
13821
13822    Make sure token is a NUMBER, make a real constant out of all we have and
13823    push it onto the expression stack.  Else issue diagnostic and pretend
13824    exponent field was a zero.  */
13825
13826 static ffelexHandler
13827 ffeexpr_token_real_exp_sign_ (ffelexToken t)
13828 {
13829   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13830     {
13831       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13832         {
13833           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
13834                        ffelex_token_where_column (ffeexpr_tokens_[2]));
13835           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13836           ffebad_finish ();
13837         }
13838
13839       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13840                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13841                                  NULL, NULL, NULL);
13842
13843       ffelex_token_kill (ffeexpr_tokens_[0]);
13844       ffelex_token_kill (ffeexpr_tokens_[1]);
13845       ffelex_token_kill (ffeexpr_tokens_[2]);
13846       ffelex_token_kill (ffeexpr_tokens_[3]);
13847       return (ffelexHandler) ffeexpr_token_binary_ (t);
13848     }
13849
13850   ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0], NULL,
13851                  ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2],
13852                              ffeexpr_tokens_[3], t);
13853
13854   ffelex_token_kill (ffeexpr_tokens_[0]);
13855   ffelex_token_kill (ffeexpr_tokens_[1]);
13856   ffelex_token_kill (ffeexpr_tokens_[2]);
13857   ffelex_token_kill (ffeexpr_tokens_[3]);
13858   return (ffelexHandler) ffeexpr_token_binary_;
13859 }
13860
13861 /* ffeexpr_token_number_ -- Rhs NUMBER
13862
13863    Return a pointer to this function to the lexer (ffelex), which will
13864    invoke it for the next token.
13865
13866    If the token is a period, we may have a floating-point number, or an
13867    integer followed by a dotdot binary operator.  If the token is a name
13868    beginning with D, E, or Q, we definitely have a floating-point number.
13869    If the token is a hollerith constant, that's what we've got, so push
13870    it onto the expression stack and continue with the binary state.
13871
13872    Otherwise, we have an integer followed by something the binary state
13873    should be able to swallow.  */
13874
13875 static ffelexHandler
13876 ffeexpr_token_number_ (ffelexToken t)
13877 {
13878   ffeexprExpr_ e;
13879   ffeinfo ni;
13880   char d;
13881   const char *p;
13882
13883   if (ffeexpr_hollerith_count_ > 0)
13884     ffelex_set_expecting_hollerith (0, '\0',
13885                                     ffewhere_line_unknown (),
13886                                     ffewhere_column_unknown ());
13887
13888   /* See if we've got a floating-point number here. */
13889
13890   switch (ffelex_token_type (t))
13891     {
13892     case FFELEX_typeNAME:
13893     case FFELEX_typeNAMES:
13894       if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13895                                    'D', 'd')
13896            || ffesrc_char_match_init (d, 'E', 'e')
13897            || ffesrc_char_match_init (d, 'Q', 'q'))
13898           && ffeexpr_isdigits_ (++p))
13899         {
13900
13901           /* Just exponent character by itself?  In which case, PLUS or MINUS
13902              must surely be next, followed by a NUMBER token. */
13903
13904           if (*p == '\0')
13905             {
13906               ffeexpr_tokens_[1] = ffelex_token_use (t);
13907               return (ffelexHandler) ffeexpr_token_number_exponent_;
13908             }
13909           ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], NULL, NULL, t,
13910                                      NULL, NULL);
13911
13912           ffelex_token_kill (ffeexpr_tokens_[0]);
13913           return (ffelexHandler) ffeexpr_token_binary_;
13914         }
13915       break;
13916
13917     case FFELEX_typePERIOD:
13918       ffeexpr_tokens_[1] = ffelex_token_use (t);
13919       return (ffelexHandler) ffeexpr_token_number_period_;
13920
13921     case FFELEX_typeHOLLERITH:
13922       e = ffeexpr_expr_new_ ();
13923       e->type = FFEEXPR_exprtypeOPERAND_;
13924       e->token = ffeexpr_tokens_[0];
13925       e->u.operand = ffebld_new_conter (ffebld_constant_new_hollerith (t));
13926       ni = ffeinfo_new (FFEINFO_basictypeHOLLERITH, FFEINFO_kindtypeNONE,
13927                         0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
13928                         ffelex_token_length (t));
13929       ffebld_set_info (e->u.operand, ni);
13930       ffeexpr_exprstack_push_operand_ (e);
13931       return (ffelexHandler) ffeexpr_token_binary_;
13932
13933     default:
13934       break;
13935     }
13936
13937   /* Nothing specific we were looking for, so make an integer and pass the
13938      current token to the binary state. */
13939
13940   ffeexpr_make_float_const_ ('I', ffeexpr_tokens_[0], NULL, NULL,
13941                              NULL, NULL, NULL);
13942   return (ffelexHandler) ffeexpr_token_binary_ (t);
13943 }
13944
13945 /* ffeexpr_token_number_exponent_ -- Rhs NUMBER NAME(D, E, or Q)
13946
13947    Return a pointer to this function to the lexer (ffelex), which will
13948    invoke it for the next token.
13949
13950    Ensures this token is PLUS or MINUS, preserves it, goes to final state
13951    for real number (exponent digits).  Else treats number as integer, passes
13952    name to binary, passes current token to subsequent handler.  */
13953
13954 static ffelexHandler
13955 ffeexpr_token_number_exponent_ (ffelexToken t)
13956 {
13957   if ((ffelex_token_type (t) != FFELEX_typePLUS)
13958       && (ffelex_token_type (t) != FFELEX_typeMINUS))
13959     {
13960       ffeexprExpr_ e;
13961       ffelexHandler nexthandler;
13962
13963       e = ffeexpr_expr_new_ ();
13964       e->type = FFEEXPR_exprtypeOPERAND_;
13965       e->token = ffeexpr_tokens_[0];
13966       e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
13967                                         (ffeexpr_tokens_[0]));
13968       ffebld_set_info (e->u.operand,
13969       ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT,
13970                    0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13971       ffeexpr_exprstack_push_operand_ (e);
13972       nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[1]);
13973       ffelex_token_kill (ffeexpr_tokens_[1]);
13974       return (ffelexHandler) (*nexthandler) (t);
13975     }
13976
13977   ffeexpr_tokens_[2] = ffelex_token_use (t);
13978   return (ffelexHandler) ffeexpr_token_number_exp_sign_;
13979 }
13980
13981 /* ffeexpr_token_number_exp_sign_ -- Rhs NUMBER NAME(D,E,Q) PLUS/MINUS
13982
13983    Return a pointer to this function to the lexer (ffelex), which will
13984    invoke it for the next token.
13985
13986    Make sure token is a NUMBER, make a real constant out of all we have and
13987    push it onto the expression stack.  Else issue diagnostic and pretend
13988    exponent field was a zero.  */
13989
13990 static ffelexHandler
13991 ffeexpr_token_number_exp_sign_ (ffelexToken t)
13992 {
13993   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13994     {
13995       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13996         {
13997           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[1]),
13998                        ffelex_token_where_column (ffeexpr_tokens_[1]));
13999           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14000           ffebad_finish ();
14001         }
14002
14003       ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
14004                                  ffeexpr_tokens_[0], NULL, NULL,
14005                                  ffeexpr_tokens_[1], ffeexpr_tokens_[2],
14006                                  NULL);
14007
14008       ffelex_token_kill (ffeexpr_tokens_[0]);
14009       ffelex_token_kill (ffeexpr_tokens_[1]);
14010       ffelex_token_kill (ffeexpr_tokens_[2]);
14011       return (ffelexHandler) ffeexpr_token_binary_ (t);
14012     }
14013
14014   ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
14015                              ffeexpr_tokens_[0], NULL, NULL,
14016                              ffeexpr_tokens_[1], ffeexpr_tokens_[2], t);
14017
14018   ffelex_token_kill (ffeexpr_tokens_[0]);
14019   ffelex_token_kill (ffeexpr_tokens_[1]);
14020   ffelex_token_kill (ffeexpr_tokens_[2]);
14021   return (ffelexHandler) ffeexpr_token_binary_;
14022 }
14023
14024 /* ffeexpr_token_number_period_ -- Rhs NUMBER PERIOD
14025
14026    Return a pointer to this function to the lexer (ffelex), which will
14027    invoke it for the next token.
14028
14029    Handle a period detected following a number at rhs state.  Must begin a
14030    floating-point value (as in 1., 1.2, 1.E3, or 1.E+3) or a dot-dot name.  */
14031
14032 static ffelexHandler
14033 ffeexpr_token_number_period_ (ffelexToken t)
14034 {
14035   ffeexprExpr_ e;
14036   ffelexHandler nexthandler;
14037   const char *p;
14038   char d;
14039
14040   switch (ffelex_token_type (t))
14041     {
14042     case FFELEX_typeNAME:
14043     case FFELEX_typeNAMES:
14044       if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
14045                                    'D', 'd')
14046            || ffesrc_char_match_init (d, 'E', 'e')
14047            || ffesrc_char_match_init (d, 'Q', 'q'))
14048           && ffeexpr_isdigits_ (++p))
14049         {
14050
14051           /* Just exponent character by itself?  In which case, PLUS or MINUS
14052              must surely be next, followed by a NUMBER token. */
14053
14054           if (*p == '\0')
14055             {
14056               ffeexpr_tokens_[2] = ffelex_token_use (t);
14057               return (ffelexHandler) ffeexpr_token_number_per_exp_;
14058             }
14059           ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0],
14060                                      ffeexpr_tokens_[1], NULL, t, NULL,
14061                                      NULL);
14062
14063           ffelex_token_kill (ffeexpr_tokens_[0]);
14064           ffelex_token_kill (ffeexpr_tokens_[1]);
14065           return (ffelexHandler) ffeexpr_token_binary_;
14066         }
14067       /* A name not representing an exponent, so assume it will be something
14068          like EQ, make an integer from the number, pass the period to binary
14069          state and the current token to the resulting state. */
14070
14071       e = ffeexpr_expr_new_ ();
14072       e->type = FFEEXPR_exprtypeOPERAND_;
14073       e->token = ffeexpr_tokens_[0];
14074       e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
14075                                         (ffeexpr_tokens_[0]));
14076       ffebld_set_info (e->u.operand,
14077                        ffeinfo_new (FFEINFO_basictypeINTEGER,
14078                                     FFEINFO_kindtypeINTEGERDEFAULT, 0,
14079                                   FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14080                                     FFETARGET_charactersizeNONE));
14081       ffeexpr_exprstack_push_operand_ (e);
14082       nexthandler = (ffelexHandler) ffeexpr_token_binary_
14083         (ffeexpr_tokens_[1]);
14084       ffelex_token_kill (ffeexpr_tokens_[1]);
14085       return (ffelexHandler) (*nexthandler) (t);
14086
14087     case FFELEX_typeNUMBER:
14088       ffeexpr_tokens_[2] = ffelex_token_use (t);
14089       return (ffelexHandler) ffeexpr_token_number_real_;
14090
14091     default:
14092       break;
14093     }
14094
14095   /* Nothing specific we were looking for, so make a real number and pass the
14096      period and then the current token to the binary state. */
14097
14098   ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14099                              ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14100                              NULL, NULL, NULL, NULL);
14101
14102   ffelex_token_kill (ffeexpr_tokens_[0]);
14103   ffelex_token_kill (ffeexpr_tokens_[1]);
14104   return (ffelexHandler) ffeexpr_token_binary_ (t);
14105 }
14106
14107 /* ffeexpr_token_number_per_exp_ -- Rhs NUMBER PERIOD NAME(D, E, or Q)
14108
14109    Return a pointer to this function to the lexer (ffelex), which will
14110    invoke it for the next token.
14111
14112    Ensures this token is PLUS or MINUS, preserves it, goes to final state
14113    for real number (exponent digits).  Else treats number as real, passes
14114    name to binary, passes current token to subsequent handler.  */
14115
14116 static ffelexHandler
14117 ffeexpr_token_number_per_exp_ (ffelexToken t)
14118 {
14119   if ((ffelex_token_type (t) != FFELEX_typePLUS)
14120       && (ffelex_token_type (t) != FFELEX_typeMINUS))
14121     {
14122       ffelexHandler nexthandler;
14123
14124       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14125                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14126                                  NULL, NULL, NULL, NULL);
14127
14128       ffelex_token_kill (ffeexpr_tokens_[0]);
14129       ffelex_token_kill (ffeexpr_tokens_[1]);
14130       nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[2]);
14131       ffelex_token_kill (ffeexpr_tokens_[2]);
14132       return (ffelexHandler) (*nexthandler) (t);
14133     }
14134
14135   ffeexpr_tokens_[3] = ffelex_token_use (t);
14136   return (ffelexHandler) ffeexpr_token_num_per_exp_sign_;
14137 }
14138
14139 /* ffeexpr_token_number_real_ -- Rhs NUMBER PERIOD NUMBER
14140
14141    Return a pointer to this function to the lexer (ffelex), which will
14142    invoke it for the next token.
14143
14144    After a number, period, and number, check next token for possible
14145    exponent designation (D, E, or Q as first/only character) and continue
14146    real-number handling accordingly.  Else form basic real constant, push
14147    onto expression stack, and enter binary state using current token (which,
14148    if it is a name not beginning with D, E, or Q, will certainly result
14149    in an error, but that's not for this routine to deal with).  */
14150
14151 static ffelexHandler
14152 ffeexpr_token_number_real_ (ffelexToken t)
14153 {
14154   char d;
14155   const char *p;
14156
14157   if (((ffelex_token_type (t) != FFELEX_typeNAME)
14158        && (ffelex_token_type (t) != FFELEX_typeNAMES))
14159       || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
14160                                      'D', 'd')
14161              || ffesrc_char_match_init (d, 'E', 'e')
14162              || ffesrc_char_match_init (d, 'Q', 'q')))
14163            && ffeexpr_isdigits_ (++p)))
14164     {
14165 #if 0
14166       /* This code has been removed because it seems inconsistent to
14167          produce a diagnostic in this case, but not all of the other
14168          ones that look for an exponent and cannot recognize one.  */
14169       if (((ffelex_token_type (t) == FFELEX_typeNAME)
14170            || (ffelex_token_type (t) == FFELEX_typeNAMES))
14171           && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
14172         {
14173           char bad[2];
14174
14175           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14176           ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
14177                        ffelex_token_where_column (ffeexpr_tokens_[0]));
14178           bad[0] = *(p - 1);
14179           bad[1] = '\0';
14180           ffebad_string (bad);
14181           ffebad_finish ();
14182         }
14183 #endif
14184       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14185                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14186                                  ffeexpr_tokens_[2], NULL, NULL, NULL);
14187
14188       ffelex_token_kill (ffeexpr_tokens_[0]);
14189       ffelex_token_kill (ffeexpr_tokens_[1]);
14190       ffelex_token_kill (ffeexpr_tokens_[2]);
14191       return (ffelexHandler) ffeexpr_token_binary_ (t);
14192     }
14193
14194   /* Just exponent character by itself?  In which case, PLUS or MINUS must
14195      surely be next, followed by a NUMBER token. */
14196
14197   if (*p == '\0')
14198     {
14199       ffeexpr_tokens_[3] = ffelex_token_use (t);
14200       return (ffelexHandler) ffeexpr_token_number_real_exp_;
14201     }
14202
14203   ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14204                              ffeexpr_tokens_[2], t, NULL, NULL);
14205
14206   ffelex_token_kill (ffeexpr_tokens_[0]);
14207   ffelex_token_kill (ffeexpr_tokens_[1]);
14208   ffelex_token_kill (ffeexpr_tokens_[2]);
14209   return (ffelexHandler) ffeexpr_token_binary_;
14210 }
14211
14212 /* ffeexpr_token_num_per_exp_sign_ -- Rhs NUMBER PERIOD NAME(D,E,Q) PLUS/MINUS
14213
14214    Return a pointer to this function to the lexer (ffelex), which will
14215    invoke it for the next token.
14216
14217    Make sure token is a NUMBER, make a real constant out of all we have and
14218    push it onto the expression stack.  Else issue diagnostic and pretend
14219    exponent field was a zero.  */
14220
14221 static ffelexHandler
14222 ffeexpr_token_num_per_exp_sign_ (ffelexToken t)
14223 {
14224   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14225     {
14226       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14227         {
14228           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
14229                        ffelex_token_where_column (ffeexpr_tokens_[2]));
14230           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14231           ffebad_finish ();
14232         }
14233
14234       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14235                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14236                                  NULL, NULL, NULL, NULL);
14237
14238       ffelex_token_kill (ffeexpr_tokens_[0]);
14239       ffelex_token_kill (ffeexpr_tokens_[1]);
14240       ffelex_token_kill (ffeexpr_tokens_[2]);
14241       ffelex_token_kill (ffeexpr_tokens_[3]);
14242       return (ffelexHandler) ffeexpr_token_binary_ (t);
14243     }
14244
14245   ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0],
14246                              ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL,
14247                              ffeexpr_tokens_[2], ffeexpr_tokens_[3], t);
14248
14249   ffelex_token_kill (ffeexpr_tokens_[0]);
14250   ffelex_token_kill (ffeexpr_tokens_[1]);
14251   ffelex_token_kill (ffeexpr_tokens_[2]);
14252   ffelex_token_kill (ffeexpr_tokens_[3]);
14253   return (ffelexHandler) ffeexpr_token_binary_;
14254 }
14255
14256 /* ffeexpr_token_number_real_exp_ -- Rhs NUMBER PERIOD NUMBER NAME(D, E, or Q)
14257
14258    Return a pointer to this function to the lexer (ffelex), which will
14259    invoke it for the next token.
14260
14261    Ensures this token is PLUS or MINUS, preserves it, goes to final state
14262    for real number (exponent digits).  Else issues diagnostic, assumes a
14263    zero exponent field for number, passes token on to binary state as if
14264    previous token had been "E0" instead of "E", for example.  */
14265
14266 static ffelexHandler
14267 ffeexpr_token_number_real_exp_ (ffelexToken t)
14268 {
14269   if ((ffelex_token_type (t) != FFELEX_typePLUS)
14270       && (ffelex_token_type (t) != FFELEX_typeMINUS))
14271     {
14272       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14273         {
14274           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
14275                        ffelex_token_where_column (ffeexpr_tokens_[3]));
14276           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14277           ffebad_finish ();
14278         }
14279
14280       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14281                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14282                                  ffeexpr_tokens_[2], NULL, NULL, NULL);
14283
14284       ffelex_token_kill (ffeexpr_tokens_[0]);
14285       ffelex_token_kill (ffeexpr_tokens_[1]);
14286       ffelex_token_kill (ffeexpr_tokens_[2]);
14287       ffelex_token_kill (ffeexpr_tokens_[3]);
14288       return (ffelexHandler) ffeexpr_token_binary_ (t);
14289     }
14290
14291   ffeexpr_tokens_[4] = ffelex_token_use (t);
14292   return (ffelexHandler) ffeexpr_token_num_real_exp_sn_;
14293 }
14294
14295 /* ffeexpr_token_num_real_exp_sn_ -- Rhs NUMBER PERIOD NUMBER NAME(D,E,Q)
14296                                   PLUS/MINUS
14297
14298    Return a pointer to this function to the lexer (ffelex), which will
14299    invoke it for the next token.
14300
14301    Make sure token is a NUMBER, make a real constant out of all we have and
14302    push it onto the expression stack.  Else issue diagnostic and pretend
14303    exponent field was a zero.  */
14304
14305 static ffelexHandler
14306 ffeexpr_token_num_real_exp_sn_ (ffelexToken t)
14307 {
14308   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14309     {
14310       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14311         {
14312           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
14313                        ffelex_token_where_column (ffeexpr_tokens_[3]));
14314           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14315           ffebad_finish ();
14316         }
14317
14318       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14319                                  ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14320                                  ffeexpr_tokens_[2], NULL, NULL, NULL);
14321
14322       ffelex_token_kill (ffeexpr_tokens_[0]);
14323       ffelex_token_kill (ffeexpr_tokens_[1]);
14324       ffelex_token_kill (ffeexpr_tokens_[2]);
14325       ffelex_token_kill (ffeexpr_tokens_[3]);
14326       ffelex_token_kill (ffeexpr_tokens_[4]);
14327       return (ffelexHandler) ffeexpr_token_binary_ (t);
14328     }
14329
14330   ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[3])[0],
14331                              ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14332                              ffeexpr_tokens_[2], ffeexpr_tokens_[3],
14333                              ffeexpr_tokens_[4], t);
14334
14335   ffelex_token_kill (ffeexpr_tokens_[0]);
14336   ffelex_token_kill (ffeexpr_tokens_[1]);
14337   ffelex_token_kill (ffeexpr_tokens_[2]);
14338   ffelex_token_kill (ffeexpr_tokens_[3]);
14339   ffelex_token_kill (ffeexpr_tokens_[4]);
14340   return (ffelexHandler) ffeexpr_token_binary_;
14341 }
14342
14343 /* ffeexpr_token_binary_ -- Handle binary operator possibility
14344
14345    Return a pointer to this function to the lexer (ffelex), which will
14346    invoke it for the next token.
14347
14348    The possibility of a binary operator is handled here, meaning the previous
14349    token was an operand.  */
14350
14351 static ffelexHandler
14352 ffeexpr_token_binary_ (ffelexToken t)
14353 {
14354   ffeexprExpr_ e;
14355
14356   if (!ffeexpr_stack_->is_rhs)
14357     return (ffelexHandler) ffeexpr_finished_ (t);       /* For now. */
14358
14359   switch (ffelex_token_type (t))
14360     {
14361     case FFELEX_typePLUS:
14362       e = ffeexpr_expr_new_ ();
14363       e->type = FFEEXPR_exprtypeBINARY_;
14364       e->token = ffelex_token_use (t);
14365       e->u.operator.op = FFEEXPR_operatorADD_;
14366       e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
14367       e->u.operator.as = FFEEXPR_operatorassociativityADD_;
14368       ffeexpr_exprstack_push_binary_ (e);
14369       return (ffelexHandler) ffeexpr_token_rhs_;
14370
14371     case FFELEX_typeMINUS:
14372       e = ffeexpr_expr_new_ ();
14373       e->type = FFEEXPR_exprtypeBINARY_;
14374       e->token = ffelex_token_use (t);
14375       e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
14376       e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
14377       e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
14378       ffeexpr_exprstack_push_binary_ (e);
14379       return (ffelexHandler) ffeexpr_token_rhs_;
14380
14381     case FFELEX_typeASTERISK:
14382       switch (ffeexpr_stack_->context)
14383         {
14384         case FFEEXPR_contextDATA:
14385           return (ffelexHandler) ffeexpr_finished_ (t);
14386
14387         default:
14388           break;
14389         }
14390       e = ffeexpr_expr_new_ ();
14391       e->type = FFEEXPR_exprtypeBINARY_;
14392       e->token = ffelex_token_use (t);
14393       e->u.operator.op = FFEEXPR_operatorMULTIPLY_;
14394       e->u.operator.prec = FFEEXPR_operatorprecedenceMULTIPLY_;
14395       e->u.operator.as = FFEEXPR_operatorassociativityMULTIPLY_;
14396       ffeexpr_exprstack_push_binary_ (e);
14397       return (ffelexHandler) ffeexpr_token_rhs_;
14398
14399     case FFELEX_typeSLASH:
14400       switch (ffeexpr_stack_->context)
14401         {
14402         case FFEEXPR_contextDATA:
14403           return (ffelexHandler) ffeexpr_finished_ (t);
14404
14405         default:
14406           break;
14407         }
14408       e = ffeexpr_expr_new_ ();
14409       e->type = FFEEXPR_exprtypeBINARY_;
14410       e->token = ffelex_token_use (t);
14411       e->u.operator.op = FFEEXPR_operatorDIVIDE_;
14412       e->u.operator.prec = FFEEXPR_operatorprecedenceDIVIDE_;
14413       e->u.operator.as = FFEEXPR_operatorassociativityDIVIDE_;
14414       ffeexpr_exprstack_push_binary_ (e);
14415       return (ffelexHandler) ffeexpr_token_rhs_;
14416
14417     case FFELEX_typePOWER:
14418       e = ffeexpr_expr_new_ ();
14419       e->type = FFEEXPR_exprtypeBINARY_;
14420       e->token = ffelex_token_use (t);
14421       e->u.operator.op = FFEEXPR_operatorPOWER_;
14422       e->u.operator.prec = FFEEXPR_operatorprecedencePOWER_;
14423       e->u.operator.as = FFEEXPR_operatorassociativityPOWER_;
14424       ffeexpr_exprstack_push_binary_ (e);
14425       return (ffelexHandler) ffeexpr_token_rhs_;
14426
14427     case FFELEX_typeCONCAT:
14428       e = ffeexpr_expr_new_ ();
14429       e->type = FFEEXPR_exprtypeBINARY_;
14430       e->token = ffelex_token_use (t);
14431       e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
14432       e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
14433       e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
14434       ffeexpr_exprstack_push_binary_ (e);
14435       return (ffelexHandler) ffeexpr_token_rhs_;
14436
14437     case FFELEX_typeOPEN_ANGLE:
14438       switch (ffeexpr_stack_->context)
14439         {
14440         case FFEEXPR_contextFORMAT:
14441           ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14442           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14443           ffebad_finish ();
14444           break;
14445
14446         default:
14447           break;
14448         }
14449       e = ffeexpr_expr_new_ ();
14450       e->type = FFEEXPR_exprtypeBINARY_;
14451       e->token = ffelex_token_use (t);
14452       e->u.operator.op = FFEEXPR_operatorLT_;
14453       e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
14454       e->u.operator.as = FFEEXPR_operatorassociativityLT_;
14455       ffeexpr_exprstack_push_binary_ (e);
14456       return (ffelexHandler) ffeexpr_token_rhs_;
14457
14458     case FFELEX_typeCLOSE_ANGLE:
14459       switch (ffeexpr_stack_->context)
14460         {
14461         case FFEEXPR_contextFORMAT:
14462           return ffeexpr_finished_ (t);
14463
14464         default:
14465           break;
14466         }
14467       e = ffeexpr_expr_new_ ();
14468       e->type = FFEEXPR_exprtypeBINARY_;
14469       e->token = ffelex_token_use (t);
14470       e->u.operator.op = FFEEXPR_operatorGT_;
14471       e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
14472       e->u.operator.as = FFEEXPR_operatorassociativityGT_;
14473       ffeexpr_exprstack_push_binary_ (e);
14474       return (ffelexHandler) ffeexpr_token_rhs_;
14475
14476     case FFELEX_typeREL_EQ:
14477       switch (ffeexpr_stack_->context)
14478         {
14479         case FFEEXPR_contextFORMAT:
14480           ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14481           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14482           ffebad_finish ();
14483           break;
14484
14485         default:
14486           break;
14487         }
14488       e = ffeexpr_expr_new_ ();
14489       e->type = FFEEXPR_exprtypeBINARY_;
14490       e->token = ffelex_token_use (t);
14491       e->u.operator.op = FFEEXPR_operatorEQ_;
14492       e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
14493       e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
14494       ffeexpr_exprstack_push_binary_ (e);
14495       return (ffelexHandler) ffeexpr_token_rhs_;
14496
14497     case FFELEX_typeREL_NE:
14498       switch (ffeexpr_stack_->context)
14499         {
14500         case FFEEXPR_contextFORMAT:
14501           ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14502           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14503           ffebad_finish ();
14504           break;
14505
14506         default:
14507           break;
14508         }
14509       e = ffeexpr_expr_new_ ();
14510       e->type = FFEEXPR_exprtypeBINARY_;
14511       e->token = ffelex_token_use (t);
14512       e->u.operator.op = FFEEXPR_operatorNE_;
14513       e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
14514       e->u.operator.as = FFEEXPR_operatorassociativityNE_;
14515       ffeexpr_exprstack_push_binary_ (e);
14516       return (ffelexHandler) ffeexpr_token_rhs_;
14517
14518     case FFELEX_typeREL_LE:
14519       switch (ffeexpr_stack_->context)
14520         {
14521         case FFEEXPR_contextFORMAT:
14522           ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14523           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14524           ffebad_finish ();
14525           break;
14526
14527         default:
14528           break;
14529         }
14530       e = ffeexpr_expr_new_ ();
14531       e->type = FFEEXPR_exprtypeBINARY_;
14532       e->token = ffelex_token_use (t);
14533       e->u.operator.op = FFEEXPR_operatorLE_;
14534       e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
14535       e->u.operator.as = FFEEXPR_operatorassociativityLE_;
14536       ffeexpr_exprstack_push_binary_ (e);
14537       return (ffelexHandler) ffeexpr_token_rhs_;
14538
14539     case FFELEX_typeREL_GE:
14540       switch (ffeexpr_stack_->context)
14541         {
14542         case FFEEXPR_contextFORMAT:
14543           ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14544           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14545           ffebad_finish ();
14546           break;
14547
14548         default:
14549           break;
14550         }
14551       e = ffeexpr_expr_new_ ();
14552       e->type = FFEEXPR_exprtypeBINARY_;
14553       e->token = ffelex_token_use (t);
14554       e->u.operator.op = FFEEXPR_operatorGE_;
14555       e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
14556       e->u.operator.as = FFEEXPR_operatorassociativityGE_;
14557       ffeexpr_exprstack_push_binary_ (e);
14558       return (ffelexHandler) ffeexpr_token_rhs_;
14559
14560     case FFELEX_typePERIOD:
14561       ffeexpr_tokens_[0] = ffelex_token_use (t);
14562       return (ffelexHandler) ffeexpr_token_binary_period_;
14563
14564 #if 0
14565     case FFELEX_typeOPEN_PAREN:
14566     case FFELEX_typeCLOSE_PAREN:
14567     case FFELEX_typeEQUALS:
14568     case FFELEX_typePOINTS:
14569     case FFELEX_typeCOMMA:
14570     case FFELEX_typeCOLON:
14571     case FFELEX_typeEOS:
14572     case FFELEX_typeSEMICOLON:
14573     case FFELEX_typeNAME:
14574     case FFELEX_typeNAMES:
14575 #endif
14576     default:
14577       return (ffelexHandler) ffeexpr_finished_ (t);
14578     }
14579 }
14580
14581 /* ffeexpr_token_binary_period_ -- Binary PERIOD
14582
14583    Return a pointer to this function to the lexer (ffelex), which will
14584    invoke it for the next token.
14585
14586    Handle a period detected at binary (expecting binary op or end) state.
14587    Must begin a dot-dot name, of which .NOT., .TRUE., and .FALSE. are not
14588    valid.  */
14589
14590 static ffelexHandler
14591 ffeexpr_token_binary_period_ (ffelexToken t)
14592 {
14593   ffeexprExpr_ operand;
14594
14595   switch (ffelex_token_type (t))
14596     {
14597     case FFELEX_typeNAME:
14598     case FFELEX_typeNAMES:
14599       ffeexpr_current_dotdot_ = ffestr_other (t);
14600       switch (ffeexpr_current_dotdot_)
14601         {
14602         case FFESTR_otherTRUE:
14603         case FFESTR_otherFALSE:
14604         case FFESTR_otherNOT:
14605           if (ffest_ffebad_start (FFEBAD_MISSING_BINARY_OPERATOR))
14606             {
14607               operand = ffeexpr_stack_->exprstack;
14608               assert (operand != NULL);
14609               assert (operand->type == FFEEXPR_exprtypeOPERAND_);
14610               ffebad_here (0, ffelex_token_where_line (operand->token), ffelex_token_where_column (operand->token));
14611               ffebad_here (1, ffelex_token_where_line (t),
14612                            ffelex_token_where_column (t));
14613               ffebad_finish ();
14614             }
14615           ffelex_token_kill (ffeexpr_tokens_[0]);
14616           return (ffelexHandler) ffeexpr_token_binary_sw_per_;
14617
14618         default:
14619           ffeexpr_tokens_[1] = ffelex_token_use (t);
14620           return (ffelexHandler) ffeexpr_token_binary_end_per_;
14621         }
14622       break;                    /* Nothing really reaches here. */
14623
14624     default:
14625       if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
14626         {
14627           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14628                        ffelex_token_where_column (ffeexpr_tokens_[0]));
14629           ffebad_finish ();
14630         }
14631       ffelex_token_kill (ffeexpr_tokens_[0]);
14632       return (ffelexHandler) ffeexpr_token_binary_ (t);
14633     }
14634 }
14635
14636 /* ffeexpr_token_binary_end_per_ -- Binary PERIOD NAME(not NOT, TRUE, or FALSE)
14637
14638    Return a pointer to this function to the lexer (ffelex), which will
14639    invoke it for the next token.
14640
14641    Expecting a period to close a dot-dot at binary (binary op
14642    or operator) state.  If period isn't found, issue a diagnostic but
14643    pretend we saw one.  ffeexpr_current_dotdot_ must already contained the
14644    dotdot representation of the name in between the two PERIOD tokens.  */
14645
14646 static ffelexHandler
14647 ffeexpr_token_binary_end_per_ (ffelexToken t)
14648 {
14649   ffeexprExpr_ e;
14650
14651   e = ffeexpr_expr_new_ ();
14652   e->type = FFEEXPR_exprtypeBINARY_;
14653   e->token = ffeexpr_tokens_[0];
14654
14655   switch (ffeexpr_current_dotdot_)
14656     {
14657     case FFESTR_otherAND:
14658       e->u.operator.op = FFEEXPR_operatorAND_;
14659       e->u.operator.prec = FFEEXPR_operatorprecedenceAND_;
14660       e->u.operator.as = FFEEXPR_operatorassociativityAND_;
14661       break;
14662
14663     case FFESTR_otherOR:
14664       e->u.operator.op = FFEEXPR_operatorOR_;
14665       e->u.operator.prec = FFEEXPR_operatorprecedenceOR_;
14666       e->u.operator.as = FFEEXPR_operatorassociativityOR_;
14667       break;
14668
14669     case FFESTR_otherXOR:
14670       e->u.operator.op = FFEEXPR_operatorXOR_;
14671       e->u.operator.prec = FFEEXPR_operatorprecedenceXOR_;
14672       e->u.operator.as = FFEEXPR_operatorassociativityXOR_;
14673       break;
14674
14675     case FFESTR_otherEQV:
14676       e->u.operator.op = FFEEXPR_operatorEQV_;
14677       e->u.operator.prec = FFEEXPR_operatorprecedenceEQV_;
14678       e->u.operator.as = FFEEXPR_operatorassociativityEQV_;
14679       break;
14680
14681     case FFESTR_otherNEQV:
14682       e->u.operator.op = FFEEXPR_operatorNEQV_;
14683       e->u.operator.prec = FFEEXPR_operatorprecedenceNEQV_;
14684       e->u.operator.as = FFEEXPR_operatorassociativityNEQV_;
14685       break;
14686
14687     case FFESTR_otherLT:
14688       e->u.operator.op = FFEEXPR_operatorLT_;
14689       e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
14690       e->u.operator.as = FFEEXPR_operatorassociativityLT_;
14691       break;
14692
14693     case FFESTR_otherLE:
14694       e->u.operator.op = FFEEXPR_operatorLE_;
14695       e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
14696       e->u.operator.as = FFEEXPR_operatorassociativityLE_;
14697       break;
14698
14699     case FFESTR_otherEQ:
14700       e->u.operator.op = FFEEXPR_operatorEQ_;
14701       e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
14702       e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
14703       break;
14704
14705     case FFESTR_otherNE:
14706       e->u.operator.op = FFEEXPR_operatorNE_;
14707       e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
14708       e->u.operator.as = FFEEXPR_operatorassociativityNE_;
14709       break;
14710
14711     case FFESTR_otherGT:
14712       e->u.operator.op = FFEEXPR_operatorGT_;
14713       e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
14714       e->u.operator.as = FFEEXPR_operatorassociativityGT_;
14715       break;
14716
14717     case FFESTR_otherGE:
14718       e->u.operator.op = FFEEXPR_operatorGE_;
14719       e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
14720       e->u.operator.as = FFEEXPR_operatorassociativityGE_;
14721       break;
14722
14723     default:
14724       if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT))
14725         {
14726           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14727                        ffelex_token_where_column (ffeexpr_tokens_[0]));
14728           ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
14729           ffebad_finish ();
14730         }
14731       e->u.operator.op = FFEEXPR_operatorEQ_;
14732       e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
14733       e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
14734       break;
14735     }
14736
14737   ffeexpr_exprstack_push_binary_ (e);
14738
14739   if (ffelex_token_type (t) != FFELEX_typePERIOD)
14740     {
14741       if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
14742         {
14743           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14744                        ffelex_token_where_column (ffeexpr_tokens_[0]));
14745           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14746           ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
14747           ffebad_finish ();
14748         }
14749       ffelex_token_kill (ffeexpr_tokens_[1]);   /* Kill dot-dot token. */
14750       return (ffelexHandler) ffeexpr_token_rhs_ (t);
14751     }
14752
14753   ffelex_token_kill (ffeexpr_tokens_[1]);       /* Kill dot-dot token. */
14754   return (ffelexHandler) ffeexpr_token_rhs_;
14755 }
14756
14757 /* ffeexpr_token_binary_sw_per_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
14758
14759    Return a pointer to this function to the lexer (ffelex), which will
14760    invoke it for the next token.
14761
14762    A diagnostic has already been issued; just swallow a period if there is
14763    one, then continue with ffeexpr_token_binary_.  */
14764
14765 static ffelexHandler
14766 ffeexpr_token_binary_sw_per_ (ffelexToken t)
14767 {
14768   if (ffelex_token_type (t) != FFELEX_typePERIOD)
14769     return (ffelexHandler) ffeexpr_token_binary_ (t);
14770
14771   return (ffelexHandler) ffeexpr_token_binary_;
14772 }
14773
14774 /* ffeexpr_token_quote_ -- Rhs QUOTE
14775
14776    Return a pointer to this function to the lexer (ffelex), which will
14777    invoke it for the next token.
14778
14779    Expecting a NUMBER that we'll treat as an octal integer.  */
14780
14781 static ffelexHandler
14782 ffeexpr_token_quote_ (ffelexToken t)
14783 {
14784   ffeexprExpr_ e;
14785   ffebld anyexpr;
14786
14787   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14788     {
14789       if (ffest_ffebad_start (FFEBAD_QUOTE_MISSES_DIGITS))
14790         {
14791           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14792                        ffelex_token_where_column (ffeexpr_tokens_[0]));
14793           ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14794           ffebad_finish ();
14795         }
14796       ffelex_token_kill (ffeexpr_tokens_[0]);
14797       return (ffelexHandler) ffeexpr_token_rhs_ (t);
14798     }
14799
14800   /* This is kind of a kludge to prevent any whining about magical numbers
14801      that start out as these octal integers, so "20000000000 (on a 32-bit
14802      2's-complement machine) by itself won't produce an error. */
14803
14804   anyexpr = ffebld_new_any ();
14805   ffebld_set_info (anyexpr, ffeinfo_new_any ());
14806
14807   e = ffeexpr_expr_new_ ();
14808   e->type = FFEEXPR_exprtypeOPERAND_;
14809   e->token = ffeexpr_tokens_[0];
14810   e->u.operand = ffebld_new_conter_with_orig
14811     (ffebld_constant_new_integeroctal (t), anyexpr);
14812   ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER,
14813                       FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY,
14814                        FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14815   ffeexpr_exprstack_push_operand_ (e);
14816   return (ffelexHandler) ffeexpr_token_binary_;
14817 }
14818
14819 /* ffeexpr_token_apostrophe_ -- Rhs APOSTROPHE
14820
14821    Return a pointer to this function to the lexer (ffelex), which will
14822    invoke it for the next token.
14823
14824    Handle an open-apostrophe, which begins either a character ('char-const'),
14825    typeless octal ('octal-const'O), or typeless hexadecimal ('hex-const'Z or
14826    'hex-const'X) constant.  */
14827
14828 static ffelexHandler
14829 ffeexpr_token_apostrophe_ (ffelexToken t)
14830 {
14831   assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
14832   if (ffe_is_pedantic_not_90 () && (ffelex_token_length (t) == 0))
14833     {
14834       ffebad_start (FFEBAD_NULL_CHAR_CONST);
14835       ffebad_here (0, ffelex_token_where_line (t),
14836                    ffelex_token_where_column (t));
14837       ffebad_finish ();
14838     }
14839   ffeexpr_tokens_[1] = ffelex_token_use (t);
14840   return (ffelexHandler) ffeexpr_token_apos_char_;
14841 }
14842
14843 /* ffeexpr_token_apos_char_ -- Rhs APOSTROPHE CHARACTER
14844
14845    Return a pointer to this function to the lexer (ffelex), which will
14846    invoke it for the next token.
14847
14848    Close-apostrophe is implicit; if this token is NAME, it is a possible
14849    typeless-constant radix specifier.  */
14850
14851 static ffelexHandler
14852 ffeexpr_token_apos_char_ (ffelexToken t)
14853 {
14854   ffeexprExpr_ e;
14855   ffeinfo ni;
14856   char c;
14857   ffetargetCharacterSize size;
14858
14859   if ((ffelex_token_type (t) == FFELEX_typeNAME)
14860       || (ffelex_token_type (t) == FFELEX_typeNAMES))
14861     {
14862       if ((ffelex_token_length (t) == 1)
14863           && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]), 'B',
14864                                       'b')
14865               || ffesrc_char_match_init (c, 'O', 'o')
14866               || ffesrc_char_match_init (c, 'X', 'x')
14867               || ffesrc_char_match_init (c, 'Z', 'z')))
14868         {
14869           e = ffeexpr_expr_new_ ();
14870           e->type = FFEEXPR_exprtypeOPERAND_;
14871           e->token = ffeexpr_tokens_[0];
14872           switch (c)
14873             {
14874             case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
14875               e->u.operand = ffebld_new_conter
14876                 (ffebld_constant_new_typeless_bv (ffeexpr_tokens_[1]));
14877               size = ffetarget_size_typeless_binary (ffeexpr_tokens_[1]);
14878               break;
14879
14880             case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
14881               e->u.operand = ffebld_new_conter
14882                 (ffebld_constant_new_typeless_ov (ffeexpr_tokens_[1]));
14883               size = ffetarget_size_typeless_octal (ffeexpr_tokens_[1]);
14884               break;
14885
14886             case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
14887               e->u.operand = ffebld_new_conter
14888                 (ffebld_constant_new_typeless_hxv (ffeexpr_tokens_[1]));
14889               size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
14890               break;
14891
14892             case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
14893               e->u.operand = ffebld_new_conter
14894                 (ffebld_constant_new_typeless_hzv (ffeexpr_tokens_[1]));
14895               size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
14896               break;
14897
14898             default:
14899             no_match:           /* :::::::::::::::::::: */
14900               assert ("not BOXZ!" == NULL);
14901               size = 0;
14902               break;
14903             }
14904           ffebld_set_info (e->u.operand,
14905                ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
14906                        0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
14907           ffeexpr_exprstack_push_operand_ (e);
14908           ffelex_token_kill (ffeexpr_tokens_[1]);
14909           return (ffelexHandler) ffeexpr_token_binary_;
14910         }
14911     }
14912   e = ffeexpr_expr_new_ ();
14913   e->type = FFEEXPR_exprtypeOPERAND_;
14914   e->token = ffeexpr_tokens_[0];
14915   e->u.operand = ffebld_new_conter (ffebld_constant_new_characterdefault
14916                                     (ffeexpr_tokens_[1]));
14917   ni = ffeinfo_new (FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTERDEFAULT,
14918                     0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14919                     ffelex_token_length (ffeexpr_tokens_[1]));
14920   ffebld_set_info (e->u.operand, ni);
14921   ffelex_token_kill (ffeexpr_tokens_[1]);
14922   ffeexpr_exprstack_push_operand_ (e);
14923   if ((ffelex_token_type (t) == FFELEX_typeNAME)
14924       || (ffelex_token_type (t) == FFELEX_typeNAMES))
14925     {
14926       if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14927         {
14928           ffebad_string (ffelex_token_text (t));
14929           ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14930           ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
14931                        ffelex_token_where_column (ffeexpr_tokens_[0]));
14932           ffebad_finish ();
14933         }
14934       e = ffeexpr_expr_new_ ();
14935       e->type = FFEEXPR_exprtypeBINARY_;
14936       e->token = ffelex_token_use (t);
14937       e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
14938       e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
14939       e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
14940       ffeexpr_exprstack_push_binary_ (e);
14941       return (ffelexHandler) ffeexpr_token_rhs_ (t);
14942     }
14943   ffeexpr_is_substr_ok_ = !ffe_is_pedantic_not_90 ();   /* Allow "'hello'(3:5)". */
14944   return (ffelexHandler) ffeexpr_token_substrp_ (t);
14945 }
14946
14947 /* ffeexpr_token_name_lhs_ -- Lhs NAME
14948
14949    Return a pointer to this function to the lexer (ffelex), which will
14950    invoke it for the next token.
14951
14952    Handle a name followed by open-paren, period (RECORD.MEMBER), percent
14953    (RECORD%MEMBER), or nothing at all.  */
14954
14955 static ffelexHandler
14956 ffeexpr_token_name_lhs_ (ffelexToken t)
14957 {
14958   ffeexprExpr_ e;
14959   ffeexprParenType_ paren_type;
14960   ffesymbol s;
14961   ffebld expr;
14962   ffeinfo info;
14963
14964   switch (ffelex_token_type (t))
14965     {
14966     case FFELEX_typeOPEN_PAREN:
14967       switch (ffeexpr_stack_->context)
14968         {
14969         case FFEEXPR_contextASSIGN:
14970         case FFEEXPR_contextAGOTO:
14971         case FFEEXPR_contextFILEUNIT_DF:
14972           goto just_name;       /* :::::::::::::::::::: */
14973
14974         default:
14975           break;
14976         }
14977       e = ffeexpr_expr_new_ ();
14978       e->type = FFEEXPR_exprtypeOPERAND_;
14979       e->token = ffelex_token_use (ffeexpr_tokens_[0]);
14980       s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], FALSE,
14981                                           &paren_type);
14982
14983       switch (ffesymbol_where (s))
14984         {
14985         case FFEINFO_whereLOCAL:
14986           if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14987             ffesymbol_error (s, ffeexpr_tokens_[0]);    /* Recursion. */
14988           break;
14989
14990         case FFEINFO_whereINTRINSIC:
14991         case FFEINFO_whereGLOBAL:
14992           if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
14993             ffesymbol_error (s, ffeexpr_tokens_[0]);    /* Can call intrin. */
14994           break;
14995
14996         case FFEINFO_whereCOMMON:
14997         case FFEINFO_whereDUMMY:
14998         case FFEINFO_whereRESULT:
14999           break;
15000
15001         case FFEINFO_whereNONE:
15002         case FFEINFO_whereANY:
15003           break;
15004
15005         default:
15006           ffesymbol_error (s, ffeexpr_tokens_[0]);
15007           break;
15008         }
15009
15010       if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15011         {
15012           e->u.operand = ffebld_new_any ();
15013           ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15014         }
15015       else
15016         {
15017           e->u.operand = ffebld_new_symter (s,
15018                                             ffesymbol_generic (s),
15019                                             ffesymbol_specific (s),
15020                                             ffesymbol_implementation (s));
15021           ffebld_set_info (e->u.operand, ffesymbol_info (s));
15022         }
15023       ffeexpr_exprstack_push_ (e);      /* Not a complete operand yet. */
15024       ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
15025       switch (paren_type)
15026         {
15027         case FFEEXPR_parentypeSUBROUTINE_:
15028           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15029           return
15030             (ffelexHandler)
15031             ffeexpr_rhs (ffeexpr_stack_->pool,
15032                          FFEEXPR_contextACTUALARG_,
15033                          ffeexpr_token_arguments_);
15034
15035         case FFEEXPR_parentypeARRAY_:
15036           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15037           ffeexpr_stack_->bound_list = ffesymbol_dims (s);
15038           ffeexpr_stack_->rank = 0;
15039           ffeexpr_stack_->constant = TRUE;
15040           ffeexpr_stack_->immediate = TRUE;
15041           switch (ffeexpr_stack_->context)
15042             {
15043             case FFEEXPR_contextDATAIMPDOITEM_:
15044               return
15045                 (ffelexHandler)
15046                 ffeexpr_rhs (ffeexpr_stack_->pool,
15047                              FFEEXPR_contextDATAIMPDOINDEX_,
15048                              ffeexpr_token_elements_);
15049
15050             case FFEEXPR_contextEQUIVALENCE:
15051               return
15052                 (ffelexHandler)
15053                 ffeexpr_rhs (ffeexpr_stack_->pool,
15054                              FFEEXPR_contextEQVINDEX_,
15055                              ffeexpr_token_elements_);
15056
15057             default:
15058               return
15059                 (ffelexHandler)
15060                 ffeexpr_rhs (ffeexpr_stack_->pool,
15061                              FFEEXPR_contextINDEX_,
15062                              ffeexpr_token_elements_);
15063             }
15064
15065         case FFEEXPR_parentypeSUBSTRING_:
15066           e->u.operand = ffeexpr_collapse_symter (e->u.operand,
15067                                                   ffeexpr_tokens_[0]);
15068           return
15069             (ffelexHandler)
15070             ffeexpr_rhs (ffeexpr_stack_->pool,
15071                          FFEEXPR_contextINDEX_,
15072                          ffeexpr_token_substring_);
15073
15074         case FFEEXPR_parentypeEQUIVALENCE_:
15075           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15076           ffeexpr_stack_->bound_list = ffesymbol_dims (s);
15077           ffeexpr_stack_->rank = 0;
15078           ffeexpr_stack_->constant = TRUE;
15079           ffeexpr_stack_->immediate = TRUE;
15080           return
15081             (ffelexHandler)
15082             ffeexpr_rhs (ffeexpr_stack_->pool,
15083                          FFEEXPR_contextEQVINDEX_,
15084                          ffeexpr_token_equivalence_);
15085
15086         case FFEEXPR_parentypeFUNCTION_:        /* Invalid case. */
15087         case FFEEXPR_parentypeFUNSUBSTR_:       /* Invalid case. */
15088           ffesymbol_error (s, ffeexpr_tokens_[0]);
15089           /* Fall through. */
15090         case FFEEXPR_parentypeANY_:
15091           e->u.operand = ffebld_new_any ();
15092           ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15093           return
15094             (ffelexHandler)
15095             ffeexpr_rhs (ffeexpr_stack_->pool,
15096                          FFEEXPR_contextACTUALARG_,
15097                          ffeexpr_token_anything_);
15098
15099         default:
15100           assert ("bad paren type" == NULL);
15101           break;
15102         }
15103
15104     case FFELEX_typeEQUALS:     /* As in "VAR=". */
15105       switch (ffeexpr_stack_->context)
15106         {
15107         case FFEEXPR_contextIMPDOITEM_: /* within
15108                                                    "(,VAR=start,end[,incr])". */
15109         case FFEEXPR_contextIMPDOITEMDF_:
15110           ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
15111           break;
15112
15113         case FFEEXPR_contextDATAIMPDOITEM_:
15114           ffeexpr_stack_->context = FFEEXPR_contextDATAIMPDOCTRL_;
15115           break;
15116
15117         default:
15118           break;
15119         }
15120       break;
15121
15122 #if 0
15123     case FFELEX_typePERIOD:
15124     case FFELEX_typePERCENT:
15125       assert ("FOO%, FOO. not yet supported!~~" == NULL);
15126       break;
15127 #endif
15128
15129     default:
15130       break;
15131     }
15132
15133 just_name:                      /* :::::::::::::::::::: */
15134   e = ffeexpr_expr_new_ ();
15135   e->type = FFEEXPR_exprtypeOPERAND_;
15136   e->token = ffeexpr_tokens_[0];
15137   s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0],
15138                                   (ffeexpr_stack_->context
15139                                    == FFEEXPR_contextSUBROUTINEREF));
15140
15141   switch (ffesymbol_where (s))
15142     {
15143     case FFEINFO_whereCONSTANT:
15144       if ((ffeexpr_stack_->context != FFEEXPR_contextPARAMETER)
15145           || (ffesymbol_kind (s) != FFEINFO_kindENTITY))
15146         ffesymbol_error (s, ffeexpr_tokens_[0]);
15147       break;
15148
15149     case FFEINFO_whereIMMEDIATE:
15150       if ((ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOCTRL_)
15151           && (ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOINDEX_))
15152         ffesymbol_error (s, ffeexpr_tokens_[0]);
15153       break;
15154
15155     case FFEINFO_whereLOCAL:
15156       if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
15157         ffesymbol_error (s, ffeexpr_tokens_[0]);        /* Recurse!. */
15158       break;
15159
15160     case FFEINFO_whereINTRINSIC:
15161       if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
15162         ffesymbol_error (s, ffeexpr_tokens_[0]);        /* Can call intrin. */
15163       break;
15164
15165     default:
15166       break;
15167     }
15168
15169   if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15170     {
15171       expr = ffebld_new_any ();
15172       info = ffeinfo_new_any ();
15173       ffebld_set_info (expr, info);
15174     }
15175   else
15176     {
15177       expr = ffebld_new_symter (s,
15178                                 ffesymbol_generic (s),
15179                                 ffesymbol_specific (s),
15180                                 ffesymbol_implementation (s));
15181       info = ffesymbol_info (s);
15182       ffebld_set_info (expr, info);
15183       if (ffesymbol_is_doiter (s))
15184         {
15185           ffebad_start (FFEBAD_DOITER);
15186           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15187                        ffelex_token_where_column (ffeexpr_tokens_[0]));
15188           ffest_ffebad_here_doiter (1, s);
15189           ffebad_string (ffesymbol_text (s));
15190           ffebad_finish ();
15191         }
15192       expr = ffeexpr_collapse_symter (expr, ffeexpr_tokens_[0]);
15193     }
15194
15195   if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
15196     {
15197       if (ffebld_op (expr) == FFEBLD_opANY)
15198         {
15199           expr = ffebld_new_any ();
15200           ffebld_set_info (expr, ffeinfo_new_any ());
15201         }
15202       else
15203         {
15204           expr = ffebld_new_subrref (expr, NULL);       /* No argument list. */
15205           if (ffesymbol_generic (s) != FFEINTRIN_genNONE)
15206             ffeintrin_fulfill_generic (&expr, &info, e->token);
15207           else if (ffesymbol_specific (s) != FFEINTRIN_specNONE)
15208             ffeintrin_fulfill_specific (&expr, &info, NULL, e->token);
15209           else
15210             ffeexpr_fulfill_call_ (&expr, e->token);
15211
15212           if (ffebld_op (expr) != FFEBLD_opANY)
15213             ffebld_set_info (expr,
15214                              ffeinfo_new (ffeinfo_basictype (info),
15215                                           ffeinfo_kindtype (info),
15216                                           0,
15217                                           FFEINFO_kindENTITY,
15218                                           FFEINFO_whereFLEETING,
15219                                           ffeinfo_size (info)));
15220           else
15221             ffebld_set_info (expr, ffeinfo_new_any ());
15222         }
15223     }
15224
15225   e->u.operand = expr;
15226   ffeexpr_exprstack_push_operand_ (e);
15227   return (ffelexHandler) ffeexpr_finished_ (t);
15228 }
15229
15230 /* ffeexpr_token_name_arg_ -- Rhs NAME
15231
15232    Return a pointer to this function to the lexer (ffelex), which will
15233    invoke it for the next token.
15234
15235    Handle first token in an actual-arg (or possible actual-arg) context
15236    being a NAME, and use second token to refine the context.  */
15237
15238 static ffelexHandler
15239 ffeexpr_token_name_arg_ (ffelexToken t)
15240 {
15241   switch (ffelex_token_type (t))
15242     {
15243     case FFELEX_typeCLOSE_PAREN:
15244     case FFELEX_typeCOMMA:
15245       switch (ffeexpr_stack_->context)
15246         {
15247         case FFEEXPR_contextINDEXORACTUALARG_:
15248           ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
15249           break;
15250
15251         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15252           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
15253           break;
15254
15255         default:
15256           break;
15257         }
15258       break;
15259
15260     default:
15261       switch (ffeexpr_stack_->context)
15262         {
15263         case FFEEXPR_contextACTUALARG_:
15264           ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
15265           break;
15266
15267         case FFEEXPR_contextINDEXORACTUALARG_:
15268           ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
15269           break;
15270
15271         case FFEEXPR_contextSFUNCDEFACTUALARG_:
15272           ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
15273           break;
15274
15275         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15276           ffeexpr_stack_->context
15277             = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
15278           break;
15279
15280         default:
15281           assert ("bad context in _name_arg_" == NULL);
15282           break;
15283         }
15284       break;
15285     }
15286
15287   return (ffelexHandler) ffeexpr_token_name_rhs_ (t);
15288 }
15289
15290 /* ffeexpr_token_name_rhs_ -- Rhs NAME
15291
15292    Return a pointer to this function to the lexer (ffelex), which will
15293    invoke it for the next token.
15294
15295    Handle a name followed by open-paren, apostrophe (O'octal-const',
15296    Z'hex-const', or X'hex-const'), period (RECORD.MEMBER).
15297
15298    26-Nov-91  JCB  1.2
15299       When followed by apostrophe or quote, set lex hexnum flag on so
15300       [0-9] as first char of next token seen as starting a potentially
15301       hex number (NAME).
15302    04-Oct-91  JCB  1.1
15303       In case of intrinsic, decorate its SYMTER with the type info for
15304       the specific intrinsic.  */
15305
15306 static ffelexHandler
15307 ffeexpr_token_name_rhs_ (ffelexToken t)
15308 {
15309   ffeexprExpr_ e;
15310   ffeexprParenType_ paren_type;
15311   ffesymbol s;
15312   bool sfdef;
15313
15314   switch (ffelex_token_type (t))
15315     {
15316     case FFELEX_typeQUOTE:
15317     case FFELEX_typeAPOSTROPHE:
15318       ffeexpr_tokens_[1] = ffelex_token_use (t);
15319       ffelex_set_hexnum (TRUE);
15320       return (ffelexHandler) ffeexpr_token_name_apos_;
15321
15322     case FFELEX_typeOPEN_PAREN:
15323       e = ffeexpr_expr_new_ ();
15324       e->type = FFEEXPR_exprtypeOPERAND_;
15325       e->token = ffelex_token_use (ffeexpr_tokens_[0]);
15326       s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], TRUE,
15327                                           &paren_type);
15328       if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15329         e->u.operand = ffebld_new_any ();
15330       else
15331         e->u.operand = ffebld_new_symter (s, ffesymbol_generic (s),
15332                                           ffesymbol_specific (s),
15333                                           ffesymbol_implementation (s));
15334       ffeexpr_exprstack_push_ (e);      /* Not a complete operand yet. */
15335       ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
15336       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15337         {
15338         case FFEEXPR_contextSFUNCDEF:
15339         case FFEEXPR_contextSFUNCDEFINDEX_:
15340         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15341         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15342           sfdef = TRUE;
15343           break;
15344
15345         case FFEEXPR_contextSFUNCDEFACTUALARG_:
15346         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15347           assert ("weird context!" == NULL);
15348           sfdef = FALSE;
15349           break;
15350
15351         default:
15352           sfdef = FALSE;
15353           break;
15354         }
15355       switch (paren_type)
15356         {
15357         case FFEEXPR_parentypeFUNCTION_:
15358           ffebld_set_info (e->u.operand, ffesymbol_info (s));
15359           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15360           if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
15361             {                   /* A statement function. */
15362               ffeexpr_stack_->num_args
15363                 = ffebld_list_length
15364                   (ffeexpr_stack_->next_dummy
15365                    = ffesymbol_dummyargs (s));
15366               ffeexpr_stack_->tokens[1] = NULL; /* !=NULL when > num_args. */
15367             }
15368           else if ((ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
15369                    && !ffe_is_pedantic_not_90 ()
15370                    && ((ffesymbol_implementation (s)
15371                         == FFEINTRIN_impICHAR)
15372                        || (ffesymbol_implementation (s)
15373                            == FFEINTRIN_impIACHAR)
15374                        || (ffesymbol_implementation (s)
15375                            == FFEINTRIN_impLEN)))
15376             {                   /* Allow arbitrary concatenations. */
15377               return
15378                 (ffelexHandler)
15379                   ffeexpr_rhs (ffeexpr_stack_->pool,
15380                                sfdef
15381                                ? FFEEXPR_contextSFUNCDEF
15382                                : FFEEXPR_contextLET,
15383                                ffeexpr_token_arguments_);
15384             }
15385           return
15386             (ffelexHandler)
15387             ffeexpr_rhs (ffeexpr_stack_->pool,
15388                          sfdef
15389                          ? FFEEXPR_contextSFUNCDEFACTUALARG_
15390                          : FFEEXPR_contextACTUALARG_,
15391                          ffeexpr_token_arguments_);
15392
15393         case FFEEXPR_parentypeARRAY_:
15394           ffebld_set_info (e->u.operand,
15395                            ffesymbol_info (ffebld_symter (e->u.operand)));
15396           ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15397           ffeexpr_stack_->bound_list = ffesymbol_dims (s);
15398           ffeexpr_stack_->rank = 0;
15399           ffeexpr_stack_->constant = TRUE;
15400           ffeexpr_stack_->immediate = TRUE;
15401           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
15402                                               sfdef
15403                                               ? FFEEXPR_contextSFUNCDEFINDEX_
15404                                               : FFEEXPR_contextINDEX_,
15405                                               ffeexpr_token_elements_);
15406
15407         case FFEEXPR_parentypeSUBSTRING_:
15408           ffebld_set_info (e->u.operand,
15409                            ffesymbol_info (ffebld_symter (e->u.operand)));
15410           e->u.operand = ffeexpr_collapse_symter (e->u.operand,
15411                                                   ffeexpr_tokens_[0]);
15412           return
15413             (ffelexHandler)
15414             ffeexpr_rhs (ffeexpr_stack_->pool,
15415                          sfdef
15416                          ? FFEEXPR_contextSFUNCDEFINDEX_
15417                          : FFEEXPR_contextINDEX_,
15418                          ffeexpr_token_substring_);
15419
15420         case FFEEXPR_parentypeFUNSUBSTR_:
15421           return
15422             (ffelexHandler)
15423             ffeexpr_rhs (ffeexpr_stack_->pool,
15424                          sfdef
15425                          ? FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
15426                          : FFEEXPR_contextINDEXORACTUALARG_,
15427                          ffeexpr_token_funsubstr_);
15428
15429         case FFEEXPR_parentypeANY_:
15430           ffebld_set_info (e->u.operand, ffesymbol_info (s));
15431           return
15432             (ffelexHandler)
15433             ffeexpr_rhs (ffeexpr_stack_->pool,
15434                          sfdef
15435                          ? FFEEXPR_contextSFUNCDEFACTUALARG_
15436                          : FFEEXPR_contextACTUALARG_,
15437                          ffeexpr_token_anything_);
15438
15439         default:
15440           assert ("bad paren type" == NULL);
15441           break;
15442         }
15443
15444     case FFELEX_typeEQUALS:     /* As in "VAR=". */
15445       switch (ffeexpr_stack_->context)
15446         {
15447         case FFEEXPR_contextIMPDOITEM_: /* "(,VAR=start,end[,incr])". */
15448         case FFEEXPR_contextIMPDOITEMDF_:
15449           ffeexpr_stack_->is_rhs = FALSE;       /* Really an lhs construct. */
15450           ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
15451           break;
15452
15453         default:
15454           break;
15455         }
15456       break;
15457
15458 #if 0
15459     case FFELEX_typePERIOD:
15460     case FFELEX_typePERCENT:
15461       ~~Support these two someday, though not required
15462         assert ("FOO%, FOO. not yet supported!~~" == NULL);
15463       break;
15464 #endif
15465
15466     default:
15467       break;
15468     }
15469
15470   switch (ffeexpr_stack_->context)
15471     {
15472     case FFEEXPR_contextINDEXORACTUALARG_:
15473     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15474       assert ("strange context" == NULL);
15475       break;
15476
15477     default:
15478       break;
15479     }
15480
15481   e = ffeexpr_expr_new_ ();
15482   e->type = FFEEXPR_exprtypeOPERAND_;
15483   e->token = ffeexpr_tokens_[0];
15484   s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0], FALSE);
15485   if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15486     {
15487       e->u.operand = ffebld_new_any ();
15488       ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15489     }
15490   else
15491     {
15492       e->u.operand = ffebld_new_symter (s, FFEINTRIN_genNONE,
15493                                         ffesymbol_specific (s),
15494                                         ffesymbol_implementation (s));
15495       if (ffesymbol_specific (s) == FFEINTRIN_specNONE)
15496         ffebld_set_info (e->u.operand, ffeinfo_use (ffesymbol_info (s)));
15497       else
15498         {                       /* Decorate the SYMTER with the actual type
15499                                    of the intrinsic. */
15500           ffebld_set_info (e->u.operand, ffeinfo_new
15501                         (ffeintrin_basictype (ffesymbol_specific (s)),
15502                          ffeintrin_kindtype (ffesymbol_specific (s)),
15503                          0,
15504                          ffesymbol_kind (s),
15505                          ffesymbol_where (s),
15506                          FFETARGET_charactersizeNONE));
15507         }
15508       if (ffesymbol_is_doiter (s))
15509         ffebld_symter_set_is_doiter (e->u.operand, TRUE);
15510       e->u.operand = ffeexpr_collapse_symter (e->u.operand,
15511                                               ffeexpr_tokens_[0]);
15512     }
15513   ffeexpr_exprstack_push_operand_ (e);
15514   return (ffelexHandler) ffeexpr_token_binary_ (t);
15515 }
15516
15517 /* ffeexpr_token_name_apos_ -- Rhs NAME APOSTROPHE
15518
15519    Return a pointer to this function to the lexer (ffelex), which will
15520    invoke it for the next token.
15521
15522    Expecting a NAME token, analyze the previous NAME token to see what kind,
15523    if any, typeless constant we've got.
15524
15525    01-Sep-90  JCB  1.1
15526       Expect a NAME instead of CHARACTER in this situation.  */
15527
15528 static ffelexHandler
15529 ffeexpr_token_name_apos_ (ffelexToken t)
15530 {
15531   ffeexprExpr_ e;
15532
15533   ffelex_set_hexnum (FALSE);
15534
15535   switch (ffelex_token_type (t))
15536     {
15537     case FFELEX_typeNAME:
15538       ffeexpr_tokens_[2] = ffelex_token_use (t);
15539       return (ffelexHandler) ffeexpr_token_name_apos_name_;
15540
15541     default:
15542       break;
15543     }
15544
15545   if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
15546     {
15547       ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
15548       ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15549                    ffelex_token_where_column (ffeexpr_tokens_[0]));
15550       ffebad_here (1, ffelex_token_where_line (t),
15551                    ffelex_token_where_column (t));
15552       ffebad_finish ();
15553     }
15554
15555   ffelex_token_kill (ffeexpr_tokens_[1]);
15556
15557   e = ffeexpr_expr_new_ ();
15558   e->type = FFEEXPR_exprtypeOPERAND_;
15559   e->u.operand = ffebld_new_any ();
15560   ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15561   e->token = ffeexpr_tokens_[0];
15562   ffeexpr_exprstack_push_operand_ (e);
15563
15564   return (ffelexHandler) ffeexpr_token_binary_ (t);
15565 }
15566
15567 /* ffeexpr_token_name_apos_name_ -- Rhs NAME APOSTROPHE NAME
15568
15569    Return a pointer to this function to the lexer (ffelex), which will
15570    invoke it for the next token.
15571
15572    Expecting an APOSTROPHE token, analyze the previous NAME token to see
15573    what kind, if any, typeless constant we've got.  */
15574
15575 static ffelexHandler
15576 ffeexpr_token_name_apos_name_ (ffelexToken t)
15577 {
15578   ffeexprExpr_ e;
15579   char c;
15580
15581   e = ffeexpr_expr_new_ ();
15582   e->type = FFEEXPR_exprtypeOPERAND_;
15583   e->token = ffeexpr_tokens_[0];
15584
15585   if ((ffelex_token_type (t) == ffelex_token_type (ffeexpr_tokens_[1]))
15586       && (ffelex_token_length (ffeexpr_tokens_[0]) == 1)
15587       && (ffesrc_char_match_init ((c = ffelex_token_text (ffeexpr_tokens_[0])[0]),
15588                                   'B', 'b')
15589           || ffesrc_char_match_init (c, 'O', 'o')
15590           || ffesrc_char_match_init (c, 'X', 'x')
15591           || ffesrc_char_match_init (c, 'Z', 'z')))
15592     {
15593       ffetargetCharacterSize size;
15594
15595       if (!ffe_is_typeless_boz ()) {
15596
15597       switch (c)
15598         {
15599         case FFESRC_CASE_MATCH_INIT ('B', 'b', imatch_b, no_imatch):
15600           e->u.operand = ffebld_new_conter (ffebld_constant_new_integerbinary
15601                                             (ffeexpr_tokens_[2]));
15602           break;
15603
15604         case FFESRC_CASE_MATCH_INIT ('O', 'o', imatch_o, no_imatch):
15605           e->u.operand = ffebld_new_conter (ffebld_constant_new_integeroctal
15606                                             (ffeexpr_tokens_[2]));
15607           break;
15608
15609         case FFESRC_CASE_MATCH_INIT ('X', 'x', imatch_x, no_imatch):
15610           e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
15611                                             (ffeexpr_tokens_[2]));
15612           break;
15613
15614         case FFESRC_CASE_MATCH_INIT ('Z', 'z', imatch_z, no_imatch):
15615           e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
15616                                             (ffeexpr_tokens_[2]));
15617           break;
15618
15619         default:
15620         no_imatch:              /* :::::::::::::::::::: */
15621           assert ("not BOXZ!" == NULL);
15622           abort ();
15623         }
15624
15625         ffebld_set_info (e->u.operand,
15626                          ffeinfo_new (FFEINFO_basictypeINTEGER,
15627                                       FFEINFO_kindtypeINTEGERDEFAULT, 0,
15628                                       FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
15629                                       FFETARGET_charactersizeNONE));
15630         ffeexpr_exprstack_push_operand_ (e);
15631         ffelex_token_kill (ffeexpr_tokens_[1]);
15632         ffelex_token_kill (ffeexpr_tokens_[2]);
15633         return (ffelexHandler) ffeexpr_token_binary_;
15634       }
15635
15636       switch (c)
15637         {
15638         case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
15639           e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_bm
15640                                             (ffeexpr_tokens_[2]));
15641           size = ffetarget_size_typeless_binary (ffeexpr_tokens_[2]);
15642           break;
15643
15644         case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
15645           e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_om
15646                                             (ffeexpr_tokens_[2]));
15647           size = ffetarget_size_typeless_octal (ffeexpr_tokens_[2]);
15648           break;
15649
15650         case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
15651           e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hxm
15652                                             (ffeexpr_tokens_[2]));
15653           size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15654           break;
15655
15656         case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
15657           e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
15658                                             (ffeexpr_tokens_[2]));
15659           size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15660           break;
15661
15662         default:
15663         no_match:               /* :::::::::::::::::::: */
15664           assert ("not BOXZ!" == NULL);
15665           e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
15666                                             (ffeexpr_tokens_[2]));
15667           size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15668           break;
15669         }
15670       ffebld_set_info (e->u.operand,
15671                ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
15672                        0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
15673       ffeexpr_exprstack_push_operand_ (e);
15674       ffelex_token_kill (ffeexpr_tokens_[1]);
15675       ffelex_token_kill (ffeexpr_tokens_[2]);
15676       return (ffelexHandler) ffeexpr_token_binary_;
15677     }
15678
15679   if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
15680     {
15681       ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
15682       ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15683                    ffelex_token_where_column (ffeexpr_tokens_[0]));
15684       ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
15685       ffebad_finish ();
15686     }
15687
15688   ffelex_token_kill (ffeexpr_tokens_[1]);
15689   ffelex_token_kill (ffeexpr_tokens_[2]);
15690
15691   e->type = FFEEXPR_exprtypeOPERAND_;
15692   e->u.operand = ffebld_new_any ();
15693   ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15694   e->token = ffeexpr_tokens_[0];
15695   ffeexpr_exprstack_push_operand_ (e);
15696
15697   switch (ffelex_token_type (t))
15698     {
15699     case FFELEX_typeAPOSTROPHE:
15700     case FFELEX_typeQUOTE:
15701       return (ffelexHandler) ffeexpr_token_binary_;
15702
15703     default:
15704       return (ffelexHandler) ffeexpr_token_binary_ (t);
15705     }
15706 }
15707
15708 /* ffeexpr_token_percent_ -- Rhs PERCENT
15709
15710    Handle a percent sign possibly followed by "LOC".  If followed instead
15711    by "VAL", "REF", or "DESCR", issue an error message and substitute
15712    "LOC".  If followed by something else, treat the percent sign as a
15713    spurious incorrect token and reprocess the token via _rhs_.  */
15714
15715 static ffelexHandler
15716 ffeexpr_token_percent_ (ffelexToken t)
15717 {
15718   switch (ffelex_token_type (t))
15719     {
15720     case FFELEX_typeNAME:
15721     case FFELEX_typeNAMES:
15722       ffeexpr_stack_->percent = ffeexpr_percent_ (t);
15723       ffeexpr_tokens_[1] = ffelex_token_use (t);
15724       return (ffelexHandler) ffeexpr_token_percent_name_;
15725
15726     default:
15727       if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
15728         {
15729           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15730                        ffelex_token_where_column (ffeexpr_tokens_[0]));
15731           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
15732                    ffelex_token_where_column (ffeexpr_stack_->first_token));
15733           ffebad_finish ();
15734         }
15735       ffelex_token_kill (ffeexpr_tokens_[0]);
15736       return (ffelexHandler) ffeexpr_token_rhs_ (t);
15737     }
15738 }
15739
15740 /* ffeexpr_token_percent_name_ -- Rhs PERCENT NAME
15741
15742    Make sure the token is OPEN_PAREN and prepare for the one-item list of
15743    LHS expressions.  Else display an error message.  */
15744
15745 static ffelexHandler
15746 ffeexpr_token_percent_name_ (ffelexToken t)
15747 {
15748   ffelexHandler nexthandler;
15749
15750   if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
15751     {
15752       if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
15753         {
15754           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15755                        ffelex_token_where_column (ffeexpr_tokens_[0]));
15756           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
15757                    ffelex_token_where_column (ffeexpr_stack_->first_token));
15758           ffebad_finish ();
15759         }
15760       ffelex_token_kill (ffeexpr_tokens_[0]);
15761       nexthandler = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_tokens_[1]);
15762       ffelex_token_kill (ffeexpr_tokens_[1]);
15763       return (ffelexHandler) (*nexthandler) (t);
15764     }
15765
15766   switch (ffeexpr_stack_->percent)
15767     {
15768     default:
15769       if (ffest_ffebad_start (FFEBAD_INVALID_PERCENT))
15770         {
15771           ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15772                        ffelex_token_where_column (ffeexpr_tokens_[0]));
15773           ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
15774           ffebad_finish ();
15775         }
15776       ffeexpr_stack_->percent = FFEEXPR_percentLOC_;
15777       /* Fall through. */
15778     case FFEEXPR_percentLOC_:
15779       ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
15780       ffelex_token_kill (ffeexpr_tokens_[1]);
15781       ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
15782       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
15783                                           FFEEXPR_contextLOC_,
15784                                           ffeexpr_cb_end_loc_);
15785     }
15786 }
15787
15788 /* ffeexpr_make_float_const_ -- Make a floating-point constant
15789
15790    See prototype.
15791
15792    Pass 'E', 'D', or 'Q' for exponent letter.  */
15793
15794 static void
15795 ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
15796                            ffelexToken decimal, ffelexToken fraction,
15797                            ffelexToken exponent, ffelexToken exponent_sign,
15798                            ffelexToken exponent_digits)
15799 {
15800   ffeexprExpr_ e;
15801
15802   e = ffeexpr_expr_new_ ();
15803   e->type = FFEEXPR_exprtypeOPERAND_;
15804   if (integer != NULL)
15805     e->token = ffelex_token_use (integer);
15806   else
15807     {
15808       assert (decimal != NULL);
15809       e->token = ffelex_token_use (decimal);
15810     }
15811
15812   switch (exp_letter)
15813     {
15814 #if !FFETARGET_okREALQUAD
15815     case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
15816       if (ffebad_start (FFEBAD_QUAD_UNSUPPORTED))
15817         {
15818           ffebad_here (0, ffelex_token_where_line (e->token),
15819                        ffelex_token_where_column (e->token));
15820           ffebad_finish ();
15821         }
15822       goto match_d;             /* The FFESRC_CASE_* macros don't
15823                                    allow fall-through! */
15824 #endif
15825
15826     case FFESRC_CASE_MATCH_INIT ('D', 'd', match_d, no_match):
15827       e->u.operand = ffebld_new_conter (ffebld_constant_new_realdouble
15828                                         (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15829       ffebld_set_info (e->u.operand,
15830              ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
15831                           0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15832       break;
15833
15834     case FFESRC_CASE_MATCH_INIT ('E', 'e', match_e, no_match):
15835       e->u.operand = ffebld_new_conter (ffebld_constant_new_realdefault
15836                                         (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15837       ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeREAL,
15838                          FFEINFO_kindtypeREALDEFAULT, 0, FFEINFO_kindENTITY,
15839                        FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15840       break;
15841
15842 #if FFETARGET_okREALQUAD
15843     case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
15844       e->u.operand = ffebld_new_conter (ffebld_constant_new_realquad
15845                                         (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15846       ffebld_set_info (e->u.operand,
15847                ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALQUAD,
15848                             0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15849       break;
15850 #endif
15851
15852     case 'I':   /* Make an integer. */
15853       e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
15854                                         (ffeexpr_tokens_[0]));
15855       ffebld_set_info (e->u.operand,
15856                        ffeinfo_new (FFEINFO_basictypeINTEGER,
15857                                     FFEINFO_kindtypeINTEGERDEFAULT, 0,
15858                                     FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
15859                                     FFETARGET_charactersizeNONE));
15860       break;
15861
15862     default:
15863     no_match:                   /* :::::::::::::::::::: */
15864       assert ("Lost the exponent letter!" == NULL);
15865     }
15866
15867   ffeexpr_exprstack_push_operand_ (e);
15868 }
15869
15870 /* Just like ffesymbol_declare_local, except performs any implicit info
15871    assignment necessary.  */
15872
15873 static ffesymbol
15874 ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin)
15875 {
15876   ffesymbol s;
15877   ffeinfoKind k;
15878   bool bad;
15879
15880   s = ffesymbol_declare_local (t, maybe_intrin);
15881
15882   switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15883     /* Special-case these since they can involve a different concept
15884        of "state" (in the stmtfunc name space).  */
15885     {
15886     case FFEEXPR_contextDATAIMPDOINDEX_:
15887     case FFEEXPR_contextDATAIMPDOCTRL_:
15888       if (ffeexpr_context_outer_ (ffeexpr_stack_)
15889           == FFEEXPR_contextDATAIMPDOINDEX_)
15890         s = ffeexpr_sym_impdoitem_ (s, t);
15891       else
15892         if (ffeexpr_stack_->is_rhs)
15893           s = ffeexpr_sym_impdoitem_ (s, t);
15894         else
15895           s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
15896       bad = (ffesymbol_kind (s) != FFEINFO_kindENTITY)
15897         || ((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
15898             && (ffesymbol_where (s) != FFEINFO_whereIMMEDIATE));
15899       if (bad && (ffesymbol_kind (s) != FFEINFO_kindANY))
15900         ffesymbol_error (s, t);
15901       return s;
15902
15903     default:
15904       break;
15905     }
15906
15907   switch ((ffesymbol_sfdummyparent (s) == NULL)
15908           ? ffesymbol_state (s)
15909           : FFESYMBOL_stateUNDERSTOOD)
15910     {
15911     case FFESYMBOL_stateNONE:   /* Before first exec, not seen in expr
15912                                    context. */
15913       if (!ffest_seen_first_exec ())
15914         goto seen;              /* :::::::::::::::::::: */
15915       /* Fall through. */
15916     case FFESYMBOL_stateUNCERTAIN:      /* Unseen since first exec. */
15917       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15918         {
15919         case FFEEXPR_contextSUBROUTINEREF:
15920           s = ffeexpr_sym_lhs_call_ (s, t);
15921           break;
15922
15923         case FFEEXPR_contextFILEEXTFUNC:
15924           s = ffeexpr_sym_lhs_extfunc_ (s, t);
15925           break;
15926
15927         case FFEEXPR_contextSFUNCDEFACTUALARG_:
15928           s = ffecom_sym_exec_transition (s);
15929           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15930             goto understood;    /* :::::::::::::::::::: */
15931           /* Fall through. */
15932         case FFEEXPR_contextACTUALARG_:
15933           s = ffeexpr_sym_rhs_actualarg_ (s, t);
15934           break;
15935
15936         case FFEEXPR_contextDATA:
15937           if (ffeexpr_stack_->is_rhs)
15938             s = ffeexpr_sym_rhs_let_ (s, t);
15939           else
15940             s = ffeexpr_sym_lhs_data_ (s, t);
15941           break;
15942
15943         case FFEEXPR_contextDATAIMPDOITEM_:
15944           s = ffeexpr_sym_lhs_data_ (s, t);
15945           break;
15946
15947         case FFEEXPR_contextSFUNCDEF:
15948         case FFEEXPR_contextSFUNCDEFINDEX_:
15949         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15950         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15951           s = ffecom_sym_exec_transition (s);
15952           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15953             goto understood;    /* :::::::::::::::::::: */
15954           /* Fall through. */
15955         case FFEEXPR_contextLET:
15956         case FFEEXPR_contextPAREN_:
15957         case FFEEXPR_contextACTUALARGEXPR_:
15958         case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15959         case FFEEXPR_contextASSIGN:
15960         case FFEEXPR_contextIOLIST:
15961         case FFEEXPR_contextIOLISTDF:
15962         case FFEEXPR_contextDO:
15963         case FFEEXPR_contextDOWHILE:
15964         case FFEEXPR_contextAGOTO:
15965         case FFEEXPR_contextCGOTO:
15966         case FFEEXPR_contextIF:
15967         case FFEEXPR_contextARITHIF:
15968         case FFEEXPR_contextFORMAT:
15969         case FFEEXPR_contextSTOP:
15970         case FFEEXPR_contextRETURN:
15971         case FFEEXPR_contextSELECTCASE:
15972         case FFEEXPR_contextCASE:
15973         case FFEEXPR_contextFILEASSOC:
15974         case FFEEXPR_contextFILEINT:
15975         case FFEEXPR_contextFILEDFINT:
15976         case FFEEXPR_contextFILELOG:
15977         case FFEEXPR_contextFILENUM:
15978         case FFEEXPR_contextFILENUMAMBIG:
15979         case FFEEXPR_contextFILECHAR:
15980         case FFEEXPR_contextFILENUMCHAR:
15981         case FFEEXPR_contextFILEDFCHAR:
15982         case FFEEXPR_contextFILEKEY:
15983         case FFEEXPR_contextFILEUNIT:
15984         case FFEEXPR_contextFILEUNIT_DF:
15985         case FFEEXPR_contextFILEUNITAMBIG:
15986         case FFEEXPR_contextFILEFORMAT:
15987         case FFEEXPR_contextFILENAMELIST:
15988         case FFEEXPR_contextFILEVXTCODE:
15989         case FFEEXPR_contextINDEX_:
15990         case FFEEXPR_contextIMPDOITEM_:
15991         case FFEEXPR_contextIMPDOITEMDF_:
15992         case FFEEXPR_contextIMPDOCTRL_:
15993         case FFEEXPR_contextLOC_:
15994           if (ffeexpr_stack_->is_rhs)
15995             s = ffeexpr_sym_rhs_let_ (s, t);
15996           else
15997             s = ffeexpr_sym_lhs_let_ (s, t);
15998           break;
15999
16000         case FFEEXPR_contextCHARACTERSIZE:
16001         case FFEEXPR_contextEQUIVALENCE:
16002         case FFEEXPR_contextINCLUDE:
16003         case FFEEXPR_contextPARAMETER:
16004         case FFEEXPR_contextDIMLIST:
16005         case FFEEXPR_contextDIMLISTCOMMON:
16006         case FFEEXPR_contextKINDTYPE:
16007         case FFEEXPR_contextINITVAL:
16008         case FFEEXPR_contextEQVINDEX_:
16009           break;                /* Will turn into errors below. */
16010
16011         default:
16012           ffesymbol_error (s, t);
16013           break;
16014         }
16015       /* Fall through. */
16016     case FFESYMBOL_stateUNDERSTOOD:     /* Nothing much more to learn. */
16017     understood:         /* :::::::::::::::::::: */
16018       k = ffesymbol_kind (s);
16019       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16020         {
16021         case FFEEXPR_contextSUBROUTINEREF:
16022           bad = ((k != FFEINFO_kindSUBROUTINE)
16023                  && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
16024                      || (k != FFEINFO_kindNONE)));
16025           break;
16026
16027         case FFEEXPR_contextFILEEXTFUNC:
16028           bad = (k != FFEINFO_kindFUNCTION)
16029             || (ffesymbol_where (s) != FFEINFO_whereGLOBAL);
16030           break;
16031
16032         case FFEEXPR_contextSFUNCDEFACTUALARG_:
16033         case FFEEXPR_contextACTUALARG_:
16034           switch (k)
16035             {
16036             case FFEINFO_kindENTITY:
16037               bad = FALSE;
16038               break;
16039
16040             case FFEINFO_kindFUNCTION:
16041             case FFEINFO_kindSUBROUTINE:
16042               bad
16043                 = ((ffesymbol_where (s) != FFEINFO_whereGLOBAL)
16044                    && (ffesymbol_where (s) != FFEINFO_whereDUMMY)
16045                    && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
16046                        || !ffeintrin_is_actualarg (ffesymbol_specific (s))));
16047               break;
16048
16049             case FFEINFO_kindNONE:
16050               if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
16051                 {
16052                   bad = !(ffeintrin_is_actualarg (ffesymbol_specific (s)));
16053                   break;
16054                 }
16055
16056               /* If state is UNDERSTOOD here, it's CHAR*(*) or attrsANY,
16057                  and in the former case, attrsTYPE is set, so we
16058                  see this as an error as we should, since CHAR*(*)
16059                  cannot be actually referenced in a main/block data
16060                  program unit.  */
16061
16062               if ((ffesymbol_attrs (s) & (FFESYMBOL_attrsANY
16063                                           | FFESYMBOL_attrsEXTERNAL
16064                                           | FFESYMBOL_attrsTYPE))
16065                   == FFESYMBOL_attrsEXTERNAL)
16066                 bad = FALSE;
16067               else
16068                 bad = TRUE;
16069               break;
16070
16071             default:
16072               bad = TRUE;
16073               break;
16074             }
16075           break;
16076
16077         case FFEEXPR_contextDATA:
16078           if (ffeexpr_stack_->is_rhs)
16079             bad = (k != FFEINFO_kindENTITY)
16080               || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16081           else
16082             bad = (k != FFEINFO_kindENTITY)
16083               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
16084                   && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
16085                   && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
16086           break;
16087
16088         case FFEEXPR_contextDATAIMPDOITEM_:
16089           bad = TRUE;           /* Unadorned item never valid. */
16090           break;
16091
16092         case FFEEXPR_contextSFUNCDEF:
16093         case FFEEXPR_contextSFUNCDEFINDEX_:
16094         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16095         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16096         case FFEEXPR_contextLET:
16097         case FFEEXPR_contextPAREN_:
16098         case FFEEXPR_contextACTUALARGEXPR_:
16099         case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16100         case FFEEXPR_contextASSIGN:
16101         case FFEEXPR_contextIOLIST:
16102         case FFEEXPR_contextIOLISTDF:
16103         case FFEEXPR_contextDO:
16104         case FFEEXPR_contextDOWHILE:
16105         case FFEEXPR_contextAGOTO:
16106         case FFEEXPR_contextCGOTO:
16107         case FFEEXPR_contextIF:
16108         case FFEEXPR_contextARITHIF:
16109         case FFEEXPR_contextFORMAT:
16110         case FFEEXPR_contextSTOP:
16111         case FFEEXPR_contextRETURN:
16112         case FFEEXPR_contextSELECTCASE:
16113         case FFEEXPR_contextCASE:
16114         case FFEEXPR_contextFILEASSOC:
16115         case FFEEXPR_contextFILEINT:
16116         case FFEEXPR_contextFILEDFINT:
16117         case FFEEXPR_contextFILELOG:
16118         case FFEEXPR_contextFILENUM:
16119         case FFEEXPR_contextFILENUMAMBIG:
16120         case FFEEXPR_contextFILECHAR:
16121         case FFEEXPR_contextFILENUMCHAR:
16122         case FFEEXPR_contextFILEDFCHAR:
16123         case FFEEXPR_contextFILEKEY:
16124         case FFEEXPR_contextFILEUNIT:
16125         case FFEEXPR_contextFILEUNIT_DF:
16126         case FFEEXPR_contextFILEUNITAMBIG:
16127         case FFEEXPR_contextFILEFORMAT:
16128         case FFEEXPR_contextFILENAMELIST:
16129         case FFEEXPR_contextFILEVXTCODE:
16130         case FFEEXPR_contextINDEX_:
16131         case FFEEXPR_contextIMPDOITEM_:
16132         case FFEEXPR_contextIMPDOITEMDF_:
16133         case FFEEXPR_contextIMPDOCTRL_:
16134         case FFEEXPR_contextLOC_:
16135           bad = (k != FFEINFO_kindENTITY);      /* This catches "SUBROUTINE
16136                                                    X(A);EXTERNAL A;CALL
16137                                                    Y(A);B=A", for example. */
16138           break;
16139
16140         case FFEEXPR_contextCHARACTERSIZE:
16141         case FFEEXPR_contextEQUIVALENCE:
16142         case FFEEXPR_contextPARAMETER:
16143         case FFEEXPR_contextDIMLIST:
16144         case FFEEXPR_contextDIMLISTCOMMON:
16145         case FFEEXPR_contextKINDTYPE:
16146         case FFEEXPR_contextINITVAL:
16147         case FFEEXPR_contextEQVINDEX_:
16148           bad = (k != FFEINFO_kindENTITY)
16149             || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16150           break;
16151
16152         case FFEEXPR_contextINCLUDE:
16153           bad = TRUE;
16154           break;
16155
16156         default:
16157           bad = TRUE;
16158           break;
16159         }
16160       if (bad && (k != FFEINFO_kindANY))
16161         ffesymbol_error (s, t);
16162       return s;
16163
16164     case FFESYMBOL_stateSEEN:   /* Seen but not yet in exec portion. */
16165     seen:                       /* :::::::::::::::::::: */
16166       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16167         {
16168         case FFEEXPR_contextPARAMETER:
16169           if (ffeexpr_stack_->is_rhs)
16170             ffesymbol_error (s, t);
16171           else
16172             s = ffeexpr_sym_lhs_parameter_ (s, t);
16173           break;
16174
16175         case FFEEXPR_contextDATA:
16176           s = ffecom_sym_exec_transition (s);
16177           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16178             goto understood;    /* :::::::::::::::::::: */
16179           if (ffeexpr_stack_->is_rhs)
16180             ffesymbol_error (s, t);
16181           else
16182             s = ffeexpr_sym_lhs_data_ (s, t);
16183           goto understood;      /* :::::::::::::::::::: */
16184
16185         case FFEEXPR_contextDATAIMPDOITEM_:
16186           s = ffecom_sym_exec_transition (s);
16187           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16188             goto understood;    /* :::::::::::::::::::: */
16189           s = ffeexpr_sym_lhs_data_ (s, t);
16190           goto understood;      /* :::::::::::::::::::: */
16191
16192         case FFEEXPR_contextEQUIVALENCE:
16193           s = ffeexpr_sym_lhs_equivalence_ (s, t);
16194           break;
16195
16196         case FFEEXPR_contextDIMLIST:
16197           s = ffeexpr_sym_rhs_dimlist_ (s, t);
16198           break;
16199
16200         case FFEEXPR_contextCHARACTERSIZE:
16201         case FFEEXPR_contextKINDTYPE:
16202         case FFEEXPR_contextDIMLISTCOMMON:
16203         case FFEEXPR_contextINITVAL:
16204         case FFEEXPR_contextEQVINDEX_:
16205           ffesymbol_error (s, t);
16206           break;
16207
16208         case FFEEXPR_contextINCLUDE:
16209           ffesymbol_error (s, t);
16210           break;
16211
16212         case FFEEXPR_contextACTUALARG_: /* E.g. I in REAL A(Y(I)). */
16213         case FFEEXPR_contextSFUNCDEFACTUALARG_:
16214           s = ffecom_sym_exec_transition (s);
16215           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16216             goto understood;    /* :::::::::::::::::::: */
16217           s = ffeexpr_sym_rhs_actualarg_ (s, t);
16218           goto understood;      /* :::::::::::::::::::: */
16219
16220         case FFEEXPR_contextINDEX_:
16221         case FFEEXPR_contextACTUALARGEXPR_:
16222         case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16223         case FFEEXPR_contextSFUNCDEF:
16224         case FFEEXPR_contextSFUNCDEFINDEX_:
16225         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16226         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16227           assert (ffeexpr_stack_->is_rhs);
16228           s = ffecom_sym_exec_transition (s);
16229           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16230             goto understood;    /* :::::::::::::::::::: */
16231           s = ffeexpr_sym_rhs_let_ (s, t);
16232           goto understood;      /* :::::::::::::::::::: */
16233
16234         default:
16235           ffesymbol_error (s, t);
16236           break;
16237         }
16238       return s;
16239
16240     default:
16241       assert ("bad symbol state" == NULL);
16242       return NULL;
16243       break;
16244     }
16245 }
16246
16247 /* Have FOO in DATA (XYZ(FOO),...)/.../ or DATA (...,XYZ=FOO,BAR,BLETCH).
16248    Could be found via the "statement-function" name space (in which case
16249    it should become an iterator) or the local name space (in which case
16250    it should be either a named constant, or a variable that will have an
16251    sfunc name space sibling that should become an iterator).  */
16252
16253 static ffesymbol
16254 ffeexpr_sym_impdoitem_ (ffesymbol sp, ffelexToken t)
16255 {
16256   ffesymbol s;
16257   ffesymbolAttrs sa;
16258   ffesymbolAttrs na;
16259   ffesymbolState ss;
16260   ffesymbolState ns;
16261   ffeinfoKind kind;
16262   ffeinfoWhere where;
16263
16264   ss = ffesymbol_state (sp);
16265
16266   if (ffesymbol_sfdummyparent (sp) != NULL)
16267     {                           /* Have symbol in sfunc name space. */
16268       switch (ss)
16269         {
16270         case FFESYMBOL_stateNONE:       /* Used as iterator already. */
16271           if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
16272             ffesymbol_error (sp, t);    /* Can't use dead iterator. */
16273           else
16274             {                   /* Can use dead iterator because we're at at
16275                                    least an innermore (higher-numbered) level
16276                                    than the iterator's outermost
16277                                    (lowest-numbered) level. */
16278               ffesymbol_signal_change (sp);
16279               ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
16280               ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
16281               ffesymbol_signal_unreported (sp);
16282             }
16283           break;
16284
16285         case FFESYMBOL_stateSEEN:       /* Seen already in this or other
16286                                            implied-DO.  Set symbol level
16287                                            number to outermost value, as that
16288                                            tells us we can see it as iterator
16289                                            at that level at the innermost. */
16290           if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
16291             {
16292               ffesymbol_signal_change (sp);
16293               ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
16294               ffesymbol_signal_unreported (sp);
16295             }
16296           break;
16297
16298         case FFESYMBOL_stateUNCERTAIN:  /* Iterator. */
16299           assert (ffeexpr_level_ == ffesymbol_maxentrynum (sp));
16300           ffesymbol_error (sp, t);      /* (,,,I=I,10). */
16301           break;
16302
16303         case FFESYMBOL_stateUNDERSTOOD:
16304           break;                /* ANY. */
16305
16306         default:
16307           assert ("Foo Bar!!" == NULL);
16308           break;
16309         }
16310
16311       return sp;
16312     }
16313
16314   /* Got symbol in local name space, so we haven't seen it in impdo yet.
16315      First, if it is brand-new and we're in executable statements, set the
16316      attributes and exec-transition it to set state UNCERTAIN or UNDERSTOOD.
16317      Second, if it is now a constant (PARAMETER), then just return it, it
16318      can't be an implied-do iterator.  If it is understood, complain if it is
16319      not a valid variable, but make the inner name space iterator anyway and
16320      return that.  If it is not understood, improve understanding of the
16321      symbol accordingly, complain accordingly, in either case make the inner
16322      name space iterator and return that.  */
16323
16324   sa = ffesymbol_attrs (sp);
16325
16326   if (ffesymbol_state_is_specable (ss)
16327       && ffest_seen_first_exec ())
16328     {
16329       assert (sa == FFESYMBOL_attrsetNONE);
16330       ffesymbol_signal_change (sp);
16331       ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
16332       ffesymbol_resolve_intrin (sp);
16333       if (ffeimplic_establish_symbol (sp))
16334         ffesymbol_set_attr (sp, FFESYMBOL_attrSFARG);
16335       else
16336         ffesymbol_error (sp, t);
16337
16338       /* After the exec transition, the state will either be UNCERTAIN (could
16339          be a dummy or local var) or UNDERSTOOD (local var, because this is a
16340          PROGRAM/BLOCKDATA program unit).  */
16341
16342       sp = ffecom_sym_exec_transition (sp);
16343       sa = ffesymbol_attrs (sp);
16344       ss = ffesymbol_state (sp);
16345     }
16346
16347   ns = ss;
16348   kind = ffesymbol_kind (sp);
16349   where = ffesymbol_where (sp);
16350
16351   if (ss == FFESYMBOL_stateUNDERSTOOD)
16352     {
16353       if (kind != FFEINFO_kindENTITY)
16354         ffesymbol_error (sp, t);
16355       if (where == FFEINFO_whereCONSTANT)
16356         return sp;
16357     }
16358   else
16359     {
16360       /* Enhance understanding of local symbol.  This used to imply exec
16361          transition, but that doesn't seem necessary, since the local symbol
16362          doesn't actually get put into an ffebld tree here -- we just learn
16363          more about it, just like when we see a local symbol's name in the
16364          dummy-arg list of a statement function.  */
16365
16366       if (ss != FFESYMBOL_stateUNCERTAIN)
16367         {
16368           /* Figure out what kind of object we've got based on previous
16369              declarations of or references to the object. */
16370
16371           ns = FFESYMBOL_stateSEEN;
16372
16373           if (sa & FFESYMBOL_attrsANY)
16374             na = sa;
16375           else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
16376                             | FFESYMBOL_attrsANY
16377                             | FFESYMBOL_attrsCOMMON
16378                             | FFESYMBOL_attrsDUMMY
16379                             | FFESYMBOL_attrsEQUIV
16380                             | FFESYMBOL_attrsINIT
16381                             | FFESYMBOL_attrsNAMELIST
16382                             | FFESYMBOL_attrsRESULT
16383                             | FFESYMBOL_attrsSAVE
16384                             | FFESYMBOL_attrsSFARG
16385                             | FFESYMBOL_attrsTYPE)))
16386             na = sa | FFESYMBOL_attrsSFARG;
16387           else
16388             na = FFESYMBOL_attrsetNONE;
16389         }
16390       else
16391         {                       /* stateUNCERTAIN. */
16392           na = sa | FFESYMBOL_attrsSFARG;
16393           ns = FFESYMBOL_stateUNDERSTOOD;
16394
16395           assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16396                            | FFESYMBOL_attrsADJUSTABLE
16397                            | FFESYMBOL_attrsANYLEN
16398                            | FFESYMBOL_attrsARRAY
16399                            | FFESYMBOL_attrsDUMMY
16400                            | FFESYMBOL_attrsEXTERNAL
16401                            | FFESYMBOL_attrsSFARG
16402                            | FFESYMBOL_attrsTYPE)));
16403
16404           if (sa & FFESYMBOL_attrsEXTERNAL)
16405             {
16406               assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16407                                | FFESYMBOL_attrsDUMMY
16408                                | FFESYMBOL_attrsEXTERNAL
16409                                | FFESYMBOL_attrsTYPE)));
16410
16411               na = FFESYMBOL_attrsetNONE;
16412             }
16413           else if (sa & FFESYMBOL_attrsDUMMY)
16414             {
16415               assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16416               assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16417                                | FFESYMBOL_attrsEXTERNAL
16418                                | FFESYMBOL_attrsTYPE)));
16419
16420               kind = FFEINFO_kindENTITY;
16421             }
16422           else if (sa & FFESYMBOL_attrsARRAY)
16423             {
16424               assert (!(sa & ~(FFESYMBOL_attrsARRAY
16425                                | FFESYMBOL_attrsADJUSTABLE
16426                                | FFESYMBOL_attrsTYPE)));
16427
16428               na = FFESYMBOL_attrsetNONE;
16429             }
16430           else if (sa & FFESYMBOL_attrsSFARG)
16431             {
16432               assert (!(sa & ~(FFESYMBOL_attrsSFARG
16433                                | FFESYMBOL_attrsTYPE)));
16434
16435               ns = FFESYMBOL_stateUNCERTAIN;
16436             }
16437           else if (sa & FFESYMBOL_attrsTYPE)
16438             {
16439               assert (!(sa & (FFESYMBOL_attrsARRAY
16440                               | FFESYMBOL_attrsDUMMY
16441                               | FFESYMBOL_attrsEXTERNAL
16442                               | FFESYMBOL_attrsSFARG)));        /* Handled above. */
16443               assert (!(sa & ~(FFESYMBOL_attrsTYPE
16444                                | FFESYMBOL_attrsADJUSTABLE
16445                                | FFESYMBOL_attrsANYLEN
16446                                | FFESYMBOL_attrsARRAY
16447                                | FFESYMBOL_attrsDUMMY
16448                                | FFESYMBOL_attrsEXTERNAL
16449                                | FFESYMBOL_attrsSFARG)));
16450
16451               kind = FFEINFO_kindENTITY;
16452
16453               if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16454                 na = FFESYMBOL_attrsetNONE;
16455               else if (ffest_is_entry_valid ())
16456                 ns = FFESYMBOL_stateUNCERTAIN;  /* Could be DUMMY or LOCAL. */
16457               else
16458                 where = FFEINFO_whereLOCAL;
16459             }
16460           else
16461             na = FFESYMBOL_attrsetNONE; /* Error. */
16462         }
16463
16464       /* Now see what we've got for a new object: NONE means a new error
16465          cropped up; ANY means an old error to be ignored; otherwise,
16466          everything's ok, update the object (symbol) and continue on. */
16467
16468       if (na == FFESYMBOL_attrsetNONE)
16469         ffesymbol_error (sp, t);
16470       else if (!(na & FFESYMBOL_attrsANY))
16471         {
16472           ffesymbol_signal_change (sp); /* May need to back up to previous
16473                                            version. */
16474           if (!ffeimplic_establish_symbol (sp))
16475             ffesymbol_error (sp, t);
16476           else
16477             {
16478               ffesymbol_set_info (sp,
16479                                   ffeinfo_new (ffesymbol_basictype (sp),
16480                                                ffesymbol_kindtype (sp),
16481                                                ffesymbol_rank (sp),
16482                                                kind,
16483                                                where,
16484                                                ffesymbol_size (sp)));
16485               ffesymbol_set_attrs (sp, na);
16486               ffesymbol_set_state (sp, ns);
16487               ffesymbol_resolve_intrin (sp);
16488               if (!ffesymbol_state_is_specable (ns))
16489                 sp = ffecom_sym_learned (sp);
16490               ffesymbol_signal_unreported (sp); /* For debugging purposes. */
16491             }
16492         }
16493     }
16494
16495   /* Here we create the sfunc-name-space symbol representing what should
16496      become an iterator in this name space at this or an outermore (lower-
16497      numbered) expression level, else the implied-DO construct is in error.  */
16498
16499   s = ffesymbol_declare_sfdummy (t);    /* Sets maxentrynum to 0 for new obj;
16500                                            also sets sfa_dummy_parent to
16501                                            parent symbol. */
16502   assert (sp == ffesymbol_sfdummyparent (s));
16503
16504   ffesymbol_signal_change (s);
16505   ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
16506   ffesymbol_set_maxentrynum (s, ffeexpr_level_);
16507   ffesymbol_set_info (s,
16508                       ffeinfo_new (FFEINFO_basictypeINTEGER,
16509                                    FFEINFO_kindtypeINTEGERDEFAULT,
16510                                    0,
16511                                    FFEINFO_kindENTITY,
16512                                    FFEINFO_whereIMMEDIATE,
16513                                    FFETARGET_charactersizeNONE));
16514   ffesymbol_signal_unreported (s);
16515
16516   if ((ffesymbol_basictype (sp) != FFEINFO_basictypeINTEGER)
16517        && (ffesymbol_basictype (sp) != FFEINFO_basictypeANY))
16518     ffesymbol_error (s, t);
16519
16520   return s;
16521 }
16522
16523 /* Have FOO in CALL FOO.  Local name space, executable context only.  */
16524
16525 static ffesymbol
16526 ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t)
16527 {
16528   ffesymbolAttrs sa;
16529   ffesymbolAttrs na;
16530   ffeinfoKind kind;
16531   ffeinfoWhere where;
16532   ffeintrinGen gen;
16533   ffeintrinSpec spec;
16534   ffeintrinImp imp;
16535   bool error = FALSE;
16536
16537   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16538           || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16539
16540   na = sa = ffesymbol_attrs (s);
16541
16542   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16543                    | FFESYMBOL_attrsADJUSTABLE
16544                    | FFESYMBOL_attrsANYLEN
16545                    | FFESYMBOL_attrsARRAY
16546                    | FFESYMBOL_attrsDUMMY
16547                    | FFESYMBOL_attrsEXTERNAL
16548                    | FFESYMBOL_attrsSFARG
16549                    | FFESYMBOL_attrsTYPE)));
16550
16551   kind = ffesymbol_kind (s);
16552   where = ffesymbol_where (s);
16553
16554   /* Figure out what kind of object we've got based on previous declarations
16555      of or references to the object. */
16556
16557   if (sa & FFESYMBOL_attrsEXTERNAL)
16558     {
16559       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16560                        | FFESYMBOL_attrsDUMMY
16561                        | FFESYMBOL_attrsEXTERNAL
16562                        | FFESYMBOL_attrsTYPE)));
16563
16564       if (sa & FFESYMBOL_attrsTYPE)
16565         error = TRUE;
16566       else
16567         /* Not TYPE. */
16568         {
16569           kind = FFEINFO_kindSUBROUTINE;
16570
16571           if (sa & FFESYMBOL_attrsDUMMY)
16572             ;                   /* Not TYPE. */
16573           else if (sa & FFESYMBOL_attrsACTUALARG)
16574             ;                   /* Not DUMMY or TYPE. */
16575           else                  /* Not ACTUALARG, DUMMY, or TYPE. */
16576             where = FFEINFO_whereGLOBAL;
16577         }
16578     }
16579   else if (sa & FFESYMBOL_attrsDUMMY)
16580     {
16581       assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16582       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16583                        | FFESYMBOL_attrsEXTERNAL
16584                        | FFESYMBOL_attrsTYPE)));
16585
16586       if (sa & FFESYMBOL_attrsTYPE)
16587         error = TRUE;
16588       else
16589         kind = FFEINFO_kindSUBROUTINE;
16590     }
16591   else if (sa & FFESYMBOL_attrsARRAY)
16592     {
16593       assert (!(sa & ~(FFESYMBOL_attrsARRAY
16594                        | FFESYMBOL_attrsADJUSTABLE
16595                        | FFESYMBOL_attrsTYPE)));
16596
16597       error = TRUE;
16598     }
16599   else if (sa & FFESYMBOL_attrsSFARG)
16600     {
16601       assert (!(sa & ~(FFESYMBOL_attrsSFARG
16602                        | FFESYMBOL_attrsTYPE)));
16603
16604       error = TRUE;
16605     }
16606   else if (sa & FFESYMBOL_attrsTYPE)
16607     {
16608       assert (!(sa & (FFESYMBOL_attrsARRAY
16609                       | FFESYMBOL_attrsDUMMY
16610                       | FFESYMBOL_attrsEXTERNAL
16611                       | FFESYMBOL_attrsSFARG)));        /* Handled above. */
16612       assert (!(sa & ~(FFESYMBOL_attrsTYPE
16613                        | FFESYMBOL_attrsADJUSTABLE
16614                        | FFESYMBOL_attrsANYLEN
16615                        | FFESYMBOL_attrsARRAY
16616                        | FFESYMBOL_attrsDUMMY
16617                        | FFESYMBOL_attrsEXTERNAL
16618                        | FFESYMBOL_attrsSFARG)));
16619
16620       error = TRUE;
16621     }
16622   else if (sa == FFESYMBOL_attrsetNONE)
16623     {
16624       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16625
16626       if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
16627                                   &gen, &spec, &imp))
16628         {
16629           ffesymbol_signal_change (s);  /* May need to back up to previous
16630                                            version. */
16631           ffesymbol_set_generic (s, gen);
16632           ffesymbol_set_specific (s, spec);
16633           ffesymbol_set_implementation (s, imp);
16634           ffesymbol_set_info (s,
16635                               ffeinfo_new (FFEINFO_basictypeNONE,
16636                                            FFEINFO_kindtypeNONE,
16637                                            0,
16638                                            FFEINFO_kindSUBROUTINE,
16639                                            FFEINFO_whereINTRINSIC,
16640                                            FFETARGET_charactersizeNONE));
16641           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16642           ffesymbol_resolve_intrin (s);
16643           ffesymbol_reference (s, t, FALSE);
16644           s = ffecom_sym_learned (s);
16645           ffesymbol_signal_unreported (s);      /* For debugging purposes. */
16646
16647           return s;
16648         }
16649
16650       kind = FFEINFO_kindSUBROUTINE;
16651       where = FFEINFO_whereGLOBAL;
16652     }
16653   else
16654     error = TRUE;
16655
16656   /* Now see what we've got for a new object: NONE means a new error cropped
16657      up; ANY means an old error to be ignored; otherwise, everything's ok,
16658      update the object (symbol) and continue on. */
16659
16660   if (error)
16661     ffesymbol_error (s, t);
16662   else if (!(na & FFESYMBOL_attrsANY))
16663     {
16664       ffesymbol_signal_change (s);      /* May need to back up to previous
16665                                            version. */
16666       ffesymbol_set_info (s,
16667                           ffeinfo_new (ffesymbol_basictype (s),
16668                                        ffesymbol_kindtype (s),
16669                                        ffesymbol_rank (s),
16670                                        kind,    /* SUBROUTINE. */
16671                                        where,   /* GLOBAL or DUMMY. */
16672                                        ffesymbol_size (s)));
16673       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16674       ffesymbol_resolve_intrin (s);
16675       ffesymbol_reference (s, t, FALSE);
16676       s = ffecom_sym_learned (s);
16677       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
16678     }
16679
16680   return s;
16681 }
16682
16683 /* Have FOO in DATA FOO/.../.  Local name space and executable context
16684    only.  (This will change in the future when DATA FOO may be followed
16685    by COMMON FOO or even INTEGER FOO(10), etc.)  */
16686
16687 static ffesymbol
16688 ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t)
16689 {
16690   ffesymbolAttrs sa;
16691   ffesymbolAttrs na;
16692   ffeinfoKind kind;
16693   ffeinfoWhere where;
16694   bool error = FALSE;
16695
16696   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16697           || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16698
16699   na = sa = ffesymbol_attrs (s);
16700
16701   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16702                    | FFESYMBOL_attrsADJUSTABLE
16703                    | FFESYMBOL_attrsANYLEN
16704                    | FFESYMBOL_attrsARRAY
16705                    | FFESYMBOL_attrsDUMMY
16706                    | FFESYMBOL_attrsEXTERNAL
16707                    | FFESYMBOL_attrsSFARG
16708                    | FFESYMBOL_attrsTYPE)));
16709
16710   kind = ffesymbol_kind (s);
16711   where = ffesymbol_where (s);
16712
16713   /* Figure out what kind of object we've got based on previous declarations
16714      of or references to the object. */
16715
16716   if (sa & FFESYMBOL_attrsEXTERNAL)
16717     {
16718       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16719                        | FFESYMBOL_attrsDUMMY
16720                        | FFESYMBOL_attrsEXTERNAL
16721                        | FFESYMBOL_attrsTYPE)));
16722
16723       error = TRUE;
16724     }
16725   else if (sa & FFESYMBOL_attrsDUMMY)
16726     {
16727       assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16728       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16729                        | FFESYMBOL_attrsEXTERNAL
16730                        | FFESYMBOL_attrsTYPE)));
16731
16732       error = TRUE;
16733     }
16734   else if (sa & FFESYMBOL_attrsARRAY)
16735     {
16736       assert (!(sa & ~(FFESYMBOL_attrsARRAY
16737                        | FFESYMBOL_attrsADJUSTABLE
16738                        | FFESYMBOL_attrsTYPE)));
16739
16740       if (sa & FFESYMBOL_attrsADJUSTABLE)
16741         error = TRUE;
16742       where = FFEINFO_whereLOCAL;
16743     }
16744   else if (sa & FFESYMBOL_attrsSFARG)
16745     {
16746       assert (!(sa & ~(FFESYMBOL_attrsSFARG
16747                        | FFESYMBOL_attrsTYPE)));
16748
16749       where = FFEINFO_whereLOCAL;
16750     }
16751   else if (sa & FFESYMBOL_attrsTYPE)
16752     {
16753       assert (!(sa & (FFESYMBOL_attrsARRAY
16754                       | FFESYMBOL_attrsDUMMY
16755                       | FFESYMBOL_attrsEXTERNAL
16756                       | FFESYMBOL_attrsSFARG)));        /* Handled above. */
16757       assert (!(sa & ~(FFESYMBOL_attrsTYPE
16758                        | FFESYMBOL_attrsADJUSTABLE
16759                        | FFESYMBOL_attrsANYLEN
16760                        | FFESYMBOL_attrsARRAY
16761                        | FFESYMBOL_attrsDUMMY
16762                        | FFESYMBOL_attrsEXTERNAL
16763                        | FFESYMBOL_attrsSFARG)));
16764
16765       if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16766         error = TRUE;
16767       else
16768         {
16769           kind = FFEINFO_kindENTITY;
16770           where = FFEINFO_whereLOCAL;
16771         }
16772     }
16773   else if (sa == FFESYMBOL_attrsetNONE)
16774     {
16775       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16776       kind = FFEINFO_kindENTITY;
16777       where = FFEINFO_whereLOCAL;
16778     }
16779   else
16780     error = TRUE;
16781
16782   /* Now see what we've got for a new object: NONE means a new error cropped
16783      up; ANY means an old error to be ignored; otherwise, everything's ok,
16784      update the object (symbol) and continue on. */
16785
16786   if (error)
16787     ffesymbol_error (s, t);
16788   else if (!(na & FFESYMBOL_attrsANY))
16789     {
16790       ffesymbol_signal_change (s);      /* May need to back up to previous
16791                                            version. */
16792       if (!ffeimplic_establish_symbol (s))
16793         {
16794           ffesymbol_error (s, t);
16795           return s;
16796         }
16797       ffesymbol_set_info (s,
16798                           ffeinfo_new (ffesymbol_basictype (s),
16799                                        ffesymbol_kindtype (s),
16800                                        ffesymbol_rank (s),
16801                                        kind,    /* ENTITY. */
16802                                        where,   /* LOCAL. */
16803                                        ffesymbol_size (s)));
16804       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16805       ffesymbol_resolve_intrin (s);
16806       s = ffecom_sym_learned (s);
16807       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
16808     }
16809
16810   return s;
16811 }
16812
16813 /* Have FOO in EQUIVALENCE (...,FOO,...).  Does not include
16814    EQUIVALENCE (...,BAR(FOO),...).  */
16815
16816 static ffesymbol
16817 ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t)
16818 {
16819   ffesymbolAttrs sa;
16820   ffesymbolAttrs na;
16821   ffeinfoKind kind;
16822   ffeinfoWhere where;
16823
16824   na = sa = ffesymbol_attrs (s);
16825   kind = FFEINFO_kindENTITY;
16826   where = ffesymbol_where (s);
16827
16828   /* Figure out what kind of object we've got based on previous declarations
16829      of or references to the object. */
16830
16831   if (!(sa & ~(FFESYMBOL_attrsADJUSTS
16832                | FFESYMBOL_attrsARRAY
16833                | FFESYMBOL_attrsCOMMON
16834                | FFESYMBOL_attrsEQUIV
16835                | FFESYMBOL_attrsINIT
16836                | FFESYMBOL_attrsNAMELIST
16837                | FFESYMBOL_attrsSAVE
16838                | FFESYMBOL_attrsSFARG
16839                | FFESYMBOL_attrsTYPE)))
16840     na = sa | FFESYMBOL_attrsEQUIV;
16841   else
16842     na = FFESYMBOL_attrsetNONE;
16843
16844   /* Don't know why we're bothering to set kind and where in this code, but
16845      added the following to make it complete, in case it's really important.
16846      Generally this is left up to symbol exec transition.  */
16847
16848   if (where == FFEINFO_whereNONE)
16849     {
16850       if (na & (FFESYMBOL_attrsADJUSTS
16851                 | FFESYMBOL_attrsCOMMON))
16852         where = FFEINFO_whereCOMMON;
16853       else if (na & FFESYMBOL_attrsSAVE)
16854         where = FFEINFO_whereLOCAL;
16855     }
16856
16857   /* Now see what we've got for a new object: NONE means a new error cropped
16858      up; ANY means an old error to be ignored; otherwise, everything's ok,
16859      update the object (symbol) and continue on. */
16860
16861   if (na == FFESYMBOL_attrsetNONE)
16862     ffesymbol_error (s, t);
16863   else if (!(na & FFESYMBOL_attrsANY))
16864     {
16865       ffesymbol_signal_change (s);      /* May need to back up to previous
16866                                            version. */
16867       ffesymbol_set_info (s,
16868                           ffeinfo_new (ffesymbol_basictype (s),
16869                                        ffesymbol_kindtype (s),
16870                                        ffesymbol_rank (s),
16871                                        kind,    /* Always ENTITY. */
16872                                        where,   /* NONE, COMMON, or LOCAL. */
16873                                        ffesymbol_size (s)));
16874       ffesymbol_set_attrs (s, na);
16875       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
16876       ffesymbol_resolve_intrin (s);
16877       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
16878     }
16879
16880   return s;
16881 }
16882
16883 /* Have FOO in OPEN(...,USEROPEN=FOO,...).  Executable context only.
16884
16885    Note that I think this should be considered semantically similar to
16886    doing CALL XYZ(FOO), in that it should be considered like an
16887    ACTUALARG context.  In particular, without EXTERNAL being specified,
16888    it should not be allowed.  */
16889
16890 static ffesymbol
16891 ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t)
16892 {
16893   ffesymbolAttrs sa;
16894   ffesymbolAttrs na;
16895   ffeinfoKind kind;
16896   ffeinfoWhere where;
16897   bool needs_type = FALSE;
16898   bool error = FALSE;
16899
16900   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16901           || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16902
16903   na = sa = ffesymbol_attrs (s);
16904
16905   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16906                    | FFESYMBOL_attrsADJUSTABLE
16907                    | FFESYMBOL_attrsANYLEN
16908                    | FFESYMBOL_attrsARRAY
16909                    | FFESYMBOL_attrsDUMMY
16910                    | FFESYMBOL_attrsEXTERNAL
16911                    | FFESYMBOL_attrsSFARG
16912                    | FFESYMBOL_attrsTYPE)));
16913
16914   kind = ffesymbol_kind (s);
16915   where = ffesymbol_where (s);
16916
16917   /* Figure out what kind of object we've got based on previous declarations
16918      of or references to the object. */
16919
16920   if (sa & FFESYMBOL_attrsEXTERNAL)
16921     {
16922       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16923                        | FFESYMBOL_attrsDUMMY
16924                        | FFESYMBOL_attrsEXTERNAL
16925                        | FFESYMBOL_attrsTYPE)));
16926
16927       if (sa & FFESYMBOL_attrsTYPE)
16928         where = FFEINFO_whereGLOBAL;
16929       else
16930         /* Not TYPE. */
16931         {
16932           kind = FFEINFO_kindFUNCTION;
16933           needs_type = TRUE;
16934
16935           if (sa & FFESYMBOL_attrsDUMMY)
16936             ;                   /* Not TYPE. */
16937           else if (sa & FFESYMBOL_attrsACTUALARG)
16938             ;                   /* Not DUMMY or TYPE. */
16939           else                  /* Not ACTUALARG, DUMMY, or TYPE. */
16940             where = FFEINFO_whereGLOBAL;
16941         }
16942     }
16943   else if (sa & FFESYMBOL_attrsDUMMY)
16944     {
16945       assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16946       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16947                        | FFESYMBOL_attrsEXTERNAL
16948                        | FFESYMBOL_attrsTYPE)));
16949
16950       kind = FFEINFO_kindFUNCTION;
16951       if (!(sa & FFESYMBOL_attrsTYPE))
16952         needs_type = TRUE;
16953     }
16954   else if (sa & FFESYMBOL_attrsARRAY)
16955     {
16956       assert (!(sa & ~(FFESYMBOL_attrsARRAY
16957                        | FFESYMBOL_attrsADJUSTABLE
16958                        | FFESYMBOL_attrsTYPE)));
16959
16960       error = TRUE;
16961     }
16962   else if (sa & FFESYMBOL_attrsSFARG)
16963     {
16964       assert (!(sa & ~(FFESYMBOL_attrsSFARG
16965                        | FFESYMBOL_attrsTYPE)));
16966
16967       error = TRUE;
16968     }
16969   else if (sa & FFESYMBOL_attrsTYPE)
16970     {
16971       assert (!(sa & (FFESYMBOL_attrsARRAY
16972                       | FFESYMBOL_attrsDUMMY
16973                       | FFESYMBOL_attrsEXTERNAL
16974                       | FFESYMBOL_attrsSFARG)));        /* Handled above. */
16975       assert (!(sa & ~(FFESYMBOL_attrsTYPE
16976                        | FFESYMBOL_attrsADJUSTABLE
16977                        | FFESYMBOL_attrsANYLEN
16978                        | FFESYMBOL_attrsARRAY
16979                        | FFESYMBOL_attrsDUMMY
16980                        | FFESYMBOL_attrsEXTERNAL
16981                        | FFESYMBOL_attrsSFARG)));
16982
16983       if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16984         error = TRUE;
16985       else
16986         {
16987           kind = FFEINFO_kindFUNCTION;
16988           where = FFEINFO_whereGLOBAL;
16989         }
16990     }
16991   else if (sa == FFESYMBOL_attrsetNONE)
16992     {
16993       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16994       kind = FFEINFO_kindFUNCTION;
16995       where = FFEINFO_whereGLOBAL;
16996       needs_type = TRUE;
16997     }
16998   else
16999     error = TRUE;
17000
17001   /* Now see what we've got for a new object: NONE means a new error cropped
17002      up; ANY means an old error to be ignored; otherwise, everything's ok,
17003      update the object (symbol) and continue on. */
17004
17005   if (error)
17006     ffesymbol_error (s, t);
17007   else if (!(na & FFESYMBOL_attrsANY))
17008     {
17009       ffesymbol_signal_change (s);      /* May need to back up to previous
17010                                            version. */
17011       if (needs_type && !ffeimplic_establish_symbol (s))
17012         {
17013           ffesymbol_error (s, t);
17014           return s;
17015         }
17016       if (!ffesymbol_explicitwhere (s))
17017         {
17018           ffebad_start (FFEBAD_NEED_EXTERNAL);
17019           ffebad_here (0, ffelex_token_where_line (t),
17020                        ffelex_token_where_column (t));
17021           ffebad_string (ffesymbol_text (s));
17022           ffebad_finish ();
17023           ffesymbol_set_explicitwhere (s, TRUE);
17024         }
17025       ffesymbol_set_info (s,
17026                           ffeinfo_new (ffesymbol_basictype (s),
17027                                        ffesymbol_kindtype (s),
17028                                        ffesymbol_rank (s),
17029                                        kind,    /* FUNCTION. */
17030                                        where,   /* GLOBAL or DUMMY. */
17031                                        ffesymbol_size (s)));
17032       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17033       ffesymbol_resolve_intrin (s);
17034       ffesymbol_reference (s, t, FALSE);
17035       s = ffecom_sym_learned (s);
17036       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
17037     }
17038
17039   return s;
17040 }
17041
17042 /* Have FOO in DATA (stuff,FOO=1,10)/.../.  */
17043
17044 static ffesymbol
17045 ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t)
17046 {
17047   ffesymbolState ss;
17048
17049   /* If the symbol isn't in the sfunc name space, pretend as though we saw a
17050      reference to it already within the imp-DO construct at this level, so as
17051      to get a symbol that is in the sfunc name space. But this is an
17052      erroneous construct, and should be caught elsewhere.  */
17053
17054   if (ffesymbol_sfdummyparent (s) == NULL)
17055     {
17056       s = ffeexpr_sym_impdoitem_ (s, t);
17057       if (ffesymbol_sfdummyparent (s) == NULL)
17058         {                       /* PARAMETER FOO...DATA (A(I),FOO=...). */
17059           ffesymbol_error (s, t);
17060           return s;
17061         }
17062     }
17063
17064   ss = ffesymbol_state (s);
17065
17066   switch (ss)
17067     {
17068     case FFESYMBOL_stateNONE:   /* Used as iterator already. */
17069       if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
17070         ffesymbol_error (s, t); /* Can't reuse dead iterator.  F90 disallows
17071                                    this; F77 allows it but it is a stupid
17072                                    feature. */
17073       else
17074         {                       /* Can use dead iterator because we're at at
17075                                    least a innermore (higher-numbered) level
17076                                    than the iterator's outermost
17077                                    (lowest-numbered) level.  This should be
17078                                    diagnosed later, because it means an item
17079                                    in this list didn't reference this
17080                                    iterator. */
17081 #if 1
17082           ffesymbol_error (s, t);       /* For now, complain. */
17083 #else /* Someday will detect all cases where initializer doesn't reference
17084          all applicable iterators, in which case reenable this code. */
17085           ffesymbol_signal_change (s);
17086           ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
17087           ffesymbol_set_maxentrynum (s, ffeexpr_level_);
17088           ffesymbol_signal_unreported (s);
17089 #endif
17090         }
17091       break;
17092
17093     case FFESYMBOL_stateSEEN:   /* Seen already in this or other implied-DO.
17094                                    If seen in outermore level, can't be an
17095                                    iterator here, so complain.  If not seen
17096                                    at current level, complain for now,
17097                                    because that indicates something F90
17098                                    rejects (though we currently don't detect
17099                                    all such cases for now). */
17100       if (ffeexpr_level_ <= ffesymbol_maxentrynum (s))
17101         {
17102           ffesymbol_signal_change (s);
17103           ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
17104           ffesymbol_signal_unreported (s);
17105         }
17106       else
17107         ffesymbol_error (s, t);
17108       break;
17109
17110     case FFESYMBOL_stateUNCERTAIN:      /* Already iterator! */
17111       assert ("DATA implied-DO control var seen twice!!" == NULL);
17112       ffesymbol_error (s, t);
17113       break;
17114
17115     case FFESYMBOL_stateUNDERSTOOD:
17116       break;                    /* ANY. */
17117
17118     default:
17119       assert ("Foo Bletch!!" == NULL);
17120       break;
17121     }
17122
17123   return s;
17124 }
17125
17126 /* Have FOO in PARAMETER (FOO=...).  */
17127
17128 static ffesymbol
17129 ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t)
17130 {
17131   ffesymbolAttrs sa;
17132
17133   sa = ffesymbol_attrs (s);
17134
17135   /* Figure out what kind of object we've got based on previous declarations
17136      of or references to the object. */
17137
17138   if (sa & ~(FFESYMBOL_attrsANYLEN
17139              | FFESYMBOL_attrsTYPE))
17140     {
17141       if (!(sa & FFESYMBOL_attrsANY))
17142         ffesymbol_error (s, t);
17143     }
17144   else
17145     {
17146       ffesymbol_signal_change (s);      /* May need to back up to previous
17147                                            version. */
17148       if (!ffeimplic_establish_symbol (s))
17149         {
17150           ffesymbol_error (s, t);
17151           return s;
17152         }
17153       ffesymbol_set_info (s,
17154                           ffeinfo_new (ffesymbol_basictype (s),
17155                                        ffesymbol_kindtype (s),
17156                                        ffesymbol_rank (s),
17157                                        FFEINFO_kindENTITY,
17158                                        FFEINFO_whereCONSTANT,
17159                                        ffesymbol_size (s)));
17160       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17161       ffesymbol_resolve_intrin (s);
17162       s = ffecom_sym_learned (s);
17163       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
17164     }
17165
17166   return s;
17167 }
17168
17169 /* Have FOO in CALL XYZ(...,FOO,...).  Does not include any other
17170    embedding of FOO, such as CALL XYZ((FOO)) or CALL XYZ(FOO+1).  */
17171
17172 static ffesymbol
17173 ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t)
17174 {
17175   ffesymbolAttrs sa;
17176   ffesymbolAttrs na;
17177   ffeinfoKind kind;
17178   ffeinfoWhere where;
17179   ffesymbolState ns;
17180   bool needs_type = FALSE;
17181
17182   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
17183           || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
17184
17185   na = sa = ffesymbol_attrs (s);
17186
17187   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17188                    | FFESYMBOL_attrsADJUSTABLE
17189                    | FFESYMBOL_attrsANYLEN
17190                    | FFESYMBOL_attrsARRAY
17191                    | FFESYMBOL_attrsDUMMY
17192                    | FFESYMBOL_attrsEXTERNAL
17193                    | FFESYMBOL_attrsSFARG
17194                    | FFESYMBOL_attrsTYPE)));
17195
17196   kind = ffesymbol_kind (s);
17197   where = ffesymbol_where (s);
17198
17199   /* Figure out what kind of object we've got based on previous declarations
17200      of or references to the object. */
17201
17202   ns = FFESYMBOL_stateUNDERSTOOD;
17203
17204   if (sa & FFESYMBOL_attrsEXTERNAL)
17205     {
17206       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17207                        | FFESYMBOL_attrsDUMMY
17208                        | FFESYMBOL_attrsEXTERNAL
17209                        | FFESYMBOL_attrsTYPE)));
17210
17211       if (sa & FFESYMBOL_attrsTYPE)
17212         where = FFEINFO_whereGLOBAL;
17213       else
17214         /* Not TYPE. */
17215         {
17216           ns = FFESYMBOL_stateUNCERTAIN;
17217
17218           if (sa & FFESYMBOL_attrsDUMMY)
17219             assert (kind == FFEINFO_kindNONE);  /* FUNCTION, SUBROUTINE. */
17220           else if (sa & FFESYMBOL_attrsACTUALARG)
17221             ;                   /* Not DUMMY or TYPE. */
17222           else
17223             /* Not ACTUALARG, DUMMY, or TYPE. */
17224             {
17225               assert (kind == FFEINFO_kindNONE);        /* FUNCTION, SUBROUTINE. */
17226               na |= FFESYMBOL_attrsACTUALARG;
17227               where = FFEINFO_whereGLOBAL;
17228             }
17229         }
17230     }
17231   else if (sa & FFESYMBOL_attrsDUMMY)
17232     {
17233       assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
17234       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
17235                        | FFESYMBOL_attrsEXTERNAL
17236                        | FFESYMBOL_attrsTYPE)));
17237
17238       kind = FFEINFO_kindENTITY;
17239       if (!(sa & FFESYMBOL_attrsTYPE))
17240         needs_type = TRUE;
17241     }
17242   else if (sa & FFESYMBOL_attrsARRAY)
17243     {
17244       assert (!(sa & ~(FFESYMBOL_attrsARRAY
17245                        | FFESYMBOL_attrsADJUSTABLE
17246                        | FFESYMBOL_attrsTYPE)));
17247
17248       where = FFEINFO_whereLOCAL;
17249     }
17250   else if (sa & FFESYMBOL_attrsSFARG)
17251     {
17252       assert (!(sa & ~(FFESYMBOL_attrsSFARG
17253                        | FFESYMBOL_attrsTYPE)));
17254
17255       where = FFEINFO_whereLOCAL;
17256     }
17257   else if (sa & FFESYMBOL_attrsTYPE)
17258     {
17259       assert (!(sa & (FFESYMBOL_attrsARRAY
17260                       | FFESYMBOL_attrsDUMMY
17261                       | FFESYMBOL_attrsEXTERNAL
17262                       | FFESYMBOL_attrsSFARG)));        /* Handled above. */
17263       assert (!(sa & ~(FFESYMBOL_attrsTYPE
17264                        | FFESYMBOL_attrsADJUSTABLE
17265                        | FFESYMBOL_attrsANYLEN
17266                        | FFESYMBOL_attrsARRAY
17267                        | FFESYMBOL_attrsDUMMY
17268                        | FFESYMBOL_attrsEXTERNAL
17269                        | FFESYMBOL_attrsSFARG)));
17270
17271       if (sa & FFESYMBOL_attrsANYLEN)
17272         ns = FFESYMBOL_stateNONE;
17273       else
17274         {
17275           kind = FFEINFO_kindENTITY;
17276           where = FFEINFO_whereLOCAL;
17277         }
17278     }
17279   else if (sa == FFESYMBOL_attrsetNONE)
17280     {
17281       /* New state is left empty because there isn't any state flag to
17282          set for this case, and it's UNDERSTOOD after all.  */
17283       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
17284       kind = FFEINFO_kindENTITY;
17285       where = FFEINFO_whereLOCAL;
17286       needs_type = TRUE;
17287     }
17288   else
17289     ns = FFESYMBOL_stateNONE;   /* Error. */
17290
17291   /* Now see what we've got for a new object: NONE means a new error cropped
17292      up; ANY means an old error to be ignored; otherwise, everything's ok,
17293      update the object (symbol) and continue on. */
17294
17295   if (ns == FFESYMBOL_stateNONE)
17296     ffesymbol_error (s, t);
17297   else if (!(na & FFESYMBOL_attrsANY))
17298     {
17299       ffesymbol_signal_change (s);      /* May need to back up to previous
17300                                            version. */
17301       if (needs_type && !ffeimplic_establish_symbol (s))
17302         {
17303           ffesymbol_error (s, t);
17304           return s;
17305         }
17306       ffesymbol_set_info (s,
17307                           ffeinfo_new (ffesymbol_basictype (s),
17308                                        ffesymbol_kindtype (s),
17309                                        ffesymbol_rank (s),
17310                                        kind,
17311                                        where,
17312                                        ffesymbol_size (s)));
17313       ffesymbol_set_attrs (s, na);
17314       ffesymbol_set_state (s, ns);
17315       s = ffecom_sym_learned (s);
17316       ffesymbol_reference (s, t, FALSE);
17317       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
17318     }
17319
17320   return s;
17321 }
17322
17323 /* Have FOO in DIMENSION XYZ(FOO) or any array declarator containing
17324    a reference to FOO.  */
17325
17326 static ffesymbol
17327 ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t)
17328 {
17329   ffesymbolAttrs sa;
17330   ffesymbolAttrs na;
17331   ffeinfoKind kind;
17332   ffeinfoWhere where;
17333
17334   na = sa = ffesymbol_attrs (s);
17335   kind = FFEINFO_kindENTITY;
17336   where = ffesymbol_where (s);
17337
17338   /* Figure out what kind of object we've got based on previous declarations
17339      of or references to the object. */
17340
17341   if (!(sa & ~(FFESYMBOL_attrsADJUSTS
17342                | FFESYMBOL_attrsCOMMON
17343                | FFESYMBOL_attrsDUMMY
17344                | FFESYMBOL_attrsEQUIV
17345                | FFESYMBOL_attrsINIT
17346                | FFESYMBOL_attrsNAMELIST
17347                | FFESYMBOL_attrsSFARG
17348                | FFESYMBOL_attrsARRAY
17349                | FFESYMBOL_attrsTYPE)))
17350     na = sa | FFESYMBOL_attrsADJUSTS;
17351   else
17352     na = FFESYMBOL_attrsetNONE;
17353
17354   /* Since this symbol definitely is going into an expression (the
17355      dimension-list for some dummy array, presumably), figure out WHERE if
17356      possible.  */
17357
17358   if (where == FFEINFO_whereNONE)
17359     {
17360       if (na & (FFESYMBOL_attrsCOMMON
17361                 | FFESYMBOL_attrsEQUIV
17362                 | FFESYMBOL_attrsINIT
17363                 | FFESYMBOL_attrsNAMELIST))
17364         where = FFEINFO_whereCOMMON;
17365       else if (na & FFESYMBOL_attrsDUMMY)
17366         where = FFEINFO_whereDUMMY;
17367     }
17368
17369   /* Now see what we've got for a new object: NONE means a new error cropped
17370      up; ANY means an old error to be ignored; otherwise, everything's ok,
17371      update the object (symbol) and continue on. */
17372
17373   if (na == FFESYMBOL_attrsetNONE)
17374     ffesymbol_error (s, t);
17375   else if (!(na & FFESYMBOL_attrsANY))
17376     {
17377       ffesymbol_signal_change (s);      /* May need to back up to previous
17378                                            version. */
17379       if (!ffeimplic_establish_symbol (s))
17380         {
17381           ffesymbol_error (s, t);
17382           return s;
17383         }
17384       ffesymbol_set_info (s,
17385                           ffeinfo_new (ffesymbol_basictype (s),
17386                                        ffesymbol_kindtype (s),
17387                                        ffesymbol_rank (s),
17388                                        kind,    /* Always ENTITY. */
17389                                        where,   /* NONE, COMMON, or DUMMY. */
17390                                        ffesymbol_size (s)));
17391       ffesymbol_set_attrs (s, na);
17392       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
17393       ffesymbol_resolve_intrin (s);
17394       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
17395     }
17396
17397   return s;
17398 }
17399
17400 /* Have FOO in XYZ = ...FOO....  Does not include cases like FOO in
17401    XYZ = BAR(FOO), as such cases are handled elsewhere.  */
17402
17403 static ffesymbol
17404 ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t)
17405 {
17406   ffesymbolAttrs sa;
17407   ffesymbolAttrs na;
17408   ffeinfoKind kind;
17409   ffeinfoWhere where;
17410   bool error = FALSE;
17411
17412   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
17413           || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
17414
17415   na = sa = ffesymbol_attrs (s);
17416
17417   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17418                    | FFESYMBOL_attrsADJUSTABLE
17419                    | FFESYMBOL_attrsANYLEN
17420                    | FFESYMBOL_attrsARRAY
17421                    | FFESYMBOL_attrsDUMMY
17422                    | FFESYMBOL_attrsEXTERNAL
17423                    | FFESYMBOL_attrsSFARG
17424                    | FFESYMBOL_attrsTYPE)));
17425
17426   kind = ffesymbol_kind (s);
17427   where = ffesymbol_where (s);
17428
17429   /* Figure out what kind of object we've got based on previous declarations
17430      of or references to the object. */
17431
17432   if (sa & FFESYMBOL_attrsEXTERNAL)
17433     {
17434       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17435                        | FFESYMBOL_attrsDUMMY
17436                        | FFESYMBOL_attrsEXTERNAL
17437                        | FFESYMBOL_attrsTYPE)));
17438
17439       error = TRUE;
17440     }
17441   else if (sa & FFESYMBOL_attrsDUMMY)
17442     {
17443       assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
17444       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
17445                        | FFESYMBOL_attrsEXTERNAL
17446                        | FFESYMBOL_attrsTYPE)));
17447
17448       kind = FFEINFO_kindENTITY;
17449     }
17450   else if (sa & FFESYMBOL_attrsARRAY)
17451     {
17452       assert (!(sa & ~(FFESYMBOL_attrsARRAY
17453                        | FFESYMBOL_attrsADJUSTABLE
17454                        | FFESYMBOL_attrsTYPE)));
17455
17456       where = FFEINFO_whereLOCAL;
17457     }
17458   else if (sa & FFESYMBOL_attrsSFARG)
17459     {
17460       assert (!(sa & ~(FFESYMBOL_attrsSFARG
17461                        | FFESYMBOL_attrsTYPE)));
17462
17463       where = FFEINFO_whereLOCAL;
17464     }
17465   else if (sa & FFESYMBOL_attrsTYPE)
17466     {
17467       assert (!(sa & (FFESYMBOL_attrsARRAY
17468                       | FFESYMBOL_attrsDUMMY
17469                       | FFESYMBOL_attrsEXTERNAL
17470                       | FFESYMBOL_attrsSFARG)));        /* Handled above. */
17471       assert (!(sa & ~(FFESYMBOL_attrsTYPE
17472                        | FFESYMBOL_attrsADJUSTABLE
17473                        | FFESYMBOL_attrsANYLEN
17474                        | FFESYMBOL_attrsARRAY
17475                        | FFESYMBOL_attrsDUMMY
17476                        | FFESYMBOL_attrsEXTERNAL
17477                        | FFESYMBOL_attrsSFARG)));
17478
17479       if (sa & FFESYMBOL_attrsANYLEN)
17480         error = TRUE;
17481       else
17482         {
17483           kind = FFEINFO_kindENTITY;
17484           where = FFEINFO_whereLOCAL;
17485         }
17486     }
17487   else if (sa == FFESYMBOL_attrsetNONE)
17488     {
17489       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
17490       kind = FFEINFO_kindENTITY;
17491       where = FFEINFO_whereLOCAL;
17492     }
17493   else
17494     error = TRUE;
17495
17496   /* Now see what we've got for a new object: NONE means a new error cropped
17497      up; ANY means an old error to be ignored; otherwise, everything's ok,
17498      update the object (symbol) and continue on. */
17499
17500   if (error)
17501     ffesymbol_error (s, t);
17502   else if (!(na & FFESYMBOL_attrsANY))
17503     {
17504       ffesymbol_signal_change (s);      /* May need to back up to previous
17505                                            version. */
17506       if (!ffeimplic_establish_symbol (s))
17507         {
17508           ffesymbol_error (s, t);
17509           return s;
17510         }
17511       ffesymbol_set_info (s,
17512                           ffeinfo_new (ffesymbol_basictype (s),
17513                                        ffesymbol_kindtype (s),
17514                                        ffesymbol_rank (s),
17515                                        kind,    /* ENTITY. */
17516                                        where,   /* LOCAL. */
17517                                        ffesymbol_size (s)));
17518       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17519       ffesymbol_resolve_intrin (s);
17520       s = ffecom_sym_learned (s);
17521       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
17522     }
17523
17524   return s;
17525 }
17526
17527 /* ffeexpr_declare_parenthesized_ -- ffesymbol wrapper for NAME(...) operand
17528
17529    ffelexToken t;
17530    bool maybe_intrin;
17531    ffeexprParenType_ paren_type;
17532    ffesymbol s;
17533    s = ffeexpr_declare_parenthesized_ (t, maybe_intrin, &paren_type);
17534
17535    Just like ffesymbol_declare_local, except performs any implicit info
17536    assignment necessary, and it returns the type of the parenthesized list
17537    (list of function args, list of array args, or substring spec).  */
17538
17539 static ffesymbol
17540 ffeexpr_declare_parenthesized_ (ffelexToken t, bool maybe_intrin,
17541                                 ffeexprParenType_ *paren_type)
17542 {
17543   ffesymbol s;
17544   ffesymbolState st;            /* Effective state. */
17545   ffeinfoKind k;
17546   bool bad;
17547
17548   if (maybe_intrin && ffesrc_check_symbol ())
17549     {                           /* Knock off some easy cases. */
17550       switch (ffeexpr_stack_->context)
17551         {
17552         case FFEEXPR_contextSUBROUTINEREF:
17553         case FFEEXPR_contextDATA:
17554         case FFEEXPR_contextDATAIMPDOINDEX_:
17555         case FFEEXPR_contextSFUNCDEF:
17556         case FFEEXPR_contextSFUNCDEFINDEX_:
17557         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17558         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17559         case FFEEXPR_contextLET:
17560         case FFEEXPR_contextPAREN_:
17561         case FFEEXPR_contextACTUALARGEXPR_:
17562         case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17563         case FFEEXPR_contextIOLIST:
17564         case FFEEXPR_contextIOLISTDF:
17565         case FFEEXPR_contextDO:
17566         case FFEEXPR_contextDOWHILE:
17567         case FFEEXPR_contextACTUALARG_:
17568         case FFEEXPR_contextCGOTO:
17569         case FFEEXPR_contextIF:
17570         case FFEEXPR_contextARITHIF:
17571         case FFEEXPR_contextFORMAT:
17572         case FFEEXPR_contextSTOP:
17573         case FFEEXPR_contextRETURN:
17574         case FFEEXPR_contextSELECTCASE:
17575         case FFEEXPR_contextCASE:
17576         case FFEEXPR_contextFILEASSOC:
17577         case FFEEXPR_contextFILEINT:
17578         case FFEEXPR_contextFILEDFINT:
17579         case FFEEXPR_contextFILELOG:
17580         case FFEEXPR_contextFILENUM:
17581         case FFEEXPR_contextFILENUMAMBIG:
17582         case FFEEXPR_contextFILECHAR:
17583         case FFEEXPR_contextFILENUMCHAR:
17584         case FFEEXPR_contextFILEDFCHAR:
17585         case FFEEXPR_contextFILEKEY:
17586         case FFEEXPR_contextFILEUNIT:
17587         case FFEEXPR_contextFILEUNIT_DF:
17588         case FFEEXPR_contextFILEUNITAMBIG:
17589         case FFEEXPR_contextFILEFORMAT:
17590         case FFEEXPR_contextFILENAMELIST:
17591         case FFEEXPR_contextFILEVXTCODE:
17592         case FFEEXPR_contextINDEX_:
17593         case FFEEXPR_contextIMPDOITEM_:
17594         case FFEEXPR_contextIMPDOITEMDF_:
17595         case FFEEXPR_contextIMPDOCTRL_:
17596         case FFEEXPR_contextDATAIMPDOCTRL_:
17597         case FFEEXPR_contextCHARACTERSIZE:
17598         case FFEEXPR_contextPARAMETER:
17599         case FFEEXPR_contextDIMLIST:
17600         case FFEEXPR_contextDIMLISTCOMMON:
17601         case FFEEXPR_contextKINDTYPE:
17602         case FFEEXPR_contextINITVAL:
17603         case FFEEXPR_contextEQVINDEX_:
17604           break;                /* These could be intrinsic invocations. */
17605
17606         case FFEEXPR_contextAGOTO:
17607         case FFEEXPR_contextFILEFORMATNML:
17608         case FFEEXPR_contextALLOCATE:
17609         case FFEEXPR_contextDEALLOCATE:
17610         case FFEEXPR_contextHEAPSTAT:
17611         case FFEEXPR_contextNULLIFY:
17612         case FFEEXPR_contextINCLUDE:
17613         case FFEEXPR_contextDATAIMPDOITEM_:
17614         case FFEEXPR_contextLOC_:
17615         case FFEEXPR_contextINDEXORACTUALARG_:
17616         case FFEEXPR_contextSFUNCDEFACTUALARG_:
17617         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
17618         case FFEEXPR_contextPARENFILENUM_:
17619         case FFEEXPR_contextPARENFILEUNIT_:
17620           maybe_intrin = FALSE;
17621           break;                /* Can't be intrinsic invocation. */
17622
17623         default:
17624           assert ("blah! blah! waaauuggh!" == NULL);
17625           break;
17626         }
17627     }
17628
17629   s = ffesymbol_declare_local (t, maybe_intrin);
17630
17631   switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17632     /* Special-case these since they can involve a different concept
17633        of "state" (in the stmtfunc name space).  */
17634     {
17635     case FFEEXPR_contextDATAIMPDOINDEX_:
17636     case FFEEXPR_contextDATAIMPDOCTRL_:
17637       if (ffeexpr_context_outer_ (ffeexpr_stack_)
17638           == FFEEXPR_contextDATAIMPDOINDEX_)
17639         s = ffeexpr_sym_impdoitem_ (s, t);
17640       else
17641         if (ffeexpr_stack_->is_rhs)
17642           s = ffeexpr_sym_impdoitem_ (s, t);
17643         else
17644           s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
17645       if (ffesymbol_kind (s) != FFEINFO_kindANY)
17646         ffesymbol_error (s, t);
17647       return s;
17648
17649     default:
17650       break;
17651     }
17652
17653   switch ((ffesymbol_sfdummyparent (s) == NULL)
17654           ? ffesymbol_state (s)
17655           : FFESYMBOL_stateUNDERSTOOD)
17656     {
17657     case FFESYMBOL_stateNONE:   /* Before first exec, not seen in expr
17658                                    context. */
17659       if (!ffest_seen_first_exec ())
17660         goto seen;              /* :::::::::::::::::::: */
17661       /* Fall through. */
17662     case FFESYMBOL_stateUNCERTAIN:      /* Unseen since first exec. */
17663       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17664         {
17665         case FFEEXPR_contextSUBROUTINEREF:
17666           s = ffeexpr_sym_lhs_call_ (s, t);     /* "CALL FOO"=="CALL
17667                                                    FOO(...)". */
17668           break;
17669
17670         case FFEEXPR_contextDATA:
17671           if (ffeexpr_stack_->is_rhs)
17672             s = ffeexpr_sym_rhs_let_ (s, t);
17673           else
17674             s = ffeexpr_sym_lhs_data_ (s, t);
17675           break;
17676
17677         case FFEEXPR_contextDATAIMPDOITEM_:
17678           s = ffeexpr_sym_lhs_data_ (s, t);
17679           break;
17680
17681         case FFEEXPR_contextSFUNCDEF:
17682         case FFEEXPR_contextSFUNCDEFINDEX_:
17683         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17684         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17685           s = ffecom_sym_exec_transition (s);
17686           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17687             goto understood;    /* :::::::::::::::::::: */
17688           /* Fall through. */
17689         case FFEEXPR_contextLET:
17690         case FFEEXPR_contextPAREN_:
17691         case FFEEXPR_contextACTUALARGEXPR_:
17692         case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17693         case FFEEXPR_contextIOLIST:
17694         case FFEEXPR_contextIOLISTDF:
17695         case FFEEXPR_contextDO:
17696         case FFEEXPR_contextDOWHILE:
17697         case FFEEXPR_contextACTUALARG_:
17698         case FFEEXPR_contextCGOTO:
17699         case FFEEXPR_contextIF:
17700         case FFEEXPR_contextARITHIF:
17701         case FFEEXPR_contextFORMAT:
17702         case FFEEXPR_contextSTOP:
17703         case FFEEXPR_contextRETURN:
17704         case FFEEXPR_contextSELECTCASE:
17705         case FFEEXPR_contextCASE:
17706         case FFEEXPR_contextFILEASSOC:
17707         case FFEEXPR_contextFILEINT:
17708         case FFEEXPR_contextFILEDFINT:
17709         case FFEEXPR_contextFILELOG:
17710         case FFEEXPR_contextFILENUM:
17711         case FFEEXPR_contextFILENUMAMBIG:
17712         case FFEEXPR_contextFILECHAR:
17713         case FFEEXPR_contextFILENUMCHAR:
17714         case FFEEXPR_contextFILEDFCHAR:
17715         case FFEEXPR_contextFILEKEY:
17716         case FFEEXPR_contextFILEUNIT:
17717         case FFEEXPR_contextFILEUNIT_DF:
17718         case FFEEXPR_contextFILEUNITAMBIG:
17719         case FFEEXPR_contextFILEFORMAT:
17720         case FFEEXPR_contextFILENAMELIST:
17721         case FFEEXPR_contextFILEVXTCODE:
17722         case FFEEXPR_contextINDEX_:
17723         case FFEEXPR_contextIMPDOITEM_:
17724         case FFEEXPR_contextIMPDOITEMDF_:
17725         case FFEEXPR_contextIMPDOCTRL_:
17726         case FFEEXPR_contextLOC_:
17727           if (ffeexpr_stack_->is_rhs)
17728             s = ffeexpr_paren_rhs_let_ (s, t);
17729           else
17730             s = ffeexpr_paren_lhs_let_ (s, t);
17731           break;
17732
17733         case FFEEXPR_contextASSIGN:
17734         case FFEEXPR_contextAGOTO:
17735         case FFEEXPR_contextCHARACTERSIZE:
17736         case FFEEXPR_contextEQUIVALENCE:
17737         case FFEEXPR_contextINCLUDE:
17738         case FFEEXPR_contextPARAMETER:
17739         case FFEEXPR_contextDIMLIST:
17740         case FFEEXPR_contextDIMLISTCOMMON:
17741         case FFEEXPR_contextKINDTYPE:
17742         case FFEEXPR_contextINITVAL:
17743         case FFEEXPR_contextEQVINDEX_:
17744           break;                /* Will turn into errors below. */
17745
17746         default:
17747           ffesymbol_error (s, t);
17748           break;
17749         }
17750       /* Fall through. */
17751     case FFESYMBOL_stateUNDERSTOOD:     /* Nothing much more to learn. */
17752     understood:         /* :::::::::::::::::::: */
17753
17754       /* State might have changed, update it.  */
17755       st = ((ffesymbol_sfdummyparent (s) == NULL)
17756             ? ffesymbol_state (s)
17757             : FFESYMBOL_stateUNDERSTOOD);
17758
17759       k = ffesymbol_kind (s);
17760       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17761         {
17762         case FFEEXPR_contextSUBROUTINEREF:
17763           bad = ((k != FFEINFO_kindSUBROUTINE)
17764                  && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
17765                      || (k != FFEINFO_kindNONE)));
17766           break;
17767
17768         case FFEEXPR_contextDATA:
17769           if (ffeexpr_stack_->is_rhs)
17770             bad = (k != FFEINFO_kindENTITY)
17771               || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
17772           else
17773             bad = (k != FFEINFO_kindENTITY)
17774               || ((ffesymbol_where (s) != FFEINFO_whereNONE)
17775                   && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
17776                   && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
17777           break;
17778
17779         case FFEEXPR_contextDATAIMPDOITEM_:
17780           bad = (k != FFEINFO_kindENTITY) || (ffesymbol_rank (s) == 0)
17781             || ((ffesymbol_where (s) != FFEINFO_whereNONE)
17782                 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
17783                 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
17784           break;
17785
17786         case FFEEXPR_contextSFUNCDEF:
17787         case FFEEXPR_contextSFUNCDEFINDEX_:
17788         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17789         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17790         case FFEEXPR_contextLET:
17791         case FFEEXPR_contextPAREN_:
17792         case FFEEXPR_contextACTUALARGEXPR_:
17793         case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17794         case FFEEXPR_contextIOLIST:
17795         case FFEEXPR_contextIOLISTDF:
17796         case FFEEXPR_contextDO:
17797         case FFEEXPR_contextDOWHILE:
17798         case FFEEXPR_contextACTUALARG_:
17799         case FFEEXPR_contextCGOTO:
17800         case FFEEXPR_contextIF:
17801         case FFEEXPR_contextARITHIF:
17802         case FFEEXPR_contextFORMAT:
17803         case FFEEXPR_contextSTOP:
17804         case FFEEXPR_contextRETURN:
17805         case FFEEXPR_contextSELECTCASE:
17806         case FFEEXPR_contextCASE:
17807         case FFEEXPR_contextFILEASSOC:
17808         case FFEEXPR_contextFILEINT:
17809         case FFEEXPR_contextFILEDFINT:
17810         case FFEEXPR_contextFILELOG:
17811         case FFEEXPR_contextFILENUM:
17812         case FFEEXPR_contextFILENUMAMBIG:
17813         case FFEEXPR_contextFILECHAR:
17814         case FFEEXPR_contextFILENUMCHAR:
17815         case FFEEXPR_contextFILEDFCHAR:
17816         case FFEEXPR_contextFILEKEY:
17817         case FFEEXPR_contextFILEUNIT:
17818         case FFEEXPR_contextFILEUNIT_DF:
17819         case FFEEXPR_contextFILEUNITAMBIG:
17820         case FFEEXPR_contextFILEFORMAT:
17821         case FFEEXPR_contextFILENAMELIST:
17822         case FFEEXPR_contextFILEVXTCODE:
17823         case FFEEXPR_contextINDEX_:
17824         case FFEEXPR_contextIMPDOITEM_:
17825         case FFEEXPR_contextIMPDOITEMDF_:
17826         case FFEEXPR_contextIMPDOCTRL_:
17827         case FFEEXPR_contextLOC_:
17828           bad = FALSE;          /* Let paren-switch handle the cases. */
17829           break;
17830
17831         case FFEEXPR_contextASSIGN:
17832         case FFEEXPR_contextAGOTO:
17833         case FFEEXPR_contextCHARACTERSIZE:
17834         case FFEEXPR_contextEQUIVALENCE:
17835         case FFEEXPR_contextPARAMETER:
17836         case FFEEXPR_contextDIMLIST:
17837         case FFEEXPR_contextDIMLISTCOMMON:
17838         case FFEEXPR_contextKINDTYPE:
17839         case FFEEXPR_contextINITVAL:
17840         case FFEEXPR_contextEQVINDEX_:
17841           bad = (k != FFEINFO_kindENTITY)
17842             || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
17843           break;
17844
17845         case FFEEXPR_contextINCLUDE:
17846           bad = TRUE;
17847           break;
17848
17849         default:
17850           bad = TRUE;
17851           break;
17852         }
17853
17854       switch (bad ? FFEINFO_kindANY : k)
17855         {
17856         case FFEINFO_kindNONE:  /* Case "CHARACTER X,Y; Y=X(?". */
17857           if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
17858             {
17859               if (ffeexpr_context_outer_ (ffeexpr_stack_)
17860                   == FFEEXPR_contextSUBROUTINEREF)
17861                 *paren_type = FFEEXPR_parentypeSUBROUTINE_;
17862               else
17863                 *paren_type = FFEEXPR_parentypeFUNCTION_;
17864               break;
17865             }
17866           if (st == FFESYMBOL_stateUNDERSTOOD)
17867             {
17868               bad = TRUE;
17869               *paren_type = FFEEXPR_parentypeANY_;
17870             }
17871           else
17872             *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
17873           break;
17874
17875         case FFEINFO_kindFUNCTION:
17876           *paren_type = FFEEXPR_parentypeFUNCTION_;
17877           switch (ffesymbol_where (s))
17878             {
17879             case FFEINFO_whereLOCAL:
17880               bad = TRUE;       /* Attempt to recurse! */
17881               break;
17882
17883             case FFEINFO_whereCONSTANT:
17884               bad = ((ffesymbol_sfexpr (s) == NULL)
17885                      || (ffebld_op (ffesymbol_sfexpr (s))
17886                          == FFEBLD_opANY));     /* Attempt to recurse! */
17887               break;
17888
17889             default:
17890               break;
17891             }
17892           break;
17893
17894         case FFEINFO_kindSUBROUTINE:
17895           if ((ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
17896               || (ffeexpr_stack_->previous != NULL))
17897             {
17898               bad = TRUE;
17899               *paren_type = FFEEXPR_parentypeANY_;
17900               break;
17901             }
17902
17903           *paren_type = FFEEXPR_parentypeSUBROUTINE_;
17904           switch (ffesymbol_where (s))
17905             {
17906             case FFEINFO_whereLOCAL:
17907             case FFEINFO_whereCONSTANT:
17908               bad = TRUE;       /* Attempt to recurse! */
17909               break;
17910
17911             default:
17912               break;
17913             }
17914           break;
17915
17916         case FFEINFO_kindENTITY:
17917           if (ffesymbol_rank (s) == 0)
17918             {
17919               if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
17920                 *paren_type = FFEEXPR_parentypeSUBSTRING_;
17921               else
17922                 {
17923                   bad = TRUE;
17924                   *paren_type = FFEEXPR_parentypeANY_;
17925                 }
17926             }
17927           else
17928             *paren_type = FFEEXPR_parentypeARRAY_;
17929           break;
17930
17931         default:
17932         case FFEINFO_kindANY:
17933           bad = TRUE;
17934           *paren_type = FFEEXPR_parentypeANY_;
17935           break;
17936         }
17937
17938       if (bad)
17939         {
17940           if (k == FFEINFO_kindANY)
17941             ffest_shutdown ();
17942           else
17943             ffesymbol_error (s, t);
17944         }
17945
17946       return s;
17947
17948     case FFESYMBOL_stateSEEN:   /* Seen but not yet in exec portion. */
17949     seen:                       /* :::::::::::::::::::: */
17950       bad = TRUE;
17951       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17952         {
17953         case FFEEXPR_contextPARAMETER:
17954           if (ffeexpr_stack_->is_rhs)
17955             ffesymbol_error (s, t);
17956           else
17957             s = ffeexpr_sym_lhs_parameter_ (s, t);
17958           break;
17959
17960         case FFEEXPR_contextDATA:
17961           s = ffecom_sym_exec_transition (s);
17962           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17963             goto understood;    /* :::::::::::::::::::: */
17964           if (ffeexpr_stack_->is_rhs)
17965             ffesymbol_error (s, t);
17966           else
17967             s = ffeexpr_sym_lhs_data_ (s, t);
17968           goto understood;      /* :::::::::::::::::::: */
17969
17970         case FFEEXPR_contextDATAIMPDOITEM_:
17971           s = ffecom_sym_exec_transition (s);
17972           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17973             goto understood;    /* :::::::::::::::::::: */
17974           s = ffeexpr_sym_lhs_data_ (s, t);
17975           goto understood;      /* :::::::::::::::::::: */
17976
17977         case FFEEXPR_contextEQUIVALENCE:
17978           s = ffeexpr_sym_lhs_equivalence_ (s, t);
17979           bad = FALSE;
17980           break;
17981
17982         case FFEEXPR_contextDIMLIST:
17983           s = ffeexpr_sym_rhs_dimlist_ (s, t);
17984           bad = FALSE;
17985           break;
17986
17987         case FFEEXPR_contextCHARACTERSIZE:
17988         case FFEEXPR_contextKINDTYPE:
17989         case FFEEXPR_contextDIMLISTCOMMON:
17990         case FFEEXPR_contextINITVAL:
17991         case FFEEXPR_contextEQVINDEX_:
17992           break;
17993
17994         case FFEEXPR_contextINCLUDE:
17995           break;
17996
17997         case FFEEXPR_contextINDEX_:
17998         case FFEEXPR_contextACTUALARGEXPR_:
17999         case FFEEXPR_contextINDEXORACTUALARGEXPR_:
18000         case FFEEXPR_contextSFUNCDEF:
18001         case FFEEXPR_contextSFUNCDEFINDEX_:
18002         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
18003         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
18004           assert (ffeexpr_stack_->is_rhs);
18005           s = ffecom_sym_exec_transition (s);
18006           if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
18007             goto understood;    /* :::::::::::::::::::: */
18008           s = ffeexpr_paren_rhs_let_ (s, t);
18009           goto understood;      /* :::::::::::::::::::: */
18010
18011         default:
18012           break;
18013         }
18014       k = ffesymbol_kind (s);
18015       switch (bad ? FFEINFO_kindANY : k)
18016         {
18017         case FFEINFO_kindNONE:  /* Case "CHARACTER X,Y; Y=X(?". */
18018           *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
18019           break;
18020
18021         case FFEINFO_kindFUNCTION:
18022           *paren_type = FFEEXPR_parentypeFUNCTION_;
18023           switch (ffesymbol_where (s))
18024             {
18025             case FFEINFO_whereLOCAL:
18026               bad = TRUE;       /* Attempt to recurse! */
18027               break;
18028
18029             case FFEINFO_whereCONSTANT:
18030               bad = ((ffesymbol_sfexpr (s) == NULL)
18031                      || (ffebld_op (ffesymbol_sfexpr (s))
18032                          == FFEBLD_opANY));     /* Attempt to recurse! */
18033               break;
18034
18035             default:
18036               break;
18037             }
18038           break;
18039
18040         case FFEINFO_kindSUBROUTINE:
18041           *paren_type = FFEEXPR_parentypeANY_;
18042           bad = TRUE;           /* Cannot possibly be in
18043                                    contextSUBROUTINEREF. */
18044           break;
18045
18046         case FFEINFO_kindENTITY:
18047           if (ffesymbol_rank (s) == 0)
18048             {
18049               if (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE)
18050                 *paren_type = FFEEXPR_parentypeEQUIVALENCE_;
18051               else if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
18052                 *paren_type = FFEEXPR_parentypeSUBSTRING_;
18053               else
18054                 {
18055                   bad = TRUE;
18056                   *paren_type = FFEEXPR_parentypeANY_;
18057                 }
18058             }
18059           else
18060             *paren_type = FFEEXPR_parentypeARRAY_;
18061           break;
18062
18063         default:
18064         case FFEINFO_kindANY:
18065           bad = TRUE;
18066           *paren_type = FFEEXPR_parentypeANY_;
18067           break;
18068         }
18069
18070       if (bad)
18071         {
18072           if (k == FFEINFO_kindANY)
18073             ffest_shutdown ();
18074           else
18075             ffesymbol_error (s, t);
18076         }
18077
18078       return s;
18079
18080     default:
18081       assert ("bad symbol state" == NULL);
18082       return NULL;
18083     }
18084 }
18085
18086 /* Have FOO in XYZ = ...FOO(...)....  Executable context only.  */
18087
18088 static ffesymbol
18089 ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t)
18090 {
18091   ffesymbolAttrs sa;
18092   ffesymbolAttrs na;
18093   ffeinfoKind kind;
18094   ffeinfoWhere where;
18095   ffeintrinGen gen;
18096   ffeintrinSpec spec;
18097   ffeintrinImp imp;
18098   bool maybe_ambig = FALSE;
18099   bool error = FALSE;
18100
18101   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
18102           || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
18103
18104   na = sa = ffesymbol_attrs (s);
18105
18106   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
18107                    | FFESYMBOL_attrsADJUSTABLE
18108                    | FFESYMBOL_attrsANYLEN
18109                    | FFESYMBOL_attrsARRAY
18110                    | FFESYMBOL_attrsDUMMY
18111                    | FFESYMBOL_attrsEXTERNAL
18112                    | FFESYMBOL_attrsSFARG
18113                    | FFESYMBOL_attrsTYPE)));
18114
18115   kind = ffesymbol_kind (s);
18116   where = ffesymbol_where (s);
18117
18118   /* Figure out what kind of object we've got based on previous declarations
18119      of or references to the object. */
18120
18121   if (sa & FFESYMBOL_attrsEXTERNAL)
18122     {
18123       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
18124                        | FFESYMBOL_attrsDUMMY
18125                        | FFESYMBOL_attrsEXTERNAL
18126                        | FFESYMBOL_attrsTYPE)));
18127
18128       if (sa & FFESYMBOL_attrsTYPE)
18129         where = FFEINFO_whereGLOBAL;
18130       else
18131         /* Not TYPE. */
18132         {
18133           kind = FFEINFO_kindFUNCTION;
18134
18135           if (sa & FFESYMBOL_attrsDUMMY)
18136             ;                   /* Not TYPE. */
18137           else if (sa & FFESYMBOL_attrsACTUALARG)
18138             ;                   /* Not DUMMY or TYPE. */
18139           else                  /* Not ACTUALARG, DUMMY, or TYPE. */
18140             where = FFEINFO_whereGLOBAL;
18141         }
18142     }
18143   else if (sa & FFESYMBOL_attrsDUMMY)
18144     {
18145       assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
18146       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
18147                        | FFESYMBOL_attrsEXTERNAL
18148                        | FFESYMBOL_attrsTYPE)));
18149
18150       kind = FFEINFO_kindFUNCTION;
18151       maybe_ambig = TRUE;       /* If basictypeCHARACTER, can't be sure; kind
18152                                    could be ENTITY w/substring ref. */
18153     }
18154   else if (sa & FFESYMBOL_attrsARRAY)
18155     {
18156       assert (!(sa & ~(FFESYMBOL_attrsARRAY
18157                        | FFESYMBOL_attrsADJUSTABLE
18158                        | FFESYMBOL_attrsTYPE)));
18159
18160       where = FFEINFO_whereLOCAL;
18161     }
18162   else if (sa & FFESYMBOL_attrsSFARG)
18163     {
18164       assert (!(sa & ~(FFESYMBOL_attrsSFARG
18165                        | FFESYMBOL_attrsTYPE)));
18166
18167       where = FFEINFO_whereLOCAL;       /* Actually an error, but at least we
18168                                            know it's a local var. */
18169     }
18170   else if (sa & FFESYMBOL_attrsTYPE)
18171     {
18172       assert (!(sa & (FFESYMBOL_attrsARRAY
18173                       | FFESYMBOL_attrsDUMMY
18174                       | FFESYMBOL_attrsEXTERNAL
18175                       | FFESYMBOL_attrsSFARG)));        /* Handled above. */
18176       assert (!(sa & ~(FFESYMBOL_attrsTYPE
18177                        | FFESYMBOL_attrsADJUSTABLE
18178                        | FFESYMBOL_attrsANYLEN
18179                        | FFESYMBOL_attrsARRAY
18180                        | FFESYMBOL_attrsDUMMY
18181                        | FFESYMBOL_attrsEXTERNAL
18182                        | FFESYMBOL_attrsSFARG)));
18183
18184       if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
18185                                   &gen, &spec, &imp))
18186         {
18187           if (!(sa & FFESYMBOL_attrsANYLEN)
18188               && (ffeimplic_peek_symbol_type (s, NULL)
18189                   == FFEINFO_basictypeCHARACTER))
18190             return s;           /* Haven't learned anything yet. */
18191
18192           ffesymbol_signal_change (s);  /* May need to back up to previous
18193                                            version. */
18194           ffesymbol_set_generic (s, gen);
18195           ffesymbol_set_specific (s, spec);
18196           ffesymbol_set_implementation (s, imp);
18197           ffesymbol_set_info (s,
18198                               ffeinfo_new (ffesymbol_basictype (s),
18199                                            ffesymbol_kindtype (s),
18200                                            0,
18201                                            FFEINFO_kindFUNCTION,
18202                                            FFEINFO_whereINTRINSIC,
18203                                            ffesymbol_size (s)));
18204           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18205           ffesymbol_resolve_intrin (s);
18206           ffesymbol_reference (s, t, FALSE);
18207           s = ffecom_sym_learned (s);
18208           ffesymbol_signal_unreported (s);      /* For debugging purposes. */
18209
18210           return s;
18211         }
18212       if (sa & FFESYMBOL_attrsANYLEN)
18213         error = TRUE;           /* Error, since the only way we can,
18214                                    given CHARACTER*(*) FOO, accept
18215                                    FOO(...) is for FOO to be a dummy
18216                                    arg or constant, but it can't
18217                                    become either now. */
18218       else if (sa & FFESYMBOL_attrsADJUSTABLE)
18219         {
18220           kind = FFEINFO_kindENTITY;
18221           where = FFEINFO_whereLOCAL;
18222         }
18223       else
18224         {
18225           kind = FFEINFO_kindFUNCTION;
18226           where = FFEINFO_whereGLOBAL;
18227           maybe_ambig = TRUE;   /* If basictypeCHARACTER, can't be sure;
18228                                    could be ENTITY/LOCAL w/substring ref. */
18229         }
18230     }
18231   else if (sa == FFESYMBOL_attrsetNONE)
18232     {
18233       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
18234
18235       if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
18236                                   &gen, &spec, &imp))
18237         {
18238           if (ffeimplic_peek_symbol_type (s, NULL)
18239               == FFEINFO_basictypeCHARACTER)
18240             return s;           /* Haven't learned anything yet. */
18241
18242           ffesymbol_signal_change (s);  /* May need to back up to previous
18243                                            version. */
18244           ffesymbol_set_generic (s, gen);
18245           ffesymbol_set_specific (s, spec);
18246           ffesymbol_set_implementation (s, imp);
18247           ffesymbol_set_info (s,
18248                               ffeinfo_new (ffesymbol_basictype (s),
18249                                            ffesymbol_kindtype (s),
18250                                            0,
18251                                            FFEINFO_kindFUNCTION,
18252                                            FFEINFO_whereINTRINSIC,
18253                                            ffesymbol_size (s)));
18254           ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18255           ffesymbol_resolve_intrin (s);
18256           s = ffecom_sym_learned (s);
18257           ffesymbol_reference (s, t, FALSE);
18258           ffesymbol_signal_unreported (s);      /* For debugging purposes. */
18259           return s;
18260         }
18261
18262       kind = FFEINFO_kindFUNCTION;
18263       where = FFEINFO_whereGLOBAL;
18264       maybe_ambig = TRUE;       /* If basictypeCHARACTER, can't be sure;
18265                                    could be ENTITY/LOCAL w/substring ref. */
18266     }
18267   else
18268     error = TRUE;
18269
18270   /* Now see what we've got for a new object: NONE means a new error cropped
18271      up; ANY means an old error to be ignored; otherwise, everything's ok,
18272      update the object (symbol) and continue on. */
18273
18274   if (error)
18275     ffesymbol_error (s, t);
18276   else if (!(na & FFESYMBOL_attrsANY))
18277     {
18278       ffesymbol_signal_change (s);      /* May need to back up to previous
18279                                            version. */
18280       if (!ffeimplic_establish_symbol (s))
18281         {
18282           ffesymbol_error (s, t);
18283           return s;
18284         }
18285       if (maybe_ambig
18286           && (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
18287         return s;               /* Still not sure, let caller deal with it
18288                                    based on (...). */
18289
18290       ffesymbol_set_info (s,
18291                           ffeinfo_new (ffesymbol_basictype (s),
18292                                        ffesymbol_kindtype (s),
18293                                        ffesymbol_rank (s),
18294                                        kind,
18295                                        where,
18296                                        ffesymbol_size (s)));
18297       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18298       ffesymbol_resolve_intrin (s);
18299       s = ffecom_sym_learned (s);
18300       ffesymbol_reference (s, t, FALSE);
18301       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
18302     }
18303
18304   return s;
18305 }
18306
18307 /* ffeexpr_token_arguments_ -- OPEN_PAREN [expr COMMA]...expr
18308
18309    Return a pointer to this function to the lexer (ffelex), which will
18310    invoke it for the next token.
18311
18312    Handle expression (which might be null) and COMMA or CLOSE_PAREN.  */
18313
18314 static ffelexHandler
18315 ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr, ffelexToken t)
18316 {
18317   ffeexprExpr_ procedure;
18318   ffebld reduced;
18319   ffeinfo info;
18320   ffeexprContext ctx;
18321   bool check_intrin = FALSE;    /* Set TRUE if intrinsic is REAL(Z) or AIMAG(Z). */
18322
18323   procedure = ffeexpr_stack_->exprstack;
18324   info = ffebld_info (procedure->u.operand);
18325
18326   /* Is there an expression to add?  If the expression is nil,
18327      it might still be an argument.  It is if:
18328
18329        -  The current token is comma, or
18330
18331        -  The -fugly-comma flag was specified *and* the procedure
18332           being invoked is external.
18333
18334      Otherwise, if neither of the above is the case, just
18335      ignore this (nil) expression.  */
18336
18337   if ((expr != NULL)
18338       || (ffelex_token_type (t) == FFELEX_typeCOMMA)
18339       || (ffe_is_ugly_comma ()
18340           && (ffeinfo_where (info) == FFEINFO_whereGLOBAL)))
18341     {
18342       /* This expression, even if nil, is apparently intended as an argument.  */
18343
18344       /* Internal procedure (CONTAINS, or statement function)?  */
18345
18346       if (ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18347         {
18348           if ((expr == NULL)
18349               && ffebad_start (FFEBAD_NULL_ARGUMENT))
18350             {
18351               ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18352                            ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18353               ffebad_here (1, ffelex_token_where_line (t),
18354                            ffelex_token_where_column (t));
18355               ffebad_finish ();
18356             }
18357
18358           if (expr == NULL)
18359             ;
18360           else
18361             {
18362               if (ffeexpr_stack_->next_dummy == NULL)
18363                 {                       /* Report later which was the first extra argument. */
18364                   if (ffeexpr_stack_->tokens[1] == NULL)
18365                     {
18366                       ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
18367                       ffeexpr_stack_->num_args = 0;
18368                     }
18369                   ++ffeexpr_stack_->num_args;   /* Count # of extra arguments. */
18370                 }
18371               else
18372                 {
18373                   if ((ffeinfo_rank (ffebld_info (expr)) != 0)
18374                       && ffebad_start (FFEBAD_ARRAY_AS_SFARG))
18375                     {
18376                       ffebad_here (0,
18377                                    ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18378                                    ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18379                       ffebad_here (1, ffelex_token_where_line (ft),
18380                                    ffelex_token_where_column (ft));
18381                       ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent
18382                                                      (ffebld_symter (ffebld_head
18383                                                                      (ffeexpr_stack_->next_dummy)))));
18384                       ffebad_finish ();
18385                     }
18386                   else
18387                     {
18388                       expr = ffeexpr_convert_expr (expr, ft,
18389                                                    ffebld_head (ffeexpr_stack_->next_dummy),
18390                                                    ffeexpr_stack_->tokens[0],
18391                                                    FFEEXPR_contextLET);
18392                       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18393                     }
18394                   --ffeexpr_stack_->num_args;   /* Count down # of args. */
18395                   ffeexpr_stack_->next_dummy
18396                     = ffebld_trail (ffeexpr_stack_->next_dummy);
18397                 }
18398             }
18399         }
18400       else
18401         {
18402           if ((expr == NULL)
18403               && ffe_is_pedantic ()
18404               && ffebad_start (FFEBAD_NULL_ARGUMENT_W))
18405             {
18406               ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18407                            ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18408               ffebad_here (1, ffelex_token_where_line (t),
18409                            ffelex_token_where_column (t));
18410               ffebad_finish ();
18411             }
18412           ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18413         }
18414     }
18415
18416   switch (ffelex_token_type (t))
18417     {
18418     case FFELEX_typeCOMMA:
18419       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
18420         {
18421         case FFEEXPR_contextSFUNCDEF:
18422         case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
18423         case FFEEXPR_contextSFUNCDEFINDEX_:
18424         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
18425           ctx = FFEEXPR_contextSFUNCDEFACTUALARG_;
18426           break;
18427
18428         case FFEEXPR_contextSFUNCDEFACTUALARG_:
18429         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18430           assert ("bad context" == NULL);
18431           ctx = FFEEXPR_context;
18432           break;
18433
18434         default:
18435           ctx = FFEEXPR_contextACTUALARG_;
18436           break;
18437         }
18438       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18439                                           ffeexpr_token_arguments_);
18440
18441     default:
18442       break;
18443     }
18444
18445   if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18446       && (ffeexpr_stack_->next_dummy != NULL))
18447     {                           /* Too few arguments. */
18448       if (ffebad_start (FFEBAD_TOO_FEW_ARGUMENTS))
18449         {
18450           char num[10];
18451
18452           sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
18453
18454           ffebad_here (0, ffelex_token_where_line (t),
18455                        ffelex_token_where_column (t));
18456           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18457                      ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18458           ffebad_string (num);
18459           ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent (ffebld_symter
18460                               (ffebld_head (ffeexpr_stack_->next_dummy)))));
18461           ffebad_finish ();
18462         }
18463       for (;
18464            ffeexpr_stack_->next_dummy != NULL;
18465            ffeexpr_stack_->next_dummy
18466            = ffebld_trail (ffeexpr_stack_->next_dummy))
18467         {
18468           expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0));
18469           ffebld_set_info (expr, ffeinfo_new_any ());
18470           ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18471         }
18472     }
18473
18474   if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18475       && (ffeexpr_stack_->tokens[1] != NULL))
18476     {                           /* Too many arguments to statement function. */
18477       if (ffebad_start (FFEBAD_TOO_MANY_ARGUMENTS))
18478         {
18479           char num[10];
18480
18481           sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
18482
18483           ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
18484                      ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
18485           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18486                      ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18487           ffebad_string (num);
18488           ffebad_finish ();
18489         }
18490       ffelex_token_kill (ffeexpr_stack_->tokens[1]);
18491     }
18492   ffebld_end_list (&ffeexpr_stack_->bottom);
18493
18494   if (ffebld_op (procedure->u.operand) == FFEBLD_opANY)
18495     {
18496       reduced = ffebld_new_any ();
18497       ffebld_set_info (reduced, ffeinfo_new_any ());
18498     }
18499   else
18500     {
18501       if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
18502         reduced = ffebld_new_funcref (procedure->u.operand,
18503                                       ffeexpr_stack_->expr);
18504       else
18505         reduced = ffebld_new_subrref (procedure->u.operand,
18506                                       ffeexpr_stack_->expr);
18507       if (ffebld_symter_generic (procedure->u.operand) != FFEINTRIN_genNONE)
18508         ffeintrin_fulfill_generic (&reduced, &info, ffeexpr_stack_->tokens[0]);
18509       else if (ffebld_symter_specific (procedure->u.operand)
18510                != FFEINTRIN_specNONE)
18511         ffeintrin_fulfill_specific (&reduced, &info, &check_intrin,
18512                                     ffeexpr_stack_->tokens[0]);
18513       else
18514         ffeexpr_fulfill_call_ (&reduced, ffeexpr_stack_->tokens[0]);
18515
18516       if (ffebld_op (reduced) != FFEBLD_opANY)
18517         ffebld_set_info (reduced,
18518                          ffeinfo_new (ffeinfo_basictype (info),
18519                                       ffeinfo_kindtype (info),
18520                                       0,
18521                                       FFEINFO_kindENTITY,
18522                                       FFEINFO_whereFLEETING,
18523                                       ffeinfo_size (info)));
18524       else
18525         ffebld_set_info (reduced, ffeinfo_new_any ());
18526     }
18527   if (ffebld_op (reduced) == FFEBLD_opFUNCREF)
18528     reduced = ffeexpr_collapse_funcref (reduced, ffeexpr_stack_->tokens[0]);
18529   ffeexpr_stack_->exprstack = procedure->previous;      /* Pops
18530                                                            not-quite-operand off
18531                                                            stack. */
18532   procedure->u.operand = reduced;       /* Save the line/column ffewhere
18533                                            info. */
18534   ffeexpr_exprstack_push_operand_ (procedure);  /* Push it back on stack. */
18535   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18536     {
18537       ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18538       ffeexpr_is_substr_ok_ = FALSE;    /* Nobody likes "FUNC(3)(1:1)".... */
18539
18540       /* If the intrinsic needs checking (is REAL(Z) or AIMAG(Z), where
18541          Z is DOUBLE COMPLEX), and a command-line option doesn't already
18542          establish interpretation, probably complain.  */
18543
18544       if (check_intrin
18545           && !ffe_is_90 ()
18546           && !ffe_is_ugly_complex ())
18547         {
18548           /* If the outer expression is REAL(me...), issue diagnostic
18549              only if next token isn't the close-paren for REAL(me).  */
18550
18551           if ((ffeexpr_stack_->previous != NULL)
18552               && (ffeexpr_stack_->previous->exprstack != NULL)
18553               && (ffeexpr_stack_->previous->exprstack->type == FFEEXPR_exprtypeOPERAND_)
18554               && ((reduced = ffeexpr_stack_->previous->exprstack->u.operand) != NULL)
18555               && (ffebld_op (reduced) == FFEBLD_opSYMTER)
18556               && (ffebld_symter_implementation (reduced) == FFEINTRIN_impREAL))
18557             return (ffelexHandler) ffeexpr_token_intrincheck_;
18558
18559           /* Diagnose the ambiguity now.  */
18560
18561           if (ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
18562             {
18563               ffebad_string (ffeintrin_name_implementation
18564                              (ffebld_symter_implementation
18565                               (ffebld_left
18566                                (ffeexpr_stack_->exprstack->u.operand))));
18567               ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
18568                            ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
18569               ffebad_finish ();
18570             }
18571         }
18572       return (ffelexHandler) ffeexpr_token_substrp_;
18573     }
18574
18575   if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
18576     {
18577       ffebad_here (0, ffelex_token_where_line (t),
18578                    ffelex_token_where_column (t));
18579       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18580                    ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18581       ffebad_finish ();
18582     }
18583   ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18584   ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FUNC(3)(1:1)".... */
18585   return
18586     (ffelexHandler) ffeexpr_find_close_paren_ (t,
18587                                                (ffelexHandler)
18588                                                ffeexpr_token_substrp_);
18589 }
18590
18591 /* ffeexpr_token_elements_ -- OPEN_PAREN [expr COMMA]...expr
18592
18593    Return a pointer to this array to the lexer (ffelex), which will
18594    invoke it for the next token.
18595
18596    Handle expression and COMMA or CLOSE_PAREN.  */
18597
18598 static ffelexHandler
18599 ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, ffelexToken t)
18600 {
18601   ffeexprExpr_ array;
18602   ffebld reduced;
18603   ffeinfo info;
18604   ffeinfoWhere where;
18605   ffetargetIntegerDefault val;
18606   ffetargetIntegerDefault lval = 0;
18607   ffetargetIntegerDefault uval = 0;
18608   ffebld lbound;
18609   ffebld ubound;
18610   bool lcheck;
18611   bool ucheck;
18612
18613   array = ffeexpr_stack_->exprstack;
18614   info = ffebld_info (array->u.operand);
18615
18616   if ((expr == NULL)            /* && ((ffeexpr_stack_->rank != 0) ||
18617                                    (ffelex_token_type(t) ==
18618          FFELEX_typeCOMMA)) */ )
18619     {
18620       if (ffebad_start (FFEBAD_NULL_ELEMENT))
18621         {
18622           ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18623                      ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18624           ffebad_here (1, ffelex_token_where_line (t),
18625                        ffelex_token_where_column (t));
18626           ffebad_finish ();
18627         }
18628       if (ffeexpr_stack_->rank < ffeinfo_rank (info))
18629         {                       /* Don't bother if we're going to complain
18630                                    later! */
18631           expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
18632           ffebld_set_info (expr, ffeinfo_new_any ());
18633         }
18634     }
18635
18636   if (expr == NULL)
18637     ;
18638   else if (ffeinfo_rank (info) == 0)
18639     {                           /* In EQUIVALENCE context, ffeinfo_rank(info)
18640                                    may == 0. */
18641       ++ffeexpr_stack_->rank;   /* Track anyway, may need for new VXT
18642                                    feature. */
18643       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18644     }
18645   else
18646     {
18647       ++ffeexpr_stack_->rank;
18648       if (ffeexpr_stack_->rank > ffeinfo_rank (info))
18649         {                       /* Report later which was the first extra
18650                                    element. */
18651           if (ffeexpr_stack_->rank == ffeinfo_rank (info) + 1)
18652             ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
18653         }
18654       else
18655         {
18656           switch (ffeinfo_where (ffebld_info (expr)))
18657             {
18658             case FFEINFO_whereCONSTANT:
18659               break;
18660
18661             case FFEINFO_whereIMMEDIATE:
18662               ffeexpr_stack_->constant = FALSE;
18663               break;
18664
18665             default:
18666               ffeexpr_stack_->constant = FALSE;
18667               ffeexpr_stack_->immediate = FALSE;
18668               break;
18669             }
18670           if (ffebld_op (expr) == FFEBLD_opCONTER
18671               && ffebld_kindtype (expr) == FFEINFO_kindtypeINTEGERDEFAULT)
18672             {
18673               val = ffebld_constant_integerdefault (ffebld_conter (expr));
18674
18675               lbound = ffebld_left (ffebld_head (ffeexpr_stack_->bound_list));
18676               if (lbound == NULL)
18677                 {
18678                   lcheck = TRUE;
18679                   lval = 1;
18680                 }
18681               else if (ffebld_op (lbound) == FFEBLD_opCONTER)
18682                 {
18683                   lcheck = TRUE;
18684                   lval = ffebld_constant_integerdefault (ffebld_conter (lbound));
18685                 }
18686               else
18687                 lcheck = FALSE;
18688
18689               ubound = ffebld_right (ffebld_head (ffeexpr_stack_->bound_list));
18690               assert (ubound != NULL);
18691               if (ffebld_op (ubound) == FFEBLD_opCONTER)
18692                 {
18693                   ucheck = TRUE;
18694                   uval = ffebld_constant_integerdefault (ffebld_conter (ubound));
18695                 }
18696               else
18697                 ucheck = FALSE;
18698
18699               if ((lcheck && (val < lval)) || (ucheck && (val > uval)))
18700                 {
18701                   ffebad_start (FFEBAD_RANGE_ARRAY);
18702                   ffebad_here (0, ffelex_token_where_line (ft),
18703                                ffelex_token_where_column (ft));
18704                   ffebad_finish ();
18705                 }
18706             }
18707           ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18708           ffeexpr_stack_->bound_list = ffebld_trail (ffeexpr_stack_->bound_list);
18709         }
18710     }
18711
18712   switch (ffelex_token_type (t))
18713     {
18714     case FFELEX_typeCOMMA:
18715       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
18716         {
18717         case FFEEXPR_contextDATAIMPDOITEM_:
18718           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18719                                               FFEEXPR_contextDATAIMPDOINDEX_,
18720                                               ffeexpr_token_elements_);
18721
18722         case FFEEXPR_contextEQUIVALENCE:
18723           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18724                                               FFEEXPR_contextEQVINDEX_,
18725                                               ffeexpr_token_elements_);
18726
18727         case FFEEXPR_contextSFUNCDEF:
18728         case FFEEXPR_contextSFUNCDEFINDEX_:
18729           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18730                                               FFEEXPR_contextSFUNCDEFINDEX_,
18731                                               ffeexpr_token_elements_);
18732
18733         case FFEEXPR_contextSFUNCDEFACTUALARG_:
18734         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18735           assert ("bad context" == NULL);
18736           break;
18737
18738         default:
18739           return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18740                                               FFEEXPR_contextINDEX_,
18741                                               ffeexpr_token_elements_);
18742         }
18743
18744     default:
18745       break;
18746     }
18747
18748   if ((ffeexpr_stack_->rank != ffeinfo_rank (info))
18749       && (ffeinfo_rank (info) != 0))
18750     {
18751       char num[10];
18752
18753       if (ffeexpr_stack_->rank < ffeinfo_rank (info))
18754         {
18755           if (ffebad_start (FFEBAD_TOO_FEW_ELEMENTS))
18756             {
18757               sprintf (num, "%d",
18758                        (int) (ffeinfo_rank (info) - ffeexpr_stack_->rank));
18759
18760               ffebad_here (0, ffelex_token_where_line (t),
18761                            ffelex_token_where_column (t));
18762               ffebad_here (1,
18763                         ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18764                      ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18765               ffebad_string (num);
18766               ffebad_finish ();
18767             }
18768         }
18769       else
18770         {
18771           if (ffebad_start (FFEBAD_TOO_MANY_ELEMENTS))
18772             {
18773               sprintf (num, "%d",
18774                        (int) (ffeexpr_stack_->rank - ffeinfo_rank (info)));
18775
18776               ffebad_here (0,
18777                         ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
18778                      ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
18779               ffebad_here (1,
18780                         ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18781                      ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18782               ffebad_string (num);
18783               ffebad_finish ();
18784             }
18785           ffelex_token_kill (ffeexpr_stack_->tokens[1]);
18786         }
18787       while (ffeexpr_stack_->rank++ < ffeinfo_rank (info))
18788         {
18789           expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
18790           ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeINTEGER,
18791                                               FFEINFO_kindtypeINTEGERDEFAULT,
18792                                               0, FFEINFO_kindENTITY,
18793                                               FFEINFO_whereCONSTANT,
18794                                               FFETARGET_charactersizeNONE));
18795           ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18796         }
18797     }
18798   ffebld_end_list (&ffeexpr_stack_->bottom);
18799
18800   if (ffebld_op (array->u.operand) == FFEBLD_opANY)
18801     {
18802       reduced = ffebld_new_any ();
18803       ffebld_set_info (reduced, ffeinfo_new_any ());
18804     }
18805   else
18806     {
18807       reduced = ffebld_new_arrayref (array->u.operand, ffeexpr_stack_->expr);
18808       if (ffeexpr_stack_->constant)
18809         where = FFEINFO_whereFLEETING_CADDR;
18810       else if (ffeexpr_stack_->immediate)
18811         where = FFEINFO_whereFLEETING_IADDR;
18812       else
18813         where = FFEINFO_whereFLEETING;
18814       ffebld_set_info (reduced,
18815                        ffeinfo_new (ffeinfo_basictype (info),
18816                                     ffeinfo_kindtype (info),
18817                                     0,
18818                                     FFEINFO_kindENTITY,
18819                                     where,
18820                                     ffeinfo_size (info)));
18821       reduced = ffeexpr_collapse_arrayref (reduced, ffeexpr_stack_->tokens[0]);
18822     }
18823
18824   ffeexpr_stack_->exprstack = array->previous;  /* Pops not-quite-operand off
18825                                                    stack. */
18826   array->u.operand = reduced;   /* Save the line/column ffewhere info. */
18827   ffeexpr_exprstack_push_operand_ (array);      /* Push it back on stack. */
18828
18829   switch (ffeinfo_basictype (info))
18830     {
18831     case FFEINFO_basictypeCHARACTER:
18832       ffeexpr_is_substr_ok_ = TRUE;     /* Everyone likes "FOO(3)(1:1)".... */
18833       break;
18834
18835     case FFEINFO_basictypeNONE:
18836       ffeexpr_is_substr_ok_ = TRUE;
18837       assert (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE);
18838       break;
18839
18840     default:
18841       ffeexpr_is_substr_ok_ = FALSE;
18842       break;
18843     }
18844
18845   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18846     {
18847       ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18848       return (ffelexHandler) ffeexpr_token_substrp_;
18849     }
18850
18851   if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
18852     {
18853       ffebad_here (0, ffelex_token_where_line (t),
18854                    ffelex_token_where_column (t));
18855       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18856                    ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18857       ffebad_finish ();
18858     }
18859   ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18860   return
18861     (ffelexHandler) ffeexpr_find_close_paren_ (t,
18862                                                (ffelexHandler)
18863                                                ffeexpr_token_substrp_);
18864 }
18865
18866 /* ffeexpr_token_equivalence_ -- OPEN_PAREN expr
18867
18868    Return a pointer to this array to the lexer (ffelex), which will
18869    invoke it for the next token.
18870
18871    If token is COLON, pass off to _substr_, else init list and pass off
18872    to _elements_.  This handles the case "EQUIVALENCE (FOO(expr?", where
18873    ? marks the token, and where FOO's rank/type has not yet been established,
18874    meaning we could be in a list of indices or in a substring
18875    specification.  */
18876
18877 static ffelexHandler
18878 ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr, ffelexToken t)
18879 {
18880   if (ffelex_token_type (t) == FFELEX_typeCOLON)
18881     return ffeexpr_token_substring_ (ft, expr, t);
18882
18883   ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
18884   return ffeexpr_token_elements_ (ft, expr, t);
18885 }
18886
18887 /* ffeexpr_token_substring_ -- NAME(of kindENTITY) OPEN_PAREN expr
18888
18889    Return a pointer to this function to the lexer (ffelex), which will
18890    invoke it for the next token.
18891
18892    Handle expression (which may be null) and COLON.  */
18893
18894 static ffelexHandler
18895 ffeexpr_token_substring_ (ffelexToken ft, ffebld expr, ffelexToken t)
18896 {
18897   ffeexprExpr_ string;
18898   ffeinfo info;
18899   ffetargetIntegerDefault i;
18900   ffeexprContext ctx;
18901   ffetargetCharacterSize size;
18902
18903   string = ffeexpr_stack_->exprstack;
18904   info = ffebld_info (string->u.operand);
18905   size = ffebld_size_max (string->u.operand);
18906
18907   if (ffelex_token_type (t) == FFELEX_typeCOLON)
18908     {
18909       if ((expr != NULL)
18910           && (ffebld_op (expr) == FFEBLD_opCONTER)
18911           && (((i = ffebld_constant_integerdefault (ffebld_conter (expr)))
18912                < 1)
18913               || ((size != FFETARGET_charactersizeNONE) && (i > size))))
18914         {
18915           ffebad_start (FFEBAD_RANGE_SUBSTR);
18916           ffebad_here (0, ffelex_token_where_line (ft),
18917                        ffelex_token_where_column (ft));
18918           ffebad_finish ();
18919         }
18920       ffeexpr_stack_->expr = expr;
18921
18922       switch (ffeexpr_stack_->context)
18923         {
18924         case FFEEXPR_contextSFUNCDEF:
18925         case FFEEXPR_contextSFUNCDEFINDEX_:
18926           ctx = FFEEXPR_contextSFUNCDEFINDEX_;
18927           break;
18928
18929         case FFEEXPR_contextSFUNCDEFACTUALARG_:
18930         case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18931           assert ("bad context" == NULL);
18932           ctx = FFEEXPR_context;
18933           break;
18934
18935         default:
18936           ctx = FFEEXPR_contextINDEX_;
18937           break;
18938         }
18939
18940       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18941                                           ffeexpr_token_substring_1_);
18942     }
18943
18944   if (ffest_ffebad_start (FFEBAD_MISSING_COLON_IN_SUBSTR))
18945     {
18946       ffebad_here (0, ffelex_token_where_line (t),
18947                    ffelex_token_where_column (t));
18948       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18949                    ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18950       ffebad_finish ();
18951     }
18952
18953   ffeexpr_stack_->expr = NULL;
18954   return (ffelexHandler) ffeexpr_token_substring_1_ (ft, expr, t);
18955 }
18956
18957 /* ffeexpr_token_substring_1_ -- NAME OPEN_PAREN [expr COMMA]...expr
18958
18959    Return a pointer to this function to the lexer (ffelex), which will
18960    invoke it for the next token.
18961
18962    Handle expression (which might be null) and CLOSE_PAREN.  */
18963
18964 static ffelexHandler
18965 ffeexpr_token_substring_1_ (ffelexToken ft, ffebld last, ffelexToken t)
18966 {
18967   ffeexprExpr_ string;
18968   ffebld reduced;
18969   ffebld substrlist;
18970   ffebld first = ffeexpr_stack_->expr;
18971   ffebld strop;
18972   ffeinfo info;
18973   ffeinfoWhere lwh;
18974   ffeinfoWhere rwh;
18975   ffeinfoWhere where;
18976   ffeinfoKindtype first_kt;
18977   ffeinfoKindtype last_kt;
18978   ffetargetIntegerDefault first_val;
18979   ffetargetIntegerDefault last_val;
18980   ffetargetCharacterSize size;
18981   ffetargetCharacterSize strop_size_max;
18982   bool first_known;
18983
18984   string = ffeexpr_stack_->exprstack;
18985   strop = string->u.operand;
18986   info = ffebld_info (strop);
18987
18988   if (first == NULL
18989       || (ffebld_op (first) == FFEBLD_opCONTER
18990           && ffebld_kindtype (first) == FFEINFO_kindtypeINTEGERDEFAULT))
18991     {                           /* The starting point is known. */
18992       first_val = (first == NULL) ? 1
18993         : ffebld_constant_integerdefault (ffebld_conter (first));
18994       first_known = TRUE;
18995     }
18996   else
18997     {                           /* Assume start of the entity. */
18998       first_val = 1;
18999       first_known = FALSE;
19000     }
19001
19002   if (last != NULL
19003       && (ffebld_op (last) == FFEBLD_opCONTER
19004           && ffebld_kindtype (last) == FFEINFO_kindtypeINTEGERDEFAULT))
19005     {                           /* The ending point is known. */
19006       last_val = ffebld_constant_integerdefault (ffebld_conter (last));
19007
19008       if (first_known)
19009         {                       /* The beginning point is a constant. */
19010           if (first_val <= last_val)
19011             size = last_val - first_val + 1;
19012           else
19013             {
19014               if (0 && ffe_is_90 ())
19015                 size = 0;
19016               else
19017                 {
19018                   size = 1;
19019                   ffebad_start (FFEBAD_ZERO_SIZE);
19020                   ffebad_here (0, ffelex_token_where_line (ft),
19021                                ffelex_token_where_column (ft));
19022                   ffebad_finish ();
19023                 }
19024             }
19025         }
19026       else
19027         size = FFETARGET_charactersizeNONE;
19028
19029       strop_size_max = ffebld_size_max (strop);
19030
19031       if ((strop_size_max != FFETARGET_charactersizeNONE)
19032           && (last_val > strop_size_max))
19033         {                       /* Beyond maximum possible end of string. */
19034           ffebad_start (FFEBAD_RANGE_SUBSTR);
19035           ffebad_here (0, ffelex_token_where_line (ft),
19036                        ffelex_token_where_column (ft));
19037           ffebad_finish ();
19038         }
19039     }
19040   else
19041     size = FFETARGET_charactersizeNONE; /* The size is not known. */
19042
19043 #if 0                           /* Don't do this, or "is size of target
19044                                    known?" would no longer be easily
19045                                    answerable.  To see if there is a max
19046                                    size, use ffebld_size_max; to get only the
19047                                    known size, else NONE, use
19048                                    ffebld_size_known; use ffebld_size if
19049                                    values are sure to be the same (not
19050                                    opSUBSTR or opCONCATENATE or known to have
19051                                    known length). By getting rid of this
19052                                    "useful info" stuff, we don't end up
19053                                    blank-padding the constant in the
19054                                    assignment "A(I:J)='XYZ'" to the known
19055                                    length of A. */
19056   if (size == FFETARGET_charactersizeNONE)
19057     size = strop_size_max;      /* Assume we use the entire string. */
19058 #endif
19059
19060   substrlist
19061     = ffebld_new_item
19062     (first,
19063      ffebld_new_item
19064      (last,
19065       NULL
19066      )
19067     )
19068     ;
19069
19070   if (first == NULL)
19071     lwh = FFEINFO_whereCONSTANT;
19072   else
19073     lwh = ffeinfo_where (ffebld_info (first));
19074   if (last == NULL)
19075     rwh = FFEINFO_whereCONSTANT;
19076   else
19077     rwh = ffeinfo_where (ffebld_info (last));
19078
19079   switch (lwh)
19080     {
19081     case FFEINFO_whereCONSTANT:
19082       switch (rwh)
19083         {
19084         case FFEINFO_whereCONSTANT:
19085           where = FFEINFO_whereCONSTANT;
19086           break;
19087
19088         case FFEINFO_whereIMMEDIATE:
19089           where = FFEINFO_whereIMMEDIATE;
19090           break;
19091
19092         default:
19093           where = FFEINFO_whereFLEETING;
19094           break;
19095         }
19096       break;
19097
19098     case FFEINFO_whereIMMEDIATE:
19099       switch (rwh)
19100         {
19101         case FFEINFO_whereCONSTANT:
19102         case FFEINFO_whereIMMEDIATE:
19103           where = FFEINFO_whereIMMEDIATE;
19104           break;
19105
19106         default:
19107           where = FFEINFO_whereFLEETING;
19108           break;
19109         }
19110       break;
19111
19112     default:
19113       where = FFEINFO_whereFLEETING;
19114       break;
19115     }
19116
19117   if (first == NULL)
19118     first_kt = FFEINFO_kindtypeINTEGERDEFAULT;
19119   else
19120     first_kt = ffeinfo_kindtype (ffebld_info (first));
19121   if (last == NULL)
19122     last_kt = FFEINFO_kindtypeINTEGERDEFAULT;
19123   else
19124     last_kt = ffeinfo_kindtype (ffebld_info (last));
19125
19126   switch (where)
19127     {
19128     case FFEINFO_whereCONSTANT:
19129       switch (ffeinfo_where (info))
19130         {
19131         case FFEINFO_whereCONSTANT:
19132           break;
19133
19134         case FFEINFO_whereIMMEDIATE:    /* Not possible, actually. */
19135           where = FFEINFO_whereIMMEDIATE;
19136           break;
19137
19138         default:
19139           where = FFEINFO_whereFLEETING_CADDR;
19140           break;
19141         }
19142       break;
19143
19144     case FFEINFO_whereIMMEDIATE:
19145       switch (ffeinfo_where (info))
19146         {
19147         case FFEINFO_whereCONSTANT:
19148         case FFEINFO_whereIMMEDIATE:    /* Not possible, actually. */
19149           break;
19150
19151         default:
19152           where = FFEINFO_whereFLEETING_IADDR;
19153           break;
19154         }
19155       break;
19156
19157     default:
19158       switch (ffeinfo_where (info))
19159         {
19160         case FFEINFO_whereCONSTANT:
19161           where = FFEINFO_whereCONSTANT_SUBOBJECT;      /* An F90 concept. */
19162           break;
19163
19164         case FFEINFO_whereIMMEDIATE:    /* Not possible, actually. */
19165         default:
19166           where = FFEINFO_whereFLEETING;
19167           break;
19168         }
19169       break;
19170     }
19171
19172   if (ffebld_op (strop) == FFEBLD_opANY)
19173     {
19174       reduced = ffebld_new_any ();
19175       ffebld_set_info (reduced, ffeinfo_new_any ());
19176     }
19177   else
19178     {
19179       reduced = ffebld_new_substr (strop, substrlist);
19180       ffebld_set_info (reduced, ffeinfo_new
19181                        (FFEINFO_basictypeCHARACTER,
19182                         ffeinfo_kindtype (info),
19183                         0,
19184                         FFEINFO_kindENTITY,
19185                         where,
19186                         size));
19187       reduced = ffeexpr_collapse_substr (reduced, ffeexpr_stack_->tokens[0]);
19188     }
19189
19190   ffeexpr_stack_->exprstack = string->previous; /* Pops not-quite-operand off
19191                                                    stack. */
19192   string->u.operand = reduced;  /* Save the line/column ffewhere info. */
19193   ffeexpr_exprstack_push_operand_ (string);     /* Push it back on stack. */
19194
19195   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
19196     {
19197       ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19198       ffeexpr_is_substr_ok_ = FALSE;    /* Nobody likes "FOO(3:5)(1:1)".... */
19199       return (ffelexHandler) ffeexpr_token_substrp_;
19200     }
19201
19202   if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
19203     {
19204       ffebad_here (0, ffelex_token_where_line (t),
19205                    ffelex_token_where_column (t));
19206       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
19207                    ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
19208       ffebad_finish ();
19209     }
19210
19211   ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19212   ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FOO(3:5)(1:1)".... */
19213   return
19214     (ffelexHandler) ffeexpr_find_close_paren_ (t,
19215                                                (ffelexHandler)
19216                                                ffeexpr_token_substrp_);
19217 }
19218
19219 /* ffeexpr_token_substrp_ -- Rhs <character entity>
19220
19221    Return a pointer to this function to the lexer (ffelex), which will
19222    invoke it for the next token.
19223
19224    If OPEN_PAREN, treat as start of a substring ("(3:4)") construct, and
19225    issue error message if flag (serves as argument) is set.  Else, just
19226    forward token to binary_.  */
19227
19228 static ffelexHandler
19229 ffeexpr_token_substrp_ (ffelexToken t)
19230 {
19231   ffeexprContext ctx;
19232
19233   if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
19234     return (ffelexHandler) ffeexpr_token_binary_ (t);
19235
19236   ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
19237
19238   switch (ffeexpr_stack_->context)
19239     {
19240     case FFEEXPR_contextSFUNCDEF:
19241     case FFEEXPR_contextSFUNCDEFINDEX_:
19242       ctx = FFEEXPR_contextSFUNCDEFINDEX_;
19243       break;
19244
19245     case FFEEXPR_contextSFUNCDEFACTUALARG_:
19246     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
19247       assert ("bad context" == NULL);
19248       ctx = FFEEXPR_context;
19249       break;
19250
19251     default:
19252       ctx = FFEEXPR_contextINDEX_;
19253       break;
19254     }
19255
19256   if (!ffeexpr_is_substr_ok_)
19257     {
19258       if (ffebad_start (FFEBAD_BAD_SUBSTR))
19259         {
19260           ffebad_here (0, ffelex_token_where_line (t),
19261                        ffelex_token_where_column (t));
19262           ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
19263                        ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
19264           ffebad_finish ();
19265         }
19266
19267       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
19268                                           ffeexpr_token_anything_);
19269     }
19270
19271   return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
19272                                       ffeexpr_token_substring_);
19273 }
19274
19275 static ffelexHandler
19276 ffeexpr_token_intrincheck_ (ffelexToken t)
19277 {
19278   if ((ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
19279       && ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
19280     {
19281       ffebad_string (ffeintrin_name_implementation
19282                      (ffebld_symter_implementation
19283                       (ffebld_left
19284                        (ffeexpr_stack_->exprstack->u.operand))));
19285       ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
19286                    ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
19287       ffebad_finish ();
19288     }
19289
19290   return (ffelexHandler) ffeexpr_token_substrp_ (t);
19291 }
19292
19293 /* ffeexpr_token_funsubstr_ -- NAME OPEN_PAREN expr
19294
19295    Return a pointer to this function to the lexer (ffelex), which will
19296    invoke it for the next token.
19297
19298    If COLON, do everything we would have done since _parenthesized_ if
19299    we had known NAME represented a kindENTITY instead of a kindFUNCTION.
19300    If not COLON, do likewise for kindFUNCTION instead.  */
19301
19302 static ffelexHandler
19303 ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr, ffelexToken t)
19304 {
19305   ffeinfoWhere where;
19306   ffesymbol s;
19307   ffesymbolAttrs sa;
19308   ffebld symter = ffeexpr_stack_->exprstack->u.operand;
19309   bool needs_type;
19310   ffeintrinGen gen;
19311   ffeintrinSpec spec;
19312   ffeintrinImp imp;
19313
19314   s = ffebld_symter (symter);
19315   sa = ffesymbol_attrs (s);
19316   where = ffesymbol_where (s);
19317
19318   /* We get here only if we don't already know enough about FOO when seeing a
19319      FOO(stuff) reference, and FOO might turn out to be a CHARACTER type.  If
19320      "stuff" is a substring reference, then FOO is a CHARACTER scalar type.
19321      Else FOO is a function, either intrinsic or external.  If intrinsic, it
19322      wouldn't necessarily be CHARACTER type, so unless it has already been
19323      declared DUMMY, it hasn't had its type established yet.  It can't be
19324      CHAR*(*) in any case, though it can have an explicit CHAR*n type.  */
19325
19326   assert (!(sa & ~(FFESYMBOL_attrsDUMMY
19327                    | FFESYMBOL_attrsTYPE)));
19328
19329   needs_type = !(ffesymbol_attrs (s) & FFESYMBOL_attrsDUMMY);
19330
19331   ffesymbol_signal_change (s);  /* Probably already done, but in case.... */
19332
19333   if (ffelex_token_type (t) == FFELEX_typeCOLON)
19334     {                           /* Definitely an ENTITY (char substring). */
19335       if (needs_type && !ffeimplic_establish_symbol (s))
19336         {
19337           ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
19338           return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19339         }
19340
19341       ffesymbol_set_info (s,
19342                           ffeinfo_new (ffesymbol_basictype (s),
19343                                        ffesymbol_kindtype (s),
19344                                        ffesymbol_rank (s),
19345                                        FFEINFO_kindENTITY,
19346                                        (where == FFEINFO_whereNONE)
19347                                        ? FFEINFO_whereLOCAL
19348                                        : where,
19349                                        ffesymbol_size (s)));
19350       ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
19351
19352       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
19353       ffesymbol_resolve_intrin (s);
19354       s = ffecom_sym_learned (s);
19355       ffesymbol_signal_unreported (s);  /* For debugging purposes. */
19356
19357       ffeexpr_stack_->exprstack->u.operand
19358         = ffeexpr_collapse_symter (symter, ffeexpr_tokens_[0]);
19359
19360       return (ffelexHandler) ffeexpr_token_substring_ (ft, expr, t);
19361     }
19362
19363   /* The "stuff" isn't a substring notation, so we now know the overall
19364      reference is to a function.  */
19365
19366   if (ffeintrin_is_intrinsic (ffesymbol_text (s), ffeexpr_stack_->tokens[0],
19367                               FALSE, &gen, &spec, &imp))
19368     {
19369       ffebld_symter_set_generic (symter, gen);
19370       ffebld_symter_set_specific (symter, spec);
19371       ffebld_symter_set_implementation (symter, imp);
19372       ffesymbol_set_generic (s, gen);
19373       ffesymbol_set_specific (s, spec);
19374       ffesymbol_set_implementation (s, imp);
19375       ffesymbol_set_info (s,
19376                           ffeinfo_new (ffesymbol_basictype (s),
19377                                        ffesymbol_kindtype (s),
19378                                        0,
19379                                        FFEINFO_kindFUNCTION,
19380                                        FFEINFO_whereINTRINSIC,
19381                                        ffesymbol_size (s)));
19382     }
19383   else
19384     {                           /* Not intrinsic, now needs CHAR type. */
19385       if (!ffeimplic_establish_symbol (s))
19386         {
19387           ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
19388           return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19389         }
19390
19391       ffesymbol_set_info (s,
19392                           ffeinfo_new (ffesymbol_basictype (s),
19393                                        ffesymbol_kindtype (s),
19394                                        ffesymbol_rank (s),
19395                                        FFEINFO_kindFUNCTION,
19396                                        (where == FFEINFO_whereNONE)
19397                                        ? FFEINFO_whereGLOBAL
19398                                        : where,
19399                                        ffesymbol_size (s)));
19400     }
19401
19402   ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
19403
19404   ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
19405   ffesymbol_resolve_intrin (s);
19406   s = ffecom_sym_learned (s);
19407   ffesymbol_reference (s, ffeexpr_stack_->tokens[0], FALSE);
19408   ffesymbol_signal_unreported (s);      /* For debugging purposes. */
19409   ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
19410   return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19411 }
19412
19413 /* ffeexpr_token_anything_ -- NAME OPEN_PAREN any-expr
19414
19415    Handle basically any expression, looking for CLOSE_PAREN.  */
19416
19417 static ffelexHandler
19418 ffeexpr_token_anything_ (ffelexToken ft UNUSED, ffebld expr UNUSED,
19419                          ffelexToken t)
19420 {
19421   ffeexprExpr_ e = ffeexpr_stack_->exprstack;
19422
19423   switch (ffelex_token_type (t))
19424     {
19425     case FFELEX_typeCOMMA:
19426     case FFELEX_typeCOLON:
19427       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
19428                                           FFEEXPR_contextACTUALARG_,
19429                                           ffeexpr_token_anything_);
19430
19431     default:
19432       e->u.operand = ffebld_new_any ();
19433       ffebld_set_info (e->u.operand, ffeinfo_new_any ());
19434       ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19435       ffeexpr_is_substr_ok_ = FALSE;
19436       if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
19437         return (ffelexHandler) ffeexpr_token_substrp_;
19438       return (ffelexHandler) ffeexpr_token_substrp_ (t);
19439     }
19440 }
19441
19442 /* Terminate module.  */
19443
19444 void
19445 ffeexpr_terminate_2 ()
19446 {
19447   assert (ffeexpr_stack_ == NULL);
19448   assert (ffeexpr_level_ == 0);
19449 }