1/* expr.c -- Implementation File (module.c template V1.0)
2   Copyright (C) 1995-1998 Free Software Foundation, Inc.
3   Contributed by James Craig Burley.
4
5This file is part of GNU Fortran.
6
7GNU Fortran is free software; you can redistribute it and/or modify
8it under the terms of the GNU General Public License as published by
9the Free Software Foundation; either version 2, or (at your option)
10any later version.
11
12GNU Fortran is distributed in the hope that it will be useful,
13but WITHOUT ANY WARRANTY; without even the implied warranty of
14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15GNU General Public License for more details.
16
17You should have received a copy of the GNU General Public License
18along with GNU Fortran; see the file COPYING.  If not, write to
19the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
2002111-1307, USA.
21
22   Related Modules:
23      None.
24
25   Description:
26      Handles syntactic and semantic analysis of Fortran expressions.
27
28   Modifications:
29*/
30
31/* Include files. */
32
33#include "proj.h"
34#include "expr.h"
35#include "bad.h"
36#include "bld.h"
37#include "com.h"
38#include "global.h"
39#include "implic.h"
40#include "intrin.h"
41#include "info.h"
42#include "lex.h"
43#include "malloc.h"
44#include "src.h"
45#include "st.h"
46#include "symbol.h"
47#include "str.h"
48#include "target.h"
49#include "where.h"
50
51/* Externals defined here. */
52
53
54/* Simple definitions and enumerations. */
55
56typedef enum
57  {
58    FFEEXPR_exprtypeUNKNOWN_,
59    FFEEXPR_exprtypeOPERAND_,
60    FFEEXPR_exprtypeUNARY_,
61    FFEEXPR_exprtypeBINARY_,
62    FFEEXPR_exprtype_
63  } ffeexprExprtype_;
64
65typedef enum
66  {
67    FFEEXPR_operatorPOWER_,
68    FFEEXPR_operatorMULTIPLY_,
69    FFEEXPR_operatorDIVIDE_,
70    FFEEXPR_operatorADD_,
71    FFEEXPR_operatorSUBTRACT_,
72    FFEEXPR_operatorCONCATENATE_,
73    FFEEXPR_operatorLT_,
74    FFEEXPR_operatorLE_,
75    FFEEXPR_operatorEQ_,
76    FFEEXPR_operatorNE_,
77    FFEEXPR_operatorGT_,
78    FFEEXPR_operatorGE_,
79    FFEEXPR_operatorNOT_,
80    FFEEXPR_operatorAND_,
81    FFEEXPR_operatorOR_,
82    FFEEXPR_operatorXOR_,
83    FFEEXPR_operatorEQV_,
84    FFEEXPR_operatorNEQV_,
85    FFEEXPR_operator_
86  } ffeexprOperator_;
87
88typedef enum
89  {
90    FFEEXPR_operatorprecedenceHIGHEST_ = 1,
91    FFEEXPR_operatorprecedencePOWER_ = 1,
92    FFEEXPR_operatorprecedenceMULTIPLY_ = 2,
93    FFEEXPR_operatorprecedenceDIVIDE_ = 2,
94    FFEEXPR_operatorprecedenceADD_ = 3,
95    FFEEXPR_operatorprecedenceSUBTRACT_ = 3,
96    FFEEXPR_operatorprecedenceLOWARITH_ = 3,
97    FFEEXPR_operatorprecedenceCONCATENATE_ = 3,
98    FFEEXPR_operatorprecedenceLT_ = 4,
99    FFEEXPR_operatorprecedenceLE_ = 4,
100    FFEEXPR_operatorprecedenceEQ_ = 4,
101    FFEEXPR_operatorprecedenceNE_ = 4,
102    FFEEXPR_operatorprecedenceGT_ = 4,
103    FFEEXPR_operatorprecedenceGE_ = 4,
104    FFEEXPR_operatorprecedenceNOT_ = 5,
105    FFEEXPR_operatorprecedenceAND_ = 6,
106    FFEEXPR_operatorprecedenceOR_ = 7,
107    FFEEXPR_operatorprecedenceXOR_ = 8,
108    FFEEXPR_operatorprecedenceEQV_ = 8,
109    FFEEXPR_operatorprecedenceNEQV_ = 8,
110    FFEEXPR_operatorprecedenceLOWEST_ = 8,
111    FFEEXPR_operatorprecedence_
112  } ffeexprOperatorPrecedence_;
113
114#define FFEEXPR_operatorassociativityL2R_ TRUE
115#define FFEEXPR_operatorassociativityR2L_ FALSE
116#define FFEEXPR_operatorassociativityPOWER_ FFEEXPR_operatorassociativityR2L_
117#define FFEEXPR_operatorassociativityMULTIPLY_ FFEEXPR_operatorassociativityL2R_
118#define FFEEXPR_operatorassociativityDIVIDE_ FFEEXPR_operatorassociativityL2R_
119#define FFEEXPR_operatorassociativityADD_ FFEEXPR_operatorassociativityL2R_
120#define FFEEXPR_operatorassociativitySUBTRACT_ FFEEXPR_operatorassociativityL2R_
121#define FFEEXPR_operatorassociativityCONCATENATE_ FFEEXPR_operatorassociativityL2R_
122#define FFEEXPR_operatorassociativityLT_ FFEEXPR_operatorassociativityL2R_
123#define FFEEXPR_operatorassociativityLE_ FFEEXPR_operatorassociativityL2R_
124#define FFEEXPR_operatorassociativityEQ_ FFEEXPR_operatorassociativityL2R_
125#define FFEEXPR_operatorassociativityNE_ FFEEXPR_operatorassociativityL2R_
126#define FFEEXPR_operatorassociativityGT_ FFEEXPR_operatorassociativityL2R_
127#define FFEEXPR_operatorassociativityGE_ FFEEXPR_operatorassociativityL2R_
128#define FFEEXPR_operatorassociativityNOT_ FFEEXPR_operatorassociativityL2R_
129#define FFEEXPR_operatorassociativityAND_ FFEEXPR_operatorassociativityL2R_
130#define FFEEXPR_operatorassociativityOR_ FFEEXPR_operatorassociativityL2R_
131#define FFEEXPR_operatorassociativityXOR_ FFEEXPR_operatorassociativityL2R_
132#define FFEEXPR_operatorassociativityEQV_ FFEEXPR_operatorassociativityL2R_
133#define FFEEXPR_operatorassociativityNEQV_ FFEEXPR_operatorassociativityL2R_
134
135typedef enum
136  {
137    FFEEXPR_parentypeFUNCTION_,
138    FFEEXPR_parentypeSUBROUTINE_,
139    FFEEXPR_parentypeARRAY_,
140    FFEEXPR_parentypeSUBSTRING_,
141    FFEEXPR_parentypeFUNSUBSTR_,/* Ambig: check for colon after first expr. */
142    FFEEXPR_parentypeEQUIVALENCE_,	/* Ambig: ARRAY_ or SUBSTRING_. */
143    FFEEXPR_parentypeANY_,	/* Allow basically anything. */
144    FFEEXPR_parentype_
145  } ffeexprParenType_;
146
147typedef enum
148  {
149    FFEEXPR_percentNONE_,
150    FFEEXPR_percentLOC_,
151    FFEEXPR_percentVAL_,
152    FFEEXPR_percentREF_,
153    FFEEXPR_percentDESCR_,
154    FFEEXPR_percent_
155  } ffeexprPercent_;
156
157/* Internal typedefs. */
158
159typedef struct _ffeexpr_expr_ *ffeexprExpr_;
160typedef bool ffeexprOperatorAssociativity_;
161typedef struct _ffeexpr_stack_ *ffeexprStack_;
162
163/* Private include files. */
164
165
166/* Internal structure definitions. */
167
168struct _ffeexpr_expr_
169  {
170    ffeexprExpr_ previous;
171    ffelexToken token;
172    ffeexprExprtype_ type;
173    union
174      {
175	struct
176	  {
177	    ffeexprOperator_ op;
178	    ffeexprOperatorPrecedence_ prec;
179	    ffeexprOperatorAssociativity_ as;
180	  }
181	operator;
182	ffebld operand;
183      }
184    u;
185  };
186
187struct _ffeexpr_stack_
188  {
189    ffeexprStack_ previous;
190    mallocPool pool;
191    ffeexprContext context;
192    ffeexprCallback callback;
193    ffelexToken first_token;
194    ffeexprExpr_ exprstack;
195    ffelexToken tokens[10];	/* Used in certain cases, like (unary)
196				   open-paren. */
197    ffebld expr;		/* For first of
198				   complex/implied-do/substring/array-elements
199				   / actual-args expression. */
200    ffebld bound_list;		/* For tracking dimension bounds list of
201				   array. */
202    ffebldListBottom bottom;	/* For building lists. */
203    ffeinfoRank rank;		/* For elements in an array reference. */
204    bool constant;		/* TRUE while elements seen so far are
205				   constants. */
206    bool immediate;		/* TRUE while elements seen so far are
207				   immediate/constants. */
208    ffebld next_dummy;		/* Next SFUNC dummy arg in arg list. */
209    ffebldListLength num_args;	/* Number of dummy args expected in arg list. */
210    bool is_rhs;		/* TRUE if rhs context, FALSE otherwise. */
211    ffeexprPercent_ percent;	/* Current %FOO keyword. */
212  };
213
214struct _ffeexpr_find_
215  {
216    ffelexToken t;
217    ffelexHandler after;
218    int level;
219  };
220
221/* Static objects accessed by functions in this module. */
222
223static ffeexprStack_ ffeexpr_stack_;	/* Expression stack for semantic. */
224static ffelexToken ffeexpr_tokens_[10];	/* Scratchpad tokens for syntactic. */
225static ffestrOther ffeexpr_current_dotdot_;	/* Current .FOO. keyword. */
226static long ffeexpr_hollerith_count_;	/* ffeexpr_token_number_ and caller. */
227static int ffeexpr_level_;	/* Level of DATA implied-DO construct. */
228static bool ffeexpr_is_substr_ok_;	/* If OPEN_PAREN as binary "op" ok. */
229static struct _ffeexpr_find_ ffeexpr_find_;
230
231/* Static functions (internal). */
232
233static ffelexHandler ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr,
234					      ffelexToken t);
235static ffelexHandler ffeexpr_cb_close_paren_ambig_ (ffelexToken ft,
236						    ffebld expr,
237						    ffelexToken t);
238static ffelexHandler ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t);
239static ffelexHandler ffeexpr_cb_close_paren_c_ (ffelexToken ft,
240						ffebld expr, ffelexToken t);
241static ffelexHandler ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr,
242					  ffelexToken t);
243static ffelexHandler ffeexpr_cb_close_paren_ci_ (ffelexToken ft,
244						 ffebld expr, ffelexToken t);
245static ffelexHandler ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr,
246					   ffelexToken t);
247static ffelexHandler ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr,
248					  ffelexToken t);
249static ffelexHandler ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr,
250					    ffelexToken t);
251static ffelexHandler ffeexpr_cb_comma_i_2_ (ffelexToken ft, ffebld expr,
252					    ffelexToken t);
253static ffelexHandler ffeexpr_cb_comma_i_3_ (ffelexToken ft, ffebld expr,
254					    ffelexToken t);
255static ffelexHandler ffeexpr_cb_comma_i_4_ (ffelexToken ft, ffebld expr,
256					    ffelexToken t);
257static ffelexHandler ffeexpr_cb_comma_i_5_ (ffelexToken t);
258static ffelexHandler ffeexpr_cb_end_loc_ (ffelexToken ft, ffebld expr,
259					  ffelexToken t);
260static ffelexHandler ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr,
261					     ffelexToken t);
262static ffelexHandler ffeexpr_cb_end_notloc_1_ (ffelexToken t);
263static ffesymbol ffeexpr_check_impctrl_ (ffesymbol s);
264static void ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
265				  ffebld dovar, ffelexToken dovar_t);
266static void ffeexpr_update_impdo_ (ffebld expr, ffebld dovar);
267static void ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar);
268static ffeexprContext ffeexpr_context_outer_ (ffeexprStack_ s);
269static ffeexprExpr_ ffeexpr_expr_new_ (void);
270static void ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t);
271static bool ffeexpr_isdigits_ (const char *p);
272static ffelexHandler ffeexpr_token_first_lhs_ (ffelexToken t);
273static ffelexHandler ffeexpr_token_first_lhs_1_ (ffelexToken t);
274static ffelexHandler ffeexpr_token_first_rhs_ (ffelexToken t);
275static ffelexHandler ffeexpr_token_first_rhs_1_ (ffelexToken t);
276static ffelexHandler ffeexpr_token_first_rhs_2_ (ffelexToken t);
277static ffelexHandler ffeexpr_token_first_rhs_3_ (ffelexToken t);
278static ffelexHandler ffeexpr_token_first_rhs_4_ (ffelexToken t);
279static ffelexHandler ffeexpr_token_first_rhs_5_ (ffelexToken t);
280static ffelexHandler ffeexpr_token_first_rhs_6_ (ffelexToken t);
281static ffelexHandler ffeexpr_token_namelist_ (ffelexToken t);
282static void ffeexpr_expr_kill_ (ffeexprExpr_ e);
283static void ffeexpr_exprstack_push_ (ffeexprExpr_ e);
284static void ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e);
285static void ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e);
286static void ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e);
287static void ffeexpr_reduce_ (void);
288static ffebld ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op,
289				      ffeexprExpr_ r);
290static ffebld ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l,
291				      ffeexprExpr_ op, ffeexprExpr_ r);
292static ffebld ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l,
293					    ffeexprExpr_ op, ffeexprExpr_ r);
294static ffebld ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l,
295				      ffeexprExpr_ op, ffeexprExpr_ r);
296static ffebld ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op,
297				      ffeexprExpr_ r);
298static ffebld ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l,
299				      ffeexprExpr_ op, ffeexprExpr_ r);
300static ffebld ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l,
301				      ffeexprExpr_ op, ffeexprExpr_ r);
302static ffebld ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l,
303				       ffeexprExpr_ op, ffeexprExpr_ r);
304static ffebld ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r);
305static ffebld ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op,
306					 ffeexprExpr_ r);
307static ffebld ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l,
308				      ffeexprExpr_ op, ffeexprExpr_ r);
309static ffebld ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l,
310					 ffeexprExpr_ op, ffeexprExpr_ r);
311static ffelexHandler ffeexpr_find_close_paren_ (ffelexToken t,
312						ffelexHandler after);
313static ffelexHandler ffeexpr_nil_finished_ (ffelexToken t);
314static ffelexHandler ffeexpr_nil_rhs_ (ffelexToken t);
315static ffelexHandler ffeexpr_nil_period_ (ffelexToken t);
316static ffelexHandler ffeexpr_nil_end_period_ (ffelexToken t);
317static ffelexHandler ffeexpr_nil_swallow_period_ (ffelexToken t);
318static ffelexHandler ffeexpr_nil_real_ (ffelexToken t);
319static ffelexHandler ffeexpr_nil_real_exponent_ (ffelexToken t);
320static ffelexHandler ffeexpr_nil_real_exp_sign_ (ffelexToken t);
321static ffelexHandler ffeexpr_nil_number_ (ffelexToken t);
322static ffelexHandler ffeexpr_nil_number_exponent_ (ffelexToken t);
323static ffelexHandler ffeexpr_nil_number_exp_sign_ (ffelexToken t);
324static ffelexHandler ffeexpr_nil_number_period_ (ffelexToken t);
325static ffelexHandler ffeexpr_nil_number_per_exp_ (ffelexToken t);
326static ffelexHandler ffeexpr_nil_number_real_ (ffelexToken t);
327static ffelexHandler ffeexpr_nil_num_per_exp_sign_ (ffelexToken t);
328static ffelexHandler ffeexpr_nil_number_real_exp_ (ffelexToken t);
329static ffelexHandler ffeexpr_nil_num_real_exp_sn_ (ffelexToken t);
330static ffelexHandler ffeexpr_nil_binary_ (ffelexToken t);
331static ffelexHandler ffeexpr_nil_binary_period_ (ffelexToken t);
332static ffelexHandler ffeexpr_nil_binary_end_per_ (ffelexToken t);
333static ffelexHandler ffeexpr_nil_binary_sw_per_ (ffelexToken t);
334static ffelexHandler ffeexpr_nil_quote_ (ffelexToken t);
335static ffelexHandler ffeexpr_nil_apostrophe_ (ffelexToken t);
336static ffelexHandler ffeexpr_nil_apos_char_ (ffelexToken t);
337static ffelexHandler ffeexpr_nil_name_rhs_ (ffelexToken t);
338static ffelexHandler ffeexpr_nil_name_apos_ (ffelexToken t);
339static ffelexHandler ffeexpr_nil_name_apos_name_ (ffelexToken t);
340static ffelexHandler ffeexpr_nil_percent_ (ffelexToken t);
341static ffelexHandler ffeexpr_nil_percent_name_ (ffelexToken t);
342static ffelexHandler ffeexpr_nil_substrp_ (ffelexToken t);
343static ffelexHandler ffeexpr_finished_ (ffelexToken t);
344static ffebld ffeexpr_finished_ambig_ (ffelexToken t, ffebld expr);
345static ffelexHandler ffeexpr_token_lhs_ (ffelexToken t);
346static ffelexHandler ffeexpr_token_rhs_ (ffelexToken t);
347static ffelexHandler ffeexpr_token_binary_ (ffelexToken t);
348static ffelexHandler ffeexpr_token_period_ (ffelexToken t);
349static ffelexHandler ffeexpr_token_end_period_ (ffelexToken t);
350static ffelexHandler ffeexpr_token_swallow_period_ (ffelexToken t);
351static ffelexHandler ffeexpr_token_real_ (ffelexToken t);
352static ffelexHandler ffeexpr_token_real_exponent_ (ffelexToken t);
353static ffelexHandler ffeexpr_token_real_exp_sign_ (ffelexToken t);
354static ffelexHandler ffeexpr_token_number_ (ffelexToken t);
355static ffelexHandler ffeexpr_token_number_exponent_ (ffelexToken t);
356static ffelexHandler ffeexpr_token_number_exp_sign_ (ffelexToken t);
357static ffelexHandler ffeexpr_token_number_period_ (ffelexToken t);
358static ffelexHandler ffeexpr_token_number_per_exp_ (ffelexToken t);
359static ffelexHandler ffeexpr_token_number_real_ (ffelexToken t);
360static ffelexHandler ffeexpr_token_num_per_exp_sign_ (ffelexToken t);
361static ffelexHandler ffeexpr_token_number_real_exp_ (ffelexToken t);
362static ffelexHandler ffeexpr_token_num_real_exp_sn_ (ffelexToken t);
363static ffelexHandler ffeexpr_token_binary_period_ (ffelexToken t);
364static ffelexHandler ffeexpr_token_binary_end_per_ (ffelexToken t);
365static ffelexHandler ffeexpr_token_binary_sw_per_ (ffelexToken t);
366static ffelexHandler ffeexpr_token_quote_ (ffelexToken t);
367static ffelexHandler ffeexpr_token_apostrophe_ (ffelexToken t);
368static ffelexHandler ffeexpr_token_apos_char_ (ffelexToken t);
369static ffelexHandler ffeexpr_token_name_lhs_ (ffelexToken t);
370static ffelexHandler ffeexpr_token_name_arg_ (ffelexToken t);
371static ffelexHandler ffeexpr_token_name_rhs_ (ffelexToken t);
372static ffelexHandler ffeexpr_token_name_apos_ (ffelexToken t);
373static ffelexHandler ffeexpr_token_name_apos_name_ (ffelexToken t);
374static ffelexHandler ffeexpr_token_percent_ (ffelexToken t);
375static ffelexHandler ffeexpr_token_percent_name_ (ffelexToken t);
376static ffelexHandler ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr,
377					       ffelexToken t);
378static ffelexHandler ffeexpr_token_elements_ (ffelexToken ft, ffebld expr,
379					      ffelexToken t);
380static ffelexHandler ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr,
381						 ffelexToken t);
382static ffelexHandler ffeexpr_token_substring_ (ffelexToken ft, ffebld expr,
383					       ffelexToken t);
384static ffelexHandler ffeexpr_token_substring_1_ (ffelexToken ft, ffebld expr,
385						 ffelexToken t);
386static ffelexHandler ffeexpr_token_substrp_ (ffelexToken t);
387static ffelexHandler ffeexpr_token_intrincheck_ (ffelexToken t);
388static ffelexHandler ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr,
389					       ffelexToken t);
390static ffelexHandler ffeexpr_token_anything_ (ffelexToken ft, ffebld expr,
391					      ffelexToken t);
392static void ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
393	    ffelexToken decimal, ffelexToken fraction, ffelexToken exponent,
394		    ffelexToken exponent_sign, ffelexToken exponent_digits);
395static ffesymbol ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin);
396static ffesymbol ffeexpr_sym_impdoitem_ (ffesymbol s, ffelexToken t);
397static ffesymbol ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t);
398static ffesymbol ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t);
399static ffesymbol ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t);
400static ffesymbol ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t);
401static ffesymbol ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t);
402static ffesymbol ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t);
403static ffesymbol ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t);
404static ffesymbol ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t);
405static ffesymbol ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t);
406static ffesymbol ffeexpr_declare_parenthesized_ (ffelexToken t,
407						 bool maybe_intrin,
408					     ffeexprParenType_ *paren_type);
409static ffesymbol ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t);
410
411/* Internal macros. */
412
413#define ffeexpr_paren_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
414#define ffeexpr_sym_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
415
416/* ffeexpr_collapse_convert -- Collapse convert expr
417
418   ffebld expr;
419   ffelexToken token;
420   expr = ffeexpr_collapse_convert(expr,token);
421
422   If the result of the expr is a constant, replaces the expr with the
423   computed constant.  */
424
425ffebld
426ffeexpr_collapse_convert (ffebld expr, ffelexToken t)
427{
428  ffebad error = FFEBAD;
429  ffebld l;
430  ffebldConstantUnion u;
431  ffeinfoBasictype bt;
432  ffeinfoKindtype kt;
433  ffetargetCharacterSize sz;
434  ffetargetCharacterSize sz2;
435
436  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
437    return expr;
438
439  l = ffebld_left (expr);
440
441  if (ffebld_op (l) != FFEBLD_opCONTER)
442    return expr;
443
444  switch (bt = ffeinfo_basictype (ffebld_info (expr)))
445    {
446    case FFEINFO_basictypeANY:
447      return expr;
448
449    case FFEINFO_basictypeINTEGER:
450      sz = FFETARGET_charactersizeNONE;
451      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
452	{
453#if FFETARGET_okINTEGER1
454	case FFEINFO_kindtypeINTEGER1:
455	  switch (ffeinfo_basictype (ffebld_info (l)))
456	    {
457	    case FFEINFO_basictypeINTEGER:
458	      switch (ffeinfo_kindtype (ffebld_info (l)))
459		{
460#if FFETARGET_okINTEGER2
461		case FFEINFO_kindtypeINTEGER2:
462		  error = ffetarget_convert_integer1_integer2
463		    (ffebld_cu_ptr_integer1 (u),
464		     ffebld_constant_integer2 (ffebld_conter (l)));
465		  break;
466#endif
467
468#if FFETARGET_okINTEGER3
469		case FFEINFO_kindtypeINTEGER3:
470		  error = ffetarget_convert_integer1_integer3
471		    (ffebld_cu_ptr_integer1 (u),
472		     ffebld_constant_integer3 (ffebld_conter (l)));
473		  break;
474#endif
475
476#if FFETARGET_okINTEGER4
477		case FFEINFO_kindtypeINTEGER4:
478		  error = ffetarget_convert_integer1_integer4
479		    (ffebld_cu_ptr_integer1 (u),
480		     ffebld_constant_integer4 (ffebld_conter (l)));
481		  break;
482#endif
483
484		default:
485		  assert ("INTEGER1/INTEGER bad source kind type" == NULL);
486		  break;
487		}
488	      break;
489
490	    case FFEINFO_basictypeREAL:
491	      switch (ffeinfo_kindtype (ffebld_info (l)))
492		{
493#if FFETARGET_okREAL1
494		case FFEINFO_kindtypeREAL1:
495		  error = ffetarget_convert_integer1_real1
496		    (ffebld_cu_ptr_integer1 (u),
497		     ffebld_constant_real1 (ffebld_conter (l)));
498		  break;
499#endif
500
501#if FFETARGET_okREAL2
502		case FFEINFO_kindtypeREAL2:
503		  error = ffetarget_convert_integer1_real2
504		    (ffebld_cu_ptr_integer1 (u),
505		     ffebld_constant_real2 (ffebld_conter (l)));
506		  break;
507#endif
508
509#if FFETARGET_okREAL3
510		case FFEINFO_kindtypeREAL3:
511		  error = ffetarget_convert_integer1_real3
512		    (ffebld_cu_ptr_integer1 (u),
513		     ffebld_constant_real3 (ffebld_conter (l)));
514		  break;
515#endif
516
517#if FFETARGET_okREAL4
518		case FFEINFO_kindtypeREAL4:
519		  error = ffetarget_convert_integer1_real4
520		    (ffebld_cu_ptr_integer1 (u),
521		     ffebld_constant_real4 (ffebld_conter (l)));
522		  break;
523#endif
524
525		default:
526		  assert ("INTEGER1/REAL bad source kind type" == NULL);
527		  break;
528		}
529	      break;
530
531	    case FFEINFO_basictypeCOMPLEX:
532	      switch (ffeinfo_kindtype (ffebld_info (l)))
533		{
534#if FFETARGET_okCOMPLEX1
535		case FFEINFO_kindtypeREAL1:
536		  error = ffetarget_convert_integer1_complex1
537		    (ffebld_cu_ptr_integer1 (u),
538		     ffebld_constant_complex1 (ffebld_conter (l)));
539		  break;
540#endif
541
542#if FFETARGET_okCOMPLEX2
543		case FFEINFO_kindtypeREAL2:
544		  error = ffetarget_convert_integer1_complex2
545		    (ffebld_cu_ptr_integer1 (u),
546		     ffebld_constant_complex2 (ffebld_conter (l)));
547		  break;
548#endif
549
550#if FFETARGET_okCOMPLEX3
551		case FFEINFO_kindtypeREAL3:
552		  error = ffetarget_convert_integer1_complex3
553		    (ffebld_cu_ptr_integer1 (u),
554		     ffebld_constant_complex3 (ffebld_conter (l)));
555		  break;
556#endif
557
558#if FFETARGET_okCOMPLEX4
559		case FFEINFO_kindtypeREAL4:
560		  error = ffetarget_convert_integer1_complex4
561		    (ffebld_cu_ptr_integer1 (u),
562		     ffebld_constant_complex4 (ffebld_conter (l)));
563		  break;
564#endif
565
566		default:
567		  assert ("INTEGER1/COMPLEX bad source kind type" == NULL);
568		  break;
569		}
570	      break;
571
572	    case FFEINFO_basictypeLOGICAL:
573	      switch (ffeinfo_kindtype (ffebld_info (l)))
574		{
575#if FFETARGET_okLOGICAL1
576		case FFEINFO_kindtypeLOGICAL1:
577		  error = ffetarget_convert_integer1_logical1
578		    (ffebld_cu_ptr_integer1 (u),
579		     ffebld_constant_logical1 (ffebld_conter (l)));
580		  break;
581#endif
582
583#if FFETARGET_okLOGICAL2
584		case FFEINFO_kindtypeLOGICAL2:
585		  error = ffetarget_convert_integer1_logical2
586		    (ffebld_cu_ptr_integer1 (u),
587		     ffebld_constant_logical2 (ffebld_conter (l)));
588		  break;
589#endif
590
591#if FFETARGET_okLOGICAL3
592		case FFEINFO_kindtypeLOGICAL3:
593		  error = ffetarget_convert_integer1_logical3
594		    (ffebld_cu_ptr_integer1 (u),
595		     ffebld_constant_logical3 (ffebld_conter (l)));
596		  break;
597#endif
598
599#if FFETARGET_okLOGICAL4
600		case FFEINFO_kindtypeLOGICAL4:
601		  error = ffetarget_convert_integer1_logical4
602		    (ffebld_cu_ptr_integer1 (u),
603		     ffebld_constant_logical4 (ffebld_conter (l)));
604		  break;
605#endif
606
607		default:
608		  assert ("INTEGER1/LOGICAL bad source kind type" == NULL);
609		  break;
610		}
611	      break;
612
613	    case FFEINFO_basictypeCHARACTER:
614	      error = ffetarget_convert_integer1_character1
615		(ffebld_cu_ptr_integer1 (u),
616		 ffebld_constant_character1 (ffebld_conter (l)));
617	      break;
618
619	    case FFEINFO_basictypeHOLLERITH:
620	      error = ffetarget_convert_integer1_hollerith
621		(ffebld_cu_ptr_integer1 (u),
622		 ffebld_constant_hollerith (ffebld_conter (l)));
623	      break;
624
625	    case FFEINFO_basictypeTYPELESS:
626	      error = ffetarget_convert_integer1_typeless
627		(ffebld_cu_ptr_integer1 (u),
628		 ffebld_constant_typeless (ffebld_conter (l)));
629	      break;
630
631	    default:
632	      assert ("INTEGER1 bad type" == NULL);
633	      break;
634	    }
635
636	  /* If conversion operation is not implemented, return original expr.  */
637	  if (error == FFEBAD_NOCANDO)
638	    return expr;
639
640	  expr = ffebld_new_conter_with_orig
641	    (ffebld_constant_new_integer1_val
642	     (ffebld_cu_val_integer1 (u)), expr);
643	  break;
644#endif
645
646#if FFETARGET_okINTEGER2
647	case FFEINFO_kindtypeINTEGER2:
648	  switch (ffeinfo_basictype (ffebld_info (l)))
649	    {
650	    case FFEINFO_basictypeINTEGER:
651	      switch (ffeinfo_kindtype (ffebld_info (l)))
652		{
653#if FFETARGET_okINTEGER1
654		case FFEINFO_kindtypeINTEGER1:
655		  error = ffetarget_convert_integer2_integer1
656		    (ffebld_cu_ptr_integer2 (u),
657		     ffebld_constant_integer1 (ffebld_conter (l)));
658		  break;
659#endif
660
661#if FFETARGET_okINTEGER3
662		case FFEINFO_kindtypeINTEGER3:
663		  error = ffetarget_convert_integer2_integer3
664		    (ffebld_cu_ptr_integer2 (u),
665		     ffebld_constant_integer3 (ffebld_conter (l)));
666		  break;
667#endif
668
669#if FFETARGET_okINTEGER4
670		case FFEINFO_kindtypeINTEGER4:
671		  error = ffetarget_convert_integer2_integer4
672		    (ffebld_cu_ptr_integer2 (u),
673		     ffebld_constant_integer4 (ffebld_conter (l)));
674		  break;
675#endif
676
677		default:
678		  assert ("INTEGER2/INTEGER bad source kind type" == NULL);
679		  break;
680		}
681	      break;
682
683	    case FFEINFO_basictypeREAL:
684	      switch (ffeinfo_kindtype (ffebld_info (l)))
685		{
686#if FFETARGET_okREAL1
687		case FFEINFO_kindtypeREAL1:
688		  error = ffetarget_convert_integer2_real1
689		    (ffebld_cu_ptr_integer2 (u),
690		     ffebld_constant_real1 (ffebld_conter (l)));
691		  break;
692#endif
693
694#if FFETARGET_okREAL2
695		case FFEINFO_kindtypeREAL2:
696		  error = ffetarget_convert_integer2_real2
697		    (ffebld_cu_ptr_integer2 (u),
698		     ffebld_constant_real2 (ffebld_conter (l)));
699		  break;
700#endif
701
702#if FFETARGET_okREAL3
703		case FFEINFO_kindtypeREAL3:
704		  error = ffetarget_convert_integer2_real3
705		    (ffebld_cu_ptr_integer2 (u),
706		     ffebld_constant_real3 (ffebld_conter (l)));
707		  break;
708#endif
709
710#if FFETARGET_okREAL4
711		case FFEINFO_kindtypeREAL4:
712		  error = ffetarget_convert_integer2_real4
713		    (ffebld_cu_ptr_integer2 (u),
714		     ffebld_constant_real4 (ffebld_conter (l)));
715		  break;
716#endif
717
718		default:
719		  assert ("INTEGER2/REAL bad source kind type" == NULL);
720		  break;
721		}
722	      break;
723
724	    case FFEINFO_basictypeCOMPLEX:
725	      switch (ffeinfo_kindtype (ffebld_info (l)))
726		{
727#if FFETARGET_okCOMPLEX1
728		case FFEINFO_kindtypeREAL1:
729		  error = ffetarget_convert_integer2_complex1
730		    (ffebld_cu_ptr_integer2 (u),
731		     ffebld_constant_complex1 (ffebld_conter (l)));
732		  break;
733#endif
734
735#if FFETARGET_okCOMPLEX2
736		case FFEINFO_kindtypeREAL2:
737		  error = ffetarget_convert_integer2_complex2
738		    (ffebld_cu_ptr_integer2 (u),
739		     ffebld_constant_complex2 (ffebld_conter (l)));
740		  break;
741#endif
742
743#if FFETARGET_okCOMPLEX3
744		case FFEINFO_kindtypeREAL3:
745		  error = ffetarget_convert_integer2_complex3
746		    (ffebld_cu_ptr_integer2 (u),
747		     ffebld_constant_complex3 (ffebld_conter (l)));
748		  break;
749#endif
750
751#if FFETARGET_okCOMPLEX4
752		case FFEINFO_kindtypeREAL4:
753		  error = ffetarget_convert_integer2_complex4
754		    (ffebld_cu_ptr_integer2 (u),
755		     ffebld_constant_complex4 (ffebld_conter (l)));
756		  break;
757#endif
758
759		default:
760		  assert ("INTEGER2/COMPLEX bad source kind type" == NULL);
761		  break;
762		}
763	      break;
764
765	    case FFEINFO_basictypeLOGICAL:
766	      switch (ffeinfo_kindtype (ffebld_info (l)))
767		{
768#if FFETARGET_okLOGICAL1
769		case FFEINFO_kindtypeLOGICAL1:
770		  error = ffetarget_convert_integer2_logical1
771		    (ffebld_cu_ptr_integer2 (u),
772		     ffebld_constant_logical1 (ffebld_conter (l)));
773		  break;
774#endif
775
776#if FFETARGET_okLOGICAL2
777		case FFEINFO_kindtypeLOGICAL2:
778		  error = ffetarget_convert_integer2_logical2
779		    (ffebld_cu_ptr_integer2 (u),
780		     ffebld_constant_logical2 (ffebld_conter (l)));
781		  break;
782#endif
783
784#if FFETARGET_okLOGICAL3
785		case FFEINFO_kindtypeLOGICAL3:
786		  error = ffetarget_convert_integer2_logical3
787		    (ffebld_cu_ptr_integer2 (u),
788		     ffebld_constant_logical3 (ffebld_conter (l)));
789		  break;
790#endif
791
792#if FFETARGET_okLOGICAL4
793		case FFEINFO_kindtypeLOGICAL4:
794		  error = ffetarget_convert_integer2_logical4
795		    (ffebld_cu_ptr_integer2 (u),
796		     ffebld_constant_logical4 (ffebld_conter (l)));
797		  break;
798#endif
799
800		default:
801		  assert ("INTEGER2/LOGICAL bad source kind type" == NULL);
802		  break;
803		}
804	      break;
805
806	    case FFEINFO_basictypeCHARACTER:
807	      error = ffetarget_convert_integer2_character1
808		(ffebld_cu_ptr_integer2 (u),
809		 ffebld_constant_character1 (ffebld_conter (l)));
810	      break;
811
812	    case FFEINFO_basictypeHOLLERITH:
813	      error = ffetarget_convert_integer2_hollerith
814		(ffebld_cu_ptr_integer2 (u),
815		 ffebld_constant_hollerith (ffebld_conter (l)));
816	      break;
817
818	    case FFEINFO_basictypeTYPELESS:
819	      error = ffetarget_convert_integer2_typeless
820		(ffebld_cu_ptr_integer2 (u),
821		 ffebld_constant_typeless (ffebld_conter (l)));
822	      break;
823
824	    default:
825	      assert ("INTEGER2 bad type" == NULL);
826	      break;
827	    }
828
829	  /* If conversion operation is not implemented, return original expr.  */
830	  if (error == FFEBAD_NOCANDO)
831	    return expr;
832
833	  expr = ffebld_new_conter_with_orig
834	    (ffebld_constant_new_integer2_val
835	     (ffebld_cu_val_integer2 (u)), expr);
836	  break;
837#endif
838
839#if FFETARGET_okINTEGER3
840	case FFEINFO_kindtypeINTEGER3:
841	  switch (ffeinfo_basictype (ffebld_info (l)))
842	    {
843	    case FFEINFO_basictypeINTEGER:
844	      switch (ffeinfo_kindtype (ffebld_info (l)))
845		{
846#if FFETARGET_okINTEGER1
847		case FFEINFO_kindtypeINTEGER1:
848		  error = ffetarget_convert_integer3_integer1
849		    (ffebld_cu_ptr_integer3 (u),
850		     ffebld_constant_integer1 (ffebld_conter (l)));
851		  break;
852#endif
853
854#if FFETARGET_okINTEGER2
855		case FFEINFO_kindtypeINTEGER2:
856		  error = ffetarget_convert_integer3_integer2
857		    (ffebld_cu_ptr_integer3 (u),
858		     ffebld_constant_integer2 (ffebld_conter (l)));
859		  break;
860#endif
861
862#if FFETARGET_okINTEGER4
863		case FFEINFO_kindtypeINTEGER4:
864		  error = ffetarget_convert_integer3_integer4
865		    (ffebld_cu_ptr_integer3 (u),
866		     ffebld_constant_integer4 (ffebld_conter (l)));
867		  break;
868#endif
869
870		default:
871		  assert ("INTEGER3/INTEGER bad source kind type" == NULL);
872		  break;
873		}
874	      break;
875
876	    case FFEINFO_basictypeREAL:
877	      switch (ffeinfo_kindtype (ffebld_info (l)))
878		{
879#if FFETARGET_okREAL1
880		case FFEINFO_kindtypeREAL1:
881		  error = ffetarget_convert_integer3_real1
882		    (ffebld_cu_ptr_integer3 (u),
883		     ffebld_constant_real1 (ffebld_conter (l)));
884		  break;
885#endif
886
887#if FFETARGET_okREAL2
888		case FFEINFO_kindtypeREAL2:
889		  error = ffetarget_convert_integer3_real2
890		    (ffebld_cu_ptr_integer3 (u),
891		     ffebld_constant_real2 (ffebld_conter (l)));
892		  break;
893#endif
894
895#if FFETARGET_okREAL3
896		case FFEINFO_kindtypeREAL3:
897		  error = ffetarget_convert_integer3_real3
898		    (ffebld_cu_ptr_integer3 (u),
899		     ffebld_constant_real3 (ffebld_conter (l)));
900		  break;
901#endif
902
903#if FFETARGET_okREAL4
904		case FFEINFO_kindtypeREAL4:
905		  error = ffetarget_convert_integer3_real4
906		    (ffebld_cu_ptr_integer3 (u),
907		     ffebld_constant_real4 (ffebld_conter (l)));
908		  break;
909#endif
910
911		default:
912		  assert ("INTEGER3/REAL bad source kind type" == NULL);
913		  break;
914		}
915	      break;
916
917	    case FFEINFO_basictypeCOMPLEX:
918	      switch (ffeinfo_kindtype (ffebld_info (l)))
919		{
920#if FFETARGET_okCOMPLEX1
921		case FFEINFO_kindtypeREAL1:
922		  error = ffetarget_convert_integer3_complex1
923		    (ffebld_cu_ptr_integer3 (u),
924		     ffebld_constant_complex1 (ffebld_conter (l)));
925		  break;
926#endif
927
928#if FFETARGET_okCOMPLEX2
929		case FFEINFO_kindtypeREAL2:
930		  error = ffetarget_convert_integer3_complex2
931		    (ffebld_cu_ptr_integer3 (u),
932		     ffebld_constant_complex2 (ffebld_conter (l)));
933		  break;
934#endif
935
936#if FFETARGET_okCOMPLEX3
937		case FFEINFO_kindtypeREAL3:
938		  error = ffetarget_convert_integer3_complex3
939		    (ffebld_cu_ptr_integer3 (u),
940		     ffebld_constant_complex3 (ffebld_conter (l)));
941		  break;
942#endif
943
944#if FFETARGET_okCOMPLEX4
945		case FFEINFO_kindtypeREAL4:
946		  error = ffetarget_convert_integer3_complex4
947		    (ffebld_cu_ptr_integer3 (u),
948		     ffebld_constant_complex4 (ffebld_conter (l)));
949		  break;
950#endif
951
952		default:
953		  assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
954		  break;
955		}
956	      break;
957
958	    case FFEINFO_basictypeLOGICAL:
959	      switch (ffeinfo_kindtype (ffebld_info (l)))
960		{
961#if FFETARGET_okLOGICAL1
962		case FFEINFO_kindtypeLOGICAL1:
963		  error = ffetarget_convert_integer3_logical1
964		    (ffebld_cu_ptr_integer3 (u),
965		     ffebld_constant_logical1 (ffebld_conter (l)));
966		  break;
967#endif
968
969#if FFETARGET_okLOGICAL2
970		case FFEINFO_kindtypeLOGICAL2:
971		  error = ffetarget_convert_integer3_logical2
972		    (ffebld_cu_ptr_integer3 (u),
973		     ffebld_constant_logical2 (ffebld_conter (l)));
974		  break;
975#endif
976
977#if FFETARGET_okLOGICAL3
978		case FFEINFO_kindtypeLOGICAL3:
979		  error = ffetarget_convert_integer3_logical3
980		    (ffebld_cu_ptr_integer3 (u),
981		     ffebld_constant_logical3 (ffebld_conter (l)));
982		  break;
983#endif
984
985#if FFETARGET_okLOGICAL4
986		case FFEINFO_kindtypeLOGICAL4:
987		  error = ffetarget_convert_integer3_logical4
988		    (ffebld_cu_ptr_integer3 (u),
989		     ffebld_constant_logical4 (ffebld_conter (l)));
990		  break;
991#endif
992
993		default:
994		  assert ("INTEGER3/LOGICAL bad source kind type" == NULL);
995		  break;
996		}
997	      break;
998
999	    case FFEINFO_basictypeCHARACTER:
1000	      error = ffetarget_convert_integer3_character1
1001		(ffebld_cu_ptr_integer3 (u),
1002		 ffebld_constant_character1 (ffebld_conter (l)));
1003	      break;
1004
1005	    case FFEINFO_basictypeHOLLERITH:
1006	      error = ffetarget_convert_integer3_hollerith
1007		(ffebld_cu_ptr_integer3 (u),
1008		 ffebld_constant_hollerith (ffebld_conter (l)));
1009	      break;
1010
1011	    case FFEINFO_basictypeTYPELESS:
1012	      error = ffetarget_convert_integer3_typeless
1013		(ffebld_cu_ptr_integer3 (u),
1014		 ffebld_constant_typeless (ffebld_conter (l)));
1015	      break;
1016
1017	    default:
1018	      assert ("INTEGER3 bad type" == NULL);
1019	      break;
1020	    }
1021
1022	  /* If conversion operation is not implemented, return original expr.  */
1023	  if (error == FFEBAD_NOCANDO)
1024	    return expr;
1025
1026	  expr = ffebld_new_conter_with_orig
1027	    (ffebld_constant_new_integer3_val
1028	     (ffebld_cu_val_integer3 (u)), expr);
1029	  break;
1030#endif
1031
1032#if FFETARGET_okINTEGER4
1033	case FFEINFO_kindtypeINTEGER4:
1034	  switch (ffeinfo_basictype (ffebld_info (l)))
1035	    {
1036	    case FFEINFO_basictypeINTEGER:
1037	      switch (ffeinfo_kindtype (ffebld_info (l)))
1038		{
1039#if FFETARGET_okINTEGER1
1040		case FFEINFO_kindtypeINTEGER1:
1041		  error = ffetarget_convert_integer4_integer1
1042		    (ffebld_cu_ptr_integer4 (u),
1043		     ffebld_constant_integer1 (ffebld_conter (l)));
1044		  break;
1045#endif
1046
1047#if FFETARGET_okINTEGER2
1048		case FFEINFO_kindtypeINTEGER2:
1049		  error = ffetarget_convert_integer4_integer2
1050		    (ffebld_cu_ptr_integer4 (u),
1051		     ffebld_constant_integer2 (ffebld_conter (l)));
1052		  break;
1053#endif
1054
1055#if FFETARGET_okINTEGER3
1056		case FFEINFO_kindtypeINTEGER3:
1057		  error = ffetarget_convert_integer4_integer3
1058		    (ffebld_cu_ptr_integer4 (u),
1059		     ffebld_constant_integer3 (ffebld_conter (l)));
1060		  break;
1061#endif
1062
1063		default:
1064		  assert ("INTEGER4/INTEGER bad source kind type" == NULL);
1065		  break;
1066		}
1067	      break;
1068
1069	    case FFEINFO_basictypeREAL:
1070	      switch (ffeinfo_kindtype (ffebld_info (l)))
1071		{
1072#if FFETARGET_okREAL1
1073		case FFEINFO_kindtypeREAL1:
1074		  error = ffetarget_convert_integer4_real1
1075		    (ffebld_cu_ptr_integer4 (u),
1076		     ffebld_constant_real1 (ffebld_conter (l)));
1077		  break;
1078#endif
1079
1080#if FFETARGET_okREAL2
1081		case FFEINFO_kindtypeREAL2:
1082		  error = ffetarget_convert_integer4_real2
1083		    (ffebld_cu_ptr_integer4 (u),
1084		     ffebld_constant_real2 (ffebld_conter (l)));
1085		  break;
1086#endif
1087
1088#if FFETARGET_okREAL3
1089		case FFEINFO_kindtypeREAL3:
1090		  error = ffetarget_convert_integer4_real3
1091		    (ffebld_cu_ptr_integer4 (u),
1092		     ffebld_constant_real3 (ffebld_conter (l)));
1093		  break;
1094#endif
1095
1096#if FFETARGET_okREAL4
1097		case FFEINFO_kindtypeREAL4:
1098		  error = ffetarget_convert_integer4_real4
1099		    (ffebld_cu_ptr_integer4 (u),
1100		     ffebld_constant_real4 (ffebld_conter (l)));
1101		  break;
1102#endif
1103
1104		default:
1105		  assert ("INTEGER4/REAL bad source kind type" == NULL);
1106		  break;
1107		}
1108	      break;
1109
1110	    case FFEINFO_basictypeCOMPLEX:
1111	      switch (ffeinfo_kindtype (ffebld_info (l)))
1112		{
1113#if FFETARGET_okCOMPLEX1
1114		case FFEINFO_kindtypeREAL1:
1115		  error = ffetarget_convert_integer4_complex1
1116		    (ffebld_cu_ptr_integer4 (u),
1117		     ffebld_constant_complex1 (ffebld_conter (l)));
1118		  break;
1119#endif
1120
1121#if FFETARGET_okCOMPLEX2
1122		case FFEINFO_kindtypeREAL2:
1123		  error = ffetarget_convert_integer4_complex2
1124		    (ffebld_cu_ptr_integer4 (u),
1125		     ffebld_constant_complex2 (ffebld_conter (l)));
1126		  break;
1127#endif
1128
1129#if FFETARGET_okCOMPLEX3
1130		case FFEINFO_kindtypeREAL3:
1131		  error = ffetarget_convert_integer4_complex3
1132		    (ffebld_cu_ptr_integer4 (u),
1133		     ffebld_constant_complex3 (ffebld_conter (l)));
1134		  break;
1135#endif
1136
1137#if FFETARGET_okCOMPLEX4
1138		case FFEINFO_kindtypeREAL4:
1139		  error = ffetarget_convert_integer4_complex4
1140		    (ffebld_cu_ptr_integer4 (u),
1141		     ffebld_constant_complex4 (ffebld_conter (l)));
1142		  break;
1143#endif
1144
1145		default:
1146		  assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
1147		  break;
1148		}
1149	      break;
1150
1151	    case FFEINFO_basictypeLOGICAL:
1152	      switch (ffeinfo_kindtype (ffebld_info (l)))
1153		{
1154#if FFETARGET_okLOGICAL1
1155		case FFEINFO_kindtypeLOGICAL1:
1156		  error = ffetarget_convert_integer4_logical1
1157		    (ffebld_cu_ptr_integer4 (u),
1158		     ffebld_constant_logical1 (ffebld_conter (l)));
1159		  break;
1160#endif
1161
1162#if FFETARGET_okLOGICAL2
1163		case FFEINFO_kindtypeLOGICAL2:
1164		  error = ffetarget_convert_integer4_logical2
1165		    (ffebld_cu_ptr_integer4 (u),
1166		     ffebld_constant_logical2 (ffebld_conter (l)));
1167		  break;
1168#endif
1169
1170#if FFETARGET_okLOGICAL3
1171		case FFEINFO_kindtypeLOGICAL3:
1172		  error = ffetarget_convert_integer4_logical3
1173		    (ffebld_cu_ptr_integer4 (u),
1174		     ffebld_constant_logical3 (ffebld_conter (l)));
1175		  break;
1176#endif
1177
1178#if FFETARGET_okLOGICAL4
1179		case FFEINFO_kindtypeLOGICAL4:
1180		  error = ffetarget_convert_integer4_logical4
1181		    (ffebld_cu_ptr_integer4 (u),
1182		     ffebld_constant_logical4 (ffebld_conter (l)));
1183		  break;
1184#endif
1185
1186		default:
1187		  assert ("INTEGER4/LOGICAL bad source kind type" == NULL);
1188		  break;
1189		}
1190	      break;
1191
1192	    case FFEINFO_basictypeCHARACTER:
1193	      error = ffetarget_convert_integer4_character1
1194		(ffebld_cu_ptr_integer4 (u),
1195		 ffebld_constant_character1 (ffebld_conter (l)));
1196	      break;
1197
1198	    case FFEINFO_basictypeHOLLERITH:
1199	      error = ffetarget_convert_integer4_hollerith
1200		(ffebld_cu_ptr_integer4 (u),
1201		 ffebld_constant_hollerith (ffebld_conter (l)));
1202	      break;
1203
1204	    case FFEINFO_basictypeTYPELESS:
1205	      error = ffetarget_convert_integer4_typeless
1206		(ffebld_cu_ptr_integer4 (u),
1207		 ffebld_constant_typeless (ffebld_conter (l)));
1208	      break;
1209
1210	    default:
1211	      assert ("INTEGER4 bad type" == NULL);
1212	      break;
1213	    }
1214
1215	  /* If conversion operation is not implemented, return original expr.  */
1216	  if (error == FFEBAD_NOCANDO)
1217	    return expr;
1218
1219	  expr = ffebld_new_conter_with_orig
1220	    (ffebld_constant_new_integer4_val
1221	     (ffebld_cu_val_integer4 (u)), expr);
1222	  break;
1223#endif
1224
1225	default:
1226	  assert ("bad integer kind type" == NULL);
1227	  break;
1228	}
1229      break;
1230
1231    case FFEINFO_basictypeLOGICAL:
1232      sz = FFETARGET_charactersizeNONE;
1233      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1234	{
1235#if FFETARGET_okLOGICAL1
1236	case FFEINFO_kindtypeLOGICAL1:
1237	  switch (ffeinfo_basictype (ffebld_info (l)))
1238	    {
1239	    case FFEINFO_basictypeLOGICAL:
1240	      switch (ffeinfo_kindtype (ffebld_info (l)))
1241		{
1242#if FFETARGET_okLOGICAL2
1243		case FFEINFO_kindtypeLOGICAL2:
1244		  error = ffetarget_convert_logical1_logical2
1245		    (ffebld_cu_ptr_logical1 (u),
1246		     ffebld_constant_logical2 (ffebld_conter (l)));
1247		  break;
1248#endif
1249
1250#if FFETARGET_okLOGICAL3
1251		case FFEINFO_kindtypeLOGICAL3:
1252		  error = ffetarget_convert_logical1_logical3
1253		    (ffebld_cu_ptr_logical1 (u),
1254		     ffebld_constant_logical3 (ffebld_conter (l)));
1255		  break;
1256#endif
1257
1258#if FFETARGET_okLOGICAL4
1259		case FFEINFO_kindtypeLOGICAL4:
1260		  error = ffetarget_convert_logical1_logical4
1261		    (ffebld_cu_ptr_logical1 (u),
1262		     ffebld_constant_logical4 (ffebld_conter (l)));
1263		  break;
1264#endif
1265
1266		default:
1267		  assert ("LOGICAL1/LOGICAL bad source kind type" == NULL);
1268		  break;
1269		}
1270	      break;
1271
1272	    case FFEINFO_basictypeINTEGER:
1273	      switch (ffeinfo_kindtype (ffebld_info (l)))
1274		{
1275#if FFETARGET_okINTEGER1
1276		case FFEINFO_kindtypeINTEGER1:
1277		  error = ffetarget_convert_logical1_integer1
1278		    (ffebld_cu_ptr_logical1 (u),
1279		     ffebld_constant_integer1 (ffebld_conter (l)));
1280		  break;
1281#endif
1282
1283#if FFETARGET_okINTEGER2
1284		case FFEINFO_kindtypeINTEGER2:
1285		  error = ffetarget_convert_logical1_integer2
1286		    (ffebld_cu_ptr_logical1 (u),
1287		     ffebld_constant_integer2 (ffebld_conter (l)));
1288		  break;
1289#endif
1290
1291#if FFETARGET_okINTEGER3
1292		case FFEINFO_kindtypeINTEGER3:
1293		  error = ffetarget_convert_logical1_integer3
1294		    (ffebld_cu_ptr_logical1 (u),
1295		     ffebld_constant_integer3 (ffebld_conter (l)));
1296		  break;
1297#endif
1298
1299#if FFETARGET_okINTEGER4
1300		case FFEINFO_kindtypeINTEGER4:
1301		  error = ffetarget_convert_logical1_integer4
1302		    (ffebld_cu_ptr_logical1 (u),
1303		     ffebld_constant_integer4 (ffebld_conter (l)));
1304		  break;
1305#endif
1306
1307		default:
1308		  assert ("LOGICAL1/INTEGER bad source kind type" == NULL);
1309		  break;
1310		}
1311	      break;
1312
1313	    case FFEINFO_basictypeCHARACTER:
1314	      error = ffetarget_convert_logical1_character1
1315		(ffebld_cu_ptr_logical1 (u),
1316		 ffebld_constant_character1 (ffebld_conter (l)));
1317	      break;
1318
1319	    case FFEINFO_basictypeHOLLERITH:
1320	      error = ffetarget_convert_logical1_hollerith
1321		(ffebld_cu_ptr_logical1 (u),
1322		 ffebld_constant_hollerith (ffebld_conter (l)));
1323	      break;
1324
1325	    case FFEINFO_basictypeTYPELESS:
1326	      error = ffetarget_convert_logical1_typeless
1327		(ffebld_cu_ptr_logical1 (u),
1328		 ffebld_constant_typeless (ffebld_conter (l)));
1329	      break;
1330
1331	    default:
1332	      assert ("LOGICAL1 bad type" == NULL);
1333	      break;
1334	    }
1335
1336	  /* If conversion operation is not implemented, return original expr.  */
1337	  if (error == FFEBAD_NOCANDO)
1338	    return expr;
1339
1340	  expr = ffebld_new_conter_with_orig
1341	    (ffebld_constant_new_logical1_val
1342	     (ffebld_cu_val_logical1 (u)), expr);
1343	  break;
1344#endif
1345
1346#if FFETARGET_okLOGICAL2
1347	case FFEINFO_kindtypeLOGICAL2:
1348	  switch (ffeinfo_basictype (ffebld_info (l)))
1349	    {
1350	    case FFEINFO_basictypeLOGICAL:
1351	      switch (ffeinfo_kindtype (ffebld_info (l)))
1352		{
1353#if FFETARGET_okLOGICAL1
1354		case FFEINFO_kindtypeLOGICAL1:
1355		  error = ffetarget_convert_logical2_logical1
1356		    (ffebld_cu_ptr_logical2 (u),
1357		     ffebld_constant_logical1 (ffebld_conter (l)));
1358		  break;
1359#endif
1360
1361#if FFETARGET_okLOGICAL3
1362		case FFEINFO_kindtypeLOGICAL3:
1363		  error = ffetarget_convert_logical2_logical3
1364		    (ffebld_cu_ptr_logical2 (u),
1365		     ffebld_constant_logical3 (ffebld_conter (l)));
1366		  break;
1367#endif
1368
1369#if FFETARGET_okLOGICAL4
1370		case FFEINFO_kindtypeLOGICAL4:
1371		  error = ffetarget_convert_logical2_logical4
1372		    (ffebld_cu_ptr_logical2 (u),
1373		     ffebld_constant_logical4 (ffebld_conter (l)));
1374		  break;
1375#endif
1376
1377		default:
1378		  assert ("LOGICAL2/LOGICAL bad source kind type" == NULL);
1379		  break;
1380		}
1381	      break;
1382
1383	    case FFEINFO_basictypeINTEGER:
1384	      switch (ffeinfo_kindtype (ffebld_info (l)))
1385		{
1386#if FFETARGET_okINTEGER1
1387		case FFEINFO_kindtypeINTEGER1:
1388		  error = ffetarget_convert_logical2_integer1
1389		    (ffebld_cu_ptr_logical2 (u),
1390		     ffebld_constant_integer1 (ffebld_conter (l)));
1391		  break;
1392#endif
1393
1394#if FFETARGET_okINTEGER2
1395		case FFEINFO_kindtypeINTEGER2:
1396		  error = ffetarget_convert_logical2_integer2
1397		    (ffebld_cu_ptr_logical2 (u),
1398		     ffebld_constant_integer2 (ffebld_conter (l)));
1399		  break;
1400#endif
1401
1402#if FFETARGET_okINTEGER3
1403		case FFEINFO_kindtypeINTEGER3:
1404		  error = ffetarget_convert_logical2_integer3
1405		    (ffebld_cu_ptr_logical2 (u),
1406		     ffebld_constant_integer3 (ffebld_conter (l)));
1407		  break;
1408#endif
1409
1410#if FFETARGET_okINTEGER4
1411		case FFEINFO_kindtypeINTEGER4:
1412		  error = ffetarget_convert_logical2_integer4
1413		    (ffebld_cu_ptr_logical2 (u),
1414		     ffebld_constant_integer4 (ffebld_conter (l)));
1415		  break;
1416#endif
1417
1418		default:
1419		  assert ("LOGICAL2/INTEGER bad source kind type" == NULL);
1420		  break;
1421		}
1422	      break;
1423
1424	    case FFEINFO_basictypeCHARACTER:
1425	      error = ffetarget_convert_logical2_character1
1426		(ffebld_cu_ptr_logical2 (u),
1427		 ffebld_constant_character1 (ffebld_conter (l)));
1428	      break;
1429
1430	    case FFEINFO_basictypeHOLLERITH:
1431	      error = ffetarget_convert_logical2_hollerith
1432		(ffebld_cu_ptr_logical2 (u),
1433		 ffebld_constant_hollerith (ffebld_conter (l)));
1434	      break;
1435
1436	    case FFEINFO_basictypeTYPELESS:
1437	      error = ffetarget_convert_logical2_typeless
1438		(ffebld_cu_ptr_logical2 (u),
1439		 ffebld_constant_typeless (ffebld_conter (l)));
1440	      break;
1441
1442	    default:
1443	      assert ("LOGICAL2 bad type" == NULL);
1444	      break;
1445	    }
1446
1447	  /* If conversion operation is not implemented, return original expr.  */
1448	  if (error == FFEBAD_NOCANDO)
1449	    return expr;
1450
1451	  expr = ffebld_new_conter_with_orig
1452	    (ffebld_constant_new_logical2_val
1453	     (ffebld_cu_val_logical2 (u)), expr);
1454	  break;
1455#endif
1456
1457#if FFETARGET_okLOGICAL3
1458	case FFEINFO_kindtypeLOGICAL3:
1459	  switch (ffeinfo_basictype (ffebld_info (l)))
1460	    {
1461	    case FFEINFO_basictypeLOGICAL:
1462	      switch (ffeinfo_kindtype (ffebld_info (l)))
1463		{
1464#if FFETARGET_okLOGICAL1
1465		case FFEINFO_kindtypeLOGICAL1:
1466		  error = ffetarget_convert_logical3_logical1
1467		    (ffebld_cu_ptr_logical3 (u),
1468		     ffebld_constant_logical1 (ffebld_conter (l)));
1469		  break;
1470#endif
1471
1472#if FFETARGET_okLOGICAL2
1473		case FFEINFO_kindtypeLOGICAL2:
1474		  error = ffetarget_convert_logical3_logical2
1475		    (ffebld_cu_ptr_logical3 (u),
1476		     ffebld_constant_logical2 (ffebld_conter (l)));
1477		  break;
1478#endif
1479
1480#if FFETARGET_okLOGICAL4
1481		case FFEINFO_kindtypeLOGICAL4:
1482		  error = ffetarget_convert_logical3_logical4
1483		    (ffebld_cu_ptr_logical3 (u),
1484		     ffebld_constant_logical4 (ffebld_conter (l)));
1485		  break;
1486#endif
1487
1488		default:
1489		  assert ("LOGICAL3/LOGICAL bad source kind type" == NULL);
1490		  break;
1491		}
1492	      break;
1493
1494	    case FFEINFO_basictypeINTEGER:
1495	      switch (ffeinfo_kindtype (ffebld_info (l)))
1496		{
1497#if FFETARGET_okINTEGER1
1498		case FFEINFO_kindtypeINTEGER1:
1499		  error = ffetarget_convert_logical3_integer1
1500		    (ffebld_cu_ptr_logical3 (u),
1501		     ffebld_constant_integer1 (ffebld_conter (l)));
1502		  break;
1503#endif
1504
1505#if FFETARGET_okINTEGER2
1506		case FFEINFO_kindtypeINTEGER2:
1507		  error = ffetarget_convert_logical3_integer2
1508		    (ffebld_cu_ptr_logical3 (u),
1509		     ffebld_constant_integer2 (ffebld_conter (l)));
1510		  break;
1511#endif
1512
1513#if FFETARGET_okINTEGER3
1514		case FFEINFO_kindtypeINTEGER3:
1515		  error = ffetarget_convert_logical3_integer3
1516		    (ffebld_cu_ptr_logical3 (u),
1517		     ffebld_constant_integer3 (ffebld_conter (l)));
1518		  break;
1519#endif
1520
1521#if FFETARGET_okINTEGER4
1522		case FFEINFO_kindtypeINTEGER4:
1523		  error = ffetarget_convert_logical3_integer4
1524		    (ffebld_cu_ptr_logical3 (u),
1525		     ffebld_constant_integer4 (ffebld_conter (l)));
1526		  break;
1527#endif
1528
1529		default:
1530		  assert ("LOGICAL3/INTEGER bad source kind type" == NULL);
1531		  break;
1532		}
1533	      break;
1534
1535	    case FFEINFO_basictypeCHARACTER:
1536	      error = ffetarget_convert_logical3_character1
1537		(ffebld_cu_ptr_logical3 (u),
1538		 ffebld_constant_character1 (ffebld_conter (l)));
1539	      break;
1540
1541	    case FFEINFO_basictypeHOLLERITH:
1542	      error = ffetarget_convert_logical3_hollerith
1543		(ffebld_cu_ptr_logical3 (u),
1544		 ffebld_constant_hollerith (ffebld_conter (l)));
1545	      break;
1546
1547	    case FFEINFO_basictypeTYPELESS:
1548	      error = ffetarget_convert_logical3_typeless
1549		(ffebld_cu_ptr_logical3 (u),
1550		 ffebld_constant_typeless (ffebld_conter (l)));
1551	      break;
1552
1553	    default:
1554	      assert ("LOGICAL3 bad type" == NULL);
1555	      break;
1556	    }
1557
1558	  /* If conversion operation is not implemented, return original expr.  */
1559	  if (error == FFEBAD_NOCANDO)
1560	    return expr;
1561
1562	  expr = ffebld_new_conter_with_orig
1563	    (ffebld_constant_new_logical3_val
1564	     (ffebld_cu_val_logical3 (u)), expr);
1565	  break;
1566#endif
1567
1568#if FFETARGET_okLOGICAL4
1569	case FFEINFO_kindtypeLOGICAL4:
1570	  switch (ffeinfo_basictype (ffebld_info (l)))
1571	    {
1572	    case FFEINFO_basictypeLOGICAL:
1573	      switch (ffeinfo_kindtype (ffebld_info (l)))
1574		{
1575#if FFETARGET_okLOGICAL1
1576		case FFEINFO_kindtypeLOGICAL1:
1577		  error = ffetarget_convert_logical4_logical1
1578		    (ffebld_cu_ptr_logical4 (u),
1579		     ffebld_constant_logical1 (ffebld_conter (l)));
1580		  break;
1581#endif
1582
1583#if FFETARGET_okLOGICAL2
1584		case FFEINFO_kindtypeLOGICAL2:
1585		  error = ffetarget_convert_logical4_logical2
1586		    (ffebld_cu_ptr_logical4 (u),
1587		     ffebld_constant_logical2 (ffebld_conter (l)));
1588		  break;
1589#endif
1590
1591#if FFETARGET_okLOGICAL3
1592		case FFEINFO_kindtypeLOGICAL3:
1593		  error = ffetarget_convert_logical4_logical3
1594		    (ffebld_cu_ptr_logical4 (u),
1595		     ffebld_constant_logical3 (ffebld_conter (l)));
1596		  break;
1597#endif
1598
1599		default:
1600		  assert ("LOGICAL4/LOGICAL bad source kind type" == NULL);
1601		  break;
1602		}
1603	      break;
1604
1605	    case FFEINFO_basictypeINTEGER:
1606	      switch (ffeinfo_kindtype (ffebld_info (l)))
1607		{
1608#if FFETARGET_okINTEGER1
1609		case FFEINFO_kindtypeINTEGER1:
1610		  error = ffetarget_convert_logical4_integer1
1611		    (ffebld_cu_ptr_logical4 (u),
1612		     ffebld_constant_integer1 (ffebld_conter (l)));
1613		  break;
1614#endif
1615
1616#if FFETARGET_okINTEGER2
1617		case FFEINFO_kindtypeINTEGER2:
1618		  error = ffetarget_convert_logical4_integer2
1619		    (ffebld_cu_ptr_logical4 (u),
1620		     ffebld_constant_integer2 (ffebld_conter (l)));
1621		  break;
1622#endif
1623
1624#if FFETARGET_okINTEGER3
1625		case FFEINFO_kindtypeINTEGER3:
1626		  error = ffetarget_convert_logical4_integer3
1627		    (ffebld_cu_ptr_logical4 (u),
1628		     ffebld_constant_integer3 (ffebld_conter (l)));
1629		  break;
1630#endif
1631
1632#if FFETARGET_okINTEGER4
1633		case FFEINFO_kindtypeINTEGER4:
1634		  error = ffetarget_convert_logical4_integer4
1635		    (ffebld_cu_ptr_logical4 (u),
1636		     ffebld_constant_integer4 (ffebld_conter (l)));
1637		  break;
1638#endif
1639
1640		default:
1641		  assert ("LOGICAL4/INTEGER bad source kind type" == NULL);
1642		  break;
1643		}
1644	      break;
1645
1646	    case FFEINFO_basictypeCHARACTER:
1647	      error = ffetarget_convert_logical4_character1
1648		(ffebld_cu_ptr_logical4 (u),
1649		 ffebld_constant_character1 (ffebld_conter (l)));
1650	      break;
1651
1652	    case FFEINFO_basictypeHOLLERITH:
1653	      error = ffetarget_convert_logical4_hollerith
1654		(ffebld_cu_ptr_logical4 (u),
1655		 ffebld_constant_hollerith (ffebld_conter (l)));
1656	      break;
1657
1658	    case FFEINFO_basictypeTYPELESS:
1659	      error = ffetarget_convert_logical4_typeless
1660		(ffebld_cu_ptr_logical4 (u),
1661		 ffebld_constant_typeless (ffebld_conter (l)));
1662	      break;
1663
1664	    default:
1665	      assert ("LOGICAL4 bad type" == NULL);
1666	      break;
1667	    }
1668
1669	  /* If conversion operation is not implemented, return original expr.  */
1670	  if (error == FFEBAD_NOCANDO)
1671	    return expr;
1672
1673	  expr = ffebld_new_conter_with_orig
1674	    (ffebld_constant_new_logical4_val
1675	     (ffebld_cu_val_logical4 (u)), expr);
1676	  break;
1677#endif
1678
1679	default:
1680	  assert ("bad logical kind type" == NULL);
1681	  break;
1682	}
1683      break;
1684
1685    case FFEINFO_basictypeREAL:
1686      sz = FFETARGET_charactersizeNONE;
1687      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1688	{
1689#if FFETARGET_okREAL1
1690	case FFEINFO_kindtypeREAL1:
1691	  switch (ffeinfo_basictype (ffebld_info (l)))
1692	    {
1693	    case FFEINFO_basictypeINTEGER:
1694	      switch (ffeinfo_kindtype (ffebld_info (l)))
1695		{
1696#if FFETARGET_okINTEGER1
1697		case FFEINFO_kindtypeINTEGER1:
1698		  error = ffetarget_convert_real1_integer1
1699		    (ffebld_cu_ptr_real1 (u),
1700		     ffebld_constant_integer1 (ffebld_conter (l)));
1701		  break;
1702#endif
1703
1704#if FFETARGET_okINTEGER2
1705		case FFEINFO_kindtypeINTEGER2:
1706		  error = ffetarget_convert_real1_integer2
1707		    (ffebld_cu_ptr_real1 (u),
1708		     ffebld_constant_integer2 (ffebld_conter (l)));
1709		  break;
1710#endif
1711
1712#if FFETARGET_okINTEGER3
1713		case FFEINFO_kindtypeINTEGER3:
1714		  error = ffetarget_convert_real1_integer3
1715		    (ffebld_cu_ptr_real1 (u),
1716		     ffebld_constant_integer3 (ffebld_conter (l)));
1717		  break;
1718#endif
1719
1720#if FFETARGET_okINTEGER4
1721		case FFEINFO_kindtypeINTEGER4:
1722		  error = ffetarget_convert_real1_integer4
1723		    (ffebld_cu_ptr_real1 (u),
1724		     ffebld_constant_integer4 (ffebld_conter (l)));
1725		  break;
1726#endif
1727
1728		default:
1729		  assert ("REAL1/INTEGER bad source kind type" == NULL);
1730		  break;
1731		}
1732	      break;
1733
1734	    case FFEINFO_basictypeREAL:
1735	      switch (ffeinfo_kindtype (ffebld_info (l)))
1736		{
1737#if FFETARGET_okREAL2
1738		case FFEINFO_kindtypeREAL2:
1739		  error = ffetarget_convert_real1_real2
1740		    (ffebld_cu_ptr_real1 (u),
1741		     ffebld_constant_real2 (ffebld_conter (l)));
1742		  break;
1743#endif
1744
1745#if FFETARGET_okREAL3
1746		case FFEINFO_kindtypeREAL3:
1747		  error = ffetarget_convert_real1_real3
1748		    (ffebld_cu_ptr_real1 (u),
1749		     ffebld_constant_real3 (ffebld_conter (l)));
1750		  break;
1751#endif
1752
1753#if FFETARGET_okREAL4
1754		case FFEINFO_kindtypeREAL4:
1755		  error = ffetarget_convert_real1_real4
1756		    (ffebld_cu_ptr_real1 (u),
1757		     ffebld_constant_real4 (ffebld_conter (l)));
1758		  break;
1759#endif
1760
1761		default:
1762		  assert ("REAL1/REAL bad source kind type" == NULL);
1763		  break;
1764		}
1765	      break;
1766
1767	    case FFEINFO_basictypeCOMPLEX:
1768	      switch (ffeinfo_kindtype (ffebld_info (l)))
1769		{
1770#if FFETARGET_okCOMPLEX1
1771		case FFEINFO_kindtypeREAL1:
1772		  error = ffetarget_convert_real1_complex1
1773		    (ffebld_cu_ptr_real1 (u),
1774		     ffebld_constant_complex1 (ffebld_conter (l)));
1775		  break;
1776#endif
1777
1778#if FFETARGET_okCOMPLEX2
1779		case FFEINFO_kindtypeREAL2:
1780		  error = ffetarget_convert_real1_complex2
1781		    (ffebld_cu_ptr_real1 (u),
1782		     ffebld_constant_complex2 (ffebld_conter (l)));
1783		  break;
1784#endif
1785
1786#if FFETARGET_okCOMPLEX3
1787		case FFEINFO_kindtypeREAL3:
1788		  error = ffetarget_convert_real1_complex3
1789		    (ffebld_cu_ptr_real1 (u),
1790		     ffebld_constant_complex3 (ffebld_conter (l)));
1791		  break;
1792#endif
1793
1794#if FFETARGET_okCOMPLEX4
1795		case FFEINFO_kindtypeREAL4:
1796		  error = ffetarget_convert_real1_complex4
1797		    (ffebld_cu_ptr_real1 (u),
1798		     ffebld_constant_complex4 (ffebld_conter (l)));
1799		  break;
1800#endif
1801
1802		default:
1803		  assert ("REAL1/COMPLEX bad source kind type" == NULL);
1804		  break;
1805		}
1806	      break;
1807
1808	    case FFEINFO_basictypeCHARACTER:
1809	      error = ffetarget_convert_real1_character1
1810		(ffebld_cu_ptr_real1 (u),
1811		 ffebld_constant_character1 (ffebld_conter (l)));
1812	      break;
1813
1814	    case FFEINFO_basictypeHOLLERITH:
1815	      error = ffetarget_convert_real1_hollerith
1816		(ffebld_cu_ptr_real1 (u),
1817		 ffebld_constant_hollerith (ffebld_conter (l)));
1818	      break;
1819
1820	    case FFEINFO_basictypeTYPELESS:
1821	      error = ffetarget_convert_real1_typeless
1822		(ffebld_cu_ptr_real1 (u),
1823		 ffebld_constant_typeless (ffebld_conter (l)));
1824	      break;
1825
1826	    default:
1827	      assert ("REAL1 bad type" == NULL);
1828	      break;
1829	    }
1830
1831	  /* If conversion operation is not implemented, return original expr.  */
1832	  if (error == FFEBAD_NOCANDO)
1833	    return expr;
1834
1835	  expr = ffebld_new_conter_with_orig
1836	    (ffebld_constant_new_real1_val
1837	     (ffebld_cu_val_real1 (u)), expr);
1838	  break;
1839#endif
1840
1841#if FFETARGET_okREAL2
1842	case FFEINFO_kindtypeREAL2:
1843	  switch (ffeinfo_basictype (ffebld_info (l)))
1844	    {
1845	    case FFEINFO_basictypeINTEGER:
1846	      switch (ffeinfo_kindtype (ffebld_info (l)))
1847		{
1848#if FFETARGET_okINTEGER1
1849		case FFEINFO_kindtypeINTEGER1:
1850		  error = ffetarget_convert_real2_integer1
1851		    (ffebld_cu_ptr_real2 (u),
1852		     ffebld_constant_integer1 (ffebld_conter (l)));
1853		  break;
1854#endif
1855
1856#if FFETARGET_okINTEGER2
1857		case FFEINFO_kindtypeINTEGER2:
1858		  error = ffetarget_convert_real2_integer2
1859		    (ffebld_cu_ptr_real2 (u),
1860		     ffebld_constant_integer2 (ffebld_conter (l)));
1861		  break;
1862#endif
1863
1864#if FFETARGET_okINTEGER3
1865		case FFEINFO_kindtypeINTEGER3:
1866		  error = ffetarget_convert_real2_integer3
1867		    (ffebld_cu_ptr_real2 (u),
1868		     ffebld_constant_integer3 (ffebld_conter (l)));
1869		  break;
1870#endif
1871
1872#if FFETARGET_okINTEGER4
1873		case FFEINFO_kindtypeINTEGER4:
1874		  error = ffetarget_convert_real2_integer4
1875		    (ffebld_cu_ptr_real2 (u),
1876		     ffebld_constant_integer4 (ffebld_conter (l)));
1877		  break;
1878#endif
1879
1880		default:
1881		  assert ("REAL2/INTEGER bad source kind type" == NULL);
1882		  break;
1883		}
1884	      break;
1885
1886	    case FFEINFO_basictypeREAL:
1887	      switch (ffeinfo_kindtype (ffebld_info (l)))
1888		{
1889#if FFETARGET_okREAL1
1890		case FFEINFO_kindtypeREAL1:
1891		  error = ffetarget_convert_real2_real1
1892		    (ffebld_cu_ptr_real2 (u),
1893		     ffebld_constant_real1 (ffebld_conter (l)));
1894		  break;
1895#endif
1896
1897#if FFETARGET_okREAL3
1898		case FFEINFO_kindtypeREAL3:
1899		  error = ffetarget_convert_real2_real3
1900		    (ffebld_cu_ptr_real2 (u),
1901		     ffebld_constant_real3 (ffebld_conter (l)));
1902		  break;
1903#endif
1904
1905#if FFETARGET_okREAL4
1906		case FFEINFO_kindtypeREAL4:
1907		  error = ffetarget_convert_real2_real4
1908		    (ffebld_cu_ptr_real2 (u),
1909		     ffebld_constant_real4 (ffebld_conter (l)));
1910		  break;
1911#endif
1912
1913		default:
1914		  assert ("REAL2/REAL bad source kind type" == NULL);
1915		  break;
1916		}
1917	      break;
1918
1919	    case FFEINFO_basictypeCOMPLEX:
1920	      switch (ffeinfo_kindtype (ffebld_info (l)))
1921		{
1922#if FFETARGET_okCOMPLEX1
1923		case FFEINFO_kindtypeREAL1:
1924		  error = ffetarget_convert_real2_complex1
1925		    (ffebld_cu_ptr_real2 (u),
1926		     ffebld_constant_complex1 (ffebld_conter (l)));
1927		  break;
1928#endif
1929
1930#if FFETARGET_okCOMPLEX2
1931		case FFEINFO_kindtypeREAL2:
1932		  error = ffetarget_convert_real2_complex2
1933		    (ffebld_cu_ptr_real2 (u),
1934		     ffebld_constant_complex2 (ffebld_conter (l)));
1935		  break;
1936#endif
1937
1938#if FFETARGET_okCOMPLEX3
1939		case FFEINFO_kindtypeREAL3:
1940		  error = ffetarget_convert_real2_complex3
1941		    (ffebld_cu_ptr_real2 (u),
1942		     ffebld_constant_complex3 (ffebld_conter (l)));
1943		  break;
1944#endif
1945
1946#if FFETARGET_okCOMPLEX4
1947		case FFEINFO_kindtypeREAL4:
1948		  error = ffetarget_convert_real2_complex4
1949		    (ffebld_cu_ptr_real2 (u),
1950		     ffebld_constant_complex4 (ffebld_conter (l)));
1951		  break;
1952#endif
1953
1954		default:
1955		  assert ("REAL2/COMPLEX bad source kind type" == NULL);
1956		  break;
1957		}
1958	      break;
1959
1960	    case FFEINFO_basictypeCHARACTER:
1961	      error = ffetarget_convert_real2_character1
1962		(ffebld_cu_ptr_real2 (u),
1963		 ffebld_constant_character1 (ffebld_conter (l)));
1964	      break;
1965
1966	    case FFEINFO_basictypeHOLLERITH:
1967	      error = ffetarget_convert_real2_hollerith
1968		(ffebld_cu_ptr_real2 (u),
1969		 ffebld_constant_hollerith (ffebld_conter (l)));
1970	      break;
1971
1972	    case FFEINFO_basictypeTYPELESS:
1973	      error = ffetarget_convert_real2_typeless
1974		(ffebld_cu_ptr_real2 (u),
1975		 ffebld_constant_typeless (ffebld_conter (l)));
1976	      break;
1977
1978	    default:
1979	      assert ("REAL2 bad type" == NULL);
1980	      break;
1981	    }
1982
1983	  /* If conversion operation is not implemented, return original expr.  */
1984	  if (error == FFEBAD_NOCANDO)
1985	    return expr;
1986
1987	  expr = ffebld_new_conter_with_orig
1988	    (ffebld_constant_new_real2_val
1989	     (ffebld_cu_val_real2 (u)), expr);
1990	  break;
1991#endif
1992
1993#if FFETARGET_okREAL3
1994	case FFEINFO_kindtypeREAL3:
1995	  switch (ffeinfo_basictype (ffebld_info (l)))
1996	    {
1997	    case FFEINFO_basictypeINTEGER:
1998	      switch (ffeinfo_kindtype (ffebld_info (l)))
1999		{
2000#if FFETARGET_okINTEGER1
2001		case FFEINFO_kindtypeINTEGER1:
2002		  error = ffetarget_convert_real3_integer1
2003		    (ffebld_cu_ptr_real3 (u),
2004		     ffebld_constant_integer1 (ffebld_conter (l)));
2005		  break;
2006#endif
2007
2008#if FFETARGET_okINTEGER2
2009		case FFEINFO_kindtypeINTEGER2:
2010		  error = ffetarget_convert_real3_integer2
2011		    (ffebld_cu_ptr_real3 (u),
2012		     ffebld_constant_integer2 (ffebld_conter (l)));
2013		  break;
2014#endif
2015
2016#if FFETARGET_okINTEGER3
2017		case FFEINFO_kindtypeINTEGER3:
2018		  error = ffetarget_convert_real3_integer3
2019		    (ffebld_cu_ptr_real3 (u),
2020		     ffebld_constant_integer3 (ffebld_conter (l)));
2021		  break;
2022#endif
2023
2024#if FFETARGET_okINTEGER4
2025		case FFEINFO_kindtypeINTEGER4:
2026		  error = ffetarget_convert_real3_integer4
2027		    (ffebld_cu_ptr_real3 (u),
2028		     ffebld_constant_integer4 (ffebld_conter (l)));
2029		  break;
2030#endif
2031
2032		default:
2033		  assert ("REAL3/INTEGER bad source kind type" == NULL);
2034		  break;
2035		}
2036	      break;
2037
2038	    case FFEINFO_basictypeREAL:
2039	      switch (ffeinfo_kindtype (ffebld_info (l)))
2040		{
2041#if FFETARGET_okREAL1
2042		case FFEINFO_kindtypeREAL1:
2043		  error = ffetarget_convert_real3_real1
2044		    (ffebld_cu_ptr_real3 (u),
2045		     ffebld_constant_real1 (ffebld_conter (l)));
2046		  break;
2047#endif
2048
2049#if FFETARGET_okREAL2
2050		case FFEINFO_kindtypeREAL2:
2051		  error = ffetarget_convert_real3_real2
2052		    (ffebld_cu_ptr_real3 (u),
2053		     ffebld_constant_real2 (ffebld_conter (l)));
2054		  break;
2055#endif
2056
2057#if FFETARGET_okREAL4
2058		case FFEINFO_kindtypeREAL4:
2059		  error = ffetarget_convert_real3_real4
2060		    (ffebld_cu_ptr_real3 (u),
2061		     ffebld_constant_real4 (ffebld_conter (l)));
2062		  break;
2063#endif
2064
2065		default:
2066		  assert ("REAL3/REAL bad source kind type" == NULL);
2067		  break;
2068		}
2069	      break;
2070
2071	    case FFEINFO_basictypeCOMPLEX:
2072	      switch (ffeinfo_kindtype (ffebld_info (l)))
2073		{
2074#if FFETARGET_okCOMPLEX1
2075		case FFEINFO_kindtypeREAL1:
2076		  error = ffetarget_convert_real3_complex1
2077		    (ffebld_cu_ptr_real3 (u),
2078		     ffebld_constant_complex1 (ffebld_conter (l)));
2079		  break;
2080#endif
2081
2082#if FFETARGET_okCOMPLEX2
2083		case FFEINFO_kindtypeREAL2:
2084		  error = ffetarget_convert_real3_complex2
2085		    (ffebld_cu_ptr_real3 (u),
2086		     ffebld_constant_complex2 (ffebld_conter (l)));
2087		  break;
2088#endif
2089
2090#if FFETARGET_okCOMPLEX3
2091		case FFEINFO_kindtypeREAL3:
2092		  error = ffetarget_convert_real3_complex3
2093		    (ffebld_cu_ptr_real3 (u),
2094		     ffebld_constant_complex3 (ffebld_conter (l)));
2095		  break;
2096#endif
2097
2098#if FFETARGET_okCOMPLEX4
2099		case FFEINFO_kindtypeREAL4:
2100		  error = ffetarget_convert_real3_complex4
2101		    (ffebld_cu_ptr_real3 (u),
2102		     ffebld_constant_complex4 (ffebld_conter (l)));
2103		  break;
2104#endif
2105
2106		default:
2107		  assert ("REAL3/COMPLEX bad source kind type" == NULL);
2108		  break;
2109		}
2110	      break;
2111
2112	    case FFEINFO_basictypeCHARACTER:
2113	      error = ffetarget_convert_real3_character1
2114		(ffebld_cu_ptr_real3 (u),
2115		 ffebld_constant_character1 (ffebld_conter (l)));
2116	      break;
2117
2118	    case FFEINFO_basictypeHOLLERITH:
2119	      error = ffetarget_convert_real3_hollerith
2120		(ffebld_cu_ptr_real3 (u),
2121		 ffebld_constant_hollerith (ffebld_conter (l)));
2122	      break;
2123
2124	    case FFEINFO_basictypeTYPELESS:
2125	      error = ffetarget_convert_real3_typeless
2126		(ffebld_cu_ptr_real3 (u),
2127		 ffebld_constant_typeless (ffebld_conter (l)));
2128	      break;
2129
2130	    default:
2131	      assert ("REAL3 bad type" == NULL);
2132	      break;
2133	    }
2134
2135	  /* If conversion operation is not implemented, return original expr.  */
2136	  if (error == FFEBAD_NOCANDO)
2137	    return expr;
2138
2139	  expr = ffebld_new_conter_with_orig
2140	    (ffebld_constant_new_real3_val
2141	     (ffebld_cu_val_real3 (u)), expr);
2142	  break;
2143#endif
2144
2145#if FFETARGET_okREAL4
2146	case FFEINFO_kindtypeREAL4:
2147	  switch (ffeinfo_basictype (ffebld_info (l)))
2148	    {
2149	    case FFEINFO_basictypeINTEGER:
2150	      switch (ffeinfo_kindtype (ffebld_info (l)))
2151		{
2152#if FFETARGET_okINTEGER1
2153		case FFEINFO_kindtypeINTEGER1:
2154		  error = ffetarget_convert_real4_integer1
2155		    (ffebld_cu_ptr_real4 (u),
2156		     ffebld_constant_integer1 (ffebld_conter (l)));
2157		  break;
2158#endif
2159
2160#if FFETARGET_okINTEGER2
2161		case FFEINFO_kindtypeINTEGER2:
2162		  error = ffetarget_convert_real4_integer2
2163		    (ffebld_cu_ptr_real4 (u),
2164		     ffebld_constant_integer2 (ffebld_conter (l)));
2165		  break;
2166#endif
2167
2168#if FFETARGET_okINTEGER3
2169		case FFEINFO_kindtypeINTEGER3:
2170		  error = ffetarget_convert_real4_integer3
2171		    (ffebld_cu_ptr_real4 (u),
2172		     ffebld_constant_integer3 (ffebld_conter (l)));
2173		  break;
2174#endif
2175
2176#if FFETARGET_okINTEGER4
2177		case FFEINFO_kindtypeINTEGER4:
2178		  error = ffetarget_convert_real4_integer4
2179		    (ffebld_cu_ptr_real4 (u),
2180		     ffebld_constant_integer4 (ffebld_conter (l)));
2181		  break;
2182#endif
2183
2184		default:
2185		  assert ("REAL4/INTEGER bad source kind type" == NULL);
2186		  break;
2187		}
2188	      break;
2189
2190	    case FFEINFO_basictypeREAL:
2191	      switch (ffeinfo_kindtype (ffebld_info (l)))
2192		{
2193#if FFETARGET_okREAL1
2194		case FFEINFO_kindtypeREAL1:
2195		  error = ffetarget_convert_real4_real1
2196		    (ffebld_cu_ptr_real4 (u),
2197		     ffebld_constant_real1 (ffebld_conter (l)));
2198		  break;
2199#endif
2200
2201#if FFETARGET_okREAL2
2202		case FFEINFO_kindtypeREAL2:
2203		  error = ffetarget_convert_real4_real2
2204		    (ffebld_cu_ptr_real4 (u),
2205		     ffebld_constant_real2 (ffebld_conter (l)));
2206		  break;
2207#endif
2208
2209#if FFETARGET_okREAL3
2210		case FFEINFO_kindtypeREAL3:
2211		  error = ffetarget_convert_real4_real3
2212		    (ffebld_cu_ptr_real4 (u),
2213		     ffebld_constant_real3 (ffebld_conter (l)));
2214		  break;
2215#endif
2216
2217		default:
2218		  assert ("REAL4/REAL bad source kind type" == NULL);
2219		  break;
2220		}
2221	      break;
2222
2223	    case FFEINFO_basictypeCOMPLEX:
2224	      switch (ffeinfo_kindtype (ffebld_info (l)))
2225		{
2226#if FFETARGET_okCOMPLEX1
2227		case FFEINFO_kindtypeREAL1:
2228		  error = ffetarget_convert_real4_complex1
2229		    (ffebld_cu_ptr_real4 (u),
2230		     ffebld_constant_complex1 (ffebld_conter (l)));
2231		  break;
2232#endif
2233
2234#if FFETARGET_okCOMPLEX2
2235		case FFEINFO_kindtypeREAL2:
2236		  error = ffetarget_convert_real4_complex2
2237		    (ffebld_cu_ptr_real4 (u),
2238		     ffebld_constant_complex2 (ffebld_conter (l)));
2239		  break;
2240#endif
2241
2242#if FFETARGET_okCOMPLEX3
2243		case FFEINFO_kindtypeREAL3:
2244		  error = ffetarget_convert_real4_complex3
2245		    (ffebld_cu_ptr_real4 (u),
2246		     ffebld_constant_complex3 (ffebld_conter (l)));
2247		  break;
2248#endif
2249
2250#if FFETARGET_okCOMPLEX4
2251		case FFEINFO_kindtypeREAL4:
2252		  error = ffetarget_convert_real4_complex4
2253		    (ffebld_cu_ptr_real4 (u),
2254		     ffebld_constant_complex4 (ffebld_conter (l)));
2255		  break;
2256#endif
2257
2258		default:
2259		  assert ("REAL4/COMPLEX bad source kind type" == NULL);
2260		  break;
2261		}
2262	      break;
2263
2264	    case FFEINFO_basictypeCHARACTER:
2265	      error = ffetarget_convert_real4_character1
2266		(ffebld_cu_ptr_real4 (u),
2267		 ffebld_constant_character1 (ffebld_conter (l)));
2268	      break;
2269
2270	    case FFEINFO_basictypeHOLLERITH:
2271	      error = ffetarget_convert_real4_hollerith
2272		(ffebld_cu_ptr_real4 (u),
2273		 ffebld_constant_hollerith (ffebld_conter (l)));
2274	      break;
2275
2276	    case FFEINFO_basictypeTYPELESS:
2277	      error = ffetarget_convert_real4_typeless
2278		(ffebld_cu_ptr_real4 (u),
2279		 ffebld_constant_typeless (ffebld_conter (l)));
2280	      break;
2281
2282	    default:
2283	      assert ("REAL4 bad type" == NULL);
2284	      break;
2285	    }
2286
2287	  /* If conversion operation is not implemented, return original expr.  */
2288	  if (error == FFEBAD_NOCANDO)
2289	    return expr;
2290
2291	  expr = ffebld_new_conter_with_orig
2292	    (ffebld_constant_new_real4_val
2293	     (ffebld_cu_val_real4 (u)), expr);
2294	  break;
2295#endif
2296
2297	default:
2298	  assert ("bad real kind type" == NULL);
2299	  break;
2300	}
2301      break;
2302
2303    case FFEINFO_basictypeCOMPLEX:
2304      sz = FFETARGET_charactersizeNONE;
2305      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2306	{
2307#if FFETARGET_okCOMPLEX1
2308	case FFEINFO_kindtypeREAL1:
2309	  switch (ffeinfo_basictype (ffebld_info (l)))
2310	    {
2311	    case FFEINFO_basictypeINTEGER:
2312	      switch (ffeinfo_kindtype (ffebld_info (l)))
2313		{
2314#if FFETARGET_okINTEGER1
2315		case FFEINFO_kindtypeINTEGER1:
2316		  error = ffetarget_convert_complex1_integer1
2317		    (ffebld_cu_ptr_complex1 (u),
2318		     ffebld_constant_integer1 (ffebld_conter (l)));
2319		  break;
2320#endif
2321
2322#if FFETARGET_okINTEGER2
2323		case FFEINFO_kindtypeINTEGER2:
2324		  error = ffetarget_convert_complex1_integer2
2325		    (ffebld_cu_ptr_complex1 (u),
2326		     ffebld_constant_integer2 (ffebld_conter (l)));
2327		  break;
2328#endif
2329
2330#if FFETARGET_okINTEGER3
2331		case FFEINFO_kindtypeINTEGER3:
2332		  error = ffetarget_convert_complex1_integer3
2333		    (ffebld_cu_ptr_complex1 (u),
2334		     ffebld_constant_integer3 (ffebld_conter (l)));
2335		  break;
2336#endif
2337
2338#if FFETARGET_okINTEGER4
2339		case FFEINFO_kindtypeINTEGER4:
2340		  error = ffetarget_convert_complex1_integer4
2341		    (ffebld_cu_ptr_complex1 (u),
2342		     ffebld_constant_integer4 (ffebld_conter (l)));
2343		  break;
2344#endif
2345
2346		default:
2347		  assert ("COMPLEX1/INTEGER bad source kind type" == NULL);
2348		  break;
2349		}
2350	      break;
2351
2352	    case FFEINFO_basictypeREAL:
2353	      switch (ffeinfo_kindtype (ffebld_info (l)))
2354		{
2355#if FFETARGET_okREAL1
2356		case FFEINFO_kindtypeREAL1:
2357		  error = ffetarget_convert_complex1_real1
2358		    (ffebld_cu_ptr_complex1 (u),
2359		     ffebld_constant_real1 (ffebld_conter (l)));
2360		  break;
2361#endif
2362
2363#if FFETARGET_okREAL2
2364		case FFEINFO_kindtypeREAL2:
2365		  error = ffetarget_convert_complex1_real2
2366		    (ffebld_cu_ptr_complex1 (u),
2367		     ffebld_constant_real2 (ffebld_conter (l)));
2368		  break;
2369#endif
2370
2371#if FFETARGET_okREAL3
2372		case FFEINFO_kindtypeREAL3:
2373		  error = ffetarget_convert_complex1_real3
2374		    (ffebld_cu_ptr_complex1 (u),
2375		     ffebld_constant_real3 (ffebld_conter (l)));
2376		  break;
2377#endif
2378
2379#if FFETARGET_okREAL4
2380		case FFEINFO_kindtypeREAL4:
2381		  error = ffetarget_convert_complex1_real4
2382		    (ffebld_cu_ptr_complex1 (u),
2383		     ffebld_constant_real4 (ffebld_conter (l)));
2384		  break;
2385#endif
2386
2387		default:
2388		  assert ("COMPLEX1/REAL bad source kind type" == NULL);
2389		  break;
2390		}
2391	      break;
2392
2393	    case FFEINFO_basictypeCOMPLEX:
2394	      switch (ffeinfo_kindtype (ffebld_info (l)))
2395		{
2396#if FFETARGET_okCOMPLEX2
2397		case FFEINFO_kindtypeREAL2:
2398		  error = ffetarget_convert_complex1_complex2
2399		    (ffebld_cu_ptr_complex1 (u),
2400		     ffebld_constant_complex2 (ffebld_conter (l)));
2401		  break;
2402#endif
2403
2404#if FFETARGET_okCOMPLEX3
2405		case FFEINFO_kindtypeREAL3:
2406		  error = ffetarget_convert_complex1_complex3
2407		    (ffebld_cu_ptr_complex1 (u),
2408		     ffebld_constant_complex3 (ffebld_conter (l)));
2409		  break;
2410#endif
2411
2412#if FFETARGET_okCOMPLEX4
2413		case FFEINFO_kindtypeREAL4:
2414		  error = ffetarget_convert_complex1_complex4
2415		    (ffebld_cu_ptr_complex1 (u),
2416		     ffebld_constant_complex4 (ffebld_conter (l)));
2417		  break;
2418#endif
2419
2420		default:
2421		  assert ("COMPLEX1/COMPLEX bad source kind type" == NULL);
2422		  break;
2423		}
2424	      break;
2425
2426	    case FFEINFO_basictypeCHARACTER:
2427	      error = ffetarget_convert_complex1_character1
2428		(ffebld_cu_ptr_complex1 (u),
2429		 ffebld_constant_character1 (ffebld_conter (l)));
2430	      break;
2431
2432	    case FFEINFO_basictypeHOLLERITH:
2433	      error = ffetarget_convert_complex1_hollerith
2434		(ffebld_cu_ptr_complex1 (u),
2435		 ffebld_constant_hollerith (ffebld_conter (l)));
2436	      break;
2437
2438	    case FFEINFO_basictypeTYPELESS:
2439	      error = ffetarget_convert_complex1_typeless
2440		(ffebld_cu_ptr_complex1 (u),
2441		 ffebld_constant_typeless (ffebld_conter (l)));
2442	      break;
2443
2444	    default:
2445	      assert ("COMPLEX1 bad type" == NULL);
2446	      break;
2447	    }
2448
2449	  /* If conversion operation is not implemented, return original expr.  */
2450	  if (error == FFEBAD_NOCANDO)
2451	    return expr;
2452
2453	  expr = ffebld_new_conter_with_orig
2454	    (ffebld_constant_new_complex1_val
2455	     (ffebld_cu_val_complex1 (u)), expr);
2456	  break;
2457#endif
2458
2459#if FFETARGET_okCOMPLEX2
2460	case FFEINFO_kindtypeREAL2:
2461	  switch (ffeinfo_basictype (ffebld_info (l)))
2462	    {
2463	    case FFEINFO_basictypeINTEGER:
2464	      switch (ffeinfo_kindtype (ffebld_info (l)))
2465		{
2466#if FFETARGET_okINTEGER1
2467		case FFEINFO_kindtypeINTEGER1:
2468		  error = ffetarget_convert_complex2_integer1
2469		    (ffebld_cu_ptr_complex2 (u),
2470		     ffebld_constant_integer1 (ffebld_conter (l)));
2471		  break;
2472#endif
2473
2474#if FFETARGET_okINTEGER2
2475		case FFEINFO_kindtypeINTEGER2:
2476		  error = ffetarget_convert_complex2_integer2
2477		    (ffebld_cu_ptr_complex2 (u),
2478		     ffebld_constant_integer2 (ffebld_conter (l)));
2479		  break;
2480#endif
2481
2482#if FFETARGET_okINTEGER3
2483		case FFEINFO_kindtypeINTEGER3:
2484		  error = ffetarget_convert_complex2_integer3
2485		    (ffebld_cu_ptr_complex2 (u),
2486		     ffebld_constant_integer3 (ffebld_conter (l)));
2487		  break;
2488#endif
2489
2490#if FFETARGET_okINTEGER4
2491		case FFEINFO_kindtypeINTEGER4:
2492		  error = ffetarget_convert_complex2_integer4
2493		    (ffebld_cu_ptr_complex2 (u),
2494		     ffebld_constant_integer4 (ffebld_conter (l)));
2495		  break;
2496#endif
2497
2498		default:
2499		  assert ("COMPLEX2/INTEGER bad source kind type" == NULL);
2500		  break;
2501		}
2502	      break;
2503
2504	    case FFEINFO_basictypeREAL:
2505	      switch (ffeinfo_kindtype (ffebld_info (l)))
2506		{
2507#if FFETARGET_okREAL1
2508		case FFEINFO_kindtypeREAL1:
2509		  error = ffetarget_convert_complex2_real1
2510		    (ffebld_cu_ptr_complex2 (u),
2511		     ffebld_constant_real1 (ffebld_conter (l)));
2512		  break;
2513#endif
2514
2515#if FFETARGET_okREAL2
2516		case FFEINFO_kindtypeREAL2:
2517		  error = ffetarget_convert_complex2_real2
2518		    (ffebld_cu_ptr_complex2 (u),
2519		     ffebld_constant_real2 (ffebld_conter (l)));
2520		  break;
2521#endif
2522
2523#if FFETARGET_okREAL3
2524		case FFEINFO_kindtypeREAL3:
2525		  error = ffetarget_convert_complex2_real3
2526		    (ffebld_cu_ptr_complex2 (u),
2527		     ffebld_constant_real3 (ffebld_conter (l)));
2528		  break;
2529#endif
2530
2531#if FFETARGET_okREAL4
2532		case FFEINFO_kindtypeREAL4:
2533		  error = ffetarget_convert_complex2_real4
2534		    (ffebld_cu_ptr_complex2 (u),
2535		     ffebld_constant_real4 (ffebld_conter (l)));
2536		  break;
2537#endif
2538
2539		default:
2540		  assert ("COMPLEX2/REAL bad source kind type" == NULL);
2541		  break;
2542		}
2543	      break;
2544
2545	    case FFEINFO_basictypeCOMPLEX:
2546	      switch (ffeinfo_kindtype (ffebld_info (l)))
2547		{
2548#if FFETARGET_okCOMPLEX1
2549		case FFEINFO_kindtypeREAL1:
2550		  error = ffetarget_convert_complex2_complex1
2551		    (ffebld_cu_ptr_complex2 (u),
2552		     ffebld_constant_complex1 (ffebld_conter (l)));
2553		  break;
2554#endif
2555
2556#if FFETARGET_okCOMPLEX3
2557		case FFEINFO_kindtypeREAL3:
2558		  error = ffetarget_convert_complex2_complex3
2559		    (ffebld_cu_ptr_complex2 (u),
2560		     ffebld_constant_complex3 (ffebld_conter (l)));
2561		  break;
2562#endif
2563
2564#if FFETARGET_okCOMPLEX4
2565		case FFEINFO_kindtypeREAL4:
2566		  error = ffetarget_convert_complex2_complex4
2567		    (ffebld_cu_ptr_complex2 (u),
2568		     ffebld_constant_complex4 (ffebld_conter (l)));
2569		  break;
2570#endif
2571
2572		default:
2573		  assert ("COMPLEX2/COMPLEX bad source kind type" == NULL);
2574		  break;
2575		}
2576	      break;
2577
2578	    case FFEINFO_basictypeCHARACTER:
2579	      error = ffetarget_convert_complex2_character1
2580		(ffebld_cu_ptr_complex2 (u),
2581		 ffebld_constant_character1 (ffebld_conter (l)));
2582	      break;
2583
2584	    case FFEINFO_basictypeHOLLERITH:
2585	      error = ffetarget_convert_complex2_hollerith
2586		(ffebld_cu_ptr_complex2 (u),
2587		 ffebld_constant_hollerith (ffebld_conter (l)));
2588	      break;
2589
2590	    case FFEINFO_basictypeTYPELESS:
2591	      error = ffetarget_convert_complex2_typeless
2592		(ffebld_cu_ptr_complex2 (u),
2593		 ffebld_constant_typeless (ffebld_conter (l)));
2594	      break;
2595
2596	    default:
2597	      assert ("COMPLEX2 bad type" == NULL);
2598	      break;
2599	    }
2600
2601	  /* If conversion operation is not implemented, return original expr.  */
2602	  if (error == FFEBAD_NOCANDO)
2603	    return expr;
2604
2605	  expr = ffebld_new_conter_with_orig
2606	    (ffebld_constant_new_complex2_val
2607	     (ffebld_cu_val_complex2 (u)), expr);
2608	  break;
2609#endif
2610
2611#if FFETARGET_okCOMPLEX3
2612	case FFEINFO_kindtypeREAL3:
2613	  switch (ffeinfo_basictype (ffebld_info (l)))
2614	    {
2615	    case FFEINFO_basictypeINTEGER:
2616	      switch (ffeinfo_kindtype (ffebld_info (l)))
2617		{
2618#if FFETARGET_okINTEGER1
2619		case FFEINFO_kindtypeINTEGER1:
2620		  error = ffetarget_convert_complex3_integer1
2621		    (ffebld_cu_ptr_complex3 (u),
2622		     ffebld_constant_integer1 (ffebld_conter (l)));
2623		  break;
2624#endif
2625
2626#if FFETARGET_okINTEGER2
2627		case FFEINFO_kindtypeINTEGER2:
2628		  error = ffetarget_convert_complex3_integer2
2629		    (ffebld_cu_ptr_complex3 (u),
2630		     ffebld_constant_integer2 (ffebld_conter (l)));
2631		  break;
2632#endif
2633
2634#if FFETARGET_okINTEGER3
2635		case FFEINFO_kindtypeINTEGER3:
2636		  error = ffetarget_convert_complex3_integer3
2637		    (ffebld_cu_ptr_complex3 (u),
2638		     ffebld_constant_integer3 (ffebld_conter (l)));
2639		  break;
2640#endif
2641
2642#if FFETARGET_okINTEGER4
2643		case FFEINFO_kindtypeINTEGER4:
2644		  error = ffetarget_convert_complex3_integer4
2645		    (ffebld_cu_ptr_complex3 (u),
2646		     ffebld_constant_integer4 (ffebld_conter (l)));
2647		  break;
2648#endif
2649
2650		default:
2651		  assert ("COMPLEX3/INTEGER bad source kind type" == NULL);
2652		  break;
2653		}
2654	      break;
2655
2656	    case FFEINFO_basictypeREAL:
2657	      switch (ffeinfo_kindtype (ffebld_info (l)))
2658		{
2659#if FFETARGET_okREAL1
2660		case FFEINFO_kindtypeREAL1:
2661		  error = ffetarget_convert_complex3_real1
2662		    (ffebld_cu_ptr_complex3 (u),
2663		     ffebld_constant_real1 (ffebld_conter (l)));
2664		  break;
2665#endif
2666
2667#if FFETARGET_okREAL2
2668		case FFEINFO_kindtypeREAL2:
2669		  error = ffetarget_convert_complex3_real2
2670		    (ffebld_cu_ptr_complex3 (u),
2671		     ffebld_constant_real2 (ffebld_conter (l)));
2672		  break;
2673#endif
2674
2675#if FFETARGET_okREAL3
2676		case FFEINFO_kindtypeREAL3:
2677		  error = ffetarget_convert_complex3_real3
2678		    (ffebld_cu_ptr_complex3 (u),
2679		     ffebld_constant_real3 (ffebld_conter (l)));
2680		  break;
2681#endif
2682
2683#if FFETARGET_okREAL4
2684		case FFEINFO_kindtypeREAL4:
2685		  error = ffetarget_convert_complex3_real4
2686		    (ffebld_cu_ptr_complex3 (u),
2687		     ffebld_constant_real4 (ffebld_conter (l)));
2688		  break;
2689#endif
2690
2691		default:
2692		  assert ("COMPLEX3/REAL bad source kind type" == NULL);
2693		  break;
2694		}
2695	      break;
2696
2697	    case FFEINFO_basictypeCOMPLEX:
2698	      switch (ffeinfo_kindtype (ffebld_info (l)))
2699		{
2700#if FFETARGET_okCOMPLEX1
2701		case FFEINFO_kindtypeREAL1:
2702		  error = ffetarget_convert_complex3_complex1
2703		    (ffebld_cu_ptr_complex3 (u),
2704		     ffebld_constant_complex1 (ffebld_conter (l)));
2705		  break;
2706#endif
2707
2708#if FFETARGET_okCOMPLEX2
2709		case FFEINFO_kindtypeREAL2:
2710		  error = ffetarget_convert_complex3_complex2
2711		    (ffebld_cu_ptr_complex3 (u),
2712		     ffebld_constant_complex2 (ffebld_conter (l)));
2713		  break;
2714#endif
2715
2716#if FFETARGET_okCOMPLEX4
2717		case FFEINFO_kindtypeREAL4:
2718		  error = ffetarget_convert_complex3_complex4
2719		    (ffebld_cu_ptr_complex3 (u),
2720		     ffebld_constant_complex4 (ffebld_conter (l)));
2721		  break;
2722#endif
2723
2724		default:
2725		  assert ("COMPLEX3/COMPLEX bad source kind type" == NULL);
2726		  break;
2727		}
2728	      break;
2729
2730	    case FFEINFO_basictypeCHARACTER:
2731	      error = ffetarget_convert_complex3_character1
2732		(ffebld_cu_ptr_complex3 (u),
2733		 ffebld_constant_character1 (ffebld_conter (l)));
2734	      break;
2735
2736	    case FFEINFO_basictypeHOLLERITH:
2737	      error = ffetarget_convert_complex3_hollerith
2738		(ffebld_cu_ptr_complex3 (u),
2739		 ffebld_constant_hollerith (ffebld_conter (l)));
2740	      break;
2741
2742	    case FFEINFO_basictypeTYPELESS:
2743	      error = ffetarget_convert_complex3_typeless
2744		(ffebld_cu_ptr_complex3 (u),
2745		 ffebld_constant_typeless (ffebld_conter (l)));
2746	      break;
2747
2748	    default:
2749	      assert ("COMPLEX3 bad type" == NULL);
2750	      break;
2751	    }
2752
2753	  /* If conversion operation is not implemented, return original expr.  */
2754	  if (error == FFEBAD_NOCANDO)
2755	    return expr;
2756
2757	  expr = ffebld_new_conter_with_orig
2758	    (ffebld_constant_new_complex3_val
2759	     (ffebld_cu_val_complex3 (u)), expr);
2760	  break;
2761#endif
2762
2763#if FFETARGET_okCOMPLEX4
2764	case FFEINFO_kindtypeREAL4:
2765	  switch (ffeinfo_basictype (ffebld_info (l)))
2766	    {
2767	    case FFEINFO_basictypeINTEGER:
2768	      switch (ffeinfo_kindtype (ffebld_info (l)))
2769		{
2770#if FFETARGET_okINTEGER1
2771		case FFEINFO_kindtypeINTEGER1:
2772		  error = ffetarget_convert_complex4_integer1
2773		    (ffebld_cu_ptr_complex4 (u),
2774		     ffebld_constant_integer1 (ffebld_conter (l)));
2775		  break;
2776#endif
2777
2778#if FFETARGET_okINTEGER2
2779		case FFEINFO_kindtypeINTEGER2:
2780		  error = ffetarget_convert_complex4_integer2
2781		    (ffebld_cu_ptr_complex4 (u),
2782		     ffebld_constant_integer2 (ffebld_conter (l)));
2783		  break;
2784#endif
2785
2786#if FFETARGET_okINTEGER3
2787		case FFEINFO_kindtypeINTEGER3:
2788		  error = ffetarget_convert_complex4_integer3
2789		    (ffebld_cu_ptr_complex4 (u),
2790		     ffebld_constant_integer3 (ffebld_conter (l)));
2791		  break;
2792#endif
2793
2794#if FFETARGET_okINTEGER4
2795		case FFEINFO_kindtypeINTEGER4:
2796		  error = ffetarget_convert_complex4_integer4
2797		    (ffebld_cu_ptr_complex4 (u),
2798		     ffebld_constant_integer4 (ffebld_conter (l)));
2799		  break;
2800#endif
2801
2802		default:
2803		  assert ("COMPLEX4/INTEGER bad source kind type" == NULL);
2804		  break;
2805		}
2806	      break;
2807
2808	    case FFEINFO_basictypeREAL:
2809	      switch (ffeinfo_kindtype (ffebld_info (l)))
2810		{
2811#if FFETARGET_okREAL1
2812		case FFEINFO_kindtypeREAL1:
2813		  error = ffetarget_convert_complex4_real1
2814		    (ffebld_cu_ptr_complex4 (u),
2815		     ffebld_constant_real1 (ffebld_conter (l)));
2816		  break;
2817#endif
2818
2819#if FFETARGET_okREAL2
2820		case FFEINFO_kindtypeREAL2:
2821		  error = ffetarget_convert_complex4_real2
2822		    (ffebld_cu_ptr_complex4 (u),
2823		     ffebld_constant_real2 (ffebld_conter (l)));
2824		  break;
2825#endif
2826
2827#if FFETARGET_okREAL3
2828		case FFEINFO_kindtypeREAL3:
2829		  error = ffetarget_convert_complex4_real3
2830		    (ffebld_cu_ptr_complex4 (u),
2831		     ffebld_constant_real3 (ffebld_conter (l)));
2832		  break;
2833#endif
2834
2835#if FFETARGET_okREAL4
2836		case FFEINFO_kindtypeREAL4:
2837		  error = ffetarget_convert_complex4_real4
2838		    (ffebld_cu_ptr_complex4 (u),
2839		     ffebld_constant_real4 (ffebld_conter (l)));
2840		  break;
2841#endif
2842
2843		default:
2844		  assert ("COMPLEX4/REAL bad source kind type" == NULL);
2845		  break;
2846		}
2847	      break;
2848
2849	    case FFEINFO_basictypeCOMPLEX:
2850	      switch (ffeinfo_kindtype (ffebld_info (l)))
2851		{
2852#if FFETARGET_okCOMPLEX1
2853		case FFEINFO_kindtypeREAL1:
2854		  error = ffetarget_convert_complex4_complex1
2855		    (ffebld_cu_ptr_complex4 (u),
2856		     ffebld_constant_complex1 (ffebld_conter (l)));
2857		  break;
2858#endif
2859
2860#if FFETARGET_okCOMPLEX2
2861		case FFEINFO_kindtypeREAL2:
2862		  error = ffetarget_convert_complex4_complex2
2863		    (ffebld_cu_ptr_complex4 (u),
2864		     ffebld_constant_complex2 (ffebld_conter (l)));
2865		  break;
2866#endif
2867
2868#if FFETARGET_okCOMPLEX3
2869		case FFEINFO_kindtypeREAL3:
2870		  error = ffetarget_convert_complex4_complex3
2871		    (ffebld_cu_ptr_complex4 (u),
2872		     ffebld_constant_complex3 (ffebld_conter (l)));
2873		  break;
2874#endif
2875
2876		default:
2877		  assert ("COMPLEX4/COMPLEX bad source kind type" == NULL);
2878		  break;
2879		}
2880	      break;
2881
2882	    case FFEINFO_basictypeCHARACTER:
2883	      error = ffetarget_convert_complex4_character1
2884		(ffebld_cu_ptr_complex4 (u),
2885		 ffebld_constant_character1 (ffebld_conter (l)));
2886	      break;
2887
2888	    case FFEINFO_basictypeHOLLERITH:
2889	      error = ffetarget_convert_complex4_hollerith
2890		(ffebld_cu_ptr_complex4 (u),
2891		 ffebld_constant_hollerith (ffebld_conter (l)));
2892	      break;
2893
2894	    case FFEINFO_basictypeTYPELESS:
2895	      error = ffetarget_convert_complex4_typeless
2896		(ffebld_cu_ptr_complex4 (u),
2897		 ffebld_constant_typeless (ffebld_conter (l)));
2898	      break;
2899
2900	    default:
2901	      assert ("COMPLEX4 bad type" == NULL);
2902	      break;
2903	    }
2904
2905	  /* If conversion operation is not implemented, return original expr.  */
2906	  if (error == FFEBAD_NOCANDO)
2907	    return expr;
2908
2909	  expr = ffebld_new_conter_with_orig
2910	    (ffebld_constant_new_complex4_val
2911	     (ffebld_cu_val_complex4 (u)), expr);
2912	  break;
2913#endif
2914
2915	default:
2916	  assert ("bad complex kind type" == NULL);
2917	  break;
2918	}
2919      break;
2920
2921    case FFEINFO_basictypeCHARACTER:
2922      if ((sz = ffebld_size (expr)) == FFETARGET_charactersizeNONE)
2923	return expr;
2924      kt = ffeinfo_kindtype (ffebld_info (expr));
2925      switch (kt)
2926	{
2927#if FFETARGET_okCHARACTER1
2928	case FFEINFO_kindtypeCHARACTER1:
2929	  switch (ffeinfo_basictype (ffebld_info (l)))
2930	    {
2931	    case FFEINFO_basictypeCHARACTER:
2932	      if ((sz2 = ffebld_size (l)) == FFETARGET_charactersizeNONE)
2933		return expr;
2934	      assert (kt == ffeinfo_kindtype (ffebld_info (l)));
2935	      assert (sz2 == ffetarget_length_character1
2936		      (ffebld_constant_character1
2937		       (ffebld_conter (l))));
2938	      error
2939		= ffetarget_convert_character1_character1
2940		(ffebld_cu_ptr_character1 (u), sz,
2941		 ffebld_constant_character1 (ffebld_conter (l)),
2942		 ffebld_constant_pool ());
2943	      break;
2944
2945	    case FFEINFO_basictypeINTEGER:
2946	      switch (ffeinfo_kindtype (ffebld_info (l)))
2947		{
2948#if FFETARGET_okINTEGER1
2949		case FFEINFO_kindtypeINTEGER1:
2950		  error
2951		    = ffetarget_convert_character1_integer1
2952		      (ffebld_cu_ptr_character1 (u),
2953		       sz,
2954		       ffebld_constant_integer1 (ffebld_conter (l)),
2955		       ffebld_constant_pool ());
2956		  break;
2957#endif
2958
2959#if FFETARGET_okINTEGER2
2960		case FFEINFO_kindtypeINTEGER2:
2961		  error
2962		    = ffetarget_convert_character1_integer2
2963		      (ffebld_cu_ptr_character1 (u),
2964		       sz,
2965		       ffebld_constant_integer2 (ffebld_conter (l)),
2966		       ffebld_constant_pool ());
2967		  break;
2968#endif
2969
2970#if FFETARGET_okINTEGER3
2971		case FFEINFO_kindtypeINTEGER3:
2972		  error
2973		    = ffetarget_convert_character1_integer3
2974		      (ffebld_cu_ptr_character1 (u),
2975		       sz,
2976		       ffebld_constant_integer3 (ffebld_conter (l)),
2977		       ffebld_constant_pool ());
2978		  break;
2979#endif
2980
2981#if FFETARGET_okINTEGER4
2982		case FFEINFO_kindtypeINTEGER4:
2983		  error
2984		    = ffetarget_convert_character1_integer4
2985		      (ffebld_cu_ptr_character1 (u),
2986		       sz,
2987		       ffebld_constant_integer4 (ffebld_conter (l)),
2988		       ffebld_constant_pool ());
2989		  break;
2990#endif
2991
2992		default:
2993		  assert ("CHARACTER1/INTEGER bad source kind type" == NULL);
2994		  break;
2995		}
2996	      break;
2997
2998	    case FFEINFO_basictypeLOGICAL:
2999	      switch (ffeinfo_kindtype (ffebld_info (l)))
3000		{
3001#if FFETARGET_okLOGICAL1
3002		case FFEINFO_kindtypeLOGICAL1:
3003		  error
3004		    = ffetarget_convert_character1_logical1
3005		      (ffebld_cu_ptr_character1 (u),
3006		       sz,
3007		       ffebld_constant_logical1 (ffebld_conter (l)),
3008		       ffebld_constant_pool ());
3009		  break;
3010#endif
3011
3012#if FFETARGET_okLOGICAL2
3013		case FFEINFO_kindtypeLOGICAL2:
3014		  error
3015		    = ffetarget_convert_character1_logical2
3016		      (ffebld_cu_ptr_character1 (u),
3017		       sz,
3018		       ffebld_constant_logical2 (ffebld_conter (l)),
3019		       ffebld_constant_pool ());
3020		  break;
3021#endif
3022
3023#if FFETARGET_okLOGICAL3
3024		case FFEINFO_kindtypeLOGICAL3:
3025		  error
3026		    = ffetarget_convert_character1_logical3
3027		      (ffebld_cu_ptr_character1 (u),
3028		       sz,
3029		       ffebld_constant_logical3 (ffebld_conter (l)),
3030		       ffebld_constant_pool ());
3031		  break;
3032#endif
3033
3034#if FFETARGET_okLOGICAL4
3035		case FFEINFO_kindtypeLOGICAL4:
3036		  error
3037		    = ffetarget_convert_character1_logical4
3038		      (ffebld_cu_ptr_character1 (u),
3039		       sz,
3040		       ffebld_constant_logical4 (ffebld_conter (l)),
3041		       ffebld_constant_pool ());
3042		  break;
3043#endif
3044
3045		default:
3046		  assert ("CHARACTER1/LOGICAL bad source kind type" == NULL);
3047		  break;
3048		}
3049	      break;
3050
3051	    case FFEINFO_basictypeHOLLERITH:
3052	      error
3053		= ffetarget_convert_character1_hollerith
3054		(ffebld_cu_ptr_character1 (u),
3055		 sz,
3056		 ffebld_constant_hollerith (ffebld_conter (l)),
3057		 ffebld_constant_pool ());
3058	      break;
3059
3060	    case FFEINFO_basictypeTYPELESS:
3061	      error
3062		= ffetarget_convert_character1_typeless
3063		(ffebld_cu_ptr_character1 (u),
3064		 sz,
3065		 ffebld_constant_typeless (ffebld_conter (l)),
3066		 ffebld_constant_pool ());
3067	      break;
3068
3069	    default:
3070	      assert ("CHARACTER1 bad type" == NULL);
3071	    }
3072
3073	  expr
3074	    = ffebld_new_conter_with_orig
3075	    (ffebld_constant_new_character1_val
3076	     (ffebld_cu_val_character1 (u)),
3077	     expr);
3078	  break;
3079#endif
3080
3081	default:
3082	  assert ("bad character kind type" == NULL);
3083	  break;
3084	}
3085      break;
3086
3087    default:
3088      assert ("bad type" == NULL);
3089      return expr;
3090    }
3091
3092  ffebld_set_info (expr, ffeinfo_new
3093		   (bt,
3094		    kt,
3095		    0,
3096		    FFEINFO_kindENTITY,
3097		    FFEINFO_whereCONSTANT,
3098		    sz));
3099
3100  if ((error != FFEBAD)
3101      && ffebad_start (error))
3102    {
3103      assert (t != NULL);
3104      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3105      ffebad_finish ();
3106    }
3107
3108  return expr;
3109}
3110
3111/* ffeexpr_collapse_paren -- Collapse paren expr
3112
3113   ffebld expr;
3114   ffelexToken token;
3115   expr = ffeexpr_collapse_paren(expr,token);
3116
3117   If the result of the expr is a constant, replaces the expr with the
3118   computed constant.  */
3119
3120ffebld
3121ffeexpr_collapse_paren (ffebld expr, ffelexToken t UNUSED)
3122{
3123  ffebld r;
3124  ffeinfoBasictype bt;
3125  ffeinfoKindtype kt;
3126  ffetargetCharacterSize len;
3127
3128  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3129    return expr;
3130
3131  r = ffebld_left (expr);
3132
3133  if (ffebld_op (r) != FFEBLD_opCONTER)
3134    return expr;
3135
3136  bt = ffeinfo_basictype (ffebld_info (r));
3137  kt = ffeinfo_kindtype (ffebld_info (r));
3138  len = ffebld_size (r);
3139
3140  expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
3141				      expr);
3142
3143  ffebld_set_info (expr, ffeinfo_new
3144		   (bt,
3145		    kt,
3146		    0,
3147		    FFEINFO_kindENTITY,
3148		    FFEINFO_whereCONSTANT,
3149		    len));
3150
3151  return expr;
3152}
3153
3154/* ffeexpr_collapse_uplus -- Collapse uplus expr
3155
3156   ffebld expr;
3157   ffelexToken token;
3158   expr = ffeexpr_collapse_uplus(expr,token);
3159
3160   If the result of the expr is a constant, replaces the expr with the
3161   computed constant.  */
3162
3163ffebld
3164ffeexpr_collapse_uplus (ffebld expr, ffelexToken t UNUSED)
3165{
3166  ffebld r;
3167  ffeinfoBasictype bt;
3168  ffeinfoKindtype kt;
3169  ffetargetCharacterSize len;
3170
3171  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3172    return expr;
3173
3174  r = ffebld_left (expr);
3175
3176  if (ffebld_op (r) != FFEBLD_opCONTER)
3177    return expr;
3178
3179  bt = ffeinfo_basictype (ffebld_info (r));
3180  kt = ffeinfo_kindtype (ffebld_info (r));
3181  len = ffebld_size (r);
3182
3183  expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
3184				      expr);
3185
3186  ffebld_set_info (expr, ffeinfo_new
3187		   (bt,
3188		    kt,
3189		    0,
3190		    FFEINFO_kindENTITY,
3191		    FFEINFO_whereCONSTANT,
3192		    len));
3193
3194  return expr;
3195}
3196
3197/* ffeexpr_collapse_uminus -- Collapse uminus expr
3198
3199   ffebld expr;
3200   ffelexToken token;
3201   expr = ffeexpr_collapse_uminus(expr,token);
3202
3203   If the result of the expr is a constant, replaces the expr with the
3204   computed constant.  */
3205
3206ffebld
3207ffeexpr_collapse_uminus (ffebld expr, ffelexToken t)
3208{
3209  ffebad error = FFEBAD;
3210  ffebld r;
3211  ffebldConstantUnion u;
3212  ffeinfoBasictype bt;
3213  ffeinfoKindtype kt;
3214
3215  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3216    return expr;
3217
3218  r = ffebld_left (expr);
3219
3220  if (ffebld_op (r) != FFEBLD_opCONTER)
3221    return expr;
3222
3223  switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3224    {
3225    case FFEINFO_basictypeANY:
3226      return expr;
3227
3228    case FFEINFO_basictypeINTEGER:
3229      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3230	{
3231#if FFETARGET_okINTEGER1
3232	case FFEINFO_kindtypeINTEGER1:
3233	  error = ffetarget_uminus_integer1 (ffebld_cu_ptr_integer1 (u),
3234			      ffebld_constant_integer1 (ffebld_conter (r)));
3235	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3236					(ffebld_cu_val_integer1 (u)), expr);
3237	  break;
3238#endif
3239
3240#if FFETARGET_okINTEGER2
3241	case FFEINFO_kindtypeINTEGER2:
3242	  error = ffetarget_uminus_integer2 (ffebld_cu_ptr_integer2 (u),
3243			      ffebld_constant_integer2 (ffebld_conter (r)));
3244	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3245					(ffebld_cu_val_integer2 (u)), expr);
3246	  break;
3247#endif
3248
3249#if FFETARGET_okINTEGER3
3250	case FFEINFO_kindtypeINTEGER3:
3251	  error = ffetarget_uminus_integer3 (ffebld_cu_ptr_integer3 (u),
3252			      ffebld_constant_integer3 (ffebld_conter (r)));
3253	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3254					(ffebld_cu_val_integer3 (u)), expr);
3255	  break;
3256#endif
3257
3258#if FFETARGET_okINTEGER4
3259	case FFEINFO_kindtypeINTEGER4:
3260	  error = ffetarget_uminus_integer4 (ffebld_cu_ptr_integer4 (u),
3261			      ffebld_constant_integer4 (ffebld_conter (r)));
3262	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3263					(ffebld_cu_val_integer4 (u)), expr);
3264	  break;
3265#endif
3266
3267	default:
3268	  assert ("bad integer kind type" == NULL);
3269	  break;
3270	}
3271      break;
3272
3273    case FFEINFO_basictypeREAL:
3274      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3275	{
3276#if FFETARGET_okREAL1
3277	case FFEINFO_kindtypeREAL1:
3278	  error = ffetarget_uminus_real1 (ffebld_cu_ptr_real1 (u),
3279				 ffebld_constant_real1 (ffebld_conter (r)));
3280	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3281					   (ffebld_cu_val_real1 (u)), expr);
3282	  break;
3283#endif
3284
3285#if FFETARGET_okREAL2
3286	case FFEINFO_kindtypeREAL2:
3287	  error = ffetarget_uminus_real2 (ffebld_cu_ptr_real2 (u),
3288				 ffebld_constant_real2 (ffebld_conter (r)));
3289	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3290					   (ffebld_cu_val_real2 (u)), expr);
3291	  break;
3292#endif
3293
3294#if FFETARGET_okREAL3
3295	case FFEINFO_kindtypeREAL3:
3296	  error = ffetarget_uminus_real3 (ffebld_cu_ptr_real3 (u),
3297				 ffebld_constant_real3 (ffebld_conter (r)));
3298	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3299					   (ffebld_cu_val_real3 (u)), expr);
3300	  break;
3301#endif
3302
3303#if FFETARGET_okREAL4
3304	case FFEINFO_kindtypeREAL4:
3305	  error = ffetarget_uminus_real4 (ffebld_cu_ptr_real4 (u),
3306				 ffebld_constant_real4 (ffebld_conter (r)));
3307	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
3308					   (ffebld_cu_val_real4 (u)), expr);
3309	  break;
3310#endif
3311
3312	default:
3313	  assert ("bad real kind type" == NULL);
3314	  break;
3315	}
3316      break;
3317
3318    case FFEINFO_basictypeCOMPLEX:
3319      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3320	{
3321#if FFETARGET_okCOMPLEX1
3322	case FFEINFO_kindtypeREAL1:
3323	  error = ffetarget_uminus_complex1 (ffebld_cu_ptr_complex1 (u),
3324			      ffebld_constant_complex1 (ffebld_conter (r)));
3325	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3326					(ffebld_cu_val_complex1 (u)), expr);
3327	  break;
3328#endif
3329
3330#if FFETARGET_okCOMPLEX2
3331	case FFEINFO_kindtypeREAL2:
3332	  error = ffetarget_uminus_complex2 (ffebld_cu_ptr_complex2 (u),
3333			      ffebld_constant_complex2 (ffebld_conter (r)));
3334	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3335					(ffebld_cu_val_complex2 (u)), expr);
3336	  break;
3337#endif
3338
3339#if FFETARGET_okCOMPLEX3
3340	case FFEINFO_kindtypeREAL3:
3341	  error = ffetarget_uminus_complex3 (ffebld_cu_ptr_complex3 (u),
3342			      ffebld_constant_complex3 (ffebld_conter (r)));
3343	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3344					(ffebld_cu_val_complex3 (u)), expr);
3345	  break;
3346#endif
3347
3348#if FFETARGET_okCOMPLEX4
3349	case FFEINFO_kindtypeREAL4:
3350	  error = ffetarget_uminus_complex4 (ffebld_cu_ptr_complex4 (u),
3351			      ffebld_constant_complex4 (ffebld_conter (r)));
3352	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
3353					(ffebld_cu_val_complex4 (u)), expr);
3354	  break;
3355#endif
3356
3357	default:
3358	  assert ("bad complex kind type" == NULL);
3359	  break;
3360	}
3361      break;
3362
3363    default:
3364      assert ("bad type" == NULL);
3365      return expr;
3366    }
3367
3368  ffebld_set_info (expr, ffeinfo_new
3369		   (bt,
3370		    kt,
3371		    0,
3372		    FFEINFO_kindENTITY,
3373		    FFEINFO_whereCONSTANT,
3374		    FFETARGET_charactersizeNONE));
3375
3376  if ((error != FFEBAD)
3377      && ffebad_start (error))
3378    {
3379      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3380      ffebad_finish ();
3381    }
3382
3383  return expr;
3384}
3385
3386/* ffeexpr_collapse_not -- Collapse not expr
3387
3388   ffebld expr;
3389   ffelexToken token;
3390   expr = ffeexpr_collapse_not(expr,token);
3391
3392   If the result of the expr is a constant, replaces the expr with the
3393   computed constant.  */
3394
3395ffebld
3396ffeexpr_collapse_not (ffebld expr, ffelexToken t)
3397{
3398  ffebad error = FFEBAD;
3399  ffebld r;
3400  ffebldConstantUnion u;
3401  ffeinfoBasictype bt;
3402  ffeinfoKindtype kt;
3403
3404  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3405    return expr;
3406
3407  r = ffebld_left (expr);
3408
3409  if (ffebld_op (r) != FFEBLD_opCONTER)
3410    return expr;
3411
3412  switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3413    {
3414    case FFEINFO_basictypeANY:
3415      return expr;
3416
3417    case FFEINFO_basictypeINTEGER:
3418      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3419	{
3420#if FFETARGET_okINTEGER1
3421	case FFEINFO_kindtypeINTEGER1:
3422	  error = ffetarget_not_integer1 (ffebld_cu_ptr_integer1 (u),
3423			      ffebld_constant_integer1 (ffebld_conter (r)));
3424	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3425					(ffebld_cu_val_integer1 (u)), expr);
3426	  break;
3427#endif
3428
3429#if FFETARGET_okINTEGER2
3430	case FFEINFO_kindtypeINTEGER2:
3431	  error = ffetarget_not_integer2 (ffebld_cu_ptr_integer2 (u),
3432			      ffebld_constant_integer2 (ffebld_conter (r)));
3433	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3434					(ffebld_cu_val_integer2 (u)), expr);
3435	  break;
3436#endif
3437
3438#if FFETARGET_okINTEGER3
3439	case FFEINFO_kindtypeINTEGER3:
3440	  error = ffetarget_not_integer3 (ffebld_cu_ptr_integer3 (u),
3441			      ffebld_constant_integer3 (ffebld_conter (r)));
3442	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3443					(ffebld_cu_val_integer3 (u)), expr);
3444	  break;
3445#endif
3446
3447#if FFETARGET_okINTEGER4
3448	case FFEINFO_kindtypeINTEGER4:
3449	  error = ffetarget_not_integer4 (ffebld_cu_ptr_integer4 (u),
3450			      ffebld_constant_integer4 (ffebld_conter (r)));
3451	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3452					(ffebld_cu_val_integer4 (u)), expr);
3453	  break;
3454#endif
3455
3456	default:
3457	  assert ("bad integer kind type" == NULL);
3458	  break;
3459	}
3460      break;
3461
3462    case FFEINFO_basictypeLOGICAL:
3463      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3464	{
3465#if FFETARGET_okLOGICAL1
3466	case FFEINFO_kindtypeLOGICAL1:
3467	  error = ffetarget_not_logical1 (ffebld_cu_ptr_logical1 (u),
3468			      ffebld_constant_logical1 (ffebld_conter (r)));
3469	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
3470					(ffebld_cu_val_logical1 (u)), expr);
3471	  break;
3472#endif
3473
3474#if FFETARGET_okLOGICAL2
3475	case FFEINFO_kindtypeLOGICAL2:
3476	  error = ffetarget_not_logical2 (ffebld_cu_ptr_logical2 (u),
3477			      ffebld_constant_logical2 (ffebld_conter (r)));
3478	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
3479					(ffebld_cu_val_logical2 (u)), expr);
3480	  break;
3481#endif
3482
3483#if FFETARGET_okLOGICAL3
3484	case FFEINFO_kindtypeLOGICAL3:
3485	  error = ffetarget_not_logical3 (ffebld_cu_ptr_logical3 (u),
3486			      ffebld_constant_logical3 (ffebld_conter (r)));
3487	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
3488					(ffebld_cu_val_logical3 (u)), expr);
3489	  break;
3490#endif
3491
3492#if FFETARGET_okLOGICAL4
3493	case FFEINFO_kindtypeLOGICAL4:
3494	  error = ffetarget_not_logical4 (ffebld_cu_ptr_logical4 (u),
3495			      ffebld_constant_logical4 (ffebld_conter (r)));
3496	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
3497					(ffebld_cu_val_logical4 (u)), expr);
3498	  break;
3499#endif
3500
3501	default:
3502	  assert ("bad logical kind type" == NULL);
3503	  break;
3504	}
3505      break;
3506
3507    default:
3508      assert ("bad type" == NULL);
3509      return expr;
3510    }
3511
3512  ffebld_set_info (expr, ffeinfo_new
3513		   (bt,
3514		    kt,
3515		    0,
3516		    FFEINFO_kindENTITY,
3517		    FFEINFO_whereCONSTANT,
3518		    FFETARGET_charactersizeNONE));
3519
3520  if ((error != FFEBAD)
3521      && ffebad_start (error))
3522    {
3523      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3524      ffebad_finish ();
3525    }
3526
3527  return expr;
3528}
3529
3530/* ffeexpr_collapse_add -- Collapse add expr
3531
3532   ffebld expr;
3533   ffelexToken token;
3534   expr = ffeexpr_collapse_add(expr,token);
3535
3536   If the result of the expr is a constant, replaces the expr with the
3537   computed constant.  */
3538
3539ffebld
3540ffeexpr_collapse_add (ffebld expr, ffelexToken t)
3541{
3542  ffebad error = FFEBAD;
3543  ffebld l;
3544  ffebld r;
3545  ffebldConstantUnion u;
3546  ffeinfoBasictype bt;
3547  ffeinfoKindtype kt;
3548
3549  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3550    return expr;
3551
3552  l = ffebld_left (expr);
3553  r = ffebld_right (expr);
3554
3555  if (ffebld_op (l) != FFEBLD_opCONTER)
3556    return expr;
3557  if (ffebld_op (r) != FFEBLD_opCONTER)
3558    return expr;
3559
3560  switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3561    {
3562    case FFEINFO_basictypeANY:
3563      return expr;
3564
3565    case FFEINFO_basictypeINTEGER:
3566      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3567	{
3568#if FFETARGET_okINTEGER1
3569	case FFEINFO_kindtypeINTEGER1:
3570	  error = ffetarget_add_integer1 (ffebld_cu_ptr_integer1 (u),
3571			       ffebld_constant_integer1 (ffebld_conter (l)),
3572			      ffebld_constant_integer1 (ffebld_conter (r)));
3573	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3574					(ffebld_cu_val_integer1 (u)), expr);
3575	  break;
3576#endif
3577
3578#if FFETARGET_okINTEGER2
3579	case FFEINFO_kindtypeINTEGER2:
3580	  error = ffetarget_add_integer2 (ffebld_cu_ptr_integer2 (u),
3581			       ffebld_constant_integer2 (ffebld_conter (l)),
3582			      ffebld_constant_integer2 (ffebld_conter (r)));
3583	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3584					(ffebld_cu_val_integer2 (u)), expr);
3585	  break;
3586#endif
3587
3588#if FFETARGET_okINTEGER3
3589	case FFEINFO_kindtypeINTEGER3:
3590	  error = ffetarget_add_integer3 (ffebld_cu_ptr_integer3 (u),
3591			       ffebld_constant_integer3 (ffebld_conter (l)),
3592			      ffebld_constant_integer3 (ffebld_conter (r)));
3593	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3594					(ffebld_cu_val_integer3 (u)), expr);
3595	  break;
3596#endif
3597
3598#if FFETARGET_okINTEGER4
3599	case FFEINFO_kindtypeINTEGER4:
3600	  error = ffetarget_add_integer4 (ffebld_cu_ptr_integer4 (u),
3601			       ffebld_constant_integer4 (ffebld_conter (l)),
3602			      ffebld_constant_integer4 (ffebld_conter (r)));
3603	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3604					(ffebld_cu_val_integer4 (u)), expr);
3605	  break;
3606#endif
3607
3608	default:
3609	  assert ("bad integer kind type" == NULL);
3610	  break;
3611	}
3612      break;
3613
3614    case FFEINFO_basictypeREAL:
3615      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3616	{
3617#if FFETARGET_okREAL1
3618	case FFEINFO_kindtypeREAL1:
3619	  error = ffetarget_add_real1 (ffebld_cu_ptr_real1 (u),
3620				  ffebld_constant_real1 (ffebld_conter (l)),
3621				 ffebld_constant_real1 (ffebld_conter (r)));
3622	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3623					   (ffebld_cu_val_real1 (u)), expr);
3624	  break;
3625#endif
3626
3627#if FFETARGET_okREAL2
3628	case FFEINFO_kindtypeREAL2:
3629	  error = ffetarget_add_real2 (ffebld_cu_ptr_real2 (u),
3630				  ffebld_constant_real2 (ffebld_conter (l)),
3631				 ffebld_constant_real2 (ffebld_conter (r)));
3632	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3633					   (ffebld_cu_val_real2 (u)), expr);
3634	  break;
3635#endif
3636
3637#if FFETARGET_okREAL3
3638	case FFEINFO_kindtypeREAL3:
3639	  error = ffetarget_add_real3 (ffebld_cu_ptr_real3 (u),
3640				  ffebld_constant_real3 (ffebld_conter (l)),
3641				 ffebld_constant_real3 (ffebld_conter (r)));
3642	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3643					   (ffebld_cu_val_real3 (u)), expr);
3644	  break;
3645#endif
3646
3647#if FFETARGET_okREAL4
3648	case FFEINFO_kindtypeREAL4:
3649	  error = ffetarget_add_real4 (ffebld_cu_ptr_real4 (u),
3650				  ffebld_constant_real4 (ffebld_conter (l)),
3651				 ffebld_constant_real4 (ffebld_conter (r)));
3652	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
3653					   (ffebld_cu_val_real4 (u)), expr);
3654	  break;
3655#endif
3656
3657	default:
3658	  assert ("bad real kind type" == NULL);
3659	  break;
3660	}
3661      break;
3662
3663    case FFEINFO_basictypeCOMPLEX:
3664      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3665	{
3666#if FFETARGET_okCOMPLEX1
3667	case FFEINFO_kindtypeREAL1:
3668	  error = ffetarget_add_complex1 (ffebld_cu_ptr_complex1 (u),
3669			       ffebld_constant_complex1 (ffebld_conter (l)),
3670			      ffebld_constant_complex1 (ffebld_conter (r)));
3671	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3672					(ffebld_cu_val_complex1 (u)), expr);
3673	  break;
3674#endif
3675
3676#if FFETARGET_okCOMPLEX2
3677	case FFEINFO_kindtypeREAL2:
3678	  error = ffetarget_add_complex2 (ffebld_cu_ptr_complex2 (u),
3679			       ffebld_constant_complex2 (ffebld_conter (l)),
3680			      ffebld_constant_complex2 (ffebld_conter (r)));
3681	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3682					(ffebld_cu_val_complex2 (u)), expr);
3683	  break;
3684#endif
3685
3686#if FFETARGET_okCOMPLEX3
3687	case FFEINFO_kindtypeREAL3:
3688	  error = ffetarget_add_complex3 (ffebld_cu_ptr_complex3 (u),
3689			       ffebld_constant_complex3 (ffebld_conter (l)),
3690			      ffebld_constant_complex3 (ffebld_conter (r)));
3691	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3692					(ffebld_cu_val_complex3 (u)), expr);
3693	  break;
3694#endif
3695
3696#if FFETARGET_okCOMPLEX4
3697	case FFEINFO_kindtypeREAL4:
3698	  error = ffetarget_add_complex4 (ffebld_cu_ptr_complex4 (u),
3699			       ffebld_constant_complex4 (ffebld_conter (l)),
3700			      ffebld_constant_complex4 (ffebld_conter (r)));
3701	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
3702					(ffebld_cu_val_complex4 (u)), expr);
3703	  break;
3704#endif
3705
3706	default:
3707	  assert ("bad complex kind type" == NULL);
3708	  break;
3709	}
3710      break;
3711
3712    default:
3713      assert ("bad type" == NULL);
3714      return expr;
3715    }
3716
3717  ffebld_set_info (expr, ffeinfo_new
3718		   (bt,
3719		    kt,
3720		    0,
3721		    FFEINFO_kindENTITY,
3722		    FFEINFO_whereCONSTANT,
3723		    FFETARGET_charactersizeNONE));
3724
3725  if ((error != FFEBAD)
3726      && ffebad_start (error))
3727    {
3728      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3729      ffebad_finish ();
3730    }
3731
3732  return expr;
3733}
3734
3735/* ffeexpr_collapse_subtract -- Collapse subtract expr
3736
3737   ffebld expr;
3738   ffelexToken token;
3739   expr = ffeexpr_collapse_subtract(expr,token);
3740
3741   If the result of the expr is a constant, replaces the expr with the
3742   computed constant.  */
3743
3744ffebld
3745ffeexpr_collapse_subtract (ffebld expr, ffelexToken t)
3746{
3747  ffebad error = FFEBAD;
3748  ffebld l;
3749  ffebld r;
3750  ffebldConstantUnion u;
3751  ffeinfoBasictype bt;
3752  ffeinfoKindtype kt;
3753
3754  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3755    return expr;
3756
3757  l = ffebld_left (expr);
3758  r = ffebld_right (expr);
3759
3760  if (ffebld_op (l) != FFEBLD_opCONTER)
3761    return expr;
3762  if (ffebld_op (r) != FFEBLD_opCONTER)
3763    return expr;
3764
3765  switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3766    {
3767    case FFEINFO_basictypeANY:
3768      return expr;
3769
3770    case FFEINFO_basictypeINTEGER:
3771      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3772	{
3773#if FFETARGET_okINTEGER1
3774	case FFEINFO_kindtypeINTEGER1:
3775	  error = ffetarget_subtract_integer1 (ffebld_cu_ptr_integer1 (u),
3776			       ffebld_constant_integer1 (ffebld_conter (l)),
3777			      ffebld_constant_integer1 (ffebld_conter (r)));
3778	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3779					(ffebld_cu_val_integer1 (u)), expr);
3780	  break;
3781#endif
3782
3783#if FFETARGET_okINTEGER2
3784	case FFEINFO_kindtypeINTEGER2:
3785	  error = ffetarget_subtract_integer2 (ffebld_cu_ptr_integer2 (u),
3786			       ffebld_constant_integer2 (ffebld_conter (l)),
3787			      ffebld_constant_integer2 (ffebld_conter (r)));
3788	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3789					(ffebld_cu_val_integer2 (u)), expr);
3790	  break;
3791#endif
3792
3793#if FFETARGET_okINTEGER3
3794	case FFEINFO_kindtypeINTEGER3:
3795	  error = ffetarget_subtract_integer3 (ffebld_cu_ptr_integer3 (u),
3796			       ffebld_constant_integer3 (ffebld_conter (l)),
3797			      ffebld_constant_integer3 (ffebld_conter (r)));
3798	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3799					(ffebld_cu_val_integer3 (u)), expr);
3800	  break;
3801#endif
3802
3803#if FFETARGET_okINTEGER4
3804	case FFEINFO_kindtypeINTEGER4:
3805	  error = ffetarget_subtract_integer4 (ffebld_cu_ptr_integer4 (u),
3806			       ffebld_constant_integer4 (ffebld_conter (l)),
3807			      ffebld_constant_integer4 (ffebld_conter (r)));
3808	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3809					(ffebld_cu_val_integer4 (u)), expr);
3810	  break;
3811#endif
3812
3813	default:
3814	  assert ("bad integer kind type" == NULL);
3815	  break;
3816	}
3817      break;
3818
3819    case FFEINFO_basictypeREAL:
3820      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3821	{
3822#if FFETARGET_okREAL1
3823	case FFEINFO_kindtypeREAL1:
3824	  error = ffetarget_subtract_real1 (ffebld_cu_ptr_real1 (u),
3825				  ffebld_constant_real1 (ffebld_conter (l)),
3826				 ffebld_constant_real1 (ffebld_conter (r)));
3827	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3828					   (ffebld_cu_val_real1 (u)), expr);
3829	  break;
3830#endif
3831
3832#if FFETARGET_okREAL2
3833	case FFEINFO_kindtypeREAL2:
3834	  error = ffetarget_subtract_real2 (ffebld_cu_ptr_real2 (u),
3835				  ffebld_constant_real2 (ffebld_conter (l)),
3836				 ffebld_constant_real2 (ffebld_conter (r)));
3837	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3838					   (ffebld_cu_val_real2 (u)), expr);
3839	  break;
3840#endif
3841
3842#if FFETARGET_okREAL3
3843	case FFEINFO_kindtypeREAL3:
3844	  error = ffetarget_subtract_real3 (ffebld_cu_ptr_real3 (u),
3845				  ffebld_constant_real3 (ffebld_conter (l)),
3846				 ffebld_constant_real3 (ffebld_conter (r)));
3847	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3848					   (ffebld_cu_val_real3 (u)), expr);
3849	  break;
3850#endif
3851
3852#if FFETARGET_okREAL4
3853	case FFEINFO_kindtypeREAL4:
3854	  error = ffetarget_subtract_real4 (ffebld_cu_ptr_real4 (u),
3855				  ffebld_constant_real4 (ffebld_conter (l)),
3856				 ffebld_constant_real4 (ffebld_conter (r)));
3857	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
3858					   (ffebld_cu_val_real4 (u)), expr);
3859	  break;
3860#endif
3861
3862	default:
3863	  assert ("bad real kind type" == NULL);
3864	  break;
3865	}
3866      break;
3867
3868    case FFEINFO_basictypeCOMPLEX:
3869      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3870	{
3871#if FFETARGET_okCOMPLEX1
3872	case FFEINFO_kindtypeREAL1:
3873	  error = ffetarget_subtract_complex1 (ffebld_cu_ptr_complex1 (u),
3874			       ffebld_constant_complex1 (ffebld_conter (l)),
3875			      ffebld_constant_complex1 (ffebld_conter (r)));
3876	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3877					(ffebld_cu_val_complex1 (u)), expr);
3878	  break;
3879#endif
3880
3881#if FFETARGET_okCOMPLEX2
3882	case FFEINFO_kindtypeREAL2:
3883	  error = ffetarget_subtract_complex2 (ffebld_cu_ptr_complex2 (u),
3884			       ffebld_constant_complex2 (ffebld_conter (l)),
3885			      ffebld_constant_complex2 (ffebld_conter (r)));
3886	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3887					(ffebld_cu_val_complex2 (u)), expr);
3888	  break;
3889#endif
3890
3891#if FFETARGET_okCOMPLEX3
3892	case FFEINFO_kindtypeREAL3:
3893	  error = ffetarget_subtract_complex3 (ffebld_cu_ptr_complex3 (u),
3894			       ffebld_constant_complex3 (ffebld_conter (l)),
3895			      ffebld_constant_complex3 (ffebld_conter (r)));
3896	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3897					(ffebld_cu_val_complex3 (u)), expr);
3898	  break;
3899#endif
3900
3901#if FFETARGET_okCOMPLEX4
3902	case FFEINFO_kindtypeREAL4:
3903	  error = ffetarget_subtract_complex4 (ffebld_cu_ptr_complex4 (u),
3904			       ffebld_constant_complex4 (ffebld_conter (l)),
3905			      ffebld_constant_complex4 (ffebld_conter (r)));
3906	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
3907					(ffebld_cu_val_complex4 (u)), expr);
3908	  break;
3909#endif
3910
3911	default:
3912	  assert ("bad complex kind type" == NULL);
3913	  break;
3914	}
3915      break;
3916
3917    default:
3918      assert ("bad type" == NULL);
3919      return expr;
3920    }
3921
3922  ffebld_set_info (expr, ffeinfo_new
3923		   (bt,
3924		    kt,
3925		    0,
3926		    FFEINFO_kindENTITY,
3927		    FFEINFO_whereCONSTANT,
3928		    FFETARGET_charactersizeNONE));
3929
3930  if ((error != FFEBAD)
3931      && ffebad_start (error))
3932    {
3933      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3934      ffebad_finish ();
3935    }
3936
3937  return expr;
3938}
3939
3940/* ffeexpr_collapse_multiply -- Collapse multiply expr
3941
3942   ffebld expr;
3943   ffelexToken token;
3944   expr = ffeexpr_collapse_multiply(expr,token);
3945
3946   If the result of the expr is a constant, replaces the expr with the
3947   computed constant.  */
3948
3949ffebld
3950ffeexpr_collapse_multiply (ffebld expr, ffelexToken t)
3951{
3952  ffebad error = FFEBAD;
3953  ffebld l;
3954  ffebld r;
3955  ffebldConstantUnion u;
3956  ffeinfoBasictype bt;
3957  ffeinfoKindtype kt;
3958
3959  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3960    return expr;
3961
3962  l = ffebld_left (expr);
3963  r = ffebld_right (expr);
3964
3965  if (ffebld_op (l) != FFEBLD_opCONTER)
3966    return expr;
3967  if (ffebld_op (r) != FFEBLD_opCONTER)
3968    return expr;
3969
3970  switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3971    {
3972    case FFEINFO_basictypeANY:
3973      return expr;
3974
3975    case FFEINFO_basictypeINTEGER:
3976      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3977	{
3978#if FFETARGET_okINTEGER1
3979	case FFEINFO_kindtypeINTEGER1:
3980	  error = ffetarget_multiply_integer1 (ffebld_cu_ptr_integer1 (u),
3981			       ffebld_constant_integer1 (ffebld_conter (l)),
3982			      ffebld_constant_integer1 (ffebld_conter (r)));
3983	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3984					(ffebld_cu_val_integer1 (u)), expr);
3985	  break;
3986#endif
3987
3988#if FFETARGET_okINTEGER2
3989	case FFEINFO_kindtypeINTEGER2:
3990	  error = ffetarget_multiply_integer2 (ffebld_cu_ptr_integer2 (u),
3991			       ffebld_constant_integer2 (ffebld_conter (l)),
3992			      ffebld_constant_integer2 (ffebld_conter (r)));
3993	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3994					(ffebld_cu_val_integer2 (u)), expr);
3995	  break;
3996#endif
3997
3998#if FFETARGET_okINTEGER3
3999	case FFEINFO_kindtypeINTEGER3:
4000	  error = ffetarget_multiply_integer3 (ffebld_cu_ptr_integer3 (u),
4001			       ffebld_constant_integer3 (ffebld_conter (l)),
4002			      ffebld_constant_integer3 (ffebld_conter (r)));
4003	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
4004					(ffebld_cu_val_integer3 (u)), expr);
4005	  break;
4006#endif
4007
4008#if FFETARGET_okINTEGER4
4009	case FFEINFO_kindtypeINTEGER4:
4010	  error = ffetarget_multiply_integer4 (ffebld_cu_ptr_integer4 (u),
4011			       ffebld_constant_integer4 (ffebld_conter (l)),
4012			      ffebld_constant_integer4 (ffebld_conter (r)));
4013	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
4014					(ffebld_cu_val_integer4 (u)), expr);
4015	  break;
4016#endif
4017
4018	default:
4019	  assert ("bad integer kind type" == NULL);
4020	  break;
4021	}
4022      break;
4023
4024    case FFEINFO_basictypeREAL:
4025      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4026	{
4027#if FFETARGET_okREAL1
4028	case FFEINFO_kindtypeREAL1:
4029	  error = ffetarget_multiply_real1 (ffebld_cu_ptr_real1 (u),
4030				  ffebld_constant_real1 (ffebld_conter (l)),
4031				 ffebld_constant_real1 (ffebld_conter (r)));
4032	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
4033					   (ffebld_cu_val_real1 (u)), expr);
4034	  break;
4035#endif
4036
4037#if FFETARGET_okREAL2
4038	case FFEINFO_kindtypeREAL2:
4039	  error = ffetarget_multiply_real2 (ffebld_cu_ptr_real2 (u),
4040				  ffebld_constant_real2 (ffebld_conter (l)),
4041				 ffebld_constant_real2 (ffebld_conter (r)));
4042	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
4043					   (ffebld_cu_val_real2 (u)), expr);
4044	  break;
4045#endif
4046
4047#if FFETARGET_okREAL3
4048	case FFEINFO_kindtypeREAL3:
4049	  error = ffetarget_multiply_real3 (ffebld_cu_ptr_real3 (u),
4050				  ffebld_constant_real3 (ffebld_conter (l)),
4051				 ffebld_constant_real3 (ffebld_conter (r)));
4052	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
4053					   (ffebld_cu_val_real3 (u)), expr);
4054	  break;
4055#endif
4056
4057#if FFETARGET_okREAL4
4058	case FFEINFO_kindtypeREAL4:
4059	  error = ffetarget_multiply_real4 (ffebld_cu_ptr_real4 (u),
4060				  ffebld_constant_real4 (ffebld_conter (l)),
4061				 ffebld_constant_real4 (ffebld_conter (r)));
4062	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
4063					   (ffebld_cu_val_real4 (u)), expr);
4064	  break;
4065#endif
4066
4067	default:
4068	  assert ("bad real kind type" == NULL);
4069	  break;
4070	}
4071      break;
4072
4073    case FFEINFO_basictypeCOMPLEX:
4074      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4075	{
4076#if FFETARGET_okCOMPLEX1
4077	case FFEINFO_kindtypeREAL1:
4078	  error = ffetarget_multiply_complex1 (ffebld_cu_ptr_complex1 (u),
4079			       ffebld_constant_complex1 (ffebld_conter (l)),
4080			      ffebld_constant_complex1 (ffebld_conter (r)));
4081	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
4082					(ffebld_cu_val_complex1 (u)), expr);
4083	  break;
4084#endif
4085
4086#if FFETARGET_okCOMPLEX2
4087	case FFEINFO_kindtypeREAL2:
4088	  error = ffetarget_multiply_complex2 (ffebld_cu_ptr_complex2 (u),
4089			       ffebld_constant_complex2 (ffebld_conter (l)),
4090			      ffebld_constant_complex2 (ffebld_conter (r)));
4091	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
4092					(ffebld_cu_val_complex2 (u)), expr);
4093	  break;
4094#endif
4095
4096#if FFETARGET_okCOMPLEX3
4097	case FFEINFO_kindtypeREAL3:
4098	  error = ffetarget_multiply_complex3 (ffebld_cu_ptr_complex3 (u),
4099			       ffebld_constant_complex3 (ffebld_conter (l)),
4100			      ffebld_constant_complex3 (ffebld_conter (r)));
4101	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
4102					(ffebld_cu_val_complex3 (u)), expr);
4103	  break;
4104#endif
4105
4106#if FFETARGET_okCOMPLEX4
4107	case FFEINFO_kindtypeREAL4:
4108	  error = ffetarget_multiply_complex4 (ffebld_cu_ptr_complex4 (u),
4109			       ffebld_constant_complex4 (ffebld_conter (l)),
4110			      ffebld_constant_complex4 (ffebld_conter (r)));
4111	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
4112					(ffebld_cu_val_complex4 (u)), expr);
4113	  break;
4114#endif
4115
4116	default:
4117	  assert ("bad complex kind type" == NULL);
4118	  break;
4119	}
4120      break;
4121
4122    default:
4123      assert ("bad type" == NULL);
4124      return expr;
4125    }
4126
4127  ffebld_set_info (expr, ffeinfo_new
4128		   (bt,
4129		    kt,
4130		    0,
4131		    FFEINFO_kindENTITY,
4132		    FFEINFO_whereCONSTANT,
4133		    FFETARGET_charactersizeNONE));
4134
4135  if ((error != FFEBAD)
4136      && ffebad_start (error))
4137    {
4138      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4139      ffebad_finish ();
4140    }
4141
4142  return expr;
4143}
4144
4145/* ffeexpr_collapse_divide -- Collapse divide expr
4146
4147   ffebld expr;
4148   ffelexToken token;
4149   expr = ffeexpr_collapse_divide(expr,token);
4150
4151   If the result of the expr is a constant, replaces the expr with the
4152   computed constant.  */
4153
4154ffebld
4155ffeexpr_collapse_divide (ffebld expr, ffelexToken t)
4156{
4157  ffebad error = FFEBAD;
4158  ffebld l;
4159  ffebld r;
4160  ffebldConstantUnion u;
4161  ffeinfoBasictype bt;
4162  ffeinfoKindtype kt;
4163
4164  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4165    return expr;
4166
4167  l = ffebld_left (expr);
4168  r = ffebld_right (expr);
4169
4170  if (ffebld_op (l) != FFEBLD_opCONTER)
4171    return expr;
4172  if (ffebld_op (r) != FFEBLD_opCONTER)
4173    return expr;
4174
4175  switch (bt = ffeinfo_basictype (ffebld_info (expr)))
4176    {
4177    case FFEINFO_basictypeANY:
4178      return expr;
4179
4180    case FFEINFO_basictypeINTEGER:
4181      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4182	{
4183#if FFETARGET_okINTEGER1
4184	case FFEINFO_kindtypeINTEGER1:
4185	  error = ffetarget_divide_integer1 (ffebld_cu_ptr_integer1 (u),
4186			       ffebld_constant_integer1 (ffebld_conter (l)),
4187			      ffebld_constant_integer1 (ffebld_conter (r)));
4188	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
4189					(ffebld_cu_val_integer1 (u)), expr);
4190	  break;
4191#endif
4192
4193#if FFETARGET_okINTEGER2
4194	case FFEINFO_kindtypeINTEGER2:
4195	  error = ffetarget_divide_integer2 (ffebld_cu_ptr_integer2 (u),
4196			       ffebld_constant_integer2 (ffebld_conter (l)),
4197			      ffebld_constant_integer2 (ffebld_conter (r)));
4198	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
4199					(ffebld_cu_val_integer2 (u)), expr);
4200	  break;
4201#endif
4202
4203#if FFETARGET_okINTEGER3
4204	case FFEINFO_kindtypeINTEGER3:
4205	  error = ffetarget_divide_integer3 (ffebld_cu_ptr_integer3 (u),
4206			       ffebld_constant_integer3 (ffebld_conter (l)),
4207			      ffebld_constant_integer3 (ffebld_conter (r)));
4208	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
4209					(ffebld_cu_val_integer3 (u)), expr);
4210	  break;
4211#endif
4212
4213#if FFETARGET_okINTEGER4
4214	case FFEINFO_kindtypeINTEGER4:
4215	  error = ffetarget_divide_integer4 (ffebld_cu_ptr_integer4 (u),
4216			       ffebld_constant_integer4 (ffebld_conter (l)),
4217			      ffebld_constant_integer4 (ffebld_conter (r)));
4218	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
4219					(ffebld_cu_val_integer4 (u)), expr);
4220	  break;
4221#endif
4222
4223	default:
4224	  assert ("bad integer kind type" == NULL);
4225	  break;
4226	}
4227      break;
4228
4229    case FFEINFO_basictypeREAL:
4230      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4231	{
4232#if FFETARGET_okREAL1
4233	case FFEINFO_kindtypeREAL1:
4234	  error = ffetarget_divide_real1 (ffebld_cu_ptr_real1 (u),
4235				  ffebld_constant_real1 (ffebld_conter (l)),
4236				 ffebld_constant_real1 (ffebld_conter (r)));
4237	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
4238					   (ffebld_cu_val_real1 (u)), expr);
4239	  break;
4240#endif
4241
4242#if FFETARGET_okREAL2
4243	case FFEINFO_kindtypeREAL2:
4244	  error = ffetarget_divide_real2 (ffebld_cu_ptr_real2 (u),
4245				  ffebld_constant_real2 (ffebld_conter (l)),
4246				 ffebld_constant_real2 (ffebld_conter (r)));
4247	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
4248					   (ffebld_cu_val_real2 (u)), expr);
4249	  break;
4250#endif
4251
4252#if FFETARGET_okREAL3
4253	case FFEINFO_kindtypeREAL3:
4254	  error = ffetarget_divide_real3 (ffebld_cu_ptr_real3 (u),
4255				  ffebld_constant_real3 (ffebld_conter (l)),
4256				 ffebld_constant_real3 (ffebld_conter (r)));
4257	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
4258					   (ffebld_cu_val_real3 (u)), expr);
4259	  break;
4260#endif
4261
4262#if FFETARGET_okREAL4
4263	case FFEINFO_kindtypeREAL4:
4264	  error = ffetarget_divide_real4 (ffebld_cu_ptr_real4 (u),
4265				  ffebld_constant_real4 (ffebld_conter (l)),
4266				 ffebld_constant_real4 (ffebld_conter (r)));
4267	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
4268					   (ffebld_cu_val_real4 (u)), expr);
4269	  break;
4270#endif
4271
4272	default:
4273	  assert ("bad real kind type" == NULL);
4274	  break;
4275	}
4276      break;
4277
4278    case FFEINFO_basictypeCOMPLEX:
4279      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4280	{
4281#if FFETARGET_okCOMPLEX1
4282	case FFEINFO_kindtypeREAL1:
4283	  error = ffetarget_divide_complex1 (ffebld_cu_ptr_complex1 (u),
4284			       ffebld_constant_complex1 (ffebld_conter (l)),
4285			      ffebld_constant_complex1 (ffebld_conter (r)));
4286	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
4287					(ffebld_cu_val_complex1 (u)), expr);
4288	  break;
4289#endif
4290
4291#if FFETARGET_okCOMPLEX2
4292	case FFEINFO_kindtypeREAL2:
4293	  error = ffetarget_divide_complex2 (ffebld_cu_ptr_complex2 (u),
4294			       ffebld_constant_complex2 (ffebld_conter (l)),
4295			      ffebld_constant_complex2 (ffebld_conter (r)));
4296	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
4297					(ffebld_cu_val_complex2 (u)), expr);
4298	  break;
4299#endif
4300
4301#if FFETARGET_okCOMPLEX3
4302	case FFEINFO_kindtypeREAL3:
4303	  error = ffetarget_divide_complex3 (ffebld_cu_ptr_complex3 (u),
4304			       ffebld_constant_complex3 (ffebld_conter (l)),
4305			      ffebld_constant_complex3 (ffebld_conter (r)));
4306	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
4307					(ffebld_cu_val_complex3 (u)), expr);
4308	  break;
4309#endif
4310
4311#if FFETARGET_okCOMPLEX4
4312	case FFEINFO_kindtypeREAL4:
4313	  error = ffetarget_divide_complex4 (ffebld_cu_ptr_complex4 (u),
4314			       ffebld_constant_complex4 (ffebld_conter (l)),
4315			      ffebld_constant_complex4 (ffebld_conter (r)));
4316	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
4317					(ffebld_cu_val_complex4 (u)), expr);
4318	  break;
4319#endif
4320
4321	default:
4322	  assert ("bad complex kind type" == NULL);
4323	  break;
4324	}
4325      break;
4326
4327    default:
4328      assert ("bad type" == NULL);
4329      return expr;
4330    }
4331
4332  ffebld_set_info (expr, ffeinfo_new
4333		   (bt,
4334		    kt,
4335		    0,
4336		    FFEINFO_kindENTITY,
4337		    FFEINFO_whereCONSTANT,
4338		    FFETARGET_charactersizeNONE));
4339
4340  if ((error != FFEBAD)
4341      && ffebad_start (error))
4342    {
4343      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4344      ffebad_finish ();
4345    }
4346
4347  return expr;
4348}
4349
4350/* ffeexpr_collapse_power -- Collapse power expr
4351
4352   ffebld expr;
4353   ffelexToken token;
4354   expr = ffeexpr_collapse_power(expr,token);
4355
4356   If the result of the expr is a constant, replaces the expr with the
4357   computed constant.  */
4358
4359ffebld
4360ffeexpr_collapse_power (ffebld expr, ffelexToken t)
4361{
4362  ffebad error = FFEBAD;
4363  ffebld l;
4364  ffebld r;
4365  ffebldConstantUnion u;
4366  ffeinfoBasictype bt;
4367  ffeinfoKindtype kt;
4368
4369  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4370    return expr;
4371
4372  l = ffebld_left (expr);
4373  r = ffebld_right (expr);
4374
4375  if (ffebld_op (l) != FFEBLD_opCONTER)
4376    return expr;
4377  if (ffebld_op (r) != FFEBLD_opCONTER)
4378    return expr;
4379
4380  if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER)
4381  || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT))
4382    return expr;
4383
4384  switch (bt = ffeinfo_basictype (ffebld_info (expr)))
4385    {
4386    case FFEINFO_basictypeANY:
4387      return expr;
4388
4389    case FFEINFO_basictypeINTEGER:
4390      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4391	{
4392	case FFEINFO_kindtypeINTEGERDEFAULT:
4393	  error = ffetarget_power_integerdefault_integerdefault
4394	    (ffebld_cu_ptr_integerdefault (u),
4395	     ffebld_constant_integerdefault (ffebld_conter (l)),
4396	     ffebld_constant_integerdefault (ffebld_conter (r)));
4397	  expr = ffebld_new_conter_with_orig
4398	    (ffebld_constant_new_integerdefault_val
4399	     (ffebld_cu_val_integerdefault (u)), expr);
4400	  break;
4401
4402	default:
4403	  assert ("bad integer kind type" == NULL);
4404	  break;
4405	}
4406      break;
4407
4408    case FFEINFO_basictypeREAL:
4409      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4410	{
4411	case FFEINFO_kindtypeREALDEFAULT:
4412	  error = ffetarget_power_realdefault_integerdefault
4413	    (ffebld_cu_ptr_realdefault (u),
4414	     ffebld_constant_realdefault (ffebld_conter (l)),
4415	     ffebld_constant_integerdefault (ffebld_conter (r)));
4416	  expr = ffebld_new_conter_with_orig
4417	    (ffebld_constant_new_realdefault_val
4418	     (ffebld_cu_val_realdefault (u)), expr);
4419	  break;
4420
4421	case FFEINFO_kindtypeREALDOUBLE:
4422	  error = ffetarget_power_realdouble_integerdefault
4423	    (ffebld_cu_ptr_realdouble (u),
4424	     ffebld_constant_realdouble (ffebld_conter (l)),
4425	     ffebld_constant_integerdefault (ffebld_conter (r)));
4426	  expr = ffebld_new_conter_with_orig
4427	    (ffebld_constant_new_realdouble_val
4428	     (ffebld_cu_val_realdouble (u)), expr);
4429	  break;
4430
4431#if FFETARGET_okREALQUAD
4432	case FFEINFO_kindtypeREALQUAD:
4433	  error = ffetarget_power_realquad_integerdefault
4434	    (ffebld_cu_ptr_realquad (u),
4435	     ffebld_constant_realquad (ffebld_conter (l)),
4436	     ffebld_constant_integerdefault (ffebld_conter (r)));
4437	  expr = ffebld_new_conter_with_orig
4438	    (ffebld_constant_new_realquad_val
4439	     (ffebld_cu_val_realquad (u)), expr);
4440	  break;
4441#endif
4442	default:
4443	  assert ("bad real kind type" == NULL);
4444	  break;
4445	}
4446      break;
4447
4448    case FFEINFO_basictypeCOMPLEX:
4449      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4450	{
4451	case FFEINFO_kindtypeREALDEFAULT:
4452	  error = ffetarget_power_complexdefault_integerdefault
4453	    (ffebld_cu_ptr_complexdefault (u),
4454	     ffebld_constant_complexdefault (ffebld_conter (l)),
4455	     ffebld_constant_integerdefault (ffebld_conter (r)));
4456	  expr = ffebld_new_conter_with_orig
4457	    (ffebld_constant_new_complexdefault_val
4458	     (ffebld_cu_val_complexdefault (u)), expr);
4459	  break;
4460
4461#if FFETARGET_okCOMPLEXDOUBLE
4462	case FFEINFO_kindtypeREALDOUBLE:
4463	  error = ffetarget_power_complexdouble_integerdefault
4464	    (ffebld_cu_ptr_complexdouble (u),
4465	     ffebld_constant_complexdouble (ffebld_conter (l)),
4466	     ffebld_constant_integerdefault (ffebld_conter (r)));
4467	  expr = ffebld_new_conter_with_orig
4468	    (ffebld_constant_new_complexdouble_val
4469	     (ffebld_cu_val_complexdouble (u)), expr);
4470	  break;
4471#endif
4472
4473#if FFETARGET_okCOMPLEXQUAD
4474	case FFEINFO_kindtypeREALQUAD:
4475	  error = ffetarget_power_complexquad_integerdefault
4476	    (ffebld_cu_ptr_complexquad (u),
4477	     ffebld_constant_complexquad (ffebld_conter (l)),
4478	     ffebld_constant_integerdefault (ffebld_conter (r)));
4479	  expr = ffebld_new_conter_with_orig
4480	    (ffebld_constant_new_complexquad_val
4481	     (ffebld_cu_val_complexquad (u)), expr);
4482	  break;
4483#endif
4484
4485	default:
4486	  assert ("bad complex kind type" == NULL);
4487	  break;
4488	}
4489      break;
4490
4491    default:
4492      assert ("bad type" == NULL);
4493      return expr;
4494    }
4495
4496  ffebld_set_info (expr, ffeinfo_new
4497		   (bt,
4498		    kt,
4499		    0,
4500		    FFEINFO_kindENTITY,
4501		    FFEINFO_whereCONSTANT,
4502		    FFETARGET_charactersizeNONE));
4503
4504  if ((error != FFEBAD)
4505      && ffebad_start (error))
4506    {
4507      ffebad_here (0, ffelex_token_where_line (t),
4508		   ffelex_token_where_column (t));
4509      ffebad_finish ();
4510    }
4511
4512  return expr;
4513}
4514
4515/* ffeexpr_collapse_concatenate -- Collapse concatenate expr
4516
4517   ffebld expr;
4518   ffelexToken token;
4519   expr = ffeexpr_collapse_concatenate(expr,token);
4520
4521   If the result of the expr is a constant, replaces the expr with the
4522   computed constant.  */
4523
4524ffebld
4525ffeexpr_collapse_concatenate (ffebld expr, ffelexToken t)
4526{
4527  ffebad error = FFEBAD;
4528  ffebld l;
4529  ffebld r;
4530  ffebldConstantUnion u;
4531  ffeinfoKindtype kt;
4532  ffetargetCharacterSize len;
4533
4534  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4535    return expr;
4536
4537  l = ffebld_left (expr);
4538  r = ffebld_right (expr);
4539
4540  if (ffebld_op (l) != FFEBLD_opCONTER)
4541    return expr;
4542  if (ffebld_op (r) != FFEBLD_opCONTER)
4543    return expr;
4544
4545  switch (ffeinfo_basictype (ffebld_info (expr)))
4546    {
4547    case FFEINFO_basictypeANY:
4548      return expr;
4549
4550    case FFEINFO_basictypeCHARACTER:
4551      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4552	{
4553#if FFETARGET_okCHARACTER1
4554	case FFEINFO_kindtypeCHARACTER1:
4555	  error = ffetarget_concatenate_character1 (ffebld_cu_ptr_character1 (u),
4556			     ffebld_constant_character1 (ffebld_conter (l)),
4557			     ffebld_constant_character1 (ffebld_conter (r)),
4558				   ffebld_constant_pool (), &len);
4559	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
4560				      (ffebld_cu_val_character1 (u)), expr);
4561	  break;
4562#endif
4563
4564#if FFETARGET_okCHARACTER2
4565	case FFEINFO_kindtypeCHARACTER2:
4566	  error = ffetarget_concatenate_character2 (ffebld_cu_ptr_character2 (u),
4567			     ffebld_constant_character2 (ffebld_conter (l)),
4568			     ffebld_constant_character2 (ffebld_conter (r)),
4569				   ffebld_constant_pool (), &len);
4570	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val
4571				      (ffebld_cu_val_character2 (u)), expr);
4572	  break;
4573#endif
4574
4575#if FFETARGET_okCHARACTER3
4576	case FFEINFO_kindtypeCHARACTER3:
4577	  error = ffetarget_concatenate_character3 (ffebld_cu_ptr_character3 (u),
4578			     ffebld_constant_character3 (ffebld_conter (l)),
4579			     ffebld_constant_character3 (ffebld_conter (r)),
4580				   ffebld_constant_pool (), &len);
4581	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val
4582				      (ffebld_cu_val_character3 (u)), expr);
4583	  break;
4584#endif
4585
4586#if FFETARGET_okCHARACTER4
4587	case FFEINFO_kindtypeCHARACTER4:
4588	  error = ffetarget_concatenate_character4 (ffebld_cu_ptr_character4 (u),
4589			     ffebld_constant_character4 (ffebld_conter (l)),
4590			     ffebld_constant_character4 (ffebld_conter (r)),
4591				   ffebld_constant_pool (), &len);
4592	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val
4593				      (ffebld_cu_val_character4 (u)), expr);
4594	  break;
4595#endif
4596
4597	default:
4598	  assert ("bad character kind type" == NULL);
4599	  break;
4600	}
4601      break;
4602
4603    default:
4604      assert ("bad type" == NULL);
4605      return expr;
4606    }
4607
4608  ffebld_set_info (expr, ffeinfo_new
4609		   (FFEINFO_basictypeCHARACTER,
4610		    kt,
4611		    0,
4612		    FFEINFO_kindENTITY,
4613		    FFEINFO_whereCONSTANT,
4614		    len));
4615
4616  if ((error != FFEBAD)
4617      && ffebad_start (error))
4618    {
4619      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4620      ffebad_finish ();
4621    }
4622
4623  return expr;
4624}
4625
4626/* ffeexpr_collapse_eq -- Collapse eq expr
4627
4628   ffebld expr;
4629   ffelexToken token;
4630   expr = ffeexpr_collapse_eq(expr,token);
4631
4632   If the result of the expr is a constant, replaces the expr with the
4633   computed constant.  */
4634
4635ffebld
4636ffeexpr_collapse_eq (ffebld expr, ffelexToken t)
4637{
4638  ffebad error = FFEBAD;
4639  ffebld l;
4640  ffebld r;
4641  bool val;
4642
4643  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4644    return expr;
4645
4646  l = ffebld_left (expr);
4647  r = ffebld_right (expr);
4648
4649  if (ffebld_op (l) != FFEBLD_opCONTER)
4650    return expr;
4651  if (ffebld_op (r) != FFEBLD_opCONTER)
4652    return expr;
4653
4654  switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4655    {
4656    case FFEINFO_basictypeANY:
4657      return expr;
4658
4659    case FFEINFO_basictypeINTEGER:
4660      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4661	{
4662#if FFETARGET_okINTEGER1
4663	case FFEINFO_kindtypeINTEGER1:
4664	  error = ffetarget_eq_integer1 (&val,
4665			       ffebld_constant_integer1 (ffebld_conter (l)),
4666			      ffebld_constant_integer1 (ffebld_conter (r)));
4667	  expr = ffebld_new_conter_with_orig
4668	    (ffebld_constant_new_logicaldefault (val), expr);
4669	  break;
4670#endif
4671
4672#if FFETARGET_okINTEGER2
4673	case FFEINFO_kindtypeINTEGER2:
4674	  error = ffetarget_eq_integer2 (&val,
4675			       ffebld_constant_integer2 (ffebld_conter (l)),
4676			      ffebld_constant_integer2 (ffebld_conter (r)));
4677	  expr = ffebld_new_conter_with_orig
4678	    (ffebld_constant_new_logicaldefault (val), expr);
4679	  break;
4680#endif
4681
4682#if FFETARGET_okINTEGER3
4683	case FFEINFO_kindtypeINTEGER3:
4684	  error = ffetarget_eq_integer3 (&val,
4685			       ffebld_constant_integer3 (ffebld_conter (l)),
4686			      ffebld_constant_integer3 (ffebld_conter (r)));
4687	  expr = ffebld_new_conter_with_orig
4688	    (ffebld_constant_new_logicaldefault (val), expr);
4689	  break;
4690#endif
4691
4692#if FFETARGET_okINTEGER4
4693	case FFEINFO_kindtypeINTEGER4:
4694	  error = ffetarget_eq_integer4 (&val,
4695			       ffebld_constant_integer4 (ffebld_conter (l)),
4696			      ffebld_constant_integer4 (ffebld_conter (r)));
4697	  expr = ffebld_new_conter_with_orig
4698	    (ffebld_constant_new_logicaldefault (val), expr);
4699	  break;
4700#endif
4701
4702	default:
4703	  assert ("bad integer kind type" == NULL);
4704	  break;
4705	}
4706      break;
4707
4708    case FFEINFO_basictypeREAL:
4709      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4710	{
4711#if FFETARGET_okREAL1
4712	case FFEINFO_kindtypeREAL1:
4713	  error = ffetarget_eq_real1 (&val,
4714				  ffebld_constant_real1 (ffebld_conter (l)),
4715				 ffebld_constant_real1 (ffebld_conter (r)));
4716	  expr = ffebld_new_conter_with_orig
4717	    (ffebld_constant_new_logicaldefault (val), expr);
4718	  break;
4719#endif
4720
4721#if FFETARGET_okREAL2
4722	case FFEINFO_kindtypeREAL2:
4723	  error = ffetarget_eq_real2 (&val,
4724				  ffebld_constant_real2 (ffebld_conter (l)),
4725				 ffebld_constant_real2 (ffebld_conter (r)));
4726	  expr = ffebld_new_conter_with_orig
4727	    (ffebld_constant_new_logicaldefault (val), expr);
4728	  break;
4729#endif
4730
4731#if FFETARGET_okREAL3
4732	case FFEINFO_kindtypeREAL3:
4733	  error = ffetarget_eq_real3 (&val,
4734				  ffebld_constant_real3 (ffebld_conter (l)),
4735				 ffebld_constant_real3 (ffebld_conter (r)));
4736	  expr = ffebld_new_conter_with_orig
4737	    (ffebld_constant_new_logicaldefault (val), expr);
4738	  break;
4739#endif
4740
4741#if FFETARGET_okREAL4
4742	case FFEINFO_kindtypeREAL4:
4743	  error = ffetarget_eq_real4 (&val,
4744				  ffebld_constant_real4 (ffebld_conter (l)),
4745				 ffebld_constant_real4 (ffebld_conter (r)));
4746	  expr = ffebld_new_conter_with_orig
4747	    (ffebld_constant_new_logicaldefault (val), expr);
4748	  break;
4749#endif
4750
4751	default:
4752	  assert ("bad real kind type" == NULL);
4753	  break;
4754	}
4755      break;
4756
4757    case FFEINFO_basictypeCOMPLEX:
4758      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4759	{
4760#if FFETARGET_okCOMPLEX1
4761	case FFEINFO_kindtypeREAL1:
4762	  error = ffetarget_eq_complex1 (&val,
4763			       ffebld_constant_complex1 (ffebld_conter (l)),
4764			      ffebld_constant_complex1 (ffebld_conter (r)));
4765	  expr = ffebld_new_conter_with_orig
4766	    (ffebld_constant_new_logicaldefault (val), expr);
4767	  break;
4768#endif
4769
4770#if FFETARGET_okCOMPLEX2
4771	case FFEINFO_kindtypeREAL2:
4772	  error = ffetarget_eq_complex2 (&val,
4773			       ffebld_constant_complex2 (ffebld_conter (l)),
4774			      ffebld_constant_complex2 (ffebld_conter (r)));
4775	  expr = ffebld_new_conter_with_orig
4776	    (ffebld_constant_new_logicaldefault (val), expr);
4777	  break;
4778#endif
4779
4780#if FFETARGET_okCOMPLEX3
4781	case FFEINFO_kindtypeREAL3:
4782	  error = ffetarget_eq_complex3 (&val,
4783			       ffebld_constant_complex3 (ffebld_conter (l)),
4784			      ffebld_constant_complex3 (ffebld_conter (r)));
4785	  expr = ffebld_new_conter_with_orig
4786	    (ffebld_constant_new_logicaldefault (val), expr);
4787	  break;
4788#endif
4789
4790#if FFETARGET_okCOMPLEX4
4791	case FFEINFO_kindtypeREAL4:
4792	  error = ffetarget_eq_complex4 (&val,
4793			       ffebld_constant_complex4 (ffebld_conter (l)),
4794			      ffebld_constant_complex4 (ffebld_conter (r)));
4795	  expr = ffebld_new_conter_with_orig
4796	    (ffebld_constant_new_logicaldefault (val), expr);
4797	  break;
4798#endif
4799
4800	default:
4801	  assert ("bad complex kind type" == NULL);
4802	  break;
4803	}
4804      break;
4805
4806    case FFEINFO_basictypeCHARACTER:
4807      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4808	{
4809#if FFETARGET_okCHARACTER1
4810	case FFEINFO_kindtypeCHARACTER1:
4811	  error = ffetarget_eq_character1 (&val,
4812			     ffebld_constant_character1 (ffebld_conter (l)),
4813			    ffebld_constant_character1 (ffebld_conter (r)));
4814	  expr = ffebld_new_conter_with_orig
4815	    (ffebld_constant_new_logicaldefault (val), expr);
4816	  break;
4817#endif
4818
4819#if FFETARGET_okCHARACTER2
4820	case FFEINFO_kindtypeCHARACTER2:
4821	  error = ffetarget_eq_character2 (&val,
4822			     ffebld_constant_character2 (ffebld_conter (l)),
4823			    ffebld_constant_character2 (ffebld_conter (r)));
4824	  expr = ffebld_new_conter_with_orig
4825	    (ffebld_constant_new_logicaldefault (val), expr);
4826	  break;
4827#endif
4828
4829#if FFETARGET_okCHARACTER3
4830	case FFEINFO_kindtypeCHARACTER3:
4831	  error = ffetarget_eq_character3 (&val,
4832			     ffebld_constant_character3 (ffebld_conter (l)),
4833			    ffebld_constant_character3 (ffebld_conter (r)));
4834	  expr = ffebld_new_conter_with_orig
4835	    (ffebld_constant_new_logicaldefault (val), expr);
4836	  break;
4837#endif
4838
4839#if FFETARGET_okCHARACTER4
4840	case FFEINFO_kindtypeCHARACTER4:
4841	  error = ffetarget_eq_character4 (&val,
4842			     ffebld_constant_character4 (ffebld_conter (l)),
4843			    ffebld_constant_character4 (ffebld_conter (r)));
4844	  expr = ffebld_new_conter_with_orig
4845	    (ffebld_constant_new_logicaldefault (val), expr);
4846	  break;
4847#endif
4848
4849	default:
4850	  assert ("bad character kind type" == NULL);
4851	  break;
4852	}
4853      break;
4854
4855    default:
4856      assert ("bad type" == NULL);
4857      return expr;
4858    }
4859
4860  ffebld_set_info (expr, ffeinfo_new
4861		   (FFEINFO_basictypeLOGICAL,
4862		    FFEINFO_kindtypeLOGICALDEFAULT,
4863		    0,
4864		    FFEINFO_kindENTITY,
4865		    FFEINFO_whereCONSTANT,
4866		    FFETARGET_charactersizeNONE));
4867
4868  if ((error != FFEBAD)
4869      && ffebad_start (error))
4870    {
4871      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4872      ffebad_finish ();
4873    }
4874
4875  return expr;
4876}
4877
4878/* ffeexpr_collapse_ne -- Collapse ne expr
4879
4880   ffebld expr;
4881   ffelexToken token;
4882   expr = ffeexpr_collapse_ne(expr,token);
4883
4884   If the result of the expr is a constant, replaces the expr with the
4885   computed constant.  */
4886
4887ffebld
4888ffeexpr_collapse_ne (ffebld expr, ffelexToken t)
4889{
4890  ffebad error = FFEBAD;
4891  ffebld l;
4892  ffebld r;
4893  bool val;
4894
4895  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4896    return expr;
4897
4898  l = ffebld_left (expr);
4899  r = ffebld_right (expr);
4900
4901  if (ffebld_op (l) != FFEBLD_opCONTER)
4902    return expr;
4903  if (ffebld_op (r) != FFEBLD_opCONTER)
4904    return expr;
4905
4906  switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4907    {
4908    case FFEINFO_basictypeANY:
4909      return expr;
4910
4911    case FFEINFO_basictypeINTEGER:
4912      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4913	{
4914#if FFETARGET_okINTEGER1
4915	case FFEINFO_kindtypeINTEGER1:
4916	  error = ffetarget_ne_integer1 (&val,
4917			       ffebld_constant_integer1 (ffebld_conter (l)),
4918			      ffebld_constant_integer1 (ffebld_conter (r)));
4919	  expr = ffebld_new_conter_with_orig
4920	    (ffebld_constant_new_logicaldefault (val), expr);
4921	  break;
4922#endif
4923
4924#if FFETARGET_okINTEGER2
4925	case FFEINFO_kindtypeINTEGER2:
4926	  error = ffetarget_ne_integer2 (&val,
4927			       ffebld_constant_integer2 (ffebld_conter (l)),
4928			      ffebld_constant_integer2 (ffebld_conter (r)));
4929	  expr = ffebld_new_conter_with_orig
4930	    (ffebld_constant_new_logicaldefault (val), expr);
4931	  break;
4932#endif
4933
4934#if FFETARGET_okINTEGER3
4935	case FFEINFO_kindtypeINTEGER3:
4936	  error = ffetarget_ne_integer3 (&val,
4937			       ffebld_constant_integer3 (ffebld_conter (l)),
4938			      ffebld_constant_integer3 (ffebld_conter (r)));
4939	  expr = ffebld_new_conter_with_orig
4940	    (ffebld_constant_new_logicaldefault (val), expr);
4941	  break;
4942#endif
4943
4944#if FFETARGET_okINTEGER4
4945	case FFEINFO_kindtypeINTEGER4:
4946	  error = ffetarget_ne_integer4 (&val,
4947			       ffebld_constant_integer4 (ffebld_conter (l)),
4948			      ffebld_constant_integer4 (ffebld_conter (r)));
4949	  expr = ffebld_new_conter_with_orig
4950	    (ffebld_constant_new_logicaldefault (val), expr);
4951	  break;
4952#endif
4953
4954	default:
4955	  assert ("bad integer kind type" == NULL);
4956	  break;
4957	}
4958      break;
4959
4960    case FFEINFO_basictypeREAL:
4961      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4962	{
4963#if FFETARGET_okREAL1
4964	case FFEINFO_kindtypeREAL1:
4965	  error = ffetarget_ne_real1 (&val,
4966				  ffebld_constant_real1 (ffebld_conter (l)),
4967				 ffebld_constant_real1 (ffebld_conter (r)));
4968	  expr = ffebld_new_conter_with_orig
4969	    (ffebld_constant_new_logicaldefault (val), expr);
4970	  break;
4971#endif
4972
4973#if FFETARGET_okREAL2
4974	case FFEINFO_kindtypeREAL2:
4975	  error = ffetarget_ne_real2 (&val,
4976				  ffebld_constant_real2 (ffebld_conter (l)),
4977				 ffebld_constant_real2 (ffebld_conter (r)));
4978	  expr = ffebld_new_conter_with_orig
4979	    (ffebld_constant_new_logicaldefault (val), expr);
4980	  break;
4981#endif
4982
4983#if FFETARGET_okREAL3
4984	case FFEINFO_kindtypeREAL3:
4985	  error = ffetarget_ne_real3 (&val,
4986				  ffebld_constant_real3 (ffebld_conter (l)),
4987				 ffebld_constant_real3 (ffebld_conter (r)));
4988	  expr = ffebld_new_conter_with_orig
4989	    (ffebld_constant_new_logicaldefault (val), expr);
4990	  break;
4991#endif
4992
4993#if FFETARGET_okREAL4
4994	case FFEINFO_kindtypeREAL4:
4995	  error = ffetarget_ne_real4 (&val,
4996				  ffebld_constant_real4 (ffebld_conter (l)),
4997				 ffebld_constant_real4 (ffebld_conter (r)));
4998	  expr = ffebld_new_conter_with_orig
4999	    (ffebld_constant_new_logicaldefault (val), expr);
5000	  break;
5001#endif
5002
5003	default:
5004	  assert ("bad real kind type" == NULL);
5005	  break;
5006	}
5007      break;
5008
5009    case FFEINFO_basictypeCOMPLEX:
5010      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5011	{
5012#if FFETARGET_okCOMPLEX1
5013	case FFEINFO_kindtypeREAL1:
5014	  error = ffetarget_ne_complex1 (&val,
5015			       ffebld_constant_complex1 (ffebld_conter (l)),
5016			      ffebld_constant_complex1 (ffebld_conter (r)));
5017	  expr = ffebld_new_conter_with_orig
5018	    (ffebld_constant_new_logicaldefault (val), expr);
5019	  break;
5020#endif
5021
5022#if FFETARGET_okCOMPLEX2
5023	case FFEINFO_kindtypeREAL2:
5024	  error = ffetarget_ne_complex2 (&val,
5025			       ffebld_constant_complex2 (ffebld_conter (l)),
5026			      ffebld_constant_complex2 (ffebld_conter (r)));
5027	  expr = ffebld_new_conter_with_orig
5028	    (ffebld_constant_new_logicaldefault (val), expr);
5029	  break;
5030#endif
5031
5032#if FFETARGET_okCOMPLEX3
5033	case FFEINFO_kindtypeREAL3:
5034	  error = ffetarget_ne_complex3 (&val,
5035			       ffebld_constant_complex3 (ffebld_conter (l)),
5036			      ffebld_constant_complex3 (ffebld_conter (r)));
5037	  expr = ffebld_new_conter_with_orig
5038	    (ffebld_constant_new_logicaldefault (val), expr);
5039	  break;
5040#endif
5041
5042#if FFETARGET_okCOMPLEX4
5043	case FFEINFO_kindtypeREAL4:
5044	  error = ffetarget_ne_complex4 (&val,
5045			       ffebld_constant_complex4 (ffebld_conter (l)),
5046			      ffebld_constant_complex4 (ffebld_conter (r)));
5047	  expr = ffebld_new_conter_with_orig
5048	    (ffebld_constant_new_logicaldefault (val), expr);
5049	  break;
5050#endif
5051
5052	default:
5053	  assert ("bad complex kind type" == NULL);
5054	  break;
5055	}
5056      break;
5057
5058    case FFEINFO_basictypeCHARACTER:
5059      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5060	{
5061#if FFETARGET_okCHARACTER1
5062	case FFEINFO_kindtypeCHARACTER1:
5063	  error = ffetarget_ne_character1 (&val,
5064			     ffebld_constant_character1 (ffebld_conter (l)),
5065			    ffebld_constant_character1 (ffebld_conter (r)));
5066	  expr = ffebld_new_conter_with_orig
5067	    (ffebld_constant_new_logicaldefault (val), expr);
5068	  break;
5069#endif
5070
5071#if FFETARGET_okCHARACTER2
5072	case FFEINFO_kindtypeCHARACTER2:
5073	  error = ffetarget_ne_character2 (&val,
5074			     ffebld_constant_character2 (ffebld_conter (l)),
5075			    ffebld_constant_character2 (ffebld_conter (r)));
5076	  expr = ffebld_new_conter_with_orig
5077	    (ffebld_constant_new_logicaldefault (val), expr);
5078	  break;
5079#endif
5080
5081#if FFETARGET_okCHARACTER3
5082	case FFEINFO_kindtypeCHARACTER3:
5083	  error = ffetarget_ne_character3 (&val,
5084			     ffebld_constant_character3 (ffebld_conter (l)),
5085			    ffebld_constant_character3 (ffebld_conter (r)));
5086	  expr = ffebld_new_conter_with_orig
5087	    (ffebld_constant_new_logicaldefault (val), expr);
5088	  break;
5089#endif
5090
5091#if FFETARGET_okCHARACTER4
5092	case FFEINFO_kindtypeCHARACTER4:
5093	  error = ffetarget_ne_character4 (&val,
5094			     ffebld_constant_character4 (ffebld_conter (l)),
5095			    ffebld_constant_character4 (ffebld_conter (r)));
5096	  expr = ffebld_new_conter_with_orig
5097	    (ffebld_constant_new_logicaldefault (val), expr);
5098	  break;
5099#endif
5100
5101	default:
5102	  assert ("bad character kind type" == NULL);
5103	  break;
5104	}
5105      break;
5106
5107    default:
5108      assert ("bad type" == NULL);
5109      return expr;
5110    }
5111
5112  ffebld_set_info (expr, ffeinfo_new
5113		   (FFEINFO_basictypeLOGICAL,
5114		    FFEINFO_kindtypeLOGICALDEFAULT,
5115		    0,
5116		    FFEINFO_kindENTITY,
5117		    FFEINFO_whereCONSTANT,
5118		    FFETARGET_charactersizeNONE));
5119
5120  if ((error != FFEBAD)
5121      && ffebad_start (error))
5122    {
5123      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5124      ffebad_finish ();
5125    }
5126
5127  return expr;
5128}
5129
5130/* ffeexpr_collapse_ge -- Collapse ge expr
5131
5132   ffebld expr;
5133   ffelexToken token;
5134   expr = ffeexpr_collapse_ge(expr,token);
5135
5136   If the result of the expr is a constant, replaces the expr with the
5137   computed constant.  */
5138
5139ffebld
5140ffeexpr_collapse_ge (ffebld expr, ffelexToken t)
5141{
5142  ffebad error = FFEBAD;
5143  ffebld l;
5144  ffebld r;
5145  bool val;
5146
5147  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5148    return expr;
5149
5150  l = ffebld_left (expr);
5151  r = ffebld_right (expr);
5152
5153  if (ffebld_op (l) != FFEBLD_opCONTER)
5154    return expr;
5155  if (ffebld_op (r) != FFEBLD_opCONTER)
5156    return expr;
5157
5158  switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5159    {
5160    case FFEINFO_basictypeANY:
5161      return expr;
5162
5163    case FFEINFO_basictypeINTEGER:
5164      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5165	{
5166#if FFETARGET_okINTEGER1
5167	case FFEINFO_kindtypeINTEGER1:
5168	  error = ffetarget_ge_integer1 (&val,
5169			       ffebld_constant_integer1 (ffebld_conter (l)),
5170			      ffebld_constant_integer1 (ffebld_conter (r)));
5171	  expr = ffebld_new_conter_with_orig
5172	    (ffebld_constant_new_logicaldefault (val), expr);
5173	  break;
5174#endif
5175
5176#if FFETARGET_okINTEGER2
5177	case FFEINFO_kindtypeINTEGER2:
5178	  error = ffetarget_ge_integer2 (&val,
5179			       ffebld_constant_integer2 (ffebld_conter (l)),
5180			      ffebld_constant_integer2 (ffebld_conter (r)));
5181	  expr = ffebld_new_conter_with_orig
5182	    (ffebld_constant_new_logicaldefault (val), expr);
5183	  break;
5184#endif
5185
5186#if FFETARGET_okINTEGER3
5187	case FFEINFO_kindtypeINTEGER3:
5188	  error = ffetarget_ge_integer3 (&val,
5189			       ffebld_constant_integer3 (ffebld_conter (l)),
5190			      ffebld_constant_integer3 (ffebld_conter (r)));
5191	  expr = ffebld_new_conter_with_orig
5192	    (ffebld_constant_new_logicaldefault (val), expr);
5193	  break;
5194#endif
5195
5196#if FFETARGET_okINTEGER4
5197	case FFEINFO_kindtypeINTEGER4:
5198	  error = ffetarget_ge_integer4 (&val,
5199			       ffebld_constant_integer4 (ffebld_conter (l)),
5200			      ffebld_constant_integer4 (ffebld_conter (r)));
5201	  expr = ffebld_new_conter_with_orig
5202	    (ffebld_constant_new_logicaldefault (val), expr);
5203	  break;
5204#endif
5205
5206	default:
5207	  assert ("bad integer kind type" == NULL);
5208	  break;
5209	}
5210      break;
5211
5212    case FFEINFO_basictypeREAL:
5213      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5214	{
5215#if FFETARGET_okREAL1
5216	case FFEINFO_kindtypeREAL1:
5217	  error = ffetarget_ge_real1 (&val,
5218				  ffebld_constant_real1 (ffebld_conter (l)),
5219				 ffebld_constant_real1 (ffebld_conter (r)));
5220	  expr = ffebld_new_conter_with_orig
5221	    (ffebld_constant_new_logicaldefault (val), expr);
5222	  break;
5223#endif
5224
5225#if FFETARGET_okREAL2
5226	case FFEINFO_kindtypeREAL2:
5227	  error = ffetarget_ge_real2 (&val,
5228				  ffebld_constant_real2 (ffebld_conter (l)),
5229				 ffebld_constant_real2 (ffebld_conter (r)));
5230	  expr = ffebld_new_conter_with_orig
5231	    (ffebld_constant_new_logicaldefault (val), expr);
5232	  break;
5233#endif
5234
5235#if FFETARGET_okREAL3
5236	case FFEINFO_kindtypeREAL3:
5237	  error = ffetarget_ge_real3 (&val,
5238				  ffebld_constant_real3 (ffebld_conter (l)),
5239				 ffebld_constant_real3 (ffebld_conter (r)));
5240	  expr = ffebld_new_conter_with_orig
5241	    (ffebld_constant_new_logicaldefault (val), expr);
5242	  break;
5243#endif
5244
5245#if FFETARGET_okREAL4
5246	case FFEINFO_kindtypeREAL4:
5247	  error = ffetarget_ge_real4 (&val,
5248				  ffebld_constant_real4 (ffebld_conter (l)),
5249				 ffebld_constant_real4 (ffebld_conter (r)));
5250	  expr = ffebld_new_conter_with_orig
5251	    (ffebld_constant_new_logicaldefault (val), expr);
5252	  break;
5253#endif
5254
5255	default:
5256	  assert ("bad real kind type" == NULL);
5257	  break;
5258	}
5259      break;
5260
5261    case FFEINFO_basictypeCHARACTER:
5262      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5263	{
5264#if FFETARGET_okCHARACTER1
5265	case FFEINFO_kindtypeCHARACTER1:
5266	  error = ffetarget_ge_character1 (&val,
5267			     ffebld_constant_character1 (ffebld_conter (l)),
5268			    ffebld_constant_character1 (ffebld_conter (r)));
5269	  expr = ffebld_new_conter_with_orig
5270	    (ffebld_constant_new_logicaldefault (val), expr);
5271	  break;
5272#endif
5273
5274#if FFETARGET_okCHARACTER2
5275	case FFEINFO_kindtypeCHARACTER2:
5276	  error = ffetarget_ge_character2 (&val,
5277			     ffebld_constant_character2 (ffebld_conter (l)),
5278			    ffebld_constant_character2 (ffebld_conter (r)));
5279	  expr = ffebld_new_conter_with_orig
5280	    (ffebld_constant_new_logicaldefault (val), expr);
5281	  break;
5282#endif
5283
5284#if FFETARGET_okCHARACTER3
5285	case FFEINFO_kindtypeCHARACTER3:
5286	  error = ffetarget_ge_character3 (&val,
5287			     ffebld_constant_character3 (ffebld_conter (l)),
5288			    ffebld_constant_character3 (ffebld_conter (r)));
5289	  expr = ffebld_new_conter_with_orig
5290	    (ffebld_constant_new_logicaldefault (val), expr);
5291	  break;
5292#endif
5293
5294#if FFETARGET_okCHARACTER4
5295	case FFEINFO_kindtypeCHARACTER4:
5296	  error = ffetarget_ge_character4 (&val,
5297			     ffebld_constant_character4 (ffebld_conter (l)),
5298			    ffebld_constant_character4 (ffebld_conter (r)));
5299	  expr = ffebld_new_conter_with_orig
5300	    (ffebld_constant_new_logicaldefault (val), expr);
5301	  break;
5302#endif
5303
5304	default:
5305	  assert ("bad character kind type" == NULL);
5306	  break;
5307	}
5308      break;
5309
5310    default:
5311      assert ("bad type" == NULL);
5312      return expr;
5313    }
5314
5315  ffebld_set_info (expr, ffeinfo_new
5316		   (FFEINFO_basictypeLOGICAL,
5317		    FFEINFO_kindtypeLOGICALDEFAULT,
5318		    0,
5319		    FFEINFO_kindENTITY,
5320		    FFEINFO_whereCONSTANT,
5321		    FFETARGET_charactersizeNONE));
5322
5323  if ((error != FFEBAD)
5324      && ffebad_start (error))
5325    {
5326      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5327      ffebad_finish ();
5328    }
5329
5330  return expr;
5331}
5332
5333/* ffeexpr_collapse_gt -- Collapse gt expr
5334
5335   ffebld expr;
5336   ffelexToken token;
5337   expr = ffeexpr_collapse_gt(expr,token);
5338
5339   If the result of the expr is a constant, replaces the expr with the
5340   computed constant.  */
5341
5342ffebld
5343ffeexpr_collapse_gt (ffebld expr, ffelexToken t)
5344{
5345  ffebad error = FFEBAD;
5346  ffebld l;
5347  ffebld r;
5348  bool val;
5349
5350  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5351    return expr;
5352
5353  l = ffebld_left (expr);
5354  r = ffebld_right (expr);
5355
5356  if (ffebld_op (l) != FFEBLD_opCONTER)
5357    return expr;
5358  if (ffebld_op (r) != FFEBLD_opCONTER)
5359    return expr;
5360
5361  switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5362    {
5363    case FFEINFO_basictypeANY:
5364      return expr;
5365
5366    case FFEINFO_basictypeINTEGER:
5367      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5368	{
5369#if FFETARGET_okINTEGER1
5370	case FFEINFO_kindtypeINTEGER1:
5371	  error = ffetarget_gt_integer1 (&val,
5372			       ffebld_constant_integer1 (ffebld_conter (l)),
5373			      ffebld_constant_integer1 (ffebld_conter (r)));
5374	  expr = ffebld_new_conter_with_orig
5375	    (ffebld_constant_new_logicaldefault (val), expr);
5376	  break;
5377#endif
5378
5379#if FFETARGET_okINTEGER2
5380	case FFEINFO_kindtypeINTEGER2:
5381	  error = ffetarget_gt_integer2 (&val,
5382			       ffebld_constant_integer2 (ffebld_conter (l)),
5383			      ffebld_constant_integer2 (ffebld_conter (r)));
5384	  expr = ffebld_new_conter_with_orig
5385	    (ffebld_constant_new_logicaldefault (val), expr);
5386	  break;
5387#endif
5388
5389#if FFETARGET_okINTEGER3
5390	case FFEINFO_kindtypeINTEGER3:
5391	  error = ffetarget_gt_integer3 (&val,
5392			       ffebld_constant_integer3 (ffebld_conter (l)),
5393			      ffebld_constant_integer3 (ffebld_conter (r)));
5394	  expr = ffebld_new_conter_with_orig
5395	    (ffebld_constant_new_logicaldefault (val), expr);
5396	  break;
5397#endif
5398
5399#if FFETARGET_okINTEGER4
5400	case FFEINFO_kindtypeINTEGER4:
5401	  error = ffetarget_gt_integer4 (&val,
5402			       ffebld_constant_integer4 (ffebld_conter (l)),
5403			      ffebld_constant_integer4 (ffebld_conter (r)));
5404	  expr = ffebld_new_conter_with_orig
5405	    (ffebld_constant_new_logicaldefault (val), expr);
5406	  break;
5407#endif
5408
5409	default:
5410	  assert ("bad integer kind type" == NULL);
5411	  break;
5412	}
5413      break;
5414
5415    case FFEINFO_basictypeREAL:
5416      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5417	{
5418#if FFETARGET_okREAL1
5419	case FFEINFO_kindtypeREAL1:
5420	  error = ffetarget_gt_real1 (&val,
5421				  ffebld_constant_real1 (ffebld_conter (l)),
5422				 ffebld_constant_real1 (ffebld_conter (r)));
5423	  expr = ffebld_new_conter_with_orig
5424	    (ffebld_constant_new_logicaldefault (val), expr);
5425	  break;
5426#endif
5427
5428#if FFETARGET_okREAL2
5429	case FFEINFO_kindtypeREAL2:
5430	  error = ffetarget_gt_real2 (&val,
5431				  ffebld_constant_real2 (ffebld_conter (l)),
5432				 ffebld_constant_real2 (ffebld_conter (r)));
5433	  expr = ffebld_new_conter_with_orig
5434	    (ffebld_constant_new_logicaldefault (val), expr);
5435	  break;
5436#endif
5437
5438#if FFETARGET_okREAL3
5439	case FFEINFO_kindtypeREAL3:
5440	  error = ffetarget_gt_real3 (&val,
5441				  ffebld_constant_real3 (ffebld_conter (l)),
5442				 ffebld_constant_real3 (ffebld_conter (r)));
5443	  expr = ffebld_new_conter_with_orig
5444	    (ffebld_constant_new_logicaldefault (val), expr);
5445	  break;
5446#endif
5447
5448#if FFETARGET_okREAL4
5449	case FFEINFO_kindtypeREAL4:
5450	  error = ffetarget_gt_real4 (&val,
5451				  ffebld_constant_real4 (ffebld_conter (l)),
5452				 ffebld_constant_real4 (ffebld_conter (r)));
5453	  expr = ffebld_new_conter_with_orig
5454	    (ffebld_constant_new_logicaldefault (val), expr);
5455	  break;
5456#endif
5457
5458	default:
5459	  assert ("bad real kind type" == NULL);
5460	  break;
5461	}
5462      break;
5463
5464    case FFEINFO_basictypeCHARACTER:
5465      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5466	{
5467#if FFETARGET_okCHARACTER1
5468	case FFEINFO_kindtypeCHARACTER1:
5469	  error = ffetarget_gt_character1 (&val,
5470			     ffebld_constant_character1 (ffebld_conter (l)),
5471			    ffebld_constant_character1 (ffebld_conter (r)));
5472	  expr = ffebld_new_conter_with_orig
5473	    (ffebld_constant_new_logicaldefault (val), expr);
5474	  break;
5475#endif
5476
5477#if FFETARGET_okCHARACTER2
5478	case FFEINFO_kindtypeCHARACTER2:
5479	  error = ffetarget_gt_character2 (&val,
5480			     ffebld_constant_character2 (ffebld_conter (l)),
5481			    ffebld_constant_character2 (ffebld_conter (r)));
5482	  expr = ffebld_new_conter_with_orig
5483	    (ffebld_constant_new_logicaldefault (val), expr);
5484	  break;
5485#endif
5486
5487#if FFETARGET_okCHARACTER3
5488	case FFEINFO_kindtypeCHARACTER3:
5489	  error = ffetarget_gt_character3 (&val,
5490			     ffebld_constant_character3 (ffebld_conter (l)),
5491			    ffebld_constant_character3 (ffebld_conter (r)));
5492	  expr = ffebld_new_conter_with_orig
5493	    (ffebld_constant_new_logicaldefault (val), expr);
5494	  break;
5495#endif
5496
5497#if FFETARGET_okCHARACTER4
5498	case FFEINFO_kindtypeCHARACTER4:
5499	  error = ffetarget_gt_character4 (&val,
5500			     ffebld_constant_character4 (ffebld_conter (l)),
5501			    ffebld_constant_character4 (ffebld_conter (r)));
5502	  expr = ffebld_new_conter_with_orig
5503	    (ffebld_constant_new_logicaldefault (val), expr);
5504	  break;
5505#endif
5506
5507	default:
5508	  assert ("bad character kind type" == NULL);
5509	  break;
5510	}
5511      break;
5512
5513    default:
5514      assert ("bad type" == NULL);
5515      return expr;
5516    }
5517
5518  ffebld_set_info (expr, ffeinfo_new
5519		   (FFEINFO_basictypeLOGICAL,
5520		    FFEINFO_kindtypeLOGICALDEFAULT,
5521		    0,
5522		    FFEINFO_kindENTITY,
5523		    FFEINFO_whereCONSTANT,
5524		    FFETARGET_charactersizeNONE));
5525
5526  if ((error != FFEBAD)
5527      && ffebad_start (error))
5528    {
5529      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5530      ffebad_finish ();
5531    }
5532
5533  return expr;
5534}
5535
5536/* ffeexpr_collapse_le -- Collapse le expr
5537
5538   ffebld expr;
5539   ffelexToken token;
5540   expr = ffeexpr_collapse_le(expr,token);
5541
5542   If the result of the expr is a constant, replaces the expr with the
5543   computed constant.  */
5544
5545ffebld
5546ffeexpr_collapse_le (ffebld expr, ffelexToken t)
5547{
5548  ffebad error = FFEBAD;
5549  ffebld l;
5550  ffebld r;
5551  bool val;
5552
5553  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5554    return expr;
5555
5556  l = ffebld_left (expr);
5557  r = ffebld_right (expr);
5558
5559  if (ffebld_op (l) != FFEBLD_opCONTER)
5560    return expr;
5561  if (ffebld_op (r) != FFEBLD_opCONTER)
5562    return expr;
5563
5564  switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5565    {
5566    case FFEINFO_basictypeANY:
5567      return expr;
5568
5569    case FFEINFO_basictypeINTEGER:
5570      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5571	{
5572#if FFETARGET_okINTEGER1
5573	case FFEINFO_kindtypeINTEGER1:
5574	  error = ffetarget_le_integer1 (&val,
5575			       ffebld_constant_integer1 (ffebld_conter (l)),
5576			      ffebld_constant_integer1 (ffebld_conter (r)));
5577	  expr = ffebld_new_conter_with_orig
5578	    (ffebld_constant_new_logicaldefault (val), expr);
5579	  break;
5580#endif
5581
5582#if FFETARGET_okINTEGER2
5583	case FFEINFO_kindtypeINTEGER2:
5584	  error = ffetarget_le_integer2 (&val,
5585			       ffebld_constant_integer2 (ffebld_conter (l)),
5586			      ffebld_constant_integer2 (ffebld_conter (r)));
5587	  expr = ffebld_new_conter_with_orig
5588	    (ffebld_constant_new_logicaldefault (val), expr);
5589	  break;
5590#endif
5591
5592#if FFETARGET_okINTEGER3
5593	case FFEINFO_kindtypeINTEGER3:
5594	  error = ffetarget_le_integer3 (&val,
5595			       ffebld_constant_integer3 (ffebld_conter (l)),
5596			      ffebld_constant_integer3 (ffebld_conter (r)));
5597	  expr = ffebld_new_conter_with_orig
5598	    (ffebld_constant_new_logicaldefault (val), expr);
5599	  break;
5600#endif
5601
5602#if FFETARGET_okINTEGER4
5603	case FFEINFO_kindtypeINTEGER4:
5604	  error = ffetarget_le_integer4 (&val,
5605			       ffebld_constant_integer4 (ffebld_conter (l)),
5606			      ffebld_constant_integer4 (ffebld_conter (r)));
5607	  expr = ffebld_new_conter_with_orig
5608	    (ffebld_constant_new_logicaldefault (val), expr);
5609	  break;
5610#endif
5611
5612	default:
5613	  assert ("bad integer kind type" == NULL);
5614	  break;
5615	}
5616      break;
5617
5618    case FFEINFO_basictypeREAL:
5619      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5620	{
5621#if FFETARGET_okREAL1
5622	case FFEINFO_kindtypeREAL1:
5623	  error = ffetarget_le_real1 (&val,
5624				  ffebld_constant_real1 (ffebld_conter (l)),
5625				 ffebld_constant_real1 (ffebld_conter (r)));
5626	  expr = ffebld_new_conter_with_orig
5627	    (ffebld_constant_new_logicaldefault (val), expr);
5628	  break;
5629#endif
5630
5631#if FFETARGET_okREAL2
5632	case FFEINFO_kindtypeREAL2:
5633	  error = ffetarget_le_real2 (&val,
5634				  ffebld_constant_real2 (ffebld_conter (l)),
5635				 ffebld_constant_real2 (ffebld_conter (r)));
5636	  expr = ffebld_new_conter_with_orig
5637	    (ffebld_constant_new_logicaldefault (val), expr);
5638	  break;
5639#endif
5640
5641#if FFETARGET_okREAL3
5642	case FFEINFO_kindtypeREAL3:
5643	  error = ffetarget_le_real3 (&val,
5644				  ffebld_constant_real3 (ffebld_conter (l)),
5645				 ffebld_constant_real3 (ffebld_conter (r)));
5646	  expr = ffebld_new_conter_with_orig
5647	    (ffebld_constant_new_logicaldefault (val), expr);
5648	  break;
5649#endif
5650
5651#if FFETARGET_okREAL4
5652	case FFEINFO_kindtypeREAL4:
5653	  error = ffetarget_le_real4 (&val,
5654				  ffebld_constant_real4 (ffebld_conter (l)),
5655				 ffebld_constant_real4 (ffebld_conter (r)));
5656	  expr = ffebld_new_conter_with_orig
5657	    (ffebld_constant_new_logicaldefault (val), expr);
5658	  break;
5659#endif
5660
5661	default:
5662	  assert ("bad real kind type" == NULL);
5663	  break;
5664	}
5665      break;
5666
5667    case FFEINFO_basictypeCHARACTER:
5668      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5669	{
5670#if FFETARGET_okCHARACTER1
5671	case FFEINFO_kindtypeCHARACTER1:
5672	  error = ffetarget_le_character1 (&val,
5673			     ffebld_constant_character1 (ffebld_conter (l)),
5674			    ffebld_constant_character1 (ffebld_conter (r)));
5675	  expr = ffebld_new_conter_with_orig
5676	    (ffebld_constant_new_logicaldefault (val), expr);
5677	  break;
5678#endif
5679
5680#if FFETARGET_okCHARACTER2
5681	case FFEINFO_kindtypeCHARACTER2:
5682	  error = ffetarget_le_character2 (&val,
5683			     ffebld_constant_character2 (ffebld_conter (l)),
5684			    ffebld_constant_character2 (ffebld_conter (r)));
5685	  expr = ffebld_new_conter_with_orig
5686	    (ffebld_constant_new_logicaldefault (val), expr);
5687	  break;
5688#endif
5689
5690#if FFETARGET_okCHARACTER3
5691	case FFEINFO_kindtypeCHARACTER3:
5692	  error = ffetarget_le_character3 (&val,
5693			     ffebld_constant_character3 (ffebld_conter (l)),
5694			    ffebld_constant_character3 (ffebld_conter (r)));
5695	  expr = ffebld_new_conter_with_orig
5696	    (ffebld_constant_new_logicaldefault (val), expr);
5697	  break;
5698#endif
5699
5700#if FFETARGET_okCHARACTER4
5701	case FFEINFO_kindtypeCHARACTER4:
5702	  error = ffetarget_le_character4 (&val,
5703			     ffebld_constant_character4 (ffebld_conter (l)),
5704			    ffebld_constant_character4 (ffebld_conter (r)));
5705	  expr = ffebld_new_conter_with_orig
5706	    (ffebld_constant_new_logicaldefault (val), expr);
5707	  break;
5708#endif
5709
5710	default:
5711	  assert ("bad character kind type" == NULL);
5712	  break;
5713	}
5714      break;
5715
5716    default:
5717      assert ("bad type" == NULL);
5718      return expr;
5719    }
5720
5721  ffebld_set_info (expr, ffeinfo_new
5722		   (FFEINFO_basictypeLOGICAL,
5723		    FFEINFO_kindtypeLOGICALDEFAULT,
5724		    0,
5725		    FFEINFO_kindENTITY,
5726		    FFEINFO_whereCONSTANT,
5727		    FFETARGET_charactersizeNONE));
5728
5729  if ((error != FFEBAD)
5730      && ffebad_start (error))
5731    {
5732      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5733      ffebad_finish ();
5734    }
5735
5736  return expr;
5737}
5738
5739/* ffeexpr_collapse_lt -- Collapse lt expr
5740
5741   ffebld expr;
5742   ffelexToken token;
5743   expr = ffeexpr_collapse_lt(expr,token);
5744
5745   If the result of the expr is a constant, replaces the expr with the
5746   computed constant.  */
5747
5748ffebld
5749ffeexpr_collapse_lt (ffebld expr, ffelexToken t)
5750{
5751  ffebad error = FFEBAD;
5752  ffebld l;
5753  ffebld r;
5754  bool val;
5755
5756  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5757    return expr;
5758
5759  l = ffebld_left (expr);
5760  r = ffebld_right (expr);
5761
5762  if (ffebld_op (l) != FFEBLD_opCONTER)
5763    return expr;
5764  if (ffebld_op (r) != FFEBLD_opCONTER)
5765    return expr;
5766
5767  switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5768    {
5769    case FFEINFO_basictypeANY:
5770      return expr;
5771
5772    case FFEINFO_basictypeINTEGER:
5773      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5774	{
5775#if FFETARGET_okINTEGER1
5776	case FFEINFO_kindtypeINTEGER1:
5777	  error = ffetarget_lt_integer1 (&val,
5778			       ffebld_constant_integer1 (ffebld_conter (l)),
5779			      ffebld_constant_integer1 (ffebld_conter (r)));
5780	  expr = ffebld_new_conter_with_orig
5781	    (ffebld_constant_new_logicaldefault (val), expr);
5782	  break;
5783#endif
5784
5785#if FFETARGET_okINTEGER2
5786	case FFEINFO_kindtypeINTEGER2:
5787	  error = ffetarget_lt_integer2 (&val,
5788			       ffebld_constant_integer2 (ffebld_conter (l)),
5789			      ffebld_constant_integer2 (ffebld_conter (r)));
5790	  expr = ffebld_new_conter_with_orig
5791	    (ffebld_constant_new_logicaldefault (val), expr);
5792	  break;
5793#endif
5794
5795#if FFETARGET_okINTEGER3
5796	case FFEINFO_kindtypeINTEGER3:
5797	  error = ffetarget_lt_integer3 (&val,
5798			       ffebld_constant_integer3 (ffebld_conter (l)),
5799			      ffebld_constant_integer3 (ffebld_conter (r)));
5800	  expr = ffebld_new_conter_with_orig
5801	    (ffebld_constant_new_logicaldefault (val), expr);
5802	  break;
5803#endif
5804
5805#if FFETARGET_okINTEGER4
5806	case FFEINFO_kindtypeINTEGER4:
5807	  error = ffetarget_lt_integer4 (&val,
5808			       ffebld_constant_integer4 (ffebld_conter (l)),
5809			      ffebld_constant_integer4 (ffebld_conter (r)));
5810	  expr = ffebld_new_conter_with_orig
5811	    (ffebld_constant_new_logicaldefault (val), expr);
5812	  break;
5813#endif
5814
5815	default:
5816	  assert ("bad integer kind type" == NULL);
5817	  break;
5818	}
5819      break;
5820
5821    case FFEINFO_basictypeREAL:
5822      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5823	{
5824#if FFETARGET_okREAL1
5825	case FFEINFO_kindtypeREAL1:
5826	  error = ffetarget_lt_real1 (&val,
5827				  ffebld_constant_real1 (ffebld_conter (l)),
5828				 ffebld_constant_real1 (ffebld_conter (r)));
5829	  expr = ffebld_new_conter_with_orig
5830	    (ffebld_constant_new_logicaldefault (val), expr);
5831	  break;
5832#endif
5833
5834#if FFETARGET_okREAL2
5835	case FFEINFO_kindtypeREAL2:
5836	  error = ffetarget_lt_real2 (&val,
5837				  ffebld_constant_real2 (ffebld_conter (l)),
5838				 ffebld_constant_real2 (ffebld_conter (r)));
5839	  expr = ffebld_new_conter_with_orig
5840	    (ffebld_constant_new_logicaldefault (val), expr);
5841	  break;
5842#endif
5843
5844#if FFETARGET_okREAL3
5845	case FFEINFO_kindtypeREAL3:
5846	  error = ffetarget_lt_real3 (&val,
5847				  ffebld_constant_real3 (ffebld_conter (l)),
5848				 ffebld_constant_real3 (ffebld_conter (r)));
5849	  expr = ffebld_new_conter_with_orig
5850	    (ffebld_constant_new_logicaldefault (val), expr);
5851	  break;
5852#endif
5853
5854#if FFETARGET_okREAL4
5855	case FFEINFO_kindtypeREAL4:
5856	  error = ffetarget_lt_real4 (&val,
5857				  ffebld_constant_real4 (ffebld_conter (l)),
5858				 ffebld_constant_real4 (ffebld_conter (r)));
5859	  expr = ffebld_new_conter_with_orig
5860	    (ffebld_constant_new_logicaldefault (val), expr);
5861	  break;
5862#endif
5863
5864	default:
5865	  assert ("bad real kind type" == NULL);
5866	  break;
5867	}
5868      break;
5869
5870    case FFEINFO_basictypeCHARACTER:
5871      switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5872	{
5873#if FFETARGET_okCHARACTER1
5874	case FFEINFO_kindtypeCHARACTER1:
5875	  error = ffetarget_lt_character1 (&val,
5876			     ffebld_constant_character1 (ffebld_conter (l)),
5877			    ffebld_constant_character1 (ffebld_conter (r)));
5878	  expr = ffebld_new_conter_with_orig
5879	    (ffebld_constant_new_logicaldefault (val), expr);
5880	  break;
5881#endif
5882
5883#if FFETARGET_okCHARACTER2
5884	case FFEINFO_kindtypeCHARACTER2:
5885	  error = ffetarget_lt_character2 (&val,
5886			     ffebld_constant_character2 (ffebld_conter (l)),
5887			    ffebld_constant_character2 (ffebld_conter (r)));
5888	  expr = ffebld_new_conter_with_orig
5889	    (ffebld_constant_new_logicaldefault (val), expr);
5890	  break;
5891#endif
5892
5893#if FFETARGET_okCHARACTER3
5894	case FFEINFO_kindtypeCHARACTER3:
5895	  error = ffetarget_lt_character3 (&val,
5896			     ffebld_constant_character3 (ffebld_conter (l)),
5897			    ffebld_constant_character3 (ffebld_conter (r)));
5898	  expr = ffebld_new_conter_with_orig
5899	    (ffebld_constant_new_logicaldefault (val), expr);
5900	  break;
5901#endif
5902
5903#if FFETARGET_okCHARACTER4
5904	case FFEINFO_kindtypeCHARACTER4:
5905	  error = ffetarget_lt_character4 (&val,
5906			     ffebld_constant_character4 (ffebld_conter (l)),
5907			    ffebld_constant_character4 (ffebld_conter (r)));
5908	  expr = ffebld_new_conter_with_orig
5909	    (ffebld_constant_new_logicaldefault (val), expr);
5910	  break;
5911#endif
5912
5913	default:
5914	  assert ("bad character kind type" == NULL);
5915	  break;
5916	}
5917      break;
5918
5919    default:
5920      assert ("bad type" == NULL);
5921      return expr;
5922    }
5923
5924  ffebld_set_info (expr, ffeinfo_new
5925		   (FFEINFO_basictypeLOGICAL,
5926		    FFEINFO_kindtypeLOGICALDEFAULT,
5927		    0,
5928		    FFEINFO_kindENTITY,
5929		    FFEINFO_whereCONSTANT,
5930		    FFETARGET_charactersizeNONE));
5931
5932  if ((error != FFEBAD)
5933      && ffebad_start (error))
5934    {
5935      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5936      ffebad_finish ();
5937    }
5938
5939  return expr;
5940}
5941
5942/* ffeexpr_collapse_and -- Collapse and expr
5943
5944   ffebld expr;
5945   ffelexToken token;
5946   expr = ffeexpr_collapse_and(expr,token);
5947
5948   If the result of the expr is a constant, replaces the expr with the
5949   computed constant.  */
5950
5951ffebld
5952ffeexpr_collapse_and (ffebld expr, ffelexToken t)
5953{
5954  ffebad error = FFEBAD;
5955  ffebld l;
5956  ffebld r;
5957  ffebldConstantUnion u;
5958  ffeinfoBasictype bt;
5959  ffeinfoKindtype kt;
5960
5961  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5962    return expr;
5963
5964  l = ffebld_left (expr);
5965  r = ffebld_right (expr);
5966
5967  if (ffebld_op (l) != FFEBLD_opCONTER)
5968    return expr;
5969  if (ffebld_op (r) != FFEBLD_opCONTER)
5970    return expr;
5971
5972  switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5973    {
5974    case FFEINFO_basictypeANY:
5975      return expr;
5976
5977    case FFEINFO_basictypeINTEGER:
5978      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5979	{
5980#if FFETARGET_okINTEGER1
5981	case FFEINFO_kindtypeINTEGER1:
5982	  error = ffetarget_and_integer1 (ffebld_cu_ptr_integer1 (u),
5983			       ffebld_constant_integer1 (ffebld_conter (l)),
5984			      ffebld_constant_integer1 (ffebld_conter (r)));
5985	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5986					(ffebld_cu_val_integer1 (u)), expr);
5987	  break;
5988#endif
5989
5990#if FFETARGET_okINTEGER2
5991	case FFEINFO_kindtypeINTEGER2:
5992	  error = ffetarget_and_integer2 (ffebld_cu_ptr_integer2 (u),
5993			       ffebld_constant_integer2 (ffebld_conter (l)),
5994			      ffebld_constant_integer2 (ffebld_conter (r)));
5995	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5996					(ffebld_cu_val_integer2 (u)), expr);
5997	  break;
5998#endif
5999
6000#if FFETARGET_okINTEGER3
6001	case FFEINFO_kindtypeINTEGER3:
6002	  error = ffetarget_and_integer3 (ffebld_cu_ptr_integer3 (u),
6003			       ffebld_constant_integer3 (ffebld_conter (l)),
6004			      ffebld_constant_integer3 (ffebld_conter (r)));
6005	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6006					(ffebld_cu_val_integer3 (u)), expr);
6007	  break;
6008#endif
6009
6010#if FFETARGET_okINTEGER4
6011	case FFEINFO_kindtypeINTEGER4:
6012	  error = ffetarget_and_integer4 (ffebld_cu_ptr_integer4 (u),
6013			       ffebld_constant_integer4 (ffebld_conter (l)),
6014			      ffebld_constant_integer4 (ffebld_conter (r)));
6015	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6016					(ffebld_cu_val_integer4 (u)), expr);
6017	  break;
6018#endif
6019
6020	default:
6021	  assert ("bad integer kind type" == NULL);
6022	  break;
6023	}
6024      break;
6025
6026    case FFEINFO_basictypeLOGICAL:
6027      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6028	{
6029#if FFETARGET_okLOGICAL1
6030	case FFEINFO_kindtypeLOGICAL1:
6031	  error = ffetarget_and_logical1 (ffebld_cu_ptr_logical1 (u),
6032			       ffebld_constant_logical1 (ffebld_conter (l)),
6033			      ffebld_constant_logical1 (ffebld_conter (r)));
6034	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6035					(ffebld_cu_val_logical1 (u)), expr);
6036	  break;
6037#endif
6038
6039#if FFETARGET_okLOGICAL2
6040	case FFEINFO_kindtypeLOGICAL2:
6041	  error = ffetarget_and_logical2 (ffebld_cu_ptr_logical2 (u),
6042			       ffebld_constant_logical2 (ffebld_conter (l)),
6043			      ffebld_constant_logical2 (ffebld_conter (r)));
6044	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6045					(ffebld_cu_val_logical2 (u)), expr);
6046	  break;
6047#endif
6048
6049#if FFETARGET_okLOGICAL3
6050	case FFEINFO_kindtypeLOGICAL3:
6051	  error = ffetarget_and_logical3 (ffebld_cu_ptr_logical3 (u),
6052			       ffebld_constant_logical3 (ffebld_conter (l)),
6053			      ffebld_constant_logical3 (ffebld_conter (r)));
6054	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6055					(ffebld_cu_val_logical3 (u)), expr);
6056	  break;
6057#endif
6058
6059#if FFETARGET_okLOGICAL4
6060	case FFEINFO_kindtypeLOGICAL4:
6061	  error = ffetarget_and_logical4 (ffebld_cu_ptr_logical4 (u),
6062			       ffebld_constant_logical4 (ffebld_conter (l)),
6063			      ffebld_constant_logical4 (ffebld_conter (r)));
6064	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6065					(ffebld_cu_val_logical4 (u)), expr);
6066	  break;
6067#endif
6068
6069	default:
6070	  assert ("bad logical kind type" == NULL);
6071	  break;
6072	}
6073      break;
6074
6075    default:
6076      assert ("bad type" == NULL);
6077      return expr;
6078    }
6079
6080  ffebld_set_info (expr, ffeinfo_new
6081		   (bt,
6082		    kt,
6083		    0,
6084		    FFEINFO_kindENTITY,
6085		    FFEINFO_whereCONSTANT,
6086		    FFETARGET_charactersizeNONE));
6087
6088  if ((error != FFEBAD)
6089      && ffebad_start (error))
6090    {
6091      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6092      ffebad_finish ();
6093    }
6094
6095  return expr;
6096}
6097
6098/* ffeexpr_collapse_or -- Collapse or expr
6099
6100   ffebld expr;
6101   ffelexToken token;
6102   expr = ffeexpr_collapse_or(expr,token);
6103
6104   If the result of the expr is a constant, replaces the expr with the
6105   computed constant.  */
6106
6107ffebld
6108ffeexpr_collapse_or (ffebld expr, ffelexToken t)
6109{
6110  ffebad error = FFEBAD;
6111  ffebld l;
6112  ffebld r;
6113  ffebldConstantUnion u;
6114  ffeinfoBasictype bt;
6115  ffeinfoKindtype kt;
6116
6117  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6118    return expr;
6119
6120  l = ffebld_left (expr);
6121  r = ffebld_right (expr);
6122
6123  if (ffebld_op (l) != FFEBLD_opCONTER)
6124    return expr;
6125  if (ffebld_op (r) != FFEBLD_opCONTER)
6126    return expr;
6127
6128  switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6129    {
6130    case FFEINFO_basictypeANY:
6131      return expr;
6132
6133    case FFEINFO_basictypeINTEGER:
6134      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6135	{
6136#if FFETARGET_okINTEGER1
6137	case FFEINFO_kindtypeINTEGER1:
6138	  error = ffetarget_or_integer1 (ffebld_cu_ptr_integer1 (u),
6139			       ffebld_constant_integer1 (ffebld_conter (l)),
6140			      ffebld_constant_integer1 (ffebld_conter (r)));
6141	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6142					(ffebld_cu_val_integer1 (u)), expr);
6143	  break;
6144#endif
6145
6146#if FFETARGET_okINTEGER2
6147	case FFEINFO_kindtypeINTEGER2:
6148	  error = ffetarget_or_integer2 (ffebld_cu_ptr_integer2 (u),
6149			       ffebld_constant_integer2 (ffebld_conter (l)),
6150			      ffebld_constant_integer2 (ffebld_conter (r)));
6151	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6152					(ffebld_cu_val_integer2 (u)), expr);
6153	  break;
6154#endif
6155
6156#if FFETARGET_okINTEGER3
6157	case FFEINFO_kindtypeINTEGER3:
6158	  error = ffetarget_or_integer3 (ffebld_cu_ptr_integer3 (u),
6159			       ffebld_constant_integer3 (ffebld_conter (l)),
6160			      ffebld_constant_integer3 (ffebld_conter (r)));
6161	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6162					(ffebld_cu_val_integer3 (u)), expr);
6163	  break;
6164#endif
6165
6166#if FFETARGET_okINTEGER4
6167	case FFEINFO_kindtypeINTEGER4:
6168	  error = ffetarget_or_integer4 (ffebld_cu_ptr_integer4 (u),
6169			       ffebld_constant_integer4 (ffebld_conter (l)),
6170			      ffebld_constant_integer4 (ffebld_conter (r)));
6171	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6172					(ffebld_cu_val_integer4 (u)), expr);
6173	  break;
6174#endif
6175
6176	default:
6177	  assert ("bad integer kind type" == NULL);
6178	  break;
6179	}
6180      break;
6181
6182    case FFEINFO_basictypeLOGICAL:
6183      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6184	{
6185#if FFETARGET_okLOGICAL1
6186	case FFEINFO_kindtypeLOGICAL1:
6187	  error = ffetarget_or_logical1 (ffebld_cu_ptr_logical1 (u),
6188			       ffebld_constant_logical1 (ffebld_conter (l)),
6189			      ffebld_constant_logical1 (ffebld_conter (r)));
6190	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6191					(ffebld_cu_val_logical1 (u)), expr);
6192	  break;
6193#endif
6194
6195#if FFETARGET_okLOGICAL2
6196	case FFEINFO_kindtypeLOGICAL2:
6197	  error = ffetarget_or_logical2 (ffebld_cu_ptr_logical2 (u),
6198			       ffebld_constant_logical2 (ffebld_conter (l)),
6199			      ffebld_constant_logical2 (ffebld_conter (r)));
6200	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6201					(ffebld_cu_val_logical2 (u)), expr);
6202	  break;
6203#endif
6204
6205#if FFETARGET_okLOGICAL3
6206	case FFEINFO_kindtypeLOGICAL3:
6207	  error = ffetarget_or_logical3 (ffebld_cu_ptr_logical3 (u),
6208			       ffebld_constant_logical3 (ffebld_conter (l)),
6209			      ffebld_constant_logical3 (ffebld_conter (r)));
6210	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6211					(ffebld_cu_val_logical3 (u)), expr);
6212	  break;
6213#endif
6214
6215#if FFETARGET_okLOGICAL4
6216	case FFEINFO_kindtypeLOGICAL4:
6217	  error = ffetarget_or_logical4 (ffebld_cu_ptr_logical4 (u),
6218			       ffebld_constant_logical4 (ffebld_conter (l)),
6219			      ffebld_constant_logical4 (ffebld_conter (r)));
6220	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6221					(ffebld_cu_val_logical4 (u)), expr);
6222	  break;
6223#endif
6224
6225	default:
6226	  assert ("bad logical kind type" == NULL);
6227	  break;
6228	}
6229      break;
6230
6231    default:
6232      assert ("bad type" == NULL);
6233      return expr;
6234    }
6235
6236  ffebld_set_info (expr, ffeinfo_new
6237		   (bt,
6238		    kt,
6239		    0,
6240		    FFEINFO_kindENTITY,
6241		    FFEINFO_whereCONSTANT,
6242		    FFETARGET_charactersizeNONE));
6243
6244  if ((error != FFEBAD)
6245      && ffebad_start (error))
6246    {
6247      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6248      ffebad_finish ();
6249    }
6250
6251  return expr;
6252}
6253
6254/* ffeexpr_collapse_xor -- Collapse xor expr
6255
6256   ffebld expr;
6257   ffelexToken token;
6258   expr = ffeexpr_collapse_xor(expr,token);
6259
6260   If the result of the expr is a constant, replaces the expr with the
6261   computed constant.  */
6262
6263ffebld
6264ffeexpr_collapse_xor (ffebld expr, ffelexToken t)
6265{
6266  ffebad error = FFEBAD;
6267  ffebld l;
6268  ffebld r;
6269  ffebldConstantUnion u;
6270  ffeinfoBasictype bt;
6271  ffeinfoKindtype kt;
6272
6273  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6274    return expr;
6275
6276  l = ffebld_left (expr);
6277  r = ffebld_right (expr);
6278
6279  if (ffebld_op (l) != FFEBLD_opCONTER)
6280    return expr;
6281  if (ffebld_op (r) != FFEBLD_opCONTER)
6282    return expr;
6283
6284  switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6285    {
6286    case FFEINFO_basictypeANY:
6287      return expr;
6288
6289    case FFEINFO_basictypeINTEGER:
6290      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6291	{
6292#if FFETARGET_okINTEGER1
6293	case FFEINFO_kindtypeINTEGER1:
6294	  error = ffetarget_xor_integer1 (ffebld_cu_ptr_integer1 (u),
6295			       ffebld_constant_integer1 (ffebld_conter (l)),
6296			      ffebld_constant_integer1 (ffebld_conter (r)));
6297	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6298					(ffebld_cu_val_integer1 (u)), expr);
6299	  break;
6300#endif
6301
6302#if FFETARGET_okINTEGER2
6303	case FFEINFO_kindtypeINTEGER2:
6304	  error = ffetarget_xor_integer2 (ffebld_cu_ptr_integer2 (u),
6305			       ffebld_constant_integer2 (ffebld_conter (l)),
6306			      ffebld_constant_integer2 (ffebld_conter (r)));
6307	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6308					(ffebld_cu_val_integer2 (u)), expr);
6309	  break;
6310#endif
6311
6312#if FFETARGET_okINTEGER3
6313	case FFEINFO_kindtypeINTEGER3:
6314	  error = ffetarget_xor_integer3 (ffebld_cu_ptr_integer3 (u),
6315			       ffebld_constant_integer3 (ffebld_conter (l)),
6316			      ffebld_constant_integer3 (ffebld_conter (r)));
6317	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6318					(ffebld_cu_val_integer3 (u)), expr);
6319	  break;
6320#endif
6321
6322#if FFETARGET_okINTEGER4
6323	case FFEINFO_kindtypeINTEGER4:
6324	  error = ffetarget_xor_integer4 (ffebld_cu_ptr_integer4 (u),
6325			       ffebld_constant_integer4 (ffebld_conter (l)),
6326			      ffebld_constant_integer4 (ffebld_conter (r)));
6327	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6328					(ffebld_cu_val_integer4 (u)), expr);
6329	  break;
6330#endif
6331
6332	default:
6333	  assert ("bad integer kind type" == NULL);
6334	  break;
6335	}
6336      break;
6337
6338    case FFEINFO_basictypeLOGICAL:
6339      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6340	{
6341#if FFETARGET_okLOGICAL1
6342	case FFEINFO_kindtypeLOGICAL1:
6343	  error = ffetarget_xor_logical1 (ffebld_cu_ptr_logical1 (u),
6344			       ffebld_constant_logical1 (ffebld_conter (l)),
6345			      ffebld_constant_logical1 (ffebld_conter (r)));
6346	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6347					(ffebld_cu_val_logical1 (u)), expr);
6348	  break;
6349#endif
6350
6351#if FFETARGET_okLOGICAL2
6352	case FFEINFO_kindtypeLOGICAL2:
6353	  error = ffetarget_xor_logical2 (ffebld_cu_ptr_logical2 (u),
6354			       ffebld_constant_logical2 (ffebld_conter (l)),
6355			      ffebld_constant_logical2 (ffebld_conter (r)));
6356	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6357					(ffebld_cu_val_logical2 (u)), expr);
6358	  break;
6359#endif
6360
6361#if FFETARGET_okLOGICAL3
6362	case FFEINFO_kindtypeLOGICAL3:
6363	  error = ffetarget_xor_logical3 (ffebld_cu_ptr_logical3 (u),
6364			       ffebld_constant_logical3 (ffebld_conter (l)),
6365			      ffebld_constant_logical3 (ffebld_conter (r)));
6366	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6367					(ffebld_cu_val_logical3 (u)), expr);
6368	  break;
6369#endif
6370
6371#if FFETARGET_okLOGICAL4
6372	case FFEINFO_kindtypeLOGICAL4:
6373	  error = ffetarget_xor_logical4 (ffebld_cu_ptr_logical4 (u),
6374			       ffebld_constant_logical4 (ffebld_conter (l)),
6375			      ffebld_constant_logical4 (ffebld_conter (r)));
6376	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6377					(ffebld_cu_val_logical4 (u)), expr);
6378	  break;
6379#endif
6380
6381	default:
6382	  assert ("bad logical kind type" == NULL);
6383	  break;
6384	}
6385      break;
6386
6387    default:
6388      assert ("bad type" == NULL);
6389      return expr;
6390    }
6391
6392  ffebld_set_info (expr, ffeinfo_new
6393		   (bt,
6394		    kt,
6395		    0,
6396		    FFEINFO_kindENTITY,
6397		    FFEINFO_whereCONSTANT,
6398		    FFETARGET_charactersizeNONE));
6399
6400  if ((error != FFEBAD)
6401      && ffebad_start (error))
6402    {
6403      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6404      ffebad_finish ();
6405    }
6406
6407  return expr;
6408}
6409
6410/* ffeexpr_collapse_eqv -- Collapse eqv expr
6411
6412   ffebld expr;
6413   ffelexToken token;
6414   expr = ffeexpr_collapse_eqv(expr,token);
6415
6416   If the result of the expr is a constant, replaces the expr with the
6417   computed constant.  */
6418
6419ffebld
6420ffeexpr_collapse_eqv (ffebld expr, ffelexToken t)
6421{
6422  ffebad error = FFEBAD;
6423  ffebld l;
6424  ffebld r;
6425  ffebldConstantUnion u;
6426  ffeinfoBasictype bt;
6427  ffeinfoKindtype kt;
6428
6429  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6430    return expr;
6431
6432  l = ffebld_left (expr);
6433  r = ffebld_right (expr);
6434
6435  if (ffebld_op (l) != FFEBLD_opCONTER)
6436    return expr;
6437  if (ffebld_op (r) != FFEBLD_opCONTER)
6438    return expr;
6439
6440  switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6441    {
6442    case FFEINFO_basictypeANY:
6443      return expr;
6444
6445    case FFEINFO_basictypeINTEGER:
6446      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6447	{
6448#if FFETARGET_okINTEGER1
6449	case FFEINFO_kindtypeINTEGER1:
6450	  error = ffetarget_eqv_integer1 (ffebld_cu_ptr_integer1 (u),
6451			       ffebld_constant_integer1 (ffebld_conter (l)),
6452			      ffebld_constant_integer1 (ffebld_conter (r)));
6453	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6454					(ffebld_cu_val_integer1 (u)), expr);
6455	  break;
6456#endif
6457
6458#if FFETARGET_okINTEGER2
6459	case FFEINFO_kindtypeINTEGER2:
6460	  error = ffetarget_eqv_integer2 (ffebld_cu_ptr_integer2 (u),
6461			       ffebld_constant_integer2 (ffebld_conter (l)),
6462			      ffebld_constant_integer2 (ffebld_conter (r)));
6463	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6464					(ffebld_cu_val_integer2 (u)), expr);
6465	  break;
6466#endif
6467
6468#if FFETARGET_okINTEGER3
6469	case FFEINFO_kindtypeINTEGER3:
6470	  error = ffetarget_eqv_integer3 (ffebld_cu_ptr_integer3 (u),
6471			       ffebld_constant_integer3 (ffebld_conter (l)),
6472			      ffebld_constant_integer3 (ffebld_conter (r)));
6473	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6474					(ffebld_cu_val_integer3 (u)), expr);
6475	  break;
6476#endif
6477
6478#if FFETARGET_okINTEGER4
6479	case FFEINFO_kindtypeINTEGER4:
6480	  error = ffetarget_eqv_integer4 (ffebld_cu_ptr_integer4 (u),
6481			       ffebld_constant_integer4 (ffebld_conter (l)),
6482			      ffebld_constant_integer4 (ffebld_conter (r)));
6483	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6484					(ffebld_cu_val_integer4 (u)), expr);
6485	  break;
6486#endif
6487
6488	default:
6489	  assert ("bad integer kind type" == NULL);
6490	  break;
6491	}
6492      break;
6493
6494    case FFEINFO_basictypeLOGICAL:
6495      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6496	{
6497#if FFETARGET_okLOGICAL1
6498	case FFEINFO_kindtypeLOGICAL1:
6499	  error = ffetarget_eqv_logical1 (ffebld_cu_ptr_logical1 (u),
6500			       ffebld_constant_logical1 (ffebld_conter (l)),
6501			      ffebld_constant_logical1 (ffebld_conter (r)));
6502	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6503					(ffebld_cu_val_logical1 (u)), expr);
6504	  break;
6505#endif
6506
6507#if FFETARGET_okLOGICAL2
6508	case FFEINFO_kindtypeLOGICAL2:
6509	  error = ffetarget_eqv_logical2 (ffebld_cu_ptr_logical2 (u),
6510			       ffebld_constant_logical2 (ffebld_conter (l)),
6511			      ffebld_constant_logical2 (ffebld_conter (r)));
6512	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6513					(ffebld_cu_val_logical2 (u)), expr);
6514	  break;
6515#endif
6516
6517#if FFETARGET_okLOGICAL3
6518	case FFEINFO_kindtypeLOGICAL3:
6519	  error = ffetarget_eqv_logical3 (ffebld_cu_ptr_logical3 (u),
6520			       ffebld_constant_logical3 (ffebld_conter (l)),
6521			      ffebld_constant_logical3 (ffebld_conter (r)));
6522	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6523					(ffebld_cu_val_logical3 (u)), expr);
6524	  break;
6525#endif
6526
6527#if FFETARGET_okLOGICAL4
6528	case FFEINFO_kindtypeLOGICAL4:
6529	  error = ffetarget_eqv_logical4 (ffebld_cu_ptr_logical4 (u),
6530			       ffebld_constant_logical4 (ffebld_conter (l)),
6531			      ffebld_constant_logical4 (ffebld_conter (r)));
6532	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6533					(ffebld_cu_val_logical4 (u)), expr);
6534	  break;
6535#endif
6536
6537	default:
6538	  assert ("bad logical kind type" == NULL);
6539	  break;
6540	}
6541      break;
6542
6543    default:
6544      assert ("bad type" == NULL);
6545      return expr;
6546    }
6547
6548  ffebld_set_info (expr, ffeinfo_new
6549		   (bt,
6550		    kt,
6551		    0,
6552		    FFEINFO_kindENTITY,
6553		    FFEINFO_whereCONSTANT,
6554		    FFETARGET_charactersizeNONE));
6555
6556  if ((error != FFEBAD)
6557      && ffebad_start (error))
6558    {
6559      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6560      ffebad_finish ();
6561    }
6562
6563  return expr;
6564}
6565
6566/* ffeexpr_collapse_neqv -- Collapse neqv expr
6567
6568   ffebld expr;
6569   ffelexToken token;
6570   expr = ffeexpr_collapse_neqv(expr,token);
6571
6572   If the result of the expr is a constant, replaces the expr with the
6573   computed constant.  */
6574
6575ffebld
6576ffeexpr_collapse_neqv (ffebld expr, ffelexToken t)
6577{
6578  ffebad error = FFEBAD;
6579  ffebld l;
6580  ffebld r;
6581  ffebldConstantUnion u;
6582  ffeinfoBasictype bt;
6583  ffeinfoKindtype kt;
6584
6585  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6586    return expr;
6587
6588  l = ffebld_left (expr);
6589  r = ffebld_right (expr);
6590
6591  if (ffebld_op (l) != FFEBLD_opCONTER)
6592    return expr;
6593  if (ffebld_op (r) != FFEBLD_opCONTER)
6594    return expr;
6595
6596  switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6597    {
6598    case FFEINFO_basictypeANY:
6599      return expr;
6600
6601    case FFEINFO_basictypeINTEGER:
6602      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6603	{
6604#if FFETARGET_okINTEGER1
6605	case FFEINFO_kindtypeINTEGER1:
6606	  error = ffetarget_neqv_integer1 (ffebld_cu_ptr_integer1 (u),
6607			       ffebld_constant_integer1 (ffebld_conter (l)),
6608			      ffebld_constant_integer1 (ffebld_conter (r)));
6609	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6610					(ffebld_cu_val_integer1 (u)), expr);
6611	  break;
6612#endif
6613
6614#if FFETARGET_okINTEGER2
6615	case FFEINFO_kindtypeINTEGER2:
6616	  error = ffetarget_neqv_integer2 (ffebld_cu_ptr_integer2 (u),
6617			       ffebld_constant_integer2 (ffebld_conter (l)),
6618			      ffebld_constant_integer2 (ffebld_conter (r)));
6619	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6620					(ffebld_cu_val_integer2 (u)), expr);
6621	  break;
6622#endif
6623
6624#if FFETARGET_okINTEGER3
6625	case FFEINFO_kindtypeINTEGER3:
6626	  error = ffetarget_neqv_integer3 (ffebld_cu_ptr_integer3 (u),
6627			       ffebld_constant_integer3 (ffebld_conter (l)),
6628			      ffebld_constant_integer3 (ffebld_conter (r)));
6629	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6630					(ffebld_cu_val_integer3 (u)), expr);
6631	  break;
6632#endif
6633
6634#if FFETARGET_okINTEGER4
6635	case FFEINFO_kindtypeINTEGER4:
6636	  error = ffetarget_neqv_integer4 (ffebld_cu_ptr_integer4 (u),
6637			       ffebld_constant_integer4 (ffebld_conter (l)),
6638			      ffebld_constant_integer4 (ffebld_conter (r)));
6639	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6640					(ffebld_cu_val_integer4 (u)), expr);
6641	  break;
6642#endif
6643
6644	default:
6645	  assert ("bad integer kind type" == NULL);
6646	  break;
6647	}
6648      break;
6649
6650    case FFEINFO_basictypeLOGICAL:
6651      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6652	{
6653#if FFETARGET_okLOGICAL1
6654	case FFEINFO_kindtypeLOGICAL1:
6655	  error = ffetarget_neqv_logical1 (ffebld_cu_ptr_logical1 (u),
6656			       ffebld_constant_logical1 (ffebld_conter (l)),
6657			      ffebld_constant_logical1 (ffebld_conter (r)));
6658	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6659					(ffebld_cu_val_logical1 (u)), expr);
6660	  break;
6661#endif
6662
6663#if FFETARGET_okLOGICAL2
6664	case FFEINFO_kindtypeLOGICAL2:
6665	  error = ffetarget_neqv_logical2 (ffebld_cu_ptr_logical2 (u),
6666			       ffebld_constant_logical2 (ffebld_conter (l)),
6667			      ffebld_constant_logical2 (ffebld_conter (r)));
6668	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6669					(ffebld_cu_val_logical2 (u)), expr);
6670	  break;
6671#endif
6672
6673#if FFETARGET_okLOGICAL3
6674	case FFEINFO_kindtypeLOGICAL3:
6675	  error = ffetarget_neqv_logical3 (ffebld_cu_ptr_logical3 (u),
6676			       ffebld_constant_logical3 (ffebld_conter (l)),
6677			      ffebld_constant_logical3 (ffebld_conter (r)));
6678	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6679					(ffebld_cu_val_logical3 (u)), expr);
6680	  break;
6681#endif
6682
6683#if FFETARGET_okLOGICAL4
6684	case FFEINFO_kindtypeLOGICAL4:
6685	  error = ffetarget_neqv_logical4 (ffebld_cu_ptr_logical4 (u),
6686			       ffebld_constant_logical4 (ffebld_conter (l)),
6687			      ffebld_constant_logical4 (ffebld_conter (r)));
6688	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6689					(ffebld_cu_val_logical4 (u)), expr);
6690	  break;
6691#endif
6692
6693	default:
6694	  assert ("bad logical kind type" == NULL);
6695	  break;
6696	}
6697      break;
6698
6699    default:
6700      assert ("bad type" == NULL);
6701      return expr;
6702    }
6703
6704  ffebld_set_info (expr, ffeinfo_new
6705		   (bt,
6706		    kt,
6707		    0,
6708		    FFEINFO_kindENTITY,
6709		    FFEINFO_whereCONSTANT,
6710		    FFETARGET_charactersizeNONE));
6711
6712  if ((error != FFEBAD)
6713      && ffebad_start (error))
6714    {
6715      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6716      ffebad_finish ();
6717    }
6718
6719  return expr;
6720}
6721
6722/* ffeexpr_collapse_symter -- Collapse symter expr
6723
6724   ffebld expr;
6725   ffelexToken token;
6726   expr = ffeexpr_collapse_symter(expr,token);
6727
6728   If the result of the expr is a constant, replaces the expr with the
6729   computed constant.  */
6730
6731ffebld
6732ffeexpr_collapse_symter (ffebld expr, ffelexToken t UNUSED)
6733{
6734  ffebld r;
6735  ffeinfoBasictype bt;
6736  ffeinfoKindtype kt;
6737  ffetargetCharacterSize len;
6738
6739  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6740    return expr;
6741
6742  if ((r = ffesymbol_init (ffebld_symter (expr))) == NULL)
6743    return expr;		/* A PARAMETER lhs in progress. */
6744
6745  switch (ffebld_op (r))
6746    {
6747    case FFEBLD_opCONTER:
6748      break;
6749
6750    case FFEBLD_opANY:
6751      return r;
6752
6753    default:
6754      return expr;
6755    }
6756
6757  bt = ffeinfo_basictype (ffebld_info (r));
6758  kt = ffeinfo_kindtype (ffebld_info (r));
6759  len = ffebld_size (r);
6760
6761  expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
6762				      expr);
6763
6764  ffebld_set_info (expr, ffeinfo_new
6765		   (bt,
6766		    kt,
6767		    0,
6768		    FFEINFO_kindENTITY,
6769		    FFEINFO_whereCONSTANT,
6770		    len));
6771
6772  return expr;
6773}
6774
6775/* ffeexpr_collapse_funcref -- Collapse funcref expr
6776
6777   ffebld expr;
6778   ffelexToken token;
6779   expr = ffeexpr_collapse_funcref(expr,token);
6780
6781   If the result of the expr is a constant, replaces the expr with the
6782   computed constant.  */
6783
6784ffebld
6785ffeexpr_collapse_funcref (ffebld expr, ffelexToken t UNUSED)
6786{
6787  return expr;			/* ~~someday go ahead and collapse these,
6788				   though not required */
6789}
6790
6791/* ffeexpr_collapse_arrayref -- Collapse arrayref expr
6792
6793   ffebld expr;
6794   ffelexToken token;
6795   expr = ffeexpr_collapse_arrayref(expr,token);
6796
6797   If the result of the expr is a constant, replaces the expr with the
6798   computed constant.  */
6799
6800ffebld
6801ffeexpr_collapse_arrayref (ffebld expr, ffelexToken t UNUSED)
6802{
6803  return expr;
6804}
6805
6806/* ffeexpr_collapse_substr -- Collapse substr expr
6807
6808   ffebld expr;
6809   ffelexToken token;
6810   expr = ffeexpr_collapse_substr(expr,token);
6811
6812   If the result of the expr is a constant, replaces the expr with the
6813   computed constant.  */
6814
6815ffebld
6816ffeexpr_collapse_substr (ffebld expr, ffelexToken t)
6817{
6818  ffebad error = FFEBAD;
6819  ffebld l;
6820  ffebld r;
6821  ffebld start;
6822  ffebld stop;
6823  ffebldConstantUnion u;
6824  ffeinfoKindtype kt;
6825  ffetargetCharacterSize len;
6826  ffetargetIntegerDefault first;
6827  ffetargetIntegerDefault last;
6828
6829  if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6830    return expr;
6831
6832  l = ffebld_left (expr);
6833  r = ffebld_right (expr);	/* opITEM. */
6834
6835  if (ffebld_op (l) != FFEBLD_opCONTER)
6836    return expr;
6837
6838  kt = ffeinfo_kindtype (ffebld_info (l));
6839  len = ffebld_size (l);
6840
6841  start = ffebld_head (r);
6842  stop = ffebld_head (ffebld_trail (r));
6843  if (start == NULL)
6844    first = 1;
6845  else
6846    {
6847      if ((ffebld_op (start) != FFEBLD_opCONTER)
6848	  || (ffeinfo_basictype (ffebld_info (start)) != FFEINFO_basictypeINTEGER)
6849	  || (ffeinfo_kindtype (ffebld_info (start))
6850	      != FFEINFO_kindtypeINTEGERDEFAULT))
6851	return expr;
6852      first = ffebld_constant_integerdefault (ffebld_conter (start));
6853    }
6854  if (stop == NULL)
6855    last = len;
6856  else
6857    {
6858      if ((ffebld_op (stop) != FFEBLD_opCONTER)
6859      || (ffeinfo_basictype (ffebld_info (stop)) != FFEINFO_basictypeINTEGER)
6860	  || (ffeinfo_kindtype (ffebld_info (stop))
6861	      != FFEINFO_kindtypeINTEGERDEFAULT))
6862	return expr;
6863      last = ffebld_constant_integerdefault (ffebld_conter (stop));
6864    }
6865
6866  /* Handle problems that should have already been diagnosed, but
6867     left in the expression tree.  */
6868
6869  if (first <= 0)
6870    first = 1;
6871  if (last < first)
6872    last = first + len - 1;
6873
6874  if ((first == 1) && (last == len))
6875    {				/* Same as original. */
6876      expr = ffebld_new_conter_with_orig (ffebld_constant_copy
6877					  (ffebld_conter (l)), expr);
6878      ffebld_set_info (expr, ffeinfo_new
6879		       (FFEINFO_basictypeCHARACTER,
6880			kt,
6881			0,
6882			FFEINFO_kindENTITY,
6883			FFEINFO_whereCONSTANT,
6884			len));
6885
6886      return expr;
6887    }
6888
6889  switch (ffeinfo_basictype (ffebld_info (expr)))
6890    {
6891    case FFEINFO_basictypeANY:
6892      return expr;
6893
6894    case FFEINFO_basictypeCHARACTER:
6895      switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6896	{
6897#if FFETARGET_okCHARACTER1
6898	case FFEINFO_kindtypeCHARACTER1:
6899	  error = ffetarget_substr_character1 (ffebld_cu_ptr_character1 (u),
6900		ffebld_constant_character1 (ffebld_conter (l)), first, last,
6901				   ffebld_constant_pool (), &len);
6902	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
6903				      (ffebld_cu_val_character1 (u)), expr);
6904	  break;
6905#endif
6906
6907#if FFETARGET_okCHARACTER2
6908	case FFEINFO_kindtypeCHARACTER2:
6909	  error = ffetarget_substr_character2 (ffebld_cu_ptr_character2 (u),
6910		ffebld_constant_character2 (ffebld_conter (l)), first, last,
6911				   ffebld_constant_pool (), &len);
6912	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val
6913				      (ffebld_cu_val_character2 (u)), expr);
6914	  break;
6915#endif
6916
6917#if FFETARGET_okCHARACTER3
6918	case FFEINFO_kindtypeCHARACTER3:
6919	  error = ffetarget_substr_character3 (ffebld_cu_ptr_character3 (u),
6920		ffebld_constant_character3 (ffebld_conter (l)), first, last,
6921				   ffebld_constant_pool (), &len);
6922	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val
6923				      (ffebld_cu_val_character3 (u)), expr);
6924	  break;
6925#endif
6926
6927#if FFETARGET_okCHARACTER4
6928	case FFEINFO_kindtypeCHARACTER4:
6929	  error = ffetarget_substr_character4 (ffebld_cu_ptr_character4 (u),
6930		ffebld_constant_character4 (ffebld_conter (l)), first, last,
6931				   ffebld_constant_pool (), &len);
6932	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val
6933				      (ffebld_cu_val_character4 (u)), expr);
6934	  break;
6935#endif
6936
6937	default:
6938	  assert ("bad character kind type" == NULL);
6939	  break;
6940	}
6941      break;
6942
6943    default:
6944      assert ("bad type" == NULL);
6945      return expr;
6946    }
6947
6948  ffebld_set_info (expr, ffeinfo_new
6949		   (FFEINFO_basictypeCHARACTER,
6950		    kt,
6951		    0,
6952		    FFEINFO_kindENTITY,
6953		    FFEINFO_whereCONSTANT,
6954		    len));
6955
6956  if ((error != FFEBAD)
6957      && ffebad_start (error))
6958    {
6959      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6960      ffebad_finish ();
6961    }
6962
6963  return expr;
6964}
6965
6966/* ffeexpr_convert -- Convert source expression to given type
6967
6968   ffebld source;
6969   ffelexToken source_token;
6970   ffelexToken dest_token;  // Any appropriate token for "destination".
6971   ffeinfoBasictype bt;
6972   ffeinfoKindtype kt;
6973   ffetargetCharactersize sz;
6974   ffeexprContext context;  // Mainly LET or DATA.
6975   source = ffeexpr_convert(source,source_token,dest_token,bt,kt,sz,context);
6976
6977   If the expression conforms, returns the source expression.  Otherwise
6978   returns source wrapped in a convert node doing the conversion, or
6979   ANY wrapped in convert if there is a conversion error (and issues an
6980   error message).  Be sensitive to the context for certain aspects of
6981   the conversion.  */
6982
6983ffebld
6984ffeexpr_convert (ffebld source, ffelexToken source_token, ffelexToken dest_token,
6985		 ffeinfoBasictype bt, ffeinfoKindtype kt, ffeinfoRank rk,
6986		 ffetargetCharacterSize sz, ffeexprContext context)
6987{
6988  bool bad;
6989  ffeinfo info;
6990  ffeinfoWhere wh;
6991
6992  info = ffebld_info (source);
6993  if ((bt != ffeinfo_basictype (info))
6994      || (kt != ffeinfo_kindtype (info))
6995      || (rk != 0)		/* Can't convert from or to arrays yet. */
6996      || (ffeinfo_rank (info) != 0)
6997      || (sz != ffebld_size_known (source)))
6998#if 0	/* Nobody seems to need this spurious CONVERT node. */
6999      || ((context != FFEEXPR_contextLET)
7000	  && (bt == FFEINFO_basictypeCHARACTER)
7001	  && (sz == FFETARGET_charactersizeNONE)))
7002#endif
7003    {
7004      switch (ffeinfo_basictype (info))
7005	{
7006	case FFEINFO_basictypeLOGICAL:
7007	  switch (bt)
7008	    {
7009	    case FFEINFO_basictypeLOGICAL:
7010	      bad = FALSE;
7011	      break;
7012
7013	    case FFEINFO_basictypeINTEGER:
7014	      bad = !ffe_is_ugly_logint ();
7015	      break;
7016
7017	    case FFEINFO_basictypeCHARACTER:
7018	      bad = ffe_is_pedantic ()
7019		|| !(ffe_is_ugly_init ()
7020		     && (context == FFEEXPR_contextDATA));
7021	      break;
7022
7023	    default:
7024	      bad = TRUE;
7025	      break;
7026	    }
7027	  break;
7028
7029	case FFEINFO_basictypeINTEGER:
7030	  switch (bt)
7031	    {
7032	    case FFEINFO_basictypeINTEGER:
7033	    case FFEINFO_basictypeREAL:
7034	    case FFEINFO_basictypeCOMPLEX:
7035	      bad = FALSE;
7036	      break;
7037
7038	    case FFEINFO_basictypeLOGICAL:
7039	      bad = !ffe_is_ugly_logint ();
7040	      break;
7041
7042	    case FFEINFO_basictypeCHARACTER:
7043	      bad = ffe_is_pedantic ()
7044		|| !(ffe_is_ugly_init ()
7045		     && (context == FFEEXPR_contextDATA));
7046	      break;
7047
7048	    default:
7049	      bad = TRUE;
7050	      break;
7051	    }
7052	  break;
7053
7054	case FFEINFO_basictypeREAL:
7055	case FFEINFO_basictypeCOMPLEX:
7056	  switch (bt)
7057	    {
7058	    case FFEINFO_basictypeINTEGER:
7059	    case FFEINFO_basictypeREAL:
7060	    case FFEINFO_basictypeCOMPLEX:
7061	      bad = FALSE;
7062	      break;
7063
7064	    case FFEINFO_basictypeCHARACTER:
7065	      bad = TRUE;
7066	      break;
7067
7068	    default:
7069	      bad = TRUE;
7070	      break;
7071	    }
7072	  break;
7073
7074	case FFEINFO_basictypeCHARACTER:
7075	  bad = (bt != FFEINFO_basictypeCHARACTER)
7076	    && (ffe_is_pedantic ()
7077		|| (bt != FFEINFO_basictypeINTEGER)
7078		|| !(ffe_is_ugly_init ()
7079		     && (context == FFEEXPR_contextDATA)));
7080	  break;
7081
7082	case FFEINFO_basictypeTYPELESS:
7083	case FFEINFO_basictypeHOLLERITH:
7084	  bad = ffe_is_pedantic ()
7085	    || !(ffe_is_ugly_init ()
7086		 && ((context == FFEEXPR_contextDATA)
7087		     || (context == FFEEXPR_contextLET)));
7088	  break;
7089
7090	default:
7091	  bad = TRUE;
7092	  break;
7093	}
7094
7095      if (!bad && ((rk != 0) || (ffeinfo_rank (info) != 0)))
7096	bad = TRUE;
7097
7098      if (bad && (bt != FFEINFO_basictypeANY) && (kt != FFEINFO_kindtypeANY)
7099	  && (ffeinfo_basictype (info) != FFEINFO_basictypeANY)
7100	  && (ffeinfo_kindtype (info) != FFEINFO_kindtypeANY)
7101	  && (ffeinfo_where (info) != FFEINFO_whereANY))
7102	{
7103	  if (ffebad_start (FFEBAD_BAD_TYPES))
7104	    {
7105	      if (dest_token == NULL)
7106		ffebad_here (0, ffewhere_line_unknown (),
7107			     ffewhere_column_unknown ());
7108	      else
7109		ffebad_here (0, ffelex_token_where_line (dest_token),
7110			     ffelex_token_where_column (dest_token));
7111	      assert (source_token != NULL);
7112	      ffebad_here (1, ffelex_token_where_line (source_token),
7113			   ffelex_token_where_column (source_token));
7114	      ffebad_finish ();
7115	    }
7116
7117	  source = ffebld_new_any ();
7118	  ffebld_set_info (source, ffeinfo_new_any ());
7119	}
7120      else
7121	{
7122	  switch (ffeinfo_where (info))
7123	    {
7124	    case FFEINFO_whereCONSTANT:
7125	      wh = FFEINFO_whereCONSTANT;
7126	      break;
7127
7128	    case FFEINFO_whereIMMEDIATE:
7129	      wh = FFEINFO_whereIMMEDIATE;
7130	      break;
7131
7132	    default:
7133	      wh = FFEINFO_whereFLEETING;
7134	      break;
7135	    }
7136	  source = ffebld_new_convert (source);
7137	  ffebld_set_info (source, ffeinfo_new
7138			   (bt,
7139			    kt,
7140			    0,
7141			    FFEINFO_kindENTITY,
7142			    wh,
7143			    sz));
7144	  source = ffeexpr_collapse_convert (source, source_token);
7145	}
7146    }
7147
7148  return source;
7149}
7150
7151/* ffeexpr_convert_expr -- Convert source expr to conform to dest expr
7152
7153   ffebld source;
7154   ffebld dest;
7155   ffelexToken source_token;
7156   ffelexToken dest_token;
7157   ffeexprContext context;
7158   source = ffeexpr_convert_expr(source,source_token,dest,dest_token,context);
7159
7160   If the expressions conform, returns the source expression.  Otherwise
7161   returns source wrapped in a convert node doing the conversion, or
7162   ANY wrapped in convert if there is a conversion error (and issues an
7163   error message).  Be sensitive to the context, such as LET or DATA.  */
7164
7165ffebld
7166ffeexpr_convert_expr (ffebld source, ffelexToken source_token, ffebld dest,
7167		      ffelexToken dest_token, ffeexprContext context)
7168{
7169  ffeinfo info;
7170
7171  info = ffebld_info (dest);
7172  return ffeexpr_convert (source, source_token, dest_token,
7173			  ffeinfo_basictype (info),
7174			  ffeinfo_kindtype (info),
7175			  ffeinfo_rank (info),
7176			  ffebld_size_known (dest),
7177			  context);
7178}
7179
7180/* ffeexpr_convert_to_sym -- Convert source expression to conform to symbol
7181
7182   ffebld source;
7183   ffesymbol dest;
7184   ffelexToken source_token;
7185   ffelexToken dest_token;
7186   source = ffeexpr_convert_to_sym(source,source_token,dest,dest_token);
7187
7188   If the expressions conform, returns the source expression.  Otherwise
7189   returns source wrapped in a convert node doing the conversion, or
7190   ANY wrapped in convert if there is a conversion error (and issues an
7191   error message).  */
7192
7193ffebld
7194ffeexpr_convert_to_sym (ffebld source, ffelexToken source_token,
7195			ffesymbol dest, ffelexToken dest_token)
7196{
7197  return ffeexpr_convert (source, source_token, dest_token, ffesymbol_basictype (dest),
7198    ffesymbol_kindtype (dest), ffesymbol_rank (dest), ffesymbol_size (dest),
7199			  FFEEXPR_contextLET);
7200}
7201
7202/* Initializes the module.  */
7203
7204void
7205ffeexpr_init_2 ()
7206{
7207  ffeexpr_stack_ = NULL;
7208  ffeexpr_level_ = 0;
7209}
7210
7211/* ffeexpr_lhs -- Begin processing left-hand-side-context expression
7212
7213   Prepares cluster for delivery of lexer tokens representing an expression
7214   in a left-hand-side context (A in A=B, for example).	 ffebld is used
7215   to build expressions in the given pool.  The appropriate lexer-token
7216   handling routine within ffeexpr is returned.	 When the end of the
7217   expression is detected, mycallbackroutine is called with the resulting
7218   single ffebld object specifying the entire expression and the first
7219   lexer token that is not considered part of the expression.  This caller-
7220   supplied routine itself returns a lexer-token handling routine.  Thus,
7221   if necessary, ffeexpr can return several tokens as end-of-expression
7222   tokens if it needs to scan forward more than one in any instance.  */
7223
7224ffelexHandler
7225ffeexpr_lhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
7226{
7227  ffeexprStack_ s;
7228
7229  ffebld_pool_push (pool);
7230  s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
7231  s->previous = ffeexpr_stack_;
7232  s->pool = pool;
7233  s->context = context;
7234  s->callback = callback;
7235  s->first_token = NULL;
7236  s->exprstack = NULL;
7237  s->is_rhs = FALSE;
7238  ffeexpr_stack_ = s;
7239  return (ffelexHandler) ffeexpr_token_first_lhs_;
7240}
7241
7242/* ffeexpr_rhs -- Begin processing right-hand-side-context expression
7243
7244   return ffeexpr_rhs(malloc_pool_image(),mycallbackroutine);  // to lexer.
7245
7246   Prepares cluster for delivery of lexer tokens representing an expression
7247   in a right-hand-side context (B in A=B, for example).  ffebld is used
7248   to build expressions in the given pool.  The appropriate lexer-token
7249   handling routine within ffeexpr is returned.	 When the end of the
7250   expression is detected, mycallbackroutine is called with the resulting
7251   single ffebld object specifying the entire expression and the first
7252   lexer token that is not considered part of the expression.  This caller-
7253   supplied routine itself returns a lexer-token handling routine.  Thus,
7254   if necessary, ffeexpr can return several tokens as end-of-expression
7255   tokens if it needs to scan forward more than one in any instance.  */
7256
7257ffelexHandler
7258ffeexpr_rhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
7259{
7260  ffeexprStack_ s;
7261
7262  ffebld_pool_push (pool);
7263  s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
7264  s->previous = ffeexpr_stack_;
7265  s->pool = pool;
7266  s->context = context;
7267  s->callback = callback;
7268  s->first_token = NULL;
7269  s->exprstack = NULL;
7270  s->is_rhs = TRUE;
7271  ffeexpr_stack_ = s;
7272  return (ffelexHandler) ffeexpr_token_first_rhs_;
7273}
7274
7275/* ffeexpr_cb_close_paren_ -- OPEN_PAREN expr
7276
7277   Pass it to ffeexpr_rhs as the callback routine.
7278
7279   Makes sure the end token is close-paren and swallows it, else issues
7280   an error message and doesn't swallow the token (passing it along instead).
7281   In either case wraps up subexpression construction by enclosing the
7282   ffebld expression in a paren.  */
7283
7284static ffelexHandler
7285ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr, ffelexToken t)
7286{
7287  ffeexprExpr_ e;
7288
7289  if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7290    {
7291      /* Oops, naughty user didn't specify the close paren! */
7292
7293      if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7294	{
7295	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7296	  ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7297		       ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7298	  ffebad_finish ();
7299	}
7300
7301      e = ffeexpr_expr_new_ ();
7302      e->type = FFEEXPR_exprtypeOPERAND_;
7303      e->u.operand = ffebld_new_any ();
7304      ffebld_set_info (e->u.operand, ffeinfo_new_any ());
7305      ffeexpr_exprstack_push_operand_ (e);
7306
7307      return
7308	(ffelexHandler) ffeexpr_find_close_paren_ (t,
7309						   (ffelexHandler)
7310						   ffeexpr_token_binary_);
7311    }
7312
7313  if (expr->op == FFEBLD_opIMPDO)
7314    {
7315      if (ffest_ffebad_start (FFEBAD_IMPDO_PAREN))
7316	{
7317	  ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7318		       ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7319	  ffebad_finish ();
7320	}
7321    }
7322  else
7323    {
7324      expr = ffebld_new_paren (expr);
7325      ffebld_set_info (expr, ffeinfo_use (ffebld_info (ffebld_left (expr))));
7326    }
7327
7328  /* Now push the (parenthesized) expression as an operand onto the
7329     expression stack. */
7330
7331  e = ffeexpr_expr_new_ ();
7332  e->type = FFEEXPR_exprtypeOPERAND_;
7333  e->u.operand = expr;
7334  e->u.operand = ffeexpr_collapse_paren (e->u.operand, ft);
7335  e->token = ffeexpr_stack_->tokens[0];
7336  ffeexpr_exprstack_push_operand_ (e);
7337
7338  return (ffelexHandler) ffeexpr_token_binary_;
7339}
7340
7341/* ffeexpr_cb_close_paren_ambig_ -- OPEN_PAREN expr
7342
7343   Pass it to ffeexpr_rhs as the callback routine.
7344
7345   We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
7346   with the next token in t.  If the next token is possibly a binary
7347   operator, continue processing the outer expression.	If the next
7348   token is COMMA, then the expression is a unit specifier, and
7349   parentheses should not be added to it because it surrounds the
7350   I/O control list that starts with the unit specifier (and continues
7351   on from here -- we haven't seen the CLOSE_PAREN that matches the
7352   OPEN_PAREN, it is up to the callback function to expect to see it
7353   at some point).  In this case, we notify the callback function that
7354   the COMMA is inside, not outside, the parens by wrapping the expression
7355   in an opITEM (with a NULL trail) -- the callback function presumably
7356   unwraps it after seeing this kludgey indicator.
7357
7358   If the next token is CLOSE_PAREN, then we go to the _1_ state to
7359   decide what to do with the token after that.
7360
7361   15-Feb-91  JCB  1.1
7362      Use an extra state for the CLOSE_PAREN case to make READ &co really
7363      work right.  */
7364
7365static ffelexHandler
7366ffeexpr_cb_close_paren_ambig_ (ffelexToken ft, ffebld expr, ffelexToken t)
7367{
7368  ffeexprCallback callback;
7369  ffeexprStack_ s;
7370
7371  if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7372    {				/* Need to see the next token before we
7373				   decide anything. */
7374      ffeexpr_stack_->expr = expr;
7375      ffeexpr_tokens_[0] = ffelex_token_use (ft);
7376      ffeexpr_tokens_[1] = ffelex_token_use (t);
7377      return (ffelexHandler) ffeexpr_cb_close_paren_ambig_1_;
7378    }
7379
7380  expr = ffeexpr_finished_ambig_ (ft, expr);
7381
7382  /* Let the callback function handle the case where t isn't COMMA. */
7383
7384  /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
7385     that preceded the expression starts a list of expressions, and the expr
7386     hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
7387     node.  The callback function should extract the real expr from the head
7388     of this opITEM node after testing it. */
7389
7390  expr = ffebld_new_item (expr, NULL);
7391
7392  ffebld_pool_pop ();
7393  callback = ffeexpr_stack_->callback;
7394  ffelex_token_kill (ffeexpr_stack_->first_token);
7395  s = ffeexpr_stack_->previous;
7396  malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
7397  ffeexpr_stack_ = s;
7398  return (ffelexHandler) (*callback) (ft, expr, t);
7399}
7400
7401/* ffeexpr_cb_close_paren_ambig_1_ -- OPEN_PAREN expr CLOSE_PAREN
7402
7403   See ffeexpr_cb_close_paren_ambig_.
7404
7405   We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
7406   with the next token in t.  If the next token is possibly a binary
7407   operator, continue processing the outer expression.	If the next
7408   token is COMMA, the expression is a parenthesized format specifier.
7409   If the next token is not EOS or SEMICOLON, then because it is not a
7410   binary operator (it is NAME, OPEN_PAREN, &c), the expression is
7411   a unit specifier, and parentheses should not be added to it because
7412   they surround the I/O control list that consists of only the unit
7413   specifier.  If the next token is EOS or SEMICOLON, the statement
7414   must be disambiguated by looking at the type of the expression -- a
7415   character expression is a parenthesized format specifier, while a
7416   non-character expression is a unit specifier.
7417
7418   Another issue is how to do the callback so the recipient of the
7419   next token knows how to handle it if it is a COMMA.	In all other
7420   cases, disambiguation is straightforward: the same approach as the
7421   above is used.
7422
7423   EXTENSION: in COMMA case, if not pedantic, use same disambiguation
7424   as for EOS/SEMICOLON case; f2c allows "READ (cilist) [[,]iolist]"
7425   and apparently other compilers do, as well, and some code out there
7426   uses this "feature".
7427
7428   19-Feb-91  JCB  1.1
7429      Extend to allow COMMA as nondisambiguating by itself.  Remember
7430      to not try and check info field for opSTAR, since that expr doesn't
7431      have a valid info field.	*/
7432
7433static ffelexHandler
7434ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t)
7435{
7436  ffeexprCallback callback;
7437  ffeexprStack_ s;
7438  ffelexHandler next;
7439  ffelexToken orig_ft = ffeexpr_tokens_[0];	/* In case callback clobbers
7440						   these. */
7441  ffelexToken orig_t = ffeexpr_tokens_[1];
7442  ffebld expr = ffeexpr_stack_->expr;
7443
7444  switch (ffelex_token_type (t))
7445    {
7446    case FFELEX_typeCOMMA:	/* Subexpr is parenthesized format specifier. */
7447      if (ffe_is_pedantic ())
7448	goto pedantic_comma;	/* :::::::::::::::::::: */
7449      /* Fall through. */
7450    case FFELEX_typeEOS:	/* Ambiguous; use type of expr to
7451				   disambiguate. */
7452    case FFELEX_typeSEMICOLON:
7453      if ((expr == NULL) || (ffebld_op (expr) == FFEBLD_opANY)
7454	  || (ffebld_op (expr) == FFEBLD_opSTAR)
7455	  || (ffeinfo_basictype (ffebld_info (expr))
7456	      != FFEINFO_basictypeCHARACTER))
7457	break;			/* Not a valid CHARACTER entity, can't be a
7458				   format spec. */
7459      /* Fall through. */
7460    default:			/* Binary op (we assume; error otherwise);
7461				   format specifier. */
7462
7463    pedantic_comma:		/* :::::::::::::::::::: */
7464
7465      switch (ffeexpr_stack_->context)
7466	{
7467	case FFEEXPR_contextFILENUMAMBIG:
7468	  ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
7469	  break;
7470
7471	case FFEEXPR_contextFILEUNITAMBIG:
7472	  ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
7473	  break;
7474
7475	default:
7476	  assert ("bad context" == NULL);
7477	  break;
7478	}
7479
7480      ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
7481      next = (ffelexHandler) ffeexpr_cb_close_paren_ (orig_ft, expr, orig_t);
7482      ffelex_token_kill (orig_ft);
7483      ffelex_token_kill (orig_t);
7484      return (ffelexHandler) (*next) (t);
7485
7486    case FFELEX_typeOPEN_PAREN:/* Non-binary op; beginning of I/O list. */
7487    case FFELEX_typeNAME:
7488      break;
7489    }
7490
7491  expr = ffeexpr_finished_ambig_ (orig_ft, expr);
7492
7493  /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
7494     that preceded the expression starts a list of expressions, and the expr
7495     hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
7496     node.  The callback function should extract the real expr from the head
7497     of this opITEM node after testing it. */
7498
7499  expr = ffebld_new_item (expr, NULL);
7500
7501  ffebld_pool_pop ();
7502  callback = ffeexpr_stack_->callback;
7503  ffelex_token_kill (ffeexpr_stack_->first_token);
7504  s = ffeexpr_stack_->previous;
7505  malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
7506  ffeexpr_stack_ = s;
7507  next = (ffelexHandler) (*callback) (orig_ft, expr, orig_t);
7508  ffelex_token_kill (orig_ft);
7509  ffelex_token_kill (orig_t);
7510  return (ffelexHandler) (*next) (t);
7511}
7512
7513/* ffeexpr_cb_close_paren_c_ -- OPEN_PAREN expr (possible complex)
7514
7515   Pass it to ffeexpr_rhs as the callback routine.
7516
7517   Makes sure the end token is close-paren and swallows it, or a comma
7518   and handles complex/implied-do possibilities, else issues
7519   an error message and doesn't swallow the token (passing it along instead).  */
7520
7521static ffelexHandler
7522ffeexpr_cb_close_paren_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
7523{
7524  /* First check to see if this is a possible complex entity.  It is if the
7525     token is a comma. */
7526
7527  if (ffelex_token_type (t) == FFELEX_typeCOMMA)
7528    {
7529      ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
7530      ffeexpr_stack_->expr = expr;
7531      return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7532				FFEEXPR_contextPAREN_, ffeexpr_cb_comma_c_);
7533    }
7534
7535  return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
7536}
7537
7538/* ffeexpr_cb_comma_c_ -- OPEN_PAREN expr COMMA expr
7539
7540   Pass it to ffeexpr_rhs as the callback routine.
7541
7542   If this token is not a comma, we have a complex constant (or an attempt
7543   at one), so handle it accordingly, displaying error messages if the token
7544   is not a close-paren.  */
7545
7546static ffelexHandler
7547ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
7548{
7549  ffeexprExpr_ e;
7550  ffeinfoBasictype lty = (ffeexpr_stack_->expr == NULL)
7551    ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (ffeexpr_stack_->expr));
7552  ffeinfoBasictype rty = (expr == NULL)
7553    ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (expr));
7554  ffeinfoKindtype lkt;
7555  ffeinfoKindtype rkt;
7556  ffeinfoKindtype nkt;
7557  bool ok = TRUE;
7558  ffebld orig;
7559
7560  if ((ffeexpr_stack_->expr == NULL)
7561      || (ffebld_op (ffeexpr_stack_->expr) != FFEBLD_opCONTER)
7562      || (((orig = ffebld_conter_orig (ffeexpr_stack_->expr)) != NULL)
7563	  && (((ffebld_op (orig) != FFEBLD_opUMINUS)
7564	       && (ffebld_op (orig) != FFEBLD_opUPLUS))
7565	      || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
7566      || ((lty != FFEINFO_basictypeINTEGER)
7567	  && (lty != FFEINFO_basictypeREAL)))
7568    {
7569      if ((lty != FFEINFO_basictypeANY)
7570	  && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
7571	{
7572	  ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
7573		     ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
7574	  ffebad_string ("Real");
7575	  ffebad_finish ();
7576	}
7577      ok = FALSE;
7578    }
7579  if ((expr == NULL)
7580      || (ffebld_op (expr) != FFEBLD_opCONTER)
7581      || (((orig = ffebld_conter_orig (expr)) != NULL)
7582	  && (((ffebld_op (orig) != FFEBLD_opUMINUS)
7583	       && (ffebld_op (orig) != FFEBLD_opUPLUS))
7584	      || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
7585      || ((rty != FFEINFO_basictypeINTEGER)
7586	  && (rty != FFEINFO_basictypeREAL)))
7587    {
7588      if ((rty != FFEINFO_basictypeANY)
7589	  && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
7590	{
7591	  ffebad_here (0, ffelex_token_where_line (ft),
7592		       ffelex_token_where_column (ft));
7593	  ffebad_string ("Imaginary");
7594	  ffebad_finish ();
7595	}
7596      ok = FALSE;
7597    }
7598
7599  ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7600
7601  /* Push the (parenthesized) expression as an operand onto the expression
7602     stack. */
7603
7604  e = ffeexpr_expr_new_ ();
7605  e->type = FFEEXPR_exprtypeOPERAND_;
7606  e->token = ffeexpr_stack_->tokens[0];
7607
7608  if (ok)
7609    {
7610      if (lty == FFEINFO_basictypeINTEGER)
7611	lkt = FFEINFO_kindtypeREALDEFAULT;
7612      else
7613	lkt = ffeinfo_kindtype (ffebld_info (ffeexpr_stack_->expr));
7614      if (rty == FFEINFO_basictypeINTEGER)
7615	rkt = FFEINFO_kindtypeREALDEFAULT;
7616      else
7617	rkt = ffeinfo_kindtype (ffebld_info (expr));
7618
7619      nkt = ffeinfo_kindtype_max (FFEINFO_basictypeCOMPLEX, lkt, rkt);
7620      ffeexpr_stack_->expr = ffeexpr_convert (ffeexpr_stack_->expr,
7621		       ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
7622		 FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
7623					      FFEEXPR_contextLET);
7624      expr = ffeexpr_convert (expr,
7625		       ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
7626		 FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
7627			      FFEEXPR_contextLET);
7628    }
7629  else
7630    nkt = FFEINFO_kindtypeANY;
7631
7632  switch (nkt)
7633    {
7634#if FFETARGET_okCOMPLEX1
7635    case FFEINFO_kindtypeREAL1:
7636      e->u.operand = ffebld_new_conter (ffebld_constant_new_complex1
7637	      (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7638      ffebld_set_info (e->u.operand,
7639		       ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7640				  FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7641				    FFETARGET_charactersizeNONE));
7642      break;
7643#endif
7644
7645#if FFETARGET_okCOMPLEX2
7646    case FFEINFO_kindtypeREAL2:
7647      e->u.operand = ffebld_new_conter (ffebld_constant_new_complex2
7648	      (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7649      ffebld_set_info (e->u.operand,
7650		       ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7651				  FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7652				    FFETARGET_charactersizeNONE));
7653      break;
7654#endif
7655
7656#if FFETARGET_okCOMPLEX3
7657    case FFEINFO_kindtypeREAL3:
7658      e->u.operand = ffebld_new_conter (ffebld_constant_new_complex3
7659	      (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7660      ffebld_set_info (e->u.operand,
7661		       ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7662				  FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7663				    FFETARGET_charactersizeNONE));
7664      break;
7665#endif
7666
7667#if FFETARGET_okCOMPLEX4
7668    case FFEINFO_kindtypeREAL4:
7669      e->u.operand = ffebld_new_conter (ffebld_constant_new_complex4
7670	      (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7671      ffebld_set_info (e->u.operand,
7672		       ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7673				  FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7674				    FFETARGET_charactersizeNONE));
7675      break;
7676#endif
7677
7678    default:
7679      if (ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
7680			? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX))
7681	{
7682	  ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7683		     ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7684	  ffebad_finish ();
7685	}
7686      /* Fall through. */
7687    case FFEINFO_kindtypeANY:
7688      e->u.operand = ffebld_new_any ();
7689      ffebld_set_info (e->u.operand, ffeinfo_new_any ());
7690      break;
7691    }
7692  ffeexpr_exprstack_push_operand_ (e);
7693
7694  /* Now, if the token is a close parenthese, we're in great shape so return
7695     the next handler. */
7696
7697  if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7698    return (ffelexHandler) ffeexpr_token_binary_;
7699
7700  /* Oops, naughty user didn't specify the close paren! */
7701
7702  if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7703    {
7704      ffebad_here (0, ffelex_token_where_line (t),
7705		   ffelex_token_where_column (t));
7706      ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7707		   ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7708      ffebad_finish ();
7709    }
7710
7711  return
7712    (ffelexHandler) ffeexpr_find_close_paren_ (t,
7713					       (ffelexHandler)
7714					       ffeexpr_token_binary_);
7715}
7716
7717/* ffeexpr_cb_close_paren_ci_ -- OPEN_PAREN expr (possible complex or
7718				    implied-DO construct)
7719
7720   Pass it to ffeexpr_rhs as the callback routine.
7721
7722   Makes sure the end token is close-paren and swallows it, or a comma
7723   and handles complex/implied-do possibilities, else issues
7724   an error message and doesn't swallow the token (passing it along instead).  */
7725
7726static ffelexHandler
7727ffeexpr_cb_close_paren_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
7728{
7729  ffeexprContext ctx;
7730
7731  /* First check to see if this is a possible complex or implied-DO entity.
7732     It is if the token is a comma. */
7733
7734  if (ffelex_token_type (t) == FFELEX_typeCOMMA)
7735    {
7736      switch (ffeexpr_stack_->context)
7737	{
7738	case FFEEXPR_contextIOLIST:
7739	case FFEEXPR_contextIMPDOITEM_:
7740	  ctx = FFEEXPR_contextIMPDOITEM_;
7741	  break;
7742
7743	case FFEEXPR_contextIOLISTDF:
7744	case FFEEXPR_contextIMPDOITEMDF_:
7745	  ctx = FFEEXPR_contextIMPDOITEMDF_;
7746	  break;
7747
7748	default:
7749	  assert ("bad context" == NULL);
7750	  ctx = FFEEXPR_contextIMPDOITEM_;
7751	  break;
7752	}
7753
7754      ffeexpr_stack_->tokens[0] = ffelex_token_use (ft);
7755      ffeexpr_stack_->expr = expr;
7756      return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7757					  ctx, ffeexpr_cb_comma_ci_);
7758    }
7759
7760  ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
7761  return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
7762}
7763
7764/* ffeexpr_cb_comma_ci_ -- OPEN_PAREN expr COMMA expr
7765
7766   Pass it to ffeexpr_rhs as the callback routine.
7767
7768   If this token is not a comma, we have a complex constant (or an attempt
7769   at one), so handle it accordingly, displaying error messages if the token
7770   is not a close-paren.  If we have a comma here, it is an attempt at an
7771   implied-DO, so start making a list accordingly.  Oh, it might be an
7772   equal sign also, meaning an implied-DO with only one item in its list.  */
7773
7774static ffelexHandler
7775ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
7776{
7777  ffebld fexpr;
7778
7779  /* First check to see if this is a possible complex constant.	 It is if the
7780     token is not a comma or an equals sign, in which case it should be a
7781     close-paren. */
7782
7783  if ((ffelex_token_type (t) != FFELEX_typeCOMMA)
7784      && (ffelex_token_type (t) != FFELEX_typeEQUALS))
7785    {
7786      ffeexpr_stack_->tokens[1] = ffeexpr_stack_->tokens[0];
7787      ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
7788      return (ffelexHandler) ffeexpr_cb_comma_c_ (ft, expr, t);
7789    }
7790
7791  /* Here we have either EQUALS or COMMA, meaning we are in an implied-DO
7792     construct.	 Make a list and handle accordingly. */
7793
7794  ffelex_token_kill (ffeexpr_stack_->tokens[0]);
7795  fexpr = ffeexpr_stack_->expr;
7796  ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7797  ffebld_append_item (&ffeexpr_stack_->bottom, fexpr);
7798  return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
7799}
7800
7801/* ffeexpr_cb_comma_i_ -- OPEN_PAREN expr
7802
7803   Pass it to ffeexpr_rhs as the callback routine.
7804
7805   Handle first item in an implied-DO construct.  */
7806
7807static ffelexHandler
7808ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr, ffelexToken t)
7809{
7810  if (ffelex_token_type (t) != FFELEX_typeCOMMA)
7811    {
7812      if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7813	{
7814	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7815	  ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7816		   ffelex_token_where_column (ffeexpr_stack_->first_token));
7817	  ffebad_finish ();
7818	}
7819      ffebld_end_list (&ffeexpr_stack_->bottom);
7820      ffeexpr_stack_->expr = ffebld_new_any ();
7821      ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7822      if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7823	return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7824      return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7825    }
7826
7827  return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
7828}
7829
7830/* ffeexpr_cb_comma_i_1_ -- OPEN_PAREN expr
7831
7832   Pass it to ffeexpr_rhs as the callback routine.
7833
7834   Handle first item in an implied-DO construct.  */
7835
7836static ffelexHandler
7837ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr, ffelexToken t)
7838{
7839  ffeexprContext ctxi;
7840  ffeexprContext ctxc;
7841
7842  switch (ffeexpr_stack_->context)
7843    {
7844    case FFEEXPR_contextDATA:
7845    case FFEEXPR_contextDATAIMPDOITEM_:
7846      ctxi = FFEEXPR_contextDATAIMPDOITEM_;
7847      ctxc = FFEEXPR_contextDATAIMPDOCTRL_;
7848      break;
7849
7850    case FFEEXPR_contextIOLIST:
7851    case FFEEXPR_contextIMPDOITEM_:
7852      ctxi = FFEEXPR_contextIMPDOITEM_;
7853      ctxc = FFEEXPR_contextIMPDOCTRL_;
7854      break;
7855
7856    case FFEEXPR_contextIOLISTDF:
7857    case FFEEXPR_contextIMPDOITEMDF_:
7858      ctxi = FFEEXPR_contextIMPDOITEMDF_;
7859      ctxc = FFEEXPR_contextIMPDOCTRL_;
7860      break;
7861
7862    default:
7863      assert ("bad context" == NULL);
7864      ctxi = FFEEXPR_context;
7865      ctxc = FFEEXPR_context;
7866      break;
7867    }
7868
7869  switch (ffelex_token_type (t))
7870    {
7871    case FFELEX_typeCOMMA:
7872      ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7873      if (ffeexpr_stack_->is_rhs)
7874	return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7875					    ctxi, ffeexpr_cb_comma_i_1_);
7876      return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7877					  ctxi, ffeexpr_cb_comma_i_1_);
7878
7879    case FFELEX_typeEQUALS:
7880      ffebld_end_list (&ffeexpr_stack_->bottom);
7881
7882      /* Complain if implied-DO variable in list of items to be read.  */
7883
7884      if ((ctxc == FFEEXPR_contextIMPDOCTRL_) && !ffeexpr_stack_->is_rhs)
7885	ffeexpr_check_impdo_ (ffeexpr_stack_->expr,
7886			      ffeexpr_stack_->first_token, expr, ft);
7887
7888      /* Set doiter flag for all appropriate SYMTERs.  */
7889
7890      ffeexpr_update_impdo_ (ffeexpr_stack_->expr, expr);
7891
7892      ffeexpr_stack_->expr = ffebld_new_impdo (ffeexpr_stack_->expr, NULL);
7893      ffebld_set_info (ffeexpr_stack_->expr,
7894		       ffeinfo_new (FFEINFO_basictypeNONE,
7895				    FFEINFO_kindtypeNONE,
7896				    0,
7897				    FFEINFO_kindNONE,
7898				    FFEINFO_whereNONE,
7899				    FFETARGET_charactersizeNONE));
7900      ffebld_init_list (&(ffebld_right (ffeexpr_stack_->expr)),
7901			&ffeexpr_stack_->bottom);
7902      ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7903      return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7904					  ctxc, ffeexpr_cb_comma_i_2_);
7905
7906    default:
7907      if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7908	{
7909	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7910	  ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7911		   ffelex_token_where_column (ffeexpr_stack_->first_token));
7912	  ffebad_finish ();
7913	}
7914      ffebld_end_list (&ffeexpr_stack_->bottom);
7915      ffeexpr_stack_->expr = ffebld_new_any ();
7916      ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7917      if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7918	return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7919      return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7920    }
7921}
7922
7923/* ffeexpr_cb_comma_i_2_ -- OPEN_PAREN expr-list EQUALS expr
7924
7925   Pass it to ffeexpr_rhs as the callback routine.
7926
7927   Handle start-value in an implied-DO construct.  */
7928
7929static ffelexHandler
7930ffeexpr_cb_comma_i_2_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7931{
7932  ffeexprContext ctx;
7933
7934  switch (ffeexpr_stack_->context)
7935    {
7936    case FFEEXPR_contextDATA:
7937    case FFEEXPR_contextDATAIMPDOITEM_:
7938      ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7939      break;
7940
7941    case FFEEXPR_contextIOLIST:
7942    case FFEEXPR_contextIOLISTDF:
7943    case FFEEXPR_contextIMPDOITEM_:
7944    case FFEEXPR_contextIMPDOITEMDF_:
7945      ctx = FFEEXPR_contextIMPDOCTRL_;
7946      break;
7947
7948    default:
7949      assert ("bad context" == NULL);
7950      ctx = FFEEXPR_context;
7951      break;
7952    }
7953
7954  switch (ffelex_token_type (t))
7955    {
7956    case FFELEX_typeCOMMA:
7957      ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7958      return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7959					  ctx, ffeexpr_cb_comma_i_3_);
7960      break;
7961
7962    default:
7963      if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7964	{
7965	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7966	  ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7967		   ffelex_token_where_column (ffeexpr_stack_->first_token));
7968	  ffebad_finish ();
7969	}
7970      ffebld_end_list (&ffeexpr_stack_->bottom);
7971      ffeexpr_stack_->expr = ffebld_new_any ();
7972      ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7973      if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7974	return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7975      return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7976    }
7977}
7978
7979/* ffeexpr_cb_comma_i_3_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7980
7981   Pass it to ffeexpr_rhs as the callback routine.
7982
7983   Handle end-value in an implied-DO construct.	 */
7984
7985static ffelexHandler
7986ffeexpr_cb_comma_i_3_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7987{
7988  ffeexprContext ctx;
7989
7990  switch (ffeexpr_stack_->context)
7991    {
7992    case FFEEXPR_contextDATA:
7993    case FFEEXPR_contextDATAIMPDOITEM_:
7994      ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7995      break;
7996
7997    case FFEEXPR_contextIOLIST:
7998    case FFEEXPR_contextIOLISTDF:
7999    case FFEEXPR_contextIMPDOITEM_:
8000    case FFEEXPR_contextIMPDOITEMDF_:
8001      ctx = FFEEXPR_contextIMPDOCTRL_;
8002      break;
8003
8004    default:
8005      assert ("bad context" == NULL);
8006      ctx = FFEEXPR_context;
8007      break;
8008    }
8009
8010  switch (ffelex_token_type (t))
8011    {
8012    case FFELEX_typeCOMMA:
8013      ffebld_append_item (&ffeexpr_stack_->bottom, expr);
8014      return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8015					  ctx, ffeexpr_cb_comma_i_4_);
8016      break;
8017
8018    case FFELEX_typeCLOSE_PAREN:
8019      ffebld_append_item (&ffeexpr_stack_->bottom, expr);
8020      return (ffelexHandler) ffeexpr_cb_comma_i_4_ (NULL, NULL, t);
8021      break;
8022
8023    default:
8024      if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
8025	{
8026	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8027	  ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
8028		   ffelex_token_where_column (ffeexpr_stack_->first_token));
8029	  ffebad_finish ();
8030	}
8031      ffebld_end_list (&ffeexpr_stack_->bottom);
8032      ffeexpr_stack_->expr = ffebld_new_any ();
8033      ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
8034      if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
8035	return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
8036      return (ffelexHandler) ffeexpr_cb_comma_i_5_;
8037    }
8038}
8039
8040/* ffeexpr_cb_comma_i_4_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
8041			       [COMMA expr]
8042
8043   Pass it to ffeexpr_rhs as the callback routine.
8044
8045   Handle incr-value in an implied-DO construct.  */
8046
8047static ffelexHandler
8048ffeexpr_cb_comma_i_4_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
8049{
8050  switch (ffelex_token_type (t))
8051    {
8052    case FFELEX_typeCLOSE_PAREN:
8053      ffebld_append_item (&ffeexpr_stack_->bottom, expr);
8054      ffebld_end_list (&ffeexpr_stack_->bottom);
8055      {
8056	ffebld item;
8057
8058	for (item = ffebld_left (ffeexpr_stack_->expr);
8059	     item != NULL;
8060	     item = ffebld_trail (item))
8061	  if (ffebld_op (ffebld_head (item)) == FFEBLD_opANY)
8062	    goto replace_with_any;	/* :::::::::::::::::::: */
8063
8064	for (item = ffebld_right (ffeexpr_stack_->expr);
8065	     item != NULL;
8066	     item = ffebld_trail (item))
8067	  if ((ffebld_head (item) != NULL)	/* Increment may be NULL. */
8068	      && (ffebld_op (ffebld_head (item)) == FFEBLD_opANY))
8069	    goto replace_with_any;	/* :::::::::::::::::::: */
8070      }
8071      break;
8072
8073    default:
8074      if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
8075	{
8076	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8077	  ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
8078		   ffelex_token_where_column (ffeexpr_stack_->first_token));
8079	  ffebad_finish ();
8080	}
8081      ffebld_end_list (&ffeexpr_stack_->bottom);
8082
8083    replace_with_any:		/* :::::::::::::::::::: */
8084
8085      ffeexpr_stack_->expr = ffebld_new_any ();
8086      ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
8087      break;
8088    }
8089
8090  if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
8091    return (ffelexHandler) ffeexpr_cb_comma_i_5_;
8092  return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
8093}
8094
8095/* ffeexpr_cb_comma_i_5_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
8096			       [COMMA expr] CLOSE_PAREN
8097
8098   Pass it to ffeexpr_rhs as the callback routine.
8099
8100   Collects token following implied-DO construct for callback function.	 */
8101
8102static ffelexHandler
8103ffeexpr_cb_comma_i_5_ (ffelexToken t)
8104{
8105  ffeexprCallback callback;
8106  ffeexprStack_ s;
8107  ffelexHandler next;
8108  ffelexToken ft;
8109  ffebld expr;
8110  bool terminate;
8111
8112  switch (ffeexpr_stack_->context)
8113    {
8114    case FFEEXPR_contextDATA:
8115    case FFEEXPR_contextDATAIMPDOITEM_:
8116      terminate = TRUE;
8117      break;
8118
8119    case FFEEXPR_contextIOLIST:
8120    case FFEEXPR_contextIOLISTDF:
8121    case FFEEXPR_contextIMPDOITEM_:
8122    case FFEEXPR_contextIMPDOITEMDF_:
8123      terminate = FALSE;
8124      break;
8125
8126    default:
8127      assert ("bad context" == NULL);
8128      terminate = FALSE;
8129      break;
8130    }
8131
8132  ffebld_pool_pop ();
8133  callback = ffeexpr_stack_->callback;
8134  ft = ffeexpr_stack_->first_token;
8135  expr = ffeexpr_stack_->expr;
8136  s = ffeexpr_stack_->previous;
8137  malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
8138		  sizeof (*ffeexpr_stack_));
8139  ffeexpr_stack_ = s;
8140  next = (ffelexHandler) (*callback) (ft, expr, t);
8141  ffelex_token_kill (ft);
8142  if (terminate)
8143    {
8144      ffesymbol_drive_sfnames (ffeexpr_check_impctrl_);
8145      --ffeexpr_level_;
8146      if (ffeexpr_level_ == 0)
8147	ffe_terminate_4 ();
8148    }
8149  return (ffelexHandler) next;
8150}
8151
8152/* ffeexpr_cb_end_loc_ -- Handle end of %LOC subexpression
8153
8154   Makes sure the end token is close-paren and swallows it, else issues
8155   an error message and doesn't swallow the token (passing it along instead).
8156   In either case wraps up subexpression construction by enclosing the
8157   ffebld expression in a %LOC.	 */
8158
8159static ffelexHandler
8160ffeexpr_cb_end_loc_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
8161{
8162  ffeexprExpr_ e;
8163
8164  /* First push the (%LOC) expression as an operand onto the expression
8165     stack. */
8166
8167  e = ffeexpr_expr_new_ ();
8168  e->type = FFEEXPR_exprtypeOPERAND_;
8169  e->token = ffeexpr_stack_->tokens[0];
8170  e->u.operand = ffebld_new_percent_loc (expr);
8171  ffebld_set_info (e->u.operand,
8172		   ffeinfo_new (FFEINFO_basictypeINTEGER,
8173				ffecom_pointer_kind (),
8174				0,
8175				FFEINFO_kindENTITY,
8176				FFEINFO_whereFLEETING,
8177				FFETARGET_charactersizeNONE));
8178#if 0				/* ~~ */
8179  e->u.operand = ffeexpr_collapse_percent_loc (e->u.operand, ft);
8180#endif
8181  ffeexpr_exprstack_push_operand_ (e);
8182
8183  /* Now, if the token is a close parenthese, we're in great shape so return
8184     the next handler. */
8185
8186  if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
8187    {
8188      ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8189      return (ffelexHandler) ffeexpr_token_binary_;
8190    }
8191
8192  /* Oops, naughty user didn't specify the close paren! */
8193
8194  if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
8195    {
8196      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8197      ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
8198		   ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
8199      ffebad_finish ();
8200    }
8201
8202  ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8203  return
8204    (ffelexHandler) ffeexpr_find_close_paren_ (t,
8205					       (ffelexHandler)
8206					       ffeexpr_token_binary_);
8207}
8208
8209/* ffeexpr_cb_end_notloc_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
8210
8211   Should be CLOSE_PAREN, and make sure expr isn't a %(VAL,REF,DESCR).  */
8212
8213static ffelexHandler
8214ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr, ffelexToken t)
8215{
8216  ffeexprExpr_ e;
8217  ffebldOp op;
8218
8219  /* If expression is itself a %(VAL,REF,DESCR), complain and strip off all
8220     such things until the lowest-level expression is reached.  */
8221
8222  op = ffebld_op (expr);
8223  if ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
8224      || (op == FFEBLD_opPERCENT_DESCR))
8225    {
8226      if (ffebad_start (FFEBAD_NESTED_PERCENT))
8227	{
8228	  ffebad_here (0, ffelex_token_where_line (ft),
8229		       ffelex_token_where_column (ft));
8230	  ffebad_finish ();
8231	}
8232
8233      do
8234	{
8235	  expr = ffebld_left (expr);
8236	  op = ffebld_op (expr);
8237	}
8238      while ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
8239	     || (op == FFEBLD_opPERCENT_DESCR));
8240    }
8241
8242  /* Push the expression as an operand onto the expression stack. */
8243
8244  e = ffeexpr_expr_new_ ();
8245  e->type = FFEEXPR_exprtypeOPERAND_;
8246  e->token = ffeexpr_stack_->tokens[0];
8247  switch (ffeexpr_stack_->percent)
8248    {
8249    case FFEEXPR_percentVAL_:
8250      e->u.operand = ffebld_new_percent_val (expr);
8251      break;
8252
8253    case FFEEXPR_percentREF_:
8254      e->u.operand = ffebld_new_percent_ref (expr);
8255      break;
8256
8257    case FFEEXPR_percentDESCR_:
8258      e->u.operand = ffebld_new_percent_descr (expr);
8259      break;
8260
8261    default:
8262      assert ("%lossage" == NULL);
8263      e->u.operand = expr;
8264      break;
8265    }
8266  ffebld_set_info (e->u.operand, ffebld_info (expr));
8267#if 0				/* ~~ */
8268  e->u.operand = ffeexpr_collapse_percent_ ? ? ? (e->u.operand, ft);
8269#endif
8270  ffeexpr_exprstack_push_operand_ (e);
8271
8272  /* Now, if the token is a close parenthese, we're in great shape so return
8273     the next handler. */
8274
8275  if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
8276    return (ffelexHandler) ffeexpr_cb_end_notloc_1_;
8277
8278  /* Oops, naughty user didn't specify the close paren! */
8279
8280  if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
8281    {
8282      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8283      ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
8284		   ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
8285      ffebad_finish ();
8286    }
8287
8288  ffebld_set_op (e->u.operand, FFEBLD_opPERCENT_LOC);
8289
8290  switch (ffeexpr_stack_->context)
8291    {
8292    case FFEEXPR_contextACTUALARG_:
8293      ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8294      break;
8295
8296    case FFEEXPR_contextINDEXORACTUALARG_:
8297      ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8298      break;
8299
8300    case FFEEXPR_contextSFUNCDEFACTUALARG_:
8301      ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8302      break;
8303
8304    case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8305      ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8306      break;
8307
8308    default:
8309      assert ("bad context?!?!" == NULL);
8310      break;
8311    }
8312
8313  ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8314  return
8315    (ffelexHandler) ffeexpr_find_close_paren_ (t,
8316					       (ffelexHandler)
8317					       ffeexpr_cb_end_notloc_1_);
8318}
8319
8320/* ffeexpr_cb_end_notloc_1_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
8321   CLOSE_PAREN
8322
8323   Should be COMMA or CLOSE_PAREN, else change back to %LOC.  */
8324
8325static ffelexHandler
8326ffeexpr_cb_end_notloc_1_ (ffelexToken t)
8327{
8328  switch (ffelex_token_type (t))
8329    {
8330    case FFELEX_typeCOMMA:
8331    case FFELEX_typeCLOSE_PAREN:
8332      switch (ffeexpr_stack_->context)
8333	{
8334	case FFEEXPR_contextACTUALARG_:
8335	case FFEEXPR_contextSFUNCDEFACTUALARG_:
8336	  break;
8337
8338	case FFEEXPR_contextINDEXORACTUALARG_:
8339	  ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
8340	  break;
8341
8342	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8343	  ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
8344	  break;
8345
8346	default:
8347	  assert ("bad context?!?!" == NULL);
8348	  break;
8349	}
8350      break;
8351
8352    default:
8353      if (ffebad_start (FFEBAD_INVALID_PERCENT))
8354	{
8355	  ffebad_here (0,
8356		       ffelex_token_where_line (ffeexpr_stack_->first_token),
8357		   ffelex_token_where_column (ffeexpr_stack_->first_token));
8358	  ffebad_string (ffelex_token_text (ffeexpr_stack_->tokens[1]));
8359	  ffebad_finish ();
8360	}
8361
8362      ffebld_set_op (ffeexpr_stack_->exprstack->u.operand,
8363		     FFEBLD_opPERCENT_LOC);
8364
8365      switch (ffeexpr_stack_->context)
8366	{
8367	case FFEEXPR_contextACTUALARG_:
8368	  ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8369	  break;
8370
8371	case FFEEXPR_contextINDEXORACTUALARG_:
8372	  ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8373	  break;
8374
8375	case FFEEXPR_contextSFUNCDEFACTUALARG_:
8376	  ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8377	  break;
8378
8379	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8380	  ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8381	  break;
8382
8383	default:
8384	  assert ("bad context?!?!" == NULL);
8385	  break;
8386	}
8387    }
8388
8389  ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8390  return
8391    (ffelexHandler) ffeexpr_token_binary_ (t);
8392}
8393
8394/* Process DATA implied-DO iterator variables as this implied-DO level
8395   terminates.  At this point, ffeexpr_level_ == 1 when we see the
8396   last right-paren in "DATA (A(I),I=1,10)/.../".  */
8397
8398static ffesymbol
8399ffeexpr_check_impctrl_ (ffesymbol s)
8400{
8401  assert (s != NULL);
8402  assert (ffesymbol_sfdummyparent (s) != NULL);
8403
8404  switch (ffesymbol_state (s))
8405    {
8406    case FFESYMBOL_stateNONE:	/* Used as iterator already. Now let symbol
8407				   be used as iterator at any level at or
8408				   innermore than the outermost of the
8409				   current level and the symbol's current
8410				   level. */
8411      if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
8412	{
8413	  ffesymbol_signal_change (s);
8414	  ffesymbol_set_maxentrynum (s, ffeexpr_level_);
8415	  ffesymbol_signal_unreported (s);
8416	}
8417      break;
8418
8419    case FFESYMBOL_stateSEEN:	/* Seen already in this or other implied-DO.
8420				   Error if at outermost level, else it can
8421				   still become an iterator. */
8422      if ((ffeexpr_level_ == 1)
8423	  && ffebad_start (FFEBAD_BAD_IMPDCL))
8424	{
8425	  ffebad_string (ffesymbol_text (s));
8426	  ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
8427	  ffebad_finish ();
8428	}
8429      break;
8430
8431    case FFESYMBOL_stateUNCERTAIN:	/* Iterator. */
8432      assert (ffeexpr_level_ <= ffesymbol_maxentrynum (s));
8433      ffesymbol_signal_change (s);
8434      ffesymbol_set_state (s, FFESYMBOL_stateNONE);
8435      ffesymbol_signal_unreported (s);
8436      break;
8437
8438    case FFESYMBOL_stateUNDERSTOOD:
8439      break;			/* ANY. */
8440
8441    default:
8442      assert ("Sasha Foo!!" == NULL);
8443      break;
8444    }
8445
8446  return s;
8447}
8448
8449/* Issue diagnostic if implied-DO variable appears in list of lhs
8450   expressions (as in "READ *, (I,I=1,10)").  */
8451
8452static void
8453ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
8454		      ffebld dovar, ffelexToken dovar_t)
8455{
8456  ffebld item;
8457  ffesymbol dovar_sym;
8458  int itemnum;
8459
8460  if (ffebld_op (dovar) != FFEBLD_opSYMTER)
8461    return;			/* Presumably opANY. */
8462
8463  dovar_sym = ffebld_symter (dovar);
8464
8465  for (itemnum = 1; list != NULL; list = ffebld_trail (list), ++itemnum)
8466    {
8467      if (((item = ffebld_head (list)) != NULL)
8468	  && (ffebld_op (item) == FFEBLD_opSYMTER)
8469	  && (ffebld_symter (item) == dovar_sym))
8470	{
8471	  char itemno[20];
8472
8473	  sprintf (&itemno[0], "%d", itemnum);
8474	  if (ffebad_start (FFEBAD_DOITER_IMPDO))
8475	    {
8476	      ffebad_here (0, ffelex_token_where_line (list_t),
8477			   ffelex_token_where_column (list_t));
8478	      ffebad_here (1, ffelex_token_where_line (dovar_t),
8479			   ffelex_token_where_column (dovar_t));
8480	      ffebad_string (ffesymbol_text (dovar_sym));
8481	      ffebad_string (itemno);
8482	      ffebad_finish ();
8483	    }
8484	}
8485    }
8486}
8487
8488/* Decorate any SYMTERs referencing the DO variable with the "doiter"
8489   flag.  */
8490
8491static void
8492ffeexpr_update_impdo_ (ffebld list, ffebld dovar)
8493{
8494  ffesymbol dovar_sym;
8495
8496  if (ffebld_op (dovar) != FFEBLD_opSYMTER)
8497    return;			/* Presumably opANY. */
8498
8499  dovar_sym = ffebld_symter (dovar);
8500
8501  ffeexpr_update_impdo_sym_ (list, dovar_sym);	/* Recurse! */
8502}
8503
8504/* Recursive function to update any expr so SYMTERs have "doiter" flag
8505   if they refer to the given variable.	 */
8506
8507static void
8508ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar)
8509{
8510  tail_recurse:			/* :::::::::::::::::::: */
8511
8512  if (expr == NULL)
8513    return;
8514
8515  switch (ffebld_op (expr))
8516    {
8517    case FFEBLD_opSYMTER:
8518      if (ffebld_symter (expr) == dovar)
8519	ffebld_symter_set_is_doiter (expr, TRUE);
8520      break;
8521
8522    case FFEBLD_opITEM:
8523      ffeexpr_update_impdo_sym_ (ffebld_head (expr), dovar);
8524      expr = ffebld_trail (expr);
8525      goto tail_recurse;	/* :::::::::::::::::::: */
8526
8527    default:
8528      break;
8529    }
8530
8531  switch (ffebld_arity (expr))
8532    {
8533    case 2:
8534      ffeexpr_update_impdo_sym_ (ffebld_left (expr), dovar);
8535      expr = ffebld_right (expr);
8536      goto tail_recurse;	/* :::::::::::::::::::: */
8537
8538    case 1:
8539      expr = ffebld_left (expr);
8540      goto tail_recurse;	/* :::::::::::::::::::: */
8541
8542    default:
8543      break;
8544    }
8545
8546  return;
8547}
8548
8549/* ffeexpr_context_outer_ -- Determine context of stack entry, skipping PARENs
8550
8551   if (ffeexpr_context_outer_(ffeexpr_stack_) == FFEEXPR_contextIF)
8552       // After zero or more PAREN_ contexts, an IF context exists  */
8553
8554static ffeexprContext
8555ffeexpr_context_outer_ (ffeexprStack_ s)
8556{
8557  assert (s != NULL);
8558
8559  for (;;)
8560    {
8561      switch (s->context)
8562	{
8563	case FFEEXPR_contextPAREN_:
8564	case FFEEXPR_contextPARENFILENUM_:
8565	case FFEEXPR_contextPARENFILEUNIT_:
8566	  break;
8567
8568	default:
8569	  return s->context;
8570	}
8571      s = s->previous;
8572      assert (s != NULL);
8573    }
8574}
8575
8576/* ffeexpr_percent_ -- Look up name in list of %FOO possibilities
8577
8578   ffeexprPercent_ p;
8579   ffelexToken t;
8580   p = ffeexpr_percent_(t);
8581
8582   Returns the identifier for the name, or the NONE identifier.	 */
8583
8584static ffeexprPercent_
8585ffeexpr_percent_ (ffelexToken t)
8586{
8587  const char *p;
8588
8589  switch (ffelex_token_length (t))
8590    {
8591    case 3:
8592      switch (*(p = ffelex_token_text (t)))
8593	{
8594	case FFESRC_CASE_MATCH_INIT ('L', 'l', match_3l, no_match_3):
8595	  if ((ffesrc_char_match_noninit (*++p, 'O', 'o'))
8596	      && (ffesrc_char_match_noninit (*++p, 'C', 'c')))
8597	    return FFEEXPR_percentLOC_;
8598	  return FFEEXPR_percentNONE_;
8599
8600	case FFESRC_CASE_MATCH_INIT ('R', 'r', match_3r, no_match_3):
8601	  if ((ffesrc_char_match_noninit (*++p, 'E', 'e'))
8602	      && (ffesrc_char_match_noninit (*++p, 'F', 'f')))
8603	    return FFEEXPR_percentREF_;
8604	  return FFEEXPR_percentNONE_;
8605
8606	case FFESRC_CASE_MATCH_INIT ('V', 'v', match_3v, no_match_3):
8607	  if ((ffesrc_char_match_noninit (*++p, 'A', 'a'))
8608	      && (ffesrc_char_match_noninit (*++p, 'L', 'l')))
8609	    return FFEEXPR_percentVAL_;
8610	  return FFEEXPR_percentNONE_;
8611
8612	default:
8613	no_match_3:		/* :::::::::::::::::::: */
8614	  return FFEEXPR_percentNONE_;
8615	}
8616
8617    case 5:
8618      if (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "DESCR",
8619			    "descr", "Descr") == 0)
8620	return FFEEXPR_percentDESCR_;
8621      return FFEEXPR_percentNONE_;
8622
8623    default:
8624      return FFEEXPR_percentNONE_;
8625    }
8626}
8627
8628/* ffeexpr_type_combine -- Binop combine types, check for mythical new COMPLEX
8629
8630   See prototype.
8631
8632   If combining the two basictype/kindtype pairs produces a COMPLEX with an
8633   unsupported kind type, complain and use the default kind type for
8634   COMPLEX.  */
8635
8636void
8637ffeexpr_type_combine (ffeinfoBasictype *xnbt, ffeinfoKindtype *xnkt,
8638		      ffeinfoBasictype lbt, ffeinfoKindtype lkt,
8639		      ffeinfoBasictype rbt, ffeinfoKindtype rkt,
8640		      ffelexToken t)
8641{
8642  ffeinfoBasictype nbt;
8643  ffeinfoKindtype nkt;
8644
8645  nbt = ffeinfo_basictype_combine (lbt, rbt);
8646  if ((nbt == FFEINFO_basictypeCOMPLEX)
8647      && ((lbt == nbt) || (lbt == FFEINFO_basictypeREAL))
8648      && ((rbt == nbt) || (rbt == FFEINFO_basictypeREAL)))
8649    {
8650      nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
8651      if (ffe_is_pedantic_not_90 () && (nkt == FFEINFO_kindtypeREALDOUBLE))
8652	nkt = FFEINFO_kindtypeNONE;	/* Force error. */
8653      switch (nkt)
8654	{
8655#if FFETARGET_okCOMPLEX1
8656	case FFEINFO_kindtypeREAL1:
8657#endif
8658#if FFETARGET_okCOMPLEX2
8659	case FFEINFO_kindtypeREAL2:
8660#endif
8661#if FFETARGET_okCOMPLEX3
8662	case FFEINFO_kindtypeREAL3:
8663#endif
8664#if FFETARGET_okCOMPLEX4
8665	case FFEINFO_kindtypeREAL4:
8666#endif
8667	  break;		/* Fine and dandy. */
8668
8669	default:
8670	  if (t != NULL)
8671	    {
8672	      ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
8673			    ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX);
8674	      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8675	      ffebad_finish ();
8676	    }
8677	  nbt = FFEINFO_basictypeNONE;
8678	  nkt = FFEINFO_kindtypeNONE;
8679	  break;
8680
8681	case FFEINFO_kindtypeANY:
8682	  nkt = FFEINFO_kindtypeREALDEFAULT;
8683	  break;
8684	}
8685    }
8686  else
8687    {				/* The normal stuff. */
8688      if (nbt == lbt)
8689	{
8690	  if (nbt == rbt)
8691	    nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
8692	  else
8693	    nkt = lkt;
8694	}
8695      else if (nbt == rbt)
8696	nkt = rkt;
8697      else
8698	{			/* Let the caller do the complaining. */
8699	  nbt = FFEINFO_basictypeNONE;
8700	  nkt = FFEINFO_kindtypeNONE;
8701	}
8702    }
8703
8704  /* Always a good idea to avoid aliasing problems.  */
8705
8706  *xnbt = nbt;
8707  *xnkt = nkt;
8708}
8709
8710/* ffeexpr_token_first_lhs_ -- First state for lhs expression
8711
8712   Return a pointer to this function to the lexer (ffelex), which will
8713   invoke it for the next token.
8714
8715   Record line and column of first token in expression, then invoke the
8716   initial-state lhs handler.  */
8717
8718static ffelexHandler
8719ffeexpr_token_first_lhs_ (ffelexToken t)
8720{
8721  ffeexpr_stack_->first_token = ffelex_token_use (t);
8722
8723  /* When changing the list of valid initial lhs tokens, check whether to
8724     update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
8725     READ (expr) <token> case -- it assumes it knows which tokens <token> can
8726     be to indicate an lhs (or implied DO), which right now is the set
8727     {NAME,OPEN_PAREN}.
8728
8729     This comment also appears in ffeexpr_token_lhs_. */
8730
8731  switch (ffelex_token_type (t))
8732    {
8733    case FFELEX_typeOPEN_PAREN:
8734      switch (ffeexpr_stack_->context)
8735	{
8736	case FFEEXPR_contextDATA:
8737	  ffe_init_4 ();
8738	  ffeexpr_level_ = 1;	/* Level of DATA implied-DO construct. */
8739	  ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8740	  return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8741			FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
8742
8743	case FFEEXPR_contextDATAIMPDOITEM_:
8744	  ++ffeexpr_level_;	/* Level of DATA implied-DO construct. */
8745	  ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8746	  return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8747			FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
8748
8749	case FFEEXPR_contextIOLIST:
8750	case FFEEXPR_contextIMPDOITEM_:
8751	  ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8752	  return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8753			    FFEEXPR_contextIMPDOITEM_, ffeexpr_cb_comma_i_);
8754
8755	case FFEEXPR_contextIOLISTDF:
8756	case FFEEXPR_contextIMPDOITEMDF_:
8757	  ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8758	  return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8759			  FFEEXPR_contextIMPDOITEMDF_, ffeexpr_cb_comma_i_);
8760
8761	case FFEEXPR_contextFILEEXTFUNC:
8762	  assert (ffeexpr_stack_->exprstack == NULL);
8763	  return (ffelexHandler) ffeexpr_token_first_lhs_1_;
8764
8765	default:
8766	  break;
8767	}
8768      break;
8769
8770    case FFELEX_typeNAME:
8771      switch (ffeexpr_stack_->context)
8772	{
8773	case FFEEXPR_contextFILENAMELIST:
8774	  assert (ffeexpr_stack_->exprstack == NULL);
8775	  return (ffelexHandler) ffeexpr_token_namelist_;
8776
8777	case FFEEXPR_contextFILEEXTFUNC:
8778	  assert (ffeexpr_stack_->exprstack == NULL);
8779	  return (ffelexHandler) ffeexpr_token_first_lhs_1_;
8780
8781	default:
8782	  break;
8783	}
8784      break;
8785
8786    default:
8787      switch (ffeexpr_stack_->context)
8788	{
8789	case FFEEXPR_contextFILEEXTFUNC:
8790	  assert (ffeexpr_stack_->exprstack == NULL);
8791	  return (ffelexHandler) ffeexpr_token_first_lhs_1_;
8792
8793	default:
8794	  break;
8795	}
8796      break;
8797    }
8798
8799  return (ffelexHandler) ffeexpr_token_lhs_ (t);
8800}
8801
8802/* ffeexpr_token_first_lhs_1_ -- NAME
8803
8804   return ffeexpr_token_first_lhs_1_;  // to lexer
8805
8806   Handle NAME as an external function (USEROPEN= VXT extension to OPEN
8807   statement).	*/
8808
8809static ffelexHandler
8810ffeexpr_token_first_lhs_1_ (ffelexToken t)
8811{
8812  ffeexprCallback callback;
8813  ffeexprStack_ s;
8814  ffelexHandler next;
8815  ffelexToken ft;
8816  ffesymbol sy = NULL;
8817  ffebld expr;
8818
8819  ffebld_pool_pop ();
8820  callback = ffeexpr_stack_->callback;
8821  ft = ffeexpr_stack_->first_token;
8822  s = ffeexpr_stack_->previous;
8823
8824  if ((ffelex_token_type (ft) != FFELEX_typeNAME)
8825      || (ffesymbol_attrs (sy = ffeexpr_declare_unadorned_ (ft, FALSE))
8826	  & FFESYMBOL_attrANY))
8827    {
8828      if ((ffelex_token_type (ft) != FFELEX_typeNAME)
8829	  || !(ffesymbol_attrs (sy) & FFESYMBOL_attrsANY))
8830	{
8831	  ffebad_start (FFEBAD_EXPR_WRONG);
8832	  ffebad_here (0, ffelex_token_where_line (ft),
8833		       ffelex_token_where_column (ft));
8834	  ffebad_finish ();
8835	}
8836      expr = ffebld_new_any ();
8837      ffebld_set_info (expr, ffeinfo_new_any ());
8838    }
8839  else
8840    {
8841      expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
8842				FFEINTRIN_impNONE);
8843      ffebld_set_info (expr, ffesymbol_info (sy));
8844    }
8845
8846  malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
8847		  sizeof (*ffeexpr_stack_));
8848  ffeexpr_stack_ = s;
8849
8850  next = (ffelexHandler) (*callback) (ft, expr, t);
8851  ffelex_token_kill (ft);
8852  return (ffelexHandler) next;
8853}
8854
8855/* ffeexpr_token_first_rhs_ -- First state for rhs expression
8856
8857   Record line and column of first token in expression, then invoke the
8858   initial-state rhs handler.
8859
8860   19-Feb-91  JCB  1.1
8861      Allow ASTERISK in PARENFILEUNIT_ case, but only on second level only
8862      (i.e. only as in READ(*), not READ((*))).	 */
8863
8864static ffelexHandler
8865ffeexpr_token_first_rhs_ (ffelexToken t)
8866{
8867  ffesymbol s;
8868
8869  ffeexpr_stack_->first_token = ffelex_token_use (t);
8870
8871  switch (ffelex_token_type (t))
8872    {
8873    case FFELEX_typeASTERISK:
8874      switch (ffeexpr_stack_->context)
8875	{
8876	case FFEEXPR_contextFILEFORMATNML:
8877	  ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8878	  /* Fall through.  */
8879	case FFEEXPR_contextFILEUNIT:
8880	case FFEEXPR_contextDIMLIST:
8881	case FFEEXPR_contextFILEFORMAT:
8882	case FFEEXPR_contextCHARACTERSIZE:
8883	  if (ffeexpr_stack_->previous != NULL)
8884	    break;		/* Valid only on first level. */
8885	  assert (ffeexpr_stack_->exprstack == NULL);
8886	  return (ffelexHandler) ffeexpr_token_first_rhs_1_;
8887
8888	case FFEEXPR_contextPARENFILEUNIT_:
8889	  if (ffeexpr_stack_->previous->previous != NULL)
8890	    break;		/* Valid only on second level. */
8891	  assert (ffeexpr_stack_->exprstack == NULL);
8892	  return (ffelexHandler) ffeexpr_token_first_rhs_1_;
8893
8894	case FFEEXPR_contextACTUALARG_:
8895	  if (ffeexpr_stack_->previous->context
8896	      != FFEEXPR_contextSUBROUTINEREF)
8897	    {
8898	      ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8899	      break;
8900	    }
8901	  assert (ffeexpr_stack_->exprstack == NULL);
8902	  return (ffelexHandler) ffeexpr_token_first_rhs_3_;
8903
8904	case FFEEXPR_contextINDEXORACTUALARG_:
8905	  ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8906	  break;
8907
8908	case FFEEXPR_contextSFUNCDEFACTUALARG_:
8909	  ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8910	  break;
8911
8912	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8913	  ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8914	  break;
8915
8916	default:
8917	  break;
8918	}
8919      break;
8920
8921    case FFELEX_typeOPEN_PAREN:
8922      switch (ffeexpr_stack_->context)
8923	{
8924	case FFEEXPR_contextFILENUMAMBIG:
8925	  return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8926					      FFEEXPR_contextPARENFILENUM_,
8927					      ffeexpr_cb_close_paren_ambig_);
8928
8929	case FFEEXPR_contextFILEUNITAMBIG:
8930	  return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8931					      FFEEXPR_contextPARENFILEUNIT_,
8932					      ffeexpr_cb_close_paren_ambig_);
8933
8934	case FFEEXPR_contextIOLIST:
8935	case FFEEXPR_contextIMPDOITEM_:
8936	  return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8937					      FFEEXPR_contextIMPDOITEM_,
8938					      ffeexpr_cb_close_paren_ci_);
8939
8940	case FFEEXPR_contextIOLISTDF:
8941	case FFEEXPR_contextIMPDOITEMDF_:
8942	  return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8943					      FFEEXPR_contextIMPDOITEMDF_,
8944					      ffeexpr_cb_close_paren_ci_);
8945
8946	case FFEEXPR_contextFILEFORMATNML:
8947	  ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8948	  break;
8949
8950	case FFEEXPR_contextACTUALARG_:
8951	  ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8952	  break;
8953
8954	case FFEEXPR_contextINDEXORACTUALARG_:
8955	  ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8956	  break;
8957
8958	case FFEEXPR_contextSFUNCDEFACTUALARG_:
8959	  ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8960	  break;
8961
8962	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8963	  ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8964	  break;
8965
8966	default:
8967	  break;
8968	}
8969      break;
8970
8971    case FFELEX_typeNUMBER:
8972      switch (ffeexpr_stack_->context)
8973	{
8974	case FFEEXPR_contextFILEFORMATNML:
8975	  ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8976	  /* Fall through.  */
8977	case FFEEXPR_contextFILEFORMAT:
8978	  if (ffeexpr_stack_->previous != NULL)
8979	    break;		/* Valid only on first level. */
8980	  assert (ffeexpr_stack_->exprstack == NULL);
8981	  return (ffelexHandler) ffeexpr_token_first_rhs_2_;
8982
8983	case FFEEXPR_contextACTUALARG_:
8984	  ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8985	  break;
8986
8987	case FFEEXPR_contextINDEXORACTUALARG_:
8988	  ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8989	  break;
8990
8991	case FFEEXPR_contextSFUNCDEFACTUALARG_:
8992	  ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8993	  break;
8994
8995	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8996	  ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8997	  break;
8998
8999	default:
9000	  break;
9001	}
9002      break;
9003
9004    case FFELEX_typeNAME:
9005      switch (ffeexpr_stack_->context)
9006	{
9007	case FFEEXPR_contextFILEFORMATNML:
9008	  assert (ffeexpr_stack_->exprstack == NULL);
9009	  s = ffesymbol_lookup_local (t);
9010	  if ((s != NULL) && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST))
9011	    return (ffelexHandler) ffeexpr_token_namelist_;
9012	  ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
9013	  break;
9014
9015	default:
9016	  break;
9017	}
9018      break;
9019
9020    case FFELEX_typePERCENT:
9021      switch (ffeexpr_stack_->context)
9022	{
9023	case FFEEXPR_contextACTUALARG_:
9024	case FFEEXPR_contextINDEXORACTUALARG_:
9025	case FFEEXPR_contextSFUNCDEFACTUALARG_:
9026	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9027	  return (ffelexHandler) ffeexpr_token_first_rhs_5_;
9028
9029	case FFEEXPR_contextFILEFORMATNML:
9030	  ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
9031	  break;
9032
9033	default:
9034	  break;
9035	}
9036
9037    default:
9038      switch (ffeexpr_stack_->context)
9039	{
9040	case FFEEXPR_contextACTUALARG_:
9041	  ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
9042	  break;
9043
9044	case FFEEXPR_contextINDEXORACTUALARG_:
9045	  ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
9046	  break;
9047
9048	case FFEEXPR_contextSFUNCDEFACTUALARG_:
9049	  ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
9050	  break;
9051
9052	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9053	  ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
9054	  break;
9055
9056	case FFEEXPR_contextFILEFORMATNML:
9057	  ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
9058	  break;
9059
9060	default:
9061	  break;
9062	}
9063      break;
9064    }
9065
9066  return (ffelexHandler) ffeexpr_token_rhs_ (t);
9067}
9068
9069/* ffeexpr_token_first_rhs_1_ -- ASTERISK
9070
9071   return ffeexpr_token_first_rhs_1_;  // to lexer
9072
9073   Return STAR as expression.  */
9074
9075static ffelexHandler
9076ffeexpr_token_first_rhs_1_ (ffelexToken t)
9077{
9078  ffebld expr;
9079  ffeexprCallback callback;
9080  ffeexprStack_ s;
9081  ffelexHandler next;
9082  ffelexToken ft;
9083
9084  expr = ffebld_new_star ();
9085  ffebld_pool_pop ();
9086  callback = ffeexpr_stack_->callback;
9087  ft = ffeexpr_stack_->first_token;
9088  s = ffeexpr_stack_->previous;
9089  malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
9090  ffeexpr_stack_ = s;
9091  next = (ffelexHandler) (*callback) (ft, expr, t);
9092  ffelex_token_kill (ft);
9093  return (ffelexHandler) next;
9094}
9095
9096/* ffeexpr_token_first_rhs_2_ -- NUMBER
9097
9098   return ffeexpr_token_first_rhs_2_;  // to lexer
9099
9100   Return NULL as expression; NUMBER as first (and only) token, unless the
9101   current token is not a terminating token, in which case run normal
9102   expression handling.	 */
9103
9104static ffelexHandler
9105ffeexpr_token_first_rhs_2_ (ffelexToken t)
9106{
9107  ffeexprCallback callback;
9108  ffeexprStack_ s;
9109  ffelexHandler next;
9110  ffelexToken ft;
9111
9112  switch (ffelex_token_type (t))
9113    {
9114    case FFELEX_typeCLOSE_PAREN:
9115    case FFELEX_typeCOMMA:
9116    case FFELEX_typeEOS:
9117    case FFELEX_typeSEMICOLON:
9118      break;
9119
9120    default:
9121      next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9122      return (ffelexHandler) (*next) (t);
9123    }
9124
9125  ffebld_pool_pop ();
9126  callback = ffeexpr_stack_->callback;
9127  ft = ffeexpr_stack_->first_token;
9128  s = ffeexpr_stack_->previous;
9129  malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
9130		  sizeof (*ffeexpr_stack_));
9131  ffeexpr_stack_ = s;
9132  next = (ffelexHandler) (*callback) (ft, NULL, t);
9133  ffelex_token_kill (ft);
9134  return (ffelexHandler) next;
9135}
9136
9137/* ffeexpr_token_first_rhs_3_ -- ASTERISK
9138
9139   return ffeexpr_token_first_rhs_3_;  // to lexer
9140
9141   Expect NUMBER, make LABTOK (with copy of token if not inhibited after
9142   confirming, else NULL).  */
9143
9144static ffelexHandler
9145ffeexpr_token_first_rhs_3_ (ffelexToken t)
9146{
9147  ffelexHandler next;
9148
9149  if (ffelex_token_type (t) != FFELEX_typeNUMBER)
9150    {				/* An error, but let normal processing handle
9151				   it. */
9152      next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9153      return (ffelexHandler) (*next) (t);
9154    }
9155
9156  /* Special case: when we see "*10" as an argument to a subroutine
9157     reference, we confirm the current statement and, if not inhibited at
9158     this point, put a copy of the token into a LABTOK node.  We do this
9159     instead of just resolving the label directly via ffelab and putting it
9160     into a LABTER simply to improve error reporting and consistency in
9161     ffestc.  We put NULL in the LABTOK if we're still inhibited, so ffestb
9162     doesn't have to worry about killing off any tokens when retracting. */
9163
9164  ffest_confirmed ();
9165  if (ffest_is_inhibited ())
9166    ffeexpr_stack_->expr = ffebld_new_labtok (NULL);
9167  else
9168    ffeexpr_stack_->expr = ffebld_new_labtok (ffelex_token_use (t));
9169  ffebld_set_info (ffeexpr_stack_->expr,
9170		   ffeinfo_new (FFEINFO_basictypeNONE,
9171				FFEINFO_kindtypeNONE,
9172				0,
9173				FFEINFO_kindNONE,
9174				FFEINFO_whereNONE,
9175				FFETARGET_charactersizeNONE));
9176
9177  return (ffelexHandler) ffeexpr_token_first_rhs_4_;
9178}
9179
9180/* ffeexpr_token_first_rhs_4_ -- ASTERISK NUMBER
9181
9182   return ffeexpr_token_first_rhs_4_;  // to lexer
9183
9184   Collect/flush appropriate stuff, send token to callback function.  */
9185
9186static ffelexHandler
9187ffeexpr_token_first_rhs_4_ (ffelexToken t)
9188{
9189  ffebld expr;
9190  ffeexprCallback callback;
9191  ffeexprStack_ s;
9192  ffelexHandler next;
9193  ffelexToken ft;
9194
9195  expr = ffeexpr_stack_->expr;
9196  ffebld_pool_pop ();
9197  callback = ffeexpr_stack_->callback;
9198  ft = ffeexpr_stack_->first_token;
9199  s = ffeexpr_stack_->previous;
9200  malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
9201  ffeexpr_stack_ = s;
9202  next = (ffelexHandler) (*callback) (ft, expr, t);
9203  ffelex_token_kill (ft);
9204  return (ffelexHandler) next;
9205}
9206
9207/* ffeexpr_token_first_rhs_5_ -- PERCENT
9208
9209   Should be NAME, or pass through original mechanism.  If NAME is LOC,
9210   pass through original mechanism, otherwise must be VAL, REF, or DESCR,
9211   in which case handle the argument (in parentheses), etc.  */
9212
9213static ffelexHandler
9214ffeexpr_token_first_rhs_5_ (ffelexToken t)
9215{
9216  ffelexHandler next;
9217
9218  if (ffelex_token_type (t) == FFELEX_typeNAME)
9219    {
9220      ffeexprPercent_ p = ffeexpr_percent_ (t);
9221
9222      switch (p)
9223	{
9224	case FFEEXPR_percentNONE_:
9225	case FFEEXPR_percentLOC_:
9226	  break;		/* Treat %LOC as any other expression. */
9227
9228	case FFEEXPR_percentVAL_:
9229	case FFEEXPR_percentREF_:
9230	case FFEEXPR_percentDESCR_:
9231	  ffeexpr_stack_->percent = p;
9232	  ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
9233	  return (ffelexHandler) ffeexpr_token_first_rhs_6_;
9234
9235	default:
9236	  assert ("bad percent?!?" == NULL);
9237	  break;
9238	}
9239    }
9240
9241  switch (ffeexpr_stack_->context)
9242    {
9243    case FFEEXPR_contextACTUALARG_:
9244      ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
9245      break;
9246
9247    case FFEEXPR_contextINDEXORACTUALARG_:
9248      ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
9249      break;
9250
9251    case FFEEXPR_contextSFUNCDEFACTUALARG_:
9252      ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
9253      break;
9254
9255    case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9256      ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
9257      break;
9258
9259    default:
9260      assert ("bad context?!?!" == NULL);
9261      break;
9262    }
9263
9264  next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9265  return (ffelexHandler) (*next) (t);
9266}
9267
9268/* ffeexpr_token_first_rhs_6_ -- PERCENT NAME(VAL,REF,DESCR)
9269
9270   Should be OPEN_PAREN, or pass through original mechanism.  */
9271
9272static ffelexHandler
9273ffeexpr_token_first_rhs_6_ (ffelexToken t)
9274{
9275  ffelexHandler next;
9276  ffelexToken ft;
9277
9278  if (ffelex_token_type (t) == FFELEX_typeOPEN_PAREN)
9279    {
9280      ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
9281      return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
9282					  ffeexpr_stack_->context,
9283					  ffeexpr_cb_end_notloc_);
9284    }
9285
9286  switch (ffeexpr_stack_->context)
9287    {
9288    case FFEEXPR_contextACTUALARG_:
9289      ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
9290      break;
9291
9292    case FFEEXPR_contextINDEXORACTUALARG_:
9293      ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
9294      break;
9295
9296    case FFEEXPR_contextSFUNCDEFACTUALARG_:
9297      ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
9298      break;
9299
9300    case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9301      ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
9302      break;
9303
9304    default:
9305      assert ("bad context?!?!" == NULL);
9306      break;
9307    }
9308
9309  ft = ffeexpr_stack_->tokens[0];
9310  next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9311  next = (ffelexHandler) (*next) (ft);
9312  ffelex_token_kill (ft);
9313  return (ffelexHandler) (*next) (t);
9314}
9315
9316/* ffeexpr_token_namelist_ -- NAME
9317
9318   return ffeexpr_token_namelist_;  // to lexer
9319
9320   Make sure NAME was a valid namelist object, wrap it in a SYMTER and
9321   return.  */
9322
9323static ffelexHandler
9324ffeexpr_token_namelist_ (ffelexToken t)
9325{
9326  ffeexprCallback callback;
9327  ffeexprStack_ s;
9328  ffelexHandler next;
9329  ffelexToken ft;
9330  ffesymbol sy;
9331  ffebld expr;
9332
9333  ffebld_pool_pop ();
9334  callback = ffeexpr_stack_->callback;
9335  ft = ffeexpr_stack_->first_token;
9336  s = ffeexpr_stack_->previous;
9337  malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
9338  ffeexpr_stack_ = s;
9339
9340  sy = ffesymbol_lookup_local (ft);
9341  if ((sy == NULL) || (ffesymbol_kind (sy) != FFEINFO_kindNAMELIST))
9342    {
9343      ffebad_start (FFEBAD_EXPR_WRONG);
9344      ffebad_here (0, ffelex_token_where_line (ft),
9345		   ffelex_token_where_column (ft));
9346      ffebad_finish ();
9347      expr = ffebld_new_any ();
9348      ffebld_set_info (expr, ffeinfo_new_any ());
9349    }
9350  else
9351    {
9352      expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
9353				FFEINTRIN_impNONE);
9354      ffebld_set_info (expr, ffesymbol_info (sy));
9355    }
9356  next = (ffelexHandler) (*callback) (ft, expr, t);
9357  ffelex_token_kill (ft);
9358  return (ffelexHandler) next;
9359}
9360
9361/* ffeexpr_expr_kill_ -- Kill an existing internal expression object
9362
9363   ffeexprExpr_ e;
9364   ffeexpr_expr_kill_(e);
9365
9366   Kills the ffewhere info, if necessary, then kills the object.  */
9367
9368static void
9369ffeexpr_expr_kill_ (ffeexprExpr_ e)
9370{
9371  if (e->token != NULL)
9372    ffelex_token_kill (e->token);
9373  malloc_kill_ks (ffe_pool_program_unit (), e, sizeof (*e));
9374}
9375
9376/* ffeexpr_expr_new_ -- Make a new internal expression object
9377
9378   ffeexprExpr_ e;
9379   e = ffeexpr_expr_new_();
9380
9381   Allocates and initializes a new expression object, returns it.  */
9382
9383static ffeexprExpr_
9384ffeexpr_expr_new_ ()
9385{
9386  ffeexprExpr_ e;
9387
9388  e = (ffeexprExpr_) malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR expr",
9389				    sizeof (*e));
9390  e->previous = NULL;
9391  e->type = FFEEXPR_exprtypeUNKNOWN_;
9392  e->token = NULL;
9393  return e;
9394}
9395
9396/* Verify that call to global is valid, and register whatever
9397   new information about a global might be discoverable by looking
9398   at the call.  */
9399
9400static void
9401ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t)
9402{
9403  int n_args;
9404  ffebld list;
9405  ffebld item;
9406  ffesymbol s;
9407
9408  assert ((ffebld_op (*expr) == FFEBLD_opSUBRREF)
9409	  || (ffebld_op (*expr) == FFEBLD_opFUNCREF));
9410
9411  if (ffebld_op (ffebld_left (*expr)) != FFEBLD_opSYMTER)
9412    return;
9413
9414  if (ffesymbol_retractable ())
9415    return;
9416
9417  s = ffebld_symter (ffebld_left (*expr));
9418  if (ffesymbol_global (s) == NULL)
9419    return;
9420
9421  for (n_args = 0, list = ffebld_right (*expr);
9422       list != NULL;
9423       list = ffebld_trail (list), ++n_args)
9424    ;
9425
9426  if (ffeglobal_proc_ref_nargs (s, n_args, t))
9427    {
9428      ffeglobalArgSummary as;
9429      ffeinfoBasictype bt;
9430      ffeinfoKindtype kt;
9431      bool array;
9432      bool fail = FALSE;
9433
9434      for (n_args = 0, list = ffebld_right (*expr);
9435	   list != NULL;
9436	   list = ffebld_trail (list), ++n_args)
9437	{
9438	  item = ffebld_head (list);
9439	  if (item != NULL)
9440	    {
9441	      bt = ffeinfo_basictype (ffebld_info (item));
9442	      kt = ffeinfo_kindtype (ffebld_info (item));
9443	      array = (ffeinfo_rank (ffebld_info (item)) > 0);
9444	      switch (ffebld_op (item))
9445		{
9446		case FFEBLD_opLABTOK:
9447		case FFEBLD_opLABTER:
9448		  as = FFEGLOBAL_argsummaryALTRTN;
9449		  break;
9450
9451#if 0
9452		  /* No, %LOC(foo) is just like any INTEGER(KIND=7)
9453		     expression, so don't treat it specially.  */
9454		case FFEBLD_opPERCENT_LOC:
9455		  as = FFEGLOBAL_argsummaryPTR;
9456		  break;
9457#endif
9458
9459		case FFEBLD_opPERCENT_VAL:
9460		  as = FFEGLOBAL_argsummaryVAL;
9461		  break;
9462
9463		case FFEBLD_opPERCENT_REF:
9464		  as = FFEGLOBAL_argsummaryREF;
9465		  break;
9466
9467		case FFEBLD_opPERCENT_DESCR:
9468		  as = FFEGLOBAL_argsummaryDESCR;
9469		  break;
9470
9471		case FFEBLD_opFUNCREF:
9472#if 0
9473		  /* No, LOC(foo) is just like any INTEGER(KIND=7)
9474		     expression, so don't treat it specially.  */
9475		  if ((ffebld_op (ffebld_left (item)) == FFEBLD_opSYMTER)
9476		      && (ffesymbol_specific (ffebld_symter (ffebld_left (item)))
9477			  == FFEINTRIN_specLOC))
9478		    {
9479		      as = FFEGLOBAL_argsummaryPTR;
9480		      break;
9481		    }
9482#endif
9483		  /* Fall through.  */
9484		default:
9485		  if (ffebld_op (item) == FFEBLD_opSYMTER)
9486		    {
9487		      as = FFEGLOBAL_argsummaryNONE;
9488
9489		      switch (ffeinfo_kind (ffebld_info (item)))
9490			{
9491			case FFEINFO_kindFUNCTION:
9492			  as = FFEGLOBAL_argsummaryFUNC;
9493			  break;
9494
9495			case FFEINFO_kindSUBROUTINE:
9496			  as = FFEGLOBAL_argsummarySUBR;
9497			  break;
9498
9499			case FFEINFO_kindNONE:
9500			  as = FFEGLOBAL_argsummaryPROC;
9501			  break;
9502
9503			default:
9504			  break;
9505			}
9506
9507		      if (as != FFEGLOBAL_argsummaryNONE)
9508			break;
9509		    }
9510
9511		  if (bt == FFEINFO_basictypeCHARACTER)
9512		    as = FFEGLOBAL_argsummaryDESCR;
9513		  else
9514		    as = FFEGLOBAL_argsummaryREF;
9515		  break;
9516		}
9517	    }
9518	  else
9519	    {
9520	      array = FALSE;
9521	      as = FFEGLOBAL_argsummaryNONE;
9522	      bt = FFEINFO_basictypeNONE;
9523	      kt = FFEINFO_kindtypeNONE;
9524	    }
9525
9526	  if (! ffeglobal_proc_ref_arg (s, n_args, as, bt, kt, array, t))
9527	    fail = TRUE;
9528	}
9529      if (! fail)
9530	return;
9531    }
9532
9533  *expr = ffebld_new_any ();
9534  ffebld_set_info (*expr, ffeinfo_new_any ());
9535}
9536
9537/* Check whether rest of string is all decimal digits.  */
9538
9539static bool
9540ffeexpr_isdigits_ (const char *p)
9541{
9542  for (; *p != '\0'; ++p)
9543    if (! ISDIGIT (*p))
9544      return FALSE;
9545  return TRUE;
9546}
9547
9548/* ffeexpr_exprstack_push_ -- Push an arbitrary expression object onto the stack
9549
9550   ffeexprExpr_ e;
9551   ffeexpr_exprstack_push_(e);
9552
9553   Pushes the expression onto the stack without any analysis of the existing
9554   contents of the stack.  */
9555
9556static void
9557ffeexpr_exprstack_push_ (ffeexprExpr_ e)
9558{
9559  e->previous = ffeexpr_stack_->exprstack;
9560  ffeexpr_stack_->exprstack = e;
9561}
9562
9563/* ffeexpr_exprstack_push_operand_ -- Push an operand onto the stack, reduce?
9564
9565   ffeexprExpr_ e;
9566   ffeexpr_exprstack_push_operand_(e);
9567
9568   Pushes the expression already containing an operand (a constant, variable,
9569   or more complicated expression that has already been fully resolved) after
9570   analyzing the stack and checking for possible reduction (which will never
9571   happen here since the highest precedence operator is ** and it has right-
9572   to-left associativity).  */
9573
9574static void
9575ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e)
9576{
9577  ffeexpr_exprstack_push_ (e);
9578#ifdef WEIRD_NONFORTRAN_RULES
9579  if ((ffeexpr_stack_->exprstack != NULL)
9580      && (ffeexpr_stack_->exprstack->expr->type == FFEEXPR_exprtypeBINARY_)
9581      && (ffeexpr_stack_->exprstack->expr->u.operator.prec
9582	  == FFEEXPR_operatorprecedenceHIGHEST_)
9583      && (ffeexpr_stack_->exprstack->expr->u.operator.as
9584	  == FFEEXPR_operatorassociativityL2R_))
9585    ffeexpr_reduce_ ();
9586#endif
9587}
9588
9589/* ffeexpr_exprstack_push_unary_ -- Push a unary operator onto the stack
9590
9591   ffeexprExpr_ e;
9592   ffeexpr_exprstack_push_unary_(e);
9593
9594   Pushes the expression already containing a unary operator.  Reduction can
9595   never happen since unary operators are themselves always R-L; that is, the
9596   top of the expression stack is not an operand, in that it is either empty,
9597   has a binary operator at the top, or a unary operator at the top.  In any
9598   of these cases, reduction is impossible.  */
9599
9600static void
9601ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e)
9602{
9603  if ((ffe_is_pedantic ()
9604       || ffe_is_warn_surprising ())
9605      && (ffeexpr_stack_->exprstack != NULL)
9606      && (ffeexpr_stack_->exprstack->type != FFEEXPR_exprtypeOPERAND_)
9607      && (ffeexpr_stack_->exprstack->u.operator.prec
9608	  <= FFEEXPR_operatorprecedenceLOWARITH_)
9609      && (e->u.operator.prec <= FFEEXPR_operatorprecedenceLOWARITH_))
9610    {
9611      ffebad_start_msg ("Two arithmetic operators in a row at %0 and %1 -- use parentheses",
9612			ffe_is_pedantic ()
9613			? FFEBAD_severityPEDANTIC
9614			: FFEBAD_severityWARNING);
9615      ffebad_here (0,
9616		  ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
9617	       ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
9618      ffebad_here (1,
9619		   ffelex_token_where_line (e->token),
9620		   ffelex_token_where_column (e->token));
9621      ffebad_finish ();
9622    }
9623
9624  ffeexpr_exprstack_push_ (e);
9625}
9626
9627/* ffeexpr_exprstack_push_binary_ -- Push a binary operator onto the stack, reduce?
9628
9629   ffeexprExpr_ e;
9630   ffeexpr_exprstack_push_binary_(e);
9631
9632   Pushes the expression already containing a binary operator after checking
9633   whether reduction is possible.  If the stack is not empty, the top of the
9634   stack must be an operand or syntactic analysis has failed somehow.  If
9635   the operand is preceded by a unary operator of higher (or equal and L-R
9636   associativity) precedence than the new binary operator, then reduce that
9637   preceding operator and its operand(s) before pushing the new binary
9638   operator.  */
9639
9640static void
9641ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e)
9642{
9643  ffeexprExpr_ ce;
9644
9645  if (ffe_is_warn_surprising ()
9646      /* These next two are always true (see assertions below).  */
9647      && (ffeexpr_stack_->exprstack != NULL)
9648      && (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_)
9649      /* If the previous operator is a unary minus, and the binary op
9650	 is of higher precedence, might not do what user expects,
9651	 e.g. "-2**2" is "-(2**2)", i.e. "-4", not "(-2)**2", which would
9652	 yield "4".  */
9653      && (ffeexpr_stack_->exprstack->previous != NULL)
9654      && (ffeexpr_stack_->exprstack->previous->type == FFEEXPR_exprtypeUNARY_)
9655      && (ffeexpr_stack_->exprstack->previous->u.operator.op
9656	  == FFEEXPR_operatorSUBTRACT_)
9657      && (e->u.operator.prec
9658	  < ffeexpr_stack_->exprstack->previous->u.operator.prec))
9659    {
9660      ffebad_start_msg ("Operator at %0 has lower precedence than that at %1 -- use parentheses", FFEBAD_severityWARNING);
9661      ffebad_here (0,
9662	 ffelex_token_where_line (ffeexpr_stack_->exprstack->previous->token),
9663      ffelex_token_where_column (ffeexpr_stack_->exprstack->previous->token));
9664      ffebad_here (1,
9665		   ffelex_token_where_line (e->token),
9666		   ffelex_token_where_column (e->token));
9667      ffebad_finish ();
9668    }
9669
9670again:
9671  assert (ffeexpr_stack_->exprstack != NULL);
9672  assert (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_);
9673  if ((ce = ffeexpr_stack_->exprstack->previous) != NULL)
9674    {
9675      assert (ce->type != FFEEXPR_exprtypeOPERAND_);
9676      if ((ce->u.operator.prec < e->u.operator.prec)
9677	  || ((ce->u.operator.prec == e->u.operator.prec)
9678	      && (e->u.operator.as == FFEEXPR_operatorassociativityL2R_)))
9679	{
9680	  ffeexpr_reduce_ ();
9681	  goto again;	/* :::::::::::::::::::: */
9682	}
9683    }
9684
9685  ffeexpr_exprstack_push_ (e);
9686}
9687
9688/* ffeexpr_reduce_ -- Reduce highest operator w/operands on stack
9689
9690   ffeexpr_reduce_();
9691
9692   Converts operand binop operand or unop operand at top of stack to a
9693   single operand having the appropriate ffebld expression, and makes
9694   sure that the expression is proper (like not trying to add two character
9695   variables, not trying to concatenate two numbers).  Also does the
9696   requisite type-assignment.  */
9697
9698static void
9699ffeexpr_reduce_ ()
9700{
9701  ffeexprExpr_ operand;		/* This is B in -B or A+B. */
9702  ffeexprExpr_ left_operand;	/* When operator is binary, this is A in A+B. */
9703  ffeexprExpr_ operator;	/* This is + in A+B. */
9704  ffebld reduced;		/* This is +(A,B) in A+B or u-(B) in -B. */
9705  ffebldConstant constnode;	/* For checking magical numbers (where mag ==
9706				   -mag). */
9707  ffebld expr;
9708  ffebld left_expr;
9709  bool submag = FALSE;
9710
9711  operand = ffeexpr_stack_->exprstack;
9712  assert (operand != NULL);
9713  assert (operand->type == FFEEXPR_exprtypeOPERAND_);
9714  operator = operand->previous;
9715  assert (operator != NULL);
9716  assert (operator->type != FFEEXPR_exprtypeOPERAND_);
9717  if (operator->type == FFEEXPR_exprtypeUNARY_)
9718    {
9719      expr = operand->u.operand;
9720      switch (operator->u.operator.op)
9721	{
9722	case FFEEXPR_operatorADD_:
9723	  reduced = ffebld_new_uplus (expr);
9724	  if (ffe_is_ugly_logint ())
9725	    reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
9726	  reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
9727	  reduced = ffeexpr_collapse_uplus (reduced, operator->token);
9728	  break;
9729
9730	case FFEEXPR_operatorSUBTRACT_:
9731	  submag = TRUE;	/* Ok to negate a magic number. */
9732	  reduced = ffebld_new_uminus (expr);
9733	  if (ffe_is_ugly_logint ())
9734	    reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
9735	  reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
9736	  reduced = ffeexpr_collapse_uminus (reduced, operator->token);
9737	  break;
9738
9739	case FFEEXPR_operatorNOT_:
9740	  reduced = ffebld_new_not (expr);
9741	  if (ffe_is_ugly_logint ())
9742	    reduced = ffeexpr_reduced_ugly1log_ (reduced, operator, operand);
9743	  reduced = ffeexpr_reduced_bool1_ (reduced, operator, operand);
9744	  reduced = ffeexpr_collapse_not (reduced, operator->token);
9745	  break;
9746
9747	default:
9748	  assert ("unexpected unary op" != NULL);
9749	  reduced = NULL;
9750	  break;
9751	}
9752      if (!submag
9753	  && (ffebld_op (expr) == FFEBLD_opCONTER)
9754	  && (ffebld_conter_orig (expr) == NULL)
9755	  && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
9756	{
9757	  ffetarget_integer_bad_magical (operand->token);
9758	}
9759      ffeexpr_stack_->exprstack = operator->previous;	/* Pops unary-op operand
9760							   off stack. */
9761      ffeexpr_expr_kill_ (operand);
9762      operator->type = FFEEXPR_exprtypeOPERAND_;	/* Convert operator, but
9763							   save */
9764      operator->u.operand = reduced;	/* the line/column ffewhere info. */
9765      ffeexpr_exprstack_push_operand_ (operator);	/* Push it back on
9766							   stack. */
9767    }
9768  else
9769    {
9770      assert (operator->type == FFEEXPR_exprtypeBINARY_);
9771      left_operand = operator->previous;
9772      assert (left_operand != NULL);
9773      assert (left_operand->type == FFEEXPR_exprtypeOPERAND_);
9774      expr = operand->u.operand;
9775      left_expr = left_operand->u.operand;
9776      switch (operator->u.operator.op)
9777	{
9778	case FFEEXPR_operatorADD_:
9779	  reduced = ffebld_new_add (left_expr, expr);
9780	  if (ffe_is_ugly_logint ())
9781	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9782					      operand);
9783	  reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9784					    operand);
9785	  reduced = ffeexpr_collapse_add (reduced, operator->token);
9786	  break;
9787
9788	case FFEEXPR_operatorSUBTRACT_:
9789	  submag = TRUE;	/* Just to pick the right error if magic
9790				   number. */
9791	  reduced = ffebld_new_subtract (left_expr, expr);
9792	  if (ffe_is_ugly_logint ())
9793	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9794					      operand);
9795	  reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9796					    operand);
9797	  reduced = ffeexpr_collapse_subtract (reduced, operator->token);
9798	  break;
9799
9800	case FFEEXPR_operatorMULTIPLY_:
9801	  reduced = ffebld_new_multiply (left_expr, expr);
9802	  if (ffe_is_ugly_logint ())
9803	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9804					      operand);
9805	  reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9806					    operand);
9807	  reduced = ffeexpr_collapse_multiply (reduced, operator->token);
9808	  break;
9809
9810	case FFEEXPR_operatorDIVIDE_:
9811	  reduced = ffebld_new_divide (left_expr, expr);
9812	  if (ffe_is_ugly_logint ())
9813	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9814					      operand);
9815	  reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9816					    operand);
9817	  reduced = ffeexpr_collapse_divide (reduced, operator->token);
9818	  break;
9819
9820	case FFEEXPR_operatorPOWER_:
9821	  reduced = ffebld_new_power (left_expr, expr);
9822	  if (ffe_is_ugly_logint ())
9823	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9824					      operand);
9825	  reduced = ffeexpr_reduced_power_ (reduced, left_operand, operator,
9826					    operand);
9827	  reduced = ffeexpr_collapse_power (reduced, operator->token);
9828	  break;
9829
9830	case FFEEXPR_operatorCONCATENATE_:
9831	  reduced = ffebld_new_concatenate (left_expr, expr);
9832	  reduced = ffeexpr_reduced_concatenate_ (reduced, left_operand, operator,
9833						  operand);
9834	  reduced = ffeexpr_collapse_concatenate (reduced, operator->token);
9835	  break;
9836
9837	case FFEEXPR_operatorLT_:
9838	  reduced = ffebld_new_lt (left_expr, expr);
9839	  if (ffe_is_ugly_logint ())
9840	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9841					      operand);
9842	  reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9843					     operand);
9844	  reduced = ffeexpr_collapse_lt (reduced, operator->token);
9845	  break;
9846
9847	case FFEEXPR_operatorLE_:
9848	  reduced = ffebld_new_le (left_expr, expr);
9849	  if (ffe_is_ugly_logint ())
9850	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9851					      operand);
9852	  reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9853					     operand);
9854	  reduced = ffeexpr_collapse_le (reduced, operator->token);
9855	  break;
9856
9857	case FFEEXPR_operatorEQ_:
9858	  reduced = ffebld_new_eq (left_expr, expr);
9859	  if (ffe_is_ugly_logint ())
9860	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9861					      operand);
9862	  reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
9863					    operand);
9864	  reduced = ffeexpr_collapse_eq (reduced, operator->token);
9865	  break;
9866
9867	case FFEEXPR_operatorNE_:
9868	  reduced = ffebld_new_ne (left_expr, expr);
9869	  if (ffe_is_ugly_logint ())
9870	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9871					      operand);
9872	  reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
9873					    operand);
9874	  reduced = ffeexpr_collapse_ne (reduced, operator->token);
9875	  break;
9876
9877	case FFEEXPR_operatorGT_:
9878	  reduced = ffebld_new_gt (left_expr, expr);
9879	  if (ffe_is_ugly_logint ())
9880	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9881					      operand);
9882	  reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9883					     operand);
9884	  reduced = ffeexpr_collapse_gt (reduced, operator->token);
9885	  break;
9886
9887	case FFEEXPR_operatorGE_:
9888	  reduced = ffebld_new_ge (left_expr, expr);
9889	  if (ffe_is_ugly_logint ())
9890	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9891					      operand);
9892	  reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9893					     operand);
9894	  reduced = ffeexpr_collapse_ge (reduced, operator->token);
9895	  break;
9896
9897	case FFEEXPR_operatorAND_:
9898	  reduced = ffebld_new_and (left_expr, expr);
9899	  if (ffe_is_ugly_logint ())
9900	    reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9901						 operand);
9902	  reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9903					    operand);
9904	  reduced = ffeexpr_collapse_and (reduced, operator->token);
9905	  break;
9906
9907	case FFEEXPR_operatorOR_:
9908	  reduced = ffebld_new_or (left_expr, expr);
9909	  if (ffe_is_ugly_logint ())
9910	    reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9911						 operand);
9912	  reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9913					    operand);
9914	  reduced = ffeexpr_collapse_or (reduced, operator->token);
9915	  break;
9916
9917	case FFEEXPR_operatorXOR_:
9918	  reduced = ffebld_new_xor (left_expr, expr);
9919	  if (ffe_is_ugly_logint ())
9920	    reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9921						 operand);
9922	  reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9923					    operand);
9924	  reduced = ffeexpr_collapse_xor (reduced, operator->token);
9925	  break;
9926
9927	case FFEEXPR_operatorEQV_:
9928	  reduced = ffebld_new_eqv (left_expr, expr);
9929	  if (ffe_is_ugly_logint ())
9930	    reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9931						 operand);
9932	  reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9933					    operand);
9934	  reduced = ffeexpr_collapse_eqv (reduced, operator->token);
9935	  break;
9936
9937	case FFEEXPR_operatorNEQV_:
9938	  reduced = ffebld_new_neqv (left_expr, expr);
9939	  if (ffe_is_ugly_logint ())
9940	    reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9941						 operand);
9942	  reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9943					    operand);
9944	  reduced = ffeexpr_collapse_neqv (reduced, operator->token);
9945	  break;
9946
9947	default:
9948	  assert ("bad bin op" == NULL);
9949	  reduced = expr;
9950	  break;
9951	}
9952      if ((ffebld_op (left_expr) == FFEBLD_opCONTER)
9953	  && (ffebld_conter_orig (expr) == NULL)
9954      && ffebld_constant_is_magical (constnode = ffebld_conter (left_expr)))
9955	{
9956	  if ((left_operand->previous != NULL)
9957	      && (left_operand->previous->type != FFEEXPR_exprtypeOPERAND_)
9958	      && (left_operand->previous->u.operator.op
9959		  == FFEEXPR_operatorSUBTRACT_))
9960	    {
9961	      if (left_operand->previous->type == FFEEXPR_exprtypeUNARY_)
9962		ffetarget_integer_bad_magical_precedence (left_operand->token,
9963							  left_operand->previous->token,
9964							  operator->token);
9965	      else
9966		ffetarget_integer_bad_magical_precedence_binary
9967		  (left_operand->token,
9968		   left_operand->previous->token,
9969		   operator->token);
9970	    }
9971	  else
9972	    ffetarget_integer_bad_magical (left_operand->token);
9973	}
9974      if ((ffebld_op (expr) == FFEBLD_opCONTER)
9975	  && (ffebld_conter_orig (expr) == NULL)
9976	  && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
9977	{
9978	  if (submag)
9979	    ffetarget_integer_bad_magical_binary (operand->token,
9980						  operator->token);
9981	  else
9982	    ffetarget_integer_bad_magical (operand->token);
9983	}
9984      ffeexpr_stack_->exprstack = left_operand->previous;	/* Pops binary-op
9985								   operands off stack. */
9986      ffeexpr_expr_kill_ (left_operand);
9987      ffeexpr_expr_kill_ (operand);
9988      operator->type = FFEEXPR_exprtypeOPERAND_;	/* Convert operator, but
9989							   save */
9990      operator->u.operand = reduced;	/* the line/column ffewhere info. */
9991      ffeexpr_exprstack_push_operand_ (operator);	/* Push it back on
9992							   stack. */
9993    }
9994}
9995
9996/* ffeexpr_reduced_bool1_ -- Wrap up reduction of NOT operator
9997
9998   reduced = ffeexpr_reduced_bool1_(reduced,op,r);
9999
10000   Makes sure the argument for reduced has basictype of
10001   LOGICAL or (ugly) INTEGER.  If
10002   argument has where of CONSTANT, assign where CONSTANT to
10003   reduced, else assign where FLEETING.
10004
10005   If these requirements cannot be met, generate error message.	 */
10006
10007static ffebld
10008ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10009{
10010  ffeinfo rinfo, ninfo;
10011  ffeinfoBasictype rbt;
10012  ffeinfoKindtype rkt;
10013  ffeinfoRank rrk;
10014  ffeinfoKind rkd;
10015  ffeinfoWhere rwh, nwh;
10016
10017  rinfo = ffebld_info (ffebld_left (reduced));
10018  rbt = ffeinfo_basictype (rinfo);
10019  rkt = ffeinfo_kindtype (rinfo);
10020  rrk = ffeinfo_rank (rinfo);
10021  rkd = ffeinfo_kind (rinfo);
10022  rwh = ffeinfo_where (rinfo);
10023
10024  if (((rbt == FFEINFO_basictypeLOGICAL)
10025       || (ffe_is_ugly_logint () && (rbt == FFEINFO_basictypeINTEGER)))
10026      && (rrk == 0))
10027    {
10028      switch (rwh)
10029	{
10030	case FFEINFO_whereCONSTANT:
10031	  nwh = FFEINFO_whereCONSTANT;
10032	  break;
10033
10034	case FFEINFO_whereIMMEDIATE:
10035	  nwh = FFEINFO_whereIMMEDIATE;
10036	  break;
10037
10038	default:
10039	  nwh = FFEINFO_whereFLEETING;
10040	  break;
10041	}
10042
10043      ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
10044			   FFETARGET_charactersizeNONE);
10045      ffebld_set_info (reduced, ninfo);
10046      return reduced;
10047    }
10048
10049  if ((rbt != FFEINFO_basictypeLOGICAL)
10050      && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
10051    {
10052      if ((rbt != FFEINFO_basictypeANY)
10053	  && ffebad_start (FFEBAD_NOT_ARG_TYPE))
10054	{
10055	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10056	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10057	  ffebad_finish ();
10058	}
10059    }
10060  else
10061    {
10062      if ((rkd != FFEINFO_kindANY)
10063	  && ffebad_start (FFEBAD_NOT_ARG_KIND))
10064	{
10065	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10066	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10067	  ffebad_string ("an array");
10068	  ffebad_finish ();
10069	}
10070    }
10071
10072  reduced = ffebld_new_any ();
10073  ffebld_set_info (reduced, ffeinfo_new_any ());
10074  return reduced;
10075}
10076
10077/* ffeexpr_reduced_bool2_ -- Wrap up reduction of boolean operators
10078
10079   reduced = ffeexpr_reduced_bool2_(reduced,l,op,r);
10080
10081   Makes sure the left and right arguments for reduced have basictype of
10082   LOGICAL or (ugly) INTEGER.  Determine common basictype and
10083   size for reduction (flag expression for combined hollerith/typeless
10084   situations for later determination of effective basictype).	If both left
10085   and right arguments have where of CONSTANT, assign where CONSTANT to
10086   reduced, else assign where FLEETING.	 Create CONVERT ops for args where
10087   needed.  Convert typeless
10088   constants to the desired type/size explicitly.
10089
10090   If these requirements cannot be met, generate error message.	 */
10091
10092static ffebld
10093ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10094			ffeexprExpr_ r)
10095{
10096  ffeinfo linfo, rinfo, ninfo;
10097  ffeinfoBasictype lbt, rbt, nbt;
10098  ffeinfoKindtype lkt, rkt, nkt;
10099  ffeinfoRank lrk, rrk;
10100  ffeinfoKind lkd, rkd;
10101  ffeinfoWhere lwh, rwh, nwh;
10102
10103  linfo = ffebld_info (ffebld_left (reduced));
10104  lbt = ffeinfo_basictype (linfo);
10105  lkt = ffeinfo_kindtype (linfo);
10106  lrk = ffeinfo_rank (linfo);
10107  lkd = ffeinfo_kind (linfo);
10108  lwh = ffeinfo_where (linfo);
10109
10110  rinfo = ffebld_info (ffebld_right (reduced));
10111  rbt = ffeinfo_basictype (rinfo);
10112  rkt = ffeinfo_kindtype (rinfo);
10113  rrk = ffeinfo_rank (rinfo);
10114  rkd = ffeinfo_kind (rinfo);
10115  rwh = ffeinfo_where (rinfo);
10116
10117  ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10118
10119  if (((nbt == FFEINFO_basictypeLOGICAL)
10120       || (ffe_is_ugly_logint () && (nbt == FFEINFO_basictypeINTEGER)))
10121      && (lrk == 0) && (rrk == 0))
10122    {
10123      switch (lwh)
10124	{
10125	case FFEINFO_whereCONSTANT:
10126	  switch (rwh)
10127	    {
10128	    case FFEINFO_whereCONSTANT:
10129	      nwh = FFEINFO_whereCONSTANT;
10130	      break;
10131
10132	    case FFEINFO_whereIMMEDIATE:
10133	      nwh = FFEINFO_whereIMMEDIATE;
10134	      break;
10135
10136	    default:
10137	      nwh = FFEINFO_whereFLEETING;
10138	      break;
10139	    }
10140	  break;
10141
10142	case FFEINFO_whereIMMEDIATE:
10143	  switch (rwh)
10144	    {
10145	    case FFEINFO_whereCONSTANT:
10146	    case FFEINFO_whereIMMEDIATE:
10147	      nwh = FFEINFO_whereIMMEDIATE;
10148	      break;
10149
10150	    default:
10151	      nwh = FFEINFO_whereFLEETING;
10152	      break;
10153	    }
10154	  break;
10155
10156	default:
10157	  nwh = FFEINFO_whereFLEETING;
10158	  break;
10159	}
10160
10161      ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10162			   FFETARGET_charactersizeNONE);
10163      ffebld_set_info (reduced, ninfo);
10164      ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10165	      l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10166						 FFEEXPR_contextLET));
10167      ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10168	      r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10169						  FFEEXPR_contextLET));
10170      return reduced;
10171    }
10172
10173  if ((lbt != FFEINFO_basictypeLOGICAL)
10174      && (!ffe_is_ugly_logint () || (lbt != FFEINFO_basictypeINTEGER)))
10175    {
10176      if ((rbt != FFEINFO_basictypeLOGICAL)
10177	  && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
10178	{
10179	  if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10180	      && ffebad_start (FFEBAD_BOOL_ARGS_TYPE))
10181	    {
10182	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10183	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10184	      ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10185	      ffebad_finish ();
10186	    }
10187	}
10188      else
10189	{
10190	  if ((lbt != FFEINFO_basictypeANY)
10191	      && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
10192	    {
10193	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10194	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10195	      ffebad_finish ();
10196	    }
10197	}
10198    }
10199  else if ((rbt != FFEINFO_basictypeLOGICAL)
10200	   && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
10201    {
10202      if ((rbt != FFEINFO_basictypeANY)
10203	  && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
10204	{
10205	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10206	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10207	  ffebad_finish ();
10208	}
10209    }
10210  else if (lrk != 0)
10211    {
10212      if ((lkd != FFEINFO_kindANY)
10213	  && ffebad_start (FFEBAD_BOOL_ARG_KIND))
10214	{
10215	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10216	  ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10217	  ffebad_string ("an array");
10218	  ffebad_finish ();
10219	}
10220    }
10221  else
10222    {
10223      if ((rkd != FFEINFO_kindANY)
10224	  && ffebad_start (FFEBAD_BOOL_ARG_KIND))
10225	{
10226	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10227	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10228	  ffebad_string ("an array");
10229	  ffebad_finish ();
10230	}
10231    }
10232
10233  reduced = ffebld_new_any ();
10234  ffebld_set_info (reduced, ffeinfo_new_any ());
10235  return reduced;
10236}
10237
10238/* ffeexpr_reduced_concatenate_ -- Wrap up reduction of concatenate operator
10239
10240   reduced = ffeexpr_reduced_concatenate_(reduced,l,op,r);
10241
10242   Makes sure the left and right arguments for reduced have basictype of
10243   CHARACTER and kind of SCALAR, FUNCTION, or STATEMENT FUNCTION.  Assign
10244   basictype of CHARACTER and kind of SCALAR to reduced.  Calculate effective
10245   size of concatenation and assign that size to reduced.  If both left and
10246   right arguments have where of CONSTANT, assign where CONSTANT to reduced,
10247   else assign where FLEETING.
10248
10249   If these requirements cannot be met, generate error message using the
10250   info in l, op, and r arguments and assign basictype, size, kind, and where
10251   of ANY.  */
10252
10253static ffebld
10254ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10255			      ffeexprExpr_ r)
10256{
10257  ffeinfo linfo, rinfo, ninfo;
10258  ffeinfoBasictype lbt, rbt, nbt;
10259  ffeinfoKindtype lkt, rkt, nkt;
10260  ffeinfoRank lrk, rrk;
10261  ffeinfoKind lkd, rkd, nkd;
10262  ffeinfoWhere lwh, rwh, nwh;
10263  ffetargetCharacterSize lszm, lszk, rszm, rszk, nszk;
10264
10265  linfo = ffebld_info (ffebld_left (reduced));
10266  lbt = ffeinfo_basictype (linfo);
10267  lkt = ffeinfo_kindtype (linfo);
10268  lrk = ffeinfo_rank (linfo);
10269  lkd = ffeinfo_kind (linfo);
10270  lwh = ffeinfo_where (linfo);
10271  lszk = ffeinfo_size (linfo);	/* Known size. */
10272  lszm = ffebld_size_max (ffebld_left (reduced));
10273
10274  rinfo = ffebld_info (ffebld_right (reduced));
10275  rbt = ffeinfo_basictype (rinfo);
10276  rkt = ffeinfo_kindtype (rinfo);
10277  rrk = ffeinfo_rank (rinfo);
10278  rkd = ffeinfo_kind (rinfo);
10279  rwh = ffeinfo_where (rinfo);
10280  rszk = ffeinfo_size (rinfo);	/* Known size. */
10281  rszm = ffebld_size_max (ffebld_right (reduced));
10282
10283  if ((lbt == FFEINFO_basictypeCHARACTER) && (rbt == FFEINFO_basictypeCHARACTER)
10284      && (lkt == rkt) && (lrk == 0) && (rrk == 0)
10285      && (((lszm != FFETARGET_charactersizeNONE)
10286	   && (rszm != FFETARGET_charactersizeNONE))
10287	  || (ffeexpr_context_outer_ (ffeexpr_stack_)
10288	      == FFEEXPR_contextLET)
10289	  || (ffeexpr_context_outer_ (ffeexpr_stack_)
10290	      == FFEEXPR_contextSFUNCDEF)))
10291    {
10292      nbt = FFEINFO_basictypeCHARACTER;
10293      nkd = FFEINFO_kindENTITY;
10294      if ((lszk == FFETARGET_charactersizeNONE)
10295	  || (rszk == FFETARGET_charactersizeNONE))
10296	nszk = FFETARGET_charactersizeNONE;	/* Ok only in rhs of LET
10297						   stmt. */
10298      else
10299	nszk = lszk + rszk;
10300
10301      switch (lwh)
10302	{
10303	case FFEINFO_whereCONSTANT:
10304	  switch (rwh)
10305	    {
10306	    case FFEINFO_whereCONSTANT:
10307	      nwh = FFEINFO_whereCONSTANT;
10308	      break;
10309
10310	    case FFEINFO_whereIMMEDIATE:
10311	      nwh = FFEINFO_whereIMMEDIATE;
10312	      break;
10313
10314	    default:
10315	      nwh = FFEINFO_whereFLEETING;
10316	      break;
10317	    }
10318	  break;
10319
10320	case FFEINFO_whereIMMEDIATE:
10321	  switch (rwh)
10322	    {
10323	    case FFEINFO_whereCONSTANT:
10324	    case FFEINFO_whereIMMEDIATE:
10325	      nwh = FFEINFO_whereIMMEDIATE;
10326	      break;
10327
10328	    default:
10329	      nwh = FFEINFO_whereFLEETING;
10330	      break;
10331	    }
10332	  break;
10333
10334	default:
10335	  nwh = FFEINFO_whereFLEETING;
10336	  break;
10337	}
10338
10339      nkt = lkt;
10340      ninfo = ffeinfo_new (nbt, nkt, 0, nkd, nwh, nszk);
10341      ffebld_set_info (reduced, ninfo);
10342      return reduced;
10343    }
10344
10345  if ((lbt != FFEINFO_basictypeCHARACTER) && (rbt != FFEINFO_basictypeCHARACTER))
10346    {
10347      if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10348	  && ffebad_start (FFEBAD_CONCAT_ARGS_TYPE))
10349	{
10350	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10351	  ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10352	  ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10353	  ffebad_finish ();
10354	}
10355    }
10356  else if (lbt != FFEINFO_basictypeCHARACTER)
10357    {
10358      if ((lbt != FFEINFO_basictypeANY)
10359	  && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
10360	{
10361	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10362	  ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10363	  ffebad_finish ();
10364	}
10365    }
10366  else if (rbt != FFEINFO_basictypeCHARACTER)
10367    {
10368      if ((rbt != FFEINFO_basictypeANY)
10369	  && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
10370	{
10371	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10372	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10373	  ffebad_finish ();
10374	}
10375    }
10376  else if ((lrk != 0) || (lszm == FFETARGET_charactersizeNONE))
10377    {
10378      if ((lkd != FFEINFO_kindANY)
10379	  && ffebad_start (FFEBAD_CONCAT_ARG_KIND))
10380	{
10381	  const char *what;
10382
10383	  if (lrk != 0)
10384	    what = "an array";
10385	  else
10386	    what = "of indeterminate length";
10387	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10388	  ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10389	  ffebad_string (what);
10390	  ffebad_finish ();
10391	}
10392    }
10393  else
10394    {
10395      if (ffebad_start (FFEBAD_CONCAT_ARG_KIND))
10396	{
10397	  const char *what;
10398
10399	  if (rrk != 0)
10400	    what = "an array";
10401	  else
10402	    what = "of indeterminate length";
10403	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10404	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10405	  ffebad_string (what);
10406	  ffebad_finish ();
10407	}
10408    }
10409
10410  reduced = ffebld_new_any ();
10411  ffebld_set_info (reduced, ffeinfo_new_any ());
10412  return reduced;
10413}
10414
10415/* ffeexpr_reduced_eqop2_ -- Wrap up reduction of EQ and NE operators
10416
10417   reduced = ffeexpr_reduced_eqop2_(reduced,l,op,r);
10418
10419   Makes sure the left and right arguments for reduced have basictype of
10420   INTEGER, REAL, COMPLEX, or CHARACTER.  Determine common basictype and
10421   size for reduction.	If both left
10422   and right arguments have where of CONSTANT, assign where CONSTANT to
10423   reduced, else assign where FLEETING.	 Create CONVERT ops for args where
10424   needed.  Convert typeless
10425   constants to the desired type/size explicitly.
10426
10427   If these requirements cannot be met, generate error message.	 */
10428
10429static ffebld
10430ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10431			ffeexprExpr_ r)
10432{
10433  ffeinfo linfo, rinfo, ninfo;
10434  ffeinfoBasictype lbt, rbt, nbt;
10435  ffeinfoKindtype lkt, rkt, nkt;
10436  ffeinfoRank lrk, rrk;
10437  ffeinfoKind lkd, rkd;
10438  ffeinfoWhere lwh, rwh, nwh;
10439  ffetargetCharacterSize lsz, rsz;
10440
10441  linfo = ffebld_info (ffebld_left (reduced));
10442  lbt = ffeinfo_basictype (linfo);
10443  lkt = ffeinfo_kindtype (linfo);
10444  lrk = ffeinfo_rank (linfo);
10445  lkd = ffeinfo_kind (linfo);
10446  lwh = ffeinfo_where (linfo);
10447  lsz = ffebld_size_known (ffebld_left (reduced));
10448
10449  rinfo = ffebld_info (ffebld_right (reduced));
10450  rbt = ffeinfo_basictype (rinfo);
10451  rkt = ffeinfo_kindtype (rinfo);
10452  rrk = ffeinfo_rank (rinfo);
10453  rkd = ffeinfo_kind (rinfo);
10454  rwh = ffeinfo_where (rinfo);
10455  rsz = ffebld_size_known (ffebld_right (reduced));
10456
10457  ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10458
10459  if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10460       || (nbt == FFEINFO_basictypeCOMPLEX) || (nbt == FFEINFO_basictypeCHARACTER))
10461      && (lrk == 0) && (rrk == 0))
10462    {
10463      switch (lwh)
10464	{
10465	case FFEINFO_whereCONSTANT:
10466	  switch (rwh)
10467	    {
10468	    case FFEINFO_whereCONSTANT:
10469	      nwh = FFEINFO_whereCONSTANT;
10470	      break;
10471
10472	    case FFEINFO_whereIMMEDIATE:
10473	      nwh = FFEINFO_whereIMMEDIATE;
10474	      break;
10475
10476	    default:
10477	      nwh = FFEINFO_whereFLEETING;
10478	      break;
10479	    }
10480	  break;
10481
10482	case FFEINFO_whereIMMEDIATE:
10483	  switch (rwh)
10484	    {
10485	    case FFEINFO_whereCONSTANT:
10486	    case FFEINFO_whereIMMEDIATE:
10487	      nwh = FFEINFO_whereIMMEDIATE;
10488	      break;
10489
10490	    default:
10491	      nwh = FFEINFO_whereFLEETING;
10492	      break;
10493	    }
10494	  break;
10495
10496	default:
10497	  nwh = FFEINFO_whereFLEETING;
10498	  break;
10499	}
10500
10501      if ((lsz != FFETARGET_charactersizeNONE)
10502	  && (rsz != FFETARGET_charactersizeNONE))
10503	lsz = rsz = (lsz > rsz) ? lsz : rsz;
10504
10505      ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
10506		   0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
10507      ffebld_set_info (reduced, ninfo);
10508      ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10509				      l->token, op->token, nbt, nkt, 0, lsz,
10510						 FFEEXPR_contextLET));
10511      ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10512				      r->token, op->token, nbt, nkt, 0, rsz,
10513						  FFEEXPR_contextLET));
10514      return reduced;
10515    }
10516
10517  if ((lbt == FFEINFO_basictypeLOGICAL)
10518      && (rbt == FFEINFO_basictypeLOGICAL))
10519    {
10520      if (ffebad_start_msg ("Use .EQV./.NEQV. instead of .EQ./.NE. at %0 for LOGICAL operands at %1 and %2",
10521			    FFEBAD_severityFATAL))
10522	{
10523	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10524	  ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10525	  ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10526	  ffebad_finish ();
10527	}
10528    }
10529  else if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10530      && (lbt != FFEINFO_basictypeCOMPLEX) && (lbt != FFEINFO_basictypeCHARACTER))
10531    {
10532      if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10533	  && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
10534	{
10535	  if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10536	      && ffebad_start (FFEBAD_EQOP_ARGS_TYPE))
10537	    {
10538	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10539	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10540	      ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10541	      ffebad_finish ();
10542	    }
10543	}
10544      else
10545	{
10546	  if ((lbt != FFEINFO_basictypeANY)
10547	      && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
10548	    {
10549	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10550	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10551	      ffebad_finish ();
10552	    }
10553	}
10554    }
10555  else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10556	   && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
10557    {
10558      if ((rbt != FFEINFO_basictypeANY)
10559	  && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
10560	{
10561	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10562	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10563	  ffebad_finish ();
10564	}
10565    }
10566  else if (lrk != 0)
10567    {
10568      if ((lkd != FFEINFO_kindANY)
10569	  && ffebad_start (FFEBAD_EQOP_ARG_KIND))
10570	{
10571	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10572	  ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10573	  ffebad_string ("an array");
10574	  ffebad_finish ();
10575	}
10576    }
10577  else
10578    {
10579      if ((rkd != FFEINFO_kindANY)
10580	  && ffebad_start (FFEBAD_EQOP_ARG_KIND))
10581	{
10582	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10583	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10584	  ffebad_string ("an array");
10585	  ffebad_finish ();
10586	}
10587    }
10588
10589  reduced = ffebld_new_any ();
10590  ffebld_set_info (reduced, ffeinfo_new_any ());
10591  return reduced;
10592}
10593
10594/* ffeexpr_reduced_math1_ -- Wrap up reduction of + - unary operators
10595
10596   reduced = ffeexpr_reduced_math1_(reduced,op,r);
10597
10598   Makes sure the argument for reduced has basictype of
10599   INTEGER, REAL, or COMPLEX.  If the argument has where of CONSTANT,
10600   assign where CONSTANT to
10601   reduced, else assign where FLEETING.
10602
10603   If these requirements cannot be met, generate error message.	 */
10604
10605static ffebld
10606ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10607{
10608  ffeinfo rinfo, ninfo;
10609  ffeinfoBasictype rbt;
10610  ffeinfoKindtype rkt;
10611  ffeinfoRank rrk;
10612  ffeinfoKind rkd;
10613  ffeinfoWhere rwh, nwh;
10614
10615  rinfo = ffebld_info (ffebld_left (reduced));
10616  rbt = ffeinfo_basictype (rinfo);
10617  rkt = ffeinfo_kindtype (rinfo);
10618  rrk = ffeinfo_rank (rinfo);
10619  rkd = ffeinfo_kind (rinfo);
10620  rwh = ffeinfo_where (rinfo);
10621
10622  if (((rbt == FFEINFO_basictypeINTEGER) || (rbt == FFEINFO_basictypeREAL)
10623       || (rbt == FFEINFO_basictypeCOMPLEX)) && (rrk == 0))
10624    {
10625      switch (rwh)
10626	{
10627	case FFEINFO_whereCONSTANT:
10628	  nwh = FFEINFO_whereCONSTANT;
10629	  break;
10630
10631	case FFEINFO_whereIMMEDIATE:
10632	  nwh = FFEINFO_whereIMMEDIATE;
10633	  break;
10634
10635	default:
10636	  nwh = FFEINFO_whereFLEETING;
10637	  break;
10638	}
10639
10640      ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
10641			   FFETARGET_charactersizeNONE);
10642      ffebld_set_info (reduced, ninfo);
10643      return reduced;
10644    }
10645
10646  if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10647      && (rbt != FFEINFO_basictypeCOMPLEX))
10648    {
10649      if ((rbt != FFEINFO_basictypeANY)
10650	  && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10651	{
10652	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10653	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10654	  ffebad_finish ();
10655	}
10656    }
10657  else
10658    {
10659      if ((rkd != FFEINFO_kindANY)
10660	  && ffebad_start (FFEBAD_MATH_ARG_KIND))
10661	{
10662	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10663	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10664	  ffebad_string ("an array");
10665	  ffebad_finish ();
10666	}
10667    }
10668
10669  reduced = ffebld_new_any ();
10670  ffebld_set_info (reduced, ffeinfo_new_any ());
10671  return reduced;
10672}
10673
10674/* ffeexpr_reduced_math2_ -- Wrap up reduction of + - * / operators
10675
10676   reduced = ffeexpr_reduced_math2_(reduced,l,op,r);
10677
10678   Makes sure the left and right arguments for reduced have basictype of
10679   INTEGER, REAL, or COMPLEX.  Determine common basictype and
10680   size for reduction (flag expression for combined hollerith/typeless
10681   situations for later determination of effective basictype).	If both left
10682   and right arguments have where of CONSTANT, assign where CONSTANT to
10683   reduced, else assign where FLEETING.	 Create CONVERT ops for args where
10684   needed.  Convert typeless
10685   constants to the desired type/size explicitly.
10686
10687   If these requirements cannot be met, generate error message.	 */
10688
10689static ffebld
10690ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10691			ffeexprExpr_ r)
10692{
10693  ffeinfo linfo, rinfo, ninfo;
10694  ffeinfoBasictype lbt, rbt, nbt;
10695  ffeinfoKindtype lkt, rkt, nkt;
10696  ffeinfoRank lrk, rrk;
10697  ffeinfoKind lkd, rkd;
10698  ffeinfoWhere lwh, rwh, nwh;
10699
10700  linfo = ffebld_info (ffebld_left (reduced));
10701  lbt = ffeinfo_basictype (linfo);
10702  lkt = ffeinfo_kindtype (linfo);
10703  lrk = ffeinfo_rank (linfo);
10704  lkd = ffeinfo_kind (linfo);
10705  lwh = ffeinfo_where (linfo);
10706
10707  rinfo = ffebld_info (ffebld_right (reduced));
10708  rbt = ffeinfo_basictype (rinfo);
10709  rkt = ffeinfo_kindtype (rinfo);
10710  rrk = ffeinfo_rank (rinfo);
10711  rkd = ffeinfo_kind (rinfo);
10712  rwh = ffeinfo_where (rinfo);
10713
10714  ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10715
10716  if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10717       || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
10718    {
10719      switch (lwh)
10720	{
10721	case FFEINFO_whereCONSTANT:
10722	  switch (rwh)
10723	    {
10724	    case FFEINFO_whereCONSTANT:
10725	      nwh = FFEINFO_whereCONSTANT;
10726	      break;
10727
10728	    case FFEINFO_whereIMMEDIATE:
10729	      nwh = FFEINFO_whereIMMEDIATE;
10730	      break;
10731
10732	    default:
10733	      nwh = FFEINFO_whereFLEETING;
10734	      break;
10735	    }
10736	  break;
10737
10738	case FFEINFO_whereIMMEDIATE:
10739	  switch (rwh)
10740	    {
10741	    case FFEINFO_whereCONSTANT:
10742	    case FFEINFO_whereIMMEDIATE:
10743	      nwh = FFEINFO_whereIMMEDIATE;
10744	      break;
10745
10746	    default:
10747	      nwh = FFEINFO_whereFLEETING;
10748	      break;
10749	    }
10750	  break;
10751
10752	default:
10753	  nwh = FFEINFO_whereFLEETING;
10754	  break;
10755	}
10756
10757      ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10758			   FFETARGET_charactersizeNONE);
10759      ffebld_set_info (reduced, ninfo);
10760      ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10761	      l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10762						 FFEEXPR_contextLET));
10763      ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10764	      r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10765						  FFEEXPR_contextLET));
10766      return reduced;
10767    }
10768
10769  if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10770      && (lbt != FFEINFO_basictypeCOMPLEX))
10771    {
10772      if ((rbt != FFEINFO_basictypeINTEGER)
10773      && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
10774	{
10775	  if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10776	      && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
10777	    {
10778	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10779	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10780	      ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10781	      ffebad_finish ();
10782	    }
10783	}
10784      else
10785	{
10786	  if ((lbt != FFEINFO_basictypeANY)
10787	      && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10788	    {
10789	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10790	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10791	      ffebad_finish ();
10792	    }
10793	}
10794    }
10795  else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10796	   && (rbt != FFEINFO_basictypeCOMPLEX))
10797    {
10798      if ((rbt != FFEINFO_basictypeANY)
10799	  && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10800	{
10801	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10802	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10803	  ffebad_finish ();
10804	}
10805    }
10806  else if (lrk != 0)
10807    {
10808      if ((lkd != FFEINFO_kindANY)
10809	  && ffebad_start (FFEBAD_MATH_ARG_KIND))
10810	{
10811	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10812	  ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10813	  ffebad_string ("an array");
10814	  ffebad_finish ();
10815	}
10816    }
10817  else
10818    {
10819      if ((rkd != FFEINFO_kindANY)
10820	  && ffebad_start (FFEBAD_MATH_ARG_KIND))
10821	{
10822	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10823	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10824	  ffebad_string ("an array");
10825	  ffebad_finish ();
10826	}
10827    }
10828
10829  reduced = ffebld_new_any ();
10830  ffebld_set_info (reduced, ffeinfo_new_any ());
10831  return reduced;
10832}
10833
10834/* ffeexpr_reduced_power_ -- Wrap up reduction of ** operator
10835
10836   reduced = ffeexpr_reduced_power_(reduced,l,op,r);
10837
10838   Makes sure the left and right arguments for reduced have basictype of
10839   INTEGER, REAL, or COMPLEX.  Determine common basictype and
10840   size for reduction (flag expression for combined hollerith/typeless
10841   situations for later determination of effective basictype).	If both left
10842   and right arguments have where of CONSTANT, assign where CONSTANT to
10843   reduced, else assign where FLEETING.	 Create CONVERT ops for args where
10844   needed.  Note that real**int or complex**int
10845   comes out as int = real**int etc with no conversions.
10846
10847   If these requirements cannot be met, generate error message using the
10848   info in l, op, and r arguments and assign basictype, size, kind, and where
10849   of ANY.  */
10850
10851static ffebld
10852ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10853			ffeexprExpr_ r)
10854{
10855  ffeinfo linfo, rinfo, ninfo;
10856  ffeinfoBasictype lbt, rbt, nbt;
10857  ffeinfoKindtype lkt, rkt, nkt;
10858  ffeinfoRank lrk, rrk;
10859  ffeinfoKind lkd, rkd;
10860  ffeinfoWhere lwh, rwh, nwh;
10861
10862  linfo = ffebld_info (ffebld_left (reduced));
10863  lbt = ffeinfo_basictype (linfo);
10864  lkt = ffeinfo_kindtype (linfo);
10865  lrk = ffeinfo_rank (linfo);
10866  lkd = ffeinfo_kind (linfo);
10867  lwh = ffeinfo_where (linfo);
10868
10869  rinfo = ffebld_info (ffebld_right (reduced));
10870  rbt = ffeinfo_basictype (rinfo);
10871  rkt = ffeinfo_kindtype (rinfo);
10872  rrk = ffeinfo_rank (rinfo);
10873  rkd = ffeinfo_kind (rinfo);
10874  rwh = ffeinfo_where (rinfo);
10875
10876  if ((rbt == FFEINFO_basictypeINTEGER)
10877      && ((lbt == FFEINFO_basictypeREAL)
10878	  || (lbt == FFEINFO_basictypeCOMPLEX)))
10879    {
10880      nbt = lbt;
10881      nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDEFAULT);
10882      if (nkt != FFEINFO_kindtypeREALDEFAULT)
10883	{
10884	  nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDOUBLE);
10885	  if (nkt != FFEINFO_kindtypeREALDOUBLE)
10886	    nkt = FFEINFO_kindtypeREALDOUBLE;	/* Highest kt we can power! */
10887	}
10888      if (rkt == FFEINFO_kindtypeINTEGER4)
10889	{
10890	  ffebad_start_msg ("Unsupported operand for ** at %1 -- converting to default INTEGER",
10891			    FFEBAD_severityWARNING);
10892	  ffebad_here (0, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10893	  ffebad_finish ();
10894	}
10895      if (rkt != FFEINFO_kindtypeINTEGERDEFAULT)
10896	{
10897	  ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10898						      r->token, op->token,
10899		FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0,
10900						FFETARGET_charactersizeNONE,
10901						      FFEEXPR_contextLET));
10902	  rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10903	}
10904    }
10905  else
10906    {
10907      ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10908
10909#if 0	/* INTEGER4**INTEGER4 works now. */
10910      if ((nbt == FFEINFO_basictypeINTEGER)
10911	  && (nkt != FFEINFO_kindtypeINTEGERDEFAULT))
10912	nkt = FFEINFO_kindtypeINTEGERDEFAULT;	/* Highest kt we can power! */
10913#endif
10914      if (((nbt == FFEINFO_basictypeREAL)
10915	   || (nbt == FFEINFO_basictypeCOMPLEX))
10916	  && (nkt != FFEINFO_kindtypeREALDEFAULT))
10917	{
10918	  nkt = ffeinfo_kindtype_max (nbt, nkt, FFEINFO_kindtypeREALDOUBLE);
10919	  if (nkt != FFEINFO_kindtypeREALDOUBLE)
10920	    nkt = FFEINFO_kindtypeREALDOUBLE;	/* Highest kt we can power! */
10921	}
10922      /* else Gonna turn into an error below. */
10923    }
10924
10925  if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10926       || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
10927    {
10928      switch (lwh)
10929	{
10930	case FFEINFO_whereCONSTANT:
10931	  switch (rwh)
10932	    {
10933	    case FFEINFO_whereCONSTANT:
10934	      nwh = FFEINFO_whereCONSTANT;
10935	      break;
10936
10937	    case FFEINFO_whereIMMEDIATE:
10938	      nwh = FFEINFO_whereIMMEDIATE;
10939	      break;
10940
10941	    default:
10942	      nwh = FFEINFO_whereFLEETING;
10943	      break;
10944	    }
10945	  break;
10946
10947	case FFEINFO_whereIMMEDIATE:
10948	  switch (rwh)
10949	    {
10950	    case FFEINFO_whereCONSTANT:
10951	    case FFEINFO_whereIMMEDIATE:
10952	      nwh = FFEINFO_whereIMMEDIATE;
10953	      break;
10954
10955	    default:
10956	      nwh = FFEINFO_whereFLEETING;
10957	      break;
10958	    }
10959	  break;
10960
10961	default:
10962	  nwh = FFEINFO_whereFLEETING;
10963	  break;
10964	}
10965
10966      ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10967			   FFETARGET_charactersizeNONE);
10968      ffebld_set_info (reduced, ninfo);
10969      ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10970	      l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10971						 FFEEXPR_contextLET));
10972      if (rbt != FFEINFO_basictypeINTEGER)
10973	ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10974	      r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10975						    FFEEXPR_contextLET));
10976      return reduced;
10977    }
10978
10979  if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10980      && (lbt != FFEINFO_basictypeCOMPLEX))
10981    {
10982      if ((rbt != FFEINFO_basictypeINTEGER)
10983      && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
10984	{
10985	  if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10986	      && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
10987	    {
10988	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10989	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10990	      ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10991	      ffebad_finish ();
10992	    }
10993	}
10994      else
10995	{
10996	  if ((lbt != FFEINFO_basictypeANY)
10997	      && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10998	    {
10999	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11000	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11001	      ffebad_finish ();
11002	    }
11003	}
11004    }
11005  else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
11006	   && (rbt != FFEINFO_basictypeCOMPLEX))
11007    {
11008      if ((rbt != FFEINFO_basictypeANY)
11009	  && ffebad_start (FFEBAD_MATH_ARG_TYPE))
11010	{
11011	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11012	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11013	  ffebad_finish ();
11014	}
11015    }
11016  else if (lrk != 0)
11017    {
11018      if ((lkd != FFEINFO_kindANY)
11019	  && ffebad_start (FFEBAD_MATH_ARG_KIND))
11020	{
11021	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11022	  ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11023	  ffebad_string ("an array");
11024	  ffebad_finish ();
11025	}
11026    }
11027  else
11028    {
11029      if ((rkd != FFEINFO_kindANY)
11030	  && ffebad_start (FFEBAD_MATH_ARG_KIND))
11031	{
11032	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11033	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11034	  ffebad_string ("an array");
11035	  ffebad_finish ();
11036	}
11037    }
11038
11039  reduced = ffebld_new_any ();
11040  ffebld_set_info (reduced, ffeinfo_new_any ());
11041  return reduced;
11042}
11043
11044/* ffeexpr_reduced_relop2_ -- Wrap up reduction of LT, LE, GE, and GT operators
11045
11046   reduced = ffeexpr_reduced_relop2_(reduced,l,op,r);
11047
11048   Makes sure the left and right arguments for reduced have basictype of
11049   INTEGER, REAL, or CHARACTER.	 Determine common basictype and
11050   size for reduction.	If both left
11051   and right arguments have where of CONSTANT, assign where CONSTANT to
11052   reduced, else assign where FLEETING.	 Create CONVERT ops for args where
11053   needed.  Convert typeless
11054   constants to the desired type/size explicitly.
11055
11056   If these requirements cannot be met, generate error message.	 */
11057
11058static ffebld
11059ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
11060			 ffeexprExpr_ r)
11061{
11062  ffeinfo linfo, rinfo, ninfo;
11063  ffeinfoBasictype lbt, rbt, nbt;
11064  ffeinfoKindtype lkt, rkt, nkt;
11065  ffeinfoRank lrk, rrk;
11066  ffeinfoKind lkd, rkd;
11067  ffeinfoWhere lwh, rwh, nwh;
11068  ffetargetCharacterSize lsz, rsz;
11069
11070  linfo = ffebld_info (ffebld_left (reduced));
11071  lbt = ffeinfo_basictype (linfo);
11072  lkt = ffeinfo_kindtype (linfo);
11073  lrk = ffeinfo_rank (linfo);
11074  lkd = ffeinfo_kind (linfo);
11075  lwh = ffeinfo_where (linfo);
11076  lsz = ffebld_size_known (ffebld_left (reduced));
11077
11078  rinfo = ffebld_info (ffebld_right (reduced));
11079  rbt = ffeinfo_basictype (rinfo);
11080  rkt = ffeinfo_kindtype (rinfo);
11081  rrk = ffeinfo_rank (rinfo);
11082  rkd = ffeinfo_kind (rinfo);
11083  rwh = ffeinfo_where (rinfo);
11084  rsz = ffebld_size_known (ffebld_right (reduced));
11085
11086  ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
11087
11088  if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
11089       || (nbt == FFEINFO_basictypeCHARACTER))
11090      && (lrk == 0) && (rrk == 0))
11091    {
11092      switch (lwh)
11093	{
11094	case FFEINFO_whereCONSTANT:
11095	  switch (rwh)
11096	    {
11097	    case FFEINFO_whereCONSTANT:
11098	      nwh = FFEINFO_whereCONSTANT;
11099	      break;
11100
11101	    case FFEINFO_whereIMMEDIATE:
11102	      nwh = FFEINFO_whereIMMEDIATE;
11103	      break;
11104
11105	    default:
11106	      nwh = FFEINFO_whereFLEETING;
11107	      break;
11108	    }
11109	  break;
11110
11111	case FFEINFO_whereIMMEDIATE:
11112	  switch (rwh)
11113	    {
11114	    case FFEINFO_whereCONSTANT:
11115	    case FFEINFO_whereIMMEDIATE:
11116	      nwh = FFEINFO_whereIMMEDIATE;
11117	      break;
11118
11119	    default:
11120	      nwh = FFEINFO_whereFLEETING;
11121	      break;
11122	    }
11123	  break;
11124
11125	default:
11126	  nwh = FFEINFO_whereFLEETING;
11127	  break;
11128	}
11129
11130      if ((lsz != FFETARGET_charactersizeNONE)
11131	  && (rsz != FFETARGET_charactersizeNONE))
11132	lsz = rsz = (lsz > rsz) ? lsz : rsz;
11133
11134      ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
11135		   0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
11136      ffebld_set_info (reduced, ninfo);
11137      ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11138				      l->token, op->token, nbt, nkt, 0, lsz,
11139						 FFEEXPR_contextLET));
11140      ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11141				      r->token, op->token, nbt, nkt, 0, rsz,
11142						  FFEEXPR_contextLET));
11143      return reduced;
11144    }
11145
11146  if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
11147      && (lbt != FFEINFO_basictypeCHARACTER))
11148    {
11149      if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
11150	  && (rbt != FFEINFO_basictypeCHARACTER))
11151	{
11152	  if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
11153	      && ffebad_start (FFEBAD_RELOP_ARGS_TYPE))
11154	    {
11155	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11156	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11157	      ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11158	      ffebad_finish ();
11159	    }
11160	}
11161      else
11162	{
11163	  if ((lbt != FFEINFO_basictypeANY)
11164	      && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
11165	    {
11166	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11167	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11168	      ffebad_finish ();
11169	    }
11170	}
11171    }
11172  else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
11173	   && (rbt != FFEINFO_basictypeCHARACTER))
11174    {
11175      if ((rbt != FFEINFO_basictypeANY)
11176	  && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
11177	{
11178	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11179	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11180	  ffebad_finish ();
11181	}
11182    }
11183  else if (lrk != 0)
11184    {
11185      if ((lkd != FFEINFO_kindANY)
11186	  && ffebad_start (FFEBAD_RELOP_ARG_KIND))
11187	{
11188	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11189	  ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11190	  ffebad_string ("an array");
11191	  ffebad_finish ();
11192	}
11193    }
11194  else
11195    {
11196      if ((rkd != FFEINFO_kindANY)
11197	  && ffebad_start (FFEBAD_RELOP_ARG_KIND))
11198	{
11199	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11200	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11201	  ffebad_string ("an array");
11202	  ffebad_finish ();
11203	}
11204    }
11205
11206  reduced = ffebld_new_any ();
11207  ffebld_set_info (reduced, ffeinfo_new_any ());
11208  return reduced;
11209}
11210
11211/* ffeexpr_reduced_ugly1_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
11212
11213   reduced = ffeexpr_reduced_ugly1_(reduced,op,r);
11214
11215   Sigh.  */
11216
11217static ffebld
11218ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
11219{
11220  ffeinfo rinfo;
11221  ffeinfoBasictype rbt;
11222  ffeinfoKindtype rkt;
11223  ffeinfoRank rrk;
11224  ffeinfoKind rkd;
11225  ffeinfoWhere rwh;
11226
11227  rinfo = ffebld_info (ffebld_left (reduced));
11228  rbt = ffeinfo_basictype (rinfo);
11229  rkt = ffeinfo_kindtype (rinfo);
11230  rrk = ffeinfo_rank (rinfo);
11231  rkd = ffeinfo_kind (rinfo);
11232  rwh = ffeinfo_where (rinfo);
11233
11234  if ((rbt == FFEINFO_basictypeTYPELESS)
11235      || (rbt == FFEINFO_basictypeHOLLERITH))
11236    {
11237      ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11238			      r->token, op->token, FFEINFO_basictypeINTEGER,
11239					  FFEINFO_kindtypeINTEGERDEFAULT, 0,
11240						 FFETARGET_charactersizeNONE,
11241						 FFEEXPR_contextLET));
11242      rinfo = ffebld_info (ffebld_left (reduced));
11243      rbt = FFEINFO_basictypeINTEGER;
11244      rkt = FFEINFO_kindtypeINTEGERDEFAULT;
11245      rrk = 0;
11246      rkd = FFEINFO_kindENTITY;
11247      rwh = ffeinfo_where (rinfo);
11248    }
11249
11250  if (rbt == FFEINFO_basictypeLOGICAL)
11251    {
11252      ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11253			      r->token, op->token, FFEINFO_basictypeINTEGER,
11254					  FFEINFO_kindtypeINTEGERDEFAULT, 0,
11255						 FFETARGET_charactersizeNONE,
11256						 FFEEXPR_contextLET));
11257    }
11258
11259  return reduced;
11260}
11261
11262/* ffeexpr_reduced_ugly1log_ -- Deal with TYPELESS and HOLLERITH
11263
11264   reduced = ffeexpr_reduced_ugly1log_(reduced,op,r);
11265
11266   Sigh.  */
11267
11268static ffebld
11269ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
11270{
11271  ffeinfo rinfo;
11272  ffeinfoBasictype rbt;
11273  ffeinfoKindtype rkt;
11274  ffeinfoRank rrk;
11275  ffeinfoKind rkd;
11276  ffeinfoWhere rwh;
11277
11278  rinfo = ffebld_info (ffebld_left (reduced));
11279  rbt = ffeinfo_basictype (rinfo);
11280  rkt = ffeinfo_kindtype (rinfo);
11281  rrk = ffeinfo_rank (rinfo);
11282  rkd = ffeinfo_kind (rinfo);
11283  rwh = ffeinfo_where (rinfo);
11284
11285  if ((rbt == FFEINFO_basictypeTYPELESS)
11286      || (rbt == FFEINFO_basictypeHOLLERITH))
11287    {
11288      ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11289			   r->token, op->token, FFEINFO_basictypeLOGICAL, 0,
11290					     FFEINFO_kindtypeLOGICALDEFAULT,
11291						 FFETARGET_charactersizeNONE,
11292						 FFEEXPR_contextLET));
11293      rinfo = ffebld_info (ffebld_left (reduced));
11294      rbt = FFEINFO_basictypeLOGICAL;
11295      rkt = FFEINFO_kindtypeLOGICALDEFAULT;
11296      rrk = 0;
11297      rkd = FFEINFO_kindENTITY;
11298      rwh = ffeinfo_where (rinfo);
11299    }
11300
11301  return reduced;
11302}
11303
11304/* ffeexpr_reduced_ugly2_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
11305
11306   reduced = ffeexpr_reduced_ugly2_(reduced,l,op,r);
11307
11308   Sigh.  */
11309
11310static ffebld
11311ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
11312			ffeexprExpr_ r)
11313{
11314  ffeinfo linfo, rinfo;
11315  ffeinfoBasictype lbt, rbt;
11316  ffeinfoKindtype lkt, rkt;
11317  ffeinfoRank lrk, rrk;
11318  ffeinfoKind lkd, rkd;
11319  ffeinfoWhere lwh, rwh;
11320
11321  linfo = ffebld_info (ffebld_left (reduced));
11322  lbt = ffeinfo_basictype (linfo);
11323  lkt = ffeinfo_kindtype (linfo);
11324  lrk = ffeinfo_rank (linfo);
11325  lkd = ffeinfo_kind (linfo);
11326  lwh = ffeinfo_where (linfo);
11327
11328  rinfo = ffebld_info (ffebld_right (reduced));
11329  rbt = ffeinfo_basictype (rinfo);
11330  rkt = ffeinfo_kindtype (rinfo);
11331  rrk = ffeinfo_rank (rinfo);
11332  rkd = ffeinfo_kind (rinfo);
11333  rwh = ffeinfo_where (rinfo);
11334
11335  if ((lbt == FFEINFO_basictypeTYPELESS)
11336      || (lbt == FFEINFO_basictypeHOLLERITH))
11337    {
11338      if ((rbt == FFEINFO_basictypeTYPELESS)
11339	  || (rbt == FFEINFO_basictypeHOLLERITH))
11340	{
11341	  ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11342			      l->token, op->token, FFEINFO_basictypeINTEGER,
11343					  FFEINFO_kindtypeINTEGERDEFAULT, 0,
11344						FFETARGET_charactersizeNONE,
11345						     FFEEXPR_contextLET));
11346	  ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11347			   r->token, op->token, FFEINFO_basictypeINTEGER, 0,
11348					     FFEINFO_kindtypeINTEGERDEFAULT,
11349						FFETARGET_charactersizeNONE,
11350						      FFEEXPR_contextLET));
11351	  linfo = ffebld_info (ffebld_left (reduced));
11352	  rinfo = ffebld_info (ffebld_right (reduced));
11353	  lbt = rbt = FFEINFO_basictypeINTEGER;
11354	  lkt = rkt = FFEINFO_kindtypeINTEGERDEFAULT;
11355	  lrk = rrk = 0;
11356	  lkd = rkd = FFEINFO_kindENTITY;
11357	  lwh = ffeinfo_where (linfo);
11358	  rwh = ffeinfo_where (rinfo);
11359	}
11360      else
11361	{
11362	  ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
11363				 l->token, ffebld_right (reduced), r->token,
11364						       FFEEXPR_contextLET));
11365	  linfo = ffebld_info (ffebld_left (reduced));
11366	  lbt = ffeinfo_basictype (linfo);
11367	  lkt = ffeinfo_kindtype (linfo);
11368	  lrk = ffeinfo_rank (linfo);
11369	  lkd = ffeinfo_kind (linfo);
11370	  lwh = ffeinfo_where (linfo);
11371	}
11372    }
11373  else
11374    {
11375      if ((rbt == FFEINFO_basictypeTYPELESS)
11376	  || (rbt == FFEINFO_basictypeHOLLERITH))
11377	{
11378	  ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
11379				  r->token, ffebld_left (reduced), l->token,
11380						       FFEEXPR_contextLET));
11381	  rinfo = ffebld_info (ffebld_right (reduced));
11382	  rbt = ffeinfo_basictype (rinfo);
11383	  rkt = ffeinfo_kindtype (rinfo);
11384	  rrk = ffeinfo_rank (rinfo);
11385	  rkd = ffeinfo_kind (rinfo);
11386	  rwh = ffeinfo_where (rinfo);
11387	}
11388      /* else Leave it alone. */
11389    }
11390
11391  if (lbt == FFEINFO_basictypeLOGICAL)
11392    {
11393      ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11394			      l->token, op->token, FFEINFO_basictypeINTEGER,
11395					  FFEINFO_kindtypeINTEGERDEFAULT, 0,
11396						 FFETARGET_charactersizeNONE,
11397						 FFEEXPR_contextLET));
11398    }
11399
11400  if (rbt == FFEINFO_basictypeLOGICAL)
11401    {
11402      ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11403			      r->token, op->token, FFEINFO_basictypeINTEGER,
11404					  FFEINFO_kindtypeINTEGERDEFAULT, 0,
11405						FFETARGET_charactersizeNONE,
11406						  FFEEXPR_contextLET));
11407    }
11408
11409  return reduced;
11410}
11411
11412/* ffeexpr_reduced_ugly2log_ -- Deal with TYPELESS and HOLLERITH
11413
11414   reduced = ffeexpr_reduced_ugly2log_(reduced,l,op,r);
11415
11416   Sigh.  */
11417
11418static ffebld
11419ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
11420			   ffeexprExpr_ r)
11421{
11422  ffeinfo linfo, rinfo;
11423  ffeinfoBasictype lbt, rbt;
11424  ffeinfoKindtype lkt, rkt;
11425  ffeinfoRank lrk, rrk;
11426  ffeinfoKind lkd, rkd;
11427  ffeinfoWhere lwh, rwh;
11428
11429  linfo = ffebld_info (ffebld_left (reduced));
11430  lbt = ffeinfo_basictype (linfo);
11431  lkt = ffeinfo_kindtype (linfo);
11432  lrk = ffeinfo_rank (linfo);
11433  lkd = ffeinfo_kind (linfo);
11434  lwh = ffeinfo_where (linfo);
11435
11436  rinfo = ffebld_info (ffebld_right (reduced));
11437  rbt = ffeinfo_basictype (rinfo);
11438  rkt = ffeinfo_kindtype (rinfo);
11439  rrk = ffeinfo_rank (rinfo);
11440  rkd = ffeinfo_kind (rinfo);
11441  rwh = ffeinfo_where (rinfo);
11442
11443  if ((lbt == FFEINFO_basictypeTYPELESS)
11444      || (lbt == FFEINFO_basictypeHOLLERITH))
11445    {
11446      if ((rbt == FFEINFO_basictypeTYPELESS)
11447	  || (rbt == FFEINFO_basictypeHOLLERITH))
11448	{
11449	  ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11450			      l->token, op->token, FFEINFO_basictypeLOGICAL,
11451					  FFEINFO_kindtypeLOGICALDEFAULT, 0,
11452						FFETARGET_charactersizeNONE,
11453						     FFEEXPR_contextLET));
11454	  ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11455			      r->token, op->token, FFEINFO_basictypeLOGICAL,
11456					  FFEINFO_kindtypeLOGICALDEFAULT, 0,
11457						FFETARGET_charactersizeNONE,
11458						      FFEEXPR_contextLET));
11459	  linfo = ffebld_info (ffebld_left (reduced));
11460	  rinfo = ffebld_info (ffebld_right (reduced));
11461	  lbt = rbt = FFEINFO_basictypeLOGICAL;
11462	  lkt = rkt = FFEINFO_kindtypeLOGICALDEFAULT;
11463	  lrk = rrk = 0;
11464	  lkd = rkd = FFEINFO_kindENTITY;
11465	  lwh = ffeinfo_where (linfo);
11466	  rwh = ffeinfo_where (rinfo);
11467	}
11468      else
11469	{
11470	  ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
11471				 l->token, ffebld_right (reduced), r->token,
11472						       FFEEXPR_contextLET));
11473	  linfo = ffebld_info (ffebld_left (reduced));
11474	  lbt = ffeinfo_basictype (linfo);
11475	  lkt = ffeinfo_kindtype (linfo);
11476	  lrk = ffeinfo_rank (linfo);
11477	  lkd = ffeinfo_kind (linfo);
11478	  lwh = ffeinfo_where (linfo);
11479	}
11480    }
11481  else
11482    {
11483      if ((rbt == FFEINFO_basictypeTYPELESS)
11484	  || (rbt == FFEINFO_basictypeHOLLERITH))
11485	{
11486	  ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
11487				  r->token, ffebld_left (reduced), l->token,
11488						       FFEEXPR_contextLET));
11489	  rinfo = ffebld_info (ffebld_right (reduced));
11490	  rbt = ffeinfo_basictype (rinfo);
11491	  rkt = ffeinfo_kindtype (rinfo);
11492	  rrk = ffeinfo_rank (rinfo);
11493	  rkd = ffeinfo_kind (rinfo);
11494	  rwh = ffeinfo_where (rinfo);
11495	}
11496      /* else Leave it alone. */
11497    }
11498
11499  return reduced;
11500}
11501
11502/* Fumble through tokens until a nonmatching CLOSE_PAREN, EOS, or SEMICOLON
11503   is found.
11504
11505   The idea is to process the tokens as they would be done by normal
11506   expression processing, with the key things being telling the lexer
11507   when hollerith/character constants are about to happen, until the
11508   true closing token is found.  */
11509
11510static ffelexHandler
11511ffeexpr_find_close_paren_ (ffelexToken t,
11512			   ffelexHandler after)
11513{
11514  ffeexpr_find_.after = after;
11515  ffeexpr_find_.level = 1;
11516  return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11517}
11518
11519static ffelexHandler
11520ffeexpr_nil_finished_ (ffelexToken t)
11521{
11522  switch (ffelex_token_type (t))
11523    {
11524    case FFELEX_typeCLOSE_PAREN:
11525      if (--ffeexpr_find_.level == 0)
11526	return (ffelexHandler) ffeexpr_find_.after;
11527      return (ffelexHandler) ffeexpr_nil_binary_;
11528
11529    case FFELEX_typeCOMMA:
11530    case FFELEX_typeCOLON:
11531    case FFELEX_typeEQUALS:
11532    case FFELEX_typePOINTS:
11533      return (ffelexHandler) ffeexpr_nil_rhs_;
11534
11535    default:
11536      if (--ffeexpr_find_.level == 0)
11537	return (ffelexHandler) ffeexpr_find_.after (t);
11538      return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11539    }
11540}
11541
11542static ffelexHandler
11543ffeexpr_nil_rhs_ (ffelexToken t)
11544{
11545  switch (ffelex_token_type (t))
11546    {
11547    case FFELEX_typeQUOTE:
11548      if (ffe_is_vxt ())
11549	return (ffelexHandler) ffeexpr_nil_quote_;
11550      ffelex_set_expecting_hollerith (-1, '\"',
11551				      ffelex_token_where_line (t),
11552				      ffelex_token_where_column (t));
11553      return (ffelexHandler) ffeexpr_nil_apostrophe_;
11554
11555    case FFELEX_typeAPOSTROPHE:
11556      ffelex_set_expecting_hollerith (-1, '\'',
11557				      ffelex_token_where_line (t),
11558				      ffelex_token_where_column (t));
11559      return (ffelexHandler) ffeexpr_nil_apostrophe_;
11560
11561    case FFELEX_typePERCENT:
11562      return (ffelexHandler) ffeexpr_nil_percent_;
11563
11564    case FFELEX_typeOPEN_PAREN:
11565      ++ffeexpr_find_.level;
11566      return (ffelexHandler) ffeexpr_nil_rhs_;
11567
11568    case FFELEX_typePLUS:
11569    case FFELEX_typeMINUS:
11570      return (ffelexHandler) ffeexpr_nil_rhs_;
11571
11572    case FFELEX_typePERIOD:
11573      return (ffelexHandler) ffeexpr_nil_period_;
11574
11575    case FFELEX_typeNUMBER:
11576      ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
11577      if (ffeexpr_hollerith_count_ > 0)
11578	ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
11579					'\0',
11580					ffelex_token_where_line (t),
11581					ffelex_token_where_column (t));
11582      return (ffelexHandler) ffeexpr_nil_number_;
11583
11584    case FFELEX_typeNAME:
11585    case FFELEX_typeNAMES:
11586      return (ffelexHandler) ffeexpr_nil_name_rhs_;
11587
11588    case FFELEX_typeASTERISK:
11589    case FFELEX_typeSLASH:
11590    case FFELEX_typePOWER:
11591    case FFELEX_typeCONCAT:
11592    case FFELEX_typeREL_EQ:
11593    case FFELEX_typeREL_NE:
11594    case FFELEX_typeREL_LE:
11595    case FFELEX_typeREL_GE:
11596      return (ffelexHandler) ffeexpr_nil_rhs_;
11597
11598    default:
11599      return (ffelexHandler) ffeexpr_nil_finished_ (t);
11600    }
11601}
11602
11603static ffelexHandler
11604ffeexpr_nil_period_ (ffelexToken t)
11605{
11606  switch (ffelex_token_type (t))
11607    {
11608    case FFELEX_typeNAME:
11609    case FFELEX_typeNAMES:
11610      ffeexpr_current_dotdot_ = ffestr_other (t);
11611      switch (ffeexpr_current_dotdot_)
11612	{
11613	case FFESTR_otherNone:
11614	  return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11615
11616	case FFESTR_otherTRUE:
11617	case FFESTR_otherFALSE:
11618	case FFESTR_otherNOT:
11619	  return (ffelexHandler) ffeexpr_nil_end_period_;
11620
11621	default:
11622	  return (ffelexHandler) ffeexpr_nil_swallow_period_;
11623	}
11624      break;			/* Nothing really reaches here. */
11625
11626    case FFELEX_typeNUMBER:
11627      return (ffelexHandler) ffeexpr_nil_real_;
11628
11629    default:
11630      return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11631    }
11632}
11633
11634static ffelexHandler
11635ffeexpr_nil_end_period_ (ffelexToken t)
11636{
11637  switch (ffeexpr_current_dotdot_)
11638    {
11639    case FFESTR_otherNOT:
11640      if (ffelex_token_type (t) != FFELEX_typePERIOD)
11641	return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11642      return (ffelexHandler) ffeexpr_nil_rhs_;
11643
11644    case FFESTR_otherTRUE:
11645    case FFESTR_otherFALSE:
11646      if (ffelex_token_type (t) != FFELEX_typePERIOD)
11647	return (ffelexHandler) ffeexpr_nil_binary_ (t);
11648      return (ffelexHandler) ffeexpr_nil_binary_;
11649
11650    default:
11651      assert ("Bad [nil] unary dotdot in ffeexpr_current_dotdot_" == NULL);
11652      exit (0);
11653      return NULL;
11654    }
11655}
11656
11657static ffelexHandler
11658ffeexpr_nil_swallow_period_ (ffelexToken t)
11659{
11660  if (ffelex_token_type (t) != FFELEX_typePERIOD)
11661    return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11662  return (ffelexHandler) ffeexpr_nil_rhs_;
11663}
11664
11665static ffelexHandler
11666ffeexpr_nil_real_ (ffelexToken t)
11667{
11668  char d;
11669  const char *p;
11670
11671  if (((ffelex_token_type (t) != FFELEX_typeNAME)
11672       && (ffelex_token_type (t) != FFELEX_typeNAMES))
11673      || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11674				     'D', 'd')
11675	     || ffesrc_char_match_init (d, 'E', 'e')
11676	     || ffesrc_char_match_init (d, 'Q', 'q')))
11677	   && ffeexpr_isdigits_ (++p)))
11678    return (ffelexHandler) ffeexpr_nil_binary_ (t);
11679
11680  if (*p == '\0')
11681    return (ffelexHandler) ffeexpr_nil_real_exponent_;
11682  return (ffelexHandler) ffeexpr_nil_binary_;
11683}
11684
11685static ffelexHandler
11686ffeexpr_nil_real_exponent_ (ffelexToken t)
11687{
11688  if ((ffelex_token_type (t) != FFELEX_typePLUS)
11689      && (ffelex_token_type (t) != FFELEX_typeMINUS))
11690    return (ffelexHandler) ffeexpr_nil_binary_ (t);
11691
11692  return (ffelexHandler) ffeexpr_nil_real_exp_sign_;
11693}
11694
11695static ffelexHandler
11696ffeexpr_nil_real_exp_sign_ (ffelexToken t)
11697{
11698  if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11699    return (ffelexHandler) ffeexpr_nil_binary_ (t);
11700  return (ffelexHandler) ffeexpr_nil_binary_;
11701}
11702
11703static ffelexHandler
11704ffeexpr_nil_number_ (ffelexToken t)
11705{
11706  char d;
11707  const char *p;
11708
11709  if (ffeexpr_hollerith_count_ > 0)
11710    ffelex_set_expecting_hollerith (0, '\0',
11711				    ffewhere_line_unknown (),
11712				    ffewhere_column_unknown ());
11713
11714  switch (ffelex_token_type (t))
11715    {
11716    case FFELEX_typeNAME:
11717    case FFELEX_typeNAMES:
11718      if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11719				   'D', 'd')
11720	   || ffesrc_char_match_init (d, 'E', 'e')
11721	   || ffesrc_char_match_init (d, 'Q', 'q'))
11722	  && ffeexpr_isdigits_ (++p))
11723	{
11724	  if (*p == '\0')
11725	    {
11726	      ffeexpr_find_.t = ffelex_token_use (t);
11727	      return (ffelexHandler) ffeexpr_nil_number_exponent_;
11728	    }
11729	  return (ffelexHandler) ffeexpr_nil_binary_;
11730	}
11731      break;
11732
11733    case FFELEX_typePERIOD:
11734      ffeexpr_find_.t = ffelex_token_use (t);
11735      return (ffelexHandler) ffeexpr_nil_number_period_;
11736
11737    case FFELEX_typeHOLLERITH:
11738      return (ffelexHandler) ffeexpr_nil_binary_;
11739
11740    default:
11741      break;
11742    }
11743  return (ffelexHandler) ffeexpr_nil_binary_ (t);
11744}
11745
11746/* Expects ffeexpr_find_.t.  */
11747
11748static ffelexHandler
11749ffeexpr_nil_number_exponent_ (ffelexToken t)
11750{
11751  ffelexHandler nexthandler;
11752
11753  if ((ffelex_token_type (t) != FFELEX_typePLUS)
11754      && (ffelex_token_type (t) != FFELEX_typeMINUS))
11755    {
11756      nexthandler
11757	= (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
11758      ffelex_token_kill (ffeexpr_find_.t);
11759      return (ffelexHandler) (*nexthandler) (t);
11760    }
11761
11762  ffelex_token_kill (ffeexpr_find_.t);
11763  return (ffelexHandler) ffeexpr_nil_number_exp_sign_;
11764}
11765
11766static ffelexHandler
11767ffeexpr_nil_number_exp_sign_ (ffelexToken t)
11768{
11769  if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11770    return (ffelexHandler) ffeexpr_nil_binary_ (t);
11771
11772  return (ffelexHandler) ffeexpr_nil_binary_;
11773}
11774
11775/* Expects ffeexpr_find_.t.  */
11776
11777static ffelexHandler
11778ffeexpr_nil_number_period_ (ffelexToken t)
11779{
11780  ffelexHandler nexthandler;
11781  char d;
11782  const char *p;
11783
11784  switch (ffelex_token_type (t))
11785    {
11786    case FFELEX_typeNAME:
11787    case FFELEX_typeNAMES:
11788      if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11789				   'D', 'd')
11790	   || ffesrc_char_match_init (d, 'E', 'e')
11791	   || ffesrc_char_match_init (d, 'Q', 'q'))
11792	  && ffeexpr_isdigits_ (++p))
11793	{
11794	  if (*p == '\0')
11795	    return (ffelexHandler) ffeexpr_nil_number_per_exp_;
11796	  ffelex_token_kill (ffeexpr_find_.t);
11797	  return (ffelexHandler) ffeexpr_nil_binary_;
11798	}
11799      nexthandler
11800	= (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
11801      ffelex_token_kill (ffeexpr_find_.t);
11802      return (ffelexHandler) (*nexthandler) (t);
11803
11804    case FFELEX_typeNUMBER:
11805      ffelex_token_kill (ffeexpr_find_.t);
11806      return (ffelexHandler) ffeexpr_nil_number_real_;
11807
11808    default:
11809      break;
11810    }
11811  ffelex_token_kill (ffeexpr_find_.t);
11812  return (ffelexHandler) ffeexpr_nil_binary_ (t);
11813}
11814
11815/* Expects ffeexpr_find_.t.  */
11816
11817static ffelexHandler
11818ffeexpr_nil_number_per_exp_ (ffelexToken t)
11819{
11820  if ((ffelex_token_type (t) != FFELEX_typePLUS)
11821      && (ffelex_token_type (t) != FFELEX_typeMINUS))
11822    {
11823      ffelexHandler nexthandler;
11824
11825      nexthandler
11826	= (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
11827      ffelex_token_kill (ffeexpr_find_.t);
11828      return (ffelexHandler) (*nexthandler) (t);
11829    }
11830
11831  ffelex_token_kill (ffeexpr_find_.t);
11832  return (ffelexHandler) ffeexpr_nil_num_per_exp_sign_;
11833}
11834
11835static ffelexHandler
11836ffeexpr_nil_number_real_ (ffelexToken t)
11837{
11838  char d;
11839  const char *p;
11840
11841  if (((ffelex_token_type (t) != FFELEX_typeNAME)
11842       && (ffelex_token_type (t) != FFELEX_typeNAMES))
11843      || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11844				     'D', 'd')
11845	     || ffesrc_char_match_init (d, 'E', 'e')
11846	     || ffesrc_char_match_init (d, 'Q', 'q')))
11847	   && ffeexpr_isdigits_ (++p)))
11848    return (ffelexHandler) ffeexpr_nil_binary_ (t);
11849
11850  if (*p == '\0')
11851    return (ffelexHandler) ffeexpr_nil_number_real_exp_;
11852
11853  return (ffelexHandler) ffeexpr_nil_binary_;
11854}
11855
11856static ffelexHandler
11857ffeexpr_nil_num_per_exp_sign_ (ffelexToken t)
11858{
11859  if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11860    return (ffelexHandler) ffeexpr_nil_binary_ (t);
11861  return (ffelexHandler) ffeexpr_nil_binary_;
11862}
11863
11864static ffelexHandler
11865ffeexpr_nil_number_real_exp_ (ffelexToken t)
11866{
11867  if ((ffelex_token_type (t) != FFELEX_typePLUS)
11868      && (ffelex_token_type (t) != FFELEX_typeMINUS))
11869    return (ffelexHandler) ffeexpr_nil_binary_ (t);
11870  return (ffelexHandler) ffeexpr_nil_num_real_exp_sn_;
11871}
11872
11873static ffelexHandler
11874ffeexpr_nil_num_real_exp_sn_ (ffelexToken t)
11875{
11876  if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11877    return (ffelexHandler) ffeexpr_nil_binary_ (t);
11878  return (ffelexHandler) ffeexpr_nil_binary_;
11879}
11880
11881static ffelexHandler
11882ffeexpr_nil_binary_ (ffelexToken t)
11883{
11884  switch (ffelex_token_type (t))
11885    {
11886    case FFELEX_typePLUS:
11887    case FFELEX_typeMINUS:
11888    case FFELEX_typeASTERISK:
11889    case FFELEX_typeSLASH:
11890    case FFELEX_typePOWER:
11891    case FFELEX_typeCONCAT:
11892    case FFELEX_typeOPEN_ANGLE:
11893    case FFELEX_typeCLOSE_ANGLE:
11894    case FFELEX_typeREL_EQ:
11895    case FFELEX_typeREL_NE:
11896    case FFELEX_typeREL_GE:
11897    case FFELEX_typeREL_LE:
11898      return (ffelexHandler) ffeexpr_nil_rhs_;
11899
11900    case FFELEX_typePERIOD:
11901      return (ffelexHandler) ffeexpr_nil_binary_period_;
11902
11903    default:
11904      return (ffelexHandler) ffeexpr_nil_finished_ (t);
11905    }
11906}
11907
11908static ffelexHandler
11909ffeexpr_nil_binary_period_ (ffelexToken t)
11910{
11911  switch (ffelex_token_type (t))
11912    {
11913    case FFELEX_typeNAME:
11914    case FFELEX_typeNAMES:
11915      ffeexpr_current_dotdot_ = ffestr_other (t);
11916      switch (ffeexpr_current_dotdot_)
11917	{
11918	case FFESTR_otherTRUE:
11919	case FFESTR_otherFALSE:
11920	case FFESTR_otherNOT:
11921	  return (ffelexHandler) ffeexpr_nil_binary_sw_per_;
11922
11923	default:
11924	  return (ffelexHandler) ffeexpr_nil_binary_end_per_;
11925	}
11926      break;			/* Nothing really reaches here. */
11927
11928    default:
11929      return (ffelexHandler) ffeexpr_nil_binary_ (t);
11930    }
11931}
11932
11933static ffelexHandler
11934ffeexpr_nil_binary_end_per_ (ffelexToken t)
11935{
11936  if (ffelex_token_type (t) != FFELEX_typePERIOD)
11937    return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11938  return (ffelexHandler) ffeexpr_nil_rhs_;
11939}
11940
11941static ffelexHandler
11942ffeexpr_nil_binary_sw_per_ (ffelexToken t)
11943{
11944  if (ffelex_token_type (t) != FFELEX_typePERIOD)
11945    return (ffelexHandler) ffeexpr_nil_binary_ (t);
11946  return (ffelexHandler) ffeexpr_nil_binary_;
11947}
11948
11949static ffelexHandler
11950ffeexpr_nil_quote_ (ffelexToken t)
11951{
11952  if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11953    return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11954  return (ffelexHandler) ffeexpr_nil_binary_;
11955}
11956
11957static ffelexHandler
11958ffeexpr_nil_apostrophe_ (ffelexToken t)
11959{
11960  assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
11961  return (ffelexHandler) ffeexpr_nil_apos_char_;
11962}
11963
11964static ffelexHandler
11965ffeexpr_nil_apos_char_ (ffelexToken t)
11966{
11967  char c;
11968
11969  if ((ffelex_token_type (t) == FFELEX_typeNAME)
11970      || (ffelex_token_type (t) == FFELEX_typeNAMES))
11971    {
11972      if ((ffelex_token_length (t) == 1)
11973	  && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]),
11974				      'B', 'b')
11975	      || ffesrc_char_match_init (c, 'O', 'o')
11976	      || ffesrc_char_match_init (c, 'X', 'x')
11977	      || ffesrc_char_match_init (c, 'Z', 'z')))
11978	return (ffelexHandler) ffeexpr_nil_binary_;
11979    }
11980  if ((ffelex_token_type (t) == FFELEX_typeNAME)
11981      || (ffelex_token_type (t) == FFELEX_typeNAMES))
11982    return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11983  return (ffelexHandler) ffeexpr_nil_substrp_ (t);
11984}
11985
11986static ffelexHandler
11987ffeexpr_nil_name_rhs_ (ffelexToken t)
11988{
11989  switch (ffelex_token_type (t))
11990    {
11991    case FFELEX_typeQUOTE:
11992    case FFELEX_typeAPOSTROPHE:
11993      ffelex_set_hexnum (TRUE);
11994      return (ffelexHandler) ffeexpr_nil_name_apos_;
11995
11996    case FFELEX_typeOPEN_PAREN:
11997      ++ffeexpr_find_.level;
11998      return (ffelexHandler) ffeexpr_nil_rhs_;
11999
12000    default:
12001      return (ffelexHandler) ffeexpr_nil_binary_ (t);
12002    }
12003}
12004
12005static ffelexHandler
12006ffeexpr_nil_name_apos_ (ffelexToken t)
12007{
12008  if (ffelex_token_type (t) == FFELEX_typeNAME)
12009    return (ffelexHandler) ffeexpr_nil_name_apos_name_;
12010  return (ffelexHandler) ffeexpr_nil_binary_ (t);
12011}
12012
12013static ffelexHandler
12014ffeexpr_nil_name_apos_name_ (ffelexToken t)
12015{
12016  switch (ffelex_token_type (t))
12017    {
12018    case FFELEX_typeAPOSTROPHE:
12019    case FFELEX_typeQUOTE:
12020      return (ffelexHandler) ffeexpr_nil_finished_;
12021
12022    default:
12023      return (ffelexHandler) ffeexpr_nil_finished_ (t);
12024    }
12025}
12026
12027static ffelexHandler
12028ffeexpr_nil_percent_ (ffelexToken t)
12029{
12030  switch (ffelex_token_type (t))
12031    {
12032    case FFELEX_typeNAME:
12033    case FFELEX_typeNAMES:
12034      ffeexpr_stack_->percent = ffeexpr_percent_ (t);
12035      ffeexpr_find_.t = ffelex_token_use (t);
12036      return (ffelexHandler) ffeexpr_nil_percent_name_;
12037
12038    default:
12039      return (ffelexHandler) ffeexpr_nil_rhs_ (t);
12040    }
12041}
12042
12043/* Expects ffeexpr_find_.t.  */
12044
12045static ffelexHandler
12046ffeexpr_nil_percent_name_ (ffelexToken t)
12047{
12048  ffelexHandler nexthandler;
12049
12050  if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
12051    {
12052      nexthandler
12053	= (ffelexHandler) ffeexpr_nil_rhs_ (ffeexpr_find_.t);
12054      ffelex_token_kill (ffeexpr_find_.t);
12055      return (ffelexHandler) (*nexthandler) (t);
12056    }
12057
12058  ffelex_token_kill (ffeexpr_find_.t);
12059  ++ffeexpr_find_.level;
12060  return (ffelexHandler) ffeexpr_nil_rhs_;
12061}
12062
12063static ffelexHandler
12064ffeexpr_nil_substrp_ (ffelexToken t)
12065{
12066  if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
12067    return (ffelexHandler) ffeexpr_nil_binary_ (t);
12068
12069  ++ffeexpr_find_.level;
12070  return (ffelexHandler) ffeexpr_nil_rhs_;
12071}
12072
12073/* ffeexpr_finished_ -- Reduce expression stack to one expr, finish
12074
12075   ffelexToken t;
12076   return ffeexpr_finished_(t);
12077
12078   Reduces expression stack to one (or zero) elements by repeatedly reducing
12079   the top operator on the stack (or, if the top element on the stack is
12080   itself an operator, issuing an error message and discarding it).  Calls
12081   finishing routine with the expression, returning the ffelexHandler it
12082   returns to the caller.  */
12083
12084static ffelexHandler
12085ffeexpr_finished_ (ffelexToken t)
12086{
12087  ffeexprExpr_ operand;		/* This is B in -B or A+B. */
12088  ffebld expr;
12089  ffeexprCallback callback;
12090  ffeexprStack_ s;
12091  ffebldConstant constnode;	/* For detecting magical number. */
12092  ffelexToken ft;		/* Temporary copy of first token in
12093				   expression. */
12094  ffelexHandler next;
12095  ffeinfo info;
12096  bool error = FALSE;
12097
12098  while (((operand = ffeexpr_stack_->exprstack) != NULL)
12099	 && ((operand->previous != NULL) || (operand->type != FFEEXPR_exprtypeOPERAND_)))
12100    {
12101      if (operand->type == FFEEXPR_exprtypeOPERAND_)
12102	ffeexpr_reduce_ ();
12103      else
12104	{
12105	  if (ffest_ffebad_start (FFEBAD_MISSING_OPERAND_FOR_OPERATOR))
12106	    {
12107	      ffebad_here (0, ffelex_token_where_line (t),
12108			   ffelex_token_where_column (t));
12109	      ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
12110	      ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
12111	      ffebad_finish ();
12112	    }
12113	  ffeexpr_stack_->exprstack = operand->previous;	/* Pop the useless
12114								   operator. */
12115	  ffeexpr_expr_kill_ (operand);
12116	}
12117    }
12118
12119  assert ((operand == NULL) || (operand->previous == NULL));
12120
12121  ffebld_pool_pop ();
12122  if (operand == NULL)
12123    expr = NULL;
12124  else
12125    {
12126      expr = operand->u.operand;
12127      info = ffebld_info (expr);
12128      if ((ffebld_op (expr) == FFEBLD_opCONTER)
12129	  && (ffebld_conter_orig (expr) == NULL)
12130	  && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
12131	{
12132	  ffetarget_integer_bad_magical (operand->token);
12133	}
12134      ffeexpr_expr_kill_ (operand);
12135      ffeexpr_stack_->exprstack = NULL;
12136    }
12137
12138  ft = ffeexpr_stack_->first_token;
12139
12140again:				/* :::::::::::::::::::: */
12141  switch (ffeexpr_stack_->context)
12142    {
12143    case FFEEXPR_contextLET:
12144    case FFEEXPR_contextSFUNCDEF:
12145      error = (expr == NULL)
12146	|| (ffeinfo_rank (info) != 0);
12147      break;
12148
12149    case FFEEXPR_contextPAREN_:
12150      if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12151	break;
12152      switch (ffeinfo_basictype (info))
12153	{
12154	case FFEINFO_basictypeHOLLERITH:
12155	case FFEINFO_basictypeTYPELESS:
12156	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12157	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12158				  FFEEXPR_contextLET);
12159	  break;
12160
12161	default:
12162	  break;
12163	}
12164      break;
12165
12166    case FFEEXPR_contextPARENFILENUM_:
12167      if (ffelex_token_type (t) != FFELEX_typeCOMMA)
12168	ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
12169      else
12170	ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
12171      goto again;		/* :::::::::::::::::::: */
12172
12173    case FFEEXPR_contextPARENFILEUNIT_:
12174      if (ffelex_token_type (t) != FFELEX_typeCOMMA)
12175	ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
12176      else
12177	ffeexpr_stack_->context = FFEEXPR_contextFILEUNIT;
12178      goto again;		/* :::::::::::::::::::: */
12179
12180    case FFEEXPR_contextACTUALARGEXPR_:
12181    case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
12182      switch ((expr == NULL) ? FFEINFO_basictypeNONE
12183	      : ffeinfo_basictype (info))
12184	{
12185	case FFEINFO_basictypeHOLLERITH:
12186	case FFEINFO_basictypeTYPELESS:
12187	  if (!ffe_is_ugly_args ()
12188	      && ffebad_start (FFEBAD_ACTUALARG))
12189	    {
12190	      ffebad_here (0, ffelex_token_where_line (ft),
12191			   ffelex_token_where_column (ft));
12192	      ffebad_finish ();
12193	    }
12194	  break;
12195
12196	default:
12197	  break;
12198	}
12199      error = (expr != NULL) && (ffeinfo_rank (info) != 0);
12200      break;
12201
12202    case FFEEXPR_contextACTUALARG_:
12203    case FFEEXPR_contextSFUNCDEFACTUALARG_:
12204      switch ((expr == NULL) ? FFEINFO_basictypeNONE
12205	      : ffeinfo_basictype (info))
12206	{
12207	case FFEINFO_basictypeHOLLERITH:
12208	case FFEINFO_basictypeTYPELESS:
12209#if 0				/* Should never get here. */
12210	  expr = ffeexpr_convert (expr, ft, ft,
12211				  FFEINFO_basictypeINTEGER,
12212				  FFEINFO_kindtypeINTEGERDEFAULT,
12213				  0,
12214				  FFETARGET_charactersizeNONE,
12215				  FFEEXPR_contextLET);
12216#else
12217	  assert ("why hollerith/typeless in actualarg_?" == NULL);
12218#endif
12219	  break;
12220
12221	default:
12222	  break;
12223	}
12224      switch ((expr == NULL) ? FFEBLD_opANY : ffebld_op (expr))
12225	{
12226	case FFEBLD_opSYMTER:
12227	case FFEBLD_opPERCENT_LOC:
12228	case FFEBLD_opPERCENT_VAL:
12229	case FFEBLD_opPERCENT_REF:
12230	case FFEBLD_opPERCENT_DESCR:
12231	  error = FALSE;
12232	  break;
12233
12234	default:
12235	  error = (expr != NULL) && (ffeinfo_rank (info) != 0);
12236	  break;
12237	}
12238      {
12239	ffesymbol s;
12240	ffeinfoWhere where;
12241	ffeinfoKind kind;
12242
12243	if (!error
12244	    && (expr != NULL)
12245	    && (ffebld_op (expr) == FFEBLD_opSYMTER)
12246	    && ((s = ffebld_symter (expr)), (where = ffesymbol_where (s)),
12247		(where == FFEINFO_whereINTRINSIC)
12248		|| (where == FFEINFO_whereGLOBAL)
12249		|| ((where == FFEINFO_whereDUMMY)
12250		    && ((kind = ffesymbol_kind (s)),
12251			(kind == FFEINFO_kindFUNCTION)
12252			|| (kind == FFEINFO_kindSUBROUTINE))))
12253	    && !ffesymbol_explicitwhere (s))
12254	  {
12255	    ffebad_start (where == FFEINFO_whereINTRINSIC
12256			  ? FFEBAD_NEED_INTRINSIC : FFEBAD_NEED_EXTERNAL);
12257	    ffebad_here (0, ffelex_token_where_line (ft),
12258			 ffelex_token_where_column (ft));
12259	    ffebad_string (ffesymbol_text (s));
12260	    ffebad_finish ();
12261	    ffesymbol_signal_change (s);
12262	    ffesymbol_set_explicitwhere (s, TRUE);
12263	    ffesymbol_signal_unreported (s);
12264	  }
12265      }
12266      break;
12267
12268    case FFEEXPR_contextINDEX_:
12269    case FFEEXPR_contextSFUNCDEFINDEX_:
12270      if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12271	break;
12272      switch ((expr == NULL) ? FFEINFO_basictypeNONE
12273	      : ffeinfo_basictype (info))
12274	{
12275	case FFEINFO_basictypeNONE:
12276	  error = FALSE;
12277	  break;
12278
12279	case FFEINFO_basictypeLOGICAL:
12280	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12281	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12282				  FFEEXPR_contextLET);
12283	  /* Fall through. */
12284	case FFEINFO_basictypeREAL:
12285	case FFEINFO_basictypeCOMPLEX:
12286	  if (ffe_is_pedantic ())
12287	    {
12288	      error = TRUE;
12289	      break;
12290	    }
12291	  /* Fall through. */
12292	case FFEINFO_basictypeHOLLERITH:
12293	case FFEINFO_basictypeTYPELESS:
12294	  error = FALSE;
12295	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12296	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12297				  FFEEXPR_contextLET);
12298	  break;
12299
12300	case FFEINFO_basictypeINTEGER:
12301	  /* Specifically, allow INTEGER(KIND=2), aka INTEGER*8, through
12302	     unmolested.  Leave it to downstream to handle kinds.  */
12303	  break;
12304
12305	default:
12306	  error = TRUE;
12307	  break;
12308	}
12309      break;			/* expr==NULL ok for substring; element case
12310				   caught by callback. */
12311
12312    case FFEEXPR_contextRETURN:
12313      if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12314	break;
12315      switch ((expr == NULL) ? FFEINFO_basictypeNONE
12316	      : ffeinfo_basictype (info))
12317	{
12318	case FFEINFO_basictypeNONE:
12319	  error = FALSE;
12320	  break;
12321
12322	case FFEINFO_basictypeLOGICAL:
12323	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12324	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12325				  FFEEXPR_contextLET);
12326	  /* Fall through. */
12327	case FFEINFO_basictypeREAL:
12328	case FFEINFO_basictypeCOMPLEX:
12329	  if (ffe_is_pedantic ())
12330	    {
12331	      error = TRUE;
12332	      break;
12333	    }
12334	  /* Fall through. */
12335	case FFEINFO_basictypeINTEGER:
12336	case FFEINFO_basictypeHOLLERITH:
12337	case FFEINFO_basictypeTYPELESS:
12338	  error = FALSE;
12339	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12340	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12341				  FFEEXPR_contextLET);
12342	  break;
12343
12344	default:
12345	  error = TRUE;
12346	  break;
12347	}
12348      break;
12349
12350    case FFEEXPR_contextDO:
12351      if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12352	break;
12353      switch (ffeinfo_basictype (info))
12354	{
12355	case FFEINFO_basictypeLOGICAL:
12356	  error = !ffe_is_ugly_logint ();
12357	  if (!ffeexpr_stack_->is_rhs)
12358	    break;		/* Don't convert lhs variable. */
12359	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12360				  ffeinfo_kindtype (ffebld_info (expr)), 0,
12361				  FFETARGET_charactersizeNONE,
12362				  FFEEXPR_contextLET);
12363	  break;
12364
12365	case FFEINFO_basictypeHOLLERITH:
12366	case FFEINFO_basictypeTYPELESS:
12367	  if (!ffeexpr_stack_->is_rhs)
12368	    {
12369	      error = TRUE;
12370	      break;		/* Don't convert lhs variable. */
12371	    }
12372	  break;
12373
12374	case FFEINFO_basictypeINTEGER:
12375	case FFEINFO_basictypeREAL:
12376	  break;
12377
12378	default:
12379	  error = TRUE;
12380	  break;
12381	}
12382      if (!ffeexpr_stack_->is_rhs
12383	  && (ffebld_op (expr) != FFEBLD_opSYMTER))
12384	error = TRUE;
12385      break;
12386
12387    case FFEEXPR_contextDOWHILE:
12388    case FFEEXPR_contextIF:
12389      if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12390	break;
12391      switch (ffeinfo_basictype (info))
12392	{
12393	case FFEINFO_basictypeINTEGER:
12394	  error = FALSE;
12395	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12396	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12397				  FFEEXPR_contextLET);
12398	  /* Fall through. */
12399	case FFEINFO_basictypeLOGICAL:
12400	case FFEINFO_basictypeHOLLERITH:
12401	case FFEINFO_basictypeTYPELESS:
12402	  error = FALSE;
12403	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12404	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12405				  FFEEXPR_contextLET);
12406	  break;
12407
12408	default:
12409	  error = TRUE;
12410	  break;
12411	}
12412      break;
12413
12414    case FFEEXPR_contextASSIGN:
12415    case FFEEXPR_contextAGOTO:
12416      switch ((expr == NULL) ? FFEINFO_basictypeNONE
12417	      : ffeinfo_basictype (info))
12418	{
12419	case FFEINFO_basictypeINTEGER:
12420	  error = (ffeinfo_kindtype (info) != ffecom_label_kind ());
12421	  break;
12422
12423	case FFEINFO_basictypeLOGICAL:
12424	  error = !ffe_is_ugly_logint ()
12425	    || (ffeinfo_kindtype (info) != ffecom_label_kind ());
12426	  break;
12427
12428	default:
12429	  error = TRUE;
12430	  break;
12431	}
12432      if ((expr == NULL) || (ffeinfo_rank (info) != 0)
12433	  || (ffebld_op (expr) != FFEBLD_opSYMTER))
12434	error = TRUE;
12435      break;
12436
12437    case FFEEXPR_contextCGOTO:
12438    case FFEEXPR_contextFORMAT:
12439    case FFEEXPR_contextDIMLIST:
12440    case FFEEXPR_contextFILENUM:	/* See equiv code in _ambig_. */
12441      if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12442	break;
12443      switch (ffeinfo_basictype (info))
12444	{
12445	case FFEINFO_basictypeLOGICAL:
12446	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12447	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12448				  FFEEXPR_contextLET);
12449	  /* Fall through. */
12450	case FFEINFO_basictypeREAL:
12451	case FFEINFO_basictypeCOMPLEX:
12452	  if (ffe_is_pedantic ())
12453	    {
12454	      error = TRUE;
12455	      break;
12456	    }
12457	  /* Fall through. */
12458	case FFEINFO_basictypeINTEGER:
12459	case FFEINFO_basictypeHOLLERITH:
12460	case FFEINFO_basictypeTYPELESS:
12461	  error = FALSE;
12462	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12463	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12464				  FFEEXPR_contextLET);
12465	  break;
12466
12467	default:
12468	  error = TRUE;
12469	  break;
12470	}
12471      break;
12472
12473    case FFEEXPR_contextARITHIF:
12474      if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12475	break;
12476      switch (ffeinfo_basictype (info))
12477	{
12478	case FFEINFO_basictypeLOGICAL:
12479	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12480	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12481				  FFEEXPR_contextLET);
12482	  if (ffe_is_pedantic ())
12483	    {
12484	      error = TRUE;
12485	      break;
12486	    }
12487	  /* Fall through. */
12488	case FFEINFO_basictypeHOLLERITH:
12489	case FFEINFO_basictypeTYPELESS:
12490	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12491	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12492				  FFEEXPR_contextLET);
12493	  /* Fall through. */
12494	case FFEINFO_basictypeINTEGER:
12495	case FFEINFO_basictypeREAL:
12496	  error = FALSE;
12497	  break;
12498
12499	default:
12500	  error = TRUE;
12501	  break;
12502	}
12503      break;
12504
12505    case FFEEXPR_contextSTOP:
12506      if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12507	break;
12508      switch ((expr == NULL) ? FFEINFO_basictypeNONE
12509	      : ffeinfo_basictype (info))
12510	{
12511	case FFEINFO_basictypeINTEGER:
12512	  error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12513	  break;
12514
12515	case FFEINFO_basictypeCHARACTER:
12516	  error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT);
12517	  break;
12518
12519	case FFEINFO_basictypeHOLLERITH:
12520	case FFEINFO_basictypeTYPELESS:
12521	  error = FALSE;
12522	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12523	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12524				  FFEEXPR_contextLET);
12525	  break;
12526
12527	case FFEINFO_basictypeNONE:
12528	  error = FALSE;
12529	  break;
12530
12531	default:
12532	  error = TRUE;
12533	  break;
12534	}
12535      if ((expr != NULL) && ((ffebld_op (expr) != FFEBLD_opCONTER)
12536			     || (ffebld_conter_orig (expr) != NULL)))
12537	error = TRUE;
12538      break;
12539
12540    case FFEEXPR_contextINCLUDE:
12541      error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12542	|| (ffeinfo_basictype (info) != FFEINFO_basictypeCHARACTER)
12543	|| (ffebld_op (expr) != FFEBLD_opCONTER)
12544	|| (ffebld_conter_orig (expr) != NULL);
12545      break;
12546
12547    case FFEEXPR_contextSELECTCASE:
12548      if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12549	break;
12550      switch (ffeinfo_basictype (info))
12551	{
12552	case FFEINFO_basictypeINTEGER:
12553	case FFEINFO_basictypeCHARACTER:
12554	case FFEINFO_basictypeLOGICAL:
12555	  error = FALSE;
12556	  break;
12557
12558	case FFEINFO_basictypeHOLLERITH:
12559	case FFEINFO_basictypeTYPELESS:
12560	  error = FALSE;
12561	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12562	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12563				  FFEEXPR_contextLET);
12564	  break;
12565
12566	default:
12567	  error = TRUE;
12568	  break;
12569	}
12570      break;
12571
12572    case FFEEXPR_contextCASE:
12573      if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12574	break;
12575      switch ((expr == NULL) ? FFEINFO_basictypeINTEGER
12576	      : ffeinfo_basictype (info))
12577	{
12578	case FFEINFO_basictypeINTEGER:
12579	case FFEINFO_basictypeCHARACTER:
12580	case FFEINFO_basictypeLOGICAL:
12581	  error = FALSE;
12582	  break;
12583
12584	case FFEINFO_basictypeHOLLERITH:
12585	case FFEINFO_basictypeTYPELESS:
12586	  error = FALSE;
12587	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12588	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12589				  FFEEXPR_contextLET);
12590	  break;
12591
12592	default:
12593	  error = TRUE;
12594	  break;
12595	}
12596      if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12597	error = TRUE;
12598      break;
12599
12600    case FFEEXPR_contextCHARACTERSIZE:
12601    case FFEEXPR_contextKINDTYPE:
12602    case FFEEXPR_contextDIMLISTCOMMON:
12603      if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12604	break;
12605      switch ((expr == NULL) ? FFEINFO_basictypeNONE
12606	      : ffeinfo_basictype (info))
12607	{
12608	case FFEINFO_basictypeLOGICAL:
12609	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12610	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12611				  FFEEXPR_contextLET);
12612	  /* Fall through. */
12613	case FFEINFO_basictypeREAL:
12614	case FFEINFO_basictypeCOMPLEX:
12615	  if (ffe_is_pedantic ())
12616	    {
12617	      error = TRUE;
12618	      break;
12619	    }
12620	  /* Fall through. */
12621	case FFEINFO_basictypeINTEGER:
12622	case FFEINFO_basictypeHOLLERITH:
12623	case FFEINFO_basictypeTYPELESS:
12624	  error = FALSE;
12625	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12626	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12627				  FFEEXPR_contextLET);
12628	  break;
12629
12630	default:
12631	  error = TRUE;
12632	  break;
12633	}
12634      if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12635	error = TRUE;
12636      break;
12637
12638    case FFEEXPR_contextEQVINDEX_:
12639      if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12640	break;
12641      switch ((expr == NULL) ? FFEINFO_basictypeNONE
12642	      : ffeinfo_basictype (info))
12643	{
12644	case FFEINFO_basictypeNONE:
12645	  error = FALSE;
12646	  break;
12647
12648	case FFEINFO_basictypeLOGICAL:
12649	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12650	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12651				  FFEEXPR_contextLET);
12652	  /* Fall through. */
12653	case FFEINFO_basictypeREAL:
12654	case FFEINFO_basictypeCOMPLEX:
12655	  if (ffe_is_pedantic ())
12656	    {
12657	      error = TRUE;
12658	      break;
12659	    }
12660	  /* Fall through. */
12661	case FFEINFO_basictypeINTEGER:
12662	case FFEINFO_basictypeHOLLERITH:
12663	case FFEINFO_basictypeTYPELESS:
12664	  error = FALSE;
12665	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12666	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12667				  FFEEXPR_contextLET);
12668	  break;
12669
12670	default:
12671	  error = TRUE;
12672	  break;
12673	}
12674      if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12675	error = TRUE;
12676      break;
12677
12678    case FFEEXPR_contextPARAMETER:
12679      if (ffeexpr_stack_->is_rhs)
12680	error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12681	  || (ffebld_op (expr) != FFEBLD_opCONTER);
12682      else
12683	error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12684	  || (ffebld_op (expr) != FFEBLD_opSYMTER);
12685      break;
12686
12687    case FFEEXPR_contextINDEXORACTUALARG_:
12688      if (ffelex_token_type (t) == FFELEX_typeCOLON)
12689	ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
12690      else
12691	ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
12692      goto again;		/* :::::::::::::::::::: */
12693
12694    case FFEEXPR_contextINDEXORACTUALARGEXPR_:
12695      if (ffelex_token_type (t) == FFELEX_typeCOLON)
12696	ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
12697      else
12698	ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
12699      goto again;		/* :::::::::::::::::::: */
12700
12701    case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
12702      if (ffelex_token_type (t) == FFELEX_typeCOLON)
12703	ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
12704      else
12705	ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
12706      goto again;		/* :::::::::::::::::::: */
12707
12708    case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
12709      if (ffelex_token_type (t) == FFELEX_typeCOLON)
12710	ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
12711      else
12712	ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
12713      goto again;		/* :::::::::::::::::::: */
12714
12715    case FFEEXPR_contextIMPDOCTRL_:
12716      if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12717	break;
12718      if (!ffeexpr_stack_->is_rhs
12719	  && (ffebld_op (expr) != FFEBLD_opSYMTER))
12720	error = TRUE;
12721      switch (ffeinfo_basictype (info))
12722	{
12723	case FFEINFO_basictypeLOGICAL:
12724	  if (! ffe_is_ugly_logint ())
12725	    error = TRUE;
12726	  if (! ffeexpr_stack_->is_rhs)
12727	    break;
12728	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12729				  ffeinfo_kindtype (info), 0,
12730				  FFETARGET_charactersizeNONE,
12731				  FFEEXPR_contextLET);
12732	  break;
12733
12734	case FFEINFO_basictypeINTEGER:
12735	case FFEINFO_basictypeHOLLERITH:
12736	case FFEINFO_basictypeTYPELESS:
12737	  break;
12738
12739	case FFEINFO_basictypeREAL:
12740	  if (!ffeexpr_stack_->is_rhs
12741	      && ffe_is_warn_surprising ()
12742	      && !error)
12743	    {
12744	      ffebad_start (FFEBAD_DO_REAL);	/* See error message!!! */
12745	      ffebad_here (0, ffelex_token_where_line (ft),
12746			   ffelex_token_where_column (ft));
12747	      ffebad_string (ffelex_token_text (ft));
12748	      ffebad_finish ();
12749	    }
12750	  break;
12751
12752	default:
12753	  error = TRUE;
12754	  break;
12755	}
12756      break;
12757
12758    case FFEEXPR_contextDATAIMPDOCTRL_:
12759      if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12760	break;
12761      if (ffeexpr_stack_->is_rhs)
12762	{
12763	  if ((ffebld_op (expr) != FFEBLD_opCONTER)
12764	      && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12765	    error = TRUE;
12766	}
12767      else if ((ffebld_op (expr) != FFEBLD_opSYMTER)
12768	       || (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12769	error = TRUE;
12770      switch (ffeinfo_basictype (info))
12771	{
12772	case FFEINFO_basictypeLOGICAL:
12773	  if (! ffeexpr_stack_->is_rhs)
12774	    break;
12775	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12776				  ffeinfo_kindtype (info), 0,
12777				  FFETARGET_charactersizeNONE,
12778				  FFEEXPR_contextLET);
12779	  /* Fall through.  */
12780	case FFEINFO_basictypeINTEGER:
12781	  if (ffeexpr_stack_->is_rhs
12782	      && (ffeinfo_kindtype (ffebld_info (expr))
12783		  != FFEINFO_kindtypeINTEGERDEFAULT))
12784	    expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12785				    FFEINFO_kindtypeINTEGERDEFAULT, 0,
12786				    FFETARGET_charactersizeNONE,
12787				    FFEEXPR_contextLET);
12788	  break;
12789
12790	case FFEINFO_basictypeHOLLERITH:
12791	case FFEINFO_basictypeTYPELESS:
12792	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12793	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12794				  FFEEXPR_contextLET);
12795	  break;
12796
12797	case FFEINFO_basictypeREAL:
12798	  if (!ffeexpr_stack_->is_rhs
12799	      && ffe_is_warn_surprising ()
12800	      && !error)
12801	    {
12802	      ffebad_start (FFEBAD_DO_REAL);	/* See error message!!! */
12803	      ffebad_here (0, ffelex_token_where_line (ft),
12804			   ffelex_token_where_column (ft));
12805	      ffebad_string (ffelex_token_text (ft));
12806	      ffebad_finish ();
12807	    }
12808	  break;
12809
12810	default:
12811	  error = TRUE;
12812	  break;
12813	}
12814      break;
12815
12816    case FFEEXPR_contextIMPDOITEM_:
12817      if (ffelex_token_type (t) == FFELEX_typeEQUALS)
12818	{
12819	  ffeexpr_stack_->is_rhs = FALSE;
12820	  ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
12821	  goto again;		/* :::::::::::::::::::: */
12822	}
12823      /* Fall through. */
12824    case FFEEXPR_contextIOLIST:
12825    case FFEEXPR_contextFILEVXTCODE:
12826      switch ((expr == NULL) ? FFEINFO_basictypeNONE
12827	      : ffeinfo_basictype (info))
12828	{
12829	case FFEINFO_basictypeHOLLERITH:
12830	case FFEINFO_basictypeTYPELESS:
12831	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12832	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12833				  FFEEXPR_contextLET);
12834	  break;
12835
12836	default:
12837	  break;
12838	}
12839      error = (expr == NULL)
12840	|| ((ffeinfo_rank (info) != 0)
12841	    && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12842		|| (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12843		|| (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12844		    == FFEBLD_opSTAR)));	/* Bad if null expr, or if
12845						   array that is not a SYMTER
12846						   (can't happen yet, I
12847						   think) or has a NULL or
12848						   STAR (assumed) array
12849						   size. */
12850      break;
12851
12852    case FFEEXPR_contextIMPDOITEMDF_:
12853      if (ffelex_token_type (t) == FFELEX_typeEQUALS)
12854	{
12855	  ffeexpr_stack_->is_rhs = FALSE;
12856	  ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
12857	  goto again;		/* :::::::::::::::::::: */
12858	}
12859      /* Fall through. */
12860    case FFEEXPR_contextIOLISTDF:
12861      switch ((expr == NULL) ? FFEINFO_basictypeNONE
12862	      : ffeinfo_basictype (info))
12863	{
12864	case FFEINFO_basictypeHOLLERITH:
12865	case FFEINFO_basictypeTYPELESS:
12866	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12867	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12868				  FFEEXPR_contextLET);
12869	  break;
12870
12871	default:
12872	  break;
12873	}
12874      error
12875	= (expr == NULL)
12876	  || ((ffeinfo_basictype (info) == FFEINFO_basictypeCHARACTER)
12877	      && (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT))
12878	    || ((ffeinfo_rank (info) != 0)
12879		&& ((ffebld_op (expr) != FFEBLD_opSYMTER)
12880		    || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12881		    || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12882			== FFEBLD_opSTAR)));	/* Bad if null expr,
12883						   non-default-kindtype
12884						   character expr, or if
12885						   array that is not a SYMTER
12886						   (can't happen yet, I
12887						   think) or has a NULL or
12888						   STAR (assumed) array
12889						   size. */
12890      break;
12891
12892    case FFEEXPR_contextDATAIMPDOITEM_:
12893      error = (expr == NULL)
12894	|| (ffebld_op (expr) != FFEBLD_opARRAYREF)
12895	|| ((ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR)
12896	    && (ffeinfo_where (info) != FFEINFO_whereFLEETING_IADDR));
12897      break;
12898
12899    case FFEEXPR_contextDATAIMPDOINDEX_:
12900      if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12901	break;
12902      switch (ffeinfo_basictype (info))
12903	{
12904	case FFEINFO_basictypeLOGICAL:
12905	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12906	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12907				  FFEEXPR_contextLET);
12908	  /* Fall through. */
12909	case FFEINFO_basictypeREAL:
12910	case FFEINFO_basictypeCOMPLEX:
12911	  if (ffe_is_pedantic ())
12912	    {
12913	      error = TRUE;
12914	      break;
12915	    }
12916	  /* Fall through. */
12917	case FFEINFO_basictypeINTEGER:
12918	case FFEINFO_basictypeHOLLERITH:
12919	case FFEINFO_basictypeTYPELESS:
12920	  error = FALSE;
12921	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12922	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12923				  FFEEXPR_contextLET);
12924	  break;
12925
12926	default:
12927	  error = TRUE;
12928	  break;
12929	}
12930      if ((ffeinfo_where (info) != FFEINFO_whereCONSTANT)
12931	  && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12932	error = TRUE;
12933      break;
12934
12935    case FFEEXPR_contextDATA:
12936      if (expr == NULL)
12937	error = TRUE;
12938      else if (ffeexpr_stack_->is_rhs)
12939	error = (ffebld_op (expr) != FFEBLD_opCONTER);
12940      else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12941	error = FALSE;
12942      else
12943	error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12944      break;
12945
12946    case FFEEXPR_contextINITVAL:
12947      error = (expr == NULL) || (ffebld_op (expr) != FFEBLD_opCONTER);
12948      break;
12949
12950    case FFEEXPR_contextEQUIVALENCE:
12951      if (expr == NULL)
12952	error = TRUE;
12953      else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12954	error = FALSE;
12955      else
12956	error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12957      break;
12958
12959    case FFEEXPR_contextFILEASSOC:
12960    case FFEEXPR_contextFILEINT:
12961      switch ((expr == NULL) ? FFEINFO_basictypeNONE
12962	      : ffeinfo_basictype (info))
12963	{
12964	case FFEINFO_basictypeINTEGER:
12965	  /* Maybe this should be supported someday, but, right now,
12966	     g77 can't generate a call to libf2c to write to an
12967	     integer other than the default size.  */
12968	  error = ((! ffeexpr_stack_->is_rhs)
12969		   && ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12970	  break;
12971
12972	default:
12973	  error = TRUE;
12974	  break;
12975	}
12976      if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12977	error = TRUE;
12978      break;
12979
12980    case FFEEXPR_contextFILEDFINT:
12981      switch ((expr == NULL) ? FFEINFO_basictypeNONE
12982	      : ffeinfo_basictype (info))
12983	{
12984	case FFEINFO_basictypeINTEGER:
12985	  error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12986	  break;
12987
12988	default:
12989	  error = TRUE;
12990	  break;
12991	}
12992      if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12993	error = TRUE;
12994      break;
12995
12996    case FFEEXPR_contextFILELOG:
12997      switch ((expr == NULL) ? FFEINFO_basictypeNONE
12998	      : ffeinfo_basictype (info))
12999	{
13000	case FFEINFO_basictypeLOGICAL:
13001	  error = FALSE;
13002	  break;
13003
13004	default:
13005	  error = TRUE;
13006	  break;
13007	}
13008      if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13009	error = TRUE;
13010      break;
13011
13012    case FFEEXPR_contextFILECHAR:
13013      switch ((expr == NULL) ? FFEINFO_basictypeNONE
13014	      : ffeinfo_basictype (info))
13015	{
13016	case FFEINFO_basictypeCHARACTER:
13017	  error = FALSE;
13018	  break;
13019
13020	default:
13021	  error = TRUE;
13022	  break;
13023	}
13024      if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13025	error = TRUE;
13026      break;
13027
13028    case FFEEXPR_contextFILENUMCHAR:
13029      if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
13030	break;
13031      switch (ffeinfo_basictype (info))
13032	{
13033	case FFEINFO_basictypeLOGICAL:
13034	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13035	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13036				  FFEEXPR_contextLET);
13037	  /* Fall through. */
13038	case FFEINFO_basictypeREAL:
13039	case FFEINFO_basictypeCOMPLEX:
13040	  if (ffe_is_pedantic ())
13041	    {
13042	      error = TRUE;
13043	      break;
13044	    }
13045	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13046	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13047				  FFEEXPR_contextLET);
13048	  break;
13049
13050	case FFEINFO_basictypeINTEGER:
13051	case FFEINFO_basictypeCHARACTER:
13052	  error = FALSE;
13053	  break;
13054
13055	default:
13056	  error = TRUE;
13057	  break;
13058	}
13059      break;
13060
13061    case FFEEXPR_contextFILEDFCHAR:
13062      if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
13063	break;
13064      switch (ffeinfo_basictype (info))
13065	{
13066	case FFEINFO_basictypeCHARACTER:
13067	  error
13068	    = (ffeinfo_kindtype (info)
13069	       != FFEINFO_kindtypeCHARACTERDEFAULT);
13070	  break;
13071
13072	default:
13073	  error = TRUE;
13074	  break;
13075	}
13076      if (!ffeexpr_stack_->is_rhs
13077	  && (ffebld_op (expr) == FFEBLD_opSUBSTR))
13078	error = TRUE;
13079      break;
13080
13081    case FFEEXPR_contextFILEUNIT:	/* See equiv code in _ambig_. */
13082      switch ((expr == NULL) ? FFEINFO_basictypeNONE
13083	      : ffeinfo_basictype (info))
13084	{
13085	case FFEINFO_basictypeLOGICAL:
13086	  if ((error = (ffeinfo_rank (info) != 0)))
13087	    break;
13088	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13089	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13090				  FFEEXPR_contextLET);
13091	  /* Fall through. */
13092	case FFEINFO_basictypeREAL:
13093	case FFEINFO_basictypeCOMPLEX:
13094	  if ((error = (ffeinfo_rank (info) != 0)))
13095	    break;
13096	  if (ffe_is_pedantic ())
13097	    {
13098	      error = TRUE;
13099	      break;
13100	    }
13101	  /* Fall through. */
13102	case FFEINFO_basictypeINTEGER:
13103	case FFEINFO_basictypeHOLLERITH:
13104	case FFEINFO_basictypeTYPELESS:
13105	  if ((error = (ffeinfo_rank (info) != 0)))
13106	    break;
13107	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13108	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13109				  FFEEXPR_contextLET);
13110	  break;
13111
13112	case FFEINFO_basictypeCHARACTER:
13113	  switch (ffebld_op (expr))
13114	    {			/* As if _lhs had been called instead of
13115				   _rhs. */
13116	    case FFEBLD_opSYMTER:
13117	      error
13118		= (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
13119	      break;
13120
13121	    case FFEBLD_opSUBSTR:
13122	      error = (ffeinfo_where (ffebld_info (expr))
13123		       == FFEINFO_whereCONSTANT_SUBOBJECT);
13124	      break;
13125
13126	    case FFEBLD_opARRAYREF:
13127	      error = FALSE;
13128	      break;
13129
13130	    default:
13131	      error = TRUE;
13132	      break;
13133	    }
13134	  if (!error
13135	   && ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
13136	       || ((ffeinfo_rank (info) != 0)
13137		   && ((ffebld_op (expr) != FFEBLD_opSYMTER)
13138		     || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
13139		  || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
13140		      == FFEBLD_opSTAR)))))	/* Bad if
13141						   non-default-kindtype
13142						   character expr, or if
13143						   array that is not a SYMTER
13144						   (can't happen yet, I
13145						   think), or has a NULL or
13146						   STAR (assumed) array
13147						   size. */
13148	    error = TRUE;
13149	  break;
13150
13151	default:
13152	  error = TRUE;
13153	  break;
13154	}
13155      break;
13156
13157    case FFEEXPR_contextFILEFORMAT:
13158      switch ((expr == NULL) ? FFEINFO_basictypeNONE
13159	      : ffeinfo_basictype (info))
13160	{
13161	case FFEINFO_basictypeINTEGER:
13162	  error = (expr == NULL)
13163	    || ((ffeinfo_rank (info) != 0) ?
13164		ffe_is_pedantic ()	/* F77 C5. */
13165		: (ffeinfo_kindtype (info) != ffecom_label_kind ()))
13166	    || (ffebld_op (expr) != FFEBLD_opSYMTER);
13167	  break;
13168
13169	case FFEINFO_basictypeLOGICAL:
13170	case FFEINFO_basictypeREAL:
13171	case FFEINFO_basictypeCOMPLEX:
13172	  /* F77 C5 -- must be an array of hollerith.  */
13173	  error
13174	    = ffe_is_pedantic ()
13175	      || (ffeinfo_rank (info) == 0);
13176	  break;
13177
13178	case FFEINFO_basictypeCHARACTER:
13179	  if ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
13180	      || ((ffeinfo_rank (info) != 0)
13181		  && ((ffebld_op (expr) != FFEBLD_opSYMTER)
13182		      || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
13183		      || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
13184			  == FFEBLD_opSTAR))))	/* Bad if
13185						   non-default-kindtype
13186						   character expr, or if
13187						   array that is not a SYMTER
13188						   (can't happen yet, I
13189						   think), or has a NULL or
13190						   STAR (assumed) array
13191						   size. */
13192	    error = TRUE;
13193	  else
13194	    error = FALSE;
13195	  break;
13196
13197	default:
13198	  error = TRUE;
13199	  break;
13200	}
13201      break;
13202
13203    case FFEEXPR_contextLOC_:
13204      /* See also ffeintrin_check_loc_.  */
13205      if ((expr == NULL)
13206	  || (ffeinfo_kind (info) != FFEINFO_kindENTITY)
13207	  || ((ffebld_op (expr) != FFEBLD_opSYMTER)
13208	      && (ffebld_op (expr) != FFEBLD_opSUBSTR)
13209	      && (ffebld_op (expr) != FFEBLD_opARRAYREF)))
13210	error = TRUE;
13211      break;
13212
13213    default:
13214      error = FALSE;
13215      break;
13216    }
13217
13218  if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
13219    {
13220      ffebad_start (FFEBAD_EXPR_WRONG);
13221      ffebad_here (0, ffelex_token_where_line (ft),
13222		   ffelex_token_where_column (ft));
13223      ffebad_finish ();
13224      expr = ffebld_new_any ();
13225      ffebld_set_info (expr, ffeinfo_new_any ());
13226    }
13227
13228  callback = ffeexpr_stack_->callback;
13229  s = ffeexpr_stack_->previous;
13230  malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
13231		  sizeof (*ffeexpr_stack_));
13232  ffeexpr_stack_ = s;
13233  next = (ffelexHandler) (*callback) (ft, expr, t);
13234  ffelex_token_kill (ft);
13235  return (ffelexHandler) next;
13236}
13237
13238/* ffeexpr_finished_ambig_ -- Check validity of ambiguous unit/form spec
13239
13240   ffebld expr;
13241   expr = ffeexpr_finished_ambig_(expr);
13242
13243   Replicates a bit of ffeexpr_finished_'s task when in a context
13244   of UNIT or FORMAT.  */
13245
13246static ffebld
13247ffeexpr_finished_ambig_ (ffelexToken ft, ffebld expr)
13248{
13249  ffeinfo info = ffebld_info (expr);
13250  bool error;
13251
13252  switch (ffeexpr_stack_->context)
13253    {
13254    case FFEEXPR_contextFILENUMAMBIG:	/* Same as FILENUM in _finished_. */
13255      switch ((expr == NULL) ? FFEINFO_basictypeNONE
13256	      : ffeinfo_basictype (info))
13257	{
13258	case FFEINFO_basictypeLOGICAL:
13259	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13260	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13261				  FFEEXPR_contextLET);
13262	  /* Fall through. */
13263	case FFEINFO_basictypeREAL:
13264	case FFEINFO_basictypeCOMPLEX:
13265	  if (ffe_is_pedantic ())
13266	    {
13267	      error = TRUE;
13268	      break;
13269	    }
13270	  /* Fall through. */
13271	case FFEINFO_basictypeINTEGER:
13272	case FFEINFO_basictypeHOLLERITH:
13273	case FFEINFO_basictypeTYPELESS:
13274	  error = FALSE;
13275	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13276	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13277				  FFEEXPR_contextLET);
13278	  break;
13279
13280	default:
13281	  error = TRUE;
13282	  break;
13283	}
13284      if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13285	error = TRUE;
13286      break;
13287
13288    case FFEEXPR_contextFILEUNITAMBIG:	/* Same as FILEUNIT in _finished_. */
13289      if ((expr != NULL) && (ffebld_op (expr) == FFEBLD_opSTAR))
13290	{
13291	  error = FALSE;
13292	  break;
13293	}
13294      switch ((expr == NULL) ? FFEINFO_basictypeNONE
13295	      : ffeinfo_basictype (info))
13296	{
13297	case FFEINFO_basictypeLOGICAL:
13298	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13299	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13300				  FFEEXPR_contextLET);
13301	  /* Fall through. */
13302	case FFEINFO_basictypeREAL:
13303	case FFEINFO_basictypeCOMPLEX:
13304	  if (ffe_is_pedantic ())
13305	    {
13306	      error = TRUE;
13307	      break;
13308	    }
13309	  /* Fall through. */
13310	case FFEINFO_basictypeINTEGER:
13311	case FFEINFO_basictypeHOLLERITH:
13312	case FFEINFO_basictypeTYPELESS:
13313	  error = (ffeinfo_rank (info) != 0);
13314	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13315	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13316				  FFEEXPR_contextLET);
13317	  break;
13318
13319	case FFEINFO_basictypeCHARACTER:
13320	  switch (ffebld_op (expr))
13321	    {			/* As if _lhs had been called instead of
13322				   _rhs. */
13323	    case FFEBLD_opSYMTER:
13324	      error
13325		= (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
13326	      break;
13327
13328	    case FFEBLD_opSUBSTR:
13329	      error = (ffeinfo_where (ffebld_info (expr))
13330		       == FFEINFO_whereCONSTANT_SUBOBJECT);
13331	      break;
13332
13333	    case FFEBLD_opARRAYREF:
13334	      error = FALSE;
13335	      break;
13336
13337	    default:
13338	      error = TRUE;
13339	      break;
13340	    }
13341	  break;
13342
13343	default:
13344	  error = TRUE;
13345	  break;
13346	}
13347      break;
13348
13349    default:
13350      assert ("bad context" == NULL);
13351      error = TRUE;
13352      break;
13353    }
13354
13355  if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
13356    {
13357      ffebad_start (FFEBAD_EXPR_WRONG);
13358      ffebad_here (0, ffelex_token_where_line (ft),
13359		   ffelex_token_where_column (ft));
13360      ffebad_finish ();
13361      expr = ffebld_new_any ();
13362      ffebld_set_info (expr, ffeinfo_new_any ());
13363    }
13364
13365  return expr;
13366}
13367
13368/* ffeexpr_token_lhs_ -- Initial state for lhs expression
13369
13370   Return a pointer to this function to the lexer (ffelex), which will
13371   invoke it for the next token.
13372
13373   Basically a smaller version of _rhs_; keep them both in sync, of course.  */
13374
13375static ffelexHandler
13376ffeexpr_token_lhs_ (ffelexToken t)
13377{
13378
13379  /* When changing the list of valid initial lhs tokens, check whether to
13380     update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
13381     READ (expr) <token> case -- it assumes it knows which tokens <token> can
13382     be to indicate an lhs (or implied DO), which right now is the set
13383     {NAME,OPEN_PAREN}.
13384
13385     This comment also appears in ffeexpr_token_first_lhs_. */
13386
13387  switch (ffelex_token_type (t))
13388    {
13389    case FFELEX_typeNAME:
13390    case FFELEX_typeNAMES:
13391      ffeexpr_tokens_[0] = ffelex_token_use (t);
13392      return (ffelexHandler) ffeexpr_token_name_lhs_;
13393
13394    default:
13395      return (ffelexHandler) ffeexpr_finished_ (t);
13396    }
13397}
13398
13399/* ffeexpr_token_rhs_ -- Initial state for rhs expression
13400
13401   Return a pointer to this function to the lexer (ffelex), which will
13402   invoke it for the next token.
13403
13404   The initial state and the post-binary-operator state are the same and
13405   both handled here, with the expression stack used to distinguish
13406   between them.  Binary operators are invalid here; unary operators,
13407   constants, subexpressions, and name references are valid.  */
13408
13409static ffelexHandler
13410ffeexpr_token_rhs_ (ffelexToken t)
13411{
13412  ffeexprExpr_ e;
13413
13414  switch (ffelex_token_type (t))
13415    {
13416    case FFELEX_typeQUOTE:
13417      if (ffe_is_vxt ())
13418	{
13419	  ffeexpr_tokens_[0] = ffelex_token_use (t);
13420	  return (ffelexHandler) ffeexpr_token_quote_;
13421	}
13422      ffeexpr_tokens_[0] = ffelex_token_use (t);
13423      ffelex_set_expecting_hollerith (-1, '\"',
13424				      ffelex_token_where_line (t),
13425				      ffelex_token_where_column (t));
13426      /* Don't have to unset this one. */
13427      return (ffelexHandler) ffeexpr_token_apostrophe_;
13428
13429    case FFELEX_typeAPOSTROPHE:
13430      ffeexpr_tokens_[0] = ffelex_token_use (t);
13431      ffelex_set_expecting_hollerith (-1, '\'',
13432				      ffelex_token_where_line (t),
13433				      ffelex_token_where_column (t));
13434      /* Don't have to unset this one. */
13435      return (ffelexHandler) ffeexpr_token_apostrophe_;
13436
13437    case FFELEX_typePERCENT:
13438      ffeexpr_tokens_[0] = ffelex_token_use (t);
13439      return (ffelexHandler) ffeexpr_token_percent_;
13440
13441    case FFELEX_typeOPEN_PAREN:
13442      ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
13443      return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
13444					  FFEEXPR_contextPAREN_,
13445					  ffeexpr_cb_close_paren_c_);
13446
13447    case FFELEX_typePLUS:
13448      e = ffeexpr_expr_new_ ();
13449      e->type = FFEEXPR_exprtypeUNARY_;
13450      e->token = ffelex_token_use (t);
13451      e->u.operator.op = FFEEXPR_operatorADD_;
13452      e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
13453      e->u.operator.as = FFEEXPR_operatorassociativityADD_;
13454      ffeexpr_exprstack_push_unary_ (e);
13455      return (ffelexHandler) ffeexpr_token_rhs_;
13456
13457    case FFELEX_typeMINUS:
13458      e = ffeexpr_expr_new_ ();
13459      e->type = FFEEXPR_exprtypeUNARY_;
13460      e->token = ffelex_token_use (t);
13461      e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
13462      e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
13463      e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
13464      ffeexpr_exprstack_push_unary_ (e);
13465      return (ffelexHandler) ffeexpr_token_rhs_;
13466
13467    case FFELEX_typePERIOD:
13468      ffeexpr_tokens_[0] = ffelex_token_use (t);
13469      return (ffelexHandler) ffeexpr_token_period_;
13470
13471    case FFELEX_typeNUMBER:
13472      ffeexpr_tokens_[0] = ffelex_token_use (t);
13473      ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
13474      if (ffeexpr_hollerith_count_ > 0)
13475	ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
13476					'\0',
13477					ffelex_token_where_line (t),
13478					ffelex_token_where_column (t));
13479      return (ffelexHandler) ffeexpr_token_number_;
13480
13481    case FFELEX_typeNAME:
13482    case FFELEX_typeNAMES:
13483      ffeexpr_tokens_[0] = ffelex_token_use (t);
13484      switch (ffeexpr_stack_->context)
13485	{
13486	case FFEEXPR_contextACTUALARG_:
13487	case FFEEXPR_contextINDEXORACTUALARG_:
13488	case FFEEXPR_contextSFUNCDEFACTUALARG_:
13489	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
13490	  return (ffelexHandler) ffeexpr_token_name_arg_;
13491
13492	default:
13493	  return (ffelexHandler) ffeexpr_token_name_rhs_;
13494	}
13495
13496    case FFELEX_typeASTERISK:
13497    case FFELEX_typeSLASH:
13498    case FFELEX_typePOWER:
13499    case FFELEX_typeCONCAT:
13500    case FFELEX_typeREL_EQ:
13501    case FFELEX_typeREL_NE:
13502    case FFELEX_typeREL_LE:
13503    case FFELEX_typeREL_GE:
13504      if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
13505	{
13506	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13507	  ffebad_finish ();
13508	}
13509      return (ffelexHandler) ffeexpr_token_rhs_;
13510
13511#if 0
13512    case FFELEX_typeEQUALS:
13513    case FFELEX_typePOINTS:
13514    case FFELEX_typeCLOSE_ANGLE:
13515    case FFELEX_typeCLOSE_PAREN:
13516    case FFELEX_typeCOMMA:
13517    case FFELEX_typeCOLON:
13518    case FFELEX_typeEOS:
13519    case FFELEX_typeSEMICOLON:
13520#endif
13521    default:
13522      return (ffelexHandler) ffeexpr_finished_ (t);
13523    }
13524}
13525
13526/* ffeexpr_token_period_ -- Rhs PERIOD
13527
13528   Return a pointer to this function to the lexer (ffelex), which will
13529   invoke it for the next token.
13530
13531   Handle a period detected at rhs (expecting unary op or operand) state.
13532   Must begin a floating-point value (as in .12) or a dot-dot name, of
13533   which only .NOT., .TRUE., and .FALSE. are truly valid.  Other sort-of-
13534   valid names represent binary operators, which are invalid here because
13535   there isn't an operand at the top of the stack.  */
13536
13537static ffelexHandler
13538ffeexpr_token_period_ (ffelexToken t)
13539{
13540  switch (ffelex_token_type (t))
13541    {
13542    case FFELEX_typeNAME:
13543    case FFELEX_typeNAMES:
13544      ffeexpr_current_dotdot_ = ffestr_other (t);
13545      switch (ffeexpr_current_dotdot_)
13546	{
13547	case FFESTR_otherNone:
13548	  if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
13549	    {
13550	      ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13551			   ffelex_token_where_column (ffeexpr_tokens_[0]));
13552	      ffebad_finish ();
13553	    }
13554	  ffelex_token_kill (ffeexpr_tokens_[0]);
13555	  return (ffelexHandler) ffeexpr_token_rhs_ (t);
13556
13557	case FFESTR_otherTRUE:
13558	case FFESTR_otherFALSE:
13559	case FFESTR_otherNOT:
13560	  ffeexpr_tokens_[1] = ffelex_token_use (t);
13561	  return (ffelexHandler) ffeexpr_token_end_period_;
13562
13563	default:
13564	  if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
13565	    {
13566	      ffebad_here (0, ffelex_token_where_line (t),
13567			   ffelex_token_where_column (t));
13568	      ffebad_finish ();
13569	    }
13570	  ffelex_token_kill (ffeexpr_tokens_[0]);
13571	  return (ffelexHandler) ffeexpr_token_swallow_period_;
13572	}
13573      break;			/* Nothing really reaches here. */
13574
13575    case FFELEX_typeNUMBER:
13576      ffeexpr_tokens_[1] = ffelex_token_use (t);
13577      return (ffelexHandler) ffeexpr_token_real_;
13578
13579    default:
13580      if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
13581	{
13582	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13583		       ffelex_token_where_column (ffeexpr_tokens_[0]));
13584	  ffebad_finish ();
13585	}
13586      ffelex_token_kill (ffeexpr_tokens_[0]);
13587      return (ffelexHandler) ffeexpr_token_rhs_ (t);
13588    }
13589}
13590
13591/* ffeexpr_token_end_period_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
13592
13593   Return a pointer to this function to the lexer (ffelex), which will
13594   invoke it for the next token.
13595
13596   Expecting a period to close a .NOT, .TRUE, or .FALSE at rhs (unary op
13597   or operator) state.	If period isn't found, issue a diagnostic but
13598   pretend we saw one.	ffeexpr_current_dotdot_ must already contained the
13599   dotdot representation of the name in between the two PERIOD tokens.	*/
13600
13601static ffelexHandler
13602ffeexpr_token_end_period_ (ffelexToken t)
13603{
13604  ffeexprExpr_ e;
13605
13606  if (ffelex_token_type (t) != FFELEX_typePERIOD)
13607    {
13608      if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
13609	{
13610	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13611		       ffelex_token_where_column (ffeexpr_tokens_[0]));
13612	  ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13613	  ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
13614	  ffebad_finish ();
13615	}
13616    }
13617
13618  ffelex_token_kill (ffeexpr_tokens_[1]);	/* Kill "NOT"/"TRUE"/"FALSE"
13619						   token. */
13620
13621  e = ffeexpr_expr_new_ ();
13622  e->token = ffeexpr_tokens_[0];
13623
13624  switch (ffeexpr_current_dotdot_)
13625    {
13626    case FFESTR_otherNOT:
13627      e->type = FFEEXPR_exprtypeUNARY_;
13628      e->u.operator.op = FFEEXPR_operatorNOT_;
13629      e->u.operator.prec = FFEEXPR_operatorprecedenceNOT_;
13630      e->u.operator.as = FFEEXPR_operatorassociativityNOT_;
13631      ffeexpr_exprstack_push_unary_ (e);
13632      if (ffelex_token_type (t) != FFELEX_typePERIOD)
13633	return (ffelexHandler) ffeexpr_token_rhs_ (t);
13634      return (ffelexHandler) ffeexpr_token_rhs_;
13635
13636    case FFESTR_otherTRUE:
13637      e->type = FFEEXPR_exprtypeOPERAND_;
13638      e->u.operand
13639	= ffebld_new_conter (ffebld_constant_new_logicaldefault (TRUE));
13640      ffebld_set_info (e->u.operand,
13641      ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
13642		   0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13643      ffeexpr_exprstack_push_operand_ (e);
13644      if (ffelex_token_type (t) != FFELEX_typePERIOD)
13645	return (ffelexHandler) ffeexpr_token_binary_ (t);
13646      return (ffelexHandler) ffeexpr_token_binary_;
13647
13648    case FFESTR_otherFALSE:
13649      e->type = FFEEXPR_exprtypeOPERAND_;
13650      e->u.operand
13651	= ffebld_new_conter (ffebld_constant_new_logicaldefault (FALSE));
13652      ffebld_set_info (e->u.operand,
13653      ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
13654		   0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13655      ffeexpr_exprstack_push_operand_ (e);
13656      if (ffelex_token_type (t) != FFELEX_typePERIOD)
13657	return (ffelexHandler) ffeexpr_token_binary_ (t);
13658      return (ffelexHandler) ffeexpr_token_binary_;
13659
13660    default:
13661      assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL);
13662      exit (0);
13663      return NULL;
13664    }
13665}
13666
13667/* ffeexpr_token_swallow_period_ -- Rhs PERIOD NAME(not NOT, TRUE, or FALSE)
13668
13669   Return a pointer to this function to the lexer (ffelex), which will
13670   invoke it for the next token.
13671
13672   A diagnostic has already been issued; just swallow a period if there is
13673   one, then continue with ffeexpr_token_rhs_.	*/
13674
13675static ffelexHandler
13676ffeexpr_token_swallow_period_ (ffelexToken t)
13677{
13678  if (ffelex_token_type (t) != FFELEX_typePERIOD)
13679    return (ffelexHandler) ffeexpr_token_rhs_ (t);
13680
13681  return (ffelexHandler) ffeexpr_token_rhs_;
13682}
13683
13684/* ffeexpr_token_real_ -- Rhs PERIOD NUMBER
13685
13686   Return a pointer to this function to the lexer (ffelex), which will
13687   invoke it for the next token.
13688
13689   After a period and a string of digits, check next token for possible
13690   exponent designation (D, E, or Q as first/only character) and continue
13691   real-number handling accordingly.  Else form basic real constant, push
13692   onto expression stack, and enter binary state using current token (which,
13693   if it is a name not beginning with D, E, or Q, will certainly result
13694   in an error, but that's not for this routine to deal with).	*/
13695
13696static ffelexHandler
13697ffeexpr_token_real_ (ffelexToken t)
13698{
13699  char d;
13700  const char *p;
13701
13702  if (((ffelex_token_type (t) != FFELEX_typeNAME)
13703       && (ffelex_token_type (t) != FFELEX_typeNAMES))
13704      || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13705				     'D', 'd')
13706	     || ffesrc_char_match_init (d, 'E', 'e')
13707	     || ffesrc_char_match_init (d, 'Q', 'q')))
13708	   && ffeexpr_isdigits_ (++p)))
13709    {
13710#if 0
13711      /* This code has been removed because it seems inconsistent to
13712	 produce a diagnostic in this case, but not all of the other
13713	 ones that look for an exponent and cannot recognize one.  */
13714      if (((ffelex_token_type (t) == FFELEX_typeNAME)
13715	   || (ffelex_token_type (t) == FFELEX_typeNAMES))
13716	  && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
13717	{
13718	  char bad[2];
13719
13720	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13721	  ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
13722		       ffelex_token_where_column (ffeexpr_tokens_[0]));
13723	  bad[0] = *(p - 1);
13724	  bad[1] = '\0';
13725	  ffebad_string (bad);
13726	  ffebad_finish ();
13727	}
13728#endif
13729      ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13730				 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13731				 NULL, NULL, NULL);
13732
13733      ffelex_token_kill (ffeexpr_tokens_[0]);
13734      ffelex_token_kill (ffeexpr_tokens_[1]);
13735      return (ffelexHandler) ffeexpr_token_binary_ (t);
13736    }
13737
13738  /* Just exponent character by itself?	 In which case, PLUS or MINUS must
13739     surely be next, followed by a NUMBER token. */
13740
13741  if (*p == '\0')
13742    {
13743      ffeexpr_tokens_[2] = ffelex_token_use (t);
13744      return (ffelexHandler) ffeexpr_token_real_exponent_;
13745    }
13746
13747  ffeexpr_make_float_const_ (d, NULL, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13748			     t, NULL, NULL);
13749
13750  ffelex_token_kill (ffeexpr_tokens_[0]);
13751  ffelex_token_kill (ffeexpr_tokens_[1]);
13752  return (ffelexHandler) ffeexpr_token_binary_;
13753}
13754
13755/* ffeexpr_token_real_exponent_ -- Rhs PERIOD NUMBER NAME(D, E, or Q)
13756
13757   Return a pointer to this function to the lexer (ffelex), which will
13758   invoke it for the next token.
13759
13760   Ensures this token is PLUS or MINUS, preserves it, goes to final state
13761   for real number (exponent digits).  Else issues diagnostic, assumes a
13762   zero exponent field for number, passes token on to binary state as if
13763   previous token had been "E0" instead of "E", for example.  */
13764
13765static ffelexHandler
13766ffeexpr_token_real_exponent_ (ffelexToken t)
13767{
13768  if ((ffelex_token_type (t) != FFELEX_typePLUS)
13769      && (ffelex_token_type (t) != FFELEX_typeMINUS))
13770    {
13771      if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13772	{
13773	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
13774		       ffelex_token_where_column (ffeexpr_tokens_[2]));
13775	  ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13776	  ffebad_finish ();
13777	}
13778
13779      ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13780				 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13781				 NULL, NULL, NULL);
13782
13783      ffelex_token_kill (ffeexpr_tokens_[0]);
13784      ffelex_token_kill (ffeexpr_tokens_[1]);
13785      ffelex_token_kill (ffeexpr_tokens_[2]);
13786      return (ffelexHandler) ffeexpr_token_binary_ (t);
13787    }
13788
13789  ffeexpr_tokens_[3] = ffelex_token_use (t);
13790  return (ffelexHandler) ffeexpr_token_real_exp_sign_;
13791}
13792
13793/* ffeexpr_token_real_exp_sign_ -- Rhs PERIOD NUMBER NAME(D,E,Q) PLUS/MINUS
13794
13795   Return a pointer to this function to the lexer (ffelex), which will
13796   invoke it for the next token.
13797
13798   Make sure token is a NUMBER, make a real constant out of all we have and
13799   push it onto the expression stack.  Else issue diagnostic and pretend
13800   exponent field was a zero.  */
13801
13802static ffelexHandler
13803ffeexpr_token_real_exp_sign_ (ffelexToken t)
13804{
13805  if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13806    {
13807      if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13808	{
13809	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
13810		       ffelex_token_where_column (ffeexpr_tokens_[2]));
13811	  ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13812	  ffebad_finish ();
13813	}
13814
13815      ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13816				 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13817				 NULL, NULL, NULL);
13818
13819      ffelex_token_kill (ffeexpr_tokens_[0]);
13820      ffelex_token_kill (ffeexpr_tokens_[1]);
13821      ffelex_token_kill (ffeexpr_tokens_[2]);
13822      ffelex_token_kill (ffeexpr_tokens_[3]);
13823      return (ffelexHandler) ffeexpr_token_binary_ (t);
13824    }
13825
13826  ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0], NULL,
13827		 ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2],
13828			     ffeexpr_tokens_[3], t);
13829
13830  ffelex_token_kill (ffeexpr_tokens_[0]);
13831  ffelex_token_kill (ffeexpr_tokens_[1]);
13832  ffelex_token_kill (ffeexpr_tokens_[2]);
13833  ffelex_token_kill (ffeexpr_tokens_[3]);
13834  return (ffelexHandler) ffeexpr_token_binary_;
13835}
13836
13837/* ffeexpr_token_number_ -- Rhs NUMBER
13838
13839   Return a pointer to this function to the lexer (ffelex), which will
13840   invoke it for the next token.
13841
13842   If the token is a period, we may have a floating-point number, or an
13843   integer followed by a dotdot binary operator.  If the token is a name
13844   beginning with D, E, or Q, we definitely have a floating-point number.
13845   If the token is a hollerith constant, that's what we've got, so push
13846   it onto the expression stack and continue with the binary state.
13847
13848   Otherwise, we have an integer followed by something the binary state
13849   should be able to swallow.  */
13850
13851static ffelexHandler
13852ffeexpr_token_number_ (ffelexToken t)
13853{
13854  ffeexprExpr_ e;
13855  ffeinfo ni;
13856  char d;
13857  const char *p;
13858
13859  if (ffeexpr_hollerith_count_ > 0)
13860    ffelex_set_expecting_hollerith (0, '\0',
13861				    ffewhere_line_unknown (),
13862				    ffewhere_column_unknown ());
13863
13864  /* See if we've got a floating-point number here. */
13865
13866  switch (ffelex_token_type (t))
13867    {
13868    case FFELEX_typeNAME:
13869    case FFELEX_typeNAMES:
13870      if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13871				   'D', 'd')
13872	   || ffesrc_char_match_init (d, 'E', 'e')
13873	   || ffesrc_char_match_init (d, 'Q', 'q'))
13874	  && ffeexpr_isdigits_ (++p))
13875	{
13876
13877	  /* Just exponent character by itself?	 In which case, PLUS or MINUS
13878	     must surely be next, followed by a NUMBER token. */
13879
13880	  if (*p == '\0')
13881	    {
13882	      ffeexpr_tokens_[1] = ffelex_token_use (t);
13883	      return (ffelexHandler) ffeexpr_token_number_exponent_;
13884	    }
13885	  ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], NULL, NULL, t,
13886				     NULL, NULL);
13887
13888	  ffelex_token_kill (ffeexpr_tokens_[0]);
13889	  return (ffelexHandler) ffeexpr_token_binary_;
13890	}
13891      break;
13892
13893    case FFELEX_typePERIOD:
13894      ffeexpr_tokens_[1] = ffelex_token_use (t);
13895      return (ffelexHandler) ffeexpr_token_number_period_;
13896
13897    case FFELEX_typeHOLLERITH:
13898      e = ffeexpr_expr_new_ ();
13899      e->type = FFEEXPR_exprtypeOPERAND_;
13900      e->token = ffeexpr_tokens_[0];
13901      e->u.operand = ffebld_new_conter (ffebld_constant_new_hollerith (t));
13902      ni = ffeinfo_new (FFEINFO_basictypeHOLLERITH, FFEINFO_kindtypeNONE,
13903			0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
13904			ffelex_token_length (t));
13905      ffebld_set_info (e->u.operand, ni);
13906      ffeexpr_exprstack_push_operand_ (e);
13907      return (ffelexHandler) ffeexpr_token_binary_;
13908
13909    default:
13910      break;
13911    }
13912
13913  /* Nothing specific we were looking for, so make an integer and pass the
13914     current token to the binary state. */
13915
13916  ffeexpr_make_float_const_ ('I', ffeexpr_tokens_[0], NULL, NULL,
13917			     NULL, NULL, NULL);
13918  return (ffelexHandler) ffeexpr_token_binary_ (t);
13919}
13920
13921/* ffeexpr_token_number_exponent_ -- Rhs NUMBER NAME(D, E, or Q)
13922
13923   Return a pointer to this function to the lexer (ffelex), which will
13924   invoke it for the next token.
13925
13926   Ensures this token is PLUS or MINUS, preserves it, goes to final state
13927   for real number (exponent digits).  Else treats number as integer, passes
13928   name to binary, passes current token to subsequent handler.  */
13929
13930static ffelexHandler
13931ffeexpr_token_number_exponent_ (ffelexToken t)
13932{
13933  if ((ffelex_token_type (t) != FFELEX_typePLUS)
13934      && (ffelex_token_type (t) != FFELEX_typeMINUS))
13935    {
13936      ffeexprExpr_ e;
13937      ffelexHandler nexthandler;
13938
13939      e = ffeexpr_expr_new_ ();
13940      e->type = FFEEXPR_exprtypeOPERAND_;
13941      e->token = ffeexpr_tokens_[0];
13942      e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
13943					(ffeexpr_tokens_[0]));
13944      ffebld_set_info (e->u.operand,
13945      ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT,
13946		   0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13947      ffeexpr_exprstack_push_operand_ (e);
13948      nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[1]);
13949      ffelex_token_kill (ffeexpr_tokens_[1]);
13950      return (ffelexHandler) (*nexthandler) (t);
13951    }
13952
13953  ffeexpr_tokens_[2] = ffelex_token_use (t);
13954  return (ffelexHandler) ffeexpr_token_number_exp_sign_;
13955}
13956
13957/* ffeexpr_token_number_exp_sign_ -- Rhs NUMBER NAME(D,E,Q) PLUS/MINUS
13958
13959   Return a pointer to this function to the lexer (ffelex), which will
13960   invoke it for the next token.
13961
13962   Make sure token is a NUMBER, make a real constant out of all we have and
13963   push it onto the expression stack.  Else issue diagnostic and pretend
13964   exponent field was a zero.  */
13965
13966static ffelexHandler
13967ffeexpr_token_number_exp_sign_ (ffelexToken t)
13968{
13969  if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13970    {
13971      if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13972	{
13973	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[1]),
13974		       ffelex_token_where_column (ffeexpr_tokens_[1]));
13975	  ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13976	  ffebad_finish ();
13977	}
13978
13979      ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
13980				 ffeexpr_tokens_[0], NULL, NULL,
13981				 ffeexpr_tokens_[1], ffeexpr_tokens_[2],
13982				 NULL);
13983
13984      ffelex_token_kill (ffeexpr_tokens_[0]);
13985      ffelex_token_kill (ffeexpr_tokens_[1]);
13986      ffelex_token_kill (ffeexpr_tokens_[2]);
13987      return (ffelexHandler) ffeexpr_token_binary_ (t);
13988    }
13989
13990  ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
13991			     ffeexpr_tokens_[0], NULL, NULL,
13992			     ffeexpr_tokens_[1], ffeexpr_tokens_[2], t);
13993
13994  ffelex_token_kill (ffeexpr_tokens_[0]);
13995  ffelex_token_kill (ffeexpr_tokens_[1]);
13996  ffelex_token_kill (ffeexpr_tokens_[2]);
13997  return (ffelexHandler) ffeexpr_token_binary_;
13998}
13999
14000/* ffeexpr_token_number_period_ -- Rhs NUMBER PERIOD
14001
14002   Return a pointer to this function to the lexer (ffelex), which will
14003   invoke it for the next token.
14004
14005   Handle a period detected following a number at rhs state.  Must begin a
14006   floating-point value (as in 1., 1.2, 1.E3, or 1.E+3) or a dot-dot name.  */
14007
14008static ffelexHandler
14009ffeexpr_token_number_period_ (ffelexToken t)
14010{
14011  ffeexprExpr_ e;
14012  ffelexHandler nexthandler;
14013  const char *p;
14014  char d;
14015
14016  switch (ffelex_token_type (t))
14017    {
14018    case FFELEX_typeNAME:
14019    case FFELEX_typeNAMES:
14020      if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
14021				   'D', 'd')
14022	   || ffesrc_char_match_init (d, 'E', 'e')
14023	   || ffesrc_char_match_init (d, 'Q', 'q'))
14024	  && ffeexpr_isdigits_ (++p))
14025	{
14026
14027	  /* Just exponent character by itself?	 In which case, PLUS or MINUS
14028	     must surely be next, followed by a NUMBER token. */
14029
14030	  if (*p == '\0')
14031	    {
14032	      ffeexpr_tokens_[2] = ffelex_token_use (t);
14033	      return (ffelexHandler) ffeexpr_token_number_per_exp_;
14034	    }
14035	  ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0],
14036				     ffeexpr_tokens_[1], NULL, t, NULL,
14037				     NULL);
14038
14039	  ffelex_token_kill (ffeexpr_tokens_[0]);
14040	  ffelex_token_kill (ffeexpr_tokens_[1]);
14041	  return (ffelexHandler) ffeexpr_token_binary_;
14042	}
14043      /* A name not representing an exponent, so assume it will be something
14044	 like EQ, make an integer from the number, pass the period to binary
14045	 state and the current token to the resulting state. */
14046
14047      e = ffeexpr_expr_new_ ();
14048      e->type = FFEEXPR_exprtypeOPERAND_;
14049      e->token = ffeexpr_tokens_[0];
14050      e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
14051					(ffeexpr_tokens_[0]));
14052      ffebld_set_info (e->u.operand,
14053		       ffeinfo_new (FFEINFO_basictypeINTEGER,
14054				    FFEINFO_kindtypeINTEGERDEFAULT, 0,
14055				  FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14056				    FFETARGET_charactersizeNONE));
14057      ffeexpr_exprstack_push_operand_ (e);
14058      nexthandler = (ffelexHandler) ffeexpr_token_binary_
14059	(ffeexpr_tokens_[1]);
14060      ffelex_token_kill (ffeexpr_tokens_[1]);
14061      return (ffelexHandler) (*nexthandler) (t);
14062
14063    case FFELEX_typeNUMBER:
14064      ffeexpr_tokens_[2] = ffelex_token_use (t);
14065      return (ffelexHandler) ffeexpr_token_number_real_;
14066
14067    default:
14068      break;
14069    }
14070
14071  /* Nothing specific we were looking for, so make a real number and pass the
14072     period and then the current token to the binary state. */
14073
14074  ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14075			     ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14076			     NULL, NULL, NULL, NULL);
14077
14078  ffelex_token_kill (ffeexpr_tokens_[0]);
14079  ffelex_token_kill (ffeexpr_tokens_[1]);
14080  return (ffelexHandler) ffeexpr_token_binary_ (t);
14081}
14082
14083/* ffeexpr_token_number_per_exp_ -- Rhs NUMBER PERIOD NAME(D, E, or Q)
14084
14085   Return a pointer to this function to the lexer (ffelex), which will
14086   invoke it for the next token.
14087
14088   Ensures this token is PLUS or MINUS, preserves it, goes to final state
14089   for real number (exponent digits).  Else treats number as real, passes
14090   name to binary, passes current token to subsequent handler.	*/
14091
14092static ffelexHandler
14093ffeexpr_token_number_per_exp_ (ffelexToken t)
14094{
14095  if ((ffelex_token_type (t) != FFELEX_typePLUS)
14096      && (ffelex_token_type (t) != FFELEX_typeMINUS))
14097    {
14098      ffelexHandler nexthandler;
14099
14100      ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14101				 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14102				 NULL, NULL, NULL, NULL);
14103
14104      ffelex_token_kill (ffeexpr_tokens_[0]);
14105      ffelex_token_kill (ffeexpr_tokens_[1]);
14106      nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[2]);
14107      ffelex_token_kill (ffeexpr_tokens_[2]);
14108      return (ffelexHandler) (*nexthandler) (t);
14109    }
14110
14111  ffeexpr_tokens_[3] = ffelex_token_use (t);
14112  return (ffelexHandler) ffeexpr_token_num_per_exp_sign_;
14113}
14114
14115/* ffeexpr_token_number_real_ -- Rhs NUMBER PERIOD NUMBER
14116
14117   Return a pointer to this function to the lexer (ffelex), which will
14118   invoke it for the next token.
14119
14120   After a number, period, and number, check next token for possible
14121   exponent designation (D, E, or Q as first/only character) and continue
14122   real-number handling accordingly.  Else form basic real constant, push
14123   onto expression stack, and enter binary state using current token (which,
14124   if it is a name not beginning with D, E, or Q, will certainly result
14125   in an error, but that's not for this routine to deal with).	*/
14126
14127static ffelexHandler
14128ffeexpr_token_number_real_ (ffelexToken t)
14129{
14130  char d;
14131  const char *p;
14132
14133  if (((ffelex_token_type (t) != FFELEX_typeNAME)
14134       && (ffelex_token_type (t) != FFELEX_typeNAMES))
14135      || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
14136				     'D', 'd')
14137	     || ffesrc_char_match_init (d, 'E', 'e')
14138	     || ffesrc_char_match_init (d, 'Q', 'q')))
14139	   && ffeexpr_isdigits_ (++p)))
14140    {
14141#if 0
14142      /* This code has been removed because it seems inconsistent to
14143	 produce a diagnostic in this case, but not all of the other
14144	 ones that look for an exponent and cannot recognize one.  */
14145      if (((ffelex_token_type (t) == FFELEX_typeNAME)
14146	   || (ffelex_token_type (t) == FFELEX_typeNAMES))
14147	  && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
14148	{
14149	  char bad[2];
14150
14151	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14152	  ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
14153		       ffelex_token_where_column (ffeexpr_tokens_[0]));
14154	  bad[0] = *(p - 1);
14155	  bad[1] = '\0';
14156	  ffebad_string (bad);
14157	  ffebad_finish ();
14158	}
14159#endif
14160      ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14161				 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14162				 ffeexpr_tokens_[2], NULL, NULL, NULL);
14163
14164      ffelex_token_kill (ffeexpr_tokens_[0]);
14165      ffelex_token_kill (ffeexpr_tokens_[1]);
14166      ffelex_token_kill (ffeexpr_tokens_[2]);
14167      return (ffelexHandler) ffeexpr_token_binary_ (t);
14168    }
14169
14170  /* Just exponent character by itself?	 In which case, PLUS or MINUS must
14171     surely be next, followed by a NUMBER token. */
14172
14173  if (*p == '\0')
14174    {
14175      ffeexpr_tokens_[3] = ffelex_token_use (t);
14176      return (ffelexHandler) ffeexpr_token_number_real_exp_;
14177    }
14178
14179  ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14180			     ffeexpr_tokens_[2], t, NULL, NULL);
14181
14182  ffelex_token_kill (ffeexpr_tokens_[0]);
14183  ffelex_token_kill (ffeexpr_tokens_[1]);
14184  ffelex_token_kill (ffeexpr_tokens_[2]);
14185  return (ffelexHandler) ffeexpr_token_binary_;
14186}
14187
14188/* ffeexpr_token_num_per_exp_sign_ -- Rhs NUMBER PERIOD NAME(D,E,Q) PLUS/MINUS
14189
14190   Return a pointer to this function to the lexer (ffelex), which will
14191   invoke it for the next token.
14192
14193   Make sure token is a NUMBER, make a real constant out of all we have and
14194   push it onto the expression stack.  Else issue diagnostic and pretend
14195   exponent field was a zero.  */
14196
14197static ffelexHandler
14198ffeexpr_token_num_per_exp_sign_ (ffelexToken t)
14199{
14200  if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14201    {
14202      if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14203	{
14204	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
14205		       ffelex_token_where_column (ffeexpr_tokens_[2]));
14206	  ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14207	  ffebad_finish ();
14208	}
14209
14210      ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14211				 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14212				 NULL, NULL, NULL, NULL);
14213
14214      ffelex_token_kill (ffeexpr_tokens_[0]);
14215      ffelex_token_kill (ffeexpr_tokens_[1]);
14216      ffelex_token_kill (ffeexpr_tokens_[2]);
14217      ffelex_token_kill (ffeexpr_tokens_[3]);
14218      return (ffelexHandler) ffeexpr_token_binary_ (t);
14219    }
14220
14221  ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0],
14222			     ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL,
14223			     ffeexpr_tokens_[2], ffeexpr_tokens_[3], t);
14224
14225  ffelex_token_kill (ffeexpr_tokens_[0]);
14226  ffelex_token_kill (ffeexpr_tokens_[1]);
14227  ffelex_token_kill (ffeexpr_tokens_[2]);
14228  ffelex_token_kill (ffeexpr_tokens_[3]);
14229  return (ffelexHandler) ffeexpr_token_binary_;
14230}
14231
14232/* ffeexpr_token_number_real_exp_ -- Rhs NUMBER PERIOD NUMBER NAME(D, E, or Q)
14233
14234   Return a pointer to this function to the lexer (ffelex), which will
14235   invoke it for the next token.
14236
14237   Ensures this token is PLUS or MINUS, preserves it, goes to final state
14238   for real number (exponent digits).  Else issues diagnostic, assumes a
14239   zero exponent field for number, passes token on to binary state as if
14240   previous token had been "E0" instead of "E", for example.  */
14241
14242static ffelexHandler
14243ffeexpr_token_number_real_exp_ (ffelexToken t)
14244{
14245  if ((ffelex_token_type (t) != FFELEX_typePLUS)
14246      && (ffelex_token_type (t) != FFELEX_typeMINUS))
14247    {
14248      if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14249	{
14250	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
14251		       ffelex_token_where_column (ffeexpr_tokens_[3]));
14252	  ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14253	  ffebad_finish ();
14254	}
14255
14256      ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14257				 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14258				 ffeexpr_tokens_[2], NULL, NULL, NULL);
14259
14260      ffelex_token_kill (ffeexpr_tokens_[0]);
14261      ffelex_token_kill (ffeexpr_tokens_[1]);
14262      ffelex_token_kill (ffeexpr_tokens_[2]);
14263      ffelex_token_kill (ffeexpr_tokens_[3]);
14264      return (ffelexHandler) ffeexpr_token_binary_ (t);
14265    }
14266
14267  ffeexpr_tokens_[4] = ffelex_token_use (t);
14268  return (ffelexHandler) ffeexpr_token_num_real_exp_sn_;
14269}
14270
14271/* ffeexpr_token_num_real_exp_sn_ -- Rhs NUMBER PERIOD NUMBER NAME(D,E,Q)
14272				  PLUS/MINUS
14273
14274   Return a pointer to this function to the lexer (ffelex), which will
14275   invoke it for the next token.
14276
14277   Make sure token is a NUMBER, make a real constant out of all we have and
14278   push it onto the expression stack.  Else issue diagnostic and pretend
14279   exponent field was a zero.  */
14280
14281static ffelexHandler
14282ffeexpr_token_num_real_exp_sn_ (ffelexToken t)
14283{
14284  if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14285    {
14286      if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14287	{
14288	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
14289		       ffelex_token_where_column (ffeexpr_tokens_[3]));
14290	  ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14291	  ffebad_finish ();
14292	}
14293
14294      ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14295				 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14296				 ffeexpr_tokens_[2], NULL, NULL, NULL);
14297
14298      ffelex_token_kill (ffeexpr_tokens_[0]);
14299      ffelex_token_kill (ffeexpr_tokens_[1]);
14300      ffelex_token_kill (ffeexpr_tokens_[2]);
14301      ffelex_token_kill (ffeexpr_tokens_[3]);
14302      ffelex_token_kill (ffeexpr_tokens_[4]);
14303      return (ffelexHandler) ffeexpr_token_binary_ (t);
14304    }
14305
14306  ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[3])[0],
14307			     ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14308			     ffeexpr_tokens_[2], ffeexpr_tokens_[3],
14309			     ffeexpr_tokens_[4], t);
14310
14311  ffelex_token_kill (ffeexpr_tokens_[0]);
14312  ffelex_token_kill (ffeexpr_tokens_[1]);
14313  ffelex_token_kill (ffeexpr_tokens_[2]);
14314  ffelex_token_kill (ffeexpr_tokens_[3]);
14315  ffelex_token_kill (ffeexpr_tokens_[4]);
14316  return (ffelexHandler) ffeexpr_token_binary_;
14317}
14318
14319/* ffeexpr_token_binary_ -- Handle binary operator possibility
14320
14321   Return a pointer to this function to the lexer (ffelex), which will
14322   invoke it for the next token.
14323
14324   The possibility of a binary operator is handled here, meaning the previous
14325   token was an operand.  */
14326
14327static ffelexHandler
14328ffeexpr_token_binary_ (ffelexToken t)
14329{
14330  ffeexprExpr_ e;
14331
14332  if (!ffeexpr_stack_->is_rhs)
14333    return (ffelexHandler) ffeexpr_finished_ (t);	/* For now. */
14334
14335  switch (ffelex_token_type (t))
14336    {
14337    case FFELEX_typePLUS:
14338      e = ffeexpr_expr_new_ ();
14339      e->type = FFEEXPR_exprtypeBINARY_;
14340      e->token = ffelex_token_use (t);
14341      e->u.operator.op = FFEEXPR_operatorADD_;
14342      e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
14343      e->u.operator.as = FFEEXPR_operatorassociativityADD_;
14344      ffeexpr_exprstack_push_binary_ (e);
14345      return (ffelexHandler) ffeexpr_token_rhs_;
14346
14347    case FFELEX_typeMINUS:
14348      e = ffeexpr_expr_new_ ();
14349      e->type = FFEEXPR_exprtypeBINARY_;
14350      e->token = ffelex_token_use (t);
14351      e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
14352      e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
14353      e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
14354      ffeexpr_exprstack_push_binary_ (e);
14355      return (ffelexHandler) ffeexpr_token_rhs_;
14356
14357    case FFELEX_typeASTERISK:
14358      switch (ffeexpr_stack_->context)
14359	{
14360	case FFEEXPR_contextDATA:
14361	  return (ffelexHandler) ffeexpr_finished_ (t);
14362
14363	default:
14364	  break;
14365	}
14366      e = ffeexpr_expr_new_ ();
14367      e->type = FFEEXPR_exprtypeBINARY_;
14368      e->token = ffelex_token_use (t);
14369      e->u.operator.op = FFEEXPR_operatorMULTIPLY_;
14370      e->u.operator.prec = FFEEXPR_operatorprecedenceMULTIPLY_;
14371      e->u.operator.as = FFEEXPR_operatorassociativityMULTIPLY_;
14372      ffeexpr_exprstack_push_binary_ (e);
14373      return (ffelexHandler) ffeexpr_token_rhs_;
14374
14375    case FFELEX_typeSLASH:
14376      switch (ffeexpr_stack_->context)
14377	{
14378	case FFEEXPR_contextDATA:
14379	  return (ffelexHandler) ffeexpr_finished_ (t);
14380
14381	default:
14382	  break;
14383	}
14384      e = ffeexpr_expr_new_ ();
14385      e->type = FFEEXPR_exprtypeBINARY_;
14386      e->token = ffelex_token_use (t);
14387      e->u.operator.op = FFEEXPR_operatorDIVIDE_;
14388      e->u.operator.prec = FFEEXPR_operatorprecedenceDIVIDE_;
14389      e->u.operator.as = FFEEXPR_operatorassociativityDIVIDE_;
14390      ffeexpr_exprstack_push_binary_ (e);
14391      return (ffelexHandler) ffeexpr_token_rhs_;
14392
14393    case FFELEX_typePOWER:
14394      e = ffeexpr_expr_new_ ();
14395      e->type = FFEEXPR_exprtypeBINARY_;
14396      e->token = ffelex_token_use (t);
14397      e->u.operator.op = FFEEXPR_operatorPOWER_;
14398      e->u.operator.prec = FFEEXPR_operatorprecedencePOWER_;
14399      e->u.operator.as = FFEEXPR_operatorassociativityPOWER_;
14400      ffeexpr_exprstack_push_binary_ (e);
14401      return (ffelexHandler) ffeexpr_token_rhs_;
14402
14403    case FFELEX_typeCONCAT:
14404      e = ffeexpr_expr_new_ ();
14405      e->type = FFEEXPR_exprtypeBINARY_;
14406      e->token = ffelex_token_use (t);
14407      e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
14408      e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
14409      e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
14410      ffeexpr_exprstack_push_binary_ (e);
14411      return (ffelexHandler) ffeexpr_token_rhs_;
14412
14413    case FFELEX_typeOPEN_ANGLE:
14414      switch (ffeexpr_stack_->context)
14415	{
14416	case FFEEXPR_contextFORMAT:
14417	  ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14418	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14419	  ffebad_finish ();
14420	  break;
14421
14422	default:
14423	  break;
14424	}
14425      e = ffeexpr_expr_new_ ();
14426      e->type = FFEEXPR_exprtypeBINARY_;
14427      e->token = ffelex_token_use (t);
14428      e->u.operator.op = FFEEXPR_operatorLT_;
14429      e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
14430      e->u.operator.as = FFEEXPR_operatorassociativityLT_;
14431      ffeexpr_exprstack_push_binary_ (e);
14432      return (ffelexHandler) ffeexpr_token_rhs_;
14433
14434    case FFELEX_typeCLOSE_ANGLE:
14435      switch (ffeexpr_stack_->context)
14436	{
14437	case FFEEXPR_contextFORMAT:
14438	  return ffeexpr_finished_ (t);
14439
14440	default:
14441	  break;
14442	}
14443      e = ffeexpr_expr_new_ ();
14444      e->type = FFEEXPR_exprtypeBINARY_;
14445      e->token = ffelex_token_use (t);
14446      e->u.operator.op = FFEEXPR_operatorGT_;
14447      e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
14448      e->u.operator.as = FFEEXPR_operatorassociativityGT_;
14449      ffeexpr_exprstack_push_binary_ (e);
14450      return (ffelexHandler) ffeexpr_token_rhs_;
14451
14452    case FFELEX_typeREL_EQ:
14453      switch (ffeexpr_stack_->context)
14454	{
14455	case FFEEXPR_contextFORMAT:
14456	  ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14457	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14458	  ffebad_finish ();
14459	  break;
14460
14461	default:
14462	  break;
14463	}
14464      e = ffeexpr_expr_new_ ();
14465      e->type = FFEEXPR_exprtypeBINARY_;
14466      e->token = ffelex_token_use (t);
14467      e->u.operator.op = FFEEXPR_operatorEQ_;
14468      e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
14469      e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
14470      ffeexpr_exprstack_push_binary_ (e);
14471      return (ffelexHandler) ffeexpr_token_rhs_;
14472
14473    case FFELEX_typeREL_NE:
14474      switch (ffeexpr_stack_->context)
14475	{
14476	case FFEEXPR_contextFORMAT:
14477	  ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14478	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14479	  ffebad_finish ();
14480	  break;
14481
14482	default:
14483	  break;
14484	}
14485      e = ffeexpr_expr_new_ ();
14486      e->type = FFEEXPR_exprtypeBINARY_;
14487      e->token = ffelex_token_use (t);
14488      e->u.operator.op = FFEEXPR_operatorNE_;
14489      e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
14490      e->u.operator.as = FFEEXPR_operatorassociativityNE_;
14491      ffeexpr_exprstack_push_binary_ (e);
14492      return (ffelexHandler) ffeexpr_token_rhs_;
14493
14494    case FFELEX_typeREL_LE:
14495      switch (ffeexpr_stack_->context)
14496	{
14497	case FFEEXPR_contextFORMAT:
14498	  ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14499	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14500	  ffebad_finish ();
14501	  break;
14502
14503	default:
14504	  break;
14505	}
14506      e = ffeexpr_expr_new_ ();
14507      e->type = FFEEXPR_exprtypeBINARY_;
14508      e->token = ffelex_token_use (t);
14509      e->u.operator.op = FFEEXPR_operatorLE_;
14510      e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
14511      e->u.operator.as = FFEEXPR_operatorassociativityLE_;
14512      ffeexpr_exprstack_push_binary_ (e);
14513      return (ffelexHandler) ffeexpr_token_rhs_;
14514
14515    case FFELEX_typeREL_GE:
14516      switch (ffeexpr_stack_->context)
14517	{
14518	case FFEEXPR_contextFORMAT:
14519	  ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14520	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14521	  ffebad_finish ();
14522	  break;
14523
14524	default:
14525	  break;
14526	}
14527      e = ffeexpr_expr_new_ ();
14528      e->type = FFEEXPR_exprtypeBINARY_;
14529      e->token = ffelex_token_use (t);
14530      e->u.operator.op = FFEEXPR_operatorGE_;
14531      e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
14532      e->u.operator.as = FFEEXPR_operatorassociativityGE_;
14533      ffeexpr_exprstack_push_binary_ (e);
14534      return (ffelexHandler) ffeexpr_token_rhs_;
14535
14536    case FFELEX_typePERIOD:
14537      ffeexpr_tokens_[0] = ffelex_token_use (t);
14538      return (ffelexHandler) ffeexpr_token_binary_period_;
14539
14540#if 0
14541    case FFELEX_typeOPEN_PAREN:
14542    case FFELEX_typeCLOSE_PAREN:
14543    case FFELEX_typeEQUALS:
14544    case FFELEX_typePOINTS:
14545    case FFELEX_typeCOMMA:
14546    case FFELEX_typeCOLON:
14547    case FFELEX_typeEOS:
14548    case FFELEX_typeSEMICOLON:
14549    case FFELEX_typeNAME:
14550    case FFELEX_typeNAMES:
14551#endif
14552    default:
14553      return (ffelexHandler) ffeexpr_finished_ (t);
14554    }
14555}
14556
14557/* ffeexpr_token_binary_period_ -- Binary PERIOD
14558
14559   Return a pointer to this function to the lexer (ffelex), which will
14560   invoke it for the next token.
14561
14562   Handle a period detected at binary (expecting binary op or end) state.
14563   Must begin a dot-dot name, of which .NOT., .TRUE., and .FALSE. are not
14564   valid.  */
14565
14566static ffelexHandler
14567ffeexpr_token_binary_period_ (ffelexToken t)
14568{
14569  ffeexprExpr_ operand;
14570
14571  switch (ffelex_token_type (t))
14572    {
14573    case FFELEX_typeNAME:
14574    case FFELEX_typeNAMES:
14575      ffeexpr_current_dotdot_ = ffestr_other (t);
14576      switch (ffeexpr_current_dotdot_)
14577	{
14578	case FFESTR_otherTRUE:
14579	case FFESTR_otherFALSE:
14580	case FFESTR_otherNOT:
14581	  if (ffest_ffebad_start (FFEBAD_MISSING_BINARY_OPERATOR))
14582	    {
14583	      operand = ffeexpr_stack_->exprstack;
14584	      assert (operand != NULL);
14585	      assert (operand->type == FFEEXPR_exprtypeOPERAND_);
14586	      ffebad_here (0, ffelex_token_where_line (operand->token), ffelex_token_where_column (operand->token));
14587	      ffebad_here (1, ffelex_token_where_line (t),
14588			   ffelex_token_where_column (t));
14589	      ffebad_finish ();
14590	    }
14591	  ffelex_token_kill (ffeexpr_tokens_[0]);
14592	  return (ffelexHandler) ffeexpr_token_binary_sw_per_;
14593
14594	default:
14595	  ffeexpr_tokens_[1] = ffelex_token_use (t);
14596	  return (ffelexHandler) ffeexpr_token_binary_end_per_;
14597	}
14598      break;			/* Nothing really reaches here. */
14599
14600    default:
14601      if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
14602	{
14603	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14604		       ffelex_token_where_column (ffeexpr_tokens_[0]));
14605	  ffebad_finish ();
14606	}
14607      ffelex_token_kill (ffeexpr_tokens_[0]);
14608      return (ffelexHandler) ffeexpr_token_binary_ (t);
14609    }
14610}
14611
14612/* ffeexpr_token_binary_end_per_ -- Binary PERIOD NAME(not NOT, TRUE, or FALSE)
14613
14614   Return a pointer to this function to the lexer (ffelex), which will
14615   invoke it for the next token.
14616
14617   Expecting a period to close a dot-dot at binary (binary op
14618   or operator) state.	If period isn't found, issue a diagnostic but
14619   pretend we saw one.	ffeexpr_current_dotdot_ must already contained the
14620   dotdot representation of the name in between the two PERIOD tokens.	*/
14621
14622static ffelexHandler
14623ffeexpr_token_binary_end_per_ (ffelexToken t)
14624{
14625  ffeexprExpr_ e;
14626
14627  e = ffeexpr_expr_new_ ();
14628  e->type = FFEEXPR_exprtypeBINARY_;
14629  e->token = ffeexpr_tokens_[0];
14630
14631  switch (ffeexpr_current_dotdot_)
14632    {
14633    case FFESTR_otherAND:
14634      e->u.operator.op = FFEEXPR_operatorAND_;
14635      e->u.operator.prec = FFEEXPR_operatorprecedenceAND_;
14636      e->u.operator.as = FFEEXPR_operatorassociativityAND_;
14637      break;
14638
14639    case FFESTR_otherOR:
14640      e->u.operator.op = FFEEXPR_operatorOR_;
14641      e->u.operator.prec = FFEEXPR_operatorprecedenceOR_;
14642      e->u.operator.as = FFEEXPR_operatorassociativityOR_;
14643      break;
14644
14645    case FFESTR_otherXOR:
14646      e->u.operator.op = FFEEXPR_operatorXOR_;
14647      e->u.operator.prec = FFEEXPR_operatorprecedenceXOR_;
14648      e->u.operator.as = FFEEXPR_operatorassociativityXOR_;
14649      break;
14650
14651    case FFESTR_otherEQV:
14652      e->u.operator.op = FFEEXPR_operatorEQV_;
14653      e->u.operator.prec = FFEEXPR_operatorprecedenceEQV_;
14654      e->u.operator.as = FFEEXPR_operatorassociativityEQV_;
14655      break;
14656
14657    case FFESTR_otherNEQV:
14658      e->u.operator.op = FFEEXPR_operatorNEQV_;
14659      e->u.operator.prec = FFEEXPR_operatorprecedenceNEQV_;
14660      e->u.operator.as = FFEEXPR_operatorassociativityNEQV_;
14661      break;
14662
14663    case FFESTR_otherLT:
14664      e->u.operator.op = FFEEXPR_operatorLT_;
14665      e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
14666      e->u.operator.as = FFEEXPR_operatorassociativityLT_;
14667      break;
14668
14669    case FFESTR_otherLE:
14670      e->u.operator.op = FFEEXPR_operatorLE_;
14671      e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
14672      e->u.operator.as = FFEEXPR_operatorassociativityLE_;
14673      break;
14674
14675    case FFESTR_otherEQ:
14676      e->u.operator.op = FFEEXPR_operatorEQ_;
14677      e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
14678      e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
14679      break;
14680
14681    case FFESTR_otherNE:
14682      e->u.operator.op = FFEEXPR_operatorNE_;
14683      e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
14684      e->u.operator.as = FFEEXPR_operatorassociativityNE_;
14685      break;
14686
14687    case FFESTR_otherGT:
14688      e->u.operator.op = FFEEXPR_operatorGT_;
14689      e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
14690      e->u.operator.as = FFEEXPR_operatorassociativityGT_;
14691      break;
14692
14693    case FFESTR_otherGE:
14694      e->u.operator.op = FFEEXPR_operatorGE_;
14695      e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
14696      e->u.operator.as = FFEEXPR_operatorassociativityGE_;
14697      break;
14698
14699    default:
14700      if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT))
14701	{
14702	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14703		       ffelex_token_where_column (ffeexpr_tokens_[0]));
14704	  ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
14705	  ffebad_finish ();
14706	}
14707      e->u.operator.op = FFEEXPR_operatorEQ_;
14708      e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
14709      e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
14710      break;
14711    }
14712
14713  ffeexpr_exprstack_push_binary_ (e);
14714
14715  if (ffelex_token_type (t) != FFELEX_typePERIOD)
14716    {
14717      if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
14718	{
14719	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14720		       ffelex_token_where_column (ffeexpr_tokens_[0]));
14721	  ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14722	  ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
14723	  ffebad_finish ();
14724	}
14725      ffelex_token_kill (ffeexpr_tokens_[1]);	/* Kill dot-dot token. */
14726      return (ffelexHandler) ffeexpr_token_rhs_ (t);
14727    }
14728
14729  ffelex_token_kill (ffeexpr_tokens_[1]);	/* Kill dot-dot token. */
14730  return (ffelexHandler) ffeexpr_token_rhs_;
14731}
14732
14733/* ffeexpr_token_binary_sw_per_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
14734
14735   Return a pointer to this function to the lexer (ffelex), which will
14736   invoke it for the next token.
14737
14738   A diagnostic has already been issued; just swallow a period if there is
14739   one, then continue with ffeexpr_token_binary_.  */
14740
14741static ffelexHandler
14742ffeexpr_token_binary_sw_per_ (ffelexToken t)
14743{
14744  if (ffelex_token_type (t) != FFELEX_typePERIOD)
14745    return (ffelexHandler) ffeexpr_token_binary_ (t);
14746
14747  return (ffelexHandler) ffeexpr_token_binary_;
14748}
14749
14750/* ffeexpr_token_quote_ -- Rhs QUOTE
14751
14752   Return a pointer to this function to the lexer (ffelex), which will
14753   invoke it for the next token.
14754
14755   Expecting a NUMBER that we'll treat as an octal integer.  */
14756
14757static ffelexHandler
14758ffeexpr_token_quote_ (ffelexToken t)
14759{
14760  ffeexprExpr_ e;
14761  ffebld anyexpr;
14762
14763  if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14764    {
14765      if (ffest_ffebad_start (FFEBAD_QUOTE_MISSES_DIGITS))
14766	{
14767	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14768		       ffelex_token_where_column (ffeexpr_tokens_[0]));
14769	  ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14770	  ffebad_finish ();
14771	}
14772      ffelex_token_kill (ffeexpr_tokens_[0]);
14773      return (ffelexHandler) ffeexpr_token_rhs_ (t);
14774    }
14775
14776  /* This is kind of a kludge to prevent any whining about magical numbers
14777     that start out as these octal integers, so "20000000000 (on a 32-bit
14778     2's-complement machine) by itself won't produce an error. */
14779
14780  anyexpr = ffebld_new_any ();
14781  ffebld_set_info (anyexpr, ffeinfo_new_any ());
14782
14783  e = ffeexpr_expr_new_ ();
14784  e->type = FFEEXPR_exprtypeOPERAND_;
14785  e->token = ffeexpr_tokens_[0];
14786  e->u.operand = ffebld_new_conter_with_orig
14787    (ffebld_constant_new_integeroctal (t), anyexpr);
14788  ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER,
14789		      FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY,
14790		       FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14791  ffeexpr_exprstack_push_operand_ (e);
14792  return (ffelexHandler) ffeexpr_token_binary_;
14793}
14794
14795/* ffeexpr_token_apostrophe_ -- Rhs APOSTROPHE
14796
14797   Return a pointer to this function to the lexer (ffelex), which will
14798   invoke it for the next token.
14799
14800   Handle an open-apostrophe, which begins either a character ('char-const'),
14801   typeless octal ('octal-const'O), or typeless hexadecimal ('hex-const'Z or
14802   'hex-const'X) constant.  */
14803
14804static ffelexHandler
14805ffeexpr_token_apostrophe_ (ffelexToken t)
14806{
14807  assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
14808  if (ffe_is_pedantic_not_90 () && (ffelex_token_length (t) == 0))
14809    {
14810      ffebad_start (FFEBAD_NULL_CHAR_CONST);
14811      ffebad_here (0, ffelex_token_where_line (t),
14812		   ffelex_token_where_column (t));
14813      ffebad_finish ();
14814    }
14815  ffeexpr_tokens_[1] = ffelex_token_use (t);
14816  return (ffelexHandler) ffeexpr_token_apos_char_;
14817}
14818
14819/* ffeexpr_token_apos_char_ -- Rhs APOSTROPHE CHARACTER
14820
14821   Return a pointer to this function to the lexer (ffelex), which will
14822   invoke it for the next token.
14823
14824   Close-apostrophe is implicit; if this token is NAME, it is a possible
14825   typeless-constant radix specifier.  */
14826
14827static ffelexHandler
14828ffeexpr_token_apos_char_ (ffelexToken t)
14829{
14830  ffeexprExpr_ e;
14831  ffeinfo ni;
14832  char c;
14833  ffetargetCharacterSize size;
14834
14835  if ((ffelex_token_type (t) == FFELEX_typeNAME)
14836      || (ffelex_token_type (t) == FFELEX_typeNAMES))
14837    {
14838      if ((ffelex_token_length (t) == 1)
14839	  && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]), 'B',
14840				      'b')
14841	      || ffesrc_char_match_init (c, 'O', 'o')
14842	      || ffesrc_char_match_init (c, 'X', 'x')
14843	      || ffesrc_char_match_init (c, 'Z', 'z')))
14844	{
14845	  e = ffeexpr_expr_new_ ();
14846	  e->type = FFEEXPR_exprtypeOPERAND_;
14847	  e->token = ffeexpr_tokens_[0];
14848	  switch (c)
14849	    {
14850	    case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
14851	      e->u.operand = ffebld_new_conter
14852		(ffebld_constant_new_typeless_bv (ffeexpr_tokens_[1]));
14853	      size = ffetarget_size_typeless_binary (ffeexpr_tokens_[1]);
14854	      break;
14855
14856	    case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
14857	      e->u.operand = ffebld_new_conter
14858		(ffebld_constant_new_typeless_ov (ffeexpr_tokens_[1]));
14859	      size = ffetarget_size_typeless_octal (ffeexpr_tokens_[1]);
14860	      break;
14861
14862	    case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
14863	      e->u.operand = ffebld_new_conter
14864		(ffebld_constant_new_typeless_hxv (ffeexpr_tokens_[1]));
14865	      size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
14866	      break;
14867
14868	    case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
14869	      e->u.operand = ffebld_new_conter
14870		(ffebld_constant_new_typeless_hzv (ffeexpr_tokens_[1]));
14871	      size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
14872	      break;
14873
14874	    default:
14875	    no_match:		/* :::::::::::::::::::: */
14876	      assert ("not BOXZ!" == NULL);
14877	      size = 0;
14878	      break;
14879	    }
14880	  ffebld_set_info (e->u.operand,
14881	       ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
14882		       0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
14883	  ffeexpr_exprstack_push_operand_ (e);
14884	  ffelex_token_kill (ffeexpr_tokens_[1]);
14885	  return (ffelexHandler) ffeexpr_token_binary_;
14886	}
14887    }
14888  e = ffeexpr_expr_new_ ();
14889  e->type = FFEEXPR_exprtypeOPERAND_;
14890  e->token = ffeexpr_tokens_[0];
14891  e->u.operand = ffebld_new_conter (ffebld_constant_new_characterdefault
14892				    (ffeexpr_tokens_[1]));
14893  ni = ffeinfo_new (FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTERDEFAULT,
14894		    0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14895		    ffelex_token_length (ffeexpr_tokens_[1]));
14896  ffebld_set_info (e->u.operand, ni);
14897  ffelex_token_kill (ffeexpr_tokens_[1]);
14898  ffeexpr_exprstack_push_operand_ (e);
14899  if ((ffelex_token_type (t) == FFELEX_typeNAME)
14900      || (ffelex_token_type (t) == FFELEX_typeNAMES))
14901    {
14902      if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14903	{
14904	  ffebad_string (ffelex_token_text (t));
14905	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14906	  ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
14907		       ffelex_token_where_column (ffeexpr_tokens_[0]));
14908	  ffebad_finish ();
14909	}
14910      e = ffeexpr_expr_new_ ();
14911      e->type = FFEEXPR_exprtypeBINARY_;
14912      e->token = ffelex_token_use (t);
14913      e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
14914      e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
14915      e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
14916      ffeexpr_exprstack_push_binary_ (e);
14917      return (ffelexHandler) ffeexpr_token_rhs_ (t);
14918    }
14919  ffeexpr_is_substr_ok_ = !ffe_is_pedantic_not_90 ();	/* Allow "'hello'(3:5)". */
14920  return (ffelexHandler) ffeexpr_token_substrp_ (t);
14921}
14922
14923/* ffeexpr_token_name_lhs_ -- Lhs NAME
14924
14925   Return a pointer to this function to the lexer (ffelex), which will
14926   invoke it for the next token.
14927
14928   Handle a name followed by open-paren, period (RECORD.MEMBER), percent
14929   (RECORD%MEMBER), or nothing at all.	*/
14930
14931static ffelexHandler
14932ffeexpr_token_name_lhs_ (ffelexToken t)
14933{
14934  ffeexprExpr_ e;
14935  ffeexprParenType_ paren_type;
14936  ffesymbol s;
14937  ffebld expr;
14938  ffeinfo info;
14939
14940  switch (ffelex_token_type (t))
14941    {
14942    case FFELEX_typeOPEN_PAREN:
14943      switch (ffeexpr_stack_->context)
14944	{
14945	case FFEEXPR_contextASSIGN:
14946	case FFEEXPR_contextAGOTO:
14947	case FFEEXPR_contextFILEUNIT_DF:
14948	  goto just_name;	/* :::::::::::::::::::: */
14949
14950	default:
14951	  break;
14952	}
14953      e = ffeexpr_expr_new_ ();
14954      e->type = FFEEXPR_exprtypeOPERAND_;
14955      e->token = ffelex_token_use (ffeexpr_tokens_[0]);
14956      s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], FALSE,
14957					  &paren_type);
14958
14959      switch (ffesymbol_where (s))
14960	{
14961	case FFEINFO_whereLOCAL:
14962	  if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14963	    ffesymbol_error (s, ffeexpr_tokens_[0]);	/* Recursion. */
14964	  break;
14965
14966	case FFEINFO_whereINTRINSIC:
14967	case FFEINFO_whereGLOBAL:
14968	  if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
14969	    ffesymbol_error (s, ffeexpr_tokens_[0]);	/* Can call intrin. */
14970	  break;
14971
14972	case FFEINFO_whereCOMMON:
14973	case FFEINFO_whereDUMMY:
14974	case FFEINFO_whereRESULT:
14975	  break;
14976
14977	case FFEINFO_whereNONE:
14978	case FFEINFO_whereANY:
14979	  break;
14980
14981	default:
14982	  ffesymbol_error (s, ffeexpr_tokens_[0]);
14983	  break;
14984	}
14985
14986      if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14987	{
14988	  e->u.operand = ffebld_new_any ();
14989	  ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14990	}
14991      else
14992	{
14993	  e->u.operand = ffebld_new_symter (s,
14994					    ffesymbol_generic (s),
14995					    ffesymbol_specific (s),
14996					    ffesymbol_implementation (s));
14997	  ffebld_set_info (e->u.operand, ffesymbol_info (s));
14998	}
14999      ffeexpr_exprstack_push_ (e);	/* Not a complete operand yet. */
15000      ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
15001      switch (paren_type)
15002	{
15003	case FFEEXPR_parentypeSUBROUTINE_:
15004	  ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15005	  return
15006	    (ffelexHandler)
15007	    ffeexpr_rhs (ffeexpr_stack_->pool,
15008			 FFEEXPR_contextACTUALARG_,
15009			 ffeexpr_token_arguments_);
15010
15011	case FFEEXPR_parentypeARRAY_:
15012	  ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15013	  ffeexpr_stack_->bound_list = ffesymbol_dims (s);
15014	  ffeexpr_stack_->rank = 0;
15015	  ffeexpr_stack_->constant = TRUE;
15016	  ffeexpr_stack_->immediate = TRUE;
15017	  switch (ffeexpr_stack_->context)
15018	    {
15019	    case FFEEXPR_contextDATAIMPDOITEM_:
15020	      return
15021		(ffelexHandler)
15022		ffeexpr_rhs (ffeexpr_stack_->pool,
15023			     FFEEXPR_contextDATAIMPDOINDEX_,
15024			     ffeexpr_token_elements_);
15025
15026	    case FFEEXPR_contextEQUIVALENCE:
15027	      return
15028		(ffelexHandler)
15029		ffeexpr_rhs (ffeexpr_stack_->pool,
15030			     FFEEXPR_contextEQVINDEX_,
15031			     ffeexpr_token_elements_);
15032
15033	    default:
15034	      return
15035		(ffelexHandler)
15036		ffeexpr_rhs (ffeexpr_stack_->pool,
15037			     FFEEXPR_contextINDEX_,
15038			     ffeexpr_token_elements_);
15039	    }
15040
15041	case FFEEXPR_parentypeSUBSTRING_:
15042	  e->u.operand = ffeexpr_collapse_symter (e->u.operand,
15043						  ffeexpr_tokens_[0]);
15044	  return
15045	    (ffelexHandler)
15046	    ffeexpr_rhs (ffeexpr_stack_->pool,
15047			 FFEEXPR_contextINDEX_,
15048			 ffeexpr_token_substring_);
15049
15050	case FFEEXPR_parentypeEQUIVALENCE_:
15051	  ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15052	  ffeexpr_stack_->bound_list = ffesymbol_dims (s);
15053	  ffeexpr_stack_->rank = 0;
15054	  ffeexpr_stack_->constant = TRUE;
15055	  ffeexpr_stack_->immediate = TRUE;
15056	  return
15057	    (ffelexHandler)
15058	    ffeexpr_rhs (ffeexpr_stack_->pool,
15059			 FFEEXPR_contextEQVINDEX_,
15060			 ffeexpr_token_equivalence_);
15061
15062	case FFEEXPR_parentypeFUNCTION_:	/* Invalid case. */
15063	case FFEEXPR_parentypeFUNSUBSTR_:	/* Invalid case. */
15064	  ffesymbol_error (s, ffeexpr_tokens_[0]);
15065	  /* Fall through. */
15066	case FFEEXPR_parentypeANY_:
15067	  e->u.operand = ffebld_new_any ();
15068	  ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15069	  return
15070	    (ffelexHandler)
15071	    ffeexpr_rhs (ffeexpr_stack_->pool,
15072			 FFEEXPR_contextACTUALARG_,
15073			 ffeexpr_token_anything_);
15074
15075	default:
15076	  assert ("bad paren type" == NULL);
15077	  break;
15078	}
15079
15080    case FFELEX_typeEQUALS:	/* As in "VAR=". */
15081      switch (ffeexpr_stack_->context)
15082	{
15083	case FFEEXPR_contextIMPDOITEM_:	/* within
15084						   "(,VAR=start,end[,incr])". */
15085	case FFEEXPR_contextIMPDOITEMDF_:
15086	  ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
15087	  break;
15088
15089	case FFEEXPR_contextDATAIMPDOITEM_:
15090	  ffeexpr_stack_->context = FFEEXPR_contextDATAIMPDOCTRL_;
15091	  break;
15092
15093	default:
15094	  break;
15095	}
15096      break;
15097
15098#if 0
15099    case FFELEX_typePERIOD:
15100    case FFELEX_typePERCENT:
15101      assert ("FOO%, FOO. not yet supported!~~" == NULL);
15102      break;
15103#endif
15104
15105    default:
15106      break;
15107    }
15108
15109just_name:			/* :::::::::::::::::::: */
15110  e = ffeexpr_expr_new_ ();
15111  e->type = FFEEXPR_exprtypeOPERAND_;
15112  e->token = ffeexpr_tokens_[0];
15113  s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0],
15114				  (ffeexpr_stack_->context
15115				   == FFEEXPR_contextSUBROUTINEREF));
15116
15117  switch (ffesymbol_where (s))
15118    {
15119    case FFEINFO_whereCONSTANT:
15120      if ((ffeexpr_stack_->context != FFEEXPR_contextPARAMETER)
15121	  || (ffesymbol_kind (s) != FFEINFO_kindENTITY))
15122	ffesymbol_error (s, ffeexpr_tokens_[0]);
15123      break;
15124
15125    case FFEINFO_whereIMMEDIATE:
15126      if ((ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOCTRL_)
15127	  && (ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOINDEX_))
15128	ffesymbol_error (s, ffeexpr_tokens_[0]);
15129      break;
15130
15131    case FFEINFO_whereLOCAL:
15132      if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
15133	ffesymbol_error (s, ffeexpr_tokens_[0]);	/* Recurse!. */
15134      break;
15135
15136    case FFEINFO_whereINTRINSIC:
15137      if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
15138	ffesymbol_error (s, ffeexpr_tokens_[0]);	/* Can call intrin. */
15139      break;
15140
15141    default:
15142      break;
15143    }
15144
15145  if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15146    {
15147      expr = ffebld_new_any ();
15148      info = ffeinfo_new_any ();
15149      ffebld_set_info (expr, info);
15150    }
15151  else
15152    {
15153      expr = ffebld_new_symter (s,
15154				ffesymbol_generic (s),
15155				ffesymbol_specific (s),
15156				ffesymbol_implementation (s));
15157      info = ffesymbol_info (s);
15158      ffebld_set_info (expr, info);
15159      if (ffesymbol_is_doiter (s))
15160	{
15161	  ffebad_start (FFEBAD_DOITER);
15162	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15163		       ffelex_token_where_column (ffeexpr_tokens_[0]));
15164	  ffest_ffebad_here_doiter (1, s);
15165	  ffebad_string (ffesymbol_text (s));
15166	  ffebad_finish ();
15167	}
15168      expr = ffeexpr_collapse_symter (expr, ffeexpr_tokens_[0]);
15169    }
15170
15171  if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
15172    {
15173      if (ffebld_op (expr) == FFEBLD_opANY)
15174	{
15175	  expr = ffebld_new_any ();
15176	  ffebld_set_info (expr, ffeinfo_new_any ());
15177	}
15178      else
15179	{
15180	  expr = ffebld_new_subrref (expr, NULL);	/* No argument list. */
15181	  if (ffesymbol_generic (s) != FFEINTRIN_genNONE)
15182	    ffeintrin_fulfill_generic (&expr, &info, e->token);
15183	  else if (ffesymbol_specific (s) != FFEINTRIN_specNONE)
15184	    ffeintrin_fulfill_specific (&expr, &info, NULL, e->token);
15185	  else
15186	    ffeexpr_fulfill_call_ (&expr, e->token);
15187
15188	  if (ffebld_op (expr) != FFEBLD_opANY)
15189	    ffebld_set_info (expr,
15190			     ffeinfo_new (ffeinfo_basictype (info),
15191					  ffeinfo_kindtype (info),
15192					  0,
15193					  FFEINFO_kindENTITY,
15194					  FFEINFO_whereFLEETING,
15195					  ffeinfo_size (info)));
15196	  else
15197	    ffebld_set_info (expr, ffeinfo_new_any ());
15198	}
15199    }
15200
15201  e->u.operand = expr;
15202  ffeexpr_exprstack_push_operand_ (e);
15203  return (ffelexHandler) ffeexpr_finished_ (t);
15204}
15205
15206/* ffeexpr_token_name_arg_ -- Rhs NAME
15207
15208   Return a pointer to this function to the lexer (ffelex), which will
15209   invoke it for the next token.
15210
15211   Handle first token in an actual-arg (or possible actual-arg) context
15212   being a NAME, and use second token to refine the context.  */
15213
15214static ffelexHandler
15215ffeexpr_token_name_arg_ (ffelexToken t)
15216{
15217  switch (ffelex_token_type (t))
15218    {
15219    case FFELEX_typeCLOSE_PAREN:
15220    case FFELEX_typeCOMMA:
15221      switch (ffeexpr_stack_->context)
15222	{
15223	case FFEEXPR_contextINDEXORACTUALARG_:
15224	  ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
15225	  break;
15226
15227	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15228	  ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
15229	  break;
15230
15231	default:
15232	  break;
15233	}
15234      break;
15235
15236    default:
15237      switch (ffeexpr_stack_->context)
15238	{
15239	case FFEEXPR_contextACTUALARG_:
15240	  ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
15241	  break;
15242
15243	case FFEEXPR_contextINDEXORACTUALARG_:
15244	  ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
15245	  break;
15246
15247	case FFEEXPR_contextSFUNCDEFACTUALARG_:
15248	  ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
15249	  break;
15250
15251	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15252	  ffeexpr_stack_->context
15253	    = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
15254	  break;
15255
15256	default:
15257	  assert ("bad context in _name_arg_" == NULL);
15258	  break;
15259	}
15260      break;
15261    }
15262
15263  return (ffelexHandler) ffeexpr_token_name_rhs_ (t);
15264}
15265
15266/* ffeexpr_token_name_rhs_ -- Rhs NAME
15267
15268   Return a pointer to this function to the lexer (ffelex), which will
15269   invoke it for the next token.
15270
15271   Handle a name followed by open-paren, apostrophe (O'octal-const',
15272   Z'hex-const', or X'hex-const'), period (RECORD.MEMBER).
15273
15274   26-Nov-91  JCB  1.2
15275      When followed by apostrophe or quote, set lex hexnum flag on so
15276      [0-9] as first char of next token seen as starting a potentially
15277      hex number (NAME).
15278   04-Oct-91  JCB  1.1
15279      In case of intrinsic, decorate its SYMTER with the type info for
15280      the specific intrinsic.  */
15281
15282static ffelexHandler
15283ffeexpr_token_name_rhs_ (ffelexToken t)
15284{
15285  ffeexprExpr_ e;
15286  ffeexprParenType_ paren_type;
15287  ffesymbol s;
15288  bool sfdef;
15289
15290  switch (ffelex_token_type (t))
15291    {
15292    case FFELEX_typeQUOTE:
15293    case FFELEX_typeAPOSTROPHE:
15294      ffeexpr_tokens_[1] = ffelex_token_use (t);
15295      ffelex_set_hexnum (TRUE);
15296      return (ffelexHandler) ffeexpr_token_name_apos_;
15297
15298    case FFELEX_typeOPEN_PAREN:
15299      e = ffeexpr_expr_new_ ();
15300      e->type = FFEEXPR_exprtypeOPERAND_;
15301      e->token = ffelex_token_use (ffeexpr_tokens_[0]);
15302      s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], TRUE,
15303					  &paren_type);
15304      if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15305	e->u.operand = ffebld_new_any ();
15306      else
15307	e->u.operand = ffebld_new_symter (s, ffesymbol_generic (s),
15308					  ffesymbol_specific (s),
15309					  ffesymbol_implementation (s));
15310      ffeexpr_exprstack_push_ (e);	/* Not a complete operand yet. */
15311      ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
15312      switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15313	{
15314	case FFEEXPR_contextSFUNCDEF:
15315	case FFEEXPR_contextSFUNCDEFINDEX_:
15316	case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15317	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15318	  sfdef = TRUE;
15319	  break;
15320
15321	case FFEEXPR_contextSFUNCDEFACTUALARG_:
15322	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15323	  assert ("weird context!" == NULL);
15324	  sfdef = FALSE;
15325	  break;
15326
15327	default:
15328	  sfdef = FALSE;
15329	  break;
15330	}
15331      switch (paren_type)
15332	{
15333	case FFEEXPR_parentypeFUNCTION_:
15334	  ffebld_set_info (e->u.operand, ffesymbol_info (s));
15335	  ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15336	  if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
15337	    {			/* A statement function. */
15338	      ffeexpr_stack_->num_args
15339		= ffebld_list_length
15340		  (ffeexpr_stack_->next_dummy
15341		   = ffesymbol_dummyargs (s));
15342	      ffeexpr_stack_->tokens[1] = NULL;	/* !=NULL when > num_args. */
15343	    }
15344	  else if ((ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
15345		   && !ffe_is_pedantic_not_90 ()
15346		   && ((ffesymbol_implementation (s)
15347			== FFEINTRIN_impICHAR)
15348		       || (ffesymbol_implementation (s)
15349			   == FFEINTRIN_impIACHAR)
15350		       || (ffesymbol_implementation (s)
15351			   == FFEINTRIN_impLEN)))
15352	    {			/* Allow arbitrary concatenations. */
15353	      return
15354		(ffelexHandler)
15355		  ffeexpr_rhs (ffeexpr_stack_->pool,
15356			       sfdef
15357			       ? FFEEXPR_contextSFUNCDEF
15358			       : FFEEXPR_contextLET,
15359			       ffeexpr_token_arguments_);
15360	    }
15361	  return
15362	    (ffelexHandler)
15363	    ffeexpr_rhs (ffeexpr_stack_->pool,
15364			 sfdef
15365			 ? FFEEXPR_contextSFUNCDEFACTUALARG_
15366			 : FFEEXPR_contextACTUALARG_,
15367			 ffeexpr_token_arguments_);
15368
15369	case FFEEXPR_parentypeARRAY_:
15370	  ffebld_set_info (e->u.operand,
15371			   ffesymbol_info (ffebld_symter (e->u.operand)));
15372	  ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15373	  ffeexpr_stack_->bound_list = ffesymbol_dims (s);
15374	  ffeexpr_stack_->rank = 0;
15375	  ffeexpr_stack_->constant = TRUE;
15376	  ffeexpr_stack_->immediate = TRUE;
15377	  return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
15378					      sfdef
15379					      ? FFEEXPR_contextSFUNCDEFINDEX_
15380					      : FFEEXPR_contextINDEX_,
15381					      ffeexpr_token_elements_);
15382
15383	case FFEEXPR_parentypeSUBSTRING_:
15384	  ffebld_set_info (e->u.operand,
15385			   ffesymbol_info (ffebld_symter (e->u.operand)));
15386	  e->u.operand = ffeexpr_collapse_symter (e->u.operand,
15387						  ffeexpr_tokens_[0]);
15388	  return
15389	    (ffelexHandler)
15390	    ffeexpr_rhs (ffeexpr_stack_->pool,
15391			 sfdef
15392			 ? FFEEXPR_contextSFUNCDEFINDEX_
15393			 : FFEEXPR_contextINDEX_,
15394			 ffeexpr_token_substring_);
15395
15396	case FFEEXPR_parentypeFUNSUBSTR_:
15397	  return
15398	    (ffelexHandler)
15399	    ffeexpr_rhs (ffeexpr_stack_->pool,
15400			 sfdef
15401			 ? FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
15402			 : FFEEXPR_contextINDEXORACTUALARG_,
15403			 ffeexpr_token_funsubstr_);
15404
15405	case FFEEXPR_parentypeANY_:
15406	  ffebld_set_info (e->u.operand, ffesymbol_info (s));
15407	  return
15408	    (ffelexHandler)
15409	    ffeexpr_rhs (ffeexpr_stack_->pool,
15410			 sfdef
15411			 ? FFEEXPR_contextSFUNCDEFACTUALARG_
15412			 : FFEEXPR_contextACTUALARG_,
15413			 ffeexpr_token_anything_);
15414
15415	default:
15416	  assert ("bad paren type" == NULL);
15417	  break;
15418	}
15419
15420    case FFELEX_typeEQUALS:	/* As in "VAR=". */
15421      switch (ffeexpr_stack_->context)
15422	{
15423	case FFEEXPR_contextIMPDOITEM_:	/* "(,VAR=start,end[,incr])". */
15424	case FFEEXPR_contextIMPDOITEMDF_:
15425	  ffeexpr_stack_->is_rhs = FALSE;	/* Really an lhs construct. */
15426	  ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
15427	  break;
15428
15429	default:
15430	  break;
15431	}
15432      break;
15433
15434#if 0
15435    case FFELEX_typePERIOD:
15436    case FFELEX_typePERCENT:
15437      ~~Support these two someday, though not required
15438	assert ("FOO%, FOO. not yet supported!~~" == NULL);
15439      break;
15440#endif
15441
15442    default:
15443      break;
15444    }
15445
15446  switch (ffeexpr_stack_->context)
15447    {
15448    case FFEEXPR_contextINDEXORACTUALARG_:
15449    case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15450      assert ("strange context" == NULL);
15451      break;
15452
15453    default:
15454      break;
15455    }
15456
15457  e = ffeexpr_expr_new_ ();
15458  e->type = FFEEXPR_exprtypeOPERAND_;
15459  e->token = ffeexpr_tokens_[0];
15460  s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0], FALSE);
15461  if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15462    {
15463      e->u.operand = ffebld_new_any ();
15464      ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15465    }
15466  else
15467    {
15468      e->u.operand = ffebld_new_symter (s, FFEINTRIN_genNONE,
15469					ffesymbol_specific (s),
15470					ffesymbol_implementation (s));
15471      if (ffesymbol_specific (s) == FFEINTRIN_specNONE)
15472	ffebld_set_info (e->u.operand, ffeinfo_use (ffesymbol_info (s)));
15473      else
15474	{			/* Decorate the SYMTER with the actual type
15475				   of the intrinsic. */
15476	  ffebld_set_info (e->u.operand, ffeinfo_new
15477			(ffeintrin_basictype (ffesymbol_specific (s)),
15478			 ffeintrin_kindtype (ffesymbol_specific (s)),
15479			 0,
15480			 ffesymbol_kind (s),
15481			 ffesymbol_where (s),
15482			 FFETARGET_charactersizeNONE));
15483	}
15484      if (ffesymbol_is_doiter (s))
15485	ffebld_symter_set_is_doiter (e->u.operand, TRUE);
15486      e->u.operand = ffeexpr_collapse_symter (e->u.operand,
15487					      ffeexpr_tokens_[0]);
15488    }
15489  ffeexpr_exprstack_push_operand_ (e);
15490  return (ffelexHandler) ffeexpr_token_binary_ (t);
15491}
15492
15493/* ffeexpr_token_name_apos_ -- Rhs NAME APOSTROPHE
15494
15495   Return a pointer to this function to the lexer (ffelex), which will
15496   invoke it for the next token.
15497
15498   Expecting a NAME token, analyze the previous NAME token to see what kind,
15499   if any, typeless constant we've got.
15500
15501   01-Sep-90  JCB  1.1
15502      Expect a NAME instead of CHARACTER in this situation.  */
15503
15504static ffelexHandler
15505ffeexpr_token_name_apos_ (ffelexToken t)
15506{
15507  ffeexprExpr_ e;
15508
15509  ffelex_set_hexnum (FALSE);
15510
15511  switch (ffelex_token_type (t))
15512    {
15513    case FFELEX_typeNAME:
15514      ffeexpr_tokens_[2] = ffelex_token_use (t);
15515      return (ffelexHandler) ffeexpr_token_name_apos_name_;
15516
15517    default:
15518      break;
15519    }
15520
15521  if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
15522    {
15523      ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
15524      ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15525		   ffelex_token_where_column (ffeexpr_tokens_[0]));
15526      ffebad_here (1, ffelex_token_where_line (t),
15527		   ffelex_token_where_column (t));
15528      ffebad_finish ();
15529    }
15530
15531  ffelex_token_kill (ffeexpr_tokens_[1]);
15532
15533  e = ffeexpr_expr_new_ ();
15534  e->type = FFEEXPR_exprtypeOPERAND_;
15535  e->u.operand = ffebld_new_any ();
15536  ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15537  e->token = ffeexpr_tokens_[0];
15538  ffeexpr_exprstack_push_operand_ (e);
15539
15540  return (ffelexHandler) ffeexpr_token_binary_ (t);
15541}
15542
15543/* ffeexpr_token_name_apos_name_ -- Rhs NAME APOSTROPHE NAME
15544
15545   Return a pointer to this function to the lexer (ffelex), which will
15546   invoke it for the next token.
15547
15548   Expecting an APOSTROPHE token, analyze the previous NAME token to see
15549   what kind, if any, typeless constant we've got.  */
15550
15551static ffelexHandler
15552ffeexpr_token_name_apos_name_ (ffelexToken t)
15553{
15554  ffeexprExpr_ e;
15555  char c;
15556
15557  e = ffeexpr_expr_new_ ();
15558  e->type = FFEEXPR_exprtypeOPERAND_;
15559  e->token = ffeexpr_tokens_[0];
15560
15561  if ((ffelex_token_type (t) == ffelex_token_type (ffeexpr_tokens_[1]))
15562      && (ffelex_token_length (ffeexpr_tokens_[0]) == 1)
15563      && (ffesrc_char_match_init ((c = ffelex_token_text (ffeexpr_tokens_[0])[0]),
15564				  'B', 'b')
15565	  || ffesrc_char_match_init (c, 'O', 'o')
15566	  || ffesrc_char_match_init (c, 'X', 'x')
15567	  || ffesrc_char_match_init (c, 'Z', 'z')))
15568    {
15569      ffetargetCharacterSize size;
15570
15571      if (!ffe_is_typeless_boz ()) {
15572
15573      switch (c)
15574	{
15575	case FFESRC_CASE_MATCH_INIT ('B', 'b', imatch_b, no_imatch):
15576	  e->u.operand = ffebld_new_conter (ffebld_constant_new_integerbinary
15577					    (ffeexpr_tokens_[2]));
15578	  break;
15579
15580	case FFESRC_CASE_MATCH_INIT ('O', 'o', imatch_o, no_imatch):
15581	  e->u.operand = ffebld_new_conter (ffebld_constant_new_integeroctal
15582					    (ffeexpr_tokens_[2]));
15583	  break;
15584
15585	case FFESRC_CASE_MATCH_INIT ('X', 'x', imatch_x, no_imatch):
15586	  e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
15587					    (ffeexpr_tokens_[2]));
15588	  break;
15589
15590	case FFESRC_CASE_MATCH_INIT ('Z', 'z', imatch_z, no_imatch):
15591	  e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
15592					    (ffeexpr_tokens_[2]));
15593	  break;
15594
15595	default:
15596	no_imatch:		/* :::::::::::::::::::: */
15597	  assert ("not BOXZ!" == NULL);
15598	  abort ();
15599	}
15600
15601	ffebld_set_info (e->u.operand,
15602			 ffeinfo_new (FFEINFO_basictypeINTEGER,
15603				      FFEINFO_kindtypeINTEGERDEFAULT, 0,
15604				      FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
15605				      FFETARGET_charactersizeNONE));
15606	ffeexpr_exprstack_push_operand_ (e);
15607	ffelex_token_kill (ffeexpr_tokens_[1]);
15608	ffelex_token_kill (ffeexpr_tokens_[2]);
15609	return (ffelexHandler) ffeexpr_token_binary_;
15610      }
15611
15612      switch (c)
15613	{
15614	case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
15615	  e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_bm
15616					    (ffeexpr_tokens_[2]));
15617	  size = ffetarget_size_typeless_binary (ffeexpr_tokens_[2]);
15618	  break;
15619
15620	case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
15621	  e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_om
15622					    (ffeexpr_tokens_[2]));
15623	  size = ffetarget_size_typeless_octal (ffeexpr_tokens_[2]);
15624	  break;
15625
15626	case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
15627	  e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hxm
15628					    (ffeexpr_tokens_[2]));
15629	  size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15630	  break;
15631
15632	case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
15633	  e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
15634					    (ffeexpr_tokens_[2]));
15635	  size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15636	  break;
15637
15638	default:
15639	no_match:		/* :::::::::::::::::::: */
15640	  assert ("not BOXZ!" == NULL);
15641	  e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
15642					    (ffeexpr_tokens_[2]));
15643	  size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15644	  break;
15645	}
15646      ffebld_set_info (e->u.operand,
15647	       ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
15648		       0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
15649      ffeexpr_exprstack_push_operand_ (e);
15650      ffelex_token_kill (ffeexpr_tokens_[1]);
15651      ffelex_token_kill (ffeexpr_tokens_[2]);
15652      return (ffelexHandler) ffeexpr_token_binary_;
15653    }
15654
15655  if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
15656    {
15657      ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
15658      ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15659		   ffelex_token_where_column (ffeexpr_tokens_[0]));
15660      ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
15661      ffebad_finish ();
15662    }
15663
15664  ffelex_token_kill (ffeexpr_tokens_[1]);
15665  ffelex_token_kill (ffeexpr_tokens_[2]);
15666
15667  e->type = FFEEXPR_exprtypeOPERAND_;
15668  e->u.operand = ffebld_new_any ();
15669  ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15670  e->token = ffeexpr_tokens_[0];
15671  ffeexpr_exprstack_push_operand_ (e);
15672
15673  switch (ffelex_token_type (t))
15674    {
15675    case FFELEX_typeAPOSTROPHE:
15676    case FFELEX_typeQUOTE:
15677      return (ffelexHandler) ffeexpr_token_binary_;
15678
15679    default:
15680      return (ffelexHandler) ffeexpr_token_binary_ (t);
15681    }
15682}
15683
15684/* ffeexpr_token_percent_ -- Rhs PERCENT
15685
15686   Handle a percent sign possibly followed by "LOC".  If followed instead
15687   by "VAL", "REF", or "DESCR", issue an error message and substitute
15688   "LOC".  If followed by something else, treat the percent sign as a
15689   spurious incorrect token and reprocess the token via _rhs_.	*/
15690
15691static ffelexHandler
15692ffeexpr_token_percent_ (ffelexToken t)
15693{
15694  switch (ffelex_token_type (t))
15695    {
15696    case FFELEX_typeNAME:
15697    case FFELEX_typeNAMES:
15698      ffeexpr_stack_->percent = ffeexpr_percent_ (t);
15699      ffeexpr_tokens_[1] = ffelex_token_use (t);
15700      return (ffelexHandler) ffeexpr_token_percent_name_;
15701
15702    default:
15703      if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
15704	{
15705	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15706		       ffelex_token_where_column (ffeexpr_tokens_[0]));
15707	  ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
15708		   ffelex_token_where_column (ffeexpr_stack_->first_token));
15709	  ffebad_finish ();
15710	}
15711      ffelex_token_kill (ffeexpr_tokens_[0]);
15712      return (ffelexHandler) ffeexpr_token_rhs_ (t);
15713    }
15714}
15715
15716/* ffeexpr_token_percent_name_ -- Rhs PERCENT NAME
15717
15718   Make sure the token is OPEN_PAREN and prepare for the one-item list of
15719   LHS expressions.  Else display an error message.  */
15720
15721static ffelexHandler
15722ffeexpr_token_percent_name_ (ffelexToken t)
15723{
15724  ffelexHandler nexthandler;
15725
15726  if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
15727    {
15728      if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
15729	{
15730	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15731		       ffelex_token_where_column (ffeexpr_tokens_[0]));
15732	  ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
15733		   ffelex_token_where_column (ffeexpr_stack_->first_token));
15734	  ffebad_finish ();
15735	}
15736      ffelex_token_kill (ffeexpr_tokens_[0]);
15737      nexthandler = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_tokens_[1]);
15738      ffelex_token_kill (ffeexpr_tokens_[1]);
15739      return (ffelexHandler) (*nexthandler) (t);
15740    }
15741
15742  switch (ffeexpr_stack_->percent)
15743    {
15744    default:
15745      if (ffest_ffebad_start (FFEBAD_INVALID_PERCENT))
15746	{
15747	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15748		       ffelex_token_where_column (ffeexpr_tokens_[0]));
15749	  ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
15750	  ffebad_finish ();
15751	}
15752      ffeexpr_stack_->percent = FFEEXPR_percentLOC_;
15753      /* Fall through. */
15754    case FFEEXPR_percentLOC_:
15755      ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
15756      ffelex_token_kill (ffeexpr_tokens_[1]);
15757      ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
15758      return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
15759					  FFEEXPR_contextLOC_,
15760					  ffeexpr_cb_end_loc_);
15761    }
15762}
15763
15764/* ffeexpr_make_float_const_ -- Make a floating-point constant
15765
15766   See prototype.
15767
15768   Pass 'E', 'D', or 'Q' for exponent letter.  */
15769
15770static void
15771ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
15772			   ffelexToken decimal, ffelexToken fraction,
15773			   ffelexToken exponent, ffelexToken exponent_sign,
15774			   ffelexToken exponent_digits)
15775{
15776  ffeexprExpr_ e;
15777
15778  e = ffeexpr_expr_new_ ();
15779  e->type = FFEEXPR_exprtypeOPERAND_;
15780  if (integer != NULL)
15781    e->token = ffelex_token_use (integer);
15782  else
15783    {
15784      assert (decimal != NULL);
15785      e->token = ffelex_token_use (decimal);
15786    }
15787
15788  switch (exp_letter)
15789    {
15790#if !FFETARGET_okREALQUAD
15791    case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
15792      if (ffebad_start (FFEBAD_QUAD_UNSUPPORTED))
15793	{
15794	  ffebad_here (0, ffelex_token_where_line (e->token),
15795		       ffelex_token_where_column (e->token));
15796	  ffebad_finish ();
15797	}
15798      goto match_d;		/* The FFESRC_CASE_* macros don't
15799				   allow fall-through! */
15800#endif
15801
15802    case FFESRC_CASE_MATCH_INIT ('D', 'd', match_d, no_match):
15803      e->u.operand = ffebld_new_conter (ffebld_constant_new_realdouble
15804					(integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15805      ffebld_set_info (e->u.operand,
15806	     ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
15807			  0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15808      break;
15809
15810    case FFESRC_CASE_MATCH_INIT ('E', 'e', match_e, no_match):
15811      e->u.operand = ffebld_new_conter (ffebld_constant_new_realdefault
15812					(integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15813      ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeREAL,
15814			 FFEINFO_kindtypeREALDEFAULT, 0, FFEINFO_kindENTITY,
15815		       FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15816      break;
15817
15818#if FFETARGET_okREALQUAD
15819    case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
15820      e->u.operand = ffebld_new_conter (ffebld_constant_new_realquad
15821					(integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15822      ffebld_set_info (e->u.operand,
15823	       ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALQUAD,
15824			    0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15825      break;
15826#endif
15827
15828    case 'I':	/* Make an integer. */
15829      e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
15830					(ffeexpr_tokens_[0]));
15831      ffebld_set_info (e->u.operand,
15832		       ffeinfo_new (FFEINFO_basictypeINTEGER,
15833				    FFEINFO_kindtypeINTEGERDEFAULT, 0,
15834				    FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
15835				    FFETARGET_charactersizeNONE));
15836      break;
15837
15838    default:
15839    no_match:			/* :::::::::::::::::::: */
15840      assert ("Lost the exponent letter!" == NULL);
15841    }
15842
15843  ffeexpr_exprstack_push_operand_ (e);
15844}
15845
15846/* Just like ffesymbol_declare_local, except performs any implicit info
15847   assignment necessary.  */
15848
15849static ffesymbol
15850ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin)
15851{
15852  ffesymbol s;
15853  ffeinfoKind k;
15854  bool bad;
15855
15856  s = ffesymbol_declare_local (t, maybe_intrin);
15857
15858  switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15859    /* Special-case these since they can involve a different concept
15860       of "state" (in the stmtfunc name space).  */
15861    {
15862    case FFEEXPR_contextDATAIMPDOINDEX_:
15863    case FFEEXPR_contextDATAIMPDOCTRL_:
15864      if (ffeexpr_context_outer_ (ffeexpr_stack_)
15865	  == FFEEXPR_contextDATAIMPDOINDEX_)
15866	s = ffeexpr_sym_impdoitem_ (s, t);
15867      else
15868	if (ffeexpr_stack_->is_rhs)
15869	  s = ffeexpr_sym_impdoitem_ (s, t);
15870	else
15871	  s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
15872      bad = (ffesymbol_kind (s) != FFEINFO_kindENTITY)
15873	|| ((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
15874	    && (ffesymbol_where (s) != FFEINFO_whereIMMEDIATE));
15875      if (bad && (ffesymbol_kind (s) != FFEINFO_kindANY))
15876	ffesymbol_error (s, t);
15877      return s;
15878
15879    default:
15880      break;
15881    }
15882
15883  switch ((ffesymbol_sfdummyparent (s) == NULL)
15884	  ? ffesymbol_state (s)
15885	  : FFESYMBOL_stateUNDERSTOOD)
15886    {
15887    case FFESYMBOL_stateNONE:	/* Before first exec, not seen in expr
15888				   context. */
15889      if (!ffest_seen_first_exec ())
15890	goto seen;		/* :::::::::::::::::::: */
15891      /* Fall through. */
15892    case FFESYMBOL_stateUNCERTAIN:	/* Unseen since first exec. */
15893      switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15894	{
15895	case FFEEXPR_contextSUBROUTINEREF:
15896	  s = ffeexpr_sym_lhs_call_ (s, t);
15897	  break;
15898
15899	case FFEEXPR_contextFILEEXTFUNC:
15900	  s = ffeexpr_sym_lhs_extfunc_ (s, t);
15901	  break;
15902
15903	case FFEEXPR_contextSFUNCDEFACTUALARG_:
15904	  s = ffecom_sym_exec_transition (s);
15905	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15906	    goto understood;	/* :::::::::::::::::::: */
15907	  /* Fall through. */
15908	case FFEEXPR_contextACTUALARG_:
15909	  s = ffeexpr_sym_rhs_actualarg_ (s, t);
15910	  break;
15911
15912	case FFEEXPR_contextDATA:
15913	  if (ffeexpr_stack_->is_rhs)
15914	    s = ffeexpr_sym_rhs_let_ (s, t);
15915	  else
15916	    s = ffeexpr_sym_lhs_data_ (s, t);
15917	  break;
15918
15919	case FFEEXPR_contextDATAIMPDOITEM_:
15920	  s = ffeexpr_sym_lhs_data_ (s, t);
15921	  break;
15922
15923	case FFEEXPR_contextSFUNCDEF:
15924	case FFEEXPR_contextSFUNCDEFINDEX_:
15925	case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15926	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15927	  s = ffecom_sym_exec_transition (s);
15928	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15929	    goto understood;	/* :::::::::::::::::::: */
15930	  /* Fall through. */
15931	case FFEEXPR_contextLET:
15932	case FFEEXPR_contextPAREN_:
15933	case FFEEXPR_contextACTUALARGEXPR_:
15934	case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15935	case FFEEXPR_contextASSIGN:
15936	case FFEEXPR_contextIOLIST:
15937	case FFEEXPR_contextIOLISTDF:
15938	case FFEEXPR_contextDO:
15939	case FFEEXPR_contextDOWHILE:
15940	case FFEEXPR_contextAGOTO:
15941	case FFEEXPR_contextCGOTO:
15942	case FFEEXPR_contextIF:
15943	case FFEEXPR_contextARITHIF:
15944	case FFEEXPR_contextFORMAT:
15945	case FFEEXPR_contextSTOP:
15946	case FFEEXPR_contextRETURN:
15947	case FFEEXPR_contextSELECTCASE:
15948	case FFEEXPR_contextCASE:
15949	case FFEEXPR_contextFILEASSOC:
15950	case FFEEXPR_contextFILEINT:
15951	case FFEEXPR_contextFILEDFINT:
15952	case FFEEXPR_contextFILELOG:
15953	case FFEEXPR_contextFILENUM:
15954	case FFEEXPR_contextFILENUMAMBIG:
15955	case FFEEXPR_contextFILECHAR:
15956	case FFEEXPR_contextFILENUMCHAR:
15957	case FFEEXPR_contextFILEDFCHAR:
15958	case FFEEXPR_contextFILEKEY:
15959	case FFEEXPR_contextFILEUNIT:
15960	case FFEEXPR_contextFILEUNIT_DF:
15961	case FFEEXPR_contextFILEUNITAMBIG:
15962	case FFEEXPR_contextFILEFORMAT:
15963	case FFEEXPR_contextFILENAMELIST:
15964	case FFEEXPR_contextFILEVXTCODE:
15965	case FFEEXPR_contextINDEX_:
15966	case FFEEXPR_contextIMPDOITEM_:
15967	case FFEEXPR_contextIMPDOITEMDF_:
15968	case FFEEXPR_contextIMPDOCTRL_:
15969	case FFEEXPR_contextLOC_:
15970	  if (ffeexpr_stack_->is_rhs)
15971	    s = ffeexpr_sym_rhs_let_ (s, t);
15972	  else
15973	    s = ffeexpr_sym_lhs_let_ (s, t);
15974	  break;
15975
15976	case FFEEXPR_contextCHARACTERSIZE:
15977	case FFEEXPR_contextEQUIVALENCE:
15978	case FFEEXPR_contextINCLUDE:
15979	case FFEEXPR_contextPARAMETER:
15980	case FFEEXPR_contextDIMLIST:
15981	case FFEEXPR_contextDIMLISTCOMMON:
15982	case FFEEXPR_contextKINDTYPE:
15983	case FFEEXPR_contextINITVAL:
15984	case FFEEXPR_contextEQVINDEX_:
15985	  break;		/* Will turn into errors below. */
15986
15987	default:
15988	  ffesymbol_error (s, t);
15989	  break;
15990	}
15991      /* Fall through. */
15992    case FFESYMBOL_stateUNDERSTOOD:	/* Nothing much more to learn. */
15993    understood:		/* :::::::::::::::::::: */
15994      k = ffesymbol_kind (s);
15995      switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15996	{
15997	case FFEEXPR_contextSUBROUTINEREF:
15998	  bad = ((k != FFEINFO_kindSUBROUTINE)
15999		 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
16000		     || (k != FFEINFO_kindNONE)));
16001	  break;
16002
16003	case FFEEXPR_contextFILEEXTFUNC:
16004	  bad = (k != FFEINFO_kindFUNCTION)
16005	    || (ffesymbol_where (s) != FFEINFO_whereGLOBAL);
16006	  break;
16007
16008	case FFEEXPR_contextSFUNCDEFACTUALARG_:
16009	case FFEEXPR_contextACTUALARG_:
16010	  switch (k)
16011	    {
16012	    case FFEINFO_kindENTITY:
16013	      bad = FALSE;
16014	      break;
16015
16016	    case FFEINFO_kindFUNCTION:
16017	    case FFEINFO_kindSUBROUTINE:
16018	      bad
16019		= ((ffesymbol_where (s) != FFEINFO_whereGLOBAL)
16020		   && (ffesymbol_where (s) != FFEINFO_whereDUMMY)
16021		   && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
16022		       || !ffeintrin_is_actualarg (ffesymbol_specific (s))));
16023	      break;
16024
16025	    case FFEINFO_kindNONE:
16026	      if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
16027		{
16028		  bad = !(ffeintrin_is_actualarg (ffesymbol_specific (s)));
16029		  break;
16030		}
16031
16032	      /* If state is UNDERSTOOD here, it's CHAR*(*) or attrsANY,
16033		 and in the former case, attrsTYPE is set, so we
16034		 see this as an error as we should, since CHAR*(*)
16035		 cannot be actually referenced in a main/block data
16036		 program unit.  */
16037
16038	      if ((ffesymbol_attrs (s) & (FFESYMBOL_attrsANY
16039					  | FFESYMBOL_attrsEXTERNAL
16040					  | FFESYMBOL_attrsTYPE))
16041		  == FFESYMBOL_attrsEXTERNAL)
16042		bad = FALSE;
16043	      else
16044		bad = TRUE;
16045	      break;
16046
16047	    default:
16048	      bad = TRUE;
16049	      break;
16050	    }
16051	  break;
16052
16053	case FFEEXPR_contextDATA:
16054	  if (ffeexpr_stack_->is_rhs)
16055	    bad = (k != FFEINFO_kindENTITY)
16056	      || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16057	  else
16058	    bad = (k != FFEINFO_kindENTITY)
16059	      || ((ffesymbol_where (s) != FFEINFO_whereNONE)
16060		  && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
16061		  && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
16062	  break;
16063
16064	case FFEEXPR_contextDATAIMPDOITEM_:
16065	  bad = TRUE;		/* Unadorned item never valid. */
16066	  break;
16067
16068	case FFEEXPR_contextSFUNCDEF:
16069	case FFEEXPR_contextSFUNCDEFINDEX_:
16070	case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16071	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16072	case FFEEXPR_contextLET:
16073	case FFEEXPR_contextPAREN_:
16074	case FFEEXPR_contextACTUALARGEXPR_:
16075	case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16076	case FFEEXPR_contextASSIGN:
16077	case FFEEXPR_contextIOLIST:
16078	case FFEEXPR_contextIOLISTDF:
16079	case FFEEXPR_contextDO:
16080	case FFEEXPR_contextDOWHILE:
16081	case FFEEXPR_contextAGOTO:
16082	case FFEEXPR_contextCGOTO:
16083	case FFEEXPR_contextIF:
16084	case FFEEXPR_contextARITHIF:
16085	case FFEEXPR_contextFORMAT:
16086	case FFEEXPR_contextSTOP:
16087	case FFEEXPR_contextRETURN:
16088	case FFEEXPR_contextSELECTCASE:
16089	case FFEEXPR_contextCASE:
16090	case FFEEXPR_contextFILEASSOC:
16091	case FFEEXPR_contextFILEINT:
16092	case FFEEXPR_contextFILEDFINT:
16093	case FFEEXPR_contextFILELOG:
16094	case FFEEXPR_contextFILENUM:
16095	case FFEEXPR_contextFILENUMAMBIG:
16096	case FFEEXPR_contextFILECHAR:
16097	case FFEEXPR_contextFILENUMCHAR:
16098	case FFEEXPR_contextFILEDFCHAR:
16099	case FFEEXPR_contextFILEKEY:
16100	case FFEEXPR_contextFILEUNIT:
16101	case FFEEXPR_contextFILEUNIT_DF:
16102	case FFEEXPR_contextFILEUNITAMBIG:
16103	case FFEEXPR_contextFILEFORMAT:
16104	case FFEEXPR_contextFILENAMELIST:
16105	case FFEEXPR_contextFILEVXTCODE:
16106	case FFEEXPR_contextINDEX_:
16107	case FFEEXPR_contextIMPDOITEM_:
16108	case FFEEXPR_contextIMPDOITEMDF_:
16109	case FFEEXPR_contextIMPDOCTRL_:
16110	case FFEEXPR_contextLOC_:
16111	  bad = (k != FFEINFO_kindENTITY);	/* This catches "SUBROUTINE
16112						   X(A);EXTERNAL A;CALL
16113						   Y(A);B=A", for example. */
16114	  break;
16115
16116	case FFEEXPR_contextCHARACTERSIZE:
16117	case FFEEXPR_contextEQUIVALENCE:
16118	case FFEEXPR_contextPARAMETER:
16119	case FFEEXPR_contextDIMLIST:
16120	case FFEEXPR_contextDIMLISTCOMMON:
16121	case FFEEXPR_contextKINDTYPE:
16122	case FFEEXPR_contextINITVAL:
16123	case FFEEXPR_contextEQVINDEX_:
16124	  bad = (k != FFEINFO_kindENTITY)
16125	    || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16126	  break;
16127
16128	case FFEEXPR_contextINCLUDE:
16129	  bad = TRUE;
16130	  break;
16131
16132	default:
16133	  bad = TRUE;
16134	  break;
16135	}
16136      if (bad && (k != FFEINFO_kindANY))
16137	ffesymbol_error (s, t);
16138      return s;
16139
16140    case FFESYMBOL_stateSEEN:	/* Seen but not yet in exec portion. */
16141    seen:			/* :::::::::::::::::::: */
16142      switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16143	{
16144	case FFEEXPR_contextPARAMETER:
16145	  if (ffeexpr_stack_->is_rhs)
16146	    ffesymbol_error (s, t);
16147	  else
16148	    s = ffeexpr_sym_lhs_parameter_ (s, t);
16149	  break;
16150
16151	case FFEEXPR_contextDATA:
16152	  s = ffecom_sym_exec_transition (s);
16153	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16154	    goto understood;	/* :::::::::::::::::::: */
16155	  if (ffeexpr_stack_->is_rhs)
16156	    ffesymbol_error (s, t);
16157	  else
16158	    s = ffeexpr_sym_lhs_data_ (s, t);
16159	  goto understood;	/* :::::::::::::::::::: */
16160
16161	case FFEEXPR_contextDATAIMPDOITEM_:
16162	  s = ffecom_sym_exec_transition (s);
16163	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16164	    goto understood;	/* :::::::::::::::::::: */
16165	  s = ffeexpr_sym_lhs_data_ (s, t);
16166	  goto understood;	/* :::::::::::::::::::: */
16167
16168	case FFEEXPR_contextEQUIVALENCE:
16169	  s = ffeexpr_sym_lhs_equivalence_ (s, t);
16170	  break;
16171
16172	case FFEEXPR_contextDIMLIST:
16173	  s = ffeexpr_sym_rhs_dimlist_ (s, t);
16174	  break;
16175
16176	case FFEEXPR_contextCHARACTERSIZE:
16177	case FFEEXPR_contextKINDTYPE:
16178	case FFEEXPR_contextDIMLISTCOMMON:
16179	case FFEEXPR_contextINITVAL:
16180	case FFEEXPR_contextEQVINDEX_:
16181	  ffesymbol_error (s, t);
16182	  break;
16183
16184	case FFEEXPR_contextINCLUDE:
16185	  ffesymbol_error (s, t);
16186	  break;
16187
16188	case FFEEXPR_contextACTUALARG_:	/* E.g. I in REAL A(Y(I)). */
16189	case FFEEXPR_contextSFUNCDEFACTUALARG_:
16190	  s = ffecom_sym_exec_transition (s);
16191	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16192	    goto understood;	/* :::::::::::::::::::: */
16193	  s = ffeexpr_sym_rhs_actualarg_ (s, t);
16194	  goto understood;	/* :::::::::::::::::::: */
16195
16196	case FFEEXPR_contextINDEX_:
16197	case FFEEXPR_contextACTUALARGEXPR_:
16198	case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16199	case FFEEXPR_contextSFUNCDEF:
16200	case FFEEXPR_contextSFUNCDEFINDEX_:
16201	case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16202	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16203	  assert (ffeexpr_stack_->is_rhs);
16204	  s = ffecom_sym_exec_transition (s);
16205	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16206	    goto understood;	/* :::::::::::::::::::: */
16207	  s = ffeexpr_sym_rhs_let_ (s, t);
16208	  goto understood;	/* :::::::::::::::::::: */
16209
16210	default:
16211	  ffesymbol_error (s, t);
16212	  break;
16213	}
16214      return s;
16215
16216    default:
16217      assert ("bad symbol state" == NULL);
16218      return NULL;
16219      break;
16220    }
16221}
16222
16223/* Have FOO in DATA (XYZ(FOO),...)/.../ or DATA (...,XYZ=FOO,BAR,BLETCH).
16224   Could be found via the "statement-function" name space (in which case
16225   it should become an iterator) or the local name space (in which case
16226   it should be either a named constant, or a variable that will have an
16227   sfunc name space sibling that should become an iterator).  */
16228
16229static ffesymbol
16230ffeexpr_sym_impdoitem_ (ffesymbol sp, ffelexToken t)
16231{
16232  ffesymbol s;
16233  ffesymbolAttrs sa;
16234  ffesymbolAttrs na;
16235  ffesymbolState ss;
16236  ffesymbolState ns;
16237  ffeinfoKind kind;
16238  ffeinfoWhere where;
16239
16240  ss = ffesymbol_state (sp);
16241
16242  if (ffesymbol_sfdummyparent (sp) != NULL)
16243    {				/* Have symbol in sfunc name space. */
16244      switch (ss)
16245	{
16246	case FFESYMBOL_stateNONE:	/* Used as iterator already. */
16247	  if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
16248	    ffesymbol_error (sp, t);	/* Can't use dead iterator. */
16249	  else
16250	    {			/* Can use dead iterator because we're at at
16251				   least an innermore (higher-numbered) level
16252				   than the iterator's outermost
16253				   (lowest-numbered) level. */
16254	      ffesymbol_signal_change (sp);
16255	      ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
16256	      ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
16257	      ffesymbol_signal_unreported (sp);
16258	    }
16259	  break;
16260
16261	case FFESYMBOL_stateSEEN:	/* Seen already in this or other
16262					   implied-DO.  Set symbol level
16263					   number to outermost value, as that
16264					   tells us we can see it as iterator
16265					   at that level at the innermost. */
16266	  if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
16267	    {
16268	      ffesymbol_signal_change (sp);
16269	      ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
16270	      ffesymbol_signal_unreported (sp);
16271	    }
16272	  break;
16273
16274	case FFESYMBOL_stateUNCERTAIN:	/* Iterator. */
16275	  assert (ffeexpr_level_ == ffesymbol_maxentrynum (sp));
16276	  ffesymbol_error (sp, t);	/* (,,,I=I,10). */
16277	  break;
16278
16279	case FFESYMBOL_stateUNDERSTOOD:
16280	  break;		/* ANY. */
16281
16282	default:
16283	  assert ("Foo Bar!!" == NULL);
16284	  break;
16285	}
16286
16287      return sp;
16288    }
16289
16290  /* Got symbol in local name space, so we haven't seen it in impdo yet.
16291     First, if it is brand-new and we're in executable statements, set the
16292     attributes and exec-transition it to set state UNCERTAIN or UNDERSTOOD.
16293     Second, if it is now a constant (PARAMETER), then just return it, it
16294     can't be an implied-do iterator.  If it is understood, complain if it is
16295     not a valid variable, but make the inner name space iterator anyway and
16296     return that.  If it is not understood, improve understanding of the
16297     symbol accordingly, complain accordingly, in either case make the inner
16298     name space iterator and return that.  */
16299
16300  sa = ffesymbol_attrs (sp);
16301
16302  if (ffesymbol_state_is_specable (ss)
16303      && ffest_seen_first_exec ())
16304    {
16305      assert (sa == FFESYMBOL_attrsetNONE);
16306      ffesymbol_signal_change (sp);
16307      ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
16308      ffesymbol_resolve_intrin (sp);
16309      if (ffeimplic_establish_symbol (sp))
16310	ffesymbol_set_attr (sp, FFESYMBOL_attrSFARG);
16311      else
16312	ffesymbol_error (sp, t);
16313
16314      /* After the exec transition, the state will either be UNCERTAIN (could
16315	 be a dummy or local var) or UNDERSTOOD (local var, because this is a
16316	 PROGRAM/BLOCKDATA program unit).  */
16317
16318      sp = ffecom_sym_exec_transition (sp);
16319      sa = ffesymbol_attrs (sp);
16320      ss = ffesymbol_state (sp);
16321    }
16322
16323  ns = ss;
16324  kind = ffesymbol_kind (sp);
16325  where = ffesymbol_where (sp);
16326
16327  if (ss == FFESYMBOL_stateUNDERSTOOD)
16328    {
16329      if (kind != FFEINFO_kindENTITY)
16330	ffesymbol_error (sp, t);
16331      if (where == FFEINFO_whereCONSTANT)
16332	return sp;
16333    }
16334  else
16335    {
16336      /* Enhance understanding of local symbol.  This used to imply exec
16337	 transition, but that doesn't seem necessary, since the local symbol
16338	 doesn't actually get put into an ffebld tree here -- we just learn
16339	 more about it, just like when we see a local symbol's name in the
16340	 dummy-arg list of a statement function.  */
16341
16342      if (ss != FFESYMBOL_stateUNCERTAIN)
16343	{
16344	  /* Figure out what kind of object we've got based on previous
16345	     declarations of or references to the object. */
16346
16347	  ns = FFESYMBOL_stateSEEN;
16348
16349	  if (sa & FFESYMBOL_attrsANY)
16350	    na = sa;
16351	  else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
16352			    | FFESYMBOL_attrsANY
16353			    | FFESYMBOL_attrsCOMMON
16354			    | FFESYMBOL_attrsDUMMY
16355			    | FFESYMBOL_attrsEQUIV
16356			    | FFESYMBOL_attrsINIT
16357			    | FFESYMBOL_attrsNAMELIST
16358			    | FFESYMBOL_attrsRESULT
16359			    | FFESYMBOL_attrsSAVE
16360			    | FFESYMBOL_attrsSFARG
16361			    | FFESYMBOL_attrsTYPE)))
16362	    na = sa | FFESYMBOL_attrsSFARG;
16363	  else
16364	    na = FFESYMBOL_attrsetNONE;
16365	}
16366      else
16367	{			/* stateUNCERTAIN. */
16368	  na = sa | FFESYMBOL_attrsSFARG;
16369	  ns = FFESYMBOL_stateUNDERSTOOD;
16370
16371	  assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16372			   | FFESYMBOL_attrsADJUSTABLE
16373			   | FFESYMBOL_attrsANYLEN
16374			   | FFESYMBOL_attrsARRAY
16375			   | FFESYMBOL_attrsDUMMY
16376			   | FFESYMBOL_attrsEXTERNAL
16377			   | FFESYMBOL_attrsSFARG
16378			   | FFESYMBOL_attrsTYPE)));
16379
16380	  if (sa & FFESYMBOL_attrsEXTERNAL)
16381	    {
16382	      assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16383			       | FFESYMBOL_attrsDUMMY
16384			       | FFESYMBOL_attrsEXTERNAL
16385			       | FFESYMBOL_attrsTYPE)));
16386
16387	      na = FFESYMBOL_attrsetNONE;
16388	    }
16389	  else if (sa & FFESYMBOL_attrsDUMMY)
16390	    {
16391	      assert (!(sa & FFESYMBOL_attrsEXTERNAL));	/* Handled above. */
16392	      assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16393			       | FFESYMBOL_attrsEXTERNAL
16394			       | FFESYMBOL_attrsTYPE)));
16395
16396	      kind = FFEINFO_kindENTITY;
16397	    }
16398	  else if (sa & FFESYMBOL_attrsARRAY)
16399	    {
16400	      assert (!(sa & ~(FFESYMBOL_attrsARRAY
16401			       | FFESYMBOL_attrsADJUSTABLE
16402			       | FFESYMBOL_attrsTYPE)));
16403
16404	      na = FFESYMBOL_attrsetNONE;
16405	    }
16406	  else if (sa & FFESYMBOL_attrsSFARG)
16407	    {
16408	      assert (!(sa & ~(FFESYMBOL_attrsSFARG
16409			       | FFESYMBOL_attrsTYPE)));
16410
16411	      ns = FFESYMBOL_stateUNCERTAIN;
16412	    }
16413	  else if (sa & FFESYMBOL_attrsTYPE)
16414	    {
16415	      assert (!(sa & (FFESYMBOL_attrsARRAY
16416			      | FFESYMBOL_attrsDUMMY
16417			      | FFESYMBOL_attrsEXTERNAL
16418			      | FFESYMBOL_attrsSFARG)));	/* Handled above. */
16419	      assert (!(sa & ~(FFESYMBOL_attrsTYPE
16420			       | FFESYMBOL_attrsADJUSTABLE
16421			       | FFESYMBOL_attrsANYLEN
16422			       | FFESYMBOL_attrsARRAY
16423			       | FFESYMBOL_attrsDUMMY
16424			       | FFESYMBOL_attrsEXTERNAL
16425			       | FFESYMBOL_attrsSFARG)));
16426
16427	      kind = FFEINFO_kindENTITY;
16428
16429	      if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16430		na = FFESYMBOL_attrsetNONE;
16431	      else if (ffest_is_entry_valid ())
16432		ns = FFESYMBOL_stateUNCERTAIN;	/* Could be DUMMY or LOCAL. */
16433	      else
16434		where = FFEINFO_whereLOCAL;
16435	    }
16436	  else
16437	    na = FFESYMBOL_attrsetNONE;	/* Error. */
16438	}
16439
16440      /* Now see what we've got for a new object: NONE means a new error
16441	 cropped up; ANY means an old error to be ignored; otherwise,
16442	 everything's ok, update the object (symbol) and continue on. */
16443
16444      if (na == FFESYMBOL_attrsetNONE)
16445	ffesymbol_error (sp, t);
16446      else if (!(na & FFESYMBOL_attrsANY))
16447	{
16448	  ffesymbol_signal_change (sp);	/* May need to back up to previous
16449					   version. */
16450	  if (!ffeimplic_establish_symbol (sp))
16451	    ffesymbol_error (sp, t);
16452	  else
16453	    {
16454	      ffesymbol_set_info (sp,
16455				  ffeinfo_new (ffesymbol_basictype (sp),
16456					       ffesymbol_kindtype (sp),
16457					       ffesymbol_rank (sp),
16458					       kind,
16459					       where,
16460					       ffesymbol_size (sp)));
16461	      ffesymbol_set_attrs (sp, na);
16462	      ffesymbol_set_state (sp, ns);
16463	      ffesymbol_resolve_intrin (sp);
16464	      if (!ffesymbol_state_is_specable (ns))
16465		sp = ffecom_sym_learned (sp);
16466	      ffesymbol_signal_unreported (sp);	/* For debugging purposes. */
16467	    }
16468	}
16469    }
16470
16471  /* Here we create the sfunc-name-space symbol representing what should
16472     become an iterator in this name space at this or an outermore (lower-
16473     numbered) expression level, else the implied-DO construct is in error.  */
16474
16475  s = ffesymbol_declare_sfdummy (t);	/* Sets maxentrynum to 0 for new obj;
16476					   also sets sfa_dummy_parent to
16477					   parent symbol. */
16478  assert (sp == ffesymbol_sfdummyparent (s));
16479
16480  ffesymbol_signal_change (s);
16481  ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
16482  ffesymbol_set_maxentrynum (s, ffeexpr_level_);
16483  ffesymbol_set_info (s,
16484		      ffeinfo_new (FFEINFO_basictypeINTEGER,
16485				   FFEINFO_kindtypeINTEGERDEFAULT,
16486				   0,
16487				   FFEINFO_kindENTITY,
16488				   FFEINFO_whereIMMEDIATE,
16489				   FFETARGET_charactersizeNONE));
16490  ffesymbol_signal_unreported (s);
16491
16492  if (((ffesymbol_basictype (sp) != FFEINFO_basictypeINTEGER)
16493       && (ffesymbol_basictype (sp) != FFEINFO_basictypeANY))
16494      || ((ffesymbol_kindtype (sp) != FFEINFO_kindtypeINTEGERDEFAULT)
16495	  && (ffesymbol_kindtype (sp) != FFEINFO_kindtypeANY)))
16496    ffesymbol_error (s, t);
16497
16498  return s;
16499}
16500
16501/* Have FOO in CALL FOO.  Local name space, executable context only.  */
16502
16503static ffesymbol
16504ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t)
16505{
16506  ffesymbolAttrs sa;
16507  ffesymbolAttrs na;
16508  ffeinfoKind kind;
16509  ffeinfoWhere where;
16510  ffeintrinGen gen;
16511  ffeintrinSpec spec;
16512  ffeintrinImp imp;
16513  bool error = FALSE;
16514
16515  assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16516	  || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16517
16518  na = sa = ffesymbol_attrs (s);
16519
16520  assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16521		   | FFESYMBOL_attrsADJUSTABLE
16522		   | FFESYMBOL_attrsANYLEN
16523		   | FFESYMBOL_attrsARRAY
16524		   | FFESYMBOL_attrsDUMMY
16525		   | FFESYMBOL_attrsEXTERNAL
16526		   | FFESYMBOL_attrsSFARG
16527		   | FFESYMBOL_attrsTYPE)));
16528
16529  kind = ffesymbol_kind (s);
16530  where = ffesymbol_where (s);
16531
16532  /* Figure out what kind of object we've got based on previous declarations
16533     of or references to the object. */
16534
16535  if (sa & FFESYMBOL_attrsEXTERNAL)
16536    {
16537      assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16538		       | FFESYMBOL_attrsDUMMY
16539		       | FFESYMBOL_attrsEXTERNAL
16540		       | FFESYMBOL_attrsTYPE)));
16541
16542      if (sa & FFESYMBOL_attrsTYPE)
16543	error = TRUE;
16544      else
16545	/* Not TYPE. */
16546	{
16547	  kind = FFEINFO_kindSUBROUTINE;
16548
16549	  if (sa & FFESYMBOL_attrsDUMMY)
16550	    ;			/* Not TYPE. */
16551	  else if (sa & FFESYMBOL_attrsACTUALARG)
16552	    ;			/* Not DUMMY or TYPE. */
16553	  else			/* Not ACTUALARG, DUMMY, or TYPE. */
16554	    where = FFEINFO_whereGLOBAL;
16555	}
16556    }
16557  else if (sa & FFESYMBOL_attrsDUMMY)
16558    {
16559      assert (!(sa & FFESYMBOL_attrsEXTERNAL));	/* Handled above. */
16560      assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16561		       | FFESYMBOL_attrsEXTERNAL
16562		       | FFESYMBOL_attrsTYPE)));
16563
16564      if (sa & FFESYMBOL_attrsTYPE)
16565	error = TRUE;
16566      else
16567	kind = FFEINFO_kindSUBROUTINE;
16568    }
16569  else if (sa & FFESYMBOL_attrsARRAY)
16570    {
16571      assert (!(sa & ~(FFESYMBOL_attrsARRAY
16572		       | FFESYMBOL_attrsADJUSTABLE
16573		       | FFESYMBOL_attrsTYPE)));
16574
16575      error = TRUE;
16576    }
16577  else if (sa & FFESYMBOL_attrsSFARG)
16578    {
16579      assert (!(sa & ~(FFESYMBOL_attrsSFARG
16580		       | FFESYMBOL_attrsTYPE)));
16581
16582      error = TRUE;
16583    }
16584  else if (sa & FFESYMBOL_attrsTYPE)
16585    {
16586      assert (!(sa & (FFESYMBOL_attrsARRAY
16587		      | FFESYMBOL_attrsDUMMY
16588		      | FFESYMBOL_attrsEXTERNAL
16589		      | FFESYMBOL_attrsSFARG)));	/* Handled above. */
16590      assert (!(sa & ~(FFESYMBOL_attrsTYPE
16591		       | FFESYMBOL_attrsADJUSTABLE
16592		       | FFESYMBOL_attrsANYLEN
16593		       | FFESYMBOL_attrsARRAY
16594		       | FFESYMBOL_attrsDUMMY
16595		       | FFESYMBOL_attrsEXTERNAL
16596		       | FFESYMBOL_attrsSFARG)));
16597
16598      error = TRUE;
16599    }
16600  else if (sa == FFESYMBOL_attrsetNONE)
16601    {
16602      assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16603
16604      if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
16605				  &gen, &spec, &imp))
16606	{
16607	  ffesymbol_signal_change (s);	/* May need to back up to previous
16608					   version. */
16609	  ffesymbol_set_generic (s, gen);
16610	  ffesymbol_set_specific (s, spec);
16611	  ffesymbol_set_implementation (s, imp);
16612	  ffesymbol_set_info (s,
16613			      ffeinfo_new (FFEINFO_basictypeNONE,
16614					   FFEINFO_kindtypeNONE,
16615					   0,
16616					   FFEINFO_kindSUBROUTINE,
16617					   FFEINFO_whereINTRINSIC,
16618					   FFETARGET_charactersizeNONE));
16619	  ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16620	  ffesymbol_resolve_intrin (s);
16621	  ffesymbol_reference (s, t, FALSE);
16622	  s = ffecom_sym_learned (s);
16623	  ffesymbol_signal_unreported (s);	/* For debugging purposes. */
16624
16625	  return s;
16626	}
16627
16628      kind = FFEINFO_kindSUBROUTINE;
16629      where = FFEINFO_whereGLOBAL;
16630    }
16631  else
16632    error = TRUE;
16633
16634  /* Now see what we've got for a new object: NONE means a new error cropped
16635     up; ANY means an old error to be ignored; otherwise, everything's ok,
16636     update the object (symbol) and continue on. */
16637
16638  if (error)
16639    ffesymbol_error (s, t);
16640  else if (!(na & FFESYMBOL_attrsANY))
16641    {
16642      ffesymbol_signal_change (s);	/* May need to back up to previous
16643					   version. */
16644      ffesymbol_set_info (s,
16645			  ffeinfo_new (ffesymbol_basictype (s),
16646				       ffesymbol_kindtype (s),
16647				       ffesymbol_rank (s),
16648				       kind,	/* SUBROUTINE. */
16649				       where,	/* GLOBAL or DUMMY. */
16650				       ffesymbol_size (s)));
16651      ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16652      ffesymbol_resolve_intrin (s);
16653      ffesymbol_reference (s, t, FALSE);
16654      s = ffecom_sym_learned (s);
16655      ffesymbol_signal_unreported (s);	/* For debugging purposes. */
16656    }
16657
16658  return s;
16659}
16660
16661/* Have FOO in DATA FOO/.../.  Local name space and executable context
16662   only.  (This will change in the future when DATA FOO may be followed
16663   by COMMON FOO or even INTEGER FOO(10), etc.)  */
16664
16665static ffesymbol
16666ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t)
16667{
16668  ffesymbolAttrs sa;
16669  ffesymbolAttrs na;
16670  ffeinfoKind kind;
16671  ffeinfoWhere where;
16672  bool error = FALSE;
16673
16674  assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16675	  || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16676
16677  na = sa = ffesymbol_attrs (s);
16678
16679  assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16680		   | FFESYMBOL_attrsADJUSTABLE
16681		   | FFESYMBOL_attrsANYLEN
16682		   | FFESYMBOL_attrsARRAY
16683		   | FFESYMBOL_attrsDUMMY
16684		   | FFESYMBOL_attrsEXTERNAL
16685		   | FFESYMBOL_attrsSFARG
16686		   | FFESYMBOL_attrsTYPE)));
16687
16688  kind = ffesymbol_kind (s);
16689  where = ffesymbol_where (s);
16690
16691  /* Figure out what kind of object we've got based on previous declarations
16692     of or references to the object. */
16693
16694  if (sa & FFESYMBOL_attrsEXTERNAL)
16695    {
16696      assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16697		       | FFESYMBOL_attrsDUMMY
16698		       | FFESYMBOL_attrsEXTERNAL
16699		       | FFESYMBOL_attrsTYPE)));
16700
16701      error = TRUE;
16702    }
16703  else if (sa & FFESYMBOL_attrsDUMMY)
16704    {
16705      assert (!(sa & FFESYMBOL_attrsEXTERNAL));	/* Handled above. */
16706      assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16707		       | FFESYMBOL_attrsEXTERNAL
16708		       | FFESYMBOL_attrsTYPE)));
16709
16710      error = TRUE;
16711    }
16712  else if (sa & FFESYMBOL_attrsARRAY)
16713    {
16714      assert (!(sa & ~(FFESYMBOL_attrsARRAY
16715		       | FFESYMBOL_attrsADJUSTABLE
16716		       | FFESYMBOL_attrsTYPE)));
16717
16718      if (sa & FFESYMBOL_attrsADJUSTABLE)
16719	error = TRUE;
16720      where = FFEINFO_whereLOCAL;
16721    }
16722  else if (sa & FFESYMBOL_attrsSFARG)
16723    {
16724      assert (!(sa & ~(FFESYMBOL_attrsSFARG
16725		       | FFESYMBOL_attrsTYPE)));
16726
16727      where = FFEINFO_whereLOCAL;
16728    }
16729  else if (sa & FFESYMBOL_attrsTYPE)
16730    {
16731      assert (!(sa & (FFESYMBOL_attrsARRAY
16732		      | FFESYMBOL_attrsDUMMY
16733		      | FFESYMBOL_attrsEXTERNAL
16734		      | FFESYMBOL_attrsSFARG)));	/* Handled above. */
16735      assert (!(sa & ~(FFESYMBOL_attrsTYPE
16736		       | FFESYMBOL_attrsADJUSTABLE
16737		       | FFESYMBOL_attrsANYLEN
16738		       | FFESYMBOL_attrsARRAY
16739		       | FFESYMBOL_attrsDUMMY
16740		       | FFESYMBOL_attrsEXTERNAL
16741		       | FFESYMBOL_attrsSFARG)));
16742
16743      if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16744	error = TRUE;
16745      else
16746	{
16747	  kind = FFEINFO_kindENTITY;
16748	  where = FFEINFO_whereLOCAL;
16749	}
16750    }
16751  else if (sa == FFESYMBOL_attrsetNONE)
16752    {
16753      assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16754      kind = FFEINFO_kindENTITY;
16755      where = FFEINFO_whereLOCAL;
16756    }
16757  else
16758    error = TRUE;
16759
16760  /* Now see what we've got for a new object: NONE means a new error cropped
16761     up; ANY means an old error to be ignored; otherwise, everything's ok,
16762     update the object (symbol) and continue on. */
16763
16764  if (error)
16765    ffesymbol_error (s, t);
16766  else if (!(na & FFESYMBOL_attrsANY))
16767    {
16768      ffesymbol_signal_change (s);	/* May need to back up to previous
16769					   version. */
16770      if (!ffeimplic_establish_symbol (s))
16771	{
16772	  ffesymbol_error (s, t);
16773	  return s;
16774	}
16775      ffesymbol_set_info (s,
16776			  ffeinfo_new (ffesymbol_basictype (s),
16777				       ffesymbol_kindtype (s),
16778				       ffesymbol_rank (s),
16779				       kind,	/* ENTITY. */
16780				       where,	/* LOCAL. */
16781				       ffesymbol_size (s)));
16782      ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16783      ffesymbol_resolve_intrin (s);
16784      s = ffecom_sym_learned (s);
16785      ffesymbol_signal_unreported (s);	/* For debugging purposes. */
16786    }
16787
16788  return s;
16789}
16790
16791/* Have FOO in EQUIVALENCE (...,FOO,...).  Does not include
16792   EQUIVALENCE (...,BAR(FOO),...).  */
16793
16794static ffesymbol
16795ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t)
16796{
16797  ffesymbolAttrs sa;
16798  ffesymbolAttrs na;
16799  ffeinfoKind kind;
16800  ffeinfoWhere where;
16801
16802  na = sa = ffesymbol_attrs (s);
16803  kind = FFEINFO_kindENTITY;
16804  where = ffesymbol_where (s);
16805
16806  /* Figure out what kind of object we've got based on previous declarations
16807     of or references to the object. */
16808
16809  if (!(sa & ~(FFESYMBOL_attrsADJUSTS
16810	       | FFESYMBOL_attrsARRAY
16811	       | FFESYMBOL_attrsCOMMON
16812	       | FFESYMBOL_attrsEQUIV
16813	       | FFESYMBOL_attrsINIT
16814	       | FFESYMBOL_attrsNAMELIST
16815	       | FFESYMBOL_attrsSAVE
16816	       | FFESYMBOL_attrsSFARG
16817	       | FFESYMBOL_attrsTYPE)))
16818    na = sa | FFESYMBOL_attrsEQUIV;
16819  else
16820    na = FFESYMBOL_attrsetNONE;
16821
16822  /* Don't know why we're bothering to set kind and where in this code, but
16823     added the following to make it complete, in case it's really important.
16824     Generally this is left up to symbol exec transition.  */
16825
16826  if (where == FFEINFO_whereNONE)
16827    {
16828      if (na & (FFESYMBOL_attrsADJUSTS
16829		| FFESYMBOL_attrsCOMMON))
16830	where = FFEINFO_whereCOMMON;
16831      else if (na & FFESYMBOL_attrsSAVE)
16832	where = FFEINFO_whereLOCAL;
16833    }
16834
16835  /* Now see what we've got for a new object: NONE means a new error cropped
16836     up; ANY means an old error to be ignored; otherwise, everything's ok,
16837     update the object (symbol) and continue on. */
16838
16839  if (na == FFESYMBOL_attrsetNONE)
16840    ffesymbol_error (s, t);
16841  else if (!(na & FFESYMBOL_attrsANY))
16842    {
16843      ffesymbol_signal_change (s);	/* May need to back up to previous
16844					   version. */
16845      ffesymbol_set_info (s,
16846			  ffeinfo_new (ffesymbol_basictype (s),
16847				       ffesymbol_kindtype (s),
16848				       ffesymbol_rank (s),
16849				       kind,	/* Always ENTITY. */
16850				       where,	/* NONE, COMMON, or LOCAL. */
16851				       ffesymbol_size (s)));
16852      ffesymbol_set_attrs (s, na);
16853      ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
16854      ffesymbol_resolve_intrin (s);
16855      ffesymbol_signal_unreported (s);	/* For debugging purposes. */
16856    }
16857
16858  return s;
16859}
16860
16861/* Have FOO in OPEN(...,USEROPEN=FOO,...).  Executable context only.
16862
16863   Note that I think this should be considered semantically similar to
16864   doing CALL XYZ(FOO), in that it should be considered like an
16865   ACTUALARG context.  In particular, without EXTERNAL being specified,
16866   it should not be allowed.  */
16867
16868static ffesymbol
16869ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t)
16870{
16871  ffesymbolAttrs sa;
16872  ffesymbolAttrs na;
16873  ffeinfoKind kind;
16874  ffeinfoWhere where;
16875  bool needs_type = FALSE;
16876  bool error = FALSE;
16877
16878  assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16879	  || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16880
16881  na = sa = ffesymbol_attrs (s);
16882
16883  assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16884		   | FFESYMBOL_attrsADJUSTABLE
16885		   | FFESYMBOL_attrsANYLEN
16886		   | FFESYMBOL_attrsARRAY
16887		   | FFESYMBOL_attrsDUMMY
16888		   | FFESYMBOL_attrsEXTERNAL
16889		   | FFESYMBOL_attrsSFARG
16890		   | FFESYMBOL_attrsTYPE)));
16891
16892  kind = ffesymbol_kind (s);
16893  where = ffesymbol_where (s);
16894
16895  /* Figure out what kind of object we've got based on previous declarations
16896     of or references to the object. */
16897
16898  if (sa & FFESYMBOL_attrsEXTERNAL)
16899    {
16900      assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16901		       | FFESYMBOL_attrsDUMMY
16902		       | FFESYMBOL_attrsEXTERNAL
16903		       | FFESYMBOL_attrsTYPE)));
16904
16905      if (sa & FFESYMBOL_attrsTYPE)
16906	where = FFEINFO_whereGLOBAL;
16907      else
16908	/* Not TYPE. */
16909	{
16910	  kind = FFEINFO_kindFUNCTION;
16911	  needs_type = TRUE;
16912
16913	  if (sa & FFESYMBOL_attrsDUMMY)
16914	    ;			/* Not TYPE. */
16915	  else if (sa & FFESYMBOL_attrsACTUALARG)
16916	    ;			/* Not DUMMY or TYPE. */
16917	  else			/* Not ACTUALARG, DUMMY, or TYPE. */
16918	    where = FFEINFO_whereGLOBAL;
16919	}
16920    }
16921  else if (sa & FFESYMBOL_attrsDUMMY)
16922    {
16923      assert (!(sa & FFESYMBOL_attrsEXTERNAL));	/* Handled above. */
16924      assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16925		       | FFESYMBOL_attrsEXTERNAL
16926		       | FFESYMBOL_attrsTYPE)));
16927
16928      kind = FFEINFO_kindFUNCTION;
16929      if (!(sa & FFESYMBOL_attrsTYPE))
16930	needs_type = TRUE;
16931    }
16932  else if (sa & FFESYMBOL_attrsARRAY)
16933    {
16934      assert (!(sa & ~(FFESYMBOL_attrsARRAY
16935		       | FFESYMBOL_attrsADJUSTABLE
16936		       | FFESYMBOL_attrsTYPE)));
16937
16938      error = TRUE;
16939    }
16940  else if (sa & FFESYMBOL_attrsSFARG)
16941    {
16942      assert (!(sa & ~(FFESYMBOL_attrsSFARG
16943		       | FFESYMBOL_attrsTYPE)));
16944
16945      error = TRUE;
16946    }
16947  else if (sa & FFESYMBOL_attrsTYPE)
16948    {
16949      assert (!(sa & (FFESYMBOL_attrsARRAY
16950		      | FFESYMBOL_attrsDUMMY
16951		      | FFESYMBOL_attrsEXTERNAL
16952		      | FFESYMBOL_attrsSFARG)));	/* Handled above. */
16953      assert (!(sa & ~(FFESYMBOL_attrsTYPE
16954		       | FFESYMBOL_attrsADJUSTABLE
16955		       | FFESYMBOL_attrsANYLEN
16956		       | FFESYMBOL_attrsARRAY
16957		       | FFESYMBOL_attrsDUMMY
16958		       | FFESYMBOL_attrsEXTERNAL
16959		       | FFESYMBOL_attrsSFARG)));
16960
16961      if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16962	error = TRUE;
16963      else
16964	{
16965	  kind = FFEINFO_kindFUNCTION;
16966	  where = FFEINFO_whereGLOBAL;
16967	}
16968    }
16969  else if (sa == FFESYMBOL_attrsetNONE)
16970    {
16971      assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16972      kind = FFEINFO_kindFUNCTION;
16973      where = FFEINFO_whereGLOBAL;
16974      needs_type = TRUE;
16975    }
16976  else
16977    error = TRUE;
16978
16979  /* Now see what we've got for a new object: NONE means a new error cropped
16980     up; ANY means an old error to be ignored; otherwise, everything's ok,
16981     update the object (symbol) and continue on. */
16982
16983  if (error)
16984    ffesymbol_error (s, t);
16985  else if (!(na & FFESYMBOL_attrsANY))
16986    {
16987      ffesymbol_signal_change (s);	/* May need to back up to previous
16988					   version. */
16989      if (needs_type && !ffeimplic_establish_symbol (s))
16990	{
16991	  ffesymbol_error (s, t);
16992	  return s;
16993	}
16994      if (!ffesymbol_explicitwhere (s))
16995	{
16996	  ffebad_start (FFEBAD_NEED_EXTERNAL);
16997	  ffebad_here (0, ffelex_token_where_line (t),
16998		       ffelex_token_where_column (t));
16999	  ffebad_string (ffesymbol_text (s));
17000	  ffebad_finish ();
17001	  ffesymbol_set_explicitwhere (s, TRUE);
17002	}
17003      ffesymbol_set_info (s,
17004			  ffeinfo_new (ffesymbol_basictype (s),
17005				       ffesymbol_kindtype (s),
17006				       ffesymbol_rank (s),
17007				       kind,	/* FUNCTION. */
17008				       where,	/* GLOBAL or DUMMY. */
17009				       ffesymbol_size (s)));
17010      ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17011      ffesymbol_resolve_intrin (s);
17012      ffesymbol_reference (s, t, FALSE);
17013      s = ffecom_sym_learned (s);
17014      ffesymbol_signal_unreported (s);	/* For debugging purposes. */
17015    }
17016
17017  return s;
17018}
17019
17020/* Have FOO in DATA (stuff,FOO=1,10)/.../.  */
17021
17022static ffesymbol
17023ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t)
17024{
17025  ffesymbolState ss;
17026
17027  /* If the symbol isn't in the sfunc name space, pretend as though we saw a
17028     reference to it already within the imp-DO construct at this level, so as
17029     to get a symbol that is in the sfunc name space. But this is an
17030     erroneous construct, and should be caught elsewhere.  */
17031
17032  if (ffesymbol_sfdummyparent (s) == NULL)
17033    {
17034      s = ffeexpr_sym_impdoitem_ (s, t);
17035      if (ffesymbol_sfdummyparent (s) == NULL)
17036	{			/* PARAMETER FOO...DATA (A(I),FOO=...). */
17037	  ffesymbol_error (s, t);
17038	  return s;
17039	}
17040    }
17041
17042  ss = ffesymbol_state (s);
17043
17044  switch (ss)
17045    {
17046    case FFESYMBOL_stateNONE:	/* Used as iterator already. */
17047      if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
17048	ffesymbol_error (s, t);	/* Can't reuse dead iterator.  F90 disallows
17049				   this; F77 allows it but it is a stupid
17050				   feature. */
17051      else
17052	{			/* Can use dead iterator because we're at at
17053				   least a innermore (higher-numbered) level
17054				   than the iterator's outermost
17055				   (lowest-numbered) level.  This should be
17056				   diagnosed later, because it means an item
17057				   in this list didn't reference this
17058				   iterator. */
17059#if 1
17060	  ffesymbol_error (s, t);	/* For now, complain. */
17061#else /* Someday will detect all cases where initializer doesn't reference
17062	 all applicable iterators, in which case reenable this code. */
17063	  ffesymbol_signal_change (s);
17064	  ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
17065	  ffesymbol_set_maxentrynum (s, ffeexpr_level_);
17066	  ffesymbol_signal_unreported (s);
17067#endif
17068	}
17069      break;
17070
17071    case FFESYMBOL_stateSEEN:	/* Seen already in this or other implied-DO.
17072				   If seen in outermore level, can't be an
17073				   iterator here, so complain.  If not seen
17074				   at current level, complain for now,
17075				   because that indicates something F90
17076				   rejects (though we currently don't detect
17077				   all such cases for now). */
17078      if (ffeexpr_level_ <= ffesymbol_maxentrynum (s))
17079	{
17080	  ffesymbol_signal_change (s);
17081	  ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
17082	  ffesymbol_signal_unreported (s);
17083	}
17084      else
17085	ffesymbol_error (s, t);
17086      break;
17087
17088    case FFESYMBOL_stateUNCERTAIN:	/* Already iterator! */
17089      assert ("DATA implied-DO control var seen twice!!" == NULL);
17090      ffesymbol_error (s, t);
17091      break;
17092
17093    case FFESYMBOL_stateUNDERSTOOD:
17094      break;			/* ANY. */
17095
17096    default:
17097      assert ("Foo Bletch!!" == NULL);
17098      break;
17099    }
17100
17101  return s;
17102}
17103
17104/* Have FOO in PARAMETER (FOO=...).  */
17105
17106static ffesymbol
17107ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t)
17108{
17109  ffesymbolAttrs sa;
17110
17111  sa = ffesymbol_attrs (s);
17112
17113  /* Figure out what kind of object we've got based on previous declarations
17114     of or references to the object. */
17115
17116  if (sa & ~(FFESYMBOL_attrsANYLEN
17117	     | FFESYMBOL_attrsTYPE))
17118    {
17119      if (!(sa & FFESYMBOL_attrsANY))
17120	ffesymbol_error (s, t);
17121    }
17122  else
17123    {
17124      ffesymbol_signal_change (s);	/* May need to back up to previous
17125					   version. */
17126      if (!ffeimplic_establish_symbol (s))
17127	{
17128	  ffesymbol_error (s, t);
17129	  return s;
17130	}
17131      ffesymbol_set_info (s,
17132			  ffeinfo_new (ffesymbol_basictype (s),
17133				       ffesymbol_kindtype (s),
17134				       ffesymbol_rank (s),
17135				       FFEINFO_kindENTITY,
17136				       FFEINFO_whereCONSTANT,
17137				       ffesymbol_size (s)));
17138      ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17139      ffesymbol_resolve_intrin (s);
17140      s = ffecom_sym_learned (s);
17141      ffesymbol_signal_unreported (s);	/* For debugging purposes. */
17142    }
17143
17144  return s;
17145}
17146
17147/* Have FOO in CALL XYZ(...,FOO,...).  Does not include any other
17148   embedding of FOO, such as CALL XYZ((FOO)) or CALL XYZ(FOO+1).  */
17149
17150static ffesymbol
17151ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t)
17152{
17153  ffesymbolAttrs sa;
17154  ffesymbolAttrs na;
17155  ffeinfoKind kind;
17156  ffeinfoWhere where;
17157  ffesymbolState ns;
17158  bool needs_type = FALSE;
17159
17160  assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
17161	  || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
17162
17163  na = sa = ffesymbol_attrs (s);
17164
17165  assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17166		   | FFESYMBOL_attrsADJUSTABLE
17167		   | FFESYMBOL_attrsANYLEN
17168		   | FFESYMBOL_attrsARRAY
17169		   | FFESYMBOL_attrsDUMMY
17170		   | FFESYMBOL_attrsEXTERNAL
17171		   | FFESYMBOL_attrsSFARG
17172		   | FFESYMBOL_attrsTYPE)));
17173
17174  kind = ffesymbol_kind (s);
17175  where = ffesymbol_where (s);
17176
17177  /* Figure out what kind of object we've got based on previous declarations
17178     of or references to the object. */
17179
17180  ns = FFESYMBOL_stateUNDERSTOOD;
17181
17182  if (sa & FFESYMBOL_attrsEXTERNAL)
17183    {
17184      assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17185		       | FFESYMBOL_attrsDUMMY
17186		       | FFESYMBOL_attrsEXTERNAL
17187		       | FFESYMBOL_attrsTYPE)));
17188
17189      if (sa & FFESYMBOL_attrsTYPE)
17190	where = FFEINFO_whereGLOBAL;
17191      else
17192	/* Not TYPE. */
17193	{
17194	  ns = FFESYMBOL_stateUNCERTAIN;
17195
17196	  if (sa & FFESYMBOL_attrsDUMMY)
17197	    assert (kind == FFEINFO_kindNONE);	/* FUNCTION, SUBROUTINE. */
17198	  else if (sa & FFESYMBOL_attrsACTUALARG)
17199	    ;			/* Not DUMMY or TYPE. */
17200	  else
17201	    /* Not ACTUALARG, DUMMY, or TYPE. */
17202	    {
17203	      assert (kind == FFEINFO_kindNONE);	/* FUNCTION, SUBROUTINE. */
17204	      na |= FFESYMBOL_attrsACTUALARG;
17205	      where = FFEINFO_whereGLOBAL;
17206	    }
17207	}
17208    }
17209  else if (sa & FFESYMBOL_attrsDUMMY)
17210    {
17211      assert (!(sa & FFESYMBOL_attrsEXTERNAL));	/* Handled above. */
17212      assert (!(sa & ~(FFESYMBOL_attrsDUMMY
17213		       | FFESYMBOL_attrsEXTERNAL
17214		       | FFESYMBOL_attrsTYPE)));
17215
17216      kind = FFEINFO_kindENTITY;
17217      if (!(sa & FFESYMBOL_attrsTYPE))
17218	needs_type = TRUE;
17219    }
17220  else if (sa & FFESYMBOL_attrsARRAY)
17221    {
17222      assert (!(sa & ~(FFESYMBOL_attrsARRAY
17223		       | FFESYMBOL_attrsADJUSTABLE
17224		       | FFESYMBOL_attrsTYPE)));
17225
17226      where = FFEINFO_whereLOCAL;
17227    }
17228  else if (sa & FFESYMBOL_attrsSFARG)
17229    {
17230      assert (!(sa & ~(FFESYMBOL_attrsSFARG
17231		       | FFESYMBOL_attrsTYPE)));
17232
17233      where = FFEINFO_whereLOCAL;
17234    }
17235  else if (sa & FFESYMBOL_attrsTYPE)
17236    {
17237      assert (!(sa & (FFESYMBOL_attrsARRAY
17238		      | FFESYMBOL_attrsDUMMY
17239		      | FFESYMBOL_attrsEXTERNAL
17240		      | FFESYMBOL_attrsSFARG)));	/* Handled above. */
17241      assert (!(sa & ~(FFESYMBOL_attrsTYPE
17242		       | FFESYMBOL_attrsADJUSTABLE
17243		       | FFESYMBOL_attrsANYLEN
17244		       | FFESYMBOL_attrsARRAY
17245		       | FFESYMBOL_attrsDUMMY
17246		       | FFESYMBOL_attrsEXTERNAL
17247		       | FFESYMBOL_attrsSFARG)));
17248
17249      if (sa & FFESYMBOL_attrsANYLEN)
17250	ns = FFESYMBOL_stateNONE;
17251      else
17252	{
17253	  kind = FFEINFO_kindENTITY;
17254	  where = FFEINFO_whereLOCAL;
17255	}
17256    }
17257  else if (sa == FFESYMBOL_attrsetNONE)
17258    {
17259      /* New state is left empty because there isn't any state flag to
17260	 set for this case, and it's UNDERSTOOD after all.  */
17261      assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
17262      kind = FFEINFO_kindENTITY;
17263      where = FFEINFO_whereLOCAL;
17264      needs_type = TRUE;
17265    }
17266  else
17267    ns = FFESYMBOL_stateNONE;	/* Error. */
17268
17269  /* Now see what we've got for a new object: NONE means a new error cropped
17270     up; ANY means an old error to be ignored; otherwise, everything's ok,
17271     update the object (symbol) and continue on. */
17272
17273  if (ns == FFESYMBOL_stateNONE)
17274    ffesymbol_error (s, t);
17275  else if (!(na & FFESYMBOL_attrsANY))
17276    {
17277      ffesymbol_signal_change (s);	/* May need to back up to previous
17278					   version. */
17279      if (needs_type && !ffeimplic_establish_symbol (s))
17280	{
17281	  ffesymbol_error (s, t);
17282	  return s;
17283	}
17284      ffesymbol_set_info (s,
17285			  ffeinfo_new (ffesymbol_basictype (s),
17286				       ffesymbol_kindtype (s),
17287				       ffesymbol_rank (s),
17288				       kind,
17289				       where,
17290				       ffesymbol_size (s)));
17291      ffesymbol_set_attrs (s, na);
17292      ffesymbol_set_state (s, ns);
17293      s = ffecom_sym_learned (s);
17294      ffesymbol_reference (s, t, FALSE);
17295      ffesymbol_signal_unreported (s);	/* For debugging purposes. */
17296    }
17297
17298  return s;
17299}
17300
17301/* Have FOO in DIMENSION XYZ(FOO) or any array declarator containing
17302   a reference to FOO.  */
17303
17304static ffesymbol
17305ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t)
17306{
17307  ffesymbolAttrs sa;
17308  ffesymbolAttrs na;
17309  ffeinfoKind kind;
17310  ffeinfoWhere where;
17311
17312  na = sa = ffesymbol_attrs (s);
17313  kind = FFEINFO_kindENTITY;
17314  where = ffesymbol_where (s);
17315
17316  /* Figure out what kind of object we've got based on previous declarations
17317     of or references to the object. */
17318
17319  if (!(sa & ~(FFESYMBOL_attrsADJUSTS
17320	       | FFESYMBOL_attrsCOMMON
17321	       | FFESYMBOL_attrsDUMMY
17322	       | FFESYMBOL_attrsEQUIV
17323	       | FFESYMBOL_attrsINIT
17324	       | FFESYMBOL_attrsNAMELIST
17325	       | FFESYMBOL_attrsSFARG
17326	       | FFESYMBOL_attrsTYPE)))
17327    na = sa | FFESYMBOL_attrsADJUSTS;
17328  else
17329    na = FFESYMBOL_attrsetNONE;
17330
17331  /* Since this symbol definitely is going into an expression (the
17332     dimension-list for some dummy array, presumably), figure out WHERE if
17333     possible.  */
17334
17335  if (where == FFEINFO_whereNONE)
17336    {
17337      if (na & (FFESYMBOL_attrsCOMMON
17338		| FFESYMBOL_attrsEQUIV
17339		| FFESYMBOL_attrsINIT
17340		| FFESYMBOL_attrsNAMELIST))
17341	where = FFEINFO_whereCOMMON;
17342      else if (na & FFESYMBOL_attrsDUMMY)
17343	where = FFEINFO_whereDUMMY;
17344    }
17345
17346  /* Now see what we've got for a new object: NONE means a new error cropped
17347     up; ANY means an old error to be ignored; otherwise, everything's ok,
17348     update the object (symbol) and continue on. */
17349
17350  if (na == FFESYMBOL_attrsetNONE)
17351    ffesymbol_error (s, t);
17352  else if (!(na & FFESYMBOL_attrsANY))
17353    {
17354      ffesymbol_signal_change (s);	/* May need to back up to previous
17355					   version. */
17356      if (!ffeimplic_establish_symbol (s))
17357	{
17358	  ffesymbol_error (s, t);
17359	  return s;
17360	}
17361      ffesymbol_set_info (s,
17362			  ffeinfo_new (ffesymbol_basictype (s),
17363				       ffesymbol_kindtype (s),
17364				       ffesymbol_rank (s),
17365				       kind,	/* Always ENTITY. */
17366				       where,	/* NONE, COMMON, or DUMMY. */
17367				       ffesymbol_size (s)));
17368      ffesymbol_set_attrs (s, na);
17369      ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
17370      ffesymbol_resolve_intrin (s);
17371      ffesymbol_signal_unreported (s);	/* For debugging purposes. */
17372    }
17373
17374  return s;
17375}
17376
17377/* Have FOO in XYZ = ...FOO....  Does not include cases like FOO in
17378   XYZ = BAR(FOO), as such cases are handled elsewhere.  */
17379
17380static ffesymbol
17381ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t)
17382{
17383  ffesymbolAttrs sa;
17384  ffesymbolAttrs na;
17385  ffeinfoKind kind;
17386  ffeinfoWhere where;
17387  bool error = FALSE;
17388
17389  assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
17390	  || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
17391
17392  na = sa = ffesymbol_attrs (s);
17393
17394  assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17395		   | FFESYMBOL_attrsADJUSTABLE
17396		   | FFESYMBOL_attrsANYLEN
17397		   | FFESYMBOL_attrsARRAY
17398		   | FFESYMBOL_attrsDUMMY
17399		   | FFESYMBOL_attrsEXTERNAL
17400		   | FFESYMBOL_attrsSFARG
17401		   | FFESYMBOL_attrsTYPE)));
17402
17403  kind = ffesymbol_kind (s);
17404  where = ffesymbol_where (s);
17405
17406  /* Figure out what kind of object we've got based on previous declarations
17407     of or references to the object. */
17408
17409  if (sa & FFESYMBOL_attrsEXTERNAL)
17410    {
17411      assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17412		       | FFESYMBOL_attrsDUMMY
17413		       | FFESYMBOL_attrsEXTERNAL
17414		       | FFESYMBOL_attrsTYPE)));
17415
17416      error = TRUE;
17417    }
17418  else if (sa & FFESYMBOL_attrsDUMMY)
17419    {
17420      assert (!(sa & FFESYMBOL_attrsEXTERNAL));	/* Handled above. */
17421      assert (!(sa & ~(FFESYMBOL_attrsDUMMY
17422		       | FFESYMBOL_attrsEXTERNAL
17423		       | FFESYMBOL_attrsTYPE)));
17424
17425      kind = FFEINFO_kindENTITY;
17426    }
17427  else if (sa & FFESYMBOL_attrsARRAY)
17428    {
17429      assert (!(sa & ~(FFESYMBOL_attrsARRAY
17430		       | FFESYMBOL_attrsADJUSTABLE
17431		       | FFESYMBOL_attrsTYPE)));
17432
17433      where = FFEINFO_whereLOCAL;
17434    }
17435  else if (sa & FFESYMBOL_attrsSFARG)
17436    {
17437      assert (!(sa & ~(FFESYMBOL_attrsSFARG
17438		       | FFESYMBOL_attrsTYPE)));
17439
17440      where = FFEINFO_whereLOCAL;
17441    }
17442  else if (sa & FFESYMBOL_attrsTYPE)
17443    {
17444      assert (!(sa & (FFESYMBOL_attrsARRAY
17445		      | FFESYMBOL_attrsDUMMY
17446		      | FFESYMBOL_attrsEXTERNAL
17447		      | FFESYMBOL_attrsSFARG)));	/* Handled above. */
17448      assert (!(sa & ~(FFESYMBOL_attrsTYPE
17449		       | FFESYMBOL_attrsADJUSTABLE
17450		       | FFESYMBOL_attrsANYLEN
17451		       | FFESYMBOL_attrsARRAY
17452		       | FFESYMBOL_attrsDUMMY
17453		       | FFESYMBOL_attrsEXTERNAL
17454		       | FFESYMBOL_attrsSFARG)));
17455
17456      if (sa & FFESYMBOL_attrsANYLEN)
17457	error = TRUE;
17458      else
17459	{
17460	  kind = FFEINFO_kindENTITY;
17461	  where = FFEINFO_whereLOCAL;
17462	}
17463    }
17464  else if (sa == FFESYMBOL_attrsetNONE)
17465    {
17466      assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
17467      kind = FFEINFO_kindENTITY;
17468      where = FFEINFO_whereLOCAL;
17469    }
17470  else
17471    error = TRUE;
17472
17473  /* Now see what we've got for a new object: NONE means a new error cropped
17474     up; ANY means an old error to be ignored; otherwise, everything's ok,
17475     update the object (symbol) and continue on. */
17476
17477  if (error)
17478    ffesymbol_error (s, t);
17479  else if (!(na & FFESYMBOL_attrsANY))
17480    {
17481      ffesymbol_signal_change (s);	/* May need to back up to previous
17482					   version. */
17483      if (!ffeimplic_establish_symbol (s))
17484	{
17485	  ffesymbol_error (s, t);
17486	  return s;
17487	}
17488      ffesymbol_set_info (s,
17489			  ffeinfo_new (ffesymbol_basictype (s),
17490				       ffesymbol_kindtype (s),
17491				       ffesymbol_rank (s),
17492				       kind,	/* ENTITY. */
17493				       where,	/* LOCAL. */
17494				       ffesymbol_size (s)));
17495      ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17496      ffesymbol_resolve_intrin (s);
17497      s = ffecom_sym_learned (s);
17498      ffesymbol_signal_unreported (s);	/* For debugging purposes. */
17499    }
17500
17501  return s;
17502}
17503
17504/* ffeexpr_declare_parenthesized_ -- ffesymbol wrapper for NAME(...) operand
17505
17506   ffelexToken t;
17507   bool maybe_intrin;
17508   ffeexprParenType_ paren_type;
17509   ffesymbol s;
17510   s = ffeexpr_declare_parenthesized_ (t, maybe_intrin, &paren_type);
17511
17512   Just like ffesymbol_declare_local, except performs any implicit info
17513   assignment necessary, and it returns the type of the parenthesized list
17514   (list of function args, list of array args, or substring spec).  */
17515
17516static ffesymbol
17517ffeexpr_declare_parenthesized_ (ffelexToken t, bool maybe_intrin,
17518				ffeexprParenType_ *paren_type)
17519{
17520  ffesymbol s;
17521  ffesymbolState st;		/* Effective state. */
17522  ffeinfoKind k;
17523  bool bad;
17524
17525  if (maybe_intrin && ffesrc_check_symbol ())
17526    {				/* Knock off some easy cases. */
17527      switch (ffeexpr_stack_->context)
17528	{
17529	case FFEEXPR_contextSUBROUTINEREF:
17530	case FFEEXPR_contextDATA:
17531	case FFEEXPR_contextDATAIMPDOINDEX_:
17532	case FFEEXPR_contextSFUNCDEF:
17533	case FFEEXPR_contextSFUNCDEFINDEX_:
17534	case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17535	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17536	case FFEEXPR_contextLET:
17537	case FFEEXPR_contextPAREN_:
17538	case FFEEXPR_contextACTUALARGEXPR_:
17539	case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17540	case FFEEXPR_contextIOLIST:
17541	case FFEEXPR_contextIOLISTDF:
17542	case FFEEXPR_contextDO:
17543	case FFEEXPR_contextDOWHILE:
17544	case FFEEXPR_contextACTUALARG_:
17545	case FFEEXPR_contextCGOTO:
17546	case FFEEXPR_contextIF:
17547	case FFEEXPR_contextARITHIF:
17548	case FFEEXPR_contextFORMAT:
17549	case FFEEXPR_contextSTOP:
17550	case FFEEXPR_contextRETURN:
17551	case FFEEXPR_contextSELECTCASE:
17552	case FFEEXPR_contextCASE:
17553	case FFEEXPR_contextFILEASSOC:
17554	case FFEEXPR_contextFILEINT:
17555	case FFEEXPR_contextFILEDFINT:
17556	case FFEEXPR_contextFILELOG:
17557	case FFEEXPR_contextFILENUM:
17558	case FFEEXPR_contextFILENUMAMBIG:
17559	case FFEEXPR_contextFILECHAR:
17560	case FFEEXPR_contextFILENUMCHAR:
17561	case FFEEXPR_contextFILEDFCHAR:
17562	case FFEEXPR_contextFILEKEY:
17563	case FFEEXPR_contextFILEUNIT:
17564	case FFEEXPR_contextFILEUNIT_DF:
17565	case FFEEXPR_contextFILEUNITAMBIG:
17566	case FFEEXPR_contextFILEFORMAT:
17567	case FFEEXPR_contextFILENAMELIST:
17568	case FFEEXPR_contextFILEVXTCODE:
17569	case FFEEXPR_contextINDEX_:
17570	case FFEEXPR_contextIMPDOITEM_:
17571	case FFEEXPR_contextIMPDOITEMDF_:
17572	case FFEEXPR_contextIMPDOCTRL_:
17573	case FFEEXPR_contextDATAIMPDOCTRL_:
17574	case FFEEXPR_contextCHARACTERSIZE:
17575	case FFEEXPR_contextPARAMETER:
17576	case FFEEXPR_contextDIMLIST:
17577	case FFEEXPR_contextDIMLISTCOMMON:
17578	case FFEEXPR_contextKINDTYPE:
17579	case FFEEXPR_contextINITVAL:
17580	case FFEEXPR_contextEQVINDEX_:
17581	  break;		/* These could be intrinsic invocations. */
17582
17583	case FFEEXPR_contextAGOTO:
17584	case FFEEXPR_contextFILEFORMATNML:
17585	case FFEEXPR_contextALLOCATE:
17586	case FFEEXPR_contextDEALLOCATE:
17587	case FFEEXPR_contextHEAPSTAT:
17588	case FFEEXPR_contextNULLIFY:
17589	case FFEEXPR_contextINCLUDE:
17590	case FFEEXPR_contextDATAIMPDOITEM_:
17591	case FFEEXPR_contextLOC_:
17592	case FFEEXPR_contextINDEXORACTUALARG_:
17593	case FFEEXPR_contextSFUNCDEFACTUALARG_:
17594	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
17595	case FFEEXPR_contextPARENFILENUM_:
17596	case FFEEXPR_contextPARENFILEUNIT_:
17597	  maybe_intrin = FALSE;
17598	  break;		/* Can't be intrinsic invocation. */
17599
17600	default:
17601	  assert ("blah! blah! waaauuggh!" == NULL);
17602	  break;
17603	}
17604    }
17605
17606  s = ffesymbol_declare_local (t, maybe_intrin);
17607
17608  switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17609    /* Special-case these since they can involve a different concept
17610       of "state" (in the stmtfunc name space).  */
17611    {
17612    case FFEEXPR_contextDATAIMPDOINDEX_:
17613    case FFEEXPR_contextDATAIMPDOCTRL_:
17614      if (ffeexpr_context_outer_ (ffeexpr_stack_)
17615	  == FFEEXPR_contextDATAIMPDOINDEX_)
17616	s = ffeexpr_sym_impdoitem_ (s, t);
17617      else
17618	if (ffeexpr_stack_->is_rhs)
17619	  s = ffeexpr_sym_impdoitem_ (s, t);
17620	else
17621	  s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
17622      if (ffesymbol_kind (s) != FFEINFO_kindANY)
17623	ffesymbol_error (s, t);
17624      return s;
17625
17626    default:
17627      break;
17628    }
17629
17630  switch ((ffesymbol_sfdummyparent (s) == NULL)
17631	  ? ffesymbol_state (s)
17632	  : FFESYMBOL_stateUNDERSTOOD)
17633    {
17634    case FFESYMBOL_stateNONE:	/* Before first exec, not seen in expr
17635				   context. */
17636      if (!ffest_seen_first_exec ())
17637	goto seen;		/* :::::::::::::::::::: */
17638      /* Fall through. */
17639    case FFESYMBOL_stateUNCERTAIN:	/* Unseen since first exec. */
17640      switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17641	{
17642	case FFEEXPR_contextSUBROUTINEREF:
17643	  s = ffeexpr_sym_lhs_call_ (s, t);	/* "CALL FOO"=="CALL
17644						   FOO(...)". */
17645	  break;
17646
17647	case FFEEXPR_contextDATA:
17648	  if (ffeexpr_stack_->is_rhs)
17649	    s = ffeexpr_sym_rhs_let_ (s, t);
17650	  else
17651	    s = ffeexpr_sym_lhs_data_ (s, t);
17652	  break;
17653
17654	case FFEEXPR_contextDATAIMPDOITEM_:
17655	  s = ffeexpr_sym_lhs_data_ (s, t);
17656	  break;
17657
17658	case FFEEXPR_contextSFUNCDEF:
17659	case FFEEXPR_contextSFUNCDEFINDEX_:
17660	case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17661	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17662	  s = ffecom_sym_exec_transition (s);
17663	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17664	    goto understood;	/* :::::::::::::::::::: */
17665	  /* Fall through. */
17666	case FFEEXPR_contextLET:
17667	case FFEEXPR_contextPAREN_:
17668	case FFEEXPR_contextACTUALARGEXPR_:
17669	case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17670	case FFEEXPR_contextIOLIST:
17671	case FFEEXPR_contextIOLISTDF:
17672	case FFEEXPR_contextDO:
17673	case FFEEXPR_contextDOWHILE:
17674	case FFEEXPR_contextACTUALARG_:
17675	case FFEEXPR_contextCGOTO:
17676	case FFEEXPR_contextIF:
17677	case FFEEXPR_contextARITHIF:
17678	case FFEEXPR_contextFORMAT:
17679	case FFEEXPR_contextSTOP:
17680	case FFEEXPR_contextRETURN:
17681	case FFEEXPR_contextSELECTCASE:
17682	case FFEEXPR_contextCASE:
17683	case FFEEXPR_contextFILEASSOC:
17684	case FFEEXPR_contextFILEINT:
17685	case FFEEXPR_contextFILEDFINT:
17686	case FFEEXPR_contextFILELOG:
17687	case FFEEXPR_contextFILENUM:
17688	case FFEEXPR_contextFILENUMAMBIG:
17689	case FFEEXPR_contextFILECHAR:
17690	case FFEEXPR_contextFILENUMCHAR:
17691	case FFEEXPR_contextFILEDFCHAR:
17692	case FFEEXPR_contextFILEKEY:
17693	case FFEEXPR_contextFILEUNIT:
17694	case FFEEXPR_contextFILEUNIT_DF:
17695	case FFEEXPR_contextFILEUNITAMBIG:
17696	case FFEEXPR_contextFILEFORMAT:
17697	case FFEEXPR_contextFILENAMELIST:
17698	case FFEEXPR_contextFILEVXTCODE:
17699	case FFEEXPR_contextINDEX_:
17700	case FFEEXPR_contextIMPDOITEM_:
17701	case FFEEXPR_contextIMPDOITEMDF_:
17702	case FFEEXPR_contextIMPDOCTRL_:
17703	case FFEEXPR_contextLOC_:
17704	  if (ffeexpr_stack_->is_rhs)
17705	    s = ffeexpr_paren_rhs_let_ (s, t);
17706	  else
17707	    s = ffeexpr_paren_lhs_let_ (s, t);
17708	  break;
17709
17710	case FFEEXPR_contextASSIGN:
17711	case FFEEXPR_contextAGOTO:
17712	case FFEEXPR_contextCHARACTERSIZE:
17713	case FFEEXPR_contextEQUIVALENCE:
17714	case FFEEXPR_contextINCLUDE:
17715	case FFEEXPR_contextPARAMETER:
17716	case FFEEXPR_contextDIMLIST:
17717	case FFEEXPR_contextDIMLISTCOMMON:
17718	case FFEEXPR_contextKINDTYPE:
17719	case FFEEXPR_contextINITVAL:
17720	case FFEEXPR_contextEQVINDEX_:
17721	  break;		/* Will turn into errors below. */
17722
17723	default:
17724	  ffesymbol_error (s, t);
17725	  break;
17726	}
17727      /* Fall through. */
17728    case FFESYMBOL_stateUNDERSTOOD:	/* Nothing much more to learn. */
17729    understood:		/* :::::::::::::::::::: */
17730
17731      /* State might have changed, update it.  */
17732      st = ((ffesymbol_sfdummyparent (s) == NULL)
17733	    ? ffesymbol_state (s)
17734	    : FFESYMBOL_stateUNDERSTOOD);
17735
17736      k = ffesymbol_kind (s);
17737      switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17738	{
17739	case FFEEXPR_contextSUBROUTINEREF:
17740	  bad = ((k != FFEINFO_kindSUBROUTINE)
17741		 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
17742		     || (k != FFEINFO_kindNONE)));
17743	  break;
17744
17745	case FFEEXPR_contextDATA:
17746	  if (ffeexpr_stack_->is_rhs)
17747	    bad = (k != FFEINFO_kindENTITY)
17748	      || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
17749	  else
17750	    bad = (k != FFEINFO_kindENTITY)
17751	      || ((ffesymbol_where (s) != FFEINFO_whereNONE)
17752		  && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
17753		  && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
17754	  break;
17755
17756	case FFEEXPR_contextDATAIMPDOITEM_:
17757	  bad = (k != FFEINFO_kindENTITY) || (ffesymbol_rank (s) == 0)
17758	    || ((ffesymbol_where (s) != FFEINFO_whereNONE)
17759		&& (ffesymbol_where (s) != FFEINFO_whereLOCAL)
17760		&& (ffesymbol_where (s) != FFEINFO_whereCOMMON));
17761	  break;
17762
17763	case FFEEXPR_contextSFUNCDEF:
17764	case FFEEXPR_contextSFUNCDEFINDEX_:
17765	case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17766	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17767	case FFEEXPR_contextLET:
17768	case FFEEXPR_contextPAREN_:
17769	case FFEEXPR_contextACTUALARGEXPR_:
17770	case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17771	case FFEEXPR_contextIOLIST:
17772	case FFEEXPR_contextIOLISTDF:
17773	case FFEEXPR_contextDO:
17774	case FFEEXPR_contextDOWHILE:
17775	case FFEEXPR_contextACTUALARG_:
17776	case FFEEXPR_contextCGOTO:
17777	case FFEEXPR_contextIF:
17778	case FFEEXPR_contextARITHIF:
17779	case FFEEXPR_contextFORMAT:
17780	case FFEEXPR_contextSTOP:
17781	case FFEEXPR_contextRETURN:
17782	case FFEEXPR_contextSELECTCASE:
17783	case FFEEXPR_contextCASE:
17784	case FFEEXPR_contextFILEASSOC:
17785	case FFEEXPR_contextFILEINT:
17786	case FFEEXPR_contextFILEDFINT:
17787	case FFEEXPR_contextFILELOG:
17788	case FFEEXPR_contextFILENUM:
17789	case FFEEXPR_contextFILENUMAMBIG:
17790	case FFEEXPR_contextFILECHAR:
17791	case FFEEXPR_contextFILENUMCHAR:
17792	case FFEEXPR_contextFILEDFCHAR:
17793	case FFEEXPR_contextFILEKEY:
17794	case FFEEXPR_contextFILEUNIT:
17795	case FFEEXPR_contextFILEUNIT_DF:
17796	case FFEEXPR_contextFILEUNITAMBIG:
17797	case FFEEXPR_contextFILEFORMAT:
17798	case FFEEXPR_contextFILENAMELIST:
17799	case FFEEXPR_contextFILEVXTCODE:
17800	case FFEEXPR_contextINDEX_:
17801	case FFEEXPR_contextIMPDOITEM_:
17802	case FFEEXPR_contextIMPDOITEMDF_:
17803	case FFEEXPR_contextIMPDOCTRL_:
17804	case FFEEXPR_contextLOC_:
17805	  bad = FALSE;		/* Let paren-switch handle the cases. */
17806	  break;
17807
17808	case FFEEXPR_contextASSIGN:
17809	case FFEEXPR_contextAGOTO:
17810	case FFEEXPR_contextCHARACTERSIZE:
17811	case FFEEXPR_contextEQUIVALENCE:
17812	case FFEEXPR_contextPARAMETER:
17813	case FFEEXPR_contextDIMLIST:
17814	case FFEEXPR_contextDIMLISTCOMMON:
17815	case FFEEXPR_contextKINDTYPE:
17816	case FFEEXPR_contextINITVAL:
17817	case FFEEXPR_contextEQVINDEX_:
17818	  bad = (k != FFEINFO_kindENTITY)
17819	    || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
17820	  break;
17821
17822	case FFEEXPR_contextINCLUDE:
17823	  bad = TRUE;
17824	  break;
17825
17826	default:
17827	  bad = TRUE;
17828	  break;
17829	}
17830
17831      switch (bad ? FFEINFO_kindANY : k)
17832	{
17833	case FFEINFO_kindNONE:	/* Case "CHARACTER X,Y; Y=X(?". */
17834	  if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
17835	    {
17836	      if (ffeexpr_context_outer_ (ffeexpr_stack_)
17837		  == FFEEXPR_contextSUBROUTINEREF)
17838		*paren_type = FFEEXPR_parentypeSUBROUTINE_;
17839	      else
17840		*paren_type = FFEEXPR_parentypeFUNCTION_;
17841	      break;
17842	    }
17843	  if (st == FFESYMBOL_stateUNDERSTOOD)
17844	    {
17845	      bad = TRUE;
17846	      *paren_type = FFEEXPR_parentypeANY_;
17847	    }
17848	  else
17849	    *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
17850	  break;
17851
17852	case FFEINFO_kindFUNCTION:
17853	  *paren_type = FFEEXPR_parentypeFUNCTION_;
17854	  switch (ffesymbol_where (s))
17855	    {
17856	    case FFEINFO_whereLOCAL:
17857	      bad = TRUE;	/* Attempt to recurse! */
17858	      break;
17859
17860	    case FFEINFO_whereCONSTANT:
17861	      bad = ((ffesymbol_sfexpr (s) == NULL)
17862		     || (ffebld_op (ffesymbol_sfexpr (s))
17863			 == FFEBLD_opANY));	/* Attempt to recurse! */
17864	      break;
17865
17866	    default:
17867	      break;
17868	    }
17869	  break;
17870
17871	case FFEINFO_kindSUBROUTINE:
17872	  if ((ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
17873	      || (ffeexpr_stack_->previous != NULL))
17874	    {
17875	      bad = TRUE;
17876	      *paren_type = FFEEXPR_parentypeANY_;
17877	      break;
17878	    }
17879
17880	  *paren_type = FFEEXPR_parentypeSUBROUTINE_;
17881	  switch (ffesymbol_where (s))
17882	    {
17883	    case FFEINFO_whereLOCAL:
17884	    case FFEINFO_whereCONSTANT:
17885	      bad = TRUE;	/* Attempt to recurse! */
17886	      break;
17887
17888	    default:
17889	      break;
17890	    }
17891	  break;
17892
17893	case FFEINFO_kindENTITY:
17894	  if (ffesymbol_rank (s) == 0)
17895	    {
17896	      if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
17897		*paren_type = FFEEXPR_parentypeSUBSTRING_;
17898	      else
17899		{
17900		  bad = TRUE;
17901		  *paren_type = FFEEXPR_parentypeANY_;
17902		}
17903	    }
17904	  else
17905	    *paren_type = FFEEXPR_parentypeARRAY_;
17906	  break;
17907
17908	default:
17909	case FFEINFO_kindANY:
17910	  bad = TRUE;
17911	  *paren_type = FFEEXPR_parentypeANY_;
17912	  break;
17913	}
17914
17915      if (bad)
17916	{
17917	  if (k == FFEINFO_kindANY)
17918	    ffest_shutdown ();
17919	  else
17920	    ffesymbol_error (s, t);
17921	}
17922
17923      return s;
17924
17925    case FFESYMBOL_stateSEEN:	/* Seen but not yet in exec portion. */
17926    seen:			/* :::::::::::::::::::: */
17927      bad = TRUE;
17928      switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17929	{
17930	case FFEEXPR_contextPARAMETER:
17931	  if (ffeexpr_stack_->is_rhs)
17932	    ffesymbol_error (s, t);
17933	  else
17934	    s = ffeexpr_sym_lhs_parameter_ (s, t);
17935	  break;
17936
17937	case FFEEXPR_contextDATA:
17938	  s = ffecom_sym_exec_transition (s);
17939	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17940	    goto understood;	/* :::::::::::::::::::: */
17941	  if (ffeexpr_stack_->is_rhs)
17942	    ffesymbol_error (s, t);
17943	  else
17944	    s = ffeexpr_sym_lhs_data_ (s, t);
17945	  goto understood;	/* :::::::::::::::::::: */
17946
17947	case FFEEXPR_contextDATAIMPDOITEM_:
17948	  s = ffecom_sym_exec_transition (s);
17949	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17950	    goto understood;	/* :::::::::::::::::::: */
17951	  s = ffeexpr_sym_lhs_data_ (s, t);
17952	  goto understood;	/* :::::::::::::::::::: */
17953
17954	case FFEEXPR_contextEQUIVALENCE:
17955	  s = ffeexpr_sym_lhs_equivalence_ (s, t);
17956	  bad = FALSE;
17957	  break;
17958
17959	case FFEEXPR_contextDIMLIST:
17960	  s = ffeexpr_sym_rhs_dimlist_ (s, t);
17961	  break;
17962
17963	case FFEEXPR_contextCHARACTERSIZE:
17964	case FFEEXPR_contextKINDTYPE:
17965	case FFEEXPR_contextDIMLISTCOMMON:
17966	case FFEEXPR_contextINITVAL:
17967	case FFEEXPR_contextEQVINDEX_:
17968	  break;
17969
17970	case FFEEXPR_contextINCLUDE:
17971	  break;
17972
17973	case FFEEXPR_contextINDEX_:
17974	case FFEEXPR_contextACTUALARGEXPR_:
17975	case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17976	case FFEEXPR_contextSFUNCDEF:
17977	case FFEEXPR_contextSFUNCDEFINDEX_:
17978	case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17979	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17980	  assert (ffeexpr_stack_->is_rhs);
17981	  s = ffecom_sym_exec_transition (s);
17982	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17983	    goto understood;	/* :::::::::::::::::::: */
17984	  s = ffeexpr_paren_rhs_let_ (s, t);
17985	  goto understood;	/* :::::::::::::::::::: */
17986
17987	default:
17988	  break;
17989	}
17990      k = ffesymbol_kind (s);
17991      switch (bad ? FFEINFO_kindANY : k)
17992	{
17993	case FFEINFO_kindNONE:	/* Case "CHARACTER X,Y; Y=X(?". */
17994	  *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
17995	  break;
17996
17997	case FFEINFO_kindFUNCTION:
17998	  *paren_type = FFEEXPR_parentypeFUNCTION_;
17999	  switch (ffesymbol_where (s))
18000	    {
18001	    case FFEINFO_whereLOCAL:
18002	      bad = TRUE;	/* Attempt to recurse! */
18003	      break;
18004
18005	    case FFEINFO_whereCONSTANT:
18006	      bad = ((ffesymbol_sfexpr (s) == NULL)
18007		     || (ffebld_op (ffesymbol_sfexpr (s))
18008			 == FFEBLD_opANY));	/* Attempt to recurse! */
18009	      break;
18010
18011	    default:
18012	      break;
18013	    }
18014	  break;
18015
18016	case FFEINFO_kindSUBROUTINE:
18017	  *paren_type = FFEEXPR_parentypeANY_;
18018	  bad = TRUE;		/* Cannot possibly be in
18019				   contextSUBROUTINEREF. */
18020	  break;
18021
18022	case FFEINFO_kindENTITY:
18023	  if (ffesymbol_rank (s) == 0)
18024	    {
18025	      if (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE)
18026		*paren_type = FFEEXPR_parentypeEQUIVALENCE_;
18027	      else if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
18028		*paren_type = FFEEXPR_parentypeSUBSTRING_;
18029	      else
18030		{
18031		  bad = TRUE;
18032		  *paren_type = FFEEXPR_parentypeANY_;
18033		}
18034	    }
18035	  else
18036	    *paren_type = FFEEXPR_parentypeARRAY_;
18037	  break;
18038
18039	default:
18040	case FFEINFO_kindANY:
18041	  bad = TRUE;
18042	  *paren_type = FFEEXPR_parentypeANY_;
18043	  break;
18044	}
18045
18046      if (bad)
18047	{
18048	  if (k == FFEINFO_kindANY)
18049	    ffest_shutdown ();
18050	  else
18051	    ffesymbol_error (s, t);
18052	}
18053
18054      return s;
18055
18056    default:
18057      assert ("bad symbol state" == NULL);
18058      return NULL;
18059    }
18060}
18061
18062/* Have FOO in XYZ = ...FOO(...)....  Executable context only.  */
18063
18064static ffesymbol
18065ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t)
18066{
18067  ffesymbolAttrs sa;
18068  ffesymbolAttrs na;
18069  ffeinfoKind kind;
18070  ffeinfoWhere where;
18071  ffeintrinGen gen;
18072  ffeintrinSpec spec;
18073  ffeintrinImp imp;
18074  bool maybe_ambig = FALSE;
18075  bool error = FALSE;
18076
18077  assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
18078	  || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
18079
18080  na = sa = ffesymbol_attrs (s);
18081
18082  assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
18083		   | FFESYMBOL_attrsADJUSTABLE
18084		   | FFESYMBOL_attrsANYLEN
18085		   | FFESYMBOL_attrsARRAY
18086		   | FFESYMBOL_attrsDUMMY
18087		   | FFESYMBOL_attrsEXTERNAL
18088		   | FFESYMBOL_attrsSFARG
18089		   | FFESYMBOL_attrsTYPE)));
18090
18091  kind = ffesymbol_kind (s);
18092  where = ffesymbol_where (s);
18093
18094  /* Figure out what kind of object we've got based on previous declarations
18095     of or references to the object. */
18096
18097  if (sa & FFESYMBOL_attrsEXTERNAL)
18098    {
18099      assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
18100		       | FFESYMBOL_attrsDUMMY
18101		       | FFESYMBOL_attrsEXTERNAL
18102		       | FFESYMBOL_attrsTYPE)));
18103
18104      if (sa & FFESYMBOL_attrsTYPE)
18105	where = FFEINFO_whereGLOBAL;
18106      else
18107	/* Not TYPE. */
18108	{
18109	  kind = FFEINFO_kindFUNCTION;
18110
18111	  if (sa & FFESYMBOL_attrsDUMMY)
18112	    ;			/* Not TYPE. */
18113	  else if (sa & FFESYMBOL_attrsACTUALARG)
18114	    ;			/* Not DUMMY or TYPE. */
18115	  else			/* Not ACTUALARG, DUMMY, or TYPE. */
18116	    where = FFEINFO_whereGLOBAL;
18117	}
18118    }
18119  else if (sa & FFESYMBOL_attrsDUMMY)
18120    {
18121      assert (!(sa & FFESYMBOL_attrsEXTERNAL));	/* Handled above. */
18122      assert (!(sa & ~(FFESYMBOL_attrsDUMMY
18123		       | FFESYMBOL_attrsEXTERNAL
18124		       | FFESYMBOL_attrsTYPE)));
18125
18126      kind = FFEINFO_kindFUNCTION;
18127      maybe_ambig = TRUE;	/* If basictypeCHARACTER, can't be sure; kind
18128				   could be ENTITY w/substring ref. */
18129    }
18130  else if (sa & FFESYMBOL_attrsARRAY)
18131    {
18132      assert (!(sa & ~(FFESYMBOL_attrsARRAY
18133		       | FFESYMBOL_attrsADJUSTABLE
18134		       | FFESYMBOL_attrsTYPE)));
18135
18136      where = FFEINFO_whereLOCAL;
18137    }
18138  else if (sa & FFESYMBOL_attrsSFARG)
18139    {
18140      assert (!(sa & ~(FFESYMBOL_attrsSFARG
18141		       | FFESYMBOL_attrsTYPE)));
18142
18143      where = FFEINFO_whereLOCAL;	/* Actually an error, but at least we
18144					   know it's a local var. */
18145    }
18146  else if (sa & FFESYMBOL_attrsTYPE)
18147    {
18148      assert (!(sa & (FFESYMBOL_attrsARRAY
18149		      | FFESYMBOL_attrsDUMMY
18150		      | FFESYMBOL_attrsEXTERNAL
18151		      | FFESYMBOL_attrsSFARG)));	/* Handled above. */
18152      assert (!(sa & ~(FFESYMBOL_attrsTYPE
18153		       | FFESYMBOL_attrsADJUSTABLE
18154		       | FFESYMBOL_attrsANYLEN
18155		       | FFESYMBOL_attrsARRAY
18156		       | FFESYMBOL_attrsDUMMY
18157		       | FFESYMBOL_attrsEXTERNAL
18158		       | FFESYMBOL_attrsSFARG)));
18159
18160      if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
18161				  &gen, &spec, &imp))
18162	{
18163	  if (!(sa & FFESYMBOL_attrsANYLEN)
18164	      && (ffeimplic_peek_symbol_type (s, NULL)
18165		  == FFEINFO_basictypeCHARACTER))
18166	    return s;		/* Haven't learned anything yet. */
18167
18168	  ffesymbol_signal_change (s);	/* May need to back up to previous
18169					   version. */
18170	  ffesymbol_set_generic (s, gen);
18171	  ffesymbol_set_specific (s, spec);
18172	  ffesymbol_set_implementation (s, imp);
18173	  ffesymbol_set_info (s,
18174			      ffeinfo_new (ffesymbol_basictype (s),
18175					   ffesymbol_kindtype (s),
18176					   0,
18177					   FFEINFO_kindFUNCTION,
18178					   FFEINFO_whereINTRINSIC,
18179					   ffesymbol_size (s)));
18180	  ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18181	  ffesymbol_resolve_intrin (s);
18182	  ffesymbol_reference (s, t, FALSE);
18183	  s = ffecom_sym_learned (s);
18184	  ffesymbol_signal_unreported (s);	/* For debugging purposes. */
18185
18186	  return s;
18187	}
18188      if (sa & FFESYMBOL_attrsANYLEN)
18189	error = TRUE;		/* Error, since the only way we can,
18190				   given CHARACTER*(*) FOO, accept
18191				   FOO(...) is for FOO to be a dummy
18192				   arg or constant, but it can't
18193				   become either now. */
18194      else if (sa & FFESYMBOL_attrsADJUSTABLE)
18195	{
18196	  kind = FFEINFO_kindENTITY;
18197	  where = FFEINFO_whereLOCAL;
18198	}
18199      else
18200	{
18201	  kind = FFEINFO_kindFUNCTION;
18202	  where = FFEINFO_whereGLOBAL;
18203	  maybe_ambig = TRUE;	/* If basictypeCHARACTER, can't be sure;
18204				   could be ENTITY/LOCAL w/substring ref. */
18205	}
18206    }
18207  else if (sa == FFESYMBOL_attrsetNONE)
18208    {
18209      assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
18210
18211      if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
18212				  &gen, &spec, &imp))
18213	{
18214	  if (ffeimplic_peek_symbol_type (s, NULL)
18215	      == FFEINFO_basictypeCHARACTER)
18216	    return s;		/* Haven't learned anything yet. */
18217
18218	  ffesymbol_signal_change (s);	/* May need to back up to previous
18219					   version. */
18220	  ffesymbol_set_generic (s, gen);
18221	  ffesymbol_set_specific (s, spec);
18222	  ffesymbol_set_implementation (s, imp);
18223	  ffesymbol_set_info (s,
18224			      ffeinfo_new (ffesymbol_basictype (s),
18225					   ffesymbol_kindtype (s),
18226					   0,
18227					   FFEINFO_kindFUNCTION,
18228					   FFEINFO_whereINTRINSIC,
18229					   ffesymbol_size (s)));
18230	  ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18231	  ffesymbol_resolve_intrin (s);
18232	  s = ffecom_sym_learned (s);
18233	  ffesymbol_reference (s, t, FALSE);
18234	  ffesymbol_signal_unreported (s);	/* For debugging purposes. */
18235	  return s;
18236	}
18237
18238      kind = FFEINFO_kindFUNCTION;
18239      where = FFEINFO_whereGLOBAL;
18240      maybe_ambig = TRUE;	/* If basictypeCHARACTER, can't be sure;
18241				   could be ENTITY/LOCAL w/substring ref. */
18242    }
18243  else
18244    error = TRUE;
18245
18246  /* Now see what we've got for a new object: NONE means a new error cropped
18247     up; ANY means an old error to be ignored; otherwise, everything's ok,
18248     update the object (symbol) and continue on. */
18249
18250  if (error)
18251    ffesymbol_error (s, t);
18252  else if (!(na & FFESYMBOL_attrsANY))
18253    {
18254      ffesymbol_signal_change (s);	/* May need to back up to previous
18255					   version. */
18256      if (!ffeimplic_establish_symbol (s))
18257	{
18258	  ffesymbol_error (s, t);
18259	  return s;
18260	}
18261      if (maybe_ambig
18262	  && (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
18263	return s;		/* Still not sure, let caller deal with it
18264				   based on (...). */
18265
18266      ffesymbol_set_info (s,
18267			  ffeinfo_new (ffesymbol_basictype (s),
18268				       ffesymbol_kindtype (s),
18269				       ffesymbol_rank (s),
18270				       kind,
18271				       where,
18272				       ffesymbol_size (s)));
18273      ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18274      ffesymbol_resolve_intrin (s);
18275      s = ffecom_sym_learned (s);
18276      ffesymbol_reference (s, t, FALSE);
18277      ffesymbol_signal_unreported (s);	/* For debugging purposes. */
18278    }
18279
18280  return s;
18281}
18282
18283/* ffeexpr_token_arguments_ -- OPEN_PAREN [expr COMMA]...expr
18284
18285   Return a pointer to this function to the lexer (ffelex), which will
18286   invoke it for the next token.
18287
18288   Handle expression (which might be null) and COMMA or CLOSE_PAREN.  */
18289
18290static ffelexHandler
18291ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr, ffelexToken t)
18292{
18293  ffeexprExpr_ procedure;
18294  ffebld reduced;
18295  ffeinfo info;
18296  ffeexprContext ctx;
18297  bool check_intrin = FALSE;	/* Set TRUE if intrinsic is REAL(Z) or AIMAG(Z). */
18298
18299  procedure = ffeexpr_stack_->exprstack;
18300  info = ffebld_info (procedure->u.operand);
18301
18302  /* Is there an expression to add?  If the expression is nil,
18303     it might still be an argument.  It is if:
18304
18305       -  The current token is comma, or
18306
18307       -  The -fugly-comma flag was specified *and* the procedure
18308          being invoked is external.
18309
18310     Otherwise, if neither of the above is the case, just
18311     ignore this (nil) expression.  */
18312
18313  if ((expr != NULL)
18314      || (ffelex_token_type (t) == FFELEX_typeCOMMA)
18315      || (ffe_is_ugly_comma ()
18316	  && (ffeinfo_where (info) == FFEINFO_whereGLOBAL)))
18317    {
18318      /* This expression, even if nil, is apparently intended as an argument.  */
18319
18320      /* Internal procedure (CONTAINS, or statement function)?  */
18321
18322      if (ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18323	{
18324	  if ((expr == NULL)
18325	      && ffebad_start (FFEBAD_NULL_ARGUMENT))
18326	    {
18327	      ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18328			   ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18329	      ffebad_here (1, ffelex_token_where_line (t),
18330			   ffelex_token_where_column (t));
18331	      ffebad_finish ();
18332	    }
18333
18334	  if (expr == NULL)
18335	    ;
18336	  else
18337	    {
18338	      if (ffeexpr_stack_->next_dummy == NULL)
18339		{			/* Report later which was the first extra argument. */
18340		  if (ffeexpr_stack_->tokens[1] == NULL)
18341		    {
18342		      ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
18343		      ffeexpr_stack_->num_args = 0;
18344		    }
18345		  ++ffeexpr_stack_->num_args;	/* Count # of extra arguments. */
18346		}
18347	      else
18348		{
18349		  if ((ffeinfo_rank (ffebld_info (expr)) != 0)
18350		      && ffebad_start (FFEBAD_ARRAY_AS_SFARG))
18351		    {
18352		      ffebad_here (0,
18353				   ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18354				   ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18355		      ffebad_here (1, ffelex_token_where_line (ft),
18356				   ffelex_token_where_column (ft));
18357		      ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent
18358						     (ffebld_symter (ffebld_head
18359								     (ffeexpr_stack_->next_dummy)))));
18360		      ffebad_finish ();
18361		    }
18362		  else
18363		    {
18364		      expr = ffeexpr_convert_expr (expr, ft,
18365						   ffebld_head (ffeexpr_stack_->next_dummy),
18366						   ffeexpr_stack_->tokens[0],
18367						   FFEEXPR_contextLET);
18368		      ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18369		    }
18370		  --ffeexpr_stack_->num_args;	/* Count down # of args. */
18371		  ffeexpr_stack_->next_dummy
18372		    = ffebld_trail (ffeexpr_stack_->next_dummy);
18373		}
18374	    }
18375	}
18376      else
18377	{
18378	  if ((expr == NULL)
18379	      && ffe_is_pedantic ()
18380	      && ffebad_start (FFEBAD_NULL_ARGUMENT_W))
18381	    {
18382	      ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18383			   ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18384	      ffebad_here (1, ffelex_token_where_line (t),
18385			   ffelex_token_where_column (t));
18386	      ffebad_finish ();
18387	    }
18388	  ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18389	}
18390    }
18391
18392  switch (ffelex_token_type (t))
18393    {
18394    case FFELEX_typeCOMMA:
18395      switch (ffeexpr_context_outer_ (ffeexpr_stack_))
18396	{
18397	case FFEEXPR_contextSFUNCDEF:
18398	case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
18399	case FFEEXPR_contextSFUNCDEFINDEX_:
18400	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
18401	  ctx = FFEEXPR_contextSFUNCDEFACTUALARG_;
18402	  break;
18403
18404	case FFEEXPR_contextSFUNCDEFACTUALARG_:
18405	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18406	  assert ("bad context" == NULL);
18407	  ctx = FFEEXPR_context;
18408	  break;
18409
18410	default:
18411	  ctx = FFEEXPR_contextACTUALARG_;
18412	  break;
18413	}
18414      return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18415					  ffeexpr_token_arguments_);
18416
18417    default:
18418      break;
18419    }
18420
18421  if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18422      && (ffeexpr_stack_->next_dummy != NULL))
18423    {				/* Too few arguments. */
18424      if (ffebad_start (FFEBAD_TOO_FEW_ARGUMENTS))
18425	{
18426	  char num[10];
18427
18428	  sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
18429
18430	  ffebad_here (0, ffelex_token_where_line (t),
18431		       ffelex_token_where_column (t));
18432	  ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18433		     ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18434	  ffebad_string (num);
18435	  ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent (ffebld_symter
18436			      (ffebld_head (ffeexpr_stack_->next_dummy)))));
18437	  ffebad_finish ();
18438	}
18439      for (;
18440	   ffeexpr_stack_->next_dummy != NULL;
18441	   ffeexpr_stack_->next_dummy
18442	   = ffebld_trail (ffeexpr_stack_->next_dummy))
18443	{
18444	  expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0));
18445	  ffebld_set_info (expr, ffeinfo_new_any ());
18446	  ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18447	}
18448    }
18449
18450  if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18451      && (ffeexpr_stack_->tokens[1] != NULL))
18452    {				/* Too many arguments to statement function. */
18453      if (ffebad_start (FFEBAD_TOO_MANY_ARGUMENTS))
18454	{
18455	  char num[10];
18456
18457	  sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
18458
18459	  ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
18460		     ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
18461	  ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18462		     ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18463	  ffebad_string (num);
18464	  ffebad_finish ();
18465	}
18466      ffelex_token_kill (ffeexpr_stack_->tokens[1]);
18467    }
18468  ffebld_end_list (&ffeexpr_stack_->bottom);
18469
18470  if (ffebld_op (procedure->u.operand) == FFEBLD_opANY)
18471    {
18472      reduced = ffebld_new_any ();
18473      ffebld_set_info (reduced, ffeinfo_new_any ());
18474    }
18475  else
18476    {
18477      if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
18478	reduced = ffebld_new_funcref (procedure->u.operand,
18479				      ffeexpr_stack_->expr);
18480      else
18481	reduced = ffebld_new_subrref (procedure->u.operand,
18482				      ffeexpr_stack_->expr);
18483      if (ffebld_symter_generic (procedure->u.operand) != FFEINTRIN_genNONE)
18484	ffeintrin_fulfill_generic (&reduced, &info, ffeexpr_stack_->tokens[0]);
18485      else if (ffebld_symter_specific (procedure->u.operand)
18486	       != FFEINTRIN_specNONE)
18487	ffeintrin_fulfill_specific (&reduced, &info, &check_intrin,
18488				    ffeexpr_stack_->tokens[0]);
18489      else
18490	ffeexpr_fulfill_call_ (&reduced, ffeexpr_stack_->tokens[0]);
18491
18492      if (ffebld_op (reduced) != FFEBLD_opANY)
18493	ffebld_set_info (reduced,
18494			 ffeinfo_new (ffeinfo_basictype (info),
18495				      ffeinfo_kindtype (info),
18496				      0,
18497				      FFEINFO_kindENTITY,
18498				      FFEINFO_whereFLEETING,
18499				      ffeinfo_size (info)));
18500      else
18501	ffebld_set_info (reduced, ffeinfo_new_any ());
18502    }
18503  if (ffebld_op (reduced) == FFEBLD_opFUNCREF)
18504    reduced = ffeexpr_collapse_funcref (reduced, ffeexpr_stack_->tokens[0]);
18505  ffeexpr_stack_->exprstack = procedure->previous;	/* Pops
18506							   not-quite-operand off
18507							   stack. */
18508  procedure->u.operand = reduced;	/* Save the line/column ffewhere
18509					   info. */
18510  ffeexpr_exprstack_push_operand_ (procedure);	/* Push it back on stack. */
18511  if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18512    {
18513      ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18514      ffeexpr_is_substr_ok_ = FALSE;	/* Nobody likes "FUNC(3)(1:1)".... */
18515
18516      /* If the intrinsic needs checking (is REAL(Z) or AIMAG(Z), where
18517	 Z is DOUBLE COMPLEX), and a command-line option doesn't already
18518	 establish interpretation, probably complain.  */
18519
18520      if (check_intrin
18521	  && !ffe_is_90 ()
18522	  && !ffe_is_ugly_complex ())
18523	{
18524	  /* If the outer expression is REAL(me...), issue diagnostic
18525	     only if next token isn't the close-paren for REAL(me).  */
18526
18527	  if ((ffeexpr_stack_->previous != NULL)
18528	      && (ffeexpr_stack_->previous->exprstack != NULL)
18529	      && (ffeexpr_stack_->previous->exprstack->type == FFEEXPR_exprtypeOPERAND_)
18530	      && ((reduced = ffeexpr_stack_->previous->exprstack->u.operand) != NULL)
18531	      && (ffebld_op (reduced) == FFEBLD_opSYMTER)
18532	      && (ffebld_symter_implementation (reduced) == FFEINTRIN_impREAL))
18533	    return (ffelexHandler) ffeexpr_token_intrincheck_;
18534
18535	  /* Diagnose the ambiguity now.  */
18536
18537	  if (ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
18538	    {
18539	      ffebad_string (ffeintrin_name_implementation
18540			     (ffebld_symter_implementation
18541			      (ffebld_left
18542			       (ffeexpr_stack_->exprstack->u.operand))));
18543	      ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
18544			   ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
18545	      ffebad_finish ();
18546	    }
18547	}
18548      return (ffelexHandler) ffeexpr_token_substrp_;
18549    }
18550
18551  if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
18552    {
18553      ffebad_here (0, ffelex_token_where_line (t),
18554		   ffelex_token_where_column (t));
18555      ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18556		   ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18557      ffebad_finish ();
18558    }
18559  ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18560  ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FUNC(3)(1:1)".... */
18561  return
18562    (ffelexHandler) ffeexpr_find_close_paren_ (t,
18563					       (ffelexHandler)
18564					       ffeexpr_token_substrp_);
18565}
18566
18567/* ffeexpr_token_elements_ -- OPEN_PAREN [expr COMMA]...expr
18568
18569   Return a pointer to this array to the lexer (ffelex), which will
18570   invoke it for the next token.
18571
18572   Handle expression and COMMA or CLOSE_PAREN.	*/
18573
18574static ffelexHandler
18575ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, ffelexToken t)
18576{
18577  ffeexprExpr_ array;
18578  ffebld reduced;
18579  ffeinfo info;
18580  ffeinfoWhere where;
18581  ffetargetIntegerDefault val;
18582  ffetargetIntegerDefault lval = 0;
18583  ffetargetIntegerDefault uval = 0;
18584  ffebld lbound;
18585  ffebld ubound;
18586  bool lcheck;
18587  bool ucheck;
18588
18589  array = ffeexpr_stack_->exprstack;
18590  info = ffebld_info (array->u.operand);
18591
18592  if ((expr == NULL)		/* && ((ffeexpr_stack_->rank != 0) ||
18593				   (ffelex_token_type(t) ==
18594	 FFELEX_typeCOMMA)) */ )
18595    {
18596      if (ffebad_start (FFEBAD_NULL_ELEMENT))
18597	{
18598	  ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18599		     ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18600	  ffebad_here (1, ffelex_token_where_line (t),
18601		       ffelex_token_where_column (t));
18602	  ffebad_finish ();
18603	}
18604      if (ffeexpr_stack_->rank < ffeinfo_rank (info))
18605	{			/* Don't bother if we're going to complain
18606				   later! */
18607	  expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
18608	  ffebld_set_info (expr, ffeinfo_new_any ());
18609	}
18610    }
18611
18612  if (expr == NULL)
18613    ;
18614  else if (ffeinfo_rank (info) == 0)
18615    {				/* In EQUIVALENCE context, ffeinfo_rank(info)
18616				   may == 0. */
18617      ++ffeexpr_stack_->rank;	/* Track anyway, may need for new VXT
18618				   feature. */
18619      ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18620    }
18621  else
18622    {
18623      ++ffeexpr_stack_->rank;
18624      if (ffeexpr_stack_->rank > ffeinfo_rank (info))
18625	{			/* Report later which was the first extra
18626				   element. */
18627	  if (ffeexpr_stack_->rank == ffeinfo_rank (info) + 1)
18628	    ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
18629	}
18630      else
18631	{
18632	  switch (ffeinfo_where (ffebld_info (expr)))
18633	    {
18634	    case FFEINFO_whereCONSTANT:
18635	      break;
18636
18637	    case FFEINFO_whereIMMEDIATE:
18638	      ffeexpr_stack_->constant = FALSE;
18639	      break;
18640
18641	    default:
18642	      ffeexpr_stack_->constant = FALSE;
18643	      ffeexpr_stack_->immediate = FALSE;
18644	      break;
18645	    }
18646	  if (ffebld_op (expr) == FFEBLD_opCONTER
18647	      && ffebld_kindtype (expr) == FFEINFO_kindtypeINTEGERDEFAULT)
18648	    {
18649	      val = ffebld_constant_integerdefault (ffebld_conter (expr));
18650
18651	      lbound = ffebld_left (ffebld_head (ffeexpr_stack_->bound_list));
18652	      if (lbound == NULL)
18653		{
18654		  lcheck = TRUE;
18655		  lval = 1;
18656		}
18657	      else if (ffebld_op (lbound) == FFEBLD_opCONTER)
18658		{
18659		  lcheck = TRUE;
18660		  lval = ffebld_constant_integerdefault (ffebld_conter (lbound));
18661		}
18662	      else
18663		lcheck = FALSE;
18664
18665	      ubound = ffebld_right (ffebld_head (ffeexpr_stack_->bound_list));
18666	      assert (ubound != NULL);
18667	      if (ffebld_op (ubound) == FFEBLD_opCONTER)
18668		{
18669		  ucheck = TRUE;
18670		  uval = ffebld_constant_integerdefault (ffebld_conter (ubound));
18671		}
18672	      else
18673		ucheck = FALSE;
18674
18675	      if ((lcheck && (val < lval)) || (ucheck && (val > uval)))
18676		{
18677		  ffebad_start (FFEBAD_RANGE_ARRAY);
18678		  ffebad_here (0, ffelex_token_where_line (ft),
18679			       ffelex_token_where_column (ft));
18680		  ffebad_finish ();
18681		}
18682	    }
18683	  ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18684	  ffeexpr_stack_->bound_list = ffebld_trail (ffeexpr_stack_->bound_list);
18685	}
18686    }
18687
18688  switch (ffelex_token_type (t))
18689    {
18690    case FFELEX_typeCOMMA:
18691      switch (ffeexpr_context_outer_ (ffeexpr_stack_))
18692	{
18693	case FFEEXPR_contextDATAIMPDOITEM_:
18694	  return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18695					      FFEEXPR_contextDATAIMPDOINDEX_,
18696					      ffeexpr_token_elements_);
18697
18698	case FFEEXPR_contextEQUIVALENCE:
18699	  return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18700					      FFEEXPR_contextEQVINDEX_,
18701					      ffeexpr_token_elements_);
18702
18703	case FFEEXPR_contextSFUNCDEF:
18704	case FFEEXPR_contextSFUNCDEFINDEX_:
18705	  return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18706					      FFEEXPR_contextSFUNCDEFINDEX_,
18707					      ffeexpr_token_elements_);
18708
18709	case FFEEXPR_contextSFUNCDEFACTUALARG_:
18710	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18711	  assert ("bad context" == NULL);
18712	  break;
18713
18714	default:
18715	  return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18716					      FFEEXPR_contextINDEX_,
18717					      ffeexpr_token_elements_);
18718	}
18719
18720    default:
18721      break;
18722    }
18723
18724  if ((ffeexpr_stack_->rank != ffeinfo_rank (info))
18725      && (ffeinfo_rank (info) != 0))
18726    {
18727      char num[10];
18728
18729      if (ffeexpr_stack_->rank < ffeinfo_rank (info))
18730	{
18731	  if (ffebad_start (FFEBAD_TOO_FEW_ELEMENTS))
18732	    {
18733	      sprintf (num, "%d",
18734		       (int) (ffeinfo_rank (info) - ffeexpr_stack_->rank));
18735
18736	      ffebad_here (0, ffelex_token_where_line (t),
18737			   ffelex_token_where_column (t));
18738	      ffebad_here (1,
18739			ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18740		     ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18741	      ffebad_string (num);
18742	      ffebad_finish ();
18743	    }
18744	}
18745      else
18746	{
18747	  if (ffebad_start (FFEBAD_TOO_MANY_ELEMENTS))
18748	    {
18749	      sprintf (num, "%d",
18750		       (int) (ffeexpr_stack_->rank - ffeinfo_rank (info)));
18751
18752	      ffebad_here (0,
18753			ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
18754		     ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
18755	      ffebad_here (1,
18756			ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18757		     ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18758	      ffebad_string (num);
18759	      ffebad_finish ();
18760	    }
18761	  ffelex_token_kill (ffeexpr_stack_->tokens[1]);
18762	}
18763      while (ffeexpr_stack_->rank++ < ffeinfo_rank (info))
18764	{
18765	  expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
18766	  ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeINTEGER,
18767					      FFEINFO_kindtypeINTEGERDEFAULT,
18768					      0, FFEINFO_kindENTITY,
18769					      FFEINFO_whereCONSTANT,
18770					      FFETARGET_charactersizeNONE));
18771	  ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18772	}
18773    }
18774  ffebld_end_list (&ffeexpr_stack_->bottom);
18775
18776  if (ffebld_op (array->u.operand) == FFEBLD_opANY)
18777    {
18778      reduced = ffebld_new_any ();
18779      ffebld_set_info (reduced, ffeinfo_new_any ());
18780    }
18781  else
18782    {
18783      reduced = ffebld_new_arrayref (array->u.operand, ffeexpr_stack_->expr);
18784      if (ffeexpr_stack_->constant)
18785	where = FFEINFO_whereFLEETING_CADDR;
18786      else if (ffeexpr_stack_->immediate)
18787	where = FFEINFO_whereFLEETING_IADDR;
18788      else
18789	where = FFEINFO_whereFLEETING;
18790      ffebld_set_info (reduced,
18791		       ffeinfo_new (ffeinfo_basictype (info),
18792				    ffeinfo_kindtype (info),
18793				    0,
18794				    FFEINFO_kindENTITY,
18795				    where,
18796				    ffeinfo_size (info)));
18797      reduced = ffeexpr_collapse_arrayref (reduced, ffeexpr_stack_->tokens[0]);
18798    }
18799
18800  ffeexpr_stack_->exprstack = array->previous;	/* Pops not-quite-operand off
18801						   stack. */
18802  array->u.operand = reduced;	/* Save the line/column ffewhere info. */
18803  ffeexpr_exprstack_push_operand_ (array);	/* Push it back on stack. */
18804
18805  switch (ffeinfo_basictype (info))
18806    {
18807    case FFEINFO_basictypeCHARACTER:
18808      ffeexpr_is_substr_ok_ = TRUE;	/* Everyone likes "FOO(3)(1:1)".... */
18809      break;
18810
18811    case FFEINFO_basictypeNONE:
18812      ffeexpr_is_substr_ok_ = TRUE;
18813      assert (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE);
18814      break;
18815
18816    default:
18817      ffeexpr_is_substr_ok_ = FALSE;
18818      break;
18819    }
18820
18821  if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18822    {
18823      ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18824      return (ffelexHandler) ffeexpr_token_substrp_;
18825    }
18826
18827  if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
18828    {
18829      ffebad_here (0, ffelex_token_where_line (t),
18830		   ffelex_token_where_column (t));
18831      ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18832		   ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18833      ffebad_finish ();
18834    }
18835  ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18836  return
18837    (ffelexHandler) ffeexpr_find_close_paren_ (t,
18838					       (ffelexHandler)
18839					       ffeexpr_token_substrp_);
18840}
18841
18842/* ffeexpr_token_equivalence_ -- OPEN_PAREN expr
18843
18844   Return a pointer to this array to the lexer (ffelex), which will
18845   invoke it for the next token.
18846
18847   If token is COLON, pass off to _substr_, else init list and pass off
18848   to _elements_.  This handles the case "EQUIVALENCE (FOO(expr?", where
18849   ? marks the token, and where FOO's rank/type has not yet been established,
18850   meaning we could be in a list of indices or in a substring
18851   specification.  */
18852
18853static ffelexHandler
18854ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr, ffelexToken t)
18855{
18856  if (ffelex_token_type (t) == FFELEX_typeCOLON)
18857    return ffeexpr_token_substring_ (ft, expr, t);
18858
18859  ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
18860  return ffeexpr_token_elements_ (ft, expr, t);
18861}
18862
18863/* ffeexpr_token_substring_ -- NAME(of kindENTITY) OPEN_PAREN expr
18864
18865   Return a pointer to this function to the lexer (ffelex), which will
18866   invoke it for the next token.
18867
18868   Handle expression (which may be null) and COLON.  */
18869
18870static ffelexHandler
18871ffeexpr_token_substring_ (ffelexToken ft, ffebld expr, ffelexToken t)
18872{
18873  ffeexprExpr_ string;
18874  ffeinfo info;
18875  ffetargetIntegerDefault i;
18876  ffeexprContext ctx;
18877  ffetargetCharacterSize size;
18878
18879  string = ffeexpr_stack_->exprstack;
18880  info = ffebld_info (string->u.operand);
18881  size = ffebld_size_max (string->u.operand);
18882
18883  if (ffelex_token_type (t) == FFELEX_typeCOLON)
18884    {
18885      if ((expr != NULL)
18886	  && (ffebld_op (expr) == FFEBLD_opCONTER)
18887	  && (((i = ffebld_constant_integerdefault (ffebld_conter (expr)))
18888	       < 1)
18889	      || ((size != FFETARGET_charactersizeNONE) && (i > size))))
18890	{
18891	  ffebad_start (FFEBAD_RANGE_SUBSTR);
18892	  ffebad_here (0, ffelex_token_where_line (ft),
18893		       ffelex_token_where_column (ft));
18894	  ffebad_finish ();
18895	}
18896      ffeexpr_stack_->expr = expr;
18897
18898      switch (ffeexpr_stack_->context)
18899	{
18900	case FFEEXPR_contextSFUNCDEF:
18901	case FFEEXPR_contextSFUNCDEFINDEX_:
18902	  ctx = FFEEXPR_contextSFUNCDEFINDEX_;
18903	  break;
18904
18905	case FFEEXPR_contextSFUNCDEFACTUALARG_:
18906	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18907	  assert ("bad context" == NULL);
18908	  ctx = FFEEXPR_context;
18909	  break;
18910
18911	default:
18912	  ctx = FFEEXPR_contextINDEX_;
18913	  break;
18914	}
18915
18916      return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18917					  ffeexpr_token_substring_1_);
18918    }
18919
18920  if (ffest_ffebad_start (FFEBAD_MISSING_COLON_IN_SUBSTR))
18921    {
18922      ffebad_here (0, ffelex_token_where_line (t),
18923		   ffelex_token_where_column (t));
18924      ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18925		   ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18926      ffebad_finish ();
18927    }
18928
18929  ffeexpr_stack_->expr = NULL;
18930  return (ffelexHandler) ffeexpr_token_substring_1_ (ft, expr, t);
18931}
18932
18933/* ffeexpr_token_substring_1_ -- NAME OPEN_PAREN [expr COMMA]...expr
18934
18935   Return a pointer to this function to the lexer (ffelex), which will
18936   invoke it for the next token.
18937
18938   Handle expression (which might be null) and CLOSE_PAREN.  */
18939
18940static ffelexHandler
18941ffeexpr_token_substring_1_ (ffelexToken ft, ffebld last, ffelexToken t)
18942{
18943  ffeexprExpr_ string;
18944  ffebld reduced;
18945  ffebld substrlist;
18946  ffebld first = ffeexpr_stack_->expr;
18947  ffebld strop;
18948  ffeinfo info;
18949  ffeinfoWhere lwh;
18950  ffeinfoWhere rwh;
18951  ffeinfoWhere where;
18952  ffeinfoKindtype first_kt;
18953  ffeinfoKindtype last_kt;
18954  ffetargetIntegerDefault first_val;
18955  ffetargetIntegerDefault last_val;
18956  ffetargetCharacterSize size;
18957  ffetargetCharacterSize strop_size_max;
18958  bool first_known;
18959
18960  string = ffeexpr_stack_->exprstack;
18961  strop = string->u.operand;
18962  info = ffebld_info (strop);
18963
18964  if (first == NULL
18965      || (ffebld_op (first) == FFEBLD_opCONTER
18966	  && ffebld_kindtype (first) == FFEINFO_kindtypeINTEGERDEFAULT))
18967    {				/* The starting point is known. */
18968      first_val = (first == NULL) ? 1
18969	: ffebld_constant_integerdefault (ffebld_conter (first));
18970      first_known = TRUE;
18971    }
18972  else
18973    {				/* Assume start of the entity. */
18974      first_val = 1;
18975      first_known = FALSE;
18976    }
18977
18978  if (last != NULL
18979      && (ffebld_op (last) == FFEBLD_opCONTER
18980	  && ffebld_kindtype (last) == FFEINFO_kindtypeINTEGERDEFAULT))
18981    {				/* The ending point is known. */
18982      last_val = ffebld_constant_integerdefault (ffebld_conter (last));
18983
18984      if (first_known)
18985	{			/* The beginning point is a constant. */
18986	  if (first_val <= last_val)
18987	    size = last_val - first_val + 1;
18988	  else
18989	    {
18990	      if (0 && ffe_is_90 ())
18991		size = 0;
18992	      else
18993		{
18994		  size = 1;
18995		  ffebad_start (FFEBAD_ZERO_SIZE);
18996		  ffebad_here (0, ffelex_token_where_line (ft),
18997			       ffelex_token_where_column (ft));
18998		  ffebad_finish ();
18999		}
19000	    }
19001	}
19002      else
19003	size = FFETARGET_charactersizeNONE;
19004
19005      strop_size_max = ffebld_size_max (strop);
19006
19007      if ((strop_size_max != FFETARGET_charactersizeNONE)
19008	  && (last_val > strop_size_max))
19009	{			/* Beyond maximum possible end of string. */
19010	  ffebad_start (FFEBAD_RANGE_SUBSTR);
19011	  ffebad_here (0, ffelex_token_where_line (ft),
19012		       ffelex_token_where_column (ft));
19013	  ffebad_finish ();
19014	}
19015    }
19016  else
19017    size = FFETARGET_charactersizeNONE;	/* The size is not known. */
19018
19019#if 0				/* Don't do this, or "is size of target
19020				   known?" would no longer be easily
19021				   answerable.	To see if there is a max
19022				   size, use ffebld_size_max; to get only the
19023				   known size, else NONE, use
19024				   ffebld_size_known; use ffebld_size if
19025				   values are sure to be the same (not
19026				   opSUBSTR or opCONCATENATE or known to have
19027				   known length). By getting rid of this
19028				   "useful info" stuff, we don't end up
19029				   blank-padding the constant in the
19030				   assignment "A(I:J)='XYZ'" to the known
19031				   length of A. */
19032  if (size == FFETARGET_charactersizeNONE)
19033    size = strop_size_max;	/* Assume we use the entire string. */
19034#endif
19035
19036  substrlist
19037    = ffebld_new_item
19038    (first,
19039     ffebld_new_item
19040     (last,
19041      NULL
19042     )
19043    )
19044    ;
19045
19046  if (first == NULL)
19047    lwh = FFEINFO_whereCONSTANT;
19048  else
19049    lwh = ffeinfo_where (ffebld_info (first));
19050  if (last == NULL)
19051    rwh = FFEINFO_whereCONSTANT;
19052  else
19053    rwh = ffeinfo_where (ffebld_info (last));
19054
19055  switch (lwh)
19056    {
19057    case FFEINFO_whereCONSTANT:
19058      switch (rwh)
19059	{
19060	case FFEINFO_whereCONSTANT:
19061	  where = FFEINFO_whereCONSTANT;
19062	  break;
19063
19064	case FFEINFO_whereIMMEDIATE:
19065	  where = FFEINFO_whereIMMEDIATE;
19066	  break;
19067
19068	default:
19069	  where = FFEINFO_whereFLEETING;
19070	  break;
19071	}
19072      break;
19073
19074    case FFEINFO_whereIMMEDIATE:
19075      switch (rwh)
19076	{
19077	case FFEINFO_whereCONSTANT:
19078	case FFEINFO_whereIMMEDIATE:
19079	  where = FFEINFO_whereIMMEDIATE;
19080	  break;
19081
19082	default:
19083	  where = FFEINFO_whereFLEETING;
19084	  break;
19085	}
19086      break;
19087
19088    default:
19089      where = FFEINFO_whereFLEETING;
19090      break;
19091    }
19092
19093  if (first == NULL)
19094    first_kt = FFEINFO_kindtypeINTEGERDEFAULT;
19095  else
19096    first_kt = ffeinfo_kindtype (ffebld_info (first));
19097  if (last == NULL)
19098    last_kt = FFEINFO_kindtypeINTEGERDEFAULT;
19099  else
19100    last_kt = ffeinfo_kindtype (ffebld_info (last));
19101
19102  switch (where)
19103    {
19104    case FFEINFO_whereCONSTANT:
19105      switch (ffeinfo_where (info))
19106	{
19107	case FFEINFO_whereCONSTANT:
19108	  break;
19109
19110	case FFEINFO_whereIMMEDIATE:	/* Not possible, actually. */
19111	  where = FFEINFO_whereIMMEDIATE;
19112	  break;
19113
19114	default:
19115	  where = FFEINFO_whereFLEETING_CADDR;
19116	  break;
19117	}
19118      break;
19119
19120    case FFEINFO_whereIMMEDIATE:
19121      switch (ffeinfo_where (info))
19122	{
19123	case FFEINFO_whereCONSTANT:
19124	case FFEINFO_whereIMMEDIATE:	/* Not possible, actually. */
19125	  break;
19126
19127	default:
19128	  where = FFEINFO_whereFLEETING_IADDR;
19129	  break;
19130	}
19131      break;
19132
19133    default:
19134      switch (ffeinfo_where (info))
19135	{
19136	case FFEINFO_whereCONSTANT:
19137	  where = FFEINFO_whereCONSTANT_SUBOBJECT;	/* An F90 concept. */
19138	  break;
19139
19140	case FFEINFO_whereIMMEDIATE:	/* Not possible, actually. */
19141	default:
19142	  where = FFEINFO_whereFLEETING;
19143	  break;
19144	}
19145      break;
19146    }
19147
19148  if (ffebld_op (strop) == FFEBLD_opANY)
19149    {
19150      reduced = ffebld_new_any ();
19151      ffebld_set_info (reduced, ffeinfo_new_any ());
19152    }
19153  else
19154    {
19155      reduced = ffebld_new_substr (strop, substrlist);
19156      ffebld_set_info (reduced, ffeinfo_new
19157		       (FFEINFO_basictypeCHARACTER,
19158			ffeinfo_kindtype (info),
19159			0,
19160			FFEINFO_kindENTITY,
19161			where,
19162			size));
19163      reduced = ffeexpr_collapse_substr (reduced, ffeexpr_stack_->tokens[0]);
19164    }
19165
19166  ffeexpr_stack_->exprstack = string->previous;	/* Pops not-quite-operand off
19167						   stack. */
19168  string->u.operand = reduced;	/* Save the line/column ffewhere info. */
19169  ffeexpr_exprstack_push_operand_ (string);	/* Push it back on stack. */
19170
19171  if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
19172    {
19173      ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19174      ffeexpr_is_substr_ok_ = FALSE;	/* Nobody likes "FOO(3:5)(1:1)".... */
19175      return (ffelexHandler) ffeexpr_token_substrp_;
19176    }
19177
19178  if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
19179    {
19180      ffebad_here (0, ffelex_token_where_line (t),
19181		   ffelex_token_where_column (t));
19182      ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
19183		   ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
19184      ffebad_finish ();
19185    }
19186
19187  ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19188  ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FOO(3:5)(1:1)".... */
19189  return
19190    (ffelexHandler) ffeexpr_find_close_paren_ (t,
19191					       (ffelexHandler)
19192					       ffeexpr_token_substrp_);
19193}
19194
19195/* ffeexpr_token_substrp_ -- Rhs <character entity>
19196
19197   Return a pointer to this function to the lexer (ffelex), which will
19198   invoke it for the next token.
19199
19200   If OPEN_PAREN, treat as start of a substring ("(3:4)") construct, and
19201   issue error message if flag (serves as argument) is set.  Else, just
19202   forward token to binary_.  */
19203
19204static ffelexHandler
19205ffeexpr_token_substrp_ (ffelexToken t)
19206{
19207  ffeexprContext ctx;
19208
19209  if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
19210    return (ffelexHandler) ffeexpr_token_binary_ (t);
19211
19212  ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
19213
19214  switch (ffeexpr_stack_->context)
19215    {
19216    case FFEEXPR_contextSFUNCDEF:
19217    case FFEEXPR_contextSFUNCDEFINDEX_:
19218      ctx = FFEEXPR_contextSFUNCDEFINDEX_;
19219      break;
19220
19221    case FFEEXPR_contextSFUNCDEFACTUALARG_:
19222    case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
19223      assert ("bad context" == NULL);
19224      ctx = FFEEXPR_context;
19225      break;
19226
19227    default:
19228      ctx = FFEEXPR_contextINDEX_;
19229      break;
19230    }
19231
19232  if (!ffeexpr_is_substr_ok_)
19233    {
19234      if (ffebad_start (FFEBAD_BAD_SUBSTR))
19235	{
19236	  ffebad_here (0, ffelex_token_where_line (t),
19237		       ffelex_token_where_column (t));
19238	  ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
19239		       ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
19240	  ffebad_finish ();
19241	}
19242
19243      return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
19244					  ffeexpr_token_anything_);
19245    }
19246
19247  return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
19248				      ffeexpr_token_substring_);
19249}
19250
19251static ffelexHandler
19252ffeexpr_token_intrincheck_ (ffelexToken t)
19253{
19254  if ((ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
19255      && ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
19256    {
19257      ffebad_string (ffeintrin_name_implementation
19258		     (ffebld_symter_implementation
19259		      (ffebld_left
19260		       (ffeexpr_stack_->exprstack->u.operand))));
19261      ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
19262		   ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
19263      ffebad_finish ();
19264    }
19265
19266  return (ffelexHandler) ffeexpr_token_substrp_ (t);
19267}
19268
19269/* ffeexpr_token_funsubstr_ -- NAME OPEN_PAREN expr
19270
19271   Return a pointer to this function to the lexer (ffelex), which will
19272   invoke it for the next token.
19273
19274   If COLON, do everything we would have done since _parenthesized_ if
19275   we had known NAME represented a kindENTITY instead of a kindFUNCTION.
19276   If not COLON, do likewise for kindFUNCTION instead.	*/
19277
19278static ffelexHandler
19279ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr, ffelexToken t)
19280{
19281  ffeinfoWhere where;
19282  ffesymbol s;
19283  ffesymbolAttrs sa;
19284  ffebld symter = ffeexpr_stack_->exprstack->u.operand;
19285  bool needs_type;
19286  ffeintrinGen gen;
19287  ffeintrinSpec spec;
19288  ffeintrinImp imp;
19289
19290  s = ffebld_symter (symter);
19291  sa = ffesymbol_attrs (s);
19292  where = ffesymbol_where (s);
19293
19294  /* We get here only if we don't already know enough about FOO when seeing a
19295     FOO(stuff) reference, and FOO might turn out to be a CHARACTER type.  If
19296     "stuff" is a substring reference, then FOO is a CHARACTER scalar type.
19297     Else FOO is a function, either intrinsic or external.  If intrinsic, it
19298     wouldn't necessarily be CHARACTER type, so unless it has already been
19299     declared DUMMY, it hasn't had its type established yet.  It can't be
19300     CHAR*(*) in any case, though it can have an explicit CHAR*n type.  */
19301
19302  assert (!(sa & ~(FFESYMBOL_attrsDUMMY
19303		   | FFESYMBOL_attrsTYPE)));
19304
19305  needs_type = !(ffesymbol_attrs (s) & FFESYMBOL_attrsDUMMY);
19306
19307  ffesymbol_signal_change (s);	/* Probably already done, but in case.... */
19308
19309  if (ffelex_token_type (t) == FFELEX_typeCOLON)
19310    {				/* Definitely an ENTITY (char substring). */
19311      if (needs_type && !ffeimplic_establish_symbol (s))
19312	{
19313	  ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
19314	  return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19315	}
19316
19317      ffesymbol_set_info (s,
19318			  ffeinfo_new (ffesymbol_basictype (s),
19319				       ffesymbol_kindtype (s),
19320				       ffesymbol_rank (s),
19321				       FFEINFO_kindENTITY,
19322				       (where == FFEINFO_whereNONE)
19323				       ? FFEINFO_whereLOCAL
19324				       : where,
19325				       ffesymbol_size (s)));
19326      ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
19327
19328      ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
19329      ffesymbol_resolve_intrin (s);
19330      s = ffecom_sym_learned (s);
19331      ffesymbol_signal_unreported (s);	/* For debugging purposes. */
19332
19333      ffeexpr_stack_->exprstack->u.operand
19334	= ffeexpr_collapse_symter (symter, ffeexpr_tokens_[0]);
19335
19336      return (ffelexHandler) ffeexpr_token_substring_ (ft, expr, t);
19337    }
19338
19339  /* The "stuff" isn't a substring notation, so we now know the overall
19340     reference is to a function.  */
19341
19342  if (ffeintrin_is_intrinsic (ffesymbol_text (s), ffeexpr_stack_->tokens[0],
19343			      FALSE, &gen, &spec, &imp))
19344    {
19345      ffebld_symter_set_generic (symter, gen);
19346      ffebld_symter_set_specific (symter, spec);
19347      ffebld_symter_set_implementation (symter, imp);
19348      ffesymbol_set_generic (s, gen);
19349      ffesymbol_set_specific (s, spec);
19350      ffesymbol_set_implementation (s, imp);
19351      ffesymbol_set_info (s,
19352			  ffeinfo_new (ffesymbol_basictype (s),
19353				       ffesymbol_kindtype (s),
19354				       0,
19355				       FFEINFO_kindFUNCTION,
19356				       FFEINFO_whereINTRINSIC,
19357				       ffesymbol_size (s)));
19358    }
19359  else
19360    {				/* Not intrinsic, now needs CHAR type. */
19361      if (!ffeimplic_establish_symbol (s))
19362	{
19363	  ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
19364	  return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19365	}
19366
19367      ffesymbol_set_info (s,
19368			  ffeinfo_new (ffesymbol_basictype (s),
19369				       ffesymbol_kindtype (s),
19370				       ffesymbol_rank (s),
19371				       FFEINFO_kindFUNCTION,
19372				       (where == FFEINFO_whereNONE)
19373				       ? FFEINFO_whereGLOBAL
19374				       : where,
19375				       ffesymbol_size (s)));
19376    }
19377
19378  ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
19379
19380  ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
19381  ffesymbol_resolve_intrin (s);
19382  s = ffecom_sym_learned (s);
19383  ffesymbol_reference (s, ffeexpr_stack_->tokens[0], FALSE);
19384  ffesymbol_signal_unreported (s);	/* For debugging purposes. */
19385  ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
19386  return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19387}
19388
19389/* ffeexpr_token_anything_ -- NAME OPEN_PAREN any-expr
19390
19391   Handle basically any expression, looking for CLOSE_PAREN.  */
19392
19393static ffelexHandler
19394ffeexpr_token_anything_ (ffelexToken ft UNUSED, ffebld expr UNUSED,
19395			 ffelexToken t)
19396{
19397  ffeexprExpr_ e = ffeexpr_stack_->exprstack;
19398
19399  switch (ffelex_token_type (t))
19400    {
19401    case FFELEX_typeCOMMA:
19402    case FFELEX_typeCOLON:
19403      return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
19404					  FFEEXPR_contextACTUALARG_,
19405					  ffeexpr_token_anything_);
19406
19407    default:
19408      e->u.operand = ffebld_new_any ();
19409      ffebld_set_info (e->u.operand, ffeinfo_new_any ());
19410      ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19411      ffeexpr_is_substr_ok_ = FALSE;
19412      if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
19413	return (ffelexHandler) ffeexpr_token_substrp_;
19414      return (ffelexHandler) ffeexpr_token_substrp_ (t);
19415    }
19416}
19417
19418/* Terminate module.  */
19419
19420void
19421ffeexpr_terminate_2 ()
19422{
19423  assert (ffeexpr_stack_ == NULL);
19424  assert (ffeexpr_level_ == 0);
19425}
19426