1 /* expr.c -- Implementation File (module.c template V1.0)
2    Copyright (C) 1995, 1996, 1997, 1998, 2001, 2002, 2003
3    Free Software Foundation, Inc.
4    Contributed by James Craig Burley.
5 
6 This file is part of GNU Fortran.
7 
8 GNU Fortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
11 any later version.
12 
13 GNU Fortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 GNU General Public License for more details.
17 
18 You should have received a copy of the GNU General Public License
19 along with GNU Fortran; see the file COPYING.  If not, write to
20 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
21 02111-1307, USA.
22 
23    Related Modules:
24       None.
25 
26    Description:
27       Handles syntactic and semantic analysis of Fortran expressions.
28 
29    Modifications:
30 */
31 
32 /* Include files. */
33 
34 #include "proj.h"
35 #include "expr.h"
36 #include "bad.h"
37 #include "bld.h"
38 #include "com.h"
39 #include "global.h"
40 #include "implic.h"
41 #include "intrin.h"
42 #include "info.h"
43 #include "lex.h"
44 #include "malloc.h"
45 #include "src.h"
46 #include "st.h"
47 #include "symbol.h"
48 #include "str.h"
49 #include "target.h"
50 #include "where.h"
51 #include "real.h"
52 
53 /* Externals defined here. */
54 
55 
56 /* Simple definitions and enumerations. */
57 
58 typedef enum
59   {
60     FFEEXPR_exprtypeUNKNOWN_,
61     FFEEXPR_exprtypeOPERAND_,
62     FFEEXPR_exprtypeUNARY_,
63     FFEEXPR_exprtypeBINARY_,
64     FFEEXPR_exprtype_
65   } ffeexprExprtype_;
66 
67 typedef enum
68   {
69     FFEEXPR_operatorPOWER_,
70     FFEEXPR_operatorMULTIPLY_,
71     FFEEXPR_operatorDIVIDE_,
72     FFEEXPR_operatorADD_,
73     FFEEXPR_operatorSUBTRACT_,
74     FFEEXPR_operatorCONCATENATE_,
75     FFEEXPR_operatorLT_,
76     FFEEXPR_operatorLE_,
77     FFEEXPR_operatorEQ_,
78     FFEEXPR_operatorNE_,
79     FFEEXPR_operatorGT_,
80     FFEEXPR_operatorGE_,
81     FFEEXPR_operatorNOT_,
82     FFEEXPR_operatorAND_,
83     FFEEXPR_operatorOR_,
84     FFEEXPR_operatorXOR_,
85     FFEEXPR_operatorEQV_,
86     FFEEXPR_operatorNEQV_,
87     FFEEXPR_operator_
88   } ffeexprOperator_;
89 
90 typedef enum
91   {
92     FFEEXPR_operatorprecedenceHIGHEST_ = 1,
93     FFEEXPR_operatorprecedencePOWER_ = 1,
94     FFEEXPR_operatorprecedenceMULTIPLY_ = 2,
95     FFEEXPR_operatorprecedenceDIVIDE_ = 2,
96     FFEEXPR_operatorprecedenceADD_ = 3,
97     FFEEXPR_operatorprecedenceSUBTRACT_ = 3,
98     FFEEXPR_operatorprecedenceLOWARITH_ = 3,
99     FFEEXPR_operatorprecedenceCONCATENATE_ = 3,
100     FFEEXPR_operatorprecedenceLT_ = 4,
101     FFEEXPR_operatorprecedenceLE_ = 4,
102     FFEEXPR_operatorprecedenceEQ_ = 4,
103     FFEEXPR_operatorprecedenceNE_ = 4,
104     FFEEXPR_operatorprecedenceGT_ = 4,
105     FFEEXPR_operatorprecedenceGE_ = 4,
106     FFEEXPR_operatorprecedenceNOT_ = 5,
107     FFEEXPR_operatorprecedenceAND_ = 6,
108     FFEEXPR_operatorprecedenceOR_ = 7,
109     FFEEXPR_operatorprecedenceXOR_ = 8,
110     FFEEXPR_operatorprecedenceEQV_ = 8,
111     FFEEXPR_operatorprecedenceNEQV_ = 8,
112     FFEEXPR_operatorprecedenceLOWEST_ = 8,
113     FFEEXPR_operatorprecedence_
114   } ffeexprOperatorPrecedence_;
115 
116 #define FFEEXPR_operatorassociativityL2R_ TRUE
117 #define FFEEXPR_operatorassociativityR2L_ FALSE
118 #define FFEEXPR_operatorassociativityPOWER_ FFEEXPR_operatorassociativityR2L_
119 #define FFEEXPR_operatorassociativityMULTIPLY_ FFEEXPR_operatorassociativityL2R_
120 #define FFEEXPR_operatorassociativityDIVIDE_ FFEEXPR_operatorassociativityL2R_
121 #define FFEEXPR_operatorassociativityADD_ FFEEXPR_operatorassociativityL2R_
122 #define FFEEXPR_operatorassociativitySUBTRACT_ FFEEXPR_operatorassociativityL2R_
123 #define FFEEXPR_operatorassociativityCONCATENATE_ FFEEXPR_operatorassociativityL2R_
124 #define FFEEXPR_operatorassociativityLT_ FFEEXPR_operatorassociativityL2R_
125 #define FFEEXPR_operatorassociativityLE_ FFEEXPR_operatorassociativityL2R_
126 #define FFEEXPR_operatorassociativityEQ_ FFEEXPR_operatorassociativityL2R_
127 #define FFEEXPR_operatorassociativityNE_ FFEEXPR_operatorassociativityL2R_
128 #define FFEEXPR_operatorassociativityGT_ FFEEXPR_operatorassociativityL2R_
129 #define FFEEXPR_operatorassociativityGE_ FFEEXPR_operatorassociativityL2R_
130 #define FFEEXPR_operatorassociativityNOT_ FFEEXPR_operatorassociativityL2R_
131 #define FFEEXPR_operatorassociativityAND_ FFEEXPR_operatorassociativityL2R_
132 #define FFEEXPR_operatorassociativityOR_ FFEEXPR_operatorassociativityL2R_
133 #define FFEEXPR_operatorassociativityXOR_ FFEEXPR_operatorassociativityL2R_
134 #define FFEEXPR_operatorassociativityEQV_ FFEEXPR_operatorassociativityL2R_
135 #define FFEEXPR_operatorassociativityNEQV_ FFEEXPR_operatorassociativityL2R_
136 
137 typedef enum
138   {
139     FFEEXPR_parentypeFUNCTION_,
140     FFEEXPR_parentypeSUBROUTINE_,
141     FFEEXPR_parentypeARRAY_,
142     FFEEXPR_parentypeSUBSTRING_,
143     FFEEXPR_parentypeFUNSUBSTR_,/* Ambig: check for colon after first expr. */
144     FFEEXPR_parentypeEQUIVALENCE_,	/* Ambig: ARRAY_ or SUBSTRING_. */
145     FFEEXPR_parentypeANY_,	/* Allow basically anything. */
146     FFEEXPR_parentype_
147   } ffeexprParenType_;
148 
149 typedef enum
150   {
151     FFEEXPR_percentNONE_,
152     FFEEXPR_percentLOC_,
153     FFEEXPR_percentVAL_,
154     FFEEXPR_percentREF_,
155     FFEEXPR_percentDESCR_,
156     FFEEXPR_percent_
157   } ffeexprPercent_;
158 
159 /* Internal typedefs. */
160 
161 typedef struct _ffeexpr_expr_ *ffeexprExpr_;
162 typedef bool ffeexprOperatorAssociativity_;
163 typedef struct _ffeexpr_stack_ *ffeexprStack_;
164 
165 /* Private include files. */
166 
167 
168 /* Internal structure definitions. */
169 
170 struct _ffeexpr_expr_
171   {
172     ffeexprExpr_ previous;
173     ffelexToken token;
174     ffeexprExprtype_ type;
175     union
176       {
177 	struct
178 	  {
179 	    ffeexprOperator_ op;
180 	    ffeexprOperatorPrecedence_ prec;
181 	    ffeexprOperatorAssociativity_ as;
182 	  }
183 	operator;
184 	ffebld operand;
185       }
186     u;
187   };
188 
189 struct _ffeexpr_stack_
190   {
191     ffeexprStack_ previous;
192     mallocPool pool;
193     ffeexprContext context;
194     ffeexprCallback callback;
195     ffelexToken first_token;
196     ffeexprExpr_ exprstack;
197     ffelexToken tokens[10];	/* Used in certain cases, like (unary)
198 				   open-paren. */
199     ffebld expr;		/* For first of
200 				   complex/implied-do/substring/array-elements
201 				   / actual-args expression. */
202     ffebld bound_list;		/* For tracking dimension bounds list of
203 				   array. */
204     ffebldListBottom bottom;	/* For building lists. */
205     ffeinfoRank rank;		/* For elements in an array reference. */
206     bool constant;		/* TRUE while elements seen so far are
207 				   constants. */
208     bool immediate;		/* TRUE while elements seen so far are
209 				   immediate/constants. */
210     ffebld next_dummy;		/* Next SFUNC dummy arg in arg list. */
211     ffebldListLength num_args;	/* Number of dummy args expected in arg list. */
212     bool is_rhs;		/* TRUE if rhs context, FALSE otherwise. */
213     ffeexprPercent_ percent;	/* Current %FOO keyword. */
214   };
215 
216 struct _ffeexpr_find_
217   {
218     ffelexToken t;
219     ffelexHandler after;
220     int level;
221   };
222 
223 /* Static objects accessed by functions in this module. */
224 
225 static ffeexprStack_ ffeexpr_stack_;	/* Expression stack for semantic. */
226 static ffelexToken ffeexpr_tokens_[10];	/* Scratchpad tokens for syntactic. */
227 static ffestrOther ffeexpr_current_dotdot_;	/* Current .FOO. keyword. */
228 static long ffeexpr_hollerith_count_;	/* ffeexpr_token_number_ and caller. */
229 static int ffeexpr_level_;	/* Level of DATA implied-DO construct. */
230 static bool ffeexpr_is_substr_ok_;	/* If OPEN_PAREN as binary "op" ok. */
231 static struct _ffeexpr_find_ ffeexpr_find_;
232 
233 /* Static functions (internal). */
234 
235 static ffelexHandler ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr,
236 					      ffelexToken t);
237 static ffelexHandler ffeexpr_cb_close_paren_ambig_ (ffelexToken ft,
238 						    ffebld expr,
239 						    ffelexToken t);
240 static ffelexHandler ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t);
241 static ffelexHandler ffeexpr_cb_close_paren_c_ (ffelexToken ft,
242 						ffebld expr, ffelexToken t);
243 static ffelexHandler ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr,
244 					  ffelexToken t);
245 static ffelexHandler ffeexpr_cb_close_paren_ci_ (ffelexToken ft,
246 						 ffebld expr, ffelexToken t);
247 static ffelexHandler ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr,
248 					   ffelexToken t);
249 static ffelexHandler ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr,
250 					  ffelexToken t);
251 static ffelexHandler ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr,
252 					    ffelexToken t);
253 static ffelexHandler ffeexpr_cb_comma_i_2_ (ffelexToken ft, ffebld expr,
254 					    ffelexToken t);
255 static ffelexHandler ffeexpr_cb_comma_i_3_ (ffelexToken ft, ffebld expr,
256 					    ffelexToken t);
257 static ffelexHandler ffeexpr_cb_comma_i_4_ (ffelexToken ft, ffebld expr,
258 					    ffelexToken t);
259 static ffelexHandler ffeexpr_cb_comma_i_5_ (ffelexToken t);
260 static ffelexHandler ffeexpr_cb_end_loc_ (ffelexToken ft, ffebld expr,
261 					  ffelexToken t);
262 static ffelexHandler ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr,
263 					     ffelexToken t);
264 static ffelexHandler ffeexpr_cb_end_notloc_1_ (ffelexToken t);
265 static ffesymbol ffeexpr_check_impctrl_ (ffesymbol s);
266 static void ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
267 				  ffebld dovar, ffelexToken dovar_t);
268 static void ffeexpr_update_impdo_ (ffebld expr, ffebld dovar);
269 static void ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar);
270 static ffeexprContext ffeexpr_context_outer_ (ffeexprStack_ s);
271 static ffeexprExpr_ ffeexpr_expr_new_ (void);
272 static void ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t);
273 static bool ffeexpr_isdigits_ (const char *p);
274 static ffelexHandler ffeexpr_token_first_lhs_ (ffelexToken t);
275 static ffelexHandler ffeexpr_token_first_lhs_1_ (ffelexToken t);
276 static ffelexHandler ffeexpr_token_first_rhs_ (ffelexToken t);
277 static ffelexHandler ffeexpr_token_first_rhs_1_ (ffelexToken t);
278 static ffelexHandler ffeexpr_token_first_rhs_2_ (ffelexToken t);
279 static ffelexHandler ffeexpr_token_first_rhs_3_ (ffelexToken t);
280 static ffelexHandler ffeexpr_token_first_rhs_4_ (ffelexToken t);
281 static ffelexHandler ffeexpr_token_first_rhs_5_ (ffelexToken t);
282 static ffelexHandler ffeexpr_token_first_rhs_6_ (ffelexToken t);
283 static ffelexHandler ffeexpr_token_namelist_ (ffelexToken t);
284 static void ffeexpr_expr_kill_ (ffeexprExpr_ e);
285 static void ffeexpr_exprstack_push_ (ffeexprExpr_ e);
286 static void ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e);
287 static void ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e);
288 static void ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e);
289 static void ffeexpr_reduce_ (void);
290 static ffebld ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op,
291 				      ffeexprExpr_ r);
292 static ffebld ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l,
293 				      ffeexprExpr_ op, ffeexprExpr_ r);
294 static ffebld ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l,
295 					    ffeexprExpr_ op, ffeexprExpr_ r);
296 static ffebld ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l,
297 				      ffeexprExpr_ op, ffeexprExpr_ r);
298 static ffebld ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op,
299 				      ffeexprExpr_ r);
300 static ffebld ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l,
301 				      ffeexprExpr_ op, ffeexprExpr_ r);
302 static ffebld ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l,
303 				      ffeexprExpr_ op, ffeexprExpr_ r);
304 static ffebld ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l,
305 				       ffeexprExpr_ op, ffeexprExpr_ r);
306 static ffebld ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r);
307 static ffebld ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op,
308 					 ffeexprExpr_ r);
309 static ffebld ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l,
310 				      ffeexprExpr_ op, ffeexprExpr_ r);
311 static ffebld ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l,
312 					 ffeexprExpr_ op, ffeexprExpr_ r,
313 					 bool *);
314 static ffelexHandler ffeexpr_find_close_paren_ (ffelexToken t,
315 						ffelexHandler after);
316 static ffelexHandler ffeexpr_nil_finished_ (ffelexToken t);
317 static ffelexHandler ffeexpr_nil_rhs_ (ffelexToken t);
318 static ffelexHandler ffeexpr_nil_period_ (ffelexToken t);
319 static ffelexHandler ffeexpr_nil_end_period_ (ffelexToken t);
320 static ffelexHandler ffeexpr_nil_swallow_period_ (ffelexToken t);
321 static ffelexHandler ffeexpr_nil_real_ (ffelexToken t);
322 static ffelexHandler ffeexpr_nil_real_exponent_ (ffelexToken t);
323 static ffelexHandler ffeexpr_nil_real_exp_sign_ (ffelexToken t);
324 static ffelexHandler ffeexpr_nil_number_ (ffelexToken t);
325 static ffelexHandler ffeexpr_nil_number_exponent_ (ffelexToken t);
326 static ffelexHandler ffeexpr_nil_number_exp_sign_ (ffelexToken t);
327 static ffelexHandler ffeexpr_nil_number_period_ (ffelexToken t);
328 static ffelexHandler ffeexpr_nil_number_per_exp_ (ffelexToken t);
329 static ffelexHandler ffeexpr_nil_number_real_ (ffelexToken t);
330 static ffelexHandler ffeexpr_nil_num_per_exp_sign_ (ffelexToken t);
331 static ffelexHandler ffeexpr_nil_number_real_exp_ (ffelexToken t);
332 static ffelexHandler ffeexpr_nil_num_real_exp_sn_ (ffelexToken t);
333 static ffelexHandler ffeexpr_nil_binary_ (ffelexToken t);
334 static ffelexHandler ffeexpr_nil_binary_period_ (ffelexToken t);
335 static ffelexHandler ffeexpr_nil_binary_end_per_ (ffelexToken t);
336 static ffelexHandler ffeexpr_nil_binary_sw_per_ (ffelexToken t);
337 static ffelexHandler ffeexpr_nil_quote_ (ffelexToken t);
338 static ffelexHandler ffeexpr_nil_apostrophe_ (ffelexToken t);
339 static ffelexHandler ffeexpr_nil_apos_char_ (ffelexToken t);
340 static ffelexHandler ffeexpr_nil_name_rhs_ (ffelexToken t);
341 static ffelexHandler ffeexpr_nil_name_apos_ (ffelexToken t);
342 static ffelexHandler ffeexpr_nil_name_apos_name_ (ffelexToken t);
343 static ffelexHandler ffeexpr_nil_percent_ (ffelexToken t);
344 static ffelexHandler ffeexpr_nil_percent_name_ (ffelexToken t);
345 static ffelexHandler ffeexpr_nil_substrp_ (ffelexToken t);
346 static ffelexHandler ffeexpr_finished_ (ffelexToken t);
347 static ffebld ffeexpr_finished_ambig_ (ffelexToken t, ffebld expr);
348 static ffelexHandler ffeexpr_token_lhs_ (ffelexToken t);
349 static ffelexHandler ffeexpr_token_rhs_ (ffelexToken t);
350 static ffelexHandler ffeexpr_token_binary_ (ffelexToken t);
351 static ffelexHandler ffeexpr_token_period_ (ffelexToken t);
352 static ffelexHandler ffeexpr_token_end_period_ (ffelexToken t);
353 static ffelexHandler ffeexpr_token_swallow_period_ (ffelexToken t);
354 static ffelexHandler ffeexpr_token_real_ (ffelexToken t);
355 static ffelexHandler ffeexpr_token_real_exponent_ (ffelexToken t);
356 static ffelexHandler ffeexpr_token_real_exp_sign_ (ffelexToken t);
357 static ffelexHandler ffeexpr_token_number_ (ffelexToken t);
358 static ffelexHandler ffeexpr_token_number_exponent_ (ffelexToken t);
359 static ffelexHandler ffeexpr_token_number_exp_sign_ (ffelexToken t);
360 static ffelexHandler ffeexpr_token_number_period_ (ffelexToken t);
361 static ffelexHandler ffeexpr_token_number_per_exp_ (ffelexToken t);
362 static ffelexHandler ffeexpr_token_number_real_ (ffelexToken t);
363 static ffelexHandler ffeexpr_token_num_per_exp_sign_ (ffelexToken t);
364 static ffelexHandler ffeexpr_token_number_real_exp_ (ffelexToken t);
365 static ffelexHandler ffeexpr_token_num_real_exp_sn_ (ffelexToken t);
366 static ffelexHandler ffeexpr_token_binary_period_ (ffelexToken t);
367 static ffelexHandler ffeexpr_token_binary_end_per_ (ffelexToken t);
368 static ffelexHandler ffeexpr_token_binary_sw_per_ (ffelexToken t);
369 static ffelexHandler ffeexpr_token_quote_ (ffelexToken t);
370 static ffelexHandler ffeexpr_token_apostrophe_ (ffelexToken t);
371 static ffelexHandler ffeexpr_token_apos_char_ (ffelexToken t);
372 static ffelexHandler ffeexpr_token_name_lhs_ (ffelexToken t);
373 static ffelexHandler ffeexpr_token_name_arg_ (ffelexToken t);
374 static ffelexHandler ffeexpr_token_name_rhs_ (ffelexToken t);
375 static ffelexHandler ffeexpr_token_name_apos_ (ffelexToken t);
376 static ffelexHandler ffeexpr_token_name_apos_name_ (ffelexToken t);
377 static ffelexHandler ffeexpr_token_percent_ (ffelexToken t);
378 static ffelexHandler ffeexpr_token_percent_name_ (ffelexToken t);
379 static ffelexHandler ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr,
380 					       ffelexToken t);
381 static ffelexHandler ffeexpr_token_elements_ (ffelexToken ft, ffebld expr,
382 					      ffelexToken t);
383 static ffelexHandler ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr,
384 						 ffelexToken t);
385 static ffelexHandler ffeexpr_token_substring_ (ffelexToken ft, ffebld expr,
386 					       ffelexToken t);
387 static ffelexHandler ffeexpr_token_substring_1_ (ffelexToken ft, ffebld expr,
388 						 ffelexToken t);
389 static ffelexHandler ffeexpr_token_substrp_ (ffelexToken t);
390 static ffelexHandler ffeexpr_token_intrincheck_ (ffelexToken t);
391 static ffelexHandler ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr,
392 					       ffelexToken t);
393 static ffelexHandler ffeexpr_token_anything_ (ffelexToken ft, ffebld expr,
394 					      ffelexToken t);
395 static void ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
396 	    ffelexToken decimal, ffelexToken fraction, ffelexToken exponent,
397 		    ffelexToken exponent_sign, ffelexToken exponent_digits);
398 static ffesymbol ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin);
399 static ffesymbol ffeexpr_sym_impdoitem_ (ffesymbol s, ffelexToken t);
400 static ffesymbol ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t);
401 static ffesymbol ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t);
402 static ffesymbol ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t);
403 static ffesymbol ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t);
404 static ffesymbol ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t);
405 static ffesymbol ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t);
406 static ffesymbol ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t);
407 static ffesymbol ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t);
408 static ffesymbol ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t);
409 static ffesymbol ffeexpr_declare_parenthesized_ (ffelexToken t,
410 						 bool maybe_intrin,
411 					     ffeexprParenType_ *paren_type);
412 static ffesymbol ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t);
413 
414 /* Internal macros. */
415 
416 #define ffeexpr_paren_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
417 #define ffeexpr_sym_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
418 
419 /* ffeexpr_collapse_convert -- Collapse convert expr
420 
421    ffebld expr;
422    ffelexToken token;
423    expr = ffeexpr_collapse_convert(expr,token);
424 
425    If the result of the expr is a constant, replaces the expr with the
426    computed constant.  */
427 
428 ffebld
ffeexpr_collapse_convert(ffebld expr,ffelexToken t)429 ffeexpr_collapse_convert (ffebld expr, ffelexToken t)
430 {
431   ffebad error = FFEBAD;
432   ffebld l;
433   ffebldConstantUnion u;
434   ffeinfoBasictype bt;
435   ffeinfoKindtype kt;
436   ffetargetCharacterSize sz;
437   ffetargetCharacterSize sz2;
438 
439   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
440     return expr;
441 
442   l = ffebld_left (expr);
443 
444   if (ffebld_op (l) != FFEBLD_opCONTER)
445     return expr;
446 
447   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
448     {
449     case FFEINFO_basictypeANY:
450       return expr;
451 
452     case FFEINFO_basictypeINTEGER:
453       sz = FFETARGET_charactersizeNONE;
454       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
455 	{
456 #if FFETARGET_okINTEGER1
457 	case FFEINFO_kindtypeINTEGER1:
458 	  switch (ffeinfo_basictype (ffebld_info (l)))
459 	    {
460 	    case FFEINFO_basictypeINTEGER:
461 	      switch (ffeinfo_kindtype (ffebld_info (l)))
462 		{
463 #if FFETARGET_okINTEGER2
464 		case FFEINFO_kindtypeINTEGER2:
465 		  error = ffetarget_convert_integer1_integer2
466 		    (ffebld_cu_ptr_integer1 (u),
467 		     ffebld_constant_integer2 (ffebld_conter (l)));
468 		  break;
469 #endif
470 
471 #if FFETARGET_okINTEGER3
472 		case FFEINFO_kindtypeINTEGER3:
473 		  error = ffetarget_convert_integer1_integer3
474 		    (ffebld_cu_ptr_integer1 (u),
475 		     ffebld_constant_integer3 (ffebld_conter (l)));
476 		  break;
477 #endif
478 
479 #if FFETARGET_okINTEGER4
480 		case FFEINFO_kindtypeINTEGER4:
481 		  error = ffetarget_convert_integer1_integer4
482 		    (ffebld_cu_ptr_integer1 (u),
483 		     ffebld_constant_integer4 (ffebld_conter (l)));
484 		  break;
485 #endif
486 
487 		default:
488 		  assert ("INTEGER1/INTEGER bad source kind type" == NULL);
489 		  break;
490 		}
491 	      break;
492 
493 	    case FFEINFO_basictypeREAL:
494 	      switch (ffeinfo_kindtype (ffebld_info (l)))
495 		{
496 #if FFETARGET_okREAL1
497 		case FFEINFO_kindtypeREAL1:
498 		  error = ffetarget_convert_integer1_real1
499 		    (ffebld_cu_ptr_integer1 (u),
500 		     ffebld_constant_real1 (ffebld_conter (l)));
501 		  break;
502 #endif
503 
504 #if FFETARGET_okREAL2
505 		case FFEINFO_kindtypeREAL2:
506 		  error = ffetarget_convert_integer1_real2
507 		    (ffebld_cu_ptr_integer1 (u),
508 		     ffebld_constant_real2 (ffebld_conter (l)));
509 		  break;
510 #endif
511 
512 #if FFETARGET_okREAL3
513 		case FFEINFO_kindtypeREAL3:
514 		  error = ffetarget_convert_integer1_real3
515 		    (ffebld_cu_ptr_integer1 (u),
516 		     ffebld_constant_real3 (ffebld_conter (l)));
517 		  break;
518 #endif
519 
520 		default:
521 		  assert ("INTEGER1/REAL bad source kind type" == NULL);
522 		  break;
523 		}
524 	      break;
525 
526 	    case FFEINFO_basictypeCOMPLEX:
527 	      switch (ffeinfo_kindtype (ffebld_info (l)))
528 		{
529 #if FFETARGET_okCOMPLEX1
530 		case FFEINFO_kindtypeREAL1:
531 		  error = ffetarget_convert_integer1_complex1
532 		    (ffebld_cu_ptr_integer1 (u),
533 		     ffebld_constant_complex1 (ffebld_conter (l)));
534 		  break;
535 #endif
536 
537 #if FFETARGET_okCOMPLEX2
538 		case FFEINFO_kindtypeREAL2:
539 		  error = ffetarget_convert_integer1_complex2
540 		    (ffebld_cu_ptr_integer1 (u),
541 		     ffebld_constant_complex2 (ffebld_conter (l)));
542 		  break;
543 #endif
544 
545 #if FFETARGET_okCOMPLEX3
546 		case FFEINFO_kindtypeREAL3:
547 		  error = ffetarget_convert_integer1_complex3
548 		    (ffebld_cu_ptr_integer1 (u),
549 		     ffebld_constant_complex3 (ffebld_conter (l)));
550 		  break;
551 #endif
552 
553 		default:
554 		  assert ("INTEGER1/COMPLEX bad source kind type" == NULL);
555 		  break;
556 		}
557 	      break;
558 
559 	    case FFEINFO_basictypeLOGICAL:
560 	      switch (ffeinfo_kindtype (ffebld_info (l)))
561 		{
562 #if FFETARGET_okLOGICAL1
563 		case FFEINFO_kindtypeLOGICAL1:
564 		  error = ffetarget_convert_integer1_logical1
565 		    (ffebld_cu_ptr_integer1 (u),
566 		     ffebld_constant_logical1 (ffebld_conter (l)));
567 		  break;
568 #endif
569 
570 #if FFETARGET_okLOGICAL2
571 		case FFEINFO_kindtypeLOGICAL2:
572 		  error = ffetarget_convert_integer1_logical2
573 		    (ffebld_cu_ptr_integer1 (u),
574 		     ffebld_constant_logical2 (ffebld_conter (l)));
575 		  break;
576 #endif
577 
578 #if FFETARGET_okLOGICAL3
579 		case FFEINFO_kindtypeLOGICAL3:
580 		  error = ffetarget_convert_integer1_logical3
581 		    (ffebld_cu_ptr_integer1 (u),
582 		     ffebld_constant_logical3 (ffebld_conter (l)));
583 		  break;
584 #endif
585 
586 #if FFETARGET_okLOGICAL4
587 		case FFEINFO_kindtypeLOGICAL4:
588 		  error = ffetarget_convert_integer1_logical4
589 		    (ffebld_cu_ptr_integer1 (u),
590 		     ffebld_constant_logical4 (ffebld_conter (l)));
591 		  break;
592 #endif
593 
594 		default:
595 		  assert ("INTEGER1/LOGICAL bad source kind type" == NULL);
596 		  break;
597 		}
598 	      break;
599 
600 	    case FFEINFO_basictypeCHARACTER:
601 	      error = ffetarget_convert_integer1_character1
602 		(ffebld_cu_ptr_integer1 (u),
603 		 ffebld_constant_character1 (ffebld_conter (l)));
604 	      break;
605 
606 	    case FFEINFO_basictypeHOLLERITH:
607 	      error = ffetarget_convert_integer1_hollerith
608 		(ffebld_cu_ptr_integer1 (u),
609 		 ffebld_constant_hollerith (ffebld_conter (l)));
610 	      break;
611 
612 	    case FFEINFO_basictypeTYPELESS:
613 	      error = ffetarget_convert_integer1_typeless
614 		(ffebld_cu_ptr_integer1 (u),
615 		 ffebld_constant_typeless (ffebld_conter (l)));
616 	      break;
617 
618 	    default:
619 	      assert ("INTEGER1 bad type" == NULL);
620 	      break;
621 	    }
622 
623 	  /* If conversion operation is not implemented, return original expr.  */
624 	  if (error == FFEBAD_NOCANDO)
625 	    return expr;
626 
627 	  expr = ffebld_new_conter_with_orig
628 	    (ffebld_constant_new_integer1_val
629 	     (ffebld_cu_val_integer1 (u)), expr);
630 	  break;
631 #endif
632 
633 #if FFETARGET_okINTEGER2
634 	case FFEINFO_kindtypeINTEGER2:
635 	  switch (ffeinfo_basictype (ffebld_info (l)))
636 	    {
637 	    case FFEINFO_basictypeINTEGER:
638 	      switch (ffeinfo_kindtype (ffebld_info (l)))
639 		{
640 #if FFETARGET_okINTEGER1
641 		case FFEINFO_kindtypeINTEGER1:
642 		  error = ffetarget_convert_integer2_integer1
643 		    (ffebld_cu_ptr_integer2 (u),
644 		     ffebld_constant_integer1 (ffebld_conter (l)));
645 		  break;
646 #endif
647 
648 #if FFETARGET_okINTEGER3
649 		case FFEINFO_kindtypeINTEGER3:
650 		  error = ffetarget_convert_integer2_integer3
651 		    (ffebld_cu_ptr_integer2 (u),
652 		     ffebld_constant_integer3 (ffebld_conter (l)));
653 		  break;
654 #endif
655 
656 #if FFETARGET_okINTEGER4
657 		case FFEINFO_kindtypeINTEGER4:
658 		  error = ffetarget_convert_integer2_integer4
659 		    (ffebld_cu_ptr_integer2 (u),
660 		     ffebld_constant_integer4 (ffebld_conter (l)));
661 		  break;
662 #endif
663 
664 		default:
665 		  assert ("INTEGER2/INTEGER bad source kind type" == NULL);
666 		  break;
667 		}
668 	      break;
669 
670 	    case FFEINFO_basictypeREAL:
671 	      switch (ffeinfo_kindtype (ffebld_info (l)))
672 		{
673 #if FFETARGET_okREAL1
674 		case FFEINFO_kindtypeREAL1:
675 		  error = ffetarget_convert_integer2_real1
676 		    (ffebld_cu_ptr_integer2 (u),
677 		     ffebld_constant_real1 (ffebld_conter (l)));
678 		  break;
679 #endif
680 
681 #if FFETARGET_okREAL2
682 		case FFEINFO_kindtypeREAL2:
683 		  error = ffetarget_convert_integer2_real2
684 		    (ffebld_cu_ptr_integer2 (u),
685 		     ffebld_constant_real2 (ffebld_conter (l)));
686 		  break;
687 #endif
688 
689 #if FFETARGET_okREAL3
690 		case FFEINFO_kindtypeREAL3:
691 		  error = ffetarget_convert_integer2_real3
692 		    (ffebld_cu_ptr_integer2 (u),
693 		     ffebld_constant_real3 (ffebld_conter (l)));
694 		  break;
695 #endif
696 
697 		default:
698 		  assert ("INTEGER2/REAL bad source kind type" == NULL);
699 		  break;
700 		}
701 	      break;
702 
703 	    case FFEINFO_basictypeCOMPLEX:
704 	      switch (ffeinfo_kindtype (ffebld_info (l)))
705 		{
706 #if FFETARGET_okCOMPLEX1
707 		case FFEINFO_kindtypeREAL1:
708 		  error = ffetarget_convert_integer2_complex1
709 		    (ffebld_cu_ptr_integer2 (u),
710 		     ffebld_constant_complex1 (ffebld_conter (l)));
711 		  break;
712 #endif
713 
714 #if FFETARGET_okCOMPLEX2
715 		case FFEINFO_kindtypeREAL2:
716 		  error = ffetarget_convert_integer2_complex2
717 		    (ffebld_cu_ptr_integer2 (u),
718 		     ffebld_constant_complex2 (ffebld_conter (l)));
719 		  break;
720 #endif
721 
722 #if FFETARGET_okCOMPLEX3
723 		case FFEINFO_kindtypeREAL3:
724 		  error = ffetarget_convert_integer2_complex3
725 		    (ffebld_cu_ptr_integer2 (u),
726 		     ffebld_constant_complex3 (ffebld_conter (l)));
727 		  break;
728 #endif
729 
730 		default:
731 		  assert ("INTEGER2/COMPLEX bad source kind type" == NULL);
732 		  break;
733 		}
734 	      break;
735 
736 	    case FFEINFO_basictypeLOGICAL:
737 	      switch (ffeinfo_kindtype (ffebld_info (l)))
738 		{
739 #if FFETARGET_okLOGICAL1
740 		case FFEINFO_kindtypeLOGICAL1:
741 		  error = ffetarget_convert_integer2_logical1
742 		    (ffebld_cu_ptr_integer2 (u),
743 		     ffebld_constant_logical1 (ffebld_conter (l)));
744 		  break;
745 #endif
746 
747 #if FFETARGET_okLOGICAL2
748 		case FFEINFO_kindtypeLOGICAL2:
749 		  error = ffetarget_convert_integer2_logical2
750 		    (ffebld_cu_ptr_integer2 (u),
751 		     ffebld_constant_logical2 (ffebld_conter (l)));
752 		  break;
753 #endif
754 
755 #if FFETARGET_okLOGICAL3
756 		case FFEINFO_kindtypeLOGICAL3:
757 		  error = ffetarget_convert_integer2_logical3
758 		    (ffebld_cu_ptr_integer2 (u),
759 		     ffebld_constant_logical3 (ffebld_conter (l)));
760 		  break;
761 #endif
762 
763 #if FFETARGET_okLOGICAL4
764 		case FFEINFO_kindtypeLOGICAL4:
765 		  error = ffetarget_convert_integer2_logical4
766 		    (ffebld_cu_ptr_integer2 (u),
767 		     ffebld_constant_logical4 (ffebld_conter (l)));
768 		  break;
769 #endif
770 
771 		default:
772 		  assert ("INTEGER2/LOGICAL bad source kind type" == NULL);
773 		  break;
774 		}
775 	      break;
776 
777 	    case FFEINFO_basictypeCHARACTER:
778 	      error = ffetarget_convert_integer2_character1
779 		(ffebld_cu_ptr_integer2 (u),
780 		 ffebld_constant_character1 (ffebld_conter (l)));
781 	      break;
782 
783 	    case FFEINFO_basictypeHOLLERITH:
784 	      error = ffetarget_convert_integer2_hollerith
785 		(ffebld_cu_ptr_integer2 (u),
786 		 ffebld_constant_hollerith (ffebld_conter (l)));
787 	      break;
788 
789 	    case FFEINFO_basictypeTYPELESS:
790 	      error = ffetarget_convert_integer2_typeless
791 		(ffebld_cu_ptr_integer2 (u),
792 		 ffebld_constant_typeless (ffebld_conter (l)));
793 	      break;
794 
795 	    default:
796 	      assert ("INTEGER2 bad type" == NULL);
797 	      break;
798 	    }
799 
800 	  /* If conversion operation is not implemented, return original expr.  */
801 	  if (error == FFEBAD_NOCANDO)
802 	    return expr;
803 
804 	  expr = ffebld_new_conter_with_orig
805 	    (ffebld_constant_new_integer2_val
806 	     (ffebld_cu_val_integer2 (u)), expr);
807 	  break;
808 #endif
809 
810 #if FFETARGET_okINTEGER3
811 	case FFEINFO_kindtypeINTEGER3:
812 	  switch (ffeinfo_basictype (ffebld_info (l)))
813 	    {
814 	    case FFEINFO_basictypeINTEGER:
815 	      switch (ffeinfo_kindtype (ffebld_info (l)))
816 		{
817 #if FFETARGET_okINTEGER1
818 		case FFEINFO_kindtypeINTEGER1:
819 		  error = ffetarget_convert_integer3_integer1
820 		    (ffebld_cu_ptr_integer3 (u),
821 		     ffebld_constant_integer1 (ffebld_conter (l)));
822 		  break;
823 #endif
824 
825 #if FFETARGET_okINTEGER2
826 		case FFEINFO_kindtypeINTEGER2:
827 		  error = ffetarget_convert_integer3_integer2
828 		    (ffebld_cu_ptr_integer3 (u),
829 		     ffebld_constant_integer2 (ffebld_conter (l)));
830 		  break;
831 #endif
832 
833 #if FFETARGET_okINTEGER4
834 		case FFEINFO_kindtypeINTEGER4:
835 		  error = ffetarget_convert_integer3_integer4
836 		    (ffebld_cu_ptr_integer3 (u),
837 		     ffebld_constant_integer4 (ffebld_conter (l)));
838 		  break;
839 #endif
840 
841 		default:
842 		  assert ("INTEGER3/INTEGER bad source kind type" == NULL);
843 		  break;
844 		}
845 	      break;
846 
847 	    case FFEINFO_basictypeREAL:
848 	      switch (ffeinfo_kindtype (ffebld_info (l)))
849 		{
850 #if FFETARGET_okREAL1
851 		case FFEINFO_kindtypeREAL1:
852 		  error = ffetarget_convert_integer3_real1
853 		    (ffebld_cu_ptr_integer3 (u),
854 		     ffebld_constant_real1 (ffebld_conter (l)));
855 		  break;
856 #endif
857 
858 #if FFETARGET_okREAL2
859 		case FFEINFO_kindtypeREAL2:
860 		  error = ffetarget_convert_integer3_real2
861 		    (ffebld_cu_ptr_integer3 (u),
862 		     ffebld_constant_real2 (ffebld_conter (l)));
863 		  break;
864 #endif
865 
866 #if FFETARGET_okREAL3
867 		case FFEINFO_kindtypeREAL3:
868 		  error = ffetarget_convert_integer3_real3
869 		    (ffebld_cu_ptr_integer3 (u),
870 		     ffebld_constant_real3 (ffebld_conter (l)));
871 		  break;
872 #endif
873 
874 		default:
875 		  assert ("INTEGER3/REAL bad source kind type" == NULL);
876 		  break;
877 		}
878 	      break;
879 
880 	    case FFEINFO_basictypeCOMPLEX:
881 	      switch (ffeinfo_kindtype (ffebld_info (l)))
882 		{
883 #if FFETARGET_okCOMPLEX1
884 		case FFEINFO_kindtypeREAL1:
885 		  error = ffetarget_convert_integer3_complex1
886 		    (ffebld_cu_ptr_integer3 (u),
887 		     ffebld_constant_complex1 (ffebld_conter (l)));
888 		  break;
889 #endif
890 
891 #if FFETARGET_okCOMPLEX2
892 		case FFEINFO_kindtypeREAL2:
893 		  error = ffetarget_convert_integer3_complex2
894 		    (ffebld_cu_ptr_integer3 (u),
895 		     ffebld_constant_complex2 (ffebld_conter (l)));
896 		  break;
897 #endif
898 
899 #if FFETARGET_okCOMPLEX3
900 		case FFEINFO_kindtypeREAL3:
901 		  error = ffetarget_convert_integer3_complex3
902 		    (ffebld_cu_ptr_integer3 (u),
903 		     ffebld_constant_complex3 (ffebld_conter (l)));
904 		  break;
905 #endif
906 
907 		default:
908 		  assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
909 		  break;
910 		}
911 	      break;
912 
913 	    case FFEINFO_basictypeLOGICAL:
914 	      switch (ffeinfo_kindtype (ffebld_info (l)))
915 		{
916 #if FFETARGET_okLOGICAL1
917 		case FFEINFO_kindtypeLOGICAL1:
918 		  error = ffetarget_convert_integer3_logical1
919 		    (ffebld_cu_ptr_integer3 (u),
920 		     ffebld_constant_logical1 (ffebld_conter (l)));
921 		  break;
922 #endif
923 
924 #if FFETARGET_okLOGICAL2
925 		case FFEINFO_kindtypeLOGICAL2:
926 		  error = ffetarget_convert_integer3_logical2
927 		    (ffebld_cu_ptr_integer3 (u),
928 		     ffebld_constant_logical2 (ffebld_conter (l)));
929 		  break;
930 #endif
931 
932 #if FFETARGET_okLOGICAL3
933 		case FFEINFO_kindtypeLOGICAL3:
934 		  error = ffetarget_convert_integer3_logical3
935 		    (ffebld_cu_ptr_integer3 (u),
936 		     ffebld_constant_logical3 (ffebld_conter (l)));
937 		  break;
938 #endif
939 
940 #if FFETARGET_okLOGICAL4
941 		case FFEINFO_kindtypeLOGICAL4:
942 		  error = ffetarget_convert_integer3_logical4
943 		    (ffebld_cu_ptr_integer3 (u),
944 		     ffebld_constant_logical4 (ffebld_conter (l)));
945 		  break;
946 #endif
947 
948 		default:
949 		  assert ("INTEGER3/LOGICAL bad source kind type" == NULL);
950 		  break;
951 		}
952 	      break;
953 
954 	    case FFEINFO_basictypeCHARACTER:
955 	      error = ffetarget_convert_integer3_character1
956 		(ffebld_cu_ptr_integer3 (u),
957 		 ffebld_constant_character1 (ffebld_conter (l)));
958 	      break;
959 
960 	    case FFEINFO_basictypeHOLLERITH:
961 	      error = ffetarget_convert_integer3_hollerith
962 		(ffebld_cu_ptr_integer3 (u),
963 		 ffebld_constant_hollerith (ffebld_conter (l)));
964 	      break;
965 
966 	    case FFEINFO_basictypeTYPELESS:
967 	      error = ffetarget_convert_integer3_typeless
968 		(ffebld_cu_ptr_integer3 (u),
969 		 ffebld_constant_typeless (ffebld_conter (l)));
970 	      break;
971 
972 	    default:
973 	      assert ("INTEGER3 bad type" == NULL);
974 	      break;
975 	    }
976 
977 	  /* If conversion operation is not implemented, return original expr.  */
978 	  if (error == FFEBAD_NOCANDO)
979 	    return expr;
980 
981 	  expr = ffebld_new_conter_with_orig
982 	    (ffebld_constant_new_integer3_val
983 	     (ffebld_cu_val_integer3 (u)), expr);
984 	  break;
985 #endif
986 
987 #if FFETARGET_okINTEGER4
988 	case FFEINFO_kindtypeINTEGER4:
989 	  switch (ffeinfo_basictype (ffebld_info (l)))
990 	    {
991 	    case FFEINFO_basictypeINTEGER:
992 	      switch (ffeinfo_kindtype (ffebld_info (l)))
993 		{
994 #if FFETARGET_okINTEGER1
995 		case FFEINFO_kindtypeINTEGER1:
996 		  error = ffetarget_convert_integer4_integer1
997 		    (ffebld_cu_ptr_integer4 (u),
998 		     ffebld_constant_integer1 (ffebld_conter (l)));
999 		  break;
1000 #endif
1001 
1002 #if FFETARGET_okINTEGER2
1003 		case FFEINFO_kindtypeINTEGER2:
1004 		  error = ffetarget_convert_integer4_integer2
1005 		    (ffebld_cu_ptr_integer4 (u),
1006 		     ffebld_constant_integer2 (ffebld_conter (l)));
1007 		  break;
1008 #endif
1009 
1010 #if FFETARGET_okINTEGER3
1011 		case FFEINFO_kindtypeINTEGER3:
1012 		  error = ffetarget_convert_integer4_integer3
1013 		    (ffebld_cu_ptr_integer4 (u),
1014 		     ffebld_constant_integer3 (ffebld_conter (l)));
1015 		  break;
1016 #endif
1017 
1018 		default:
1019 		  assert ("INTEGER4/INTEGER bad source kind type" == NULL);
1020 		  break;
1021 		}
1022 	      break;
1023 
1024 	    case FFEINFO_basictypeREAL:
1025 	      switch (ffeinfo_kindtype (ffebld_info (l)))
1026 		{
1027 #if FFETARGET_okREAL1
1028 		case FFEINFO_kindtypeREAL1:
1029 		  error = ffetarget_convert_integer4_real1
1030 		    (ffebld_cu_ptr_integer4 (u),
1031 		     ffebld_constant_real1 (ffebld_conter (l)));
1032 		  break;
1033 #endif
1034 
1035 #if FFETARGET_okREAL2
1036 		case FFEINFO_kindtypeREAL2:
1037 		  error = ffetarget_convert_integer4_real2
1038 		    (ffebld_cu_ptr_integer4 (u),
1039 		     ffebld_constant_real2 (ffebld_conter (l)));
1040 		  break;
1041 #endif
1042 
1043 #if FFETARGET_okREAL3
1044 		case FFEINFO_kindtypeREAL3:
1045 		  error = ffetarget_convert_integer4_real3
1046 		    (ffebld_cu_ptr_integer4 (u),
1047 		     ffebld_constant_real3 (ffebld_conter (l)));
1048 		  break;
1049 #endif
1050 
1051 		default:
1052 		  assert ("INTEGER4/REAL bad source kind type" == NULL);
1053 		  break;
1054 		}
1055 	      break;
1056 
1057 	    case FFEINFO_basictypeCOMPLEX:
1058 	      switch (ffeinfo_kindtype (ffebld_info (l)))
1059 		{
1060 #if FFETARGET_okCOMPLEX1
1061 		case FFEINFO_kindtypeREAL1:
1062 		  error = ffetarget_convert_integer4_complex1
1063 		    (ffebld_cu_ptr_integer4 (u),
1064 		     ffebld_constant_complex1 (ffebld_conter (l)));
1065 		  break;
1066 #endif
1067 
1068 #if FFETARGET_okCOMPLEX2
1069 		case FFEINFO_kindtypeREAL2:
1070 		  error = ffetarget_convert_integer4_complex2
1071 		    (ffebld_cu_ptr_integer4 (u),
1072 		     ffebld_constant_complex2 (ffebld_conter (l)));
1073 		  break;
1074 #endif
1075 
1076 #if FFETARGET_okCOMPLEX3
1077 		case FFEINFO_kindtypeREAL3:
1078 		  error = ffetarget_convert_integer4_complex3
1079 		    (ffebld_cu_ptr_integer4 (u),
1080 		     ffebld_constant_complex3 (ffebld_conter (l)));
1081 		  break;
1082 #endif
1083 
1084 		default:
1085 		  assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
1086 		  break;
1087 		}
1088 	      break;
1089 
1090 	    case FFEINFO_basictypeLOGICAL:
1091 	      switch (ffeinfo_kindtype (ffebld_info (l)))
1092 		{
1093 #if FFETARGET_okLOGICAL1
1094 		case FFEINFO_kindtypeLOGICAL1:
1095 		  error = ffetarget_convert_integer4_logical1
1096 		    (ffebld_cu_ptr_integer4 (u),
1097 		     ffebld_constant_logical1 (ffebld_conter (l)));
1098 		  break;
1099 #endif
1100 
1101 #if FFETARGET_okLOGICAL2
1102 		case FFEINFO_kindtypeLOGICAL2:
1103 		  error = ffetarget_convert_integer4_logical2
1104 		    (ffebld_cu_ptr_integer4 (u),
1105 		     ffebld_constant_logical2 (ffebld_conter (l)));
1106 		  break;
1107 #endif
1108 
1109 #if FFETARGET_okLOGICAL3
1110 		case FFEINFO_kindtypeLOGICAL3:
1111 		  error = ffetarget_convert_integer4_logical3
1112 		    (ffebld_cu_ptr_integer4 (u),
1113 		     ffebld_constant_logical3 (ffebld_conter (l)));
1114 		  break;
1115 #endif
1116 
1117 #if FFETARGET_okLOGICAL4
1118 		case FFEINFO_kindtypeLOGICAL4:
1119 		  error = ffetarget_convert_integer4_logical4
1120 		    (ffebld_cu_ptr_integer4 (u),
1121 		     ffebld_constant_logical4 (ffebld_conter (l)));
1122 		  break;
1123 #endif
1124 
1125 		default:
1126 		  assert ("INTEGER4/LOGICAL bad source kind type" == NULL);
1127 		  break;
1128 		}
1129 	      break;
1130 
1131 	    case FFEINFO_basictypeCHARACTER:
1132 	      error = ffetarget_convert_integer4_character1
1133 		(ffebld_cu_ptr_integer4 (u),
1134 		 ffebld_constant_character1 (ffebld_conter (l)));
1135 	      break;
1136 
1137 	    case FFEINFO_basictypeHOLLERITH:
1138 	      error = ffetarget_convert_integer4_hollerith
1139 		(ffebld_cu_ptr_integer4 (u),
1140 		 ffebld_constant_hollerith (ffebld_conter (l)));
1141 	      break;
1142 
1143 	    case FFEINFO_basictypeTYPELESS:
1144 	      error = ffetarget_convert_integer4_typeless
1145 		(ffebld_cu_ptr_integer4 (u),
1146 		 ffebld_constant_typeless (ffebld_conter (l)));
1147 	      break;
1148 
1149 	    default:
1150 	      assert ("INTEGER4 bad type" == NULL);
1151 	      break;
1152 	    }
1153 
1154 	  /* If conversion operation is not implemented, return original expr.  */
1155 	  if (error == FFEBAD_NOCANDO)
1156 	    return expr;
1157 
1158 	  expr = ffebld_new_conter_with_orig
1159 	    (ffebld_constant_new_integer4_val
1160 	     (ffebld_cu_val_integer4 (u)), expr);
1161 	  break;
1162 #endif
1163 
1164 	default:
1165 	  assert ("bad integer kind type" == NULL);
1166 	  break;
1167 	}
1168       break;
1169 
1170     case FFEINFO_basictypeLOGICAL:
1171       sz = FFETARGET_charactersizeNONE;
1172       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1173 	{
1174 #if FFETARGET_okLOGICAL1
1175 	case FFEINFO_kindtypeLOGICAL1:
1176 	  switch (ffeinfo_basictype (ffebld_info (l)))
1177 	    {
1178 	    case FFEINFO_basictypeLOGICAL:
1179 	      switch (ffeinfo_kindtype (ffebld_info (l)))
1180 		{
1181 #if FFETARGET_okLOGICAL2
1182 		case FFEINFO_kindtypeLOGICAL2:
1183 		  error = ffetarget_convert_logical1_logical2
1184 		    (ffebld_cu_ptr_logical1 (u),
1185 		     ffebld_constant_logical2 (ffebld_conter (l)));
1186 		  break;
1187 #endif
1188 
1189 #if FFETARGET_okLOGICAL3
1190 		case FFEINFO_kindtypeLOGICAL3:
1191 		  error = ffetarget_convert_logical1_logical3
1192 		    (ffebld_cu_ptr_logical1 (u),
1193 		     ffebld_constant_logical3 (ffebld_conter (l)));
1194 		  break;
1195 #endif
1196 
1197 #if FFETARGET_okLOGICAL4
1198 		case FFEINFO_kindtypeLOGICAL4:
1199 		  error = ffetarget_convert_logical1_logical4
1200 		    (ffebld_cu_ptr_logical1 (u),
1201 		     ffebld_constant_logical4 (ffebld_conter (l)));
1202 		  break;
1203 #endif
1204 
1205 		default:
1206 		  assert ("LOGICAL1/LOGICAL bad source kind type" == NULL);
1207 		  break;
1208 		}
1209 	      break;
1210 
1211 	    case FFEINFO_basictypeINTEGER:
1212 	      switch (ffeinfo_kindtype (ffebld_info (l)))
1213 		{
1214 #if FFETARGET_okINTEGER1
1215 		case FFEINFO_kindtypeINTEGER1:
1216 		  error = ffetarget_convert_logical1_integer1
1217 		    (ffebld_cu_ptr_logical1 (u),
1218 		     ffebld_constant_integer1 (ffebld_conter (l)));
1219 		  break;
1220 #endif
1221 
1222 #if FFETARGET_okINTEGER2
1223 		case FFEINFO_kindtypeINTEGER2:
1224 		  error = ffetarget_convert_logical1_integer2
1225 		    (ffebld_cu_ptr_logical1 (u),
1226 		     ffebld_constant_integer2 (ffebld_conter (l)));
1227 		  break;
1228 #endif
1229 
1230 #if FFETARGET_okINTEGER3
1231 		case FFEINFO_kindtypeINTEGER3:
1232 		  error = ffetarget_convert_logical1_integer3
1233 		    (ffebld_cu_ptr_logical1 (u),
1234 		     ffebld_constant_integer3 (ffebld_conter (l)));
1235 		  break;
1236 #endif
1237 
1238 #if FFETARGET_okINTEGER4
1239 		case FFEINFO_kindtypeINTEGER4:
1240 		  error = ffetarget_convert_logical1_integer4
1241 		    (ffebld_cu_ptr_logical1 (u),
1242 		     ffebld_constant_integer4 (ffebld_conter (l)));
1243 		  break;
1244 #endif
1245 
1246 		default:
1247 		  assert ("LOGICAL1/INTEGER bad source kind type" == NULL);
1248 		  break;
1249 		}
1250 	      break;
1251 
1252 	    case FFEINFO_basictypeCHARACTER:
1253 	      error = ffetarget_convert_logical1_character1
1254 		(ffebld_cu_ptr_logical1 (u),
1255 		 ffebld_constant_character1 (ffebld_conter (l)));
1256 	      break;
1257 
1258 	    case FFEINFO_basictypeHOLLERITH:
1259 	      error = ffetarget_convert_logical1_hollerith
1260 		(ffebld_cu_ptr_logical1 (u),
1261 		 ffebld_constant_hollerith (ffebld_conter (l)));
1262 	      break;
1263 
1264 	    case FFEINFO_basictypeTYPELESS:
1265 	      error = ffetarget_convert_logical1_typeless
1266 		(ffebld_cu_ptr_logical1 (u),
1267 		 ffebld_constant_typeless (ffebld_conter (l)));
1268 	      break;
1269 
1270 	    default:
1271 	      assert ("LOGICAL1 bad type" == NULL);
1272 	      break;
1273 	    }
1274 
1275 	  /* If conversion operation is not implemented, return original expr.  */
1276 	  if (error == FFEBAD_NOCANDO)
1277 	    return expr;
1278 
1279 	  expr = ffebld_new_conter_with_orig
1280 	    (ffebld_constant_new_logical1_val
1281 	     (ffebld_cu_val_logical1 (u)), expr);
1282 	  break;
1283 #endif
1284 
1285 #if FFETARGET_okLOGICAL2
1286 	case FFEINFO_kindtypeLOGICAL2:
1287 	  switch (ffeinfo_basictype (ffebld_info (l)))
1288 	    {
1289 	    case FFEINFO_basictypeLOGICAL:
1290 	      switch (ffeinfo_kindtype (ffebld_info (l)))
1291 		{
1292 #if FFETARGET_okLOGICAL1
1293 		case FFEINFO_kindtypeLOGICAL1:
1294 		  error = ffetarget_convert_logical2_logical1
1295 		    (ffebld_cu_ptr_logical2 (u),
1296 		     ffebld_constant_logical1 (ffebld_conter (l)));
1297 		  break;
1298 #endif
1299 
1300 #if FFETARGET_okLOGICAL3
1301 		case FFEINFO_kindtypeLOGICAL3:
1302 		  error = ffetarget_convert_logical2_logical3
1303 		    (ffebld_cu_ptr_logical2 (u),
1304 		     ffebld_constant_logical3 (ffebld_conter (l)));
1305 		  break;
1306 #endif
1307 
1308 #if FFETARGET_okLOGICAL4
1309 		case FFEINFO_kindtypeLOGICAL4:
1310 		  error = ffetarget_convert_logical2_logical4
1311 		    (ffebld_cu_ptr_logical2 (u),
1312 		     ffebld_constant_logical4 (ffebld_conter (l)));
1313 		  break;
1314 #endif
1315 
1316 		default:
1317 		  assert ("LOGICAL2/LOGICAL bad source kind type" == NULL);
1318 		  break;
1319 		}
1320 	      break;
1321 
1322 	    case FFEINFO_basictypeINTEGER:
1323 	      switch (ffeinfo_kindtype (ffebld_info (l)))
1324 		{
1325 #if FFETARGET_okINTEGER1
1326 		case FFEINFO_kindtypeINTEGER1:
1327 		  error = ffetarget_convert_logical2_integer1
1328 		    (ffebld_cu_ptr_logical2 (u),
1329 		     ffebld_constant_integer1 (ffebld_conter (l)));
1330 		  break;
1331 #endif
1332 
1333 #if FFETARGET_okINTEGER2
1334 		case FFEINFO_kindtypeINTEGER2:
1335 		  error = ffetarget_convert_logical2_integer2
1336 		    (ffebld_cu_ptr_logical2 (u),
1337 		     ffebld_constant_integer2 (ffebld_conter (l)));
1338 		  break;
1339 #endif
1340 
1341 #if FFETARGET_okINTEGER3
1342 		case FFEINFO_kindtypeINTEGER3:
1343 		  error = ffetarget_convert_logical2_integer3
1344 		    (ffebld_cu_ptr_logical2 (u),
1345 		     ffebld_constant_integer3 (ffebld_conter (l)));
1346 		  break;
1347 #endif
1348 
1349 #if FFETARGET_okINTEGER4
1350 		case FFEINFO_kindtypeINTEGER4:
1351 		  error = ffetarget_convert_logical2_integer4
1352 		    (ffebld_cu_ptr_logical2 (u),
1353 		     ffebld_constant_integer4 (ffebld_conter (l)));
1354 		  break;
1355 #endif
1356 
1357 		default:
1358 		  assert ("LOGICAL2/INTEGER bad source kind type" == NULL);
1359 		  break;
1360 		}
1361 	      break;
1362 
1363 	    case FFEINFO_basictypeCHARACTER:
1364 	      error = ffetarget_convert_logical2_character1
1365 		(ffebld_cu_ptr_logical2 (u),
1366 		 ffebld_constant_character1 (ffebld_conter (l)));
1367 	      break;
1368 
1369 	    case FFEINFO_basictypeHOLLERITH:
1370 	      error = ffetarget_convert_logical2_hollerith
1371 		(ffebld_cu_ptr_logical2 (u),
1372 		 ffebld_constant_hollerith (ffebld_conter (l)));
1373 	      break;
1374 
1375 	    case FFEINFO_basictypeTYPELESS:
1376 	      error = ffetarget_convert_logical2_typeless
1377 		(ffebld_cu_ptr_logical2 (u),
1378 		 ffebld_constant_typeless (ffebld_conter (l)));
1379 	      break;
1380 
1381 	    default:
1382 	      assert ("LOGICAL2 bad type" == NULL);
1383 	      break;
1384 	    }
1385 
1386 	  /* If conversion operation is not implemented, return original expr.  */
1387 	  if (error == FFEBAD_NOCANDO)
1388 	    return expr;
1389 
1390 	  expr = ffebld_new_conter_with_orig
1391 	    (ffebld_constant_new_logical2_val
1392 	     (ffebld_cu_val_logical2 (u)), expr);
1393 	  break;
1394 #endif
1395 
1396 #if FFETARGET_okLOGICAL3
1397 	case FFEINFO_kindtypeLOGICAL3:
1398 	  switch (ffeinfo_basictype (ffebld_info (l)))
1399 	    {
1400 	    case FFEINFO_basictypeLOGICAL:
1401 	      switch (ffeinfo_kindtype (ffebld_info (l)))
1402 		{
1403 #if FFETARGET_okLOGICAL1
1404 		case FFEINFO_kindtypeLOGICAL1:
1405 		  error = ffetarget_convert_logical3_logical1
1406 		    (ffebld_cu_ptr_logical3 (u),
1407 		     ffebld_constant_logical1 (ffebld_conter (l)));
1408 		  break;
1409 #endif
1410 
1411 #if FFETARGET_okLOGICAL2
1412 		case FFEINFO_kindtypeLOGICAL2:
1413 		  error = ffetarget_convert_logical3_logical2
1414 		    (ffebld_cu_ptr_logical3 (u),
1415 		     ffebld_constant_logical2 (ffebld_conter (l)));
1416 		  break;
1417 #endif
1418 
1419 #if FFETARGET_okLOGICAL4
1420 		case FFEINFO_kindtypeLOGICAL4:
1421 		  error = ffetarget_convert_logical3_logical4
1422 		    (ffebld_cu_ptr_logical3 (u),
1423 		     ffebld_constant_logical4 (ffebld_conter (l)));
1424 		  break;
1425 #endif
1426 
1427 		default:
1428 		  assert ("LOGICAL3/LOGICAL bad source kind type" == NULL);
1429 		  break;
1430 		}
1431 	      break;
1432 
1433 	    case FFEINFO_basictypeINTEGER:
1434 	      switch (ffeinfo_kindtype (ffebld_info (l)))
1435 		{
1436 #if FFETARGET_okINTEGER1
1437 		case FFEINFO_kindtypeINTEGER1:
1438 		  error = ffetarget_convert_logical3_integer1
1439 		    (ffebld_cu_ptr_logical3 (u),
1440 		     ffebld_constant_integer1 (ffebld_conter (l)));
1441 		  break;
1442 #endif
1443 
1444 #if FFETARGET_okINTEGER2
1445 		case FFEINFO_kindtypeINTEGER2:
1446 		  error = ffetarget_convert_logical3_integer2
1447 		    (ffebld_cu_ptr_logical3 (u),
1448 		     ffebld_constant_integer2 (ffebld_conter (l)));
1449 		  break;
1450 #endif
1451 
1452 #if FFETARGET_okINTEGER3
1453 		case FFEINFO_kindtypeINTEGER3:
1454 		  error = ffetarget_convert_logical3_integer3
1455 		    (ffebld_cu_ptr_logical3 (u),
1456 		     ffebld_constant_integer3 (ffebld_conter (l)));
1457 		  break;
1458 #endif
1459 
1460 #if FFETARGET_okINTEGER4
1461 		case FFEINFO_kindtypeINTEGER4:
1462 		  error = ffetarget_convert_logical3_integer4
1463 		    (ffebld_cu_ptr_logical3 (u),
1464 		     ffebld_constant_integer4 (ffebld_conter (l)));
1465 		  break;
1466 #endif
1467 
1468 		default:
1469 		  assert ("LOGICAL3/INTEGER bad source kind type" == NULL);
1470 		  break;
1471 		}
1472 	      break;
1473 
1474 	    case FFEINFO_basictypeCHARACTER:
1475 	      error = ffetarget_convert_logical3_character1
1476 		(ffebld_cu_ptr_logical3 (u),
1477 		 ffebld_constant_character1 (ffebld_conter (l)));
1478 	      break;
1479 
1480 	    case FFEINFO_basictypeHOLLERITH:
1481 	      error = ffetarget_convert_logical3_hollerith
1482 		(ffebld_cu_ptr_logical3 (u),
1483 		 ffebld_constant_hollerith (ffebld_conter (l)));
1484 	      break;
1485 
1486 	    case FFEINFO_basictypeTYPELESS:
1487 	      error = ffetarget_convert_logical3_typeless
1488 		(ffebld_cu_ptr_logical3 (u),
1489 		 ffebld_constant_typeless (ffebld_conter (l)));
1490 	      break;
1491 
1492 	    default:
1493 	      assert ("LOGICAL3 bad type" == NULL);
1494 	      break;
1495 	    }
1496 
1497 	  /* If conversion operation is not implemented, return original expr.  */
1498 	  if (error == FFEBAD_NOCANDO)
1499 	    return expr;
1500 
1501 	  expr = ffebld_new_conter_with_orig
1502 	    (ffebld_constant_new_logical3_val
1503 	     (ffebld_cu_val_logical3 (u)), expr);
1504 	  break;
1505 #endif
1506 
1507 #if FFETARGET_okLOGICAL4
1508 	case FFEINFO_kindtypeLOGICAL4:
1509 	  switch (ffeinfo_basictype (ffebld_info (l)))
1510 	    {
1511 	    case FFEINFO_basictypeLOGICAL:
1512 	      switch (ffeinfo_kindtype (ffebld_info (l)))
1513 		{
1514 #if FFETARGET_okLOGICAL1
1515 		case FFEINFO_kindtypeLOGICAL1:
1516 		  error = ffetarget_convert_logical4_logical1
1517 		    (ffebld_cu_ptr_logical4 (u),
1518 		     ffebld_constant_logical1 (ffebld_conter (l)));
1519 		  break;
1520 #endif
1521 
1522 #if FFETARGET_okLOGICAL2
1523 		case FFEINFO_kindtypeLOGICAL2:
1524 		  error = ffetarget_convert_logical4_logical2
1525 		    (ffebld_cu_ptr_logical4 (u),
1526 		     ffebld_constant_logical2 (ffebld_conter (l)));
1527 		  break;
1528 #endif
1529 
1530 #if FFETARGET_okLOGICAL3
1531 		case FFEINFO_kindtypeLOGICAL3:
1532 		  error = ffetarget_convert_logical4_logical3
1533 		    (ffebld_cu_ptr_logical4 (u),
1534 		     ffebld_constant_logical3 (ffebld_conter (l)));
1535 		  break;
1536 #endif
1537 
1538 		default:
1539 		  assert ("LOGICAL4/LOGICAL bad source kind type" == NULL);
1540 		  break;
1541 		}
1542 	      break;
1543 
1544 	    case FFEINFO_basictypeINTEGER:
1545 	      switch (ffeinfo_kindtype (ffebld_info (l)))
1546 		{
1547 #if FFETARGET_okINTEGER1
1548 		case FFEINFO_kindtypeINTEGER1:
1549 		  error = ffetarget_convert_logical4_integer1
1550 		    (ffebld_cu_ptr_logical4 (u),
1551 		     ffebld_constant_integer1 (ffebld_conter (l)));
1552 		  break;
1553 #endif
1554 
1555 #if FFETARGET_okINTEGER2
1556 		case FFEINFO_kindtypeINTEGER2:
1557 		  error = ffetarget_convert_logical4_integer2
1558 		    (ffebld_cu_ptr_logical4 (u),
1559 		     ffebld_constant_integer2 (ffebld_conter (l)));
1560 		  break;
1561 #endif
1562 
1563 #if FFETARGET_okINTEGER3
1564 		case FFEINFO_kindtypeINTEGER3:
1565 		  error = ffetarget_convert_logical4_integer3
1566 		    (ffebld_cu_ptr_logical4 (u),
1567 		     ffebld_constant_integer3 (ffebld_conter (l)));
1568 		  break;
1569 #endif
1570 
1571 #if FFETARGET_okINTEGER4
1572 		case FFEINFO_kindtypeINTEGER4:
1573 		  error = ffetarget_convert_logical4_integer4
1574 		    (ffebld_cu_ptr_logical4 (u),
1575 		     ffebld_constant_integer4 (ffebld_conter (l)));
1576 		  break;
1577 #endif
1578 
1579 		default:
1580 		  assert ("LOGICAL4/INTEGER bad source kind type" == NULL);
1581 		  break;
1582 		}
1583 	      break;
1584 
1585 	    case FFEINFO_basictypeCHARACTER:
1586 	      error = ffetarget_convert_logical4_character1
1587 		(ffebld_cu_ptr_logical4 (u),
1588 		 ffebld_constant_character1 (ffebld_conter (l)));
1589 	      break;
1590 
1591 	    case FFEINFO_basictypeHOLLERITH:
1592 	      error = ffetarget_convert_logical4_hollerith
1593 		(ffebld_cu_ptr_logical4 (u),
1594 		 ffebld_constant_hollerith (ffebld_conter (l)));
1595 	      break;
1596 
1597 	    case FFEINFO_basictypeTYPELESS:
1598 	      error = ffetarget_convert_logical4_typeless
1599 		(ffebld_cu_ptr_logical4 (u),
1600 		 ffebld_constant_typeless (ffebld_conter (l)));
1601 	      break;
1602 
1603 	    default:
1604 	      assert ("LOGICAL4 bad type" == NULL);
1605 	      break;
1606 	    }
1607 
1608 	  /* If conversion operation is not implemented, return original expr.  */
1609 	  if (error == FFEBAD_NOCANDO)
1610 	    return expr;
1611 
1612 	  expr = ffebld_new_conter_with_orig
1613 	    (ffebld_constant_new_logical4_val
1614 	     (ffebld_cu_val_logical4 (u)), expr);
1615 	  break;
1616 #endif
1617 
1618 	default:
1619 	  assert ("bad logical kind type" == NULL);
1620 	  break;
1621 	}
1622       break;
1623 
1624     case FFEINFO_basictypeREAL:
1625       sz = FFETARGET_charactersizeNONE;
1626       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1627 	{
1628 #if FFETARGET_okREAL1
1629 	case FFEINFO_kindtypeREAL1:
1630 	  switch (ffeinfo_basictype (ffebld_info (l)))
1631 	    {
1632 	    case FFEINFO_basictypeINTEGER:
1633 	      switch (ffeinfo_kindtype (ffebld_info (l)))
1634 		{
1635 #if FFETARGET_okINTEGER1
1636 		case FFEINFO_kindtypeINTEGER1:
1637 		  error = ffetarget_convert_real1_integer1
1638 		    (ffebld_cu_ptr_real1 (u),
1639 		     ffebld_constant_integer1 (ffebld_conter (l)));
1640 		  break;
1641 #endif
1642 
1643 #if FFETARGET_okINTEGER2
1644 		case FFEINFO_kindtypeINTEGER2:
1645 		  error = ffetarget_convert_real1_integer2
1646 		    (ffebld_cu_ptr_real1 (u),
1647 		     ffebld_constant_integer2 (ffebld_conter (l)));
1648 		  break;
1649 #endif
1650 
1651 #if FFETARGET_okINTEGER3
1652 		case FFEINFO_kindtypeINTEGER3:
1653 		  error = ffetarget_convert_real1_integer3
1654 		    (ffebld_cu_ptr_real1 (u),
1655 		     ffebld_constant_integer3 (ffebld_conter (l)));
1656 		  break;
1657 #endif
1658 
1659 #if FFETARGET_okINTEGER4
1660 		case FFEINFO_kindtypeINTEGER4:
1661 		  error = ffetarget_convert_real1_integer4
1662 		    (ffebld_cu_ptr_real1 (u),
1663 		     ffebld_constant_integer4 (ffebld_conter (l)));
1664 		  break;
1665 #endif
1666 
1667 		default:
1668 		  assert ("REAL1/INTEGER bad source kind type" == NULL);
1669 		  break;
1670 		}
1671 	      break;
1672 
1673 	    case FFEINFO_basictypeREAL:
1674 	      switch (ffeinfo_kindtype (ffebld_info (l)))
1675 		{
1676 #if FFETARGET_okREAL2
1677 		case FFEINFO_kindtypeREAL2:
1678 		  error = ffetarget_convert_real1_real2
1679 		    (ffebld_cu_ptr_real1 (u),
1680 		     ffebld_constant_real2 (ffebld_conter (l)));
1681 		  break;
1682 #endif
1683 
1684 #if FFETARGET_okREAL3
1685 		case FFEINFO_kindtypeREAL3:
1686 		  error = ffetarget_convert_real1_real3
1687 		    (ffebld_cu_ptr_real1 (u),
1688 		     ffebld_constant_real3 (ffebld_conter (l)));
1689 		  break;
1690 #endif
1691 
1692 		default:
1693 		  assert ("REAL1/REAL bad source kind type" == NULL);
1694 		  break;
1695 		}
1696 	      break;
1697 
1698 	    case FFEINFO_basictypeCOMPLEX:
1699 	      switch (ffeinfo_kindtype (ffebld_info (l)))
1700 		{
1701 #if FFETARGET_okCOMPLEX1
1702 		case FFEINFO_kindtypeREAL1:
1703 		  error = ffetarget_convert_real1_complex1
1704 		    (ffebld_cu_ptr_real1 (u),
1705 		     ffebld_constant_complex1 (ffebld_conter (l)));
1706 		  break;
1707 #endif
1708 
1709 #if FFETARGET_okCOMPLEX2
1710 		case FFEINFO_kindtypeREAL2:
1711 		  error = ffetarget_convert_real1_complex2
1712 		    (ffebld_cu_ptr_real1 (u),
1713 		     ffebld_constant_complex2 (ffebld_conter (l)));
1714 		  break;
1715 #endif
1716 
1717 #if FFETARGET_okCOMPLEX3
1718 		case FFEINFO_kindtypeREAL3:
1719 		  error = ffetarget_convert_real1_complex3
1720 		    (ffebld_cu_ptr_real1 (u),
1721 		     ffebld_constant_complex3 (ffebld_conter (l)));
1722 		  break;
1723 #endif
1724 
1725 		default:
1726 		  assert ("REAL1/COMPLEX bad source kind type" == NULL);
1727 		  break;
1728 		}
1729 	      break;
1730 
1731 	    case FFEINFO_basictypeCHARACTER:
1732 	      error = ffetarget_convert_real1_character1
1733 		(ffebld_cu_ptr_real1 (u),
1734 		 ffebld_constant_character1 (ffebld_conter (l)));
1735 	      break;
1736 
1737 	    case FFEINFO_basictypeHOLLERITH:
1738 	      error = ffetarget_convert_real1_hollerith
1739 		(ffebld_cu_ptr_real1 (u),
1740 		 ffebld_constant_hollerith (ffebld_conter (l)));
1741 	      break;
1742 
1743 	    case FFEINFO_basictypeTYPELESS:
1744 	      error = ffetarget_convert_real1_typeless
1745 		(ffebld_cu_ptr_real1 (u),
1746 		 ffebld_constant_typeless (ffebld_conter (l)));
1747 	      break;
1748 
1749 	    default:
1750 	      assert ("REAL1 bad type" == NULL);
1751 	      break;
1752 	    }
1753 
1754 	  /* If conversion operation is not implemented, return original expr.  */
1755 	  if (error == FFEBAD_NOCANDO)
1756 	    return expr;
1757 
1758 	  expr = ffebld_new_conter_with_orig
1759 	    (ffebld_constant_new_real1_val
1760 	     (ffebld_cu_val_real1 (u)), expr);
1761 	  break;
1762 #endif
1763 
1764 #if FFETARGET_okREAL2
1765 	case FFEINFO_kindtypeREAL2:
1766 	  switch (ffeinfo_basictype (ffebld_info (l)))
1767 	    {
1768 	    case FFEINFO_basictypeINTEGER:
1769 	      switch (ffeinfo_kindtype (ffebld_info (l)))
1770 		{
1771 #if FFETARGET_okINTEGER1
1772 		case FFEINFO_kindtypeINTEGER1:
1773 		  error = ffetarget_convert_real2_integer1
1774 		    (ffebld_cu_ptr_real2 (u),
1775 		     ffebld_constant_integer1 (ffebld_conter (l)));
1776 		  break;
1777 #endif
1778 
1779 #if FFETARGET_okINTEGER2
1780 		case FFEINFO_kindtypeINTEGER2:
1781 		  error = ffetarget_convert_real2_integer2
1782 		    (ffebld_cu_ptr_real2 (u),
1783 		     ffebld_constant_integer2 (ffebld_conter (l)));
1784 		  break;
1785 #endif
1786 
1787 #if FFETARGET_okINTEGER3
1788 		case FFEINFO_kindtypeINTEGER3:
1789 		  error = ffetarget_convert_real2_integer3
1790 		    (ffebld_cu_ptr_real2 (u),
1791 		     ffebld_constant_integer3 (ffebld_conter (l)));
1792 		  break;
1793 #endif
1794 
1795 #if FFETARGET_okINTEGER4
1796 		case FFEINFO_kindtypeINTEGER4:
1797 		  error = ffetarget_convert_real2_integer4
1798 		    (ffebld_cu_ptr_real2 (u),
1799 		     ffebld_constant_integer4 (ffebld_conter (l)));
1800 		  break;
1801 #endif
1802 
1803 		default:
1804 		  assert ("REAL2/INTEGER bad source kind type" == NULL);
1805 		  break;
1806 		}
1807 	      break;
1808 
1809 	    case FFEINFO_basictypeREAL:
1810 	      switch (ffeinfo_kindtype (ffebld_info (l)))
1811 		{
1812 #if FFETARGET_okREAL1
1813 		case FFEINFO_kindtypeREAL1:
1814 		  error = ffetarget_convert_real2_real1
1815 		    (ffebld_cu_ptr_real2 (u),
1816 		     ffebld_constant_real1 (ffebld_conter (l)));
1817 		  break;
1818 #endif
1819 
1820 #if FFETARGET_okREAL3
1821 		case FFEINFO_kindtypeREAL3:
1822 		  error = ffetarget_convert_real2_real3
1823 		    (ffebld_cu_ptr_real2 (u),
1824 		     ffebld_constant_real3 (ffebld_conter (l)));
1825 		  break;
1826 #endif
1827 
1828 		default:
1829 		  assert ("REAL2/REAL bad source kind type" == NULL);
1830 		  break;
1831 		}
1832 	      break;
1833 
1834 	    case FFEINFO_basictypeCOMPLEX:
1835 	      switch (ffeinfo_kindtype (ffebld_info (l)))
1836 		{
1837 #if FFETARGET_okCOMPLEX1
1838 		case FFEINFO_kindtypeREAL1:
1839 		  error = ffetarget_convert_real2_complex1
1840 		    (ffebld_cu_ptr_real2 (u),
1841 		     ffebld_constant_complex1 (ffebld_conter (l)));
1842 		  break;
1843 #endif
1844 
1845 #if FFETARGET_okCOMPLEX2
1846 		case FFEINFO_kindtypeREAL2:
1847 		  error = ffetarget_convert_real2_complex2
1848 		    (ffebld_cu_ptr_real2 (u),
1849 		     ffebld_constant_complex2 (ffebld_conter (l)));
1850 		  break;
1851 #endif
1852 
1853 #if FFETARGET_okCOMPLEX3
1854 		case FFEINFO_kindtypeREAL3:
1855 		  error = ffetarget_convert_real2_complex3
1856 		    (ffebld_cu_ptr_real2 (u),
1857 		     ffebld_constant_complex3 (ffebld_conter (l)));
1858 		  break;
1859 #endif
1860 
1861 		default:
1862 		  assert ("REAL2/COMPLEX bad source kind type" == NULL);
1863 		  break;
1864 		}
1865 	      break;
1866 
1867 	    case FFEINFO_basictypeCHARACTER:
1868 	      error = ffetarget_convert_real2_character1
1869 		(ffebld_cu_ptr_real2 (u),
1870 		 ffebld_constant_character1 (ffebld_conter (l)));
1871 	      break;
1872 
1873 	    case FFEINFO_basictypeHOLLERITH:
1874 	      error = ffetarget_convert_real2_hollerith
1875 		(ffebld_cu_ptr_real2 (u),
1876 		 ffebld_constant_hollerith (ffebld_conter (l)));
1877 	      break;
1878 
1879 	    case FFEINFO_basictypeTYPELESS:
1880 	      error = ffetarget_convert_real2_typeless
1881 		(ffebld_cu_ptr_real2 (u),
1882 		 ffebld_constant_typeless (ffebld_conter (l)));
1883 	      break;
1884 
1885 	    default:
1886 	      assert ("REAL2 bad type" == NULL);
1887 	      break;
1888 	    }
1889 
1890 	  /* If conversion operation is not implemented, return original expr.  */
1891 	  if (error == FFEBAD_NOCANDO)
1892 	    return expr;
1893 
1894 	  expr = ffebld_new_conter_with_orig
1895 	    (ffebld_constant_new_real2_val
1896 	     (ffebld_cu_val_real2 (u)), expr);
1897 	  break;
1898 #endif
1899 
1900 #if FFETARGET_okREAL3
1901 	case FFEINFO_kindtypeREAL3:
1902 	  switch (ffeinfo_basictype (ffebld_info (l)))
1903 	    {
1904 	    case FFEINFO_basictypeINTEGER:
1905 	      switch (ffeinfo_kindtype (ffebld_info (l)))
1906 		{
1907 #if FFETARGET_okINTEGER1
1908 		case FFEINFO_kindtypeINTEGER1:
1909 		  error = ffetarget_convert_real3_integer1
1910 		    (ffebld_cu_ptr_real3 (u),
1911 		     ffebld_constant_integer1 (ffebld_conter (l)));
1912 		  break;
1913 #endif
1914 
1915 #if FFETARGET_okINTEGER2
1916 		case FFEINFO_kindtypeINTEGER2:
1917 		  error = ffetarget_convert_real3_integer2
1918 		    (ffebld_cu_ptr_real3 (u),
1919 		     ffebld_constant_integer2 (ffebld_conter (l)));
1920 		  break;
1921 #endif
1922 
1923 #if FFETARGET_okINTEGER3
1924 		case FFEINFO_kindtypeINTEGER3:
1925 		  error = ffetarget_convert_real3_integer3
1926 		    (ffebld_cu_ptr_real3 (u),
1927 		     ffebld_constant_integer3 (ffebld_conter (l)));
1928 		  break;
1929 #endif
1930 
1931 #if FFETARGET_okINTEGER4
1932 		case FFEINFO_kindtypeINTEGER4:
1933 		  error = ffetarget_convert_real3_integer4
1934 		    (ffebld_cu_ptr_real3 (u),
1935 		     ffebld_constant_integer4 (ffebld_conter (l)));
1936 		  break;
1937 #endif
1938 
1939 		default:
1940 		  assert ("REAL3/INTEGER bad source kind type" == NULL);
1941 		  break;
1942 		}
1943 	      break;
1944 
1945 	    case FFEINFO_basictypeREAL:
1946 	      switch (ffeinfo_kindtype (ffebld_info (l)))
1947 		{
1948 #if FFETARGET_okREAL1
1949 		case FFEINFO_kindtypeREAL1:
1950 		  error = ffetarget_convert_real3_real1
1951 		    (ffebld_cu_ptr_real3 (u),
1952 		     ffebld_constant_real1 (ffebld_conter (l)));
1953 		  break;
1954 #endif
1955 
1956 #if FFETARGET_okREAL2
1957 		case FFEINFO_kindtypeREAL2:
1958 		  error = ffetarget_convert_real3_real2
1959 		    (ffebld_cu_ptr_real3 (u),
1960 		     ffebld_constant_real2 (ffebld_conter (l)));
1961 		  break;
1962 #endif
1963 
1964 		default:
1965 		  assert ("REAL3/REAL bad source kind type" == NULL);
1966 		  break;
1967 		}
1968 	      break;
1969 
1970 	    case FFEINFO_basictypeCOMPLEX:
1971 	      switch (ffeinfo_kindtype (ffebld_info (l)))
1972 		{
1973 #if FFETARGET_okCOMPLEX1
1974 		case FFEINFO_kindtypeREAL1:
1975 		  error = ffetarget_convert_real3_complex1
1976 		    (ffebld_cu_ptr_real3 (u),
1977 		     ffebld_constant_complex1 (ffebld_conter (l)));
1978 		  break;
1979 #endif
1980 
1981 #if FFETARGET_okCOMPLEX2
1982 		case FFEINFO_kindtypeREAL2:
1983 		  error = ffetarget_convert_real3_complex2
1984 		    (ffebld_cu_ptr_real3 (u),
1985 		     ffebld_constant_complex2 (ffebld_conter (l)));
1986 		  break;
1987 #endif
1988 
1989 #if FFETARGET_okCOMPLEX3
1990 		case FFEINFO_kindtypeREAL3:
1991 		  error = ffetarget_convert_real3_complex3
1992 		    (ffebld_cu_ptr_real3 (u),
1993 		     ffebld_constant_complex3 (ffebld_conter (l)));
1994 		  break;
1995 #endif
1996 
1997 		default:
1998 		  assert ("REAL3/COMPLEX bad source kind type" == NULL);
1999 		  break;
2000 		}
2001 	      break;
2002 
2003 	    case FFEINFO_basictypeCHARACTER:
2004 	      error = ffetarget_convert_real3_character1
2005 		(ffebld_cu_ptr_real3 (u),
2006 		 ffebld_constant_character1 (ffebld_conter (l)));
2007 	      break;
2008 
2009 	    case FFEINFO_basictypeHOLLERITH:
2010 	      error = ffetarget_convert_real3_hollerith
2011 		(ffebld_cu_ptr_real3 (u),
2012 		 ffebld_constant_hollerith (ffebld_conter (l)));
2013 	      break;
2014 
2015 	    case FFEINFO_basictypeTYPELESS:
2016 	      error = ffetarget_convert_real3_typeless
2017 		(ffebld_cu_ptr_real3 (u),
2018 		 ffebld_constant_typeless (ffebld_conter (l)));
2019 	      break;
2020 
2021 	    default:
2022 	      assert ("REAL3 bad type" == NULL);
2023 	      break;
2024 	    }
2025 
2026 	  /* If conversion operation is not implemented, return original expr.  */
2027 	  if (error == FFEBAD_NOCANDO)
2028 	    return expr;
2029 
2030 	  expr = ffebld_new_conter_with_orig
2031 	    (ffebld_constant_new_real3_val
2032 	     (ffebld_cu_val_real3 (u)), expr);
2033 	  break;
2034 #endif
2035 
2036 	default:
2037 	  assert ("bad real kind type" == NULL);
2038 	  break;
2039 	}
2040       break;
2041 
2042     case FFEINFO_basictypeCOMPLEX:
2043       sz = FFETARGET_charactersizeNONE;
2044       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2045 	{
2046 #if FFETARGET_okCOMPLEX1
2047 	case FFEINFO_kindtypeREAL1:
2048 	  switch (ffeinfo_basictype (ffebld_info (l)))
2049 	    {
2050 	    case FFEINFO_basictypeINTEGER:
2051 	      switch (ffeinfo_kindtype (ffebld_info (l)))
2052 		{
2053 #if FFETARGET_okINTEGER1
2054 		case FFEINFO_kindtypeINTEGER1:
2055 		  error = ffetarget_convert_complex1_integer1
2056 		    (ffebld_cu_ptr_complex1 (u),
2057 		     ffebld_constant_integer1 (ffebld_conter (l)));
2058 		  break;
2059 #endif
2060 
2061 #if FFETARGET_okINTEGER2
2062 		case FFEINFO_kindtypeINTEGER2:
2063 		  error = ffetarget_convert_complex1_integer2
2064 		    (ffebld_cu_ptr_complex1 (u),
2065 		     ffebld_constant_integer2 (ffebld_conter (l)));
2066 		  break;
2067 #endif
2068 
2069 #if FFETARGET_okINTEGER3
2070 		case FFEINFO_kindtypeINTEGER3:
2071 		  error = ffetarget_convert_complex1_integer3
2072 		    (ffebld_cu_ptr_complex1 (u),
2073 		     ffebld_constant_integer3 (ffebld_conter (l)));
2074 		  break;
2075 #endif
2076 
2077 #if FFETARGET_okINTEGER4
2078 		case FFEINFO_kindtypeINTEGER4:
2079 		  error = ffetarget_convert_complex1_integer4
2080 		    (ffebld_cu_ptr_complex1 (u),
2081 		     ffebld_constant_integer4 (ffebld_conter (l)));
2082 		  break;
2083 #endif
2084 
2085 		default:
2086 		  assert ("COMPLEX1/INTEGER bad source kind type" == NULL);
2087 		  break;
2088 		}
2089 	      break;
2090 
2091 	    case FFEINFO_basictypeREAL:
2092 	      switch (ffeinfo_kindtype (ffebld_info (l)))
2093 		{
2094 #if FFETARGET_okREAL1
2095 		case FFEINFO_kindtypeREAL1:
2096 		  error = ffetarget_convert_complex1_real1
2097 		    (ffebld_cu_ptr_complex1 (u),
2098 		     ffebld_constant_real1 (ffebld_conter (l)));
2099 		  break;
2100 #endif
2101 
2102 #if FFETARGET_okREAL2
2103 		case FFEINFO_kindtypeREAL2:
2104 		  error = ffetarget_convert_complex1_real2
2105 		    (ffebld_cu_ptr_complex1 (u),
2106 		     ffebld_constant_real2 (ffebld_conter (l)));
2107 		  break;
2108 #endif
2109 
2110 #if FFETARGET_okREAL3
2111 		case FFEINFO_kindtypeREAL3:
2112 		  error = ffetarget_convert_complex1_real3
2113 		    (ffebld_cu_ptr_complex1 (u),
2114 		     ffebld_constant_real3 (ffebld_conter (l)));
2115 		  break;
2116 #endif
2117 
2118 		default:
2119 		  assert ("COMPLEX1/REAL bad source kind type" == NULL);
2120 		  break;
2121 		}
2122 	      break;
2123 
2124 	    case FFEINFO_basictypeCOMPLEX:
2125 	      switch (ffeinfo_kindtype (ffebld_info (l)))
2126 		{
2127 #if FFETARGET_okCOMPLEX2
2128 		case FFEINFO_kindtypeREAL2:
2129 		  error = ffetarget_convert_complex1_complex2
2130 		    (ffebld_cu_ptr_complex1 (u),
2131 		     ffebld_constant_complex2 (ffebld_conter (l)));
2132 		  break;
2133 #endif
2134 
2135 #if FFETARGET_okCOMPLEX3
2136 		case FFEINFO_kindtypeREAL3:
2137 		  error = ffetarget_convert_complex1_complex3
2138 		    (ffebld_cu_ptr_complex1 (u),
2139 		     ffebld_constant_complex3 (ffebld_conter (l)));
2140 		  break;
2141 #endif
2142 
2143 		default:
2144 		  assert ("COMPLEX1/COMPLEX bad source kind type" == NULL);
2145 		  break;
2146 		}
2147 	      break;
2148 
2149 	    case FFEINFO_basictypeCHARACTER:
2150 	      error = ffetarget_convert_complex1_character1
2151 		(ffebld_cu_ptr_complex1 (u),
2152 		 ffebld_constant_character1 (ffebld_conter (l)));
2153 	      break;
2154 
2155 	    case FFEINFO_basictypeHOLLERITH:
2156 	      error = ffetarget_convert_complex1_hollerith
2157 		(ffebld_cu_ptr_complex1 (u),
2158 		 ffebld_constant_hollerith (ffebld_conter (l)));
2159 	      break;
2160 
2161 	    case FFEINFO_basictypeTYPELESS:
2162 	      error = ffetarget_convert_complex1_typeless
2163 		(ffebld_cu_ptr_complex1 (u),
2164 		 ffebld_constant_typeless (ffebld_conter (l)));
2165 	      break;
2166 
2167 	    default:
2168 	      assert ("COMPLEX1 bad type" == NULL);
2169 	      break;
2170 	    }
2171 
2172 	  /* If conversion operation is not implemented, return original expr.  */
2173 	  if (error == FFEBAD_NOCANDO)
2174 	    return expr;
2175 
2176 	  expr = ffebld_new_conter_with_orig
2177 	    (ffebld_constant_new_complex1_val
2178 	     (ffebld_cu_val_complex1 (u)), expr);
2179 	  break;
2180 #endif
2181 
2182 #if FFETARGET_okCOMPLEX2
2183 	case FFEINFO_kindtypeREAL2:
2184 	  switch (ffeinfo_basictype (ffebld_info (l)))
2185 	    {
2186 	    case FFEINFO_basictypeINTEGER:
2187 	      switch (ffeinfo_kindtype (ffebld_info (l)))
2188 		{
2189 #if FFETARGET_okINTEGER1
2190 		case FFEINFO_kindtypeINTEGER1:
2191 		  error = ffetarget_convert_complex2_integer1
2192 		    (ffebld_cu_ptr_complex2 (u),
2193 		     ffebld_constant_integer1 (ffebld_conter (l)));
2194 		  break;
2195 #endif
2196 
2197 #if FFETARGET_okINTEGER2
2198 		case FFEINFO_kindtypeINTEGER2:
2199 		  error = ffetarget_convert_complex2_integer2
2200 		    (ffebld_cu_ptr_complex2 (u),
2201 		     ffebld_constant_integer2 (ffebld_conter (l)));
2202 		  break;
2203 #endif
2204 
2205 #if FFETARGET_okINTEGER3
2206 		case FFEINFO_kindtypeINTEGER3:
2207 		  error = ffetarget_convert_complex2_integer3
2208 		    (ffebld_cu_ptr_complex2 (u),
2209 		     ffebld_constant_integer3 (ffebld_conter (l)));
2210 		  break;
2211 #endif
2212 
2213 #if FFETARGET_okINTEGER4
2214 		case FFEINFO_kindtypeINTEGER4:
2215 		  error = ffetarget_convert_complex2_integer4
2216 		    (ffebld_cu_ptr_complex2 (u),
2217 		     ffebld_constant_integer4 (ffebld_conter (l)));
2218 		  break;
2219 #endif
2220 
2221 		default:
2222 		  assert ("COMPLEX2/INTEGER bad source kind type" == NULL);
2223 		  break;
2224 		}
2225 	      break;
2226 
2227 	    case FFEINFO_basictypeREAL:
2228 	      switch (ffeinfo_kindtype (ffebld_info (l)))
2229 		{
2230 #if FFETARGET_okREAL1
2231 		case FFEINFO_kindtypeREAL1:
2232 		  error = ffetarget_convert_complex2_real1
2233 		    (ffebld_cu_ptr_complex2 (u),
2234 		     ffebld_constant_real1 (ffebld_conter (l)));
2235 		  break;
2236 #endif
2237 
2238 #if FFETARGET_okREAL2
2239 		case FFEINFO_kindtypeREAL2:
2240 		  error = ffetarget_convert_complex2_real2
2241 		    (ffebld_cu_ptr_complex2 (u),
2242 		     ffebld_constant_real2 (ffebld_conter (l)));
2243 		  break;
2244 #endif
2245 
2246 #if FFETARGET_okREAL3
2247 		case FFEINFO_kindtypeREAL3:
2248 		  error = ffetarget_convert_complex2_real3
2249 		    (ffebld_cu_ptr_complex2 (u),
2250 		     ffebld_constant_real3 (ffebld_conter (l)));
2251 		  break;
2252 #endif
2253 
2254 		default:
2255 		  assert ("COMPLEX2/REAL bad source kind type" == NULL);
2256 		  break;
2257 		}
2258 	      break;
2259 
2260 	    case FFEINFO_basictypeCOMPLEX:
2261 	      switch (ffeinfo_kindtype (ffebld_info (l)))
2262 		{
2263 #if FFETARGET_okCOMPLEX1
2264 		case FFEINFO_kindtypeREAL1:
2265 		  error = ffetarget_convert_complex2_complex1
2266 		    (ffebld_cu_ptr_complex2 (u),
2267 		     ffebld_constant_complex1 (ffebld_conter (l)));
2268 		  break;
2269 #endif
2270 
2271 #if FFETARGET_okCOMPLEX3
2272 		case FFEINFO_kindtypeREAL3:
2273 		  error = ffetarget_convert_complex2_complex3
2274 		    (ffebld_cu_ptr_complex2 (u),
2275 		     ffebld_constant_complex3 (ffebld_conter (l)));
2276 		  break;
2277 #endif
2278 
2279 		default:
2280 		  assert ("COMPLEX2/COMPLEX bad source kind type" == NULL);
2281 		  break;
2282 		}
2283 	      break;
2284 
2285 	    case FFEINFO_basictypeCHARACTER:
2286 	      error = ffetarget_convert_complex2_character1
2287 		(ffebld_cu_ptr_complex2 (u),
2288 		 ffebld_constant_character1 (ffebld_conter (l)));
2289 	      break;
2290 
2291 	    case FFEINFO_basictypeHOLLERITH:
2292 	      error = ffetarget_convert_complex2_hollerith
2293 		(ffebld_cu_ptr_complex2 (u),
2294 		 ffebld_constant_hollerith (ffebld_conter (l)));
2295 	      break;
2296 
2297 	    case FFEINFO_basictypeTYPELESS:
2298 	      error = ffetarget_convert_complex2_typeless
2299 		(ffebld_cu_ptr_complex2 (u),
2300 		 ffebld_constant_typeless (ffebld_conter (l)));
2301 	      break;
2302 
2303 	    default:
2304 	      assert ("COMPLEX2 bad type" == NULL);
2305 	      break;
2306 	    }
2307 
2308 	  /* If conversion operation is not implemented, return original expr.  */
2309 	  if (error == FFEBAD_NOCANDO)
2310 	    return expr;
2311 
2312 	  expr = ffebld_new_conter_with_orig
2313 	    (ffebld_constant_new_complex2_val
2314 	     (ffebld_cu_val_complex2 (u)), expr);
2315 	  break;
2316 #endif
2317 
2318 #if FFETARGET_okCOMPLEX3
2319 	case FFEINFO_kindtypeREAL3:
2320 	  switch (ffeinfo_basictype (ffebld_info (l)))
2321 	    {
2322 	    case FFEINFO_basictypeINTEGER:
2323 	      switch (ffeinfo_kindtype (ffebld_info (l)))
2324 		{
2325 #if FFETARGET_okINTEGER1
2326 		case FFEINFO_kindtypeINTEGER1:
2327 		  error = ffetarget_convert_complex3_integer1
2328 		    (ffebld_cu_ptr_complex3 (u),
2329 		     ffebld_constant_integer1 (ffebld_conter (l)));
2330 		  break;
2331 #endif
2332 
2333 #if FFETARGET_okINTEGER2
2334 		case FFEINFO_kindtypeINTEGER2:
2335 		  error = ffetarget_convert_complex3_integer2
2336 		    (ffebld_cu_ptr_complex3 (u),
2337 		     ffebld_constant_integer2 (ffebld_conter (l)));
2338 		  break;
2339 #endif
2340 
2341 #if FFETARGET_okINTEGER3
2342 		case FFEINFO_kindtypeINTEGER3:
2343 		  error = ffetarget_convert_complex3_integer3
2344 		    (ffebld_cu_ptr_complex3 (u),
2345 		     ffebld_constant_integer3 (ffebld_conter (l)));
2346 		  break;
2347 #endif
2348 
2349 #if FFETARGET_okINTEGER4
2350 		case FFEINFO_kindtypeINTEGER4:
2351 		  error = ffetarget_convert_complex3_integer4
2352 		    (ffebld_cu_ptr_complex3 (u),
2353 		     ffebld_constant_integer4 (ffebld_conter (l)));
2354 		  break;
2355 #endif
2356 
2357 		default:
2358 		  assert ("COMPLEX3/INTEGER bad source kind type" == NULL);
2359 		  break;
2360 		}
2361 	      break;
2362 
2363 	    case FFEINFO_basictypeREAL:
2364 	      switch (ffeinfo_kindtype (ffebld_info (l)))
2365 		{
2366 #if FFETARGET_okREAL1
2367 		case FFEINFO_kindtypeREAL1:
2368 		  error = ffetarget_convert_complex3_real1
2369 		    (ffebld_cu_ptr_complex3 (u),
2370 		     ffebld_constant_real1 (ffebld_conter (l)));
2371 		  break;
2372 #endif
2373 
2374 #if FFETARGET_okREAL2
2375 		case FFEINFO_kindtypeREAL2:
2376 		  error = ffetarget_convert_complex3_real2
2377 		    (ffebld_cu_ptr_complex3 (u),
2378 		     ffebld_constant_real2 (ffebld_conter (l)));
2379 		  break;
2380 #endif
2381 
2382 #if FFETARGET_okREAL3
2383 		case FFEINFO_kindtypeREAL3:
2384 		  error = ffetarget_convert_complex3_real3
2385 		    (ffebld_cu_ptr_complex3 (u),
2386 		     ffebld_constant_real3 (ffebld_conter (l)));
2387 		  break;
2388 #endif
2389 
2390 		default:
2391 		  assert ("COMPLEX3/REAL bad source kind type" == NULL);
2392 		  break;
2393 		}
2394 	      break;
2395 
2396 	    case FFEINFO_basictypeCOMPLEX:
2397 	      switch (ffeinfo_kindtype (ffebld_info (l)))
2398 		{
2399 #if FFETARGET_okCOMPLEX1
2400 		case FFEINFO_kindtypeREAL1:
2401 		  error = ffetarget_convert_complex3_complex1
2402 		    (ffebld_cu_ptr_complex3 (u),
2403 		     ffebld_constant_complex1 (ffebld_conter (l)));
2404 		  break;
2405 #endif
2406 
2407 #if FFETARGET_okCOMPLEX2
2408 		case FFEINFO_kindtypeREAL2:
2409 		  error = ffetarget_convert_complex3_complex2
2410 		    (ffebld_cu_ptr_complex3 (u),
2411 		     ffebld_constant_complex2 (ffebld_conter (l)));
2412 		  break;
2413 #endif
2414 
2415 		default:
2416 		  assert ("COMPLEX3/COMPLEX bad source kind type" == NULL);
2417 		  break;
2418 		}
2419 	      break;
2420 
2421 	    case FFEINFO_basictypeCHARACTER:
2422 	      error = ffetarget_convert_complex3_character1
2423 		(ffebld_cu_ptr_complex3 (u),
2424 		 ffebld_constant_character1 (ffebld_conter (l)));
2425 	      break;
2426 
2427 	    case FFEINFO_basictypeHOLLERITH:
2428 	      error = ffetarget_convert_complex3_hollerith
2429 		(ffebld_cu_ptr_complex3 (u),
2430 		 ffebld_constant_hollerith (ffebld_conter (l)));
2431 	      break;
2432 
2433 	    case FFEINFO_basictypeTYPELESS:
2434 	      error = ffetarget_convert_complex3_typeless
2435 		(ffebld_cu_ptr_complex3 (u),
2436 		 ffebld_constant_typeless (ffebld_conter (l)));
2437 	      break;
2438 
2439 	    default:
2440 	      assert ("COMPLEX3 bad type" == NULL);
2441 	      break;
2442 	    }
2443 
2444 	  /* If conversion operation is not implemented, return original expr.  */
2445 	  if (error == FFEBAD_NOCANDO)
2446 	    return expr;
2447 
2448 	  expr = ffebld_new_conter_with_orig
2449 	    (ffebld_constant_new_complex3_val
2450 	     (ffebld_cu_val_complex3 (u)), expr);
2451 	  break;
2452 #endif
2453 
2454 	default:
2455 	  assert ("bad complex kind type" == NULL);
2456 	  break;
2457 	}
2458       break;
2459 
2460     case FFEINFO_basictypeCHARACTER:
2461       if ((sz = ffebld_size (expr)) == FFETARGET_charactersizeNONE)
2462 	return expr;
2463       kt = ffeinfo_kindtype (ffebld_info (expr));
2464       switch (kt)
2465 	{
2466 #if FFETARGET_okCHARACTER1
2467 	case FFEINFO_kindtypeCHARACTER1:
2468 	  switch (ffeinfo_basictype (ffebld_info (l)))
2469 	    {
2470 	    case FFEINFO_basictypeCHARACTER:
2471 	      if ((sz2 = ffebld_size (l)) == FFETARGET_charactersizeNONE)
2472 		return expr;
2473 	      assert (kt == ffeinfo_kindtype (ffebld_info (l)));
2474 	      assert (sz2 == ffetarget_length_character1
2475 		      (ffebld_constant_character1
2476 		       (ffebld_conter (l))));
2477 	      error
2478 		= ffetarget_convert_character1_character1
2479 		(ffebld_cu_ptr_character1 (u), sz,
2480 		 ffebld_constant_character1 (ffebld_conter (l)),
2481 		 ffebld_constant_pool ());
2482 	      break;
2483 
2484 	    case FFEINFO_basictypeINTEGER:
2485 	      switch (ffeinfo_kindtype (ffebld_info (l)))
2486 		{
2487 #if FFETARGET_okINTEGER1
2488 		case FFEINFO_kindtypeINTEGER1:
2489 		  error
2490 		    = ffetarget_convert_character1_integer1
2491 		      (ffebld_cu_ptr_character1 (u),
2492 		       sz,
2493 		       ffebld_constant_integer1 (ffebld_conter (l)),
2494 		       ffebld_constant_pool ());
2495 		  break;
2496 #endif
2497 
2498 #if FFETARGET_okINTEGER2
2499 		case FFEINFO_kindtypeINTEGER2:
2500 		  error
2501 		    = ffetarget_convert_character1_integer2
2502 		      (ffebld_cu_ptr_character1 (u),
2503 		       sz,
2504 		       ffebld_constant_integer2 (ffebld_conter (l)),
2505 		       ffebld_constant_pool ());
2506 		  break;
2507 #endif
2508 
2509 #if FFETARGET_okINTEGER3
2510 		case FFEINFO_kindtypeINTEGER3:
2511 		  error
2512 		    = ffetarget_convert_character1_integer3
2513 		      (ffebld_cu_ptr_character1 (u),
2514 		       sz,
2515 		       ffebld_constant_integer3 (ffebld_conter (l)),
2516 		       ffebld_constant_pool ());
2517 		  break;
2518 #endif
2519 
2520 #if FFETARGET_okINTEGER4
2521 		case FFEINFO_kindtypeINTEGER4:
2522 		  error
2523 		    = ffetarget_convert_character1_integer4
2524 		      (ffebld_cu_ptr_character1 (u),
2525 		       sz,
2526 		       ffebld_constant_integer4 (ffebld_conter (l)),
2527 		       ffebld_constant_pool ());
2528 		  break;
2529 #endif
2530 
2531 		default:
2532 		  assert ("CHARACTER1/INTEGER bad source kind type" == NULL);
2533 		  break;
2534 		}
2535 	      break;
2536 
2537 	    case FFEINFO_basictypeLOGICAL:
2538 	      switch (ffeinfo_kindtype (ffebld_info (l)))
2539 		{
2540 #if FFETARGET_okLOGICAL1
2541 		case FFEINFO_kindtypeLOGICAL1:
2542 		  error
2543 		    = ffetarget_convert_character1_logical1
2544 		      (ffebld_cu_ptr_character1 (u),
2545 		       sz,
2546 		       ffebld_constant_logical1 (ffebld_conter (l)),
2547 		       ffebld_constant_pool ());
2548 		  break;
2549 #endif
2550 
2551 #if FFETARGET_okLOGICAL2
2552 		case FFEINFO_kindtypeLOGICAL2:
2553 		  error
2554 		    = ffetarget_convert_character1_logical2
2555 		      (ffebld_cu_ptr_character1 (u),
2556 		       sz,
2557 		       ffebld_constant_logical2 (ffebld_conter (l)),
2558 		       ffebld_constant_pool ());
2559 		  break;
2560 #endif
2561 
2562 #if FFETARGET_okLOGICAL3
2563 		case FFEINFO_kindtypeLOGICAL3:
2564 		  error
2565 		    = ffetarget_convert_character1_logical3
2566 		      (ffebld_cu_ptr_character1 (u),
2567 		       sz,
2568 		       ffebld_constant_logical3 (ffebld_conter (l)),
2569 		       ffebld_constant_pool ());
2570 		  break;
2571 #endif
2572 
2573 #if FFETARGET_okLOGICAL4
2574 		case FFEINFO_kindtypeLOGICAL4:
2575 		  error
2576 		    = ffetarget_convert_character1_logical4
2577 		      (ffebld_cu_ptr_character1 (u),
2578 		       sz,
2579 		       ffebld_constant_logical4 (ffebld_conter (l)),
2580 		       ffebld_constant_pool ());
2581 		  break;
2582 #endif
2583 
2584 		default:
2585 		  assert ("CHARACTER1/LOGICAL bad source kind type" == NULL);
2586 		  break;
2587 		}
2588 	      break;
2589 
2590 	    case FFEINFO_basictypeHOLLERITH:
2591 	      error
2592 		= ffetarget_convert_character1_hollerith
2593 		(ffebld_cu_ptr_character1 (u),
2594 		 sz,
2595 		 ffebld_constant_hollerith (ffebld_conter (l)),
2596 		 ffebld_constant_pool ());
2597 	      break;
2598 
2599 	    case FFEINFO_basictypeTYPELESS:
2600 	      error
2601 		= ffetarget_convert_character1_typeless
2602 		(ffebld_cu_ptr_character1 (u),
2603 		 sz,
2604 		 ffebld_constant_typeless (ffebld_conter (l)),
2605 		 ffebld_constant_pool ());
2606 	      break;
2607 
2608 	    default:
2609 	      assert ("CHARACTER1 bad type" == NULL);
2610 	    }
2611 
2612 	  expr
2613 	    = ffebld_new_conter_with_orig
2614 	    (ffebld_constant_new_character1_val
2615 	     (ffebld_cu_val_character1 (u)),
2616 	     expr);
2617 	  break;
2618 #endif
2619 
2620 	default:
2621 	  assert ("bad character kind type" == NULL);
2622 	  break;
2623 	}
2624       break;
2625 
2626     default:
2627       assert ("bad type" == NULL);
2628       return expr;
2629     }
2630 
2631   ffebld_set_info (expr, ffeinfo_new
2632 		   (bt,
2633 		    kt,
2634 		    0,
2635 		    FFEINFO_kindENTITY,
2636 		    FFEINFO_whereCONSTANT,
2637 		    sz));
2638 
2639   if ((error != FFEBAD)
2640       && ffebad_start (error))
2641     {
2642       assert (t != NULL);
2643       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
2644       ffebad_finish ();
2645     }
2646 
2647   return expr;
2648 }
2649 
2650 /* ffeexpr_collapse_paren -- Collapse paren expr
2651 
2652    ffebld expr;
2653    ffelexToken token;
2654    expr = ffeexpr_collapse_paren(expr,token);
2655 
2656    If the result of the expr is a constant, replaces the expr with the
2657    computed constant.  */
2658 
2659 ffebld
ffeexpr_collapse_paren(ffebld expr,ffelexToken t UNUSED)2660 ffeexpr_collapse_paren (ffebld expr, ffelexToken t UNUSED)
2661 {
2662   ffebld r;
2663   ffeinfoBasictype bt;
2664   ffeinfoKindtype kt;
2665   ffetargetCharacterSize len;
2666 
2667   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
2668     return expr;
2669 
2670   r = ffebld_left (expr);
2671 
2672   if (ffebld_op (r) != FFEBLD_opCONTER)
2673     return expr;
2674 
2675   bt = ffeinfo_basictype (ffebld_info (r));
2676   kt = ffeinfo_kindtype (ffebld_info (r));
2677   len = ffebld_size (r);
2678 
2679   expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
2680 				      expr);
2681 
2682   ffebld_set_info (expr, ffeinfo_new
2683 		   (bt,
2684 		    kt,
2685 		    0,
2686 		    FFEINFO_kindENTITY,
2687 		    FFEINFO_whereCONSTANT,
2688 		    len));
2689 
2690   return expr;
2691 }
2692 
2693 /* ffeexpr_collapse_uplus -- Collapse uplus expr
2694 
2695    ffebld expr;
2696    ffelexToken token;
2697    expr = ffeexpr_collapse_uplus(expr,token);
2698 
2699    If the result of the expr is a constant, replaces the expr with the
2700    computed constant.  */
2701 
2702 ffebld
ffeexpr_collapse_uplus(ffebld expr,ffelexToken t UNUSED)2703 ffeexpr_collapse_uplus (ffebld expr, ffelexToken t UNUSED)
2704 {
2705   ffebld r;
2706   ffeinfoBasictype bt;
2707   ffeinfoKindtype kt;
2708   ffetargetCharacterSize len;
2709 
2710   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
2711     return expr;
2712 
2713   r = ffebld_left (expr);
2714 
2715   if (ffebld_op (r) != FFEBLD_opCONTER)
2716     return expr;
2717 
2718   bt = ffeinfo_basictype (ffebld_info (r));
2719   kt = ffeinfo_kindtype (ffebld_info (r));
2720   len = ffebld_size (r);
2721 
2722   expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
2723 				      expr);
2724 
2725   ffebld_set_info (expr, ffeinfo_new
2726 		   (bt,
2727 		    kt,
2728 		    0,
2729 		    FFEINFO_kindENTITY,
2730 		    FFEINFO_whereCONSTANT,
2731 		    len));
2732 
2733   return expr;
2734 }
2735 
2736 /* ffeexpr_collapse_uminus -- Collapse uminus expr
2737 
2738    ffebld expr;
2739    ffelexToken token;
2740    expr = ffeexpr_collapse_uminus(expr,token);
2741 
2742    If the result of the expr is a constant, replaces the expr with the
2743    computed constant.  */
2744 
2745 ffebld
ffeexpr_collapse_uminus(ffebld expr,ffelexToken t)2746 ffeexpr_collapse_uminus (ffebld expr, ffelexToken t)
2747 {
2748   ffebad error = FFEBAD;
2749   ffebld r;
2750   ffebldConstantUnion u;
2751   ffeinfoBasictype bt;
2752   ffeinfoKindtype kt;
2753 
2754   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
2755     return expr;
2756 
2757   r = ffebld_left (expr);
2758 
2759   if (ffebld_op (r) != FFEBLD_opCONTER)
2760     return expr;
2761 
2762   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
2763     {
2764     case FFEINFO_basictypeANY:
2765       return expr;
2766 
2767     case FFEINFO_basictypeINTEGER:
2768       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2769 	{
2770 #if FFETARGET_okINTEGER1
2771 	case FFEINFO_kindtypeINTEGER1:
2772 	  error = ffetarget_uminus_integer1 (ffebld_cu_ptr_integer1 (u),
2773 			      ffebld_constant_integer1 (ffebld_conter (r)));
2774 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
2775 					(ffebld_cu_val_integer1 (u)), expr);
2776 	  break;
2777 #endif
2778 
2779 #if FFETARGET_okINTEGER2
2780 	case FFEINFO_kindtypeINTEGER2:
2781 	  error = ffetarget_uminus_integer2 (ffebld_cu_ptr_integer2 (u),
2782 			      ffebld_constant_integer2 (ffebld_conter (r)));
2783 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
2784 					(ffebld_cu_val_integer2 (u)), expr);
2785 	  break;
2786 #endif
2787 
2788 #if FFETARGET_okINTEGER3
2789 	case FFEINFO_kindtypeINTEGER3:
2790 	  error = ffetarget_uminus_integer3 (ffebld_cu_ptr_integer3 (u),
2791 			      ffebld_constant_integer3 (ffebld_conter (r)));
2792 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
2793 					(ffebld_cu_val_integer3 (u)), expr);
2794 	  break;
2795 #endif
2796 
2797 #if FFETARGET_okINTEGER4
2798 	case FFEINFO_kindtypeINTEGER4:
2799 	  error = ffetarget_uminus_integer4 (ffebld_cu_ptr_integer4 (u),
2800 			      ffebld_constant_integer4 (ffebld_conter (r)));
2801 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
2802 					(ffebld_cu_val_integer4 (u)), expr);
2803 	  break;
2804 #endif
2805 
2806 	default:
2807 	  assert ("bad integer kind type" == NULL);
2808 	  break;
2809 	}
2810       break;
2811 
2812     case FFEINFO_basictypeREAL:
2813       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2814 	{
2815 #if FFETARGET_okREAL1
2816 	case FFEINFO_kindtypeREAL1:
2817 	  error = ffetarget_uminus_real1 (ffebld_cu_ptr_real1 (u),
2818 				 ffebld_constant_real1 (ffebld_conter (r)));
2819 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
2820 					   (ffebld_cu_val_real1 (u)), expr);
2821 	  break;
2822 #endif
2823 
2824 #if FFETARGET_okREAL2
2825 	case FFEINFO_kindtypeREAL2:
2826 	  error = ffetarget_uminus_real2 (ffebld_cu_ptr_real2 (u),
2827 				 ffebld_constant_real2 (ffebld_conter (r)));
2828 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
2829 					   (ffebld_cu_val_real2 (u)), expr);
2830 	  break;
2831 #endif
2832 
2833 #if FFETARGET_okREAL3
2834 	case FFEINFO_kindtypeREAL3:
2835 	  error = ffetarget_uminus_real3 (ffebld_cu_ptr_real3 (u),
2836 				 ffebld_constant_real3 (ffebld_conter (r)));
2837 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
2838 					   (ffebld_cu_val_real3 (u)), expr);
2839 	  break;
2840 #endif
2841 
2842 	default:
2843 	  assert ("bad real kind type" == NULL);
2844 	  break;
2845 	}
2846       break;
2847 
2848     case FFEINFO_basictypeCOMPLEX:
2849       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2850 	{
2851 #if FFETARGET_okCOMPLEX1
2852 	case FFEINFO_kindtypeREAL1:
2853 	  error = ffetarget_uminus_complex1 (ffebld_cu_ptr_complex1 (u),
2854 			      ffebld_constant_complex1 (ffebld_conter (r)));
2855 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
2856 					(ffebld_cu_val_complex1 (u)), expr);
2857 	  break;
2858 #endif
2859 
2860 #if FFETARGET_okCOMPLEX2
2861 	case FFEINFO_kindtypeREAL2:
2862 	  error = ffetarget_uminus_complex2 (ffebld_cu_ptr_complex2 (u),
2863 			      ffebld_constant_complex2 (ffebld_conter (r)));
2864 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
2865 					(ffebld_cu_val_complex2 (u)), expr);
2866 	  break;
2867 #endif
2868 
2869 #if FFETARGET_okCOMPLEX3
2870 	case FFEINFO_kindtypeREAL3:
2871 	  error = ffetarget_uminus_complex3 (ffebld_cu_ptr_complex3 (u),
2872 			      ffebld_constant_complex3 (ffebld_conter (r)));
2873 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
2874 					(ffebld_cu_val_complex3 (u)), expr);
2875 	  break;
2876 #endif
2877 
2878 	default:
2879 	  assert ("bad complex kind type" == NULL);
2880 	  break;
2881 	}
2882       break;
2883 
2884     default:
2885       assert ("bad type" == NULL);
2886       return expr;
2887     }
2888 
2889   ffebld_set_info (expr, ffeinfo_new
2890 		   (bt,
2891 		    kt,
2892 		    0,
2893 		    FFEINFO_kindENTITY,
2894 		    FFEINFO_whereCONSTANT,
2895 		    FFETARGET_charactersizeNONE));
2896 
2897   if ((error != FFEBAD)
2898       && ffebad_start (error))
2899     {
2900       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
2901       ffebad_finish ();
2902     }
2903 
2904   return expr;
2905 }
2906 
2907 /* ffeexpr_collapse_not -- Collapse not expr
2908 
2909    ffebld expr;
2910    ffelexToken token;
2911    expr = ffeexpr_collapse_not(expr,token);
2912 
2913    If the result of the expr is a constant, replaces the expr with the
2914    computed constant.  */
2915 
2916 ffebld
ffeexpr_collapse_not(ffebld expr,ffelexToken t)2917 ffeexpr_collapse_not (ffebld expr, ffelexToken t)
2918 {
2919   ffebad error = FFEBAD;
2920   ffebld r;
2921   ffebldConstantUnion u;
2922   ffeinfoBasictype bt;
2923   ffeinfoKindtype kt;
2924 
2925   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
2926     return expr;
2927 
2928   r = ffebld_left (expr);
2929 
2930   if (ffebld_op (r) != FFEBLD_opCONTER)
2931     return expr;
2932 
2933   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
2934     {
2935     case FFEINFO_basictypeANY:
2936       return expr;
2937 
2938     case FFEINFO_basictypeINTEGER:
2939       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2940 	{
2941 #if FFETARGET_okINTEGER1
2942 	case FFEINFO_kindtypeINTEGER1:
2943 	  error = ffetarget_not_integer1 (ffebld_cu_ptr_integer1 (u),
2944 			      ffebld_constant_integer1 (ffebld_conter (r)));
2945 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
2946 					(ffebld_cu_val_integer1 (u)), expr);
2947 	  break;
2948 #endif
2949 
2950 #if FFETARGET_okINTEGER2
2951 	case FFEINFO_kindtypeINTEGER2:
2952 	  error = ffetarget_not_integer2 (ffebld_cu_ptr_integer2 (u),
2953 			      ffebld_constant_integer2 (ffebld_conter (r)));
2954 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
2955 					(ffebld_cu_val_integer2 (u)), expr);
2956 	  break;
2957 #endif
2958 
2959 #if FFETARGET_okINTEGER3
2960 	case FFEINFO_kindtypeINTEGER3:
2961 	  error = ffetarget_not_integer3 (ffebld_cu_ptr_integer3 (u),
2962 			      ffebld_constant_integer3 (ffebld_conter (r)));
2963 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
2964 					(ffebld_cu_val_integer3 (u)), expr);
2965 	  break;
2966 #endif
2967 
2968 #if FFETARGET_okINTEGER4
2969 	case FFEINFO_kindtypeINTEGER4:
2970 	  error = ffetarget_not_integer4 (ffebld_cu_ptr_integer4 (u),
2971 			      ffebld_constant_integer4 (ffebld_conter (r)));
2972 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
2973 					(ffebld_cu_val_integer4 (u)), expr);
2974 	  break;
2975 #endif
2976 
2977 	default:
2978 	  assert ("bad integer kind type" == NULL);
2979 	  break;
2980 	}
2981       break;
2982 
2983     case FFEINFO_basictypeLOGICAL:
2984       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2985 	{
2986 #if FFETARGET_okLOGICAL1
2987 	case FFEINFO_kindtypeLOGICAL1:
2988 	  error = ffetarget_not_logical1 (ffebld_cu_ptr_logical1 (u),
2989 			      ffebld_constant_logical1 (ffebld_conter (r)));
2990 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
2991 					(ffebld_cu_val_logical1 (u)), expr);
2992 	  break;
2993 #endif
2994 
2995 #if FFETARGET_okLOGICAL2
2996 	case FFEINFO_kindtypeLOGICAL2:
2997 	  error = ffetarget_not_logical2 (ffebld_cu_ptr_logical2 (u),
2998 			      ffebld_constant_logical2 (ffebld_conter (r)));
2999 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
3000 					(ffebld_cu_val_logical2 (u)), expr);
3001 	  break;
3002 #endif
3003 
3004 #if FFETARGET_okLOGICAL3
3005 	case FFEINFO_kindtypeLOGICAL3:
3006 	  error = ffetarget_not_logical3 (ffebld_cu_ptr_logical3 (u),
3007 			      ffebld_constant_logical3 (ffebld_conter (r)));
3008 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
3009 					(ffebld_cu_val_logical3 (u)), expr);
3010 	  break;
3011 #endif
3012 
3013 #if FFETARGET_okLOGICAL4
3014 	case FFEINFO_kindtypeLOGICAL4:
3015 	  error = ffetarget_not_logical4 (ffebld_cu_ptr_logical4 (u),
3016 			      ffebld_constant_logical4 (ffebld_conter (r)));
3017 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
3018 					(ffebld_cu_val_logical4 (u)), expr);
3019 	  break;
3020 #endif
3021 
3022 	default:
3023 	  assert ("bad logical kind type" == NULL);
3024 	  break;
3025 	}
3026       break;
3027 
3028     default:
3029       assert ("bad type" == NULL);
3030       return expr;
3031     }
3032 
3033   ffebld_set_info (expr, ffeinfo_new
3034 		   (bt,
3035 		    kt,
3036 		    0,
3037 		    FFEINFO_kindENTITY,
3038 		    FFEINFO_whereCONSTANT,
3039 		    FFETARGET_charactersizeNONE));
3040 
3041   if ((error != FFEBAD)
3042       && ffebad_start (error))
3043     {
3044       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3045       ffebad_finish ();
3046     }
3047 
3048   return expr;
3049 }
3050 
3051 /* ffeexpr_collapse_add -- Collapse add expr
3052 
3053    ffebld expr;
3054    ffelexToken token;
3055    expr = ffeexpr_collapse_add(expr,token);
3056 
3057    If the result of the expr is a constant, replaces the expr with the
3058    computed constant.  */
3059 
3060 ffebld
ffeexpr_collapse_add(ffebld expr,ffelexToken t)3061 ffeexpr_collapse_add (ffebld expr, ffelexToken t)
3062 {
3063   ffebad error = FFEBAD;
3064   ffebld l;
3065   ffebld r;
3066   ffebldConstantUnion u;
3067   ffeinfoBasictype bt;
3068   ffeinfoKindtype kt;
3069 
3070   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3071     return expr;
3072 
3073   l = ffebld_left (expr);
3074   r = ffebld_right (expr);
3075 
3076   if (ffebld_op (l) != FFEBLD_opCONTER)
3077     return expr;
3078   if (ffebld_op (r) != FFEBLD_opCONTER)
3079     return expr;
3080 
3081   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3082     {
3083     case FFEINFO_basictypeANY:
3084       return expr;
3085 
3086     case FFEINFO_basictypeINTEGER:
3087       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3088 	{
3089 #if FFETARGET_okINTEGER1
3090 	case FFEINFO_kindtypeINTEGER1:
3091 	  error = ffetarget_add_integer1 (ffebld_cu_ptr_integer1 (u),
3092 			       ffebld_constant_integer1 (ffebld_conter (l)),
3093 			      ffebld_constant_integer1 (ffebld_conter (r)));
3094 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3095 					(ffebld_cu_val_integer1 (u)), expr);
3096 	  break;
3097 #endif
3098 
3099 #if FFETARGET_okINTEGER2
3100 	case FFEINFO_kindtypeINTEGER2:
3101 	  error = ffetarget_add_integer2 (ffebld_cu_ptr_integer2 (u),
3102 			       ffebld_constant_integer2 (ffebld_conter (l)),
3103 			      ffebld_constant_integer2 (ffebld_conter (r)));
3104 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3105 					(ffebld_cu_val_integer2 (u)), expr);
3106 	  break;
3107 #endif
3108 
3109 #if FFETARGET_okINTEGER3
3110 	case FFEINFO_kindtypeINTEGER3:
3111 	  error = ffetarget_add_integer3 (ffebld_cu_ptr_integer3 (u),
3112 			       ffebld_constant_integer3 (ffebld_conter (l)),
3113 			      ffebld_constant_integer3 (ffebld_conter (r)));
3114 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3115 					(ffebld_cu_val_integer3 (u)), expr);
3116 	  break;
3117 #endif
3118 
3119 #if FFETARGET_okINTEGER4
3120 	case FFEINFO_kindtypeINTEGER4:
3121 	  error = ffetarget_add_integer4 (ffebld_cu_ptr_integer4 (u),
3122 			       ffebld_constant_integer4 (ffebld_conter (l)),
3123 			      ffebld_constant_integer4 (ffebld_conter (r)));
3124 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3125 					(ffebld_cu_val_integer4 (u)), expr);
3126 	  break;
3127 #endif
3128 
3129 	default:
3130 	  assert ("bad integer kind type" == NULL);
3131 	  break;
3132 	}
3133       break;
3134 
3135     case FFEINFO_basictypeREAL:
3136       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3137 	{
3138 #if FFETARGET_okREAL1
3139 	case FFEINFO_kindtypeREAL1:
3140 	  error = ffetarget_add_real1 (ffebld_cu_ptr_real1 (u),
3141 				  ffebld_constant_real1 (ffebld_conter (l)),
3142 				 ffebld_constant_real1 (ffebld_conter (r)));
3143 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3144 					   (ffebld_cu_val_real1 (u)), expr);
3145 	  break;
3146 #endif
3147 
3148 #if FFETARGET_okREAL2
3149 	case FFEINFO_kindtypeREAL2:
3150 	  error = ffetarget_add_real2 (ffebld_cu_ptr_real2 (u),
3151 				  ffebld_constant_real2 (ffebld_conter (l)),
3152 				 ffebld_constant_real2 (ffebld_conter (r)));
3153 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3154 					   (ffebld_cu_val_real2 (u)), expr);
3155 	  break;
3156 #endif
3157 
3158 #if FFETARGET_okREAL3
3159 	case FFEINFO_kindtypeREAL3:
3160 	  error = ffetarget_add_real3 (ffebld_cu_ptr_real3 (u),
3161 				  ffebld_constant_real3 (ffebld_conter (l)),
3162 				 ffebld_constant_real3 (ffebld_conter (r)));
3163 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3164 					   (ffebld_cu_val_real3 (u)), expr);
3165 	  break;
3166 #endif
3167 
3168 	default:
3169 	  assert ("bad real kind type" == NULL);
3170 	  break;
3171 	}
3172       break;
3173 
3174     case FFEINFO_basictypeCOMPLEX:
3175       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3176 	{
3177 #if FFETARGET_okCOMPLEX1
3178 	case FFEINFO_kindtypeREAL1:
3179 	  error = ffetarget_add_complex1 (ffebld_cu_ptr_complex1 (u),
3180 			       ffebld_constant_complex1 (ffebld_conter (l)),
3181 			      ffebld_constant_complex1 (ffebld_conter (r)));
3182 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3183 					(ffebld_cu_val_complex1 (u)), expr);
3184 	  break;
3185 #endif
3186 
3187 #if FFETARGET_okCOMPLEX2
3188 	case FFEINFO_kindtypeREAL2:
3189 	  error = ffetarget_add_complex2 (ffebld_cu_ptr_complex2 (u),
3190 			       ffebld_constant_complex2 (ffebld_conter (l)),
3191 			      ffebld_constant_complex2 (ffebld_conter (r)));
3192 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3193 					(ffebld_cu_val_complex2 (u)), expr);
3194 	  break;
3195 #endif
3196 
3197 #if FFETARGET_okCOMPLEX3
3198 	case FFEINFO_kindtypeREAL3:
3199 	  error = ffetarget_add_complex3 (ffebld_cu_ptr_complex3 (u),
3200 			       ffebld_constant_complex3 (ffebld_conter (l)),
3201 			      ffebld_constant_complex3 (ffebld_conter (r)));
3202 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3203 					(ffebld_cu_val_complex3 (u)), expr);
3204 	  break;
3205 #endif
3206 
3207 	default:
3208 	  assert ("bad complex kind type" == NULL);
3209 	  break;
3210 	}
3211       break;
3212 
3213     default:
3214       assert ("bad type" == NULL);
3215       return expr;
3216     }
3217 
3218   ffebld_set_info (expr, ffeinfo_new
3219 		   (bt,
3220 		    kt,
3221 		    0,
3222 		    FFEINFO_kindENTITY,
3223 		    FFEINFO_whereCONSTANT,
3224 		    FFETARGET_charactersizeNONE));
3225 
3226   if ((error != FFEBAD)
3227       && ffebad_start (error))
3228     {
3229       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3230       ffebad_finish ();
3231     }
3232 
3233   return expr;
3234 }
3235 
3236 /* ffeexpr_collapse_subtract -- Collapse subtract expr
3237 
3238    ffebld expr;
3239    ffelexToken token;
3240    expr = ffeexpr_collapse_subtract(expr,token);
3241 
3242    If the result of the expr is a constant, replaces the expr with the
3243    computed constant.  */
3244 
3245 ffebld
ffeexpr_collapse_subtract(ffebld expr,ffelexToken t)3246 ffeexpr_collapse_subtract (ffebld expr, ffelexToken t)
3247 {
3248   ffebad error = FFEBAD;
3249   ffebld l;
3250   ffebld r;
3251   ffebldConstantUnion u;
3252   ffeinfoBasictype bt;
3253   ffeinfoKindtype kt;
3254 
3255   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3256     return expr;
3257 
3258   l = ffebld_left (expr);
3259   r = ffebld_right (expr);
3260 
3261   if (ffebld_op (l) != FFEBLD_opCONTER)
3262     return expr;
3263   if (ffebld_op (r) != FFEBLD_opCONTER)
3264     return expr;
3265 
3266   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3267     {
3268     case FFEINFO_basictypeANY:
3269       return expr;
3270 
3271     case FFEINFO_basictypeINTEGER:
3272       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3273 	{
3274 #if FFETARGET_okINTEGER1
3275 	case FFEINFO_kindtypeINTEGER1:
3276 	  error = ffetarget_subtract_integer1 (ffebld_cu_ptr_integer1 (u),
3277 			       ffebld_constant_integer1 (ffebld_conter (l)),
3278 			      ffebld_constant_integer1 (ffebld_conter (r)));
3279 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3280 					(ffebld_cu_val_integer1 (u)), expr);
3281 	  break;
3282 #endif
3283 
3284 #if FFETARGET_okINTEGER2
3285 	case FFEINFO_kindtypeINTEGER2:
3286 	  error = ffetarget_subtract_integer2 (ffebld_cu_ptr_integer2 (u),
3287 			       ffebld_constant_integer2 (ffebld_conter (l)),
3288 			      ffebld_constant_integer2 (ffebld_conter (r)));
3289 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3290 					(ffebld_cu_val_integer2 (u)), expr);
3291 	  break;
3292 #endif
3293 
3294 #if FFETARGET_okINTEGER3
3295 	case FFEINFO_kindtypeINTEGER3:
3296 	  error = ffetarget_subtract_integer3 (ffebld_cu_ptr_integer3 (u),
3297 			       ffebld_constant_integer3 (ffebld_conter (l)),
3298 			      ffebld_constant_integer3 (ffebld_conter (r)));
3299 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3300 					(ffebld_cu_val_integer3 (u)), expr);
3301 	  break;
3302 #endif
3303 
3304 #if FFETARGET_okINTEGER4
3305 	case FFEINFO_kindtypeINTEGER4:
3306 	  error = ffetarget_subtract_integer4 (ffebld_cu_ptr_integer4 (u),
3307 			       ffebld_constant_integer4 (ffebld_conter (l)),
3308 			      ffebld_constant_integer4 (ffebld_conter (r)));
3309 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3310 					(ffebld_cu_val_integer4 (u)), expr);
3311 	  break;
3312 #endif
3313 
3314 	default:
3315 	  assert ("bad integer kind type" == NULL);
3316 	  break;
3317 	}
3318       break;
3319 
3320     case FFEINFO_basictypeREAL:
3321       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3322 	{
3323 #if FFETARGET_okREAL1
3324 	case FFEINFO_kindtypeREAL1:
3325 	  error = ffetarget_subtract_real1 (ffebld_cu_ptr_real1 (u),
3326 				  ffebld_constant_real1 (ffebld_conter (l)),
3327 				 ffebld_constant_real1 (ffebld_conter (r)));
3328 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3329 					   (ffebld_cu_val_real1 (u)), expr);
3330 	  break;
3331 #endif
3332 
3333 #if FFETARGET_okREAL2
3334 	case FFEINFO_kindtypeREAL2:
3335 	  error = ffetarget_subtract_real2 (ffebld_cu_ptr_real2 (u),
3336 				  ffebld_constant_real2 (ffebld_conter (l)),
3337 				 ffebld_constant_real2 (ffebld_conter (r)));
3338 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3339 					   (ffebld_cu_val_real2 (u)), expr);
3340 	  break;
3341 #endif
3342 
3343 #if FFETARGET_okREAL3
3344 	case FFEINFO_kindtypeREAL3:
3345 	  error = ffetarget_subtract_real3 (ffebld_cu_ptr_real3 (u),
3346 				  ffebld_constant_real3 (ffebld_conter (l)),
3347 				 ffebld_constant_real3 (ffebld_conter (r)));
3348 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3349 					   (ffebld_cu_val_real3 (u)), expr);
3350 	  break;
3351 #endif
3352 
3353 	default:
3354 	  assert ("bad real kind type" == NULL);
3355 	  break;
3356 	}
3357       break;
3358 
3359     case FFEINFO_basictypeCOMPLEX:
3360       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3361 	{
3362 #if FFETARGET_okCOMPLEX1
3363 	case FFEINFO_kindtypeREAL1:
3364 	  error = ffetarget_subtract_complex1 (ffebld_cu_ptr_complex1 (u),
3365 			       ffebld_constant_complex1 (ffebld_conter (l)),
3366 			      ffebld_constant_complex1 (ffebld_conter (r)));
3367 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3368 					(ffebld_cu_val_complex1 (u)), expr);
3369 	  break;
3370 #endif
3371 
3372 #if FFETARGET_okCOMPLEX2
3373 	case FFEINFO_kindtypeREAL2:
3374 	  error = ffetarget_subtract_complex2 (ffebld_cu_ptr_complex2 (u),
3375 			       ffebld_constant_complex2 (ffebld_conter (l)),
3376 			      ffebld_constant_complex2 (ffebld_conter (r)));
3377 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3378 					(ffebld_cu_val_complex2 (u)), expr);
3379 	  break;
3380 #endif
3381 
3382 #if FFETARGET_okCOMPLEX3
3383 	case FFEINFO_kindtypeREAL3:
3384 	  error = ffetarget_subtract_complex3 (ffebld_cu_ptr_complex3 (u),
3385 			       ffebld_constant_complex3 (ffebld_conter (l)),
3386 			      ffebld_constant_complex3 (ffebld_conter (r)));
3387 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3388 					(ffebld_cu_val_complex3 (u)), expr);
3389 	  break;
3390 #endif
3391 
3392 	default:
3393 	  assert ("bad complex kind type" == NULL);
3394 	  break;
3395 	}
3396       break;
3397 
3398     default:
3399       assert ("bad type" == NULL);
3400       return expr;
3401     }
3402 
3403   ffebld_set_info (expr, ffeinfo_new
3404 		   (bt,
3405 		    kt,
3406 		    0,
3407 		    FFEINFO_kindENTITY,
3408 		    FFEINFO_whereCONSTANT,
3409 		    FFETARGET_charactersizeNONE));
3410 
3411   if ((error != FFEBAD)
3412       && ffebad_start (error))
3413     {
3414       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3415       ffebad_finish ();
3416     }
3417 
3418   return expr;
3419 }
3420 
3421 /* ffeexpr_collapse_multiply -- Collapse multiply expr
3422 
3423    ffebld expr;
3424    ffelexToken token;
3425    expr = ffeexpr_collapse_multiply(expr,token);
3426 
3427    If the result of the expr is a constant, replaces the expr with the
3428    computed constant.  */
3429 
3430 ffebld
ffeexpr_collapse_multiply(ffebld expr,ffelexToken t)3431 ffeexpr_collapse_multiply (ffebld expr, ffelexToken t)
3432 {
3433   ffebad error = FFEBAD;
3434   ffebld l;
3435   ffebld r;
3436   ffebldConstantUnion u;
3437   ffeinfoBasictype bt;
3438   ffeinfoKindtype kt;
3439 
3440   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3441     return expr;
3442 
3443   l = ffebld_left (expr);
3444   r = ffebld_right (expr);
3445 
3446   if (ffebld_op (l) != FFEBLD_opCONTER)
3447     return expr;
3448   if (ffebld_op (r) != FFEBLD_opCONTER)
3449     return expr;
3450 
3451   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3452     {
3453     case FFEINFO_basictypeANY:
3454       return expr;
3455 
3456     case FFEINFO_basictypeINTEGER:
3457       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3458 	{
3459 #if FFETARGET_okINTEGER1
3460 	case FFEINFO_kindtypeINTEGER1:
3461 	  error = ffetarget_multiply_integer1 (ffebld_cu_ptr_integer1 (u),
3462 			       ffebld_constant_integer1 (ffebld_conter (l)),
3463 			      ffebld_constant_integer1 (ffebld_conter (r)));
3464 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3465 					(ffebld_cu_val_integer1 (u)), expr);
3466 	  break;
3467 #endif
3468 
3469 #if FFETARGET_okINTEGER2
3470 	case FFEINFO_kindtypeINTEGER2:
3471 	  error = ffetarget_multiply_integer2 (ffebld_cu_ptr_integer2 (u),
3472 			       ffebld_constant_integer2 (ffebld_conter (l)),
3473 			      ffebld_constant_integer2 (ffebld_conter (r)));
3474 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3475 					(ffebld_cu_val_integer2 (u)), expr);
3476 	  break;
3477 #endif
3478 
3479 #if FFETARGET_okINTEGER3
3480 	case FFEINFO_kindtypeINTEGER3:
3481 	  error = ffetarget_multiply_integer3 (ffebld_cu_ptr_integer3 (u),
3482 			       ffebld_constant_integer3 (ffebld_conter (l)),
3483 			      ffebld_constant_integer3 (ffebld_conter (r)));
3484 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3485 					(ffebld_cu_val_integer3 (u)), expr);
3486 	  break;
3487 #endif
3488 
3489 #if FFETARGET_okINTEGER4
3490 	case FFEINFO_kindtypeINTEGER4:
3491 	  error = ffetarget_multiply_integer4 (ffebld_cu_ptr_integer4 (u),
3492 			       ffebld_constant_integer4 (ffebld_conter (l)),
3493 			      ffebld_constant_integer4 (ffebld_conter (r)));
3494 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3495 					(ffebld_cu_val_integer4 (u)), expr);
3496 	  break;
3497 #endif
3498 
3499 	default:
3500 	  assert ("bad integer kind type" == NULL);
3501 	  break;
3502 	}
3503       break;
3504 
3505     case FFEINFO_basictypeREAL:
3506       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3507 	{
3508 #if FFETARGET_okREAL1
3509 	case FFEINFO_kindtypeREAL1:
3510 	  error = ffetarget_multiply_real1 (ffebld_cu_ptr_real1 (u),
3511 				  ffebld_constant_real1 (ffebld_conter (l)),
3512 				 ffebld_constant_real1 (ffebld_conter (r)));
3513 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3514 					   (ffebld_cu_val_real1 (u)), expr);
3515 	  break;
3516 #endif
3517 
3518 #if FFETARGET_okREAL2
3519 	case FFEINFO_kindtypeREAL2:
3520 	  error = ffetarget_multiply_real2 (ffebld_cu_ptr_real2 (u),
3521 				  ffebld_constant_real2 (ffebld_conter (l)),
3522 				 ffebld_constant_real2 (ffebld_conter (r)));
3523 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3524 					   (ffebld_cu_val_real2 (u)), expr);
3525 	  break;
3526 #endif
3527 
3528 #if FFETARGET_okREAL3
3529 	case FFEINFO_kindtypeREAL3:
3530 	  error = ffetarget_multiply_real3 (ffebld_cu_ptr_real3 (u),
3531 				  ffebld_constant_real3 (ffebld_conter (l)),
3532 				 ffebld_constant_real3 (ffebld_conter (r)));
3533 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3534 					   (ffebld_cu_val_real3 (u)), expr);
3535 	  break;
3536 #endif
3537 
3538 	default:
3539 	  assert ("bad real kind type" == NULL);
3540 	  break;
3541 	}
3542       break;
3543 
3544     case FFEINFO_basictypeCOMPLEX:
3545       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3546 	{
3547 #if FFETARGET_okCOMPLEX1
3548 	case FFEINFO_kindtypeREAL1:
3549 	  error = ffetarget_multiply_complex1 (ffebld_cu_ptr_complex1 (u),
3550 			       ffebld_constant_complex1 (ffebld_conter (l)),
3551 			      ffebld_constant_complex1 (ffebld_conter (r)));
3552 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3553 					(ffebld_cu_val_complex1 (u)), expr);
3554 	  break;
3555 #endif
3556 
3557 #if FFETARGET_okCOMPLEX2
3558 	case FFEINFO_kindtypeREAL2:
3559 	  error = ffetarget_multiply_complex2 (ffebld_cu_ptr_complex2 (u),
3560 			       ffebld_constant_complex2 (ffebld_conter (l)),
3561 			      ffebld_constant_complex2 (ffebld_conter (r)));
3562 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3563 					(ffebld_cu_val_complex2 (u)), expr);
3564 	  break;
3565 #endif
3566 
3567 #if FFETARGET_okCOMPLEX3
3568 	case FFEINFO_kindtypeREAL3:
3569 	  error = ffetarget_multiply_complex3 (ffebld_cu_ptr_complex3 (u),
3570 			       ffebld_constant_complex3 (ffebld_conter (l)),
3571 			      ffebld_constant_complex3 (ffebld_conter (r)));
3572 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3573 					(ffebld_cu_val_complex3 (u)), expr);
3574 	  break;
3575 #endif
3576 
3577 	default:
3578 	  assert ("bad complex kind type" == NULL);
3579 	  break;
3580 	}
3581       break;
3582 
3583     default:
3584       assert ("bad type" == NULL);
3585       return expr;
3586     }
3587 
3588   ffebld_set_info (expr, ffeinfo_new
3589 		   (bt,
3590 		    kt,
3591 		    0,
3592 		    FFEINFO_kindENTITY,
3593 		    FFEINFO_whereCONSTANT,
3594 		    FFETARGET_charactersizeNONE));
3595 
3596   if ((error != FFEBAD)
3597       && ffebad_start (error))
3598     {
3599       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3600       ffebad_finish ();
3601     }
3602 
3603   return expr;
3604 }
3605 
3606 /* ffeexpr_collapse_divide -- Collapse divide expr
3607 
3608    ffebld expr;
3609    ffelexToken token;
3610    expr = ffeexpr_collapse_divide(expr,token);
3611 
3612    If the result of the expr is a constant, replaces the expr with the
3613    computed constant.  */
3614 
3615 ffebld
ffeexpr_collapse_divide(ffebld expr,ffelexToken t)3616 ffeexpr_collapse_divide (ffebld expr, ffelexToken t)
3617 {
3618   ffebad error = FFEBAD;
3619   ffebld l;
3620   ffebld r;
3621   ffebldConstantUnion u;
3622   ffeinfoBasictype bt;
3623   ffeinfoKindtype kt;
3624 
3625   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3626     return expr;
3627 
3628   l = ffebld_left (expr);
3629   r = ffebld_right (expr);
3630 
3631   if (ffebld_op (l) != FFEBLD_opCONTER)
3632     return expr;
3633   if (ffebld_op (r) != FFEBLD_opCONTER)
3634     return expr;
3635 
3636   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3637     {
3638     case FFEINFO_basictypeANY:
3639       return expr;
3640 
3641     case FFEINFO_basictypeINTEGER:
3642       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3643 	{
3644 #if FFETARGET_okINTEGER1
3645 	case FFEINFO_kindtypeINTEGER1:
3646 	  error = ffetarget_divide_integer1 (ffebld_cu_ptr_integer1 (u),
3647 			       ffebld_constant_integer1 (ffebld_conter (l)),
3648 			      ffebld_constant_integer1 (ffebld_conter (r)));
3649 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3650 					(ffebld_cu_val_integer1 (u)), expr);
3651 	  break;
3652 #endif
3653 
3654 #if FFETARGET_okINTEGER2
3655 	case FFEINFO_kindtypeINTEGER2:
3656 	  error = ffetarget_divide_integer2 (ffebld_cu_ptr_integer2 (u),
3657 			       ffebld_constant_integer2 (ffebld_conter (l)),
3658 			      ffebld_constant_integer2 (ffebld_conter (r)));
3659 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3660 					(ffebld_cu_val_integer2 (u)), expr);
3661 	  break;
3662 #endif
3663 
3664 #if FFETARGET_okINTEGER3
3665 	case FFEINFO_kindtypeINTEGER3:
3666 	  error = ffetarget_divide_integer3 (ffebld_cu_ptr_integer3 (u),
3667 			       ffebld_constant_integer3 (ffebld_conter (l)),
3668 			      ffebld_constant_integer3 (ffebld_conter (r)));
3669 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3670 					(ffebld_cu_val_integer3 (u)), expr);
3671 	  break;
3672 #endif
3673 
3674 #if FFETARGET_okINTEGER4
3675 	case FFEINFO_kindtypeINTEGER4:
3676 	  error = ffetarget_divide_integer4 (ffebld_cu_ptr_integer4 (u),
3677 			       ffebld_constant_integer4 (ffebld_conter (l)),
3678 			      ffebld_constant_integer4 (ffebld_conter (r)));
3679 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3680 					(ffebld_cu_val_integer4 (u)), expr);
3681 	  break;
3682 #endif
3683 
3684 	default:
3685 	  assert ("bad integer kind type" == NULL);
3686 	  break;
3687 	}
3688       break;
3689 
3690     case FFEINFO_basictypeREAL:
3691       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3692 	{
3693 #if FFETARGET_okREAL1
3694 	case FFEINFO_kindtypeREAL1:
3695 	  error = ffetarget_divide_real1 (ffebld_cu_ptr_real1 (u),
3696 				  ffebld_constant_real1 (ffebld_conter (l)),
3697 				 ffebld_constant_real1 (ffebld_conter (r)));
3698 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3699 					   (ffebld_cu_val_real1 (u)), expr);
3700 	  break;
3701 #endif
3702 
3703 #if FFETARGET_okREAL2
3704 	case FFEINFO_kindtypeREAL2:
3705 	  error = ffetarget_divide_real2 (ffebld_cu_ptr_real2 (u),
3706 				  ffebld_constant_real2 (ffebld_conter (l)),
3707 				 ffebld_constant_real2 (ffebld_conter (r)));
3708 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3709 					   (ffebld_cu_val_real2 (u)), expr);
3710 	  break;
3711 #endif
3712 
3713 #if FFETARGET_okREAL3
3714 	case FFEINFO_kindtypeREAL3:
3715 	  error = ffetarget_divide_real3 (ffebld_cu_ptr_real3 (u),
3716 				  ffebld_constant_real3 (ffebld_conter (l)),
3717 				 ffebld_constant_real3 (ffebld_conter (r)));
3718 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3719 					   (ffebld_cu_val_real3 (u)), expr);
3720 	  break;
3721 #endif
3722 
3723 	default:
3724 	  assert ("bad real kind type" == NULL);
3725 	  break;
3726 	}
3727       break;
3728 
3729     case FFEINFO_basictypeCOMPLEX:
3730       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3731 	{
3732 #if FFETARGET_okCOMPLEX1
3733 	case FFEINFO_kindtypeREAL1:
3734 	  error = ffetarget_divide_complex1 (ffebld_cu_ptr_complex1 (u),
3735 			       ffebld_constant_complex1 (ffebld_conter (l)),
3736 			      ffebld_constant_complex1 (ffebld_conter (r)));
3737 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3738 					(ffebld_cu_val_complex1 (u)), expr);
3739 	  break;
3740 #endif
3741 
3742 #if FFETARGET_okCOMPLEX2
3743 	case FFEINFO_kindtypeREAL2:
3744 	  error = ffetarget_divide_complex2 (ffebld_cu_ptr_complex2 (u),
3745 			       ffebld_constant_complex2 (ffebld_conter (l)),
3746 			      ffebld_constant_complex2 (ffebld_conter (r)));
3747 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3748 					(ffebld_cu_val_complex2 (u)), expr);
3749 	  break;
3750 #endif
3751 
3752 #if FFETARGET_okCOMPLEX3
3753 	case FFEINFO_kindtypeREAL3:
3754 	  error = ffetarget_divide_complex3 (ffebld_cu_ptr_complex3 (u),
3755 			       ffebld_constant_complex3 (ffebld_conter (l)),
3756 			      ffebld_constant_complex3 (ffebld_conter (r)));
3757 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3758 					(ffebld_cu_val_complex3 (u)), expr);
3759 	  break;
3760 #endif
3761 
3762 	default:
3763 	  assert ("bad complex kind type" == NULL);
3764 	  break;
3765 	}
3766       break;
3767 
3768     default:
3769       assert ("bad type" == NULL);
3770       return expr;
3771     }
3772 
3773   ffebld_set_info (expr, ffeinfo_new
3774 		   (bt,
3775 		    kt,
3776 		    0,
3777 		    FFEINFO_kindENTITY,
3778 		    FFEINFO_whereCONSTANT,
3779 		    FFETARGET_charactersizeNONE));
3780 
3781   if ((error != FFEBAD)
3782       && ffebad_start (error))
3783     {
3784       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3785       ffebad_finish ();
3786     }
3787 
3788   return expr;
3789 }
3790 
3791 /* ffeexpr_collapse_power -- Collapse power expr
3792 
3793    ffebld expr;
3794    ffelexToken token;
3795    expr = ffeexpr_collapse_power(expr,token);
3796 
3797    If the result of the expr is a constant, replaces the expr with the
3798    computed constant.  */
3799 
3800 ffebld
ffeexpr_collapse_power(ffebld expr,ffelexToken t)3801 ffeexpr_collapse_power (ffebld expr, ffelexToken t)
3802 {
3803   ffebad error = FFEBAD;
3804   ffebld l;
3805   ffebld r;
3806   ffebldConstantUnion u;
3807   ffeinfoBasictype bt;
3808   ffeinfoKindtype kt;
3809 
3810   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3811     return expr;
3812 
3813   l = ffebld_left (expr);
3814   r = ffebld_right (expr);
3815 
3816   if (ffebld_op (l) != FFEBLD_opCONTER)
3817     return expr;
3818   if (ffebld_op (r) != FFEBLD_opCONTER)
3819     return expr;
3820 
3821   if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER)
3822   || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT))
3823     return expr;
3824 
3825   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3826     {
3827     case FFEINFO_basictypeANY:
3828       return expr;
3829 
3830     case FFEINFO_basictypeINTEGER:
3831       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3832 	{
3833 	case FFEINFO_kindtypeINTEGERDEFAULT:
3834 	  error = ffetarget_power_integerdefault_integerdefault
3835 	    (ffebld_cu_ptr_integerdefault (u),
3836 	     ffebld_constant_integerdefault (ffebld_conter (l)),
3837 	     ffebld_constant_integerdefault (ffebld_conter (r)));
3838 	  expr = ffebld_new_conter_with_orig
3839 	    (ffebld_constant_new_integerdefault_val
3840 	     (ffebld_cu_val_integerdefault (u)), expr);
3841 	  break;
3842 
3843 	default:
3844 	  assert ("bad integer kind type" == NULL);
3845 	  break;
3846 	}
3847       break;
3848 
3849     case FFEINFO_basictypeREAL:
3850       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3851 	{
3852 	case FFEINFO_kindtypeREALDEFAULT:
3853 	  error = ffetarget_power_realdefault_integerdefault
3854 	    (ffebld_cu_ptr_realdefault (u),
3855 	     ffebld_constant_realdefault (ffebld_conter (l)),
3856 	     ffebld_constant_integerdefault (ffebld_conter (r)));
3857 	  expr = ffebld_new_conter_with_orig
3858 	    (ffebld_constant_new_realdefault_val
3859 	     (ffebld_cu_val_realdefault (u)), expr);
3860 	  break;
3861 
3862 	case FFEINFO_kindtypeREALDOUBLE:
3863 	  error = ffetarget_power_realdouble_integerdefault
3864 	    (ffebld_cu_ptr_realdouble (u),
3865 	     ffebld_constant_realdouble (ffebld_conter (l)),
3866 	     ffebld_constant_integerdefault (ffebld_conter (r)));
3867 	  expr = ffebld_new_conter_with_orig
3868 	    (ffebld_constant_new_realdouble_val
3869 	     (ffebld_cu_val_realdouble (u)), expr);
3870 	  break;
3871 
3872 #if FFETARGET_okREALQUAD
3873 	case FFEINFO_kindtypeREALQUAD:
3874 	  error = ffetarget_power_realquad_integerdefault
3875 	    (ffebld_cu_ptr_realquad (u),
3876 	     ffebld_constant_realquad (ffebld_conter (l)),
3877 	     ffebld_constant_integerdefault (ffebld_conter (r)));
3878 	  expr = ffebld_new_conter_with_orig
3879 	    (ffebld_constant_new_realquad_val
3880 	     (ffebld_cu_val_realquad (u)), expr);
3881 	  break;
3882 #endif
3883 	default:
3884 	  assert ("bad real kind type" == NULL);
3885 	  break;
3886 	}
3887       break;
3888 
3889     case FFEINFO_basictypeCOMPLEX:
3890       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3891 	{
3892 	case FFEINFO_kindtypeREALDEFAULT:
3893 	  error = ffetarget_power_complexdefault_integerdefault
3894 	    (ffebld_cu_ptr_complexdefault (u),
3895 	     ffebld_constant_complexdefault (ffebld_conter (l)),
3896 	     ffebld_constant_integerdefault (ffebld_conter (r)));
3897 	  expr = ffebld_new_conter_with_orig
3898 	    (ffebld_constant_new_complexdefault_val
3899 	     (ffebld_cu_val_complexdefault (u)), expr);
3900 	  break;
3901 
3902 #if FFETARGET_okCOMPLEXDOUBLE
3903 	case FFEINFO_kindtypeREALDOUBLE:
3904 	  error = ffetarget_power_complexdouble_integerdefault
3905 	    (ffebld_cu_ptr_complexdouble (u),
3906 	     ffebld_constant_complexdouble (ffebld_conter (l)),
3907 	     ffebld_constant_integerdefault (ffebld_conter (r)));
3908 	  expr = ffebld_new_conter_with_orig
3909 	    (ffebld_constant_new_complexdouble_val
3910 	     (ffebld_cu_val_complexdouble (u)), expr);
3911 	  break;
3912 #endif
3913 
3914 #if FFETARGET_okCOMPLEXQUAD
3915 	case FFEINFO_kindtypeREALQUAD:
3916 	  error = ffetarget_power_complexquad_integerdefault
3917 	    (ffebld_cu_ptr_complexquad (u),
3918 	     ffebld_constant_complexquad (ffebld_conter (l)),
3919 	     ffebld_constant_integerdefault (ffebld_conter (r)));
3920 	  expr = ffebld_new_conter_with_orig
3921 	    (ffebld_constant_new_complexquad_val
3922 	     (ffebld_cu_val_complexquad (u)), expr);
3923 	  break;
3924 #endif
3925 
3926 	default:
3927 	  assert ("bad complex kind type" == NULL);
3928 	  break;
3929 	}
3930       break;
3931 
3932     default:
3933       assert ("bad type" == NULL);
3934       return expr;
3935     }
3936 
3937   ffebld_set_info (expr, ffeinfo_new
3938 		   (bt,
3939 		    kt,
3940 		    0,
3941 		    FFEINFO_kindENTITY,
3942 		    FFEINFO_whereCONSTANT,
3943 		    FFETARGET_charactersizeNONE));
3944 
3945   if ((error != FFEBAD)
3946       && ffebad_start (error))
3947     {
3948       ffebad_here (0, ffelex_token_where_line (t),
3949 		   ffelex_token_where_column (t));
3950       ffebad_finish ();
3951     }
3952 
3953   return expr;
3954 }
3955 
3956 /* ffeexpr_collapse_concatenate -- Collapse concatenate expr
3957 
3958    ffebld expr;
3959    ffelexToken token;
3960    expr = ffeexpr_collapse_concatenate(expr,token);
3961 
3962    If the result of the expr is a constant, replaces the expr with the
3963    computed constant.  */
3964 
3965 ffebld
ffeexpr_collapse_concatenate(ffebld expr,ffelexToken t)3966 ffeexpr_collapse_concatenate (ffebld expr, ffelexToken t)
3967 {
3968   ffebad error = FFEBAD;
3969   ffebld l;
3970   ffebld r;
3971   ffebldConstantUnion u;
3972   ffeinfoKindtype kt;
3973   ffetargetCharacterSize len;
3974 
3975   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3976     return expr;
3977 
3978   l = ffebld_left (expr);
3979   r = ffebld_right (expr);
3980 
3981   if (ffebld_op (l) != FFEBLD_opCONTER)
3982     return expr;
3983   if (ffebld_op (r) != FFEBLD_opCONTER)
3984     return expr;
3985 
3986   switch (ffeinfo_basictype (ffebld_info (expr)))
3987     {
3988     case FFEINFO_basictypeANY:
3989       return expr;
3990 
3991     case FFEINFO_basictypeCHARACTER:
3992       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3993 	{
3994 #if FFETARGET_okCHARACTER1
3995 	case FFEINFO_kindtypeCHARACTER1:
3996 	  error = ffetarget_concatenate_character1 (ffebld_cu_ptr_character1 (u),
3997 			     ffebld_constant_character1 (ffebld_conter (l)),
3998 			     ffebld_constant_character1 (ffebld_conter (r)),
3999 				   ffebld_constant_pool (), &len);
4000 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
4001 				      (ffebld_cu_val_character1 (u)), expr);
4002 	  break;
4003 #endif
4004 
4005 	default:
4006 	  assert ("bad character kind type" == NULL);
4007 	  break;
4008 	}
4009       break;
4010 
4011     default:
4012       assert ("bad type" == NULL);
4013       return expr;
4014     }
4015 
4016   ffebld_set_info (expr, ffeinfo_new
4017 		   (FFEINFO_basictypeCHARACTER,
4018 		    kt,
4019 		    0,
4020 		    FFEINFO_kindENTITY,
4021 		    FFEINFO_whereCONSTANT,
4022 		    len));
4023 
4024   if ((error != FFEBAD)
4025       && ffebad_start (error))
4026     {
4027       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4028       ffebad_finish ();
4029     }
4030 
4031   return expr;
4032 }
4033 
4034 /* ffeexpr_collapse_eq -- Collapse eq expr
4035 
4036    ffebld expr;
4037    ffelexToken token;
4038    expr = ffeexpr_collapse_eq(expr,token);
4039 
4040    If the result of the expr is a constant, replaces the expr with the
4041    computed constant.  */
4042 
4043 ffebld
ffeexpr_collapse_eq(ffebld expr,ffelexToken t)4044 ffeexpr_collapse_eq (ffebld expr, ffelexToken t)
4045 {
4046   ffebad error = FFEBAD;
4047   ffebld l;
4048   ffebld r;
4049   bool val;
4050 
4051   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4052     return expr;
4053 
4054   l = ffebld_left (expr);
4055   r = ffebld_right (expr);
4056 
4057   if (ffebld_op (l) != FFEBLD_opCONTER)
4058     return expr;
4059   if (ffebld_op (r) != FFEBLD_opCONTER)
4060     return expr;
4061 
4062   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4063     {
4064     case FFEINFO_basictypeANY:
4065       return expr;
4066 
4067     case FFEINFO_basictypeINTEGER:
4068       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4069 	{
4070 #if FFETARGET_okINTEGER1
4071 	case FFEINFO_kindtypeINTEGER1:
4072 	  error = ffetarget_eq_integer1 (&val,
4073 			       ffebld_constant_integer1 (ffebld_conter (l)),
4074 			      ffebld_constant_integer1 (ffebld_conter (r)));
4075 	  expr = ffebld_new_conter_with_orig
4076 	    (ffebld_constant_new_logicaldefault (val), expr);
4077 	  break;
4078 #endif
4079 
4080 #if FFETARGET_okINTEGER2
4081 	case FFEINFO_kindtypeINTEGER2:
4082 	  error = ffetarget_eq_integer2 (&val,
4083 			       ffebld_constant_integer2 (ffebld_conter (l)),
4084 			      ffebld_constant_integer2 (ffebld_conter (r)));
4085 	  expr = ffebld_new_conter_with_orig
4086 	    (ffebld_constant_new_logicaldefault (val), expr);
4087 	  break;
4088 #endif
4089 
4090 #if FFETARGET_okINTEGER3
4091 	case FFEINFO_kindtypeINTEGER3:
4092 	  error = ffetarget_eq_integer3 (&val,
4093 			       ffebld_constant_integer3 (ffebld_conter (l)),
4094 			      ffebld_constant_integer3 (ffebld_conter (r)));
4095 	  expr = ffebld_new_conter_with_orig
4096 	    (ffebld_constant_new_logicaldefault (val), expr);
4097 	  break;
4098 #endif
4099 
4100 #if FFETARGET_okINTEGER4
4101 	case FFEINFO_kindtypeINTEGER4:
4102 	  error = ffetarget_eq_integer4 (&val,
4103 			       ffebld_constant_integer4 (ffebld_conter (l)),
4104 			      ffebld_constant_integer4 (ffebld_conter (r)));
4105 	  expr = ffebld_new_conter_with_orig
4106 	    (ffebld_constant_new_logicaldefault (val), expr);
4107 	  break;
4108 #endif
4109 
4110 	default:
4111 	  assert ("bad integer kind type" == NULL);
4112 	  break;
4113 	}
4114       break;
4115 
4116     case FFEINFO_basictypeREAL:
4117       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4118 	{
4119 #if FFETARGET_okREAL1
4120 	case FFEINFO_kindtypeREAL1:
4121 	  error = ffetarget_eq_real1 (&val,
4122 				  ffebld_constant_real1 (ffebld_conter (l)),
4123 				 ffebld_constant_real1 (ffebld_conter (r)));
4124 	  expr = ffebld_new_conter_with_orig
4125 	    (ffebld_constant_new_logicaldefault (val), expr);
4126 	  break;
4127 #endif
4128 
4129 #if FFETARGET_okREAL2
4130 	case FFEINFO_kindtypeREAL2:
4131 	  error = ffetarget_eq_real2 (&val,
4132 				  ffebld_constant_real2 (ffebld_conter (l)),
4133 				 ffebld_constant_real2 (ffebld_conter (r)));
4134 	  expr = ffebld_new_conter_with_orig
4135 	    (ffebld_constant_new_logicaldefault (val), expr);
4136 	  break;
4137 #endif
4138 
4139 #if FFETARGET_okREAL3
4140 	case FFEINFO_kindtypeREAL3:
4141 	  error = ffetarget_eq_real3 (&val,
4142 				  ffebld_constant_real3 (ffebld_conter (l)),
4143 				 ffebld_constant_real3 (ffebld_conter (r)));
4144 	  expr = ffebld_new_conter_with_orig
4145 	    (ffebld_constant_new_logicaldefault (val), expr);
4146 	  break;
4147 #endif
4148 
4149 	default:
4150 	  assert ("bad real kind type" == NULL);
4151 	  break;
4152 	}
4153       break;
4154 
4155     case FFEINFO_basictypeCOMPLEX:
4156       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4157 	{
4158 #if FFETARGET_okCOMPLEX1
4159 	case FFEINFO_kindtypeREAL1:
4160 	  error = ffetarget_eq_complex1 (&val,
4161 			       ffebld_constant_complex1 (ffebld_conter (l)),
4162 			      ffebld_constant_complex1 (ffebld_conter (r)));
4163 	  expr = ffebld_new_conter_with_orig
4164 	    (ffebld_constant_new_logicaldefault (val), expr);
4165 	  break;
4166 #endif
4167 
4168 #if FFETARGET_okCOMPLEX2
4169 	case FFEINFO_kindtypeREAL2:
4170 	  error = ffetarget_eq_complex2 (&val,
4171 			       ffebld_constant_complex2 (ffebld_conter (l)),
4172 			      ffebld_constant_complex2 (ffebld_conter (r)));
4173 	  expr = ffebld_new_conter_with_orig
4174 	    (ffebld_constant_new_logicaldefault (val), expr);
4175 	  break;
4176 #endif
4177 
4178 #if FFETARGET_okCOMPLEX3
4179 	case FFEINFO_kindtypeREAL3:
4180 	  error = ffetarget_eq_complex3 (&val,
4181 			       ffebld_constant_complex3 (ffebld_conter (l)),
4182 			      ffebld_constant_complex3 (ffebld_conter (r)));
4183 	  expr = ffebld_new_conter_with_orig
4184 	    (ffebld_constant_new_logicaldefault (val), expr);
4185 	  break;
4186 #endif
4187 
4188 	default:
4189 	  assert ("bad complex kind type" == NULL);
4190 	  break;
4191 	}
4192       break;
4193 
4194     case FFEINFO_basictypeCHARACTER:
4195       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4196 	{
4197 #if FFETARGET_okCHARACTER1
4198 	case FFEINFO_kindtypeCHARACTER1:
4199 	  error = ffetarget_eq_character1 (&val,
4200 			     ffebld_constant_character1 (ffebld_conter (l)),
4201 			    ffebld_constant_character1 (ffebld_conter (r)));
4202 	  expr = ffebld_new_conter_with_orig
4203 	    (ffebld_constant_new_logicaldefault (val), expr);
4204 	  break;
4205 #endif
4206 
4207 	default:
4208 	  assert ("bad character kind type" == NULL);
4209 	  break;
4210 	}
4211       break;
4212 
4213     default:
4214       assert ("bad type" == NULL);
4215       return expr;
4216     }
4217 
4218   ffebld_set_info (expr, ffeinfo_new
4219 		   (FFEINFO_basictypeLOGICAL,
4220 		    FFEINFO_kindtypeLOGICALDEFAULT,
4221 		    0,
4222 		    FFEINFO_kindENTITY,
4223 		    FFEINFO_whereCONSTANT,
4224 		    FFETARGET_charactersizeNONE));
4225 
4226   if ((error != FFEBAD)
4227       && ffebad_start (error))
4228     {
4229       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4230       ffebad_finish ();
4231     }
4232 
4233   return expr;
4234 }
4235 
4236 /* ffeexpr_collapse_ne -- Collapse ne expr
4237 
4238    ffebld expr;
4239    ffelexToken token;
4240    expr = ffeexpr_collapse_ne(expr,token);
4241 
4242    If the result of the expr is a constant, replaces the expr with the
4243    computed constant.  */
4244 
4245 ffebld
ffeexpr_collapse_ne(ffebld expr,ffelexToken t)4246 ffeexpr_collapse_ne (ffebld expr, ffelexToken t)
4247 {
4248   ffebad error = FFEBAD;
4249   ffebld l;
4250   ffebld r;
4251   bool val;
4252 
4253   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4254     return expr;
4255 
4256   l = ffebld_left (expr);
4257   r = ffebld_right (expr);
4258 
4259   if (ffebld_op (l) != FFEBLD_opCONTER)
4260     return expr;
4261   if (ffebld_op (r) != FFEBLD_opCONTER)
4262     return expr;
4263 
4264   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4265     {
4266     case FFEINFO_basictypeANY:
4267       return expr;
4268 
4269     case FFEINFO_basictypeINTEGER:
4270       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4271 	{
4272 #if FFETARGET_okINTEGER1
4273 	case FFEINFO_kindtypeINTEGER1:
4274 	  error = ffetarget_ne_integer1 (&val,
4275 			       ffebld_constant_integer1 (ffebld_conter (l)),
4276 			      ffebld_constant_integer1 (ffebld_conter (r)));
4277 	  expr = ffebld_new_conter_with_orig
4278 	    (ffebld_constant_new_logicaldefault (val), expr);
4279 	  break;
4280 #endif
4281 
4282 #if FFETARGET_okINTEGER2
4283 	case FFEINFO_kindtypeINTEGER2:
4284 	  error = ffetarget_ne_integer2 (&val,
4285 			       ffebld_constant_integer2 (ffebld_conter (l)),
4286 			      ffebld_constant_integer2 (ffebld_conter (r)));
4287 	  expr = ffebld_new_conter_with_orig
4288 	    (ffebld_constant_new_logicaldefault (val), expr);
4289 	  break;
4290 #endif
4291 
4292 #if FFETARGET_okINTEGER3
4293 	case FFEINFO_kindtypeINTEGER3:
4294 	  error = ffetarget_ne_integer3 (&val,
4295 			       ffebld_constant_integer3 (ffebld_conter (l)),
4296 			      ffebld_constant_integer3 (ffebld_conter (r)));
4297 	  expr = ffebld_new_conter_with_orig
4298 	    (ffebld_constant_new_logicaldefault (val), expr);
4299 	  break;
4300 #endif
4301 
4302 #if FFETARGET_okINTEGER4
4303 	case FFEINFO_kindtypeINTEGER4:
4304 	  error = ffetarget_ne_integer4 (&val,
4305 			       ffebld_constant_integer4 (ffebld_conter (l)),
4306 			      ffebld_constant_integer4 (ffebld_conter (r)));
4307 	  expr = ffebld_new_conter_with_orig
4308 	    (ffebld_constant_new_logicaldefault (val), expr);
4309 	  break;
4310 #endif
4311 
4312 	default:
4313 	  assert ("bad integer kind type" == NULL);
4314 	  break;
4315 	}
4316       break;
4317 
4318     case FFEINFO_basictypeREAL:
4319       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4320 	{
4321 #if FFETARGET_okREAL1
4322 	case FFEINFO_kindtypeREAL1:
4323 	  error = ffetarget_ne_real1 (&val,
4324 				  ffebld_constant_real1 (ffebld_conter (l)),
4325 				 ffebld_constant_real1 (ffebld_conter (r)));
4326 	  expr = ffebld_new_conter_with_orig
4327 	    (ffebld_constant_new_logicaldefault (val), expr);
4328 	  break;
4329 #endif
4330 
4331 #if FFETARGET_okREAL2
4332 	case FFEINFO_kindtypeREAL2:
4333 	  error = ffetarget_ne_real2 (&val,
4334 				  ffebld_constant_real2 (ffebld_conter (l)),
4335 				 ffebld_constant_real2 (ffebld_conter (r)));
4336 	  expr = ffebld_new_conter_with_orig
4337 	    (ffebld_constant_new_logicaldefault (val), expr);
4338 	  break;
4339 #endif
4340 
4341 #if FFETARGET_okREAL3
4342 	case FFEINFO_kindtypeREAL3:
4343 	  error = ffetarget_ne_real3 (&val,
4344 				  ffebld_constant_real3 (ffebld_conter (l)),
4345 				 ffebld_constant_real3 (ffebld_conter (r)));
4346 	  expr = ffebld_new_conter_with_orig
4347 	    (ffebld_constant_new_logicaldefault (val), expr);
4348 	  break;
4349 #endif
4350 
4351 	default:
4352 	  assert ("bad real kind type" == NULL);
4353 	  break;
4354 	}
4355       break;
4356 
4357     case FFEINFO_basictypeCOMPLEX:
4358       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4359 	{
4360 #if FFETARGET_okCOMPLEX1
4361 	case FFEINFO_kindtypeREAL1:
4362 	  error = ffetarget_ne_complex1 (&val,
4363 			       ffebld_constant_complex1 (ffebld_conter (l)),
4364 			      ffebld_constant_complex1 (ffebld_conter (r)));
4365 	  expr = ffebld_new_conter_with_orig
4366 	    (ffebld_constant_new_logicaldefault (val), expr);
4367 	  break;
4368 #endif
4369 
4370 #if FFETARGET_okCOMPLEX2
4371 	case FFEINFO_kindtypeREAL2:
4372 	  error = ffetarget_ne_complex2 (&val,
4373 			       ffebld_constant_complex2 (ffebld_conter (l)),
4374 			      ffebld_constant_complex2 (ffebld_conter (r)));
4375 	  expr = ffebld_new_conter_with_orig
4376 	    (ffebld_constant_new_logicaldefault (val), expr);
4377 	  break;
4378 #endif
4379 
4380 #if FFETARGET_okCOMPLEX3
4381 	case FFEINFO_kindtypeREAL3:
4382 	  error = ffetarget_ne_complex3 (&val,
4383 			       ffebld_constant_complex3 (ffebld_conter (l)),
4384 			      ffebld_constant_complex3 (ffebld_conter (r)));
4385 	  expr = ffebld_new_conter_with_orig
4386 	    (ffebld_constant_new_logicaldefault (val), expr);
4387 	  break;
4388 #endif
4389 
4390 	default:
4391 	  assert ("bad complex kind type" == NULL);
4392 	  break;
4393 	}
4394       break;
4395 
4396     case FFEINFO_basictypeCHARACTER:
4397       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4398 	{
4399 #if FFETARGET_okCHARACTER1
4400 	case FFEINFO_kindtypeCHARACTER1:
4401 	  error = ffetarget_ne_character1 (&val,
4402 			     ffebld_constant_character1 (ffebld_conter (l)),
4403 			    ffebld_constant_character1 (ffebld_conter (r)));
4404 	  expr = ffebld_new_conter_with_orig
4405 	    (ffebld_constant_new_logicaldefault (val), expr);
4406 	  break;
4407 #endif
4408 
4409 	default:
4410 	  assert ("bad character kind type" == NULL);
4411 	  break;
4412 	}
4413       break;
4414 
4415     default:
4416       assert ("bad type" == NULL);
4417       return expr;
4418     }
4419 
4420   ffebld_set_info (expr, ffeinfo_new
4421 		   (FFEINFO_basictypeLOGICAL,
4422 		    FFEINFO_kindtypeLOGICALDEFAULT,
4423 		    0,
4424 		    FFEINFO_kindENTITY,
4425 		    FFEINFO_whereCONSTANT,
4426 		    FFETARGET_charactersizeNONE));
4427 
4428   if ((error != FFEBAD)
4429       && ffebad_start (error))
4430     {
4431       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4432       ffebad_finish ();
4433     }
4434 
4435   return expr;
4436 }
4437 
4438 /* ffeexpr_collapse_ge -- Collapse ge expr
4439 
4440    ffebld expr;
4441    ffelexToken token;
4442    expr = ffeexpr_collapse_ge(expr,token);
4443 
4444    If the result of the expr is a constant, replaces the expr with the
4445    computed constant.  */
4446 
4447 ffebld
ffeexpr_collapse_ge(ffebld expr,ffelexToken t)4448 ffeexpr_collapse_ge (ffebld expr, ffelexToken t)
4449 {
4450   ffebad error = FFEBAD;
4451   ffebld l;
4452   ffebld r;
4453   bool val;
4454 
4455   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4456     return expr;
4457 
4458   l = ffebld_left (expr);
4459   r = ffebld_right (expr);
4460 
4461   if (ffebld_op (l) != FFEBLD_opCONTER)
4462     return expr;
4463   if (ffebld_op (r) != FFEBLD_opCONTER)
4464     return expr;
4465 
4466   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4467     {
4468     case FFEINFO_basictypeANY:
4469       return expr;
4470 
4471     case FFEINFO_basictypeINTEGER:
4472       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4473 	{
4474 #if FFETARGET_okINTEGER1
4475 	case FFEINFO_kindtypeINTEGER1:
4476 	  error = ffetarget_ge_integer1 (&val,
4477 			       ffebld_constant_integer1 (ffebld_conter (l)),
4478 			      ffebld_constant_integer1 (ffebld_conter (r)));
4479 	  expr = ffebld_new_conter_with_orig
4480 	    (ffebld_constant_new_logicaldefault (val), expr);
4481 	  break;
4482 #endif
4483 
4484 #if FFETARGET_okINTEGER2
4485 	case FFEINFO_kindtypeINTEGER2:
4486 	  error = ffetarget_ge_integer2 (&val,
4487 			       ffebld_constant_integer2 (ffebld_conter (l)),
4488 			      ffebld_constant_integer2 (ffebld_conter (r)));
4489 	  expr = ffebld_new_conter_with_orig
4490 	    (ffebld_constant_new_logicaldefault (val), expr);
4491 	  break;
4492 #endif
4493 
4494 #if FFETARGET_okINTEGER3
4495 	case FFEINFO_kindtypeINTEGER3:
4496 	  error = ffetarget_ge_integer3 (&val,
4497 			       ffebld_constant_integer3 (ffebld_conter (l)),
4498 			      ffebld_constant_integer3 (ffebld_conter (r)));
4499 	  expr = ffebld_new_conter_with_orig
4500 	    (ffebld_constant_new_logicaldefault (val), expr);
4501 	  break;
4502 #endif
4503 
4504 #if FFETARGET_okINTEGER4
4505 	case FFEINFO_kindtypeINTEGER4:
4506 	  error = ffetarget_ge_integer4 (&val,
4507 			       ffebld_constant_integer4 (ffebld_conter (l)),
4508 			      ffebld_constant_integer4 (ffebld_conter (r)));
4509 	  expr = ffebld_new_conter_with_orig
4510 	    (ffebld_constant_new_logicaldefault (val), expr);
4511 	  break;
4512 #endif
4513 
4514 	default:
4515 	  assert ("bad integer kind type" == NULL);
4516 	  break;
4517 	}
4518       break;
4519 
4520     case FFEINFO_basictypeREAL:
4521       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4522 	{
4523 #if FFETARGET_okREAL1
4524 	case FFEINFO_kindtypeREAL1:
4525 	  error = ffetarget_ge_real1 (&val,
4526 				  ffebld_constant_real1 (ffebld_conter (l)),
4527 				 ffebld_constant_real1 (ffebld_conter (r)));
4528 	  expr = ffebld_new_conter_with_orig
4529 	    (ffebld_constant_new_logicaldefault (val), expr);
4530 	  break;
4531 #endif
4532 
4533 #if FFETARGET_okREAL2
4534 	case FFEINFO_kindtypeREAL2:
4535 	  error = ffetarget_ge_real2 (&val,
4536 				  ffebld_constant_real2 (ffebld_conter (l)),
4537 				 ffebld_constant_real2 (ffebld_conter (r)));
4538 	  expr = ffebld_new_conter_with_orig
4539 	    (ffebld_constant_new_logicaldefault (val), expr);
4540 	  break;
4541 #endif
4542 
4543 #if FFETARGET_okREAL3
4544 	case FFEINFO_kindtypeREAL3:
4545 	  error = ffetarget_ge_real3 (&val,
4546 				  ffebld_constant_real3 (ffebld_conter (l)),
4547 				 ffebld_constant_real3 (ffebld_conter (r)));
4548 	  expr = ffebld_new_conter_with_orig
4549 	    (ffebld_constant_new_logicaldefault (val), expr);
4550 	  break;
4551 #endif
4552 
4553 	default:
4554 	  assert ("bad real kind type" == NULL);
4555 	  break;
4556 	}
4557       break;
4558 
4559     case FFEINFO_basictypeCHARACTER:
4560       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4561 	{
4562 #if FFETARGET_okCHARACTER1
4563 	case FFEINFO_kindtypeCHARACTER1:
4564 	  error = ffetarget_ge_character1 (&val,
4565 			     ffebld_constant_character1 (ffebld_conter (l)),
4566 			    ffebld_constant_character1 (ffebld_conter (r)));
4567 	  expr = ffebld_new_conter_with_orig
4568 	    (ffebld_constant_new_logicaldefault (val), expr);
4569 	  break;
4570 #endif
4571 
4572 	default:
4573 	  assert ("bad character kind type" == NULL);
4574 	  break;
4575 	}
4576       break;
4577 
4578     default:
4579       assert ("bad type" == NULL);
4580       return expr;
4581     }
4582 
4583   ffebld_set_info (expr, ffeinfo_new
4584 		   (FFEINFO_basictypeLOGICAL,
4585 		    FFEINFO_kindtypeLOGICALDEFAULT,
4586 		    0,
4587 		    FFEINFO_kindENTITY,
4588 		    FFEINFO_whereCONSTANT,
4589 		    FFETARGET_charactersizeNONE));
4590 
4591   if ((error != FFEBAD)
4592       && ffebad_start (error))
4593     {
4594       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4595       ffebad_finish ();
4596     }
4597 
4598   return expr;
4599 }
4600 
4601 /* ffeexpr_collapse_gt -- Collapse gt expr
4602 
4603    ffebld expr;
4604    ffelexToken token;
4605    expr = ffeexpr_collapse_gt(expr,token);
4606 
4607    If the result of the expr is a constant, replaces the expr with the
4608    computed constant.  */
4609 
4610 ffebld
ffeexpr_collapse_gt(ffebld expr,ffelexToken t)4611 ffeexpr_collapse_gt (ffebld expr, ffelexToken t)
4612 {
4613   ffebad error = FFEBAD;
4614   ffebld l;
4615   ffebld r;
4616   bool val;
4617 
4618   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4619     return expr;
4620 
4621   l = ffebld_left (expr);
4622   r = ffebld_right (expr);
4623 
4624   if (ffebld_op (l) != FFEBLD_opCONTER)
4625     return expr;
4626   if (ffebld_op (r) != FFEBLD_opCONTER)
4627     return expr;
4628 
4629   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4630     {
4631     case FFEINFO_basictypeANY:
4632       return expr;
4633 
4634     case FFEINFO_basictypeINTEGER:
4635       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4636 	{
4637 #if FFETARGET_okINTEGER1
4638 	case FFEINFO_kindtypeINTEGER1:
4639 	  error = ffetarget_gt_integer1 (&val,
4640 			       ffebld_constant_integer1 (ffebld_conter (l)),
4641 			      ffebld_constant_integer1 (ffebld_conter (r)));
4642 	  expr = ffebld_new_conter_with_orig
4643 	    (ffebld_constant_new_logicaldefault (val), expr);
4644 	  break;
4645 #endif
4646 
4647 #if FFETARGET_okINTEGER2
4648 	case FFEINFO_kindtypeINTEGER2:
4649 	  error = ffetarget_gt_integer2 (&val,
4650 			       ffebld_constant_integer2 (ffebld_conter (l)),
4651 			      ffebld_constant_integer2 (ffebld_conter (r)));
4652 	  expr = ffebld_new_conter_with_orig
4653 	    (ffebld_constant_new_logicaldefault (val), expr);
4654 	  break;
4655 #endif
4656 
4657 #if FFETARGET_okINTEGER3
4658 	case FFEINFO_kindtypeINTEGER3:
4659 	  error = ffetarget_gt_integer3 (&val,
4660 			       ffebld_constant_integer3 (ffebld_conter (l)),
4661 			      ffebld_constant_integer3 (ffebld_conter (r)));
4662 	  expr = ffebld_new_conter_with_orig
4663 	    (ffebld_constant_new_logicaldefault (val), expr);
4664 	  break;
4665 #endif
4666 
4667 #if FFETARGET_okINTEGER4
4668 	case FFEINFO_kindtypeINTEGER4:
4669 	  error = ffetarget_gt_integer4 (&val,
4670 			       ffebld_constant_integer4 (ffebld_conter (l)),
4671 			      ffebld_constant_integer4 (ffebld_conter (r)));
4672 	  expr = ffebld_new_conter_with_orig
4673 	    (ffebld_constant_new_logicaldefault (val), expr);
4674 	  break;
4675 #endif
4676 
4677 	default:
4678 	  assert ("bad integer kind type" == NULL);
4679 	  break;
4680 	}
4681       break;
4682 
4683     case FFEINFO_basictypeREAL:
4684       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4685 	{
4686 #if FFETARGET_okREAL1
4687 	case FFEINFO_kindtypeREAL1:
4688 	  error = ffetarget_gt_real1 (&val,
4689 				  ffebld_constant_real1 (ffebld_conter (l)),
4690 				 ffebld_constant_real1 (ffebld_conter (r)));
4691 	  expr = ffebld_new_conter_with_orig
4692 	    (ffebld_constant_new_logicaldefault (val), expr);
4693 	  break;
4694 #endif
4695 
4696 #if FFETARGET_okREAL2
4697 	case FFEINFO_kindtypeREAL2:
4698 	  error = ffetarget_gt_real2 (&val,
4699 				  ffebld_constant_real2 (ffebld_conter (l)),
4700 				 ffebld_constant_real2 (ffebld_conter (r)));
4701 	  expr = ffebld_new_conter_with_orig
4702 	    (ffebld_constant_new_logicaldefault (val), expr);
4703 	  break;
4704 #endif
4705 
4706 #if FFETARGET_okREAL3
4707 	case FFEINFO_kindtypeREAL3:
4708 	  error = ffetarget_gt_real3 (&val,
4709 				  ffebld_constant_real3 (ffebld_conter (l)),
4710 				 ffebld_constant_real3 (ffebld_conter (r)));
4711 	  expr = ffebld_new_conter_with_orig
4712 	    (ffebld_constant_new_logicaldefault (val), expr);
4713 	  break;
4714 #endif
4715 
4716 	default:
4717 	  assert ("bad real kind type" == NULL);
4718 	  break;
4719 	}
4720       break;
4721 
4722     case FFEINFO_basictypeCHARACTER:
4723       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4724 	{
4725 #if FFETARGET_okCHARACTER1
4726 	case FFEINFO_kindtypeCHARACTER1:
4727 	  error = ffetarget_gt_character1 (&val,
4728 			     ffebld_constant_character1 (ffebld_conter (l)),
4729 			    ffebld_constant_character1 (ffebld_conter (r)));
4730 	  expr = ffebld_new_conter_with_orig
4731 	    (ffebld_constant_new_logicaldefault (val), expr);
4732 	  break;
4733 #endif
4734 
4735 	default:
4736 	  assert ("bad character kind type" == NULL);
4737 	  break;
4738 	}
4739       break;
4740 
4741     default:
4742       assert ("bad type" == NULL);
4743       return expr;
4744     }
4745 
4746   ffebld_set_info (expr, ffeinfo_new
4747 		   (FFEINFO_basictypeLOGICAL,
4748 		    FFEINFO_kindtypeLOGICALDEFAULT,
4749 		    0,
4750 		    FFEINFO_kindENTITY,
4751 		    FFEINFO_whereCONSTANT,
4752 		    FFETARGET_charactersizeNONE));
4753 
4754   if ((error != FFEBAD)
4755       && ffebad_start (error))
4756     {
4757       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4758       ffebad_finish ();
4759     }
4760 
4761   return expr;
4762 }
4763 
4764 /* ffeexpr_collapse_le -- Collapse le expr
4765 
4766    ffebld expr;
4767    ffelexToken token;
4768    expr = ffeexpr_collapse_le(expr,token);
4769 
4770    If the result of the expr is a constant, replaces the expr with the
4771    computed constant.  */
4772 
4773 ffebld
ffeexpr_collapse_le(ffebld expr,ffelexToken t)4774 ffeexpr_collapse_le (ffebld expr, ffelexToken t)
4775 {
4776   ffebad error = FFEBAD;
4777   ffebld l;
4778   ffebld r;
4779   bool val;
4780 
4781   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4782     return expr;
4783 
4784   l = ffebld_left (expr);
4785   r = ffebld_right (expr);
4786 
4787   if (ffebld_op (l) != FFEBLD_opCONTER)
4788     return expr;
4789   if (ffebld_op (r) != FFEBLD_opCONTER)
4790     return expr;
4791 
4792   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4793     {
4794     case FFEINFO_basictypeANY:
4795       return expr;
4796 
4797     case FFEINFO_basictypeINTEGER:
4798       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4799 	{
4800 #if FFETARGET_okINTEGER1
4801 	case FFEINFO_kindtypeINTEGER1:
4802 	  error = ffetarget_le_integer1 (&val,
4803 			       ffebld_constant_integer1 (ffebld_conter (l)),
4804 			      ffebld_constant_integer1 (ffebld_conter (r)));
4805 	  expr = ffebld_new_conter_with_orig
4806 	    (ffebld_constant_new_logicaldefault (val), expr);
4807 	  break;
4808 #endif
4809 
4810 #if FFETARGET_okINTEGER2
4811 	case FFEINFO_kindtypeINTEGER2:
4812 	  error = ffetarget_le_integer2 (&val,
4813 			       ffebld_constant_integer2 (ffebld_conter (l)),
4814 			      ffebld_constant_integer2 (ffebld_conter (r)));
4815 	  expr = ffebld_new_conter_with_orig
4816 	    (ffebld_constant_new_logicaldefault (val), expr);
4817 	  break;
4818 #endif
4819 
4820 #if FFETARGET_okINTEGER3
4821 	case FFEINFO_kindtypeINTEGER3:
4822 	  error = ffetarget_le_integer3 (&val,
4823 			       ffebld_constant_integer3 (ffebld_conter (l)),
4824 			      ffebld_constant_integer3 (ffebld_conter (r)));
4825 	  expr = ffebld_new_conter_with_orig
4826 	    (ffebld_constant_new_logicaldefault (val), expr);
4827 	  break;
4828 #endif
4829 
4830 #if FFETARGET_okINTEGER4
4831 	case FFEINFO_kindtypeINTEGER4:
4832 	  error = ffetarget_le_integer4 (&val,
4833 			       ffebld_constant_integer4 (ffebld_conter (l)),
4834 			      ffebld_constant_integer4 (ffebld_conter (r)));
4835 	  expr = ffebld_new_conter_with_orig
4836 	    (ffebld_constant_new_logicaldefault (val), expr);
4837 	  break;
4838 #endif
4839 
4840 	default:
4841 	  assert ("bad integer kind type" == NULL);
4842 	  break;
4843 	}
4844       break;
4845 
4846     case FFEINFO_basictypeREAL:
4847       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4848 	{
4849 #if FFETARGET_okREAL1
4850 	case FFEINFO_kindtypeREAL1:
4851 	  error = ffetarget_le_real1 (&val,
4852 				  ffebld_constant_real1 (ffebld_conter (l)),
4853 				 ffebld_constant_real1 (ffebld_conter (r)));
4854 	  expr = ffebld_new_conter_with_orig
4855 	    (ffebld_constant_new_logicaldefault (val), expr);
4856 	  break;
4857 #endif
4858 
4859 #if FFETARGET_okREAL2
4860 	case FFEINFO_kindtypeREAL2:
4861 	  error = ffetarget_le_real2 (&val,
4862 				  ffebld_constant_real2 (ffebld_conter (l)),
4863 				 ffebld_constant_real2 (ffebld_conter (r)));
4864 	  expr = ffebld_new_conter_with_orig
4865 	    (ffebld_constant_new_logicaldefault (val), expr);
4866 	  break;
4867 #endif
4868 
4869 #if FFETARGET_okREAL3
4870 	case FFEINFO_kindtypeREAL3:
4871 	  error = ffetarget_le_real3 (&val,
4872 				  ffebld_constant_real3 (ffebld_conter (l)),
4873 				 ffebld_constant_real3 (ffebld_conter (r)));
4874 	  expr = ffebld_new_conter_with_orig
4875 	    (ffebld_constant_new_logicaldefault (val), expr);
4876 	  break;
4877 #endif
4878 
4879 	default:
4880 	  assert ("bad real kind type" == NULL);
4881 	  break;
4882 	}
4883       break;
4884 
4885     case FFEINFO_basictypeCHARACTER:
4886       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4887 	{
4888 #if FFETARGET_okCHARACTER1
4889 	case FFEINFO_kindtypeCHARACTER1:
4890 	  error = ffetarget_le_character1 (&val,
4891 			     ffebld_constant_character1 (ffebld_conter (l)),
4892 			    ffebld_constant_character1 (ffebld_conter (r)));
4893 	  expr = ffebld_new_conter_with_orig
4894 	    (ffebld_constant_new_logicaldefault (val), expr);
4895 	  break;
4896 #endif
4897 
4898 	default:
4899 	  assert ("bad character kind type" == NULL);
4900 	  break;
4901 	}
4902       break;
4903 
4904     default:
4905       assert ("bad type" == NULL);
4906       return expr;
4907     }
4908 
4909   ffebld_set_info (expr, ffeinfo_new
4910 		   (FFEINFO_basictypeLOGICAL,
4911 		    FFEINFO_kindtypeLOGICALDEFAULT,
4912 		    0,
4913 		    FFEINFO_kindENTITY,
4914 		    FFEINFO_whereCONSTANT,
4915 		    FFETARGET_charactersizeNONE));
4916 
4917   if ((error != FFEBAD)
4918       && ffebad_start (error))
4919     {
4920       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4921       ffebad_finish ();
4922     }
4923 
4924   return expr;
4925 }
4926 
4927 /* ffeexpr_collapse_lt -- Collapse lt expr
4928 
4929    ffebld expr;
4930    ffelexToken token;
4931    expr = ffeexpr_collapse_lt(expr,token);
4932 
4933    If the result of the expr is a constant, replaces the expr with the
4934    computed constant.  */
4935 
4936 ffebld
ffeexpr_collapse_lt(ffebld expr,ffelexToken t)4937 ffeexpr_collapse_lt (ffebld expr, ffelexToken t)
4938 {
4939   ffebad error = FFEBAD;
4940   ffebld l;
4941   ffebld r;
4942   bool val;
4943 
4944   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4945     return expr;
4946 
4947   l = ffebld_left (expr);
4948   r = ffebld_right (expr);
4949 
4950   if (ffebld_op (l) != FFEBLD_opCONTER)
4951     return expr;
4952   if (ffebld_op (r) != FFEBLD_opCONTER)
4953     return expr;
4954 
4955   switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4956     {
4957     case FFEINFO_basictypeANY:
4958       return expr;
4959 
4960     case FFEINFO_basictypeINTEGER:
4961       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4962 	{
4963 #if FFETARGET_okINTEGER1
4964 	case FFEINFO_kindtypeINTEGER1:
4965 	  error = ffetarget_lt_integer1 (&val,
4966 			       ffebld_constant_integer1 (ffebld_conter (l)),
4967 			      ffebld_constant_integer1 (ffebld_conter (r)));
4968 	  expr = ffebld_new_conter_with_orig
4969 	    (ffebld_constant_new_logicaldefault (val), expr);
4970 	  break;
4971 #endif
4972 
4973 #if FFETARGET_okINTEGER2
4974 	case FFEINFO_kindtypeINTEGER2:
4975 	  error = ffetarget_lt_integer2 (&val,
4976 			       ffebld_constant_integer2 (ffebld_conter (l)),
4977 			      ffebld_constant_integer2 (ffebld_conter (r)));
4978 	  expr = ffebld_new_conter_with_orig
4979 	    (ffebld_constant_new_logicaldefault (val), expr);
4980 	  break;
4981 #endif
4982 
4983 #if FFETARGET_okINTEGER3
4984 	case FFEINFO_kindtypeINTEGER3:
4985 	  error = ffetarget_lt_integer3 (&val,
4986 			       ffebld_constant_integer3 (ffebld_conter (l)),
4987 			      ffebld_constant_integer3 (ffebld_conter (r)));
4988 	  expr = ffebld_new_conter_with_orig
4989 	    (ffebld_constant_new_logicaldefault (val), expr);
4990 	  break;
4991 #endif
4992 
4993 #if FFETARGET_okINTEGER4
4994 	case FFEINFO_kindtypeINTEGER4:
4995 	  error = ffetarget_lt_integer4 (&val,
4996 			       ffebld_constant_integer4 (ffebld_conter (l)),
4997 			      ffebld_constant_integer4 (ffebld_conter (r)));
4998 	  expr = ffebld_new_conter_with_orig
4999 	    (ffebld_constant_new_logicaldefault (val), expr);
5000 	  break;
5001 #endif
5002 
5003 	default:
5004 	  assert ("bad integer kind type" == NULL);
5005 	  break;
5006 	}
5007       break;
5008 
5009     case FFEINFO_basictypeREAL:
5010       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5011 	{
5012 #if FFETARGET_okREAL1
5013 	case FFEINFO_kindtypeREAL1:
5014 	  error = ffetarget_lt_real1 (&val,
5015 				  ffebld_constant_real1 (ffebld_conter (l)),
5016 				 ffebld_constant_real1 (ffebld_conter (r)));
5017 	  expr = ffebld_new_conter_with_orig
5018 	    (ffebld_constant_new_logicaldefault (val), expr);
5019 	  break;
5020 #endif
5021 
5022 #if FFETARGET_okREAL2
5023 	case FFEINFO_kindtypeREAL2:
5024 	  error = ffetarget_lt_real2 (&val,
5025 				  ffebld_constant_real2 (ffebld_conter (l)),
5026 				 ffebld_constant_real2 (ffebld_conter (r)));
5027 	  expr = ffebld_new_conter_with_orig
5028 	    (ffebld_constant_new_logicaldefault (val), expr);
5029 	  break;
5030 #endif
5031 
5032 #if FFETARGET_okREAL3
5033 	case FFEINFO_kindtypeREAL3:
5034 	  error = ffetarget_lt_real3 (&val,
5035 				  ffebld_constant_real3 (ffebld_conter (l)),
5036 				 ffebld_constant_real3 (ffebld_conter (r)));
5037 	  expr = ffebld_new_conter_with_orig
5038 	    (ffebld_constant_new_logicaldefault (val), expr);
5039 	  break;
5040 #endif
5041 
5042 	default:
5043 	  assert ("bad real kind type" == NULL);
5044 	  break;
5045 	}
5046       break;
5047 
5048     case FFEINFO_basictypeCHARACTER:
5049       switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5050 	{
5051 #if FFETARGET_okCHARACTER1
5052 	case FFEINFO_kindtypeCHARACTER1:
5053 	  error = ffetarget_lt_character1 (&val,
5054 			     ffebld_constant_character1 (ffebld_conter (l)),
5055 			    ffebld_constant_character1 (ffebld_conter (r)));
5056 	  expr = ffebld_new_conter_with_orig
5057 	    (ffebld_constant_new_logicaldefault (val), expr);
5058 	  break;
5059 #endif
5060 
5061 	default:
5062 	  assert ("bad character kind type" == NULL);
5063 	  break;
5064 	}
5065       break;
5066 
5067     default:
5068       assert ("bad type" == NULL);
5069       return expr;
5070     }
5071 
5072   ffebld_set_info (expr, ffeinfo_new
5073 		   (FFEINFO_basictypeLOGICAL,
5074 		    FFEINFO_kindtypeLOGICALDEFAULT,
5075 		    0,
5076 		    FFEINFO_kindENTITY,
5077 		    FFEINFO_whereCONSTANT,
5078 		    FFETARGET_charactersizeNONE));
5079 
5080   if ((error != FFEBAD)
5081       && ffebad_start (error))
5082     {
5083       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5084       ffebad_finish ();
5085     }
5086 
5087   return expr;
5088 }
5089 
5090 /* ffeexpr_collapse_and -- Collapse and expr
5091 
5092    ffebld expr;
5093    ffelexToken token;
5094    expr = ffeexpr_collapse_and(expr,token);
5095 
5096    If the result of the expr is a constant, replaces the expr with the
5097    computed constant.  */
5098 
5099 ffebld
ffeexpr_collapse_and(ffebld expr,ffelexToken t)5100 ffeexpr_collapse_and (ffebld expr, ffelexToken t)
5101 {
5102   ffebad error = FFEBAD;
5103   ffebld l;
5104   ffebld r;
5105   ffebldConstantUnion u;
5106   ffeinfoBasictype bt;
5107   ffeinfoKindtype kt;
5108 
5109   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5110     return expr;
5111 
5112   l = ffebld_left (expr);
5113   r = ffebld_right (expr);
5114 
5115   if (ffebld_op (l) != FFEBLD_opCONTER)
5116     return expr;
5117   if (ffebld_op (r) != FFEBLD_opCONTER)
5118     return expr;
5119 
5120   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5121     {
5122     case FFEINFO_basictypeANY:
5123       return expr;
5124 
5125     case FFEINFO_basictypeINTEGER:
5126       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5127 	{
5128 #if FFETARGET_okINTEGER1
5129 	case FFEINFO_kindtypeINTEGER1:
5130 	  error = ffetarget_and_integer1 (ffebld_cu_ptr_integer1 (u),
5131 			       ffebld_constant_integer1 (ffebld_conter (l)),
5132 			      ffebld_constant_integer1 (ffebld_conter (r)));
5133 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5134 					(ffebld_cu_val_integer1 (u)), expr);
5135 	  break;
5136 #endif
5137 
5138 #if FFETARGET_okINTEGER2
5139 	case FFEINFO_kindtypeINTEGER2:
5140 	  error = ffetarget_and_integer2 (ffebld_cu_ptr_integer2 (u),
5141 			       ffebld_constant_integer2 (ffebld_conter (l)),
5142 			      ffebld_constant_integer2 (ffebld_conter (r)));
5143 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5144 					(ffebld_cu_val_integer2 (u)), expr);
5145 	  break;
5146 #endif
5147 
5148 #if FFETARGET_okINTEGER3
5149 	case FFEINFO_kindtypeINTEGER3:
5150 	  error = ffetarget_and_integer3 (ffebld_cu_ptr_integer3 (u),
5151 			       ffebld_constant_integer3 (ffebld_conter (l)),
5152 			      ffebld_constant_integer3 (ffebld_conter (r)));
5153 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5154 					(ffebld_cu_val_integer3 (u)), expr);
5155 	  break;
5156 #endif
5157 
5158 #if FFETARGET_okINTEGER4
5159 	case FFEINFO_kindtypeINTEGER4:
5160 	  error = ffetarget_and_integer4 (ffebld_cu_ptr_integer4 (u),
5161 			       ffebld_constant_integer4 (ffebld_conter (l)),
5162 			      ffebld_constant_integer4 (ffebld_conter (r)));
5163 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5164 					(ffebld_cu_val_integer4 (u)), expr);
5165 	  break;
5166 #endif
5167 
5168 	default:
5169 	  assert ("bad integer kind type" == NULL);
5170 	  break;
5171 	}
5172       break;
5173 
5174     case FFEINFO_basictypeLOGICAL:
5175       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5176 	{
5177 #if FFETARGET_okLOGICAL1
5178 	case FFEINFO_kindtypeLOGICAL1:
5179 	  error = ffetarget_and_logical1 (ffebld_cu_ptr_logical1 (u),
5180 			       ffebld_constant_logical1 (ffebld_conter (l)),
5181 			      ffebld_constant_logical1 (ffebld_conter (r)));
5182 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5183 					(ffebld_cu_val_logical1 (u)), expr);
5184 	  break;
5185 #endif
5186 
5187 #if FFETARGET_okLOGICAL2
5188 	case FFEINFO_kindtypeLOGICAL2:
5189 	  error = ffetarget_and_logical2 (ffebld_cu_ptr_logical2 (u),
5190 			       ffebld_constant_logical2 (ffebld_conter (l)),
5191 			      ffebld_constant_logical2 (ffebld_conter (r)));
5192 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5193 					(ffebld_cu_val_logical2 (u)), expr);
5194 	  break;
5195 #endif
5196 
5197 #if FFETARGET_okLOGICAL3
5198 	case FFEINFO_kindtypeLOGICAL3:
5199 	  error = ffetarget_and_logical3 (ffebld_cu_ptr_logical3 (u),
5200 			       ffebld_constant_logical3 (ffebld_conter (l)),
5201 			      ffebld_constant_logical3 (ffebld_conter (r)));
5202 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5203 					(ffebld_cu_val_logical3 (u)), expr);
5204 	  break;
5205 #endif
5206 
5207 #if FFETARGET_okLOGICAL4
5208 	case FFEINFO_kindtypeLOGICAL4:
5209 	  error = ffetarget_and_logical4 (ffebld_cu_ptr_logical4 (u),
5210 			       ffebld_constant_logical4 (ffebld_conter (l)),
5211 			      ffebld_constant_logical4 (ffebld_conter (r)));
5212 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5213 					(ffebld_cu_val_logical4 (u)), expr);
5214 	  break;
5215 #endif
5216 
5217 	default:
5218 	  assert ("bad logical kind type" == NULL);
5219 	  break;
5220 	}
5221       break;
5222 
5223     default:
5224       assert ("bad type" == NULL);
5225       return expr;
5226     }
5227 
5228   ffebld_set_info (expr, ffeinfo_new
5229 		   (bt,
5230 		    kt,
5231 		    0,
5232 		    FFEINFO_kindENTITY,
5233 		    FFEINFO_whereCONSTANT,
5234 		    FFETARGET_charactersizeNONE));
5235 
5236   if ((error != FFEBAD)
5237       && ffebad_start (error))
5238     {
5239       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5240       ffebad_finish ();
5241     }
5242 
5243   return expr;
5244 }
5245 
5246 /* ffeexpr_collapse_or -- Collapse or expr
5247 
5248    ffebld expr;
5249    ffelexToken token;
5250    expr = ffeexpr_collapse_or(expr,token);
5251 
5252    If the result of the expr is a constant, replaces the expr with the
5253    computed constant.  */
5254 
5255 ffebld
ffeexpr_collapse_or(ffebld expr,ffelexToken t)5256 ffeexpr_collapse_or (ffebld expr, ffelexToken t)
5257 {
5258   ffebad error = FFEBAD;
5259   ffebld l;
5260   ffebld r;
5261   ffebldConstantUnion u;
5262   ffeinfoBasictype bt;
5263   ffeinfoKindtype kt;
5264 
5265   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5266     return expr;
5267 
5268   l = ffebld_left (expr);
5269   r = ffebld_right (expr);
5270 
5271   if (ffebld_op (l) != FFEBLD_opCONTER)
5272     return expr;
5273   if (ffebld_op (r) != FFEBLD_opCONTER)
5274     return expr;
5275 
5276   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5277     {
5278     case FFEINFO_basictypeANY:
5279       return expr;
5280 
5281     case FFEINFO_basictypeINTEGER:
5282       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5283 	{
5284 #if FFETARGET_okINTEGER1
5285 	case FFEINFO_kindtypeINTEGER1:
5286 	  error = ffetarget_or_integer1 (ffebld_cu_ptr_integer1 (u),
5287 			       ffebld_constant_integer1 (ffebld_conter (l)),
5288 			      ffebld_constant_integer1 (ffebld_conter (r)));
5289 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5290 					(ffebld_cu_val_integer1 (u)), expr);
5291 	  break;
5292 #endif
5293 
5294 #if FFETARGET_okINTEGER2
5295 	case FFEINFO_kindtypeINTEGER2:
5296 	  error = ffetarget_or_integer2 (ffebld_cu_ptr_integer2 (u),
5297 			       ffebld_constant_integer2 (ffebld_conter (l)),
5298 			      ffebld_constant_integer2 (ffebld_conter (r)));
5299 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5300 					(ffebld_cu_val_integer2 (u)), expr);
5301 	  break;
5302 #endif
5303 
5304 #if FFETARGET_okINTEGER3
5305 	case FFEINFO_kindtypeINTEGER3:
5306 	  error = ffetarget_or_integer3 (ffebld_cu_ptr_integer3 (u),
5307 			       ffebld_constant_integer3 (ffebld_conter (l)),
5308 			      ffebld_constant_integer3 (ffebld_conter (r)));
5309 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5310 					(ffebld_cu_val_integer3 (u)), expr);
5311 	  break;
5312 #endif
5313 
5314 #if FFETARGET_okINTEGER4
5315 	case FFEINFO_kindtypeINTEGER4:
5316 	  error = ffetarget_or_integer4 (ffebld_cu_ptr_integer4 (u),
5317 			       ffebld_constant_integer4 (ffebld_conter (l)),
5318 			      ffebld_constant_integer4 (ffebld_conter (r)));
5319 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5320 					(ffebld_cu_val_integer4 (u)), expr);
5321 	  break;
5322 #endif
5323 
5324 	default:
5325 	  assert ("bad integer kind type" == NULL);
5326 	  break;
5327 	}
5328       break;
5329 
5330     case FFEINFO_basictypeLOGICAL:
5331       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5332 	{
5333 #if FFETARGET_okLOGICAL1
5334 	case FFEINFO_kindtypeLOGICAL1:
5335 	  error = ffetarget_or_logical1 (ffebld_cu_ptr_logical1 (u),
5336 			       ffebld_constant_logical1 (ffebld_conter (l)),
5337 			      ffebld_constant_logical1 (ffebld_conter (r)));
5338 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5339 					(ffebld_cu_val_logical1 (u)), expr);
5340 	  break;
5341 #endif
5342 
5343 #if FFETARGET_okLOGICAL2
5344 	case FFEINFO_kindtypeLOGICAL2:
5345 	  error = ffetarget_or_logical2 (ffebld_cu_ptr_logical2 (u),
5346 			       ffebld_constant_logical2 (ffebld_conter (l)),
5347 			      ffebld_constant_logical2 (ffebld_conter (r)));
5348 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5349 					(ffebld_cu_val_logical2 (u)), expr);
5350 	  break;
5351 #endif
5352 
5353 #if FFETARGET_okLOGICAL3
5354 	case FFEINFO_kindtypeLOGICAL3:
5355 	  error = ffetarget_or_logical3 (ffebld_cu_ptr_logical3 (u),
5356 			       ffebld_constant_logical3 (ffebld_conter (l)),
5357 			      ffebld_constant_logical3 (ffebld_conter (r)));
5358 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5359 					(ffebld_cu_val_logical3 (u)), expr);
5360 	  break;
5361 #endif
5362 
5363 #if FFETARGET_okLOGICAL4
5364 	case FFEINFO_kindtypeLOGICAL4:
5365 	  error = ffetarget_or_logical4 (ffebld_cu_ptr_logical4 (u),
5366 			       ffebld_constant_logical4 (ffebld_conter (l)),
5367 			      ffebld_constant_logical4 (ffebld_conter (r)));
5368 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5369 					(ffebld_cu_val_logical4 (u)), expr);
5370 	  break;
5371 #endif
5372 
5373 	default:
5374 	  assert ("bad logical kind type" == NULL);
5375 	  break;
5376 	}
5377       break;
5378 
5379     default:
5380       assert ("bad type" == NULL);
5381       return expr;
5382     }
5383 
5384   ffebld_set_info (expr, ffeinfo_new
5385 		   (bt,
5386 		    kt,
5387 		    0,
5388 		    FFEINFO_kindENTITY,
5389 		    FFEINFO_whereCONSTANT,
5390 		    FFETARGET_charactersizeNONE));
5391 
5392   if ((error != FFEBAD)
5393       && ffebad_start (error))
5394     {
5395       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5396       ffebad_finish ();
5397     }
5398 
5399   return expr;
5400 }
5401 
5402 /* ffeexpr_collapse_xor -- Collapse xor expr
5403 
5404    ffebld expr;
5405    ffelexToken token;
5406    expr = ffeexpr_collapse_xor(expr,token);
5407 
5408    If the result of the expr is a constant, replaces the expr with the
5409    computed constant.  */
5410 
5411 ffebld
ffeexpr_collapse_xor(ffebld expr,ffelexToken t)5412 ffeexpr_collapse_xor (ffebld expr, ffelexToken t)
5413 {
5414   ffebad error = FFEBAD;
5415   ffebld l;
5416   ffebld r;
5417   ffebldConstantUnion u;
5418   ffeinfoBasictype bt;
5419   ffeinfoKindtype kt;
5420 
5421   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5422     return expr;
5423 
5424   l = ffebld_left (expr);
5425   r = ffebld_right (expr);
5426 
5427   if (ffebld_op (l) != FFEBLD_opCONTER)
5428     return expr;
5429   if (ffebld_op (r) != FFEBLD_opCONTER)
5430     return expr;
5431 
5432   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5433     {
5434     case FFEINFO_basictypeANY:
5435       return expr;
5436 
5437     case FFEINFO_basictypeINTEGER:
5438       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5439 	{
5440 #if FFETARGET_okINTEGER1
5441 	case FFEINFO_kindtypeINTEGER1:
5442 	  error = ffetarget_xor_integer1 (ffebld_cu_ptr_integer1 (u),
5443 			       ffebld_constant_integer1 (ffebld_conter (l)),
5444 			      ffebld_constant_integer1 (ffebld_conter (r)));
5445 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5446 					(ffebld_cu_val_integer1 (u)), expr);
5447 	  break;
5448 #endif
5449 
5450 #if FFETARGET_okINTEGER2
5451 	case FFEINFO_kindtypeINTEGER2:
5452 	  error = ffetarget_xor_integer2 (ffebld_cu_ptr_integer2 (u),
5453 			       ffebld_constant_integer2 (ffebld_conter (l)),
5454 			      ffebld_constant_integer2 (ffebld_conter (r)));
5455 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5456 					(ffebld_cu_val_integer2 (u)), expr);
5457 	  break;
5458 #endif
5459 
5460 #if FFETARGET_okINTEGER3
5461 	case FFEINFO_kindtypeINTEGER3:
5462 	  error = ffetarget_xor_integer3 (ffebld_cu_ptr_integer3 (u),
5463 			       ffebld_constant_integer3 (ffebld_conter (l)),
5464 			      ffebld_constant_integer3 (ffebld_conter (r)));
5465 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5466 					(ffebld_cu_val_integer3 (u)), expr);
5467 	  break;
5468 #endif
5469 
5470 #if FFETARGET_okINTEGER4
5471 	case FFEINFO_kindtypeINTEGER4:
5472 	  error = ffetarget_xor_integer4 (ffebld_cu_ptr_integer4 (u),
5473 			       ffebld_constant_integer4 (ffebld_conter (l)),
5474 			      ffebld_constant_integer4 (ffebld_conter (r)));
5475 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5476 					(ffebld_cu_val_integer4 (u)), expr);
5477 	  break;
5478 #endif
5479 
5480 	default:
5481 	  assert ("bad integer kind type" == NULL);
5482 	  break;
5483 	}
5484       break;
5485 
5486     case FFEINFO_basictypeLOGICAL:
5487       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5488 	{
5489 #if FFETARGET_okLOGICAL1
5490 	case FFEINFO_kindtypeLOGICAL1:
5491 	  error = ffetarget_xor_logical1 (ffebld_cu_ptr_logical1 (u),
5492 			       ffebld_constant_logical1 (ffebld_conter (l)),
5493 			      ffebld_constant_logical1 (ffebld_conter (r)));
5494 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5495 					(ffebld_cu_val_logical1 (u)), expr);
5496 	  break;
5497 #endif
5498 
5499 #if FFETARGET_okLOGICAL2
5500 	case FFEINFO_kindtypeLOGICAL2:
5501 	  error = ffetarget_xor_logical2 (ffebld_cu_ptr_logical2 (u),
5502 			       ffebld_constant_logical2 (ffebld_conter (l)),
5503 			      ffebld_constant_logical2 (ffebld_conter (r)));
5504 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5505 					(ffebld_cu_val_logical2 (u)), expr);
5506 	  break;
5507 #endif
5508 
5509 #if FFETARGET_okLOGICAL3
5510 	case FFEINFO_kindtypeLOGICAL3:
5511 	  error = ffetarget_xor_logical3 (ffebld_cu_ptr_logical3 (u),
5512 			       ffebld_constant_logical3 (ffebld_conter (l)),
5513 			      ffebld_constant_logical3 (ffebld_conter (r)));
5514 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5515 					(ffebld_cu_val_logical3 (u)), expr);
5516 	  break;
5517 #endif
5518 
5519 #if FFETARGET_okLOGICAL4
5520 	case FFEINFO_kindtypeLOGICAL4:
5521 	  error = ffetarget_xor_logical4 (ffebld_cu_ptr_logical4 (u),
5522 			       ffebld_constant_logical4 (ffebld_conter (l)),
5523 			      ffebld_constant_logical4 (ffebld_conter (r)));
5524 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5525 					(ffebld_cu_val_logical4 (u)), expr);
5526 	  break;
5527 #endif
5528 
5529 	default:
5530 	  assert ("bad logical kind type" == NULL);
5531 	  break;
5532 	}
5533       break;
5534 
5535     default:
5536       assert ("bad type" == NULL);
5537       return expr;
5538     }
5539 
5540   ffebld_set_info (expr, ffeinfo_new
5541 		   (bt,
5542 		    kt,
5543 		    0,
5544 		    FFEINFO_kindENTITY,
5545 		    FFEINFO_whereCONSTANT,
5546 		    FFETARGET_charactersizeNONE));
5547 
5548   if ((error != FFEBAD)
5549       && ffebad_start (error))
5550     {
5551       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5552       ffebad_finish ();
5553     }
5554 
5555   return expr;
5556 }
5557 
5558 /* ffeexpr_collapse_eqv -- Collapse eqv expr
5559 
5560    ffebld expr;
5561    ffelexToken token;
5562    expr = ffeexpr_collapse_eqv(expr,token);
5563 
5564    If the result of the expr is a constant, replaces the expr with the
5565    computed constant.  */
5566 
5567 ffebld
ffeexpr_collapse_eqv(ffebld expr,ffelexToken t)5568 ffeexpr_collapse_eqv (ffebld expr, ffelexToken t)
5569 {
5570   ffebad error = FFEBAD;
5571   ffebld l;
5572   ffebld r;
5573   ffebldConstantUnion u;
5574   ffeinfoBasictype bt;
5575   ffeinfoKindtype kt;
5576 
5577   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5578     return expr;
5579 
5580   l = ffebld_left (expr);
5581   r = ffebld_right (expr);
5582 
5583   if (ffebld_op (l) != FFEBLD_opCONTER)
5584     return expr;
5585   if (ffebld_op (r) != FFEBLD_opCONTER)
5586     return expr;
5587 
5588   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5589     {
5590     case FFEINFO_basictypeANY:
5591       return expr;
5592 
5593     case FFEINFO_basictypeINTEGER:
5594       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5595 	{
5596 #if FFETARGET_okINTEGER1
5597 	case FFEINFO_kindtypeINTEGER1:
5598 	  error = ffetarget_eqv_integer1 (ffebld_cu_ptr_integer1 (u),
5599 			       ffebld_constant_integer1 (ffebld_conter (l)),
5600 			      ffebld_constant_integer1 (ffebld_conter (r)));
5601 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5602 					(ffebld_cu_val_integer1 (u)), expr);
5603 	  break;
5604 #endif
5605 
5606 #if FFETARGET_okINTEGER2
5607 	case FFEINFO_kindtypeINTEGER2:
5608 	  error = ffetarget_eqv_integer2 (ffebld_cu_ptr_integer2 (u),
5609 			       ffebld_constant_integer2 (ffebld_conter (l)),
5610 			      ffebld_constant_integer2 (ffebld_conter (r)));
5611 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5612 					(ffebld_cu_val_integer2 (u)), expr);
5613 	  break;
5614 #endif
5615 
5616 #if FFETARGET_okINTEGER3
5617 	case FFEINFO_kindtypeINTEGER3:
5618 	  error = ffetarget_eqv_integer3 (ffebld_cu_ptr_integer3 (u),
5619 			       ffebld_constant_integer3 (ffebld_conter (l)),
5620 			      ffebld_constant_integer3 (ffebld_conter (r)));
5621 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5622 					(ffebld_cu_val_integer3 (u)), expr);
5623 	  break;
5624 #endif
5625 
5626 #if FFETARGET_okINTEGER4
5627 	case FFEINFO_kindtypeINTEGER4:
5628 	  error = ffetarget_eqv_integer4 (ffebld_cu_ptr_integer4 (u),
5629 			       ffebld_constant_integer4 (ffebld_conter (l)),
5630 			      ffebld_constant_integer4 (ffebld_conter (r)));
5631 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5632 					(ffebld_cu_val_integer4 (u)), expr);
5633 	  break;
5634 #endif
5635 
5636 	default:
5637 	  assert ("bad integer kind type" == NULL);
5638 	  break;
5639 	}
5640       break;
5641 
5642     case FFEINFO_basictypeLOGICAL:
5643       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5644 	{
5645 #if FFETARGET_okLOGICAL1
5646 	case FFEINFO_kindtypeLOGICAL1:
5647 	  error = ffetarget_eqv_logical1 (ffebld_cu_ptr_logical1 (u),
5648 			       ffebld_constant_logical1 (ffebld_conter (l)),
5649 			      ffebld_constant_logical1 (ffebld_conter (r)));
5650 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5651 					(ffebld_cu_val_logical1 (u)), expr);
5652 	  break;
5653 #endif
5654 
5655 #if FFETARGET_okLOGICAL2
5656 	case FFEINFO_kindtypeLOGICAL2:
5657 	  error = ffetarget_eqv_logical2 (ffebld_cu_ptr_logical2 (u),
5658 			       ffebld_constant_logical2 (ffebld_conter (l)),
5659 			      ffebld_constant_logical2 (ffebld_conter (r)));
5660 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5661 					(ffebld_cu_val_logical2 (u)), expr);
5662 	  break;
5663 #endif
5664 
5665 #if FFETARGET_okLOGICAL3
5666 	case FFEINFO_kindtypeLOGICAL3:
5667 	  error = ffetarget_eqv_logical3 (ffebld_cu_ptr_logical3 (u),
5668 			       ffebld_constant_logical3 (ffebld_conter (l)),
5669 			      ffebld_constant_logical3 (ffebld_conter (r)));
5670 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5671 					(ffebld_cu_val_logical3 (u)), expr);
5672 	  break;
5673 #endif
5674 
5675 #if FFETARGET_okLOGICAL4
5676 	case FFEINFO_kindtypeLOGICAL4:
5677 	  error = ffetarget_eqv_logical4 (ffebld_cu_ptr_logical4 (u),
5678 			       ffebld_constant_logical4 (ffebld_conter (l)),
5679 			      ffebld_constant_logical4 (ffebld_conter (r)));
5680 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5681 					(ffebld_cu_val_logical4 (u)), expr);
5682 	  break;
5683 #endif
5684 
5685 	default:
5686 	  assert ("bad logical kind type" == NULL);
5687 	  break;
5688 	}
5689       break;
5690 
5691     default:
5692       assert ("bad type" == NULL);
5693       return expr;
5694     }
5695 
5696   ffebld_set_info (expr, ffeinfo_new
5697 		   (bt,
5698 		    kt,
5699 		    0,
5700 		    FFEINFO_kindENTITY,
5701 		    FFEINFO_whereCONSTANT,
5702 		    FFETARGET_charactersizeNONE));
5703 
5704   if ((error != FFEBAD)
5705       && ffebad_start (error))
5706     {
5707       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5708       ffebad_finish ();
5709     }
5710 
5711   return expr;
5712 }
5713 
5714 /* ffeexpr_collapse_neqv -- Collapse neqv expr
5715 
5716    ffebld expr;
5717    ffelexToken token;
5718    expr = ffeexpr_collapse_neqv(expr,token);
5719 
5720    If the result of the expr is a constant, replaces the expr with the
5721    computed constant.  */
5722 
5723 ffebld
ffeexpr_collapse_neqv(ffebld expr,ffelexToken t)5724 ffeexpr_collapse_neqv (ffebld expr, ffelexToken t)
5725 {
5726   ffebad error = FFEBAD;
5727   ffebld l;
5728   ffebld r;
5729   ffebldConstantUnion u;
5730   ffeinfoBasictype bt;
5731   ffeinfoKindtype kt;
5732 
5733   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5734     return expr;
5735 
5736   l = ffebld_left (expr);
5737   r = ffebld_right (expr);
5738 
5739   if (ffebld_op (l) != FFEBLD_opCONTER)
5740     return expr;
5741   if (ffebld_op (r) != FFEBLD_opCONTER)
5742     return expr;
5743 
5744   switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5745     {
5746     case FFEINFO_basictypeANY:
5747       return expr;
5748 
5749     case FFEINFO_basictypeINTEGER:
5750       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5751 	{
5752 #if FFETARGET_okINTEGER1
5753 	case FFEINFO_kindtypeINTEGER1:
5754 	  error = ffetarget_neqv_integer1 (ffebld_cu_ptr_integer1 (u),
5755 			       ffebld_constant_integer1 (ffebld_conter (l)),
5756 			      ffebld_constant_integer1 (ffebld_conter (r)));
5757 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5758 					(ffebld_cu_val_integer1 (u)), expr);
5759 	  break;
5760 #endif
5761 
5762 #if FFETARGET_okINTEGER2
5763 	case FFEINFO_kindtypeINTEGER2:
5764 	  error = ffetarget_neqv_integer2 (ffebld_cu_ptr_integer2 (u),
5765 			       ffebld_constant_integer2 (ffebld_conter (l)),
5766 			      ffebld_constant_integer2 (ffebld_conter (r)));
5767 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5768 					(ffebld_cu_val_integer2 (u)), expr);
5769 	  break;
5770 #endif
5771 
5772 #if FFETARGET_okINTEGER3
5773 	case FFEINFO_kindtypeINTEGER3:
5774 	  error = ffetarget_neqv_integer3 (ffebld_cu_ptr_integer3 (u),
5775 			       ffebld_constant_integer3 (ffebld_conter (l)),
5776 			      ffebld_constant_integer3 (ffebld_conter (r)));
5777 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5778 					(ffebld_cu_val_integer3 (u)), expr);
5779 	  break;
5780 #endif
5781 
5782 #if FFETARGET_okINTEGER4
5783 	case FFEINFO_kindtypeINTEGER4:
5784 	  error = ffetarget_neqv_integer4 (ffebld_cu_ptr_integer4 (u),
5785 			       ffebld_constant_integer4 (ffebld_conter (l)),
5786 			      ffebld_constant_integer4 (ffebld_conter (r)));
5787 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5788 					(ffebld_cu_val_integer4 (u)), expr);
5789 	  break;
5790 #endif
5791 
5792 	default:
5793 	  assert ("bad integer kind type" == NULL);
5794 	  break;
5795 	}
5796       break;
5797 
5798     case FFEINFO_basictypeLOGICAL:
5799       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5800 	{
5801 #if FFETARGET_okLOGICAL1
5802 	case FFEINFO_kindtypeLOGICAL1:
5803 	  error = ffetarget_neqv_logical1 (ffebld_cu_ptr_logical1 (u),
5804 			       ffebld_constant_logical1 (ffebld_conter (l)),
5805 			      ffebld_constant_logical1 (ffebld_conter (r)));
5806 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5807 					(ffebld_cu_val_logical1 (u)), expr);
5808 	  break;
5809 #endif
5810 
5811 #if FFETARGET_okLOGICAL2
5812 	case FFEINFO_kindtypeLOGICAL2:
5813 	  error = ffetarget_neqv_logical2 (ffebld_cu_ptr_logical2 (u),
5814 			       ffebld_constant_logical2 (ffebld_conter (l)),
5815 			      ffebld_constant_logical2 (ffebld_conter (r)));
5816 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5817 					(ffebld_cu_val_logical2 (u)), expr);
5818 	  break;
5819 #endif
5820 
5821 #if FFETARGET_okLOGICAL3
5822 	case FFEINFO_kindtypeLOGICAL3:
5823 	  error = ffetarget_neqv_logical3 (ffebld_cu_ptr_logical3 (u),
5824 			       ffebld_constant_logical3 (ffebld_conter (l)),
5825 			      ffebld_constant_logical3 (ffebld_conter (r)));
5826 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5827 					(ffebld_cu_val_logical3 (u)), expr);
5828 	  break;
5829 #endif
5830 
5831 #if FFETARGET_okLOGICAL4
5832 	case FFEINFO_kindtypeLOGICAL4:
5833 	  error = ffetarget_neqv_logical4 (ffebld_cu_ptr_logical4 (u),
5834 			       ffebld_constant_logical4 (ffebld_conter (l)),
5835 			      ffebld_constant_logical4 (ffebld_conter (r)));
5836 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5837 					(ffebld_cu_val_logical4 (u)), expr);
5838 	  break;
5839 #endif
5840 
5841 	default:
5842 	  assert ("bad logical kind type" == NULL);
5843 	  break;
5844 	}
5845       break;
5846 
5847     default:
5848       assert ("bad type" == NULL);
5849       return expr;
5850     }
5851 
5852   ffebld_set_info (expr, ffeinfo_new
5853 		   (bt,
5854 		    kt,
5855 		    0,
5856 		    FFEINFO_kindENTITY,
5857 		    FFEINFO_whereCONSTANT,
5858 		    FFETARGET_charactersizeNONE));
5859 
5860   if ((error != FFEBAD)
5861       && ffebad_start (error))
5862     {
5863       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5864       ffebad_finish ();
5865     }
5866 
5867   return expr;
5868 }
5869 
5870 /* ffeexpr_collapse_symter -- Collapse symter expr
5871 
5872    ffebld expr;
5873    ffelexToken token;
5874    expr = ffeexpr_collapse_symter(expr,token);
5875 
5876    If the result of the expr is a constant, replaces the expr with the
5877    computed constant.  */
5878 
5879 ffebld
ffeexpr_collapse_symter(ffebld expr,ffelexToken t UNUSED)5880 ffeexpr_collapse_symter (ffebld expr, ffelexToken t UNUSED)
5881 {
5882   ffebld r;
5883   ffeinfoBasictype bt;
5884   ffeinfoKindtype kt;
5885   ffetargetCharacterSize len;
5886 
5887   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5888     return expr;
5889 
5890   if ((r = ffesymbol_init (ffebld_symter (expr))) == NULL)
5891     return expr;		/* A PARAMETER lhs in progress. */
5892 
5893   switch (ffebld_op (r))
5894     {
5895     case FFEBLD_opCONTER:
5896       break;
5897 
5898     case FFEBLD_opANY:
5899       return r;
5900 
5901     default:
5902       return expr;
5903     }
5904 
5905   bt = ffeinfo_basictype (ffebld_info (r));
5906   kt = ffeinfo_kindtype (ffebld_info (r));
5907   len = ffebld_size (r);
5908 
5909   expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
5910 				      expr);
5911 
5912   ffebld_set_info (expr, ffeinfo_new
5913 		   (bt,
5914 		    kt,
5915 		    0,
5916 		    FFEINFO_kindENTITY,
5917 		    FFEINFO_whereCONSTANT,
5918 		    len));
5919 
5920   return expr;
5921 }
5922 
5923 /* ffeexpr_collapse_funcref -- Collapse funcref expr
5924 
5925    ffebld expr;
5926    ffelexToken token;
5927    expr = ffeexpr_collapse_funcref(expr,token);
5928 
5929    If the result of the expr is a constant, replaces the expr with the
5930    computed constant.  */
5931 
5932 ffebld
ffeexpr_collapse_funcref(ffebld expr,ffelexToken t UNUSED)5933 ffeexpr_collapse_funcref (ffebld expr, ffelexToken t UNUSED)
5934 {
5935   return expr;			/* ~~someday go ahead and collapse these,
5936 				   though not required */
5937 }
5938 
5939 /* ffeexpr_collapse_arrayref -- Collapse arrayref expr
5940 
5941    ffebld expr;
5942    ffelexToken token;
5943    expr = ffeexpr_collapse_arrayref(expr,token);
5944 
5945    If the result of the expr is a constant, replaces the expr with the
5946    computed constant.  */
5947 
5948 ffebld
ffeexpr_collapse_arrayref(ffebld expr,ffelexToken t UNUSED)5949 ffeexpr_collapse_arrayref (ffebld expr, ffelexToken t UNUSED)
5950 {
5951   return expr;
5952 }
5953 
5954 /* ffeexpr_collapse_substr -- Collapse substr expr
5955 
5956    ffebld expr;
5957    ffelexToken token;
5958    expr = ffeexpr_collapse_substr(expr,token);
5959 
5960    If the result of the expr is a constant, replaces the expr with the
5961    computed constant.  */
5962 
5963 ffebld
ffeexpr_collapse_substr(ffebld expr,ffelexToken t)5964 ffeexpr_collapse_substr (ffebld expr, ffelexToken t)
5965 {
5966   ffebad error = FFEBAD;
5967   ffebld l;
5968   ffebld r;
5969   ffebld start;
5970   ffebld stop;
5971   ffebldConstantUnion u;
5972   ffeinfoKindtype kt;
5973   ffetargetCharacterSize len;
5974   ffetargetIntegerDefault first;
5975   ffetargetIntegerDefault last;
5976 
5977   if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5978     return expr;
5979 
5980   l = ffebld_left (expr);
5981   r = ffebld_right (expr);	/* opITEM. */
5982 
5983   if (ffebld_op (l) != FFEBLD_opCONTER)
5984     return expr;
5985 
5986   kt = ffeinfo_kindtype (ffebld_info (l));
5987   len = ffebld_size (l);
5988 
5989   start = ffebld_head (r);
5990   stop = ffebld_head (ffebld_trail (r));
5991   if (start == NULL)
5992     first = 1;
5993   else
5994     {
5995       if ((ffebld_op (start) != FFEBLD_opCONTER)
5996 	  || (ffeinfo_basictype (ffebld_info (start)) != FFEINFO_basictypeINTEGER)
5997 	  || (ffeinfo_kindtype (ffebld_info (start))
5998 	      != FFEINFO_kindtypeINTEGERDEFAULT))
5999 	return expr;
6000       first = ffebld_constant_integerdefault (ffebld_conter (start));
6001     }
6002   if (stop == NULL)
6003     last = len;
6004   else
6005     {
6006       if ((ffebld_op (stop) != FFEBLD_opCONTER)
6007       || (ffeinfo_basictype (ffebld_info (stop)) != FFEINFO_basictypeINTEGER)
6008 	  || (ffeinfo_kindtype (ffebld_info (stop))
6009 	      != FFEINFO_kindtypeINTEGERDEFAULT))
6010 	return expr;
6011       last = ffebld_constant_integerdefault (ffebld_conter (stop));
6012     }
6013 
6014   /* Handle problems that should have already been diagnosed, but
6015      left in the expression tree.  */
6016 
6017   if (first <= 0)
6018     first = 1;
6019   if (last < first)
6020     last = first + len - 1;
6021 
6022   if ((first == 1) && (last == len))
6023     {				/* Same as original. */
6024       expr = ffebld_new_conter_with_orig (ffebld_constant_copy
6025 					  (ffebld_conter (l)), expr);
6026       ffebld_set_info (expr, ffeinfo_new
6027 		       (FFEINFO_basictypeCHARACTER,
6028 			kt,
6029 			0,
6030 			FFEINFO_kindENTITY,
6031 			FFEINFO_whereCONSTANT,
6032 			len));
6033 
6034       return expr;
6035     }
6036 
6037   switch (ffeinfo_basictype (ffebld_info (expr)))
6038     {
6039     case FFEINFO_basictypeANY:
6040       return expr;
6041 
6042     case FFEINFO_basictypeCHARACTER:
6043       switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6044 	{
6045 #if FFETARGET_okCHARACTER1
6046 	case FFEINFO_kindtypeCHARACTER1:
6047 	  error = ffetarget_substr_character1 (ffebld_cu_ptr_character1 (u),
6048 		ffebld_constant_character1 (ffebld_conter (l)), first, last,
6049 				   ffebld_constant_pool (), &len);
6050 	  expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
6051 				      (ffebld_cu_val_character1 (u)), expr);
6052 	  break;
6053 #endif
6054 
6055 	default:
6056 	  assert ("bad character kind type" == NULL);
6057 	  break;
6058 	}
6059       break;
6060 
6061     default:
6062       assert ("bad type" == NULL);
6063       return expr;
6064     }
6065 
6066   ffebld_set_info (expr, ffeinfo_new
6067 		   (FFEINFO_basictypeCHARACTER,
6068 		    kt,
6069 		    0,
6070 		    FFEINFO_kindENTITY,
6071 		    FFEINFO_whereCONSTANT,
6072 		    len));
6073 
6074   if ((error != FFEBAD)
6075       && ffebad_start (error))
6076     {
6077       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6078       ffebad_finish ();
6079     }
6080 
6081   return expr;
6082 }
6083 
6084 /* ffeexpr_convert -- Convert source expression to given type
6085 
6086    ffebld source;
6087    ffelexToken source_token;
6088    ffelexToken dest_token;  // Any appropriate token for "destination".
6089    ffeinfoBasictype bt;
6090    ffeinfoKindtype kt;
6091    ffetargetCharactersize sz;
6092    ffeexprContext context;  // Mainly LET or DATA.
6093    source = ffeexpr_convert(source,source_token,dest_token,bt,kt,sz,context);
6094 
6095    If the expression conforms, returns the source expression.  Otherwise
6096    returns source wrapped in a convert node doing the conversion, or
6097    ANY wrapped in convert if there is a conversion error (and issues an
6098    error message).  Be sensitive to the context for certain aspects of
6099    the conversion.  */
6100 
6101 ffebld
ffeexpr_convert(ffebld source,ffelexToken source_token,ffelexToken dest_token,ffeinfoBasictype bt,ffeinfoKindtype kt,ffeinfoRank rk,ffetargetCharacterSize sz,ffeexprContext context)6102 ffeexpr_convert (ffebld source, ffelexToken source_token, ffelexToken dest_token,
6103 		 ffeinfoBasictype bt, ffeinfoKindtype kt, ffeinfoRank rk,
6104 		 ffetargetCharacterSize sz, ffeexprContext context)
6105 {
6106   bool bad;
6107   ffeinfo info;
6108   ffeinfoWhere wh;
6109 
6110   info = ffebld_info (source);
6111   if ((bt != ffeinfo_basictype (info))
6112       || (kt != ffeinfo_kindtype (info))
6113       || (rk != 0)		/* Can't convert from or to arrays yet. */
6114       || (ffeinfo_rank (info) != 0)
6115       || (sz != ffebld_size_known (source)))
6116 #if 0	/* Nobody seems to need this spurious CONVERT node. */
6117       || ((context != FFEEXPR_contextLET)
6118 	  && (bt == FFEINFO_basictypeCHARACTER)
6119 	  && (sz == FFETARGET_charactersizeNONE)))
6120 #endif
6121     {
6122       switch (ffeinfo_basictype (info))
6123 	{
6124 	case FFEINFO_basictypeLOGICAL:
6125 	  switch (bt)
6126 	    {
6127 	    case FFEINFO_basictypeLOGICAL:
6128 	      bad = FALSE;
6129 	      break;
6130 
6131 	    case FFEINFO_basictypeINTEGER:
6132 	      bad = !ffe_is_ugly_logint ();
6133 	      break;
6134 
6135 	    case FFEINFO_basictypeCHARACTER:
6136 	      bad = ffe_is_pedantic ()
6137 		|| !(ffe_is_ugly_init ()
6138 		     && (context == FFEEXPR_contextDATA));
6139 	      break;
6140 
6141 	    default:
6142 	      bad = TRUE;
6143 	      break;
6144 	    }
6145 	  break;
6146 
6147 	case FFEINFO_basictypeINTEGER:
6148 	  switch (bt)
6149 	    {
6150 	    case FFEINFO_basictypeINTEGER:
6151 	    case FFEINFO_basictypeREAL:
6152 	    case FFEINFO_basictypeCOMPLEX:
6153 	      bad = FALSE;
6154 	      break;
6155 
6156 	    case FFEINFO_basictypeLOGICAL:
6157 	      bad = !ffe_is_ugly_logint ();
6158 	      break;
6159 
6160 	    case FFEINFO_basictypeCHARACTER:
6161 	      bad = ffe_is_pedantic ()
6162 		|| !(ffe_is_ugly_init ()
6163 		     && (context == FFEEXPR_contextDATA));
6164 	      break;
6165 
6166 	    default:
6167 	      bad = TRUE;
6168 	      break;
6169 	    }
6170 	  break;
6171 
6172 	case FFEINFO_basictypeREAL:
6173 	case FFEINFO_basictypeCOMPLEX:
6174 	  switch (bt)
6175 	    {
6176 	    case FFEINFO_basictypeINTEGER:
6177 	    case FFEINFO_basictypeREAL:
6178 	    case FFEINFO_basictypeCOMPLEX:
6179 	      bad = FALSE;
6180 	      break;
6181 
6182 	    case FFEINFO_basictypeCHARACTER:
6183 	      bad = TRUE;
6184 	      break;
6185 
6186 	    default:
6187 	      bad = TRUE;
6188 	      break;
6189 	    }
6190 	  break;
6191 
6192 	case FFEINFO_basictypeCHARACTER:
6193 	  bad = (bt != FFEINFO_basictypeCHARACTER)
6194 	    && (ffe_is_pedantic ()
6195 		|| (bt != FFEINFO_basictypeINTEGER)
6196 		|| !(ffe_is_ugly_init ()
6197 		     && (context == FFEEXPR_contextDATA)));
6198 	  break;
6199 
6200 	case FFEINFO_basictypeTYPELESS:
6201 	case FFEINFO_basictypeHOLLERITH:
6202 	  bad = ffe_is_pedantic ()
6203 	    || !(ffe_is_ugly_init ()
6204 		 && ((context == FFEEXPR_contextDATA)
6205 		     || (context == FFEEXPR_contextLET)));
6206 	  break;
6207 
6208 	default:
6209 	  bad = TRUE;
6210 	  break;
6211 	}
6212 
6213       if (!bad && ((rk != 0) || (ffeinfo_rank (info) != 0)))
6214 	bad = TRUE;
6215 
6216       if (bad && (bt != FFEINFO_basictypeANY) && (kt != FFEINFO_kindtypeANY)
6217 	  && (ffeinfo_basictype (info) != FFEINFO_basictypeANY)
6218 	  && (ffeinfo_kindtype (info) != FFEINFO_kindtypeANY)
6219 	  && (ffeinfo_where (info) != FFEINFO_whereANY))
6220 	{
6221 	  if (ffebad_start (FFEBAD_BAD_TYPES))
6222 	    {
6223 	      if (dest_token == NULL)
6224 		ffebad_here (0, ffewhere_line_unknown (),
6225 			     ffewhere_column_unknown ());
6226 	      else
6227 		ffebad_here (0, ffelex_token_where_line (dest_token),
6228 			     ffelex_token_where_column (dest_token));
6229 	      assert (source_token != NULL);
6230 	      ffebad_here (1, ffelex_token_where_line (source_token),
6231 			   ffelex_token_where_column (source_token));
6232 	      ffebad_finish ();
6233 	    }
6234 
6235 	  source = ffebld_new_any ();
6236 	  ffebld_set_info (source, ffeinfo_new_any ());
6237 	}
6238       else
6239 	{
6240 	  switch (ffeinfo_where (info))
6241 	    {
6242 	    case FFEINFO_whereCONSTANT:
6243 	      wh = FFEINFO_whereCONSTANT;
6244 	      break;
6245 
6246 	    case FFEINFO_whereIMMEDIATE:
6247 	      wh = FFEINFO_whereIMMEDIATE;
6248 	      break;
6249 
6250 	    default:
6251 	      wh = FFEINFO_whereFLEETING;
6252 	      break;
6253 	    }
6254 	  source = ffebld_new_convert (source);
6255 	  ffebld_set_info (source, ffeinfo_new
6256 			   (bt,
6257 			    kt,
6258 			    0,
6259 			    FFEINFO_kindENTITY,
6260 			    wh,
6261 			    sz));
6262 	  source = ffeexpr_collapse_convert (source, source_token);
6263 	}
6264     }
6265 
6266   return source;
6267 }
6268 
6269 /* ffeexpr_convert_expr -- Convert source expr to conform to dest expr
6270 
6271    ffebld source;
6272    ffebld dest;
6273    ffelexToken source_token;
6274    ffelexToken dest_token;
6275    ffeexprContext context;
6276    source = ffeexpr_convert_expr(source,source_token,dest,dest_token,context);
6277 
6278    If the expressions conform, returns the source expression.  Otherwise
6279    returns source wrapped in a convert node doing the conversion, or
6280    ANY wrapped in convert if there is a conversion error (and issues an
6281    error message).  Be sensitive to the context, such as LET or DATA.  */
6282 
6283 ffebld
ffeexpr_convert_expr(ffebld source,ffelexToken source_token,ffebld dest,ffelexToken dest_token,ffeexprContext context)6284 ffeexpr_convert_expr (ffebld source, ffelexToken source_token, ffebld dest,
6285 		      ffelexToken dest_token, ffeexprContext context)
6286 {
6287   ffeinfo info;
6288 
6289   info = ffebld_info (dest);
6290   return ffeexpr_convert (source, source_token, dest_token,
6291 			  ffeinfo_basictype (info),
6292 			  ffeinfo_kindtype (info),
6293 			  ffeinfo_rank (info),
6294 			  ffebld_size_known (dest),
6295 			  context);
6296 }
6297 
6298 /* ffeexpr_convert_to_sym -- Convert source expression to conform to symbol
6299 
6300    ffebld source;
6301    ffesymbol dest;
6302    ffelexToken source_token;
6303    ffelexToken dest_token;
6304    source = ffeexpr_convert_to_sym(source,source_token,dest,dest_token);
6305 
6306    If the expressions conform, returns the source expression.  Otherwise
6307    returns source wrapped in a convert node doing the conversion, or
6308    ANY wrapped in convert if there is a conversion error (and issues an
6309    error message).  */
6310 
6311 ffebld
ffeexpr_convert_to_sym(ffebld source,ffelexToken source_token,ffesymbol dest,ffelexToken dest_token)6312 ffeexpr_convert_to_sym (ffebld source, ffelexToken source_token,
6313 			ffesymbol dest, ffelexToken dest_token)
6314 {
6315   return ffeexpr_convert (source, source_token, dest_token, ffesymbol_basictype (dest),
6316     ffesymbol_kindtype (dest), ffesymbol_rank (dest), ffesymbol_size (dest),
6317 			  FFEEXPR_contextLET);
6318 }
6319 
6320 /* Initializes the module.  */
6321 
6322 void
ffeexpr_init_2(void)6323 ffeexpr_init_2 (void)
6324 {
6325   ffeexpr_stack_ = NULL;
6326   ffeexpr_level_ = 0;
6327 }
6328 
6329 /* ffeexpr_lhs -- Begin processing left-hand-side-context expression
6330 
6331    Prepares cluster for delivery of lexer tokens representing an expression
6332    in a left-hand-side context (A in A=B, for example).	 ffebld is used
6333    to build expressions in the given pool.  The appropriate lexer-token
6334    handling routine within ffeexpr is returned.	 When the end of the
6335    expression is detected, mycallbackroutine is called with the resulting
6336    single ffebld object specifying the entire expression and the first
6337    lexer token that is not considered part of the expression.  This caller-
6338    supplied routine itself returns a lexer-token handling routine.  Thus,
6339    if necessary, ffeexpr can return several tokens as end-of-expression
6340    tokens if it needs to scan forward more than one in any instance.  */
6341 
6342 ffelexHandler
ffeexpr_lhs(mallocPool pool,ffeexprContext context,ffeexprCallback callback)6343 ffeexpr_lhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
6344 {
6345   ffeexprStack_ s;
6346 
6347   ffebld_pool_push (pool);
6348   s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
6349   s->previous = ffeexpr_stack_;
6350   s->pool = pool;
6351   s->context = context;
6352   s->callback = callback;
6353   s->first_token = NULL;
6354   s->exprstack = NULL;
6355   s->is_rhs = FALSE;
6356   ffeexpr_stack_ = s;
6357   return (ffelexHandler) ffeexpr_token_first_lhs_;
6358 }
6359 
6360 /* ffeexpr_rhs -- Begin processing right-hand-side-context expression
6361 
6362    return ffeexpr_rhs(malloc_pool_image(),mycallbackroutine);  // to lexer.
6363 
6364    Prepares cluster for delivery of lexer tokens representing an expression
6365    in a right-hand-side context (B in A=B, for example).  ffebld is used
6366    to build expressions in the given pool.  The appropriate lexer-token
6367    handling routine within ffeexpr is returned.	 When the end of the
6368    expression is detected, mycallbackroutine is called with the resulting
6369    single ffebld object specifying the entire expression and the first
6370    lexer token that is not considered part of the expression.  This caller-
6371    supplied routine itself returns a lexer-token handling routine.  Thus,
6372    if necessary, ffeexpr can return several tokens as end-of-expression
6373    tokens if it needs to scan forward more than one in any instance.  */
6374 
6375 ffelexHandler
ffeexpr_rhs(mallocPool pool,ffeexprContext context,ffeexprCallback callback)6376 ffeexpr_rhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
6377 {
6378   ffeexprStack_ s;
6379 
6380   ffebld_pool_push (pool);
6381   s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
6382   s->previous = ffeexpr_stack_;
6383   s->pool = pool;
6384   s->context = context;
6385   s->callback = callback;
6386   s->first_token = NULL;
6387   s->exprstack = NULL;
6388   s->is_rhs = TRUE;
6389   ffeexpr_stack_ = s;
6390   return (ffelexHandler) ffeexpr_token_first_rhs_;
6391 }
6392 
6393 /* ffeexpr_cb_close_paren_ -- OPEN_PAREN expr
6394 
6395    Pass it to ffeexpr_rhs as the callback routine.
6396 
6397    Makes sure the end token is close-paren and swallows it, else issues
6398    an error message and doesn't swallow the token (passing it along instead).
6399    In either case wraps up subexpression construction by enclosing the
6400    ffebld expression in a paren.  */
6401 
6402 static ffelexHandler
ffeexpr_cb_close_paren_(ffelexToken ft,ffebld expr,ffelexToken t)6403 ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr, ffelexToken t)
6404 {
6405   ffeexprExpr_ e;
6406 
6407   if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
6408     {
6409       /* Oops, naughty user didn't specify the close paren! */
6410 
6411       if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
6412 	{
6413 	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6414 	  ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
6415 		       ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
6416 	  ffebad_finish ();
6417 	}
6418 
6419       e = ffeexpr_expr_new_ ();
6420       e->type = FFEEXPR_exprtypeOPERAND_;
6421       e->u.operand = ffebld_new_any ();
6422       ffebld_set_info (e->u.operand, ffeinfo_new_any ());
6423       ffeexpr_exprstack_push_operand_ (e);
6424 
6425       return
6426 	(ffelexHandler) ffeexpr_find_close_paren_ (t,
6427 						   (ffelexHandler)
6428 						   ffeexpr_token_binary_);
6429     }
6430 
6431   if (expr->op == FFEBLD_opIMPDO)
6432     {
6433       if (ffest_ffebad_start (FFEBAD_IMPDO_PAREN))
6434 	{
6435 	  ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
6436 		       ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
6437 	  ffebad_finish ();
6438 	}
6439     }
6440   else
6441     {
6442       expr = ffebld_new_paren (expr);
6443       ffebld_set_info (expr, ffeinfo_use (ffebld_info (ffebld_left (expr))));
6444     }
6445 
6446   /* Now push the (parenthesized) expression as an operand onto the
6447      expression stack. */
6448 
6449   e = ffeexpr_expr_new_ ();
6450   e->type = FFEEXPR_exprtypeOPERAND_;
6451   e->u.operand = expr;
6452   e->u.operand = ffeexpr_collapse_paren (e->u.operand, ft);
6453   e->token = ffeexpr_stack_->tokens[0];
6454   ffeexpr_exprstack_push_operand_ (e);
6455 
6456   return (ffelexHandler) ffeexpr_token_binary_;
6457 }
6458 
6459 /* ffeexpr_cb_close_paren_ambig_ -- OPEN_PAREN expr
6460 
6461    Pass it to ffeexpr_rhs as the callback routine.
6462 
6463    We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
6464    with the next token in t.  If the next token is possibly a binary
6465    operator, continue processing the outer expression.	If the next
6466    token is COMMA, then the expression is a unit specifier, and
6467    parentheses should not be added to it because it surrounds the
6468    I/O control list that starts with the unit specifier (and continues
6469    on from here -- we haven't seen the CLOSE_PAREN that matches the
6470    OPEN_PAREN, it is up to the callback function to expect to see it
6471    at some point).  In this case, we notify the callback function that
6472    the COMMA is inside, not outside, the parens by wrapping the expression
6473    in an opITEM (with a NULL trail) -- the callback function presumably
6474    unwraps it after seeing this kludgey indicator.
6475 
6476    If the next token is CLOSE_PAREN, then we go to the _1_ state to
6477    decide what to do with the token after that.
6478 
6479    15-Feb-91  JCB  1.1
6480       Use an extra state for the CLOSE_PAREN case to make READ &co really
6481       work right.  */
6482 
6483 static ffelexHandler
ffeexpr_cb_close_paren_ambig_(ffelexToken ft,ffebld expr,ffelexToken t)6484 ffeexpr_cb_close_paren_ambig_ (ffelexToken ft, ffebld expr, ffelexToken t)
6485 {
6486   ffeexprCallback callback;
6487   ffeexprStack_ s;
6488 
6489   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
6490     {				/* Need to see the next token before we
6491 				   decide anything. */
6492       ffeexpr_stack_->expr = expr;
6493       ffeexpr_tokens_[0] = ffelex_token_use (ft);
6494       ffeexpr_tokens_[1] = ffelex_token_use (t);
6495       return (ffelexHandler) ffeexpr_cb_close_paren_ambig_1_;
6496     }
6497 
6498   expr = ffeexpr_finished_ambig_ (ft, expr);
6499 
6500   /* Let the callback function handle the case where t isn't COMMA. */
6501 
6502   /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
6503      that preceded the expression starts a list of expressions, and the expr
6504      hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
6505      node.  The callback function should extract the real expr from the head
6506      of this opITEM node after testing it. */
6507 
6508   expr = ffebld_new_item (expr, NULL);
6509 
6510   ffebld_pool_pop ();
6511   callback = ffeexpr_stack_->callback;
6512   ffelex_token_kill (ffeexpr_stack_->first_token);
6513   s = ffeexpr_stack_->previous;
6514   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
6515   ffeexpr_stack_ = s;
6516   return (ffelexHandler) (*callback) (ft, expr, t);
6517 }
6518 
6519 /* ffeexpr_cb_close_paren_ambig_1_ -- OPEN_PAREN expr CLOSE_PAREN
6520 
6521    See ffeexpr_cb_close_paren_ambig_.
6522 
6523    We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
6524    with the next token in t.  If the next token is possibly a binary
6525    operator, continue processing the outer expression.	If the next
6526    token is COMMA, the expression is a parenthesized format specifier.
6527    If the next token is not EOS or SEMICOLON, then because it is not a
6528    binary operator (it is NAME, OPEN_PAREN, &c), the expression is
6529    a unit specifier, and parentheses should not be added to it because
6530    they surround the I/O control list that consists of only the unit
6531    specifier.  If the next token is EOS or SEMICOLON, the statement
6532    must be disambiguated by looking at the type of the expression -- a
6533    character expression is a parenthesized format specifier, while a
6534    non-character expression is a unit specifier.
6535 
6536    Another issue is how to do the callback so the recipient of the
6537    next token knows how to handle it if it is a COMMA.	In all other
6538    cases, disambiguation is straightforward: the same approach as the
6539    above is used.
6540 
6541    EXTENSION: in COMMA case, if not pedantic, use same disambiguation
6542    as for EOS/SEMICOLON case; f2c allows "READ (cilist) [[,]iolist]"
6543    and apparently other compilers do, as well, and some code out there
6544    uses this "feature".
6545 
6546    19-Feb-91  JCB  1.1
6547       Extend to allow COMMA as nondisambiguating by itself.  Remember
6548       to not try and check info field for opSTAR, since that expr doesn't
6549       have a valid info field.	*/
6550 
6551 static ffelexHandler
ffeexpr_cb_close_paren_ambig_1_(ffelexToken t)6552 ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t)
6553 {
6554   ffeexprCallback callback;
6555   ffeexprStack_ s;
6556   ffelexHandler next;
6557   ffelexToken orig_ft = ffeexpr_tokens_[0];	/* In case callback clobbers
6558 						   these. */
6559   ffelexToken orig_t = ffeexpr_tokens_[1];
6560   ffebld expr = ffeexpr_stack_->expr;
6561 
6562   switch (ffelex_token_type (t))
6563     {
6564     case FFELEX_typeCOMMA:	/* Subexpr is parenthesized format specifier. */
6565       if (ffe_is_pedantic ())
6566 	goto pedantic_comma;	/* :::::::::::::::::::: */
6567       /* Fall through. */
6568     case FFELEX_typeEOS:	/* Ambiguous; use type of expr to
6569 				   disambiguate. */
6570     case FFELEX_typeSEMICOLON:
6571       if ((expr == NULL) || (ffebld_op (expr) == FFEBLD_opANY)
6572 	  || (ffebld_op (expr) == FFEBLD_opSTAR)
6573 	  || (ffeinfo_basictype (ffebld_info (expr))
6574 	      != FFEINFO_basictypeCHARACTER))
6575 	break;			/* Not a valid CHARACTER entity, can't be a
6576 				   format spec. */
6577       /* Fall through. */
6578     default:			/* Binary op (we assume; error otherwise);
6579 				   format specifier. */
6580 
6581     pedantic_comma:		/* :::::::::::::::::::: */
6582 
6583       switch (ffeexpr_stack_->context)
6584 	{
6585 	case FFEEXPR_contextFILENUMAMBIG:
6586 	  ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
6587 	  break;
6588 
6589 	case FFEEXPR_contextFILEUNITAMBIG:
6590 	  ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
6591 	  break;
6592 
6593 	default:
6594 	  assert ("bad context" == NULL);
6595 	  break;
6596 	}
6597 
6598       ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
6599       next = (ffelexHandler) ffeexpr_cb_close_paren_ (orig_ft, expr, orig_t);
6600       ffelex_token_kill (orig_ft);
6601       ffelex_token_kill (orig_t);
6602       return (ffelexHandler) (*next) (t);
6603 
6604     case FFELEX_typeOPEN_PAREN:/* Non-binary op; beginning of I/O list. */
6605     case FFELEX_typeNAME:
6606       break;
6607     }
6608 
6609   expr = ffeexpr_finished_ambig_ (orig_ft, expr);
6610 
6611   /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
6612      that preceded the expression starts a list of expressions, and the expr
6613      hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
6614      node.  The callback function should extract the real expr from the head
6615      of this opITEM node after testing it. */
6616 
6617   expr = ffebld_new_item (expr, NULL);
6618 
6619   ffebld_pool_pop ();
6620   callback = ffeexpr_stack_->callback;
6621   ffelex_token_kill (ffeexpr_stack_->first_token);
6622   s = ffeexpr_stack_->previous;
6623   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
6624   ffeexpr_stack_ = s;
6625   next = (ffelexHandler) (*callback) (orig_ft, expr, orig_t);
6626   ffelex_token_kill (orig_ft);
6627   ffelex_token_kill (orig_t);
6628   return (ffelexHandler) (*next) (t);
6629 }
6630 
6631 /* ffeexpr_cb_close_paren_c_ -- OPEN_PAREN expr (possible complex)
6632 
6633    Pass it to ffeexpr_rhs as the callback routine.
6634 
6635    Makes sure the end token is close-paren and swallows it, or a comma
6636    and handles complex/implied-do possibilities, else issues
6637    an error message and doesn't swallow the token (passing it along instead).  */
6638 
6639 static ffelexHandler
ffeexpr_cb_close_paren_c_(ffelexToken ft,ffebld expr,ffelexToken t)6640 ffeexpr_cb_close_paren_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
6641 {
6642   /* First check to see if this is a possible complex entity.  It is if the
6643      token is a comma. */
6644 
6645   if (ffelex_token_type (t) == FFELEX_typeCOMMA)
6646     {
6647       ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
6648       ffeexpr_stack_->expr = expr;
6649       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
6650 				FFEEXPR_contextPAREN_, ffeexpr_cb_comma_c_);
6651     }
6652 
6653   return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
6654 }
6655 
6656 /* ffeexpr_cb_comma_c_ -- OPEN_PAREN expr COMMA expr
6657 
6658    Pass it to ffeexpr_rhs as the callback routine.
6659 
6660    If this token is not a comma, we have a complex constant (or an attempt
6661    at one), so handle it accordingly, displaying error messages if the token
6662    is not a close-paren.  */
6663 
6664 static ffelexHandler
ffeexpr_cb_comma_c_(ffelexToken ft,ffebld expr,ffelexToken t)6665 ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
6666 {
6667   ffeexprExpr_ e;
6668   ffeinfoBasictype lty = (ffeexpr_stack_->expr == NULL)
6669     ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (ffeexpr_stack_->expr));
6670   ffeinfoBasictype rty = (expr == NULL)
6671     ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (expr));
6672   ffeinfoKindtype lkt;
6673   ffeinfoKindtype rkt;
6674   ffeinfoKindtype nkt;
6675   bool ok = TRUE;
6676   ffebld orig;
6677 
6678   if ((ffeexpr_stack_->expr == NULL)
6679       || (ffebld_op (ffeexpr_stack_->expr) != FFEBLD_opCONTER)
6680       || (((orig = ffebld_conter_orig (ffeexpr_stack_->expr)) != NULL)
6681 	  && (((ffebld_op (orig) != FFEBLD_opUMINUS)
6682 	       && (ffebld_op (orig) != FFEBLD_opUPLUS))
6683 	      || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
6684       || ((lty != FFEINFO_basictypeINTEGER)
6685 	  && (lty != FFEINFO_basictypeREAL)))
6686     {
6687       if ((lty != FFEINFO_basictypeANY)
6688 	  && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
6689 	{
6690 	  ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
6691 		     ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
6692 	  ffebad_string ("Real");
6693 	  ffebad_finish ();
6694 	}
6695       ok = FALSE;
6696     }
6697   if ((expr == NULL)
6698       || (ffebld_op (expr) != FFEBLD_opCONTER)
6699       || (((orig = ffebld_conter_orig (expr)) != NULL)
6700 	  && (((ffebld_op (orig) != FFEBLD_opUMINUS)
6701 	       && (ffebld_op (orig) != FFEBLD_opUPLUS))
6702 	      || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
6703       || ((rty != FFEINFO_basictypeINTEGER)
6704 	  && (rty != FFEINFO_basictypeREAL)))
6705     {
6706       if ((rty != FFEINFO_basictypeANY)
6707 	  && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
6708 	{
6709 	  ffebad_here (0, ffelex_token_where_line (ft),
6710 		       ffelex_token_where_column (ft));
6711 	  ffebad_string ("Imaginary");
6712 	  ffebad_finish ();
6713 	}
6714       ok = FALSE;
6715     }
6716 
6717   ffelex_token_kill (ffeexpr_stack_->tokens[1]);
6718 
6719   /* Push the (parenthesized) expression as an operand onto the expression
6720      stack. */
6721 
6722   e = ffeexpr_expr_new_ ();
6723   e->type = FFEEXPR_exprtypeOPERAND_;
6724   e->token = ffeexpr_stack_->tokens[0];
6725 
6726   if (ok)
6727     {
6728       if (lty == FFEINFO_basictypeINTEGER)
6729 	lkt = FFEINFO_kindtypeREALDEFAULT;
6730       else
6731 	lkt = ffeinfo_kindtype (ffebld_info (ffeexpr_stack_->expr));
6732       if (rty == FFEINFO_basictypeINTEGER)
6733 	rkt = FFEINFO_kindtypeREALDEFAULT;
6734       else
6735 	rkt = ffeinfo_kindtype (ffebld_info (expr));
6736 
6737       nkt = ffeinfo_kindtype_max (FFEINFO_basictypeCOMPLEX, lkt, rkt);
6738       ffeexpr_stack_->expr = ffeexpr_convert (ffeexpr_stack_->expr,
6739 		       ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
6740 		 FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
6741 					      FFEEXPR_contextLET);
6742       expr = ffeexpr_convert (expr,
6743 		       ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
6744 		 FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
6745 			      FFEEXPR_contextLET);
6746     }
6747   else
6748     nkt = FFEINFO_kindtypeANY;
6749 
6750   switch (nkt)
6751     {
6752 #if FFETARGET_okCOMPLEX1
6753     case FFEINFO_kindtypeREAL1:
6754       e->u.operand = ffebld_new_conter (ffebld_constant_new_complex1
6755 	      (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
6756       ffebld_set_info (e->u.operand,
6757 		       ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
6758 				  FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
6759 				    FFETARGET_charactersizeNONE));
6760       break;
6761 #endif
6762 
6763 #if FFETARGET_okCOMPLEX2
6764     case FFEINFO_kindtypeREAL2:
6765       e->u.operand = ffebld_new_conter (ffebld_constant_new_complex2
6766 	      (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
6767       ffebld_set_info (e->u.operand,
6768 		       ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
6769 				  FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
6770 				    FFETARGET_charactersizeNONE));
6771       break;
6772 #endif
6773 
6774 #if FFETARGET_okCOMPLEX3
6775     case FFEINFO_kindtypeREAL3:
6776       e->u.operand = ffebld_new_conter (ffebld_constant_new_complex3
6777 	      (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
6778       ffebld_set_info (e->u.operand,
6779 		       ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
6780 				  FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
6781 				    FFETARGET_charactersizeNONE));
6782       break;
6783 #endif
6784 
6785     default:
6786       if (ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
6787 			? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX))
6788 	{
6789 	  ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
6790 		     ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
6791 	  ffebad_finish ();
6792 	}
6793       /* Fall through. */
6794     case FFEINFO_kindtypeANY:
6795       e->u.operand = ffebld_new_any ();
6796       ffebld_set_info (e->u.operand, ffeinfo_new_any ());
6797       break;
6798     }
6799   ffeexpr_exprstack_push_operand_ (e);
6800 
6801   /* Now, if the token is a close parenthese, we're in great shape so return
6802      the next handler. */
6803 
6804   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
6805     return (ffelexHandler) ffeexpr_token_binary_;
6806 
6807   /* Oops, naughty user didn't specify the close paren! */
6808 
6809   if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
6810     {
6811       ffebad_here (0, ffelex_token_where_line (t),
6812 		   ffelex_token_where_column (t));
6813       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
6814 		   ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
6815       ffebad_finish ();
6816     }
6817 
6818   return
6819     (ffelexHandler) ffeexpr_find_close_paren_ (t,
6820 					       (ffelexHandler)
6821 					       ffeexpr_token_binary_);
6822 }
6823 
6824 /* ffeexpr_cb_close_paren_ci_ -- OPEN_PAREN expr (possible complex or
6825 				    implied-DO construct)
6826 
6827    Pass it to ffeexpr_rhs as the callback routine.
6828 
6829    Makes sure the end token is close-paren and swallows it, or a comma
6830    and handles complex/implied-do possibilities, else issues
6831    an error message and doesn't swallow the token (passing it along instead).  */
6832 
6833 static ffelexHandler
ffeexpr_cb_close_paren_ci_(ffelexToken ft,ffebld expr,ffelexToken t)6834 ffeexpr_cb_close_paren_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
6835 {
6836   ffeexprContext ctx;
6837 
6838   /* First check to see if this is a possible complex or implied-DO entity.
6839      It is if the token is a comma. */
6840 
6841   if (ffelex_token_type (t) == FFELEX_typeCOMMA)
6842     {
6843       switch (ffeexpr_stack_->context)
6844 	{
6845 	case FFEEXPR_contextIOLIST:
6846 	case FFEEXPR_contextIMPDOITEM_:
6847 	  ctx = FFEEXPR_contextIMPDOITEM_;
6848 	  break;
6849 
6850 	case FFEEXPR_contextIOLISTDF:
6851 	case FFEEXPR_contextIMPDOITEMDF_:
6852 	  ctx = FFEEXPR_contextIMPDOITEMDF_;
6853 	  break;
6854 
6855 	default:
6856 	  assert ("bad context" == NULL);
6857 	  ctx = FFEEXPR_contextIMPDOITEM_;
6858 	  break;
6859 	}
6860 
6861       ffeexpr_stack_->tokens[0] = ffelex_token_use (ft);
6862       ffeexpr_stack_->expr = expr;
6863       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
6864 					  ctx, ffeexpr_cb_comma_ci_);
6865     }
6866 
6867   ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
6868   return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
6869 }
6870 
6871 /* ffeexpr_cb_comma_ci_ -- OPEN_PAREN expr COMMA expr
6872 
6873    Pass it to ffeexpr_rhs as the callback routine.
6874 
6875    If this token is not a comma, we have a complex constant (or an attempt
6876    at one), so handle it accordingly, displaying error messages if the token
6877    is not a close-paren.  If we have a comma here, it is an attempt at an
6878    implied-DO, so start making a list accordingly.  Oh, it might be an
6879    equal sign also, meaning an implied-DO with only one item in its list.  */
6880 
6881 static ffelexHandler
ffeexpr_cb_comma_ci_(ffelexToken ft,ffebld expr,ffelexToken t)6882 ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
6883 {
6884   ffebld fexpr;
6885 
6886   /* First check to see if this is a possible complex constant.	 It is if the
6887      token is not a comma or an equals sign, in which case it should be a
6888      close-paren. */
6889 
6890   if ((ffelex_token_type (t) != FFELEX_typeCOMMA)
6891       && (ffelex_token_type (t) != FFELEX_typeEQUALS))
6892     {
6893       ffeexpr_stack_->tokens[1] = ffeexpr_stack_->tokens[0];
6894       ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
6895       return (ffelexHandler) ffeexpr_cb_comma_c_ (ft, expr, t);
6896     }
6897 
6898   /* Here we have either EQUALS or COMMA, meaning we are in an implied-DO
6899      construct.	 Make a list and handle accordingly. */
6900 
6901   ffelex_token_kill (ffeexpr_stack_->tokens[0]);
6902   fexpr = ffeexpr_stack_->expr;
6903   ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
6904   ffebld_append_item (&ffeexpr_stack_->bottom, fexpr);
6905   return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
6906 }
6907 
6908 /* ffeexpr_cb_comma_i_ -- OPEN_PAREN expr
6909 
6910    Pass it to ffeexpr_rhs as the callback routine.
6911 
6912    Handle first item in an implied-DO construct.  */
6913 
6914 static ffelexHandler
ffeexpr_cb_comma_i_(ffelexToken ft,ffebld expr,ffelexToken t)6915 ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr, ffelexToken t)
6916 {
6917   if (ffelex_token_type (t) != FFELEX_typeCOMMA)
6918     {
6919       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
6920 	{
6921 	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6922 	  ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
6923 		   ffelex_token_where_column (ffeexpr_stack_->first_token));
6924 	  ffebad_finish ();
6925 	}
6926       ffebld_end_list (&ffeexpr_stack_->bottom);
6927       ffeexpr_stack_->expr = ffebld_new_any ();
6928       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
6929       if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
6930 	return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
6931       return (ffelexHandler) ffeexpr_cb_comma_i_5_;
6932     }
6933 
6934   return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
6935 }
6936 
6937 /* ffeexpr_cb_comma_i_1_ -- OPEN_PAREN expr
6938 
6939    Pass it to ffeexpr_rhs as the callback routine.
6940 
6941    Handle first item in an implied-DO construct.  */
6942 
6943 static ffelexHandler
ffeexpr_cb_comma_i_1_(ffelexToken ft,ffebld expr,ffelexToken t)6944 ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr, ffelexToken t)
6945 {
6946   ffeexprContext ctxi;
6947   ffeexprContext ctxc;
6948 
6949   switch (ffeexpr_stack_->context)
6950     {
6951     case FFEEXPR_contextDATA:
6952     case FFEEXPR_contextDATAIMPDOITEM_:
6953       ctxi = FFEEXPR_contextDATAIMPDOITEM_;
6954       ctxc = FFEEXPR_contextDATAIMPDOCTRL_;
6955       break;
6956 
6957     case FFEEXPR_contextIOLIST:
6958     case FFEEXPR_contextIMPDOITEM_:
6959       ctxi = FFEEXPR_contextIMPDOITEM_;
6960       ctxc = FFEEXPR_contextIMPDOCTRL_;
6961       break;
6962 
6963     case FFEEXPR_contextIOLISTDF:
6964     case FFEEXPR_contextIMPDOITEMDF_:
6965       ctxi = FFEEXPR_contextIMPDOITEMDF_;
6966       ctxc = FFEEXPR_contextIMPDOCTRL_;
6967       break;
6968 
6969     default:
6970       assert ("bad context" == NULL);
6971       ctxi = FFEEXPR_context;
6972       ctxc = FFEEXPR_context;
6973       break;
6974     }
6975 
6976   switch (ffelex_token_type (t))
6977     {
6978     case FFELEX_typeCOMMA:
6979       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
6980       if (ffeexpr_stack_->is_rhs)
6981 	return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
6982 					    ctxi, ffeexpr_cb_comma_i_1_);
6983       return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
6984 					  ctxi, ffeexpr_cb_comma_i_1_);
6985 
6986     case FFELEX_typeEQUALS:
6987       ffebld_end_list (&ffeexpr_stack_->bottom);
6988 
6989       /* Complain if implied-DO variable in list of items to be read.  */
6990 
6991       if ((ctxc == FFEEXPR_contextIMPDOCTRL_) && !ffeexpr_stack_->is_rhs)
6992 	ffeexpr_check_impdo_ (ffeexpr_stack_->expr,
6993 			      ffeexpr_stack_->first_token, expr, ft);
6994 
6995       /* Set doiter flag for all appropriate SYMTERs.  */
6996 
6997       ffeexpr_update_impdo_ (ffeexpr_stack_->expr, expr);
6998 
6999       ffeexpr_stack_->expr = ffebld_new_impdo (ffeexpr_stack_->expr, NULL);
7000       ffebld_set_info (ffeexpr_stack_->expr,
7001 		       ffeinfo_new (FFEINFO_basictypeNONE,
7002 				    FFEINFO_kindtypeNONE,
7003 				    0,
7004 				    FFEINFO_kindNONE,
7005 				    FFEINFO_whereNONE,
7006 				    FFETARGET_charactersizeNONE));
7007       ffebld_init_list (&(ffebld_right (ffeexpr_stack_->expr)),
7008 			&ffeexpr_stack_->bottom);
7009       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7010       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7011 					  ctxc, ffeexpr_cb_comma_i_2_);
7012 
7013     default:
7014       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7015 	{
7016 	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7017 	  ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7018 		   ffelex_token_where_column (ffeexpr_stack_->first_token));
7019 	  ffebad_finish ();
7020 	}
7021       ffebld_end_list (&ffeexpr_stack_->bottom);
7022       ffeexpr_stack_->expr = ffebld_new_any ();
7023       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7024       if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7025 	return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7026       return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7027     }
7028 }
7029 
7030 /* ffeexpr_cb_comma_i_2_ -- OPEN_PAREN expr-list EQUALS expr
7031 
7032    Pass it to ffeexpr_rhs as the callback routine.
7033 
7034    Handle start-value in an implied-DO construct.  */
7035 
7036 static ffelexHandler
ffeexpr_cb_comma_i_2_(ffelexToken ft UNUSED,ffebld expr,ffelexToken t)7037 ffeexpr_cb_comma_i_2_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7038 {
7039   ffeexprContext ctx;
7040 
7041   switch (ffeexpr_stack_->context)
7042     {
7043     case FFEEXPR_contextDATA:
7044     case FFEEXPR_contextDATAIMPDOITEM_:
7045       ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7046       break;
7047 
7048     case FFEEXPR_contextIOLIST:
7049     case FFEEXPR_contextIOLISTDF:
7050     case FFEEXPR_contextIMPDOITEM_:
7051     case FFEEXPR_contextIMPDOITEMDF_:
7052       ctx = FFEEXPR_contextIMPDOCTRL_;
7053       break;
7054 
7055     default:
7056       assert ("bad context" == NULL);
7057       ctx = FFEEXPR_context;
7058       break;
7059     }
7060 
7061   switch (ffelex_token_type (t))
7062     {
7063     case FFELEX_typeCOMMA:
7064       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7065       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7066 					  ctx, ffeexpr_cb_comma_i_3_);
7067       break;
7068 
7069     default:
7070       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7071 	{
7072 	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7073 	  ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7074 		   ffelex_token_where_column (ffeexpr_stack_->first_token));
7075 	  ffebad_finish ();
7076 	}
7077       ffebld_end_list (&ffeexpr_stack_->bottom);
7078       ffeexpr_stack_->expr = ffebld_new_any ();
7079       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7080       if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7081 	return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7082       return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7083     }
7084 }
7085 
7086 /* ffeexpr_cb_comma_i_3_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7087 
7088    Pass it to ffeexpr_rhs as the callback routine.
7089 
7090    Handle end-value in an implied-DO construct.	 */
7091 
7092 static ffelexHandler
ffeexpr_cb_comma_i_3_(ffelexToken ft UNUSED,ffebld expr,ffelexToken t)7093 ffeexpr_cb_comma_i_3_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7094 {
7095   ffeexprContext ctx;
7096 
7097   switch (ffeexpr_stack_->context)
7098     {
7099     case FFEEXPR_contextDATA:
7100     case FFEEXPR_contextDATAIMPDOITEM_:
7101       ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7102       break;
7103 
7104     case FFEEXPR_contextIOLIST:
7105     case FFEEXPR_contextIOLISTDF:
7106     case FFEEXPR_contextIMPDOITEM_:
7107     case FFEEXPR_contextIMPDOITEMDF_:
7108       ctx = FFEEXPR_contextIMPDOCTRL_;
7109       break;
7110 
7111     default:
7112       assert ("bad context" == NULL);
7113       ctx = FFEEXPR_context;
7114       break;
7115     }
7116 
7117   switch (ffelex_token_type (t))
7118     {
7119     case FFELEX_typeCOMMA:
7120       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7121       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7122 					  ctx, ffeexpr_cb_comma_i_4_);
7123       break;
7124 
7125     case FFELEX_typeCLOSE_PAREN:
7126       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7127       return (ffelexHandler) ffeexpr_cb_comma_i_4_ (NULL, NULL, t);
7128       break;
7129 
7130     default:
7131       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7132 	{
7133 	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7134 	  ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7135 		   ffelex_token_where_column (ffeexpr_stack_->first_token));
7136 	  ffebad_finish ();
7137 	}
7138       ffebld_end_list (&ffeexpr_stack_->bottom);
7139       ffeexpr_stack_->expr = ffebld_new_any ();
7140       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7141       if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7142 	return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7143       return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7144     }
7145 }
7146 
7147 /* ffeexpr_cb_comma_i_4_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7148 			       [COMMA expr]
7149 
7150    Pass it to ffeexpr_rhs as the callback routine.
7151 
7152    Handle incr-value in an implied-DO construct.  */
7153 
7154 static ffelexHandler
ffeexpr_cb_comma_i_4_(ffelexToken ft UNUSED,ffebld expr,ffelexToken t)7155 ffeexpr_cb_comma_i_4_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7156 {
7157   switch (ffelex_token_type (t))
7158     {
7159     case FFELEX_typeCLOSE_PAREN:
7160       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7161       ffebld_end_list (&ffeexpr_stack_->bottom);
7162       {
7163 	ffebld item;
7164 
7165 	for (item = ffebld_left (ffeexpr_stack_->expr);
7166 	     item != NULL;
7167 	     item = ffebld_trail (item))
7168 	  if (ffebld_op (ffebld_head (item)) == FFEBLD_opANY)
7169 	    goto replace_with_any;	/* :::::::::::::::::::: */
7170 
7171 	for (item = ffebld_right (ffeexpr_stack_->expr);
7172 	     item != NULL;
7173 	     item = ffebld_trail (item))
7174 	  if ((ffebld_head (item) != NULL)	/* Increment may be NULL. */
7175 	      && (ffebld_op (ffebld_head (item)) == FFEBLD_opANY))
7176 	    goto replace_with_any;	/* :::::::::::::::::::: */
7177       }
7178       break;
7179 
7180     default:
7181       if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7182 	{
7183 	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7184 	  ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7185 		   ffelex_token_where_column (ffeexpr_stack_->first_token));
7186 	  ffebad_finish ();
7187 	}
7188       ffebld_end_list (&ffeexpr_stack_->bottom);
7189 
7190     replace_with_any:		/* :::::::::::::::::::: */
7191 
7192       ffeexpr_stack_->expr = ffebld_new_any ();
7193       ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7194       break;
7195     }
7196 
7197   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7198     return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7199   return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7200 }
7201 
7202 /* ffeexpr_cb_comma_i_5_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7203 			       [COMMA expr] CLOSE_PAREN
7204 
7205    Pass it to ffeexpr_rhs as the callback routine.
7206 
7207    Collects token following implied-DO construct for callback function.	 */
7208 
7209 static ffelexHandler
ffeexpr_cb_comma_i_5_(ffelexToken t)7210 ffeexpr_cb_comma_i_5_ (ffelexToken t)
7211 {
7212   ffeexprCallback callback;
7213   ffeexprStack_ s;
7214   ffelexHandler next;
7215   ffelexToken ft;
7216   ffebld expr;
7217   bool terminate;
7218 
7219   switch (ffeexpr_stack_->context)
7220     {
7221     case FFEEXPR_contextDATA:
7222     case FFEEXPR_contextDATAIMPDOITEM_:
7223       terminate = TRUE;
7224       break;
7225 
7226     case FFEEXPR_contextIOLIST:
7227     case FFEEXPR_contextIOLISTDF:
7228     case FFEEXPR_contextIMPDOITEM_:
7229     case FFEEXPR_contextIMPDOITEMDF_:
7230       terminate = FALSE;
7231       break;
7232 
7233     default:
7234       assert ("bad context" == NULL);
7235       terminate = FALSE;
7236       break;
7237     }
7238 
7239   ffebld_pool_pop ();
7240   callback = ffeexpr_stack_->callback;
7241   ft = ffeexpr_stack_->first_token;
7242   expr = ffeexpr_stack_->expr;
7243   s = ffeexpr_stack_->previous;
7244   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
7245 		  sizeof (*ffeexpr_stack_));
7246   ffeexpr_stack_ = s;
7247   next = (ffelexHandler) (*callback) (ft, expr, t);
7248   ffelex_token_kill (ft);
7249   if (terminate)
7250     {
7251       ffesymbol_drive_sfnames (ffeexpr_check_impctrl_);
7252       --ffeexpr_level_;
7253       if (ffeexpr_level_ == 0)
7254 	ffe_terminate_4 ();
7255     }
7256   return (ffelexHandler) next;
7257 }
7258 
7259 /* ffeexpr_cb_end_loc_ -- Handle end of %LOC subexpression
7260 
7261    Makes sure the end token is close-paren and swallows it, else issues
7262    an error message and doesn't swallow the token (passing it along instead).
7263    In either case wraps up subexpression construction by enclosing the
7264    ffebld expression in a %LOC.	 */
7265 
7266 static ffelexHandler
ffeexpr_cb_end_loc_(ffelexToken ft UNUSED,ffebld expr,ffelexToken t)7267 ffeexpr_cb_end_loc_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7268 {
7269   ffeexprExpr_ e;
7270 
7271   /* First push the (%LOC) expression as an operand onto the expression
7272      stack. */
7273 
7274   e = ffeexpr_expr_new_ ();
7275   e->type = FFEEXPR_exprtypeOPERAND_;
7276   e->token = ffeexpr_stack_->tokens[0];
7277   e->u.operand = ffebld_new_percent_loc (expr);
7278   ffebld_set_info (e->u.operand,
7279 		   ffeinfo_new (FFEINFO_basictypeINTEGER,
7280 				ffecom_pointer_kind (),
7281 				0,
7282 				FFEINFO_kindENTITY,
7283 				FFEINFO_whereFLEETING,
7284 				FFETARGET_charactersizeNONE));
7285 #if 0				/* ~~ */
7286   e->u.operand = ffeexpr_collapse_percent_loc (e->u.operand, ft);
7287 #endif
7288   ffeexpr_exprstack_push_operand_ (e);
7289 
7290   /* Now, if the token is a close parenthese, we're in great shape so return
7291      the next handler. */
7292 
7293   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7294     {
7295       ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7296       return (ffelexHandler) ffeexpr_token_binary_;
7297     }
7298 
7299   /* Oops, naughty user didn't specify the close paren! */
7300 
7301   if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7302     {
7303       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7304       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
7305 		   ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
7306       ffebad_finish ();
7307     }
7308 
7309   ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7310   return
7311     (ffelexHandler) ffeexpr_find_close_paren_ (t,
7312 					       (ffelexHandler)
7313 					       ffeexpr_token_binary_);
7314 }
7315 
7316 /* ffeexpr_cb_end_notloc_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
7317 
7318    Should be CLOSE_PAREN, and make sure expr isn't a %(VAL,REF,DESCR).  */
7319 
7320 static ffelexHandler
ffeexpr_cb_end_notloc_(ffelexToken ft,ffebld expr,ffelexToken t)7321 ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr, ffelexToken t)
7322 {
7323   ffeexprExpr_ e;
7324   ffebldOp op;
7325 
7326   /* If expression is itself a %(VAL,REF,DESCR), complain and strip off all
7327      such things until the lowest-level expression is reached.  */
7328 
7329   op = ffebld_op (expr);
7330   if ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
7331       || (op == FFEBLD_opPERCENT_DESCR))
7332     {
7333       if (ffebad_start (FFEBAD_NESTED_PERCENT))
7334 	{
7335 	  ffebad_here (0, ffelex_token_where_line (ft),
7336 		       ffelex_token_where_column (ft));
7337 	  ffebad_finish ();
7338 	}
7339 
7340       do
7341 	{
7342 	  expr = ffebld_left (expr);
7343 	  op = ffebld_op (expr);
7344 	}
7345       while ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
7346 	     || (op == FFEBLD_opPERCENT_DESCR));
7347     }
7348 
7349   /* Push the expression as an operand onto the expression stack. */
7350 
7351   e = ffeexpr_expr_new_ ();
7352   e->type = FFEEXPR_exprtypeOPERAND_;
7353   e->token = ffeexpr_stack_->tokens[0];
7354   switch (ffeexpr_stack_->percent)
7355     {
7356     case FFEEXPR_percentVAL_:
7357       e->u.operand = ffebld_new_percent_val (expr);
7358       break;
7359 
7360     case FFEEXPR_percentREF_:
7361       e->u.operand = ffebld_new_percent_ref (expr);
7362       break;
7363 
7364     case FFEEXPR_percentDESCR_:
7365       e->u.operand = ffebld_new_percent_descr (expr);
7366       break;
7367 
7368     default:
7369       assert ("%lossage" == NULL);
7370       e->u.operand = expr;
7371       break;
7372     }
7373   ffebld_set_info (e->u.operand, ffebld_info (expr));
7374 #if 0				/* ~~ */
7375   e->u.operand = ffeexpr_collapse_percent_ ? ? ? (e->u.operand, ft);
7376 #endif
7377   ffeexpr_exprstack_push_operand_ (e);
7378 
7379   /* Now, if the token is a close parenthese, we're in great shape so return
7380      the next handler. */
7381 
7382   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7383     return (ffelexHandler) ffeexpr_cb_end_notloc_1_;
7384 
7385   /* Oops, naughty user didn't specify the close paren! */
7386 
7387   if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7388     {
7389       ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7390       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
7391 		   ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
7392       ffebad_finish ();
7393     }
7394 
7395   ffebld_set_op (e->u.operand, FFEBLD_opPERCENT_LOC);
7396 
7397   switch (ffeexpr_stack_->context)
7398     {
7399     case FFEEXPR_contextACTUALARG_:
7400       ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
7401       break;
7402 
7403     case FFEEXPR_contextINDEXORACTUALARG_:
7404       ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
7405       break;
7406 
7407     case FFEEXPR_contextSFUNCDEFACTUALARG_:
7408       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
7409       break;
7410 
7411     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
7412       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
7413       break;
7414 
7415     default:
7416       assert ("bad context?!?!" == NULL);
7417       break;
7418     }
7419 
7420   ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7421   return
7422     (ffelexHandler) ffeexpr_find_close_paren_ (t,
7423 					       (ffelexHandler)
7424 					       ffeexpr_cb_end_notloc_1_);
7425 }
7426 
7427 /* ffeexpr_cb_end_notloc_1_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
7428    CLOSE_PAREN
7429 
7430    Should be COMMA or CLOSE_PAREN, else change back to %LOC.  */
7431 
7432 static ffelexHandler
ffeexpr_cb_end_notloc_1_(ffelexToken t)7433 ffeexpr_cb_end_notloc_1_ (ffelexToken t)
7434 {
7435   switch (ffelex_token_type (t))
7436     {
7437     case FFELEX_typeCOMMA:
7438     case FFELEX_typeCLOSE_PAREN:
7439       switch (ffeexpr_stack_->context)
7440 	{
7441 	case FFEEXPR_contextACTUALARG_:
7442 	case FFEEXPR_contextSFUNCDEFACTUALARG_:
7443 	  break;
7444 
7445 	case FFEEXPR_contextINDEXORACTUALARG_:
7446 	  ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
7447 	  break;
7448 
7449 	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
7450 	  ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
7451 	  break;
7452 
7453 	default:
7454 	  assert ("bad context?!?!" == NULL);
7455 	  break;
7456 	}
7457       break;
7458 
7459     default:
7460       if (ffebad_start (FFEBAD_INVALID_PERCENT))
7461 	{
7462 	  ffebad_here (0,
7463 		       ffelex_token_where_line (ffeexpr_stack_->first_token),
7464 		   ffelex_token_where_column (ffeexpr_stack_->first_token));
7465 	  ffebad_string (ffelex_token_text (ffeexpr_stack_->tokens[1]));
7466 	  ffebad_finish ();
7467 	}
7468 
7469       ffebld_set_op (ffeexpr_stack_->exprstack->u.operand,
7470 		     FFEBLD_opPERCENT_LOC);
7471 
7472       switch (ffeexpr_stack_->context)
7473 	{
7474 	case FFEEXPR_contextACTUALARG_:
7475 	  ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
7476 	  break;
7477 
7478 	case FFEEXPR_contextINDEXORACTUALARG_:
7479 	  ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
7480 	  break;
7481 
7482 	case FFEEXPR_contextSFUNCDEFACTUALARG_:
7483 	  ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
7484 	  break;
7485 
7486 	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
7487 	  ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
7488 	  break;
7489 
7490 	default:
7491 	  assert ("bad context?!?!" == NULL);
7492 	  break;
7493 	}
7494     }
7495 
7496   ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7497   return
7498     (ffelexHandler) ffeexpr_token_binary_ (t);
7499 }
7500 
7501 /* Process DATA implied-DO iterator variables as this implied-DO level
7502    terminates.  At this point, ffeexpr_level_ == 1 when we see the
7503    last right-paren in "DATA (A(I),I=1,10)/.../".  */
7504 
7505 static ffesymbol
ffeexpr_check_impctrl_(ffesymbol s)7506 ffeexpr_check_impctrl_ (ffesymbol s)
7507 {
7508   assert (s != NULL);
7509   assert (ffesymbol_sfdummyparent (s) != NULL);
7510 
7511   switch (ffesymbol_state (s))
7512     {
7513     case FFESYMBOL_stateNONE:	/* Used as iterator already. Now let symbol
7514 				   be used as iterator at any level at or
7515 				   innermore than the outermost of the
7516 				   current level and the symbol's current
7517 				   level. */
7518       if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
7519 	{
7520 	  ffesymbol_signal_change (s);
7521 	  ffesymbol_set_maxentrynum (s, ffeexpr_level_);
7522 	  ffesymbol_signal_unreported (s);
7523 	}
7524       break;
7525 
7526     case FFESYMBOL_stateSEEN:	/* Seen already in this or other implied-DO.
7527 				   Error if at outermost level, else it can
7528 				   still become an iterator. */
7529       if ((ffeexpr_level_ == 1)
7530 	  && ffebad_start (FFEBAD_BAD_IMPDCL))
7531 	{
7532 	  ffebad_string (ffesymbol_text (s));
7533 	  ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
7534 	  ffebad_finish ();
7535 	}
7536       break;
7537 
7538     case FFESYMBOL_stateUNCERTAIN:	/* Iterator. */
7539       assert (ffeexpr_level_ <= ffesymbol_maxentrynum (s));
7540       ffesymbol_signal_change (s);
7541       ffesymbol_set_state (s, FFESYMBOL_stateNONE);
7542       ffesymbol_signal_unreported (s);
7543       break;
7544 
7545     case FFESYMBOL_stateUNDERSTOOD:
7546       break;			/* ANY. */
7547 
7548     default:
7549       assert ("Sasha Foo!!" == NULL);
7550       break;
7551     }
7552 
7553   return s;
7554 }
7555 
7556 /* Issue diagnostic if implied-DO variable appears in list of lhs
7557    expressions (as in "READ *, (I,I=1,10)").  */
7558 
7559 static void
ffeexpr_check_impdo_(ffebld list,ffelexToken list_t,ffebld dovar,ffelexToken dovar_t)7560 ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
7561 		      ffebld dovar, ffelexToken dovar_t)
7562 {
7563   ffebld item;
7564   ffesymbol dovar_sym;
7565   int itemnum;
7566 
7567   if (ffebld_op (dovar) != FFEBLD_opSYMTER)
7568     return;			/* Presumably opANY. */
7569 
7570   dovar_sym = ffebld_symter (dovar);
7571 
7572   for (itemnum = 1; list != NULL; list = ffebld_trail (list), ++itemnum)
7573     {
7574       if (((item = ffebld_head (list)) != NULL)
7575 	  && (ffebld_op (item) == FFEBLD_opSYMTER)
7576 	  && (ffebld_symter (item) == dovar_sym))
7577 	{
7578 	  char itemno[20];
7579 
7580 	  sprintf (&itemno[0], "%d", itemnum);
7581 	  if (ffebad_start (FFEBAD_DOITER_IMPDO))
7582 	    {
7583 	      ffebad_here (0, ffelex_token_where_line (list_t),
7584 			   ffelex_token_where_column (list_t));
7585 	      ffebad_here (1, ffelex_token_where_line (dovar_t),
7586 			   ffelex_token_where_column (dovar_t));
7587 	      ffebad_string (ffesymbol_text (dovar_sym));
7588 	      ffebad_string (itemno);
7589 	      ffebad_finish ();
7590 	    }
7591 	}
7592     }
7593 }
7594 
7595 /* Decorate any SYMTERs referencing the DO variable with the "doiter"
7596    flag.  */
7597 
7598 static void
ffeexpr_update_impdo_(ffebld list,ffebld dovar)7599 ffeexpr_update_impdo_ (ffebld list, ffebld dovar)
7600 {
7601   ffesymbol dovar_sym;
7602 
7603   if (ffebld_op (dovar) != FFEBLD_opSYMTER)
7604     return;			/* Presumably opANY. */
7605 
7606   dovar_sym = ffebld_symter (dovar);
7607 
7608   ffeexpr_update_impdo_sym_ (list, dovar_sym);	/* Recurse! */
7609 }
7610 
7611 /* Recursive function to update any expr so SYMTERs have "doiter" flag
7612    if they refer to the given variable.	 */
7613 
7614 static void
ffeexpr_update_impdo_sym_(ffebld expr,ffesymbol dovar)7615 ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar)
7616 {
7617   tail_recurse:			/* :::::::::::::::::::: */
7618 
7619   if (expr == NULL)
7620     return;
7621 
7622   switch (ffebld_op (expr))
7623     {
7624     case FFEBLD_opSYMTER:
7625       if (ffebld_symter (expr) == dovar)
7626 	ffebld_symter_set_is_doiter (expr, TRUE);
7627       break;
7628 
7629     case FFEBLD_opITEM:
7630       ffeexpr_update_impdo_sym_ (ffebld_head (expr), dovar);
7631       expr = ffebld_trail (expr);
7632       goto tail_recurse;	/* :::::::::::::::::::: */
7633 
7634     default:
7635       break;
7636     }
7637 
7638   switch (ffebld_arity (expr))
7639     {
7640     case 2:
7641       ffeexpr_update_impdo_sym_ (ffebld_left (expr), dovar);
7642       expr = ffebld_right (expr);
7643       goto tail_recurse;	/* :::::::::::::::::::: */
7644 
7645     case 1:
7646       expr = ffebld_left (expr);
7647       goto tail_recurse;	/* :::::::::::::::::::: */
7648 
7649     default:
7650       break;
7651     }
7652 
7653   return;
7654 }
7655 
7656 /* ffeexpr_context_outer_ -- Determine context of stack entry, skipping PARENs
7657 
7658    if (ffeexpr_context_outer_(ffeexpr_stack_) == FFEEXPR_contextIF)
7659        // After zero or more PAREN_ contexts, an IF context exists  */
7660 
7661 static ffeexprContext
ffeexpr_context_outer_(ffeexprStack_ s)7662 ffeexpr_context_outer_ (ffeexprStack_ s)
7663 {
7664   assert (s != NULL);
7665 
7666   for (;;)
7667     {
7668       switch (s->context)
7669 	{
7670 	case FFEEXPR_contextPAREN_:
7671 	case FFEEXPR_contextPARENFILENUM_:
7672 	case FFEEXPR_contextPARENFILEUNIT_:
7673 	  break;
7674 
7675 	default:
7676 	  return s->context;
7677 	}
7678       s = s->previous;
7679       assert (s != NULL);
7680     }
7681 }
7682 
7683 /* ffeexpr_percent_ -- Look up name in list of %FOO possibilities
7684 
7685    ffeexprPercent_ p;
7686    ffelexToken t;
7687    p = ffeexpr_percent_(t);
7688 
7689    Returns the identifier for the name, or the NONE identifier.	 */
7690 
7691 static ffeexprPercent_
ffeexpr_percent_(ffelexToken t)7692 ffeexpr_percent_ (ffelexToken t)
7693 {
7694   const char *p;
7695 
7696   switch (ffelex_token_length (t))
7697     {
7698     case 3:
7699       switch (*(p = ffelex_token_text (t)))
7700 	{
7701 	case FFESRC_CASE_MATCH_INIT ('L', 'l', match_3l, no_match_3):
7702 	  if ((ffesrc_char_match_noninit (*++p, 'O', 'o'))
7703 	      && (ffesrc_char_match_noninit (*++p, 'C', 'c')))
7704 	    return FFEEXPR_percentLOC_;
7705 	  return FFEEXPR_percentNONE_;
7706 
7707 	case FFESRC_CASE_MATCH_INIT ('R', 'r', match_3r, no_match_3):
7708 	  if ((ffesrc_char_match_noninit (*++p, 'E', 'e'))
7709 	      && (ffesrc_char_match_noninit (*++p, 'F', 'f')))
7710 	    return FFEEXPR_percentREF_;
7711 	  return FFEEXPR_percentNONE_;
7712 
7713 	case FFESRC_CASE_MATCH_INIT ('V', 'v', match_3v, no_match_3):
7714 	  if ((ffesrc_char_match_noninit (*++p, 'A', 'a'))
7715 	      && (ffesrc_char_match_noninit (*++p, 'L', 'l')))
7716 	    return FFEEXPR_percentVAL_;
7717 	  return FFEEXPR_percentNONE_;
7718 
7719 	default:
7720 	no_match_3:		/* :::::::::::::::::::: */
7721 	  return FFEEXPR_percentNONE_;
7722 	}
7723 
7724     case 5:
7725       if (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "DESCR",
7726 			    "descr", "Descr") == 0)
7727 	return FFEEXPR_percentDESCR_;
7728       return FFEEXPR_percentNONE_;
7729 
7730     default:
7731       return FFEEXPR_percentNONE_;
7732     }
7733 }
7734 
7735 /* ffeexpr_type_combine -- Binop combine types, check for mythical new COMPLEX
7736 
7737    See prototype.
7738 
7739    If combining the two basictype/kindtype pairs produces a COMPLEX with an
7740    unsupported kind type, complain and use the default kind type for
7741    COMPLEX.  */
7742 
7743 void
ffeexpr_type_combine(ffeinfoBasictype * xnbt,ffeinfoKindtype * xnkt,ffeinfoBasictype lbt,ffeinfoKindtype lkt,ffeinfoBasictype rbt,ffeinfoKindtype rkt,ffelexToken t)7744 ffeexpr_type_combine (ffeinfoBasictype *xnbt, ffeinfoKindtype *xnkt,
7745 		      ffeinfoBasictype lbt, ffeinfoKindtype lkt,
7746 		      ffeinfoBasictype rbt, ffeinfoKindtype rkt,
7747 		      ffelexToken t)
7748 {
7749   ffeinfoBasictype nbt;
7750   ffeinfoKindtype nkt;
7751 
7752   nbt = ffeinfo_basictype_combine (lbt, rbt);
7753   if ((nbt == FFEINFO_basictypeCOMPLEX)
7754       && ((lbt == nbt) || (lbt == FFEINFO_basictypeREAL))
7755       && ((rbt == nbt) || (rbt == FFEINFO_basictypeREAL)))
7756     {
7757       nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
7758       if (ffe_is_pedantic_not_90 () && (nkt == FFEINFO_kindtypeREALDOUBLE))
7759 	nkt = FFEINFO_kindtypeNONE;	/* Force error. */
7760       switch (nkt)
7761 	{
7762 #if FFETARGET_okCOMPLEX1
7763 	case FFEINFO_kindtypeREAL1:
7764 #endif
7765 #if FFETARGET_okCOMPLEX2
7766 	case FFEINFO_kindtypeREAL2:
7767 #endif
7768 #if FFETARGET_okCOMPLEX3
7769 	case FFEINFO_kindtypeREAL3:
7770 #endif
7771 	  break;		/* Fine and dandy. */
7772 
7773 	default:
7774 	  if (t != NULL)
7775 	    {
7776 	      ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
7777 			    ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX);
7778 	      ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7779 	      ffebad_finish ();
7780 	    }
7781 	  nbt = FFEINFO_basictypeNONE;
7782 	  nkt = FFEINFO_kindtypeNONE;
7783 	  break;
7784 
7785 	case FFEINFO_kindtypeANY:
7786 	  nkt = FFEINFO_kindtypeREALDEFAULT;
7787 	  break;
7788 	}
7789     }
7790   else
7791     {				/* The normal stuff. */
7792       if (nbt == lbt)
7793 	{
7794 	  if (nbt == rbt)
7795 	    nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
7796 	  else
7797 	    nkt = lkt;
7798 	}
7799       else if (nbt == rbt)
7800 	nkt = rkt;
7801       else
7802 	{			/* Let the caller do the complaining. */
7803 	  nbt = FFEINFO_basictypeNONE;
7804 	  nkt = FFEINFO_kindtypeNONE;
7805 	}
7806     }
7807 
7808   /* Always a good idea to avoid aliasing problems.  */
7809 
7810   *xnbt = nbt;
7811   *xnkt = nkt;
7812 }
7813 
7814 /* ffeexpr_token_first_lhs_ -- First state for lhs expression
7815 
7816    Return a pointer to this function to the lexer (ffelex), which will
7817    invoke it for the next token.
7818 
7819    Record line and column of first token in expression, then invoke the
7820    initial-state lhs handler.  */
7821 
7822 static ffelexHandler
ffeexpr_token_first_lhs_(ffelexToken t)7823 ffeexpr_token_first_lhs_ (ffelexToken t)
7824 {
7825   ffeexpr_stack_->first_token = ffelex_token_use (t);
7826 
7827   /* When changing the list of valid initial lhs tokens, check whether to
7828      update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
7829      READ (expr) <token> case -- it assumes it knows which tokens <token> can
7830      be to indicate an lhs (or implied DO), which right now is the set
7831      {NAME,OPEN_PAREN}.
7832 
7833      This comment also appears in ffeexpr_token_lhs_. */
7834 
7835   switch (ffelex_token_type (t))
7836     {
7837     case FFELEX_typeOPEN_PAREN:
7838       switch (ffeexpr_stack_->context)
7839 	{
7840 	case FFEEXPR_contextDATA:
7841 	  ffe_init_4 ();
7842 	  ffeexpr_level_ = 1;	/* Level of DATA implied-DO construct. */
7843 	  ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7844 	  return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7845 			FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
7846 
7847 	case FFEEXPR_contextDATAIMPDOITEM_:
7848 	  ++ffeexpr_level_;	/* Level of DATA implied-DO construct. */
7849 	  ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7850 	  return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7851 			FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
7852 
7853 	case FFEEXPR_contextIOLIST:
7854 	case FFEEXPR_contextIMPDOITEM_:
7855 	  ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7856 	  return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7857 			    FFEEXPR_contextIMPDOITEM_, ffeexpr_cb_comma_i_);
7858 
7859 	case FFEEXPR_contextIOLISTDF:
7860 	case FFEEXPR_contextIMPDOITEMDF_:
7861 	  ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7862 	  return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7863 			  FFEEXPR_contextIMPDOITEMDF_, ffeexpr_cb_comma_i_);
7864 
7865 	case FFEEXPR_contextFILEEXTFUNC:
7866 	  assert (ffeexpr_stack_->exprstack == NULL);
7867 	  return (ffelexHandler) ffeexpr_token_first_lhs_1_;
7868 
7869 	default:
7870 	  break;
7871 	}
7872       break;
7873 
7874     case FFELEX_typeNAME:
7875       switch (ffeexpr_stack_->context)
7876 	{
7877 	case FFEEXPR_contextFILENAMELIST:
7878 	  assert (ffeexpr_stack_->exprstack == NULL);
7879 	  return (ffelexHandler) ffeexpr_token_namelist_;
7880 
7881 	case FFEEXPR_contextFILEEXTFUNC:
7882 	  assert (ffeexpr_stack_->exprstack == NULL);
7883 	  return (ffelexHandler) ffeexpr_token_first_lhs_1_;
7884 
7885 	default:
7886 	  break;
7887 	}
7888       break;
7889 
7890     default:
7891       switch (ffeexpr_stack_->context)
7892 	{
7893 	case FFEEXPR_contextFILEEXTFUNC:
7894 	  assert (ffeexpr_stack_->exprstack == NULL);
7895 	  return (ffelexHandler) ffeexpr_token_first_lhs_1_;
7896 
7897 	default:
7898 	  break;
7899 	}
7900       break;
7901     }
7902 
7903   return (ffelexHandler) ffeexpr_token_lhs_ (t);
7904 }
7905 
7906 /* ffeexpr_token_first_lhs_1_ -- NAME
7907 
7908    return ffeexpr_token_first_lhs_1_;  // to lexer
7909 
7910    Handle NAME as an external function (USEROPEN= VXT extension to OPEN
7911    statement).	*/
7912 
7913 static ffelexHandler
ffeexpr_token_first_lhs_1_(ffelexToken t)7914 ffeexpr_token_first_lhs_1_ (ffelexToken t)
7915 {
7916   ffeexprCallback callback;
7917   ffeexprStack_ s;
7918   ffelexHandler next;
7919   ffelexToken ft;
7920   ffesymbol sy = NULL;
7921   ffebld expr;
7922 
7923   ffebld_pool_pop ();
7924   callback = ffeexpr_stack_->callback;
7925   ft = ffeexpr_stack_->first_token;
7926   s = ffeexpr_stack_->previous;
7927 
7928   if ((ffelex_token_type (ft) != FFELEX_typeNAME)
7929       || (ffesymbol_attrs (sy = ffeexpr_declare_unadorned_ (ft, FALSE))
7930 	  & FFESYMBOL_attrANY))
7931     {
7932       if ((ffelex_token_type (ft) != FFELEX_typeNAME)
7933 	  || !(ffesymbol_attrs (sy) & FFESYMBOL_attrsANY))
7934 	{
7935 	  ffebad_start (FFEBAD_EXPR_WRONG);
7936 	  ffebad_here (0, ffelex_token_where_line (ft),
7937 		       ffelex_token_where_column (ft));
7938 	  ffebad_finish ();
7939 	}
7940       expr = ffebld_new_any ();
7941       ffebld_set_info (expr, ffeinfo_new_any ());
7942     }
7943   else
7944     {
7945       expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
7946 				FFEINTRIN_impNONE);
7947       ffebld_set_info (expr, ffesymbol_info (sy));
7948     }
7949 
7950   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
7951 		  sizeof (*ffeexpr_stack_));
7952   ffeexpr_stack_ = s;
7953 
7954   next = (ffelexHandler) (*callback) (ft, expr, t);
7955   ffelex_token_kill (ft);
7956   return (ffelexHandler) next;
7957 }
7958 
7959 /* ffeexpr_token_first_rhs_ -- First state for rhs expression
7960 
7961    Record line and column of first token in expression, then invoke the
7962    initial-state rhs handler.
7963 
7964    19-Feb-91  JCB  1.1
7965       Allow ASTERISK in PARENFILEUNIT_ case, but only on second level only
7966       (i.e. only as in READ(*), not READ((*))).	 */
7967 
7968 static ffelexHandler
ffeexpr_token_first_rhs_(ffelexToken t)7969 ffeexpr_token_first_rhs_ (ffelexToken t)
7970 {
7971   ffesymbol s;
7972 
7973   ffeexpr_stack_->first_token = ffelex_token_use (t);
7974 
7975   switch (ffelex_token_type (t))
7976     {
7977     case FFELEX_typeASTERISK:
7978       switch (ffeexpr_stack_->context)
7979 	{
7980 	case FFEEXPR_contextFILEFORMATNML:
7981 	  ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
7982 	  /* Fall through.  */
7983 	case FFEEXPR_contextFILEUNIT:
7984 	case FFEEXPR_contextDIMLIST:
7985 	case FFEEXPR_contextFILEFORMAT:
7986 	case FFEEXPR_contextCHARACTERSIZE:
7987 	  if (ffeexpr_stack_->previous != NULL)
7988 	    break;		/* Valid only on first level. */
7989 	  assert (ffeexpr_stack_->exprstack == NULL);
7990 	  return (ffelexHandler) ffeexpr_token_first_rhs_1_;
7991 
7992 	case FFEEXPR_contextPARENFILEUNIT_:
7993 	  if (ffeexpr_stack_->previous->previous != NULL)
7994 	    break;		/* Valid only on second level. */
7995 	  assert (ffeexpr_stack_->exprstack == NULL);
7996 	  return (ffelexHandler) ffeexpr_token_first_rhs_1_;
7997 
7998 	case FFEEXPR_contextACTUALARG_:
7999 	  if (ffeexpr_stack_->previous->context
8000 	      != FFEEXPR_contextSUBROUTINEREF)
8001 	    {
8002 	      ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8003 	      break;
8004 	    }
8005 	  assert (ffeexpr_stack_->exprstack == NULL);
8006 	  return (ffelexHandler) ffeexpr_token_first_rhs_3_;
8007 
8008 	case FFEEXPR_contextINDEXORACTUALARG_:
8009 	  ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8010 	  break;
8011 
8012 	case FFEEXPR_contextSFUNCDEFACTUALARG_:
8013 	  ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8014 	  break;
8015 
8016 	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8017 	  ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8018 	  break;
8019 
8020 	default:
8021 	  break;
8022 	}
8023       break;
8024 
8025     case FFELEX_typeOPEN_PAREN:
8026       switch (ffeexpr_stack_->context)
8027 	{
8028 	case FFEEXPR_contextFILENUMAMBIG:
8029 	  return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8030 					      FFEEXPR_contextPARENFILENUM_,
8031 					      ffeexpr_cb_close_paren_ambig_);
8032 
8033 	case FFEEXPR_contextFILEUNITAMBIG:
8034 	  return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8035 					      FFEEXPR_contextPARENFILEUNIT_,
8036 					      ffeexpr_cb_close_paren_ambig_);
8037 
8038 	case FFEEXPR_contextIOLIST:
8039 	case FFEEXPR_contextIMPDOITEM_:
8040 	  return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8041 					      FFEEXPR_contextIMPDOITEM_,
8042 					      ffeexpr_cb_close_paren_ci_);
8043 
8044 	case FFEEXPR_contextIOLISTDF:
8045 	case FFEEXPR_contextIMPDOITEMDF_:
8046 	  return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8047 					      FFEEXPR_contextIMPDOITEMDF_,
8048 					      ffeexpr_cb_close_paren_ci_);
8049 
8050 	case FFEEXPR_contextFILEFORMATNML:
8051 	  ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8052 	  break;
8053 
8054 	case FFEEXPR_contextACTUALARG_:
8055 	  ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8056 	  break;
8057 
8058 	case FFEEXPR_contextINDEXORACTUALARG_:
8059 	  ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8060 	  break;
8061 
8062 	case FFEEXPR_contextSFUNCDEFACTUALARG_:
8063 	  ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8064 	  break;
8065 
8066 	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8067 	  ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8068 	  break;
8069 
8070 	default:
8071 	  break;
8072 	}
8073       break;
8074 
8075     case FFELEX_typeNUMBER:
8076       switch (ffeexpr_stack_->context)
8077 	{
8078 	case FFEEXPR_contextFILEFORMATNML:
8079 	  ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8080 	  /* Fall through.  */
8081 	case FFEEXPR_contextFILEFORMAT:
8082 	  if (ffeexpr_stack_->previous != NULL)
8083 	    break;		/* Valid only on first level. */
8084 	  assert (ffeexpr_stack_->exprstack == NULL);
8085 	  return (ffelexHandler) ffeexpr_token_first_rhs_2_;
8086 
8087 	case FFEEXPR_contextACTUALARG_:
8088 	  ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8089 	  break;
8090 
8091 	case FFEEXPR_contextINDEXORACTUALARG_:
8092 	  ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8093 	  break;
8094 
8095 	case FFEEXPR_contextSFUNCDEFACTUALARG_:
8096 	  ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8097 	  break;
8098 
8099 	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8100 	  ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8101 	  break;
8102 
8103 	default:
8104 	  break;
8105 	}
8106       break;
8107 
8108     case FFELEX_typeNAME:
8109       switch (ffeexpr_stack_->context)
8110 	{
8111 	case FFEEXPR_contextFILEFORMATNML:
8112 	  assert (ffeexpr_stack_->exprstack == NULL);
8113 	  s = ffesymbol_lookup_local (t);
8114 	  if ((s != NULL) && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST))
8115 	    return (ffelexHandler) ffeexpr_token_namelist_;
8116 	  ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8117 	  break;
8118 
8119 	default:
8120 	  break;
8121 	}
8122       break;
8123 
8124     case FFELEX_typePERCENT:
8125       switch (ffeexpr_stack_->context)
8126 	{
8127 	case FFEEXPR_contextACTUALARG_:
8128 	case FFEEXPR_contextINDEXORACTUALARG_:
8129 	case FFEEXPR_contextSFUNCDEFACTUALARG_:
8130 	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8131 	  return (ffelexHandler) ffeexpr_token_first_rhs_5_;
8132 
8133 	case FFEEXPR_contextFILEFORMATNML:
8134 	  ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8135 	  break;
8136 
8137 	default:
8138 	  break;
8139 	}
8140 
8141     default:
8142       switch (ffeexpr_stack_->context)
8143 	{
8144 	case FFEEXPR_contextACTUALARG_:
8145 	  ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8146 	  break;
8147 
8148 	case FFEEXPR_contextINDEXORACTUALARG_:
8149 	  ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8150 	  break;
8151 
8152 	case FFEEXPR_contextSFUNCDEFACTUALARG_:
8153 	  ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8154 	  break;
8155 
8156 	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8157 	  ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8158 	  break;
8159 
8160 	case FFEEXPR_contextFILEFORMATNML:
8161 	  ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8162 	  break;
8163 
8164 	default:
8165 	  break;
8166 	}
8167       break;
8168     }
8169 
8170   return (ffelexHandler) ffeexpr_token_rhs_ (t);
8171 }
8172 
8173 /* ffeexpr_token_first_rhs_1_ -- ASTERISK
8174 
8175    return ffeexpr_token_first_rhs_1_;  // to lexer
8176 
8177    Return STAR as expression.  */
8178 
8179 static ffelexHandler
ffeexpr_token_first_rhs_1_(ffelexToken t)8180 ffeexpr_token_first_rhs_1_ (ffelexToken t)
8181 {
8182   ffebld expr;
8183   ffeexprCallback callback;
8184   ffeexprStack_ s;
8185   ffelexHandler next;
8186   ffelexToken ft;
8187 
8188   expr = ffebld_new_star ();
8189   ffebld_pool_pop ();
8190   callback = ffeexpr_stack_->callback;
8191   ft = ffeexpr_stack_->first_token;
8192   s = ffeexpr_stack_->previous;
8193   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
8194   ffeexpr_stack_ = s;
8195   next = (ffelexHandler) (*callback) (ft, expr, t);
8196   ffelex_token_kill (ft);
8197   return (ffelexHandler) next;
8198 }
8199 
8200 /* ffeexpr_token_first_rhs_2_ -- NUMBER
8201 
8202    return ffeexpr_token_first_rhs_2_;  // to lexer
8203 
8204    Return NULL as expression; NUMBER as first (and only) token, unless the
8205    current token is not a terminating token, in which case run normal
8206    expression handling.	 */
8207 
8208 static ffelexHandler
ffeexpr_token_first_rhs_2_(ffelexToken t)8209 ffeexpr_token_first_rhs_2_ (ffelexToken t)
8210 {
8211   ffeexprCallback callback;
8212   ffeexprStack_ s;
8213   ffelexHandler next;
8214   ffelexToken ft;
8215 
8216   switch (ffelex_token_type (t))
8217     {
8218     case FFELEX_typeCLOSE_PAREN:
8219     case FFELEX_typeCOMMA:
8220     case FFELEX_typeEOS:
8221     case FFELEX_typeSEMICOLON:
8222       break;
8223 
8224     default:
8225       next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
8226       return (ffelexHandler) (*next) (t);
8227     }
8228 
8229   ffebld_pool_pop ();
8230   callback = ffeexpr_stack_->callback;
8231   ft = ffeexpr_stack_->first_token;
8232   s = ffeexpr_stack_->previous;
8233   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
8234 		  sizeof (*ffeexpr_stack_));
8235   ffeexpr_stack_ = s;
8236   next = (ffelexHandler) (*callback) (ft, NULL, t);
8237   ffelex_token_kill (ft);
8238   return (ffelexHandler) next;
8239 }
8240 
8241 /* ffeexpr_token_first_rhs_3_ -- ASTERISK
8242 
8243    return ffeexpr_token_first_rhs_3_;  // to lexer
8244 
8245    Expect NUMBER, make LABTOK (with copy of token if not inhibited after
8246    confirming, else NULL).  */
8247 
8248 static ffelexHandler
ffeexpr_token_first_rhs_3_(ffelexToken t)8249 ffeexpr_token_first_rhs_3_ (ffelexToken t)
8250 {
8251   ffelexHandler next;
8252 
8253   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
8254     {				/* An error, but let normal processing handle
8255 				   it. */
8256       next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
8257       return (ffelexHandler) (*next) (t);
8258     }
8259 
8260   /* Special case: when we see "*10" as an argument to a subroutine
8261      reference, we confirm the current statement and, if not inhibited at
8262      this point, put a copy of the token into a LABTOK node.  We do this
8263      instead of just resolving the label directly via ffelab and putting it
8264      into a LABTER simply to improve error reporting and consistency in
8265      ffestc.  We put NULL in the LABTOK if we're still inhibited, so ffestb
8266      doesn't have to worry about killing off any tokens when retracting. */
8267 
8268   ffest_confirmed ();
8269   if (ffest_is_inhibited ())
8270     ffeexpr_stack_->expr = ffebld_new_labtok (NULL);
8271   else
8272     ffeexpr_stack_->expr = ffebld_new_labtok (ffelex_token_use (t));
8273   ffebld_set_info (ffeexpr_stack_->expr,
8274 		   ffeinfo_new (FFEINFO_basictypeNONE,
8275 				FFEINFO_kindtypeNONE,
8276 				0,
8277 				FFEINFO_kindNONE,
8278 				FFEINFO_whereNONE,
8279 				FFETARGET_charactersizeNONE));
8280 
8281   return (ffelexHandler) ffeexpr_token_first_rhs_4_;
8282 }
8283 
8284 /* ffeexpr_token_first_rhs_4_ -- ASTERISK NUMBER
8285 
8286    return ffeexpr_token_first_rhs_4_;  // to lexer
8287 
8288    Collect/flush appropriate stuff, send token to callback function.  */
8289 
8290 static ffelexHandler
ffeexpr_token_first_rhs_4_(ffelexToken t)8291 ffeexpr_token_first_rhs_4_ (ffelexToken t)
8292 {
8293   ffebld expr;
8294   ffeexprCallback callback;
8295   ffeexprStack_ s;
8296   ffelexHandler next;
8297   ffelexToken ft;
8298 
8299   expr = ffeexpr_stack_->expr;
8300   ffebld_pool_pop ();
8301   callback = ffeexpr_stack_->callback;
8302   ft = ffeexpr_stack_->first_token;
8303   s = ffeexpr_stack_->previous;
8304   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
8305   ffeexpr_stack_ = s;
8306   next = (ffelexHandler) (*callback) (ft, expr, t);
8307   ffelex_token_kill (ft);
8308   return (ffelexHandler) next;
8309 }
8310 
8311 /* ffeexpr_token_first_rhs_5_ -- PERCENT
8312 
8313    Should be NAME, or pass through original mechanism.  If NAME is LOC,
8314    pass through original mechanism, otherwise must be VAL, REF, or DESCR,
8315    in which case handle the argument (in parentheses), etc.  */
8316 
8317 static ffelexHandler
ffeexpr_token_first_rhs_5_(ffelexToken t)8318 ffeexpr_token_first_rhs_5_ (ffelexToken t)
8319 {
8320   ffelexHandler next;
8321 
8322   if (ffelex_token_type (t) == FFELEX_typeNAME)
8323     {
8324       ffeexprPercent_ p = ffeexpr_percent_ (t);
8325 
8326       switch (p)
8327 	{
8328 	case FFEEXPR_percentNONE_:
8329 	case FFEEXPR_percentLOC_:
8330 	  break;		/* Treat %LOC as any other expression. */
8331 
8332 	case FFEEXPR_percentVAL_:
8333 	case FFEEXPR_percentREF_:
8334 	case FFEEXPR_percentDESCR_:
8335 	  ffeexpr_stack_->percent = p;
8336 	  ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
8337 	  return (ffelexHandler) ffeexpr_token_first_rhs_6_;
8338 
8339 	default:
8340 	  assert ("bad percent?!?" == NULL);
8341 	  break;
8342 	}
8343     }
8344 
8345   switch (ffeexpr_stack_->context)
8346     {
8347     case FFEEXPR_contextACTUALARG_:
8348       ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8349       break;
8350 
8351     case FFEEXPR_contextINDEXORACTUALARG_:
8352       ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8353       break;
8354 
8355     case FFEEXPR_contextSFUNCDEFACTUALARG_:
8356       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8357       break;
8358 
8359     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8360       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8361       break;
8362 
8363     default:
8364       assert ("bad context?!?!" == NULL);
8365       break;
8366     }
8367 
8368   next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
8369   return (ffelexHandler) (*next) (t);
8370 }
8371 
8372 /* ffeexpr_token_first_rhs_6_ -- PERCENT NAME(VAL,REF,DESCR)
8373 
8374    Should be OPEN_PAREN, or pass through original mechanism.  */
8375 
8376 static ffelexHandler
ffeexpr_token_first_rhs_6_(ffelexToken t)8377 ffeexpr_token_first_rhs_6_ (ffelexToken t)
8378 {
8379   ffelexHandler next;
8380   ffelexToken ft;
8381 
8382   if (ffelex_token_type (t) == FFELEX_typeOPEN_PAREN)
8383     {
8384       ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
8385       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8386 					  ffeexpr_stack_->context,
8387 					  ffeexpr_cb_end_notloc_);
8388     }
8389 
8390   switch (ffeexpr_stack_->context)
8391     {
8392     case FFEEXPR_contextACTUALARG_:
8393       ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8394       break;
8395 
8396     case FFEEXPR_contextINDEXORACTUALARG_:
8397       ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8398       break;
8399 
8400     case FFEEXPR_contextSFUNCDEFACTUALARG_:
8401       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8402       break;
8403 
8404     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8405       ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8406       break;
8407 
8408     default:
8409       assert ("bad context?!?!" == NULL);
8410       break;
8411     }
8412 
8413   ft = ffeexpr_stack_->tokens[0];
8414   next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
8415   next = (ffelexHandler) (*next) (ft);
8416   ffelex_token_kill (ft);
8417   return (ffelexHandler) (*next) (t);
8418 }
8419 
8420 /* ffeexpr_token_namelist_ -- NAME
8421 
8422    return ffeexpr_token_namelist_;  // to lexer
8423 
8424    Make sure NAME was a valid namelist object, wrap it in a SYMTER and
8425    return.  */
8426 
8427 static ffelexHandler
ffeexpr_token_namelist_(ffelexToken t)8428 ffeexpr_token_namelist_ (ffelexToken t)
8429 {
8430   ffeexprCallback callback;
8431   ffeexprStack_ s;
8432   ffelexHandler next;
8433   ffelexToken ft;
8434   ffesymbol sy;
8435   ffebld expr;
8436 
8437   ffebld_pool_pop ();
8438   callback = ffeexpr_stack_->callback;
8439   ft = ffeexpr_stack_->first_token;
8440   s = ffeexpr_stack_->previous;
8441   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
8442   ffeexpr_stack_ = s;
8443 
8444   sy = ffesymbol_lookup_local (ft);
8445   if ((sy == NULL) || (ffesymbol_kind (sy) != FFEINFO_kindNAMELIST))
8446     {
8447       ffebad_start (FFEBAD_EXPR_WRONG);
8448       ffebad_here (0, ffelex_token_where_line (ft),
8449 		   ffelex_token_where_column (ft));
8450       ffebad_finish ();
8451       expr = ffebld_new_any ();
8452       ffebld_set_info (expr, ffeinfo_new_any ());
8453     }
8454   else
8455     {
8456       expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
8457 				FFEINTRIN_impNONE);
8458       ffebld_set_info (expr, ffesymbol_info (sy));
8459     }
8460   next = (ffelexHandler) (*callback) (ft, expr, t);
8461   ffelex_token_kill (ft);
8462   return (ffelexHandler) next;
8463 }
8464 
8465 /* ffeexpr_expr_kill_ -- Kill an existing internal expression object
8466 
8467    ffeexprExpr_ e;
8468    ffeexpr_expr_kill_(e);
8469 
8470    Kills the ffewhere info, if necessary, then kills the object.  */
8471 
8472 static void
ffeexpr_expr_kill_(ffeexprExpr_ e)8473 ffeexpr_expr_kill_ (ffeexprExpr_ e)
8474 {
8475   if (e->token != NULL)
8476     ffelex_token_kill (e->token);
8477   malloc_kill_ks (ffe_pool_program_unit (), e, sizeof (*e));
8478 }
8479 
8480 /* ffeexpr_expr_new_ -- Make a new internal expression object
8481 
8482    ffeexprExpr_ e;
8483    e = ffeexpr_expr_new_();
8484 
8485    Allocates and initializes a new expression object, returns it.  */
8486 
8487 static ffeexprExpr_
ffeexpr_expr_new_(void)8488 ffeexpr_expr_new_ (void)
8489 {
8490   ffeexprExpr_ e;
8491 
8492   e = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR expr", sizeof (*e));
8493   e->previous = NULL;
8494   e->type = FFEEXPR_exprtypeUNKNOWN_;
8495   e->token = NULL;
8496   return e;
8497 }
8498 
8499 /* Verify that call to global is valid, and register whatever
8500    new information about a global might be discoverable by looking
8501    at the call.  */
8502 
8503 static void
ffeexpr_fulfill_call_(ffebld * expr,ffelexToken t)8504 ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t)
8505 {
8506   int n_args;
8507   ffebld list;
8508   ffebld item;
8509   ffesymbol s;
8510 
8511   assert ((ffebld_op (*expr) == FFEBLD_opSUBRREF)
8512 	  || (ffebld_op (*expr) == FFEBLD_opFUNCREF));
8513 
8514   if (ffebld_op (ffebld_left (*expr)) != FFEBLD_opSYMTER)
8515     return;
8516 
8517   if (ffesymbol_retractable ())
8518     return;
8519 
8520   s = ffebld_symter (ffebld_left (*expr));
8521   if (ffesymbol_global (s) == NULL)
8522     return;
8523 
8524   for (n_args = 0, list = ffebld_right (*expr);
8525        list != NULL;
8526        list = ffebld_trail (list), ++n_args)
8527     ;
8528 
8529   if (ffeglobal_proc_ref_nargs (s, n_args, t))
8530     {
8531       ffeglobalArgSummary as;
8532       ffeinfoBasictype bt;
8533       ffeinfoKindtype kt;
8534       bool array;
8535       bool fail = FALSE;
8536 
8537       for (n_args = 0, list = ffebld_right (*expr);
8538 	   list != NULL;
8539 	   list = ffebld_trail (list), ++n_args)
8540 	{
8541 	  item = ffebld_head (list);
8542 	  if (item != NULL)
8543 	    {
8544 	      bt = ffeinfo_basictype (ffebld_info (item));
8545 	      kt = ffeinfo_kindtype (ffebld_info (item));
8546 	      array = (ffeinfo_rank (ffebld_info (item)) > 0);
8547 	      switch (ffebld_op (item))
8548 		{
8549 		case FFEBLD_opLABTOK:
8550 		case FFEBLD_opLABTER:
8551 		  as = FFEGLOBAL_argsummaryALTRTN;
8552 		  break;
8553 
8554 #if 0
8555 		  /* No, %LOC(foo) is just like any INTEGER(KIND=7)
8556 		     expression, so don't treat it specially.  */
8557 		case FFEBLD_opPERCENT_LOC:
8558 		  as = FFEGLOBAL_argsummaryPTR;
8559 		  break;
8560 #endif
8561 
8562 		case FFEBLD_opPERCENT_VAL:
8563 		  as = FFEGLOBAL_argsummaryVAL;
8564 		  break;
8565 
8566 		case FFEBLD_opPERCENT_REF:
8567 		  as = FFEGLOBAL_argsummaryREF;
8568 		  break;
8569 
8570 		case FFEBLD_opPERCENT_DESCR:
8571 		  as = FFEGLOBAL_argsummaryDESCR;
8572 		  break;
8573 
8574 		case FFEBLD_opFUNCREF:
8575 #if 0
8576 		  /* No, LOC(foo) is just like any INTEGER(KIND=7)
8577 		     expression, so don't treat it specially.  */
8578 		  if ((ffebld_op (ffebld_left (item)) == FFEBLD_opSYMTER)
8579 		      && (ffesymbol_specific (ffebld_symter (ffebld_left (item)))
8580 			  == FFEINTRIN_specLOC))
8581 		    {
8582 		      as = FFEGLOBAL_argsummaryPTR;
8583 		      break;
8584 		    }
8585 #endif
8586 		  /* Fall through.  */
8587 		default:
8588 		  if (ffebld_op (item) == FFEBLD_opSYMTER)
8589 		    {
8590 		      as = FFEGLOBAL_argsummaryNONE;
8591 
8592 		      switch (ffeinfo_kind (ffebld_info (item)))
8593 			{
8594 			case FFEINFO_kindFUNCTION:
8595 			  as = FFEGLOBAL_argsummaryFUNC;
8596 			  break;
8597 
8598 			case FFEINFO_kindSUBROUTINE:
8599 			  as = FFEGLOBAL_argsummarySUBR;
8600 			  break;
8601 
8602 			case FFEINFO_kindNONE:
8603 			  as = FFEGLOBAL_argsummaryPROC;
8604 			  break;
8605 
8606 			default:
8607 			  break;
8608 			}
8609 
8610 		      if (as != FFEGLOBAL_argsummaryNONE)
8611 			break;
8612 		    }
8613 
8614 		  if (bt == FFEINFO_basictypeCHARACTER)
8615 		    as = FFEGLOBAL_argsummaryDESCR;
8616 		  else
8617 		    as = FFEGLOBAL_argsummaryREF;
8618 		  break;
8619 		}
8620 	    }
8621 	  else
8622 	    {
8623 	      array = FALSE;
8624 	      as = FFEGLOBAL_argsummaryNONE;
8625 	      bt = FFEINFO_basictypeNONE;
8626 	      kt = FFEINFO_kindtypeNONE;
8627 	    }
8628 
8629 	  if (! ffeglobal_proc_ref_arg (s, n_args, as, bt, kt, array, t))
8630 	    fail = TRUE;
8631 	}
8632       if (! fail)
8633 	return;
8634     }
8635 
8636   *expr = ffebld_new_any ();
8637   ffebld_set_info (*expr, ffeinfo_new_any ());
8638 }
8639 
8640 /* Check whether rest of string is all decimal digits.  */
8641 
8642 static bool
ffeexpr_isdigits_(const char * p)8643 ffeexpr_isdigits_ (const char *p)
8644 {
8645   for (; *p != '\0'; ++p)
8646     if (! ISDIGIT (*p))
8647       return FALSE;
8648   return TRUE;
8649 }
8650 
8651 /* ffeexpr_exprstack_push_ -- Push an arbitrary expression object onto the stack
8652 
8653    ffeexprExpr_ e;
8654    ffeexpr_exprstack_push_(e);
8655 
8656    Pushes the expression onto the stack without any analysis of the existing
8657    contents of the stack.  */
8658 
8659 static void
ffeexpr_exprstack_push_(ffeexprExpr_ e)8660 ffeexpr_exprstack_push_ (ffeexprExpr_ e)
8661 {
8662   e->previous = ffeexpr_stack_->exprstack;
8663   ffeexpr_stack_->exprstack = e;
8664 }
8665 
8666 /* ffeexpr_exprstack_push_operand_ -- Push an operand onto the stack, reduce?
8667 
8668    ffeexprExpr_ e;
8669    ffeexpr_exprstack_push_operand_(e);
8670 
8671    Pushes the expression already containing an operand (a constant, variable,
8672    or more complicated expression that has already been fully resolved) after
8673    analyzing the stack and checking for possible reduction (which will never
8674    happen here since the highest precedence operator is ** and it has right-
8675    to-left associativity).  */
8676 
8677 static void
ffeexpr_exprstack_push_operand_(ffeexprExpr_ e)8678 ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e)
8679 {
8680   ffeexpr_exprstack_push_ (e);
8681 }
8682 
8683 /* ffeexpr_exprstack_push_unary_ -- Push a unary operator onto the stack
8684 
8685    ffeexprExpr_ e;
8686    ffeexpr_exprstack_push_unary_(e);
8687 
8688    Pushes the expression already containing a unary operator.  Reduction can
8689    never happen since unary operators are themselves always R-L; that is, the
8690    top of the expression stack is not an operand, in that it is either empty,
8691    has a binary operator at the top, or a unary operator at the top.  In any
8692    of these cases, reduction is impossible.  */
8693 
8694 static void
ffeexpr_exprstack_push_unary_(ffeexprExpr_ e)8695 ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e)
8696 {
8697   if ((ffe_is_pedantic ()
8698        || ffe_is_warn_surprising ())
8699       && (ffeexpr_stack_->exprstack != NULL)
8700       && (ffeexpr_stack_->exprstack->type != FFEEXPR_exprtypeOPERAND_)
8701       && (ffeexpr_stack_->exprstack->u.operator.prec
8702 	  <= FFEEXPR_operatorprecedenceLOWARITH_)
8703       && (e->u.operator.prec <= FFEEXPR_operatorprecedenceLOWARITH_))
8704     {
8705       /* xgettext:no-c-format */
8706       ffebad_start_msg ("Two arithmetic operators in a row at %0 and %1 -- use parentheses",
8707 			ffe_is_pedantic ()
8708 			? FFEBAD_severityPEDANTIC
8709 			: FFEBAD_severityWARNING);
8710       ffebad_here (0,
8711 		  ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
8712 	       ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
8713       ffebad_here (1,
8714 		   ffelex_token_where_line (e->token),
8715 		   ffelex_token_where_column (e->token));
8716       ffebad_finish ();
8717     }
8718 
8719   ffeexpr_exprstack_push_ (e);
8720 }
8721 
8722 /* ffeexpr_exprstack_push_binary_ -- Push a binary operator onto the stack, reduce?
8723 
8724    ffeexprExpr_ e;
8725    ffeexpr_exprstack_push_binary_(e);
8726 
8727    Pushes the expression already containing a binary operator after checking
8728    whether reduction is possible.  If the stack is not empty, the top of the
8729    stack must be an operand or syntactic analysis has failed somehow.  If
8730    the operand is preceded by a unary operator of higher (or equal and L-R
8731    associativity) precedence than the new binary operator, then reduce that
8732    preceding operator and its operand(s) before pushing the new binary
8733    operator.  */
8734 
8735 static void
ffeexpr_exprstack_push_binary_(ffeexprExpr_ e)8736 ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e)
8737 {
8738   ffeexprExpr_ ce;
8739 
8740   if (ffe_is_warn_surprising ()
8741       /* These next two are always true (see assertions below).  */
8742       && (ffeexpr_stack_->exprstack != NULL)
8743       && (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_)
8744       /* If the previous operator is a unary minus, and the binary op
8745 	 is of higher precedence, might not do what user expects,
8746 	 e.g. "-2**2" is "-(2**2)", i.e. "-4", not "(-2)**2", which would
8747 	 yield "4".  */
8748       && (ffeexpr_stack_->exprstack->previous != NULL)
8749       && (ffeexpr_stack_->exprstack->previous->type == FFEEXPR_exprtypeUNARY_)
8750       && (ffeexpr_stack_->exprstack->previous->u.operator.op
8751 	  == FFEEXPR_operatorSUBTRACT_)
8752       && (e->u.operator.prec
8753 	  < ffeexpr_stack_->exprstack->previous->u.operator.prec))
8754     {
8755       /* xgettext:no-c-format */
8756       ffebad_start_msg ("Operator at %0 has lower precedence than that at %1 -- use parentheses", FFEBAD_severityWARNING);
8757       ffebad_here (0,
8758 	 ffelex_token_where_line (ffeexpr_stack_->exprstack->previous->token),
8759       ffelex_token_where_column (ffeexpr_stack_->exprstack->previous->token));
8760       ffebad_here (1,
8761 		   ffelex_token_where_line (e->token),
8762 		   ffelex_token_where_column (e->token));
8763       ffebad_finish ();
8764     }
8765 
8766 again:
8767   assert (ffeexpr_stack_->exprstack != NULL);
8768   assert (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_);
8769   if ((ce = ffeexpr_stack_->exprstack->previous) != NULL)
8770     {
8771       assert (ce->type != FFEEXPR_exprtypeOPERAND_);
8772       if ((ce->u.operator.prec < e->u.operator.prec)
8773 	  || ((ce->u.operator.prec == e->u.operator.prec)
8774 	      && (e->u.operator.as == FFEEXPR_operatorassociativityL2R_)))
8775 	{
8776 	  ffeexpr_reduce_ ();
8777 	  goto again;	/* :::::::::::::::::::: */
8778 	}
8779     }
8780 
8781   ffeexpr_exprstack_push_ (e);
8782 }
8783 
8784 /* ffeexpr_reduce_ -- Reduce highest operator w/operands on stack
8785 
8786    ffeexpr_reduce_();
8787 
8788    Converts operand binop operand or unop operand at top of stack to a
8789    single operand having the appropriate ffebld expression, and makes
8790    sure that the expression is proper (like not trying to add two character
8791    variables, not trying to concatenate two numbers).  Also does the
8792    requisite type-assignment.  */
8793 
8794 static void
ffeexpr_reduce_(void)8795 ffeexpr_reduce_ (void)
8796 {
8797   ffeexprExpr_ operand;		/* This is B in -B or A+B. */
8798   ffeexprExpr_ left_operand;	/* When operator is binary, this is A in A+B. */
8799   ffeexprExpr_ operator;	/* This is + in A+B. */
8800   ffebld reduced;		/* This is +(A,B) in A+B or u-(B) in -B. */
8801   ffebldConstant constnode;	/* For checking magical numbers (where mag ==
8802 				   -mag). */
8803   ffebld expr;
8804   ffebld left_expr;
8805   bool submag = FALSE;
8806   bool bothlogical;
8807 
8808   operand = ffeexpr_stack_->exprstack;
8809   assert (operand != NULL);
8810   assert (operand->type == FFEEXPR_exprtypeOPERAND_);
8811   operator = operand->previous;
8812   assert (operator != NULL);
8813   assert (operator->type != FFEEXPR_exprtypeOPERAND_);
8814   if (operator->type == FFEEXPR_exprtypeUNARY_)
8815     {
8816       expr = operand->u.operand;
8817       switch (operator->u.operator.op)
8818 	{
8819 	case FFEEXPR_operatorADD_:
8820 	  reduced = ffebld_new_uplus (expr);
8821 	  if (ffe_is_ugly_logint ())
8822 	    reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
8823 	  reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
8824 	  reduced = ffeexpr_collapse_uplus (reduced, operator->token);
8825 	  break;
8826 
8827 	case FFEEXPR_operatorSUBTRACT_:
8828 	  submag = TRUE;	/* Ok to negate a magic number. */
8829 	  reduced = ffebld_new_uminus (expr);
8830 	  if (ffe_is_ugly_logint ())
8831 	    reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
8832 	  reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
8833 	  reduced = ffeexpr_collapse_uminus (reduced, operator->token);
8834 	  break;
8835 
8836 	case FFEEXPR_operatorNOT_:
8837 	  reduced = ffebld_new_not (expr);
8838 	  if (ffe_is_ugly_logint ())
8839 	    reduced = ffeexpr_reduced_ugly1log_ (reduced, operator, operand);
8840 	  reduced = ffeexpr_reduced_bool1_ (reduced, operator, operand);
8841 	  reduced = ffeexpr_collapse_not (reduced, operator->token);
8842 	  break;
8843 
8844 	default:
8845 	  assert ("unexpected unary op" != NULL);
8846 	  reduced = NULL;
8847 	  break;
8848 	}
8849       if (!submag
8850 	  && (ffebld_op (expr) == FFEBLD_opCONTER)
8851 	  && (ffebld_conter_orig (expr) == NULL)
8852 	  && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
8853 	{
8854 	  ffetarget_integer_bad_magical (operand->token);
8855 	}
8856       ffeexpr_stack_->exprstack = operator->previous;	/* Pops unary-op operand
8857 							   off stack. */
8858       ffeexpr_expr_kill_ (operand);
8859       operator->type = FFEEXPR_exprtypeOPERAND_;	/* Convert operator, but
8860 							   save */
8861       operator->u.operand = reduced;	/* the line/column ffewhere info. */
8862       ffeexpr_exprstack_push_operand_ (operator);	/* Push it back on
8863 							   stack. */
8864     }
8865   else
8866     {
8867       assert (operator->type == FFEEXPR_exprtypeBINARY_);
8868       left_operand = operator->previous;
8869       assert (left_operand != NULL);
8870       assert (left_operand->type == FFEEXPR_exprtypeOPERAND_);
8871       expr = operand->u.operand;
8872       left_expr = left_operand->u.operand;
8873       switch (operator->u.operator.op)
8874 	{
8875 	case FFEEXPR_operatorADD_:
8876 	  reduced = ffebld_new_add (left_expr, expr);
8877 	  if (ffe_is_ugly_logint ())
8878 	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8879 					      operand);
8880 	  reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
8881 					    operand);
8882 	  reduced = ffeexpr_collapse_add (reduced, operator->token);
8883 	  break;
8884 
8885 	case FFEEXPR_operatorSUBTRACT_:
8886 	  submag = TRUE;	/* Just to pick the right error if magic
8887 				   number. */
8888 	  reduced = ffebld_new_subtract (left_expr, expr);
8889 	  if (ffe_is_ugly_logint ())
8890 	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8891 					      operand);
8892 	  reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
8893 					    operand);
8894 	  reduced = ffeexpr_collapse_subtract (reduced, operator->token);
8895 	  break;
8896 
8897 	case FFEEXPR_operatorMULTIPLY_:
8898 	  reduced = ffebld_new_multiply (left_expr, expr);
8899 	  if (ffe_is_ugly_logint ())
8900 	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8901 					      operand);
8902 	  reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
8903 					    operand);
8904 	  reduced = ffeexpr_collapse_multiply (reduced, operator->token);
8905 	  break;
8906 
8907 	case FFEEXPR_operatorDIVIDE_:
8908 	  reduced = ffebld_new_divide (left_expr, expr);
8909 	  if (ffe_is_ugly_logint ())
8910 	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8911 					      operand);
8912 	  reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
8913 					    operand);
8914 	  reduced = ffeexpr_collapse_divide (reduced, operator->token);
8915 	  break;
8916 
8917 	case FFEEXPR_operatorPOWER_:
8918 	  reduced = ffebld_new_power (left_expr, expr);
8919 	  if (ffe_is_ugly_logint ())
8920 	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8921 					      operand);
8922 	  reduced = ffeexpr_reduced_power_ (reduced, left_operand, operator,
8923 					    operand);
8924 	  reduced = ffeexpr_collapse_power (reduced, operator->token);
8925 	  break;
8926 
8927 	case FFEEXPR_operatorCONCATENATE_:
8928 	  reduced = ffebld_new_concatenate (left_expr, expr);
8929 	  reduced = ffeexpr_reduced_concatenate_ (reduced, left_operand, operator,
8930 						  operand);
8931 	  reduced = ffeexpr_collapse_concatenate (reduced, operator->token);
8932 	  break;
8933 
8934 	case FFEEXPR_operatorLT_:
8935 	  reduced = ffebld_new_lt (left_expr, expr);
8936 	  if (ffe_is_ugly_logint ())
8937 	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8938 					      operand);
8939 	  reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
8940 					     operand);
8941 	  reduced = ffeexpr_collapse_lt (reduced, operator->token);
8942 	  break;
8943 
8944 	case FFEEXPR_operatorLE_:
8945 	  reduced = ffebld_new_le (left_expr, expr);
8946 	  if (ffe_is_ugly_logint ())
8947 	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8948 					      operand);
8949 	  reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
8950 					     operand);
8951 	  reduced = ffeexpr_collapse_le (reduced, operator->token);
8952 	  break;
8953 
8954 	case FFEEXPR_operatorEQ_:
8955 	  reduced = ffebld_new_eq (left_expr, expr);
8956 	  if (ffe_is_ugly_logint ())
8957 	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8958 					      operand);
8959 	  reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
8960 					    operand);
8961 	  reduced = ffeexpr_collapse_eq (reduced, operator->token);
8962 	  break;
8963 
8964 	case FFEEXPR_operatorNE_:
8965 	  reduced = ffebld_new_ne (left_expr, expr);
8966 	  if (ffe_is_ugly_logint ())
8967 	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8968 					      operand);
8969 	  reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
8970 					    operand);
8971 	  reduced = ffeexpr_collapse_ne (reduced, operator->token);
8972 	  break;
8973 
8974 	case FFEEXPR_operatorGT_:
8975 	  reduced = ffebld_new_gt (left_expr, expr);
8976 	  if (ffe_is_ugly_logint ())
8977 	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8978 					      operand);
8979 	  reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
8980 					     operand);
8981 	  reduced = ffeexpr_collapse_gt (reduced, operator->token);
8982 	  break;
8983 
8984 	case FFEEXPR_operatorGE_:
8985 	  reduced = ffebld_new_ge (left_expr, expr);
8986 	  if (ffe_is_ugly_logint ())
8987 	    reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8988 					      operand);
8989 	  reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
8990 					     operand);
8991 	  reduced = ffeexpr_collapse_ge (reduced, operator->token);
8992 	  break;
8993 
8994 	case FFEEXPR_operatorAND_:
8995 	  reduced = ffebld_new_and (left_expr, expr);
8996 	  if (ffe_is_ugly_logint ())
8997 	    reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
8998 						 operand, &bothlogical);
8999 	  reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9000 					    operand);
9001 	  reduced = ffeexpr_collapse_and (reduced, operator->token);
9002 	  if (ffe_is_ugly_logint() && bothlogical)
9003 	    reduced = ffeexpr_convert (reduced, left_operand->token,
9004 				       operator->token,
9005 				       FFEINFO_basictypeLOGICAL,
9006 				       FFEINFO_kindtypeLOGICALDEFAULT, 0,
9007 				       FFETARGET_charactersizeNONE,
9008 				       FFEEXPR_contextLET);
9009 	  break;
9010 
9011 	case FFEEXPR_operatorOR_:
9012 	  reduced = ffebld_new_or (left_expr, expr);
9013 	  if (ffe_is_ugly_logint ())
9014 	    reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9015 						 operand, &bothlogical);
9016 	  reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9017 					    operand);
9018 	  reduced = ffeexpr_collapse_or (reduced, operator->token);
9019 	  if (ffe_is_ugly_logint() && bothlogical)
9020 	    reduced = ffeexpr_convert (reduced, left_operand->token,
9021 				       operator->token,
9022 				       FFEINFO_basictypeLOGICAL,
9023 				       FFEINFO_kindtypeLOGICALDEFAULT, 0,
9024 				       FFETARGET_charactersizeNONE,
9025 				       FFEEXPR_contextLET);
9026 	  break;
9027 
9028 	case FFEEXPR_operatorXOR_:
9029 	  reduced = ffebld_new_xor (left_expr, expr);
9030 	  if (ffe_is_ugly_logint ())
9031 	    reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9032 						 operand, &bothlogical);
9033 	  reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9034 					    operand);
9035 	  reduced = ffeexpr_collapse_xor (reduced, operator->token);
9036 	  if (ffe_is_ugly_logint() && bothlogical)
9037 	    reduced = ffeexpr_convert (reduced, left_operand->token,
9038 				       operator->token,
9039 				       FFEINFO_basictypeLOGICAL,
9040 				       FFEINFO_kindtypeLOGICALDEFAULT, 0,
9041 				       FFETARGET_charactersizeNONE,
9042 				       FFEEXPR_contextLET);
9043 	  break;
9044 
9045 	case FFEEXPR_operatorEQV_:
9046 	  reduced = ffebld_new_eqv (left_expr, expr);
9047 	  if (ffe_is_ugly_logint ())
9048 	    reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9049 						 operand, NULL);
9050 	  reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9051 					    operand);
9052 	  reduced = ffeexpr_collapse_eqv (reduced, operator->token);
9053 	  break;
9054 
9055 	case FFEEXPR_operatorNEQV_:
9056 	  reduced = ffebld_new_neqv (left_expr, expr);
9057 	  if (ffe_is_ugly_logint ())
9058 	    reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9059 						 operand, NULL);
9060 	  reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9061 					    operand);
9062 	  reduced = ffeexpr_collapse_neqv (reduced, operator->token);
9063 	  break;
9064 
9065 	default:
9066 	  assert ("bad bin op" == NULL);
9067 	  reduced = expr;
9068 	  break;
9069 	}
9070       if ((ffebld_op (left_expr) == FFEBLD_opCONTER)
9071 	  && (ffebld_conter_orig (expr) == NULL)
9072       && ffebld_constant_is_magical (constnode = ffebld_conter (left_expr)))
9073 	{
9074 	  if ((left_operand->previous != NULL)
9075 	      && (left_operand->previous->type != FFEEXPR_exprtypeOPERAND_)
9076 	      && (left_operand->previous->u.operator.op
9077 		  == FFEEXPR_operatorSUBTRACT_))
9078 	    {
9079 	      if (left_operand->previous->type == FFEEXPR_exprtypeUNARY_)
9080 		ffetarget_integer_bad_magical_precedence (left_operand->token,
9081 							  left_operand->previous->token,
9082 							  operator->token);
9083 	      else
9084 		ffetarget_integer_bad_magical_precedence_binary
9085 		  (left_operand->token,
9086 		   left_operand->previous->token,
9087 		   operator->token);
9088 	    }
9089 	  else
9090 	    ffetarget_integer_bad_magical (left_operand->token);
9091 	}
9092       if ((ffebld_op (expr) == FFEBLD_opCONTER)
9093 	  && (ffebld_conter_orig (expr) == NULL)
9094 	  && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
9095 	{
9096 	  if (submag)
9097 	    ffetarget_integer_bad_magical_binary (operand->token,
9098 						  operator->token);
9099 	  else
9100 	    ffetarget_integer_bad_magical (operand->token);
9101 	}
9102       ffeexpr_stack_->exprstack = left_operand->previous;	/* Pops binary-op
9103 								   operands off stack. */
9104       ffeexpr_expr_kill_ (left_operand);
9105       ffeexpr_expr_kill_ (operand);
9106       operator->type = FFEEXPR_exprtypeOPERAND_;	/* Convert operator, but
9107 							   save */
9108       operator->u.operand = reduced;	/* the line/column ffewhere info. */
9109       ffeexpr_exprstack_push_operand_ (operator);	/* Push it back on
9110 							   stack. */
9111     }
9112 }
9113 
9114 /* ffeexpr_reduced_bool1_ -- Wrap up reduction of NOT operator
9115 
9116    reduced = ffeexpr_reduced_bool1_(reduced,op,r);
9117 
9118    Makes sure the argument for reduced has basictype of
9119    LOGICAL or (ugly) INTEGER.  If
9120    argument has where of CONSTANT, assign where CONSTANT to
9121    reduced, else assign where FLEETING.
9122 
9123    If these requirements cannot be met, generate error message.	 */
9124 
9125 static ffebld
ffeexpr_reduced_bool1_(ffebld reduced,ffeexprExpr_ op,ffeexprExpr_ r)9126 ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
9127 {
9128   ffeinfo rinfo, ninfo;
9129   ffeinfoBasictype rbt;
9130   ffeinfoKindtype rkt;
9131   ffeinfoRank rrk;
9132   ffeinfoKind rkd;
9133   ffeinfoWhere rwh, nwh;
9134 
9135   rinfo = ffebld_info (ffebld_left (reduced));
9136   rbt = ffeinfo_basictype (rinfo);
9137   rkt = ffeinfo_kindtype (rinfo);
9138   rrk = ffeinfo_rank (rinfo);
9139   rkd = ffeinfo_kind (rinfo);
9140   rwh = ffeinfo_where (rinfo);
9141 
9142   if (((rbt == FFEINFO_basictypeLOGICAL)
9143        || (ffe_is_ugly_logint () && (rbt == FFEINFO_basictypeINTEGER)))
9144       && (rrk == 0))
9145     {
9146       switch (rwh)
9147 	{
9148 	case FFEINFO_whereCONSTANT:
9149 	  nwh = FFEINFO_whereCONSTANT;
9150 	  break;
9151 
9152 	case FFEINFO_whereIMMEDIATE:
9153 	  nwh = FFEINFO_whereIMMEDIATE;
9154 	  break;
9155 
9156 	default:
9157 	  nwh = FFEINFO_whereFLEETING;
9158 	  break;
9159 	}
9160 
9161       ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
9162 			   FFETARGET_charactersizeNONE);
9163       ffebld_set_info (reduced, ninfo);
9164       return reduced;
9165     }
9166 
9167   if ((rbt != FFEINFO_basictypeLOGICAL)
9168       && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
9169     {
9170       if ((rbt != FFEINFO_basictypeANY)
9171 	  && ffebad_start (FFEBAD_NOT_ARG_TYPE))
9172 	{
9173 	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9174 	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9175 	  ffebad_finish ();
9176 	}
9177     }
9178   else
9179     {
9180       if ((rkd != FFEINFO_kindANY)
9181 	  && ffebad_start (FFEBAD_NOT_ARG_KIND))
9182 	{
9183 	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9184 	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9185 	  ffebad_string ("an array");
9186 	  ffebad_finish ();
9187 	}
9188     }
9189 
9190   reduced = ffebld_new_any ();
9191   ffebld_set_info (reduced, ffeinfo_new_any ());
9192   return reduced;
9193 }
9194 
9195 /* ffeexpr_reduced_bool2_ -- Wrap up reduction of boolean operators
9196 
9197    reduced = ffeexpr_reduced_bool2_(reduced,l,op,r);
9198 
9199    Makes sure the left and right arguments for reduced have basictype of
9200    LOGICAL or (ugly) INTEGER.  Determine common basictype and
9201    size for reduction (flag expression for combined hollerith/typeless
9202    situations for later determination of effective basictype).	If both left
9203    and right arguments have where of CONSTANT, assign where CONSTANT to
9204    reduced, else assign where FLEETING.	 Create CONVERT ops for args where
9205    needed.  Convert typeless
9206    constants to the desired type/size explicitly.
9207 
9208    If these requirements cannot be met, generate error message.	 */
9209 
9210 static ffebld
ffeexpr_reduced_bool2_(ffebld reduced,ffeexprExpr_ l,ffeexprExpr_ op,ffeexprExpr_ r)9211 ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9212 			ffeexprExpr_ r)
9213 {
9214   ffeinfo linfo, rinfo, ninfo;
9215   ffeinfoBasictype lbt, rbt, nbt;
9216   ffeinfoKindtype lkt, rkt, nkt;
9217   ffeinfoRank lrk, rrk;
9218   ffeinfoKind lkd, rkd;
9219   ffeinfoWhere lwh, rwh, nwh;
9220 
9221   linfo = ffebld_info (ffebld_left (reduced));
9222   lbt = ffeinfo_basictype (linfo);
9223   lkt = ffeinfo_kindtype (linfo);
9224   lrk = ffeinfo_rank (linfo);
9225   lkd = ffeinfo_kind (linfo);
9226   lwh = ffeinfo_where (linfo);
9227 
9228   rinfo = ffebld_info (ffebld_right (reduced));
9229   rbt = ffeinfo_basictype (rinfo);
9230   rkt = ffeinfo_kindtype (rinfo);
9231   rrk = ffeinfo_rank (rinfo);
9232   rkd = ffeinfo_kind (rinfo);
9233   rwh = ffeinfo_where (rinfo);
9234 
9235   ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
9236 
9237   if (((nbt == FFEINFO_basictypeLOGICAL)
9238        || (ffe_is_ugly_logint () && (nbt == FFEINFO_basictypeINTEGER)))
9239       && (lrk == 0) && (rrk == 0))
9240     {
9241       switch (lwh)
9242 	{
9243 	case FFEINFO_whereCONSTANT:
9244 	  switch (rwh)
9245 	    {
9246 	    case FFEINFO_whereCONSTANT:
9247 	      nwh = FFEINFO_whereCONSTANT;
9248 	      break;
9249 
9250 	    case FFEINFO_whereIMMEDIATE:
9251 	      nwh = FFEINFO_whereIMMEDIATE;
9252 	      break;
9253 
9254 	    default:
9255 	      nwh = FFEINFO_whereFLEETING;
9256 	      break;
9257 	    }
9258 	  break;
9259 
9260 	case FFEINFO_whereIMMEDIATE:
9261 	  switch (rwh)
9262 	    {
9263 	    case FFEINFO_whereCONSTANT:
9264 	    case FFEINFO_whereIMMEDIATE:
9265 	      nwh = FFEINFO_whereIMMEDIATE;
9266 	      break;
9267 
9268 	    default:
9269 	      nwh = FFEINFO_whereFLEETING;
9270 	      break;
9271 	    }
9272 	  break;
9273 
9274 	default:
9275 	  nwh = FFEINFO_whereFLEETING;
9276 	  break;
9277 	}
9278 
9279       ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
9280 			   FFETARGET_charactersizeNONE);
9281       ffebld_set_info (reduced, ninfo);
9282       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
9283 	      l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
9284 						 FFEEXPR_contextLET));
9285       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
9286 	      r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
9287 						  FFEEXPR_contextLET));
9288       return reduced;
9289     }
9290 
9291   if ((lbt != FFEINFO_basictypeLOGICAL)
9292       && (!ffe_is_ugly_logint () || (lbt != FFEINFO_basictypeINTEGER)))
9293     {
9294       if ((rbt != FFEINFO_basictypeLOGICAL)
9295 	  && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
9296 	{
9297 	  if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
9298 	      && ffebad_start (FFEBAD_BOOL_ARGS_TYPE))
9299 	    {
9300 	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9301 	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9302 	      ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9303 	      ffebad_finish ();
9304 	    }
9305 	}
9306       else
9307 	{
9308 	  if ((lbt != FFEINFO_basictypeANY)
9309 	      && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
9310 	    {
9311 	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9312 	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9313 	      ffebad_finish ();
9314 	    }
9315 	}
9316     }
9317   else if ((rbt != FFEINFO_basictypeLOGICAL)
9318 	   && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
9319     {
9320       if ((rbt != FFEINFO_basictypeANY)
9321 	  && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
9322 	{
9323 	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9324 	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9325 	  ffebad_finish ();
9326 	}
9327     }
9328   else if (lrk != 0)
9329     {
9330       if ((lkd != FFEINFO_kindANY)
9331 	  && ffebad_start (FFEBAD_BOOL_ARG_KIND))
9332 	{
9333 	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9334 	  ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9335 	  ffebad_string ("an array");
9336 	  ffebad_finish ();
9337 	}
9338     }
9339   else
9340     {
9341       if ((rkd != FFEINFO_kindANY)
9342 	  && ffebad_start (FFEBAD_BOOL_ARG_KIND))
9343 	{
9344 	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9345 	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9346 	  ffebad_string ("an array");
9347 	  ffebad_finish ();
9348 	}
9349     }
9350 
9351   reduced = ffebld_new_any ();
9352   ffebld_set_info (reduced, ffeinfo_new_any ());
9353   return reduced;
9354 }
9355 
9356 /* ffeexpr_reduced_concatenate_ -- Wrap up reduction of concatenate operator
9357 
9358    reduced = ffeexpr_reduced_concatenate_(reduced,l,op,r);
9359 
9360    Makes sure the left and right arguments for reduced have basictype of
9361    CHARACTER and kind of SCALAR, FUNCTION, or STATEMENT FUNCTION.  Assign
9362    basictype of CHARACTER and kind of SCALAR to reduced.  Calculate effective
9363    size of concatenation and assign that size to reduced.  If both left and
9364    right arguments have where of CONSTANT, assign where CONSTANT to reduced,
9365    else assign where FLEETING.
9366 
9367    If these requirements cannot be met, generate error message using the
9368    info in l, op, and r arguments and assign basictype, size, kind, and where
9369    of ANY.  */
9370 
9371 static ffebld
ffeexpr_reduced_concatenate_(ffebld reduced,ffeexprExpr_ l,ffeexprExpr_ op,ffeexprExpr_ r)9372 ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9373 			      ffeexprExpr_ r)
9374 {
9375   ffeinfo linfo, rinfo, ninfo;
9376   ffeinfoBasictype lbt, rbt, nbt;
9377   ffeinfoKindtype lkt, rkt, nkt;
9378   ffeinfoRank lrk, rrk;
9379   ffeinfoKind lkd, rkd, nkd;
9380   ffeinfoWhere lwh, rwh, nwh;
9381   ffetargetCharacterSize lszm, lszk, rszm, rszk, nszk;
9382 
9383   linfo = ffebld_info (ffebld_left (reduced));
9384   lbt = ffeinfo_basictype (linfo);
9385   lkt = ffeinfo_kindtype (linfo);
9386   lrk = ffeinfo_rank (linfo);
9387   lkd = ffeinfo_kind (linfo);
9388   lwh = ffeinfo_where (linfo);
9389   lszk = ffeinfo_size (linfo);	/* Known size. */
9390   lszm = ffebld_size_max (ffebld_left (reduced));
9391 
9392   rinfo = ffebld_info (ffebld_right (reduced));
9393   rbt = ffeinfo_basictype (rinfo);
9394   rkt = ffeinfo_kindtype (rinfo);
9395   rrk = ffeinfo_rank (rinfo);
9396   rkd = ffeinfo_kind (rinfo);
9397   rwh = ffeinfo_where (rinfo);
9398   rszk = ffeinfo_size (rinfo);	/* Known size. */
9399   rszm = ffebld_size_max (ffebld_right (reduced));
9400 
9401   if ((lbt == FFEINFO_basictypeCHARACTER) && (rbt == FFEINFO_basictypeCHARACTER)
9402       && (lkt == rkt) && (lrk == 0) && (rrk == 0)
9403       && (((lszm != FFETARGET_charactersizeNONE)
9404 	   && (rszm != FFETARGET_charactersizeNONE))
9405 	  || (ffeexpr_context_outer_ (ffeexpr_stack_)
9406 	      == FFEEXPR_contextLET)
9407 	  || (ffeexpr_context_outer_ (ffeexpr_stack_)
9408 	      == FFEEXPR_contextSFUNCDEF)))
9409     {
9410       nbt = FFEINFO_basictypeCHARACTER;
9411       nkd = FFEINFO_kindENTITY;
9412       if ((lszk == FFETARGET_charactersizeNONE)
9413 	  || (rszk == FFETARGET_charactersizeNONE))
9414 	nszk = FFETARGET_charactersizeNONE;	/* Ok only in rhs of LET
9415 						   stmt. */
9416       else
9417 	nszk = lszk + rszk;
9418 
9419       switch (lwh)
9420 	{
9421 	case FFEINFO_whereCONSTANT:
9422 	  switch (rwh)
9423 	    {
9424 	    case FFEINFO_whereCONSTANT:
9425 	      nwh = FFEINFO_whereCONSTANT;
9426 	      break;
9427 
9428 	    case FFEINFO_whereIMMEDIATE:
9429 	      nwh = FFEINFO_whereIMMEDIATE;
9430 	      break;
9431 
9432 	    default:
9433 	      nwh = FFEINFO_whereFLEETING;
9434 	      break;
9435 	    }
9436 	  break;
9437 
9438 	case FFEINFO_whereIMMEDIATE:
9439 	  switch (rwh)
9440 	    {
9441 	    case FFEINFO_whereCONSTANT:
9442 	    case FFEINFO_whereIMMEDIATE:
9443 	      nwh = FFEINFO_whereIMMEDIATE;
9444 	      break;
9445 
9446 	    default:
9447 	      nwh = FFEINFO_whereFLEETING;
9448 	      break;
9449 	    }
9450 	  break;
9451 
9452 	default:
9453 	  nwh = FFEINFO_whereFLEETING;
9454 	  break;
9455 	}
9456 
9457       nkt = lkt;
9458       ninfo = ffeinfo_new (nbt, nkt, 0, nkd, nwh, nszk);
9459       ffebld_set_info (reduced, ninfo);
9460       return reduced;
9461     }
9462 
9463   if ((lbt != FFEINFO_basictypeCHARACTER) && (rbt != FFEINFO_basictypeCHARACTER))
9464     {
9465       if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
9466 	  && ffebad_start (FFEBAD_CONCAT_ARGS_TYPE))
9467 	{
9468 	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9469 	  ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9470 	  ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9471 	  ffebad_finish ();
9472 	}
9473     }
9474   else if (lbt != FFEINFO_basictypeCHARACTER)
9475     {
9476       if ((lbt != FFEINFO_basictypeANY)
9477 	  && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
9478 	{
9479 	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9480 	  ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9481 	  ffebad_finish ();
9482 	}
9483     }
9484   else if (rbt != FFEINFO_basictypeCHARACTER)
9485     {
9486       if ((rbt != FFEINFO_basictypeANY)
9487 	  && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
9488 	{
9489 	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9490 	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9491 	  ffebad_finish ();
9492 	}
9493     }
9494   else if ((lrk != 0) || (lszm == FFETARGET_charactersizeNONE))
9495     {
9496       if ((lkd != FFEINFO_kindANY)
9497 	  && ffebad_start (FFEBAD_CONCAT_ARG_KIND))
9498 	{
9499 	  const char *what;
9500 
9501 	  if (lrk != 0)
9502 	    what = "an array";
9503 	  else
9504 	    what = "of indeterminate length";
9505 	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9506 	  ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9507 	  ffebad_string (what);
9508 	  ffebad_finish ();
9509 	}
9510     }
9511   else
9512     {
9513       if (ffebad_start (FFEBAD_CONCAT_ARG_KIND))
9514 	{
9515 	  const char *what;
9516 
9517 	  if (rrk != 0)
9518 	    what = "an array";
9519 	  else
9520 	    what = "of indeterminate length";
9521 	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9522 	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9523 	  ffebad_string (what);
9524 	  ffebad_finish ();
9525 	}
9526     }
9527 
9528   reduced = ffebld_new_any ();
9529   ffebld_set_info (reduced, ffeinfo_new_any ());
9530   return reduced;
9531 }
9532 
9533 /* ffeexpr_reduced_eqop2_ -- Wrap up reduction of EQ and NE operators
9534 
9535    reduced = ffeexpr_reduced_eqop2_(reduced,l,op,r);
9536 
9537    Makes sure the left and right arguments for reduced have basictype of
9538    INTEGER, REAL, COMPLEX, or CHARACTER.  Determine common basictype and
9539    size for reduction.	If both left
9540    and right arguments have where of CONSTANT, assign where CONSTANT to
9541    reduced, else assign where FLEETING.	 Create CONVERT ops for args where
9542    needed.  Convert typeless
9543    constants to the desired type/size explicitly.
9544 
9545    If these requirements cannot be met, generate error message.	 */
9546 
9547 static ffebld
ffeexpr_reduced_eqop2_(ffebld reduced,ffeexprExpr_ l,ffeexprExpr_ op,ffeexprExpr_ r)9548 ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9549 			ffeexprExpr_ r)
9550 {
9551   ffeinfo linfo, rinfo, ninfo;
9552   ffeinfoBasictype lbt, rbt, nbt;
9553   ffeinfoKindtype lkt, rkt, nkt;
9554   ffeinfoRank lrk, rrk;
9555   ffeinfoKind lkd, rkd;
9556   ffeinfoWhere lwh, rwh, nwh;
9557   ffetargetCharacterSize lsz, rsz;
9558 
9559   linfo = ffebld_info (ffebld_left (reduced));
9560   lbt = ffeinfo_basictype (linfo);
9561   lkt = ffeinfo_kindtype (linfo);
9562   lrk = ffeinfo_rank (linfo);
9563   lkd = ffeinfo_kind (linfo);
9564   lwh = ffeinfo_where (linfo);
9565   lsz = ffebld_size_known (ffebld_left (reduced));
9566 
9567   rinfo = ffebld_info (ffebld_right (reduced));
9568   rbt = ffeinfo_basictype (rinfo);
9569   rkt = ffeinfo_kindtype (rinfo);
9570   rrk = ffeinfo_rank (rinfo);
9571   rkd = ffeinfo_kind (rinfo);
9572   rwh = ffeinfo_where (rinfo);
9573   rsz = ffebld_size_known (ffebld_right (reduced));
9574 
9575   ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
9576 
9577   if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
9578        || (nbt == FFEINFO_basictypeCOMPLEX) || (nbt == FFEINFO_basictypeCHARACTER))
9579       && (lrk == 0) && (rrk == 0))
9580     {
9581       switch (lwh)
9582 	{
9583 	case FFEINFO_whereCONSTANT:
9584 	  switch (rwh)
9585 	    {
9586 	    case FFEINFO_whereCONSTANT:
9587 	      nwh = FFEINFO_whereCONSTANT;
9588 	      break;
9589 
9590 	    case FFEINFO_whereIMMEDIATE:
9591 	      nwh = FFEINFO_whereIMMEDIATE;
9592 	      break;
9593 
9594 	    default:
9595 	      nwh = FFEINFO_whereFLEETING;
9596 	      break;
9597 	    }
9598 	  break;
9599 
9600 	case FFEINFO_whereIMMEDIATE:
9601 	  switch (rwh)
9602 	    {
9603 	    case FFEINFO_whereCONSTANT:
9604 	    case FFEINFO_whereIMMEDIATE:
9605 	      nwh = FFEINFO_whereIMMEDIATE;
9606 	      break;
9607 
9608 	    default:
9609 	      nwh = FFEINFO_whereFLEETING;
9610 	      break;
9611 	    }
9612 	  break;
9613 
9614 	default:
9615 	  nwh = FFEINFO_whereFLEETING;
9616 	  break;
9617 	}
9618 
9619       if ((lsz != FFETARGET_charactersizeNONE)
9620 	  && (rsz != FFETARGET_charactersizeNONE))
9621 	lsz = rsz = (lsz > rsz) ? lsz : rsz;
9622 
9623       ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
9624 		   0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
9625       ffebld_set_info (reduced, ninfo);
9626       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
9627 				      l->token, op->token, nbt, nkt, 0, lsz,
9628 						 FFEEXPR_contextLET));
9629       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
9630 				      r->token, op->token, nbt, nkt, 0, rsz,
9631 						  FFEEXPR_contextLET));
9632       return reduced;
9633     }
9634 
9635   if ((lbt == FFEINFO_basictypeLOGICAL)
9636       && (rbt == FFEINFO_basictypeLOGICAL))
9637     {
9638       /* xgettext:no-c-format */
9639       if (ffebad_start_msg ("Use .EQV./.NEQV. instead of .EQ./.NE. at %0 for LOGICAL operands at %1 and %2",
9640 			    FFEBAD_severityFATAL))
9641 	{
9642 	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9643 	  ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9644 	  ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9645 	  ffebad_finish ();
9646 	}
9647     }
9648   else if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
9649       && (lbt != FFEINFO_basictypeCOMPLEX) && (lbt != FFEINFO_basictypeCHARACTER))
9650     {
9651       if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
9652 	  && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
9653 	{
9654 	  if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
9655 	      && ffebad_start (FFEBAD_EQOP_ARGS_TYPE))
9656 	    {
9657 	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9658 	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9659 	      ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9660 	      ffebad_finish ();
9661 	    }
9662 	}
9663       else
9664 	{
9665 	  if ((lbt != FFEINFO_basictypeANY)
9666 	      && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
9667 	    {
9668 	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9669 	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9670 	      ffebad_finish ();
9671 	    }
9672 	}
9673     }
9674   else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
9675 	   && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
9676     {
9677       if ((rbt != FFEINFO_basictypeANY)
9678 	  && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
9679 	{
9680 	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9681 	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9682 	  ffebad_finish ();
9683 	}
9684     }
9685   else if (lrk != 0)
9686     {
9687       if ((lkd != FFEINFO_kindANY)
9688 	  && ffebad_start (FFEBAD_EQOP_ARG_KIND))
9689 	{
9690 	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9691 	  ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9692 	  ffebad_string ("an array");
9693 	  ffebad_finish ();
9694 	}
9695     }
9696   else
9697     {
9698       if ((rkd != FFEINFO_kindANY)
9699 	  && ffebad_start (FFEBAD_EQOP_ARG_KIND))
9700 	{
9701 	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9702 	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9703 	  ffebad_string ("an array");
9704 	  ffebad_finish ();
9705 	}
9706     }
9707 
9708   reduced = ffebld_new_any ();
9709   ffebld_set_info (reduced, ffeinfo_new_any ());
9710   return reduced;
9711 }
9712 
9713 /* ffeexpr_reduced_math1_ -- Wrap up reduction of + - unary operators
9714 
9715    reduced = ffeexpr_reduced_math1_(reduced,op,r);
9716 
9717    Makes sure the argument for reduced has basictype of
9718    INTEGER, REAL, or COMPLEX.  If the argument has where of CONSTANT,
9719    assign where CONSTANT to
9720    reduced, else assign where FLEETING.
9721 
9722    If these requirements cannot be met, generate error message.	 */
9723 
9724 static ffebld
ffeexpr_reduced_math1_(ffebld reduced,ffeexprExpr_ op,ffeexprExpr_ r)9725 ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
9726 {
9727   ffeinfo rinfo, ninfo;
9728   ffeinfoBasictype rbt;
9729   ffeinfoKindtype rkt;
9730   ffeinfoRank rrk;
9731   ffeinfoKind rkd;
9732   ffeinfoWhere rwh, nwh;
9733 
9734   rinfo = ffebld_info (ffebld_left (reduced));
9735   rbt = ffeinfo_basictype (rinfo);
9736   rkt = ffeinfo_kindtype (rinfo);
9737   rrk = ffeinfo_rank (rinfo);
9738   rkd = ffeinfo_kind (rinfo);
9739   rwh = ffeinfo_where (rinfo);
9740 
9741   if (((rbt == FFEINFO_basictypeINTEGER) || (rbt == FFEINFO_basictypeREAL)
9742        || (rbt == FFEINFO_basictypeCOMPLEX)) && (rrk == 0))
9743     {
9744       switch (rwh)
9745 	{
9746 	case FFEINFO_whereCONSTANT:
9747 	  nwh = FFEINFO_whereCONSTANT;
9748 	  break;
9749 
9750 	case FFEINFO_whereIMMEDIATE:
9751 	  nwh = FFEINFO_whereIMMEDIATE;
9752 	  break;
9753 
9754 	default:
9755 	  nwh = FFEINFO_whereFLEETING;
9756 	  break;
9757 	}
9758 
9759       ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
9760 			   FFETARGET_charactersizeNONE);
9761       ffebld_set_info (reduced, ninfo);
9762       return reduced;
9763     }
9764 
9765   if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
9766       && (rbt != FFEINFO_basictypeCOMPLEX))
9767     {
9768       if ((rbt != FFEINFO_basictypeANY)
9769 	  && ffebad_start (FFEBAD_MATH_ARG_TYPE))
9770 	{
9771 	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9772 	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9773 	  ffebad_finish ();
9774 	}
9775     }
9776   else
9777     {
9778       if ((rkd != FFEINFO_kindANY)
9779 	  && ffebad_start (FFEBAD_MATH_ARG_KIND))
9780 	{
9781 	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9782 	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9783 	  ffebad_string ("an array");
9784 	  ffebad_finish ();
9785 	}
9786     }
9787 
9788   reduced = ffebld_new_any ();
9789   ffebld_set_info (reduced, ffeinfo_new_any ());
9790   return reduced;
9791 }
9792 
9793 /* ffeexpr_reduced_math2_ -- Wrap up reduction of + - * / operators
9794 
9795    reduced = ffeexpr_reduced_math2_(reduced,l,op,r);
9796 
9797    Makes sure the left and right arguments for reduced have basictype of
9798    INTEGER, REAL, or COMPLEX.  Determine common basictype and
9799    size for reduction (flag expression for combined hollerith/typeless
9800    situations for later determination of effective basictype).	If both left
9801    and right arguments have where of CONSTANT, assign where CONSTANT to
9802    reduced, else assign where FLEETING.	 Create CONVERT ops for args where
9803    needed.  Convert typeless
9804    constants to the desired type/size explicitly.
9805 
9806    If these requirements cannot be met, generate error message.	 */
9807 
9808 static ffebld
ffeexpr_reduced_math2_(ffebld reduced,ffeexprExpr_ l,ffeexprExpr_ op,ffeexprExpr_ r)9809 ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9810 			ffeexprExpr_ r)
9811 {
9812   ffeinfo linfo, rinfo, ninfo;
9813   ffeinfoBasictype lbt, rbt, nbt;
9814   ffeinfoKindtype lkt, rkt, nkt;
9815   ffeinfoRank lrk, rrk;
9816   ffeinfoKind lkd, rkd;
9817   ffeinfoWhere lwh, rwh, nwh;
9818 
9819   linfo = ffebld_info (ffebld_left (reduced));
9820   lbt = ffeinfo_basictype (linfo);
9821   lkt = ffeinfo_kindtype (linfo);
9822   lrk = ffeinfo_rank (linfo);
9823   lkd = ffeinfo_kind (linfo);
9824   lwh = ffeinfo_where (linfo);
9825 
9826   rinfo = ffebld_info (ffebld_right (reduced));
9827   rbt = ffeinfo_basictype (rinfo);
9828   rkt = ffeinfo_kindtype (rinfo);
9829   rrk = ffeinfo_rank (rinfo);
9830   rkd = ffeinfo_kind (rinfo);
9831   rwh = ffeinfo_where (rinfo);
9832 
9833   ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
9834 
9835   if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
9836        || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
9837     {
9838       switch (lwh)
9839 	{
9840 	case FFEINFO_whereCONSTANT:
9841 	  switch (rwh)
9842 	    {
9843 	    case FFEINFO_whereCONSTANT:
9844 	      nwh = FFEINFO_whereCONSTANT;
9845 	      break;
9846 
9847 	    case FFEINFO_whereIMMEDIATE:
9848 	      nwh = FFEINFO_whereIMMEDIATE;
9849 	      break;
9850 
9851 	    default:
9852 	      nwh = FFEINFO_whereFLEETING;
9853 	      break;
9854 	    }
9855 	  break;
9856 
9857 	case FFEINFO_whereIMMEDIATE:
9858 	  switch (rwh)
9859 	    {
9860 	    case FFEINFO_whereCONSTANT:
9861 	    case FFEINFO_whereIMMEDIATE:
9862 	      nwh = FFEINFO_whereIMMEDIATE;
9863 	      break;
9864 
9865 	    default:
9866 	      nwh = FFEINFO_whereFLEETING;
9867 	      break;
9868 	    }
9869 	  break;
9870 
9871 	default:
9872 	  nwh = FFEINFO_whereFLEETING;
9873 	  break;
9874 	}
9875 
9876       ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
9877 			   FFETARGET_charactersizeNONE);
9878       ffebld_set_info (reduced, ninfo);
9879       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
9880 	      l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
9881 						 FFEEXPR_contextLET));
9882       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
9883 	      r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
9884 						  FFEEXPR_contextLET));
9885       return reduced;
9886     }
9887 
9888   if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
9889       && (lbt != FFEINFO_basictypeCOMPLEX))
9890     {
9891       if ((rbt != FFEINFO_basictypeINTEGER)
9892       && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
9893 	{
9894 	  if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
9895 	      && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
9896 	    {
9897 	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9898 	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9899 	      ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9900 	      ffebad_finish ();
9901 	    }
9902 	}
9903       else
9904 	{
9905 	  if ((lbt != FFEINFO_basictypeANY)
9906 	      && ffebad_start (FFEBAD_MATH_ARG_TYPE))
9907 	    {
9908 	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9909 	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9910 	      ffebad_finish ();
9911 	    }
9912 	}
9913     }
9914   else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
9915 	   && (rbt != FFEINFO_basictypeCOMPLEX))
9916     {
9917       if ((rbt != FFEINFO_basictypeANY)
9918 	  && ffebad_start (FFEBAD_MATH_ARG_TYPE))
9919 	{
9920 	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9921 	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9922 	  ffebad_finish ();
9923 	}
9924     }
9925   else if (lrk != 0)
9926     {
9927       if ((lkd != FFEINFO_kindANY)
9928 	  && ffebad_start (FFEBAD_MATH_ARG_KIND))
9929 	{
9930 	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9931 	  ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9932 	  ffebad_string ("an array");
9933 	  ffebad_finish ();
9934 	}
9935     }
9936   else
9937     {
9938       if ((rkd != FFEINFO_kindANY)
9939 	  && ffebad_start (FFEBAD_MATH_ARG_KIND))
9940 	{
9941 	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9942 	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9943 	  ffebad_string ("an array");
9944 	  ffebad_finish ();
9945 	}
9946     }
9947 
9948   reduced = ffebld_new_any ();
9949   ffebld_set_info (reduced, ffeinfo_new_any ());
9950   return reduced;
9951 }
9952 
9953 /* ffeexpr_reduced_power_ -- Wrap up reduction of ** operator
9954 
9955    reduced = ffeexpr_reduced_power_(reduced,l,op,r);
9956 
9957    Makes sure the left and right arguments for reduced have basictype of
9958    INTEGER, REAL, or COMPLEX.  Determine common basictype and
9959    size for reduction (flag expression for combined hollerith/typeless
9960    situations for later determination of effective basictype).	If both left
9961    and right arguments have where of CONSTANT, assign where CONSTANT to
9962    reduced, else assign where FLEETING.	 Create CONVERT ops for args where
9963    needed.  Note that real**int or complex**int
9964    comes out as int = real**int etc with no conversions.
9965 
9966    If these requirements cannot be met, generate error message using the
9967    info in l, op, and r arguments and assign basictype, size, kind, and where
9968    of ANY.  */
9969 
9970 static ffebld
ffeexpr_reduced_power_(ffebld reduced,ffeexprExpr_ l,ffeexprExpr_ op,ffeexprExpr_ r)9971 ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9972 			ffeexprExpr_ r)
9973 {
9974   ffeinfo linfo, rinfo, ninfo;
9975   ffeinfoBasictype lbt, rbt, nbt;
9976   ffeinfoKindtype lkt, rkt, nkt;
9977   ffeinfoRank lrk, rrk;
9978   ffeinfoKind lkd, rkd;
9979   ffeinfoWhere lwh, rwh, nwh;
9980 
9981   linfo = ffebld_info (ffebld_left (reduced));
9982   lbt = ffeinfo_basictype (linfo);
9983   lkt = ffeinfo_kindtype (linfo);
9984   lrk = ffeinfo_rank (linfo);
9985   lkd = ffeinfo_kind (linfo);
9986   lwh = ffeinfo_where (linfo);
9987 
9988   rinfo = ffebld_info (ffebld_right (reduced));
9989   rbt = ffeinfo_basictype (rinfo);
9990   rkt = ffeinfo_kindtype (rinfo);
9991   rrk = ffeinfo_rank (rinfo);
9992   rkd = ffeinfo_kind (rinfo);
9993   rwh = ffeinfo_where (rinfo);
9994 
9995   if ((rbt == FFEINFO_basictypeINTEGER)
9996       && ((lbt == FFEINFO_basictypeREAL)
9997 	  || (lbt == FFEINFO_basictypeCOMPLEX)))
9998     {
9999       nbt = lbt;
10000       nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDEFAULT);
10001       if (nkt != FFEINFO_kindtypeREALDEFAULT)
10002 	{
10003 	  nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDOUBLE);
10004 	  if (nkt != FFEINFO_kindtypeREALDOUBLE)
10005 	    nkt = FFEINFO_kindtypeREALDOUBLE;	/* Highest kt we can power! */
10006 	}
10007       if (rkt == FFEINFO_kindtypeINTEGER4)
10008 	{
10009 	  /* xgettext:no-c-format */
10010 	  ffebad_start_msg ("Unsupported operand for ** at %1 -- converting to default INTEGER",
10011 			    FFEBAD_severityWARNING);
10012 	  ffebad_here (0, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10013 	  ffebad_finish ();
10014 	}
10015       if (rkt != FFEINFO_kindtypeINTEGERDEFAULT)
10016 	{
10017 	  ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10018 						      r->token, op->token,
10019 		FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0,
10020 						FFETARGET_charactersizeNONE,
10021 						      FFEEXPR_contextLET));
10022 	  rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10023 	}
10024     }
10025   else
10026     {
10027       ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10028 
10029 #if 0	/* INTEGER4**INTEGER4 works now. */
10030       if ((nbt == FFEINFO_basictypeINTEGER)
10031 	  && (nkt != FFEINFO_kindtypeINTEGERDEFAULT))
10032 	nkt = FFEINFO_kindtypeINTEGERDEFAULT;	/* Highest kt we can power! */
10033 #endif
10034       if (((nbt == FFEINFO_basictypeREAL)
10035 	   || (nbt == FFEINFO_basictypeCOMPLEX))
10036 	  && (nkt != FFEINFO_kindtypeREALDEFAULT))
10037 	{
10038 	  nkt = ffeinfo_kindtype_max (nbt, nkt, FFEINFO_kindtypeREALDOUBLE);
10039 	  if (nkt != FFEINFO_kindtypeREALDOUBLE)
10040 	    nkt = FFEINFO_kindtypeREALDOUBLE;	/* Highest kt we can power! */
10041 	}
10042       /* else Gonna turn into an error below. */
10043     }
10044 
10045   if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10046        || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
10047     {
10048       switch (lwh)
10049 	{
10050 	case FFEINFO_whereCONSTANT:
10051 	  switch (rwh)
10052 	    {
10053 	    case FFEINFO_whereCONSTANT:
10054 	      nwh = FFEINFO_whereCONSTANT;
10055 	      break;
10056 
10057 	    case FFEINFO_whereIMMEDIATE:
10058 	      nwh = FFEINFO_whereIMMEDIATE;
10059 	      break;
10060 
10061 	    default:
10062 	      nwh = FFEINFO_whereFLEETING;
10063 	      break;
10064 	    }
10065 	  break;
10066 
10067 	case FFEINFO_whereIMMEDIATE:
10068 	  switch (rwh)
10069 	    {
10070 	    case FFEINFO_whereCONSTANT:
10071 	    case FFEINFO_whereIMMEDIATE:
10072 	      nwh = FFEINFO_whereIMMEDIATE;
10073 	      break;
10074 
10075 	    default:
10076 	      nwh = FFEINFO_whereFLEETING;
10077 	      break;
10078 	    }
10079 	  break;
10080 
10081 	default:
10082 	  nwh = FFEINFO_whereFLEETING;
10083 	  break;
10084 	}
10085 
10086       ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10087 			   FFETARGET_charactersizeNONE);
10088       ffebld_set_info (reduced, ninfo);
10089       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10090 	      l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10091 						 FFEEXPR_contextLET));
10092       if (rbt != FFEINFO_basictypeINTEGER)
10093 	ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10094 	      r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10095 						    FFEEXPR_contextLET));
10096       return reduced;
10097     }
10098 
10099   if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10100       && (lbt != FFEINFO_basictypeCOMPLEX))
10101     {
10102       if ((rbt != FFEINFO_basictypeINTEGER)
10103       && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
10104 	{
10105 	  if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10106 	      && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
10107 	    {
10108 	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10109 	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10110 	      ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10111 	      ffebad_finish ();
10112 	    }
10113 	}
10114       else
10115 	{
10116 	  if ((lbt != FFEINFO_basictypeANY)
10117 	      && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10118 	    {
10119 	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10120 	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10121 	      ffebad_finish ();
10122 	    }
10123 	}
10124     }
10125   else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10126 	   && (rbt != FFEINFO_basictypeCOMPLEX))
10127     {
10128       if ((rbt != FFEINFO_basictypeANY)
10129 	  && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10130 	{
10131 	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10132 	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10133 	  ffebad_finish ();
10134 	}
10135     }
10136   else if (lrk != 0)
10137     {
10138       if ((lkd != FFEINFO_kindANY)
10139 	  && ffebad_start (FFEBAD_MATH_ARG_KIND))
10140 	{
10141 	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10142 	  ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10143 	  ffebad_string ("an array");
10144 	  ffebad_finish ();
10145 	}
10146     }
10147   else
10148     {
10149       if ((rkd != FFEINFO_kindANY)
10150 	  && ffebad_start (FFEBAD_MATH_ARG_KIND))
10151 	{
10152 	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10153 	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10154 	  ffebad_string ("an array");
10155 	  ffebad_finish ();
10156 	}
10157     }
10158 
10159   reduced = ffebld_new_any ();
10160   ffebld_set_info (reduced, ffeinfo_new_any ());
10161   return reduced;
10162 }
10163 
10164 /* ffeexpr_reduced_relop2_ -- Wrap up reduction of LT, LE, GE, and GT operators
10165 
10166    reduced = ffeexpr_reduced_relop2_(reduced,l,op,r);
10167 
10168    Makes sure the left and right arguments for reduced have basictype of
10169    INTEGER, REAL, or CHARACTER.	 Determine common basictype and
10170    size for reduction.	If both left
10171    and right arguments have where of CONSTANT, assign where CONSTANT to
10172    reduced, else assign where FLEETING.	 Create CONVERT ops for args where
10173    needed.  Convert typeless
10174    constants to the desired type/size explicitly.
10175 
10176    If these requirements cannot be met, generate error message.	 */
10177 
10178 static ffebld
ffeexpr_reduced_relop2_(ffebld reduced,ffeexprExpr_ l,ffeexprExpr_ op,ffeexprExpr_ r)10179 ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10180 			 ffeexprExpr_ r)
10181 {
10182   ffeinfo linfo, rinfo, ninfo;
10183   ffeinfoBasictype lbt, rbt, nbt;
10184   ffeinfoKindtype lkt, rkt, nkt;
10185   ffeinfoRank lrk, rrk;
10186   ffeinfoKind lkd, rkd;
10187   ffeinfoWhere lwh, rwh, nwh;
10188   ffetargetCharacterSize lsz, rsz;
10189 
10190   linfo = ffebld_info (ffebld_left (reduced));
10191   lbt = ffeinfo_basictype (linfo);
10192   lkt = ffeinfo_kindtype (linfo);
10193   lrk = ffeinfo_rank (linfo);
10194   lkd = ffeinfo_kind (linfo);
10195   lwh = ffeinfo_where (linfo);
10196   lsz = ffebld_size_known (ffebld_left (reduced));
10197 
10198   rinfo = ffebld_info (ffebld_right (reduced));
10199   rbt = ffeinfo_basictype (rinfo);
10200   rkt = ffeinfo_kindtype (rinfo);
10201   rrk = ffeinfo_rank (rinfo);
10202   rkd = ffeinfo_kind (rinfo);
10203   rwh = ffeinfo_where (rinfo);
10204   rsz = ffebld_size_known (ffebld_right (reduced));
10205 
10206   ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10207 
10208   if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10209        || (nbt == FFEINFO_basictypeCHARACTER))
10210       && (lrk == 0) && (rrk == 0))
10211     {
10212       switch (lwh)
10213 	{
10214 	case FFEINFO_whereCONSTANT:
10215 	  switch (rwh)
10216 	    {
10217 	    case FFEINFO_whereCONSTANT:
10218 	      nwh = FFEINFO_whereCONSTANT;
10219 	      break;
10220 
10221 	    case FFEINFO_whereIMMEDIATE:
10222 	      nwh = FFEINFO_whereIMMEDIATE;
10223 	      break;
10224 
10225 	    default:
10226 	      nwh = FFEINFO_whereFLEETING;
10227 	      break;
10228 	    }
10229 	  break;
10230 
10231 	case FFEINFO_whereIMMEDIATE:
10232 	  switch (rwh)
10233 	    {
10234 	    case FFEINFO_whereCONSTANT:
10235 	    case FFEINFO_whereIMMEDIATE:
10236 	      nwh = FFEINFO_whereIMMEDIATE;
10237 	      break;
10238 
10239 	    default:
10240 	      nwh = FFEINFO_whereFLEETING;
10241 	      break;
10242 	    }
10243 	  break;
10244 
10245 	default:
10246 	  nwh = FFEINFO_whereFLEETING;
10247 	  break;
10248 	}
10249 
10250       if ((lsz != FFETARGET_charactersizeNONE)
10251 	  && (rsz != FFETARGET_charactersizeNONE))
10252 	lsz = rsz = (lsz > rsz) ? lsz : rsz;
10253 
10254       ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
10255 		   0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
10256       ffebld_set_info (reduced, ninfo);
10257       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10258 				      l->token, op->token, nbt, nkt, 0, lsz,
10259 						 FFEEXPR_contextLET));
10260       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10261 				      r->token, op->token, nbt, nkt, 0, rsz,
10262 						  FFEEXPR_contextLET));
10263       return reduced;
10264     }
10265 
10266   if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10267       && (lbt != FFEINFO_basictypeCHARACTER))
10268     {
10269       if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10270 	  && (rbt != FFEINFO_basictypeCHARACTER))
10271 	{
10272 	  if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10273 	      && ffebad_start (FFEBAD_RELOP_ARGS_TYPE))
10274 	    {
10275 	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10276 	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10277 	      ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10278 	      ffebad_finish ();
10279 	    }
10280 	}
10281       else
10282 	{
10283 	  if ((lbt != FFEINFO_basictypeANY)
10284 	      && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
10285 	    {
10286 	      ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10287 	      ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10288 	      ffebad_finish ();
10289 	    }
10290 	}
10291     }
10292   else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10293 	   && (rbt != FFEINFO_basictypeCHARACTER))
10294     {
10295       if ((rbt != FFEINFO_basictypeANY)
10296 	  && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
10297 	{
10298 	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10299 	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10300 	  ffebad_finish ();
10301 	}
10302     }
10303   else if (lrk != 0)
10304     {
10305       if ((lkd != FFEINFO_kindANY)
10306 	  && ffebad_start (FFEBAD_RELOP_ARG_KIND))
10307 	{
10308 	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10309 	  ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10310 	  ffebad_string ("an array");
10311 	  ffebad_finish ();
10312 	}
10313     }
10314   else
10315     {
10316       if ((rkd != FFEINFO_kindANY)
10317 	  && ffebad_start (FFEBAD_RELOP_ARG_KIND))
10318 	{
10319 	  ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10320 	  ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10321 	  ffebad_string ("an array");
10322 	  ffebad_finish ();
10323 	}
10324     }
10325 
10326   reduced = ffebld_new_any ();
10327   ffebld_set_info (reduced, ffeinfo_new_any ());
10328   return reduced;
10329 }
10330 
10331 /* ffeexpr_reduced_ugly1_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
10332 
10333    reduced = ffeexpr_reduced_ugly1_(reduced,op,r);
10334 
10335    Sigh.  */
10336 
10337 static ffebld
ffeexpr_reduced_ugly1_(ffebld reduced,ffeexprExpr_ op,ffeexprExpr_ r)10338 ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10339 {
10340   ffeinfo rinfo;
10341   ffeinfoBasictype rbt;
10342   ffeinfoKindtype rkt;
10343   ffeinfoRank rrk;
10344   ffeinfoKind rkd;
10345   ffeinfoWhere rwh;
10346 
10347   rinfo = ffebld_info (ffebld_left (reduced));
10348   rbt = ffeinfo_basictype (rinfo);
10349   rkt = ffeinfo_kindtype (rinfo);
10350   rrk = ffeinfo_rank (rinfo);
10351   rkd = ffeinfo_kind (rinfo);
10352   rwh = ffeinfo_where (rinfo);
10353 
10354   if ((rbt == FFEINFO_basictypeTYPELESS)
10355       || (rbt == FFEINFO_basictypeHOLLERITH))
10356     {
10357       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10358 			      r->token, op->token, FFEINFO_basictypeINTEGER,
10359 					  FFEINFO_kindtypeINTEGERDEFAULT, 0,
10360 						 FFETARGET_charactersizeNONE,
10361 						 FFEEXPR_contextLET));
10362       rinfo = ffebld_info (ffebld_left (reduced));
10363       rbt = FFEINFO_basictypeINTEGER;
10364       rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10365       rrk = 0;
10366       rkd = FFEINFO_kindENTITY;
10367       rwh = ffeinfo_where (rinfo);
10368     }
10369 
10370   if (rbt == FFEINFO_basictypeLOGICAL)
10371     {
10372       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10373 			      r->token, op->token, FFEINFO_basictypeINTEGER,
10374 					  FFEINFO_kindtypeINTEGERDEFAULT, 0,
10375 						 FFETARGET_charactersizeNONE,
10376 						 FFEEXPR_contextLET));
10377     }
10378 
10379   return reduced;
10380 }
10381 
10382 /* ffeexpr_reduced_ugly1log_ -- Deal with TYPELESS and HOLLERITH
10383 
10384    reduced = ffeexpr_reduced_ugly1log_(reduced,op,r);
10385 
10386    Sigh.  */
10387 
10388 static ffebld
ffeexpr_reduced_ugly1log_(ffebld reduced,ffeexprExpr_ op,ffeexprExpr_ r)10389 ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10390 {
10391   ffeinfo rinfo;
10392   ffeinfoBasictype rbt;
10393   ffeinfoKindtype rkt;
10394   ffeinfoRank rrk;
10395   ffeinfoKind rkd;
10396   ffeinfoWhere rwh;
10397 
10398   rinfo = ffebld_info (ffebld_left (reduced));
10399   rbt = ffeinfo_basictype (rinfo);
10400   rkt = ffeinfo_kindtype (rinfo);
10401   rrk = ffeinfo_rank (rinfo);
10402   rkd = ffeinfo_kind (rinfo);
10403   rwh = ffeinfo_where (rinfo);
10404 
10405   if ((rbt == FFEINFO_basictypeTYPELESS)
10406       || (rbt == FFEINFO_basictypeHOLLERITH))
10407     {
10408       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10409 			   r->token, op->token, FFEINFO_basictypeLOGICAL, 0,
10410 					     FFEINFO_kindtypeLOGICALDEFAULT,
10411 						 FFETARGET_charactersizeNONE,
10412 						 FFEEXPR_contextLET));
10413       rinfo = ffebld_info (ffebld_left (reduced));
10414       rbt = FFEINFO_basictypeLOGICAL;
10415       rkt = FFEINFO_kindtypeLOGICALDEFAULT;
10416       rrk = 0;
10417       rkd = FFEINFO_kindENTITY;
10418       rwh = ffeinfo_where (rinfo);
10419     }
10420 
10421   return reduced;
10422 }
10423 
10424 /* ffeexpr_reduced_ugly2_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
10425 
10426    reduced = ffeexpr_reduced_ugly2_(reduced,l,op,r);
10427 
10428    Sigh.  */
10429 
10430 static ffebld
ffeexpr_reduced_ugly2_(ffebld reduced,ffeexprExpr_ l,ffeexprExpr_ op,ffeexprExpr_ r)10431 ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10432 			ffeexprExpr_ r)
10433 {
10434   ffeinfo linfo, rinfo;
10435   ffeinfoBasictype lbt, rbt;
10436   ffeinfoKindtype lkt, rkt;
10437   ffeinfoRank lrk, rrk;
10438   ffeinfoKind lkd, rkd;
10439   ffeinfoWhere lwh, rwh;
10440 
10441   linfo = ffebld_info (ffebld_left (reduced));
10442   lbt = ffeinfo_basictype (linfo);
10443   lkt = ffeinfo_kindtype (linfo);
10444   lrk = ffeinfo_rank (linfo);
10445   lkd = ffeinfo_kind (linfo);
10446   lwh = ffeinfo_where (linfo);
10447 
10448   rinfo = ffebld_info (ffebld_right (reduced));
10449   rbt = ffeinfo_basictype (rinfo);
10450   rkt = ffeinfo_kindtype (rinfo);
10451   rrk = ffeinfo_rank (rinfo);
10452   rkd = ffeinfo_kind (rinfo);
10453   rwh = ffeinfo_where (rinfo);
10454 
10455   if ((lbt == FFEINFO_basictypeTYPELESS)
10456       || (lbt == FFEINFO_basictypeHOLLERITH))
10457     {
10458       if ((rbt == FFEINFO_basictypeTYPELESS)
10459 	  || (rbt == FFEINFO_basictypeHOLLERITH))
10460 	{
10461 	  ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10462 			      l->token, op->token, FFEINFO_basictypeINTEGER,
10463 					  FFEINFO_kindtypeINTEGERDEFAULT, 0,
10464 						FFETARGET_charactersizeNONE,
10465 						     FFEEXPR_contextLET));
10466 	  ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10467 			   r->token, op->token, FFEINFO_basictypeINTEGER, 0,
10468 					     FFEINFO_kindtypeINTEGERDEFAULT,
10469 						FFETARGET_charactersizeNONE,
10470 						      FFEEXPR_contextLET));
10471 	  linfo = ffebld_info (ffebld_left (reduced));
10472 	  rinfo = ffebld_info (ffebld_right (reduced));
10473 	  lbt = rbt = FFEINFO_basictypeINTEGER;
10474 	  lkt = rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10475 	  lrk = rrk = 0;
10476 	  lkd = rkd = FFEINFO_kindENTITY;
10477 	  lwh = ffeinfo_where (linfo);
10478 	  rwh = ffeinfo_where (rinfo);
10479 	}
10480       else
10481 	{
10482 	  ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
10483 				 l->token, ffebld_right (reduced), r->token,
10484 						       FFEEXPR_contextLET));
10485 	  linfo = ffebld_info (ffebld_left (reduced));
10486 	  lbt = ffeinfo_basictype (linfo);
10487 	  lkt = ffeinfo_kindtype (linfo);
10488 	  lrk = ffeinfo_rank (linfo);
10489 	  lkd = ffeinfo_kind (linfo);
10490 	  lwh = ffeinfo_where (linfo);
10491 	}
10492     }
10493   else
10494     {
10495       if ((rbt == FFEINFO_basictypeTYPELESS)
10496 	  || (rbt == FFEINFO_basictypeHOLLERITH))
10497 	{
10498 	  ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
10499 				  r->token, ffebld_left (reduced), l->token,
10500 						       FFEEXPR_contextLET));
10501 	  rinfo = ffebld_info (ffebld_right (reduced));
10502 	  rbt = ffeinfo_basictype (rinfo);
10503 	  rkt = ffeinfo_kindtype (rinfo);
10504 	  rrk = ffeinfo_rank (rinfo);
10505 	  rkd = ffeinfo_kind (rinfo);
10506 	  rwh = ffeinfo_where (rinfo);
10507 	}
10508       /* else Leave it alone. */
10509     }
10510 
10511   if (lbt == FFEINFO_basictypeLOGICAL)
10512     {
10513       ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10514 			      l->token, op->token, FFEINFO_basictypeINTEGER,
10515 					  FFEINFO_kindtypeINTEGERDEFAULT, 0,
10516 						 FFETARGET_charactersizeNONE,
10517 						 FFEEXPR_contextLET));
10518     }
10519 
10520   if (rbt == FFEINFO_basictypeLOGICAL)
10521     {
10522       ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10523 			      r->token, op->token, FFEINFO_basictypeINTEGER,
10524 					  FFEINFO_kindtypeINTEGERDEFAULT, 0,
10525 						FFETARGET_charactersizeNONE,
10526 						  FFEEXPR_contextLET));
10527     }
10528 
10529   return reduced;
10530 }
10531 
10532 /* ffeexpr_reduced_ugly2log_ -- Deal with TYPELESS and HOLLERITH
10533 
10534    reduced = ffeexpr_reduced_ugly2log_(reduced,l,op,r);
10535 
10536    Sigh.  */
10537 
10538 static ffebld
ffeexpr_reduced_ugly2log_(ffebld reduced,ffeexprExpr_ l,ffeexprExpr_ op,ffeexprExpr_ r,bool * bothlogical)10539 ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10540 			   ffeexprExpr_ r, bool *bothlogical)
10541 {
10542   ffeinfo linfo, rinfo;
10543   ffeinfoBasictype lbt, rbt;
10544   ffeinfoKindtype lkt, rkt;
10545   ffeinfoRank lrk, rrk;
10546   ffeinfoKind lkd, rkd;
10547   ffeinfoWhere lwh, rwh;
10548 
10549   linfo = ffebld_info (ffebld_left (reduced));
10550   lbt = ffeinfo_basictype (linfo);
10551   lkt = ffeinfo_kindtype (linfo);
10552   lrk = ffeinfo_rank (linfo);
10553   lkd = ffeinfo_kind (linfo);
10554   lwh = ffeinfo_where (linfo);
10555 
10556   rinfo = ffebld_info (ffebld_right (reduced));
10557   rbt = ffeinfo_basictype (rinfo);
10558   rkt = ffeinfo_kindtype (rinfo);
10559   rrk = ffeinfo_rank (rinfo);
10560   rkd = ffeinfo_kind (rinfo);
10561   rwh = ffeinfo_where (rinfo);
10562 
10563   if ((lbt == FFEINFO_basictypeTYPELESS)
10564       || (lbt == FFEINFO_basictypeHOLLERITH))
10565     {
10566       if ((rbt == FFEINFO_basictypeTYPELESS)
10567 	  || (rbt == FFEINFO_basictypeHOLLERITH))
10568 	{
10569 	  ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10570 			      l->token, op->token, FFEINFO_basictypeLOGICAL,
10571 					  FFEINFO_kindtypeLOGICALDEFAULT, 0,
10572 						FFETARGET_charactersizeNONE,
10573 						     FFEEXPR_contextLET));
10574 	  ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10575 			      r->token, op->token, FFEINFO_basictypeLOGICAL,
10576 					  FFEINFO_kindtypeLOGICALDEFAULT, 0,
10577 						FFETARGET_charactersizeNONE,
10578 						      FFEEXPR_contextLET));
10579 	  linfo = ffebld_info (ffebld_left (reduced));
10580 	  rinfo = ffebld_info (ffebld_right (reduced));
10581 	  lbt = rbt = FFEINFO_basictypeLOGICAL;
10582 	  lkt = rkt = FFEINFO_kindtypeLOGICALDEFAULT;
10583 	  lrk = rrk = 0;
10584 	  lkd = rkd = FFEINFO_kindENTITY;
10585 	  lwh = ffeinfo_where (linfo);
10586 	  rwh = ffeinfo_where (rinfo);
10587 	}
10588       else
10589 	{
10590 	  ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
10591 				 l->token, ffebld_right (reduced), r->token,
10592 						       FFEEXPR_contextLET));
10593 	  linfo = ffebld_info (ffebld_left (reduced));
10594 	  lbt = ffeinfo_basictype (linfo);
10595 	  lkt = ffeinfo_kindtype (linfo);
10596 	  lrk = ffeinfo_rank (linfo);
10597 	  lkd = ffeinfo_kind (linfo);
10598 	  lwh = ffeinfo_where (linfo);
10599 	}
10600     }
10601   else
10602     {
10603       if ((rbt == FFEINFO_basictypeTYPELESS)
10604 	  || (rbt == FFEINFO_basictypeHOLLERITH))
10605 	{
10606 	  ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
10607 				  r->token, ffebld_left (reduced), l->token,
10608 						       FFEEXPR_contextLET));
10609 	  rinfo = ffebld_info (ffebld_right (reduced));
10610 	  rbt = ffeinfo_basictype (rinfo);
10611 	  rkt = ffeinfo_kindtype (rinfo);
10612 	  rrk = ffeinfo_rank (rinfo);
10613 	  rkd = ffeinfo_kind (rinfo);
10614 	  rwh = ffeinfo_where (rinfo);
10615 	}
10616       /* else Leave it alone. */
10617     }
10618 
10619   if (lbt == FFEINFO_basictypeLOGICAL)
10620     {
10621       ffebld_set_left (reduced,
10622 		       ffeexpr_convert (ffebld_left (reduced),
10623 					l->token, op->token,
10624 					FFEINFO_basictypeINTEGER,
10625 					FFEINFO_kindtypeINTEGERDEFAULT, 0,
10626 					FFETARGET_charactersizeNONE,
10627 					FFEEXPR_contextLET));
10628     }
10629 
10630   if (rbt == FFEINFO_basictypeLOGICAL)
10631     {
10632       ffebld_set_right (reduced,
10633 			ffeexpr_convert (ffebld_right (reduced),
10634 					 r->token, op->token,
10635 					 FFEINFO_basictypeINTEGER,
10636 					 FFEINFO_kindtypeINTEGERDEFAULT, 0,
10637 					 FFETARGET_charactersizeNONE,
10638 					 FFEEXPR_contextLET));
10639     }
10640 
10641   if (bothlogical != NULL)
10642     *bothlogical = (lbt == FFEINFO_basictypeLOGICAL
10643 		    && rbt == FFEINFO_basictypeLOGICAL);
10644 
10645   return reduced;
10646 }
10647 
10648 /* Fumble through tokens until a nonmatching CLOSE_PAREN, EOS, or SEMICOLON
10649    is found.
10650 
10651    The idea is to process the tokens as they would be done by normal
10652    expression processing, with the key things being telling the lexer
10653    when hollerith/character constants are about to happen, until the
10654    true closing token is found.  */
10655 
10656 static ffelexHandler
ffeexpr_find_close_paren_(ffelexToken t,ffelexHandler after)10657 ffeexpr_find_close_paren_ (ffelexToken t,
10658 			   ffelexHandler after)
10659 {
10660   ffeexpr_find_.after = after;
10661   ffeexpr_find_.level = 1;
10662   return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10663 }
10664 
10665 static ffelexHandler
ffeexpr_nil_finished_(ffelexToken t)10666 ffeexpr_nil_finished_ (ffelexToken t)
10667 {
10668   switch (ffelex_token_type (t))
10669     {
10670     case FFELEX_typeCLOSE_PAREN:
10671       if (--ffeexpr_find_.level == 0)
10672 	return (ffelexHandler) ffeexpr_find_.after;
10673       return (ffelexHandler) ffeexpr_nil_binary_;
10674 
10675     case FFELEX_typeCOMMA:
10676     case FFELEX_typeCOLON:
10677     case FFELEX_typeEQUALS:
10678     case FFELEX_typePOINTS:
10679       return (ffelexHandler) ffeexpr_nil_rhs_;
10680 
10681     default:
10682       if (--ffeexpr_find_.level == 0)
10683 	return (ffelexHandler) ffeexpr_find_.after (t);
10684       return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10685     }
10686 }
10687 
10688 static ffelexHandler
ffeexpr_nil_rhs_(ffelexToken t)10689 ffeexpr_nil_rhs_ (ffelexToken t)
10690 {
10691   switch (ffelex_token_type (t))
10692     {
10693     case FFELEX_typeQUOTE:
10694       if (ffe_is_vxt ())
10695 	return (ffelexHandler) ffeexpr_nil_quote_;
10696       ffelex_set_expecting_hollerith (-1, '\"',
10697 				      ffelex_token_where_line (t),
10698 				      ffelex_token_where_column (t));
10699       return (ffelexHandler) ffeexpr_nil_apostrophe_;
10700 
10701     case FFELEX_typeAPOSTROPHE:
10702       ffelex_set_expecting_hollerith (-1, '\'',
10703 				      ffelex_token_where_line (t),
10704 				      ffelex_token_where_column (t));
10705       return (ffelexHandler) ffeexpr_nil_apostrophe_;
10706 
10707     case FFELEX_typePERCENT:
10708       return (ffelexHandler) ffeexpr_nil_percent_;
10709 
10710     case FFELEX_typeOPEN_PAREN:
10711       ++ffeexpr_find_.level;
10712       return (ffelexHandler) ffeexpr_nil_rhs_;
10713 
10714     case FFELEX_typePLUS:
10715     case FFELEX_typeMINUS:
10716       return (ffelexHandler) ffeexpr_nil_rhs_;
10717 
10718     case FFELEX_typePERIOD:
10719       return (ffelexHandler) ffeexpr_nil_period_;
10720 
10721     case FFELEX_typeNUMBER:
10722       ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
10723       if (ffeexpr_hollerith_count_ > 0)
10724 	ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
10725 					'\0',
10726 					ffelex_token_where_line (t),
10727 					ffelex_token_where_column (t));
10728       return (ffelexHandler) ffeexpr_nil_number_;
10729 
10730     case FFELEX_typeNAME:
10731     case FFELEX_typeNAMES:
10732       return (ffelexHandler) ffeexpr_nil_name_rhs_;
10733 
10734     case FFELEX_typeASTERISK:
10735     case FFELEX_typeSLASH:
10736     case FFELEX_typePOWER:
10737     case FFELEX_typeCONCAT:
10738     case FFELEX_typeREL_EQ:
10739     case FFELEX_typeREL_NE:
10740     case FFELEX_typeREL_LE:
10741     case FFELEX_typeREL_GE:
10742       return (ffelexHandler) ffeexpr_nil_rhs_;
10743 
10744     default:
10745       return (ffelexHandler) ffeexpr_nil_finished_ (t);
10746     }
10747 }
10748 
10749 static ffelexHandler
ffeexpr_nil_period_(ffelexToken t)10750 ffeexpr_nil_period_ (ffelexToken t)
10751 {
10752   switch (ffelex_token_type (t))
10753     {
10754     case FFELEX_typeNAME:
10755     case FFELEX_typeNAMES:
10756       ffeexpr_current_dotdot_ = ffestr_other (t);
10757       switch (ffeexpr_current_dotdot_)
10758 	{
10759 	case FFESTR_otherNone:
10760 	  return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10761 
10762 	case FFESTR_otherTRUE:
10763 	case FFESTR_otherFALSE:
10764 	case FFESTR_otherNOT:
10765 	  return (ffelexHandler) ffeexpr_nil_end_period_;
10766 
10767 	default:
10768 	  return (ffelexHandler) ffeexpr_nil_swallow_period_;
10769 	}
10770       break;			/* Nothing really reaches here. */
10771 
10772     case FFELEX_typeNUMBER:
10773       return (ffelexHandler) ffeexpr_nil_real_;
10774 
10775     default:
10776       return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10777     }
10778 }
10779 
10780 static ffelexHandler
ffeexpr_nil_end_period_(ffelexToken t)10781 ffeexpr_nil_end_period_ (ffelexToken t)
10782 {
10783   switch (ffeexpr_current_dotdot_)
10784     {
10785     case FFESTR_otherNOT:
10786       if (ffelex_token_type (t) != FFELEX_typePERIOD)
10787 	return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10788       return (ffelexHandler) ffeexpr_nil_rhs_;
10789 
10790     case FFESTR_otherTRUE:
10791     case FFESTR_otherFALSE:
10792       if (ffelex_token_type (t) != FFELEX_typePERIOD)
10793 	return (ffelexHandler) ffeexpr_nil_binary_ (t);
10794       return (ffelexHandler) ffeexpr_nil_binary_;
10795 
10796     default:
10797       assert ("Bad [nil] unary dotdot in ffeexpr_current_dotdot_" == NULL);
10798       exit (0);
10799       return NULL;
10800     }
10801 }
10802 
10803 static ffelexHandler
ffeexpr_nil_swallow_period_(ffelexToken t)10804 ffeexpr_nil_swallow_period_ (ffelexToken t)
10805 {
10806   if (ffelex_token_type (t) != FFELEX_typePERIOD)
10807     return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10808   return (ffelexHandler) ffeexpr_nil_rhs_;
10809 }
10810 
10811 static ffelexHandler
ffeexpr_nil_real_(ffelexToken t)10812 ffeexpr_nil_real_ (ffelexToken t)
10813 {
10814   char d;
10815   const char *p;
10816 
10817   if (((ffelex_token_type (t) != FFELEX_typeNAME)
10818        && (ffelex_token_type (t) != FFELEX_typeNAMES))
10819       || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
10820 				     'D', 'd')
10821 	     || ffesrc_char_match_init (d, 'E', 'e')
10822 	     || ffesrc_char_match_init (d, 'Q', 'q')))
10823 	   && ffeexpr_isdigits_ (++p)))
10824     return (ffelexHandler) ffeexpr_nil_binary_ (t);
10825 
10826   if (*p == '\0')
10827     return (ffelexHandler) ffeexpr_nil_real_exponent_;
10828   return (ffelexHandler) ffeexpr_nil_binary_;
10829 }
10830 
10831 static ffelexHandler
ffeexpr_nil_real_exponent_(ffelexToken t)10832 ffeexpr_nil_real_exponent_ (ffelexToken t)
10833 {
10834   if ((ffelex_token_type (t) != FFELEX_typePLUS)
10835       && (ffelex_token_type (t) != FFELEX_typeMINUS))
10836     return (ffelexHandler) ffeexpr_nil_binary_ (t);
10837 
10838   return (ffelexHandler) ffeexpr_nil_real_exp_sign_;
10839 }
10840 
10841 static ffelexHandler
ffeexpr_nil_real_exp_sign_(ffelexToken t)10842 ffeexpr_nil_real_exp_sign_ (ffelexToken t)
10843 {
10844   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
10845     return (ffelexHandler) ffeexpr_nil_binary_ (t);
10846   return (ffelexHandler) ffeexpr_nil_binary_;
10847 }
10848 
10849 static ffelexHandler
ffeexpr_nil_number_(ffelexToken t)10850 ffeexpr_nil_number_ (ffelexToken t)
10851 {
10852   char d;
10853   const char *p;
10854 
10855   if (ffeexpr_hollerith_count_ > 0)
10856     ffelex_set_expecting_hollerith (0, '\0',
10857 				    ffewhere_line_unknown (),
10858 				    ffewhere_column_unknown ());
10859 
10860   switch (ffelex_token_type (t))
10861     {
10862     case FFELEX_typeNAME:
10863     case FFELEX_typeNAMES:
10864       if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
10865 				   'D', 'd')
10866 	   || ffesrc_char_match_init (d, 'E', 'e')
10867 	   || ffesrc_char_match_init (d, 'Q', 'q'))
10868 	  && ffeexpr_isdigits_ (++p))
10869 	{
10870 	  if (*p == '\0')
10871 	    {
10872 	      ffeexpr_find_.t = ffelex_token_use (t);
10873 	      return (ffelexHandler) ffeexpr_nil_number_exponent_;
10874 	    }
10875 	  return (ffelexHandler) ffeexpr_nil_binary_;
10876 	}
10877       break;
10878 
10879     case FFELEX_typePERIOD:
10880       ffeexpr_find_.t = ffelex_token_use (t);
10881       return (ffelexHandler) ffeexpr_nil_number_period_;
10882 
10883     case FFELEX_typeHOLLERITH:
10884       return (ffelexHandler) ffeexpr_nil_binary_;
10885 
10886     default:
10887       break;
10888     }
10889   return (ffelexHandler) ffeexpr_nil_binary_ (t);
10890 }
10891 
10892 /* Expects ffeexpr_find_.t.  */
10893 
10894 static ffelexHandler
ffeexpr_nil_number_exponent_(ffelexToken t)10895 ffeexpr_nil_number_exponent_ (ffelexToken t)
10896 {
10897   ffelexHandler nexthandler;
10898 
10899   if ((ffelex_token_type (t) != FFELEX_typePLUS)
10900       && (ffelex_token_type (t) != FFELEX_typeMINUS))
10901     {
10902       nexthandler
10903 	= (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
10904       ffelex_token_kill (ffeexpr_find_.t);
10905       return (ffelexHandler) (*nexthandler) (t);
10906     }
10907 
10908   ffelex_token_kill (ffeexpr_find_.t);
10909   return (ffelexHandler) ffeexpr_nil_number_exp_sign_;
10910 }
10911 
10912 static ffelexHandler
ffeexpr_nil_number_exp_sign_(ffelexToken t)10913 ffeexpr_nil_number_exp_sign_ (ffelexToken t)
10914 {
10915   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
10916     return (ffelexHandler) ffeexpr_nil_binary_ (t);
10917 
10918   return (ffelexHandler) ffeexpr_nil_binary_;
10919 }
10920 
10921 /* Expects ffeexpr_find_.t.  */
10922 
10923 static ffelexHandler
ffeexpr_nil_number_period_(ffelexToken t)10924 ffeexpr_nil_number_period_ (ffelexToken t)
10925 {
10926   ffelexHandler nexthandler;
10927   char d;
10928   const char *p;
10929 
10930   switch (ffelex_token_type (t))
10931     {
10932     case FFELEX_typeNAME:
10933     case FFELEX_typeNAMES:
10934       if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
10935 				   'D', 'd')
10936 	   || ffesrc_char_match_init (d, 'E', 'e')
10937 	   || ffesrc_char_match_init (d, 'Q', 'q'))
10938 	  && ffeexpr_isdigits_ (++p))
10939 	{
10940 	  if (*p == '\0')
10941 	    return (ffelexHandler) ffeexpr_nil_number_per_exp_;
10942 	  ffelex_token_kill (ffeexpr_find_.t);
10943 	  return (ffelexHandler) ffeexpr_nil_binary_;
10944 	}
10945       nexthandler
10946 	= (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
10947       ffelex_token_kill (ffeexpr_find_.t);
10948       return (ffelexHandler) (*nexthandler) (t);
10949 
10950     case FFELEX_typeNUMBER:
10951       ffelex_token_kill (ffeexpr_find_.t);
10952       return (ffelexHandler) ffeexpr_nil_number_real_;
10953 
10954     default:
10955       break;
10956     }
10957   ffelex_token_kill (ffeexpr_find_.t);
10958   return (ffelexHandler) ffeexpr_nil_binary_ (t);
10959 }
10960 
10961 /* Expects ffeexpr_find_.t.  */
10962 
10963 static ffelexHandler
ffeexpr_nil_number_per_exp_(ffelexToken t)10964 ffeexpr_nil_number_per_exp_ (ffelexToken t)
10965 {
10966   if ((ffelex_token_type (t) != FFELEX_typePLUS)
10967       && (ffelex_token_type (t) != FFELEX_typeMINUS))
10968     {
10969       ffelexHandler nexthandler;
10970 
10971       nexthandler
10972 	= (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
10973       ffelex_token_kill (ffeexpr_find_.t);
10974       return (ffelexHandler) (*nexthandler) (t);
10975     }
10976 
10977   ffelex_token_kill (ffeexpr_find_.t);
10978   return (ffelexHandler) ffeexpr_nil_num_per_exp_sign_;
10979 }
10980 
10981 static ffelexHandler
ffeexpr_nil_number_real_(ffelexToken t)10982 ffeexpr_nil_number_real_ (ffelexToken t)
10983 {
10984   char d;
10985   const char *p;
10986 
10987   if (((ffelex_token_type (t) != FFELEX_typeNAME)
10988        && (ffelex_token_type (t) != FFELEX_typeNAMES))
10989       || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
10990 				     'D', 'd')
10991 	     || ffesrc_char_match_init (d, 'E', 'e')
10992 	     || ffesrc_char_match_init (d, 'Q', 'q')))
10993 	   && ffeexpr_isdigits_ (++p)))
10994     return (ffelexHandler) ffeexpr_nil_binary_ (t);
10995 
10996   if (*p == '\0')
10997     return (ffelexHandler) ffeexpr_nil_number_real_exp_;
10998 
10999   return (ffelexHandler) ffeexpr_nil_binary_;
11000 }
11001 
11002 static ffelexHandler
ffeexpr_nil_num_per_exp_sign_(ffelexToken t)11003 ffeexpr_nil_num_per_exp_sign_ (ffelexToken t)
11004 {
11005   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11006     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11007   return (ffelexHandler) ffeexpr_nil_binary_;
11008 }
11009 
11010 static ffelexHandler
ffeexpr_nil_number_real_exp_(ffelexToken t)11011 ffeexpr_nil_number_real_exp_ (ffelexToken t)
11012 {
11013   if ((ffelex_token_type (t) != FFELEX_typePLUS)
11014       && (ffelex_token_type (t) != FFELEX_typeMINUS))
11015     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11016   return (ffelexHandler) ffeexpr_nil_num_real_exp_sn_;
11017 }
11018 
11019 static ffelexHandler
ffeexpr_nil_num_real_exp_sn_(ffelexToken t)11020 ffeexpr_nil_num_real_exp_sn_ (ffelexToken t)
11021 {
11022   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11023     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11024   return (ffelexHandler) ffeexpr_nil_binary_;
11025 }
11026 
11027 static ffelexHandler
ffeexpr_nil_binary_(ffelexToken t)11028 ffeexpr_nil_binary_ (ffelexToken t)
11029 {
11030   switch (ffelex_token_type (t))
11031     {
11032     case FFELEX_typePLUS:
11033     case FFELEX_typeMINUS:
11034     case FFELEX_typeASTERISK:
11035     case FFELEX_typeSLASH:
11036     case FFELEX_typePOWER:
11037     case FFELEX_typeCONCAT:
11038     case FFELEX_typeOPEN_ANGLE:
11039     case FFELEX_typeCLOSE_ANGLE:
11040     case FFELEX_typeREL_EQ:
11041     case FFELEX_typeREL_NE:
11042     case FFELEX_typeREL_GE:
11043     case FFELEX_typeREL_LE:
11044       return (ffelexHandler) ffeexpr_nil_rhs_;
11045 
11046     case FFELEX_typePERIOD:
11047       return (ffelexHandler) ffeexpr_nil_binary_period_;
11048 
11049     default:
11050       return (ffelexHandler) ffeexpr_nil_finished_ (t);
11051     }
11052 }
11053 
11054 static ffelexHandler
ffeexpr_nil_binary_period_(ffelexToken t)11055 ffeexpr_nil_binary_period_ (ffelexToken t)
11056 {
11057   switch (ffelex_token_type (t))
11058     {
11059     case FFELEX_typeNAME:
11060     case FFELEX_typeNAMES:
11061       ffeexpr_current_dotdot_ = ffestr_other (t);
11062       switch (ffeexpr_current_dotdot_)
11063 	{
11064 	case FFESTR_otherTRUE:
11065 	case FFESTR_otherFALSE:
11066 	case FFESTR_otherNOT:
11067 	  return (ffelexHandler) ffeexpr_nil_binary_sw_per_;
11068 
11069 	default:
11070 	  return (ffelexHandler) ffeexpr_nil_binary_end_per_;
11071 	}
11072       break;			/* Nothing really reaches here. */
11073 
11074     default:
11075       return (ffelexHandler) ffeexpr_nil_binary_ (t);
11076     }
11077 }
11078 
11079 static ffelexHandler
ffeexpr_nil_binary_end_per_(ffelexToken t)11080 ffeexpr_nil_binary_end_per_ (ffelexToken t)
11081 {
11082   if (ffelex_token_type (t) != FFELEX_typePERIOD)
11083     return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11084   return (ffelexHandler) ffeexpr_nil_rhs_;
11085 }
11086 
11087 static ffelexHandler
ffeexpr_nil_binary_sw_per_(ffelexToken t)11088 ffeexpr_nil_binary_sw_per_ (ffelexToken t)
11089 {
11090   if (ffelex_token_type (t) != FFELEX_typePERIOD)
11091     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11092   return (ffelexHandler) ffeexpr_nil_binary_;
11093 }
11094 
11095 static ffelexHandler
ffeexpr_nil_quote_(ffelexToken t)11096 ffeexpr_nil_quote_ (ffelexToken t)
11097 {
11098   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11099     return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11100   return (ffelexHandler) ffeexpr_nil_binary_;
11101 }
11102 
11103 static ffelexHandler
ffeexpr_nil_apostrophe_(ffelexToken t)11104 ffeexpr_nil_apostrophe_ (ffelexToken t)
11105 {
11106   assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
11107   return (ffelexHandler) ffeexpr_nil_apos_char_;
11108 }
11109 
11110 static ffelexHandler
ffeexpr_nil_apos_char_(ffelexToken t)11111 ffeexpr_nil_apos_char_ (ffelexToken t)
11112 {
11113   char c;
11114 
11115   if ((ffelex_token_type (t) == FFELEX_typeNAME)
11116       || (ffelex_token_type (t) == FFELEX_typeNAMES))
11117     {
11118       if ((ffelex_token_length (t) == 1)
11119 	  && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]),
11120 				      'B', 'b')
11121 	      || ffesrc_char_match_init (c, 'O', 'o')
11122 	      || ffesrc_char_match_init (c, 'X', 'x')
11123 	      || ffesrc_char_match_init (c, 'Z', 'z')))
11124 	return (ffelexHandler) ffeexpr_nil_binary_;
11125     }
11126   if ((ffelex_token_type (t) == FFELEX_typeNAME)
11127       || (ffelex_token_type (t) == FFELEX_typeNAMES))
11128     return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11129   return (ffelexHandler) ffeexpr_nil_substrp_ (t);
11130 }
11131 
11132 static ffelexHandler
ffeexpr_nil_name_rhs_(ffelexToken t)11133 ffeexpr_nil_name_rhs_ (ffelexToken t)
11134 {
11135   switch (ffelex_token_type (t))
11136     {
11137     case FFELEX_typeQUOTE:
11138     case FFELEX_typeAPOSTROPHE:
11139       ffelex_set_hexnum (TRUE);
11140       return (ffelexHandler) ffeexpr_nil_name_apos_;
11141 
11142     case FFELEX_typeOPEN_PAREN:
11143       ++ffeexpr_find_.level;
11144       return (ffelexHandler) ffeexpr_nil_rhs_;
11145 
11146     default:
11147       return (ffelexHandler) ffeexpr_nil_binary_ (t);
11148     }
11149 }
11150 
11151 static ffelexHandler
ffeexpr_nil_name_apos_(ffelexToken t)11152 ffeexpr_nil_name_apos_ (ffelexToken t)
11153 {
11154   if (ffelex_token_type (t) == FFELEX_typeNAME)
11155     return (ffelexHandler) ffeexpr_nil_name_apos_name_;
11156   return (ffelexHandler) ffeexpr_nil_binary_ (t);
11157 }
11158 
11159 static ffelexHandler
ffeexpr_nil_name_apos_name_(ffelexToken t)11160 ffeexpr_nil_name_apos_name_ (ffelexToken t)
11161 {
11162   switch (ffelex_token_type (t))
11163     {
11164     case FFELEX_typeAPOSTROPHE:
11165     case FFELEX_typeQUOTE:
11166       return (ffelexHandler) ffeexpr_nil_finished_;
11167 
11168     default:
11169       return (ffelexHandler) ffeexpr_nil_finished_ (t);
11170     }
11171 }
11172 
11173 static ffelexHandler
ffeexpr_nil_percent_(ffelexToken t)11174 ffeexpr_nil_percent_ (ffelexToken t)
11175 {
11176   switch (ffelex_token_type (t))
11177     {
11178     case FFELEX_typeNAME:
11179     case FFELEX_typeNAMES:
11180       ffeexpr_stack_->percent = ffeexpr_percent_ (t);
11181       ffeexpr_find_.t = ffelex_token_use (t);
11182       return (ffelexHandler) ffeexpr_nil_percent_name_;
11183 
11184     default:
11185       return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11186     }
11187 }
11188 
11189 /* Expects ffeexpr_find_.t.  */
11190 
11191 static ffelexHandler
ffeexpr_nil_percent_name_(ffelexToken t)11192 ffeexpr_nil_percent_name_ (ffelexToken t)
11193 {
11194   ffelexHandler nexthandler;
11195 
11196   if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
11197     {
11198       nexthandler
11199 	= (ffelexHandler) ffeexpr_nil_rhs_ (ffeexpr_find_.t);
11200       ffelex_token_kill (ffeexpr_find_.t);
11201       return (ffelexHandler) (*nexthandler) (t);
11202     }
11203 
11204   ffelex_token_kill (ffeexpr_find_.t);
11205   ++ffeexpr_find_.level;
11206   return (ffelexHandler) ffeexpr_nil_rhs_;
11207 }
11208 
11209 static ffelexHandler
ffeexpr_nil_substrp_(ffelexToken t)11210 ffeexpr_nil_substrp_ (ffelexToken t)
11211 {
11212   if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
11213     return (ffelexHandler) ffeexpr_nil_binary_ (t);
11214 
11215   ++ffeexpr_find_.level;
11216   return (ffelexHandler) ffeexpr_nil_rhs_;
11217 }
11218 
11219 /* ffeexpr_finished_ -- Reduce expression stack to one expr, finish
11220 
11221    ffelexToken t;
11222    return ffeexpr_finished_(t);
11223 
11224    Reduces expression stack to one (or zero) elements by repeatedly reducing
11225    the top operator on the stack (or, if the top element on the stack is
11226    itself an operator, issuing an error message and discarding it).  Calls
11227    finishing routine with the expression, returning the ffelexHandler it
11228    returns to the caller.  */
11229 
11230 static ffelexHandler
ffeexpr_finished_(ffelexToken t)11231 ffeexpr_finished_ (ffelexToken t)
11232 {
11233   ffeexprExpr_ operand;		/* This is B in -B or A+B. */
11234   ffebld expr;
11235   ffeexprCallback callback;
11236   ffeexprStack_ s;
11237   ffebldConstant constnode;	/* For detecting magical number. */
11238   ffelexToken ft;		/* Temporary copy of first token in
11239 				   expression. */
11240   ffelexHandler next;
11241   ffeinfo info;
11242   bool error = FALSE;
11243 
11244   while (((operand = ffeexpr_stack_->exprstack) != NULL)
11245 	 && ((operand->previous != NULL) || (operand->type != FFEEXPR_exprtypeOPERAND_)))
11246     {
11247       if (operand->type == FFEEXPR_exprtypeOPERAND_)
11248 	ffeexpr_reduce_ ();
11249       else
11250 	{
11251 	  if (ffest_ffebad_start (FFEBAD_MISSING_OPERAND_FOR_OPERATOR))
11252 	    {
11253 	      ffebad_here (0, ffelex_token_where_line (t),
11254 			   ffelex_token_where_column (t));
11255 	      ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
11256 	      ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
11257 	      ffebad_finish ();
11258 	    }
11259 	  ffeexpr_stack_->exprstack = operand->previous;	/* Pop the useless
11260 								   operator. */
11261 	  ffeexpr_expr_kill_ (operand);
11262 	}
11263     }
11264 
11265   assert ((operand == NULL) || (operand->previous == NULL));
11266 
11267   ffebld_pool_pop ();
11268   if (operand == NULL)
11269     expr = NULL;
11270   else
11271     {
11272       expr = operand->u.operand;
11273       info = ffebld_info (expr);
11274       if ((ffebld_op (expr) == FFEBLD_opCONTER)
11275 	  && (ffebld_conter_orig (expr) == NULL)
11276 	  && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
11277 	{
11278 	  ffetarget_integer_bad_magical (operand->token);
11279 	}
11280       ffeexpr_expr_kill_ (operand);
11281       ffeexpr_stack_->exprstack = NULL;
11282     }
11283 
11284   ft = ffeexpr_stack_->first_token;
11285 
11286 again:				/* :::::::::::::::::::: */
11287   switch (ffeexpr_stack_->context)
11288     {
11289     case FFEEXPR_contextLET:
11290     case FFEEXPR_contextSFUNCDEF:
11291       error = (expr == NULL)
11292 	|| (ffeinfo_rank (info) != 0);
11293       break;
11294 
11295     case FFEEXPR_contextPAREN_:
11296       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11297 	break;
11298       switch (ffeinfo_basictype (info))
11299 	{
11300 	case FFEINFO_basictypeHOLLERITH:
11301 	case FFEINFO_basictypeTYPELESS:
11302 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11303 	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11304 				  FFEEXPR_contextLET);
11305 	  break;
11306 
11307 	default:
11308 	  break;
11309 	}
11310       break;
11311 
11312     case FFEEXPR_contextPARENFILENUM_:
11313       if (ffelex_token_type (t) != FFELEX_typeCOMMA)
11314 	ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
11315       else
11316 	ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
11317       goto again;		/* :::::::::::::::::::: */
11318 
11319     case FFEEXPR_contextPARENFILEUNIT_:
11320       if (ffelex_token_type (t) != FFELEX_typeCOMMA)
11321 	ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
11322       else
11323 	ffeexpr_stack_->context = FFEEXPR_contextFILEUNIT;
11324       goto again;		/* :::::::::::::::::::: */
11325 
11326     case FFEEXPR_contextACTUALARGEXPR_:
11327     case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
11328       switch ((expr == NULL) ? FFEINFO_basictypeNONE
11329 	      : ffeinfo_basictype (info))
11330 	{
11331 	case FFEINFO_basictypeHOLLERITH:
11332 	case FFEINFO_basictypeTYPELESS:
11333 	  if (!ffe_is_ugly_args ()
11334 	      && ffebad_start (FFEBAD_ACTUALARG))
11335 	    {
11336 	      ffebad_here (0, ffelex_token_where_line (ft),
11337 			   ffelex_token_where_column (ft));
11338 	      ffebad_finish ();
11339 	    }
11340 	  break;
11341 
11342 	default:
11343 	  break;
11344 	}
11345       error = (expr != NULL) && (ffeinfo_rank (info) != 0);
11346       break;
11347 
11348     case FFEEXPR_contextACTUALARG_:
11349     case FFEEXPR_contextSFUNCDEFACTUALARG_:
11350       switch ((expr == NULL) ? FFEINFO_basictypeNONE
11351 	      : ffeinfo_basictype (info))
11352 	{
11353 	case FFEINFO_basictypeHOLLERITH:
11354 	case FFEINFO_basictypeTYPELESS:
11355 #if 0				/* Should never get here. */
11356 	  expr = ffeexpr_convert (expr, ft, ft,
11357 				  FFEINFO_basictypeINTEGER,
11358 				  FFEINFO_kindtypeINTEGERDEFAULT,
11359 				  0,
11360 				  FFETARGET_charactersizeNONE,
11361 				  FFEEXPR_contextLET);
11362 #else
11363 	  assert ("why hollerith/typeless in actualarg_?" == NULL);
11364 #endif
11365 	  break;
11366 
11367 	default:
11368 	  break;
11369 	}
11370       switch ((expr == NULL) ? FFEBLD_opANY : ffebld_op (expr))
11371 	{
11372 	case FFEBLD_opSYMTER:
11373 	case FFEBLD_opPERCENT_LOC:
11374 	case FFEBLD_opPERCENT_VAL:
11375 	case FFEBLD_opPERCENT_REF:
11376 	case FFEBLD_opPERCENT_DESCR:
11377 	  error = FALSE;
11378 	  break;
11379 
11380 	default:
11381 	  error = (expr != NULL) && (ffeinfo_rank (info) != 0);
11382 	  break;
11383 	}
11384       {
11385 	ffesymbol s;
11386 	ffeinfoWhere where;
11387 	ffeinfoKind kind;
11388 
11389 	if (!error
11390 	    && (expr != NULL)
11391 	    && (ffebld_op (expr) == FFEBLD_opSYMTER)
11392 	    && ((s = ffebld_symter (expr)), (where = ffesymbol_where (s)),
11393 		(where == FFEINFO_whereINTRINSIC)
11394 		|| (where == FFEINFO_whereGLOBAL)
11395 		|| ((where == FFEINFO_whereDUMMY)
11396 		    && ((kind = ffesymbol_kind (s)),
11397 			(kind == FFEINFO_kindFUNCTION)
11398 			|| (kind == FFEINFO_kindSUBROUTINE))))
11399 	    && !ffesymbol_explicitwhere (s))
11400 	  {
11401 	    ffebad_start (where == FFEINFO_whereINTRINSIC
11402 			  ? FFEBAD_NEED_INTRINSIC : FFEBAD_NEED_EXTERNAL);
11403 	    ffebad_here (0, ffelex_token_where_line (ft),
11404 			 ffelex_token_where_column (ft));
11405 	    ffebad_string (ffesymbol_text (s));
11406 	    ffebad_finish ();
11407 	    ffesymbol_signal_change (s);
11408 	    ffesymbol_set_explicitwhere (s, TRUE);
11409 	    ffesymbol_signal_unreported (s);
11410 	  }
11411       }
11412       break;
11413 
11414     case FFEEXPR_contextINDEX_:
11415     case FFEEXPR_contextSFUNCDEFINDEX_:
11416       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11417 	break;
11418       switch ((expr == NULL) ? FFEINFO_basictypeNONE
11419 	      : ffeinfo_basictype (info))
11420 	{
11421 	case FFEINFO_basictypeNONE:
11422 	  error = FALSE;
11423 	  break;
11424 
11425 	case FFEINFO_basictypeLOGICAL:
11426 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11427 	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11428 				  FFEEXPR_contextLET);
11429 	  /* Fall through. */
11430 	case FFEINFO_basictypeREAL:
11431 	case FFEINFO_basictypeCOMPLEX:
11432 	  if (ffe_is_pedantic ())
11433 	    {
11434 	      error = TRUE;
11435 	      break;
11436 	    }
11437 	  /* Fall through. */
11438 	case FFEINFO_basictypeHOLLERITH:
11439 	case FFEINFO_basictypeTYPELESS:
11440 	  error = FALSE;
11441 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11442 	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11443 				  FFEEXPR_contextLET);
11444 	  break;
11445 
11446 	case FFEINFO_basictypeINTEGER:
11447 	  /* Specifically, allow INTEGER(KIND=2), aka INTEGER*8, through
11448 	     unmolested.  Leave it to downstream to handle kinds.  */
11449 	  break;
11450 
11451 	default:
11452 	  error = TRUE;
11453 	  break;
11454 	}
11455       break;			/* expr==NULL ok for substring; element case
11456 				   caught by callback. */
11457 
11458     case FFEEXPR_contextRETURN:
11459       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11460 	break;
11461       switch ((expr == NULL) ? FFEINFO_basictypeNONE
11462 	      : ffeinfo_basictype (info))
11463 	{
11464 	case FFEINFO_basictypeNONE:
11465 	  error = FALSE;
11466 	  break;
11467 
11468 	case FFEINFO_basictypeLOGICAL:
11469 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11470 	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11471 				  FFEEXPR_contextLET);
11472 	  /* Fall through. */
11473 	case FFEINFO_basictypeREAL:
11474 	case FFEINFO_basictypeCOMPLEX:
11475 	  if (ffe_is_pedantic ())
11476 	    {
11477 	      error = TRUE;
11478 	      break;
11479 	    }
11480 	  /* Fall through. */
11481 	case FFEINFO_basictypeINTEGER:
11482 	case FFEINFO_basictypeHOLLERITH:
11483 	case FFEINFO_basictypeTYPELESS:
11484 	  error = FALSE;
11485 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11486 	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11487 				  FFEEXPR_contextLET);
11488 	  break;
11489 
11490 	default:
11491 	  error = TRUE;
11492 	  break;
11493 	}
11494       break;
11495 
11496     case FFEEXPR_contextDO:
11497       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11498 	break;
11499       switch (ffeinfo_basictype (info))
11500 	{
11501 	case FFEINFO_basictypeLOGICAL:
11502 	  error = !ffe_is_ugly_logint ();
11503 	  if (!ffeexpr_stack_->is_rhs)
11504 	    break;		/* Don't convert lhs variable. */
11505 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11506 				  ffeinfo_kindtype (ffebld_info (expr)), 0,
11507 				  FFETARGET_charactersizeNONE,
11508 				  FFEEXPR_contextLET);
11509 	  break;
11510 
11511 	case FFEINFO_basictypeHOLLERITH:
11512 	case FFEINFO_basictypeTYPELESS:
11513 	  if (!ffeexpr_stack_->is_rhs)
11514 	    {
11515 	      error = TRUE;
11516 	      break;		/* Don't convert lhs variable. */
11517 	    }
11518 	  break;
11519 
11520 	case FFEINFO_basictypeINTEGER:
11521 	case FFEINFO_basictypeREAL:
11522 	  break;
11523 
11524 	default:
11525 	  error = TRUE;
11526 	  break;
11527 	}
11528       if (!ffeexpr_stack_->is_rhs
11529 	  && (ffebld_op (expr) != FFEBLD_opSYMTER))
11530 	error = TRUE;
11531       break;
11532 
11533     case FFEEXPR_contextDOWHILE:
11534     case FFEEXPR_contextIF:
11535       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11536 	break;
11537       switch (ffeinfo_basictype (info))
11538 	{
11539 	case FFEINFO_basictypeINTEGER:
11540 	  error = FALSE;
11541 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11542 	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11543 				  FFEEXPR_contextLET);
11544 	  /* Fall through. */
11545 	case FFEINFO_basictypeLOGICAL:
11546 	case FFEINFO_basictypeHOLLERITH:
11547 	case FFEINFO_basictypeTYPELESS:
11548 	  error = FALSE;
11549 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11550 	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11551 				  FFEEXPR_contextLET);
11552 	  break;
11553 
11554 	default:
11555 	  error = TRUE;
11556 	  break;
11557 	}
11558       break;
11559 
11560     case FFEEXPR_contextASSIGN:
11561     case FFEEXPR_contextAGOTO:
11562       switch ((expr == NULL) ? FFEINFO_basictypeNONE
11563 	      : ffeinfo_basictype (info))
11564 	{
11565 	case FFEINFO_basictypeINTEGER:
11566 	  error = (ffeinfo_kindtype (info) != ffecom_label_kind ());
11567 	  break;
11568 
11569 	case FFEINFO_basictypeLOGICAL:
11570 	  error = !ffe_is_ugly_logint ()
11571 	    || (ffeinfo_kindtype (info) != ffecom_label_kind ());
11572 	  break;
11573 
11574 	default:
11575 	  error = TRUE;
11576 	  break;
11577 	}
11578       if ((expr == NULL) || (ffeinfo_rank (info) != 0)
11579 	  || (ffebld_op (expr) != FFEBLD_opSYMTER))
11580 	error = TRUE;
11581       break;
11582 
11583     case FFEEXPR_contextCGOTO:
11584     case FFEEXPR_contextFORMAT:
11585     case FFEEXPR_contextDIMLIST:
11586     case FFEEXPR_contextFILENUM:	/* See equiv code in _ambig_. */
11587       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11588 	break;
11589       switch (ffeinfo_basictype (info))
11590 	{
11591 	case FFEINFO_basictypeLOGICAL:
11592 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11593 	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11594 				  FFEEXPR_contextLET);
11595 	  /* Fall through. */
11596 	case FFEINFO_basictypeREAL:
11597 	case FFEINFO_basictypeCOMPLEX:
11598 	  if (ffe_is_pedantic ())
11599 	    {
11600 	      error = TRUE;
11601 	      break;
11602 	    }
11603 	  /* Fall through. */
11604 	case FFEINFO_basictypeINTEGER:
11605 	case FFEINFO_basictypeHOLLERITH:
11606 	case FFEINFO_basictypeTYPELESS:
11607 	  error = FALSE;
11608 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11609 	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11610 				  FFEEXPR_contextLET);
11611 	  break;
11612 
11613 	default:
11614 	  error = TRUE;
11615 	  break;
11616 	}
11617       break;
11618 
11619     case FFEEXPR_contextARITHIF:
11620       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11621 	break;
11622       switch (ffeinfo_basictype (info))
11623 	{
11624 	case FFEINFO_basictypeLOGICAL:
11625 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11626 	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11627 				  FFEEXPR_contextLET);
11628 	  if (ffe_is_pedantic ())
11629 	    {
11630 	      error = TRUE;
11631 	      break;
11632 	    }
11633 	  /* Fall through. */
11634 	case FFEINFO_basictypeHOLLERITH:
11635 	case FFEINFO_basictypeTYPELESS:
11636 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11637 	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11638 				  FFEEXPR_contextLET);
11639 	  /* Fall through. */
11640 	case FFEINFO_basictypeINTEGER:
11641 	case FFEINFO_basictypeREAL:
11642 	  error = FALSE;
11643 	  break;
11644 
11645 	default:
11646 	  error = TRUE;
11647 	  break;
11648 	}
11649       break;
11650 
11651     case FFEEXPR_contextSTOP:
11652       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11653 	break;
11654       switch ((expr == NULL) ? FFEINFO_basictypeNONE
11655 	      : ffeinfo_basictype (info))
11656 	{
11657 	case FFEINFO_basictypeINTEGER:
11658 	  error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
11659 	  break;
11660 
11661 	case FFEINFO_basictypeCHARACTER:
11662 	  error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT);
11663 	  break;
11664 
11665 	case FFEINFO_basictypeHOLLERITH:
11666 	case FFEINFO_basictypeTYPELESS:
11667 	  error = FALSE;
11668 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11669 	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11670 				  FFEEXPR_contextLET);
11671 	  break;
11672 
11673 	case FFEINFO_basictypeNONE:
11674 	  error = FALSE;
11675 	  break;
11676 
11677 	default:
11678 	  error = TRUE;
11679 	  break;
11680 	}
11681       if ((expr != NULL) && ((ffebld_op (expr) != FFEBLD_opCONTER)
11682 			     || (ffebld_conter_orig (expr) != NULL)))
11683 	error = TRUE;
11684       break;
11685 
11686     case FFEEXPR_contextINCLUDE:
11687       error = (expr == NULL) || (ffeinfo_rank (info) != 0)
11688 	|| (ffeinfo_basictype (info) != FFEINFO_basictypeCHARACTER)
11689 	|| (ffebld_op (expr) != FFEBLD_opCONTER)
11690 	|| (ffebld_conter_orig (expr) != NULL);
11691       break;
11692 
11693     case FFEEXPR_contextSELECTCASE:
11694       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11695 	break;
11696       switch (ffeinfo_basictype (info))
11697 	{
11698 	case FFEINFO_basictypeINTEGER:
11699 	case FFEINFO_basictypeCHARACTER:
11700 	case FFEINFO_basictypeLOGICAL:
11701 	  error = FALSE;
11702 	  break;
11703 
11704 	case FFEINFO_basictypeHOLLERITH:
11705 	case FFEINFO_basictypeTYPELESS:
11706 	  error = FALSE;
11707 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11708 	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11709 				  FFEEXPR_contextLET);
11710 	  break;
11711 
11712 	default:
11713 	  error = TRUE;
11714 	  break;
11715 	}
11716       break;
11717 
11718     case FFEEXPR_contextCASE:
11719       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11720 	break;
11721       switch ((expr == NULL) ? FFEINFO_basictypeINTEGER
11722 	      : ffeinfo_basictype (info))
11723 	{
11724 	case FFEINFO_basictypeINTEGER:
11725 	case FFEINFO_basictypeCHARACTER:
11726 	case FFEINFO_basictypeLOGICAL:
11727 	  error = FALSE;
11728 	  break;
11729 
11730 	case FFEINFO_basictypeHOLLERITH:
11731 	case FFEINFO_basictypeTYPELESS:
11732 	  error = FALSE;
11733 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11734 	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11735 				  FFEEXPR_contextLET);
11736 	  break;
11737 
11738 	default:
11739 	  error = TRUE;
11740 	  break;
11741 	}
11742       if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
11743 	error = TRUE;
11744       break;
11745 
11746     case FFEEXPR_contextCHARACTERSIZE:
11747     case FFEEXPR_contextKINDTYPE:
11748     case FFEEXPR_contextDIMLISTCOMMON:
11749       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11750 	break;
11751       switch ((expr == NULL) ? FFEINFO_basictypeNONE
11752 	      : ffeinfo_basictype (info))
11753 	{
11754 	case FFEINFO_basictypeLOGICAL:
11755 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11756 	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11757 				  FFEEXPR_contextLET);
11758 	  /* Fall through. */
11759 	case FFEINFO_basictypeREAL:
11760 	case FFEINFO_basictypeCOMPLEX:
11761 	  if (ffe_is_pedantic ())
11762 	    {
11763 	      error = TRUE;
11764 	      break;
11765 	    }
11766 	  /* Fall through. */
11767 	case FFEINFO_basictypeINTEGER:
11768 	case FFEINFO_basictypeHOLLERITH:
11769 	case FFEINFO_basictypeTYPELESS:
11770 	  error = FALSE;
11771 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11772 	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11773 				  FFEEXPR_contextLET);
11774 	  break;
11775 
11776 	default:
11777 	  error = TRUE;
11778 	  break;
11779 	}
11780       if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
11781 	error = TRUE;
11782       break;
11783 
11784     case FFEEXPR_contextEQVINDEX_:
11785       if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11786 	break;
11787       switch ((expr == NULL) ? FFEINFO_basictypeNONE
11788 	      : ffeinfo_basictype (info))
11789 	{
11790 	case FFEINFO_basictypeNONE:
11791 	  error = FALSE;
11792 	  break;
11793 
11794 	case FFEINFO_basictypeLOGICAL:
11795 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11796 	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11797 				  FFEEXPR_contextLET);
11798 	  /* Fall through. */
11799 	case FFEINFO_basictypeREAL:
11800 	case FFEINFO_basictypeCOMPLEX:
11801 	  if (ffe_is_pedantic ())
11802 	    {
11803 	      error = TRUE;
11804 	      break;
11805 	    }
11806 	  /* Fall through. */
11807 	case FFEINFO_basictypeINTEGER:
11808 	case FFEINFO_basictypeHOLLERITH:
11809 	case FFEINFO_basictypeTYPELESS:
11810 	  error = FALSE;
11811 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11812 	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11813 				  FFEEXPR_contextLET);
11814 	  break;
11815 
11816 	default:
11817 	  error = TRUE;
11818 	  break;
11819 	}
11820       if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
11821 	error = TRUE;
11822       break;
11823 
11824     case FFEEXPR_contextPARAMETER:
11825       if (ffeexpr_stack_->is_rhs)
11826 	error = (expr == NULL) || (ffeinfo_rank (info) != 0)
11827 	  || (ffebld_op (expr) != FFEBLD_opCONTER);
11828       else
11829 	error = (expr == NULL) || (ffeinfo_rank (info) != 0)
11830 	  || (ffebld_op (expr) != FFEBLD_opSYMTER);
11831       break;
11832 
11833     case FFEEXPR_contextINDEXORACTUALARG_:
11834       if (ffelex_token_type (t) == FFELEX_typeCOLON)
11835 	ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
11836       else
11837 	ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
11838       goto again;		/* :::::::::::::::::::: */
11839 
11840     case FFEEXPR_contextINDEXORACTUALARGEXPR_:
11841       if (ffelex_token_type (t) == FFELEX_typeCOLON)
11842 	ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
11843       else
11844 	ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
11845       goto again;		/* :::::::::::::::::::: */
11846 
11847     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
11848       if (ffelex_token_type (t) == FFELEX_typeCOLON)
11849 	ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
11850       else
11851 	ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
11852       goto again;		/* :::::::::::::::::::: */
11853 
11854     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
11855       if (ffelex_token_type (t) == FFELEX_typeCOLON)
11856 	ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
11857       else
11858 	ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
11859       goto again;		/* :::::::::::::::::::: */
11860 
11861     case FFEEXPR_contextIMPDOCTRL_:
11862       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11863 	break;
11864       if (!ffeexpr_stack_->is_rhs
11865 	  && (ffebld_op (expr) != FFEBLD_opSYMTER))
11866 	error = TRUE;
11867       switch (ffeinfo_basictype (info))
11868 	{
11869 	case FFEINFO_basictypeLOGICAL:
11870 	  if (! ffe_is_ugly_logint ())
11871 	    error = TRUE;
11872 	  if (! ffeexpr_stack_->is_rhs)
11873 	    break;
11874 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11875 				  ffeinfo_kindtype (info), 0,
11876 				  FFETARGET_charactersizeNONE,
11877 				  FFEEXPR_contextLET);
11878 	  break;
11879 
11880 	case FFEINFO_basictypeINTEGER:
11881 	case FFEINFO_basictypeHOLLERITH:
11882 	case FFEINFO_basictypeTYPELESS:
11883 	  break;
11884 
11885 	case FFEINFO_basictypeREAL:
11886 	  if (!ffeexpr_stack_->is_rhs
11887 	      && ffe_is_warn_surprising ()
11888 	      && !error)
11889 	    {
11890 	      ffebad_start (FFEBAD_DO_REAL);	/* See error message!!! */
11891 	      ffebad_here (0, ffelex_token_where_line (ft),
11892 			   ffelex_token_where_column (ft));
11893 	      ffebad_string (ffelex_token_text (ft));
11894 	      ffebad_finish ();
11895 	    }
11896 	  break;
11897 
11898 	default:
11899 	  error = TRUE;
11900 	  break;
11901 	}
11902       break;
11903 
11904     case FFEEXPR_contextDATAIMPDOCTRL_:
11905       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11906 	break;
11907       if (ffeexpr_stack_->is_rhs)
11908 	{
11909 	  if ((ffebld_op (expr) != FFEBLD_opCONTER)
11910 	      && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
11911 	    error = TRUE;
11912 	}
11913       else if ((ffebld_op (expr) != FFEBLD_opSYMTER)
11914 	       || (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
11915 	error = TRUE;
11916       switch (ffeinfo_basictype (info))
11917 	{
11918 	case FFEINFO_basictypeLOGICAL:
11919 	  if (! ffeexpr_stack_->is_rhs)
11920 	    break;
11921 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11922 				  ffeinfo_kindtype (info), 0,
11923 				  FFETARGET_charactersizeNONE,
11924 				  FFEEXPR_contextLET);
11925 	  /* Fall through.  */
11926 	case FFEINFO_basictypeINTEGER:
11927 	  if (ffeexpr_stack_->is_rhs
11928 	      && (ffeinfo_kindtype (ffebld_info (expr))
11929 		  != FFEINFO_kindtypeINTEGERDEFAULT))
11930 	    expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11931 				    FFEINFO_kindtypeINTEGERDEFAULT, 0,
11932 				    FFETARGET_charactersizeNONE,
11933 				    FFEEXPR_contextLET);
11934 	  break;
11935 
11936 	case FFEINFO_basictypeHOLLERITH:
11937 	case FFEINFO_basictypeTYPELESS:
11938 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11939 	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11940 				  FFEEXPR_contextLET);
11941 	  break;
11942 
11943 	case FFEINFO_basictypeREAL:
11944 	  if (!ffeexpr_stack_->is_rhs
11945 	      && ffe_is_warn_surprising ()
11946 	      && !error)
11947 	    {
11948 	      ffebad_start (FFEBAD_DO_REAL);	/* See error message!!! */
11949 	      ffebad_here (0, ffelex_token_where_line (ft),
11950 			   ffelex_token_where_column (ft));
11951 	      ffebad_string (ffelex_token_text (ft));
11952 	      ffebad_finish ();
11953 	    }
11954 	  break;
11955 
11956 	default:
11957 	  error = TRUE;
11958 	  break;
11959 	}
11960       break;
11961 
11962     case FFEEXPR_contextIMPDOITEM_:
11963       if (ffelex_token_type (t) == FFELEX_typeEQUALS)
11964 	{
11965 	  ffeexpr_stack_->is_rhs = FALSE;
11966 	  ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
11967 	  goto again;		/* :::::::::::::::::::: */
11968 	}
11969       /* Fall through. */
11970     case FFEEXPR_contextIOLIST:
11971     case FFEEXPR_contextFILEVXTCODE:
11972       switch ((expr == NULL) ? FFEINFO_basictypeNONE
11973 	      : ffeinfo_basictype (info))
11974 	{
11975 	case FFEINFO_basictypeHOLLERITH:
11976 	case FFEINFO_basictypeTYPELESS:
11977 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11978 	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11979 				  FFEEXPR_contextLET);
11980 	  break;
11981 
11982 	default:
11983 	  break;
11984 	}
11985       error = (expr == NULL)
11986 	|| ((ffeinfo_rank (info) != 0)
11987 	    && ((ffebld_op (expr) != FFEBLD_opSYMTER)
11988 		|| (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
11989 		|| (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
11990 		    == FFEBLD_opSTAR)));	/* Bad if null expr, or if
11991 						   array that is not a SYMTER
11992 						   (can't happen yet, I
11993 						   think) or has a NULL or
11994 						   STAR (assumed) array
11995 						   size. */
11996       break;
11997 
11998     case FFEEXPR_contextIMPDOITEMDF_:
11999       if (ffelex_token_type (t) == FFELEX_typeEQUALS)
12000 	{
12001 	  ffeexpr_stack_->is_rhs = FALSE;
12002 	  ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
12003 	  goto again;		/* :::::::::::::::::::: */
12004 	}
12005       /* Fall through. */
12006     case FFEEXPR_contextIOLISTDF:
12007       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12008 	      : ffeinfo_basictype (info))
12009 	{
12010 	case FFEINFO_basictypeHOLLERITH:
12011 	case FFEINFO_basictypeTYPELESS:
12012 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12013 	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12014 				  FFEEXPR_contextLET);
12015 	  break;
12016 
12017 	default:
12018 	  break;
12019 	}
12020       error
12021 	= (expr == NULL)
12022 	  || ((ffeinfo_basictype (info) == FFEINFO_basictypeCHARACTER)
12023 	      && (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT))
12024 	    || ((ffeinfo_rank (info) != 0)
12025 		&& ((ffebld_op (expr) != FFEBLD_opSYMTER)
12026 		    || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12027 		    || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12028 			== FFEBLD_opSTAR)));	/* Bad if null expr,
12029 						   non-default-kindtype
12030 						   character expr, or if
12031 						   array that is not a SYMTER
12032 						   (can't happen yet, I
12033 						   think) or has a NULL or
12034 						   STAR (assumed) array
12035 						   size. */
12036       break;
12037 
12038     case FFEEXPR_contextDATAIMPDOITEM_:
12039       error = (expr == NULL)
12040 	|| (ffebld_op (expr) != FFEBLD_opARRAYREF)
12041 	|| ((ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR)
12042 	    && (ffeinfo_where (info) != FFEINFO_whereFLEETING_IADDR));
12043       break;
12044 
12045     case FFEEXPR_contextDATAIMPDOINDEX_:
12046       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12047 	break;
12048       switch (ffeinfo_basictype (info))
12049 	{
12050 	case FFEINFO_basictypeLOGICAL:
12051 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12052 	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12053 				  FFEEXPR_contextLET);
12054 	  /* Fall through. */
12055 	case FFEINFO_basictypeREAL:
12056 	case FFEINFO_basictypeCOMPLEX:
12057 	  if (ffe_is_pedantic ())
12058 	    {
12059 	      error = TRUE;
12060 	      break;
12061 	    }
12062 	  /* Fall through. */
12063 	case FFEINFO_basictypeINTEGER:
12064 	case FFEINFO_basictypeHOLLERITH:
12065 	case FFEINFO_basictypeTYPELESS:
12066 	  error = FALSE;
12067 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12068 	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12069 				  FFEEXPR_contextLET);
12070 	  break;
12071 
12072 	default:
12073 	  error = TRUE;
12074 	  break;
12075 	}
12076       if ((ffeinfo_where (info) != FFEINFO_whereCONSTANT)
12077 	  && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12078 	error = TRUE;
12079       break;
12080 
12081     case FFEEXPR_contextDATA:
12082       if (expr == NULL)
12083 	error = TRUE;
12084       else if (ffeexpr_stack_->is_rhs)
12085 	error = (ffebld_op (expr) != FFEBLD_opCONTER);
12086       else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12087 	error = FALSE;
12088       else
12089 	error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12090       break;
12091 
12092     case FFEEXPR_contextINITVAL:
12093       error = (expr == NULL) || (ffebld_op (expr) != FFEBLD_opCONTER);
12094       break;
12095 
12096     case FFEEXPR_contextEQUIVALENCE:
12097       if (expr == NULL)
12098 	error = TRUE;
12099       else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12100 	error = FALSE;
12101       else
12102 	error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12103       break;
12104 
12105     case FFEEXPR_contextFILEASSOC:
12106     case FFEEXPR_contextFILEINT:
12107       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12108 	      : ffeinfo_basictype (info))
12109 	{
12110 	case FFEINFO_basictypeINTEGER:
12111 	  /* Maybe this should be supported someday, but, right now,
12112 	     g77 can't generate a call to libf2c to write to an
12113 	     integer other than the default size.  */
12114 	  error = ((! ffeexpr_stack_->is_rhs)
12115 		   && ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12116 	  break;
12117 
12118 	default:
12119 	  error = TRUE;
12120 	  break;
12121 	}
12122       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12123 	error = TRUE;
12124       break;
12125 
12126     case FFEEXPR_contextFILEDFINT:
12127       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12128 	      : ffeinfo_basictype (info))
12129 	{
12130 	case FFEINFO_basictypeINTEGER:
12131 	  error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12132 	  break;
12133 
12134 	default:
12135 	  error = TRUE;
12136 	  break;
12137 	}
12138       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12139 	error = TRUE;
12140       break;
12141 
12142     case FFEEXPR_contextFILELOG:
12143       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12144 	      : ffeinfo_basictype (info))
12145 	{
12146 	case FFEINFO_basictypeLOGICAL:
12147 	  error = FALSE;
12148 	  break;
12149 
12150 	default:
12151 	  error = TRUE;
12152 	  break;
12153 	}
12154       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12155 	error = TRUE;
12156       break;
12157 
12158     case FFEEXPR_contextFILECHAR:
12159       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12160 	      : ffeinfo_basictype (info))
12161 	{
12162 	case FFEINFO_basictypeCHARACTER:
12163 	  error = FALSE;
12164 	  break;
12165 
12166 	default:
12167 	  error = TRUE;
12168 	  break;
12169 	}
12170       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12171 	error = TRUE;
12172       break;
12173 
12174     case FFEEXPR_contextFILENUMCHAR:
12175       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12176 	break;
12177       switch (ffeinfo_basictype (info))
12178 	{
12179 	case FFEINFO_basictypeLOGICAL:
12180 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12181 	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12182 				  FFEEXPR_contextLET);
12183 	  /* Fall through. */
12184 	case FFEINFO_basictypeREAL:
12185 	case FFEINFO_basictypeCOMPLEX:
12186 	  if (ffe_is_pedantic ())
12187 	    {
12188 	      error = TRUE;
12189 	      break;
12190 	    }
12191 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12192 	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12193 				  FFEEXPR_contextLET);
12194 	  break;
12195 
12196 	case FFEINFO_basictypeINTEGER:
12197 	case FFEINFO_basictypeCHARACTER:
12198 	  error = FALSE;
12199 	  break;
12200 
12201 	default:
12202 	  error = TRUE;
12203 	  break;
12204 	}
12205       break;
12206 
12207     case FFEEXPR_contextFILEDFCHAR:
12208       if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12209 	break;
12210       switch (ffeinfo_basictype (info))
12211 	{
12212 	case FFEINFO_basictypeCHARACTER:
12213 	  error
12214 	    = (ffeinfo_kindtype (info)
12215 	       != FFEINFO_kindtypeCHARACTERDEFAULT);
12216 	  break;
12217 
12218 	default:
12219 	  error = TRUE;
12220 	  break;
12221 	}
12222       if (!ffeexpr_stack_->is_rhs
12223 	  && (ffebld_op (expr) == FFEBLD_opSUBSTR))
12224 	error = TRUE;
12225       break;
12226 
12227     case FFEEXPR_contextFILEUNIT:	/* See equiv code in _ambig_. */
12228       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12229 	      : ffeinfo_basictype (info))
12230 	{
12231 	case FFEINFO_basictypeLOGICAL:
12232 	  if ((error = (ffeinfo_rank (info) != 0)))
12233 	    break;
12234 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12235 	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12236 				  FFEEXPR_contextLET);
12237 	  /* Fall through. */
12238 	case FFEINFO_basictypeREAL:
12239 	case FFEINFO_basictypeCOMPLEX:
12240 	  if ((error = (ffeinfo_rank (info) != 0)))
12241 	    break;
12242 	  if (ffe_is_pedantic ())
12243 	    {
12244 	      error = TRUE;
12245 	      break;
12246 	    }
12247 	  /* Fall through. */
12248 	case FFEINFO_basictypeINTEGER:
12249 	case FFEINFO_basictypeHOLLERITH:
12250 	case FFEINFO_basictypeTYPELESS:
12251 	  if ((error = (ffeinfo_rank (info) != 0)))
12252 	    break;
12253 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12254 	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12255 				  FFEEXPR_contextLET);
12256 	  break;
12257 
12258 	case FFEINFO_basictypeCHARACTER:
12259 	  switch (ffebld_op (expr))
12260 	    {			/* As if _lhs had been called instead of
12261 				   _rhs. */
12262 	    case FFEBLD_opSYMTER:
12263 	      error
12264 		= (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
12265 	      break;
12266 
12267 	    case FFEBLD_opSUBSTR:
12268 	      error = (ffeinfo_where (ffebld_info (expr))
12269 		       == FFEINFO_whereCONSTANT_SUBOBJECT);
12270 	      break;
12271 
12272 	    case FFEBLD_opARRAYREF:
12273 	      error = FALSE;
12274 	      break;
12275 
12276 	    default:
12277 	      error = TRUE;
12278 	      break;
12279 	    }
12280 	  if (!error
12281 	   && ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
12282 	       || ((ffeinfo_rank (info) != 0)
12283 		   && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12284 		     || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12285 		  || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12286 		      == FFEBLD_opSTAR)))))	/* Bad if
12287 						   non-default-kindtype
12288 						   character expr, or if
12289 						   array that is not a SYMTER
12290 						   (can't happen yet, I
12291 						   think), or has a NULL or
12292 						   STAR (assumed) array
12293 						   size. */
12294 	    error = TRUE;
12295 	  break;
12296 
12297 	default:
12298 	  error = TRUE;
12299 	  break;
12300 	}
12301       break;
12302 
12303     case FFEEXPR_contextFILEFORMAT:
12304       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12305 	      : ffeinfo_basictype (info))
12306 	{
12307 	case FFEINFO_basictypeINTEGER:
12308 	  error = (expr == NULL)
12309 	    || ((ffeinfo_rank (info) != 0) ?
12310 		ffe_is_pedantic ()	/* F77 C5. */
12311 		: (bool) (ffeinfo_kindtype (info) != ffecom_label_kind ()))
12312 	    || (ffebld_op (expr) != FFEBLD_opSYMTER);
12313 	  break;
12314 
12315 	case FFEINFO_basictypeLOGICAL:
12316 	case FFEINFO_basictypeREAL:
12317 	case FFEINFO_basictypeCOMPLEX:
12318 	  /* F77 C5 -- must be an array of hollerith.  */
12319 	  error
12320 	    = ffe_is_pedantic ()
12321 	      || (ffeinfo_rank (info) == 0);
12322 	  break;
12323 
12324 	case FFEINFO_basictypeCHARACTER:
12325 	  if ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
12326 	      || ((ffeinfo_rank (info) != 0)
12327 		  && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12328 		      || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12329 		      || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12330 			  == FFEBLD_opSTAR))))	/* Bad if
12331 						   non-default-kindtype
12332 						   character expr, or if
12333 						   array that is not a SYMTER
12334 						   (can't happen yet, I
12335 						   think), or has a NULL or
12336 						   STAR (assumed) array
12337 						   size. */
12338 	    error = TRUE;
12339 	  else
12340 	    error = FALSE;
12341 	  break;
12342 
12343 	default:
12344 	  error = TRUE;
12345 	  break;
12346 	}
12347       break;
12348 
12349     case FFEEXPR_contextLOC_:
12350       /* See also ffeintrin_check_loc_.  */
12351       if ((expr == NULL)
12352 	  || (ffeinfo_kind (info) != FFEINFO_kindENTITY)
12353 	  || ((ffebld_op (expr) != FFEBLD_opSYMTER)
12354 	      && (ffebld_op (expr) != FFEBLD_opSUBSTR)
12355 	      && (ffebld_op (expr) != FFEBLD_opARRAYREF)))
12356 	error = TRUE;
12357       break;
12358 
12359     default:
12360       error = FALSE;
12361       break;
12362     }
12363 
12364   if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
12365     {
12366       ffebad_start (FFEBAD_EXPR_WRONG);
12367       ffebad_here (0, ffelex_token_where_line (ft),
12368 		   ffelex_token_where_column (ft));
12369       ffebad_finish ();
12370       expr = ffebld_new_any ();
12371       ffebld_set_info (expr, ffeinfo_new_any ());
12372     }
12373 
12374   callback = ffeexpr_stack_->callback;
12375   s = ffeexpr_stack_->previous;
12376   malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
12377 		  sizeof (*ffeexpr_stack_));
12378   ffeexpr_stack_ = s;
12379   next = (ffelexHandler) (*callback) (ft, expr, t);
12380   ffelex_token_kill (ft);
12381   return (ffelexHandler) next;
12382 }
12383 
12384 /* ffeexpr_finished_ambig_ -- Check validity of ambiguous unit/form spec
12385 
12386    ffebld expr;
12387    expr = ffeexpr_finished_ambig_(expr);
12388 
12389    Replicates a bit of ffeexpr_finished_'s task when in a context
12390    of UNIT or FORMAT.  */
12391 
12392 static ffebld
ffeexpr_finished_ambig_(ffelexToken ft,ffebld expr)12393 ffeexpr_finished_ambig_ (ffelexToken ft, ffebld expr)
12394 {
12395   ffeinfo info = ffebld_info (expr);
12396   bool error;
12397 
12398   switch (ffeexpr_stack_->context)
12399     {
12400     case FFEEXPR_contextFILENUMAMBIG:	/* Same as FILENUM in _finished_. */
12401       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12402 	      : ffeinfo_basictype (info))
12403 	{
12404 	case FFEINFO_basictypeLOGICAL:
12405 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12406 	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12407 				  FFEEXPR_contextLET);
12408 	  /* Fall through. */
12409 	case FFEINFO_basictypeREAL:
12410 	case FFEINFO_basictypeCOMPLEX:
12411 	  if (ffe_is_pedantic ())
12412 	    {
12413 	      error = TRUE;
12414 	      break;
12415 	    }
12416 	  /* Fall through. */
12417 	case FFEINFO_basictypeINTEGER:
12418 	case FFEINFO_basictypeHOLLERITH:
12419 	case FFEINFO_basictypeTYPELESS:
12420 	  error = FALSE;
12421 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12422 	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12423 				  FFEEXPR_contextLET);
12424 	  break;
12425 
12426 	default:
12427 	  error = TRUE;
12428 	  break;
12429 	}
12430       if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12431 	error = TRUE;
12432       break;
12433 
12434     case FFEEXPR_contextFILEUNITAMBIG:	/* Same as FILEUNIT in _finished_. */
12435       if ((expr != NULL) && (ffebld_op (expr) == FFEBLD_opSTAR))
12436 	{
12437 	  error = FALSE;
12438 	  break;
12439 	}
12440       switch ((expr == NULL) ? FFEINFO_basictypeNONE
12441 	      : ffeinfo_basictype (info))
12442 	{
12443 	case FFEINFO_basictypeLOGICAL:
12444 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12445 	     FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12446 				  FFEEXPR_contextLET);
12447 	  /* Fall through. */
12448 	case FFEINFO_basictypeREAL:
12449 	case FFEINFO_basictypeCOMPLEX:
12450 	  if (ffe_is_pedantic ())
12451 	    {
12452 	      error = TRUE;
12453 	      break;
12454 	    }
12455 	  /* Fall through. */
12456 	case FFEINFO_basictypeINTEGER:
12457 	case FFEINFO_basictypeHOLLERITH:
12458 	case FFEINFO_basictypeTYPELESS:
12459 	  error = (ffeinfo_rank (info) != 0);
12460 	  expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12461 	     FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12462 				  FFEEXPR_contextLET);
12463 	  break;
12464 
12465 	case FFEINFO_basictypeCHARACTER:
12466 	  switch (ffebld_op (expr))
12467 	    {			/* As if _lhs had been called instead of
12468 				   _rhs. */
12469 	    case FFEBLD_opSYMTER:
12470 	      error
12471 		= (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
12472 	      break;
12473 
12474 	    case FFEBLD_opSUBSTR:
12475 	      error = (ffeinfo_where (ffebld_info (expr))
12476 		       == FFEINFO_whereCONSTANT_SUBOBJECT);
12477 	      break;
12478 
12479 	    case FFEBLD_opARRAYREF:
12480 	      error = FALSE;
12481 	      break;
12482 
12483 	    default:
12484 	      error = TRUE;
12485 	      break;
12486 	    }
12487 	  break;
12488 
12489 	default:
12490 	  error = TRUE;
12491 	  break;
12492 	}
12493       break;
12494 
12495     default:
12496       assert ("bad context" == NULL);
12497       error = TRUE;
12498       break;
12499     }
12500 
12501   if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
12502     {
12503       ffebad_start (FFEBAD_EXPR_WRONG);
12504       ffebad_here (0, ffelex_token_where_line (ft),
12505 		   ffelex_token_where_column (ft));
12506       ffebad_finish ();
12507       expr = ffebld_new_any ();
12508       ffebld_set_info (expr, ffeinfo_new_any ());
12509     }
12510 
12511   return expr;
12512 }
12513 
12514 /* ffeexpr_token_lhs_ -- Initial state for lhs expression
12515 
12516    Return a pointer to this function to the lexer (ffelex), which will
12517    invoke it for the next token.
12518 
12519    Basically a smaller version of _rhs_; keep them both in sync, of course.  */
12520 
12521 static ffelexHandler
ffeexpr_token_lhs_(ffelexToken t)12522 ffeexpr_token_lhs_ (ffelexToken t)
12523 {
12524 
12525   /* When changing the list of valid initial lhs tokens, check whether to
12526      update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
12527      READ (expr) <token> case -- it assumes it knows which tokens <token> can
12528      be to indicate an lhs (or implied DO), which right now is the set
12529      {NAME,OPEN_PAREN}.
12530 
12531      This comment also appears in ffeexpr_token_first_lhs_. */
12532 
12533   switch (ffelex_token_type (t))
12534     {
12535     case FFELEX_typeNAME:
12536     case FFELEX_typeNAMES:
12537       ffeexpr_tokens_[0] = ffelex_token_use (t);
12538       return (ffelexHandler) ffeexpr_token_name_lhs_;
12539 
12540     default:
12541       return (ffelexHandler) ffeexpr_finished_ (t);
12542     }
12543 }
12544 
12545 /* ffeexpr_token_rhs_ -- Initial state for rhs expression
12546 
12547    Return a pointer to this function to the lexer (ffelex), which will
12548    invoke it for the next token.
12549 
12550    The initial state and the post-binary-operator state are the same and
12551    both handled here, with the expression stack used to distinguish
12552    between them.  Binary operators are invalid here; unary operators,
12553    constants, subexpressions, and name references are valid.  */
12554 
12555 static ffelexHandler
ffeexpr_token_rhs_(ffelexToken t)12556 ffeexpr_token_rhs_ (ffelexToken t)
12557 {
12558   ffeexprExpr_ e;
12559 
12560   switch (ffelex_token_type (t))
12561     {
12562     case FFELEX_typeQUOTE:
12563       if (ffe_is_vxt ())
12564 	{
12565 	  ffeexpr_tokens_[0] = ffelex_token_use (t);
12566 	  return (ffelexHandler) ffeexpr_token_quote_;
12567 	}
12568       ffeexpr_tokens_[0] = ffelex_token_use (t);
12569       ffelex_set_expecting_hollerith (-1, '\"',
12570 				      ffelex_token_where_line (t),
12571 				      ffelex_token_where_column (t));
12572       /* Don't have to unset this one. */
12573       return (ffelexHandler) ffeexpr_token_apostrophe_;
12574 
12575     case FFELEX_typeAPOSTROPHE:
12576       ffeexpr_tokens_[0] = ffelex_token_use (t);
12577       ffelex_set_expecting_hollerith (-1, '\'',
12578 				      ffelex_token_where_line (t),
12579 				      ffelex_token_where_column (t));
12580       /* Don't have to unset this one. */
12581       return (ffelexHandler) ffeexpr_token_apostrophe_;
12582 
12583     case FFELEX_typePERCENT:
12584       ffeexpr_tokens_[0] = ffelex_token_use (t);
12585       return (ffelexHandler) ffeexpr_token_percent_;
12586 
12587     case FFELEX_typeOPEN_PAREN:
12588       ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
12589       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
12590 					  FFEEXPR_contextPAREN_,
12591 					  ffeexpr_cb_close_paren_c_);
12592 
12593     case FFELEX_typePLUS:
12594       e = ffeexpr_expr_new_ ();
12595       e->type = FFEEXPR_exprtypeUNARY_;
12596       e->token = ffelex_token_use (t);
12597       e->u.operator.op = FFEEXPR_operatorADD_;
12598       e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
12599       e->u.operator.as = FFEEXPR_operatorassociativityADD_;
12600       ffeexpr_exprstack_push_unary_ (e);
12601       return (ffelexHandler) ffeexpr_token_rhs_;
12602 
12603     case FFELEX_typeMINUS:
12604       e = ffeexpr_expr_new_ ();
12605       e->type = FFEEXPR_exprtypeUNARY_;
12606       e->token = ffelex_token_use (t);
12607       e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
12608       e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
12609       e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
12610       ffeexpr_exprstack_push_unary_ (e);
12611       return (ffelexHandler) ffeexpr_token_rhs_;
12612 
12613     case FFELEX_typePERIOD:
12614       ffeexpr_tokens_[0] = ffelex_token_use (t);
12615       return (ffelexHandler) ffeexpr_token_period_;
12616 
12617     case FFELEX_typeNUMBER:
12618       ffeexpr_tokens_[0] = ffelex_token_use (t);
12619       ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
12620       if (ffeexpr_hollerith_count_ > 0)
12621 	ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
12622 					'\0',
12623 					ffelex_token_where_line (t),
12624 					ffelex_token_where_column (t));
12625       return (ffelexHandler) ffeexpr_token_number_;
12626 
12627     case FFELEX_typeNAME:
12628     case FFELEX_typeNAMES:
12629       ffeexpr_tokens_[0] = ffelex_token_use (t);
12630       switch (ffeexpr_stack_->context)
12631 	{
12632 	case FFEEXPR_contextACTUALARG_:
12633 	case FFEEXPR_contextINDEXORACTUALARG_:
12634 	case FFEEXPR_contextSFUNCDEFACTUALARG_:
12635 	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
12636 	  return (ffelexHandler) ffeexpr_token_name_arg_;
12637 
12638 	default:
12639 	  return (ffelexHandler) ffeexpr_token_name_rhs_;
12640 	}
12641 
12642     case FFELEX_typeASTERISK:
12643     case FFELEX_typeSLASH:
12644     case FFELEX_typePOWER:
12645     case FFELEX_typeCONCAT:
12646     case FFELEX_typeREL_EQ:
12647     case FFELEX_typeREL_NE:
12648     case FFELEX_typeREL_LE:
12649     case FFELEX_typeREL_GE:
12650       if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
12651 	{
12652 	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
12653 	  ffebad_finish ();
12654 	}
12655       return (ffelexHandler) ffeexpr_token_rhs_;
12656 
12657 #if 0
12658     case FFELEX_typeEQUALS:
12659     case FFELEX_typePOINTS:
12660     case FFELEX_typeCLOSE_ANGLE:
12661     case FFELEX_typeCLOSE_PAREN:
12662     case FFELEX_typeCOMMA:
12663     case FFELEX_typeCOLON:
12664     case FFELEX_typeEOS:
12665     case FFELEX_typeSEMICOLON:
12666 #endif
12667     default:
12668       return (ffelexHandler) ffeexpr_finished_ (t);
12669     }
12670 }
12671 
12672 /* ffeexpr_token_period_ -- Rhs PERIOD
12673 
12674    Return a pointer to this function to the lexer (ffelex), which will
12675    invoke it for the next token.
12676 
12677    Handle a period detected at rhs (expecting unary op or operand) state.
12678    Must begin a floating-point value (as in .12) or a dot-dot name, of
12679    which only .NOT., .TRUE., and .FALSE. are truly valid.  Other sort-of-
12680    valid names represent binary operators, which are invalid here because
12681    there isn't an operand at the top of the stack.  */
12682 
12683 static ffelexHandler
ffeexpr_token_period_(ffelexToken t)12684 ffeexpr_token_period_ (ffelexToken t)
12685 {
12686   switch (ffelex_token_type (t))
12687     {
12688     case FFELEX_typeNAME:
12689     case FFELEX_typeNAMES:
12690       ffeexpr_current_dotdot_ = ffestr_other (t);
12691       switch (ffeexpr_current_dotdot_)
12692 	{
12693 	case FFESTR_otherNone:
12694 	  if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
12695 	    {
12696 	      ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
12697 			   ffelex_token_where_column (ffeexpr_tokens_[0]));
12698 	      ffebad_finish ();
12699 	    }
12700 	  ffelex_token_kill (ffeexpr_tokens_[0]);
12701 	  return (ffelexHandler) ffeexpr_token_rhs_ (t);
12702 
12703 	case FFESTR_otherTRUE:
12704 	case FFESTR_otherFALSE:
12705 	case FFESTR_otherNOT:
12706 	  ffeexpr_tokens_[1] = ffelex_token_use (t);
12707 	  return (ffelexHandler) ffeexpr_token_end_period_;
12708 
12709 	default:
12710 	  if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
12711 	    {
12712 	      ffebad_here (0, ffelex_token_where_line (t),
12713 			   ffelex_token_where_column (t));
12714 	      ffebad_finish ();
12715 	    }
12716 	  ffelex_token_kill (ffeexpr_tokens_[0]);
12717 	  return (ffelexHandler) ffeexpr_token_swallow_period_;
12718 	}
12719       break;			/* Nothing really reaches here. */
12720 
12721     case FFELEX_typeNUMBER:
12722       ffeexpr_tokens_[1] = ffelex_token_use (t);
12723       return (ffelexHandler) ffeexpr_token_real_;
12724 
12725     default:
12726       if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
12727 	{
12728 	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
12729 		       ffelex_token_where_column (ffeexpr_tokens_[0]));
12730 	  ffebad_finish ();
12731 	}
12732       ffelex_token_kill (ffeexpr_tokens_[0]);
12733       return (ffelexHandler) ffeexpr_token_rhs_ (t);
12734     }
12735 }
12736 
12737 /* ffeexpr_token_end_period_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
12738 
12739    Return a pointer to this function to the lexer (ffelex), which will
12740    invoke it for the next token.
12741 
12742    Expecting a period to close a .NOT, .TRUE, or .FALSE at rhs (unary op
12743    or operator) state.	If period isn't found, issue a diagnostic but
12744    pretend we saw one.	ffeexpr_current_dotdot_ must already contained the
12745    dotdot representation of the name in between the two PERIOD tokens.	*/
12746 
12747 static ffelexHandler
ffeexpr_token_end_period_(ffelexToken t)12748 ffeexpr_token_end_period_ (ffelexToken t)
12749 {
12750   ffeexprExpr_ e;
12751 
12752   if (ffelex_token_type (t) != FFELEX_typePERIOD)
12753     {
12754       if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
12755 	{
12756 	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
12757 		       ffelex_token_where_column (ffeexpr_tokens_[0]));
12758 	  ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
12759 	  ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
12760 	  ffebad_finish ();
12761 	}
12762     }
12763 
12764   ffelex_token_kill (ffeexpr_tokens_[1]);	/* Kill "NOT"/"TRUE"/"FALSE"
12765 						   token. */
12766 
12767   e = ffeexpr_expr_new_ ();
12768   e->token = ffeexpr_tokens_[0];
12769 
12770   switch (ffeexpr_current_dotdot_)
12771     {
12772     case FFESTR_otherNOT:
12773       e->type = FFEEXPR_exprtypeUNARY_;
12774       e->u.operator.op = FFEEXPR_operatorNOT_;
12775       e->u.operator.prec = FFEEXPR_operatorprecedenceNOT_;
12776       e->u.operator.as = FFEEXPR_operatorassociativityNOT_;
12777       ffeexpr_exprstack_push_unary_ (e);
12778       if (ffelex_token_type (t) != FFELEX_typePERIOD)
12779 	return (ffelexHandler) ffeexpr_token_rhs_ (t);
12780       return (ffelexHandler) ffeexpr_token_rhs_;
12781 
12782     case FFESTR_otherTRUE:
12783       e->type = FFEEXPR_exprtypeOPERAND_;
12784       e->u.operand
12785 	= ffebld_new_conter (ffebld_constant_new_logicaldefault (TRUE));
12786       ffebld_set_info (e->u.operand,
12787       ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
12788 		   0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
12789       ffeexpr_exprstack_push_operand_ (e);
12790       if (ffelex_token_type (t) != FFELEX_typePERIOD)
12791 	return (ffelexHandler) ffeexpr_token_binary_ (t);
12792       return (ffelexHandler) ffeexpr_token_binary_;
12793 
12794     case FFESTR_otherFALSE:
12795       e->type = FFEEXPR_exprtypeOPERAND_;
12796       e->u.operand
12797 	= ffebld_new_conter (ffebld_constant_new_logicaldefault (FALSE));
12798       ffebld_set_info (e->u.operand,
12799       ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
12800 		   0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
12801       ffeexpr_exprstack_push_operand_ (e);
12802       if (ffelex_token_type (t) != FFELEX_typePERIOD)
12803 	return (ffelexHandler) ffeexpr_token_binary_ (t);
12804       return (ffelexHandler) ffeexpr_token_binary_;
12805 
12806     default:
12807       assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL);
12808       exit (0);
12809       return NULL;
12810     }
12811 }
12812 
12813 /* ffeexpr_token_swallow_period_ -- Rhs PERIOD NAME(not NOT, TRUE, or FALSE)
12814 
12815    Return a pointer to this function to the lexer (ffelex), which will
12816    invoke it for the next token.
12817 
12818    A diagnostic has already been issued; just swallow a period if there is
12819    one, then continue with ffeexpr_token_rhs_.	*/
12820 
12821 static ffelexHandler
ffeexpr_token_swallow_period_(ffelexToken t)12822 ffeexpr_token_swallow_period_ (ffelexToken t)
12823 {
12824   if (ffelex_token_type (t) != FFELEX_typePERIOD)
12825     return (ffelexHandler) ffeexpr_token_rhs_ (t);
12826 
12827   return (ffelexHandler) ffeexpr_token_rhs_;
12828 }
12829 
12830 /* ffeexpr_token_real_ -- Rhs PERIOD NUMBER
12831 
12832    Return a pointer to this function to the lexer (ffelex), which will
12833    invoke it for the next token.
12834 
12835    After a period and a string of digits, check next token for possible
12836    exponent designation (D, E, or Q as first/only character) and continue
12837    real-number handling accordingly.  Else form basic real constant, push
12838    onto expression stack, and enter binary state using current token (which,
12839    if it is a name not beginning with D, E, or Q, will certainly result
12840    in an error, but that's not for this routine to deal with).	*/
12841 
12842 static ffelexHandler
ffeexpr_token_real_(ffelexToken t)12843 ffeexpr_token_real_ (ffelexToken t)
12844 {
12845   char d;
12846   const char *p;
12847 
12848   if (((ffelex_token_type (t) != FFELEX_typeNAME)
12849        && (ffelex_token_type (t) != FFELEX_typeNAMES))
12850       || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
12851 				     'D', 'd')
12852 	     || ffesrc_char_match_init (d, 'E', 'e')
12853 	     || ffesrc_char_match_init (d, 'Q', 'q')))
12854 	   && ffeexpr_isdigits_ (++p)))
12855     {
12856 #if 0
12857       /* This code has been removed because it seems inconsistent to
12858 	 produce a diagnostic in this case, but not all of the other
12859 	 ones that look for an exponent and cannot recognize one.  */
12860       if (((ffelex_token_type (t) == FFELEX_typeNAME)
12861 	   || (ffelex_token_type (t) == FFELEX_typeNAMES))
12862 	  && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
12863 	{
12864 	  char bad[2];
12865 
12866 	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
12867 	  ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
12868 		       ffelex_token_where_column (ffeexpr_tokens_[0]));
12869 	  bad[0] = *(p - 1);
12870 	  bad[1] = '\0';
12871 	  ffebad_string (bad);
12872 	  ffebad_finish ();
12873 	}
12874 #endif
12875       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
12876 				 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
12877 				 NULL, NULL, NULL);
12878 
12879       ffelex_token_kill (ffeexpr_tokens_[0]);
12880       ffelex_token_kill (ffeexpr_tokens_[1]);
12881       return (ffelexHandler) ffeexpr_token_binary_ (t);
12882     }
12883 
12884   /* Just exponent character by itself?	 In which case, PLUS or MINUS must
12885      surely be next, followed by a NUMBER token. */
12886 
12887   if (*p == '\0')
12888     {
12889       ffeexpr_tokens_[2] = ffelex_token_use (t);
12890       return (ffelexHandler) ffeexpr_token_real_exponent_;
12891     }
12892 
12893   ffeexpr_make_float_const_ (d, NULL, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
12894 			     t, NULL, NULL);
12895 
12896   ffelex_token_kill (ffeexpr_tokens_[0]);
12897   ffelex_token_kill (ffeexpr_tokens_[1]);
12898   return (ffelexHandler) ffeexpr_token_binary_;
12899 }
12900 
12901 /* ffeexpr_token_real_exponent_ -- Rhs PERIOD NUMBER NAME(D, E, or Q)
12902 
12903    Return a pointer to this function to the lexer (ffelex), which will
12904    invoke it for the next token.
12905 
12906    Ensures this token is PLUS or MINUS, preserves it, goes to final state
12907    for real number (exponent digits).  Else issues diagnostic, assumes a
12908    zero exponent field for number, passes token on to binary state as if
12909    previous token had been "E0" instead of "E", for example.  */
12910 
12911 static ffelexHandler
ffeexpr_token_real_exponent_(ffelexToken t)12912 ffeexpr_token_real_exponent_ (ffelexToken t)
12913 {
12914   if ((ffelex_token_type (t) != FFELEX_typePLUS)
12915       && (ffelex_token_type (t) != FFELEX_typeMINUS))
12916     {
12917       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
12918 	{
12919 	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
12920 		       ffelex_token_where_column (ffeexpr_tokens_[2]));
12921 	  ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
12922 	  ffebad_finish ();
12923 	}
12924 
12925       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
12926 				 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
12927 				 NULL, NULL, NULL);
12928 
12929       ffelex_token_kill (ffeexpr_tokens_[0]);
12930       ffelex_token_kill (ffeexpr_tokens_[1]);
12931       ffelex_token_kill (ffeexpr_tokens_[2]);
12932       return (ffelexHandler) ffeexpr_token_binary_ (t);
12933     }
12934 
12935   ffeexpr_tokens_[3] = ffelex_token_use (t);
12936   return (ffelexHandler) ffeexpr_token_real_exp_sign_;
12937 }
12938 
12939 /* ffeexpr_token_real_exp_sign_ -- Rhs PERIOD NUMBER NAME(D,E,Q) PLUS/MINUS
12940 
12941    Return a pointer to this function to the lexer (ffelex), which will
12942    invoke it for the next token.
12943 
12944    Make sure token is a NUMBER, make a real constant out of all we have and
12945    push it onto the expression stack.  Else issue diagnostic and pretend
12946    exponent field was a zero.  */
12947 
12948 static ffelexHandler
ffeexpr_token_real_exp_sign_(ffelexToken t)12949 ffeexpr_token_real_exp_sign_ (ffelexToken t)
12950 {
12951   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
12952     {
12953       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
12954 	{
12955 	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
12956 		       ffelex_token_where_column (ffeexpr_tokens_[2]));
12957 	  ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
12958 	  ffebad_finish ();
12959 	}
12960 
12961       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
12962 				 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
12963 				 NULL, NULL, NULL);
12964 
12965       ffelex_token_kill (ffeexpr_tokens_[0]);
12966       ffelex_token_kill (ffeexpr_tokens_[1]);
12967       ffelex_token_kill (ffeexpr_tokens_[2]);
12968       ffelex_token_kill (ffeexpr_tokens_[3]);
12969       return (ffelexHandler) ffeexpr_token_binary_ (t);
12970     }
12971 
12972   ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0], NULL,
12973 		 ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2],
12974 			     ffeexpr_tokens_[3], t);
12975 
12976   ffelex_token_kill (ffeexpr_tokens_[0]);
12977   ffelex_token_kill (ffeexpr_tokens_[1]);
12978   ffelex_token_kill (ffeexpr_tokens_[2]);
12979   ffelex_token_kill (ffeexpr_tokens_[3]);
12980   return (ffelexHandler) ffeexpr_token_binary_;
12981 }
12982 
12983 /* ffeexpr_token_number_ -- Rhs NUMBER
12984 
12985    Return a pointer to this function to the lexer (ffelex), which will
12986    invoke it for the next token.
12987 
12988    If the token is a period, we may have a floating-point number, or an
12989    integer followed by a dotdot binary operator.  If the token is a name
12990    beginning with D, E, or Q, we definitely have a floating-point number.
12991    If the token is a hollerith constant, that's what we've got, so push
12992    it onto the expression stack and continue with the binary state.
12993 
12994    Otherwise, we have an integer followed by something the binary state
12995    should be able to swallow.  */
12996 
12997 static ffelexHandler
ffeexpr_token_number_(ffelexToken t)12998 ffeexpr_token_number_ (ffelexToken t)
12999 {
13000   ffeexprExpr_ e;
13001   ffeinfo ni;
13002   char d;
13003   const char *p;
13004 
13005   if (ffeexpr_hollerith_count_ > 0)
13006     ffelex_set_expecting_hollerith (0, '\0',
13007 				    ffewhere_line_unknown (),
13008 				    ffewhere_column_unknown ());
13009 
13010   /* See if we've got a floating-point number here. */
13011 
13012   switch (ffelex_token_type (t))
13013     {
13014     case FFELEX_typeNAME:
13015     case FFELEX_typeNAMES:
13016       if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13017 				   'D', 'd')
13018 	   || ffesrc_char_match_init (d, 'E', 'e')
13019 	   || ffesrc_char_match_init (d, 'Q', 'q'))
13020 	  && ffeexpr_isdigits_ (++p))
13021 	{
13022 
13023 	  /* Just exponent character by itself?	 In which case, PLUS or MINUS
13024 	     must surely be next, followed by a NUMBER token. */
13025 
13026 	  if (*p == '\0')
13027 	    {
13028 	      ffeexpr_tokens_[1] = ffelex_token_use (t);
13029 	      return (ffelexHandler) ffeexpr_token_number_exponent_;
13030 	    }
13031 	  ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], NULL, NULL, t,
13032 				     NULL, NULL);
13033 
13034 	  ffelex_token_kill (ffeexpr_tokens_[0]);
13035 	  return (ffelexHandler) ffeexpr_token_binary_;
13036 	}
13037       break;
13038 
13039     case FFELEX_typePERIOD:
13040       ffeexpr_tokens_[1] = ffelex_token_use (t);
13041       return (ffelexHandler) ffeexpr_token_number_period_;
13042 
13043     case FFELEX_typeHOLLERITH:
13044       e = ffeexpr_expr_new_ ();
13045       e->type = FFEEXPR_exprtypeOPERAND_;
13046       e->token = ffeexpr_tokens_[0];
13047       e->u.operand = ffebld_new_conter (ffebld_constant_new_hollerith (t));
13048       ni = ffeinfo_new (FFEINFO_basictypeHOLLERITH, FFEINFO_kindtypeNONE,
13049 			0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
13050 			ffelex_token_length (t));
13051       ffebld_set_info (e->u.operand, ni);
13052       ffeexpr_exprstack_push_operand_ (e);
13053       return (ffelexHandler) ffeexpr_token_binary_;
13054 
13055     default:
13056       break;
13057     }
13058 
13059   /* Nothing specific we were looking for, so make an integer and pass the
13060      current token to the binary state. */
13061 
13062   ffeexpr_make_float_const_ ('I', ffeexpr_tokens_[0], NULL, NULL,
13063 			     NULL, NULL, NULL);
13064   return (ffelexHandler) ffeexpr_token_binary_ (t);
13065 }
13066 
13067 /* ffeexpr_token_number_exponent_ -- Rhs NUMBER NAME(D, E, or Q)
13068 
13069    Return a pointer to this function to the lexer (ffelex), which will
13070    invoke it for the next token.
13071 
13072    Ensures this token is PLUS or MINUS, preserves it, goes to final state
13073    for real number (exponent digits).  Else treats number as integer, passes
13074    name to binary, passes current token to subsequent handler.  */
13075 
13076 static ffelexHandler
ffeexpr_token_number_exponent_(ffelexToken t)13077 ffeexpr_token_number_exponent_ (ffelexToken t)
13078 {
13079   if ((ffelex_token_type (t) != FFELEX_typePLUS)
13080       && (ffelex_token_type (t) != FFELEX_typeMINUS))
13081     {
13082       ffeexprExpr_ e;
13083       ffelexHandler nexthandler;
13084 
13085       e = ffeexpr_expr_new_ ();
13086       e->type = FFEEXPR_exprtypeOPERAND_;
13087       e->token = ffeexpr_tokens_[0];
13088       e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
13089 					(ffeexpr_tokens_[0]));
13090       ffebld_set_info (e->u.operand,
13091       ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT,
13092 		   0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13093       ffeexpr_exprstack_push_operand_ (e);
13094       nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[1]);
13095       ffelex_token_kill (ffeexpr_tokens_[1]);
13096       return (ffelexHandler) (*nexthandler) (t);
13097     }
13098 
13099   ffeexpr_tokens_[2] = ffelex_token_use (t);
13100   return (ffelexHandler) ffeexpr_token_number_exp_sign_;
13101 }
13102 
13103 /* ffeexpr_token_number_exp_sign_ -- Rhs NUMBER NAME(D,E,Q) PLUS/MINUS
13104 
13105    Return a pointer to this function to the lexer (ffelex), which will
13106    invoke it for the next token.
13107 
13108    Make sure token is a NUMBER, make a real constant out of all we have and
13109    push it onto the expression stack.  Else issue diagnostic and pretend
13110    exponent field was a zero.  */
13111 
13112 static ffelexHandler
ffeexpr_token_number_exp_sign_(ffelexToken t)13113 ffeexpr_token_number_exp_sign_ (ffelexToken t)
13114 {
13115   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13116     {
13117       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13118 	{
13119 	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[1]),
13120 		       ffelex_token_where_column (ffeexpr_tokens_[1]));
13121 	  ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13122 	  ffebad_finish ();
13123 	}
13124 
13125       ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
13126 				 ffeexpr_tokens_[0], NULL, NULL,
13127 				 ffeexpr_tokens_[1], ffeexpr_tokens_[2],
13128 				 NULL);
13129 
13130       ffelex_token_kill (ffeexpr_tokens_[0]);
13131       ffelex_token_kill (ffeexpr_tokens_[1]);
13132       ffelex_token_kill (ffeexpr_tokens_[2]);
13133       return (ffelexHandler) ffeexpr_token_binary_ (t);
13134     }
13135 
13136   ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
13137 			     ffeexpr_tokens_[0], NULL, NULL,
13138 			     ffeexpr_tokens_[1], ffeexpr_tokens_[2], t);
13139 
13140   ffelex_token_kill (ffeexpr_tokens_[0]);
13141   ffelex_token_kill (ffeexpr_tokens_[1]);
13142   ffelex_token_kill (ffeexpr_tokens_[2]);
13143   return (ffelexHandler) ffeexpr_token_binary_;
13144 }
13145 
13146 /* ffeexpr_token_number_period_ -- Rhs NUMBER PERIOD
13147 
13148    Return a pointer to this function to the lexer (ffelex), which will
13149    invoke it for the next token.
13150 
13151    Handle a period detected following a number at rhs state.  Must begin a
13152    floating-point value (as in 1., 1.2, 1.E3, or 1.E+3) or a dot-dot name.  */
13153 
13154 static ffelexHandler
ffeexpr_token_number_period_(ffelexToken t)13155 ffeexpr_token_number_period_ (ffelexToken t)
13156 {
13157   ffeexprExpr_ e;
13158   ffelexHandler nexthandler;
13159   const char *p;
13160   char d;
13161 
13162   switch (ffelex_token_type (t))
13163     {
13164     case FFELEX_typeNAME:
13165     case FFELEX_typeNAMES:
13166       if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13167 				   'D', 'd')
13168 	   || ffesrc_char_match_init (d, 'E', 'e')
13169 	   || ffesrc_char_match_init (d, 'Q', 'q'))
13170 	  && ffeexpr_isdigits_ (++p))
13171 	{
13172 
13173 	  /* Just exponent character by itself?	 In which case, PLUS or MINUS
13174 	     must surely be next, followed by a NUMBER token. */
13175 
13176 	  if (*p == '\0')
13177 	    {
13178 	      ffeexpr_tokens_[2] = ffelex_token_use (t);
13179 	      return (ffelexHandler) ffeexpr_token_number_per_exp_;
13180 	    }
13181 	  ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0],
13182 				     ffeexpr_tokens_[1], NULL, t, NULL,
13183 				     NULL);
13184 
13185 	  ffelex_token_kill (ffeexpr_tokens_[0]);
13186 	  ffelex_token_kill (ffeexpr_tokens_[1]);
13187 	  return (ffelexHandler) ffeexpr_token_binary_;
13188 	}
13189       /* A name not representing an exponent, so assume it will be something
13190 	 like EQ, make an integer from the number, pass the period to binary
13191 	 state and the current token to the resulting state. */
13192 
13193       e = ffeexpr_expr_new_ ();
13194       e->type = FFEEXPR_exprtypeOPERAND_;
13195       e->token = ffeexpr_tokens_[0];
13196       e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
13197 					(ffeexpr_tokens_[0]));
13198       ffebld_set_info (e->u.operand,
13199 		       ffeinfo_new (FFEINFO_basictypeINTEGER,
13200 				    FFEINFO_kindtypeINTEGERDEFAULT, 0,
13201 				  FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
13202 				    FFETARGET_charactersizeNONE));
13203       ffeexpr_exprstack_push_operand_ (e);
13204       nexthandler = (ffelexHandler) ffeexpr_token_binary_
13205 	(ffeexpr_tokens_[1]);
13206       ffelex_token_kill (ffeexpr_tokens_[1]);
13207       return (ffelexHandler) (*nexthandler) (t);
13208 
13209     case FFELEX_typeNUMBER:
13210       ffeexpr_tokens_[2] = ffelex_token_use (t);
13211       return (ffelexHandler) ffeexpr_token_number_real_;
13212 
13213     default:
13214       break;
13215     }
13216 
13217   /* Nothing specific we were looking for, so make a real number and pass the
13218      period and then the current token to the binary state. */
13219 
13220   ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13221 			     ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13222 			     NULL, NULL, NULL, NULL);
13223 
13224   ffelex_token_kill (ffeexpr_tokens_[0]);
13225   ffelex_token_kill (ffeexpr_tokens_[1]);
13226   return (ffelexHandler) ffeexpr_token_binary_ (t);
13227 }
13228 
13229 /* ffeexpr_token_number_per_exp_ -- Rhs NUMBER PERIOD NAME(D, E, or Q)
13230 
13231    Return a pointer to this function to the lexer (ffelex), which will
13232    invoke it for the next token.
13233 
13234    Ensures this token is PLUS or MINUS, preserves it, goes to final state
13235    for real number (exponent digits).  Else treats number as real, passes
13236    name to binary, passes current token to subsequent handler.	*/
13237 
13238 static ffelexHandler
ffeexpr_token_number_per_exp_(ffelexToken t)13239 ffeexpr_token_number_per_exp_ (ffelexToken t)
13240 {
13241   if ((ffelex_token_type (t) != FFELEX_typePLUS)
13242       && (ffelex_token_type (t) != FFELEX_typeMINUS))
13243     {
13244       ffelexHandler nexthandler;
13245 
13246       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13247 				 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13248 				 NULL, NULL, NULL, NULL);
13249 
13250       ffelex_token_kill (ffeexpr_tokens_[0]);
13251       ffelex_token_kill (ffeexpr_tokens_[1]);
13252       nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[2]);
13253       ffelex_token_kill (ffeexpr_tokens_[2]);
13254       return (ffelexHandler) (*nexthandler) (t);
13255     }
13256 
13257   ffeexpr_tokens_[3] = ffelex_token_use (t);
13258   return (ffelexHandler) ffeexpr_token_num_per_exp_sign_;
13259 }
13260 
13261 /* ffeexpr_token_number_real_ -- Rhs NUMBER PERIOD NUMBER
13262 
13263    Return a pointer to this function to the lexer (ffelex), which will
13264    invoke it for the next token.
13265 
13266    After a number, period, and number, check next token for possible
13267    exponent designation (D, E, or Q as first/only character) and continue
13268    real-number handling accordingly.  Else form basic real constant, push
13269    onto expression stack, and enter binary state using current token (which,
13270    if it is a name not beginning with D, E, or Q, will certainly result
13271    in an error, but that's not for this routine to deal with).	*/
13272 
13273 static ffelexHandler
ffeexpr_token_number_real_(ffelexToken t)13274 ffeexpr_token_number_real_ (ffelexToken t)
13275 {
13276   char d;
13277   const char *p;
13278 
13279   if (((ffelex_token_type (t) != FFELEX_typeNAME)
13280        && (ffelex_token_type (t) != FFELEX_typeNAMES))
13281       || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13282 				     'D', 'd')
13283 	     || ffesrc_char_match_init (d, 'E', 'e')
13284 	     || ffesrc_char_match_init (d, 'Q', 'q')))
13285 	   && ffeexpr_isdigits_ (++p)))
13286     {
13287 #if 0
13288       /* This code has been removed because it seems inconsistent to
13289 	 produce a diagnostic in this case, but not all of the other
13290 	 ones that look for an exponent and cannot recognize one.  */
13291       if (((ffelex_token_type (t) == FFELEX_typeNAME)
13292 	   || (ffelex_token_type (t) == FFELEX_typeNAMES))
13293 	  && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
13294 	{
13295 	  char bad[2];
13296 
13297 	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13298 	  ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
13299 		       ffelex_token_where_column (ffeexpr_tokens_[0]));
13300 	  bad[0] = *(p - 1);
13301 	  bad[1] = '\0';
13302 	  ffebad_string (bad);
13303 	  ffebad_finish ();
13304 	}
13305 #endif
13306       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13307 				 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13308 				 ffeexpr_tokens_[2], NULL, NULL, NULL);
13309 
13310       ffelex_token_kill (ffeexpr_tokens_[0]);
13311       ffelex_token_kill (ffeexpr_tokens_[1]);
13312       ffelex_token_kill (ffeexpr_tokens_[2]);
13313       return (ffelexHandler) ffeexpr_token_binary_ (t);
13314     }
13315 
13316   /* Just exponent character by itself?	 In which case, PLUS or MINUS must
13317      surely be next, followed by a NUMBER token. */
13318 
13319   if (*p == '\0')
13320     {
13321       ffeexpr_tokens_[3] = ffelex_token_use (t);
13322       return (ffelexHandler) ffeexpr_token_number_real_exp_;
13323     }
13324 
13325   ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13326 			     ffeexpr_tokens_[2], t, NULL, NULL);
13327 
13328   ffelex_token_kill (ffeexpr_tokens_[0]);
13329   ffelex_token_kill (ffeexpr_tokens_[1]);
13330   ffelex_token_kill (ffeexpr_tokens_[2]);
13331   return (ffelexHandler) ffeexpr_token_binary_;
13332 }
13333 
13334 /* ffeexpr_token_num_per_exp_sign_ -- Rhs NUMBER PERIOD NAME(D,E,Q) PLUS/MINUS
13335 
13336    Return a pointer to this function to the lexer (ffelex), which will
13337    invoke it for the next token.
13338 
13339    Make sure token is a NUMBER, make a real constant out of all we have and
13340    push it onto the expression stack.  Else issue diagnostic and pretend
13341    exponent field was a zero.  */
13342 
13343 static ffelexHandler
ffeexpr_token_num_per_exp_sign_(ffelexToken t)13344 ffeexpr_token_num_per_exp_sign_ (ffelexToken t)
13345 {
13346   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13347     {
13348       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13349 	{
13350 	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
13351 		       ffelex_token_where_column (ffeexpr_tokens_[2]));
13352 	  ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13353 	  ffebad_finish ();
13354 	}
13355 
13356       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13357 				 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13358 				 NULL, NULL, NULL, NULL);
13359 
13360       ffelex_token_kill (ffeexpr_tokens_[0]);
13361       ffelex_token_kill (ffeexpr_tokens_[1]);
13362       ffelex_token_kill (ffeexpr_tokens_[2]);
13363       ffelex_token_kill (ffeexpr_tokens_[3]);
13364       return (ffelexHandler) ffeexpr_token_binary_ (t);
13365     }
13366 
13367   ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0],
13368 			     ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL,
13369 			     ffeexpr_tokens_[2], ffeexpr_tokens_[3], t);
13370 
13371   ffelex_token_kill (ffeexpr_tokens_[0]);
13372   ffelex_token_kill (ffeexpr_tokens_[1]);
13373   ffelex_token_kill (ffeexpr_tokens_[2]);
13374   ffelex_token_kill (ffeexpr_tokens_[3]);
13375   return (ffelexHandler) ffeexpr_token_binary_;
13376 }
13377 
13378 /* ffeexpr_token_number_real_exp_ -- Rhs NUMBER PERIOD NUMBER NAME(D, E, or Q)
13379 
13380    Return a pointer to this function to the lexer (ffelex), which will
13381    invoke it for the next token.
13382 
13383    Ensures this token is PLUS or MINUS, preserves it, goes to final state
13384    for real number (exponent digits).  Else issues diagnostic, assumes a
13385    zero exponent field for number, passes token on to binary state as if
13386    previous token had been "E0" instead of "E", for example.  */
13387 
13388 static ffelexHandler
ffeexpr_token_number_real_exp_(ffelexToken t)13389 ffeexpr_token_number_real_exp_ (ffelexToken t)
13390 {
13391   if ((ffelex_token_type (t) != FFELEX_typePLUS)
13392       && (ffelex_token_type (t) != FFELEX_typeMINUS))
13393     {
13394       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13395 	{
13396 	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
13397 		       ffelex_token_where_column (ffeexpr_tokens_[3]));
13398 	  ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13399 	  ffebad_finish ();
13400 	}
13401 
13402       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13403 				 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13404 				 ffeexpr_tokens_[2], NULL, NULL, NULL);
13405 
13406       ffelex_token_kill (ffeexpr_tokens_[0]);
13407       ffelex_token_kill (ffeexpr_tokens_[1]);
13408       ffelex_token_kill (ffeexpr_tokens_[2]);
13409       ffelex_token_kill (ffeexpr_tokens_[3]);
13410       return (ffelexHandler) ffeexpr_token_binary_ (t);
13411     }
13412 
13413   ffeexpr_tokens_[4] = ffelex_token_use (t);
13414   return (ffelexHandler) ffeexpr_token_num_real_exp_sn_;
13415 }
13416 
13417 /* ffeexpr_token_num_real_exp_sn_ -- Rhs NUMBER PERIOD NUMBER NAME(D,E,Q)
13418 				  PLUS/MINUS
13419 
13420    Return a pointer to this function to the lexer (ffelex), which will
13421    invoke it for the next token.
13422 
13423    Make sure token is a NUMBER, make a real constant out of all we have and
13424    push it onto the expression stack.  Else issue diagnostic and pretend
13425    exponent field was a zero.  */
13426 
13427 static ffelexHandler
ffeexpr_token_num_real_exp_sn_(ffelexToken t)13428 ffeexpr_token_num_real_exp_sn_ (ffelexToken t)
13429 {
13430   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13431     {
13432       if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13433 	{
13434 	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
13435 		       ffelex_token_where_column (ffeexpr_tokens_[3]));
13436 	  ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13437 	  ffebad_finish ();
13438 	}
13439 
13440       ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13441 				 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13442 				 ffeexpr_tokens_[2], NULL, NULL, NULL);
13443 
13444       ffelex_token_kill (ffeexpr_tokens_[0]);
13445       ffelex_token_kill (ffeexpr_tokens_[1]);
13446       ffelex_token_kill (ffeexpr_tokens_[2]);
13447       ffelex_token_kill (ffeexpr_tokens_[3]);
13448       ffelex_token_kill (ffeexpr_tokens_[4]);
13449       return (ffelexHandler) ffeexpr_token_binary_ (t);
13450     }
13451 
13452   ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[3])[0],
13453 			     ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13454 			     ffeexpr_tokens_[2], ffeexpr_tokens_[3],
13455 			     ffeexpr_tokens_[4], t);
13456 
13457   ffelex_token_kill (ffeexpr_tokens_[0]);
13458   ffelex_token_kill (ffeexpr_tokens_[1]);
13459   ffelex_token_kill (ffeexpr_tokens_[2]);
13460   ffelex_token_kill (ffeexpr_tokens_[3]);
13461   ffelex_token_kill (ffeexpr_tokens_[4]);
13462   return (ffelexHandler) ffeexpr_token_binary_;
13463 }
13464 
13465 /* ffeexpr_token_binary_ -- Handle binary operator possibility
13466 
13467    Return a pointer to this function to the lexer (ffelex), which will
13468    invoke it for the next token.
13469 
13470    The possibility of a binary operator is handled here, meaning the previous
13471    token was an operand.  */
13472 
13473 static ffelexHandler
ffeexpr_token_binary_(ffelexToken t)13474 ffeexpr_token_binary_ (ffelexToken t)
13475 {
13476   ffeexprExpr_ e;
13477 
13478   if (!ffeexpr_stack_->is_rhs)
13479     return (ffelexHandler) ffeexpr_finished_ (t);	/* For now. */
13480 
13481   switch (ffelex_token_type (t))
13482     {
13483     case FFELEX_typePLUS:
13484       e = ffeexpr_expr_new_ ();
13485       e->type = FFEEXPR_exprtypeBINARY_;
13486       e->token = ffelex_token_use (t);
13487       e->u.operator.op = FFEEXPR_operatorADD_;
13488       e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
13489       e->u.operator.as = FFEEXPR_operatorassociativityADD_;
13490       ffeexpr_exprstack_push_binary_ (e);
13491       return (ffelexHandler) ffeexpr_token_rhs_;
13492 
13493     case FFELEX_typeMINUS:
13494       e = ffeexpr_expr_new_ ();
13495       e->type = FFEEXPR_exprtypeBINARY_;
13496       e->token = ffelex_token_use (t);
13497       e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
13498       e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
13499       e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
13500       ffeexpr_exprstack_push_binary_ (e);
13501       return (ffelexHandler) ffeexpr_token_rhs_;
13502 
13503     case FFELEX_typeASTERISK:
13504       switch (ffeexpr_stack_->context)
13505 	{
13506 	case FFEEXPR_contextDATA:
13507 	  return (ffelexHandler) ffeexpr_finished_ (t);
13508 
13509 	default:
13510 	  break;
13511 	}
13512       e = ffeexpr_expr_new_ ();
13513       e->type = FFEEXPR_exprtypeBINARY_;
13514       e->token = ffelex_token_use (t);
13515       e->u.operator.op = FFEEXPR_operatorMULTIPLY_;
13516       e->u.operator.prec = FFEEXPR_operatorprecedenceMULTIPLY_;
13517       e->u.operator.as = FFEEXPR_operatorassociativityMULTIPLY_;
13518       ffeexpr_exprstack_push_binary_ (e);
13519       return (ffelexHandler) ffeexpr_token_rhs_;
13520 
13521     case FFELEX_typeSLASH:
13522       switch (ffeexpr_stack_->context)
13523 	{
13524 	case FFEEXPR_contextDATA:
13525 	  return (ffelexHandler) ffeexpr_finished_ (t);
13526 
13527 	default:
13528 	  break;
13529 	}
13530       e = ffeexpr_expr_new_ ();
13531       e->type = FFEEXPR_exprtypeBINARY_;
13532       e->token = ffelex_token_use (t);
13533       e->u.operator.op = FFEEXPR_operatorDIVIDE_;
13534       e->u.operator.prec = FFEEXPR_operatorprecedenceDIVIDE_;
13535       e->u.operator.as = FFEEXPR_operatorassociativityDIVIDE_;
13536       ffeexpr_exprstack_push_binary_ (e);
13537       return (ffelexHandler) ffeexpr_token_rhs_;
13538 
13539     case FFELEX_typePOWER:
13540       e = ffeexpr_expr_new_ ();
13541       e->type = FFEEXPR_exprtypeBINARY_;
13542       e->token = ffelex_token_use (t);
13543       e->u.operator.op = FFEEXPR_operatorPOWER_;
13544       e->u.operator.prec = FFEEXPR_operatorprecedencePOWER_;
13545       e->u.operator.as = FFEEXPR_operatorassociativityPOWER_;
13546       ffeexpr_exprstack_push_binary_ (e);
13547       return (ffelexHandler) ffeexpr_token_rhs_;
13548 
13549     case FFELEX_typeCONCAT:
13550       e = ffeexpr_expr_new_ ();
13551       e->type = FFEEXPR_exprtypeBINARY_;
13552       e->token = ffelex_token_use (t);
13553       e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
13554       e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
13555       e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
13556       ffeexpr_exprstack_push_binary_ (e);
13557       return (ffelexHandler) ffeexpr_token_rhs_;
13558 
13559     case FFELEX_typeOPEN_ANGLE:
13560       switch (ffeexpr_stack_->context)
13561 	{
13562 	case FFEEXPR_contextFORMAT:
13563 	  ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13564 	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13565 	  ffebad_finish ();
13566 	  break;
13567 
13568 	default:
13569 	  break;
13570 	}
13571       e = ffeexpr_expr_new_ ();
13572       e->type = FFEEXPR_exprtypeBINARY_;
13573       e->token = ffelex_token_use (t);
13574       e->u.operator.op = FFEEXPR_operatorLT_;
13575       e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
13576       e->u.operator.as = FFEEXPR_operatorassociativityLT_;
13577       ffeexpr_exprstack_push_binary_ (e);
13578       return (ffelexHandler) ffeexpr_token_rhs_;
13579 
13580     case FFELEX_typeCLOSE_ANGLE:
13581       switch (ffeexpr_stack_->context)
13582 	{
13583 	case FFEEXPR_contextFORMAT:
13584 	  return ffeexpr_finished_ (t);
13585 
13586 	default:
13587 	  break;
13588 	}
13589       e = ffeexpr_expr_new_ ();
13590       e->type = FFEEXPR_exprtypeBINARY_;
13591       e->token = ffelex_token_use (t);
13592       e->u.operator.op = FFEEXPR_operatorGT_;
13593       e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
13594       e->u.operator.as = FFEEXPR_operatorassociativityGT_;
13595       ffeexpr_exprstack_push_binary_ (e);
13596       return (ffelexHandler) ffeexpr_token_rhs_;
13597 
13598     case FFELEX_typeREL_EQ:
13599       switch (ffeexpr_stack_->context)
13600 	{
13601 	case FFEEXPR_contextFORMAT:
13602 	  ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13603 	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13604 	  ffebad_finish ();
13605 	  break;
13606 
13607 	default:
13608 	  break;
13609 	}
13610       e = ffeexpr_expr_new_ ();
13611       e->type = FFEEXPR_exprtypeBINARY_;
13612       e->token = ffelex_token_use (t);
13613       e->u.operator.op = FFEEXPR_operatorEQ_;
13614       e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
13615       e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
13616       ffeexpr_exprstack_push_binary_ (e);
13617       return (ffelexHandler) ffeexpr_token_rhs_;
13618 
13619     case FFELEX_typeREL_NE:
13620       switch (ffeexpr_stack_->context)
13621 	{
13622 	case FFEEXPR_contextFORMAT:
13623 	  ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13624 	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13625 	  ffebad_finish ();
13626 	  break;
13627 
13628 	default:
13629 	  break;
13630 	}
13631       e = ffeexpr_expr_new_ ();
13632       e->type = FFEEXPR_exprtypeBINARY_;
13633       e->token = ffelex_token_use (t);
13634       e->u.operator.op = FFEEXPR_operatorNE_;
13635       e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
13636       e->u.operator.as = FFEEXPR_operatorassociativityNE_;
13637       ffeexpr_exprstack_push_binary_ (e);
13638       return (ffelexHandler) ffeexpr_token_rhs_;
13639 
13640     case FFELEX_typeREL_LE:
13641       switch (ffeexpr_stack_->context)
13642 	{
13643 	case FFEEXPR_contextFORMAT:
13644 	  ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13645 	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13646 	  ffebad_finish ();
13647 	  break;
13648 
13649 	default:
13650 	  break;
13651 	}
13652       e = ffeexpr_expr_new_ ();
13653       e->type = FFEEXPR_exprtypeBINARY_;
13654       e->token = ffelex_token_use (t);
13655       e->u.operator.op = FFEEXPR_operatorLE_;
13656       e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
13657       e->u.operator.as = FFEEXPR_operatorassociativityLE_;
13658       ffeexpr_exprstack_push_binary_ (e);
13659       return (ffelexHandler) ffeexpr_token_rhs_;
13660 
13661     case FFELEX_typeREL_GE:
13662       switch (ffeexpr_stack_->context)
13663 	{
13664 	case FFEEXPR_contextFORMAT:
13665 	  ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13666 	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13667 	  ffebad_finish ();
13668 	  break;
13669 
13670 	default:
13671 	  break;
13672 	}
13673       e = ffeexpr_expr_new_ ();
13674       e->type = FFEEXPR_exprtypeBINARY_;
13675       e->token = ffelex_token_use (t);
13676       e->u.operator.op = FFEEXPR_operatorGE_;
13677       e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
13678       e->u.operator.as = FFEEXPR_operatorassociativityGE_;
13679       ffeexpr_exprstack_push_binary_ (e);
13680       return (ffelexHandler) ffeexpr_token_rhs_;
13681 
13682     case FFELEX_typePERIOD:
13683       ffeexpr_tokens_[0] = ffelex_token_use (t);
13684       return (ffelexHandler) ffeexpr_token_binary_period_;
13685 
13686 #if 0
13687     case FFELEX_typeOPEN_PAREN:
13688     case FFELEX_typeCLOSE_PAREN:
13689     case FFELEX_typeEQUALS:
13690     case FFELEX_typePOINTS:
13691     case FFELEX_typeCOMMA:
13692     case FFELEX_typeCOLON:
13693     case FFELEX_typeEOS:
13694     case FFELEX_typeSEMICOLON:
13695     case FFELEX_typeNAME:
13696     case FFELEX_typeNAMES:
13697 #endif
13698     default:
13699       return (ffelexHandler) ffeexpr_finished_ (t);
13700     }
13701 }
13702 
13703 /* ffeexpr_token_binary_period_ -- Binary PERIOD
13704 
13705    Return a pointer to this function to the lexer (ffelex), which will
13706    invoke it for the next token.
13707 
13708    Handle a period detected at binary (expecting binary op or end) state.
13709    Must begin a dot-dot name, of which .NOT., .TRUE., and .FALSE. are not
13710    valid.  */
13711 
13712 static ffelexHandler
ffeexpr_token_binary_period_(ffelexToken t)13713 ffeexpr_token_binary_period_ (ffelexToken t)
13714 {
13715   ffeexprExpr_ operand;
13716 
13717   switch (ffelex_token_type (t))
13718     {
13719     case FFELEX_typeNAME:
13720     case FFELEX_typeNAMES:
13721       ffeexpr_current_dotdot_ = ffestr_other (t);
13722       switch (ffeexpr_current_dotdot_)
13723 	{
13724 	case FFESTR_otherTRUE:
13725 	case FFESTR_otherFALSE:
13726 	case FFESTR_otherNOT:
13727 	  if (ffest_ffebad_start (FFEBAD_MISSING_BINARY_OPERATOR))
13728 	    {
13729 	      operand = ffeexpr_stack_->exprstack;
13730 	      assert (operand != NULL);
13731 	      assert (operand->type == FFEEXPR_exprtypeOPERAND_);
13732 	      ffebad_here (0, ffelex_token_where_line (operand->token), ffelex_token_where_column (operand->token));
13733 	      ffebad_here (1, ffelex_token_where_line (t),
13734 			   ffelex_token_where_column (t));
13735 	      ffebad_finish ();
13736 	    }
13737 	  ffelex_token_kill (ffeexpr_tokens_[0]);
13738 	  return (ffelexHandler) ffeexpr_token_binary_sw_per_;
13739 
13740 	default:
13741 	  ffeexpr_tokens_[1] = ffelex_token_use (t);
13742 	  return (ffelexHandler) ffeexpr_token_binary_end_per_;
13743 	}
13744       break;			/* Nothing really reaches here. */
13745 
13746     default:
13747       if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
13748 	{
13749 	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13750 		       ffelex_token_where_column (ffeexpr_tokens_[0]));
13751 	  ffebad_finish ();
13752 	}
13753       ffelex_token_kill (ffeexpr_tokens_[0]);
13754       return (ffelexHandler) ffeexpr_token_binary_ (t);
13755     }
13756 }
13757 
13758 /* ffeexpr_token_binary_end_per_ -- Binary PERIOD NAME(not NOT, TRUE, or FALSE)
13759 
13760    Return a pointer to this function to the lexer (ffelex), which will
13761    invoke it for the next token.
13762 
13763    Expecting a period to close a dot-dot at binary (binary op
13764    or operator) state.	If period isn't found, issue a diagnostic but
13765    pretend we saw one.	ffeexpr_current_dotdot_ must already contained the
13766    dotdot representation of the name in between the two PERIOD tokens.	*/
13767 
13768 static ffelexHandler
ffeexpr_token_binary_end_per_(ffelexToken t)13769 ffeexpr_token_binary_end_per_ (ffelexToken t)
13770 {
13771   ffeexprExpr_ e;
13772 
13773   e = ffeexpr_expr_new_ ();
13774   e->type = FFEEXPR_exprtypeBINARY_;
13775   e->token = ffeexpr_tokens_[0];
13776 
13777   switch (ffeexpr_current_dotdot_)
13778     {
13779     case FFESTR_otherAND:
13780       e->u.operator.op = FFEEXPR_operatorAND_;
13781       e->u.operator.prec = FFEEXPR_operatorprecedenceAND_;
13782       e->u.operator.as = FFEEXPR_operatorassociativityAND_;
13783       break;
13784 
13785     case FFESTR_otherOR:
13786       e->u.operator.op = FFEEXPR_operatorOR_;
13787       e->u.operator.prec = FFEEXPR_operatorprecedenceOR_;
13788       e->u.operator.as = FFEEXPR_operatorassociativityOR_;
13789       break;
13790 
13791     case FFESTR_otherXOR:
13792       e->u.operator.op = FFEEXPR_operatorXOR_;
13793       e->u.operator.prec = FFEEXPR_operatorprecedenceXOR_;
13794       e->u.operator.as = FFEEXPR_operatorassociativityXOR_;
13795       break;
13796 
13797     case FFESTR_otherEQV:
13798       e->u.operator.op = FFEEXPR_operatorEQV_;
13799       e->u.operator.prec = FFEEXPR_operatorprecedenceEQV_;
13800       e->u.operator.as = FFEEXPR_operatorassociativityEQV_;
13801       break;
13802 
13803     case FFESTR_otherNEQV:
13804       e->u.operator.op = FFEEXPR_operatorNEQV_;
13805       e->u.operator.prec = FFEEXPR_operatorprecedenceNEQV_;
13806       e->u.operator.as = FFEEXPR_operatorassociativityNEQV_;
13807       break;
13808 
13809     case FFESTR_otherLT:
13810       e->u.operator.op = FFEEXPR_operatorLT_;
13811       e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
13812       e->u.operator.as = FFEEXPR_operatorassociativityLT_;
13813       break;
13814 
13815     case FFESTR_otherLE:
13816       e->u.operator.op = FFEEXPR_operatorLE_;
13817       e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
13818       e->u.operator.as = FFEEXPR_operatorassociativityLE_;
13819       break;
13820 
13821     case FFESTR_otherEQ:
13822       e->u.operator.op = FFEEXPR_operatorEQ_;
13823       e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
13824       e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
13825       break;
13826 
13827     case FFESTR_otherNE:
13828       e->u.operator.op = FFEEXPR_operatorNE_;
13829       e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
13830       e->u.operator.as = FFEEXPR_operatorassociativityNE_;
13831       break;
13832 
13833     case FFESTR_otherGT:
13834       e->u.operator.op = FFEEXPR_operatorGT_;
13835       e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
13836       e->u.operator.as = FFEEXPR_operatorassociativityGT_;
13837       break;
13838 
13839     case FFESTR_otherGE:
13840       e->u.operator.op = FFEEXPR_operatorGE_;
13841       e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
13842       e->u.operator.as = FFEEXPR_operatorassociativityGE_;
13843       break;
13844 
13845     default:
13846       if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT))
13847 	{
13848 	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13849 		       ffelex_token_where_column (ffeexpr_tokens_[0]));
13850 	  ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
13851 	  ffebad_finish ();
13852 	}
13853       e->u.operator.op = FFEEXPR_operatorEQ_;
13854       e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
13855       e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
13856       break;
13857     }
13858 
13859   ffeexpr_exprstack_push_binary_ (e);
13860 
13861   if (ffelex_token_type (t) != FFELEX_typePERIOD)
13862     {
13863       if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
13864 	{
13865 	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13866 		       ffelex_token_where_column (ffeexpr_tokens_[0]));
13867 	  ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13868 	  ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
13869 	  ffebad_finish ();
13870 	}
13871       ffelex_token_kill (ffeexpr_tokens_[1]);	/* Kill dot-dot token. */
13872       return (ffelexHandler) ffeexpr_token_rhs_ (t);
13873     }
13874 
13875   ffelex_token_kill (ffeexpr_tokens_[1]);	/* Kill dot-dot token. */
13876   return (ffelexHandler) ffeexpr_token_rhs_;
13877 }
13878 
13879 /* ffeexpr_token_binary_sw_per_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
13880 
13881    Return a pointer to this function to the lexer (ffelex), which will
13882    invoke it for the next token.
13883 
13884    A diagnostic has already been issued; just swallow a period if there is
13885    one, then continue with ffeexpr_token_binary_.  */
13886 
13887 static ffelexHandler
ffeexpr_token_binary_sw_per_(ffelexToken t)13888 ffeexpr_token_binary_sw_per_ (ffelexToken t)
13889 {
13890   if (ffelex_token_type (t) != FFELEX_typePERIOD)
13891     return (ffelexHandler) ffeexpr_token_binary_ (t);
13892 
13893   return (ffelexHandler) ffeexpr_token_binary_;
13894 }
13895 
13896 /* ffeexpr_token_quote_ -- Rhs QUOTE
13897 
13898    Return a pointer to this function to the lexer (ffelex), which will
13899    invoke it for the next token.
13900 
13901    Expecting a NUMBER that we'll treat as an octal integer.  */
13902 
13903 static ffelexHandler
ffeexpr_token_quote_(ffelexToken t)13904 ffeexpr_token_quote_ (ffelexToken t)
13905 {
13906   ffeexprExpr_ e;
13907   ffebld anyexpr;
13908 
13909   if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13910     {
13911       if (ffest_ffebad_start (FFEBAD_QUOTE_MISSES_DIGITS))
13912 	{
13913 	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13914 		       ffelex_token_where_column (ffeexpr_tokens_[0]));
13915 	  ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13916 	  ffebad_finish ();
13917 	}
13918       ffelex_token_kill (ffeexpr_tokens_[0]);
13919       return (ffelexHandler) ffeexpr_token_rhs_ (t);
13920     }
13921 
13922   /* This is kind of a kludge to prevent any whining about magical numbers
13923      that start out as these octal integers, so "20000000000 (on a 32-bit
13924      2's-complement machine) by itself won't produce an error. */
13925 
13926   anyexpr = ffebld_new_any ();
13927   ffebld_set_info (anyexpr, ffeinfo_new_any ());
13928 
13929   e = ffeexpr_expr_new_ ();
13930   e->type = FFEEXPR_exprtypeOPERAND_;
13931   e->token = ffeexpr_tokens_[0];
13932   e->u.operand = ffebld_new_conter_with_orig
13933     (ffebld_constant_new_integeroctal (t), anyexpr);
13934   ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER,
13935 		      FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY,
13936 		       FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13937   ffeexpr_exprstack_push_operand_ (e);
13938   return (ffelexHandler) ffeexpr_token_binary_;
13939 }
13940 
13941 /* ffeexpr_token_apostrophe_ -- Rhs APOSTROPHE
13942 
13943    Return a pointer to this function to the lexer (ffelex), which will
13944    invoke it for the next token.
13945 
13946    Handle an open-apostrophe, which begins either a character ('char-const'),
13947    typeless octal ('octal-const'O), or typeless hexadecimal ('hex-const'Z or
13948    'hex-const'X) constant.  */
13949 
13950 static ffelexHandler
ffeexpr_token_apostrophe_(ffelexToken t)13951 ffeexpr_token_apostrophe_ (ffelexToken t)
13952 {
13953   assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
13954   if (ffe_is_pedantic_not_90 () && (ffelex_token_length (t) == 0))
13955     {
13956       ffebad_start (FFEBAD_NULL_CHAR_CONST);
13957       ffebad_here (0, ffelex_token_where_line (t),
13958 		   ffelex_token_where_column (t));
13959       ffebad_finish ();
13960     }
13961   ffeexpr_tokens_[1] = ffelex_token_use (t);
13962   return (ffelexHandler) ffeexpr_token_apos_char_;
13963 }
13964 
13965 /* ffeexpr_token_apos_char_ -- Rhs APOSTROPHE CHARACTER
13966 
13967    Return a pointer to this function to the lexer (ffelex), which will
13968    invoke it for the next token.
13969 
13970    Close-apostrophe is implicit; if this token is NAME, it is a possible
13971    typeless-constant radix specifier.  */
13972 
13973 static ffelexHandler
ffeexpr_token_apos_char_(ffelexToken t)13974 ffeexpr_token_apos_char_ (ffelexToken t)
13975 {
13976   ffeexprExpr_ e;
13977   ffeinfo ni;
13978   char c;
13979   ffetargetCharacterSize size;
13980 
13981   if ((ffelex_token_type (t) == FFELEX_typeNAME)
13982       || (ffelex_token_type (t) == FFELEX_typeNAMES))
13983     {
13984       if ((ffelex_token_length (t) == 1)
13985 	  && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]), 'B',
13986 				      'b')
13987 	      || ffesrc_char_match_init (c, 'O', 'o')
13988 	      || ffesrc_char_match_init (c, 'X', 'x')
13989 	      || ffesrc_char_match_init (c, 'Z', 'z')))
13990 	{
13991 	  e = ffeexpr_expr_new_ ();
13992 	  e->type = FFEEXPR_exprtypeOPERAND_;
13993 	  e->token = ffeexpr_tokens_[0];
13994 	  switch (c)
13995 	    {
13996 	    case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
13997 	      e->u.operand = ffebld_new_conter
13998 		(ffebld_constant_new_typeless_bv (ffeexpr_tokens_[1]));
13999 	      size = ffetarget_size_typeless_binary (ffeexpr_tokens_[1]);
14000 	      break;
14001 
14002 	    case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
14003 	      e->u.operand = ffebld_new_conter
14004 		(ffebld_constant_new_typeless_ov (ffeexpr_tokens_[1]));
14005 	      size = ffetarget_size_typeless_octal (ffeexpr_tokens_[1]);
14006 	      break;
14007 
14008 	    case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
14009 	      e->u.operand = ffebld_new_conter
14010 		(ffebld_constant_new_typeless_hxv (ffeexpr_tokens_[1]));
14011 	      size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
14012 	      break;
14013 
14014 	    case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
14015 	      e->u.operand = ffebld_new_conter
14016 		(ffebld_constant_new_typeless_hzv (ffeexpr_tokens_[1]));
14017 	      size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
14018 	      break;
14019 
14020 	    default:
14021 	    no_match:		/* :::::::::::::::::::: */
14022 	      assert ("not BOXZ!" == NULL);
14023 	      size = 0;
14024 	      break;
14025 	    }
14026 	  ffebld_set_info (e->u.operand,
14027 	       ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
14028 		       0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
14029 	  ffeexpr_exprstack_push_operand_ (e);
14030 	  ffelex_token_kill (ffeexpr_tokens_[1]);
14031 	  return (ffelexHandler) ffeexpr_token_binary_;
14032 	}
14033     }
14034   e = ffeexpr_expr_new_ ();
14035   e->type = FFEEXPR_exprtypeOPERAND_;
14036   e->token = ffeexpr_tokens_[0];
14037   e->u.operand = ffebld_new_conter (ffebld_constant_new_characterdefault
14038 				    (ffeexpr_tokens_[1]));
14039   ni = ffeinfo_new (FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTERDEFAULT,
14040 		    0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14041 		    ffelex_token_length (ffeexpr_tokens_[1]));
14042   ffebld_set_info (e->u.operand, ni);
14043   ffelex_token_kill (ffeexpr_tokens_[1]);
14044   ffeexpr_exprstack_push_operand_ (e);
14045   if ((ffelex_token_type (t) == FFELEX_typeNAME)
14046       || (ffelex_token_type (t) == FFELEX_typeNAMES))
14047     {
14048       if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14049 	{
14050 	  ffebad_string (ffelex_token_text (t));
14051 	  ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14052 	  ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
14053 		       ffelex_token_where_column (ffeexpr_tokens_[0]));
14054 	  ffebad_finish ();
14055 	}
14056       e = ffeexpr_expr_new_ ();
14057       e->type = FFEEXPR_exprtypeBINARY_;
14058       e->token = ffelex_token_use (t);
14059       e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
14060       e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
14061       e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
14062       ffeexpr_exprstack_push_binary_ (e);
14063       return (ffelexHandler) ffeexpr_token_rhs_ (t);
14064     }
14065   ffeexpr_is_substr_ok_ = !ffe_is_pedantic_not_90 ();	/* Allow "'hello'(3:5)". */
14066   return (ffelexHandler) ffeexpr_token_substrp_ (t);
14067 }
14068 
14069 /* ffeexpr_token_name_lhs_ -- Lhs NAME
14070 
14071    Return a pointer to this function to the lexer (ffelex), which will
14072    invoke it for the next token.
14073 
14074    Handle a name followed by open-paren, period (RECORD.MEMBER), percent
14075    (RECORD%MEMBER), or nothing at all.	*/
14076 
14077 static ffelexHandler
ffeexpr_token_name_lhs_(ffelexToken t)14078 ffeexpr_token_name_lhs_ (ffelexToken t)
14079 {
14080   ffeexprExpr_ e;
14081   ffeexprParenType_ paren_type;
14082   ffesymbol s;
14083   ffebld expr;
14084   ffeinfo info;
14085 
14086   switch (ffelex_token_type (t))
14087     {
14088     case FFELEX_typeOPEN_PAREN:
14089       switch (ffeexpr_stack_->context)
14090 	{
14091 	case FFEEXPR_contextASSIGN:
14092 	case FFEEXPR_contextAGOTO:
14093 	case FFEEXPR_contextFILEUNIT_DF:
14094 	  goto just_name;	/* :::::::::::::::::::: */
14095 
14096 	default:
14097 	  break;
14098 	}
14099       e = ffeexpr_expr_new_ ();
14100       e->type = FFEEXPR_exprtypeOPERAND_;
14101       e->token = ffelex_token_use (ffeexpr_tokens_[0]);
14102       s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], FALSE,
14103 					  &paren_type);
14104 
14105       switch (ffesymbol_where (s))
14106 	{
14107 	case FFEINFO_whereLOCAL:
14108 	  if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14109 	    ffesymbol_error (s, ffeexpr_tokens_[0]);	/* Recursion. */
14110 	  break;
14111 
14112 	case FFEINFO_whereINTRINSIC:
14113 	case FFEINFO_whereGLOBAL:
14114 	  if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
14115 	    ffesymbol_error (s, ffeexpr_tokens_[0]);	/* Can call intrin. */
14116 	  break;
14117 
14118 	case FFEINFO_whereCOMMON:
14119 	case FFEINFO_whereDUMMY:
14120 	case FFEINFO_whereRESULT:
14121 	  break;
14122 
14123 	case FFEINFO_whereNONE:
14124 	case FFEINFO_whereANY:
14125 	  break;
14126 
14127 	default:
14128 	  ffesymbol_error (s, ffeexpr_tokens_[0]);
14129 	  break;
14130 	}
14131 
14132       if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14133 	{
14134 	  e->u.operand = ffebld_new_any ();
14135 	  ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14136 	}
14137       else
14138 	{
14139 	  e->u.operand = ffebld_new_symter (s,
14140 					    ffesymbol_generic (s),
14141 					    ffesymbol_specific (s),
14142 					    ffesymbol_implementation (s));
14143 	  ffebld_set_info (e->u.operand, ffesymbol_info (s));
14144 	}
14145       ffeexpr_exprstack_push_ (e);	/* Not a complete operand yet. */
14146       ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
14147       switch (paren_type)
14148 	{
14149 	case FFEEXPR_parentypeSUBROUTINE_:
14150 	  ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14151 	  return
14152 	    (ffelexHandler)
14153 	    ffeexpr_rhs (ffeexpr_stack_->pool,
14154 			 FFEEXPR_contextACTUALARG_,
14155 			 ffeexpr_token_arguments_);
14156 
14157 	case FFEEXPR_parentypeARRAY_:
14158 	  ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14159 	  ffeexpr_stack_->bound_list = ffesymbol_dims (s);
14160 	  ffeexpr_stack_->rank = 0;
14161 	  ffeexpr_stack_->constant = TRUE;
14162 	  ffeexpr_stack_->immediate = TRUE;
14163 	  switch (ffeexpr_stack_->context)
14164 	    {
14165 	    case FFEEXPR_contextDATAIMPDOITEM_:
14166 	      return
14167 		(ffelexHandler)
14168 		ffeexpr_rhs (ffeexpr_stack_->pool,
14169 			     FFEEXPR_contextDATAIMPDOINDEX_,
14170 			     ffeexpr_token_elements_);
14171 
14172 	    case FFEEXPR_contextEQUIVALENCE:
14173 	      return
14174 		(ffelexHandler)
14175 		ffeexpr_rhs (ffeexpr_stack_->pool,
14176 			     FFEEXPR_contextEQVINDEX_,
14177 			     ffeexpr_token_elements_);
14178 
14179 	    default:
14180 	      return
14181 		(ffelexHandler)
14182 		ffeexpr_rhs (ffeexpr_stack_->pool,
14183 			     FFEEXPR_contextINDEX_,
14184 			     ffeexpr_token_elements_);
14185 	    }
14186 
14187 	case FFEEXPR_parentypeSUBSTRING_:
14188 	  e->u.operand = ffeexpr_collapse_symter (e->u.operand,
14189 						  ffeexpr_tokens_[0]);
14190 	  return
14191 	    (ffelexHandler)
14192 	    ffeexpr_rhs (ffeexpr_stack_->pool,
14193 			 FFEEXPR_contextINDEX_,
14194 			 ffeexpr_token_substring_);
14195 
14196 	case FFEEXPR_parentypeEQUIVALENCE_:
14197 	  ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14198 	  ffeexpr_stack_->bound_list = ffesymbol_dims (s);
14199 	  ffeexpr_stack_->rank = 0;
14200 	  ffeexpr_stack_->constant = TRUE;
14201 	  ffeexpr_stack_->immediate = TRUE;
14202 	  return
14203 	    (ffelexHandler)
14204 	    ffeexpr_rhs (ffeexpr_stack_->pool,
14205 			 FFEEXPR_contextEQVINDEX_,
14206 			 ffeexpr_token_equivalence_);
14207 
14208 	case FFEEXPR_parentypeFUNCTION_:	/* Invalid case. */
14209 	case FFEEXPR_parentypeFUNSUBSTR_:	/* Invalid case. */
14210 	  ffesymbol_error (s, ffeexpr_tokens_[0]);
14211 	  /* Fall through. */
14212 	case FFEEXPR_parentypeANY_:
14213 	  e->u.operand = ffebld_new_any ();
14214 	  ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14215 	  return
14216 	    (ffelexHandler)
14217 	    ffeexpr_rhs (ffeexpr_stack_->pool,
14218 			 FFEEXPR_contextACTUALARG_,
14219 			 ffeexpr_token_anything_);
14220 
14221 	default:
14222 	  assert ("bad paren type" == NULL);
14223 	  break;
14224 	}
14225 
14226     case FFELEX_typeEQUALS:	/* As in "VAR=". */
14227       switch (ffeexpr_stack_->context)
14228 	{
14229 	case FFEEXPR_contextIMPDOITEM_:	/* within
14230 						   "(,VAR=start,end[,incr])". */
14231 	case FFEEXPR_contextIMPDOITEMDF_:
14232 	  ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
14233 	  break;
14234 
14235 	case FFEEXPR_contextDATAIMPDOITEM_:
14236 	  ffeexpr_stack_->context = FFEEXPR_contextDATAIMPDOCTRL_;
14237 	  break;
14238 
14239 	default:
14240 	  break;
14241 	}
14242       break;
14243 
14244 #if 0
14245     case FFELEX_typePERIOD:
14246     case FFELEX_typePERCENT:
14247       assert ("FOO%, FOO. not yet supported!~~" == NULL);
14248       break;
14249 #endif
14250 
14251     default:
14252       break;
14253     }
14254 
14255 just_name:			/* :::::::::::::::::::: */
14256   e = ffeexpr_expr_new_ ();
14257   e->type = FFEEXPR_exprtypeOPERAND_;
14258   e->token = ffeexpr_tokens_[0];
14259   s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0],
14260 				  (ffeexpr_stack_->context
14261 				   == FFEEXPR_contextSUBROUTINEREF));
14262 
14263   switch (ffesymbol_where (s))
14264     {
14265     case FFEINFO_whereCONSTANT:
14266       if ((ffeexpr_stack_->context != FFEEXPR_contextPARAMETER)
14267 	  || (ffesymbol_kind (s) != FFEINFO_kindENTITY))
14268 	ffesymbol_error (s, ffeexpr_tokens_[0]);
14269       break;
14270 
14271     case FFEINFO_whereIMMEDIATE:
14272       if ((ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOCTRL_)
14273 	  && (ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOINDEX_))
14274 	ffesymbol_error (s, ffeexpr_tokens_[0]);
14275       break;
14276 
14277     case FFEINFO_whereLOCAL:
14278       if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14279 	ffesymbol_error (s, ffeexpr_tokens_[0]);	/* Recurse!. */
14280       break;
14281 
14282     case FFEINFO_whereINTRINSIC:
14283       if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
14284 	ffesymbol_error (s, ffeexpr_tokens_[0]);	/* Can call intrin. */
14285       break;
14286 
14287     default:
14288       break;
14289     }
14290 
14291   if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14292     {
14293       expr = ffebld_new_any ();
14294       info = ffeinfo_new_any ();
14295       ffebld_set_info (expr, info);
14296     }
14297   else
14298     {
14299       expr = ffebld_new_symter (s,
14300 				ffesymbol_generic (s),
14301 				ffesymbol_specific (s),
14302 				ffesymbol_implementation (s));
14303       info = ffesymbol_info (s);
14304       ffebld_set_info (expr, info);
14305       if (ffesymbol_is_doiter (s))
14306 	{
14307 	  ffebad_start (FFEBAD_DOITER);
14308 	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14309 		       ffelex_token_where_column (ffeexpr_tokens_[0]));
14310 	  ffest_ffebad_here_doiter (1, s);
14311 	  ffebad_string (ffesymbol_text (s));
14312 	  ffebad_finish ();
14313 	}
14314       expr = ffeexpr_collapse_symter (expr, ffeexpr_tokens_[0]);
14315     }
14316 
14317   if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14318     {
14319       if (ffebld_op (expr) == FFEBLD_opANY)
14320 	{
14321 	  expr = ffebld_new_any ();
14322 	  ffebld_set_info (expr, ffeinfo_new_any ());
14323 	}
14324       else
14325 	{
14326 	  expr = ffebld_new_subrref (expr, NULL);	/* No argument list. */
14327 	  if (ffesymbol_generic (s) != FFEINTRIN_genNONE)
14328 	    ffeintrin_fulfill_generic (&expr, &info, e->token);
14329 	  else if (ffesymbol_specific (s) != FFEINTRIN_specNONE)
14330 	    ffeintrin_fulfill_specific (&expr, &info, NULL, e->token);
14331 	  else
14332 	    ffeexpr_fulfill_call_ (&expr, e->token);
14333 
14334 	  if (ffebld_op (expr) != FFEBLD_opANY)
14335 	    ffebld_set_info (expr,
14336 			     ffeinfo_new (ffeinfo_basictype (info),
14337 					  ffeinfo_kindtype (info),
14338 					  0,
14339 					  FFEINFO_kindENTITY,
14340 					  FFEINFO_whereFLEETING,
14341 					  ffeinfo_size (info)));
14342 	  else
14343 	    ffebld_set_info (expr, ffeinfo_new_any ());
14344 	}
14345     }
14346 
14347   e->u.operand = expr;
14348   ffeexpr_exprstack_push_operand_ (e);
14349   return (ffelexHandler) ffeexpr_finished_ (t);
14350 }
14351 
14352 /* ffeexpr_token_name_arg_ -- Rhs NAME
14353 
14354    Return a pointer to this function to the lexer (ffelex), which will
14355    invoke it for the next token.
14356 
14357    Handle first token in an actual-arg (or possible actual-arg) context
14358    being a NAME, and use second token to refine the context.  */
14359 
14360 static ffelexHandler
ffeexpr_token_name_arg_(ffelexToken t)14361 ffeexpr_token_name_arg_ (ffelexToken t)
14362 {
14363   switch (ffelex_token_type (t))
14364     {
14365     case FFELEX_typeCLOSE_PAREN:
14366     case FFELEX_typeCOMMA:
14367       switch (ffeexpr_stack_->context)
14368 	{
14369 	case FFEEXPR_contextINDEXORACTUALARG_:
14370 	  ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
14371 	  break;
14372 
14373 	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
14374 	  ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
14375 	  break;
14376 
14377 	default:
14378 	  break;
14379 	}
14380       break;
14381 
14382     default:
14383       switch (ffeexpr_stack_->context)
14384 	{
14385 	case FFEEXPR_contextACTUALARG_:
14386 	  ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
14387 	  break;
14388 
14389 	case FFEEXPR_contextINDEXORACTUALARG_:
14390 	  ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
14391 	  break;
14392 
14393 	case FFEEXPR_contextSFUNCDEFACTUALARG_:
14394 	  ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
14395 	  break;
14396 
14397 	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
14398 	  ffeexpr_stack_->context
14399 	    = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
14400 	  break;
14401 
14402 	default:
14403 	  assert ("bad context in _name_arg_" == NULL);
14404 	  break;
14405 	}
14406       break;
14407     }
14408 
14409   return (ffelexHandler) ffeexpr_token_name_rhs_ (t);
14410 }
14411 
14412 /* ffeexpr_token_name_rhs_ -- Rhs NAME
14413 
14414    Return a pointer to this function to the lexer (ffelex), which will
14415    invoke it for the next token.
14416 
14417    Handle a name followed by open-paren, apostrophe (O'octal-const',
14418    Z'hex-const', or X'hex-const'), period (RECORD.MEMBER).
14419 
14420    26-Nov-91  JCB  1.2
14421       When followed by apostrophe or quote, set lex hexnum flag on so
14422       [0-9] as first char of next token seen as starting a potentially
14423       hex number (NAME).
14424    04-Oct-91  JCB  1.1
14425       In case of intrinsic, decorate its SYMTER with the type info for
14426       the specific intrinsic.  */
14427 
14428 static ffelexHandler
ffeexpr_token_name_rhs_(ffelexToken t)14429 ffeexpr_token_name_rhs_ (ffelexToken t)
14430 {
14431   ffeexprExpr_ e;
14432   ffeexprParenType_ paren_type;
14433   ffesymbol s;
14434   bool sfdef;
14435 
14436   switch (ffelex_token_type (t))
14437     {
14438     case FFELEX_typeQUOTE:
14439     case FFELEX_typeAPOSTROPHE:
14440       ffeexpr_tokens_[1] = ffelex_token_use (t);
14441       ffelex_set_hexnum (TRUE);
14442       return (ffelexHandler) ffeexpr_token_name_apos_;
14443 
14444     case FFELEX_typeOPEN_PAREN:
14445       e = ffeexpr_expr_new_ ();
14446       e->type = FFEEXPR_exprtypeOPERAND_;
14447       e->token = ffelex_token_use (ffeexpr_tokens_[0]);
14448       s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], TRUE,
14449 					  &paren_type);
14450       if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14451 	e->u.operand = ffebld_new_any ();
14452       else
14453 	e->u.operand = ffebld_new_symter (s, ffesymbol_generic (s),
14454 					  ffesymbol_specific (s),
14455 					  ffesymbol_implementation (s));
14456       ffeexpr_exprstack_push_ (e);	/* Not a complete operand yet. */
14457       ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
14458       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
14459 	{
14460 	case FFEEXPR_contextSFUNCDEF:
14461 	case FFEEXPR_contextSFUNCDEFINDEX_:
14462 	case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
14463 	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
14464 	  sfdef = TRUE;
14465 	  break;
14466 
14467 	case FFEEXPR_contextSFUNCDEFACTUALARG_:
14468 	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
14469 	  assert ("weird context!" == NULL);
14470 	  sfdef = FALSE;
14471 	  break;
14472 
14473 	default:
14474 	  sfdef = FALSE;
14475 	  break;
14476 	}
14477       switch (paren_type)
14478 	{
14479 	case FFEEXPR_parentypeFUNCTION_:
14480 	  ffebld_set_info (e->u.operand, ffesymbol_info (s));
14481 	  ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14482 	  if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
14483 	    {			/* A statement function. */
14484 	      ffeexpr_stack_->num_args
14485 		= ffebld_list_length
14486 		  (ffeexpr_stack_->next_dummy
14487 		   = ffesymbol_dummyargs (s));
14488 	      ffeexpr_stack_->tokens[1] = NULL;	/* !=NULL when > num_args. */
14489 	    }
14490 	  else if ((ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
14491 		   && !ffe_is_pedantic_not_90 ()
14492 		   && ((ffesymbol_implementation (s)
14493 			== FFEINTRIN_impICHAR)
14494 		       || (ffesymbol_implementation (s)
14495 			   == FFEINTRIN_impIACHAR)
14496 		       || (ffesymbol_implementation (s)
14497 			   == FFEINTRIN_impLEN)))
14498 	    {			/* Allow arbitrary concatenations. */
14499 	      return
14500 		(ffelexHandler)
14501 		  ffeexpr_rhs (ffeexpr_stack_->pool,
14502 			       sfdef
14503 			       ? FFEEXPR_contextSFUNCDEF
14504 			       : FFEEXPR_contextLET,
14505 			       ffeexpr_token_arguments_);
14506 	    }
14507 	  return
14508 	    (ffelexHandler)
14509 	    ffeexpr_rhs (ffeexpr_stack_->pool,
14510 			 sfdef
14511 			 ? FFEEXPR_contextSFUNCDEFACTUALARG_
14512 			 : FFEEXPR_contextACTUALARG_,
14513 			 ffeexpr_token_arguments_);
14514 
14515 	case FFEEXPR_parentypeARRAY_:
14516 	  ffebld_set_info (e->u.operand,
14517 			   ffesymbol_info (ffebld_symter (e->u.operand)));
14518 	  ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14519 	  ffeexpr_stack_->bound_list = ffesymbol_dims (s);
14520 	  ffeexpr_stack_->rank = 0;
14521 	  ffeexpr_stack_->constant = TRUE;
14522 	  ffeexpr_stack_->immediate = TRUE;
14523 	  return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
14524 					      sfdef
14525 					      ? FFEEXPR_contextSFUNCDEFINDEX_
14526 					      : FFEEXPR_contextINDEX_,
14527 					      ffeexpr_token_elements_);
14528 
14529 	case FFEEXPR_parentypeSUBSTRING_:
14530 	  ffebld_set_info (e->u.operand,
14531 			   ffesymbol_info (ffebld_symter (e->u.operand)));
14532 	  e->u.operand = ffeexpr_collapse_symter (e->u.operand,
14533 						  ffeexpr_tokens_[0]);
14534 	  return
14535 	    (ffelexHandler)
14536 	    ffeexpr_rhs (ffeexpr_stack_->pool,
14537 			 sfdef
14538 			 ? FFEEXPR_contextSFUNCDEFINDEX_
14539 			 : FFEEXPR_contextINDEX_,
14540 			 ffeexpr_token_substring_);
14541 
14542 	case FFEEXPR_parentypeFUNSUBSTR_:
14543 	  return
14544 	    (ffelexHandler)
14545 	    ffeexpr_rhs (ffeexpr_stack_->pool,
14546 			 sfdef
14547 			 ? FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
14548 			 : FFEEXPR_contextINDEXORACTUALARG_,
14549 			 ffeexpr_token_funsubstr_);
14550 
14551 	case FFEEXPR_parentypeANY_:
14552 	  ffebld_set_info (e->u.operand, ffesymbol_info (s));
14553 	  return
14554 	    (ffelexHandler)
14555 	    ffeexpr_rhs (ffeexpr_stack_->pool,
14556 			 sfdef
14557 			 ? FFEEXPR_contextSFUNCDEFACTUALARG_
14558 			 : FFEEXPR_contextACTUALARG_,
14559 			 ffeexpr_token_anything_);
14560 
14561 	default:
14562 	  assert ("bad paren type" == NULL);
14563 	  break;
14564 	}
14565 
14566     case FFELEX_typeEQUALS:	/* As in "VAR=". */
14567       switch (ffeexpr_stack_->context)
14568 	{
14569 	case FFEEXPR_contextIMPDOITEM_:	/* "(,VAR=start,end[,incr])". */
14570 	case FFEEXPR_contextIMPDOITEMDF_:
14571 	  ffeexpr_stack_->is_rhs = FALSE;	/* Really an lhs construct. */
14572 	  ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
14573 	  break;
14574 
14575 	default:
14576 	  break;
14577 	}
14578       break;
14579 
14580 #if 0
14581     case FFELEX_typePERIOD:
14582     case FFELEX_typePERCENT:
14583       ~~Support these two someday, though not required
14584 	assert ("FOO%, FOO. not yet supported!~~" == NULL);
14585       break;
14586 #endif
14587 
14588     default:
14589       break;
14590     }
14591 
14592   switch (ffeexpr_stack_->context)
14593     {
14594     case FFEEXPR_contextINDEXORACTUALARG_:
14595     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
14596       assert ("strange context" == NULL);
14597       break;
14598 
14599     default:
14600       break;
14601     }
14602 
14603   e = ffeexpr_expr_new_ ();
14604   e->type = FFEEXPR_exprtypeOPERAND_;
14605   e->token = ffeexpr_tokens_[0];
14606   s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0], FALSE);
14607   if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14608     {
14609       e->u.operand = ffebld_new_any ();
14610       ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14611     }
14612   else
14613     {
14614       e->u.operand = ffebld_new_symter (s, FFEINTRIN_genNONE,
14615 					ffesymbol_specific (s),
14616 					ffesymbol_implementation (s));
14617       if (ffesymbol_specific (s) == FFEINTRIN_specNONE)
14618 	ffebld_set_info (e->u.operand, ffeinfo_use (ffesymbol_info (s)));
14619       else
14620 	{			/* Decorate the SYMTER with the actual type
14621 				   of the intrinsic. */
14622 	  ffebld_set_info (e->u.operand, ffeinfo_new
14623 			(ffeintrin_basictype (ffesymbol_specific (s)),
14624 			 ffeintrin_kindtype (ffesymbol_specific (s)),
14625 			 0,
14626 			 ffesymbol_kind (s),
14627 			 ffesymbol_where (s),
14628 			 FFETARGET_charactersizeNONE));
14629 	}
14630       if (ffesymbol_is_doiter (s))
14631 	ffebld_symter_set_is_doiter (e->u.operand, TRUE);
14632       e->u.operand = ffeexpr_collapse_symter (e->u.operand,
14633 					      ffeexpr_tokens_[0]);
14634     }
14635   ffeexpr_exprstack_push_operand_ (e);
14636   return (ffelexHandler) ffeexpr_token_binary_ (t);
14637 }
14638 
14639 /* ffeexpr_token_name_apos_ -- Rhs NAME APOSTROPHE
14640 
14641    Return a pointer to this function to the lexer (ffelex), which will
14642    invoke it for the next token.
14643 
14644    Expecting a NAME token, analyze the previous NAME token to see what kind,
14645    if any, typeless constant we've got.
14646 
14647    01-Sep-90  JCB  1.1
14648       Expect a NAME instead of CHARACTER in this situation.  */
14649 
14650 static ffelexHandler
ffeexpr_token_name_apos_(ffelexToken t)14651 ffeexpr_token_name_apos_ (ffelexToken t)
14652 {
14653   ffeexprExpr_ e;
14654 
14655   ffelex_set_hexnum (FALSE);
14656 
14657   switch (ffelex_token_type (t))
14658     {
14659     case FFELEX_typeNAME:
14660       ffeexpr_tokens_[2] = ffelex_token_use (t);
14661       return (ffelexHandler) ffeexpr_token_name_apos_name_;
14662 
14663     default:
14664       break;
14665     }
14666 
14667   if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14668     {
14669       ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
14670       ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14671 		   ffelex_token_where_column (ffeexpr_tokens_[0]));
14672       ffebad_here (1, ffelex_token_where_line (t),
14673 		   ffelex_token_where_column (t));
14674       ffebad_finish ();
14675     }
14676 
14677   ffelex_token_kill (ffeexpr_tokens_[1]);
14678 
14679   e = ffeexpr_expr_new_ ();
14680   e->type = FFEEXPR_exprtypeOPERAND_;
14681   e->u.operand = ffebld_new_any ();
14682   ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14683   e->token = ffeexpr_tokens_[0];
14684   ffeexpr_exprstack_push_operand_ (e);
14685 
14686   return (ffelexHandler) ffeexpr_token_binary_ (t);
14687 }
14688 
14689 /* ffeexpr_token_name_apos_name_ -- Rhs NAME APOSTROPHE NAME
14690 
14691    Return a pointer to this function to the lexer (ffelex), which will
14692    invoke it for the next token.
14693 
14694    Expecting an APOSTROPHE token, analyze the previous NAME token to see
14695    what kind, if any, typeless constant we've got.  */
14696 
14697 static ffelexHandler
ffeexpr_token_name_apos_name_(ffelexToken t)14698 ffeexpr_token_name_apos_name_ (ffelexToken t)
14699 {
14700   ffeexprExpr_ e;
14701   char c;
14702 
14703   e = ffeexpr_expr_new_ ();
14704   e->type = FFEEXPR_exprtypeOPERAND_;
14705   e->token = ffeexpr_tokens_[0];
14706 
14707   if ((ffelex_token_type (t) == ffelex_token_type (ffeexpr_tokens_[1]))
14708       && (ffelex_token_length (ffeexpr_tokens_[0]) == 1)
14709       && (ffesrc_char_match_init ((c = ffelex_token_text (ffeexpr_tokens_[0])[0]),
14710 				  'B', 'b')
14711 	  || ffesrc_char_match_init (c, 'O', 'o')
14712 	  || ffesrc_char_match_init (c, 'X', 'x')
14713 	  || ffesrc_char_match_init (c, 'Z', 'z')))
14714     {
14715       ffetargetCharacterSize size;
14716 
14717       if (!ffe_is_typeless_boz ()) {
14718 
14719       switch (c)
14720 	{
14721 	case FFESRC_CASE_MATCH_INIT ('B', 'b', imatch_b, no_imatch):
14722 	  e->u.operand = ffebld_new_conter (ffebld_constant_new_integerbinary
14723 					    (ffeexpr_tokens_[2]));
14724 	  break;
14725 
14726 	case FFESRC_CASE_MATCH_INIT ('O', 'o', imatch_o, no_imatch):
14727 	  e->u.operand = ffebld_new_conter (ffebld_constant_new_integeroctal
14728 					    (ffeexpr_tokens_[2]));
14729 	  break;
14730 
14731 	case FFESRC_CASE_MATCH_INIT ('X', 'x', imatch_x, no_imatch):
14732 	  e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
14733 					    (ffeexpr_tokens_[2]));
14734 	  break;
14735 
14736 	case FFESRC_CASE_MATCH_INIT ('Z', 'z', imatch_z, no_imatch):
14737 	  e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
14738 					    (ffeexpr_tokens_[2]));
14739 	  break;
14740 
14741 	default:
14742 	no_imatch:		/* :::::::::::::::::::: */
14743 	  assert ("not BOXZ!" == NULL);
14744 	  abort ();
14745 	}
14746 
14747 	ffebld_set_info (e->u.operand,
14748 			 ffeinfo_new (FFEINFO_basictypeINTEGER,
14749 				      FFEINFO_kindtypeINTEGERDEFAULT, 0,
14750 				      FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14751 				      FFETARGET_charactersizeNONE));
14752 	ffeexpr_exprstack_push_operand_ (e);
14753 	ffelex_token_kill (ffeexpr_tokens_[1]);
14754 	ffelex_token_kill (ffeexpr_tokens_[2]);
14755 	return (ffelexHandler) ffeexpr_token_binary_;
14756       }
14757 
14758       switch (c)
14759 	{
14760 	case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
14761 	  e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_bm
14762 					    (ffeexpr_tokens_[2]));
14763 	  size = ffetarget_size_typeless_binary (ffeexpr_tokens_[2]);
14764 	  break;
14765 
14766 	case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
14767 	  e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_om
14768 					    (ffeexpr_tokens_[2]));
14769 	  size = ffetarget_size_typeless_octal (ffeexpr_tokens_[2]);
14770 	  break;
14771 
14772 	case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
14773 	  e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hxm
14774 					    (ffeexpr_tokens_[2]));
14775 	  size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
14776 	  break;
14777 
14778 	case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
14779 	  e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
14780 					    (ffeexpr_tokens_[2]));
14781 	  size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
14782 	  break;
14783 
14784 	default:
14785 	no_match:		/* :::::::::::::::::::: */
14786 	  assert ("not BOXZ!" == NULL);
14787 	  e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
14788 					    (ffeexpr_tokens_[2]));
14789 	  size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
14790 	  break;
14791 	}
14792       ffebld_set_info (e->u.operand,
14793 	       ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
14794 		       0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
14795       ffeexpr_exprstack_push_operand_ (e);
14796       ffelex_token_kill (ffeexpr_tokens_[1]);
14797       ffelex_token_kill (ffeexpr_tokens_[2]);
14798       return (ffelexHandler) ffeexpr_token_binary_;
14799     }
14800 
14801   if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14802     {
14803       ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
14804       ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14805 		   ffelex_token_where_column (ffeexpr_tokens_[0]));
14806       ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14807       ffebad_finish ();
14808     }
14809 
14810   ffelex_token_kill (ffeexpr_tokens_[1]);
14811   ffelex_token_kill (ffeexpr_tokens_[2]);
14812 
14813   e->type = FFEEXPR_exprtypeOPERAND_;
14814   e->u.operand = ffebld_new_any ();
14815   ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14816   e->token = ffeexpr_tokens_[0];
14817   ffeexpr_exprstack_push_operand_ (e);
14818 
14819   switch (ffelex_token_type (t))
14820     {
14821     case FFELEX_typeAPOSTROPHE:
14822     case FFELEX_typeQUOTE:
14823       return (ffelexHandler) ffeexpr_token_binary_;
14824 
14825     default:
14826       return (ffelexHandler) ffeexpr_token_binary_ (t);
14827     }
14828 }
14829 
14830 /* ffeexpr_token_percent_ -- Rhs PERCENT
14831 
14832    Handle a percent sign possibly followed by "LOC".  If followed instead
14833    by "VAL", "REF", or "DESCR", issue an error message and substitute
14834    "LOC".  If followed by something else, treat the percent sign as a
14835    spurious incorrect token and reprocess the token via _rhs_.	*/
14836 
14837 static ffelexHandler
ffeexpr_token_percent_(ffelexToken t)14838 ffeexpr_token_percent_ (ffelexToken t)
14839 {
14840   switch (ffelex_token_type (t))
14841     {
14842     case FFELEX_typeNAME:
14843     case FFELEX_typeNAMES:
14844       ffeexpr_stack_->percent = ffeexpr_percent_ (t);
14845       ffeexpr_tokens_[1] = ffelex_token_use (t);
14846       return (ffelexHandler) ffeexpr_token_percent_name_;
14847 
14848     default:
14849       if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
14850 	{
14851 	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14852 		       ffelex_token_where_column (ffeexpr_tokens_[0]));
14853 	  ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
14854 		   ffelex_token_where_column (ffeexpr_stack_->first_token));
14855 	  ffebad_finish ();
14856 	}
14857       ffelex_token_kill (ffeexpr_tokens_[0]);
14858       return (ffelexHandler) ffeexpr_token_rhs_ (t);
14859     }
14860 }
14861 
14862 /* ffeexpr_token_percent_name_ -- Rhs PERCENT NAME
14863 
14864    Make sure the token is OPEN_PAREN and prepare for the one-item list of
14865    LHS expressions.  Else display an error message.  */
14866 
14867 static ffelexHandler
ffeexpr_token_percent_name_(ffelexToken t)14868 ffeexpr_token_percent_name_ (ffelexToken t)
14869 {
14870   ffelexHandler nexthandler;
14871 
14872   if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
14873     {
14874       if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
14875 	{
14876 	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14877 		       ffelex_token_where_column (ffeexpr_tokens_[0]));
14878 	  ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
14879 		   ffelex_token_where_column (ffeexpr_stack_->first_token));
14880 	  ffebad_finish ();
14881 	}
14882       ffelex_token_kill (ffeexpr_tokens_[0]);
14883       nexthandler = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_tokens_[1]);
14884       ffelex_token_kill (ffeexpr_tokens_[1]);
14885       return (ffelexHandler) (*nexthandler) (t);
14886     }
14887 
14888   switch (ffeexpr_stack_->percent)
14889     {
14890     default:
14891       if (ffest_ffebad_start (FFEBAD_INVALID_PERCENT))
14892 	{
14893 	  ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14894 		       ffelex_token_where_column (ffeexpr_tokens_[0]));
14895 	  ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
14896 	  ffebad_finish ();
14897 	}
14898       ffeexpr_stack_->percent = FFEEXPR_percentLOC_;
14899       /* Fall through. */
14900     case FFEEXPR_percentLOC_:
14901       ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
14902       ffelex_token_kill (ffeexpr_tokens_[1]);
14903       ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
14904       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
14905 					  FFEEXPR_contextLOC_,
14906 					  ffeexpr_cb_end_loc_);
14907     }
14908 }
14909 
14910 /* ffeexpr_make_float_const_ -- Make a floating-point constant
14911 
14912    See prototype.
14913 
14914    Pass 'E', 'D', or 'Q' for exponent letter.  */
14915 
14916 static void
ffeexpr_make_float_const_(char exp_letter,ffelexToken integer,ffelexToken decimal,ffelexToken fraction,ffelexToken exponent,ffelexToken exponent_sign,ffelexToken exponent_digits)14917 ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
14918 			   ffelexToken decimal, ffelexToken fraction,
14919 			   ffelexToken exponent, ffelexToken exponent_sign,
14920 			   ffelexToken exponent_digits)
14921 {
14922   ffeexprExpr_ e;
14923 
14924   e = ffeexpr_expr_new_ ();
14925   e->type = FFEEXPR_exprtypeOPERAND_;
14926   if (integer != NULL)
14927     e->token = ffelex_token_use (integer);
14928   else
14929     {
14930       assert (decimal != NULL);
14931       e->token = ffelex_token_use (decimal);
14932     }
14933 
14934   switch (exp_letter)
14935     {
14936 #if !FFETARGET_okREALQUAD
14937     case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
14938       if (ffebad_start (FFEBAD_QUAD_UNSUPPORTED))
14939 	{
14940 	  ffebad_here (0, ffelex_token_where_line (e->token),
14941 		       ffelex_token_where_column (e->token));
14942 	  ffebad_finish ();
14943 	}
14944       goto match_d;		/* The FFESRC_CASE_* macros don't
14945 				   allow fall-through! */
14946 #endif
14947 
14948     case FFESRC_CASE_MATCH_INIT ('D', 'd', match_d, no_match):
14949       e->u.operand = ffebld_new_conter (ffebld_constant_new_realdouble
14950 					(integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
14951       ffebld_set_info (e->u.operand,
14952 	     ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
14953 			  0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14954       break;
14955 
14956     case FFESRC_CASE_MATCH_INIT ('E', 'e', match_e, no_match):
14957       e->u.operand = ffebld_new_conter (ffebld_constant_new_realdefault
14958 					(integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
14959       ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeREAL,
14960 			 FFEINFO_kindtypeREALDEFAULT, 0, FFEINFO_kindENTITY,
14961 		       FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14962       break;
14963 
14964 #if FFETARGET_okREALQUAD
14965     case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
14966       e->u.operand = ffebld_new_conter (ffebld_constant_new_realquad
14967 					(integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
14968       ffebld_set_info (e->u.operand,
14969 	       ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALQUAD,
14970 			    0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14971       break;
14972 #endif
14973 
14974     case 'I':	/* Make an integer. */
14975       e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
14976 					(ffeexpr_tokens_[0]));
14977       ffebld_set_info (e->u.operand,
14978 		       ffeinfo_new (FFEINFO_basictypeINTEGER,
14979 				    FFEINFO_kindtypeINTEGERDEFAULT, 0,
14980 				    FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14981 				    FFETARGET_charactersizeNONE));
14982       break;
14983 
14984     default:
14985     no_match:			/* :::::::::::::::::::: */
14986       assert ("Lost the exponent letter!" == NULL);
14987     }
14988 
14989   ffeexpr_exprstack_push_operand_ (e);
14990 }
14991 
14992 /* Just like ffesymbol_declare_local, except performs any implicit info
14993    assignment necessary.  */
14994 
14995 static ffesymbol
ffeexpr_declare_unadorned_(ffelexToken t,bool maybe_intrin)14996 ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin)
14997 {
14998   ffesymbol s;
14999   ffeinfoKind k;
15000   bool bad;
15001 
15002   s = ffesymbol_declare_local (t, maybe_intrin);
15003 
15004   switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15005     /* Special-case these since they can involve a different concept
15006        of "state" (in the stmtfunc name space).  */
15007     {
15008     case FFEEXPR_contextDATAIMPDOINDEX_:
15009     case FFEEXPR_contextDATAIMPDOCTRL_:
15010       if (ffeexpr_context_outer_ (ffeexpr_stack_)
15011 	  == FFEEXPR_contextDATAIMPDOINDEX_)
15012 	s = ffeexpr_sym_impdoitem_ (s, t);
15013       else
15014 	if (ffeexpr_stack_->is_rhs)
15015 	  s = ffeexpr_sym_impdoitem_ (s, t);
15016 	else
15017 	  s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
15018       bad = (ffesymbol_kind (s) != FFEINFO_kindENTITY)
15019 	|| ((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
15020 	    && (ffesymbol_where (s) != FFEINFO_whereIMMEDIATE));
15021       if (bad && (ffesymbol_kind (s) != FFEINFO_kindANY))
15022 	ffesymbol_error (s, t);
15023       return s;
15024 
15025     default:
15026       break;
15027     }
15028 
15029   switch ((ffesymbol_sfdummyparent (s) == NULL)
15030 	  ? ffesymbol_state (s)
15031 	  : FFESYMBOL_stateUNDERSTOOD)
15032     {
15033     case FFESYMBOL_stateNONE:	/* Before first exec, not seen in expr
15034 				   context. */
15035       if (!ffest_seen_first_exec ())
15036 	goto seen;		/* :::::::::::::::::::: */
15037       /* Fall through. */
15038     case FFESYMBOL_stateUNCERTAIN:	/* Unseen since first exec. */
15039       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15040 	{
15041 	case FFEEXPR_contextSUBROUTINEREF:
15042 	  s = ffeexpr_sym_lhs_call_ (s, t);
15043 	  break;
15044 
15045 	case FFEEXPR_contextFILEEXTFUNC:
15046 	  s = ffeexpr_sym_lhs_extfunc_ (s, t);
15047 	  break;
15048 
15049 	case FFEEXPR_contextSFUNCDEFACTUALARG_:
15050 	  s = ffecom_sym_exec_transition (s);
15051 	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15052 	    goto understood;	/* :::::::::::::::::::: */
15053 	  /* Fall through. */
15054 	case FFEEXPR_contextACTUALARG_:
15055 	  s = ffeexpr_sym_rhs_actualarg_ (s, t);
15056 	  break;
15057 
15058 	case FFEEXPR_contextDATA:
15059 	  if (ffeexpr_stack_->is_rhs)
15060 	    s = ffeexpr_sym_rhs_let_ (s, t);
15061 	  else
15062 	    s = ffeexpr_sym_lhs_data_ (s, t);
15063 	  break;
15064 
15065 	case FFEEXPR_contextDATAIMPDOITEM_:
15066 	  s = ffeexpr_sym_lhs_data_ (s, t);
15067 	  break;
15068 
15069 	case FFEEXPR_contextSFUNCDEF:
15070 	case FFEEXPR_contextSFUNCDEFINDEX_:
15071 	case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15072 	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15073 	  s = ffecom_sym_exec_transition (s);
15074 	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15075 	    goto understood;	/* :::::::::::::::::::: */
15076 	  /* Fall through. */
15077 	case FFEEXPR_contextLET:
15078 	case FFEEXPR_contextPAREN_:
15079 	case FFEEXPR_contextACTUALARGEXPR_:
15080 	case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15081 	case FFEEXPR_contextASSIGN:
15082 	case FFEEXPR_contextIOLIST:
15083 	case FFEEXPR_contextIOLISTDF:
15084 	case FFEEXPR_contextDO:
15085 	case FFEEXPR_contextDOWHILE:
15086 	case FFEEXPR_contextAGOTO:
15087 	case FFEEXPR_contextCGOTO:
15088 	case FFEEXPR_contextIF:
15089 	case FFEEXPR_contextARITHIF:
15090 	case FFEEXPR_contextFORMAT:
15091 	case FFEEXPR_contextSTOP:
15092 	case FFEEXPR_contextRETURN:
15093 	case FFEEXPR_contextSELECTCASE:
15094 	case FFEEXPR_contextCASE:
15095 	case FFEEXPR_contextFILEASSOC:
15096 	case FFEEXPR_contextFILEINT:
15097 	case FFEEXPR_contextFILEDFINT:
15098 	case FFEEXPR_contextFILELOG:
15099 	case FFEEXPR_contextFILENUM:
15100 	case FFEEXPR_contextFILENUMAMBIG:
15101 	case FFEEXPR_contextFILECHAR:
15102 	case FFEEXPR_contextFILENUMCHAR:
15103 	case FFEEXPR_contextFILEDFCHAR:
15104 	case FFEEXPR_contextFILEKEY:
15105 	case FFEEXPR_contextFILEUNIT:
15106 	case FFEEXPR_contextFILEUNIT_DF:
15107 	case FFEEXPR_contextFILEUNITAMBIG:
15108 	case FFEEXPR_contextFILEFORMAT:
15109 	case FFEEXPR_contextFILENAMELIST:
15110 	case FFEEXPR_contextFILEVXTCODE:
15111 	case FFEEXPR_contextINDEX_:
15112 	case FFEEXPR_contextIMPDOITEM_:
15113 	case FFEEXPR_contextIMPDOITEMDF_:
15114 	case FFEEXPR_contextIMPDOCTRL_:
15115 	case FFEEXPR_contextLOC_:
15116 	  if (ffeexpr_stack_->is_rhs)
15117 	    s = ffeexpr_sym_rhs_let_ (s, t);
15118 	  else
15119 	    s = ffeexpr_sym_lhs_let_ (s, t);
15120 	  break;
15121 
15122 	case FFEEXPR_contextCHARACTERSIZE:
15123 	case FFEEXPR_contextEQUIVALENCE:
15124 	case FFEEXPR_contextINCLUDE:
15125 	case FFEEXPR_contextPARAMETER:
15126 	case FFEEXPR_contextDIMLIST:
15127 	case FFEEXPR_contextDIMLISTCOMMON:
15128 	case FFEEXPR_contextKINDTYPE:
15129 	case FFEEXPR_contextINITVAL:
15130 	case FFEEXPR_contextEQVINDEX_:
15131 	  break;		/* Will turn into errors below. */
15132 
15133 	default:
15134 	  ffesymbol_error (s, t);
15135 	  break;
15136 	}
15137       /* Fall through. */
15138     case FFESYMBOL_stateUNDERSTOOD:	/* Nothing much more to learn. */
15139     understood:		/* :::::::::::::::::::: */
15140       k = ffesymbol_kind (s);
15141       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15142 	{
15143 	case FFEEXPR_contextSUBROUTINEREF:
15144 	  bad = ((k != FFEINFO_kindSUBROUTINE)
15145 		 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
15146 		     || (k != FFEINFO_kindNONE)));
15147 	  break;
15148 
15149 	case FFEEXPR_contextFILEEXTFUNC:
15150 	  bad = (k != FFEINFO_kindFUNCTION)
15151 	    || (ffesymbol_where (s) != FFEINFO_whereGLOBAL);
15152 	  break;
15153 
15154 	case FFEEXPR_contextSFUNCDEFACTUALARG_:
15155 	case FFEEXPR_contextACTUALARG_:
15156 	  switch (k)
15157 	    {
15158 	    case FFEINFO_kindENTITY:
15159 	      bad = FALSE;
15160 	      break;
15161 
15162 	    case FFEINFO_kindFUNCTION:
15163 	    case FFEINFO_kindSUBROUTINE:
15164 	      bad
15165 		= ((ffesymbol_where (s) != FFEINFO_whereGLOBAL)
15166 		   && (ffesymbol_where (s) != FFEINFO_whereDUMMY)
15167 		   && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
15168 		       || !ffeintrin_is_actualarg (ffesymbol_specific (s))));
15169 	      break;
15170 
15171 	    case FFEINFO_kindNONE:
15172 	      if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
15173 		{
15174 		  bad = !(ffeintrin_is_actualarg (ffesymbol_specific (s)));
15175 		  break;
15176 		}
15177 
15178 	      /* If state is UNDERSTOOD here, it's CHAR*(*) or attrsANY,
15179 		 and in the former case, attrsTYPE is set, so we
15180 		 see this as an error as we should, since CHAR*(*)
15181 		 cannot be actually referenced in a main/block data
15182 		 program unit.  */
15183 
15184 	      if ((ffesymbol_attrs (s) & (FFESYMBOL_attrsANY
15185 					  | FFESYMBOL_attrsEXTERNAL
15186 					  | FFESYMBOL_attrsTYPE))
15187 		  == FFESYMBOL_attrsEXTERNAL)
15188 		bad = FALSE;
15189 	      else
15190 		bad = TRUE;
15191 	      break;
15192 
15193 	    default:
15194 	      bad = TRUE;
15195 	      break;
15196 	    }
15197 	  break;
15198 
15199 	case FFEEXPR_contextDATA:
15200 	  if (ffeexpr_stack_->is_rhs)
15201 	    bad = (k != FFEINFO_kindENTITY)
15202 	      || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
15203 	  else
15204 	    bad = (k != FFEINFO_kindENTITY)
15205 	      || ((ffesymbol_where (s) != FFEINFO_whereNONE)
15206 		  && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
15207 		  && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
15208 	  break;
15209 
15210 	case FFEEXPR_contextDATAIMPDOITEM_:
15211 	  bad = TRUE;		/* Unadorned item never valid. */
15212 	  break;
15213 
15214 	case FFEEXPR_contextSFUNCDEF:
15215 	case FFEEXPR_contextSFUNCDEFINDEX_:
15216 	case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15217 	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15218 	case FFEEXPR_contextLET:
15219 	case FFEEXPR_contextPAREN_:
15220 	case FFEEXPR_contextACTUALARGEXPR_:
15221 	case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15222 	case FFEEXPR_contextASSIGN:
15223 	case FFEEXPR_contextIOLIST:
15224 	case FFEEXPR_contextIOLISTDF:
15225 	case FFEEXPR_contextDO:
15226 	case FFEEXPR_contextDOWHILE:
15227 	case FFEEXPR_contextAGOTO:
15228 	case FFEEXPR_contextCGOTO:
15229 	case FFEEXPR_contextIF:
15230 	case FFEEXPR_contextARITHIF:
15231 	case FFEEXPR_contextFORMAT:
15232 	case FFEEXPR_contextSTOP:
15233 	case FFEEXPR_contextRETURN:
15234 	case FFEEXPR_contextSELECTCASE:
15235 	case FFEEXPR_contextCASE:
15236 	case FFEEXPR_contextFILEASSOC:
15237 	case FFEEXPR_contextFILEINT:
15238 	case FFEEXPR_contextFILEDFINT:
15239 	case FFEEXPR_contextFILELOG:
15240 	case FFEEXPR_contextFILENUM:
15241 	case FFEEXPR_contextFILENUMAMBIG:
15242 	case FFEEXPR_contextFILECHAR:
15243 	case FFEEXPR_contextFILENUMCHAR:
15244 	case FFEEXPR_contextFILEDFCHAR:
15245 	case FFEEXPR_contextFILEKEY:
15246 	case FFEEXPR_contextFILEUNIT:
15247 	case FFEEXPR_contextFILEUNIT_DF:
15248 	case FFEEXPR_contextFILEUNITAMBIG:
15249 	case FFEEXPR_contextFILEFORMAT:
15250 	case FFEEXPR_contextFILENAMELIST:
15251 	case FFEEXPR_contextFILEVXTCODE:
15252 	case FFEEXPR_contextINDEX_:
15253 	case FFEEXPR_contextIMPDOITEM_:
15254 	case FFEEXPR_contextIMPDOITEMDF_:
15255 	case FFEEXPR_contextIMPDOCTRL_:
15256 	case FFEEXPR_contextLOC_:
15257 	  bad = (k != FFEINFO_kindENTITY);	/* This catches "SUBROUTINE
15258 						   X(A);EXTERNAL A;CALL
15259 						   Y(A);B=A", for example. */
15260 	  break;
15261 
15262 	case FFEEXPR_contextCHARACTERSIZE:
15263 	case FFEEXPR_contextEQUIVALENCE:
15264 	case FFEEXPR_contextPARAMETER:
15265 	case FFEEXPR_contextDIMLIST:
15266 	case FFEEXPR_contextDIMLISTCOMMON:
15267 	case FFEEXPR_contextKINDTYPE:
15268 	case FFEEXPR_contextINITVAL:
15269 	case FFEEXPR_contextEQVINDEX_:
15270 	  bad = (k != FFEINFO_kindENTITY)
15271 	    || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
15272 	  break;
15273 
15274 	case FFEEXPR_contextINCLUDE:
15275 	  bad = TRUE;
15276 	  break;
15277 
15278 	default:
15279 	  bad = TRUE;
15280 	  break;
15281 	}
15282       if (bad && (k != FFEINFO_kindANY))
15283 	ffesymbol_error (s, t);
15284       return s;
15285 
15286     case FFESYMBOL_stateSEEN:	/* Seen but not yet in exec portion. */
15287     seen:			/* :::::::::::::::::::: */
15288       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15289 	{
15290 	case FFEEXPR_contextPARAMETER:
15291 	  if (ffeexpr_stack_->is_rhs)
15292 	    ffesymbol_error (s, t);
15293 	  else
15294 	    s = ffeexpr_sym_lhs_parameter_ (s, t);
15295 	  break;
15296 
15297 	case FFEEXPR_contextDATA:
15298 	  s = ffecom_sym_exec_transition (s);
15299 	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15300 	    goto understood;	/* :::::::::::::::::::: */
15301 	  if (ffeexpr_stack_->is_rhs)
15302 	    ffesymbol_error (s, t);
15303 	  else
15304 	    s = ffeexpr_sym_lhs_data_ (s, t);
15305 	  goto understood;	/* :::::::::::::::::::: */
15306 
15307 	case FFEEXPR_contextDATAIMPDOITEM_:
15308 	  s = ffecom_sym_exec_transition (s);
15309 	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15310 	    goto understood;	/* :::::::::::::::::::: */
15311 	  s = ffeexpr_sym_lhs_data_ (s, t);
15312 	  goto understood;	/* :::::::::::::::::::: */
15313 
15314 	case FFEEXPR_contextEQUIVALENCE:
15315 	  s = ffeexpr_sym_lhs_equivalence_ (s, t);
15316 	  break;
15317 
15318 	case FFEEXPR_contextDIMLIST:
15319 	  s = ffeexpr_sym_rhs_dimlist_ (s, t);
15320 	  break;
15321 
15322 	case FFEEXPR_contextCHARACTERSIZE:
15323 	case FFEEXPR_contextKINDTYPE:
15324 	case FFEEXPR_contextDIMLISTCOMMON:
15325 	case FFEEXPR_contextINITVAL:
15326 	case FFEEXPR_contextEQVINDEX_:
15327 	  ffesymbol_error (s, t);
15328 	  break;
15329 
15330 	case FFEEXPR_contextINCLUDE:
15331 	  ffesymbol_error (s, t);
15332 	  break;
15333 
15334 	case FFEEXPR_contextACTUALARG_:	/* E.g. I in REAL A(Y(I)). */
15335 	case FFEEXPR_contextSFUNCDEFACTUALARG_:
15336 	  s = ffecom_sym_exec_transition (s);
15337 	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15338 	    goto understood;	/* :::::::::::::::::::: */
15339 	  s = ffeexpr_sym_rhs_actualarg_ (s, t);
15340 	  goto understood;	/* :::::::::::::::::::: */
15341 
15342 	case FFEEXPR_contextINDEX_:
15343 	case FFEEXPR_contextACTUALARGEXPR_:
15344 	case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15345 	case FFEEXPR_contextSFUNCDEF:
15346 	case FFEEXPR_contextSFUNCDEFINDEX_:
15347 	case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15348 	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15349 	  assert (ffeexpr_stack_->is_rhs);
15350 	  s = ffecom_sym_exec_transition (s);
15351 	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15352 	    goto understood;	/* :::::::::::::::::::: */
15353 	  s = ffeexpr_sym_rhs_let_ (s, t);
15354 	  goto understood;	/* :::::::::::::::::::: */
15355 
15356 	default:
15357 	  ffesymbol_error (s, t);
15358 	  break;
15359 	}
15360       return s;
15361 
15362     default:
15363       assert ("bad symbol state" == NULL);
15364       return NULL;
15365       break;
15366     }
15367 }
15368 
15369 /* Have FOO in DATA (XYZ(FOO),...)/.../ or DATA (...,XYZ=FOO,BAR,BLETCH).
15370    Could be found via the "statement-function" name space (in which case
15371    it should become an iterator) or the local name space (in which case
15372    it should be either a named constant, or a variable that will have an
15373    sfunc name space sibling that should become an iterator).  */
15374 
15375 static ffesymbol
ffeexpr_sym_impdoitem_(ffesymbol sp,ffelexToken t)15376 ffeexpr_sym_impdoitem_ (ffesymbol sp, ffelexToken t)
15377 {
15378   ffesymbol s;
15379   ffesymbolAttrs sa;
15380   ffesymbolAttrs na;
15381   ffesymbolState ss;
15382   ffesymbolState ns;
15383   ffeinfoKind kind;
15384   ffeinfoWhere where;
15385 
15386   ss = ffesymbol_state (sp);
15387 
15388   if (ffesymbol_sfdummyparent (sp) != NULL)
15389     {				/* Have symbol in sfunc name space. */
15390       switch (ss)
15391 	{
15392 	case FFESYMBOL_stateNONE:	/* Used as iterator already. */
15393 	  if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
15394 	    ffesymbol_error (sp, t);	/* Can't use dead iterator. */
15395 	  else
15396 	    {			/* Can use dead iterator because we're at at
15397 				   least an innermore (higher-numbered) level
15398 				   than the iterator's outermost
15399 				   (lowest-numbered) level. */
15400 	      ffesymbol_signal_change (sp);
15401 	      ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
15402 	      ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
15403 	      ffesymbol_signal_unreported (sp);
15404 	    }
15405 	  break;
15406 
15407 	case FFESYMBOL_stateSEEN:	/* Seen already in this or other
15408 					   implied-DO.  Set symbol level
15409 					   number to outermost value, as that
15410 					   tells us we can see it as iterator
15411 					   at that level at the innermost. */
15412 	  if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
15413 	    {
15414 	      ffesymbol_signal_change (sp);
15415 	      ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
15416 	      ffesymbol_signal_unreported (sp);
15417 	    }
15418 	  break;
15419 
15420 	case FFESYMBOL_stateUNCERTAIN:	/* Iterator. */
15421 	  assert (ffeexpr_level_ == ffesymbol_maxentrynum (sp));
15422 	  ffesymbol_error (sp, t);	/* (,,,I=I,10). */
15423 	  break;
15424 
15425 	case FFESYMBOL_stateUNDERSTOOD:
15426 	  break;		/* ANY. */
15427 
15428 	default:
15429 	  assert ("Foo Bar!!" == NULL);
15430 	  break;
15431 	}
15432 
15433       return sp;
15434     }
15435 
15436   /* Got symbol in local name space, so we haven't seen it in impdo yet.
15437      First, if it is brand-new and we're in executable statements, set the
15438      attributes and exec-transition it to set state UNCERTAIN or UNDERSTOOD.
15439      Second, if it is now a constant (PARAMETER), then just return it, it
15440      can't be an implied-do iterator.  If it is understood, complain if it is
15441      not a valid variable, but make the inner name space iterator anyway and
15442      return that.  If it is not understood, improve understanding of the
15443      symbol accordingly, complain accordingly, in either case make the inner
15444      name space iterator and return that.  */
15445 
15446   sa = ffesymbol_attrs (sp);
15447 
15448   if (ffesymbol_state_is_specable (ss)
15449       && ffest_seen_first_exec ())
15450     {
15451       assert (sa == FFESYMBOL_attrsetNONE);
15452       ffesymbol_signal_change (sp);
15453       ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
15454       ffesymbol_resolve_intrin (sp);
15455       if (ffeimplic_establish_symbol (sp))
15456 	ffesymbol_set_attr (sp, FFESYMBOL_attrSFARG);
15457       else
15458 	ffesymbol_error (sp, t);
15459 
15460       /* After the exec transition, the state will either be UNCERTAIN (could
15461 	 be a dummy or local var) or UNDERSTOOD (local var, because this is a
15462 	 PROGRAM/BLOCKDATA program unit).  */
15463 
15464       sp = ffecom_sym_exec_transition (sp);
15465       sa = ffesymbol_attrs (sp);
15466       ss = ffesymbol_state (sp);
15467     }
15468 
15469   ns = ss;
15470   kind = ffesymbol_kind (sp);
15471   where = ffesymbol_where (sp);
15472 
15473   if (ss == FFESYMBOL_stateUNDERSTOOD)
15474     {
15475       if (kind != FFEINFO_kindENTITY)
15476 	ffesymbol_error (sp, t);
15477       if (where == FFEINFO_whereCONSTANT)
15478 	return sp;
15479     }
15480   else
15481     {
15482       /* Enhance understanding of local symbol.  This used to imply exec
15483 	 transition, but that doesn't seem necessary, since the local symbol
15484 	 doesn't actually get put into an ffebld tree here -- we just learn
15485 	 more about it, just like when we see a local symbol's name in the
15486 	 dummy-arg list of a statement function.  */
15487 
15488       if (ss != FFESYMBOL_stateUNCERTAIN)
15489 	{
15490 	  /* Figure out what kind of object we've got based on previous
15491 	     declarations of or references to the object. */
15492 
15493 	  ns = FFESYMBOL_stateSEEN;
15494 
15495 	  if (sa & FFESYMBOL_attrsANY)
15496 	    na = sa;
15497 	  else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
15498 			    | FFESYMBOL_attrsANY
15499 			    | FFESYMBOL_attrsCOMMON
15500 			    | FFESYMBOL_attrsDUMMY
15501 			    | FFESYMBOL_attrsEQUIV
15502 			    | FFESYMBOL_attrsINIT
15503 			    | FFESYMBOL_attrsNAMELIST
15504 			    | FFESYMBOL_attrsRESULT
15505 			    | FFESYMBOL_attrsSAVE
15506 			    | FFESYMBOL_attrsSFARG
15507 			    | FFESYMBOL_attrsTYPE)))
15508 	    na = sa | FFESYMBOL_attrsSFARG;
15509 	  else
15510 	    na = FFESYMBOL_attrsetNONE;
15511 	}
15512       else
15513 	{			/* stateUNCERTAIN. */
15514 	  na = sa | FFESYMBOL_attrsSFARG;
15515 	  ns = FFESYMBOL_stateUNDERSTOOD;
15516 
15517 	  assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15518 			   | FFESYMBOL_attrsADJUSTABLE
15519 			   | FFESYMBOL_attrsANYLEN
15520 			   | FFESYMBOL_attrsARRAY
15521 			   | FFESYMBOL_attrsDUMMY
15522 			   | FFESYMBOL_attrsEXTERNAL
15523 			   | FFESYMBOL_attrsSFARG
15524 			   | FFESYMBOL_attrsTYPE)));
15525 
15526 	  if (sa & FFESYMBOL_attrsEXTERNAL)
15527 	    {
15528 	      assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15529 			       | FFESYMBOL_attrsDUMMY
15530 			       | FFESYMBOL_attrsEXTERNAL
15531 			       | FFESYMBOL_attrsTYPE)));
15532 
15533 	      na = FFESYMBOL_attrsetNONE;
15534 	    }
15535 	  else if (sa & FFESYMBOL_attrsDUMMY)
15536 	    {
15537 	      assert (!(sa & FFESYMBOL_attrsEXTERNAL));	/* Handled above. */
15538 	      assert (!(sa & ~(FFESYMBOL_attrsDUMMY
15539 			       | FFESYMBOL_attrsEXTERNAL
15540 			       | FFESYMBOL_attrsTYPE)));
15541 
15542 	      kind = FFEINFO_kindENTITY;
15543 	    }
15544 	  else if (sa & FFESYMBOL_attrsARRAY)
15545 	    {
15546 	      assert (!(sa & ~(FFESYMBOL_attrsARRAY
15547 			       | FFESYMBOL_attrsADJUSTABLE
15548 			       | FFESYMBOL_attrsTYPE)));
15549 
15550 	      na = FFESYMBOL_attrsetNONE;
15551 	    }
15552 	  else if (sa & FFESYMBOL_attrsSFARG)
15553 	    {
15554 	      assert (!(sa & ~(FFESYMBOL_attrsSFARG
15555 			       | FFESYMBOL_attrsTYPE)));
15556 
15557 	      ns = FFESYMBOL_stateUNCERTAIN;
15558 	    }
15559 	  else if (sa & FFESYMBOL_attrsTYPE)
15560 	    {
15561 	      assert (!(sa & (FFESYMBOL_attrsARRAY
15562 			      | FFESYMBOL_attrsDUMMY
15563 			      | FFESYMBOL_attrsEXTERNAL
15564 			      | FFESYMBOL_attrsSFARG)));	/* Handled above. */
15565 	      assert (!(sa & ~(FFESYMBOL_attrsTYPE
15566 			       | FFESYMBOL_attrsADJUSTABLE
15567 			       | FFESYMBOL_attrsANYLEN
15568 			       | FFESYMBOL_attrsARRAY
15569 			       | FFESYMBOL_attrsDUMMY
15570 			       | FFESYMBOL_attrsEXTERNAL
15571 			       | FFESYMBOL_attrsSFARG)));
15572 
15573 	      kind = FFEINFO_kindENTITY;
15574 
15575 	      if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
15576 		na = FFESYMBOL_attrsetNONE;
15577 	      else if (ffest_is_entry_valid ())
15578 		ns = FFESYMBOL_stateUNCERTAIN;	/* Could be DUMMY or LOCAL. */
15579 	      else
15580 		where = FFEINFO_whereLOCAL;
15581 	    }
15582 	  else
15583 	    na = FFESYMBOL_attrsetNONE;	/* Error. */
15584 	}
15585 
15586       /* Now see what we've got for a new object: NONE means a new error
15587 	 cropped up; ANY means an old error to be ignored; otherwise,
15588 	 everything's ok, update the object (symbol) and continue on. */
15589 
15590       if (na == FFESYMBOL_attrsetNONE)
15591 	ffesymbol_error (sp, t);
15592       else if (!(na & FFESYMBOL_attrsANY))
15593 	{
15594 	  ffesymbol_signal_change (sp);	/* May need to back up to previous
15595 					   version. */
15596 	  if (!ffeimplic_establish_symbol (sp))
15597 	    ffesymbol_error (sp, t);
15598 	  else
15599 	    {
15600 	      ffesymbol_set_info (sp,
15601 				  ffeinfo_new (ffesymbol_basictype (sp),
15602 					       ffesymbol_kindtype (sp),
15603 					       ffesymbol_rank (sp),
15604 					       kind,
15605 					       where,
15606 					       ffesymbol_size (sp)));
15607 	      ffesymbol_set_attrs (sp, na);
15608 	      ffesymbol_set_state (sp, ns);
15609 	      ffesymbol_resolve_intrin (sp);
15610 	      if (!ffesymbol_state_is_specable (ns))
15611 		sp = ffecom_sym_learned (sp);
15612 	      ffesymbol_signal_unreported (sp);	/* For debugging purposes. */
15613 	    }
15614 	}
15615     }
15616 
15617   /* Here we create the sfunc-name-space symbol representing what should
15618      become an iterator in this name space at this or an outermore (lower-
15619      numbered) expression level, else the implied-DO construct is in error.  */
15620 
15621   s = ffesymbol_declare_sfdummy (t);	/* Sets maxentrynum to 0 for new obj;
15622 					   also sets sfa_dummy_parent to
15623 					   parent symbol. */
15624   assert (sp == ffesymbol_sfdummyparent (s));
15625 
15626   ffesymbol_signal_change (s);
15627   ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
15628   ffesymbol_set_maxentrynum (s, ffeexpr_level_);
15629   ffesymbol_set_info (s,
15630 		      ffeinfo_new (FFEINFO_basictypeINTEGER,
15631 				   FFEINFO_kindtypeINTEGERDEFAULT,
15632 				   0,
15633 				   FFEINFO_kindENTITY,
15634 				   FFEINFO_whereIMMEDIATE,
15635 				   FFETARGET_charactersizeNONE));
15636   ffesymbol_signal_unreported (s);
15637 
15638   if ((ffesymbol_basictype (sp) != FFEINFO_basictypeINTEGER)
15639        && (ffesymbol_basictype (sp) != FFEINFO_basictypeANY))
15640     ffesymbol_error (s, t);
15641 
15642   return s;
15643 }
15644 
15645 /* Have FOO in CALL FOO.  Local name space, executable context only.  */
15646 
15647 static ffesymbol
ffeexpr_sym_lhs_call_(ffesymbol s,ffelexToken t)15648 ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t)
15649 {
15650   ffesymbolAttrs sa;
15651   ffesymbolAttrs na;
15652   ffeinfoKind kind;
15653   ffeinfoWhere where;
15654   ffeintrinGen gen;
15655   ffeintrinSpec spec;
15656   ffeintrinImp imp;
15657   bool error = FALSE;
15658 
15659   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
15660 	  || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
15661 
15662   na = sa = ffesymbol_attrs (s);
15663 
15664   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15665 		   | FFESYMBOL_attrsADJUSTABLE
15666 		   | FFESYMBOL_attrsANYLEN
15667 		   | FFESYMBOL_attrsARRAY
15668 		   | FFESYMBOL_attrsDUMMY
15669 		   | FFESYMBOL_attrsEXTERNAL
15670 		   | FFESYMBOL_attrsSFARG
15671 		   | FFESYMBOL_attrsTYPE)));
15672 
15673   kind = ffesymbol_kind (s);
15674   where = ffesymbol_where (s);
15675 
15676   /* Figure out what kind of object we've got based on previous declarations
15677      of or references to the object. */
15678 
15679   if (sa & FFESYMBOL_attrsEXTERNAL)
15680     {
15681       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15682 		       | FFESYMBOL_attrsDUMMY
15683 		       | FFESYMBOL_attrsEXTERNAL
15684 		       | FFESYMBOL_attrsTYPE)));
15685 
15686       if (sa & FFESYMBOL_attrsTYPE)
15687 	error = TRUE;
15688       else
15689 	/* Not TYPE. */
15690 	{
15691 	  kind = FFEINFO_kindSUBROUTINE;
15692 
15693 	  if (sa & FFESYMBOL_attrsDUMMY)
15694 	    ;			/* Not TYPE. */
15695 	  else if (sa & FFESYMBOL_attrsACTUALARG)
15696 	    ;			/* Not DUMMY or TYPE. */
15697 	  else			/* Not ACTUALARG, DUMMY, or TYPE. */
15698 	    where = FFEINFO_whereGLOBAL;
15699 	}
15700     }
15701   else if (sa & FFESYMBOL_attrsDUMMY)
15702     {
15703       assert (!(sa & FFESYMBOL_attrsEXTERNAL));	/* Handled above. */
15704       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
15705 		       | FFESYMBOL_attrsEXTERNAL
15706 		       | FFESYMBOL_attrsTYPE)));
15707 
15708       if (sa & FFESYMBOL_attrsTYPE)
15709 	error = TRUE;
15710       else
15711 	kind = FFEINFO_kindSUBROUTINE;
15712     }
15713   else if (sa & FFESYMBOL_attrsARRAY)
15714     {
15715       assert (!(sa & ~(FFESYMBOL_attrsARRAY
15716 		       | FFESYMBOL_attrsADJUSTABLE
15717 		       | FFESYMBOL_attrsTYPE)));
15718 
15719       error = TRUE;
15720     }
15721   else if (sa & FFESYMBOL_attrsSFARG)
15722     {
15723       assert (!(sa & ~(FFESYMBOL_attrsSFARG
15724 		       | FFESYMBOL_attrsTYPE)));
15725 
15726       error = TRUE;
15727     }
15728   else if (sa & FFESYMBOL_attrsTYPE)
15729     {
15730       assert (!(sa & (FFESYMBOL_attrsARRAY
15731 		      | FFESYMBOL_attrsDUMMY
15732 		      | FFESYMBOL_attrsEXTERNAL
15733 		      | FFESYMBOL_attrsSFARG)));	/* Handled above. */
15734       assert (!(sa & ~(FFESYMBOL_attrsTYPE
15735 		       | FFESYMBOL_attrsADJUSTABLE
15736 		       | FFESYMBOL_attrsANYLEN
15737 		       | FFESYMBOL_attrsARRAY
15738 		       | FFESYMBOL_attrsDUMMY
15739 		       | FFESYMBOL_attrsEXTERNAL
15740 		       | FFESYMBOL_attrsSFARG)));
15741 
15742       error = TRUE;
15743     }
15744   else if (sa == FFESYMBOL_attrsetNONE)
15745     {
15746       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
15747 
15748       if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
15749 				  &gen, &spec, &imp))
15750 	{
15751 	  ffesymbol_signal_change (s);	/* May need to back up to previous
15752 					   version. */
15753 	  ffesymbol_set_generic (s, gen);
15754 	  ffesymbol_set_specific (s, spec);
15755 	  ffesymbol_set_implementation (s, imp);
15756 	  ffesymbol_set_info (s,
15757 			      ffeinfo_new (FFEINFO_basictypeNONE,
15758 					   FFEINFO_kindtypeNONE,
15759 					   0,
15760 					   FFEINFO_kindSUBROUTINE,
15761 					   FFEINFO_whereINTRINSIC,
15762 					   FFETARGET_charactersizeNONE));
15763 	  ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
15764 	  ffesymbol_resolve_intrin (s);
15765 	  ffesymbol_reference (s, t, FALSE);
15766 	  s = ffecom_sym_learned (s);
15767 	  ffesymbol_signal_unreported (s);	/* For debugging purposes. */
15768 
15769 	  return s;
15770 	}
15771 
15772       kind = FFEINFO_kindSUBROUTINE;
15773       where = FFEINFO_whereGLOBAL;
15774     }
15775   else
15776     error = TRUE;
15777 
15778   /* Now see what we've got for a new object: NONE means a new error cropped
15779      up; ANY means an old error to be ignored; otherwise, everything's ok,
15780      update the object (symbol) and continue on. */
15781 
15782   if (error)
15783     ffesymbol_error (s, t);
15784   else if (!(na & FFESYMBOL_attrsANY))
15785     {
15786       ffesymbol_signal_change (s);	/* May need to back up to previous
15787 					   version. */
15788       ffesymbol_set_info (s,
15789 			  ffeinfo_new (ffesymbol_basictype (s),
15790 				       ffesymbol_kindtype (s),
15791 				       ffesymbol_rank (s),
15792 				       kind,	/* SUBROUTINE. */
15793 				       where,	/* GLOBAL or DUMMY. */
15794 				       ffesymbol_size (s)));
15795       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
15796       ffesymbol_resolve_intrin (s);
15797       ffesymbol_reference (s, t, FALSE);
15798       s = ffecom_sym_learned (s);
15799       ffesymbol_signal_unreported (s);	/* For debugging purposes. */
15800     }
15801 
15802   return s;
15803 }
15804 
15805 /* Have FOO in DATA FOO/.../.  Local name space and executable context
15806    only.  (This will change in the future when DATA FOO may be followed
15807    by COMMON FOO or even INTEGER FOO(10), etc.)  */
15808 
15809 static ffesymbol
ffeexpr_sym_lhs_data_(ffesymbol s,ffelexToken t)15810 ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t)
15811 {
15812   ffesymbolAttrs sa;
15813   ffesymbolAttrs na;
15814   ffeinfoKind kind;
15815   ffeinfoWhere where;
15816   bool error = FALSE;
15817 
15818   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
15819 	  || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
15820 
15821   na = sa = ffesymbol_attrs (s);
15822 
15823   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15824 		   | FFESYMBOL_attrsADJUSTABLE
15825 		   | FFESYMBOL_attrsANYLEN
15826 		   | FFESYMBOL_attrsARRAY
15827 		   | FFESYMBOL_attrsDUMMY
15828 		   | FFESYMBOL_attrsEXTERNAL
15829 		   | FFESYMBOL_attrsSFARG
15830 		   | FFESYMBOL_attrsTYPE)));
15831 
15832   kind = ffesymbol_kind (s);
15833   where = ffesymbol_where (s);
15834 
15835   /* Figure out what kind of object we've got based on previous declarations
15836      of or references to the object. */
15837 
15838   if (sa & FFESYMBOL_attrsEXTERNAL)
15839     {
15840       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15841 		       | FFESYMBOL_attrsDUMMY
15842 		       | FFESYMBOL_attrsEXTERNAL
15843 		       | FFESYMBOL_attrsTYPE)));
15844 
15845       error = TRUE;
15846     }
15847   else if (sa & FFESYMBOL_attrsDUMMY)
15848     {
15849       assert (!(sa & FFESYMBOL_attrsEXTERNAL));	/* Handled above. */
15850       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
15851 		       | FFESYMBOL_attrsEXTERNAL
15852 		       | FFESYMBOL_attrsTYPE)));
15853 
15854       error = TRUE;
15855     }
15856   else if (sa & FFESYMBOL_attrsARRAY)
15857     {
15858       assert (!(sa & ~(FFESYMBOL_attrsARRAY
15859 		       | FFESYMBOL_attrsADJUSTABLE
15860 		       | FFESYMBOL_attrsTYPE)));
15861 
15862       if (sa & FFESYMBOL_attrsADJUSTABLE)
15863 	error = TRUE;
15864       where = FFEINFO_whereLOCAL;
15865     }
15866   else if (sa & FFESYMBOL_attrsSFARG)
15867     {
15868       assert (!(sa & ~(FFESYMBOL_attrsSFARG
15869 		       | FFESYMBOL_attrsTYPE)));
15870 
15871       where = FFEINFO_whereLOCAL;
15872     }
15873   else if (sa & FFESYMBOL_attrsTYPE)
15874     {
15875       assert (!(sa & (FFESYMBOL_attrsARRAY
15876 		      | FFESYMBOL_attrsDUMMY
15877 		      | FFESYMBOL_attrsEXTERNAL
15878 		      | FFESYMBOL_attrsSFARG)));	/* Handled above. */
15879       assert (!(sa & ~(FFESYMBOL_attrsTYPE
15880 		       | FFESYMBOL_attrsADJUSTABLE
15881 		       | FFESYMBOL_attrsANYLEN
15882 		       | FFESYMBOL_attrsARRAY
15883 		       | FFESYMBOL_attrsDUMMY
15884 		       | FFESYMBOL_attrsEXTERNAL
15885 		       | FFESYMBOL_attrsSFARG)));
15886 
15887       if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
15888 	error = TRUE;
15889       else
15890 	{
15891 	  kind = FFEINFO_kindENTITY;
15892 	  where = FFEINFO_whereLOCAL;
15893 	}
15894     }
15895   else if (sa == FFESYMBOL_attrsetNONE)
15896     {
15897       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
15898       kind = FFEINFO_kindENTITY;
15899       where = FFEINFO_whereLOCAL;
15900     }
15901   else
15902     error = TRUE;
15903 
15904   /* Now see what we've got for a new object: NONE means a new error cropped
15905      up; ANY means an old error to be ignored; otherwise, everything's ok,
15906      update the object (symbol) and continue on. */
15907 
15908   if (error)
15909     ffesymbol_error (s, t);
15910   else if (!(na & FFESYMBOL_attrsANY))
15911     {
15912       ffesymbol_signal_change (s);	/* May need to back up to previous
15913 					   version. */
15914       if (!ffeimplic_establish_symbol (s))
15915 	{
15916 	  ffesymbol_error (s, t);
15917 	  return s;
15918 	}
15919       ffesymbol_set_info (s,
15920 			  ffeinfo_new (ffesymbol_basictype (s),
15921 				       ffesymbol_kindtype (s),
15922 				       ffesymbol_rank (s),
15923 				       kind,	/* ENTITY. */
15924 				       where,	/* LOCAL. */
15925 				       ffesymbol_size (s)));
15926       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
15927       ffesymbol_resolve_intrin (s);
15928       s = ffecom_sym_learned (s);
15929       ffesymbol_signal_unreported (s);	/* For debugging purposes. */
15930     }
15931 
15932   return s;
15933 }
15934 
15935 /* Have FOO in EQUIVALENCE (...,FOO,...).  Does not include
15936    EQUIVALENCE (...,BAR(FOO),...).  */
15937 
15938 static ffesymbol
ffeexpr_sym_lhs_equivalence_(ffesymbol s,ffelexToken t)15939 ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t)
15940 {
15941   ffesymbolAttrs sa;
15942   ffesymbolAttrs na;
15943   ffeinfoKind kind;
15944   ffeinfoWhere where;
15945 
15946   na = sa = ffesymbol_attrs (s);
15947   kind = FFEINFO_kindENTITY;
15948   where = ffesymbol_where (s);
15949 
15950   /* Figure out what kind of object we've got based on previous declarations
15951      of or references to the object. */
15952 
15953   if (!(sa & ~(FFESYMBOL_attrsADJUSTS
15954 	       | FFESYMBOL_attrsARRAY
15955 	       | FFESYMBOL_attrsCOMMON
15956 	       | FFESYMBOL_attrsEQUIV
15957 	       | FFESYMBOL_attrsINIT
15958 	       | FFESYMBOL_attrsNAMELIST
15959 	       | FFESYMBOL_attrsSAVE
15960 	       | FFESYMBOL_attrsSFARG
15961 	       | FFESYMBOL_attrsTYPE)))
15962     na = sa | FFESYMBOL_attrsEQUIV;
15963   else
15964     na = FFESYMBOL_attrsetNONE;
15965 
15966   /* Don't know why we're bothering to set kind and where in this code, but
15967      added the following to make it complete, in case it's really important.
15968      Generally this is left up to symbol exec transition.  */
15969 
15970   if (where == FFEINFO_whereNONE)
15971     {
15972       if (na & (FFESYMBOL_attrsADJUSTS
15973 		| FFESYMBOL_attrsCOMMON))
15974 	where = FFEINFO_whereCOMMON;
15975       else if (na & FFESYMBOL_attrsSAVE)
15976 	where = FFEINFO_whereLOCAL;
15977     }
15978 
15979   /* Now see what we've got for a new object: NONE means a new error cropped
15980      up; ANY means an old error to be ignored; otherwise, everything's ok,
15981      update the object (symbol) and continue on. */
15982 
15983   if (na == FFESYMBOL_attrsetNONE)
15984     ffesymbol_error (s, t);
15985   else if (!(na & FFESYMBOL_attrsANY))
15986     {
15987       ffesymbol_signal_change (s);	/* May need to back up to previous
15988 					   version. */
15989       ffesymbol_set_info (s,
15990 			  ffeinfo_new (ffesymbol_basictype (s),
15991 				       ffesymbol_kindtype (s),
15992 				       ffesymbol_rank (s),
15993 				       kind,	/* Always ENTITY. */
15994 				       where,	/* NONE, COMMON, or LOCAL. */
15995 				       ffesymbol_size (s)));
15996       ffesymbol_set_attrs (s, na);
15997       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
15998       ffesymbol_resolve_intrin (s);
15999       ffesymbol_signal_unreported (s);	/* For debugging purposes. */
16000     }
16001 
16002   return s;
16003 }
16004 
16005 /* Have FOO in OPEN(...,USEROPEN=FOO,...).  Executable context only.
16006 
16007    Note that I think this should be considered semantically similar to
16008    doing CALL XYZ(FOO), in that it should be considered like an
16009    ACTUALARG context.  In particular, without EXTERNAL being specified,
16010    it should not be allowed.  */
16011 
16012 static ffesymbol
ffeexpr_sym_lhs_extfunc_(ffesymbol s,ffelexToken t)16013 ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t)
16014 {
16015   ffesymbolAttrs sa;
16016   ffesymbolAttrs na;
16017   ffeinfoKind kind;
16018   ffeinfoWhere where;
16019   bool needs_type = FALSE;
16020   bool error = FALSE;
16021 
16022   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16023 	  || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16024 
16025   na = sa = ffesymbol_attrs (s);
16026 
16027   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16028 		   | FFESYMBOL_attrsADJUSTABLE
16029 		   | FFESYMBOL_attrsANYLEN
16030 		   | FFESYMBOL_attrsARRAY
16031 		   | FFESYMBOL_attrsDUMMY
16032 		   | FFESYMBOL_attrsEXTERNAL
16033 		   | FFESYMBOL_attrsSFARG
16034 		   | FFESYMBOL_attrsTYPE)));
16035 
16036   kind = ffesymbol_kind (s);
16037   where = ffesymbol_where (s);
16038 
16039   /* Figure out what kind of object we've got based on previous declarations
16040      of or references to the object. */
16041 
16042   if (sa & FFESYMBOL_attrsEXTERNAL)
16043     {
16044       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16045 		       | FFESYMBOL_attrsDUMMY
16046 		       | FFESYMBOL_attrsEXTERNAL
16047 		       | FFESYMBOL_attrsTYPE)));
16048 
16049       if (sa & FFESYMBOL_attrsTYPE)
16050 	where = FFEINFO_whereGLOBAL;
16051       else
16052 	/* Not TYPE. */
16053 	{
16054 	  kind = FFEINFO_kindFUNCTION;
16055 	  needs_type = TRUE;
16056 
16057 	  if (sa & FFESYMBOL_attrsDUMMY)
16058 	    ;			/* Not TYPE. */
16059 	  else if (sa & FFESYMBOL_attrsACTUALARG)
16060 	    ;			/* Not DUMMY or TYPE. */
16061 	  else			/* Not ACTUALARG, DUMMY, or TYPE. */
16062 	    where = FFEINFO_whereGLOBAL;
16063 	}
16064     }
16065   else if (sa & FFESYMBOL_attrsDUMMY)
16066     {
16067       assert (!(sa & FFESYMBOL_attrsEXTERNAL));	/* Handled above. */
16068       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16069 		       | FFESYMBOL_attrsEXTERNAL
16070 		       | FFESYMBOL_attrsTYPE)));
16071 
16072       kind = FFEINFO_kindFUNCTION;
16073       if (!(sa & FFESYMBOL_attrsTYPE))
16074 	needs_type = TRUE;
16075     }
16076   else if (sa & FFESYMBOL_attrsARRAY)
16077     {
16078       assert (!(sa & ~(FFESYMBOL_attrsARRAY
16079 		       | FFESYMBOL_attrsADJUSTABLE
16080 		       | FFESYMBOL_attrsTYPE)));
16081 
16082       error = TRUE;
16083     }
16084   else if (sa & FFESYMBOL_attrsSFARG)
16085     {
16086       assert (!(sa & ~(FFESYMBOL_attrsSFARG
16087 		       | FFESYMBOL_attrsTYPE)));
16088 
16089       error = TRUE;
16090     }
16091   else if (sa & FFESYMBOL_attrsTYPE)
16092     {
16093       assert (!(sa & (FFESYMBOL_attrsARRAY
16094 		      | FFESYMBOL_attrsDUMMY
16095 		      | FFESYMBOL_attrsEXTERNAL
16096 		      | FFESYMBOL_attrsSFARG)));	/* Handled above. */
16097       assert (!(sa & ~(FFESYMBOL_attrsTYPE
16098 		       | FFESYMBOL_attrsADJUSTABLE
16099 		       | FFESYMBOL_attrsANYLEN
16100 		       | FFESYMBOL_attrsARRAY
16101 		       | FFESYMBOL_attrsDUMMY
16102 		       | FFESYMBOL_attrsEXTERNAL
16103 		       | FFESYMBOL_attrsSFARG)));
16104 
16105       if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16106 	error = TRUE;
16107       else
16108 	{
16109 	  kind = FFEINFO_kindFUNCTION;
16110 	  where = FFEINFO_whereGLOBAL;
16111 	}
16112     }
16113   else if (sa == FFESYMBOL_attrsetNONE)
16114     {
16115       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16116       kind = FFEINFO_kindFUNCTION;
16117       where = FFEINFO_whereGLOBAL;
16118       needs_type = TRUE;
16119     }
16120   else
16121     error = TRUE;
16122 
16123   /* Now see what we've got for a new object: NONE means a new error cropped
16124      up; ANY means an old error to be ignored; otherwise, everything's ok,
16125      update the object (symbol) and continue on. */
16126 
16127   if (error)
16128     ffesymbol_error (s, t);
16129   else if (!(na & FFESYMBOL_attrsANY))
16130     {
16131       ffesymbol_signal_change (s);	/* May need to back up to previous
16132 					   version. */
16133       if (needs_type && !ffeimplic_establish_symbol (s))
16134 	{
16135 	  ffesymbol_error (s, t);
16136 	  return s;
16137 	}
16138       if (!ffesymbol_explicitwhere (s))
16139 	{
16140 	  ffebad_start (FFEBAD_NEED_EXTERNAL);
16141 	  ffebad_here (0, ffelex_token_where_line (t),
16142 		       ffelex_token_where_column (t));
16143 	  ffebad_string (ffesymbol_text (s));
16144 	  ffebad_finish ();
16145 	  ffesymbol_set_explicitwhere (s, TRUE);
16146 	}
16147       ffesymbol_set_info (s,
16148 			  ffeinfo_new (ffesymbol_basictype (s),
16149 				       ffesymbol_kindtype (s),
16150 				       ffesymbol_rank (s),
16151 				       kind,	/* FUNCTION. */
16152 				       where,	/* GLOBAL or DUMMY. */
16153 				       ffesymbol_size (s)));
16154       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16155       ffesymbol_resolve_intrin (s);
16156       ffesymbol_reference (s, t, FALSE);
16157       s = ffecom_sym_learned (s);
16158       ffesymbol_signal_unreported (s);	/* For debugging purposes. */
16159     }
16160 
16161   return s;
16162 }
16163 
16164 /* Have FOO in DATA (stuff,FOO=1,10)/.../.  */
16165 
16166 static ffesymbol
ffeexpr_sym_lhs_impdoctrl_(ffesymbol s,ffelexToken t)16167 ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t)
16168 {
16169   ffesymbolState ss;
16170 
16171   /* If the symbol isn't in the sfunc name space, pretend as though we saw a
16172      reference to it already within the imp-DO construct at this level, so as
16173      to get a symbol that is in the sfunc name space. But this is an
16174      erroneous construct, and should be caught elsewhere.  */
16175 
16176   if (ffesymbol_sfdummyparent (s) == NULL)
16177     {
16178       s = ffeexpr_sym_impdoitem_ (s, t);
16179       if (ffesymbol_sfdummyparent (s) == NULL)
16180 	{			/* PARAMETER FOO...DATA (A(I),FOO=...). */
16181 	  ffesymbol_error (s, t);
16182 	  return s;
16183 	}
16184     }
16185 
16186   ss = ffesymbol_state (s);
16187 
16188   switch (ss)
16189     {
16190     case FFESYMBOL_stateNONE:	/* Used as iterator already. */
16191       if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
16192 	ffesymbol_error (s, t);	/* Can't reuse dead iterator.  F90 disallows
16193 				   this; F77 allows it but it is a stupid
16194 				   feature. */
16195       else
16196 	{			/* Can use dead iterator because we're at at
16197 				   least a innermore (higher-numbered) level
16198 				   than the iterator's outermost
16199 				   (lowest-numbered) level.  This should be
16200 				   diagnosed later, because it means an item
16201 				   in this list didn't reference this
16202 				   iterator. */
16203 #if 1
16204 	  ffesymbol_error (s, t);	/* For now, complain. */
16205 #else /* Someday will detect all cases where initializer doesn't reference
16206 	 all applicable iterators, in which case reenable this code. */
16207 	  ffesymbol_signal_change (s);
16208 	  ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
16209 	  ffesymbol_set_maxentrynum (s, ffeexpr_level_);
16210 	  ffesymbol_signal_unreported (s);
16211 #endif
16212 	}
16213       break;
16214 
16215     case FFESYMBOL_stateSEEN:	/* Seen already in this or other implied-DO.
16216 				   If seen in outermore level, can't be an
16217 				   iterator here, so complain.  If not seen
16218 				   at current level, complain for now,
16219 				   because that indicates something F90
16220 				   rejects (though we currently don't detect
16221 				   all such cases for now). */
16222       if (ffeexpr_level_ <= ffesymbol_maxentrynum (s))
16223 	{
16224 	  ffesymbol_signal_change (s);
16225 	  ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
16226 	  ffesymbol_signal_unreported (s);
16227 	}
16228       else
16229 	ffesymbol_error (s, t);
16230       break;
16231 
16232     case FFESYMBOL_stateUNCERTAIN:	/* Already iterator! */
16233       assert ("DATA implied-DO control var seen twice!!" == NULL);
16234       ffesymbol_error (s, t);
16235       break;
16236 
16237     case FFESYMBOL_stateUNDERSTOOD:
16238       break;			/* ANY. */
16239 
16240     default:
16241       assert ("Foo Bletch!!" == NULL);
16242       break;
16243     }
16244 
16245   return s;
16246 }
16247 
16248 /* Have FOO in PARAMETER (FOO=...).  */
16249 
16250 static ffesymbol
ffeexpr_sym_lhs_parameter_(ffesymbol s,ffelexToken t)16251 ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t)
16252 {
16253   ffesymbolAttrs sa;
16254 
16255   sa = ffesymbol_attrs (s);
16256 
16257   /* Figure out what kind of object we've got based on previous declarations
16258      of or references to the object. */
16259 
16260   if (sa & ~(FFESYMBOL_attrsANYLEN
16261 	     | FFESYMBOL_attrsTYPE))
16262     {
16263       if (!(sa & FFESYMBOL_attrsANY))
16264 	ffesymbol_error (s, t);
16265     }
16266   else
16267     {
16268       ffesymbol_signal_change (s);	/* May need to back up to previous
16269 					   version. */
16270       if (!ffeimplic_establish_symbol (s))
16271 	{
16272 	  ffesymbol_error (s, t);
16273 	  return s;
16274 	}
16275       ffesymbol_set_info (s,
16276 			  ffeinfo_new (ffesymbol_basictype (s),
16277 				       ffesymbol_kindtype (s),
16278 				       ffesymbol_rank (s),
16279 				       FFEINFO_kindENTITY,
16280 				       FFEINFO_whereCONSTANT,
16281 				       ffesymbol_size (s)));
16282       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16283       ffesymbol_resolve_intrin (s);
16284       s = ffecom_sym_learned (s);
16285       ffesymbol_signal_unreported (s);	/* For debugging purposes. */
16286     }
16287 
16288   return s;
16289 }
16290 
16291 /* Have FOO in CALL XYZ(...,FOO,...).  Does not include any other
16292    embedding of FOO, such as CALL XYZ((FOO)) or CALL XYZ(FOO+1).  */
16293 
16294 static ffesymbol
ffeexpr_sym_rhs_actualarg_(ffesymbol s,ffelexToken t)16295 ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t)
16296 {
16297   ffesymbolAttrs sa;
16298   ffesymbolAttrs na;
16299   ffeinfoKind kind;
16300   ffeinfoWhere where;
16301   ffesymbolState ns;
16302   bool needs_type = FALSE;
16303 
16304   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16305 	  || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16306 
16307   na = sa = ffesymbol_attrs (s);
16308 
16309   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16310 		   | FFESYMBOL_attrsADJUSTABLE
16311 		   | FFESYMBOL_attrsANYLEN
16312 		   | FFESYMBOL_attrsARRAY
16313 		   | FFESYMBOL_attrsDUMMY
16314 		   | FFESYMBOL_attrsEXTERNAL
16315 		   | FFESYMBOL_attrsSFARG
16316 		   | FFESYMBOL_attrsTYPE)));
16317 
16318   kind = ffesymbol_kind (s);
16319   where = ffesymbol_where (s);
16320 
16321   /* Figure out what kind of object we've got based on previous declarations
16322      of or references to the object. */
16323 
16324   ns = FFESYMBOL_stateUNDERSTOOD;
16325 
16326   if (sa & FFESYMBOL_attrsEXTERNAL)
16327     {
16328       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16329 		       | FFESYMBOL_attrsDUMMY
16330 		       | FFESYMBOL_attrsEXTERNAL
16331 		       | FFESYMBOL_attrsTYPE)));
16332 
16333       if (sa & FFESYMBOL_attrsTYPE)
16334 	where = FFEINFO_whereGLOBAL;
16335       else
16336 	/* Not TYPE. */
16337 	{
16338 	  ns = FFESYMBOL_stateUNCERTAIN;
16339 
16340 	  if (sa & FFESYMBOL_attrsDUMMY)
16341 	    assert (kind == FFEINFO_kindNONE);	/* FUNCTION, SUBROUTINE. */
16342 	  else if (sa & FFESYMBOL_attrsACTUALARG)
16343 	    ;			/* Not DUMMY or TYPE. */
16344 	  else
16345 	    /* Not ACTUALARG, DUMMY, or TYPE. */
16346 	    {
16347 	      assert (kind == FFEINFO_kindNONE);	/* FUNCTION, SUBROUTINE. */
16348 	      na |= FFESYMBOL_attrsACTUALARG;
16349 	      where = FFEINFO_whereGLOBAL;
16350 	    }
16351 	}
16352     }
16353   else if (sa & FFESYMBOL_attrsDUMMY)
16354     {
16355       assert (!(sa & FFESYMBOL_attrsEXTERNAL));	/* Handled above. */
16356       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16357 		       | FFESYMBOL_attrsEXTERNAL
16358 		       | FFESYMBOL_attrsTYPE)));
16359 
16360       kind = FFEINFO_kindENTITY;
16361       if (!(sa & FFESYMBOL_attrsTYPE))
16362 	needs_type = TRUE;
16363     }
16364   else if (sa & FFESYMBOL_attrsARRAY)
16365     {
16366       assert (!(sa & ~(FFESYMBOL_attrsARRAY
16367 		       | FFESYMBOL_attrsADJUSTABLE
16368 		       | FFESYMBOL_attrsTYPE)));
16369 
16370       where = FFEINFO_whereLOCAL;
16371     }
16372   else if (sa & FFESYMBOL_attrsSFARG)
16373     {
16374       assert (!(sa & ~(FFESYMBOL_attrsSFARG
16375 		       | FFESYMBOL_attrsTYPE)));
16376 
16377       where = FFEINFO_whereLOCAL;
16378     }
16379   else if (sa & FFESYMBOL_attrsTYPE)
16380     {
16381       assert (!(sa & (FFESYMBOL_attrsARRAY
16382 		      | FFESYMBOL_attrsDUMMY
16383 		      | FFESYMBOL_attrsEXTERNAL
16384 		      | FFESYMBOL_attrsSFARG)));	/* Handled above. */
16385       assert (!(sa & ~(FFESYMBOL_attrsTYPE
16386 		       | FFESYMBOL_attrsADJUSTABLE
16387 		       | FFESYMBOL_attrsANYLEN
16388 		       | FFESYMBOL_attrsARRAY
16389 		       | FFESYMBOL_attrsDUMMY
16390 		       | FFESYMBOL_attrsEXTERNAL
16391 		       | FFESYMBOL_attrsSFARG)));
16392 
16393       if (sa & FFESYMBOL_attrsANYLEN)
16394 	ns = FFESYMBOL_stateNONE;
16395       else
16396 	{
16397 	  kind = FFEINFO_kindENTITY;
16398 	  where = FFEINFO_whereLOCAL;
16399 	}
16400     }
16401   else if (sa == FFESYMBOL_attrsetNONE)
16402     {
16403       /* New state is left empty because there isn't any state flag to
16404 	 set for this case, and it's UNDERSTOOD after all.  */
16405       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16406       kind = FFEINFO_kindENTITY;
16407       where = FFEINFO_whereLOCAL;
16408       needs_type = TRUE;
16409     }
16410   else
16411     ns = FFESYMBOL_stateNONE;	/* Error. */
16412 
16413   /* Now see what we've got for a new object: NONE means a new error cropped
16414      up; ANY means an old error to be ignored; otherwise, everything's ok,
16415      update the object (symbol) and continue on. */
16416 
16417   if (ns == FFESYMBOL_stateNONE)
16418     ffesymbol_error (s, t);
16419   else if (!(na & FFESYMBOL_attrsANY))
16420     {
16421       ffesymbol_signal_change (s);	/* May need to back up to previous
16422 					   version. */
16423       if (needs_type && !ffeimplic_establish_symbol (s))
16424 	{
16425 	  ffesymbol_error (s, t);
16426 	  return s;
16427 	}
16428       ffesymbol_set_info (s,
16429 			  ffeinfo_new (ffesymbol_basictype (s),
16430 				       ffesymbol_kindtype (s),
16431 				       ffesymbol_rank (s),
16432 				       kind,
16433 				       where,
16434 				       ffesymbol_size (s)));
16435       ffesymbol_set_attrs (s, na);
16436       ffesymbol_set_state (s, ns);
16437       s = ffecom_sym_learned (s);
16438       ffesymbol_reference (s, t, FALSE);
16439       ffesymbol_signal_unreported (s);	/* For debugging purposes. */
16440     }
16441 
16442   return s;
16443 }
16444 
16445 /* Have FOO in DIMENSION XYZ(FOO) or any array declarator containing
16446    a reference to FOO.  */
16447 
16448 static ffesymbol
ffeexpr_sym_rhs_dimlist_(ffesymbol s,ffelexToken t)16449 ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t)
16450 {
16451   ffesymbolAttrs sa;
16452   ffesymbolAttrs na;
16453   ffeinfoKind kind;
16454   ffeinfoWhere where;
16455 
16456   na = sa = ffesymbol_attrs (s);
16457   kind = FFEINFO_kindENTITY;
16458   where = ffesymbol_where (s);
16459 
16460   /* Figure out what kind of object we've got based on previous declarations
16461      of or references to the object. */
16462 
16463   if (!(sa & ~(FFESYMBOL_attrsADJUSTS
16464 	       | FFESYMBOL_attrsCOMMON
16465 	       | FFESYMBOL_attrsDUMMY
16466 	       | FFESYMBOL_attrsEQUIV
16467 	       | FFESYMBOL_attrsINIT
16468 	       | FFESYMBOL_attrsNAMELIST
16469 	       | FFESYMBOL_attrsSFARG
16470                | FFESYMBOL_attrsARRAY
16471 	       | FFESYMBOL_attrsTYPE)))
16472     na = sa | FFESYMBOL_attrsADJUSTS;
16473   else
16474     na = FFESYMBOL_attrsetNONE;
16475 
16476   /* Since this symbol definitely is going into an expression (the
16477      dimension-list for some dummy array, presumably), figure out WHERE if
16478      possible.  */
16479 
16480   if (where == FFEINFO_whereNONE)
16481     {
16482       if (na & (FFESYMBOL_attrsCOMMON
16483 		| FFESYMBOL_attrsEQUIV
16484 		| FFESYMBOL_attrsINIT
16485 		| FFESYMBOL_attrsNAMELIST))
16486 	where = FFEINFO_whereCOMMON;
16487       else if (na & FFESYMBOL_attrsDUMMY)
16488 	where = FFEINFO_whereDUMMY;
16489     }
16490 
16491   /* Now see what we've got for a new object: NONE means a new error cropped
16492      up; ANY means an old error to be ignored; otherwise, everything's ok,
16493      update the object (symbol) and continue on. */
16494 
16495   if (na == FFESYMBOL_attrsetNONE)
16496     ffesymbol_error (s, t);
16497   else if (!(na & FFESYMBOL_attrsANY))
16498     {
16499       ffesymbol_signal_change (s);	/* May need to back up to previous
16500 					   version. */
16501       if (!ffeimplic_establish_symbol (s))
16502 	{
16503 	  ffesymbol_error (s, t);
16504 	  return s;
16505 	}
16506       ffesymbol_set_info (s,
16507 			  ffeinfo_new (ffesymbol_basictype (s),
16508 				       ffesymbol_kindtype (s),
16509 				       ffesymbol_rank (s),
16510 				       kind,	/* Always ENTITY. */
16511 				       where,	/* NONE, COMMON, or DUMMY. */
16512 				       ffesymbol_size (s)));
16513       ffesymbol_set_attrs (s, na);
16514       ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
16515       ffesymbol_resolve_intrin (s);
16516       ffesymbol_signal_unreported (s);	/* For debugging purposes. */
16517     }
16518 
16519   return s;
16520 }
16521 
16522 /* Have FOO in XYZ = ...FOO....  Does not include cases like FOO in
16523    XYZ = BAR(FOO), as such cases are handled elsewhere.  */
16524 
16525 static ffesymbol
ffeexpr_sym_rhs_let_(ffesymbol s,ffelexToken t)16526 ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t)
16527 {
16528   ffesymbolAttrs sa;
16529   ffesymbolAttrs na;
16530   ffeinfoKind kind;
16531   ffeinfoWhere where;
16532   bool error = FALSE;
16533 
16534   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16535 	  || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16536 
16537   na = sa = ffesymbol_attrs (s);
16538 
16539   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16540 		   | FFESYMBOL_attrsADJUSTABLE
16541 		   | FFESYMBOL_attrsANYLEN
16542 		   | FFESYMBOL_attrsARRAY
16543 		   | FFESYMBOL_attrsDUMMY
16544 		   | FFESYMBOL_attrsEXTERNAL
16545 		   | FFESYMBOL_attrsSFARG
16546 		   | FFESYMBOL_attrsTYPE)));
16547 
16548   kind = ffesymbol_kind (s);
16549   where = ffesymbol_where (s);
16550 
16551   /* Figure out what kind of object we've got based on previous declarations
16552      of or references to the object. */
16553 
16554   if (sa & FFESYMBOL_attrsEXTERNAL)
16555     {
16556       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16557 		       | FFESYMBOL_attrsDUMMY
16558 		       | FFESYMBOL_attrsEXTERNAL
16559 		       | FFESYMBOL_attrsTYPE)));
16560 
16561       error = TRUE;
16562     }
16563   else if (sa & FFESYMBOL_attrsDUMMY)
16564     {
16565       assert (!(sa & FFESYMBOL_attrsEXTERNAL));	/* Handled above. */
16566       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16567 		       | FFESYMBOL_attrsEXTERNAL
16568 		       | FFESYMBOL_attrsTYPE)));
16569 
16570       kind = FFEINFO_kindENTITY;
16571     }
16572   else if (sa & FFESYMBOL_attrsARRAY)
16573     {
16574       assert (!(sa & ~(FFESYMBOL_attrsARRAY
16575 		       | FFESYMBOL_attrsADJUSTABLE
16576 		       | FFESYMBOL_attrsTYPE)));
16577 
16578       where = FFEINFO_whereLOCAL;
16579     }
16580   else if (sa & FFESYMBOL_attrsSFARG)
16581     {
16582       assert (!(sa & ~(FFESYMBOL_attrsSFARG
16583 		       | FFESYMBOL_attrsTYPE)));
16584 
16585       where = FFEINFO_whereLOCAL;
16586     }
16587   else if (sa & FFESYMBOL_attrsTYPE)
16588     {
16589       assert (!(sa & (FFESYMBOL_attrsARRAY
16590 		      | FFESYMBOL_attrsDUMMY
16591 		      | FFESYMBOL_attrsEXTERNAL
16592 		      | FFESYMBOL_attrsSFARG)));	/* Handled above. */
16593       assert (!(sa & ~(FFESYMBOL_attrsTYPE
16594 		       | FFESYMBOL_attrsADJUSTABLE
16595 		       | FFESYMBOL_attrsANYLEN
16596 		       | FFESYMBOL_attrsARRAY
16597 		       | FFESYMBOL_attrsDUMMY
16598 		       | FFESYMBOL_attrsEXTERNAL
16599 		       | FFESYMBOL_attrsSFARG)));
16600 
16601       if (sa & FFESYMBOL_attrsANYLEN)
16602 	error = TRUE;
16603       else
16604 	{
16605 	  kind = FFEINFO_kindENTITY;
16606 	  where = FFEINFO_whereLOCAL;
16607 	}
16608     }
16609   else if (sa == FFESYMBOL_attrsetNONE)
16610     {
16611       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16612       kind = FFEINFO_kindENTITY;
16613       where = FFEINFO_whereLOCAL;
16614     }
16615   else
16616     error = TRUE;
16617 
16618   /* Now see what we've got for a new object: NONE means a new error cropped
16619      up; ANY means an old error to be ignored; otherwise, everything's ok,
16620      update the object (symbol) and continue on. */
16621 
16622   if (error)
16623     ffesymbol_error (s, t);
16624   else if (!(na & FFESYMBOL_attrsANY))
16625     {
16626       ffesymbol_signal_change (s);	/* May need to back up to previous
16627 					   version. */
16628       if (!ffeimplic_establish_symbol (s))
16629 	{
16630 	  ffesymbol_error (s, t);
16631 	  return s;
16632 	}
16633       ffesymbol_set_info (s,
16634 			  ffeinfo_new (ffesymbol_basictype (s),
16635 				       ffesymbol_kindtype (s),
16636 				       ffesymbol_rank (s),
16637 				       kind,	/* ENTITY. */
16638 				       where,	/* LOCAL. */
16639 				       ffesymbol_size (s)));
16640       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16641       ffesymbol_resolve_intrin (s);
16642       s = ffecom_sym_learned (s);
16643       ffesymbol_signal_unreported (s);	/* For debugging purposes. */
16644     }
16645 
16646   return s;
16647 }
16648 
16649 /* ffeexpr_declare_parenthesized_ -- ffesymbol wrapper for NAME(...) operand
16650 
16651    ffelexToken t;
16652    bool maybe_intrin;
16653    ffeexprParenType_ paren_type;
16654    ffesymbol s;
16655    s = ffeexpr_declare_parenthesized_ (t, maybe_intrin, &paren_type);
16656 
16657    Just like ffesymbol_declare_local, except performs any implicit info
16658    assignment necessary, and it returns the type of the parenthesized list
16659    (list of function args, list of array args, or substring spec).  */
16660 
16661 static ffesymbol
ffeexpr_declare_parenthesized_(ffelexToken t,bool maybe_intrin,ffeexprParenType_ * paren_type)16662 ffeexpr_declare_parenthesized_ (ffelexToken t, bool maybe_intrin,
16663 				ffeexprParenType_ *paren_type)
16664 {
16665   ffesymbol s;
16666   ffesymbolState st;		/* Effective state. */
16667   ffeinfoKind k;
16668   bool bad;
16669 
16670   if (maybe_intrin && ffesrc_check_symbol ())
16671     {				/* Knock off some easy cases. */
16672       switch (ffeexpr_stack_->context)
16673 	{
16674 	case FFEEXPR_contextSUBROUTINEREF:
16675 	case FFEEXPR_contextDATA:
16676 	case FFEEXPR_contextDATAIMPDOINDEX_:
16677 	case FFEEXPR_contextSFUNCDEF:
16678 	case FFEEXPR_contextSFUNCDEFINDEX_:
16679 	case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16680 	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16681 	case FFEEXPR_contextLET:
16682 	case FFEEXPR_contextPAREN_:
16683 	case FFEEXPR_contextACTUALARGEXPR_:
16684 	case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16685 	case FFEEXPR_contextIOLIST:
16686 	case FFEEXPR_contextIOLISTDF:
16687 	case FFEEXPR_contextDO:
16688 	case FFEEXPR_contextDOWHILE:
16689 	case FFEEXPR_contextACTUALARG_:
16690 	case FFEEXPR_contextCGOTO:
16691 	case FFEEXPR_contextIF:
16692 	case FFEEXPR_contextARITHIF:
16693 	case FFEEXPR_contextFORMAT:
16694 	case FFEEXPR_contextSTOP:
16695 	case FFEEXPR_contextRETURN:
16696 	case FFEEXPR_contextSELECTCASE:
16697 	case FFEEXPR_contextCASE:
16698 	case FFEEXPR_contextFILEASSOC:
16699 	case FFEEXPR_contextFILEINT:
16700 	case FFEEXPR_contextFILEDFINT:
16701 	case FFEEXPR_contextFILELOG:
16702 	case FFEEXPR_contextFILENUM:
16703 	case FFEEXPR_contextFILENUMAMBIG:
16704 	case FFEEXPR_contextFILECHAR:
16705 	case FFEEXPR_contextFILENUMCHAR:
16706 	case FFEEXPR_contextFILEDFCHAR:
16707 	case FFEEXPR_contextFILEKEY:
16708 	case FFEEXPR_contextFILEUNIT:
16709 	case FFEEXPR_contextFILEUNIT_DF:
16710 	case FFEEXPR_contextFILEUNITAMBIG:
16711 	case FFEEXPR_contextFILEFORMAT:
16712 	case FFEEXPR_contextFILENAMELIST:
16713 	case FFEEXPR_contextFILEVXTCODE:
16714 	case FFEEXPR_contextINDEX_:
16715 	case FFEEXPR_contextIMPDOITEM_:
16716 	case FFEEXPR_contextIMPDOITEMDF_:
16717 	case FFEEXPR_contextIMPDOCTRL_:
16718 	case FFEEXPR_contextDATAIMPDOCTRL_:
16719 	case FFEEXPR_contextCHARACTERSIZE:
16720 	case FFEEXPR_contextPARAMETER:
16721 	case FFEEXPR_contextDIMLIST:
16722 	case FFEEXPR_contextDIMLISTCOMMON:
16723 	case FFEEXPR_contextKINDTYPE:
16724 	case FFEEXPR_contextINITVAL:
16725 	case FFEEXPR_contextEQVINDEX_:
16726 	  break;		/* These could be intrinsic invocations. */
16727 
16728 	case FFEEXPR_contextAGOTO:
16729 	case FFEEXPR_contextFILEFORMATNML:
16730 	case FFEEXPR_contextALLOCATE:
16731 	case FFEEXPR_contextDEALLOCATE:
16732 	case FFEEXPR_contextHEAPSTAT:
16733 	case FFEEXPR_contextNULLIFY:
16734 	case FFEEXPR_contextINCLUDE:
16735 	case FFEEXPR_contextDATAIMPDOITEM_:
16736 	case FFEEXPR_contextLOC_:
16737 	case FFEEXPR_contextINDEXORACTUALARG_:
16738 	case FFEEXPR_contextSFUNCDEFACTUALARG_:
16739 	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
16740 	case FFEEXPR_contextPARENFILENUM_:
16741 	case FFEEXPR_contextPARENFILEUNIT_:
16742 	  maybe_intrin = FALSE;
16743 	  break;		/* Can't be intrinsic invocation. */
16744 
16745 	default:
16746 	  assert ("blah! blah! waaauuggh!" == NULL);
16747 	  break;
16748 	}
16749     }
16750 
16751   s = ffesymbol_declare_local (t, maybe_intrin);
16752 
16753   switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16754     /* Special-case these since they can involve a different concept
16755        of "state" (in the stmtfunc name space).  */
16756     {
16757     case FFEEXPR_contextDATAIMPDOINDEX_:
16758     case FFEEXPR_contextDATAIMPDOCTRL_:
16759       if (ffeexpr_context_outer_ (ffeexpr_stack_)
16760 	  == FFEEXPR_contextDATAIMPDOINDEX_)
16761 	s = ffeexpr_sym_impdoitem_ (s, t);
16762       else
16763 	if (ffeexpr_stack_->is_rhs)
16764 	  s = ffeexpr_sym_impdoitem_ (s, t);
16765 	else
16766 	  s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
16767       if (ffesymbol_kind (s) != FFEINFO_kindANY)
16768 	ffesymbol_error (s, t);
16769       return s;
16770 
16771     default:
16772       break;
16773     }
16774 
16775   switch ((ffesymbol_sfdummyparent (s) == NULL)
16776 	  ? ffesymbol_state (s)
16777 	  : FFESYMBOL_stateUNDERSTOOD)
16778     {
16779     case FFESYMBOL_stateNONE:	/* Before first exec, not seen in expr
16780 				   context. */
16781       if (!ffest_seen_first_exec ())
16782 	goto seen;		/* :::::::::::::::::::: */
16783       /* Fall through. */
16784     case FFESYMBOL_stateUNCERTAIN:	/* Unseen since first exec. */
16785       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16786 	{
16787 	case FFEEXPR_contextSUBROUTINEREF:
16788 	  s = ffeexpr_sym_lhs_call_ (s, t);	/* "CALL FOO"=="CALL
16789 						   FOO(...)". */
16790 	  break;
16791 
16792 	case FFEEXPR_contextDATA:
16793 	  if (ffeexpr_stack_->is_rhs)
16794 	    s = ffeexpr_sym_rhs_let_ (s, t);
16795 	  else
16796 	    s = ffeexpr_sym_lhs_data_ (s, t);
16797 	  break;
16798 
16799 	case FFEEXPR_contextDATAIMPDOITEM_:
16800 	  s = ffeexpr_sym_lhs_data_ (s, t);
16801 	  break;
16802 
16803 	case FFEEXPR_contextSFUNCDEF:
16804 	case FFEEXPR_contextSFUNCDEFINDEX_:
16805 	case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16806 	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16807 	  s = ffecom_sym_exec_transition (s);
16808 	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16809 	    goto understood;	/* :::::::::::::::::::: */
16810 	  /* Fall through. */
16811 	case FFEEXPR_contextLET:
16812 	case FFEEXPR_contextPAREN_:
16813 	case FFEEXPR_contextACTUALARGEXPR_:
16814 	case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16815 	case FFEEXPR_contextIOLIST:
16816 	case FFEEXPR_contextIOLISTDF:
16817 	case FFEEXPR_contextDO:
16818 	case FFEEXPR_contextDOWHILE:
16819 	case FFEEXPR_contextACTUALARG_:
16820 	case FFEEXPR_contextCGOTO:
16821 	case FFEEXPR_contextIF:
16822 	case FFEEXPR_contextARITHIF:
16823 	case FFEEXPR_contextFORMAT:
16824 	case FFEEXPR_contextSTOP:
16825 	case FFEEXPR_contextRETURN:
16826 	case FFEEXPR_contextSELECTCASE:
16827 	case FFEEXPR_contextCASE:
16828 	case FFEEXPR_contextFILEASSOC:
16829 	case FFEEXPR_contextFILEINT:
16830 	case FFEEXPR_contextFILEDFINT:
16831 	case FFEEXPR_contextFILELOG:
16832 	case FFEEXPR_contextFILENUM:
16833 	case FFEEXPR_contextFILENUMAMBIG:
16834 	case FFEEXPR_contextFILECHAR:
16835 	case FFEEXPR_contextFILENUMCHAR:
16836 	case FFEEXPR_contextFILEDFCHAR:
16837 	case FFEEXPR_contextFILEKEY:
16838 	case FFEEXPR_contextFILEUNIT:
16839 	case FFEEXPR_contextFILEUNIT_DF:
16840 	case FFEEXPR_contextFILEUNITAMBIG:
16841 	case FFEEXPR_contextFILEFORMAT:
16842 	case FFEEXPR_contextFILENAMELIST:
16843 	case FFEEXPR_contextFILEVXTCODE:
16844 	case FFEEXPR_contextINDEX_:
16845 	case FFEEXPR_contextIMPDOITEM_:
16846 	case FFEEXPR_contextIMPDOITEMDF_:
16847 	case FFEEXPR_contextIMPDOCTRL_:
16848 	case FFEEXPR_contextLOC_:
16849 	  if (ffeexpr_stack_->is_rhs)
16850 	    s = ffeexpr_paren_rhs_let_ (s, t);
16851 	  else
16852 	    s = ffeexpr_paren_lhs_let_ (s, t);
16853 	  break;
16854 
16855 	case FFEEXPR_contextASSIGN:
16856 	case FFEEXPR_contextAGOTO:
16857 	case FFEEXPR_contextCHARACTERSIZE:
16858 	case FFEEXPR_contextEQUIVALENCE:
16859 	case FFEEXPR_contextINCLUDE:
16860 	case FFEEXPR_contextPARAMETER:
16861 	case FFEEXPR_contextDIMLIST:
16862 	case FFEEXPR_contextDIMLISTCOMMON:
16863 	case FFEEXPR_contextKINDTYPE:
16864 	case FFEEXPR_contextINITVAL:
16865 	case FFEEXPR_contextEQVINDEX_:
16866 	  break;		/* Will turn into errors below. */
16867 
16868 	default:
16869 	  ffesymbol_error (s, t);
16870 	  break;
16871 	}
16872       /* Fall through. */
16873     case FFESYMBOL_stateUNDERSTOOD:	/* Nothing much more to learn. */
16874     understood:		/* :::::::::::::::::::: */
16875 
16876       /* State might have changed, update it.  */
16877       st = ((ffesymbol_sfdummyparent (s) == NULL)
16878 	    ? ffesymbol_state (s)
16879 	    : FFESYMBOL_stateUNDERSTOOD);
16880 
16881       k = ffesymbol_kind (s);
16882       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16883 	{
16884 	case FFEEXPR_contextSUBROUTINEREF:
16885 	  bad = ((k != FFEINFO_kindSUBROUTINE)
16886 		 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
16887 		     || (k != FFEINFO_kindNONE)));
16888 	  break;
16889 
16890 	case FFEEXPR_contextDATA:
16891 	  if (ffeexpr_stack_->is_rhs)
16892 	    bad = (k != FFEINFO_kindENTITY)
16893 	      || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16894 	  else
16895 	    bad = (k != FFEINFO_kindENTITY)
16896 	      || ((ffesymbol_where (s) != FFEINFO_whereNONE)
16897 		  && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
16898 		  && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
16899 	  break;
16900 
16901 	case FFEEXPR_contextDATAIMPDOITEM_:
16902 	  bad = (k != FFEINFO_kindENTITY) || (ffesymbol_rank (s) == 0)
16903 	    || ((ffesymbol_where (s) != FFEINFO_whereNONE)
16904 		&& (ffesymbol_where (s) != FFEINFO_whereLOCAL)
16905 		&& (ffesymbol_where (s) != FFEINFO_whereCOMMON));
16906 	  break;
16907 
16908 	case FFEEXPR_contextSFUNCDEF:
16909 	case FFEEXPR_contextSFUNCDEFINDEX_:
16910 	case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16911 	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16912 	case FFEEXPR_contextLET:
16913 	case FFEEXPR_contextPAREN_:
16914 	case FFEEXPR_contextACTUALARGEXPR_:
16915 	case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16916 	case FFEEXPR_contextIOLIST:
16917 	case FFEEXPR_contextIOLISTDF:
16918 	case FFEEXPR_contextDO:
16919 	case FFEEXPR_contextDOWHILE:
16920 	case FFEEXPR_contextACTUALARG_:
16921 	case FFEEXPR_contextCGOTO:
16922 	case FFEEXPR_contextIF:
16923 	case FFEEXPR_contextARITHIF:
16924 	case FFEEXPR_contextFORMAT:
16925 	case FFEEXPR_contextSTOP:
16926 	case FFEEXPR_contextRETURN:
16927 	case FFEEXPR_contextSELECTCASE:
16928 	case FFEEXPR_contextCASE:
16929 	case FFEEXPR_contextFILEASSOC:
16930 	case FFEEXPR_contextFILEINT:
16931 	case FFEEXPR_contextFILEDFINT:
16932 	case FFEEXPR_contextFILELOG:
16933 	case FFEEXPR_contextFILENUM:
16934 	case FFEEXPR_contextFILENUMAMBIG:
16935 	case FFEEXPR_contextFILECHAR:
16936 	case FFEEXPR_contextFILENUMCHAR:
16937 	case FFEEXPR_contextFILEDFCHAR:
16938 	case FFEEXPR_contextFILEKEY:
16939 	case FFEEXPR_contextFILEUNIT:
16940 	case FFEEXPR_contextFILEUNIT_DF:
16941 	case FFEEXPR_contextFILEUNITAMBIG:
16942 	case FFEEXPR_contextFILEFORMAT:
16943 	case FFEEXPR_contextFILENAMELIST:
16944 	case FFEEXPR_contextFILEVXTCODE:
16945 	case FFEEXPR_contextINDEX_:
16946 	case FFEEXPR_contextIMPDOITEM_:
16947 	case FFEEXPR_contextIMPDOITEMDF_:
16948 	case FFEEXPR_contextIMPDOCTRL_:
16949 	case FFEEXPR_contextLOC_:
16950 	  bad = FALSE;		/* Let paren-switch handle the cases. */
16951 	  break;
16952 
16953 	case FFEEXPR_contextASSIGN:
16954 	case FFEEXPR_contextAGOTO:
16955 	case FFEEXPR_contextCHARACTERSIZE:
16956 	case FFEEXPR_contextEQUIVALENCE:
16957 	case FFEEXPR_contextPARAMETER:
16958 	case FFEEXPR_contextDIMLIST:
16959 	case FFEEXPR_contextDIMLISTCOMMON:
16960 	case FFEEXPR_contextKINDTYPE:
16961 	case FFEEXPR_contextINITVAL:
16962 	case FFEEXPR_contextEQVINDEX_:
16963 	  bad = (k != FFEINFO_kindENTITY)
16964 	    || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16965 	  break;
16966 
16967 	case FFEEXPR_contextINCLUDE:
16968 	  bad = TRUE;
16969 	  break;
16970 
16971 	default:
16972 	  bad = TRUE;
16973 	  break;
16974 	}
16975 
16976       switch (bad ? FFEINFO_kindANY : k)
16977 	{
16978 	case FFEINFO_kindNONE:	/* Case "CHARACTER X,Y; Y=X(?". */
16979 	  if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
16980 	    {
16981 	      if (ffeexpr_context_outer_ (ffeexpr_stack_)
16982 		  == FFEEXPR_contextSUBROUTINEREF)
16983 		*paren_type = FFEEXPR_parentypeSUBROUTINE_;
16984 	      else
16985 		*paren_type = FFEEXPR_parentypeFUNCTION_;
16986 	      break;
16987 	    }
16988 	  if (st == FFESYMBOL_stateUNDERSTOOD)
16989 	    {
16990 	      bad = TRUE;
16991 	      *paren_type = FFEEXPR_parentypeANY_;
16992 	    }
16993 	  else
16994 	    *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
16995 	  break;
16996 
16997 	case FFEINFO_kindFUNCTION:
16998 	  *paren_type = FFEEXPR_parentypeFUNCTION_;
16999 	  switch (ffesymbol_where (s))
17000 	    {
17001 	    case FFEINFO_whereLOCAL:
17002 	      bad = TRUE;	/* Attempt to recurse! */
17003 	      break;
17004 
17005 	    case FFEINFO_whereCONSTANT:
17006 	      bad = ((ffesymbol_sfexpr (s) == NULL)
17007 		     || (ffebld_op (ffesymbol_sfexpr (s))
17008 			 == FFEBLD_opANY));	/* Attempt to recurse! */
17009 	      break;
17010 
17011 	    default:
17012 	      break;
17013 	    }
17014 	  break;
17015 
17016 	case FFEINFO_kindSUBROUTINE:
17017 	  if ((ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
17018 	      || (ffeexpr_stack_->previous != NULL))
17019 	    {
17020 	      bad = TRUE;
17021 	      *paren_type = FFEEXPR_parentypeANY_;
17022 	      break;
17023 	    }
17024 
17025 	  *paren_type = FFEEXPR_parentypeSUBROUTINE_;
17026 	  switch (ffesymbol_where (s))
17027 	    {
17028 	    case FFEINFO_whereLOCAL:
17029 	    case FFEINFO_whereCONSTANT:
17030 	      bad = TRUE;	/* Attempt to recurse! */
17031 	      break;
17032 
17033 	    default:
17034 	      break;
17035 	    }
17036 	  break;
17037 
17038 	case FFEINFO_kindENTITY:
17039 	  if (ffesymbol_rank (s) == 0)
17040 	    {
17041 	      if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
17042 		*paren_type = FFEEXPR_parentypeSUBSTRING_;
17043 	      else
17044 		{
17045 		  bad = TRUE;
17046 		  *paren_type = FFEEXPR_parentypeANY_;
17047 		}
17048 	    }
17049 	  else
17050 	    *paren_type = FFEEXPR_parentypeARRAY_;
17051 	  break;
17052 
17053 	default:
17054 	case FFEINFO_kindANY:
17055 	  bad = TRUE;
17056 	  *paren_type = FFEEXPR_parentypeANY_;
17057 	  break;
17058 	}
17059 
17060       if (bad)
17061 	{
17062 	  if (k == FFEINFO_kindANY)
17063 	    ffest_shutdown ();
17064 	  else
17065 	    ffesymbol_error (s, t);
17066 	}
17067 
17068       return s;
17069 
17070     case FFESYMBOL_stateSEEN:	/* Seen but not yet in exec portion. */
17071     seen:			/* :::::::::::::::::::: */
17072       bad = TRUE;
17073       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17074 	{
17075 	case FFEEXPR_contextPARAMETER:
17076 	  if (ffeexpr_stack_->is_rhs)
17077 	    ffesymbol_error (s, t);
17078 	  else
17079 	    s = ffeexpr_sym_lhs_parameter_ (s, t);
17080 	  break;
17081 
17082 	case FFEEXPR_contextDATA:
17083 	  s = ffecom_sym_exec_transition (s);
17084 	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17085 	    goto understood;	/* :::::::::::::::::::: */
17086 	  if (ffeexpr_stack_->is_rhs)
17087 	    ffesymbol_error (s, t);
17088 	  else
17089 	    s = ffeexpr_sym_lhs_data_ (s, t);
17090 	  goto understood;	/* :::::::::::::::::::: */
17091 
17092 	case FFEEXPR_contextDATAIMPDOITEM_:
17093 	  s = ffecom_sym_exec_transition (s);
17094 	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17095 	    goto understood;	/* :::::::::::::::::::: */
17096 	  s = ffeexpr_sym_lhs_data_ (s, t);
17097 	  goto understood;	/* :::::::::::::::::::: */
17098 
17099 	case FFEEXPR_contextEQUIVALENCE:
17100 	  s = ffeexpr_sym_lhs_equivalence_ (s, t);
17101 	  bad = FALSE;
17102 	  break;
17103 
17104 	case FFEEXPR_contextDIMLIST:
17105 	  s = ffeexpr_sym_rhs_dimlist_ (s, t);
17106           bad = FALSE;
17107 	  break;
17108 
17109 	case FFEEXPR_contextCHARACTERSIZE:
17110 	case FFEEXPR_contextKINDTYPE:
17111 	case FFEEXPR_contextDIMLISTCOMMON:
17112 	case FFEEXPR_contextINITVAL:
17113 	case FFEEXPR_contextEQVINDEX_:
17114 	  break;
17115 
17116 	case FFEEXPR_contextINCLUDE:
17117 	  break;
17118 
17119 	case FFEEXPR_contextINDEX_:
17120 	case FFEEXPR_contextACTUALARGEXPR_:
17121 	case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17122 	case FFEEXPR_contextSFUNCDEF:
17123 	case FFEEXPR_contextSFUNCDEFINDEX_:
17124 	case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17125 	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17126 	  assert (ffeexpr_stack_->is_rhs);
17127 	  s = ffecom_sym_exec_transition (s);
17128 	  if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17129 	    goto understood;	/* :::::::::::::::::::: */
17130 	  s = ffeexpr_paren_rhs_let_ (s, t);
17131 	  goto understood;	/* :::::::::::::::::::: */
17132 
17133 	default:
17134 	  break;
17135 	}
17136       k = ffesymbol_kind (s);
17137       switch (bad ? FFEINFO_kindANY : k)
17138 	{
17139 	case FFEINFO_kindNONE:	/* Case "CHARACTER X,Y; Y=X(?". */
17140 	  *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
17141 	  break;
17142 
17143 	case FFEINFO_kindFUNCTION:
17144 	  *paren_type = FFEEXPR_parentypeFUNCTION_;
17145 	  switch (ffesymbol_where (s))
17146 	    {
17147 	    case FFEINFO_whereLOCAL:
17148 	      bad = TRUE;	/* Attempt to recurse! */
17149 	      break;
17150 
17151 	    case FFEINFO_whereCONSTANT:
17152 	      bad = ((ffesymbol_sfexpr (s) == NULL)
17153 		     || (ffebld_op (ffesymbol_sfexpr (s))
17154 			 == FFEBLD_opANY));	/* Attempt to recurse! */
17155 	      break;
17156 
17157 	    default:
17158 	      break;
17159 	    }
17160 	  break;
17161 
17162 	case FFEINFO_kindSUBROUTINE:
17163 	  *paren_type = FFEEXPR_parentypeANY_;
17164 	  bad = TRUE;		/* Cannot possibly be in
17165 				   contextSUBROUTINEREF. */
17166 	  break;
17167 
17168 	case FFEINFO_kindENTITY:
17169 	  if (ffesymbol_rank (s) == 0)
17170 	    {
17171 	      if (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE)
17172 		*paren_type = FFEEXPR_parentypeEQUIVALENCE_;
17173 	      else if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
17174 		*paren_type = FFEEXPR_parentypeSUBSTRING_;
17175 	      else
17176 		{
17177 		  bad = TRUE;
17178 		  *paren_type = FFEEXPR_parentypeANY_;
17179 		}
17180 	    }
17181 	  else
17182 	    *paren_type = FFEEXPR_parentypeARRAY_;
17183 	  break;
17184 
17185 	default:
17186 	case FFEINFO_kindANY:
17187 	  bad = TRUE;
17188 	  *paren_type = FFEEXPR_parentypeANY_;
17189 	  break;
17190 	}
17191 
17192       if (bad)
17193 	{
17194 	  if (k == FFEINFO_kindANY)
17195 	    ffest_shutdown ();
17196 	  else
17197 	    ffesymbol_error (s, t);
17198 	}
17199 
17200       return s;
17201 
17202     default:
17203       assert ("bad symbol state" == NULL);
17204       return NULL;
17205     }
17206 }
17207 
17208 /* Have FOO in XYZ = ...FOO(...)....  Executable context only.  */
17209 
17210 static ffesymbol
ffeexpr_paren_rhs_let_(ffesymbol s,ffelexToken t)17211 ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t)
17212 {
17213   ffesymbolAttrs sa;
17214   ffesymbolAttrs na;
17215   ffeinfoKind kind;
17216   ffeinfoWhere where;
17217   ffeintrinGen gen;
17218   ffeintrinSpec spec;
17219   ffeintrinImp imp;
17220   bool maybe_ambig = FALSE;
17221   bool error = FALSE;
17222 
17223   assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
17224 	  || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
17225 
17226   na = sa = ffesymbol_attrs (s);
17227 
17228   assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17229 		   | FFESYMBOL_attrsADJUSTABLE
17230 		   | FFESYMBOL_attrsANYLEN
17231 		   | FFESYMBOL_attrsARRAY
17232 		   | FFESYMBOL_attrsDUMMY
17233 		   | FFESYMBOL_attrsEXTERNAL
17234 		   | FFESYMBOL_attrsSFARG
17235 		   | FFESYMBOL_attrsTYPE)));
17236 
17237   kind = ffesymbol_kind (s);
17238   where = ffesymbol_where (s);
17239 
17240   /* Figure out what kind of object we've got based on previous declarations
17241      of or references to the object. */
17242 
17243   if (sa & FFESYMBOL_attrsEXTERNAL)
17244     {
17245       assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17246 		       | FFESYMBOL_attrsDUMMY
17247 		       | FFESYMBOL_attrsEXTERNAL
17248 		       | FFESYMBOL_attrsTYPE)));
17249 
17250       if (sa & FFESYMBOL_attrsTYPE)
17251 	where = FFEINFO_whereGLOBAL;
17252       else
17253 	/* Not TYPE. */
17254 	{
17255 	  kind = FFEINFO_kindFUNCTION;
17256 
17257 	  if (sa & FFESYMBOL_attrsDUMMY)
17258 	    ;			/* Not TYPE. */
17259 	  else if (sa & FFESYMBOL_attrsACTUALARG)
17260 	    ;			/* Not DUMMY or TYPE. */
17261 	  else			/* Not ACTUALARG, DUMMY, or TYPE. */
17262 	    where = FFEINFO_whereGLOBAL;
17263 	}
17264     }
17265   else if (sa & FFESYMBOL_attrsDUMMY)
17266     {
17267       assert (!(sa & FFESYMBOL_attrsEXTERNAL));	/* Handled above. */
17268       assert (!(sa & ~(FFESYMBOL_attrsDUMMY
17269 		       | FFESYMBOL_attrsEXTERNAL
17270 		       | FFESYMBOL_attrsTYPE)));
17271 
17272       kind = FFEINFO_kindFUNCTION;
17273       maybe_ambig = TRUE;	/* If basictypeCHARACTER, can't be sure; kind
17274 				   could be ENTITY w/substring ref. */
17275     }
17276   else if (sa & FFESYMBOL_attrsARRAY)
17277     {
17278       assert (!(sa & ~(FFESYMBOL_attrsARRAY
17279 		       | FFESYMBOL_attrsADJUSTABLE
17280 		       | FFESYMBOL_attrsTYPE)));
17281 
17282       where = FFEINFO_whereLOCAL;
17283     }
17284   else if (sa & FFESYMBOL_attrsSFARG)
17285     {
17286       assert (!(sa & ~(FFESYMBOL_attrsSFARG
17287 		       | FFESYMBOL_attrsTYPE)));
17288 
17289       where = FFEINFO_whereLOCAL;	/* Actually an error, but at least we
17290 					   know it's a local var. */
17291     }
17292   else if (sa & FFESYMBOL_attrsTYPE)
17293     {
17294       assert (!(sa & (FFESYMBOL_attrsARRAY
17295 		      | FFESYMBOL_attrsDUMMY
17296 		      | FFESYMBOL_attrsEXTERNAL
17297 		      | FFESYMBOL_attrsSFARG)));	/* Handled above. */
17298       assert (!(sa & ~(FFESYMBOL_attrsTYPE
17299 		       | FFESYMBOL_attrsADJUSTABLE
17300 		       | FFESYMBOL_attrsANYLEN
17301 		       | FFESYMBOL_attrsARRAY
17302 		       | FFESYMBOL_attrsDUMMY
17303 		       | FFESYMBOL_attrsEXTERNAL
17304 		       | FFESYMBOL_attrsSFARG)));
17305 
17306       if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
17307 				  &gen, &spec, &imp))
17308 	{
17309 	  if (!(sa & FFESYMBOL_attrsANYLEN)
17310 	      && (ffeimplic_peek_symbol_type (s, NULL)
17311 		  == FFEINFO_basictypeCHARACTER))
17312 	    return s;		/* Haven't learned anything yet. */
17313 
17314 	  ffesymbol_signal_change (s);	/* May need to back up to previous
17315 					   version. */
17316 	  ffesymbol_set_generic (s, gen);
17317 	  ffesymbol_set_specific (s, spec);
17318 	  ffesymbol_set_implementation (s, imp);
17319 	  ffesymbol_set_info (s,
17320 			      ffeinfo_new (ffesymbol_basictype (s),
17321 					   ffesymbol_kindtype (s),
17322 					   0,
17323 					   FFEINFO_kindFUNCTION,
17324 					   FFEINFO_whereINTRINSIC,
17325 					   ffesymbol_size (s)));
17326 	  ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17327 	  ffesymbol_resolve_intrin (s);
17328 	  ffesymbol_reference (s, t, FALSE);
17329 	  s = ffecom_sym_learned (s);
17330 	  ffesymbol_signal_unreported (s);	/* For debugging purposes. */
17331 
17332 	  return s;
17333 	}
17334       if (sa & FFESYMBOL_attrsANYLEN)
17335 	error = TRUE;		/* Error, since the only way we can,
17336 				   given CHARACTER*(*) FOO, accept
17337 				   FOO(...) is for FOO to be a dummy
17338 				   arg or constant, but it can't
17339 				   become either now. */
17340       else if (sa & FFESYMBOL_attrsADJUSTABLE)
17341 	{
17342 	  kind = FFEINFO_kindENTITY;
17343 	  where = FFEINFO_whereLOCAL;
17344 	}
17345       else
17346 	{
17347 	  kind = FFEINFO_kindFUNCTION;
17348 	  where = FFEINFO_whereGLOBAL;
17349 	  maybe_ambig = TRUE;	/* If basictypeCHARACTER, can't be sure;
17350 				   could be ENTITY/LOCAL w/substring ref. */
17351 	}
17352     }
17353   else if (sa == FFESYMBOL_attrsetNONE)
17354     {
17355       assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
17356 
17357       if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
17358 				  &gen, &spec, &imp))
17359 	{
17360 	  if (ffeimplic_peek_symbol_type (s, NULL)
17361 	      == FFEINFO_basictypeCHARACTER)
17362 	    return s;		/* Haven't learned anything yet. */
17363 
17364 	  ffesymbol_signal_change (s);	/* May need to back up to previous
17365 					   version. */
17366 	  ffesymbol_set_generic (s, gen);
17367 	  ffesymbol_set_specific (s, spec);
17368 	  ffesymbol_set_implementation (s, imp);
17369 	  ffesymbol_set_info (s,
17370 			      ffeinfo_new (ffesymbol_basictype (s),
17371 					   ffesymbol_kindtype (s),
17372 					   0,
17373 					   FFEINFO_kindFUNCTION,
17374 					   FFEINFO_whereINTRINSIC,
17375 					   ffesymbol_size (s)));
17376 	  ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17377 	  ffesymbol_resolve_intrin (s);
17378 	  s = ffecom_sym_learned (s);
17379 	  ffesymbol_reference (s, t, FALSE);
17380 	  ffesymbol_signal_unreported (s);	/* For debugging purposes. */
17381 	  return s;
17382 	}
17383 
17384       kind = FFEINFO_kindFUNCTION;
17385       where = FFEINFO_whereGLOBAL;
17386       maybe_ambig = TRUE;	/* If basictypeCHARACTER, can't be sure;
17387 				   could be ENTITY/LOCAL w/substring ref. */
17388     }
17389   else
17390     error = TRUE;
17391 
17392   /* Now see what we've got for a new object: NONE means a new error cropped
17393      up; ANY means an old error to be ignored; otherwise, everything's ok,
17394      update the object (symbol) and continue on. */
17395 
17396   if (error)
17397     ffesymbol_error (s, t);
17398   else if (!(na & FFESYMBOL_attrsANY))
17399     {
17400       ffesymbol_signal_change (s);	/* May need to back up to previous
17401 					   version. */
17402       if (!ffeimplic_establish_symbol (s))
17403 	{
17404 	  ffesymbol_error (s, t);
17405 	  return s;
17406 	}
17407       if (maybe_ambig
17408 	  && (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
17409 	return s;		/* Still not sure, let caller deal with it
17410 				   based on (...). */
17411 
17412       ffesymbol_set_info (s,
17413 			  ffeinfo_new (ffesymbol_basictype (s),
17414 				       ffesymbol_kindtype (s),
17415 				       ffesymbol_rank (s),
17416 				       kind,
17417 				       where,
17418 				       ffesymbol_size (s)));
17419       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17420       ffesymbol_resolve_intrin (s);
17421       s = ffecom_sym_learned (s);
17422       ffesymbol_reference (s, t, FALSE);
17423       ffesymbol_signal_unreported (s);	/* For debugging purposes. */
17424     }
17425 
17426   return s;
17427 }
17428 
17429 /* ffeexpr_token_arguments_ -- OPEN_PAREN [expr COMMA]...expr
17430 
17431    Return a pointer to this function to the lexer (ffelex), which will
17432    invoke it for the next token.
17433 
17434    Handle expression (which might be null) and COMMA or CLOSE_PAREN.  */
17435 
17436 static ffelexHandler
ffeexpr_token_arguments_(ffelexToken ft,ffebld expr,ffelexToken t)17437 ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr, ffelexToken t)
17438 {
17439   ffeexprExpr_ procedure;
17440   ffebld reduced;
17441   ffeinfo info;
17442   ffeexprContext ctx;
17443   bool check_intrin = FALSE;	/* Set TRUE if intrinsic is REAL(Z) or AIMAG(Z). */
17444 
17445   procedure = ffeexpr_stack_->exprstack;
17446   info = ffebld_info (procedure->u.operand);
17447 
17448   /* Is there an expression to add?  If the expression is nil,
17449      it might still be an argument.  It is if:
17450 
17451        -  The current token is comma, or
17452 
17453        -  The -fugly-comma flag was specified *and* the procedure
17454           being invoked is external.
17455 
17456      Otherwise, if neither of the above is the case, just
17457      ignore this (nil) expression.  */
17458 
17459   if ((expr != NULL)
17460       || (ffelex_token_type (t) == FFELEX_typeCOMMA)
17461       || (ffe_is_ugly_comma ()
17462 	  && (ffeinfo_where (info) == FFEINFO_whereGLOBAL)))
17463     {
17464       /* This expression, even if nil, is apparently intended as an argument.  */
17465 
17466       /* Internal procedure (CONTAINS, or statement function)?  */
17467 
17468       if (ffeinfo_where (info) == FFEINFO_whereCONSTANT)
17469 	{
17470 	  if ((expr == NULL)
17471 	      && ffebad_start (FFEBAD_NULL_ARGUMENT))
17472 	    {
17473 	      ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17474 			   ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17475 	      ffebad_here (1, ffelex_token_where_line (t),
17476 			   ffelex_token_where_column (t));
17477 	      ffebad_finish ();
17478 	    }
17479 
17480 	  if (expr == NULL)
17481 	    ;
17482 	  else
17483 	    {
17484 	      if (ffeexpr_stack_->next_dummy == NULL)
17485 		{			/* Report later which was the first extra argument. */
17486 		  if (ffeexpr_stack_->tokens[1] == NULL)
17487 		    {
17488 		      ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
17489 		      ffeexpr_stack_->num_args = 0;
17490 		    }
17491 		  ++ffeexpr_stack_->num_args;	/* Count # of extra arguments. */
17492 		}
17493 	      else
17494 		{
17495 		  if ((ffeinfo_rank (ffebld_info (expr)) != 0)
17496 		      && ffebad_start (FFEBAD_ARRAY_AS_SFARG))
17497 		    {
17498 		      ffebad_here (0,
17499 				   ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17500 				   ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17501 		      ffebad_here (1, ffelex_token_where_line (ft),
17502 				   ffelex_token_where_column (ft));
17503 		      ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent
17504 						     (ffebld_symter (ffebld_head
17505 								     (ffeexpr_stack_->next_dummy)))));
17506 		      ffebad_finish ();
17507 		    }
17508 		  else
17509 		    {
17510 		      expr = ffeexpr_convert_expr (expr, ft,
17511 						   ffebld_head (ffeexpr_stack_->next_dummy),
17512 						   ffeexpr_stack_->tokens[0],
17513 						   FFEEXPR_contextLET);
17514 		      ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17515 		    }
17516 		  --ffeexpr_stack_->num_args;	/* Count down # of args. */
17517 		  ffeexpr_stack_->next_dummy
17518 		    = ffebld_trail (ffeexpr_stack_->next_dummy);
17519 		}
17520 	    }
17521 	}
17522       else
17523 	{
17524 	  if ((expr == NULL)
17525 	      && ffe_is_pedantic ()
17526 	      && ffebad_start (FFEBAD_NULL_ARGUMENT_W))
17527 	    {
17528 	      ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17529 			   ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17530 	      ffebad_here (1, ffelex_token_where_line (t),
17531 			   ffelex_token_where_column (t));
17532 	      ffebad_finish ();
17533 	    }
17534 	  ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17535 	}
17536     }
17537 
17538   switch (ffelex_token_type (t))
17539     {
17540     case FFELEX_typeCOMMA:
17541       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17542 	{
17543 	case FFEEXPR_contextSFUNCDEF:
17544 	case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17545 	case FFEEXPR_contextSFUNCDEFINDEX_:
17546 	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17547 	  ctx = FFEEXPR_contextSFUNCDEFACTUALARG_;
17548 	  break;
17549 
17550 	case FFEEXPR_contextSFUNCDEFACTUALARG_:
17551 	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
17552 	  assert ("bad context" == NULL);
17553 	  ctx = FFEEXPR_context;
17554 	  break;
17555 
17556 	default:
17557 	  ctx = FFEEXPR_contextACTUALARG_;
17558 	  break;
17559 	}
17560       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
17561 					  ffeexpr_token_arguments_);
17562 
17563     default:
17564       break;
17565     }
17566 
17567   if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
17568       && (ffeexpr_stack_->next_dummy != NULL))
17569     {				/* Too few arguments. */
17570       if (ffebad_start (FFEBAD_TOO_FEW_ARGUMENTS))
17571 	{
17572 	  char num[10];
17573 
17574 	  sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
17575 
17576 	  ffebad_here (0, ffelex_token_where_line (t),
17577 		       ffelex_token_where_column (t));
17578 	  ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17579 		     ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17580 	  ffebad_string (num);
17581 	  ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent (ffebld_symter
17582 			      (ffebld_head (ffeexpr_stack_->next_dummy)))));
17583 	  ffebad_finish ();
17584 	}
17585       for (;
17586 	   ffeexpr_stack_->next_dummy != NULL;
17587 	   ffeexpr_stack_->next_dummy
17588 	   = ffebld_trail (ffeexpr_stack_->next_dummy))
17589 	{
17590 	  expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0));
17591 	  ffebld_set_info (expr, ffeinfo_new_any ());
17592 	  ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17593 	}
17594     }
17595 
17596   if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
17597       && (ffeexpr_stack_->tokens[1] != NULL))
17598     {				/* Too many arguments to statement function. */
17599       if (ffebad_start (FFEBAD_TOO_MANY_ARGUMENTS))
17600 	{
17601 	  char num[10];
17602 
17603 	  sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
17604 
17605 	  ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
17606 		     ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
17607 	  ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17608 		     ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17609 	  ffebad_string (num);
17610 	  ffebad_finish ();
17611 	}
17612       ffelex_token_kill (ffeexpr_stack_->tokens[1]);
17613     }
17614   ffebld_end_list (&ffeexpr_stack_->bottom);
17615 
17616   if (ffebld_op (procedure->u.operand) == FFEBLD_opANY)
17617     {
17618       reduced = ffebld_new_any ();
17619       ffebld_set_info (reduced, ffeinfo_new_any ());
17620     }
17621   else
17622     {
17623       if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
17624 	reduced = ffebld_new_funcref (procedure->u.operand,
17625 				      ffeexpr_stack_->expr);
17626       else
17627 	reduced = ffebld_new_subrref (procedure->u.operand,
17628 				      ffeexpr_stack_->expr);
17629       if (ffebld_symter_generic (procedure->u.operand) != FFEINTRIN_genNONE)
17630 	ffeintrin_fulfill_generic (&reduced, &info, ffeexpr_stack_->tokens[0]);
17631       else if (ffebld_symter_specific (procedure->u.operand)
17632 	       != FFEINTRIN_specNONE)
17633 	ffeintrin_fulfill_specific (&reduced, &info, &check_intrin,
17634 				    ffeexpr_stack_->tokens[0]);
17635       else
17636 	ffeexpr_fulfill_call_ (&reduced, ffeexpr_stack_->tokens[0]);
17637 
17638       if (ffebld_op (reduced) != FFEBLD_opANY)
17639 	ffebld_set_info (reduced,
17640 			 ffeinfo_new (ffeinfo_basictype (info),
17641 				      ffeinfo_kindtype (info),
17642 				      0,
17643 				      FFEINFO_kindENTITY,
17644 				      FFEINFO_whereFLEETING,
17645 				      ffeinfo_size (info)));
17646       else
17647 	ffebld_set_info (reduced, ffeinfo_new_any ());
17648     }
17649   if (ffebld_op (reduced) == FFEBLD_opFUNCREF)
17650     reduced = ffeexpr_collapse_funcref (reduced, ffeexpr_stack_->tokens[0]);
17651   ffeexpr_stack_->exprstack = procedure->previous;	/* Pops
17652 							   not-quite-operand off
17653 							   stack. */
17654   procedure->u.operand = reduced;	/* Save the line/column ffewhere
17655 					   info. */
17656   ffeexpr_exprstack_push_operand_ (procedure);	/* Push it back on stack. */
17657   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
17658     {
17659       ffelex_token_kill (ffeexpr_stack_->tokens[0]);
17660       ffeexpr_is_substr_ok_ = FALSE;	/* Nobody likes "FUNC(3)(1:1)".... */
17661 
17662       /* If the intrinsic needs checking (is REAL(Z) or AIMAG(Z), where
17663 	 Z is DOUBLE COMPLEX), and a command-line option doesn't already
17664 	 establish interpretation, probably complain.  */
17665 
17666       if (check_intrin
17667 	  && !ffe_is_90 ()
17668 	  && !ffe_is_ugly_complex ())
17669 	{
17670 	  /* If the outer expression is REAL(me...), issue diagnostic
17671 	     only if next token isn't the close-paren for REAL(me).  */
17672 
17673 	  if ((ffeexpr_stack_->previous != NULL)
17674 	      && (ffeexpr_stack_->previous->exprstack != NULL)
17675 	      && (ffeexpr_stack_->previous->exprstack->type == FFEEXPR_exprtypeOPERAND_)
17676 	      && ((reduced = ffeexpr_stack_->previous->exprstack->u.operand) != NULL)
17677 	      && (ffebld_op (reduced) == FFEBLD_opSYMTER)
17678 	      && (ffebld_symter_implementation (reduced) == FFEINTRIN_impREAL))
17679 	    return (ffelexHandler) ffeexpr_token_intrincheck_;
17680 
17681 	  /* Diagnose the ambiguity now.  */
17682 
17683 	  if (ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
17684 	    {
17685 	      ffebad_string (ffeintrin_name_implementation
17686 			     (ffebld_symter_implementation
17687 			      (ffebld_left
17688 			       (ffeexpr_stack_->exprstack->u.operand))));
17689 	      ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
17690 			   ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
17691 	      ffebad_finish ();
17692 	    }
17693 	}
17694       return (ffelexHandler) ffeexpr_token_substrp_;
17695     }
17696 
17697   if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
17698     {
17699       ffebad_here (0, ffelex_token_where_line (t),
17700 		   ffelex_token_where_column (t));
17701       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17702 		   ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17703       ffebad_finish ();
17704     }
17705   ffelex_token_kill (ffeexpr_stack_->tokens[0]);
17706   ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FUNC(3)(1:1)".... */
17707   return
17708     (ffelexHandler) ffeexpr_find_close_paren_ (t,
17709 					       (ffelexHandler)
17710 					       ffeexpr_token_substrp_);
17711 }
17712 
17713 /* ffeexpr_token_elements_ -- OPEN_PAREN [expr COMMA]...expr
17714 
17715    Return a pointer to this array to the lexer (ffelex), which will
17716    invoke it for the next token.
17717 
17718    Handle expression and COMMA or CLOSE_PAREN.	*/
17719 
17720 static ffelexHandler
ffeexpr_token_elements_(ffelexToken ft,ffebld expr,ffelexToken t)17721 ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, ffelexToken t)
17722 {
17723   ffeexprExpr_ array;
17724   ffebld reduced;
17725   ffeinfo info;
17726   ffeinfoWhere where;
17727   ffetargetIntegerDefault val;
17728   ffetargetIntegerDefault lval = 0;
17729   ffetargetIntegerDefault uval = 0;
17730   ffebld lbound;
17731   ffebld ubound;
17732   bool lcheck;
17733   bool ucheck;
17734 
17735   array = ffeexpr_stack_->exprstack;
17736   info = ffebld_info (array->u.operand);
17737 
17738   if ((expr == NULL)		/* && ((ffeexpr_stack_->rank != 0) ||
17739 				   (ffelex_token_type(t) ==
17740 	 FFELEX_typeCOMMA)) */ )
17741     {
17742       if (ffebad_start (FFEBAD_NULL_ELEMENT))
17743 	{
17744 	  ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17745 		     ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17746 	  ffebad_here (1, ffelex_token_where_line (t),
17747 		       ffelex_token_where_column (t));
17748 	  ffebad_finish ();
17749 	}
17750       if (ffeexpr_stack_->rank < ffeinfo_rank (info))
17751 	{			/* Don't bother if we're going to complain
17752 				   later! */
17753 	  expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
17754 	  ffebld_set_info (expr, ffeinfo_new_any ());
17755 	}
17756     }
17757 
17758   if (expr == NULL)
17759     ;
17760   else if (ffeinfo_rank (info) == 0)
17761     {				/* In EQUIVALENCE context, ffeinfo_rank(info)
17762 				   may == 0. */
17763       ++ffeexpr_stack_->rank;	/* Track anyway, may need for new VXT
17764 				   feature. */
17765       ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17766     }
17767   else
17768     {
17769       ++ffeexpr_stack_->rank;
17770       if (ffeexpr_stack_->rank > ffeinfo_rank (info))
17771 	{			/* Report later which was the first extra
17772 				   element. */
17773 	  if (ffeexpr_stack_->rank == ffeinfo_rank (info) + 1)
17774 	    ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
17775 	}
17776       else
17777 	{
17778 	  switch (ffeinfo_where (ffebld_info (expr)))
17779 	    {
17780 	    case FFEINFO_whereCONSTANT:
17781 	      break;
17782 
17783 	    case FFEINFO_whereIMMEDIATE:
17784 	      ffeexpr_stack_->constant = FALSE;
17785 	      break;
17786 
17787 	    default:
17788 	      ffeexpr_stack_->constant = FALSE;
17789 	      ffeexpr_stack_->immediate = FALSE;
17790 	      break;
17791 	    }
17792 	  if (ffebld_op (expr) == FFEBLD_opCONTER
17793 	      && ffebld_kindtype (expr) == FFEINFO_kindtypeINTEGERDEFAULT)
17794 	    {
17795 	      val = ffebld_constant_integerdefault (ffebld_conter (expr));
17796 
17797 	      lbound = ffebld_left (ffebld_head (ffeexpr_stack_->bound_list));
17798 	      if (lbound == NULL)
17799 		{
17800 		  lcheck = TRUE;
17801 		  lval = 1;
17802 		}
17803 	      else if (ffebld_op (lbound) == FFEBLD_opCONTER)
17804 		{
17805 		  lcheck = TRUE;
17806 		  lval = ffebld_constant_integerdefault (ffebld_conter (lbound));
17807 		}
17808 	      else
17809 		lcheck = FALSE;
17810 
17811 	      ubound = ffebld_right (ffebld_head (ffeexpr_stack_->bound_list));
17812 	      assert (ubound != NULL);
17813 	      if (ffebld_op (ubound) == FFEBLD_opCONTER)
17814 		{
17815 		  ucheck = TRUE;
17816 		  uval = ffebld_constant_integerdefault (ffebld_conter (ubound));
17817 		}
17818 	      else
17819 		ucheck = FALSE;
17820 
17821 	      if ((lcheck && (val < lval)) || (ucheck && (val > uval)))
17822 		{
17823 		  ffebad_start (FFEBAD_RANGE_ARRAY);
17824 		  ffebad_here (0, ffelex_token_where_line (ft),
17825 			       ffelex_token_where_column (ft));
17826 		  ffebad_finish ();
17827 		}
17828 	    }
17829 	  ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17830 	  ffeexpr_stack_->bound_list = ffebld_trail (ffeexpr_stack_->bound_list);
17831 	}
17832     }
17833 
17834   switch (ffelex_token_type (t))
17835     {
17836     case FFELEX_typeCOMMA:
17837       switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17838 	{
17839 	case FFEEXPR_contextDATAIMPDOITEM_:
17840 	  return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
17841 					      FFEEXPR_contextDATAIMPDOINDEX_,
17842 					      ffeexpr_token_elements_);
17843 
17844 	case FFEEXPR_contextEQUIVALENCE:
17845 	  return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
17846 					      FFEEXPR_contextEQVINDEX_,
17847 					      ffeexpr_token_elements_);
17848 
17849 	case FFEEXPR_contextSFUNCDEF:
17850 	case FFEEXPR_contextSFUNCDEFINDEX_:
17851 	  return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
17852 					      FFEEXPR_contextSFUNCDEFINDEX_,
17853 					      ffeexpr_token_elements_);
17854 
17855 	case FFEEXPR_contextSFUNCDEFACTUALARG_:
17856 	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
17857 	  assert ("bad context" == NULL);
17858 	  break;
17859 
17860 	default:
17861 	  return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
17862 					      FFEEXPR_contextINDEX_,
17863 					      ffeexpr_token_elements_);
17864 	}
17865 
17866     default:
17867       break;
17868     }
17869 
17870   if ((ffeexpr_stack_->rank != ffeinfo_rank (info))
17871       && (ffeinfo_rank (info) != 0))
17872     {
17873       char num[10];
17874 
17875       if (ffeexpr_stack_->rank < ffeinfo_rank (info))
17876 	{
17877 	  if (ffebad_start (FFEBAD_TOO_FEW_ELEMENTS))
17878 	    {
17879 	      sprintf (num, "%d",
17880 		       (int) (ffeinfo_rank (info) - ffeexpr_stack_->rank));
17881 
17882 	      ffebad_here (0, ffelex_token_where_line (t),
17883 			   ffelex_token_where_column (t));
17884 	      ffebad_here (1,
17885 			ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17886 		     ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17887 	      ffebad_string (num);
17888 	      ffebad_finish ();
17889 	    }
17890 	}
17891       else
17892 	{
17893 	  if (ffebad_start (FFEBAD_TOO_MANY_ELEMENTS))
17894 	    {
17895 	      sprintf (num, "%d",
17896 		       (int) (ffeexpr_stack_->rank - ffeinfo_rank (info)));
17897 
17898 	      ffebad_here (0,
17899 			ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
17900 		     ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
17901 	      ffebad_here (1,
17902 			ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17903 		     ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17904 	      ffebad_string (num);
17905 	      ffebad_finish ();
17906 	    }
17907 	  ffelex_token_kill (ffeexpr_stack_->tokens[1]);
17908 	}
17909       while (ffeexpr_stack_->rank++ < ffeinfo_rank (info))
17910 	{
17911 	  expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
17912 	  ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeINTEGER,
17913 					      FFEINFO_kindtypeINTEGERDEFAULT,
17914 					      0, FFEINFO_kindENTITY,
17915 					      FFEINFO_whereCONSTANT,
17916 					      FFETARGET_charactersizeNONE));
17917 	  ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17918 	}
17919     }
17920   ffebld_end_list (&ffeexpr_stack_->bottom);
17921 
17922   if (ffebld_op (array->u.operand) == FFEBLD_opANY)
17923     {
17924       reduced = ffebld_new_any ();
17925       ffebld_set_info (reduced, ffeinfo_new_any ());
17926     }
17927   else
17928     {
17929       reduced = ffebld_new_arrayref (array->u.operand, ffeexpr_stack_->expr);
17930       if (ffeexpr_stack_->constant)
17931 	where = FFEINFO_whereFLEETING_CADDR;
17932       else if (ffeexpr_stack_->immediate)
17933 	where = FFEINFO_whereFLEETING_IADDR;
17934       else
17935 	where = FFEINFO_whereFLEETING;
17936       ffebld_set_info (reduced,
17937 		       ffeinfo_new (ffeinfo_basictype (info),
17938 				    ffeinfo_kindtype (info),
17939 				    0,
17940 				    FFEINFO_kindENTITY,
17941 				    where,
17942 				    ffeinfo_size (info)));
17943       reduced = ffeexpr_collapse_arrayref (reduced, ffeexpr_stack_->tokens[0]);
17944     }
17945 
17946   ffeexpr_stack_->exprstack = array->previous;	/* Pops not-quite-operand off
17947 						   stack. */
17948   array->u.operand = reduced;	/* Save the line/column ffewhere info. */
17949   ffeexpr_exprstack_push_operand_ (array);	/* Push it back on stack. */
17950 
17951   switch (ffeinfo_basictype (info))
17952     {
17953     case FFEINFO_basictypeCHARACTER:
17954       ffeexpr_is_substr_ok_ = TRUE;	/* Everyone likes "FOO(3)(1:1)".... */
17955       break;
17956 
17957     case FFEINFO_basictypeNONE:
17958       ffeexpr_is_substr_ok_ = TRUE;
17959       assert (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE);
17960       break;
17961 
17962     default:
17963       ffeexpr_is_substr_ok_ = FALSE;
17964       break;
17965     }
17966 
17967   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
17968     {
17969       ffelex_token_kill (ffeexpr_stack_->tokens[0]);
17970       return (ffelexHandler) ffeexpr_token_substrp_;
17971     }
17972 
17973   if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
17974     {
17975       ffebad_here (0, ffelex_token_where_line (t),
17976 		   ffelex_token_where_column (t));
17977       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17978 		   ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17979       ffebad_finish ();
17980     }
17981   ffelex_token_kill (ffeexpr_stack_->tokens[0]);
17982   return
17983     (ffelexHandler) ffeexpr_find_close_paren_ (t,
17984 					       (ffelexHandler)
17985 					       ffeexpr_token_substrp_);
17986 }
17987 
17988 /* ffeexpr_token_equivalence_ -- OPEN_PAREN expr
17989 
17990    Return a pointer to this array to the lexer (ffelex), which will
17991    invoke it for the next token.
17992 
17993    If token is COLON, pass off to _substr_, else init list and pass off
17994    to _elements_.  This handles the case "EQUIVALENCE (FOO(expr?", where
17995    ? marks the token, and where FOO's rank/type has not yet been established,
17996    meaning we could be in a list of indices or in a substring
17997    specification.  */
17998 
17999 static ffelexHandler
ffeexpr_token_equivalence_(ffelexToken ft,ffebld expr,ffelexToken t)18000 ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr, ffelexToken t)
18001 {
18002   if (ffelex_token_type (t) == FFELEX_typeCOLON)
18003     return ffeexpr_token_substring_ (ft, expr, t);
18004 
18005   ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
18006   return ffeexpr_token_elements_ (ft, expr, t);
18007 }
18008 
18009 /* ffeexpr_token_substring_ -- NAME(of kindENTITY) OPEN_PAREN expr
18010 
18011    Return a pointer to this function to the lexer (ffelex), which will
18012    invoke it for the next token.
18013 
18014    Handle expression (which may be null) and COLON.  */
18015 
18016 static ffelexHandler
ffeexpr_token_substring_(ffelexToken ft,ffebld expr,ffelexToken t)18017 ffeexpr_token_substring_ (ffelexToken ft, ffebld expr, ffelexToken t)
18018 {
18019   ffeexprExpr_ string;
18020   ffeinfo info;
18021   ffetargetIntegerDefault i;
18022   ffeexprContext ctx;
18023   ffetargetCharacterSize size;
18024 
18025   string = ffeexpr_stack_->exprstack;
18026   info = ffebld_info (string->u.operand);
18027   size = ffebld_size_max (string->u.operand);
18028 
18029   if (ffelex_token_type (t) == FFELEX_typeCOLON)
18030     {
18031       if ((expr != NULL)
18032 	  && (ffebld_op (expr) == FFEBLD_opCONTER)
18033 	  && (((i = ffebld_constant_integerdefault (ffebld_conter (expr)))
18034 	       < 1)
18035 	      || ((size != FFETARGET_charactersizeNONE) && (i > size))))
18036 	{
18037 	  ffebad_start (FFEBAD_RANGE_SUBSTR);
18038 	  ffebad_here (0, ffelex_token_where_line (ft),
18039 		       ffelex_token_where_column (ft));
18040 	  ffebad_finish ();
18041 	}
18042       ffeexpr_stack_->expr = expr;
18043 
18044       switch (ffeexpr_stack_->context)
18045 	{
18046 	case FFEEXPR_contextSFUNCDEF:
18047 	case FFEEXPR_contextSFUNCDEFINDEX_:
18048 	  ctx = FFEEXPR_contextSFUNCDEFINDEX_;
18049 	  break;
18050 
18051 	case FFEEXPR_contextSFUNCDEFACTUALARG_:
18052 	case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18053 	  assert ("bad context" == NULL);
18054 	  ctx = FFEEXPR_context;
18055 	  break;
18056 
18057 	default:
18058 	  ctx = FFEEXPR_contextINDEX_;
18059 	  break;
18060 	}
18061 
18062       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18063 					  ffeexpr_token_substring_1_);
18064     }
18065 
18066   if (ffest_ffebad_start (FFEBAD_MISSING_COLON_IN_SUBSTR))
18067     {
18068       ffebad_here (0, ffelex_token_where_line (t),
18069 		   ffelex_token_where_column (t));
18070       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18071 		   ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18072       ffebad_finish ();
18073     }
18074 
18075   ffeexpr_stack_->expr = NULL;
18076   return (ffelexHandler) ffeexpr_token_substring_1_ (ft, expr, t);
18077 }
18078 
18079 /* ffeexpr_token_substring_1_ -- NAME OPEN_PAREN [expr COMMA]...expr
18080 
18081    Return a pointer to this function to the lexer (ffelex), which will
18082    invoke it for the next token.
18083 
18084    Handle expression (which might be null) and CLOSE_PAREN.  */
18085 
18086 static ffelexHandler
ffeexpr_token_substring_1_(ffelexToken ft,ffebld last,ffelexToken t)18087 ffeexpr_token_substring_1_ (ffelexToken ft, ffebld last, ffelexToken t)
18088 {
18089   ffeexprExpr_ string;
18090   ffebld reduced;
18091   ffebld substrlist;
18092   ffebld first = ffeexpr_stack_->expr;
18093   ffebld strop;
18094   ffeinfo info;
18095   ffeinfoWhere lwh;
18096   ffeinfoWhere rwh;
18097   ffeinfoWhere where;
18098   ffeinfoKindtype first_kt;
18099   ffeinfoKindtype last_kt;
18100   ffetargetIntegerDefault first_val;
18101   ffetargetIntegerDefault last_val;
18102   ffetargetCharacterSize size;
18103   ffetargetCharacterSize strop_size_max;
18104   bool first_known;
18105 
18106   string = ffeexpr_stack_->exprstack;
18107   strop = string->u.operand;
18108   info = ffebld_info (strop);
18109 
18110   if (first == NULL
18111       || (ffebld_op (first) == FFEBLD_opCONTER
18112 	  && ffebld_kindtype (first) == FFEINFO_kindtypeINTEGERDEFAULT))
18113     {				/* The starting point is known. */
18114       first_val = (first == NULL) ? 1
18115 	: ffebld_constant_integerdefault (ffebld_conter (first));
18116       first_known = TRUE;
18117     }
18118   else
18119     {				/* Assume start of the entity. */
18120       first_val = 1;
18121       first_known = FALSE;
18122     }
18123 
18124   if (last != NULL
18125       && (ffebld_op (last) == FFEBLD_opCONTER
18126 	  && ffebld_kindtype (last) == FFEINFO_kindtypeINTEGERDEFAULT))
18127     {				/* The ending point is known. */
18128       last_val = ffebld_constant_integerdefault (ffebld_conter (last));
18129 
18130       if (first_known)
18131 	{			/* The beginning point is a constant. */
18132 	  if (first_val <= last_val)
18133 	    size = last_val - first_val + 1;
18134 	  else
18135 	    {
18136 	      if (0 && ffe_is_90 ())
18137 		size = 0;
18138 	      else
18139 		{
18140 		  size = 1;
18141 		  ffebad_start (FFEBAD_ZERO_SIZE);
18142 		  ffebad_here (0, ffelex_token_where_line (ft),
18143 			       ffelex_token_where_column (ft));
18144 		  ffebad_finish ();
18145 		}
18146 	    }
18147 	}
18148       else
18149 	size = FFETARGET_charactersizeNONE;
18150 
18151       strop_size_max = ffebld_size_max (strop);
18152 
18153       if ((strop_size_max != FFETARGET_charactersizeNONE)
18154 	  && (last_val > strop_size_max))
18155 	{			/* Beyond maximum possible end of string. */
18156 	  ffebad_start (FFEBAD_RANGE_SUBSTR);
18157 	  ffebad_here (0, ffelex_token_where_line (ft),
18158 		       ffelex_token_where_column (ft));
18159 	  ffebad_finish ();
18160 	}
18161     }
18162   else
18163     size = FFETARGET_charactersizeNONE;	/* The size is not known. */
18164 
18165 #if 0				/* Don't do this, or "is size of target
18166 				   known?" would no longer be easily
18167 				   answerable.	To see if there is a max
18168 				   size, use ffebld_size_max; to get only the
18169 				   known size, else NONE, use
18170 				   ffebld_size_known; use ffebld_size if
18171 				   values are sure to be the same (not
18172 				   opSUBSTR or opCONCATENATE or known to have
18173 				   known length). By getting rid of this
18174 				   "useful info" stuff, we don't end up
18175 				   blank-padding the constant in the
18176 				   assignment "A(I:J)='XYZ'" to the known
18177 				   length of A. */
18178   if (size == FFETARGET_charactersizeNONE)
18179     size = strop_size_max;	/* Assume we use the entire string. */
18180 #endif
18181 
18182   substrlist
18183     = ffebld_new_item
18184     (first,
18185      ffebld_new_item
18186      (last,
18187       NULL
18188      )
18189     )
18190     ;
18191 
18192   if (first == NULL)
18193     lwh = FFEINFO_whereCONSTANT;
18194   else
18195     lwh = ffeinfo_where (ffebld_info (first));
18196   if (last == NULL)
18197     rwh = FFEINFO_whereCONSTANT;
18198   else
18199     rwh = ffeinfo_where (ffebld_info (last));
18200 
18201   switch (lwh)
18202     {
18203     case FFEINFO_whereCONSTANT:
18204       switch (rwh)
18205 	{
18206 	case FFEINFO_whereCONSTANT:
18207 	  where = FFEINFO_whereCONSTANT;
18208 	  break;
18209 
18210 	case FFEINFO_whereIMMEDIATE:
18211 	  where = FFEINFO_whereIMMEDIATE;
18212 	  break;
18213 
18214 	default:
18215 	  where = FFEINFO_whereFLEETING;
18216 	  break;
18217 	}
18218       break;
18219 
18220     case FFEINFO_whereIMMEDIATE:
18221       switch (rwh)
18222 	{
18223 	case FFEINFO_whereCONSTANT:
18224 	case FFEINFO_whereIMMEDIATE:
18225 	  where = FFEINFO_whereIMMEDIATE;
18226 	  break;
18227 
18228 	default:
18229 	  where = FFEINFO_whereFLEETING;
18230 	  break;
18231 	}
18232       break;
18233 
18234     default:
18235       where = FFEINFO_whereFLEETING;
18236       break;
18237     }
18238 
18239   if (first == NULL)
18240     first_kt = FFEINFO_kindtypeINTEGERDEFAULT;
18241   else
18242     first_kt = ffeinfo_kindtype (ffebld_info (first));
18243   if (last == NULL)
18244     last_kt = FFEINFO_kindtypeINTEGERDEFAULT;
18245   else
18246     last_kt = ffeinfo_kindtype (ffebld_info (last));
18247 
18248   switch (where)
18249     {
18250     case FFEINFO_whereCONSTANT:
18251       switch (ffeinfo_where (info))
18252 	{
18253 	case FFEINFO_whereCONSTANT:
18254 	  break;
18255 
18256 	case FFEINFO_whereIMMEDIATE:	/* Not possible, actually. */
18257 	  where = FFEINFO_whereIMMEDIATE;
18258 	  break;
18259 
18260 	default:
18261 	  where = FFEINFO_whereFLEETING_CADDR;
18262 	  break;
18263 	}
18264       break;
18265 
18266     case FFEINFO_whereIMMEDIATE:
18267       switch (ffeinfo_where (info))
18268 	{
18269 	case FFEINFO_whereCONSTANT:
18270 	case FFEINFO_whereIMMEDIATE:	/* Not possible, actually. */
18271 	  break;
18272 
18273 	default:
18274 	  where = FFEINFO_whereFLEETING_IADDR;
18275 	  break;
18276 	}
18277       break;
18278 
18279     default:
18280       switch (ffeinfo_where (info))
18281 	{
18282 	case FFEINFO_whereCONSTANT:
18283 	  where = FFEINFO_whereCONSTANT_SUBOBJECT;	/* An F90 concept. */
18284 	  break;
18285 
18286 	case FFEINFO_whereIMMEDIATE:	/* Not possible, actually. */
18287 	default:
18288 	  where = FFEINFO_whereFLEETING;
18289 	  break;
18290 	}
18291       break;
18292     }
18293 
18294   if (ffebld_op (strop) == FFEBLD_opANY)
18295     {
18296       reduced = ffebld_new_any ();
18297       ffebld_set_info (reduced, ffeinfo_new_any ());
18298     }
18299   else
18300     {
18301       reduced = ffebld_new_substr (strop, substrlist);
18302       ffebld_set_info (reduced, ffeinfo_new
18303 		       (FFEINFO_basictypeCHARACTER,
18304 			ffeinfo_kindtype (info),
18305 			0,
18306 			FFEINFO_kindENTITY,
18307 			where,
18308 			size));
18309       reduced = ffeexpr_collapse_substr (reduced, ffeexpr_stack_->tokens[0]);
18310     }
18311 
18312   ffeexpr_stack_->exprstack = string->previous;	/* Pops not-quite-operand off
18313 						   stack. */
18314   string->u.operand = reduced;	/* Save the line/column ffewhere info. */
18315   ffeexpr_exprstack_push_operand_ (string);	/* Push it back on stack. */
18316 
18317   if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18318     {
18319       ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18320       ffeexpr_is_substr_ok_ = FALSE;	/* Nobody likes "FOO(3:5)(1:1)".... */
18321       return (ffelexHandler) ffeexpr_token_substrp_;
18322     }
18323 
18324   if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
18325     {
18326       ffebad_here (0, ffelex_token_where_line (t),
18327 		   ffelex_token_where_column (t));
18328       ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18329 		   ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18330       ffebad_finish ();
18331     }
18332 
18333   ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18334   ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FOO(3:5)(1:1)".... */
18335   return
18336     (ffelexHandler) ffeexpr_find_close_paren_ (t,
18337 					       (ffelexHandler)
18338 					       ffeexpr_token_substrp_);
18339 }
18340 
18341 /* ffeexpr_token_substrp_ -- Rhs <character entity>
18342 
18343    Return a pointer to this function to the lexer (ffelex), which will
18344    invoke it for the next token.
18345 
18346    If OPEN_PAREN, treat as start of a substring ("(3:4)") construct, and
18347    issue error message if flag (serves as argument) is set.  Else, just
18348    forward token to binary_.  */
18349 
18350 static ffelexHandler
ffeexpr_token_substrp_(ffelexToken t)18351 ffeexpr_token_substrp_ (ffelexToken t)
18352 {
18353   ffeexprContext ctx;
18354 
18355   if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
18356     return (ffelexHandler) ffeexpr_token_binary_ (t);
18357 
18358   ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
18359 
18360   switch (ffeexpr_stack_->context)
18361     {
18362     case FFEEXPR_contextSFUNCDEF:
18363     case FFEEXPR_contextSFUNCDEFINDEX_:
18364       ctx = FFEEXPR_contextSFUNCDEFINDEX_;
18365       break;
18366 
18367     case FFEEXPR_contextSFUNCDEFACTUALARG_:
18368     case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18369       assert ("bad context" == NULL);
18370       ctx = FFEEXPR_context;
18371       break;
18372 
18373     default:
18374       ctx = FFEEXPR_contextINDEX_;
18375       break;
18376     }
18377 
18378   if (!ffeexpr_is_substr_ok_)
18379     {
18380       if (ffebad_start (FFEBAD_BAD_SUBSTR))
18381 	{
18382 	  ffebad_here (0, ffelex_token_where_line (t),
18383 		       ffelex_token_where_column (t));
18384 	  ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
18385 		       ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
18386 	  ffebad_finish ();
18387 	}
18388 
18389       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18390 					  ffeexpr_token_anything_);
18391     }
18392 
18393   return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18394 				      ffeexpr_token_substring_);
18395 }
18396 
18397 static ffelexHandler
ffeexpr_token_intrincheck_(ffelexToken t)18398 ffeexpr_token_intrincheck_ (ffelexToken t)
18399 {
18400   if ((ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
18401       && ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
18402     {
18403       ffebad_string (ffeintrin_name_implementation
18404 		     (ffebld_symter_implementation
18405 		      (ffebld_left
18406 		       (ffeexpr_stack_->exprstack->u.operand))));
18407       ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
18408 		   ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
18409       ffebad_finish ();
18410     }
18411 
18412   return (ffelexHandler) ffeexpr_token_substrp_ (t);
18413 }
18414 
18415 /* ffeexpr_token_funsubstr_ -- NAME OPEN_PAREN expr
18416 
18417    Return a pointer to this function to the lexer (ffelex), which will
18418    invoke it for the next token.
18419 
18420    If COLON, do everything we would have done since _parenthesized_ if
18421    we had known NAME represented a kindENTITY instead of a kindFUNCTION.
18422    If not COLON, do likewise for kindFUNCTION instead.	*/
18423 
18424 static ffelexHandler
ffeexpr_token_funsubstr_(ffelexToken ft,ffebld expr,ffelexToken t)18425 ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr, ffelexToken t)
18426 {
18427   ffeinfoWhere where;
18428   ffesymbol s;
18429   ffesymbolAttrs sa;
18430   ffebld symter = ffeexpr_stack_->exprstack->u.operand;
18431   bool needs_type;
18432   ffeintrinGen gen;
18433   ffeintrinSpec spec;
18434   ffeintrinImp imp;
18435 
18436   s = ffebld_symter (symter);
18437   sa = ffesymbol_attrs (s);
18438   where = ffesymbol_where (s);
18439 
18440   /* We get here only if we don't already know enough about FOO when seeing a
18441      FOO(stuff) reference, and FOO might turn out to be a CHARACTER type.  If
18442      "stuff" is a substring reference, then FOO is a CHARACTER scalar type.
18443      Else FOO is a function, either intrinsic or external.  If intrinsic, it
18444      wouldn't necessarily be CHARACTER type, so unless it has already been
18445      declared DUMMY, it hasn't had its type established yet.  It can't be
18446      CHAR*(*) in any case, though it can have an explicit CHAR*n type.  */
18447 
18448   assert (!(sa & ~(FFESYMBOL_attrsDUMMY
18449 		   | FFESYMBOL_attrsTYPE)));
18450 
18451   needs_type = !(ffesymbol_attrs (s) & FFESYMBOL_attrsDUMMY);
18452 
18453   ffesymbol_signal_change (s);	/* Probably already done, but in case.... */
18454 
18455   if (ffelex_token_type (t) == FFELEX_typeCOLON)
18456     {				/* Definitely an ENTITY (char substring). */
18457       if (needs_type && !ffeimplic_establish_symbol (s))
18458 	{
18459 	  ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
18460 	  return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
18461 	}
18462 
18463       ffesymbol_set_info (s,
18464 			  ffeinfo_new (ffesymbol_basictype (s),
18465 				       ffesymbol_kindtype (s),
18466 				       ffesymbol_rank (s),
18467 				       FFEINFO_kindENTITY,
18468 				       (where == FFEINFO_whereNONE)
18469 				       ? FFEINFO_whereLOCAL
18470 				       : where,
18471 				       ffesymbol_size (s)));
18472       ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
18473 
18474       ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18475       ffesymbol_resolve_intrin (s);
18476       s = ffecom_sym_learned (s);
18477       ffesymbol_signal_unreported (s);	/* For debugging purposes. */
18478 
18479       ffeexpr_stack_->exprstack->u.operand
18480 	= ffeexpr_collapse_symter (symter, ffeexpr_tokens_[0]);
18481 
18482       return (ffelexHandler) ffeexpr_token_substring_ (ft, expr, t);
18483     }
18484 
18485   /* The "stuff" isn't a substring notation, so we now know the overall
18486      reference is to a function.  */
18487 
18488   if (ffeintrin_is_intrinsic (ffesymbol_text (s), ffeexpr_stack_->tokens[0],
18489 			      FALSE, &gen, &spec, &imp))
18490     {
18491       ffebld_symter_set_generic (symter, gen);
18492       ffebld_symter_set_specific (symter, spec);
18493       ffebld_symter_set_implementation (symter, imp);
18494       ffesymbol_set_generic (s, gen);
18495       ffesymbol_set_specific (s, spec);
18496       ffesymbol_set_implementation (s, imp);
18497       ffesymbol_set_info (s,
18498 			  ffeinfo_new (ffesymbol_basictype (s),
18499 				       ffesymbol_kindtype (s),
18500 				       0,
18501 				       FFEINFO_kindFUNCTION,
18502 				       FFEINFO_whereINTRINSIC,
18503 				       ffesymbol_size (s)));
18504     }
18505   else
18506     {				/* Not intrinsic, now needs CHAR type. */
18507       if (!ffeimplic_establish_symbol (s))
18508 	{
18509 	  ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
18510 	  return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
18511 	}
18512 
18513       ffesymbol_set_info (s,
18514 			  ffeinfo_new (ffesymbol_basictype (s),
18515 				       ffesymbol_kindtype (s),
18516 				       ffesymbol_rank (s),
18517 				       FFEINFO_kindFUNCTION,
18518 				       (where == FFEINFO_whereNONE)
18519 				       ? FFEINFO_whereGLOBAL
18520 				       : where,
18521 				       ffesymbol_size (s)));
18522     }
18523 
18524   ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
18525 
18526   ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18527   ffesymbol_resolve_intrin (s);
18528   s = ffecom_sym_learned (s);
18529   ffesymbol_reference (s, ffeexpr_stack_->tokens[0], FALSE);
18530   ffesymbol_signal_unreported (s);	/* For debugging purposes. */
18531   ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
18532   return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
18533 }
18534 
18535 /* ffeexpr_token_anything_ -- NAME OPEN_PAREN any-expr
18536 
18537    Handle basically any expression, looking for CLOSE_PAREN.  */
18538 
18539 static ffelexHandler
ffeexpr_token_anything_(ffelexToken ft UNUSED,ffebld expr UNUSED,ffelexToken t)18540 ffeexpr_token_anything_ (ffelexToken ft UNUSED, ffebld expr UNUSED,
18541 			 ffelexToken t)
18542 {
18543   ffeexprExpr_ e = ffeexpr_stack_->exprstack;
18544 
18545   switch (ffelex_token_type (t))
18546     {
18547     case FFELEX_typeCOMMA:
18548     case FFELEX_typeCOLON:
18549       return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18550 					  FFEEXPR_contextACTUALARG_,
18551 					  ffeexpr_token_anything_);
18552 
18553     default:
18554       e->u.operand = ffebld_new_any ();
18555       ffebld_set_info (e->u.operand, ffeinfo_new_any ());
18556       ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18557       ffeexpr_is_substr_ok_ = FALSE;
18558       if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18559 	return (ffelexHandler) ffeexpr_token_substrp_;
18560       return (ffelexHandler) ffeexpr_token_substrp_ (t);
18561     }
18562 }
18563 
18564 /* Terminate module.  */
18565 
18566 void
ffeexpr_terminate_2(void)18567 ffeexpr_terminate_2 (void)
18568 {
18569   assert (ffeexpr_stack_ == NULL);
18570   assert (ffeexpr_level_ == 0);
18571 }
18572