?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2002-06-06 James Clark <jjc@jclark.com>
[official-gcc.git] / gcc / f / expr.c
blob077da3ef87d777f5555bed0f908196ebfcaf92c6
1 /* expr.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 1997, 1998, 2001, 2002, 2003
3 Free Software Foundation, Inc.
4 Contributed by James Craig Burley.
5
6 This file is part of GNU Fortran.
7
8 GNU Fortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
11 any later version.
12
13 GNU Fortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GNU Fortran; see the file COPYING. If not, write to
20 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
21 02111-1307, USA.
22
23 Related Modules:
24 None.
25
26 Description:
27 Handles syntactic and semantic analysis of Fortran expressions.
28
29 Modifications:
30 */
31
32 /* Include files. */
33
34 #include "proj.h"
35 #include "expr.h"
36 #include "bad.h"
37 #include "bld.h"
38 #include "com.h"
39 #include "global.h"
40 #include "implic.h"
41 #include "intrin.h"
42 #include "info.h"
43 #include "lex.h"
44 #include "malloc.h"
45 #include "src.h"
46 #include "st.h"
47 #include "symbol.h"
48 #include "str.h"
49 #include "target.h"
50 #include "where.h"
51 #include "real.h"
52
53 /* Externals defined here. */
54
55
56 /* Simple definitions and enumerations. */
57
58 typedef enum
59 {
60 FFEEXPR_exprtypeUNKNOWN_,
61 FFEEXPR_exprtypeOPERAND_,
62 FFEEXPR_exprtypeUNARY_,
63 FFEEXPR_exprtypeBINARY_,
64 FFEEXPR_exprtype_
65 } ffeexprExprtype_;
66
67 typedef enum
68 {
69 FFEEXPR_operatorPOWER_,
70 FFEEXPR_operatorMULTIPLY_,
71 FFEEXPR_operatorDIVIDE_,
72 FFEEXPR_operatorADD_,
73 FFEEXPR_operatorSUBTRACT_,
74 FFEEXPR_operatorCONCATENATE_,
75 FFEEXPR_operatorLT_,
76 FFEEXPR_operatorLE_,
77 FFEEXPR_operatorEQ_,
78 FFEEXPR_operatorNE_,
79 FFEEXPR_operatorGT_,
80 FFEEXPR_operatorGE_,
81 FFEEXPR_operatorNOT_,
82 FFEEXPR_operatorAND_,
83 FFEEXPR_operatorOR_,
84 FFEEXPR_operatorXOR_,
85 FFEEXPR_operatorEQV_,
86 FFEEXPR_operatorNEQV_,
87 FFEEXPR_operator_
88 } ffeexprOperator_;
89
90 typedef enum
91 {
92 FFEEXPR_operatorprecedenceHIGHEST_ = 1,
93 FFEEXPR_operatorprecedencePOWER_ = 1,
94 FFEEXPR_operatorprecedenceMULTIPLY_ = 2,
95 FFEEXPR_operatorprecedenceDIVIDE_ = 2,
96 FFEEXPR_operatorprecedenceADD_ = 3,
97 FFEEXPR_operatorprecedenceSUBTRACT_ = 3,
98 FFEEXPR_operatorprecedenceLOWARITH_ = 3,
99 FFEEXPR_operatorprecedenceCONCATENATE_ = 3,
100 FFEEXPR_operatorprecedenceLT_ = 4,
101 FFEEXPR_operatorprecedenceLE_ = 4,
102 FFEEXPR_operatorprecedenceEQ_ = 4,
103 FFEEXPR_operatorprecedenceNE_ = 4,
104 FFEEXPR_operatorprecedenceGT_ = 4,
105 FFEEXPR_operatorprecedenceGE_ = 4,
106 FFEEXPR_operatorprecedenceNOT_ = 5,
107 FFEEXPR_operatorprecedenceAND_ = 6,
108 FFEEXPR_operatorprecedenceOR_ = 7,
109 FFEEXPR_operatorprecedenceXOR_ = 8,
110 FFEEXPR_operatorprecedenceEQV_ = 8,
111 FFEEXPR_operatorprecedenceNEQV_ = 8,
112 FFEEXPR_operatorprecedenceLOWEST_ = 8,
113 FFEEXPR_operatorprecedence_
114 } ffeexprOperatorPrecedence_;
115
116 #define FFEEXPR_operatorassociativityL2R_ TRUE
117 #define FFEEXPR_operatorassociativityR2L_ FALSE
118 #define FFEEXPR_operatorassociativityPOWER_ FFEEXPR_operatorassociativityR2L_
119 #define FFEEXPR_operatorassociativityMULTIPLY_ FFEEXPR_operatorassociativityL2R_
120 #define FFEEXPR_operatorassociativityDIVIDE_ FFEEXPR_operatorassociativityL2R_
121 #define FFEEXPR_operatorassociativityADD_ FFEEXPR_operatorassociativityL2R_
122 #define FFEEXPR_operatorassociativitySUBTRACT_ FFEEXPR_operatorassociativityL2R_
123 #define FFEEXPR_operatorassociativityCONCATENATE_ FFEEXPR_operatorassociativityL2R_
124 #define FFEEXPR_operatorassociativityLT_ FFEEXPR_operatorassociativityL2R_
125 #define FFEEXPR_operatorassociativityLE_ FFEEXPR_operatorassociativityL2R_
126 #define FFEEXPR_operatorassociativityEQ_ FFEEXPR_operatorassociativityL2R_
127 #define FFEEXPR_operatorassociativityNE_ FFEEXPR_operatorassociativityL2R_
128 #define FFEEXPR_operatorassociativityGT_ FFEEXPR_operatorassociativityL2R_
129 #define FFEEXPR_operatorassociativityGE_ FFEEXPR_operatorassociativityL2R_
130 #define FFEEXPR_operatorassociativityNOT_ FFEEXPR_operatorassociativityL2R_
131 #define FFEEXPR_operatorassociativityAND_ FFEEXPR_operatorassociativityL2R_
132 #define FFEEXPR_operatorassociativityOR_ FFEEXPR_operatorassociativityL2R_
133 #define FFEEXPR_operatorassociativityXOR_ FFEEXPR_operatorassociativityL2R_
134 #define FFEEXPR_operatorassociativityEQV_ FFEEXPR_operatorassociativityL2R_
135 #define FFEEXPR_operatorassociativityNEQV_ FFEEXPR_operatorassociativityL2R_
136
137 typedef enum
138 {
139 FFEEXPR_parentypeFUNCTION_,
140 FFEEXPR_parentypeSUBROUTINE_,
141 FFEEXPR_parentypeARRAY_,
142 FFEEXPR_parentypeSUBSTRING_,
143 FFEEXPR_parentypeFUNSUBSTR_,/* Ambig: check for colon after first expr. */
144 FFEEXPR_parentypeEQUIVALENCE_, /* Ambig: ARRAY_ or SUBSTRING_. */
145 FFEEXPR_parentypeANY_, /* Allow basically anything. */
146 FFEEXPR_parentype_
147 } ffeexprParenType_;
148
149 typedef enum
150 {
151 FFEEXPR_percentNONE_,
152 FFEEXPR_percentLOC_,
153 FFEEXPR_percentVAL_,
154 FFEEXPR_percentREF_,
155 FFEEXPR_percentDESCR_,
156 FFEEXPR_percent_
157 } ffeexprPercent_;
158
159 /* Internal typedefs. */
160
161 typedef struct _ffeexpr_expr_ *ffeexprExpr_;
162 typedef bool ffeexprOperatorAssociativity_;
163 typedef struct _ffeexpr_stack_ *ffeexprStack_;
164
165 /* Private include files. */
166
167
168 /* Internal structure definitions. */
169
170 struct _ffeexpr_expr_
171 {
172 ffeexprExpr_ previous;
173 ffelexToken token;
174 ffeexprExprtype_ type;
175 union
176 {
177 struct
178 {
179 ffeexprOperator_ op;
180 ffeexprOperatorPrecedence_ prec;
181 ffeexprOperatorAssociativity_ as;
182 }
183 operator;
184 ffebld operand;
185 }
186 u;
187 };
188
189 struct _ffeexpr_stack_
190 {
191 ffeexprStack_ previous;
192 mallocPool pool;
193 ffeexprContext context;
194 ffeexprCallback callback;
195 ffelexToken first_token;
196 ffeexprExpr_ exprstack;
197 ffelexToken tokens[10]; /* Used in certain cases, like (unary)
198 open-paren. */
199 ffebld expr; /* For first of
200 complex/implied-do/substring/array-elements
201 / actual-args expression. */
202 ffebld bound_list; /* For tracking dimension bounds list of
203 array. */
204 ffebldListBottom bottom; /* For building lists. */
205 ffeinfoRank rank; /* For elements in an array reference. */
206 bool constant; /* TRUE while elements seen so far are
207 constants. */
208 bool immediate; /* TRUE while elements seen so far are
209 immediate/constants. */
210 ffebld next_dummy; /* Next SFUNC dummy arg in arg list. */
211 ffebldListLength num_args; /* Number of dummy args expected in arg list. */
212 bool is_rhs; /* TRUE if rhs context, FALSE otherwise. */
213 ffeexprPercent_ percent; /* Current %FOO keyword. */
214 };
215
216 struct _ffeexpr_find_
217 {
218 ffelexToken t;
219 ffelexHandler after;
220 int level;
221 };
222
223 /* Static objects accessed by functions in this module. */
224
225 static ffeexprStack_ ffeexpr_stack_; /* Expression stack for semantic. */
226 static ffelexToken ffeexpr_tokens_[10]; /* Scratchpad tokens for syntactic. */
227 static ffestrOther ffeexpr_current_dotdot_; /* Current .FOO. keyword. */
228 static long ffeexpr_hollerith_count_; /* ffeexpr_token_number_ and caller. */
229 static int ffeexpr_level_; /* Level of DATA implied-DO construct. */
230 static bool ffeexpr_is_substr_ok_; /* If OPEN_PAREN as binary "op" ok. */
231 static struct _ffeexpr_find_ ffeexpr_find_;
232
233 /* Static functions (internal). */
234
235 static ffelexHandler ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr,
236 ffelexToken t);
237 static ffelexHandler ffeexpr_cb_close_paren_ambig_ (ffelexToken ft,
238 ffebld expr,
239 ffelexToken t);
240 static ffelexHandler ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t);
241 static ffelexHandler ffeexpr_cb_close_paren_c_ (ffelexToken ft,
242 ffebld expr, ffelexToken t);
243 static ffelexHandler ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr,
244 ffelexToken t);
245 static ffelexHandler ffeexpr_cb_close_paren_ci_ (ffelexToken ft,
246 ffebld expr, ffelexToken t);
247 static ffelexHandler ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr,
248 ffelexToken t);
249 static ffelexHandler ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr,
250 ffelexToken t);
251 static ffelexHandler ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr,
252 ffelexToken t);
253 static ffelexHandler ffeexpr_cb_comma_i_2_ (ffelexToken ft, ffebld expr,
254 ffelexToken t);
255 static ffelexHandler ffeexpr_cb_comma_i_3_ (ffelexToken ft, ffebld expr,
256 ffelexToken t);
257 static ffelexHandler ffeexpr_cb_comma_i_4_ (ffelexToken ft, ffebld expr,
258 ffelexToken t);
259 static ffelexHandler ffeexpr_cb_comma_i_5_ (ffelexToken t);
260 static ffelexHandler ffeexpr_cb_end_loc_ (ffelexToken ft, ffebld expr,
261 ffelexToken t);
262 static ffelexHandler ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr,
263 ffelexToken t);
264 static ffelexHandler ffeexpr_cb_end_notloc_1_ (ffelexToken t);
265 static ffesymbol ffeexpr_check_impctrl_ (ffesymbol s);
266 static void ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
267 ffebld dovar, ffelexToken dovar_t);
268 static void ffeexpr_update_impdo_ (ffebld expr, ffebld dovar);
269 static void ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar);
270 static ffeexprContext ffeexpr_context_outer_ (ffeexprStack_ s);
271 static ffeexprExpr_ ffeexpr_expr_new_ (void);
272 static void ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t);
273 static bool ffeexpr_isdigits_ (const char *p);
274 static ffelexHandler ffeexpr_token_first_lhs_ (ffelexToken t);
275 static ffelexHandler ffeexpr_token_first_lhs_1_ (ffelexToken t);
276 static ffelexHandler ffeexpr_token_first_rhs_ (ffelexToken t);
277 static ffelexHandler ffeexpr_token_first_rhs_1_ (ffelexToken t);
278 static ffelexHandler ffeexpr_token_first_rhs_2_ (ffelexToken t);
279 static ffelexHandler ffeexpr_token_first_rhs_3_ (ffelexToken t);
280 static ffelexHandler ffeexpr_token_first_rhs_4_ (ffelexToken t);
281 static ffelexHandler ffeexpr_token_first_rhs_5_ (ffelexToken t);
282 static ffelexHandler ffeexpr_token_first_rhs_6_ (ffelexToken t);
283 static ffelexHandler ffeexpr_token_namelist_ (ffelexToken t);
284 static void ffeexpr_expr_kill_ (ffeexprExpr_ e);
285 static void ffeexpr_exprstack_push_ (ffeexprExpr_ e);
286 static void ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e);
287 static void ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e);
288 static void ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e);
289 static void ffeexpr_reduce_ (void);
290 static ffebld ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op,
291 ffeexprExpr_ r);
292 static ffebld ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l,
293 ffeexprExpr_ op, ffeexprExpr_ r);
294 static ffebld ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l,
295 ffeexprExpr_ op, ffeexprExpr_ r);
296 static ffebld ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l,
297 ffeexprExpr_ op, ffeexprExpr_ r);
298 static ffebld ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op,
299 ffeexprExpr_ r);
300 static ffebld ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l,
301 ffeexprExpr_ op, ffeexprExpr_ r);
302 static ffebld ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l,
303 ffeexprExpr_ op, ffeexprExpr_ r);
304 static ffebld ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l,
305 ffeexprExpr_ op, ffeexprExpr_ r);
306 static ffebld ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r);
307 static ffebld ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op,
308 ffeexprExpr_ r);
309 static ffebld ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l,
310 ffeexprExpr_ op, ffeexprExpr_ r);
311 static ffebld ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l,
312 ffeexprExpr_ op, ffeexprExpr_ r);
313 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 }
9581
9582 /* ffeexpr_exprstack_push_unary_ -- Push a unary operator onto the stack
9583
9584 ffeexprExpr_ e;
9585 ffeexpr_exprstack_push_unary_(e);
9586
9587 Pushes the expression already containing a unary operator. Reduction can
9588 never happen since unary operators are themselves always R-L; that is, the
9589 top of the expression stack is not an operand, in that it is either empty,
9590 has a binary operator at the top, or a unary operator at the top. In any
9591 of these cases, reduction is impossible. */
9592
9593 static void
9594 ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e)
9595 {
9596 if ((ffe_is_pedantic ()
9597 || ffe_is_warn_surprising ())
9598 && (ffeexpr_stack_->exprstack != NULL)
9599 && (ffeexpr_stack_->exprstack->type != FFEEXPR_exprtypeOPERAND_)
9600 && (ffeexpr_stack_->exprstack->u.operator.prec
9601 <= FFEEXPR_operatorprecedenceLOWARITH_)
9602 && (e->u.operator.prec <= FFEEXPR_operatorprecedenceLOWARITH_))
9603 {
9604 /* xgettext:no-c-format */
9605 ffebad_start_msg ("Two arithmetic operators in a row at %0 and %1 -- use parentheses",
9606 ffe_is_pedantic ()
9607 ? FFEBAD_severityPEDANTIC
9608 : FFEBAD_severityWARNING);
9609 ffebad_here (0,
9610 ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
9611 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
9612 ffebad_here (1,
9613 ffelex_token_where_line (e->token),
9614 ffelex_token_where_column (e->token));
9615 ffebad_finish ();
9616 }
9617
9618 ffeexpr_exprstack_push_ (e);
9619 }
9620
9621 /* ffeexpr_exprstack_push_binary_ -- Push a binary operator onto the stack, reduce?
9622
9623 ffeexprExpr_ e;
9624 ffeexpr_exprstack_push_binary_(e);
9625
9626 Pushes the expression already containing a binary operator after checking
9627 whether reduction is possible. If the stack is not empty, the top of the
9628 stack must be an operand or syntactic analysis has failed somehow. If
9629 the operand is preceded by a unary operator of higher (or equal and L-R
9630 associativity) precedence than the new binary operator, then reduce that
9631 preceding operator and its operand(s) before pushing the new binary
9632 operator. */
9633
9634 static void
9635 ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e)
9636 {
9637 ffeexprExpr_ ce;
9638
9639 if (ffe_is_warn_surprising ()
9640 /* These next two are always true (see assertions below). */
9641 && (ffeexpr_stack_->exprstack != NULL)
9642 && (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_)
9643 /* If the previous operator is a unary minus, and the binary op
9644 is of higher precedence, might not do what user expects,
9645 e.g. "-2**2" is "-(2**2)", i.e. "-4", not "(-2)**2", which would
9646 yield "4". */
9647 && (ffeexpr_stack_->exprstack->previous != NULL)
9648 && (ffeexpr_stack_->exprstack->previous->type == FFEEXPR_exprtypeUNARY_)
9649 && (ffeexpr_stack_->exprstack->previous->u.operator.op
9650 == FFEEXPR_operatorSUBTRACT_)
9651 && (e->u.operator.prec
9652 < ffeexpr_stack_->exprstack->previous->u.operator.prec))
9653 {
9654 /* xgettext:no-c-format */
9655 ffebad_start_msg ("Operator at %0 has lower precedence than that at %1 -- use parentheses", FFEBAD_severityWARNING);
9656 ffebad_here (0,
9657 ffelex_token_where_line (ffeexpr_stack_->exprstack->previous->token),
9658 ffelex_token_where_column (ffeexpr_stack_->exprstack->previous->token));
9659 ffebad_here (1,
9660 ffelex_token_where_line (e->token),
9661 ffelex_token_where_column (e->token));
9662 ffebad_finish ();
9663 }
9664
9665 again:
9666 assert (ffeexpr_stack_->exprstack != NULL);
9667 assert (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_);
9668 if ((ce = ffeexpr_stack_->exprstack->previous) != NULL)
9669 {
9670 assert (ce->type != FFEEXPR_exprtypeOPERAND_);
9671 if ((ce->u.operator.prec < e->u.operator.prec)
9672 || ((ce->u.operator.prec == e->u.operator.prec)
9673 && (e->u.operator.as == FFEEXPR_operatorassociativityL2R_)))
9674 {
9675 ffeexpr_reduce_ ();
9676 goto again; /* :::::::::::::::::::: */
9677 }
9678 }
9679
9680 ffeexpr_exprstack_push_ (e);
9681 }
9682
9683 /* ffeexpr_reduce_ -- Reduce highest operator w/operands on stack
9684
9685 ffeexpr_reduce_();
9686
9687 Converts operand binop operand or unop operand at top of stack to a
9688 single operand having the appropriate ffebld expression, and makes
9689 sure that the expression is proper (like not trying to add two character
9690 variables, not trying to concatenate two numbers). Also does the
9691 requisite type-assignment. */
9692
9693 static void
9694 ffeexpr_reduce_ ()
9695 {
9696 ffeexprExpr_ operand; /* This is B in -B or A+B. */
9697 ffeexprExpr_ left_operand; /* When operator is binary, this is A in A+B. */
9698 ffeexprExpr_ operator; /* This is + in A+B. */
9699 ffebld reduced; /* This is +(A,B) in A+B or u-(B) in -B. */
9700 ffebldConstant constnode; /* For checking magical numbers (where mag ==
9701 -mag). */
9702 ffebld expr;
9703 ffebld left_expr;
9704 bool submag = FALSE;
9705
9706 operand = ffeexpr_stack_->exprstack;
9707 assert (operand != NULL);
9708 assert (operand->type == FFEEXPR_exprtypeOPERAND_);
9709 operator = operand->previous;
9710 assert (operator != NULL);
9711 assert (operator->type != FFEEXPR_exprtypeOPERAND_);
9712 if (operator->type == FFEEXPR_exprtypeUNARY_)
9713 {
9714 expr = operand->u.operand;
9715 switch (operator->u.operator.op)
9716 {
9717 case FFEEXPR_operatorADD_:
9718 reduced = ffebld_new_uplus (expr);
9719 if (ffe_is_ugly_logint ())
9720 reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
9721 reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
9722 reduced = ffeexpr_collapse_uplus (reduced, operator->token);
9723 break;
9724
9725 case FFEEXPR_operatorSUBTRACT_:
9726 submag = TRUE; /* Ok to negate a magic number. */
9727 reduced = ffebld_new_uminus (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_uminus (reduced, operator->token);
9732 break;
9733
9734 case FFEEXPR_operatorNOT_:
9735 reduced = ffebld_new_not (expr);
9736 if (ffe_is_ugly_logint ())
9737 reduced = ffeexpr_reduced_ugly1log_ (reduced, operator, operand);
9738 reduced = ffeexpr_reduced_bool1_ (reduced, operator, operand);
9739 reduced = ffeexpr_collapse_not (reduced, operator->token);
9740 break;
9741
9742 default:
9743 assert ("unexpected unary op" != NULL);
9744 reduced = NULL;
9745 break;
9746 }
9747 if (!submag
9748 && (ffebld_op (expr) == FFEBLD_opCONTER)
9749 && (ffebld_conter_orig (expr) == NULL)
9750 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
9751 {
9752 ffetarget_integer_bad_magical (operand->token);
9753 }
9754 ffeexpr_stack_->exprstack = operator->previous; /* Pops unary-op operand
9755 off stack. */
9756 ffeexpr_expr_kill_ (operand);
9757 operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but
9758 save */
9759 operator->u.operand = reduced; /* the line/column ffewhere info. */
9760 ffeexpr_exprstack_push_operand_ (operator); /* Push it back on
9761 stack. */
9762 }
9763 else
9764 {
9765 assert (operator->type == FFEEXPR_exprtypeBINARY_);
9766 left_operand = operator->previous;
9767 assert (left_operand != NULL);
9768 assert (left_operand->type == FFEEXPR_exprtypeOPERAND_);
9769 expr = operand->u.operand;
9770 left_expr = left_operand->u.operand;
9771 switch (operator->u.operator.op)
9772 {
9773 case FFEEXPR_operatorADD_:
9774 reduced = ffebld_new_add (left_expr, expr);
9775 if (ffe_is_ugly_logint ())
9776 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9777 operand);
9778 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9779 operand);
9780 reduced = ffeexpr_collapse_add (reduced, operator->token);
9781 break;
9782
9783 case FFEEXPR_operatorSUBTRACT_:
9784 submag = TRUE; /* Just to pick the right error if magic
9785 number. */
9786 reduced = ffebld_new_subtract (left_expr, expr);
9787 if (ffe_is_ugly_logint ())
9788 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9789 operand);
9790 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9791 operand);
9792 reduced = ffeexpr_collapse_subtract (reduced, operator->token);
9793 break;
9794
9795 case FFEEXPR_operatorMULTIPLY_:
9796 reduced = ffebld_new_multiply (left_expr, expr);
9797 if (ffe_is_ugly_logint ())
9798 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9799 operand);
9800 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9801 operand);
9802 reduced = ffeexpr_collapse_multiply (reduced, operator->token);
9803 break;
9804
9805 case FFEEXPR_operatorDIVIDE_:
9806 reduced = ffebld_new_divide (left_expr, expr);
9807 if (ffe_is_ugly_logint ())
9808 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9809 operand);
9810 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9811 operand);
9812 reduced = ffeexpr_collapse_divide (reduced, operator->token);
9813 break;
9814
9815 case FFEEXPR_operatorPOWER_:
9816 reduced = ffebld_new_power (left_expr, expr);
9817 if (ffe_is_ugly_logint ())
9818 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9819 operand);
9820 reduced = ffeexpr_reduced_power_ (reduced, left_operand, operator,
9821 operand);
9822 reduced = ffeexpr_collapse_power (reduced, operator->token);
9823 break;
9824
9825 case FFEEXPR_operatorCONCATENATE_:
9826 reduced = ffebld_new_concatenate (left_expr, expr);
9827 reduced = ffeexpr_reduced_concatenate_ (reduced, left_operand, operator,
9828 operand);
9829 reduced = ffeexpr_collapse_concatenate (reduced, operator->token);
9830 break;
9831
9832 case FFEEXPR_operatorLT_:
9833 reduced = ffebld_new_lt (left_expr, expr);
9834 if (ffe_is_ugly_logint ())
9835 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9836 operand);
9837 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9838 operand);
9839 reduced = ffeexpr_collapse_lt (reduced, operator->token);
9840 break;
9841
9842 case FFEEXPR_operatorLE_:
9843 reduced = ffebld_new_le (left_expr, expr);
9844 if (ffe_is_ugly_logint ())
9845 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9846 operand);
9847 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9848 operand);
9849 reduced = ffeexpr_collapse_le (reduced, operator->token);
9850 break;
9851
9852 case FFEEXPR_operatorEQ_:
9853 reduced = ffebld_new_eq (left_expr, expr);
9854 if (ffe_is_ugly_logint ())
9855 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9856 operand);
9857 reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
9858 operand);
9859 reduced = ffeexpr_collapse_eq (reduced, operator->token);
9860 break;
9861
9862 case FFEEXPR_operatorNE_:
9863 reduced = ffebld_new_ne (left_expr, expr);
9864 if (ffe_is_ugly_logint ())
9865 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9866 operand);
9867 reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
9868 operand);
9869 reduced = ffeexpr_collapse_ne (reduced, operator->token);
9870 break;
9871
9872 case FFEEXPR_operatorGT_:
9873 reduced = ffebld_new_gt (left_expr, expr);
9874 if (ffe_is_ugly_logint ())
9875 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9876 operand);
9877 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9878 operand);
9879 reduced = ffeexpr_collapse_gt (reduced, operator->token);
9880 break;
9881
9882 case FFEEXPR_operatorGE_:
9883 reduced = ffebld_new_ge (left_expr, expr);
9884 if (ffe_is_ugly_logint ())
9885 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9886 operand);
9887 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9888 operand);
9889 reduced = ffeexpr_collapse_ge (reduced, operator->token);
9890 break;
9891
9892 case FFEEXPR_operatorAND_:
9893 reduced = ffebld_new_and (left_expr, expr);
9894 if (ffe_is_ugly_logint ())
9895 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9896 operand);
9897 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9898 operand);
9899 reduced = ffeexpr_collapse_and (reduced, operator->token);
9900 break;
9901
9902 case FFEEXPR_operatorOR_:
9903 reduced = ffebld_new_or (left_expr, expr);
9904 if (ffe_is_ugly_logint ())
9905 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9906 operand);
9907 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9908 operand);
9909 reduced = ffeexpr_collapse_or (reduced, operator->token);
9910 break;
9911
9912 case FFEEXPR_operatorXOR_:
9913 reduced = ffebld_new_xor (left_expr, expr);
9914 if (ffe_is_ugly_logint ())
9915 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9916 operand);
9917 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9918 operand);
9919 reduced = ffeexpr_collapse_xor (reduced, operator->token);
9920 break;
9921
9922 case FFEEXPR_operatorEQV_:
9923 reduced = ffebld_new_eqv (left_expr, expr);
9924 if (ffe_is_ugly_logint ())
9925 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9926 operand);
9927 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9928 operand);
9929 reduced = ffeexpr_collapse_eqv (reduced, operator->token);
9930 break;
9931
9932 case FFEEXPR_operatorNEQV_:
9933 reduced = ffebld_new_neqv (left_expr, expr);
9934 if (ffe_is_ugly_logint ())
9935 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9936 operand);
9937 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9938 operand);
9939 reduced = ffeexpr_collapse_neqv (reduced, operator->token);
9940 break;
9941
9942 default:
9943 assert ("bad bin op" == NULL);
9944 reduced = expr;
9945 break;
9946 }
9947 if ((ffebld_op (left_expr) == FFEBLD_opCONTER)
9948 && (ffebld_conter_orig (expr) == NULL)
9949 && ffebld_constant_is_magical (constnode = ffebld_conter (left_expr)))
9950 {
9951 if ((left_operand->previous != NULL)
9952 && (left_operand->previous->type != FFEEXPR_exprtypeOPERAND_)
9953 && (left_operand->previous->u.operator.op
9954 == FFEEXPR_operatorSUBTRACT_))
9955 {
9956 if (left_operand->previous->type == FFEEXPR_exprtypeUNARY_)
9957 ffetarget_integer_bad_magical_precedence (left_operand->token,
9958 left_operand->previous->token,
9959 operator->token);
9960 else
9961 ffetarget_integer_bad_magical_precedence_binary
9962 (left_operand->token,
9963 left_operand->previous->token,
9964 operator->token);
9965 }
9966 else
9967 ffetarget_integer_bad_magical (left_operand->token);
9968 }
9969 if ((ffebld_op (expr) == FFEBLD_opCONTER)
9970 && (ffebld_conter_orig (expr) == NULL)
9971 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
9972 {
9973 if (submag)
9974 ffetarget_integer_bad_magical_binary (operand->token,
9975 operator->token);
9976 else
9977 ffetarget_integer_bad_magical (operand->token);
9978 }
9979 ffeexpr_stack_->exprstack = left_operand->previous; /* Pops binary-op
9980 operands off stack. */
9981 ffeexpr_expr_kill_ (left_operand);
9982 ffeexpr_expr_kill_ (operand);
9983 operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but
9984 save */
9985 operator->u.operand = reduced; /* the line/column ffewhere info. */
9986 ffeexpr_exprstack_push_operand_ (operator); /* Push it back on
9987 stack. */
9988 }
9989 }
9990
9991 /* ffeexpr_reduced_bool1_ -- Wrap up reduction of NOT operator
9992
9993 reduced = ffeexpr_reduced_bool1_(reduced,op,r);
9994
9995 Makes sure the argument for reduced has basictype of
9996 LOGICAL or (ugly) INTEGER. If
9997 argument has where of CONSTANT, assign where CONSTANT to
9998 reduced, else assign where FLEETING.
9999
10000 If these requirements cannot be met, generate error message. */
10001
10002 static ffebld
10003 ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10004 {
10005 ffeinfo rinfo, ninfo;
10006 ffeinfoBasictype rbt;
10007 ffeinfoKindtype rkt;
10008 ffeinfoRank rrk;
10009 ffeinfoKind rkd;
10010 ffeinfoWhere rwh, nwh;
10011
10012 rinfo = ffebld_info (ffebld_left (reduced));
10013 rbt = ffeinfo_basictype (rinfo);
10014 rkt = ffeinfo_kindtype (rinfo);
10015 rrk = ffeinfo_rank (rinfo);
10016 rkd = ffeinfo_kind (rinfo);
10017 rwh = ffeinfo_where (rinfo);
10018
10019 if (((rbt == FFEINFO_basictypeLOGICAL)
10020 || (ffe_is_ugly_logint () && (rbt == FFEINFO_basictypeINTEGER)))
10021 && (rrk == 0))
10022 {
10023 switch (rwh)
10024 {
10025 case FFEINFO_whereCONSTANT:
10026 nwh = FFEINFO_whereCONSTANT;
10027 break;
10028
10029 case FFEINFO_whereIMMEDIATE:
10030 nwh = FFEINFO_whereIMMEDIATE;
10031 break;
10032
10033 default:
10034 nwh = FFEINFO_whereFLEETING;
10035 break;
10036 }
10037
10038 ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
10039 FFETARGET_charactersizeNONE);
10040 ffebld_set_info (reduced, ninfo);
10041 return reduced;
10042 }
10043
10044 if ((rbt != FFEINFO_basictypeLOGICAL)
10045 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
10046 {
10047 if ((rbt != FFEINFO_basictypeANY)
10048 && ffebad_start (FFEBAD_NOT_ARG_TYPE))
10049 {
10050 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10051 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10052 ffebad_finish ();
10053 }
10054 }
10055 else
10056 {
10057 if ((rkd != FFEINFO_kindANY)
10058 && ffebad_start (FFEBAD_NOT_ARG_KIND))
10059 {
10060 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10061 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10062 ffebad_string ("an array");
10063 ffebad_finish ();
10064 }
10065 }
10066
10067 reduced = ffebld_new_any ();
10068 ffebld_set_info (reduced, ffeinfo_new_any ());
10069 return reduced;
10070 }
10071
10072 /* ffeexpr_reduced_bool2_ -- Wrap up reduction of boolean operators
10073
10074 reduced = ffeexpr_reduced_bool2_(reduced,l,op,r);
10075
10076 Makes sure the left and right arguments for reduced have basictype of
10077 LOGICAL or (ugly) INTEGER. Determine common basictype and
10078 size for reduction (flag expression for combined hollerith/typeless
10079 situations for later determination of effective basictype). If both left
10080 and right arguments have where of CONSTANT, assign where CONSTANT to
10081 reduced, else assign where FLEETING. Create CONVERT ops for args where
10082 needed. Convert typeless
10083 constants to the desired type/size explicitly.
10084
10085 If these requirements cannot be met, generate error message. */
10086
10087 static ffebld
10088 ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10089 ffeexprExpr_ r)
10090 {
10091 ffeinfo linfo, rinfo, ninfo;
10092 ffeinfoBasictype lbt, rbt, nbt;
10093 ffeinfoKindtype lkt, rkt, nkt;
10094 ffeinfoRank lrk, rrk;
10095 ffeinfoKind lkd, rkd;
10096 ffeinfoWhere lwh, rwh, nwh;
10097
10098 linfo = ffebld_info (ffebld_left (reduced));
10099 lbt = ffeinfo_basictype (linfo);
10100 lkt = ffeinfo_kindtype (linfo);
10101 lrk = ffeinfo_rank (linfo);
10102 lkd = ffeinfo_kind (linfo);
10103 lwh = ffeinfo_where (linfo);
10104
10105 rinfo = ffebld_info (ffebld_right (reduced));
10106 rbt = ffeinfo_basictype (rinfo);
10107 rkt = ffeinfo_kindtype (rinfo);
10108 rrk = ffeinfo_rank (rinfo);
10109 rkd = ffeinfo_kind (rinfo);
10110 rwh = ffeinfo_where (rinfo);
10111
10112 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10113
10114 if (((nbt == FFEINFO_basictypeLOGICAL)
10115 || (ffe_is_ugly_logint () && (nbt == FFEINFO_basictypeINTEGER)))
10116 && (lrk == 0) && (rrk == 0))
10117 {
10118 switch (lwh)
10119 {
10120 case FFEINFO_whereCONSTANT:
10121 switch (rwh)
10122 {
10123 case FFEINFO_whereCONSTANT:
10124 nwh = FFEINFO_whereCONSTANT;
10125 break;
10126
10127 case FFEINFO_whereIMMEDIATE:
10128 nwh = FFEINFO_whereIMMEDIATE;
10129 break;
10130
10131 default:
10132 nwh = FFEINFO_whereFLEETING;
10133 break;
10134 }
10135 break;
10136
10137 case FFEINFO_whereIMMEDIATE:
10138 switch (rwh)
10139 {
10140 case FFEINFO_whereCONSTANT:
10141 case FFEINFO_whereIMMEDIATE:
10142 nwh = FFEINFO_whereIMMEDIATE;
10143 break;
10144
10145 default:
10146 nwh = FFEINFO_whereFLEETING;
10147 break;
10148 }
10149 break;
10150
10151 default:
10152 nwh = FFEINFO_whereFLEETING;
10153 break;
10154 }
10155
10156 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10157 FFETARGET_charactersizeNONE);
10158 ffebld_set_info (reduced, ninfo);
10159 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10160 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10161 FFEEXPR_contextLET));
10162 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10163 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10164 FFEEXPR_contextLET));
10165 return reduced;
10166 }
10167
10168 if ((lbt != FFEINFO_basictypeLOGICAL)
10169 && (!ffe_is_ugly_logint () || (lbt != FFEINFO_basictypeINTEGER)))
10170 {
10171 if ((rbt != FFEINFO_basictypeLOGICAL)
10172 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
10173 {
10174 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10175 && ffebad_start (FFEBAD_BOOL_ARGS_TYPE))
10176 {
10177 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10178 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10179 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10180 ffebad_finish ();
10181 }
10182 }
10183 else
10184 {
10185 if ((lbt != FFEINFO_basictypeANY)
10186 && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
10187 {
10188 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10189 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10190 ffebad_finish ();
10191 }
10192 }
10193 }
10194 else if ((rbt != FFEINFO_basictypeLOGICAL)
10195 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
10196 {
10197 if ((rbt != FFEINFO_basictypeANY)
10198 && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
10199 {
10200 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10201 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10202 ffebad_finish ();
10203 }
10204 }
10205 else if (lrk != 0)
10206 {
10207 if ((lkd != FFEINFO_kindANY)
10208 && ffebad_start (FFEBAD_BOOL_ARG_KIND))
10209 {
10210 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10211 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10212 ffebad_string ("an array");
10213 ffebad_finish ();
10214 }
10215 }
10216 else
10217 {
10218 if ((rkd != FFEINFO_kindANY)
10219 && ffebad_start (FFEBAD_BOOL_ARG_KIND))
10220 {
10221 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10222 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10223 ffebad_string ("an array");
10224 ffebad_finish ();
10225 }
10226 }
10227
10228 reduced = ffebld_new_any ();
10229 ffebld_set_info (reduced, ffeinfo_new_any ());
10230 return reduced;
10231 }
10232
10233 /* ffeexpr_reduced_concatenate_ -- Wrap up reduction of concatenate operator
10234
10235 reduced = ffeexpr_reduced_concatenate_(reduced,l,op,r);
10236
10237 Makes sure the left and right arguments for reduced have basictype of
10238 CHARACTER and kind of SCALAR, FUNCTION, or STATEMENT FUNCTION. Assign
10239 basictype of CHARACTER and kind of SCALAR to reduced. Calculate effective
10240 size of concatenation and assign that size to reduced. If both left and
10241 right arguments have where of CONSTANT, assign where CONSTANT to reduced,
10242 else assign where FLEETING.
10243
10244 If these requirements cannot be met, generate error message using the
10245 info in l, op, and r arguments and assign basictype, size, kind, and where
10246 of ANY. */
10247
10248 static ffebld
10249 ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10250 ffeexprExpr_ r)
10251 {
10252 ffeinfo linfo, rinfo, ninfo;
10253 ffeinfoBasictype lbt, rbt, nbt;
10254 ffeinfoKindtype lkt, rkt, nkt;
10255 ffeinfoRank lrk, rrk;
10256 ffeinfoKind lkd, rkd, nkd;
10257 ffeinfoWhere lwh, rwh, nwh;
10258 ffetargetCharacterSize lszm, lszk, rszm, rszk, nszk;
10259
10260 linfo = ffebld_info (ffebld_left (reduced));
10261 lbt = ffeinfo_basictype (linfo);
10262 lkt = ffeinfo_kindtype (linfo);
10263 lrk = ffeinfo_rank (linfo);
10264 lkd = ffeinfo_kind (linfo);
10265 lwh = ffeinfo_where (linfo);
10266 lszk = ffeinfo_size (linfo); /* Known size. */
10267 lszm = ffebld_size_max (ffebld_left (reduced));
10268
10269 rinfo = ffebld_info (ffebld_right (reduced));
10270 rbt = ffeinfo_basictype (rinfo);
10271 rkt = ffeinfo_kindtype (rinfo);
10272 rrk = ffeinfo_rank (rinfo);
10273 rkd = ffeinfo_kind (rinfo);
10274 rwh = ffeinfo_where (rinfo);
10275 rszk = ffeinfo_size (rinfo); /* Known size. */
10276 rszm = ffebld_size_max (ffebld_right (reduced));
10277
10278 if ((lbt == FFEINFO_basictypeCHARACTER) && (rbt == FFEINFO_basictypeCHARACTER)
10279 && (lkt == rkt) && (lrk == 0) && (rrk == 0)
10280 && (((lszm != FFETARGET_charactersizeNONE)
10281 && (rszm != FFETARGET_charactersizeNONE))
10282 || (ffeexpr_context_outer_ (ffeexpr_stack_)
10283 == FFEEXPR_contextLET)
10284 || (ffeexpr_context_outer_ (ffeexpr_stack_)
10285 == FFEEXPR_contextSFUNCDEF)))
10286 {
10287 nbt = FFEINFO_basictypeCHARACTER;
10288 nkd = FFEINFO_kindENTITY;
10289 if ((lszk == FFETARGET_charactersizeNONE)
10290 || (rszk == FFETARGET_charactersizeNONE))
10291 nszk = FFETARGET_charactersizeNONE; /* Ok only in rhs of LET
10292 stmt. */
10293 else
10294 nszk = lszk + rszk;
10295
10296 switch (lwh)
10297 {
10298 case FFEINFO_whereCONSTANT:
10299 switch (rwh)
10300 {
10301 case FFEINFO_whereCONSTANT:
10302 nwh = FFEINFO_whereCONSTANT;
10303 break;
10304
10305 case FFEINFO_whereIMMEDIATE:
10306 nwh = FFEINFO_whereIMMEDIATE;
10307 break;
10308
10309 default:
10310 nwh = FFEINFO_whereFLEETING;
10311 break;
10312 }
10313 break;
10314
10315 case FFEINFO_whereIMMEDIATE:
10316 switch (rwh)
10317 {
10318 case FFEINFO_whereCONSTANT:
10319 case FFEINFO_whereIMMEDIATE:
10320 nwh = FFEINFO_whereIMMEDIATE;
10321 break;
10322
10323 default:
10324 nwh = FFEINFO_whereFLEETING;
10325 break;
10326 }
10327 break;
10328
10329 default:
10330 nwh = FFEINFO_whereFLEETING;
10331 break;
10332 }
10333
10334 nkt = lkt;
10335 ninfo = ffeinfo_new (nbt, nkt, 0, nkd, nwh, nszk);
10336 ffebld_set_info (reduced, ninfo);
10337 return reduced;
10338 }
10339
10340 if ((lbt != FFEINFO_basictypeCHARACTER) && (rbt != FFEINFO_basictypeCHARACTER))
10341 {
10342 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10343 && ffebad_start (FFEBAD_CONCAT_ARGS_TYPE))
10344 {
10345 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10346 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10347 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10348 ffebad_finish ();
10349 }
10350 }
10351 else if (lbt != FFEINFO_basictypeCHARACTER)
10352 {
10353 if ((lbt != FFEINFO_basictypeANY)
10354 && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
10355 {
10356 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10357 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10358 ffebad_finish ();
10359 }
10360 }
10361 else if (rbt != FFEINFO_basictypeCHARACTER)
10362 {
10363 if ((rbt != FFEINFO_basictypeANY)
10364 && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
10365 {
10366 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10367 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10368 ffebad_finish ();
10369 }
10370 }
10371 else if ((lrk != 0) || (lszm == FFETARGET_charactersizeNONE))
10372 {
10373 if ((lkd != FFEINFO_kindANY)
10374 && ffebad_start (FFEBAD_CONCAT_ARG_KIND))
10375 {
10376 const char *what;
10377
10378 if (lrk != 0)
10379 what = "an array";
10380 else
10381 what = "of indeterminate length";
10382 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10383 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10384 ffebad_string (what);
10385 ffebad_finish ();
10386 }
10387 }
10388 else
10389 {
10390 if (ffebad_start (FFEBAD_CONCAT_ARG_KIND))
10391 {
10392 const char *what;
10393
10394 if (rrk != 0)
10395 what = "an array";
10396 else
10397 what = "of indeterminate length";
10398 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10399 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10400 ffebad_string (what);
10401 ffebad_finish ();
10402 }
10403 }
10404
10405 reduced = ffebld_new_any ();
10406 ffebld_set_info (reduced, ffeinfo_new_any ());
10407 return reduced;
10408 }
10409
10410 /* ffeexpr_reduced_eqop2_ -- Wrap up reduction of EQ and NE operators
10411
10412 reduced = ffeexpr_reduced_eqop2_(reduced,l,op,r);
10413
10414 Makes sure the left and right arguments for reduced have basictype of
10415 INTEGER, REAL, COMPLEX, or CHARACTER. Determine common basictype and
10416 size for reduction. If both left
10417 and right arguments have where of CONSTANT, assign where CONSTANT to
10418 reduced, else assign where FLEETING. Create CONVERT ops for args where
10419 needed. Convert typeless
10420 constants to the desired type/size explicitly.
10421
10422 If these requirements cannot be met, generate error message. */
10423
10424 static ffebld
10425 ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10426 ffeexprExpr_ r)
10427 {
10428 ffeinfo linfo, rinfo, ninfo;
10429 ffeinfoBasictype lbt, rbt, nbt;
10430 ffeinfoKindtype lkt, rkt, nkt;
10431 ffeinfoRank lrk, rrk;
10432 ffeinfoKind lkd, rkd;
10433 ffeinfoWhere lwh, rwh, nwh;
10434 ffetargetCharacterSize lsz, rsz;
10435
10436 linfo = ffebld_info (ffebld_left (reduced));
10437 lbt = ffeinfo_basictype (linfo);
10438 lkt = ffeinfo_kindtype (linfo);
10439 lrk = ffeinfo_rank (linfo);
10440 lkd = ffeinfo_kind (linfo);
10441 lwh = ffeinfo_where (linfo);
10442 lsz = ffebld_size_known (ffebld_left (reduced));
10443
10444 rinfo = ffebld_info (ffebld_right (reduced));
10445 rbt = ffeinfo_basictype (rinfo);
10446 rkt = ffeinfo_kindtype (rinfo);
10447 rrk = ffeinfo_rank (rinfo);
10448 rkd = ffeinfo_kind (rinfo);
10449 rwh = ffeinfo_where (rinfo);
10450 rsz = ffebld_size_known (ffebld_right (reduced));
10451
10452 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10453
10454 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10455 || (nbt == FFEINFO_basictypeCOMPLEX) || (nbt == FFEINFO_basictypeCHARACTER))
10456 && (lrk == 0) && (rrk == 0))
10457 {
10458 switch (lwh)
10459 {
10460 case FFEINFO_whereCONSTANT:
10461 switch (rwh)
10462 {
10463 case FFEINFO_whereCONSTANT:
10464 nwh = FFEINFO_whereCONSTANT;
10465 break;
10466
10467 case FFEINFO_whereIMMEDIATE:
10468 nwh = FFEINFO_whereIMMEDIATE;
10469 break;
10470
10471 default:
10472 nwh = FFEINFO_whereFLEETING;
10473 break;
10474 }
10475 break;
10476
10477 case FFEINFO_whereIMMEDIATE:
10478 switch (rwh)
10479 {
10480 case FFEINFO_whereCONSTANT:
10481 case FFEINFO_whereIMMEDIATE:
10482 nwh = FFEINFO_whereIMMEDIATE;
10483 break;
10484
10485 default:
10486 nwh = FFEINFO_whereFLEETING;
10487 break;
10488 }
10489 break;
10490
10491 default:
10492 nwh = FFEINFO_whereFLEETING;
10493 break;
10494 }
10495
10496 if ((lsz != FFETARGET_charactersizeNONE)
10497 && (rsz != FFETARGET_charactersizeNONE))
10498 lsz = rsz = (lsz > rsz) ? lsz : rsz;
10499
10500 ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
10501 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
10502 ffebld_set_info (reduced, ninfo);
10503 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10504 l->token, op->token, nbt, nkt, 0, lsz,
10505 FFEEXPR_contextLET));
10506 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10507 r->token, op->token, nbt, nkt, 0, rsz,
10508 FFEEXPR_contextLET));
10509 return reduced;
10510 }
10511
10512 if ((lbt == FFEINFO_basictypeLOGICAL)
10513 && (rbt == FFEINFO_basictypeLOGICAL))
10514 {
10515 /* xgettext:no-c-format */
10516 if (ffebad_start_msg ("Use .EQV./.NEQV. instead of .EQ./.NE. at %0 for LOGICAL operands at %1 and %2",
10517 FFEBAD_severityFATAL))
10518 {
10519 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10520 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10521 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10522 ffebad_finish ();
10523 }
10524 }
10525 else if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10526 && (lbt != FFEINFO_basictypeCOMPLEX) && (lbt != FFEINFO_basictypeCHARACTER))
10527 {
10528 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10529 && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
10530 {
10531 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10532 && ffebad_start (FFEBAD_EQOP_ARGS_TYPE))
10533 {
10534 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10535 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10536 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10537 ffebad_finish ();
10538 }
10539 }
10540 else
10541 {
10542 if ((lbt != FFEINFO_basictypeANY)
10543 && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
10544 {
10545 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10546 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10547 ffebad_finish ();
10548 }
10549 }
10550 }
10551 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10552 && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
10553 {
10554 if ((rbt != FFEINFO_basictypeANY)
10555 && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
10556 {
10557 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10558 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10559 ffebad_finish ();
10560 }
10561 }
10562 else if (lrk != 0)
10563 {
10564 if ((lkd != FFEINFO_kindANY)
10565 && ffebad_start (FFEBAD_EQOP_ARG_KIND))
10566 {
10567 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10568 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10569 ffebad_string ("an array");
10570 ffebad_finish ();
10571 }
10572 }
10573 else
10574 {
10575 if ((rkd != FFEINFO_kindANY)
10576 && ffebad_start (FFEBAD_EQOP_ARG_KIND))
10577 {
10578 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10579 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10580 ffebad_string ("an array");
10581 ffebad_finish ();
10582 }
10583 }
10584
10585 reduced = ffebld_new_any ();
10586 ffebld_set_info (reduced, ffeinfo_new_any ());
10587 return reduced;
10588 }
10589
10590 /* ffeexpr_reduced_math1_ -- Wrap up reduction of + - unary operators
10591
10592 reduced = ffeexpr_reduced_math1_(reduced,op,r);
10593
10594 Makes sure the argument for reduced has basictype of
10595 INTEGER, REAL, or COMPLEX. If the argument has where of CONSTANT,
10596 assign where CONSTANT to
10597 reduced, else assign where FLEETING.
10598
10599 If these requirements cannot be met, generate error message. */
10600
10601 static ffebld
10602 ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10603 {
10604 ffeinfo rinfo, ninfo;
10605 ffeinfoBasictype rbt;
10606 ffeinfoKindtype rkt;
10607 ffeinfoRank rrk;
10608 ffeinfoKind rkd;
10609 ffeinfoWhere rwh, nwh;
10610
10611 rinfo = ffebld_info (ffebld_left (reduced));
10612 rbt = ffeinfo_basictype (rinfo);
10613 rkt = ffeinfo_kindtype (rinfo);
10614 rrk = ffeinfo_rank (rinfo);
10615 rkd = ffeinfo_kind (rinfo);
10616 rwh = ffeinfo_where (rinfo);
10617
10618 if (((rbt == FFEINFO_basictypeINTEGER) || (rbt == FFEINFO_basictypeREAL)
10619 || (rbt == FFEINFO_basictypeCOMPLEX)) && (rrk == 0))
10620 {
10621 switch (rwh)
10622 {
10623 case FFEINFO_whereCONSTANT:
10624 nwh = FFEINFO_whereCONSTANT;
10625 break;
10626
10627 case FFEINFO_whereIMMEDIATE:
10628 nwh = FFEINFO_whereIMMEDIATE;
10629 break;
10630
10631 default:
10632 nwh = FFEINFO_whereFLEETING;
10633 break;
10634 }
10635
10636 ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
10637 FFETARGET_charactersizeNONE);
10638 ffebld_set_info (reduced, ninfo);
10639 return reduced;
10640 }
10641
10642 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10643 && (rbt != FFEINFO_basictypeCOMPLEX))
10644 {
10645 if ((rbt != FFEINFO_basictypeANY)
10646 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10647 {
10648 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10649 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10650 ffebad_finish ();
10651 }
10652 }
10653 else
10654 {
10655 if ((rkd != FFEINFO_kindANY)
10656 && ffebad_start (FFEBAD_MATH_ARG_KIND))
10657 {
10658 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10659 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10660 ffebad_string ("an array");
10661 ffebad_finish ();
10662 }
10663 }
10664
10665 reduced = ffebld_new_any ();
10666 ffebld_set_info (reduced, ffeinfo_new_any ());
10667 return reduced;
10668 }
10669
10670 /* ffeexpr_reduced_math2_ -- Wrap up reduction of + - * / operators
10671
10672 reduced = ffeexpr_reduced_math2_(reduced,l,op,r);
10673
10674 Makes sure the left and right arguments for reduced have basictype of
10675 INTEGER, REAL, or COMPLEX. Determine common basictype and
10676 size for reduction (flag expression for combined hollerith/typeless
10677 situations for later determination of effective basictype). If both left
10678 and right arguments have where of CONSTANT, assign where CONSTANT to
10679 reduced, else assign where FLEETING. Create CONVERT ops for args where
10680 needed. Convert typeless
10681 constants to the desired type/size explicitly.
10682
10683 If these requirements cannot be met, generate error message. */
10684
10685 static ffebld
10686 ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10687 ffeexprExpr_ r)
10688 {
10689 ffeinfo linfo, rinfo, ninfo;
10690 ffeinfoBasictype lbt, rbt, nbt;
10691 ffeinfoKindtype lkt, rkt, nkt;
10692 ffeinfoRank lrk, rrk;
10693 ffeinfoKind lkd, rkd;
10694 ffeinfoWhere lwh, rwh, nwh;
10695
10696 linfo = ffebld_info (ffebld_left (reduced));
10697 lbt = ffeinfo_basictype (linfo);
10698 lkt = ffeinfo_kindtype (linfo);
10699 lrk = ffeinfo_rank (linfo);
10700 lkd = ffeinfo_kind (linfo);
10701 lwh = ffeinfo_where (linfo);
10702
10703 rinfo = ffebld_info (ffebld_right (reduced));
10704 rbt = ffeinfo_basictype (rinfo);
10705 rkt = ffeinfo_kindtype (rinfo);
10706 rrk = ffeinfo_rank (rinfo);
10707 rkd = ffeinfo_kind (rinfo);
10708 rwh = ffeinfo_where (rinfo);
10709
10710 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10711
10712 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10713 || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
10714 {
10715 switch (lwh)
10716 {
10717 case FFEINFO_whereCONSTANT:
10718 switch (rwh)
10719 {
10720 case FFEINFO_whereCONSTANT:
10721 nwh = FFEINFO_whereCONSTANT;
10722 break;
10723
10724 case FFEINFO_whereIMMEDIATE:
10725 nwh = FFEINFO_whereIMMEDIATE;
10726 break;
10727
10728 default:
10729 nwh = FFEINFO_whereFLEETING;
10730 break;
10731 }
10732 break;
10733
10734 case FFEINFO_whereIMMEDIATE:
10735 switch (rwh)
10736 {
10737 case FFEINFO_whereCONSTANT:
10738 case FFEINFO_whereIMMEDIATE:
10739 nwh = FFEINFO_whereIMMEDIATE;
10740 break;
10741
10742 default:
10743 nwh = FFEINFO_whereFLEETING;
10744 break;
10745 }
10746 break;
10747
10748 default:
10749 nwh = FFEINFO_whereFLEETING;
10750 break;
10751 }
10752
10753 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10754 FFETARGET_charactersizeNONE);
10755 ffebld_set_info (reduced, ninfo);
10756 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10757 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10758 FFEEXPR_contextLET));
10759 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10760 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10761 FFEEXPR_contextLET));
10762 return reduced;
10763 }
10764
10765 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10766 && (lbt != FFEINFO_basictypeCOMPLEX))
10767 {
10768 if ((rbt != FFEINFO_basictypeINTEGER)
10769 && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
10770 {
10771 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10772 && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
10773 {
10774 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10775 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10776 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10777 ffebad_finish ();
10778 }
10779 }
10780 else
10781 {
10782 if ((lbt != FFEINFO_basictypeANY)
10783 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10784 {
10785 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10786 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10787 ffebad_finish ();
10788 }
10789 }
10790 }
10791 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10792 && (rbt != FFEINFO_basictypeCOMPLEX))
10793 {
10794 if ((rbt != FFEINFO_basictypeANY)
10795 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10796 {
10797 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10798 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10799 ffebad_finish ();
10800 }
10801 }
10802 else if (lrk != 0)
10803 {
10804 if ((lkd != FFEINFO_kindANY)
10805 && ffebad_start (FFEBAD_MATH_ARG_KIND))
10806 {
10807 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10808 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10809 ffebad_string ("an array");
10810 ffebad_finish ();
10811 }
10812 }
10813 else
10814 {
10815 if ((rkd != FFEINFO_kindANY)
10816 && ffebad_start (FFEBAD_MATH_ARG_KIND))
10817 {
10818 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10819 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10820 ffebad_string ("an array");
10821 ffebad_finish ();
10822 }
10823 }
10824
10825 reduced = ffebld_new_any ();
10826 ffebld_set_info (reduced, ffeinfo_new_any ());
10827 return reduced;
10828 }
10829
10830 /* ffeexpr_reduced_power_ -- Wrap up reduction of ** operator
10831
10832 reduced = ffeexpr_reduced_power_(reduced,l,op,r);
10833
10834 Makes sure the left and right arguments for reduced have basictype of
10835 INTEGER, REAL, or COMPLEX. Determine common basictype and
10836 size for reduction (flag expression for combined hollerith/typeless
10837 situations for later determination of effective basictype). If both left
10838 and right arguments have where of CONSTANT, assign where CONSTANT to
10839 reduced, else assign where FLEETING. Create CONVERT ops for args where
10840 needed. Note that real**int or complex**int
10841 comes out as int = real**int etc with no conversions.
10842
10843 If these requirements cannot be met, generate error message using the
10844 info in l, op, and r arguments and assign basictype, size, kind, and where
10845 of ANY. */
10846
10847 static ffebld
10848 ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10849 ffeexprExpr_ r)
10850 {
10851 ffeinfo linfo, rinfo, ninfo;
10852 ffeinfoBasictype lbt, rbt, nbt;
10853 ffeinfoKindtype lkt, rkt, nkt;
10854 ffeinfoRank lrk, rrk;
10855 ffeinfoKind lkd, rkd;
10856 ffeinfoWhere lwh, rwh, nwh;
10857
10858 linfo = ffebld_info (ffebld_left (reduced));
10859 lbt = ffeinfo_basictype (linfo);
10860 lkt = ffeinfo_kindtype (linfo);
10861 lrk = ffeinfo_rank (linfo);
10862 lkd = ffeinfo_kind (linfo);
10863 lwh = ffeinfo_where (linfo);
10864
10865 rinfo = ffebld_info (ffebld_right (reduced));
10866 rbt = ffeinfo_basictype (rinfo);
10867 rkt = ffeinfo_kindtype (rinfo);
10868 rrk = ffeinfo_rank (rinfo);
10869 rkd = ffeinfo_kind (rinfo);
10870 rwh = ffeinfo_where (rinfo);
10871
10872 if ((rbt == FFEINFO_basictypeINTEGER)
10873 && ((lbt == FFEINFO_basictypeREAL)
10874 || (lbt == FFEINFO_basictypeCOMPLEX)))
10875 {
10876 nbt = lbt;
10877 nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDEFAULT);
10878 if (nkt != FFEINFO_kindtypeREALDEFAULT)
10879 {
10880 nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDOUBLE);
10881 if (nkt != FFEINFO_kindtypeREALDOUBLE)
10882 nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */
10883 }
10884 if (rkt == FFEINFO_kindtypeINTEGER4)
10885 {
10886 /* xgettext:no-c-format */
10887 ffebad_start_msg ("Unsupported operand for ** at %1 -- converting to default INTEGER",
10888 FFEBAD_severityWARNING);
10889 ffebad_here (0, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10890 ffebad_finish ();
10891 }
10892 if (rkt != FFEINFO_kindtypeINTEGERDEFAULT)
10893 {
10894 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10895 r->token, op->token,
10896 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0,
10897 FFETARGET_charactersizeNONE,
10898 FFEEXPR_contextLET));
10899 rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10900 }
10901 }
10902 else
10903 {
10904 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10905
10906 #if 0 /* INTEGER4**INTEGER4 works now. */
10907 if ((nbt == FFEINFO_basictypeINTEGER)
10908 && (nkt != FFEINFO_kindtypeINTEGERDEFAULT))
10909 nkt = FFEINFO_kindtypeINTEGERDEFAULT; /* Highest kt we can power! */
10910 #endif
10911 if (((nbt == FFEINFO_basictypeREAL)
10912 || (nbt == FFEINFO_basictypeCOMPLEX))
10913 && (nkt != FFEINFO_kindtypeREALDEFAULT))
10914 {
10915 nkt = ffeinfo_kindtype_max (nbt, nkt, FFEINFO_kindtypeREALDOUBLE);
10916 if (nkt != FFEINFO_kindtypeREALDOUBLE)
10917 nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */
10918 }
10919 /* else Gonna turn into an error below. */
10920 }
10921
10922 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10923 || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
10924 {
10925 switch (lwh)
10926 {
10927 case FFEINFO_whereCONSTANT:
10928 switch (rwh)
10929 {
10930 case FFEINFO_whereCONSTANT:
10931 nwh = FFEINFO_whereCONSTANT;
10932 break;
10933
10934 case FFEINFO_whereIMMEDIATE:
10935 nwh = FFEINFO_whereIMMEDIATE;
10936 break;
10937
10938 default:
10939 nwh = FFEINFO_whereFLEETING;
10940 break;
10941 }
10942 break;
10943
10944 case FFEINFO_whereIMMEDIATE:
10945 switch (rwh)
10946 {
10947 case FFEINFO_whereCONSTANT:
10948 case FFEINFO_whereIMMEDIATE:
10949 nwh = FFEINFO_whereIMMEDIATE;
10950 break;
10951
10952 default:
10953 nwh = FFEINFO_whereFLEETING;
10954 break;
10955 }
10956 break;
10957
10958 default:
10959 nwh = FFEINFO_whereFLEETING;
10960 break;
10961 }
10962
10963 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10964 FFETARGET_charactersizeNONE);
10965 ffebld_set_info (reduced, ninfo);
10966 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10967 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10968 FFEEXPR_contextLET));
10969 if (rbt != FFEINFO_basictypeINTEGER)
10970 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10971 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10972 FFEEXPR_contextLET));
10973 return reduced;
10974 }
10975
10976 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10977 && (lbt != FFEINFO_basictypeCOMPLEX))
10978 {
10979 if ((rbt != FFEINFO_basictypeINTEGER)
10980 && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
10981 {
10982 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10983 && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
10984 {
10985 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10986 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10987 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10988 ffebad_finish ();
10989 }
10990 }
10991 else
10992 {
10993 if ((lbt != FFEINFO_basictypeANY)
10994 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10995 {
10996 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10997 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10998 ffebad_finish ();
10999 }
11000 }
11001 }
11002 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
11003 && (rbt != FFEINFO_basictypeCOMPLEX))
11004 {
11005 if ((rbt != FFEINFO_basictypeANY)
11006 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
11007 {
11008 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11009 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11010 ffebad_finish ();
11011 }
11012 }
11013 else if (lrk != 0)
11014 {
11015 if ((lkd != FFEINFO_kindANY)
11016 && ffebad_start (FFEBAD_MATH_ARG_KIND))
11017 {
11018 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11019 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11020 ffebad_string ("an array");
11021 ffebad_finish ();
11022 }
11023 }
11024 else
11025 {
11026 if ((rkd != FFEINFO_kindANY)
11027 && ffebad_start (FFEBAD_MATH_ARG_KIND))
11028 {
11029 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11030 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11031 ffebad_string ("an array");
11032 ffebad_finish ();
11033 }
11034 }
11035
11036 reduced = ffebld_new_any ();
11037 ffebld_set_info (reduced, ffeinfo_new_any ());
11038 return reduced;
11039 }
11040
11041 /* ffeexpr_reduced_relop2_ -- Wrap up reduction of LT, LE, GE, and GT operators
11042
11043 reduced = ffeexpr_reduced_relop2_(reduced,l,op,r);
11044
11045 Makes sure the left and right arguments for reduced have basictype of
11046 INTEGER, REAL, or CHARACTER. Determine common basictype and
11047 size for reduction. If both left
11048 and right arguments have where of CONSTANT, assign where CONSTANT to
11049 reduced, else assign where FLEETING. Create CONVERT ops for args where
11050 needed. Convert typeless
11051 constants to the desired type/size explicitly.
11052
11053 If these requirements cannot be met, generate error message. */
11054
11055 static ffebld
11056 ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
11057 ffeexprExpr_ r)
11058 {
11059 ffeinfo linfo, rinfo, ninfo;
11060 ffeinfoBasictype lbt, rbt, nbt;
11061 ffeinfoKindtype lkt, rkt, nkt;
11062 ffeinfoRank lrk, rrk;
11063 ffeinfoKind lkd, rkd;
11064 ffeinfoWhere lwh, rwh, nwh;
11065 ffetargetCharacterSize lsz, rsz;
11066
11067 linfo = ffebld_info (ffebld_left (reduced));
11068 lbt = ffeinfo_basictype (linfo);
11069 lkt = ffeinfo_kindtype (linfo);
11070 lrk = ffeinfo_rank (linfo);
11071 lkd = ffeinfo_kind (linfo);
11072 lwh = ffeinfo_where (linfo);
11073 lsz = ffebld_size_known (ffebld_left (reduced));
11074
11075 rinfo = ffebld_info (ffebld_right (reduced));
11076 rbt = ffeinfo_basictype (rinfo);
11077 rkt = ffeinfo_kindtype (rinfo);
11078 rrk = ffeinfo_rank (rinfo);
11079 rkd = ffeinfo_kind (rinfo);
11080 rwh = ffeinfo_where (rinfo);
11081 rsz = ffebld_size_known (ffebld_right (reduced));
11082
11083 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
11084
11085 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
11086 || (nbt == FFEINFO_basictypeCHARACTER))
11087 && (lrk == 0) && (rrk == 0))
11088 {
11089 switch (lwh)
11090 {
11091 case FFEINFO_whereCONSTANT:
11092 switch (rwh)
11093 {
11094 case FFEINFO_whereCONSTANT:
11095 nwh = FFEINFO_whereCONSTANT;
11096 break;
11097
11098 case FFEINFO_whereIMMEDIATE:
11099 nwh = FFEINFO_whereIMMEDIATE;
11100 break;
11101
11102 default:
11103 nwh = FFEINFO_whereFLEETING;
11104 break;
11105 }
11106 break;
11107
11108 case FFEINFO_whereIMMEDIATE:
11109 switch (rwh)
11110 {
11111 case FFEINFO_whereCONSTANT:
11112 case FFEINFO_whereIMMEDIATE:
11113 nwh = FFEINFO_whereIMMEDIATE;
11114 break;
11115
11116 default:
11117 nwh = FFEINFO_whereFLEETING;
11118 break;
11119 }
11120 break;
11121
11122 default:
11123 nwh = FFEINFO_whereFLEETING;
11124 break;
11125 }
11126
11127 if ((lsz != FFETARGET_charactersizeNONE)
11128 && (rsz != FFETARGET_charactersizeNONE))
11129 lsz = rsz = (lsz > rsz) ? lsz : rsz;
11130
11131 ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
11132 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
11133 ffebld_set_info (reduced, ninfo);
11134 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11135 l->token, op->token, nbt, nkt, 0, lsz,
11136 FFEEXPR_contextLET));
11137 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11138 r->token, op->token, nbt, nkt, 0, rsz,
11139 FFEEXPR_contextLET));
11140 return reduced;
11141 }
11142
11143 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
11144 && (lbt != FFEINFO_basictypeCHARACTER))
11145 {
11146 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
11147 && (rbt != FFEINFO_basictypeCHARACTER))
11148 {
11149 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
11150 && ffebad_start (FFEBAD_RELOP_ARGS_TYPE))
11151 {
11152 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11153 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11154 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11155 ffebad_finish ();
11156 }
11157 }
11158 else
11159 {
11160 if ((lbt != FFEINFO_basictypeANY)
11161 && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
11162 {
11163 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11164 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11165 ffebad_finish ();
11166 }
11167 }
11168 }
11169 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
11170 && (rbt != FFEINFO_basictypeCHARACTER))
11171 {
11172 if ((rbt != FFEINFO_basictypeANY)
11173 && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
11174 {
11175 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11176 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11177 ffebad_finish ();
11178 }
11179 }
11180 else if (lrk != 0)
11181 {
11182 if ((lkd != FFEINFO_kindANY)
11183 && ffebad_start (FFEBAD_RELOP_ARG_KIND))
11184 {
11185 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11186 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11187 ffebad_string ("an array");
11188 ffebad_finish ();
11189 }
11190 }
11191 else
11192 {
11193 if ((rkd != FFEINFO_kindANY)
11194 && ffebad_start (FFEBAD_RELOP_ARG_KIND))
11195 {
11196 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11197 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11198 ffebad_string ("an array");
11199 ffebad_finish ();
11200 }
11201 }
11202
11203 reduced = ffebld_new_any ();
11204 ffebld_set_info (reduced, ffeinfo_new_any ());
11205 return reduced;
11206 }
11207
11208 /* ffeexpr_reduced_ugly1_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
11209
11210 reduced = ffeexpr_reduced_ugly1_(reduced,op,r);
11211
11212 Sigh. */
11213
11214 static ffebld
11215 ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
11216 {
11217 ffeinfo rinfo;
11218 ffeinfoBasictype rbt;
11219 ffeinfoKindtype rkt;
11220 ffeinfoRank rrk;
11221 ffeinfoKind rkd;
11222 ffeinfoWhere rwh;
11223
11224 rinfo = ffebld_info (ffebld_left (reduced));
11225 rbt = ffeinfo_basictype (rinfo);
11226 rkt = ffeinfo_kindtype (rinfo);
11227 rrk = ffeinfo_rank (rinfo);
11228 rkd = ffeinfo_kind (rinfo);
11229 rwh = ffeinfo_where (rinfo);
11230
11231 if ((rbt == FFEINFO_basictypeTYPELESS)
11232 || (rbt == FFEINFO_basictypeHOLLERITH))
11233 {
11234 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11235 r->token, op->token, FFEINFO_basictypeINTEGER,
11236 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11237 FFETARGET_charactersizeNONE,
11238 FFEEXPR_contextLET));
11239 rinfo = ffebld_info (ffebld_left (reduced));
11240 rbt = FFEINFO_basictypeINTEGER;
11241 rkt = FFEINFO_kindtypeINTEGERDEFAULT;
11242 rrk = 0;
11243 rkd = FFEINFO_kindENTITY;
11244 rwh = ffeinfo_where (rinfo);
11245 }
11246
11247 if (rbt == FFEINFO_basictypeLOGICAL)
11248 {
11249 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11250 r->token, op->token, FFEINFO_basictypeINTEGER,
11251 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11252 FFETARGET_charactersizeNONE,
11253 FFEEXPR_contextLET));
11254 }
11255
11256 return reduced;
11257 }
11258
11259 /* ffeexpr_reduced_ugly1log_ -- Deal with TYPELESS and HOLLERITH
11260
11261 reduced = ffeexpr_reduced_ugly1log_(reduced,op,r);
11262
11263 Sigh. */
11264
11265 static ffebld
11266 ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
11267 {
11268 ffeinfo rinfo;
11269 ffeinfoBasictype rbt;
11270 ffeinfoKindtype rkt;
11271 ffeinfoRank rrk;
11272 ffeinfoKind rkd;
11273 ffeinfoWhere rwh;
11274
11275 rinfo = ffebld_info (ffebld_left (reduced));
11276 rbt = ffeinfo_basictype (rinfo);
11277 rkt = ffeinfo_kindtype (rinfo);
11278 rrk = ffeinfo_rank (rinfo);
11279 rkd = ffeinfo_kind (rinfo);
11280 rwh = ffeinfo_where (rinfo);
11281
11282 if ((rbt == FFEINFO_basictypeTYPELESS)
11283 || (rbt == FFEINFO_basictypeHOLLERITH))
11284 {
11285 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11286 r->token, op->token, FFEINFO_basictypeLOGICAL, 0,
11287 FFEINFO_kindtypeLOGICALDEFAULT,
11288 FFETARGET_charactersizeNONE,
11289 FFEEXPR_contextLET));
11290 rinfo = ffebld_info (ffebld_left (reduced));
11291 rbt = FFEINFO_basictypeLOGICAL;
11292 rkt = FFEINFO_kindtypeLOGICALDEFAULT;
11293 rrk = 0;
11294 rkd = FFEINFO_kindENTITY;
11295 rwh = ffeinfo_where (rinfo);
11296 }
11297
11298 return reduced;
11299 }
11300
11301 /* ffeexpr_reduced_ugly2_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
11302
11303 reduced = ffeexpr_reduced_ugly2_(reduced,l,op,r);
11304
11305 Sigh. */
11306
11307 static ffebld
11308 ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
11309 ffeexprExpr_ r)
11310 {
11311 ffeinfo linfo, rinfo;
11312 ffeinfoBasictype lbt, rbt;
11313 ffeinfoKindtype lkt, rkt;
11314 ffeinfoRank lrk, rrk;
11315 ffeinfoKind lkd, rkd;
11316 ffeinfoWhere lwh, rwh;
11317
11318 linfo = ffebld_info (ffebld_left (reduced));
11319 lbt = ffeinfo_basictype (linfo);
11320 lkt = ffeinfo_kindtype (linfo);
11321 lrk = ffeinfo_rank (linfo);
11322 lkd = ffeinfo_kind (linfo);
11323 lwh = ffeinfo_where (linfo);
11324
11325 rinfo = ffebld_info (ffebld_right (reduced));
11326 rbt = ffeinfo_basictype (rinfo);
11327 rkt = ffeinfo_kindtype (rinfo);
11328 rrk = ffeinfo_rank (rinfo);
11329 rkd = ffeinfo_kind (rinfo);
11330 rwh = ffeinfo_where (rinfo);
11331
11332 if ((lbt == FFEINFO_basictypeTYPELESS)
11333 || (lbt == FFEINFO_basictypeHOLLERITH))
11334 {
11335 if ((rbt == FFEINFO_basictypeTYPELESS)
11336 || (rbt == FFEINFO_basictypeHOLLERITH))
11337 {
11338 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11339 l->token, op->token, FFEINFO_basictypeINTEGER,
11340 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11341 FFETARGET_charactersizeNONE,
11342 FFEEXPR_contextLET));
11343 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11344 r->token, op->token, FFEINFO_basictypeINTEGER, 0,
11345 FFEINFO_kindtypeINTEGERDEFAULT,
11346 FFETARGET_charactersizeNONE,
11347 FFEEXPR_contextLET));
11348 linfo = ffebld_info (ffebld_left (reduced));
11349 rinfo = ffebld_info (ffebld_right (reduced));
11350 lbt = rbt = FFEINFO_basictypeINTEGER;
11351 lkt = rkt = FFEINFO_kindtypeINTEGERDEFAULT;
11352 lrk = rrk = 0;
11353 lkd = rkd = FFEINFO_kindENTITY;
11354 lwh = ffeinfo_where (linfo);
11355 rwh = ffeinfo_where (rinfo);
11356 }
11357 else
11358 {
11359 ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
11360 l->token, ffebld_right (reduced), r->token,
11361 FFEEXPR_contextLET));
11362 linfo = ffebld_info (ffebld_left (reduced));
11363 lbt = ffeinfo_basictype (linfo);
11364 lkt = ffeinfo_kindtype (linfo);
11365 lrk = ffeinfo_rank (linfo);
11366 lkd = ffeinfo_kind (linfo);
11367 lwh = ffeinfo_where (linfo);
11368 }
11369 }
11370 else
11371 {
11372 if ((rbt == FFEINFO_basictypeTYPELESS)
11373 || (rbt == FFEINFO_basictypeHOLLERITH))
11374 {
11375 ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
11376 r->token, ffebld_left (reduced), l->token,
11377 FFEEXPR_contextLET));
11378 rinfo = ffebld_info (ffebld_right (reduced));
11379 rbt = ffeinfo_basictype (rinfo);
11380 rkt = ffeinfo_kindtype (rinfo);
11381 rrk = ffeinfo_rank (rinfo);
11382 rkd = ffeinfo_kind (rinfo);
11383 rwh = ffeinfo_where (rinfo);
11384 }
11385 /* else Leave it alone. */
11386 }
11387
11388 if (lbt == FFEINFO_basictypeLOGICAL)
11389 {
11390 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11391 l->token, op->token, FFEINFO_basictypeINTEGER,
11392 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11393 FFETARGET_charactersizeNONE,
11394 FFEEXPR_contextLET));
11395 }
11396
11397 if (rbt == FFEINFO_basictypeLOGICAL)
11398 {
11399 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11400 r->token, op->token, FFEINFO_basictypeINTEGER,
11401 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11402 FFETARGET_charactersizeNONE,
11403 FFEEXPR_contextLET));
11404 }
11405
11406 return reduced;
11407 }
11408
11409 /* ffeexpr_reduced_ugly2log_ -- Deal with TYPELESS and HOLLERITH
11410
11411 reduced = ffeexpr_reduced_ugly2log_(reduced,l,op,r);
11412
11413 Sigh. */
11414
11415 static ffebld
11416 ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
11417 ffeexprExpr_ r)
11418 {
11419 ffeinfo linfo, rinfo;
11420 ffeinfoBasictype lbt, rbt;
11421 ffeinfoKindtype lkt, rkt;
11422 ffeinfoRank lrk, rrk;
11423 ffeinfoKind lkd, rkd;
11424 ffeinfoWhere lwh, rwh;
11425
11426 linfo = ffebld_info (ffebld_left (reduced));
11427 lbt = ffeinfo_basictype (linfo);
11428 lkt = ffeinfo_kindtype (linfo);
11429 lrk = ffeinfo_rank (linfo);
11430 lkd = ffeinfo_kind (linfo);
11431 lwh = ffeinfo_where (linfo);
11432
11433 rinfo = ffebld_info (ffebld_right (reduced));
11434 rbt = ffeinfo_basictype (rinfo);
11435 rkt = ffeinfo_kindtype (rinfo);
11436 rrk = ffeinfo_rank (rinfo);
11437 rkd = ffeinfo_kind (rinfo);
11438 rwh = ffeinfo_where (rinfo);
11439
11440 if ((lbt == FFEINFO_basictypeTYPELESS)
11441 || (lbt == FFEINFO_basictypeHOLLERITH))
11442 {
11443 if ((rbt == FFEINFO_basictypeTYPELESS)
11444 || (rbt == FFEINFO_basictypeHOLLERITH))
11445 {
11446 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11447 l->token, op->token, FFEINFO_basictypeLOGICAL,
11448 FFEINFO_kindtypeLOGICALDEFAULT, 0,
11449 FFETARGET_charactersizeNONE,
11450 FFEEXPR_contextLET));
11451 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11452 r->token, op->token, FFEINFO_basictypeLOGICAL,
11453 FFEINFO_kindtypeLOGICALDEFAULT, 0,
11454 FFETARGET_charactersizeNONE,
11455 FFEEXPR_contextLET));
11456 linfo = ffebld_info (ffebld_left (reduced));
11457 rinfo = ffebld_info (ffebld_right (reduced));
11458 lbt = rbt = FFEINFO_basictypeLOGICAL;
11459 lkt = rkt = FFEINFO_kindtypeLOGICALDEFAULT;
11460 lrk = rrk = 0;
11461 lkd = rkd = FFEINFO_kindENTITY;
11462 lwh = ffeinfo_where (linfo);
11463 rwh = ffeinfo_where (rinfo);
11464 }
11465 else
11466 {
11467 ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
11468 l->token, ffebld_right (reduced), r->token,
11469 FFEEXPR_contextLET));
11470 linfo = ffebld_info (ffebld_left (reduced));
11471 lbt = ffeinfo_basictype (linfo);
11472 lkt = ffeinfo_kindtype (linfo);
11473 lrk = ffeinfo_rank (linfo);
11474 lkd = ffeinfo_kind (linfo);
11475 lwh = ffeinfo_where (linfo);
11476 }
11477 }
11478 else
11479 {
11480 if ((rbt == FFEINFO_basictypeTYPELESS)
11481 || (rbt == FFEINFO_basictypeHOLLERITH))
11482 {
11483 ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
11484 r->token, ffebld_left (reduced), l->token,
11485 FFEEXPR_contextLET));
11486 rinfo = ffebld_info (ffebld_right (reduced));
11487 rbt = ffeinfo_basictype (rinfo);
11488 rkt = ffeinfo_kindtype (rinfo);
11489 rrk = ffeinfo_rank (rinfo);
11490 rkd = ffeinfo_kind (rinfo);
11491 rwh = ffeinfo_where (rinfo);
11492 }
11493 /* else Leave it alone. */
11494 }
11495
11496 if (lbt == FFEINFO_basictypeLOGICAL)
11497 {
11498 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11499 l->token, op->token, FFEINFO_basictypeINTEGER,
11500 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11501 FFETARGET_charactersizeNONE,
11502 FFEEXPR_contextLET));
11503 }
11504
11505 if (rbt == FFEINFO_basictypeLOGICAL)
11506 {
11507 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11508 r->token, op->token, FFEINFO_basictypeINTEGER,
11509 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11510 FFETARGET_charactersizeNONE,
11511 FFEEXPR_contextLET));
11512 }
11513
11514 return reduced;
11515 }
11516
11517 /* Fumble through tokens until a nonmatching CLOSE_PAREN, EOS, or SEMICOLON
11518 is found.
11519
11520 The idea is to process the tokens as they would be done by normal
11521 expression processing, with the key things being telling the lexer
11522 when hollerith/character constants are about to happen, until the
11523 true closing token is found. */
11524
11525 static ffelexHandler
11526 ffeexpr_find_close_paren_ (ffelexToken t,
11527 ffelexHandler after)
11528 {
11529 ffeexpr_find_.after = after;
11530 ffeexpr_find_.level = 1;
11531 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11532 }
11533
11534 static ffelexHandler
11535 ffeexpr_nil_finished_ (ffelexToken t)
11536 {
11537 switch (ffelex_token_type (t))
11538 {
11539 case FFELEX_typeCLOSE_PAREN:
11540 if (--ffeexpr_find_.level == 0)
11541 return (ffelexHandler) ffeexpr_find_.after;
11542 return (ffelexHandler) ffeexpr_nil_binary_;
11543
11544 case FFELEX_typeCOMMA:
11545 case FFELEX_typeCOLON:
11546 case FFELEX_typeEQUALS:
11547 case FFELEX_typePOINTS:
11548 return (ffelexHandler) ffeexpr_nil_rhs_;
11549
11550 default:
11551 if (--ffeexpr_find_.level == 0)
11552 return (ffelexHandler) ffeexpr_find_.after (t);
11553 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11554 }
11555 }
11556
11557 static ffelexHandler
11558 ffeexpr_nil_rhs_ (ffelexToken t)
11559 {
11560 switch (ffelex_token_type (t))
11561 {
11562 case FFELEX_typeQUOTE:
11563 if (ffe_is_vxt ())
11564 return (ffelexHandler) ffeexpr_nil_quote_;
11565 ffelex_set_expecting_hollerith (-1, '\"',
11566 ffelex_token_where_line (t),
11567 ffelex_token_where_column (t));
11568 return (ffelexHandler) ffeexpr_nil_apostrophe_;
11569
11570 case FFELEX_typeAPOSTROPHE:
11571 ffelex_set_expecting_hollerith (-1, '\'',
11572 ffelex_token_where_line (t),
11573 ffelex_token_where_column (t));
11574 return (ffelexHandler) ffeexpr_nil_apostrophe_;
11575
11576 case FFELEX_typePERCENT:
11577 return (ffelexHandler) ffeexpr_nil_percent_;
11578
11579 case FFELEX_typeOPEN_PAREN:
11580 ++ffeexpr_find_.level;
11581 return (ffelexHandler) ffeexpr_nil_rhs_;
11582
11583 case FFELEX_typePLUS:
11584 case FFELEX_typeMINUS:
11585 return (ffelexHandler) ffeexpr_nil_rhs_;
11586
11587 case FFELEX_typePERIOD:
11588 return (ffelexHandler) ffeexpr_nil_period_;
11589
11590 case FFELEX_typeNUMBER:
11591 ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
11592 if (ffeexpr_hollerith_count_ > 0)
11593 ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
11594 '\0',
11595 ffelex_token_where_line (t),
11596 ffelex_token_where_column (t));
11597 return (ffelexHandler) ffeexpr_nil_number_;
11598
11599 case FFELEX_typeNAME:
11600 case FFELEX_typeNAMES:
11601 return (ffelexHandler) ffeexpr_nil_name_rhs_;
11602
11603 case FFELEX_typeASTERISK:
11604 case FFELEX_typeSLASH:
11605 case FFELEX_typePOWER:
11606 case FFELEX_typeCONCAT:
11607 case FFELEX_typeREL_EQ:
11608 case FFELEX_typeREL_NE:
11609 case FFELEX_typeREL_LE:
11610 case FFELEX_typeREL_GE:
11611 return (ffelexHandler) ffeexpr_nil_rhs_;
11612
11613 default:
11614 return (ffelexHandler) ffeexpr_nil_finished_ (t);
11615 }
11616 }
11617
11618 static ffelexHandler
11619 ffeexpr_nil_period_ (ffelexToken t)
11620 {
11621 switch (ffelex_token_type (t))
11622 {
11623 case FFELEX_typeNAME:
11624 case FFELEX_typeNAMES:
11625 ffeexpr_current_dotdot_ = ffestr_other (t);
11626 switch (ffeexpr_current_dotdot_)
11627 {
11628 case FFESTR_otherNone:
11629 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11630
11631 case FFESTR_otherTRUE:
11632 case FFESTR_otherFALSE:
11633 case FFESTR_otherNOT:
11634 return (ffelexHandler) ffeexpr_nil_end_period_;
11635
11636 default:
11637 return (ffelexHandler) ffeexpr_nil_swallow_period_;
11638 }
11639 break; /* Nothing really reaches here. */
11640
11641 case FFELEX_typeNUMBER:
11642 return (ffelexHandler) ffeexpr_nil_real_;
11643
11644 default:
11645 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11646 }
11647 }
11648
11649 static ffelexHandler
11650 ffeexpr_nil_end_period_ (ffelexToken t)
11651 {
11652 switch (ffeexpr_current_dotdot_)
11653 {
11654 case FFESTR_otherNOT:
11655 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11656 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11657 return (ffelexHandler) ffeexpr_nil_rhs_;
11658
11659 case FFESTR_otherTRUE:
11660 case FFESTR_otherFALSE:
11661 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11662 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11663 return (ffelexHandler) ffeexpr_nil_binary_;
11664
11665 default:
11666 assert ("Bad [nil] unary dotdot in ffeexpr_current_dotdot_" == NULL);
11667 exit (0);
11668 return NULL;
11669 }
11670 }
11671
11672 static ffelexHandler
11673 ffeexpr_nil_swallow_period_ (ffelexToken t)
11674 {
11675 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11676 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11677 return (ffelexHandler) ffeexpr_nil_rhs_;
11678 }
11679
11680 static ffelexHandler
11681 ffeexpr_nil_real_ (ffelexToken t)
11682 {
11683 char d;
11684 const char *p;
11685
11686 if (((ffelex_token_type (t) != FFELEX_typeNAME)
11687 && (ffelex_token_type (t) != FFELEX_typeNAMES))
11688 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11689 'D', 'd')
11690 || ffesrc_char_match_init (d, 'E', 'e')
11691 || ffesrc_char_match_init (d, 'Q', 'q')))
11692 && ffeexpr_isdigits_ (++p)))
11693 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11694
11695 if (*p == '\0')
11696 return (ffelexHandler) ffeexpr_nil_real_exponent_;
11697 return (ffelexHandler) ffeexpr_nil_binary_;
11698 }
11699
11700 static ffelexHandler
11701 ffeexpr_nil_real_exponent_ (ffelexToken t)
11702 {
11703 if ((ffelex_token_type (t) != FFELEX_typePLUS)
11704 && (ffelex_token_type (t) != FFELEX_typeMINUS))
11705 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11706
11707 return (ffelexHandler) ffeexpr_nil_real_exp_sign_;
11708 }
11709
11710 static ffelexHandler
11711 ffeexpr_nil_real_exp_sign_ (ffelexToken t)
11712 {
11713 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11714 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11715 return (ffelexHandler) ffeexpr_nil_binary_;
11716 }
11717
11718 static ffelexHandler
11719 ffeexpr_nil_number_ (ffelexToken t)
11720 {
11721 char d;
11722 const char *p;
11723
11724 if (ffeexpr_hollerith_count_ > 0)
11725 ffelex_set_expecting_hollerith (0, '\0',
11726 ffewhere_line_unknown (),
11727 ffewhere_column_unknown ());
11728
11729 switch (ffelex_token_type (t))
11730 {
11731 case FFELEX_typeNAME:
11732 case FFELEX_typeNAMES:
11733 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11734 'D', 'd')
11735 || ffesrc_char_match_init (d, 'E', 'e')
11736 || ffesrc_char_match_init (d, 'Q', 'q'))
11737 && ffeexpr_isdigits_ (++p))
11738 {
11739 if (*p == '\0')
11740 {
11741 ffeexpr_find_.t = ffelex_token_use (t);
11742 return (ffelexHandler) ffeexpr_nil_number_exponent_;
11743 }
11744 return (ffelexHandler) ffeexpr_nil_binary_;
11745 }
11746 break;
11747
11748 case FFELEX_typePERIOD:
11749 ffeexpr_find_.t = ffelex_token_use (t);
11750 return (ffelexHandler) ffeexpr_nil_number_period_;
11751
11752 case FFELEX_typeHOLLERITH:
11753 return (ffelexHandler) ffeexpr_nil_binary_;
11754
11755 default:
11756 break;
11757 }
11758 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11759 }
11760
11761 /* Expects ffeexpr_find_.t. */
11762
11763 static ffelexHandler
11764 ffeexpr_nil_number_exponent_ (ffelexToken t)
11765 {
11766 ffelexHandler nexthandler;
11767
11768 if ((ffelex_token_type (t) != FFELEX_typePLUS)
11769 && (ffelex_token_type (t) != FFELEX_typeMINUS))
11770 {
11771 nexthandler
11772 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
11773 ffelex_token_kill (ffeexpr_find_.t);
11774 return (ffelexHandler) (*nexthandler) (t);
11775 }
11776
11777 ffelex_token_kill (ffeexpr_find_.t);
11778 return (ffelexHandler) ffeexpr_nil_number_exp_sign_;
11779 }
11780
11781 static ffelexHandler
11782 ffeexpr_nil_number_exp_sign_ (ffelexToken t)
11783 {
11784 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11785 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11786
11787 return (ffelexHandler) ffeexpr_nil_binary_;
11788 }
11789
11790 /* Expects ffeexpr_find_.t. */
11791
11792 static ffelexHandler
11793 ffeexpr_nil_number_period_ (ffelexToken t)
11794 {
11795 ffelexHandler nexthandler;
11796 char d;
11797 const char *p;
11798
11799 switch (ffelex_token_type (t))
11800 {
11801 case FFELEX_typeNAME:
11802 case FFELEX_typeNAMES:
11803 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11804 'D', 'd')
11805 || ffesrc_char_match_init (d, 'E', 'e')
11806 || ffesrc_char_match_init (d, 'Q', 'q'))
11807 && ffeexpr_isdigits_ (++p))
11808 {
11809 if (*p == '\0')
11810 return (ffelexHandler) ffeexpr_nil_number_per_exp_;
11811 ffelex_token_kill (ffeexpr_find_.t);
11812 return (ffelexHandler) ffeexpr_nil_binary_;
11813 }
11814 nexthandler
11815 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
11816 ffelex_token_kill (ffeexpr_find_.t);
11817 return (ffelexHandler) (*nexthandler) (t);
11818
11819 case FFELEX_typeNUMBER:
11820 ffelex_token_kill (ffeexpr_find_.t);
11821 return (ffelexHandler) ffeexpr_nil_number_real_;
11822
11823 default:
11824 break;
11825 }
11826 ffelex_token_kill (ffeexpr_find_.t);
11827 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11828 }
11829
11830 /* Expects ffeexpr_find_.t. */
11831
11832 static ffelexHandler
11833 ffeexpr_nil_number_per_exp_ (ffelexToken t)
11834 {
11835 if ((ffelex_token_type (t) != FFELEX_typePLUS)
11836 && (ffelex_token_type (t) != FFELEX_typeMINUS))
11837 {
11838 ffelexHandler nexthandler;
11839
11840 nexthandler
11841 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
11842 ffelex_token_kill (ffeexpr_find_.t);
11843 return (ffelexHandler) (*nexthandler) (t);
11844 }
11845
11846 ffelex_token_kill (ffeexpr_find_.t);
11847 return (ffelexHandler) ffeexpr_nil_num_per_exp_sign_;
11848 }
11849
11850 static ffelexHandler
11851 ffeexpr_nil_number_real_ (ffelexToken t)
11852 {
11853 char d;
11854 const char *p;
11855
11856 if (((ffelex_token_type (t) != FFELEX_typeNAME)
11857 && (ffelex_token_type (t) != FFELEX_typeNAMES))
11858 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11859 'D', 'd')
11860 || ffesrc_char_match_init (d, 'E', 'e')
11861 || ffesrc_char_match_init (d, 'Q', 'q')))
11862 && ffeexpr_isdigits_ (++p)))
11863 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11864
11865 if (*p == '\0')
11866 return (ffelexHandler) ffeexpr_nil_number_real_exp_;
11867
11868 return (ffelexHandler) ffeexpr_nil_binary_;
11869 }
11870
11871 static ffelexHandler
11872 ffeexpr_nil_num_per_exp_sign_ (ffelexToken t)
11873 {
11874 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11875 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11876 return (ffelexHandler) ffeexpr_nil_binary_;
11877 }
11878
11879 static ffelexHandler
11880 ffeexpr_nil_number_real_exp_ (ffelexToken t)
11881 {
11882 if ((ffelex_token_type (t) != FFELEX_typePLUS)
11883 && (ffelex_token_type (t) != FFELEX_typeMINUS))
11884 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11885 return (ffelexHandler) ffeexpr_nil_num_real_exp_sn_;
11886 }
11887
11888 static ffelexHandler
11889 ffeexpr_nil_num_real_exp_sn_ (ffelexToken t)
11890 {
11891 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11892 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11893 return (ffelexHandler) ffeexpr_nil_binary_;
11894 }
11895
11896 static ffelexHandler
11897 ffeexpr_nil_binary_ (ffelexToken t)
11898 {
11899 switch (ffelex_token_type (t))
11900 {
11901 case FFELEX_typePLUS:
11902 case FFELEX_typeMINUS:
11903 case FFELEX_typeASTERISK:
11904 case FFELEX_typeSLASH:
11905 case FFELEX_typePOWER:
11906 case FFELEX_typeCONCAT:
11907 case FFELEX_typeOPEN_ANGLE:
11908 case FFELEX_typeCLOSE_ANGLE:
11909 case FFELEX_typeREL_EQ:
11910 case FFELEX_typeREL_NE:
11911 case FFELEX_typeREL_GE:
11912 case FFELEX_typeREL_LE:
11913 return (ffelexHandler) ffeexpr_nil_rhs_;
11914
11915 case FFELEX_typePERIOD:
11916 return (ffelexHandler) ffeexpr_nil_binary_period_;
11917
11918 default:
11919 return (ffelexHandler) ffeexpr_nil_finished_ (t);
11920 }
11921 }
11922
11923 static ffelexHandler
11924 ffeexpr_nil_binary_period_ (ffelexToken t)
11925 {
11926 switch (ffelex_token_type (t))
11927 {
11928 case FFELEX_typeNAME:
11929 case FFELEX_typeNAMES:
11930 ffeexpr_current_dotdot_ = ffestr_other (t);
11931 switch (ffeexpr_current_dotdot_)
11932 {
11933 case FFESTR_otherTRUE:
11934 case FFESTR_otherFALSE:
11935 case FFESTR_otherNOT:
11936 return (ffelexHandler) ffeexpr_nil_binary_sw_per_;
11937
11938 default:
11939 return (ffelexHandler) ffeexpr_nil_binary_end_per_;
11940 }
11941 break; /* Nothing really reaches here. */
11942
11943 default:
11944 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11945 }
11946 }
11947
11948 static ffelexHandler
11949 ffeexpr_nil_binary_end_per_ (ffelexToken t)
11950 {
11951 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11952 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11953 return (ffelexHandler) ffeexpr_nil_rhs_;
11954 }
11955
11956 static ffelexHandler
11957 ffeexpr_nil_binary_sw_per_ (ffelexToken t)
11958 {
11959 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11960 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11961 return (ffelexHandler) ffeexpr_nil_binary_;
11962 }
11963
11964 static ffelexHandler
11965 ffeexpr_nil_quote_ (ffelexToken t)
11966 {
11967 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11968 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11969 return (ffelexHandler) ffeexpr_nil_binary_;
11970 }
11971
11972 static ffelexHandler
11973 ffeexpr_nil_apostrophe_ (ffelexToken t)
11974 {
11975 assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
11976 return (ffelexHandler) ffeexpr_nil_apos_char_;
11977 }
11978
11979 static ffelexHandler
11980 ffeexpr_nil_apos_char_ (ffelexToken t)
11981 {
11982 char c;
11983
11984 if ((ffelex_token_type (t) == FFELEX_typeNAME)
11985 || (ffelex_token_type (t) == FFELEX_typeNAMES))
11986 {
11987 if ((ffelex_token_length (t) == 1)
11988 && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]),
11989 'B', 'b')
11990 || ffesrc_char_match_init (c, 'O', 'o')
11991 || ffesrc_char_match_init (c, 'X', 'x')
11992 || ffesrc_char_match_init (c, 'Z', 'z')))
11993 return (ffelexHandler) ffeexpr_nil_binary_;
11994 }
11995 if ((ffelex_token_type (t) == FFELEX_typeNAME)
11996 || (ffelex_token_type (t) == FFELEX_typeNAMES))
11997 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11998 return (ffelexHandler) ffeexpr_nil_substrp_ (t);
11999 }
12000
12001 static ffelexHandler
12002 ffeexpr_nil_name_rhs_ (ffelexToken t)
12003 {
12004 switch (ffelex_token_type (t))
12005 {
12006 case FFELEX_typeQUOTE:
12007 case FFELEX_typeAPOSTROPHE:
12008 ffelex_set_hexnum (TRUE);
12009 return (ffelexHandler) ffeexpr_nil_name_apos_;
12010
12011 case FFELEX_typeOPEN_PAREN:
12012 ++ffeexpr_find_.level;
12013 return (ffelexHandler) ffeexpr_nil_rhs_;
12014
12015 default:
12016 return (ffelexHandler) ffeexpr_nil_binary_ (t);
12017 }
12018 }
12019
12020 static ffelexHandler
12021 ffeexpr_nil_name_apos_ (ffelexToken t)
12022 {
12023 if (ffelex_token_type (t) == FFELEX_typeNAME)
12024 return (ffelexHandler) ffeexpr_nil_name_apos_name_;
12025 return (ffelexHandler) ffeexpr_nil_binary_ (t);
12026 }
12027
12028 static ffelexHandler
12029 ffeexpr_nil_name_apos_name_ (ffelexToken t)
12030 {
12031 switch (ffelex_token_type (t))
12032 {
12033 case FFELEX_typeAPOSTROPHE:
12034 case FFELEX_typeQUOTE:
12035 return (ffelexHandler) ffeexpr_nil_finished_;
12036
12037 default:
12038 return (ffelexHandler) ffeexpr_nil_finished_ (t);
12039 }
12040 }
12041
12042 static ffelexHandler
12043 ffeexpr_nil_percent_ (ffelexToken t)
12044 {
12045 switch (ffelex_token_type (t))
12046 {
12047 case FFELEX_typeNAME:
12048 case FFELEX_typeNAMES:
12049 ffeexpr_stack_->percent = ffeexpr_percent_ (t);
12050 ffeexpr_find_.t = ffelex_token_use (t);
12051 return (ffelexHandler) ffeexpr_nil_percent_name_;
12052
12053 default:
12054 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
12055 }
12056 }
12057
12058 /* Expects ffeexpr_find_.t. */
12059
12060 static ffelexHandler
12061 ffeexpr_nil_percent_name_ (ffelexToken t)
12062 {
12063 ffelexHandler nexthandler;
12064
12065 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
12066 {
12067 nexthandler
12068 = (ffelexHandler) ffeexpr_nil_rhs_ (ffeexpr_find_.t);
12069 ffelex_token_kill (ffeexpr_find_.t);
12070 return (ffelexHandler) (*nexthandler) (t);
12071 }
12072
12073 ffelex_token_kill (ffeexpr_find_.t);
12074 ++ffeexpr_find_.level;
12075 return (ffelexHandler) ffeexpr_nil_rhs_;
12076 }
12077
12078 static ffelexHandler
12079 ffeexpr_nil_substrp_ (ffelexToken t)
12080 {
12081 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
12082 return (ffelexHandler) ffeexpr_nil_binary_ (t);
12083
12084 ++ffeexpr_find_.level;
12085 return (ffelexHandler) ffeexpr_nil_rhs_;
12086 }
12087
12088 /* ffeexpr_finished_ -- Reduce expression stack to one expr, finish
12089
12090 ffelexToken t;
12091 return ffeexpr_finished_(t);
12092
12093 Reduces expression stack to one (or zero) elements by repeatedly reducing
12094 the top operator on the stack (or, if the top element on the stack is
12095 itself an operator, issuing an error message and discarding it). Calls
12096 finishing routine with the expression, returning the ffelexHandler it
12097 returns to the caller. */
12098
12099 static ffelexHandler
12100 ffeexpr_finished_ (ffelexToken t)
12101 {
12102 ffeexprExpr_ operand; /* This is B in -B or A+B. */
12103 ffebld expr;
12104 ffeexprCallback callback;
12105 ffeexprStack_ s;
12106 ffebldConstant constnode; /* For detecting magical number. */
12107 ffelexToken ft; /* Temporary copy of first token in
12108 expression. */
12109 ffelexHandler next;
12110 ffeinfo info;
12111 bool error = FALSE;
12112
12113 while (((operand = ffeexpr_stack_->exprstack) != NULL)
12114 && ((operand->previous != NULL) || (operand->type != FFEEXPR_exprtypeOPERAND_)))
12115 {
12116 if (operand->type == FFEEXPR_exprtypeOPERAND_)
12117 ffeexpr_reduce_ ();
12118 else
12119 {
12120 if (ffest_ffebad_start (FFEBAD_MISSING_OPERAND_FOR_OPERATOR))
12121 {
12122 ffebad_here (0, ffelex_token_where_line (t),
12123 ffelex_token_where_column (t));
12124 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
12125 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
12126 ffebad_finish ();
12127 }
12128 ffeexpr_stack_->exprstack = operand->previous; /* Pop the useless
12129 operator. */
12130 ffeexpr_expr_kill_ (operand);
12131 }
12132 }
12133
12134 assert ((operand == NULL) || (operand->previous == NULL));
12135
12136 ffebld_pool_pop ();
12137 if (operand == NULL)
12138 expr = NULL;
12139 else
12140 {
12141 expr = operand->u.operand;
12142 info = ffebld_info (expr);
12143 if ((ffebld_op (expr) == FFEBLD_opCONTER)
12144 && (ffebld_conter_orig (expr) == NULL)
12145 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
12146 {
12147 ffetarget_integer_bad_magical (operand->token);
12148 }
12149 ffeexpr_expr_kill_ (operand);
12150 ffeexpr_stack_->exprstack = NULL;
12151 }
12152
12153 ft = ffeexpr_stack_->first_token;
12154
12155 again: /* :::::::::::::::::::: */
12156 switch (ffeexpr_stack_->context)
12157 {
12158 case FFEEXPR_contextLET:
12159 case FFEEXPR_contextSFUNCDEF:
12160 error = (expr == NULL)
12161 || (ffeinfo_rank (info) != 0);
12162 break;
12163
12164 case FFEEXPR_contextPAREN_:
12165 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12166 break;
12167 switch (ffeinfo_basictype (info))
12168 {
12169 case FFEINFO_basictypeHOLLERITH:
12170 case FFEINFO_basictypeTYPELESS:
12171 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12172 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12173 FFEEXPR_contextLET);
12174 break;
12175
12176 default:
12177 break;
12178 }
12179 break;
12180
12181 case FFEEXPR_contextPARENFILENUM_:
12182 if (ffelex_token_type (t) != FFELEX_typeCOMMA)
12183 ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
12184 else
12185 ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
12186 goto again; /* :::::::::::::::::::: */
12187
12188 case FFEEXPR_contextPARENFILEUNIT_:
12189 if (ffelex_token_type (t) != FFELEX_typeCOMMA)
12190 ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
12191 else
12192 ffeexpr_stack_->context = FFEEXPR_contextFILEUNIT;
12193 goto again; /* :::::::::::::::::::: */
12194
12195 case FFEEXPR_contextACTUALARGEXPR_:
12196 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
12197 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12198 : ffeinfo_basictype (info))
12199 {
12200 case FFEINFO_basictypeHOLLERITH:
12201 case FFEINFO_basictypeTYPELESS:
12202 if (!ffe_is_ugly_args ()
12203 && ffebad_start (FFEBAD_ACTUALARG))
12204 {
12205 ffebad_here (0, ffelex_token_where_line (ft),
12206 ffelex_token_where_column (ft));
12207 ffebad_finish ();
12208 }
12209 break;
12210
12211 default:
12212 break;
12213 }
12214 error = (expr != NULL) && (ffeinfo_rank (info) != 0);
12215 break;
12216
12217 case FFEEXPR_contextACTUALARG_:
12218 case FFEEXPR_contextSFUNCDEFACTUALARG_:
12219 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12220 : ffeinfo_basictype (info))
12221 {
12222 case FFEINFO_basictypeHOLLERITH:
12223 case FFEINFO_basictypeTYPELESS:
12224 #if 0 /* Should never get here. */
12225 expr = ffeexpr_convert (expr, ft, ft,
12226 FFEINFO_basictypeINTEGER,
12227 FFEINFO_kindtypeINTEGERDEFAULT,
12228 0,
12229 FFETARGET_charactersizeNONE,
12230 FFEEXPR_contextLET);
12231 #else
12232 assert ("why hollerith/typeless in actualarg_?" == NULL);
12233 #endif
12234 break;
12235
12236 default:
12237 break;
12238 }
12239 switch ((expr == NULL) ? FFEBLD_opANY : ffebld_op (expr))
12240 {
12241 case FFEBLD_opSYMTER:
12242 case FFEBLD_opPERCENT_LOC:
12243 case FFEBLD_opPERCENT_VAL:
12244 case FFEBLD_opPERCENT_REF:
12245 case FFEBLD_opPERCENT_DESCR:
12246 error = FALSE;
12247 break;
12248
12249 default:
12250 error = (expr != NULL) && (ffeinfo_rank (info) != 0);
12251 break;
12252 }
12253 {
12254 ffesymbol s;
12255 ffeinfoWhere where;
12256 ffeinfoKind kind;
12257
12258 if (!error
12259 && (expr != NULL)
12260 && (ffebld_op (expr) == FFEBLD_opSYMTER)
12261 && ((s = ffebld_symter (expr)), (where = ffesymbol_where (s)),
12262 (where == FFEINFO_whereINTRINSIC)
12263 || (where == FFEINFO_whereGLOBAL)
12264 || ((where == FFEINFO_whereDUMMY)
12265 && ((kind = ffesymbol_kind (s)),
12266 (kind == FFEINFO_kindFUNCTION)
12267 || (kind == FFEINFO_kindSUBROUTINE))))
12268 && !ffesymbol_explicitwhere (s))
12269 {
12270 ffebad_start (where == FFEINFO_whereINTRINSIC
12271 ? FFEBAD_NEED_INTRINSIC : FFEBAD_NEED_EXTERNAL);
12272 ffebad_here (0, ffelex_token_where_line (ft),
12273 ffelex_token_where_column (ft));
12274 ffebad_string (ffesymbol_text (s));
12275 ffebad_finish ();
12276 ffesymbol_signal_change (s);
12277 ffesymbol_set_explicitwhere (s, TRUE);
12278 ffesymbol_signal_unreported (s);
12279 }
12280 }
12281 break;
12282
12283 case FFEEXPR_contextINDEX_:
12284 case FFEEXPR_contextSFUNCDEFINDEX_:
12285 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12286 break;
12287 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12288 : ffeinfo_basictype (info))
12289 {
12290 case FFEINFO_basictypeNONE:
12291 error = FALSE;
12292 break;
12293
12294 case FFEINFO_basictypeLOGICAL:
12295 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12296 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12297 FFEEXPR_contextLET);
12298 /* Fall through. */
12299 case FFEINFO_basictypeREAL:
12300 case FFEINFO_basictypeCOMPLEX:
12301 if (ffe_is_pedantic ())
12302 {
12303 error = TRUE;
12304 break;
12305 }
12306 /* Fall through. */
12307 case FFEINFO_basictypeHOLLERITH:
12308 case FFEINFO_basictypeTYPELESS:
12309 error = FALSE;
12310 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12311 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12312 FFEEXPR_contextLET);
12313 break;
12314
12315 case FFEINFO_basictypeINTEGER:
12316 /* Specifically, allow INTEGER(KIND=2), aka INTEGER*8, through
12317 unmolested. Leave it to downstream to handle kinds. */
12318 break;
12319
12320 default:
12321 error = TRUE;
12322 break;
12323 }
12324 break; /* expr==NULL ok for substring; element case
12325 caught by callback. */
12326
12327 case FFEEXPR_contextRETURN:
12328 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12329 break;
12330 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12331 : ffeinfo_basictype (info))
12332 {
12333 case FFEINFO_basictypeNONE:
12334 error = FALSE;
12335 break;
12336
12337 case FFEINFO_basictypeLOGICAL:
12338 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12339 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12340 FFEEXPR_contextLET);
12341 /* Fall through. */
12342 case FFEINFO_basictypeREAL:
12343 case FFEINFO_basictypeCOMPLEX:
12344 if (ffe_is_pedantic ())
12345 {
12346 error = TRUE;
12347 break;
12348 }
12349 /* Fall through. */
12350 case FFEINFO_basictypeINTEGER:
12351 case FFEINFO_basictypeHOLLERITH:
12352 case FFEINFO_basictypeTYPELESS:
12353 error = FALSE;
12354 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12355 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12356 FFEEXPR_contextLET);
12357 break;
12358
12359 default:
12360 error = TRUE;
12361 break;
12362 }
12363 break;
12364
12365 case FFEEXPR_contextDO:
12366 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12367 break;
12368 switch (ffeinfo_basictype (info))
12369 {
12370 case FFEINFO_basictypeLOGICAL:
12371 error = !ffe_is_ugly_logint ();
12372 if (!ffeexpr_stack_->is_rhs)
12373 break; /* Don't convert lhs variable. */
12374 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12375 ffeinfo_kindtype (ffebld_info (expr)), 0,
12376 FFETARGET_charactersizeNONE,
12377 FFEEXPR_contextLET);
12378 break;
12379
12380 case FFEINFO_basictypeHOLLERITH:
12381 case FFEINFO_basictypeTYPELESS:
12382 if (!ffeexpr_stack_->is_rhs)
12383 {
12384 error = TRUE;
12385 break; /* Don't convert lhs variable. */
12386 }
12387 break;
12388
12389 case FFEINFO_basictypeINTEGER:
12390 case FFEINFO_basictypeREAL:
12391 break;
12392
12393 default:
12394 error = TRUE;
12395 break;
12396 }
12397 if (!ffeexpr_stack_->is_rhs
12398 && (ffebld_op (expr) != FFEBLD_opSYMTER))
12399 error = TRUE;
12400 break;
12401
12402 case FFEEXPR_contextDOWHILE:
12403 case FFEEXPR_contextIF:
12404 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12405 break;
12406 switch (ffeinfo_basictype (info))
12407 {
12408 case FFEINFO_basictypeINTEGER:
12409 error = FALSE;
12410 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12411 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12412 FFEEXPR_contextLET);
12413 /* Fall through. */
12414 case FFEINFO_basictypeLOGICAL:
12415 case FFEINFO_basictypeHOLLERITH:
12416 case FFEINFO_basictypeTYPELESS:
12417 error = FALSE;
12418 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12419 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12420 FFEEXPR_contextLET);
12421 break;
12422
12423 default:
12424 error = TRUE;
12425 break;
12426 }
12427 break;
12428
12429 case FFEEXPR_contextASSIGN:
12430 case FFEEXPR_contextAGOTO:
12431 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12432 : ffeinfo_basictype (info))
12433 {
12434 case FFEINFO_basictypeINTEGER:
12435 error = (ffeinfo_kindtype (info) != ffecom_label_kind ());
12436 break;
12437
12438 case FFEINFO_basictypeLOGICAL:
12439 error = !ffe_is_ugly_logint ()
12440 || (ffeinfo_kindtype (info) != ffecom_label_kind ());
12441 break;
12442
12443 default:
12444 error = TRUE;
12445 break;
12446 }
12447 if ((expr == NULL) || (ffeinfo_rank (info) != 0)
12448 || (ffebld_op (expr) != FFEBLD_opSYMTER))
12449 error = TRUE;
12450 break;
12451
12452 case FFEEXPR_contextCGOTO:
12453 case FFEEXPR_contextFORMAT:
12454 case FFEEXPR_contextDIMLIST:
12455 case FFEEXPR_contextFILENUM: /* See equiv code in _ambig_. */
12456 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12457 break;
12458 switch (ffeinfo_basictype (info))
12459 {
12460 case FFEINFO_basictypeLOGICAL:
12461 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12462 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12463 FFEEXPR_contextLET);
12464 /* Fall through. */
12465 case FFEINFO_basictypeREAL:
12466 case FFEINFO_basictypeCOMPLEX:
12467 if (ffe_is_pedantic ())
12468 {
12469 error = TRUE;
12470 break;
12471 }
12472 /* Fall through. */
12473 case FFEINFO_basictypeINTEGER:
12474 case FFEINFO_basictypeHOLLERITH:
12475 case FFEINFO_basictypeTYPELESS:
12476 error = FALSE;
12477 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12478 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12479 FFEEXPR_contextLET);
12480 break;
12481
12482 default:
12483 error = TRUE;
12484 break;
12485 }
12486 break;
12487
12488 case FFEEXPR_contextARITHIF:
12489 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12490 break;
12491 switch (ffeinfo_basictype (info))
12492 {
12493 case FFEINFO_basictypeLOGICAL:
12494 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12495 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12496 FFEEXPR_contextLET);
12497 if (ffe_is_pedantic ())
12498 {
12499 error = TRUE;
12500 break;
12501 }
12502 /* Fall through. */
12503 case FFEINFO_basictypeHOLLERITH:
12504 case FFEINFO_basictypeTYPELESS:
12505 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12506 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12507 FFEEXPR_contextLET);
12508 /* Fall through. */
12509 case FFEINFO_basictypeINTEGER:
12510 case FFEINFO_basictypeREAL:
12511 error = FALSE;
12512 break;
12513
12514 default:
12515 error = TRUE;
12516 break;
12517 }
12518 break;
12519
12520 case FFEEXPR_contextSTOP:
12521 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12522 break;
12523 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12524 : ffeinfo_basictype (info))
12525 {
12526 case FFEINFO_basictypeINTEGER:
12527 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12528 break;
12529
12530 case FFEINFO_basictypeCHARACTER:
12531 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT);
12532 break;
12533
12534 case FFEINFO_basictypeHOLLERITH:
12535 case FFEINFO_basictypeTYPELESS:
12536 error = FALSE;
12537 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12538 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12539 FFEEXPR_contextLET);
12540 break;
12541
12542 case FFEINFO_basictypeNONE:
12543 error = FALSE;
12544 break;
12545
12546 default:
12547 error = TRUE;
12548 break;
12549 }
12550 if ((expr != NULL) && ((ffebld_op (expr) != FFEBLD_opCONTER)
12551 || (ffebld_conter_orig (expr) != NULL)))
12552 error = TRUE;
12553 break;
12554
12555 case FFEEXPR_contextINCLUDE:
12556 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12557 || (ffeinfo_basictype (info) != FFEINFO_basictypeCHARACTER)
12558 || (ffebld_op (expr) != FFEBLD_opCONTER)
12559 || (ffebld_conter_orig (expr) != NULL);
12560 break;
12561
12562 case FFEEXPR_contextSELECTCASE:
12563 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12564 break;
12565 switch (ffeinfo_basictype (info))
12566 {
12567 case FFEINFO_basictypeINTEGER:
12568 case FFEINFO_basictypeCHARACTER:
12569 case FFEINFO_basictypeLOGICAL:
12570 error = FALSE;
12571 break;
12572
12573 case FFEINFO_basictypeHOLLERITH:
12574 case FFEINFO_basictypeTYPELESS:
12575 error = FALSE;
12576 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12577 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12578 FFEEXPR_contextLET);
12579 break;
12580
12581 default:
12582 error = TRUE;
12583 break;
12584 }
12585 break;
12586
12587 case FFEEXPR_contextCASE:
12588 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12589 break;
12590 switch ((expr == NULL) ? FFEINFO_basictypeINTEGER
12591 : ffeinfo_basictype (info))
12592 {
12593 case FFEINFO_basictypeINTEGER:
12594 case FFEINFO_basictypeCHARACTER:
12595 case FFEINFO_basictypeLOGICAL:
12596 error = FALSE;
12597 break;
12598
12599 case FFEINFO_basictypeHOLLERITH:
12600 case FFEINFO_basictypeTYPELESS:
12601 error = FALSE;
12602 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12603 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12604 FFEEXPR_contextLET);
12605 break;
12606
12607 default:
12608 error = TRUE;
12609 break;
12610 }
12611 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12612 error = TRUE;
12613 break;
12614
12615 case FFEEXPR_contextCHARACTERSIZE:
12616 case FFEEXPR_contextKINDTYPE:
12617 case FFEEXPR_contextDIMLISTCOMMON:
12618 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12619 break;
12620 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12621 : ffeinfo_basictype (info))
12622 {
12623 case FFEINFO_basictypeLOGICAL:
12624 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12625 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12626 FFEEXPR_contextLET);
12627 /* Fall through. */
12628 case FFEINFO_basictypeREAL:
12629 case FFEINFO_basictypeCOMPLEX:
12630 if (ffe_is_pedantic ())
12631 {
12632 error = TRUE;
12633 break;
12634 }
12635 /* Fall through. */
12636 case FFEINFO_basictypeINTEGER:
12637 case FFEINFO_basictypeHOLLERITH:
12638 case FFEINFO_basictypeTYPELESS:
12639 error = FALSE;
12640 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12641 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12642 FFEEXPR_contextLET);
12643 break;
12644
12645 default:
12646 error = TRUE;
12647 break;
12648 }
12649 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12650 error = TRUE;
12651 break;
12652
12653 case FFEEXPR_contextEQVINDEX_:
12654 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12655 break;
12656 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12657 : ffeinfo_basictype (info))
12658 {
12659 case FFEINFO_basictypeNONE:
12660 error = FALSE;
12661 break;
12662
12663 case FFEINFO_basictypeLOGICAL:
12664 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12665 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12666 FFEEXPR_contextLET);
12667 /* Fall through. */
12668 case FFEINFO_basictypeREAL:
12669 case FFEINFO_basictypeCOMPLEX:
12670 if (ffe_is_pedantic ())
12671 {
12672 error = TRUE;
12673 break;
12674 }
12675 /* Fall through. */
12676 case FFEINFO_basictypeINTEGER:
12677 case FFEINFO_basictypeHOLLERITH:
12678 case FFEINFO_basictypeTYPELESS:
12679 error = FALSE;
12680 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12681 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12682 FFEEXPR_contextLET);
12683 break;
12684
12685 default:
12686 error = TRUE;
12687 break;
12688 }
12689 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12690 error = TRUE;
12691 break;
12692
12693 case FFEEXPR_contextPARAMETER:
12694 if (ffeexpr_stack_->is_rhs)
12695 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12696 || (ffebld_op (expr) != FFEBLD_opCONTER);
12697 else
12698 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12699 || (ffebld_op (expr) != FFEBLD_opSYMTER);
12700 break;
12701
12702 case FFEEXPR_contextINDEXORACTUALARG_:
12703 if (ffelex_token_type (t) == FFELEX_typeCOLON)
12704 ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
12705 else
12706 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
12707 goto again; /* :::::::::::::::::::: */
12708
12709 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
12710 if (ffelex_token_type (t) == FFELEX_typeCOLON)
12711 ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
12712 else
12713 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
12714 goto again; /* :::::::::::::::::::: */
12715
12716 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
12717 if (ffelex_token_type (t) == FFELEX_typeCOLON)
12718 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
12719 else
12720 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
12721 goto again; /* :::::::::::::::::::: */
12722
12723 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
12724 if (ffelex_token_type (t) == FFELEX_typeCOLON)
12725 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
12726 else
12727 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
12728 goto again; /* :::::::::::::::::::: */
12729
12730 case FFEEXPR_contextIMPDOCTRL_:
12731 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12732 break;
12733 if (!ffeexpr_stack_->is_rhs
12734 && (ffebld_op (expr) != FFEBLD_opSYMTER))
12735 error = TRUE;
12736 switch (ffeinfo_basictype (info))
12737 {
12738 case FFEINFO_basictypeLOGICAL:
12739 if (! ffe_is_ugly_logint ())
12740 error = TRUE;
12741 if (! ffeexpr_stack_->is_rhs)
12742 break;
12743 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12744 ffeinfo_kindtype (info), 0,
12745 FFETARGET_charactersizeNONE,
12746 FFEEXPR_contextLET);
12747 break;
12748
12749 case FFEINFO_basictypeINTEGER:
12750 case FFEINFO_basictypeHOLLERITH:
12751 case FFEINFO_basictypeTYPELESS:
12752 break;
12753
12754 case FFEINFO_basictypeREAL:
12755 if (!ffeexpr_stack_->is_rhs
12756 && ffe_is_warn_surprising ()
12757 && !error)
12758 {
12759 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
12760 ffebad_here (0, ffelex_token_where_line (ft),
12761 ffelex_token_where_column (ft));
12762 ffebad_string (ffelex_token_text (ft));
12763 ffebad_finish ();
12764 }
12765 break;
12766
12767 default:
12768 error = TRUE;
12769 break;
12770 }
12771 break;
12772
12773 case FFEEXPR_contextDATAIMPDOCTRL_:
12774 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12775 break;
12776 if (ffeexpr_stack_->is_rhs)
12777 {
12778 if ((ffebld_op (expr) != FFEBLD_opCONTER)
12779 && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12780 error = TRUE;
12781 }
12782 else if ((ffebld_op (expr) != FFEBLD_opSYMTER)
12783 || (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12784 error = TRUE;
12785 switch (ffeinfo_basictype (info))
12786 {
12787 case FFEINFO_basictypeLOGICAL:
12788 if (! ffeexpr_stack_->is_rhs)
12789 break;
12790 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12791 ffeinfo_kindtype (info), 0,
12792 FFETARGET_charactersizeNONE,
12793 FFEEXPR_contextLET);
12794 /* Fall through. */
12795 case FFEINFO_basictypeINTEGER:
12796 if (ffeexpr_stack_->is_rhs
12797 && (ffeinfo_kindtype (ffebld_info (expr))
12798 != FFEINFO_kindtypeINTEGERDEFAULT))
12799 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12800 FFEINFO_kindtypeINTEGERDEFAULT, 0,
12801 FFETARGET_charactersizeNONE,
12802 FFEEXPR_contextLET);
12803 break;
12804
12805 case FFEINFO_basictypeHOLLERITH:
12806 case FFEINFO_basictypeTYPELESS:
12807 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12808 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12809 FFEEXPR_contextLET);
12810 break;
12811
12812 case FFEINFO_basictypeREAL:
12813 if (!ffeexpr_stack_->is_rhs
12814 && ffe_is_warn_surprising ()
12815 && !error)
12816 {
12817 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
12818 ffebad_here (0, ffelex_token_where_line (ft),
12819 ffelex_token_where_column (ft));
12820 ffebad_string (ffelex_token_text (ft));
12821 ffebad_finish ();
12822 }
12823 break;
12824
12825 default:
12826 error = TRUE;
12827 break;
12828 }
12829 break;
12830
12831 case FFEEXPR_contextIMPDOITEM_:
12832 if (ffelex_token_type (t) == FFELEX_typeEQUALS)
12833 {
12834 ffeexpr_stack_->is_rhs = FALSE;
12835 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
12836 goto again; /* :::::::::::::::::::: */
12837 }
12838 /* Fall through. */
12839 case FFEEXPR_contextIOLIST:
12840 case FFEEXPR_contextFILEVXTCODE:
12841 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12842 : ffeinfo_basictype (info))
12843 {
12844 case FFEINFO_basictypeHOLLERITH:
12845 case FFEINFO_basictypeTYPELESS:
12846 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12847 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12848 FFEEXPR_contextLET);
12849 break;
12850
12851 default:
12852 break;
12853 }
12854 error = (expr == NULL)
12855 || ((ffeinfo_rank (info) != 0)
12856 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12857 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12858 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12859 == FFEBLD_opSTAR))); /* Bad if null expr, or if
12860 array that is not a SYMTER
12861 (can't happen yet, I
12862 think) or has a NULL or
12863 STAR (assumed) array
12864 size. */
12865 break;
12866
12867 case FFEEXPR_contextIMPDOITEMDF_:
12868 if (ffelex_token_type (t) == FFELEX_typeEQUALS)
12869 {
12870 ffeexpr_stack_->is_rhs = FALSE;
12871 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
12872 goto again; /* :::::::::::::::::::: */
12873 }
12874 /* Fall through. */
12875 case FFEEXPR_contextIOLISTDF:
12876 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12877 : ffeinfo_basictype (info))
12878 {
12879 case FFEINFO_basictypeHOLLERITH:
12880 case FFEINFO_basictypeTYPELESS:
12881 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12882 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12883 FFEEXPR_contextLET);
12884 break;
12885
12886 default:
12887 break;
12888 }
12889 error
12890 = (expr == NULL)
12891 || ((ffeinfo_basictype (info) == FFEINFO_basictypeCHARACTER)
12892 && (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT))
12893 || ((ffeinfo_rank (info) != 0)
12894 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12895 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12896 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12897 == FFEBLD_opSTAR))); /* Bad if null expr,
12898 non-default-kindtype
12899 character expr, or if
12900 array that is not a SYMTER
12901 (can't happen yet, I
12902 think) or has a NULL or
12903 STAR (assumed) array
12904 size. */
12905 break;
12906
12907 case FFEEXPR_contextDATAIMPDOITEM_:
12908 error = (expr == NULL)
12909 || (ffebld_op (expr) != FFEBLD_opARRAYREF)
12910 || ((ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR)
12911 && (ffeinfo_where (info) != FFEINFO_whereFLEETING_IADDR));
12912 break;
12913
12914 case FFEEXPR_contextDATAIMPDOINDEX_:
12915 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12916 break;
12917 switch (ffeinfo_basictype (info))
12918 {
12919 case FFEINFO_basictypeLOGICAL:
12920 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12921 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12922 FFEEXPR_contextLET);
12923 /* Fall through. */
12924 case FFEINFO_basictypeREAL:
12925 case FFEINFO_basictypeCOMPLEX:
12926 if (ffe_is_pedantic ())
12927 {
12928 error = TRUE;
12929 break;
12930 }
12931 /* Fall through. */
12932 case FFEINFO_basictypeINTEGER:
12933 case FFEINFO_basictypeHOLLERITH:
12934 case FFEINFO_basictypeTYPELESS:
12935 error = FALSE;
12936 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12937 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12938 FFEEXPR_contextLET);
12939 break;
12940
12941 default:
12942 error = TRUE;
12943 break;
12944 }
12945 if ((ffeinfo_where (info) != FFEINFO_whereCONSTANT)
12946 && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12947 error = TRUE;
12948 break;
12949
12950 case FFEEXPR_contextDATA:
12951 if (expr == NULL)
12952 error = TRUE;
12953 else if (ffeexpr_stack_->is_rhs)
12954 error = (ffebld_op (expr) != FFEBLD_opCONTER);
12955 else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12956 error = FALSE;
12957 else
12958 error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12959 break;
12960
12961 case FFEEXPR_contextINITVAL:
12962 error = (expr == NULL) || (ffebld_op (expr) != FFEBLD_opCONTER);
12963 break;
12964
12965 case FFEEXPR_contextEQUIVALENCE:
12966 if (expr == NULL)
12967 error = TRUE;
12968 else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12969 error = FALSE;
12970 else
12971 error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12972 break;
12973
12974 case FFEEXPR_contextFILEASSOC:
12975 case FFEEXPR_contextFILEINT:
12976 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12977 : ffeinfo_basictype (info))
12978 {
12979 case FFEINFO_basictypeINTEGER:
12980 /* Maybe this should be supported someday, but, right now,
12981 g77 can't generate a call to libf2c to write to an
12982 integer other than the default size. */
12983 error = ((! ffeexpr_stack_->is_rhs)
12984 && ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12985 break;
12986
12987 default:
12988 error = TRUE;
12989 break;
12990 }
12991 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12992 error = TRUE;
12993 break;
12994
12995 case FFEEXPR_contextFILEDFINT:
12996 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12997 : ffeinfo_basictype (info))
12998 {
12999 case FFEINFO_basictypeINTEGER:
13000 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
13001 break;
13002
13003 default:
13004 error = TRUE;
13005 break;
13006 }
13007 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13008 error = TRUE;
13009 break;
13010
13011 case FFEEXPR_contextFILELOG:
13012 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13013 : ffeinfo_basictype (info))
13014 {
13015 case FFEINFO_basictypeLOGICAL:
13016 error = FALSE;
13017 break;
13018
13019 default:
13020 error = TRUE;
13021 break;
13022 }
13023 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13024 error = TRUE;
13025 break;
13026
13027 case FFEEXPR_contextFILECHAR:
13028 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13029 : ffeinfo_basictype (info))
13030 {
13031 case FFEINFO_basictypeCHARACTER:
13032 error = FALSE;
13033 break;
13034
13035 default:
13036 error = TRUE;
13037 break;
13038 }
13039 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13040 error = TRUE;
13041 break;
13042
13043 case FFEEXPR_contextFILENUMCHAR:
13044 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
13045 break;
13046 switch (ffeinfo_basictype (info))
13047 {
13048 case FFEINFO_basictypeLOGICAL:
13049 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13050 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13051 FFEEXPR_contextLET);
13052 /* Fall through. */
13053 case FFEINFO_basictypeREAL:
13054 case FFEINFO_basictypeCOMPLEX:
13055 if (ffe_is_pedantic ())
13056 {
13057 error = TRUE;
13058 break;
13059 }
13060 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13061 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13062 FFEEXPR_contextLET);
13063 break;
13064
13065 case FFEINFO_basictypeINTEGER:
13066 case FFEINFO_basictypeCHARACTER:
13067 error = FALSE;
13068 break;
13069
13070 default:
13071 error = TRUE;
13072 break;
13073 }
13074 break;
13075
13076 case FFEEXPR_contextFILEDFCHAR:
13077 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
13078 break;
13079 switch (ffeinfo_basictype (info))
13080 {
13081 case FFEINFO_basictypeCHARACTER:
13082 error
13083 = (ffeinfo_kindtype (info)
13084 != FFEINFO_kindtypeCHARACTERDEFAULT);
13085 break;
13086
13087 default:
13088 error = TRUE;
13089 break;
13090 }
13091 if (!ffeexpr_stack_->is_rhs
13092 && (ffebld_op (expr) == FFEBLD_opSUBSTR))
13093 error = TRUE;
13094 break;
13095
13096 case FFEEXPR_contextFILEUNIT: /* See equiv code in _ambig_. */
13097 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13098 : ffeinfo_basictype (info))
13099 {
13100 case FFEINFO_basictypeLOGICAL:
13101 if ((error = (ffeinfo_rank (info) != 0)))
13102 break;
13103 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13104 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13105 FFEEXPR_contextLET);
13106 /* Fall through. */
13107 case FFEINFO_basictypeREAL:
13108 case FFEINFO_basictypeCOMPLEX:
13109 if ((error = (ffeinfo_rank (info) != 0)))
13110 break;
13111 if (ffe_is_pedantic ())
13112 {
13113 error = TRUE;
13114 break;
13115 }
13116 /* Fall through. */
13117 case FFEINFO_basictypeINTEGER:
13118 case FFEINFO_basictypeHOLLERITH:
13119 case FFEINFO_basictypeTYPELESS:
13120 if ((error = (ffeinfo_rank (info) != 0)))
13121 break;
13122 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13123 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13124 FFEEXPR_contextLET);
13125 break;
13126
13127 case FFEINFO_basictypeCHARACTER:
13128 switch (ffebld_op (expr))
13129 { /* As if _lhs had been called instead of
13130 _rhs. */
13131 case FFEBLD_opSYMTER:
13132 error
13133 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
13134 break;
13135
13136 case FFEBLD_opSUBSTR:
13137 error = (ffeinfo_where (ffebld_info (expr))
13138 == FFEINFO_whereCONSTANT_SUBOBJECT);
13139 break;
13140
13141 case FFEBLD_opARRAYREF:
13142 error = FALSE;
13143 break;
13144
13145 default:
13146 error = TRUE;
13147 break;
13148 }
13149 if (!error
13150 && ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
13151 || ((ffeinfo_rank (info) != 0)
13152 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
13153 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
13154 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
13155 == FFEBLD_opSTAR))))) /* Bad if
13156 non-default-kindtype
13157 character expr, or if
13158 array that is not a SYMTER
13159 (can't happen yet, I
13160 think), or has a NULL or
13161 STAR (assumed) array
13162 size. */
13163 error = TRUE;
13164 break;
13165
13166 default:
13167 error = TRUE;
13168 break;
13169 }
13170 break;
13171
13172 case FFEEXPR_contextFILEFORMAT:
13173 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13174 : ffeinfo_basictype (info))
13175 {
13176 case FFEINFO_basictypeINTEGER:
13177 error = (expr == NULL)
13178 || ((ffeinfo_rank (info) != 0) ?
13179 ffe_is_pedantic () /* F77 C5. */
13180 : (bool) (ffeinfo_kindtype (info) != ffecom_label_kind ()))
13181 || (ffebld_op (expr) != FFEBLD_opSYMTER);
13182 break;
13183
13184 case FFEINFO_basictypeLOGICAL:
13185 case FFEINFO_basictypeREAL:
13186 case FFEINFO_basictypeCOMPLEX:
13187 /* F77 C5 -- must be an array of hollerith. */
13188 error
13189 = ffe_is_pedantic ()
13190 || (ffeinfo_rank (info) == 0);
13191 break;
13192
13193 case FFEINFO_basictypeCHARACTER:
13194 if ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
13195 || ((ffeinfo_rank (info) != 0)
13196 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
13197 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
13198 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
13199 == FFEBLD_opSTAR)))) /* Bad if
13200 non-default-kindtype
13201 character expr, or if
13202 array that is not a SYMTER
13203 (can't happen yet, I
13204 think), or has a NULL or
13205 STAR (assumed) array
13206 size. */
13207 error = TRUE;
13208 else
13209 error = FALSE;
13210 break;
13211
13212 default:
13213 error = TRUE;
13214 break;
13215 }
13216 break;
13217
13218 case FFEEXPR_contextLOC_:
13219 /* See also ffeintrin_check_loc_. */
13220 if ((expr == NULL)
13221 || (ffeinfo_kind (info) != FFEINFO_kindENTITY)
13222 || ((ffebld_op (expr) != FFEBLD_opSYMTER)
13223 && (ffebld_op (expr) != FFEBLD_opSUBSTR)
13224 && (ffebld_op (expr) != FFEBLD_opARRAYREF)))
13225 error = TRUE;
13226 break;
13227
13228 default:
13229 error = FALSE;
13230 break;
13231 }
13232
13233 if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
13234 {
13235 ffebad_start (FFEBAD_EXPR_WRONG);
13236 ffebad_here (0, ffelex_token_where_line (ft),
13237 ffelex_token_where_column (ft));
13238 ffebad_finish ();
13239 expr = ffebld_new_any ();
13240 ffebld_set_info (expr, ffeinfo_new_any ());
13241 }
13242
13243 callback = ffeexpr_stack_->callback;
13244 s = ffeexpr_stack_->previous;
13245 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
13246 sizeof (*ffeexpr_stack_));
13247 ffeexpr_stack_ = s;
13248 next = (ffelexHandler) (*callback) (ft, expr, t);
13249 ffelex_token_kill (ft);
13250 return (ffelexHandler) next;
13251 }
13252
13253 /* ffeexpr_finished_ambig_ -- Check validity of ambiguous unit/form spec
13254
13255 ffebld expr;
13256 expr = ffeexpr_finished_ambig_(expr);
13257
13258 Replicates a bit of ffeexpr_finished_'s task when in a context
13259 of UNIT or FORMAT. */
13260
13261 static ffebld
13262 ffeexpr_finished_ambig_ (ffelexToken ft, ffebld expr)
13263 {
13264 ffeinfo info = ffebld_info (expr);
13265 bool error;
13266
13267 switch (ffeexpr_stack_->context)
13268 {
13269 case FFEEXPR_contextFILENUMAMBIG: /* Same as FILENUM in _finished_. */
13270 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13271 : ffeinfo_basictype (info))
13272 {
13273 case FFEINFO_basictypeLOGICAL:
13274 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13275 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13276 FFEEXPR_contextLET);
13277 /* Fall through. */
13278 case FFEINFO_basictypeREAL:
13279 case FFEINFO_basictypeCOMPLEX:
13280 if (ffe_is_pedantic ())
13281 {
13282 error = TRUE;
13283 break;
13284 }
13285 /* Fall through. */
13286 case FFEINFO_basictypeINTEGER:
13287 case FFEINFO_basictypeHOLLERITH:
13288 case FFEINFO_basictypeTYPELESS:
13289 error = FALSE;
13290 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13291 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13292 FFEEXPR_contextLET);
13293 break;
13294
13295 default:
13296 error = TRUE;
13297 break;
13298 }
13299 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13300 error = TRUE;
13301 break;
13302
13303 case FFEEXPR_contextFILEUNITAMBIG: /* Same as FILEUNIT in _finished_. */
13304 if ((expr != NULL) && (ffebld_op (expr) == FFEBLD_opSTAR))
13305 {
13306 error = FALSE;
13307 break;
13308 }
13309 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13310 : ffeinfo_basictype (info))
13311 {
13312 case FFEINFO_basictypeLOGICAL:
13313 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13314 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13315 FFEEXPR_contextLET);
13316 /* Fall through. */
13317 case FFEINFO_basictypeREAL:
13318 case FFEINFO_basictypeCOMPLEX:
13319 if (ffe_is_pedantic ())
13320 {
13321 error = TRUE;
13322 break;
13323 }
13324 /* Fall through. */
13325 case FFEINFO_basictypeINTEGER:
13326 case FFEINFO_basictypeHOLLERITH:
13327 case FFEINFO_basictypeTYPELESS:
13328 error = (ffeinfo_rank (info) != 0);
13329 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13330 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13331 FFEEXPR_contextLET);
13332 break;
13333
13334 case FFEINFO_basictypeCHARACTER:
13335 switch (ffebld_op (expr))
13336 { /* As if _lhs had been called instead of
13337 _rhs. */
13338 case FFEBLD_opSYMTER:
13339 error
13340 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
13341 break;
13342
13343 case FFEBLD_opSUBSTR:
13344 error = (ffeinfo_where (ffebld_info (expr))
13345 == FFEINFO_whereCONSTANT_SUBOBJECT);
13346 break;
13347
13348 case FFEBLD_opARRAYREF:
13349 error = FALSE;
13350 break;
13351
13352 default:
13353 error = TRUE;
13354 break;
13355 }
13356 break;
13357
13358 default:
13359 error = TRUE;
13360 break;
13361 }
13362 break;
13363
13364 default:
13365 assert ("bad context" == NULL);
13366 error = TRUE;
13367 break;
13368 }
13369
13370 if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
13371 {
13372 ffebad_start (FFEBAD_EXPR_WRONG);
13373 ffebad_here (0, ffelex_token_where_line (ft),
13374 ffelex_token_where_column (ft));
13375 ffebad_finish ();
13376 expr = ffebld_new_any ();
13377 ffebld_set_info (expr, ffeinfo_new_any ());
13378 }
13379
13380 return expr;
13381 }
13382
13383 /* ffeexpr_token_lhs_ -- Initial state for lhs expression
13384
13385 Return a pointer to this function to the lexer (ffelex), which will
13386 invoke it for the next token.
13387
13388 Basically a smaller version of _rhs_; keep them both in sync, of course. */
13389
13390 static ffelexHandler
13391 ffeexpr_token_lhs_ (ffelexToken t)
13392 {
13393
13394 /* When changing the list of valid initial lhs tokens, check whether to
13395 update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
13396 READ (expr) <token> case -- it assumes it knows which tokens <token> can
13397 be to indicate an lhs (or implied DO), which right now is the set
13398 {NAME,OPEN_PAREN}.
13399
13400 This comment also appears in ffeexpr_token_first_lhs_. */
13401
13402 switch (ffelex_token_type (t))
13403 {
13404 case FFELEX_typeNAME:
13405 case FFELEX_typeNAMES:
13406 ffeexpr_tokens_[0] = ffelex_token_use (t);
13407 return (ffelexHandler) ffeexpr_token_name_lhs_;
13408
13409 default:
13410 return (ffelexHandler) ffeexpr_finished_ (t);
13411 }
13412 }
13413
13414 /* ffeexpr_token_rhs_ -- Initial state for rhs expression
13415
13416 Return a pointer to this function to the lexer (ffelex), which will
13417 invoke it for the next token.
13418
13419 The initial state and the post-binary-operator state are the same and
13420 both handled here, with the expression stack used to distinguish
13421 between them. Binary operators are invalid here; unary operators,
13422 constants, subexpressions, and name references are valid. */
13423
13424 static ffelexHandler
13425 ffeexpr_token_rhs_ (ffelexToken t)
13426 {
13427 ffeexprExpr_ e;
13428
13429 switch (ffelex_token_type (t))
13430 {
13431 case FFELEX_typeQUOTE:
13432 if (ffe_is_vxt ())
13433 {
13434 ffeexpr_tokens_[0] = ffelex_token_use (t);
13435 return (ffelexHandler) ffeexpr_token_quote_;
13436 }
13437 ffeexpr_tokens_[0] = ffelex_token_use (t);
13438 ffelex_set_expecting_hollerith (-1, '\"',
13439 ffelex_token_where_line (t),
13440 ffelex_token_where_column (t));
13441 /* Don't have to unset this one. */
13442 return (ffelexHandler) ffeexpr_token_apostrophe_;
13443
13444 case FFELEX_typeAPOSTROPHE:
13445 ffeexpr_tokens_[0] = ffelex_token_use (t);
13446 ffelex_set_expecting_hollerith (-1, '\'',
13447 ffelex_token_where_line (t),
13448 ffelex_token_where_column (t));
13449 /* Don't have to unset this one. */
13450 return (ffelexHandler) ffeexpr_token_apostrophe_;
13451
13452 case FFELEX_typePERCENT:
13453 ffeexpr_tokens_[0] = ffelex_token_use (t);
13454 return (ffelexHandler) ffeexpr_token_percent_;
13455
13456 case FFELEX_typeOPEN_PAREN:
13457 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
13458 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
13459 FFEEXPR_contextPAREN_,
13460 ffeexpr_cb_close_paren_c_);
13461
13462 case FFELEX_typePLUS:
13463 e = ffeexpr_expr_new_ ();
13464 e->type = FFEEXPR_exprtypeUNARY_;
13465 e->token = ffelex_token_use (t);
13466 e->u.operator.op = FFEEXPR_operatorADD_;
13467 e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
13468 e->u.operator.as = FFEEXPR_operatorassociativityADD_;
13469 ffeexpr_exprstack_push_unary_ (e);
13470 return (ffelexHandler) ffeexpr_token_rhs_;
13471
13472 case FFELEX_typeMINUS:
13473 e = ffeexpr_expr_new_ ();
13474 e->type = FFEEXPR_exprtypeUNARY_;
13475 e->token = ffelex_token_use (t);
13476 e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
13477 e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
13478 e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
13479 ffeexpr_exprstack_push_unary_ (e);
13480 return (ffelexHandler) ffeexpr_token_rhs_;
13481
13482 case FFELEX_typePERIOD:
13483 ffeexpr_tokens_[0] = ffelex_token_use (t);
13484 return (ffelexHandler) ffeexpr_token_period_;
13485
13486 case FFELEX_typeNUMBER:
13487 ffeexpr_tokens_[0] = ffelex_token_use (t);
13488 ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
13489 if (ffeexpr_hollerith_count_ > 0)
13490 ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
13491 '\0',
13492 ffelex_token_where_line (t),
13493 ffelex_token_where_column (t));
13494 return (ffelexHandler) ffeexpr_token_number_;
13495
13496 case FFELEX_typeNAME:
13497 case FFELEX_typeNAMES:
13498 ffeexpr_tokens_[0] = ffelex_token_use (t);
13499 switch (ffeexpr_stack_->context)
13500 {
13501 case FFEEXPR_contextACTUALARG_:
13502 case FFEEXPR_contextINDEXORACTUALARG_:
13503 case FFEEXPR_contextSFUNCDEFACTUALARG_:
13504 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
13505 return (ffelexHandler) ffeexpr_token_name_arg_;
13506
13507 default:
13508 return (ffelexHandler) ffeexpr_token_name_rhs_;
13509 }
13510
13511 case FFELEX_typeASTERISK:
13512 case FFELEX_typeSLASH:
13513 case FFELEX_typePOWER:
13514 case FFELEX_typeCONCAT:
13515 case FFELEX_typeREL_EQ:
13516 case FFELEX_typeREL_NE:
13517 case FFELEX_typeREL_LE:
13518 case FFELEX_typeREL_GE:
13519 if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
13520 {
13521 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13522 ffebad_finish ();
13523 }
13524 return (ffelexHandler) ffeexpr_token_rhs_;
13525
13526 #if 0
13527 case FFELEX_typeEQUALS:
13528 case FFELEX_typePOINTS:
13529 case FFELEX_typeCLOSE_ANGLE:
13530 case FFELEX_typeCLOSE_PAREN:
13531 case FFELEX_typeCOMMA:
13532 case FFELEX_typeCOLON:
13533 case FFELEX_typeEOS:
13534 case FFELEX_typeSEMICOLON:
13535 #endif
13536 default:
13537 return (ffelexHandler) ffeexpr_finished_ (t);
13538 }
13539 }
13540
13541 /* ffeexpr_token_period_ -- Rhs PERIOD
13542
13543 Return a pointer to this function to the lexer (ffelex), which will
13544 invoke it for the next token.
13545
13546 Handle a period detected at rhs (expecting unary op or operand) state.
13547 Must begin a floating-point value (as in .12) or a dot-dot name, of
13548 which only .NOT., .TRUE., and .FALSE. are truly valid. Other sort-of-
13549 valid names represent binary operators, which are invalid here because
13550 there isn't an operand at the top of the stack. */
13551
13552 static ffelexHandler
13553 ffeexpr_token_period_ (ffelexToken t)
13554 {
13555 switch (ffelex_token_type (t))
13556 {
13557 case FFELEX_typeNAME:
13558 case FFELEX_typeNAMES:
13559 ffeexpr_current_dotdot_ = ffestr_other (t);
13560 switch (ffeexpr_current_dotdot_)
13561 {
13562 case FFESTR_otherNone:
13563 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
13564 {
13565 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13566 ffelex_token_where_column (ffeexpr_tokens_[0]));
13567 ffebad_finish ();
13568 }
13569 ffelex_token_kill (ffeexpr_tokens_[0]);
13570 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13571
13572 case FFESTR_otherTRUE:
13573 case FFESTR_otherFALSE:
13574 case FFESTR_otherNOT:
13575 ffeexpr_tokens_[1] = ffelex_token_use (t);
13576 return (ffelexHandler) ffeexpr_token_end_period_;
13577
13578 default:
13579 if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
13580 {
13581 ffebad_here (0, ffelex_token_where_line (t),
13582 ffelex_token_where_column (t));
13583 ffebad_finish ();
13584 }
13585 ffelex_token_kill (ffeexpr_tokens_[0]);
13586 return (ffelexHandler) ffeexpr_token_swallow_period_;
13587 }
13588 break; /* Nothing really reaches here. */
13589
13590 case FFELEX_typeNUMBER:
13591 ffeexpr_tokens_[1] = ffelex_token_use (t);
13592 return (ffelexHandler) ffeexpr_token_real_;
13593
13594 default:
13595 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
13596 {
13597 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13598 ffelex_token_where_column (ffeexpr_tokens_[0]));
13599 ffebad_finish ();
13600 }
13601 ffelex_token_kill (ffeexpr_tokens_[0]);
13602 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13603 }
13604 }
13605
13606 /* ffeexpr_token_end_period_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
13607
13608 Return a pointer to this function to the lexer (ffelex), which will
13609 invoke it for the next token.
13610
13611 Expecting a period to close a .NOT, .TRUE, or .FALSE at rhs (unary op
13612 or operator) state. If period isn't found, issue a diagnostic but
13613 pretend we saw one. ffeexpr_current_dotdot_ must already contained the
13614 dotdot representation of the name in between the two PERIOD tokens. */
13615
13616 static ffelexHandler
13617 ffeexpr_token_end_period_ (ffelexToken t)
13618 {
13619 ffeexprExpr_ e;
13620
13621 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13622 {
13623 if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
13624 {
13625 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13626 ffelex_token_where_column (ffeexpr_tokens_[0]));
13627 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13628 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
13629 ffebad_finish ();
13630 }
13631 }
13632
13633 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill "NOT"/"TRUE"/"FALSE"
13634 token. */
13635
13636 e = ffeexpr_expr_new_ ();
13637 e->token = ffeexpr_tokens_[0];
13638
13639 switch (ffeexpr_current_dotdot_)
13640 {
13641 case FFESTR_otherNOT:
13642 e->type = FFEEXPR_exprtypeUNARY_;
13643 e->u.operator.op = FFEEXPR_operatorNOT_;
13644 e->u.operator.prec = FFEEXPR_operatorprecedenceNOT_;
13645 e->u.operator.as = FFEEXPR_operatorassociativityNOT_;
13646 ffeexpr_exprstack_push_unary_ (e);
13647 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13648 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13649 return (ffelexHandler) ffeexpr_token_rhs_;
13650
13651 case FFESTR_otherTRUE:
13652 e->type = FFEEXPR_exprtypeOPERAND_;
13653 e->u.operand
13654 = ffebld_new_conter (ffebld_constant_new_logicaldefault (TRUE));
13655 ffebld_set_info (e->u.operand,
13656 ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
13657 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13658 ffeexpr_exprstack_push_operand_ (e);
13659 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13660 return (ffelexHandler) ffeexpr_token_binary_ (t);
13661 return (ffelexHandler) ffeexpr_token_binary_;
13662
13663 case FFESTR_otherFALSE:
13664 e->type = FFEEXPR_exprtypeOPERAND_;
13665 e->u.operand
13666 = ffebld_new_conter (ffebld_constant_new_logicaldefault (FALSE));
13667 ffebld_set_info (e->u.operand,
13668 ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
13669 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13670 ffeexpr_exprstack_push_operand_ (e);
13671 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13672 return (ffelexHandler) ffeexpr_token_binary_ (t);
13673 return (ffelexHandler) ffeexpr_token_binary_;
13674
13675 default:
13676 assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL);
13677 exit (0);
13678 return NULL;
13679 }
13680 }
13681
13682 /* ffeexpr_token_swallow_period_ -- Rhs PERIOD NAME(not NOT, TRUE, or FALSE)
13683
13684 Return a pointer to this function to the lexer (ffelex), which will
13685 invoke it for the next token.
13686
13687 A diagnostic has already been issued; just swallow a period if there is
13688 one, then continue with ffeexpr_token_rhs_. */
13689
13690 static ffelexHandler
13691 ffeexpr_token_swallow_period_ (ffelexToken t)
13692 {
13693 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13694 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13695
13696 return (ffelexHandler) ffeexpr_token_rhs_;
13697 }
13698
13699 /* ffeexpr_token_real_ -- Rhs PERIOD NUMBER
13700
13701 Return a pointer to this function to the lexer (ffelex), which will
13702 invoke it for the next token.
13703
13704 After a period and a string of digits, check next token for possible
13705 exponent designation (D, E, or Q as first/only character) and continue
13706 real-number handling accordingly. Else form basic real constant, push
13707 onto expression stack, and enter binary state using current token (which,
13708 if it is a name not beginning with D, E, or Q, will certainly result
13709 in an error, but that's not for this routine to deal with). */
13710
13711 static ffelexHandler
13712 ffeexpr_token_real_ (ffelexToken t)
13713 {
13714 char d;
13715 const char *p;
13716
13717 if (((ffelex_token_type (t) != FFELEX_typeNAME)
13718 && (ffelex_token_type (t) != FFELEX_typeNAMES))
13719 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13720 'D', 'd')
13721 || ffesrc_char_match_init (d, 'E', 'e')
13722 || ffesrc_char_match_init (d, 'Q', 'q')))
13723 && ffeexpr_isdigits_ (++p)))
13724 {
13725 #if 0
13726 /* This code has been removed because it seems inconsistent to
13727 produce a diagnostic in this case, but not all of the other
13728 ones that look for an exponent and cannot recognize one. */
13729 if (((ffelex_token_type (t) == FFELEX_typeNAME)
13730 || (ffelex_token_type (t) == FFELEX_typeNAMES))
13731 && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
13732 {
13733 char bad[2];
13734
13735 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13736 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
13737 ffelex_token_where_column (ffeexpr_tokens_[0]));
13738 bad[0] = *(p - 1);
13739 bad[1] = '\0';
13740 ffebad_string (bad);
13741 ffebad_finish ();
13742 }
13743 #endif
13744 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13745 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13746 NULL, NULL, NULL);
13747
13748 ffelex_token_kill (ffeexpr_tokens_[0]);
13749 ffelex_token_kill (ffeexpr_tokens_[1]);
13750 return (ffelexHandler) ffeexpr_token_binary_ (t);
13751 }
13752
13753 /* Just exponent character by itself? In which case, PLUS or MINUS must
13754 surely be next, followed by a NUMBER token. */
13755
13756 if (*p == '\0')
13757 {
13758 ffeexpr_tokens_[2] = ffelex_token_use (t);
13759 return (ffelexHandler) ffeexpr_token_real_exponent_;
13760 }
13761
13762 ffeexpr_make_float_const_ (d, NULL, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13763 t, NULL, NULL);
13764
13765 ffelex_token_kill (ffeexpr_tokens_[0]);
13766 ffelex_token_kill (ffeexpr_tokens_[1]);
13767 return (ffelexHandler) ffeexpr_token_binary_;
13768 }
13769
13770 /* ffeexpr_token_real_exponent_ -- Rhs PERIOD NUMBER NAME(D, E, or Q)
13771
13772 Return a pointer to this function to the lexer (ffelex), which will
13773 invoke it for the next token.
13774
13775 Ensures this token is PLUS or MINUS, preserves it, goes to final state
13776 for real number (exponent digits). Else issues diagnostic, assumes a
13777 zero exponent field for number, passes token on to binary state as if
13778 previous token had been "E0" instead of "E", for example. */
13779
13780 static ffelexHandler
13781 ffeexpr_token_real_exponent_ (ffelexToken t)
13782 {
13783 if ((ffelex_token_type (t) != FFELEX_typePLUS)
13784 && (ffelex_token_type (t) != FFELEX_typeMINUS))
13785 {
13786 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13787 {
13788 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
13789 ffelex_token_where_column (ffeexpr_tokens_[2]));
13790 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13791 ffebad_finish ();
13792 }
13793
13794 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13795 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13796 NULL, NULL, NULL);
13797
13798 ffelex_token_kill (ffeexpr_tokens_[0]);
13799 ffelex_token_kill (ffeexpr_tokens_[1]);
13800 ffelex_token_kill (ffeexpr_tokens_[2]);
13801 return (ffelexHandler) ffeexpr_token_binary_ (t);
13802 }
13803
13804 ffeexpr_tokens_[3] = ffelex_token_use (t);
13805 return (ffelexHandler) ffeexpr_token_real_exp_sign_;
13806 }
13807
13808 /* ffeexpr_token_real_exp_sign_ -- Rhs PERIOD NUMBER NAME(D,E,Q) PLUS/MINUS
13809
13810 Return a pointer to this function to the lexer (ffelex), which will
13811 invoke it for the next token.
13812
13813 Make sure token is a NUMBER, make a real constant out of all we have and
13814 push it onto the expression stack. Else issue diagnostic and pretend
13815 exponent field was a zero. */
13816
13817 static ffelexHandler
13818 ffeexpr_token_real_exp_sign_ (ffelexToken t)
13819 {
13820 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13821 {
13822 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13823 {
13824 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
13825 ffelex_token_where_column (ffeexpr_tokens_[2]));
13826 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13827 ffebad_finish ();
13828 }
13829
13830 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13831 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13832 NULL, NULL, NULL);
13833
13834 ffelex_token_kill (ffeexpr_tokens_[0]);
13835 ffelex_token_kill (ffeexpr_tokens_[1]);
13836 ffelex_token_kill (ffeexpr_tokens_[2]);
13837 ffelex_token_kill (ffeexpr_tokens_[3]);
13838 return (ffelexHandler) ffeexpr_token_binary_ (t);
13839 }
13840
13841 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0], NULL,
13842 ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2],
13843 ffeexpr_tokens_[3], t);
13844
13845 ffelex_token_kill (ffeexpr_tokens_[0]);
13846 ffelex_token_kill (ffeexpr_tokens_[1]);
13847 ffelex_token_kill (ffeexpr_tokens_[2]);
13848 ffelex_token_kill (ffeexpr_tokens_[3]);
13849 return (ffelexHandler) ffeexpr_token_binary_;
13850 }
13851
13852 /* ffeexpr_token_number_ -- Rhs NUMBER
13853
13854 Return a pointer to this function to the lexer (ffelex), which will
13855 invoke it for the next token.
13856
13857 If the token is a period, we may have a floating-point number, or an
13858 integer followed by a dotdot binary operator. If the token is a name
13859 beginning with D, E, or Q, we definitely have a floating-point number.
13860 If the token is a hollerith constant, that's what we've got, so push
13861 it onto the expression stack and continue with the binary state.
13862
13863 Otherwise, we have an integer followed by something the binary state
13864 should be able to swallow. */
13865
13866 static ffelexHandler
13867 ffeexpr_token_number_ (ffelexToken t)
13868 {
13869 ffeexprExpr_ e;
13870 ffeinfo ni;
13871 char d;
13872 const char *p;
13873
13874 if (ffeexpr_hollerith_count_ > 0)
13875 ffelex_set_expecting_hollerith (0, '\0',
13876 ffewhere_line_unknown (),
13877 ffewhere_column_unknown ());
13878
13879 /* See if we've got a floating-point number here. */
13880
13881 switch (ffelex_token_type (t))
13882 {
13883 case FFELEX_typeNAME:
13884 case FFELEX_typeNAMES:
13885 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13886 'D', 'd')
13887 || ffesrc_char_match_init (d, 'E', 'e')
13888 || ffesrc_char_match_init (d, 'Q', 'q'))
13889 && ffeexpr_isdigits_ (++p))
13890 {
13891
13892 /* Just exponent character by itself? In which case, PLUS or MINUS
13893 must surely be next, followed by a NUMBER token. */
13894
13895 if (*p == '\0')
13896 {
13897 ffeexpr_tokens_[1] = ffelex_token_use (t);
13898 return (ffelexHandler) ffeexpr_token_number_exponent_;
13899 }
13900 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], NULL, NULL, t,
13901 NULL, NULL);
13902
13903 ffelex_token_kill (ffeexpr_tokens_[0]);
13904 return (ffelexHandler) ffeexpr_token_binary_;
13905 }
13906 break;
13907
13908 case FFELEX_typePERIOD:
13909 ffeexpr_tokens_[1] = ffelex_token_use (t);
13910 return (ffelexHandler) ffeexpr_token_number_period_;
13911
13912 case FFELEX_typeHOLLERITH:
13913 e = ffeexpr_expr_new_ ();
13914 e->type = FFEEXPR_exprtypeOPERAND_;
13915 e->token = ffeexpr_tokens_[0];
13916 e->u.operand = ffebld_new_conter (ffebld_constant_new_hollerith (t));
13917 ni = ffeinfo_new (FFEINFO_basictypeHOLLERITH, FFEINFO_kindtypeNONE,
13918 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
13919 ffelex_token_length (t));
13920 ffebld_set_info (e->u.operand, ni);
13921 ffeexpr_exprstack_push_operand_ (e);
13922 return (ffelexHandler) ffeexpr_token_binary_;
13923
13924 default:
13925 break;
13926 }
13927
13928 /* Nothing specific we were looking for, so make an integer and pass the
13929 current token to the binary state. */
13930
13931 ffeexpr_make_float_const_ ('I', ffeexpr_tokens_[0], NULL, NULL,
13932 NULL, NULL, NULL);
13933 return (ffelexHandler) ffeexpr_token_binary_ (t);
13934 }
13935
13936 /* ffeexpr_token_number_exponent_ -- Rhs NUMBER NAME(D, E, or Q)
13937
13938 Return a pointer to this function to the lexer (ffelex), which will
13939 invoke it for the next token.
13940
13941 Ensures this token is PLUS or MINUS, preserves it, goes to final state
13942 for real number (exponent digits). Else treats number as integer, passes
13943 name to binary, passes current token to subsequent handler. */
13944
13945 static ffelexHandler
13946 ffeexpr_token_number_exponent_ (ffelexToken t)
13947 {
13948 if ((ffelex_token_type (t) != FFELEX_typePLUS)
13949 && (ffelex_token_type (t) != FFELEX_typeMINUS))
13950 {
13951 ffeexprExpr_ e;
13952 ffelexHandler nexthandler;
13953
13954 e = ffeexpr_expr_new_ ();
13955 e->type = FFEEXPR_exprtypeOPERAND_;
13956 e->token = ffeexpr_tokens_[0];
13957 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
13958 (ffeexpr_tokens_[0]));
13959 ffebld_set_info (e->u.operand,
13960 ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT,
13961 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13962 ffeexpr_exprstack_push_operand_ (e);
13963 nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[1]);
13964 ffelex_token_kill (ffeexpr_tokens_[1]);
13965 return (ffelexHandler) (*nexthandler) (t);
13966 }
13967
13968 ffeexpr_tokens_[2] = ffelex_token_use (t);
13969 return (ffelexHandler) ffeexpr_token_number_exp_sign_;
13970 }
13971
13972 /* ffeexpr_token_number_exp_sign_ -- Rhs NUMBER NAME(D,E,Q) PLUS/MINUS
13973
13974 Return a pointer to this function to the lexer (ffelex), which will
13975 invoke it for the next token.
13976
13977 Make sure token is a NUMBER, make a real constant out of all we have and
13978 push it onto the expression stack. Else issue diagnostic and pretend
13979 exponent field was a zero. */
13980
13981 static ffelexHandler
13982 ffeexpr_token_number_exp_sign_ (ffelexToken t)
13983 {
13984 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13985 {
13986 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13987 {
13988 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[1]),
13989 ffelex_token_where_column (ffeexpr_tokens_[1]));
13990 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13991 ffebad_finish ();
13992 }
13993
13994 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
13995 ffeexpr_tokens_[0], NULL, NULL,
13996 ffeexpr_tokens_[1], ffeexpr_tokens_[2],
13997 NULL);
13998
13999 ffelex_token_kill (ffeexpr_tokens_[0]);
14000 ffelex_token_kill (ffeexpr_tokens_[1]);
14001 ffelex_token_kill (ffeexpr_tokens_[2]);
14002 return (ffelexHandler) ffeexpr_token_binary_ (t);
14003 }
14004
14005 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
14006 ffeexpr_tokens_[0], NULL, NULL,
14007 ffeexpr_tokens_[1], ffeexpr_tokens_[2], t);
14008
14009 ffelex_token_kill (ffeexpr_tokens_[0]);
14010 ffelex_token_kill (ffeexpr_tokens_[1]);
14011 ffelex_token_kill (ffeexpr_tokens_[2]);
14012 return (ffelexHandler) ffeexpr_token_binary_;
14013 }
14014
14015 /* ffeexpr_token_number_period_ -- Rhs NUMBER PERIOD
14016
14017 Return a pointer to this function to the lexer (ffelex), which will
14018 invoke it for the next token.
14019
14020 Handle a period detected following a number at rhs state. Must begin a
14021 floating-point value (as in 1., 1.2, 1.E3, or 1.E+3) or a dot-dot name. */
14022
14023 static ffelexHandler
14024 ffeexpr_token_number_period_ (ffelexToken t)
14025 {
14026 ffeexprExpr_ e;
14027 ffelexHandler nexthandler;
14028 const char *p;
14029 char d;
14030
14031 switch (ffelex_token_type (t))
14032 {
14033 case FFELEX_typeNAME:
14034 case FFELEX_typeNAMES:
14035 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
14036 'D', 'd')
14037 || ffesrc_char_match_init (d, 'E', 'e')
14038 || ffesrc_char_match_init (d, 'Q', 'q'))
14039 && ffeexpr_isdigits_ (++p))
14040 {
14041
14042 /* Just exponent character by itself? In which case, PLUS or MINUS
14043 must surely be next, followed by a NUMBER token. */
14044
14045 if (*p == '\0')
14046 {
14047 ffeexpr_tokens_[2] = ffelex_token_use (t);
14048 return (ffelexHandler) ffeexpr_token_number_per_exp_;
14049 }
14050 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0],
14051 ffeexpr_tokens_[1], NULL, t, NULL,
14052 NULL);
14053
14054 ffelex_token_kill (ffeexpr_tokens_[0]);
14055 ffelex_token_kill (ffeexpr_tokens_[1]);
14056 return (ffelexHandler) ffeexpr_token_binary_;
14057 }
14058 /* A name not representing an exponent, so assume it will be something
14059 like EQ, make an integer from the number, pass the period to binary
14060 state and the current token to the resulting state. */
14061
14062 e = ffeexpr_expr_new_ ();
14063 e->type = FFEEXPR_exprtypeOPERAND_;
14064 e->token = ffeexpr_tokens_[0];
14065 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
14066 (ffeexpr_tokens_[0]));
14067 ffebld_set_info (e->u.operand,
14068 ffeinfo_new (FFEINFO_basictypeINTEGER,
14069 FFEINFO_kindtypeINTEGERDEFAULT, 0,
14070 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14071 FFETARGET_charactersizeNONE));
14072 ffeexpr_exprstack_push_operand_ (e);
14073 nexthandler = (ffelexHandler) ffeexpr_token_binary_
14074 (ffeexpr_tokens_[1]);
14075 ffelex_token_kill (ffeexpr_tokens_[1]);
14076 return (ffelexHandler) (*nexthandler) (t);
14077
14078 case FFELEX_typeNUMBER:
14079 ffeexpr_tokens_[2] = ffelex_token_use (t);
14080 return (ffelexHandler) ffeexpr_token_number_real_;
14081
14082 default:
14083 break;
14084 }
14085
14086 /* Nothing specific we were looking for, so make a real number and pass the
14087 period and then the current token to the binary state. */
14088
14089 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14090 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14091 NULL, NULL, NULL, NULL);
14092
14093 ffelex_token_kill (ffeexpr_tokens_[0]);
14094 ffelex_token_kill (ffeexpr_tokens_[1]);
14095 return (ffelexHandler) ffeexpr_token_binary_ (t);
14096 }
14097
14098 /* ffeexpr_token_number_per_exp_ -- Rhs NUMBER PERIOD NAME(D, E, or Q)
14099
14100 Return a pointer to this function to the lexer (ffelex), which will
14101 invoke it for the next token.
14102
14103 Ensures this token is PLUS or MINUS, preserves it, goes to final state
14104 for real number (exponent digits). Else treats number as real, passes
14105 name to binary, passes current token to subsequent handler. */
14106
14107 static ffelexHandler
14108 ffeexpr_token_number_per_exp_ (ffelexToken t)
14109 {
14110 if ((ffelex_token_type (t) != FFELEX_typePLUS)
14111 && (ffelex_token_type (t) != FFELEX_typeMINUS))
14112 {
14113 ffelexHandler nexthandler;
14114
14115 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14116 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14117 NULL, NULL, NULL, NULL);
14118
14119 ffelex_token_kill (ffeexpr_tokens_[0]);
14120 ffelex_token_kill (ffeexpr_tokens_[1]);
14121 nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[2]);
14122 ffelex_token_kill (ffeexpr_tokens_[2]);
14123 return (ffelexHandler) (*nexthandler) (t);
14124 }
14125
14126 ffeexpr_tokens_[3] = ffelex_token_use (t);
14127 return (ffelexHandler) ffeexpr_token_num_per_exp_sign_;
14128 }
14129
14130 /* ffeexpr_token_number_real_ -- Rhs NUMBER PERIOD NUMBER
14131
14132 Return a pointer to this function to the lexer (ffelex), which will
14133 invoke it for the next token.
14134
14135 After a number, period, and number, check next token for possible
14136 exponent designation (D, E, or Q as first/only character) and continue
14137 real-number handling accordingly. Else form basic real constant, push
14138 onto expression stack, and enter binary state using current token (which,
14139 if it is a name not beginning with D, E, or Q, will certainly result
14140 in an error, but that's not for this routine to deal with). */
14141
14142 static ffelexHandler
14143 ffeexpr_token_number_real_ (ffelexToken t)
14144 {
14145 char d;
14146 const char *p;
14147
14148 if (((ffelex_token_type (t) != FFELEX_typeNAME)
14149 && (ffelex_token_type (t) != FFELEX_typeNAMES))
14150 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
14151 'D', 'd')
14152 || ffesrc_char_match_init (d, 'E', 'e')
14153 || ffesrc_char_match_init (d, 'Q', 'q')))
14154 && ffeexpr_isdigits_ (++p)))
14155 {
14156 #if 0
14157 /* This code has been removed because it seems inconsistent to
14158 produce a diagnostic in this case, but not all of the other
14159 ones that look for an exponent and cannot recognize one. */
14160 if (((ffelex_token_type (t) == FFELEX_typeNAME)
14161 || (ffelex_token_type (t) == FFELEX_typeNAMES))
14162 && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
14163 {
14164 char bad[2];
14165
14166 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14167 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
14168 ffelex_token_where_column (ffeexpr_tokens_[0]));
14169 bad[0] = *(p - 1);
14170 bad[1] = '\0';
14171 ffebad_string (bad);
14172 ffebad_finish ();
14173 }
14174 #endif
14175 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14176 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14177 ffeexpr_tokens_[2], NULL, NULL, NULL);
14178
14179 ffelex_token_kill (ffeexpr_tokens_[0]);
14180 ffelex_token_kill (ffeexpr_tokens_[1]);
14181 ffelex_token_kill (ffeexpr_tokens_[2]);
14182 return (ffelexHandler) ffeexpr_token_binary_ (t);
14183 }
14184
14185 /* Just exponent character by itself? In which case, PLUS or MINUS must
14186 surely be next, followed by a NUMBER token. */
14187
14188 if (*p == '\0')
14189 {
14190 ffeexpr_tokens_[3] = ffelex_token_use (t);
14191 return (ffelexHandler) ffeexpr_token_number_real_exp_;
14192 }
14193
14194 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14195 ffeexpr_tokens_[2], t, NULL, NULL);
14196
14197 ffelex_token_kill (ffeexpr_tokens_[0]);
14198 ffelex_token_kill (ffeexpr_tokens_[1]);
14199 ffelex_token_kill (ffeexpr_tokens_[2]);
14200 return (ffelexHandler) ffeexpr_token_binary_;
14201 }
14202
14203 /* ffeexpr_token_num_per_exp_sign_ -- Rhs NUMBER PERIOD NAME(D,E,Q) PLUS/MINUS
14204
14205 Return a pointer to this function to the lexer (ffelex), which will
14206 invoke it for the next token.
14207
14208 Make sure token is a NUMBER, make a real constant out of all we have and
14209 push it onto the expression stack. Else issue diagnostic and pretend
14210 exponent field was a zero. */
14211
14212 static ffelexHandler
14213 ffeexpr_token_num_per_exp_sign_ (ffelexToken t)
14214 {
14215 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14216 {
14217 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14218 {
14219 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
14220 ffelex_token_where_column (ffeexpr_tokens_[2]));
14221 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14222 ffebad_finish ();
14223 }
14224
14225 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14226 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14227 NULL, NULL, NULL, NULL);
14228
14229 ffelex_token_kill (ffeexpr_tokens_[0]);
14230 ffelex_token_kill (ffeexpr_tokens_[1]);
14231 ffelex_token_kill (ffeexpr_tokens_[2]);
14232 ffelex_token_kill (ffeexpr_tokens_[3]);
14233 return (ffelexHandler) ffeexpr_token_binary_ (t);
14234 }
14235
14236 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0],
14237 ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL,
14238 ffeexpr_tokens_[2], ffeexpr_tokens_[3], t);
14239
14240 ffelex_token_kill (ffeexpr_tokens_[0]);
14241 ffelex_token_kill (ffeexpr_tokens_[1]);
14242 ffelex_token_kill (ffeexpr_tokens_[2]);
14243 ffelex_token_kill (ffeexpr_tokens_[3]);
14244 return (ffelexHandler) ffeexpr_token_binary_;
14245 }
14246
14247 /* ffeexpr_token_number_real_exp_ -- Rhs NUMBER PERIOD NUMBER NAME(D, E, or Q)
14248
14249 Return a pointer to this function to the lexer (ffelex), which will
14250 invoke it for the next token.
14251
14252 Ensures this token is PLUS or MINUS, preserves it, goes to final state
14253 for real number (exponent digits). Else issues diagnostic, assumes a
14254 zero exponent field for number, passes token on to binary state as if
14255 previous token had been "E0" instead of "E", for example. */
14256
14257 static ffelexHandler
14258 ffeexpr_token_number_real_exp_ (ffelexToken t)
14259 {
14260 if ((ffelex_token_type (t) != FFELEX_typePLUS)
14261 && (ffelex_token_type (t) != FFELEX_typeMINUS))
14262 {
14263 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14264 {
14265 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
14266 ffelex_token_where_column (ffeexpr_tokens_[3]));
14267 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14268 ffebad_finish ();
14269 }
14270
14271 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14272 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14273 ffeexpr_tokens_[2], NULL, NULL, NULL);
14274
14275 ffelex_token_kill (ffeexpr_tokens_[0]);
14276 ffelex_token_kill (ffeexpr_tokens_[1]);
14277 ffelex_token_kill (ffeexpr_tokens_[2]);
14278 ffelex_token_kill (ffeexpr_tokens_[3]);
14279 return (ffelexHandler) ffeexpr_token_binary_ (t);
14280 }
14281
14282 ffeexpr_tokens_[4] = ffelex_token_use (t);
14283 return (ffelexHandler) ffeexpr_token_num_real_exp_sn_;
14284 }
14285
14286 /* ffeexpr_token_num_real_exp_sn_ -- Rhs NUMBER PERIOD NUMBER NAME(D,E,Q)
14287 PLUS/MINUS
14288
14289 Return a pointer to this function to the lexer (ffelex), which will
14290 invoke it for the next token.
14291
14292 Make sure token is a NUMBER, make a real constant out of all we have and
14293 push it onto the expression stack. Else issue diagnostic and pretend
14294 exponent field was a zero. */
14295
14296 static ffelexHandler
14297 ffeexpr_token_num_real_exp_sn_ (ffelexToken t)
14298 {
14299 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14300 {
14301 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14302 {
14303 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
14304 ffelex_token_where_column (ffeexpr_tokens_[3]));
14305 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14306 ffebad_finish ();
14307 }
14308
14309 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14310 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14311 ffeexpr_tokens_[2], NULL, NULL, NULL);
14312
14313 ffelex_token_kill (ffeexpr_tokens_[0]);
14314 ffelex_token_kill (ffeexpr_tokens_[1]);
14315 ffelex_token_kill (ffeexpr_tokens_[2]);
14316 ffelex_token_kill (ffeexpr_tokens_[3]);
14317 ffelex_token_kill (ffeexpr_tokens_[4]);
14318 return (ffelexHandler) ffeexpr_token_binary_ (t);
14319 }
14320
14321 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[3])[0],
14322 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14323 ffeexpr_tokens_[2], ffeexpr_tokens_[3],
14324 ffeexpr_tokens_[4], t);
14325
14326 ffelex_token_kill (ffeexpr_tokens_[0]);
14327 ffelex_token_kill (ffeexpr_tokens_[1]);
14328 ffelex_token_kill (ffeexpr_tokens_[2]);
14329 ffelex_token_kill (ffeexpr_tokens_[3]);
14330 ffelex_token_kill (ffeexpr_tokens_[4]);
14331 return (ffelexHandler) ffeexpr_token_binary_;
14332 }
14333
14334 /* ffeexpr_token_binary_ -- Handle binary operator possibility
14335
14336 Return a pointer to this function to the lexer (ffelex), which will
14337 invoke it for the next token.
14338
14339 The possibility of a binary operator is handled here, meaning the previous
14340 token was an operand. */
14341
14342 static ffelexHandler
14343 ffeexpr_token_binary_ (ffelexToken t)
14344 {
14345 ffeexprExpr_ e;
14346
14347 if (!ffeexpr_stack_->is_rhs)
14348 return (ffelexHandler) ffeexpr_finished_ (t); /* For now. */
14349
14350 switch (ffelex_token_type (t))
14351 {
14352 case FFELEX_typePLUS:
14353 e = ffeexpr_expr_new_ ();
14354 e->type = FFEEXPR_exprtypeBINARY_;
14355 e->token = ffelex_token_use (t);
14356 e->u.operator.op = FFEEXPR_operatorADD_;
14357 e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
14358 e->u.operator.as = FFEEXPR_operatorassociativityADD_;
14359 ffeexpr_exprstack_push_binary_ (e);
14360 return (ffelexHandler) ffeexpr_token_rhs_;
14361
14362 case FFELEX_typeMINUS:
14363 e = ffeexpr_expr_new_ ();
14364 e->type = FFEEXPR_exprtypeBINARY_;
14365 e->token = ffelex_token_use (t);
14366 e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
14367 e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
14368 e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
14369 ffeexpr_exprstack_push_binary_ (e);
14370 return (ffelexHandler) ffeexpr_token_rhs_;
14371
14372 case FFELEX_typeASTERISK:
14373 switch (ffeexpr_stack_->context)
14374 {
14375 case FFEEXPR_contextDATA:
14376 return (ffelexHandler) ffeexpr_finished_ (t);
14377
14378 default:
14379 break;
14380 }
14381 e = ffeexpr_expr_new_ ();
14382 e->type = FFEEXPR_exprtypeBINARY_;
14383 e->token = ffelex_token_use (t);
14384 e->u.operator.op = FFEEXPR_operatorMULTIPLY_;
14385 e->u.operator.prec = FFEEXPR_operatorprecedenceMULTIPLY_;
14386 e->u.operator.as = FFEEXPR_operatorassociativityMULTIPLY_;
14387 ffeexpr_exprstack_push_binary_ (e);
14388 return (ffelexHandler) ffeexpr_token_rhs_;
14389
14390 case FFELEX_typeSLASH:
14391 switch (ffeexpr_stack_->context)
14392 {
14393 case FFEEXPR_contextDATA:
14394 return (ffelexHandler) ffeexpr_finished_ (t);
14395
14396 default:
14397 break;
14398 }
14399 e = ffeexpr_expr_new_ ();
14400 e->type = FFEEXPR_exprtypeBINARY_;
14401 e->token = ffelex_token_use (t);
14402 e->u.operator.op = FFEEXPR_operatorDIVIDE_;
14403 e->u.operator.prec = FFEEXPR_operatorprecedenceDIVIDE_;
14404 e->u.operator.as = FFEEXPR_operatorassociativityDIVIDE_;
14405 ffeexpr_exprstack_push_binary_ (e);
14406 return (ffelexHandler) ffeexpr_token_rhs_;
14407
14408 case FFELEX_typePOWER:
14409 e = ffeexpr_expr_new_ ();
14410 e->type = FFEEXPR_exprtypeBINARY_;
14411 e->token = ffelex_token_use (t);
14412 e->u.operator.op = FFEEXPR_operatorPOWER_;
14413 e->u.operator.prec = FFEEXPR_operatorprecedencePOWER_;
14414 e->u.operator.as = FFEEXPR_operatorassociativityPOWER_;
14415 ffeexpr_exprstack_push_binary_ (e);
14416 return (ffelexHandler) ffeexpr_token_rhs_;
14417
14418 case FFELEX_typeCONCAT:
14419 e = ffeexpr_expr_new_ ();
14420 e->type = FFEEXPR_exprtypeBINARY_;
14421 e->token = ffelex_token_use (t);
14422 e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
14423 e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
14424 e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
14425 ffeexpr_exprstack_push_binary_ (e);
14426 return (ffelexHandler) ffeexpr_token_rhs_;
14427
14428 case FFELEX_typeOPEN_ANGLE:
14429 switch (ffeexpr_stack_->context)
14430 {
14431 case FFEEXPR_contextFORMAT:
14432 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14433 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14434 ffebad_finish ();
14435 break;
14436
14437 default:
14438 break;
14439 }
14440 e = ffeexpr_expr_new_ ();
14441 e->type = FFEEXPR_exprtypeBINARY_;
14442 e->token = ffelex_token_use (t);
14443 e->u.operator.op = FFEEXPR_operatorLT_;
14444 e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
14445 e->u.operator.as = FFEEXPR_operatorassociativityLT_;
14446 ffeexpr_exprstack_push_binary_ (e);
14447 return (ffelexHandler) ffeexpr_token_rhs_;
14448
14449 case FFELEX_typeCLOSE_ANGLE:
14450 switch (ffeexpr_stack_->context)
14451 {
14452 case FFEEXPR_contextFORMAT:
14453 return ffeexpr_finished_ (t);
14454
14455 default:
14456 break;
14457 }
14458 e = ffeexpr_expr_new_ ();
14459 e->type = FFEEXPR_exprtypeBINARY_;
14460 e->token = ffelex_token_use (t);
14461 e->u.operator.op = FFEEXPR_operatorGT_;
14462 e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
14463 e->u.operator.as = FFEEXPR_operatorassociativityGT_;
14464 ffeexpr_exprstack_push_binary_ (e);
14465 return (ffelexHandler) ffeexpr_token_rhs_;
14466
14467 case FFELEX_typeREL_EQ:
14468 switch (ffeexpr_stack_->context)
14469 {
14470 case FFEEXPR_contextFORMAT:
14471 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14472 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14473 ffebad_finish ();
14474 break;
14475
14476 default:
14477 break;
14478 }
14479 e = ffeexpr_expr_new_ ();
14480 e->type = FFEEXPR_exprtypeBINARY_;
14481 e->token = ffelex_token_use (t);
14482 e->u.operator.op = FFEEXPR_operatorEQ_;
14483 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
14484 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
14485 ffeexpr_exprstack_push_binary_ (e);
14486 return (ffelexHandler) ffeexpr_token_rhs_;
14487
14488 case FFELEX_typeREL_NE:
14489 switch (ffeexpr_stack_->context)
14490 {
14491 case FFEEXPR_contextFORMAT:
14492 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14493 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14494 ffebad_finish ();
14495 break;
14496
14497 default:
14498 break;
14499 }
14500 e = ffeexpr_expr_new_ ();
14501 e->type = FFEEXPR_exprtypeBINARY_;
14502 e->token = ffelex_token_use (t);
14503 e->u.operator.op = FFEEXPR_operatorNE_;
14504 e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
14505 e->u.operator.as = FFEEXPR_operatorassociativityNE_;
14506 ffeexpr_exprstack_push_binary_ (e);
14507 return (ffelexHandler) ffeexpr_token_rhs_;
14508
14509 case FFELEX_typeREL_LE:
14510 switch (ffeexpr_stack_->context)
14511 {
14512 case FFEEXPR_contextFORMAT:
14513 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14514 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14515 ffebad_finish ();
14516 break;
14517
14518 default:
14519 break;
14520 }
14521 e = ffeexpr_expr_new_ ();
14522 e->type = FFEEXPR_exprtypeBINARY_;
14523 e->token = ffelex_token_use (t);
14524 e->u.operator.op = FFEEXPR_operatorLE_;
14525 e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
14526 e->u.operator.as = FFEEXPR_operatorassociativityLE_;
14527 ffeexpr_exprstack_push_binary_ (e);
14528 return (ffelexHandler) ffeexpr_token_rhs_;
14529
14530 case FFELEX_typeREL_GE:
14531 switch (ffeexpr_stack_->context)
14532 {
14533 case FFEEXPR_contextFORMAT:
14534 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14535 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14536 ffebad_finish ();
14537 break;
14538
14539 default:
14540 break;
14541 }
14542 e = ffeexpr_expr_new_ ();
14543 e->type = FFEEXPR_exprtypeBINARY_;
14544 e->token = ffelex_token_use (t);
14545 e->u.operator.op = FFEEXPR_operatorGE_;
14546 e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
14547 e->u.operator.as = FFEEXPR_operatorassociativityGE_;
14548 ffeexpr_exprstack_push_binary_ (e);
14549 return (ffelexHandler) ffeexpr_token_rhs_;
14550
14551 case FFELEX_typePERIOD:
14552 ffeexpr_tokens_[0] = ffelex_token_use (t);
14553 return (ffelexHandler) ffeexpr_token_binary_period_;
14554
14555 #if 0
14556 case FFELEX_typeOPEN_PAREN:
14557 case FFELEX_typeCLOSE_PAREN:
14558 case FFELEX_typeEQUALS:
14559 case FFELEX_typePOINTS:
14560 case FFELEX_typeCOMMA:
14561 case FFELEX_typeCOLON:
14562 case FFELEX_typeEOS:
14563 case FFELEX_typeSEMICOLON:
14564 case FFELEX_typeNAME:
14565 case FFELEX_typeNAMES:
14566 #endif
14567 default:
14568 return (ffelexHandler) ffeexpr_finished_ (t);
14569 }
14570 }
14571
14572 /* ffeexpr_token_binary_period_ -- Binary PERIOD
14573
14574 Return a pointer to this function to the lexer (ffelex), which will
14575 invoke it for the next token.
14576
14577 Handle a period detected at binary (expecting binary op or end) state.
14578 Must begin a dot-dot name, of which .NOT., .TRUE., and .FALSE. are not
14579 valid. */
14580
14581 static ffelexHandler
14582 ffeexpr_token_binary_period_ (ffelexToken t)
14583 {
14584 ffeexprExpr_ operand;
14585
14586 switch (ffelex_token_type (t))
14587 {
14588 case FFELEX_typeNAME:
14589 case FFELEX_typeNAMES:
14590 ffeexpr_current_dotdot_ = ffestr_other (t);
14591 switch (ffeexpr_current_dotdot_)
14592 {
14593 case FFESTR_otherTRUE:
14594 case FFESTR_otherFALSE:
14595 case FFESTR_otherNOT:
14596 if (ffest_ffebad_start (FFEBAD_MISSING_BINARY_OPERATOR))
14597 {
14598 operand = ffeexpr_stack_->exprstack;
14599 assert (operand != NULL);
14600 assert (operand->type == FFEEXPR_exprtypeOPERAND_);
14601 ffebad_here (0, ffelex_token_where_line (operand->token), ffelex_token_where_column (operand->token));
14602 ffebad_here (1, ffelex_token_where_line (t),
14603 ffelex_token_where_column (t));
14604 ffebad_finish ();
14605 }
14606 ffelex_token_kill (ffeexpr_tokens_[0]);
14607 return (ffelexHandler) ffeexpr_token_binary_sw_per_;
14608
14609 default:
14610 ffeexpr_tokens_[1] = ffelex_token_use (t);
14611 return (ffelexHandler) ffeexpr_token_binary_end_per_;
14612 }
14613 break; /* Nothing really reaches here. */
14614
14615 default:
14616 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
14617 {
14618 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14619 ffelex_token_where_column (ffeexpr_tokens_[0]));
14620 ffebad_finish ();
14621 }
14622 ffelex_token_kill (ffeexpr_tokens_[0]);
14623 return (ffelexHandler) ffeexpr_token_binary_ (t);
14624 }
14625 }
14626
14627 /* ffeexpr_token_binary_end_per_ -- Binary PERIOD NAME(not NOT, TRUE, or FALSE)
14628
14629 Return a pointer to this function to the lexer (ffelex), which will
14630 invoke it for the next token.
14631
14632 Expecting a period to close a dot-dot at binary (binary op
14633 or operator) state. If period isn't found, issue a diagnostic but
14634 pretend we saw one. ffeexpr_current_dotdot_ must already contained the
14635 dotdot representation of the name in between the two PERIOD tokens. */
14636
14637 static ffelexHandler
14638 ffeexpr_token_binary_end_per_ (ffelexToken t)
14639 {
14640 ffeexprExpr_ e;
14641
14642 e = ffeexpr_expr_new_ ();
14643 e->type = FFEEXPR_exprtypeBINARY_;
14644 e->token = ffeexpr_tokens_[0];
14645
14646 switch (ffeexpr_current_dotdot_)
14647 {
14648 case FFESTR_otherAND:
14649 e->u.operator.op = FFEEXPR_operatorAND_;
14650 e->u.operator.prec = FFEEXPR_operatorprecedenceAND_;
14651 e->u.operator.as = FFEEXPR_operatorassociativityAND_;
14652 break;
14653
14654 case FFESTR_otherOR:
14655 e->u.operator.op = FFEEXPR_operatorOR_;
14656 e->u.operator.prec = FFEEXPR_operatorprecedenceOR_;
14657 e->u.operator.as = FFEEXPR_operatorassociativityOR_;
14658 break;
14659
14660 case FFESTR_otherXOR:
14661 e->u.operator.op = FFEEXPR_operatorXOR_;
14662 e->u.operator.prec = FFEEXPR_operatorprecedenceXOR_;
14663 e->u.operator.as = FFEEXPR_operatorassociativityXOR_;
14664 break;
14665
14666 case FFESTR_otherEQV:
14667 e->u.operator.op = FFEEXPR_operatorEQV_;
14668 e->u.operator.prec = FFEEXPR_operatorprecedenceEQV_;
14669 e->u.operator.as = FFEEXPR_operatorassociativityEQV_;
14670 break;
14671
14672 case FFESTR_otherNEQV:
14673 e->u.operator.op = FFEEXPR_operatorNEQV_;
14674 e->u.operator.prec = FFEEXPR_operatorprecedenceNEQV_;
14675 e->u.operator.as = FFEEXPR_operatorassociativityNEQV_;
14676 break;
14677
14678 case FFESTR_otherLT:
14679 e->u.operator.op = FFEEXPR_operatorLT_;
14680 e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
14681 e->u.operator.as = FFEEXPR_operatorassociativityLT_;
14682 break;
14683
14684 case FFESTR_otherLE:
14685 e->u.operator.op = FFEEXPR_operatorLE_;
14686 e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
14687 e->u.operator.as = FFEEXPR_operatorassociativityLE_;
14688 break;
14689
14690 case FFESTR_otherEQ:
14691 e->u.operator.op = FFEEXPR_operatorEQ_;
14692 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
14693 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
14694 break;
14695
14696 case FFESTR_otherNE:
14697 e->u.operator.op = FFEEXPR_operatorNE_;
14698 e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
14699 e->u.operator.as = FFEEXPR_operatorassociativityNE_;
14700 break;
14701
14702 case FFESTR_otherGT:
14703 e->u.operator.op = FFEEXPR_operatorGT_;
14704 e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
14705 e->u.operator.as = FFEEXPR_operatorassociativityGT_;
14706 break;
14707
14708 case FFESTR_otherGE:
14709 e->u.operator.op = FFEEXPR_operatorGE_;
14710 e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
14711 e->u.operator.as = FFEEXPR_operatorassociativityGE_;
14712 break;
14713
14714 default:
14715 if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT))
14716 {
14717 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14718 ffelex_token_where_column (ffeexpr_tokens_[0]));
14719 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
14720 ffebad_finish ();
14721 }
14722 e->u.operator.op = FFEEXPR_operatorEQ_;
14723 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
14724 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
14725 break;
14726 }
14727
14728 ffeexpr_exprstack_push_binary_ (e);
14729
14730 if (ffelex_token_type (t) != FFELEX_typePERIOD)
14731 {
14732 if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
14733 {
14734 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14735 ffelex_token_where_column (ffeexpr_tokens_[0]));
14736 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14737 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
14738 ffebad_finish ();
14739 }
14740 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */
14741 return (ffelexHandler) ffeexpr_token_rhs_ (t);
14742 }
14743
14744 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */
14745 return (ffelexHandler) ffeexpr_token_rhs_;
14746 }
14747
14748 /* ffeexpr_token_binary_sw_per_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
14749
14750 Return a pointer to this function to the lexer (ffelex), which will
14751 invoke it for the next token.
14752
14753 A diagnostic has already been issued; just swallow a period if there is
14754 one, then continue with ffeexpr_token_binary_. */
14755
14756 static ffelexHandler
14757 ffeexpr_token_binary_sw_per_ (ffelexToken t)
14758 {
14759 if (ffelex_token_type (t) != FFELEX_typePERIOD)
14760 return (ffelexHandler) ffeexpr_token_binary_ (t);
14761
14762 return (ffelexHandler) ffeexpr_token_binary_;
14763 }
14764
14765 /* ffeexpr_token_quote_ -- Rhs QUOTE
14766
14767 Return a pointer to this function to the lexer (ffelex), which will
14768 invoke it for the next token.
14769
14770 Expecting a NUMBER that we'll treat as an octal integer. */
14771
14772 static ffelexHandler
14773 ffeexpr_token_quote_ (ffelexToken t)
14774 {
14775 ffeexprExpr_ e;
14776 ffebld anyexpr;
14777
14778 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14779 {
14780 if (ffest_ffebad_start (FFEBAD_QUOTE_MISSES_DIGITS))
14781 {
14782 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14783 ffelex_token_where_column (ffeexpr_tokens_[0]));
14784 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14785 ffebad_finish ();
14786 }
14787 ffelex_token_kill (ffeexpr_tokens_[0]);
14788 return (ffelexHandler) ffeexpr_token_rhs_ (t);
14789 }
14790
14791 /* This is kind of a kludge to prevent any whining about magical numbers
14792 that start out as these octal integers, so "20000000000 (on a 32-bit
14793 2's-complement machine) by itself won't produce an error. */
14794
14795 anyexpr = ffebld_new_any ();
14796 ffebld_set_info (anyexpr, ffeinfo_new_any ());
14797
14798 e = ffeexpr_expr_new_ ();
14799 e->type = FFEEXPR_exprtypeOPERAND_;
14800 e->token = ffeexpr_tokens_[0];
14801 e->u.operand = ffebld_new_conter_with_orig
14802 (ffebld_constant_new_integeroctal (t), anyexpr);
14803 ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER,
14804 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY,
14805 FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14806 ffeexpr_exprstack_push_operand_ (e);
14807 return (ffelexHandler) ffeexpr_token_binary_;
14808 }
14809
14810 /* ffeexpr_token_apostrophe_ -- Rhs APOSTROPHE
14811
14812 Return a pointer to this function to the lexer (ffelex), which will
14813 invoke it for the next token.
14814
14815 Handle an open-apostrophe, which begins either a character ('char-const'),
14816 typeless octal ('octal-const'O), or typeless hexadecimal ('hex-const'Z or
14817 'hex-const'X) constant. */
14818
14819 static ffelexHandler
14820 ffeexpr_token_apostrophe_ (ffelexToken t)
14821 {
14822 assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
14823 if (ffe_is_pedantic_not_90 () && (ffelex_token_length (t) == 0))
14824 {
14825 ffebad_start (FFEBAD_NULL_CHAR_CONST);
14826 ffebad_here (0, ffelex_token_where_line (t),
14827 ffelex_token_where_column (t));
14828 ffebad_finish ();
14829 }
14830 ffeexpr_tokens_[1] = ffelex_token_use (t);
14831 return (ffelexHandler) ffeexpr_token_apos_char_;
14832 }
14833
14834 /* ffeexpr_token_apos_char_ -- Rhs APOSTROPHE CHARACTER
14835
14836 Return a pointer to this function to the lexer (ffelex), which will
14837 invoke it for the next token.
14838
14839 Close-apostrophe is implicit; if this token is NAME, it is a possible
14840 typeless-constant radix specifier. */
14841
14842 static ffelexHandler
14843 ffeexpr_token_apos_char_ (ffelexToken t)
14844 {
14845 ffeexprExpr_ e;
14846 ffeinfo ni;
14847 char c;
14848 ffetargetCharacterSize size;
14849
14850 if ((ffelex_token_type (t) == FFELEX_typeNAME)
14851 || (ffelex_token_type (t) == FFELEX_typeNAMES))
14852 {
14853 if ((ffelex_token_length (t) == 1)
14854 && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]), 'B',
14855 'b')
14856 || ffesrc_char_match_init (c, 'O', 'o')
14857 || ffesrc_char_match_init (c, 'X', 'x')
14858 || ffesrc_char_match_init (c, 'Z', 'z')))
14859 {
14860 e = ffeexpr_expr_new_ ();
14861 e->type = FFEEXPR_exprtypeOPERAND_;
14862 e->token = ffeexpr_tokens_[0];
14863 switch (c)
14864 {
14865 case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
14866 e->u.operand = ffebld_new_conter
14867 (ffebld_constant_new_typeless_bv (ffeexpr_tokens_[1]));
14868 size = ffetarget_size_typeless_binary (ffeexpr_tokens_[1]);
14869 break;
14870
14871 case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
14872 e->u.operand = ffebld_new_conter
14873 (ffebld_constant_new_typeless_ov (ffeexpr_tokens_[1]));
14874 size = ffetarget_size_typeless_octal (ffeexpr_tokens_[1]);
14875 break;
14876
14877 case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
14878 e->u.operand = ffebld_new_conter
14879 (ffebld_constant_new_typeless_hxv (ffeexpr_tokens_[1]));
14880 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
14881 break;
14882
14883 case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
14884 e->u.operand = ffebld_new_conter
14885 (ffebld_constant_new_typeless_hzv (ffeexpr_tokens_[1]));
14886 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
14887 break;
14888
14889 default:
14890 no_match: /* :::::::::::::::::::: */
14891 assert ("not BOXZ!" == NULL);
14892 size = 0;
14893 break;
14894 }
14895 ffebld_set_info (e->u.operand,
14896 ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
14897 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
14898 ffeexpr_exprstack_push_operand_ (e);
14899 ffelex_token_kill (ffeexpr_tokens_[1]);
14900 return (ffelexHandler) ffeexpr_token_binary_;
14901 }
14902 }
14903 e = ffeexpr_expr_new_ ();
14904 e->type = FFEEXPR_exprtypeOPERAND_;
14905 e->token = ffeexpr_tokens_[0];
14906 e->u.operand = ffebld_new_conter (ffebld_constant_new_characterdefault
14907 (ffeexpr_tokens_[1]));
14908 ni = ffeinfo_new (FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTERDEFAULT,
14909 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14910 ffelex_token_length (ffeexpr_tokens_[1]));
14911 ffebld_set_info (e->u.operand, ni);
14912 ffelex_token_kill (ffeexpr_tokens_[1]);
14913 ffeexpr_exprstack_push_operand_ (e);
14914 if ((ffelex_token_type (t) == FFELEX_typeNAME)
14915 || (ffelex_token_type (t) == FFELEX_typeNAMES))
14916 {
14917 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14918 {
14919 ffebad_string (ffelex_token_text (t));
14920 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14921 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
14922 ffelex_token_where_column (ffeexpr_tokens_[0]));
14923 ffebad_finish ();
14924 }
14925 e = ffeexpr_expr_new_ ();
14926 e->type = FFEEXPR_exprtypeBINARY_;
14927 e->token = ffelex_token_use (t);
14928 e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
14929 e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
14930 e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
14931 ffeexpr_exprstack_push_binary_ (e);
14932 return (ffelexHandler) ffeexpr_token_rhs_ (t);
14933 }
14934 ffeexpr_is_substr_ok_ = !ffe_is_pedantic_not_90 (); /* Allow "'hello'(3:5)". */
14935 return (ffelexHandler) ffeexpr_token_substrp_ (t);
14936 }
14937
14938 /* ffeexpr_token_name_lhs_ -- Lhs NAME
14939
14940 Return a pointer to this function to the lexer (ffelex), which will
14941 invoke it for the next token.
14942
14943 Handle a name followed by open-paren, period (RECORD.MEMBER), percent
14944 (RECORD%MEMBER), or nothing at all. */
14945
14946 static ffelexHandler
14947 ffeexpr_token_name_lhs_ (ffelexToken t)
14948 {
14949 ffeexprExpr_ e;
14950 ffeexprParenType_ paren_type;
14951 ffesymbol s;
14952 ffebld expr;
14953 ffeinfo info;
14954
14955 switch (ffelex_token_type (t))
14956 {
14957 case FFELEX_typeOPEN_PAREN:
14958 switch (ffeexpr_stack_->context)
14959 {
14960 case FFEEXPR_contextASSIGN:
14961 case FFEEXPR_contextAGOTO:
14962 case FFEEXPR_contextFILEUNIT_DF:
14963 goto just_name; /* :::::::::::::::::::: */
14964
14965 default:
14966 break;
14967 }
14968 e = ffeexpr_expr_new_ ();
14969 e->type = FFEEXPR_exprtypeOPERAND_;
14970 e->token = ffelex_token_use (ffeexpr_tokens_[0]);
14971 s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], FALSE,
14972 &paren_type);
14973
14974 switch (ffesymbol_where (s))
14975 {
14976 case FFEINFO_whereLOCAL:
14977 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14978 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recursion. */
14979 break;
14980
14981 case FFEINFO_whereINTRINSIC:
14982 case FFEINFO_whereGLOBAL:
14983 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
14984 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */
14985 break;
14986
14987 case FFEINFO_whereCOMMON:
14988 case FFEINFO_whereDUMMY:
14989 case FFEINFO_whereRESULT:
14990 break;
14991
14992 case FFEINFO_whereNONE:
14993 case FFEINFO_whereANY:
14994 break;
14995
14996 default:
14997 ffesymbol_error (s, ffeexpr_tokens_[0]);
14998 break;
14999 }
15000
15001 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15002 {
15003 e->u.operand = ffebld_new_any ();
15004 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15005 }
15006 else
15007 {
15008 e->u.operand = ffebld_new_symter (s,
15009 ffesymbol_generic (s),
15010 ffesymbol_specific (s),
15011 ffesymbol_implementation (s));
15012 ffebld_set_info (e->u.operand, ffesymbol_info (s));
15013 }
15014 ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */
15015 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
15016 switch (paren_type)
15017 {
15018 case FFEEXPR_parentypeSUBROUTINE_:
15019 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15020 return
15021 (ffelexHandler)
15022 ffeexpr_rhs (ffeexpr_stack_->pool,
15023 FFEEXPR_contextACTUALARG_,
15024 ffeexpr_token_arguments_);
15025
15026 case FFEEXPR_parentypeARRAY_:
15027 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15028 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
15029 ffeexpr_stack_->rank = 0;
15030 ffeexpr_stack_->constant = TRUE;
15031 ffeexpr_stack_->immediate = TRUE;
15032 switch (ffeexpr_stack_->context)
15033 {
15034 case FFEEXPR_contextDATAIMPDOITEM_:
15035 return
15036 (ffelexHandler)
15037 ffeexpr_rhs (ffeexpr_stack_->pool,
15038 FFEEXPR_contextDATAIMPDOINDEX_,
15039 ffeexpr_token_elements_);
15040
15041 case FFEEXPR_contextEQUIVALENCE:
15042 return
15043 (ffelexHandler)
15044 ffeexpr_rhs (ffeexpr_stack_->pool,
15045 FFEEXPR_contextEQVINDEX_,
15046 ffeexpr_token_elements_);
15047
15048 default:
15049 return
15050 (ffelexHandler)
15051 ffeexpr_rhs (ffeexpr_stack_->pool,
15052 FFEEXPR_contextINDEX_,
15053 ffeexpr_token_elements_);
15054 }
15055
15056 case FFEEXPR_parentypeSUBSTRING_:
15057 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
15058 ffeexpr_tokens_[0]);
15059 return
15060 (ffelexHandler)
15061 ffeexpr_rhs (ffeexpr_stack_->pool,
15062 FFEEXPR_contextINDEX_,
15063 ffeexpr_token_substring_);
15064
15065 case FFEEXPR_parentypeEQUIVALENCE_:
15066 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15067 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
15068 ffeexpr_stack_->rank = 0;
15069 ffeexpr_stack_->constant = TRUE;
15070 ffeexpr_stack_->immediate = TRUE;
15071 return
15072 (ffelexHandler)
15073 ffeexpr_rhs (ffeexpr_stack_->pool,
15074 FFEEXPR_contextEQVINDEX_,
15075 ffeexpr_token_equivalence_);
15076
15077 case FFEEXPR_parentypeFUNCTION_: /* Invalid case. */
15078 case FFEEXPR_parentypeFUNSUBSTR_: /* Invalid case. */
15079 ffesymbol_error (s, ffeexpr_tokens_[0]);
15080 /* Fall through. */
15081 case FFEEXPR_parentypeANY_:
15082 e->u.operand = ffebld_new_any ();
15083 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15084 return
15085 (ffelexHandler)
15086 ffeexpr_rhs (ffeexpr_stack_->pool,
15087 FFEEXPR_contextACTUALARG_,
15088 ffeexpr_token_anything_);
15089
15090 default:
15091 assert ("bad paren type" == NULL);
15092 break;
15093 }
15094
15095 case FFELEX_typeEQUALS: /* As in "VAR=". */
15096 switch (ffeexpr_stack_->context)
15097 {
15098 case FFEEXPR_contextIMPDOITEM_: /* within
15099 "(,VAR=start,end[,incr])". */
15100 case FFEEXPR_contextIMPDOITEMDF_:
15101 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
15102 break;
15103
15104 case FFEEXPR_contextDATAIMPDOITEM_:
15105 ffeexpr_stack_->context = FFEEXPR_contextDATAIMPDOCTRL_;
15106 break;
15107
15108 default:
15109 break;
15110 }
15111 break;
15112
15113 #if 0
15114 case FFELEX_typePERIOD:
15115 case FFELEX_typePERCENT:
15116 assert ("FOO%, FOO. not yet supported!~~" == NULL);
15117 break;
15118 #endif
15119
15120 default:
15121 break;
15122 }
15123
15124 just_name: /* :::::::::::::::::::: */
15125 e = ffeexpr_expr_new_ ();
15126 e->type = FFEEXPR_exprtypeOPERAND_;
15127 e->token = ffeexpr_tokens_[0];
15128 s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0],
15129 (ffeexpr_stack_->context
15130 == FFEEXPR_contextSUBROUTINEREF));
15131
15132 switch (ffesymbol_where (s))
15133 {
15134 case FFEINFO_whereCONSTANT:
15135 if ((ffeexpr_stack_->context != FFEEXPR_contextPARAMETER)
15136 || (ffesymbol_kind (s) != FFEINFO_kindENTITY))
15137 ffesymbol_error (s, ffeexpr_tokens_[0]);
15138 break;
15139
15140 case FFEINFO_whereIMMEDIATE:
15141 if ((ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOCTRL_)
15142 && (ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOINDEX_))
15143 ffesymbol_error (s, ffeexpr_tokens_[0]);
15144 break;
15145
15146 case FFEINFO_whereLOCAL:
15147 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
15148 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recurse!. */
15149 break;
15150
15151 case FFEINFO_whereINTRINSIC:
15152 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
15153 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */
15154 break;
15155
15156 default:
15157 break;
15158 }
15159
15160 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15161 {
15162 expr = ffebld_new_any ();
15163 info = ffeinfo_new_any ();
15164 ffebld_set_info (expr, info);
15165 }
15166 else
15167 {
15168 expr = ffebld_new_symter (s,
15169 ffesymbol_generic (s),
15170 ffesymbol_specific (s),
15171 ffesymbol_implementation (s));
15172 info = ffesymbol_info (s);
15173 ffebld_set_info (expr, info);
15174 if (ffesymbol_is_doiter (s))
15175 {
15176 ffebad_start (FFEBAD_DOITER);
15177 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15178 ffelex_token_where_column (ffeexpr_tokens_[0]));
15179 ffest_ffebad_here_doiter (1, s);
15180 ffebad_string (ffesymbol_text (s));
15181 ffebad_finish ();
15182 }
15183 expr = ffeexpr_collapse_symter (expr, ffeexpr_tokens_[0]);
15184 }
15185
15186 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
15187 {
15188 if (ffebld_op (expr) == FFEBLD_opANY)
15189 {
15190 expr = ffebld_new_any ();
15191 ffebld_set_info (expr, ffeinfo_new_any ());
15192 }
15193 else
15194 {
15195 expr = ffebld_new_subrref (expr, NULL); /* No argument list. */
15196 if (ffesymbol_generic (s) != FFEINTRIN_genNONE)
15197 ffeintrin_fulfill_generic (&expr, &info, e->token);
15198 else if (ffesymbol_specific (s) != FFEINTRIN_specNONE)
15199 ffeintrin_fulfill_specific (&expr, &info, NULL, e->token);
15200 else
15201 ffeexpr_fulfill_call_ (&expr, e->token);
15202
15203 if (ffebld_op (expr) != FFEBLD_opANY)
15204 ffebld_set_info (expr,
15205 ffeinfo_new (ffeinfo_basictype (info),
15206 ffeinfo_kindtype (info),
15207 0,
15208 FFEINFO_kindENTITY,
15209 FFEINFO_whereFLEETING,
15210 ffeinfo_size (info)));
15211 else
15212 ffebld_set_info (expr, ffeinfo_new_any ());
15213 }
15214 }
15215
15216 e->u.operand = expr;
15217 ffeexpr_exprstack_push_operand_ (e);
15218 return (ffelexHandler) ffeexpr_finished_ (t);
15219 }
15220
15221 /* ffeexpr_token_name_arg_ -- Rhs NAME
15222
15223 Return a pointer to this function to the lexer (ffelex), which will
15224 invoke it for the next token.
15225
15226 Handle first token in an actual-arg (or possible actual-arg) context
15227 being a NAME, and use second token to refine the context. */
15228
15229 static ffelexHandler
15230 ffeexpr_token_name_arg_ (ffelexToken t)
15231 {
15232 switch (ffelex_token_type (t))
15233 {
15234 case FFELEX_typeCLOSE_PAREN:
15235 case FFELEX_typeCOMMA:
15236 switch (ffeexpr_stack_->context)
15237 {
15238 case FFEEXPR_contextINDEXORACTUALARG_:
15239 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
15240 break;
15241
15242 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15243 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
15244 break;
15245
15246 default:
15247 break;
15248 }
15249 break;
15250
15251 default:
15252 switch (ffeexpr_stack_->context)
15253 {
15254 case FFEEXPR_contextACTUALARG_:
15255 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
15256 break;
15257
15258 case FFEEXPR_contextINDEXORACTUALARG_:
15259 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
15260 break;
15261
15262 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15263 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
15264 break;
15265
15266 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15267 ffeexpr_stack_->context
15268 = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
15269 break;
15270
15271 default:
15272 assert ("bad context in _name_arg_" == NULL);
15273 break;
15274 }
15275 break;
15276 }
15277
15278 return (ffelexHandler) ffeexpr_token_name_rhs_ (t);
15279 }
15280
15281 /* ffeexpr_token_name_rhs_ -- Rhs NAME
15282
15283 Return a pointer to this function to the lexer (ffelex), which will
15284 invoke it for the next token.
15285
15286 Handle a name followed by open-paren, apostrophe (O'octal-const',
15287 Z'hex-const', or X'hex-const'), period (RECORD.MEMBER).
15288
15289 26-Nov-91 JCB 1.2
15290 When followed by apostrophe or quote, set lex hexnum flag on so
15291 [0-9] as first char of next token seen as starting a potentially
15292 hex number (NAME).
15293 04-Oct-91 JCB 1.1
15294 In case of intrinsic, decorate its SYMTER with the type info for
15295 the specific intrinsic. */
15296
15297 static ffelexHandler
15298 ffeexpr_token_name_rhs_ (ffelexToken t)
15299 {
15300 ffeexprExpr_ e;
15301 ffeexprParenType_ paren_type;
15302 ffesymbol s;
15303 bool sfdef;
15304
15305 switch (ffelex_token_type (t))
15306 {
15307 case FFELEX_typeQUOTE:
15308 case FFELEX_typeAPOSTROPHE:
15309 ffeexpr_tokens_[1] = ffelex_token_use (t);
15310 ffelex_set_hexnum (TRUE);
15311 return (ffelexHandler) ffeexpr_token_name_apos_;
15312
15313 case FFELEX_typeOPEN_PAREN:
15314 e = ffeexpr_expr_new_ ();
15315 e->type = FFEEXPR_exprtypeOPERAND_;
15316 e->token = ffelex_token_use (ffeexpr_tokens_[0]);
15317 s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], TRUE,
15318 &paren_type);
15319 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15320 e->u.operand = ffebld_new_any ();
15321 else
15322 e->u.operand = ffebld_new_symter (s, ffesymbol_generic (s),
15323 ffesymbol_specific (s),
15324 ffesymbol_implementation (s));
15325 ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */
15326 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
15327 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15328 {
15329 case FFEEXPR_contextSFUNCDEF:
15330 case FFEEXPR_contextSFUNCDEFINDEX_:
15331 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15332 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15333 sfdef = TRUE;
15334 break;
15335
15336 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15337 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15338 assert ("weird context!" == NULL);
15339 sfdef = FALSE;
15340 break;
15341
15342 default:
15343 sfdef = FALSE;
15344 break;
15345 }
15346 switch (paren_type)
15347 {
15348 case FFEEXPR_parentypeFUNCTION_:
15349 ffebld_set_info (e->u.operand, ffesymbol_info (s));
15350 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15351 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
15352 { /* A statement function. */
15353 ffeexpr_stack_->num_args
15354 = ffebld_list_length
15355 (ffeexpr_stack_->next_dummy
15356 = ffesymbol_dummyargs (s));
15357 ffeexpr_stack_->tokens[1] = NULL; /* !=NULL when > num_args. */
15358 }
15359 else if ((ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
15360 && !ffe_is_pedantic_not_90 ()
15361 && ((ffesymbol_implementation (s)
15362 == FFEINTRIN_impICHAR)
15363 || (ffesymbol_implementation (s)
15364 == FFEINTRIN_impIACHAR)
15365 || (ffesymbol_implementation (s)
15366 == FFEINTRIN_impLEN)))
15367 { /* Allow arbitrary concatenations. */
15368 return
15369 (ffelexHandler)
15370 ffeexpr_rhs (ffeexpr_stack_->pool,
15371 sfdef
15372 ? FFEEXPR_contextSFUNCDEF
15373 : FFEEXPR_contextLET,
15374 ffeexpr_token_arguments_);
15375 }
15376 return
15377 (ffelexHandler)
15378 ffeexpr_rhs (ffeexpr_stack_->pool,
15379 sfdef
15380 ? FFEEXPR_contextSFUNCDEFACTUALARG_
15381 : FFEEXPR_contextACTUALARG_,
15382 ffeexpr_token_arguments_);
15383
15384 case FFEEXPR_parentypeARRAY_:
15385 ffebld_set_info (e->u.operand,
15386 ffesymbol_info (ffebld_symter (e->u.operand)));
15387 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15388 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
15389 ffeexpr_stack_->rank = 0;
15390 ffeexpr_stack_->constant = TRUE;
15391 ffeexpr_stack_->immediate = TRUE;
15392 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
15393 sfdef
15394 ? FFEEXPR_contextSFUNCDEFINDEX_
15395 : FFEEXPR_contextINDEX_,
15396 ffeexpr_token_elements_);
15397
15398 case FFEEXPR_parentypeSUBSTRING_:
15399 ffebld_set_info (e->u.operand,
15400 ffesymbol_info (ffebld_symter (e->u.operand)));
15401 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
15402 ffeexpr_tokens_[0]);
15403 return
15404 (ffelexHandler)
15405 ffeexpr_rhs (ffeexpr_stack_->pool,
15406 sfdef
15407 ? FFEEXPR_contextSFUNCDEFINDEX_
15408 : FFEEXPR_contextINDEX_,
15409 ffeexpr_token_substring_);
15410
15411 case FFEEXPR_parentypeFUNSUBSTR_:
15412 return
15413 (ffelexHandler)
15414 ffeexpr_rhs (ffeexpr_stack_->pool,
15415 sfdef
15416 ? FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
15417 : FFEEXPR_contextINDEXORACTUALARG_,
15418 ffeexpr_token_funsubstr_);
15419
15420 case FFEEXPR_parentypeANY_:
15421 ffebld_set_info (e->u.operand, ffesymbol_info (s));
15422 return
15423 (ffelexHandler)
15424 ffeexpr_rhs (ffeexpr_stack_->pool,
15425 sfdef
15426 ? FFEEXPR_contextSFUNCDEFACTUALARG_
15427 : FFEEXPR_contextACTUALARG_,
15428 ffeexpr_token_anything_);
15429
15430 default:
15431 assert ("bad paren type" == NULL);
15432 break;
15433 }
15434
15435 case FFELEX_typeEQUALS: /* As in "VAR=". */
15436 switch (ffeexpr_stack_->context)
15437 {
15438 case FFEEXPR_contextIMPDOITEM_: /* "(,VAR=start,end[,incr])". */
15439 case FFEEXPR_contextIMPDOITEMDF_:
15440 ffeexpr_stack_->is_rhs = FALSE; /* Really an lhs construct. */
15441 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
15442 break;
15443
15444 default:
15445 break;
15446 }
15447 break;
15448
15449 #if 0
15450 case FFELEX_typePERIOD:
15451 case FFELEX_typePERCENT:
15452 ~~Support these two someday, though not required
15453 assert ("FOO%, FOO. not yet supported!~~" == NULL);
15454 break;
15455 #endif
15456
15457 default:
15458 break;
15459 }
15460
15461 switch (ffeexpr_stack_->context)
15462 {
15463 case FFEEXPR_contextINDEXORACTUALARG_:
15464 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15465 assert ("strange context" == NULL);
15466 break;
15467
15468 default:
15469 break;
15470 }
15471
15472 e = ffeexpr_expr_new_ ();
15473 e->type = FFEEXPR_exprtypeOPERAND_;
15474 e->token = ffeexpr_tokens_[0];
15475 s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0], FALSE);
15476 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15477 {
15478 e->u.operand = ffebld_new_any ();
15479 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15480 }
15481 else
15482 {
15483 e->u.operand = ffebld_new_symter (s, FFEINTRIN_genNONE,
15484 ffesymbol_specific (s),
15485 ffesymbol_implementation (s));
15486 if (ffesymbol_specific (s) == FFEINTRIN_specNONE)
15487 ffebld_set_info (e->u.operand, ffeinfo_use (ffesymbol_info (s)));
15488 else
15489 { /* Decorate the SYMTER with the actual type
15490 of the intrinsic. */
15491 ffebld_set_info (e->u.operand, ffeinfo_new
15492 (ffeintrin_basictype (ffesymbol_specific (s)),
15493 ffeintrin_kindtype (ffesymbol_specific (s)),
15494 0,
15495 ffesymbol_kind (s),
15496 ffesymbol_where (s),
15497 FFETARGET_charactersizeNONE));
15498 }
15499 if (ffesymbol_is_doiter (s))
15500 ffebld_symter_set_is_doiter (e->u.operand, TRUE);
15501 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
15502 ffeexpr_tokens_[0]);
15503 }
15504 ffeexpr_exprstack_push_operand_ (e);
15505 return (ffelexHandler) ffeexpr_token_binary_ (t);
15506 }
15507
15508 /* ffeexpr_token_name_apos_ -- Rhs NAME APOSTROPHE
15509
15510 Return a pointer to this function to the lexer (ffelex), which will
15511 invoke it for the next token.
15512
15513 Expecting a NAME token, analyze the previous NAME token to see what kind,
15514 if any, typeless constant we've got.
15515
15516 01-Sep-90 JCB 1.1
15517 Expect a NAME instead of CHARACTER in this situation. */
15518
15519 static ffelexHandler
15520 ffeexpr_token_name_apos_ (ffelexToken t)
15521 {
15522 ffeexprExpr_ e;
15523
15524 ffelex_set_hexnum (FALSE);
15525
15526 switch (ffelex_token_type (t))
15527 {
15528 case FFELEX_typeNAME:
15529 ffeexpr_tokens_[2] = ffelex_token_use (t);
15530 return (ffelexHandler) ffeexpr_token_name_apos_name_;
15531
15532 default:
15533 break;
15534 }
15535
15536 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
15537 {
15538 ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
15539 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15540 ffelex_token_where_column (ffeexpr_tokens_[0]));
15541 ffebad_here (1, ffelex_token_where_line (t),
15542 ffelex_token_where_column (t));
15543 ffebad_finish ();
15544 }
15545
15546 ffelex_token_kill (ffeexpr_tokens_[1]);
15547
15548 e = ffeexpr_expr_new_ ();
15549 e->type = FFEEXPR_exprtypeOPERAND_;
15550 e->u.operand = ffebld_new_any ();
15551 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15552 e->token = ffeexpr_tokens_[0];
15553 ffeexpr_exprstack_push_operand_ (e);
15554
15555 return (ffelexHandler) ffeexpr_token_binary_ (t);
15556 }
15557
15558 /* ffeexpr_token_name_apos_name_ -- Rhs NAME APOSTROPHE NAME
15559
15560 Return a pointer to this function to the lexer (ffelex), which will
15561 invoke it for the next token.
15562
15563 Expecting an APOSTROPHE token, analyze the previous NAME token to see
15564 what kind, if any, typeless constant we've got. */
15565
15566 static ffelexHandler
15567 ffeexpr_token_name_apos_name_ (ffelexToken t)
15568 {
15569 ffeexprExpr_ e;
15570 char c;
15571
15572 e = ffeexpr_expr_new_ ();
15573 e->type = FFEEXPR_exprtypeOPERAND_;
15574 e->token = ffeexpr_tokens_[0];
15575
15576 if ((ffelex_token_type (t) == ffelex_token_type (ffeexpr_tokens_[1]))
15577 && (ffelex_token_length (ffeexpr_tokens_[0]) == 1)
15578 && (ffesrc_char_match_init ((c = ffelex_token_text (ffeexpr_tokens_[0])[0]),
15579 'B', 'b')
15580 || ffesrc_char_match_init (c, 'O', 'o')
15581 || ffesrc_char_match_init (c, 'X', 'x')
15582 || ffesrc_char_match_init (c, 'Z', 'z')))
15583 {
15584 ffetargetCharacterSize size;
15585
15586 if (!ffe_is_typeless_boz ()) {
15587
15588 switch (c)
15589 {
15590 case FFESRC_CASE_MATCH_INIT ('B', 'b', imatch_b, no_imatch):
15591 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerbinary
15592 (ffeexpr_tokens_[2]));
15593 break;
15594
15595 case FFESRC_CASE_MATCH_INIT ('O', 'o', imatch_o, no_imatch):
15596 e->u.operand = ffebld_new_conter (ffebld_constant_new_integeroctal
15597 (ffeexpr_tokens_[2]));
15598 break;
15599
15600 case FFESRC_CASE_MATCH_INIT ('X', 'x', imatch_x, no_imatch):
15601 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
15602 (ffeexpr_tokens_[2]));
15603 break;
15604
15605 case FFESRC_CASE_MATCH_INIT ('Z', 'z', imatch_z, no_imatch):
15606 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
15607 (ffeexpr_tokens_[2]));
15608 break;
15609
15610 default:
15611 no_imatch: /* :::::::::::::::::::: */
15612 assert ("not BOXZ!" == NULL);
15613 abort ();
15614 }
15615
15616 ffebld_set_info (e->u.operand,
15617 ffeinfo_new (FFEINFO_basictypeINTEGER,
15618 FFEINFO_kindtypeINTEGERDEFAULT, 0,
15619 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
15620 FFETARGET_charactersizeNONE));
15621 ffeexpr_exprstack_push_operand_ (e);
15622 ffelex_token_kill (ffeexpr_tokens_[1]);
15623 ffelex_token_kill (ffeexpr_tokens_[2]);
15624 return (ffelexHandler) ffeexpr_token_binary_;
15625 }
15626
15627 switch (c)
15628 {
15629 case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
15630 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_bm
15631 (ffeexpr_tokens_[2]));
15632 size = ffetarget_size_typeless_binary (ffeexpr_tokens_[2]);
15633 break;
15634
15635 case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
15636 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_om
15637 (ffeexpr_tokens_[2]));
15638 size = ffetarget_size_typeless_octal (ffeexpr_tokens_[2]);
15639 break;
15640
15641 case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
15642 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hxm
15643 (ffeexpr_tokens_[2]));
15644 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15645 break;
15646
15647 case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
15648 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
15649 (ffeexpr_tokens_[2]));
15650 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15651 break;
15652
15653 default:
15654 no_match: /* :::::::::::::::::::: */
15655 assert ("not BOXZ!" == NULL);
15656 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
15657 (ffeexpr_tokens_[2]));
15658 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15659 break;
15660 }
15661 ffebld_set_info (e->u.operand,
15662 ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
15663 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
15664 ffeexpr_exprstack_push_operand_ (e);
15665 ffelex_token_kill (ffeexpr_tokens_[1]);
15666 ffelex_token_kill (ffeexpr_tokens_[2]);
15667 return (ffelexHandler) ffeexpr_token_binary_;
15668 }
15669
15670 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
15671 {
15672 ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
15673 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15674 ffelex_token_where_column (ffeexpr_tokens_[0]));
15675 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
15676 ffebad_finish ();
15677 }
15678
15679 ffelex_token_kill (ffeexpr_tokens_[1]);
15680 ffelex_token_kill (ffeexpr_tokens_[2]);
15681
15682 e->type = FFEEXPR_exprtypeOPERAND_;
15683 e->u.operand = ffebld_new_any ();
15684 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15685 e->token = ffeexpr_tokens_[0];
15686 ffeexpr_exprstack_push_operand_ (e);
15687
15688 switch (ffelex_token_type (t))
15689 {
15690 case FFELEX_typeAPOSTROPHE:
15691 case FFELEX_typeQUOTE:
15692 return (ffelexHandler) ffeexpr_token_binary_;
15693
15694 default:
15695 return (ffelexHandler) ffeexpr_token_binary_ (t);
15696 }
15697 }
15698
15699 /* ffeexpr_token_percent_ -- Rhs PERCENT
15700
15701 Handle a percent sign possibly followed by "LOC". If followed instead
15702 by "VAL", "REF", or "DESCR", issue an error message and substitute
15703 "LOC". If followed by something else, treat the percent sign as a
15704 spurious incorrect token and reprocess the token via _rhs_. */
15705
15706 static ffelexHandler
15707 ffeexpr_token_percent_ (ffelexToken t)
15708 {
15709 switch (ffelex_token_type (t))
15710 {
15711 case FFELEX_typeNAME:
15712 case FFELEX_typeNAMES:
15713 ffeexpr_stack_->percent = ffeexpr_percent_ (t);
15714 ffeexpr_tokens_[1] = ffelex_token_use (t);
15715 return (ffelexHandler) ffeexpr_token_percent_name_;
15716
15717 default:
15718 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
15719 {
15720 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15721 ffelex_token_where_column (ffeexpr_tokens_[0]));
15722 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
15723 ffelex_token_where_column (ffeexpr_stack_->first_token));
15724 ffebad_finish ();
15725 }
15726 ffelex_token_kill (ffeexpr_tokens_[0]);
15727 return (ffelexHandler) ffeexpr_token_rhs_ (t);
15728 }
15729 }
15730
15731 /* ffeexpr_token_percent_name_ -- Rhs PERCENT NAME
15732
15733 Make sure the token is OPEN_PAREN and prepare for the one-item list of
15734 LHS expressions. Else display an error message. */
15735
15736 static ffelexHandler
15737 ffeexpr_token_percent_name_ (ffelexToken t)
15738 {
15739 ffelexHandler nexthandler;
15740
15741 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
15742 {
15743 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
15744 {
15745 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15746 ffelex_token_where_column (ffeexpr_tokens_[0]));
15747 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
15748 ffelex_token_where_column (ffeexpr_stack_->first_token));
15749 ffebad_finish ();
15750 }
15751 ffelex_token_kill (ffeexpr_tokens_[0]);
15752 nexthandler = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_tokens_[1]);
15753 ffelex_token_kill (ffeexpr_tokens_[1]);
15754 return (ffelexHandler) (*nexthandler) (t);
15755 }
15756
15757 switch (ffeexpr_stack_->percent)
15758 {
15759 default:
15760 if (ffest_ffebad_start (FFEBAD_INVALID_PERCENT))
15761 {
15762 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15763 ffelex_token_where_column (ffeexpr_tokens_[0]));
15764 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
15765 ffebad_finish ();
15766 }
15767 ffeexpr_stack_->percent = FFEEXPR_percentLOC_;
15768 /* Fall through. */
15769 case FFEEXPR_percentLOC_:
15770 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
15771 ffelex_token_kill (ffeexpr_tokens_[1]);
15772 ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
15773 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
15774 FFEEXPR_contextLOC_,
15775 ffeexpr_cb_end_loc_);
15776 }
15777 }
15778
15779 /* ffeexpr_make_float_const_ -- Make a floating-point constant
15780
15781 See prototype.
15782
15783 Pass 'E', 'D', or 'Q' for exponent letter. */
15784
15785 static void
15786 ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
15787 ffelexToken decimal, ffelexToken fraction,
15788 ffelexToken exponent, ffelexToken exponent_sign,
15789 ffelexToken exponent_digits)
15790 {
15791 ffeexprExpr_ e;
15792
15793 e = ffeexpr_expr_new_ ();
15794 e->type = FFEEXPR_exprtypeOPERAND_;
15795 if (integer != NULL)
15796 e->token = ffelex_token_use (integer);
15797 else
15798 {
15799 assert (decimal != NULL);
15800 e->token = ffelex_token_use (decimal);
15801 }
15802
15803 switch (exp_letter)
15804 {
15805 #if !FFETARGET_okREALQUAD
15806 case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
15807 if (ffebad_start (FFEBAD_QUAD_UNSUPPORTED))
15808 {
15809 ffebad_here (0, ffelex_token_where_line (e->token),
15810 ffelex_token_where_column (e->token));
15811 ffebad_finish ();
15812 }
15813 goto match_d; /* The FFESRC_CASE_* macros don't
15814 allow fall-through! */
15815 #endif
15816
15817 case FFESRC_CASE_MATCH_INIT ('D', 'd', match_d, no_match):
15818 e->u.operand = ffebld_new_conter (ffebld_constant_new_realdouble
15819 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15820 ffebld_set_info (e->u.operand,
15821 ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
15822 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15823 break;
15824
15825 case FFESRC_CASE_MATCH_INIT ('E', 'e', match_e, no_match):
15826 e->u.operand = ffebld_new_conter (ffebld_constant_new_realdefault
15827 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15828 ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeREAL,
15829 FFEINFO_kindtypeREALDEFAULT, 0, FFEINFO_kindENTITY,
15830 FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15831 break;
15832
15833 #if FFETARGET_okREALQUAD
15834 case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
15835 e->u.operand = ffebld_new_conter (ffebld_constant_new_realquad
15836 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15837 ffebld_set_info (e->u.operand,
15838 ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALQUAD,
15839 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15840 break;
15841 #endif
15842
15843 case 'I': /* Make an integer. */
15844 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
15845 (ffeexpr_tokens_[0]));
15846 ffebld_set_info (e->u.operand,
15847 ffeinfo_new (FFEINFO_basictypeINTEGER,
15848 FFEINFO_kindtypeINTEGERDEFAULT, 0,
15849 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
15850 FFETARGET_charactersizeNONE));
15851 break;
15852
15853 default:
15854 no_match: /* :::::::::::::::::::: */
15855 assert ("Lost the exponent letter!" == NULL);
15856 }
15857
15858 ffeexpr_exprstack_push_operand_ (e);
15859 }
15860
15861 /* Just like ffesymbol_declare_local, except performs any implicit info
15862 assignment necessary. */
15863
15864 static ffesymbol
15865 ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin)
15866 {
15867 ffesymbol s;
15868 ffeinfoKind k;
15869 bool bad;
15870
15871 s = ffesymbol_declare_local (t, maybe_intrin);
15872
15873 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15874 /* Special-case these since they can involve a different concept
15875 of "state" (in the stmtfunc name space). */
15876 {
15877 case FFEEXPR_contextDATAIMPDOINDEX_:
15878 case FFEEXPR_contextDATAIMPDOCTRL_:
15879 if (ffeexpr_context_outer_ (ffeexpr_stack_)
15880 == FFEEXPR_contextDATAIMPDOINDEX_)
15881 s = ffeexpr_sym_impdoitem_ (s, t);
15882 else
15883 if (ffeexpr_stack_->is_rhs)
15884 s = ffeexpr_sym_impdoitem_ (s, t);
15885 else
15886 s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
15887 bad = (ffesymbol_kind (s) != FFEINFO_kindENTITY)
15888 || ((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
15889 && (ffesymbol_where (s) != FFEINFO_whereIMMEDIATE));
15890 if (bad && (ffesymbol_kind (s) != FFEINFO_kindANY))
15891 ffesymbol_error (s, t);
15892 return s;
15893
15894 default:
15895 break;
15896 }
15897
15898 switch ((ffesymbol_sfdummyparent (s) == NULL)
15899 ? ffesymbol_state (s)
15900 : FFESYMBOL_stateUNDERSTOOD)
15901 {
15902 case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr
15903 context. */
15904 if (!ffest_seen_first_exec ())
15905 goto seen; /* :::::::::::::::::::: */
15906 /* Fall through. */
15907 case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */
15908 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15909 {
15910 case FFEEXPR_contextSUBROUTINEREF:
15911 s = ffeexpr_sym_lhs_call_ (s, t);
15912 break;
15913
15914 case FFEEXPR_contextFILEEXTFUNC:
15915 s = ffeexpr_sym_lhs_extfunc_ (s, t);
15916 break;
15917
15918 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15919 s = ffecom_sym_exec_transition (s);
15920 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15921 goto understood; /* :::::::::::::::::::: */
15922 /* Fall through. */
15923 case FFEEXPR_contextACTUALARG_:
15924 s = ffeexpr_sym_rhs_actualarg_ (s, t);
15925 break;
15926
15927 case FFEEXPR_contextDATA:
15928 if (ffeexpr_stack_->is_rhs)
15929 s = ffeexpr_sym_rhs_let_ (s, t);
15930 else
15931 s = ffeexpr_sym_lhs_data_ (s, t);
15932 break;
15933
15934 case FFEEXPR_contextDATAIMPDOITEM_:
15935 s = ffeexpr_sym_lhs_data_ (s, t);
15936 break;
15937
15938 case FFEEXPR_contextSFUNCDEF:
15939 case FFEEXPR_contextSFUNCDEFINDEX_:
15940 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15941 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15942 s = ffecom_sym_exec_transition (s);
15943 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15944 goto understood; /* :::::::::::::::::::: */
15945 /* Fall through. */
15946 case FFEEXPR_contextLET:
15947 case FFEEXPR_contextPAREN_:
15948 case FFEEXPR_contextACTUALARGEXPR_:
15949 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15950 case FFEEXPR_contextASSIGN:
15951 case FFEEXPR_contextIOLIST:
15952 case FFEEXPR_contextIOLISTDF:
15953 case FFEEXPR_contextDO:
15954 case FFEEXPR_contextDOWHILE:
15955 case FFEEXPR_contextAGOTO:
15956 case FFEEXPR_contextCGOTO:
15957 case FFEEXPR_contextIF:
15958 case FFEEXPR_contextARITHIF:
15959 case FFEEXPR_contextFORMAT:
15960 case FFEEXPR_contextSTOP:
15961 case FFEEXPR_contextRETURN:
15962 case FFEEXPR_contextSELECTCASE:
15963 case FFEEXPR_contextCASE:
15964 case FFEEXPR_contextFILEASSOC:
15965 case FFEEXPR_contextFILEINT:
15966 case FFEEXPR_contextFILEDFINT:
15967 case FFEEXPR_contextFILELOG:
15968 case FFEEXPR_contextFILENUM:
15969 case FFEEXPR_contextFILENUMAMBIG:
15970 case FFEEXPR_contextFILECHAR:
15971 case FFEEXPR_contextFILENUMCHAR:
15972 case FFEEXPR_contextFILEDFCHAR:
15973 case FFEEXPR_contextFILEKEY:
15974 case FFEEXPR_contextFILEUNIT:
15975 case FFEEXPR_contextFILEUNIT_DF:
15976 case FFEEXPR_contextFILEUNITAMBIG:
15977 case FFEEXPR_contextFILEFORMAT:
15978 case FFEEXPR_contextFILENAMELIST:
15979 case FFEEXPR_contextFILEVXTCODE:
15980 case FFEEXPR_contextINDEX_:
15981 case FFEEXPR_contextIMPDOITEM_:
15982 case FFEEXPR_contextIMPDOITEMDF_:
15983 case FFEEXPR_contextIMPDOCTRL_:
15984 case FFEEXPR_contextLOC_:
15985 if (ffeexpr_stack_->is_rhs)
15986 s = ffeexpr_sym_rhs_let_ (s, t);
15987 else
15988 s = ffeexpr_sym_lhs_let_ (s, t);
15989 break;
15990
15991 case FFEEXPR_contextCHARACTERSIZE:
15992 case FFEEXPR_contextEQUIVALENCE:
15993 case FFEEXPR_contextINCLUDE:
15994 case FFEEXPR_contextPARAMETER:
15995 case FFEEXPR_contextDIMLIST:
15996 case FFEEXPR_contextDIMLISTCOMMON:
15997 case FFEEXPR_contextKINDTYPE:
15998 case FFEEXPR_contextINITVAL:
15999 case FFEEXPR_contextEQVINDEX_:
16000 break; /* Will turn into errors below. */
16001
16002 default:
16003 ffesymbol_error (s, t);
16004 break;
16005 }
16006 /* Fall through. */
16007 case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */
16008 understood: /* :::::::::::::::::::: */
16009 k = ffesymbol_kind (s);
16010 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16011 {
16012 case FFEEXPR_contextSUBROUTINEREF:
16013 bad = ((k != FFEINFO_kindSUBROUTINE)
16014 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
16015 || (k != FFEINFO_kindNONE)));
16016 break;
16017
16018 case FFEEXPR_contextFILEEXTFUNC:
16019 bad = (k != FFEINFO_kindFUNCTION)
16020 || (ffesymbol_where (s) != FFEINFO_whereGLOBAL);
16021 break;
16022
16023 case FFEEXPR_contextSFUNCDEFACTUALARG_:
16024 case FFEEXPR_contextACTUALARG_:
16025 switch (k)
16026 {
16027 case FFEINFO_kindENTITY:
16028 bad = FALSE;
16029 break;
16030
16031 case FFEINFO_kindFUNCTION:
16032 case FFEINFO_kindSUBROUTINE:
16033 bad
16034 = ((ffesymbol_where (s) != FFEINFO_whereGLOBAL)
16035 && (ffesymbol_where (s) != FFEINFO_whereDUMMY)
16036 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
16037 || !ffeintrin_is_actualarg (ffesymbol_specific (s))));
16038 break;
16039
16040 case FFEINFO_kindNONE:
16041 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
16042 {
16043 bad = !(ffeintrin_is_actualarg (ffesymbol_specific (s)));
16044 break;
16045 }
16046
16047 /* If state is UNDERSTOOD here, it's CHAR*(*) or attrsANY,
16048 and in the former case, attrsTYPE is set, so we
16049 see this as an error as we should, since CHAR*(*)
16050 cannot be actually referenced in a main/block data
16051 program unit. */
16052
16053 if ((ffesymbol_attrs (s) & (FFESYMBOL_attrsANY
16054 | FFESYMBOL_attrsEXTERNAL
16055 | FFESYMBOL_attrsTYPE))
16056 == FFESYMBOL_attrsEXTERNAL)
16057 bad = FALSE;
16058 else
16059 bad = TRUE;
16060 break;
16061
16062 default:
16063 bad = TRUE;
16064 break;
16065 }
16066 break;
16067
16068 case FFEEXPR_contextDATA:
16069 if (ffeexpr_stack_->is_rhs)
16070 bad = (k != FFEINFO_kindENTITY)
16071 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16072 else
16073 bad = (k != FFEINFO_kindENTITY)
16074 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
16075 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
16076 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
16077 break;
16078
16079 case FFEEXPR_contextDATAIMPDOITEM_:
16080 bad = TRUE; /* Unadorned item never valid. */
16081 break;
16082
16083 case FFEEXPR_contextSFUNCDEF:
16084 case FFEEXPR_contextSFUNCDEFINDEX_:
16085 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16086 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16087 case FFEEXPR_contextLET:
16088 case FFEEXPR_contextPAREN_:
16089 case FFEEXPR_contextACTUALARGEXPR_:
16090 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16091 case FFEEXPR_contextASSIGN:
16092 case FFEEXPR_contextIOLIST:
16093 case FFEEXPR_contextIOLISTDF:
16094 case FFEEXPR_contextDO:
16095 case FFEEXPR_contextDOWHILE:
16096 case FFEEXPR_contextAGOTO:
16097 case FFEEXPR_contextCGOTO:
16098 case FFEEXPR_contextIF:
16099 case FFEEXPR_contextARITHIF:
16100 case FFEEXPR_contextFORMAT:
16101 case FFEEXPR_contextSTOP:
16102 case FFEEXPR_contextRETURN:
16103 case FFEEXPR_contextSELECTCASE:
16104 case FFEEXPR_contextCASE:
16105 case FFEEXPR_contextFILEASSOC:
16106 case FFEEXPR_contextFILEINT:
16107 case FFEEXPR_contextFILEDFINT:
16108 case FFEEXPR_contextFILELOG:
16109 case FFEEXPR_contextFILENUM:
16110 case FFEEXPR_contextFILENUMAMBIG:
16111 case FFEEXPR_contextFILECHAR:
16112 case FFEEXPR_contextFILENUMCHAR:
16113 case FFEEXPR_contextFILEDFCHAR:
16114 case FFEEXPR_contextFILEKEY:
16115 case FFEEXPR_contextFILEUNIT:
16116 case FFEEXPR_contextFILEUNIT_DF:
16117 case FFEEXPR_contextFILEUNITAMBIG:
16118 case FFEEXPR_contextFILEFORMAT:
16119 case FFEEXPR_contextFILENAMELIST:
16120 case FFEEXPR_contextFILEVXTCODE:
16121 case FFEEXPR_contextINDEX_:
16122 case FFEEXPR_contextIMPDOITEM_:
16123 case FFEEXPR_contextIMPDOITEMDF_:
16124 case FFEEXPR_contextIMPDOCTRL_:
16125 case FFEEXPR_contextLOC_:
16126 bad = (k != FFEINFO_kindENTITY); /* This catches "SUBROUTINE
16127 X(A);EXTERNAL A;CALL
16128 Y(A);B=A", for example. */
16129 break;
16130
16131 case FFEEXPR_contextCHARACTERSIZE:
16132 case FFEEXPR_contextEQUIVALENCE:
16133 case FFEEXPR_contextPARAMETER:
16134 case FFEEXPR_contextDIMLIST:
16135 case FFEEXPR_contextDIMLISTCOMMON:
16136 case FFEEXPR_contextKINDTYPE:
16137 case FFEEXPR_contextINITVAL:
16138 case FFEEXPR_contextEQVINDEX_:
16139 bad = (k != FFEINFO_kindENTITY)
16140 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16141 break;
16142
16143 case FFEEXPR_contextINCLUDE:
16144 bad = TRUE;
16145 break;
16146
16147 default:
16148 bad = TRUE;
16149 break;
16150 }
16151 if (bad && (k != FFEINFO_kindANY))
16152 ffesymbol_error (s, t);
16153 return s;
16154
16155 case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */
16156 seen: /* :::::::::::::::::::: */
16157 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16158 {
16159 case FFEEXPR_contextPARAMETER:
16160 if (ffeexpr_stack_->is_rhs)
16161 ffesymbol_error (s, t);
16162 else
16163 s = ffeexpr_sym_lhs_parameter_ (s, t);
16164 break;
16165
16166 case FFEEXPR_contextDATA:
16167 s = ffecom_sym_exec_transition (s);
16168 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16169 goto understood; /* :::::::::::::::::::: */
16170 if (ffeexpr_stack_->is_rhs)
16171 ffesymbol_error (s, t);
16172 else
16173 s = ffeexpr_sym_lhs_data_ (s, t);
16174 goto understood; /* :::::::::::::::::::: */
16175
16176 case FFEEXPR_contextDATAIMPDOITEM_:
16177 s = ffecom_sym_exec_transition (s);
16178 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16179 goto understood; /* :::::::::::::::::::: */
16180 s = ffeexpr_sym_lhs_data_ (s, t);
16181 goto understood; /* :::::::::::::::::::: */
16182
16183 case FFEEXPR_contextEQUIVALENCE:
16184 s = ffeexpr_sym_lhs_equivalence_ (s, t);
16185 break;
16186
16187 case FFEEXPR_contextDIMLIST:
16188 s = ffeexpr_sym_rhs_dimlist_ (s, t);
16189 break;
16190
16191 case FFEEXPR_contextCHARACTERSIZE:
16192 case FFEEXPR_contextKINDTYPE:
16193 case FFEEXPR_contextDIMLISTCOMMON:
16194 case FFEEXPR_contextINITVAL:
16195 case FFEEXPR_contextEQVINDEX_:
16196 ffesymbol_error (s, t);
16197 break;
16198
16199 case FFEEXPR_contextINCLUDE:
16200 ffesymbol_error (s, t);
16201 break;
16202
16203 case FFEEXPR_contextACTUALARG_: /* E.g. I in REAL A(Y(I)). */
16204 case FFEEXPR_contextSFUNCDEFACTUALARG_:
16205 s = ffecom_sym_exec_transition (s);
16206 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16207 goto understood; /* :::::::::::::::::::: */
16208 s = ffeexpr_sym_rhs_actualarg_ (s, t);
16209 goto understood; /* :::::::::::::::::::: */
16210
16211 case FFEEXPR_contextINDEX_:
16212 case FFEEXPR_contextACTUALARGEXPR_:
16213 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16214 case FFEEXPR_contextSFUNCDEF:
16215 case FFEEXPR_contextSFUNCDEFINDEX_:
16216 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16217 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16218 assert (ffeexpr_stack_->is_rhs);
16219 s = ffecom_sym_exec_transition (s);
16220 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16221 goto understood; /* :::::::::::::::::::: */
16222 s = ffeexpr_sym_rhs_let_ (s, t);
16223 goto understood; /* :::::::::::::::::::: */
16224
16225 default:
16226 ffesymbol_error (s, t);
16227 break;
16228 }
16229 return s;
16230
16231 default:
16232 assert ("bad symbol state" == NULL);
16233 return NULL;
16234 break;
16235 }
16236 }
16237
16238 /* Have FOO in DATA (XYZ(FOO),...)/.../ or DATA (...,XYZ=FOO,BAR,BLETCH).
16239 Could be found via the "statement-function" name space (in which case
16240 it should become an iterator) or the local name space (in which case
16241 it should be either a named constant, or a variable that will have an
16242 sfunc name space sibling that should become an iterator). */
16243
16244 static ffesymbol
16245 ffeexpr_sym_impdoitem_ (ffesymbol sp, ffelexToken t)
16246 {
16247 ffesymbol s;
16248 ffesymbolAttrs sa;
16249 ffesymbolAttrs na;
16250 ffesymbolState ss;
16251 ffesymbolState ns;
16252 ffeinfoKind kind;
16253 ffeinfoWhere where;
16254
16255 ss = ffesymbol_state (sp);
16256
16257 if (ffesymbol_sfdummyparent (sp) != NULL)
16258 { /* Have symbol in sfunc name space. */
16259 switch (ss)
16260 {
16261 case FFESYMBOL_stateNONE: /* Used as iterator already. */
16262 if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
16263 ffesymbol_error (sp, t); /* Can't use dead iterator. */
16264 else
16265 { /* Can use dead iterator because we're at at
16266 least an innermore (higher-numbered) level
16267 than the iterator's outermost
16268 (lowest-numbered) level. */
16269 ffesymbol_signal_change (sp);
16270 ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
16271 ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
16272 ffesymbol_signal_unreported (sp);
16273 }
16274 break;
16275
16276 case FFESYMBOL_stateSEEN: /* Seen already in this or other
16277 implied-DO. Set symbol level
16278 number to outermost value, as that
16279 tells us we can see it as iterator
16280 at that level at the innermost. */
16281 if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
16282 {
16283 ffesymbol_signal_change (sp);
16284 ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
16285 ffesymbol_signal_unreported (sp);
16286 }
16287 break;
16288
16289 case FFESYMBOL_stateUNCERTAIN: /* Iterator. */
16290 assert (ffeexpr_level_ == ffesymbol_maxentrynum (sp));
16291 ffesymbol_error (sp, t); /* (,,,I=I,10). */
16292 break;
16293
16294 case FFESYMBOL_stateUNDERSTOOD:
16295 break; /* ANY. */
16296
16297 default:
16298 assert ("Foo Bar!!" == NULL);
16299 break;
16300 }
16301
16302 return sp;
16303 }
16304
16305 /* Got symbol in local name space, so we haven't seen it in impdo yet.
16306 First, if it is brand-new and we're in executable statements, set the
16307 attributes and exec-transition it to set state UNCERTAIN or UNDERSTOOD.
16308 Second, if it is now a constant (PARAMETER), then just return it, it
16309 can't be an implied-do iterator. If it is understood, complain if it is
16310 not a valid variable, but make the inner name space iterator anyway and
16311 return that. If it is not understood, improve understanding of the
16312 symbol accordingly, complain accordingly, in either case make the inner
16313 name space iterator and return that. */
16314
16315 sa = ffesymbol_attrs (sp);
16316
16317 if (ffesymbol_state_is_specable (ss)
16318 && ffest_seen_first_exec ())
16319 {
16320 assert (sa == FFESYMBOL_attrsetNONE);
16321 ffesymbol_signal_change (sp);
16322 ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
16323 ffesymbol_resolve_intrin (sp);
16324 if (ffeimplic_establish_symbol (sp))
16325 ffesymbol_set_attr (sp, FFESYMBOL_attrSFARG);
16326 else
16327 ffesymbol_error (sp, t);
16328
16329 /* After the exec transition, the state will either be UNCERTAIN (could
16330 be a dummy or local var) or UNDERSTOOD (local var, because this is a
16331 PROGRAM/BLOCKDATA program unit). */
16332
16333 sp = ffecom_sym_exec_transition (sp);
16334 sa = ffesymbol_attrs (sp);
16335 ss = ffesymbol_state (sp);
16336 }
16337
16338 ns = ss;
16339 kind = ffesymbol_kind (sp);
16340 where = ffesymbol_where (sp);
16341
16342 if (ss == FFESYMBOL_stateUNDERSTOOD)
16343 {
16344 if (kind != FFEINFO_kindENTITY)
16345 ffesymbol_error (sp, t);
16346 if (where == FFEINFO_whereCONSTANT)
16347 return sp;
16348 }
16349 else
16350 {
16351 /* Enhance understanding of local symbol. This used to imply exec
16352 transition, but that doesn't seem necessary, since the local symbol
16353 doesn't actually get put into an ffebld tree here -- we just learn
16354 more about it, just like when we see a local symbol's name in the
16355 dummy-arg list of a statement function. */
16356
16357 if (ss != FFESYMBOL_stateUNCERTAIN)
16358 {
16359 /* Figure out what kind of object we've got based on previous
16360 declarations of or references to the object. */
16361
16362 ns = FFESYMBOL_stateSEEN;
16363
16364 if (sa & FFESYMBOL_attrsANY)
16365 na = sa;
16366 else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
16367 | FFESYMBOL_attrsANY
16368 | FFESYMBOL_attrsCOMMON
16369 | FFESYMBOL_attrsDUMMY
16370 | FFESYMBOL_attrsEQUIV
16371 | FFESYMBOL_attrsINIT
16372 | FFESYMBOL_attrsNAMELIST
16373 | FFESYMBOL_attrsRESULT
16374 | FFESYMBOL_attrsSAVE
16375 | FFESYMBOL_attrsSFARG
16376 | FFESYMBOL_attrsTYPE)))
16377 na = sa | FFESYMBOL_attrsSFARG;
16378 else
16379 na = FFESYMBOL_attrsetNONE;
16380 }
16381 else
16382 { /* stateUNCERTAIN. */
16383 na = sa | FFESYMBOL_attrsSFARG;
16384 ns = FFESYMBOL_stateUNDERSTOOD;
16385
16386 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16387 | FFESYMBOL_attrsADJUSTABLE
16388 | FFESYMBOL_attrsANYLEN
16389 | FFESYMBOL_attrsARRAY
16390 | FFESYMBOL_attrsDUMMY
16391 | FFESYMBOL_attrsEXTERNAL
16392 | FFESYMBOL_attrsSFARG
16393 | FFESYMBOL_attrsTYPE)));
16394
16395 if (sa & FFESYMBOL_attrsEXTERNAL)
16396 {
16397 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16398 | FFESYMBOL_attrsDUMMY
16399 | FFESYMBOL_attrsEXTERNAL
16400 | FFESYMBOL_attrsTYPE)));
16401
16402 na = FFESYMBOL_attrsetNONE;
16403 }
16404 else if (sa & FFESYMBOL_attrsDUMMY)
16405 {
16406 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16407 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16408 | FFESYMBOL_attrsEXTERNAL
16409 | FFESYMBOL_attrsTYPE)));
16410
16411 kind = FFEINFO_kindENTITY;
16412 }
16413 else if (sa & FFESYMBOL_attrsARRAY)
16414 {
16415 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16416 | FFESYMBOL_attrsADJUSTABLE
16417 | FFESYMBOL_attrsTYPE)));
16418
16419 na = FFESYMBOL_attrsetNONE;
16420 }
16421 else if (sa & FFESYMBOL_attrsSFARG)
16422 {
16423 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16424 | FFESYMBOL_attrsTYPE)));
16425
16426 ns = FFESYMBOL_stateUNCERTAIN;
16427 }
16428 else if (sa & FFESYMBOL_attrsTYPE)
16429 {
16430 assert (!(sa & (FFESYMBOL_attrsARRAY
16431 | FFESYMBOL_attrsDUMMY
16432 | FFESYMBOL_attrsEXTERNAL
16433 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16434 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16435 | FFESYMBOL_attrsADJUSTABLE
16436 | FFESYMBOL_attrsANYLEN
16437 | FFESYMBOL_attrsARRAY
16438 | FFESYMBOL_attrsDUMMY
16439 | FFESYMBOL_attrsEXTERNAL
16440 | FFESYMBOL_attrsSFARG)));
16441
16442 kind = FFEINFO_kindENTITY;
16443
16444 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16445 na = FFESYMBOL_attrsetNONE;
16446 else if (ffest_is_entry_valid ())
16447 ns = FFESYMBOL_stateUNCERTAIN; /* Could be DUMMY or LOCAL. */
16448 else
16449 where = FFEINFO_whereLOCAL;
16450 }
16451 else
16452 na = FFESYMBOL_attrsetNONE; /* Error. */
16453 }
16454
16455 /* Now see what we've got for a new object: NONE means a new error
16456 cropped up; ANY means an old error to be ignored; otherwise,
16457 everything's ok, update the object (symbol) and continue on. */
16458
16459 if (na == FFESYMBOL_attrsetNONE)
16460 ffesymbol_error (sp, t);
16461 else if (!(na & FFESYMBOL_attrsANY))
16462 {
16463 ffesymbol_signal_change (sp); /* May need to back up to previous
16464 version. */
16465 if (!ffeimplic_establish_symbol (sp))
16466 ffesymbol_error (sp, t);
16467 else
16468 {
16469 ffesymbol_set_info (sp,
16470 ffeinfo_new (ffesymbol_basictype (sp),
16471 ffesymbol_kindtype (sp),
16472 ffesymbol_rank (sp),
16473 kind,
16474 where,
16475 ffesymbol_size (sp)));
16476 ffesymbol_set_attrs (sp, na);
16477 ffesymbol_set_state (sp, ns);
16478 ffesymbol_resolve_intrin (sp);
16479 if (!ffesymbol_state_is_specable (ns))
16480 sp = ffecom_sym_learned (sp);
16481 ffesymbol_signal_unreported (sp); /* For debugging purposes. */
16482 }
16483 }
16484 }
16485
16486 /* Here we create the sfunc-name-space symbol representing what should
16487 become an iterator in this name space at this or an outermore (lower-
16488 numbered) expression level, else the implied-DO construct is in error. */
16489
16490 s = ffesymbol_declare_sfdummy (t); /* Sets maxentrynum to 0 for new obj;
16491 also sets sfa_dummy_parent to
16492 parent symbol. */
16493 assert (sp == ffesymbol_sfdummyparent (s));
16494
16495 ffesymbol_signal_change (s);
16496 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
16497 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
16498 ffesymbol_set_info (s,
16499 ffeinfo_new (FFEINFO_basictypeINTEGER,
16500 FFEINFO_kindtypeINTEGERDEFAULT,
16501 0,
16502 FFEINFO_kindENTITY,
16503 FFEINFO_whereIMMEDIATE,
16504 FFETARGET_charactersizeNONE));
16505 ffesymbol_signal_unreported (s);
16506
16507 if ((ffesymbol_basictype (sp) != FFEINFO_basictypeINTEGER)
16508 && (ffesymbol_basictype (sp) != FFEINFO_basictypeANY))
16509 ffesymbol_error (s, t);
16510
16511 return s;
16512 }
16513
16514 /* Have FOO in CALL FOO. Local name space, executable context only. */
16515
16516 static ffesymbol
16517 ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t)
16518 {
16519 ffesymbolAttrs sa;
16520 ffesymbolAttrs na;
16521 ffeinfoKind kind;
16522 ffeinfoWhere where;
16523 ffeintrinGen gen;
16524 ffeintrinSpec spec;
16525 ffeintrinImp imp;
16526 bool error = FALSE;
16527
16528 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16529 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16530
16531 na = sa = ffesymbol_attrs (s);
16532
16533 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16534 | FFESYMBOL_attrsADJUSTABLE
16535 | FFESYMBOL_attrsANYLEN
16536 | FFESYMBOL_attrsARRAY
16537 | FFESYMBOL_attrsDUMMY
16538 | FFESYMBOL_attrsEXTERNAL
16539 | FFESYMBOL_attrsSFARG
16540 | FFESYMBOL_attrsTYPE)));
16541
16542 kind = ffesymbol_kind (s);
16543 where = ffesymbol_where (s);
16544
16545 /* Figure out what kind of object we've got based on previous declarations
16546 of or references to the object. */
16547
16548 if (sa & FFESYMBOL_attrsEXTERNAL)
16549 {
16550 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16551 | FFESYMBOL_attrsDUMMY
16552 | FFESYMBOL_attrsEXTERNAL
16553 | FFESYMBOL_attrsTYPE)));
16554
16555 if (sa & FFESYMBOL_attrsTYPE)
16556 error = TRUE;
16557 else
16558 /* Not TYPE. */
16559 {
16560 kind = FFEINFO_kindSUBROUTINE;
16561
16562 if (sa & FFESYMBOL_attrsDUMMY)
16563 ; /* Not TYPE. */
16564 else if (sa & FFESYMBOL_attrsACTUALARG)
16565 ; /* Not DUMMY or TYPE. */
16566 else /* Not ACTUALARG, DUMMY, or TYPE. */
16567 where = FFEINFO_whereGLOBAL;
16568 }
16569 }
16570 else if (sa & FFESYMBOL_attrsDUMMY)
16571 {
16572 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16573 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16574 | FFESYMBOL_attrsEXTERNAL
16575 | FFESYMBOL_attrsTYPE)));
16576
16577 if (sa & FFESYMBOL_attrsTYPE)
16578 error = TRUE;
16579 else
16580 kind = FFEINFO_kindSUBROUTINE;
16581 }
16582 else if (sa & FFESYMBOL_attrsARRAY)
16583 {
16584 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16585 | FFESYMBOL_attrsADJUSTABLE
16586 | FFESYMBOL_attrsTYPE)));
16587
16588 error = TRUE;
16589 }
16590 else if (sa & FFESYMBOL_attrsSFARG)
16591 {
16592 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16593 | FFESYMBOL_attrsTYPE)));
16594
16595 error = TRUE;
16596 }
16597 else if (sa & FFESYMBOL_attrsTYPE)
16598 {
16599 assert (!(sa & (FFESYMBOL_attrsARRAY
16600 | FFESYMBOL_attrsDUMMY
16601 | FFESYMBOL_attrsEXTERNAL
16602 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16603 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16604 | FFESYMBOL_attrsADJUSTABLE
16605 | FFESYMBOL_attrsANYLEN
16606 | FFESYMBOL_attrsARRAY
16607 | FFESYMBOL_attrsDUMMY
16608 | FFESYMBOL_attrsEXTERNAL
16609 | FFESYMBOL_attrsSFARG)));
16610
16611 error = TRUE;
16612 }
16613 else if (sa == FFESYMBOL_attrsetNONE)
16614 {
16615 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16616
16617 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
16618 &gen, &spec, &imp))
16619 {
16620 ffesymbol_signal_change (s); /* May need to back up to previous
16621 version. */
16622 ffesymbol_set_generic (s, gen);
16623 ffesymbol_set_specific (s, spec);
16624 ffesymbol_set_implementation (s, imp);
16625 ffesymbol_set_info (s,
16626 ffeinfo_new (FFEINFO_basictypeNONE,
16627 FFEINFO_kindtypeNONE,
16628 0,
16629 FFEINFO_kindSUBROUTINE,
16630 FFEINFO_whereINTRINSIC,
16631 FFETARGET_charactersizeNONE));
16632 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16633 ffesymbol_resolve_intrin (s);
16634 ffesymbol_reference (s, t, FALSE);
16635 s = ffecom_sym_learned (s);
16636 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16637
16638 return s;
16639 }
16640
16641 kind = FFEINFO_kindSUBROUTINE;
16642 where = FFEINFO_whereGLOBAL;
16643 }
16644 else
16645 error = TRUE;
16646
16647 /* Now see what we've got for a new object: NONE means a new error cropped
16648 up; ANY means an old error to be ignored; otherwise, everything's ok,
16649 update the object (symbol) and continue on. */
16650
16651 if (error)
16652 ffesymbol_error (s, t);
16653 else if (!(na & FFESYMBOL_attrsANY))
16654 {
16655 ffesymbol_signal_change (s); /* May need to back up to previous
16656 version. */
16657 ffesymbol_set_info (s,
16658 ffeinfo_new (ffesymbol_basictype (s),
16659 ffesymbol_kindtype (s),
16660 ffesymbol_rank (s),
16661 kind, /* SUBROUTINE. */
16662 where, /* GLOBAL or DUMMY. */
16663 ffesymbol_size (s)));
16664 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16665 ffesymbol_resolve_intrin (s);
16666 ffesymbol_reference (s, t, FALSE);
16667 s = ffecom_sym_learned (s);
16668 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16669 }
16670
16671 return s;
16672 }
16673
16674 /* Have FOO in DATA FOO/.../. Local name space and executable context
16675 only. (This will change in the future when DATA FOO may be followed
16676 by COMMON FOO or even INTEGER FOO(10), etc.) */
16677
16678 static ffesymbol
16679 ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t)
16680 {
16681 ffesymbolAttrs sa;
16682 ffesymbolAttrs na;
16683 ffeinfoKind kind;
16684 ffeinfoWhere where;
16685 bool error = FALSE;
16686
16687 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16688 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16689
16690 na = sa = ffesymbol_attrs (s);
16691
16692 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16693 | FFESYMBOL_attrsADJUSTABLE
16694 | FFESYMBOL_attrsANYLEN
16695 | FFESYMBOL_attrsARRAY
16696 | FFESYMBOL_attrsDUMMY
16697 | FFESYMBOL_attrsEXTERNAL
16698 | FFESYMBOL_attrsSFARG
16699 | FFESYMBOL_attrsTYPE)));
16700
16701 kind = ffesymbol_kind (s);
16702 where = ffesymbol_where (s);
16703
16704 /* Figure out what kind of object we've got based on previous declarations
16705 of or references to the object. */
16706
16707 if (sa & FFESYMBOL_attrsEXTERNAL)
16708 {
16709 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16710 | FFESYMBOL_attrsDUMMY
16711 | FFESYMBOL_attrsEXTERNAL
16712 | FFESYMBOL_attrsTYPE)));
16713
16714 error = TRUE;
16715 }
16716 else if (sa & FFESYMBOL_attrsDUMMY)
16717 {
16718 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16719 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16720 | FFESYMBOL_attrsEXTERNAL
16721 | FFESYMBOL_attrsTYPE)));
16722
16723 error = TRUE;
16724 }
16725 else if (sa & FFESYMBOL_attrsARRAY)
16726 {
16727 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16728 | FFESYMBOL_attrsADJUSTABLE
16729 | FFESYMBOL_attrsTYPE)));
16730
16731 if (sa & FFESYMBOL_attrsADJUSTABLE)
16732 error = TRUE;
16733 where = FFEINFO_whereLOCAL;
16734 }
16735 else if (sa & FFESYMBOL_attrsSFARG)
16736 {
16737 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16738 | FFESYMBOL_attrsTYPE)));
16739
16740 where = FFEINFO_whereLOCAL;
16741 }
16742 else if (sa & FFESYMBOL_attrsTYPE)
16743 {
16744 assert (!(sa & (FFESYMBOL_attrsARRAY
16745 | FFESYMBOL_attrsDUMMY
16746 | FFESYMBOL_attrsEXTERNAL
16747 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16748 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16749 | FFESYMBOL_attrsADJUSTABLE
16750 | FFESYMBOL_attrsANYLEN
16751 | FFESYMBOL_attrsARRAY
16752 | FFESYMBOL_attrsDUMMY
16753 | FFESYMBOL_attrsEXTERNAL
16754 | FFESYMBOL_attrsSFARG)));
16755
16756 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16757 error = TRUE;
16758 else
16759 {
16760 kind = FFEINFO_kindENTITY;
16761 where = FFEINFO_whereLOCAL;
16762 }
16763 }
16764 else if (sa == FFESYMBOL_attrsetNONE)
16765 {
16766 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16767 kind = FFEINFO_kindENTITY;
16768 where = FFEINFO_whereLOCAL;
16769 }
16770 else
16771 error = TRUE;
16772
16773 /* Now see what we've got for a new object: NONE means a new error cropped
16774 up; ANY means an old error to be ignored; otherwise, everything's ok,
16775 update the object (symbol) and continue on. */
16776
16777 if (error)
16778 ffesymbol_error (s, t);
16779 else if (!(na & FFESYMBOL_attrsANY))
16780 {
16781 ffesymbol_signal_change (s); /* May need to back up to previous
16782 version. */
16783 if (!ffeimplic_establish_symbol (s))
16784 {
16785 ffesymbol_error (s, t);
16786 return s;
16787 }
16788 ffesymbol_set_info (s,
16789 ffeinfo_new (ffesymbol_basictype (s),
16790 ffesymbol_kindtype (s),
16791 ffesymbol_rank (s),
16792 kind, /* ENTITY. */
16793 where, /* LOCAL. */
16794 ffesymbol_size (s)));
16795 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16796 ffesymbol_resolve_intrin (s);
16797 s = ffecom_sym_learned (s);
16798 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16799 }
16800
16801 return s;
16802 }
16803
16804 /* Have FOO in EQUIVALENCE (...,FOO,...). Does not include
16805 EQUIVALENCE (...,BAR(FOO),...). */
16806
16807 static ffesymbol
16808 ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t)
16809 {
16810 ffesymbolAttrs sa;
16811 ffesymbolAttrs na;
16812 ffeinfoKind kind;
16813 ffeinfoWhere where;
16814
16815 na = sa = ffesymbol_attrs (s);
16816 kind = FFEINFO_kindENTITY;
16817 where = ffesymbol_where (s);
16818
16819 /* Figure out what kind of object we've got based on previous declarations
16820 of or references to the object. */
16821
16822 if (!(sa & ~(FFESYMBOL_attrsADJUSTS
16823 | FFESYMBOL_attrsARRAY
16824 | FFESYMBOL_attrsCOMMON
16825 | FFESYMBOL_attrsEQUIV
16826 | FFESYMBOL_attrsINIT
16827 | FFESYMBOL_attrsNAMELIST
16828 | FFESYMBOL_attrsSAVE
16829 | FFESYMBOL_attrsSFARG
16830 | FFESYMBOL_attrsTYPE)))
16831 na = sa | FFESYMBOL_attrsEQUIV;
16832 else
16833 na = FFESYMBOL_attrsetNONE;
16834
16835 /* Don't know why we're bothering to set kind and where in this code, but
16836 added the following to make it complete, in case it's really important.
16837 Generally this is left up to symbol exec transition. */
16838
16839 if (where == FFEINFO_whereNONE)
16840 {
16841 if (na & (FFESYMBOL_attrsADJUSTS
16842 | FFESYMBOL_attrsCOMMON))
16843 where = FFEINFO_whereCOMMON;
16844 else if (na & FFESYMBOL_attrsSAVE)
16845 where = FFEINFO_whereLOCAL;
16846 }
16847
16848 /* Now see what we've got for a new object: NONE means a new error cropped
16849 up; ANY means an old error to be ignored; otherwise, everything's ok,
16850 update the object (symbol) and continue on. */
16851
16852 if (na == FFESYMBOL_attrsetNONE)
16853 ffesymbol_error (s, t);
16854 else if (!(na & FFESYMBOL_attrsANY))
16855 {
16856 ffesymbol_signal_change (s); /* May need to back up to previous
16857 version. */
16858 ffesymbol_set_info (s,
16859 ffeinfo_new (ffesymbol_basictype (s),
16860 ffesymbol_kindtype (s),
16861 ffesymbol_rank (s),
16862 kind, /* Always ENTITY. */
16863 where, /* NONE, COMMON, or LOCAL. */
16864 ffesymbol_size (s)));
16865 ffesymbol_set_attrs (s, na);
16866 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
16867 ffesymbol_resolve_intrin (s);
16868 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16869 }
16870
16871 return s;
16872 }
16873
16874 /* Have FOO in OPEN(...,USEROPEN=FOO,...). Executable context only.
16875
16876 Note that I think this should be considered semantically similar to
16877 doing CALL XYZ(FOO), in that it should be considered like an
16878 ACTUALARG context. In particular, without EXTERNAL being specified,
16879 it should not be allowed. */
16880
16881 static ffesymbol
16882 ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t)
16883 {
16884 ffesymbolAttrs sa;
16885 ffesymbolAttrs na;
16886 ffeinfoKind kind;
16887 ffeinfoWhere where;
16888 bool needs_type = FALSE;
16889 bool error = FALSE;
16890
16891 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16892 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16893
16894 na = sa = ffesymbol_attrs (s);
16895
16896 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16897 | FFESYMBOL_attrsADJUSTABLE
16898 | FFESYMBOL_attrsANYLEN
16899 | FFESYMBOL_attrsARRAY
16900 | FFESYMBOL_attrsDUMMY
16901 | FFESYMBOL_attrsEXTERNAL
16902 | FFESYMBOL_attrsSFARG
16903 | FFESYMBOL_attrsTYPE)));
16904
16905 kind = ffesymbol_kind (s);
16906 where = ffesymbol_where (s);
16907
16908 /* Figure out what kind of object we've got based on previous declarations
16909 of or references to the object. */
16910
16911 if (sa & FFESYMBOL_attrsEXTERNAL)
16912 {
16913 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16914 | FFESYMBOL_attrsDUMMY
16915 | FFESYMBOL_attrsEXTERNAL
16916 | FFESYMBOL_attrsTYPE)));
16917
16918 if (sa & FFESYMBOL_attrsTYPE)
16919 where = FFEINFO_whereGLOBAL;
16920 else
16921 /* Not TYPE. */
16922 {
16923 kind = FFEINFO_kindFUNCTION;
16924 needs_type = TRUE;
16925
16926 if (sa & FFESYMBOL_attrsDUMMY)
16927 ; /* Not TYPE. */
16928 else if (sa & FFESYMBOL_attrsACTUALARG)
16929 ; /* Not DUMMY or TYPE. */
16930 else /* Not ACTUALARG, DUMMY, or TYPE. */
16931 where = FFEINFO_whereGLOBAL;
16932 }
16933 }
16934 else if (sa & FFESYMBOL_attrsDUMMY)
16935 {
16936 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16937 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16938 | FFESYMBOL_attrsEXTERNAL
16939 | FFESYMBOL_attrsTYPE)));
16940
16941 kind = FFEINFO_kindFUNCTION;
16942 if (!(sa & FFESYMBOL_attrsTYPE))
16943 needs_type = TRUE;
16944 }
16945 else if (sa & FFESYMBOL_attrsARRAY)
16946 {
16947 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16948 | FFESYMBOL_attrsADJUSTABLE
16949 | FFESYMBOL_attrsTYPE)));
16950
16951 error = TRUE;
16952 }
16953 else if (sa & FFESYMBOL_attrsSFARG)
16954 {
16955 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16956 | FFESYMBOL_attrsTYPE)));
16957
16958 error = TRUE;
16959 }
16960 else if (sa & FFESYMBOL_attrsTYPE)
16961 {
16962 assert (!(sa & (FFESYMBOL_attrsARRAY
16963 | FFESYMBOL_attrsDUMMY
16964 | FFESYMBOL_attrsEXTERNAL
16965 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16966 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16967 | FFESYMBOL_attrsADJUSTABLE
16968 | FFESYMBOL_attrsANYLEN
16969 | FFESYMBOL_attrsARRAY
16970 | FFESYMBOL_attrsDUMMY
16971 | FFESYMBOL_attrsEXTERNAL
16972 | FFESYMBOL_attrsSFARG)));
16973
16974 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16975 error = TRUE;
16976 else
16977 {
16978 kind = FFEINFO_kindFUNCTION;
16979 where = FFEINFO_whereGLOBAL;
16980 }
16981 }
16982 else if (sa == FFESYMBOL_attrsetNONE)
16983 {
16984 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16985 kind = FFEINFO_kindFUNCTION;
16986 where = FFEINFO_whereGLOBAL;
16987 needs_type = TRUE;
16988 }
16989 else
16990 error = TRUE;
16991
16992 /* Now see what we've got for a new object: NONE means a new error cropped
16993 up; ANY means an old error to be ignored; otherwise, everything's ok,
16994 update the object (symbol) and continue on. */
16995
16996 if (error)
16997 ffesymbol_error (s, t);
16998 else if (!(na & FFESYMBOL_attrsANY))
16999 {
17000 ffesymbol_signal_change (s); /* May need to back up to previous
17001 version. */
17002 if (needs_type && !ffeimplic_establish_symbol (s))
17003 {
17004 ffesymbol_error (s, t);
17005 return s;
17006 }
17007 if (!ffesymbol_explicitwhere (s))
17008 {
17009 ffebad_start (FFEBAD_NEED_EXTERNAL);
17010 ffebad_here (0, ffelex_token_where_line (t),
17011 ffelex_token_where_column (t));
17012 ffebad_string (ffesymbol_text (s));
17013 ffebad_finish ();
17014 ffesymbol_set_explicitwhere (s, TRUE);
17015 }
17016 ffesymbol_set_info (s,
17017 ffeinfo_new (ffesymbol_basictype (s),
17018 ffesymbol_kindtype (s),
17019 ffesymbol_rank (s),
17020 kind, /* FUNCTION. */
17021 where, /* GLOBAL or DUMMY. */
17022 ffesymbol_size (s)));
17023 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17024 ffesymbol_resolve_intrin (s);
17025 ffesymbol_reference (s, t, FALSE);
17026 s = ffecom_sym_learned (s);
17027 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17028 }
17029
17030 return s;
17031 }
17032
17033 /* Have FOO in DATA (stuff,FOO=1,10)/.../. */
17034
17035 static ffesymbol
17036 ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t)
17037 {
17038 ffesymbolState ss;
17039
17040 /* If the symbol isn't in the sfunc name space, pretend as though we saw a
17041 reference to it already within the imp-DO construct at this level, so as
17042 to get a symbol that is in the sfunc name space. But this is an
17043 erroneous construct, and should be caught elsewhere. */
17044
17045 if (ffesymbol_sfdummyparent (s) == NULL)
17046 {
17047 s = ffeexpr_sym_impdoitem_ (s, t);
17048 if (ffesymbol_sfdummyparent (s) == NULL)
17049 { /* PARAMETER FOO...DATA (A(I),FOO=...). */
17050 ffesymbol_error (s, t);
17051 return s;
17052 }
17053 }
17054
17055 ss = ffesymbol_state (s);
17056
17057 switch (ss)
17058 {
17059 case FFESYMBOL_stateNONE: /* Used as iterator already. */
17060 if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
17061 ffesymbol_error (s, t); /* Can't reuse dead iterator. F90 disallows
17062 this; F77 allows it but it is a stupid
17063 feature. */
17064 else
17065 { /* Can use dead iterator because we're at at
17066 least a innermore (higher-numbered) level
17067 than the iterator's outermost
17068 (lowest-numbered) level. This should be
17069 diagnosed later, because it means an item
17070 in this list didn't reference this
17071 iterator. */
17072 #if 1
17073 ffesymbol_error (s, t); /* For now, complain. */
17074 #else /* Someday will detect all cases where initializer doesn't reference
17075 all applicable iterators, in which case reenable this code. */
17076 ffesymbol_signal_change (s);
17077 ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
17078 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
17079 ffesymbol_signal_unreported (s);
17080 #endif
17081 }
17082 break;
17083
17084 case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO.
17085 If seen in outermore level, can't be an
17086 iterator here, so complain. If not seen
17087 at current level, complain for now,
17088 because that indicates something F90
17089 rejects (though we currently don't detect
17090 all such cases for now). */
17091 if (ffeexpr_level_ <= ffesymbol_maxentrynum (s))
17092 {
17093 ffesymbol_signal_change (s);
17094 ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
17095 ffesymbol_signal_unreported (s);
17096 }
17097 else
17098 ffesymbol_error (s, t);
17099 break;
17100
17101 case FFESYMBOL_stateUNCERTAIN: /* Already iterator! */
17102 assert ("DATA implied-DO control var seen twice!!" == NULL);
17103 ffesymbol_error (s, t);
17104 break;
17105
17106 case FFESYMBOL_stateUNDERSTOOD:
17107 break; /* ANY. */
17108
17109 default:
17110 assert ("Foo Bletch!!" == NULL);
17111 break;
17112 }
17113
17114 return s;
17115 }
17116
17117 /* Have FOO in PARAMETER (FOO=...). */
17118
17119 static ffesymbol
17120 ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t)
17121 {
17122 ffesymbolAttrs sa;
17123
17124 sa = ffesymbol_attrs (s);
17125
17126 /* Figure out what kind of object we've got based on previous declarations
17127 of or references to the object. */
17128
17129 if (sa & ~(FFESYMBOL_attrsANYLEN
17130 | FFESYMBOL_attrsTYPE))
17131 {
17132 if (!(sa & FFESYMBOL_attrsANY))
17133 ffesymbol_error (s, t);
17134 }
17135 else
17136 {
17137 ffesymbol_signal_change (s); /* May need to back up to previous
17138 version. */
17139 if (!ffeimplic_establish_symbol (s))
17140 {
17141 ffesymbol_error (s, t);
17142 return s;
17143 }
17144 ffesymbol_set_info (s,
17145 ffeinfo_new (ffesymbol_basictype (s),
17146 ffesymbol_kindtype (s),
17147 ffesymbol_rank (s),
17148 FFEINFO_kindENTITY,
17149 FFEINFO_whereCONSTANT,
17150 ffesymbol_size (s)));
17151 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17152 ffesymbol_resolve_intrin (s);
17153 s = ffecom_sym_learned (s);
17154 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17155 }
17156
17157 return s;
17158 }
17159
17160 /* Have FOO in CALL XYZ(...,FOO,...). Does not include any other
17161 embedding of FOO, such as CALL XYZ((FOO)) or CALL XYZ(FOO+1). */
17162
17163 static ffesymbol
17164 ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t)
17165 {
17166 ffesymbolAttrs sa;
17167 ffesymbolAttrs na;
17168 ffeinfoKind kind;
17169 ffeinfoWhere where;
17170 ffesymbolState ns;
17171 bool needs_type = FALSE;
17172
17173 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
17174 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
17175
17176 na = sa = ffesymbol_attrs (s);
17177
17178 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17179 | FFESYMBOL_attrsADJUSTABLE
17180 | FFESYMBOL_attrsANYLEN
17181 | FFESYMBOL_attrsARRAY
17182 | FFESYMBOL_attrsDUMMY
17183 | FFESYMBOL_attrsEXTERNAL
17184 | FFESYMBOL_attrsSFARG
17185 | FFESYMBOL_attrsTYPE)));
17186
17187 kind = ffesymbol_kind (s);
17188 where = ffesymbol_where (s);
17189
17190 /* Figure out what kind of object we've got based on previous declarations
17191 of or references to the object. */
17192
17193 ns = FFESYMBOL_stateUNDERSTOOD;
17194
17195 if (sa & FFESYMBOL_attrsEXTERNAL)
17196 {
17197 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17198 | FFESYMBOL_attrsDUMMY
17199 | FFESYMBOL_attrsEXTERNAL
17200 | FFESYMBOL_attrsTYPE)));
17201
17202 if (sa & FFESYMBOL_attrsTYPE)
17203 where = FFEINFO_whereGLOBAL;
17204 else
17205 /* Not TYPE. */
17206 {
17207 ns = FFESYMBOL_stateUNCERTAIN;
17208
17209 if (sa & FFESYMBOL_attrsDUMMY)
17210 assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */
17211 else if (sa & FFESYMBOL_attrsACTUALARG)
17212 ; /* Not DUMMY or TYPE. */
17213 else
17214 /* Not ACTUALARG, DUMMY, or TYPE. */
17215 {
17216 assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */
17217 na |= FFESYMBOL_attrsACTUALARG;
17218 where = FFEINFO_whereGLOBAL;
17219 }
17220 }
17221 }
17222 else if (sa & FFESYMBOL_attrsDUMMY)
17223 {
17224 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
17225 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
17226 | FFESYMBOL_attrsEXTERNAL
17227 | FFESYMBOL_attrsTYPE)));
17228
17229 kind = FFEINFO_kindENTITY;
17230 if (!(sa & FFESYMBOL_attrsTYPE))
17231 needs_type = TRUE;
17232 }
17233 else if (sa & FFESYMBOL_attrsARRAY)
17234 {
17235 assert (!(sa & ~(FFESYMBOL_attrsARRAY
17236 | FFESYMBOL_attrsADJUSTABLE
17237 | FFESYMBOL_attrsTYPE)));
17238
17239 where = FFEINFO_whereLOCAL;
17240 }
17241 else if (sa & FFESYMBOL_attrsSFARG)
17242 {
17243 assert (!(sa & ~(FFESYMBOL_attrsSFARG
17244 | FFESYMBOL_attrsTYPE)));
17245
17246 where = FFEINFO_whereLOCAL;
17247 }
17248 else if (sa & FFESYMBOL_attrsTYPE)
17249 {
17250 assert (!(sa & (FFESYMBOL_attrsARRAY
17251 | FFESYMBOL_attrsDUMMY
17252 | FFESYMBOL_attrsEXTERNAL
17253 | FFESYMBOL_attrsSFARG))); /* Handled above. */
17254 assert (!(sa & ~(FFESYMBOL_attrsTYPE
17255 | FFESYMBOL_attrsADJUSTABLE
17256 | FFESYMBOL_attrsANYLEN
17257 | FFESYMBOL_attrsARRAY
17258 | FFESYMBOL_attrsDUMMY
17259 | FFESYMBOL_attrsEXTERNAL
17260 | FFESYMBOL_attrsSFARG)));
17261
17262 if (sa & FFESYMBOL_attrsANYLEN)
17263 ns = FFESYMBOL_stateNONE;
17264 else
17265 {
17266 kind = FFEINFO_kindENTITY;
17267 where = FFEINFO_whereLOCAL;
17268 }
17269 }
17270 else if (sa == FFESYMBOL_attrsetNONE)
17271 {
17272 /* New state is left empty because there isn't any state flag to
17273 set for this case, and it's UNDERSTOOD after all. */
17274 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
17275 kind = FFEINFO_kindENTITY;
17276 where = FFEINFO_whereLOCAL;
17277 needs_type = TRUE;
17278 }
17279 else
17280 ns = FFESYMBOL_stateNONE; /* Error. */
17281
17282 /* Now see what we've got for a new object: NONE means a new error cropped
17283 up; ANY means an old error to be ignored; otherwise, everything's ok,
17284 update the object (symbol) and continue on. */
17285
17286 if (ns == FFESYMBOL_stateNONE)
17287 ffesymbol_error (s, t);
17288 else if (!(na & FFESYMBOL_attrsANY))
17289 {
17290 ffesymbol_signal_change (s); /* May need to back up to previous
17291 version. */
17292 if (needs_type && !ffeimplic_establish_symbol (s))
17293 {
17294 ffesymbol_error (s, t);
17295 return s;
17296 }
17297 ffesymbol_set_info (s,
17298 ffeinfo_new (ffesymbol_basictype (s),
17299 ffesymbol_kindtype (s),
17300 ffesymbol_rank (s),
17301 kind,
17302 where,
17303 ffesymbol_size (s)));
17304 ffesymbol_set_attrs (s, na);
17305 ffesymbol_set_state (s, ns);
17306 s = ffecom_sym_learned (s);
17307 ffesymbol_reference (s, t, FALSE);
17308 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17309 }
17310
17311 return s;
17312 }
17313
17314 /* Have FOO in DIMENSION XYZ(FOO) or any array declarator containing
17315 a reference to FOO. */
17316
17317 static ffesymbol
17318 ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t)
17319 {
17320 ffesymbolAttrs sa;
17321 ffesymbolAttrs na;
17322 ffeinfoKind kind;
17323 ffeinfoWhere where;
17324
17325 na = sa = ffesymbol_attrs (s);
17326 kind = FFEINFO_kindENTITY;
17327 where = ffesymbol_where (s);
17328
17329 /* Figure out what kind of object we've got based on previous declarations
17330 of or references to the object. */
17331
17332 if (!(sa & ~(FFESYMBOL_attrsADJUSTS
17333 | FFESYMBOL_attrsCOMMON
17334 | FFESYMBOL_attrsDUMMY
17335 | FFESYMBOL_attrsEQUIV
17336 | FFESYMBOL_attrsINIT
17337 | FFESYMBOL_attrsNAMELIST
17338 | FFESYMBOL_attrsSFARG
17339 | FFESYMBOL_attrsARRAY
17340 | FFESYMBOL_attrsTYPE)))
17341 na = sa | FFESYMBOL_attrsADJUSTS;
17342 else
17343 na = FFESYMBOL_attrsetNONE;
17344
17345 /* Since this symbol definitely is going into an expression (the
17346 dimension-list for some dummy array, presumably), figure out WHERE if
17347 possible. */
17348
17349 if (where == FFEINFO_whereNONE)
17350 {
17351 if (na & (FFESYMBOL_attrsCOMMON
17352 | FFESYMBOL_attrsEQUIV
17353 | FFESYMBOL_attrsINIT
17354 | FFESYMBOL_attrsNAMELIST))
17355 where = FFEINFO_whereCOMMON;
17356 else if (na & FFESYMBOL_attrsDUMMY)
17357 where = FFEINFO_whereDUMMY;
17358 }
17359
17360 /* Now see what we've got for a new object: NONE means a new error cropped
17361 up; ANY means an old error to be ignored; otherwise, everything's ok,
17362 update the object (symbol) and continue on. */
17363
17364 if (na == FFESYMBOL_attrsetNONE)
17365 ffesymbol_error (s, t);
17366 else if (!(na & FFESYMBOL_attrsANY))
17367 {
17368 ffesymbol_signal_change (s); /* May need to back up to previous
17369 version. */
17370 if (!ffeimplic_establish_symbol (s))
17371 {
17372 ffesymbol_error (s, t);
17373 return s;
17374 }
17375 ffesymbol_set_info (s,
17376 ffeinfo_new (ffesymbol_basictype (s),
17377 ffesymbol_kindtype (s),
17378 ffesymbol_rank (s),
17379 kind, /* Always ENTITY. */
17380 where, /* NONE, COMMON, or DUMMY. */
17381 ffesymbol_size (s)));
17382 ffesymbol_set_attrs (s, na);
17383 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
17384 ffesymbol_resolve_intrin (s);
17385 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17386 }
17387
17388 return s;
17389 }
17390
17391 /* Have FOO in XYZ = ...FOO.... Does not include cases like FOO in
17392 XYZ = BAR(FOO), as such cases are handled elsewhere. */
17393
17394 static ffesymbol
17395 ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t)
17396 {
17397 ffesymbolAttrs sa;
17398 ffesymbolAttrs na;
17399 ffeinfoKind kind;
17400 ffeinfoWhere where;
17401 bool error = FALSE;
17402
17403 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
17404 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
17405
17406 na = sa = ffesymbol_attrs (s);
17407
17408 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17409 | FFESYMBOL_attrsADJUSTABLE
17410 | FFESYMBOL_attrsANYLEN
17411 | FFESYMBOL_attrsARRAY
17412 | FFESYMBOL_attrsDUMMY
17413 | FFESYMBOL_attrsEXTERNAL
17414 | FFESYMBOL_attrsSFARG
17415 | FFESYMBOL_attrsTYPE)));
17416
17417 kind = ffesymbol_kind (s);
17418 where = ffesymbol_where (s);
17419
17420 /* Figure out what kind of object we've got based on previous declarations
17421 of or references to the object. */
17422
17423 if (sa & FFESYMBOL_attrsEXTERNAL)
17424 {
17425 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17426 | FFESYMBOL_attrsDUMMY
17427 | FFESYMBOL_attrsEXTERNAL
17428 | FFESYMBOL_attrsTYPE)));
17429
17430 error = TRUE;
17431 }
17432 else if (sa & FFESYMBOL_attrsDUMMY)
17433 {
17434 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
17435 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
17436 | FFESYMBOL_attrsEXTERNAL
17437 | FFESYMBOL_attrsTYPE)));
17438
17439 kind = FFEINFO_kindENTITY;
17440 }
17441 else if (sa & FFESYMBOL_attrsARRAY)
17442 {
17443 assert (!(sa & ~(FFESYMBOL_attrsARRAY
17444 | FFESYMBOL_attrsADJUSTABLE
17445 | FFESYMBOL_attrsTYPE)));
17446
17447 where = FFEINFO_whereLOCAL;
17448 }
17449 else if (sa & FFESYMBOL_attrsSFARG)
17450 {
17451 assert (!(sa & ~(FFESYMBOL_attrsSFARG
17452 | FFESYMBOL_attrsTYPE)));
17453
17454 where = FFEINFO_whereLOCAL;
17455 }
17456 else if (sa & FFESYMBOL_attrsTYPE)
17457 {
17458 assert (!(sa & (FFESYMBOL_attrsARRAY
17459 | FFESYMBOL_attrsDUMMY
17460 | FFESYMBOL_attrsEXTERNAL
17461 | FFESYMBOL_attrsSFARG))); /* Handled above. */
17462 assert (!(sa & ~(FFESYMBOL_attrsTYPE
17463 | FFESYMBOL_attrsADJUSTABLE
17464 | FFESYMBOL_attrsANYLEN
17465 | FFESYMBOL_attrsARRAY
17466 | FFESYMBOL_attrsDUMMY
17467 | FFESYMBOL_attrsEXTERNAL
17468 | FFESYMBOL_attrsSFARG)));
17469
17470 if (sa & FFESYMBOL_attrsANYLEN)
17471 error = TRUE;
17472 else
17473 {
17474 kind = FFEINFO_kindENTITY;
17475 where = FFEINFO_whereLOCAL;
17476 }
17477 }
17478 else if (sa == FFESYMBOL_attrsetNONE)
17479 {
17480 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
17481 kind = FFEINFO_kindENTITY;
17482 where = FFEINFO_whereLOCAL;
17483 }
17484 else
17485 error = TRUE;
17486
17487 /* Now see what we've got for a new object: NONE means a new error cropped
17488 up; ANY means an old error to be ignored; otherwise, everything's ok,
17489 update the object (symbol) and continue on. */
17490
17491 if (error)
17492 ffesymbol_error (s, t);
17493 else if (!(na & FFESYMBOL_attrsANY))
17494 {
17495 ffesymbol_signal_change (s); /* May need to back up to previous
17496 version. */
17497 if (!ffeimplic_establish_symbol (s))
17498 {
17499 ffesymbol_error (s, t);
17500 return s;
17501 }
17502 ffesymbol_set_info (s,
17503 ffeinfo_new (ffesymbol_basictype (s),
17504 ffesymbol_kindtype (s),
17505 ffesymbol_rank (s),
17506 kind, /* ENTITY. */
17507 where, /* LOCAL. */
17508 ffesymbol_size (s)));
17509 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17510 ffesymbol_resolve_intrin (s);
17511 s = ffecom_sym_learned (s);
17512 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17513 }
17514
17515 return s;
17516 }
17517
17518 /* ffeexpr_declare_parenthesized_ -- ffesymbol wrapper for NAME(...) operand
17519
17520 ffelexToken t;
17521 bool maybe_intrin;
17522 ffeexprParenType_ paren_type;
17523 ffesymbol s;
17524 s = ffeexpr_declare_parenthesized_ (t, maybe_intrin, &paren_type);
17525
17526 Just like ffesymbol_declare_local, except performs any implicit info
17527 assignment necessary, and it returns the type of the parenthesized list
17528 (list of function args, list of array args, or substring spec). */
17529
17530 static ffesymbol
17531 ffeexpr_declare_parenthesized_ (ffelexToken t, bool maybe_intrin,
17532 ffeexprParenType_ *paren_type)
17533 {
17534 ffesymbol s;
17535 ffesymbolState st; /* Effective state. */
17536 ffeinfoKind k;
17537 bool bad;
17538
17539 if (maybe_intrin && ffesrc_check_symbol ())
17540 { /* Knock off some easy cases. */
17541 switch (ffeexpr_stack_->context)
17542 {
17543 case FFEEXPR_contextSUBROUTINEREF:
17544 case FFEEXPR_contextDATA:
17545 case FFEEXPR_contextDATAIMPDOINDEX_:
17546 case FFEEXPR_contextSFUNCDEF:
17547 case FFEEXPR_contextSFUNCDEFINDEX_:
17548 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17549 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17550 case FFEEXPR_contextLET:
17551 case FFEEXPR_contextPAREN_:
17552 case FFEEXPR_contextACTUALARGEXPR_:
17553 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17554 case FFEEXPR_contextIOLIST:
17555 case FFEEXPR_contextIOLISTDF:
17556 case FFEEXPR_contextDO:
17557 case FFEEXPR_contextDOWHILE:
17558 case FFEEXPR_contextACTUALARG_:
17559 case FFEEXPR_contextCGOTO:
17560 case FFEEXPR_contextIF:
17561 case FFEEXPR_contextARITHIF:
17562 case FFEEXPR_contextFORMAT:
17563 case FFEEXPR_contextSTOP:
17564 case FFEEXPR_contextRETURN:
17565 case FFEEXPR_contextSELECTCASE:
17566 case FFEEXPR_contextCASE:
17567 case FFEEXPR_contextFILEASSOC:
17568 case FFEEXPR_contextFILEINT:
17569 case FFEEXPR_contextFILEDFINT:
17570 case FFEEXPR_contextFILELOG:
17571 case FFEEXPR_contextFILENUM:
17572 case FFEEXPR_contextFILENUMAMBIG:
17573 case FFEEXPR_contextFILECHAR:
17574 case FFEEXPR_contextFILENUMCHAR:
17575 case FFEEXPR_contextFILEDFCHAR:
17576 case FFEEXPR_contextFILEKEY:
17577 case FFEEXPR_contextFILEUNIT:
17578 case FFEEXPR_contextFILEUNIT_DF:
17579 case FFEEXPR_contextFILEUNITAMBIG:
17580 case FFEEXPR_contextFILEFORMAT:
17581 case FFEEXPR_contextFILENAMELIST:
17582 case FFEEXPR_contextFILEVXTCODE:
17583 case FFEEXPR_contextINDEX_:
17584 case FFEEXPR_contextIMPDOITEM_:
17585 case FFEEXPR_contextIMPDOITEMDF_:
17586 case FFEEXPR_contextIMPDOCTRL_:
17587 case FFEEXPR_contextDATAIMPDOCTRL_:
17588 case FFEEXPR_contextCHARACTERSIZE:
17589 case FFEEXPR_contextPARAMETER:
17590 case FFEEXPR_contextDIMLIST:
17591 case FFEEXPR_contextDIMLISTCOMMON:
17592 case FFEEXPR_contextKINDTYPE:
17593 case FFEEXPR_contextINITVAL:
17594 case FFEEXPR_contextEQVINDEX_:
17595 break; /* These could be intrinsic invocations. */
17596
17597 case FFEEXPR_contextAGOTO:
17598 case FFEEXPR_contextFILEFORMATNML:
17599 case FFEEXPR_contextALLOCATE:
17600 case FFEEXPR_contextDEALLOCATE:
17601 case FFEEXPR_contextHEAPSTAT:
17602 case FFEEXPR_contextNULLIFY:
17603 case FFEEXPR_contextINCLUDE:
17604 case FFEEXPR_contextDATAIMPDOITEM_:
17605 case FFEEXPR_contextLOC_:
17606 case FFEEXPR_contextINDEXORACTUALARG_:
17607 case FFEEXPR_contextSFUNCDEFACTUALARG_:
17608 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
17609 case FFEEXPR_contextPARENFILENUM_:
17610 case FFEEXPR_contextPARENFILEUNIT_:
17611 maybe_intrin = FALSE;
17612 break; /* Can't be intrinsic invocation. */
17613
17614 default:
17615 assert ("blah! blah! waaauuggh!" == NULL);
17616 break;
17617 }
17618 }
17619
17620 s = ffesymbol_declare_local (t, maybe_intrin);
17621
17622 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17623 /* Special-case these since they can involve a different concept
17624 of "state" (in the stmtfunc name space). */
17625 {
17626 case FFEEXPR_contextDATAIMPDOINDEX_:
17627 case FFEEXPR_contextDATAIMPDOCTRL_:
17628 if (ffeexpr_context_outer_ (ffeexpr_stack_)
17629 == FFEEXPR_contextDATAIMPDOINDEX_)
17630 s = ffeexpr_sym_impdoitem_ (s, t);
17631 else
17632 if (ffeexpr_stack_->is_rhs)
17633 s = ffeexpr_sym_impdoitem_ (s, t);
17634 else
17635 s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
17636 if (ffesymbol_kind (s) != FFEINFO_kindANY)
17637 ffesymbol_error (s, t);
17638 return s;
17639
17640 default:
17641 break;
17642 }
17643
17644 switch ((ffesymbol_sfdummyparent (s) == NULL)
17645 ? ffesymbol_state (s)
17646 : FFESYMBOL_stateUNDERSTOOD)
17647 {
17648 case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr
17649 context. */
17650 if (!ffest_seen_first_exec ())
17651 goto seen; /* :::::::::::::::::::: */
17652 /* Fall through. */
17653 case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */
17654 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17655 {
17656 case FFEEXPR_contextSUBROUTINEREF:
17657 s = ffeexpr_sym_lhs_call_ (s, t); /* "CALL FOO"=="CALL
17658 FOO(...)". */
17659 break;
17660
17661 case FFEEXPR_contextDATA:
17662 if (ffeexpr_stack_->is_rhs)
17663 s = ffeexpr_sym_rhs_let_ (s, t);
17664 else
17665 s = ffeexpr_sym_lhs_data_ (s, t);
17666 break;
17667
17668 case FFEEXPR_contextDATAIMPDOITEM_:
17669 s = ffeexpr_sym_lhs_data_ (s, t);
17670 break;
17671
17672 case FFEEXPR_contextSFUNCDEF:
17673 case FFEEXPR_contextSFUNCDEFINDEX_:
17674 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17675 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17676 s = ffecom_sym_exec_transition (s);
17677 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17678 goto understood; /* :::::::::::::::::::: */
17679 /* Fall through. */
17680 case FFEEXPR_contextLET:
17681 case FFEEXPR_contextPAREN_:
17682 case FFEEXPR_contextACTUALARGEXPR_:
17683 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17684 case FFEEXPR_contextIOLIST:
17685 case FFEEXPR_contextIOLISTDF:
17686 case FFEEXPR_contextDO:
17687 case FFEEXPR_contextDOWHILE:
17688 case FFEEXPR_contextACTUALARG_:
17689 case FFEEXPR_contextCGOTO:
17690 case FFEEXPR_contextIF:
17691 case FFEEXPR_contextARITHIF:
17692 case FFEEXPR_contextFORMAT:
17693 case FFEEXPR_contextSTOP:
17694 case FFEEXPR_contextRETURN:
17695 case FFEEXPR_contextSELECTCASE:
17696 case FFEEXPR_contextCASE:
17697 case FFEEXPR_contextFILEASSOC:
17698 case FFEEXPR_contextFILEINT:
17699 case FFEEXPR_contextFILEDFINT:
17700 case FFEEXPR_contextFILELOG:
17701 case FFEEXPR_contextFILENUM:
17702 case FFEEXPR_contextFILENUMAMBIG:
17703 case FFEEXPR_contextFILECHAR:
17704 case FFEEXPR_contextFILENUMCHAR:
17705 case FFEEXPR_contextFILEDFCHAR:
17706 case FFEEXPR_contextFILEKEY:
17707 case FFEEXPR_contextFILEUNIT:
17708 case FFEEXPR_contextFILEUNIT_DF:
17709 case FFEEXPR_contextFILEUNITAMBIG:
17710 case FFEEXPR_contextFILEFORMAT:
17711 case FFEEXPR_contextFILENAMELIST:
17712 case FFEEXPR_contextFILEVXTCODE:
17713 case FFEEXPR_contextINDEX_:
17714 case FFEEXPR_contextIMPDOITEM_:
17715 case FFEEXPR_contextIMPDOITEMDF_:
17716 case FFEEXPR_contextIMPDOCTRL_:
17717 case FFEEXPR_contextLOC_:
17718 if (ffeexpr_stack_->is_rhs)
17719 s = ffeexpr_paren_rhs_let_ (s, t);
17720 else
17721 s = ffeexpr_paren_lhs_let_ (s, t);
17722 break;
17723
17724 case FFEEXPR_contextASSIGN:
17725 case FFEEXPR_contextAGOTO:
17726 case FFEEXPR_contextCHARACTERSIZE:
17727 case FFEEXPR_contextEQUIVALENCE:
17728 case FFEEXPR_contextINCLUDE:
17729 case FFEEXPR_contextPARAMETER:
17730 case FFEEXPR_contextDIMLIST:
17731 case FFEEXPR_contextDIMLISTCOMMON:
17732 case FFEEXPR_contextKINDTYPE:
17733 case FFEEXPR_contextINITVAL:
17734 case FFEEXPR_contextEQVINDEX_:
17735 break; /* Will turn into errors below. */
17736
17737 default:
17738 ffesymbol_error (s, t);
17739 break;
17740 }
17741 /* Fall through. */
17742 case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */
17743 understood: /* :::::::::::::::::::: */
17744
17745 /* State might have changed, update it. */
17746 st = ((ffesymbol_sfdummyparent (s) == NULL)
17747 ? ffesymbol_state (s)
17748 : FFESYMBOL_stateUNDERSTOOD);
17749
17750 k = ffesymbol_kind (s);
17751 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17752 {
17753 case FFEEXPR_contextSUBROUTINEREF:
17754 bad = ((k != FFEINFO_kindSUBROUTINE)
17755 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
17756 || (k != FFEINFO_kindNONE)));
17757 break;
17758
17759 case FFEEXPR_contextDATA:
17760 if (ffeexpr_stack_->is_rhs)
17761 bad = (k != FFEINFO_kindENTITY)
17762 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
17763 else
17764 bad = (k != FFEINFO_kindENTITY)
17765 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
17766 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
17767 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
17768 break;
17769
17770 case FFEEXPR_contextDATAIMPDOITEM_:
17771 bad = (k != FFEINFO_kindENTITY) || (ffesymbol_rank (s) == 0)
17772 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
17773 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
17774 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
17775 break;
17776
17777 case FFEEXPR_contextSFUNCDEF:
17778 case FFEEXPR_contextSFUNCDEFINDEX_:
17779 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17780 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17781 case FFEEXPR_contextLET:
17782 case FFEEXPR_contextPAREN_:
17783 case FFEEXPR_contextACTUALARGEXPR_:
17784 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17785 case FFEEXPR_contextIOLIST:
17786 case FFEEXPR_contextIOLISTDF:
17787 case FFEEXPR_contextDO:
17788 case FFEEXPR_contextDOWHILE:
17789 case FFEEXPR_contextACTUALARG_:
17790 case FFEEXPR_contextCGOTO:
17791 case FFEEXPR_contextIF:
17792 case FFEEXPR_contextARITHIF:
17793 case FFEEXPR_contextFORMAT:
17794 case FFEEXPR_contextSTOP:
17795 case FFEEXPR_contextRETURN:
17796 case FFEEXPR_contextSELECTCASE:
17797 case FFEEXPR_contextCASE:
17798 case FFEEXPR_contextFILEASSOC:
17799 case FFEEXPR_contextFILEINT:
17800 case FFEEXPR_contextFILEDFINT:
17801 case FFEEXPR_contextFILELOG:
17802 case FFEEXPR_contextFILENUM:
17803 case FFEEXPR_contextFILENUMAMBIG:
17804 case FFEEXPR_contextFILECHAR:
17805 case FFEEXPR_contextFILENUMCHAR:
17806 case FFEEXPR_contextFILEDFCHAR:
17807 case FFEEXPR_contextFILEKEY:
17808 case FFEEXPR_contextFILEUNIT:
17809 case FFEEXPR_contextFILEUNIT_DF:
17810 case FFEEXPR_contextFILEUNITAMBIG:
17811 case FFEEXPR_contextFILEFORMAT:
17812 case FFEEXPR_contextFILENAMELIST:
17813 case FFEEXPR_contextFILEVXTCODE:
17814 case FFEEXPR_contextINDEX_:
17815 case FFEEXPR_contextIMPDOITEM_:
17816 case FFEEXPR_contextIMPDOITEMDF_:
17817 case FFEEXPR_contextIMPDOCTRL_:
17818 case FFEEXPR_contextLOC_:
17819 bad = FALSE; /* Let paren-switch handle the cases. */
17820 break;
17821
17822 case FFEEXPR_contextASSIGN:
17823 case FFEEXPR_contextAGOTO:
17824 case FFEEXPR_contextCHARACTERSIZE:
17825 case FFEEXPR_contextEQUIVALENCE:
17826 case FFEEXPR_contextPARAMETER:
17827 case FFEEXPR_contextDIMLIST:
17828 case FFEEXPR_contextDIMLISTCOMMON:
17829 case FFEEXPR_contextKINDTYPE:
17830 case FFEEXPR_contextINITVAL:
17831 case FFEEXPR_contextEQVINDEX_:
17832 bad = (k != FFEINFO_kindENTITY)
17833 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
17834 break;
17835
17836 case FFEEXPR_contextINCLUDE:
17837 bad = TRUE;
17838 break;
17839
17840 default:
17841 bad = TRUE;
17842 break;
17843 }
17844
17845 switch (bad ? FFEINFO_kindANY : k)
17846 {
17847 case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */
17848 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
17849 {
17850 if (ffeexpr_context_outer_ (ffeexpr_stack_)
17851 == FFEEXPR_contextSUBROUTINEREF)
17852 *paren_type = FFEEXPR_parentypeSUBROUTINE_;
17853 else
17854 *paren_type = FFEEXPR_parentypeFUNCTION_;
17855 break;
17856 }
17857 if (st == FFESYMBOL_stateUNDERSTOOD)
17858 {
17859 bad = TRUE;
17860 *paren_type = FFEEXPR_parentypeANY_;
17861 }
17862 else
17863 *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
17864 break;
17865
17866 case FFEINFO_kindFUNCTION:
17867 *paren_type = FFEEXPR_parentypeFUNCTION_;
17868 switch (ffesymbol_where (s))
17869 {
17870 case FFEINFO_whereLOCAL:
17871 bad = TRUE; /* Attempt to recurse! */
17872 break;
17873
17874 case FFEINFO_whereCONSTANT:
17875 bad = ((ffesymbol_sfexpr (s) == NULL)
17876 || (ffebld_op (ffesymbol_sfexpr (s))
17877 == FFEBLD_opANY)); /* Attempt to recurse! */
17878 break;
17879
17880 default:
17881 break;
17882 }
17883 break;
17884
17885 case FFEINFO_kindSUBROUTINE:
17886 if ((ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
17887 || (ffeexpr_stack_->previous != NULL))
17888 {
17889 bad = TRUE;
17890 *paren_type = FFEEXPR_parentypeANY_;
17891 break;
17892 }
17893
17894 *paren_type = FFEEXPR_parentypeSUBROUTINE_;
17895 switch (ffesymbol_where (s))
17896 {
17897 case FFEINFO_whereLOCAL:
17898 case FFEINFO_whereCONSTANT:
17899 bad = TRUE; /* Attempt to recurse! */
17900 break;
17901
17902 default:
17903 break;
17904 }
17905 break;
17906
17907 case FFEINFO_kindENTITY:
17908 if (ffesymbol_rank (s) == 0)
17909 {
17910 if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
17911 *paren_type = FFEEXPR_parentypeSUBSTRING_;
17912 else
17913 {
17914 bad = TRUE;
17915 *paren_type = FFEEXPR_parentypeANY_;
17916 }
17917 }
17918 else
17919 *paren_type = FFEEXPR_parentypeARRAY_;
17920 break;
17921
17922 default:
17923 case FFEINFO_kindANY:
17924 bad = TRUE;
17925 *paren_type = FFEEXPR_parentypeANY_;
17926 break;
17927 }
17928
17929 if (bad)
17930 {
17931 if (k == FFEINFO_kindANY)
17932 ffest_shutdown ();
17933 else
17934 ffesymbol_error (s, t);
17935 }
17936
17937 return s;
17938
17939 case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */
17940 seen: /* :::::::::::::::::::: */
17941 bad = TRUE;
17942 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17943 {
17944 case FFEEXPR_contextPARAMETER:
17945 if (ffeexpr_stack_->is_rhs)
17946 ffesymbol_error (s, t);
17947 else
17948 s = ffeexpr_sym_lhs_parameter_ (s, t);
17949 break;
17950
17951 case FFEEXPR_contextDATA:
17952 s = ffecom_sym_exec_transition (s);
17953 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17954 goto understood; /* :::::::::::::::::::: */
17955 if (ffeexpr_stack_->is_rhs)
17956 ffesymbol_error (s, t);
17957 else
17958 s = ffeexpr_sym_lhs_data_ (s, t);
17959 goto understood; /* :::::::::::::::::::: */
17960
17961 case FFEEXPR_contextDATAIMPDOITEM_:
17962 s = ffecom_sym_exec_transition (s);
17963 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17964 goto understood; /* :::::::::::::::::::: */
17965 s = ffeexpr_sym_lhs_data_ (s, t);
17966 goto understood; /* :::::::::::::::::::: */
17967
17968 case FFEEXPR_contextEQUIVALENCE:
17969 s = ffeexpr_sym_lhs_equivalence_ (s, t);
17970 bad = FALSE;
17971 break;
17972
17973 case FFEEXPR_contextDIMLIST:
17974 s = ffeexpr_sym_rhs_dimlist_ (s, t);
17975 bad = FALSE;
17976 break;
17977
17978 case FFEEXPR_contextCHARACTERSIZE:
17979 case FFEEXPR_contextKINDTYPE:
17980 case FFEEXPR_contextDIMLISTCOMMON:
17981 case FFEEXPR_contextINITVAL:
17982 case FFEEXPR_contextEQVINDEX_:
17983 break;
17984
17985 case FFEEXPR_contextINCLUDE:
17986 break;
17987
17988 case FFEEXPR_contextINDEX_:
17989 case FFEEXPR_contextACTUALARGEXPR_:
17990 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17991 case FFEEXPR_contextSFUNCDEF:
17992 case FFEEXPR_contextSFUNCDEFINDEX_:
17993 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17994 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17995 assert (ffeexpr_stack_->is_rhs);
17996 s = ffecom_sym_exec_transition (s);
17997 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17998 goto understood; /* :::::::::::::::::::: */
17999 s = ffeexpr_paren_rhs_let_ (s, t);
18000 goto understood; /* :::::::::::::::::::: */
18001
18002 default:
18003 break;
18004 }
18005 k = ffesymbol_kind (s);
18006 switch (bad ? FFEINFO_kindANY : k)
18007 {
18008 case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */
18009 *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
18010 break;
18011
18012 case FFEINFO_kindFUNCTION:
18013 *paren_type = FFEEXPR_parentypeFUNCTION_;
18014 switch (ffesymbol_where (s))
18015 {
18016 case FFEINFO_whereLOCAL:
18017 bad = TRUE; /* Attempt to recurse! */
18018 break;
18019
18020 case FFEINFO_whereCONSTANT:
18021 bad = ((ffesymbol_sfexpr (s) == NULL)
18022 || (ffebld_op (ffesymbol_sfexpr (s))
18023 == FFEBLD_opANY)); /* Attempt to recurse! */
18024 break;
18025
18026 default:
18027 break;
18028 }
18029 break;
18030
18031 case FFEINFO_kindSUBROUTINE:
18032 *paren_type = FFEEXPR_parentypeANY_;
18033 bad = TRUE; /* Cannot possibly be in
18034 contextSUBROUTINEREF. */
18035 break;
18036
18037 case FFEINFO_kindENTITY:
18038 if (ffesymbol_rank (s) == 0)
18039 {
18040 if (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE)
18041 *paren_type = FFEEXPR_parentypeEQUIVALENCE_;
18042 else if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
18043 *paren_type = FFEEXPR_parentypeSUBSTRING_;
18044 else
18045 {
18046 bad = TRUE;
18047 *paren_type = FFEEXPR_parentypeANY_;
18048 }
18049 }
18050 else
18051 *paren_type = FFEEXPR_parentypeARRAY_;
18052 break;
18053
18054 default:
18055 case FFEINFO_kindANY:
18056 bad = TRUE;
18057 *paren_type = FFEEXPR_parentypeANY_;
18058 break;
18059 }
18060
18061 if (bad)
18062 {
18063 if (k == FFEINFO_kindANY)
18064 ffest_shutdown ();
18065 else
18066 ffesymbol_error (s, t);
18067 }
18068
18069 return s;
18070
18071 default:
18072 assert ("bad symbol state" == NULL);
18073 return NULL;
18074 }
18075 }
18076
18077 /* Have FOO in XYZ = ...FOO(...).... Executable context only. */
18078
18079 static ffesymbol
18080 ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t)
18081 {
18082 ffesymbolAttrs sa;
18083 ffesymbolAttrs na;
18084 ffeinfoKind kind;
18085 ffeinfoWhere where;
18086 ffeintrinGen gen;
18087 ffeintrinSpec spec;
18088 ffeintrinImp imp;
18089 bool maybe_ambig = FALSE;
18090 bool error = FALSE;
18091
18092 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
18093 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
18094
18095 na = sa = ffesymbol_attrs (s);
18096
18097 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
18098 | FFESYMBOL_attrsADJUSTABLE
18099 | FFESYMBOL_attrsANYLEN
18100 | FFESYMBOL_attrsARRAY
18101 | FFESYMBOL_attrsDUMMY
18102 | FFESYMBOL_attrsEXTERNAL
18103 | FFESYMBOL_attrsSFARG
18104 | FFESYMBOL_attrsTYPE)));
18105
18106 kind = ffesymbol_kind (s);
18107 where = ffesymbol_where (s);
18108
18109 /* Figure out what kind of object we've got based on previous declarations
18110 of or references to the object. */
18111
18112 if (sa & FFESYMBOL_attrsEXTERNAL)
18113 {
18114 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
18115 | FFESYMBOL_attrsDUMMY
18116 | FFESYMBOL_attrsEXTERNAL
18117 | FFESYMBOL_attrsTYPE)));
18118
18119 if (sa & FFESYMBOL_attrsTYPE)
18120 where = FFEINFO_whereGLOBAL;
18121 else
18122 /* Not TYPE. */
18123 {
18124 kind = FFEINFO_kindFUNCTION;
18125
18126 if (sa & FFESYMBOL_attrsDUMMY)
18127 ; /* Not TYPE. */
18128 else if (sa & FFESYMBOL_attrsACTUALARG)
18129 ; /* Not DUMMY or TYPE. */
18130 else /* Not ACTUALARG, DUMMY, or TYPE. */
18131 where = FFEINFO_whereGLOBAL;
18132 }
18133 }
18134 else if (sa & FFESYMBOL_attrsDUMMY)
18135 {
18136 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
18137 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
18138 | FFESYMBOL_attrsEXTERNAL
18139 | FFESYMBOL_attrsTYPE)));
18140
18141 kind = FFEINFO_kindFUNCTION;
18142 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure; kind
18143 could be ENTITY w/substring ref. */
18144 }
18145 else if (sa & FFESYMBOL_attrsARRAY)
18146 {
18147 assert (!(sa & ~(FFESYMBOL_attrsARRAY
18148 | FFESYMBOL_attrsADJUSTABLE
18149 | FFESYMBOL_attrsTYPE)));
18150
18151 where = FFEINFO_whereLOCAL;
18152 }
18153 else if (sa & FFESYMBOL_attrsSFARG)
18154 {
18155 assert (!(sa & ~(FFESYMBOL_attrsSFARG
18156 | FFESYMBOL_attrsTYPE)));
18157
18158 where = FFEINFO_whereLOCAL; /* Actually an error, but at least we
18159 know it's a local var. */
18160 }
18161 else if (sa & FFESYMBOL_attrsTYPE)
18162 {
18163 assert (!(sa & (FFESYMBOL_attrsARRAY
18164 | FFESYMBOL_attrsDUMMY
18165 | FFESYMBOL_attrsEXTERNAL
18166 | FFESYMBOL_attrsSFARG))); /* Handled above. */
18167 assert (!(sa & ~(FFESYMBOL_attrsTYPE
18168 | FFESYMBOL_attrsADJUSTABLE
18169 | FFESYMBOL_attrsANYLEN
18170 | FFESYMBOL_attrsARRAY
18171 | FFESYMBOL_attrsDUMMY
18172 | FFESYMBOL_attrsEXTERNAL
18173 | FFESYMBOL_attrsSFARG)));
18174
18175 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
18176 &gen, &spec, &imp))
18177 {
18178 if (!(sa & FFESYMBOL_attrsANYLEN)
18179 && (ffeimplic_peek_symbol_type (s, NULL)
18180 == FFEINFO_basictypeCHARACTER))
18181 return s; /* Haven't learned anything yet. */
18182
18183 ffesymbol_signal_change (s); /* May need to back up to previous
18184 version. */
18185 ffesymbol_set_generic (s, gen);
18186 ffesymbol_set_specific (s, spec);
18187 ffesymbol_set_implementation (s, imp);
18188 ffesymbol_set_info (s,
18189 ffeinfo_new (ffesymbol_basictype (s),
18190 ffesymbol_kindtype (s),
18191 0,
18192 FFEINFO_kindFUNCTION,
18193 FFEINFO_whereINTRINSIC,
18194 ffesymbol_size (s)));
18195 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18196 ffesymbol_resolve_intrin (s);
18197 ffesymbol_reference (s, t, FALSE);
18198 s = ffecom_sym_learned (s);
18199 ffesymbol_signal_unreported (s); /* For debugging purposes. */
18200
18201 return s;
18202 }
18203 if (sa & FFESYMBOL_attrsANYLEN)
18204 error = TRUE; /* Error, since the only way we can,
18205 given CHARACTER*(*) FOO, accept
18206 FOO(...) is for FOO to be a dummy
18207 arg or constant, but it can't
18208 become either now. */
18209 else if (sa & FFESYMBOL_attrsADJUSTABLE)
18210 {
18211 kind = FFEINFO_kindENTITY;
18212 where = FFEINFO_whereLOCAL;
18213 }
18214 else
18215 {
18216 kind = FFEINFO_kindFUNCTION;
18217 where = FFEINFO_whereGLOBAL;
18218 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure;
18219 could be ENTITY/LOCAL w/substring ref. */
18220 }
18221 }
18222 else if (sa == FFESYMBOL_attrsetNONE)
18223 {
18224 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
18225
18226 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
18227 &gen, &spec, &imp))
18228 {
18229 if (ffeimplic_peek_symbol_type (s, NULL)
18230 == FFEINFO_basictypeCHARACTER)
18231 return s; /* Haven't learned anything yet. */
18232
18233 ffesymbol_signal_change (s); /* May need to back up to previous
18234 version. */
18235 ffesymbol_set_generic (s, gen);
18236 ffesymbol_set_specific (s, spec);
18237 ffesymbol_set_implementation (s, imp);
18238 ffesymbol_set_info (s,
18239 ffeinfo_new (ffesymbol_basictype (s),
18240 ffesymbol_kindtype (s),
18241 0,
18242 FFEINFO_kindFUNCTION,
18243 FFEINFO_whereINTRINSIC,
18244 ffesymbol_size (s)));
18245 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18246 ffesymbol_resolve_intrin (s);
18247 s = ffecom_sym_learned (s);
18248 ffesymbol_reference (s, t, FALSE);
18249 ffesymbol_signal_unreported (s); /* For debugging purposes. */
18250 return s;
18251 }
18252
18253 kind = FFEINFO_kindFUNCTION;
18254 where = FFEINFO_whereGLOBAL;
18255 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure;
18256 could be ENTITY/LOCAL w/substring ref. */
18257 }
18258 else
18259 error = TRUE;
18260
18261 /* Now see what we've got for a new object: NONE means a new error cropped
18262 up; ANY means an old error to be ignored; otherwise, everything's ok,
18263 update the object (symbol) and continue on. */
18264
18265 if (error)
18266 ffesymbol_error (s, t);
18267 else if (!(na & FFESYMBOL_attrsANY))
18268 {
18269 ffesymbol_signal_change (s); /* May need to back up to previous
18270 version. */
18271 if (!ffeimplic_establish_symbol (s))
18272 {
18273 ffesymbol_error (s, t);
18274 return s;
18275 }
18276 if (maybe_ambig
18277 && (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
18278 return s; /* Still not sure, let caller deal with it
18279 based on (...). */
18280
18281 ffesymbol_set_info (s,
18282 ffeinfo_new (ffesymbol_basictype (s),
18283 ffesymbol_kindtype (s),
18284 ffesymbol_rank (s),
18285 kind,
18286 where,
18287 ffesymbol_size (s)));
18288 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18289 ffesymbol_resolve_intrin (s);
18290 s = ffecom_sym_learned (s);
18291 ffesymbol_reference (s, t, FALSE);
18292 ffesymbol_signal_unreported (s); /* For debugging purposes. */
18293 }
18294
18295 return s;
18296 }
18297
18298 /* ffeexpr_token_arguments_ -- OPEN_PAREN [expr COMMA]...expr
18299
18300 Return a pointer to this function to the lexer (ffelex), which will
18301 invoke it for the next token.
18302
18303 Handle expression (which might be null) and COMMA or CLOSE_PAREN. */
18304
18305 static ffelexHandler
18306 ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr, ffelexToken t)
18307 {
18308 ffeexprExpr_ procedure;
18309 ffebld reduced;
18310 ffeinfo info;
18311 ffeexprContext ctx;
18312 bool check_intrin = FALSE; /* Set TRUE if intrinsic is REAL(Z) or AIMAG(Z). */
18313
18314 procedure = ffeexpr_stack_->exprstack;
18315 info = ffebld_info (procedure->u.operand);
18316
18317 /* Is there an expression to add? If the expression is nil,
18318 it might still be an argument. It is if:
18319
18320 - The current token is comma, or
18321
18322 - The -fugly-comma flag was specified *and* the procedure
18323 being invoked is external.
18324
18325 Otherwise, if neither of the above is the case, just
18326 ignore this (nil) expression. */
18327
18328 if ((expr != NULL)
18329 || (ffelex_token_type (t) == FFELEX_typeCOMMA)
18330 || (ffe_is_ugly_comma ()
18331 && (ffeinfo_where (info) == FFEINFO_whereGLOBAL)))
18332 {
18333 /* This expression, even if nil, is apparently intended as an argument. */
18334
18335 /* Internal procedure (CONTAINS, or statement function)? */
18336
18337 if (ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18338 {
18339 if ((expr == NULL)
18340 && ffebad_start (FFEBAD_NULL_ARGUMENT))
18341 {
18342 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18343 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18344 ffebad_here (1, ffelex_token_where_line (t),
18345 ffelex_token_where_column (t));
18346 ffebad_finish ();
18347 }
18348
18349 if (expr == NULL)
18350 ;
18351 else
18352 {
18353 if (ffeexpr_stack_->next_dummy == NULL)
18354 { /* Report later which was the first extra argument. */
18355 if (ffeexpr_stack_->tokens[1] == NULL)
18356 {
18357 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
18358 ffeexpr_stack_->num_args = 0;
18359 }
18360 ++ffeexpr_stack_->num_args; /* Count # of extra arguments. */
18361 }
18362 else
18363 {
18364 if ((ffeinfo_rank (ffebld_info (expr)) != 0)
18365 && ffebad_start (FFEBAD_ARRAY_AS_SFARG))
18366 {
18367 ffebad_here (0,
18368 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18369 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18370 ffebad_here (1, ffelex_token_where_line (ft),
18371 ffelex_token_where_column (ft));
18372 ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent
18373 (ffebld_symter (ffebld_head
18374 (ffeexpr_stack_->next_dummy)))));
18375 ffebad_finish ();
18376 }
18377 else
18378 {
18379 expr = ffeexpr_convert_expr (expr, ft,
18380 ffebld_head (ffeexpr_stack_->next_dummy),
18381 ffeexpr_stack_->tokens[0],
18382 FFEEXPR_contextLET);
18383 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18384 }
18385 --ffeexpr_stack_->num_args; /* Count down # of args. */
18386 ffeexpr_stack_->next_dummy
18387 = ffebld_trail (ffeexpr_stack_->next_dummy);
18388 }
18389 }
18390 }
18391 else
18392 {
18393 if ((expr == NULL)
18394 && ffe_is_pedantic ()
18395 && ffebad_start (FFEBAD_NULL_ARGUMENT_W))
18396 {
18397 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18398 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18399 ffebad_here (1, ffelex_token_where_line (t),
18400 ffelex_token_where_column (t));
18401 ffebad_finish ();
18402 }
18403 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18404 }
18405 }
18406
18407 switch (ffelex_token_type (t))
18408 {
18409 case FFELEX_typeCOMMA:
18410 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
18411 {
18412 case FFEEXPR_contextSFUNCDEF:
18413 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
18414 case FFEEXPR_contextSFUNCDEFINDEX_:
18415 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
18416 ctx = FFEEXPR_contextSFUNCDEFACTUALARG_;
18417 break;
18418
18419 case FFEEXPR_contextSFUNCDEFACTUALARG_:
18420 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18421 assert ("bad context" == NULL);
18422 ctx = FFEEXPR_context;
18423 break;
18424
18425 default:
18426 ctx = FFEEXPR_contextACTUALARG_;
18427 break;
18428 }
18429 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18430 ffeexpr_token_arguments_);
18431
18432 default:
18433 break;
18434 }
18435
18436 if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18437 && (ffeexpr_stack_->next_dummy != NULL))
18438 { /* Too few arguments. */
18439 if (ffebad_start (FFEBAD_TOO_FEW_ARGUMENTS))
18440 {
18441 char num[10];
18442
18443 sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
18444
18445 ffebad_here (0, ffelex_token_where_line (t),
18446 ffelex_token_where_column (t));
18447 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18448 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18449 ffebad_string (num);
18450 ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent (ffebld_symter
18451 (ffebld_head (ffeexpr_stack_->next_dummy)))));
18452 ffebad_finish ();
18453 }
18454 for (;
18455 ffeexpr_stack_->next_dummy != NULL;
18456 ffeexpr_stack_->next_dummy
18457 = ffebld_trail (ffeexpr_stack_->next_dummy))
18458 {
18459 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0));
18460 ffebld_set_info (expr, ffeinfo_new_any ());
18461 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18462 }
18463 }
18464
18465 if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18466 && (ffeexpr_stack_->tokens[1] != NULL))
18467 { /* Too many arguments to statement function. */
18468 if (ffebad_start (FFEBAD_TOO_MANY_ARGUMENTS))
18469 {
18470 char num[10];
18471
18472 sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
18473
18474 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
18475 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
18476 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18477 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18478 ffebad_string (num);
18479 ffebad_finish ();
18480 }
18481 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
18482 }
18483 ffebld_end_list (&ffeexpr_stack_->bottom);
18484
18485 if (ffebld_op (procedure->u.operand) == FFEBLD_opANY)
18486 {
18487 reduced = ffebld_new_any ();
18488 ffebld_set_info (reduced, ffeinfo_new_any ());
18489 }
18490 else
18491 {
18492 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
18493 reduced = ffebld_new_funcref (procedure->u.operand,
18494 ffeexpr_stack_->expr);
18495 else
18496 reduced = ffebld_new_subrref (procedure->u.operand,
18497 ffeexpr_stack_->expr);
18498 if (ffebld_symter_generic (procedure->u.operand) != FFEINTRIN_genNONE)
18499 ffeintrin_fulfill_generic (&reduced, &info, ffeexpr_stack_->tokens[0]);
18500 else if (ffebld_symter_specific (procedure->u.operand)
18501 != FFEINTRIN_specNONE)
18502 ffeintrin_fulfill_specific (&reduced, &info, &check_intrin,
18503 ffeexpr_stack_->tokens[0]);
18504 else
18505 ffeexpr_fulfill_call_ (&reduced, ffeexpr_stack_->tokens[0]);
18506
18507 if (ffebld_op (reduced) != FFEBLD_opANY)
18508 ffebld_set_info (reduced,
18509 ffeinfo_new (ffeinfo_basictype (info),
18510 ffeinfo_kindtype (info),
18511 0,
18512 FFEINFO_kindENTITY,
18513 FFEINFO_whereFLEETING,
18514 ffeinfo_size (info)));
18515 else
18516 ffebld_set_info (reduced, ffeinfo_new_any ());
18517 }
18518 if (ffebld_op (reduced) == FFEBLD_opFUNCREF)
18519 reduced = ffeexpr_collapse_funcref (reduced, ffeexpr_stack_->tokens[0]);
18520 ffeexpr_stack_->exprstack = procedure->previous; /* Pops
18521 not-quite-operand off
18522 stack. */
18523 procedure->u.operand = reduced; /* Save the line/column ffewhere
18524 info. */
18525 ffeexpr_exprstack_push_operand_ (procedure); /* Push it back on stack. */
18526 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18527 {
18528 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18529 ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FUNC(3)(1:1)".... */
18530
18531 /* If the intrinsic needs checking (is REAL(Z) or AIMAG(Z), where
18532 Z is DOUBLE COMPLEX), and a command-line option doesn't already
18533 establish interpretation, probably complain. */
18534
18535 if (check_intrin
18536 && !ffe_is_90 ()
18537 && !ffe_is_ugly_complex ())
18538 {
18539 /* If the outer expression is REAL(me...), issue diagnostic
18540 only if next token isn't the close-paren for REAL(me). */
18541
18542 if ((ffeexpr_stack_->previous != NULL)
18543 && (ffeexpr_stack_->previous->exprstack != NULL)
18544 && (ffeexpr_stack_->previous->exprstack->type == FFEEXPR_exprtypeOPERAND_)
18545 && ((reduced = ffeexpr_stack_->previous->exprstack->u.operand) != NULL)
18546 && (ffebld_op (reduced) == FFEBLD_opSYMTER)
18547 && (ffebld_symter_implementation (reduced) == FFEINTRIN_impREAL))
18548 return (ffelexHandler) ffeexpr_token_intrincheck_;
18549
18550 /* Diagnose the ambiguity now. */
18551
18552 if (ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
18553 {
18554 ffebad_string (ffeintrin_name_implementation
18555 (ffebld_symter_implementation
18556 (ffebld_left
18557 (ffeexpr_stack_->exprstack->u.operand))));
18558 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
18559 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
18560 ffebad_finish ();
18561 }
18562 }
18563 return (ffelexHandler) ffeexpr_token_substrp_;
18564 }
18565
18566 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
18567 {
18568 ffebad_here (0, ffelex_token_where_line (t),
18569 ffelex_token_where_column (t));
18570 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18571 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18572 ffebad_finish ();
18573 }
18574 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18575 ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FUNC(3)(1:1)".... */
18576 return
18577 (ffelexHandler) ffeexpr_find_close_paren_ (t,
18578 (ffelexHandler)
18579 ffeexpr_token_substrp_);
18580 }
18581
18582 /* ffeexpr_token_elements_ -- OPEN_PAREN [expr COMMA]...expr
18583
18584 Return a pointer to this array to the lexer (ffelex), which will
18585 invoke it for the next token.
18586
18587 Handle expression and COMMA or CLOSE_PAREN. */
18588
18589 static ffelexHandler
18590 ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, ffelexToken t)
18591 {
18592 ffeexprExpr_ array;
18593 ffebld reduced;
18594 ffeinfo info;
18595 ffeinfoWhere where;
18596 ffetargetIntegerDefault val;
18597 ffetargetIntegerDefault lval = 0;
18598 ffetargetIntegerDefault uval = 0;
18599 ffebld lbound;
18600 ffebld ubound;
18601 bool lcheck;
18602 bool ucheck;
18603
18604 array = ffeexpr_stack_->exprstack;
18605 info = ffebld_info (array->u.operand);
18606
18607 if ((expr == NULL) /* && ((ffeexpr_stack_->rank != 0) ||
18608 (ffelex_token_type(t) ==
18609 FFELEX_typeCOMMA)) */ )
18610 {
18611 if (ffebad_start (FFEBAD_NULL_ELEMENT))
18612 {
18613 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18614 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18615 ffebad_here (1, ffelex_token_where_line (t),
18616 ffelex_token_where_column (t));
18617 ffebad_finish ();
18618 }
18619 if (ffeexpr_stack_->rank < ffeinfo_rank (info))
18620 { /* Don't bother if we're going to complain
18621 later! */
18622 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
18623 ffebld_set_info (expr, ffeinfo_new_any ());
18624 }
18625 }
18626
18627 if (expr == NULL)
18628 ;
18629 else if (ffeinfo_rank (info) == 0)
18630 { /* In EQUIVALENCE context, ffeinfo_rank(info)
18631 may == 0. */
18632 ++ffeexpr_stack_->rank; /* Track anyway, may need for new VXT
18633 feature. */
18634 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18635 }
18636 else
18637 {
18638 ++ffeexpr_stack_->rank;
18639 if (ffeexpr_stack_->rank > ffeinfo_rank (info))
18640 { /* Report later which was the first extra
18641 element. */
18642 if (ffeexpr_stack_->rank == ffeinfo_rank (info) + 1)
18643 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
18644 }
18645 else
18646 {
18647 switch (ffeinfo_where (ffebld_info (expr)))
18648 {
18649 case FFEINFO_whereCONSTANT:
18650 break;
18651
18652 case FFEINFO_whereIMMEDIATE:
18653 ffeexpr_stack_->constant = FALSE;
18654 break;
18655
18656 default:
18657 ffeexpr_stack_->constant = FALSE;
18658 ffeexpr_stack_->immediate = FALSE;
18659 break;
18660 }
18661 if (ffebld_op (expr) == FFEBLD_opCONTER
18662 && ffebld_kindtype (expr) == FFEINFO_kindtypeINTEGERDEFAULT)
18663 {
18664 val = ffebld_constant_integerdefault (ffebld_conter (expr));
18665
18666 lbound = ffebld_left (ffebld_head (ffeexpr_stack_->bound_list));
18667 if (lbound == NULL)
18668 {
18669 lcheck = TRUE;
18670 lval = 1;
18671 }
18672 else if (ffebld_op (lbound) == FFEBLD_opCONTER)
18673 {
18674 lcheck = TRUE;
18675 lval = ffebld_constant_integerdefault (ffebld_conter (lbound));
18676 }
18677 else
18678 lcheck = FALSE;
18679
18680 ubound = ffebld_right (ffebld_head (ffeexpr_stack_->bound_list));
18681 assert (ubound != NULL);
18682 if (ffebld_op (ubound) == FFEBLD_opCONTER)
18683 {
18684 ucheck = TRUE;
18685 uval = ffebld_constant_integerdefault (ffebld_conter (ubound));
18686 }
18687 else
18688 ucheck = FALSE;
18689
18690 if ((lcheck && (val < lval)) || (ucheck && (val > uval)))
18691 {
18692 ffebad_start (FFEBAD_RANGE_ARRAY);
18693 ffebad_here (0, ffelex_token_where_line (ft),
18694 ffelex_token_where_column (ft));
18695 ffebad_finish ();
18696 }
18697 }
18698 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18699 ffeexpr_stack_->bound_list = ffebld_trail (ffeexpr_stack_->bound_list);
18700 }
18701 }
18702
18703 switch (ffelex_token_type (t))
18704 {
18705 case FFELEX_typeCOMMA:
18706 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
18707 {
18708 case FFEEXPR_contextDATAIMPDOITEM_:
18709 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18710 FFEEXPR_contextDATAIMPDOINDEX_,
18711 ffeexpr_token_elements_);
18712
18713 case FFEEXPR_contextEQUIVALENCE:
18714 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18715 FFEEXPR_contextEQVINDEX_,
18716 ffeexpr_token_elements_);
18717
18718 case FFEEXPR_contextSFUNCDEF:
18719 case FFEEXPR_contextSFUNCDEFINDEX_:
18720 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18721 FFEEXPR_contextSFUNCDEFINDEX_,
18722 ffeexpr_token_elements_);
18723
18724 case FFEEXPR_contextSFUNCDEFACTUALARG_:
18725 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18726 assert ("bad context" == NULL);
18727 break;
18728
18729 default:
18730 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18731 FFEEXPR_contextINDEX_,
18732 ffeexpr_token_elements_);
18733 }
18734
18735 default:
18736 break;
18737 }
18738
18739 if ((ffeexpr_stack_->rank != ffeinfo_rank (info))
18740 && (ffeinfo_rank (info) != 0))
18741 {
18742 char num[10];
18743
18744 if (ffeexpr_stack_->rank < ffeinfo_rank (info))
18745 {
18746 if (ffebad_start (FFEBAD_TOO_FEW_ELEMENTS))
18747 {
18748 sprintf (num, "%d",
18749 (int) (ffeinfo_rank (info) - ffeexpr_stack_->rank));
18750
18751 ffebad_here (0, ffelex_token_where_line (t),
18752 ffelex_token_where_column (t));
18753 ffebad_here (1,
18754 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18755 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18756 ffebad_string (num);
18757 ffebad_finish ();
18758 }
18759 }
18760 else
18761 {
18762 if (ffebad_start (FFEBAD_TOO_MANY_ELEMENTS))
18763 {
18764 sprintf (num, "%d",
18765 (int) (ffeexpr_stack_->rank - ffeinfo_rank (info)));
18766
18767 ffebad_here (0,
18768 ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
18769 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
18770 ffebad_here (1,
18771 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18772 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18773 ffebad_string (num);
18774 ffebad_finish ();
18775 }
18776 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
18777 }
18778 while (ffeexpr_stack_->rank++ < ffeinfo_rank (info))
18779 {
18780 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
18781 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeINTEGER,
18782 FFEINFO_kindtypeINTEGERDEFAULT,
18783 0, FFEINFO_kindENTITY,
18784 FFEINFO_whereCONSTANT,
18785 FFETARGET_charactersizeNONE));
18786 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18787 }
18788 }
18789 ffebld_end_list (&ffeexpr_stack_->bottom);
18790
18791 if (ffebld_op (array->u.operand) == FFEBLD_opANY)
18792 {
18793 reduced = ffebld_new_any ();
18794 ffebld_set_info (reduced, ffeinfo_new_any ());
18795 }
18796 else
18797 {
18798 reduced = ffebld_new_arrayref (array->u.operand, ffeexpr_stack_->expr);
18799 if (ffeexpr_stack_->constant)
18800 where = FFEINFO_whereFLEETING_CADDR;
18801 else if (ffeexpr_stack_->immediate)
18802 where = FFEINFO_whereFLEETING_IADDR;
18803 else
18804 where = FFEINFO_whereFLEETING;
18805 ffebld_set_info (reduced,
18806 ffeinfo_new (ffeinfo_basictype (info),
18807 ffeinfo_kindtype (info),
18808 0,
18809 FFEINFO_kindENTITY,
18810 where,
18811 ffeinfo_size (info)));
18812 reduced = ffeexpr_collapse_arrayref (reduced, ffeexpr_stack_->tokens[0]);
18813 }
18814
18815 ffeexpr_stack_->exprstack = array->previous; /* Pops not-quite-operand off
18816 stack. */
18817 array->u.operand = reduced; /* Save the line/column ffewhere info. */
18818 ffeexpr_exprstack_push_operand_ (array); /* Push it back on stack. */
18819
18820 switch (ffeinfo_basictype (info))
18821 {
18822 case FFEINFO_basictypeCHARACTER:
18823 ffeexpr_is_substr_ok_ = TRUE; /* Everyone likes "FOO(3)(1:1)".... */
18824 break;
18825
18826 case FFEINFO_basictypeNONE:
18827 ffeexpr_is_substr_ok_ = TRUE;
18828 assert (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE);
18829 break;
18830
18831 default:
18832 ffeexpr_is_substr_ok_ = FALSE;
18833 break;
18834 }
18835
18836 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18837 {
18838 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18839 return (ffelexHandler) ffeexpr_token_substrp_;
18840 }
18841
18842 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
18843 {
18844 ffebad_here (0, ffelex_token_where_line (t),
18845 ffelex_token_where_column (t));
18846 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18847 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18848 ffebad_finish ();
18849 }
18850 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18851 return
18852 (ffelexHandler) ffeexpr_find_close_paren_ (t,
18853 (ffelexHandler)
18854 ffeexpr_token_substrp_);
18855 }
18856
18857 /* ffeexpr_token_equivalence_ -- OPEN_PAREN expr
18858
18859 Return a pointer to this array to the lexer (ffelex), which will
18860 invoke it for the next token.
18861
18862 If token is COLON, pass off to _substr_, else init list and pass off
18863 to _elements_. This handles the case "EQUIVALENCE (FOO(expr?", where
18864 ? marks the token, and where FOO's rank/type has not yet been established,
18865 meaning we could be in a list of indices or in a substring
18866 specification. */
18867
18868 static ffelexHandler
18869 ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr, ffelexToken t)
18870 {
18871 if (ffelex_token_type (t) == FFELEX_typeCOLON)
18872 return ffeexpr_token_substring_ (ft, expr, t);
18873
18874 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
18875 return ffeexpr_token_elements_ (ft, expr, t);
18876 }
18877
18878 /* ffeexpr_token_substring_ -- NAME(of kindENTITY) OPEN_PAREN expr
18879
18880 Return a pointer to this function to the lexer (ffelex), which will
18881 invoke it for the next token.
18882
18883 Handle expression (which may be null) and COLON. */
18884
18885 static ffelexHandler
18886 ffeexpr_token_substring_ (ffelexToken ft, ffebld expr, ffelexToken t)
18887 {
18888 ffeexprExpr_ string;
18889 ffeinfo info;
18890 ffetargetIntegerDefault i;
18891 ffeexprContext ctx;
18892 ffetargetCharacterSize size;
18893
18894 string = ffeexpr_stack_->exprstack;
18895 info = ffebld_info (string->u.operand);
18896 size = ffebld_size_max (string->u.operand);
18897
18898 if (ffelex_token_type (t) == FFELEX_typeCOLON)
18899 {
18900 if ((expr != NULL)
18901 && (ffebld_op (expr) == FFEBLD_opCONTER)
18902 && (((i = ffebld_constant_integerdefault (ffebld_conter (expr)))
18903 < 1)
18904 || ((size != FFETARGET_charactersizeNONE) && (i > size))))
18905 {
18906 ffebad_start (FFEBAD_RANGE_SUBSTR);
18907 ffebad_here (0, ffelex_token_where_line (ft),
18908 ffelex_token_where_column (ft));
18909 ffebad_finish ();
18910 }
18911 ffeexpr_stack_->expr = expr;
18912
18913 switch (ffeexpr_stack_->context)
18914 {
18915 case FFEEXPR_contextSFUNCDEF:
18916 case FFEEXPR_contextSFUNCDEFINDEX_:
18917 ctx = FFEEXPR_contextSFUNCDEFINDEX_;
18918 break;
18919
18920 case FFEEXPR_contextSFUNCDEFACTUALARG_:
18921 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18922 assert ("bad context" == NULL);
18923 ctx = FFEEXPR_context;
18924 break;
18925
18926 default:
18927 ctx = FFEEXPR_contextINDEX_;
18928 break;
18929 }
18930
18931 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18932 ffeexpr_token_substring_1_);
18933 }
18934
18935 if (ffest_ffebad_start (FFEBAD_MISSING_COLON_IN_SUBSTR))
18936 {
18937 ffebad_here (0, ffelex_token_where_line (t),
18938 ffelex_token_where_column (t));
18939 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18940 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18941 ffebad_finish ();
18942 }
18943
18944 ffeexpr_stack_->expr = NULL;
18945 return (ffelexHandler) ffeexpr_token_substring_1_ (ft, expr, t);
18946 }
18947
18948 /* ffeexpr_token_substring_1_ -- NAME OPEN_PAREN [expr COMMA]...expr
18949
18950 Return a pointer to this function to the lexer (ffelex), which will
18951 invoke it for the next token.
18952
18953 Handle expression (which might be null) and CLOSE_PAREN. */
18954
18955 static ffelexHandler
18956 ffeexpr_token_substring_1_ (ffelexToken ft, ffebld last, ffelexToken t)
18957 {
18958 ffeexprExpr_ string;
18959 ffebld reduced;
18960 ffebld substrlist;
18961 ffebld first = ffeexpr_stack_->expr;
18962 ffebld strop;
18963 ffeinfo info;
18964 ffeinfoWhere lwh;
18965 ffeinfoWhere rwh;
18966 ffeinfoWhere where;
18967 ffeinfoKindtype first_kt;
18968 ffeinfoKindtype last_kt;
18969 ffetargetIntegerDefault first_val;
18970 ffetargetIntegerDefault last_val;
18971 ffetargetCharacterSize size;
18972 ffetargetCharacterSize strop_size_max;
18973 bool first_known;
18974
18975 string = ffeexpr_stack_->exprstack;
18976 strop = string->u.operand;
18977 info = ffebld_info (strop);
18978
18979 if (first == NULL
18980 || (ffebld_op (first) == FFEBLD_opCONTER
18981 && ffebld_kindtype (first) == FFEINFO_kindtypeINTEGERDEFAULT))
18982 { /* The starting point is known. */
18983 first_val = (first == NULL) ? 1
18984 : ffebld_constant_integerdefault (ffebld_conter (first));
18985 first_known = TRUE;
18986 }
18987 else
18988 { /* Assume start of the entity. */
18989 first_val = 1;
18990 first_known = FALSE;
18991 }
18992
18993 if (last != NULL
18994 && (ffebld_op (last) == FFEBLD_opCONTER
18995 && ffebld_kindtype (last) == FFEINFO_kindtypeINTEGERDEFAULT))
18996 { /* The ending point is known. */
18997 last_val = ffebld_constant_integerdefault (ffebld_conter (last));
18998
18999 if (first_known)
19000 { /* The beginning point is a constant. */
19001 if (first_val <= last_val)
19002 size = last_val - first_val + 1;
19003 else
19004 {
19005 if (0 && ffe_is_90 ())
19006 size = 0;
19007 else
19008 {
19009 size = 1;
19010 ffebad_start (FFEBAD_ZERO_SIZE);
19011 ffebad_here (0, ffelex_token_where_line (ft),
19012 ffelex_token_where_column (ft));
19013 ffebad_finish ();
19014 }
19015 }
19016 }
19017 else
19018 size = FFETARGET_charactersizeNONE;
19019
19020 strop_size_max = ffebld_size_max (strop);
19021
19022 if ((strop_size_max != FFETARGET_charactersizeNONE)
19023 && (last_val > strop_size_max))
19024 { /* Beyond maximum possible end of string. */
19025 ffebad_start (FFEBAD_RANGE_SUBSTR);
19026 ffebad_here (0, ffelex_token_where_line (ft),
19027 ffelex_token_where_column (ft));
19028 ffebad_finish ();
19029 }
19030 }
19031 else
19032 size = FFETARGET_charactersizeNONE; /* The size is not known. */
19033
19034 #if 0 /* Don't do this, or "is size of target
19035 known?" would no longer be easily
19036 answerable. To see if there is a max
19037 size, use ffebld_size_max; to get only the
19038 known size, else NONE, use
19039 ffebld_size_known; use ffebld_size if
19040 values are sure to be the same (not
19041 opSUBSTR or opCONCATENATE or known to have
19042 known length). By getting rid of this
19043 "useful info" stuff, we don't end up
19044 blank-padding the constant in the
19045 assignment "A(I:J)='XYZ'" to the known
19046 length of A. */
19047 if (size == FFETARGET_charactersizeNONE)
19048 size = strop_size_max; /* Assume we use the entire string. */
19049 #endif
19050
19051 substrlist
19052 = ffebld_new_item
19053 (first,
19054 ffebld_new_item
19055 (last,
19056 NULL
19057 )
19058 )
19059 ;
19060
19061 if (first == NULL)
19062 lwh = FFEINFO_whereCONSTANT;
19063 else
19064 lwh = ffeinfo_where (ffebld_info (first));
19065 if (last == NULL)
19066 rwh = FFEINFO_whereCONSTANT;
19067 else
19068 rwh = ffeinfo_where (ffebld_info (last));
19069
19070 switch (lwh)
19071 {
19072 case FFEINFO_whereCONSTANT:
19073 switch (rwh)
19074 {
19075 case FFEINFO_whereCONSTANT:
19076 where = FFEINFO_whereCONSTANT;
19077 break;
19078
19079 case FFEINFO_whereIMMEDIATE:
19080 where = FFEINFO_whereIMMEDIATE;
19081 break;
19082
19083 default:
19084 where = FFEINFO_whereFLEETING;
19085 break;
19086 }
19087 break;
19088
19089 case FFEINFO_whereIMMEDIATE:
19090 switch (rwh)
19091 {
19092 case FFEINFO_whereCONSTANT:
19093 case FFEINFO_whereIMMEDIATE:
19094 where = FFEINFO_whereIMMEDIATE;
19095 break;
19096
19097 default:
19098 where = FFEINFO_whereFLEETING;
19099 break;
19100 }
19101 break;
19102
19103 default:
19104 where = FFEINFO_whereFLEETING;
19105 break;
19106 }
19107
19108 if (first == NULL)
19109 first_kt = FFEINFO_kindtypeINTEGERDEFAULT;
19110 else
19111 first_kt = ffeinfo_kindtype (ffebld_info (first));
19112 if (last == NULL)
19113 last_kt = FFEINFO_kindtypeINTEGERDEFAULT;
19114 else
19115 last_kt = ffeinfo_kindtype (ffebld_info (last));
19116
19117 switch (where)
19118 {
19119 case FFEINFO_whereCONSTANT:
19120 switch (ffeinfo_where (info))
19121 {
19122 case FFEINFO_whereCONSTANT:
19123 break;
19124
19125 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
19126 where = FFEINFO_whereIMMEDIATE;
19127 break;
19128
19129 default:
19130 where = FFEINFO_whereFLEETING_CADDR;
19131 break;
19132 }
19133 break;
19134
19135 case FFEINFO_whereIMMEDIATE:
19136 switch (ffeinfo_where (info))
19137 {
19138 case FFEINFO_whereCONSTANT:
19139 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
19140 break;
19141
19142 default:
19143 where = FFEINFO_whereFLEETING_IADDR;
19144 break;
19145 }
19146 break;
19147
19148 default:
19149 switch (ffeinfo_where (info))
19150 {
19151 case FFEINFO_whereCONSTANT:
19152 where = FFEINFO_whereCONSTANT_SUBOBJECT; /* An F90 concept. */
19153 break;
19154
19155 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
19156 default:
19157 where = FFEINFO_whereFLEETING;
19158 break;
19159 }
19160 break;
19161 }
19162
19163 if (ffebld_op (strop) == FFEBLD_opANY)
19164 {
19165 reduced = ffebld_new_any ();
19166 ffebld_set_info (reduced, ffeinfo_new_any ());
19167 }
19168 else
19169 {
19170 reduced = ffebld_new_substr (strop, substrlist);
19171 ffebld_set_info (reduced, ffeinfo_new
19172 (FFEINFO_basictypeCHARACTER,
19173 ffeinfo_kindtype (info),
19174 0,
19175 FFEINFO_kindENTITY,
19176 where,
19177 size));
19178 reduced = ffeexpr_collapse_substr (reduced, ffeexpr_stack_->tokens[0]);
19179 }
19180
19181 ffeexpr_stack_->exprstack = string->previous; /* Pops not-quite-operand off
19182 stack. */
19183 string->u.operand = reduced; /* Save the line/column ffewhere info. */
19184 ffeexpr_exprstack_push_operand_ (string); /* Push it back on stack. */
19185
19186 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
19187 {
19188 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19189 ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FOO(3:5)(1:1)".... */
19190 return (ffelexHandler) ffeexpr_token_substrp_;
19191 }
19192
19193 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
19194 {
19195 ffebad_here (0, ffelex_token_where_line (t),
19196 ffelex_token_where_column (t));
19197 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
19198 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
19199 ffebad_finish ();
19200 }
19201
19202 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19203 ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FOO(3:5)(1:1)".... */
19204 return
19205 (ffelexHandler) ffeexpr_find_close_paren_ (t,
19206 (ffelexHandler)
19207 ffeexpr_token_substrp_);
19208 }
19209
19210 /* ffeexpr_token_substrp_ -- Rhs <character entity>
19211
19212 Return a pointer to this function to the lexer (ffelex), which will
19213 invoke it for the next token.
19214
19215 If OPEN_PAREN, treat as start of a substring ("(3:4)") construct, and
19216 issue error message if flag (serves as argument) is set. Else, just
19217 forward token to binary_. */
19218
19219 static ffelexHandler
19220 ffeexpr_token_substrp_ (ffelexToken t)
19221 {
19222 ffeexprContext ctx;
19223
19224 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
19225 return (ffelexHandler) ffeexpr_token_binary_ (t);
19226
19227 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
19228
19229 switch (ffeexpr_stack_->context)
19230 {
19231 case FFEEXPR_contextSFUNCDEF:
19232 case FFEEXPR_contextSFUNCDEFINDEX_:
19233 ctx = FFEEXPR_contextSFUNCDEFINDEX_;
19234 break;
19235
19236 case FFEEXPR_contextSFUNCDEFACTUALARG_:
19237 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
19238 assert ("bad context" == NULL);
19239 ctx = FFEEXPR_context;
19240 break;
19241
19242 default:
19243 ctx = FFEEXPR_contextINDEX_;
19244 break;
19245 }
19246
19247 if (!ffeexpr_is_substr_ok_)
19248 {
19249 if (ffebad_start (FFEBAD_BAD_SUBSTR))
19250 {
19251 ffebad_here (0, ffelex_token_where_line (t),
19252 ffelex_token_where_column (t));
19253 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
19254 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
19255 ffebad_finish ();
19256 }
19257
19258 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
19259 ffeexpr_token_anything_);
19260 }
19261
19262 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
19263 ffeexpr_token_substring_);
19264 }
19265
19266 static ffelexHandler
19267 ffeexpr_token_intrincheck_ (ffelexToken t)
19268 {
19269 if ((ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
19270 && ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
19271 {
19272 ffebad_string (ffeintrin_name_implementation
19273 (ffebld_symter_implementation
19274 (ffebld_left
19275 (ffeexpr_stack_->exprstack->u.operand))));
19276 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
19277 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
19278 ffebad_finish ();
19279 }
19280
19281 return (ffelexHandler) ffeexpr_token_substrp_ (t);
19282 }
19283
19284 /* ffeexpr_token_funsubstr_ -- NAME OPEN_PAREN expr
19285
19286 Return a pointer to this function to the lexer (ffelex), which will
19287 invoke it for the next token.
19288
19289 If COLON, do everything we would have done since _parenthesized_ if
19290 we had known NAME represented a kindENTITY instead of a kindFUNCTION.
19291 If not COLON, do likewise for kindFUNCTION instead. */
19292
19293 static ffelexHandler
19294 ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr, ffelexToken t)
19295 {
19296 ffeinfoWhere where;
19297 ffesymbol s;
19298 ffesymbolAttrs sa;
19299 ffebld symter = ffeexpr_stack_->exprstack->u.operand;
19300 bool needs_type;
19301 ffeintrinGen gen;
19302 ffeintrinSpec spec;
19303 ffeintrinImp imp;
19304
19305 s = ffebld_symter (symter);
19306 sa = ffesymbol_attrs (s);
19307 where = ffesymbol_where (s);
19308
19309 /* We get here only if we don't already know enough about FOO when seeing a
19310 FOO(stuff) reference, and FOO might turn out to be a CHARACTER type. If
19311 "stuff" is a substring reference, then FOO is a CHARACTER scalar type.
19312 Else FOO is a function, either intrinsic or external. If intrinsic, it
19313 wouldn't necessarily be CHARACTER type, so unless it has already been
19314 declared DUMMY, it hasn't had its type established yet. It can't be
19315 CHAR*(*) in any case, though it can have an explicit CHAR*n type. */
19316
19317 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
19318 | FFESYMBOL_attrsTYPE)));
19319
19320 needs_type = !(ffesymbol_attrs (s) & FFESYMBOL_attrsDUMMY);
19321
19322 ffesymbol_signal_change (s); /* Probably already done, but in case.... */
19323
19324 if (ffelex_token_type (t) == FFELEX_typeCOLON)
19325 { /* Definitely an ENTITY (char substring). */
19326 if (needs_type && !ffeimplic_establish_symbol (s))
19327 {
19328 ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
19329 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19330 }
19331
19332 ffesymbol_set_info (s,
19333 ffeinfo_new (ffesymbol_basictype (s),
19334 ffesymbol_kindtype (s),
19335 ffesymbol_rank (s),
19336 FFEINFO_kindENTITY,
19337 (where == FFEINFO_whereNONE)
19338 ? FFEINFO_whereLOCAL
19339 : where,
19340 ffesymbol_size (s)));
19341 ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
19342
19343 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
19344 ffesymbol_resolve_intrin (s);
19345 s = ffecom_sym_learned (s);
19346 ffesymbol_signal_unreported (s); /* For debugging purposes. */
19347
19348 ffeexpr_stack_->exprstack->u.operand
19349 = ffeexpr_collapse_symter (symter, ffeexpr_tokens_[0]);
19350
19351 return (ffelexHandler) ffeexpr_token_substring_ (ft, expr, t);
19352 }
19353
19354 /* The "stuff" isn't a substring notation, so we now know the overall
19355 reference is to a function. */
19356
19357 if (ffeintrin_is_intrinsic (ffesymbol_text (s), ffeexpr_stack_->tokens[0],
19358 FALSE, &gen, &spec, &imp))
19359 {
19360 ffebld_symter_set_generic (symter, gen);
19361 ffebld_symter_set_specific (symter, spec);
19362 ffebld_symter_set_implementation (symter, imp);
19363 ffesymbol_set_generic (s, gen);
19364 ffesymbol_set_specific (s, spec);
19365 ffesymbol_set_implementation (s, imp);
19366 ffesymbol_set_info (s,
19367 ffeinfo_new (ffesymbol_basictype (s),
19368 ffesymbol_kindtype (s),
19369 0,
19370 FFEINFO_kindFUNCTION,
19371 FFEINFO_whereINTRINSIC,
19372 ffesymbol_size (s)));
19373 }
19374 else
19375 { /* Not intrinsic, now needs CHAR type. */
19376 if (!ffeimplic_establish_symbol (s))
19377 {
19378 ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
19379 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19380 }
19381
19382 ffesymbol_set_info (s,
19383 ffeinfo_new (ffesymbol_basictype (s),
19384 ffesymbol_kindtype (s),
19385 ffesymbol_rank (s),
19386 FFEINFO_kindFUNCTION,
19387 (where == FFEINFO_whereNONE)
19388 ? FFEINFO_whereGLOBAL
19389 : where,
19390 ffesymbol_size (s)));
19391 }
19392
19393 ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
19394
19395 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
19396 ffesymbol_resolve_intrin (s);
19397 s = ffecom_sym_learned (s);
19398 ffesymbol_reference (s, ffeexpr_stack_->tokens[0], FALSE);
19399 ffesymbol_signal_unreported (s); /* For debugging purposes. */
19400 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
19401 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19402 }
19403
19404 /* ffeexpr_token_anything_ -- NAME OPEN_PAREN any-expr
19405
19406 Handle basically any expression, looking for CLOSE_PAREN. */
19407
19408 static ffelexHandler
19409 ffeexpr_token_anything_ (ffelexToken ft UNUSED, ffebld expr UNUSED,
19410 ffelexToken t)
19411 {
19412 ffeexprExpr_ e = ffeexpr_stack_->exprstack;
19413
19414 switch (ffelex_token_type (t))
19415 {
19416 case FFELEX_typeCOMMA:
19417 case FFELEX_typeCOLON:
19418 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
19419 FFEEXPR_contextACTUALARG_,
19420 ffeexpr_token_anything_);
19421
19422 default:
19423 e->u.operand = ffebld_new_any ();
19424 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
19425 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19426 ffeexpr_is_substr_ok_ = FALSE;
19427 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
19428 return (ffelexHandler) ffeexpr_token_substrp_;
19429 return (ffelexHandler) ffeexpr_token_substrp_ (t);
19430 }
19431 }
19432
19433 /* Terminate module. */
19434
19435 void
19436 ffeexpr_terminate_2 ()
19437 {
19438 assert (ffeexpr_stack_ == NULL);
19439 assert (ffeexpr_level_ == 0);
19440 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org