?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
re PR libstdc++/8716 (std::string( NULL, 0 ) throws exception also on zero length)
[official-gcc.git] / gcc / f / expr.c
blob4824be7cdb35801ea228ec21d138375782794d0a
1 /* expr.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 1997, 1998, 2001, 2002
3 Free Software Foundation, Inc.
4 Contributed by James Craig Burley.
5
6 This file is part of GNU Fortran.
7
8 GNU Fortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
11 any later version.
12
13 GNU Fortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GNU Fortran; see the file COPYING. If not, write to
20 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
21 02111-1307, USA.
22
23 Related Modules:
24 None.
25
26 Description:
27 Handles syntactic and semantic analysis of Fortran expressions.
28
29 Modifications:
30 */
31
32 /* Include files. */
33
34 #include "proj.h"
35 #include "expr.h"
36 #include "bad.h"
37 #include "bld.h"
38 #include "com.h"
39 #include "global.h"
40 #include "implic.h"
41 #include "intrin.h"
42 #include "info.h"
43 #include "lex.h"
44 #include "malloc.h"
45 #include "src.h"
46 #include "st.h"
47 #include "symbol.h"
48 #include "str.h"
49 #include "target.h"
50 #include "where.h"
51 #include "real.h"
52
53 /* Externals defined here. */
54
55
56 /* Simple definitions and enumerations. */
57
58 typedef enum
59 {
60 FFEEXPR_exprtypeUNKNOWN_,
61 FFEEXPR_exprtypeOPERAND_,
62 FFEEXPR_exprtypeUNARY_,
63 FFEEXPR_exprtypeBINARY_,
64 FFEEXPR_exprtype_
65 } ffeexprExprtype_;
66
67 typedef enum
68 {
69 FFEEXPR_operatorPOWER_,
70 FFEEXPR_operatorMULTIPLY_,
71 FFEEXPR_operatorDIVIDE_,
72 FFEEXPR_operatorADD_,
73 FFEEXPR_operatorSUBTRACT_,
74 FFEEXPR_operatorCONCATENATE_,
75 FFEEXPR_operatorLT_,
76 FFEEXPR_operatorLE_,
77 FFEEXPR_operatorEQ_,
78 FFEEXPR_operatorNE_,
79 FFEEXPR_operatorGT_,
80 FFEEXPR_operatorGE_,
81 FFEEXPR_operatorNOT_,
82 FFEEXPR_operatorAND_,
83 FFEEXPR_operatorOR_,
84 FFEEXPR_operatorXOR_,
85 FFEEXPR_operatorEQV_,
86 FFEEXPR_operatorNEQV_,
87 FFEEXPR_operator_
88 } ffeexprOperator_;
89
90 typedef enum
91 {
92 FFEEXPR_operatorprecedenceHIGHEST_ = 1,
93 FFEEXPR_operatorprecedencePOWER_ = 1,
94 FFEEXPR_operatorprecedenceMULTIPLY_ = 2,
95 FFEEXPR_operatorprecedenceDIVIDE_ = 2,
96 FFEEXPR_operatorprecedenceADD_ = 3,
97 FFEEXPR_operatorprecedenceSUBTRACT_ = 3,
98 FFEEXPR_operatorprecedenceLOWARITH_ = 3,
99 FFEEXPR_operatorprecedenceCONCATENATE_ = 3,
100 FFEEXPR_operatorprecedenceLT_ = 4,
101 FFEEXPR_operatorprecedenceLE_ = 4,
102 FFEEXPR_operatorprecedenceEQ_ = 4,
103 FFEEXPR_operatorprecedenceNE_ = 4,
104 FFEEXPR_operatorprecedenceGT_ = 4,
105 FFEEXPR_operatorprecedenceGE_ = 4,
106 FFEEXPR_operatorprecedenceNOT_ = 5,
107 FFEEXPR_operatorprecedenceAND_ = 6,
108 FFEEXPR_operatorprecedenceOR_ = 7,
109 FFEEXPR_operatorprecedenceXOR_ = 8,
110 FFEEXPR_operatorprecedenceEQV_ = 8,
111 FFEEXPR_operatorprecedenceNEQV_ = 8,
112 FFEEXPR_operatorprecedenceLOWEST_ = 8,
113 FFEEXPR_operatorprecedence_
114 } ffeexprOperatorPrecedence_;
115
116 #define FFEEXPR_operatorassociativityL2R_ TRUE
117 #define FFEEXPR_operatorassociativityR2L_ FALSE
118 #define FFEEXPR_operatorassociativityPOWER_ FFEEXPR_operatorassociativityR2L_
119 #define FFEEXPR_operatorassociativityMULTIPLY_ FFEEXPR_operatorassociativityL2R_
120 #define FFEEXPR_operatorassociativityDIVIDE_ FFEEXPR_operatorassociativityL2R_
121 #define FFEEXPR_operatorassociativityADD_ FFEEXPR_operatorassociativityL2R_
122 #define FFEEXPR_operatorassociativitySUBTRACT_ FFEEXPR_operatorassociativityL2R_
123 #define FFEEXPR_operatorassociativityCONCATENATE_ FFEEXPR_operatorassociativityL2R_
124 #define FFEEXPR_operatorassociativityLT_ FFEEXPR_operatorassociativityL2R_
125 #define FFEEXPR_operatorassociativityLE_ FFEEXPR_operatorassociativityL2R_
126 #define FFEEXPR_operatorassociativityEQ_ FFEEXPR_operatorassociativityL2R_
127 #define FFEEXPR_operatorassociativityNE_ FFEEXPR_operatorassociativityL2R_
128 #define FFEEXPR_operatorassociativityGT_ FFEEXPR_operatorassociativityL2R_
129 #define FFEEXPR_operatorassociativityGE_ FFEEXPR_operatorassociativityL2R_
130 #define FFEEXPR_operatorassociativityNOT_ FFEEXPR_operatorassociativityL2R_
131 #define FFEEXPR_operatorassociativityAND_ FFEEXPR_operatorassociativityL2R_
132 #define FFEEXPR_operatorassociativityOR_ FFEEXPR_operatorassociativityL2R_
133 #define FFEEXPR_operatorassociativityXOR_ FFEEXPR_operatorassociativityL2R_
134 #define FFEEXPR_operatorassociativityEQV_ FFEEXPR_operatorassociativityL2R_
135 #define FFEEXPR_operatorassociativityNEQV_ FFEEXPR_operatorassociativityL2R_
136
137 typedef enum
138 {
139 FFEEXPR_parentypeFUNCTION_,
140 FFEEXPR_parentypeSUBROUTINE_,
141 FFEEXPR_parentypeARRAY_,
142 FFEEXPR_parentypeSUBSTRING_,
143 FFEEXPR_parentypeFUNSUBSTR_,/* Ambig: check for colon after first expr. */
144 FFEEXPR_parentypeEQUIVALENCE_, /* Ambig: ARRAY_ or SUBSTRING_. */
145 FFEEXPR_parentypeANY_, /* Allow basically anything. */
146 FFEEXPR_parentype_
147 } ffeexprParenType_;
148
149 typedef enum
150 {
151 FFEEXPR_percentNONE_,
152 FFEEXPR_percentLOC_,
153 FFEEXPR_percentVAL_,
154 FFEEXPR_percentREF_,
155 FFEEXPR_percentDESCR_,
156 FFEEXPR_percent_
157 } ffeexprPercent_;
158
159 /* Internal typedefs. */
160
161 typedef struct _ffeexpr_expr_ *ffeexprExpr_;
162 typedef bool ffeexprOperatorAssociativity_;
163 typedef struct _ffeexpr_stack_ *ffeexprStack_;
164
165 /* Private include files. */
166
167
168 /* Internal structure definitions. */
169
170 struct _ffeexpr_expr_
171 {
172 ffeexprExpr_ previous;
173 ffelexToken token;
174 ffeexprExprtype_ type;
175 union
176 {
177 struct
178 {
179 ffeexprOperator_ op;
180 ffeexprOperatorPrecedence_ prec;
181 ffeexprOperatorAssociativity_ as;
182 }
183 operator;
184 ffebld operand;
185 }
186 u;
187 };
188
189 struct _ffeexpr_stack_
190 {
191 ffeexprStack_ previous;
192 mallocPool pool;
193 ffeexprContext context;
194 ffeexprCallback callback;
195 ffelexToken first_token;
196 ffeexprExpr_ exprstack;
197 ffelexToken tokens[10]; /* Used in certain cases, like (unary)
198 open-paren. */
199 ffebld expr; /* For first of
200 complex/implied-do/substring/array-elements
201 / actual-args expression. */
202 ffebld bound_list; /* For tracking dimension bounds list of
203 array. */
204 ffebldListBottom bottom; /* For building lists. */
205 ffeinfoRank rank; /* For elements in an array reference. */
206 bool constant; /* TRUE while elements seen so far are
207 constants. */
208 bool immediate; /* TRUE while elements seen so far are
209 immediate/constants. */
210 ffebld next_dummy; /* Next SFUNC dummy arg in arg list. */
211 ffebldListLength num_args; /* Number of dummy args expected in arg list. */
212 bool is_rhs; /* TRUE if rhs context, FALSE otherwise. */
213 ffeexprPercent_ percent; /* Current %FOO keyword. */
214 };
215
216 struct _ffeexpr_find_
217 {
218 ffelexToken t;
219 ffelexHandler after;
220 int level;
221 };
222
223 /* Static objects accessed by functions in this module. */
224
225 static ffeexprStack_ ffeexpr_stack_; /* Expression stack for semantic. */
226 static ffelexToken ffeexpr_tokens_[10]; /* Scratchpad tokens for syntactic. */
227 static ffestrOther ffeexpr_current_dotdot_; /* Current .FOO. keyword. */
228 static long ffeexpr_hollerith_count_; /* ffeexpr_token_number_ and caller. */
229 static int ffeexpr_level_; /* Level of DATA implied-DO construct. */
230 static bool ffeexpr_is_substr_ok_; /* If OPEN_PAREN as binary "op" ok. */
231 static struct _ffeexpr_find_ ffeexpr_find_;
232
233 /* Static functions (internal). */
234
235 static ffelexHandler ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr,
236 ffelexToken t);
237 static ffelexHandler ffeexpr_cb_close_paren_ambig_ (ffelexToken ft,
238 ffebld expr,
239 ffelexToken t);
240 static ffelexHandler ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t);
241 static ffelexHandler ffeexpr_cb_close_paren_c_ (ffelexToken ft,
242 ffebld expr, ffelexToken t);
243 static ffelexHandler ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr,
244 ffelexToken t);
245 static ffelexHandler ffeexpr_cb_close_paren_ci_ (ffelexToken ft,
246 ffebld expr, ffelexToken t);
247 static ffelexHandler ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr,
248 ffelexToken t);
249 static ffelexHandler ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr,
250 ffelexToken t);
251 static ffelexHandler ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr,
252 ffelexToken t);
253 static ffelexHandler ffeexpr_cb_comma_i_2_ (ffelexToken ft, ffebld expr,
254 ffelexToken t);
255 static ffelexHandler ffeexpr_cb_comma_i_3_ (ffelexToken ft, ffebld expr,
256 ffelexToken t);
257 static ffelexHandler ffeexpr_cb_comma_i_4_ (ffelexToken ft, ffebld expr,
258 ffelexToken t);
259 static ffelexHandler ffeexpr_cb_comma_i_5_ (ffelexToken t);
260 static ffelexHandler ffeexpr_cb_end_loc_ (ffelexToken ft, ffebld expr,
261 ffelexToken t);
262 static ffelexHandler ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr,
263 ffelexToken t);
264 static ffelexHandler ffeexpr_cb_end_notloc_1_ (ffelexToken t);
265 static ffesymbol ffeexpr_check_impctrl_ (ffesymbol s);
266 static void ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
267 ffebld dovar, ffelexToken dovar_t);
268 static void ffeexpr_update_impdo_ (ffebld expr, ffebld dovar);
269 static void ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar);
270 static ffeexprContext ffeexpr_context_outer_ (ffeexprStack_ s);
271 static ffeexprExpr_ ffeexpr_expr_new_ (void);
272 static void ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t);
273 static bool ffeexpr_isdigits_ (const char *p);
274 static ffelexHandler ffeexpr_token_first_lhs_ (ffelexToken t);
275 static ffelexHandler ffeexpr_token_first_lhs_1_ (ffelexToken t);
276 static ffelexHandler ffeexpr_token_first_rhs_ (ffelexToken t);
277 static ffelexHandler ffeexpr_token_first_rhs_1_ (ffelexToken t);
278 static ffelexHandler ffeexpr_token_first_rhs_2_ (ffelexToken t);
279 static ffelexHandler ffeexpr_token_first_rhs_3_ (ffelexToken t);
280 static ffelexHandler ffeexpr_token_first_rhs_4_ (ffelexToken t);
281 static ffelexHandler ffeexpr_token_first_rhs_5_ (ffelexToken t);
282 static ffelexHandler ffeexpr_token_first_rhs_6_ (ffelexToken t);
283 static ffelexHandler ffeexpr_token_namelist_ (ffelexToken t);
284 static void ffeexpr_expr_kill_ (ffeexprExpr_ e);
285 static void ffeexpr_exprstack_push_ (ffeexprExpr_ e);
286 static void ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e);
287 static void ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e);
288 static void ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e);
289 static void ffeexpr_reduce_ (void);
290 static ffebld ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op,
291 ffeexprExpr_ r);
292 static ffebld ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l,
293 ffeexprExpr_ op, ffeexprExpr_ r);
294 static ffebld ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l,
295 ffeexprExpr_ op, ffeexprExpr_ r);
296 static ffebld ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l,
297 ffeexprExpr_ op, ffeexprExpr_ r);
298 static ffebld ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op,
299 ffeexprExpr_ r);
300 static ffebld ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l,
301 ffeexprExpr_ op, ffeexprExpr_ r);
302 static ffebld ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l,
303 ffeexprExpr_ op, ffeexprExpr_ r);
304 static ffebld ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l,
305 ffeexprExpr_ op, ffeexprExpr_ r);
306 static ffebld ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r);
307 static ffebld ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op,
308 ffeexprExpr_ r);
309 static ffebld ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l,
310 ffeexprExpr_ op, ffeexprExpr_ r);
311 static ffebld ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l,
312 ffeexprExpr_ op, ffeexprExpr_ r);
313 static ffelexHandler ffeexpr_find_close_paren_ (ffelexToken t,
314 ffelexHandler after);
315 static ffelexHandler ffeexpr_nil_finished_ (ffelexToken t);
316 static ffelexHandler ffeexpr_nil_rhs_ (ffelexToken t);
317 static ffelexHandler ffeexpr_nil_period_ (ffelexToken t);
318 static ffelexHandler ffeexpr_nil_end_period_ (ffelexToken t);
319 static ffelexHandler ffeexpr_nil_swallow_period_ (ffelexToken t);
320 static ffelexHandler ffeexpr_nil_real_ (ffelexToken t);
321 static ffelexHandler ffeexpr_nil_real_exponent_ (ffelexToken t);
322 static ffelexHandler ffeexpr_nil_real_exp_sign_ (ffelexToken t);
323 static ffelexHandler ffeexpr_nil_number_ (ffelexToken t);
324 static ffelexHandler ffeexpr_nil_number_exponent_ (ffelexToken t);
325 static ffelexHandler ffeexpr_nil_number_exp_sign_ (ffelexToken t);
326 static ffelexHandler ffeexpr_nil_number_period_ (ffelexToken t);
327 static ffelexHandler ffeexpr_nil_number_per_exp_ (ffelexToken t);
328 static ffelexHandler ffeexpr_nil_number_real_ (ffelexToken t);
329 static ffelexHandler ffeexpr_nil_num_per_exp_sign_ (ffelexToken t);
330 static ffelexHandler ffeexpr_nil_number_real_exp_ (ffelexToken t);
331 static ffelexHandler ffeexpr_nil_num_real_exp_sn_ (ffelexToken t);
332 static ffelexHandler ffeexpr_nil_binary_ (ffelexToken t);
333 static ffelexHandler ffeexpr_nil_binary_period_ (ffelexToken t);
334 static ffelexHandler ffeexpr_nil_binary_end_per_ (ffelexToken t);
335 static ffelexHandler ffeexpr_nil_binary_sw_per_ (ffelexToken t);
336 static ffelexHandler ffeexpr_nil_quote_ (ffelexToken t);
337 static ffelexHandler ffeexpr_nil_apostrophe_ (ffelexToken t);
338 static ffelexHandler ffeexpr_nil_apos_char_ (ffelexToken t);
339 static ffelexHandler ffeexpr_nil_name_rhs_ (ffelexToken t);
340 static ffelexHandler ffeexpr_nil_name_apos_ (ffelexToken t);
341 static ffelexHandler ffeexpr_nil_name_apos_name_ (ffelexToken t);
342 static ffelexHandler ffeexpr_nil_percent_ (ffelexToken t);
343 static ffelexHandler ffeexpr_nil_percent_name_ (ffelexToken t);
344 static ffelexHandler ffeexpr_nil_substrp_ (ffelexToken t);
345 static ffelexHandler ffeexpr_finished_ (ffelexToken t);
346 static ffebld ffeexpr_finished_ambig_ (ffelexToken t, ffebld expr);
347 static ffelexHandler ffeexpr_token_lhs_ (ffelexToken t);
348 static ffelexHandler ffeexpr_token_rhs_ (ffelexToken t);
349 static ffelexHandler ffeexpr_token_binary_ (ffelexToken t);
350 static ffelexHandler ffeexpr_token_period_ (ffelexToken t);
351 static ffelexHandler ffeexpr_token_end_period_ (ffelexToken t);
352 static ffelexHandler ffeexpr_token_swallow_period_ (ffelexToken t);
353 static ffelexHandler ffeexpr_token_real_ (ffelexToken t);
354 static ffelexHandler ffeexpr_token_real_exponent_ (ffelexToken t);
355 static ffelexHandler ffeexpr_token_real_exp_sign_ (ffelexToken t);
356 static ffelexHandler ffeexpr_token_number_ (ffelexToken t);
357 static ffelexHandler ffeexpr_token_number_exponent_ (ffelexToken t);
358 static ffelexHandler ffeexpr_token_number_exp_sign_ (ffelexToken t);
359 static ffelexHandler ffeexpr_token_number_period_ (ffelexToken t);
360 static ffelexHandler ffeexpr_token_number_per_exp_ (ffelexToken t);
361 static ffelexHandler ffeexpr_token_number_real_ (ffelexToken t);
362 static ffelexHandler ffeexpr_token_num_per_exp_sign_ (ffelexToken t);
363 static ffelexHandler ffeexpr_token_number_real_exp_ (ffelexToken t);
364 static ffelexHandler ffeexpr_token_num_real_exp_sn_ (ffelexToken t);
365 static ffelexHandler ffeexpr_token_binary_period_ (ffelexToken t);
366 static ffelexHandler ffeexpr_token_binary_end_per_ (ffelexToken t);
367 static ffelexHandler ffeexpr_token_binary_sw_per_ (ffelexToken t);
368 static ffelexHandler ffeexpr_token_quote_ (ffelexToken t);
369 static ffelexHandler ffeexpr_token_apostrophe_ (ffelexToken t);
370 static ffelexHandler ffeexpr_token_apos_char_ (ffelexToken t);
371 static ffelexHandler ffeexpr_token_name_lhs_ (ffelexToken t);
372 static ffelexHandler ffeexpr_token_name_arg_ (ffelexToken t);
373 static ffelexHandler ffeexpr_token_name_rhs_ (ffelexToken t);
374 static ffelexHandler ffeexpr_token_name_apos_ (ffelexToken t);
375 static ffelexHandler ffeexpr_token_name_apos_name_ (ffelexToken t);
376 static ffelexHandler ffeexpr_token_percent_ (ffelexToken t);
377 static ffelexHandler ffeexpr_token_percent_name_ (ffelexToken t);
378 static ffelexHandler ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr,
379 ffelexToken t);
380 static ffelexHandler ffeexpr_token_elements_ (ffelexToken ft, ffebld expr,
381 ffelexToken t);
382 static ffelexHandler ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr,
383 ffelexToken t);
384 static ffelexHandler ffeexpr_token_substring_ (ffelexToken ft, ffebld expr,
385 ffelexToken t);
386 static ffelexHandler ffeexpr_token_substring_1_ (ffelexToken ft, ffebld expr,
387 ffelexToken t);
388 static ffelexHandler ffeexpr_token_substrp_ (ffelexToken t);
389 static ffelexHandler ffeexpr_token_intrincheck_ (ffelexToken t);
390 static ffelexHandler ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr,
391 ffelexToken t);
392 static ffelexHandler ffeexpr_token_anything_ (ffelexToken ft, ffebld expr,
393 ffelexToken t);
394 static void ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
395 ffelexToken decimal, ffelexToken fraction, ffelexToken exponent,
396 ffelexToken exponent_sign, ffelexToken exponent_digits);
397 static ffesymbol ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin);
398 static ffesymbol ffeexpr_sym_impdoitem_ (ffesymbol s, ffelexToken t);
399 static ffesymbol ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t);
400 static ffesymbol ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t);
401 static ffesymbol ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t);
402 static ffesymbol ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t);
403 static ffesymbol ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t);
404 static ffesymbol ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t);
405 static ffesymbol ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t);
406 static ffesymbol ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t);
407 static ffesymbol ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t);
408 static ffesymbol ffeexpr_declare_parenthesized_ (ffelexToken t,
409 bool maybe_intrin,
410 ffeexprParenType_ *paren_type);
411 static ffesymbol ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t);
412
413 /* Internal macros. */
414
415 #define ffeexpr_paren_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
416 #define ffeexpr_sym_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
417 \f
418 /* ffeexpr_collapse_convert -- Collapse convert expr
419
420 ffebld expr;
421 ffelexToken token;
422 expr = ffeexpr_collapse_convert(expr,token);
423
424 If the result of the expr is a constant, replaces the expr with the
425 computed constant. */
426
427 ffebld
428 ffeexpr_collapse_convert (ffebld expr, ffelexToken t)
429 {
430 ffebad error = FFEBAD;
431 ffebld l;
432 ffebldConstantUnion u;
433 ffeinfoBasictype bt;
434 ffeinfoKindtype kt;
435 ffetargetCharacterSize sz;
436 ffetargetCharacterSize sz2;
437
438 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
439 return expr;
440
441 l = ffebld_left (expr);
442
443 if (ffebld_op (l) != FFEBLD_opCONTER)
444 return expr;
445
446 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
447 {
448 case FFEINFO_basictypeANY:
449 return expr;
450
451 case FFEINFO_basictypeINTEGER:
452 sz = FFETARGET_charactersizeNONE;
453 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
454 {
455 #if FFETARGET_okINTEGER1
456 case FFEINFO_kindtypeINTEGER1:
457 switch (ffeinfo_basictype (ffebld_info (l)))
458 {
459 case FFEINFO_basictypeINTEGER:
460 switch (ffeinfo_kindtype (ffebld_info (l)))
461 {
462 #if FFETARGET_okINTEGER2
463 case FFEINFO_kindtypeINTEGER2:
464 error = ffetarget_convert_integer1_integer2
465 (ffebld_cu_ptr_integer1 (u),
466 ffebld_constant_integer2 (ffebld_conter (l)));
467 break;
468 #endif
469
470 #if FFETARGET_okINTEGER3
471 case FFEINFO_kindtypeINTEGER3:
472 error = ffetarget_convert_integer1_integer3
473 (ffebld_cu_ptr_integer1 (u),
474 ffebld_constant_integer3 (ffebld_conter (l)));
475 break;
476 #endif
477
478 #if FFETARGET_okINTEGER4
479 case FFEINFO_kindtypeINTEGER4:
480 error = ffetarget_convert_integer1_integer4
481 (ffebld_cu_ptr_integer1 (u),
482 ffebld_constant_integer4 (ffebld_conter (l)));
483 break;
484 #endif
485
486 default:
487 assert ("INTEGER1/INTEGER bad source kind type" == NULL);
488 break;
489 }
490 break;
491
492 case FFEINFO_basictypeREAL:
493 switch (ffeinfo_kindtype (ffebld_info (l)))
494 {
495 #if FFETARGET_okREAL1
496 case FFEINFO_kindtypeREAL1:
497 error = ffetarget_convert_integer1_real1
498 (ffebld_cu_ptr_integer1 (u),
499 ffebld_constant_real1 (ffebld_conter (l)));
500 break;
501 #endif
502
503 #if FFETARGET_okREAL2
504 case FFEINFO_kindtypeREAL2:
505 error = ffetarget_convert_integer1_real2
506 (ffebld_cu_ptr_integer1 (u),
507 ffebld_constant_real2 (ffebld_conter (l)));
508 break;
509 #endif
510
511 #if FFETARGET_okREAL3
512 case FFEINFO_kindtypeREAL3:
513 error = ffetarget_convert_integer1_real3
514 (ffebld_cu_ptr_integer1 (u),
515 ffebld_constant_real3 (ffebld_conter (l)));
516 break;
517 #endif
518
519 #if FFETARGET_okREAL4
520 case FFEINFO_kindtypeREAL4:
521 error = ffetarget_convert_integer1_real4
522 (ffebld_cu_ptr_integer1 (u),
523 ffebld_constant_real4 (ffebld_conter (l)));
524 break;
525 #endif
526
527 default:
528 assert ("INTEGER1/REAL bad source kind type" == NULL);
529 break;
530 }
531 break;
532
533 case FFEINFO_basictypeCOMPLEX:
534 switch (ffeinfo_kindtype (ffebld_info (l)))
535 {
536 #if FFETARGET_okCOMPLEX1
537 case FFEINFO_kindtypeREAL1:
538 error = ffetarget_convert_integer1_complex1
539 (ffebld_cu_ptr_integer1 (u),
540 ffebld_constant_complex1 (ffebld_conter (l)));
541 break;
542 #endif
543
544 #if FFETARGET_okCOMPLEX2
545 case FFEINFO_kindtypeREAL2:
546 error = ffetarget_convert_integer1_complex2
547 (ffebld_cu_ptr_integer1 (u),
548 ffebld_constant_complex2 (ffebld_conter (l)));
549 break;
550 #endif
551
552 #if FFETARGET_okCOMPLEX3
553 case FFEINFO_kindtypeREAL3:
554 error = ffetarget_convert_integer1_complex3
555 (ffebld_cu_ptr_integer1 (u),
556 ffebld_constant_complex3 (ffebld_conter (l)));
557 break;
558 #endif
559
560 #if FFETARGET_okCOMPLEX4
561 case FFEINFO_kindtypeREAL4:
562 error = ffetarget_convert_integer1_complex4
563 (ffebld_cu_ptr_integer1 (u),
564 ffebld_constant_complex4 (ffebld_conter (l)));
565 break;
566 #endif
567
568 default:
569 assert ("INTEGER1/COMPLEX bad source kind type" == NULL);
570 break;
571 }
572 break;
573
574 case FFEINFO_basictypeLOGICAL:
575 switch (ffeinfo_kindtype (ffebld_info (l)))
576 {
577 #if FFETARGET_okLOGICAL1
578 case FFEINFO_kindtypeLOGICAL1:
579 error = ffetarget_convert_integer1_logical1
580 (ffebld_cu_ptr_integer1 (u),
581 ffebld_constant_logical1 (ffebld_conter (l)));
582 break;
583 #endif
584
585 #if FFETARGET_okLOGICAL2
586 case FFEINFO_kindtypeLOGICAL2:
587 error = ffetarget_convert_integer1_logical2
588 (ffebld_cu_ptr_integer1 (u),
589 ffebld_constant_logical2 (ffebld_conter (l)));
590 break;
591 #endif
592
593 #if FFETARGET_okLOGICAL3
594 case FFEINFO_kindtypeLOGICAL3:
595 error = ffetarget_convert_integer1_logical3
596 (ffebld_cu_ptr_integer1 (u),
597 ffebld_constant_logical3 (ffebld_conter (l)));
598 break;
599 #endif
600
601 #if FFETARGET_okLOGICAL4
602 case FFEINFO_kindtypeLOGICAL4:
603 error = ffetarget_convert_integer1_logical4
604 (ffebld_cu_ptr_integer1 (u),
605 ffebld_constant_logical4 (ffebld_conter (l)));
606 break;
607 #endif
608
609 default:
610 assert ("INTEGER1/LOGICAL bad source kind type" == NULL);
611 break;
612 }
613 break;
614
615 case FFEINFO_basictypeCHARACTER:
616 error = ffetarget_convert_integer1_character1
617 (ffebld_cu_ptr_integer1 (u),
618 ffebld_constant_character1 (ffebld_conter (l)));
619 break;
620
621 case FFEINFO_basictypeHOLLERITH:
622 error = ffetarget_convert_integer1_hollerith
623 (ffebld_cu_ptr_integer1 (u),
624 ffebld_constant_hollerith (ffebld_conter (l)));
625 break;
626
627 case FFEINFO_basictypeTYPELESS:
628 error = ffetarget_convert_integer1_typeless
629 (ffebld_cu_ptr_integer1 (u),
630 ffebld_constant_typeless (ffebld_conter (l)));
631 break;
632
633 default:
634 assert ("INTEGER1 bad type" == NULL);
635 break;
636 }
637
638 /* If conversion operation is not implemented, return original expr. */
639 if (error == FFEBAD_NOCANDO)
640 return expr;
641
642 expr = ffebld_new_conter_with_orig
643 (ffebld_constant_new_integer1_val
644 (ffebld_cu_val_integer1 (u)), expr);
645 break;
646 #endif
647
648 #if FFETARGET_okINTEGER2
649 case FFEINFO_kindtypeINTEGER2:
650 switch (ffeinfo_basictype (ffebld_info (l)))
651 {
652 case FFEINFO_basictypeINTEGER:
653 switch (ffeinfo_kindtype (ffebld_info (l)))
654 {
655 #if FFETARGET_okINTEGER1
656 case FFEINFO_kindtypeINTEGER1:
657 error = ffetarget_convert_integer2_integer1
658 (ffebld_cu_ptr_integer2 (u),
659 ffebld_constant_integer1 (ffebld_conter (l)));
660 break;
661 #endif
662
663 #if FFETARGET_okINTEGER3
664 case FFEINFO_kindtypeINTEGER3:
665 error = ffetarget_convert_integer2_integer3
666 (ffebld_cu_ptr_integer2 (u),
667 ffebld_constant_integer3 (ffebld_conter (l)));
668 break;
669 #endif
670
671 #if FFETARGET_okINTEGER4
672 case FFEINFO_kindtypeINTEGER4:
673 error = ffetarget_convert_integer2_integer4
674 (ffebld_cu_ptr_integer2 (u),
675 ffebld_constant_integer4 (ffebld_conter (l)));
676 break;
677 #endif
678
679 default:
680 assert ("INTEGER2/INTEGER bad source kind type" == NULL);
681 break;
682 }
683 break;
684
685 case FFEINFO_basictypeREAL:
686 switch (ffeinfo_kindtype (ffebld_info (l)))
687 {
688 #if FFETARGET_okREAL1
689 case FFEINFO_kindtypeREAL1:
690 error = ffetarget_convert_integer2_real1
691 (ffebld_cu_ptr_integer2 (u),
692 ffebld_constant_real1 (ffebld_conter (l)));
693 break;
694 #endif
695
696 #if FFETARGET_okREAL2
697 case FFEINFO_kindtypeREAL2:
698 error = ffetarget_convert_integer2_real2
699 (ffebld_cu_ptr_integer2 (u),
700 ffebld_constant_real2 (ffebld_conter (l)));
701 break;
702 #endif
703
704 #if FFETARGET_okREAL3
705 case FFEINFO_kindtypeREAL3:
706 error = ffetarget_convert_integer2_real3
707 (ffebld_cu_ptr_integer2 (u),
708 ffebld_constant_real3 (ffebld_conter (l)));
709 break;
710 #endif
711
712 #if FFETARGET_okREAL4
713 case FFEINFO_kindtypeREAL4:
714 error = ffetarget_convert_integer2_real4
715 (ffebld_cu_ptr_integer2 (u),
716 ffebld_constant_real4 (ffebld_conter (l)));
717 break;
718 #endif
719
720 default:
721 assert ("INTEGER2/REAL bad source kind type" == NULL);
722 break;
723 }
724 break;
725
726 case FFEINFO_basictypeCOMPLEX:
727 switch (ffeinfo_kindtype (ffebld_info (l)))
728 {
729 #if FFETARGET_okCOMPLEX1
730 case FFEINFO_kindtypeREAL1:
731 error = ffetarget_convert_integer2_complex1
732 (ffebld_cu_ptr_integer2 (u),
733 ffebld_constant_complex1 (ffebld_conter (l)));
734 break;
735 #endif
736
737 #if FFETARGET_okCOMPLEX2
738 case FFEINFO_kindtypeREAL2:
739 error = ffetarget_convert_integer2_complex2
740 (ffebld_cu_ptr_integer2 (u),
741 ffebld_constant_complex2 (ffebld_conter (l)));
742 break;
743 #endif
744
745 #if FFETARGET_okCOMPLEX3
746 case FFEINFO_kindtypeREAL3:
747 error = ffetarget_convert_integer2_complex3
748 (ffebld_cu_ptr_integer2 (u),
749 ffebld_constant_complex3 (ffebld_conter (l)));
750 break;
751 #endif
752
753 #if FFETARGET_okCOMPLEX4
754 case FFEINFO_kindtypeREAL4:
755 error = ffetarget_convert_integer2_complex4
756 (ffebld_cu_ptr_integer2 (u),
757 ffebld_constant_complex4 (ffebld_conter (l)));
758 break;
759 #endif
760
761 default:
762 assert ("INTEGER2/COMPLEX bad source kind type" == NULL);
763 break;
764 }
765 break;
766
767 case FFEINFO_basictypeLOGICAL:
768 switch (ffeinfo_kindtype (ffebld_info (l)))
769 {
770 #if FFETARGET_okLOGICAL1
771 case FFEINFO_kindtypeLOGICAL1:
772 error = ffetarget_convert_integer2_logical1
773 (ffebld_cu_ptr_integer2 (u),
774 ffebld_constant_logical1 (ffebld_conter (l)));
775 break;
776 #endif
777
778 #if FFETARGET_okLOGICAL2
779 case FFEINFO_kindtypeLOGICAL2:
780 error = ffetarget_convert_integer2_logical2
781 (ffebld_cu_ptr_integer2 (u),
782 ffebld_constant_logical2 (ffebld_conter (l)));
783 break;
784 #endif
785
786 #if FFETARGET_okLOGICAL3
787 case FFEINFO_kindtypeLOGICAL3:
788 error = ffetarget_convert_integer2_logical3
789 (ffebld_cu_ptr_integer2 (u),
790 ffebld_constant_logical3 (ffebld_conter (l)));
791 break;
792 #endif
793
794 #if FFETARGET_okLOGICAL4
795 case FFEINFO_kindtypeLOGICAL4:
796 error = ffetarget_convert_integer2_logical4
797 (ffebld_cu_ptr_integer2 (u),
798 ffebld_constant_logical4 (ffebld_conter (l)));
799 break;
800 #endif
801
802 default:
803 assert ("INTEGER2/LOGICAL bad source kind type" == NULL);
804 break;
805 }
806 break;
807
808 case FFEINFO_basictypeCHARACTER:
809 error = ffetarget_convert_integer2_character1
810 (ffebld_cu_ptr_integer2 (u),
811 ffebld_constant_character1 (ffebld_conter (l)));
812 break;
813
814 case FFEINFO_basictypeHOLLERITH:
815 error = ffetarget_convert_integer2_hollerith
816 (ffebld_cu_ptr_integer2 (u),
817 ffebld_constant_hollerith (ffebld_conter (l)));
818 break;
819
820 case FFEINFO_basictypeTYPELESS:
821 error = ffetarget_convert_integer2_typeless
822 (ffebld_cu_ptr_integer2 (u),
823 ffebld_constant_typeless (ffebld_conter (l)));
824 break;
825
826 default:
827 assert ("INTEGER2 bad type" == NULL);
828 break;
829 }
830
831 /* If conversion operation is not implemented, return original expr. */
832 if (error == FFEBAD_NOCANDO)
833 return expr;
834
835 expr = ffebld_new_conter_with_orig
836 (ffebld_constant_new_integer2_val
837 (ffebld_cu_val_integer2 (u)), expr);
838 break;
839 #endif
840
841 #if FFETARGET_okINTEGER3
842 case FFEINFO_kindtypeINTEGER3:
843 switch (ffeinfo_basictype (ffebld_info (l)))
844 {
845 case FFEINFO_basictypeINTEGER:
846 switch (ffeinfo_kindtype (ffebld_info (l)))
847 {
848 #if FFETARGET_okINTEGER1
849 case FFEINFO_kindtypeINTEGER1:
850 error = ffetarget_convert_integer3_integer1
851 (ffebld_cu_ptr_integer3 (u),
852 ffebld_constant_integer1 (ffebld_conter (l)));
853 break;
854 #endif
855
856 #if FFETARGET_okINTEGER2
857 case FFEINFO_kindtypeINTEGER2:
858 error = ffetarget_convert_integer3_integer2
859 (ffebld_cu_ptr_integer3 (u),
860 ffebld_constant_integer2 (ffebld_conter (l)));
861 break;
862 #endif
863
864 #if FFETARGET_okINTEGER4
865 case FFEINFO_kindtypeINTEGER4:
866 error = ffetarget_convert_integer3_integer4
867 (ffebld_cu_ptr_integer3 (u),
868 ffebld_constant_integer4 (ffebld_conter (l)));
869 break;
870 #endif
871
872 default:
873 assert ("INTEGER3/INTEGER bad source kind type" == NULL);
874 break;
875 }
876 break;
877
878 case FFEINFO_basictypeREAL:
879 switch (ffeinfo_kindtype (ffebld_info (l)))
880 {
881 #if FFETARGET_okREAL1
882 case FFEINFO_kindtypeREAL1:
883 error = ffetarget_convert_integer3_real1
884 (ffebld_cu_ptr_integer3 (u),
885 ffebld_constant_real1 (ffebld_conter (l)));
886 break;
887 #endif
888
889 #if FFETARGET_okREAL2
890 case FFEINFO_kindtypeREAL2:
891 error = ffetarget_convert_integer3_real2
892 (ffebld_cu_ptr_integer3 (u),
893 ffebld_constant_real2 (ffebld_conter (l)));
894 break;
895 #endif
896
897 #if FFETARGET_okREAL3
898 case FFEINFO_kindtypeREAL3:
899 error = ffetarget_convert_integer3_real3
900 (ffebld_cu_ptr_integer3 (u),
901 ffebld_constant_real3 (ffebld_conter (l)));
902 break;
903 #endif
904
905 #if FFETARGET_okREAL4
906 case FFEINFO_kindtypeREAL4:
907 error = ffetarget_convert_integer3_real4
908 (ffebld_cu_ptr_integer3 (u),
909 ffebld_constant_real4 (ffebld_conter (l)));
910 break;
911 #endif
912
913 default:
914 assert ("INTEGER3/REAL bad source kind type" == NULL);
915 break;
916 }
917 break;
918
919 case FFEINFO_basictypeCOMPLEX:
920 switch (ffeinfo_kindtype (ffebld_info (l)))
921 {
922 #if FFETARGET_okCOMPLEX1
923 case FFEINFO_kindtypeREAL1:
924 error = ffetarget_convert_integer3_complex1
925 (ffebld_cu_ptr_integer3 (u),
926 ffebld_constant_complex1 (ffebld_conter (l)));
927 break;
928 #endif
929
930 #if FFETARGET_okCOMPLEX2
931 case FFEINFO_kindtypeREAL2:
932 error = ffetarget_convert_integer3_complex2
933 (ffebld_cu_ptr_integer3 (u),
934 ffebld_constant_complex2 (ffebld_conter (l)));
935 break;
936 #endif
937
938 #if FFETARGET_okCOMPLEX3
939 case FFEINFO_kindtypeREAL3:
940 error = ffetarget_convert_integer3_complex3
941 (ffebld_cu_ptr_integer3 (u),
942 ffebld_constant_complex3 (ffebld_conter (l)));
943 break;
944 #endif
945
946 #if FFETARGET_okCOMPLEX4
947 case FFEINFO_kindtypeREAL4:
948 error = ffetarget_convert_integer3_complex4
949 (ffebld_cu_ptr_integer3 (u),
950 ffebld_constant_complex4 (ffebld_conter (l)));
951 break;
952 #endif
953
954 default:
955 assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
956 break;
957 }
958 break;
959
960 case FFEINFO_basictypeLOGICAL:
961 switch (ffeinfo_kindtype (ffebld_info (l)))
962 {
963 #if FFETARGET_okLOGICAL1
964 case FFEINFO_kindtypeLOGICAL1:
965 error = ffetarget_convert_integer3_logical1
966 (ffebld_cu_ptr_integer3 (u),
967 ffebld_constant_logical1 (ffebld_conter (l)));
968 break;
969 #endif
970
971 #if FFETARGET_okLOGICAL2
972 case FFEINFO_kindtypeLOGICAL2:
973 error = ffetarget_convert_integer3_logical2
974 (ffebld_cu_ptr_integer3 (u),
975 ffebld_constant_logical2 (ffebld_conter (l)));
976 break;
977 #endif
978
979 #if FFETARGET_okLOGICAL3
980 case FFEINFO_kindtypeLOGICAL3:
981 error = ffetarget_convert_integer3_logical3
982 (ffebld_cu_ptr_integer3 (u),
983 ffebld_constant_logical3 (ffebld_conter (l)));
984 break;
985 #endif
986
987 #if FFETARGET_okLOGICAL4
988 case FFEINFO_kindtypeLOGICAL4:
989 error = ffetarget_convert_integer3_logical4
990 (ffebld_cu_ptr_integer3 (u),
991 ffebld_constant_logical4 (ffebld_conter (l)));
992 break;
993 #endif
994
995 default:
996 assert ("INTEGER3/LOGICAL bad source kind type" == NULL);
997 break;
998 }
999 break;
1000
1001 case FFEINFO_basictypeCHARACTER:
1002 error = ffetarget_convert_integer3_character1
1003 (ffebld_cu_ptr_integer3 (u),
1004 ffebld_constant_character1 (ffebld_conter (l)));
1005 break;
1006
1007 case FFEINFO_basictypeHOLLERITH:
1008 error = ffetarget_convert_integer3_hollerith
1009 (ffebld_cu_ptr_integer3 (u),
1010 ffebld_constant_hollerith (ffebld_conter (l)));
1011 break;
1012
1013 case FFEINFO_basictypeTYPELESS:
1014 error = ffetarget_convert_integer3_typeless
1015 (ffebld_cu_ptr_integer3 (u),
1016 ffebld_constant_typeless (ffebld_conter (l)));
1017 break;
1018
1019 default:
1020 assert ("INTEGER3 bad type" == NULL);
1021 break;
1022 }
1023
1024 /* If conversion operation is not implemented, return original expr. */
1025 if (error == FFEBAD_NOCANDO)
1026 return expr;
1027
1028 expr = ffebld_new_conter_with_orig
1029 (ffebld_constant_new_integer3_val
1030 (ffebld_cu_val_integer3 (u)), expr);
1031 break;
1032 #endif
1033
1034 #if FFETARGET_okINTEGER4
1035 case FFEINFO_kindtypeINTEGER4:
1036 switch (ffeinfo_basictype (ffebld_info (l)))
1037 {
1038 case FFEINFO_basictypeINTEGER:
1039 switch (ffeinfo_kindtype (ffebld_info (l)))
1040 {
1041 #if FFETARGET_okINTEGER1
1042 case FFEINFO_kindtypeINTEGER1:
1043 error = ffetarget_convert_integer4_integer1
1044 (ffebld_cu_ptr_integer4 (u),
1045 ffebld_constant_integer1 (ffebld_conter (l)));
1046 break;
1047 #endif
1048
1049 #if FFETARGET_okINTEGER2
1050 case FFEINFO_kindtypeINTEGER2:
1051 error = ffetarget_convert_integer4_integer2
1052 (ffebld_cu_ptr_integer4 (u),
1053 ffebld_constant_integer2 (ffebld_conter (l)));
1054 break;
1055 #endif
1056
1057 #if FFETARGET_okINTEGER3
1058 case FFEINFO_kindtypeINTEGER3:
1059 error = ffetarget_convert_integer4_integer3
1060 (ffebld_cu_ptr_integer4 (u),
1061 ffebld_constant_integer3 (ffebld_conter (l)));
1062 break;
1063 #endif
1064
1065 default:
1066 assert ("INTEGER4/INTEGER bad source kind type" == NULL);
1067 break;
1068 }
1069 break;
1070
1071 case FFEINFO_basictypeREAL:
1072 switch (ffeinfo_kindtype (ffebld_info (l)))
1073 {
1074 #if FFETARGET_okREAL1
1075 case FFEINFO_kindtypeREAL1:
1076 error = ffetarget_convert_integer4_real1
1077 (ffebld_cu_ptr_integer4 (u),
1078 ffebld_constant_real1 (ffebld_conter (l)));
1079 break;
1080 #endif
1081
1082 #if FFETARGET_okREAL2
1083 case FFEINFO_kindtypeREAL2:
1084 error = ffetarget_convert_integer4_real2
1085 (ffebld_cu_ptr_integer4 (u),
1086 ffebld_constant_real2 (ffebld_conter (l)));
1087 break;
1088 #endif
1089
1090 #if FFETARGET_okREAL3
1091 case FFEINFO_kindtypeREAL3:
1092 error = ffetarget_convert_integer4_real3
1093 (ffebld_cu_ptr_integer4 (u),
1094 ffebld_constant_real3 (ffebld_conter (l)));
1095 break;
1096 #endif
1097
1098 #if FFETARGET_okREAL4
1099 case FFEINFO_kindtypeREAL4:
1100 error = ffetarget_convert_integer4_real4
1101 (ffebld_cu_ptr_integer4 (u),
1102 ffebld_constant_real4 (ffebld_conter (l)));
1103 break;
1104 #endif
1105
1106 default:
1107 assert ("INTEGER4/REAL bad source kind type" == NULL);
1108 break;
1109 }
1110 break;
1111
1112 case FFEINFO_basictypeCOMPLEX:
1113 switch (ffeinfo_kindtype (ffebld_info (l)))
1114 {
1115 #if FFETARGET_okCOMPLEX1
1116 case FFEINFO_kindtypeREAL1:
1117 error = ffetarget_convert_integer4_complex1
1118 (ffebld_cu_ptr_integer4 (u),
1119 ffebld_constant_complex1 (ffebld_conter (l)));
1120 break;
1121 #endif
1122
1123 #if FFETARGET_okCOMPLEX2
1124 case FFEINFO_kindtypeREAL2:
1125 error = ffetarget_convert_integer4_complex2
1126 (ffebld_cu_ptr_integer4 (u),
1127 ffebld_constant_complex2 (ffebld_conter (l)));
1128 break;
1129 #endif
1130
1131 #if FFETARGET_okCOMPLEX3
1132 case FFEINFO_kindtypeREAL3:
1133 error = ffetarget_convert_integer4_complex3
1134 (ffebld_cu_ptr_integer4 (u),
1135 ffebld_constant_complex3 (ffebld_conter (l)));
1136 break;
1137 #endif
1138
1139 #if FFETARGET_okCOMPLEX4
1140 case FFEINFO_kindtypeREAL4:
1141 error = ffetarget_convert_integer4_complex4
1142 (ffebld_cu_ptr_integer4 (u),
1143 ffebld_constant_complex4 (ffebld_conter (l)));
1144 break;
1145 #endif
1146
1147 default:
1148 assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
1149 break;
1150 }
1151 break;
1152
1153 case FFEINFO_basictypeLOGICAL:
1154 switch (ffeinfo_kindtype (ffebld_info (l)))
1155 {
1156 #if FFETARGET_okLOGICAL1
1157 case FFEINFO_kindtypeLOGICAL1:
1158 error = ffetarget_convert_integer4_logical1
1159 (ffebld_cu_ptr_integer4 (u),
1160 ffebld_constant_logical1 (ffebld_conter (l)));
1161 break;
1162 #endif
1163
1164 #if FFETARGET_okLOGICAL2
1165 case FFEINFO_kindtypeLOGICAL2:
1166 error = ffetarget_convert_integer4_logical2
1167 (ffebld_cu_ptr_integer4 (u),
1168 ffebld_constant_logical2 (ffebld_conter (l)));
1169 break;
1170 #endif
1171
1172 #if FFETARGET_okLOGICAL3
1173 case FFEINFO_kindtypeLOGICAL3:
1174 error = ffetarget_convert_integer4_logical3
1175 (ffebld_cu_ptr_integer4 (u),
1176 ffebld_constant_logical3 (ffebld_conter (l)));
1177 break;
1178 #endif
1179
1180 #if FFETARGET_okLOGICAL4
1181 case FFEINFO_kindtypeLOGICAL4:
1182 error = ffetarget_convert_integer4_logical4
1183 (ffebld_cu_ptr_integer4 (u),
1184 ffebld_constant_logical4 (ffebld_conter (l)));
1185 break;
1186 #endif
1187
1188 default:
1189 assert ("INTEGER4/LOGICAL bad source kind type" == NULL);
1190 break;
1191 }
1192 break;
1193
1194 case FFEINFO_basictypeCHARACTER:
1195 error = ffetarget_convert_integer4_character1
1196 (ffebld_cu_ptr_integer4 (u),
1197 ffebld_constant_character1 (ffebld_conter (l)));
1198 break;
1199
1200 case FFEINFO_basictypeHOLLERITH:
1201 error = ffetarget_convert_integer4_hollerith
1202 (ffebld_cu_ptr_integer4 (u),
1203 ffebld_constant_hollerith (ffebld_conter (l)));
1204 break;
1205
1206 case FFEINFO_basictypeTYPELESS:
1207 error = ffetarget_convert_integer4_typeless
1208 (ffebld_cu_ptr_integer4 (u),
1209 ffebld_constant_typeless (ffebld_conter (l)));
1210 break;
1211
1212 default:
1213 assert ("INTEGER4 bad type" == NULL);
1214 break;
1215 }
1216
1217 /* If conversion operation is not implemented, return original expr. */
1218 if (error == FFEBAD_NOCANDO)
1219 return expr;
1220
1221 expr = ffebld_new_conter_with_orig
1222 (ffebld_constant_new_integer4_val
1223 (ffebld_cu_val_integer4 (u)), expr);
1224 break;
1225 #endif
1226
1227 default:
1228 assert ("bad integer kind type" == NULL);
1229 break;
1230 }
1231 break;
1232
1233 case FFEINFO_basictypeLOGICAL:
1234 sz = FFETARGET_charactersizeNONE;
1235 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1236 {
1237 #if FFETARGET_okLOGICAL1
1238 case FFEINFO_kindtypeLOGICAL1:
1239 switch (ffeinfo_basictype (ffebld_info (l)))
1240 {
1241 case FFEINFO_basictypeLOGICAL:
1242 switch (ffeinfo_kindtype (ffebld_info (l)))
1243 {
1244 #if FFETARGET_okLOGICAL2
1245 case FFEINFO_kindtypeLOGICAL2:
1246 error = ffetarget_convert_logical1_logical2
1247 (ffebld_cu_ptr_logical1 (u),
1248 ffebld_constant_logical2 (ffebld_conter (l)));
1249 break;
1250 #endif
1251
1252 #if FFETARGET_okLOGICAL3
1253 case FFEINFO_kindtypeLOGICAL3:
1254 error = ffetarget_convert_logical1_logical3
1255 (ffebld_cu_ptr_logical1 (u),
1256 ffebld_constant_logical3 (ffebld_conter (l)));
1257 break;
1258 #endif
1259
1260 #if FFETARGET_okLOGICAL4
1261 case FFEINFO_kindtypeLOGICAL4:
1262 error = ffetarget_convert_logical1_logical4
1263 (ffebld_cu_ptr_logical1 (u),
1264 ffebld_constant_logical4 (ffebld_conter (l)));
1265 break;
1266 #endif
1267
1268 default:
1269 assert ("LOGICAL1/LOGICAL bad source kind type" == NULL);
1270 break;
1271 }
1272 break;
1273
1274 case FFEINFO_basictypeINTEGER:
1275 switch (ffeinfo_kindtype (ffebld_info (l)))
1276 {
1277 #if FFETARGET_okINTEGER1
1278 case FFEINFO_kindtypeINTEGER1:
1279 error = ffetarget_convert_logical1_integer1
1280 (ffebld_cu_ptr_logical1 (u),
1281 ffebld_constant_integer1 (ffebld_conter (l)));
1282 break;
1283 #endif
1284
1285 #if FFETARGET_okINTEGER2
1286 case FFEINFO_kindtypeINTEGER2:
1287 error = ffetarget_convert_logical1_integer2
1288 (ffebld_cu_ptr_logical1 (u),
1289 ffebld_constant_integer2 (ffebld_conter (l)));
1290 break;
1291 #endif
1292
1293 #if FFETARGET_okINTEGER3
1294 case FFEINFO_kindtypeINTEGER3:
1295 error = ffetarget_convert_logical1_integer3
1296 (ffebld_cu_ptr_logical1 (u),
1297 ffebld_constant_integer3 (ffebld_conter (l)));
1298 break;
1299 #endif
1300
1301 #if FFETARGET_okINTEGER4
1302 case FFEINFO_kindtypeINTEGER4:
1303 error = ffetarget_convert_logical1_integer4
1304 (ffebld_cu_ptr_logical1 (u),
1305 ffebld_constant_integer4 (ffebld_conter (l)));
1306 break;
1307 #endif
1308
1309 default:
1310 assert ("LOGICAL1/INTEGER bad source kind type" == NULL);
1311 break;
1312 }
1313 break;
1314
1315 case FFEINFO_basictypeCHARACTER:
1316 error = ffetarget_convert_logical1_character1
1317 (ffebld_cu_ptr_logical1 (u),
1318 ffebld_constant_character1 (ffebld_conter (l)));
1319 break;
1320
1321 case FFEINFO_basictypeHOLLERITH:
1322 error = ffetarget_convert_logical1_hollerith
1323 (ffebld_cu_ptr_logical1 (u),
1324 ffebld_constant_hollerith (ffebld_conter (l)));
1325 break;
1326
1327 case FFEINFO_basictypeTYPELESS:
1328 error = ffetarget_convert_logical1_typeless
1329 (ffebld_cu_ptr_logical1 (u),
1330 ffebld_constant_typeless (ffebld_conter (l)));
1331 break;
1332
1333 default:
1334 assert ("LOGICAL1 bad type" == NULL);
1335 break;
1336 }
1337
1338 /* If conversion operation is not implemented, return original expr. */
1339 if (error == FFEBAD_NOCANDO)
1340 return expr;
1341
1342 expr = ffebld_new_conter_with_orig
1343 (ffebld_constant_new_logical1_val
1344 (ffebld_cu_val_logical1 (u)), expr);
1345 break;
1346 #endif
1347
1348 #if FFETARGET_okLOGICAL2
1349 case FFEINFO_kindtypeLOGICAL2:
1350 switch (ffeinfo_basictype (ffebld_info (l)))
1351 {
1352 case FFEINFO_basictypeLOGICAL:
1353 switch (ffeinfo_kindtype (ffebld_info (l)))
1354 {
1355 #if FFETARGET_okLOGICAL1
1356 case FFEINFO_kindtypeLOGICAL1:
1357 error = ffetarget_convert_logical2_logical1
1358 (ffebld_cu_ptr_logical2 (u),
1359 ffebld_constant_logical1 (ffebld_conter (l)));
1360 break;
1361 #endif
1362
1363 #if FFETARGET_okLOGICAL3
1364 case FFEINFO_kindtypeLOGICAL3:
1365 error = ffetarget_convert_logical2_logical3
1366 (ffebld_cu_ptr_logical2 (u),
1367 ffebld_constant_logical3 (ffebld_conter (l)));
1368 break;
1369 #endif
1370
1371 #if FFETARGET_okLOGICAL4
1372 case FFEINFO_kindtypeLOGICAL4:
1373 error = ffetarget_convert_logical2_logical4
1374 (ffebld_cu_ptr_logical2 (u),
1375 ffebld_constant_logical4 (ffebld_conter (l)));
1376 break;
1377 #endif
1378
1379 default:
1380 assert ("LOGICAL2/LOGICAL bad source kind type" == NULL);
1381 break;
1382 }
1383 break;
1384
1385 case FFEINFO_basictypeINTEGER:
1386 switch (ffeinfo_kindtype (ffebld_info (l)))
1387 {
1388 #if FFETARGET_okINTEGER1
1389 case FFEINFO_kindtypeINTEGER1:
1390 error = ffetarget_convert_logical2_integer1
1391 (ffebld_cu_ptr_logical2 (u),
1392 ffebld_constant_integer1 (ffebld_conter (l)));
1393 break;
1394 #endif
1395
1396 #if FFETARGET_okINTEGER2
1397 case FFEINFO_kindtypeINTEGER2:
1398 error = ffetarget_convert_logical2_integer2
1399 (ffebld_cu_ptr_logical2 (u),
1400 ffebld_constant_integer2 (ffebld_conter (l)));
1401 break;
1402 #endif
1403
1404 #if FFETARGET_okINTEGER3
1405 case FFEINFO_kindtypeINTEGER3:
1406 error = ffetarget_convert_logical2_integer3
1407 (ffebld_cu_ptr_logical2 (u),
1408 ffebld_constant_integer3 (ffebld_conter (l)));
1409 break;
1410 #endif
1411
1412 #if FFETARGET_okINTEGER4
1413 case FFEINFO_kindtypeINTEGER4:
1414 error = ffetarget_convert_logical2_integer4
1415 (ffebld_cu_ptr_logical2 (u),
1416 ffebld_constant_integer4 (ffebld_conter (l)));
1417 break;
1418 #endif
1419
1420 default:
1421 assert ("LOGICAL2/INTEGER bad source kind type" == NULL);
1422 break;
1423 }
1424 break;
1425
1426 case FFEINFO_basictypeCHARACTER:
1427 error = ffetarget_convert_logical2_character1
1428 (ffebld_cu_ptr_logical2 (u),
1429 ffebld_constant_character1 (ffebld_conter (l)));
1430 break;
1431
1432 case FFEINFO_basictypeHOLLERITH:
1433 error = ffetarget_convert_logical2_hollerith
1434 (ffebld_cu_ptr_logical2 (u),
1435 ffebld_constant_hollerith (ffebld_conter (l)));
1436 break;
1437
1438 case FFEINFO_basictypeTYPELESS:
1439 error = ffetarget_convert_logical2_typeless
1440 (ffebld_cu_ptr_logical2 (u),
1441 ffebld_constant_typeless (ffebld_conter (l)));
1442 break;
1443
1444 default:
1445 assert ("LOGICAL2 bad type" == NULL);
1446 break;
1447 }
1448
1449 /* If conversion operation is not implemented, return original expr. */
1450 if (error == FFEBAD_NOCANDO)
1451 return expr;
1452
1453 expr = ffebld_new_conter_with_orig
1454 (ffebld_constant_new_logical2_val
1455 (ffebld_cu_val_logical2 (u)), expr);
1456 break;
1457 #endif
1458
1459 #if FFETARGET_okLOGICAL3
1460 case FFEINFO_kindtypeLOGICAL3:
1461 switch (ffeinfo_basictype (ffebld_info (l)))
1462 {
1463 case FFEINFO_basictypeLOGICAL:
1464 switch (ffeinfo_kindtype (ffebld_info (l)))
1465 {
1466 #if FFETARGET_okLOGICAL1
1467 case FFEINFO_kindtypeLOGICAL1:
1468 error = ffetarget_convert_logical3_logical1
1469 (ffebld_cu_ptr_logical3 (u),
1470 ffebld_constant_logical1 (ffebld_conter (l)));
1471 break;
1472 #endif
1473
1474 #if FFETARGET_okLOGICAL2
1475 case FFEINFO_kindtypeLOGICAL2:
1476 error = ffetarget_convert_logical3_logical2
1477 (ffebld_cu_ptr_logical3 (u),
1478 ffebld_constant_logical2 (ffebld_conter (l)));
1479 break;
1480 #endif
1481
1482 #if FFETARGET_okLOGICAL4
1483 case FFEINFO_kindtypeLOGICAL4:
1484 error = ffetarget_convert_logical3_logical4
1485 (ffebld_cu_ptr_logical3 (u),
1486 ffebld_constant_logical4 (ffebld_conter (l)));
1487 break;
1488 #endif
1489
1490 default:
1491 assert ("LOGICAL3/LOGICAL bad source kind type" == NULL);
1492 break;
1493 }
1494 break;
1495
1496 case FFEINFO_basictypeINTEGER:
1497 switch (ffeinfo_kindtype (ffebld_info (l)))
1498 {
1499 #if FFETARGET_okINTEGER1
1500 case FFEINFO_kindtypeINTEGER1:
1501 error = ffetarget_convert_logical3_integer1
1502 (ffebld_cu_ptr_logical3 (u),
1503 ffebld_constant_integer1 (ffebld_conter (l)));
1504 break;
1505 #endif
1506
1507 #if FFETARGET_okINTEGER2
1508 case FFEINFO_kindtypeINTEGER2:
1509 error = ffetarget_convert_logical3_integer2
1510 (ffebld_cu_ptr_logical3 (u),
1511 ffebld_constant_integer2 (ffebld_conter (l)));
1512 break;
1513 #endif
1514
1515 #if FFETARGET_okINTEGER3
1516 case FFEINFO_kindtypeINTEGER3:
1517 error = ffetarget_convert_logical3_integer3
1518 (ffebld_cu_ptr_logical3 (u),
1519 ffebld_constant_integer3 (ffebld_conter (l)));
1520 break;
1521 #endif
1522
1523 #if FFETARGET_okINTEGER4
1524 case FFEINFO_kindtypeINTEGER4:
1525 error = ffetarget_convert_logical3_integer4
1526 (ffebld_cu_ptr_logical3 (u),
1527 ffebld_constant_integer4 (ffebld_conter (l)));
1528 break;
1529 #endif
1530
1531 default:
1532 assert ("LOGICAL3/INTEGER bad source kind type" == NULL);
1533 break;
1534 }
1535 break;
1536
1537 case FFEINFO_basictypeCHARACTER:
1538 error = ffetarget_convert_logical3_character1
1539 (ffebld_cu_ptr_logical3 (u),
1540 ffebld_constant_character1 (ffebld_conter (l)));
1541 break;
1542
1543 case FFEINFO_basictypeHOLLERITH:
1544 error = ffetarget_convert_logical3_hollerith
1545 (ffebld_cu_ptr_logical3 (u),
1546 ffebld_constant_hollerith (ffebld_conter (l)));
1547 break;
1548
1549 case FFEINFO_basictypeTYPELESS:
1550 error = ffetarget_convert_logical3_typeless
1551 (ffebld_cu_ptr_logical3 (u),
1552 ffebld_constant_typeless (ffebld_conter (l)));
1553 break;
1554
1555 default:
1556 assert ("LOGICAL3 bad type" == NULL);
1557 break;
1558 }
1559
1560 /* If conversion operation is not implemented, return original expr. */
1561 if (error == FFEBAD_NOCANDO)
1562 return expr;
1563
1564 expr = ffebld_new_conter_with_orig
1565 (ffebld_constant_new_logical3_val
1566 (ffebld_cu_val_logical3 (u)), expr);
1567 break;
1568 #endif
1569
1570 #if FFETARGET_okLOGICAL4
1571 case FFEINFO_kindtypeLOGICAL4:
1572 switch (ffeinfo_basictype (ffebld_info (l)))
1573 {
1574 case FFEINFO_basictypeLOGICAL:
1575 switch (ffeinfo_kindtype (ffebld_info (l)))
1576 {
1577 #if FFETARGET_okLOGICAL1
1578 case FFEINFO_kindtypeLOGICAL1:
1579 error = ffetarget_convert_logical4_logical1
1580 (ffebld_cu_ptr_logical4 (u),
1581 ffebld_constant_logical1 (ffebld_conter (l)));
1582 break;
1583 #endif
1584
1585 #if FFETARGET_okLOGICAL2
1586 case FFEINFO_kindtypeLOGICAL2:
1587 error = ffetarget_convert_logical4_logical2
1588 (ffebld_cu_ptr_logical4 (u),
1589 ffebld_constant_logical2 (ffebld_conter (l)));
1590 break;
1591 #endif
1592
1593 #if FFETARGET_okLOGICAL3
1594 case FFEINFO_kindtypeLOGICAL3:
1595 error = ffetarget_convert_logical4_logical3
1596 (ffebld_cu_ptr_logical4 (u),
1597 ffebld_constant_logical3 (ffebld_conter (l)));
1598 break;
1599 #endif
1600
1601 default:
1602 assert ("LOGICAL4/LOGICAL bad source kind type" == NULL);
1603 break;
1604 }
1605 break;
1606
1607 case FFEINFO_basictypeINTEGER:
1608 switch (ffeinfo_kindtype (ffebld_info (l)))
1609 {
1610 #if FFETARGET_okINTEGER1
1611 case FFEINFO_kindtypeINTEGER1:
1612 error = ffetarget_convert_logical4_integer1
1613 (ffebld_cu_ptr_logical4 (u),
1614 ffebld_constant_integer1 (ffebld_conter (l)));
1615 break;
1616 #endif
1617
1618 #if FFETARGET_okINTEGER2
1619 case FFEINFO_kindtypeINTEGER2:
1620 error = ffetarget_convert_logical4_integer2
1621 (ffebld_cu_ptr_logical4 (u),
1622 ffebld_constant_integer2 (ffebld_conter (l)));
1623 break;
1624 #endif
1625
1626 #if FFETARGET_okINTEGER3
1627 case FFEINFO_kindtypeINTEGER3:
1628 error = ffetarget_convert_logical4_integer3
1629 (ffebld_cu_ptr_logical4 (u),
1630 ffebld_constant_integer3 (ffebld_conter (l)));
1631 break;
1632 #endif
1633
1634 #if FFETARGET_okINTEGER4
1635 case FFEINFO_kindtypeINTEGER4:
1636 error = ffetarget_convert_logical4_integer4
1637 (ffebld_cu_ptr_logical4 (u),
1638 ffebld_constant_integer4 (ffebld_conter (l)));
1639 break;
1640 #endif
1641
1642 default:
1643 assert ("LOGICAL4/INTEGER bad source kind type" == NULL);
1644 break;
1645 }
1646 break;
1647
1648 case FFEINFO_basictypeCHARACTER:
1649 error = ffetarget_convert_logical4_character1
1650 (ffebld_cu_ptr_logical4 (u),
1651 ffebld_constant_character1 (ffebld_conter (l)));
1652 break;
1653
1654 case FFEINFO_basictypeHOLLERITH:
1655 error = ffetarget_convert_logical4_hollerith
1656 (ffebld_cu_ptr_logical4 (u),
1657 ffebld_constant_hollerith (ffebld_conter (l)));
1658 break;
1659
1660 case FFEINFO_basictypeTYPELESS:
1661 error = ffetarget_convert_logical4_typeless
1662 (ffebld_cu_ptr_logical4 (u),
1663 ffebld_constant_typeless (ffebld_conter (l)));
1664 break;
1665
1666 default:
1667 assert ("LOGICAL4 bad type" == NULL);
1668 break;
1669 }
1670
1671 /* If conversion operation is not implemented, return original expr. */
1672 if (error == FFEBAD_NOCANDO)
1673 return expr;
1674
1675 expr = ffebld_new_conter_with_orig
1676 (ffebld_constant_new_logical4_val
1677 (ffebld_cu_val_logical4 (u)), expr);
1678 break;
1679 #endif
1680
1681 default:
1682 assert ("bad logical kind type" == NULL);
1683 break;
1684 }
1685 break;
1686
1687 case FFEINFO_basictypeREAL:
1688 sz = FFETARGET_charactersizeNONE;
1689 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1690 {
1691 #if FFETARGET_okREAL1
1692 case FFEINFO_kindtypeREAL1:
1693 switch (ffeinfo_basictype (ffebld_info (l)))
1694 {
1695 case FFEINFO_basictypeINTEGER:
1696 switch (ffeinfo_kindtype (ffebld_info (l)))
1697 {
1698 #if FFETARGET_okINTEGER1
1699 case FFEINFO_kindtypeINTEGER1:
1700 error = ffetarget_convert_real1_integer1
1701 (ffebld_cu_ptr_real1 (u),
1702 ffebld_constant_integer1 (ffebld_conter (l)));
1703 break;
1704 #endif
1705
1706 #if FFETARGET_okINTEGER2
1707 case FFEINFO_kindtypeINTEGER2:
1708 error = ffetarget_convert_real1_integer2
1709 (ffebld_cu_ptr_real1 (u),
1710 ffebld_constant_integer2 (ffebld_conter (l)));
1711 break;
1712 #endif
1713
1714 #if FFETARGET_okINTEGER3
1715 case FFEINFO_kindtypeINTEGER3:
1716 error = ffetarget_convert_real1_integer3
1717 (ffebld_cu_ptr_real1 (u),
1718 ffebld_constant_integer3 (ffebld_conter (l)));
1719 break;
1720 #endif
1721
1722 #if FFETARGET_okINTEGER4
1723 case FFEINFO_kindtypeINTEGER4:
1724 error = ffetarget_convert_real1_integer4
1725 (ffebld_cu_ptr_real1 (u),
1726 ffebld_constant_integer4 (ffebld_conter (l)));
1727 break;
1728 #endif
1729
1730 default:
1731 assert ("REAL1/INTEGER bad source kind type" == NULL);
1732 break;
1733 }
1734 break;
1735
1736 case FFEINFO_basictypeREAL:
1737 switch (ffeinfo_kindtype (ffebld_info (l)))
1738 {
1739 #if FFETARGET_okREAL2
1740 case FFEINFO_kindtypeREAL2:
1741 error = ffetarget_convert_real1_real2
1742 (ffebld_cu_ptr_real1 (u),
1743 ffebld_constant_real2 (ffebld_conter (l)));
1744 break;
1745 #endif
1746
1747 #if FFETARGET_okREAL3
1748 case FFEINFO_kindtypeREAL3:
1749 error = ffetarget_convert_real1_real3
1750 (ffebld_cu_ptr_real1 (u),
1751 ffebld_constant_real3 (ffebld_conter (l)));
1752 break;
1753 #endif
1754
1755 #if FFETARGET_okREAL4
1756 case FFEINFO_kindtypeREAL4:
1757 error = ffetarget_convert_real1_real4
1758 (ffebld_cu_ptr_real1 (u),
1759 ffebld_constant_real4 (ffebld_conter (l)));
1760 break;
1761 #endif
1762
1763 default:
1764 assert ("REAL1/REAL bad source kind type" == NULL);
1765 break;
1766 }
1767 break;
1768
1769 case FFEINFO_basictypeCOMPLEX:
1770 switch (ffeinfo_kindtype (ffebld_info (l)))
1771 {
1772 #if FFETARGET_okCOMPLEX1
1773 case FFEINFO_kindtypeREAL1:
1774 error = ffetarget_convert_real1_complex1
1775 (ffebld_cu_ptr_real1 (u),
1776 ffebld_constant_complex1 (ffebld_conter (l)));
1777 break;
1778 #endif
1779
1780 #if FFETARGET_okCOMPLEX2
1781 case FFEINFO_kindtypeREAL2:
1782 error = ffetarget_convert_real1_complex2
1783 (ffebld_cu_ptr_real1 (u),
1784 ffebld_constant_complex2 (ffebld_conter (l)));
1785 break;
1786 #endif
1787
1788 #if FFETARGET_okCOMPLEX3
1789 case FFEINFO_kindtypeREAL3:
1790 error = ffetarget_convert_real1_complex3
1791 (ffebld_cu_ptr_real1 (u),
1792 ffebld_constant_complex3 (ffebld_conter (l)));
1793 break;
1794 #endif
1795
1796 #if FFETARGET_okCOMPLEX4
1797 case FFEINFO_kindtypeREAL4:
1798 error = ffetarget_convert_real1_complex4
1799 (ffebld_cu_ptr_real1 (u),
1800 ffebld_constant_complex4 (ffebld_conter (l)));
1801 break;
1802 #endif
1803
1804 default:
1805 assert ("REAL1/COMPLEX bad source kind type" == NULL);
1806 break;
1807 }
1808 break;
1809
1810 case FFEINFO_basictypeCHARACTER:
1811 error = ffetarget_convert_real1_character1
1812 (ffebld_cu_ptr_real1 (u),
1813 ffebld_constant_character1 (ffebld_conter (l)));
1814 break;
1815
1816 case FFEINFO_basictypeHOLLERITH:
1817 error = ffetarget_convert_real1_hollerith
1818 (ffebld_cu_ptr_real1 (u),
1819 ffebld_constant_hollerith (ffebld_conter (l)));
1820 break;
1821
1822 case FFEINFO_basictypeTYPELESS:
1823 error = ffetarget_convert_real1_typeless
1824 (ffebld_cu_ptr_real1 (u),
1825 ffebld_constant_typeless (ffebld_conter (l)));
1826 break;
1827
1828 default:
1829 assert ("REAL1 bad type" == NULL);
1830 break;
1831 }
1832
1833 /* If conversion operation is not implemented, return original expr. */
1834 if (error == FFEBAD_NOCANDO)
1835 return expr;
1836
1837 expr = ffebld_new_conter_with_orig
1838 (ffebld_constant_new_real1_val
1839 (ffebld_cu_val_real1 (u)), expr);
1840 break;
1841 #endif
1842
1843 #if FFETARGET_okREAL2
1844 case FFEINFO_kindtypeREAL2:
1845 switch (ffeinfo_basictype (ffebld_info (l)))
1846 {
1847 case FFEINFO_basictypeINTEGER:
1848 switch (ffeinfo_kindtype (ffebld_info (l)))
1849 {
1850 #if FFETARGET_okINTEGER1
1851 case FFEINFO_kindtypeINTEGER1:
1852 error = ffetarget_convert_real2_integer1
1853 (ffebld_cu_ptr_real2 (u),
1854 ffebld_constant_integer1 (ffebld_conter (l)));
1855 break;
1856 #endif
1857
1858 #if FFETARGET_okINTEGER2
1859 case FFEINFO_kindtypeINTEGER2:
1860 error = ffetarget_convert_real2_integer2
1861 (ffebld_cu_ptr_real2 (u),
1862 ffebld_constant_integer2 (ffebld_conter (l)));
1863 break;
1864 #endif
1865
1866 #if FFETARGET_okINTEGER3
1867 case FFEINFO_kindtypeINTEGER3:
1868 error = ffetarget_convert_real2_integer3
1869 (ffebld_cu_ptr_real2 (u),
1870 ffebld_constant_integer3 (ffebld_conter (l)));
1871 break;
1872 #endif
1873
1874 #if FFETARGET_okINTEGER4
1875 case FFEINFO_kindtypeINTEGER4:
1876 error = ffetarget_convert_real2_integer4
1877 (ffebld_cu_ptr_real2 (u),
1878 ffebld_constant_integer4 (ffebld_conter (l)));
1879 break;
1880 #endif
1881
1882 default:
1883 assert ("REAL2/INTEGER bad source kind type" == NULL);
1884 break;
1885 }
1886 break;
1887
1888 case FFEINFO_basictypeREAL:
1889 switch (ffeinfo_kindtype (ffebld_info (l)))
1890 {
1891 #if FFETARGET_okREAL1
1892 case FFEINFO_kindtypeREAL1:
1893 error = ffetarget_convert_real2_real1
1894 (ffebld_cu_ptr_real2 (u),
1895 ffebld_constant_real1 (ffebld_conter (l)));
1896 break;
1897 #endif
1898
1899 #if FFETARGET_okREAL3
1900 case FFEINFO_kindtypeREAL3:
1901 error = ffetarget_convert_real2_real3
1902 (ffebld_cu_ptr_real2 (u),
1903 ffebld_constant_real3 (ffebld_conter (l)));
1904 break;
1905 #endif
1906
1907 #if FFETARGET_okREAL4
1908 case FFEINFO_kindtypeREAL4:
1909 error = ffetarget_convert_real2_real4
1910 (ffebld_cu_ptr_real2 (u),
1911 ffebld_constant_real4 (ffebld_conter (l)));
1912 break;
1913 #endif
1914
1915 default:
1916 assert ("REAL2/REAL bad source kind type" == NULL);
1917 break;
1918 }
1919 break;
1920
1921 case FFEINFO_basictypeCOMPLEX:
1922 switch (ffeinfo_kindtype (ffebld_info (l)))
1923 {
1924 #if FFETARGET_okCOMPLEX1
1925 case FFEINFO_kindtypeREAL1:
1926 error = ffetarget_convert_real2_complex1
1927 (ffebld_cu_ptr_real2 (u),
1928 ffebld_constant_complex1 (ffebld_conter (l)));
1929 break;
1930 #endif
1931
1932 #if FFETARGET_okCOMPLEX2
1933 case FFEINFO_kindtypeREAL2:
1934 error = ffetarget_convert_real2_complex2
1935 (ffebld_cu_ptr_real2 (u),
1936 ffebld_constant_complex2 (ffebld_conter (l)));
1937 break;
1938 #endif
1939
1940 #if FFETARGET_okCOMPLEX3
1941 case FFEINFO_kindtypeREAL3:
1942 error = ffetarget_convert_real2_complex3
1943 (ffebld_cu_ptr_real2 (u),
1944 ffebld_constant_complex3 (ffebld_conter (l)));
1945 break;
1946 #endif
1947
1948 #if FFETARGET_okCOMPLEX4
1949 case FFEINFO_kindtypeREAL4:
1950 error = ffetarget_convert_real2_complex4
1951 (ffebld_cu_ptr_real2 (u),
1952 ffebld_constant_complex4 (ffebld_conter (l)));
1953 break;
1954 #endif
1955
1956 default:
1957 assert ("REAL2/COMPLEX bad source kind type" == NULL);
1958 break;
1959 }
1960 break;
1961
1962 case FFEINFO_basictypeCHARACTER:
1963 error = ffetarget_convert_real2_character1
1964 (ffebld_cu_ptr_real2 (u),
1965 ffebld_constant_character1 (ffebld_conter (l)));
1966 break;
1967
1968 case FFEINFO_basictypeHOLLERITH:
1969 error = ffetarget_convert_real2_hollerith
1970 (ffebld_cu_ptr_real2 (u),
1971 ffebld_constant_hollerith (ffebld_conter (l)));
1972 break;
1973
1974 case FFEINFO_basictypeTYPELESS:
1975 error = ffetarget_convert_real2_typeless
1976 (ffebld_cu_ptr_real2 (u),
1977 ffebld_constant_typeless (ffebld_conter (l)));
1978 break;
1979
1980 default:
1981 assert ("REAL2 bad type" == NULL);
1982 break;
1983 }
1984
1985 /* If conversion operation is not implemented, return original expr. */
1986 if (error == FFEBAD_NOCANDO)
1987 return expr;
1988
1989 expr = ffebld_new_conter_with_orig
1990 (ffebld_constant_new_real2_val
1991 (ffebld_cu_val_real2 (u)), expr);
1992 break;
1993 #endif
1994
1995 #if FFETARGET_okREAL3
1996 case FFEINFO_kindtypeREAL3:
1997 switch (ffeinfo_basictype (ffebld_info (l)))
1998 {
1999 case FFEINFO_basictypeINTEGER:
2000 switch (ffeinfo_kindtype (ffebld_info (l)))
2001 {
2002 #if FFETARGET_okINTEGER1
2003 case FFEINFO_kindtypeINTEGER1:
2004 error = ffetarget_convert_real3_integer1
2005 (ffebld_cu_ptr_real3 (u),
2006 ffebld_constant_integer1 (ffebld_conter (l)));
2007 break;
2008 #endif
2009
2010 #if FFETARGET_okINTEGER2
2011 case FFEINFO_kindtypeINTEGER2:
2012 error = ffetarget_convert_real3_integer2
2013 (ffebld_cu_ptr_real3 (u),
2014 ffebld_constant_integer2 (ffebld_conter (l)));
2015 break;
2016 #endif
2017
2018 #if FFETARGET_okINTEGER3
2019 case FFEINFO_kindtypeINTEGER3:
2020 error = ffetarget_convert_real3_integer3
2021 (ffebld_cu_ptr_real3 (u),
2022 ffebld_constant_integer3 (ffebld_conter (l)));
2023 break;
2024 #endif
2025
2026 #if FFETARGET_okINTEGER4
2027 case FFEINFO_kindtypeINTEGER4:
2028 error = ffetarget_convert_real3_integer4
2029 (ffebld_cu_ptr_real3 (u),
2030 ffebld_constant_integer4 (ffebld_conter (l)));
2031 break;
2032 #endif
2033
2034 default:
2035 assert ("REAL3/INTEGER bad source kind type" == NULL);
2036 break;
2037 }
2038 break;
2039
2040 case FFEINFO_basictypeREAL:
2041 switch (ffeinfo_kindtype (ffebld_info (l)))
2042 {
2043 #if FFETARGET_okREAL1
2044 case FFEINFO_kindtypeREAL1:
2045 error = ffetarget_convert_real3_real1
2046 (ffebld_cu_ptr_real3 (u),
2047 ffebld_constant_real1 (ffebld_conter (l)));
2048 break;
2049 #endif
2050
2051 #if FFETARGET_okREAL2
2052 case FFEINFO_kindtypeREAL2:
2053 error = ffetarget_convert_real3_real2
2054 (ffebld_cu_ptr_real3 (u),
2055 ffebld_constant_real2 (ffebld_conter (l)));
2056 break;
2057 #endif
2058
2059 #if FFETARGET_okREAL4
2060 case FFEINFO_kindtypeREAL4:
2061 error = ffetarget_convert_real3_real4
2062 (ffebld_cu_ptr_real3 (u),
2063 ffebld_constant_real4 (ffebld_conter (l)));
2064 break;
2065 #endif
2066
2067 default:
2068 assert ("REAL3/REAL bad source kind type" == NULL);
2069 break;
2070 }
2071 break;
2072
2073 case FFEINFO_basictypeCOMPLEX:
2074 switch (ffeinfo_kindtype (ffebld_info (l)))
2075 {
2076 #if FFETARGET_okCOMPLEX1
2077 case FFEINFO_kindtypeREAL1:
2078 error = ffetarget_convert_real3_complex1
2079 (ffebld_cu_ptr_real3 (u),
2080 ffebld_constant_complex1 (ffebld_conter (l)));
2081 break;
2082 #endif
2083
2084 #if FFETARGET_okCOMPLEX2
2085 case FFEINFO_kindtypeREAL2:
2086 error = ffetarget_convert_real3_complex2
2087 (ffebld_cu_ptr_real3 (u),
2088 ffebld_constant_complex2 (ffebld_conter (l)));
2089 break;
2090 #endif
2091
2092 #if FFETARGET_okCOMPLEX3
2093 case FFEINFO_kindtypeREAL3:
2094 error = ffetarget_convert_real3_complex3
2095 (ffebld_cu_ptr_real3 (u),
2096 ffebld_constant_complex3 (ffebld_conter (l)));
2097 break;
2098 #endif
2099
2100 #if FFETARGET_okCOMPLEX4
2101 case FFEINFO_kindtypeREAL4:
2102 error = ffetarget_convert_real3_complex4
2103 (ffebld_cu_ptr_real3 (u),
2104 ffebld_constant_complex4 (ffebld_conter (l)));
2105 break;
2106 #endif
2107
2108 default:
2109 assert ("REAL3/COMPLEX bad source kind type" == NULL);
2110 break;
2111 }
2112 break;
2113
2114 case FFEINFO_basictypeCHARACTER:
2115 error = ffetarget_convert_real3_character1
2116 (ffebld_cu_ptr_real3 (u),
2117 ffebld_constant_character1 (ffebld_conter (l)));
2118 break;
2119
2120 case FFEINFO_basictypeHOLLERITH:
2121 error = ffetarget_convert_real3_hollerith
2122 (ffebld_cu_ptr_real3 (u),
2123 ffebld_constant_hollerith (ffebld_conter (l)));
2124 break;
2125
2126 case FFEINFO_basictypeTYPELESS:
2127 error = ffetarget_convert_real3_typeless
2128 (ffebld_cu_ptr_real3 (u),
2129 ffebld_constant_typeless (ffebld_conter (l)));
2130 break;
2131
2132 default:
2133 assert ("REAL3 bad type" == NULL);
2134 break;
2135 }
2136
2137 /* If conversion operation is not implemented, return original expr. */
2138 if (error == FFEBAD_NOCANDO)
2139 return expr;
2140
2141 expr = ffebld_new_conter_with_orig
2142 (ffebld_constant_new_real3_val
2143 (ffebld_cu_val_real3 (u)), expr);
2144 break;
2145 #endif
2146
2147 #if FFETARGET_okREAL4
2148 case FFEINFO_kindtypeREAL4:
2149 switch (ffeinfo_basictype (ffebld_info (l)))
2150 {
2151 case FFEINFO_basictypeINTEGER:
2152 switch (ffeinfo_kindtype (ffebld_info (l)))
2153 {
2154 #if FFETARGET_okINTEGER1
2155 case FFEINFO_kindtypeINTEGER1:
2156 error = ffetarget_convert_real4_integer1
2157 (ffebld_cu_ptr_real4 (u),
2158 ffebld_constant_integer1 (ffebld_conter (l)));
2159 break;
2160 #endif
2161
2162 #if FFETARGET_okINTEGER2
2163 case FFEINFO_kindtypeINTEGER2:
2164 error = ffetarget_convert_real4_integer2
2165 (ffebld_cu_ptr_real4 (u),
2166 ffebld_constant_integer2 (ffebld_conter (l)));
2167 break;
2168 #endif
2169
2170 #if FFETARGET_okINTEGER3
2171 case FFEINFO_kindtypeINTEGER3:
2172 error = ffetarget_convert_real4_integer3
2173 (ffebld_cu_ptr_real4 (u),
2174 ffebld_constant_integer3 (ffebld_conter (l)));
2175 break;
2176 #endif
2177
2178 #if FFETARGET_okINTEGER4
2179 case FFEINFO_kindtypeINTEGER4:
2180 error = ffetarget_convert_real4_integer4
2181 (ffebld_cu_ptr_real4 (u),
2182 ffebld_constant_integer4 (ffebld_conter (l)));
2183 break;
2184 #endif
2185
2186 default:
2187 assert ("REAL4/INTEGER bad source kind type" == NULL);
2188 break;
2189 }
2190 break;
2191
2192 case FFEINFO_basictypeREAL:
2193 switch (ffeinfo_kindtype (ffebld_info (l)))
2194 {
2195 #if FFETARGET_okREAL1
2196 case FFEINFO_kindtypeREAL1:
2197 error = ffetarget_convert_real4_real1
2198 (ffebld_cu_ptr_real4 (u),
2199 ffebld_constant_real1 (ffebld_conter (l)));
2200 break;
2201 #endif
2202
2203 #if FFETARGET_okREAL2
2204 case FFEINFO_kindtypeREAL2:
2205 error = ffetarget_convert_real4_real2
2206 (ffebld_cu_ptr_real4 (u),
2207 ffebld_constant_real2 (ffebld_conter (l)));
2208 break;
2209 #endif
2210
2211 #if FFETARGET_okREAL3
2212 case FFEINFO_kindtypeREAL3:
2213 error = ffetarget_convert_real4_real3
2214 (ffebld_cu_ptr_real4 (u),
2215 ffebld_constant_real3 (ffebld_conter (l)));
2216 break;
2217 #endif
2218
2219 default:
2220 assert ("REAL4/REAL bad source kind type" == NULL);
2221 break;
2222 }
2223 break;
2224
2225 case FFEINFO_basictypeCOMPLEX:
2226 switch (ffeinfo_kindtype (ffebld_info (l)))
2227 {
2228 #if FFETARGET_okCOMPLEX1
2229 case FFEINFO_kindtypeREAL1:
2230 error = ffetarget_convert_real4_complex1
2231 (ffebld_cu_ptr_real4 (u),
2232 ffebld_constant_complex1 (ffebld_conter (l)));
2233 break;
2234 #endif
2235
2236 #if FFETARGET_okCOMPLEX2
2237 case FFEINFO_kindtypeREAL2:
2238 error = ffetarget_convert_real4_complex2
2239 (ffebld_cu_ptr_real4 (u),
2240 ffebld_constant_complex2 (ffebld_conter (l)));
2241 break;
2242 #endif
2243
2244 #if FFETARGET_okCOMPLEX3
2245 case FFEINFO_kindtypeREAL3:
2246 error = ffetarget_convert_real4_complex3
2247 (ffebld_cu_ptr_real4 (u),
2248 ffebld_constant_complex3 (ffebld_conter (l)));
2249 break;
2250 #endif
2251
2252 #if FFETARGET_okCOMPLEX4
2253 case FFEINFO_kindtypeREAL4:
2254 error = ffetarget_convert_real4_complex4
2255 (ffebld_cu_ptr_real4 (u),
2256 ffebld_constant_complex4 (ffebld_conter (l)));
2257 break;
2258 #endif
2259
2260 default:
2261 assert ("REAL4/COMPLEX bad source kind type" == NULL);
2262 break;
2263 }
2264 break;
2265
2266 case FFEINFO_basictypeCHARACTER:
2267 error = ffetarget_convert_real4_character1
2268 (ffebld_cu_ptr_real4 (u),
2269 ffebld_constant_character1 (ffebld_conter (l)));
2270 break;
2271
2272 case FFEINFO_basictypeHOLLERITH:
2273 error = ffetarget_convert_real4_hollerith
2274 (ffebld_cu_ptr_real4 (u),
2275 ffebld_constant_hollerith (ffebld_conter (l)));
2276 break;
2277
2278 case FFEINFO_basictypeTYPELESS:
2279 error = ffetarget_convert_real4_typeless
2280 (ffebld_cu_ptr_real4 (u),
2281 ffebld_constant_typeless (ffebld_conter (l)));
2282 break;
2283
2284 default:
2285 assert ("REAL4 bad type" == NULL);
2286 break;
2287 }
2288
2289 /* If conversion operation is not implemented, return original expr. */
2290 if (error == FFEBAD_NOCANDO)
2291 return expr;
2292
2293 expr = ffebld_new_conter_with_orig
2294 (ffebld_constant_new_real4_val
2295 (ffebld_cu_val_real4 (u)), expr);
2296 break;
2297 #endif
2298
2299 default:
2300 assert ("bad real kind type" == NULL);
2301 break;
2302 }
2303 break;
2304
2305 case FFEINFO_basictypeCOMPLEX:
2306 sz = FFETARGET_charactersizeNONE;
2307 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2308 {
2309 #if FFETARGET_okCOMPLEX1
2310 case FFEINFO_kindtypeREAL1:
2311 switch (ffeinfo_basictype (ffebld_info (l)))
2312 {
2313 case FFEINFO_basictypeINTEGER:
2314 switch (ffeinfo_kindtype (ffebld_info (l)))
2315 {
2316 #if FFETARGET_okINTEGER1
2317 case FFEINFO_kindtypeINTEGER1:
2318 error = ffetarget_convert_complex1_integer1
2319 (ffebld_cu_ptr_complex1 (u),
2320 ffebld_constant_integer1 (ffebld_conter (l)));
2321 break;
2322 #endif
2323
2324 #if FFETARGET_okINTEGER2
2325 case FFEINFO_kindtypeINTEGER2:
2326 error = ffetarget_convert_complex1_integer2
2327 (ffebld_cu_ptr_complex1 (u),
2328 ffebld_constant_integer2 (ffebld_conter (l)));
2329 break;
2330 #endif
2331
2332 #if FFETARGET_okINTEGER3
2333 case FFEINFO_kindtypeINTEGER3:
2334 error = ffetarget_convert_complex1_integer3
2335 (ffebld_cu_ptr_complex1 (u),
2336 ffebld_constant_integer3 (ffebld_conter (l)));
2337 break;
2338 #endif
2339
2340 #if FFETARGET_okINTEGER4
2341 case FFEINFO_kindtypeINTEGER4:
2342 error = ffetarget_convert_complex1_integer4
2343 (ffebld_cu_ptr_complex1 (u),
2344 ffebld_constant_integer4 (ffebld_conter (l)));
2345 break;
2346 #endif
2347
2348 default:
2349 assert ("COMPLEX1/INTEGER bad source kind type" == NULL);
2350 break;
2351 }
2352 break;
2353
2354 case FFEINFO_basictypeREAL:
2355 switch (ffeinfo_kindtype (ffebld_info (l)))
2356 {
2357 #if FFETARGET_okREAL1
2358 case FFEINFO_kindtypeREAL1:
2359 error = ffetarget_convert_complex1_real1
2360 (ffebld_cu_ptr_complex1 (u),
2361 ffebld_constant_real1 (ffebld_conter (l)));
2362 break;
2363 #endif
2364
2365 #if FFETARGET_okREAL2
2366 case FFEINFO_kindtypeREAL2:
2367 error = ffetarget_convert_complex1_real2
2368 (ffebld_cu_ptr_complex1 (u),
2369 ffebld_constant_real2 (ffebld_conter (l)));
2370 break;
2371 #endif
2372
2373 #if FFETARGET_okREAL3
2374 case FFEINFO_kindtypeREAL3:
2375 error = ffetarget_convert_complex1_real3
2376 (ffebld_cu_ptr_complex1 (u),
2377 ffebld_constant_real3 (ffebld_conter (l)));
2378 break;
2379 #endif
2380
2381 #if FFETARGET_okREAL4
2382 case FFEINFO_kindtypeREAL4:
2383 error = ffetarget_convert_complex1_real4
2384 (ffebld_cu_ptr_complex1 (u),
2385 ffebld_constant_real4 (ffebld_conter (l)));
2386 break;
2387 #endif
2388
2389 default:
2390 assert ("COMPLEX1/REAL bad source kind type" == NULL);
2391 break;
2392 }
2393 break;
2394
2395 case FFEINFO_basictypeCOMPLEX:
2396 switch (ffeinfo_kindtype (ffebld_info (l)))
2397 {
2398 #if FFETARGET_okCOMPLEX2
2399 case FFEINFO_kindtypeREAL2:
2400 error = ffetarget_convert_complex1_complex2
2401 (ffebld_cu_ptr_complex1 (u),
2402 ffebld_constant_complex2 (ffebld_conter (l)));
2403 break;
2404 #endif
2405
2406 #if FFETARGET_okCOMPLEX3
2407 case FFEINFO_kindtypeREAL3:
2408 error = ffetarget_convert_complex1_complex3
2409 (ffebld_cu_ptr_complex1 (u),
2410 ffebld_constant_complex3 (ffebld_conter (l)));
2411 break;
2412 #endif
2413
2414 #if FFETARGET_okCOMPLEX4
2415 case FFEINFO_kindtypeREAL4:
2416 error = ffetarget_convert_complex1_complex4
2417 (ffebld_cu_ptr_complex1 (u),
2418 ffebld_constant_complex4 (ffebld_conter (l)));
2419 break;
2420 #endif
2421
2422 default:
2423 assert ("COMPLEX1/COMPLEX bad source kind type" == NULL);
2424 break;
2425 }
2426 break;
2427
2428 case FFEINFO_basictypeCHARACTER:
2429 error = ffetarget_convert_complex1_character1
2430 (ffebld_cu_ptr_complex1 (u),
2431 ffebld_constant_character1 (ffebld_conter (l)));
2432 break;
2433
2434 case FFEINFO_basictypeHOLLERITH:
2435 error = ffetarget_convert_complex1_hollerith
2436 (ffebld_cu_ptr_complex1 (u),
2437 ffebld_constant_hollerith (ffebld_conter (l)));
2438 break;
2439
2440 case FFEINFO_basictypeTYPELESS:
2441 error = ffetarget_convert_complex1_typeless
2442 (ffebld_cu_ptr_complex1 (u),
2443 ffebld_constant_typeless (ffebld_conter (l)));
2444 break;
2445
2446 default:
2447 assert ("COMPLEX1 bad type" == NULL);
2448 break;
2449 }
2450
2451 /* If conversion operation is not implemented, return original expr. */
2452 if (error == FFEBAD_NOCANDO)
2453 return expr;
2454
2455 expr = ffebld_new_conter_with_orig
2456 (ffebld_constant_new_complex1_val
2457 (ffebld_cu_val_complex1 (u)), expr);
2458 break;
2459 #endif
2460
2461 #if FFETARGET_okCOMPLEX2
2462 case FFEINFO_kindtypeREAL2:
2463 switch (ffeinfo_basictype (ffebld_info (l)))
2464 {
2465 case FFEINFO_basictypeINTEGER:
2466 switch (ffeinfo_kindtype (ffebld_info (l)))
2467 {
2468 #if FFETARGET_okINTEGER1
2469 case FFEINFO_kindtypeINTEGER1:
2470 error = ffetarget_convert_complex2_integer1
2471 (ffebld_cu_ptr_complex2 (u),
2472 ffebld_constant_integer1 (ffebld_conter (l)));
2473 break;
2474 #endif
2475
2476 #if FFETARGET_okINTEGER2
2477 case FFEINFO_kindtypeINTEGER2:
2478 error = ffetarget_convert_complex2_integer2
2479 (ffebld_cu_ptr_complex2 (u),
2480 ffebld_constant_integer2 (ffebld_conter (l)));
2481 break;
2482 #endif
2483
2484 #if FFETARGET_okINTEGER3
2485 case FFEINFO_kindtypeINTEGER3:
2486 error = ffetarget_convert_complex2_integer3
2487 (ffebld_cu_ptr_complex2 (u),
2488 ffebld_constant_integer3 (ffebld_conter (l)));
2489 break;
2490 #endif
2491
2492 #if FFETARGET_okINTEGER4
2493 case FFEINFO_kindtypeINTEGER4:
2494 error = ffetarget_convert_complex2_integer4
2495 (ffebld_cu_ptr_complex2 (u),
2496 ffebld_constant_integer4 (ffebld_conter (l)));
2497 break;
2498 #endif
2499
2500 default:
2501 assert ("COMPLEX2/INTEGER bad source kind type" == NULL);
2502 break;
2503 }
2504 break;
2505
2506 case FFEINFO_basictypeREAL:
2507 switch (ffeinfo_kindtype (ffebld_info (l)))
2508 {
2509 #if FFETARGET_okREAL1
2510 case FFEINFO_kindtypeREAL1:
2511 error = ffetarget_convert_complex2_real1
2512 (ffebld_cu_ptr_complex2 (u),
2513 ffebld_constant_real1 (ffebld_conter (l)));
2514 break;
2515 #endif
2516
2517 #if FFETARGET_okREAL2
2518 case FFEINFO_kindtypeREAL2:
2519 error = ffetarget_convert_complex2_real2
2520 (ffebld_cu_ptr_complex2 (u),
2521 ffebld_constant_real2 (ffebld_conter (l)));
2522 break;
2523 #endif
2524
2525 #if FFETARGET_okREAL3
2526 case FFEINFO_kindtypeREAL3:
2527 error = ffetarget_convert_complex2_real3
2528 (ffebld_cu_ptr_complex2 (u),
2529 ffebld_constant_real3 (ffebld_conter (l)));
2530 break;
2531 #endif
2532
2533 #if FFETARGET_okREAL4
2534 case FFEINFO_kindtypeREAL4:
2535 error = ffetarget_convert_complex2_real4
2536 (ffebld_cu_ptr_complex2 (u),
2537 ffebld_constant_real4 (ffebld_conter (l)));
2538 break;
2539 #endif
2540
2541 default:
2542 assert ("COMPLEX2/REAL bad source kind type" == NULL);
2543 break;
2544 }
2545 break;
2546
2547 case FFEINFO_basictypeCOMPLEX:
2548 switch (ffeinfo_kindtype (ffebld_info (l)))
2549 {
2550 #if FFETARGET_okCOMPLEX1
2551 case FFEINFO_kindtypeREAL1:
2552 error = ffetarget_convert_complex2_complex1
2553 (ffebld_cu_ptr_complex2 (u),
2554 ffebld_constant_complex1 (ffebld_conter (l)));
2555 break;
2556 #endif
2557
2558 #if FFETARGET_okCOMPLEX3
2559 case FFEINFO_kindtypeREAL3:
2560 error = ffetarget_convert_complex2_complex3
2561 (ffebld_cu_ptr_complex2 (u),
2562 ffebld_constant_complex3 (ffebld_conter (l)));
2563 break;
2564 #endif
2565
2566 #if FFETARGET_okCOMPLEX4
2567 case FFEINFO_kindtypeREAL4:
2568 error = ffetarget_convert_complex2_complex4
2569 (ffebld_cu_ptr_complex2 (u),
2570 ffebld_constant_complex4 (ffebld_conter (l)));
2571 break;
2572 #endif
2573
2574 default:
2575 assert ("COMPLEX2/COMPLEX bad source kind type" == NULL);
2576 break;
2577 }
2578 break;
2579
2580 case FFEINFO_basictypeCHARACTER:
2581 error = ffetarget_convert_complex2_character1
2582 (ffebld_cu_ptr_complex2 (u),
2583 ffebld_constant_character1 (ffebld_conter (l)));
2584 break;
2585
2586 case FFEINFO_basictypeHOLLERITH:
2587 error = ffetarget_convert_complex2_hollerith
2588 (ffebld_cu_ptr_complex2 (u),
2589 ffebld_constant_hollerith (ffebld_conter (l)));
2590 break;
2591
2592 case FFEINFO_basictypeTYPELESS:
2593 error = ffetarget_convert_complex2_typeless
2594 (ffebld_cu_ptr_complex2 (u),
2595 ffebld_constant_typeless (ffebld_conter (l)));
2596 break;
2597
2598 default:
2599 assert ("COMPLEX2 bad type" == NULL);
2600 break;
2601 }
2602
2603 /* If conversion operation is not implemented, return original expr. */
2604 if (error == FFEBAD_NOCANDO)
2605 return expr;
2606
2607 expr = ffebld_new_conter_with_orig
2608 (ffebld_constant_new_complex2_val
2609 (ffebld_cu_val_complex2 (u)), expr);
2610 break;
2611 #endif
2612
2613 #if FFETARGET_okCOMPLEX3
2614 case FFEINFO_kindtypeREAL3:
2615 switch (ffeinfo_basictype (ffebld_info (l)))
2616 {
2617 case FFEINFO_basictypeINTEGER:
2618 switch (ffeinfo_kindtype (ffebld_info (l)))
2619 {
2620 #if FFETARGET_okINTEGER1
2621 case FFEINFO_kindtypeINTEGER1:
2622 error = ffetarget_convert_complex3_integer1
2623 (ffebld_cu_ptr_complex3 (u),
2624 ffebld_constant_integer1 (ffebld_conter (l)));
2625 break;
2626 #endif
2627
2628 #if FFETARGET_okINTEGER2
2629 case FFEINFO_kindtypeINTEGER2:
2630 error = ffetarget_convert_complex3_integer2
2631 (ffebld_cu_ptr_complex3 (u),
2632 ffebld_constant_integer2 (ffebld_conter (l)));
2633 break;
2634 #endif
2635
2636 #if FFETARGET_okINTEGER3
2637 case FFEINFO_kindtypeINTEGER3:
2638 error = ffetarget_convert_complex3_integer3
2639 (ffebld_cu_ptr_complex3 (u),
2640 ffebld_constant_integer3 (ffebld_conter (l)));
2641 break;
2642 #endif
2643
2644 #if FFETARGET_okINTEGER4
2645 case FFEINFO_kindtypeINTEGER4:
2646 error = ffetarget_convert_complex3_integer4
2647 (ffebld_cu_ptr_complex3 (u),
2648 ffebld_constant_integer4 (ffebld_conter (l)));
2649 break;
2650 #endif
2651
2652 default:
2653 assert ("COMPLEX3/INTEGER bad source kind type" == NULL);
2654 break;
2655 }
2656 break;
2657
2658 case FFEINFO_basictypeREAL:
2659 switch (ffeinfo_kindtype (ffebld_info (l)))
2660 {
2661 #if FFETARGET_okREAL1
2662 case FFEINFO_kindtypeREAL1:
2663 error = ffetarget_convert_complex3_real1
2664 (ffebld_cu_ptr_complex3 (u),
2665 ffebld_constant_real1 (ffebld_conter (l)));
2666 break;
2667 #endif
2668
2669 #if FFETARGET_okREAL2
2670 case FFEINFO_kindtypeREAL2:
2671 error = ffetarget_convert_complex3_real2
2672 (ffebld_cu_ptr_complex3 (u),
2673 ffebld_constant_real2 (ffebld_conter (l)));
2674 break;
2675 #endif
2676
2677 #if FFETARGET_okREAL3
2678 case FFEINFO_kindtypeREAL3:
2679 error = ffetarget_convert_complex3_real3
2680 (ffebld_cu_ptr_complex3 (u),
2681 ffebld_constant_real3 (ffebld_conter (l)));
2682 break;
2683 #endif
2684
2685 #if FFETARGET_okREAL4
2686 case FFEINFO_kindtypeREAL4:
2687 error = ffetarget_convert_complex3_real4
2688 (ffebld_cu_ptr_complex3 (u),
2689 ffebld_constant_real4 (ffebld_conter (l)));
2690 break;
2691 #endif
2692
2693 default:
2694 assert ("COMPLEX3/REAL bad source kind type" == NULL);
2695 break;
2696 }
2697 break;
2698
2699 case FFEINFO_basictypeCOMPLEX:
2700 switch (ffeinfo_kindtype (ffebld_info (l)))
2701 {
2702 #if FFETARGET_okCOMPLEX1
2703 case FFEINFO_kindtypeREAL1:
2704 error = ffetarget_convert_complex3_complex1
2705 (ffebld_cu_ptr_complex3 (u),
2706 ffebld_constant_complex1 (ffebld_conter (l)));
2707 break;
2708 #endif
2709
2710 #if FFETARGET_okCOMPLEX2
2711 case FFEINFO_kindtypeREAL2:
2712 error = ffetarget_convert_complex3_complex2
2713 (ffebld_cu_ptr_complex3 (u),
2714 ffebld_constant_complex2 (ffebld_conter (l)));
2715 break;
2716 #endif
2717
2718 #if FFETARGET_okCOMPLEX4
2719 case FFEINFO_kindtypeREAL4:
2720 error = ffetarget_convert_complex3_complex4
2721 (ffebld_cu_ptr_complex3 (u),
2722 ffebld_constant_complex4 (ffebld_conter (l)));
2723 break;
2724 #endif
2725
2726 default:
2727 assert ("COMPLEX3/COMPLEX bad source kind type" == NULL);
2728 break;
2729 }
2730 break;
2731
2732 case FFEINFO_basictypeCHARACTER:
2733 error = ffetarget_convert_complex3_character1
2734 (ffebld_cu_ptr_complex3 (u),
2735 ffebld_constant_character1 (ffebld_conter (l)));
2736 break;
2737
2738 case FFEINFO_basictypeHOLLERITH:
2739 error = ffetarget_convert_complex3_hollerith
2740 (ffebld_cu_ptr_complex3 (u),
2741 ffebld_constant_hollerith (ffebld_conter (l)));
2742 break;
2743
2744 case FFEINFO_basictypeTYPELESS:
2745 error = ffetarget_convert_complex3_typeless
2746 (ffebld_cu_ptr_complex3 (u),
2747 ffebld_constant_typeless (ffebld_conter (l)));
2748 break;
2749
2750 default:
2751 assert ("COMPLEX3 bad type" == NULL);
2752 break;
2753 }
2754
2755 /* If conversion operation is not implemented, return original expr. */
2756 if (error == FFEBAD_NOCANDO)
2757 return expr;
2758
2759 expr = ffebld_new_conter_with_orig
2760 (ffebld_constant_new_complex3_val
2761 (ffebld_cu_val_complex3 (u)), expr);
2762 break;
2763 #endif
2764
2765 #if FFETARGET_okCOMPLEX4
2766 case FFEINFO_kindtypeREAL4:
2767 switch (ffeinfo_basictype (ffebld_info (l)))
2768 {
2769 case FFEINFO_basictypeINTEGER:
2770 switch (ffeinfo_kindtype (ffebld_info (l)))
2771 {
2772 #if FFETARGET_okINTEGER1
2773 case FFEINFO_kindtypeINTEGER1:
2774 error = ffetarget_convert_complex4_integer1
2775 (ffebld_cu_ptr_complex4 (u),
2776 ffebld_constant_integer1 (ffebld_conter (l)));
2777 break;
2778 #endif
2779
2780 #if FFETARGET_okINTEGER2
2781 case FFEINFO_kindtypeINTEGER2:
2782 error = ffetarget_convert_complex4_integer2
2783 (ffebld_cu_ptr_complex4 (u),
2784 ffebld_constant_integer2 (ffebld_conter (l)));
2785 break;
2786 #endif
2787
2788 #if FFETARGET_okINTEGER3
2789 case FFEINFO_kindtypeINTEGER3:
2790 error = ffetarget_convert_complex4_integer3
2791 (ffebld_cu_ptr_complex4 (u),
2792 ffebld_constant_integer3 (ffebld_conter (l)));
2793 break;
2794 #endif
2795
2796 #if FFETARGET_okINTEGER4
2797 case FFEINFO_kindtypeINTEGER4:
2798 error = ffetarget_convert_complex4_integer4
2799 (ffebld_cu_ptr_complex4 (u),
2800 ffebld_constant_integer4 (ffebld_conter (l)));
2801 break;
2802 #endif
2803
2804 default:
2805 assert ("COMPLEX4/INTEGER bad source kind type" == NULL);
2806 break;
2807 }
2808 break;
2809
2810 case FFEINFO_basictypeREAL:
2811 switch (ffeinfo_kindtype (ffebld_info (l)))
2812 {
2813 #if FFETARGET_okREAL1
2814 case FFEINFO_kindtypeREAL1:
2815 error = ffetarget_convert_complex4_real1
2816 (ffebld_cu_ptr_complex4 (u),
2817 ffebld_constant_real1 (ffebld_conter (l)));
2818 break;
2819 #endif
2820
2821 #if FFETARGET_okREAL2
2822 case FFEINFO_kindtypeREAL2:
2823 error = ffetarget_convert_complex4_real2
2824 (ffebld_cu_ptr_complex4 (u),
2825 ffebld_constant_real2 (ffebld_conter (l)));
2826 break;
2827 #endif
2828
2829 #if FFETARGET_okREAL3
2830 case FFEINFO_kindtypeREAL3:
2831 error = ffetarget_convert_complex4_real3
2832 (ffebld_cu_ptr_complex4 (u),
2833 ffebld_constant_real3 (ffebld_conter (l)));
2834 break;
2835 #endif
2836
2837 #if FFETARGET_okREAL4
2838 case FFEINFO_kindtypeREAL4:
2839 error = ffetarget_convert_complex4_real4
2840 (ffebld_cu_ptr_complex4 (u),
2841 ffebld_constant_real4 (ffebld_conter (l)));
2842 break;
2843 #endif
2844
2845 default:
2846 assert ("COMPLEX4/REAL bad source kind type" == NULL);
2847 break;
2848 }
2849 break;
2850
2851 case FFEINFO_basictypeCOMPLEX:
2852 switch (ffeinfo_kindtype (ffebld_info (l)))
2853 {
2854 #if FFETARGET_okCOMPLEX1
2855 case FFEINFO_kindtypeREAL1:
2856 error = ffetarget_convert_complex4_complex1
2857 (ffebld_cu_ptr_complex4 (u),
2858 ffebld_constant_complex1 (ffebld_conter (l)));
2859 break;
2860 #endif
2861
2862 #if FFETARGET_okCOMPLEX2
2863 case FFEINFO_kindtypeREAL2:
2864 error = ffetarget_convert_complex4_complex2
2865 (ffebld_cu_ptr_complex4 (u),
2866 ffebld_constant_complex2 (ffebld_conter (l)));
2867 break;
2868 #endif
2869
2870 #if FFETARGET_okCOMPLEX3
2871 case FFEINFO_kindtypeREAL3:
2872 error = ffetarget_convert_complex4_complex3
2873 (ffebld_cu_ptr_complex4 (u),
2874 ffebld_constant_complex3 (ffebld_conter (l)));
2875 break;
2876 #endif
2877
2878 default:
2879 assert ("COMPLEX4/COMPLEX bad source kind type" == NULL);
2880 break;
2881 }
2882 break;
2883
2884 case FFEINFO_basictypeCHARACTER:
2885 error = ffetarget_convert_complex4_character1
2886 (ffebld_cu_ptr_complex4 (u),
2887 ffebld_constant_character1 (ffebld_conter (l)));
2888 break;
2889
2890 case FFEINFO_basictypeHOLLERITH:
2891 error = ffetarget_convert_complex4_hollerith
2892 (ffebld_cu_ptr_complex4 (u),
2893 ffebld_constant_hollerith (ffebld_conter (l)));
2894 break;
2895
2896 case FFEINFO_basictypeTYPELESS:
2897 error = ffetarget_convert_complex4_typeless
2898 (ffebld_cu_ptr_complex4 (u),
2899 ffebld_constant_typeless (ffebld_conter (l)));
2900 break;
2901
2902 default:
2903 assert ("COMPLEX4 bad type" == NULL);
2904 break;
2905 }
2906
2907 /* If conversion operation is not implemented, return original expr. */
2908 if (error == FFEBAD_NOCANDO)
2909 return expr;
2910
2911 expr = ffebld_new_conter_with_orig
2912 (ffebld_constant_new_complex4_val
2913 (ffebld_cu_val_complex4 (u)), expr);
2914 break;
2915 #endif
2916
2917 default:
2918 assert ("bad complex kind type" == NULL);
2919 break;
2920 }
2921 break;
2922
2923 case FFEINFO_basictypeCHARACTER:
2924 if ((sz = ffebld_size (expr)) == FFETARGET_charactersizeNONE)
2925 return expr;
2926 kt = ffeinfo_kindtype (ffebld_info (expr));
2927 switch (kt)
2928 {
2929 #if FFETARGET_okCHARACTER1
2930 case FFEINFO_kindtypeCHARACTER1:
2931 switch (ffeinfo_basictype (ffebld_info (l)))
2932 {
2933 case FFEINFO_basictypeCHARACTER:
2934 if ((sz2 = ffebld_size (l)) == FFETARGET_charactersizeNONE)
2935 return expr;
2936 assert (kt == ffeinfo_kindtype (ffebld_info (l)));
2937 assert (sz2 == ffetarget_length_character1
2938 (ffebld_constant_character1
2939 (ffebld_conter (l))));
2940 error
2941 = ffetarget_convert_character1_character1
2942 (ffebld_cu_ptr_character1 (u), sz,
2943 ffebld_constant_character1 (ffebld_conter (l)),
2944 ffebld_constant_pool ());
2945 break;
2946
2947 case FFEINFO_basictypeINTEGER:
2948 switch (ffeinfo_kindtype (ffebld_info (l)))
2949 {
2950 #if FFETARGET_okINTEGER1
2951 case FFEINFO_kindtypeINTEGER1:
2952 error
2953 = ffetarget_convert_character1_integer1
2954 (ffebld_cu_ptr_character1 (u),
2955 sz,
2956 ffebld_constant_integer1 (ffebld_conter (l)),
2957 ffebld_constant_pool ());
2958 break;
2959 #endif
2960
2961 #if FFETARGET_okINTEGER2
2962 case FFEINFO_kindtypeINTEGER2:
2963 error
2964 = ffetarget_convert_character1_integer2
2965 (ffebld_cu_ptr_character1 (u),
2966 sz,
2967 ffebld_constant_integer2 (ffebld_conter (l)),
2968 ffebld_constant_pool ());
2969 break;
2970 #endif
2971
2972 #if FFETARGET_okINTEGER3
2973 case FFEINFO_kindtypeINTEGER3:
2974 error
2975 = ffetarget_convert_character1_integer3
2976 (ffebld_cu_ptr_character1 (u),
2977 sz,
2978 ffebld_constant_integer3 (ffebld_conter (l)),
2979 ffebld_constant_pool ());
2980 break;
2981 #endif
2982
2983 #if FFETARGET_okINTEGER4
2984 case FFEINFO_kindtypeINTEGER4:
2985 error
2986 = ffetarget_convert_character1_integer4
2987 (ffebld_cu_ptr_character1 (u),
2988 sz,
2989 ffebld_constant_integer4 (ffebld_conter (l)),
2990 ffebld_constant_pool ());
2991 break;
2992 #endif
2993
2994 default:
2995 assert ("CHARACTER1/INTEGER bad source kind type" == NULL);
2996 break;
2997 }
2998 break;
2999
3000 case FFEINFO_basictypeLOGICAL:
3001 switch (ffeinfo_kindtype (ffebld_info (l)))
3002 {
3003 #if FFETARGET_okLOGICAL1
3004 case FFEINFO_kindtypeLOGICAL1:
3005 error
3006 = ffetarget_convert_character1_logical1
3007 (ffebld_cu_ptr_character1 (u),
3008 sz,
3009 ffebld_constant_logical1 (ffebld_conter (l)),
3010 ffebld_constant_pool ());
3011 break;
3012 #endif
3013
3014 #if FFETARGET_okLOGICAL2
3015 case FFEINFO_kindtypeLOGICAL2:
3016 error
3017 = ffetarget_convert_character1_logical2
3018 (ffebld_cu_ptr_character1 (u),
3019 sz,
3020 ffebld_constant_logical2 (ffebld_conter (l)),
3021 ffebld_constant_pool ());
3022 break;
3023 #endif
3024
3025 #if FFETARGET_okLOGICAL3
3026 case FFEINFO_kindtypeLOGICAL3:
3027 error
3028 = ffetarget_convert_character1_logical3
3029 (ffebld_cu_ptr_character1 (u),
3030 sz,
3031 ffebld_constant_logical3 (ffebld_conter (l)),
3032 ffebld_constant_pool ());
3033 break;
3034 #endif
3035
3036 #if FFETARGET_okLOGICAL4
3037 case FFEINFO_kindtypeLOGICAL4:
3038 error
3039 = ffetarget_convert_character1_logical4
3040 (ffebld_cu_ptr_character1 (u),
3041 sz,
3042 ffebld_constant_logical4 (ffebld_conter (l)),
3043 ffebld_constant_pool ());
3044 break;
3045 #endif
3046
3047 default:
3048 assert ("CHARACTER1/LOGICAL bad source kind type" == NULL);
3049 break;
3050 }
3051 break;
3052
3053 case FFEINFO_basictypeHOLLERITH:
3054 error
3055 = ffetarget_convert_character1_hollerith
3056 (ffebld_cu_ptr_character1 (u),
3057 sz,
3058 ffebld_constant_hollerith (ffebld_conter (l)),
3059 ffebld_constant_pool ());
3060 break;
3061
3062 case FFEINFO_basictypeTYPELESS:
3063 error
3064 = ffetarget_convert_character1_typeless
3065 (ffebld_cu_ptr_character1 (u),
3066 sz,
3067 ffebld_constant_typeless (ffebld_conter (l)),
3068 ffebld_constant_pool ());
3069 break;
3070
3071 default:
3072 assert ("CHARACTER1 bad type" == NULL);
3073 }
3074
3075 expr
3076 = ffebld_new_conter_with_orig
3077 (ffebld_constant_new_character1_val
3078 (ffebld_cu_val_character1 (u)),
3079 expr);
3080 break;
3081 #endif
3082
3083 default:
3084 assert ("bad character kind type" == NULL);
3085 break;
3086 }
3087 break;
3088
3089 default:
3090 assert ("bad type" == NULL);
3091 return expr;
3092 }
3093
3094 ffebld_set_info (expr, ffeinfo_new
3095 (bt,
3096 kt,
3097 0,
3098 FFEINFO_kindENTITY,
3099 FFEINFO_whereCONSTANT,
3100 sz));
3101
3102 if ((error != FFEBAD)
3103 && ffebad_start (error))
3104 {
3105 assert (t != NULL);
3106 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3107 ffebad_finish ();
3108 }
3109
3110 return expr;
3111 }
3112
3113 /* ffeexpr_collapse_paren -- Collapse paren expr
3114
3115 ffebld expr;
3116 ffelexToken token;
3117 expr = ffeexpr_collapse_paren(expr,token);
3118
3119 If the result of the expr is a constant, replaces the expr with the
3120 computed constant. */
3121
3122 ffebld
3123 ffeexpr_collapse_paren (ffebld expr, ffelexToken t UNUSED)
3124 {
3125 ffebld r;
3126 ffeinfoBasictype bt;
3127 ffeinfoKindtype kt;
3128 ffetargetCharacterSize len;
3129
3130 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3131 return expr;
3132
3133 r = ffebld_left (expr);
3134
3135 if (ffebld_op (r) != FFEBLD_opCONTER)
3136 return expr;
3137
3138 bt = ffeinfo_basictype (ffebld_info (r));
3139 kt = ffeinfo_kindtype (ffebld_info (r));
3140 len = ffebld_size (r);
3141
3142 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
3143 expr);
3144
3145 ffebld_set_info (expr, ffeinfo_new
3146 (bt,
3147 kt,
3148 0,
3149 FFEINFO_kindENTITY,
3150 FFEINFO_whereCONSTANT,
3151 len));
3152
3153 return expr;
3154 }
3155
3156 /* ffeexpr_collapse_uplus -- Collapse uplus expr
3157
3158 ffebld expr;
3159 ffelexToken token;
3160 expr = ffeexpr_collapse_uplus(expr,token);
3161
3162 If the result of the expr is a constant, replaces the expr with the
3163 computed constant. */
3164
3165 ffebld
3166 ffeexpr_collapse_uplus (ffebld expr, ffelexToken t UNUSED)
3167 {
3168 ffebld r;
3169 ffeinfoBasictype bt;
3170 ffeinfoKindtype kt;
3171 ffetargetCharacterSize len;
3172
3173 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3174 return expr;
3175
3176 r = ffebld_left (expr);
3177
3178 if (ffebld_op (r) != FFEBLD_opCONTER)
3179 return expr;
3180
3181 bt = ffeinfo_basictype (ffebld_info (r));
3182 kt = ffeinfo_kindtype (ffebld_info (r));
3183 len = ffebld_size (r);
3184
3185 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
3186 expr);
3187
3188 ffebld_set_info (expr, ffeinfo_new
3189 (bt,
3190 kt,
3191 0,
3192 FFEINFO_kindENTITY,
3193 FFEINFO_whereCONSTANT,
3194 len));
3195
3196 return expr;
3197 }
3198
3199 /* ffeexpr_collapse_uminus -- Collapse uminus expr
3200
3201 ffebld expr;
3202 ffelexToken token;
3203 expr = ffeexpr_collapse_uminus(expr,token);
3204
3205 If the result of the expr is a constant, replaces the expr with the
3206 computed constant. */
3207
3208 ffebld
3209 ffeexpr_collapse_uminus (ffebld expr, ffelexToken t)
3210 {
3211 ffebad error = FFEBAD;
3212 ffebld r;
3213 ffebldConstantUnion u;
3214 ffeinfoBasictype bt;
3215 ffeinfoKindtype kt;
3216
3217 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3218 return expr;
3219
3220 r = ffebld_left (expr);
3221
3222 if (ffebld_op (r) != FFEBLD_opCONTER)
3223 return expr;
3224
3225 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3226 {
3227 case FFEINFO_basictypeANY:
3228 return expr;
3229
3230 case FFEINFO_basictypeINTEGER:
3231 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3232 {
3233 #if FFETARGET_okINTEGER1
3234 case FFEINFO_kindtypeINTEGER1:
3235 error = ffetarget_uminus_integer1 (ffebld_cu_ptr_integer1 (u),
3236 ffebld_constant_integer1 (ffebld_conter (r)));
3237 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3238 (ffebld_cu_val_integer1 (u)), expr);
3239 break;
3240 #endif
3241
3242 #if FFETARGET_okINTEGER2
3243 case FFEINFO_kindtypeINTEGER2:
3244 error = ffetarget_uminus_integer2 (ffebld_cu_ptr_integer2 (u),
3245 ffebld_constant_integer2 (ffebld_conter (r)));
3246 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3247 (ffebld_cu_val_integer2 (u)), expr);
3248 break;
3249 #endif
3250
3251 #if FFETARGET_okINTEGER3
3252 case FFEINFO_kindtypeINTEGER3:
3253 error = ffetarget_uminus_integer3 (ffebld_cu_ptr_integer3 (u),
3254 ffebld_constant_integer3 (ffebld_conter (r)));
3255 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3256 (ffebld_cu_val_integer3 (u)), expr);
3257 break;
3258 #endif
3259
3260 #if FFETARGET_okINTEGER4
3261 case FFEINFO_kindtypeINTEGER4:
3262 error = ffetarget_uminus_integer4 (ffebld_cu_ptr_integer4 (u),
3263 ffebld_constant_integer4 (ffebld_conter (r)));
3264 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3265 (ffebld_cu_val_integer4 (u)), expr);
3266 break;
3267 #endif
3268
3269 default:
3270 assert ("bad integer kind type" == NULL);
3271 break;
3272 }
3273 break;
3274
3275 case FFEINFO_basictypeREAL:
3276 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3277 {
3278 #if FFETARGET_okREAL1
3279 case FFEINFO_kindtypeREAL1:
3280 error = ffetarget_uminus_real1 (ffebld_cu_ptr_real1 (u),
3281 ffebld_constant_real1 (ffebld_conter (r)));
3282 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3283 (ffebld_cu_val_real1 (u)), expr);
3284 break;
3285 #endif
3286
3287 #if FFETARGET_okREAL2
3288 case FFEINFO_kindtypeREAL2:
3289 error = ffetarget_uminus_real2 (ffebld_cu_ptr_real2 (u),
3290 ffebld_constant_real2 (ffebld_conter (r)));
3291 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3292 (ffebld_cu_val_real2 (u)), expr);
3293 break;
3294 #endif
3295
3296 #if FFETARGET_okREAL3
3297 case FFEINFO_kindtypeREAL3:
3298 error = ffetarget_uminus_real3 (ffebld_cu_ptr_real3 (u),
3299 ffebld_constant_real3 (ffebld_conter (r)));
3300 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3301 (ffebld_cu_val_real3 (u)), expr);
3302 break;
3303 #endif
3304
3305 #if FFETARGET_okREAL4
3306 case FFEINFO_kindtypeREAL4:
3307 error = ffetarget_uminus_real4 (ffebld_cu_ptr_real4 (u),
3308 ffebld_constant_real4 (ffebld_conter (r)));
3309 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
3310 (ffebld_cu_val_real4 (u)), expr);
3311 break;
3312 #endif
3313
3314 default:
3315 assert ("bad real kind type" == NULL);
3316 break;
3317 }
3318 break;
3319
3320 case FFEINFO_basictypeCOMPLEX:
3321 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3322 {
3323 #if FFETARGET_okCOMPLEX1
3324 case FFEINFO_kindtypeREAL1:
3325 error = ffetarget_uminus_complex1 (ffebld_cu_ptr_complex1 (u),
3326 ffebld_constant_complex1 (ffebld_conter (r)));
3327 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3328 (ffebld_cu_val_complex1 (u)), expr);
3329 break;
3330 #endif
3331
3332 #if FFETARGET_okCOMPLEX2
3333 case FFEINFO_kindtypeREAL2:
3334 error = ffetarget_uminus_complex2 (ffebld_cu_ptr_complex2 (u),
3335 ffebld_constant_complex2 (ffebld_conter (r)));
3336 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3337 (ffebld_cu_val_complex2 (u)), expr);
3338 break;
3339 #endif
3340
3341 #if FFETARGET_okCOMPLEX3
3342 case FFEINFO_kindtypeREAL3:
3343 error = ffetarget_uminus_complex3 (ffebld_cu_ptr_complex3 (u),
3344 ffebld_constant_complex3 (ffebld_conter (r)));
3345 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3346 (ffebld_cu_val_complex3 (u)), expr);
3347 break;
3348 #endif
3349
3350 #if FFETARGET_okCOMPLEX4
3351 case FFEINFO_kindtypeREAL4:
3352 error = ffetarget_uminus_complex4 (ffebld_cu_ptr_complex4 (u),
3353 ffebld_constant_complex4 (ffebld_conter (r)));
3354 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
3355 (ffebld_cu_val_complex4 (u)), expr);
3356 break;
3357 #endif
3358
3359 default:
3360 assert ("bad complex kind type" == NULL);
3361 break;
3362 }
3363 break;
3364
3365 default:
3366 assert ("bad type" == NULL);
3367 return expr;
3368 }
3369
3370 ffebld_set_info (expr, ffeinfo_new
3371 (bt,
3372 kt,
3373 0,
3374 FFEINFO_kindENTITY,
3375 FFEINFO_whereCONSTANT,
3376 FFETARGET_charactersizeNONE));
3377
3378 if ((error != FFEBAD)
3379 && ffebad_start (error))
3380 {
3381 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3382 ffebad_finish ();
3383 }
3384
3385 return expr;
3386 }
3387
3388 /* ffeexpr_collapse_not -- Collapse not expr
3389
3390 ffebld expr;
3391 ffelexToken token;
3392 expr = ffeexpr_collapse_not(expr,token);
3393
3394 If the result of the expr is a constant, replaces the expr with the
3395 computed constant. */
3396
3397 ffebld
3398 ffeexpr_collapse_not (ffebld expr, ffelexToken t)
3399 {
3400 ffebad error = FFEBAD;
3401 ffebld r;
3402 ffebldConstantUnion u;
3403 ffeinfoBasictype bt;
3404 ffeinfoKindtype kt;
3405
3406 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3407 return expr;
3408
3409 r = ffebld_left (expr);
3410
3411 if (ffebld_op (r) != FFEBLD_opCONTER)
3412 return expr;
3413
3414 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3415 {
3416 case FFEINFO_basictypeANY:
3417 return expr;
3418
3419 case FFEINFO_basictypeINTEGER:
3420 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3421 {
3422 #if FFETARGET_okINTEGER1
3423 case FFEINFO_kindtypeINTEGER1:
3424 error = ffetarget_not_integer1 (ffebld_cu_ptr_integer1 (u),
3425 ffebld_constant_integer1 (ffebld_conter (r)));
3426 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3427 (ffebld_cu_val_integer1 (u)), expr);
3428 break;
3429 #endif
3430
3431 #if FFETARGET_okINTEGER2
3432 case FFEINFO_kindtypeINTEGER2:
3433 error = ffetarget_not_integer2 (ffebld_cu_ptr_integer2 (u),
3434 ffebld_constant_integer2 (ffebld_conter (r)));
3435 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3436 (ffebld_cu_val_integer2 (u)), expr);
3437 break;
3438 #endif
3439
3440 #if FFETARGET_okINTEGER3
3441 case FFEINFO_kindtypeINTEGER3:
3442 error = ffetarget_not_integer3 (ffebld_cu_ptr_integer3 (u),
3443 ffebld_constant_integer3 (ffebld_conter (r)));
3444 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3445 (ffebld_cu_val_integer3 (u)), expr);
3446 break;
3447 #endif
3448
3449 #if FFETARGET_okINTEGER4
3450 case FFEINFO_kindtypeINTEGER4:
3451 error = ffetarget_not_integer4 (ffebld_cu_ptr_integer4 (u),
3452 ffebld_constant_integer4 (ffebld_conter (r)));
3453 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3454 (ffebld_cu_val_integer4 (u)), expr);
3455 break;
3456 #endif
3457
3458 default:
3459 assert ("bad integer kind type" == NULL);
3460 break;
3461 }
3462 break;
3463
3464 case FFEINFO_basictypeLOGICAL:
3465 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3466 {
3467 #if FFETARGET_okLOGICAL1
3468 case FFEINFO_kindtypeLOGICAL1:
3469 error = ffetarget_not_logical1 (ffebld_cu_ptr_logical1 (u),
3470 ffebld_constant_logical1 (ffebld_conter (r)));
3471 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
3472 (ffebld_cu_val_logical1 (u)), expr);
3473 break;
3474 #endif
3475
3476 #if FFETARGET_okLOGICAL2
3477 case FFEINFO_kindtypeLOGICAL2:
3478 error = ffetarget_not_logical2 (ffebld_cu_ptr_logical2 (u),
3479 ffebld_constant_logical2 (ffebld_conter (r)));
3480 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
3481 (ffebld_cu_val_logical2 (u)), expr);
3482 break;
3483 #endif
3484
3485 #if FFETARGET_okLOGICAL3
3486 case FFEINFO_kindtypeLOGICAL3:
3487 error = ffetarget_not_logical3 (ffebld_cu_ptr_logical3 (u),
3488 ffebld_constant_logical3 (ffebld_conter (r)));
3489 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
3490 (ffebld_cu_val_logical3 (u)), expr);
3491 break;
3492 #endif
3493
3494 #if FFETARGET_okLOGICAL4
3495 case FFEINFO_kindtypeLOGICAL4:
3496 error = ffetarget_not_logical4 (ffebld_cu_ptr_logical4 (u),
3497 ffebld_constant_logical4 (ffebld_conter (r)));
3498 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
3499 (ffebld_cu_val_logical4 (u)), expr);
3500 break;
3501 #endif
3502
3503 default:
3504 assert ("bad logical kind type" == NULL);
3505 break;
3506 }
3507 break;
3508
3509 default:
3510 assert ("bad type" == NULL);
3511 return expr;
3512 }
3513
3514 ffebld_set_info (expr, ffeinfo_new
3515 (bt,
3516 kt,
3517 0,
3518 FFEINFO_kindENTITY,
3519 FFEINFO_whereCONSTANT,
3520 FFETARGET_charactersizeNONE));
3521
3522 if ((error != FFEBAD)
3523 && ffebad_start (error))
3524 {
3525 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3526 ffebad_finish ();
3527 }
3528
3529 return expr;
3530 }
3531
3532 /* ffeexpr_collapse_add -- Collapse add expr
3533
3534 ffebld expr;
3535 ffelexToken token;
3536 expr = ffeexpr_collapse_add(expr,token);
3537
3538 If the result of the expr is a constant, replaces the expr with the
3539 computed constant. */
3540
3541 ffebld
3542 ffeexpr_collapse_add (ffebld expr, ffelexToken t)
3543 {
3544 ffebad error = FFEBAD;
3545 ffebld l;
3546 ffebld r;
3547 ffebldConstantUnion u;
3548 ffeinfoBasictype bt;
3549 ffeinfoKindtype kt;
3550
3551 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3552 return expr;
3553
3554 l = ffebld_left (expr);
3555 r = ffebld_right (expr);
3556
3557 if (ffebld_op (l) != FFEBLD_opCONTER)
3558 return expr;
3559 if (ffebld_op (r) != FFEBLD_opCONTER)
3560 return expr;
3561
3562 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3563 {
3564 case FFEINFO_basictypeANY:
3565 return expr;
3566
3567 case FFEINFO_basictypeINTEGER:
3568 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3569 {
3570 #if FFETARGET_okINTEGER1
3571 case FFEINFO_kindtypeINTEGER1:
3572 error = ffetarget_add_integer1 (ffebld_cu_ptr_integer1 (u),
3573 ffebld_constant_integer1 (ffebld_conter (l)),
3574 ffebld_constant_integer1 (ffebld_conter (r)));
3575 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3576 (ffebld_cu_val_integer1 (u)), expr);
3577 break;
3578 #endif
3579
3580 #if FFETARGET_okINTEGER2
3581 case FFEINFO_kindtypeINTEGER2:
3582 error = ffetarget_add_integer2 (ffebld_cu_ptr_integer2 (u),
3583 ffebld_constant_integer2 (ffebld_conter (l)),
3584 ffebld_constant_integer2 (ffebld_conter (r)));
3585 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3586 (ffebld_cu_val_integer2 (u)), expr);
3587 break;
3588 #endif
3589
3590 #if FFETARGET_okINTEGER3
3591 case FFEINFO_kindtypeINTEGER3:
3592 error = ffetarget_add_integer3 (ffebld_cu_ptr_integer3 (u),
3593 ffebld_constant_integer3 (ffebld_conter (l)),
3594 ffebld_constant_integer3 (ffebld_conter (r)));
3595 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3596 (ffebld_cu_val_integer3 (u)), expr);
3597 break;
3598 #endif
3599
3600 #if FFETARGET_okINTEGER4
3601 case FFEINFO_kindtypeINTEGER4:
3602 error = ffetarget_add_integer4 (ffebld_cu_ptr_integer4 (u),
3603 ffebld_constant_integer4 (ffebld_conter (l)),
3604 ffebld_constant_integer4 (ffebld_conter (r)));
3605 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3606 (ffebld_cu_val_integer4 (u)), expr);
3607 break;
3608 #endif
3609
3610 default:
3611 assert ("bad integer kind type" == NULL);
3612 break;
3613 }
3614 break;
3615
3616 case FFEINFO_basictypeREAL:
3617 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3618 {
3619 #if FFETARGET_okREAL1
3620 case FFEINFO_kindtypeREAL1:
3621 error = ffetarget_add_real1 (ffebld_cu_ptr_real1 (u),
3622 ffebld_constant_real1 (ffebld_conter (l)),
3623 ffebld_constant_real1 (ffebld_conter (r)));
3624 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3625 (ffebld_cu_val_real1 (u)), expr);
3626 break;
3627 #endif
3628
3629 #if FFETARGET_okREAL2
3630 case FFEINFO_kindtypeREAL2:
3631 error = ffetarget_add_real2 (ffebld_cu_ptr_real2 (u),
3632 ffebld_constant_real2 (ffebld_conter (l)),
3633 ffebld_constant_real2 (ffebld_conter (r)));
3634 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3635 (ffebld_cu_val_real2 (u)), expr);
3636 break;
3637 #endif
3638
3639 #if FFETARGET_okREAL3
3640 case FFEINFO_kindtypeREAL3:
3641 error = ffetarget_add_real3 (ffebld_cu_ptr_real3 (u),
3642 ffebld_constant_real3 (ffebld_conter (l)),
3643 ffebld_constant_real3 (ffebld_conter (r)));
3644 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3645 (ffebld_cu_val_real3 (u)), expr);
3646 break;
3647 #endif
3648
3649 #if FFETARGET_okREAL4
3650 case FFEINFO_kindtypeREAL4:
3651 error = ffetarget_add_real4 (ffebld_cu_ptr_real4 (u),
3652 ffebld_constant_real4 (ffebld_conter (l)),
3653 ffebld_constant_real4 (ffebld_conter (r)));
3654 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
3655 (ffebld_cu_val_real4 (u)), expr);
3656 break;
3657 #endif
3658
3659 default:
3660 assert ("bad real kind type" == NULL);
3661 break;
3662 }
3663 break;
3664
3665 case FFEINFO_basictypeCOMPLEX:
3666 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3667 {
3668 #if FFETARGET_okCOMPLEX1
3669 case FFEINFO_kindtypeREAL1:
3670 error = ffetarget_add_complex1 (ffebld_cu_ptr_complex1 (u),
3671 ffebld_constant_complex1 (ffebld_conter (l)),
3672 ffebld_constant_complex1 (ffebld_conter (r)));
3673 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3674 (ffebld_cu_val_complex1 (u)), expr);
3675 break;
3676 #endif
3677
3678 #if FFETARGET_okCOMPLEX2
3679 case FFEINFO_kindtypeREAL2:
3680 error = ffetarget_add_complex2 (ffebld_cu_ptr_complex2 (u),
3681 ffebld_constant_complex2 (ffebld_conter (l)),
3682 ffebld_constant_complex2 (ffebld_conter (r)));
3683 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3684 (ffebld_cu_val_complex2 (u)), expr);
3685 break;
3686 #endif
3687
3688 #if FFETARGET_okCOMPLEX3
3689 case FFEINFO_kindtypeREAL3:
3690 error = ffetarget_add_complex3 (ffebld_cu_ptr_complex3 (u),
3691 ffebld_constant_complex3 (ffebld_conter (l)),
3692 ffebld_constant_complex3 (ffebld_conter (r)));
3693 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3694 (ffebld_cu_val_complex3 (u)), expr);
3695 break;
3696 #endif
3697
3698 #if FFETARGET_okCOMPLEX4
3699 case FFEINFO_kindtypeREAL4:
3700 error = ffetarget_add_complex4 (ffebld_cu_ptr_complex4 (u),
3701 ffebld_constant_complex4 (ffebld_conter (l)),
3702 ffebld_constant_complex4 (ffebld_conter (r)));
3703 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
3704 (ffebld_cu_val_complex4 (u)), expr);
3705 break;
3706 #endif
3707
3708 default:
3709 assert ("bad complex kind type" == NULL);
3710 break;
3711 }
3712 break;
3713
3714 default:
3715 assert ("bad type" == NULL);
3716 return expr;
3717 }
3718
3719 ffebld_set_info (expr, ffeinfo_new
3720 (bt,
3721 kt,
3722 0,
3723 FFEINFO_kindENTITY,
3724 FFEINFO_whereCONSTANT,
3725 FFETARGET_charactersizeNONE));
3726
3727 if ((error != FFEBAD)
3728 && ffebad_start (error))
3729 {
3730 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3731 ffebad_finish ();
3732 }
3733
3734 return expr;
3735 }
3736
3737 /* ffeexpr_collapse_subtract -- Collapse subtract expr
3738
3739 ffebld expr;
3740 ffelexToken token;
3741 expr = ffeexpr_collapse_subtract(expr,token);
3742
3743 If the result of the expr is a constant, replaces the expr with the
3744 computed constant. */
3745
3746 ffebld
3747 ffeexpr_collapse_subtract (ffebld expr, ffelexToken t)
3748 {
3749 ffebad error = FFEBAD;
3750 ffebld l;
3751 ffebld r;
3752 ffebldConstantUnion u;
3753 ffeinfoBasictype bt;
3754 ffeinfoKindtype kt;
3755
3756 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3757 return expr;
3758
3759 l = ffebld_left (expr);
3760 r = ffebld_right (expr);
3761
3762 if (ffebld_op (l) != FFEBLD_opCONTER)
3763 return expr;
3764 if (ffebld_op (r) != FFEBLD_opCONTER)
3765 return expr;
3766
3767 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3768 {
3769 case FFEINFO_basictypeANY:
3770 return expr;
3771
3772 case FFEINFO_basictypeINTEGER:
3773 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3774 {
3775 #if FFETARGET_okINTEGER1
3776 case FFEINFO_kindtypeINTEGER1:
3777 error = ffetarget_subtract_integer1 (ffebld_cu_ptr_integer1 (u),
3778 ffebld_constant_integer1 (ffebld_conter (l)),
3779 ffebld_constant_integer1 (ffebld_conter (r)));
3780 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3781 (ffebld_cu_val_integer1 (u)), expr);
3782 break;
3783 #endif
3784
3785 #if FFETARGET_okINTEGER2
3786 case FFEINFO_kindtypeINTEGER2:
3787 error = ffetarget_subtract_integer2 (ffebld_cu_ptr_integer2 (u),
3788 ffebld_constant_integer2 (ffebld_conter (l)),
3789 ffebld_constant_integer2 (ffebld_conter (r)));
3790 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3791 (ffebld_cu_val_integer2 (u)), expr);
3792 break;
3793 #endif
3794
3795 #if FFETARGET_okINTEGER3
3796 case FFEINFO_kindtypeINTEGER3:
3797 error = ffetarget_subtract_integer3 (ffebld_cu_ptr_integer3 (u),
3798 ffebld_constant_integer3 (ffebld_conter (l)),
3799 ffebld_constant_integer3 (ffebld_conter (r)));
3800 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3801 (ffebld_cu_val_integer3 (u)), expr);
3802 break;
3803 #endif
3804
3805 #if FFETARGET_okINTEGER4
3806 case FFEINFO_kindtypeINTEGER4:
3807 error = ffetarget_subtract_integer4 (ffebld_cu_ptr_integer4 (u),
3808 ffebld_constant_integer4 (ffebld_conter (l)),
3809 ffebld_constant_integer4 (ffebld_conter (r)));
3810 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3811 (ffebld_cu_val_integer4 (u)), expr);
3812 break;
3813 #endif
3814
3815 default:
3816 assert ("bad integer kind type" == NULL);
3817 break;
3818 }
3819 break;
3820
3821 case FFEINFO_basictypeREAL:
3822 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3823 {
3824 #if FFETARGET_okREAL1
3825 case FFEINFO_kindtypeREAL1:
3826 error = ffetarget_subtract_real1 (ffebld_cu_ptr_real1 (u),
3827 ffebld_constant_real1 (ffebld_conter (l)),
3828 ffebld_constant_real1 (ffebld_conter (r)));
3829 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3830 (ffebld_cu_val_real1 (u)), expr);
3831 break;
3832 #endif
3833
3834 #if FFETARGET_okREAL2
3835 case FFEINFO_kindtypeREAL2:
3836 error = ffetarget_subtract_real2 (ffebld_cu_ptr_real2 (u),
3837 ffebld_constant_real2 (ffebld_conter (l)),
3838 ffebld_constant_real2 (ffebld_conter (r)));
3839 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3840 (ffebld_cu_val_real2 (u)), expr);
3841 break;
3842 #endif
3843
3844 #if FFETARGET_okREAL3
3845 case FFEINFO_kindtypeREAL3:
3846 error = ffetarget_subtract_real3 (ffebld_cu_ptr_real3 (u),
3847 ffebld_constant_real3 (ffebld_conter (l)),
3848 ffebld_constant_real3 (ffebld_conter (r)));
3849 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3850 (ffebld_cu_val_real3 (u)), expr);
3851 break;
3852 #endif
3853
3854 #if FFETARGET_okREAL4
3855 case FFEINFO_kindtypeREAL4:
3856 error = ffetarget_subtract_real4 (ffebld_cu_ptr_real4 (u),
3857 ffebld_constant_real4 (ffebld_conter (l)),
3858 ffebld_constant_real4 (ffebld_conter (r)));
3859 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
3860 (ffebld_cu_val_real4 (u)), expr);
3861 break;
3862 #endif
3863
3864 default:
3865 assert ("bad real kind type" == NULL);
3866 break;
3867 }
3868 break;
3869
3870 case FFEINFO_basictypeCOMPLEX:
3871 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3872 {
3873 #if FFETARGET_okCOMPLEX1
3874 case FFEINFO_kindtypeREAL1:
3875 error = ffetarget_subtract_complex1 (ffebld_cu_ptr_complex1 (u),
3876 ffebld_constant_complex1 (ffebld_conter (l)),
3877 ffebld_constant_complex1 (ffebld_conter (r)));
3878 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3879 (ffebld_cu_val_complex1 (u)), expr);
3880 break;
3881 #endif
3882
3883 #if FFETARGET_okCOMPLEX2
3884 case FFEINFO_kindtypeREAL2:
3885 error = ffetarget_subtract_complex2 (ffebld_cu_ptr_complex2 (u),
3886 ffebld_constant_complex2 (ffebld_conter (l)),
3887 ffebld_constant_complex2 (ffebld_conter (r)));
3888 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3889 (ffebld_cu_val_complex2 (u)), expr);
3890 break;
3891 #endif
3892
3893 #if FFETARGET_okCOMPLEX3
3894 case FFEINFO_kindtypeREAL3:
3895 error = ffetarget_subtract_complex3 (ffebld_cu_ptr_complex3 (u),
3896 ffebld_constant_complex3 (ffebld_conter (l)),
3897 ffebld_constant_complex3 (ffebld_conter (r)));
3898 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3899 (ffebld_cu_val_complex3 (u)), expr);
3900 break;
3901 #endif
3902
3903 #if FFETARGET_okCOMPLEX4
3904 case FFEINFO_kindtypeREAL4:
3905 error = ffetarget_subtract_complex4 (ffebld_cu_ptr_complex4 (u),
3906 ffebld_constant_complex4 (ffebld_conter (l)),
3907 ffebld_constant_complex4 (ffebld_conter (r)));
3908 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
3909 (ffebld_cu_val_complex4 (u)), expr);
3910 break;
3911 #endif
3912
3913 default:
3914 assert ("bad complex kind type" == NULL);
3915 break;
3916 }
3917 break;
3918
3919 default:
3920 assert ("bad type" == NULL);
3921 return expr;
3922 }
3923
3924 ffebld_set_info (expr, ffeinfo_new
3925 (bt,
3926 kt,
3927 0,
3928 FFEINFO_kindENTITY,
3929 FFEINFO_whereCONSTANT,
3930 FFETARGET_charactersizeNONE));
3931
3932 if ((error != FFEBAD)
3933 && ffebad_start (error))
3934 {
3935 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3936 ffebad_finish ();
3937 }
3938
3939 return expr;
3940 }
3941
3942 /* ffeexpr_collapse_multiply -- Collapse multiply expr
3943
3944 ffebld expr;
3945 ffelexToken token;
3946 expr = ffeexpr_collapse_multiply(expr,token);
3947
3948 If the result of the expr is a constant, replaces the expr with the
3949 computed constant. */
3950
3951 ffebld
3952 ffeexpr_collapse_multiply (ffebld expr, ffelexToken t)
3953 {
3954 ffebad error = FFEBAD;
3955 ffebld l;
3956 ffebld r;
3957 ffebldConstantUnion u;
3958 ffeinfoBasictype bt;
3959 ffeinfoKindtype kt;
3960
3961 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3962 return expr;
3963
3964 l = ffebld_left (expr);
3965 r = ffebld_right (expr);
3966
3967 if (ffebld_op (l) != FFEBLD_opCONTER)
3968 return expr;
3969 if (ffebld_op (r) != FFEBLD_opCONTER)
3970 return expr;
3971
3972 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3973 {
3974 case FFEINFO_basictypeANY:
3975 return expr;
3976
3977 case FFEINFO_basictypeINTEGER:
3978 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3979 {
3980 #if FFETARGET_okINTEGER1
3981 case FFEINFO_kindtypeINTEGER1:
3982 error = ffetarget_multiply_integer1 (ffebld_cu_ptr_integer1 (u),
3983 ffebld_constant_integer1 (ffebld_conter (l)),
3984 ffebld_constant_integer1 (ffebld_conter (r)));
3985 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3986 (ffebld_cu_val_integer1 (u)), expr);
3987 break;
3988 #endif
3989
3990 #if FFETARGET_okINTEGER2
3991 case FFEINFO_kindtypeINTEGER2:
3992 error = ffetarget_multiply_integer2 (ffebld_cu_ptr_integer2 (u),
3993 ffebld_constant_integer2 (ffebld_conter (l)),
3994 ffebld_constant_integer2 (ffebld_conter (r)));
3995 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3996 (ffebld_cu_val_integer2 (u)), expr);
3997 break;
3998 #endif
3999
4000 #if FFETARGET_okINTEGER3
4001 case FFEINFO_kindtypeINTEGER3:
4002 error = ffetarget_multiply_integer3 (ffebld_cu_ptr_integer3 (u),
4003 ffebld_constant_integer3 (ffebld_conter (l)),
4004 ffebld_constant_integer3 (ffebld_conter (r)));
4005 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
4006 (ffebld_cu_val_integer3 (u)), expr);
4007 break;
4008 #endif
4009
4010 #if FFETARGET_okINTEGER4
4011 case FFEINFO_kindtypeINTEGER4:
4012 error = ffetarget_multiply_integer4 (ffebld_cu_ptr_integer4 (u),
4013 ffebld_constant_integer4 (ffebld_conter (l)),
4014 ffebld_constant_integer4 (ffebld_conter (r)));
4015 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
4016 (ffebld_cu_val_integer4 (u)), expr);
4017 break;
4018 #endif
4019
4020 default:
4021 assert ("bad integer kind type" == NULL);
4022 break;
4023 }
4024 break;
4025
4026 case FFEINFO_basictypeREAL:
4027 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4028 {
4029 #if FFETARGET_okREAL1
4030 case FFEINFO_kindtypeREAL1:
4031 error = ffetarget_multiply_real1 (ffebld_cu_ptr_real1 (u),
4032 ffebld_constant_real1 (ffebld_conter (l)),
4033 ffebld_constant_real1 (ffebld_conter (r)));
4034 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
4035 (ffebld_cu_val_real1 (u)), expr);
4036 break;
4037 #endif
4038
4039 #if FFETARGET_okREAL2
4040 case FFEINFO_kindtypeREAL2:
4041 error = ffetarget_multiply_real2 (ffebld_cu_ptr_real2 (u),
4042 ffebld_constant_real2 (ffebld_conter (l)),
4043 ffebld_constant_real2 (ffebld_conter (r)));
4044 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
4045 (ffebld_cu_val_real2 (u)), expr);
4046 break;
4047 #endif
4048
4049 #if FFETARGET_okREAL3
4050 case FFEINFO_kindtypeREAL3:
4051 error = ffetarget_multiply_real3 (ffebld_cu_ptr_real3 (u),
4052 ffebld_constant_real3 (ffebld_conter (l)),
4053 ffebld_constant_real3 (ffebld_conter (r)));
4054 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
4055 (ffebld_cu_val_real3 (u)), expr);
4056 break;
4057 #endif
4058
4059 #if FFETARGET_okREAL4
4060 case FFEINFO_kindtypeREAL4:
4061 error = ffetarget_multiply_real4 (ffebld_cu_ptr_real4 (u),
4062 ffebld_constant_real4 (ffebld_conter (l)),
4063 ffebld_constant_real4 (ffebld_conter (r)));
4064 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
4065 (ffebld_cu_val_real4 (u)), expr);
4066 break;
4067 #endif
4068
4069 default:
4070 assert ("bad real kind type" == NULL);
4071 break;
4072 }
4073 break;
4074
4075 case FFEINFO_basictypeCOMPLEX:
4076 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4077 {
4078 #if FFETARGET_okCOMPLEX1
4079 case FFEINFO_kindtypeREAL1:
4080 error = ffetarget_multiply_complex1 (ffebld_cu_ptr_complex1 (u),
4081 ffebld_constant_complex1 (ffebld_conter (l)),
4082 ffebld_constant_complex1 (ffebld_conter (r)));
4083 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
4084 (ffebld_cu_val_complex1 (u)), expr);
4085 break;
4086 #endif
4087
4088 #if FFETARGET_okCOMPLEX2
4089 case FFEINFO_kindtypeREAL2:
4090 error = ffetarget_multiply_complex2 (ffebld_cu_ptr_complex2 (u),
4091 ffebld_constant_complex2 (ffebld_conter (l)),
4092 ffebld_constant_complex2 (ffebld_conter (r)));
4093 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
4094 (ffebld_cu_val_complex2 (u)), expr);
4095 break;
4096 #endif
4097
4098 #if FFETARGET_okCOMPLEX3
4099 case FFEINFO_kindtypeREAL3:
4100 error = ffetarget_multiply_complex3 (ffebld_cu_ptr_complex3 (u),
4101 ffebld_constant_complex3 (ffebld_conter (l)),
4102 ffebld_constant_complex3 (ffebld_conter (r)));
4103 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
4104 (ffebld_cu_val_complex3 (u)), expr);
4105 break;
4106 #endif
4107
4108 #if FFETARGET_okCOMPLEX4
4109 case FFEINFO_kindtypeREAL4:
4110 error = ffetarget_multiply_complex4 (ffebld_cu_ptr_complex4 (u),
4111 ffebld_constant_complex4 (ffebld_conter (l)),
4112 ffebld_constant_complex4 (ffebld_conter (r)));
4113 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
4114 (ffebld_cu_val_complex4 (u)), expr);
4115 break;
4116 #endif
4117
4118 default:
4119 assert ("bad complex kind type" == NULL);
4120 break;
4121 }
4122 break;
4123
4124 default:
4125 assert ("bad type" == NULL);
4126 return expr;
4127 }
4128
4129 ffebld_set_info (expr, ffeinfo_new
4130 (bt,
4131 kt,
4132 0,
4133 FFEINFO_kindENTITY,
4134 FFEINFO_whereCONSTANT,
4135 FFETARGET_charactersizeNONE));
4136
4137 if ((error != FFEBAD)
4138 && ffebad_start (error))
4139 {
4140 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4141 ffebad_finish ();
4142 }
4143
4144 return expr;
4145 }
4146
4147 /* ffeexpr_collapse_divide -- Collapse divide expr
4148
4149 ffebld expr;
4150 ffelexToken token;
4151 expr = ffeexpr_collapse_divide(expr,token);
4152
4153 If the result of the expr is a constant, replaces the expr with the
4154 computed constant. */
4155
4156 ffebld
4157 ffeexpr_collapse_divide (ffebld expr, ffelexToken t)
4158 {
4159 ffebad error = FFEBAD;
4160 ffebld l;
4161 ffebld r;
4162 ffebldConstantUnion u;
4163 ffeinfoBasictype bt;
4164 ffeinfoKindtype kt;
4165
4166 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4167 return expr;
4168
4169 l = ffebld_left (expr);
4170 r = ffebld_right (expr);
4171
4172 if (ffebld_op (l) != FFEBLD_opCONTER)
4173 return expr;
4174 if (ffebld_op (r) != FFEBLD_opCONTER)
4175 return expr;
4176
4177 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
4178 {
4179 case FFEINFO_basictypeANY:
4180 return expr;
4181
4182 case FFEINFO_basictypeINTEGER:
4183 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4184 {
4185 #if FFETARGET_okINTEGER1
4186 case FFEINFO_kindtypeINTEGER1:
4187 error = ffetarget_divide_integer1 (ffebld_cu_ptr_integer1 (u),
4188 ffebld_constant_integer1 (ffebld_conter (l)),
4189 ffebld_constant_integer1 (ffebld_conter (r)));
4190 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
4191 (ffebld_cu_val_integer1 (u)), expr);
4192 break;
4193 #endif
4194
4195 #if FFETARGET_okINTEGER2
4196 case FFEINFO_kindtypeINTEGER2:
4197 error = ffetarget_divide_integer2 (ffebld_cu_ptr_integer2 (u),
4198 ffebld_constant_integer2 (ffebld_conter (l)),
4199 ffebld_constant_integer2 (ffebld_conter (r)));
4200 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
4201 (ffebld_cu_val_integer2 (u)), expr);
4202 break;
4203 #endif
4204
4205 #if FFETARGET_okINTEGER3
4206 case FFEINFO_kindtypeINTEGER3:
4207 error = ffetarget_divide_integer3 (ffebld_cu_ptr_integer3 (u),
4208 ffebld_constant_integer3 (ffebld_conter (l)),
4209 ffebld_constant_integer3 (ffebld_conter (r)));
4210 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
4211 (ffebld_cu_val_integer3 (u)), expr);
4212 break;
4213 #endif
4214
4215 #if FFETARGET_okINTEGER4
4216 case FFEINFO_kindtypeINTEGER4:
4217 error = ffetarget_divide_integer4 (ffebld_cu_ptr_integer4 (u),
4218 ffebld_constant_integer4 (ffebld_conter (l)),
4219 ffebld_constant_integer4 (ffebld_conter (r)));
4220 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
4221 (ffebld_cu_val_integer4 (u)), expr);
4222 break;
4223 #endif
4224
4225 default:
4226 assert ("bad integer kind type" == NULL);
4227 break;
4228 }
4229 break;
4230
4231 case FFEINFO_basictypeREAL:
4232 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4233 {
4234 #if FFETARGET_okREAL1
4235 case FFEINFO_kindtypeREAL1:
4236 error = ffetarget_divide_real1 (ffebld_cu_ptr_real1 (u),
4237 ffebld_constant_real1 (ffebld_conter (l)),
4238 ffebld_constant_real1 (ffebld_conter (r)));
4239 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
4240 (ffebld_cu_val_real1 (u)), expr);
4241 break;
4242 #endif
4243
4244 #if FFETARGET_okREAL2
4245 case FFEINFO_kindtypeREAL2:
4246 error = ffetarget_divide_real2 (ffebld_cu_ptr_real2 (u),
4247 ffebld_constant_real2 (ffebld_conter (l)),
4248 ffebld_constant_real2 (ffebld_conter (r)));
4249 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
4250 (ffebld_cu_val_real2 (u)), expr);
4251 break;
4252 #endif
4253
4254 #if FFETARGET_okREAL3
4255 case FFEINFO_kindtypeREAL3:
4256 error = ffetarget_divide_real3 (ffebld_cu_ptr_real3 (u),
4257 ffebld_constant_real3 (ffebld_conter (l)),
4258 ffebld_constant_real3 (ffebld_conter (r)));
4259 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
4260 (ffebld_cu_val_real3 (u)), expr);
4261 break;
4262 #endif
4263
4264 #if FFETARGET_okREAL4
4265 case FFEINFO_kindtypeREAL4:
4266 error = ffetarget_divide_real4 (ffebld_cu_ptr_real4 (u),
4267 ffebld_constant_real4 (ffebld_conter (l)),
4268 ffebld_constant_real4 (ffebld_conter (r)));
4269 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
4270 (ffebld_cu_val_real4 (u)), expr);
4271 break;
4272 #endif
4273
4274 default:
4275 assert ("bad real kind type" == NULL);
4276 break;
4277 }
4278 break;
4279
4280 case FFEINFO_basictypeCOMPLEX:
4281 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4282 {
4283 #if FFETARGET_okCOMPLEX1
4284 case FFEINFO_kindtypeREAL1:
4285 error = ffetarget_divide_complex1 (ffebld_cu_ptr_complex1 (u),
4286 ffebld_constant_complex1 (ffebld_conter (l)),
4287 ffebld_constant_complex1 (ffebld_conter (r)));
4288 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
4289 (ffebld_cu_val_complex1 (u)), expr);
4290 break;
4291 #endif
4292
4293 #if FFETARGET_okCOMPLEX2
4294 case FFEINFO_kindtypeREAL2:
4295 error = ffetarget_divide_complex2 (ffebld_cu_ptr_complex2 (u),
4296 ffebld_constant_complex2 (ffebld_conter (l)),
4297 ffebld_constant_complex2 (ffebld_conter (r)));
4298 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
4299 (ffebld_cu_val_complex2 (u)), expr);
4300 break;
4301 #endif
4302
4303 #if FFETARGET_okCOMPLEX3
4304 case FFEINFO_kindtypeREAL3:
4305 error = ffetarget_divide_complex3 (ffebld_cu_ptr_complex3 (u),
4306 ffebld_constant_complex3 (ffebld_conter (l)),
4307 ffebld_constant_complex3 (ffebld_conter (r)));
4308 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
4309 (ffebld_cu_val_complex3 (u)), expr);
4310 break;
4311 #endif
4312
4313 #if FFETARGET_okCOMPLEX4
4314 case FFEINFO_kindtypeREAL4:
4315 error = ffetarget_divide_complex4 (ffebld_cu_ptr_complex4 (u),
4316 ffebld_constant_complex4 (ffebld_conter (l)),
4317 ffebld_constant_complex4 (ffebld_conter (r)));
4318 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
4319 (ffebld_cu_val_complex4 (u)), expr);
4320 break;
4321 #endif
4322
4323 default:
4324 assert ("bad complex kind type" == NULL);
4325 break;
4326 }
4327 break;
4328
4329 default:
4330 assert ("bad type" == NULL);
4331 return expr;
4332 }
4333
4334 ffebld_set_info (expr, ffeinfo_new
4335 (bt,
4336 kt,
4337 0,
4338 FFEINFO_kindENTITY,
4339 FFEINFO_whereCONSTANT,
4340 FFETARGET_charactersizeNONE));
4341
4342 if ((error != FFEBAD)
4343 && ffebad_start (error))
4344 {
4345 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4346 ffebad_finish ();
4347 }
4348
4349 return expr;
4350 }
4351
4352 /* ffeexpr_collapse_power -- Collapse power expr
4353
4354 ffebld expr;
4355 ffelexToken token;
4356 expr = ffeexpr_collapse_power(expr,token);
4357
4358 If the result of the expr is a constant, replaces the expr with the
4359 computed constant. */
4360
4361 ffebld
4362 ffeexpr_collapse_power (ffebld expr, ffelexToken t)
4363 {
4364 ffebad error = FFEBAD;
4365 ffebld l;
4366 ffebld r;
4367 ffebldConstantUnion u;
4368 ffeinfoBasictype bt;
4369 ffeinfoKindtype kt;
4370
4371 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4372 return expr;
4373
4374 l = ffebld_left (expr);
4375 r = ffebld_right (expr);
4376
4377 if (ffebld_op (l) != FFEBLD_opCONTER)
4378 return expr;
4379 if (ffebld_op (r) != FFEBLD_opCONTER)
4380 return expr;
4381
4382 if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER)
4383 || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT))
4384 return expr;
4385
4386 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
4387 {
4388 case FFEINFO_basictypeANY:
4389 return expr;
4390
4391 case FFEINFO_basictypeINTEGER:
4392 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4393 {
4394 case FFEINFO_kindtypeINTEGERDEFAULT:
4395 error = ffetarget_power_integerdefault_integerdefault
4396 (ffebld_cu_ptr_integerdefault (u),
4397 ffebld_constant_integerdefault (ffebld_conter (l)),
4398 ffebld_constant_integerdefault (ffebld_conter (r)));
4399 expr = ffebld_new_conter_with_orig
4400 (ffebld_constant_new_integerdefault_val
4401 (ffebld_cu_val_integerdefault (u)), expr);
4402 break;
4403
4404 default:
4405 assert ("bad integer kind type" == NULL);
4406 break;
4407 }
4408 break;
4409
4410 case FFEINFO_basictypeREAL:
4411 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4412 {
4413 case FFEINFO_kindtypeREALDEFAULT:
4414 error = ffetarget_power_realdefault_integerdefault
4415 (ffebld_cu_ptr_realdefault (u),
4416 ffebld_constant_realdefault (ffebld_conter (l)),
4417 ffebld_constant_integerdefault (ffebld_conter (r)));
4418 expr = ffebld_new_conter_with_orig
4419 (ffebld_constant_new_realdefault_val
4420 (ffebld_cu_val_realdefault (u)), expr);
4421 break;
4422
4423 case FFEINFO_kindtypeREALDOUBLE:
4424 error = ffetarget_power_realdouble_integerdefault
4425 (ffebld_cu_ptr_realdouble (u),
4426 ffebld_constant_realdouble (ffebld_conter (l)),
4427 ffebld_constant_integerdefault (ffebld_conter (r)));
4428 expr = ffebld_new_conter_with_orig
4429 (ffebld_constant_new_realdouble_val
4430 (ffebld_cu_val_realdouble (u)), expr);
4431 break;
4432
4433 #if FFETARGET_okREALQUAD
4434 case FFEINFO_kindtypeREALQUAD:
4435 error = ffetarget_power_realquad_integerdefault
4436 (ffebld_cu_ptr_realquad (u),
4437 ffebld_constant_realquad (ffebld_conter (l)),
4438 ffebld_constant_integerdefault (ffebld_conter (r)));
4439 expr = ffebld_new_conter_with_orig
4440 (ffebld_constant_new_realquad_val
4441 (ffebld_cu_val_realquad (u)), expr);
4442 break;
4443 #endif
4444 default:
4445 assert ("bad real kind type" == NULL);
4446 break;
4447 }
4448 break;
4449
4450 case FFEINFO_basictypeCOMPLEX:
4451 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4452 {
4453 case FFEINFO_kindtypeREALDEFAULT:
4454 error = ffetarget_power_complexdefault_integerdefault
4455 (ffebld_cu_ptr_complexdefault (u),
4456 ffebld_constant_complexdefault (ffebld_conter (l)),
4457 ffebld_constant_integerdefault (ffebld_conter (r)));
4458 expr = ffebld_new_conter_with_orig
4459 (ffebld_constant_new_complexdefault_val
4460 (ffebld_cu_val_complexdefault (u)), expr);
4461 break;
4462
4463 #if FFETARGET_okCOMPLEXDOUBLE
4464 case FFEINFO_kindtypeREALDOUBLE:
4465 error = ffetarget_power_complexdouble_integerdefault
4466 (ffebld_cu_ptr_complexdouble (u),
4467 ffebld_constant_complexdouble (ffebld_conter (l)),
4468 ffebld_constant_integerdefault (ffebld_conter (r)));
4469 expr = ffebld_new_conter_with_orig
4470 (ffebld_constant_new_complexdouble_val
4471 (ffebld_cu_val_complexdouble (u)), expr);
4472 break;
4473 #endif
4474
4475 #if FFETARGET_okCOMPLEXQUAD
4476 case FFEINFO_kindtypeREALQUAD:
4477 error = ffetarget_power_complexquad_integerdefault
4478 (ffebld_cu_ptr_complexquad (u),
4479 ffebld_constant_complexquad (ffebld_conter (l)),
4480 ffebld_constant_integerdefault (ffebld_conter (r)));
4481 expr = ffebld_new_conter_with_orig
4482 (ffebld_constant_new_complexquad_val
4483 (ffebld_cu_val_complexquad (u)), expr);
4484 break;
4485 #endif
4486
4487 default:
4488 assert ("bad complex kind type" == NULL);
4489 break;
4490 }
4491 break;
4492
4493 default:
4494 assert ("bad type" == NULL);
4495 return expr;
4496 }
4497
4498 ffebld_set_info (expr, ffeinfo_new
4499 (bt,
4500 kt,
4501 0,
4502 FFEINFO_kindENTITY,
4503 FFEINFO_whereCONSTANT,
4504 FFETARGET_charactersizeNONE));
4505
4506 if ((error != FFEBAD)
4507 && ffebad_start (error))
4508 {
4509 ffebad_here (0, ffelex_token_where_line (t),
4510 ffelex_token_where_column (t));
4511 ffebad_finish ();
4512 }
4513
4514 return expr;
4515 }
4516
4517 /* ffeexpr_collapse_concatenate -- Collapse concatenate expr
4518
4519 ffebld expr;
4520 ffelexToken token;
4521 expr = ffeexpr_collapse_concatenate(expr,token);
4522
4523 If the result of the expr is a constant, replaces the expr with the
4524 computed constant. */
4525
4526 ffebld
4527 ffeexpr_collapse_concatenate (ffebld expr, ffelexToken t)
4528 {
4529 ffebad error = FFEBAD;
4530 ffebld l;
4531 ffebld r;
4532 ffebldConstantUnion u;
4533 ffeinfoKindtype kt;
4534 ffetargetCharacterSize len;
4535
4536 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4537 return expr;
4538
4539 l = ffebld_left (expr);
4540 r = ffebld_right (expr);
4541
4542 if (ffebld_op (l) != FFEBLD_opCONTER)
4543 return expr;
4544 if (ffebld_op (r) != FFEBLD_opCONTER)
4545 return expr;
4546
4547 switch (ffeinfo_basictype (ffebld_info (expr)))
4548 {
4549 case FFEINFO_basictypeANY:
4550 return expr;
4551
4552 case FFEINFO_basictypeCHARACTER:
4553 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4554 {
4555 #if FFETARGET_okCHARACTER1
4556 case FFEINFO_kindtypeCHARACTER1:
4557 error = ffetarget_concatenate_character1 (ffebld_cu_ptr_character1 (u),
4558 ffebld_constant_character1 (ffebld_conter (l)),
4559 ffebld_constant_character1 (ffebld_conter (r)),
4560 ffebld_constant_pool (), &len);
4561 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
4562 (ffebld_cu_val_character1 (u)), expr);
4563 break;
4564 #endif
4565
4566 #if FFETARGET_okCHARACTER2
4567 case FFEINFO_kindtypeCHARACTER2:
4568 error = ffetarget_concatenate_character2 (ffebld_cu_ptr_character2 (u),
4569 ffebld_constant_character2 (ffebld_conter (l)),
4570 ffebld_constant_character2 (ffebld_conter (r)),
4571 ffebld_constant_pool (), &len);
4572 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val
4573 (ffebld_cu_val_character2 (u)), expr);
4574 break;
4575 #endif
4576
4577 #if FFETARGET_okCHARACTER3
4578 case FFEINFO_kindtypeCHARACTER3:
4579 error = ffetarget_concatenate_character3 (ffebld_cu_ptr_character3 (u),
4580 ffebld_constant_character3 (ffebld_conter (l)),
4581 ffebld_constant_character3 (ffebld_conter (r)),
4582 ffebld_constant_pool (), &len);
4583 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val
4584 (ffebld_cu_val_character3 (u)), expr);
4585 break;
4586 #endif
4587
4588 #if FFETARGET_okCHARACTER4
4589 case FFEINFO_kindtypeCHARACTER4:
4590 error = ffetarget_concatenate_character4 (ffebld_cu_ptr_character4 (u),
4591 ffebld_constant_character4 (ffebld_conter (l)),
4592 ffebld_constant_character4 (ffebld_conter (r)),
4593 ffebld_constant_pool (), &len);
4594 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val
4595 (ffebld_cu_val_character4 (u)), expr);
4596 break;
4597 #endif
4598
4599 default:
4600 assert ("bad character kind type" == NULL);
4601 break;
4602 }
4603 break;
4604
4605 default:
4606 assert ("bad type" == NULL);
4607 return expr;
4608 }
4609
4610 ffebld_set_info (expr, ffeinfo_new
4611 (FFEINFO_basictypeCHARACTER,
4612 kt,
4613 0,
4614 FFEINFO_kindENTITY,
4615 FFEINFO_whereCONSTANT,
4616 len));
4617
4618 if ((error != FFEBAD)
4619 && ffebad_start (error))
4620 {
4621 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4622 ffebad_finish ();
4623 }
4624
4625 return expr;
4626 }
4627
4628 /* ffeexpr_collapse_eq -- Collapse eq expr
4629
4630 ffebld expr;
4631 ffelexToken token;
4632 expr = ffeexpr_collapse_eq(expr,token);
4633
4634 If the result of the expr is a constant, replaces the expr with the
4635 computed constant. */
4636
4637 ffebld
4638 ffeexpr_collapse_eq (ffebld expr, ffelexToken t)
4639 {
4640 ffebad error = FFEBAD;
4641 ffebld l;
4642 ffebld r;
4643 bool val;
4644
4645 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4646 return expr;
4647
4648 l = ffebld_left (expr);
4649 r = ffebld_right (expr);
4650
4651 if (ffebld_op (l) != FFEBLD_opCONTER)
4652 return expr;
4653 if (ffebld_op (r) != FFEBLD_opCONTER)
4654 return expr;
4655
4656 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4657 {
4658 case FFEINFO_basictypeANY:
4659 return expr;
4660
4661 case FFEINFO_basictypeINTEGER:
4662 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4663 {
4664 #if FFETARGET_okINTEGER1
4665 case FFEINFO_kindtypeINTEGER1:
4666 error = ffetarget_eq_integer1 (&val,
4667 ffebld_constant_integer1 (ffebld_conter (l)),
4668 ffebld_constant_integer1 (ffebld_conter (r)));
4669 expr = ffebld_new_conter_with_orig
4670 (ffebld_constant_new_logicaldefault (val), expr);
4671 break;
4672 #endif
4673
4674 #if FFETARGET_okINTEGER2
4675 case FFEINFO_kindtypeINTEGER2:
4676 error = ffetarget_eq_integer2 (&val,
4677 ffebld_constant_integer2 (ffebld_conter (l)),
4678 ffebld_constant_integer2 (ffebld_conter (r)));
4679 expr = ffebld_new_conter_with_orig
4680 (ffebld_constant_new_logicaldefault (val), expr);
4681 break;
4682 #endif
4683
4684 #if FFETARGET_okINTEGER3
4685 case FFEINFO_kindtypeINTEGER3:
4686 error = ffetarget_eq_integer3 (&val,
4687 ffebld_constant_integer3 (ffebld_conter (l)),
4688 ffebld_constant_integer3 (ffebld_conter (r)));
4689 expr = ffebld_new_conter_with_orig
4690 (ffebld_constant_new_logicaldefault (val), expr);
4691 break;
4692 #endif
4693
4694 #if FFETARGET_okINTEGER4
4695 case FFEINFO_kindtypeINTEGER4:
4696 error = ffetarget_eq_integer4 (&val,
4697 ffebld_constant_integer4 (ffebld_conter (l)),
4698 ffebld_constant_integer4 (ffebld_conter (r)));
4699 expr = ffebld_new_conter_with_orig
4700 (ffebld_constant_new_logicaldefault (val), expr);
4701 break;
4702 #endif
4703
4704 default:
4705 assert ("bad integer kind type" == NULL);
4706 break;
4707 }
4708 break;
4709
4710 case FFEINFO_basictypeREAL:
4711 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4712 {
4713 #if FFETARGET_okREAL1
4714 case FFEINFO_kindtypeREAL1:
4715 error = ffetarget_eq_real1 (&val,
4716 ffebld_constant_real1 (ffebld_conter (l)),
4717 ffebld_constant_real1 (ffebld_conter (r)));
4718 expr = ffebld_new_conter_with_orig
4719 (ffebld_constant_new_logicaldefault (val), expr);
4720 break;
4721 #endif
4722
4723 #if FFETARGET_okREAL2
4724 case FFEINFO_kindtypeREAL2:
4725 error = ffetarget_eq_real2 (&val,
4726 ffebld_constant_real2 (ffebld_conter (l)),
4727 ffebld_constant_real2 (ffebld_conter (r)));
4728 expr = ffebld_new_conter_with_orig
4729 (ffebld_constant_new_logicaldefault (val), expr);
4730 break;
4731 #endif
4732
4733 #if FFETARGET_okREAL3
4734 case FFEINFO_kindtypeREAL3:
4735 error = ffetarget_eq_real3 (&val,
4736 ffebld_constant_real3 (ffebld_conter (l)),
4737 ffebld_constant_real3 (ffebld_conter (r)));
4738 expr = ffebld_new_conter_with_orig
4739 (ffebld_constant_new_logicaldefault (val), expr);
4740 break;
4741 #endif
4742
4743 #if FFETARGET_okREAL4
4744 case FFEINFO_kindtypeREAL4:
4745 error = ffetarget_eq_real4 (&val,
4746 ffebld_constant_real4 (ffebld_conter (l)),
4747 ffebld_constant_real4 (ffebld_conter (r)));
4748 expr = ffebld_new_conter_with_orig
4749 (ffebld_constant_new_logicaldefault (val), expr);
4750 break;
4751 #endif
4752
4753 default:
4754 assert ("bad real kind type" == NULL);
4755 break;
4756 }
4757 break;
4758
4759 case FFEINFO_basictypeCOMPLEX:
4760 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4761 {
4762 #if FFETARGET_okCOMPLEX1
4763 case FFEINFO_kindtypeREAL1:
4764 error = ffetarget_eq_complex1 (&val,
4765 ffebld_constant_complex1 (ffebld_conter (l)),
4766 ffebld_constant_complex1 (ffebld_conter (r)));
4767 expr = ffebld_new_conter_with_orig
4768 (ffebld_constant_new_logicaldefault (val), expr);
4769 break;
4770 #endif
4771
4772 #if FFETARGET_okCOMPLEX2
4773 case FFEINFO_kindtypeREAL2:
4774 error = ffetarget_eq_complex2 (&val,
4775 ffebld_constant_complex2 (ffebld_conter (l)),
4776 ffebld_constant_complex2 (ffebld_conter (r)));
4777 expr = ffebld_new_conter_with_orig
4778 (ffebld_constant_new_logicaldefault (val), expr);
4779 break;
4780 #endif
4781
4782 #if FFETARGET_okCOMPLEX3
4783 case FFEINFO_kindtypeREAL3:
4784 error = ffetarget_eq_complex3 (&val,
4785 ffebld_constant_complex3 (ffebld_conter (l)),
4786 ffebld_constant_complex3 (ffebld_conter (r)));
4787 expr = ffebld_new_conter_with_orig
4788 (ffebld_constant_new_logicaldefault (val), expr);
4789 break;
4790 #endif
4791
4792 #if FFETARGET_okCOMPLEX4
4793 case FFEINFO_kindtypeREAL4:
4794 error = ffetarget_eq_complex4 (&val,
4795 ffebld_constant_complex4 (ffebld_conter (l)),
4796 ffebld_constant_complex4 (ffebld_conter (r)));
4797 expr = ffebld_new_conter_with_orig
4798 (ffebld_constant_new_logicaldefault (val), expr);
4799 break;
4800 #endif
4801
4802 default:
4803 assert ("bad complex kind type" == NULL);
4804 break;
4805 }
4806 break;
4807
4808 case FFEINFO_basictypeCHARACTER:
4809 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4810 {
4811 #if FFETARGET_okCHARACTER1
4812 case FFEINFO_kindtypeCHARACTER1:
4813 error = ffetarget_eq_character1 (&val,
4814 ffebld_constant_character1 (ffebld_conter (l)),
4815 ffebld_constant_character1 (ffebld_conter (r)));
4816 expr = ffebld_new_conter_with_orig
4817 (ffebld_constant_new_logicaldefault (val), expr);
4818 break;
4819 #endif
4820
4821 #if FFETARGET_okCHARACTER2
4822 case FFEINFO_kindtypeCHARACTER2:
4823 error = ffetarget_eq_character2 (&val,
4824 ffebld_constant_character2 (ffebld_conter (l)),
4825 ffebld_constant_character2 (ffebld_conter (r)));
4826 expr = ffebld_new_conter_with_orig
4827 (ffebld_constant_new_logicaldefault (val), expr);
4828 break;
4829 #endif
4830
4831 #if FFETARGET_okCHARACTER3
4832 case FFEINFO_kindtypeCHARACTER3:
4833 error = ffetarget_eq_character3 (&val,
4834 ffebld_constant_character3 (ffebld_conter (l)),
4835 ffebld_constant_character3 (ffebld_conter (r)));
4836 expr = ffebld_new_conter_with_orig
4837 (ffebld_constant_new_logicaldefault (val), expr);
4838 break;
4839 #endif
4840
4841 #if FFETARGET_okCHARACTER4
4842 case FFEINFO_kindtypeCHARACTER4:
4843 error = ffetarget_eq_character4 (&val,
4844 ffebld_constant_character4 (ffebld_conter (l)),
4845 ffebld_constant_character4 (ffebld_conter (r)));
4846 expr = ffebld_new_conter_with_orig
4847 (ffebld_constant_new_logicaldefault (val), expr);
4848 break;
4849 #endif
4850
4851 default:
4852 assert ("bad character kind type" == NULL);
4853 break;
4854 }
4855 break;
4856
4857 default:
4858 assert ("bad type" == NULL);
4859 return expr;
4860 }
4861
4862 ffebld_set_info (expr, ffeinfo_new
4863 (FFEINFO_basictypeLOGICAL,
4864 FFEINFO_kindtypeLOGICALDEFAULT,
4865 0,
4866 FFEINFO_kindENTITY,
4867 FFEINFO_whereCONSTANT,
4868 FFETARGET_charactersizeNONE));
4869
4870 if ((error != FFEBAD)
4871 && ffebad_start (error))
4872 {
4873 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4874 ffebad_finish ();
4875 }
4876
4877 return expr;
4878 }
4879
4880 /* ffeexpr_collapse_ne -- Collapse ne expr
4881
4882 ffebld expr;
4883 ffelexToken token;
4884 expr = ffeexpr_collapse_ne(expr,token);
4885
4886 If the result of the expr is a constant, replaces the expr with the
4887 computed constant. */
4888
4889 ffebld
4890 ffeexpr_collapse_ne (ffebld expr, ffelexToken t)
4891 {
4892 ffebad error = FFEBAD;
4893 ffebld l;
4894 ffebld r;
4895 bool val;
4896
4897 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4898 return expr;
4899
4900 l = ffebld_left (expr);
4901 r = ffebld_right (expr);
4902
4903 if (ffebld_op (l) != FFEBLD_opCONTER)
4904 return expr;
4905 if (ffebld_op (r) != FFEBLD_opCONTER)
4906 return expr;
4907
4908 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4909 {
4910 case FFEINFO_basictypeANY:
4911 return expr;
4912
4913 case FFEINFO_basictypeINTEGER:
4914 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4915 {
4916 #if FFETARGET_okINTEGER1
4917 case FFEINFO_kindtypeINTEGER1:
4918 error = ffetarget_ne_integer1 (&val,
4919 ffebld_constant_integer1 (ffebld_conter (l)),
4920 ffebld_constant_integer1 (ffebld_conter (r)));
4921 expr = ffebld_new_conter_with_orig
4922 (ffebld_constant_new_logicaldefault (val), expr);
4923 break;
4924 #endif
4925
4926 #if FFETARGET_okINTEGER2
4927 case FFEINFO_kindtypeINTEGER2:
4928 error = ffetarget_ne_integer2 (&val,
4929 ffebld_constant_integer2 (ffebld_conter (l)),
4930 ffebld_constant_integer2 (ffebld_conter (r)));
4931 expr = ffebld_new_conter_with_orig
4932 (ffebld_constant_new_logicaldefault (val), expr);
4933 break;
4934 #endif
4935
4936 #if FFETARGET_okINTEGER3
4937 case FFEINFO_kindtypeINTEGER3:
4938 error = ffetarget_ne_integer3 (&val,
4939 ffebld_constant_integer3 (ffebld_conter (l)),
4940 ffebld_constant_integer3 (ffebld_conter (r)));
4941 expr = ffebld_new_conter_with_orig
4942 (ffebld_constant_new_logicaldefault (val), expr);
4943 break;
4944 #endif
4945
4946 #if FFETARGET_okINTEGER4
4947 case FFEINFO_kindtypeINTEGER4:
4948 error = ffetarget_ne_integer4 (&val,
4949 ffebld_constant_integer4 (ffebld_conter (l)),
4950 ffebld_constant_integer4 (ffebld_conter (r)));
4951 expr = ffebld_new_conter_with_orig
4952 (ffebld_constant_new_logicaldefault (val), expr);
4953 break;
4954 #endif
4955
4956 default:
4957 assert ("bad integer kind type" == NULL);
4958 break;
4959 }
4960 break;
4961
4962 case FFEINFO_basictypeREAL:
4963 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4964 {
4965 #if FFETARGET_okREAL1
4966 case FFEINFO_kindtypeREAL1:
4967 error = ffetarget_ne_real1 (&val,
4968 ffebld_constant_real1 (ffebld_conter (l)),
4969 ffebld_constant_real1 (ffebld_conter (r)));
4970 expr = ffebld_new_conter_with_orig
4971 (ffebld_constant_new_logicaldefault (val), expr);
4972 break;
4973 #endif
4974
4975 #if FFETARGET_okREAL2
4976 case FFEINFO_kindtypeREAL2:
4977 error = ffetarget_ne_real2 (&val,
4978 ffebld_constant_real2 (ffebld_conter (l)),
4979 ffebld_constant_real2 (ffebld_conter (r)));
4980 expr = ffebld_new_conter_with_orig
4981 (ffebld_constant_new_logicaldefault (val), expr);
4982 break;
4983 #endif
4984
4985 #if FFETARGET_okREAL3
4986 case FFEINFO_kindtypeREAL3:
4987 error = ffetarget_ne_real3 (&val,
4988 ffebld_constant_real3 (ffebld_conter (l)),
4989 ffebld_constant_real3 (ffebld_conter (r)));
4990 expr = ffebld_new_conter_with_orig
4991 (ffebld_constant_new_logicaldefault (val), expr);
4992 break;
4993 #endif
4994
4995 #if FFETARGET_okREAL4
4996 case FFEINFO_kindtypeREAL4:
4997 error = ffetarget_ne_real4 (&val,
4998 ffebld_constant_real4 (ffebld_conter (l)),
4999 ffebld_constant_real4 (ffebld_conter (r)));
5000 expr = ffebld_new_conter_with_orig
5001 (ffebld_constant_new_logicaldefault (val), expr);
5002 break;
5003 #endif
5004
5005 default:
5006 assert ("bad real kind type" == NULL);
5007 break;
5008 }
5009 break;
5010
5011 case FFEINFO_basictypeCOMPLEX:
5012 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5013 {
5014 #if FFETARGET_okCOMPLEX1
5015 case FFEINFO_kindtypeREAL1:
5016 error = ffetarget_ne_complex1 (&val,
5017 ffebld_constant_complex1 (ffebld_conter (l)),
5018 ffebld_constant_complex1 (ffebld_conter (r)));
5019 expr = ffebld_new_conter_with_orig
5020 (ffebld_constant_new_logicaldefault (val), expr);
5021 break;
5022 #endif
5023
5024 #if FFETARGET_okCOMPLEX2
5025 case FFEINFO_kindtypeREAL2:
5026 error = ffetarget_ne_complex2 (&val,
5027 ffebld_constant_complex2 (ffebld_conter (l)),
5028 ffebld_constant_complex2 (ffebld_conter (r)));
5029 expr = ffebld_new_conter_with_orig
5030 (ffebld_constant_new_logicaldefault (val), expr);
5031 break;
5032 #endif
5033
5034 #if FFETARGET_okCOMPLEX3
5035 case FFEINFO_kindtypeREAL3:
5036 error = ffetarget_ne_complex3 (&val,
5037 ffebld_constant_complex3 (ffebld_conter (l)),
5038 ffebld_constant_complex3 (ffebld_conter (r)));
5039 expr = ffebld_new_conter_with_orig
5040 (ffebld_constant_new_logicaldefault (val), expr);
5041 break;
5042 #endif
5043
5044 #if FFETARGET_okCOMPLEX4
5045 case FFEINFO_kindtypeREAL4:
5046 error = ffetarget_ne_complex4 (&val,
5047 ffebld_constant_complex4 (ffebld_conter (l)),
5048 ffebld_constant_complex4 (ffebld_conter (r)));
5049 expr = ffebld_new_conter_with_orig
5050 (ffebld_constant_new_logicaldefault (val), expr);
5051 break;
5052 #endif
5053
5054 default:
5055 assert ("bad complex kind type" == NULL);
5056 break;
5057 }
5058 break;
5059
5060 case FFEINFO_basictypeCHARACTER:
5061 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5062 {
5063 #if FFETARGET_okCHARACTER1
5064 case FFEINFO_kindtypeCHARACTER1:
5065 error = ffetarget_ne_character1 (&val,
5066 ffebld_constant_character1 (ffebld_conter (l)),
5067 ffebld_constant_character1 (ffebld_conter (r)));
5068 expr = ffebld_new_conter_with_orig
5069 (ffebld_constant_new_logicaldefault (val), expr);
5070 break;
5071 #endif
5072
5073 #if FFETARGET_okCHARACTER2
5074 case FFEINFO_kindtypeCHARACTER2:
5075 error = ffetarget_ne_character2 (&val,
5076 ffebld_constant_character2 (ffebld_conter (l)),
5077 ffebld_constant_character2 (ffebld_conter (r)));
5078 expr = ffebld_new_conter_with_orig
5079 (ffebld_constant_new_logicaldefault (val), expr);
5080 break;
5081 #endif
5082
5083 #if FFETARGET_okCHARACTER3
5084 case FFEINFO_kindtypeCHARACTER3:
5085 error = ffetarget_ne_character3 (&val,
5086 ffebld_constant_character3 (ffebld_conter (l)),
5087 ffebld_constant_character3 (ffebld_conter (r)));
5088 expr = ffebld_new_conter_with_orig
5089 (ffebld_constant_new_logicaldefault (val), expr);
5090 break;
5091 #endif
5092
5093 #if FFETARGET_okCHARACTER4
5094 case FFEINFO_kindtypeCHARACTER4:
5095 error = ffetarget_ne_character4 (&val,
5096 ffebld_constant_character4 (ffebld_conter (l)),
5097 ffebld_constant_character4 (ffebld_conter (r)));
5098 expr = ffebld_new_conter_with_orig
5099 (ffebld_constant_new_logicaldefault (val), expr);
5100 break;
5101 #endif
5102
5103 default:
5104 assert ("bad character kind type" == NULL);
5105 break;
5106 }
5107 break;
5108
5109 default:
5110 assert ("bad type" == NULL);
5111 return expr;
5112 }
5113
5114 ffebld_set_info (expr, ffeinfo_new
5115 (FFEINFO_basictypeLOGICAL,
5116 FFEINFO_kindtypeLOGICALDEFAULT,
5117 0,
5118 FFEINFO_kindENTITY,
5119 FFEINFO_whereCONSTANT,
5120 FFETARGET_charactersizeNONE));
5121
5122 if ((error != FFEBAD)
5123 && ffebad_start (error))
5124 {
5125 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5126 ffebad_finish ();
5127 }
5128
5129 return expr;
5130 }
5131
5132 /* ffeexpr_collapse_ge -- Collapse ge expr
5133
5134 ffebld expr;
5135 ffelexToken token;
5136 expr = ffeexpr_collapse_ge(expr,token);
5137
5138 If the result of the expr is a constant, replaces the expr with the
5139 computed constant. */
5140
5141 ffebld
5142 ffeexpr_collapse_ge (ffebld expr, ffelexToken t)
5143 {
5144 ffebad error = FFEBAD;
5145 ffebld l;
5146 ffebld r;
5147 bool val;
5148
5149 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5150 return expr;
5151
5152 l = ffebld_left (expr);
5153 r = ffebld_right (expr);
5154
5155 if (ffebld_op (l) != FFEBLD_opCONTER)
5156 return expr;
5157 if (ffebld_op (r) != FFEBLD_opCONTER)
5158 return expr;
5159
5160 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5161 {
5162 case FFEINFO_basictypeANY:
5163 return expr;
5164
5165 case FFEINFO_basictypeINTEGER:
5166 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5167 {
5168 #if FFETARGET_okINTEGER1
5169 case FFEINFO_kindtypeINTEGER1:
5170 error = ffetarget_ge_integer1 (&val,
5171 ffebld_constant_integer1 (ffebld_conter (l)),
5172 ffebld_constant_integer1 (ffebld_conter (r)));
5173 expr = ffebld_new_conter_with_orig
5174 (ffebld_constant_new_logicaldefault (val), expr);
5175 break;
5176 #endif
5177
5178 #if FFETARGET_okINTEGER2
5179 case FFEINFO_kindtypeINTEGER2:
5180 error = ffetarget_ge_integer2 (&val,
5181 ffebld_constant_integer2 (ffebld_conter (l)),
5182 ffebld_constant_integer2 (ffebld_conter (r)));
5183 expr = ffebld_new_conter_with_orig
5184 (ffebld_constant_new_logicaldefault (val), expr);
5185 break;
5186 #endif
5187
5188 #if FFETARGET_okINTEGER3
5189 case FFEINFO_kindtypeINTEGER3:
5190 error = ffetarget_ge_integer3 (&val,
5191 ffebld_constant_integer3 (ffebld_conter (l)),
5192 ffebld_constant_integer3 (ffebld_conter (r)));
5193 expr = ffebld_new_conter_with_orig
5194 (ffebld_constant_new_logicaldefault (val), expr);
5195 break;
5196 #endif
5197
5198 #if FFETARGET_okINTEGER4
5199 case FFEINFO_kindtypeINTEGER4:
5200 error = ffetarget_ge_integer4 (&val,
5201 ffebld_constant_integer4 (ffebld_conter (l)),
5202 ffebld_constant_integer4 (ffebld_conter (r)));
5203 expr = ffebld_new_conter_with_orig
5204 (ffebld_constant_new_logicaldefault (val), expr);
5205 break;
5206 #endif
5207
5208 default:
5209 assert ("bad integer kind type" == NULL);
5210 break;
5211 }
5212 break;
5213
5214 case FFEINFO_basictypeREAL:
5215 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5216 {
5217 #if FFETARGET_okREAL1
5218 case FFEINFO_kindtypeREAL1:
5219 error = ffetarget_ge_real1 (&val,
5220 ffebld_constant_real1 (ffebld_conter (l)),
5221 ffebld_constant_real1 (ffebld_conter (r)));
5222 expr = ffebld_new_conter_with_orig
5223 (ffebld_constant_new_logicaldefault (val), expr);
5224 break;
5225 #endif
5226
5227 #if FFETARGET_okREAL2
5228 case FFEINFO_kindtypeREAL2:
5229 error = ffetarget_ge_real2 (&val,
5230 ffebld_constant_real2 (ffebld_conter (l)),
5231 ffebld_constant_real2 (ffebld_conter (r)));
5232 expr = ffebld_new_conter_with_orig
5233 (ffebld_constant_new_logicaldefault (val), expr);
5234 break;
5235 #endif
5236
5237 #if FFETARGET_okREAL3
5238 case FFEINFO_kindtypeREAL3:
5239 error = ffetarget_ge_real3 (&val,
5240 ffebld_constant_real3 (ffebld_conter (l)),
5241 ffebld_constant_real3 (ffebld_conter (r)));
5242 expr = ffebld_new_conter_with_orig
5243 (ffebld_constant_new_logicaldefault (val), expr);
5244 break;
5245 #endif
5246
5247 #if FFETARGET_okREAL4
5248 case FFEINFO_kindtypeREAL4:
5249 error = ffetarget_ge_real4 (&val,
5250 ffebld_constant_real4 (ffebld_conter (l)),
5251 ffebld_constant_real4 (ffebld_conter (r)));
5252 expr = ffebld_new_conter_with_orig
5253 (ffebld_constant_new_logicaldefault (val), expr);
5254 break;
5255 #endif
5256
5257 default:
5258 assert ("bad real kind type" == NULL);
5259 break;
5260 }
5261 break;
5262
5263 case FFEINFO_basictypeCHARACTER:
5264 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5265 {
5266 #if FFETARGET_okCHARACTER1
5267 case FFEINFO_kindtypeCHARACTER1:
5268 error = ffetarget_ge_character1 (&val,
5269 ffebld_constant_character1 (ffebld_conter (l)),
5270 ffebld_constant_character1 (ffebld_conter (r)));
5271 expr = ffebld_new_conter_with_orig
5272 (ffebld_constant_new_logicaldefault (val), expr);
5273 break;
5274 #endif
5275
5276 #if FFETARGET_okCHARACTER2
5277 case FFEINFO_kindtypeCHARACTER2:
5278 error = ffetarget_ge_character2 (&val,
5279 ffebld_constant_character2 (ffebld_conter (l)),
5280 ffebld_constant_character2 (ffebld_conter (r)));
5281 expr = ffebld_new_conter_with_orig
5282 (ffebld_constant_new_logicaldefault (val), expr);
5283 break;
5284 #endif
5285
5286 #if FFETARGET_okCHARACTER3
5287 case FFEINFO_kindtypeCHARACTER3:
5288 error = ffetarget_ge_character3 (&val,
5289 ffebld_constant_character3 (ffebld_conter (l)),
5290 ffebld_constant_character3 (ffebld_conter (r)));
5291 expr = ffebld_new_conter_with_orig
5292 (ffebld_constant_new_logicaldefault (val), expr);
5293 break;
5294 #endif
5295
5296 #if FFETARGET_okCHARACTER4
5297 case FFEINFO_kindtypeCHARACTER4:
5298 error = ffetarget_ge_character4 (&val,
5299 ffebld_constant_character4 (ffebld_conter (l)),
5300 ffebld_constant_character4 (ffebld_conter (r)));
5301 expr = ffebld_new_conter_with_orig
5302 (ffebld_constant_new_logicaldefault (val), expr);
5303 break;
5304 #endif
5305
5306 default:
5307 assert ("bad character kind type" == NULL);
5308 break;
5309 }
5310 break;
5311
5312 default:
5313 assert ("bad type" == NULL);
5314 return expr;
5315 }
5316
5317 ffebld_set_info (expr, ffeinfo_new
5318 (FFEINFO_basictypeLOGICAL,
5319 FFEINFO_kindtypeLOGICALDEFAULT,
5320 0,
5321 FFEINFO_kindENTITY,
5322 FFEINFO_whereCONSTANT,
5323 FFETARGET_charactersizeNONE));
5324
5325 if ((error != FFEBAD)
5326 && ffebad_start (error))
5327 {
5328 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5329 ffebad_finish ();
5330 }
5331
5332 return expr;
5333 }
5334
5335 /* ffeexpr_collapse_gt -- Collapse gt expr
5336
5337 ffebld expr;
5338 ffelexToken token;
5339 expr = ffeexpr_collapse_gt(expr,token);
5340
5341 If the result of the expr is a constant, replaces the expr with the
5342 computed constant. */
5343
5344 ffebld
5345 ffeexpr_collapse_gt (ffebld expr, ffelexToken t)
5346 {
5347 ffebad error = FFEBAD;
5348 ffebld l;
5349 ffebld r;
5350 bool val;
5351
5352 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5353 return expr;
5354
5355 l = ffebld_left (expr);
5356 r = ffebld_right (expr);
5357
5358 if (ffebld_op (l) != FFEBLD_opCONTER)
5359 return expr;
5360 if (ffebld_op (r) != FFEBLD_opCONTER)
5361 return expr;
5362
5363 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5364 {
5365 case FFEINFO_basictypeANY:
5366 return expr;
5367
5368 case FFEINFO_basictypeINTEGER:
5369 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5370 {
5371 #if FFETARGET_okINTEGER1
5372 case FFEINFO_kindtypeINTEGER1:
5373 error = ffetarget_gt_integer1 (&val,
5374 ffebld_constant_integer1 (ffebld_conter (l)),
5375 ffebld_constant_integer1 (ffebld_conter (r)));
5376 expr = ffebld_new_conter_with_orig
5377 (ffebld_constant_new_logicaldefault (val), expr);
5378 break;
5379 #endif
5380
5381 #if FFETARGET_okINTEGER2
5382 case FFEINFO_kindtypeINTEGER2:
5383 error = ffetarget_gt_integer2 (&val,
5384 ffebld_constant_integer2 (ffebld_conter (l)),
5385 ffebld_constant_integer2 (ffebld_conter (r)));
5386 expr = ffebld_new_conter_with_orig
5387 (ffebld_constant_new_logicaldefault (val), expr);
5388 break;
5389 #endif
5390
5391 #if FFETARGET_okINTEGER3
5392 case FFEINFO_kindtypeINTEGER3:
5393 error = ffetarget_gt_integer3 (&val,
5394 ffebld_constant_integer3 (ffebld_conter (l)),
5395 ffebld_constant_integer3 (ffebld_conter (r)));
5396 expr = ffebld_new_conter_with_orig
5397 (ffebld_constant_new_logicaldefault (val), expr);
5398 break;
5399 #endif
5400
5401 #if FFETARGET_okINTEGER4
5402 case FFEINFO_kindtypeINTEGER4:
5403 error = ffetarget_gt_integer4 (&val,
5404 ffebld_constant_integer4 (ffebld_conter (l)),
5405 ffebld_constant_integer4 (ffebld_conter (r)));
5406 expr = ffebld_new_conter_with_orig
5407 (ffebld_constant_new_logicaldefault (val), expr);
5408 break;
5409 #endif
5410
5411 default:
5412 assert ("bad integer kind type" == NULL);
5413 break;
5414 }
5415 break;
5416
5417 case FFEINFO_basictypeREAL:
5418 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5419 {
5420 #if FFETARGET_okREAL1
5421 case FFEINFO_kindtypeREAL1:
5422 error = ffetarget_gt_real1 (&val,
5423 ffebld_constant_real1 (ffebld_conter (l)),
5424 ffebld_constant_real1 (ffebld_conter (r)));
5425 expr = ffebld_new_conter_with_orig
5426 (ffebld_constant_new_logicaldefault (val), expr);
5427 break;
5428 #endif
5429
5430 #if FFETARGET_okREAL2
5431 case FFEINFO_kindtypeREAL2:
5432 error = ffetarget_gt_real2 (&val,
5433 ffebld_constant_real2 (ffebld_conter (l)),
5434 ffebld_constant_real2 (ffebld_conter (r)));
5435 expr = ffebld_new_conter_with_orig
5436 (ffebld_constant_new_logicaldefault (val), expr);
5437 break;
5438 #endif
5439
5440 #if FFETARGET_okREAL3
5441 case FFEINFO_kindtypeREAL3:
5442 error = ffetarget_gt_real3 (&val,
5443 ffebld_constant_real3 (ffebld_conter (l)),
5444 ffebld_constant_real3 (ffebld_conter (r)));
5445 expr = ffebld_new_conter_with_orig
5446 (ffebld_constant_new_logicaldefault (val), expr);
5447 break;
5448 #endif
5449
5450 #if FFETARGET_okREAL4
5451 case FFEINFO_kindtypeREAL4:
5452 error = ffetarget_gt_real4 (&val,
5453 ffebld_constant_real4 (ffebld_conter (l)),
5454 ffebld_constant_real4 (ffebld_conter (r)));
5455 expr = ffebld_new_conter_with_orig
5456 (ffebld_constant_new_logicaldefault (val), expr);
5457 break;
5458 #endif
5459
5460 default:
5461 assert ("bad real kind type" == NULL);
5462 break;
5463 }
5464 break;
5465
5466 case FFEINFO_basictypeCHARACTER:
5467 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5468 {
5469 #if FFETARGET_okCHARACTER1
5470 case FFEINFO_kindtypeCHARACTER1:
5471 error = ffetarget_gt_character1 (&val,
5472 ffebld_constant_character1 (ffebld_conter (l)),
5473 ffebld_constant_character1 (ffebld_conter (r)));
5474 expr = ffebld_new_conter_with_orig
5475 (ffebld_constant_new_logicaldefault (val), expr);
5476 break;
5477 #endif
5478
5479 #if FFETARGET_okCHARACTER2
5480 case FFEINFO_kindtypeCHARACTER2:
5481 error = ffetarget_gt_character2 (&val,
5482 ffebld_constant_character2 (ffebld_conter (l)),
5483 ffebld_constant_character2 (ffebld_conter (r)));
5484 expr = ffebld_new_conter_with_orig
5485 (ffebld_constant_new_logicaldefault (val), expr);
5486 break;
5487 #endif
5488
5489 #if FFETARGET_okCHARACTER3
5490 case FFEINFO_kindtypeCHARACTER3:
5491 error = ffetarget_gt_character3 (&val,
5492 ffebld_constant_character3 (ffebld_conter (l)),
5493 ffebld_constant_character3 (ffebld_conter (r)));
5494 expr = ffebld_new_conter_with_orig
5495 (ffebld_constant_new_logicaldefault (val), expr);
5496 break;
5497 #endif
5498
5499 #if FFETARGET_okCHARACTER4
5500 case FFEINFO_kindtypeCHARACTER4:
5501 error = ffetarget_gt_character4 (&val,
5502 ffebld_constant_character4 (ffebld_conter (l)),
5503 ffebld_constant_character4 (ffebld_conter (r)));
5504 expr = ffebld_new_conter_with_orig
5505 (ffebld_constant_new_logicaldefault (val), expr);
5506 break;
5507 #endif
5508
5509 default:
5510 assert ("bad character kind type" == NULL);
5511 break;
5512 }
5513 break;
5514
5515 default:
5516 assert ("bad type" == NULL);
5517 return expr;
5518 }
5519
5520 ffebld_set_info (expr, ffeinfo_new
5521 (FFEINFO_basictypeLOGICAL,
5522 FFEINFO_kindtypeLOGICALDEFAULT,
5523 0,
5524 FFEINFO_kindENTITY,
5525 FFEINFO_whereCONSTANT,
5526 FFETARGET_charactersizeNONE));
5527
5528 if ((error != FFEBAD)
5529 && ffebad_start (error))
5530 {
5531 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5532 ffebad_finish ();
5533 }
5534
5535 return expr;
5536 }
5537
5538 /* ffeexpr_collapse_le -- Collapse le expr
5539
5540 ffebld expr;
5541 ffelexToken token;
5542 expr = ffeexpr_collapse_le(expr,token);
5543
5544 If the result of the expr is a constant, replaces the expr with the
5545 computed constant. */
5546
5547 ffebld
5548 ffeexpr_collapse_le (ffebld expr, ffelexToken t)
5549 {
5550 ffebad error = FFEBAD;
5551 ffebld l;
5552 ffebld r;
5553 bool val;
5554
5555 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5556 return expr;
5557
5558 l = ffebld_left (expr);
5559 r = ffebld_right (expr);
5560
5561 if (ffebld_op (l) != FFEBLD_opCONTER)
5562 return expr;
5563 if (ffebld_op (r) != FFEBLD_opCONTER)
5564 return expr;
5565
5566 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5567 {
5568 case FFEINFO_basictypeANY:
5569 return expr;
5570
5571 case FFEINFO_basictypeINTEGER:
5572 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5573 {
5574 #if FFETARGET_okINTEGER1
5575 case FFEINFO_kindtypeINTEGER1:
5576 error = ffetarget_le_integer1 (&val,
5577 ffebld_constant_integer1 (ffebld_conter (l)),
5578 ffebld_constant_integer1 (ffebld_conter (r)));
5579 expr = ffebld_new_conter_with_orig
5580 (ffebld_constant_new_logicaldefault (val), expr);
5581 break;
5582 #endif
5583
5584 #if FFETARGET_okINTEGER2
5585 case FFEINFO_kindtypeINTEGER2:
5586 error = ffetarget_le_integer2 (&val,
5587 ffebld_constant_integer2 (ffebld_conter (l)),
5588 ffebld_constant_integer2 (ffebld_conter (r)));
5589 expr = ffebld_new_conter_with_orig
5590 (ffebld_constant_new_logicaldefault (val), expr);
5591 break;
5592 #endif
5593
5594 #if FFETARGET_okINTEGER3
5595 case FFEINFO_kindtypeINTEGER3:
5596 error = ffetarget_le_integer3 (&val,
5597 ffebld_constant_integer3 (ffebld_conter (l)),
5598 ffebld_constant_integer3 (ffebld_conter (r)));
5599 expr = ffebld_new_conter_with_orig
5600 (ffebld_constant_new_logicaldefault (val), expr);
5601 break;
5602 #endif
5603
5604 #if FFETARGET_okINTEGER4
5605 case FFEINFO_kindtypeINTEGER4:
5606 error = ffetarget_le_integer4 (&val,
5607 ffebld_constant_integer4 (ffebld_conter (l)),
5608 ffebld_constant_integer4 (ffebld_conter (r)));
5609 expr = ffebld_new_conter_with_orig
5610 (ffebld_constant_new_logicaldefault (val), expr);
5611 break;
5612 #endif
5613
5614 default:
5615 assert ("bad integer kind type" == NULL);
5616 break;
5617 }
5618 break;
5619
5620 case FFEINFO_basictypeREAL:
5621 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5622 {
5623 #if FFETARGET_okREAL1
5624 case FFEINFO_kindtypeREAL1:
5625 error = ffetarget_le_real1 (&val,
5626 ffebld_constant_real1 (ffebld_conter (l)),
5627 ffebld_constant_real1 (ffebld_conter (r)));
5628 expr = ffebld_new_conter_with_orig
5629 (ffebld_constant_new_logicaldefault (val), expr);
5630 break;
5631 #endif
5632
5633 #if FFETARGET_okREAL2
5634 case FFEINFO_kindtypeREAL2:
5635 error = ffetarget_le_real2 (&val,
5636 ffebld_constant_real2 (ffebld_conter (l)),
5637 ffebld_constant_real2 (ffebld_conter (r)));
5638 expr = ffebld_new_conter_with_orig
5639 (ffebld_constant_new_logicaldefault (val), expr);
5640 break;
5641 #endif
5642
5643 #if FFETARGET_okREAL3
5644 case FFEINFO_kindtypeREAL3:
5645 error = ffetarget_le_real3 (&val,
5646 ffebld_constant_real3 (ffebld_conter (l)),
5647 ffebld_constant_real3 (ffebld_conter (r)));
5648 expr = ffebld_new_conter_with_orig
5649 (ffebld_constant_new_logicaldefault (val), expr);
5650 break;
5651 #endif
5652
5653 #if FFETARGET_okREAL4
5654 case FFEINFO_kindtypeREAL4:
5655 error = ffetarget_le_real4 (&val,
5656 ffebld_constant_real4 (ffebld_conter (l)),
5657 ffebld_constant_real4 (ffebld_conter (r)));
5658 expr = ffebld_new_conter_with_orig
5659 (ffebld_constant_new_logicaldefault (val), expr);
5660 break;
5661 #endif
5662
5663 default:
5664 assert ("bad real kind type" == NULL);
5665 break;
5666 }
5667 break;
5668
5669 case FFEINFO_basictypeCHARACTER:
5670 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5671 {
5672 #if FFETARGET_okCHARACTER1
5673 case FFEINFO_kindtypeCHARACTER1:
5674 error = ffetarget_le_character1 (&val,
5675 ffebld_constant_character1 (ffebld_conter (l)),
5676 ffebld_constant_character1 (ffebld_conter (r)));
5677 expr = ffebld_new_conter_with_orig
5678 (ffebld_constant_new_logicaldefault (val), expr);
5679 break;
5680 #endif
5681
5682 #if FFETARGET_okCHARACTER2
5683 case FFEINFO_kindtypeCHARACTER2:
5684 error = ffetarget_le_character2 (&val,
5685 ffebld_constant_character2 (ffebld_conter (l)),
5686 ffebld_constant_character2 (ffebld_conter (r)));
5687 expr = ffebld_new_conter_with_orig
5688 (ffebld_constant_new_logicaldefault (val), expr);
5689 break;
5690 #endif
5691
5692 #if FFETARGET_okCHARACTER3
5693 case FFEINFO_kindtypeCHARACTER3:
5694 error = ffetarget_le_character3 (&val,
5695 ffebld_constant_character3 (ffebld_conter (l)),
5696 ffebld_constant_character3 (ffebld_conter (r)));
5697 expr = ffebld_new_conter_with_orig
5698 (ffebld_constant_new_logicaldefault (val), expr);
5699 break;
5700 #endif
5701
5702 #if FFETARGET_okCHARACTER4
5703 case FFEINFO_kindtypeCHARACTER4:
5704 error = ffetarget_le_character4 (&val,
5705 ffebld_constant_character4 (ffebld_conter (l)),
5706 ffebld_constant_character4 (ffebld_conter (r)));
5707 expr = ffebld_new_conter_with_orig
5708 (ffebld_constant_new_logicaldefault (val), expr);
5709 break;
5710 #endif
5711
5712 default:
5713 assert ("bad character kind type" == NULL);
5714 break;
5715 }
5716 break;
5717
5718 default:
5719 assert ("bad type" == NULL);
5720 return expr;
5721 }
5722
5723 ffebld_set_info (expr, ffeinfo_new
5724 (FFEINFO_basictypeLOGICAL,
5725 FFEINFO_kindtypeLOGICALDEFAULT,
5726 0,
5727 FFEINFO_kindENTITY,
5728 FFEINFO_whereCONSTANT,
5729 FFETARGET_charactersizeNONE));
5730
5731 if ((error != FFEBAD)
5732 && ffebad_start (error))
5733 {
5734 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5735 ffebad_finish ();
5736 }
5737
5738 return expr;
5739 }
5740
5741 /* ffeexpr_collapse_lt -- Collapse lt expr
5742
5743 ffebld expr;
5744 ffelexToken token;
5745 expr = ffeexpr_collapse_lt(expr,token);
5746
5747 If the result of the expr is a constant, replaces the expr with the
5748 computed constant. */
5749
5750 ffebld
5751 ffeexpr_collapse_lt (ffebld expr, ffelexToken t)
5752 {
5753 ffebad error = FFEBAD;
5754 ffebld l;
5755 ffebld r;
5756 bool val;
5757
5758 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5759 return expr;
5760
5761 l = ffebld_left (expr);
5762 r = ffebld_right (expr);
5763
5764 if (ffebld_op (l) != FFEBLD_opCONTER)
5765 return expr;
5766 if (ffebld_op (r) != FFEBLD_opCONTER)
5767 return expr;
5768
5769 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5770 {
5771 case FFEINFO_basictypeANY:
5772 return expr;
5773
5774 case FFEINFO_basictypeINTEGER:
5775 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5776 {
5777 #if FFETARGET_okINTEGER1
5778 case FFEINFO_kindtypeINTEGER1:
5779 error = ffetarget_lt_integer1 (&val,
5780 ffebld_constant_integer1 (ffebld_conter (l)),
5781 ffebld_constant_integer1 (ffebld_conter (r)));
5782 expr = ffebld_new_conter_with_orig
5783 (ffebld_constant_new_logicaldefault (val), expr);
5784 break;
5785 #endif
5786
5787 #if FFETARGET_okINTEGER2
5788 case FFEINFO_kindtypeINTEGER2:
5789 error = ffetarget_lt_integer2 (&val,
5790 ffebld_constant_integer2 (ffebld_conter (l)),
5791 ffebld_constant_integer2 (ffebld_conter (r)));
5792 expr = ffebld_new_conter_with_orig
5793 (ffebld_constant_new_logicaldefault (val), expr);
5794 break;
5795 #endif
5796
5797 #if FFETARGET_okINTEGER3
5798 case FFEINFO_kindtypeINTEGER3:
5799 error = ffetarget_lt_integer3 (&val,
5800 ffebld_constant_integer3 (ffebld_conter (l)),
5801 ffebld_constant_integer3 (ffebld_conter (r)));
5802 expr = ffebld_new_conter_with_orig
5803 (ffebld_constant_new_logicaldefault (val), expr);
5804 break;
5805 #endif
5806
5807 #if FFETARGET_okINTEGER4
5808 case FFEINFO_kindtypeINTEGER4:
5809 error = ffetarget_lt_integer4 (&val,
5810 ffebld_constant_integer4 (ffebld_conter (l)),
5811 ffebld_constant_integer4 (ffebld_conter (r)));
5812 expr = ffebld_new_conter_with_orig
5813 (ffebld_constant_new_logicaldefault (val), expr);
5814 break;
5815 #endif
5816
5817 default:
5818 assert ("bad integer kind type" == NULL);
5819 break;
5820 }
5821 break;
5822
5823 case FFEINFO_basictypeREAL:
5824 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5825 {
5826 #if FFETARGET_okREAL1
5827 case FFEINFO_kindtypeREAL1:
5828 error = ffetarget_lt_real1 (&val,
5829 ffebld_constant_real1 (ffebld_conter (l)),
5830 ffebld_constant_real1 (ffebld_conter (r)));
5831 expr = ffebld_new_conter_with_orig
5832 (ffebld_constant_new_logicaldefault (val), expr);
5833 break;
5834 #endif
5835
5836 #if FFETARGET_okREAL2
5837 case FFEINFO_kindtypeREAL2:
5838 error = ffetarget_lt_real2 (&val,
5839 ffebld_constant_real2 (ffebld_conter (l)),
5840 ffebld_constant_real2 (ffebld_conter (r)));
5841 expr = ffebld_new_conter_with_orig
5842 (ffebld_constant_new_logicaldefault (val), expr);
5843 break;
5844 #endif
5845
5846 #if FFETARGET_okREAL3
5847 case FFEINFO_kindtypeREAL3:
5848 error = ffetarget_lt_real3 (&val,
5849 ffebld_constant_real3 (ffebld_conter (l)),
5850 ffebld_constant_real3 (ffebld_conter (r)));
5851 expr = ffebld_new_conter_with_orig
5852 (ffebld_constant_new_logicaldefault (val), expr);
5853 break;
5854 #endif
5855
5856 #if FFETARGET_okREAL4
5857 case FFEINFO_kindtypeREAL4:
5858 error = ffetarget_lt_real4 (&val,
5859 ffebld_constant_real4 (ffebld_conter (l)),
5860 ffebld_constant_real4 (ffebld_conter (r)));
5861 expr = ffebld_new_conter_with_orig
5862 (ffebld_constant_new_logicaldefault (val), expr);
5863 break;
5864 #endif
5865
5866 default:
5867 assert ("bad real kind type" == NULL);
5868 break;
5869 }
5870 break;
5871
5872 case FFEINFO_basictypeCHARACTER:
5873 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5874 {
5875 #if FFETARGET_okCHARACTER1
5876 case FFEINFO_kindtypeCHARACTER1:
5877 error = ffetarget_lt_character1 (&val,
5878 ffebld_constant_character1 (ffebld_conter (l)),
5879 ffebld_constant_character1 (ffebld_conter (r)));
5880 expr = ffebld_new_conter_with_orig
5881 (ffebld_constant_new_logicaldefault (val), expr);
5882 break;
5883 #endif
5884
5885 #if FFETARGET_okCHARACTER2
5886 case FFEINFO_kindtypeCHARACTER2:
5887 error = ffetarget_lt_character2 (&val,
5888 ffebld_constant_character2 (ffebld_conter (l)),
5889 ffebld_constant_character2 (ffebld_conter (r)));
5890 expr = ffebld_new_conter_with_orig
5891 (ffebld_constant_new_logicaldefault (val), expr);
5892 break;
5893 #endif
5894
5895 #if FFETARGET_okCHARACTER3
5896 case FFEINFO_kindtypeCHARACTER3:
5897 error = ffetarget_lt_character3 (&val,
5898 ffebld_constant_character3 (ffebld_conter (l)),
5899 ffebld_constant_character3 (ffebld_conter (r)));
5900 expr = ffebld_new_conter_with_orig
5901 (ffebld_constant_new_logicaldefault (val), expr);
5902 break;
5903 #endif
5904
5905 #if FFETARGET_okCHARACTER4
5906 case FFEINFO_kindtypeCHARACTER4:
5907 error = ffetarget_lt_character4 (&val,
5908 ffebld_constant_character4 (ffebld_conter (l)),
5909 ffebld_constant_character4 (ffebld_conter (r)));
5910 expr = ffebld_new_conter_with_orig
5911 (ffebld_constant_new_logicaldefault (val), expr);
5912 break;
5913 #endif
5914
5915 default:
5916 assert ("bad character kind type" == NULL);
5917 break;
5918 }
5919 break;
5920
5921 default:
5922 assert ("bad type" == NULL);
5923 return expr;
5924 }
5925
5926 ffebld_set_info (expr, ffeinfo_new
5927 (FFEINFO_basictypeLOGICAL,
5928 FFEINFO_kindtypeLOGICALDEFAULT,
5929 0,
5930 FFEINFO_kindENTITY,
5931 FFEINFO_whereCONSTANT,
5932 FFETARGET_charactersizeNONE));
5933
5934 if ((error != FFEBAD)
5935 && ffebad_start (error))
5936 {
5937 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5938 ffebad_finish ();
5939 }
5940
5941 return expr;
5942 }
5943
5944 /* ffeexpr_collapse_and -- Collapse and expr
5945
5946 ffebld expr;
5947 ffelexToken token;
5948 expr = ffeexpr_collapse_and(expr,token);
5949
5950 If the result of the expr is a constant, replaces the expr with the
5951 computed constant. */
5952
5953 ffebld
5954 ffeexpr_collapse_and (ffebld expr, ffelexToken t)
5955 {
5956 ffebad error = FFEBAD;
5957 ffebld l;
5958 ffebld r;
5959 ffebldConstantUnion u;
5960 ffeinfoBasictype bt;
5961 ffeinfoKindtype kt;
5962
5963 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5964 return expr;
5965
5966 l = ffebld_left (expr);
5967 r = ffebld_right (expr);
5968
5969 if (ffebld_op (l) != FFEBLD_opCONTER)
5970 return expr;
5971 if (ffebld_op (r) != FFEBLD_opCONTER)
5972 return expr;
5973
5974 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5975 {
5976 case FFEINFO_basictypeANY:
5977 return expr;
5978
5979 case FFEINFO_basictypeINTEGER:
5980 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5981 {
5982 #if FFETARGET_okINTEGER1
5983 case FFEINFO_kindtypeINTEGER1:
5984 error = ffetarget_and_integer1 (ffebld_cu_ptr_integer1 (u),
5985 ffebld_constant_integer1 (ffebld_conter (l)),
5986 ffebld_constant_integer1 (ffebld_conter (r)));
5987 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5988 (ffebld_cu_val_integer1 (u)), expr);
5989 break;
5990 #endif
5991
5992 #if FFETARGET_okINTEGER2
5993 case FFEINFO_kindtypeINTEGER2:
5994 error = ffetarget_and_integer2 (ffebld_cu_ptr_integer2 (u),
5995 ffebld_constant_integer2 (ffebld_conter (l)),
5996 ffebld_constant_integer2 (ffebld_conter (r)));
5997 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5998 (ffebld_cu_val_integer2 (u)), expr);
5999 break;
6000 #endif
6001
6002 #if FFETARGET_okINTEGER3
6003 case FFEINFO_kindtypeINTEGER3:
6004 error = ffetarget_and_integer3 (ffebld_cu_ptr_integer3 (u),
6005 ffebld_constant_integer3 (ffebld_conter (l)),
6006 ffebld_constant_integer3 (ffebld_conter (r)));
6007 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6008 (ffebld_cu_val_integer3 (u)), expr);
6009 break;
6010 #endif
6011
6012 #if FFETARGET_okINTEGER4
6013 case FFEINFO_kindtypeINTEGER4:
6014 error = ffetarget_and_integer4 (ffebld_cu_ptr_integer4 (u),
6015 ffebld_constant_integer4 (ffebld_conter (l)),
6016 ffebld_constant_integer4 (ffebld_conter (r)));
6017 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6018 (ffebld_cu_val_integer4 (u)), expr);
6019 break;
6020 #endif
6021
6022 default:
6023 assert ("bad integer kind type" == NULL);
6024 break;
6025 }
6026 break;
6027
6028 case FFEINFO_basictypeLOGICAL:
6029 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6030 {
6031 #if FFETARGET_okLOGICAL1
6032 case FFEINFO_kindtypeLOGICAL1:
6033 error = ffetarget_and_logical1 (ffebld_cu_ptr_logical1 (u),
6034 ffebld_constant_logical1 (ffebld_conter (l)),
6035 ffebld_constant_logical1 (ffebld_conter (r)));
6036 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6037 (ffebld_cu_val_logical1 (u)), expr);
6038 break;
6039 #endif
6040
6041 #if FFETARGET_okLOGICAL2
6042 case FFEINFO_kindtypeLOGICAL2:
6043 error = ffetarget_and_logical2 (ffebld_cu_ptr_logical2 (u),
6044 ffebld_constant_logical2 (ffebld_conter (l)),
6045 ffebld_constant_logical2 (ffebld_conter (r)));
6046 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6047 (ffebld_cu_val_logical2 (u)), expr);
6048 break;
6049 #endif
6050
6051 #if FFETARGET_okLOGICAL3
6052 case FFEINFO_kindtypeLOGICAL3:
6053 error = ffetarget_and_logical3 (ffebld_cu_ptr_logical3 (u),
6054 ffebld_constant_logical3 (ffebld_conter (l)),
6055 ffebld_constant_logical3 (ffebld_conter (r)));
6056 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6057 (ffebld_cu_val_logical3 (u)), expr);
6058 break;
6059 #endif
6060
6061 #if FFETARGET_okLOGICAL4
6062 case FFEINFO_kindtypeLOGICAL4:
6063 error = ffetarget_and_logical4 (ffebld_cu_ptr_logical4 (u),
6064 ffebld_constant_logical4 (ffebld_conter (l)),
6065 ffebld_constant_logical4 (ffebld_conter (r)));
6066 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6067 (ffebld_cu_val_logical4 (u)), expr);
6068 break;
6069 #endif
6070
6071 default:
6072 assert ("bad logical kind type" == NULL);
6073 break;
6074 }
6075 break;
6076
6077 default:
6078 assert ("bad type" == NULL);
6079 return expr;
6080 }
6081
6082 ffebld_set_info (expr, ffeinfo_new
6083 (bt,
6084 kt,
6085 0,
6086 FFEINFO_kindENTITY,
6087 FFEINFO_whereCONSTANT,
6088 FFETARGET_charactersizeNONE));
6089
6090 if ((error != FFEBAD)
6091 && ffebad_start (error))
6092 {
6093 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6094 ffebad_finish ();
6095 }
6096
6097 return expr;
6098 }
6099
6100 /* ffeexpr_collapse_or -- Collapse or expr
6101
6102 ffebld expr;
6103 ffelexToken token;
6104 expr = ffeexpr_collapse_or(expr,token);
6105
6106 If the result of the expr is a constant, replaces the expr with the
6107 computed constant. */
6108
6109 ffebld
6110 ffeexpr_collapse_or (ffebld expr, ffelexToken t)
6111 {
6112 ffebad error = FFEBAD;
6113 ffebld l;
6114 ffebld r;
6115 ffebldConstantUnion u;
6116 ffeinfoBasictype bt;
6117 ffeinfoKindtype kt;
6118
6119 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6120 return expr;
6121
6122 l = ffebld_left (expr);
6123 r = ffebld_right (expr);
6124
6125 if (ffebld_op (l) != FFEBLD_opCONTER)
6126 return expr;
6127 if (ffebld_op (r) != FFEBLD_opCONTER)
6128 return expr;
6129
6130 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6131 {
6132 case FFEINFO_basictypeANY:
6133 return expr;
6134
6135 case FFEINFO_basictypeINTEGER:
6136 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6137 {
6138 #if FFETARGET_okINTEGER1
6139 case FFEINFO_kindtypeINTEGER1:
6140 error = ffetarget_or_integer1 (ffebld_cu_ptr_integer1 (u),
6141 ffebld_constant_integer1 (ffebld_conter (l)),
6142 ffebld_constant_integer1 (ffebld_conter (r)));
6143 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6144 (ffebld_cu_val_integer1 (u)), expr);
6145 break;
6146 #endif
6147
6148 #if FFETARGET_okINTEGER2
6149 case FFEINFO_kindtypeINTEGER2:
6150 error = ffetarget_or_integer2 (ffebld_cu_ptr_integer2 (u),
6151 ffebld_constant_integer2 (ffebld_conter (l)),
6152 ffebld_constant_integer2 (ffebld_conter (r)));
6153 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6154 (ffebld_cu_val_integer2 (u)), expr);
6155 break;
6156 #endif
6157
6158 #if FFETARGET_okINTEGER3
6159 case FFEINFO_kindtypeINTEGER3:
6160 error = ffetarget_or_integer3 (ffebld_cu_ptr_integer3 (u),
6161 ffebld_constant_integer3 (ffebld_conter (l)),
6162 ffebld_constant_integer3 (ffebld_conter (r)));
6163 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6164 (ffebld_cu_val_integer3 (u)), expr);
6165 break;
6166 #endif
6167
6168 #if FFETARGET_okINTEGER4
6169 case FFEINFO_kindtypeINTEGER4:
6170 error = ffetarget_or_integer4 (ffebld_cu_ptr_integer4 (u),
6171 ffebld_constant_integer4 (ffebld_conter (l)),
6172 ffebld_constant_integer4 (ffebld_conter (r)));
6173 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6174 (ffebld_cu_val_integer4 (u)), expr);
6175 break;
6176 #endif
6177
6178 default:
6179 assert ("bad integer kind type" == NULL);
6180 break;
6181 }
6182 break;
6183
6184 case FFEINFO_basictypeLOGICAL:
6185 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6186 {
6187 #if FFETARGET_okLOGICAL1
6188 case FFEINFO_kindtypeLOGICAL1:
6189 error = ffetarget_or_logical1 (ffebld_cu_ptr_logical1 (u),
6190 ffebld_constant_logical1 (ffebld_conter (l)),
6191 ffebld_constant_logical1 (ffebld_conter (r)));
6192 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6193 (ffebld_cu_val_logical1 (u)), expr);
6194 break;
6195 #endif
6196
6197 #if FFETARGET_okLOGICAL2
6198 case FFEINFO_kindtypeLOGICAL2:
6199 error = ffetarget_or_logical2 (ffebld_cu_ptr_logical2 (u),
6200 ffebld_constant_logical2 (ffebld_conter (l)),
6201 ffebld_constant_logical2 (ffebld_conter (r)));
6202 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6203 (ffebld_cu_val_logical2 (u)), expr);
6204 break;
6205 #endif
6206
6207 #if FFETARGET_okLOGICAL3
6208 case FFEINFO_kindtypeLOGICAL3:
6209 error = ffetarget_or_logical3 (ffebld_cu_ptr_logical3 (u),
6210 ffebld_constant_logical3 (ffebld_conter (l)),
6211 ffebld_constant_logical3 (ffebld_conter (r)));
6212 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6213 (ffebld_cu_val_logical3 (u)), expr);
6214 break;
6215 #endif
6216
6217 #if FFETARGET_okLOGICAL4
6218 case FFEINFO_kindtypeLOGICAL4:
6219 error = ffetarget_or_logical4 (ffebld_cu_ptr_logical4 (u),
6220 ffebld_constant_logical4 (ffebld_conter (l)),
6221 ffebld_constant_logical4 (ffebld_conter (r)));
6222 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6223 (ffebld_cu_val_logical4 (u)), expr);
6224 break;
6225 #endif
6226
6227 default:
6228 assert ("bad logical kind type" == NULL);
6229 break;
6230 }
6231 break;
6232
6233 default:
6234 assert ("bad type" == NULL);
6235 return expr;
6236 }
6237
6238 ffebld_set_info (expr, ffeinfo_new
6239 (bt,
6240 kt,
6241 0,
6242 FFEINFO_kindENTITY,
6243 FFEINFO_whereCONSTANT,
6244 FFETARGET_charactersizeNONE));
6245
6246 if ((error != FFEBAD)
6247 && ffebad_start (error))
6248 {
6249 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6250 ffebad_finish ();
6251 }
6252
6253 return expr;
6254 }
6255
6256 /* ffeexpr_collapse_xor -- Collapse xor expr
6257
6258 ffebld expr;
6259 ffelexToken token;
6260 expr = ffeexpr_collapse_xor(expr,token);
6261
6262 If the result of the expr is a constant, replaces the expr with the
6263 computed constant. */
6264
6265 ffebld
6266 ffeexpr_collapse_xor (ffebld expr, ffelexToken t)
6267 {
6268 ffebad error = FFEBAD;
6269 ffebld l;
6270 ffebld r;
6271 ffebldConstantUnion u;
6272 ffeinfoBasictype bt;
6273 ffeinfoKindtype kt;
6274
6275 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6276 return expr;
6277
6278 l = ffebld_left (expr);
6279 r = ffebld_right (expr);
6280
6281 if (ffebld_op (l) != FFEBLD_opCONTER)
6282 return expr;
6283 if (ffebld_op (r) != FFEBLD_opCONTER)
6284 return expr;
6285
6286 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6287 {
6288 case FFEINFO_basictypeANY:
6289 return expr;
6290
6291 case FFEINFO_basictypeINTEGER:
6292 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6293 {
6294 #if FFETARGET_okINTEGER1
6295 case FFEINFO_kindtypeINTEGER1:
6296 error = ffetarget_xor_integer1 (ffebld_cu_ptr_integer1 (u),
6297 ffebld_constant_integer1 (ffebld_conter (l)),
6298 ffebld_constant_integer1 (ffebld_conter (r)));
6299 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6300 (ffebld_cu_val_integer1 (u)), expr);
6301 break;
6302 #endif
6303
6304 #if FFETARGET_okINTEGER2
6305 case FFEINFO_kindtypeINTEGER2:
6306 error = ffetarget_xor_integer2 (ffebld_cu_ptr_integer2 (u),
6307 ffebld_constant_integer2 (ffebld_conter (l)),
6308 ffebld_constant_integer2 (ffebld_conter (r)));
6309 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6310 (ffebld_cu_val_integer2 (u)), expr);
6311 break;
6312 #endif
6313
6314 #if FFETARGET_okINTEGER3
6315 case FFEINFO_kindtypeINTEGER3:
6316 error = ffetarget_xor_integer3 (ffebld_cu_ptr_integer3 (u),
6317 ffebld_constant_integer3 (ffebld_conter (l)),
6318 ffebld_constant_integer3 (ffebld_conter (r)));
6319 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6320 (ffebld_cu_val_integer3 (u)), expr);
6321 break;
6322 #endif
6323
6324 #if FFETARGET_okINTEGER4
6325 case FFEINFO_kindtypeINTEGER4:
6326 error = ffetarget_xor_integer4 (ffebld_cu_ptr_integer4 (u),
6327 ffebld_constant_integer4 (ffebld_conter (l)),
6328 ffebld_constant_integer4 (ffebld_conter (r)));
6329 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6330 (ffebld_cu_val_integer4 (u)), expr);
6331 break;
6332 #endif
6333
6334 default:
6335 assert ("bad integer kind type" == NULL);
6336 break;
6337 }
6338 break;
6339
6340 case FFEINFO_basictypeLOGICAL:
6341 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6342 {
6343 #if FFETARGET_okLOGICAL1
6344 case FFEINFO_kindtypeLOGICAL1:
6345 error = ffetarget_xor_logical1 (ffebld_cu_ptr_logical1 (u),
6346 ffebld_constant_logical1 (ffebld_conter (l)),
6347 ffebld_constant_logical1 (ffebld_conter (r)));
6348 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6349 (ffebld_cu_val_logical1 (u)), expr);
6350 break;
6351 #endif
6352
6353 #if FFETARGET_okLOGICAL2
6354 case FFEINFO_kindtypeLOGICAL2:
6355 error = ffetarget_xor_logical2 (ffebld_cu_ptr_logical2 (u),
6356 ffebld_constant_logical2 (ffebld_conter (l)),
6357 ffebld_constant_logical2 (ffebld_conter (r)));
6358 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6359 (ffebld_cu_val_logical2 (u)), expr);
6360 break;
6361 #endif
6362
6363 #if FFETARGET_okLOGICAL3
6364 case FFEINFO_kindtypeLOGICAL3:
6365 error = ffetarget_xor_logical3 (ffebld_cu_ptr_logical3 (u),
6366 ffebld_constant_logical3 (ffebld_conter (l)),
6367 ffebld_constant_logical3 (ffebld_conter (r)));
6368 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6369 (ffebld_cu_val_logical3 (u)), expr);
6370 break;
6371 #endif
6372
6373 #if FFETARGET_okLOGICAL4
6374 case FFEINFO_kindtypeLOGICAL4:
6375 error = ffetarget_xor_logical4 (ffebld_cu_ptr_logical4 (u),
6376 ffebld_constant_logical4 (ffebld_conter (l)),
6377 ffebld_constant_logical4 (ffebld_conter (r)));
6378 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6379 (ffebld_cu_val_logical4 (u)), expr);
6380 break;
6381 #endif
6382
6383 default:
6384 assert ("bad logical kind type" == NULL);
6385 break;
6386 }
6387 break;
6388
6389 default:
6390 assert ("bad type" == NULL);
6391 return expr;
6392 }
6393
6394 ffebld_set_info (expr, ffeinfo_new
6395 (bt,
6396 kt,
6397 0,
6398 FFEINFO_kindENTITY,
6399 FFEINFO_whereCONSTANT,
6400 FFETARGET_charactersizeNONE));
6401
6402 if ((error != FFEBAD)
6403 && ffebad_start (error))
6404 {
6405 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6406 ffebad_finish ();
6407 }
6408
6409 return expr;
6410 }
6411
6412 /* ffeexpr_collapse_eqv -- Collapse eqv expr
6413
6414 ffebld expr;
6415 ffelexToken token;
6416 expr = ffeexpr_collapse_eqv(expr,token);
6417
6418 If the result of the expr is a constant, replaces the expr with the
6419 computed constant. */
6420
6421 ffebld
6422 ffeexpr_collapse_eqv (ffebld expr, ffelexToken t)
6423 {
6424 ffebad error = FFEBAD;
6425 ffebld l;
6426 ffebld r;
6427 ffebldConstantUnion u;
6428 ffeinfoBasictype bt;
6429 ffeinfoKindtype kt;
6430
6431 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6432 return expr;
6433
6434 l = ffebld_left (expr);
6435 r = ffebld_right (expr);
6436
6437 if (ffebld_op (l) != FFEBLD_opCONTER)
6438 return expr;
6439 if (ffebld_op (r) != FFEBLD_opCONTER)
6440 return expr;
6441
6442 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6443 {
6444 case FFEINFO_basictypeANY:
6445 return expr;
6446
6447 case FFEINFO_basictypeINTEGER:
6448 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6449 {
6450 #if FFETARGET_okINTEGER1
6451 case FFEINFO_kindtypeINTEGER1:
6452 error = ffetarget_eqv_integer1 (ffebld_cu_ptr_integer1 (u),
6453 ffebld_constant_integer1 (ffebld_conter (l)),
6454 ffebld_constant_integer1 (ffebld_conter (r)));
6455 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6456 (ffebld_cu_val_integer1 (u)), expr);
6457 break;
6458 #endif
6459
6460 #if FFETARGET_okINTEGER2
6461 case FFEINFO_kindtypeINTEGER2:
6462 error = ffetarget_eqv_integer2 (ffebld_cu_ptr_integer2 (u),
6463 ffebld_constant_integer2 (ffebld_conter (l)),
6464 ffebld_constant_integer2 (ffebld_conter (r)));
6465 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6466 (ffebld_cu_val_integer2 (u)), expr);
6467 break;
6468 #endif
6469
6470 #if FFETARGET_okINTEGER3
6471 case FFEINFO_kindtypeINTEGER3:
6472 error = ffetarget_eqv_integer3 (ffebld_cu_ptr_integer3 (u),
6473 ffebld_constant_integer3 (ffebld_conter (l)),
6474 ffebld_constant_integer3 (ffebld_conter (r)));
6475 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6476 (ffebld_cu_val_integer3 (u)), expr);
6477 break;
6478 #endif
6479
6480 #if FFETARGET_okINTEGER4
6481 case FFEINFO_kindtypeINTEGER4:
6482 error = ffetarget_eqv_integer4 (ffebld_cu_ptr_integer4 (u),
6483 ffebld_constant_integer4 (ffebld_conter (l)),
6484 ffebld_constant_integer4 (ffebld_conter (r)));
6485 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6486 (ffebld_cu_val_integer4 (u)), expr);
6487 break;
6488 #endif
6489
6490 default:
6491 assert ("bad integer kind type" == NULL);
6492 break;
6493 }
6494 break;
6495
6496 case FFEINFO_basictypeLOGICAL:
6497 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6498 {
6499 #if FFETARGET_okLOGICAL1
6500 case FFEINFO_kindtypeLOGICAL1:
6501 error = ffetarget_eqv_logical1 (ffebld_cu_ptr_logical1 (u),
6502 ffebld_constant_logical1 (ffebld_conter (l)),
6503 ffebld_constant_logical1 (ffebld_conter (r)));
6504 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6505 (ffebld_cu_val_logical1 (u)), expr);
6506 break;
6507 #endif
6508
6509 #if FFETARGET_okLOGICAL2
6510 case FFEINFO_kindtypeLOGICAL2:
6511 error = ffetarget_eqv_logical2 (ffebld_cu_ptr_logical2 (u),
6512 ffebld_constant_logical2 (ffebld_conter (l)),
6513 ffebld_constant_logical2 (ffebld_conter (r)));
6514 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6515 (ffebld_cu_val_logical2 (u)), expr);
6516 break;
6517 #endif
6518
6519 #if FFETARGET_okLOGICAL3
6520 case FFEINFO_kindtypeLOGICAL3:
6521 error = ffetarget_eqv_logical3 (ffebld_cu_ptr_logical3 (u),
6522 ffebld_constant_logical3 (ffebld_conter (l)),
6523 ffebld_constant_logical3 (ffebld_conter (r)));
6524 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6525 (ffebld_cu_val_logical3 (u)), expr);
6526 break;
6527 #endif
6528
6529 #if FFETARGET_okLOGICAL4
6530 case FFEINFO_kindtypeLOGICAL4:
6531 error = ffetarget_eqv_logical4 (ffebld_cu_ptr_logical4 (u),
6532 ffebld_constant_logical4 (ffebld_conter (l)),
6533 ffebld_constant_logical4 (ffebld_conter (r)));
6534 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6535 (ffebld_cu_val_logical4 (u)), expr);
6536 break;
6537 #endif
6538
6539 default:
6540 assert ("bad logical kind type" == NULL);
6541 break;
6542 }
6543 break;
6544
6545 default:
6546 assert ("bad type" == NULL);
6547 return expr;
6548 }
6549
6550 ffebld_set_info (expr, ffeinfo_new
6551 (bt,
6552 kt,
6553 0,
6554 FFEINFO_kindENTITY,
6555 FFEINFO_whereCONSTANT,
6556 FFETARGET_charactersizeNONE));
6557
6558 if ((error != FFEBAD)
6559 && ffebad_start (error))
6560 {
6561 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6562 ffebad_finish ();
6563 }
6564
6565 return expr;
6566 }
6567
6568 /* ffeexpr_collapse_neqv -- Collapse neqv expr
6569
6570 ffebld expr;
6571 ffelexToken token;
6572 expr = ffeexpr_collapse_neqv(expr,token);
6573
6574 If the result of the expr is a constant, replaces the expr with the
6575 computed constant. */
6576
6577 ffebld
6578 ffeexpr_collapse_neqv (ffebld expr, ffelexToken t)
6579 {
6580 ffebad error = FFEBAD;
6581 ffebld l;
6582 ffebld r;
6583 ffebldConstantUnion u;
6584 ffeinfoBasictype bt;
6585 ffeinfoKindtype kt;
6586
6587 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6588 return expr;
6589
6590 l = ffebld_left (expr);
6591 r = ffebld_right (expr);
6592
6593 if (ffebld_op (l) != FFEBLD_opCONTER)
6594 return expr;
6595 if (ffebld_op (r) != FFEBLD_opCONTER)
6596 return expr;
6597
6598 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6599 {
6600 case FFEINFO_basictypeANY:
6601 return expr;
6602
6603 case FFEINFO_basictypeINTEGER:
6604 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6605 {
6606 #if FFETARGET_okINTEGER1
6607 case FFEINFO_kindtypeINTEGER1:
6608 error = ffetarget_neqv_integer1 (ffebld_cu_ptr_integer1 (u),
6609 ffebld_constant_integer1 (ffebld_conter (l)),
6610 ffebld_constant_integer1 (ffebld_conter (r)));
6611 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6612 (ffebld_cu_val_integer1 (u)), expr);
6613 break;
6614 #endif
6615
6616 #if FFETARGET_okINTEGER2
6617 case FFEINFO_kindtypeINTEGER2:
6618 error = ffetarget_neqv_integer2 (ffebld_cu_ptr_integer2 (u),
6619 ffebld_constant_integer2 (ffebld_conter (l)),
6620 ffebld_constant_integer2 (ffebld_conter (r)));
6621 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6622 (ffebld_cu_val_integer2 (u)), expr);
6623 break;
6624 #endif
6625
6626 #if FFETARGET_okINTEGER3
6627 case FFEINFO_kindtypeINTEGER3:
6628 error = ffetarget_neqv_integer3 (ffebld_cu_ptr_integer3 (u),
6629 ffebld_constant_integer3 (ffebld_conter (l)),
6630 ffebld_constant_integer3 (ffebld_conter (r)));
6631 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6632 (ffebld_cu_val_integer3 (u)), expr);
6633 break;
6634 #endif
6635
6636 #if FFETARGET_okINTEGER4
6637 case FFEINFO_kindtypeINTEGER4:
6638 error = ffetarget_neqv_integer4 (ffebld_cu_ptr_integer4 (u),
6639 ffebld_constant_integer4 (ffebld_conter (l)),
6640 ffebld_constant_integer4 (ffebld_conter (r)));
6641 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6642 (ffebld_cu_val_integer4 (u)), expr);
6643 break;
6644 #endif
6645
6646 default:
6647 assert ("bad integer kind type" == NULL);
6648 break;
6649 }
6650 break;
6651
6652 case FFEINFO_basictypeLOGICAL:
6653 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6654 {
6655 #if FFETARGET_okLOGICAL1
6656 case FFEINFO_kindtypeLOGICAL1:
6657 error = ffetarget_neqv_logical1 (ffebld_cu_ptr_logical1 (u),
6658 ffebld_constant_logical1 (ffebld_conter (l)),
6659 ffebld_constant_logical1 (ffebld_conter (r)));
6660 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6661 (ffebld_cu_val_logical1 (u)), expr);
6662 break;
6663 #endif
6664
6665 #if FFETARGET_okLOGICAL2
6666 case FFEINFO_kindtypeLOGICAL2:
6667 error = ffetarget_neqv_logical2 (ffebld_cu_ptr_logical2 (u),
6668 ffebld_constant_logical2 (ffebld_conter (l)),
6669 ffebld_constant_logical2 (ffebld_conter (r)));
6670 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6671 (ffebld_cu_val_logical2 (u)), expr);
6672 break;
6673 #endif
6674
6675 #if FFETARGET_okLOGICAL3
6676 case FFEINFO_kindtypeLOGICAL3:
6677 error = ffetarget_neqv_logical3 (ffebld_cu_ptr_logical3 (u),
6678 ffebld_constant_logical3 (ffebld_conter (l)),
6679 ffebld_constant_logical3 (ffebld_conter (r)));
6680 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6681 (ffebld_cu_val_logical3 (u)), expr);
6682 break;
6683 #endif
6684
6685 #if FFETARGET_okLOGICAL4
6686 case FFEINFO_kindtypeLOGICAL4:
6687 error = ffetarget_neqv_logical4 (ffebld_cu_ptr_logical4 (u),
6688 ffebld_constant_logical4 (ffebld_conter (l)),
6689 ffebld_constant_logical4 (ffebld_conter (r)));
6690 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6691 (ffebld_cu_val_logical4 (u)), expr);
6692 break;
6693 #endif
6694
6695 default:
6696 assert ("bad logical kind type" == NULL);
6697 break;
6698 }
6699 break;
6700
6701 default:
6702 assert ("bad type" == NULL);
6703 return expr;
6704 }
6705
6706 ffebld_set_info (expr, ffeinfo_new
6707 (bt,
6708 kt,
6709 0,
6710 FFEINFO_kindENTITY,
6711 FFEINFO_whereCONSTANT,
6712 FFETARGET_charactersizeNONE));
6713
6714 if ((error != FFEBAD)
6715 && ffebad_start (error))
6716 {
6717 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6718 ffebad_finish ();
6719 }
6720
6721 return expr;
6722 }
6723
6724 /* ffeexpr_collapse_symter -- Collapse symter expr
6725
6726 ffebld expr;
6727 ffelexToken token;
6728 expr = ffeexpr_collapse_symter(expr,token);
6729
6730 If the result of the expr is a constant, replaces the expr with the
6731 computed constant. */
6732
6733 ffebld
6734 ffeexpr_collapse_symter (ffebld expr, ffelexToken t UNUSED)
6735 {
6736 ffebld r;
6737 ffeinfoBasictype bt;
6738 ffeinfoKindtype kt;
6739 ffetargetCharacterSize len;
6740
6741 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6742 return expr;
6743
6744 if ((r = ffesymbol_init (ffebld_symter (expr))) == NULL)
6745 return expr; /* A PARAMETER lhs in progress. */
6746
6747 switch (ffebld_op (r))
6748 {
6749 case FFEBLD_opCONTER:
6750 break;
6751
6752 case FFEBLD_opANY:
6753 return r;
6754
6755 default:
6756 return expr;
6757 }
6758
6759 bt = ffeinfo_basictype (ffebld_info (r));
6760 kt = ffeinfo_kindtype (ffebld_info (r));
6761 len = ffebld_size (r);
6762
6763 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
6764 expr);
6765
6766 ffebld_set_info (expr, ffeinfo_new
6767 (bt,
6768 kt,
6769 0,
6770 FFEINFO_kindENTITY,
6771 FFEINFO_whereCONSTANT,
6772 len));
6773
6774 return expr;
6775 }
6776
6777 /* ffeexpr_collapse_funcref -- Collapse funcref expr
6778
6779 ffebld expr;
6780 ffelexToken token;
6781 expr = ffeexpr_collapse_funcref(expr,token);
6782
6783 If the result of the expr is a constant, replaces the expr with the
6784 computed constant. */
6785
6786 ffebld
6787 ffeexpr_collapse_funcref (ffebld expr, ffelexToken t UNUSED)
6788 {
6789 return expr; /* ~~someday go ahead and collapse these,
6790 though not required */
6791 }
6792
6793 /* ffeexpr_collapse_arrayref -- Collapse arrayref expr
6794
6795 ffebld expr;
6796 ffelexToken token;
6797 expr = ffeexpr_collapse_arrayref(expr,token);
6798
6799 If the result of the expr is a constant, replaces the expr with the
6800 computed constant. */
6801
6802 ffebld
6803 ffeexpr_collapse_arrayref (ffebld expr, ffelexToken t UNUSED)
6804 {
6805 return expr;
6806 }
6807
6808 /* ffeexpr_collapse_substr -- Collapse substr expr
6809
6810 ffebld expr;
6811 ffelexToken token;
6812 expr = ffeexpr_collapse_substr(expr,token);
6813
6814 If the result of the expr is a constant, replaces the expr with the
6815 computed constant. */
6816
6817 ffebld
6818 ffeexpr_collapse_substr (ffebld expr, ffelexToken t)
6819 {
6820 ffebad error = FFEBAD;
6821 ffebld l;
6822 ffebld r;
6823 ffebld start;
6824 ffebld stop;
6825 ffebldConstantUnion u;
6826 ffeinfoKindtype kt;
6827 ffetargetCharacterSize len;
6828 ffetargetIntegerDefault first;
6829 ffetargetIntegerDefault last;
6830
6831 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6832 return expr;
6833
6834 l = ffebld_left (expr);
6835 r = ffebld_right (expr); /* opITEM. */
6836
6837 if (ffebld_op (l) != FFEBLD_opCONTER)
6838 return expr;
6839
6840 kt = ffeinfo_kindtype (ffebld_info (l));
6841 len = ffebld_size (l);
6842
6843 start = ffebld_head (r);
6844 stop = ffebld_head (ffebld_trail (r));
6845 if (start == NULL)
6846 first = 1;
6847 else
6848 {
6849 if ((ffebld_op (start) != FFEBLD_opCONTER)
6850 || (ffeinfo_basictype (ffebld_info (start)) != FFEINFO_basictypeINTEGER)
6851 || (ffeinfo_kindtype (ffebld_info (start))
6852 != FFEINFO_kindtypeINTEGERDEFAULT))
6853 return expr;
6854 first = ffebld_constant_integerdefault (ffebld_conter (start));
6855 }
6856 if (stop == NULL)
6857 last = len;
6858 else
6859 {
6860 if ((ffebld_op (stop) != FFEBLD_opCONTER)
6861 || (ffeinfo_basictype (ffebld_info (stop)) != FFEINFO_basictypeINTEGER)
6862 || (ffeinfo_kindtype (ffebld_info (stop))
6863 != FFEINFO_kindtypeINTEGERDEFAULT))
6864 return expr;
6865 last = ffebld_constant_integerdefault (ffebld_conter (stop));
6866 }
6867
6868 /* Handle problems that should have already been diagnosed, but
6869 left in the expression tree. */
6870
6871 if (first <= 0)
6872 first = 1;
6873 if (last < first)
6874 last = first + len - 1;
6875
6876 if ((first == 1) && (last == len))
6877 { /* Same as original. */
6878 expr = ffebld_new_conter_with_orig (ffebld_constant_copy
6879 (ffebld_conter (l)), expr);
6880 ffebld_set_info (expr, ffeinfo_new
6881 (FFEINFO_basictypeCHARACTER,
6882 kt,
6883 0,
6884 FFEINFO_kindENTITY,
6885 FFEINFO_whereCONSTANT,
6886 len));
6887
6888 return expr;
6889 }
6890
6891 switch (ffeinfo_basictype (ffebld_info (expr)))
6892 {
6893 case FFEINFO_basictypeANY:
6894 return expr;
6895
6896 case FFEINFO_basictypeCHARACTER:
6897 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6898 {
6899 #if FFETARGET_okCHARACTER1
6900 case FFEINFO_kindtypeCHARACTER1:
6901 error = ffetarget_substr_character1 (ffebld_cu_ptr_character1 (u),
6902 ffebld_constant_character1 (ffebld_conter (l)), first, last,
6903 ffebld_constant_pool (), &len);
6904 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
6905 (ffebld_cu_val_character1 (u)), expr);
6906 break;
6907 #endif
6908
6909 #if FFETARGET_okCHARACTER2
6910 case FFEINFO_kindtypeCHARACTER2:
6911 error = ffetarget_substr_character2 (ffebld_cu_ptr_character2 (u),
6912 ffebld_constant_character2 (ffebld_conter (l)), first, last,
6913 ffebld_constant_pool (), &len);
6914 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val
6915 (ffebld_cu_val_character2 (u)), expr);
6916 break;
6917 #endif
6918
6919 #if FFETARGET_okCHARACTER3
6920 case FFEINFO_kindtypeCHARACTER3:
6921 error = ffetarget_substr_character3 (ffebld_cu_ptr_character3 (u),
6922 ffebld_constant_character3 (ffebld_conter (l)), first, last,
6923 ffebld_constant_pool (), &len);
6924 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val
6925 (ffebld_cu_val_character3 (u)), expr);
6926 break;
6927 #endif
6928
6929 #if FFETARGET_okCHARACTER4
6930 case FFEINFO_kindtypeCHARACTER4:
6931 error = ffetarget_substr_character4 (ffebld_cu_ptr_character4 (u),
6932 ffebld_constant_character4 (ffebld_conter (l)), first, last,
6933 ffebld_constant_pool (), &len);
6934 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val
6935 (ffebld_cu_val_character4 (u)), expr);
6936 break;
6937 #endif
6938
6939 default:
6940 assert ("bad character kind type" == NULL);
6941 break;
6942 }
6943 break;
6944
6945 default:
6946 assert ("bad type" == NULL);
6947 return expr;
6948 }
6949
6950 ffebld_set_info (expr, ffeinfo_new
6951 (FFEINFO_basictypeCHARACTER,
6952 kt,
6953 0,
6954 FFEINFO_kindENTITY,
6955 FFEINFO_whereCONSTANT,
6956 len));
6957
6958 if ((error != FFEBAD)
6959 && ffebad_start (error))
6960 {
6961 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6962 ffebad_finish ();
6963 }
6964
6965 return expr;
6966 }
6967
6968 /* ffeexpr_convert -- Convert source expression to given type
6969
6970 ffebld source;
6971 ffelexToken source_token;
6972 ffelexToken dest_token; // Any appropriate token for "destination".
6973 ffeinfoBasictype bt;
6974 ffeinfoKindtype kt;
6975 ffetargetCharactersize sz;
6976 ffeexprContext context; // Mainly LET or DATA.
6977 source = ffeexpr_convert(source,source_token,dest_token,bt,kt,sz,context);
6978
6979 If the expression conforms, returns the source expression. Otherwise
6980 returns source wrapped in a convert node doing the conversion, or
6981 ANY wrapped in convert if there is a conversion error (and issues an
6982 error message). Be sensitive to the context for certain aspects of
6983 the conversion. */
6984
6985 ffebld
6986 ffeexpr_convert (ffebld source, ffelexToken source_token, ffelexToken dest_token,
6987 ffeinfoBasictype bt, ffeinfoKindtype kt, ffeinfoRank rk,
6988 ffetargetCharacterSize sz, ffeexprContext context)
6989 {
6990 bool bad;
6991 ffeinfo info;
6992 ffeinfoWhere wh;
6993
6994 info = ffebld_info (source);
6995 if ((bt != ffeinfo_basictype (info))
6996 || (kt != ffeinfo_kindtype (info))
6997 || (rk != 0) /* Can't convert from or to arrays yet. */
6998 || (ffeinfo_rank (info) != 0)
6999 || (sz != ffebld_size_known (source)))
7000 #if 0 /* Nobody seems to need this spurious CONVERT node. */
7001 || ((context != FFEEXPR_contextLET)
7002 && (bt == FFEINFO_basictypeCHARACTER)
7003 && (sz == FFETARGET_charactersizeNONE)))
7004 #endif
7005 {
7006 switch (ffeinfo_basictype (info))
7007 {
7008 case FFEINFO_basictypeLOGICAL:
7009 switch (bt)
7010 {
7011 case FFEINFO_basictypeLOGICAL:
7012 bad = FALSE;
7013 break;
7014
7015 case FFEINFO_basictypeINTEGER:
7016 bad = !ffe_is_ugly_logint ();
7017 break;
7018
7019 case FFEINFO_basictypeCHARACTER:
7020 bad = ffe_is_pedantic ()
7021 || !(ffe_is_ugly_init ()
7022 && (context == FFEEXPR_contextDATA));
7023 break;
7024
7025 default:
7026 bad = TRUE;
7027 break;
7028 }
7029 break;
7030
7031 case FFEINFO_basictypeINTEGER:
7032 switch (bt)
7033 {
7034 case FFEINFO_basictypeINTEGER:
7035 case FFEINFO_basictypeREAL:
7036 case FFEINFO_basictypeCOMPLEX:
7037 bad = FALSE;
7038 break;
7039
7040 case FFEINFO_basictypeLOGICAL:
7041 bad = !ffe_is_ugly_logint ();
7042 break;
7043
7044 case FFEINFO_basictypeCHARACTER:
7045 bad = ffe_is_pedantic ()
7046 || !(ffe_is_ugly_init ()
7047 && (context == FFEEXPR_contextDATA));
7048 break;
7049
7050 default:
7051 bad = TRUE;
7052 break;
7053 }
7054 break;
7055
7056 case FFEINFO_basictypeREAL:
7057 case FFEINFO_basictypeCOMPLEX:
7058 switch (bt)
7059 {
7060 case FFEINFO_basictypeINTEGER:
7061 case FFEINFO_basictypeREAL:
7062 case FFEINFO_basictypeCOMPLEX:
7063 bad = FALSE;
7064 break;
7065
7066 case FFEINFO_basictypeCHARACTER:
7067 bad = TRUE;
7068 break;
7069
7070 default:
7071 bad = TRUE;
7072 break;
7073 }
7074 break;
7075
7076 case FFEINFO_basictypeCHARACTER:
7077 bad = (bt != FFEINFO_basictypeCHARACTER)
7078 && (ffe_is_pedantic ()
7079 || (bt != FFEINFO_basictypeINTEGER)
7080 || !(ffe_is_ugly_init ()
7081 && (context == FFEEXPR_contextDATA)));
7082 break;
7083
7084 case FFEINFO_basictypeTYPELESS:
7085 case FFEINFO_basictypeHOLLERITH:
7086 bad = ffe_is_pedantic ()
7087 || !(ffe_is_ugly_init ()
7088 && ((context == FFEEXPR_contextDATA)
7089 || (context == FFEEXPR_contextLET)));
7090 break;
7091
7092 default:
7093 bad = TRUE;
7094 break;
7095 }
7096
7097 if (!bad && ((rk != 0) || (ffeinfo_rank (info) != 0)))
7098 bad = TRUE;
7099
7100 if (bad && (bt != FFEINFO_basictypeANY) && (kt != FFEINFO_kindtypeANY)
7101 && (ffeinfo_basictype (info) != FFEINFO_basictypeANY)
7102 && (ffeinfo_kindtype (info) != FFEINFO_kindtypeANY)
7103 && (ffeinfo_where (info) != FFEINFO_whereANY))
7104 {
7105 if (ffebad_start (FFEBAD_BAD_TYPES))
7106 {
7107 if (dest_token == NULL)
7108 ffebad_here (0, ffewhere_line_unknown (),
7109 ffewhere_column_unknown ());
7110 else
7111 ffebad_here (0, ffelex_token_where_line (dest_token),
7112 ffelex_token_where_column (dest_token));
7113 assert (source_token != NULL);
7114 ffebad_here (1, ffelex_token_where_line (source_token),
7115 ffelex_token_where_column (source_token));
7116 ffebad_finish ();
7117 }
7118
7119 source = ffebld_new_any ();
7120 ffebld_set_info (source, ffeinfo_new_any ());
7121 }
7122 else
7123 {
7124 switch (ffeinfo_where (info))
7125 {
7126 case FFEINFO_whereCONSTANT:
7127 wh = FFEINFO_whereCONSTANT;
7128 break;
7129
7130 case FFEINFO_whereIMMEDIATE:
7131 wh = FFEINFO_whereIMMEDIATE;
7132 break;
7133
7134 default:
7135 wh = FFEINFO_whereFLEETING;
7136 break;
7137 }
7138 source = ffebld_new_convert (source);
7139 ffebld_set_info (source, ffeinfo_new
7140 (bt,
7141 kt,
7142 0,
7143 FFEINFO_kindENTITY,
7144 wh,
7145 sz));
7146 source = ffeexpr_collapse_convert (source, source_token);
7147 }
7148 }
7149
7150 return source;
7151 }
7152
7153 /* ffeexpr_convert_expr -- Convert source expr to conform to dest expr
7154
7155 ffebld source;
7156 ffebld dest;
7157 ffelexToken source_token;
7158 ffelexToken dest_token;
7159 ffeexprContext context;
7160 source = ffeexpr_convert_expr(source,source_token,dest,dest_token,context);
7161
7162 If the expressions conform, returns the source expression. Otherwise
7163 returns source wrapped in a convert node doing the conversion, or
7164 ANY wrapped in convert if there is a conversion error (and issues an
7165 error message). Be sensitive to the context, such as LET or DATA. */
7166
7167 ffebld
7168 ffeexpr_convert_expr (ffebld source, ffelexToken source_token, ffebld dest,
7169 ffelexToken dest_token, ffeexprContext context)
7170 {
7171 ffeinfo info;
7172
7173 info = ffebld_info (dest);
7174 return ffeexpr_convert (source, source_token, dest_token,
7175 ffeinfo_basictype (info),
7176 ffeinfo_kindtype (info),
7177 ffeinfo_rank (info),
7178 ffebld_size_known (dest),
7179 context);
7180 }
7181
7182 /* ffeexpr_convert_to_sym -- Convert source expression to conform to symbol
7183
7184 ffebld source;
7185 ffesymbol dest;
7186 ffelexToken source_token;
7187 ffelexToken dest_token;
7188 source = ffeexpr_convert_to_sym(source,source_token,dest,dest_token);
7189
7190 If the expressions conform, returns the source expression. Otherwise
7191 returns source wrapped in a convert node doing the conversion, or
7192 ANY wrapped in convert if there is a conversion error (and issues an
7193 error message). */
7194
7195 ffebld
7196 ffeexpr_convert_to_sym (ffebld source, ffelexToken source_token,
7197 ffesymbol dest, ffelexToken dest_token)
7198 {
7199 return ffeexpr_convert (source, source_token, dest_token, ffesymbol_basictype (dest),
7200 ffesymbol_kindtype (dest), ffesymbol_rank (dest), ffesymbol_size (dest),
7201 FFEEXPR_contextLET);
7202 }
7203
7204 /* Initializes the module. */
7205
7206 void
7207 ffeexpr_init_2 ()
7208 {
7209 ffeexpr_stack_ = NULL;
7210 ffeexpr_level_ = 0;
7211 }
7212
7213 /* ffeexpr_lhs -- Begin processing left-hand-side-context expression
7214
7215 Prepares cluster for delivery of lexer tokens representing an expression
7216 in a left-hand-side context (A in A=B, for example). ffebld is used
7217 to build expressions in the given pool. The appropriate lexer-token
7218 handling routine within ffeexpr is returned. When the end of the
7219 expression is detected, mycallbackroutine is called with the resulting
7220 single ffebld object specifying the entire expression and the first
7221 lexer token that is not considered part of the expression. This caller-
7222 supplied routine itself returns a lexer-token handling routine. Thus,
7223 if necessary, ffeexpr can return several tokens as end-of-expression
7224 tokens if it needs to scan forward more than one in any instance. */
7225
7226 ffelexHandler
7227 ffeexpr_lhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
7228 {
7229 ffeexprStack_ s;
7230
7231 ffebld_pool_push (pool);
7232 s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
7233 s->previous = ffeexpr_stack_;
7234 s->pool = pool;
7235 s->context = context;
7236 s->callback = callback;
7237 s->first_token = NULL;
7238 s->exprstack = NULL;
7239 s->is_rhs = FALSE;
7240 ffeexpr_stack_ = s;
7241 return (ffelexHandler) ffeexpr_token_first_lhs_;
7242 }
7243
7244 /* ffeexpr_rhs -- Begin processing right-hand-side-context expression
7245
7246 return ffeexpr_rhs(malloc_pool_image(),mycallbackroutine); // to lexer.
7247
7248 Prepares cluster for delivery of lexer tokens representing an expression
7249 in a right-hand-side context (B in A=B, for example). ffebld is used
7250 to build expressions in the given pool. The appropriate lexer-token
7251 handling routine within ffeexpr is returned. When the end of the
7252 expression is detected, mycallbackroutine is called with the resulting
7253 single ffebld object specifying the entire expression and the first
7254 lexer token that is not considered part of the expression. This caller-
7255 supplied routine itself returns a lexer-token handling routine. Thus,
7256 if necessary, ffeexpr can return several tokens as end-of-expression
7257 tokens if it needs to scan forward more than one in any instance. */
7258
7259 ffelexHandler
7260 ffeexpr_rhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
7261 {
7262 ffeexprStack_ s;
7263
7264 ffebld_pool_push (pool);
7265 s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
7266 s->previous = ffeexpr_stack_;
7267 s->pool = pool;
7268 s->context = context;
7269 s->callback = callback;
7270 s->first_token = NULL;
7271 s->exprstack = NULL;
7272 s->is_rhs = TRUE;
7273 ffeexpr_stack_ = s;
7274 return (ffelexHandler) ffeexpr_token_first_rhs_;
7275 }
7276
7277 /* ffeexpr_cb_close_paren_ -- OPEN_PAREN expr
7278
7279 Pass it to ffeexpr_rhs as the callback routine.
7280
7281 Makes sure the end token is close-paren and swallows it, else issues
7282 an error message and doesn't swallow the token (passing it along instead).
7283 In either case wraps up subexpression construction by enclosing the
7284 ffebld expression in a paren. */
7285
7286 static ffelexHandler
7287 ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr, ffelexToken t)
7288 {
7289 ffeexprExpr_ e;
7290
7291 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7292 {
7293 /* Oops, naughty user didn't specify the close paren! */
7294
7295 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7296 {
7297 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7298 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7299 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7300 ffebad_finish ();
7301 }
7302
7303 e = ffeexpr_expr_new_ ();
7304 e->type = FFEEXPR_exprtypeOPERAND_;
7305 e->u.operand = ffebld_new_any ();
7306 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
7307 ffeexpr_exprstack_push_operand_ (e);
7308
7309 return
7310 (ffelexHandler) ffeexpr_find_close_paren_ (t,
7311 (ffelexHandler)
7312 ffeexpr_token_binary_);
7313 }
7314
7315 if (expr->op == FFEBLD_opIMPDO)
7316 {
7317 if (ffest_ffebad_start (FFEBAD_IMPDO_PAREN))
7318 {
7319 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7320 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7321 ffebad_finish ();
7322 }
7323 }
7324 else
7325 {
7326 expr = ffebld_new_paren (expr);
7327 ffebld_set_info (expr, ffeinfo_use (ffebld_info (ffebld_left (expr))));
7328 }
7329
7330 /* Now push the (parenthesized) expression as an operand onto the
7331 expression stack. */
7332
7333 e = ffeexpr_expr_new_ ();
7334 e->type = FFEEXPR_exprtypeOPERAND_;
7335 e->u.operand = expr;
7336 e->u.operand = ffeexpr_collapse_paren (e->u.operand, ft);
7337 e->token = ffeexpr_stack_->tokens[0];
7338 ffeexpr_exprstack_push_operand_ (e);
7339
7340 return (ffelexHandler) ffeexpr_token_binary_;
7341 }
7342
7343 /* ffeexpr_cb_close_paren_ambig_ -- OPEN_PAREN expr
7344
7345 Pass it to ffeexpr_rhs as the callback routine.
7346
7347 We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
7348 with the next token in t. If the next token is possibly a binary
7349 operator, continue processing the outer expression. If the next
7350 token is COMMA, then the expression is a unit specifier, and
7351 parentheses should not be added to it because it surrounds the
7352 I/O control list that starts with the unit specifier (and continues
7353 on from here -- we haven't seen the CLOSE_PAREN that matches the
7354 OPEN_PAREN, it is up to the callback function to expect to see it
7355 at some point). In this case, we notify the callback function that
7356 the COMMA is inside, not outside, the parens by wrapping the expression
7357 in an opITEM (with a NULL trail) -- the callback function presumably
7358 unwraps it after seeing this kludgey indicator.
7359
7360 If the next token is CLOSE_PAREN, then we go to the _1_ state to
7361 decide what to do with the token after that.
7362
7363 15-Feb-91 JCB 1.1
7364 Use an extra state for the CLOSE_PAREN case to make READ &co really
7365 work right. */
7366
7367 static ffelexHandler
7368 ffeexpr_cb_close_paren_ambig_ (ffelexToken ft, ffebld expr, ffelexToken t)
7369 {
7370 ffeexprCallback callback;
7371 ffeexprStack_ s;
7372
7373 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7374 { /* Need to see the next token before we
7375 decide anything. */
7376 ffeexpr_stack_->expr = expr;
7377 ffeexpr_tokens_[0] = ffelex_token_use (ft);
7378 ffeexpr_tokens_[1] = ffelex_token_use (t);
7379 return (ffelexHandler) ffeexpr_cb_close_paren_ambig_1_;
7380 }
7381
7382 expr = ffeexpr_finished_ambig_ (ft, expr);
7383
7384 /* Let the callback function handle the case where t isn't COMMA. */
7385
7386 /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
7387 that preceded the expression starts a list of expressions, and the expr
7388 hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
7389 node. The callback function should extract the real expr from the head
7390 of this opITEM node after testing it. */
7391
7392 expr = ffebld_new_item (expr, NULL);
7393
7394 ffebld_pool_pop ();
7395 callback = ffeexpr_stack_->callback;
7396 ffelex_token_kill (ffeexpr_stack_->first_token);
7397 s = ffeexpr_stack_->previous;
7398 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
7399 ffeexpr_stack_ = s;
7400 return (ffelexHandler) (*callback) (ft, expr, t);
7401 }
7402
7403 /* ffeexpr_cb_close_paren_ambig_1_ -- OPEN_PAREN expr CLOSE_PAREN
7404
7405 See ffeexpr_cb_close_paren_ambig_.
7406
7407 We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
7408 with the next token in t. If the next token is possibly a binary
7409 operator, continue processing the outer expression. If the next
7410 token is COMMA, the expression is a parenthesized format specifier.
7411 If the next token is not EOS or SEMICOLON, then because it is not a
7412 binary operator (it is NAME, OPEN_PAREN, &c), the expression is
7413 a unit specifier, and parentheses should not be added to it because
7414 they surround the I/O control list that consists of only the unit
7415 specifier. If the next token is EOS or SEMICOLON, the statement
7416 must be disambiguated by looking at the type of the expression -- a
7417 character expression is a parenthesized format specifier, while a
7418 non-character expression is a unit specifier.
7419
7420 Another issue is how to do the callback so the recipient of the
7421 next token knows how to handle it if it is a COMMA. In all other
7422 cases, disambiguation is straightforward: the same approach as the
7423 above is used.
7424
7425 EXTENSION: in COMMA case, if not pedantic, use same disambiguation
7426 as for EOS/SEMICOLON case; f2c allows "READ (cilist) [[,]iolist]"
7427 and apparently other compilers do, as well, and some code out there
7428 uses this "feature".
7429
7430 19-Feb-91 JCB 1.1
7431 Extend to allow COMMA as nondisambiguating by itself. Remember
7432 to not try and check info field for opSTAR, since that expr doesn't
7433 have a valid info field. */
7434
7435 static ffelexHandler
7436 ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t)
7437 {
7438 ffeexprCallback callback;
7439 ffeexprStack_ s;
7440 ffelexHandler next;
7441 ffelexToken orig_ft = ffeexpr_tokens_[0]; /* In case callback clobbers
7442 these. */
7443 ffelexToken orig_t = ffeexpr_tokens_[1];
7444 ffebld expr = ffeexpr_stack_->expr;
7445
7446 switch (ffelex_token_type (t))
7447 {
7448 case FFELEX_typeCOMMA: /* Subexpr is parenthesized format specifier. */
7449 if (ffe_is_pedantic ())
7450 goto pedantic_comma; /* :::::::::::::::::::: */
7451 /* Fall through. */
7452 case FFELEX_typeEOS: /* Ambiguous; use type of expr to
7453 disambiguate. */
7454 case FFELEX_typeSEMICOLON:
7455 if ((expr == NULL) || (ffebld_op (expr) == FFEBLD_opANY)
7456 || (ffebld_op (expr) == FFEBLD_opSTAR)
7457 || (ffeinfo_basictype (ffebld_info (expr))
7458 != FFEINFO_basictypeCHARACTER))
7459 break; /* Not a valid CHARACTER entity, can't be a
7460 format spec. */
7461 /* Fall through. */
7462 default: /* Binary op (we assume; error otherwise);
7463 format specifier. */
7464
7465 pedantic_comma: /* :::::::::::::::::::: */
7466
7467 switch (ffeexpr_stack_->context)
7468 {
7469 case FFEEXPR_contextFILENUMAMBIG:
7470 ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
7471 break;
7472
7473 case FFEEXPR_contextFILEUNITAMBIG:
7474 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
7475 break;
7476
7477 default:
7478 assert ("bad context" == NULL);
7479 break;
7480 }
7481
7482 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
7483 next = (ffelexHandler) ffeexpr_cb_close_paren_ (orig_ft, expr, orig_t);
7484 ffelex_token_kill (orig_ft);
7485 ffelex_token_kill (orig_t);
7486 return (ffelexHandler) (*next) (t);
7487
7488 case FFELEX_typeOPEN_PAREN:/* Non-binary op; beginning of I/O list. */
7489 case FFELEX_typeNAME:
7490 break;
7491 }
7492
7493 expr = ffeexpr_finished_ambig_ (orig_ft, expr);
7494
7495 /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
7496 that preceded the expression starts a list of expressions, and the expr
7497 hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
7498 node. The callback function should extract the real expr from the head
7499 of this opITEM node after testing it. */
7500
7501 expr = ffebld_new_item (expr, NULL);
7502
7503 ffebld_pool_pop ();
7504 callback = ffeexpr_stack_->callback;
7505 ffelex_token_kill (ffeexpr_stack_->first_token);
7506 s = ffeexpr_stack_->previous;
7507 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
7508 ffeexpr_stack_ = s;
7509 next = (ffelexHandler) (*callback) (orig_ft, expr, orig_t);
7510 ffelex_token_kill (orig_ft);
7511 ffelex_token_kill (orig_t);
7512 return (ffelexHandler) (*next) (t);
7513 }
7514
7515 /* ffeexpr_cb_close_paren_c_ -- OPEN_PAREN expr (possible complex)
7516
7517 Pass it to ffeexpr_rhs as the callback routine.
7518
7519 Makes sure the end token is close-paren and swallows it, or a comma
7520 and handles complex/implied-do possibilities, else issues
7521 an error message and doesn't swallow the token (passing it along instead). */
7522
7523 static ffelexHandler
7524 ffeexpr_cb_close_paren_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
7525 {
7526 /* First check to see if this is a possible complex entity. It is if the
7527 token is a comma. */
7528
7529 if (ffelex_token_type (t) == FFELEX_typeCOMMA)
7530 {
7531 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
7532 ffeexpr_stack_->expr = expr;
7533 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7534 FFEEXPR_contextPAREN_, ffeexpr_cb_comma_c_);
7535 }
7536
7537 return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
7538 }
7539
7540 /* ffeexpr_cb_comma_c_ -- OPEN_PAREN expr COMMA expr
7541
7542 Pass it to ffeexpr_rhs as the callback routine.
7543
7544 If this token is not a comma, we have a complex constant (or an attempt
7545 at one), so handle it accordingly, displaying error messages if the token
7546 is not a close-paren. */
7547
7548 static ffelexHandler
7549 ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
7550 {
7551 ffeexprExpr_ e;
7552 ffeinfoBasictype lty = (ffeexpr_stack_->expr == NULL)
7553 ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (ffeexpr_stack_->expr));
7554 ffeinfoBasictype rty = (expr == NULL)
7555 ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (expr));
7556 ffeinfoKindtype lkt;
7557 ffeinfoKindtype rkt;
7558 ffeinfoKindtype nkt;
7559 bool ok = TRUE;
7560 ffebld orig;
7561
7562 if ((ffeexpr_stack_->expr == NULL)
7563 || (ffebld_op (ffeexpr_stack_->expr) != FFEBLD_opCONTER)
7564 || (((orig = ffebld_conter_orig (ffeexpr_stack_->expr)) != NULL)
7565 && (((ffebld_op (orig) != FFEBLD_opUMINUS)
7566 && (ffebld_op (orig) != FFEBLD_opUPLUS))
7567 || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
7568 || ((lty != FFEINFO_basictypeINTEGER)
7569 && (lty != FFEINFO_basictypeREAL)))
7570 {
7571 if ((lty != FFEINFO_basictypeANY)
7572 && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
7573 {
7574 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
7575 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
7576 ffebad_string ("Real");
7577 ffebad_finish ();
7578 }
7579 ok = FALSE;
7580 }
7581 if ((expr == NULL)
7582 || (ffebld_op (expr) != FFEBLD_opCONTER)
7583 || (((orig = ffebld_conter_orig (expr)) != NULL)
7584 && (((ffebld_op (orig) != FFEBLD_opUMINUS)
7585 && (ffebld_op (orig) != FFEBLD_opUPLUS))
7586 || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
7587 || ((rty != FFEINFO_basictypeINTEGER)
7588 && (rty != FFEINFO_basictypeREAL)))
7589 {
7590 if ((rty != FFEINFO_basictypeANY)
7591 && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
7592 {
7593 ffebad_here (0, ffelex_token_where_line (ft),
7594 ffelex_token_where_column (ft));
7595 ffebad_string ("Imaginary");
7596 ffebad_finish ();
7597 }
7598 ok = FALSE;
7599 }
7600
7601 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7602
7603 /* Push the (parenthesized) expression as an operand onto the expression
7604 stack. */
7605
7606 e = ffeexpr_expr_new_ ();
7607 e->type = FFEEXPR_exprtypeOPERAND_;
7608 e->token = ffeexpr_stack_->tokens[0];
7609
7610 if (ok)
7611 {
7612 if (lty == FFEINFO_basictypeINTEGER)
7613 lkt = FFEINFO_kindtypeREALDEFAULT;
7614 else
7615 lkt = ffeinfo_kindtype (ffebld_info (ffeexpr_stack_->expr));
7616 if (rty == FFEINFO_basictypeINTEGER)
7617 rkt = FFEINFO_kindtypeREALDEFAULT;
7618 else
7619 rkt = ffeinfo_kindtype (ffebld_info (expr));
7620
7621 nkt = ffeinfo_kindtype_max (FFEINFO_basictypeCOMPLEX, lkt, rkt);
7622 ffeexpr_stack_->expr = ffeexpr_convert (ffeexpr_stack_->expr,
7623 ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
7624 FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
7625 FFEEXPR_contextLET);
7626 expr = ffeexpr_convert (expr,
7627 ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
7628 FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
7629 FFEEXPR_contextLET);
7630 }
7631 else
7632 nkt = FFEINFO_kindtypeANY;
7633
7634 switch (nkt)
7635 {
7636 #if FFETARGET_okCOMPLEX1
7637 case FFEINFO_kindtypeREAL1:
7638 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex1
7639 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7640 ffebld_set_info (e->u.operand,
7641 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7642 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7643 FFETARGET_charactersizeNONE));
7644 break;
7645 #endif
7646
7647 #if FFETARGET_okCOMPLEX2
7648 case FFEINFO_kindtypeREAL2:
7649 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex2
7650 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7651 ffebld_set_info (e->u.operand,
7652 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7653 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7654 FFETARGET_charactersizeNONE));
7655 break;
7656 #endif
7657
7658 #if FFETARGET_okCOMPLEX3
7659 case FFEINFO_kindtypeREAL3:
7660 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex3
7661 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7662 ffebld_set_info (e->u.operand,
7663 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7664 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7665 FFETARGET_charactersizeNONE));
7666 break;
7667 #endif
7668
7669 #if FFETARGET_okCOMPLEX4
7670 case FFEINFO_kindtypeREAL4:
7671 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex4
7672 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7673 ffebld_set_info (e->u.operand,
7674 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7675 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7676 FFETARGET_charactersizeNONE));
7677 break;
7678 #endif
7679
7680 default:
7681 if (ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
7682 ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX))
7683 {
7684 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7685 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7686 ffebad_finish ();
7687 }
7688 /* Fall through. */
7689 case FFEINFO_kindtypeANY:
7690 e->u.operand = ffebld_new_any ();
7691 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
7692 break;
7693 }
7694 ffeexpr_exprstack_push_operand_ (e);
7695
7696 /* Now, if the token is a close parenthese, we're in great shape so return
7697 the next handler. */
7698
7699 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7700 return (ffelexHandler) ffeexpr_token_binary_;
7701
7702 /* Oops, naughty user didn't specify the close paren! */
7703
7704 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7705 {
7706 ffebad_here (0, ffelex_token_where_line (t),
7707 ffelex_token_where_column (t));
7708 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7709 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7710 ffebad_finish ();
7711 }
7712
7713 return
7714 (ffelexHandler) ffeexpr_find_close_paren_ (t,
7715 (ffelexHandler)
7716 ffeexpr_token_binary_);
7717 }
7718
7719 /* ffeexpr_cb_close_paren_ci_ -- OPEN_PAREN expr (possible complex or
7720 implied-DO construct)
7721
7722 Pass it to ffeexpr_rhs as the callback routine.
7723
7724 Makes sure the end token is close-paren and swallows it, or a comma
7725 and handles complex/implied-do possibilities, else issues
7726 an error message and doesn't swallow the token (passing it along instead). */
7727
7728 static ffelexHandler
7729 ffeexpr_cb_close_paren_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
7730 {
7731 ffeexprContext ctx;
7732
7733 /* First check to see if this is a possible complex or implied-DO entity.
7734 It is if the token is a comma. */
7735
7736 if (ffelex_token_type (t) == FFELEX_typeCOMMA)
7737 {
7738 switch (ffeexpr_stack_->context)
7739 {
7740 case FFEEXPR_contextIOLIST:
7741 case FFEEXPR_contextIMPDOITEM_:
7742 ctx = FFEEXPR_contextIMPDOITEM_;
7743 break;
7744
7745 case FFEEXPR_contextIOLISTDF:
7746 case FFEEXPR_contextIMPDOITEMDF_:
7747 ctx = FFEEXPR_contextIMPDOITEMDF_;
7748 break;
7749
7750 default:
7751 assert ("bad context" == NULL);
7752 ctx = FFEEXPR_contextIMPDOITEM_;
7753 break;
7754 }
7755
7756 ffeexpr_stack_->tokens[0] = ffelex_token_use (ft);
7757 ffeexpr_stack_->expr = expr;
7758 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7759 ctx, ffeexpr_cb_comma_ci_);
7760 }
7761
7762 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
7763 return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
7764 }
7765
7766 /* ffeexpr_cb_comma_ci_ -- OPEN_PAREN expr COMMA expr
7767
7768 Pass it to ffeexpr_rhs as the callback routine.
7769
7770 If this token is not a comma, we have a complex constant (or an attempt
7771 at one), so handle it accordingly, displaying error messages if the token
7772 is not a close-paren. If we have a comma here, it is an attempt at an
7773 implied-DO, so start making a list accordingly. Oh, it might be an
7774 equal sign also, meaning an implied-DO with only one item in its list. */
7775
7776 static ffelexHandler
7777 ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
7778 {
7779 ffebld fexpr;
7780
7781 /* First check to see if this is a possible complex constant. It is if the
7782 token is not a comma or an equals sign, in which case it should be a
7783 close-paren. */
7784
7785 if ((ffelex_token_type (t) != FFELEX_typeCOMMA)
7786 && (ffelex_token_type (t) != FFELEX_typeEQUALS))
7787 {
7788 ffeexpr_stack_->tokens[1] = ffeexpr_stack_->tokens[0];
7789 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
7790 return (ffelexHandler) ffeexpr_cb_comma_c_ (ft, expr, t);
7791 }
7792
7793 /* Here we have either EQUALS or COMMA, meaning we are in an implied-DO
7794 construct. Make a list and handle accordingly. */
7795
7796 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
7797 fexpr = ffeexpr_stack_->expr;
7798 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7799 ffebld_append_item (&ffeexpr_stack_->bottom, fexpr);
7800 return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
7801 }
7802
7803 /* ffeexpr_cb_comma_i_ -- OPEN_PAREN expr
7804
7805 Pass it to ffeexpr_rhs as the callback routine.
7806
7807 Handle first item in an implied-DO construct. */
7808
7809 static ffelexHandler
7810 ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr, ffelexToken t)
7811 {
7812 if (ffelex_token_type (t) != FFELEX_typeCOMMA)
7813 {
7814 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7815 {
7816 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7817 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7818 ffelex_token_where_column (ffeexpr_stack_->first_token));
7819 ffebad_finish ();
7820 }
7821 ffebld_end_list (&ffeexpr_stack_->bottom);
7822 ffeexpr_stack_->expr = ffebld_new_any ();
7823 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7824 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7825 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7826 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7827 }
7828
7829 return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
7830 }
7831
7832 /* ffeexpr_cb_comma_i_1_ -- OPEN_PAREN expr
7833
7834 Pass it to ffeexpr_rhs as the callback routine.
7835
7836 Handle first item in an implied-DO construct. */
7837
7838 static ffelexHandler
7839 ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr, ffelexToken t)
7840 {
7841 ffeexprContext ctxi;
7842 ffeexprContext ctxc;
7843
7844 switch (ffeexpr_stack_->context)
7845 {
7846 case FFEEXPR_contextDATA:
7847 case FFEEXPR_contextDATAIMPDOITEM_:
7848 ctxi = FFEEXPR_contextDATAIMPDOITEM_;
7849 ctxc = FFEEXPR_contextDATAIMPDOCTRL_;
7850 break;
7851
7852 case FFEEXPR_contextIOLIST:
7853 case FFEEXPR_contextIMPDOITEM_:
7854 ctxi = FFEEXPR_contextIMPDOITEM_;
7855 ctxc = FFEEXPR_contextIMPDOCTRL_;
7856 break;
7857
7858 case FFEEXPR_contextIOLISTDF:
7859 case FFEEXPR_contextIMPDOITEMDF_:
7860 ctxi = FFEEXPR_contextIMPDOITEMDF_;
7861 ctxc = FFEEXPR_contextIMPDOCTRL_;
7862 break;
7863
7864 default:
7865 assert ("bad context" == NULL);
7866 ctxi = FFEEXPR_context;
7867 ctxc = FFEEXPR_context;
7868 break;
7869 }
7870
7871 switch (ffelex_token_type (t))
7872 {
7873 case FFELEX_typeCOMMA:
7874 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7875 if (ffeexpr_stack_->is_rhs)
7876 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7877 ctxi, ffeexpr_cb_comma_i_1_);
7878 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7879 ctxi, ffeexpr_cb_comma_i_1_);
7880
7881 case FFELEX_typeEQUALS:
7882 ffebld_end_list (&ffeexpr_stack_->bottom);
7883
7884 /* Complain if implied-DO variable in list of items to be read. */
7885
7886 if ((ctxc == FFEEXPR_contextIMPDOCTRL_) && !ffeexpr_stack_->is_rhs)
7887 ffeexpr_check_impdo_ (ffeexpr_stack_->expr,
7888 ffeexpr_stack_->first_token, expr, ft);
7889
7890 /* Set doiter flag for all appropriate SYMTERs. */
7891
7892 ffeexpr_update_impdo_ (ffeexpr_stack_->expr, expr);
7893
7894 ffeexpr_stack_->expr = ffebld_new_impdo (ffeexpr_stack_->expr, NULL);
7895 ffebld_set_info (ffeexpr_stack_->expr,
7896 ffeinfo_new (FFEINFO_basictypeNONE,
7897 FFEINFO_kindtypeNONE,
7898 0,
7899 FFEINFO_kindNONE,
7900 FFEINFO_whereNONE,
7901 FFETARGET_charactersizeNONE));
7902 ffebld_init_list (&(ffebld_right (ffeexpr_stack_->expr)),
7903 &ffeexpr_stack_->bottom);
7904 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7905 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7906 ctxc, ffeexpr_cb_comma_i_2_);
7907
7908 default:
7909 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7910 {
7911 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7912 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7913 ffelex_token_where_column (ffeexpr_stack_->first_token));
7914 ffebad_finish ();
7915 }
7916 ffebld_end_list (&ffeexpr_stack_->bottom);
7917 ffeexpr_stack_->expr = ffebld_new_any ();
7918 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7919 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7920 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7921 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7922 }
7923 }
7924
7925 /* ffeexpr_cb_comma_i_2_ -- OPEN_PAREN expr-list EQUALS expr
7926
7927 Pass it to ffeexpr_rhs as the callback routine.
7928
7929 Handle start-value in an implied-DO construct. */
7930
7931 static ffelexHandler
7932 ffeexpr_cb_comma_i_2_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7933 {
7934 ffeexprContext ctx;
7935
7936 switch (ffeexpr_stack_->context)
7937 {
7938 case FFEEXPR_contextDATA:
7939 case FFEEXPR_contextDATAIMPDOITEM_:
7940 ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7941 break;
7942
7943 case FFEEXPR_contextIOLIST:
7944 case FFEEXPR_contextIOLISTDF:
7945 case FFEEXPR_contextIMPDOITEM_:
7946 case FFEEXPR_contextIMPDOITEMDF_:
7947 ctx = FFEEXPR_contextIMPDOCTRL_;
7948 break;
7949
7950 default:
7951 assert ("bad context" == NULL);
7952 ctx = FFEEXPR_context;
7953 break;
7954 }
7955
7956 switch (ffelex_token_type (t))
7957 {
7958 case FFELEX_typeCOMMA:
7959 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7960 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7961 ctx, ffeexpr_cb_comma_i_3_);
7962 break;
7963
7964 default:
7965 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7966 {
7967 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7968 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7969 ffelex_token_where_column (ffeexpr_stack_->first_token));
7970 ffebad_finish ();
7971 }
7972 ffebld_end_list (&ffeexpr_stack_->bottom);
7973 ffeexpr_stack_->expr = ffebld_new_any ();
7974 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7975 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7976 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7977 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7978 }
7979 }
7980
7981 /* ffeexpr_cb_comma_i_3_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7982
7983 Pass it to ffeexpr_rhs as the callback routine.
7984
7985 Handle end-value in an implied-DO construct. */
7986
7987 static ffelexHandler
7988 ffeexpr_cb_comma_i_3_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7989 {
7990 ffeexprContext ctx;
7991
7992 switch (ffeexpr_stack_->context)
7993 {
7994 case FFEEXPR_contextDATA:
7995 case FFEEXPR_contextDATAIMPDOITEM_:
7996 ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7997 break;
7998
7999 case FFEEXPR_contextIOLIST:
8000 case FFEEXPR_contextIOLISTDF:
8001 case FFEEXPR_contextIMPDOITEM_:
8002 case FFEEXPR_contextIMPDOITEMDF_:
8003 ctx = FFEEXPR_contextIMPDOCTRL_;
8004 break;
8005
8006 default:
8007 assert ("bad context" == NULL);
8008 ctx = FFEEXPR_context;
8009 break;
8010 }
8011
8012 switch (ffelex_token_type (t))
8013 {
8014 case FFELEX_typeCOMMA:
8015 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
8016 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8017 ctx, ffeexpr_cb_comma_i_4_);
8018 break;
8019
8020 case FFELEX_typeCLOSE_PAREN:
8021 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
8022 return (ffelexHandler) ffeexpr_cb_comma_i_4_ (NULL, NULL, t);
8023 break;
8024
8025 default:
8026 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
8027 {
8028 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8029 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
8030 ffelex_token_where_column (ffeexpr_stack_->first_token));
8031 ffebad_finish ();
8032 }
8033 ffebld_end_list (&ffeexpr_stack_->bottom);
8034 ffeexpr_stack_->expr = ffebld_new_any ();
8035 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
8036 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
8037 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
8038 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
8039 }
8040 }
8041
8042 /* ffeexpr_cb_comma_i_4_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
8043 [COMMA expr]
8044
8045 Pass it to ffeexpr_rhs as the callback routine.
8046
8047 Handle incr-value in an implied-DO construct. */
8048
8049 static ffelexHandler
8050 ffeexpr_cb_comma_i_4_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
8051 {
8052 switch (ffelex_token_type (t))
8053 {
8054 case FFELEX_typeCLOSE_PAREN:
8055 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
8056 ffebld_end_list (&ffeexpr_stack_->bottom);
8057 {
8058 ffebld item;
8059
8060 for (item = ffebld_left (ffeexpr_stack_->expr);
8061 item != NULL;
8062 item = ffebld_trail (item))
8063 if (ffebld_op (ffebld_head (item)) == FFEBLD_opANY)
8064 goto replace_with_any; /* :::::::::::::::::::: */
8065
8066 for (item = ffebld_right (ffeexpr_stack_->expr);
8067 item != NULL;
8068 item = ffebld_trail (item))
8069 if ((ffebld_head (item) != NULL) /* Increment may be NULL. */
8070 && (ffebld_op (ffebld_head (item)) == FFEBLD_opANY))
8071 goto replace_with_any; /* :::::::::::::::::::: */
8072 }
8073 break;
8074
8075 default:
8076 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
8077 {
8078 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8079 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
8080 ffelex_token_where_column (ffeexpr_stack_->first_token));
8081 ffebad_finish ();
8082 }
8083 ffebld_end_list (&ffeexpr_stack_->bottom);
8084
8085 replace_with_any: /* :::::::::::::::::::: */
8086
8087 ffeexpr_stack_->expr = ffebld_new_any ();
8088 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
8089 break;
8090 }
8091
8092 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
8093 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
8094 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
8095 }
8096
8097 /* ffeexpr_cb_comma_i_5_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
8098 [COMMA expr] CLOSE_PAREN
8099
8100 Pass it to ffeexpr_rhs as the callback routine.
8101
8102 Collects token following implied-DO construct for callback function. */
8103
8104 static ffelexHandler
8105 ffeexpr_cb_comma_i_5_ (ffelexToken t)
8106 {
8107 ffeexprCallback callback;
8108 ffeexprStack_ s;
8109 ffelexHandler next;
8110 ffelexToken ft;
8111 ffebld expr;
8112 bool terminate;
8113
8114 switch (ffeexpr_stack_->context)
8115 {
8116 case FFEEXPR_contextDATA:
8117 case FFEEXPR_contextDATAIMPDOITEM_:
8118 terminate = TRUE;
8119 break;
8120
8121 case FFEEXPR_contextIOLIST:
8122 case FFEEXPR_contextIOLISTDF:
8123 case FFEEXPR_contextIMPDOITEM_:
8124 case FFEEXPR_contextIMPDOITEMDF_:
8125 terminate = FALSE;
8126 break;
8127
8128 default:
8129 assert ("bad context" == NULL);
8130 terminate = FALSE;
8131 break;
8132 }
8133
8134 ffebld_pool_pop ();
8135 callback = ffeexpr_stack_->callback;
8136 ft = ffeexpr_stack_->first_token;
8137 expr = ffeexpr_stack_->expr;
8138 s = ffeexpr_stack_->previous;
8139 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
8140 sizeof (*ffeexpr_stack_));
8141 ffeexpr_stack_ = s;
8142 next = (ffelexHandler) (*callback) (ft, expr, t);
8143 ffelex_token_kill (ft);
8144 if (terminate)
8145 {
8146 ffesymbol_drive_sfnames (ffeexpr_check_impctrl_);
8147 --ffeexpr_level_;
8148 if (ffeexpr_level_ == 0)
8149 ffe_terminate_4 ();
8150 }
8151 return (ffelexHandler) next;
8152 }
8153
8154 /* ffeexpr_cb_end_loc_ -- Handle end of %LOC subexpression
8155
8156 Makes sure the end token is close-paren and swallows it, else issues
8157 an error message and doesn't swallow the token (passing it along instead).
8158 In either case wraps up subexpression construction by enclosing the
8159 ffebld expression in a %LOC. */
8160
8161 static ffelexHandler
8162 ffeexpr_cb_end_loc_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
8163 {
8164 ffeexprExpr_ e;
8165
8166 /* First push the (%LOC) expression as an operand onto the expression
8167 stack. */
8168
8169 e = ffeexpr_expr_new_ ();
8170 e->type = FFEEXPR_exprtypeOPERAND_;
8171 e->token = ffeexpr_stack_->tokens[0];
8172 e->u.operand = ffebld_new_percent_loc (expr);
8173 ffebld_set_info (e->u.operand,
8174 ffeinfo_new (FFEINFO_basictypeINTEGER,
8175 ffecom_pointer_kind (),
8176 0,
8177 FFEINFO_kindENTITY,
8178 FFEINFO_whereFLEETING,
8179 FFETARGET_charactersizeNONE));
8180 #if 0 /* ~~ */
8181 e->u.operand = ffeexpr_collapse_percent_loc (e->u.operand, ft);
8182 #endif
8183 ffeexpr_exprstack_push_operand_ (e);
8184
8185 /* Now, if the token is a close parenthese, we're in great shape so return
8186 the next handler. */
8187
8188 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
8189 {
8190 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8191 return (ffelexHandler) ffeexpr_token_binary_;
8192 }
8193
8194 /* Oops, naughty user didn't specify the close paren! */
8195
8196 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
8197 {
8198 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8199 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
8200 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
8201 ffebad_finish ();
8202 }
8203
8204 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8205 return
8206 (ffelexHandler) ffeexpr_find_close_paren_ (t,
8207 (ffelexHandler)
8208 ffeexpr_token_binary_);
8209 }
8210
8211 /* ffeexpr_cb_end_notloc_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
8212
8213 Should be CLOSE_PAREN, and make sure expr isn't a %(VAL,REF,DESCR). */
8214
8215 static ffelexHandler
8216 ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr, ffelexToken t)
8217 {
8218 ffeexprExpr_ e;
8219 ffebldOp op;
8220
8221 /* If expression is itself a %(VAL,REF,DESCR), complain and strip off all
8222 such things until the lowest-level expression is reached. */
8223
8224 op = ffebld_op (expr);
8225 if ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
8226 || (op == FFEBLD_opPERCENT_DESCR))
8227 {
8228 if (ffebad_start (FFEBAD_NESTED_PERCENT))
8229 {
8230 ffebad_here (0, ffelex_token_where_line (ft),
8231 ffelex_token_where_column (ft));
8232 ffebad_finish ();
8233 }
8234
8235 do
8236 {
8237 expr = ffebld_left (expr);
8238 op = ffebld_op (expr);
8239 }
8240 while ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
8241 || (op == FFEBLD_opPERCENT_DESCR));
8242 }
8243
8244 /* Push the expression as an operand onto the expression stack. */
8245
8246 e = ffeexpr_expr_new_ ();
8247 e->type = FFEEXPR_exprtypeOPERAND_;
8248 e->token = ffeexpr_stack_->tokens[0];
8249 switch (ffeexpr_stack_->percent)
8250 {
8251 case FFEEXPR_percentVAL_:
8252 e->u.operand = ffebld_new_percent_val (expr);
8253 break;
8254
8255 case FFEEXPR_percentREF_:
8256 e->u.operand = ffebld_new_percent_ref (expr);
8257 break;
8258
8259 case FFEEXPR_percentDESCR_:
8260 e->u.operand = ffebld_new_percent_descr (expr);
8261 break;
8262
8263 default:
8264 assert ("%lossage" == NULL);
8265 e->u.operand = expr;
8266 break;
8267 }
8268 ffebld_set_info (e->u.operand, ffebld_info (expr));
8269 #if 0 /* ~~ */
8270 e->u.operand = ffeexpr_collapse_percent_ ? ? ? (e->u.operand, ft);
8271 #endif
8272 ffeexpr_exprstack_push_operand_ (e);
8273
8274 /* Now, if the token is a close parenthese, we're in great shape so return
8275 the next handler. */
8276
8277 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
8278 return (ffelexHandler) ffeexpr_cb_end_notloc_1_;
8279
8280 /* Oops, naughty user didn't specify the close paren! */
8281
8282 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
8283 {
8284 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8285 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
8286 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
8287 ffebad_finish ();
8288 }
8289
8290 ffebld_set_op (e->u.operand, FFEBLD_opPERCENT_LOC);
8291
8292 switch (ffeexpr_stack_->context)
8293 {
8294 case FFEEXPR_contextACTUALARG_:
8295 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8296 break;
8297
8298 case FFEEXPR_contextINDEXORACTUALARG_:
8299 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8300 break;
8301
8302 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8303 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8304 break;
8305
8306 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8307 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8308 break;
8309
8310 default:
8311 assert ("bad context?!?!" == NULL);
8312 break;
8313 }
8314
8315 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8316 return
8317 (ffelexHandler) ffeexpr_find_close_paren_ (t,
8318 (ffelexHandler)
8319 ffeexpr_cb_end_notloc_1_);
8320 }
8321
8322 /* ffeexpr_cb_end_notloc_1_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
8323 CLOSE_PAREN
8324
8325 Should be COMMA or CLOSE_PAREN, else change back to %LOC. */
8326
8327 static ffelexHandler
8328 ffeexpr_cb_end_notloc_1_ (ffelexToken t)
8329 {
8330 switch (ffelex_token_type (t))
8331 {
8332 case FFELEX_typeCOMMA:
8333 case FFELEX_typeCLOSE_PAREN:
8334 switch (ffeexpr_stack_->context)
8335 {
8336 case FFEEXPR_contextACTUALARG_:
8337 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8338 break;
8339
8340 case FFEEXPR_contextINDEXORACTUALARG_:
8341 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
8342 break;
8343
8344 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8345 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
8346 break;
8347
8348 default:
8349 assert ("bad context?!?!" == NULL);
8350 break;
8351 }
8352 break;
8353
8354 default:
8355 if (ffebad_start (FFEBAD_INVALID_PERCENT))
8356 {
8357 ffebad_here (0,
8358 ffelex_token_where_line (ffeexpr_stack_->first_token),
8359 ffelex_token_where_column (ffeexpr_stack_->first_token));
8360 ffebad_string (ffelex_token_text (ffeexpr_stack_->tokens[1]));
8361 ffebad_finish ();
8362 }
8363
8364 ffebld_set_op (ffeexpr_stack_->exprstack->u.operand,
8365 FFEBLD_opPERCENT_LOC);
8366
8367 switch (ffeexpr_stack_->context)
8368 {
8369 case FFEEXPR_contextACTUALARG_:
8370 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8371 break;
8372
8373 case FFEEXPR_contextINDEXORACTUALARG_:
8374 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8375 break;
8376
8377 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8378 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8379 break;
8380
8381 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8382 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8383 break;
8384
8385 default:
8386 assert ("bad context?!?!" == NULL);
8387 break;
8388 }
8389 }
8390
8391 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8392 return
8393 (ffelexHandler) ffeexpr_token_binary_ (t);
8394 }
8395
8396 /* Process DATA implied-DO iterator variables as this implied-DO level
8397 terminates. At this point, ffeexpr_level_ == 1 when we see the
8398 last right-paren in "DATA (A(I),I=1,10)/.../". */
8399
8400 static ffesymbol
8401 ffeexpr_check_impctrl_ (ffesymbol s)
8402 {
8403 assert (s != NULL);
8404 assert (ffesymbol_sfdummyparent (s) != NULL);
8405
8406 switch (ffesymbol_state (s))
8407 {
8408 case FFESYMBOL_stateNONE: /* Used as iterator already. Now let symbol
8409 be used as iterator at any level at or
8410 innermore than the outermost of the
8411 current level and the symbol's current
8412 level. */
8413 if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
8414 {
8415 ffesymbol_signal_change (s);
8416 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
8417 ffesymbol_signal_unreported (s);
8418 }
8419 break;
8420
8421 case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO.
8422 Error if at outermost level, else it can
8423 still become an iterator. */
8424 if ((ffeexpr_level_ == 1)
8425 && ffebad_start (FFEBAD_BAD_IMPDCL))
8426 {
8427 ffebad_string (ffesymbol_text (s));
8428 ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
8429 ffebad_finish ();
8430 }
8431 break;
8432
8433 case FFESYMBOL_stateUNCERTAIN: /* Iterator. */
8434 assert (ffeexpr_level_ <= ffesymbol_maxentrynum (s));
8435 ffesymbol_signal_change (s);
8436 ffesymbol_set_state (s, FFESYMBOL_stateNONE);
8437 ffesymbol_signal_unreported (s);
8438 break;
8439
8440 case FFESYMBOL_stateUNDERSTOOD:
8441 break; /* ANY. */
8442
8443 default:
8444 assert ("Sasha Foo!!" == NULL);
8445 break;
8446 }
8447
8448 return s;
8449 }
8450
8451 /* Issue diagnostic if implied-DO variable appears in list of lhs
8452 expressions (as in "READ *, (I,I=1,10)"). */
8453
8454 static void
8455 ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
8456 ffebld dovar, ffelexToken dovar_t)
8457 {
8458 ffebld item;
8459 ffesymbol dovar_sym;
8460 int itemnum;
8461
8462 if (ffebld_op (dovar) != FFEBLD_opSYMTER)
8463 return; /* Presumably opANY. */
8464
8465 dovar_sym = ffebld_symter (dovar);
8466
8467 for (itemnum = 1; list != NULL; list = ffebld_trail (list), ++itemnum)
8468 {
8469 if (((item = ffebld_head (list)) != NULL)
8470 && (ffebld_op (item) == FFEBLD_opSYMTER)
8471 && (ffebld_symter (item) == dovar_sym))
8472 {
8473 char itemno[20];
8474
8475 sprintf (&itemno[0], "%d", itemnum);
8476 if (ffebad_start (FFEBAD_DOITER_IMPDO))
8477 {
8478 ffebad_here (0, ffelex_token_where_line (list_t),
8479 ffelex_token_where_column (list_t));
8480 ffebad_here (1, ffelex_token_where_line (dovar_t),
8481 ffelex_token_where_column (dovar_t));
8482 ffebad_string (ffesymbol_text (dovar_sym));
8483 ffebad_string (itemno);
8484 ffebad_finish ();
8485 }
8486 }
8487 }
8488 }
8489
8490 /* Decorate any SYMTERs referencing the DO variable with the "doiter"
8491 flag. */
8492
8493 static void
8494 ffeexpr_update_impdo_ (ffebld list, ffebld dovar)
8495 {
8496 ffesymbol dovar_sym;
8497
8498 if (ffebld_op (dovar) != FFEBLD_opSYMTER)
8499 return; /* Presumably opANY. */
8500
8501 dovar_sym = ffebld_symter (dovar);
8502
8503 ffeexpr_update_impdo_sym_ (list, dovar_sym); /* Recurse! */
8504 }
8505
8506 /* Recursive function to update any expr so SYMTERs have "doiter" flag
8507 if they refer to the given variable. */
8508
8509 static void
8510 ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar)
8511 {
8512 tail_recurse: /* :::::::::::::::::::: */
8513
8514 if (expr == NULL)
8515 return;
8516
8517 switch (ffebld_op (expr))
8518 {
8519 case FFEBLD_opSYMTER:
8520 if (ffebld_symter (expr) == dovar)
8521 ffebld_symter_set_is_doiter (expr, TRUE);
8522 break;
8523
8524 case FFEBLD_opITEM:
8525 ffeexpr_update_impdo_sym_ (ffebld_head (expr), dovar);
8526 expr = ffebld_trail (expr);
8527 goto tail_recurse; /* :::::::::::::::::::: */
8528
8529 default:
8530 break;
8531 }
8532
8533 switch (ffebld_arity (expr))
8534 {
8535 case 2:
8536 ffeexpr_update_impdo_sym_ (ffebld_left (expr), dovar);
8537 expr = ffebld_right (expr);
8538 goto tail_recurse; /* :::::::::::::::::::: */
8539
8540 case 1:
8541 expr = ffebld_left (expr);
8542 goto tail_recurse; /* :::::::::::::::::::: */
8543
8544 default:
8545 break;
8546 }
8547
8548 return;
8549 }
8550
8551 /* ffeexpr_context_outer_ -- Determine context of stack entry, skipping PARENs
8552
8553 if (ffeexpr_context_outer_(ffeexpr_stack_) == FFEEXPR_contextIF)
8554 // After zero or more PAREN_ contexts, an IF context exists */
8555
8556 static ffeexprContext
8557 ffeexpr_context_outer_ (ffeexprStack_ s)
8558 {
8559 assert (s != NULL);
8560
8561 for (;;)
8562 {
8563 switch (s->context)
8564 {
8565 case FFEEXPR_contextPAREN_:
8566 case FFEEXPR_contextPARENFILENUM_:
8567 case FFEEXPR_contextPARENFILEUNIT_:
8568 break;
8569
8570 default:
8571 return s->context;
8572 }
8573 s = s->previous;
8574 assert (s != NULL);
8575 }
8576 }
8577
8578 /* ffeexpr_percent_ -- Look up name in list of %FOO possibilities
8579
8580 ffeexprPercent_ p;
8581 ffelexToken t;
8582 p = ffeexpr_percent_(t);
8583
8584 Returns the identifier for the name, or the NONE identifier. */
8585
8586 static ffeexprPercent_
8587 ffeexpr_percent_ (ffelexToken t)
8588 {
8589 const char *p;
8590
8591 switch (ffelex_token_length (t))
8592 {
8593 case 3:
8594 switch (*(p = ffelex_token_text (t)))
8595 {
8596 case FFESRC_CASE_MATCH_INIT ('L', 'l', match_3l, no_match_3):
8597 if ((ffesrc_char_match_noninit (*++p, 'O', 'o'))
8598 && (ffesrc_char_match_noninit (*++p, 'C', 'c')))
8599 return FFEEXPR_percentLOC_;
8600 return FFEEXPR_percentNONE_;
8601
8602 case FFESRC_CASE_MATCH_INIT ('R', 'r', match_3r, no_match_3):
8603 if ((ffesrc_char_match_noninit (*++p, 'E', 'e'))
8604 && (ffesrc_char_match_noninit (*++p, 'F', 'f')))
8605 return FFEEXPR_percentREF_;
8606 return FFEEXPR_percentNONE_;
8607
8608 case FFESRC_CASE_MATCH_INIT ('V', 'v', match_3v, no_match_3):
8609 if ((ffesrc_char_match_noninit (*++p, 'A', 'a'))
8610 && (ffesrc_char_match_noninit (*++p, 'L', 'l')))
8611 return FFEEXPR_percentVAL_;
8612 return FFEEXPR_percentNONE_;
8613
8614 default:
8615 no_match_3: /* :::::::::::::::::::: */
8616 return FFEEXPR_percentNONE_;
8617 }
8618
8619 case 5:
8620 if (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "DESCR",
8621 "descr", "Descr") == 0)
8622 return FFEEXPR_percentDESCR_;
8623 return FFEEXPR_percentNONE_;
8624
8625 default:
8626 return FFEEXPR_percentNONE_;
8627 }
8628 }
8629
8630 /* ffeexpr_type_combine -- Binop combine types, check for mythical new COMPLEX
8631
8632 See prototype.
8633
8634 If combining the two basictype/kindtype pairs produces a COMPLEX with an
8635 unsupported kind type, complain and use the default kind type for
8636 COMPLEX. */
8637
8638 void
8639 ffeexpr_type_combine (ffeinfoBasictype *xnbt, ffeinfoKindtype *xnkt,
8640 ffeinfoBasictype lbt, ffeinfoKindtype lkt,
8641 ffeinfoBasictype rbt, ffeinfoKindtype rkt,
8642 ffelexToken t)
8643 {
8644 ffeinfoBasictype nbt;
8645 ffeinfoKindtype nkt;
8646
8647 nbt = ffeinfo_basictype_combine (lbt, rbt);
8648 if ((nbt == FFEINFO_basictypeCOMPLEX)
8649 && ((lbt == nbt) || (lbt == FFEINFO_basictypeREAL))
8650 && ((rbt == nbt) || (rbt == FFEINFO_basictypeREAL)))
8651 {
8652 nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
8653 if (ffe_is_pedantic_not_90 () && (nkt == FFEINFO_kindtypeREALDOUBLE))
8654 nkt = FFEINFO_kindtypeNONE; /* Force error. */
8655 switch (nkt)
8656 {
8657 #if FFETARGET_okCOMPLEX1
8658 case FFEINFO_kindtypeREAL1:
8659 #endif
8660 #if FFETARGET_okCOMPLEX2
8661 case FFEINFO_kindtypeREAL2:
8662 #endif
8663 #if FFETARGET_okCOMPLEX3
8664 case FFEINFO_kindtypeREAL3:
8665 #endif
8666 #if FFETARGET_okCOMPLEX4
8667 case FFEINFO_kindtypeREAL4:
8668 #endif
8669 break; /* Fine and dandy. */
8670
8671 default:
8672 if (t != NULL)
8673 {
8674 ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
8675 ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX);
8676 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8677 ffebad_finish ();
8678 }
8679 nbt = FFEINFO_basictypeNONE;
8680 nkt = FFEINFO_kindtypeNONE;
8681 break;
8682
8683 case FFEINFO_kindtypeANY:
8684 nkt = FFEINFO_kindtypeREALDEFAULT;
8685 break;
8686 }
8687 }
8688 else
8689 { /* The normal stuff. */
8690 if (nbt == lbt)
8691 {
8692 if (nbt == rbt)
8693 nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
8694 else
8695 nkt = lkt;
8696 }
8697 else if (nbt == rbt)
8698 nkt = rkt;
8699 else
8700 { /* Let the caller do the complaining. */
8701 nbt = FFEINFO_basictypeNONE;
8702 nkt = FFEINFO_kindtypeNONE;
8703 }
8704 }
8705
8706 /* Always a good idea to avoid aliasing problems. */
8707
8708 *xnbt = nbt;
8709 *xnkt = nkt;
8710 }
8711
8712 /* ffeexpr_token_first_lhs_ -- First state for lhs expression
8713
8714 Return a pointer to this function to the lexer (ffelex), which will
8715 invoke it for the next token.
8716
8717 Record line and column of first token in expression, then invoke the
8718 initial-state lhs handler. */
8719
8720 static ffelexHandler
8721 ffeexpr_token_first_lhs_ (ffelexToken t)
8722 {
8723 ffeexpr_stack_->first_token = ffelex_token_use (t);
8724
8725 /* When changing the list of valid initial lhs tokens, check whether to
8726 update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
8727 READ (expr) <token> case -- it assumes it knows which tokens <token> can
8728 be to indicate an lhs (or implied DO), which right now is the set
8729 {NAME,OPEN_PAREN}.
8730
8731 This comment also appears in ffeexpr_token_lhs_. */
8732
8733 switch (ffelex_token_type (t))
8734 {
8735 case FFELEX_typeOPEN_PAREN:
8736 switch (ffeexpr_stack_->context)
8737 {
8738 case FFEEXPR_contextDATA:
8739 ffe_init_4 ();
8740 ffeexpr_level_ = 1; /* Level of DATA implied-DO construct. */
8741 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8742 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8743 FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
8744
8745 case FFEEXPR_contextDATAIMPDOITEM_:
8746 ++ffeexpr_level_; /* Level of DATA implied-DO construct. */
8747 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8748 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8749 FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
8750
8751 case FFEEXPR_contextIOLIST:
8752 case FFEEXPR_contextIMPDOITEM_:
8753 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8754 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8755 FFEEXPR_contextIMPDOITEM_, ffeexpr_cb_comma_i_);
8756
8757 case FFEEXPR_contextIOLISTDF:
8758 case FFEEXPR_contextIMPDOITEMDF_:
8759 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8760 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8761 FFEEXPR_contextIMPDOITEMDF_, ffeexpr_cb_comma_i_);
8762
8763 case FFEEXPR_contextFILEEXTFUNC:
8764 assert (ffeexpr_stack_->exprstack == NULL);
8765 return (ffelexHandler) ffeexpr_token_first_lhs_1_;
8766
8767 default:
8768 break;
8769 }
8770 break;
8771
8772 case FFELEX_typeNAME:
8773 switch (ffeexpr_stack_->context)
8774 {
8775 case FFEEXPR_contextFILENAMELIST:
8776 assert (ffeexpr_stack_->exprstack == NULL);
8777 return (ffelexHandler) ffeexpr_token_namelist_;
8778
8779 case FFEEXPR_contextFILEEXTFUNC:
8780 assert (ffeexpr_stack_->exprstack == NULL);
8781 return (ffelexHandler) ffeexpr_token_first_lhs_1_;
8782
8783 default:
8784 break;
8785 }
8786 break;
8787
8788 default:
8789 switch (ffeexpr_stack_->context)
8790 {
8791 case FFEEXPR_contextFILEEXTFUNC:
8792 assert (ffeexpr_stack_->exprstack == NULL);
8793 return (ffelexHandler) ffeexpr_token_first_lhs_1_;
8794
8795 default:
8796 break;
8797 }
8798 break;
8799 }
8800
8801 return (ffelexHandler) ffeexpr_token_lhs_ (t);
8802 }
8803
8804 /* ffeexpr_token_first_lhs_1_ -- NAME
8805
8806 return ffeexpr_token_first_lhs_1_; // to lexer
8807
8808 Handle NAME as an external function (USEROPEN= VXT extension to OPEN
8809 statement). */
8810
8811 static ffelexHandler
8812 ffeexpr_token_first_lhs_1_ (ffelexToken t)
8813 {
8814 ffeexprCallback callback;
8815 ffeexprStack_ s;
8816 ffelexHandler next;
8817 ffelexToken ft;
8818 ffesymbol sy = NULL;
8819 ffebld expr;
8820
8821 ffebld_pool_pop ();
8822 callback = ffeexpr_stack_->callback;
8823 ft = ffeexpr_stack_->first_token;
8824 s = ffeexpr_stack_->previous;
8825
8826 if ((ffelex_token_type (ft) != FFELEX_typeNAME)
8827 || (ffesymbol_attrs (sy = ffeexpr_declare_unadorned_ (ft, FALSE))
8828 & FFESYMBOL_attrANY))
8829 {
8830 if ((ffelex_token_type (ft) != FFELEX_typeNAME)
8831 || !(ffesymbol_attrs (sy) & FFESYMBOL_attrsANY))
8832 {
8833 ffebad_start (FFEBAD_EXPR_WRONG);
8834 ffebad_here (0, ffelex_token_where_line (ft),
8835 ffelex_token_where_column (ft));
8836 ffebad_finish ();
8837 }
8838 expr = ffebld_new_any ();
8839 ffebld_set_info (expr, ffeinfo_new_any ());
8840 }
8841 else
8842 {
8843 expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
8844 FFEINTRIN_impNONE);
8845 ffebld_set_info (expr, ffesymbol_info (sy));
8846 }
8847
8848 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
8849 sizeof (*ffeexpr_stack_));
8850 ffeexpr_stack_ = s;
8851
8852 next = (ffelexHandler) (*callback) (ft, expr, t);
8853 ffelex_token_kill (ft);
8854 return (ffelexHandler) next;
8855 }
8856
8857 /* ffeexpr_token_first_rhs_ -- First state for rhs expression
8858
8859 Record line and column of first token in expression, then invoke the
8860 initial-state rhs handler.
8861
8862 19-Feb-91 JCB 1.1
8863 Allow ASTERISK in PARENFILEUNIT_ case, but only on second level only
8864 (i.e. only as in READ(*), not READ((*))). */
8865
8866 static ffelexHandler
8867 ffeexpr_token_first_rhs_ (ffelexToken t)
8868 {
8869 ffesymbol s;
8870
8871 ffeexpr_stack_->first_token = ffelex_token_use (t);
8872
8873 switch (ffelex_token_type (t))
8874 {
8875 case FFELEX_typeASTERISK:
8876 switch (ffeexpr_stack_->context)
8877 {
8878 case FFEEXPR_contextFILEFORMATNML:
8879 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8880 /* Fall through. */
8881 case FFEEXPR_contextFILEUNIT:
8882 case FFEEXPR_contextDIMLIST:
8883 case FFEEXPR_contextFILEFORMAT:
8884 case FFEEXPR_contextCHARACTERSIZE:
8885 if (ffeexpr_stack_->previous != NULL)
8886 break; /* Valid only on first level. */
8887 assert (ffeexpr_stack_->exprstack == NULL);
8888 return (ffelexHandler) ffeexpr_token_first_rhs_1_;
8889
8890 case FFEEXPR_contextPARENFILEUNIT_:
8891 if (ffeexpr_stack_->previous->previous != NULL)
8892 break; /* Valid only on second level. */
8893 assert (ffeexpr_stack_->exprstack == NULL);
8894 return (ffelexHandler) ffeexpr_token_first_rhs_1_;
8895
8896 case FFEEXPR_contextACTUALARG_:
8897 if (ffeexpr_stack_->previous->context
8898 != FFEEXPR_contextSUBROUTINEREF)
8899 {
8900 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8901 break;
8902 }
8903 assert (ffeexpr_stack_->exprstack == NULL);
8904 return (ffelexHandler) ffeexpr_token_first_rhs_3_;
8905
8906 case FFEEXPR_contextINDEXORACTUALARG_:
8907 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8908 break;
8909
8910 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8911 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8912 break;
8913
8914 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8915 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8916 break;
8917
8918 default:
8919 break;
8920 }
8921 break;
8922
8923 case FFELEX_typeOPEN_PAREN:
8924 switch (ffeexpr_stack_->context)
8925 {
8926 case FFEEXPR_contextFILENUMAMBIG:
8927 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8928 FFEEXPR_contextPARENFILENUM_,
8929 ffeexpr_cb_close_paren_ambig_);
8930
8931 case FFEEXPR_contextFILEUNITAMBIG:
8932 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8933 FFEEXPR_contextPARENFILEUNIT_,
8934 ffeexpr_cb_close_paren_ambig_);
8935
8936 case FFEEXPR_contextIOLIST:
8937 case FFEEXPR_contextIMPDOITEM_:
8938 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8939 FFEEXPR_contextIMPDOITEM_,
8940 ffeexpr_cb_close_paren_ci_);
8941
8942 case FFEEXPR_contextIOLISTDF:
8943 case FFEEXPR_contextIMPDOITEMDF_:
8944 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8945 FFEEXPR_contextIMPDOITEMDF_,
8946 ffeexpr_cb_close_paren_ci_);
8947
8948 case FFEEXPR_contextFILEFORMATNML:
8949 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8950 break;
8951
8952 case FFEEXPR_contextACTUALARG_:
8953 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8954 break;
8955
8956 case FFEEXPR_contextINDEXORACTUALARG_:
8957 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8958 break;
8959
8960 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8961 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8962 break;
8963
8964 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8965 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8966 break;
8967
8968 default:
8969 break;
8970 }
8971 break;
8972
8973 case FFELEX_typeNUMBER:
8974 switch (ffeexpr_stack_->context)
8975 {
8976 case FFEEXPR_contextFILEFORMATNML:
8977 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8978 /* Fall through. */
8979 case FFEEXPR_contextFILEFORMAT:
8980 if (ffeexpr_stack_->previous != NULL)
8981 break; /* Valid only on first level. */
8982 assert (ffeexpr_stack_->exprstack == NULL);
8983 return (ffelexHandler) ffeexpr_token_first_rhs_2_;
8984
8985 case FFEEXPR_contextACTUALARG_:
8986 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8987 break;
8988
8989 case FFEEXPR_contextINDEXORACTUALARG_:
8990 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8991 break;
8992
8993 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8994 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8995 break;
8996
8997 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8998 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8999 break;
9000
9001 default:
9002 break;
9003 }
9004 break;
9005
9006 case FFELEX_typeNAME:
9007 switch (ffeexpr_stack_->context)
9008 {
9009 case FFEEXPR_contextFILEFORMATNML:
9010 assert (ffeexpr_stack_->exprstack == NULL);
9011 s = ffesymbol_lookup_local (t);
9012 if ((s != NULL) && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST))
9013 return (ffelexHandler) ffeexpr_token_namelist_;
9014 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
9015 break;
9016
9017 default:
9018 break;
9019 }
9020 break;
9021
9022 case FFELEX_typePERCENT:
9023 switch (ffeexpr_stack_->context)
9024 {
9025 case FFEEXPR_contextACTUALARG_:
9026 case FFEEXPR_contextINDEXORACTUALARG_:
9027 case FFEEXPR_contextSFUNCDEFACTUALARG_:
9028 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9029 return (ffelexHandler) ffeexpr_token_first_rhs_5_;
9030
9031 case FFEEXPR_contextFILEFORMATNML:
9032 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
9033 break;
9034
9035 default:
9036 break;
9037 }
9038
9039 default:
9040 switch (ffeexpr_stack_->context)
9041 {
9042 case FFEEXPR_contextACTUALARG_:
9043 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
9044 break;
9045
9046 case FFEEXPR_contextINDEXORACTUALARG_:
9047 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
9048 break;
9049
9050 case FFEEXPR_contextSFUNCDEFACTUALARG_:
9051 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
9052 break;
9053
9054 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9055 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
9056 break;
9057
9058 case FFEEXPR_contextFILEFORMATNML:
9059 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
9060 break;
9061
9062 default:
9063 break;
9064 }
9065 break;
9066 }
9067
9068 return (ffelexHandler) ffeexpr_token_rhs_ (t);
9069 }
9070
9071 /* ffeexpr_token_first_rhs_1_ -- ASTERISK
9072
9073 return ffeexpr_token_first_rhs_1_; // to lexer
9074
9075 Return STAR as expression. */
9076
9077 static ffelexHandler
9078 ffeexpr_token_first_rhs_1_ (ffelexToken t)
9079 {
9080 ffebld expr;
9081 ffeexprCallback callback;
9082 ffeexprStack_ s;
9083 ffelexHandler next;
9084 ffelexToken ft;
9085
9086 expr = ffebld_new_star ();
9087 ffebld_pool_pop ();
9088 callback = ffeexpr_stack_->callback;
9089 ft = ffeexpr_stack_->first_token;
9090 s = ffeexpr_stack_->previous;
9091 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
9092 ffeexpr_stack_ = s;
9093 next = (ffelexHandler) (*callback) (ft, expr, t);
9094 ffelex_token_kill (ft);
9095 return (ffelexHandler) next;
9096 }
9097
9098 /* ffeexpr_token_first_rhs_2_ -- NUMBER
9099
9100 return ffeexpr_token_first_rhs_2_; // to lexer
9101
9102 Return NULL as expression; NUMBER as first (and only) token, unless the
9103 current token is not a terminating token, in which case run normal
9104 expression handling. */
9105
9106 static ffelexHandler
9107 ffeexpr_token_first_rhs_2_ (ffelexToken t)
9108 {
9109 ffeexprCallback callback;
9110 ffeexprStack_ s;
9111 ffelexHandler next;
9112 ffelexToken ft;
9113
9114 switch (ffelex_token_type (t))
9115 {
9116 case FFELEX_typeCLOSE_PAREN:
9117 case FFELEX_typeCOMMA:
9118 case FFELEX_typeEOS:
9119 case FFELEX_typeSEMICOLON:
9120 break;
9121
9122 default:
9123 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9124 return (ffelexHandler) (*next) (t);
9125 }
9126
9127 ffebld_pool_pop ();
9128 callback = ffeexpr_stack_->callback;
9129 ft = ffeexpr_stack_->first_token;
9130 s = ffeexpr_stack_->previous;
9131 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
9132 sizeof (*ffeexpr_stack_));
9133 ffeexpr_stack_ = s;
9134 next = (ffelexHandler) (*callback) (ft, NULL, t);
9135 ffelex_token_kill (ft);
9136 return (ffelexHandler) next;
9137 }
9138
9139 /* ffeexpr_token_first_rhs_3_ -- ASTERISK
9140
9141 return ffeexpr_token_first_rhs_3_; // to lexer
9142
9143 Expect NUMBER, make LABTOK (with copy of token if not inhibited after
9144 confirming, else NULL). */
9145
9146 static ffelexHandler
9147 ffeexpr_token_first_rhs_3_ (ffelexToken t)
9148 {
9149 ffelexHandler next;
9150
9151 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
9152 { /* An error, but let normal processing handle
9153 it. */
9154 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9155 return (ffelexHandler) (*next) (t);
9156 }
9157
9158 /* Special case: when we see "*10" as an argument to a subroutine
9159 reference, we confirm the current statement and, if not inhibited at
9160 this point, put a copy of the token into a LABTOK node. We do this
9161 instead of just resolving the label directly via ffelab and putting it
9162 into a LABTER simply to improve error reporting and consistency in
9163 ffestc. We put NULL in the LABTOK if we're still inhibited, so ffestb
9164 doesn't have to worry about killing off any tokens when retracting. */
9165
9166 ffest_confirmed ();
9167 if (ffest_is_inhibited ())
9168 ffeexpr_stack_->expr = ffebld_new_labtok (NULL);
9169 else
9170 ffeexpr_stack_->expr = ffebld_new_labtok (ffelex_token_use (t));
9171 ffebld_set_info (ffeexpr_stack_->expr,
9172 ffeinfo_new (FFEINFO_basictypeNONE,
9173 FFEINFO_kindtypeNONE,
9174 0,
9175 FFEINFO_kindNONE,
9176 FFEINFO_whereNONE,
9177 FFETARGET_charactersizeNONE));
9178
9179 return (ffelexHandler) ffeexpr_token_first_rhs_4_;
9180 }
9181
9182 /* ffeexpr_token_first_rhs_4_ -- ASTERISK NUMBER
9183
9184 return ffeexpr_token_first_rhs_4_; // to lexer
9185
9186 Collect/flush appropriate stuff, send token to callback function. */
9187
9188 static ffelexHandler
9189 ffeexpr_token_first_rhs_4_ (ffelexToken t)
9190 {
9191 ffebld expr;
9192 ffeexprCallback callback;
9193 ffeexprStack_ s;
9194 ffelexHandler next;
9195 ffelexToken ft;
9196
9197 expr = ffeexpr_stack_->expr;
9198 ffebld_pool_pop ();
9199 callback = ffeexpr_stack_->callback;
9200 ft = ffeexpr_stack_->first_token;
9201 s = ffeexpr_stack_->previous;
9202 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
9203 ffeexpr_stack_ = s;
9204 next = (ffelexHandler) (*callback) (ft, expr, t);
9205 ffelex_token_kill (ft);
9206 return (ffelexHandler) next;
9207 }
9208
9209 /* ffeexpr_token_first_rhs_5_ -- PERCENT
9210
9211 Should be NAME, or pass through original mechanism. If NAME is LOC,
9212 pass through original mechanism, otherwise must be VAL, REF, or DESCR,
9213 in which case handle the argument (in parentheses), etc. */
9214
9215 static ffelexHandler
9216 ffeexpr_token_first_rhs_5_ (ffelexToken t)
9217 {
9218 ffelexHandler next;
9219
9220 if (ffelex_token_type (t) == FFELEX_typeNAME)
9221 {
9222 ffeexprPercent_ p = ffeexpr_percent_ (t);
9223
9224 switch (p)
9225 {
9226 case FFEEXPR_percentNONE_:
9227 case FFEEXPR_percentLOC_:
9228 break; /* Treat %LOC as any other expression. */
9229
9230 case FFEEXPR_percentVAL_:
9231 case FFEEXPR_percentREF_:
9232 case FFEEXPR_percentDESCR_:
9233 ffeexpr_stack_->percent = p;
9234 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
9235 return (ffelexHandler) ffeexpr_token_first_rhs_6_;
9236
9237 default:
9238 assert ("bad percent?!?" == NULL);
9239 break;
9240 }
9241 }
9242
9243 switch (ffeexpr_stack_->context)
9244 {
9245 case FFEEXPR_contextACTUALARG_:
9246 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
9247 break;
9248
9249 case FFEEXPR_contextINDEXORACTUALARG_:
9250 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
9251 break;
9252
9253 case FFEEXPR_contextSFUNCDEFACTUALARG_:
9254 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
9255 break;
9256
9257 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9258 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
9259 break;
9260
9261 default:
9262 assert ("bad context?!?!" == NULL);
9263 break;
9264 }
9265
9266 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9267 return (ffelexHandler) (*next) (t);
9268 }
9269
9270 /* ffeexpr_token_first_rhs_6_ -- PERCENT NAME(VAL,REF,DESCR)
9271
9272 Should be OPEN_PAREN, or pass through original mechanism. */
9273
9274 static ffelexHandler
9275 ffeexpr_token_first_rhs_6_ (ffelexToken t)
9276 {
9277 ffelexHandler next;
9278 ffelexToken ft;
9279
9280 if (ffelex_token_type (t) == FFELEX_typeOPEN_PAREN)
9281 {
9282 ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
9283 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
9284 ffeexpr_stack_->context,
9285 ffeexpr_cb_end_notloc_);
9286 }
9287
9288 switch (ffeexpr_stack_->context)
9289 {
9290 case FFEEXPR_contextACTUALARG_:
9291 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
9292 break;
9293
9294 case FFEEXPR_contextINDEXORACTUALARG_:
9295 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
9296 break;
9297
9298 case FFEEXPR_contextSFUNCDEFACTUALARG_:
9299 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
9300 break;
9301
9302 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9303 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
9304 break;
9305
9306 default:
9307 assert ("bad context?!?!" == NULL);
9308 break;
9309 }
9310
9311 ft = ffeexpr_stack_->tokens[0];
9312 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9313 next = (ffelexHandler) (*next) (ft);
9314 ffelex_token_kill (ft);
9315 return (ffelexHandler) (*next) (t);
9316 }
9317
9318 /* ffeexpr_token_namelist_ -- NAME
9319
9320 return ffeexpr_token_namelist_; // to lexer
9321
9322 Make sure NAME was a valid namelist object, wrap it in a SYMTER and
9323 return. */
9324
9325 static ffelexHandler
9326 ffeexpr_token_namelist_ (ffelexToken t)
9327 {
9328 ffeexprCallback callback;
9329 ffeexprStack_ s;
9330 ffelexHandler next;
9331 ffelexToken ft;
9332 ffesymbol sy;
9333 ffebld expr;
9334
9335 ffebld_pool_pop ();
9336 callback = ffeexpr_stack_->callback;
9337 ft = ffeexpr_stack_->first_token;
9338 s = ffeexpr_stack_->previous;
9339 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
9340 ffeexpr_stack_ = s;
9341
9342 sy = ffesymbol_lookup_local (ft);
9343 if ((sy == NULL) || (ffesymbol_kind (sy) != FFEINFO_kindNAMELIST))
9344 {
9345 ffebad_start (FFEBAD_EXPR_WRONG);
9346 ffebad_here (0, ffelex_token_where_line (ft),
9347 ffelex_token_where_column (ft));
9348 ffebad_finish ();
9349 expr = ffebld_new_any ();
9350 ffebld_set_info (expr, ffeinfo_new_any ());
9351 }
9352 else
9353 {
9354 expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
9355 FFEINTRIN_impNONE);
9356 ffebld_set_info (expr, ffesymbol_info (sy));
9357 }
9358 next = (ffelexHandler) (*callback) (ft, expr, t);
9359 ffelex_token_kill (ft);
9360 return (ffelexHandler) next;
9361 }
9362
9363 /* ffeexpr_expr_kill_ -- Kill an existing internal expression object
9364
9365 ffeexprExpr_ e;
9366 ffeexpr_expr_kill_(e);
9367
9368 Kills the ffewhere info, if necessary, then kills the object. */
9369
9370 static void
9371 ffeexpr_expr_kill_ (ffeexprExpr_ e)
9372 {
9373 if (e->token != NULL)
9374 ffelex_token_kill (e->token);
9375 malloc_kill_ks (ffe_pool_program_unit (), e, sizeof (*e));
9376 }
9377
9378 /* ffeexpr_expr_new_ -- Make a new internal expression object
9379
9380 ffeexprExpr_ e;
9381 e = ffeexpr_expr_new_();
9382
9383 Allocates and initializes a new expression object, returns it. */
9384
9385 static ffeexprExpr_
9386 ffeexpr_expr_new_ ()
9387 {
9388 ffeexprExpr_ e;
9389
9390 e = (ffeexprExpr_) malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR expr",
9391 sizeof (*e));
9392 e->previous = NULL;
9393 e->type = FFEEXPR_exprtypeUNKNOWN_;
9394 e->token = NULL;
9395 return e;
9396 }
9397
9398 /* Verify that call to global is valid, and register whatever
9399 new information about a global might be discoverable by looking
9400 at the call. */
9401
9402 static void
9403 ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t)
9404 {
9405 int n_args;
9406 ffebld list;
9407 ffebld item;
9408 ffesymbol s;
9409
9410 assert ((ffebld_op (*expr) == FFEBLD_opSUBRREF)
9411 || (ffebld_op (*expr) == FFEBLD_opFUNCREF));
9412
9413 if (ffebld_op (ffebld_left (*expr)) != FFEBLD_opSYMTER)
9414 return;
9415
9416 if (ffesymbol_retractable ())
9417 return;
9418
9419 s = ffebld_symter (ffebld_left (*expr));
9420 if (ffesymbol_global (s) == NULL)
9421 return;
9422
9423 for (n_args = 0, list = ffebld_right (*expr);
9424 list != NULL;
9425 list = ffebld_trail (list), ++n_args)
9426 ;
9427
9428 if (ffeglobal_proc_ref_nargs (s, n_args, t))
9429 {
9430 ffeglobalArgSummary as;
9431 ffeinfoBasictype bt;
9432 ffeinfoKindtype kt;
9433 bool array;
9434 bool fail = FALSE;
9435
9436 for (n_args = 0, list = ffebld_right (*expr);
9437 list != NULL;
9438 list = ffebld_trail (list), ++n_args)
9439 {
9440 item = ffebld_head (list);
9441 if (item != NULL)
9442 {
9443 bt = ffeinfo_basictype (ffebld_info (item));
9444 kt = ffeinfo_kindtype (ffebld_info (item));
9445 array = (ffeinfo_rank (ffebld_info (item)) > 0);
9446 switch (ffebld_op (item))
9447 {
9448 case FFEBLD_opLABTOK:
9449 case FFEBLD_opLABTER:
9450 as = FFEGLOBAL_argsummaryALTRTN;
9451 break;
9452
9453 #if 0
9454 /* No, %LOC(foo) is just like any INTEGER(KIND=7)
9455 expression, so don't treat it specially. */
9456 case FFEBLD_opPERCENT_LOC:
9457 as = FFEGLOBAL_argsummaryPTR;
9458 break;
9459 #endif
9460
9461 case FFEBLD_opPERCENT_VAL:
9462 as = FFEGLOBAL_argsummaryVAL;
9463 break;
9464
9465 case FFEBLD_opPERCENT_REF:
9466 as = FFEGLOBAL_argsummaryREF;
9467 break;
9468
9469 case FFEBLD_opPERCENT_DESCR:
9470 as = FFEGLOBAL_argsummaryDESCR;
9471 break;
9472
9473 case FFEBLD_opFUNCREF:
9474 #if 0
9475 /* No, LOC(foo) is just like any INTEGER(KIND=7)
9476 expression, so don't treat it specially. */
9477 if ((ffebld_op (ffebld_left (item)) == FFEBLD_opSYMTER)
9478 && (ffesymbol_specific (ffebld_symter (ffebld_left (item)))
9479 == FFEINTRIN_specLOC))
9480 {
9481 as = FFEGLOBAL_argsummaryPTR;
9482 break;
9483 }
9484 #endif
9485 /* Fall through. */
9486 default:
9487 if (ffebld_op (item) == FFEBLD_opSYMTER)
9488 {
9489 as = FFEGLOBAL_argsummaryNONE;
9490
9491 switch (ffeinfo_kind (ffebld_info (item)))
9492 {
9493 case FFEINFO_kindFUNCTION:
9494 as = FFEGLOBAL_argsummaryFUNC;
9495 break;
9496
9497 case FFEINFO_kindSUBROUTINE:
9498 as = FFEGLOBAL_argsummarySUBR;
9499 break;
9500
9501 case FFEINFO_kindNONE:
9502 as = FFEGLOBAL_argsummaryPROC;
9503 break;
9504
9505 default:
9506 break;
9507 }
9508
9509 if (as != FFEGLOBAL_argsummaryNONE)
9510 break;
9511 }
9512
9513 if (bt == FFEINFO_basictypeCHARACTER)
9514 as = FFEGLOBAL_argsummaryDESCR;
9515 else
9516 as = FFEGLOBAL_argsummaryREF;
9517 break;
9518 }
9519 }
9520 else
9521 {
9522 array = FALSE;
9523 as = FFEGLOBAL_argsummaryNONE;
9524 bt = FFEINFO_basictypeNONE;
9525 kt = FFEINFO_kindtypeNONE;
9526 }
9527
9528 if (! ffeglobal_proc_ref_arg (s, n_args, as, bt, kt, array, t))
9529 fail = TRUE;
9530 }
9531 if (! fail)
9532 return;
9533 }
9534
9535 *expr = ffebld_new_any ();
9536 ffebld_set_info (*expr, ffeinfo_new_any ());
9537 }
9538
9539 /* Check whether rest of string is all decimal digits. */
9540
9541 static bool
9542 ffeexpr_isdigits_ (const char *p)
9543 {
9544 for (; *p != '\0'; ++p)
9545 if (! ISDIGIT (*p))
9546 return FALSE;
9547 return TRUE;
9548 }
9549
9550 /* ffeexpr_exprstack_push_ -- Push an arbitrary expression object onto the stack
9551
9552 ffeexprExpr_ e;
9553 ffeexpr_exprstack_push_(e);
9554
9555 Pushes the expression onto the stack without any analysis of the existing
9556 contents of the stack. */
9557
9558 static void
9559 ffeexpr_exprstack_push_ (ffeexprExpr_ e)
9560 {
9561 e->previous = ffeexpr_stack_->exprstack;
9562 ffeexpr_stack_->exprstack = e;
9563 }
9564
9565 /* ffeexpr_exprstack_push_operand_ -- Push an operand onto the stack, reduce?
9566
9567 ffeexprExpr_ e;
9568 ffeexpr_exprstack_push_operand_(e);
9569
9570 Pushes the expression already containing an operand (a constant, variable,
9571 or more complicated expression that has already been fully resolved) after
9572 analyzing the stack and checking for possible reduction (which will never
9573 happen here since the highest precedence operator is ** and it has right-
9574 to-left associativity). */
9575
9576 static void
9577 ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e)
9578 {
9579 ffeexpr_exprstack_push_ (e);
9580 #ifdef WEIRD_NONFORTRAN_RULES
9581 if ((ffeexpr_stack_->exprstack != NULL)
9582 && (ffeexpr_stack_->exprstack->expr->type == FFEEXPR_exprtypeBINARY_)
9583 && (ffeexpr_stack_->exprstack->expr->u.operator.prec
9584 == FFEEXPR_operatorprecedenceHIGHEST_)
9585 && (ffeexpr_stack_->exprstack->expr->u.operator.as
9586 == FFEEXPR_operatorassociativityL2R_))
9587 ffeexpr_reduce_ ();
9588 #endif
9589 }
9590
9591 /* ffeexpr_exprstack_push_unary_ -- Push a unary operator onto the stack
9592
9593 ffeexprExpr_ e;
9594 ffeexpr_exprstack_push_unary_(e);
9595
9596 Pushes the expression already containing a unary operator. Reduction can
9597 never happen since unary operators are themselves always R-L; that is, the
9598 top of the expression stack is not an operand, in that it is either empty,
9599 has a binary operator at the top, or a unary operator at the top. In any
9600 of these cases, reduction is impossible. */
9601
9602 static void
9603 ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e)
9604 {
9605 if ((ffe_is_pedantic ()
9606 || ffe_is_warn_surprising ())
9607 && (ffeexpr_stack_->exprstack != NULL)
9608 && (ffeexpr_stack_->exprstack->type != FFEEXPR_exprtypeOPERAND_)
9609 && (ffeexpr_stack_->exprstack->u.operator.prec
9610 <= FFEEXPR_operatorprecedenceLOWARITH_)
9611 && (e->u.operator.prec <= FFEEXPR_operatorprecedenceLOWARITH_))
9612 {
9613 /* xgettext:no-c-format */
9614 ffebad_start_msg ("Two arithmetic operators in a row at %0 and %1 -- use parentheses",
9615 ffe_is_pedantic ()
9616 ? FFEBAD_severityPEDANTIC
9617 : FFEBAD_severityWARNING);
9618 ffebad_here (0,
9619 ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
9620 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
9621 ffebad_here (1,
9622 ffelex_token_where_line (e->token),
9623 ffelex_token_where_column (e->token));
9624 ffebad_finish ();
9625 }
9626
9627 ffeexpr_exprstack_push_ (e);
9628 }
9629
9630 /* ffeexpr_exprstack_push_binary_ -- Push a binary operator onto the stack, reduce?
9631
9632 ffeexprExpr_ e;
9633 ffeexpr_exprstack_push_binary_(e);
9634
9635 Pushes the expression already containing a binary operator after checking
9636 whether reduction is possible. If the stack is not empty, the top of the
9637 stack must be an operand or syntactic analysis has failed somehow. If
9638 the operand is preceded by a unary operator of higher (or equal and L-R
9639 associativity) precedence than the new binary operator, then reduce that
9640 preceding operator and its operand(s) before pushing the new binary
9641 operator. */
9642
9643 static void
9644 ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e)
9645 {
9646 ffeexprExpr_ ce;
9647
9648 if (ffe_is_warn_surprising ()
9649 /* These next two are always true (see assertions below). */
9650 && (ffeexpr_stack_->exprstack != NULL)
9651 && (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_)
9652 /* If the previous operator is a unary minus, and the binary op
9653 is of higher precedence, might not do what user expects,
9654 e.g. "-2**2" is "-(2**2)", i.e. "-4", not "(-2)**2", which would
9655 yield "4". */
9656 && (ffeexpr_stack_->exprstack->previous != NULL)
9657 && (ffeexpr_stack_->exprstack->previous->type == FFEEXPR_exprtypeUNARY_)
9658 && (ffeexpr_stack_->exprstack->previous->u.operator.op
9659 == FFEEXPR_operatorSUBTRACT_)
9660 && (e->u.operator.prec
9661 < ffeexpr_stack_->exprstack->previous->u.operator.prec))
9662 {
9663 /* xgettext:no-c-format */
9664 ffebad_start_msg ("Operator at %0 has lower precedence than that at %1 -- use parentheses", FFEBAD_severityWARNING);
9665 ffebad_here (0,
9666 ffelex_token_where_line (ffeexpr_stack_->exprstack->previous->token),
9667 ffelex_token_where_column (ffeexpr_stack_->exprstack->previous->token));
9668 ffebad_here (1,
9669 ffelex_token_where_line (e->token),
9670 ffelex_token_where_column (e->token));
9671 ffebad_finish ();
9672 }
9673
9674 again:
9675 assert (ffeexpr_stack_->exprstack != NULL);
9676 assert (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_);
9677 if ((ce = ffeexpr_stack_->exprstack->previous) != NULL)
9678 {
9679 assert (ce->type != FFEEXPR_exprtypeOPERAND_);
9680 if ((ce->u.operator.prec < e->u.operator.prec)
9681 || ((ce->u.operator.prec == e->u.operator.prec)
9682 && (e->u.operator.as == FFEEXPR_operatorassociativityL2R_)))
9683 {
9684 ffeexpr_reduce_ ();
9685 goto again; /* :::::::::::::::::::: */
9686 }
9687 }
9688
9689 ffeexpr_exprstack_push_ (e);
9690 }
9691
9692 /* ffeexpr_reduce_ -- Reduce highest operator w/operands on stack
9693
9694 ffeexpr_reduce_();
9695
9696 Converts operand binop operand or unop operand at top of stack to a
9697 single operand having the appropriate ffebld expression, and makes
9698 sure that the expression is proper (like not trying to add two character
9699 variables, not trying to concatenate two numbers). Also does the
9700 requisite type-assignment. */
9701
9702 static void
9703 ffeexpr_reduce_ ()
9704 {
9705 ffeexprExpr_ operand; /* This is B in -B or A+B. */
9706 ffeexprExpr_ left_operand; /* When operator is binary, this is A in A+B. */
9707 ffeexprExpr_ operator; /* This is + in A+B. */
9708 ffebld reduced; /* This is +(A,B) in A+B or u-(B) in -B. */
9709 ffebldConstant constnode; /* For checking magical numbers (where mag ==
9710 -mag). */
9711 ffebld expr;
9712 ffebld left_expr;
9713 bool submag = FALSE;
9714
9715 operand = ffeexpr_stack_->exprstack;
9716 assert (operand != NULL);
9717 assert (operand->type == FFEEXPR_exprtypeOPERAND_);
9718 operator = operand->previous;
9719 assert (operator != NULL);
9720 assert (operator->type != FFEEXPR_exprtypeOPERAND_);
9721 if (operator->type == FFEEXPR_exprtypeUNARY_)
9722 {
9723 expr = operand->u.operand;
9724 switch (operator->u.operator.op)
9725 {
9726 case FFEEXPR_operatorADD_:
9727 reduced = ffebld_new_uplus (expr);
9728 if (ffe_is_ugly_logint ())
9729 reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
9730 reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
9731 reduced = ffeexpr_collapse_uplus (reduced, operator->token);
9732 break;
9733
9734 case FFEEXPR_operatorSUBTRACT_:
9735 submag = TRUE; /* Ok to negate a magic number. */
9736 reduced = ffebld_new_uminus (expr);
9737 if (ffe_is_ugly_logint ())
9738 reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
9739 reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
9740 reduced = ffeexpr_collapse_uminus (reduced, operator->token);
9741 break;
9742
9743 case FFEEXPR_operatorNOT_:
9744 reduced = ffebld_new_not (expr);
9745 if (ffe_is_ugly_logint ())
9746 reduced = ffeexpr_reduced_ugly1log_ (reduced, operator, operand);
9747 reduced = ffeexpr_reduced_bool1_ (reduced, operator, operand);
9748 reduced = ffeexpr_collapse_not (reduced, operator->token);
9749 break;
9750
9751 default:
9752 assert ("unexpected unary op" != NULL);
9753 reduced = NULL;
9754 break;
9755 }
9756 if (!submag
9757 && (ffebld_op (expr) == FFEBLD_opCONTER)
9758 && (ffebld_conter_orig (expr) == NULL)
9759 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
9760 {
9761 ffetarget_integer_bad_magical (operand->token);
9762 }
9763 ffeexpr_stack_->exprstack = operator->previous; /* Pops unary-op operand
9764 off stack. */
9765 ffeexpr_expr_kill_ (operand);
9766 operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but
9767 save */
9768 operator->u.operand = reduced; /* the line/column ffewhere info. */
9769 ffeexpr_exprstack_push_operand_ (operator); /* Push it back on
9770 stack. */
9771 }
9772 else
9773 {
9774 assert (operator->type == FFEEXPR_exprtypeBINARY_);
9775 left_operand = operator->previous;
9776 assert (left_operand != NULL);
9777 assert (left_operand->type == FFEEXPR_exprtypeOPERAND_);
9778 expr = operand->u.operand;
9779 left_expr = left_operand->u.operand;
9780 switch (operator->u.operator.op)
9781 {
9782 case FFEEXPR_operatorADD_:
9783 reduced = ffebld_new_add (left_expr, expr);
9784 if (ffe_is_ugly_logint ())
9785 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9786 operand);
9787 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9788 operand);
9789 reduced = ffeexpr_collapse_add (reduced, operator->token);
9790 break;
9791
9792 case FFEEXPR_operatorSUBTRACT_:
9793 submag = TRUE; /* Just to pick the right error if magic
9794 number. */
9795 reduced = ffebld_new_subtract (left_expr, expr);
9796 if (ffe_is_ugly_logint ())
9797 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9798 operand);
9799 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9800 operand);
9801 reduced = ffeexpr_collapse_subtract (reduced, operator->token);
9802 break;
9803
9804 case FFEEXPR_operatorMULTIPLY_:
9805 reduced = ffebld_new_multiply (left_expr, expr);
9806 if (ffe_is_ugly_logint ())
9807 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9808 operand);
9809 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9810 operand);
9811 reduced = ffeexpr_collapse_multiply (reduced, operator->token);
9812 break;
9813
9814 case FFEEXPR_operatorDIVIDE_:
9815 reduced = ffebld_new_divide (left_expr, expr);
9816 if (ffe_is_ugly_logint ())
9817 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9818 operand);
9819 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9820 operand);
9821 reduced = ffeexpr_collapse_divide (reduced, operator->token);
9822 break;
9823
9824 case FFEEXPR_operatorPOWER_:
9825 reduced = ffebld_new_power (left_expr, expr);
9826 if (ffe_is_ugly_logint ())
9827 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9828 operand);
9829 reduced = ffeexpr_reduced_power_ (reduced, left_operand, operator,
9830 operand);
9831 reduced = ffeexpr_collapse_power (reduced, operator->token);
9832 break;
9833
9834 case FFEEXPR_operatorCONCATENATE_:
9835 reduced = ffebld_new_concatenate (left_expr, expr);
9836 reduced = ffeexpr_reduced_concatenate_ (reduced, left_operand, operator,
9837 operand);
9838 reduced = ffeexpr_collapse_concatenate (reduced, operator->token);
9839 break;
9840
9841 case FFEEXPR_operatorLT_:
9842 reduced = ffebld_new_lt (left_expr, expr);
9843 if (ffe_is_ugly_logint ())
9844 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9845 operand);
9846 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9847 operand);
9848 reduced = ffeexpr_collapse_lt (reduced, operator->token);
9849 break;
9850
9851 case FFEEXPR_operatorLE_:
9852 reduced = ffebld_new_le (left_expr, expr);
9853 if (ffe_is_ugly_logint ())
9854 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9855 operand);
9856 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9857 operand);
9858 reduced = ffeexpr_collapse_le (reduced, operator->token);
9859 break;
9860
9861 case FFEEXPR_operatorEQ_:
9862 reduced = ffebld_new_eq (left_expr, expr);
9863 if (ffe_is_ugly_logint ())
9864 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9865 operand);
9866 reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
9867 operand);
9868 reduced = ffeexpr_collapse_eq (reduced, operator->token);
9869 break;
9870
9871 case FFEEXPR_operatorNE_:
9872 reduced = ffebld_new_ne (left_expr, expr);
9873 if (ffe_is_ugly_logint ())
9874 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9875 operand);
9876 reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
9877 operand);
9878 reduced = ffeexpr_collapse_ne (reduced, operator->token);
9879 break;
9880
9881 case FFEEXPR_operatorGT_:
9882 reduced = ffebld_new_gt (left_expr, expr);
9883 if (ffe_is_ugly_logint ())
9884 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9885 operand);
9886 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9887 operand);
9888 reduced = ffeexpr_collapse_gt (reduced, operator->token);
9889 break;
9890
9891 case FFEEXPR_operatorGE_:
9892 reduced = ffebld_new_ge (left_expr, expr);
9893 if (ffe_is_ugly_logint ())
9894 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9895 operand);
9896 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9897 operand);
9898 reduced = ffeexpr_collapse_ge (reduced, operator->token);
9899 break;
9900
9901 case FFEEXPR_operatorAND_:
9902 reduced = ffebld_new_and (left_expr, expr);
9903 if (ffe_is_ugly_logint ())
9904 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9905 operand);
9906 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9907 operand);
9908 reduced = ffeexpr_collapse_and (reduced, operator->token);
9909 break;
9910
9911 case FFEEXPR_operatorOR_:
9912 reduced = ffebld_new_or (left_expr, expr);
9913 if (ffe_is_ugly_logint ())
9914 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9915 operand);
9916 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9917 operand);
9918 reduced = ffeexpr_collapse_or (reduced, operator->token);
9919 break;
9920
9921 case FFEEXPR_operatorXOR_:
9922 reduced = ffebld_new_xor (left_expr, expr);
9923 if (ffe_is_ugly_logint ())
9924 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9925 operand);
9926 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9927 operand);
9928 reduced = ffeexpr_collapse_xor (reduced, operator->token);
9929 break;
9930
9931 case FFEEXPR_operatorEQV_:
9932 reduced = ffebld_new_eqv (left_expr, expr);
9933 if (ffe_is_ugly_logint ())
9934 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9935 operand);
9936 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9937 operand);
9938 reduced = ffeexpr_collapse_eqv (reduced, operator->token);
9939 break;
9940
9941 case FFEEXPR_operatorNEQV_:
9942 reduced = ffebld_new_neqv (left_expr, expr);
9943 if (ffe_is_ugly_logint ())
9944 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9945 operand);
9946 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9947 operand);
9948 reduced = ffeexpr_collapse_neqv (reduced, operator->token);
9949 break;
9950
9951 default:
9952 assert ("bad bin op" == NULL);
9953 reduced = expr;
9954 break;
9955 }
9956 if ((ffebld_op (left_expr) == FFEBLD_opCONTER)
9957 && (ffebld_conter_orig (expr) == NULL)
9958 && ffebld_constant_is_magical (constnode = ffebld_conter (left_expr)))
9959 {
9960 if ((left_operand->previous != NULL)
9961 && (left_operand->previous->type != FFEEXPR_exprtypeOPERAND_)
9962 && (left_operand->previous->u.operator.op
9963 == FFEEXPR_operatorSUBTRACT_))
9964 {
9965 if (left_operand->previous->type == FFEEXPR_exprtypeUNARY_)
9966 ffetarget_integer_bad_magical_precedence (left_operand->token,
9967 left_operand->previous->token,
9968 operator->token);
9969 else
9970 ffetarget_integer_bad_magical_precedence_binary
9971 (left_operand->token,
9972 left_operand->previous->token,
9973 operator->token);
9974 }
9975 else
9976 ffetarget_integer_bad_magical (left_operand->token);
9977 }
9978 if ((ffebld_op (expr) == FFEBLD_opCONTER)
9979 && (ffebld_conter_orig (expr) == NULL)
9980 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
9981 {
9982 if (submag)
9983 ffetarget_integer_bad_magical_binary (operand->token,
9984 operator->token);
9985 else
9986 ffetarget_integer_bad_magical (operand->token);
9987 }
9988 ffeexpr_stack_->exprstack = left_operand->previous; /* Pops binary-op
9989 operands off stack. */
9990 ffeexpr_expr_kill_ (left_operand);
9991 ffeexpr_expr_kill_ (operand);
9992 operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but
9993 save */
9994 operator->u.operand = reduced; /* the line/column ffewhere info. */
9995 ffeexpr_exprstack_push_operand_ (operator); /* Push it back on
9996 stack. */
9997 }
9998 }
9999
10000 /* ffeexpr_reduced_bool1_ -- Wrap up reduction of NOT operator
10001
10002 reduced = ffeexpr_reduced_bool1_(reduced,op,r);
10003
10004 Makes sure the argument for reduced has basictype of
10005 LOGICAL or (ugly) INTEGER. If
10006 argument has where of CONSTANT, assign where CONSTANT to
10007 reduced, else assign where FLEETING.
10008
10009 If these requirements cannot be met, generate error message. */
10010
10011 static ffebld
10012 ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10013 {
10014 ffeinfo rinfo, ninfo;
10015 ffeinfoBasictype rbt;
10016 ffeinfoKindtype rkt;
10017 ffeinfoRank rrk;
10018 ffeinfoKind rkd;
10019 ffeinfoWhere rwh, nwh;
10020
10021 rinfo = ffebld_info (ffebld_left (reduced));
10022 rbt = ffeinfo_basictype (rinfo);
10023 rkt = ffeinfo_kindtype (rinfo);
10024 rrk = ffeinfo_rank (rinfo);
10025 rkd = ffeinfo_kind (rinfo);
10026 rwh = ffeinfo_where (rinfo);
10027
10028 if (((rbt == FFEINFO_basictypeLOGICAL)
10029 || (ffe_is_ugly_logint () && (rbt == FFEINFO_basictypeINTEGER)))
10030 && (rrk == 0))
10031 {
10032 switch (rwh)
10033 {
10034 case FFEINFO_whereCONSTANT:
10035 nwh = FFEINFO_whereCONSTANT;
10036 break;
10037
10038 case FFEINFO_whereIMMEDIATE:
10039 nwh = FFEINFO_whereIMMEDIATE;
10040 break;
10041
10042 default:
10043 nwh = FFEINFO_whereFLEETING;
10044 break;
10045 }
10046
10047 ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
10048 FFETARGET_charactersizeNONE);
10049 ffebld_set_info (reduced, ninfo);
10050 return reduced;
10051 }
10052
10053 if ((rbt != FFEINFO_basictypeLOGICAL)
10054 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
10055 {
10056 if ((rbt != FFEINFO_basictypeANY)
10057 && ffebad_start (FFEBAD_NOT_ARG_TYPE))
10058 {
10059 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10060 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10061 ffebad_finish ();
10062 }
10063 }
10064 else
10065 {
10066 if ((rkd != FFEINFO_kindANY)
10067 && ffebad_start (FFEBAD_NOT_ARG_KIND))
10068 {
10069 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10070 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10071 ffebad_string ("an array");
10072 ffebad_finish ();
10073 }
10074 }
10075
10076 reduced = ffebld_new_any ();
10077 ffebld_set_info (reduced, ffeinfo_new_any ());
10078 return reduced;
10079 }
10080
10081 /* ffeexpr_reduced_bool2_ -- Wrap up reduction of boolean operators
10082
10083 reduced = ffeexpr_reduced_bool2_(reduced,l,op,r);
10084
10085 Makes sure the left and right arguments for reduced have basictype of
10086 LOGICAL or (ugly) INTEGER. Determine common basictype and
10087 size for reduction (flag expression for combined hollerith/typeless
10088 situations for later determination of effective basictype). If both left
10089 and right arguments have where of CONSTANT, assign where CONSTANT to
10090 reduced, else assign where FLEETING. Create CONVERT ops for args where
10091 needed. Convert typeless
10092 constants to the desired type/size explicitly.
10093
10094 If these requirements cannot be met, generate error message. */
10095
10096 static ffebld
10097 ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10098 ffeexprExpr_ r)
10099 {
10100 ffeinfo linfo, rinfo, ninfo;
10101 ffeinfoBasictype lbt, rbt, nbt;
10102 ffeinfoKindtype lkt, rkt, nkt;
10103 ffeinfoRank lrk, rrk;
10104 ffeinfoKind lkd, rkd;
10105 ffeinfoWhere lwh, rwh, nwh;
10106
10107 linfo = ffebld_info (ffebld_left (reduced));
10108 lbt = ffeinfo_basictype (linfo);
10109 lkt = ffeinfo_kindtype (linfo);
10110 lrk = ffeinfo_rank (linfo);
10111 lkd = ffeinfo_kind (linfo);
10112 lwh = ffeinfo_where (linfo);
10113
10114 rinfo = ffebld_info (ffebld_right (reduced));
10115 rbt = ffeinfo_basictype (rinfo);
10116 rkt = ffeinfo_kindtype (rinfo);
10117 rrk = ffeinfo_rank (rinfo);
10118 rkd = ffeinfo_kind (rinfo);
10119 rwh = ffeinfo_where (rinfo);
10120
10121 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10122
10123 if (((nbt == FFEINFO_basictypeLOGICAL)
10124 || (ffe_is_ugly_logint () && (nbt == FFEINFO_basictypeINTEGER)))
10125 && (lrk == 0) && (rrk == 0))
10126 {
10127 switch (lwh)
10128 {
10129 case FFEINFO_whereCONSTANT:
10130 switch (rwh)
10131 {
10132 case FFEINFO_whereCONSTANT:
10133 nwh = FFEINFO_whereCONSTANT;
10134 break;
10135
10136 case FFEINFO_whereIMMEDIATE:
10137 nwh = FFEINFO_whereIMMEDIATE;
10138 break;
10139
10140 default:
10141 nwh = FFEINFO_whereFLEETING;
10142 break;
10143 }
10144 break;
10145
10146 case FFEINFO_whereIMMEDIATE:
10147 switch (rwh)
10148 {
10149 case FFEINFO_whereCONSTANT:
10150 case FFEINFO_whereIMMEDIATE:
10151 nwh = FFEINFO_whereIMMEDIATE;
10152 break;
10153
10154 default:
10155 nwh = FFEINFO_whereFLEETING;
10156 break;
10157 }
10158 break;
10159
10160 default:
10161 nwh = FFEINFO_whereFLEETING;
10162 break;
10163 }
10164
10165 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10166 FFETARGET_charactersizeNONE);
10167 ffebld_set_info (reduced, ninfo);
10168 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10169 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10170 FFEEXPR_contextLET));
10171 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10172 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10173 FFEEXPR_contextLET));
10174 return reduced;
10175 }
10176
10177 if ((lbt != FFEINFO_basictypeLOGICAL)
10178 && (!ffe_is_ugly_logint () || (lbt != FFEINFO_basictypeINTEGER)))
10179 {
10180 if ((rbt != FFEINFO_basictypeLOGICAL)
10181 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
10182 {
10183 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10184 && ffebad_start (FFEBAD_BOOL_ARGS_TYPE))
10185 {
10186 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10187 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10188 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10189 ffebad_finish ();
10190 }
10191 }
10192 else
10193 {
10194 if ((lbt != FFEINFO_basictypeANY)
10195 && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
10196 {
10197 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10198 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10199 ffebad_finish ();
10200 }
10201 }
10202 }
10203 else if ((rbt != FFEINFO_basictypeLOGICAL)
10204 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
10205 {
10206 if ((rbt != FFEINFO_basictypeANY)
10207 && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
10208 {
10209 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10210 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10211 ffebad_finish ();
10212 }
10213 }
10214 else if (lrk != 0)
10215 {
10216 if ((lkd != FFEINFO_kindANY)
10217 && ffebad_start (FFEBAD_BOOL_ARG_KIND))
10218 {
10219 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10220 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10221 ffebad_string ("an array");
10222 ffebad_finish ();
10223 }
10224 }
10225 else
10226 {
10227 if ((rkd != FFEINFO_kindANY)
10228 && ffebad_start (FFEBAD_BOOL_ARG_KIND))
10229 {
10230 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10231 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10232 ffebad_string ("an array");
10233 ffebad_finish ();
10234 }
10235 }
10236
10237 reduced = ffebld_new_any ();
10238 ffebld_set_info (reduced, ffeinfo_new_any ());
10239 return reduced;
10240 }
10241
10242 /* ffeexpr_reduced_concatenate_ -- Wrap up reduction of concatenate operator
10243
10244 reduced = ffeexpr_reduced_concatenate_(reduced,l,op,r);
10245
10246 Makes sure the left and right arguments for reduced have basictype of
10247 CHARACTER and kind of SCALAR, FUNCTION, or STATEMENT FUNCTION. Assign
10248 basictype of CHARACTER and kind of SCALAR to reduced. Calculate effective
10249 size of concatenation and assign that size to reduced. If both left and
10250 right arguments have where of CONSTANT, assign where CONSTANT to reduced,
10251 else assign where FLEETING.
10252
10253 If these requirements cannot be met, generate error message using the
10254 info in l, op, and r arguments and assign basictype, size, kind, and where
10255 of ANY. */
10256
10257 static ffebld
10258 ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10259 ffeexprExpr_ r)
10260 {
10261 ffeinfo linfo, rinfo, ninfo;
10262 ffeinfoBasictype lbt, rbt, nbt;
10263 ffeinfoKindtype lkt, rkt, nkt;
10264 ffeinfoRank lrk, rrk;
10265 ffeinfoKind lkd, rkd, nkd;
10266 ffeinfoWhere lwh, rwh, nwh;
10267 ffetargetCharacterSize lszm, lszk, rszm, rszk, nszk;
10268
10269 linfo = ffebld_info (ffebld_left (reduced));
10270 lbt = ffeinfo_basictype (linfo);
10271 lkt = ffeinfo_kindtype (linfo);
10272 lrk = ffeinfo_rank (linfo);
10273 lkd = ffeinfo_kind (linfo);
10274 lwh = ffeinfo_where (linfo);
10275 lszk = ffeinfo_size (linfo); /* Known size. */
10276 lszm = ffebld_size_max (ffebld_left (reduced));
10277
10278 rinfo = ffebld_info (ffebld_right (reduced));
10279 rbt = ffeinfo_basictype (rinfo);
10280 rkt = ffeinfo_kindtype (rinfo);
10281 rrk = ffeinfo_rank (rinfo);
10282 rkd = ffeinfo_kind (rinfo);
10283 rwh = ffeinfo_where (rinfo);
10284 rszk = ffeinfo_size (rinfo); /* Known size. */
10285 rszm = ffebld_size_max (ffebld_right (reduced));
10286
10287 if ((lbt == FFEINFO_basictypeCHARACTER) && (rbt == FFEINFO_basictypeCHARACTER)
10288 && (lkt == rkt) && (lrk == 0) && (rrk == 0)
10289 && (((lszm != FFETARGET_charactersizeNONE)
10290 && (rszm != FFETARGET_charactersizeNONE))
10291 || (ffeexpr_context_outer_ (ffeexpr_stack_)
10292 == FFEEXPR_contextLET)
10293 || (ffeexpr_context_outer_ (ffeexpr_stack_)
10294 == FFEEXPR_contextSFUNCDEF)))
10295 {
10296 nbt = FFEINFO_basictypeCHARACTER;
10297 nkd = FFEINFO_kindENTITY;
10298 if ((lszk == FFETARGET_charactersizeNONE)
10299 || (rszk == FFETARGET_charactersizeNONE))
10300 nszk = FFETARGET_charactersizeNONE; /* Ok only in rhs of LET
10301 stmt. */
10302 else
10303 nszk = lszk + rszk;
10304
10305 switch (lwh)
10306 {
10307 case FFEINFO_whereCONSTANT:
10308 switch (rwh)
10309 {
10310 case FFEINFO_whereCONSTANT:
10311 nwh = FFEINFO_whereCONSTANT;
10312 break;
10313
10314 case FFEINFO_whereIMMEDIATE:
10315 nwh = FFEINFO_whereIMMEDIATE;
10316 break;
10317
10318 default:
10319 nwh = FFEINFO_whereFLEETING;
10320 break;
10321 }
10322 break;
10323
10324 case FFEINFO_whereIMMEDIATE:
10325 switch (rwh)
10326 {
10327 case FFEINFO_whereCONSTANT:
10328 case FFEINFO_whereIMMEDIATE:
10329 nwh = FFEINFO_whereIMMEDIATE;
10330 break;
10331
10332 default:
10333 nwh = FFEINFO_whereFLEETING;
10334 break;
10335 }
10336 break;
10337
10338 default:
10339 nwh = FFEINFO_whereFLEETING;
10340 break;
10341 }
10342
10343 nkt = lkt;
10344 ninfo = ffeinfo_new (nbt, nkt, 0, nkd, nwh, nszk);
10345 ffebld_set_info (reduced, ninfo);
10346 return reduced;
10347 }
10348
10349 if ((lbt != FFEINFO_basictypeCHARACTER) && (rbt != FFEINFO_basictypeCHARACTER))
10350 {
10351 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10352 && ffebad_start (FFEBAD_CONCAT_ARGS_TYPE))
10353 {
10354 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10355 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10356 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10357 ffebad_finish ();
10358 }
10359 }
10360 else if (lbt != FFEINFO_basictypeCHARACTER)
10361 {
10362 if ((lbt != FFEINFO_basictypeANY)
10363 && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
10364 {
10365 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10366 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10367 ffebad_finish ();
10368 }
10369 }
10370 else if (rbt != FFEINFO_basictypeCHARACTER)
10371 {
10372 if ((rbt != FFEINFO_basictypeANY)
10373 && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
10374 {
10375 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10376 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10377 ffebad_finish ();
10378 }
10379 }
10380 else if ((lrk != 0) || (lszm == FFETARGET_charactersizeNONE))
10381 {
10382 if ((lkd != FFEINFO_kindANY)
10383 && ffebad_start (FFEBAD_CONCAT_ARG_KIND))
10384 {
10385 const char *what;
10386
10387 if (lrk != 0)
10388 what = "an array";
10389 else
10390 what = "of indeterminate length";
10391 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10392 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10393 ffebad_string (what);
10394 ffebad_finish ();
10395 }
10396 }
10397 else
10398 {
10399 if (ffebad_start (FFEBAD_CONCAT_ARG_KIND))
10400 {
10401 const char *what;
10402
10403 if (rrk != 0)
10404 what = "an array";
10405 else
10406 what = "of indeterminate length";
10407 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10408 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10409 ffebad_string (what);
10410 ffebad_finish ();
10411 }
10412 }
10413
10414 reduced = ffebld_new_any ();
10415 ffebld_set_info (reduced, ffeinfo_new_any ());
10416 return reduced;
10417 }
10418
10419 /* ffeexpr_reduced_eqop2_ -- Wrap up reduction of EQ and NE operators
10420
10421 reduced = ffeexpr_reduced_eqop2_(reduced,l,op,r);
10422
10423 Makes sure the left and right arguments for reduced have basictype of
10424 INTEGER, REAL, COMPLEX, or CHARACTER. Determine common basictype and
10425 size for reduction. If both left
10426 and right arguments have where of CONSTANT, assign where CONSTANT to
10427 reduced, else assign where FLEETING. Create CONVERT ops for args where
10428 needed. Convert typeless
10429 constants to the desired type/size explicitly.
10430
10431 If these requirements cannot be met, generate error message. */
10432
10433 static ffebld
10434 ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10435 ffeexprExpr_ r)
10436 {
10437 ffeinfo linfo, rinfo, ninfo;
10438 ffeinfoBasictype lbt, rbt, nbt;
10439 ffeinfoKindtype lkt, rkt, nkt;
10440 ffeinfoRank lrk, rrk;
10441 ffeinfoKind lkd, rkd;
10442 ffeinfoWhere lwh, rwh, nwh;
10443 ffetargetCharacterSize lsz, rsz;
10444
10445 linfo = ffebld_info (ffebld_left (reduced));
10446 lbt = ffeinfo_basictype (linfo);
10447 lkt = ffeinfo_kindtype (linfo);
10448 lrk = ffeinfo_rank (linfo);
10449 lkd = ffeinfo_kind (linfo);
10450 lwh = ffeinfo_where (linfo);
10451 lsz = ffebld_size_known (ffebld_left (reduced));
10452
10453 rinfo = ffebld_info (ffebld_right (reduced));
10454 rbt = ffeinfo_basictype (rinfo);
10455 rkt = ffeinfo_kindtype (rinfo);
10456 rrk = ffeinfo_rank (rinfo);
10457 rkd = ffeinfo_kind (rinfo);
10458 rwh = ffeinfo_where (rinfo);
10459 rsz = ffebld_size_known (ffebld_right (reduced));
10460
10461 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10462
10463 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10464 || (nbt == FFEINFO_basictypeCOMPLEX) || (nbt == FFEINFO_basictypeCHARACTER))
10465 && (lrk == 0) && (rrk == 0))
10466 {
10467 switch (lwh)
10468 {
10469 case FFEINFO_whereCONSTANT:
10470 switch (rwh)
10471 {
10472 case FFEINFO_whereCONSTANT:
10473 nwh = FFEINFO_whereCONSTANT;
10474 break;
10475
10476 case FFEINFO_whereIMMEDIATE:
10477 nwh = FFEINFO_whereIMMEDIATE;
10478 break;
10479
10480 default:
10481 nwh = FFEINFO_whereFLEETING;
10482 break;
10483 }
10484 break;
10485
10486 case FFEINFO_whereIMMEDIATE:
10487 switch (rwh)
10488 {
10489 case FFEINFO_whereCONSTANT:
10490 case FFEINFO_whereIMMEDIATE:
10491 nwh = FFEINFO_whereIMMEDIATE;
10492 break;
10493
10494 default:
10495 nwh = FFEINFO_whereFLEETING;
10496 break;
10497 }
10498 break;
10499
10500 default:
10501 nwh = FFEINFO_whereFLEETING;
10502 break;
10503 }
10504
10505 if ((lsz != FFETARGET_charactersizeNONE)
10506 && (rsz != FFETARGET_charactersizeNONE))
10507 lsz = rsz = (lsz > rsz) ? lsz : rsz;
10508
10509 ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
10510 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
10511 ffebld_set_info (reduced, ninfo);
10512 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10513 l->token, op->token, nbt, nkt, 0, lsz,
10514 FFEEXPR_contextLET));
10515 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10516 r->token, op->token, nbt, nkt, 0, rsz,
10517 FFEEXPR_contextLET));
10518 return reduced;
10519 }
10520
10521 if ((lbt == FFEINFO_basictypeLOGICAL)
10522 && (rbt == FFEINFO_basictypeLOGICAL))
10523 {
10524 /* xgettext:no-c-format */
10525 if (ffebad_start_msg ("Use .EQV./.NEQV. instead of .EQ./.NE. at %0 for LOGICAL operands at %1 and %2",
10526 FFEBAD_severityFATAL))
10527 {
10528 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10529 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10530 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10531 ffebad_finish ();
10532 }
10533 }
10534 else if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10535 && (lbt != FFEINFO_basictypeCOMPLEX) && (lbt != FFEINFO_basictypeCHARACTER))
10536 {
10537 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10538 && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
10539 {
10540 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10541 && ffebad_start (FFEBAD_EQOP_ARGS_TYPE))
10542 {
10543 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10544 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10545 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10546 ffebad_finish ();
10547 }
10548 }
10549 else
10550 {
10551 if ((lbt != FFEINFO_basictypeANY)
10552 && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
10553 {
10554 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10555 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10556 ffebad_finish ();
10557 }
10558 }
10559 }
10560 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10561 && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
10562 {
10563 if ((rbt != FFEINFO_basictypeANY)
10564 && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
10565 {
10566 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10567 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10568 ffebad_finish ();
10569 }
10570 }
10571 else if (lrk != 0)
10572 {
10573 if ((lkd != FFEINFO_kindANY)
10574 && ffebad_start (FFEBAD_EQOP_ARG_KIND))
10575 {
10576 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10577 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10578 ffebad_string ("an array");
10579 ffebad_finish ();
10580 }
10581 }
10582 else
10583 {
10584 if ((rkd != FFEINFO_kindANY)
10585 && ffebad_start (FFEBAD_EQOP_ARG_KIND))
10586 {
10587 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10588 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10589 ffebad_string ("an array");
10590 ffebad_finish ();
10591 }
10592 }
10593
10594 reduced = ffebld_new_any ();
10595 ffebld_set_info (reduced, ffeinfo_new_any ());
10596 return reduced;
10597 }
10598
10599 /* ffeexpr_reduced_math1_ -- Wrap up reduction of + - unary operators
10600
10601 reduced = ffeexpr_reduced_math1_(reduced,op,r);
10602
10603 Makes sure the argument for reduced has basictype of
10604 INTEGER, REAL, or COMPLEX. If the argument has where of CONSTANT,
10605 assign where CONSTANT to
10606 reduced, else assign where FLEETING.
10607
10608 If these requirements cannot be met, generate error message. */
10609
10610 static ffebld
10611 ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10612 {
10613 ffeinfo rinfo, ninfo;
10614 ffeinfoBasictype rbt;
10615 ffeinfoKindtype rkt;
10616 ffeinfoRank rrk;
10617 ffeinfoKind rkd;
10618 ffeinfoWhere rwh, nwh;
10619
10620 rinfo = ffebld_info (ffebld_left (reduced));
10621 rbt = ffeinfo_basictype (rinfo);
10622 rkt = ffeinfo_kindtype (rinfo);
10623 rrk = ffeinfo_rank (rinfo);
10624 rkd = ffeinfo_kind (rinfo);
10625 rwh = ffeinfo_where (rinfo);
10626
10627 if (((rbt == FFEINFO_basictypeINTEGER) || (rbt == FFEINFO_basictypeREAL)
10628 || (rbt == FFEINFO_basictypeCOMPLEX)) && (rrk == 0))
10629 {
10630 switch (rwh)
10631 {
10632 case FFEINFO_whereCONSTANT:
10633 nwh = FFEINFO_whereCONSTANT;
10634 break;
10635
10636 case FFEINFO_whereIMMEDIATE:
10637 nwh = FFEINFO_whereIMMEDIATE;
10638 break;
10639
10640 default:
10641 nwh = FFEINFO_whereFLEETING;
10642 break;
10643 }
10644
10645 ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
10646 FFETARGET_charactersizeNONE);
10647 ffebld_set_info (reduced, ninfo);
10648 return reduced;
10649 }
10650
10651 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10652 && (rbt != FFEINFO_basictypeCOMPLEX))
10653 {
10654 if ((rbt != FFEINFO_basictypeANY)
10655 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10656 {
10657 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10658 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10659 ffebad_finish ();
10660 }
10661 }
10662 else
10663 {
10664 if ((rkd != FFEINFO_kindANY)
10665 && ffebad_start (FFEBAD_MATH_ARG_KIND))
10666 {
10667 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10668 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10669 ffebad_string ("an array");
10670 ffebad_finish ();
10671 }
10672 }
10673
10674 reduced = ffebld_new_any ();
10675 ffebld_set_info (reduced, ffeinfo_new_any ());
10676 return reduced;
10677 }
10678
10679 /* ffeexpr_reduced_math2_ -- Wrap up reduction of + - * / operators
10680
10681 reduced = ffeexpr_reduced_math2_(reduced,l,op,r);
10682
10683 Makes sure the left and right arguments for reduced have basictype of
10684 INTEGER, REAL, or COMPLEX. Determine common basictype and
10685 size for reduction (flag expression for combined hollerith/typeless
10686 situations for later determination of effective basictype). If both left
10687 and right arguments have where of CONSTANT, assign where CONSTANT to
10688 reduced, else assign where FLEETING. Create CONVERT ops for args where
10689 needed. Convert typeless
10690 constants to the desired type/size explicitly.
10691
10692 If these requirements cannot be met, generate error message. */
10693
10694 static ffebld
10695 ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10696 ffeexprExpr_ r)
10697 {
10698 ffeinfo linfo, rinfo, ninfo;
10699 ffeinfoBasictype lbt, rbt, nbt;
10700 ffeinfoKindtype lkt, rkt, nkt;
10701 ffeinfoRank lrk, rrk;
10702 ffeinfoKind lkd, rkd;
10703 ffeinfoWhere lwh, rwh, nwh;
10704
10705 linfo = ffebld_info (ffebld_left (reduced));
10706 lbt = ffeinfo_basictype (linfo);
10707 lkt = ffeinfo_kindtype (linfo);
10708 lrk = ffeinfo_rank (linfo);
10709 lkd = ffeinfo_kind (linfo);
10710 lwh = ffeinfo_where (linfo);
10711
10712 rinfo = ffebld_info (ffebld_right (reduced));
10713 rbt = ffeinfo_basictype (rinfo);
10714 rkt = ffeinfo_kindtype (rinfo);
10715 rrk = ffeinfo_rank (rinfo);
10716 rkd = ffeinfo_kind (rinfo);
10717 rwh = ffeinfo_where (rinfo);
10718
10719 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10720
10721 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10722 || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
10723 {
10724 switch (lwh)
10725 {
10726 case FFEINFO_whereCONSTANT:
10727 switch (rwh)
10728 {
10729 case FFEINFO_whereCONSTANT:
10730 nwh = FFEINFO_whereCONSTANT;
10731 break;
10732
10733 case FFEINFO_whereIMMEDIATE:
10734 nwh = FFEINFO_whereIMMEDIATE;
10735 break;
10736
10737 default:
10738 nwh = FFEINFO_whereFLEETING;
10739 break;
10740 }
10741 break;
10742
10743 case FFEINFO_whereIMMEDIATE:
10744 switch (rwh)
10745 {
10746 case FFEINFO_whereCONSTANT:
10747 case FFEINFO_whereIMMEDIATE:
10748 nwh = FFEINFO_whereIMMEDIATE;
10749 break;
10750
10751 default:
10752 nwh = FFEINFO_whereFLEETING;
10753 break;
10754 }
10755 break;
10756
10757 default:
10758 nwh = FFEINFO_whereFLEETING;
10759 break;
10760 }
10761
10762 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10763 FFETARGET_charactersizeNONE);
10764 ffebld_set_info (reduced, ninfo);
10765 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10766 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10767 FFEEXPR_contextLET));
10768 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10769 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10770 FFEEXPR_contextLET));
10771 return reduced;
10772 }
10773
10774 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10775 && (lbt != FFEINFO_basictypeCOMPLEX))
10776 {
10777 if ((rbt != FFEINFO_basictypeINTEGER)
10778 && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
10779 {
10780 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10781 && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
10782 {
10783 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10784 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10785 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10786 ffebad_finish ();
10787 }
10788 }
10789 else
10790 {
10791 if ((lbt != FFEINFO_basictypeANY)
10792 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10793 {
10794 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10795 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10796 ffebad_finish ();
10797 }
10798 }
10799 }
10800 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10801 && (rbt != FFEINFO_basictypeCOMPLEX))
10802 {
10803 if ((rbt != FFEINFO_basictypeANY)
10804 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10805 {
10806 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10807 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10808 ffebad_finish ();
10809 }
10810 }
10811 else if (lrk != 0)
10812 {
10813 if ((lkd != FFEINFO_kindANY)
10814 && ffebad_start (FFEBAD_MATH_ARG_KIND))
10815 {
10816 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10817 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10818 ffebad_string ("an array");
10819 ffebad_finish ();
10820 }
10821 }
10822 else
10823 {
10824 if ((rkd != FFEINFO_kindANY)
10825 && ffebad_start (FFEBAD_MATH_ARG_KIND))
10826 {
10827 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10828 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10829 ffebad_string ("an array");
10830 ffebad_finish ();
10831 }
10832 }
10833
10834 reduced = ffebld_new_any ();
10835 ffebld_set_info (reduced, ffeinfo_new_any ());
10836 return reduced;
10837 }
10838
10839 /* ffeexpr_reduced_power_ -- Wrap up reduction of ** operator
10840
10841 reduced = ffeexpr_reduced_power_(reduced,l,op,r);
10842
10843 Makes sure the left and right arguments for reduced have basictype of
10844 INTEGER, REAL, or COMPLEX. Determine common basictype and
10845 size for reduction (flag expression for combined hollerith/typeless
10846 situations for later determination of effective basictype). If both left
10847 and right arguments have where of CONSTANT, assign where CONSTANT to
10848 reduced, else assign where FLEETING. Create CONVERT ops for args where
10849 needed. Note that real**int or complex**int
10850 comes out as int = real**int etc with no conversions.
10851
10852 If these requirements cannot be met, generate error message using the
10853 info in l, op, and r arguments and assign basictype, size, kind, and where
10854 of ANY. */
10855
10856 static ffebld
10857 ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10858 ffeexprExpr_ r)
10859 {
10860 ffeinfo linfo, rinfo, ninfo;
10861 ffeinfoBasictype lbt, rbt, nbt;
10862 ffeinfoKindtype lkt, rkt, nkt;
10863 ffeinfoRank lrk, rrk;
10864 ffeinfoKind lkd, rkd;
10865 ffeinfoWhere lwh, rwh, nwh;
10866
10867 linfo = ffebld_info (ffebld_left (reduced));
10868 lbt = ffeinfo_basictype (linfo);
10869 lkt = ffeinfo_kindtype (linfo);
10870 lrk = ffeinfo_rank (linfo);
10871 lkd = ffeinfo_kind (linfo);
10872 lwh = ffeinfo_where (linfo);
10873
10874 rinfo = ffebld_info (ffebld_right (reduced));
10875 rbt = ffeinfo_basictype (rinfo);
10876 rkt = ffeinfo_kindtype (rinfo);
10877 rrk = ffeinfo_rank (rinfo);
10878 rkd = ffeinfo_kind (rinfo);
10879 rwh = ffeinfo_where (rinfo);
10880
10881 if ((rbt == FFEINFO_basictypeINTEGER)
10882 && ((lbt == FFEINFO_basictypeREAL)
10883 || (lbt == FFEINFO_basictypeCOMPLEX)))
10884 {
10885 nbt = lbt;
10886 nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDEFAULT);
10887 if (nkt != FFEINFO_kindtypeREALDEFAULT)
10888 {
10889 nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDOUBLE);
10890 if (nkt != FFEINFO_kindtypeREALDOUBLE)
10891 nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */
10892 }
10893 if (rkt == FFEINFO_kindtypeINTEGER4)
10894 {
10895 /* xgettext:no-c-format */
10896 ffebad_start_msg ("Unsupported operand for ** at %1 -- converting to default INTEGER",
10897 FFEBAD_severityWARNING);
10898 ffebad_here (0, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10899 ffebad_finish ();
10900 }
10901 if (rkt != FFEINFO_kindtypeINTEGERDEFAULT)
10902 {
10903 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10904 r->token, op->token,
10905 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0,
10906 FFETARGET_charactersizeNONE,
10907 FFEEXPR_contextLET));
10908 rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10909 }
10910 }
10911 else
10912 {
10913 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10914
10915 #if 0 /* INTEGER4**INTEGER4 works now. */
10916 if ((nbt == FFEINFO_basictypeINTEGER)
10917 && (nkt != FFEINFO_kindtypeINTEGERDEFAULT))
10918 nkt = FFEINFO_kindtypeINTEGERDEFAULT; /* Highest kt we can power! */
10919 #endif
10920 if (((nbt == FFEINFO_basictypeREAL)
10921 || (nbt == FFEINFO_basictypeCOMPLEX))
10922 && (nkt != FFEINFO_kindtypeREALDEFAULT))
10923 {
10924 nkt = ffeinfo_kindtype_max (nbt, nkt, FFEINFO_kindtypeREALDOUBLE);
10925 if (nkt != FFEINFO_kindtypeREALDOUBLE)
10926 nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */
10927 }
10928 /* else Gonna turn into an error below. */
10929 }
10930
10931 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10932 || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
10933 {
10934 switch (lwh)
10935 {
10936 case FFEINFO_whereCONSTANT:
10937 switch (rwh)
10938 {
10939 case FFEINFO_whereCONSTANT:
10940 nwh = FFEINFO_whereCONSTANT;
10941 break;
10942
10943 case FFEINFO_whereIMMEDIATE:
10944 nwh = FFEINFO_whereIMMEDIATE;
10945 break;
10946
10947 default:
10948 nwh = FFEINFO_whereFLEETING;
10949 break;
10950 }
10951 break;
10952
10953 case FFEINFO_whereIMMEDIATE:
10954 switch (rwh)
10955 {
10956 case FFEINFO_whereCONSTANT:
10957 case FFEINFO_whereIMMEDIATE:
10958 nwh = FFEINFO_whereIMMEDIATE;
10959 break;
10960
10961 default:
10962 nwh = FFEINFO_whereFLEETING;
10963 break;
10964 }
10965 break;
10966
10967 default:
10968 nwh = FFEINFO_whereFLEETING;
10969 break;
10970 }
10971
10972 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10973 FFETARGET_charactersizeNONE);
10974 ffebld_set_info (reduced, ninfo);
10975 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10976 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10977 FFEEXPR_contextLET));
10978 if (rbt != FFEINFO_basictypeINTEGER)
10979 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10980 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10981 FFEEXPR_contextLET));
10982 return reduced;
10983 }
10984
10985 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10986 && (lbt != FFEINFO_basictypeCOMPLEX))
10987 {
10988 if ((rbt != FFEINFO_basictypeINTEGER)
10989 && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
10990 {
10991 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10992 && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
10993 {
10994 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10995 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10996 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10997 ffebad_finish ();
10998 }
10999 }
11000 else
11001 {
11002 if ((lbt != FFEINFO_basictypeANY)
11003 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
11004 {
11005 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11006 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11007 ffebad_finish ();
11008 }
11009 }
11010 }
11011 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
11012 && (rbt != FFEINFO_basictypeCOMPLEX))
11013 {
11014 if ((rbt != FFEINFO_basictypeANY)
11015 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
11016 {
11017 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11018 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11019 ffebad_finish ();
11020 }
11021 }
11022 else if (lrk != 0)
11023 {
11024 if ((lkd != FFEINFO_kindANY)
11025 && ffebad_start (FFEBAD_MATH_ARG_KIND))
11026 {
11027 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11028 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11029 ffebad_string ("an array");
11030 ffebad_finish ();
11031 }
11032 }
11033 else
11034 {
11035 if ((rkd != FFEINFO_kindANY)
11036 && ffebad_start (FFEBAD_MATH_ARG_KIND))
11037 {
11038 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11039 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11040 ffebad_string ("an array");
11041 ffebad_finish ();
11042 }
11043 }
11044
11045 reduced = ffebld_new_any ();
11046 ffebld_set_info (reduced, ffeinfo_new_any ());
11047 return reduced;
11048 }
11049
11050 /* ffeexpr_reduced_relop2_ -- Wrap up reduction of LT, LE, GE, and GT operators
11051
11052 reduced = ffeexpr_reduced_relop2_(reduced,l,op,r);
11053
11054 Makes sure the left and right arguments for reduced have basictype of
11055 INTEGER, REAL, or CHARACTER. Determine common basictype and
11056 size for reduction. If both left
11057 and right arguments have where of CONSTANT, assign where CONSTANT to
11058 reduced, else assign where FLEETING. Create CONVERT ops for args where
11059 needed. Convert typeless
11060 constants to the desired type/size explicitly.
11061
11062 If these requirements cannot be met, generate error message. */
11063
11064 static ffebld
11065 ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
11066 ffeexprExpr_ r)
11067 {
11068 ffeinfo linfo, rinfo, ninfo;
11069 ffeinfoBasictype lbt, rbt, nbt;
11070 ffeinfoKindtype lkt, rkt, nkt;
11071 ffeinfoRank lrk, rrk;
11072 ffeinfoKind lkd, rkd;
11073 ffeinfoWhere lwh, rwh, nwh;
11074 ffetargetCharacterSize lsz, rsz;
11075
11076 linfo = ffebld_info (ffebld_left (reduced));
11077 lbt = ffeinfo_basictype (linfo);
11078 lkt = ffeinfo_kindtype (linfo);
11079 lrk = ffeinfo_rank (linfo);
11080 lkd = ffeinfo_kind (linfo);
11081 lwh = ffeinfo_where (linfo);
11082 lsz = ffebld_size_known (ffebld_left (reduced));
11083
11084 rinfo = ffebld_info (ffebld_right (reduced));
11085 rbt = ffeinfo_basictype (rinfo);
11086 rkt = ffeinfo_kindtype (rinfo);
11087 rrk = ffeinfo_rank (rinfo);
11088 rkd = ffeinfo_kind (rinfo);
11089 rwh = ffeinfo_where (rinfo);
11090 rsz = ffebld_size_known (ffebld_right (reduced));
11091
11092 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
11093
11094 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
11095 || (nbt == FFEINFO_basictypeCHARACTER))
11096 && (lrk == 0) && (rrk == 0))
11097 {
11098 switch (lwh)
11099 {
11100 case FFEINFO_whereCONSTANT:
11101 switch (rwh)
11102 {
11103 case FFEINFO_whereCONSTANT:
11104 nwh = FFEINFO_whereCONSTANT;
11105 break;
11106
11107 case FFEINFO_whereIMMEDIATE:
11108 nwh = FFEINFO_whereIMMEDIATE;
11109 break;
11110
11111 default:
11112 nwh = FFEINFO_whereFLEETING;
11113 break;
11114 }
11115 break;
11116
11117 case FFEINFO_whereIMMEDIATE:
11118 switch (rwh)
11119 {
11120 case FFEINFO_whereCONSTANT:
11121 case FFEINFO_whereIMMEDIATE:
11122 nwh = FFEINFO_whereIMMEDIATE;
11123 break;
11124
11125 default:
11126 nwh = FFEINFO_whereFLEETING;
11127 break;
11128 }
11129 break;
11130
11131 default:
11132 nwh = FFEINFO_whereFLEETING;
11133 break;
11134 }
11135
11136 if ((lsz != FFETARGET_charactersizeNONE)
11137 && (rsz != FFETARGET_charactersizeNONE))
11138 lsz = rsz = (lsz > rsz) ? lsz : rsz;
11139
11140 ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
11141 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
11142 ffebld_set_info (reduced, ninfo);
11143 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11144 l->token, op->token, nbt, nkt, 0, lsz,
11145 FFEEXPR_contextLET));
11146 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11147 r->token, op->token, nbt, nkt, 0, rsz,
11148 FFEEXPR_contextLET));
11149 return reduced;
11150 }
11151
11152 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
11153 && (lbt != FFEINFO_basictypeCHARACTER))
11154 {
11155 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
11156 && (rbt != FFEINFO_basictypeCHARACTER))
11157 {
11158 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
11159 && ffebad_start (FFEBAD_RELOP_ARGS_TYPE))
11160 {
11161 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11162 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11163 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11164 ffebad_finish ();
11165 }
11166 }
11167 else
11168 {
11169 if ((lbt != FFEINFO_basictypeANY)
11170 && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
11171 {
11172 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11173 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11174 ffebad_finish ();
11175 }
11176 }
11177 }
11178 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
11179 && (rbt != FFEINFO_basictypeCHARACTER))
11180 {
11181 if ((rbt != FFEINFO_basictypeANY)
11182 && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
11183 {
11184 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11185 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11186 ffebad_finish ();
11187 }
11188 }
11189 else if (lrk != 0)
11190 {
11191 if ((lkd != FFEINFO_kindANY)
11192 && ffebad_start (FFEBAD_RELOP_ARG_KIND))
11193 {
11194 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11195 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11196 ffebad_string ("an array");
11197 ffebad_finish ();
11198 }
11199 }
11200 else
11201 {
11202 if ((rkd != FFEINFO_kindANY)
11203 && ffebad_start (FFEBAD_RELOP_ARG_KIND))
11204 {
11205 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11206 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11207 ffebad_string ("an array");
11208 ffebad_finish ();
11209 }
11210 }
11211
11212 reduced = ffebld_new_any ();
11213 ffebld_set_info (reduced, ffeinfo_new_any ());
11214 return reduced;
11215 }
11216
11217 /* ffeexpr_reduced_ugly1_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
11218
11219 reduced = ffeexpr_reduced_ugly1_(reduced,op,r);
11220
11221 Sigh. */
11222
11223 static ffebld
11224 ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
11225 {
11226 ffeinfo rinfo;
11227 ffeinfoBasictype rbt;
11228 ffeinfoKindtype rkt;
11229 ffeinfoRank rrk;
11230 ffeinfoKind rkd;
11231 ffeinfoWhere rwh;
11232
11233 rinfo = ffebld_info (ffebld_left (reduced));
11234 rbt = ffeinfo_basictype (rinfo);
11235 rkt = ffeinfo_kindtype (rinfo);
11236 rrk = ffeinfo_rank (rinfo);
11237 rkd = ffeinfo_kind (rinfo);
11238 rwh = ffeinfo_where (rinfo);
11239
11240 if ((rbt == FFEINFO_basictypeTYPELESS)
11241 || (rbt == FFEINFO_basictypeHOLLERITH))
11242 {
11243 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11244 r->token, op->token, FFEINFO_basictypeINTEGER,
11245 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11246 FFETARGET_charactersizeNONE,
11247 FFEEXPR_contextLET));
11248 rinfo = ffebld_info (ffebld_left (reduced));
11249 rbt = FFEINFO_basictypeINTEGER;
11250 rkt = FFEINFO_kindtypeINTEGERDEFAULT;
11251 rrk = 0;
11252 rkd = FFEINFO_kindENTITY;
11253 rwh = ffeinfo_where (rinfo);
11254 }
11255
11256 if (rbt == FFEINFO_basictypeLOGICAL)
11257 {
11258 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11259 r->token, op->token, FFEINFO_basictypeINTEGER,
11260 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11261 FFETARGET_charactersizeNONE,
11262 FFEEXPR_contextLET));
11263 }
11264
11265 return reduced;
11266 }
11267
11268 /* ffeexpr_reduced_ugly1log_ -- Deal with TYPELESS and HOLLERITH
11269
11270 reduced = ffeexpr_reduced_ugly1log_(reduced,op,r);
11271
11272 Sigh. */
11273
11274 static ffebld
11275 ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
11276 {
11277 ffeinfo rinfo;
11278 ffeinfoBasictype rbt;
11279 ffeinfoKindtype rkt;
11280 ffeinfoRank rrk;
11281 ffeinfoKind rkd;
11282 ffeinfoWhere rwh;
11283
11284 rinfo = ffebld_info (ffebld_left (reduced));
11285 rbt = ffeinfo_basictype (rinfo);
11286 rkt = ffeinfo_kindtype (rinfo);
11287 rrk = ffeinfo_rank (rinfo);
11288 rkd = ffeinfo_kind (rinfo);
11289 rwh = ffeinfo_where (rinfo);
11290
11291 if ((rbt == FFEINFO_basictypeTYPELESS)
11292 || (rbt == FFEINFO_basictypeHOLLERITH))
11293 {
11294 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11295 r->token, op->token, FFEINFO_basictypeLOGICAL, 0,
11296 FFEINFO_kindtypeLOGICALDEFAULT,
11297 FFETARGET_charactersizeNONE,
11298 FFEEXPR_contextLET));
11299 rinfo = ffebld_info (ffebld_left (reduced));
11300 rbt = FFEINFO_basictypeLOGICAL;
11301 rkt = FFEINFO_kindtypeLOGICALDEFAULT;
11302 rrk = 0;
11303 rkd = FFEINFO_kindENTITY;
11304 rwh = ffeinfo_where (rinfo);
11305 }
11306
11307 return reduced;
11308 }
11309
11310 /* ffeexpr_reduced_ugly2_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
11311
11312 reduced = ffeexpr_reduced_ugly2_(reduced,l,op,r);
11313
11314 Sigh. */
11315
11316 static ffebld
11317 ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
11318 ffeexprExpr_ r)
11319 {
11320 ffeinfo linfo, rinfo;
11321 ffeinfoBasictype lbt, rbt;
11322 ffeinfoKindtype lkt, rkt;
11323 ffeinfoRank lrk, rrk;
11324 ffeinfoKind lkd, rkd;
11325 ffeinfoWhere lwh, rwh;
11326
11327 linfo = ffebld_info (ffebld_left (reduced));
11328 lbt = ffeinfo_basictype (linfo);
11329 lkt = ffeinfo_kindtype (linfo);
11330 lrk = ffeinfo_rank (linfo);
11331 lkd = ffeinfo_kind (linfo);
11332 lwh = ffeinfo_where (linfo);
11333
11334 rinfo = ffebld_info (ffebld_right (reduced));
11335 rbt = ffeinfo_basictype (rinfo);
11336 rkt = ffeinfo_kindtype (rinfo);
11337 rrk = ffeinfo_rank (rinfo);
11338 rkd = ffeinfo_kind (rinfo);
11339 rwh = ffeinfo_where (rinfo);
11340
11341 if ((lbt == FFEINFO_basictypeTYPELESS)
11342 || (lbt == FFEINFO_basictypeHOLLERITH))
11343 {
11344 if ((rbt == FFEINFO_basictypeTYPELESS)
11345 || (rbt == FFEINFO_basictypeHOLLERITH))
11346 {
11347 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11348 l->token, op->token, FFEINFO_basictypeINTEGER,
11349 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11350 FFETARGET_charactersizeNONE,
11351 FFEEXPR_contextLET));
11352 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11353 r->token, op->token, FFEINFO_basictypeINTEGER, 0,
11354 FFEINFO_kindtypeINTEGERDEFAULT,
11355 FFETARGET_charactersizeNONE,
11356 FFEEXPR_contextLET));
11357 linfo = ffebld_info (ffebld_left (reduced));
11358 rinfo = ffebld_info (ffebld_right (reduced));
11359 lbt = rbt = FFEINFO_basictypeINTEGER;
11360 lkt = rkt = FFEINFO_kindtypeINTEGERDEFAULT;
11361 lrk = rrk = 0;
11362 lkd = rkd = FFEINFO_kindENTITY;
11363 lwh = ffeinfo_where (linfo);
11364 rwh = ffeinfo_where (rinfo);
11365 }
11366 else
11367 {
11368 ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
11369 l->token, ffebld_right (reduced), r->token,
11370 FFEEXPR_contextLET));
11371 linfo = ffebld_info (ffebld_left (reduced));
11372 lbt = ffeinfo_basictype (linfo);
11373 lkt = ffeinfo_kindtype (linfo);
11374 lrk = ffeinfo_rank (linfo);
11375 lkd = ffeinfo_kind (linfo);
11376 lwh = ffeinfo_where (linfo);
11377 }
11378 }
11379 else
11380 {
11381 if ((rbt == FFEINFO_basictypeTYPELESS)
11382 || (rbt == FFEINFO_basictypeHOLLERITH))
11383 {
11384 ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
11385 r->token, ffebld_left (reduced), l->token,
11386 FFEEXPR_contextLET));
11387 rinfo = ffebld_info (ffebld_right (reduced));
11388 rbt = ffeinfo_basictype (rinfo);
11389 rkt = ffeinfo_kindtype (rinfo);
11390 rrk = ffeinfo_rank (rinfo);
11391 rkd = ffeinfo_kind (rinfo);
11392 rwh = ffeinfo_where (rinfo);
11393 }
11394 /* else Leave it alone. */
11395 }
11396
11397 if (lbt == FFEINFO_basictypeLOGICAL)
11398 {
11399 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11400 l->token, op->token, FFEINFO_basictypeINTEGER,
11401 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11402 FFETARGET_charactersizeNONE,
11403 FFEEXPR_contextLET));
11404 }
11405
11406 if (rbt == FFEINFO_basictypeLOGICAL)
11407 {
11408 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11409 r->token, op->token, FFEINFO_basictypeINTEGER,
11410 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11411 FFETARGET_charactersizeNONE,
11412 FFEEXPR_contextLET));
11413 }
11414
11415 return reduced;
11416 }
11417
11418 /* ffeexpr_reduced_ugly2log_ -- Deal with TYPELESS and HOLLERITH
11419
11420 reduced = ffeexpr_reduced_ugly2log_(reduced,l,op,r);
11421
11422 Sigh. */
11423
11424 static ffebld
11425 ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
11426 ffeexprExpr_ r)
11427 {
11428 ffeinfo linfo, rinfo;
11429 ffeinfoBasictype lbt, rbt;
11430 ffeinfoKindtype lkt, rkt;
11431 ffeinfoRank lrk, rrk;
11432 ffeinfoKind lkd, rkd;
11433 ffeinfoWhere lwh, rwh;
11434
11435 linfo = ffebld_info (ffebld_left (reduced));
11436 lbt = ffeinfo_basictype (linfo);
11437 lkt = ffeinfo_kindtype (linfo);
11438 lrk = ffeinfo_rank (linfo);
11439 lkd = ffeinfo_kind (linfo);
11440 lwh = ffeinfo_where (linfo);
11441
11442 rinfo = ffebld_info (ffebld_right (reduced));
11443 rbt = ffeinfo_basictype (rinfo);
11444 rkt = ffeinfo_kindtype (rinfo);
11445 rrk = ffeinfo_rank (rinfo);
11446 rkd = ffeinfo_kind (rinfo);
11447 rwh = ffeinfo_where (rinfo);
11448
11449 if ((lbt == FFEINFO_basictypeTYPELESS)
11450 || (lbt == FFEINFO_basictypeHOLLERITH))
11451 {
11452 if ((rbt == FFEINFO_basictypeTYPELESS)
11453 || (rbt == FFEINFO_basictypeHOLLERITH))
11454 {
11455 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11456 l->token, op->token, FFEINFO_basictypeLOGICAL,
11457 FFEINFO_kindtypeLOGICALDEFAULT, 0,
11458 FFETARGET_charactersizeNONE,
11459 FFEEXPR_contextLET));
11460 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11461 r->token, op->token, FFEINFO_basictypeLOGICAL,
11462 FFEINFO_kindtypeLOGICALDEFAULT, 0,
11463 FFETARGET_charactersizeNONE,
11464 FFEEXPR_contextLET));
11465 linfo = ffebld_info (ffebld_left (reduced));
11466 rinfo = ffebld_info (ffebld_right (reduced));
11467 lbt = rbt = FFEINFO_basictypeLOGICAL;
11468 lkt = rkt = FFEINFO_kindtypeLOGICALDEFAULT;
11469 lrk = rrk = 0;
11470 lkd = rkd = FFEINFO_kindENTITY;
11471 lwh = ffeinfo_where (linfo);
11472 rwh = ffeinfo_where (rinfo);
11473 }
11474 else
11475 {
11476 ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
11477 l->token, ffebld_right (reduced), r->token,
11478 FFEEXPR_contextLET));
11479 linfo = ffebld_info (ffebld_left (reduced));
11480 lbt = ffeinfo_basictype (linfo);
11481 lkt = ffeinfo_kindtype (linfo);
11482 lrk = ffeinfo_rank (linfo);
11483 lkd = ffeinfo_kind (linfo);
11484 lwh = ffeinfo_where (linfo);
11485 }
11486 }
11487 else
11488 {
11489 if ((rbt == FFEINFO_basictypeTYPELESS)
11490 || (rbt == FFEINFO_basictypeHOLLERITH))
11491 {
11492 ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
11493 r->token, ffebld_left (reduced), l->token,
11494 FFEEXPR_contextLET));
11495 rinfo = ffebld_info (ffebld_right (reduced));
11496 rbt = ffeinfo_basictype (rinfo);
11497 rkt = ffeinfo_kindtype (rinfo);
11498 rrk = ffeinfo_rank (rinfo);
11499 rkd = ffeinfo_kind (rinfo);
11500 rwh = ffeinfo_where (rinfo);
11501 }
11502 /* else Leave it alone. */
11503 }
11504
11505 if (lbt == FFEINFO_basictypeLOGICAL)
11506 {
11507 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11508 l->token, op->token, FFEINFO_basictypeINTEGER,
11509 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11510 FFETARGET_charactersizeNONE,
11511 FFEEXPR_contextLET));
11512 }
11513
11514 if (rbt == FFEINFO_basictypeLOGICAL)
11515 {
11516 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11517 r->token, op->token, FFEINFO_basictypeINTEGER,
11518 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11519 FFETARGET_charactersizeNONE,
11520 FFEEXPR_contextLET));
11521 }
11522
11523 return reduced;
11524 }
11525
11526 /* Fumble through tokens until a nonmatching CLOSE_PAREN, EOS, or SEMICOLON
11527 is found.
11528
11529 The idea is to process the tokens as they would be done by normal
11530 expression processing, with the key things being telling the lexer
11531 when hollerith/character constants are about to happen, until the
11532 true closing token is found. */
11533
11534 static ffelexHandler
11535 ffeexpr_find_close_paren_ (ffelexToken t,
11536 ffelexHandler after)
11537 {
11538 ffeexpr_find_.after = after;
11539 ffeexpr_find_.level = 1;
11540 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11541 }
11542
11543 static ffelexHandler
11544 ffeexpr_nil_finished_ (ffelexToken t)
11545 {
11546 switch (ffelex_token_type (t))
11547 {
11548 case FFELEX_typeCLOSE_PAREN:
11549 if (--ffeexpr_find_.level == 0)
11550 return (ffelexHandler) ffeexpr_find_.after;
11551 return (ffelexHandler) ffeexpr_nil_binary_;
11552
11553 case FFELEX_typeCOMMA:
11554 case FFELEX_typeCOLON:
11555 case FFELEX_typeEQUALS:
11556 case FFELEX_typePOINTS:
11557 return (ffelexHandler) ffeexpr_nil_rhs_;
11558
11559 default:
11560 if (--ffeexpr_find_.level == 0)
11561 return (ffelexHandler) ffeexpr_find_.after (t);
11562 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11563 }
11564 }
11565
11566 static ffelexHandler
11567 ffeexpr_nil_rhs_ (ffelexToken t)
11568 {
11569 switch (ffelex_token_type (t))
11570 {
11571 case FFELEX_typeQUOTE:
11572 if (ffe_is_vxt ())
11573 return (ffelexHandler) ffeexpr_nil_quote_;
11574 ffelex_set_expecting_hollerith (-1, '\"',
11575 ffelex_token_where_line (t),
11576 ffelex_token_where_column (t));
11577 return (ffelexHandler) ffeexpr_nil_apostrophe_;
11578
11579 case FFELEX_typeAPOSTROPHE:
11580 ffelex_set_expecting_hollerith (-1, '\'',
11581 ffelex_token_where_line (t),
11582 ffelex_token_where_column (t));
11583 return (ffelexHandler) ffeexpr_nil_apostrophe_;
11584
11585 case FFELEX_typePERCENT:
11586 return (ffelexHandler) ffeexpr_nil_percent_;
11587
11588 case FFELEX_typeOPEN_PAREN:
11589 ++ffeexpr_find_.level;
11590 return (ffelexHandler) ffeexpr_nil_rhs_;
11591
11592 case FFELEX_typePLUS:
11593 case FFELEX_typeMINUS:
11594 return (ffelexHandler) ffeexpr_nil_rhs_;
11595
11596 case FFELEX_typePERIOD:
11597 return (ffelexHandler) ffeexpr_nil_period_;
11598
11599 case FFELEX_typeNUMBER:
11600 ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
11601 if (ffeexpr_hollerith_count_ > 0)
11602 ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
11603 '\0',
11604 ffelex_token_where_line (t),
11605 ffelex_token_where_column (t));
11606 return (ffelexHandler) ffeexpr_nil_number_;
11607
11608 case FFELEX_typeNAME:
11609 case FFELEX_typeNAMES:
11610 return (ffelexHandler) ffeexpr_nil_name_rhs_;
11611
11612 case FFELEX_typeASTERISK:
11613 case FFELEX_typeSLASH:
11614 case FFELEX_typePOWER:
11615 case FFELEX_typeCONCAT:
11616 case FFELEX_typeREL_EQ:
11617 case FFELEX_typeREL_NE:
11618 case FFELEX_typeREL_LE:
11619 case FFELEX_typeREL_GE:
11620 return (ffelexHandler) ffeexpr_nil_rhs_;
11621
11622 default:
11623 return (ffelexHandler) ffeexpr_nil_finished_ (t);
11624 }
11625 }
11626
11627 static ffelexHandler
11628 ffeexpr_nil_period_ (ffelexToken t)
11629 {
11630 switch (ffelex_token_type (t))
11631 {
11632 case FFELEX_typeNAME:
11633 case FFELEX_typeNAMES:
11634 ffeexpr_current_dotdot_ = ffestr_other (t);
11635 switch (ffeexpr_current_dotdot_)
11636 {
11637 case FFESTR_otherNone:
11638 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11639
11640 case FFESTR_otherTRUE:
11641 case FFESTR_otherFALSE:
11642 case FFESTR_otherNOT:
11643 return (ffelexHandler) ffeexpr_nil_end_period_;
11644
11645 default:
11646 return (ffelexHandler) ffeexpr_nil_swallow_period_;
11647 }
11648 break; /* Nothing really reaches here. */
11649
11650 case FFELEX_typeNUMBER:
11651 return (ffelexHandler) ffeexpr_nil_real_;
11652
11653 default:
11654 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11655 }
11656 }
11657
11658 static ffelexHandler
11659 ffeexpr_nil_end_period_ (ffelexToken t)
11660 {
11661 switch (ffeexpr_current_dotdot_)
11662 {
11663 case FFESTR_otherNOT:
11664 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11665 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11666 return (ffelexHandler) ffeexpr_nil_rhs_;
11667
11668 case FFESTR_otherTRUE:
11669 case FFESTR_otherFALSE:
11670 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11671 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11672 return (ffelexHandler) ffeexpr_nil_binary_;
11673
11674 default:
11675 assert ("Bad [nil] unary dotdot in ffeexpr_current_dotdot_" == NULL);
11676 exit (0);
11677 return NULL;
11678 }
11679 }
11680
11681 static ffelexHandler
11682 ffeexpr_nil_swallow_period_ (ffelexToken t)
11683 {
11684 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11685 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11686 return (ffelexHandler) ffeexpr_nil_rhs_;
11687 }
11688
11689 static ffelexHandler
11690 ffeexpr_nil_real_ (ffelexToken t)
11691 {
11692 char d;
11693 const char *p;
11694
11695 if (((ffelex_token_type (t) != FFELEX_typeNAME)
11696 && (ffelex_token_type (t) != FFELEX_typeNAMES))
11697 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11698 'D', 'd')
11699 || ffesrc_char_match_init (d, 'E', 'e')
11700 || ffesrc_char_match_init (d, 'Q', 'q')))
11701 && ffeexpr_isdigits_ (++p)))
11702 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11703
11704 if (*p == '\0')
11705 return (ffelexHandler) ffeexpr_nil_real_exponent_;
11706 return (ffelexHandler) ffeexpr_nil_binary_;
11707 }
11708
11709 static ffelexHandler
11710 ffeexpr_nil_real_exponent_ (ffelexToken t)
11711 {
11712 if ((ffelex_token_type (t) != FFELEX_typePLUS)
11713 && (ffelex_token_type (t) != FFELEX_typeMINUS))
11714 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11715
11716 return (ffelexHandler) ffeexpr_nil_real_exp_sign_;
11717 }
11718
11719 static ffelexHandler
11720 ffeexpr_nil_real_exp_sign_ (ffelexToken t)
11721 {
11722 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11723 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11724 return (ffelexHandler) ffeexpr_nil_binary_;
11725 }
11726
11727 static ffelexHandler
11728 ffeexpr_nil_number_ (ffelexToken t)
11729 {
11730 char d;
11731 const char *p;
11732
11733 if (ffeexpr_hollerith_count_ > 0)
11734 ffelex_set_expecting_hollerith (0, '\0',
11735 ffewhere_line_unknown (),
11736 ffewhere_column_unknown ());
11737
11738 switch (ffelex_token_type (t))
11739 {
11740 case FFELEX_typeNAME:
11741 case FFELEX_typeNAMES:
11742 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11743 'D', 'd')
11744 || ffesrc_char_match_init (d, 'E', 'e')
11745 || ffesrc_char_match_init (d, 'Q', 'q'))
11746 && ffeexpr_isdigits_ (++p))
11747 {
11748 if (*p == '\0')
11749 {
11750 ffeexpr_find_.t = ffelex_token_use (t);
11751 return (ffelexHandler) ffeexpr_nil_number_exponent_;
11752 }
11753 return (ffelexHandler) ffeexpr_nil_binary_;
11754 }
11755 break;
11756
11757 case FFELEX_typePERIOD:
11758 ffeexpr_find_.t = ffelex_token_use (t);
11759 return (ffelexHandler) ffeexpr_nil_number_period_;
11760
11761 case FFELEX_typeHOLLERITH:
11762 return (ffelexHandler) ffeexpr_nil_binary_;
11763
11764 default:
11765 break;
11766 }
11767 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11768 }
11769
11770 /* Expects ffeexpr_find_.t. */
11771
11772 static ffelexHandler
11773 ffeexpr_nil_number_exponent_ (ffelexToken t)
11774 {
11775 ffelexHandler nexthandler;
11776
11777 if ((ffelex_token_type (t) != FFELEX_typePLUS)
11778 && (ffelex_token_type (t) != FFELEX_typeMINUS))
11779 {
11780 nexthandler
11781 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
11782 ffelex_token_kill (ffeexpr_find_.t);
11783 return (ffelexHandler) (*nexthandler) (t);
11784 }
11785
11786 ffelex_token_kill (ffeexpr_find_.t);
11787 return (ffelexHandler) ffeexpr_nil_number_exp_sign_;
11788 }
11789
11790 static ffelexHandler
11791 ffeexpr_nil_number_exp_sign_ (ffelexToken t)
11792 {
11793 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11794 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11795
11796 return (ffelexHandler) ffeexpr_nil_binary_;
11797 }
11798
11799 /* Expects ffeexpr_find_.t. */
11800
11801 static ffelexHandler
11802 ffeexpr_nil_number_period_ (ffelexToken t)
11803 {
11804 ffelexHandler nexthandler;
11805 char d;
11806 const char *p;
11807
11808 switch (ffelex_token_type (t))
11809 {
11810 case FFELEX_typeNAME:
11811 case FFELEX_typeNAMES:
11812 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11813 'D', 'd')
11814 || ffesrc_char_match_init (d, 'E', 'e')
11815 || ffesrc_char_match_init (d, 'Q', 'q'))
11816 && ffeexpr_isdigits_ (++p))
11817 {
11818 if (*p == '\0')
11819 return (ffelexHandler) ffeexpr_nil_number_per_exp_;
11820 ffelex_token_kill (ffeexpr_find_.t);
11821 return (ffelexHandler) ffeexpr_nil_binary_;
11822 }
11823 nexthandler
11824 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
11825 ffelex_token_kill (ffeexpr_find_.t);
11826 return (ffelexHandler) (*nexthandler) (t);
11827
11828 case FFELEX_typeNUMBER:
11829 ffelex_token_kill (ffeexpr_find_.t);
11830 return (ffelexHandler) ffeexpr_nil_number_real_;
11831
11832 default:
11833 break;
11834 }
11835 ffelex_token_kill (ffeexpr_find_.t);
11836 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11837 }
11838
11839 /* Expects ffeexpr_find_.t. */
11840
11841 static ffelexHandler
11842 ffeexpr_nil_number_per_exp_ (ffelexToken t)
11843 {
11844 if ((ffelex_token_type (t) != FFELEX_typePLUS)
11845 && (ffelex_token_type (t) != FFELEX_typeMINUS))
11846 {
11847 ffelexHandler nexthandler;
11848
11849 nexthandler
11850 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
11851 ffelex_token_kill (ffeexpr_find_.t);
11852 return (ffelexHandler) (*nexthandler) (t);
11853 }
11854
11855 ffelex_token_kill (ffeexpr_find_.t);
11856 return (ffelexHandler) ffeexpr_nil_num_per_exp_sign_;
11857 }
11858
11859 static ffelexHandler
11860 ffeexpr_nil_number_real_ (ffelexToken t)
11861 {
11862 char d;
11863 const char *p;
11864
11865 if (((ffelex_token_type (t) != FFELEX_typeNAME)
11866 && (ffelex_token_type (t) != FFELEX_typeNAMES))
11867 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11868 'D', 'd')
11869 || ffesrc_char_match_init (d, 'E', 'e')
11870 || ffesrc_char_match_init (d, 'Q', 'q')))
11871 && ffeexpr_isdigits_ (++p)))
11872 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11873
11874 if (*p == '\0')
11875 return (ffelexHandler) ffeexpr_nil_number_real_exp_;
11876
11877 return (ffelexHandler) ffeexpr_nil_binary_;
11878 }
11879
11880 static ffelexHandler
11881 ffeexpr_nil_num_per_exp_sign_ (ffelexToken t)
11882 {
11883 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11884 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11885 return (ffelexHandler) ffeexpr_nil_binary_;
11886 }
11887
11888 static ffelexHandler
11889 ffeexpr_nil_number_real_exp_ (ffelexToken t)
11890 {
11891 if ((ffelex_token_type (t) != FFELEX_typePLUS)
11892 && (ffelex_token_type (t) != FFELEX_typeMINUS))
11893 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11894 return (ffelexHandler) ffeexpr_nil_num_real_exp_sn_;
11895 }
11896
11897 static ffelexHandler
11898 ffeexpr_nil_num_real_exp_sn_ (ffelexToken t)
11899 {
11900 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11901 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11902 return (ffelexHandler) ffeexpr_nil_binary_;
11903 }
11904
11905 static ffelexHandler
11906 ffeexpr_nil_binary_ (ffelexToken t)
11907 {
11908 switch (ffelex_token_type (t))
11909 {
11910 case FFELEX_typePLUS:
11911 case FFELEX_typeMINUS:
11912 case FFELEX_typeASTERISK:
11913 case FFELEX_typeSLASH:
11914 case FFELEX_typePOWER:
11915 case FFELEX_typeCONCAT:
11916 case FFELEX_typeOPEN_ANGLE:
11917 case FFELEX_typeCLOSE_ANGLE:
11918 case FFELEX_typeREL_EQ:
11919 case FFELEX_typeREL_NE:
11920 case FFELEX_typeREL_GE:
11921 case FFELEX_typeREL_LE:
11922 return (ffelexHandler) ffeexpr_nil_rhs_;
11923
11924 case FFELEX_typePERIOD:
11925 return (ffelexHandler) ffeexpr_nil_binary_period_;
11926
11927 default:
11928 return (ffelexHandler) ffeexpr_nil_finished_ (t);
11929 }
11930 }
11931
11932 static ffelexHandler
11933 ffeexpr_nil_binary_period_ (ffelexToken t)
11934 {
11935 switch (ffelex_token_type (t))
11936 {
11937 case FFELEX_typeNAME:
11938 case FFELEX_typeNAMES:
11939 ffeexpr_current_dotdot_ = ffestr_other (t);
11940 switch (ffeexpr_current_dotdot_)
11941 {
11942 case FFESTR_otherTRUE:
11943 case FFESTR_otherFALSE:
11944 case FFESTR_otherNOT:
11945 return (ffelexHandler) ffeexpr_nil_binary_sw_per_;
11946
11947 default:
11948 return (ffelexHandler) ffeexpr_nil_binary_end_per_;
11949 }
11950 break; /* Nothing really reaches here. */
11951
11952 default:
11953 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11954 }
11955 }
11956
11957 static ffelexHandler
11958 ffeexpr_nil_binary_end_per_ (ffelexToken t)
11959 {
11960 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11961 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11962 return (ffelexHandler) ffeexpr_nil_rhs_;
11963 }
11964
11965 static ffelexHandler
11966 ffeexpr_nil_binary_sw_per_ (ffelexToken t)
11967 {
11968 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11969 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11970 return (ffelexHandler) ffeexpr_nil_binary_;
11971 }
11972
11973 static ffelexHandler
11974 ffeexpr_nil_quote_ (ffelexToken t)
11975 {
11976 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11977 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11978 return (ffelexHandler) ffeexpr_nil_binary_;
11979 }
11980
11981 static ffelexHandler
11982 ffeexpr_nil_apostrophe_ (ffelexToken t)
11983 {
11984 assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
11985 return (ffelexHandler) ffeexpr_nil_apos_char_;
11986 }
11987
11988 static ffelexHandler
11989 ffeexpr_nil_apos_char_ (ffelexToken t)
11990 {
11991 char c;
11992
11993 if ((ffelex_token_type (t) == FFELEX_typeNAME)
11994 || (ffelex_token_type (t) == FFELEX_typeNAMES))
11995 {
11996 if ((ffelex_token_length (t) == 1)
11997 && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]),
11998 'B', 'b')
11999 || ffesrc_char_match_init (c, 'O', 'o')
12000 || ffesrc_char_match_init (c, 'X', 'x')
12001 || ffesrc_char_match_init (c, 'Z', 'z')))
12002 return (ffelexHandler) ffeexpr_nil_binary_;
12003 }
12004 if ((ffelex_token_type (t) == FFELEX_typeNAME)
12005 || (ffelex_token_type (t) == FFELEX_typeNAMES))
12006 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
12007 return (ffelexHandler) ffeexpr_nil_substrp_ (t);
12008 }
12009
12010 static ffelexHandler
12011 ffeexpr_nil_name_rhs_ (ffelexToken t)
12012 {
12013 switch (ffelex_token_type (t))
12014 {
12015 case FFELEX_typeQUOTE:
12016 case FFELEX_typeAPOSTROPHE:
12017 ffelex_set_hexnum (TRUE);
12018 return (ffelexHandler) ffeexpr_nil_name_apos_;
12019
12020 case FFELEX_typeOPEN_PAREN:
12021 ++ffeexpr_find_.level;
12022 return (ffelexHandler) ffeexpr_nil_rhs_;
12023
12024 default:
12025 return (ffelexHandler) ffeexpr_nil_binary_ (t);
12026 }
12027 }
12028
12029 static ffelexHandler
12030 ffeexpr_nil_name_apos_ (ffelexToken t)
12031 {
12032 if (ffelex_token_type (t) == FFELEX_typeNAME)
12033 return (ffelexHandler) ffeexpr_nil_name_apos_name_;
12034 return (ffelexHandler) ffeexpr_nil_binary_ (t);
12035 }
12036
12037 static ffelexHandler
12038 ffeexpr_nil_name_apos_name_ (ffelexToken t)
12039 {
12040 switch (ffelex_token_type (t))
12041 {
12042 case FFELEX_typeAPOSTROPHE:
12043 case FFELEX_typeQUOTE:
12044 return (ffelexHandler) ffeexpr_nil_finished_;
12045
12046 default:
12047 return (ffelexHandler) ffeexpr_nil_finished_ (t);
12048 }
12049 }
12050
12051 static ffelexHandler
12052 ffeexpr_nil_percent_ (ffelexToken t)
12053 {
12054 switch (ffelex_token_type (t))
12055 {
12056 case FFELEX_typeNAME:
12057 case FFELEX_typeNAMES:
12058 ffeexpr_stack_->percent = ffeexpr_percent_ (t);
12059 ffeexpr_find_.t = ffelex_token_use (t);
12060 return (ffelexHandler) ffeexpr_nil_percent_name_;
12061
12062 default:
12063 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
12064 }
12065 }
12066
12067 /* Expects ffeexpr_find_.t. */
12068
12069 static ffelexHandler
12070 ffeexpr_nil_percent_name_ (ffelexToken t)
12071 {
12072 ffelexHandler nexthandler;
12073
12074 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
12075 {
12076 nexthandler
12077 = (ffelexHandler) ffeexpr_nil_rhs_ (ffeexpr_find_.t);
12078 ffelex_token_kill (ffeexpr_find_.t);
12079 return (ffelexHandler) (*nexthandler) (t);
12080 }
12081
12082 ffelex_token_kill (ffeexpr_find_.t);
12083 ++ffeexpr_find_.level;
12084 return (ffelexHandler) ffeexpr_nil_rhs_;
12085 }
12086
12087 static ffelexHandler
12088 ffeexpr_nil_substrp_ (ffelexToken t)
12089 {
12090 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
12091 return (ffelexHandler) ffeexpr_nil_binary_ (t);
12092
12093 ++ffeexpr_find_.level;
12094 return (ffelexHandler) ffeexpr_nil_rhs_;
12095 }
12096
12097 /* ffeexpr_finished_ -- Reduce expression stack to one expr, finish
12098
12099 ffelexToken t;
12100 return ffeexpr_finished_(t);
12101
12102 Reduces expression stack to one (or zero) elements by repeatedly reducing
12103 the top operator on the stack (or, if the top element on the stack is
12104 itself an operator, issuing an error message and discarding it). Calls
12105 finishing routine with the expression, returning the ffelexHandler it
12106 returns to the caller. */
12107
12108 static ffelexHandler
12109 ffeexpr_finished_ (ffelexToken t)
12110 {
12111 ffeexprExpr_ operand; /* This is B in -B or A+B. */
12112 ffebld expr;
12113 ffeexprCallback callback;
12114 ffeexprStack_ s;
12115 ffebldConstant constnode; /* For detecting magical number. */
12116 ffelexToken ft; /* Temporary copy of first token in
12117 expression. */
12118 ffelexHandler next;
12119 ffeinfo info;
12120 bool error = FALSE;
12121
12122 while (((operand = ffeexpr_stack_->exprstack) != NULL)
12123 && ((operand->previous != NULL) || (operand->type != FFEEXPR_exprtypeOPERAND_)))
12124 {
12125 if (operand->type == FFEEXPR_exprtypeOPERAND_)
12126 ffeexpr_reduce_ ();
12127 else
12128 {
12129 if (ffest_ffebad_start (FFEBAD_MISSING_OPERAND_FOR_OPERATOR))
12130 {
12131 ffebad_here (0, ffelex_token_where_line (t),
12132 ffelex_token_where_column (t));
12133 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
12134 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
12135 ffebad_finish ();
12136 }
12137 ffeexpr_stack_->exprstack = operand->previous; /* Pop the useless
12138 operator. */
12139 ffeexpr_expr_kill_ (operand);
12140 }
12141 }
12142
12143 assert ((operand == NULL) || (operand->previous == NULL));
12144
12145 ffebld_pool_pop ();
12146 if (operand == NULL)
12147 expr = NULL;
12148 else
12149 {
12150 expr = operand->u.operand;
12151 info = ffebld_info (expr);
12152 if ((ffebld_op (expr) == FFEBLD_opCONTER)
12153 && (ffebld_conter_orig (expr) == NULL)
12154 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
12155 {
12156 ffetarget_integer_bad_magical (operand->token);
12157 }
12158 ffeexpr_expr_kill_ (operand);
12159 ffeexpr_stack_->exprstack = NULL;
12160 }
12161
12162 ft = ffeexpr_stack_->first_token;
12163
12164 again: /* :::::::::::::::::::: */
12165 switch (ffeexpr_stack_->context)
12166 {
12167 case FFEEXPR_contextLET:
12168 case FFEEXPR_contextSFUNCDEF:
12169 error = (expr == NULL)
12170 || (ffeinfo_rank (info) != 0);
12171 break;
12172
12173 case FFEEXPR_contextPAREN_:
12174 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12175 break;
12176 switch (ffeinfo_basictype (info))
12177 {
12178 case FFEINFO_basictypeHOLLERITH:
12179 case FFEINFO_basictypeTYPELESS:
12180 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12181 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12182 FFEEXPR_contextLET);
12183 break;
12184
12185 default:
12186 break;
12187 }
12188 break;
12189
12190 case FFEEXPR_contextPARENFILENUM_:
12191 if (ffelex_token_type (t) != FFELEX_typeCOMMA)
12192 ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
12193 else
12194 ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
12195 goto again; /* :::::::::::::::::::: */
12196
12197 case FFEEXPR_contextPARENFILEUNIT_:
12198 if (ffelex_token_type (t) != FFELEX_typeCOMMA)
12199 ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
12200 else
12201 ffeexpr_stack_->context = FFEEXPR_contextFILEUNIT;
12202 goto again; /* :::::::::::::::::::: */
12203
12204 case FFEEXPR_contextACTUALARGEXPR_:
12205 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
12206 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12207 : ffeinfo_basictype (info))
12208 {
12209 case FFEINFO_basictypeHOLLERITH:
12210 case FFEINFO_basictypeTYPELESS:
12211 if (!ffe_is_ugly_args ()
12212 && ffebad_start (FFEBAD_ACTUALARG))
12213 {
12214 ffebad_here (0, ffelex_token_where_line (ft),
12215 ffelex_token_where_column (ft));
12216 ffebad_finish ();
12217 }
12218 break;
12219
12220 default:
12221 break;
12222 }
12223 error = (expr != NULL) && (ffeinfo_rank (info) != 0);
12224 break;
12225
12226 case FFEEXPR_contextACTUALARG_:
12227 case FFEEXPR_contextSFUNCDEFACTUALARG_:
12228 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12229 : ffeinfo_basictype (info))
12230 {
12231 case FFEINFO_basictypeHOLLERITH:
12232 case FFEINFO_basictypeTYPELESS:
12233 #if 0 /* Should never get here. */
12234 expr = ffeexpr_convert (expr, ft, ft,
12235 FFEINFO_basictypeINTEGER,
12236 FFEINFO_kindtypeINTEGERDEFAULT,
12237 0,
12238 FFETARGET_charactersizeNONE,
12239 FFEEXPR_contextLET);
12240 #else
12241 assert ("why hollerith/typeless in actualarg_?" == NULL);
12242 #endif
12243 break;
12244
12245 default:
12246 break;
12247 }
12248 switch ((expr == NULL) ? FFEBLD_opANY : ffebld_op (expr))
12249 {
12250 case FFEBLD_opSYMTER:
12251 case FFEBLD_opPERCENT_LOC:
12252 case FFEBLD_opPERCENT_VAL:
12253 case FFEBLD_opPERCENT_REF:
12254 case FFEBLD_opPERCENT_DESCR:
12255 error = FALSE;
12256 break;
12257
12258 default:
12259 error = (expr != NULL) && (ffeinfo_rank (info) != 0);
12260 break;
12261 }
12262 {
12263 ffesymbol s;
12264 ffeinfoWhere where;
12265 ffeinfoKind kind;
12266
12267 if (!error
12268 && (expr != NULL)
12269 && (ffebld_op (expr) == FFEBLD_opSYMTER)
12270 && ((s = ffebld_symter (expr)), (where = ffesymbol_where (s)),
12271 (where == FFEINFO_whereINTRINSIC)
12272 || (where == FFEINFO_whereGLOBAL)
12273 || ((where == FFEINFO_whereDUMMY)
12274 && ((kind = ffesymbol_kind (s)),
12275 (kind == FFEINFO_kindFUNCTION)
12276 || (kind == FFEINFO_kindSUBROUTINE))))
12277 && !ffesymbol_explicitwhere (s))
12278 {
12279 ffebad_start (where == FFEINFO_whereINTRINSIC
12280 ? FFEBAD_NEED_INTRINSIC : FFEBAD_NEED_EXTERNAL);
12281 ffebad_here (0, ffelex_token_where_line (ft),
12282 ffelex_token_where_column (ft));
12283 ffebad_string (ffesymbol_text (s));
12284 ffebad_finish ();
12285 ffesymbol_signal_change (s);
12286 ffesymbol_set_explicitwhere (s, TRUE);
12287 ffesymbol_signal_unreported (s);
12288 }
12289 }
12290 break;
12291
12292 case FFEEXPR_contextINDEX_:
12293 case FFEEXPR_contextSFUNCDEFINDEX_:
12294 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12295 break;
12296 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12297 : ffeinfo_basictype (info))
12298 {
12299 case FFEINFO_basictypeNONE:
12300 error = FALSE;
12301 break;
12302
12303 case FFEINFO_basictypeLOGICAL:
12304 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12305 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12306 FFEEXPR_contextLET);
12307 /* Fall through. */
12308 case FFEINFO_basictypeREAL:
12309 case FFEINFO_basictypeCOMPLEX:
12310 if (ffe_is_pedantic ())
12311 {
12312 error = TRUE;
12313 break;
12314 }
12315 /* Fall through. */
12316 case FFEINFO_basictypeHOLLERITH:
12317 case FFEINFO_basictypeTYPELESS:
12318 error = FALSE;
12319 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12320 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12321 FFEEXPR_contextLET);
12322 break;
12323
12324 case FFEINFO_basictypeINTEGER:
12325 /* Specifically, allow INTEGER(KIND=2), aka INTEGER*8, through
12326 unmolested. Leave it to downstream to handle kinds. */
12327 break;
12328
12329 default:
12330 error = TRUE;
12331 break;
12332 }
12333 break; /* expr==NULL ok for substring; element case
12334 caught by callback. */
12335
12336 case FFEEXPR_contextRETURN:
12337 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12338 break;
12339 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12340 : ffeinfo_basictype (info))
12341 {
12342 case FFEINFO_basictypeNONE:
12343 error = FALSE;
12344 break;
12345
12346 case FFEINFO_basictypeLOGICAL:
12347 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12348 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12349 FFEEXPR_contextLET);
12350 /* Fall through. */
12351 case FFEINFO_basictypeREAL:
12352 case FFEINFO_basictypeCOMPLEX:
12353 if (ffe_is_pedantic ())
12354 {
12355 error = TRUE;
12356 break;
12357 }
12358 /* Fall through. */
12359 case FFEINFO_basictypeINTEGER:
12360 case FFEINFO_basictypeHOLLERITH:
12361 case FFEINFO_basictypeTYPELESS:
12362 error = FALSE;
12363 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12364 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12365 FFEEXPR_contextLET);
12366 break;
12367
12368 default:
12369 error = TRUE;
12370 break;
12371 }
12372 break;
12373
12374 case FFEEXPR_contextDO:
12375 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12376 break;
12377 switch (ffeinfo_basictype (info))
12378 {
12379 case FFEINFO_basictypeLOGICAL:
12380 error = !ffe_is_ugly_logint ();
12381 if (!ffeexpr_stack_->is_rhs)
12382 break; /* Don't convert lhs variable. */
12383 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12384 ffeinfo_kindtype (ffebld_info (expr)), 0,
12385 FFETARGET_charactersizeNONE,
12386 FFEEXPR_contextLET);
12387 break;
12388
12389 case FFEINFO_basictypeHOLLERITH:
12390 case FFEINFO_basictypeTYPELESS:
12391 if (!ffeexpr_stack_->is_rhs)
12392 {
12393 error = TRUE;
12394 break; /* Don't convert lhs variable. */
12395 }
12396 break;
12397
12398 case FFEINFO_basictypeINTEGER:
12399 case FFEINFO_basictypeREAL:
12400 break;
12401
12402 default:
12403 error = TRUE;
12404 break;
12405 }
12406 if (!ffeexpr_stack_->is_rhs
12407 && (ffebld_op (expr) != FFEBLD_opSYMTER))
12408 error = TRUE;
12409 break;
12410
12411 case FFEEXPR_contextDOWHILE:
12412 case FFEEXPR_contextIF:
12413 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12414 break;
12415 switch (ffeinfo_basictype (info))
12416 {
12417 case FFEINFO_basictypeINTEGER:
12418 error = FALSE;
12419 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12420 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12421 FFEEXPR_contextLET);
12422 /* Fall through. */
12423 case FFEINFO_basictypeLOGICAL:
12424 case FFEINFO_basictypeHOLLERITH:
12425 case FFEINFO_basictypeTYPELESS:
12426 error = FALSE;
12427 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12428 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12429 FFEEXPR_contextLET);
12430 break;
12431
12432 default:
12433 error = TRUE;
12434 break;
12435 }
12436 break;
12437
12438 case FFEEXPR_contextASSIGN:
12439 case FFEEXPR_contextAGOTO:
12440 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12441 : ffeinfo_basictype (info))
12442 {
12443 case FFEINFO_basictypeINTEGER:
12444 error = (ffeinfo_kindtype (info) != ffecom_label_kind ());
12445 break;
12446
12447 case FFEINFO_basictypeLOGICAL:
12448 error = !ffe_is_ugly_logint ()
12449 || (ffeinfo_kindtype (info) != ffecom_label_kind ());
12450 break;
12451
12452 default:
12453 error = TRUE;
12454 break;
12455 }
12456 if ((expr == NULL) || (ffeinfo_rank (info) != 0)
12457 || (ffebld_op (expr) != FFEBLD_opSYMTER))
12458 error = TRUE;
12459 break;
12460
12461 case FFEEXPR_contextCGOTO:
12462 case FFEEXPR_contextFORMAT:
12463 case FFEEXPR_contextDIMLIST:
12464 case FFEEXPR_contextFILENUM: /* See equiv code in _ambig_. */
12465 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12466 break;
12467 switch (ffeinfo_basictype (info))
12468 {
12469 case FFEINFO_basictypeLOGICAL:
12470 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12471 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12472 FFEEXPR_contextLET);
12473 /* Fall through. */
12474 case FFEINFO_basictypeREAL:
12475 case FFEINFO_basictypeCOMPLEX:
12476 if (ffe_is_pedantic ())
12477 {
12478 error = TRUE;
12479 break;
12480 }
12481 /* Fall through. */
12482 case FFEINFO_basictypeINTEGER:
12483 case FFEINFO_basictypeHOLLERITH:
12484 case FFEINFO_basictypeTYPELESS:
12485 error = FALSE;
12486 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12487 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12488 FFEEXPR_contextLET);
12489 break;
12490
12491 default:
12492 error = TRUE;
12493 break;
12494 }
12495 break;
12496
12497 case FFEEXPR_contextARITHIF:
12498 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12499 break;
12500 switch (ffeinfo_basictype (info))
12501 {
12502 case FFEINFO_basictypeLOGICAL:
12503 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12504 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12505 FFEEXPR_contextLET);
12506 if (ffe_is_pedantic ())
12507 {
12508 error = TRUE;
12509 break;
12510 }
12511 /* Fall through. */
12512 case FFEINFO_basictypeHOLLERITH:
12513 case FFEINFO_basictypeTYPELESS:
12514 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12515 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12516 FFEEXPR_contextLET);
12517 /* Fall through. */
12518 case FFEINFO_basictypeINTEGER:
12519 case FFEINFO_basictypeREAL:
12520 error = FALSE;
12521 break;
12522
12523 default:
12524 error = TRUE;
12525 break;
12526 }
12527 break;
12528
12529 case FFEEXPR_contextSTOP:
12530 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12531 break;
12532 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12533 : ffeinfo_basictype (info))
12534 {
12535 case FFEINFO_basictypeINTEGER:
12536 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12537 break;
12538
12539 case FFEINFO_basictypeCHARACTER:
12540 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT);
12541 break;
12542
12543 case FFEINFO_basictypeHOLLERITH:
12544 case FFEINFO_basictypeTYPELESS:
12545 error = FALSE;
12546 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12547 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12548 FFEEXPR_contextLET);
12549 break;
12550
12551 case FFEINFO_basictypeNONE:
12552 error = FALSE;
12553 break;
12554
12555 default:
12556 error = TRUE;
12557 break;
12558 }
12559 if ((expr != NULL) && ((ffebld_op (expr) != FFEBLD_opCONTER)
12560 || (ffebld_conter_orig (expr) != NULL)))
12561 error = TRUE;
12562 break;
12563
12564 case FFEEXPR_contextINCLUDE:
12565 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12566 || (ffeinfo_basictype (info) != FFEINFO_basictypeCHARACTER)
12567 || (ffebld_op (expr) != FFEBLD_opCONTER)
12568 || (ffebld_conter_orig (expr) != NULL);
12569 break;
12570
12571 case FFEEXPR_contextSELECTCASE:
12572 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12573 break;
12574 switch (ffeinfo_basictype (info))
12575 {
12576 case FFEINFO_basictypeINTEGER:
12577 case FFEINFO_basictypeCHARACTER:
12578 case FFEINFO_basictypeLOGICAL:
12579 error = FALSE;
12580 break;
12581
12582 case FFEINFO_basictypeHOLLERITH:
12583 case FFEINFO_basictypeTYPELESS:
12584 error = FALSE;
12585 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12586 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12587 FFEEXPR_contextLET);
12588 break;
12589
12590 default:
12591 error = TRUE;
12592 break;
12593 }
12594 break;
12595
12596 case FFEEXPR_contextCASE:
12597 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12598 break;
12599 switch ((expr == NULL) ? FFEINFO_basictypeINTEGER
12600 : ffeinfo_basictype (info))
12601 {
12602 case FFEINFO_basictypeINTEGER:
12603 case FFEINFO_basictypeCHARACTER:
12604 case FFEINFO_basictypeLOGICAL:
12605 error = FALSE;
12606 break;
12607
12608 case FFEINFO_basictypeHOLLERITH:
12609 case FFEINFO_basictypeTYPELESS:
12610 error = FALSE;
12611 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12612 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12613 FFEEXPR_contextLET);
12614 break;
12615
12616 default:
12617 error = TRUE;
12618 break;
12619 }
12620 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12621 error = TRUE;
12622 break;
12623
12624 case FFEEXPR_contextCHARACTERSIZE:
12625 case FFEEXPR_contextKINDTYPE:
12626 case FFEEXPR_contextDIMLISTCOMMON:
12627 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12628 break;
12629 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12630 : ffeinfo_basictype (info))
12631 {
12632 case FFEINFO_basictypeLOGICAL:
12633 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12634 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12635 FFEEXPR_contextLET);
12636 /* Fall through. */
12637 case FFEINFO_basictypeREAL:
12638 case FFEINFO_basictypeCOMPLEX:
12639 if (ffe_is_pedantic ())
12640 {
12641 error = TRUE;
12642 break;
12643 }
12644 /* Fall through. */
12645 case FFEINFO_basictypeINTEGER:
12646 case FFEINFO_basictypeHOLLERITH:
12647 case FFEINFO_basictypeTYPELESS:
12648 error = FALSE;
12649 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12650 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12651 FFEEXPR_contextLET);
12652 break;
12653
12654 default:
12655 error = TRUE;
12656 break;
12657 }
12658 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12659 error = TRUE;
12660 break;
12661
12662 case FFEEXPR_contextEQVINDEX_:
12663 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12664 break;
12665 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12666 : ffeinfo_basictype (info))
12667 {
12668 case FFEINFO_basictypeNONE:
12669 error = FALSE;
12670 break;
12671
12672 case FFEINFO_basictypeLOGICAL:
12673 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12674 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12675 FFEEXPR_contextLET);
12676 /* Fall through. */
12677 case FFEINFO_basictypeREAL:
12678 case FFEINFO_basictypeCOMPLEX:
12679 if (ffe_is_pedantic ())
12680 {
12681 error = TRUE;
12682 break;
12683 }
12684 /* Fall through. */
12685 case FFEINFO_basictypeINTEGER:
12686 case FFEINFO_basictypeHOLLERITH:
12687 case FFEINFO_basictypeTYPELESS:
12688 error = FALSE;
12689 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12690 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12691 FFEEXPR_contextLET);
12692 break;
12693
12694 default:
12695 error = TRUE;
12696 break;
12697 }
12698 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12699 error = TRUE;
12700 break;
12701
12702 case FFEEXPR_contextPARAMETER:
12703 if (ffeexpr_stack_->is_rhs)
12704 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12705 || (ffebld_op (expr) != FFEBLD_opCONTER);
12706 else
12707 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12708 || (ffebld_op (expr) != FFEBLD_opSYMTER);
12709 break;
12710
12711 case FFEEXPR_contextINDEXORACTUALARG_:
12712 if (ffelex_token_type (t) == FFELEX_typeCOLON)
12713 ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
12714 else
12715 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
12716 goto again; /* :::::::::::::::::::: */
12717
12718 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
12719 if (ffelex_token_type (t) == FFELEX_typeCOLON)
12720 ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
12721 else
12722 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
12723 goto again; /* :::::::::::::::::::: */
12724
12725 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
12726 if (ffelex_token_type (t) == FFELEX_typeCOLON)
12727 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
12728 else
12729 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
12730 goto again; /* :::::::::::::::::::: */
12731
12732 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
12733 if (ffelex_token_type (t) == FFELEX_typeCOLON)
12734 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
12735 else
12736 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
12737 goto again; /* :::::::::::::::::::: */
12738
12739 case FFEEXPR_contextIMPDOCTRL_:
12740 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12741 break;
12742 if (!ffeexpr_stack_->is_rhs
12743 && (ffebld_op (expr) != FFEBLD_opSYMTER))
12744 error = TRUE;
12745 switch (ffeinfo_basictype (info))
12746 {
12747 case FFEINFO_basictypeLOGICAL:
12748 if (! ffe_is_ugly_logint ())
12749 error = TRUE;
12750 if (! ffeexpr_stack_->is_rhs)
12751 break;
12752 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12753 ffeinfo_kindtype (info), 0,
12754 FFETARGET_charactersizeNONE,
12755 FFEEXPR_contextLET);
12756 break;
12757
12758 case FFEINFO_basictypeINTEGER:
12759 case FFEINFO_basictypeHOLLERITH:
12760 case FFEINFO_basictypeTYPELESS:
12761 break;
12762
12763 case FFEINFO_basictypeREAL:
12764 if (!ffeexpr_stack_->is_rhs
12765 && ffe_is_warn_surprising ()
12766 && !error)
12767 {
12768 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
12769 ffebad_here (0, ffelex_token_where_line (ft),
12770 ffelex_token_where_column (ft));
12771 ffebad_string (ffelex_token_text (ft));
12772 ffebad_finish ();
12773 }
12774 break;
12775
12776 default:
12777 error = TRUE;
12778 break;
12779 }
12780 break;
12781
12782 case FFEEXPR_contextDATAIMPDOCTRL_:
12783 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12784 break;
12785 if (ffeexpr_stack_->is_rhs)
12786 {
12787 if ((ffebld_op (expr) != FFEBLD_opCONTER)
12788 && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12789 error = TRUE;
12790 }
12791 else if ((ffebld_op (expr) != FFEBLD_opSYMTER)
12792 || (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12793 error = TRUE;
12794 switch (ffeinfo_basictype (info))
12795 {
12796 case FFEINFO_basictypeLOGICAL:
12797 if (! ffeexpr_stack_->is_rhs)
12798 break;
12799 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12800 ffeinfo_kindtype (info), 0,
12801 FFETARGET_charactersizeNONE,
12802 FFEEXPR_contextLET);
12803 /* Fall through. */
12804 case FFEINFO_basictypeINTEGER:
12805 if (ffeexpr_stack_->is_rhs
12806 && (ffeinfo_kindtype (ffebld_info (expr))
12807 != FFEINFO_kindtypeINTEGERDEFAULT))
12808 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12809 FFEINFO_kindtypeINTEGERDEFAULT, 0,
12810 FFETARGET_charactersizeNONE,
12811 FFEEXPR_contextLET);
12812 break;
12813
12814 case FFEINFO_basictypeHOLLERITH:
12815 case FFEINFO_basictypeTYPELESS:
12816 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12817 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12818 FFEEXPR_contextLET);
12819 break;
12820
12821 case FFEINFO_basictypeREAL:
12822 if (!ffeexpr_stack_->is_rhs
12823 && ffe_is_warn_surprising ()
12824 && !error)
12825 {
12826 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
12827 ffebad_here (0, ffelex_token_where_line (ft),
12828 ffelex_token_where_column (ft));
12829 ffebad_string (ffelex_token_text (ft));
12830 ffebad_finish ();
12831 }
12832 break;
12833
12834 default:
12835 error = TRUE;
12836 break;
12837 }
12838 break;
12839
12840 case FFEEXPR_contextIMPDOITEM_:
12841 if (ffelex_token_type (t) == FFELEX_typeEQUALS)
12842 {
12843 ffeexpr_stack_->is_rhs = FALSE;
12844 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
12845 goto again; /* :::::::::::::::::::: */
12846 }
12847 /* Fall through. */
12848 case FFEEXPR_contextIOLIST:
12849 case FFEEXPR_contextFILEVXTCODE:
12850 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12851 : ffeinfo_basictype (info))
12852 {
12853 case FFEINFO_basictypeHOLLERITH:
12854 case FFEINFO_basictypeTYPELESS:
12855 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12856 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12857 FFEEXPR_contextLET);
12858 break;
12859
12860 default:
12861 break;
12862 }
12863 error = (expr == NULL)
12864 || ((ffeinfo_rank (info) != 0)
12865 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12866 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12867 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12868 == FFEBLD_opSTAR))); /* Bad if null expr, or if
12869 array that is not a SYMTER
12870 (can't happen yet, I
12871 think) or has a NULL or
12872 STAR (assumed) array
12873 size. */
12874 break;
12875
12876 case FFEEXPR_contextIMPDOITEMDF_:
12877 if (ffelex_token_type (t) == FFELEX_typeEQUALS)
12878 {
12879 ffeexpr_stack_->is_rhs = FALSE;
12880 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
12881 goto again; /* :::::::::::::::::::: */
12882 }
12883 /* Fall through. */
12884 case FFEEXPR_contextIOLISTDF:
12885 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12886 : ffeinfo_basictype (info))
12887 {
12888 case FFEINFO_basictypeHOLLERITH:
12889 case FFEINFO_basictypeTYPELESS:
12890 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12891 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12892 FFEEXPR_contextLET);
12893 break;
12894
12895 default:
12896 break;
12897 }
12898 error
12899 = (expr == NULL)
12900 || ((ffeinfo_basictype (info) == FFEINFO_basictypeCHARACTER)
12901 && (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT))
12902 || ((ffeinfo_rank (info) != 0)
12903 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12904 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12905 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12906 == FFEBLD_opSTAR))); /* Bad if null expr,
12907 non-default-kindtype
12908 character expr, or if
12909 array that is not a SYMTER
12910 (can't happen yet, I
12911 think) or has a NULL or
12912 STAR (assumed) array
12913 size. */
12914 break;
12915
12916 case FFEEXPR_contextDATAIMPDOITEM_:
12917 error = (expr == NULL)
12918 || (ffebld_op (expr) != FFEBLD_opARRAYREF)
12919 || ((ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR)
12920 && (ffeinfo_where (info) != FFEINFO_whereFLEETING_IADDR));
12921 break;
12922
12923 case FFEEXPR_contextDATAIMPDOINDEX_:
12924 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12925 break;
12926 switch (ffeinfo_basictype (info))
12927 {
12928 case FFEINFO_basictypeLOGICAL:
12929 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12930 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12931 FFEEXPR_contextLET);
12932 /* Fall through. */
12933 case FFEINFO_basictypeREAL:
12934 case FFEINFO_basictypeCOMPLEX:
12935 if (ffe_is_pedantic ())
12936 {
12937 error = TRUE;
12938 break;
12939 }
12940 /* Fall through. */
12941 case FFEINFO_basictypeINTEGER:
12942 case FFEINFO_basictypeHOLLERITH:
12943 case FFEINFO_basictypeTYPELESS:
12944 error = FALSE;
12945 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12946 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12947 FFEEXPR_contextLET);
12948 break;
12949
12950 default:
12951 error = TRUE;
12952 break;
12953 }
12954 if ((ffeinfo_where (info) != FFEINFO_whereCONSTANT)
12955 && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12956 error = TRUE;
12957 break;
12958
12959 case FFEEXPR_contextDATA:
12960 if (expr == NULL)
12961 error = TRUE;
12962 else if (ffeexpr_stack_->is_rhs)
12963 error = (ffebld_op (expr) != FFEBLD_opCONTER);
12964 else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12965 error = FALSE;
12966 else
12967 error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12968 break;
12969
12970 case FFEEXPR_contextINITVAL:
12971 error = (expr == NULL) || (ffebld_op (expr) != FFEBLD_opCONTER);
12972 break;
12973
12974 case FFEEXPR_contextEQUIVALENCE:
12975 if (expr == NULL)
12976 error = TRUE;
12977 else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12978 error = FALSE;
12979 else
12980 error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12981 break;
12982
12983 case FFEEXPR_contextFILEASSOC:
12984 case FFEEXPR_contextFILEINT:
12985 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12986 : ffeinfo_basictype (info))
12987 {
12988 case FFEINFO_basictypeINTEGER:
12989 /* Maybe this should be supported someday, but, right now,
12990 g77 can't generate a call to libf2c to write to an
12991 integer other than the default size. */
12992 error = ((! ffeexpr_stack_->is_rhs)
12993 && ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12994 break;
12995
12996 default:
12997 error = TRUE;
12998 break;
12999 }
13000 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13001 error = TRUE;
13002 break;
13003
13004 case FFEEXPR_contextFILEDFINT:
13005 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13006 : ffeinfo_basictype (info))
13007 {
13008 case FFEINFO_basictypeINTEGER:
13009 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
13010 break;
13011
13012 default:
13013 error = TRUE;
13014 break;
13015 }
13016 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13017 error = TRUE;
13018 break;
13019
13020 case FFEEXPR_contextFILELOG:
13021 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13022 : ffeinfo_basictype (info))
13023 {
13024 case FFEINFO_basictypeLOGICAL:
13025 error = FALSE;
13026 break;
13027
13028 default:
13029 error = TRUE;
13030 break;
13031 }
13032 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13033 error = TRUE;
13034 break;
13035
13036 case FFEEXPR_contextFILECHAR:
13037 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13038 : ffeinfo_basictype (info))
13039 {
13040 case FFEINFO_basictypeCHARACTER:
13041 error = FALSE;
13042 break;
13043
13044 default:
13045 error = TRUE;
13046 break;
13047 }
13048 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13049 error = TRUE;
13050 break;
13051
13052 case FFEEXPR_contextFILENUMCHAR:
13053 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
13054 break;
13055 switch (ffeinfo_basictype (info))
13056 {
13057 case FFEINFO_basictypeLOGICAL:
13058 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13059 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13060 FFEEXPR_contextLET);
13061 /* Fall through. */
13062 case FFEINFO_basictypeREAL:
13063 case FFEINFO_basictypeCOMPLEX:
13064 if (ffe_is_pedantic ())
13065 {
13066 error = TRUE;
13067 break;
13068 }
13069 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13070 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13071 FFEEXPR_contextLET);
13072 break;
13073
13074 case FFEINFO_basictypeINTEGER:
13075 case FFEINFO_basictypeCHARACTER:
13076 error = FALSE;
13077 break;
13078
13079 default:
13080 error = TRUE;
13081 break;
13082 }
13083 break;
13084
13085 case FFEEXPR_contextFILEDFCHAR:
13086 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
13087 break;
13088 switch (ffeinfo_basictype (info))
13089 {
13090 case FFEINFO_basictypeCHARACTER:
13091 error
13092 = (ffeinfo_kindtype (info)
13093 != FFEINFO_kindtypeCHARACTERDEFAULT);
13094 break;
13095
13096 default:
13097 error = TRUE;
13098 break;
13099 }
13100 if (!ffeexpr_stack_->is_rhs
13101 && (ffebld_op (expr) == FFEBLD_opSUBSTR))
13102 error = TRUE;
13103 break;
13104
13105 case FFEEXPR_contextFILEUNIT: /* See equiv code in _ambig_. */
13106 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13107 : ffeinfo_basictype (info))
13108 {
13109 case FFEINFO_basictypeLOGICAL:
13110 if ((error = (ffeinfo_rank (info) != 0)))
13111 break;
13112 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13113 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13114 FFEEXPR_contextLET);
13115 /* Fall through. */
13116 case FFEINFO_basictypeREAL:
13117 case FFEINFO_basictypeCOMPLEX:
13118 if ((error = (ffeinfo_rank (info) != 0)))
13119 break;
13120 if (ffe_is_pedantic ())
13121 {
13122 error = TRUE;
13123 break;
13124 }
13125 /* Fall through. */
13126 case FFEINFO_basictypeINTEGER:
13127 case FFEINFO_basictypeHOLLERITH:
13128 case FFEINFO_basictypeTYPELESS:
13129 if ((error = (ffeinfo_rank (info) != 0)))
13130 break;
13131 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13132 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13133 FFEEXPR_contextLET);
13134 break;
13135
13136 case FFEINFO_basictypeCHARACTER:
13137 switch (ffebld_op (expr))
13138 { /* As if _lhs had been called instead of
13139 _rhs. */
13140 case FFEBLD_opSYMTER:
13141 error
13142 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
13143 break;
13144
13145 case FFEBLD_opSUBSTR:
13146 error = (ffeinfo_where (ffebld_info (expr))
13147 == FFEINFO_whereCONSTANT_SUBOBJECT);
13148 break;
13149
13150 case FFEBLD_opARRAYREF:
13151 error = FALSE;
13152 break;
13153
13154 default:
13155 error = TRUE;
13156 break;
13157 }
13158 if (!error
13159 && ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
13160 || ((ffeinfo_rank (info) != 0)
13161 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
13162 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
13163 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
13164 == FFEBLD_opSTAR))))) /* Bad if
13165 non-default-kindtype
13166 character expr, or if
13167 array that is not a SYMTER
13168 (can't happen yet, I
13169 think), or has a NULL or
13170 STAR (assumed) array
13171 size. */
13172 error = TRUE;
13173 break;
13174
13175 default:
13176 error = TRUE;
13177 break;
13178 }
13179 break;
13180
13181 case FFEEXPR_contextFILEFORMAT:
13182 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13183 : ffeinfo_basictype (info))
13184 {
13185 case FFEINFO_basictypeINTEGER:
13186 error = (expr == NULL)
13187 || ((ffeinfo_rank (info) != 0) ?
13188 ffe_is_pedantic () /* F77 C5. */
13189 : (bool) (ffeinfo_kindtype (info) != ffecom_label_kind ()))
13190 || (ffebld_op (expr) != FFEBLD_opSYMTER);
13191 break;
13192
13193 case FFEINFO_basictypeLOGICAL:
13194 case FFEINFO_basictypeREAL:
13195 case FFEINFO_basictypeCOMPLEX:
13196 /* F77 C5 -- must be an array of hollerith. */
13197 error
13198 = ffe_is_pedantic ()
13199 || (ffeinfo_rank (info) == 0);
13200 break;
13201
13202 case FFEINFO_basictypeCHARACTER:
13203 if ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
13204 || ((ffeinfo_rank (info) != 0)
13205 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
13206 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
13207 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
13208 == FFEBLD_opSTAR)))) /* Bad if
13209 non-default-kindtype
13210 character expr, or if
13211 array that is not a SYMTER
13212 (can't happen yet, I
13213 think), or has a NULL or
13214 STAR (assumed) array
13215 size. */
13216 error = TRUE;
13217 else
13218 error = FALSE;
13219 break;
13220
13221 default:
13222 error = TRUE;
13223 break;
13224 }
13225 break;
13226
13227 case FFEEXPR_contextLOC_:
13228 /* See also ffeintrin_check_loc_. */
13229 if ((expr == NULL)
13230 || (ffeinfo_kind (info) != FFEINFO_kindENTITY)
13231 || ((ffebld_op (expr) != FFEBLD_opSYMTER)
13232 && (ffebld_op (expr) != FFEBLD_opSUBSTR)
13233 && (ffebld_op (expr) != FFEBLD_opARRAYREF)))
13234 error = TRUE;
13235 break;
13236
13237 default:
13238 error = FALSE;
13239 break;
13240 }
13241
13242 if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
13243 {
13244 ffebad_start (FFEBAD_EXPR_WRONG);
13245 ffebad_here (0, ffelex_token_where_line (ft),
13246 ffelex_token_where_column (ft));
13247 ffebad_finish ();
13248 expr = ffebld_new_any ();
13249 ffebld_set_info (expr, ffeinfo_new_any ());
13250 }
13251
13252 callback = ffeexpr_stack_->callback;
13253 s = ffeexpr_stack_->previous;
13254 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
13255 sizeof (*ffeexpr_stack_));
13256 ffeexpr_stack_ = s;
13257 next = (ffelexHandler) (*callback) (ft, expr, t);
13258 ffelex_token_kill (ft);
13259 return (ffelexHandler) next;
13260 }
13261
13262 /* ffeexpr_finished_ambig_ -- Check validity of ambiguous unit/form spec
13263
13264 ffebld expr;
13265 expr = ffeexpr_finished_ambig_(expr);
13266
13267 Replicates a bit of ffeexpr_finished_'s task when in a context
13268 of UNIT or FORMAT. */
13269
13270 static ffebld
13271 ffeexpr_finished_ambig_ (ffelexToken ft, ffebld expr)
13272 {
13273 ffeinfo info = ffebld_info (expr);
13274 bool error;
13275
13276 switch (ffeexpr_stack_->context)
13277 {
13278 case FFEEXPR_contextFILENUMAMBIG: /* Same as FILENUM in _finished_. */
13279 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13280 : ffeinfo_basictype (info))
13281 {
13282 case FFEINFO_basictypeLOGICAL:
13283 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13284 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13285 FFEEXPR_contextLET);
13286 /* Fall through. */
13287 case FFEINFO_basictypeREAL:
13288 case FFEINFO_basictypeCOMPLEX:
13289 if (ffe_is_pedantic ())
13290 {
13291 error = TRUE;
13292 break;
13293 }
13294 /* Fall through. */
13295 case FFEINFO_basictypeINTEGER:
13296 case FFEINFO_basictypeHOLLERITH:
13297 case FFEINFO_basictypeTYPELESS:
13298 error = FALSE;
13299 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13300 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13301 FFEEXPR_contextLET);
13302 break;
13303
13304 default:
13305 error = TRUE;
13306 break;
13307 }
13308 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13309 error = TRUE;
13310 break;
13311
13312 case FFEEXPR_contextFILEUNITAMBIG: /* Same as FILEUNIT in _finished_. */
13313 if ((expr != NULL) && (ffebld_op (expr) == FFEBLD_opSTAR))
13314 {
13315 error = FALSE;
13316 break;
13317 }
13318 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13319 : ffeinfo_basictype (info))
13320 {
13321 case FFEINFO_basictypeLOGICAL:
13322 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13323 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13324 FFEEXPR_contextLET);
13325 /* Fall through. */
13326 case FFEINFO_basictypeREAL:
13327 case FFEINFO_basictypeCOMPLEX:
13328 if (ffe_is_pedantic ())
13329 {
13330 error = TRUE;
13331 break;
13332 }
13333 /* Fall through. */
13334 case FFEINFO_basictypeINTEGER:
13335 case FFEINFO_basictypeHOLLERITH:
13336 case FFEINFO_basictypeTYPELESS:
13337 error = (ffeinfo_rank (info) != 0);
13338 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13339 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13340 FFEEXPR_contextLET);
13341 break;
13342
13343 case FFEINFO_basictypeCHARACTER:
13344 switch (ffebld_op (expr))
13345 { /* As if _lhs had been called instead of
13346 _rhs. */
13347 case FFEBLD_opSYMTER:
13348 error
13349 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
13350 break;
13351
13352 case FFEBLD_opSUBSTR:
13353 error = (ffeinfo_where (ffebld_info (expr))
13354 == FFEINFO_whereCONSTANT_SUBOBJECT);
13355 break;
13356
13357 case FFEBLD_opARRAYREF:
13358 error = FALSE;
13359 break;
13360
13361 default:
13362 error = TRUE;
13363 break;
13364 }
13365 break;
13366
13367 default:
13368 error = TRUE;
13369 break;
13370 }
13371 break;
13372
13373 default:
13374 assert ("bad context" == NULL);
13375 error = TRUE;
13376 break;
13377 }
13378
13379 if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
13380 {
13381 ffebad_start (FFEBAD_EXPR_WRONG);
13382 ffebad_here (0, ffelex_token_where_line (ft),
13383 ffelex_token_where_column (ft));
13384 ffebad_finish ();
13385 expr = ffebld_new_any ();
13386 ffebld_set_info (expr, ffeinfo_new_any ());
13387 }
13388
13389 return expr;
13390 }
13391
13392 /* ffeexpr_token_lhs_ -- Initial state for lhs expression
13393
13394 Return a pointer to this function to the lexer (ffelex), which will
13395 invoke it for the next token.
13396
13397 Basically a smaller version of _rhs_; keep them both in sync, of course. */
13398
13399 static ffelexHandler
13400 ffeexpr_token_lhs_ (ffelexToken t)
13401 {
13402
13403 /* When changing the list of valid initial lhs tokens, check whether to
13404 update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
13405 READ (expr) <token> case -- it assumes it knows which tokens <token> can
13406 be to indicate an lhs (or implied DO), which right now is the set
13407 {NAME,OPEN_PAREN}.
13408
13409 This comment also appears in ffeexpr_token_first_lhs_. */
13410
13411 switch (ffelex_token_type (t))
13412 {
13413 case FFELEX_typeNAME:
13414 case FFELEX_typeNAMES:
13415 ffeexpr_tokens_[0] = ffelex_token_use (t);
13416 return (ffelexHandler) ffeexpr_token_name_lhs_;
13417
13418 default:
13419 return (ffelexHandler) ffeexpr_finished_ (t);
13420 }
13421 }
13422
13423 /* ffeexpr_token_rhs_ -- Initial state for rhs expression
13424
13425 Return a pointer to this function to the lexer (ffelex), which will
13426 invoke it for the next token.
13427
13428 The initial state and the post-binary-operator state are the same and
13429 both handled here, with the expression stack used to distinguish
13430 between them. Binary operators are invalid here; unary operators,
13431 constants, subexpressions, and name references are valid. */
13432
13433 static ffelexHandler
13434 ffeexpr_token_rhs_ (ffelexToken t)
13435 {
13436 ffeexprExpr_ e;
13437
13438 switch (ffelex_token_type (t))
13439 {
13440 case FFELEX_typeQUOTE:
13441 if (ffe_is_vxt ())
13442 {
13443 ffeexpr_tokens_[0] = ffelex_token_use (t);
13444 return (ffelexHandler) ffeexpr_token_quote_;
13445 }
13446 ffeexpr_tokens_[0] = ffelex_token_use (t);
13447 ffelex_set_expecting_hollerith (-1, '\"',
13448 ffelex_token_where_line (t),
13449 ffelex_token_where_column (t));
13450 /* Don't have to unset this one. */
13451 return (ffelexHandler) ffeexpr_token_apostrophe_;
13452
13453 case FFELEX_typeAPOSTROPHE:
13454 ffeexpr_tokens_[0] = ffelex_token_use (t);
13455 ffelex_set_expecting_hollerith (-1, '\'',
13456 ffelex_token_where_line (t),
13457 ffelex_token_where_column (t));
13458 /* Don't have to unset this one. */
13459 return (ffelexHandler) ffeexpr_token_apostrophe_;
13460
13461 case FFELEX_typePERCENT:
13462 ffeexpr_tokens_[0] = ffelex_token_use (t);
13463 return (ffelexHandler) ffeexpr_token_percent_;
13464
13465 case FFELEX_typeOPEN_PAREN:
13466 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
13467 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
13468 FFEEXPR_contextPAREN_,
13469 ffeexpr_cb_close_paren_c_);
13470
13471 case FFELEX_typePLUS:
13472 e = ffeexpr_expr_new_ ();
13473 e->type = FFEEXPR_exprtypeUNARY_;
13474 e->token = ffelex_token_use (t);
13475 e->u.operator.op = FFEEXPR_operatorADD_;
13476 e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
13477 e->u.operator.as = FFEEXPR_operatorassociativityADD_;
13478 ffeexpr_exprstack_push_unary_ (e);
13479 return (ffelexHandler) ffeexpr_token_rhs_;
13480
13481 case FFELEX_typeMINUS:
13482 e = ffeexpr_expr_new_ ();
13483 e->type = FFEEXPR_exprtypeUNARY_;
13484 e->token = ffelex_token_use (t);
13485 e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
13486 e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
13487 e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
13488 ffeexpr_exprstack_push_unary_ (e);
13489 return (ffelexHandler) ffeexpr_token_rhs_;
13490
13491 case FFELEX_typePERIOD:
13492 ffeexpr_tokens_[0] = ffelex_token_use (t);
13493 return (ffelexHandler) ffeexpr_token_period_;
13494
13495 case FFELEX_typeNUMBER:
13496 ffeexpr_tokens_[0] = ffelex_token_use (t);
13497 ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
13498 if (ffeexpr_hollerith_count_ > 0)
13499 ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
13500 '\0',
13501 ffelex_token_where_line (t),
13502 ffelex_token_where_column (t));
13503 return (ffelexHandler) ffeexpr_token_number_;
13504
13505 case FFELEX_typeNAME:
13506 case FFELEX_typeNAMES:
13507 ffeexpr_tokens_[0] = ffelex_token_use (t);
13508 switch (ffeexpr_stack_->context)
13509 {
13510 case FFEEXPR_contextACTUALARG_:
13511 case FFEEXPR_contextINDEXORACTUALARG_:
13512 case FFEEXPR_contextSFUNCDEFACTUALARG_:
13513 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
13514 return (ffelexHandler) ffeexpr_token_name_arg_;
13515
13516 default:
13517 return (ffelexHandler) ffeexpr_token_name_rhs_;
13518 }
13519
13520 case FFELEX_typeASTERISK:
13521 case FFELEX_typeSLASH:
13522 case FFELEX_typePOWER:
13523 case FFELEX_typeCONCAT:
13524 case FFELEX_typeREL_EQ:
13525 case FFELEX_typeREL_NE:
13526 case FFELEX_typeREL_LE:
13527 case FFELEX_typeREL_GE:
13528 if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
13529 {
13530 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13531 ffebad_finish ();
13532 }
13533 return (ffelexHandler) ffeexpr_token_rhs_;
13534
13535 #if 0
13536 case FFELEX_typeEQUALS:
13537 case FFELEX_typePOINTS:
13538 case FFELEX_typeCLOSE_ANGLE:
13539 case FFELEX_typeCLOSE_PAREN:
13540 case FFELEX_typeCOMMA:
13541 case FFELEX_typeCOLON:
13542 case FFELEX_typeEOS:
13543 case FFELEX_typeSEMICOLON:
13544 #endif
13545 default:
13546 return (ffelexHandler) ffeexpr_finished_ (t);
13547 }
13548 }
13549
13550 /* ffeexpr_token_period_ -- Rhs PERIOD
13551
13552 Return a pointer to this function to the lexer (ffelex), which will
13553 invoke it for the next token.
13554
13555 Handle a period detected at rhs (expecting unary op or operand) state.
13556 Must begin a floating-point value (as in .12) or a dot-dot name, of
13557 which only .NOT., .TRUE., and .FALSE. are truly valid. Other sort-of-
13558 valid names represent binary operators, which are invalid here because
13559 there isn't an operand at the top of the stack. */
13560
13561 static ffelexHandler
13562 ffeexpr_token_period_ (ffelexToken t)
13563 {
13564 switch (ffelex_token_type (t))
13565 {
13566 case FFELEX_typeNAME:
13567 case FFELEX_typeNAMES:
13568 ffeexpr_current_dotdot_ = ffestr_other (t);
13569 switch (ffeexpr_current_dotdot_)
13570 {
13571 case FFESTR_otherNone:
13572 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
13573 {
13574 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13575 ffelex_token_where_column (ffeexpr_tokens_[0]));
13576 ffebad_finish ();
13577 }
13578 ffelex_token_kill (ffeexpr_tokens_[0]);
13579 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13580
13581 case FFESTR_otherTRUE:
13582 case FFESTR_otherFALSE:
13583 case FFESTR_otherNOT:
13584 ffeexpr_tokens_[1] = ffelex_token_use (t);
13585 return (ffelexHandler) ffeexpr_token_end_period_;
13586
13587 default:
13588 if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
13589 {
13590 ffebad_here (0, ffelex_token_where_line (t),
13591 ffelex_token_where_column (t));
13592 ffebad_finish ();
13593 }
13594 ffelex_token_kill (ffeexpr_tokens_[0]);
13595 return (ffelexHandler) ffeexpr_token_swallow_period_;
13596 }
13597 break; /* Nothing really reaches here. */
13598
13599 case FFELEX_typeNUMBER:
13600 ffeexpr_tokens_[1] = ffelex_token_use (t);
13601 return (ffelexHandler) ffeexpr_token_real_;
13602
13603 default:
13604 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
13605 {
13606 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13607 ffelex_token_where_column (ffeexpr_tokens_[0]));
13608 ffebad_finish ();
13609 }
13610 ffelex_token_kill (ffeexpr_tokens_[0]);
13611 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13612 }
13613 }
13614
13615 /* ffeexpr_token_end_period_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
13616
13617 Return a pointer to this function to the lexer (ffelex), which will
13618 invoke it for the next token.
13619
13620 Expecting a period to close a .NOT, .TRUE, or .FALSE at rhs (unary op
13621 or operator) state. If period isn't found, issue a diagnostic but
13622 pretend we saw one. ffeexpr_current_dotdot_ must already contained the
13623 dotdot representation of the name in between the two PERIOD tokens. */
13624
13625 static ffelexHandler
13626 ffeexpr_token_end_period_ (ffelexToken t)
13627 {
13628 ffeexprExpr_ e;
13629
13630 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13631 {
13632 if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
13633 {
13634 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13635 ffelex_token_where_column (ffeexpr_tokens_[0]));
13636 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13637 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
13638 ffebad_finish ();
13639 }
13640 }
13641
13642 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill "NOT"/"TRUE"/"FALSE"
13643 token. */
13644
13645 e = ffeexpr_expr_new_ ();
13646 e->token = ffeexpr_tokens_[0];
13647
13648 switch (ffeexpr_current_dotdot_)
13649 {
13650 case FFESTR_otherNOT:
13651 e->type = FFEEXPR_exprtypeUNARY_;
13652 e->u.operator.op = FFEEXPR_operatorNOT_;
13653 e->u.operator.prec = FFEEXPR_operatorprecedenceNOT_;
13654 e->u.operator.as = FFEEXPR_operatorassociativityNOT_;
13655 ffeexpr_exprstack_push_unary_ (e);
13656 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13657 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13658 return (ffelexHandler) ffeexpr_token_rhs_;
13659
13660 case FFESTR_otherTRUE:
13661 e->type = FFEEXPR_exprtypeOPERAND_;
13662 e->u.operand
13663 = ffebld_new_conter (ffebld_constant_new_logicaldefault (TRUE));
13664 ffebld_set_info (e->u.operand,
13665 ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
13666 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13667 ffeexpr_exprstack_push_operand_ (e);
13668 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13669 return (ffelexHandler) ffeexpr_token_binary_ (t);
13670 return (ffelexHandler) ffeexpr_token_binary_;
13671
13672 case FFESTR_otherFALSE:
13673 e->type = FFEEXPR_exprtypeOPERAND_;
13674 e->u.operand
13675 = ffebld_new_conter (ffebld_constant_new_logicaldefault (FALSE));
13676 ffebld_set_info (e->u.operand,
13677 ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
13678 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13679 ffeexpr_exprstack_push_operand_ (e);
13680 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13681 return (ffelexHandler) ffeexpr_token_binary_ (t);
13682 return (ffelexHandler) ffeexpr_token_binary_;
13683
13684 default:
13685 assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL);
13686 exit (0);
13687 return NULL;
13688 }
13689 }
13690
13691 /* ffeexpr_token_swallow_period_ -- Rhs PERIOD NAME(not NOT, TRUE, or FALSE)
13692
13693 Return a pointer to this function to the lexer (ffelex), which will
13694 invoke it for the next token.
13695
13696 A diagnostic has already been issued; just swallow a period if there is
13697 one, then continue with ffeexpr_token_rhs_. */
13698
13699 static ffelexHandler
13700 ffeexpr_token_swallow_period_ (ffelexToken t)
13701 {
13702 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13703 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13704
13705 return (ffelexHandler) ffeexpr_token_rhs_;
13706 }
13707
13708 /* ffeexpr_token_real_ -- Rhs PERIOD NUMBER
13709
13710 Return a pointer to this function to the lexer (ffelex), which will
13711 invoke it for the next token.
13712
13713 After a period and a string of digits, check next token for possible
13714 exponent designation (D, E, or Q as first/only character) and continue
13715 real-number handling accordingly. Else form basic real constant, push
13716 onto expression stack, and enter binary state using current token (which,
13717 if it is a name not beginning with D, E, or Q, will certainly result
13718 in an error, but that's not for this routine to deal with). */
13719
13720 static ffelexHandler
13721 ffeexpr_token_real_ (ffelexToken t)
13722 {
13723 char d;
13724 const char *p;
13725
13726 if (((ffelex_token_type (t) != FFELEX_typeNAME)
13727 && (ffelex_token_type (t) != FFELEX_typeNAMES))
13728 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13729 'D', 'd')
13730 || ffesrc_char_match_init (d, 'E', 'e')
13731 || ffesrc_char_match_init (d, 'Q', 'q')))
13732 && ffeexpr_isdigits_ (++p)))
13733 {
13734 #if 0
13735 /* This code has been removed because it seems inconsistent to
13736 produce a diagnostic in this case, but not all of the other
13737 ones that look for an exponent and cannot recognize one. */
13738 if (((ffelex_token_type (t) == FFELEX_typeNAME)
13739 || (ffelex_token_type (t) == FFELEX_typeNAMES))
13740 && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
13741 {
13742 char bad[2];
13743
13744 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13745 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
13746 ffelex_token_where_column (ffeexpr_tokens_[0]));
13747 bad[0] = *(p - 1);
13748 bad[1] = '\0';
13749 ffebad_string (bad);
13750 ffebad_finish ();
13751 }
13752 #endif
13753 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13754 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13755 NULL, NULL, NULL);
13756
13757 ffelex_token_kill (ffeexpr_tokens_[0]);
13758 ffelex_token_kill (ffeexpr_tokens_[1]);
13759 return (ffelexHandler) ffeexpr_token_binary_ (t);
13760 }
13761
13762 /* Just exponent character by itself? In which case, PLUS or MINUS must
13763 surely be next, followed by a NUMBER token. */
13764
13765 if (*p == '\0')
13766 {
13767 ffeexpr_tokens_[2] = ffelex_token_use (t);
13768 return (ffelexHandler) ffeexpr_token_real_exponent_;
13769 }
13770
13771 ffeexpr_make_float_const_ (d, NULL, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13772 t, NULL, NULL);
13773
13774 ffelex_token_kill (ffeexpr_tokens_[0]);
13775 ffelex_token_kill (ffeexpr_tokens_[1]);
13776 return (ffelexHandler) ffeexpr_token_binary_;
13777 }
13778
13779 /* ffeexpr_token_real_exponent_ -- Rhs PERIOD NUMBER NAME(D, E, or Q)
13780
13781 Return a pointer to this function to the lexer (ffelex), which will
13782 invoke it for the next token.
13783
13784 Ensures this token is PLUS or MINUS, preserves it, goes to final state
13785 for real number (exponent digits). Else issues diagnostic, assumes a
13786 zero exponent field for number, passes token on to binary state as if
13787 previous token had been "E0" instead of "E", for example. */
13788
13789 static ffelexHandler
13790 ffeexpr_token_real_exponent_ (ffelexToken t)
13791 {
13792 if ((ffelex_token_type (t) != FFELEX_typePLUS)
13793 && (ffelex_token_type (t) != FFELEX_typeMINUS))
13794 {
13795 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13796 {
13797 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
13798 ffelex_token_where_column (ffeexpr_tokens_[2]));
13799 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13800 ffebad_finish ();
13801 }
13802
13803 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13804 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13805 NULL, NULL, NULL);
13806
13807 ffelex_token_kill (ffeexpr_tokens_[0]);
13808 ffelex_token_kill (ffeexpr_tokens_[1]);
13809 ffelex_token_kill (ffeexpr_tokens_[2]);
13810 return (ffelexHandler) ffeexpr_token_binary_ (t);
13811 }
13812
13813 ffeexpr_tokens_[3] = ffelex_token_use (t);
13814 return (ffelexHandler) ffeexpr_token_real_exp_sign_;
13815 }
13816
13817 /* ffeexpr_token_real_exp_sign_ -- Rhs PERIOD NUMBER NAME(D,E,Q) PLUS/MINUS
13818
13819 Return a pointer to this function to the lexer (ffelex), which will
13820 invoke it for the next token.
13821
13822 Make sure token is a NUMBER, make a real constant out of all we have and
13823 push it onto the expression stack. Else issue diagnostic and pretend
13824 exponent field was a zero. */
13825
13826 static ffelexHandler
13827 ffeexpr_token_real_exp_sign_ (ffelexToken t)
13828 {
13829 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13830 {
13831 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13832 {
13833 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
13834 ffelex_token_where_column (ffeexpr_tokens_[2]));
13835 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13836 ffebad_finish ();
13837 }
13838
13839 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13840 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13841 NULL, NULL, NULL);
13842
13843 ffelex_token_kill (ffeexpr_tokens_[0]);
13844 ffelex_token_kill (ffeexpr_tokens_[1]);
13845 ffelex_token_kill (ffeexpr_tokens_[2]);
13846 ffelex_token_kill (ffeexpr_tokens_[3]);
13847 return (ffelexHandler) ffeexpr_token_binary_ (t);
13848 }
13849
13850 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0], NULL,
13851 ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2],
13852 ffeexpr_tokens_[3], t);
13853
13854 ffelex_token_kill (ffeexpr_tokens_[0]);
13855 ffelex_token_kill (ffeexpr_tokens_[1]);
13856 ffelex_token_kill (ffeexpr_tokens_[2]);
13857 ffelex_token_kill (ffeexpr_tokens_[3]);
13858 return (ffelexHandler) ffeexpr_token_binary_;
13859 }
13860
13861 /* ffeexpr_token_number_ -- Rhs NUMBER
13862
13863 Return a pointer to this function to the lexer (ffelex), which will
13864 invoke it for the next token.
13865
13866 If the token is a period, we may have a floating-point number, or an
13867 integer followed by a dotdot binary operator. If the token is a name
13868 beginning with D, E, or Q, we definitely have a floating-point number.
13869 If the token is a hollerith constant, that's what we've got, so push
13870 it onto the expression stack and continue with the binary state.
13871
13872 Otherwise, we have an integer followed by something the binary state
13873 should be able to swallow. */
13874
13875 static ffelexHandler
13876 ffeexpr_token_number_ (ffelexToken t)
13877 {
13878 ffeexprExpr_ e;
13879 ffeinfo ni;
13880 char d;
13881 const char *p;
13882
13883 if (ffeexpr_hollerith_count_ > 0)
13884 ffelex_set_expecting_hollerith (0, '\0',
13885 ffewhere_line_unknown (),
13886 ffewhere_column_unknown ());
13887
13888 /* See if we've got a floating-point number here. */
13889
13890 switch (ffelex_token_type (t))
13891 {
13892 case FFELEX_typeNAME:
13893 case FFELEX_typeNAMES:
13894 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13895 'D', 'd')
13896 || ffesrc_char_match_init (d, 'E', 'e')
13897 || ffesrc_char_match_init (d, 'Q', 'q'))
13898 && ffeexpr_isdigits_ (++p))
13899 {
13900
13901 /* Just exponent character by itself? In which case, PLUS or MINUS
13902 must surely be next, followed by a NUMBER token. */
13903
13904 if (*p == '\0')
13905 {
13906 ffeexpr_tokens_[1] = ffelex_token_use (t);
13907 return (ffelexHandler) ffeexpr_token_number_exponent_;
13908 }
13909 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], NULL, NULL, t,
13910 NULL, NULL);
13911
13912 ffelex_token_kill (ffeexpr_tokens_[0]);
13913 return (ffelexHandler) ffeexpr_token_binary_;
13914 }
13915 break;
13916
13917 case FFELEX_typePERIOD:
13918 ffeexpr_tokens_[1] = ffelex_token_use (t);
13919 return (ffelexHandler) ffeexpr_token_number_period_;
13920
13921 case FFELEX_typeHOLLERITH:
13922 e = ffeexpr_expr_new_ ();
13923 e->type = FFEEXPR_exprtypeOPERAND_;
13924 e->token = ffeexpr_tokens_[0];
13925 e->u.operand = ffebld_new_conter (ffebld_constant_new_hollerith (t));
13926 ni = ffeinfo_new (FFEINFO_basictypeHOLLERITH, FFEINFO_kindtypeNONE,
13927 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
13928 ffelex_token_length (t));
13929 ffebld_set_info (e->u.operand, ni);
13930 ffeexpr_exprstack_push_operand_ (e);
13931 return (ffelexHandler) ffeexpr_token_binary_;
13932
13933 default:
13934 break;
13935 }
13936
13937 /* Nothing specific we were looking for, so make an integer and pass the
13938 current token to the binary state. */
13939
13940 ffeexpr_make_float_const_ ('I', ffeexpr_tokens_[0], NULL, NULL,
13941 NULL, NULL, NULL);
13942 return (ffelexHandler) ffeexpr_token_binary_ (t);
13943 }
13944
13945 /* ffeexpr_token_number_exponent_ -- Rhs NUMBER NAME(D, E, or Q)
13946
13947 Return a pointer to this function to the lexer (ffelex), which will
13948 invoke it for the next token.
13949
13950 Ensures this token is PLUS or MINUS, preserves it, goes to final state
13951 for real number (exponent digits). Else treats number as integer, passes
13952 name to binary, passes current token to subsequent handler. */
13953
13954 static ffelexHandler
13955 ffeexpr_token_number_exponent_ (ffelexToken t)
13956 {
13957 if ((ffelex_token_type (t) != FFELEX_typePLUS)
13958 && (ffelex_token_type (t) != FFELEX_typeMINUS))
13959 {
13960 ffeexprExpr_ e;
13961 ffelexHandler nexthandler;
13962
13963 e = ffeexpr_expr_new_ ();
13964 e->type = FFEEXPR_exprtypeOPERAND_;
13965 e->token = ffeexpr_tokens_[0];
13966 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
13967 (ffeexpr_tokens_[0]));
13968 ffebld_set_info (e->u.operand,
13969 ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT,
13970 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13971 ffeexpr_exprstack_push_operand_ (e);
13972 nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[1]);
13973 ffelex_token_kill (ffeexpr_tokens_[1]);
13974 return (ffelexHandler) (*nexthandler) (t);
13975 }
13976
13977 ffeexpr_tokens_[2] = ffelex_token_use (t);
13978 return (ffelexHandler) ffeexpr_token_number_exp_sign_;
13979 }
13980
13981 /* ffeexpr_token_number_exp_sign_ -- Rhs NUMBER NAME(D,E,Q) PLUS/MINUS
13982
13983 Return a pointer to this function to the lexer (ffelex), which will
13984 invoke it for the next token.
13985
13986 Make sure token is a NUMBER, make a real constant out of all we have and
13987 push it onto the expression stack. Else issue diagnostic and pretend
13988 exponent field was a zero. */
13989
13990 static ffelexHandler
13991 ffeexpr_token_number_exp_sign_ (ffelexToken t)
13992 {
13993 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13994 {
13995 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13996 {
13997 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[1]),
13998 ffelex_token_where_column (ffeexpr_tokens_[1]));
13999 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14000 ffebad_finish ();
14001 }
14002
14003 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
14004 ffeexpr_tokens_[0], NULL, NULL,
14005 ffeexpr_tokens_[1], ffeexpr_tokens_[2],
14006 NULL);
14007
14008 ffelex_token_kill (ffeexpr_tokens_[0]);
14009 ffelex_token_kill (ffeexpr_tokens_[1]);
14010 ffelex_token_kill (ffeexpr_tokens_[2]);
14011 return (ffelexHandler) ffeexpr_token_binary_ (t);
14012 }
14013
14014 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
14015 ffeexpr_tokens_[0], NULL, NULL,
14016 ffeexpr_tokens_[1], ffeexpr_tokens_[2], t);
14017
14018 ffelex_token_kill (ffeexpr_tokens_[0]);
14019 ffelex_token_kill (ffeexpr_tokens_[1]);
14020 ffelex_token_kill (ffeexpr_tokens_[2]);
14021 return (ffelexHandler) ffeexpr_token_binary_;
14022 }
14023
14024 /* ffeexpr_token_number_period_ -- Rhs NUMBER PERIOD
14025
14026 Return a pointer to this function to the lexer (ffelex), which will
14027 invoke it for the next token.
14028
14029 Handle a period detected following a number at rhs state. Must begin a
14030 floating-point value (as in 1., 1.2, 1.E3, or 1.E+3) or a dot-dot name. */
14031
14032 static ffelexHandler
14033 ffeexpr_token_number_period_ (ffelexToken t)
14034 {
14035 ffeexprExpr_ e;
14036 ffelexHandler nexthandler;
14037 const char *p;
14038 char d;
14039
14040 switch (ffelex_token_type (t))
14041 {
14042 case FFELEX_typeNAME:
14043 case FFELEX_typeNAMES:
14044 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
14045 'D', 'd')
14046 || ffesrc_char_match_init (d, 'E', 'e')
14047 || ffesrc_char_match_init (d, 'Q', 'q'))
14048 && ffeexpr_isdigits_ (++p))
14049 {
14050
14051 /* Just exponent character by itself? In which case, PLUS or MINUS
14052 must surely be next, followed by a NUMBER token. */
14053
14054 if (*p == '\0')
14055 {
14056 ffeexpr_tokens_[2] = ffelex_token_use (t);
14057 return (ffelexHandler) ffeexpr_token_number_per_exp_;
14058 }
14059 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0],
14060 ffeexpr_tokens_[1], NULL, t, NULL,
14061 NULL);
14062
14063 ffelex_token_kill (ffeexpr_tokens_[0]);
14064 ffelex_token_kill (ffeexpr_tokens_[1]);
14065 return (ffelexHandler) ffeexpr_token_binary_;
14066 }
14067 /* A name not representing an exponent, so assume it will be something
14068 like EQ, make an integer from the number, pass the period to binary
14069 state and the current token to the resulting state. */
14070
14071 e = ffeexpr_expr_new_ ();
14072 e->type = FFEEXPR_exprtypeOPERAND_;
14073 e->token = ffeexpr_tokens_[0];
14074 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
14075 (ffeexpr_tokens_[0]));
14076 ffebld_set_info (e->u.operand,
14077 ffeinfo_new (FFEINFO_basictypeINTEGER,
14078 FFEINFO_kindtypeINTEGERDEFAULT, 0,
14079 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14080 FFETARGET_charactersizeNONE));
14081 ffeexpr_exprstack_push_operand_ (e);
14082 nexthandler = (ffelexHandler) ffeexpr_token_binary_
14083 (ffeexpr_tokens_[1]);
14084 ffelex_token_kill (ffeexpr_tokens_[1]);
14085 return (ffelexHandler) (*nexthandler) (t);
14086
14087 case FFELEX_typeNUMBER:
14088 ffeexpr_tokens_[2] = ffelex_token_use (t);
14089 return (ffelexHandler) ffeexpr_token_number_real_;
14090
14091 default:
14092 break;
14093 }
14094
14095 /* Nothing specific we were looking for, so make a real number and pass the
14096 period and then the current token to the binary state. */
14097
14098 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14099 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14100 NULL, NULL, NULL, NULL);
14101
14102 ffelex_token_kill (ffeexpr_tokens_[0]);
14103 ffelex_token_kill (ffeexpr_tokens_[1]);
14104 return (ffelexHandler) ffeexpr_token_binary_ (t);
14105 }
14106
14107 /* ffeexpr_token_number_per_exp_ -- Rhs NUMBER PERIOD NAME(D, E, or Q)
14108
14109 Return a pointer to this function to the lexer (ffelex), which will
14110 invoke it for the next token.
14111
14112 Ensures this token is PLUS or MINUS, preserves it, goes to final state
14113 for real number (exponent digits). Else treats number as real, passes
14114 name to binary, passes current token to subsequent handler. */
14115
14116 static ffelexHandler
14117 ffeexpr_token_number_per_exp_ (ffelexToken t)
14118 {
14119 if ((ffelex_token_type (t) != FFELEX_typePLUS)
14120 && (ffelex_token_type (t) != FFELEX_typeMINUS))
14121 {
14122 ffelexHandler nexthandler;
14123
14124 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14125 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14126 NULL, NULL, NULL, NULL);
14127
14128 ffelex_token_kill (ffeexpr_tokens_[0]);
14129 ffelex_token_kill (ffeexpr_tokens_[1]);
14130 nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[2]);
14131 ffelex_token_kill (ffeexpr_tokens_[2]);
14132 return (ffelexHandler) (*nexthandler) (t);
14133 }
14134
14135 ffeexpr_tokens_[3] = ffelex_token_use (t);
14136 return (ffelexHandler) ffeexpr_token_num_per_exp_sign_;
14137 }
14138
14139 /* ffeexpr_token_number_real_ -- Rhs NUMBER PERIOD NUMBER
14140
14141 Return a pointer to this function to the lexer (ffelex), which will
14142 invoke it for the next token.
14143
14144 After a number, period, and number, check next token for possible
14145 exponent designation (D, E, or Q as first/only character) and continue
14146 real-number handling accordingly. Else form basic real constant, push
14147 onto expression stack, and enter binary state using current token (which,
14148 if it is a name not beginning with D, E, or Q, will certainly result
14149 in an error, but that's not for this routine to deal with). */
14150
14151 static ffelexHandler
14152 ffeexpr_token_number_real_ (ffelexToken t)
14153 {
14154 char d;
14155 const char *p;
14156
14157 if (((ffelex_token_type (t) != FFELEX_typeNAME)
14158 && (ffelex_token_type (t) != FFELEX_typeNAMES))
14159 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
14160 'D', 'd')
14161 || ffesrc_char_match_init (d, 'E', 'e')
14162 || ffesrc_char_match_init (d, 'Q', 'q')))
14163 && ffeexpr_isdigits_ (++p)))
14164 {
14165 #if 0
14166 /* This code has been removed because it seems inconsistent to
14167 produce a diagnostic in this case, but not all of the other
14168 ones that look for an exponent and cannot recognize one. */
14169 if (((ffelex_token_type (t) == FFELEX_typeNAME)
14170 || (ffelex_token_type (t) == FFELEX_typeNAMES))
14171 && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
14172 {
14173 char bad[2];
14174
14175 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14176 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
14177 ffelex_token_where_column (ffeexpr_tokens_[0]));
14178 bad[0] = *(p - 1);
14179 bad[1] = '\0';
14180 ffebad_string (bad);
14181 ffebad_finish ();
14182 }
14183 #endif
14184 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14185 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14186 ffeexpr_tokens_[2], NULL, NULL, NULL);
14187
14188 ffelex_token_kill (ffeexpr_tokens_[0]);
14189 ffelex_token_kill (ffeexpr_tokens_[1]);
14190 ffelex_token_kill (ffeexpr_tokens_[2]);
14191 return (ffelexHandler) ffeexpr_token_binary_ (t);
14192 }
14193
14194 /* Just exponent character by itself? In which case, PLUS or MINUS must
14195 surely be next, followed by a NUMBER token. */
14196
14197 if (*p == '\0')
14198 {
14199 ffeexpr_tokens_[3] = ffelex_token_use (t);
14200 return (ffelexHandler) ffeexpr_token_number_real_exp_;
14201 }
14202
14203 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14204 ffeexpr_tokens_[2], t, NULL, NULL);
14205
14206 ffelex_token_kill (ffeexpr_tokens_[0]);
14207 ffelex_token_kill (ffeexpr_tokens_[1]);
14208 ffelex_token_kill (ffeexpr_tokens_[2]);
14209 return (ffelexHandler) ffeexpr_token_binary_;
14210 }
14211
14212 /* ffeexpr_token_num_per_exp_sign_ -- Rhs NUMBER PERIOD NAME(D,E,Q) PLUS/MINUS
14213
14214 Return a pointer to this function to the lexer (ffelex), which will
14215 invoke it for the next token.
14216
14217 Make sure token is a NUMBER, make a real constant out of all we have and
14218 push it onto the expression stack. Else issue diagnostic and pretend
14219 exponent field was a zero. */
14220
14221 static ffelexHandler
14222 ffeexpr_token_num_per_exp_sign_ (ffelexToken t)
14223 {
14224 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14225 {
14226 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14227 {
14228 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
14229 ffelex_token_where_column (ffeexpr_tokens_[2]));
14230 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14231 ffebad_finish ();
14232 }
14233
14234 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14235 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14236 NULL, NULL, NULL, NULL);
14237
14238 ffelex_token_kill (ffeexpr_tokens_[0]);
14239 ffelex_token_kill (ffeexpr_tokens_[1]);
14240 ffelex_token_kill (ffeexpr_tokens_[2]);
14241 ffelex_token_kill (ffeexpr_tokens_[3]);
14242 return (ffelexHandler) ffeexpr_token_binary_ (t);
14243 }
14244
14245 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0],
14246 ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL,
14247 ffeexpr_tokens_[2], ffeexpr_tokens_[3], t);
14248
14249 ffelex_token_kill (ffeexpr_tokens_[0]);
14250 ffelex_token_kill (ffeexpr_tokens_[1]);
14251 ffelex_token_kill (ffeexpr_tokens_[2]);
14252 ffelex_token_kill (ffeexpr_tokens_[3]);
14253 return (ffelexHandler) ffeexpr_token_binary_;
14254 }
14255
14256 /* ffeexpr_token_number_real_exp_ -- Rhs NUMBER PERIOD NUMBER NAME(D, E, or Q)
14257
14258 Return a pointer to this function to the lexer (ffelex), which will
14259 invoke it for the next token.
14260
14261 Ensures this token is PLUS or MINUS, preserves it, goes to final state
14262 for real number (exponent digits). Else issues diagnostic, assumes a
14263 zero exponent field for number, passes token on to binary state as if
14264 previous token had been "E0" instead of "E", for example. */
14265
14266 static ffelexHandler
14267 ffeexpr_token_number_real_exp_ (ffelexToken t)
14268 {
14269 if ((ffelex_token_type (t) != FFELEX_typePLUS)
14270 && (ffelex_token_type (t) != FFELEX_typeMINUS))
14271 {
14272 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14273 {
14274 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
14275 ffelex_token_where_column (ffeexpr_tokens_[3]));
14276 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14277 ffebad_finish ();
14278 }
14279
14280 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14281 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14282 ffeexpr_tokens_[2], NULL, NULL, NULL);
14283
14284 ffelex_token_kill (ffeexpr_tokens_[0]);
14285 ffelex_token_kill (ffeexpr_tokens_[1]);
14286 ffelex_token_kill (ffeexpr_tokens_[2]);
14287 ffelex_token_kill (ffeexpr_tokens_[3]);
14288 return (ffelexHandler) ffeexpr_token_binary_ (t);
14289 }
14290
14291 ffeexpr_tokens_[4] = ffelex_token_use (t);
14292 return (ffelexHandler) ffeexpr_token_num_real_exp_sn_;
14293 }
14294
14295 /* ffeexpr_token_num_real_exp_sn_ -- Rhs NUMBER PERIOD NUMBER NAME(D,E,Q)
14296 PLUS/MINUS
14297
14298 Return a pointer to this function to the lexer (ffelex), which will
14299 invoke it for the next token.
14300
14301 Make sure token is a NUMBER, make a real constant out of all we have and
14302 push it onto the expression stack. Else issue diagnostic and pretend
14303 exponent field was a zero. */
14304
14305 static ffelexHandler
14306 ffeexpr_token_num_real_exp_sn_ (ffelexToken t)
14307 {
14308 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14309 {
14310 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14311 {
14312 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
14313 ffelex_token_where_column (ffeexpr_tokens_[3]));
14314 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14315 ffebad_finish ();
14316 }
14317
14318 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14319 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14320 ffeexpr_tokens_[2], NULL, NULL, NULL);
14321
14322 ffelex_token_kill (ffeexpr_tokens_[0]);
14323 ffelex_token_kill (ffeexpr_tokens_[1]);
14324 ffelex_token_kill (ffeexpr_tokens_[2]);
14325 ffelex_token_kill (ffeexpr_tokens_[3]);
14326 ffelex_token_kill (ffeexpr_tokens_[4]);
14327 return (ffelexHandler) ffeexpr_token_binary_ (t);
14328 }
14329
14330 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[3])[0],
14331 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14332 ffeexpr_tokens_[2], ffeexpr_tokens_[3],
14333 ffeexpr_tokens_[4], t);
14334
14335 ffelex_token_kill (ffeexpr_tokens_[0]);
14336 ffelex_token_kill (ffeexpr_tokens_[1]);
14337 ffelex_token_kill (ffeexpr_tokens_[2]);
14338 ffelex_token_kill (ffeexpr_tokens_[3]);
14339 ffelex_token_kill (ffeexpr_tokens_[4]);
14340 return (ffelexHandler) ffeexpr_token_binary_;
14341 }
14342
14343 /* ffeexpr_token_binary_ -- Handle binary operator possibility
14344
14345 Return a pointer to this function to the lexer (ffelex), which will
14346 invoke it for the next token.
14347
14348 The possibility of a binary operator is handled here, meaning the previous
14349 token was an operand. */
14350
14351 static ffelexHandler
14352 ffeexpr_token_binary_ (ffelexToken t)
14353 {
14354 ffeexprExpr_ e;
14355
14356 if (!ffeexpr_stack_->is_rhs)
14357 return (ffelexHandler) ffeexpr_finished_ (t); /* For now. */
14358
14359 switch (ffelex_token_type (t))
14360 {
14361 case FFELEX_typePLUS:
14362 e = ffeexpr_expr_new_ ();
14363 e->type = FFEEXPR_exprtypeBINARY_;
14364 e->token = ffelex_token_use (t);
14365 e->u.operator.op = FFEEXPR_operatorADD_;
14366 e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
14367 e->u.operator.as = FFEEXPR_operatorassociativityADD_;
14368 ffeexpr_exprstack_push_binary_ (e);
14369 return (ffelexHandler) ffeexpr_token_rhs_;
14370
14371 case FFELEX_typeMINUS:
14372 e = ffeexpr_expr_new_ ();
14373 e->type = FFEEXPR_exprtypeBINARY_;
14374 e->token = ffelex_token_use (t);
14375 e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
14376 e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
14377 e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
14378 ffeexpr_exprstack_push_binary_ (e);
14379 return (ffelexHandler) ffeexpr_token_rhs_;
14380
14381 case FFELEX_typeASTERISK:
14382 switch (ffeexpr_stack_->context)
14383 {
14384 case FFEEXPR_contextDATA:
14385 return (ffelexHandler) ffeexpr_finished_ (t);
14386
14387 default:
14388 break;
14389 }
14390 e = ffeexpr_expr_new_ ();
14391 e->type = FFEEXPR_exprtypeBINARY_;
14392 e->token = ffelex_token_use (t);
14393 e->u.operator.op = FFEEXPR_operatorMULTIPLY_;
14394 e->u.operator.prec = FFEEXPR_operatorprecedenceMULTIPLY_;
14395 e->u.operator.as = FFEEXPR_operatorassociativityMULTIPLY_;
14396 ffeexpr_exprstack_push_binary_ (e);
14397 return (ffelexHandler) ffeexpr_token_rhs_;
14398
14399 case FFELEX_typeSLASH:
14400 switch (ffeexpr_stack_->context)
14401 {
14402 case FFEEXPR_contextDATA:
14403 return (ffelexHandler) ffeexpr_finished_ (t);
14404
14405 default:
14406 break;
14407 }
14408 e = ffeexpr_expr_new_ ();
14409 e->type = FFEEXPR_exprtypeBINARY_;
14410 e->token = ffelex_token_use (t);
14411 e->u.operator.op = FFEEXPR_operatorDIVIDE_;
14412 e->u.operator.prec = FFEEXPR_operatorprecedenceDIVIDE_;
14413 e->u.operator.as = FFEEXPR_operatorassociativityDIVIDE_;
14414 ffeexpr_exprstack_push_binary_ (e);
14415 return (ffelexHandler) ffeexpr_token_rhs_;
14416
14417 case FFELEX_typePOWER:
14418 e = ffeexpr_expr_new_ ();
14419 e->type = FFEEXPR_exprtypeBINARY_;
14420 e->token = ffelex_token_use (t);
14421 e->u.operator.op = FFEEXPR_operatorPOWER_;
14422 e->u.operator.prec = FFEEXPR_operatorprecedencePOWER_;
14423 e->u.operator.as = FFEEXPR_operatorassociativityPOWER_;
14424 ffeexpr_exprstack_push_binary_ (e);
14425 return (ffelexHandler) ffeexpr_token_rhs_;
14426
14427 case FFELEX_typeCONCAT:
14428 e = ffeexpr_expr_new_ ();
14429 e->type = FFEEXPR_exprtypeBINARY_;
14430 e->token = ffelex_token_use (t);
14431 e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
14432 e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
14433 e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
14434 ffeexpr_exprstack_push_binary_ (e);
14435 return (ffelexHandler) ffeexpr_token_rhs_;
14436
14437 case FFELEX_typeOPEN_ANGLE:
14438 switch (ffeexpr_stack_->context)
14439 {
14440 case FFEEXPR_contextFORMAT:
14441 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14442 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14443 ffebad_finish ();
14444 break;
14445
14446 default:
14447 break;
14448 }
14449 e = ffeexpr_expr_new_ ();
14450 e->type = FFEEXPR_exprtypeBINARY_;
14451 e->token = ffelex_token_use (t);
14452 e->u.operator.op = FFEEXPR_operatorLT_;
14453 e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
14454 e->u.operator.as = FFEEXPR_operatorassociativityLT_;
14455 ffeexpr_exprstack_push_binary_ (e);
14456 return (ffelexHandler) ffeexpr_token_rhs_;
14457
14458 case FFELEX_typeCLOSE_ANGLE:
14459 switch (ffeexpr_stack_->context)
14460 {
14461 case FFEEXPR_contextFORMAT:
14462 return ffeexpr_finished_ (t);
14463
14464 default:
14465 break;
14466 }
14467 e = ffeexpr_expr_new_ ();
14468 e->type = FFEEXPR_exprtypeBINARY_;
14469 e->token = ffelex_token_use (t);
14470 e->u.operator.op = FFEEXPR_operatorGT_;
14471 e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
14472 e->u.operator.as = FFEEXPR_operatorassociativityGT_;
14473 ffeexpr_exprstack_push_binary_ (e);
14474 return (ffelexHandler) ffeexpr_token_rhs_;
14475
14476 case FFELEX_typeREL_EQ:
14477 switch (ffeexpr_stack_->context)
14478 {
14479 case FFEEXPR_contextFORMAT:
14480 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14481 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14482 ffebad_finish ();
14483 break;
14484
14485 default:
14486 break;
14487 }
14488 e = ffeexpr_expr_new_ ();
14489 e->type = FFEEXPR_exprtypeBINARY_;
14490 e->token = ffelex_token_use (t);
14491 e->u.operator.op = FFEEXPR_operatorEQ_;
14492 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
14493 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
14494 ffeexpr_exprstack_push_binary_ (e);
14495 return (ffelexHandler) ffeexpr_token_rhs_;
14496
14497 case FFELEX_typeREL_NE:
14498 switch (ffeexpr_stack_->context)
14499 {
14500 case FFEEXPR_contextFORMAT:
14501 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14502 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14503 ffebad_finish ();
14504 break;
14505
14506 default:
14507 break;
14508 }
14509 e = ffeexpr_expr_new_ ();
14510 e->type = FFEEXPR_exprtypeBINARY_;
14511 e->token = ffelex_token_use (t);
14512 e->u.operator.op = FFEEXPR_operatorNE_;
14513 e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
14514 e->u.operator.as = FFEEXPR_operatorassociativityNE_;
14515 ffeexpr_exprstack_push_binary_ (e);
14516 return (ffelexHandler) ffeexpr_token_rhs_;
14517
14518 case FFELEX_typeREL_LE:
14519 switch (ffeexpr_stack_->context)
14520 {
14521 case FFEEXPR_contextFORMAT:
14522 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14523 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14524 ffebad_finish ();
14525 break;
14526
14527 default:
14528 break;
14529 }
14530 e = ffeexpr_expr_new_ ();
14531 e->type = FFEEXPR_exprtypeBINARY_;
14532 e->token = ffelex_token_use (t);
14533 e->u.operator.op = FFEEXPR_operatorLE_;
14534 e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
14535 e->u.operator.as = FFEEXPR_operatorassociativityLE_;
14536 ffeexpr_exprstack_push_binary_ (e);
14537 return (ffelexHandler) ffeexpr_token_rhs_;
14538
14539 case FFELEX_typeREL_GE:
14540 switch (ffeexpr_stack_->context)
14541 {
14542 case FFEEXPR_contextFORMAT:
14543 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14544 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14545 ffebad_finish ();
14546 break;
14547
14548 default:
14549 break;
14550 }
14551 e = ffeexpr_expr_new_ ();
14552 e->type = FFEEXPR_exprtypeBINARY_;
14553 e->token = ffelex_token_use (t);
14554 e->u.operator.op = FFEEXPR_operatorGE_;
14555 e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
14556 e->u.operator.as = FFEEXPR_operatorassociativityGE_;
14557 ffeexpr_exprstack_push_binary_ (e);
14558 return (ffelexHandler) ffeexpr_token_rhs_;
14559
14560 case FFELEX_typePERIOD:
14561 ffeexpr_tokens_[0] = ffelex_token_use (t);
14562 return (ffelexHandler) ffeexpr_token_binary_period_;
14563
14564 #if 0
14565 case FFELEX_typeOPEN_PAREN:
14566 case FFELEX_typeCLOSE_PAREN:
14567 case FFELEX_typeEQUALS:
14568 case FFELEX_typePOINTS:
14569 case FFELEX_typeCOMMA:
14570 case FFELEX_typeCOLON:
14571 case FFELEX_typeEOS:
14572 case FFELEX_typeSEMICOLON:
14573 case FFELEX_typeNAME:
14574 case FFELEX_typeNAMES:
14575 #endif
14576 default:
14577 return (ffelexHandler) ffeexpr_finished_ (t);
14578 }
14579 }
14580
14581 /* ffeexpr_token_binary_period_ -- Binary PERIOD
14582
14583 Return a pointer to this function to the lexer (ffelex), which will
14584 invoke it for the next token.
14585
14586 Handle a period detected at binary (expecting binary op or end) state.
14587 Must begin a dot-dot name, of which .NOT., .TRUE., and .FALSE. are not
14588 valid. */
14589
14590 static ffelexHandler
14591 ffeexpr_token_binary_period_ (ffelexToken t)
14592 {
14593 ffeexprExpr_ operand;
14594
14595 switch (ffelex_token_type (t))
14596 {
14597 case FFELEX_typeNAME:
14598 case FFELEX_typeNAMES:
14599 ffeexpr_current_dotdot_ = ffestr_other (t);
14600 switch (ffeexpr_current_dotdot_)
14601 {
14602 case FFESTR_otherTRUE:
14603 case FFESTR_otherFALSE:
14604 case FFESTR_otherNOT:
14605 if (ffest_ffebad_start (FFEBAD_MISSING_BINARY_OPERATOR))
14606 {
14607 operand = ffeexpr_stack_->exprstack;
14608 assert (operand != NULL);
14609 assert (operand->type == FFEEXPR_exprtypeOPERAND_);
14610 ffebad_here (0, ffelex_token_where_line (operand->token), ffelex_token_where_column (operand->token));
14611 ffebad_here (1, ffelex_token_where_line (t),
14612 ffelex_token_where_column (t));
14613 ffebad_finish ();
14614 }
14615 ffelex_token_kill (ffeexpr_tokens_[0]);
14616 return (ffelexHandler) ffeexpr_token_binary_sw_per_;
14617
14618 default:
14619 ffeexpr_tokens_[1] = ffelex_token_use (t);
14620 return (ffelexHandler) ffeexpr_token_binary_end_per_;
14621 }
14622 break; /* Nothing really reaches here. */
14623
14624 default:
14625 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
14626 {
14627 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14628 ffelex_token_where_column (ffeexpr_tokens_[0]));
14629 ffebad_finish ();
14630 }
14631 ffelex_token_kill (ffeexpr_tokens_[0]);
14632 return (ffelexHandler) ffeexpr_token_binary_ (t);
14633 }
14634 }
14635
14636 /* ffeexpr_token_binary_end_per_ -- Binary PERIOD NAME(not NOT, TRUE, or FALSE)
14637
14638 Return a pointer to this function to the lexer (ffelex), which will
14639 invoke it for the next token.
14640
14641 Expecting a period to close a dot-dot at binary (binary op
14642 or operator) state. If period isn't found, issue a diagnostic but
14643 pretend we saw one. ffeexpr_current_dotdot_ must already contained the
14644 dotdot representation of the name in between the two PERIOD tokens. */
14645
14646 static ffelexHandler
14647 ffeexpr_token_binary_end_per_ (ffelexToken t)
14648 {
14649 ffeexprExpr_ e;
14650
14651 e = ffeexpr_expr_new_ ();
14652 e->type = FFEEXPR_exprtypeBINARY_;
14653 e->token = ffeexpr_tokens_[0];
14654
14655 switch (ffeexpr_current_dotdot_)
14656 {
14657 case FFESTR_otherAND:
14658 e->u.operator.op = FFEEXPR_operatorAND_;
14659 e->u.operator.prec = FFEEXPR_operatorprecedenceAND_;
14660 e->u.operator.as = FFEEXPR_operatorassociativityAND_;
14661 break;
14662
14663 case FFESTR_otherOR:
14664 e->u.operator.op = FFEEXPR_operatorOR_;
14665 e->u.operator.prec = FFEEXPR_operatorprecedenceOR_;
14666 e->u.operator.as = FFEEXPR_operatorassociativityOR_;
14667 break;
14668
14669 case FFESTR_otherXOR:
14670 e->u.operator.op = FFEEXPR_operatorXOR_;
14671 e->u.operator.prec = FFEEXPR_operatorprecedenceXOR_;
14672 e->u.operator.as = FFEEXPR_operatorassociativityXOR_;
14673 break;
14674
14675 case FFESTR_otherEQV:
14676 e->u.operator.op = FFEEXPR_operatorEQV_;
14677 e->u.operator.prec = FFEEXPR_operatorprecedenceEQV_;
14678 e->u.operator.as = FFEEXPR_operatorassociativityEQV_;
14679 break;
14680
14681 case FFESTR_otherNEQV:
14682 e->u.operator.op = FFEEXPR_operatorNEQV_;
14683 e->u.operator.prec = FFEEXPR_operatorprecedenceNEQV_;
14684 e->u.operator.as = FFEEXPR_operatorassociativityNEQV_;
14685 break;
14686
14687 case FFESTR_otherLT:
14688 e->u.operator.op = FFEEXPR_operatorLT_;
14689 e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
14690 e->u.operator.as = FFEEXPR_operatorassociativityLT_;
14691 break;
14692
14693 case FFESTR_otherLE:
14694 e->u.operator.op = FFEEXPR_operatorLE_;
14695 e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
14696 e->u.operator.as = FFEEXPR_operatorassociativityLE_;
14697 break;
14698
14699 case FFESTR_otherEQ:
14700 e->u.operator.op = FFEEXPR_operatorEQ_;
14701 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
14702 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
14703 break;
14704
14705 case FFESTR_otherNE:
14706 e->u.operator.op = FFEEXPR_operatorNE_;
14707 e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
14708 e->u.operator.as = FFEEXPR_operatorassociativityNE_;
14709 break;
14710
14711 case FFESTR_otherGT:
14712 e->u.operator.op = FFEEXPR_operatorGT_;
14713 e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
14714 e->u.operator.as = FFEEXPR_operatorassociativityGT_;
14715 break;
14716
14717 case FFESTR_otherGE:
14718 e->u.operator.op = FFEEXPR_operatorGE_;
14719 e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
14720 e->u.operator.as = FFEEXPR_operatorassociativityGE_;
14721 break;
14722
14723 default:
14724 if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT))
14725 {
14726 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14727 ffelex_token_where_column (ffeexpr_tokens_[0]));
14728 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
14729 ffebad_finish ();
14730 }
14731 e->u.operator.op = FFEEXPR_operatorEQ_;
14732 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
14733 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
14734 break;
14735 }
14736
14737 ffeexpr_exprstack_push_binary_ (e);
14738
14739 if (ffelex_token_type (t) != FFELEX_typePERIOD)
14740 {
14741 if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
14742 {
14743 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14744 ffelex_token_where_column (ffeexpr_tokens_[0]));
14745 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14746 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
14747 ffebad_finish ();
14748 }
14749 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */
14750 return (ffelexHandler) ffeexpr_token_rhs_ (t);
14751 }
14752
14753 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */
14754 return (ffelexHandler) ffeexpr_token_rhs_;
14755 }
14756
14757 /* ffeexpr_token_binary_sw_per_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
14758
14759 Return a pointer to this function to the lexer (ffelex), which will
14760 invoke it for the next token.
14761
14762 A diagnostic has already been issued; just swallow a period if there is
14763 one, then continue with ffeexpr_token_binary_. */
14764
14765 static ffelexHandler
14766 ffeexpr_token_binary_sw_per_ (ffelexToken t)
14767 {
14768 if (ffelex_token_type (t) != FFELEX_typePERIOD)
14769 return (ffelexHandler) ffeexpr_token_binary_ (t);
14770
14771 return (ffelexHandler) ffeexpr_token_binary_;
14772 }
14773
14774 /* ffeexpr_token_quote_ -- Rhs QUOTE
14775
14776 Return a pointer to this function to the lexer (ffelex), which will
14777 invoke it for the next token.
14778
14779 Expecting a NUMBER that we'll treat as an octal integer. */
14780
14781 static ffelexHandler
14782 ffeexpr_token_quote_ (ffelexToken t)
14783 {
14784 ffeexprExpr_ e;
14785 ffebld anyexpr;
14786
14787 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14788 {
14789 if (ffest_ffebad_start (FFEBAD_QUOTE_MISSES_DIGITS))
14790 {
14791 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14792 ffelex_token_where_column (ffeexpr_tokens_[0]));
14793 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14794 ffebad_finish ();
14795 }
14796 ffelex_token_kill (ffeexpr_tokens_[0]);
14797 return (ffelexHandler) ffeexpr_token_rhs_ (t);
14798 }
14799
14800 /* This is kind of a kludge to prevent any whining about magical numbers
14801 that start out as these octal integers, so "20000000000 (on a 32-bit
14802 2's-complement machine) by itself won't produce an error. */
14803
14804 anyexpr = ffebld_new_any ();
14805 ffebld_set_info (anyexpr, ffeinfo_new_any ());
14806
14807 e = ffeexpr_expr_new_ ();
14808 e->type = FFEEXPR_exprtypeOPERAND_;
14809 e->token = ffeexpr_tokens_[0];
14810 e->u.operand = ffebld_new_conter_with_orig
14811 (ffebld_constant_new_integeroctal (t), anyexpr);
14812 ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER,
14813 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY,
14814 FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14815 ffeexpr_exprstack_push_operand_ (e);
14816 return (ffelexHandler) ffeexpr_token_binary_;
14817 }
14818
14819 /* ffeexpr_token_apostrophe_ -- Rhs APOSTROPHE
14820
14821 Return a pointer to this function to the lexer (ffelex), which will
14822 invoke it for the next token.
14823
14824 Handle an open-apostrophe, which begins either a character ('char-const'),
14825 typeless octal ('octal-const'O), or typeless hexadecimal ('hex-const'Z or
14826 'hex-const'X) constant. */
14827
14828 static ffelexHandler
14829 ffeexpr_token_apostrophe_ (ffelexToken t)
14830 {
14831 assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
14832 if (ffe_is_pedantic_not_90 () && (ffelex_token_length (t) == 0))
14833 {
14834 ffebad_start (FFEBAD_NULL_CHAR_CONST);
14835 ffebad_here (0, ffelex_token_where_line (t),
14836 ffelex_token_where_column (t));
14837 ffebad_finish ();
14838 }
14839 ffeexpr_tokens_[1] = ffelex_token_use (t);
14840 return (ffelexHandler) ffeexpr_token_apos_char_;
14841 }
14842
14843 /* ffeexpr_token_apos_char_ -- Rhs APOSTROPHE CHARACTER
14844
14845 Return a pointer to this function to the lexer (ffelex), which will
14846 invoke it for the next token.
14847
14848 Close-apostrophe is implicit; if this token is NAME, it is a possible
14849 typeless-constant radix specifier. */
14850
14851 static ffelexHandler
14852 ffeexpr_token_apos_char_ (ffelexToken t)
14853 {
14854 ffeexprExpr_ e;
14855 ffeinfo ni;
14856 char c;
14857 ffetargetCharacterSize size;
14858
14859 if ((ffelex_token_type (t) == FFELEX_typeNAME)
14860 || (ffelex_token_type (t) == FFELEX_typeNAMES))
14861 {
14862 if ((ffelex_token_length (t) == 1)
14863 && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]), 'B',
14864 'b')
14865 || ffesrc_char_match_init (c, 'O', 'o')
14866 || ffesrc_char_match_init (c, 'X', 'x')
14867 || ffesrc_char_match_init (c, 'Z', 'z')))
14868 {
14869 e = ffeexpr_expr_new_ ();
14870 e->type = FFEEXPR_exprtypeOPERAND_;
14871 e->token = ffeexpr_tokens_[0];
14872 switch (c)
14873 {
14874 case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
14875 e->u.operand = ffebld_new_conter
14876 (ffebld_constant_new_typeless_bv (ffeexpr_tokens_[1]));
14877 size = ffetarget_size_typeless_binary (ffeexpr_tokens_[1]);
14878 break;
14879
14880 case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
14881 e->u.operand = ffebld_new_conter
14882 (ffebld_constant_new_typeless_ov (ffeexpr_tokens_[1]));
14883 size = ffetarget_size_typeless_octal (ffeexpr_tokens_[1]);
14884 break;
14885
14886 case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
14887 e->u.operand = ffebld_new_conter
14888 (ffebld_constant_new_typeless_hxv (ffeexpr_tokens_[1]));
14889 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
14890 break;
14891
14892 case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
14893 e->u.operand = ffebld_new_conter
14894 (ffebld_constant_new_typeless_hzv (ffeexpr_tokens_[1]));
14895 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
14896 break;
14897
14898 default:
14899 no_match: /* :::::::::::::::::::: */
14900 assert ("not BOXZ!" == NULL);
14901 size = 0;
14902 break;
14903 }
14904 ffebld_set_info (e->u.operand,
14905 ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
14906 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
14907 ffeexpr_exprstack_push_operand_ (e);
14908 ffelex_token_kill (ffeexpr_tokens_[1]);
14909 return (ffelexHandler) ffeexpr_token_binary_;
14910 }
14911 }
14912 e = ffeexpr_expr_new_ ();
14913 e->type = FFEEXPR_exprtypeOPERAND_;
14914 e->token = ffeexpr_tokens_[0];
14915 e->u.operand = ffebld_new_conter (ffebld_constant_new_characterdefault
14916 (ffeexpr_tokens_[1]));
14917 ni = ffeinfo_new (FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTERDEFAULT,
14918 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14919 ffelex_token_length (ffeexpr_tokens_[1]));
14920 ffebld_set_info (e->u.operand, ni);
14921 ffelex_token_kill (ffeexpr_tokens_[1]);
14922 ffeexpr_exprstack_push_operand_ (e);
14923 if ((ffelex_token_type (t) == FFELEX_typeNAME)
14924 || (ffelex_token_type (t) == FFELEX_typeNAMES))
14925 {
14926 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14927 {
14928 ffebad_string (ffelex_token_text (t));
14929 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14930 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
14931 ffelex_token_where_column (ffeexpr_tokens_[0]));
14932 ffebad_finish ();
14933 }
14934 e = ffeexpr_expr_new_ ();
14935 e->type = FFEEXPR_exprtypeBINARY_;
14936 e->token = ffelex_token_use (t);
14937 e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
14938 e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
14939 e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
14940 ffeexpr_exprstack_push_binary_ (e);
14941 return (ffelexHandler) ffeexpr_token_rhs_ (t);
14942 }
14943 ffeexpr_is_substr_ok_ = !ffe_is_pedantic_not_90 (); /* Allow "'hello'(3:5)". */
14944 return (ffelexHandler) ffeexpr_token_substrp_ (t);
14945 }
14946
14947 /* ffeexpr_token_name_lhs_ -- Lhs NAME
14948
14949 Return a pointer to this function to the lexer (ffelex), which will
14950 invoke it for the next token.
14951
14952 Handle a name followed by open-paren, period (RECORD.MEMBER), percent
14953 (RECORD%MEMBER), or nothing at all. */
14954
14955 static ffelexHandler
14956 ffeexpr_token_name_lhs_ (ffelexToken t)
14957 {
14958 ffeexprExpr_ e;
14959 ffeexprParenType_ paren_type;
14960 ffesymbol s;
14961 ffebld expr;
14962 ffeinfo info;
14963
14964 switch (ffelex_token_type (t))
14965 {
14966 case FFELEX_typeOPEN_PAREN:
14967 switch (ffeexpr_stack_->context)
14968 {
14969 case FFEEXPR_contextASSIGN:
14970 case FFEEXPR_contextAGOTO:
14971 case FFEEXPR_contextFILEUNIT_DF:
14972 goto just_name; /* :::::::::::::::::::: */
14973
14974 default:
14975 break;
14976 }
14977 e = ffeexpr_expr_new_ ();
14978 e->type = FFEEXPR_exprtypeOPERAND_;
14979 e->token = ffelex_token_use (ffeexpr_tokens_[0]);
14980 s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], FALSE,
14981 &paren_type);
14982
14983 switch (ffesymbol_where (s))
14984 {
14985 case FFEINFO_whereLOCAL:
14986 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14987 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recursion. */
14988 break;
14989
14990 case FFEINFO_whereINTRINSIC:
14991 case FFEINFO_whereGLOBAL:
14992 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
14993 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */
14994 break;
14995
14996 case FFEINFO_whereCOMMON:
14997 case FFEINFO_whereDUMMY:
14998 case FFEINFO_whereRESULT:
14999 break;
15000
15001 case FFEINFO_whereNONE:
15002 case FFEINFO_whereANY:
15003 break;
15004
15005 default:
15006 ffesymbol_error (s, ffeexpr_tokens_[0]);
15007 break;
15008 }
15009
15010 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15011 {
15012 e->u.operand = ffebld_new_any ();
15013 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15014 }
15015 else
15016 {
15017 e->u.operand = ffebld_new_symter (s,
15018 ffesymbol_generic (s),
15019 ffesymbol_specific (s),
15020 ffesymbol_implementation (s));
15021 ffebld_set_info (e->u.operand, ffesymbol_info (s));
15022 }
15023 ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */
15024 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
15025 switch (paren_type)
15026 {
15027 case FFEEXPR_parentypeSUBROUTINE_:
15028 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15029 return
15030 (ffelexHandler)
15031 ffeexpr_rhs (ffeexpr_stack_->pool,
15032 FFEEXPR_contextACTUALARG_,
15033 ffeexpr_token_arguments_);
15034
15035 case FFEEXPR_parentypeARRAY_:
15036 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15037 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
15038 ffeexpr_stack_->rank = 0;
15039 ffeexpr_stack_->constant = TRUE;
15040 ffeexpr_stack_->immediate = TRUE;
15041 switch (ffeexpr_stack_->context)
15042 {
15043 case FFEEXPR_contextDATAIMPDOITEM_:
15044 return
15045 (ffelexHandler)
15046 ffeexpr_rhs (ffeexpr_stack_->pool,
15047 FFEEXPR_contextDATAIMPDOINDEX_,
15048 ffeexpr_token_elements_);
15049
15050 case FFEEXPR_contextEQUIVALENCE:
15051 return
15052 (ffelexHandler)
15053 ffeexpr_rhs (ffeexpr_stack_->pool,
15054 FFEEXPR_contextEQVINDEX_,
15055 ffeexpr_token_elements_);
15056
15057 default:
15058 return
15059 (ffelexHandler)
15060 ffeexpr_rhs (ffeexpr_stack_->pool,
15061 FFEEXPR_contextINDEX_,
15062 ffeexpr_token_elements_);
15063 }
15064
15065 case FFEEXPR_parentypeSUBSTRING_:
15066 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
15067 ffeexpr_tokens_[0]);
15068 return
15069 (ffelexHandler)
15070 ffeexpr_rhs (ffeexpr_stack_->pool,
15071 FFEEXPR_contextINDEX_,
15072 ffeexpr_token_substring_);
15073
15074 case FFEEXPR_parentypeEQUIVALENCE_:
15075 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15076 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
15077 ffeexpr_stack_->rank = 0;
15078 ffeexpr_stack_->constant = TRUE;
15079 ffeexpr_stack_->immediate = TRUE;
15080 return
15081 (ffelexHandler)
15082 ffeexpr_rhs (ffeexpr_stack_->pool,
15083 FFEEXPR_contextEQVINDEX_,
15084 ffeexpr_token_equivalence_);
15085
15086 case FFEEXPR_parentypeFUNCTION_: /* Invalid case. */
15087 case FFEEXPR_parentypeFUNSUBSTR_: /* Invalid case. */
15088 ffesymbol_error (s, ffeexpr_tokens_[0]);
15089 /* Fall through. */
15090 case FFEEXPR_parentypeANY_:
15091 e->u.operand = ffebld_new_any ();
15092 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15093 return
15094 (ffelexHandler)
15095 ffeexpr_rhs (ffeexpr_stack_->pool,
15096 FFEEXPR_contextACTUALARG_,
15097 ffeexpr_token_anything_);
15098
15099 default:
15100 assert ("bad paren type" == NULL);
15101 break;
15102 }
15103
15104 case FFELEX_typeEQUALS: /* As in "VAR=". */
15105 switch (ffeexpr_stack_->context)
15106 {
15107 case FFEEXPR_contextIMPDOITEM_: /* within
15108 "(,VAR=start,end[,incr])". */
15109 case FFEEXPR_contextIMPDOITEMDF_:
15110 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
15111 break;
15112
15113 case FFEEXPR_contextDATAIMPDOITEM_:
15114 ffeexpr_stack_->context = FFEEXPR_contextDATAIMPDOCTRL_;
15115 break;
15116
15117 default:
15118 break;
15119 }
15120 break;
15121
15122 #if 0
15123 case FFELEX_typePERIOD:
15124 case FFELEX_typePERCENT:
15125 assert ("FOO%, FOO. not yet supported!~~" == NULL);
15126 break;
15127 #endif
15128
15129 default:
15130 break;
15131 }
15132
15133 just_name: /* :::::::::::::::::::: */
15134 e = ffeexpr_expr_new_ ();
15135 e->type = FFEEXPR_exprtypeOPERAND_;
15136 e->token = ffeexpr_tokens_[0];
15137 s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0],
15138 (ffeexpr_stack_->context
15139 == FFEEXPR_contextSUBROUTINEREF));
15140
15141 switch (ffesymbol_where (s))
15142 {
15143 case FFEINFO_whereCONSTANT:
15144 if ((ffeexpr_stack_->context != FFEEXPR_contextPARAMETER)
15145 || (ffesymbol_kind (s) != FFEINFO_kindENTITY))
15146 ffesymbol_error (s, ffeexpr_tokens_[0]);
15147 break;
15148
15149 case FFEINFO_whereIMMEDIATE:
15150 if ((ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOCTRL_)
15151 && (ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOINDEX_))
15152 ffesymbol_error (s, ffeexpr_tokens_[0]);
15153 break;
15154
15155 case FFEINFO_whereLOCAL:
15156 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
15157 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recurse!. */
15158 break;
15159
15160 case FFEINFO_whereINTRINSIC:
15161 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
15162 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */
15163 break;
15164
15165 default:
15166 break;
15167 }
15168
15169 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15170 {
15171 expr = ffebld_new_any ();
15172 info = ffeinfo_new_any ();
15173 ffebld_set_info (expr, info);
15174 }
15175 else
15176 {
15177 expr = ffebld_new_symter (s,
15178 ffesymbol_generic (s),
15179 ffesymbol_specific (s),
15180 ffesymbol_implementation (s));
15181 info = ffesymbol_info (s);
15182 ffebld_set_info (expr, info);
15183 if (ffesymbol_is_doiter (s))
15184 {
15185 ffebad_start (FFEBAD_DOITER);
15186 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15187 ffelex_token_where_column (ffeexpr_tokens_[0]));
15188 ffest_ffebad_here_doiter (1, s);
15189 ffebad_string (ffesymbol_text (s));
15190 ffebad_finish ();
15191 }
15192 expr = ffeexpr_collapse_symter (expr, ffeexpr_tokens_[0]);
15193 }
15194
15195 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
15196 {
15197 if (ffebld_op (expr) == FFEBLD_opANY)
15198 {
15199 expr = ffebld_new_any ();
15200 ffebld_set_info (expr, ffeinfo_new_any ());
15201 }
15202 else
15203 {
15204 expr = ffebld_new_subrref (expr, NULL); /* No argument list. */
15205 if (ffesymbol_generic (s) != FFEINTRIN_genNONE)
15206 ffeintrin_fulfill_generic (&expr, &info, e->token);
15207 else if (ffesymbol_specific (s) != FFEINTRIN_specNONE)
15208 ffeintrin_fulfill_specific (&expr, &info, NULL, e->token);
15209 else
15210 ffeexpr_fulfill_call_ (&expr, e->token);
15211
15212 if (ffebld_op (expr) != FFEBLD_opANY)
15213 ffebld_set_info (expr,
15214 ffeinfo_new (ffeinfo_basictype (info),
15215 ffeinfo_kindtype (info),
15216 0,
15217 FFEINFO_kindENTITY,
15218 FFEINFO_whereFLEETING,
15219 ffeinfo_size (info)));
15220 else
15221 ffebld_set_info (expr, ffeinfo_new_any ());
15222 }
15223 }
15224
15225 e->u.operand = expr;
15226 ffeexpr_exprstack_push_operand_ (e);
15227 return (ffelexHandler) ffeexpr_finished_ (t);
15228 }
15229
15230 /* ffeexpr_token_name_arg_ -- Rhs NAME
15231
15232 Return a pointer to this function to the lexer (ffelex), which will
15233 invoke it for the next token.
15234
15235 Handle first token in an actual-arg (or possible actual-arg) context
15236 being a NAME, and use second token to refine the context. */
15237
15238 static ffelexHandler
15239 ffeexpr_token_name_arg_ (ffelexToken t)
15240 {
15241 switch (ffelex_token_type (t))
15242 {
15243 case FFELEX_typeCLOSE_PAREN:
15244 case FFELEX_typeCOMMA:
15245 switch (ffeexpr_stack_->context)
15246 {
15247 case FFEEXPR_contextINDEXORACTUALARG_:
15248 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
15249 break;
15250
15251 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15252 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
15253 break;
15254
15255 default:
15256 break;
15257 }
15258 break;
15259
15260 default:
15261 switch (ffeexpr_stack_->context)
15262 {
15263 case FFEEXPR_contextACTUALARG_:
15264 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
15265 break;
15266
15267 case FFEEXPR_contextINDEXORACTUALARG_:
15268 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
15269 break;
15270
15271 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15272 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
15273 break;
15274
15275 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15276 ffeexpr_stack_->context
15277 = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
15278 break;
15279
15280 default:
15281 assert ("bad context in _name_arg_" == NULL);
15282 break;
15283 }
15284 break;
15285 }
15286
15287 return (ffelexHandler) ffeexpr_token_name_rhs_ (t);
15288 }
15289
15290 /* ffeexpr_token_name_rhs_ -- Rhs NAME
15291
15292 Return a pointer to this function to the lexer (ffelex), which will
15293 invoke it for the next token.
15294
15295 Handle a name followed by open-paren, apostrophe (O'octal-const',
15296 Z'hex-const', or X'hex-const'), period (RECORD.MEMBER).
15297
15298 26-Nov-91 JCB 1.2
15299 When followed by apostrophe or quote, set lex hexnum flag on so
15300 [0-9] as first char of next token seen as starting a potentially
15301 hex number (NAME).
15302 04-Oct-91 JCB 1.1
15303 In case of intrinsic, decorate its SYMTER with the type info for
15304 the specific intrinsic. */
15305
15306 static ffelexHandler
15307 ffeexpr_token_name_rhs_ (ffelexToken t)
15308 {
15309 ffeexprExpr_ e;
15310 ffeexprParenType_ paren_type;
15311 ffesymbol s;
15312 bool sfdef;
15313
15314 switch (ffelex_token_type (t))
15315 {
15316 case FFELEX_typeQUOTE:
15317 case FFELEX_typeAPOSTROPHE:
15318 ffeexpr_tokens_[1] = ffelex_token_use (t);
15319 ffelex_set_hexnum (TRUE);
15320 return (ffelexHandler) ffeexpr_token_name_apos_;
15321
15322 case FFELEX_typeOPEN_PAREN:
15323 e = ffeexpr_expr_new_ ();
15324 e->type = FFEEXPR_exprtypeOPERAND_;
15325 e->token = ffelex_token_use (ffeexpr_tokens_[0]);
15326 s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], TRUE,
15327 &paren_type);
15328 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15329 e->u.operand = ffebld_new_any ();
15330 else
15331 e->u.operand = ffebld_new_symter (s, ffesymbol_generic (s),
15332 ffesymbol_specific (s),
15333 ffesymbol_implementation (s));
15334 ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */
15335 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
15336 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15337 {
15338 case FFEEXPR_contextSFUNCDEF:
15339 case FFEEXPR_contextSFUNCDEFINDEX_:
15340 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15341 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15342 sfdef = TRUE;
15343 break;
15344
15345 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15346 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15347 assert ("weird context!" == NULL);
15348 sfdef = FALSE;
15349 break;
15350
15351 default:
15352 sfdef = FALSE;
15353 break;
15354 }
15355 switch (paren_type)
15356 {
15357 case FFEEXPR_parentypeFUNCTION_:
15358 ffebld_set_info (e->u.operand, ffesymbol_info (s));
15359 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15360 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
15361 { /* A statement function. */
15362 ffeexpr_stack_->num_args
15363 = ffebld_list_length
15364 (ffeexpr_stack_->next_dummy
15365 = ffesymbol_dummyargs (s));
15366 ffeexpr_stack_->tokens[1] = NULL; /* !=NULL when > num_args. */
15367 }
15368 else if ((ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
15369 && !ffe_is_pedantic_not_90 ()
15370 && ((ffesymbol_implementation (s)
15371 == FFEINTRIN_impICHAR)
15372 || (ffesymbol_implementation (s)
15373 == FFEINTRIN_impIACHAR)
15374 || (ffesymbol_implementation (s)
15375 == FFEINTRIN_impLEN)))
15376 { /* Allow arbitrary concatenations. */
15377 return
15378 (ffelexHandler)
15379 ffeexpr_rhs (ffeexpr_stack_->pool,
15380 sfdef
15381 ? FFEEXPR_contextSFUNCDEF
15382 : FFEEXPR_contextLET,
15383 ffeexpr_token_arguments_);
15384 }
15385 return
15386 (ffelexHandler)
15387 ffeexpr_rhs (ffeexpr_stack_->pool,
15388 sfdef
15389 ? FFEEXPR_contextSFUNCDEFACTUALARG_
15390 : FFEEXPR_contextACTUALARG_,
15391 ffeexpr_token_arguments_);
15392
15393 case FFEEXPR_parentypeARRAY_:
15394 ffebld_set_info (e->u.operand,
15395 ffesymbol_info (ffebld_symter (e->u.operand)));
15396 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15397 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
15398 ffeexpr_stack_->rank = 0;
15399 ffeexpr_stack_->constant = TRUE;
15400 ffeexpr_stack_->immediate = TRUE;
15401 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
15402 sfdef
15403 ? FFEEXPR_contextSFUNCDEFINDEX_
15404 : FFEEXPR_contextINDEX_,
15405 ffeexpr_token_elements_);
15406
15407 case FFEEXPR_parentypeSUBSTRING_:
15408 ffebld_set_info (e->u.operand,
15409 ffesymbol_info (ffebld_symter (e->u.operand)));
15410 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
15411 ffeexpr_tokens_[0]);
15412 return
15413 (ffelexHandler)
15414 ffeexpr_rhs (ffeexpr_stack_->pool,
15415 sfdef
15416 ? FFEEXPR_contextSFUNCDEFINDEX_
15417 : FFEEXPR_contextINDEX_,
15418 ffeexpr_token_substring_);
15419
15420 case FFEEXPR_parentypeFUNSUBSTR_:
15421 return
15422 (ffelexHandler)
15423 ffeexpr_rhs (ffeexpr_stack_->pool,
15424 sfdef
15425 ? FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
15426 : FFEEXPR_contextINDEXORACTUALARG_,
15427 ffeexpr_token_funsubstr_);
15428
15429 case FFEEXPR_parentypeANY_:
15430 ffebld_set_info (e->u.operand, ffesymbol_info (s));
15431 return
15432 (ffelexHandler)
15433 ffeexpr_rhs (ffeexpr_stack_->pool,
15434 sfdef
15435 ? FFEEXPR_contextSFUNCDEFACTUALARG_
15436 : FFEEXPR_contextACTUALARG_,
15437 ffeexpr_token_anything_);
15438
15439 default:
15440 assert ("bad paren type" == NULL);
15441 break;
15442 }
15443
15444 case FFELEX_typeEQUALS: /* As in "VAR=". */
15445 switch (ffeexpr_stack_->context)
15446 {
15447 case FFEEXPR_contextIMPDOITEM_: /* "(,VAR=start,end[,incr])". */
15448 case FFEEXPR_contextIMPDOITEMDF_:
15449 ffeexpr_stack_->is_rhs = FALSE; /* Really an lhs construct. */
15450 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
15451 break;
15452
15453 default:
15454 break;
15455 }
15456 break;
15457
15458 #if 0
15459 case FFELEX_typePERIOD:
15460 case FFELEX_typePERCENT:
15461 ~~Support these two someday, though not required
15462 assert ("FOO%, FOO. not yet supported!~~" == NULL);
15463 break;
15464 #endif
15465
15466 default:
15467 break;
15468 }
15469
15470 switch (ffeexpr_stack_->context)
15471 {
15472 case FFEEXPR_contextINDEXORACTUALARG_:
15473 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15474 assert ("strange context" == NULL);
15475 break;
15476
15477 default:
15478 break;
15479 }
15480
15481 e = ffeexpr_expr_new_ ();
15482 e->type = FFEEXPR_exprtypeOPERAND_;
15483 e->token = ffeexpr_tokens_[0];
15484 s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0], FALSE);
15485 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15486 {
15487 e->u.operand = ffebld_new_any ();
15488 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15489 }
15490 else
15491 {
15492 e->u.operand = ffebld_new_symter (s, FFEINTRIN_genNONE,
15493 ffesymbol_specific (s),
15494 ffesymbol_implementation (s));
15495 if (ffesymbol_specific (s) == FFEINTRIN_specNONE)
15496 ffebld_set_info (e->u.operand, ffeinfo_use (ffesymbol_info (s)));
15497 else
15498 { /* Decorate the SYMTER with the actual type
15499 of the intrinsic. */
15500 ffebld_set_info (e->u.operand, ffeinfo_new
15501 (ffeintrin_basictype (ffesymbol_specific (s)),
15502 ffeintrin_kindtype (ffesymbol_specific (s)),
15503 0,
15504 ffesymbol_kind (s),
15505 ffesymbol_where (s),
15506 FFETARGET_charactersizeNONE));
15507 }
15508 if (ffesymbol_is_doiter (s))
15509 ffebld_symter_set_is_doiter (e->u.operand, TRUE);
15510 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
15511 ffeexpr_tokens_[0]);
15512 }
15513 ffeexpr_exprstack_push_operand_ (e);
15514 return (ffelexHandler) ffeexpr_token_binary_ (t);
15515 }
15516
15517 /* ffeexpr_token_name_apos_ -- Rhs NAME APOSTROPHE
15518
15519 Return a pointer to this function to the lexer (ffelex), which will
15520 invoke it for the next token.
15521
15522 Expecting a NAME token, analyze the previous NAME token to see what kind,
15523 if any, typeless constant we've got.
15524
15525 01-Sep-90 JCB 1.1
15526 Expect a NAME instead of CHARACTER in this situation. */
15527
15528 static ffelexHandler
15529 ffeexpr_token_name_apos_ (ffelexToken t)
15530 {
15531 ffeexprExpr_ e;
15532
15533 ffelex_set_hexnum (FALSE);
15534
15535 switch (ffelex_token_type (t))
15536 {
15537 case FFELEX_typeNAME:
15538 ffeexpr_tokens_[2] = ffelex_token_use (t);
15539 return (ffelexHandler) ffeexpr_token_name_apos_name_;
15540
15541 default:
15542 break;
15543 }
15544
15545 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
15546 {
15547 ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
15548 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15549 ffelex_token_where_column (ffeexpr_tokens_[0]));
15550 ffebad_here (1, ffelex_token_where_line (t),
15551 ffelex_token_where_column (t));
15552 ffebad_finish ();
15553 }
15554
15555 ffelex_token_kill (ffeexpr_tokens_[1]);
15556
15557 e = ffeexpr_expr_new_ ();
15558 e->type = FFEEXPR_exprtypeOPERAND_;
15559 e->u.operand = ffebld_new_any ();
15560 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15561 e->token = ffeexpr_tokens_[0];
15562 ffeexpr_exprstack_push_operand_ (e);
15563
15564 return (ffelexHandler) ffeexpr_token_binary_ (t);
15565 }
15566
15567 /* ffeexpr_token_name_apos_name_ -- Rhs NAME APOSTROPHE NAME
15568
15569 Return a pointer to this function to the lexer (ffelex), which will
15570 invoke it for the next token.
15571
15572 Expecting an APOSTROPHE token, analyze the previous NAME token to see
15573 what kind, if any, typeless constant we've got. */
15574
15575 static ffelexHandler
15576 ffeexpr_token_name_apos_name_ (ffelexToken t)
15577 {
15578 ffeexprExpr_ e;
15579 char c;
15580
15581 e = ffeexpr_expr_new_ ();
15582 e->type = FFEEXPR_exprtypeOPERAND_;
15583 e->token = ffeexpr_tokens_[0];
15584
15585 if ((ffelex_token_type (t) == ffelex_token_type (ffeexpr_tokens_[1]))
15586 && (ffelex_token_length (ffeexpr_tokens_[0]) == 1)
15587 && (ffesrc_char_match_init ((c = ffelex_token_text (ffeexpr_tokens_[0])[0]),
15588 'B', 'b')
15589 || ffesrc_char_match_init (c, 'O', 'o')
15590 || ffesrc_char_match_init (c, 'X', 'x')
15591 || ffesrc_char_match_init (c, 'Z', 'z')))
15592 {
15593 ffetargetCharacterSize size;
15594
15595 if (!ffe_is_typeless_boz ()) {
15596
15597 switch (c)
15598 {
15599 case FFESRC_CASE_MATCH_INIT ('B', 'b', imatch_b, no_imatch):
15600 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerbinary
15601 (ffeexpr_tokens_[2]));
15602 break;
15603
15604 case FFESRC_CASE_MATCH_INIT ('O', 'o', imatch_o, no_imatch):
15605 e->u.operand = ffebld_new_conter (ffebld_constant_new_integeroctal
15606 (ffeexpr_tokens_[2]));
15607 break;
15608
15609 case FFESRC_CASE_MATCH_INIT ('X', 'x', imatch_x, no_imatch):
15610 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
15611 (ffeexpr_tokens_[2]));
15612 break;
15613
15614 case FFESRC_CASE_MATCH_INIT ('Z', 'z', imatch_z, no_imatch):
15615 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
15616 (ffeexpr_tokens_[2]));
15617 break;
15618
15619 default:
15620 no_imatch: /* :::::::::::::::::::: */
15621 assert ("not BOXZ!" == NULL);
15622 abort ();
15623 }
15624
15625 ffebld_set_info (e->u.operand,
15626 ffeinfo_new (FFEINFO_basictypeINTEGER,
15627 FFEINFO_kindtypeINTEGERDEFAULT, 0,
15628 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
15629 FFETARGET_charactersizeNONE));
15630 ffeexpr_exprstack_push_operand_ (e);
15631 ffelex_token_kill (ffeexpr_tokens_[1]);
15632 ffelex_token_kill (ffeexpr_tokens_[2]);
15633 return (ffelexHandler) ffeexpr_token_binary_;
15634 }
15635
15636 switch (c)
15637 {
15638 case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
15639 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_bm
15640 (ffeexpr_tokens_[2]));
15641 size = ffetarget_size_typeless_binary (ffeexpr_tokens_[2]);
15642 break;
15643
15644 case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
15645 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_om
15646 (ffeexpr_tokens_[2]));
15647 size = ffetarget_size_typeless_octal (ffeexpr_tokens_[2]);
15648 break;
15649
15650 case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
15651 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hxm
15652 (ffeexpr_tokens_[2]));
15653 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15654 break;
15655
15656 case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
15657 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
15658 (ffeexpr_tokens_[2]));
15659 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15660 break;
15661
15662 default:
15663 no_match: /* :::::::::::::::::::: */
15664 assert ("not BOXZ!" == NULL);
15665 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
15666 (ffeexpr_tokens_[2]));
15667 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15668 break;
15669 }
15670 ffebld_set_info (e->u.operand,
15671 ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
15672 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
15673 ffeexpr_exprstack_push_operand_ (e);
15674 ffelex_token_kill (ffeexpr_tokens_[1]);
15675 ffelex_token_kill (ffeexpr_tokens_[2]);
15676 return (ffelexHandler) ffeexpr_token_binary_;
15677 }
15678
15679 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
15680 {
15681 ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
15682 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15683 ffelex_token_where_column (ffeexpr_tokens_[0]));
15684 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
15685 ffebad_finish ();
15686 }
15687
15688 ffelex_token_kill (ffeexpr_tokens_[1]);
15689 ffelex_token_kill (ffeexpr_tokens_[2]);
15690
15691 e->type = FFEEXPR_exprtypeOPERAND_;
15692 e->u.operand = ffebld_new_any ();
15693 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15694 e->token = ffeexpr_tokens_[0];
15695 ffeexpr_exprstack_push_operand_ (e);
15696
15697 switch (ffelex_token_type (t))
15698 {
15699 case FFELEX_typeAPOSTROPHE:
15700 case FFELEX_typeQUOTE:
15701 return (ffelexHandler) ffeexpr_token_binary_;
15702
15703 default:
15704 return (ffelexHandler) ffeexpr_token_binary_ (t);
15705 }
15706 }
15707
15708 /* ffeexpr_token_percent_ -- Rhs PERCENT
15709
15710 Handle a percent sign possibly followed by "LOC". If followed instead
15711 by "VAL", "REF", or "DESCR", issue an error message and substitute
15712 "LOC". If followed by something else, treat the percent sign as a
15713 spurious incorrect token and reprocess the token via _rhs_. */
15714
15715 static ffelexHandler
15716 ffeexpr_token_percent_ (ffelexToken t)
15717 {
15718 switch (ffelex_token_type (t))
15719 {
15720 case FFELEX_typeNAME:
15721 case FFELEX_typeNAMES:
15722 ffeexpr_stack_->percent = ffeexpr_percent_ (t);
15723 ffeexpr_tokens_[1] = ffelex_token_use (t);
15724 return (ffelexHandler) ffeexpr_token_percent_name_;
15725
15726 default:
15727 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
15728 {
15729 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15730 ffelex_token_where_column (ffeexpr_tokens_[0]));
15731 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
15732 ffelex_token_where_column (ffeexpr_stack_->first_token));
15733 ffebad_finish ();
15734 }
15735 ffelex_token_kill (ffeexpr_tokens_[0]);
15736 return (ffelexHandler) ffeexpr_token_rhs_ (t);
15737 }
15738 }
15739
15740 /* ffeexpr_token_percent_name_ -- Rhs PERCENT NAME
15741
15742 Make sure the token is OPEN_PAREN and prepare for the one-item list of
15743 LHS expressions. Else display an error message. */
15744
15745 static ffelexHandler
15746 ffeexpr_token_percent_name_ (ffelexToken t)
15747 {
15748 ffelexHandler nexthandler;
15749
15750 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
15751 {
15752 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
15753 {
15754 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15755 ffelex_token_where_column (ffeexpr_tokens_[0]));
15756 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
15757 ffelex_token_where_column (ffeexpr_stack_->first_token));
15758 ffebad_finish ();
15759 }
15760 ffelex_token_kill (ffeexpr_tokens_[0]);
15761 nexthandler = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_tokens_[1]);
15762 ffelex_token_kill (ffeexpr_tokens_[1]);
15763 return (ffelexHandler) (*nexthandler) (t);
15764 }
15765
15766 switch (ffeexpr_stack_->percent)
15767 {
15768 default:
15769 if (ffest_ffebad_start (FFEBAD_INVALID_PERCENT))
15770 {
15771 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15772 ffelex_token_where_column (ffeexpr_tokens_[0]));
15773 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
15774 ffebad_finish ();
15775 }
15776 ffeexpr_stack_->percent = FFEEXPR_percentLOC_;
15777 /* Fall through. */
15778 case FFEEXPR_percentLOC_:
15779 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
15780 ffelex_token_kill (ffeexpr_tokens_[1]);
15781 ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
15782 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
15783 FFEEXPR_contextLOC_,
15784 ffeexpr_cb_end_loc_);
15785 }
15786 }
15787
15788 /* ffeexpr_make_float_const_ -- Make a floating-point constant
15789
15790 See prototype.
15791
15792 Pass 'E', 'D', or 'Q' for exponent letter. */
15793
15794 static void
15795 ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
15796 ffelexToken decimal, ffelexToken fraction,
15797 ffelexToken exponent, ffelexToken exponent_sign,
15798 ffelexToken exponent_digits)
15799 {
15800 ffeexprExpr_ e;
15801
15802 e = ffeexpr_expr_new_ ();
15803 e->type = FFEEXPR_exprtypeOPERAND_;
15804 if (integer != NULL)
15805 e->token = ffelex_token_use (integer);
15806 else
15807 {
15808 assert (decimal != NULL);
15809 e->token = ffelex_token_use (decimal);
15810 }
15811
15812 switch (exp_letter)
15813 {
15814 #if !FFETARGET_okREALQUAD
15815 case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
15816 if (ffebad_start (FFEBAD_QUAD_UNSUPPORTED))
15817 {
15818 ffebad_here (0, ffelex_token_where_line (e->token),
15819 ffelex_token_where_column (e->token));
15820 ffebad_finish ();
15821 }
15822 goto match_d; /* The FFESRC_CASE_* macros don't
15823 allow fall-through! */
15824 #endif
15825
15826 case FFESRC_CASE_MATCH_INIT ('D', 'd', match_d, no_match):
15827 e->u.operand = ffebld_new_conter (ffebld_constant_new_realdouble
15828 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15829 ffebld_set_info (e->u.operand,
15830 ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
15831 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15832 break;
15833
15834 case FFESRC_CASE_MATCH_INIT ('E', 'e', match_e, no_match):
15835 e->u.operand = ffebld_new_conter (ffebld_constant_new_realdefault
15836 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15837 ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeREAL,
15838 FFEINFO_kindtypeREALDEFAULT, 0, FFEINFO_kindENTITY,
15839 FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15840 break;
15841
15842 #if FFETARGET_okREALQUAD
15843 case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
15844 e->u.operand = ffebld_new_conter (ffebld_constant_new_realquad
15845 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15846 ffebld_set_info (e->u.operand,
15847 ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALQUAD,
15848 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15849 break;
15850 #endif
15851
15852 case 'I': /* Make an integer. */
15853 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
15854 (ffeexpr_tokens_[0]));
15855 ffebld_set_info (e->u.operand,
15856 ffeinfo_new (FFEINFO_basictypeINTEGER,
15857 FFEINFO_kindtypeINTEGERDEFAULT, 0,
15858 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
15859 FFETARGET_charactersizeNONE));
15860 break;
15861
15862 default:
15863 no_match: /* :::::::::::::::::::: */
15864 assert ("Lost the exponent letter!" == NULL);
15865 }
15866
15867 ffeexpr_exprstack_push_operand_ (e);
15868 }
15869
15870 /* Just like ffesymbol_declare_local, except performs any implicit info
15871 assignment necessary. */
15872
15873 static ffesymbol
15874 ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin)
15875 {
15876 ffesymbol s;
15877 ffeinfoKind k;
15878 bool bad;
15879
15880 s = ffesymbol_declare_local (t, maybe_intrin);
15881
15882 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15883 /* Special-case these since they can involve a different concept
15884 of "state" (in the stmtfunc name space). */
15885 {
15886 case FFEEXPR_contextDATAIMPDOINDEX_:
15887 case FFEEXPR_contextDATAIMPDOCTRL_:
15888 if (ffeexpr_context_outer_ (ffeexpr_stack_)
15889 == FFEEXPR_contextDATAIMPDOINDEX_)
15890 s = ffeexpr_sym_impdoitem_ (s, t);
15891 else
15892 if (ffeexpr_stack_->is_rhs)
15893 s = ffeexpr_sym_impdoitem_ (s, t);
15894 else
15895 s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
15896 bad = (ffesymbol_kind (s) != FFEINFO_kindENTITY)
15897 || ((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
15898 && (ffesymbol_where (s) != FFEINFO_whereIMMEDIATE));
15899 if (bad && (ffesymbol_kind (s) != FFEINFO_kindANY))
15900 ffesymbol_error (s, t);
15901 return s;
15902
15903 default:
15904 break;
15905 }
15906
15907 switch ((ffesymbol_sfdummyparent (s) == NULL)
15908 ? ffesymbol_state (s)
15909 : FFESYMBOL_stateUNDERSTOOD)
15910 {
15911 case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr
15912 context. */
15913 if (!ffest_seen_first_exec ())
15914 goto seen; /* :::::::::::::::::::: */
15915 /* Fall through. */
15916 case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */
15917 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15918 {
15919 case FFEEXPR_contextSUBROUTINEREF:
15920 s = ffeexpr_sym_lhs_call_ (s, t);
15921 break;
15922
15923 case FFEEXPR_contextFILEEXTFUNC:
15924 s = ffeexpr_sym_lhs_extfunc_ (s, t);
15925 break;
15926
15927 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15928 s = ffecom_sym_exec_transition (s);
15929 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15930 goto understood; /* :::::::::::::::::::: */
15931 /* Fall through. */
15932 case FFEEXPR_contextACTUALARG_:
15933 s = ffeexpr_sym_rhs_actualarg_ (s, t);
15934 break;
15935
15936 case FFEEXPR_contextDATA:
15937 if (ffeexpr_stack_->is_rhs)
15938 s = ffeexpr_sym_rhs_let_ (s, t);
15939 else
15940 s = ffeexpr_sym_lhs_data_ (s, t);
15941 break;
15942
15943 case FFEEXPR_contextDATAIMPDOITEM_:
15944 s = ffeexpr_sym_lhs_data_ (s, t);
15945 break;
15946
15947 case FFEEXPR_contextSFUNCDEF:
15948 case FFEEXPR_contextSFUNCDEFINDEX_:
15949 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15950 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15951 s = ffecom_sym_exec_transition (s);
15952 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15953 goto understood; /* :::::::::::::::::::: */
15954 /* Fall through. */
15955 case FFEEXPR_contextLET:
15956 case FFEEXPR_contextPAREN_:
15957 case FFEEXPR_contextACTUALARGEXPR_:
15958 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15959 case FFEEXPR_contextASSIGN:
15960 case FFEEXPR_contextIOLIST:
15961 case FFEEXPR_contextIOLISTDF:
15962 case FFEEXPR_contextDO:
15963 case FFEEXPR_contextDOWHILE:
15964 case FFEEXPR_contextAGOTO:
15965 case FFEEXPR_contextCGOTO:
15966 case FFEEXPR_contextIF:
15967 case FFEEXPR_contextARITHIF:
15968 case FFEEXPR_contextFORMAT:
15969 case FFEEXPR_contextSTOP:
15970 case FFEEXPR_contextRETURN:
15971 case FFEEXPR_contextSELECTCASE:
15972 case FFEEXPR_contextCASE:
15973 case FFEEXPR_contextFILEASSOC:
15974 case FFEEXPR_contextFILEINT:
15975 case FFEEXPR_contextFILEDFINT:
15976 case FFEEXPR_contextFILELOG:
15977 case FFEEXPR_contextFILENUM:
15978 case FFEEXPR_contextFILENUMAMBIG:
15979 case FFEEXPR_contextFILECHAR:
15980 case FFEEXPR_contextFILENUMCHAR:
15981 case FFEEXPR_contextFILEDFCHAR:
15982 case FFEEXPR_contextFILEKEY:
15983 case FFEEXPR_contextFILEUNIT:
15984 case FFEEXPR_contextFILEUNIT_DF:
15985 case FFEEXPR_contextFILEUNITAMBIG:
15986 case FFEEXPR_contextFILEFORMAT:
15987 case FFEEXPR_contextFILENAMELIST:
15988 case FFEEXPR_contextFILEVXTCODE:
15989 case FFEEXPR_contextINDEX_:
15990 case FFEEXPR_contextIMPDOITEM_:
15991 case FFEEXPR_contextIMPDOITEMDF_:
15992 case FFEEXPR_contextIMPDOCTRL_:
15993 case FFEEXPR_contextLOC_:
15994 if (ffeexpr_stack_->is_rhs)
15995 s = ffeexpr_sym_rhs_let_ (s, t);
15996 else
15997 s = ffeexpr_sym_lhs_let_ (s, t);
15998 break;
15999
16000 case FFEEXPR_contextCHARACTERSIZE:
16001 case FFEEXPR_contextEQUIVALENCE:
16002 case FFEEXPR_contextINCLUDE:
16003 case FFEEXPR_contextPARAMETER:
16004 case FFEEXPR_contextDIMLIST:
16005 case FFEEXPR_contextDIMLISTCOMMON:
16006 case FFEEXPR_contextKINDTYPE:
16007 case FFEEXPR_contextINITVAL:
16008 case FFEEXPR_contextEQVINDEX_:
16009 break; /* Will turn into errors below. */
16010
16011 default:
16012 ffesymbol_error (s, t);
16013 break;
16014 }
16015 /* Fall through. */
16016 case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */
16017 understood: /* :::::::::::::::::::: */
16018 k = ffesymbol_kind (s);
16019 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16020 {
16021 case FFEEXPR_contextSUBROUTINEREF:
16022 bad = ((k != FFEINFO_kindSUBROUTINE)
16023 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
16024 || (k != FFEINFO_kindNONE)));
16025 break;
16026
16027 case FFEEXPR_contextFILEEXTFUNC:
16028 bad = (k != FFEINFO_kindFUNCTION)
16029 || (ffesymbol_where (s) != FFEINFO_whereGLOBAL);
16030 break;
16031
16032 case FFEEXPR_contextSFUNCDEFACTUALARG_:
16033 case FFEEXPR_contextACTUALARG_:
16034 switch (k)
16035 {
16036 case FFEINFO_kindENTITY:
16037 bad = FALSE;
16038 break;
16039
16040 case FFEINFO_kindFUNCTION:
16041 case FFEINFO_kindSUBROUTINE:
16042 bad
16043 = ((ffesymbol_where (s) != FFEINFO_whereGLOBAL)
16044 && (ffesymbol_where (s) != FFEINFO_whereDUMMY)
16045 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
16046 || !ffeintrin_is_actualarg (ffesymbol_specific (s))));
16047 break;
16048
16049 case FFEINFO_kindNONE:
16050 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
16051 {
16052 bad = !(ffeintrin_is_actualarg (ffesymbol_specific (s)));
16053 break;
16054 }
16055
16056 /* If state is UNDERSTOOD here, it's CHAR*(*) or attrsANY,
16057 and in the former case, attrsTYPE is set, so we
16058 see this as an error as we should, since CHAR*(*)
16059 cannot be actually referenced in a main/block data
16060 program unit. */
16061
16062 if ((ffesymbol_attrs (s) & (FFESYMBOL_attrsANY
16063 | FFESYMBOL_attrsEXTERNAL
16064 | FFESYMBOL_attrsTYPE))
16065 == FFESYMBOL_attrsEXTERNAL)
16066 bad = FALSE;
16067 else
16068 bad = TRUE;
16069 break;
16070
16071 default:
16072 bad = TRUE;
16073 break;
16074 }
16075 break;
16076
16077 case FFEEXPR_contextDATA:
16078 if (ffeexpr_stack_->is_rhs)
16079 bad = (k != FFEINFO_kindENTITY)
16080 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16081 else
16082 bad = (k != FFEINFO_kindENTITY)
16083 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
16084 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
16085 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
16086 break;
16087
16088 case FFEEXPR_contextDATAIMPDOITEM_:
16089 bad = TRUE; /* Unadorned item never valid. */
16090 break;
16091
16092 case FFEEXPR_contextSFUNCDEF:
16093 case FFEEXPR_contextSFUNCDEFINDEX_:
16094 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16095 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16096 case FFEEXPR_contextLET:
16097 case FFEEXPR_contextPAREN_:
16098 case FFEEXPR_contextACTUALARGEXPR_:
16099 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16100 case FFEEXPR_contextASSIGN:
16101 case FFEEXPR_contextIOLIST:
16102 case FFEEXPR_contextIOLISTDF:
16103 case FFEEXPR_contextDO:
16104 case FFEEXPR_contextDOWHILE:
16105 case FFEEXPR_contextAGOTO:
16106 case FFEEXPR_contextCGOTO:
16107 case FFEEXPR_contextIF:
16108 case FFEEXPR_contextARITHIF:
16109 case FFEEXPR_contextFORMAT:
16110 case FFEEXPR_contextSTOP:
16111 case FFEEXPR_contextRETURN:
16112 case FFEEXPR_contextSELECTCASE:
16113 case FFEEXPR_contextCASE:
16114 case FFEEXPR_contextFILEASSOC:
16115 case FFEEXPR_contextFILEINT:
16116 case FFEEXPR_contextFILEDFINT:
16117 case FFEEXPR_contextFILELOG:
16118 case FFEEXPR_contextFILENUM:
16119 case FFEEXPR_contextFILENUMAMBIG:
16120 case FFEEXPR_contextFILECHAR:
16121 case FFEEXPR_contextFILENUMCHAR:
16122 case FFEEXPR_contextFILEDFCHAR:
16123 case FFEEXPR_contextFILEKEY:
16124 case FFEEXPR_contextFILEUNIT:
16125 case FFEEXPR_contextFILEUNIT_DF:
16126 case FFEEXPR_contextFILEUNITAMBIG:
16127 case FFEEXPR_contextFILEFORMAT:
16128 case FFEEXPR_contextFILENAMELIST:
16129 case FFEEXPR_contextFILEVXTCODE:
16130 case FFEEXPR_contextINDEX_:
16131 case FFEEXPR_contextIMPDOITEM_:
16132 case FFEEXPR_contextIMPDOITEMDF_:
16133 case FFEEXPR_contextIMPDOCTRL_:
16134 case FFEEXPR_contextLOC_:
16135 bad = (k != FFEINFO_kindENTITY); /* This catches "SUBROUTINE
16136 X(A);EXTERNAL A;CALL
16137 Y(A);B=A", for example. */
16138 break;
16139
16140 case FFEEXPR_contextCHARACTERSIZE:
16141 case FFEEXPR_contextEQUIVALENCE:
16142 case FFEEXPR_contextPARAMETER:
16143 case FFEEXPR_contextDIMLIST:
16144 case FFEEXPR_contextDIMLISTCOMMON:
16145 case FFEEXPR_contextKINDTYPE:
16146 case FFEEXPR_contextINITVAL:
16147 case FFEEXPR_contextEQVINDEX_:
16148 bad = (k != FFEINFO_kindENTITY)
16149 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16150 break;
16151
16152 case FFEEXPR_contextINCLUDE:
16153 bad = TRUE;
16154 break;
16155
16156 default:
16157 bad = TRUE;
16158 break;
16159 }
16160 if (bad && (k != FFEINFO_kindANY))
16161 ffesymbol_error (s, t);
16162 return s;
16163
16164 case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */
16165 seen: /* :::::::::::::::::::: */
16166 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16167 {
16168 case FFEEXPR_contextPARAMETER:
16169 if (ffeexpr_stack_->is_rhs)
16170 ffesymbol_error (s, t);
16171 else
16172 s = ffeexpr_sym_lhs_parameter_ (s, t);
16173 break;
16174
16175 case FFEEXPR_contextDATA:
16176 s = ffecom_sym_exec_transition (s);
16177 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16178 goto understood; /* :::::::::::::::::::: */
16179 if (ffeexpr_stack_->is_rhs)
16180 ffesymbol_error (s, t);
16181 else
16182 s = ffeexpr_sym_lhs_data_ (s, t);
16183 goto understood; /* :::::::::::::::::::: */
16184
16185 case FFEEXPR_contextDATAIMPDOITEM_:
16186 s = ffecom_sym_exec_transition (s);
16187 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16188 goto understood; /* :::::::::::::::::::: */
16189 s = ffeexpr_sym_lhs_data_ (s, t);
16190 goto understood; /* :::::::::::::::::::: */
16191
16192 case FFEEXPR_contextEQUIVALENCE:
16193 s = ffeexpr_sym_lhs_equivalence_ (s, t);
16194 break;
16195
16196 case FFEEXPR_contextDIMLIST:
16197 s = ffeexpr_sym_rhs_dimlist_ (s, t);
16198 break;
16199
16200 case FFEEXPR_contextCHARACTERSIZE:
16201 case FFEEXPR_contextKINDTYPE:
16202 case FFEEXPR_contextDIMLISTCOMMON:
16203 case FFEEXPR_contextINITVAL:
16204 case FFEEXPR_contextEQVINDEX_:
16205 ffesymbol_error (s, t);
16206 break;
16207
16208 case FFEEXPR_contextINCLUDE:
16209 ffesymbol_error (s, t);
16210 break;
16211
16212 case FFEEXPR_contextACTUALARG_: /* E.g. I in REAL A(Y(I)). */
16213 case FFEEXPR_contextSFUNCDEFACTUALARG_:
16214 s = ffecom_sym_exec_transition (s);
16215 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16216 goto understood; /* :::::::::::::::::::: */
16217 s = ffeexpr_sym_rhs_actualarg_ (s, t);
16218 goto understood; /* :::::::::::::::::::: */
16219
16220 case FFEEXPR_contextINDEX_:
16221 case FFEEXPR_contextACTUALARGEXPR_:
16222 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16223 case FFEEXPR_contextSFUNCDEF:
16224 case FFEEXPR_contextSFUNCDEFINDEX_:
16225 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16226 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16227 assert (ffeexpr_stack_->is_rhs);
16228 s = ffecom_sym_exec_transition (s);
16229 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16230 goto understood; /* :::::::::::::::::::: */
16231 s = ffeexpr_sym_rhs_let_ (s, t);
16232 goto understood; /* :::::::::::::::::::: */
16233
16234 default:
16235 ffesymbol_error (s, t);
16236 break;
16237 }
16238 return s;
16239
16240 default:
16241 assert ("bad symbol state" == NULL);
16242 return NULL;
16243 break;
16244 }
16245 }
16246
16247 /* Have FOO in DATA (XYZ(FOO),...)/.../ or DATA (...,XYZ=FOO,BAR,BLETCH).
16248 Could be found via the "statement-function" name space (in which case
16249 it should become an iterator) or the local name space (in which case
16250 it should be either a named constant, or a variable that will have an
16251 sfunc name space sibling that should become an iterator). */
16252
16253 static ffesymbol
16254 ffeexpr_sym_impdoitem_ (ffesymbol sp, ffelexToken t)
16255 {
16256 ffesymbol s;
16257 ffesymbolAttrs sa;
16258 ffesymbolAttrs na;
16259 ffesymbolState ss;
16260 ffesymbolState ns;
16261 ffeinfoKind kind;
16262 ffeinfoWhere where;
16263
16264 ss = ffesymbol_state (sp);
16265
16266 if (ffesymbol_sfdummyparent (sp) != NULL)
16267 { /* Have symbol in sfunc name space. */
16268 switch (ss)
16269 {
16270 case FFESYMBOL_stateNONE: /* Used as iterator already. */
16271 if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
16272 ffesymbol_error (sp, t); /* Can't use dead iterator. */
16273 else
16274 { /* Can use dead iterator because we're at at
16275 least an innermore (higher-numbered) level
16276 than the iterator's outermost
16277 (lowest-numbered) level. */
16278 ffesymbol_signal_change (sp);
16279 ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
16280 ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
16281 ffesymbol_signal_unreported (sp);
16282 }
16283 break;
16284
16285 case FFESYMBOL_stateSEEN: /* Seen already in this or other
16286 implied-DO. Set symbol level
16287 number to outermost value, as that
16288 tells us we can see it as iterator
16289 at that level at the innermost. */
16290 if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
16291 {
16292 ffesymbol_signal_change (sp);
16293 ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
16294 ffesymbol_signal_unreported (sp);
16295 }
16296 break;
16297
16298 case FFESYMBOL_stateUNCERTAIN: /* Iterator. */
16299 assert (ffeexpr_level_ == ffesymbol_maxentrynum (sp));
16300 ffesymbol_error (sp, t); /* (,,,I=I,10). */
16301 break;
16302
16303 case FFESYMBOL_stateUNDERSTOOD:
16304 break; /* ANY. */
16305
16306 default:
16307 assert ("Foo Bar!!" == NULL);
16308 break;
16309 }
16310
16311 return sp;
16312 }
16313
16314 /* Got symbol in local name space, so we haven't seen it in impdo yet.
16315 First, if it is brand-new and we're in executable statements, set the
16316 attributes and exec-transition it to set state UNCERTAIN or UNDERSTOOD.
16317 Second, if it is now a constant (PARAMETER), then just return it, it
16318 can't be an implied-do iterator. If it is understood, complain if it is
16319 not a valid variable, but make the inner name space iterator anyway and
16320 return that. If it is not understood, improve understanding of the
16321 symbol accordingly, complain accordingly, in either case make the inner
16322 name space iterator and return that. */
16323
16324 sa = ffesymbol_attrs (sp);
16325
16326 if (ffesymbol_state_is_specable (ss)
16327 && ffest_seen_first_exec ())
16328 {
16329 assert (sa == FFESYMBOL_attrsetNONE);
16330 ffesymbol_signal_change (sp);
16331 ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
16332 ffesymbol_resolve_intrin (sp);
16333 if (ffeimplic_establish_symbol (sp))
16334 ffesymbol_set_attr (sp, FFESYMBOL_attrSFARG);
16335 else
16336 ffesymbol_error (sp, t);
16337
16338 /* After the exec transition, the state will either be UNCERTAIN (could
16339 be a dummy or local var) or UNDERSTOOD (local var, because this is a
16340 PROGRAM/BLOCKDATA program unit). */
16341
16342 sp = ffecom_sym_exec_transition (sp);
16343 sa = ffesymbol_attrs (sp);
16344 ss = ffesymbol_state (sp);
16345 }
16346
16347 ns = ss;
16348 kind = ffesymbol_kind (sp);
16349 where = ffesymbol_where (sp);
16350
16351 if (ss == FFESYMBOL_stateUNDERSTOOD)
16352 {
16353 if (kind != FFEINFO_kindENTITY)
16354 ffesymbol_error (sp, t);
16355 if (where == FFEINFO_whereCONSTANT)
16356 return sp;
16357 }
16358 else
16359 {
16360 /* Enhance understanding of local symbol. This used to imply exec
16361 transition, but that doesn't seem necessary, since the local symbol
16362 doesn't actually get put into an ffebld tree here -- we just learn
16363 more about it, just like when we see a local symbol's name in the
16364 dummy-arg list of a statement function. */
16365
16366 if (ss != FFESYMBOL_stateUNCERTAIN)
16367 {
16368 /* Figure out what kind of object we've got based on previous
16369 declarations of or references to the object. */
16370
16371 ns = FFESYMBOL_stateSEEN;
16372
16373 if (sa & FFESYMBOL_attrsANY)
16374 na = sa;
16375 else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
16376 | FFESYMBOL_attrsANY
16377 | FFESYMBOL_attrsCOMMON
16378 | FFESYMBOL_attrsDUMMY
16379 | FFESYMBOL_attrsEQUIV
16380 | FFESYMBOL_attrsINIT
16381 | FFESYMBOL_attrsNAMELIST
16382 | FFESYMBOL_attrsRESULT
16383 | FFESYMBOL_attrsSAVE
16384 | FFESYMBOL_attrsSFARG
16385 | FFESYMBOL_attrsTYPE)))
16386 na = sa | FFESYMBOL_attrsSFARG;
16387 else
16388 na = FFESYMBOL_attrsetNONE;
16389 }
16390 else
16391 { /* stateUNCERTAIN. */
16392 na = sa | FFESYMBOL_attrsSFARG;
16393 ns = FFESYMBOL_stateUNDERSTOOD;
16394
16395 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16396 | FFESYMBOL_attrsADJUSTABLE
16397 | FFESYMBOL_attrsANYLEN
16398 | FFESYMBOL_attrsARRAY
16399 | FFESYMBOL_attrsDUMMY
16400 | FFESYMBOL_attrsEXTERNAL
16401 | FFESYMBOL_attrsSFARG
16402 | FFESYMBOL_attrsTYPE)));
16403
16404 if (sa & FFESYMBOL_attrsEXTERNAL)
16405 {
16406 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16407 | FFESYMBOL_attrsDUMMY
16408 | FFESYMBOL_attrsEXTERNAL
16409 | FFESYMBOL_attrsTYPE)));
16410
16411 na = FFESYMBOL_attrsetNONE;
16412 }
16413 else if (sa & FFESYMBOL_attrsDUMMY)
16414 {
16415 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16416 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16417 | FFESYMBOL_attrsEXTERNAL
16418 | FFESYMBOL_attrsTYPE)));
16419
16420 kind = FFEINFO_kindENTITY;
16421 }
16422 else if (sa & FFESYMBOL_attrsARRAY)
16423 {
16424 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16425 | FFESYMBOL_attrsADJUSTABLE
16426 | FFESYMBOL_attrsTYPE)));
16427
16428 na = FFESYMBOL_attrsetNONE;
16429 }
16430 else if (sa & FFESYMBOL_attrsSFARG)
16431 {
16432 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16433 | FFESYMBOL_attrsTYPE)));
16434
16435 ns = FFESYMBOL_stateUNCERTAIN;
16436 }
16437 else if (sa & FFESYMBOL_attrsTYPE)
16438 {
16439 assert (!(sa & (FFESYMBOL_attrsARRAY
16440 | FFESYMBOL_attrsDUMMY
16441 | FFESYMBOL_attrsEXTERNAL
16442 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16443 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16444 | FFESYMBOL_attrsADJUSTABLE
16445 | FFESYMBOL_attrsANYLEN
16446 | FFESYMBOL_attrsARRAY
16447 | FFESYMBOL_attrsDUMMY
16448 | FFESYMBOL_attrsEXTERNAL
16449 | FFESYMBOL_attrsSFARG)));
16450
16451 kind = FFEINFO_kindENTITY;
16452
16453 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16454 na = FFESYMBOL_attrsetNONE;
16455 else if (ffest_is_entry_valid ())
16456 ns = FFESYMBOL_stateUNCERTAIN; /* Could be DUMMY or LOCAL. */
16457 else
16458 where = FFEINFO_whereLOCAL;
16459 }
16460 else
16461 na = FFESYMBOL_attrsetNONE; /* Error. */
16462 }
16463
16464 /* Now see what we've got for a new object: NONE means a new error
16465 cropped up; ANY means an old error to be ignored; otherwise,
16466 everything's ok, update the object (symbol) and continue on. */
16467
16468 if (na == FFESYMBOL_attrsetNONE)
16469 ffesymbol_error (sp, t);
16470 else if (!(na & FFESYMBOL_attrsANY))
16471 {
16472 ffesymbol_signal_change (sp); /* May need to back up to previous
16473 version. */
16474 if (!ffeimplic_establish_symbol (sp))
16475 ffesymbol_error (sp, t);
16476 else
16477 {
16478 ffesymbol_set_info (sp,
16479 ffeinfo_new (ffesymbol_basictype (sp),
16480 ffesymbol_kindtype (sp),
16481 ffesymbol_rank (sp),
16482 kind,
16483 where,
16484 ffesymbol_size (sp)));
16485 ffesymbol_set_attrs (sp, na);
16486 ffesymbol_set_state (sp, ns);
16487 ffesymbol_resolve_intrin (sp);
16488 if (!ffesymbol_state_is_specable (ns))
16489 sp = ffecom_sym_learned (sp);
16490 ffesymbol_signal_unreported (sp); /* For debugging purposes. */
16491 }
16492 }
16493 }
16494
16495 /* Here we create the sfunc-name-space symbol representing what should
16496 become an iterator in this name space at this or an outermore (lower-
16497 numbered) expression level, else the implied-DO construct is in error. */
16498
16499 s = ffesymbol_declare_sfdummy (t); /* Sets maxentrynum to 0 for new obj;
16500 also sets sfa_dummy_parent to
16501 parent symbol. */
16502 assert (sp == ffesymbol_sfdummyparent (s));
16503
16504 ffesymbol_signal_change (s);
16505 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
16506 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
16507 ffesymbol_set_info (s,
16508 ffeinfo_new (FFEINFO_basictypeINTEGER,
16509 FFEINFO_kindtypeINTEGERDEFAULT,
16510 0,
16511 FFEINFO_kindENTITY,
16512 FFEINFO_whereIMMEDIATE,
16513 FFETARGET_charactersizeNONE));
16514 ffesymbol_signal_unreported (s);
16515
16516 if ((ffesymbol_basictype (sp) != FFEINFO_basictypeINTEGER)
16517 && (ffesymbol_basictype (sp) != FFEINFO_basictypeANY))
16518 ffesymbol_error (s, t);
16519
16520 return s;
16521 }
16522
16523 /* Have FOO in CALL FOO. Local name space, executable context only. */
16524
16525 static ffesymbol
16526 ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t)
16527 {
16528 ffesymbolAttrs sa;
16529 ffesymbolAttrs na;
16530 ffeinfoKind kind;
16531 ffeinfoWhere where;
16532 ffeintrinGen gen;
16533 ffeintrinSpec spec;
16534 ffeintrinImp imp;
16535 bool error = FALSE;
16536
16537 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16538 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16539
16540 na = sa = ffesymbol_attrs (s);
16541
16542 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16543 | FFESYMBOL_attrsADJUSTABLE
16544 | FFESYMBOL_attrsANYLEN
16545 | FFESYMBOL_attrsARRAY
16546 | FFESYMBOL_attrsDUMMY
16547 | FFESYMBOL_attrsEXTERNAL
16548 | FFESYMBOL_attrsSFARG
16549 | FFESYMBOL_attrsTYPE)));
16550
16551 kind = ffesymbol_kind (s);
16552 where = ffesymbol_where (s);
16553
16554 /* Figure out what kind of object we've got based on previous declarations
16555 of or references to the object. */
16556
16557 if (sa & FFESYMBOL_attrsEXTERNAL)
16558 {
16559 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16560 | FFESYMBOL_attrsDUMMY
16561 | FFESYMBOL_attrsEXTERNAL
16562 | FFESYMBOL_attrsTYPE)));
16563
16564 if (sa & FFESYMBOL_attrsTYPE)
16565 error = TRUE;
16566 else
16567 /* Not TYPE. */
16568 {
16569 kind = FFEINFO_kindSUBROUTINE;
16570
16571 if (sa & FFESYMBOL_attrsDUMMY)
16572 ; /* Not TYPE. */
16573 else if (sa & FFESYMBOL_attrsACTUALARG)
16574 ; /* Not DUMMY or TYPE. */
16575 else /* Not ACTUALARG, DUMMY, or TYPE. */
16576 where = FFEINFO_whereGLOBAL;
16577 }
16578 }
16579 else if (sa & FFESYMBOL_attrsDUMMY)
16580 {
16581 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16582 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16583 | FFESYMBOL_attrsEXTERNAL
16584 | FFESYMBOL_attrsTYPE)));
16585
16586 if (sa & FFESYMBOL_attrsTYPE)
16587 error = TRUE;
16588 else
16589 kind = FFEINFO_kindSUBROUTINE;
16590 }
16591 else if (sa & FFESYMBOL_attrsARRAY)
16592 {
16593 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16594 | FFESYMBOL_attrsADJUSTABLE
16595 | FFESYMBOL_attrsTYPE)));
16596
16597 error = TRUE;
16598 }
16599 else if (sa & FFESYMBOL_attrsSFARG)
16600 {
16601 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16602 | FFESYMBOL_attrsTYPE)));
16603
16604 error = TRUE;
16605 }
16606 else if (sa & FFESYMBOL_attrsTYPE)
16607 {
16608 assert (!(sa & (FFESYMBOL_attrsARRAY
16609 | FFESYMBOL_attrsDUMMY
16610 | FFESYMBOL_attrsEXTERNAL
16611 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16612 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16613 | FFESYMBOL_attrsADJUSTABLE
16614 | FFESYMBOL_attrsANYLEN
16615 | FFESYMBOL_attrsARRAY
16616 | FFESYMBOL_attrsDUMMY
16617 | FFESYMBOL_attrsEXTERNAL
16618 | FFESYMBOL_attrsSFARG)));
16619
16620 error = TRUE;
16621 }
16622 else if (sa == FFESYMBOL_attrsetNONE)
16623 {
16624 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16625
16626 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
16627 &gen, &spec, &imp))
16628 {
16629 ffesymbol_signal_change (s); /* May need to back up to previous
16630 version. */
16631 ffesymbol_set_generic (s, gen);
16632 ffesymbol_set_specific (s, spec);
16633 ffesymbol_set_implementation (s, imp);
16634 ffesymbol_set_info (s,
16635 ffeinfo_new (FFEINFO_basictypeNONE,
16636 FFEINFO_kindtypeNONE,
16637 0,
16638 FFEINFO_kindSUBROUTINE,
16639 FFEINFO_whereINTRINSIC,
16640 FFETARGET_charactersizeNONE));
16641 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16642 ffesymbol_resolve_intrin (s);
16643 ffesymbol_reference (s, t, FALSE);
16644 s = ffecom_sym_learned (s);
16645 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16646
16647 return s;
16648 }
16649
16650 kind = FFEINFO_kindSUBROUTINE;
16651 where = FFEINFO_whereGLOBAL;
16652 }
16653 else
16654 error = TRUE;
16655
16656 /* Now see what we've got for a new object: NONE means a new error cropped
16657 up; ANY means an old error to be ignored; otherwise, everything's ok,
16658 update the object (symbol) and continue on. */
16659
16660 if (error)
16661 ffesymbol_error (s, t);
16662 else if (!(na & FFESYMBOL_attrsANY))
16663 {
16664 ffesymbol_signal_change (s); /* May need to back up to previous
16665 version. */
16666 ffesymbol_set_info (s,
16667 ffeinfo_new (ffesymbol_basictype (s),
16668 ffesymbol_kindtype (s),
16669 ffesymbol_rank (s),
16670 kind, /* SUBROUTINE. */
16671 where, /* GLOBAL or DUMMY. */
16672 ffesymbol_size (s)));
16673 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16674 ffesymbol_resolve_intrin (s);
16675 ffesymbol_reference (s, t, FALSE);
16676 s = ffecom_sym_learned (s);
16677 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16678 }
16679
16680 return s;
16681 }
16682
16683 /* Have FOO in DATA FOO/.../. Local name space and executable context
16684 only. (This will change in the future when DATA FOO may be followed
16685 by COMMON FOO or even INTEGER FOO(10), etc.) */
16686
16687 static ffesymbol
16688 ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t)
16689 {
16690 ffesymbolAttrs sa;
16691 ffesymbolAttrs na;
16692 ffeinfoKind kind;
16693 ffeinfoWhere where;
16694 bool error = FALSE;
16695
16696 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16697 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16698
16699 na = sa = ffesymbol_attrs (s);
16700
16701 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16702 | FFESYMBOL_attrsADJUSTABLE
16703 | FFESYMBOL_attrsANYLEN
16704 | FFESYMBOL_attrsARRAY
16705 | FFESYMBOL_attrsDUMMY
16706 | FFESYMBOL_attrsEXTERNAL
16707 | FFESYMBOL_attrsSFARG
16708 | FFESYMBOL_attrsTYPE)));
16709
16710 kind = ffesymbol_kind (s);
16711 where = ffesymbol_where (s);
16712
16713 /* Figure out what kind of object we've got based on previous declarations
16714 of or references to the object. */
16715
16716 if (sa & FFESYMBOL_attrsEXTERNAL)
16717 {
16718 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16719 | FFESYMBOL_attrsDUMMY
16720 | FFESYMBOL_attrsEXTERNAL
16721 | FFESYMBOL_attrsTYPE)));
16722
16723 error = TRUE;
16724 }
16725 else if (sa & FFESYMBOL_attrsDUMMY)
16726 {
16727 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16728 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16729 | FFESYMBOL_attrsEXTERNAL
16730 | FFESYMBOL_attrsTYPE)));
16731
16732 error = TRUE;
16733 }
16734 else if (sa & FFESYMBOL_attrsARRAY)
16735 {
16736 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16737 | FFESYMBOL_attrsADJUSTABLE
16738 | FFESYMBOL_attrsTYPE)));
16739
16740 if (sa & FFESYMBOL_attrsADJUSTABLE)
16741 error = TRUE;
16742 where = FFEINFO_whereLOCAL;
16743 }
16744 else if (sa & FFESYMBOL_attrsSFARG)
16745 {
16746 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16747 | FFESYMBOL_attrsTYPE)));
16748
16749 where = FFEINFO_whereLOCAL;
16750 }
16751 else if (sa & FFESYMBOL_attrsTYPE)
16752 {
16753 assert (!(sa & (FFESYMBOL_attrsARRAY
16754 | FFESYMBOL_attrsDUMMY
16755 | FFESYMBOL_attrsEXTERNAL
16756 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16757 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16758 | FFESYMBOL_attrsADJUSTABLE
16759 | FFESYMBOL_attrsANYLEN
16760 | FFESYMBOL_attrsARRAY
16761 | FFESYMBOL_attrsDUMMY
16762 | FFESYMBOL_attrsEXTERNAL
16763 | FFESYMBOL_attrsSFARG)));
16764
16765 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16766 error = TRUE;
16767 else
16768 {
16769 kind = FFEINFO_kindENTITY;
16770 where = FFEINFO_whereLOCAL;
16771 }
16772 }
16773 else if (sa == FFESYMBOL_attrsetNONE)
16774 {
16775 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16776 kind = FFEINFO_kindENTITY;
16777 where = FFEINFO_whereLOCAL;
16778 }
16779 else
16780 error = TRUE;
16781
16782 /* Now see what we've got for a new object: NONE means a new error cropped
16783 up; ANY means an old error to be ignored; otherwise, everything's ok,
16784 update the object (symbol) and continue on. */
16785
16786 if (error)
16787 ffesymbol_error (s, t);
16788 else if (!(na & FFESYMBOL_attrsANY))
16789 {
16790 ffesymbol_signal_change (s); /* May need to back up to previous
16791 version. */
16792 if (!ffeimplic_establish_symbol (s))
16793 {
16794 ffesymbol_error (s, t);
16795 return s;
16796 }
16797 ffesymbol_set_info (s,
16798 ffeinfo_new (ffesymbol_basictype (s),
16799 ffesymbol_kindtype (s),
16800 ffesymbol_rank (s),
16801 kind, /* ENTITY. */
16802 where, /* LOCAL. */
16803 ffesymbol_size (s)));
16804 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16805 ffesymbol_resolve_intrin (s);
16806 s = ffecom_sym_learned (s);
16807 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16808 }
16809
16810 return s;
16811 }
16812
16813 /* Have FOO in EQUIVALENCE (...,FOO,...). Does not include
16814 EQUIVALENCE (...,BAR(FOO),...). */
16815
16816 static ffesymbol
16817 ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t)
16818 {
16819 ffesymbolAttrs sa;
16820 ffesymbolAttrs na;
16821 ffeinfoKind kind;
16822 ffeinfoWhere where;
16823
16824 na = sa = ffesymbol_attrs (s);
16825 kind = FFEINFO_kindENTITY;
16826 where = ffesymbol_where (s);
16827
16828 /* Figure out what kind of object we've got based on previous declarations
16829 of or references to the object. */
16830
16831 if (!(sa & ~(FFESYMBOL_attrsADJUSTS
16832 | FFESYMBOL_attrsARRAY
16833 | FFESYMBOL_attrsCOMMON
16834 | FFESYMBOL_attrsEQUIV
16835 | FFESYMBOL_attrsINIT
16836 | FFESYMBOL_attrsNAMELIST
16837 | FFESYMBOL_attrsSAVE
16838 | FFESYMBOL_attrsSFARG
16839 | FFESYMBOL_attrsTYPE)))
16840 na = sa | FFESYMBOL_attrsEQUIV;
16841 else
16842 na = FFESYMBOL_attrsetNONE;
16843
16844 /* Don't know why we're bothering to set kind and where in this code, but
16845 added the following to make it complete, in case it's really important.
16846 Generally this is left up to symbol exec transition. */
16847
16848 if (where == FFEINFO_whereNONE)
16849 {
16850 if (na & (FFESYMBOL_attrsADJUSTS
16851 | FFESYMBOL_attrsCOMMON))
16852 where = FFEINFO_whereCOMMON;
16853 else if (na & FFESYMBOL_attrsSAVE)
16854 where = FFEINFO_whereLOCAL;
16855 }
16856
16857 /* Now see what we've got for a new object: NONE means a new error cropped
16858 up; ANY means an old error to be ignored; otherwise, everything's ok,
16859 update the object (symbol) and continue on. */
16860
16861 if (na == FFESYMBOL_attrsetNONE)
16862 ffesymbol_error (s, t);
16863 else if (!(na & FFESYMBOL_attrsANY))
16864 {
16865 ffesymbol_signal_change (s); /* May need to back up to previous
16866 version. */
16867 ffesymbol_set_info (s,
16868 ffeinfo_new (ffesymbol_basictype (s),
16869 ffesymbol_kindtype (s),
16870 ffesymbol_rank (s),
16871 kind, /* Always ENTITY. */
16872 where, /* NONE, COMMON, or LOCAL. */
16873 ffesymbol_size (s)));
16874 ffesymbol_set_attrs (s, na);
16875 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
16876 ffesymbol_resolve_intrin (s);
16877 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16878 }
16879
16880 return s;
16881 }
16882
16883 /* Have FOO in OPEN(...,USEROPEN=FOO,...). Executable context only.
16884
16885 Note that I think this should be considered semantically similar to
16886 doing CALL XYZ(FOO), in that it should be considered like an
16887 ACTUALARG context. In particular, without EXTERNAL being specified,
16888 it should not be allowed. */
16889
16890 static ffesymbol
16891 ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t)
16892 {
16893 ffesymbolAttrs sa;
16894 ffesymbolAttrs na;
16895 ffeinfoKind kind;
16896 ffeinfoWhere where;
16897 bool needs_type = FALSE;
16898 bool error = FALSE;
16899
16900 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16901 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16902
16903 na = sa = ffesymbol_attrs (s);
16904
16905 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16906 | FFESYMBOL_attrsADJUSTABLE
16907 | FFESYMBOL_attrsANYLEN
16908 | FFESYMBOL_attrsARRAY
16909 | FFESYMBOL_attrsDUMMY
16910 | FFESYMBOL_attrsEXTERNAL
16911 | FFESYMBOL_attrsSFARG
16912 | FFESYMBOL_attrsTYPE)));
16913
16914 kind = ffesymbol_kind (s);
16915 where = ffesymbol_where (s);
16916
16917 /* Figure out what kind of object we've got based on previous declarations
16918 of or references to the object. */
16919
16920 if (sa & FFESYMBOL_attrsEXTERNAL)
16921 {
16922 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16923 | FFESYMBOL_attrsDUMMY
16924 | FFESYMBOL_attrsEXTERNAL
16925 | FFESYMBOL_attrsTYPE)));
16926
16927 if (sa & FFESYMBOL_attrsTYPE)
16928 where = FFEINFO_whereGLOBAL;
16929 else
16930 /* Not TYPE. */
16931 {
16932 kind = FFEINFO_kindFUNCTION;
16933 needs_type = TRUE;
16934
16935 if (sa & FFESYMBOL_attrsDUMMY)
16936 ; /* Not TYPE. */
16937 else if (sa & FFESYMBOL_attrsACTUALARG)
16938 ; /* Not DUMMY or TYPE. */
16939 else /* Not ACTUALARG, DUMMY, or TYPE. */
16940 where = FFEINFO_whereGLOBAL;
16941 }
16942 }
16943 else if (sa & FFESYMBOL_attrsDUMMY)
16944 {
16945 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16946 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16947 | FFESYMBOL_attrsEXTERNAL
16948 | FFESYMBOL_attrsTYPE)));
16949
16950 kind = FFEINFO_kindFUNCTION;
16951 if (!(sa & FFESYMBOL_attrsTYPE))
16952 needs_type = TRUE;
16953 }
16954 else if (sa & FFESYMBOL_attrsARRAY)
16955 {
16956 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16957 | FFESYMBOL_attrsADJUSTABLE
16958 | FFESYMBOL_attrsTYPE)));
16959
16960 error = TRUE;
16961 }
16962 else if (sa & FFESYMBOL_attrsSFARG)
16963 {
16964 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16965 | FFESYMBOL_attrsTYPE)));
16966
16967 error = TRUE;
16968 }
16969 else if (sa & FFESYMBOL_attrsTYPE)
16970 {
16971 assert (!(sa & (FFESYMBOL_attrsARRAY
16972 | FFESYMBOL_attrsDUMMY
16973 | FFESYMBOL_attrsEXTERNAL
16974 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16975 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16976 | FFESYMBOL_attrsADJUSTABLE
16977 | FFESYMBOL_attrsANYLEN
16978 | FFESYMBOL_attrsARRAY
16979 | FFESYMBOL_attrsDUMMY
16980 | FFESYMBOL_attrsEXTERNAL
16981 | FFESYMBOL_attrsSFARG)));
16982
16983 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16984 error = TRUE;
16985 else
16986 {
16987 kind = FFEINFO_kindFUNCTION;
16988 where = FFEINFO_whereGLOBAL;
16989 }
16990 }
16991 else if (sa == FFESYMBOL_attrsetNONE)
16992 {
16993 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16994 kind = FFEINFO_kindFUNCTION;
16995 where = FFEINFO_whereGLOBAL;
16996 needs_type = TRUE;
16997 }
16998 else
16999 error = TRUE;
17000
17001 /* Now see what we've got for a new object: NONE means a new error cropped
17002 up; ANY means an old error to be ignored; otherwise, everything's ok,
17003 update the object (symbol) and continue on. */
17004
17005 if (error)
17006 ffesymbol_error (s, t);
17007 else if (!(na & FFESYMBOL_attrsANY))
17008 {
17009 ffesymbol_signal_change (s); /* May need to back up to previous
17010 version. */
17011 if (needs_type && !ffeimplic_establish_symbol (s))
17012 {
17013 ffesymbol_error (s, t);
17014 return s;
17015 }
17016 if (!ffesymbol_explicitwhere (s))
17017 {
17018 ffebad_start (FFEBAD_NEED_EXTERNAL);
17019 ffebad_here (0, ffelex_token_where_line (t),
17020 ffelex_token_where_column (t));
17021 ffebad_string (ffesymbol_text (s));
17022 ffebad_finish ();
17023 ffesymbol_set_explicitwhere (s, TRUE);
17024 }
17025 ffesymbol_set_info (s,
17026 ffeinfo_new (ffesymbol_basictype (s),
17027 ffesymbol_kindtype (s),
17028 ffesymbol_rank (s),
17029 kind, /* FUNCTION. */
17030 where, /* GLOBAL or DUMMY. */
17031 ffesymbol_size (s)));
17032 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17033 ffesymbol_resolve_intrin (s);
17034 ffesymbol_reference (s, t, FALSE);
17035 s = ffecom_sym_learned (s);
17036 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17037 }
17038
17039 return s;
17040 }
17041
17042 /* Have FOO in DATA (stuff,FOO=1,10)/.../. */
17043
17044 static ffesymbol
17045 ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t)
17046 {
17047 ffesymbolState ss;
17048
17049 /* If the symbol isn't in the sfunc name space, pretend as though we saw a
17050 reference to it already within the imp-DO construct at this level, so as
17051 to get a symbol that is in the sfunc name space. But this is an
17052 erroneous construct, and should be caught elsewhere. */
17053
17054 if (ffesymbol_sfdummyparent (s) == NULL)
17055 {
17056 s = ffeexpr_sym_impdoitem_ (s, t);
17057 if (ffesymbol_sfdummyparent (s) == NULL)
17058 { /* PARAMETER FOO...DATA (A(I),FOO=...). */
17059 ffesymbol_error (s, t);
17060 return s;
17061 }
17062 }
17063
17064 ss = ffesymbol_state (s);
17065
17066 switch (ss)
17067 {
17068 case FFESYMBOL_stateNONE: /* Used as iterator already. */
17069 if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
17070 ffesymbol_error (s, t); /* Can't reuse dead iterator. F90 disallows
17071 this; F77 allows it but it is a stupid
17072 feature. */
17073 else
17074 { /* Can use dead iterator because we're at at
17075 least a innermore (higher-numbered) level
17076 than the iterator's outermost
17077 (lowest-numbered) level. This should be
17078 diagnosed later, because it means an item
17079 in this list didn't reference this
17080 iterator. */
17081 #if 1
17082 ffesymbol_error (s, t); /* For now, complain. */
17083 #else /* Someday will detect all cases where initializer doesn't reference
17084 all applicable iterators, in which case reenable this code. */
17085 ffesymbol_signal_change (s);
17086 ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
17087 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
17088 ffesymbol_signal_unreported (s);
17089 #endif
17090 }
17091 break;
17092
17093 case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO.
17094 If seen in outermore level, can't be an
17095 iterator here, so complain. If not seen
17096 at current level, complain for now,
17097 because that indicates something F90
17098 rejects (though we currently don't detect
17099 all such cases for now). */
17100 if (ffeexpr_level_ <= ffesymbol_maxentrynum (s))
17101 {
17102 ffesymbol_signal_change (s);
17103 ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
17104 ffesymbol_signal_unreported (s);
17105 }
17106 else
17107 ffesymbol_error (s, t);
17108 break;
17109
17110 case FFESYMBOL_stateUNCERTAIN: /* Already iterator! */
17111 assert ("DATA implied-DO control var seen twice!!" == NULL);
17112 ffesymbol_error (s, t);
17113 break;
17114
17115 case FFESYMBOL_stateUNDERSTOOD:
17116 break; /* ANY. */
17117
17118 default:
17119 assert ("Foo Bletch!!" == NULL);
17120 break;
17121 }
17122
17123 return s;
17124 }
17125
17126 /* Have FOO in PARAMETER (FOO=...). */
17127
17128 static ffesymbol
17129 ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t)
17130 {
17131 ffesymbolAttrs sa;
17132
17133 sa = ffesymbol_attrs (s);
17134
17135 /* Figure out what kind of object we've got based on previous declarations
17136 of or references to the object. */
17137
17138 if (sa & ~(FFESYMBOL_attrsANYLEN
17139 | FFESYMBOL_attrsTYPE))
17140 {
17141 if (!(sa & FFESYMBOL_attrsANY))
17142 ffesymbol_error (s, t);
17143 }
17144 else
17145 {
17146 ffesymbol_signal_change (s); /* May need to back up to previous
17147 version. */
17148 if (!ffeimplic_establish_symbol (s))
17149 {
17150 ffesymbol_error (s, t);
17151 return s;
17152 }
17153 ffesymbol_set_info (s,
17154 ffeinfo_new (ffesymbol_basictype (s),
17155 ffesymbol_kindtype (s),
17156 ffesymbol_rank (s),
17157 FFEINFO_kindENTITY,
17158 FFEINFO_whereCONSTANT,
17159 ffesymbol_size (s)));
17160 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17161 ffesymbol_resolve_intrin (s);
17162 s = ffecom_sym_learned (s);
17163 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17164 }
17165
17166 return s;
17167 }
17168
17169 /* Have FOO in CALL XYZ(...,FOO,...). Does not include any other
17170 embedding of FOO, such as CALL XYZ((FOO)) or CALL XYZ(FOO+1). */
17171
17172 static ffesymbol
17173 ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t)
17174 {
17175 ffesymbolAttrs sa;
17176 ffesymbolAttrs na;
17177 ffeinfoKind kind;
17178 ffeinfoWhere where;
17179 ffesymbolState ns;
17180 bool needs_type = FALSE;
17181
17182 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
17183 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
17184
17185 na = sa = ffesymbol_attrs (s);
17186
17187 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17188 | FFESYMBOL_attrsADJUSTABLE
17189 | FFESYMBOL_attrsANYLEN
17190 | FFESYMBOL_attrsARRAY
17191 | FFESYMBOL_attrsDUMMY
17192 | FFESYMBOL_attrsEXTERNAL
17193 | FFESYMBOL_attrsSFARG
17194 | FFESYMBOL_attrsTYPE)));
17195
17196 kind = ffesymbol_kind (s);
17197 where = ffesymbol_where (s);
17198
17199 /* Figure out what kind of object we've got based on previous declarations
17200 of or references to the object. */
17201
17202 ns = FFESYMBOL_stateUNDERSTOOD;
17203
17204 if (sa & FFESYMBOL_attrsEXTERNAL)
17205 {
17206 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17207 | FFESYMBOL_attrsDUMMY
17208 | FFESYMBOL_attrsEXTERNAL
17209 | FFESYMBOL_attrsTYPE)));
17210
17211 if (sa & FFESYMBOL_attrsTYPE)
17212 where = FFEINFO_whereGLOBAL;
17213 else
17214 /* Not TYPE. */
17215 {
17216 ns = FFESYMBOL_stateUNCERTAIN;
17217
17218 if (sa & FFESYMBOL_attrsDUMMY)
17219 assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */
17220 else if (sa & FFESYMBOL_attrsACTUALARG)
17221 ; /* Not DUMMY or TYPE. */
17222 else
17223 /* Not ACTUALARG, DUMMY, or TYPE. */
17224 {
17225 assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */
17226 na |= FFESYMBOL_attrsACTUALARG;
17227 where = FFEINFO_whereGLOBAL;
17228 }
17229 }
17230 }
17231 else if (sa & FFESYMBOL_attrsDUMMY)
17232 {
17233 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
17234 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
17235 | FFESYMBOL_attrsEXTERNAL
17236 | FFESYMBOL_attrsTYPE)));
17237
17238 kind = FFEINFO_kindENTITY;
17239 if (!(sa & FFESYMBOL_attrsTYPE))
17240 needs_type = TRUE;
17241 }
17242 else if (sa & FFESYMBOL_attrsARRAY)
17243 {
17244 assert (!(sa & ~(FFESYMBOL_attrsARRAY
17245 | FFESYMBOL_attrsADJUSTABLE
17246 | FFESYMBOL_attrsTYPE)));
17247
17248 where = FFEINFO_whereLOCAL;
17249 }
17250 else if (sa & FFESYMBOL_attrsSFARG)
17251 {
17252 assert (!(sa & ~(FFESYMBOL_attrsSFARG
17253 | FFESYMBOL_attrsTYPE)));
17254
17255 where = FFEINFO_whereLOCAL;
17256 }
17257 else if (sa & FFESYMBOL_attrsTYPE)
17258 {
17259 assert (!(sa & (FFESYMBOL_attrsARRAY
17260 | FFESYMBOL_attrsDUMMY
17261 | FFESYMBOL_attrsEXTERNAL
17262 | FFESYMBOL_attrsSFARG))); /* Handled above. */
17263 assert (!(sa & ~(FFESYMBOL_attrsTYPE
17264 | FFESYMBOL_attrsADJUSTABLE
17265 | FFESYMBOL_attrsANYLEN
17266 | FFESYMBOL_attrsARRAY
17267 | FFESYMBOL_attrsDUMMY
17268 | FFESYMBOL_attrsEXTERNAL
17269 | FFESYMBOL_attrsSFARG)));
17270
17271 if (sa & FFESYMBOL_attrsANYLEN)
17272 ns = FFESYMBOL_stateNONE;
17273 else
17274 {
17275 kind = FFEINFO_kindENTITY;
17276 where = FFEINFO_whereLOCAL;
17277 }
17278 }
17279 else if (sa == FFESYMBOL_attrsetNONE)
17280 {
17281 /* New state is left empty because there isn't any state flag to
17282 set for this case, and it's UNDERSTOOD after all. */
17283 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
17284 kind = FFEINFO_kindENTITY;
17285 where = FFEINFO_whereLOCAL;
17286 needs_type = TRUE;
17287 }
17288 else
17289 ns = FFESYMBOL_stateNONE; /* Error. */
17290
17291 /* Now see what we've got for a new object: NONE means a new error cropped
17292 up; ANY means an old error to be ignored; otherwise, everything's ok,
17293 update the object (symbol) and continue on. */
17294
17295 if (ns == FFESYMBOL_stateNONE)
17296 ffesymbol_error (s, t);
17297 else if (!(na & FFESYMBOL_attrsANY))
17298 {
17299 ffesymbol_signal_change (s); /* May need to back up to previous
17300 version. */
17301 if (needs_type && !ffeimplic_establish_symbol (s))
17302 {
17303 ffesymbol_error (s, t);
17304 return s;
17305 }
17306 ffesymbol_set_info (s,
17307 ffeinfo_new (ffesymbol_basictype (s),
17308 ffesymbol_kindtype (s),
17309 ffesymbol_rank (s),
17310 kind,
17311 where,
17312 ffesymbol_size (s)));
17313 ffesymbol_set_attrs (s, na);
17314 ffesymbol_set_state (s, ns);
17315 s = ffecom_sym_learned (s);
17316 ffesymbol_reference (s, t, FALSE);
17317 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17318 }
17319
17320 return s;
17321 }
17322
17323 /* Have FOO in DIMENSION XYZ(FOO) or any array declarator containing
17324 a reference to FOO. */
17325
17326 static ffesymbol
17327 ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t)
17328 {
17329 ffesymbolAttrs sa;
17330 ffesymbolAttrs na;
17331 ffeinfoKind kind;
17332 ffeinfoWhere where;
17333
17334 na = sa = ffesymbol_attrs (s);
17335 kind = FFEINFO_kindENTITY;
17336 where = ffesymbol_where (s);
17337
17338 /* Figure out what kind of object we've got based on previous declarations
17339 of or references to the object. */
17340
17341 if (!(sa & ~(FFESYMBOL_attrsADJUSTS
17342 | FFESYMBOL_attrsCOMMON
17343 | FFESYMBOL_attrsDUMMY
17344 | FFESYMBOL_attrsEQUIV
17345 | FFESYMBOL_attrsINIT
17346 | FFESYMBOL_attrsNAMELIST
17347 | FFESYMBOL_attrsSFARG
17348 | FFESYMBOL_attrsARRAY
17349 | FFESYMBOL_attrsTYPE)))
17350 na = sa | FFESYMBOL_attrsADJUSTS;
17351 else
17352 na = FFESYMBOL_attrsetNONE;
17353
17354 /* Since this symbol definitely is going into an expression (the
17355 dimension-list for some dummy array, presumably), figure out WHERE if
17356 possible. */
17357
17358 if (where == FFEINFO_whereNONE)
17359 {
17360 if (na & (FFESYMBOL_attrsCOMMON
17361 | FFESYMBOL_attrsEQUIV
17362 | FFESYMBOL_attrsINIT
17363 | FFESYMBOL_attrsNAMELIST))
17364 where = FFEINFO_whereCOMMON;
17365 else if (na & FFESYMBOL_attrsDUMMY)
17366 where = FFEINFO_whereDUMMY;
17367 }
17368
17369 /* Now see what we've got for a new object: NONE means a new error cropped
17370 up; ANY means an old error to be ignored; otherwise, everything's ok,
17371 update the object (symbol) and continue on. */
17372
17373 if (na == FFESYMBOL_attrsetNONE)
17374 ffesymbol_error (s, t);
17375 else if (!(na & FFESYMBOL_attrsANY))
17376 {
17377 ffesymbol_signal_change (s); /* May need to back up to previous
17378 version. */
17379 if (!ffeimplic_establish_symbol (s))
17380 {
17381 ffesymbol_error (s, t);
17382 return s;
17383 }
17384 ffesymbol_set_info (s,
17385 ffeinfo_new (ffesymbol_basictype (s),
17386 ffesymbol_kindtype (s),
17387 ffesymbol_rank (s),
17388 kind, /* Always ENTITY. */
17389 where, /* NONE, COMMON, or DUMMY. */
17390 ffesymbol_size (s)));
17391 ffesymbol_set_attrs (s, na);
17392 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
17393 ffesymbol_resolve_intrin (s);
17394 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17395 }
17396
17397 return s;
17398 }
17399
17400 /* Have FOO in XYZ = ...FOO.... Does not include cases like FOO in
17401 XYZ = BAR(FOO), as such cases are handled elsewhere. */
17402
17403 static ffesymbol
17404 ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t)
17405 {
17406 ffesymbolAttrs sa;
17407 ffesymbolAttrs na;
17408 ffeinfoKind kind;
17409 ffeinfoWhere where;
17410 bool error = FALSE;
17411
17412 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
17413 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
17414
17415 na = sa = ffesymbol_attrs (s);
17416
17417 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17418 | FFESYMBOL_attrsADJUSTABLE
17419 | FFESYMBOL_attrsANYLEN
17420 | FFESYMBOL_attrsARRAY
17421 | FFESYMBOL_attrsDUMMY
17422 | FFESYMBOL_attrsEXTERNAL
17423 | FFESYMBOL_attrsSFARG
17424 | FFESYMBOL_attrsTYPE)));
17425
17426 kind = ffesymbol_kind (s);
17427 where = ffesymbol_where (s);
17428
17429 /* Figure out what kind of object we've got based on previous declarations
17430 of or references to the object. */
17431
17432 if (sa & FFESYMBOL_attrsEXTERNAL)
17433 {
17434 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17435 | FFESYMBOL_attrsDUMMY
17436 | FFESYMBOL_attrsEXTERNAL
17437 | FFESYMBOL_attrsTYPE)));
17438
17439 error = TRUE;
17440 }
17441 else if (sa & FFESYMBOL_attrsDUMMY)
17442 {
17443 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
17444 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
17445 | FFESYMBOL_attrsEXTERNAL
17446 | FFESYMBOL_attrsTYPE)));
17447
17448 kind = FFEINFO_kindENTITY;
17449 }
17450 else if (sa & FFESYMBOL_attrsARRAY)
17451 {
17452 assert (!(sa & ~(FFESYMBOL_attrsARRAY
17453 | FFESYMBOL_attrsADJUSTABLE
17454 | FFESYMBOL_attrsTYPE)));
17455
17456 where = FFEINFO_whereLOCAL;
17457 }
17458 else if (sa & FFESYMBOL_attrsSFARG)
17459 {
17460 assert (!(sa & ~(FFESYMBOL_attrsSFARG
17461 | FFESYMBOL_attrsTYPE)));
17462
17463 where = FFEINFO_whereLOCAL;
17464 }
17465 else if (sa & FFESYMBOL_attrsTYPE)
17466 {
17467 assert (!(sa & (FFESYMBOL_attrsARRAY
17468 | FFESYMBOL_attrsDUMMY
17469 | FFESYMBOL_attrsEXTERNAL
17470 | FFESYMBOL_attrsSFARG))); /* Handled above. */
17471 assert (!(sa & ~(FFESYMBOL_attrsTYPE
17472 | FFESYMBOL_attrsADJUSTABLE
17473 | FFESYMBOL_attrsANYLEN
17474 | FFESYMBOL_attrsARRAY
17475 | FFESYMBOL_attrsDUMMY
17476 | FFESYMBOL_attrsEXTERNAL
17477 | FFESYMBOL_attrsSFARG)));
17478
17479 if (sa & FFESYMBOL_attrsANYLEN)
17480 error = TRUE;
17481 else
17482 {
17483 kind = FFEINFO_kindENTITY;
17484 where = FFEINFO_whereLOCAL;
17485 }
17486 }
17487 else if (sa == FFESYMBOL_attrsetNONE)
17488 {
17489 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
17490 kind = FFEINFO_kindENTITY;
17491 where = FFEINFO_whereLOCAL;
17492 }
17493 else
17494 error = TRUE;
17495
17496 /* Now see what we've got for a new object: NONE means a new error cropped
17497 up; ANY means an old error to be ignored; otherwise, everything's ok,
17498 update the object (symbol) and continue on. */
17499
17500 if (error)
17501 ffesymbol_error (s, t);
17502 else if (!(na & FFESYMBOL_attrsANY))
17503 {
17504 ffesymbol_signal_change (s); /* May need to back up to previous
17505 version. */
17506 if (!ffeimplic_establish_symbol (s))
17507 {
17508 ffesymbol_error (s, t);
17509 return s;
17510 }
17511 ffesymbol_set_info (s,
17512 ffeinfo_new (ffesymbol_basictype (s),
17513 ffesymbol_kindtype (s),
17514 ffesymbol_rank (s),
17515 kind, /* ENTITY. */
17516 where, /* LOCAL. */
17517 ffesymbol_size (s)));
17518 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17519 ffesymbol_resolve_intrin (s);
17520 s = ffecom_sym_learned (s);
17521 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17522 }
17523
17524 return s;
17525 }
17526
17527 /* ffeexpr_declare_parenthesized_ -- ffesymbol wrapper for NAME(...) operand
17528
17529 ffelexToken t;
17530 bool maybe_intrin;
17531 ffeexprParenType_ paren_type;
17532 ffesymbol s;
17533 s = ffeexpr_declare_parenthesized_ (t, maybe_intrin, &paren_type);
17534
17535 Just like ffesymbol_declare_local, except performs any implicit info
17536 assignment necessary, and it returns the type of the parenthesized list
17537 (list of function args, list of array args, or substring spec). */
17538
17539 static ffesymbol
17540 ffeexpr_declare_parenthesized_ (ffelexToken t, bool maybe_intrin,
17541 ffeexprParenType_ *paren_type)
17542 {
17543 ffesymbol s;
17544 ffesymbolState st; /* Effective state. */
17545 ffeinfoKind k;
17546 bool bad;
17547
17548 if (maybe_intrin && ffesrc_check_symbol ())
17549 { /* Knock off some easy cases. */
17550 switch (ffeexpr_stack_->context)
17551 {
17552 case FFEEXPR_contextSUBROUTINEREF:
17553 case FFEEXPR_contextDATA:
17554 case FFEEXPR_contextDATAIMPDOINDEX_:
17555 case FFEEXPR_contextSFUNCDEF:
17556 case FFEEXPR_contextSFUNCDEFINDEX_:
17557 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17558 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17559 case FFEEXPR_contextLET:
17560 case FFEEXPR_contextPAREN_:
17561 case FFEEXPR_contextACTUALARGEXPR_:
17562 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17563 case FFEEXPR_contextIOLIST:
17564 case FFEEXPR_contextIOLISTDF:
17565 case FFEEXPR_contextDO:
17566 case FFEEXPR_contextDOWHILE:
17567 case FFEEXPR_contextACTUALARG_:
17568 case FFEEXPR_contextCGOTO:
17569 case FFEEXPR_contextIF:
17570 case FFEEXPR_contextARITHIF:
17571 case FFEEXPR_contextFORMAT:
17572 case FFEEXPR_contextSTOP:
17573 case FFEEXPR_contextRETURN:
17574 case FFEEXPR_contextSELECTCASE:
17575 case FFEEXPR_contextCASE:
17576 case FFEEXPR_contextFILEASSOC:
17577 case FFEEXPR_contextFILEINT:
17578 case FFEEXPR_contextFILEDFINT:
17579 case FFEEXPR_contextFILELOG:
17580 case FFEEXPR_contextFILENUM:
17581 case FFEEXPR_contextFILENUMAMBIG:
17582 case FFEEXPR_contextFILECHAR:
17583 case FFEEXPR_contextFILENUMCHAR:
17584 case FFEEXPR_contextFILEDFCHAR:
17585 case FFEEXPR_contextFILEKEY:
17586 case FFEEXPR_contextFILEUNIT:
17587 case FFEEXPR_contextFILEUNIT_DF:
17588 case FFEEXPR_contextFILEUNITAMBIG:
17589 case FFEEXPR_contextFILEFORMAT:
17590 case FFEEXPR_contextFILENAMELIST:
17591 case FFEEXPR_contextFILEVXTCODE:
17592 case FFEEXPR_contextINDEX_:
17593 case FFEEXPR_contextIMPDOITEM_:
17594 case FFEEXPR_contextIMPDOITEMDF_:
17595 case FFEEXPR_contextIMPDOCTRL_:
17596 case FFEEXPR_contextDATAIMPDOCTRL_:
17597 case FFEEXPR_contextCHARACTERSIZE:
17598 case FFEEXPR_contextPARAMETER:
17599 case FFEEXPR_contextDIMLIST:
17600 case FFEEXPR_contextDIMLISTCOMMON:
17601 case FFEEXPR_contextKINDTYPE:
17602 case FFEEXPR_contextINITVAL:
17603 case FFEEXPR_contextEQVINDEX_:
17604 break; /* These could be intrinsic invocations. */
17605
17606 case FFEEXPR_contextAGOTO:
17607 case FFEEXPR_contextFILEFORMATNML:
17608 case FFEEXPR_contextALLOCATE:
17609 case FFEEXPR_contextDEALLOCATE:
17610 case FFEEXPR_contextHEAPSTAT:
17611 case FFEEXPR_contextNULLIFY:
17612 case FFEEXPR_contextINCLUDE:
17613 case FFEEXPR_contextDATAIMPDOITEM_:
17614 case FFEEXPR_contextLOC_:
17615 case FFEEXPR_contextINDEXORACTUALARG_:
17616 case FFEEXPR_contextSFUNCDEFACTUALARG_:
17617 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
17618 case FFEEXPR_contextPARENFILENUM_:
17619 case FFEEXPR_contextPARENFILEUNIT_:
17620 maybe_intrin = FALSE;
17621 break; /* Can't be intrinsic invocation. */
17622
17623 default:
17624 assert ("blah! blah! waaauuggh!" == NULL);
17625 break;
17626 }
17627 }
17628
17629 s = ffesymbol_declare_local (t, maybe_intrin);
17630
17631 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17632 /* Special-case these since they can involve a different concept
17633 of "state" (in the stmtfunc name space). */
17634 {
17635 case FFEEXPR_contextDATAIMPDOINDEX_:
17636 case FFEEXPR_contextDATAIMPDOCTRL_:
17637 if (ffeexpr_context_outer_ (ffeexpr_stack_)
17638 == FFEEXPR_contextDATAIMPDOINDEX_)
17639 s = ffeexpr_sym_impdoitem_ (s, t);
17640 else
17641 if (ffeexpr_stack_->is_rhs)
17642 s = ffeexpr_sym_impdoitem_ (s, t);
17643 else
17644 s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
17645 if (ffesymbol_kind (s) != FFEINFO_kindANY)
17646 ffesymbol_error (s, t);
17647 return s;
17648
17649 default:
17650 break;
17651 }
17652
17653 switch ((ffesymbol_sfdummyparent (s) == NULL)
17654 ? ffesymbol_state (s)
17655 : FFESYMBOL_stateUNDERSTOOD)
17656 {
17657 case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr
17658 context. */
17659 if (!ffest_seen_first_exec ())
17660 goto seen; /* :::::::::::::::::::: */
17661 /* Fall through. */
17662 case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */
17663 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17664 {
17665 case FFEEXPR_contextSUBROUTINEREF:
17666 s = ffeexpr_sym_lhs_call_ (s, t); /* "CALL FOO"=="CALL
17667 FOO(...)". */
17668 break;
17669
17670 case FFEEXPR_contextDATA:
17671 if (ffeexpr_stack_->is_rhs)
17672 s = ffeexpr_sym_rhs_let_ (s, t);
17673 else
17674 s = ffeexpr_sym_lhs_data_ (s, t);
17675 break;
17676
17677 case FFEEXPR_contextDATAIMPDOITEM_:
17678 s = ffeexpr_sym_lhs_data_ (s, t);
17679 break;
17680
17681 case FFEEXPR_contextSFUNCDEF:
17682 case FFEEXPR_contextSFUNCDEFINDEX_:
17683 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17684 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17685 s = ffecom_sym_exec_transition (s);
17686 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17687 goto understood; /* :::::::::::::::::::: */
17688 /* Fall through. */
17689 case FFEEXPR_contextLET:
17690 case FFEEXPR_contextPAREN_:
17691 case FFEEXPR_contextACTUALARGEXPR_:
17692 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17693 case FFEEXPR_contextIOLIST:
17694 case FFEEXPR_contextIOLISTDF:
17695 case FFEEXPR_contextDO:
17696 case FFEEXPR_contextDOWHILE:
17697 case FFEEXPR_contextACTUALARG_:
17698 case FFEEXPR_contextCGOTO:
17699 case FFEEXPR_contextIF:
17700 case FFEEXPR_contextARITHIF:
17701 case FFEEXPR_contextFORMAT:
17702 case FFEEXPR_contextSTOP:
17703 case FFEEXPR_contextRETURN:
17704 case FFEEXPR_contextSELECTCASE:
17705 case FFEEXPR_contextCASE:
17706 case FFEEXPR_contextFILEASSOC:
17707 case FFEEXPR_contextFILEINT:
17708 case FFEEXPR_contextFILEDFINT:
17709 case FFEEXPR_contextFILELOG:
17710 case FFEEXPR_contextFILENUM:
17711 case FFEEXPR_contextFILENUMAMBIG:
17712 case FFEEXPR_contextFILECHAR:
17713 case FFEEXPR_contextFILENUMCHAR:
17714 case FFEEXPR_contextFILEDFCHAR:
17715 case FFEEXPR_contextFILEKEY:
17716 case FFEEXPR_contextFILEUNIT:
17717 case FFEEXPR_contextFILEUNIT_DF:
17718 case FFEEXPR_contextFILEUNITAMBIG:
17719 case FFEEXPR_contextFILEFORMAT:
17720 case FFEEXPR_contextFILENAMELIST:
17721 case FFEEXPR_contextFILEVXTCODE:
17722 case FFEEXPR_contextINDEX_:
17723 case FFEEXPR_contextIMPDOITEM_:
17724 case FFEEXPR_contextIMPDOITEMDF_:
17725 case FFEEXPR_contextIMPDOCTRL_:
17726 case FFEEXPR_contextLOC_:
17727 if (ffeexpr_stack_->is_rhs)
17728 s = ffeexpr_paren_rhs_let_ (s, t);
17729 else
17730 s = ffeexpr_paren_lhs_let_ (s, t);
17731 break;
17732
17733 case FFEEXPR_contextASSIGN:
17734 case FFEEXPR_contextAGOTO:
17735 case FFEEXPR_contextCHARACTERSIZE:
17736 case FFEEXPR_contextEQUIVALENCE:
17737 case FFEEXPR_contextINCLUDE:
17738 case FFEEXPR_contextPARAMETER:
17739 case FFEEXPR_contextDIMLIST:
17740 case FFEEXPR_contextDIMLISTCOMMON:
17741 case FFEEXPR_contextKINDTYPE:
17742 case FFEEXPR_contextINITVAL:
17743 case FFEEXPR_contextEQVINDEX_:
17744 break; /* Will turn into errors below. */
17745
17746 default:
17747 ffesymbol_error (s, t);
17748 break;
17749 }
17750 /* Fall through. */
17751 case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */
17752 understood: /* :::::::::::::::::::: */
17753
17754 /* State might have changed, update it. */
17755 st = ((ffesymbol_sfdummyparent (s) == NULL)
17756 ? ffesymbol_state (s)
17757 : FFESYMBOL_stateUNDERSTOOD);
17758
17759 k = ffesymbol_kind (s);
17760 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17761 {
17762 case FFEEXPR_contextSUBROUTINEREF:
17763 bad = ((k != FFEINFO_kindSUBROUTINE)
17764 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
17765 || (k != FFEINFO_kindNONE)));
17766 break;
17767
17768 case FFEEXPR_contextDATA:
17769 if (ffeexpr_stack_->is_rhs)
17770 bad = (k != FFEINFO_kindENTITY)
17771 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
17772 else
17773 bad = (k != FFEINFO_kindENTITY)
17774 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
17775 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
17776 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
17777 break;
17778
17779 case FFEEXPR_contextDATAIMPDOITEM_:
17780 bad = (k != FFEINFO_kindENTITY) || (ffesymbol_rank (s) == 0)
17781 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
17782 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
17783 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
17784 break;
17785
17786 case FFEEXPR_contextSFUNCDEF:
17787 case FFEEXPR_contextSFUNCDEFINDEX_:
17788 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17789 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17790 case FFEEXPR_contextLET:
17791 case FFEEXPR_contextPAREN_:
17792 case FFEEXPR_contextACTUALARGEXPR_:
17793 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17794 case FFEEXPR_contextIOLIST:
17795 case FFEEXPR_contextIOLISTDF:
17796 case FFEEXPR_contextDO:
17797 case FFEEXPR_contextDOWHILE:
17798 case FFEEXPR_contextACTUALARG_:
17799 case FFEEXPR_contextCGOTO:
17800 case FFEEXPR_contextIF:
17801 case FFEEXPR_contextARITHIF:
17802 case FFEEXPR_contextFORMAT:
17803 case FFEEXPR_contextSTOP:
17804 case FFEEXPR_contextRETURN:
17805 case FFEEXPR_contextSELECTCASE:
17806 case FFEEXPR_contextCASE:
17807 case FFEEXPR_contextFILEASSOC:
17808 case FFEEXPR_contextFILEINT:
17809 case FFEEXPR_contextFILEDFINT:
17810 case FFEEXPR_contextFILELOG:
17811 case FFEEXPR_contextFILENUM:
17812 case FFEEXPR_contextFILENUMAMBIG:
17813 case FFEEXPR_contextFILECHAR:
17814 case FFEEXPR_contextFILENUMCHAR:
17815 case FFEEXPR_contextFILEDFCHAR:
17816 case FFEEXPR_contextFILEKEY:
17817 case FFEEXPR_contextFILEUNIT:
17818 case FFEEXPR_contextFILEUNIT_DF:
17819 case FFEEXPR_contextFILEUNITAMBIG:
17820 case FFEEXPR_contextFILEFORMAT:
17821 case FFEEXPR_contextFILENAMELIST:
17822 case FFEEXPR_contextFILEVXTCODE:
17823 case FFEEXPR_contextINDEX_:
17824 case FFEEXPR_contextIMPDOITEM_:
17825 case FFEEXPR_contextIMPDOITEMDF_:
17826 case FFEEXPR_contextIMPDOCTRL_:
17827 case FFEEXPR_contextLOC_:
17828 bad = FALSE; /* Let paren-switch handle the cases. */
17829 break;
17830
17831 case FFEEXPR_contextASSIGN:
17832 case FFEEXPR_contextAGOTO:
17833 case FFEEXPR_contextCHARACTERSIZE:
17834 case FFEEXPR_contextEQUIVALENCE:
17835 case FFEEXPR_contextPARAMETER:
17836 case FFEEXPR_contextDIMLIST:
17837 case FFEEXPR_contextDIMLISTCOMMON:
17838 case FFEEXPR_contextKINDTYPE:
17839 case FFEEXPR_contextINITVAL:
17840 case FFEEXPR_contextEQVINDEX_:
17841 bad = (k != FFEINFO_kindENTITY)
17842 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
17843 break;
17844
17845 case FFEEXPR_contextINCLUDE:
17846 bad = TRUE;
17847 break;
17848
17849 default:
17850 bad = TRUE;
17851 break;
17852 }
17853
17854 switch (bad ? FFEINFO_kindANY : k)
17855 {
17856 case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */
17857 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
17858 {
17859 if (ffeexpr_context_outer_ (ffeexpr_stack_)
17860 == FFEEXPR_contextSUBROUTINEREF)
17861 *paren_type = FFEEXPR_parentypeSUBROUTINE_;
17862 else
17863 *paren_type = FFEEXPR_parentypeFUNCTION_;
17864 break;
17865 }
17866 if (st == FFESYMBOL_stateUNDERSTOOD)
17867 {
17868 bad = TRUE;
17869 *paren_type = FFEEXPR_parentypeANY_;
17870 }
17871 else
17872 *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
17873 break;
17874
17875 case FFEINFO_kindFUNCTION:
17876 *paren_type = FFEEXPR_parentypeFUNCTION_;
17877 switch (ffesymbol_where (s))
17878 {
17879 case FFEINFO_whereLOCAL:
17880 bad = TRUE; /* Attempt to recurse! */
17881 break;
17882
17883 case FFEINFO_whereCONSTANT:
17884 bad = ((ffesymbol_sfexpr (s) == NULL)
17885 || (ffebld_op (ffesymbol_sfexpr (s))
17886 == FFEBLD_opANY)); /* Attempt to recurse! */
17887 break;
17888
17889 default:
17890 break;
17891 }
17892 break;
17893
17894 case FFEINFO_kindSUBROUTINE:
17895 if ((ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
17896 || (ffeexpr_stack_->previous != NULL))
17897 {
17898 bad = TRUE;
17899 *paren_type = FFEEXPR_parentypeANY_;
17900 break;
17901 }
17902
17903 *paren_type = FFEEXPR_parentypeSUBROUTINE_;
17904 switch (ffesymbol_where (s))
17905 {
17906 case FFEINFO_whereLOCAL:
17907 case FFEINFO_whereCONSTANT:
17908 bad = TRUE; /* Attempt to recurse! */
17909 break;
17910
17911 default:
17912 break;
17913 }
17914 break;
17915
17916 case FFEINFO_kindENTITY:
17917 if (ffesymbol_rank (s) == 0)
17918 {
17919 if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
17920 *paren_type = FFEEXPR_parentypeSUBSTRING_;
17921 else
17922 {
17923 bad = TRUE;
17924 *paren_type = FFEEXPR_parentypeANY_;
17925 }
17926 }
17927 else
17928 *paren_type = FFEEXPR_parentypeARRAY_;
17929 break;
17930
17931 default:
17932 case FFEINFO_kindANY:
17933 bad = TRUE;
17934 *paren_type = FFEEXPR_parentypeANY_;
17935 break;
17936 }
17937
17938 if (bad)
17939 {
17940 if (k == FFEINFO_kindANY)
17941 ffest_shutdown ();
17942 else
17943 ffesymbol_error (s, t);
17944 }
17945
17946 return s;
17947
17948 case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */
17949 seen: /* :::::::::::::::::::: */
17950 bad = TRUE;
17951 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17952 {
17953 case FFEEXPR_contextPARAMETER:
17954 if (ffeexpr_stack_->is_rhs)
17955 ffesymbol_error (s, t);
17956 else
17957 s = ffeexpr_sym_lhs_parameter_ (s, t);
17958 break;
17959
17960 case FFEEXPR_contextDATA:
17961 s = ffecom_sym_exec_transition (s);
17962 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17963 goto understood; /* :::::::::::::::::::: */
17964 if (ffeexpr_stack_->is_rhs)
17965 ffesymbol_error (s, t);
17966 else
17967 s = ffeexpr_sym_lhs_data_ (s, t);
17968 goto understood; /* :::::::::::::::::::: */
17969
17970 case FFEEXPR_contextDATAIMPDOITEM_:
17971 s = ffecom_sym_exec_transition (s);
17972 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17973 goto understood; /* :::::::::::::::::::: */
17974 s = ffeexpr_sym_lhs_data_ (s, t);
17975 goto understood; /* :::::::::::::::::::: */
17976
17977 case FFEEXPR_contextEQUIVALENCE:
17978 s = ffeexpr_sym_lhs_equivalence_ (s, t);
17979 bad = FALSE;
17980 break;
17981
17982 case FFEEXPR_contextDIMLIST:
17983 s = ffeexpr_sym_rhs_dimlist_ (s, t);
17984 bad = FALSE;
17985 break;
17986
17987 case FFEEXPR_contextCHARACTERSIZE:
17988 case FFEEXPR_contextKINDTYPE:
17989 case FFEEXPR_contextDIMLISTCOMMON:
17990 case FFEEXPR_contextINITVAL:
17991 case FFEEXPR_contextEQVINDEX_:
17992 break;
17993
17994 case FFEEXPR_contextINCLUDE:
17995 break;
17996
17997 case FFEEXPR_contextINDEX_:
17998 case FFEEXPR_contextACTUALARGEXPR_:
17999 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
18000 case FFEEXPR_contextSFUNCDEF:
18001 case FFEEXPR_contextSFUNCDEFINDEX_:
18002 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
18003 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
18004 assert (ffeexpr_stack_->is_rhs);
18005 s = ffecom_sym_exec_transition (s);
18006 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
18007 goto understood; /* :::::::::::::::::::: */
18008 s = ffeexpr_paren_rhs_let_ (s, t);
18009 goto understood; /* :::::::::::::::::::: */
18010
18011 default:
18012 break;
18013 }
18014 k = ffesymbol_kind (s);
18015 switch (bad ? FFEINFO_kindANY : k)
18016 {
18017 case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */
18018 *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
18019 break;
18020
18021 case FFEINFO_kindFUNCTION:
18022 *paren_type = FFEEXPR_parentypeFUNCTION_;
18023 switch (ffesymbol_where (s))
18024 {
18025 case FFEINFO_whereLOCAL:
18026 bad = TRUE; /* Attempt to recurse! */
18027 break;
18028
18029 case FFEINFO_whereCONSTANT:
18030 bad = ((ffesymbol_sfexpr (s) == NULL)
18031 || (ffebld_op (ffesymbol_sfexpr (s))
18032 == FFEBLD_opANY)); /* Attempt to recurse! */
18033 break;
18034
18035 default:
18036 break;
18037 }
18038 break;
18039
18040 case FFEINFO_kindSUBROUTINE:
18041 *paren_type = FFEEXPR_parentypeANY_;
18042 bad = TRUE; /* Cannot possibly be in
18043 contextSUBROUTINEREF. */
18044 break;
18045
18046 case FFEINFO_kindENTITY:
18047 if (ffesymbol_rank (s) == 0)
18048 {
18049 if (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE)
18050 *paren_type = FFEEXPR_parentypeEQUIVALENCE_;
18051 else if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
18052 *paren_type = FFEEXPR_parentypeSUBSTRING_;
18053 else
18054 {
18055 bad = TRUE;
18056 *paren_type = FFEEXPR_parentypeANY_;
18057 }
18058 }
18059 else
18060 *paren_type = FFEEXPR_parentypeARRAY_;
18061 break;
18062
18063 default:
18064 case FFEINFO_kindANY:
18065 bad = TRUE;
18066 *paren_type = FFEEXPR_parentypeANY_;
18067 break;
18068 }
18069
18070 if (bad)
18071 {
18072 if (k == FFEINFO_kindANY)
18073 ffest_shutdown ();
18074 else
18075 ffesymbol_error (s, t);
18076 }
18077
18078 return s;
18079
18080 default:
18081 assert ("bad symbol state" == NULL);
18082 return NULL;
18083 }
18084 }
18085
18086 /* Have FOO in XYZ = ...FOO(...).... Executable context only. */
18087
18088 static ffesymbol
18089 ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t)
18090 {
18091 ffesymbolAttrs sa;
18092 ffesymbolAttrs na;
18093 ffeinfoKind kind;
18094 ffeinfoWhere where;
18095 ffeintrinGen gen;
18096 ffeintrinSpec spec;
18097 ffeintrinImp imp;
18098 bool maybe_ambig = FALSE;
18099 bool error = FALSE;
18100
18101 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
18102 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
18103
18104 na = sa = ffesymbol_attrs (s);
18105
18106 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
18107 | FFESYMBOL_attrsADJUSTABLE
18108 | FFESYMBOL_attrsANYLEN
18109 | FFESYMBOL_attrsARRAY
18110 | FFESYMBOL_attrsDUMMY
18111 | FFESYMBOL_attrsEXTERNAL
18112 | FFESYMBOL_attrsSFARG
18113 | FFESYMBOL_attrsTYPE)));
18114
18115 kind = ffesymbol_kind (s);
18116 where = ffesymbol_where (s);
18117
18118 /* Figure out what kind of object we've got based on previous declarations
18119 of or references to the object. */
18120
18121 if (sa & FFESYMBOL_attrsEXTERNAL)
18122 {
18123 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
18124 | FFESYMBOL_attrsDUMMY
18125 | FFESYMBOL_attrsEXTERNAL
18126 | FFESYMBOL_attrsTYPE)));
18127
18128 if (sa & FFESYMBOL_attrsTYPE)
18129 where = FFEINFO_whereGLOBAL;
18130 else
18131 /* Not TYPE. */
18132 {
18133 kind = FFEINFO_kindFUNCTION;
18134
18135 if (sa & FFESYMBOL_attrsDUMMY)
18136 ; /* Not TYPE. */
18137 else if (sa & FFESYMBOL_attrsACTUALARG)
18138 ; /* Not DUMMY or TYPE. */
18139 else /* Not ACTUALARG, DUMMY, or TYPE. */
18140 where = FFEINFO_whereGLOBAL;
18141 }
18142 }
18143 else if (sa & FFESYMBOL_attrsDUMMY)
18144 {
18145 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
18146 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
18147 | FFESYMBOL_attrsEXTERNAL
18148 | FFESYMBOL_attrsTYPE)));
18149
18150 kind = FFEINFO_kindFUNCTION;
18151 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure; kind
18152 could be ENTITY w/substring ref. */
18153 }
18154 else if (sa & FFESYMBOL_attrsARRAY)
18155 {
18156 assert (!(sa & ~(FFESYMBOL_attrsARRAY
18157 | FFESYMBOL_attrsADJUSTABLE
18158 | FFESYMBOL_attrsTYPE)));
18159
18160 where = FFEINFO_whereLOCAL;
18161 }
18162 else if (sa & FFESYMBOL_attrsSFARG)
18163 {
18164 assert (!(sa & ~(FFESYMBOL_attrsSFARG
18165 | FFESYMBOL_attrsTYPE)));
18166
18167 where = FFEINFO_whereLOCAL; /* Actually an error, but at least we
18168 know it's a local var. */
18169 }
18170 else if (sa & FFESYMBOL_attrsTYPE)
18171 {
18172 assert (!(sa & (FFESYMBOL_attrsARRAY
18173 | FFESYMBOL_attrsDUMMY
18174 | FFESYMBOL_attrsEXTERNAL
18175 | FFESYMBOL_attrsSFARG))); /* Handled above. */
18176 assert (!(sa & ~(FFESYMBOL_attrsTYPE
18177 | FFESYMBOL_attrsADJUSTABLE
18178 | FFESYMBOL_attrsANYLEN
18179 | FFESYMBOL_attrsARRAY
18180 | FFESYMBOL_attrsDUMMY
18181 | FFESYMBOL_attrsEXTERNAL
18182 | FFESYMBOL_attrsSFARG)));
18183
18184 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
18185 &gen, &spec, &imp))
18186 {
18187 if (!(sa & FFESYMBOL_attrsANYLEN)
18188 && (ffeimplic_peek_symbol_type (s, NULL)
18189 == FFEINFO_basictypeCHARACTER))
18190 return s; /* Haven't learned anything yet. */
18191
18192 ffesymbol_signal_change (s); /* May need to back up to previous
18193 version. */
18194 ffesymbol_set_generic (s, gen);
18195 ffesymbol_set_specific (s, spec);
18196 ffesymbol_set_implementation (s, imp);
18197 ffesymbol_set_info (s,
18198 ffeinfo_new (ffesymbol_basictype (s),
18199 ffesymbol_kindtype (s),
18200 0,
18201 FFEINFO_kindFUNCTION,
18202 FFEINFO_whereINTRINSIC,
18203 ffesymbol_size (s)));
18204 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18205 ffesymbol_resolve_intrin (s);
18206 ffesymbol_reference (s, t, FALSE);
18207 s = ffecom_sym_learned (s);
18208 ffesymbol_signal_unreported (s); /* For debugging purposes. */
18209
18210 return s;
18211 }
18212 if (sa & FFESYMBOL_attrsANYLEN)
18213 error = TRUE; /* Error, since the only way we can,
18214 given CHARACTER*(*) FOO, accept
18215 FOO(...) is for FOO to be a dummy
18216 arg or constant, but it can't
18217 become either now. */
18218 else if (sa & FFESYMBOL_attrsADJUSTABLE)
18219 {
18220 kind = FFEINFO_kindENTITY;
18221 where = FFEINFO_whereLOCAL;
18222 }
18223 else
18224 {
18225 kind = FFEINFO_kindFUNCTION;
18226 where = FFEINFO_whereGLOBAL;
18227 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure;
18228 could be ENTITY/LOCAL w/substring ref. */
18229 }
18230 }
18231 else if (sa == FFESYMBOL_attrsetNONE)
18232 {
18233 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
18234
18235 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
18236 &gen, &spec, &imp))
18237 {
18238 if (ffeimplic_peek_symbol_type (s, NULL)
18239 == FFEINFO_basictypeCHARACTER)
18240 return s; /* Haven't learned anything yet. */
18241
18242 ffesymbol_signal_change (s); /* May need to back up to previous
18243 version. */
18244 ffesymbol_set_generic (s, gen);
18245 ffesymbol_set_specific (s, spec);
18246 ffesymbol_set_implementation (s, imp);
18247 ffesymbol_set_info (s,
18248 ffeinfo_new (ffesymbol_basictype (s),
18249 ffesymbol_kindtype (s),
18250 0,
18251 FFEINFO_kindFUNCTION,
18252 FFEINFO_whereINTRINSIC,
18253 ffesymbol_size (s)));
18254 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18255 ffesymbol_resolve_intrin (s);
18256 s = ffecom_sym_learned (s);
18257 ffesymbol_reference (s, t, FALSE);
18258 ffesymbol_signal_unreported (s); /* For debugging purposes. */
18259 return s;
18260 }
18261
18262 kind = FFEINFO_kindFUNCTION;
18263 where = FFEINFO_whereGLOBAL;
18264 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure;
18265 could be ENTITY/LOCAL w/substring ref. */
18266 }
18267 else
18268 error = TRUE;
18269
18270 /* Now see what we've got for a new object: NONE means a new error cropped
18271 up; ANY means an old error to be ignored; otherwise, everything's ok,
18272 update the object (symbol) and continue on. */
18273
18274 if (error)
18275 ffesymbol_error (s, t);
18276 else if (!(na & FFESYMBOL_attrsANY))
18277 {
18278 ffesymbol_signal_change (s); /* May need to back up to previous
18279 version. */
18280 if (!ffeimplic_establish_symbol (s))
18281 {
18282 ffesymbol_error (s, t);
18283 return s;
18284 }
18285 if (maybe_ambig
18286 && (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
18287 return s; /* Still not sure, let caller deal with it
18288 based on (...). */
18289
18290 ffesymbol_set_info (s,
18291 ffeinfo_new (ffesymbol_basictype (s),
18292 ffesymbol_kindtype (s),
18293 ffesymbol_rank (s),
18294 kind,
18295 where,
18296 ffesymbol_size (s)));
18297 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18298 ffesymbol_resolve_intrin (s);
18299 s = ffecom_sym_learned (s);
18300 ffesymbol_reference (s, t, FALSE);
18301 ffesymbol_signal_unreported (s); /* For debugging purposes. */
18302 }
18303
18304 return s;
18305 }
18306
18307 /* ffeexpr_token_arguments_ -- OPEN_PAREN [expr COMMA]...expr
18308
18309 Return a pointer to this function to the lexer (ffelex), which will
18310 invoke it for the next token.
18311
18312 Handle expression (which might be null) and COMMA or CLOSE_PAREN. */
18313
18314 static ffelexHandler
18315 ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr, ffelexToken t)
18316 {
18317 ffeexprExpr_ procedure;
18318 ffebld reduced;
18319 ffeinfo info;
18320 ffeexprContext ctx;
18321 bool check_intrin = FALSE; /* Set TRUE if intrinsic is REAL(Z) or AIMAG(Z). */
18322
18323 procedure = ffeexpr_stack_->exprstack;
18324 info = ffebld_info (procedure->u.operand);
18325
18326 /* Is there an expression to add? If the expression is nil,
18327 it might still be an argument. It is if:
18328
18329 - The current token is comma, or
18330
18331 - The -fugly-comma flag was specified *and* the procedure
18332 being invoked is external.
18333
18334 Otherwise, if neither of the above is the case, just
18335 ignore this (nil) expression. */
18336
18337 if ((expr != NULL)
18338 || (ffelex_token_type (t) == FFELEX_typeCOMMA)
18339 || (ffe_is_ugly_comma ()
18340 && (ffeinfo_where (info) == FFEINFO_whereGLOBAL)))
18341 {
18342 /* This expression, even if nil, is apparently intended as an argument. */
18343
18344 /* Internal procedure (CONTAINS, or statement function)? */
18345
18346 if (ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18347 {
18348 if ((expr == NULL)
18349 && ffebad_start (FFEBAD_NULL_ARGUMENT))
18350 {
18351 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18352 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18353 ffebad_here (1, ffelex_token_where_line (t),
18354 ffelex_token_where_column (t));
18355 ffebad_finish ();
18356 }
18357
18358 if (expr == NULL)
18359 ;
18360 else
18361 {
18362 if (ffeexpr_stack_->next_dummy == NULL)
18363 { /* Report later which was the first extra argument. */
18364 if (ffeexpr_stack_->tokens[1] == NULL)
18365 {
18366 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
18367 ffeexpr_stack_->num_args = 0;
18368 }
18369 ++ffeexpr_stack_->num_args; /* Count # of extra arguments. */
18370 }
18371 else
18372 {
18373 if ((ffeinfo_rank (ffebld_info (expr)) != 0)
18374 && ffebad_start (FFEBAD_ARRAY_AS_SFARG))
18375 {
18376 ffebad_here (0,
18377 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18378 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18379 ffebad_here (1, ffelex_token_where_line (ft),
18380 ffelex_token_where_column (ft));
18381 ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent
18382 (ffebld_symter (ffebld_head
18383 (ffeexpr_stack_->next_dummy)))));
18384 ffebad_finish ();
18385 }
18386 else
18387 {
18388 expr = ffeexpr_convert_expr (expr, ft,
18389 ffebld_head (ffeexpr_stack_->next_dummy),
18390 ffeexpr_stack_->tokens[0],
18391 FFEEXPR_contextLET);
18392 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18393 }
18394 --ffeexpr_stack_->num_args; /* Count down # of args. */
18395 ffeexpr_stack_->next_dummy
18396 = ffebld_trail (ffeexpr_stack_->next_dummy);
18397 }
18398 }
18399 }
18400 else
18401 {
18402 if ((expr == NULL)
18403 && ffe_is_pedantic ()
18404 && ffebad_start (FFEBAD_NULL_ARGUMENT_W))
18405 {
18406 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18407 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18408 ffebad_here (1, ffelex_token_where_line (t),
18409 ffelex_token_where_column (t));
18410 ffebad_finish ();
18411 }
18412 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18413 }
18414 }
18415
18416 switch (ffelex_token_type (t))
18417 {
18418 case FFELEX_typeCOMMA:
18419 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
18420 {
18421 case FFEEXPR_contextSFUNCDEF:
18422 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
18423 case FFEEXPR_contextSFUNCDEFINDEX_:
18424 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
18425 ctx = FFEEXPR_contextSFUNCDEFACTUALARG_;
18426 break;
18427
18428 case FFEEXPR_contextSFUNCDEFACTUALARG_:
18429 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18430 assert ("bad context" == NULL);
18431 ctx = FFEEXPR_context;
18432 break;
18433
18434 default:
18435 ctx = FFEEXPR_contextACTUALARG_;
18436 break;
18437 }
18438 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18439 ffeexpr_token_arguments_);
18440
18441 default:
18442 break;
18443 }
18444
18445 if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18446 && (ffeexpr_stack_->next_dummy != NULL))
18447 { /* Too few arguments. */
18448 if (ffebad_start (FFEBAD_TOO_FEW_ARGUMENTS))
18449 {
18450 char num[10];
18451
18452 sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
18453
18454 ffebad_here (0, ffelex_token_where_line (t),
18455 ffelex_token_where_column (t));
18456 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18457 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18458 ffebad_string (num);
18459 ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent (ffebld_symter
18460 (ffebld_head (ffeexpr_stack_->next_dummy)))));
18461 ffebad_finish ();
18462 }
18463 for (;
18464 ffeexpr_stack_->next_dummy != NULL;
18465 ffeexpr_stack_->next_dummy
18466 = ffebld_trail (ffeexpr_stack_->next_dummy))
18467 {
18468 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0));
18469 ffebld_set_info (expr, ffeinfo_new_any ());
18470 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18471 }
18472 }
18473
18474 if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18475 && (ffeexpr_stack_->tokens[1] != NULL))
18476 { /* Too many arguments to statement function. */
18477 if (ffebad_start (FFEBAD_TOO_MANY_ARGUMENTS))
18478 {
18479 char num[10];
18480
18481 sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
18482
18483 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
18484 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
18485 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18486 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18487 ffebad_string (num);
18488 ffebad_finish ();
18489 }
18490 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
18491 }
18492 ffebld_end_list (&ffeexpr_stack_->bottom);
18493
18494 if (ffebld_op (procedure->u.operand) == FFEBLD_opANY)
18495 {
18496 reduced = ffebld_new_any ();
18497 ffebld_set_info (reduced, ffeinfo_new_any ());
18498 }
18499 else
18500 {
18501 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
18502 reduced = ffebld_new_funcref (procedure->u.operand,
18503 ffeexpr_stack_->expr);
18504 else
18505 reduced = ffebld_new_subrref (procedure->u.operand,
18506 ffeexpr_stack_->expr);
18507 if (ffebld_symter_generic (procedure->u.operand) != FFEINTRIN_genNONE)
18508 ffeintrin_fulfill_generic (&reduced, &info, ffeexpr_stack_->tokens[0]);
18509 else if (ffebld_symter_specific (procedure->u.operand)
18510 != FFEINTRIN_specNONE)
18511 ffeintrin_fulfill_specific (&reduced, &info, &check_intrin,
18512 ffeexpr_stack_->tokens[0]);
18513 else
18514 ffeexpr_fulfill_call_ (&reduced, ffeexpr_stack_->tokens[0]);
18515
18516 if (ffebld_op (reduced) != FFEBLD_opANY)
18517 ffebld_set_info (reduced,
18518 ffeinfo_new (ffeinfo_basictype (info),
18519 ffeinfo_kindtype (info),
18520 0,
18521 FFEINFO_kindENTITY,
18522 FFEINFO_whereFLEETING,
18523 ffeinfo_size (info)));
18524 else
18525 ffebld_set_info (reduced, ffeinfo_new_any ());
18526 }
18527 if (ffebld_op (reduced) == FFEBLD_opFUNCREF)
18528 reduced = ffeexpr_collapse_funcref (reduced, ffeexpr_stack_->tokens[0]);
18529 ffeexpr_stack_->exprstack = procedure->previous; /* Pops
18530 not-quite-operand off
18531 stack. */
18532 procedure->u.operand = reduced; /* Save the line/column ffewhere
18533 info. */
18534 ffeexpr_exprstack_push_operand_ (procedure); /* Push it back on stack. */
18535 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18536 {
18537 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18538 ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FUNC(3)(1:1)".... */
18539
18540 /* If the intrinsic needs checking (is REAL(Z) or AIMAG(Z), where
18541 Z is DOUBLE COMPLEX), and a command-line option doesn't already
18542 establish interpretation, probably complain. */
18543
18544 if (check_intrin
18545 && !ffe_is_90 ()
18546 && !ffe_is_ugly_complex ())
18547 {
18548 /* If the outer expression is REAL(me...), issue diagnostic
18549 only if next token isn't the close-paren for REAL(me). */
18550
18551 if ((ffeexpr_stack_->previous != NULL)
18552 && (ffeexpr_stack_->previous->exprstack != NULL)
18553 && (ffeexpr_stack_->previous->exprstack->type == FFEEXPR_exprtypeOPERAND_)
18554 && ((reduced = ffeexpr_stack_->previous->exprstack->u.operand) != NULL)
18555 && (ffebld_op (reduced) == FFEBLD_opSYMTER)
18556 && (ffebld_symter_implementation (reduced) == FFEINTRIN_impREAL))
18557 return (ffelexHandler) ffeexpr_token_intrincheck_;
18558
18559 /* Diagnose the ambiguity now. */
18560
18561 if (ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
18562 {
18563 ffebad_string (ffeintrin_name_implementation
18564 (ffebld_symter_implementation
18565 (ffebld_left
18566 (ffeexpr_stack_->exprstack->u.operand))));
18567 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
18568 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
18569 ffebad_finish ();
18570 }
18571 }
18572 return (ffelexHandler) ffeexpr_token_substrp_;
18573 }
18574
18575 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
18576 {
18577 ffebad_here (0, ffelex_token_where_line (t),
18578 ffelex_token_where_column (t));
18579 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18580 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18581 ffebad_finish ();
18582 }
18583 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18584 ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FUNC(3)(1:1)".... */
18585 return
18586 (ffelexHandler) ffeexpr_find_close_paren_ (t,
18587 (ffelexHandler)
18588 ffeexpr_token_substrp_);
18589 }
18590
18591 /* ffeexpr_token_elements_ -- OPEN_PAREN [expr COMMA]...expr
18592
18593 Return a pointer to this array to the lexer (ffelex), which will
18594 invoke it for the next token.
18595
18596 Handle expression and COMMA or CLOSE_PAREN. */
18597
18598 static ffelexHandler
18599 ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, ffelexToken t)
18600 {
18601 ffeexprExpr_ array;
18602 ffebld reduced;
18603 ffeinfo info;
18604 ffeinfoWhere where;
18605 ffetargetIntegerDefault val;
18606 ffetargetIntegerDefault lval = 0;
18607 ffetargetIntegerDefault uval = 0;
18608 ffebld lbound;
18609 ffebld ubound;
18610 bool lcheck;
18611 bool ucheck;
18612
18613 array = ffeexpr_stack_->exprstack;
18614 info = ffebld_info (array->u.operand);
18615
18616 if ((expr == NULL) /* && ((ffeexpr_stack_->rank != 0) ||
18617 (ffelex_token_type(t) ==
18618 FFELEX_typeCOMMA)) */ )
18619 {
18620 if (ffebad_start (FFEBAD_NULL_ELEMENT))
18621 {
18622 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18623 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18624 ffebad_here (1, ffelex_token_where_line (t),
18625 ffelex_token_where_column (t));
18626 ffebad_finish ();
18627 }
18628 if (ffeexpr_stack_->rank < ffeinfo_rank (info))
18629 { /* Don't bother if we're going to complain
18630 later! */
18631 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
18632 ffebld_set_info (expr, ffeinfo_new_any ());
18633 }
18634 }
18635
18636 if (expr == NULL)
18637 ;
18638 else if (ffeinfo_rank (info) == 0)
18639 { /* In EQUIVALENCE context, ffeinfo_rank(info)
18640 may == 0. */
18641 ++ffeexpr_stack_->rank; /* Track anyway, may need for new VXT
18642 feature. */
18643 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18644 }
18645 else
18646 {
18647 ++ffeexpr_stack_->rank;
18648 if (ffeexpr_stack_->rank > ffeinfo_rank (info))
18649 { /* Report later which was the first extra
18650 element. */
18651 if (ffeexpr_stack_->rank == ffeinfo_rank (info) + 1)
18652 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
18653 }
18654 else
18655 {
18656 switch (ffeinfo_where (ffebld_info (expr)))
18657 {
18658 case FFEINFO_whereCONSTANT:
18659 break;
18660
18661 case FFEINFO_whereIMMEDIATE:
18662 ffeexpr_stack_->constant = FALSE;
18663 break;
18664
18665 default:
18666 ffeexpr_stack_->constant = FALSE;
18667 ffeexpr_stack_->immediate = FALSE;
18668 break;
18669 }
18670 if (ffebld_op (expr) == FFEBLD_opCONTER
18671 && ffebld_kindtype (expr) == FFEINFO_kindtypeINTEGERDEFAULT)
18672 {
18673 val = ffebld_constant_integerdefault (ffebld_conter (expr));
18674
18675 lbound = ffebld_left (ffebld_head (ffeexpr_stack_->bound_list));
18676 if (lbound == NULL)
18677 {
18678 lcheck = TRUE;
18679 lval = 1;
18680 }
18681 else if (ffebld_op (lbound) == FFEBLD_opCONTER)
18682 {
18683 lcheck = TRUE;
18684 lval = ffebld_constant_integerdefault (ffebld_conter (lbound));
18685 }
18686 else
18687 lcheck = FALSE;
18688
18689 ubound = ffebld_right (ffebld_head (ffeexpr_stack_->bound_list));
18690 assert (ubound != NULL);
18691 if (ffebld_op (ubound) == FFEBLD_opCONTER)
18692 {
18693 ucheck = TRUE;
18694 uval = ffebld_constant_integerdefault (ffebld_conter (ubound));
18695 }
18696 else
18697 ucheck = FALSE;
18698
18699 if ((lcheck && (val < lval)) || (ucheck && (val > uval)))
18700 {
18701 ffebad_start (FFEBAD_RANGE_ARRAY);
18702 ffebad_here (0, ffelex_token_where_line (ft),
18703 ffelex_token_where_column (ft));
18704 ffebad_finish ();
18705 }
18706 }
18707 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18708 ffeexpr_stack_->bound_list = ffebld_trail (ffeexpr_stack_->bound_list);
18709 }
18710 }
18711
18712 switch (ffelex_token_type (t))
18713 {
18714 case FFELEX_typeCOMMA:
18715 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
18716 {
18717 case FFEEXPR_contextDATAIMPDOITEM_:
18718 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18719 FFEEXPR_contextDATAIMPDOINDEX_,
18720 ffeexpr_token_elements_);
18721
18722 case FFEEXPR_contextEQUIVALENCE:
18723 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18724 FFEEXPR_contextEQVINDEX_,
18725 ffeexpr_token_elements_);
18726
18727 case FFEEXPR_contextSFUNCDEF:
18728 case FFEEXPR_contextSFUNCDEFINDEX_:
18729 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18730 FFEEXPR_contextSFUNCDEFINDEX_,
18731 ffeexpr_token_elements_);
18732
18733 case FFEEXPR_contextSFUNCDEFACTUALARG_:
18734 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18735 assert ("bad context" == NULL);
18736 break;
18737
18738 default:
18739 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18740 FFEEXPR_contextINDEX_,
18741 ffeexpr_token_elements_);
18742 }
18743
18744 default:
18745 break;
18746 }
18747
18748 if ((ffeexpr_stack_->rank != ffeinfo_rank (info))
18749 && (ffeinfo_rank (info) != 0))
18750 {
18751 char num[10];
18752
18753 if (ffeexpr_stack_->rank < ffeinfo_rank (info))
18754 {
18755 if (ffebad_start (FFEBAD_TOO_FEW_ELEMENTS))
18756 {
18757 sprintf (num, "%d",
18758 (int) (ffeinfo_rank (info) - ffeexpr_stack_->rank));
18759
18760 ffebad_here (0, ffelex_token_where_line (t),
18761 ffelex_token_where_column (t));
18762 ffebad_here (1,
18763 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18764 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18765 ffebad_string (num);
18766 ffebad_finish ();
18767 }
18768 }
18769 else
18770 {
18771 if (ffebad_start (FFEBAD_TOO_MANY_ELEMENTS))
18772 {
18773 sprintf (num, "%d",
18774 (int) (ffeexpr_stack_->rank - ffeinfo_rank (info)));
18775
18776 ffebad_here (0,
18777 ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
18778 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
18779 ffebad_here (1,
18780 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18781 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18782 ffebad_string (num);
18783 ffebad_finish ();
18784 }
18785 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
18786 }
18787 while (ffeexpr_stack_->rank++ < ffeinfo_rank (info))
18788 {
18789 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
18790 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeINTEGER,
18791 FFEINFO_kindtypeINTEGERDEFAULT,
18792 0, FFEINFO_kindENTITY,
18793 FFEINFO_whereCONSTANT,
18794 FFETARGET_charactersizeNONE));
18795 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18796 }
18797 }
18798 ffebld_end_list (&ffeexpr_stack_->bottom);
18799
18800 if (ffebld_op (array->u.operand) == FFEBLD_opANY)
18801 {
18802 reduced = ffebld_new_any ();
18803 ffebld_set_info (reduced, ffeinfo_new_any ());
18804 }
18805 else
18806 {
18807 reduced = ffebld_new_arrayref (array->u.operand, ffeexpr_stack_->expr);
18808 if (ffeexpr_stack_->constant)
18809 where = FFEINFO_whereFLEETING_CADDR;
18810 else if (ffeexpr_stack_->immediate)
18811 where = FFEINFO_whereFLEETING_IADDR;
18812 else
18813 where = FFEINFO_whereFLEETING;
18814 ffebld_set_info (reduced,
18815 ffeinfo_new (ffeinfo_basictype (info),
18816 ffeinfo_kindtype (info),
18817 0,
18818 FFEINFO_kindENTITY,
18819 where,
18820 ffeinfo_size (info)));
18821 reduced = ffeexpr_collapse_arrayref (reduced, ffeexpr_stack_->tokens[0]);
18822 }
18823
18824 ffeexpr_stack_->exprstack = array->previous; /* Pops not-quite-operand off
18825 stack. */
18826 array->u.operand = reduced; /* Save the line/column ffewhere info. */
18827 ffeexpr_exprstack_push_operand_ (array); /* Push it back on stack. */
18828
18829 switch (ffeinfo_basictype (info))
18830 {
18831 case FFEINFO_basictypeCHARACTER:
18832 ffeexpr_is_substr_ok_ = TRUE; /* Everyone likes "FOO(3)(1:1)".... */
18833 break;
18834
18835 case FFEINFO_basictypeNONE:
18836 ffeexpr_is_substr_ok_ = TRUE;
18837 assert (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE);
18838 break;
18839
18840 default:
18841 ffeexpr_is_substr_ok_ = FALSE;
18842 break;
18843 }
18844
18845 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18846 {
18847 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18848 return (ffelexHandler) ffeexpr_token_substrp_;
18849 }
18850
18851 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
18852 {
18853 ffebad_here (0, ffelex_token_where_line (t),
18854 ffelex_token_where_column (t));
18855 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18856 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18857 ffebad_finish ();
18858 }
18859 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18860 return
18861 (ffelexHandler) ffeexpr_find_close_paren_ (t,
18862 (ffelexHandler)
18863 ffeexpr_token_substrp_);
18864 }
18865
18866 /* ffeexpr_token_equivalence_ -- OPEN_PAREN expr
18867
18868 Return a pointer to this array to the lexer (ffelex), which will
18869 invoke it for the next token.
18870
18871 If token is COLON, pass off to _substr_, else init list and pass off
18872 to _elements_. This handles the case "EQUIVALENCE (FOO(expr?", where
18873 ? marks the token, and where FOO's rank/type has not yet been established,
18874 meaning we could be in a list of indices or in a substring
18875 specification. */
18876
18877 static ffelexHandler
18878 ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr, ffelexToken t)
18879 {
18880 if (ffelex_token_type (t) == FFELEX_typeCOLON)
18881 return ffeexpr_token_substring_ (ft, expr, t);
18882
18883 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
18884 return ffeexpr_token_elements_ (ft, expr, t);
18885 }
18886
18887 /* ffeexpr_token_substring_ -- NAME(of kindENTITY) OPEN_PAREN expr
18888
18889 Return a pointer to this function to the lexer (ffelex), which will
18890 invoke it for the next token.
18891
18892 Handle expression (which may be null) and COLON. */
18893
18894 static ffelexHandler
18895 ffeexpr_token_substring_ (ffelexToken ft, ffebld expr, ffelexToken t)
18896 {
18897 ffeexprExpr_ string;
18898 ffeinfo info;
18899 ffetargetIntegerDefault i;
18900 ffeexprContext ctx;
18901 ffetargetCharacterSize size;
18902
18903 string = ffeexpr_stack_->exprstack;
18904 info = ffebld_info (string->u.operand);
18905 size = ffebld_size_max (string->u.operand);
18906
18907 if (ffelex_token_type (t) == FFELEX_typeCOLON)
18908 {
18909 if ((expr != NULL)
18910 && (ffebld_op (expr) == FFEBLD_opCONTER)
18911 && (((i = ffebld_constant_integerdefault (ffebld_conter (expr)))
18912 < 1)
18913 || ((size != FFETARGET_charactersizeNONE) && (i > size))))
18914 {
18915 ffebad_start (FFEBAD_RANGE_SUBSTR);
18916 ffebad_here (0, ffelex_token_where_line (ft),
18917 ffelex_token_where_column (ft));
18918 ffebad_finish ();
18919 }
18920 ffeexpr_stack_->expr = expr;
18921
18922 switch (ffeexpr_stack_->context)
18923 {
18924 case FFEEXPR_contextSFUNCDEF:
18925 case FFEEXPR_contextSFUNCDEFINDEX_:
18926 ctx = FFEEXPR_contextSFUNCDEFINDEX_;
18927 break;
18928
18929 case FFEEXPR_contextSFUNCDEFACTUALARG_:
18930 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18931 assert ("bad context" == NULL);
18932 ctx = FFEEXPR_context;
18933 break;
18934
18935 default:
18936 ctx = FFEEXPR_contextINDEX_;
18937 break;
18938 }
18939
18940 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18941 ffeexpr_token_substring_1_);
18942 }
18943
18944 if (ffest_ffebad_start (FFEBAD_MISSING_COLON_IN_SUBSTR))
18945 {
18946 ffebad_here (0, ffelex_token_where_line (t),
18947 ffelex_token_where_column (t));
18948 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18949 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18950 ffebad_finish ();
18951 }
18952
18953 ffeexpr_stack_->expr = NULL;
18954 return (ffelexHandler) ffeexpr_token_substring_1_ (ft, expr, t);
18955 }
18956
18957 /* ffeexpr_token_substring_1_ -- NAME OPEN_PAREN [expr COMMA]...expr
18958
18959 Return a pointer to this function to the lexer (ffelex), which will
18960 invoke it for the next token.
18961
18962 Handle expression (which might be null) and CLOSE_PAREN. */
18963
18964 static ffelexHandler
18965 ffeexpr_token_substring_1_ (ffelexToken ft, ffebld last, ffelexToken t)
18966 {
18967 ffeexprExpr_ string;
18968 ffebld reduced;
18969 ffebld substrlist;
18970 ffebld first = ffeexpr_stack_->expr;
18971 ffebld strop;
18972 ffeinfo info;
18973 ffeinfoWhere lwh;
18974 ffeinfoWhere rwh;
18975 ffeinfoWhere where;
18976 ffeinfoKindtype first_kt;
18977 ffeinfoKindtype last_kt;
18978 ffetargetIntegerDefault first_val;
18979 ffetargetIntegerDefault last_val;
18980 ffetargetCharacterSize size;
18981 ffetargetCharacterSize strop_size_max;
18982 bool first_known;
18983
18984 string = ffeexpr_stack_->exprstack;
18985 strop = string->u.operand;
18986 info = ffebld_info (strop);
18987
18988 if (first == NULL
18989 || (ffebld_op (first) == FFEBLD_opCONTER
18990 && ffebld_kindtype (first) == FFEINFO_kindtypeINTEGERDEFAULT))
18991 { /* The starting point is known. */
18992 first_val = (first == NULL) ? 1
18993 : ffebld_constant_integerdefault (ffebld_conter (first));
18994 first_known = TRUE;
18995 }
18996 else
18997 { /* Assume start of the entity. */
18998 first_val = 1;
18999 first_known = FALSE;
19000 }
19001
19002 if (last != NULL
19003 && (ffebld_op (last) == FFEBLD_opCONTER
19004 && ffebld_kindtype (last) == FFEINFO_kindtypeINTEGERDEFAULT))
19005 { /* The ending point is known. */
19006 last_val = ffebld_constant_integerdefault (ffebld_conter (last));
19007
19008 if (first_known)
19009 { /* The beginning point is a constant. */
19010 if (first_val <= last_val)
19011 size = last_val - first_val + 1;
19012 else
19013 {
19014 if (0 && ffe_is_90 ())
19015 size = 0;
19016 else
19017 {
19018 size = 1;
19019 ffebad_start (FFEBAD_ZERO_SIZE);
19020 ffebad_here (0, ffelex_token_where_line (ft),
19021 ffelex_token_where_column (ft));
19022 ffebad_finish ();
19023 }
19024 }
19025 }
19026 else
19027 size = FFETARGET_charactersizeNONE;
19028
19029 strop_size_max = ffebld_size_max (strop);
19030
19031 if ((strop_size_max != FFETARGET_charactersizeNONE)
19032 && (last_val > strop_size_max))
19033 { /* Beyond maximum possible end of string. */
19034 ffebad_start (FFEBAD_RANGE_SUBSTR);
19035 ffebad_here (0, ffelex_token_where_line (ft),
19036 ffelex_token_where_column (ft));
19037 ffebad_finish ();
19038 }
19039 }
19040 else
19041 size = FFETARGET_charactersizeNONE; /* The size is not known. */
19042
19043 #if 0 /* Don't do this, or "is size of target
19044 known?" would no longer be easily
19045 answerable. To see if there is a max
19046 size, use ffebld_size_max; to get only the
19047 known size, else NONE, use
19048 ffebld_size_known; use ffebld_size if
19049 values are sure to be the same (not
19050 opSUBSTR or opCONCATENATE or known to have
19051 known length). By getting rid of this
19052 "useful info" stuff, we don't end up
19053 blank-padding the constant in the
19054 assignment "A(I:J)='XYZ'" to the known
19055 length of A. */
19056 if (size == FFETARGET_charactersizeNONE)
19057 size = strop_size_max; /* Assume we use the entire string. */
19058 #endif
19059
19060 substrlist
19061 = ffebld_new_item
19062 (first,
19063 ffebld_new_item
19064 (last,
19065 NULL
19066 )
19067 )
19068 ;
19069
19070 if (first == NULL)
19071 lwh = FFEINFO_whereCONSTANT;
19072 else
19073 lwh = ffeinfo_where (ffebld_info (first));
19074 if (last == NULL)
19075 rwh = FFEINFO_whereCONSTANT;
19076 else
19077 rwh = ffeinfo_where (ffebld_info (last));
19078
19079 switch (lwh)
19080 {
19081 case FFEINFO_whereCONSTANT:
19082 switch (rwh)
19083 {
19084 case FFEINFO_whereCONSTANT:
19085 where = FFEINFO_whereCONSTANT;
19086 break;
19087
19088 case FFEINFO_whereIMMEDIATE:
19089 where = FFEINFO_whereIMMEDIATE;
19090 break;
19091
19092 default:
19093 where = FFEINFO_whereFLEETING;
19094 break;
19095 }
19096 break;
19097
19098 case FFEINFO_whereIMMEDIATE:
19099 switch (rwh)
19100 {
19101 case FFEINFO_whereCONSTANT:
19102 case FFEINFO_whereIMMEDIATE:
19103 where = FFEINFO_whereIMMEDIATE;
19104 break;
19105
19106 default:
19107 where = FFEINFO_whereFLEETING;
19108 break;
19109 }
19110 break;
19111
19112 default:
19113 where = FFEINFO_whereFLEETING;
19114 break;
19115 }
19116
19117 if (first == NULL)
19118 first_kt = FFEINFO_kindtypeINTEGERDEFAULT;
19119 else
19120 first_kt = ffeinfo_kindtype (ffebld_info (first));
19121 if (last == NULL)
19122 last_kt = FFEINFO_kindtypeINTEGERDEFAULT;
19123 else
19124 last_kt = ffeinfo_kindtype (ffebld_info (last));
19125
19126 switch (where)
19127 {
19128 case FFEINFO_whereCONSTANT:
19129 switch (ffeinfo_where (info))
19130 {
19131 case FFEINFO_whereCONSTANT:
19132 break;
19133
19134 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
19135 where = FFEINFO_whereIMMEDIATE;
19136 break;
19137
19138 default:
19139 where = FFEINFO_whereFLEETING_CADDR;
19140 break;
19141 }
19142 break;
19143
19144 case FFEINFO_whereIMMEDIATE:
19145 switch (ffeinfo_where (info))
19146 {
19147 case FFEINFO_whereCONSTANT:
19148 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
19149 break;
19150
19151 default:
19152 where = FFEINFO_whereFLEETING_IADDR;
19153 break;
19154 }
19155 break;
19156
19157 default:
19158 switch (ffeinfo_where (info))
19159 {
19160 case FFEINFO_whereCONSTANT:
19161 where = FFEINFO_whereCONSTANT_SUBOBJECT; /* An F90 concept. */
19162 break;
19163
19164 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
19165 default:
19166 where = FFEINFO_whereFLEETING;
19167 break;
19168 }
19169 break;
19170 }
19171
19172 if (ffebld_op (strop) == FFEBLD_opANY)
19173 {
19174 reduced = ffebld_new_any ();
19175 ffebld_set_info (reduced, ffeinfo_new_any ());
19176 }
19177 else
19178 {
19179 reduced = ffebld_new_substr (strop, substrlist);
19180 ffebld_set_info (reduced, ffeinfo_new
19181 (FFEINFO_basictypeCHARACTER,
19182 ffeinfo_kindtype (info),
19183 0,
19184 FFEINFO_kindENTITY,
19185 where,
19186 size));
19187 reduced = ffeexpr_collapse_substr (reduced, ffeexpr_stack_->tokens[0]);
19188 }
19189
19190 ffeexpr_stack_->exprstack = string->previous; /* Pops not-quite-operand off
19191 stack. */
19192 string->u.operand = reduced; /* Save the line/column ffewhere info. */
19193 ffeexpr_exprstack_push_operand_ (string); /* Push it back on stack. */
19194
19195 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
19196 {
19197 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19198 ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FOO(3:5)(1:1)".... */
19199 return (ffelexHandler) ffeexpr_token_substrp_;
19200 }
19201
19202 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
19203 {
19204 ffebad_here (0, ffelex_token_where_line (t),
19205 ffelex_token_where_column (t));
19206 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
19207 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
19208 ffebad_finish ();
19209 }
19210
19211 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19212 ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FOO(3:5)(1:1)".... */
19213 return
19214 (ffelexHandler) ffeexpr_find_close_paren_ (t,
19215 (ffelexHandler)
19216 ffeexpr_token_substrp_);
19217 }
19218
19219 /* ffeexpr_token_substrp_ -- Rhs <character entity>
19220
19221 Return a pointer to this function to the lexer (ffelex), which will
19222 invoke it for the next token.
19223
19224 If OPEN_PAREN, treat as start of a substring ("(3:4)") construct, and
19225 issue error message if flag (serves as argument) is set. Else, just
19226 forward token to binary_. */
19227
19228 static ffelexHandler
19229 ffeexpr_token_substrp_ (ffelexToken t)
19230 {
19231 ffeexprContext ctx;
19232
19233 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
19234 return (ffelexHandler) ffeexpr_token_binary_ (t);
19235
19236 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
19237
19238 switch (ffeexpr_stack_->context)
19239 {
19240 case FFEEXPR_contextSFUNCDEF:
19241 case FFEEXPR_contextSFUNCDEFINDEX_:
19242 ctx = FFEEXPR_contextSFUNCDEFINDEX_;
19243 break;
19244
19245 case FFEEXPR_contextSFUNCDEFACTUALARG_:
19246 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
19247 assert ("bad context" == NULL);
19248 ctx = FFEEXPR_context;
19249 break;
19250
19251 default:
19252 ctx = FFEEXPR_contextINDEX_;
19253 break;
19254 }
19255
19256 if (!ffeexpr_is_substr_ok_)
19257 {
19258 if (ffebad_start (FFEBAD_BAD_SUBSTR))
19259 {
19260 ffebad_here (0, ffelex_token_where_line (t),
19261 ffelex_token_where_column (t));
19262 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
19263 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
19264 ffebad_finish ();
19265 }
19266
19267 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
19268 ffeexpr_token_anything_);
19269 }
19270
19271 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
19272 ffeexpr_token_substring_);
19273 }
19274
19275 static ffelexHandler
19276 ffeexpr_token_intrincheck_ (ffelexToken t)
19277 {
19278 if ((ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
19279 && ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
19280 {
19281 ffebad_string (ffeintrin_name_implementation
19282 (ffebld_symter_implementation
19283 (ffebld_left
19284 (ffeexpr_stack_->exprstack->u.operand))));
19285 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
19286 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
19287 ffebad_finish ();
19288 }
19289
19290 return (ffelexHandler) ffeexpr_token_substrp_ (t);
19291 }
19292
19293 /* ffeexpr_token_funsubstr_ -- NAME OPEN_PAREN expr
19294
19295 Return a pointer to this function to the lexer (ffelex), which will
19296 invoke it for the next token.
19297
19298 If COLON, do everything we would have done since _parenthesized_ if
19299 we had known NAME represented a kindENTITY instead of a kindFUNCTION.
19300 If not COLON, do likewise for kindFUNCTION instead. */
19301
19302 static ffelexHandler
19303 ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr, ffelexToken t)
19304 {
19305 ffeinfoWhere where;
19306 ffesymbol s;
19307 ffesymbolAttrs sa;
19308 ffebld symter = ffeexpr_stack_->exprstack->u.operand;
19309 bool needs_type;
19310 ffeintrinGen gen;
19311 ffeintrinSpec spec;
19312 ffeintrinImp imp;
19313
19314 s = ffebld_symter (symter);
19315 sa = ffesymbol_attrs (s);
19316 where = ffesymbol_where (s);
19317
19318 /* We get here only if we don't already know enough about FOO when seeing a
19319 FOO(stuff) reference, and FOO might turn out to be a CHARACTER type. If
19320 "stuff" is a substring reference, then FOO is a CHARACTER scalar type.
19321 Else FOO is a function, either intrinsic or external. If intrinsic, it
19322 wouldn't necessarily be CHARACTER type, so unless it has already been
19323 declared DUMMY, it hasn't had its type established yet. It can't be
19324 CHAR*(*) in any case, though it can have an explicit CHAR*n type. */
19325
19326 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
19327 | FFESYMBOL_attrsTYPE)));
19328
19329 needs_type = !(ffesymbol_attrs (s) & FFESYMBOL_attrsDUMMY);
19330
19331 ffesymbol_signal_change (s); /* Probably already done, but in case.... */
19332
19333 if (ffelex_token_type (t) == FFELEX_typeCOLON)
19334 { /* Definitely an ENTITY (char substring). */
19335 if (needs_type && !ffeimplic_establish_symbol (s))
19336 {
19337 ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
19338 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19339 }
19340
19341 ffesymbol_set_info (s,
19342 ffeinfo_new (ffesymbol_basictype (s),
19343 ffesymbol_kindtype (s),
19344 ffesymbol_rank (s),
19345 FFEINFO_kindENTITY,
19346 (where == FFEINFO_whereNONE)
19347 ? FFEINFO_whereLOCAL
19348 : where,
19349 ffesymbol_size (s)));
19350 ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
19351
19352 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
19353 ffesymbol_resolve_intrin (s);
19354 s = ffecom_sym_learned (s);
19355 ffesymbol_signal_unreported (s); /* For debugging purposes. */
19356
19357 ffeexpr_stack_->exprstack->u.operand
19358 = ffeexpr_collapse_symter (symter, ffeexpr_tokens_[0]);
19359
19360 return (ffelexHandler) ffeexpr_token_substring_ (ft, expr, t);
19361 }
19362
19363 /* The "stuff" isn't a substring notation, so we now know the overall
19364 reference is to a function. */
19365
19366 if (ffeintrin_is_intrinsic (ffesymbol_text (s), ffeexpr_stack_->tokens[0],
19367 FALSE, &gen, &spec, &imp))
19368 {
19369 ffebld_symter_set_generic (symter, gen);
19370 ffebld_symter_set_specific (symter, spec);
19371 ffebld_symter_set_implementation (symter, imp);
19372 ffesymbol_set_generic (s, gen);
19373 ffesymbol_set_specific (s, spec);
19374 ffesymbol_set_implementation (s, imp);
19375 ffesymbol_set_info (s,
19376 ffeinfo_new (ffesymbol_basictype (s),
19377 ffesymbol_kindtype (s),
19378 0,
19379 FFEINFO_kindFUNCTION,
19380 FFEINFO_whereINTRINSIC,
19381 ffesymbol_size (s)));
19382 }
19383 else
19384 { /* Not intrinsic, now needs CHAR type. */
19385 if (!ffeimplic_establish_symbol (s))
19386 {
19387 ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
19388 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19389 }
19390
19391 ffesymbol_set_info (s,
19392 ffeinfo_new (ffesymbol_basictype (s),
19393 ffesymbol_kindtype (s),
19394 ffesymbol_rank (s),
19395 FFEINFO_kindFUNCTION,
19396 (where == FFEINFO_whereNONE)
19397 ? FFEINFO_whereGLOBAL
19398 : where,
19399 ffesymbol_size (s)));
19400 }
19401
19402 ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
19403
19404 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
19405 ffesymbol_resolve_intrin (s);
19406 s = ffecom_sym_learned (s);
19407 ffesymbol_reference (s, ffeexpr_stack_->tokens[0], FALSE);
19408 ffesymbol_signal_unreported (s); /* For debugging purposes. */
19409 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
19410 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19411 }
19412
19413 /* ffeexpr_token_anything_ -- NAME OPEN_PAREN any-expr
19414
19415 Handle basically any expression, looking for CLOSE_PAREN. */
19416
19417 static ffelexHandler
19418 ffeexpr_token_anything_ (ffelexToken ft UNUSED, ffebld expr UNUSED,
19419 ffelexToken t)
19420 {
19421 ffeexprExpr_ e = ffeexpr_stack_->exprstack;
19422
19423 switch (ffelex_token_type (t))
19424 {
19425 case FFELEX_typeCOMMA:
19426 case FFELEX_typeCOLON:
19427 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
19428 FFEEXPR_contextACTUALARG_,
19429 ffeexpr_token_anything_);
19430
19431 default:
19432 e->u.operand = ffebld_new_any ();
19433 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
19434 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19435 ffeexpr_is_substr_ok_ = FALSE;
19436 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
19437 return (ffelexHandler) ffeexpr_token_substrp_;
19438 return (ffelexHandler) ffeexpr_token_substrp_ (t);
19439 }
19440 }
19441
19442 /* Terminate module. */
19443
19444 void
19445 ffeexpr_terminate_2 ()
19446 {
19447 assert (ffeexpr_stack_ == NULL);
19448 assert (ffeexpr_level_ == 0);
19449 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org