?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Add D30V options
[official-gcc.git] / gcc / f / expr.c
blob82b9f47bc5920ccd7fedcce6c952f71ebfa0c5cd
1 /* expr.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 1997, 1998 Free Software Foundation, Inc.
3 Contributed by James Craig Burley.
4
5 This file is part of GNU Fortran.
6
7 GNU Fortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
11
12 GNU Fortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GNU Fortran; see the file COPYING. If not, write to
19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
20 02111-1307, USA.
21
22 Related Modules:
23 None.
24
25 Description:
26 Handles syntactic and semantic analysis of Fortran expressions.
27
28 Modifications:
29 */
30
31 /* Include files. */
32
33 #include "proj.h"
34 #include "expr.h"
35 #include "bad.h"
36 #include "bld.h"
37 #include "com.h"
38 #include "global.h"
39 #include "implic.h"
40 #include "intrin.h"
41 #include "info.h"
42 #include "lex.h"
43 #include "malloc.h"
44 #include "src.h"
45 #include "st.h"
46 #include "symbol.h"
47 #include "str.h"
48 #include "target.h"
49 #include "where.h"
50
51 /* Externals defined here. */
52
53
54 /* Simple definitions and enumerations. */
55
56 typedef enum
57 {
58 FFEEXPR_exprtypeUNKNOWN_,
59 FFEEXPR_exprtypeOPERAND_,
60 FFEEXPR_exprtypeUNARY_,
61 FFEEXPR_exprtypeBINARY_,
62 FFEEXPR_exprtype_
63 } ffeexprExprtype_;
64
65 typedef enum
66 {
67 FFEEXPR_operatorPOWER_,
68 FFEEXPR_operatorMULTIPLY_,
69 FFEEXPR_operatorDIVIDE_,
70 FFEEXPR_operatorADD_,
71 FFEEXPR_operatorSUBTRACT_,
72 FFEEXPR_operatorCONCATENATE_,
73 FFEEXPR_operatorLT_,
74 FFEEXPR_operatorLE_,
75 FFEEXPR_operatorEQ_,
76 FFEEXPR_operatorNE_,
77 FFEEXPR_operatorGT_,
78 FFEEXPR_operatorGE_,
79 FFEEXPR_operatorNOT_,
80 FFEEXPR_operatorAND_,
81 FFEEXPR_operatorOR_,
82 FFEEXPR_operatorXOR_,
83 FFEEXPR_operatorEQV_,
84 FFEEXPR_operatorNEQV_,
85 FFEEXPR_operator_
86 } ffeexprOperator_;
87
88 typedef enum
89 {
90 FFEEXPR_operatorprecedenceHIGHEST_ = 1,
91 FFEEXPR_operatorprecedencePOWER_ = 1,
92 FFEEXPR_operatorprecedenceMULTIPLY_ = 2,
93 FFEEXPR_operatorprecedenceDIVIDE_ = 2,
94 FFEEXPR_operatorprecedenceADD_ = 3,
95 FFEEXPR_operatorprecedenceSUBTRACT_ = 3,
96 FFEEXPR_operatorprecedenceLOWARITH_ = 3,
97 FFEEXPR_operatorprecedenceCONCATENATE_ = 3,
98 FFEEXPR_operatorprecedenceLT_ = 4,
99 FFEEXPR_operatorprecedenceLE_ = 4,
100 FFEEXPR_operatorprecedenceEQ_ = 4,
101 FFEEXPR_operatorprecedenceNE_ = 4,
102 FFEEXPR_operatorprecedenceGT_ = 4,
103 FFEEXPR_operatorprecedenceGE_ = 4,
104 FFEEXPR_operatorprecedenceNOT_ = 5,
105 FFEEXPR_operatorprecedenceAND_ = 6,
106 FFEEXPR_operatorprecedenceOR_ = 7,
107 FFEEXPR_operatorprecedenceXOR_ = 8,
108 FFEEXPR_operatorprecedenceEQV_ = 8,
109 FFEEXPR_operatorprecedenceNEQV_ = 8,
110 FFEEXPR_operatorprecedenceLOWEST_ = 8,
111 FFEEXPR_operatorprecedence_
112 } ffeexprOperatorPrecedence_;
113
114 #define FFEEXPR_operatorassociativityL2R_ TRUE
115 #define FFEEXPR_operatorassociativityR2L_ FALSE
116 #define FFEEXPR_operatorassociativityPOWER_ FFEEXPR_operatorassociativityR2L_
117 #define FFEEXPR_operatorassociativityMULTIPLY_ FFEEXPR_operatorassociativityL2R_
118 #define FFEEXPR_operatorassociativityDIVIDE_ FFEEXPR_operatorassociativityL2R_
119 #define FFEEXPR_operatorassociativityADD_ FFEEXPR_operatorassociativityL2R_
120 #define FFEEXPR_operatorassociativitySUBTRACT_ FFEEXPR_operatorassociativityL2R_
121 #define FFEEXPR_operatorassociativityCONCATENATE_ FFEEXPR_operatorassociativityL2R_
122 #define FFEEXPR_operatorassociativityLT_ FFEEXPR_operatorassociativityL2R_
123 #define FFEEXPR_operatorassociativityLE_ FFEEXPR_operatorassociativityL2R_
124 #define FFEEXPR_operatorassociativityEQ_ FFEEXPR_operatorassociativityL2R_
125 #define FFEEXPR_operatorassociativityNE_ FFEEXPR_operatorassociativityL2R_
126 #define FFEEXPR_operatorassociativityGT_ FFEEXPR_operatorassociativityL2R_
127 #define FFEEXPR_operatorassociativityGE_ FFEEXPR_operatorassociativityL2R_
128 #define FFEEXPR_operatorassociativityNOT_ FFEEXPR_operatorassociativityL2R_
129 #define FFEEXPR_operatorassociativityAND_ FFEEXPR_operatorassociativityL2R_
130 #define FFEEXPR_operatorassociativityOR_ FFEEXPR_operatorassociativityL2R_
131 #define FFEEXPR_operatorassociativityXOR_ FFEEXPR_operatorassociativityL2R_
132 #define FFEEXPR_operatorassociativityEQV_ FFEEXPR_operatorassociativityL2R_
133 #define FFEEXPR_operatorassociativityNEQV_ FFEEXPR_operatorassociativityL2R_
134
135 typedef enum
136 {
137 FFEEXPR_parentypeFUNCTION_,
138 FFEEXPR_parentypeSUBROUTINE_,
139 FFEEXPR_parentypeARRAY_,
140 FFEEXPR_parentypeSUBSTRING_,
141 FFEEXPR_parentypeFUNSUBSTR_,/* Ambig: check for colon after first expr. */
142 FFEEXPR_parentypeEQUIVALENCE_, /* Ambig: ARRAY_ or SUBSTRING_. */
143 FFEEXPR_parentypeANY_, /* Allow basically anything. */
144 FFEEXPR_parentype_
145 } ffeexprParenType_;
146
147 typedef enum
148 {
149 FFEEXPR_percentNONE_,
150 FFEEXPR_percentLOC_,
151 FFEEXPR_percentVAL_,
152 FFEEXPR_percentREF_,
153 FFEEXPR_percentDESCR_,
154 FFEEXPR_percent_
155 } ffeexprPercent_;
156
157 /* Internal typedefs. */
158
159 typedef struct _ffeexpr_expr_ *ffeexprExpr_;
160 typedef bool ffeexprOperatorAssociativity_;
161 typedef struct _ffeexpr_stack_ *ffeexprStack_;
162
163 /* Private include files. */
164
165
166 /* Internal structure definitions. */
167
168 struct _ffeexpr_expr_
169 {
170 ffeexprExpr_ previous;
171 ffelexToken token;
172 ffeexprExprtype_ type;
173 union
174 {
175 struct
176 {
177 ffeexprOperator_ op;
178 ffeexprOperatorPrecedence_ prec;
179 ffeexprOperatorAssociativity_ as;
180 }
181 operator;
182 ffebld operand;
183 }
184 u;
185 };
186
187 struct _ffeexpr_stack_
188 {
189 ffeexprStack_ previous;
190 mallocPool pool;
191 ffeexprContext context;
192 ffeexprCallback callback;
193 ffelexToken first_token;
194 ffeexprExpr_ exprstack;
195 ffelexToken tokens[10]; /* Used in certain cases, like (unary)
196 open-paren. */
197 ffebld expr; /* For first of
198 complex/implied-do/substring/array-elements
199 / actual-args expression. */
200 ffebld bound_list; /* For tracking dimension bounds list of
201 array. */
202 ffebldListBottom bottom; /* For building lists. */
203 ffeinfoRank rank; /* For elements in an array reference. */
204 bool constant; /* TRUE while elements seen so far are
205 constants. */
206 bool immediate; /* TRUE while elements seen so far are
207 immediate/constants. */
208 ffebld next_dummy; /* Next SFUNC dummy arg in arg list. */
209 ffebldListLength num_args; /* Number of dummy args expected in arg list. */
210 bool is_rhs; /* TRUE if rhs context, FALSE otherwise. */
211 ffeexprPercent_ percent; /* Current %FOO keyword. */
212 };
213
214 struct _ffeexpr_find_
215 {
216 ffelexToken t;
217 ffelexHandler after;
218 int level;
219 };
220
221 /* Static objects accessed by functions in this module. */
222
223 static ffeexprStack_ ffeexpr_stack_; /* Expression stack for semantic. */
224 static ffelexToken ffeexpr_tokens_[10]; /* Scratchpad tokens for syntactic. */
225 static ffestrOther ffeexpr_current_dotdot_; /* Current .FOO. keyword. */
226 static long ffeexpr_hollerith_count_; /* ffeexpr_token_number_ and caller. */
227 static int ffeexpr_level_; /* Level of DATA implied-DO construct. */
228 static bool ffeexpr_is_substr_ok_; /* If OPEN_PAREN as binary "op" ok. */
229 static struct _ffeexpr_find_ ffeexpr_find_;
230
231 /* Static functions (internal). */
232
233 static ffelexHandler ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr,
234 ffelexToken t);
235 static ffelexHandler ffeexpr_cb_close_paren_ambig_ (ffelexToken ft,
236 ffebld expr,
237 ffelexToken t);
238 static ffelexHandler ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t);
239 static ffelexHandler ffeexpr_cb_close_paren_c_ (ffelexToken ft,
240 ffebld expr, ffelexToken t);
241 static ffelexHandler ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr,
242 ffelexToken t);
243 static ffelexHandler ffeexpr_cb_close_paren_ci_ (ffelexToken ft,
244 ffebld expr, ffelexToken t);
245 static ffelexHandler ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr,
246 ffelexToken t);
247 static ffelexHandler ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr,
248 ffelexToken t);
249 static ffelexHandler ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr,
250 ffelexToken t);
251 static ffelexHandler ffeexpr_cb_comma_i_2_ (ffelexToken ft, ffebld expr,
252 ffelexToken t);
253 static ffelexHandler ffeexpr_cb_comma_i_3_ (ffelexToken ft, ffebld expr,
254 ffelexToken t);
255 static ffelexHandler ffeexpr_cb_comma_i_4_ (ffelexToken ft, ffebld expr,
256 ffelexToken t);
257 static ffelexHandler ffeexpr_cb_comma_i_5_ (ffelexToken t);
258 static ffelexHandler ffeexpr_cb_end_loc_ (ffelexToken ft, ffebld expr,
259 ffelexToken t);
260 static ffelexHandler ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr,
261 ffelexToken t);
262 static ffelexHandler ffeexpr_cb_end_notloc_1_ (ffelexToken t);
263 static ffesymbol ffeexpr_check_impctrl_ (ffesymbol s);
264 static void ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
265 ffebld dovar, ffelexToken dovar_t);
266 static void ffeexpr_update_impdo_ (ffebld expr, ffebld dovar);
267 static void ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar);
268 static ffeexprContext ffeexpr_context_outer_ (ffeexprStack_ s);
269 static ffeexprExpr_ ffeexpr_expr_new_ (void);
270 static void ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t);
271 static bool ffeexpr_isdigits_ (const char *p);
272 static ffelexHandler ffeexpr_token_first_lhs_ (ffelexToken t);
273 static ffelexHandler ffeexpr_token_first_lhs_1_ (ffelexToken t);
274 static ffelexHandler ffeexpr_token_first_rhs_ (ffelexToken t);
275 static ffelexHandler ffeexpr_token_first_rhs_1_ (ffelexToken t);
276 static ffelexHandler ffeexpr_token_first_rhs_2_ (ffelexToken t);
277 static ffelexHandler ffeexpr_token_first_rhs_3_ (ffelexToken t);
278 static ffelexHandler ffeexpr_token_first_rhs_4_ (ffelexToken t);
279 static ffelexHandler ffeexpr_token_first_rhs_5_ (ffelexToken t);
280 static ffelexHandler ffeexpr_token_first_rhs_6_ (ffelexToken t);
281 static ffelexHandler ffeexpr_token_namelist_ (ffelexToken t);
282 static void ffeexpr_expr_kill_ (ffeexprExpr_ e);
283 static void ffeexpr_exprstack_push_ (ffeexprExpr_ e);
284 static void ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e);
285 static void ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e);
286 static void ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e);
287 static void ffeexpr_reduce_ (void);
288 static ffebld ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op,
289 ffeexprExpr_ r);
290 static ffebld ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l,
291 ffeexprExpr_ op, ffeexprExpr_ r);
292 static ffebld ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l,
293 ffeexprExpr_ op, ffeexprExpr_ r);
294 static ffebld ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l,
295 ffeexprExpr_ op, ffeexprExpr_ r);
296 static ffebld ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op,
297 ffeexprExpr_ r);
298 static ffebld ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l,
299 ffeexprExpr_ op, ffeexprExpr_ r);
300 static ffebld ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l,
301 ffeexprExpr_ op, ffeexprExpr_ r);
302 static ffebld ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l,
303 ffeexprExpr_ op, ffeexprExpr_ r);
304 static ffebld ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r);
305 static ffebld ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op,
306 ffeexprExpr_ r);
307 static ffebld ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l,
308 ffeexprExpr_ op, ffeexprExpr_ r);
309 static ffebld ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l,
310 ffeexprExpr_ op, ffeexprExpr_ r);
311 static ffelexHandler ffeexpr_find_close_paren_ (ffelexToken t,
312 ffelexHandler after);
313 static ffelexHandler ffeexpr_nil_finished_ (ffelexToken t);
314 static ffelexHandler ffeexpr_nil_rhs_ (ffelexToken t);
315 static ffelexHandler ffeexpr_nil_period_ (ffelexToken t);
316 static ffelexHandler ffeexpr_nil_end_period_ (ffelexToken t);
317 static ffelexHandler ffeexpr_nil_swallow_period_ (ffelexToken t);
318 static ffelexHandler ffeexpr_nil_real_ (ffelexToken t);
319 static ffelexHandler ffeexpr_nil_real_exponent_ (ffelexToken t);
320 static ffelexHandler ffeexpr_nil_real_exp_sign_ (ffelexToken t);
321 static ffelexHandler ffeexpr_nil_number_ (ffelexToken t);
322 static ffelexHandler ffeexpr_nil_number_exponent_ (ffelexToken t);
323 static ffelexHandler ffeexpr_nil_number_exp_sign_ (ffelexToken t);
324 static ffelexHandler ffeexpr_nil_number_period_ (ffelexToken t);
325 static ffelexHandler ffeexpr_nil_number_per_exp_ (ffelexToken t);
326 static ffelexHandler ffeexpr_nil_number_real_ (ffelexToken t);
327 static ffelexHandler ffeexpr_nil_num_per_exp_sign_ (ffelexToken t);
328 static ffelexHandler ffeexpr_nil_number_real_exp_ (ffelexToken t);
329 static ffelexHandler ffeexpr_nil_num_real_exp_sn_ (ffelexToken t);
330 static ffelexHandler ffeexpr_nil_binary_ (ffelexToken t);
331 static ffelexHandler ffeexpr_nil_binary_period_ (ffelexToken t);
332 static ffelexHandler ffeexpr_nil_binary_end_per_ (ffelexToken t);
333 static ffelexHandler ffeexpr_nil_binary_sw_per_ (ffelexToken t);
334 static ffelexHandler ffeexpr_nil_quote_ (ffelexToken t);
335 static ffelexHandler ffeexpr_nil_apostrophe_ (ffelexToken t);
336 static ffelexHandler ffeexpr_nil_apos_char_ (ffelexToken t);
337 static ffelexHandler ffeexpr_nil_name_rhs_ (ffelexToken t);
338 static ffelexHandler ffeexpr_nil_name_apos_ (ffelexToken t);
339 static ffelexHandler ffeexpr_nil_name_apos_name_ (ffelexToken t);
340 static ffelexHandler ffeexpr_nil_percent_ (ffelexToken t);
341 static ffelexHandler ffeexpr_nil_percent_name_ (ffelexToken t);
342 static ffelexHandler ffeexpr_nil_substrp_ (ffelexToken t);
343 static ffelexHandler ffeexpr_finished_ (ffelexToken t);
344 static ffebld ffeexpr_finished_ambig_ (ffelexToken t, ffebld expr);
345 static ffelexHandler ffeexpr_token_lhs_ (ffelexToken t);
346 static ffelexHandler ffeexpr_token_rhs_ (ffelexToken t);
347 static ffelexHandler ffeexpr_token_binary_ (ffelexToken t);
348 static ffelexHandler ffeexpr_token_period_ (ffelexToken t);
349 static ffelexHandler ffeexpr_token_end_period_ (ffelexToken t);
350 static ffelexHandler ffeexpr_token_swallow_period_ (ffelexToken t);
351 static ffelexHandler ffeexpr_token_real_ (ffelexToken t);
352 static ffelexHandler ffeexpr_token_real_exponent_ (ffelexToken t);
353 static ffelexHandler ffeexpr_token_real_exp_sign_ (ffelexToken t);
354 static ffelexHandler ffeexpr_token_number_ (ffelexToken t);
355 static ffelexHandler ffeexpr_token_number_exponent_ (ffelexToken t);
356 static ffelexHandler ffeexpr_token_number_exp_sign_ (ffelexToken t);
357 static ffelexHandler ffeexpr_token_number_period_ (ffelexToken t);
358 static ffelexHandler ffeexpr_token_number_per_exp_ (ffelexToken t);
359 static ffelexHandler ffeexpr_token_number_real_ (ffelexToken t);
360 static ffelexHandler ffeexpr_token_num_per_exp_sign_ (ffelexToken t);
361 static ffelexHandler ffeexpr_token_number_real_exp_ (ffelexToken t);
362 static ffelexHandler ffeexpr_token_num_real_exp_sn_ (ffelexToken t);
363 static ffelexHandler ffeexpr_token_binary_period_ (ffelexToken t);
364 static ffelexHandler ffeexpr_token_binary_end_per_ (ffelexToken t);
365 static ffelexHandler ffeexpr_token_binary_sw_per_ (ffelexToken t);
366 static ffelexHandler ffeexpr_token_quote_ (ffelexToken t);
367 static ffelexHandler ffeexpr_token_apostrophe_ (ffelexToken t);
368 static ffelexHandler ffeexpr_token_apos_char_ (ffelexToken t);
369 static ffelexHandler ffeexpr_token_name_lhs_ (ffelexToken t);
370 static ffelexHandler ffeexpr_token_name_arg_ (ffelexToken t);
371 static ffelexHandler ffeexpr_token_name_rhs_ (ffelexToken t);
372 static ffelexHandler ffeexpr_token_name_apos_ (ffelexToken t);
373 static ffelexHandler ffeexpr_token_name_apos_name_ (ffelexToken t);
374 static ffelexHandler ffeexpr_token_percent_ (ffelexToken t);
375 static ffelexHandler ffeexpr_token_percent_name_ (ffelexToken t);
376 static ffelexHandler ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr,
377 ffelexToken t);
378 static ffelexHandler ffeexpr_token_elements_ (ffelexToken ft, ffebld expr,
379 ffelexToken t);
380 static ffelexHandler ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr,
381 ffelexToken t);
382 static ffelexHandler ffeexpr_token_substring_ (ffelexToken ft, ffebld expr,
383 ffelexToken t);
384 static ffelexHandler ffeexpr_token_substring_1_ (ffelexToken ft, ffebld expr,
385 ffelexToken t);
386 static ffelexHandler ffeexpr_token_substrp_ (ffelexToken t);
387 static ffelexHandler ffeexpr_token_intrincheck_ (ffelexToken t);
388 static ffelexHandler ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr,
389 ffelexToken t);
390 static ffelexHandler ffeexpr_token_anything_ (ffelexToken ft, ffebld expr,
391 ffelexToken t);
392 static void ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
393 ffelexToken decimal, ffelexToken fraction, ffelexToken exponent,
394 ffelexToken exponent_sign, ffelexToken exponent_digits);
395 static ffesymbol ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin);
396 static ffesymbol ffeexpr_sym_impdoitem_ (ffesymbol s, ffelexToken t);
397 static ffesymbol ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t);
398 static ffesymbol ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t);
399 static ffesymbol ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t);
400 static ffesymbol ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t);
401 static ffesymbol ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t);
402 static ffesymbol ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t);
403 static ffesymbol ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t);
404 static ffesymbol ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t);
405 static ffesymbol ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t);
406 static ffesymbol ffeexpr_declare_parenthesized_ (ffelexToken t,
407 bool maybe_intrin,
408 ffeexprParenType_ *paren_type);
409 static ffesymbol ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t);
410
411 /* Internal macros. */
412
413 #define ffeexpr_paren_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
414 #define ffeexpr_sym_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
415 \f
416 /* ffeexpr_collapse_convert -- Collapse convert expr
417
418 ffebld expr;
419 ffelexToken token;
420 expr = ffeexpr_collapse_convert(expr,token);
421
422 If the result of the expr is a constant, replaces the expr with the
423 computed constant. */
424
425 ffebld
426 ffeexpr_collapse_convert (ffebld expr, ffelexToken t)
427 {
428 ffebad error = FFEBAD;
429 ffebld l;
430 ffebldConstantUnion u;
431 ffeinfoBasictype bt;
432 ffeinfoKindtype kt;
433 ffetargetCharacterSize sz;
434 ffetargetCharacterSize sz2;
435
436 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
437 return expr;
438
439 l = ffebld_left (expr);
440
441 if (ffebld_op (l) != FFEBLD_opCONTER)
442 return expr;
443
444 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
445 {
446 case FFEINFO_basictypeANY:
447 return expr;
448
449 case FFEINFO_basictypeINTEGER:
450 sz = FFETARGET_charactersizeNONE;
451 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
452 {
453 #if FFETARGET_okINTEGER1
454 case FFEINFO_kindtypeINTEGER1:
455 switch (ffeinfo_basictype (ffebld_info (l)))
456 {
457 case FFEINFO_basictypeINTEGER:
458 switch (ffeinfo_kindtype (ffebld_info (l)))
459 {
460 #if FFETARGET_okINTEGER2
461 case FFEINFO_kindtypeINTEGER2:
462 error = ffetarget_convert_integer1_integer2
463 (ffebld_cu_ptr_integer1 (u),
464 ffebld_constant_integer2 (ffebld_conter (l)));
465 break;
466 #endif
467
468 #if FFETARGET_okINTEGER3
469 case FFEINFO_kindtypeINTEGER3:
470 error = ffetarget_convert_integer1_integer3
471 (ffebld_cu_ptr_integer1 (u),
472 ffebld_constant_integer3 (ffebld_conter (l)));
473 break;
474 #endif
475
476 #if FFETARGET_okINTEGER4
477 case FFEINFO_kindtypeINTEGER4:
478 error = ffetarget_convert_integer1_integer4
479 (ffebld_cu_ptr_integer1 (u),
480 ffebld_constant_integer4 (ffebld_conter (l)));
481 break;
482 #endif
483
484 default:
485 assert ("INTEGER1/INTEGER bad source kind type" == NULL);
486 break;
487 }
488 break;
489
490 case FFEINFO_basictypeREAL:
491 switch (ffeinfo_kindtype (ffebld_info (l)))
492 {
493 #if FFETARGET_okREAL1
494 case FFEINFO_kindtypeREAL1:
495 error = ffetarget_convert_integer1_real1
496 (ffebld_cu_ptr_integer1 (u),
497 ffebld_constant_real1 (ffebld_conter (l)));
498 break;
499 #endif
500
501 #if FFETARGET_okREAL2
502 case FFEINFO_kindtypeREAL2:
503 error = ffetarget_convert_integer1_real2
504 (ffebld_cu_ptr_integer1 (u),
505 ffebld_constant_real2 (ffebld_conter (l)));
506 break;
507 #endif
508
509 #if FFETARGET_okREAL3
510 case FFEINFO_kindtypeREAL3:
511 error = ffetarget_convert_integer1_real3
512 (ffebld_cu_ptr_integer1 (u),
513 ffebld_constant_real3 (ffebld_conter (l)));
514 break;
515 #endif
516
517 #if FFETARGET_okREAL4
518 case FFEINFO_kindtypeREAL4:
519 error = ffetarget_convert_integer1_real4
520 (ffebld_cu_ptr_integer1 (u),
521 ffebld_constant_real4 (ffebld_conter (l)));
522 break;
523 #endif
524
525 default:
526 assert ("INTEGER1/REAL bad source kind type" == NULL);
527 break;
528 }
529 break;
530
531 case FFEINFO_basictypeCOMPLEX:
532 switch (ffeinfo_kindtype (ffebld_info (l)))
533 {
534 #if FFETARGET_okCOMPLEX1
535 case FFEINFO_kindtypeREAL1:
536 error = ffetarget_convert_integer1_complex1
537 (ffebld_cu_ptr_integer1 (u),
538 ffebld_constant_complex1 (ffebld_conter (l)));
539 break;
540 #endif
541
542 #if FFETARGET_okCOMPLEX2
543 case FFEINFO_kindtypeREAL2:
544 error = ffetarget_convert_integer1_complex2
545 (ffebld_cu_ptr_integer1 (u),
546 ffebld_constant_complex2 (ffebld_conter (l)));
547 break;
548 #endif
549
550 #if FFETARGET_okCOMPLEX3
551 case FFEINFO_kindtypeREAL3:
552 error = ffetarget_convert_integer1_complex3
553 (ffebld_cu_ptr_integer1 (u),
554 ffebld_constant_complex3 (ffebld_conter (l)));
555 break;
556 #endif
557
558 #if FFETARGET_okCOMPLEX4
559 case FFEINFO_kindtypeREAL4:
560 error = ffetarget_convert_integer1_complex4
561 (ffebld_cu_ptr_integer1 (u),
562 ffebld_constant_complex4 (ffebld_conter (l)));
563 break;
564 #endif
565
566 default:
567 assert ("INTEGER1/COMPLEX bad source kind type" == NULL);
568 break;
569 }
570 break;
571
572 case FFEINFO_basictypeLOGICAL:
573 switch (ffeinfo_kindtype (ffebld_info (l)))
574 {
575 #if FFETARGET_okLOGICAL1
576 case FFEINFO_kindtypeLOGICAL1:
577 error = ffetarget_convert_integer1_logical1
578 (ffebld_cu_ptr_integer1 (u),
579 ffebld_constant_logical1 (ffebld_conter (l)));
580 break;
581 #endif
582
583 #if FFETARGET_okLOGICAL2
584 case FFEINFO_kindtypeLOGICAL2:
585 error = ffetarget_convert_integer1_logical2
586 (ffebld_cu_ptr_integer1 (u),
587 ffebld_constant_logical2 (ffebld_conter (l)));
588 break;
589 #endif
590
591 #if FFETARGET_okLOGICAL3
592 case FFEINFO_kindtypeLOGICAL3:
593 error = ffetarget_convert_integer1_logical3
594 (ffebld_cu_ptr_integer1 (u),
595 ffebld_constant_logical3 (ffebld_conter (l)));
596 break;
597 #endif
598
599 #if FFETARGET_okLOGICAL4
600 case FFEINFO_kindtypeLOGICAL4:
601 error = ffetarget_convert_integer1_logical4
602 (ffebld_cu_ptr_integer1 (u),
603 ffebld_constant_logical4 (ffebld_conter (l)));
604 break;
605 #endif
606
607 default:
608 assert ("INTEGER1/LOGICAL bad source kind type" == NULL);
609 break;
610 }
611 break;
612
613 case FFEINFO_basictypeCHARACTER:
614 error = ffetarget_convert_integer1_character1
615 (ffebld_cu_ptr_integer1 (u),
616 ffebld_constant_character1 (ffebld_conter (l)));
617 break;
618
619 case FFEINFO_basictypeHOLLERITH:
620 error = ffetarget_convert_integer1_hollerith
621 (ffebld_cu_ptr_integer1 (u),
622 ffebld_constant_hollerith (ffebld_conter (l)));
623 break;
624
625 case FFEINFO_basictypeTYPELESS:
626 error = ffetarget_convert_integer1_typeless
627 (ffebld_cu_ptr_integer1 (u),
628 ffebld_constant_typeless (ffebld_conter (l)));
629 break;
630
631 default:
632 assert ("INTEGER1 bad type" == NULL);
633 break;
634 }
635
636 /* If conversion operation is not implemented, return original expr. */
637 if (error == FFEBAD_NOCANDO)
638 return expr;
639
640 expr = ffebld_new_conter_with_orig
641 (ffebld_constant_new_integer1_val
642 (ffebld_cu_val_integer1 (u)), expr);
643 break;
644 #endif
645
646 #if FFETARGET_okINTEGER2
647 case FFEINFO_kindtypeINTEGER2:
648 switch (ffeinfo_basictype (ffebld_info (l)))
649 {
650 case FFEINFO_basictypeINTEGER:
651 switch (ffeinfo_kindtype (ffebld_info (l)))
652 {
653 #if FFETARGET_okINTEGER1
654 case FFEINFO_kindtypeINTEGER1:
655 error = ffetarget_convert_integer2_integer1
656 (ffebld_cu_ptr_integer2 (u),
657 ffebld_constant_integer1 (ffebld_conter (l)));
658 break;
659 #endif
660
661 #if FFETARGET_okINTEGER3
662 case FFEINFO_kindtypeINTEGER3:
663 error = ffetarget_convert_integer2_integer3
664 (ffebld_cu_ptr_integer2 (u),
665 ffebld_constant_integer3 (ffebld_conter (l)));
666 break;
667 #endif
668
669 #if FFETARGET_okINTEGER4
670 case FFEINFO_kindtypeINTEGER4:
671 error = ffetarget_convert_integer2_integer4
672 (ffebld_cu_ptr_integer2 (u),
673 ffebld_constant_integer4 (ffebld_conter (l)));
674 break;
675 #endif
676
677 default:
678 assert ("INTEGER2/INTEGER bad source kind type" == NULL);
679 break;
680 }
681 break;
682
683 case FFEINFO_basictypeREAL:
684 switch (ffeinfo_kindtype (ffebld_info (l)))
685 {
686 #if FFETARGET_okREAL1
687 case FFEINFO_kindtypeREAL1:
688 error = ffetarget_convert_integer2_real1
689 (ffebld_cu_ptr_integer2 (u),
690 ffebld_constant_real1 (ffebld_conter (l)));
691 break;
692 #endif
693
694 #if FFETARGET_okREAL2
695 case FFEINFO_kindtypeREAL2:
696 error = ffetarget_convert_integer2_real2
697 (ffebld_cu_ptr_integer2 (u),
698 ffebld_constant_real2 (ffebld_conter (l)));
699 break;
700 #endif
701
702 #if FFETARGET_okREAL3
703 case FFEINFO_kindtypeREAL3:
704 error = ffetarget_convert_integer2_real3
705 (ffebld_cu_ptr_integer2 (u),
706 ffebld_constant_real3 (ffebld_conter (l)));
707 break;
708 #endif
709
710 #if FFETARGET_okREAL4
711 case FFEINFO_kindtypeREAL4:
712 error = ffetarget_convert_integer2_real4
713 (ffebld_cu_ptr_integer2 (u),
714 ffebld_constant_real4 (ffebld_conter (l)));
715 break;
716 #endif
717
718 default:
719 assert ("INTEGER2/REAL bad source kind type" == NULL);
720 break;
721 }
722 break;
723
724 case FFEINFO_basictypeCOMPLEX:
725 switch (ffeinfo_kindtype (ffebld_info (l)))
726 {
727 #if FFETARGET_okCOMPLEX1
728 case FFEINFO_kindtypeREAL1:
729 error = ffetarget_convert_integer2_complex1
730 (ffebld_cu_ptr_integer2 (u),
731 ffebld_constant_complex1 (ffebld_conter (l)));
732 break;
733 #endif
734
735 #if FFETARGET_okCOMPLEX2
736 case FFEINFO_kindtypeREAL2:
737 error = ffetarget_convert_integer2_complex2
738 (ffebld_cu_ptr_integer2 (u),
739 ffebld_constant_complex2 (ffebld_conter (l)));
740 break;
741 #endif
742
743 #if FFETARGET_okCOMPLEX3
744 case FFEINFO_kindtypeREAL3:
745 error = ffetarget_convert_integer2_complex3
746 (ffebld_cu_ptr_integer2 (u),
747 ffebld_constant_complex3 (ffebld_conter (l)));
748 break;
749 #endif
750
751 #if FFETARGET_okCOMPLEX4
752 case FFEINFO_kindtypeREAL4:
753 error = ffetarget_convert_integer2_complex4
754 (ffebld_cu_ptr_integer2 (u),
755 ffebld_constant_complex4 (ffebld_conter (l)));
756 break;
757 #endif
758
759 default:
760 assert ("INTEGER2/COMPLEX bad source kind type" == NULL);
761 break;
762 }
763 break;
764
765 case FFEINFO_basictypeLOGICAL:
766 switch (ffeinfo_kindtype (ffebld_info (l)))
767 {
768 #if FFETARGET_okLOGICAL1
769 case FFEINFO_kindtypeLOGICAL1:
770 error = ffetarget_convert_integer2_logical1
771 (ffebld_cu_ptr_integer2 (u),
772 ffebld_constant_logical1 (ffebld_conter (l)));
773 break;
774 #endif
775
776 #if FFETARGET_okLOGICAL2
777 case FFEINFO_kindtypeLOGICAL2:
778 error = ffetarget_convert_integer2_logical2
779 (ffebld_cu_ptr_integer2 (u),
780 ffebld_constant_logical2 (ffebld_conter (l)));
781 break;
782 #endif
783
784 #if FFETARGET_okLOGICAL3
785 case FFEINFO_kindtypeLOGICAL3:
786 error = ffetarget_convert_integer2_logical3
787 (ffebld_cu_ptr_integer2 (u),
788 ffebld_constant_logical3 (ffebld_conter (l)));
789 break;
790 #endif
791
792 #if FFETARGET_okLOGICAL4
793 case FFEINFO_kindtypeLOGICAL4:
794 error = ffetarget_convert_integer2_logical4
795 (ffebld_cu_ptr_integer2 (u),
796 ffebld_constant_logical4 (ffebld_conter (l)));
797 break;
798 #endif
799
800 default:
801 assert ("INTEGER2/LOGICAL bad source kind type" == NULL);
802 break;
803 }
804 break;
805
806 case FFEINFO_basictypeCHARACTER:
807 error = ffetarget_convert_integer2_character1
808 (ffebld_cu_ptr_integer2 (u),
809 ffebld_constant_character1 (ffebld_conter (l)));
810 break;
811
812 case FFEINFO_basictypeHOLLERITH:
813 error = ffetarget_convert_integer2_hollerith
814 (ffebld_cu_ptr_integer2 (u),
815 ffebld_constant_hollerith (ffebld_conter (l)));
816 break;
817
818 case FFEINFO_basictypeTYPELESS:
819 error = ffetarget_convert_integer2_typeless
820 (ffebld_cu_ptr_integer2 (u),
821 ffebld_constant_typeless (ffebld_conter (l)));
822 break;
823
824 default:
825 assert ("INTEGER2 bad type" == NULL);
826 break;
827 }
828
829 /* If conversion operation is not implemented, return original expr. */
830 if (error == FFEBAD_NOCANDO)
831 return expr;
832
833 expr = ffebld_new_conter_with_orig
834 (ffebld_constant_new_integer2_val
835 (ffebld_cu_val_integer2 (u)), expr);
836 break;
837 #endif
838
839 #if FFETARGET_okINTEGER3
840 case FFEINFO_kindtypeINTEGER3:
841 switch (ffeinfo_basictype (ffebld_info (l)))
842 {
843 case FFEINFO_basictypeINTEGER:
844 switch (ffeinfo_kindtype (ffebld_info (l)))
845 {
846 #if FFETARGET_okINTEGER1
847 case FFEINFO_kindtypeINTEGER1:
848 error = ffetarget_convert_integer3_integer1
849 (ffebld_cu_ptr_integer3 (u),
850 ffebld_constant_integer1 (ffebld_conter (l)));
851 break;
852 #endif
853
854 #if FFETARGET_okINTEGER2
855 case FFEINFO_kindtypeINTEGER2:
856 error = ffetarget_convert_integer3_integer2
857 (ffebld_cu_ptr_integer3 (u),
858 ffebld_constant_integer2 (ffebld_conter (l)));
859 break;
860 #endif
861
862 #if FFETARGET_okINTEGER4
863 case FFEINFO_kindtypeINTEGER4:
864 error = ffetarget_convert_integer3_integer4
865 (ffebld_cu_ptr_integer3 (u),
866 ffebld_constant_integer4 (ffebld_conter (l)));
867 break;
868 #endif
869
870 default:
871 assert ("INTEGER3/INTEGER bad source kind type" == NULL);
872 break;
873 }
874 break;
875
876 case FFEINFO_basictypeREAL:
877 switch (ffeinfo_kindtype (ffebld_info (l)))
878 {
879 #if FFETARGET_okREAL1
880 case FFEINFO_kindtypeREAL1:
881 error = ffetarget_convert_integer3_real1
882 (ffebld_cu_ptr_integer3 (u),
883 ffebld_constant_real1 (ffebld_conter (l)));
884 break;
885 #endif
886
887 #if FFETARGET_okREAL2
888 case FFEINFO_kindtypeREAL2:
889 error = ffetarget_convert_integer3_real2
890 (ffebld_cu_ptr_integer3 (u),
891 ffebld_constant_real2 (ffebld_conter (l)));
892 break;
893 #endif
894
895 #if FFETARGET_okREAL3
896 case FFEINFO_kindtypeREAL3:
897 error = ffetarget_convert_integer3_real3
898 (ffebld_cu_ptr_integer3 (u),
899 ffebld_constant_real3 (ffebld_conter (l)));
900 break;
901 #endif
902
903 #if FFETARGET_okREAL4
904 case FFEINFO_kindtypeREAL4:
905 error = ffetarget_convert_integer3_real4
906 (ffebld_cu_ptr_integer3 (u),
907 ffebld_constant_real4 (ffebld_conter (l)));
908 break;
909 #endif
910
911 default:
912 assert ("INTEGER3/REAL bad source kind type" == NULL);
913 break;
914 }
915 break;
916
917 case FFEINFO_basictypeCOMPLEX:
918 switch (ffeinfo_kindtype (ffebld_info (l)))
919 {
920 #if FFETARGET_okCOMPLEX1
921 case FFEINFO_kindtypeREAL1:
922 error = ffetarget_convert_integer3_complex1
923 (ffebld_cu_ptr_integer3 (u),
924 ffebld_constant_complex1 (ffebld_conter (l)));
925 break;
926 #endif
927
928 #if FFETARGET_okCOMPLEX2
929 case FFEINFO_kindtypeREAL2:
930 error = ffetarget_convert_integer3_complex2
931 (ffebld_cu_ptr_integer3 (u),
932 ffebld_constant_complex2 (ffebld_conter (l)));
933 break;
934 #endif
935
936 #if FFETARGET_okCOMPLEX3
937 case FFEINFO_kindtypeREAL3:
938 error = ffetarget_convert_integer3_complex3
939 (ffebld_cu_ptr_integer3 (u),
940 ffebld_constant_complex3 (ffebld_conter (l)));
941 break;
942 #endif
943
944 #if FFETARGET_okCOMPLEX4
945 case FFEINFO_kindtypeREAL4:
946 error = ffetarget_convert_integer3_complex4
947 (ffebld_cu_ptr_integer3 (u),
948 ffebld_constant_complex4 (ffebld_conter (l)));
949 break;
950 #endif
951
952 default:
953 assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
954 break;
955 }
956 break;
957
958 case FFEINFO_basictypeLOGICAL:
959 switch (ffeinfo_kindtype (ffebld_info (l)))
960 {
961 #if FFETARGET_okLOGICAL1
962 case FFEINFO_kindtypeLOGICAL1:
963 error = ffetarget_convert_integer3_logical1
964 (ffebld_cu_ptr_integer3 (u),
965 ffebld_constant_logical1 (ffebld_conter (l)));
966 break;
967 #endif
968
969 #if FFETARGET_okLOGICAL2
970 case FFEINFO_kindtypeLOGICAL2:
971 error = ffetarget_convert_integer3_logical2
972 (ffebld_cu_ptr_integer3 (u),
973 ffebld_constant_logical2 (ffebld_conter (l)));
974 break;
975 #endif
976
977 #if FFETARGET_okLOGICAL3
978 case FFEINFO_kindtypeLOGICAL3:
979 error = ffetarget_convert_integer3_logical3
980 (ffebld_cu_ptr_integer3 (u),
981 ffebld_constant_logical3 (ffebld_conter (l)));
982 break;
983 #endif
984
985 #if FFETARGET_okLOGICAL4
986 case FFEINFO_kindtypeLOGICAL4:
987 error = ffetarget_convert_integer3_logical4
988 (ffebld_cu_ptr_integer3 (u),
989 ffebld_constant_logical4 (ffebld_conter (l)));
990 break;
991 #endif
992
993 default:
994 assert ("INTEGER3/LOGICAL bad source kind type" == NULL);
995 break;
996 }
997 break;
998
999 case FFEINFO_basictypeCHARACTER:
1000 error = ffetarget_convert_integer3_character1
1001 (ffebld_cu_ptr_integer3 (u),
1002 ffebld_constant_character1 (ffebld_conter (l)));
1003 break;
1004
1005 case FFEINFO_basictypeHOLLERITH:
1006 error = ffetarget_convert_integer3_hollerith
1007 (ffebld_cu_ptr_integer3 (u),
1008 ffebld_constant_hollerith (ffebld_conter (l)));
1009 break;
1010
1011 case FFEINFO_basictypeTYPELESS:
1012 error = ffetarget_convert_integer3_typeless
1013 (ffebld_cu_ptr_integer3 (u),
1014 ffebld_constant_typeless (ffebld_conter (l)));
1015 break;
1016
1017 default:
1018 assert ("INTEGER3 bad type" == NULL);
1019 break;
1020 }
1021
1022 /* If conversion operation is not implemented, return original expr. */
1023 if (error == FFEBAD_NOCANDO)
1024 return expr;
1025
1026 expr = ffebld_new_conter_with_orig
1027 (ffebld_constant_new_integer3_val
1028 (ffebld_cu_val_integer3 (u)), expr);
1029 break;
1030 #endif
1031
1032 #if FFETARGET_okINTEGER4
1033 case FFEINFO_kindtypeINTEGER4:
1034 switch (ffeinfo_basictype (ffebld_info (l)))
1035 {
1036 case FFEINFO_basictypeINTEGER:
1037 switch (ffeinfo_kindtype (ffebld_info (l)))
1038 {
1039 #if FFETARGET_okINTEGER1
1040 case FFEINFO_kindtypeINTEGER1:
1041 error = ffetarget_convert_integer4_integer1
1042 (ffebld_cu_ptr_integer4 (u),
1043 ffebld_constant_integer1 (ffebld_conter (l)));
1044 break;
1045 #endif
1046
1047 #if FFETARGET_okINTEGER2
1048 case FFEINFO_kindtypeINTEGER2:
1049 error = ffetarget_convert_integer4_integer2
1050 (ffebld_cu_ptr_integer4 (u),
1051 ffebld_constant_integer2 (ffebld_conter (l)));
1052 break;
1053 #endif
1054
1055 #if FFETARGET_okINTEGER3
1056 case FFEINFO_kindtypeINTEGER3:
1057 error = ffetarget_convert_integer4_integer3
1058 (ffebld_cu_ptr_integer4 (u),
1059 ffebld_constant_integer3 (ffebld_conter (l)));
1060 break;
1061 #endif
1062
1063 default:
1064 assert ("INTEGER4/INTEGER bad source kind type" == NULL);
1065 break;
1066 }
1067 break;
1068
1069 case FFEINFO_basictypeREAL:
1070 switch (ffeinfo_kindtype (ffebld_info (l)))
1071 {
1072 #if FFETARGET_okREAL1
1073 case FFEINFO_kindtypeREAL1:
1074 error = ffetarget_convert_integer4_real1
1075 (ffebld_cu_ptr_integer4 (u),
1076 ffebld_constant_real1 (ffebld_conter (l)));
1077 break;
1078 #endif
1079
1080 #if FFETARGET_okREAL2
1081 case FFEINFO_kindtypeREAL2:
1082 error = ffetarget_convert_integer4_real2
1083 (ffebld_cu_ptr_integer4 (u),
1084 ffebld_constant_real2 (ffebld_conter (l)));
1085 break;
1086 #endif
1087
1088 #if FFETARGET_okREAL3
1089 case FFEINFO_kindtypeREAL3:
1090 error = ffetarget_convert_integer4_real3
1091 (ffebld_cu_ptr_integer4 (u),
1092 ffebld_constant_real3 (ffebld_conter (l)));
1093 break;
1094 #endif
1095
1096 #if FFETARGET_okREAL4
1097 case FFEINFO_kindtypeREAL4:
1098 error = ffetarget_convert_integer4_real4
1099 (ffebld_cu_ptr_integer4 (u),
1100 ffebld_constant_real4 (ffebld_conter (l)));
1101 break;
1102 #endif
1103
1104 default:
1105 assert ("INTEGER4/REAL bad source kind type" == NULL);
1106 break;
1107 }
1108 break;
1109
1110 case FFEINFO_basictypeCOMPLEX:
1111 switch (ffeinfo_kindtype (ffebld_info (l)))
1112 {
1113 #if FFETARGET_okCOMPLEX1
1114 case FFEINFO_kindtypeREAL1:
1115 error = ffetarget_convert_integer4_complex1
1116 (ffebld_cu_ptr_integer4 (u),
1117 ffebld_constant_complex1 (ffebld_conter (l)));
1118 break;
1119 #endif
1120
1121 #if FFETARGET_okCOMPLEX2
1122 case FFEINFO_kindtypeREAL2:
1123 error = ffetarget_convert_integer4_complex2
1124 (ffebld_cu_ptr_integer4 (u),
1125 ffebld_constant_complex2 (ffebld_conter (l)));
1126 break;
1127 #endif
1128
1129 #if FFETARGET_okCOMPLEX3
1130 case FFEINFO_kindtypeREAL3:
1131 error = ffetarget_convert_integer4_complex3
1132 (ffebld_cu_ptr_integer4 (u),
1133 ffebld_constant_complex3 (ffebld_conter (l)));
1134 break;
1135 #endif
1136
1137 #if FFETARGET_okCOMPLEX4
1138 case FFEINFO_kindtypeREAL4:
1139 error = ffetarget_convert_integer4_complex4
1140 (ffebld_cu_ptr_integer4 (u),
1141 ffebld_constant_complex4 (ffebld_conter (l)));
1142 break;
1143 #endif
1144
1145 default:
1146 assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
1147 break;
1148 }
1149 break;
1150
1151 case FFEINFO_basictypeLOGICAL:
1152 switch (ffeinfo_kindtype (ffebld_info (l)))
1153 {
1154 #if FFETARGET_okLOGICAL1
1155 case FFEINFO_kindtypeLOGICAL1:
1156 error = ffetarget_convert_integer4_logical1
1157 (ffebld_cu_ptr_integer4 (u),
1158 ffebld_constant_logical1 (ffebld_conter (l)));
1159 break;
1160 #endif
1161
1162 #if FFETARGET_okLOGICAL2
1163 case FFEINFO_kindtypeLOGICAL2:
1164 error = ffetarget_convert_integer4_logical2
1165 (ffebld_cu_ptr_integer4 (u),
1166 ffebld_constant_logical2 (ffebld_conter (l)));
1167 break;
1168 #endif
1169
1170 #if FFETARGET_okLOGICAL3
1171 case FFEINFO_kindtypeLOGICAL3:
1172 error = ffetarget_convert_integer4_logical3
1173 (ffebld_cu_ptr_integer4 (u),
1174 ffebld_constant_logical3 (ffebld_conter (l)));
1175 break;
1176 #endif
1177
1178 #if FFETARGET_okLOGICAL4
1179 case FFEINFO_kindtypeLOGICAL4:
1180 error = ffetarget_convert_integer4_logical4
1181 (ffebld_cu_ptr_integer4 (u),
1182 ffebld_constant_logical4 (ffebld_conter (l)));
1183 break;
1184 #endif
1185
1186 default:
1187 assert ("INTEGER4/LOGICAL bad source kind type" == NULL);
1188 break;
1189 }
1190 break;
1191
1192 case FFEINFO_basictypeCHARACTER:
1193 error = ffetarget_convert_integer4_character1
1194 (ffebld_cu_ptr_integer4 (u),
1195 ffebld_constant_character1 (ffebld_conter (l)));
1196 break;
1197
1198 case FFEINFO_basictypeHOLLERITH:
1199 error = ffetarget_convert_integer4_hollerith
1200 (ffebld_cu_ptr_integer4 (u),
1201 ffebld_constant_hollerith (ffebld_conter (l)));
1202 break;
1203
1204 case FFEINFO_basictypeTYPELESS:
1205 error = ffetarget_convert_integer4_typeless
1206 (ffebld_cu_ptr_integer4 (u),
1207 ffebld_constant_typeless (ffebld_conter (l)));
1208 break;
1209
1210 default:
1211 assert ("INTEGER4 bad type" == NULL);
1212 break;
1213 }
1214
1215 /* If conversion operation is not implemented, return original expr. */
1216 if (error == FFEBAD_NOCANDO)
1217 return expr;
1218
1219 expr = ffebld_new_conter_with_orig
1220 (ffebld_constant_new_integer4_val
1221 (ffebld_cu_val_integer4 (u)), expr);
1222 break;
1223 #endif
1224
1225 default:
1226 assert ("bad integer kind type" == NULL);
1227 break;
1228 }
1229 break;
1230
1231 case FFEINFO_basictypeLOGICAL:
1232 sz = FFETARGET_charactersizeNONE;
1233 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1234 {
1235 #if FFETARGET_okLOGICAL1
1236 case FFEINFO_kindtypeLOGICAL1:
1237 switch (ffeinfo_basictype (ffebld_info (l)))
1238 {
1239 case FFEINFO_basictypeLOGICAL:
1240 switch (ffeinfo_kindtype (ffebld_info (l)))
1241 {
1242 #if FFETARGET_okLOGICAL2
1243 case FFEINFO_kindtypeLOGICAL2:
1244 error = ffetarget_convert_logical1_logical2
1245 (ffebld_cu_ptr_logical1 (u),
1246 ffebld_constant_logical2 (ffebld_conter (l)));
1247 break;
1248 #endif
1249
1250 #if FFETARGET_okLOGICAL3
1251 case FFEINFO_kindtypeLOGICAL3:
1252 error = ffetarget_convert_logical1_logical3
1253 (ffebld_cu_ptr_logical1 (u),
1254 ffebld_constant_logical3 (ffebld_conter (l)));
1255 break;
1256 #endif
1257
1258 #if FFETARGET_okLOGICAL4
1259 case FFEINFO_kindtypeLOGICAL4:
1260 error = ffetarget_convert_logical1_logical4
1261 (ffebld_cu_ptr_logical1 (u),
1262 ffebld_constant_logical4 (ffebld_conter (l)));
1263 break;
1264 #endif
1265
1266 default:
1267 assert ("LOGICAL1/LOGICAL bad source kind type" == NULL);
1268 break;
1269 }
1270 break;
1271
1272 case FFEINFO_basictypeINTEGER:
1273 switch (ffeinfo_kindtype (ffebld_info (l)))
1274 {
1275 #if FFETARGET_okINTEGER1
1276 case FFEINFO_kindtypeINTEGER1:
1277 error = ffetarget_convert_logical1_integer1
1278 (ffebld_cu_ptr_logical1 (u),
1279 ffebld_constant_integer1 (ffebld_conter (l)));
1280 break;
1281 #endif
1282
1283 #if FFETARGET_okINTEGER2
1284 case FFEINFO_kindtypeINTEGER2:
1285 error = ffetarget_convert_logical1_integer2
1286 (ffebld_cu_ptr_logical1 (u),
1287 ffebld_constant_integer2 (ffebld_conter (l)));
1288 break;
1289 #endif
1290
1291 #if FFETARGET_okINTEGER3
1292 case FFEINFO_kindtypeINTEGER3:
1293 error = ffetarget_convert_logical1_integer3
1294 (ffebld_cu_ptr_logical1 (u),
1295 ffebld_constant_integer3 (ffebld_conter (l)));
1296 break;
1297 #endif
1298
1299 #if FFETARGET_okINTEGER4
1300 case FFEINFO_kindtypeINTEGER4:
1301 error = ffetarget_convert_logical1_integer4
1302 (ffebld_cu_ptr_logical1 (u),
1303 ffebld_constant_integer4 (ffebld_conter (l)));
1304 break;
1305 #endif
1306
1307 default:
1308 assert ("LOGICAL1/INTEGER bad source kind type" == NULL);
1309 break;
1310 }
1311 break;
1312
1313 case FFEINFO_basictypeCHARACTER:
1314 error = ffetarget_convert_logical1_character1
1315 (ffebld_cu_ptr_logical1 (u),
1316 ffebld_constant_character1 (ffebld_conter (l)));
1317 break;
1318
1319 case FFEINFO_basictypeHOLLERITH:
1320 error = ffetarget_convert_logical1_hollerith
1321 (ffebld_cu_ptr_logical1 (u),
1322 ffebld_constant_hollerith (ffebld_conter (l)));
1323 break;
1324
1325 case FFEINFO_basictypeTYPELESS:
1326 error = ffetarget_convert_logical1_typeless
1327 (ffebld_cu_ptr_logical1 (u),
1328 ffebld_constant_typeless (ffebld_conter (l)));
1329 break;
1330
1331 default:
1332 assert ("LOGICAL1 bad type" == NULL);
1333 break;
1334 }
1335
1336 /* If conversion operation is not implemented, return original expr. */
1337 if (error == FFEBAD_NOCANDO)
1338 return expr;
1339
1340 expr = ffebld_new_conter_with_orig
1341 (ffebld_constant_new_logical1_val
1342 (ffebld_cu_val_logical1 (u)), expr);
1343 break;
1344 #endif
1345
1346 #if FFETARGET_okLOGICAL2
1347 case FFEINFO_kindtypeLOGICAL2:
1348 switch (ffeinfo_basictype (ffebld_info (l)))
1349 {
1350 case FFEINFO_basictypeLOGICAL:
1351 switch (ffeinfo_kindtype (ffebld_info (l)))
1352 {
1353 #if FFETARGET_okLOGICAL1
1354 case FFEINFO_kindtypeLOGICAL1:
1355 error = ffetarget_convert_logical2_logical1
1356 (ffebld_cu_ptr_logical2 (u),
1357 ffebld_constant_logical1 (ffebld_conter (l)));
1358 break;
1359 #endif
1360
1361 #if FFETARGET_okLOGICAL3
1362 case FFEINFO_kindtypeLOGICAL3:
1363 error = ffetarget_convert_logical2_logical3
1364 (ffebld_cu_ptr_logical2 (u),
1365 ffebld_constant_logical3 (ffebld_conter (l)));
1366 break;
1367 #endif
1368
1369 #if FFETARGET_okLOGICAL4
1370 case FFEINFO_kindtypeLOGICAL4:
1371 error = ffetarget_convert_logical2_logical4
1372 (ffebld_cu_ptr_logical2 (u),
1373 ffebld_constant_logical4 (ffebld_conter (l)));
1374 break;
1375 #endif
1376
1377 default:
1378 assert ("LOGICAL2/LOGICAL bad source kind type" == NULL);
1379 break;
1380 }
1381 break;
1382
1383 case FFEINFO_basictypeINTEGER:
1384 switch (ffeinfo_kindtype (ffebld_info (l)))
1385 {
1386 #if FFETARGET_okINTEGER1
1387 case FFEINFO_kindtypeINTEGER1:
1388 error = ffetarget_convert_logical2_integer1
1389 (ffebld_cu_ptr_logical2 (u),
1390 ffebld_constant_integer1 (ffebld_conter (l)));
1391 break;
1392 #endif
1393
1394 #if FFETARGET_okINTEGER2
1395 case FFEINFO_kindtypeINTEGER2:
1396 error = ffetarget_convert_logical2_integer2
1397 (ffebld_cu_ptr_logical2 (u),
1398 ffebld_constant_integer2 (ffebld_conter (l)));
1399 break;
1400 #endif
1401
1402 #if FFETARGET_okINTEGER3
1403 case FFEINFO_kindtypeINTEGER3:
1404 error = ffetarget_convert_logical2_integer3
1405 (ffebld_cu_ptr_logical2 (u),
1406 ffebld_constant_integer3 (ffebld_conter (l)));
1407 break;
1408 #endif
1409
1410 #if FFETARGET_okINTEGER4
1411 case FFEINFO_kindtypeINTEGER4:
1412 error = ffetarget_convert_logical2_integer4
1413 (ffebld_cu_ptr_logical2 (u),
1414 ffebld_constant_integer4 (ffebld_conter (l)));
1415 break;
1416 #endif
1417
1418 default:
1419 assert ("LOGICAL2/INTEGER bad source kind type" == NULL);
1420 break;
1421 }
1422 break;
1423
1424 case FFEINFO_basictypeCHARACTER:
1425 error = ffetarget_convert_logical2_character1
1426 (ffebld_cu_ptr_logical2 (u),
1427 ffebld_constant_character1 (ffebld_conter (l)));
1428 break;
1429
1430 case FFEINFO_basictypeHOLLERITH:
1431 error = ffetarget_convert_logical2_hollerith
1432 (ffebld_cu_ptr_logical2 (u),
1433 ffebld_constant_hollerith (ffebld_conter (l)));
1434 break;
1435
1436 case FFEINFO_basictypeTYPELESS:
1437 error = ffetarget_convert_logical2_typeless
1438 (ffebld_cu_ptr_logical2 (u),
1439 ffebld_constant_typeless (ffebld_conter (l)));
1440 break;
1441
1442 default:
1443 assert ("LOGICAL2 bad type" == NULL);
1444 break;
1445 }
1446
1447 /* If conversion operation is not implemented, return original expr. */
1448 if (error == FFEBAD_NOCANDO)
1449 return expr;
1450
1451 expr = ffebld_new_conter_with_orig
1452 (ffebld_constant_new_logical2_val
1453 (ffebld_cu_val_logical2 (u)), expr);
1454 break;
1455 #endif
1456
1457 #if FFETARGET_okLOGICAL3
1458 case FFEINFO_kindtypeLOGICAL3:
1459 switch (ffeinfo_basictype (ffebld_info (l)))
1460 {
1461 case FFEINFO_basictypeLOGICAL:
1462 switch (ffeinfo_kindtype (ffebld_info (l)))
1463 {
1464 #if FFETARGET_okLOGICAL1
1465 case FFEINFO_kindtypeLOGICAL1:
1466 error = ffetarget_convert_logical3_logical1
1467 (ffebld_cu_ptr_logical3 (u),
1468 ffebld_constant_logical1 (ffebld_conter (l)));
1469 break;
1470 #endif
1471
1472 #if FFETARGET_okLOGICAL2
1473 case FFEINFO_kindtypeLOGICAL2:
1474 error = ffetarget_convert_logical3_logical2
1475 (ffebld_cu_ptr_logical3 (u),
1476 ffebld_constant_logical2 (ffebld_conter (l)));
1477 break;
1478 #endif
1479
1480 #if FFETARGET_okLOGICAL4
1481 case FFEINFO_kindtypeLOGICAL4:
1482 error = ffetarget_convert_logical3_logical4
1483 (ffebld_cu_ptr_logical3 (u),
1484 ffebld_constant_logical4 (ffebld_conter (l)));
1485 break;
1486 #endif
1487
1488 default:
1489 assert ("LOGICAL3/LOGICAL bad source kind type" == NULL);
1490 break;
1491 }
1492 break;
1493
1494 case FFEINFO_basictypeINTEGER:
1495 switch (ffeinfo_kindtype (ffebld_info (l)))
1496 {
1497 #if FFETARGET_okINTEGER1
1498 case FFEINFO_kindtypeINTEGER1:
1499 error = ffetarget_convert_logical3_integer1
1500 (ffebld_cu_ptr_logical3 (u),
1501 ffebld_constant_integer1 (ffebld_conter (l)));
1502 break;
1503 #endif
1504
1505 #if FFETARGET_okINTEGER2
1506 case FFEINFO_kindtypeINTEGER2:
1507 error = ffetarget_convert_logical3_integer2
1508 (ffebld_cu_ptr_logical3 (u),
1509 ffebld_constant_integer2 (ffebld_conter (l)));
1510 break;
1511 #endif
1512
1513 #if FFETARGET_okINTEGER3
1514 case FFEINFO_kindtypeINTEGER3:
1515 error = ffetarget_convert_logical3_integer3
1516 (ffebld_cu_ptr_logical3 (u),
1517 ffebld_constant_integer3 (ffebld_conter (l)));
1518 break;
1519 #endif
1520
1521 #if FFETARGET_okINTEGER4
1522 case FFEINFO_kindtypeINTEGER4:
1523 error = ffetarget_convert_logical3_integer4
1524 (ffebld_cu_ptr_logical3 (u),
1525 ffebld_constant_integer4 (ffebld_conter (l)));
1526 break;
1527 #endif
1528
1529 default:
1530 assert ("LOGICAL3/INTEGER bad source kind type" == NULL);
1531 break;
1532 }
1533 break;
1534
1535 case FFEINFO_basictypeCHARACTER:
1536 error = ffetarget_convert_logical3_character1
1537 (ffebld_cu_ptr_logical3 (u),
1538 ffebld_constant_character1 (ffebld_conter (l)));
1539 break;
1540
1541 case FFEINFO_basictypeHOLLERITH:
1542 error = ffetarget_convert_logical3_hollerith
1543 (ffebld_cu_ptr_logical3 (u),
1544 ffebld_constant_hollerith (ffebld_conter (l)));
1545 break;
1546
1547 case FFEINFO_basictypeTYPELESS:
1548 error = ffetarget_convert_logical3_typeless
1549 (ffebld_cu_ptr_logical3 (u),
1550 ffebld_constant_typeless (ffebld_conter (l)));
1551 break;
1552
1553 default:
1554 assert ("LOGICAL3 bad type" == NULL);
1555 break;
1556 }
1557
1558 /* If conversion operation is not implemented, return original expr. */
1559 if (error == FFEBAD_NOCANDO)
1560 return expr;
1561
1562 expr = ffebld_new_conter_with_orig
1563 (ffebld_constant_new_logical3_val
1564 (ffebld_cu_val_logical3 (u)), expr);
1565 break;
1566 #endif
1567
1568 #if FFETARGET_okLOGICAL4
1569 case FFEINFO_kindtypeLOGICAL4:
1570 switch (ffeinfo_basictype (ffebld_info (l)))
1571 {
1572 case FFEINFO_basictypeLOGICAL:
1573 switch (ffeinfo_kindtype (ffebld_info (l)))
1574 {
1575 #if FFETARGET_okLOGICAL1
1576 case FFEINFO_kindtypeLOGICAL1:
1577 error = ffetarget_convert_logical4_logical1
1578 (ffebld_cu_ptr_logical4 (u),
1579 ffebld_constant_logical1 (ffebld_conter (l)));
1580 break;
1581 #endif
1582
1583 #if FFETARGET_okLOGICAL2
1584 case FFEINFO_kindtypeLOGICAL2:
1585 error = ffetarget_convert_logical4_logical2
1586 (ffebld_cu_ptr_logical4 (u),
1587 ffebld_constant_logical2 (ffebld_conter (l)));
1588 break;
1589 #endif
1590
1591 #if FFETARGET_okLOGICAL3
1592 case FFEINFO_kindtypeLOGICAL3:
1593 error = ffetarget_convert_logical4_logical3
1594 (ffebld_cu_ptr_logical4 (u),
1595 ffebld_constant_logical3 (ffebld_conter (l)));
1596 break;
1597 #endif
1598
1599 default:
1600 assert ("LOGICAL4/LOGICAL bad source kind type" == NULL);
1601 break;
1602 }
1603 break;
1604
1605 case FFEINFO_basictypeINTEGER:
1606 switch (ffeinfo_kindtype (ffebld_info (l)))
1607 {
1608 #if FFETARGET_okINTEGER1
1609 case FFEINFO_kindtypeINTEGER1:
1610 error = ffetarget_convert_logical4_integer1
1611 (ffebld_cu_ptr_logical4 (u),
1612 ffebld_constant_integer1 (ffebld_conter (l)));
1613 break;
1614 #endif
1615
1616 #if FFETARGET_okINTEGER2
1617 case FFEINFO_kindtypeINTEGER2:
1618 error = ffetarget_convert_logical4_integer2
1619 (ffebld_cu_ptr_logical4 (u),
1620 ffebld_constant_integer2 (ffebld_conter (l)));
1621 break;
1622 #endif
1623
1624 #if FFETARGET_okINTEGER3
1625 case FFEINFO_kindtypeINTEGER3:
1626 error = ffetarget_convert_logical4_integer3
1627 (ffebld_cu_ptr_logical4 (u),
1628 ffebld_constant_integer3 (ffebld_conter (l)));
1629 break;
1630 #endif
1631
1632 #if FFETARGET_okINTEGER4
1633 case FFEINFO_kindtypeINTEGER4:
1634 error = ffetarget_convert_logical4_integer4
1635 (ffebld_cu_ptr_logical4 (u),
1636 ffebld_constant_integer4 (ffebld_conter (l)));
1637 break;
1638 #endif
1639
1640 default:
1641 assert ("LOGICAL4/INTEGER bad source kind type" == NULL);
1642 break;
1643 }
1644 break;
1645
1646 case FFEINFO_basictypeCHARACTER:
1647 error = ffetarget_convert_logical4_character1
1648 (ffebld_cu_ptr_logical4 (u),
1649 ffebld_constant_character1 (ffebld_conter (l)));
1650 break;
1651
1652 case FFEINFO_basictypeHOLLERITH:
1653 error = ffetarget_convert_logical4_hollerith
1654 (ffebld_cu_ptr_logical4 (u),
1655 ffebld_constant_hollerith (ffebld_conter (l)));
1656 break;
1657
1658 case FFEINFO_basictypeTYPELESS:
1659 error = ffetarget_convert_logical4_typeless
1660 (ffebld_cu_ptr_logical4 (u),
1661 ffebld_constant_typeless (ffebld_conter (l)));
1662 break;
1663
1664 default:
1665 assert ("LOGICAL4 bad type" == NULL);
1666 break;
1667 }
1668
1669 /* If conversion operation is not implemented, return original expr. */
1670 if (error == FFEBAD_NOCANDO)
1671 return expr;
1672
1673 expr = ffebld_new_conter_with_orig
1674 (ffebld_constant_new_logical4_val
1675 (ffebld_cu_val_logical4 (u)), expr);
1676 break;
1677 #endif
1678
1679 default:
1680 assert ("bad logical kind type" == NULL);
1681 break;
1682 }
1683 break;
1684
1685 case FFEINFO_basictypeREAL:
1686 sz = FFETARGET_charactersizeNONE;
1687 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1688 {
1689 #if FFETARGET_okREAL1
1690 case FFEINFO_kindtypeREAL1:
1691 switch (ffeinfo_basictype (ffebld_info (l)))
1692 {
1693 case FFEINFO_basictypeINTEGER:
1694 switch (ffeinfo_kindtype (ffebld_info (l)))
1695 {
1696 #if FFETARGET_okINTEGER1
1697 case FFEINFO_kindtypeINTEGER1:
1698 error = ffetarget_convert_real1_integer1
1699 (ffebld_cu_ptr_real1 (u),
1700 ffebld_constant_integer1 (ffebld_conter (l)));
1701 break;
1702 #endif
1703
1704 #if FFETARGET_okINTEGER2
1705 case FFEINFO_kindtypeINTEGER2:
1706 error = ffetarget_convert_real1_integer2
1707 (ffebld_cu_ptr_real1 (u),
1708 ffebld_constant_integer2 (ffebld_conter (l)));
1709 break;
1710 #endif
1711
1712 #if FFETARGET_okINTEGER3
1713 case FFEINFO_kindtypeINTEGER3:
1714 error = ffetarget_convert_real1_integer3
1715 (ffebld_cu_ptr_real1 (u),
1716 ffebld_constant_integer3 (ffebld_conter (l)));
1717 break;
1718 #endif
1719
1720 #if FFETARGET_okINTEGER4
1721 case FFEINFO_kindtypeINTEGER4:
1722 error = ffetarget_convert_real1_integer4
1723 (ffebld_cu_ptr_real1 (u),
1724 ffebld_constant_integer4 (ffebld_conter (l)));
1725 break;
1726 #endif
1727
1728 default:
1729 assert ("REAL1/INTEGER bad source kind type" == NULL);
1730 break;
1731 }
1732 break;
1733
1734 case FFEINFO_basictypeREAL:
1735 switch (ffeinfo_kindtype (ffebld_info (l)))
1736 {
1737 #if FFETARGET_okREAL2
1738 case FFEINFO_kindtypeREAL2:
1739 error = ffetarget_convert_real1_real2
1740 (ffebld_cu_ptr_real1 (u),
1741 ffebld_constant_real2 (ffebld_conter (l)));
1742 break;
1743 #endif
1744
1745 #if FFETARGET_okREAL3
1746 case FFEINFO_kindtypeREAL3:
1747 error = ffetarget_convert_real1_real3
1748 (ffebld_cu_ptr_real1 (u),
1749 ffebld_constant_real3 (ffebld_conter (l)));
1750 break;
1751 #endif
1752
1753 #if FFETARGET_okREAL4
1754 case FFEINFO_kindtypeREAL4:
1755 error = ffetarget_convert_real1_real4
1756 (ffebld_cu_ptr_real1 (u),
1757 ffebld_constant_real4 (ffebld_conter (l)));
1758 break;
1759 #endif
1760
1761 default:
1762 assert ("REAL1/REAL bad source kind type" == NULL);
1763 break;
1764 }
1765 break;
1766
1767 case FFEINFO_basictypeCOMPLEX:
1768 switch (ffeinfo_kindtype (ffebld_info (l)))
1769 {
1770 #if FFETARGET_okCOMPLEX1
1771 case FFEINFO_kindtypeREAL1:
1772 error = ffetarget_convert_real1_complex1
1773 (ffebld_cu_ptr_real1 (u),
1774 ffebld_constant_complex1 (ffebld_conter (l)));
1775 break;
1776 #endif
1777
1778 #if FFETARGET_okCOMPLEX2
1779 case FFEINFO_kindtypeREAL2:
1780 error = ffetarget_convert_real1_complex2
1781 (ffebld_cu_ptr_real1 (u),
1782 ffebld_constant_complex2 (ffebld_conter (l)));
1783 break;
1784 #endif
1785
1786 #if FFETARGET_okCOMPLEX3
1787 case FFEINFO_kindtypeREAL3:
1788 error = ffetarget_convert_real1_complex3
1789 (ffebld_cu_ptr_real1 (u),
1790 ffebld_constant_complex3 (ffebld_conter (l)));
1791 break;
1792 #endif
1793
1794 #if FFETARGET_okCOMPLEX4
1795 case FFEINFO_kindtypeREAL4:
1796 error = ffetarget_convert_real1_complex4
1797 (ffebld_cu_ptr_real1 (u),
1798 ffebld_constant_complex4 (ffebld_conter (l)));
1799 break;
1800 #endif
1801
1802 default:
1803 assert ("REAL1/COMPLEX bad source kind type" == NULL);
1804 break;
1805 }
1806 break;
1807
1808 case FFEINFO_basictypeCHARACTER:
1809 error = ffetarget_convert_real1_character1
1810 (ffebld_cu_ptr_real1 (u),
1811 ffebld_constant_character1 (ffebld_conter (l)));
1812 break;
1813
1814 case FFEINFO_basictypeHOLLERITH:
1815 error = ffetarget_convert_real1_hollerith
1816 (ffebld_cu_ptr_real1 (u),
1817 ffebld_constant_hollerith (ffebld_conter (l)));
1818 break;
1819
1820 case FFEINFO_basictypeTYPELESS:
1821 error = ffetarget_convert_real1_typeless
1822 (ffebld_cu_ptr_real1 (u),
1823 ffebld_constant_typeless (ffebld_conter (l)));
1824 break;
1825
1826 default:
1827 assert ("REAL1 bad type" == NULL);
1828 break;
1829 }
1830
1831 /* If conversion operation is not implemented, return original expr. */
1832 if (error == FFEBAD_NOCANDO)
1833 return expr;
1834
1835 expr = ffebld_new_conter_with_orig
1836 (ffebld_constant_new_real1_val
1837 (ffebld_cu_val_real1 (u)), expr);
1838 break;
1839 #endif
1840
1841 #if FFETARGET_okREAL2
1842 case FFEINFO_kindtypeREAL2:
1843 switch (ffeinfo_basictype (ffebld_info (l)))
1844 {
1845 case FFEINFO_basictypeINTEGER:
1846 switch (ffeinfo_kindtype (ffebld_info (l)))
1847 {
1848 #if FFETARGET_okINTEGER1
1849 case FFEINFO_kindtypeINTEGER1:
1850 error = ffetarget_convert_real2_integer1
1851 (ffebld_cu_ptr_real2 (u),
1852 ffebld_constant_integer1 (ffebld_conter (l)));
1853 break;
1854 #endif
1855
1856 #if FFETARGET_okINTEGER2
1857 case FFEINFO_kindtypeINTEGER2:
1858 error = ffetarget_convert_real2_integer2
1859 (ffebld_cu_ptr_real2 (u),
1860 ffebld_constant_integer2 (ffebld_conter (l)));
1861 break;
1862 #endif
1863
1864 #if FFETARGET_okINTEGER3
1865 case FFEINFO_kindtypeINTEGER3:
1866 error = ffetarget_convert_real2_integer3
1867 (ffebld_cu_ptr_real2 (u),
1868 ffebld_constant_integer3 (ffebld_conter (l)));
1869 break;
1870 #endif
1871
1872 #if FFETARGET_okINTEGER4
1873 case FFEINFO_kindtypeINTEGER4:
1874 error = ffetarget_convert_real2_integer4
1875 (ffebld_cu_ptr_real2 (u),
1876 ffebld_constant_integer4 (ffebld_conter (l)));
1877 break;
1878 #endif
1879
1880 default:
1881 assert ("REAL2/INTEGER bad source kind type" == NULL);
1882 break;
1883 }
1884 break;
1885
1886 case FFEINFO_basictypeREAL:
1887 switch (ffeinfo_kindtype (ffebld_info (l)))
1888 {
1889 #if FFETARGET_okREAL1
1890 case FFEINFO_kindtypeREAL1:
1891 error = ffetarget_convert_real2_real1
1892 (ffebld_cu_ptr_real2 (u),
1893 ffebld_constant_real1 (ffebld_conter (l)));
1894 break;
1895 #endif
1896
1897 #if FFETARGET_okREAL3
1898 case FFEINFO_kindtypeREAL3:
1899 error = ffetarget_convert_real2_real3
1900 (ffebld_cu_ptr_real2 (u),
1901 ffebld_constant_real3 (ffebld_conter (l)));
1902 break;
1903 #endif
1904
1905 #if FFETARGET_okREAL4
1906 case FFEINFO_kindtypeREAL4:
1907 error = ffetarget_convert_real2_real4
1908 (ffebld_cu_ptr_real2 (u),
1909 ffebld_constant_real4 (ffebld_conter (l)));
1910 break;
1911 #endif
1912
1913 default:
1914 assert ("REAL2/REAL bad source kind type" == NULL);
1915 break;
1916 }
1917 break;
1918
1919 case FFEINFO_basictypeCOMPLEX:
1920 switch (ffeinfo_kindtype (ffebld_info (l)))
1921 {
1922 #if FFETARGET_okCOMPLEX1
1923 case FFEINFO_kindtypeREAL1:
1924 error = ffetarget_convert_real2_complex1
1925 (ffebld_cu_ptr_real2 (u),
1926 ffebld_constant_complex1 (ffebld_conter (l)));
1927 break;
1928 #endif
1929
1930 #if FFETARGET_okCOMPLEX2
1931 case FFEINFO_kindtypeREAL2:
1932 error = ffetarget_convert_real2_complex2
1933 (ffebld_cu_ptr_real2 (u),
1934 ffebld_constant_complex2 (ffebld_conter (l)));
1935 break;
1936 #endif
1937
1938 #if FFETARGET_okCOMPLEX3
1939 case FFEINFO_kindtypeREAL3:
1940 error = ffetarget_convert_real2_complex3
1941 (ffebld_cu_ptr_real2 (u),
1942 ffebld_constant_complex3 (ffebld_conter (l)));
1943 break;
1944 #endif
1945
1946 #if FFETARGET_okCOMPLEX4
1947 case FFEINFO_kindtypeREAL4:
1948 error = ffetarget_convert_real2_complex4
1949 (ffebld_cu_ptr_real2 (u),
1950 ffebld_constant_complex4 (ffebld_conter (l)));
1951 break;
1952 #endif
1953
1954 default:
1955 assert ("REAL2/COMPLEX bad source kind type" == NULL);
1956 break;
1957 }
1958 break;
1959
1960 case FFEINFO_basictypeCHARACTER:
1961 error = ffetarget_convert_real2_character1
1962 (ffebld_cu_ptr_real2 (u),
1963 ffebld_constant_character1 (ffebld_conter (l)));
1964 break;
1965
1966 case FFEINFO_basictypeHOLLERITH:
1967 error = ffetarget_convert_real2_hollerith
1968 (ffebld_cu_ptr_real2 (u),
1969 ffebld_constant_hollerith (ffebld_conter (l)));
1970 break;
1971
1972 case FFEINFO_basictypeTYPELESS:
1973 error = ffetarget_convert_real2_typeless
1974 (ffebld_cu_ptr_real2 (u),
1975 ffebld_constant_typeless (ffebld_conter (l)));
1976 break;
1977
1978 default:
1979 assert ("REAL2 bad type" == NULL);
1980 break;
1981 }
1982
1983 /* If conversion operation is not implemented, return original expr. */
1984 if (error == FFEBAD_NOCANDO)
1985 return expr;
1986
1987 expr = ffebld_new_conter_with_orig
1988 (ffebld_constant_new_real2_val
1989 (ffebld_cu_val_real2 (u)), expr);
1990 break;
1991 #endif
1992
1993 #if FFETARGET_okREAL3
1994 case FFEINFO_kindtypeREAL3:
1995 switch (ffeinfo_basictype (ffebld_info (l)))
1996 {
1997 case FFEINFO_basictypeINTEGER:
1998 switch (ffeinfo_kindtype (ffebld_info (l)))
1999 {
2000 #if FFETARGET_okINTEGER1
2001 case FFEINFO_kindtypeINTEGER1:
2002 error = ffetarget_convert_real3_integer1
2003 (ffebld_cu_ptr_real3 (u),
2004 ffebld_constant_integer1 (ffebld_conter (l)));
2005 break;
2006 #endif
2007
2008 #if FFETARGET_okINTEGER2
2009 case FFEINFO_kindtypeINTEGER2:
2010 error = ffetarget_convert_real3_integer2
2011 (ffebld_cu_ptr_real3 (u),
2012 ffebld_constant_integer2 (ffebld_conter (l)));
2013 break;
2014 #endif
2015
2016 #if FFETARGET_okINTEGER3
2017 case FFEINFO_kindtypeINTEGER3:
2018 error = ffetarget_convert_real3_integer3
2019 (ffebld_cu_ptr_real3 (u),
2020 ffebld_constant_integer3 (ffebld_conter (l)));
2021 break;
2022 #endif
2023
2024 #if FFETARGET_okINTEGER4
2025 case FFEINFO_kindtypeINTEGER4:
2026 error = ffetarget_convert_real3_integer4
2027 (ffebld_cu_ptr_real3 (u),
2028 ffebld_constant_integer4 (ffebld_conter (l)));
2029 break;
2030 #endif
2031
2032 default:
2033 assert ("REAL3/INTEGER bad source kind type" == NULL);
2034 break;
2035 }
2036 break;
2037
2038 case FFEINFO_basictypeREAL:
2039 switch (ffeinfo_kindtype (ffebld_info (l)))
2040 {
2041 #if FFETARGET_okREAL1
2042 case FFEINFO_kindtypeREAL1:
2043 error = ffetarget_convert_real3_real1
2044 (ffebld_cu_ptr_real3 (u),
2045 ffebld_constant_real1 (ffebld_conter (l)));
2046 break;
2047 #endif
2048
2049 #if FFETARGET_okREAL2
2050 case FFEINFO_kindtypeREAL2:
2051 error = ffetarget_convert_real3_real2
2052 (ffebld_cu_ptr_real3 (u),
2053 ffebld_constant_real2 (ffebld_conter (l)));
2054 break;
2055 #endif
2056
2057 #if FFETARGET_okREAL4
2058 case FFEINFO_kindtypeREAL4:
2059 error = ffetarget_convert_real3_real4
2060 (ffebld_cu_ptr_real3 (u),
2061 ffebld_constant_real4 (ffebld_conter (l)));
2062 break;
2063 #endif
2064
2065 default:
2066 assert ("REAL3/REAL bad source kind type" == NULL);
2067 break;
2068 }
2069 break;
2070
2071 case FFEINFO_basictypeCOMPLEX:
2072 switch (ffeinfo_kindtype (ffebld_info (l)))
2073 {
2074 #if FFETARGET_okCOMPLEX1
2075 case FFEINFO_kindtypeREAL1:
2076 error = ffetarget_convert_real3_complex1
2077 (ffebld_cu_ptr_real3 (u),
2078 ffebld_constant_complex1 (ffebld_conter (l)));
2079 break;
2080 #endif
2081
2082 #if FFETARGET_okCOMPLEX2
2083 case FFEINFO_kindtypeREAL2:
2084 error = ffetarget_convert_real3_complex2
2085 (ffebld_cu_ptr_real3 (u),
2086 ffebld_constant_complex2 (ffebld_conter (l)));
2087 break;
2088 #endif
2089
2090 #if FFETARGET_okCOMPLEX3
2091 case FFEINFO_kindtypeREAL3:
2092 error = ffetarget_convert_real3_complex3
2093 (ffebld_cu_ptr_real3 (u),
2094 ffebld_constant_complex3 (ffebld_conter (l)));
2095 break;
2096 #endif
2097
2098 #if FFETARGET_okCOMPLEX4
2099 case FFEINFO_kindtypeREAL4:
2100 error = ffetarget_convert_real3_complex4
2101 (ffebld_cu_ptr_real3 (u),
2102 ffebld_constant_complex4 (ffebld_conter (l)));
2103 break;
2104 #endif
2105
2106 default:
2107 assert ("REAL3/COMPLEX bad source kind type" == NULL);
2108 break;
2109 }
2110 break;
2111
2112 case FFEINFO_basictypeCHARACTER:
2113 error = ffetarget_convert_real3_character1
2114 (ffebld_cu_ptr_real3 (u),
2115 ffebld_constant_character1 (ffebld_conter (l)));
2116 break;
2117
2118 case FFEINFO_basictypeHOLLERITH:
2119 error = ffetarget_convert_real3_hollerith
2120 (ffebld_cu_ptr_real3 (u),
2121 ffebld_constant_hollerith (ffebld_conter (l)));
2122 break;
2123
2124 case FFEINFO_basictypeTYPELESS:
2125 error = ffetarget_convert_real3_typeless
2126 (ffebld_cu_ptr_real3 (u),
2127 ffebld_constant_typeless (ffebld_conter (l)));
2128 break;
2129
2130 default:
2131 assert ("REAL3 bad type" == NULL);
2132 break;
2133 }
2134
2135 /* If conversion operation is not implemented, return original expr. */
2136 if (error == FFEBAD_NOCANDO)
2137 return expr;
2138
2139 expr = ffebld_new_conter_with_orig
2140 (ffebld_constant_new_real3_val
2141 (ffebld_cu_val_real3 (u)), expr);
2142 break;
2143 #endif
2144
2145 #if FFETARGET_okREAL4
2146 case FFEINFO_kindtypeREAL4:
2147 switch (ffeinfo_basictype (ffebld_info (l)))
2148 {
2149 case FFEINFO_basictypeINTEGER:
2150 switch (ffeinfo_kindtype (ffebld_info (l)))
2151 {
2152 #if FFETARGET_okINTEGER1
2153 case FFEINFO_kindtypeINTEGER1:
2154 error = ffetarget_convert_real4_integer1
2155 (ffebld_cu_ptr_real4 (u),
2156 ffebld_constant_integer1 (ffebld_conter (l)));
2157 break;
2158 #endif
2159
2160 #if FFETARGET_okINTEGER2
2161 case FFEINFO_kindtypeINTEGER2:
2162 error = ffetarget_convert_real4_integer2
2163 (ffebld_cu_ptr_real4 (u),
2164 ffebld_constant_integer2 (ffebld_conter (l)));
2165 break;
2166 #endif
2167
2168 #if FFETARGET_okINTEGER3
2169 case FFEINFO_kindtypeINTEGER3:
2170 error = ffetarget_convert_real4_integer3
2171 (ffebld_cu_ptr_real4 (u),
2172 ffebld_constant_integer3 (ffebld_conter (l)));
2173 break;
2174 #endif
2175
2176 #if FFETARGET_okINTEGER4
2177 case FFEINFO_kindtypeINTEGER4:
2178 error = ffetarget_convert_real4_integer4
2179 (ffebld_cu_ptr_real4 (u),
2180 ffebld_constant_integer4 (ffebld_conter (l)));
2181 break;
2182 #endif
2183
2184 default:
2185 assert ("REAL4/INTEGER bad source kind type" == NULL);
2186 break;
2187 }
2188 break;
2189
2190 case FFEINFO_basictypeREAL:
2191 switch (ffeinfo_kindtype (ffebld_info (l)))
2192 {
2193 #if FFETARGET_okREAL1
2194 case FFEINFO_kindtypeREAL1:
2195 error = ffetarget_convert_real4_real1
2196 (ffebld_cu_ptr_real4 (u),
2197 ffebld_constant_real1 (ffebld_conter (l)));
2198 break;
2199 #endif
2200
2201 #if FFETARGET_okREAL2
2202 case FFEINFO_kindtypeREAL2:
2203 error = ffetarget_convert_real4_real2
2204 (ffebld_cu_ptr_real4 (u),
2205 ffebld_constant_real2 (ffebld_conter (l)));
2206 break;
2207 #endif
2208
2209 #if FFETARGET_okREAL3
2210 case FFEINFO_kindtypeREAL3:
2211 error = ffetarget_convert_real4_real3
2212 (ffebld_cu_ptr_real4 (u),
2213 ffebld_constant_real3 (ffebld_conter (l)));
2214 break;
2215 #endif
2216
2217 default:
2218 assert ("REAL4/REAL bad source kind type" == NULL);
2219 break;
2220 }
2221 break;
2222
2223 case FFEINFO_basictypeCOMPLEX:
2224 switch (ffeinfo_kindtype (ffebld_info (l)))
2225 {
2226 #if FFETARGET_okCOMPLEX1
2227 case FFEINFO_kindtypeREAL1:
2228 error = ffetarget_convert_real4_complex1
2229 (ffebld_cu_ptr_real4 (u),
2230 ffebld_constant_complex1 (ffebld_conter (l)));
2231 break;
2232 #endif
2233
2234 #if FFETARGET_okCOMPLEX2
2235 case FFEINFO_kindtypeREAL2:
2236 error = ffetarget_convert_real4_complex2
2237 (ffebld_cu_ptr_real4 (u),
2238 ffebld_constant_complex2 (ffebld_conter (l)));
2239 break;
2240 #endif
2241
2242 #if FFETARGET_okCOMPLEX3
2243 case FFEINFO_kindtypeREAL3:
2244 error = ffetarget_convert_real4_complex3
2245 (ffebld_cu_ptr_real4 (u),
2246 ffebld_constant_complex3 (ffebld_conter (l)));
2247 break;
2248 #endif
2249
2250 #if FFETARGET_okCOMPLEX4
2251 case FFEINFO_kindtypeREAL4:
2252 error = ffetarget_convert_real4_complex4
2253 (ffebld_cu_ptr_real4 (u),
2254 ffebld_constant_complex4 (ffebld_conter (l)));
2255 break;
2256 #endif
2257
2258 default:
2259 assert ("REAL4/COMPLEX bad source kind type" == NULL);
2260 break;
2261 }
2262 break;
2263
2264 case FFEINFO_basictypeCHARACTER:
2265 error = ffetarget_convert_real4_character1
2266 (ffebld_cu_ptr_real4 (u),
2267 ffebld_constant_character1 (ffebld_conter (l)));
2268 break;
2269
2270 case FFEINFO_basictypeHOLLERITH:
2271 error = ffetarget_convert_real4_hollerith
2272 (ffebld_cu_ptr_real4 (u),
2273 ffebld_constant_hollerith (ffebld_conter (l)));
2274 break;
2275
2276 case FFEINFO_basictypeTYPELESS:
2277 error = ffetarget_convert_real4_typeless
2278 (ffebld_cu_ptr_real4 (u),
2279 ffebld_constant_typeless (ffebld_conter (l)));
2280 break;
2281
2282 default:
2283 assert ("REAL4 bad type" == NULL);
2284 break;
2285 }
2286
2287 /* If conversion operation is not implemented, return original expr. */
2288 if (error == FFEBAD_NOCANDO)
2289 return expr;
2290
2291 expr = ffebld_new_conter_with_orig
2292 (ffebld_constant_new_real4_val
2293 (ffebld_cu_val_real4 (u)), expr);
2294 break;
2295 #endif
2296
2297 default:
2298 assert ("bad real kind type" == NULL);
2299 break;
2300 }
2301 break;
2302
2303 case FFEINFO_basictypeCOMPLEX:
2304 sz = FFETARGET_charactersizeNONE;
2305 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2306 {
2307 #if FFETARGET_okCOMPLEX1
2308 case FFEINFO_kindtypeREAL1:
2309 switch (ffeinfo_basictype (ffebld_info (l)))
2310 {
2311 case FFEINFO_basictypeINTEGER:
2312 switch (ffeinfo_kindtype (ffebld_info (l)))
2313 {
2314 #if FFETARGET_okINTEGER1
2315 case FFEINFO_kindtypeINTEGER1:
2316 error = ffetarget_convert_complex1_integer1
2317 (ffebld_cu_ptr_complex1 (u),
2318 ffebld_constant_integer1 (ffebld_conter (l)));
2319 break;
2320 #endif
2321
2322 #if FFETARGET_okINTEGER2
2323 case FFEINFO_kindtypeINTEGER2:
2324 error = ffetarget_convert_complex1_integer2
2325 (ffebld_cu_ptr_complex1 (u),
2326 ffebld_constant_integer2 (ffebld_conter (l)));
2327 break;
2328 #endif
2329
2330 #if FFETARGET_okINTEGER3
2331 case FFEINFO_kindtypeINTEGER3:
2332 error = ffetarget_convert_complex1_integer3
2333 (ffebld_cu_ptr_complex1 (u),
2334 ffebld_constant_integer3 (ffebld_conter (l)));
2335 break;
2336 #endif
2337
2338 #if FFETARGET_okINTEGER4
2339 case FFEINFO_kindtypeINTEGER4:
2340 error = ffetarget_convert_complex1_integer4
2341 (ffebld_cu_ptr_complex1 (u),
2342 ffebld_constant_integer4 (ffebld_conter (l)));
2343 break;
2344 #endif
2345
2346 default:
2347 assert ("COMPLEX1/INTEGER bad source kind type" == NULL);
2348 break;
2349 }
2350 break;
2351
2352 case FFEINFO_basictypeREAL:
2353 switch (ffeinfo_kindtype (ffebld_info (l)))
2354 {
2355 #if FFETARGET_okREAL1
2356 case FFEINFO_kindtypeREAL1:
2357 error = ffetarget_convert_complex1_real1
2358 (ffebld_cu_ptr_complex1 (u),
2359 ffebld_constant_real1 (ffebld_conter (l)));
2360 break;
2361 #endif
2362
2363 #if FFETARGET_okREAL2
2364 case FFEINFO_kindtypeREAL2:
2365 error = ffetarget_convert_complex1_real2
2366 (ffebld_cu_ptr_complex1 (u),
2367 ffebld_constant_real2 (ffebld_conter (l)));
2368 break;
2369 #endif
2370
2371 #if FFETARGET_okREAL3
2372 case FFEINFO_kindtypeREAL3:
2373 error = ffetarget_convert_complex1_real3
2374 (ffebld_cu_ptr_complex1 (u),
2375 ffebld_constant_real3 (ffebld_conter (l)));
2376 break;
2377 #endif
2378
2379 #if FFETARGET_okREAL4
2380 case FFEINFO_kindtypeREAL4:
2381 error = ffetarget_convert_complex1_real4
2382 (ffebld_cu_ptr_complex1 (u),
2383 ffebld_constant_real4 (ffebld_conter (l)));
2384 break;
2385 #endif
2386
2387 default:
2388 assert ("COMPLEX1/REAL bad source kind type" == NULL);
2389 break;
2390 }
2391 break;
2392
2393 case FFEINFO_basictypeCOMPLEX:
2394 switch (ffeinfo_kindtype (ffebld_info (l)))
2395 {
2396 #if FFETARGET_okCOMPLEX2
2397 case FFEINFO_kindtypeREAL2:
2398 error = ffetarget_convert_complex1_complex2
2399 (ffebld_cu_ptr_complex1 (u),
2400 ffebld_constant_complex2 (ffebld_conter (l)));
2401 break;
2402 #endif
2403
2404 #if FFETARGET_okCOMPLEX3
2405 case FFEINFO_kindtypeREAL3:
2406 error = ffetarget_convert_complex1_complex3
2407 (ffebld_cu_ptr_complex1 (u),
2408 ffebld_constant_complex3 (ffebld_conter (l)));
2409 break;
2410 #endif
2411
2412 #if FFETARGET_okCOMPLEX4
2413 case FFEINFO_kindtypeREAL4:
2414 error = ffetarget_convert_complex1_complex4
2415 (ffebld_cu_ptr_complex1 (u),
2416 ffebld_constant_complex4 (ffebld_conter (l)));
2417 break;
2418 #endif
2419
2420 default:
2421 assert ("COMPLEX1/COMPLEX bad source kind type" == NULL);
2422 break;
2423 }
2424 break;
2425
2426 case FFEINFO_basictypeCHARACTER:
2427 error = ffetarget_convert_complex1_character1
2428 (ffebld_cu_ptr_complex1 (u),
2429 ffebld_constant_character1 (ffebld_conter (l)));
2430 break;
2431
2432 case FFEINFO_basictypeHOLLERITH:
2433 error = ffetarget_convert_complex1_hollerith
2434 (ffebld_cu_ptr_complex1 (u),
2435 ffebld_constant_hollerith (ffebld_conter (l)));
2436 break;
2437
2438 case FFEINFO_basictypeTYPELESS:
2439 error = ffetarget_convert_complex1_typeless
2440 (ffebld_cu_ptr_complex1 (u),
2441 ffebld_constant_typeless (ffebld_conter (l)));
2442 break;
2443
2444 default:
2445 assert ("COMPLEX1 bad type" == NULL);
2446 break;
2447 }
2448
2449 /* If conversion operation is not implemented, return original expr. */
2450 if (error == FFEBAD_NOCANDO)
2451 return expr;
2452
2453 expr = ffebld_new_conter_with_orig
2454 (ffebld_constant_new_complex1_val
2455 (ffebld_cu_val_complex1 (u)), expr);
2456 break;
2457 #endif
2458
2459 #if FFETARGET_okCOMPLEX2
2460 case FFEINFO_kindtypeREAL2:
2461 switch (ffeinfo_basictype (ffebld_info (l)))
2462 {
2463 case FFEINFO_basictypeINTEGER:
2464 switch (ffeinfo_kindtype (ffebld_info (l)))
2465 {
2466 #if FFETARGET_okINTEGER1
2467 case FFEINFO_kindtypeINTEGER1:
2468 error = ffetarget_convert_complex2_integer1
2469 (ffebld_cu_ptr_complex2 (u),
2470 ffebld_constant_integer1 (ffebld_conter (l)));
2471 break;
2472 #endif
2473
2474 #if FFETARGET_okINTEGER2
2475 case FFEINFO_kindtypeINTEGER2:
2476 error = ffetarget_convert_complex2_integer2
2477 (ffebld_cu_ptr_complex2 (u),
2478 ffebld_constant_integer2 (ffebld_conter (l)));
2479 break;
2480 #endif
2481
2482 #if FFETARGET_okINTEGER3
2483 case FFEINFO_kindtypeINTEGER3:
2484 error = ffetarget_convert_complex2_integer3
2485 (ffebld_cu_ptr_complex2 (u),
2486 ffebld_constant_integer3 (ffebld_conter (l)));
2487 break;
2488 #endif
2489
2490 #if FFETARGET_okINTEGER4
2491 case FFEINFO_kindtypeINTEGER4:
2492 error = ffetarget_convert_complex2_integer4
2493 (ffebld_cu_ptr_complex2 (u),
2494 ffebld_constant_integer4 (ffebld_conter (l)));
2495 break;
2496 #endif
2497
2498 default:
2499 assert ("COMPLEX2/INTEGER bad source kind type" == NULL);
2500 break;
2501 }
2502 break;
2503
2504 case FFEINFO_basictypeREAL:
2505 switch (ffeinfo_kindtype (ffebld_info (l)))
2506 {
2507 #if FFETARGET_okREAL1
2508 case FFEINFO_kindtypeREAL1:
2509 error = ffetarget_convert_complex2_real1
2510 (ffebld_cu_ptr_complex2 (u),
2511 ffebld_constant_real1 (ffebld_conter (l)));
2512 break;
2513 #endif
2514
2515 #if FFETARGET_okREAL2
2516 case FFEINFO_kindtypeREAL2:
2517 error = ffetarget_convert_complex2_real2
2518 (ffebld_cu_ptr_complex2 (u),
2519 ffebld_constant_real2 (ffebld_conter (l)));
2520 break;
2521 #endif
2522
2523 #if FFETARGET_okREAL3
2524 case FFEINFO_kindtypeREAL3:
2525 error = ffetarget_convert_complex2_real3
2526 (ffebld_cu_ptr_complex2 (u),
2527 ffebld_constant_real3 (ffebld_conter (l)));
2528 break;
2529 #endif
2530
2531 #if FFETARGET_okREAL4
2532 case FFEINFO_kindtypeREAL4:
2533 error = ffetarget_convert_complex2_real4
2534 (ffebld_cu_ptr_complex2 (u),
2535 ffebld_constant_real4 (ffebld_conter (l)));
2536 break;
2537 #endif
2538
2539 default:
2540 assert ("COMPLEX2/REAL bad source kind type" == NULL);
2541 break;
2542 }
2543 break;
2544
2545 case FFEINFO_basictypeCOMPLEX:
2546 switch (ffeinfo_kindtype (ffebld_info (l)))
2547 {
2548 #if FFETARGET_okCOMPLEX1
2549 case FFEINFO_kindtypeREAL1:
2550 error = ffetarget_convert_complex2_complex1
2551 (ffebld_cu_ptr_complex2 (u),
2552 ffebld_constant_complex1 (ffebld_conter (l)));
2553 break;
2554 #endif
2555
2556 #if FFETARGET_okCOMPLEX3
2557 case FFEINFO_kindtypeREAL3:
2558 error = ffetarget_convert_complex2_complex3
2559 (ffebld_cu_ptr_complex2 (u),
2560 ffebld_constant_complex3 (ffebld_conter (l)));
2561 break;
2562 #endif
2563
2564 #if FFETARGET_okCOMPLEX4
2565 case FFEINFO_kindtypeREAL4:
2566 error = ffetarget_convert_complex2_complex4
2567 (ffebld_cu_ptr_complex2 (u),
2568 ffebld_constant_complex4 (ffebld_conter (l)));
2569 break;
2570 #endif
2571
2572 default:
2573 assert ("COMPLEX2/COMPLEX bad source kind type" == NULL);
2574 break;
2575 }
2576 break;
2577
2578 case FFEINFO_basictypeCHARACTER:
2579 error = ffetarget_convert_complex2_character1
2580 (ffebld_cu_ptr_complex2 (u),
2581 ffebld_constant_character1 (ffebld_conter (l)));
2582 break;
2583
2584 case FFEINFO_basictypeHOLLERITH:
2585 error = ffetarget_convert_complex2_hollerith
2586 (ffebld_cu_ptr_complex2 (u),
2587 ffebld_constant_hollerith (ffebld_conter (l)));
2588 break;
2589
2590 case FFEINFO_basictypeTYPELESS:
2591 error = ffetarget_convert_complex2_typeless
2592 (ffebld_cu_ptr_complex2 (u),
2593 ffebld_constant_typeless (ffebld_conter (l)));
2594 break;
2595
2596 default:
2597 assert ("COMPLEX2 bad type" == NULL);
2598 break;
2599 }
2600
2601 /* If conversion operation is not implemented, return original expr. */
2602 if (error == FFEBAD_NOCANDO)
2603 return expr;
2604
2605 expr = ffebld_new_conter_with_orig
2606 (ffebld_constant_new_complex2_val
2607 (ffebld_cu_val_complex2 (u)), expr);
2608 break;
2609 #endif
2610
2611 #if FFETARGET_okCOMPLEX3
2612 case FFEINFO_kindtypeREAL3:
2613 switch (ffeinfo_basictype (ffebld_info (l)))
2614 {
2615 case FFEINFO_basictypeINTEGER:
2616 switch (ffeinfo_kindtype (ffebld_info (l)))
2617 {
2618 #if FFETARGET_okINTEGER1
2619 case FFEINFO_kindtypeINTEGER1:
2620 error = ffetarget_convert_complex3_integer1
2621 (ffebld_cu_ptr_complex3 (u),
2622 ffebld_constant_integer1 (ffebld_conter (l)));
2623 break;
2624 #endif
2625
2626 #if FFETARGET_okINTEGER2
2627 case FFEINFO_kindtypeINTEGER2:
2628 error = ffetarget_convert_complex3_integer2
2629 (ffebld_cu_ptr_complex3 (u),
2630 ffebld_constant_integer2 (ffebld_conter (l)));
2631 break;
2632 #endif
2633
2634 #if FFETARGET_okINTEGER3
2635 case FFEINFO_kindtypeINTEGER3:
2636 error = ffetarget_convert_complex3_integer3
2637 (ffebld_cu_ptr_complex3 (u),
2638 ffebld_constant_integer3 (ffebld_conter (l)));
2639 break;
2640 #endif
2641
2642 #if FFETARGET_okINTEGER4
2643 case FFEINFO_kindtypeINTEGER4:
2644 error = ffetarget_convert_complex3_integer4
2645 (ffebld_cu_ptr_complex3 (u),
2646 ffebld_constant_integer4 (ffebld_conter (l)));
2647 break;
2648 #endif
2649
2650 default:
2651 assert ("COMPLEX3/INTEGER bad source kind type" == NULL);
2652 break;
2653 }
2654 break;
2655
2656 case FFEINFO_basictypeREAL:
2657 switch (ffeinfo_kindtype (ffebld_info (l)))
2658 {
2659 #if FFETARGET_okREAL1
2660 case FFEINFO_kindtypeREAL1:
2661 error = ffetarget_convert_complex3_real1
2662 (ffebld_cu_ptr_complex3 (u),
2663 ffebld_constant_real1 (ffebld_conter (l)));
2664 break;
2665 #endif
2666
2667 #if FFETARGET_okREAL2
2668 case FFEINFO_kindtypeREAL2:
2669 error = ffetarget_convert_complex3_real2
2670 (ffebld_cu_ptr_complex3 (u),
2671 ffebld_constant_real2 (ffebld_conter (l)));
2672 break;
2673 #endif
2674
2675 #if FFETARGET_okREAL3
2676 case FFEINFO_kindtypeREAL3:
2677 error = ffetarget_convert_complex3_real3
2678 (ffebld_cu_ptr_complex3 (u),
2679 ffebld_constant_real3 (ffebld_conter (l)));
2680 break;
2681 #endif
2682
2683 #if FFETARGET_okREAL4
2684 case FFEINFO_kindtypeREAL4:
2685 error = ffetarget_convert_complex3_real4
2686 (ffebld_cu_ptr_complex3 (u),
2687 ffebld_constant_real4 (ffebld_conter (l)));
2688 break;
2689 #endif
2690
2691 default:
2692 assert ("COMPLEX3/REAL bad source kind type" == NULL);
2693 break;
2694 }
2695 break;
2696
2697 case FFEINFO_basictypeCOMPLEX:
2698 switch (ffeinfo_kindtype (ffebld_info (l)))
2699 {
2700 #if FFETARGET_okCOMPLEX1
2701 case FFEINFO_kindtypeREAL1:
2702 error = ffetarget_convert_complex3_complex1
2703 (ffebld_cu_ptr_complex3 (u),
2704 ffebld_constant_complex1 (ffebld_conter (l)));
2705 break;
2706 #endif
2707
2708 #if FFETARGET_okCOMPLEX2
2709 case FFEINFO_kindtypeREAL2:
2710 error = ffetarget_convert_complex3_complex2
2711 (ffebld_cu_ptr_complex3 (u),
2712 ffebld_constant_complex2 (ffebld_conter (l)));
2713 break;
2714 #endif
2715
2716 #if FFETARGET_okCOMPLEX4
2717 case FFEINFO_kindtypeREAL4:
2718 error = ffetarget_convert_complex3_complex4
2719 (ffebld_cu_ptr_complex3 (u),
2720 ffebld_constant_complex4 (ffebld_conter (l)));
2721 break;
2722 #endif
2723
2724 default:
2725 assert ("COMPLEX3/COMPLEX bad source kind type" == NULL);
2726 break;
2727 }
2728 break;
2729
2730 case FFEINFO_basictypeCHARACTER:
2731 error = ffetarget_convert_complex3_character1
2732 (ffebld_cu_ptr_complex3 (u),
2733 ffebld_constant_character1 (ffebld_conter (l)));
2734 break;
2735
2736 case FFEINFO_basictypeHOLLERITH:
2737 error = ffetarget_convert_complex3_hollerith
2738 (ffebld_cu_ptr_complex3 (u),
2739 ffebld_constant_hollerith (ffebld_conter (l)));
2740 break;
2741
2742 case FFEINFO_basictypeTYPELESS:
2743 error = ffetarget_convert_complex3_typeless
2744 (ffebld_cu_ptr_complex3 (u),
2745 ffebld_constant_typeless (ffebld_conter (l)));
2746 break;
2747
2748 default:
2749 assert ("COMPLEX3 bad type" == NULL);
2750 break;
2751 }
2752
2753 /* If conversion operation is not implemented, return original expr. */
2754 if (error == FFEBAD_NOCANDO)
2755 return expr;
2756
2757 expr = ffebld_new_conter_with_orig
2758 (ffebld_constant_new_complex3_val
2759 (ffebld_cu_val_complex3 (u)), expr);
2760 break;
2761 #endif
2762
2763 #if FFETARGET_okCOMPLEX4
2764 case FFEINFO_kindtypeREAL4:
2765 switch (ffeinfo_basictype (ffebld_info (l)))
2766 {
2767 case FFEINFO_basictypeINTEGER:
2768 switch (ffeinfo_kindtype (ffebld_info (l)))
2769 {
2770 #if FFETARGET_okINTEGER1
2771 case FFEINFO_kindtypeINTEGER1:
2772 error = ffetarget_convert_complex4_integer1
2773 (ffebld_cu_ptr_complex4 (u),
2774 ffebld_constant_integer1 (ffebld_conter (l)));
2775 break;
2776 #endif
2777
2778 #if FFETARGET_okINTEGER2
2779 case FFEINFO_kindtypeINTEGER2:
2780 error = ffetarget_convert_complex4_integer2
2781 (ffebld_cu_ptr_complex4 (u),
2782 ffebld_constant_integer2 (ffebld_conter (l)));
2783 break;
2784 #endif
2785
2786 #if FFETARGET_okINTEGER3
2787 case FFEINFO_kindtypeINTEGER3:
2788 error = ffetarget_convert_complex4_integer3
2789 (ffebld_cu_ptr_complex4 (u),
2790 ffebld_constant_integer3 (ffebld_conter (l)));
2791 break;
2792 #endif
2793
2794 #if FFETARGET_okINTEGER4
2795 case FFEINFO_kindtypeINTEGER4:
2796 error = ffetarget_convert_complex4_integer4
2797 (ffebld_cu_ptr_complex4 (u),
2798 ffebld_constant_integer4 (ffebld_conter (l)));
2799 break;
2800 #endif
2801
2802 default:
2803 assert ("COMPLEX4/INTEGER bad source kind type" == NULL);
2804 break;
2805 }
2806 break;
2807
2808 case FFEINFO_basictypeREAL:
2809 switch (ffeinfo_kindtype (ffebld_info (l)))
2810 {
2811 #if FFETARGET_okREAL1
2812 case FFEINFO_kindtypeREAL1:
2813 error = ffetarget_convert_complex4_real1
2814 (ffebld_cu_ptr_complex4 (u),
2815 ffebld_constant_real1 (ffebld_conter (l)));
2816 break;
2817 #endif
2818
2819 #if FFETARGET_okREAL2
2820 case FFEINFO_kindtypeREAL2:
2821 error = ffetarget_convert_complex4_real2
2822 (ffebld_cu_ptr_complex4 (u),
2823 ffebld_constant_real2 (ffebld_conter (l)));
2824 break;
2825 #endif
2826
2827 #if FFETARGET_okREAL3
2828 case FFEINFO_kindtypeREAL3:
2829 error = ffetarget_convert_complex4_real3
2830 (ffebld_cu_ptr_complex4 (u),
2831 ffebld_constant_real3 (ffebld_conter (l)));
2832 break;
2833 #endif
2834
2835 #if FFETARGET_okREAL4
2836 case FFEINFO_kindtypeREAL4:
2837 error = ffetarget_convert_complex4_real4
2838 (ffebld_cu_ptr_complex4 (u),
2839 ffebld_constant_real4 (ffebld_conter (l)));
2840 break;
2841 #endif
2842
2843 default:
2844 assert ("COMPLEX4/REAL bad source kind type" == NULL);
2845 break;
2846 }
2847 break;
2848
2849 case FFEINFO_basictypeCOMPLEX:
2850 switch (ffeinfo_kindtype (ffebld_info (l)))
2851 {
2852 #if FFETARGET_okCOMPLEX1
2853 case FFEINFO_kindtypeREAL1:
2854 error = ffetarget_convert_complex4_complex1
2855 (ffebld_cu_ptr_complex4 (u),
2856 ffebld_constant_complex1 (ffebld_conter (l)));
2857 break;
2858 #endif
2859
2860 #if FFETARGET_okCOMPLEX2
2861 case FFEINFO_kindtypeREAL2:
2862 error = ffetarget_convert_complex4_complex2
2863 (ffebld_cu_ptr_complex4 (u),
2864 ffebld_constant_complex2 (ffebld_conter (l)));
2865 break;
2866 #endif
2867
2868 #if FFETARGET_okCOMPLEX3
2869 case FFEINFO_kindtypeREAL3:
2870 error = ffetarget_convert_complex4_complex3
2871 (ffebld_cu_ptr_complex4 (u),
2872 ffebld_constant_complex3 (ffebld_conter (l)));
2873 break;
2874 #endif
2875
2876 default:
2877 assert ("COMPLEX4/COMPLEX bad source kind type" == NULL);
2878 break;
2879 }
2880 break;
2881
2882 case FFEINFO_basictypeCHARACTER:
2883 error = ffetarget_convert_complex4_character1
2884 (ffebld_cu_ptr_complex4 (u),
2885 ffebld_constant_character1 (ffebld_conter (l)));
2886 break;
2887
2888 case FFEINFO_basictypeHOLLERITH:
2889 error = ffetarget_convert_complex4_hollerith
2890 (ffebld_cu_ptr_complex4 (u),
2891 ffebld_constant_hollerith (ffebld_conter (l)));
2892 break;
2893
2894 case FFEINFO_basictypeTYPELESS:
2895 error = ffetarget_convert_complex4_typeless
2896 (ffebld_cu_ptr_complex4 (u),
2897 ffebld_constant_typeless (ffebld_conter (l)));
2898 break;
2899
2900 default:
2901 assert ("COMPLEX4 bad type" == NULL);
2902 break;
2903 }
2904
2905 /* If conversion operation is not implemented, return original expr. */
2906 if (error == FFEBAD_NOCANDO)
2907 return expr;
2908
2909 expr = ffebld_new_conter_with_orig
2910 (ffebld_constant_new_complex4_val
2911 (ffebld_cu_val_complex4 (u)), expr);
2912 break;
2913 #endif
2914
2915 default:
2916 assert ("bad complex kind type" == NULL);
2917 break;
2918 }
2919 break;
2920
2921 case FFEINFO_basictypeCHARACTER:
2922 if ((sz = ffebld_size (expr)) == FFETARGET_charactersizeNONE)
2923 return expr;
2924 kt = ffeinfo_kindtype (ffebld_info (expr));
2925 switch (kt)
2926 {
2927 #if FFETARGET_okCHARACTER1
2928 case FFEINFO_kindtypeCHARACTER1:
2929 switch (ffeinfo_basictype (ffebld_info (l)))
2930 {
2931 case FFEINFO_basictypeCHARACTER:
2932 if ((sz2 = ffebld_size (l)) == FFETARGET_charactersizeNONE)
2933 return expr;
2934 assert (kt == ffeinfo_kindtype (ffebld_info (l)));
2935 assert (sz2 == ffetarget_length_character1
2936 (ffebld_constant_character1
2937 (ffebld_conter (l))));
2938 error
2939 = ffetarget_convert_character1_character1
2940 (ffebld_cu_ptr_character1 (u), sz,
2941 ffebld_constant_character1 (ffebld_conter (l)),
2942 ffebld_constant_pool ());
2943 break;
2944
2945 case FFEINFO_basictypeINTEGER:
2946 switch (ffeinfo_kindtype (ffebld_info (l)))
2947 {
2948 #if FFETARGET_okINTEGER1
2949 case FFEINFO_kindtypeINTEGER1:
2950 error
2951 = ffetarget_convert_character1_integer1
2952 (ffebld_cu_ptr_character1 (u),
2953 sz,
2954 ffebld_constant_integer1 (ffebld_conter (l)),
2955 ffebld_constant_pool ());
2956 break;
2957 #endif
2958
2959 #if FFETARGET_okINTEGER2
2960 case FFEINFO_kindtypeINTEGER2:
2961 error
2962 = ffetarget_convert_character1_integer2
2963 (ffebld_cu_ptr_character1 (u),
2964 sz,
2965 ffebld_constant_integer2 (ffebld_conter (l)),
2966 ffebld_constant_pool ());
2967 break;
2968 #endif
2969
2970 #if FFETARGET_okINTEGER3
2971 case FFEINFO_kindtypeINTEGER3:
2972 error
2973 = ffetarget_convert_character1_integer3
2974 (ffebld_cu_ptr_character1 (u),
2975 sz,
2976 ffebld_constant_integer3 (ffebld_conter (l)),
2977 ffebld_constant_pool ());
2978 break;
2979 #endif
2980
2981 #if FFETARGET_okINTEGER4
2982 case FFEINFO_kindtypeINTEGER4:
2983 error
2984 = ffetarget_convert_character1_integer4
2985 (ffebld_cu_ptr_character1 (u),
2986 sz,
2987 ffebld_constant_integer4 (ffebld_conter (l)),
2988 ffebld_constant_pool ());
2989 break;
2990 #endif
2991
2992 default:
2993 assert ("CHARACTER1/INTEGER bad source kind type" == NULL);
2994 break;
2995 }
2996 break;
2997
2998 case FFEINFO_basictypeLOGICAL:
2999 switch (ffeinfo_kindtype (ffebld_info (l)))
3000 {
3001 #if FFETARGET_okLOGICAL1
3002 case FFEINFO_kindtypeLOGICAL1:
3003 error
3004 = ffetarget_convert_character1_logical1
3005 (ffebld_cu_ptr_character1 (u),
3006 sz,
3007 ffebld_constant_logical1 (ffebld_conter (l)),
3008 ffebld_constant_pool ());
3009 break;
3010 #endif
3011
3012 #if FFETARGET_okLOGICAL2
3013 case FFEINFO_kindtypeLOGICAL2:
3014 error
3015 = ffetarget_convert_character1_logical2
3016 (ffebld_cu_ptr_character1 (u),
3017 sz,
3018 ffebld_constant_logical2 (ffebld_conter (l)),
3019 ffebld_constant_pool ());
3020 break;
3021 #endif
3022
3023 #if FFETARGET_okLOGICAL3
3024 case FFEINFO_kindtypeLOGICAL3:
3025 error
3026 = ffetarget_convert_character1_logical3
3027 (ffebld_cu_ptr_character1 (u),
3028 sz,
3029 ffebld_constant_logical3 (ffebld_conter (l)),
3030 ffebld_constant_pool ());
3031 break;
3032 #endif
3033
3034 #if FFETARGET_okLOGICAL4
3035 case FFEINFO_kindtypeLOGICAL4:
3036 error
3037 = ffetarget_convert_character1_logical4
3038 (ffebld_cu_ptr_character1 (u),
3039 sz,
3040 ffebld_constant_logical4 (ffebld_conter (l)),
3041 ffebld_constant_pool ());
3042 break;
3043 #endif
3044
3045 default:
3046 assert ("CHARACTER1/LOGICAL bad source kind type" == NULL);
3047 break;
3048 }
3049 break;
3050
3051 case FFEINFO_basictypeHOLLERITH:
3052 error
3053 = ffetarget_convert_character1_hollerith
3054 (ffebld_cu_ptr_character1 (u),
3055 sz,
3056 ffebld_constant_hollerith (ffebld_conter (l)),
3057 ffebld_constant_pool ());
3058 break;
3059
3060 case FFEINFO_basictypeTYPELESS:
3061 error
3062 = ffetarget_convert_character1_typeless
3063 (ffebld_cu_ptr_character1 (u),
3064 sz,
3065 ffebld_constant_typeless (ffebld_conter (l)),
3066 ffebld_constant_pool ());
3067 break;
3068
3069 default:
3070 assert ("CHARACTER1 bad type" == NULL);
3071 }
3072
3073 expr
3074 = ffebld_new_conter_with_orig
3075 (ffebld_constant_new_character1_val
3076 (ffebld_cu_val_character1 (u)),
3077 expr);
3078 break;
3079 #endif
3080
3081 default:
3082 assert ("bad character kind type" == NULL);
3083 break;
3084 }
3085 break;
3086
3087 default:
3088 assert ("bad type" == NULL);
3089 return expr;
3090 }
3091
3092 ffebld_set_info (expr, ffeinfo_new
3093 (bt,
3094 kt,
3095 0,
3096 FFEINFO_kindENTITY,
3097 FFEINFO_whereCONSTANT,
3098 sz));
3099
3100 if ((error != FFEBAD)
3101 && ffebad_start (error))
3102 {
3103 assert (t != NULL);
3104 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3105 ffebad_finish ();
3106 }
3107
3108 return expr;
3109 }
3110
3111 /* ffeexpr_collapse_paren -- Collapse paren expr
3112
3113 ffebld expr;
3114 ffelexToken token;
3115 expr = ffeexpr_collapse_paren(expr,token);
3116
3117 If the result of the expr is a constant, replaces the expr with the
3118 computed constant. */
3119
3120 ffebld
3121 ffeexpr_collapse_paren (ffebld expr, ffelexToken t UNUSED)
3122 {
3123 ffebld r;
3124 ffeinfoBasictype bt;
3125 ffeinfoKindtype kt;
3126 ffetargetCharacterSize len;
3127
3128 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3129 return expr;
3130
3131 r = ffebld_left (expr);
3132
3133 if (ffebld_op (r) != FFEBLD_opCONTER)
3134 return expr;
3135
3136 bt = ffeinfo_basictype (ffebld_info (r));
3137 kt = ffeinfo_kindtype (ffebld_info (r));
3138 len = ffebld_size (r);
3139
3140 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
3141 expr);
3142
3143 ffebld_set_info (expr, ffeinfo_new
3144 (bt,
3145 kt,
3146 0,
3147 FFEINFO_kindENTITY,
3148 FFEINFO_whereCONSTANT,
3149 len));
3150
3151 return expr;
3152 }
3153
3154 /* ffeexpr_collapse_uplus -- Collapse uplus expr
3155
3156 ffebld expr;
3157 ffelexToken token;
3158 expr = ffeexpr_collapse_uplus(expr,token);
3159
3160 If the result of the expr is a constant, replaces the expr with the
3161 computed constant. */
3162
3163 ffebld
3164 ffeexpr_collapse_uplus (ffebld expr, ffelexToken t UNUSED)
3165 {
3166 ffebld r;
3167 ffeinfoBasictype bt;
3168 ffeinfoKindtype kt;
3169 ffetargetCharacterSize len;
3170
3171 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3172 return expr;
3173
3174 r = ffebld_left (expr);
3175
3176 if (ffebld_op (r) != FFEBLD_opCONTER)
3177 return expr;
3178
3179 bt = ffeinfo_basictype (ffebld_info (r));
3180 kt = ffeinfo_kindtype (ffebld_info (r));
3181 len = ffebld_size (r);
3182
3183 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
3184 expr);
3185
3186 ffebld_set_info (expr, ffeinfo_new
3187 (bt,
3188 kt,
3189 0,
3190 FFEINFO_kindENTITY,
3191 FFEINFO_whereCONSTANT,
3192 len));
3193
3194 return expr;
3195 }
3196
3197 /* ffeexpr_collapse_uminus -- Collapse uminus expr
3198
3199 ffebld expr;
3200 ffelexToken token;
3201 expr = ffeexpr_collapse_uminus(expr,token);
3202
3203 If the result of the expr is a constant, replaces the expr with the
3204 computed constant. */
3205
3206 ffebld
3207 ffeexpr_collapse_uminus (ffebld expr, ffelexToken t)
3208 {
3209 ffebad error = FFEBAD;
3210 ffebld r;
3211 ffebldConstantUnion u;
3212 ffeinfoBasictype bt;
3213 ffeinfoKindtype kt;
3214
3215 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3216 return expr;
3217
3218 r = ffebld_left (expr);
3219
3220 if (ffebld_op (r) != FFEBLD_opCONTER)
3221 return expr;
3222
3223 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3224 {
3225 case FFEINFO_basictypeANY:
3226 return expr;
3227
3228 case FFEINFO_basictypeINTEGER:
3229 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3230 {
3231 #if FFETARGET_okINTEGER1
3232 case FFEINFO_kindtypeINTEGER1:
3233 error = ffetarget_uminus_integer1 (ffebld_cu_ptr_integer1 (u),
3234 ffebld_constant_integer1 (ffebld_conter (r)));
3235 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3236 (ffebld_cu_val_integer1 (u)), expr);
3237 break;
3238 #endif
3239
3240 #if FFETARGET_okINTEGER2
3241 case FFEINFO_kindtypeINTEGER2:
3242 error = ffetarget_uminus_integer2 (ffebld_cu_ptr_integer2 (u),
3243 ffebld_constant_integer2 (ffebld_conter (r)));
3244 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3245 (ffebld_cu_val_integer2 (u)), expr);
3246 break;
3247 #endif
3248
3249 #if FFETARGET_okINTEGER3
3250 case FFEINFO_kindtypeINTEGER3:
3251 error = ffetarget_uminus_integer3 (ffebld_cu_ptr_integer3 (u),
3252 ffebld_constant_integer3 (ffebld_conter (r)));
3253 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3254 (ffebld_cu_val_integer3 (u)), expr);
3255 break;
3256 #endif
3257
3258 #if FFETARGET_okINTEGER4
3259 case FFEINFO_kindtypeINTEGER4:
3260 error = ffetarget_uminus_integer4 (ffebld_cu_ptr_integer4 (u),
3261 ffebld_constant_integer4 (ffebld_conter (r)));
3262 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3263 (ffebld_cu_val_integer4 (u)), expr);
3264 break;
3265 #endif
3266
3267 default:
3268 assert ("bad integer kind type" == NULL);
3269 break;
3270 }
3271 break;
3272
3273 case FFEINFO_basictypeREAL:
3274 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3275 {
3276 #if FFETARGET_okREAL1
3277 case FFEINFO_kindtypeREAL1:
3278 error = ffetarget_uminus_real1 (ffebld_cu_ptr_real1 (u),
3279 ffebld_constant_real1 (ffebld_conter (r)));
3280 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3281 (ffebld_cu_val_real1 (u)), expr);
3282 break;
3283 #endif
3284
3285 #if FFETARGET_okREAL2
3286 case FFEINFO_kindtypeREAL2:
3287 error = ffetarget_uminus_real2 (ffebld_cu_ptr_real2 (u),
3288 ffebld_constant_real2 (ffebld_conter (r)));
3289 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3290 (ffebld_cu_val_real2 (u)), expr);
3291 break;
3292 #endif
3293
3294 #if FFETARGET_okREAL3
3295 case FFEINFO_kindtypeREAL3:
3296 error = ffetarget_uminus_real3 (ffebld_cu_ptr_real3 (u),
3297 ffebld_constant_real3 (ffebld_conter (r)));
3298 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3299 (ffebld_cu_val_real3 (u)), expr);
3300 break;
3301 #endif
3302
3303 #if FFETARGET_okREAL4
3304 case FFEINFO_kindtypeREAL4:
3305 error = ffetarget_uminus_real4 (ffebld_cu_ptr_real4 (u),
3306 ffebld_constant_real4 (ffebld_conter (r)));
3307 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
3308 (ffebld_cu_val_real4 (u)), expr);
3309 break;
3310 #endif
3311
3312 default:
3313 assert ("bad real kind type" == NULL);
3314 break;
3315 }
3316 break;
3317
3318 case FFEINFO_basictypeCOMPLEX:
3319 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3320 {
3321 #if FFETARGET_okCOMPLEX1
3322 case FFEINFO_kindtypeREAL1:
3323 error = ffetarget_uminus_complex1 (ffebld_cu_ptr_complex1 (u),
3324 ffebld_constant_complex1 (ffebld_conter (r)));
3325 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3326 (ffebld_cu_val_complex1 (u)), expr);
3327 break;
3328 #endif
3329
3330 #if FFETARGET_okCOMPLEX2
3331 case FFEINFO_kindtypeREAL2:
3332 error = ffetarget_uminus_complex2 (ffebld_cu_ptr_complex2 (u),
3333 ffebld_constant_complex2 (ffebld_conter (r)));
3334 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3335 (ffebld_cu_val_complex2 (u)), expr);
3336 break;
3337 #endif
3338
3339 #if FFETARGET_okCOMPLEX3
3340 case FFEINFO_kindtypeREAL3:
3341 error = ffetarget_uminus_complex3 (ffebld_cu_ptr_complex3 (u),
3342 ffebld_constant_complex3 (ffebld_conter (r)));
3343 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3344 (ffebld_cu_val_complex3 (u)), expr);
3345 break;
3346 #endif
3347
3348 #if FFETARGET_okCOMPLEX4
3349 case FFEINFO_kindtypeREAL4:
3350 error = ffetarget_uminus_complex4 (ffebld_cu_ptr_complex4 (u),
3351 ffebld_constant_complex4 (ffebld_conter (r)));
3352 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
3353 (ffebld_cu_val_complex4 (u)), expr);
3354 break;
3355 #endif
3356
3357 default:
3358 assert ("bad complex kind type" == NULL);
3359 break;
3360 }
3361 break;
3362
3363 default:
3364 assert ("bad type" == NULL);
3365 return expr;
3366 }
3367
3368 ffebld_set_info (expr, ffeinfo_new
3369 (bt,
3370 kt,
3371 0,
3372 FFEINFO_kindENTITY,
3373 FFEINFO_whereCONSTANT,
3374 FFETARGET_charactersizeNONE));
3375
3376 if ((error != FFEBAD)
3377 && ffebad_start (error))
3378 {
3379 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3380 ffebad_finish ();
3381 }
3382
3383 return expr;
3384 }
3385
3386 /* ffeexpr_collapse_not -- Collapse not expr
3387
3388 ffebld expr;
3389 ffelexToken token;
3390 expr = ffeexpr_collapse_not(expr,token);
3391
3392 If the result of the expr is a constant, replaces the expr with the
3393 computed constant. */
3394
3395 ffebld
3396 ffeexpr_collapse_not (ffebld expr, ffelexToken t)
3397 {
3398 ffebad error = FFEBAD;
3399 ffebld r;
3400 ffebldConstantUnion u;
3401 ffeinfoBasictype bt;
3402 ffeinfoKindtype kt;
3403
3404 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3405 return expr;
3406
3407 r = ffebld_left (expr);
3408
3409 if (ffebld_op (r) != FFEBLD_opCONTER)
3410 return expr;
3411
3412 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3413 {
3414 case FFEINFO_basictypeANY:
3415 return expr;
3416
3417 case FFEINFO_basictypeINTEGER:
3418 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3419 {
3420 #if FFETARGET_okINTEGER1
3421 case FFEINFO_kindtypeINTEGER1:
3422 error = ffetarget_not_integer1 (ffebld_cu_ptr_integer1 (u),
3423 ffebld_constant_integer1 (ffebld_conter (r)));
3424 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3425 (ffebld_cu_val_integer1 (u)), expr);
3426 break;
3427 #endif
3428
3429 #if FFETARGET_okINTEGER2
3430 case FFEINFO_kindtypeINTEGER2:
3431 error = ffetarget_not_integer2 (ffebld_cu_ptr_integer2 (u),
3432 ffebld_constant_integer2 (ffebld_conter (r)));
3433 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3434 (ffebld_cu_val_integer2 (u)), expr);
3435 break;
3436 #endif
3437
3438 #if FFETARGET_okINTEGER3
3439 case FFEINFO_kindtypeINTEGER3:
3440 error = ffetarget_not_integer3 (ffebld_cu_ptr_integer3 (u),
3441 ffebld_constant_integer3 (ffebld_conter (r)));
3442 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3443 (ffebld_cu_val_integer3 (u)), expr);
3444 break;
3445 #endif
3446
3447 #if FFETARGET_okINTEGER4
3448 case FFEINFO_kindtypeINTEGER4:
3449 error = ffetarget_not_integer4 (ffebld_cu_ptr_integer4 (u),
3450 ffebld_constant_integer4 (ffebld_conter (r)));
3451 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3452 (ffebld_cu_val_integer4 (u)), expr);
3453 break;
3454 #endif
3455
3456 default:
3457 assert ("bad integer kind type" == NULL);
3458 break;
3459 }
3460 break;
3461
3462 case FFEINFO_basictypeLOGICAL:
3463 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3464 {
3465 #if FFETARGET_okLOGICAL1
3466 case FFEINFO_kindtypeLOGICAL1:
3467 error = ffetarget_not_logical1 (ffebld_cu_ptr_logical1 (u),
3468 ffebld_constant_logical1 (ffebld_conter (r)));
3469 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
3470 (ffebld_cu_val_logical1 (u)), expr);
3471 break;
3472 #endif
3473
3474 #if FFETARGET_okLOGICAL2
3475 case FFEINFO_kindtypeLOGICAL2:
3476 error = ffetarget_not_logical2 (ffebld_cu_ptr_logical2 (u),
3477 ffebld_constant_logical2 (ffebld_conter (r)));
3478 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
3479 (ffebld_cu_val_logical2 (u)), expr);
3480 break;
3481 #endif
3482
3483 #if FFETARGET_okLOGICAL3
3484 case FFEINFO_kindtypeLOGICAL3:
3485 error = ffetarget_not_logical3 (ffebld_cu_ptr_logical3 (u),
3486 ffebld_constant_logical3 (ffebld_conter (r)));
3487 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
3488 (ffebld_cu_val_logical3 (u)), expr);
3489 break;
3490 #endif
3491
3492 #if FFETARGET_okLOGICAL4
3493 case FFEINFO_kindtypeLOGICAL4:
3494 error = ffetarget_not_logical4 (ffebld_cu_ptr_logical4 (u),
3495 ffebld_constant_logical4 (ffebld_conter (r)));
3496 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
3497 (ffebld_cu_val_logical4 (u)), expr);
3498 break;
3499 #endif
3500
3501 default:
3502 assert ("bad logical kind type" == NULL);
3503 break;
3504 }
3505 break;
3506
3507 default:
3508 assert ("bad type" == NULL);
3509 return expr;
3510 }
3511
3512 ffebld_set_info (expr, ffeinfo_new
3513 (bt,
3514 kt,
3515 0,
3516 FFEINFO_kindENTITY,
3517 FFEINFO_whereCONSTANT,
3518 FFETARGET_charactersizeNONE));
3519
3520 if ((error != FFEBAD)
3521 && ffebad_start (error))
3522 {
3523 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3524 ffebad_finish ();
3525 }
3526
3527 return expr;
3528 }
3529
3530 /* ffeexpr_collapse_add -- Collapse add expr
3531
3532 ffebld expr;
3533 ffelexToken token;
3534 expr = ffeexpr_collapse_add(expr,token);
3535
3536 If the result of the expr is a constant, replaces the expr with the
3537 computed constant. */
3538
3539 ffebld
3540 ffeexpr_collapse_add (ffebld expr, ffelexToken t)
3541 {
3542 ffebad error = FFEBAD;
3543 ffebld l;
3544 ffebld r;
3545 ffebldConstantUnion u;
3546 ffeinfoBasictype bt;
3547 ffeinfoKindtype kt;
3548
3549 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3550 return expr;
3551
3552 l = ffebld_left (expr);
3553 r = ffebld_right (expr);
3554
3555 if (ffebld_op (l) != FFEBLD_opCONTER)
3556 return expr;
3557 if (ffebld_op (r) != FFEBLD_opCONTER)
3558 return expr;
3559
3560 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3561 {
3562 case FFEINFO_basictypeANY:
3563 return expr;
3564
3565 case FFEINFO_basictypeINTEGER:
3566 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3567 {
3568 #if FFETARGET_okINTEGER1
3569 case FFEINFO_kindtypeINTEGER1:
3570 error = ffetarget_add_integer1 (ffebld_cu_ptr_integer1 (u),
3571 ffebld_constant_integer1 (ffebld_conter (l)),
3572 ffebld_constant_integer1 (ffebld_conter (r)));
3573 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3574 (ffebld_cu_val_integer1 (u)), expr);
3575 break;
3576 #endif
3577
3578 #if FFETARGET_okINTEGER2
3579 case FFEINFO_kindtypeINTEGER2:
3580 error = ffetarget_add_integer2 (ffebld_cu_ptr_integer2 (u),
3581 ffebld_constant_integer2 (ffebld_conter (l)),
3582 ffebld_constant_integer2 (ffebld_conter (r)));
3583 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3584 (ffebld_cu_val_integer2 (u)), expr);
3585 break;
3586 #endif
3587
3588 #if FFETARGET_okINTEGER3
3589 case FFEINFO_kindtypeINTEGER3:
3590 error = ffetarget_add_integer3 (ffebld_cu_ptr_integer3 (u),
3591 ffebld_constant_integer3 (ffebld_conter (l)),
3592 ffebld_constant_integer3 (ffebld_conter (r)));
3593 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3594 (ffebld_cu_val_integer3 (u)), expr);
3595 break;
3596 #endif
3597
3598 #if FFETARGET_okINTEGER4
3599 case FFEINFO_kindtypeINTEGER4:
3600 error = ffetarget_add_integer4 (ffebld_cu_ptr_integer4 (u),
3601 ffebld_constant_integer4 (ffebld_conter (l)),
3602 ffebld_constant_integer4 (ffebld_conter (r)));
3603 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3604 (ffebld_cu_val_integer4 (u)), expr);
3605 break;
3606 #endif
3607
3608 default:
3609 assert ("bad integer kind type" == NULL);
3610 break;
3611 }
3612 break;
3613
3614 case FFEINFO_basictypeREAL:
3615 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3616 {
3617 #if FFETARGET_okREAL1
3618 case FFEINFO_kindtypeREAL1:
3619 error = ffetarget_add_real1 (ffebld_cu_ptr_real1 (u),
3620 ffebld_constant_real1 (ffebld_conter (l)),
3621 ffebld_constant_real1 (ffebld_conter (r)));
3622 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3623 (ffebld_cu_val_real1 (u)), expr);
3624 break;
3625 #endif
3626
3627 #if FFETARGET_okREAL2
3628 case FFEINFO_kindtypeREAL2:
3629 error = ffetarget_add_real2 (ffebld_cu_ptr_real2 (u),
3630 ffebld_constant_real2 (ffebld_conter (l)),
3631 ffebld_constant_real2 (ffebld_conter (r)));
3632 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3633 (ffebld_cu_val_real2 (u)), expr);
3634 break;
3635 #endif
3636
3637 #if FFETARGET_okREAL3
3638 case FFEINFO_kindtypeREAL3:
3639 error = ffetarget_add_real3 (ffebld_cu_ptr_real3 (u),
3640 ffebld_constant_real3 (ffebld_conter (l)),
3641 ffebld_constant_real3 (ffebld_conter (r)));
3642 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3643 (ffebld_cu_val_real3 (u)), expr);
3644 break;
3645 #endif
3646
3647 #if FFETARGET_okREAL4
3648 case FFEINFO_kindtypeREAL4:
3649 error = ffetarget_add_real4 (ffebld_cu_ptr_real4 (u),
3650 ffebld_constant_real4 (ffebld_conter (l)),
3651 ffebld_constant_real4 (ffebld_conter (r)));
3652 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
3653 (ffebld_cu_val_real4 (u)), expr);
3654 break;
3655 #endif
3656
3657 default:
3658 assert ("bad real kind type" == NULL);
3659 break;
3660 }
3661 break;
3662
3663 case FFEINFO_basictypeCOMPLEX:
3664 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3665 {
3666 #if FFETARGET_okCOMPLEX1
3667 case FFEINFO_kindtypeREAL1:
3668 error = ffetarget_add_complex1 (ffebld_cu_ptr_complex1 (u),
3669 ffebld_constant_complex1 (ffebld_conter (l)),
3670 ffebld_constant_complex1 (ffebld_conter (r)));
3671 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3672 (ffebld_cu_val_complex1 (u)), expr);
3673 break;
3674 #endif
3675
3676 #if FFETARGET_okCOMPLEX2
3677 case FFEINFO_kindtypeREAL2:
3678 error = ffetarget_add_complex2 (ffebld_cu_ptr_complex2 (u),
3679 ffebld_constant_complex2 (ffebld_conter (l)),
3680 ffebld_constant_complex2 (ffebld_conter (r)));
3681 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3682 (ffebld_cu_val_complex2 (u)), expr);
3683 break;
3684 #endif
3685
3686 #if FFETARGET_okCOMPLEX3
3687 case FFEINFO_kindtypeREAL3:
3688 error = ffetarget_add_complex3 (ffebld_cu_ptr_complex3 (u),
3689 ffebld_constant_complex3 (ffebld_conter (l)),
3690 ffebld_constant_complex3 (ffebld_conter (r)));
3691 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3692 (ffebld_cu_val_complex3 (u)), expr);
3693 break;
3694 #endif
3695
3696 #if FFETARGET_okCOMPLEX4
3697 case FFEINFO_kindtypeREAL4:
3698 error = ffetarget_add_complex4 (ffebld_cu_ptr_complex4 (u),
3699 ffebld_constant_complex4 (ffebld_conter (l)),
3700 ffebld_constant_complex4 (ffebld_conter (r)));
3701 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
3702 (ffebld_cu_val_complex4 (u)), expr);
3703 break;
3704 #endif
3705
3706 default:
3707 assert ("bad complex kind type" == NULL);
3708 break;
3709 }
3710 break;
3711
3712 default:
3713 assert ("bad type" == NULL);
3714 return expr;
3715 }
3716
3717 ffebld_set_info (expr, ffeinfo_new
3718 (bt,
3719 kt,
3720 0,
3721 FFEINFO_kindENTITY,
3722 FFEINFO_whereCONSTANT,
3723 FFETARGET_charactersizeNONE));
3724
3725 if ((error != FFEBAD)
3726 && ffebad_start (error))
3727 {
3728 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3729 ffebad_finish ();
3730 }
3731
3732 return expr;
3733 }
3734
3735 /* ffeexpr_collapse_subtract -- Collapse subtract expr
3736
3737 ffebld expr;
3738 ffelexToken token;
3739 expr = ffeexpr_collapse_subtract(expr,token);
3740
3741 If the result of the expr is a constant, replaces the expr with the
3742 computed constant. */
3743
3744 ffebld
3745 ffeexpr_collapse_subtract (ffebld expr, ffelexToken t)
3746 {
3747 ffebad error = FFEBAD;
3748 ffebld l;
3749 ffebld r;
3750 ffebldConstantUnion u;
3751 ffeinfoBasictype bt;
3752 ffeinfoKindtype kt;
3753
3754 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3755 return expr;
3756
3757 l = ffebld_left (expr);
3758 r = ffebld_right (expr);
3759
3760 if (ffebld_op (l) != FFEBLD_opCONTER)
3761 return expr;
3762 if (ffebld_op (r) != FFEBLD_opCONTER)
3763 return expr;
3764
3765 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3766 {
3767 case FFEINFO_basictypeANY:
3768 return expr;
3769
3770 case FFEINFO_basictypeINTEGER:
3771 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3772 {
3773 #if FFETARGET_okINTEGER1
3774 case FFEINFO_kindtypeINTEGER1:
3775 error = ffetarget_subtract_integer1 (ffebld_cu_ptr_integer1 (u),
3776 ffebld_constant_integer1 (ffebld_conter (l)),
3777 ffebld_constant_integer1 (ffebld_conter (r)));
3778 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3779 (ffebld_cu_val_integer1 (u)), expr);
3780 break;
3781 #endif
3782
3783 #if FFETARGET_okINTEGER2
3784 case FFEINFO_kindtypeINTEGER2:
3785 error = ffetarget_subtract_integer2 (ffebld_cu_ptr_integer2 (u),
3786 ffebld_constant_integer2 (ffebld_conter (l)),
3787 ffebld_constant_integer2 (ffebld_conter (r)));
3788 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3789 (ffebld_cu_val_integer2 (u)), expr);
3790 break;
3791 #endif
3792
3793 #if FFETARGET_okINTEGER3
3794 case FFEINFO_kindtypeINTEGER3:
3795 error = ffetarget_subtract_integer3 (ffebld_cu_ptr_integer3 (u),
3796 ffebld_constant_integer3 (ffebld_conter (l)),
3797 ffebld_constant_integer3 (ffebld_conter (r)));
3798 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3799 (ffebld_cu_val_integer3 (u)), expr);
3800 break;
3801 #endif
3802
3803 #if FFETARGET_okINTEGER4
3804 case FFEINFO_kindtypeINTEGER4:
3805 error = ffetarget_subtract_integer4 (ffebld_cu_ptr_integer4 (u),
3806 ffebld_constant_integer4 (ffebld_conter (l)),
3807 ffebld_constant_integer4 (ffebld_conter (r)));
3808 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3809 (ffebld_cu_val_integer4 (u)), expr);
3810 break;
3811 #endif
3812
3813 default:
3814 assert ("bad integer kind type" == NULL);
3815 break;
3816 }
3817 break;
3818
3819 case FFEINFO_basictypeREAL:
3820 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3821 {
3822 #if FFETARGET_okREAL1
3823 case FFEINFO_kindtypeREAL1:
3824 error = ffetarget_subtract_real1 (ffebld_cu_ptr_real1 (u),
3825 ffebld_constant_real1 (ffebld_conter (l)),
3826 ffebld_constant_real1 (ffebld_conter (r)));
3827 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3828 (ffebld_cu_val_real1 (u)), expr);
3829 break;
3830 #endif
3831
3832 #if FFETARGET_okREAL2
3833 case FFEINFO_kindtypeREAL2:
3834 error = ffetarget_subtract_real2 (ffebld_cu_ptr_real2 (u),
3835 ffebld_constant_real2 (ffebld_conter (l)),
3836 ffebld_constant_real2 (ffebld_conter (r)));
3837 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3838 (ffebld_cu_val_real2 (u)), expr);
3839 break;
3840 #endif
3841
3842 #if FFETARGET_okREAL3
3843 case FFEINFO_kindtypeREAL3:
3844 error = ffetarget_subtract_real3 (ffebld_cu_ptr_real3 (u),
3845 ffebld_constant_real3 (ffebld_conter (l)),
3846 ffebld_constant_real3 (ffebld_conter (r)));
3847 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3848 (ffebld_cu_val_real3 (u)), expr);
3849 break;
3850 #endif
3851
3852 #if FFETARGET_okREAL4
3853 case FFEINFO_kindtypeREAL4:
3854 error = ffetarget_subtract_real4 (ffebld_cu_ptr_real4 (u),
3855 ffebld_constant_real4 (ffebld_conter (l)),
3856 ffebld_constant_real4 (ffebld_conter (r)));
3857 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
3858 (ffebld_cu_val_real4 (u)), expr);
3859 break;
3860 #endif
3861
3862 default:
3863 assert ("bad real kind type" == NULL);
3864 break;
3865 }
3866 break;
3867
3868 case FFEINFO_basictypeCOMPLEX:
3869 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3870 {
3871 #if FFETARGET_okCOMPLEX1
3872 case FFEINFO_kindtypeREAL1:
3873 error = ffetarget_subtract_complex1 (ffebld_cu_ptr_complex1 (u),
3874 ffebld_constant_complex1 (ffebld_conter (l)),
3875 ffebld_constant_complex1 (ffebld_conter (r)));
3876 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3877 (ffebld_cu_val_complex1 (u)), expr);
3878 break;
3879 #endif
3880
3881 #if FFETARGET_okCOMPLEX2
3882 case FFEINFO_kindtypeREAL2:
3883 error = ffetarget_subtract_complex2 (ffebld_cu_ptr_complex2 (u),
3884 ffebld_constant_complex2 (ffebld_conter (l)),
3885 ffebld_constant_complex2 (ffebld_conter (r)));
3886 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3887 (ffebld_cu_val_complex2 (u)), expr);
3888 break;
3889 #endif
3890
3891 #if FFETARGET_okCOMPLEX3
3892 case FFEINFO_kindtypeREAL3:
3893 error = ffetarget_subtract_complex3 (ffebld_cu_ptr_complex3 (u),
3894 ffebld_constant_complex3 (ffebld_conter (l)),
3895 ffebld_constant_complex3 (ffebld_conter (r)));
3896 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3897 (ffebld_cu_val_complex3 (u)), expr);
3898 break;
3899 #endif
3900
3901 #if FFETARGET_okCOMPLEX4
3902 case FFEINFO_kindtypeREAL4:
3903 error = ffetarget_subtract_complex4 (ffebld_cu_ptr_complex4 (u),
3904 ffebld_constant_complex4 (ffebld_conter (l)),
3905 ffebld_constant_complex4 (ffebld_conter (r)));
3906 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
3907 (ffebld_cu_val_complex4 (u)), expr);
3908 break;
3909 #endif
3910
3911 default:
3912 assert ("bad complex kind type" == NULL);
3913 break;
3914 }
3915 break;
3916
3917 default:
3918 assert ("bad type" == NULL);
3919 return expr;
3920 }
3921
3922 ffebld_set_info (expr, ffeinfo_new
3923 (bt,
3924 kt,
3925 0,
3926 FFEINFO_kindENTITY,
3927 FFEINFO_whereCONSTANT,
3928 FFETARGET_charactersizeNONE));
3929
3930 if ((error != FFEBAD)
3931 && ffebad_start (error))
3932 {
3933 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3934 ffebad_finish ();
3935 }
3936
3937 return expr;
3938 }
3939
3940 /* ffeexpr_collapse_multiply -- Collapse multiply expr
3941
3942 ffebld expr;
3943 ffelexToken token;
3944 expr = ffeexpr_collapse_multiply(expr,token);
3945
3946 If the result of the expr is a constant, replaces the expr with the
3947 computed constant. */
3948
3949 ffebld
3950 ffeexpr_collapse_multiply (ffebld expr, ffelexToken t)
3951 {
3952 ffebad error = FFEBAD;
3953 ffebld l;
3954 ffebld r;
3955 ffebldConstantUnion u;
3956 ffeinfoBasictype bt;
3957 ffeinfoKindtype kt;
3958
3959 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3960 return expr;
3961
3962 l = ffebld_left (expr);
3963 r = ffebld_right (expr);
3964
3965 if (ffebld_op (l) != FFEBLD_opCONTER)
3966 return expr;
3967 if (ffebld_op (r) != FFEBLD_opCONTER)
3968 return expr;
3969
3970 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3971 {
3972 case FFEINFO_basictypeANY:
3973 return expr;
3974
3975 case FFEINFO_basictypeINTEGER:
3976 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3977 {
3978 #if FFETARGET_okINTEGER1
3979 case FFEINFO_kindtypeINTEGER1:
3980 error = ffetarget_multiply_integer1 (ffebld_cu_ptr_integer1 (u),
3981 ffebld_constant_integer1 (ffebld_conter (l)),
3982 ffebld_constant_integer1 (ffebld_conter (r)));
3983 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3984 (ffebld_cu_val_integer1 (u)), expr);
3985 break;
3986 #endif
3987
3988 #if FFETARGET_okINTEGER2
3989 case FFEINFO_kindtypeINTEGER2:
3990 error = ffetarget_multiply_integer2 (ffebld_cu_ptr_integer2 (u),
3991 ffebld_constant_integer2 (ffebld_conter (l)),
3992 ffebld_constant_integer2 (ffebld_conter (r)));
3993 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3994 (ffebld_cu_val_integer2 (u)), expr);
3995 break;
3996 #endif
3997
3998 #if FFETARGET_okINTEGER3
3999 case FFEINFO_kindtypeINTEGER3:
4000 error = ffetarget_multiply_integer3 (ffebld_cu_ptr_integer3 (u),
4001 ffebld_constant_integer3 (ffebld_conter (l)),
4002 ffebld_constant_integer3 (ffebld_conter (r)));
4003 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
4004 (ffebld_cu_val_integer3 (u)), expr);
4005 break;
4006 #endif
4007
4008 #if FFETARGET_okINTEGER4
4009 case FFEINFO_kindtypeINTEGER4:
4010 error = ffetarget_multiply_integer4 (ffebld_cu_ptr_integer4 (u),
4011 ffebld_constant_integer4 (ffebld_conter (l)),
4012 ffebld_constant_integer4 (ffebld_conter (r)));
4013 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
4014 (ffebld_cu_val_integer4 (u)), expr);
4015 break;
4016 #endif
4017
4018 default:
4019 assert ("bad integer kind type" == NULL);
4020 break;
4021 }
4022 break;
4023
4024 case FFEINFO_basictypeREAL:
4025 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4026 {
4027 #if FFETARGET_okREAL1
4028 case FFEINFO_kindtypeREAL1:
4029 error = ffetarget_multiply_real1 (ffebld_cu_ptr_real1 (u),
4030 ffebld_constant_real1 (ffebld_conter (l)),
4031 ffebld_constant_real1 (ffebld_conter (r)));
4032 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
4033 (ffebld_cu_val_real1 (u)), expr);
4034 break;
4035 #endif
4036
4037 #if FFETARGET_okREAL2
4038 case FFEINFO_kindtypeREAL2:
4039 error = ffetarget_multiply_real2 (ffebld_cu_ptr_real2 (u),
4040 ffebld_constant_real2 (ffebld_conter (l)),
4041 ffebld_constant_real2 (ffebld_conter (r)));
4042 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
4043 (ffebld_cu_val_real2 (u)), expr);
4044 break;
4045 #endif
4046
4047 #if FFETARGET_okREAL3
4048 case FFEINFO_kindtypeREAL3:
4049 error = ffetarget_multiply_real3 (ffebld_cu_ptr_real3 (u),
4050 ffebld_constant_real3 (ffebld_conter (l)),
4051 ffebld_constant_real3 (ffebld_conter (r)));
4052 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
4053 (ffebld_cu_val_real3 (u)), expr);
4054 break;
4055 #endif
4056
4057 #if FFETARGET_okREAL4
4058 case FFEINFO_kindtypeREAL4:
4059 error = ffetarget_multiply_real4 (ffebld_cu_ptr_real4 (u),
4060 ffebld_constant_real4 (ffebld_conter (l)),
4061 ffebld_constant_real4 (ffebld_conter (r)));
4062 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
4063 (ffebld_cu_val_real4 (u)), expr);
4064 break;
4065 #endif
4066
4067 default:
4068 assert ("bad real kind type" == NULL);
4069 break;
4070 }
4071 break;
4072
4073 case FFEINFO_basictypeCOMPLEX:
4074 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4075 {
4076 #if FFETARGET_okCOMPLEX1
4077 case FFEINFO_kindtypeREAL1:
4078 error = ffetarget_multiply_complex1 (ffebld_cu_ptr_complex1 (u),
4079 ffebld_constant_complex1 (ffebld_conter (l)),
4080 ffebld_constant_complex1 (ffebld_conter (r)));
4081 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
4082 (ffebld_cu_val_complex1 (u)), expr);
4083 break;
4084 #endif
4085
4086 #if FFETARGET_okCOMPLEX2
4087 case FFEINFO_kindtypeREAL2:
4088 error = ffetarget_multiply_complex2 (ffebld_cu_ptr_complex2 (u),
4089 ffebld_constant_complex2 (ffebld_conter (l)),
4090 ffebld_constant_complex2 (ffebld_conter (r)));
4091 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
4092 (ffebld_cu_val_complex2 (u)), expr);
4093 break;
4094 #endif
4095
4096 #if FFETARGET_okCOMPLEX3
4097 case FFEINFO_kindtypeREAL3:
4098 error = ffetarget_multiply_complex3 (ffebld_cu_ptr_complex3 (u),
4099 ffebld_constant_complex3 (ffebld_conter (l)),
4100 ffebld_constant_complex3 (ffebld_conter (r)));
4101 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
4102 (ffebld_cu_val_complex3 (u)), expr);
4103 break;
4104 #endif
4105
4106 #if FFETARGET_okCOMPLEX4
4107 case FFEINFO_kindtypeREAL4:
4108 error = ffetarget_multiply_complex4 (ffebld_cu_ptr_complex4 (u),
4109 ffebld_constant_complex4 (ffebld_conter (l)),
4110 ffebld_constant_complex4 (ffebld_conter (r)));
4111 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
4112 (ffebld_cu_val_complex4 (u)), expr);
4113 break;
4114 #endif
4115
4116 default:
4117 assert ("bad complex kind type" == NULL);
4118 break;
4119 }
4120 break;
4121
4122 default:
4123 assert ("bad type" == NULL);
4124 return expr;
4125 }
4126
4127 ffebld_set_info (expr, ffeinfo_new
4128 (bt,
4129 kt,
4130 0,
4131 FFEINFO_kindENTITY,
4132 FFEINFO_whereCONSTANT,
4133 FFETARGET_charactersizeNONE));
4134
4135 if ((error != FFEBAD)
4136 && ffebad_start (error))
4137 {
4138 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4139 ffebad_finish ();
4140 }
4141
4142 return expr;
4143 }
4144
4145 /* ffeexpr_collapse_divide -- Collapse divide expr
4146
4147 ffebld expr;
4148 ffelexToken token;
4149 expr = ffeexpr_collapse_divide(expr,token);
4150
4151 If the result of the expr is a constant, replaces the expr with the
4152 computed constant. */
4153
4154 ffebld
4155 ffeexpr_collapse_divide (ffebld expr, ffelexToken t)
4156 {
4157 ffebad error = FFEBAD;
4158 ffebld l;
4159 ffebld r;
4160 ffebldConstantUnion u;
4161 ffeinfoBasictype bt;
4162 ffeinfoKindtype kt;
4163
4164 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4165 return expr;
4166
4167 l = ffebld_left (expr);
4168 r = ffebld_right (expr);
4169
4170 if (ffebld_op (l) != FFEBLD_opCONTER)
4171 return expr;
4172 if (ffebld_op (r) != FFEBLD_opCONTER)
4173 return expr;
4174
4175 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
4176 {
4177 case FFEINFO_basictypeANY:
4178 return expr;
4179
4180 case FFEINFO_basictypeINTEGER:
4181 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4182 {
4183 #if FFETARGET_okINTEGER1
4184 case FFEINFO_kindtypeINTEGER1:
4185 error = ffetarget_divide_integer1 (ffebld_cu_ptr_integer1 (u),
4186 ffebld_constant_integer1 (ffebld_conter (l)),
4187 ffebld_constant_integer1 (ffebld_conter (r)));
4188 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
4189 (ffebld_cu_val_integer1 (u)), expr);
4190 break;
4191 #endif
4192
4193 #if FFETARGET_okINTEGER2
4194 case FFEINFO_kindtypeINTEGER2:
4195 error = ffetarget_divide_integer2 (ffebld_cu_ptr_integer2 (u),
4196 ffebld_constant_integer2 (ffebld_conter (l)),
4197 ffebld_constant_integer2 (ffebld_conter (r)));
4198 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
4199 (ffebld_cu_val_integer2 (u)), expr);
4200 break;
4201 #endif
4202
4203 #if FFETARGET_okINTEGER3
4204 case FFEINFO_kindtypeINTEGER3:
4205 error = ffetarget_divide_integer3 (ffebld_cu_ptr_integer3 (u),
4206 ffebld_constant_integer3 (ffebld_conter (l)),
4207 ffebld_constant_integer3 (ffebld_conter (r)));
4208 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
4209 (ffebld_cu_val_integer3 (u)), expr);
4210 break;
4211 #endif
4212
4213 #if FFETARGET_okINTEGER4
4214 case FFEINFO_kindtypeINTEGER4:
4215 error = ffetarget_divide_integer4 (ffebld_cu_ptr_integer4 (u),
4216 ffebld_constant_integer4 (ffebld_conter (l)),
4217 ffebld_constant_integer4 (ffebld_conter (r)));
4218 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
4219 (ffebld_cu_val_integer4 (u)), expr);
4220 break;
4221 #endif
4222
4223 default:
4224 assert ("bad integer kind type" == NULL);
4225 break;
4226 }
4227 break;
4228
4229 case FFEINFO_basictypeREAL:
4230 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4231 {
4232 #if FFETARGET_okREAL1
4233 case FFEINFO_kindtypeREAL1:
4234 error = ffetarget_divide_real1 (ffebld_cu_ptr_real1 (u),
4235 ffebld_constant_real1 (ffebld_conter (l)),
4236 ffebld_constant_real1 (ffebld_conter (r)));
4237 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
4238 (ffebld_cu_val_real1 (u)), expr);
4239 break;
4240 #endif
4241
4242 #if FFETARGET_okREAL2
4243 case FFEINFO_kindtypeREAL2:
4244 error = ffetarget_divide_real2 (ffebld_cu_ptr_real2 (u),
4245 ffebld_constant_real2 (ffebld_conter (l)),
4246 ffebld_constant_real2 (ffebld_conter (r)));
4247 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
4248 (ffebld_cu_val_real2 (u)), expr);
4249 break;
4250 #endif
4251
4252 #if FFETARGET_okREAL3
4253 case FFEINFO_kindtypeREAL3:
4254 error = ffetarget_divide_real3 (ffebld_cu_ptr_real3 (u),
4255 ffebld_constant_real3 (ffebld_conter (l)),
4256 ffebld_constant_real3 (ffebld_conter (r)));
4257 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
4258 (ffebld_cu_val_real3 (u)), expr);
4259 break;
4260 #endif
4261
4262 #if FFETARGET_okREAL4
4263 case FFEINFO_kindtypeREAL4:
4264 error = ffetarget_divide_real4 (ffebld_cu_ptr_real4 (u),
4265 ffebld_constant_real4 (ffebld_conter (l)),
4266 ffebld_constant_real4 (ffebld_conter (r)));
4267 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
4268 (ffebld_cu_val_real4 (u)), expr);
4269 break;
4270 #endif
4271
4272 default:
4273 assert ("bad real kind type" == NULL);
4274 break;
4275 }
4276 break;
4277
4278 case FFEINFO_basictypeCOMPLEX:
4279 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4280 {
4281 #if FFETARGET_okCOMPLEX1
4282 case FFEINFO_kindtypeREAL1:
4283 error = ffetarget_divide_complex1 (ffebld_cu_ptr_complex1 (u),
4284 ffebld_constant_complex1 (ffebld_conter (l)),
4285 ffebld_constant_complex1 (ffebld_conter (r)));
4286 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
4287 (ffebld_cu_val_complex1 (u)), expr);
4288 break;
4289 #endif
4290
4291 #if FFETARGET_okCOMPLEX2
4292 case FFEINFO_kindtypeREAL2:
4293 error = ffetarget_divide_complex2 (ffebld_cu_ptr_complex2 (u),
4294 ffebld_constant_complex2 (ffebld_conter (l)),
4295 ffebld_constant_complex2 (ffebld_conter (r)));
4296 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
4297 (ffebld_cu_val_complex2 (u)), expr);
4298 break;
4299 #endif
4300
4301 #if FFETARGET_okCOMPLEX3
4302 case FFEINFO_kindtypeREAL3:
4303 error = ffetarget_divide_complex3 (ffebld_cu_ptr_complex3 (u),
4304 ffebld_constant_complex3 (ffebld_conter (l)),
4305 ffebld_constant_complex3 (ffebld_conter (r)));
4306 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
4307 (ffebld_cu_val_complex3 (u)), expr);
4308 break;
4309 #endif
4310
4311 #if FFETARGET_okCOMPLEX4
4312 case FFEINFO_kindtypeREAL4:
4313 error = ffetarget_divide_complex4 (ffebld_cu_ptr_complex4 (u),
4314 ffebld_constant_complex4 (ffebld_conter (l)),
4315 ffebld_constant_complex4 (ffebld_conter (r)));
4316 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
4317 (ffebld_cu_val_complex4 (u)), expr);
4318 break;
4319 #endif
4320
4321 default:
4322 assert ("bad complex kind type" == NULL);
4323 break;
4324 }
4325 break;
4326
4327 default:
4328 assert ("bad type" == NULL);
4329 return expr;
4330 }
4331
4332 ffebld_set_info (expr, ffeinfo_new
4333 (bt,
4334 kt,
4335 0,
4336 FFEINFO_kindENTITY,
4337 FFEINFO_whereCONSTANT,
4338 FFETARGET_charactersizeNONE));
4339
4340 if ((error != FFEBAD)
4341 && ffebad_start (error))
4342 {
4343 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4344 ffebad_finish ();
4345 }
4346
4347 return expr;
4348 }
4349
4350 /* ffeexpr_collapse_power -- Collapse power expr
4351
4352 ffebld expr;
4353 ffelexToken token;
4354 expr = ffeexpr_collapse_power(expr,token);
4355
4356 If the result of the expr is a constant, replaces the expr with the
4357 computed constant. */
4358
4359 ffebld
4360 ffeexpr_collapse_power (ffebld expr, ffelexToken t)
4361 {
4362 ffebad error = FFEBAD;
4363 ffebld l;
4364 ffebld r;
4365 ffebldConstantUnion u;
4366 ffeinfoBasictype bt;
4367 ffeinfoKindtype kt;
4368
4369 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4370 return expr;
4371
4372 l = ffebld_left (expr);
4373 r = ffebld_right (expr);
4374
4375 if (ffebld_op (l) != FFEBLD_opCONTER)
4376 return expr;
4377 if (ffebld_op (r) != FFEBLD_opCONTER)
4378 return expr;
4379
4380 if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER)
4381 || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT))
4382 return expr;
4383
4384 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
4385 {
4386 case FFEINFO_basictypeANY:
4387 return expr;
4388
4389 case FFEINFO_basictypeINTEGER:
4390 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4391 {
4392 case FFEINFO_kindtypeINTEGERDEFAULT:
4393 error = ffetarget_power_integerdefault_integerdefault
4394 (ffebld_cu_ptr_integerdefault (u),
4395 ffebld_constant_integerdefault (ffebld_conter (l)),
4396 ffebld_constant_integerdefault (ffebld_conter (r)));
4397 expr = ffebld_new_conter_with_orig
4398 (ffebld_constant_new_integerdefault_val
4399 (ffebld_cu_val_integerdefault (u)), expr);
4400 break;
4401
4402 default:
4403 assert ("bad integer kind type" == NULL);
4404 break;
4405 }
4406 break;
4407
4408 case FFEINFO_basictypeREAL:
4409 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4410 {
4411 case FFEINFO_kindtypeREALDEFAULT:
4412 error = ffetarget_power_realdefault_integerdefault
4413 (ffebld_cu_ptr_realdefault (u),
4414 ffebld_constant_realdefault (ffebld_conter (l)),
4415 ffebld_constant_integerdefault (ffebld_conter (r)));
4416 expr = ffebld_new_conter_with_orig
4417 (ffebld_constant_new_realdefault_val
4418 (ffebld_cu_val_realdefault (u)), expr);
4419 break;
4420
4421 case FFEINFO_kindtypeREALDOUBLE:
4422 error = ffetarget_power_realdouble_integerdefault
4423 (ffebld_cu_ptr_realdouble (u),
4424 ffebld_constant_realdouble (ffebld_conter (l)),
4425 ffebld_constant_integerdefault (ffebld_conter (r)));
4426 expr = ffebld_new_conter_with_orig
4427 (ffebld_constant_new_realdouble_val
4428 (ffebld_cu_val_realdouble (u)), expr);
4429 break;
4430
4431 #if FFETARGET_okREALQUAD
4432 case FFEINFO_kindtypeREALQUAD:
4433 error = ffetarget_power_realquad_integerdefault
4434 (ffebld_cu_ptr_realquad (u),
4435 ffebld_constant_realquad (ffebld_conter (l)),
4436 ffebld_constant_integerdefault (ffebld_conter (r)));
4437 expr = ffebld_new_conter_with_orig
4438 (ffebld_constant_new_realquad_val
4439 (ffebld_cu_val_realquad (u)), expr);
4440 break;
4441 #endif
4442 default:
4443 assert ("bad real kind type" == NULL);
4444 break;
4445 }
4446 break;
4447
4448 case FFEINFO_basictypeCOMPLEX:
4449 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4450 {
4451 case FFEINFO_kindtypeREALDEFAULT:
4452 error = ffetarget_power_complexdefault_integerdefault
4453 (ffebld_cu_ptr_complexdefault (u),
4454 ffebld_constant_complexdefault (ffebld_conter (l)),
4455 ffebld_constant_integerdefault (ffebld_conter (r)));
4456 expr = ffebld_new_conter_with_orig
4457 (ffebld_constant_new_complexdefault_val
4458 (ffebld_cu_val_complexdefault (u)), expr);
4459 break;
4460
4461 #if FFETARGET_okCOMPLEXDOUBLE
4462 case FFEINFO_kindtypeREALDOUBLE:
4463 error = ffetarget_power_complexdouble_integerdefault
4464 (ffebld_cu_ptr_complexdouble (u),
4465 ffebld_constant_complexdouble (ffebld_conter (l)),
4466 ffebld_constant_integerdefault (ffebld_conter (r)));
4467 expr = ffebld_new_conter_with_orig
4468 (ffebld_constant_new_complexdouble_val
4469 (ffebld_cu_val_complexdouble (u)), expr);
4470 break;
4471 #endif
4472
4473 #if FFETARGET_okCOMPLEXQUAD
4474 case FFEINFO_kindtypeREALQUAD:
4475 error = ffetarget_power_complexquad_integerdefault
4476 (ffebld_cu_ptr_complexquad (u),
4477 ffebld_constant_complexquad (ffebld_conter (l)),
4478 ffebld_constant_integerdefault (ffebld_conter (r)));
4479 expr = ffebld_new_conter_with_orig
4480 (ffebld_constant_new_complexquad_val
4481 (ffebld_cu_val_complexquad (u)), expr);
4482 break;
4483 #endif
4484
4485 default:
4486 assert ("bad complex kind type" == NULL);
4487 break;
4488 }
4489 break;
4490
4491 default:
4492 assert ("bad type" == NULL);
4493 return expr;
4494 }
4495
4496 ffebld_set_info (expr, ffeinfo_new
4497 (bt,
4498 kt,
4499 0,
4500 FFEINFO_kindENTITY,
4501 FFEINFO_whereCONSTANT,
4502 FFETARGET_charactersizeNONE));
4503
4504 if ((error != FFEBAD)
4505 && ffebad_start (error))
4506 {
4507 ffebad_here (0, ffelex_token_where_line (t),
4508 ffelex_token_where_column (t));
4509 ffebad_finish ();
4510 }
4511
4512 return expr;
4513 }
4514
4515 /* ffeexpr_collapse_concatenate -- Collapse concatenate expr
4516
4517 ffebld expr;
4518 ffelexToken token;
4519 expr = ffeexpr_collapse_concatenate(expr,token);
4520
4521 If the result of the expr is a constant, replaces the expr with the
4522 computed constant. */
4523
4524 ffebld
4525 ffeexpr_collapse_concatenate (ffebld expr, ffelexToken t)
4526 {
4527 ffebad error = FFEBAD;
4528 ffebld l;
4529 ffebld r;
4530 ffebldConstantUnion u;
4531 ffeinfoKindtype kt;
4532 ffetargetCharacterSize len;
4533
4534 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4535 return expr;
4536
4537 l = ffebld_left (expr);
4538 r = ffebld_right (expr);
4539
4540 if (ffebld_op (l) != FFEBLD_opCONTER)
4541 return expr;
4542 if (ffebld_op (r) != FFEBLD_opCONTER)
4543 return expr;
4544
4545 switch (ffeinfo_basictype (ffebld_info (expr)))
4546 {
4547 case FFEINFO_basictypeANY:
4548 return expr;
4549
4550 case FFEINFO_basictypeCHARACTER:
4551 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4552 {
4553 #if FFETARGET_okCHARACTER1
4554 case FFEINFO_kindtypeCHARACTER1:
4555 error = ffetarget_concatenate_character1 (ffebld_cu_ptr_character1 (u),
4556 ffebld_constant_character1 (ffebld_conter (l)),
4557 ffebld_constant_character1 (ffebld_conter (r)),
4558 ffebld_constant_pool (), &len);
4559 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
4560 (ffebld_cu_val_character1 (u)), expr);
4561 break;
4562 #endif
4563
4564 #if FFETARGET_okCHARACTER2
4565 case FFEINFO_kindtypeCHARACTER2:
4566 error = ffetarget_concatenate_character2 (ffebld_cu_ptr_character2 (u),
4567 ffebld_constant_character2 (ffebld_conter (l)),
4568 ffebld_constant_character2 (ffebld_conter (r)),
4569 ffebld_constant_pool (), &len);
4570 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val
4571 (ffebld_cu_val_character2 (u)), expr);
4572 break;
4573 #endif
4574
4575 #if FFETARGET_okCHARACTER3
4576 case FFEINFO_kindtypeCHARACTER3:
4577 error = ffetarget_concatenate_character3 (ffebld_cu_ptr_character3 (u),
4578 ffebld_constant_character3 (ffebld_conter (l)),
4579 ffebld_constant_character3 (ffebld_conter (r)),
4580 ffebld_constant_pool (), &len);
4581 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val
4582 (ffebld_cu_val_character3 (u)), expr);
4583 break;
4584 #endif
4585
4586 #if FFETARGET_okCHARACTER4
4587 case FFEINFO_kindtypeCHARACTER4:
4588 error = ffetarget_concatenate_character4 (ffebld_cu_ptr_character4 (u),
4589 ffebld_constant_character4 (ffebld_conter (l)),
4590 ffebld_constant_character4 (ffebld_conter (r)),
4591 ffebld_constant_pool (), &len);
4592 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val
4593 (ffebld_cu_val_character4 (u)), expr);
4594 break;
4595 #endif
4596
4597 default:
4598 assert ("bad character kind type" == NULL);
4599 break;
4600 }
4601 break;
4602
4603 default:
4604 assert ("bad type" == NULL);
4605 return expr;
4606 }
4607
4608 ffebld_set_info (expr, ffeinfo_new
4609 (FFEINFO_basictypeCHARACTER,
4610 kt,
4611 0,
4612 FFEINFO_kindENTITY,
4613 FFEINFO_whereCONSTANT,
4614 len));
4615
4616 if ((error != FFEBAD)
4617 && ffebad_start (error))
4618 {
4619 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4620 ffebad_finish ();
4621 }
4622
4623 return expr;
4624 }
4625
4626 /* ffeexpr_collapse_eq -- Collapse eq expr
4627
4628 ffebld expr;
4629 ffelexToken token;
4630 expr = ffeexpr_collapse_eq(expr,token);
4631
4632 If the result of the expr is a constant, replaces the expr with the
4633 computed constant. */
4634
4635 ffebld
4636 ffeexpr_collapse_eq (ffebld expr, ffelexToken t)
4637 {
4638 ffebad error = FFEBAD;
4639 ffebld l;
4640 ffebld r;
4641 bool val;
4642
4643 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4644 return expr;
4645
4646 l = ffebld_left (expr);
4647 r = ffebld_right (expr);
4648
4649 if (ffebld_op (l) != FFEBLD_opCONTER)
4650 return expr;
4651 if (ffebld_op (r) != FFEBLD_opCONTER)
4652 return expr;
4653
4654 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4655 {
4656 case FFEINFO_basictypeANY:
4657 return expr;
4658
4659 case FFEINFO_basictypeINTEGER:
4660 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4661 {
4662 #if FFETARGET_okINTEGER1
4663 case FFEINFO_kindtypeINTEGER1:
4664 error = ffetarget_eq_integer1 (&val,
4665 ffebld_constant_integer1 (ffebld_conter (l)),
4666 ffebld_constant_integer1 (ffebld_conter (r)));
4667 expr = ffebld_new_conter_with_orig
4668 (ffebld_constant_new_logicaldefault (val), expr);
4669 break;
4670 #endif
4671
4672 #if FFETARGET_okINTEGER2
4673 case FFEINFO_kindtypeINTEGER2:
4674 error = ffetarget_eq_integer2 (&val,
4675 ffebld_constant_integer2 (ffebld_conter (l)),
4676 ffebld_constant_integer2 (ffebld_conter (r)));
4677 expr = ffebld_new_conter_with_orig
4678 (ffebld_constant_new_logicaldefault (val), expr);
4679 break;
4680 #endif
4681
4682 #if FFETARGET_okINTEGER3
4683 case FFEINFO_kindtypeINTEGER3:
4684 error = ffetarget_eq_integer3 (&val,
4685 ffebld_constant_integer3 (ffebld_conter (l)),
4686 ffebld_constant_integer3 (ffebld_conter (r)));
4687 expr = ffebld_new_conter_with_orig
4688 (ffebld_constant_new_logicaldefault (val), expr);
4689 break;
4690 #endif
4691
4692 #if FFETARGET_okINTEGER4
4693 case FFEINFO_kindtypeINTEGER4:
4694 error = ffetarget_eq_integer4 (&val,
4695 ffebld_constant_integer4 (ffebld_conter (l)),
4696 ffebld_constant_integer4 (ffebld_conter (r)));
4697 expr = ffebld_new_conter_with_orig
4698 (ffebld_constant_new_logicaldefault (val), expr);
4699 break;
4700 #endif
4701
4702 default:
4703 assert ("bad integer kind type" == NULL);
4704 break;
4705 }
4706 break;
4707
4708 case FFEINFO_basictypeREAL:
4709 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4710 {
4711 #if FFETARGET_okREAL1
4712 case FFEINFO_kindtypeREAL1:
4713 error = ffetarget_eq_real1 (&val,
4714 ffebld_constant_real1 (ffebld_conter (l)),
4715 ffebld_constant_real1 (ffebld_conter (r)));
4716 expr = ffebld_new_conter_with_orig
4717 (ffebld_constant_new_logicaldefault (val), expr);
4718 break;
4719 #endif
4720
4721 #if FFETARGET_okREAL2
4722 case FFEINFO_kindtypeREAL2:
4723 error = ffetarget_eq_real2 (&val,
4724 ffebld_constant_real2 (ffebld_conter (l)),
4725 ffebld_constant_real2 (ffebld_conter (r)));
4726 expr = ffebld_new_conter_with_orig
4727 (ffebld_constant_new_logicaldefault (val), expr);
4728 break;
4729 #endif
4730
4731 #if FFETARGET_okREAL3
4732 case FFEINFO_kindtypeREAL3:
4733 error = ffetarget_eq_real3 (&val,
4734 ffebld_constant_real3 (ffebld_conter (l)),
4735 ffebld_constant_real3 (ffebld_conter (r)));
4736 expr = ffebld_new_conter_with_orig
4737 (ffebld_constant_new_logicaldefault (val), expr);
4738 break;
4739 #endif
4740
4741 #if FFETARGET_okREAL4
4742 case FFEINFO_kindtypeREAL4:
4743 error = ffetarget_eq_real4 (&val,
4744 ffebld_constant_real4 (ffebld_conter (l)),
4745 ffebld_constant_real4 (ffebld_conter (r)));
4746 expr = ffebld_new_conter_with_orig
4747 (ffebld_constant_new_logicaldefault (val), expr);
4748 break;
4749 #endif
4750
4751 default:
4752 assert ("bad real kind type" == NULL);
4753 break;
4754 }
4755 break;
4756
4757 case FFEINFO_basictypeCOMPLEX:
4758 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4759 {
4760 #if FFETARGET_okCOMPLEX1
4761 case FFEINFO_kindtypeREAL1:
4762 error = ffetarget_eq_complex1 (&val,
4763 ffebld_constant_complex1 (ffebld_conter (l)),
4764 ffebld_constant_complex1 (ffebld_conter (r)));
4765 expr = ffebld_new_conter_with_orig
4766 (ffebld_constant_new_logicaldefault (val), expr);
4767 break;
4768 #endif
4769
4770 #if FFETARGET_okCOMPLEX2
4771 case FFEINFO_kindtypeREAL2:
4772 error = ffetarget_eq_complex2 (&val,
4773 ffebld_constant_complex2 (ffebld_conter (l)),
4774 ffebld_constant_complex2 (ffebld_conter (r)));
4775 expr = ffebld_new_conter_with_orig
4776 (ffebld_constant_new_logicaldefault (val), expr);
4777 break;
4778 #endif
4779
4780 #if FFETARGET_okCOMPLEX3
4781 case FFEINFO_kindtypeREAL3:
4782 error = ffetarget_eq_complex3 (&val,
4783 ffebld_constant_complex3 (ffebld_conter (l)),
4784 ffebld_constant_complex3 (ffebld_conter (r)));
4785 expr = ffebld_new_conter_with_orig
4786 (ffebld_constant_new_logicaldefault (val), expr);
4787 break;
4788 #endif
4789
4790 #if FFETARGET_okCOMPLEX4
4791 case FFEINFO_kindtypeREAL4:
4792 error = ffetarget_eq_complex4 (&val,
4793 ffebld_constant_complex4 (ffebld_conter (l)),
4794 ffebld_constant_complex4 (ffebld_conter (r)));
4795 expr = ffebld_new_conter_with_orig
4796 (ffebld_constant_new_logicaldefault (val), expr);
4797 break;
4798 #endif
4799
4800 default:
4801 assert ("bad complex kind type" == NULL);
4802 break;
4803 }
4804 break;
4805
4806 case FFEINFO_basictypeCHARACTER:
4807 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4808 {
4809 #if FFETARGET_okCHARACTER1
4810 case FFEINFO_kindtypeCHARACTER1:
4811 error = ffetarget_eq_character1 (&val,
4812 ffebld_constant_character1 (ffebld_conter (l)),
4813 ffebld_constant_character1 (ffebld_conter (r)));
4814 expr = ffebld_new_conter_with_orig
4815 (ffebld_constant_new_logicaldefault (val), expr);
4816 break;
4817 #endif
4818
4819 #if FFETARGET_okCHARACTER2
4820 case FFEINFO_kindtypeCHARACTER2:
4821 error = ffetarget_eq_character2 (&val,
4822 ffebld_constant_character2 (ffebld_conter (l)),
4823 ffebld_constant_character2 (ffebld_conter (r)));
4824 expr = ffebld_new_conter_with_orig
4825 (ffebld_constant_new_logicaldefault (val), expr);
4826 break;
4827 #endif
4828
4829 #if FFETARGET_okCHARACTER3
4830 case FFEINFO_kindtypeCHARACTER3:
4831 error = ffetarget_eq_character3 (&val,
4832 ffebld_constant_character3 (ffebld_conter (l)),
4833 ffebld_constant_character3 (ffebld_conter (r)));
4834 expr = ffebld_new_conter_with_orig
4835 (ffebld_constant_new_logicaldefault (val), expr);
4836 break;
4837 #endif
4838
4839 #if FFETARGET_okCHARACTER4
4840 case FFEINFO_kindtypeCHARACTER4:
4841 error = ffetarget_eq_character4 (&val,
4842 ffebld_constant_character4 (ffebld_conter (l)),
4843 ffebld_constant_character4 (ffebld_conter (r)));
4844 expr = ffebld_new_conter_with_orig
4845 (ffebld_constant_new_logicaldefault (val), expr);
4846 break;
4847 #endif
4848
4849 default:
4850 assert ("bad character kind type" == NULL);
4851 break;
4852 }
4853 break;
4854
4855 default:
4856 assert ("bad type" == NULL);
4857 return expr;
4858 }
4859
4860 ffebld_set_info (expr, ffeinfo_new
4861 (FFEINFO_basictypeLOGICAL,
4862 FFEINFO_kindtypeLOGICALDEFAULT,
4863 0,
4864 FFEINFO_kindENTITY,
4865 FFEINFO_whereCONSTANT,
4866 FFETARGET_charactersizeNONE));
4867
4868 if ((error != FFEBAD)
4869 && ffebad_start (error))
4870 {
4871 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4872 ffebad_finish ();
4873 }
4874
4875 return expr;
4876 }
4877
4878 /* ffeexpr_collapse_ne -- Collapse ne expr
4879
4880 ffebld expr;
4881 ffelexToken token;
4882 expr = ffeexpr_collapse_ne(expr,token);
4883
4884 If the result of the expr is a constant, replaces the expr with the
4885 computed constant. */
4886
4887 ffebld
4888 ffeexpr_collapse_ne (ffebld expr, ffelexToken t)
4889 {
4890 ffebad error = FFEBAD;
4891 ffebld l;
4892 ffebld r;
4893 bool val;
4894
4895 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4896 return expr;
4897
4898 l = ffebld_left (expr);
4899 r = ffebld_right (expr);
4900
4901 if (ffebld_op (l) != FFEBLD_opCONTER)
4902 return expr;
4903 if (ffebld_op (r) != FFEBLD_opCONTER)
4904 return expr;
4905
4906 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4907 {
4908 case FFEINFO_basictypeANY:
4909 return expr;
4910
4911 case FFEINFO_basictypeINTEGER:
4912 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4913 {
4914 #if FFETARGET_okINTEGER1
4915 case FFEINFO_kindtypeINTEGER1:
4916 error = ffetarget_ne_integer1 (&val,
4917 ffebld_constant_integer1 (ffebld_conter (l)),
4918 ffebld_constant_integer1 (ffebld_conter (r)));
4919 expr = ffebld_new_conter_with_orig
4920 (ffebld_constant_new_logicaldefault (val), expr);
4921 break;
4922 #endif
4923
4924 #if FFETARGET_okINTEGER2
4925 case FFEINFO_kindtypeINTEGER2:
4926 error = ffetarget_ne_integer2 (&val,
4927 ffebld_constant_integer2 (ffebld_conter (l)),
4928 ffebld_constant_integer2 (ffebld_conter (r)));
4929 expr = ffebld_new_conter_with_orig
4930 (ffebld_constant_new_logicaldefault (val), expr);
4931 break;
4932 #endif
4933
4934 #if FFETARGET_okINTEGER3
4935 case FFEINFO_kindtypeINTEGER3:
4936 error = ffetarget_ne_integer3 (&val,
4937 ffebld_constant_integer3 (ffebld_conter (l)),
4938 ffebld_constant_integer3 (ffebld_conter (r)));
4939 expr = ffebld_new_conter_with_orig
4940 (ffebld_constant_new_logicaldefault (val), expr);
4941 break;
4942 #endif
4943
4944 #if FFETARGET_okINTEGER4
4945 case FFEINFO_kindtypeINTEGER4:
4946 error = ffetarget_ne_integer4 (&val,
4947 ffebld_constant_integer4 (ffebld_conter (l)),
4948 ffebld_constant_integer4 (ffebld_conter (r)));
4949 expr = ffebld_new_conter_with_orig
4950 (ffebld_constant_new_logicaldefault (val), expr);
4951 break;
4952 #endif
4953
4954 default:
4955 assert ("bad integer kind type" == NULL);
4956 break;
4957 }
4958 break;
4959
4960 case FFEINFO_basictypeREAL:
4961 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4962 {
4963 #if FFETARGET_okREAL1
4964 case FFEINFO_kindtypeREAL1:
4965 error = ffetarget_ne_real1 (&val,
4966 ffebld_constant_real1 (ffebld_conter (l)),
4967 ffebld_constant_real1 (ffebld_conter (r)));
4968 expr = ffebld_new_conter_with_orig
4969 (ffebld_constant_new_logicaldefault (val), expr);
4970 break;
4971 #endif
4972
4973 #if FFETARGET_okREAL2
4974 case FFEINFO_kindtypeREAL2:
4975 error = ffetarget_ne_real2 (&val,
4976 ffebld_constant_real2 (ffebld_conter (l)),
4977 ffebld_constant_real2 (ffebld_conter (r)));
4978 expr = ffebld_new_conter_with_orig
4979 (ffebld_constant_new_logicaldefault (val), expr);
4980 break;
4981 #endif
4982
4983 #if FFETARGET_okREAL3
4984 case FFEINFO_kindtypeREAL3:
4985 error = ffetarget_ne_real3 (&val,
4986 ffebld_constant_real3 (ffebld_conter (l)),
4987 ffebld_constant_real3 (ffebld_conter (r)));
4988 expr = ffebld_new_conter_with_orig
4989 (ffebld_constant_new_logicaldefault (val), expr);
4990 break;
4991 #endif
4992
4993 #if FFETARGET_okREAL4
4994 case FFEINFO_kindtypeREAL4:
4995 error = ffetarget_ne_real4 (&val,
4996 ffebld_constant_real4 (ffebld_conter (l)),
4997 ffebld_constant_real4 (ffebld_conter (r)));
4998 expr = ffebld_new_conter_with_orig
4999 (ffebld_constant_new_logicaldefault (val), expr);
5000 break;
5001 #endif
5002
5003 default:
5004 assert ("bad real kind type" == NULL);
5005 break;
5006 }
5007 break;
5008
5009 case FFEINFO_basictypeCOMPLEX:
5010 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5011 {
5012 #if FFETARGET_okCOMPLEX1
5013 case FFEINFO_kindtypeREAL1:
5014 error = ffetarget_ne_complex1 (&val,
5015 ffebld_constant_complex1 (ffebld_conter (l)),
5016 ffebld_constant_complex1 (ffebld_conter (r)));
5017 expr = ffebld_new_conter_with_orig
5018 (ffebld_constant_new_logicaldefault (val), expr);
5019 break;
5020 #endif
5021
5022 #if FFETARGET_okCOMPLEX2
5023 case FFEINFO_kindtypeREAL2:
5024 error = ffetarget_ne_complex2 (&val,
5025 ffebld_constant_complex2 (ffebld_conter (l)),
5026 ffebld_constant_complex2 (ffebld_conter (r)));
5027 expr = ffebld_new_conter_with_orig
5028 (ffebld_constant_new_logicaldefault (val), expr);
5029 break;
5030 #endif
5031
5032 #if FFETARGET_okCOMPLEX3
5033 case FFEINFO_kindtypeREAL3:
5034 error = ffetarget_ne_complex3 (&val,
5035 ffebld_constant_complex3 (ffebld_conter (l)),
5036 ffebld_constant_complex3 (ffebld_conter (r)));
5037 expr = ffebld_new_conter_with_orig
5038 (ffebld_constant_new_logicaldefault (val), expr);
5039 break;
5040 #endif
5041
5042 #if FFETARGET_okCOMPLEX4
5043 case FFEINFO_kindtypeREAL4:
5044 error = ffetarget_ne_complex4 (&val,
5045 ffebld_constant_complex4 (ffebld_conter (l)),
5046 ffebld_constant_complex4 (ffebld_conter (r)));
5047 expr = ffebld_new_conter_with_orig
5048 (ffebld_constant_new_logicaldefault (val), expr);
5049 break;
5050 #endif
5051
5052 default:
5053 assert ("bad complex kind type" == NULL);
5054 break;
5055 }
5056 break;
5057
5058 case FFEINFO_basictypeCHARACTER:
5059 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5060 {
5061 #if FFETARGET_okCHARACTER1
5062 case FFEINFO_kindtypeCHARACTER1:
5063 error = ffetarget_ne_character1 (&val,
5064 ffebld_constant_character1 (ffebld_conter (l)),
5065 ffebld_constant_character1 (ffebld_conter (r)));
5066 expr = ffebld_new_conter_with_orig
5067 (ffebld_constant_new_logicaldefault (val), expr);
5068 break;
5069 #endif
5070
5071 #if FFETARGET_okCHARACTER2
5072 case FFEINFO_kindtypeCHARACTER2:
5073 error = ffetarget_ne_character2 (&val,
5074 ffebld_constant_character2 (ffebld_conter (l)),
5075 ffebld_constant_character2 (ffebld_conter (r)));
5076 expr = ffebld_new_conter_with_orig
5077 (ffebld_constant_new_logicaldefault (val), expr);
5078 break;
5079 #endif
5080
5081 #if FFETARGET_okCHARACTER3
5082 case FFEINFO_kindtypeCHARACTER3:
5083 error = ffetarget_ne_character3 (&val,
5084 ffebld_constant_character3 (ffebld_conter (l)),
5085 ffebld_constant_character3 (ffebld_conter (r)));
5086 expr = ffebld_new_conter_with_orig
5087 (ffebld_constant_new_logicaldefault (val), expr);
5088 break;
5089 #endif
5090
5091 #if FFETARGET_okCHARACTER4
5092 case FFEINFO_kindtypeCHARACTER4:
5093 error = ffetarget_ne_character4 (&val,
5094 ffebld_constant_character4 (ffebld_conter (l)),
5095 ffebld_constant_character4 (ffebld_conter (r)));
5096 expr = ffebld_new_conter_with_orig
5097 (ffebld_constant_new_logicaldefault (val), expr);
5098 break;
5099 #endif
5100
5101 default:
5102 assert ("bad character kind type" == NULL);
5103 break;
5104 }
5105 break;
5106
5107 default:
5108 assert ("bad type" == NULL);
5109 return expr;
5110 }
5111
5112 ffebld_set_info (expr, ffeinfo_new
5113 (FFEINFO_basictypeLOGICAL,
5114 FFEINFO_kindtypeLOGICALDEFAULT,
5115 0,
5116 FFEINFO_kindENTITY,
5117 FFEINFO_whereCONSTANT,
5118 FFETARGET_charactersizeNONE));
5119
5120 if ((error != FFEBAD)
5121 && ffebad_start (error))
5122 {
5123 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5124 ffebad_finish ();
5125 }
5126
5127 return expr;
5128 }
5129
5130 /* ffeexpr_collapse_ge -- Collapse ge expr
5131
5132 ffebld expr;
5133 ffelexToken token;
5134 expr = ffeexpr_collapse_ge(expr,token);
5135
5136 If the result of the expr is a constant, replaces the expr with the
5137 computed constant. */
5138
5139 ffebld
5140 ffeexpr_collapse_ge (ffebld expr, ffelexToken t)
5141 {
5142 ffebad error = FFEBAD;
5143 ffebld l;
5144 ffebld r;
5145 bool val;
5146
5147 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5148 return expr;
5149
5150 l = ffebld_left (expr);
5151 r = ffebld_right (expr);
5152
5153 if (ffebld_op (l) != FFEBLD_opCONTER)
5154 return expr;
5155 if (ffebld_op (r) != FFEBLD_opCONTER)
5156 return expr;
5157
5158 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5159 {
5160 case FFEINFO_basictypeANY:
5161 return expr;
5162
5163 case FFEINFO_basictypeINTEGER:
5164 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5165 {
5166 #if FFETARGET_okINTEGER1
5167 case FFEINFO_kindtypeINTEGER1:
5168 error = ffetarget_ge_integer1 (&val,
5169 ffebld_constant_integer1 (ffebld_conter (l)),
5170 ffebld_constant_integer1 (ffebld_conter (r)));
5171 expr = ffebld_new_conter_with_orig
5172 (ffebld_constant_new_logicaldefault (val), expr);
5173 break;
5174 #endif
5175
5176 #if FFETARGET_okINTEGER2
5177 case FFEINFO_kindtypeINTEGER2:
5178 error = ffetarget_ge_integer2 (&val,
5179 ffebld_constant_integer2 (ffebld_conter (l)),
5180 ffebld_constant_integer2 (ffebld_conter (r)));
5181 expr = ffebld_new_conter_with_orig
5182 (ffebld_constant_new_logicaldefault (val), expr);
5183 break;
5184 #endif
5185
5186 #if FFETARGET_okINTEGER3
5187 case FFEINFO_kindtypeINTEGER3:
5188 error = ffetarget_ge_integer3 (&val,
5189 ffebld_constant_integer3 (ffebld_conter (l)),
5190 ffebld_constant_integer3 (ffebld_conter (r)));
5191 expr = ffebld_new_conter_with_orig
5192 (ffebld_constant_new_logicaldefault (val), expr);
5193 break;
5194 #endif
5195
5196 #if FFETARGET_okINTEGER4
5197 case FFEINFO_kindtypeINTEGER4:
5198 error = ffetarget_ge_integer4 (&val,
5199 ffebld_constant_integer4 (ffebld_conter (l)),
5200 ffebld_constant_integer4 (ffebld_conter (r)));
5201 expr = ffebld_new_conter_with_orig
5202 (ffebld_constant_new_logicaldefault (val), expr);
5203 break;
5204 #endif
5205
5206 default:
5207 assert ("bad integer kind type" == NULL);
5208 break;
5209 }
5210 break;
5211
5212 case FFEINFO_basictypeREAL:
5213 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5214 {
5215 #if FFETARGET_okREAL1
5216 case FFEINFO_kindtypeREAL1:
5217 error = ffetarget_ge_real1 (&val,
5218 ffebld_constant_real1 (ffebld_conter (l)),
5219 ffebld_constant_real1 (ffebld_conter (r)));
5220 expr = ffebld_new_conter_with_orig
5221 (ffebld_constant_new_logicaldefault (val), expr);
5222 break;
5223 #endif
5224
5225 #if FFETARGET_okREAL2
5226 case FFEINFO_kindtypeREAL2:
5227 error = ffetarget_ge_real2 (&val,
5228 ffebld_constant_real2 (ffebld_conter (l)),
5229 ffebld_constant_real2 (ffebld_conter (r)));
5230 expr = ffebld_new_conter_with_orig
5231 (ffebld_constant_new_logicaldefault (val), expr);
5232 break;
5233 #endif
5234
5235 #if FFETARGET_okREAL3
5236 case FFEINFO_kindtypeREAL3:
5237 error = ffetarget_ge_real3 (&val,
5238 ffebld_constant_real3 (ffebld_conter (l)),
5239 ffebld_constant_real3 (ffebld_conter (r)));
5240 expr = ffebld_new_conter_with_orig
5241 (ffebld_constant_new_logicaldefault (val), expr);
5242 break;
5243 #endif
5244
5245 #if FFETARGET_okREAL4
5246 case FFEINFO_kindtypeREAL4:
5247 error = ffetarget_ge_real4 (&val,
5248 ffebld_constant_real4 (ffebld_conter (l)),
5249 ffebld_constant_real4 (ffebld_conter (r)));
5250 expr = ffebld_new_conter_with_orig
5251 (ffebld_constant_new_logicaldefault (val), expr);
5252 break;
5253 #endif
5254
5255 default:
5256 assert ("bad real kind type" == NULL);
5257 break;
5258 }
5259 break;
5260
5261 case FFEINFO_basictypeCHARACTER:
5262 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5263 {
5264 #if FFETARGET_okCHARACTER1
5265 case FFEINFO_kindtypeCHARACTER1:
5266 error = ffetarget_ge_character1 (&val,
5267 ffebld_constant_character1 (ffebld_conter (l)),
5268 ffebld_constant_character1 (ffebld_conter (r)));
5269 expr = ffebld_new_conter_with_orig
5270 (ffebld_constant_new_logicaldefault (val), expr);
5271 break;
5272 #endif
5273
5274 #if FFETARGET_okCHARACTER2
5275 case FFEINFO_kindtypeCHARACTER2:
5276 error = ffetarget_ge_character2 (&val,
5277 ffebld_constant_character2 (ffebld_conter (l)),
5278 ffebld_constant_character2 (ffebld_conter (r)));
5279 expr = ffebld_new_conter_with_orig
5280 (ffebld_constant_new_logicaldefault (val), expr);
5281 break;
5282 #endif
5283
5284 #if FFETARGET_okCHARACTER3
5285 case FFEINFO_kindtypeCHARACTER3:
5286 error = ffetarget_ge_character3 (&val,
5287 ffebld_constant_character3 (ffebld_conter (l)),
5288 ffebld_constant_character3 (ffebld_conter (r)));
5289 expr = ffebld_new_conter_with_orig
5290 (ffebld_constant_new_logicaldefault (val), expr);
5291 break;
5292 #endif
5293
5294 #if FFETARGET_okCHARACTER4
5295 case FFEINFO_kindtypeCHARACTER4:
5296 error = ffetarget_ge_character4 (&val,
5297 ffebld_constant_character4 (ffebld_conter (l)),
5298 ffebld_constant_character4 (ffebld_conter (r)));
5299 expr = ffebld_new_conter_with_orig
5300 (ffebld_constant_new_logicaldefault (val), expr);
5301 break;
5302 #endif
5303
5304 default:
5305 assert ("bad character kind type" == NULL);
5306 break;
5307 }
5308 break;
5309
5310 default:
5311 assert ("bad type" == NULL);
5312 return expr;
5313 }
5314
5315 ffebld_set_info (expr, ffeinfo_new
5316 (FFEINFO_basictypeLOGICAL,
5317 FFEINFO_kindtypeLOGICALDEFAULT,
5318 0,
5319 FFEINFO_kindENTITY,
5320 FFEINFO_whereCONSTANT,
5321 FFETARGET_charactersizeNONE));
5322
5323 if ((error != FFEBAD)
5324 && ffebad_start (error))
5325 {
5326 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5327 ffebad_finish ();
5328 }
5329
5330 return expr;
5331 }
5332
5333 /* ffeexpr_collapse_gt -- Collapse gt expr
5334
5335 ffebld expr;
5336 ffelexToken token;
5337 expr = ffeexpr_collapse_gt(expr,token);
5338
5339 If the result of the expr is a constant, replaces the expr with the
5340 computed constant. */
5341
5342 ffebld
5343 ffeexpr_collapse_gt (ffebld expr, ffelexToken t)
5344 {
5345 ffebad error = FFEBAD;
5346 ffebld l;
5347 ffebld r;
5348 bool val;
5349
5350 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5351 return expr;
5352
5353 l = ffebld_left (expr);
5354 r = ffebld_right (expr);
5355
5356 if (ffebld_op (l) != FFEBLD_opCONTER)
5357 return expr;
5358 if (ffebld_op (r) != FFEBLD_opCONTER)
5359 return expr;
5360
5361 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5362 {
5363 case FFEINFO_basictypeANY:
5364 return expr;
5365
5366 case FFEINFO_basictypeINTEGER:
5367 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5368 {
5369 #if FFETARGET_okINTEGER1
5370 case FFEINFO_kindtypeINTEGER1:
5371 error = ffetarget_gt_integer1 (&val,
5372 ffebld_constant_integer1 (ffebld_conter (l)),
5373 ffebld_constant_integer1 (ffebld_conter (r)));
5374 expr = ffebld_new_conter_with_orig
5375 (ffebld_constant_new_logicaldefault (val), expr);
5376 break;
5377 #endif
5378
5379 #if FFETARGET_okINTEGER2
5380 case FFEINFO_kindtypeINTEGER2:
5381 error = ffetarget_gt_integer2 (&val,
5382 ffebld_constant_integer2 (ffebld_conter (l)),
5383 ffebld_constant_integer2 (ffebld_conter (r)));
5384 expr = ffebld_new_conter_with_orig
5385 (ffebld_constant_new_logicaldefault (val), expr);
5386 break;
5387 #endif
5388
5389 #if FFETARGET_okINTEGER3
5390 case FFEINFO_kindtypeINTEGER3:
5391 error = ffetarget_gt_integer3 (&val,
5392 ffebld_constant_integer3 (ffebld_conter (l)),
5393 ffebld_constant_integer3 (ffebld_conter (r)));
5394 expr = ffebld_new_conter_with_orig
5395 (ffebld_constant_new_logicaldefault (val), expr);
5396 break;
5397 #endif
5398
5399 #if FFETARGET_okINTEGER4
5400 case FFEINFO_kindtypeINTEGER4:
5401 error = ffetarget_gt_integer4 (&val,
5402 ffebld_constant_integer4 (ffebld_conter (l)),
5403 ffebld_constant_integer4 (ffebld_conter (r)));
5404 expr = ffebld_new_conter_with_orig
5405 (ffebld_constant_new_logicaldefault (val), expr);
5406 break;
5407 #endif
5408
5409 default:
5410 assert ("bad integer kind type" == NULL);
5411 break;
5412 }
5413 break;
5414
5415 case FFEINFO_basictypeREAL:
5416 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5417 {
5418 #if FFETARGET_okREAL1
5419 case FFEINFO_kindtypeREAL1:
5420 error = ffetarget_gt_real1 (&val,
5421 ffebld_constant_real1 (ffebld_conter (l)),
5422 ffebld_constant_real1 (ffebld_conter (r)));
5423 expr = ffebld_new_conter_with_orig
5424 (ffebld_constant_new_logicaldefault (val), expr);
5425 break;
5426 #endif
5427
5428 #if FFETARGET_okREAL2
5429 case FFEINFO_kindtypeREAL2:
5430 error = ffetarget_gt_real2 (&val,
5431 ffebld_constant_real2 (ffebld_conter (l)),
5432 ffebld_constant_real2 (ffebld_conter (r)));
5433 expr = ffebld_new_conter_with_orig
5434 (ffebld_constant_new_logicaldefault (val), expr);
5435 break;
5436 #endif
5437
5438 #if FFETARGET_okREAL3
5439 case FFEINFO_kindtypeREAL3:
5440 error = ffetarget_gt_real3 (&val,
5441 ffebld_constant_real3 (ffebld_conter (l)),
5442 ffebld_constant_real3 (ffebld_conter (r)));
5443 expr = ffebld_new_conter_with_orig
5444 (ffebld_constant_new_logicaldefault (val), expr);
5445 break;
5446 #endif
5447
5448 #if FFETARGET_okREAL4
5449 case FFEINFO_kindtypeREAL4:
5450 error = ffetarget_gt_real4 (&val,
5451 ffebld_constant_real4 (ffebld_conter (l)),
5452 ffebld_constant_real4 (ffebld_conter (r)));
5453 expr = ffebld_new_conter_with_orig
5454 (ffebld_constant_new_logicaldefault (val), expr);
5455 break;
5456 #endif
5457
5458 default:
5459 assert ("bad real kind type" == NULL);
5460 break;
5461 }
5462 break;
5463
5464 case FFEINFO_basictypeCHARACTER:
5465 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5466 {
5467 #if FFETARGET_okCHARACTER1
5468 case FFEINFO_kindtypeCHARACTER1:
5469 error = ffetarget_gt_character1 (&val,
5470 ffebld_constant_character1 (ffebld_conter (l)),
5471 ffebld_constant_character1 (ffebld_conter (r)));
5472 expr = ffebld_new_conter_with_orig
5473 (ffebld_constant_new_logicaldefault (val), expr);
5474 break;
5475 #endif
5476
5477 #if FFETARGET_okCHARACTER2
5478 case FFEINFO_kindtypeCHARACTER2:
5479 error = ffetarget_gt_character2 (&val,
5480 ffebld_constant_character2 (ffebld_conter (l)),
5481 ffebld_constant_character2 (ffebld_conter (r)));
5482 expr = ffebld_new_conter_with_orig
5483 (ffebld_constant_new_logicaldefault (val), expr);
5484 break;
5485 #endif
5486
5487 #if FFETARGET_okCHARACTER3
5488 case FFEINFO_kindtypeCHARACTER3:
5489 error = ffetarget_gt_character3 (&val,
5490 ffebld_constant_character3 (ffebld_conter (l)),
5491 ffebld_constant_character3 (ffebld_conter (r)));
5492 expr = ffebld_new_conter_with_orig
5493 (ffebld_constant_new_logicaldefault (val), expr);
5494 break;
5495 #endif
5496
5497 #if FFETARGET_okCHARACTER4
5498 case FFEINFO_kindtypeCHARACTER4:
5499 error = ffetarget_gt_character4 (&val,
5500 ffebld_constant_character4 (ffebld_conter (l)),
5501 ffebld_constant_character4 (ffebld_conter (r)));
5502 expr = ffebld_new_conter_with_orig
5503 (ffebld_constant_new_logicaldefault (val), expr);
5504 break;
5505 #endif
5506
5507 default:
5508 assert ("bad character kind type" == NULL);
5509 break;
5510 }
5511 break;
5512
5513 default:
5514 assert ("bad type" == NULL);
5515 return expr;
5516 }
5517
5518 ffebld_set_info (expr, ffeinfo_new
5519 (FFEINFO_basictypeLOGICAL,
5520 FFEINFO_kindtypeLOGICALDEFAULT,
5521 0,
5522 FFEINFO_kindENTITY,
5523 FFEINFO_whereCONSTANT,
5524 FFETARGET_charactersizeNONE));
5525
5526 if ((error != FFEBAD)
5527 && ffebad_start (error))
5528 {
5529 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5530 ffebad_finish ();
5531 }
5532
5533 return expr;
5534 }
5535
5536 /* ffeexpr_collapse_le -- Collapse le expr
5537
5538 ffebld expr;
5539 ffelexToken token;
5540 expr = ffeexpr_collapse_le(expr,token);
5541
5542 If the result of the expr is a constant, replaces the expr with the
5543 computed constant. */
5544
5545 ffebld
5546 ffeexpr_collapse_le (ffebld expr, ffelexToken t)
5547 {
5548 ffebad error = FFEBAD;
5549 ffebld l;
5550 ffebld r;
5551 bool val;
5552
5553 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5554 return expr;
5555
5556 l = ffebld_left (expr);
5557 r = ffebld_right (expr);
5558
5559 if (ffebld_op (l) != FFEBLD_opCONTER)
5560 return expr;
5561 if (ffebld_op (r) != FFEBLD_opCONTER)
5562 return expr;
5563
5564 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5565 {
5566 case FFEINFO_basictypeANY:
5567 return expr;
5568
5569 case FFEINFO_basictypeINTEGER:
5570 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5571 {
5572 #if FFETARGET_okINTEGER1
5573 case FFEINFO_kindtypeINTEGER1:
5574 error = ffetarget_le_integer1 (&val,
5575 ffebld_constant_integer1 (ffebld_conter (l)),
5576 ffebld_constant_integer1 (ffebld_conter (r)));
5577 expr = ffebld_new_conter_with_orig
5578 (ffebld_constant_new_logicaldefault (val), expr);
5579 break;
5580 #endif
5581
5582 #if FFETARGET_okINTEGER2
5583 case FFEINFO_kindtypeINTEGER2:
5584 error = ffetarget_le_integer2 (&val,
5585 ffebld_constant_integer2 (ffebld_conter (l)),
5586 ffebld_constant_integer2 (ffebld_conter (r)));
5587 expr = ffebld_new_conter_with_orig
5588 (ffebld_constant_new_logicaldefault (val), expr);
5589 break;
5590 #endif
5591
5592 #if FFETARGET_okINTEGER3
5593 case FFEINFO_kindtypeINTEGER3:
5594 error = ffetarget_le_integer3 (&val,
5595 ffebld_constant_integer3 (ffebld_conter (l)),
5596 ffebld_constant_integer3 (ffebld_conter (r)));
5597 expr = ffebld_new_conter_with_orig
5598 (ffebld_constant_new_logicaldefault (val), expr);
5599 break;
5600 #endif
5601
5602 #if FFETARGET_okINTEGER4
5603 case FFEINFO_kindtypeINTEGER4:
5604 error = ffetarget_le_integer4 (&val,
5605 ffebld_constant_integer4 (ffebld_conter (l)),
5606 ffebld_constant_integer4 (ffebld_conter (r)));
5607 expr = ffebld_new_conter_with_orig
5608 (ffebld_constant_new_logicaldefault (val), expr);
5609 break;
5610 #endif
5611
5612 default:
5613 assert ("bad integer kind type" == NULL);
5614 break;
5615 }
5616 break;
5617
5618 case FFEINFO_basictypeREAL:
5619 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5620 {
5621 #if FFETARGET_okREAL1
5622 case FFEINFO_kindtypeREAL1:
5623 error = ffetarget_le_real1 (&val,
5624 ffebld_constant_real1 (ffebld_conter (l)),
5625 ffebld_constant_real1 (ffebld_conter (r)));
5626 expr = ffebld_new_conter_with_orig
5627 (ffebld_constant_new_logicaldefault (val), expr);
5628 break;
5629 #endif
5630
5631 #if FFETARGET_okREAL2
5632 case FFEINFO_kindtypeREAL2:
5633 error = ffetarget_le_real2 (&val,
5634 ffebld_constant_real2 (ffebld_conter (l)),
5635 ffebld_constant_real2 (ffebld_conter (r)));
5636 expr = ffebld_new_conter_with_orig
5637 (ffebld_constant_new_logicaldefault (val), expr);
5638 break;
5639 #endif
5640
5641 #if FFETARGET_okREAL3
5642 case FFEINFO_kindtypeREAL3:
5643 error = ffetarget_le_real3 (&val,
5644 ffebld_constant_real3 (ffebld_conter (l)),
5645 ffebld_constant_real3 (ffebld_conter (r)));
5646 expr = ffebld_new_conter_with_orig
5647 (ffebld_constant_new_logicaldefault (val), expr);
5648 break;
5649 #endif
5650
5651 #if FFETARGET_okREAL4
5652 case FFEINFO_kindtypeREAL4:
5653 error = ffetarget_le_real4 (&val,
5654 ffebld_constant_real4 (ffebld_conter (l)),
5655 ffebld_constant_real4 (ffebld_conter (r)));
5656 expr = ffebld_new_conter_with_orig
5657 (ffebld_constant_new_logicaldefault (val), expr);
5658 break;
5659 #endif
5660
5661 default:
5662 assert ("bad real kind type" == NULL);
5663 break;
5664 }
5665 break;
5666
5667 case FFEINFO_basictypeCHARACTER:
5668 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5669 {
5670 #if FFETARGET_okCHARACTER1
5671 case FFEINFO_kindtypeCHARACTER1:
5672 error = ffetarget_le_character1 (&val,
5673 ffebld_constant_character1 (ffebld_conter (l)),
5674 ffebld_constant_character1 (ffebld_conter (r)));
5675 expr = ffebld_new_conter_with_orig
5676 (ffebld_constant_new_logicaldefault (val), expr);
5677 break;
5678 #endif
5679
5680 #if FFETARGET_okCHARACTER2
5681 case FFEINFO_kindtypeCHARACTER2:
5682 error = ffetarget_le_character2 (&val,
5683 ffebld_constant_character2 (ffebld_conter (l)),
5684 ffebld_constant_character2 (ffebld_conter (r)));
5685 expr = ffebld_new_conter_with_orig
5686 (ffebld_constant_new_logicaldefault (val), expr);
5687 break;
5688 #endif
5689
5690 #if FFETARGET_okCHARACTER3
5691 case FFEINFO_kindtypeCHARACTER3:
5692 error = ffetarget_le_character3 (&val,
5693 ffebld_constant_character3 (ffebld_conter (l)),
5694 ffebld_constant_character3 (ffebld_conter (r)));
5695 expr = ffebld_new_conter_with_orig
5696 (ffebld_constant_new_logicaldefault (val), expr);
5697 break;
5698 #endif
5699
5700 #if FFETARGET_okCHARACTER4
5701 case FFEINFO_kindtypeCHARACTER4:
5702 error = ffetarget_le_character4 (&val,
5703 ffebld_constant_character4 (ffebld_conter (l)),
5704 ffebld_constant_character4 (ffebld_conter (r)));
5705 expr = ffebld_new_conter_with_orig
5706 (ffebld_constant_new_logicaldefault (val), expr);
5707 break;
5708 #endif
5709
5710 default:
5711 assert ("bad character kind type" == NULL);
5712 break;
5713 }
5714 break;
5715
5716 default:
5717 assert ("bad type" == NULL);
5718 return expr;
5719 }
5720
5721 ffebld_set_info (expr, ffeinfo_new
5722 (FFEINFO_basictypeLOGICAL,
5723 FFEINFO_kindtypeLOGICALDEFAULT,
5724 0,
5725 FFEINFO_kindENTITY,
5726 FFEINFO_whereCONSTANT,
5727 FFETARGET_charactersizeNONE));
5728
5729 if ((error != FFEBAD)
5730 && ffebad_start (error))
5731 {
5732 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5733 ffebad_finish ();
5734 }
5735
5736 return expr;
5737 }
5738
5739 /* ffeexpr_collapse_lt -- Collapse lt expr
5740
5741 ffebld expr;
5742 ffelexToken token;
5743 expr = ffeexpr_collapse_lt(expr,token);
5744
5745 If the result of the expr is a constant, replaces the expr with the
5746 computed constant. */
5747
5748 ffebld
5749 ffeexpr_collapse_lt (ffebld expr, ffelexToken t)
5750 {
5751 ffebad error = FFEBAD;
5752 ffebld l;
5753 ffebld r;
5754 bool val;
5755
5756 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5757 return expr;
5758
5759 l = ffebld_left (expr);
5760 r = ffebld_right (expr);
5761
5762 if (ffebld_op (l) != FFEBLD_opCONTER)
5763 return expr;
5764 if (ffebld_op (r) != FFEBLD_opCONTER)
5765 return expr;
5766
5767 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5768 {
5769 case FFEINFO_basictypeANY:
5770 return expr;
5771
5772 case FFEINFO_basictypeINTEGER:
5773 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5774 {
5775 #if FFETARGET_okINTEGER1
5776 case FFEINFO_kindtypeINTEGER1:
5777 error = ffetarget_lt_integer1 (&val,
5778 ffebld_constant_integer1 (ffebld_conter (l)),
5779 ffebld_constant_integer1 (ffebld_conter (r)));
5780 expr = ffebld_new_conter_with_orig
5781 (ffebld_constant_new_logicaldefault (val), expr);
5782 break;
5783 #endif
5784
5785 #if FFETARGET_okINTEGER2
5786 case FFEINFO_kindtypeINTEGER2:
5787 error = ffetarget_lt_integer2 (&val,
5788 ffebld_constant_integer2 (ffebld_conter (l)),
5789 ffebld_constant_integer2 (ffebld_conter (r)));
5790 expr = ffebld_new_conter_with_orig
5791 (ffebld_constant_new_logicaldefault (val), expr);
5792 break;
5793 #endif
5794
5795 #if FFETARGET_okINTEGER3
5796 case FFEINFO_kindtypeINTEGER3:
5797 error = ffetarget_lt_integer3 (&val,
5798 ffebld_constant_integer3 (ffebld_conter (l)),
5799 ffebld_constant_integer3 (ffebld_conter (r)));
5800 expr = ffebld_new_conter_with_orig
5801 (ffebld_constant_new_logicaldefault (val), expr);
5802 break;
5803 #endif
5804
5805 #if FFETARGET_okINTEGER4
5806 case FFEINFO_kindtypeINTEGER4:
5807 error = ffetarget_lt_integer4 (&val,
5808 ffebld_constant_integer4 (ffebld_conter (l)),
5809 ffebld_constant_integer4 (ffebld_conter (r)));
5810 expr = ffebld_new_conter_with_orig
5811 (ffebld_constant_new_logicaldefault (val), expr);
5812 break;
5813 #endif
5814
5815 default:
5816 assert ("bad integer kind type" == NULL);
5817 break;
5818 }
5819 break;
5820
5821 case FFEINFO_basictypeREAL:
5822 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5823 {
5824 #if FFETARGET_okREAL1
5825 case FFEINFO_kindtypeREAL1:
5826 error = ffetarget_lt_real1 (&val,
5827 ffebld_constant_real1 (ffebld_conter (l)),
5828 ffebld_constant_real1 (ffebld_conter (r)));
5829 expr = ffebld_new_conter_with_orig
5830 (ffebld_constant_new_logicaldefault (val), expr);
5831 break;
5832 #endif
5833
5834 #if FFETARGET_okREAL2
5835 case FFEINFO_kindtypeREAL2:
5836 error = ffetarget_lt_real2 (&val,
5837 ffebld_constant_real2 (ffebld_conter (l)),
5838 ffebld_constant_real2 (ffebld_conter (r)));
5839 expr = ffebld_new_conter_with_orig
5840 (ffebld_constant_new_logicaldefault (val), expr);
5841 break;
5842 #endif
5843
5844 #if FFETARGET_okREAL3
5845 case FFEINFO_kindtypeREAL3:
5846 error = ffetarget_lt_real3 (&val,
5847 ffebld_constant_real3 (ffebld_conter (l)),
5848 ffebld_constant_real3 (ffebld_conter (r)));
5849 expr = ffebld_new_conter_with_orig
5850 (ffebld_constant_new_logicaldefault (val), expr);
5851 break;
5852 #endif
5853
5854 #if FFETARGET_okREAL4
5855 case FFEINFO_kindtypeREAL4:
5856 error = ffetarget_lt_real4 (&val,
5857 ffebld_constant_real4 (ffebld_conter (l)),
5858 ffebld_constant_real4 (ffebld_conter (r)));
5859 expr = ffebld_new_conter_with_orig
5860 (ffebld_constant_new_logicaldefault (val), expr);
5861 break;
5862 #endif
5863
5864 default:
5865 assert ("bad real kind type" == NULL);
5866 break;
5867 }
5868 break;
5869
5870 case FFEINFO_basictypeCHARACTER:
5871 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5872 {
5873 #if FFETARGET_okCHARACTER1
5874 case FFEINFO_kindtypeCHARACTER1:
5875 error = ffetarget_lt_character1 (&val,
5876 ffebld_constant_character1 (ffebld_conter (l)),
5877 ffebld_constant_character1 (ffebld_conter (r)));
5878 expr = ffebld_new_conter_with_orig
5879 (ffebld_constant_new_logicaldefault (val), expr);
5880 break;
5881 #endif
5882
5883 #if FFETARGET_okCHARACTER2
5884 case FFEINFO_kindtypeCHARACTER2:
5885 error = ffetarget_lt_character2 (&val,
5886 ffebld_constant_character2 (ffebld_conter (l)),
5887 ffebld_constant_character2 (ffebld_conter (r)));
5888 expr = ffebld_new_conter_with_orig
5889 (ffebld_constant_new_logicaldefault (val), expr);
5890 break;
5891 #endif
5892
5893 #if FFETARGET_okCHARACTER3
5894 case FFEINFO_kindtypeCHARACTER3:
5895 error = ffetarget_lt_character3 (&val,
5896 ffebld_constant_character3 (ffebld_conter (l)),
5897 ffebld_constant_character3 (ffebld_conter (r)));
5898 expr = ffebld_new_conter_with_orig
5899 (ffebld_constant_new_logicaldefault (val), expr);
5900 break;
5901 #endif
5902
5903 #if FFETARGET_okCHARACTER4
5904 case FFEINFO_kindtypeCHARACTER4:
5905 error = ffetarget_lt_character4 (&val,
5906 ffebld_constant_character4 (ffebld_conter (l)),
5907 ffebld_constant_character4 (ffebld_conter (r)));
5908 expr = ffebld_new_conter_with_orig
5909 (ffebld_constant_new_logicaldefault (val), expr);
5910 break;
5911 #endif
5912
5913 default:
5914 assert ("bad character kind type" == NULL);
5915 break;
5916 }
5917 break;
5918
5919 default:
5920 assert ("bad type" == NULL);
5921 return expr;
5922 }
5923
5924 ffebld_set_info (expr, ffeinfo_new
5925 (FFEINFO_basictypeLOGICAL,
5926 FFEINFO_kindtypeLOGICALDEFAULT,
5927 0,
5928 FFEINFO_kindENTITY,
5929 FFEINFO_whereCONSTANT,
5930 FFETARGET_charactersizeNONE));
5931
5932 if ((error != FFEBAD)
5933 && ffebad_start (error))
5934 {
5935 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5936 ffebad_finish ();
5937 }
5938
5939 return expr;
5940 }
5941
5942 /* ffeexpr_collapse_and -- Collapse and expr
5943
5944 ffebld expr;
5945 ffelexToken token;
5946 expr = ffeexpr_collapse_and(expr,token);
5947
5948 If the result of the expr is a constant, replaces the expr with the
5949 computed constant. */
5950
5951 ffebld
5952 ffeexpr_collapse_and (ffebld expr, ffelexToken t)
5953 {
5954 ffebad error = FFEBAD;
5955 ffebld l;
5956 ffebld r;
5957 ffebldConstantUnion u;
5958 ffeinfoBasictype bt;
5959 ffeinfoKindtype kt;
5960
5961 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5962 return expr;
5963
5964 l = ffebld_left (expr);
5965 r = ffebld_right (expr);
5966
5967 if (ffebld_op (l) != FFEBLD_opCONTER)
5968 return expr;
5969 if (ffebld_op (r) != FFEBLD_opCONTER)
5970 return expr;
5971
5972 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5973 {
5974 case FFEINFO_basictypeANY:
5975 return expr;
5976
5977 case FFEINFO_basictypeINTEGER:
5978 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5979 {
5980 #if FFETARGET_okINTEGER1
5981 case FFEINFO_kindtypeINTEGER1:
5982 error = ffetarget_and_integer1 (ffebld_cu_ptr_integer1 (u),
5983 ffebld_constant_integer1 (ffebld_conter (l)),
5984 ffebld_constant_integer1 (ffebld_conter (r)));
5985 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5986 (ffebld_cu_val_integer1 (u)), expr);
5987 break;
5988 #endif
5989
5990 #if FFETARGET_okINTEGER2
5991 case FFEINFO_kindtypeINTEGER2:
5992 error = ffetarget_and_integer2 (ffebld_cu_ptr_integer2 (u),
5993 ffebld_constant_integer2 (ffebld_conter (l)),
5994 ffebld_constant_integer2 (ffebld_conter (r)));
5995 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5996 (ffebld_cu_val_integer2 (u)), expr);
5997 break;
5998 #endif
5999
6000 #if FFETARGET_okINTEGER3
6001 case FFEINFO_kindtypeINTEGER3:
6002 error = ffetarget_and_integer3 (ffebld_cu_ptr_integer3 (u),
6003 ffebld_constant_integer3 (ffebld_conter (l)),
6004 ffebld_constant_integer3 (ffebld_conter (r)));
6005 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6006 (ffebld_cu_val_integer3 (u)), expr);
6007 break;
6008 #endif
6009
6010 #if FFETARGET_okINTEGER4
6011 case FFEINFO_kindtypeINTEGER4:
6012 error = ffetarget_and_integer4 (ffebld_cu_ptr_integer4 (u),
6013 ffebld_constant_integer4 (ffebld_conter (l)),
6014 ffebld_constant_integer4 (ffebld_conter (r)));
6015 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6016 (ffebld_cu_val_integer4 (u)), expr);
6017 break;
6018 #endif
6019
6020 default:
6021 assert ("bad integer kind type" == NULL);
6022 break;
6023 }
6024 break;
6025
6026 case FFEINFO_basictypeLOGICAL:
6027 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6028 {
6029 #if FFETARGET_okLOGICAL1
6030 case FFEINFO_kindtypeLOGICAL1:
6031 error = ffetarget_and_logical1 (ffebld_cu_ptr_logical1 (u),
6032 ffebld_constant_logical1 (ffebld_conter (l)),
6033 ffebld_constant_logical1 (ffebld_conter (r)));
6034 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6035 (ffebld_cu_val_logical1 (u)), expr);
6036 break;
6037 #endif
6038
6039 #if FFETARGET_okLOGICAL2
6040 case FFEINFO_kindtypeLOGICAL2:
6041 error = ffetarget_and_logical2 (ffebld_cu_ptr_logical2 (u),
6042 ffebld_constant_logical2 (ffebld_conter (l)),
6043 ffebld_constant_logical2 (ffebld_conter (r)));
6044 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6045 (ffebld_cu_val_logical2 (u)), expr);
6046 break;
6047 #endif
6048
6049 #if FFETARGET_okLOGICAL3
6050 case FFEINFO_kindtypeLOGICAL3:
6051 error = ffetarget_and_logical3 (ffebld_cu_ptr_logical3 (u),
6052 ffebld_constant_logical3 (ffebld_conter (l)),
6053 ffebld_constant_logical3 (ffebld_conter (r)));
6054 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6055 (ffebld_cu_val_logical3 (u)), expr);
6056 break;
6057 #endif
6058
6059 #if FFETARGET_okLOGICAL4
6060 case FFEINFO_kindtypeLOGICAL4:
6061 error = ffetarget_and_logical4 (ffebld_cu_ptr_logical4 (u),
6062 ffebld_constant_logical4 (ffebld_conter (l)),
6063 ffebld_constant_logical4 (ffebld_conter (r)));
6064 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6065 (ffebld_cu_val_logical4 (u)), expr);
6066 break;
6067 #endif
6068
6069 default:
6070 assert ("bad logical kind type" == NULL);
6071 break;
6072 }
6073 break;
6074
6075 default:
6076 assert ("bad type" == NULL);
6077 return expr;
6078 }
6079
6080 ffebld_set_info (expr, ffeinfo_new
6081 (bt,
6082 kt,
6083 0,
6084 FFEINFO_kindENTITY,
6085 FFEINFO_whereCONSTANT,
6086 FFETARGET_charactersizeNONE));
6087
6088 if ((error != FFEBAD)
6089 && ffebad_start (error))
6090 {
6091 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6092 ffebad_finish ();
6093 }
6094
6095 return expr;
6096 }
6097
6098 /* ffeexpr_collapse_or -- Collapse or expr
6099
6100 ffebld expr;
6101 ffelexToken token;
6102 expr = ffeexpr_collapse_or(expr,token);
6103
6104 If the result of the expr is a constant, replaces the expr with the
6105 computed constant. */
6106
6107 ffebld
6108 ffeexpr_collapse_or (ffebld expr, ffelexToken t)
6109 {
6110 ffebad error = FFEBAD;
6111 ffebld l;
6112 ffebld r;
6113 ffebldConstantUnion u;
6114 ffeinfoBasictype bt;
6115 ffeinfoKindtype kt;
6116
6117 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6118 return expr;
6119
6120 l = ffebld_left (expr);
6121 r = ffebld_right (expr);
6122
6123 if (ffebld_op (l) != FFEBLD_opCONTER)
6124 return expr;
6125 if (ffebld_op (r) != FFEBLD_opCONTER)
6126 return expr;
6127
6128 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6129 {
6130 case FFEINFO_basictypeANY:
6131 return expr;
6132
6133 case FFEINFO_basictypeINTEGER:
6134 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6135 {
6136 #if FFETARGET_okINTEGER1
6137 case FFEINFO_kindtypeINTEGER1:
6138 error = ffetarget_or_integer1 (ffebld_cu_ptr_integer1 (u),
6139 ffebld_constant_integer1 (ffebld_conter (l)),
6140 ffebld_constant_integer1 (ffebld_conter (r)));
6141 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6142 (ffebld_cu_val_integer1 (u)), expr);
6143 break;
6144 #endif
6145
6146 #if FFETARGET_okINTEGER2
6147 case FFEINFO_kindtypeINTEGER2:
6148 error = ffetarget_or_integer2 (ffebld_cu_ptr_integer2 (u),
6149 ffebld_constant_integer2 (ffebld_conter (l)),
6150 ffebld_constant_integer2 (ffebld_conter (r)));
6151 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6152 (ffebld_cu_val_integer2 (u)), expr);
6153 break;
6154 #endif
6155
6156 #if FFETARGET_okINTEGER3
6157 case FFEINFO_kindtypeINTEGER3:
6158 error = ffetarget_or_integer3 (ffebld_cu_ptr_integer3 (u),
6159 ffebld_constant_integer3 (ffebld_conter (l)),
6160 ffebld_constant_integer3 (ffebld_conter (r)));
6161 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6162 (ffebld_cu_val_integer3 (u)), expr);
6163 break;
6164 #endif
6165
6166 #if FFETARGET_okINTEGER4
6167 case FFEINFO_kindtypeINTEGER4:
6168 error = ffetarget_or_integer4 (ffebld_cu_ptr_integer4 (u),
6169 ffebld_constant_integer4 (ffebld_conter (l)),
6170 ffebld_constant_integer4 (ffebld_conter (r)));
6171 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6172 (ffebld_cu_val_integer4 (u)), expr);
6173 break;
6174 #endif
6175
6176 default:
6177 assert ("bad integer kind type" == NULL);
6178 break;
6179 }
6180 break;
6181
6182 case FFEINFO_basictypeLOGICAL:
6183 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6184 {
6185 #if FFETARGET_okLOGICAL1
6186 case FFEINFO_kindtypeLOGICAL1:
6187 error = ffetarget_or_logical1 (ffebld_cu_ptr_logical1 (u),
6188 ffebld_constant_logical1 (ffebld_conter (l)),
6189 ffebld_constant_logical1 (ffebld_conter (r)));
6190 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6191 (ffebld_cu_val_logical1 (u)), expr);
6192 break;
6193 #endif
6194
6195 #if FFETARGET_okLOGICAL2
6196 case FFEINFO_kindtypeLOGICAL2:
6197 error = ffetarget_or_logical2 (ffebld_cu_ptr_logical2 (u),
6198 ffebld_constant_logical2 (ffebld_conter (l)),
6199 ffebld_constant_logical2 (ffebld_conter (r)));
6200 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6201 (ffebld_cu_val_logical2 (u)), expr);
6202 break;
6203 #endif
6204
6205 #if FFETARGET_okLOGICAL3
6206 case FFEINFO_kindtypeLOGICAL3:
6207 error = ffetarget_or_logical3 (ffebld_cu_ptr_logical3 (u),
6208 ffebld_constant_logical3 (ffebld_conter (l)),
6209 ffebld_constant_logical3 (ffebld_conter (r)));
6210 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6211 (ffebld_cu_val_logical3 (u)), expr);
6212 break;
6213 #endif
6214
6215 #if FFETARGET_okLOGICAL4
6216 case FFEINFO_kindtypeLOGICAL4:
6217 error = ffetarget_or_logical4 (ffebld_cu_ptr_logical4 (u),
6218 ffebld_constant_logical4 (ffebld_conter (l)),
6219 ffebld_constant_logical4 (ffebld_conter (r)));
6220 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6221 (ffebld_cu_val_logical4 (u)), expr);
6222 break;
6223 #endif
6224
6225 default:
6226 assert ("bad logical kind type" == NULL);
6227 break;
6228 }
6229 break;
6230
6231 default:
6232 assert ("bad type" == NULL);
6233 return expr;
6234 }
6235
6236 ffebld_set_info (expr, ffeinfo_new
6237 (bt,
6238 kt,
6239 0,
6240 FFEINFO_kindENTITY,
6241 FFEINFO_whereCONSTANT,
6242 FFETARGET_charactersizeNONE));
6243
6244 if ((error != FFEBAD)
6245 && ffebad_start (error))
6246 {
6247 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6248 ffebad_finish ();
6249 }
6250
6251 return expr;
6252 }
6253
6254 /* ffeexpr_collapse_xor -- Collapse xor expr
6255
6256 ffebld expr;
6257 ffelexToken token;
6258 expr = ffeexpr_collapse_xor(expr,token);
6259
6260 If the result of the expr is a constant, replaces the expr with the
6261 computed constant. */
6262
6263 ffebld
6264 ffeexpr_collapse_xor (ffebld expr, ffelexToken t)
6265 {
6266 ffebad error = FFEBAD;
6267 ffebld l;
6268 ffebld r;
6269 ffebldConstantUnion u;
6270 ffeinfoBasictype bt;
6271 ffeinfoKindtype kt;
6272
6273 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6274 return expr;
6275
6276 l = ffebld_left (expr);
6277 r = ffebld_right (expr);
6278
6279 if (ffebld_op (l) != FFEBLD_opCONTER)
6280 return expr;
6281 if (ffebld_op (r) != FFEBLD_opCONTER)
6282 return expr;
6283
6284 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6285 {
6286 case FFEINFO_basictypeANY:
6287 return expr;
6288
6289 case FFEINFO_basictypeINTEGER:
6290 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6291 {
6292 #if FFETARGET_okINTEGER1
6293 case FFEINFO_kindtypeINTEGER1:
6294 error = ffetarget_xor_integer1 (ffebld_cu_ptr_integer1 (u),
6295 ffebld_constant_integer1 (ffebld_conter (l)),
6296 ffebld_constant_integer1 (ffebld_conter (r)));
6297 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6298 (ffebld_cu_val_integer1 (u)), expr);
6299 break;
6300 #endif
6301
6302 #if FFETARGET_okINTEGER2
6303 case FFEINFO_kindtypeINTEGER2:
6304 error = ffetarget_xor_integer2 (ffebld_cu_ptr_integer2 (u),
6305 ffebld_constant_integer2 (ffebld_conter (l)),
6306 ffebld_constant_integer2 (ffebld_conter (r)));
6307 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6308 (ffebld_cu_val_integer2 (u)), expr);
6309 break;
6310 #endif
6311
6312 #if FFETARGET_okINTEGER3
6313 case FFEINFO_kindtypeINTEGER3:
6314 error = ffetarget_xor_integer3 (ffebld_cu_ptr_integer3 (u),
6315 ffebld_constant_integer3 (ffebld_conter (l)),
6316 ffebld_constant_integer3 (ffebld_conter (r)));
6317 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6318 (ffebld_cu_val_integer3 (u)), expr);
6319 break;
6320 #endif
6321
6322 #if FFETARGET_okINTEGER4
6323 case FFEINFO_kindtypeINTEGER4:
6324 error = ffetarget_xor_integer4 (ffebld_cu_ptr_integer4 (u),
6325 ffebld_constant_integer4 (ffebld_conter (l)),
6326 ffebld_constant_integer4 (ffebld_conter (r)));
6327 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6328 (ffebld_cu_val_integer4 (u)), expr);
6329 break;
6330 #endif
6331
6332 default:
6333 assert ("bad integer kind type" == NULL);
6334 break;
6335 }
6336 break;
6337
6338 case FFEINFO_basictypeLOGICAL:
6339 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6340 {
6341 #if FFETARGET_okLOGICAL1
6342 case FFEINFO_kindtypeLOGICAL1:
6343 error = ffetarget_xor_logical1 (ffebld_cu_ptr_logical1 (u),
6344 ffebld_constant_logical1 (ffebld_conter (l)),
6345 ffebld_constant_logical1 (ffebld_conter (r)));
6346 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6347 (ffebld_cu_val_logical1 (u)), expr);
6348 break;
6349 #endif
6350
6351 #if FFETARGET_okLOGICAL2
6352 case FFEINFO_kindtypeLOGICAL2:
6353 error = ffetarget_xor_logical2 (ffebld_cu_ptr_logical2 (u),
6354 ffebld_constant_logical2 (ffebld_conter (l)),
6355 ffebld_constant_logical2 (ffebld_conter (r)));
6356 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6357 (ffebld_cu_val_logical2 (u)), expr);
6358 break;
6359 #endif
6360
6361 #if FFETARGET_okLOGICAL3
6362 case FFEINFO_kindtypeLOGICAL3:
6363 error = ffetarget_xor_logical3 (ffebld_cu_ptr_logical3 (u),
6364 ffebld_constant_logical3 (ffebld_conter (l)),
6365 ffebld_constant_logical3 (ffebld_conter (r)));
6366 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6367 (ffebld_cu_val_logical3 (u)), expr);
6368 break;
6369 #endif
6370
6371 #if FFETARGET_okLOGICAL4
6372 case FFEINFO_kindtypeLOGICAL4:
6373 error = ffetarget_xor_logical4 (ffebld_cu_ptr_logical4 (u),
6374 ffebld_constant_logical4 (ffebld_conter (l)),
6375 ffebld_constant_logical4 (ffebld_conter (r)));
6376 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6377 (ffebld_cu_val_logical4 (u)), expr);
6378 break;
6379 #endif
6380
6381 default:
6382 assert ("bad logical kind type" == NULL);
6383 break;
6384 }
6385 break;
6386
6387 default:
6388 assert ("bad type" == NULL);
6389 return expr;
6390 }
6391
6392 ffebld_set_info (expr, ffeinfo_new
6393 (bt,
6394 kt,
6395 0,
6396 FFEINFO_kindENTITY,
6397 FFEINFO_whereCONSTANT,
6398 FFETARGET_charactersizeNONE));
6399
6400 if ((error != FFEBAD)
6401 && ffebad_start (error))
6402 {
6403 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6404 ffebad_finish ();
6405 }
6406
6407 return expr;
6408 }
6409
6410 /* ffeexpr_collapse_eqv -- Collapse eqv expr
6411
6412 ffebld expr;
6413 ffelexToken token;
6414 expr = ffeexpr_collapse_eqv(expr,token);
6415
6416 If the result of the expr is a constant, replaces the expr with the
6417 computed constant. */
6418
6419 ffebld
6420 ffeexpr_collapse_eqv (ffebld expr, ffelexToken t)
6421 {
6422 ffebad error = FFEBAD;
6423 ffebld l;
6424 ffebld r;
6425 ffebldConstantUnion u;
6426 ffeinfoBasictype bt;
6427 ffeinfoKindtype kt;
6428
6429 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6430 return expr;
6431
6432 l = ffebld_left (expr);
6433 r = ffebld_right (expr);
6434
6435 if (ffebld_op (l) != FFEBLD_opCONTER)
6436 return expr;
6437 if (ffebld_op (r) != FFEBLD_opCONTER)
6438 return expr;
6439
6440 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6441 {
6442 case FFEINFO_basictypeANY:
6443 return expr;
6444
6445 case FFEINFO_basictypeINTEGER:
6446 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6447 {
6448 #if FFETARGET_okINTEGER1
6449 case FFEINFO_kindtypeINTEGER1:
6450 error = ffetarget_eqv_integer1 (ffebld_cu_ptr_integer1 (u),
6451 ffebld_constant_integer1 (ffebld_conter (l)),
6452 ffebld_constant_integer1 (ffebld_conter (r)));
6453 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6454 (ffebld_cu_val_integer1 (u)), expr);
6455 break;
6456 #endif
6457
6458 #if FFETARGET_okINTEGER2
6459 case FFEINFO_kindtypeINTEGER2:
6460 error = ffetarget_eqv_integer2 (ffebld_cu_ptr_integer2 (u),
6461 ffebld_constant_integer2 (ffebld_conter (l)),
6462 ffebld_constant_integer2 (ffebld_conter (r)));
6463 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6464 (ffebld_cu_val_integer2 (u)), expr);
6465 break;
6466 #endif
6467
6468 #if FFETARGET_okINTEGER3
6469 case FFEINFO_kindtypeINTEGER3:
6470 error = ffetarget_eqv_integer3 (ffebld_cu_ptr_integer3 (u),
6471 ffebld_constant_integer3 (ffebld_conter (l)),
6472 ffebld_constant_integer3 (ffebld_conter (r)));
6473 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6474 (ffebld_cu_val_integer3 (u)), expr);
6475 break;
6476 #endif
6477
6478 #if FFETARGET_okINTEGER4
6479 case FFEINFO_kindtypeINTEGER4:
6480 error = ffetarget_eqv_integer4 (ffebld_cu_ptr_integer4 (u),
6481 ffebld_constant_integer4 (ffebld_conter (l)),
6482 ffebld_constant_integer4 (ffebld_conter (r)));
6483 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6484 (ffebld_cu_val_integer4 (u)), expr);
6485 break;
6486 #endif
6487
6488 default:
6489 assert ("bad integer kind type" == NULL);
6490 break;
6491 }
6492 break;
6493
6494 case FFEINFO_basictypeLOGICAL:
6495 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6496 {
6497 #if FFETARGET_okLOGICAL1
6498 case FFEINFO_kindtypeLOGICAL1:
6499 error = ffetarget_eqv_logical1 (ffebld_cu_ptr_logical1 (u),
6500 ffebld_constant_logical1 (ffebld_conter (l)),
6501 ffebld_constant_logical1 (ffebld_conter (r)));
6502 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6503 (ffebld_cu_val_logical1 (u)), expr);
6504 break;
6505 #endif
6506
6507 #if FFETARGET_okLOGICAL2
6508 case FFEINFO_kindtypeLOGICAL2:
6509 error = ffetarget_eqv_logical2 (ffebld_cu_ptr_logical2 (u),
6510 ffebld_constant_logical2 (ffebld_conter (l)),
6511 ffebld_constant_logical2 (ffebld_conter (r)));
6512 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6513 (ffebld_cu_val_logical2 (u)), expr);
6514 break;
6515 #endif
6516
6517 #if FFETARGET_okLOGICAL3
6518 case FFEINFO_kindtypeLOGICAL3:
6519 error = ffetarget_eqv_logical3 (ffebld_cu_ptr_logical3 (u),
6520 ffebld_constant_logical3 (ffebld_conter (l)),
6521 ffebld_constant_logical3 (ffebld_conter (r)));
6522 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6523 (ffebld_cu_val_logical3 (u)), expr);
6524 break;
6525 #endif
6526
6527 #if FFETARGET_okLOGICAL4
6528 case FFEINFO_kindtypeLOGICAL4:
6529 error = ffetarget_eqv_logical4 (ffebld_cu_ptr_logical4 (u),
6530 ffebld_constant_logical4 (ffebld_conter (l)),
6531 ffebld_constant_logical4 (ffebld_conter (r)));
6532 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6533 (ffebld_cu_val_logical4 (u)), expr);
6534 break;
6535 #endif
6536
6537 default:
6538 assert ("bad logical kind type" == NULL);
6539 break;
6540 }
6541 break;
6542
6543 default:
6544 assert ("bad type" == NULL);
6545 return expr;
6546 }
6547
6548 ffebld_set_info (expr, ffeinfo_new
6549 (bt,
6550 kt,
6551 0,
6552 FFEINFO_kindENTITY,
6553 FFEINFO_whereCONSTANT,
6554 FFETARGET_charactersizeNONE));
6555
6556 if ((error != FFEBAD)
6557 && ffebad_start (error))
6558 {
6559 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6560 ffebad_finish ();
6561 }
6562
6563 return expr;
6564 }
6565
6566 /* ffeexpr_collapse_neqv -- Collapse neqv expr
6567
6568 ffebld expr;
6569 ffelexToken token;
6570 expr = ffeexpr_collapse_neqv(expr,token);
6571
6572 If the result of the expr is a constant, replaces the expr with the
6573 computed constant. */
6574
6575 ffebld
6576 ffeexpr_collapse_neqv (ffebld expr, ffelexToken t)
6577 {
6578 ffebad error = FFEBAD;
6579 ffebld l;
6580 ffebld r;
6581 ffebldConstantUnion u;
6582 ffeinfoBasictype bt;
6583 ffeinfoKindtype kt;
6584
6585 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6586 return expr;
6587
6588 l = ffebld_left (expr);
6589 r = ffebld_right (expr);
6590
6591 if (ffebld_op (l) != FFEBLD_opCONTER)
6592 return expr;
6593 if (ffebld_op (r) != FFEBLD_opCONTER)
6594 return expr;
6595
6596 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6597 {
6598 case FFEINFO_basictypeANY:
6599 return expr;
6600
6601 case FFEINFO_basictypeINTEGER:
6602 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6603 {
6604 #if FFETARGET_okINTEGER1
6605 case FFEINFO_kindtypeINTEGER1:
6606 error = ffetarget_neqv_integer1 (ffebld_cu_ptr_integer1 (u),
6607 ffebld_constant_integer1 (ffebld_conter (l)),
6608 ffebld_constant_integer1 (ffebld_conter (r)));
6609 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6610 (ffebld_cu_val_integer1 (u)), expr);
6611 break;
6612 #endif
6613
6614 #if FFETARGET_okINTEGER2
6615 case FFEINFO_kindtypeINTEGER2:
6616 error = ffetarget_neqv_integer2 (ffebld_cu_ptr_integer2 (u),
6617 ffebld_constant_integer2 (ffebld_conter (l)),
6618 ffebld_constant_integer2 (ffebld_conter (r)));
6619 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6620 (ffebld_cu_val_integer2 (u)), expr);
6621 break;
6622 #endif
6623
6624 #if FFETARGET_okINTEGER3
6625 case FFEINFO_kindtypeINTEGER3:
6626 error = ffetarget_neqv_integer3 (ffebld_cu_ptr_integer3 (u),
6627 ffebld_constant_integer3 (ffebld_conter (l)),
6628 ffebld_constant_integer3 (ffebld_conter (r)));
6629 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6630 (ffebld_cu_val_integer3 (u)), expr);
6631 break;
6632 #endif
6633
6634 #if FFETARGET_okINTEGER4
6635 case FFEINFO_kindtypeINTEGER4:
6636 error = ffetarget_neqv_integer4 (ffebld_cu_ptr_integer4 (u),
6637 ffebld_constant_integer4 (ffebld_conter (l)),
6638 ffebld_constant_integer4 (ffebld_conter (r)));
6639 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6640 (ffebld_cu_val_integer4 (u)), expr);
6641 break;
6642 #endif
6643
6644 default:
6645 assert ("bad integer kind type" == NULL);
6646 break;
6647 }
6648 break;
6649
6650 case FFEINFO_basictypeLOGICAL:
6651 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6652 {
6653 #if FFETARGET_okLOGICAL1
6654 case FFEINFO_kindtypeLOGICAL1:
6655 error = ffetarget_neqv_logical1 (ffebld_cu_ptr_logical1 (u),
6656 ffebld_constant_logical1 (ffebld_conter (l)),
6657 ffebld_constant_logical1 (ffebld_conter (r)));
6658 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6659 (ffebld_cu_val_logical1 (u)), expr);
6660 break;
6661 #endif
6662
6663 #if FFETARGET_okLOGICAL2
6664 case FFEINFO_kindtypeLOGICAL2:
6665 error = ffetarget_neqv_logical2 (ffebld_cu_ptr_logical2 (u),
6666 ffebld_constant_logical2 (ffebld_conter (l)),
6667 ffebld_constant_logical2 (ffebld_conter (r)));
6668 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6669 (ffebld_cu_val_logical2 (u)), expr);
6670 break;
6671 #endif
6672
6673 #if FFETARGET_okLOGICAL3
6674 case FFEINFO_kindtypeLOGICAL3:
6675 error = ffetarget_neqv_logical3 (ffebld_cu_ptr_logical3 (u),
6676 ffebld_constant_logical3 (ffebld_conter (l)),
6677 ffebld_constant_logical3 (ffebld_conter (r)));
6678 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6679 (ffebld_cu_val_logical3 (u)), expr);
6680 break;
6681 #endif
6682
6683 #if FFETARGET_okLOGICAL4
6684 case FFEINFO_kindtypeLOGICAL4:
6685 error = ffetarget_neqv_logical4 (ffebld_cu_ptr_logical4 (u),
6686 ffebld_constant_logical4 (ffebld_conter (l)),
6687 ffebld_constant_logical4 (ffebld_conter (r)));
6688 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6689 (ffebld_cu_val_logical4 (u)), expr);
6690 break;
6691 #endif
6692
6693 default:
6694 assert ("bad logical kind type" == NULL);
6695 break;
6696 }
6697 break;
6698
6699 default:
6700 assert ("bad type" == NULL);
6701 return expr;
6702 }
6703
6704 ffebld_set_info (expr, ffeinfo_new
6705 (bt,
6706 kt,
6707 0,
6708 FFEINFO_kindENTITY,
6709 FFEINFO_whereCONSTANT,
6710 FFETARGET_charactersizeNONE));
6711
6712 if ((error != FFEBAD)
6713 && ffebad_start (error))
6714 {
6715 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6716 ffebad_finish ();
6717 }
6718
6719 return expr;
6720 }
6721
6722 /* ffeexpr_collapse_symter -- Collapse symter expr
6723
6724 ffebld expr;
6725 ffelexToken token;
6726 expr = ffeexpr_collapse_symter(expr,token);
6727
6728 If the result of the expr is a constant, replaces the expr with the
6729 computed constant. */
6730
6731 ffebld
6732 ffeexpr_collapse_symter (ffebld expr, ffelexToken t UNUSED)
6733 {
6734 ffebld r;
6735 ffeinfoBasictype bt;
6736 ffeinfoKindtype kt;
6737 ffetargetCharacterSize len;
6738
6739 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6740 return expr;
6741
6742 if ((r = ffesymbol_init (ffebld_symter (expr))) == NULL)
6743 return expr; /* A PARAMETER lhs in progress. */
6744
6745 switch (ffebld_op (r))
6746 {
6747 case FFEBLD_opCONTER:
6748 break;
6749
6750 case FFEBLD_opANY:
6751 return r;
6752
6753 default:
6754 return expr;
6755 }
6756
6757 bt = ffeinfo_basictype (ffebld_info (r));
6758 kt = ffeinfo_kindtype (ffebld_info (r));
6759 len = ffebld_size (r);
6760
6761 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
6762 expr);
6763
6764 ffebld_set_info (expr, ffeinfo_new
6765 (bt,
6766 kt,
6767 0,
6768 FFEINFO_kindENTITY,
6769 FFEINFO_whereCONSTANT,
6770 len));
6771
6772 return expr;
6773 }
6774
6775 /* ffeexpr_collapse_funcref -- Collapse funcref expr
6776
6777 ffebld expr;
6778 ffelexToken token;
6779 expr = ffeexpr_collapse_funcref(expr,token);
6780
6781 If the result of the expr is a constant, replaces the expr with the
6782 computed constant. */
6783
6784 ffebld
6785 ffeexpr_collapse_funcref (ffebld expr, ffelexToken t UNUSED)
6786 {
6787 return expr; /* ~~someday go ahead and collapse these,
6788 though not required */
6789 }
6790
6791 /* ffeexpr_collapse_arrayref -- Collapse arrayref expr
6792
6793 ffebld expr;
6794 ffelexToken token;
6795 expr = ffeexpr_collapse_arrayref(expr,token);
6796
6797 If the result of the expr is a constant, replaces the expr with the
6798 computed constant. */
6799
6800 ffebld
6801 ffeexpr_collapse_arrayref (ffebld expr, ffelexToken t UNUSED)
6802 {
6803 return expr;
6804 }
6805
6806 /* ffeexpr_collapse_substr -- Collapse substr expr
6807
6808 ffebld expr;
6809 ffelexToken token;
6810 expr = ffeexpr_collapse_substr(expr,token);
6811
6812 If the result of the expr is a constant, replaces the expr with the
6813 computed constant. */
6814
6815 ffebld
6816 ffeexpr_collapse_substr (ffebld expr, ffelexToken t)
6817 {
6818 ffebad error = FFEBAD;
6819 ffebld l;
6820 ffebld r;
6821 ffebld start;
6822 ffebld stop;
6823 ffebldConstantUnion u;
6824 ffeinfoKindtype kt;
6825 ffetargetCharacterSize len;
6826 ffetargetIntegerDefault first;
6827 ffetargetIntegerDefault last;
6828
6829 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6830 return expr;
6831
6832 l = ffebld_left (expr);
6833 r = ffebld_right (expr); /* opITEM. */
6834
6835 if (ffebld_op (l) != FFEBLD_opCONTER)
6836 return expr;
6837
6838 kt = ffeinfo_kindtype (ffebld_info (l));
6839 len = ffebld_size (l);
6840
6841 start = ffebld_head (r);
6842 stop = ffebld_head (ffebld_trail (r));
6843 if (start == NULL)
6844 first = 1;
6845 else
6846 {
6847 if ((ffebld_op (start) != FFEBLD_opCONTER)
6848 || (ffeinfo_basictype (ffebld_info (start)) != FFEINFO_basictypeINTEGER)
6849 || (ffeinfo_kindtype (ffebld_info (start))
6850 != FFEINFO_kindtypeINTEGERDEFAULT))
6851 return expr;
6852 first = ffebld_constant_integerdefault (ffebld_conter (start));
6853 }
6854 if (stop == NULL)
6855 last = len;
6856 else
6857 {
6858 if ((ffebld_op (stop) != FFEBLD_opCONTER)
6859 || (ffeinfo_basictype (ffebld_info (stop)) != FFEINFO_basictypeINTEGER)
6860 || (ffeinfo_kindtype (ffebld_info (stop))
6861 != FFEINFO_kindtypeINTEGERDEFAULT))
6862 return expr;
6863 last = ffebld_constant_integerdefault (ffebld_conter (stop));
6864 }
6865
6866 /* Handle problems that should have already been diagnosed, but
6867 left in the expression tree. */
6868
6869 if (first <= 0)
6870 first = 1;
6871 if (last < first)
6872 last = first + len - 1;
6873
6874 if ((first == 1) && (last == len))
6875 { /* Same as original. */
6876 expr = ffebld_new_conter_with_orig (ffebld_constant_copy
6877 (ffebld_conter (l)), expr);
6878 ffebld_set_info (expr, ffeinfo_new
6879 (FFEINFO_basictypeCHARACTER,
6880 kt,
6881 0,
6882 FFEINFO_kindENTITY,
6883 FFEINFO_whereCONSTANT,
6884 len));
6885
6886 return expr;
6887 }
6888
6889 switch (ffeinfo_basictype (ffebld_info (expr)))
6890 {
6891 case FFEINFO_basictypeANY:
6892 return expr;
6893
6894 case FFEINFO_basictypeCHARACTER:
6895 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6896 {
6897 #if FFETARGET_okCHARACTER1
6898 case FFEINFO_kindtypeCHARACTER1:
6899 error = ffetarget_substr_character1 (ffebld_cu_ptr_character1 (u),
6900 ffebld_constant_character1 (ffebld_conter (l)), first, last,
6901 ffebld_constant_pool (), &len);
6902 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
6903 (ffebld_cu_val_character1 (u)), expr);
6904 break;
6905 #endif
6906
6907 #if FFETARGET_okCHARACTER2
6908 case FFEINFO_kindtypeCHARACTER2:
6909 error = ffetarget_substr_character2 (ffebld_cu_ptr_character2 (u),
6910 ffebld_constant_character2 (ffebld_conter (l)), first, last,
6911 ffebld_constant_pool (), &len);
6912 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val
6913 (ffebld_cu_val_character2 (u)), expr);
6914 break;
6915 #endif
6916
6917 #if FFETARGET_okCHARACTER3
6918 case FFEINFO_kindtypeCHARACTER3:
6919 error = ffetarget_substr_character3 (ffebld_cu_ptr_character3 (u),
6920 ffebld_constant_character3 (ffebld_conter (l)), first, last,
6921 ffebld_constant_pool (), &len);
6922 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val
6923 (ffebld_cu_val_character3 (u)), expr);
6924 break;
6925 #endif
6926
6927 #if FFETARGET_okCHARACTER4
6928 case FFEINFO_kindtypeCHARACTER4:
6929 error = ffetarget_substr_character4 (ffebld_cu_ptr_character4 (u),
6930 ffebld_constant_character4 (ffebld_conter (l)), first, last,
6931 ffebld_constant_pool (), &len);
6932 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val
6933 (ffebld_cu_val_character4 (u)), expr);
6934 break;
6935 #endif
6936
6937 default:
6938 assert ("bad character kind type" == NULL);
6939 break;
6940 }
6941 break;
6942
6943 default:
6944 assert ("bad type" == NULL);
6945 return expr;
6946 }
6947
6948 ffebld_set_info (expr, ffeinfo_new
6949 (FFEINFO_basictypeCHARACTER,
6950 kt,
6951 0,
6952 FFEINFO_kindENTITY,
6953 FFEINFO_whereCONSTANT,
6954 len));
6955
6956 if ((error != FFEBAD)
6957 && ffebad_start (error))
6958 {
6959 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6960 ffebad_finish ();
6961 }
6962
6963 return expr;
6964 }
6965
6966 /* ffeexpr_convert -- Convert source expression to given type
6967
6968 ffebld source;
6969 ffelexToken source_token;
6970 ffelexToken dest_token; // Any appropriate token for "destination".
6971 ffeinfoBasictype bt;
6972 ffeinfoKindtype kt;
6973 ffetargetCharactersize sz;
6974 ffeexprContext context; // Mainly LET or DATA.
6975 source = ffeexpr_convert(source,source_token,dest_token,bt,kt,sz,context);
6976
6977 If the expression conforms, returns the source expression. Otherwise
6978 returns source wrapped in a convert node doing the conversion, or
6979 ANY wrapped in convert if there is a conversion error (and issues an
6980 error message). Be sensitive to the context for certain aspects of
6981 the conversion. */
6982
6983 ffebld
6984 ffeexpr_convert (ffebld source, ffelexToken source_token, ffelexToken dest_token,
6985 ffeinfoBasictype bt, ffeinfoKindtype kt, ffeinfoRank rk,
6986 ffetargetCharacterSize sz, ffeexprContext context)
6987 {
6988 bool bad;
6989 ffeinfo info;
6990 ffeinfoWhere wh;
6991
6992 info = ffebld_info (source);
6993 if ((bt != ffeinfo_basictype (info))
6994 || (kt != ffeinfo_kindtype (info))
6995 || (rk != 0) /* Can't convert from or to arrays yet. */
6996 || (ffeinfo_rank (info) != 0)
6997 || (sz != ffebld_size_known (source)))
6998 #if 0 /* Nobody seems to need this spurious CONVERT node. */
6999 || ((context != FFEEXPR_contextLET)
7000 && (bt == FFEINFO_basictypeCHARACTER)
7001 && (sz == FFETARGET_charactersizeNONE)))
7002 #endif
7003 {
7004 switch (ffeinfo_basictype (info))
7005 {
7006 case FFEINFO_basictypeLOGICAL:
7007 switch (bt)
7008 {
7009 case FFEINFO_basictypeLOGICAL:
7010 bad = FALSE;
7011 break;
7012
7013 case FFEINFO_basictypeINTEGER:
7014 bad = !ffe_is_ugly_logint ();
7015 break;
7016
7017 case FFEINFO_basictypeCHARACTER:
7018 bad = ffe_is_pedantic ()
7019 || !(ffe_is_ugly_init ()
7020 && (context == FFEEXPR_contextDATA));
7021 break;
7022
7023 default:
7024 bad = TRUE;
7025 break;
7026 }
7027 break;
7028
7029 case FFEINFO_basictypeINTEGER:
7030 switch (bt)
7031 {
7032 case FFEINFO_basictypeINTEGER:
7033 case FFEINFO_basictypeREAL:
7034 case FFEINFO_basictypeCOMPLEX:
7035 bad = FALSE;
7036 break;
7037
7038 case FFEINFO_basictypeLOGICAL:
7039 bad = !ffe_is_ugly_logint ();
7040 break;
7041
7042 case FFEINFO_basictypeCHARACTER:
7043 bad = ffe_is_pedantic ()
7044 || !(ffe_is_ugly_init ()
7045 && (context == FFEEXPR_contextDATA));
7046 break;
7047
7048 default:
7049 bad = TRUE;
7050 break;
7051 }
7052 break;
7053
7054 case FFEINFO_basictypeREAL:
7055 case FFEINFO_basictypeCOMPLEX:
7056 switch (bt)
7057 {
7058 case FFEINFO_basictypeINTEGER:
7059 case FFEINFO_basictypeREAL:
7060 case FFEINFO_basictypeCOMPLEX:
7061 bad = FALSE;
7062 break;
7063
7064 case FFEINFO_basictypeCHARACTER:
7065 bad = TRUE;
7066 break;
7067
7068 default:
7069 bad = TRUE;
7070 break;
7071 }
7072 break;
7073
7074 case FFEINFO_basictypeCHARACTER:
7075 bad = (bt != FFEINFO_basictypeCHARACTER)
7076 && (ffe_is_pedantic ()
7077 || (bt != FFEINFO_basictypeINTEGER)
7078 || !(ffe_is_ugly_init ()
7079 && (context == FFEEXPR_contextDATA)));
7080 break;
7081
7082 case FFEINFO_basictypeTYPELESS:
7083 case FFEINFO_basictypeHOLLERITH:
7084 bad = ffe_is_pedantic ()
7085 || !(ffe_is_ugly_init ()
7086 && ((context == FFEEXPR_contextDATA)
7087 || (context == FFEEXPR_contextLET)));
7088 break;
7089
7090 default:
7091 bad = TRUE;
7092 break;
7093 }
7094
7095 if (!bad && ((rk != 0) || (ffeinfo_rank (info) != 0)))
7096 bad = TRUE;
7097
7098 if (bad && (bt != FFEINFO_basictypeANY) && (kt != FFEINFO_kindtypeANY)
7099 && (ffeinfo_basictype (info) != FFEINFO_basictypeANY)
7100 && (ffeinfo_kindtype (info) != FFEINFO_kindtypeANY)
7101 && (ffeinfo_where (info) != FFEINFO_whereANY))
7102 {
7103 if (ffebad_start (FFEBAD_BAD_TYPES))
7104 {
7105 if (dest_token == NULL)
7106 ffebad_here (0, ffewhere_line_unknown (),
7107 ffewhere_column_unknown ());
7108 else
7109 ffebad_here (0, ffelex_token_where_line (dest_token),
7110 ffelex_token_where_column (dest_token));
7111 assert (source_token != NULL);
7112 ffebad_here (1, ffelex_token_where_line (source_token),
7113 ffelex_token_where_column (source_token));
7114 ffebad_finish ();
7115 }
7116
7117 source = ffebld_new_any ();
7118 ffebld_set_info (source, ffeinfo_new_any ());
7119 }
7120 else
7121 {
7122 switch (ffeinfo_where (info))
7123 {
7124 case FFEINFO_whereCONSTANT:
7125 wh = FFEINFO_whereCONSTANT;
7126 break;
7127
7128 case FFEINFO_whereIMMEDIATE:
7129 wh = FFEINFO_whereIMMEDIATE;
7130 break;
7131
7132 default:
7133 wh = FFEINFO_whereFLEETING;
7134 break;
7135 }
7136 source = ffebld_new_convert (source);
7137 ffebld_set_info (source, ffeinfo_new
7138 (bt,
7139 kt,
7140 0,
7141 FFEINFO_kindENTITY,
7142 wh,
7143 sz));
7144 source = ffeexpr_collapse_convert (source, source_token);
7145 }
7146 }
7147
7148 return source;
7149 }
7150
7151 /* ffeexpr_convert_expr -- Convert source expr to conform to dest expr
7152
7153 ffebld source;
7154 ffebld dest;
7155 ffelexToken source_token;
7156 ffelexToken dest_token;
7157 ffeexprContext context;
7158 source = ffeexpr_convert_expr(source,source_token,dest,dest_token,context);
7159
7160 If the expressions conform, returns the source expression. Otherwise
7161 returns source wrapped in a convert node doing the conversion, or
7162 ANY wrapped in convert if there is a conversion error (and issues an
7163 error message). Be sensitive to the context, such as LET or DATA. */
7164
7165 ffebld
7166 ffeexpr_convert_expr (ffebld source, ffelexToken source_token, ffebld dest,
7167 ffelexToken dest_token, ffeexprContext context)
7168 {
7169 ffeinfo info;
7170
7171 info = ffebld_info (dest);
7172 return ffeexpr_convert (source, source_token, dest_token,
7173 ffeinfo_basictype (info),
7174 ffeinfo_kindtype (info),
7175 ffeinfo_rank (info),
7176 ffebld_size_known (dest),
7177 context);
7178 }
7179
7180 /* ffeexpr_convert_to_sym -- Convert source expression to conform to symbol
7181
7182 ffebld source;
7183 ffesymbol dest;
7184 ffelexToken source_token;
7185 ffelexToken dest_token;
7186 source = ffeexpr_convert_to_sym(source,source_token,dest,dest_token);
7187
7188 If the expressions conform, returns the source expression. Otherwise
7189 returns source wrapped in a convert node doing the conversion, or
7190 ANY wrapped in convert if there is a conversion error (and issues an
7191 error message). */
7192
7193 ffebld
7194 ffeexpr_convert_to_sym (ffebld source, ffelexToken source_token,
7195 ffesymbol dest, ffelexToken dest_token)
7196 {
7197 return ffeexpr_convert (source, source_token, dest_token, ffesymbol_basictype (dest),
7198 ffesymbol_kindtype (dest), ffesymbol_rank (dest), ffesymbol_size (dest),
7199 FFEEXPR_contextLET);
7200 }
7201
7202 /* Initializes the module. */
7203
7204 void
7205 ffeexpr_init_2 ()
7206 {
7207 ffeexpr_stack_ = NULL;
7208 ffeexpr_level_ = 0;
7209 }
7210
7211 /* ffeexpr_lhs -- Begin processing left-hand-side-context expression
7212
7213 Prepares cluster for delivery of lexer tokens representing an expression
7214 in a left-hand-side context (A in A=B, for example). ffebld is used
7215 to build expressions in the given pool. The appropriate lexer-token
7216 handling routine within ffeexpr is returned. When the end of the
7217 expression is detected, mycallbackroutine is called with the resulting
7218 single ffebld object specifying the entire expression and the first
7219 lexer token that is not considered part of the expression. This caller-
7220 supplied routine itself returns a lexer-token handling routine. Thus,
7221 if necessary, ffeexpr can return several tokens as end-of-expression
7222 tokens if it needs to scan forward more than one in any instance. */
7223
7224 ffelexHandler
7225 ffeexpr_lhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
7226 {
7227 ffeexprStack_ s;
7228
7229 ffebld_pool_push (pool);
7230 s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
7231 s->previous = ffeexpr_stack_;
7232 s->pool = pool;
7233 s->context = context;
7234 s->callback = callback;
7235 s->first_token = NULL;
7236 s->exprstack = NULL;
7237 s->is_rhs = FALSE;
7238 ffeexpr_stack_ = s;
7239 return (ffelexHandler) ffeexpr_token_first_lhs_;
7240 }
7241
7242 /* ffeexpr_rhs -- Begin processing right-hand-side-context expression
7243
7244 return ffeexpr_rhs(malloc_pool_image(),mycallbackroutine); // to lexer.
7245
7246 Prepares cluster for delivery of lexer tokens representing an expression
7247 in a right-hand-side context (B in A=B, for example). ffebld is used
7248 to build expressions in the given pool. The appropriate lexer-token
7249 handling routine within ffeexpr is returned. When the end of the
7250 expression is detected, mycallbackroutine is called with the resulting
7251 single ffebld object specifying the entire expression and the first
7252 lexer token that is not considered part of the expression. This caller-
7253 supplied routine itself returns a lexer-token handling routine. Thus,
7254 if necessary, ffeexpr can return several tokens as end-of-expression
7255 tokens if it needs to scan forward more than one in any instance. */
7256
7257 ffelexHandler
7258 ffeexpr_rhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
7259 {
7260 ffeexprStack_ s;
7261
7262 ffebld_pool_push (pool);
7263 s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
7264 s->previous = ffeexpr_stack_;
7265 s->pool = pool;
7266 s->context = context;
7267 s->callback = callback;
7268 s->first_token = NULL;
7269 s->exprstack = NULL;
7270 s->is_rhs = TRUE;
7271 ffeexpr_stack_ = s;
7272 return (ffelexHandler) ffeexpr_token_first_rhs_;
7273 }
7274
7275 /* ffeexpr_cb_close_paren_ -- OPEN_PAREN expr
7276
7277 Pass it to ffeexpr_rhs as the callback routine.
7278
7279 Makes sure the end token is close-paren and swallows it, else issues
7280 an error message and doesn't swallow the token (passing it along instead).
7281 In either case wraps up subexpression construction by enclosing the
7282 ffebld expression in a paren. */
7283
7284 static ffelexHandler
7285 ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr, ffelexToken t)
7286 {
7287 ffeexprExpr_ e;
7288
7289 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7290 {
7291 /* Oops, naughty user didn't specify the close paren! */
7292
7293 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7294 {
7295 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7296 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7297 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7298 ffebad_finish ();
7299 }
7300
7301 e = ffeexpr_expr_new_ ();
7302 e->type = FFEEXPR_exprtypeOPERAND_;
7303 e->u.operand = ffebld_new_any ();
7304 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
7305 ffeexpr_exprstack_push_operand_ (e);
7306
7307 return
7308 (ffelexHandler) ffeexpr_find_close_paren_ (t,
7309 (ffelexHandler)
7310 ffeexpr_token_binary_);
7311 }
7312
7313 if (expr->op == FFEBLD_opIMPDO)
7314 {
7315 if (ffest_ffebad_start (FFEBAD_IMPDO_PAREN))
7316 {
7317 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7318 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7319 ffebad_finish ();
7320 }
7321 }
7322 else
7323 {
7324 expr = ffebld_new_paren (expr);
7325 ffebld_set_info (expr, ffeinfo_use (ffebld_info (ffebld_left (expr))));
7326 }
7327
7328 /* Now push the (parenthesized) expression as an operand onto the
7329 expression stack. */
7330
7331 e = ffeexpr_expr_new_ ();
7332 e->type = FFEEXPR_exprtypeOPERAND_;
7333 e->u.operand = expr;
7334 e->u.operand = ffeexpr_collapse_paren (e->u.operand, ft);
7335 e->token = ffeexpr_stack_->tokens[0];
7336 ffeexpr_exprstack_push_operand_ (e);
7337
7338 return (ffelexHandler) ffeexpr_token_binary_;
7339 }
7340
7341 /* ffeexpr_cb_close_paren_ambig_ -- OPEN_PAREN expr
7342
7343 Pass it to ffeexpr_rhs as the callback routine.
7344
7345 We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
7346 with the next token in t. If the next token is possibly a binary
7347 operator, continue processing the outer expression. If the next
7348 token is COMMA, then the expression is a unit specifier, and
7349 parentheses should not be added to it because it surrounds the
7350 I/O control list that starts with the unit specifier (and continues
7351 on from here -- we haven't seen the CLOSE_PAREN that matches the
7352 OPEN_PAREN, it is up to the callback function to expect to see it
7353 at some point). In this case, we notify the callback function that
7354 the COMMA is inside, not outside, the parens by wrapping the expression
7355 in an opITEM (with a NULL trail) -- the callback function presumably
7356 unwraps it after seeing this kludgey indicator.
7357
7358 If the next token is CLOSE_PAREN, then we go to the _1_ state to
7359 decide what to do with the token after that.
7360
7361 15-Feb-91 JCB 1.1
7362 Use an extra state for the CLOSE_PAREN case to make READ &co really
7363 work right. */
7364
7365 static ffelexHandler
7366 ffeexpr_cb_close_paren_ambig_ (ffelexToken ft, ffebld expr, ffelexToken t)
7367 {
7368 ffeexprCallback callback;
7369 ffeexprStack_ s;
7370
7371 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7372 { /* Need to see the next token before we
7373 decide anything. */
7374 ffeexpr_stack_->expr = expr;
7375 ffeexpr_tokens_[0] = ffelex_token_use (ft);
7376 ffeexpr_tokens_[1] = ffelex_token_use (t);
7377 return (ffelexHandler) ffeexpr_cb_close_paren_ambig_1_;
7378 }
7379
7380 expr = ffeexpr_finished_ambig_ (ft, expr);
7381
7382 /* Let the callback function handle the case where t isn't COMMA. */
7383
7384 /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
7385 that preceded the expression starts a list of expressions, and the expr
7386 hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
7387 node. The callback function should extract the real expr from the head
7388 of this opITEM node after testing it. */
7389
7390 expr = ffebld_new_item (expr, NULL);
7391
7392 ffebld_pool_pop ();
7393 callback = ffeexpr_stack_->callback;
7394 ffelex_token_kill (ffeexpr_stack_->first_token);
7395 s = ffeexpr_stack_->previous;
7396 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
7397 ffeexpr_stack_ = s;
7398 return (ffelexHandler) (*callback) (ft, expr, t);
7399 }
7400
7401 /* ffeexpr_cb_close_paren_ambig_1_ -- OPEN_PAREN expr CLOSE_PAREN
7402
7403 See ffeexpr_cb_close_paren_ambig_.
7404
7405 We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
7406 with the next token in t. If the next token is possibly a binary
7407 operator, continue processing the outer expression. If the next
7408 token is COMMA, the expression is a parenthesized format specifier.
7409 If the next token is not EOS or SEMICOLON, then because it is not a
7410 binary operator (it is NAME, OPEN_PAREN, &c), the expression is
7411 a unit specifier, and parentheses should not be added to it because
7412 they surround the I/O control list that consists of only the unit
7413 specifier. If the next token is EOS or SEMICOLON, the statement
7414 must be disambiguated by looking at the type of the expression -- a
7415 character expression is a parenthesized format specifier, while a
7416 non-character expression is a unit specifier.
7417
7418 Another issue is how to do the callback so the recipient of the
7419 next token knows how to handle it if it is a COMMA. In all other
7420 cases, disambiguation is straightforward: the same approach as the
7421 above is used.
7422
7423 EXTENSION: in COMMA case, if not pedantic, use same disambiguation
7424 as for EOS/SEMICOLON case; f2c allows "READ (cilist) [[,]iolist]"
7425 and apparently other compilers do, as well, and some code out there
7426 uses this "feature".
7427
7428 19-Feb-91 JCB 1.1
7429 Extend to allow COMMA as nondisambiguating by itself. Remember
7430 to not try and check info field for opSTAR, since that expr doesn't
7431 have a valid info field. */
7432
7433 static ffelexHandler
7434 ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t)
7435 {
7436 ffeexprCallback callback;
7437 ffeexprStack_ s;
7438 ffelexHandler next;
7439 ffelexToken orig_ft = ffeexpr_tokens_[0]; /* In case callback clobbers
7440 these. */
7441 ffelexToken orig_t = ffeexpr_tokens_[1];
7442 ffebld expr = ffeexpr_stack_->expr;
7443
7444 switch (ffelex_token_type (t))
7445 {
7446 case FFELEX_typeCOMMA: /* Subexpr is parenthesized format specifier. */
7447 if (ffe_is_pedantic ())
7448 goto pedantic_comma; /* :::::::::::::::::::: */
7449 /* Fall through. */
7450 case FFELEX_typeEOS: /* Ambiguous; use type of expr to
7451 disambiguate. */
7452 case FFELEX_typeSEMICOLON:
7453 if ((expr == NULL) || (ffebld_op (expr) == FFEBLD_opANY)
7454 || (ffebld_op (expr) == FFEBLD_opSTAR)
7455 || (ffeinfo_basictype (ffebld_info (expr))
7456 != FFEINFO_basictypeCHARACTER))
7457 break; /* Not a valid CHARACTER entity, can't be a
7458 format spec. */
7459 /* Fall through. */
7460 default: /* Binary op (we assume; error otherwise);
7461 format specifier. */
7462
7463 pedantic_comma: /* :::::::::::::::::::: */
7464
7465 switch (ffeexpr_stack_->context)
7466 {
7467 case FFEEXPR_contextFILENUMAMBIG:
7468 ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
7469 break;
7470
7471 case FFEEXPR_contextFILEUNITAMBIG:
7472 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
7473 break;
7474
7475 default:
7476 assert ("bad context" == NULL);
7477 break;
7478 }
7479
7480 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
7481 next = (ffelexHandler) ffeexpr_cb_close_paren_ (orig_ft, expr, orig_t);
7482 ffelex_token_kill (orig_ft);
7483 ffelex_token_kill (orig_t);
7484 return (ffelexHandler) (*next) (t);
7485
7486 case FFELEX_typeOPEN_PAREN:/* Non-binary op; beginning of I/O list. */
7487 case FFELEX_typeNAME:
7488 break;
7489 }
7490
7491 expr = ffeexpr_finished_ambig_ (orig_ft, expr);
7492
7493 /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
7494 that preceded the expression starts a list of expressions, and the expr
7495 hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
7496 node. The callback function should extract the real expr from the head
7497 of this opITEM node after testing it. */
7498
7499 expr = ffebld_new_item (expr, NULL);
7500
7501 ffebld_pool_pop ();
7502 callback = ffeexpr_stack_->callback;
7503 ffelex_token_kill (ffeexpr_stack_->first_token);
7504 s = ffeexpr_stack_->previous;
7505 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
7506 ffeexpr_stack_ = s;
7507 next = (ffelexHandler) (*callback) (orig_ft, expr, orig_t);
7508 ffelex_token_kill (orig_ft);
7509 ffelex_token_kill (orig_t);
7510 return (ffelexHandler) (*next) (t);
7511 }
7512
7513 /* ffeexpr_cb_close_paren_c_ -- OPEN_PAREN expr (possible complex)
7514
7515 Pass it to ffeexpr_rhs as the callback routine.
7516
7517 Makes sure the end token is close-paren and swallows it, or a comma
7518 and handles complex/implied-do possibilities, else issues
7519 an error message and doesn't swallow the token (passing it along instead). */
7520
7521 static ffelexHandler
7522 ffeexpr_cb_close_paren_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
7523 {
7524 /* First check to see if this is a possible complex entity. It is if the
7525 token is a comma. */
7526
7527 if (ffelex_token_type (t) == FFELEX_typeCOMMA)
7528 {
7529 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
7530 ffeexpr_stack_->expr = expr;
7531 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7532 FFEEXPR_contextPAREN_, ffeexpr_cb_comma_c_);
7533 }
7534
7535 return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
7536 }
7537
7538 /* ffeexpr_cb_comma_c_ -- OPEN_PAREN expr COMMA expr
7539
7540 Pass it to ffeexpr_rhs as the callback routine.
7541
7542 If this token is not a comma, we have a complex constant (or an attempt
7543 at one), so handle it accordingly, displaying error messages if the token
7544 is not a close-paren. */
7545
7546 static ffelexHandler
7547 ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
7548 {
7549 ffeexprExpr_ e;
7550 ffeinfoBasictype lty = (ffeexpr_stack_->expr == NULL)
7551 ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (ffeexpr_stack_->expr));
7552 ffeinfoBasictype rty = (expr == NULL)
7553 ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (expr));
7554 ffeinfoKindtype lkt;
7555 ffeinfoKindtype rkt;
7556 ffeinfoKindtype nkt;
7557 bool ok = TRUE;
7558 ffebld orig;
7559
7560 if ((ffeexpr_stack_->expr == NULL)
7561 || (ffebld_op (ffeexpr_stack_->expr) != FFEBLD_opCONTER)
7562 || (((orig = ffebld_conter_orig (ffeexpr_stack_->expr)) != NULL)
7563 && (((ffebld_op (orig) != FFEBLD_opUMINUS)
7564 && (ffebld_op (orig) != FFEBLD_opUPLUS))
7565 || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
7566 || ((lty != FFEINFO_basictypeINTEGER)
7567 && (lty != FFEINFO_basictypeREAL)))
7568 {
7569 if ((lty != FFEINFO_basictypeANY)
7570 && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
7571 {
7572 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
7573 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
7574 ffebad_string ("Real");
7575 ffebad_finish ();
7576 }
7577 ok = FALSE;
7578 }
7579 if ((expr == NULL)
7580 || (ffebld_op (expr) != FFEBLD_opCONTER)
7581 || (((orig = ffebld_conter_orig (expr)) != NULL)
7582 && (((ffebld_op (orig) != FFEBLD_opUMINUS)
7583 && (ffebld_op (orig) != FFEBLD_opUPLUS))
7584 || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
7585 || ((rty != FFEINFO_basictypeINTEGER)
7586 && (rty != FFEINFO_basictypeREAL)))
7587 {
7588 if ((rty != FFEINFO_basictypeANY)
7589 && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
7590 {
7591 ffebad_here (0, ffelex_token_where_line (ft),
7592 ffelex_token_where_column (ft));
7593 ffebad_string ("Imaginary");
7594 ffebad_finish ();
7595 }
7596 ok = FALSE;
7597 }
7598
7599 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7600
7601 /* Push the (parenthesized) expression as an operand onto the expression
7602 stack. */
7603
7604 e = ffeexpr_expr_new_ ();
7605 e->type = FFEEXPR_exprtypeOPERAND_;
7606 e->token = ffeexpr_stack_->tokens[0];
7607
7608 if (ok)
7609 {
7610 if (lty == FFEINFO_basictypeINTEGER)
7611 lkt = FFEINFO_kindtypeREALDEFAULT;
7612 else
7613 lkt = ffeinfo_kindtype (ffebld_info (ffeexpr_stack_->expr));
7614 if (rty == FFEINFO_basictypeINTEGER)
7615 rkt = FFEINFO_kindtypeREALDEFAULT;
7616 else
7617 rkt = ffeinfo_kindtype (ffebld_info (expr));
7618
7619 nkt = ffeinfo_kindtype_max (FFEINFO_basictypeCOMPLEX, lkt, rkt);
7620 ffeexpr_stack_->expr = ffeexpr_convert (ffeexpr_stack_->expr,
7621 ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
7622 FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
7623 FFEEXPR_contextLET);
7624 expr = ffeexpr_convert (expr,
7625 ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
7626 FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
7627 FFEEXPR_contextLET);
7628 }
7629 else
7630 nkt = FFEINFO_kindtypeANY;
7631
7632 switch (nkt)
7633 {
7634 #if FFETARGET_okCOMPLEX1
7635 case FFEINFO_kindtypeREAL1:
7636 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex1
7637 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7638 ffebld_set_info (e->u.operand,
7639 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7640 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7641 FFETARGET_charactersizeNONE));
7642 break;
7643 #endif
7644
7645 #if FFETARGET_okCOMPLEX2
7646 case FFEINFO_kindtypeREAL2:
7647 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex2
7648 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7649 ffebld_set_info (e->u.operand,
7650 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7651 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7652 FFETARGET_charactersizeNONE));
7653 break;
7654 #endif
7655
7656 #if FFETARGET_okCOMPLEX3
7657 case FFEINFO_kindtypeREAL3:
7658 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex3
7659 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7660 ffebld_set_info (e->u.operand,
7661 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7662 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7663 FFETARGET_charactersizeNONE));
7664 break;
7665 #endif
7666
7667 #if FFETARGET_okCOMPLEX4
7668 case FFEINFO_kindtypeREAL4:
7669 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex4
7670 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7671 ffebld_set_info (e->u.operand,
7672 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7673 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7674 FFETARGET_charactersizeNONE));
7675 break;
7676 #endif
7677
7678 default:
7679 if (ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
7680 ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX))
7681 {
7682 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7683 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7684 ffebad_finish ();
7685 }
7686 /* Fall through. */
7687 case FFEINFO_kindtypeANY:
7688 e->u.operand = ffebld_new_any ();
7689 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
7690 break;
7691 }
7692 ffeexpr_exprstack_push_operand_ (e);
7693
7694 /* Now, if the token is a close parenthese, we're in great shape so return
7695 the next handler. */
7696
7697 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7698 return (ffelexHandler) ffeexpr_token_binary_;
7699
7700 /* Oops, naughty user didn't specify the close paren! */
7701
7702 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7703 {
7704 ffebad_here (0, ffelex_token_where_line (t),
7705 ffelex_token_where_column (t));
7706 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7707 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7708 ffebad_finish ();
7709 }
7710
7711 return
7712 (ffelexHandler) ffeexpr_find_close_paren_ (t,
7713 (ffelexHandler)
7714 ffeexpr_token_binary_);
7715 }
7716
7717 /* ffeexpr_cb_close_paren_ci_ -- OPEN_PAREN expr (possible complex or
7718 implied-DO construct)
7719
7720 Pass it to ffeexpr_rhs as the callback routine.
7721
7722 Makes sure the end token is close-paren and swallows it, or a comma
7723 and handles complex/implied-do possibilities, else issues
7724 an error message and doesn't swallow the token (passing it along instead). */
7725
7726 static ffelexHandler
7727 ffeexpr_cb_close_paren_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
7728 {
7729 ffeexprContext ctx;
7730
7731 /* First check to see if this is a possible complex or implied-DO entity.
7732 It is if the token is a comma. */
7733
7734 if (ffelex_token_type (t) == FFELEX_typeCOMMA)
7735 {
7736 switch (ffeexpr_stack_->context)
7737 {
7738 case FFEEXPR_contextIOLIST:
7739 case FFEEXPR_contextIMPDOITEM_:
7740 ctx = FFEEXPR_contextIMPDOITEM_;
7741 break;
7742
7743 case FFEEXPR_contextIOLISTDF:
7744 case FFEEXPR_contextIMPDOITEMDF_:
7745 ctx = FFEEXPR_contextIMPDOITEMDF_;
7746 break;
7747
7748 default:
7749 assert ("bad context" == NULL);
7750 ctx = FFEEXPR_contextIMPDOITEM_;
7751 break;
7752 }
7753
7754 ffeexpr_stack_->tokens[0] = ffelex_token_use (ft);
7755 ffeexpr_stack_->expr = expr;
7756 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7757 ctx, ffeexpr_cb_comma_ci_);
7758 }
7759
7760 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
7761 return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
7762 }
7763
7764 /* ffeexpr_cb_comma_ci_ -- OPEN_PAREN expr COMMA expr
7765
7766 Pass it to ffeexpr_rhs as the callback routine.
7767
7768 If this token is not a comma, we have a complex constant (or an attempt
7769 at one), so handle it accordingly, displaying error messages if the token
7770 is not a close-paren. If we have a comma here, it is an attempt at an
7771 implied-DO, so start making a list accordingly. Oh, it might be an
7772 equal sign also, meaning an implied-DO with only one item in its list. */
7773
7774 static ffelexHandler
7775 ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
7776 {
7777 ffebld fexpr;
7778
7779 /* First check to see if this is a possible complex constant. It is if the
7780 token is not a comma or an equals sign, in which case it should be a
7781 close-paren. */
7782
7783 if ((ffelex_token_type (t) != FFELEX_typeCOMMA)
7784 && (ffelex_token_type (t) != FFELEX_typeEQUALS))
7785 {
7786 ffeexpr_stack_->tokens[1] = ffeexpr_stack_->tokens[0];
7787 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
7788 return (ffelexHandler) ffeexpr_cb_comma_c_ (ft, expr, t);
7789 }
7790
7791 /* Here we have either EQUALS or COMMA, meaning we are in an implied-DO
7792 construct. Make a list and handle accordingly. */
7793
7794 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
7795 fexpr = ffeexpr_stack_->expr;
7796 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7797 ffebld_append_item (&ffeexpr_stack_->bottom, fexpr);
7798 return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
7799 }
7800
7801 /* ffeexpr_cb_comma_i_ -- OPEN_PAREN expr
7802
7803 Pass it to ffeexpr_rhs as the callback routine.
7804
7805 Handle first item in an implied-DO construct. */
7806
7807 static ffelexHandler
7808 ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr, ffelexToken t)
7809 {
7810 if (ffelex_token_type (t) != FFELEX_typeCOMMA)
7811 {
7812 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7813 {
7814 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7815 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7816 ffelex_token_where_column (ffeexpr_stack_->first_token));
7817 ffebad_finish ();
7818 }
7819 ffebld_end_list (&ffeexpr_stack_->bottom);
7820 ffeexpr_stack_->expr = ffebld_new_any ();
7821 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7822 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7823 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7824 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7825 }
7826
7827 return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
7828 }
7829
7830 /* ffeexpr_cb_comma_i_1_ -- OPEN_PAREN expr
7831
7832 Pass it to ffeexpr_rhs as the callback routine.
7833
7834 Handle first item in an implied-DO construct. */
7835
7836 static ffelexHandler
7837 ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr, ffelexToken t)
7838 {
7839 ffeexprContext ctxi;
7840 ffeexprContext ctxc;
7841
7842 switch (ffeexpr_stack_->context)
7843 {
7844 case FFEEXPR_contextDATA:
7845 case FFEEXPR_contextDATAIMPDOITEM_:
7846 ctxi = FFEEXPR_contextDATAIMPDOITEM_;
7847 ctxc = FFEEXPR_contextDATAIMPDOCTRL_;
7848 break;
7849
7850 case FFEEXPR_contextIOLIST:
7851 case FFEEXPR_contextIMPDOITEM_:
7852 ctxi = FFEEXPR_contextIMPDOITEM_;
7853 ctxc = FFEEXPR_contextIMPDOCTRL_;
7854 break;
7855
7856 case FFEEXPR_contextIOLISTDF:
7857 case FFEEXPR_contextIMPDOITEMDF_:
7858 ctxi = FFEEXPR_contextIMPDOITEMDF_;
7859 ctxc = FFEEXPR_contextIMPDOCTRL_;
7860 break;
7861
7862 default:
7863 assert ("bad context" == NULL);
7864 ctxi = FFEEXPR_context;
7865 ctxc = FFEEXPR_context;
7866 break;
7867 }
7868
7869 switch (ffelex_token_type (t))
7870 {
7871 case FFELEX_typeCOMMA:
7872 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7873 if (ffeexpr_stack_->is_rhs)
7874 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7875 ctxi, ffeexpr_cb_comma_i_1_);
7876 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7877 ctxi, ffeexpr_cb_comma_i_1_);
7878
7879 case FFELEX_typeEQUALS:
7880 ffebld_end_list (&ffeexpr_stack_->bottom);
7881
7882 /* Complain if implied-DO variable in list of items to be read. */
7883
7884 if ((ctxc == FFEEXPR_contextIMPDOCTRL_) && !ffeexpr_stack_->is_rhs)
7885 ffeexpr_check_impdo_ (ffeexpr_stack_->expr,
7886 ffeexpr_stack_->first_token, expr, ft);
7887
7888 /* Set doiter flag for all appropriate SYMTERs. */
7889
7890 ffeexpr_update_impdo_ (ffeexpr_stack_->expr, expr);
7891
7892 ffeexpr_stack_->expr = ffebld_new_impdo (ffeexpr_stack_->expr, NULL);
7893 ffebld_set_info (ffeexpr_stack_->expr,
7894 ffeinfo_new (FFEINFO_basictypeNONE,
7895 FFEINFO_kindtypeNONE,
7896 0,
7897 FFEINFO_kindNONE,
7898 FFEINFO_whereNONE,
7899 FFETARGET_charactersizeNONE));
7900 ffebld_init_list (&(ffebld_right (ffeexpr_stack_->expr)),
7901 &ffeexpr_stack_->bottom);
7902 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7903 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7904 ctxc, ffeexpr_cb_comma_i_2_);
7905
7906 default:
7907 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7908 {
7909 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7910 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7911 ffelex_token_where_column (ffeexpr_stack_->first_token));
7912 ffebad_finish ();
7913 }
7914 ffebld_end_list (&ffeexpr_stack_->bottom);
7915 ffeexpr_stack_->expr = ffebld_new_any ();
7916 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7917 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7918 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7919 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7920 }
7921 }
7922
7923 /* ffeexpr_cb_comma_i_2_ -- OPEN_PAREN expr-list EQUALS expr
7924
7925 Pass it to ffeexpr_rhs as the callback routine.
7926
7927 Handle start-value in an implied-DO construct. */
7928
7929 static ffelexHandler
7930 ffeexpr_cb_comma_i_2_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7931 {
7932 ffeexprContext ctx;
7933
7934 switch (ffeexpr_stack_->context)
7935 {
7936 case FFEEXPR_contextDATA:
7937 case FFEEXPR_contextDATAIMPDOITEM_:
7938 ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7939 break;
7940
7941 case FFEEXPR_contextIOLIST:
7942 case FFEEXPR_contextIOLISTDF:
7943 case FFEEXPR_contextIMPDOITEM_:
7944 case FFEEXPR_contextIMPDOITEMDF_:
7945 ctx = FFEEXPR_contextIMPDOCTRL_;
7946 break;
7947
7948 default:
7949 assert ("bad context" == NULL);
7950 ctx = FFEEXPR_context;
7951 break;
7952 }
7953
7954 switch (ffelex_token_type (t))
7955 {
7956 case FFELEX_typeCOMMA:
7957 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7958 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7959 ctx, ffeexpr_cb_comma_i_3_);
7960 break;
7961
7962 default:
7963 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7964 {
7965 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7966 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7967 ffelex_token_where_column (ffeexpr_stack_->first_token));
7968 ffebad_finish ();
7969 }
7970 ffebld_end_list (&ffeexpr_stack_->bottom);
7971 ffeexpr_stack_->expr = ffebld_new_any ();
7972 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7973 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7974 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7975 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7976 }
7977 }
7978
7979 /* ffeexpr_cb_comma_i_3_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7980
7981 Pass it to ffeexpr_rhs as the callback routine.
7982
7983 Handle end-value in an implied-DO construct. */
7984
7985 static ffelexHandler
7986 ffeexpr_cb_comma_i_3_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7987 {
7988 ffeexprContext ctx;
7989
7990 switch (ffeexpr_stack_->context)
7991 {
7992 case FFEEXPR_contextDATA:
7993 case FFEEXPR_contextDATAIMPDOITEM_:
7994 ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7995 break;
7996
7997 case FFEEXPR_contextIOLIST:
7998 case FFEEXPR_contextIOLISTDF:
7999 case FFEEXPR_contextIMPDOITEM_:
8000 case FFEEXPR_contextIMPDOITEMDF_:
8001 ctx = FFEEXPR_contextIMPDOCTRL_;
8002 break;
8003
8004 default:
8005 assert ("bad context" == NULL);
8006 ctx = FFEEXPR_context;
8007 break;
8008 }
8009
8010 switch (ffelex_token_type (t))
8011 {
8012 case FFELEX_typeCOMMA:
8013 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
8014 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8015 ctx, ffeexpr_cb_comma_i_4_);
8016 break;
8017
8018 case FFELEX_typeCLOSE_PAREN:
8019 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
8020 return (ffelexHandler) ffeexpr_cb_comma_i_4_ (NULL, NULL, t);
8021 break;
8022
8023 default:
8024 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
8025 {
8026 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8027 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
8028 ffelex_token_where_column (ffeexpr_stack_->first_token));
8029 ffebad_finish ();
8030 }
8031 ffebld_end_list (&ffeexpr_stack_->bottom);
8032 ffeexpr_stack_->expr = ffebld_new_any ();
8033 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
8034 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
8035 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
8036 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
8037 }
8038 }
8039
8040 /* ffeexpr_cb_comma_i_4_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
8041 [COMMA expr]
8042
8043 Pass it to ffeexpr_rhs as the callback routine.
8044
8045 Handle incr-value in an implied-DO construct. */
8046
8047 static ffelexHandler
8048 ffeexpr_cb_comma_i_4_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
8049 {
8050 switch (ffelex_token_type (t))
8051 {
8052 case FFELEX_typeCLOSE_PAREN:
8053 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
8054 ffebld_end_list (&ffeexpr_stack_->bottom);
8055 {
8056 ffebld item;
8057
8058 for (item = ffebld_left (ffeexpr_stack_->expr);
8059 item != NULL;
8060 item = ffebld_trail (item))
8061 if (ffebld_op (ffebld_head (item)) == FFEBLD_opANY)
8062 goto replace_with_any; /* :::::::::::::::::::: */
8063
8064 for (item = ffebld_right (ffeexpr_stack_->expr);
8065 item != NULL;
8066 item = ffebld_trail (item))
8067 if ((ffebld_head (item) != NULL) /* Increment may be NULL. */
8068 && (ffebld_op (ffebld_head (item)) == FFEBLD_opANY))
8069 goto replace_with_any; /* :::::::::::::::::::: */
8070 }
8071 break;
8072
8073 default:
8074 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
8075 {
8076 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8077 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
8078 ffelex_token_where_column (ffeexpr_stack_->first_token));
8079 ffebad_finish ();
8080 }
8081 ffebld_end_list (&ffeexpr_stack_->bottom);
8082
8083 replace_with_any: /* :::::::::::::::::::: */
8084
8085 ffeexpr_stack_->expr = ffebld_new_any ();
8086 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
8087 break;
8088 }
8089
8090 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
8091 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
8092 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
8093 }
8094
8095 /* ffeexpr_cb_comma_i_5_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
8096 [COMMA expr] CLOSE_PAREN
8097
8098 Pass it to ffeexpr_rhs as the callback routine.
8099
8100 Collects token following implied-DO construct for callback function. */
8101
8102 static ffelexHandler
8103 ffeexpr_cb_comma_i_5_ (ffelexToken t)
8104 {
8105 ffeexprCallback callback;
8106 ffeexprStack_ s;
8107 ffelexHandler next;
8108 ffelexToken ft;
8109 ffebld expr;
8110 bool terminate;
8111
8112 switch (ffeexpr_stack_->context)
8113 {
8114 case FFEEXPR_contextDATA:
8115 case FFEEXPR_contextDATAIMPDOITEM_:
8116 terminate = TRUE;
8117 break;
8118
8119 case FFEEXPR_contextIOLIST:
8120 case FFEEXPR_contextIOLISTDF:
8121 case FFEEXPR_contextIMPDOITEM_:
8122 case FFEEXPR_contextIMPDOITEMDF_:
8123 terminate = FALSE;
8124 break;
8125
8126 default:
8127 assert ("bad context" == NULL);
8128 terminate = FALSE;
8129 break;
8130 }
8131
8132 ffebld_pool_pop ();
8133 callback = ffeexpr_stack_->callback;
8134 ft = ffeexpr_stack_->first_token;
8135 expr = ffeexpr_stack_->expr;
8136 s = ffeexpr_stack_->previous;
8137 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
8138 sizeof (*ffeexpr_stack_));
8139 ffeexpr_stack_ = s;
8140 next = (ffelexHandler) (*callback) (ft, expr, t);
8141 ffelex_token_kill (ft);
8142 if (terminate)
8143 {
8144 ffesymbol_drive_sfnames (ffeexpr_check_impctrl_);
8145 --ffeexpr_level_;
8146 if (ffeexpr_level_ == 0)
8147 ffe_terminate_4 ();
8148 }
8149 return (ffelexHandler) next;
8150 }
8151
8152 /* ffeexpr_cb_end_loc_ -- Handle end of %LOC subexpression
8153
8154 Makes sure the end token is close-paren and swallows it, else issues
8155 an error message and doesn't swallow the token (passing it along instead).
8156 In either case wraps up subexpression construction by enclosing the
8157 ffebld expression in a %LOC. */
8158
8159 static ffelexHandler
8160 ffeexpr_cb_end_loc_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
8161 {
8162 ffeexprExpr_ e;
8163
8164 /* First push the (%LOC) expression as an operand onto the expression
8165 stack. */
8166
8167 e = ffeexpr_expr_new_ ();
8168 e->type = FFEEXPR_exprtypeOPERAND_;
8169 e->token = ffeexpr_stack_->tokens[0];
8170 e->u.operand = ffebld_new_percent_loc (expr);
8171 ffebld_set_info (e->u.operand,
8172 ffeinfo_new (FFEINFO_basictypeINTEGER,
8173 ffecom_pointer_kind (),
8174 0,
8175 FFEINFO_kindENTITY,
8176 FFEINFO_whereFLEETING,
8177 FFETARGET_charactersizeNONE));
8178 #if 0 /* ~~ */
8179 e->u.operand = ffeexpr_collapse_percent_loc (e->u.operand, ft);
8180 #endif
8181 ffeexpr_exprstack_push_operand_ (e);
8182
8183 /* Now, if the token is a close parenthese, we're in great shape so return
8184 the next handler. */
8185
8186 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
8187 {
8188 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8189 return (ffelexHandler) ffeexpr_token_binary_;
8190 }
8191
8192 /* Oops, naughty user didn't specify the close paren! */
8193
8194 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
8195 {
8196 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8197 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
8198 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
8199 ffebad_finish ();
8200 }
8201
8202 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8203 return
8204 (ffelexHandler) ffeexpr_find_close_paren_ (t,
8205 (ffelexHandler)
8206 ffeexpr_token_binary_);
8207 }
8208
8209 /* ffeexpr_cb_end_notloc_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
8210
8211 Should be CLOSE_PAREN, and make sure expr isn't a %(VAL,REF,DESCR). */
8212
8213 static ffelexHandler
8214 ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr, ffelexToken t)
8215 {
8216 ffeexprExpr_ e;
8217 ffebldOp op;
8218
8219 /* If expression is itself a %(VAL,REF,DESCR), complain and strip off all
8220 such things until the lowest-level expression is reached. */
8221
8222 op = ffebld_op (expr);
8223 if ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
8224 || (op == FFEBLD_opPERCENT_DESCR))
8225 {
8226 if (ffebad_start (FFEBAD_NESTED_PERCENT))
8227 {
8228 ffebad_here (0, ffelex_token_where_line (ft),
8229 ffelex_token_where_column (ft));
8230 ffebad_finish ();
8231 }
8232
8233 do
8234 {
8235 expr = ffebld_left (expr);
8236 op = ffebld_op (expr);
8237 }
8238 while ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
8239 || (op == FFEBLD_opPERCENT_DESCR));
8240 }
8241
8242 /* Push the expression as an operand onto the expression stack. */
8243
8244 e = ffeexpr_expr_new_ ();
8245 e->type = FFEEXPR_exprtypeOPERAND_;
8246 e->token = ffeexpr_stack_->tokens[0];
8247 switch (ffeexpr_stack_->percent)
8248 {
8249 case FFEEXPR_percentVAL_:
8250 e->u.operand = ffebld_new_percent_val (expr);
8251 break;
8252
8253 case FFEEXPR_percentREF_:
8254 e->u.operand = ffebld_new_percent_ref (expr);
8255 break;
8256
8257 case FFEEXPR_percentDESCR_:
8258 e->u.operand = ffebld_new_percent_descr (expr);
8259 break;
8260
8261 default:
8262 assert ("%lossage" == NULL);
8263 e->u.operand = expr;
8264 break;
8265 }
8266 ffebld_set_info (e->u.operand, ffebld_info (expr));
8267 #if 0 /* ~~ */
8268 e->u.operand = ffeexpr_collapse_percent_ ? ? ? (e->u.operand, ft);
8269 #endif
8270 ffeexpr_exprstack_push_operand_ (e);
8271
8272 /* Now, if the token is a close parenthese, we're in great shape so return
8273 the next handler. */
8274
8275 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
8276 return (ffelexHandler) ffeexpr_cb_end_notloc_1_;
8277
8278 /* Oops, naughty user didn't specify the close paren! */
8279
8280 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
8281 {
8282 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8283 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
8284 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
8285 ffebad_finish ();
8286 }
8287
8288 ffebld_set_op (e->u.operand, FFEBLD_opPERCENT_LOC);
8289
8290 switch (ffeexpr_stack_->context)
8291 {
8292 case FFEEXPR_contextACTUALARG_:
8293 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8294 break;
8295
8296 case FFEEXPR_contextINDEXORACTUALARG_:
8297 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8298 break;
8299
8300 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8301 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8302 break;
8303
8304 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8305 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8306 break;
8307
8308 default:
8309 assert ("bad context?!?!" == NULL);
8310 break;
8311 }
8312
8313 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8314 return
8315 (ffelexHandler) ffeexpr_find_close_paren_ (t,
8316 (ffelexHandler)
8317 ffeexpr_cb_end_notloc_1_);
8318 }
8319
8320 /* ffeexpr_cb_end_notloc_1_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
8321 CLOSE_PAREN
8322
8323 Should be COMMA or CLOSE_PAREN, else change back to %LOC. */
8324
8325 static ffelexHandler
8326 ffeexpr_cb_end_notloc_1_ (ffelexToken t)
8327 {
8328 switch (ffelex_token_type (t))
8329 {
8330 case FFELEX_typeCOMMA:
8331 case FFELEX_typeCLOSE_PAREN:
8332 switch (ffeexpr_stack_->context)
8333 {
8334 case FFEEXPR_contextACTUALARG_:
8335 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8336 break;
8337
8338 case FFEEXPR_contextINDEXORACTUALARG_:
8339 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
8340 break;
8341
8342 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8343 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
8344 break;
8345
8346 default:
8347 assert ("bad context?!?!" == NULL);
8348 break;
8349 }
8350 break;
8351
8352 default:
8353 if (ffebad_start (FFEBAD_INVALID_PERCENT))
8354 {
8355 ffebad_here (0,
8356 ffelex_token_where_line (ffeexpr_stack_->first_token),
8357 ffelex_token_where_column (ffeexpr_stack_->first_token));
8358 ffebad_string (ffelex_token_text (ffeexpr_stack_->tokens[1]));
8359 ffebad_finish ();
8360 }
8361
8362 ffebld_set_op (ffeexpr_stack_->exprstack->u.operand,
8363 FFEBLD_opPERCENT_LOC);
8364
8365 switch (ffeexpr_stack_->context)
8366 {
8367 case FFEEXPR_contextACTUALARG_:
8368 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8369 break;
8370
8371 case FFEEXPR_contextINDEXORACTUALARG_:
8372 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8373 break;
8374
8375 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8376 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8377 break;
8378
8379 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8380 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8381 break;
8382
8383 default:
8384 assert ("bad context?!?!" == NULL);
8385 break;
8386 }
8387 }
8388
8389 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8390 return
8391 (ffelexHandler) ffeexpr_token_binary_ (t);
8392 }
8393
8394 /* Process DATA implied-DO iterator variables as this implied-DO level
8395 terminates. At this point, ffeexpr_level_ == 1 when we see the
8396 last right-paren in "DATA (A(I),I=1,10)/.../". */
8397
8398 static ffesymbol
8399 ffeexpr_check_impctrl_ (ffesymbol s)
8400 {
8401 assert (s != NULL);
8402 assert (ffesymbol_sfdummyparent (s) != NULL);
8403
8404 switch (ffesymbol_state (s))
8405 {
8406 case FFESYMBOL_stateNONE: /* Used as iterator already. Now let symbol
8407 be used as iterator at any level at or
8408 innermore than the outermost of the
8409 current level and the symbol's current
8410 level. */
8411 if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
8412 {
8413 ffesymbol_signal_change (s);
8414 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
8415 ffesymbol_signal_unreported (s);
8416 }
8417 break;
8418
8419 case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO.
8420 Error if at outermost level, else it can
8421 still become an iterator. */
8422 if ((ffeexpr_level_ == 1)
8423 && ffebad_start (FFEBAD_BAD_IMPDCL))
8424 {
8425 ffebad_string (ffesymbol_text (s));
8426 ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
8427 ffebad_finish ();
8428 }
8429 break;
8430
8431 case FFESYMBOL_stateUNCERTAIN: /* Iterator. */
8432 assert (ffeexpr_level_ <= ffesymbol_maxentrynum (s));
8433 ffesymbol_signal_change (s);
8434 ffesymbol_set_state (s, FFESYMBOL_stateNONE);
8435 ffesymbol_signal_unreported (s);
8436 break;
8437
8438 case FFESYMBOL_stateUNDERSTOOD:
8439 break; /* ANY. */
8440
8441 default:
8442 assert ("Sasha Foo!!" == NULL);
8443 break;
8444 }
8445
8446 return s;
8447 }
8448
8449 /* Issue diagnostic if implied-DO variable appears in list of lhs
8450 expressions (as in "READ *, (I,I=1,10)"). */
8451
8452 static void
8453 ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
8454 ffebld dovar, ffelexToken dovar_t)
8455 {
8456 ffebld item;
8457 ffesymbol dovar_sym;
8458 int itemnum;
8459
8460 if (ffebld_op (dovar) != FFEBLD_opSYMTER)
8461 return; /* Presumably opANY. */
8462
8463 dovar_sym = ffebld_symter (dovar);
8464
8465 for (itemnum = 1; list != NULL; list = ffebld_trail (list), ++itemnum)
8466 {
8467 if (((item = ffebld_head (list)) != NULL)
8468 && (ffebld_op (item) == FFEBLD_opSYMTER)
8469 && (ffebld_symter (item) == dovar_sym))
8470 {
8471 char itemno[20];
8472
8473 sprintf (&itemno[0], "%d", itemnum);
8474 if (ffebad_start (FFEBAD_DOITER_IMPDO))
8475 {
8476 ffebad_here (0, ffelex_token_where_line (list_t),
8477 ffelex_token_where_column (list_t));
8478 ffebad_here (1, ffelex_token_where_line (dovar_t),
8479 ffelex_token_where_column (dovar_t));
8480 ffebad_string (ffesymbol_text (dovar_sym));
8481 ffebad_string (itemno);
8482 ffebad_finish ();
8483 }
8484 }
8485 }
8486 }
8487
8488 /* Decorate any SYMTERs referencing the DO variable with the "doiter"
8489 flag. */
8490
8491 static void
8492 ffeexpr_update_impdo_ (ffebld list, ffebld dovar)
8493 {
8494 ffesymbol dovar_sym;
8495
8496 if (ffebld_op (dovar) != FFEBLD_opSYMTER)
8497 return; /* Presumably opANY. */
8498
8499 dovar_sym = ffebld_symter (dovar);
8500
8501 ffeexpr_update_impdo_sym_ (list, dovar_sym); /* Recurse! */
8502 }
8503
8504 /* Recursive function to update any expr so SYMTERs have "doiter" flag
8505 if they refer to the given variable. */
8506
8507 static void
8508 ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar)
8509 {
8510 tail_recurse: /* :::::::::::::::::::: */
8511
8512 if (expr == NULL)
8513 return;
8514
8515 switch (ffebld_op (expr))
8516 {
8517 case FFEBLD_opSYMTER:
8518 if (ffebld_symter (expr) == dovar)
8519 ffebld_symter_set_is_doiter (expr, TRUE);
8520 break;
8521
8522 case FFEBLD_opITEM:
8523 ffeexpr_update_impdo_sym_ (ffebld_head (expr), dovar);
8524 expr = ffebld_trail (expr);
8525 goto tail_recurse; /* :::::::::::::::::::: */
8526
8527 default:
8528 break;
8529 }
8530
8531 switch (ffebld_arity (expr))
8532 {
8533 case 2:
8534 ffeexpr_update_impdo_sym_ (ffebld_left (expr), dovar);
8535 expr = ffebld_right (expr);
8536 goto tail_recurse; /* :::::::::::::::::::: */
8537
8538 case 1:
8539 expr = ffebld_left (expr);
8540 goto tail_recurse; /* :::::::::::::::::::: */
8541
8542 default:
8543 break;
8544 }
8545
8546 return;
8547 }
8548
8549 /* ffeexpr_context_outer_ -- Determine context of stack entry, skipping PARENs
8550
8551 if (ffeexpr_context_outer_(ffeexpr_stack_) == FFEEXPR_contextIF)
8552 // After zero or more PAREN_ contexts, an IF context exists */
8553
8554 static ffeexprContext
8555 ffeexpr_context_outer_ (ffeexprStack_ s)
8556 {
8557 assert (s != NULL);
8558
8559 for (;;)
8560 {
8561 switch (s->context)
8562 {
8563 case FFEEXPR_contextPAREN_:
8564 case FFEEXPR_contextPARENFILENUM_:
8565 case FFEEXPR_contextPARENFILEUNIT_:
8566 break;
8567
8568 default:
8569 return s->context;
8570 }
8571 s = s->previous;
8572 assert (s != NULL);
8573 }
8574 }
8575
8576 /* ffeexpr_percent_ -- Look up name in list of %FOO possibilities
8577
8578 ffeexprPercent_ p;
8579 ffelexToken t;
8580 p = ffeexpr_percent_(t);
8581
8582 Returns the identifier for the name, or the NONE identifier. */
8583
8584 static ffeexprPercent_
8585 ffeexpr_percent_ (ffelexToken t)
8586 {
8587 const char *p;
8588
8589 switch (ffelex_token_length (t))
8590 {
8591 case 3:
8592 switch (*(p = ffelex_token_text (t)))
8593 {
8594 case FFESRC_CASE_MATCH_INIT ('L', 'l', match_3l, no_match_3):
8595 if ((ffesrc_char_match_noninit (*++p, 'O', 'o'))
8596 && (ffesrc_char_match_noninit (*++p, 'C', 'c')))
8597 return FFEEXPR_percentLOC_;
8598 return FFEEXPR_percentNONE_;
8599
8600 case FFESRC_CASE_MATCH_INIT ('R', 'r', match_3r, no_match_3):
8601 if ((ffesrc_char_match_noninit (*++p, 'E', 'e'))
8602 && (ffesrc_char_match_noninit (*++p, 'F', 'f')))
8603 return FFEEXPR_percentREF_;
8604 return FFEEXPR_percentNONE_;
8605
8606 case FFESRC_CASE_MATCH_INIT ('V', 'v', match_3v, no_match_3):
8607 if ((ffesrc_char_match_noninit (*++p, 'A', 'a'))
8608 && (ffesrc_char_match_noninit (*++p, 'L', 'l')))
8609 return FFEEXPR_percentVAL_;
8610 return FFEEXPR_percentNONE_;
8611
8612 default:
8613 no_match_3: /* :::::::::::::::::::: */
8614 return FFEEXPR_percentNONE_;
8615 }
8616
8617 case 5:
8618 if (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "DESCR",
8619 "descr", "Descr") == 0)
8620 return FFEEXPR_percentDESCR_;
8621 return FFEEXPR_percentNONE_;
8622
8623 default:
8624 return FFEEXPR_percentNONE_;
8625 }
8626 }
8627
8628 /* ffeexpr_type_combine -- Binop combine types, check for mythical new COMPLEX
8629
8630 See prototype.
8631
8632 If combining the two basictype/kindtype pairs produces a COMPLEX with an
8633 unsupported kind type, complain and use the default kind type for
8634 COMPLEX. */
8635
8636 void
8637 ffeexpr_type_combine (ffeinfoBasictype *xnbt, ffeinfoKindtype *xnkt,
8638 ffeinfoBasictype lbt, ffeinfoKindtype lkt,
8639 ffeinfoBasictype rbt, ffeinfoKindtype rkt,
8640 ffelexToken t)
8641 {
8642 ffeinfoBasictype nbt;
8643 ffeinfoKindtype nkt;
8644
8645 nbt = ffeinfo_basictype_combine (lbt, rbt);
8646 if ((nbt == FFEINFO_basictypeCOMPLEX)
8647 && ((lbt == nbt) || (lbt == FFEINFO_basictypeREAL))
8648 && ((rbt == nbt) || (rbt == FFEINFO_basictypeREAL)))
8649 {
8650 nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
8651 if (ffe_is_pedantic_not_90 () && (nkt == FFEINFO_kindtypeREALDOUBLE))
8652 nkt = FFEINFO_kindtypeNONE; /* Force error. */
8653 switch (nkt)
8654 {
8655 #if FFETARGET_okCOMPLEX1
8656 case FFEINFO_kindtypeREAL1:
8657 #endif
8658 #if FFETARGET_okCOMPLEX2
8659 case FFEINFO_kindtypeREAL2:
8660 #endif
8661 #if FFETARGET_okCOMPLEX3
8662 case FFEINFO_kindtypeREAL3:
8663 #endif
8664 #if FFETARGET_okCOMPLEX4
8665 case FFEINFO_kindtypeREAL4:
8666 #endif
8667 break; /* Fine and dandy. */
8668
8669 default:
8670 if (t != NULL)
8671 {
8672 ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
8673 ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX);
8674 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8675 ffebad_finish ();
8676 }
8677 nbt = FFEINFO_basictypeNONE;
8678 nkt = FFEINFO_kindtypeNONE;
8679 break;
8680
8681 case FFEINFO_kindtypeANY:
8682 nkt = FFEINFO_kindtypeREALDEFAULT;
8683 break;
8684 }
8685 }
8686 else
8687 { /* The normal stuff. */
8688 if (nbt == lbt)
8689 {
8690 if (nbt == rbt)
8691 nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
8692 else
8693 nkt = lkt;
8694 }
8695 else if (nbt == rbt)
8696 nkt = rkt;
8697 else
8698 { /* Let the caller do the complaining. */
8699 nbt = FFEINFO_basictypeNONE;
8700 nkt = FFEINFO_kindtypeNONE;
8701 }
8702 }
8703
8704 /* Always a good idea to avoid aliasing problems. */
8705
8706 *xnbt = nbt;
8707 *xnkt = nkt;
8708 }
8709
8710 /* ffeexpr_token_first_lhs_ -- First state for lhs expression
8711
8712 Return a pointer to this function to the lexer (ffelex), which will
8713 invoke it for the next token.
8714
8715 Record line and column of first token in expression, then invoke the
8716 initial-state lhs handler. */
8717
8718 static ffelexHandler
8719 ffeexpr_token_first_lhs_ (ffelexToken t)
8720 {
8721 ffeexpr_stack_->first_token = ffelex_token_use (t);
8722
8723 /* When changing the list of valid initial lhs tokens, check whether to
8724 update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
8725 READ (expr) <token> case -- it assumes it knows which tokens <token> can
8726 be to indicate an lhs (or implied DO), which right now is the set
8727 {NAME,OPEN_PAREN}.
8728
8729 This comment also appears in ffeexpr_token_lhs_. */
8730
8731 switch (ffelex_token_type (t))
8732 {
8733 case FFELEX_typeOPEN_PAREN:
8734 switch (ffeexpr_stack_->context)
8735 {
8736 case FFEEXPR_contextDATA:
8737 ffe_init_4 ();
8738 ffeexpr_level_ = 1; /* Level of DATA implied-DO construct. */
8739 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8740 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8741 FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
8742
8743 case FFEEXPR_contextDATAIMPDOITEM_:
8744 ++ffeexpr_level_; /* Level of DATA implied-DO construct. */
8745 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8746 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8747 FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
8748
8749 case FFEEXPR_contextIOLIST:
8750 case FFEEXPR_contextIMPDOITEM_:
8751 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8752 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8753 FFEEXPR_contextIMPDOITEM_, ffeexpr_cb_comma_i_);
8754
8755 case FFEEXPR_contextIOLISTDF:
8756 case FFEEXPR_contextIMPDOITEMDF_:
8757 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8758 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8759 FFEEXPR_contextIMPDOITEMDF_, ffeexpr_cb_comma_i_);
8760
8761 case FFEEXPR_contextFILEEXTFUNC:
8762 assert (ffeexpr_stack_->exprstack == NULL);
8763 return (ffelexHandler) ffeexpr_token_first_lhs_1_;
8764
8765 default:
8766 break;
8767 }
8768 break;
8769
8770 case FFELEX_typeNAME:
8771 switch (ffeexpr_stack_->context)
8772 {
8773 case FFEEXPR_contextFILENAMELIST:
8774 assert (ffeexpr_stack_->exprstack == NULL);
8775 return (ffelexHandler) ffeexpr_token_namelist_;
8776
8777 case FFEEXPR_contextFILEEXTFUNC:
8778 assert (ffeexpr_stack_->exprstack == NULL);
8779 return (ffelexHandler) ffeexpr_token_first_lhs_1_;
8780
8781 default:
8782 break;
8783 }
8784 break;
8785
8786 default:
8787 switch (ffeexpr_stack_->context)
8788 {
8789 case FFEEXPR_contextFILEEXTFUNC:
8790 assert (ffeexpr_stack_->exprstack == NULL);
8791 return (ffelexHandler) ffeexpr_token_first_lhs_1_;
8792
8793 default:
8794 break;
8795 }
8796 break;
8797 }
8798
8799 return (ffelexHandler) ffeexpr_token_lhs_ (t);
8800 }
8801
8802 /* ffeexpr_token_first_lhs_1_ -- NAME
8803
8804 return ffeexpr_token_first_lhs_1_; // to lexer
8805
8806 Handle NAME as an external function (USEROPEN= VXT extension to OPEN
8807 statement). */
8808
8809 static ffelexHandler
8810 ffeexpr_token_first_lhs_1_ (ffelexToken t)
8811 {
8812 ffeexprCallback callback;
8813 ffeexprStack_ s;
8814 ffelexHandler next;
8815 ffelexToken ft;
8816 ffesymbol sy = NULL;
8817 ffebld expr;
8818
8819 ffebld_pool_pop ();
8820 callback = ffeexpr_stack_->callback;
8821 ft = ffeexpr_stack_->first_token;
8822 s = ffeexpr_stack_->previous;
8823
8824 if ((ffelex_token_type (ft) != FFELEX_typeNAME)
8825 || (ffesymbol_attrs (sy = ffeexpr_declare_unadorned_ (ft, FALSE))
8826 & FFESYMBOL_attrANY))
8827 {
8828 if ((ffelex_token_type (ft) != FFELEX_typeNAME)
8829 || !(ffesymbol_attrs (sy) & FFESYMBOL_attrsANY))
8830 {
8831 ffebad_start (FFEBAD_EXPR_WRONG);
8832 ffebad_here (0, ffelex_token_where_line (ft),
8833 ffelex_token_where_column (ft));
8834 ffebad_finish ();
8835 }
8836 expr = ffebld_new_any ();
8837 ffebld_set_info (expr, ffeinfo_new_any ());
8838 }
8839 else
8840 {
8841 expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
8842 FFEINTRIN_impNONE);
8843 ffebld_set_info (expr, ffesymbol_info (sy));
8844 }
8845
8846 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
8847 sizeof (*ffeexpr_stack_));
8848 ffeexpr_stack_ = s;
8849
8850 next = (ffelexHandler) (*callback) (ft, expr, t);
8851 ffelex_token_kill (ft);
8852 return (ffelexHandler) next;
8853 }
8854
8855 /* ffeexpr_token_first_rhs_ -- First state for rhs expression
8856
8857 Record line and column of first token in expression, then invoke the
8858 initial-state rhs handler.
8859
8860 19-Feb-91 JCB 1.1
8861 Allow ASTERISK in PARENFILEUNIT_ case, but only on second level only
8862 (i.e. only as in READ(*), not READ((*))). */
8863
8864 static ffelexHandler
8865 ffeexpr_token_first_rhs_ (ffelexToken t)
8866 {
8867 ffesymbol s;
8868
8869 ffeexpr_stack_->first_token = ffelex_token_use (t);
8870
8871 switch (ffelex_token_type (t))
8872 {
8873 case FFELEX_typeASTERISK:
8874 switch (ffeexpr_stack_->context)
8875 {
8876 case FFEEXPR_contextFILEFORMATNML:
8877 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8878 /* Fall through. */
8879 case FFEEXPR_contextFILEUNIT:
8880 case FFEEXPR_contextDIMLIST:
8881 case FFEEXPR_contextFILEFORMAT:
8882 case FFEEXPR_contextCHARACTERSIZE:
8883 if (ffeexpr_stack_->previous != NULL)
8884 break; /* Valid only on first level. */
8885 assert (ffeexpr_stack_->exprstack == NULL);
8886 return (ffelexHandler) ffeexpr_token_first_rhs_1_;
8887
8888 case FFEEXPR_contextPARENFILEUNIT_:
8889 if (ffeexpr_stack_->previous->previous != NULL)
8890 break; /* Valid only on second level. */
8891 assert (ffeexpr_stack_->exprstack == NULL);
8892 return (ffelexHandler) ffeexpr_token_first_rhs_1_;
8893
8894 case FFEEXPR_contextACTUALARG_:
8895 if (ffeexpr_stack_->previous->context
8896 != FFEEXPR_contextSUBROUTINEREF)
8897 {
8898 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8899 break;
8900 }
8901 assert (ffeexpr_stack_->exprstack == NULL);
8902 return (ffelexHandler) ffeexpr_token_first_rhs_3_;
8903
8904 case FFEEXPR_contextINDEXORACTUALARG_:
8905 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8906 break;
8907
8908 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8909 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8910 break;
8911
8912 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8913 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8914 break;
8915
8916 default:
8917 break;
8918 }
8919 break;
8920
8921 case FFELEX_typeOPEN_PAREN:
8922 switch (ffeexpr_stack_->context)
8923 {
8924 case FFEEXPR_contextFILENUMAMBIG:
8925 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8926 FFEEXPR_contextPARENFILENUM_,
8927 ffeexpr_cb_close_paren_ambig_);
8928
8929 case FFEEXPR_contextFILEUNITAMBIG:
8930 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8931 FFEEXPR_contextPARENFILEUNIT_,
8932 ffeexpr_cb_close_paren_ambig_);
8933
8934 case FFEEXPR_contextIOLIST:
8935 case FFEEXPR_contextIMPDOITEM_:
8936 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8937 FFEEXPR_contextIMPDOITEM_,
8938 ffeexpr_cb_close_paren_ci_);
8939
8940 case FFEEXPR_contextIOLISTDF:
8941 case FFEEXPR_contextIMPDOITEMDF_:
8942 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8943 FFEEXPR_contextIMPDOITEMDF_,
8944 ffeexpr_cb_close_paren_ci_);
8945
8946 case FFEEXPR_contextFILEFORMATNML:
8947 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8948 break;
8949
8950 case FFEEXPR_contextACTUALARG_:
8951 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8952 break;
8953
8954 case FFEEXPR_contextINDEXORACTUALARG_:
8955 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8956 break;
8957
8958 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8959 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8960 break;
8961
8962 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8963 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8964 break;
8965
8966 default:
8967 break;
8968 }
8969 break;
8970
8971 case FFELEX_typeNUMBER:
8972 switch (ffeexpr_stack_->context)
8973 {
8974 case FFEEXPR_contextFILEFORMATNML:
8975 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8976 /* Fall through. */
8977 case FFEEXPR_contextFILEFORMAT:
8978 if (ffeexpr_stack_->previous != NULL)
8979 break; /* Valid only on first level. */
8980 assert (ffeexpr_stack_->exprstack == NULL);
8981 return (ffelexHandler) ffeexpr_token_first_rhs_2_;
8982
8983 case FFEEXPR_contextACTUALARG_:
8984 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8985 break;
8986
8987 case FFEEXPR_contextINDEXORACTUALARG_:
8988 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8989 break;
8990
8991 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8992 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8993 break;
8994
8995 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8996 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8997 break;
8998
8999 default:
9000 break;
9001 }
9002 break;
9003
9004 case FFELEX_typeNAME:
9005 switch (ffeexpr_stack_->context)
9006 {
9007 case FFEEXPR_contextFILEFORMATNML:
9008 assert (ffeexpr_stack_->exprstack == NULL);
9009 s = ffesymbol_lookup_local (t);
9010 if ((s != NULL) && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST))
9011 return (ffelexHandler) ffeexpr_token_namelist_;
9012 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
9013 break;
9014
9015 default:
9016 break;
9017 }
9018 break;
9019
9020 case FFELEX_typePERCENT:
9021 switch (ffeexpr_stack_->context)
9022 {
9023 case FFEEXPR_contextACTUALARG_:
9024 case FFEEXPR_contextINDEXORACTUALARG_:
9025 case FFEEXPR_contextSFUNCDEFACTUALARG_:
9026 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9027 return (ffelexHandler) ffeexpr_token_first_rhs_5_;
9028
9029 case FFEEXPR_contextFILEFORMATNML:
9030 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
9031 break;
9032
9033 default:
9034 break;
9035 }
9036
9037 default:
9038 switch (ffeexpr_stack_->context)
9039 {
9040 case FFEEXPR_contextACTUALARG_:
9041 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
9042 break;
9043
9044 case FFEEXPR_contextINDEXORACTUALARG_:
9045 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
9046 break;
9047
9048 case FFEEXPR_contextSFUNCDEFACTUALARG_:
9049 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
9050 break;
9051
9052 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9053 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
9054 break;
9055
9056 case FFEEXPR_contextFILEFORMATNML:
9057 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
9058 break;
9059
9060 default:
9061 break;
9062 }
9063 break;
9064 }
9065
9066 return (ffelexHandler) ffeexpr_token_rhs_ (t);
9067 }
9068
9069 /* ffeexpr_token_first_rhs_1_ -- ASTERISK
9070
9071 return ffeexpr_token_first_rhs_1_; // to lexer
9072
9073 Return STAR as expression. */
9074
9075 static ffelexHandler
9076 ffeexpr_token_first_rhs_1_ (ffelexToken t)
9077 {
9078 ffebld expr;
9079 ffeexprCallback callback;
9080 ffeexprStack_ s;
9081 ffelexHandler next;
9082 ffelexToken ft;
9083
9084 expr = ffebld_new_star ();
9085 ffebld_pool_pop ();
9086 callback = ffeexpr_stack_->callback;
9087 ft = ffeexpr_stack_->first_token;
9088 s = ffeexpr_stack_->previous;
9089 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
9090 ffeexpr_stack_ = s;
9091 next = (ffelexHandler) (*callback) (ft, expr, t);
9092 ffelex_token_kill (ft);
9093 return (ffelexHandler) next;
9094 }
9095
9096 /* ffeexpr_token_first_rhs_2_ -- NUMBER
9097
9098 return ffeexpr_token_first_rhs_2_; // to lexer
9099
9100 Return NULL as expression; NUMBER as first (and only) token, unless the
9101 current token is not a terminating token, in which case run normal
9102 expression handling. */
9103
9104 static ffelexHandler
9105 ffeexpr_token_first_rhs_2_ (ffelexToken t)
9106 {
9107 ffeexprCallback callback;
9108 ffeexprStack_ s;
9109 ffelexHandler next;
9110 ffelexToken ft;
9111
9112 switch (ffelex_token_type (t))
9113 {
9114 case FFELEX_typeCLOSE_PAREN:
9115 case FFELEX_typeCOMMA:
9116 case FFELEX_typeEOS:
9117 case FFELEX_typeSEMICOLON:
9118 break;
9119
9120 default:
9121 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9122 return (ffelexHandler) (*next) (t);
9123 }
9124
9125 ffebld_pool_pop ();
9126 callback = ffeexpr_stack_->callback;
9127 ft = ffeexpr_stack_->first_token;
9128 s = ffeexpr_stack_->previous;
9129 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
9130 sizeof (*ffeexpr_stack_));
9131 ffeexpr_stack_ = s;
9132 next = (ffelexHandler) (*callback) (ft, NULL, t);
9133 ffelex_token_kill (ft);
9134 return (ffelexHandler) next;
9135 }
9136
9137 /* ffeexpr_token_first_rhs_3_ -- ASTERISK
9138
9139 return ffeexpr_token_first_rhs_3_; // to lexer
9140
9141 Expect NUMBER, make LABTOK (with copy of token if not inhibited after
9142 confirming, else NULL). */
9143
9144 static ffelexHandler
9145 ffeexpr_token_first_rhs_3_ (ffelexToken t)
9146 {
9147 ffelexHandler next;
9148
9149 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
9150 { /* An error, but let normal processing handle
9151 it. */
9152 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9153 return (ffelexHandler) (*next) (t);
9154 }
9155
9156 /* Special case: when we see "*10" as an argument to a subroutine
9157 reference, we confirm the current statement and, if not inhibited at
9158 this point, put a copy of the token into a LABTOK node. We do this
9159 instead of just resolving the label directly via ffelab and putting it
9160 into a LABTER simply to improve error reporting and consistency in
9161 ffestc. We put NULL in the LABTOK if we're still inhibited, so ffestb
9162 doesn't have to worry about killing off any tokens when retracting. */
9163
9164 ffest_confirmed ();
9165 if (ffest_is_inhibited ())
9166 ffeexpr_stack_->expr = ffebld_new_labtok (NULL);
9167 else
9168 ffeexpr_stack_->expr = ffebld_new_labtok (ffelex_token_use (t));
9169 ffebld_set_info (ffeexpr_stack_->expr,
9170 ffeinfo_new (FFEINFO_basictypeNONE,
9171 FFEINFO_kindtypeNONE,
9172 0,
9173 FFEINFO_kindNONE,
9174 FFEINFO_whereNONE,
9175 FFETARGET_charactersizeNONE));
9176
9177 return (ffelexHandler) ffeexpr_token_first_rhs_4_;
9178 }
9179
9180 /* ffeexpr_token_first_rhs_4_ -- ASTERISK NUMBER
9181
9182 return ffeexpr_token_first_rhs_4_; // to lexer
9183
9184 Collect/flush appropriate stuff, send token to callback function. */
9185
9186 static ffelexHandler
9187 ffeexpr_token_first_rhs_4_ (ffelexToken t)
9188 {
9189 ffebld expr;
9190 ffeexprCallback callback;
9191 ffeexprStack_ s;
9192 ffelexHandler next;
9193 ffelexToken ft;
9194
9195 expr = ffeexpr_stack_->expr;
9196 ffebld_pool_pop ();
9197 callback = ffeexpr_stack_->callback;
9198 ft = ffeexpr_stack_->first_token;
9199 s = ffeexpr_stack_->previous;
9200 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
9201 ffeexpr_stack_ = s;
9202 next = (ffelexHandler) (*callback) (ft, expr, t);
9203 ffelex_token_kill (ft);
9204 return (ffelexHandler) next;
9205 }
9206
9207 /* ffeexpr_token_first_rhs_5_ -- PERCENT
9208
9209 Should be NAME, or pass through original mechanism. If NAME is LOC,
9210 pass through original mechanism, otherwise must be VAL, REF, or DESCR,
9211 in which case handle the argument (in parentheses), etc. */
9212
9213 static ffelexHandler
9214 ffeexpr_token_first_rhs_5_ (ffelexToken t)
9215 {
9216 ffelexHandler next;
9217
9218 if (ffelex_token_type (t) == FFELEX_typeNAME)
9219 {
9220 ffeexprPercent_ p = ffeexpr_percent_ (t);
9221
9222 switch (p)
9223 {
9224 case FFEEXPR_percentNONE_:
9225 case FFEEXPR_percentLOC_:
9226 break; /* Treat %LOC as any other expression. */
9227
9228 case FFEEXPR_percentVAL_:
9229 case FFEEXPR_percentREF_:
9230 case FFEEXPR_percentDESCR_:
9231 ffeexpr_stack_->percent = p;
9232 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
9233 return (ffelexHandler) ffeexpr_token_first_rhs_6_;
9234
9235 default:
9236 assert ("bad percent?!?" == NULL);
9237 break;
9238 }
9239 }
9240
9241 switch (ffeexpr_stack_->context)
9242 {
9243 case FFEEXPR_contextACTUALARG_:
9244 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
9245 break;
9246
9247 case FFEEXPR_contextINDEXORACTUALARG_:
9248 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
9249 break;
9250
9251 case FFEEXPR_contextSFUNCDEFACTUALARG_:
9252 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
9253 break;
9254
9255 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9256 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
9257 break;
9258
9259 default:
9260 assert ("bad context?!?!" == NULL);
9261 break;
9262 }
9263
9264 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9265 return (ffelexHandler) (*next) (t);
9266 }
9267
9268 /* ffeexpr_token_first_rhs_6_ -- PERCENT NAME(VAL,REF,DESCR)
9269
9270 Should be OPEN_PAREN, or pass through original mechanism. */
9271
9272 static ffelexHandler
9273 ffeexpr_token_first_rhs_6_ (ffelexToken t)
9274 {
9275 ffelexHandler next;
9276 ffelexToken ft;
9277
9278 if (ffelex_token_type (t) == FFELEX_typeOPEN_PAREN)
9279 {
9280 ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
9281 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
9282 ffeexpr_stack_->context,
9283 ffeexpr_cb_end_notloc_);
9284 }
9285
9286 switch (ffeexpr_stack_->context)
9287 {
9288 case FFEEXPR_contextACTUALARG_:
9289 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
9290 break;
9291
9292 case FFEEXPR_contextINDEXORACTUALARG_:
9293 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
9294 break;
9295
9296 case FFEEXPR_contextSFUNCDEFACTUALARG_:
9297 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
9298 break;
9299
9300 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9301 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
9302 break;
9303
9304 default:
9305 assert ("bad context?!?!" == NULL);
9306 break;
9307 }
9308
9309 ft = ffeexpr_stack_->tokens[0];
9310 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9311 next = (ffelexHandler) (*next) (ft);
9312 ffelex_token_kill (ft);
9313 return (ffelexHandler) (*next) (t);
9314 }
9315
9316 /* ffeexpr_token_namelist_ -- NAME
9317
9318 return ffeexpr_token_namelist_; // to lexer
9319
9320 Make sure NAME was a valid namelist object, wrap it in a SYMTER and
9321 return. */
9322
9323 static ffelexHandler
9324 ffeexpr_token_namelist_ (ffelexToken t)
9325 {
9326 ffeexprCallback callback;
9327 ffeexprStack_ s;
9328 ffelexHandler next;
9329 ffelexToken ft;
9330 ffesymbol sy;
9331 ffebld expr;
9332
9333 ffebld_pool_pop ();
9334 callback = ffeexpr_stack_->callback;
9335 ft = ffeexpr_stack_->first_token;
9336 s = ffeexpr_stack_->previous;
9337 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
9338 ffeexpr_stack_ = s;
9339
9340 sy = ffesymbol_lookup_local (ft);
9341 if ((sy == NULL) || (ffesymbol_kind (sy) != FFEINFO_kindNAMELIST))
9342 {
9343 ffebad_start (FFEBAD_EXPR_WRONG);
9344 ffebad_here (0, ffelex_token_where_line (ft),
9345 ffelex_token_where_column (ft));
9346 ffebad_finish ();
9347 expr = ffebld_new_any ();
9348 ffebld_set_info (expr, ffeinfo_new_any ());
9349 }
9350 else
9351 {
9352 expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
9353 FFEINTRIN_impNONE);
9354 ffebld_set_info (expr, ffesymbol_info (sy));
9355 }
9356 next = (ffelexHandler) (*callback) (ft, expr, t);
9357 ffelex_token_kill (ft);
9358 return (ffelexHandler) next;
9359 }
9360
9361 /* ffeexpr_expr_kill_ -- Kill an existing internal expression object
9362
9363 ffeexprExpr_ e;
9364 ffeexpr_expr_kill_(e);
9365
9366 Kills the ffewhere info, if necessary, then kills the object. */
9367
9368 static void
9369 ffeexpr_expr_kill_ (ffeexprExpr_ e)
9370 {
9371 if (e->token != NULL)
9372 ffelex_token_kill (e->token);
9373 malloc_kill_ks (ffe_pool_program_unit (), e, sizeof (*e));
9374 }
9375
9376 /* ffeexpr_expr_new_ -- Make a new internal expression object
9377
9378 ffeexprExpr_ e;
9379 e = ffeexpr_expr_new_();
9380
9381 Allocates and initializes a new expression object, returns it. */
9382
9383 static ffeexprExpr_
9384 ffeexpr_expr_new_ ()
9385 {
9386 ffeexprExpr_ e;
9387
9388 e = (ffeexprExpr_) malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR expr",
9389 sizeof (*e));
9390 e->previous = NULL;
9391 e->type = FFEEXPR_exprtypeUNKNOWN_;
9392 e->token = NULL;
9393 return e;
9394 }
9395
9396 /* Verify that call to global is valid, and register whatever
9397 new information about a global might be discoverable by looking
9398 at the call. */
9399
9400 static void
9401 ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t)
9402 {
9403 int n_args;
9404 ffebld list;
9405 ffebld item;
9406 ffesymbol s;
9407
9408 assert ((ffebld_op (*expr) == FFEBLD_opSUBRREF)
9409 || (ffebld_op (*expr) == FFEBLD_opFUNCREF));
9410
9411 if (ffebld_op (ffebld_left (*expr)) != FFEBLD_opSYMTER)
9412 return;
9413
9414 if (ffesymbol_retractable ())
9415 return;
9416
9417 s = ffebld_symter (ffebld_left (*expr));
9418 if (ffesymbol_global (s) == NULL)
9419 return;
9420
9421 for (n_args = 0, list = ffebld_right (*expr);
9422 list != NULL;
9423 list = ffebld_trail (list), ++n_args)
9424 ;
9425
9426 if (ffeglobal_proc_ref_nargs (s, n_args, t))
9427 {
9428 ffeglobalArgSummary as;
9429 ffeinfoBasictype bt;
9430 ffeinfoKindtype kt;
9431 bool array;
9432 bool fail = FALSE;
9433
9434 for (n_args = 0, list = ffebld_right (*expr);
9435 list != NULL;
9436 list = ffebld_trail (list), ++n_args)
9437 {
9438 item = ffebld_head (list);
9439 if (item != NULL)
9440 {
9441 bt = ffeinfo_basictype (ffebld_info (item));
9442 kt = ffeinfo_kindtype (ffebld_info (item));
9443 array = (ffeinfo_rank (ffebld_info (item)) > 0);
9444 switch (ffebld_op (item))
9445 {
9446 case FFEBLD_opLABTOK:
9447 case FFEBLD_opLABTER:
9448 as = FFEGLOBAL_argsummaryALTRTN;
9449 break;
9450
9451 #if 0
9452 /* No, %LOC(foo) is just like any INTEGER(KIND=7)
9453 expression, so don't treat it specially. */
9454 case FFEBLD_opPERCENT_LOC:
9455 as = FFEGLOBAL_argsummaryPTR;
9456 break;
9457 #endif
9458
9459 case FFEBLD_opPERCENT_VAL:
9460 as = FFEGLOBAL_argsummaryVAL;
9461 break;
9462
9463 case FFEBLD_opPERCENT_REF:
9464 as = FFEGLOBAL_argsummaryREF;
9465 break;
9466
9467 case FFEBLD_opPERCENT_DESCR:
9468 as = FFEGLOBAL_argsummaryDESCR;
9469 break;
9470
9471 case FFEBLD_opFUNCREF:
9472 #if 0
9473 /* No, LOC(foo) is just like any INTEGER(KIND=7)
9474 expression, so don't treat it specially. */
9475 if ((ffebld_op (ffebld_left (item)) == FFEBLD_opSYMTER)
9476 && (ffesymbol_specific (ffebld_symter (ffebld_left (item)))
9477 == FFEINTRIN_specLOC))
9478 {
9479 as = FFEGLOBAL_argsummaryPTR;
9480 break;
9481 }
9482 #endif
9483 /* Fall through. */
9484 default:
9485 if (ffebld_op (item) == FFEBLD_opSYMTER)
9486 {
9487 as = FFEGLOBAL_argsummaryNONE;
9488
9489 switch (ffeinfo_kind (ffebld_info (item)))
9490 {
9491 case FFEINFO_kindFUNCTION:
9492 as = FFEGLOBAL_argsummaryFUNC;
9493 break;
9494
9495 case FFEINFO_kindSUBROUTINE:
9496 as = FFEGLOBAL_argsummarySUBR;
9497 break;
9498
9499 case FFEINFO_kindNONE:
9500 as = FFEGLOBAL_argsummaryPROC;
9501 break;
9502
9503 default:
9504 break;
9505 }
9506
9507 if (as != FFEGLOBAL_argsummaryNONE)
9508 break;
9509 }
9510
9511 if (bt == FFEINFO_basictypeCHARACTER)
9512 as = FFEGLOBAL_argsummaryDESCR;
9513 else
9514 as = FFEGLOBAL_argsummaryREF;
9515 break;
9516 }
9517 }
9518 else
9519 {
9520 array = FALSE;
9521 as = FFEGLOBAL_argsummaryNONE;
9522 bt = FFEINFO_basictypeNONE;
9523 kt = FFEINFO_kindtypeNONE;
9524 }
9525
9526 if (! ffeglobal_proc_ref_arg (s, n_args, as, bt, kt, array, t))
9527 fail = TRUE;
9528 }
9529 if (! fail)
9530 return;
9531 }
9532
9533 *expr = ffebld_new_any ();
9534 ffebld_set_info (*expr, ffeinfo_new_any ());
9535 }
9536
9537 /* Check whether rest of string is all decimal digits. */
9538
9539 static bool
9540 ffeexpr_isdigits_ (const char *p)
9541 {
9542 for (; *p != '\0'; ++p)
9543 if (! ISDIGIT (*p))
9544 return FALSE;
9545 return TRUE;
9546 }
9547
9548 /* ffeexpr_exprstack_push_ -- Push an arbitrary expression object onto the stack
9549
9550 ffeexprExpr_ e;
9551 ffeexpr_exprstack_push_(e);
9552
9553 Pushes the expression onto the stack without any analysis of the existing
9554 contents of the stack. */
9555
9556 static void
9557 ffeexpr_exprstack_push_ (ffeexprExpr_ e)
9558 {
9559 e->previous = ffeexpr_stack_->exprstack;
9560 ffeexpr_stack_->exprstack = e;
9561 }
9562
9563 /* ffeexpr_exprstack_push_operand_ -- Push an operand onto the stack, reduce?
9564
9565 ffeexprExpr_ e;
9566 ffeexpr_exprstack_push_operand_(e);
9567
9568 Pushes the expression already containing an operand (a constant, variable,
9569 or more complicated expression that has already been fully resolved) after
9570 analyzing the stack and checking for possible reduction (which will never
9571 happen here since the highest precedence operator is ** and it has right-
9572 to-left associativity). */
9573
9574 static void
9575 ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e)
9576 {
9577 ffeexpr_exprstack_push_ (e);
9578 #ifdef WEIRD_NONFORTRAN_RULES
9579 if ((ffeexpr_stack_->exprstack != NULL)
9580 && (ffeexpr_stack_->exprstack->expr->type == FFEEXPR_exprtypeBINARY_)
9581 && (ffeexpr_stack_->exprstack->expr->u.operator.prec
9582 == FFEEXPR_operatorprecedenceHIGHEST_)
9583 && (ffeexpr_stack_->exprstack->expr->u.operator.as
9584 == FFEEXPR_operatorassociativityL2R_))
9585 ffeexpr_reduce_ ();
9586 #endif
9587 }
9588
9589 /* ffeexpr_exprstack_push_unary_ -- Push a unary operator onto the stack
9590
9591 ffeexprExpr_ e;
9592 ffeexpr_exprstack_push_unary_(e);
9593
9594 Pushes the expression already containing a unary operator. Reduction can
9595 never happen since unary operators are themselves always R-L; that is, the
9596 top of the expression stack is not an operand, in that it is either empty,
9597 has a binary operator at the top, or a unary operator at the top. In any
9598 of these cases, reduction is impossible. */
9599
9600 static void
9601 ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e)
9602 {
9603 if ((ffe_is_pedantic ()
9604 || ffe_is_warn_surprising ())
9605 && (ffeexpr_stack_->exprstack != NULL)
9606 && (ffeexpr_stack_->exprstack->type != FFEEXPR_exprtypeOPERAND_)
9607 && (ffeexpr_stack_->exprstack->u.operator.prec
9608 <= FFEEXPR_operatorprecedenceLOWARITH_)
9609 && (e->u.operator.prec <= FFEEXPR_operatorprecedenceLOWARITH_))
9610 {
9611 ffebad_start_msg ("Two arithmetic operators in a row at %0 and %1 -- use parentheses",
9612 ffe_is_pedantic ()
9613 ? FFEBAD_severityPEDANTIC
9614 : FFEBAD_severityWARNING);
9615 ffebad_here (0,
9616 ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
9617 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
9618 ffebad_here (1,
9619 ffelex_token_where_line (e->token),
9620 ffelex_token_where_column (e->token));
9621 ffebad_finish ();
9622 }
9623
9624 ffeexpr_exprstack_push_ (e);
9625 }
9626
9627 /* ffeexpr_exprstack_push_binary_ -- Push a binary operator onto the stack, reduce?
9628
9629 ffeexprExpr_ e;
9630 ffeexpr_exprstack_push_binary_(e);
9631
9632 Pushes the expression already containing a binary operator after checking
9633 whether reduction is possible. If the stack is not empty, the top of the
9634 stack must be an operand or syntactic analysis has failed somehow. If
9635 the operand is preceded by a unary operator of higher (or equal and L-R
9636 associativity) precedence than the new binary operator, then reduce that
9637 preceding operator and its operand(s) before pushing the new binary
9638 operator. */
9639
9640 static void
9641 ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e)
9642 {
9643 ffeexprExpr_ ce;
9644
9645 if (ffe_is_warn_surprising ()
9646 /* These next two are always true (see assertions below). */
9647 && (ffeexpr_stack_->exprstack != NULL)
9648 && (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_)
9649 /* If the previous operator is a unary minus, and the binary op
9650 is of higher precedence, might not do what user expects,
9651 e.g. "-2**2" is "-(2**2)", i.e. "-4", not "(-2)**2", which would
9652 yield "4". */
9653 && (ffeexpr_stack_->exprstack->previous != NULL)
9654 && (ffeexpr_stack_->exprstack->previous->type == FFEEXPR_exprtypeUNARY_)
9655 && (ffeexpr_stack_->exprstack->previous->u.operator.op
9656 == FFEEXPR_operatorSUBTRACT_)
9657 && (e->u.operator.prec
9658 < ffeexpr_stack_->exprstack->previous->u.operator.prec))
9659 {
9660 ffebad_start_msg ("Operator at %0 has lower precedence than that at %1 -- use parentheses", FFEBAD_severityWARNING);
9661 ffebad_here (0,
9662 ffelex_token_where_line (ffeexpr_stack_->exprstack->previous->token),
9663 ffelex_token_where_column (ffeexpr_stack_->exprstack->previous->token));
9664 ffebad_here (1,
9665 ffelex_token_where_line (e->token),
9666 ffelex_token_where_column (e->token));
9667 ffebad_finish ();
9668 }
9669
9670 again:
9671 assert (ffeexpr_stack_->exprstack != NULL);
9672 assert (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_);
9673 if ((ce = ffeexpr_stack_->exprstack->previous) != NULL)
9674 {
9675 assert (ce->type != FFEEXPR_exprtypeOPERAND_);
9676 if ((ce->u.operator.prec < e->u.operator.prec)
9677 || ((ce->u.operator.prec == e->u.operator.prec)
9678 && (e->u.operator.as == FFEEXPR_operatorassociativityL2R_)))
9679 {
9680 ffeexpr_reduce_ ();
9681 goto again; /* :::::::::::::::::::: */
9682 }
9683 }
9684
9685 ffeexpr_exprstack_push_ (e);
9686 }
9687
9688 /* ffeexpr_reduce_ -- Reduce highest operator w/operands on stack
9689
9690 ffeexpr_reduce_();
9691
9692 Converts operand binop operand or unop operand at top of stack to a
9693 single operand having the appropriate ffebld expression, and makes
9694 sure that the expression is proper (like not trying to add two character
9695 variables, not trying to concatenate two numbers). Also does the
9696 requisite type-assignment. */
9697
9698 static void
9699 ffeexpr_reduce_ ()
9700 {
9701 ffeexprExpr_ operand; /* This is B in -B or A+B. */
9702 ffeexprExpr_ left_operand; /* When operator is binary, this is A in A+B. */
9703 ffeexprExpr_ operator; /* This is + in A+B. */
9704 ffebld reduced; /* This is +(A,B) in A+B or u-(B) in -B. */
9705 ffebldConstant constnode; /* For checking magical numbers (where mag ==
9706 -mag). */
9707 ffebld expr;
9708 ffebld left_expr;
9709 bool submag = FALSE;
9710
9711 operand = ffeexpr_stack_->exprstack;
9712 assert (operand != NULL);
9713 assert (operand->type == FFEEXPR_exprtypeOPERAND_);
9714 operator = operand->previous;
9715 assert (operator != NULL);
9716 assert (operator->type != FFEEXPR_exprtypeOPERAND_);
9717 if (operator->type == FFEEXPR_exprtypeUNARY_)
9718 {
9719 expr = operand->u.operand;
9720 switch (operator->u.operator.op)
9721 {
9722 case FFEEXPR_operatorADD_:
9723 reduced = ffebld_new_uplus (expr);
9724 if (ffe_is_ugly_logint ())
9725 reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
9726 reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
9727 reduced = ffeexpr_collapse_uplus (reduced, operator->token);
9728 break;
9729
9730 case FFEEXPR_operatorSUBTRACT_:
9731 submag = TRUE; /* Ok to negate a magic number. */
9732 reduced = ffebld_new_uminus (expr);
9733 if (ffe_is_ugly_logint ())
9734 reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
9735 reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
9736 reduced = ffeexpr_collapse_uminus (reduced, operator->token);
9737 break;
9738
9739 case FFEEXPR_operatorNOT_:
9740 reduced = ffebld_new_not (expr);
9741 if (ffe_is_ugly_logint ())
9742 reduced = ffeexpr_reduced_ugly1log_ (reduced, operator, operand);
9743 reduced = ffeexpr_reduced_bool1_ (reduced, operator, operand);
9744 reduced = ffeexpr_collapse_not (reduced, operator->token);
9745 break;
9746
9747 default:
9748 assert ("unexpected unary op" != NULL);
9749 reduced = NULL;
9750 break;
9751 }
9752 if (!submag
9753 && (ffebld_op (expr) == FFEBLD_opCONTER)
9754 && (ffebld_conter_orig (expr) == NULL)
9755 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
9756 {
9757 ffetarget_integer_bad_magical (operand->token);
9758 }
9759 ffeexpr_stack_->exprstack = operator->previous; /* Pops unary-op operand
9760 off stack. */
9761 ffeexpr_expr_kill_ (operand);
9762 operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but
9763 save */
9764 operator->u.operand = reduced; /* the line/column ffewhere info. */
9765 ffeexpr_exprstack_push_operand_ (operator); /* Push it back on
9766 stack. */
9767 }
9768 else
9769 {
9770 assert (operator->type == FFEEXPR_exprtypeBINARY_);
9771 left_operand = operator->previous;
9772 assert (left_operand != NULL);
9773 assert (left_operand->type == FFEEXPR_exprtypeOPERAND_);
9774 expr = operand->u.operand;
9775 left_expr = left_operand->u.operand;
9776 switch (operator->u.operator.op)
9777 {
9778 case FFEEXPR_operatorADD_:
9779 reduced = ffebld_new_add (left_expr, expr);
9780 if (ffe_is_ugly_logint ())
9781 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9782 operand);
9783 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9784 operand);
9785 reduced = ffeexpr_collapse_add (reduced, operator->token);
9786 break;
9787
9788 case FFEEXPR_operatorSUBTRACT_:
9789 submag = TRUE; /* Just to pick the right error if magic
9790 number. */
9791 reduced = ffebld_new_subtract (left_expr, expr);
9792 if (ffe_is_ugly_logint ())
9793 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9794 operand);
9795 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9796 operand);
9797 reduced = ffeexpr_collapse_subtract (reduced, operator->token);
9798 break;
9799
9800 case FFEEXPR_operatorMULTIPLY_:
9801 reduced = ffebld_new_multiply (left_expr, expr);
9802 if (ffe_is_ugly_logint ())
9803 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9804 operand);
9805 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9806 operand);
9807 reduced = ffeexpr_collapse_multiply (reduced, operator->token);
9808 break;
9809
9810 case FFEEXPR_operatorDIVIDE_:
9811 reduced = ffebld_new_divide (left_expr, expr);
9812 if (ffe_is_ugly_logint ())
9813 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9814 operand);
9815 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9816 operand);
9817 reduced = ffeexpr_collapse_divide (reduced, operator->token);
9818 break;
9819
9820 case FFEEXPR_operatorPOWER_:
9821 reduced = ffebld_new_power (left_expr, expr);
9822 if (ffe_is_ugly_logint ())
9823 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9824 operand);
9825 reduced = ffeexpr_reduced_power_ (reduced, left_operand, operator,
9826 operand);
9827 reduced = ffeexpr_collapse_power (reduced, operator->token);
9828 break;
9829
9830 case FFEEXPR_operatorCONCATENATE_:
9831 reduced = ffebld_new_concatenate (left_expr, expr);
9832 reduced = ffeexpr_reduced_concatenate_ (reduced, left_operand, operator,
9833 operand);
9834 reduced = ffeexpr_collapse_concatenate (reduced, operator->token);
9835 break;
9836
9837 case FFEEXPR_operatorLT_:
9838 reduced = ffebld_new_lt (left_expr, expr);
9839 if (ffe_is_ugly_logint ())
9840 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9841 operand);
9842 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9843 operand);
9844 reduced = ffeexpr_collapse_lt (reduced, operator->token);
9845 break;
9846
9847 case FFEEXPR_operatorLE_:
9848 reduced = ffebld_new_le (left_expr, expr);
9849 if (ffe_is_ugly_logint ())
9850 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9851 operand);
9852 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9853 operand);
9854 reduced = ffeexpr_collapse_le (reduced, operator->token);
9855 break;
9856
9857 case FFEEXPR_operatorEQ_:
9858 reduced = ffebld_new_eq (left_expr, expr);
9859 if (ffe_is_ugly_logint ())
9860 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9861 operand);
9862 reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
9863 operand);
9864 reduced = ffeexpr_collapse_eq (reduced, operator->token);
9865 break;
9866
9867 case FFEEXPR_operatorNE_:
9868 reduced = ffebld_new_ne (left_expr, expr);
9869 if (ffe_is_ugly_logint ())
9870 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9871 operand);
9872 reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
9873 operand);
9874 reduced = ffeexpr_collapse_ne (reduced, operator->token);
9875 break;
9876
9877 case FFEEXPR_operatorGT_:
9878 reduced = ffebld_new_gt (left_expr, expr);
9879 if (ffe_is_ugly_logint ())
9880 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9881 operand);
9882 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9883 operand);
9884 reduced = ffeexpr_collapse_gt (reduced, operator->token);
9885 break;
9886
9887 case FFEEXPR_operatorGE_:
9888 reduced = ffebld_new_ge (left_expr, expr);
9889 if (ffe_is_ugly_logint ())
9890 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9891 operand);
9892 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9893 operand);
9894 reduced = ffeexpr_collapse_ge (reduced, operator->token);
9895 break;
9896
9897 case FFEEXPR_operatorAND_:
9898 reduced = ffebld_new_and (left_expr, expr);
9899 if (ffe_is_ugly_logint ())
9900 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9901 operand);
9902 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9903 operand);
9904 reduced = ffeexpr_collapse_and (reduced, operator->token);
9905 break;
9906
9907 case FFEEXPR_operatorOR_:
9908 reduced = ffebld_new_or (left_expr, expr);
9909 if (ffe_is_ugly_logint ())
9910 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9911 operand);
9912 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9913 operand);
9914 reduced = ffeexpr_collapse_or (reduced, operator->token);
9915 break;
9916
9917 case FFEEXPR_operatorXOR_:
9918 reduced = ffebld_new_xor (left_expr, expr);
9919 if (ffe_is_ugly_logint ())
9920 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9921 operand);
9922 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9923 operand);
9924 reduced = ffeexpr_collapse_xor (reduced, operator->token);
9925 break;
9926
9927 case FFEEXPR_operatorEQV_:
9928 reduced = ffebld_new_eqv (left_expr, expr);
9929 if (ffe_is_ugly_logint ())
9930 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9931 operand);
9932 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9933 operand);
9934 reduced = ffeexpr_collapse_eqv (reduced, operator->token);
9935 break;
9936
9937 case FFEEXPR_operatorNEQV_:
9938 reduced = ffebld_new_neqv (left_expr, expr);
9939 if (ffe_is_ugly_logint ())
9940 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9941 operand);
9942 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9943 operand);
9944 reduced = ffeexpr_collapse_neqv (reduced, operator->token);
9945 break;
9946
9947 default:
9948 assert ("bad bin op" == NULL);
9949 reduced = expr;
9950 break;
9951 }
9952 if ((ffebld_op (left_expr) == FFEBLD_opCONTER)
9953 && (ffebld_conter_orig (expr) == NULL)
9954 && ffebld_constant_is_magical (constnode = ffebld_conter (left_expr)))
9955 {
9956 if ((left_operand->previous != NULL)
9957 && (left_operand->previous->type != FFEEXPR_exprtypeOPERAND_)
9958 && (left_operand->previous->u.operator.op
9959 == FFEEXPR_operatorSUBTRACT_))
9960 {
9961 if (left_operand->previous->type == FFEEXPR_exprtypeUNARY_)
9962 ffetarget_integer_bad_magical_precedence (left_operand->token,
9963 left_operand->previous->token,
9964 operator->token);
9965 else
9966 ffetarget_integer_bad_magical_precedence_binary
9967 (left_operand->token,
9968 left_operand->previous->token,
9969 operator->token);
9970 }
9971 else
9972 ffetarget_integer_bad_magical (left_operand->token);
9973 }
9974 if ((ffebld_op (expr) == FFEBLD_opCONTER)
9975 && (ffebld_conter_orig (expr) == NULL)
9976 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
9977 {
9978 if (submag)
9979 ffetarget_integer_bad_magical_binary (operand->token,
9980 operator->token);
9981 else
9982 ffetarget_integer_bad_magical (operand->token);
9983 }
9984 ffeexpr_stack_->exprstack = left_operand->previous; /* Pops binary-op
9985 operands off stack. */
9986 ffeexpr_expr_kill_ (left_operand);
9987 ffeexpr_expr_kill_ (operand);
9988 operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but
9989 save */
9990 operator->u.operand = reduced; /* the line/column ffewhere info. */
9991 ffeexpr_exprstack_push_operand_ (operator); /* Push it back on
9992 stack. */
9993 }
9994 }
9995
9996 /* ffeexpr_reduced_bool1_ -- Wrap up reduction of NOT operator
9997
9998 reduced = ffeexpr_reduced_bool1_(reduced,op,r);
9999
10000 Makes sure the argument for reduced has basictype of
10001 LOGICAL or (ugly) INTEGER. If
10002 argument has where of CONSTANT, assign where CONSTANT to
10003 reduced, else assign where FLEETING.
10004
10005 If these requirements cannot be met, generate error message. */
10006
10007 static ffebld
10008 ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10009 {
10010 ffeinfo rinfo, ninfo;
10011 ffeinfoBasictype rbt;
10012 ffeinfoKindtype rkt;
10013 ffeinfoRank rrk;
10014 ffeinfoKind rkd;
10015 ffeinfoWhere rwh, nwh;
10016
10017 rinfo = ffebld_info (ffebld_left (reduced));
10018 rbt = ffeinfo_basictype (rinfo);
10019 rkt = ffeinfo_kindtype (rinfo);
10020 rrk = ffeinfo_rank (rinfo);
10021 rkd = ffeinfo_kind (rinfo);
10022 rwh = ffeinfo_where (rinfo);
10023
10024 if (((rbt == FFEINFO_basictypeLOGICAL)
10025 || (ffe_is_ugly_logint () && (rbt == FFEINFO_basictypeINTEGER)))
10026 && (rrk == 0))
10027 {
10028 switch (rwh)
10029 {
10030 case FFEINFO_whereCONSTANT:
10031 nwh = FFEINFO_whereCONSTANT;
10032 break;
10033
10034 case FFEINFO_whereIMMEDIATE:
10035 nwh = FFEINFO_whereIMMEDIATE;
10036 break;
10037
10038 default:
10039 nwh = FFEINFO_whereFLEETING;
10040 break;
10041 }
10042
10043 ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
10044 FFETARGET_charactersizeNONE);
10045 ffebld_set_info (reduced, ninfo);
10046 return reduced;
10047 }
10048
10049 if ((rbt != FFEINFO_basictypeLOGICAL)
10050 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
10051 {
10052 if ((rbt != FFEINFO_basictypeANY)
10053 && ffebad_start (FFEBAD_NOT_ARG_TYPE))
10054 {
10055 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10056 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10057 ffebad_finish ();
10058 }
10059 }
10060 else
10061 {
10062 if ((rkd != FFEINFO_kindANY)
10063 && ffebad_start (FFEBAD_NOT_ARG_KIND))
10064 {
10065 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10066 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10067 ffebad_string ("an array");
10068 ffebad_finish ();
10069 }
10070 }
10071
10072 reduced = ffebld_new_any ();
10073 ffebld_set_info (reduced, ffeinfo_new_any ());
10074 return reduced;
10075 }
10076
10077 /* ffeexpr_reduced_bool2_ -- Wrap up reduction of boolean operators
10078
10079 reduced = ffeexpr_reduced_bool2_(reduced,l,op,r);
10080
10081 Makes sure the left and right arguments for reduced have basictype of
10082 LOGICAL or (ugly) INTEGER. Determine common basictype and
10083 size for reduction (flag expression for combined hollerith/typeless
10084 situations for later determination of effective basictype). If both left
10085 and right arguments have where of CONSTANT, assign where CONSTANT to
10086 reduced, else assign where FLEETING. Create CONVERT ops for args where
10087 needed. Convert typeless
10088 constants to the desired type/size explicitly.
10089
10090 If these requirements cannot be met, generate error message. */
10091
10092 static ffebld
10093 ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10094 ffeexprExpr_ r)
10095 {
10096 ffeinfo linfo, rinfo, ninfo;
10097 ffeinfoBasictype lbt, rbt, nbt;
10098 ffeinfoKindtype lkt, rkt, nkt;
10099 ffeinfoRank lrk, rrk;
10100 ffeinfoKind lkd, rkd;
10101 ffeinfoWhere lwh, rwh, nwh;
10102
10103 linfo = ffebld_info (ffebld_left (reduced));
10104 lbt = ffeinfo_basictype (linfo);
10105 lkt = ffeinfo_kindtype (linfo);
10106 lrk = ffeinfo_rank (linfo);
10107 lkd = ffeinfo_kind (linfo);
10108 lwh = ffeinfo_where (linfo);
10109
10110 rinfo = ffebld_info (ffebld_right (reduced));
10111 rbt = ffeinfo_basictype (rinfo);
10112 rkt = ffeinfo_kindtype (rinfo);
10113 rrk = ffeinfo_rank (rinfo);
10114 rkd = ffeinfo_kind (rinfo);
10115 rwh = ffeinfo_where (rinfo);
10116
10117 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10118
10119 if (((nbt == FFEINFO_basictypeLOGICAL)
10120 || (ffe_is_ugly_logint () && (nbt == FFEINFO_basictypeINTEGER)))
10121 && (lrk == 0) && (rrk == 0))
10122 {
10123 switch (lwh)
10124 {
10125 case FFEINFO_whereCONSTANT:
10126 switch (rwh)
10127 {
10128 case FFEINFO_whereCONSTANT:
10129 nwh = FFEINFO_whereCONSTANT;
10130 break;
10131
10132 case FFEINFO_whereIMMEDIATE:
10133 nwh = FFEINFO_whereIMMEDIATE;
10134 break;
10135
10136 default:
10137 nwh = FFEINFO_whereFLEETING;
10138 break;
10139 }
10140 break;
10141
10142 case FFEINFO_whereIMMEDIATE:
10143 switch (rwh)
10144 {
10145 case FFEINFO_whereCONSTANT:
10146 case FFEINFO_whereIMMEDIATE:
10147 nwh = FFEINFO_whereIMMEDIATE;
10148 break;
10149
10150 default:
10151 nwh = FFEINFO_whereFLEETING;
10152 break;
10153 }
10154 break;
10155
10156 default:
10157 nwh = FFEINFO_whereFLEETING;
10158 break;
10159 }
10160
10161 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10162 FFETARGET_charactersizeNONE);
10163 ffebld_set_info (reduced, ninfo);
10164 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10165 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10166 FFEEXPR_contextLET));
10167 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10168 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10169 FFEEXPR_contextLET));
10170 return reduced;
10171 }
10172
10173 if ((lbt != FFEINFO_basictypeLOGICAL)
10174 && (!ffe_is_ugly_logint () || (lbt != FFEINFO_basictypeINTEGER)))
10175 {
10176 if ((rbt != FFEINFO_basictypeLOGICAL)
10177 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
10178 {
10179 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10180 && ffebad_start (FFEBAD_BOOL_ARGS_TYPE))
10181 {
10182 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10183 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10184 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10185 ffebad_finish ();
10186 }
10187 }
10188 else
10189 {
10190 if ((lbt != FFEINFO_basictypeANY)
10191 && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
10192 {
10193 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10194 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10195 ffebad_finish ();
10196 }
10197 }
10198 }
10199 else if ((rbt != FFEINFO_basictypeLOGICAL)
10200 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
10201 {
10202 if ((rbt != FFEINFO_basictypeANY)
10203 && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
10204 {
10205 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10206 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10207 ffebad_finish ();
10208 }
10209 }
10210 else if (lrk != 0)
10211 {
10212 if ((lkd != FFEINFO_kindANY)
10213 && ffebad_start (FFEBAD_BOOL_ARG_KIND))
10214 {
10215 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10216 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10217 ffebad_string ("an array");
10218 ffebad_finish ();
10219 }
10220 }
10221 else
10222 {
10223 if ((rkd != FFEINFO_kindANY)
10224 && ffebad_start (FFEBAD_BOOL_ARG_KIND))
10225 {
10226 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10227 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10228 ffebad_string ("an array");
10229 ffebad_finish ();
10230 }
10231 }
10232
10233 reduced = ffebld_new_any ();
10234 ffebld_set_info (reduced, ffeinfo_new_any ());
10235 return reduced;
10236 }
10237
10238 /* ffeexpr_reduced_concatenate_ -- Wrap up reduction of concatenate operator
10239
10240 reduced = ffeexpr_reduced_concatenate_(reduced,l,op,r);
10241
10242 Makes sure the left and right arguments for reduced have basictype of
10243 CHARACTER and kind of SCALAR, FUNCTION, or STATEMENT FUNCTION. Assign
10244 basictype of CHARACTER and kind of SCALAR to reduced. Calculate effective
10245 size of concatenation and assign that size to reduced. If both left and
10246 right arguments have where of CONSTANT, assign where CONSTANT to reduced,
10247 else assign where FLEETING.
10248
10249 If these requirements cannot be met, generate error message using the
10250 info in l, op, and r arguments and assign basictype, size, kind, and where
10251 of ANY. */
10252
10253 static ffebld
10254 ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10255 ffeexprExpr_ r)
10256 {
10257 ffeinfo linfo, rinfo, ninfo;
10258 ffeinfoBasictype lbt, rbt, nbt;
10259 ffeinfoKindtype lkt, rkt, nkt;
10260 ffeinfoRank lrk, rrk;
10261 ffeinfoKind lkd, rkd, nkd;
10262 ffeinfoWhere lwh, rwh, nwh;
10263 ffetargetCharacterSize lszm, lszk, rszm, rszk, nszk;
10264
10265 linfo = ffebld_info (ffebld_left (reduced));
10266 lbt = ffeinfo_basictype (linfo);
10267 lkt = ffeinfo_kindtype (linfo);
10268 lrk = ffeinfo_rank (linfo);
10269 lkd = ffeinfo_kind (linfo);
10270 lwh = ffeinfo_where (linfo);
10271 lszk = ffeinfo_size (linfo); /* Known size. */
10272 lszm = ffebld_size_max (ffebld_left (reduced));
10273
10274 rinfo = ffebld_info (ffebld_right (reduced));
10275 rbt = ffeinfo_basictype (rinfo);
10276 rkt = ffeinfo_kindtype (rinfo);
10277 rrk = ffeinfo_rank (rinfo);
10278 rkd = ffeinfo_kind (rinfo);
10279 rwh = ffeinfo_where (rinfo);
10280 rszk = ffeinfo_size (rinfo); /* Known size. */
10281 rszm = ffebld_size_max (ffebld_right (reduced));
10282
10283 if ((lbt == FFEINFO_basictypeCHARACTER) && (rbt == FFEINFO_basictypeCHARACTER)
10284 && (lkt == rkt) && (lrk == 0) && (rrk == 0)
10285 && (((lszm != FFETARGET_charactersizeNONE)
10286 && (rszm != FFETARGET_charactersizeNONE))
10287 || (ffeexpr_context_outer_ (ffeexpr_stack_)
10288 == FFEEXPR_contextLET)
10289 || (ffeexpr_context_outer_ (ffeexpr_stack_)
10290 == FFEEXPR_contextSFUNCDEF)))
10291 {
10292 nbt = FFEINFO_basictypeCHARACTER;
10293 nkd = FFEINFO_kindENTITY;
10294 if ((lszk == FFETARGET_charactersizeNONE)
10295 || (rszk == FFETARGET_charactersizeNONE))
10296 nszk = FFETARGET_charactersizeNONE; /* Ok only in rhs of LET
10297 stmt. */
10298 else
10299 nszk = lszk + rszk;
10300
10301 switch (lwh)
10302 {
10303 case FFEINFO_whereCONSTANT:
10304 switch (rwh)
10305 {
10306 case FFEINFO_whereCONSTANT:
10307 nwh = FFEINFO_whereCONSTANT;
10308 break;
10309
10310 case FFEINFO_whereIMMEDIATE:
10311 nwh = FFEINFO_whereIMMEDIATE;
10312 break;
10313
10314 default:
10315 nwh = FFEINFO_whereFLEETING;
10316 break;
10317 }
10318 break;
10319
10320 case FFEINFO_whereIMMEDIATE:
10321 switch (rwh)
10322 {
10323 case FFEINFO_whereCONSTANT:
10324 case FFEINFO_whereIMMEDIATE:
10325 nwh = FFEINFO_whereIMMEDIATE;
10326 break;
10327
10328 default:
10329 nwh = FFEINFO_whereFLEETING;
10330 break;
10331 }
10332 break;
10333
10334 default:
10335 nwh = FFEINFO_whereFLEETING;
10336 break;
10337 }
10338
10339 nkt = lkt;
10340 ninfo = ffeinfo_new (nbt, nkt, 0, nkd, nwh, nszk);
10341 ffebld_set_info (reduced, ninfo);
10342 return reduced;
10343 }
10344
10345 if ((lbt != FFEINFO_basictypeCHARACTER) && (rbt != FFEINFO_basictypeCHARACTER))
10346 {
10347 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10348 && ffebad_start (FFEBAD_CONCAT_ARGS_TYPE))
10349 {
10350 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10351 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10352 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10353 ffebad_finish ();
10354 }
10355 }
10356 else if (lbt != FFEINFO_basictypeCHARACTER)
10357 {
10358 if ((lbt != FFEINFO_basictypeANY)
10359 && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
10360 {
10361 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10362 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10363 ffebad_finish ();
10364 }
10365 }
10366 else if (rbt != FFEINFO_basictypeCHARACTER)
10367 {
10368 if ((rbt != FFEINFO_basictypeANY)
10369 && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
10370 {
10371 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10372 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10373 ffebad_finish ();
10374 }
10375 }
10376 else if ((lrk != 0) || (lszm == FFETARGET_charactersizeNONE))
10377 {
10378 if ((lkd != FFEINFO_kindANY)
10379 && ffebad_start (FFEBAD_CONCAT_ARG_KIND))
10380 {
10381 const char *what;
10382
10383 if (lrk != 0)
10384 what = "an array";
10385 else
10386 what = "of indeterminate length";
10387 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10388 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10389 ffebad_string (what);
10390 ffebad_finish ();
10391 }
10392 }
10393 else
10394 {
10395 if (ffebad_start (FFEBAD_CONCAT_ARG_KIND))
10396 {
10397 const char *what;
10398
10399 if (rrk != 0)
10400 what = "an array";
10401 else
10402 what = "of indeterminate length";
10403 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10404 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10405 ffebad_string (what);
10406 ffebad_finish ();
10407 }
10408 }
10409
10410 reduced = ffebld_new_any ();
10411 ffebld_set_info (reduced, ffeinfo_new_any ());
10412 return reduced;
10413 }
10414
10415 /* ffeexpr_reduced_eqop2_ -- Wrap up reduction of EQ and NE operators
10416
10417 reduced = ffeexpr_reduced_eqop2_(reduced,l,op,r);
10418
10419 Makes sure the left and right arguments for reduced have basictype of
10420 INTEGER, REAL, COMPLEX, or CHARACTER. Determine common basictype and
10421 size for reduction. If both left
10422 and right arguments have where of CONSTANT, assign where CONSTANT to
10423 reduced, else assign where FLEETING. Create CONVERT ops for args where
10424 needed. Convert typeless
10425 constants to the desired type/size explicitly.
10426
10427 If these requirements cannot be met, generate error message. */
10428
10429 static ffebld
10430 ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10431 ffeexprExpr_ r)
10432 {
10433 ffeinfo linfo, rinfo, ninfo;
10434 ffeinfoBasictype lbt, rbt, nbt;
10435 ffeinfoKindtype lkt, rkt, nkt;
10436 ffeinfoRank lrk, rrk;
10437 ffeinfoKind lkd, rkd;
10438 ffeinfoWhere lwh, rwh, nwh;
10439 ffetargetCharacterSize lsz, rsz;
10440
10441 linfo = ffebld_info (ffebld_left (reduced));
10442 lbt = ffeinfo_basictype (linfo);
10443 lkt = ffeinfo_kindtype (linfo);
10444 lrk = ffeinfo_rank (linfo);
10445 lkd = ffeinfo_kind (linfo);
10446 lwh = ffeinfo_where (linfo);
10447 lsz = ffebld_size_known (ffebld_left (reduced));
10448
10449 rinfo = ffebld_info (ffebld_right (reduced));
10450 rbt = ffeinfo_basictype (rinfo);
10451 rkt = ffeinfo_kindtype (rinfo);
10452 rrk = ffeinfo_rank (rinfo);
10453 rkd = ffeinfo_kind (rinfo);
10454 rwh = ffeinfo_where (rinfo);
10455 rsz = ffebld_size_known (ffebld_right (reduced));
10456
10457 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10458
10459 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10460 || (nbt == FFEINFO_basictypeCOMPLEX) || (nbt == FFEINFO_basictypeCHARACTER))
10461 && (lrk == 0) && (rrk == 0))
10462 {
10463 switch (lwh)
10464 {
10465 case FFEINFO_whereCONSTANT:
10466 switch (rwh)
10467 {
10468 case FFEINFO_whereCONSTANT:
10469 nwh = FFEINFO_whereCONSTANT;
10470 break;
10471
10472 case FFEINFO_whereIMMEDIATE:
10473 nwh = FFEINFO_whereIMMEDIATE;
10474 break;
10475
10476 default:
10477 nwh = FFEINFO_whereFLEETING;
10478 break;
10479 }
10480 break;
10481
10482 case FFEINFO_whereIMMEDIATE:
10483 switch (rwh)
10484 {
10485 case FFEINFO_whereCONSTANT:
10486 case FFEINFO_whereIMMEDIATE:
10487 nwh = FFEINFO_whereIMMEDIATE;
10488 break;
10489
10490 default:
10491 nwh = FFEINFO_whereFLEETING;
10492 break;
10493 }
10494 break;
10495
10496 default:
10497 nwh = FFEINFO_whereFLEETING;
10498 break;
10499 }
10500
10501 if ((lsz != FFETARGET_charactersizeNONE)
10502 && (rsz != FFETARGET_charactersizeNONE))
10503 lsz = rsz = (lsz > rsz) ? lsz : rsz;
10504
10505 ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
10506 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
10507 ffebld_set_info (reduced, ninfo);
10508 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10509 l->token, op->token, nbt, nkt, 0, lsz,
10510 FFEEXPR_contextLET));
10511 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10512 r->token, op->token, nbt, nkt, 0, rsz,
10513 FFEEXPR_contextLET));
10514 return reduced;
10515 }
10516
10517 if ((lbt == FFEINFO_basictypeLOGICAL)
10518 && (rbt == FFEINFO_basictypeLOGICAL))
10519 {
10520 if (ffebad_start_msg ("Use .EQV./.NEQV. instead of .EQ./.NE. at %0 for LOGICAL operands at %1 and %2",
10521 FFEBAD_severityFATAL))
10522 {
10523 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10524 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10525 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10526 ffebad_finish ();
10527 }
10528 }
10529 else if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10530 && (lbt != FFEINFO_basictypeCOMPLEX) && (lbt != FFEINFO_basictypeCHARACTER))
10531 {
10532 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10533 && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
10534 {
10535 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10536 && ffebad_start (FFEBAD_EQOP_ARGS_TYPE))
10537 {
10538 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10539 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10540 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10541 ffebad_finish ();
10542 }
10543 }
10544 else
10545 {
10546 if ((lbt != FFEINFO_basictypeANY)
10547 && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
10548 {
10549 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10550 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10551 ffebad_finish ();
10552 }
10553 }
10554 }
10555 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10556 && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
10557 {
10558 if ((rbt != FFEINFO_basictypeANY)
10559 && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
10560 {
10561 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10562 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10563 ffebad_finish ();
10564 }
10565 }
10566 else if (lrk != 0)
10567 {
10568 if ((lkd != FFEINFO_kindANY)
10569 && ffebad_start (FFEBAD_EQOP_ARG_KIND))
10570 {
10571 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10572 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10573 ffebad_string ("an array");
10574 ffebad_finish ();
10575 }
10576 }
10577 else
10578 {
10579 if ((rkd != FFEINFO_kindANY)
10580 && ffebad_start (FFEBAD_EQOP_ARG_KIND))
10581 {
10582 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10583 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10584 ffebad_string ("an array");
10585 ffebad_finish ();
10586 }
10587 }
10588
10589 reduced = ffebld_new_any ();
10590 ffebld_set_info (reduced, ffeinfo_new_any ());
10591 return reduced;
10592 }
10593
10594 /* ffeexpr_reduced_math1_ -- Wrap up reduction of + - unary operators
10595
10596 reduced = ffeexpr_reduced_math1_(reduced,op,r);
10597
10598 Makes sure the argument for reduced has basictype of
10599 INTEGER, REAL, or COMPLEX. If the argument has where of CONSTANT,
10600 assign where CONSTANT to
10601 reduced, else assign where FLEETING.
10602
10603 If these requirements cannot be met, generate error message. */
10604
10605 static ffebld
10606 ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10607 {
10608 ffeinfo rinfo, ninfo;
10609 ffeinfoBasictype rbt;
10610 ffeinfoKindtype rkt;
10611 ffeinfoRank rrk;
10612 ffeinfoKind rkd;
10613 ffeinfoWhere rwh, nwh;
10614
10615 rinfo = ffebld_info (ffebld_left (reduced));
10616 rbt = ffeinfo_basictype (rinfo);
10617 rkt = ffeinfo_kindtype (rinfo);
10618 rrk = ffeinfo_rank (rinfo);
10619 rkd = ffeinfo_kind (rinfo);
10620 rwh = ffeinfo_where (rinfo);
10621
10622 if (((rbt == FFEINFO_basictypeINTEGER) || (rbt == FFEINFO_basictypeREAL)
10623 || (rbt == FFEINFO_basictypeCOMPLEX)) && (rrk == 0))
10624 {
10625 switch (rwh)
10626 {
10627 case FFEINFO_whereCONSTANT:
10628 nwh = FFEINFO_whereCONSTANT;
10629 break;
10630
10631 case FFEINFO_whereIMMEDIATE:
10632 nwh = FFEINFO_whereIMMEDIATE;
10633 break;
10634
10635 default:
10636 nwh = FFEINFO_whereFLEETING;
10637 break;
10638 }
10639
10640 ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
10641 FFETARGET_charactersizeNONE);
10642 ffebld_set_info (reduced, ninfo);
10643 return reduced;
10644 }
10645
10646 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10647 && (rbt != FFEINFO_basictypeCOMPLEX))
10648 {
10649 if ((rbt != FFEINFO_basictypeANY)
10650 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10651 {
10652 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10653 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10654 ffebad_finish ();
10655 }
10656 }
10657 else
10658 {
10659 if ((rkd != FFEINFO_kindANY)
10660 && ffebad_start (FFEBAD_MATH_ARG_KIND))
10661 {
10662 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10663 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10664 ffebad_string ("an array");
10665 ffebad_finish ();
10666 }
10667 }
10668
10669 reduced = ffebld_new_any ();
10670 ffebld_set_info (reduced, ffeinfo_new_any ());
10671 return reduced;
10672 }
10673
10674 /* ffeexpr_reduced_math2_ -- Wrap up reduction of + - * / operators
10675
10676 reduced = ffeexpr_reduced_math2_(reduced,l,op,r);
10677
10678 Makes sure the left and right arguments for reduced have basictype of
10679 INTEGER, REAL, or COMPLEX. Determine common basictype and
10680 size for reduction (flag expression for combined hollerith/typeless
10681 situations for later determination of effective basictype). If both left
10682 and right arguments have where of CONSTANT, assign where CONSTANT to
10683 reduced, else assign where FLEETING. Create CONVERT ops for args where
10684 needed. Convert typeless
10685 constants to the desired type/size explicitly.
10686
10687 If these requirements cannot be met, generate error message. */
10688
10689 static ffebld
10690 ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10691 ffeexprExpr_ r)
10692 {
10693 ffeinfo linfo, rinfo, ninfo;
10694 ffeinfoBasictype lbt, rbt, nbt;
10695 ffeinfoKindtype lkt, rkt, nkt;
10696 ffeinfoRank lrk, rrk;
10697 ffeinfoKind lkd, rkd;
10698 ffeinfoWhere lwh, rwh, nwh;
10699
10700 linfo = ffebld_info (ffebld_left (reduced));
10701 lbt = ffeinfo_basictype (linfo);
10702 lkt = ffeinfo_kindtype (linfo);
10703 lrk = ffeinfo_rank (linfo);
10704 lkd = ffeinfo_kind (linfo);
10705 lwh = ffeinfo_where (linfo);
10706
10707 rinfo = ffebld_info (ffebld_right (reduced));
10708 rbt = ffeinfo_basictype (rinfo);
10709 rkt = ffeinfo_kindtype (rinfo);
10710 rrk = ffeinfo_rank (rinfo);
10711 rkd = ffeinfo_kind (rinfo);
10712 rwh = ffeinfo_where (rinfo);
10713
10714 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10715
10716 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10717 || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
10718 {
10719 switch (lwh)
10720 {
10721 case FFEINFO_whereCONSTANT:
10722 switch (rwh)
10723 {
10724 case FFEINFO_whereCONSTANT:
10725 nwh = FFEINFO_whereCONSTANT;
10726 break;
10727
10728 case FFEINFO_whereIMMEDIATE:
10729 nwh = FFEINFO_whereIMMEDIATE;
10730 break;
10731
10732 default:
10733 nwh = FFEINFO_whereFLEETING;
10734 break;
10735 }
10736 break;
10737
10738 case FFEINFO_whereIMMEDIATE:
10739 switch (rwh)
10740 {
10741 case FFEINFO_whereCONSTANT:
10742 case FFEINFO_whereIMMEDIATE:
10743 nwh = FFEINFO_whereIMMEDIATE;
10744 break;
10745
10746 default:
10747 nwh = FFEINFO_whereFLEETING;
10748 break;
10749 }
10750 break;
10751
10752 default:
10753 nwh = FFEINFO_whereFLEETING;
10754 break;
10755 }
10756
10757 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10758 FFETARGET_charactersizeNONE);
10759 ffebld_set_info (reduced, ninfo);
10760 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10761 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10762 FFEEXPR_contextLET));
10763 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10764 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10765 FFEEXPR_contextLET));
10766 return reduced;
10767 }
10768
10769 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10770 && (lbt != FFEINFO_basictypeCOMPLEX))
10771 {
10772 if ((rbt != FFEINFO_basictypeINTEGER)
10773 && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
10774 {
10775 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10776 && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
10777 {
10778 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10779 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10780 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10781 ffebad_finish ();
10782 }
10783 }
10784 else
10785 {
10786 if ((lbt != FFEINFO_basictypeANY)
10787 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10788 {
10789 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10790 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10791 ffebad_finish ();
10792 }
10793 }
10794 }
10795 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10796 && (rbt != FFEINFO_basictypeCOMPLEX))
10797 {
10798 if ((rbt != FFEINFO_basictypeANY)
10799 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10800 {
10801 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10802 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10803 ffebad_finish ();
10804 }
10805 }
10806 else if (lrk != 0)
10807 {
10808 if ((lkd != FFEINFO_kindANY)
10809 && ffebad_start (FFEBAD_MATH_ARG_KIND))
10810 {
10811 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10812 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10813 ffebad_string ("an array");
10814 ffebad_finish ();
10815 }
10816 }
10817 else
10818 {
10819 if ((rkd != FFEINFO_kindANY)
10820 && ffebad_start (FFEBAD_MATH_ARG_KIND))
10821 {
10822 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10823 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10824 ffebad_string ("an array");
10825 ffebad_finish ();
10826 }
10827 }
10828
10829 reduced = ffebld_new_any ();
10830 ffebld_set_info (reduced, ffeinfo_new_any ());
10831 return reduced;
10832 }
10833
10834 /* ffeexpr_reduced_power_ -- Wrap up reduction of ** operator
10835
10836 reduced = ffeexpr_reduced_power_(reduced,l,op,r);
10837
10838 Makes sure the left and right arguments for reduced have basictype of
10839 INTEGER, REAL, or COMPLEX. Determine common basictype and
10840 size for reduction (flag expression for combined hollerith/typeless
10841 situations for later determination of effective basictype). If both left
10842 and right arguments have where of CONSTANT, assign where CONSTANT to
10843 reduced, else assign where FLEETING. Create CONVERT ops for args where
10844 needed. Note that real**int or complex**int
10845 comes out as int = real**int etc with no conversions.
10846
10847 If these requirements cannot be met, generate error message using the
10848 info in l, op, and r arguments and assign basictype, size, kind, and where
10849 of ANY. */
10850
10851 static ffebld
10852 ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10853 ffeexprExpr_ r)
10854 {
10855 ffeinfo linfo, rinfo, ninfo;
10856 ffeinfoBasictype lbt, rbt, nbt;
10857 ffeinfoKindtype lkt, rkt, nkt;
10858 ffeinfoRank lrk, rrk;
10859 ffeinfoKind lkd, rkd;
10860 ffeinfoWhere lwh, rwh, nwh;
10861
10862 linfo = ffebld_info (ffebld_left (reduced));
10863 lbt = ffeinfo_basictype (linfo);
10864 lkt = ffeinfo_kindtype (linfo);
10865 lrk = ffeinfo_rank (linfo);
10866 lkd = ffeinfo_kind (linfo);
10867 lwh = ffeinfo_where (linfo);
10868
10869 rinfo = ffebld_info (ffebld_right (reduced));
10870 rbt = ffeinfo_basictype (rinfo);
10871 rkt = ffeinfo_kindtype (rinfo);
10872 rrk = ffeinfo_rank (rinfo);
10873 rkd = ffeinfo_kind (rinfo);
10874 rwh = ffeinfo_where (rinfo);
10875
10876 if ((rbt == FFEINFO_basictypeINTEGER)
10877 && ((lbt == FFEINFO_basictypeREAL)
10878 || (lbt == FFEINFO_basictypeCOMPLEX)))
10879 {
10880 nbt = lbt;
10881 nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDEFAULT);
10882 if (nkt != FFEINFO_kindtypeREALDEFAULT)
10883 {
10884 nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDOUBLE);
10885 if (nkt != FFEINFO_kindtypeREALDOUBLE)
10886 nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */
10887 }
10888 if (rkt == FFEINFO_kindtypeINTEGER4)
10889 {
10890 ffebad_start_msg ("Unsupported operand for ** at %1 -- converting to default INTEGER",
10891 FFEBAD_severityWARNING);
10892 ffebad_here (0, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10893 ffebad_finish ();
10894 }
10895 if (rkt != FFEINFO_kindtypeINTEGERDEFAULT)
10896 {
10897 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10898 r->token, op->token,
10899 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0,
10900 FFETARGET_charactersizeNONE,
10901 FFEEXPR_contextLET));
10902 rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10903 }
10904 }
10905 else
10906 {
10907 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10908
10909 #if 0 /* INTEGER4**INTEGER4 works now. */
10910 if ((nbt == FFEINFO_basictypeINTEGER)
10911 && (nkt != FFEINFO_kindtypeINTEGERDEFAULT))
10912 nkt = FFEINFO_kindtypeINTEGERDEFAULT; /* Highest kt we can power! */
10913 #endif
10914 if (((nbt == FFEINFO_basictypeREAL)
10915 || (nbt == FFEINFO_basictypeCOMPLEX))
10916 && (nkt != FFEINFO_kindtypeREALDEFAULT))
10917 {
10918 nkt = ffeinfo_kindtype_max (nbt, nkt, FFEINFO_kindtypeREALDOUBLE);
10919 if (nkt != FFEINFO_kindtypeREALDOUBLE)
10920 nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */
10921 }
10922 /* else Gonna turn into an error below. */
10923 }
10924
10925 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10926 || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
10927 {
10928 switch (lwh)
10929 {
10930 case FFEINFO_whereCONSTANT:
10931 switch (rwh)
10932 {
10933 case FFEINFO_whereCONSTANT:
10934 nwh = FFEINFO_whereCONSTANT;
10935 break;
10936
10937 case FFEINFO_whereIMMEDIATE:
10938 nwh = FFEINFO_whereIMMEDIATE;
10939 break;
10940
10941 default:
10942 nwh = FFEINFO_whereFLEETING;
10943 break;
10944 }
10945 break;
10946
10947 case FFEINFO_whereIMMEDIATE:
10948 switch (rwh)
10949 {
10950 case FFEINFO_whereCONSTANT:
10951 case FFEINFO_whereIMMEDIATE:
10952 nwh = FFEINFO_whereIMMEDIATE;
10953 break;
10954
10955 default:
10956 nwh = FFEINFO_whereFLEETING;
10957 break;
10958 }
10959 break;
10960
10961 default:
10962 nwh = FFEINFO_whereFLEETING;
10963 break;
10964 }
10965
10966 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10967 FFETARGET_charactersizeNONE);
10968 ffebld_set_info (reduced, ninfo);
10969 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10970 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10971 FFEEXPR_contextLET));
10972 if (rbt != FFEINFO_basictypeINTEGER)
10973 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10974 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10975 FFEEXPR_contextLET));
10976 return reduced;
10977 }
10978
10979 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10980 && (lbt != FFEINFO_basictypeCOMPLEX))
10981 {
10982 if ((rbt != FFEINFO_basictypeINTEGER)
10983 && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
10984 {
10985 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10986 && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
10987 {
10988 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10989 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10990 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10991 ffebad_finish ();
10992 }
10993 }
10994 else
10995 {
10996 if ((lbt != FFEINFO_basictypeANY)
10997 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10998 {
10999 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11000 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11001 ffebad_finish ();
11002 }
11003 }
11004 }
11005 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
11006 && (rbt != FFEINFO_basictypeCOMPLEX))
11007 {
11008 if ((rbt != FFEINFO_basictypeANY)
11009 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
11010 {
11011 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11012 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11013 ffebad_finish ();
11014 }
11015 }
11016 else if (lrk != 0)
11017 {
11018 if ((lkd != FFEINFO_kindANY)
11019 && ffebad_start (FFEBAD_MATH_ARG_KIND))
11020 {
11021 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11022 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11023 ffebad_string ("an array");
11024 ffebad_finish ();
11025 }
11026 }
11027 else
11028 {
11029 if ((rkd != FFEINFO_kindANY)
11030 && ffebad_start (FFEBAD_MATH_ARG_KIND))
11031 {
11032 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11033 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11034 ffebad_string ("an array");
11035 ffebad_finish ();
11036 }
11037 }
11038
11039 reduced = ffebld_new_any ();
11040 ffebld_set_info (reduced, ffeinfo_new_any ());
11041 return reduced;
11042 }
11043
11044 /* ffeexpr_reduced_relop2_ -- Wrap up reduction of LT, LE, GE, and GT operators
11045
11046 reduced = ffeexpr_reduced_relop2_(reduced,l,op,r);
11047
11048 Makes sure the left and right arguments for reduced have basictype of
11049 INTEGER, REAL, or CHARACTER. Determine common basictype and
11050 size for reduction. If both left
11051 and right arguments have where of CONSTANT, assign where CONSTANT to
11052 reduced, else assign where FLEETING. Create CONVERT ops for args where
11053 needed. Convert typeless
11054 constants to the desired type/size explicitly.
11055
11056 If these requirements cannot be met, generate error message. */
11057
11058 static ffebld
11059 ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
11060 ffeexprExpr_ r)
11061 {
11062 ffeinfo linfo, rinfo, ninfo;
11063 ffeinfoBasictype lbt, rbt, nbt;
11064 ffeinfoKindtype lkt, rkt, nkt;
11065 ffeinfoRank lrk, rrk;
11066 ffeinfoKind lkd, rkd;
11067 ffeinfoWhere lwh, rwh, nwh;
11068 ffetargetCharacterSize lsz, rsz;
11069
11070 linfo = ffebld_info (ffebld_left (reduced));
11071 lbt = ffeinfo_basictype (linfo);
11072 lkt = ffeinfo_kindtype (linfo);
11073 lrk = ffeinfo_rank (linfo);
11074 lkd = ffeinfo_kind (linfo);
11075 lwh = ffeinfo_where (linfo);
11076 lsz = ffebld_size_known (ffebld_left (reduced));
11077
11078 rinfo = ffebld_info (ffebld_right (reduced));
11079 rbt = ffeinfo_basictype (rinfo);
11080 rkt = ffeinfo_kindtype (rinfo);
11081 rrk = ffeinfo_rank (rinfo);
11082 rkd = ffeinfo_kind (rinfo);
11083 rwh = ffeinfo_where (rinfo);
11084 rsz = ffebld_size_known (ffebld_right (reduced));
11085
11086 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
11087
11088 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
11089 || (nbt == FFEINFO_basictypeCHARACTER))
11090 && (lrk == 0) && (rrk == 0))
11091 {
11092 switch (lwh)
11093 {
11094 case FFEINFO_whereCONSTANT:
11095 switch (rwh)
11096 {
11097 case FFEINFO_whereCONSTANT:
11098 nwh = FFEINFO_whereCONSTANT;
11099 break;
11100
11101 case FFEINFO_whereIMMEDIATE:
11102 nwh = FFEINFO_whereIMMEDIATE;
11103 break;
11104
11105 default:
11106 nwh = FFEINFO_whereFLEETING;
11107 break;
11108 }
11109 break;
11110
11111 case FFEINFO_whereIMMEDIATE:
11112 switch (rwh)
11113 {
11114 case FFEINFO_whereCONSTANT:
11115 case FFEINFO_whereIMMEDIATE:
11116 nwh = FFEINFO_whereIMMEDIATE;
11117 break;
11118
11119 default:
11120 nwh = FFEINFO_whereFLEETING;
11121 break;
11122 }
11123 break;
11124
11125 default:
11126 nwh = FFEINFO_whereFLEETING;
11127 break;
11128 }
11129
11130 if ((lsz != FFETARGET_charactersizeNONE)
11131 && (rsz != FFETARGET_charactersizeNONE))
11132 lsz = rsz = (lsz > rsz) ? lsz : rsz;
11133
11134 ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
11135 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
11136 ffebld_set_info (reduced, ninfo);
11137 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11138 l->token, op->token, nbt, nkt, 0, lsz,
11139 FFEEXPR_contextLET));
11140 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11141 r->token, op->token, nbt, nkt, 0, rsz,
11142 FFEEXPR_contextLET));
11143 return reduced;
11144 }
11145
11146 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
11147 && (lbt != FFEINFO_basictypeCHARACTER))
11148 {
11149 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
11150 && (rbt != FFEINFO_basictypeCHARACTER))
11151 {
11152 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
11153 && ffebad_start (FFEBAD_RELOP_ARGS_TYPE))
11154 {
11155 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11156 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11157 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11158 ffebad_finish ();
11159 }
11160 }
11161 else
11162 {
11163 if ((lbt != FFEINFO_basictypeANY)
11164 && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
11165 {
11166 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11167 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11168 ffebad_finish ();
11169 }
11170 }
11171 }
11172 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
11173 && (rbt != FFEINFO_basictypeCHARACTER))
11174 {
11175 if ((rbt != FFEINFO_basictypeANY)
11176 && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
11177 {
11178 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11179 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11180 ffebad_finish ();
11181 }
11182 }
11183 else if (lrk != 0)
11184 {
11185 if ((lkd != FFEINFO_kindANY)
11186 && ffebad_start (FFEBAD_RELOP_ARG_KIND))
11187 {
11188 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11189 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11190 ffebad_string ("an array");
11191 ffebad_finish ();
11192 }
11193 }
11194 else
11195 {
11196 if ((rkd != FFEINFO_kindANY)
11197 && ffebad_start (FFEBAD_RELOP_ARG_KIND))
11198 {
11199 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11200 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11201 ffebad_string ("an array");
11202 ffebad_finish ();
11203 }
11204 }
11205
11206 reduced = ffebld_new_any ();
11207 ffebld_set_info (reduced, ffeinfo_new_any ());
11208 return reduced;
11209 }
11210
11211 /* ffeexpr_reduced_ugly1_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
11212
11213 reduced = ffeexpr_reduced_ugly1_(reduced,op,r);
11214
11215 Sigh. */
11216
11217 static ffebld
11218 ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
11219 {
11220 ffeinfo rinfo;
11221 ffeinfoBasictype rbt;
11222 ffeinfoKindtype rkt;
11223 ffeinfoRank rrk;
11224 ffeinfoKind rkd;
11225 ffeinfoWhere rwh;
11226
11227 rinfo = ffebld_info (ffebld_left (reduced));
11228 rbt = ffeinfo_basictype (rinfo);
11229 rkt = ffeinfo_kindtype (rinfo);
11230 rrk = ffeinfo_rank (rinfo);
11231 rkd = ffeinfo_kind (rinfo);
11232 rwh = ffeinfo_where (rinfo);
11233
11234 if ((rbt == FFEINFO_basictypeTYPELESS)
11235 || (rbt == FFEINFO_basictypeHOLLERITH))
11236 {
11237 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11238 r->token, op->token, FFEINFO_basictypeINTEGER,
11239 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11240 FFETARGET_charactersizeNONE,
11241 FFEEXPR_contextLET));
11242 rinfo = ffebld_info (ffebld_left (reduced));
11243 rbt = FFEINFO_basictypeINTEGER;
11244 rkt = FFEINFO_kindtypeINTEGERDEFAULT;
11245 rrk = 0;
11246 rkd = FFEINFO_kindENTITY;
11247 rwh = ffeinfo_where (rinfo);
11248 }
11249
11250 if (rbt == FFEINFO_basictypeLOGICAL)
11251 {
11252 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11253 r->token, op->token, FFEINFO_basictypeINTEGER,
11254 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11255 FFETARGET_charactersizeNONE,
11256 FFEEXPR_contextLET));
11257 }
11258
11259 return reduced;
11260 }
11261
11262 /* ffeexpr_reduced_ugly1log_ -- Deal with TYPELESS and HOLLERITH
11263
11264 reduced = ffeexpr_reduced_ugly1log_(reduced,op,r);
11265
11266 Sigh. */
11267
11268 static ffebld
11269 ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
11270 {
11271 ffeinfo rinfo;
11272 ffeinfoBasictype rbt;
11273 ffeinfoKindtype rkt;
11274 ffeinfoRank rrk;
11275 ffeinfoKind rkd;
11276 ffeinfoWhere rwh;
11277
11278 rinfo = ffebld_info (ffebld_left (reduced));
11279 rbt = ffeinfo_basictype (rinfo);
11280 rkt = ffeinfo_kindtype (rinfo);
11281 rrk = ffeinfo_rank (rinfo);
11282 rkd = ffeinfo_kind (rinfo);
11283 rwh = ffeinfo_where (rinfo);
11284
11285 if ((rbt == FFEINFO_basictypeTYPELESS)
11286 || (rbt == FFEINFO_basictypeHOLLERITH))
11287 {
11288 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11289 r->token, op->token, FFEINFO_basictypeLOGICAL, 0,
11290 FFEINFO_kindtypeLOGICALDEFAULT,
11291 FFETARGET_charactersizeNONE,
11292 FFEEXPR_contextLET));
11293 rinfo = ffebld_info (ffebld_left (reduced));
11294 rbt = FFEINFO_basictypeLOGICAL;
11295 rkt = FFEINFO_kindtypeLOGICALDEFAULT;
11296 rrk = 0;
11297 rkd = FFEINFO_kindENTITY;
11298 rwh = ffeinfo_where (rinfo);
11299 }
11300
11301 return reduced;
11302 }
11303
11304 /* ffeexpr_reduced_ugly2_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
11305
11306 reduced = ffeexpr_reduced_ugly2_(reduced,l,op,r);
11307
11308 Sigh. */
11309
11310 static ffebld
11311 ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
11312 ffeexprExpr_ r)
11313 {
11314 ffeinfo linfo, rinfo;
11315 ffeinfoBasictype lbt, rbt;
11316 ffeinfoKindtype lkt, rkt;
11317 ffeinfoRank lrk, rrk;
11318 ffeinfoKind lkd, rkd;
11319 ffeinfoWhere lwh, rwh;
11320
11321 linfo = ffebld_info (ffebld_left (reduced));
11322 lbt = ffeinfo_basictype (linfo);
11323 lkt = ffeinfo_kindtype (linfo);
11324 lrk = ffeinfo_rank (linfo);
11325 lkd = ffeinfo_kind (linfo);
11326 lwh = ffeinfo_where (linfo);
11327
11328 rinfo = ffebld_info (ffebld_right (reduced));
11329 rbt = ffeinfo_basictype (rinfo);
11330 rkt = ffeinfo_kindtype (rinfo);
11331 rrk = ffeinfo_rank (rinfo);
11332 rkd = ffeinfo_kind (rinfo);
11333 rwh = ffeinfo_where (rinfo);
11334
11335 if ((lbt == FFEINFO_basictypeTYPELESS)
11336 || (lbt == FFEINFO_basictypeHOLLERITH))
11337 {
11338 if ((rbt == FFEINFO_basictypeTYPELESS)
11339 || (rbt == FFEINFO_basictypeHOLLERITH))
11340 {
11341 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11342 l->token, op->token, FFEINFO_basictypeINTEGER,
11343 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11344 FFETARGET_charactersizeNONE,
11345 FFEEXPR_contextLET));
11346 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11347 r->token, op->token, FFEINFO_basictypeINTEGER, 0,
11348 FFEINFO_kindtypeINTEGERDEFAULT,
11349 FFETARGET_charactersizeNONE,
11350 FFEEXPR_contextLET));
11351 linfo = ffebld_info (ffebld_left (reduced));
11352 rinfo = ffebld_info (ffebld_right (reduced));
11353 lbt = rbt = FFEINFO_basictypeINTEGER;
11354 lkt = rkt = FFEINFO_kindtypeINTEGERDEFAULT;
11355 lrk = rrk = 0;
11356 lkd = rkd = FFEINFO_kindENTITY;
11357 lwh = ffeinfo_where (linfo);
11358 rwh = ffeinfo_where (rinfo);
11359 }
11360 else
11361 {
11362 ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
11363 l->token, ffebld_right (reduced), r->token,
11364 FFEEXPR_contextLET));
11365 linfo = ffebld_info (ffebld_left (reduced));
11366 lbt = ffeinfo_basictype (linfo);
11367 lkt = ffeinfo_kindtype (linfo);
11368 lrk = ffeinfo_rank (linfo);
11369 lkd = ffeinfo_kind (linfo);
11370 lwh = ffeinfo_where (linfo);
11371 }
11372 }
11373 else
11374 {
11375 if ((rbt == FFEINFO_basictypeTYPELESS)
11376 || (rbt == FFEINFO_basictypeHOLLERITH))
11377 {
11378 ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
11379 r->token, ffebld_left (reduced), l->token,
11380 FFEEXPR_contextLET));
11381 rinfo = ffebld_info (ffebld_right (reduced));
11382 rbt = ffeinfo_basictype (rinfo);
11383 rkt = ffeinfo_kindtype (rinfo);
11384 rrk = ffeinfo_rank (rinfo);
11385 rkd = ffeinfo_kind (rinfo);
11386 rwh = ffeinfo_where (rinfo);
11387 }
11388 /* else Leave it alone. */
11389 }
11390
11391 if (lbt == FFEINFO_basictypeLOGICAL)
11392 {
11393 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11394 l->token, op->token, FFEINFO_basictypeINTEGER,
11395 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11396 FFETARGET_charactersizeNONE,
11397 FFEEXPR_contextLET));
11398 }
11399
11400 if (rbt == FFEINFO_basictypeLOGICAL)
11401 {
11402 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11403 r->token, op->token, FFEINFO_basictypeINTEGER,
11404 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11405 FFETARGET_charactersizeNONE,
11406 FFEEXPR_contextLET));
11407 }
11408
11409 return reduced;
11410 }
11411
11412 /* ffeexpr_reduced_ugly2log_ -- Deal with TYPELESS and HOLLERITH
11413
11414 reduced = ffeexpr_reduced_ugly2log_(reduced,l,op,r);
11415
11416 Sigh. */
11417
11418 static ffebld
11419 ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
11420 ffeexprExpr_ r)
11421 {
11422 ffeinfo linfo, rinfo;
11423 ffeinfoBasictype lbt, rbt;
11424 ffeinfoKindtype lkt, rkt;
11425 ffeinfoRank lrk, rrk;
11426 ffeinfoKind lkd, rkd;
11427 ffeinfoWhere lwh, rwh;
11428
11429 linfo = ffebld_info (ffebld_left (reduced));
11430 lbt = ffeinfo_basictype (linfo);
11431 lkt = ffeinfo_kindtype (linfo);
11432 lrk = ffeinfo_rank (linfo);
11433 lkd = ffeinfo_kind (linfo);
11434 lwh = ffeinfo_where (linfo);
11435
11436 rinfo = ffebld_info (ffebld_right (reduced));
11437 rbt = ffeinfo_basictype (rinfo);
11438 rkt = ffeinfo_kindtype (rinfo);
11439 rrk = ffeinfo_rank (rinfo);
11440 rkd = ffeinfo_kind (rinfo);
11441 rwh = ffeinfo_where (rinfo);
11442
11443 if ((lbt == FFEINFO_basictypeTYPELESS)
11444 || (lbt == FFEINFO_basictypeHOLLERITH))
11445 {
11446 if ((rbt == FFEINFO_basictypeTYPELESS)
11447 || (rbt == FFEINFO_basictypeHOLLERITH))
11448 {
11449 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11450 l->token, op->token, FFEINFO_basictypeLOGICAL,
11451 FFEINFO_kindtypeLOGICALDEFAULT, 0,
11452 FFETARGET_charactersizeNONE,
11453 FFEEXPR_contextLET));
11454 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11455 r->token, op->token, FFEINFO_basictypeLOGICAL,
11456 FFEINFO_kindtypeLOGICALDEFAULT, 0,
11457 FFETARGET_charactersizeNONE,
11458 FFEEXPR_contextLET));
11459 linfo = ffebld_info (ffebld_left (reduced));
11460 rinfo = ffebld_info (ffebld_right (reduced));
11461 lbt = rbt = FFEINFO_basictypeLOGICAL;
11462 lkt = rkt = FFEINFO_kindtypeLOGICALDEFAULT;
11463 lrk = rrk = 0;
11464 lkd = rkd = FFEINFO_kindENTITY;
11465 lwh = ffeinfo_where (linfo);
11466 rwh = ffeinfo_where (rinfo);
11467 }
11468 else
11469 {
11470 ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
11471 l->token, ffebld_right (reduced), r->token,
11472 FFEEXPR_contextLET));
11473 linfo = ffebld_info (ffebld_left (reduced));
11474 lbt = ffeinfo_basictype (linfo);
11475 lkt = ffeinfo_kindtype (linfo);
11476 lrk = ffeinfo_rank (linfo);
11477 lkd = ffeinfo_kind (linfo);
11478 lwh = ffeinfo_where (linfo);
11479 }
11480 }
11481 else
11482 {
11483 if ((rbt == FFEINFO_basictypeTYPELESS)
11484 || (rbt == FFEINFO_basictypeHOLLERITH))
11485 {
11486 ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
11487 r->token, ffebld_left (reduced), l->token,
11488 FFEEXPR_contextLET));
11489 rinfo = ffebld_info (ffebld_right (reduced));
11490 rbt = ffeinfo_basictype (rinfo);
11491 rkt = ffeinfo_kindtype (rinfo);
11492 rrk = ffeinfo_rank (rinfo);
11493 rkd = ffeinfo_kind (rinfo);
11494 rwh = ffeinfo_where (rinfo);
11495 }
11496 /* else Leave it alone. */
11497 }
11498
11499 return reduced;
11500 }
11501
11502 /* Fumble through tokens until a nonmatching CLOSE_PAREN, EOS, or SEMICOLON
11503 is found.
11504
11505 The idea is to process the tokens as they would be done by normal
11506 expression processing, with the key things being telling the lexer
11507 when hollerith/character constants are about to happen, until the
11508 true closing token is found. */
11509
11510 static ffelexHandler
11511 ffeexpr_find_close_paren_ (ffelexToken t,
11512 ffelexHandler after)
11513 {
11514 ffeexpr_find_.after = after;
11515 ffeexpr_find_.level = 1;
11516 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11517 }
11518
11519 static ffelexHandler
11520 ffeexpr_nil_finished_ (ffelexToken t)
11521 {
11522 switch (ffelex_token_type (t))
11523 {
11524 case FFELEX_typeCLOSE_PAREN:
11525 if (--ffeexpr_find_.level == 0)
11526 return (ffelexHandler) ffeexpr_find_.after;
11527 return (ffelexHandler) ffeexpr_nil_binary_;
11528
11529 case FFELEX_typeCOMMA:
11530 case FFELEX_typeCOLON:
11531 case FFELEX_typeEQUALS:
11532 case FFELEX_typePOINTS:
11533 return (ffelexHandler) ffeexpr_nil_rhs_;
11534
11535 default:
11536 if (--ffeexpr_find_.level == 0)
11537 return (ffelexHandler) ffeexpr_find_.after (t);
11538 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11539 }
11540 }
11541
11542 static ffelexHandler
11543 ffeexpr_nil_rhs_ (ffelexToken t)
11544 {
11545 switch (ffelex_token_type (t))
11546 {
11547 case FFELEX_typeQUOTE:
11548 if (ffe_is_vxt ())
11549 return (ffelexHandler) ffeexpr_nil_quote_;
11550 ffelex_set_expecting_hollerith (-1, '\"',
11551 ffelex_token_where_line (t),
11552 ffelex_token_where_column (t));
11553 return (ffelexHandler) ffeexpr_nil_apostrophe_;
11554
11555 case FFELEX_typeAPOSTROPHE:
11556 ffelex_set_expecting_hollerith (-1, '\'',
11557 ffelex_token_where_line (t),
11558 ffelex_token_where_column (t));
11559 return (ffelexHandler) ffeexpr_nil_apostrophe_;
11560
11561 case FFELEX_typePERCENT:
11562 return (ffelexHandler) ffeexpr_nil_percent_;
11563
11564 case FFELEX_typeOPEN_PAREN:
11565 ++ffeexpr_find_.level;
11566 return (ffelexHandler) ffeexpr_nil_rhs_;
11567
11568 case FFELEX_typePLUS:
11569 case FFELEX_typeMINUS:
11570 return (ffelexHandler) ffeexpr_nil_rhs_;
11571
11572 case FFELEX_typePERIOD:
11573 return (ffelexHandler) ffeexpr_nil_period_;
11574
11575 case FFELEX_typeNUMBER:
11576 ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
11577 if (ffeexpr_hollerith_count_ > 0)
11578 ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
11579 '\0',
11580 ffelex_token_where_line (t),
11581 ffelex_token_where_column (t));
11582 return (ffelexHandler) ffeexpr_nil_number_;
11583
11584 case FFELEX_typeNAME:
11585 case FFELEX_typeNAMES:
11586 return (ffelexHandler) ffeexpr_nil_name_rhs_;
11587
11588 case FFELEX_typeASTERISK:
11589 case FFELEX_typeSLASH:
11590 case FFELEX_typePOWER:
11591 case FFELEX_typeCONCAT:
11592 case FFELEX_typeREL_EQ:
11593 case FFELEX_typeREL_NE:
11594 case FFELEX_typeREL_LE:
11595 case FFELEX_typeREL_GE:
11596 return (ffelexHandler) ffeexpr_nil_rhs_;
11597
11598 default:
11599 return (ffelexHandler) ffeexpr_nil_finished_ (t);
11600 }
11601 }
11602
11603 static ffelexHandler
11604 ffeexpr_nil_period_ (ffelexToken t)
11605 {
11606 switch (ffelex_token_type (t))
11607 {
11608 case FFELEX_typeNAME:
11609 case FFELEX_typeNAMES:
11610 ffeexpr_current_dotdot_ = ffestr_other (t);
11611 switch (ffeexpr_current_dotdot_)
11612 {
11613 case FFESTR_otherNone:
11614 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11615
11616 case FFESTR_otherTRUE:
11617 case FFESTR_otherFALSE:
11618 case FFESTR_otherNOT:
11619 return (ffelexHandler) ffeexpr_nil_end_period_;
11620
11621 default:
11622 return (ffelexHandler) ffeexpr_nil_swallow_period_;
11623 }
11624 break; /* Nothing really reaches here. */
11625
11626 case FFELEX_typeNUMBER:
11627 return (ffelexHandler) ffeexpr_nil_real_;
11628
11629 default:
11630 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11631 }
11632 }
11633
11634 static ffelexHandler
11635 ffeexpr_nil_end_period_ (ffelexToken t)
11636 {
11637 switch (ffeexpr_current_dotdot_)
11638 {
11639 case FFESTR_otherNOT:
11640 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11641 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11642 return (ffelexHandler) ffeexpr_nil_rhs_;
11643
11644 case FFESTR_otherTRUE:
11645 case FFESTR_otherFALSE:
11646 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11647 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11648 return (ffelexHandler) ffeexpr_nil_binary_;
11649
11650 default:
11651 assert ("Bad [nil] unary dotdot in ffeexpr_current_dotdot_" == NULL);
11652 exit (0);
11653 return NULL;
11654 }
11655 }
11656
11657 static ffelexHandler
11658 ffeexpr_nil_swallow_period_ (ffelexToken t)
11659 {
11660 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11661 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11662 return (ffelexHandler) ffeexpr_nil_rhs_;
11663 }
11664
11665 static ffelexHandler
11666 ffeexpr_nil_real_ (ffelexToken t)
11667 {
11668 char d;
11669 const char *p;
11670
11671 if (((ffelex_token_type (t) != FFELEX_typeNAME)
11672 && (ffelex_token_type (t) != FFELEX_typeNAMES))
11673 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11674 'D', 'd')
11675 || ffesrc_char_match_init (d, 'E', 'e')
11676 || ffesrc_char_match_init (d, 'Q', 'q')))
11677 && ffeexpr_isdigits_ (++p)))
11678 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11679
11680 if (*p == '\0')
11681 return (ffelexHandler) ffeexpr_nil_real_exponent_;
11682 return (ffelexHandler) ffeexpr_nil_binary_;
11683 }
11684
11685 static ffelexHandler
11686 ffeexpr_nil_real_exponent_ (ffelexToken t)
11687 {
11688 if ((ffelex_token_type (t) != FFELEX_typePLUS)
11689 && (ffelex_token_type (t) != FFELEX_typeMINUS))
11690 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11691
11692 return (ffelexHandler) ffeexpr_nil_real_exp_sign_;
11693 }
11694
11695 static ffelexHandler
11696 ffeexpr_nil_real_exp_sign_ (ffelexToken t)
11697 {
11698 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11699 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11700 return (ffelexHandler) ffeexpr_nil_binary_;
11701 }
11702
11703 static ffelexHandler
11704 ffeexpr_nil_number_ (ffelexToken t)
11705 {
11706 char d;
11707 const char *p;
11708
11709 if (ffeexpr_hollerith_count_ > 0)
11710 ffelex_set_expecting_hollerith (0, '\0',
11711 ffewhere_line_unknown (),
11712 ffewhere_column_unknown ());
11713
11714 switch (ffelex_token_type (t))
11715 {
11716 case FFELEX_typeNAME:
11717 case FFELEX_typeNAMES:
11718 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11719 'D', 'd')
11720 || ffesrc_char_match_init (d, 'E', 'e')
11721 || ffesrc_char_match_init (d, 'Q', 'q'))
11722 && ffeexpr_isdigits_ (++p))
11723 {
11724 if (*p == '\0')
11725 {
11726 ffeexpr_find_.t = ffelex_token_use (t);
11727 return (ffelexHandler) ffeexpr_nil_number_exponent_;
11728 }
11729 return (ffelexHandler) ffeexpr_nil_binary_;
11730 }
11731 break;
11732
11733 case FFELEX_typePERIOD:
11734 ffeexpr_find_.t = ffelex_token_use (t);
11735 return (ffelexHandler) ffeexpr_nil_number_period_;
11736
11737 case FFELEX_typeHOLLERITH:
11738 return (ffelexHandler) ffeexpr_nil_binary_;
11739
11740 default:
11741 break;
11742 }
11743 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11744 }
11745
11746 /* Expects ffeexpr_find_.t. */
11747
11748 static ffelexHandler
11749 ffeexpr_nil_number_exponent_ (ffelexToken t)
11750 {
11751 ffelexHandler nexthandler;
11752
11753 if ((ffelex_token_type (t) != FFELEX_typePLUS)
11754 && (ffelex_token_type (t) != FFELEX_typeMINUS))
11755 {
11756 nexthandler
11757 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
11758 ffelex_token_kill (ffeexpr_find_.t);
11759 return (ffelexHandler) (*nexthandler) (t);
11760 }
11761
11762 ffelex_token_kill (ffeexpr_find_.t);
11763 return (ffelexHandler) ffeexpr_nil_number_exp_sign_;
11764 }
11765
11766 static ffelexHandler
11767 ffeexpr_nil_number_exp_sign_ (ffelexToken t)
11768 {
11769 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11770 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11771
11772 return (ffelexHandler) ffeexpr_nil_binary_;
11773 }
11774
11775 /* Expects ffeexpr_find_.t. */
11776
11777 static ffelexHandler
11778 ffeexpr_nil_number_period_ (ffelexToken t)
11779 {
11780 ffelexHandler nexthandler;
11781 char d;
11782 const char *p;
11783
11784 switch (ffelex_token_type (t))
11785 {
11786 case FFELEX_typeNAME:
11787 case FFELEX_typeNAMES:
11788 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11789 'D', 'd')
11790 || ffesrc_char_match_init (d, 'E', 'e')
11791 || ffesrc_char_match_init (d, 'Q', 'q'))
11792 && ffeexpr_isdigits_ (++p))
11793 {
11794 if (*p == '\0')
11795 return (ffelexHandler) ffeexpr_nil_number_per_exp_;
11796 ffelex_token_kill (ffeexpr_find_.t);
11797 return (ffelexHandler) ffeexpr_nil_binary_;
11798 }
11799 nexthandler
11800 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
11801 ffelex_token_kill (ffeexpr_find_.t);
11802 return (ffelexHandler) (*nexthandler) (t);
11803
11804 case FFELEX_typeNUMBER:
11805 ffelex_token_kill (ffeexpr_find_.t);
11806 return (ffelexHandler) ffeexpr_nil_number_real_;
11807
11808 default:
11809 break;
11810 }
11811 ffelex_token_kill (ffeexpr_find_.t);
11812 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11813 }
11814
11815 /* Expects ffeexpr_find_.t. */
11816
11817 static ffelexHandler
11818 ffeexpr_nil_number_per_exp_ (ffelexToken t)
11819 {
11820 if ((ffelex_token_type (t) != FFELEX_typePLUS)
11821 && (ffelex_token_type (t) != FFELEX_typeMINUS))
11822 {
11823 ffelexHandler nexthandler;
11824
11825 nexthandler
11826 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
11827 ffelex_token_kill (ffeexpr_find_.t);
11828 return (ffelexHandler) (*nexthandler) (t);
11829 }
11830
11831 ffelex_token_kill (ffeexpr_find_.t);
11832 return (ffelexHandler) ffeexpr_nil_num_per_exp_sign_;
11833 }
11834
11835 static ffelexHandler
11836 ffeexpr_nil_number_real_ (ffelexToken t)
11837 {
11838 char d;
11839 const char *p;
11840
11841 if (((ffelex_token_type (t) != FFELEX_typeNAME)
11842 && (ffelex_token_type (t) != FFELEX_typeNAMES))
11843 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11844 'D', 'd')
11845 || ffesrc_char_match_init (d, 'E', 'e')
11846 || ffesrc_char_match_init (d, 'Q', 'q')))
11847 && ffeexpr_isdigits_ (++p)))
11848 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11849
11850 if (*p == '\0')
11851 return (ffelexHandler) ffeexpr_nil_number_real_exp_;
11852
11853 return (ffelexHandler) ffeexpr_nil_binary_;
11854 }
11855
11856 static ffelexHandler
11857 ffeexpr_nil_num_per_exp_sign_ (ffelexToken t)
11858 {
11859 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11860 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11861 return (ffelexHandler) ffeexpr_nil_binary_;
11862 }
11863
11864 static ffelexHandler
11865 ffeexpr_nil_number_real_exp_ (ffelexToken t)
11866 {
11867 if ((ffelex_token_type (t) != FFELEX_typePLUS)
11868 && (ffelex_token_type (t) != FFELEX_typeMINUS))
11869 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11870 return (ffelexHandler) ffeexpr_nil_num_real_exp_sn_;
11871 }
11872
11873 static ffelexHandler
11874 ffeexpr_nil_num_real_exp_sn_ (ffelexToken t)
11875 {
11876 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11877 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11878 return (ffelexHandler) ffeexpr_nil_binary_;
11879 }
11880
11881 static ffelexHandler
11882 ffeexpr_nil_binary_ (ffelexToken t)
11883 {
11884 switch (ffelex_token_type (t))
11885 {
11886 case FFELEX_typePLUS:
11887 case FFELEX_typeMINUS:
11888 case FFELEX_typeASTERISK:
11889 case FFELEX_typeSLASH:
11890 case FFELEX_typePOWER:
11891 case FFELEX_typeCONCAT:
11892 case FFELEX_typeOPEN_ANGLE:
11893 case FFELEX_typeCLOSE_ANGLE:
11894 case FFELEX_typeREL_EQ:
11895 case FFELEX_typeREL_NE:
11896 case FFELEX_typeREL_GE:
11897 case FFELEX_typeREL_LE:
11898 return (ffelexHandler) ffeexpr_nil_rhs_;
11899
11900 case FFELEX_typePERIOD:
11901 return (ffelexHandler) ffeexpr_nil_binary_period_;
11902
11903 default:
11904 return (ffelexHandler) ffeexpr_nil_finished_ (t);
11905 }
11906 }
11907
11908 static ffelexHandler
11909 ffeexpr_nil_binary_period_ (ffelexToken t)
11910 {
11911 switch (ffelex_token_type (t))
11912 {
11913 case FFELEX_typeNAME:
11914 case FFELEX_typeNAMES:
11915 ffeexpr_current_dotdot_ = ffestr_other (t);
11916 switch (ffeexpr_current_dotdot_)
11917 {
11918 case FFESTR_otherTRUE:
11919 case FFESTR_otherFALSE:
11920 case FFESTR_otherNOT:
11921 return (ffelexHandler) ffeexpr_nil_binary_sw_per_;
11922
11923 default:
11924 return (ffelexHandler) ffeexpr_nil_binary_end_per_;
11925 }
11926 break; /* Nothing really reaches here. */
11927
11928 default:
11929 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11930 }
11931 }
11932
11933 static ffelexHandler
11934 ffeexpr_nil_binary_end_per_ (ffelexToken t)
11935 {
11936 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11937 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11938 return (ffelexHandler) ffeexpr_nil_rhs_;
11939 }
11940
11941 static ffelexHandler
11942 ffeexpr_nil_binary_sw_per_ (ffelexToken t)
11943 {
11944 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11945 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11946 return (ffelexHandler) ffeexpr_nil_binary_;
11947 }
11948
11949 static ffelexHandler
11950 ffeexpr_nil_quote_ (ffelexToken t)
11951 {
11952 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11953 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11954 return (ffelexHandler) ffeexpr_nil_binary_;
11955 }
11956
11957 static ffelexHandler
11958 ffeexpr_nil_apostrophe_ (ffelexToken t)
11959 {
11960 assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
11961 return (ffelexHandler) ffeexpr_nil_apos_char_;
11962 }
11963
11964 static ffelexHandler
11965 ffeexpr_nil_apos_char_ (ffelexToken t)
11966 {
11967 char c;
11968
11969 if ((ffelex_token_type (t) == FFELEX_typeNAME)
11970 || (ffelex_token_type (t) == FFELEX_typeNAMES))
11971 {
11972 if ((ffelex_token_length (t) == 1)
11973 && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]),
11974 'B', 'b')
11975 || ffesrc_char_match_init (c, 'O', 'o')
11976 || ffesrc_char_match_init (c, 'X', 'x')
11977 || ffesrc_char_match_init (c, 'Z', 'z')))
11978 return (ffelexHandler) ffeexpr_nil_binary_;
11979 }
11980 if ((ffelex_token_type (t) == FFELEX_typeNAME)
11981 || (ffelex_token_type (t) == FFELEX_typeNAMES))
11982 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11983 return (ffelexHandler) ffeexpr_nil_substrp_ (t);
11984 }
11985
11986 static ffelexHandler
11987 ffeexpr_nil_name_rhs_ (ffelexToken t)
11988 {
11989 switch (ffelex_token_type (t))
11990 {
11991 case FFELEX_typeQUOTE:
11992 case FFELEX_typeAPOSTROPHE:
11993 ffelex_set_hexnum (TRUE);
11994 return (ffelexHandler) ffeexpr_nil_name_apos_;
11995
11996 case FFELEX_typeOPEN_PAREN:
11997 ++ffeexpr_find_.level;
11998 return (ffelexHandler) ffeexpr_nil_rhs_;
11999
12000 default:
12001 return (ffelexHandler) ffeexpr_nil_binary_ (t);
12002 }
12003 }
12004
12005 static ffelexHandler
12006 ffeexpr_nil_name_apos_ (ffelexToken t)
12007 {
12008 if (ffelex_token_type (t) == FFELEX_typeNAME)
12009 return (ffelexHandler) ffeexpr_nil_name_apos_name_;
12010 return (ffelexHandler) ffeexpr_nil_binary_ (t);
12011 }
12012
12013 static ffelexHandler
12014 ffeexpr_nil_name_apos_name_ (ffelexToken t)
12015 {
12016 switch (ffelex_token_type (t))
12017 {
12018 case FFELEX_typeAPOSTROPHE:
12019 case FFELEX_typeQUOTE:
12020 return (ffelexHandler) ffeexpr_nil_finished_;
12021
12022 default:
12023 return (ffelexHandler) ffeexpr_nil_finished_ (t);
12024 }
12025 }
12026
12027 static ffelexHandler
12028 ffeexpr_nil_percent_ (ffelexToken t)
12029 {
12030 switch (ffelex_token_type (t))
12031 {
12032 case FFELEX_typeNAME:
12033 case FFELEX_typeNAMES:
12034 ffeexpr_stack_->percent = ffeexpr_percent_ (t);
12035 ffeexpr_find_.t = ffelex_token_use (t);
12036 return (ffelexHandler) ffeexpr_nil_percent_name_;
12037
12038 default:
12039 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
12040 }
12041 }
12042
12043 /* Expects ffeexpr_find_.t. */
12044
12045 static ffelexHandler
12046 ffeexpr_nil_percent_name_ (ffelexToken t)
12047 {
12048 ffelexHandler nexthandler;
12049
12050 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
12051 {
12052 nexthandler
12053 = (ffelexHandler) ffeexpr_nil_rhs_ (ffeexpr_find_.t);
12054 ffelex_token_kill (ffeexpr_find_.t);
12055 return (ffelexHandler) (*nexthandler) (t);
12056 }
12057
12058 ffelex_token_kill (ffeexpr_find_.t);
12059 ++ffeexpr_find_.level;
12060 return (ffelexHandler) ffeexpr_nil_rhs_;
12061 }
12062
12063 static ffelexHandler
12064 ffeexpr_nil_substrp_ (ffelexToken t)
12065 {
12066 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
12067 return (ffelexHandler) ffeexpr_nil_binary_ (t);
12068
12069 ++ffeexpr_find_.level;
12070 return (ffelexHandler) ffeexpr_nil_rhs_;
12071 }
12072
12073 /* ffeexpr_finished_ -- Reduce expression stack to one expr, finish
12074
12075 ffelexToken t;
12076 return ffeexpr_finished_(t);
12077
12078 Reduces expression stack to one (or zero) elements by repeatedly reducing
12079 the top operator on the stack (or, if the top element on the stack is
12080 itself an operator, issuing an error message and discarding it). Calls
12081 finishing routine with the expression, returning the ffelexHandler it
12082 returns to the caller. */
12083
12084 static ffelexHandler
12085 ffeexpr_finished_ (ffelexToken t)
12086 {
12087 ffeexprExpr_ operand; /* This is B in -B or A+B. */
12088 ffebld expr;
12089 ffeexprCallback callback;
12090 ffeexprStack_ s;
12091 ffebldConstant constnode; /* For detecting magical number. */
12092 ffelexToken ft; /* Temporary copy of first token in
12093 expression. */
12094 ffelexHandler next;
12095 ffeinfo info;
12096 bool error = FALSE;
12097
12098 while (((operand = ffeexpr_stack_->exprstack) != NULL)
12099 && ((operand->previous != NULL) || (operand->type != FFEEXPR_exprtypeOPERAND_)))
12100 {
12101 if (operand->type == FFEEXPR_exprtypeOPERAND_)
12102 ffeexpr_reduce_ ();
12103 else
12104 {
12105 if (ffest_ffebad_start (FFEBAD_MISSING_OPERAND_FOR_OPERATOR))
12106 {
12107 ffebad_here (0, ffelex_token_where_line (t),
12108 ffelex_token_where_column (t));
12109 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
12110 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
12111 ffebad_finish ();
12112 }
12113 ffeexpr_stack_->exprstack = operand->previous; /* Pop the useless
12114 operator. */
12115 ffeexpr_expr_kill_ (operand);
12116 }
12117 }
12118
12119 assert ((operand == NULL) || (operand->previous == NULL));
12120
12121 ffebld_pool_pop ();
12122 if (operand == NULL)
12123 expr = NULL;
12124 else
12125 {
12126 expr = operand->u.operand;
12127 info = ffebld_info (expr);
12128 if ((ffebld_op (expr) == FFEBLD_opCONTER)
12129 && (ffebld_conter_orig (expr) == NULL)
12130 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
12131 {
12132 ffetarget_integer_bad_magical (operand->token);
12133 }
12134 ffeexpr_expr_kill_ (operand);
12135 ffeexpr_stack_->exprstack = NULL;
12136 }
12137
12138 ft = ffeexpr_stack_->first_token;
12139
12140 again: /* :::::::::::::::::::: */
12141 switch (ffeexpr_stack_->context)
12142 {
12143 case FFEEXPR_contextLET:
12144 case FFEEXPR_contextSFUNCDEF:
12145 error = (expr == NULL)
12146 || (ffeinfo_rank (info) != 0);
12147 break;
12148
12149 case FFEEXPR_contextPAREN_:
12150 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12151 break;
12152 switch (ffeinfo_basictype (info))
12153 {
12154 case FFEINFO_basictypeHOLLERITH:
12155 case FFEINFO_basictypeTYPELESS:
12156 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12157 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12158 FFEEXPR_contextLET);
12159 break;
12160
12161 default:
12162 break;
12163 }
12164 break;
12165
12166 case FFEEXPR_contextPARENFILENUM_:
12167 if (ffelex_token_type (t) != FFELEX_typeCOMMA)
12168 ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
12169 else
12170 ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
12171 goto again; /* :::::::::::::::::::: */
12172
12173 case FFEEXPR_contextPARENFILEUNIT_:
12174 if (ffelex_token_type (t) != FFELEX_typeCOMMA)
12175 ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
12176 else
12177 ffeexpr_stack_->context = FFEEXPR_contextFILEUNIT;
12178 goto again; /* :::::::::::::::::::: */
12179
12180 case FFEEXPR_contextACTUALARGEXPR_:
12181 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
12182 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12183 : ffeinfo_basictype (info))
12184 {
12185 case FFEINFO_basictypeHOLLERITH:
12186 case FFEINFO_basictypeTYPELESS:
12187 if (!ffe_is_ugly_args ()
12188 && ffebad_start (FFEBAD_ACTUALARG))
12189 {
12190 ffebad_here (0, ffelex_token_where_line (ft),
12191 ffelex_token_where_column (ft));
12192 ffebad_finish ();
12193 }
12194 break;
12195
12196 default:
12197 break;
12198 }
12199 error = (expr != NULL) && (ffeinfo_rank (info) != 0);
12200 break;
12201
12202 case FFEEXPR_contextACTUALARG_:
12203 case FFEEXPR_contextSFUNCDEFACTUALARG_:
12204 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12205 : ffeinfo_basictype (info))
12206 {
12207 case FFEINFO_basictypeHOLLERITH:
12208 case FFEINFO_basictypeTYPELESS:
12209 #if 0 /* Should never get here. */
12210 expr = ffeexpr_convert (expr, ft, ft,
12211 FFEINFO_basictypeINTEGER,
12212 FFEINFO_kindtypeINTEGERDEFAULT,
12213 0,
12214 FFETARGET_charactersizeNONE,
12215 FFEEXPR_contextLET);
12216 #else
12217 assert ("why hollerith/typeless in actualarg_?" == NULL);
12218 #endif
12219 break;
12220
12221 default:
12222 break;
12223 }
12224 switch ((expr == NULL) ? FFEBLD_opANY : ffebld_op (expr))
12225 {
12226 case FFEBLD_opSYMTER:
12227 case FFEBLD_opPERCENT_LOC:
12228 case FFEBLD_opPERCENT_VAL:
12229 case FFEBLD_opPERCENT_REF:
12230 case FFEBLD_opPERCENT_DESCR:
12231 error = FALSE;
12232 break;
12233
12234 default:
12235 error = (expr != NULL) && (ffeinfo_rank (info) != 0);
12236 break;
12237 }
12238 {
12239 ffesymbol s;
12240 ffeinfoWhere where;
12241 ffeinfoKind kind;
12242
12243 if (!error
12244 && (expr != NULL)
12245 && (ffebld_op (expr) == FFEBLD_opSYMTER)
12246 && ((s = ffebld_symter (expr)), (where = ffesymbol_where (s)),
12247 (where == FFEINFO_whereINTRINSIC)
12248 || (where == FFEINFO_whereGLOBAL)
12249 || ((where == FFEINFO_whereDUMMY)
12250 && ((kind = ffesymbol_kind (s)),
12251 (kind == FFEINFO_kindFUNCTION)
12252 || (kind == FFEINFO_kindSUBROUTINE))))
12253 && !ffesymbol_explicitwhere (s))
12254 {
12255 ffebad_start (where == FFEINFO_whereINTRINSIC
12256 ? FFEBAD_NEED_INTRINSIC : FFEBAD_NEED_EXTERNAL);
12257 ffebad_here (0, ffelex_token_where_line (ft),
12258 ffelex_token_where_column (ft));
12259 ffebad_string (ffesymbol_text (s));
12260 ffebad_finish ();
12261 ffesymbol_signal_change (s);
12262 ffesymbol_set_explicitwhere (s, TRUE);
12263 ffesymbol_signal_unreported (s);
12264 }
12265 }
12266 break;
12267
12268 case FFEEXPR_contextINDEX_:
12269 case FFEEXPR_contextSFUNCDEFINDEX_:
12270 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12271 break;
12272 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12273 : ffeinfo_basictype (info))
12274 {
12275 case FFEINFO_basictypeNONE:
12276 error = FALSE;
12277 break;
12278
12279 case FFEINFO_basictypeLOGICAL:
12280 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12281 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12282 FFEEXPR_contextLET);
12283 /* Fall through. */
12284 case FFEINFO_basictypeREAL:
12285 case FFEINFO_basictypeCOMPLEX:
12286 if (ffe_is_pedantic ())
12287 {
12288 error = TRUE;
12289 break;
12290 }
12291 /* Fall through. */
12292 case FFEINFO_basictypeHOLLERITH:
12293 case FFEINFO_basictypeTYPELESS:
12294 error = FALSE;
12295 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12296 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12297 FFEEXPR_contextLET);
12298 break;
12299
12300 case FFEINFO_basictypeINTEGER:
12301 /* Specifically, allow INTEGER(KIND=2), aka INTEGER*8, through
12302 unmolested. Leave it to downstream to handle kinds. */
12303 break;
12304
12305 default:
12306 error = TRUE;
12307 break;
12308 }
12309 break; /* expr==NULL ok for substring; element case
12310 caught by callback. */
12311
12312 case FFEEXPR_contextRETURN:
12313 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12314 break;
12315 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12316 : ffeinfo_basictype (info))
12317 {
12318 case FFEINFO_basictypeNONE:
12319 error = FALSE;
12320 break;
12321
12322 case FFEINFO_basictypeLOGICAL:
12323 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12324 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12325 FFEEXPR_contextLET);
12326 /* Fall through. */
12327 case FFEINFO_basictypeREAL:
12328 case FFEINFO_basictypeCOMPLEX:
12329 if (ffe_is_pedantic ())
12330 {
12331 error = TRUE;
12332 break;
12333 }
12334 /* Fall through. */
12335 case FFEINFO_basictypeINTEGER:
12336 case FFEINFO_basictypeHOLLERITH:
12337 case FFEINFO_basictypeTYPELESS:
12338 error = FALSE;
12339 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12340 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12341 FFEEXPR_contextLET);
12342 break;
12343
12344 default:
12345 error = TRUE;
12346 break;
12347 }
12348 break;
12349
12350 case FFEEXPR_contextDO:
12351 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12352 break;
12353 switch (ffeinfo_basictype (info))
12354 {
12355 case FFEINFO_basictypeLOGICAL:
12356 error = !ffe_is_ugly_logint ();
12357 if (!ffeexpr_stack_->is_rhs)
12358 break; /* Don't convert lhs variable. */
12359 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12360 ffeinfo_kindtype (ffebld_info (expr)), 0,
12361 FFETARGET_charactersizeNONE,
12362 FFEEXPR_contextLET);
12363 break;
12364
12365 case FFEINFO_basictypeHOLLERITH:
12366 case FFEINFO_basictypeTYPELESS:
12367 if (!ffeexpr_stack_->is_rhs)
12368 {
12369 error = TRUE;
12370 break; /* Don't convert lhs variable. */
12371 }
12372 break;
12373
12374 case FFEINFO_basictypeINTEGER:
12375 case FFEINFO_basictypeREAL:
12376 break;
12377
12378 default:
12379 error = TRUE;
12380 break;
12381 }
12382 if (!ffeexpr_stack_->is_rhs
12383 && (ffebld_op (expr) != FFEBLD_opSYMTER))
12384 error = TRUE;
12385 break;
12386
12387 case FFEEXPR_contextDOWHILE:
12388 case FFEEXPR_contextIF:
12389 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12390 break;
12391 switch (ffeinfo_basictype (info))
12392 {
12393 case FFEINFO_basictypeINTEGER:
12394 error = FALSE;
12395 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12396 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12397 FFEEXPR_contextLET);
12398 /* Fall through. */
12399 case FFEINFO_basictypeLOGICAL:
12400 case FFEINFO_basictypeHOLLERITH:
12401 case FFEINFO_basictypeTYPELESS:
12402 error = FALSE;
12403 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12404 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12405 FFEEXPR_contextLET);
12406 break;
12407
12408 default:
12409 error = TRUE;
12410 break;
12411 }
12412 break;
12413
12414 case FFEEXPR_contextASSIGN:
12415 case FFEEXPR_contextAGOTO:
12416 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12417 : ffeinfo_basictype (info))
12418 {
12419 case FFEINFO_basictypeINTEGER:
12420 error = (ffeinfo_kindtype (info) != ffecom_label_kind ());
12421 break;
12422
12423 case FFEINFO_basictypeLOGICAL:
12424 error = !ffe_is_ugly_logint ()
12425 || (ffeinfo_kindtype (info) != ffecom_label_kind ());
12426 break;
12427
12428 default:
12429 error = TRUE;
12430 break;
12431 }
12432 if ((expr == NULL) || (ffeinfo_rank (info) != 0)
12433 || (ffebld_op (expr) != FFEBLD_opSYMTER))
12434 error = TRUE;
12435 break;
12436
12437 case FFEEXPR_contextCGOTO:
12438 case FFEEXPR_contextFORMAT:
12439 case FFEEXPR_contextDIMLIST:
12440 case FFEEXPR_contextFILENUM: /* See equiv code in _ambig_. */
12441 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12442 break;
12443 switch (ffeinfo_basictype (info))
12444 {
12445 case FFEINFO_basictypeLOGICAL:
12446 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12447 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12448 FFEEXPR_contextLET);
12449 /* Fall through. */
12450 case FFEINFO_basictypeREAL:
12451 case FFEINFO_basictypeCOMPLEX:
12452 if (ffe_is_pedantic ())
12453 {
12454 error = TRUE;
12455 break;
12456 }
12457 /* Fall through. */
12458 case FFEINFO_basictypeINTEGER:
12459 case FFEINFO_basictypeHOLLERITH:
12460 case FFEINFO_basictypeTYPELESS:
12461 error = FALSE;
12462 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12463 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12464 FFEEXPR_contextLET);
12465 break;
12466
12467 default:
12468 error = TRUE;
12469 break;
12470 }
12471 break;
12472
12473 case FFEEXPR_contextARITHIF:
12474 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12475 break;
12476 switch (ffeinfo_basictype (info))
12477 {
12478 case FFEINFO_basictypeLOGICAL:
12479 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12480 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12481 FFEEXPR_contextLET);
12482 if (ffe_is_pedantic ())
12483 {
12484 error = TRUE;
12485 break;
12486 }
12487 /* Fall through. */
12488 case FFEINFO_basictypeHOLLERITH:
12489 case FFEINFO_basictypeTYPELESS:
12490 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12491 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12492 FFEEXPR_contextLET);
12493 /* Fall through. */
12494 case FFEINFO_basictypeINTEGER:
12495 case FFEINFO_basictypeREAL:
12496 error = FALSE;
12497 break;
12498
12499 default:
12500 error = TRUE;
12501 break;
12502 }
12503 break;
12504
12505 case FFEEXPR_contextSTOP:
12506 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12507 break;
12508 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12509 : ffeinfo_basictype (info))
12510 {
12511 case FFEINFO_basictypeINTEGER:
12512 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12513 break;
12514
12515 case FFEINFO_basictypeCHARACTER:
12516 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT);
12517 break;
12518
12519 case FFEINFO_basictypeHOLLERITH:
12520 case FFEINFO_basictypeTYPELESS:
12521 error = FALSE;
12522 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12523 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12524 FFEEXPR_contextLET);
12525 break;
12526
12527 case FFEINFO_basictypeNONE:
12528 error = FALSE;
12529 break;
12530
12531 default:
12532 error = TRUE;
12533 break;
12534 }
12535 if ((expr != NULL) && ((ffebld_op (expr) != FFEBLD_opCONTER)
12536 || (ffebld_conter_orig (expr) != NULL)))
12537 error = TRUE;
12538 break;
12539
12540 case FFEEXPR_contextINCLUDE:
12541 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12542 || (ffeinfo_basictype (info) != FFEINFO_basictypeCHARACTER)
12543 || (ffebld_op (expr) != FFEBLD_opCONTER)
12544 || (ffebld_conter_orig (expr) != NULL);
12545 break;
12546
12547 case FFEEXPR_contextSELECTCASE:
12548 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12549 break;
12550 switch (ffeinfo_basictype (info))
12551 {
12552 case FFEINFO_basictypeINTEGER:
12553 case FFEINFO_basictypeCHARACTER:
12554 case FFEINFO_basictypeLOGICAL:
12555 error = FALSE;
12556 break;
12557
12558 case FFEINFO_basictypeHOLLERITH:
12559 case FFEINFO_basictypeTYPELESS:
12560 error = FALSE;
12561 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12562 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12563 FFEEXPR_contextLET);
12564 break;
12565
12566 default:
12567 error = TRUE;
12568 break;
12569 }
12570 break;
12571
12572 case FFEEXPR_contextCASE:
12573 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12574 break;
12575 switch ((expr == NULL) ? FFEINFO_basictypeINTEGER
12576 : ffeinfo_basictype (info))
12577 {
12578 case FFEINFO_basictypeINTEGER:
12579 case FFEINFO_basictypeCHARACTER:
12580 case FFEINFO_basictypeLOGICAL:
12581 error = FALSE;
12582 break;
12583
12584 case FFEINFO_basictypeHOLLERITH:
12585 case FFEINFO_basictypeTYPELESS:
12586 error = FALSE;
12587 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12588 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12589 FFEEXPR_contextLET);
12590 break;
12591
12592 default:
12593 error = TRUE;
12594 break;
12595 }
12596 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12597 error = TRUE;
12598 break;
12599
12600 case FFEEXPR_contextCHARACTERSIZE:
12601 case FFEEXPR_contextKINDTYPE:
12602 case FFEEXPR_contextDIMLISTCOMMON:
12603 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12604 break;
12605 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12606 : ffeinfo_basictype (info))
12607 {
12608 case FFEINFO_basictypeLOGICAL:
12609 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12610 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12611 FFEEXPR_contextLET);
12612 /* Fall through. */
12613 case FFEINFO_basictypeREAL:
12614 case FFEINFO_basictypeCOMPLEX:
12615 if (ffe_is_pedantic ())
12616 {
12617 error = TRUE;
12618 break;
12619 }
12620 /* Fall through. */
12621 case FFEINFO_basictypeINTEGER:
12622 case FFEINFO_basictypeHOLLERITH:
12623 case FFEINFO_basictypeTYPELESS:
12624 error = FALSE;
12625 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12626 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12627 FFEEXPR_contextLET);
12628 break;
12629
12630 default:
12631 error = TRUE;
12632 break;
12633 }
12634 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12635 error = TRUE;
12636 break;
12637
12638 case FFEEXPR_contextEQVINDEX_:
12639 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12640 break;
12641 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12642 : ffeinfo_basictype (info))
12643 {
12644 case FFEINFO_basictypeNONE:
12645 error = FALSE;
12646 break;
12647
12648 case FFEINFO_basictypeLOGICAL:
12649 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12650 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12651 FFEEXPR_contextLET);
12652 /* Fall through. */
12653 case FFEINFO_basictypeREAL:
12654 case FFEINFO_basictypeCOMPLEX:
12655 if (ffe_is_pedantic ())
12656 {
12657 error = TRUE;
12658 break;
12659 }
12660 /* Fall through. */
12661 case FFEINFO_basictypeINTEGER:
12662 case FFEINFO_basictypeHOLLERITH:
12663 case FFEINFO_basictypeTYPELESS:
12664 error = FALSE;
12665 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12666 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12667 FFEEXPR_contextLET);
12668 break;
12669
12670 default:
12671 error = TRUE;
12672 break;
12673 }
12674 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12675 error = TRUE;
12676 break;
12677
12678 case FFEEXPR_contextPARAMETER:
12679 if (ffeexpr_stack_->is_rhs)
12680 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12681 || (ffebld_op (expr) != FFEBLD_opCONTER);
12682 else
12683 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12684 || (ffebld_op (expr) != FFEBLD_opSYMTER);
12685 break;
12686
12687 case FFEEXPR_contextINDEXORACTUALARG_:
12688 if (ffelex_token_type (t) == FFELEX_typeCOLON)
12689 ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
12690 else
12691 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
12692 goto again; /* :::::::::::::::::::: */
12693
12694 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
12695 if (ffelex_token_type (t) == FFELEX_typeCOLON)
12696 ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
12697 else
12698 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
12699 goto again; /* :::::::::::::::::::: */
12700
12701 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
12702 if (ffelex_token_type (t) == FFELEX_typeCOLON)
12703 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
12704 else
12705 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
12706 goto again; /* :::::::::::::::::::: */
12707
12708 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
12709 if (ffelex_token_type (t) == FFELEX_typeCOLON)
12710 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
12711 else
12712 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
12713 goto again; /* :::::::::::::::::::: */
12714
12715 case FFEEXPR_contextIMPDOCTRL_:
12716 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12717 break;
12718 if (!ffeexpr_stack_->is_rhs
12719 && (ffebld_op (expr) != FFEBLD_opSYMTER))
12720 error = TRUE;
12721 switch (ffeinfo_basictype (info))
12722 {
12723 case FFEINFO_basictypeLOGICAL:
12724 if (! ffe_is_ugly_logint ())
12725 error = TRUE;
12726 if (! ffeexpr_stack_->is_rhs)
12727 break;
12728 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12729 ffeinfo_kindtype (info), 0,
12730 FFETARGET_charactersizeNONE,
12731 FFEEXPR_contextLET);
12732 break;
12733
12734 case FFEINFO_basictypeINTEGER:
12735 case FFEINFO_basictypeHOLLERITH:
12736 case FFEINFO_basictypeTYPELESS:
12737 break;
12738
12739 case FFEINFO_basictypeREAL:
12740 if (!ffeexpr_stack_->is_rhs
12741 && ffe_is_warn_surprising ()
12742 && !error)
12743 {
12744 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
12745 ffebad_here (0, ffelex_token_where_line (ft),
12746 ffelex_token_where_column (ft));
12747 ffebad_string (ffelex_token_text (ft));
12748 ffebad_finish ();
12749 }
12750 break;
12751
12752 default:
12753 error = TRUE;
12754 break;
12755 }
12756 break;
12757
12758 case FFEEXPR_contextDATAIMPDOCTRL_:
12759 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12760 break;
12761 if (ffeexpr_stack_->is_rhs)
12762 {
12763 if ((ffebld_op (expr) != FFEBLD_opCONTER)
12764 && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12765 error = TRUE;
12766 }
12767 else if ((ffebld_op (expr) != FFEBLD_opSYMTER)
12768 || (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12769 error = TRUE;
12770 switch (ffeinfo_basictype (info))
12771 {
12772 case FFEINFO_basictypeLOGICAL:
12773 if (! ffeexpr_stack_->is_rhs)
12774 break;
12775 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12776 ffeinfo_kindtype (info), 0,
12777 FFETARGET_charactersizeNONE,
12778 FFEEXPR_contextLET);
12779 /* Fall through. */
12780 case FFEINFO_basictypeINTEGER:
12781 if (ffeexpr_stack_->is_rhs
12782 && (ffeinfo_kindtype (ffebld_info (expr))
12783 != FFEINFO_kindtypeINTEGERDEFAULT))
12784 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12785 FFEINFO_kindtypeINTEGERDEFAULT, 0,
12786 FFETARGET_charactersizeNONE,
12787 FFEEXPR_contextLET);
12788 break;
12789
12790 case FFEINFO_basictypeHOLLERITH:
12791 case FFEINFO_basictypeTYPELESS:
12792 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12793 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12794 FFEEXPR_contextLET);
12795 break;
12796
12797 case FFEINFO_basictypeREAL:
12798 if (!ffeexpr_stack_->is_rhs
12799 && ffe_is_warn_surprising ()
12800 && !error)
12801 {
12802 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
12803 ffebad_here (0, ffelex_token_where_line (ft),
12804 ffelex_token_where_column (ft));
12805 ffebad_string (ffelex_token_text (ft));
12806 ffebad_finish ();
12807 }
12808 break;
12809
12810 default:
12811 error = TRUE;
12812 break;
12813 }
12814 break;
12815
12816 case FFEEXPR_contextIMPDOITEM_:
12817 if (ffelex_token_type (t) == FFELEX_typeEQUALS)
12818 {
12819 ffeexpr_stack_->is_rhs = FALSE;
12820 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
12821 goto again; /* :::::::::::::::::::: */
12822 }
12823 /* Fall through. */
12824 case FFEEXPR_contextIOLIST:
12825 case FFEEXPR_contextFILEVXTCODE:
12826 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12827 : ffeinfo_basictype (info))
12828 {
12829 case FFEINFO_basictypeHOLLERITH:
12830 case FFEINFO_basictypeTYPELESS:
12831 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12832 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12833 FFEEXPR_contextLET);
12834 break;
12835
12836 default:
12837 break;
12838 }
12839 error = (expr == NULL)
12840 || ((ffeinfo_rank (info) != 0)
12841 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12842 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12843 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12844 == FFEBLD_opSTAR))); /* Bad if null expr, or if
12845 array that is not a SYMTER
12846 (can't happen yet, I
12847 think) or has a NULL or
12848 STAR (assumed) array
12849 size. */
12850 break;
12851
12852 case FFEEXPR_contextIMPDOITEMDF_:
12853 if (ffelex_token_type (t) == FFELEX_typeEQUALS)
12854 {
12855 ffeexpr_stack_->is_rhs = FALSE;
12856 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
12857 goto again; /* :::::::::::::::::::: */
12858 }
12859 /* Fall through. */
12860 case FFEEXPR_contextIOLISTDF:
12861 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12862 : ffeinfo_basictype (info))
12863 {
12864 case FFEINFO_basictypeHOLLERITH:
12865 case FFEINFO_basictypeTYPELESS:
12866 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12867 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12868 FFEEXPR_contextLET);
12869 break;
12870
12871 default:
12872 break;
12873 }
12874 error
12875 = (expr == NULL)
12876 || ((ffeinfo_basictype (info) == FFEINFO_basictypeCHARACTER)
12877 && (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT))
12878 || ((ffeinfo_rank (info) != 0)
12879 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12880 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12881 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12882 == FFEBLD_opSTAR))); /* Bad if null expr,
12883 non-default-kindtype
12884 character expr, or if
12885 array that is not a SYMTER
12886 (can't happen yet, I
12887 think) or has a NULL or
12888 STAR (assumed) array
12889 size. */
12890 break;
12891
12892 case FFEEXPR_contextDATAIMPDOITEM_:
12893 error = (expr == NULL)
12894 || (ffebld_op (expr) != FFEBLD_opARRAYREF)
12895 || ((ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR)
12896 && (ffeinfo_where (info) != FFEINFO_whereFLEETING_IADDR));
12897 break;
12898
12899 case FFEEXPR_contextDATAIMPDOINDEX_:
12900 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12901 break;
12902 switch (ffeinfo_basictype (info))
12903 {
12904 case FFEINFO_basictypeLOGICAL:
12905 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12906 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12907 FFEEXPR_contextLET);
12908 /* Fall through. */
12909 case FFEINFO_basictypeREAL:
12910 case FFEINFO_basictypeCOMPLEX:
12911 if (ffe_is_pedantic ())
12912 {
12913 error = TRUE;
12914 break;
12915 }
12916 /* Fall through. */
12917 case FFEINFO_basictypeINTEGER:
12918 case FFEINFO_basictypeHOLLERITH:
12919 case FFEINFO_basictypeTYPELESS:
12920 error = FALSE;
12921 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12922 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12923 FFEEXPR_contextLET);
12924 break;
12925
12926 default:
12927 error = TRUE;
12928 break;
12929 }
12930 if ((ffeinfo_where (info) != FFEINFO_whereCONSTANT)
12931 && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12932 error = TRUE;
12933 break;
12934
12935 case FFEEXPR_contextDATA:
12936 if (expr == NULL)
12937 error = TRUE;
12938 else if (ffeexpr_stack_->is_rhs)
12939 error = (ffebld_op (expr) != FFEBLD_opCONTER);
12940 else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12941 error = FALSE;
12942 else
12943 error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12944 break;
12945
12946 case FFEEXPR_contextINITVAL:
12947 error = (expr == NULL) || (ffebld_op (expr) != FFEBLD_opCONTER);
12948 break;
12949
12950 case FFEEXPR_contextEQUIVALENCE:
12951 if (expr == NULL)
12952 error = TRUE;
12953 else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12954 error = FALSE;
12955 else
12956 error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12957 break;
12958
12959 case FFEEXPR_contextFILEASSOC:
12960 case FFEEXPR_contextFILEINT:
12961 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12962 : ffeinfo_basictype (info))
12963 {
12964 case FFEINFO_basictypeINTEGER:
12965 /* Maybe this should be supported someday, but, right now,
12966 g77 can't generate a call to libf2c to write to an
12967 integer other than the default size. */
12968 error = ((! ffeexpr_stack_->is_rhs)
12969 && ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12970 break;
12971
12972 default:
12973 error = TRUE;
12974 break;
12975 }
12976 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12977 error = TRUE;
12978 break;
12979
12980 case FFEEXPR_contextFILEDFINT:
12981 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12982 : ffeinfo_basictype (info))
12983 {
12984 case FFEINFO_basictypeINTEGER:
12985 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12986 break;
12987
12988 default:
12989 error = TRUE;
12990 break;
12991 }
12992 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12993 error = TRUE;
12994 break;
12995
12996 case FFEEXPR_contextFILELOG:
12997 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12998 : ffeinfo_basictype (info))
12999 {
13000 case FFEINFO_basictypeLOGICAL:
13001 error = FALSE;
13002 break;
13003
13004 default:
13005 error = TRUE;
13006 break;
13007 }
13008 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13009 error = TRUE;
13010 break;
13011
13012 case FFEEXPR_contextFILECHAR:
13013 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13014 : ffeinfo_basictype (info))
13015 {
13016 case FFEINFO_basictypeCHARACTER:
13017 error = FALSE;
13018 break;
13019
13020 default:
13021 error = TRUE;
13022 break;
13023 }
13024 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13025 error = TRUE;
13026 break;
13027
13028 case FFEEXPR_contextFILENUMCHAR:
13029 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
13030 break;
13031 switch (ffeinfo_basictype (info))
13032 {
13033 case FFEINFO_basictypeLOGICAL:
13034 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13035 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13036 FFEEXPR_contextLET);
13037 /* Fall through. */
13038 case FFEINFO_basictypeREAL:
13039 case FFEINFO_basictypeCOMPLEX:
13040 if (ffe_is_pedantic ())
13041 {
13042 error = TRUE;
13043 break;
13044 }
13045 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13046 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13047 FFEEXPR_contextLET);
13048 break;
13049
13050 case FFEINFO_basictypeINTEGER:
13051 case FFEINFO_basictypeCHARACTER:
13052 error = FALSE;
13053 break;
13054
13055 default:
13056 error = TRUE;
13057 break;
13058 }
13059 break;
13060
13061 case FFEEXPR_contextFILEDFCHAR:
13062 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
13063 break;
13064 switch (ffeinfo_basictype (info))
13065 {
13066 case FFEINFO_basictypeCHARACTER:
13067 error
13068 = (ffeinfo_kindtype (info)
13069 != FFEINFO_kindtypeCHARACTERDEFAULT);
13070 break;
13071
13072 default:
13073 error = TRUE;
13074 break;
13075 }
13076 if (!ffeexpr_stack_->is_rhs
13077 && (ffebld_op (expr) == FFEBLD_opSUBSTR))
13078 error = TRUE;
13079 break;
13080
13081 case FFEEXPR_contextFILEUNIT: /* See equiv code in _ambig_. */
13082 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13083 : ffeinfo_basictype (info))
13084 {
13085 case FFEINFO_basictypeLOGICAL:
13086 if ((error = (ffeinfo_rank (info) != 0)))
13087 break;
13088 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13089 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13090 FFEEXPR_contextLET);
13091 /* Fall through. */
13092 case FFEINFO_basictypeREAL:
13093 case FFEINFO_basictypeCOMPLEX:
13094 if ((error = (ffeinfo_rank (info) != 0)))
13095 break;
13096 if (ffe_is_pedantic ())
13097 {
13098 error = TRUE;
13099 break;
13100 }
13101 /* Fall through. */
13102 case FFEINFO_basictypeINTEGER:
13103 case FFEINFO_basictypeHOLLERITH:
13104 case FFEINFO_basictypeTYPELESS:
13105 if ((error = (ffeinfo_rank (info) != 0)))
13106 break;
13107 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13108 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13109 FFEEXPR_contextLET);
13110 break;
13111
13112 case FFEINFO_basictypeCHARACTER:
13113 switch (ffebld_op (expr))
13114 { /* As if _lhs had been called instead of
13115 _rhs. */
13116 case FFEBLD_opSYMTER:
13117 error
13118 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
13119 break;
13120
13121 case FFEBLD_opSUBSTR:
13122 error = (ffeinfo_where (ffebld_info (expr))
13123 == FFEINFO_whereCONSTANT_SUBOBJECT);
13124 break;
13125
13126 case FFEBLD_opARRAYREF:
13127 error = FALSE;
13128 break;
13129
13130 default:
13131 error = TRUE;
13132 break;
13133 }
13134 if (!error
13135 && ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
13136 || ((ffeinfo_rank (info) != 0)
13137 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
13138 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
13139 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
13140 == FFEBLD_opSTAR))))) /* Bad if
13141 non-default-kindtype
13142 character expr, or if
13143 array that is not a SYMTER
13144 (can't happen yet, I
13145 think), or has a NULL or
13146 STAR (assumed) array
13147 size. */
13148 error = TRUE;
13149 break;
13150
13151 default:
13152 error = TRUE;
13153 break;
13154 }
13155 break;
13156
13157 case FFEEXPR_contextFILEFORMAT:
13158 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13159 : ffeinfo_basictype (info))
13160 {
13161 case FFEINFO_basictypeINTEGER:
13162 error = (expr == NULL)
13163 || ((ffeinfo_rank (info) != 0) ?
13164 ffe_is_pedantic () /* F77 C5. */
13165 : (ffeinfo_kindtype (info) != ffecom_label_kind ()))
13166 || (ffebld_op (expr) != FFEBLD_opSYMTER);
13167 break;
13168
13169 case FFEINFO_basictypeLOGICAL:
13170 case FFEINFO_basictypeREAL:
13171 case FFEINFO_basictypeCOMPLEX:
13172 /* F77 C5 -- must be an array of hollerith. */
13173 error
13174 = ffe_is_pedantic ()
13175 || (ffeinfo_rank (info) == 0);
13176 break;
13177
13178 case FFEINFO_basictypeCHARACTER:
13179 if ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
13180 || ((ffeinfo_rank (info) != 0)
13181 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
13182 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
13183 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
13184 == FFEBLD_opSTAR)))) /* Bad if
13185 non-default-kindtype
13186 character expr, or if
13187 array that is not a SYMTER
13188 (can't happen yet, I
13189 think), or has a NULL or
13190 STAR (assumed) array
13191 size. */
13192 error = TRUE;
13193 else
13194 error = FALSE;
13195 break;
13196
13197 default:
13198 error = TRUE;
13199 break;
13200 }
13201 break;
13202
13203 case FFEEXPR_contextLOC_:
13204 /* See also ffeintrin_check_loc_. */
13205 if ((expr == NULL)
13206 || (ffeinfo_kind (info) != FFEINFO_kindENTITY)
13207 || ((ffebld_op (expr) != FFEBLD_opSYMTER)
13208 && (ffebld_op (expr) != FFEBLD_opSUBSTR)
13209 && (ffebld_op (expr) != FFEBLD_opARRAYREF)))
13210 error = TRUE;
13211 break;
13212
13213 default:
13214 error = FALSE;
13215 break;
13216 }
13217
13218 if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
13219 {
13220 ffebad_start (FFEBAD_EXPR_WRONG);
13221 ffebad_here (0, ffelex_token_where_line (ft),
13222 ffelex_token_where_column (ft));
13223 ffebad_finish ();
13224 expr = ffebld_new_any ();
13225 ffebld_set_info (expr, ffeinfo_new_any ());
13226 }
13227
13228 callback = ffeexpr_stack_->callback;
13229 s = ffeexpr_stack_->previous;
13230 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
13231 sizeof (*ffeexpr_stack_));
13232 ffeexpr_stack_ = s;
13233 next = (ffelexHandler) (*callback) (ft, expr, t);
13234 ffelex_token_kill (ft);
13235 return (ffelexHandler) next;
13236 }
13237
13238 /* ffeexpr_finished_ambig_ -- Check validity of ambiguous unit/form spec
13239
13240 ffebld expr;
13241 expr = ffeexpr_finished_ambig_(expr);
13242
13243 Replicates a bit of ffeexpr_finished_'s task when in a context
13244 of UNIT or FORMAT. */
13245
13246 static ffebld
13247 ffeexpr_finished_ambig_ (ffelexToken ft, ffebld expr)
13248 {
13249 ffeinfo info = ffebld_info (expr);
13250 bool error;
13251
13252 switch (ffeexpr_stack_->context)
13253 {
13254 case FFEEXPR_contextFILENUMAMBIG: /* Same as FILENUM in _finished_. */
13255 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13256 : ffeinfo_basictype (info))
13257 {
13258 case FFEINFO_basictypeLOGICAL:
13259 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13260 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13261 FFEEXPR_contextLET);
13262 /* Fall through. */
13263 case FFEINFO_basictypeREAL:
13264 case FFEINFO_basictypeCOMPLEX:
13265 if (ffe_is_pedantic ())
13266 {
13267 error = TRUE;
13268 break;
13269 }
13270 /* Fall through. */
13271 case FFEINFO_basictypeINTEGER:
13272 case FFEINFO_basictypeHOLLERITH:
13273 case FFEINFO_basictypeTYPELESS:
13274 error = FALSE;
13275 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13276 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13277 FFEEXPR_contextLET);
13278 break;
13279
13280 default:
13281 error = TRUE;
13282 break;
13283 }
13284 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13285 error = TRUE;
13286 break;
13287
13288 case FFEEXPR_contextFILEUNITAMBIG: /* Same as FILEUNIT in _finished_. */
13289 if ((expr != NULL) && (ffebld_op (expr) == FFEBLD_opSTAR))
13290 {
13291 error = FALSE;
13292 break;
13293 }
13294 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13295 : ffeinfo_basictype (info))
13296 {
13297 case FFEINFO_basictypeLOGICAL:
13298 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13299 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13300 FFEEXPR_contextLET);
13301 /* Fall through. */
13302 case FFEINFO_basictypeREAL:
13303 case FFEINFO_basictypeCOMPLEX:
13304 if (ffe_is_pedantic ())
13305 {
13306 error = TRUE;
13307 break;
13308 }
13309 /* Fall through. */
13310 case FFEINFO_basictypeINTEGER:
13311 case FFEINFO_basictypeHOLLERITH:
13312 case FFEINFO_basictypeTYPELESS:
13313 error = (ffeinfo_rank (info) != 0);
13314 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13315 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13316 FFEEXPR_contextLET);
13317 break;
13318
13319 case FFEINFO_basictypeCHARACTER:
13320 switch (ffebld_op (expr))
13321 { /* As if _lhs had been called instead of
13322 _rhs. */
13323 case FFEBLD_opSYMTER:
13324 error
13325 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
13326 break;
13327
13328 case FFEBLD_opSUBSTR:
13329 error = (ffeinfo_where (ffebld_info (expr))
13330 == FFEINFO_whereCONSTANT_SUBOBJECT);
13331 break;
13332
13333 case FFEBLD_opARRAYREF:
13334 error = FALSE;
13335 break;
13336
13337 default:
13338 error = TRUE;
13339 break;
13340 }
13341 break;
13342
13343 default:
13344 error = TRUE;
13345 break;
13346 }
13347 break;
13348
13349 default:
13350 assert ("bad context" == NULL);
13351 error = TRUE;
13352 break;
13353 }
13354
13355 if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
13356 {
13357 ffebad_start (FFEBAD_EXPR_WRONG);
13358 ffebad_here (0, ffelex_token_where_line (ft),
13359 ffelex_token_where_column (ft));
13360 ffebad_finish ();
13361 expr = ffebld_new_any ();
13362 ffebld_set_info (expr, ffeinfo_new_any ());
13363 }
13364
13365 return expr;
13366 }
13367
13368 /* ffeexpr_token_lhs_ -- Initial state for lhs expression
13369
13370 Return a pointer to this function to the lexer (ffelex), which will
13371 invoke it for the next token.
13372
13373 Basically a smaller version of _rhs_; keep them both in sync, of course. */
13374
13375 static ffelexHandler
13376 ffeexpr_token_lhs_ (ffelexToken t)
13377 {
13378
13379 /* When changing the list of valid initial lhs tokens, check whether to
13380 update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
13381 READ (expr) <token> case -- it assumes it knows which tokens <token> can
13382 be to indicate an lhs (or implied DO), which right now is the set
13383 {NAME,OPEN_PAREN}.
13384
13385 This comment also appears in ffeexpr_token_first_lhs_. */
13386
13387 switch (ffelex_token_type (t))
13388 {
13389 case FFELEX_typeNAME:
13390 case FFELEX_typeNAMES:
13391 ffeexpr_tokens_[0] = ffelex_token_use (t);
13392 return (ffelexHandler) ffeexpr_token_name_lhs_;
13393
13394 default:
13395 return (ffelexHandler) ffeexpr_finished_ (t);
13396 }
13397 }
13398
13399 /* ffeexpr_token_rhs_ -- Initial state for rhs expression
13400
13401 Return a pointer to this function to the lexer (ffelex), which will
13402 invoke it for the next token.
13403
13404 The initial state and the post-binary-operator state are the same and
13405 both handled here, with the expression stack used to distinguish
13406 between them. Binary operators are invalid here; unary operators,
13407 constants, subexpressions, and name references are valid. */
13408
13409 static ffelexHandler
13410 ffeexpr_token_rhs_ (ffelexToken t)
13411 {
13412 ffeexprExpr_ e;
13413
13414 switch (ffelex_token_type (t))
13415 {
13416 case FFELEX_typeQUOTE:
13417 if (ffe_is_vxt ())
13418 {
13419 ffeexpr_tokens_[0] = ffelex_token_use (t);
13420 return (ffelexHandler) ffeexpr_token_quote_;
13421 }
13422 ffeexpr_tokens_[0] = ffelex_token_use (t);
13423 ffelex_set_expecting_hollerith (-1, '\"',
13424 ffelex_token_where_line (t),
13425 ffelex_token_where_column (t));
13426 /* Don't have to unset this one. */
13427 return (ffelexHandler) ffeexpr_token_apostrophe_;
13428
13429 case FFELEX_typeAPOSTROPHE:
13430 ffeexpr_tokens_[0] = ffelex_token_use (t);
13431 ffelex_set_expecting_hollerith (-1, '\'',
13432 ffelex_token_where_line (t),
13433 ffelex_token_where_column (t));
13434 /* Don't have to unset this one. */
13435 return (ffelexHandler) ffeexpr_token_apostrophe_;
13436
13437 case FFELEX_typePERCENT:
13438 ffeexpr_tokens_[0] = ffelex_token_use (t);
13439 return (ffelexHandler) ffeexpr_token_percent_;
13440
13441 case FFELEX_typeOPEN_PAREN:
13442 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
13443 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
13444 FFEEXPR_contextPAREN_,
13445 ffeexpr_cb_close_paren_c_);
13446
13447 case FFELEX_typePLUS:
13448 e = ffeexpr_expr_new_ ();
13449 e->type = FFEEXPR_exprtypeUNARY_;
13450 e->token = ffelex_token_use (t);
13451 e->u.operator.op = FFEEXPR_operatorADD_;
13452 e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
13453 e->u.operator.as = FFEEXPR_operatorassociativityADD_;
13454 ffeexpr_exprstack_push_unary_ (e);
13455 return (ffelexHandler) ffeexpr_token_rhs_;
13456
13457 case FFELEX_typeMINUS:
13458 e = ffeexpr_expr_new_ ();
13459 e->type = FFEEXPR_exprtypeUNARY_;
13460 e->token = ffelex_token_use (t);
13461 e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
13462 e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
13463 e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
13464 ffeexpr_exprstack_push_unary_ (e);
13465 return (ffelexHandler) ffeexpr_token_rhs_;
13466
13467 case FFELEX_typePERIOD:
13468 ffeexpr_tokens_[0] = ffelex_token_use (t);
13469 return (ffelexHandler) ffeexpr_token_period_;
13470
13471 case FFELEX_typeNUMBER:
13472 ffeexpr_tokens_[0] = ffelex_token_use (t);
13473 ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
13474 if (ffeexpr_hollerith_count_ > 0)
13475 ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
13476 '\0',
13477 ffelex_token_where_line (t),
13478 ffelex_token_where_column (t));
13479 return (ffelexHandler) ffeexpr_token_number_;
13480
13481 case FFELEX_typeNAME:
13482 case FFELEX_typeNAMES:
13483 ffeexpr_tokens_[0] = ffelex_token_use (t);
13484 switch (ffeexpr_stack_->context)
13485 {
13486 case FFEEXPR_contextACTUALARG_:
13487 case FFEEXPR_contextINDEXORACTUALARG_:
13488 case FFEEXPR_contextSFUNCDEFACTUALARG_:
13489 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
13490 return (ffelexHandler) ffeexpr_token_name_arg_;
13491
13492 default:
13493 return (ffelexHandler) ffeexpr_token_name_rhs_;
13494 }
13495
13496 case FFELEX_typeASTERISK:
13497 case FFELEX_typeSLASH:
13498 case FFELEX_typePOWER:
13499 case FFELEX_typeCONCAT:
13500 case FFELEX_typeREL_EQ:
13501 case FFELEX_typeREL_NE:
13502 case FFELEX_typeREL_LE:
13503 case FFELEX_typeREL_GE:
13504 if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
13505 {
13506 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13507 ffebad_finish ();
13508 }
13509 return (ffelexHandler) ffeexpr_token_rhs_;
13510
13511 #if 0
13512 case FFELEX_typeEQUALS:
13513 case FFELEX_typePOINTS:
13514 case FFELEX_typeCLOSE_ANGLE:
13515 case FFELEX_typeCLOSE_PAREN:
13516 case FFELEX_typeCOMMA:
13517 case FFELEX_typeCOLON:
13518 case FFELEX_typeEOS:
13519 case FFELEX_typeSEMICOLON:
13520 #endif
13521 default:
13522 return (ffelexHandler) ffeexpr_finished_ (t);
13523 }
13524 }
13525
13526 /* ffeexpr_token_period_ -- Rhs PERIOD
13527
13528 Return a pointer to this function to the lexer (ffelex), which will
13529 invoke it for the next token.
13530
13531 Handle a period detected at rhs (expecting unary op or operand) state.
13532 Must begin a floating-point value (as in .12) or a dot-dot name, of
13533 which only .NOT., .TRUE., and .FALSE. are truly valid. Other sort-of-
13534 valid names represent binary operators, which are invalid here because
13535 there isn't an operand at the top of the stack. */
13536
13537 static ffelexHandler
13538 ffeexpr_token_period_ (ffelexToken t)
13539 {
13540 switch (ffelex_token_type (t))
13541 {
13542 case FFELEX_typeNAME:
13543 case FFELEX_typeNAMES:
13544 ffeexpr_current_dotdot_ = ffestr_other (t);
13545 switch (ffeexpr_current_dotdot_)
13546 {
13547 case FFESTR_otherNone:
13548 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
13549 {
13550 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13551 ffelex_token_where_column (ffeexpr_tokens_[0]));
13552 ffebad_finish ();
13553 }
13554 ffelex_token_kill (ffeexpr_tokens_[0]);
13555 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13556
13557 case FFESTR_otherTRUE:
13558 case FFESTR_otherFALSE:
13559 case FFESTR_otherNOT:
13560 ffeexpr_tokens_[1] = ffelex_token_use (t);
13561 return (ffelexHandler) ffeexpr_token_end_period_;
13562
13563 default:
13564 if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
13565 {
13566 ffebad_here (0, ffelex_token_where_line (t),
13567 ffelex_token_where_column (t));
13568 ffebad_finish ();
13569 }
13570 ffelex_token_kill (ffeexpr_tokens_[0]);
13571 return (ffelexHandler) ffeexpr_token_swallow_period_;
13572 }
13573 break; /* Nothing really reaches here. */
13574
13575 case FFELEX_typeNUMBER:
13576 ffeexpr_tokens_[1] = ffelex_token_use (t);
13577 return (ffelexHandler) ffeexpr_token_real_;
13578
13579 default:
13580 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
13581 {
13582 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13583 ffelex_token_where_column (ffeexpr_tokens_[0]));
13584 ffebad_finish ();
13585 }
13586 ffelex_token_kill (ffeexpr_tokens_[0]);
13587 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13588 }
13589 }
13590
13591 /* ffeexpr_token_end_period_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
13592
13593 Return a pointer to this function to the lexer (ffelex), which will
13594 invoke it for the next token.
13595
13596 Expecting a period to close a .NOT, .TRUE, or .FALSE at rhs (unary op
13597 or operator) state. If period isn't found, issue a diagnostic but
13598 pretend we saw one. ffeexpr_current_dotdot_ must already contained the
13599 dotdot representation of the name in between the two PERIOD tokens. */
13600
13601 static ffelexHandler
13602 ffeexpr_token_end_period_ (ffelexToken t)
13603 {
13604 ffeexprExpr_ e;
13605
13606 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13607 {
13608 if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
13609 {
13610 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13611 ffelex_token_where_column (ffeexpr_tokens_[0]));
13612 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13613 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
13614 ffebad_finish ();
13615 }
13616 }
13617
13618 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill "NOT"/"TRUE"/"FALSE"
13619 token. */
13620
13621 e = ffeexpr_expr_new_ ();
13622 e->token = ffeexpr_tokens_[0];
13623
13624 switch (ffeexpr_current_dotdot_)
13625 {
13626 case FFESTR_otherNOT:
13627 e->type = FFEEXPR_exprtypeUNARY_;
13628 e->u.operator.op = FFEEXPR_operatorNOT_;
13629 e->u.operator.prec = FFEEXPR_operatorprecedenceNOT_;
13630 e->u.operator.as = FFEEXPR_operatorassociativityNOT_;
13631 ffeexpr_exprstack_push_unary_ (e);
13632 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13633 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13634 return (ffelexHandler) ffeexpr_token_rhs_;
13635
13636 case FFESTR_otherTRUE:
13637 e->type = FFEEXPR_exprtypeOPERAND_;
13638 e->u.operand
13639 = ffebld_new_conter (ffebld_constant_new_logicaldefault (TRUE));
13640 ffebld_set_info (e->u.operand,
13641 ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
13642 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13643 ffeexpr_exprstack_push_operand_ (e);
13644 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13645 return (ffelexHandler) ffeexpr_token_binary_ (t);
13646 return (ffelexHandler) ffeexpr_token_binary_;
13647
13648 case FFESTR_otherFALSE:
13649 e->type = FFEEXPR_exprtypeOPERAND_;
13650 e->u.operand
13651 = ffebld_new_conter (ffebld_constant_new_logicaldefault (FALSE));
13652 ffebld_set_info (e->u.operand,
13653 ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
13654 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13655 ffeexpr_exprstack_push_operand_ (e);
13656 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13657 return (ffelexHandler) ffeexpr_token_binary_ (t);
13658 return (ffelexHandler) ffeexpr_token_binary_;
13659
13660 default:
13661 assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL);
13662 exit (0);
13663 return NULL;
13664 }
13665 }
13666
13667 /* ffeexpr_token_swallow_period_ -- Rhs PERIOD NAME(not NOT, TRUE, or FALSE)
13668
13669 Return a pointer to this function to the lexer (ffelex), which will
13670 invoke it for the next token.
13671
13672 A diagnostic has already been issued; just swallow a period if there is
13673 one, then continue with ffeexpr_token_rhs_. */
13674
13675 static ffelexHandler
13676 ffeexpr_token_swallow_period_ (ffelexToken t)
13677 {
13678 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13679 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13680
13681 return (ffelexHandler) ffeexpr_token_rhs_;
13682 }
13683
13684 /* ffeexpr_token_real_ -- Rhs PERIOD NUMBER
13685
13686 Return a pointer to this function to the lexer (ffelex), which will
13687 invoke it for the next token.
13688
13689 After a period and a string of digits, check next token for possible
13690 exponent designation (D, E, or Q as first/only character) and continue
13691 real-number handling accordingly. Else form basic real constant, push
13692 onto expression stack, and enter binary state using current token (which,
13693 if it is a name not beginning with D, E, or Q, will certainly result
13694 in an error, but that's not for this routine to deal with). */
13695
13696 static ffelexHandler
13697 ffeexpr_token_real_ (ffelexToken t)
13698 {
13699 char d;
13700 const char *p;
13701
13702 if (((ffelex_token_type (t) != FFELEX_typeNAME)
13703 && (ffelex_token_type (t) != FFELEX_typeNAMES))
13704 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13705 'D', 'd')
13706 || ffesrc_char_match_init (d, 'E', 'e')
13707 || ffesrc_char_match_init (d, 'Q', 'q')))
13708 && ffeexpr_isdigits_ (++p)))
13709 {
13710 #if 0
13711 /* This code has been removed because it seems inconsistent to
13712 produce a diagnostic in this case, but not all of the other
13713 ones that look for an exponent and cannot recognize one. */
13714 if (((ffelex_token_type (t) == FFELEX_typeNAME)
13715 || (ffelex_token_type (t) == FFELEX_typeNAMES))
13716 && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
13717 {
13718 char bad[2];
13719
13720 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13721 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
13722 ffelex_token_where_column (ffeexpr_tokens_[0]));
13723 bad[0] = *(p - 1);
13724 bad[1] = '\0';
13725 ffebad_string (bad);
13726 ffebad_finish ();
13727 }
13728 #endif
13729 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13730 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13731 NULL, NULL, NULL);
13732
13733 ffelex_token_kill (ffeexpr_tokens_[0]);
13734 ffelex_token_kill (ffeexpr_tokens_[1]);
13735 return (ffelexHandler) ffeexpr_token_binary_ (t);
13736 }
13737
13738 /* Just exponent character by itself? In which case, PLUS or MINUS must
13739 surely be next, followed by a NUMBER token. */
13740
13741 if (*p == '\0')
13742 {
13743 ffeexpr_tokens_[2] = ffelex_token_use (t);
13744 return (ffelexHandler) ffeexpr_token_real_exponent_;
13745 }
13746
13747 ffeexpr_make_float_const_ (d, NULL, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13748 t, NULL, NULL);
13749
13750 ffelex_token_kill (ffeexpr_tokens_[0]);
13751 ffelex_token_kill (ffeexpr_tokens_[1]);
13752 return (ffelexHandler) ffeexpr_token_binary_;
13753 }
13754
13755 /* ffeexpr_token_real_exponent_ -- Rhs PERIOD NUMBER NAME(D, E, or Q)
13756
13757 Return a pointer to this function to the lexer (ffelex), which will
13758 invoke it for the next token.
13759
13760 Ensures this token is PLUS or MINUS, preserves it, goes to final state
13761 for real number (exponent digits). Else issues diagnostic, assumes a
13762 zero exponent field for number, passes token on to binary state as if
13763 previous token had been "E0" instead of "E", for example. */
13764
13765 static ffelexHandler
13766 ffeexpr_token_real_exponent_ (ffelexToken t)
13767 {
13768 if ((ffelex_token_type (t) != FFELEX_typePLUS)
13769 && (ffelex_token_type (t) != FFELEX_typeMINUS))
13770 {
13771 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13772 {
13773 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
13774 ffelex_token_where_column (ffeexpr_tokens_[2]));
13775 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13776 ffebad_finish ();
13777 }
13778
13779 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13780 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13781 NULL, NULL, NULL);
13782
13783 ffelex_token_kill (ffeexpr_tokens_[0]);
13784 ffelex_token_kill (ffeexpr_tokens_[1]);
13785 ffelex_token_kill (ffeexpr_tokens_[2]);
13786 return (ffelexHandler) ffeexpr_token_binary_ (t);
13787 }
13788
13789 ffeexpr_tokens_[3] = ffelex_token_use (t);
13790 return (ffelexHandler) ffeexpr_token_real_exp_sign_;
13791 }
13792
13793 /* ffeexpr_token_real_exp_sign_ -- Rhs PERIOD NUMBER NAME(D,E,Q) PLUS/MINUS
13794
13795 Return a pointer to this function to the lexer (ffelex), which will
13796 invoke it for the next token.
13797
13798 Make sure token is a NUMBER, make a real constant out of all we have and
13799 push it onto the expression stack. Else issue diagnostic and pretend
13800 exponent field was a zero. */
13801
13802 static ffelexHandler
13803 ffeexpr_token_real_exp_sign_ (ffelexToken t)
13804 {
13805 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13806 {
13807 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13808 {
13809 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
13810 ffelex_token_where_column (ffeexpr_tokens_[2]));
13811 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13812 ffebad_finish ();
13813 }
13814
13815 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13816 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13817 NULL, NULL, NULL);
13818
13819 ffelex_token_kill (ffeexpr_tokens_[0]);
13820 ffelex_token_kill (ffeexpr_tokens_[1]);
13821 ffelex_token_kill (ffeexpr_tokens_[2]);
13822 ffelex_token_kill (ffeexpr_tokens_[3]);
13823 return (ffelexHandler) ffeexpr_token_binary_ (t);
13824 }
13825
13826 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0], NULL,
13827 ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2],
13828 ffeexpr_tokens_[3], t);
13829
13830 ffelex_token_kill (ffeexpr_tokens_[0]);
13831 ffelex_token_kill (ffeexpr_tokens_[1]);
13832 ffelex_token_kill (ffeexpr_tokens_[2]);
13833 ffelex_token_kill (ffeexpr_tokens_[3]);
13834 return (ffelexHandler) ffeexpr_token_binary_;
13835 }
13836
13837 /* ffeexpr_token_number_ -- Rhs NUMBER
13838
13839 Return a pointer to this function to the lexer (ffelex), which will
13840 invoke it for the next token.
13841
13842 If the token is a period, we may have a floating-point number, or an
13843 integer followed by a dotdot binary operator. If the token is a name
13844 beginning with D, E, or Q, we definitely have a floating-point number.
13845 If the token is a hollerith constant, that's what we've got, so push
13846 it onto the expression stack and continue with the binary state.
13847
13848 Otherwise, we have an integer followed by something the binary state
13849 should be able to swallow. */
13850
13851 static ffelexHandler
13852 ffeexpr_token_number_ (ffelexToken t)
13853 {
13854 ffeexprExpr_ e;
13855 ffeinfo ni;
13856 char d;
13857 const char *p;
13858
13859 if (ffeexpr_hollerith_count_ > 0)
13860 ffelex_set_expecting_hollerith (0, '\0',
13861 ffewhere_line_unknown (),
13862 ffewhere_column_unknown ());
13863
13864 /* See if we've got a floating-point number here. */
13865
13866 switch (ffelex_token_type (t))
13867 {
13868 case FFELEX_typeNAME:
13869 case FFELEX_typeNAMES:
13870 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13871 'D', 'd')
13872 || ffesrc_char_match_init (d, 'E', 'e')
13873 || ffesrc_char_match_init (d, 'Q', 'q'))
13874 && ffeexpr_isdigits_ (++p))
13875 {
13876
13877 /* Just exponent character by itself? In which case, PLUS or MINUS
13878 must surely be next, followed by a NUMBER token. */
13879
13880 if (*p == '\0')
13881 {
13882 ffeexpr_tokens_[1] = ffelex_token_use (t);
13883 return (ffelexHandler) ffeexpr_token_number_exponent_;
13884 }
13885 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], NULL, NULL, t,
13886 NULL, NULL);
13887
13888 ffelex_token_kill (ffeexpr_tokens_[0]);
13889 return (ffelexHandler) ffeexpr_token_binary_;
13890 }
13891 break;
13892
13893 case FFELEX_typePERIOD:
13894 ffeexpr_tokens_[1] = ffelex_token_use (t);
13895 return (ffelexHandler) ffeexpr_token_number_period_;
13896
13897 case FFELEX_typeHOLLERITH:
13898 e = ffeexpr_expr_new_ ();
13899 e->type = FFEEXPR_exprtypeOPERAND_;
13900 e->token = ffeexpr_tokens_[0];
13901 e->u.operand = ffebld_new_conter (ffebld_constant_new_hollerith (t));
13902 ni = ffeinfo_new (FFEINFO_basictypeHOLLERITH, FFEINFO_kindtypeNONE,
13903 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
13904 ffelex_token_length (t));
13905 ffebld_set_info (e->u.operand, ni);
13906 ffeexpr_exprstack_push_operand_ (e);
13907 return (ffelexHandler) ffeexpr_token_binary_;
13908
13909 default:
13910 break;
13911 }
13912
13913 /* Nothing specific we were looking for, so make an integer and pass the
13914 current token to the binary state. */
13915
13916 ffeexpr_make_float_const_ ('I', ffeexpr_tokens_[0], NULL, NULL,
13917 NULL, NULL, NULL);
13918 return (ffelexHandler) ffeexpr_token_binary_ (t);
13919 }
13920
13921 /* ffeexpr_token_number_exponent_ -- Rhs NUMBER NAME(D, E, or Q)
13922
13923 Return a pointer to this function to the lexer (ffelex), which will
13924 invoke it for the next token.
13925
13926 Ensures this token is PLUS or MINUS, preserves it, goes to final state
13927 for real number (exponent digits). Else treats number as integer, passes
13928 name to binary, passes current token to subsequent handler. */
13929
13930 static ffelexHandler
13931 ffeexpr_token_number_exponent_ (ffelexToken t)
13932 {
13933 if ((ffelex_token_type (t) != FFELEX_typePLUS)
13934 && (ffelex_token_type (t) != FFELEX_typeMINUS))
13935 {
13936 ffeexprExpr_ e;
13937 ffelexHandler nexthandler;
13938
13939 e = ffeexpr_expr_new_ ();
13940 e->type = FFEEXPR_exprtypeOPERAND_;
13941 e->token = ffeexpr_tokens_[0];
13942 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
13943 (ffeexpr_tokens_[0]));
13944 ffebld_set_info (e->u.operand,
13945 ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT,
13946 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13947 ffeexpr_exprstack_push_operand_ (e);
13948 nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[1]);
13949 ffelex_token_kill (ffeexpr_tokens_[1]);
13950 return (ffelexHandler) (*nexthandler) (t);
13951 }
13952
13953 ffeexpr_tokens_[2] = ffelex_token_use (t);
13954 return (ffelexHandler) ffeexpr_token_number_exp_sign_;
13955 }
13956
13957 /* ffeexpr_token_number_exp_sign_ -- Rhs NUMBER NAME(D,E,Q) PLUS/MINUS
13958
13959 Return a pointer to this function to the lexer (ffelex), which will
13960 invoke it for the next token.
13961
13962 Make sure token is a NUMBER, make a real constant out of all we have and
13963 push it onto the expression stack. Else issue diagnostic and pretend
13964 exponent field was a zero. */
13965
13966 static ffelexHandler
13967 ffeexpr_token_number_exp_sign_ (ffelexToken t)
13968 {
13969 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13970 {
13971 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13972 {
13973 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[1]),
13974 ffelex_token_where_column (ffeexpr_tokens_[1]));
13975 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13976 ffebad_finish ();
13977 }
13978
13979 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
13980 ffeexpr_tokens_[0], NULL, NULL,
13981 ffeexpr_tokens_[1], ffeexpr_tokens_[2],
13982 NULL);
13983
13984 ffelex_token_kill (ffeexpr_tokens_[0]);
13985 ffelex_token_kill (ffeexpr_tokens_[1]);
13986 ffelex_token_kill (ffeexpr_tokens_[2]);
13987 return (ffelexHandler) ffeexpr_token_binary_ (t);
13988 }
13989
13990 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
13991 ffeexpr_tokens_[0], NULL, NULL,
13992 ffeexpr_tokens_[1], ffeexpr_tokens_[2], t);
13993
13994 ffelex_token_kill (ffeexpr_tokens_[0]);
13995 ffelex_token_kill (ffeexpr_tokens_[1]);
13996 ffelex_token_kill (ffeexpr_tokens_[2]);
13997 return (ffelexHandler) ffeexpr_token_binary_;
13998 }
13999
14000 /* ffeexpr_token_number_period_ -- Rhs NUMBER PERIOD
14001
14002 Return a pointer to this function to the lexer (ffelex), which will
14003 invoke it for the next token.
14004
14005 Handle a period detected following a number at rhs state. Must begin a
14006 floating-point value (as in 1., 1.2, 1.E3, or 1.E+3) or a dot-dot name. */
14007
14008 static ffelexHandler
14009 ffeexpr_token_number_period_ (ffelexToken t)
14010 {
14011 ffeexprExpr_ e;
14012 ffelexHandler nexthandler;
14013 const char *p;
14014 char d;
14015
14016 switch (ffelex_token_type (t))
14017 {
14018 case FFELEX_typeNAME:
14019 case FFELEX_typeNAMES:
14020 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
14021 'D', 'd')
14022 || ffesrc_char_match_init (d, 'E', 'e')
14023 || ffesrc_char_match_init (d, 'Q', 'q'))
14024 && ffeexpr_isdigits_ (++p))
14025 {
14026
14027 /* Just exponent character by itself? In which case, PLUS or MINUS
14028 must surely be next, followed by a NUMBER token. */
14029
14030 if (*p == '\0')
14031 {
14032 ffeexpr_tokens_[2] = ffelex_token_use (t);
14033 return (ffelexHandler) ffeexpr_token_number_per_exp_;
14034 }
14035 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0],
14036 ffeexpr_tokens_[1], NULL, t, NULL,
14037 NULL);
14038
14039 ffelex_token_kill (ffeexpr_tokens_[0]);
14040 ffelex_token_kill (ffeexpr_tokens_[1]);
14041 return (ffelexHandler) ffeexpr_token_binary_;
14042 }
14043 /* A name not representing an exponent, so assume it will be something
14044 like EQ, make an integer from the number, pass the period to binary
14045 state and the current token to the resulting state. */
14046
14047 e = ffeexpr_expr_new_ ();
14048 e->type = FFEEXPR_exprtypeOPERAND_;
14049 e->token = ffeexpr_tokens_[0];
14050 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
14051 (ffeexpr_tokens_[0]));
14052 ffebld_set_info (e->u.operand,
14053 ffeinfo_new (FFEINFO_basictypeINTEGER,
14054 FFEINFO_kindtypeINTEGERDEFAULT, 0,
14055 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14056 FFETARGET_charactersizeNONE));
14057 ffeexpr_exprstack_push_operand_ (e);
14058 nexthandler = (ffelexHandler) ffeexpr_token_binary_
14059 (ffeexpr_tokens_[1]);
14060 ffelex_token_kill (ffeexpr_tokens_[1]);
14061 return (ffelexHandler) (*nexthandler) (t);
14062
14063 case FFELEX_typeNUMBER:
14064 ffeexpr_tokens_[2] = ffelex_token_use (t);
14065 return (ffelexHandler) ffeexpr_token_number_real_;
14066
14067 default:
14068 break;
14069 }
14070
14071 /* Nothing specific we were looking for, so make a real number and pass the
14072 period and then the current token to the binary state. */
14073
14074 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14075 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14076 NULL, NULL, NULL, NULL);
14077
14078 ffelex_token_kill (ffeexpr_tokens_[0]);
14079 ffelex_token_kill (ffeexpr_tokens_[1]);
14080 return (ffelexHandler) ffeexpr_token_binary_ (t);
14081 }
14082
14083 /* ffeexpr_token_number_per_exp_ -- Rhs NUMBER PERIOD NAME(D, E, or Q)
14084
14085 Return a pointer to this function to the lexer (ffelex), which will
14086 invoke it for the next token.
14087
14088 Ensures this token is PLUS or MINUS, preserves it, goes to final state
14089 for real number (exponent digits). Else treats number as real, passes
14090 name to binary, passes current token to subsequent handler. */
14091
14092 static ffelexHandler
14093 ffeexpr_token_number_per_exp_ (ffelexToken t)
14094 {
14095 if ((ffelex_token_type (t) != FFELEX_typePLUS)
14096 && (ffelex_token_type (t) != FFELEX_typeMINUS))
14097 {
14098 ffelexHandler nexthandler;
14099
14100 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14101 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14102 NULL, NULL, NULL, NULL);
14103
14104 ffelex_token_kill (ffeexpr_tokens_[0]);
14105 ffelex_token_kill (ffeexpr_tokens_[1]);
14106 nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[2]);
14107 ffelex_token_kill (ffeexpr_tokens_[2]);
14108 return (ffelexHandler) (*nexthandler) (t);
14109 }
14110
14111 ffeexpr_tokens_[3] = ffelex_token_use (t);
14112 return (ffelexHandler) ffeexpr_token_num_per_exp_sign_;
14113 }
14114
14115 /* ffeexpr_token_number_real_ -- Rhs NUMBER PERIOD NUMBER
14116
14117 Return a pointer to this function to the lexer (ffelex), which will
14118 invoke it for the next token.
14119
14120 After a number, period, and number, check next token for possible
14121 exponent designation (D, E, or Q as first/only character) and continue
14122 real-number handling accordingly. Else form basic real constant, push
14123 onto expression stack, and enter binary state using current token (which,
14124 if it is a name not beginning with D, E, or Q, will certainly result
14125 in an error, but that's not for this routine to deal with). */
14126
14127 static ffelexHandler
14128 ffeexpr_token_number_real_ (ffelexToken t)
14129 {
14130 char d;
14131 const char *p;
14132
14133 if (((ffelex_token_type (t) != FFELEX_typeNAME)
14134 && (ffelex_token_type (t) != FFELEX_typeNAMES))
14135 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
14136 'D', 'd')
14137 || ffesrc_char_match_init (d, 'E', 'e')
14138 || ffesrc_char_match_init (d, 'Q', 'q')))
14139 && ffeexpr_isdigits_ (++p)))
14140 {
14141 #if 0
14142 /* This code has been removed because it seems inconsistent to
14143 produce a diagnostic in this case, but not all of the other
14144 ones that look for an exponent and cannot recognize one. */
14145 if (((ffelex_token_type (t) == FFELEX_typeNAME)
14146 || (ffelex_token_type (t) == FFELEX_typeNAMES))
14147 && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
14148 {
14149 char bad[2];
14150
14151 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14152 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
14153 ffelex_token_where_column (ffeexpr_tokens_[0]));
14154 bad[0] = *(p - 1);
14155 bad[1] = '\0';
14156 ffebad_string (bad);
14157 ffebad_finish ();
14158 }
14159 #endif
14160 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14161 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14162 ffeexpr_tokens_[2], NULL, NULL, NULL);
14163
14164 ffelex_token_kill (ffeexpr_tokens_[0]);
14165 ffelex_token_kill (ffeexpr_tokens_[1]);
14166 ffelex_token_kill (ffeexpr_tokens_[2]);
14167 return (ffelexHandler) ffeexpr_token_binary_ (t);
14168 }
14169
14170 /* Just exponent character by itself? In which case, PLUS or MINUS must
14171 surely be next, followed by a NUMBER token. */
14172
14173 if (*p == '\0')
14174 {
14175 ffeexpr_tokens_[3] = ffelex_token_use (t);
14176 return (ffelexHandler) ffeexpr_token_number_real_exp_;
14177 }
14178
14179 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14180 ffeexpr_tokens_[2], t, NULL, NULL);
14181
14182 ffelex_token_kill (ffeexpr_tokens_[0]);
14183 ffelex_token_kill (ffeexpr_tokens_[1]);
14184 ffelex_token_kill (ffeexpr_tokens_[2]);
14185 return (ffelexHandler) ffeexpr_token_binary_;
14186 }
14187
14188 /* ffeexpr_token_num_per_exp_sign_ -- Rhs NUMBER PERIOD NAME(D,E,Q) PLUS/MINUS
14189
14190 Return a pointer to this function to the lexer (ffelex), which will
14191 invoke it for the next token.
14192
14193 Make sure token is a NUMBER, make a real constant out of all we have and
14194 push it onto the expression stack. Else issue diagnostic and pretend
14195 exponent field was a zero. */
14196
14197 static ffelexHandler
14198 ffeexpr_token_num_per_exp_sign_ (ffelexToken t)
14199 {
14200 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14201 {
14202 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14203 {
14204 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
14205 ffelex_token_where_column (ffeexpr_tokens_[2]));
14206 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14207 ffebad_finish ();
14208 }
14209
14210 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14211 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14212 NULL, NULL, NULL, NULL);
14213
14214 ffelex_token_kill (ffeexpr_tokens_[0]);
14215 ffelex_token_kill (ffeexpr_tokens_[1]);
14216 ffelex_token_kill (ffeexpr_tokens_[2]);
14217 ffelex_token_kill (ffeexpr_tokens_[3]);
14218 return (ffelexHandler) ffeexpr_token_binary_ (t);
14219 }
14220
14221 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0],
14222 ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL,
14223 ffeexpr_tokens_[2], ffeexpr_tokens_[3], t);
14224
14225 ffelex_token_kill (ffeexpr_tokens_[0]);
14226 ffelex_token_kill (ffeexpr_tokens_[1]);
14227 ffelex_token_kill (ffeexpr_tokens_[2]);
14228 ffelex_token_kill (ffeexpr_tokens_[3]);
14229 return (ffelexHandler) ffeexpr_token_binary_;
14230 }
14231
14232 /* ffeexpr_token_number_real_exp_ -- Rhs NUMBER PERIOD NUMBER NAME(D, E, or Q)
14233
14234 Return a pointer to this function to the lexer (ffelex), which will
14235 invoke it for the next token.
14236
14237 Ensures this token is PLUS or MINUS, preserves it, goes to final state
14238 for real number (exponent digits). Else issues diagnostic, assumes a
14239 zero exponent field for number, passes token on to binary state as if
14240 previous token had been "E0" instead of "E", for example. */
14241
14242 static ffelexHandler
14243 ffeexpr_token_number_real_exp_ (ffelexToken t)
14244 {
14245 if ((ffelex_token_type (t) != FFELEX_typePLUS)
14246 && (ffelex_token_type (t) != FFELEX_typeMINUS))
14247 {
14248 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14249 {
14250 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
14251 ffelex_token_where_column (ffeexpr_tokens_[3]));
14252 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14253 ffebad_finish ();
14254 }
14255
14256 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14257 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14258 ffeexpr_tokens_[2], NULL, NULL, NULL);
14259
14260 ffelex_token_kill (ffeexpr_tokens_[0]);
14261 ffelex_token_kill (ffeexpr_tokens_[1]);
14262 ffelex_token_kill (ffeexpr_tokens_[2]);
14263 ffelex_token_kill (ffeexpr_tokens_[3]);
14264 return (ffelexHandler) ffeexpr_token_binary_ (t);
14265 }
14266
14267 ffeexpr_tokens_[4] = ffelex_token_use (t);
14268 return (ffelexHandler) ffeexpr_token_num_real_exp_sn_;
14269 }
14270
14271 /* ffeexpr_token_num_real_exp_sn_ -- Rhs NUMBER PERIOD NUMBER NAME(D,E,Q)
14272 PLUS/MINUS
14273
14274 Return a pointer to this function to the lexer (ffelex), which will
14275 invoke it for the next token.
14276
14277 Make sure token is a NUMBER, make a real constant out of all we have and
14278 push it onto the expression stack. Else issue diagnostic and pretend
14279 exponent field was a zero. */
14280
14281 static ffelexHandler
14282 ffeexpr_token_num_real_exp_sn_ (ffelexToken t)
14283 {
14284 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14285 {
14286 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14287 {
14288 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
14289 ffelex_token_where_column (ffeexpr_tokens_[3]));
14290 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14291 ffebad_finish ();
14292 }
14293
14294 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14295 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14296 ffeexpr_tokens_[2], NULL, NULL, NULL);
14297
14298 ffelex_token_kill (ffeexpr_tokens_[0]);
14299 ffelex_token_kill (ffeexpr_tokens_[1]);
14300 ffelex_token_kill (ffeexpr_tokens_[2]);
14301 ffelex_token_kill (ffeexpr_tokens_[3]);
14302 ffelex_token_kill (ffeexpr_tokens_[4]);
14303 return (ffelexHandler) ffeexpr_token_binary_ (t);
14304 }
14305
14306 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[3])[0],
14307 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14308 ffeexpr_tokens_[2], ffeexpr_tokens_[3],
14309 ffeexpr_tokens_[4], t);
14310
14311 ffelex_token_kill (ffeexpr_tokens_[0]);
14312 ffelex_token_kill (ffeexpr_tokens_[1]);
14313 ffelex_token_kill (ffeexpr_tokens_[2]);
14314 ffelex_token_kill (ffeexpr_tokens_[3]);
14315 ffelex_token_kill (ffeexpr_tokens_[4]);
14316 return (ffelexHandler) ffeexpr_token_binary_;
14317 }
14318
14319 /* ffeexpr_token_binary_ -- Handle binary operator possibility
14320
14321 Return a pointer to this function to the lexer (ffelex), which will
14322 invoke it for the next token.
14323
14324 The possibility of a binary operator is handled here, meaning the previous
14325 token was an operand. */
14326
14327 static ffelexHandler
14328 ffeexpr_token_binary_ (ffelexToken t)
14329 {
14330 ffeexprExpr_ e;
14331
14332 if (!ffeexpr_stack_->is_rhs)
14333 return (ffelexHandler) ffeexpr_finished_ (t); /* For now. */
14334
14335 switch (ffelex_token_type (t))
14336 {
14337 case FFELEX_typePLUS:
14338 e = ffeexpr_expr_new_ ();
14339 e->type = FFEEXPR_exprtypeBINARY_;
14340 e->token = ffelex_token_use (t);
14341 e->u.operator.op = FFEEXPR_operatorADD_;
14342 e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
14343 e->u.operator.as = FFEEXPR_operatorassociativityADD_;
14344 ffeexpr_exprstack_push_binary_ (e);
14345 return (ffelexHandler) ffeexpr_token_rhs_;
14346
14347 case FFELEX_typeMINUS:
14348 e = ffeexpr_expr_new_ ();
14349 e->type = FFEEXPR_exprtypeBINARY_;
14350 e->token = ffelex_token_use (t);
14351 e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
14352 e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
14353 e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
14354 ffeexpr_exprstack_push_binary_ (e);
14355 return (ffelexHandler) ffeexpr_token_rhs_;
14356
14357 case FFELEX_typeASTERISK:
14358 switch (ffeexpr_stack_->context)
14359 {
14360 case FFEEXPR_contextDATA:
14361 return (ffelexHandler) ffeexpr_finished_ (t);
14362
14363 default:
14364 break;
14365 }
14366 e = ffeexpr_expr_new_ ();
14367 e->type = FFEEXPR_exprtypeBINARY_;
14368 e->token = ffelex_token_use (t);
14369 e->u.operator.op = FFEEXPR_operatorMULTIPLY_;
14370 e->u.operator.prec = FFEEXPR_operatorprecedenceMULTIPLY_;
14371 e->u.operator.as = FFEEXPR_operatorassociativityMULTIPLY_;
14372 ffeexpr_exprstack_push_binary_ (e);
14373 return (ffelexHandler) ffeexpr_token_rhs_;
14374
14375 case FFELEX_typeSLASH:
14376 switch (ffeexpr_stack_->context)
14377 {
14378 case FFEEXPR_contextDATA:
14379 return (ffelexHandler) ffeexpr_finished_ (t);
14380
14381 default:
14382 break;
14383 }
14384 e = ffeexpr_expr_new_ ();
14385 e->type = FFEEXPR_exprtypeBINARY_;
14386 e->token = ffelex_token_use (t);
14387 e->u.operator.op = FFEEXPR_operatorDIVIDE_;
14388 e->u.operator.prec = FFEEXPR_operatorprecedenceDIVIDE_;
14389 e->u.operator.as = FFEEXPR_operatorassociativityDIVIDE_;
14390 ffeexpr_exprstack_push_binary_ (e);
14391 return (ffelexHandler) ffeexpr_token_rhs_;
14392
14393 case FFELEX_typePOWER:
14394 e = ffeexpr_expr_new_ ();
14395 e->type = FFEEXPR_exprtypeBINARY_;
14396 e->token = ffelex_token_use (t);
14397 e->u.operator.op = FFEEXPR_operatorPOWER_;
14398 e->u.operator.prec = FFEEXPR_operatorprecedencePOWER_;
14399 e->u.operator.as = FFEEXPR_operatorassociativityPOWER_;
14400 ffeexpr_exprstack_push_binary_ (e);
14401 return (ffelexHandler) ffeexpr_token_rhs_;
14402
14403 case FFELEX_typeCONCAT:
14404 e = ffeexpr_expr_new_ ();
14405 e->type = FFEEXPR_exprtypeBINARY_;
14406 e->token = ffelex_token_use (t);
14407 e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
14408 e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
14409 e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
14410 ffeexpr_exprstack_push_binary_ (e);
14411 return (ffelexHandler) ffeexpr_token_rhs_;
14412
14413 case FFELEX_typeOPEN_ANGLE:
14414 switch (ffeexpr_stack_->context)
14415 {
14416 case FFEEXPR_contextFORMAT:
14417 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14418 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14419 ffebad_finish ();
14420 break;
14421
14422 default:
14423 break;
14424 }
14425 e = ffeexpr_expr_new_ ();
14426 e->type = FFEEXPR_exprtypeBINARY_;
14427 e->token = ffelex_token_use (t);
14428 e->u.operator.op = FFEEXPR_operatorLT_;
14429 e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
14430 e->u.operator.as = FFEEXPR_operatorassociativityLT_;
14431 ffeexpr_exprstack_push_binary_ (e);
14432 return (ffelexHandler) ffeexpr_token_rhs_;
14433
14434 case FFELEX_typeCLOSE_ANGLE:
14435 switch (ffeexpr_stack_->context)
14436 {
14437 case FFEEXPR_contextFORMAT:
14438 return ffeexpr_finished_ (t);
14439
14440 default:
14441 break;
14442 }
14443 e = ffeexpr_expr_new_ ();
14444 e->type = FFEEXPR_exprtypeBINARY_;
14445 e->token = ffelex_token_use (t);
14446 e->u.operator.op = FFEEXPR_operatorGT_;
14447 e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
14448 e->u.operator.as = FFEEXPR_operatorassociativityGT_;
14449 ffeexpr_exprstack_push_binary_ (e);
14450 return (ffelexHandler) ffeexpr_token_rhs_;
14451
14452 case FFELEX_typeREL_EQ:
14453 switch (ffeexpr_stack_->context)
14454 {
14455 case FFEEXPR_contextFORMAT:
14456 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14457 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14458 ffebad_finish ();
14459 break;
14460
14461 default:
14462 break;
14463 }
14464 e = ffeexpr_expr_new_ ();
14465 e->type = FFEEXPR_exprtypeBINARY_;
14466 e->token = ffelex_token_use (t);
14467 e->u.operator.op = FFEEXPR_operatorEQ_;
14468 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
14469 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
14470 ffeexpr_exprstack_push_binary_ (e);
14471 return (ffelexHandler) ffeexpr_token_rhs_;
14472
14473 case FFELEX_typeREL_NE:
14474 switch (ffeexpr_stack_->context)
14475 {
14476 case FFEEXPR_contextFORMAT:
14477 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14478 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14479 ffebad_finish ();
14480 break;
14481
14482 default:
14483 break;
14484 }
14485 e = ffeexpr_expr_new_ ();
14486 e->type = FFEEXPR_exprtypeBINARY_;
14487 e->token = ffelex_token_use (t);
14488 e->u.operator.op = FFEEXPR_operatorNE_;
14489 e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
14490 e->u.operator.as = FFEEXPR_operatorassociativityNE_;
14491 ffeexpr_exprstack_push_binary_ (e);
14492 return (ffelexHandler) ffeexpr_token_rhs_;
14493
14494 case FFELEX_typeREL_LE:
14495 switch (ffeexpr_stack_->context)
14496 {
14497 case FFEEXPR_contextFORMAT:
14498 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14499 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14500 ffebad_finish ();
14501 break;
14502
14503 default:
14504 break;
14505 }
14506 e = ffeexpr_expr_new_ ();
14507 e->type = FFEEXPR_exprtypeBINARY_;
14508 e->token = ffelex_token_use (t);
14509 e->u.operator.op = FFEEXPR_operatorLE_;
14510 e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
14511 e->u.operator.as = FFEEXPR_operatorassociativityLE_;
14512 ffeexpr_exprstack_push_binary_ (e);
14513 return (ffelexHandler) ffeexpr_token_rhs_;
14514
14515 case FFELEX_typeREL_GE:
14516 switch (ffeexpr_stack_->context)
14517 {
14518 case FFEEXPR_contextFORMAT:
14519 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14520 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14521 ffebad_finish ();
14522 break;
14523
14524 default:
14525 break;
14526 }
14527 e = ffeexpr_expr_new_ ();
14528 e->type = FFEEXPR_exprtypeBINARY_;
14529 e->token = ffelex_token_use (t);
14530 e->u.operator.op = FFEEXPR_operatorGE_;
14531 e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
14532 e->u.operator.as = FFEEXPR_operatorassociativityGE_;
14533 ffeexpr_exprstack_push_binary_ (e);
14534 return (ffelexHandler) ffeexpr_token_rhs_;
14535
14536 case FFELEX_typePERIOD:
14537 ffeexpr_tokens_[0] = ffelex_token_use (t);
14538 return (ffelexHandler) ffeexpr_token_binary_period_;
14539
14540 #if 0
14541 case FFELEX_typeOPEN_PAREN:
14542 case FFELEX_typeCLOSE_PAREN:
14543 case FFELEX_typeEQUALS:
14544 case FFELEX_typePOINTS:
14545 case FFELEX_typeCOMMA:
14546 case FFELEX_typeCOLON:
14547 case FFELEX_typeEOS:
14548 case FFELEX_typeSEMICOLON:
14549 case FFELEX_typeNAME:
14550 case FFELEX_typeNAMES:
14551 #endif
14552 default:
14553 return (ffelexHandler) ffeexpr_finished_ (t);
14554 }
14555 }
14556
14557 /* ffeexpr_token_binary_period_ -- Binary PERIOD
14558
14559 Return a pointer to this function to the lexer (ffelex), which will
14560 invoke it for the next token.
14561
14562 Handle a period detected at binary (expecting binary op or end) state.
14563 Must begin a dot-dot name, of which .NOT., .TRUE., and .FALSE. are not
14564 valid. */
14565
14566 static ffelexHandler
14567 ffeexpr_token_binary_period_ (ffelexToken t)
14568 {
14569 ffeexprExpr_ operand;
14570
14571 switch (ffelex_token_type (t))
14572 {
14573 case FFELEX_typeNAME:
14574 case FFELEX_typeNAMES:
14575 ffeexpr_current_dotdot_ = ffestr_other (t);
14576 switch (ffeexpr_current_dotdot_)
14577 {
14578 case FFESTR_otherTRUE:
14579 case FFESTR_otherFALSE:
14580 case FFESTR_otherNOT:
14581 if (ffest_ffebad_start (FFEBAD_MISSING_BINARY_OPERATOR))
14582 {
14583 operand = ffeexpr_stack_->exprstack;
14584 assert (operand != NULL);
14585 assert (operand->type == FFEEXPR_exprtypeOPERAND_);
14586 ffebad_here (0, ffelex_token_where_line (operand->token), ffelex_token_where_column (operand->token));
14587 ffebad_here (1, ffelex_token_where_line (t),
14588 ffelex_token_where_column (t));
14589 ffebad_finish ();
14590 }
14591 ffelex_token_kill (ffeexpr_tokens_[0]);
14592 return (ffelexHandler) ffeexpr_token_binary_sw_per_;
14593
14594 default:
14595 ffeexpr_tokens_[1] = ffelex_token_use (t);
14596 return (ffelexHandler) ffeexpr_token_binary_end_per_;
14597 }
14598 break; /* Nothing really reaches here. */
14599
14600 default:
14601 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
14602 {
14603 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14604 ffelex_token_where_column (ffeexpr_tokens_[0]));
14605 ffebad_finish ();
14606 }
14607 ffelex_token_kill (ffeexpr_tokens_[0]);
14608 return (ffelexHandler) ffeexpr_token_binary_ (t);
14609 }
14610 }
14611
14612 /* ffeexpr_token_binary_end_per_ -- Binary PERIOD NAME(not NOT, TRUE, or FALSE)
14613
14614 Return a pointer to this function to the lexer (ffelex), which will
14615 invoke it for the next token.
14616
14617 Expecting a period to close a dot-dot at binary (binary op
14618 or operator) state. If period isn't found, issue a diagnostic but
14619 pretend we saw one. ffeexpr_current_dotdot_ must already contained the
14620 dotdot representation of the name in between the two PERIOD tokens. */
14621
14622 static ffelexHandler
14623 ffeexpr_token_binary_end_per_ (ffelexToken t)
14624 {
14625 ffeexprExpr_ e;
14626
14627 e = ffeexpr_expr_new_ ();
14628 e->type = FFEEXPR_exprtypeBINARY_;
14629 e->token = ffeexpr_tokens_[0];
14630
14631 switch (ffeexpr_current_dotdot_)
14632 {
14633 case FFESTR_otherAND:
14634 e->u.operator.op = FFEEXPR_operatorAND_;
14635 e->u.operator.prec = FFEEXPR_operatorprecedenceAND_;
14636 e->u.operator.as = FFEEXPR_operatorassociativityAND_;
14637 break;
14638
14639 case FFESTR_otherOR:
14640 e->u.operator.op = FFEEXPR_operatorOR_;
14641 e->u.operator.prec = FFEEXPR_operatorprecedenceOR_;
14642 e->u.operator.as = FFEEXPR_operatorassociativityOR_;
14643 break;
14644
14645 case FFESTR_otherXOR:
14646 e->u.operator.op = FFEEXPR_operatorXOR_;
14647 e->u.operator.prec = FFEEXPR_operatorprecedenceXOR_;
14648 e->u.operator.as = FFEEXPR_operatorassociativityXOR_;
14649 break;
14650
14651 case FFESTR_otherEQV:
14652 e->u.operator.op = FFEEXPR_operatorEQV_;
14653 e->u.operator.prec = FFEEXPR_operatorprecedenceEQV_;
14654 e->u.operator.as = FFEEXPR_operatorassociativityEQV_;
14655 break;
14656
14657 case FFESTR_otherNEQV:
14658 e->u.operator.op = FFEEXPR_operatorNEQV_;
14659 e->u.operator.prec = FFEEXPR_operatorprecedenceNEQV_;
14660 e->u.operator.as = FFEEXPR_operatorassociativityNEQV_;
14661 break;
14662
14663 case FFESTR_otherLT:
14664 e->u.operator.op = FFEEXPR_operatorLT_;
14665 e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
14666 e->u.operator.as = FFEEXPR_operatorassociativityLT_;
14667 break;
14668
14669 case FFESTR_otherLE:
14670 e->u.operator.op = FFEEXPR_operatorLE_;
14671 e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
14672 e->u.operator.as = FFEEXPR_operatorassociativityLE_;
14673 break;
14674
14675 case FFESTR_otherEQ:
14676 e->u.operator.op = FFEEXPR_operatorEQ_;
14677 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
14678 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
14679 break;
14680
14681 case FFESTR_otherNE:
14682 e->u.operator.op = FFEEXPR_operatorNE_;
14683 e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
14684 e->u.operator.as = FFEEXPR_operatorassociativityNE_;
14685 break;
14686
14687 case FFESTR_otherGT:
14688 e->u.operator.op = FFEEXPR_operatorGT_;
14689 e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
14690 e->u.operator.as = FFEEXPR_operatorassociativityGT_;
14691 break;
14692
14693 case FFESTR_otherGE:
14694 e->u.operator.op = FFEEXPR_operatorGE_;
14695 e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
14696 e->u.operator.as = FFEEXPR_operatorassociativityGE_;
14697 break;
14698
14699 default:
14700 if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT))
14701 {
14702 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14703 ffelex_token_where_column (ffeexpr_tokens_[0]));
14704 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
14705 ffebad_finish ();
14706 }
14707 e->u.operator.op = FFEEXPR_operatorEQ_;
14708 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
14709 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
14710 break;
14711 }
14712
14713 ffeexpr_exprstack_push_binary_ (e);
14714
14715 if (ffelex_token_type (t) != FFELEX_typePERIOD)
14716 {
14717 if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
14718 {
14719 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14720 ffelex_token_where_column (ffeexpr_tokens_[0]));
14721 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14722 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
14723 ffebad_finish ();
14724 }
14725 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */
14726 return (ffelexHandler) ffeexpr_token_rhs_ (t);
14727 }
14728
14729 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */
14730 return (ffelexHandler) ffeexpr_token_rhs_;
14731 }
14732
14733 /* ffeexpr_token_binary_sw_per_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
14734
14735 Return a pointer to this function to the lexer (ffelex), which will
14736 invoke it for the next token.
14737
14738 A diagnostic has already been issued; just swallow a period if there is
14739 one, then continue with ffeexpr_token_binary_. */
14740
14741 static ffelexHandler
14742 ffeexpr_token_binary_sw_per_ (ffelexToken t)
14743 {
14744 if (ffelex_token_type (t) != FFELEX_typePERIOD)
14745 return (ffelexHandler) ffeexpr_token_binary_ (t);
14746
14747 return (ffelexHandler) ffeexpr_token_binary_;
14748 }
14749
14750 /* ffeexpr_token_quote_ -- Rhs QUOTE
14751
14752 Return a pointer to this function to the lexer (ffelex), which will
14753 invoke it for the next token.
14754
14755 Expecting a NUMBER that we'll treat as an octal integer. */
14756
14757 static ffelexHandler
14758 ffeexpr_token_quote_ (ffelexToken t)
14759 {
14760 ffeexprExpr_ e;
14761 ffebld anyexpr;
14762
14763 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14764 {
14765 if (ffest_ffebad_start (FFEBAD_QUOTE_MISSES_DIGITS))
14766 {
14767 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14768 ffelex_token_where_column (ffeexpr_tokens_[0]));
14769 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14770 ffebad_finish ();
14771 }
14772 ffelex_token_kill (ffeexpr_tokens_[0]);
14773 return (ffelexHandler) ffeexpr_token_rhs_ (t);
14774 }
14775
14776 /* This is kind of a kludge to prevent any whining about magical numbers
14777 that start out as these octal integers, so "20000000000 (on a 32-bit
14778 2's-complement machine) by itself won't produce an error. */
14779
14780 anyexpr = ffebld_new_any ();
14781 ffebld_set_info (anyexpr, ffeinfo_new_any ());
14782
14783 e = ffeexpr_expr_new_ ();
14784 e->type = FFEEXPR_exprtypeOPERAND_;
14785 e->token = ffeexpr_tokens_[0];
14786 e->u.operand = ffebld_new_conter_with_orig
14787 (ffebld_constant_new_integeroctal (t), anyexpr);
14788 ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER,
14789 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY,
14790 FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14791 ffeexpr_exprstack_push_operand_ (e);
14792 return (ffelexHandler) ffeexpr_token_binary_;
14793 }
14794
14795 /* ffeexpr_token_apostrophe_ -- Rhs APOSTROPHE
14796
14797 Return a pointer to this function to the lexer (ffelex), which will
14798 invoke it for the next token.
14799
14800 Handle an open-apostrophe, which begins either a character ('char-const'),
14801 typeless octal ('octal-const'O), or typeless hexadecimal ('hex-const'Z or
14802 'hex-const'X) constant. */
14803
14804 static ffelexHandler
14805 ffeexpr_token_apostrophe_ (ffelexToken t)
14806 {
14807 assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
14808 if (ffe_is_pedantic_not_90 () && (ffelex_token_length (t) == 0))
14809 {
14810 ffebad_start (FFEBAD_NULL_CHAR_CONST);
14811 ffebad_here (0, ffelex_token_where_line (t),
14812 ffelex_token_where_column (t));
14813 ffebad_finish ();
14814 }
14815 ffeexpr_tokens_[1] = ffelex_token_use (t);
14816 return (ffelexHandler) ffeexpr_token_apos_char_;
14817 }
14818
14819 /* ffeexpr_token_apos_char_ -- Rhs APOSTROPHE CHARACTER
14820
14821 Return a pointer to this function to the lexer (ffelex), which will
14822 invoke it for the next token.
14823
14824 Close-apostrophe is implicit; if this token is NAME, it is a possible
14825 typeless-constant radix specifier. */
14826
14827 static ffelexHandler
14828 ffeexpr_token_apos_char_ (ffelexToken t)
14829 {
14830 ffeexprExpr_ e;
14831 ffeinfo ni;
14832 char c;
14833 ffetargetCharacterSize size;
14834
14835 if ((ffelex_token_type (t) == FFELEX_typeNAME)
14836 || (ffelex_token_type (t) == FFELEX_typeNAMES))
14837 {
14838 if ((ffelex_token_length (t) == 1)
14839 && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]), 'B',
14840 'b')
14841 || ffesrc_char_match_init (c, 'O', 'o')
14842 || ffesrc_char_match_init (c, 'X', 'x')
14843 || ffesrc_char_match_init (c, 'Z', 'z')))
14844 {
14845 e = ffeexpr_expr_new_ ();
14846 e->type = FFEEXPR_exprtypeOPERAND_;
14847 e->token = ffeexpr_tokens_[0];
14848 switch (c)
14849 {
14850 case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
14851 e->u.operand = ffebld_new_conter
14852 (ffebld_constant_new_typeless_bv (ffeexpr_tokens_[1]));
14853 size = ffetarget_size_typeless_binary (ffeexpr_tokens_[1]);
14854 break;
14855
14856 case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
14857 e->u.operand = ffebld_new_conter
14858 (ffebld_constant_new_typeless_ov (ffeexpr_tokens_[1]));
14859 size = ffetarget_size_typeless_octal (ffeexpr_tokens_[1]);
14860 break;
14861
14862 case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
14863 e->u.operand = ffebld_new_conter
14864 (ffebld_constant_new_typeless_hxv (ffeexpr_tokens_[1]));
14865 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
14866 break;
14867
14868 case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
14869 e->u.operand = ffebld_new_conter
14870 (ffebld_constant_new_typeless_hzv (ffeexpr_tokens_[1]));
14871 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
14872 break;
14873
14874 default:
14875 no_match: /* :::::::::::::::::::: */
14876 assert ("not BOXZ!" == NULL);
14877 size = 0;
14878 break;
14879 }
14880 ffebld_set_info (e->u.operand,
14881 ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
14882 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
14883 ffeexpr_exprstack_push_operand_ (e);
14884 ffelex_token_kill (ffeexpr_tokens_[1]);
14885 return (ffelexHandler) ffeexpr_token_binary_;
14886 }
14887 }
14888 e = ffeexpr_expr_new_ ();
14889 e->type = FFEEXPR_exprtypeOPERAND_;
14890 e->token = ffeexpr_tokens_[0];
14891 e->u.operand = ffebld_new_conter (ffebld_constant_new_characterdefault
14892 (ffeexpr_tokens_[1]));
14893 ni = ffeinfo_new (FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTERDEFAULT,
14894 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14895 ffelex_token_length (ffeexpr_tokens_[1]));
14896 ffebld_set_info (e->u.operand, ni);
14897 ffelex_token_kill (ffeexpr_tokens_[1]);
14898 ffeexpr_exprstack_push_operand_ (e);
14899 if ((ffelex_token_type (t) == FFELEX_typeNAME)
14900 || (ffelex_token_type (t) == FFELEX_typeNAMES))
14901 {
14902 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14903 {
14904 ffebad_string (ffelex_token_text (t));
14905 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14906 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
14907 ffelex_token_where_column (ffeexpr_tokens_[0]));
14908 ffebad_finish ();
14909 }
14910 e = ffeexpr_expr_new_ ();
14911 e->type = FFEEXPR_exprtypeBINARY_;
14912 e->token = ffelex_token_use (t);
14913 e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
14914 e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
14915 e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
14916 ffeexpr_exprstack_push_binary_ (e);
14917 return (ffelexHandler) ffeexpr_token_rhs_ (t);
14918 }
14919 ffeexpr_is_substr_ok_ = !ffe_is_pedantic_not_90 (); /* Allow "'hello'(3:5)". */
14920 return (ffelexHandler) ffeexpr_token_substrp_ (t);
14921 }
14922
14923 /* ffeexpr_token_name_lhs_ -- Lhs NAME
14924
14925 Return a pointer to this function to the lexer (ffelex), which will
14926 invoke it for the next token.
14927
14928 Handle a name followed by open-paren, period (RECORD.MEMBER), percent
14929 (RECORD%MEMBER), or nothing at all. */
14930
14931 static ffelexHandler
14932 ffeexpr_token_name_lhs_ (ffelexToken t)
14933 {
14934 ffeexprExpr_ e;
14935 ffeexprParenType_ paren_type;
14936 ffesymbol s;
14937 ffebld expr;
14938 ffeinfo info;
14939
14940 switch (ffelex_token_type (t))
14941 {
14942 case FFELEX_typeOPEN_PAREN:
14943 switch (ffeexpr_stack_->context)
14944 {
14945 case FFEEXPR_contextASSIGN:
14946 case FFEEXPR_contextAGOTO:
14947 case FFEEXPR_contextFILEUNIT_DF:
14948 goto just_name; /* :::::::::::::::::::: */
14949
14950 default:
14951 break;
14952 }
14953 e = ffeexpr_expr_new_ ();
14954 e->type = FFEEXPR_exprtypeOPERAND_;
14955 e->token = ffelex_token_use (ffeexpr_tokens_[0]);
14956 s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], FALSE,
14957 &paren_type);
14958
14959 switch (ffesymbol_where (s))
14960 {
14961 case FFEINFO_whereLOCAL:
14962 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14963 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recursion. */
14964 break;
14965
14966 case FFEINFO_whereINTRINSIC:
14967 case FFEINFO_whereGLOBAL:
14968 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
14969 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */
14970 break;
14971
14972 case FFEINFO_whereCOMMON:
14973 case FFEINFO_whereDUMMY:
14974 case FFEINFO_whereRESULT:
14975 break;
14976
14977 case FFEINFO_whereNONE:
14978 case FFEINFO_whereANY:
14979 break;
14980
14981 default:
14982 ffesymbol_error (s, ffeexpr_tokens_[0]);
14983 break;
14984 }
14985
14986 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14987 {
14988 e->u.operand = ffebld_new_any ();
14989 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14990 }
14991 else
14992 {
14993 e->u.operand = ffebld_new_symter (s,
14994 ffesymbol_generic (s),
14995 ffesymbol_specific (s),
14996 ffesymbol_implementation (s));
14997 ffebld_set_info (e->u.operand, ffesymbol_info (s));
14998 }
14999 ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */
15000 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
15001 switch (paren_type)
15002 {
15003 case FFEEXPR_parentypeSUBROUTINE_:
15004 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15005 return
15006 (ffelexHandler)
15007 ffeexpr_rhs (ffeexpr_stack_->pool,
15008 FFEEXPR_contextACTUALARG_,
15009 ffeexpr_token_arguments_);
15010
15011 case FFEEXPR_parentypeARRAY_:
15012 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15013 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
15014 ffeexpr_stack_->rank = 0;
15015 ffeexpr_stack_->constant = TRUE;
15016 ffeexpr_stack_->immediate = TRUE;
15017 switch (ffeexpr_stack_->context)
15018 {
15019 case FFEEXPR_contextDATAIMPDOITEM_:
15020 return
15021 (ffelexHandler)
15022 ffeexpr_rhs (ffeexpr_stack_->pool,
15023 FFEEXPR_contextDATAIMPDOINDEX_,
15024 ffeexpr_token_elements_);
15025
15026 case FFEEXPR_contextEQUIVALENCE:
15027 return
15028 (ffelexHandler)
15029 ffeexpr_rhs (ffeexpr_stack_->pool,
15030 FFEEXPR_contextEQVINDEX_,
15031 ffeexpr_token_elements_);
15032
15033 default:
15034 return
15035 (ffelexHandler)
15036 ffeexpr_rhs (ffeexpr_stack_->pool,
15037 FFEEXPR_contextINDEX_,
15038 ffeexpr_token_elements_);
15039 }
15040
15041 case FFEEXPR_parentypeSUBSTRING_:
15042 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
15043 ffeexpr_tokens_[0]);
15044 return
15045 (ffelexHandler)
15046 ffeexpr_rhs (ffeexpr_stack_->pool,
15047 FFEEXPR_contextINDEX_,
15048 ffeexpr_token_substring_);
15049
15050 case FFEEXPR_parentypeEQUIVALENCE_:
15051 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15052 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
15053 ffeexpr_stack_->rank = 0;
15054 ffeexpr_stack_->constant = TRUE;
15055 ffeexpr_stack_->immediate = TRUE;
15056 return
15057 (ffelexHandler)
15058 ffeexpr_rhs (ffeexpr_stack_->pool,
15059 FFEEXPR_contextEQVINDEX_,
15060 ffeexpr_token_equivalence_);
15061
15062 case FFEEXPR_parentypeFUNCTION_: /* Invalid case. */
15063 case FFEEXPR_parentypeFUNSUBSTR_: /* Invalid case. */
15064 ffesymbol_error (s, ffeexpr_tokens_[0]);
15065 /* Fall through. */
15066 case FFEEXPR_parentypeANY_:
15067 e->u.operand = ffebld_new_any ();
15068 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15069 return
15070 (ffelexHandler)
15071 ffeexpr_rhs (ffeexpr_stack_->pool,
15072 FFEEXPR_contextACTUALARG_,
15073 ffeexpr_token_anything_);
15074
15075 default:
15076 assert ("bad paren type" == NULL);
15077 break;
15078 }
15079
15080 case FFELEX_typeEQUALS: /* As in "VAR=". */
15081 switch (ffeexpr_stack_->context)
15082 {
15083 case FFEEXPR_contextIMPDOITEM_: /* within
15084 "(,VAR=start,end[,incr])". */
15085 case FFEEXPR_contextIMPDOITEMDF_:
15086 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
15087 break;
15088
15089 case FFEEXPR_contextDATAIMPDOITEM_:
15090 ffeexpr_stack_->context = FFEEXPR_contextDATAIMPDOCTRL_;
15091 break;
15092
15093 default:
15094 break;
15095 }
15096 break;
15097
15098 #if 0
15099 case FFELEX_typePERIOD:
15100 case FFELEX_typePERCENT:
15101 assert ("FOO%, FOO. not yet supported!~~" == NULL);
15102 break;
15103 #endif
15104
15105 default:
15106 break;
15107 }
15108
15109 just_name: /* :::::::::::::::::::: */
15110 e = ffeexpr_expr_new_ ();
15111 e->type = FFEEXPR_exprtypeOPERAND_;
15112 e->token = ffeexpr_tokens_[0];
15113 s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0],
15114 (ffeexpr_stack_->context
15115 == FFEEXPR_contextSUBROUTINEREF));
15116
15117 switch (ffesymbol_where (s))
15118 {
15119 case FFEINFO_whereCONSTANT:
15120 if ((ffeexpr_stack_->context != FFEEXPR_contextPARAMETER)
15121 || (ffesymbol_kind (s) != FFEINFO_kindENTITY))
15122 ffesymbol_error (s, ffeexpr_tokens_[0]);
15123 break;
15124
15125 case FFEINFO_whereIMMEDIATE:
15126 if ((ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOCTRL_)
15127 && (ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOINDEX_))
15128 ffesymbol_error (s, ffeexpr_tokens_[0]);
15129 break;
15130
15131 case FFEINFO_whereLOCAL:
15132 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
15133 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recurse!. */
15134 break;
15135
15136 case FFEINFO_whereINTRINSIC:
15137 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
15138 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */
15139 break;
15140
15141 default:
15142 break;
15143 }
15144
15145 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15146 {
15147 expr = ffebld_new_any ();
15148 info = ffeinfo_new_any ();
15149 ffebld_set_info (expr, info);
15150 }
15151 else
15152 {
15153 expr = ffebld_new_symter (s,
15154 ffesymbol_generic (s),
15155 ffesymbol_specific (s),
15156 ffesymbol_implementation (s));
15157 info = ffesymbol_info (s);
15158 ffebld_set_info (expr, info);
15159 if (ffesymbol_is_doiter (s))
15160 {
15161 ffebad_start (FFEBAD_DOITER);
15162 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15163 ffelex_token_where_column (ffeexpr_tokens_[0]));
15164 ffest_ffebad_here_doiter (1, s);
15165 ffebad_string (ffesymbol_text (s));
15166 ffebad_finish ();
15167 }
15168 expr = ffeexpr_collapse_symter (expr, ffeexpr_tokens_[0]);
15169 }
15170
15171 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
15172 {
15173 if (ffebld_op (expr) == FFEBLD_opANY)
15174 {
15175 expr = ffebld_new_any ();
15176 ffebld_set_info (expr, ffeinfo_new_any ());
15177 }
15178 else
15179 {
15180 expr = ffebld_new_subrref (expr, NULL); /* No argument list. */
15181 if (ffesymbol_generic (s) != FFEINTRIN_genNONE)
15182 ffeintrin_fulfill_generic (&expr, &info, e->token);
15183 else if (ffesymbol_specific (s) != FFEINTRIN_specNONE)
15184 ffeintrin_fulfill_specific (&expr, &info, NULL, e->token);
15185 else
15186 ffeexpr_fulfill_call_ (&expr, e->token);
15187
15188 if (ffebld_op (expr) != FFEBLD_opANY)
15189 ffebld_set_info (expr,
15190 ffeinfo_new (ffeinfo_basictype (info),
15191 ffeinfo_kindtype (info),
15192 0,
15193 FFEINFO_kindENTITY,
15194 FFEINFO_whereFLEETING,
15195 ffeinfo_size (info)));
15196 else
15197 ffebld_set_info (expr, ffeinfo_new_any ());
15198 }
15199 }
15200
15201 e->u.operand = expr;
15202 ffeexpr_exprstack_push_operand_ (e);
15203 return (ffelexHandler) ffeexpr_finished_ (t);
15204 }
15205
15206 /* ffeexpr_token_name_arg_ -- Rhs NAME
15207
15208 Return a pointer to this function to the lexer (ffelex), which will
15209 invoke it for the next token.
15210
15211 Handle first token in an actual-arg (or possible actual-arg) context
15212 being a NAME, and use second token to refine the context. */
15213
15214 static ffelexHandler
15215 ffeexpr_token_name_arg_ (ffelexToken t)
15216 {
15217 switch (ffelex_token_type (t))
15218 {
15219 case FFELEX_typeCLOSE_PAREN:
15220 case FFELEX_typeCOMMA:
15221 switch (ffeexpr_stack_->context)
15222 {
15223 case FFEEXPR_contextINDEXORACTUALARG_:
15224 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
15225 break;
15226
15227 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15228 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
15229 break;
15230
15231 default:
15232 break;
15233 }
15234 break;
15235
15236 default:
15237 switch (ffeexpr_stack_->context)
15238 {
15239 case FFEEXPR_contextACTUALARG_:
15240 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
15241 break;
15242
15243 case FFEEXPR_contextINDEXORACTUALARG_:
15244 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
15245 break;
15246
15247 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15248 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
15249 break;
15250
15251 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15252 ffeexpr_stack_->context
15253 = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
15254 break;
15255
15256 default:
15257 assert ("bad context in _name_arg_" == NULL);
15258 break;
15259 }
15260 break;
15261 }
15262
15263 return (ffelexHandler) ffeexpr_token_name_rhs_ (t);
15264 }
15265
15266 /* ffeexpr_token_name_rhs_ -- Rhs NAME
15267
15268 Return a pointer to this function to the lexer (ffelex), which will
15269 invoke it for the next token.
15270
15271 Handle a name followed by open-paren, apostrophe (O'octal-const',
15272 Z'hex-const', or X'hex-const'), period (RECORD.MEMBER).
15273
15274 26-Nov-91 JCB 1.2
15275 When followed by apostrophe or quote, set lex hexnum flag on so
15276 [0-9] as first char of next token seen as starting a potentially
15277 hex number (NAME).
15278 04-Oct-91 JCB 1.1
15279 In case of intrinsic, decorate its SYMTER with the type info for
15280 the specific intrinsic. */
15281
15282 static ffelexHandler
15283 ffeexpr_token_name_rhs_ (ffelexToken t)
15284 {
15285 ffeexprExpr_ e;
15286 ffeexprParenType_ paren_type;
15287 ffesymbol s;
15288 bool sfdef;
15289
15290 switch (ffelex_token_type (t))
15291 {
15292 case FFELEX_typeQUOTE:
15293 case FFELEX_typeAPOSTROPHE:
15294 ffeexpr_tokens_[1] = ffelex_token_use (t);
15295 ffelex_set_hexnum (TRUE);
15296 return (ffelexHandler) ffeexpr_token_name_apos_;
15297
15298 case FFELEX_typeOPEN_PAREN:
15299 e = ffeexpr_expr_new_ ();
15300 e->type = FFEEXPR_exprtypeOPERAND_;
15301 e->token = ffelex_token_use (ffeexpr_tokens_[0]);
15302 s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], TRUE,
15303 &paren_type);
15304 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15305 e->u.operand = ffebld_new_any ();
15306 else
15307 e->u.operand = ffebld_new_symter (s, ffesymbol_generic (s),
15308 ffesymbol_specific (s),
15309 ffesymbol_implementation (s));
15310 ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */
15311 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
15312 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15313 {
15314 case FFEEXPR_contextSFUNCDEF:
15315 case FFEEXPR_contextSFUNCDEFINDEX_:
15316 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15317 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15318 sfdef = TRUE;
15319 break;
15320
15321 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15322 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15323 assert ("weird context!" == NULL);
15324 sfdef = FALSE;
15325 break;
15326
15327 default:
15328 sfdef = FALSE;
15329 break;
15330 }
15331 switch (paren_type)
15332 {
15333 case FFEEXPR_parentypeFUNCTION_:
15334 ffebld_set_info (e->u.operand, ffesymbol_info (s));
15335 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15336 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
15337 { /* A statement function. */
15338 ffeexpr_stack_->num_args
15339 = ffebld_list_length
15340 (ffeexpr_stack_->next_dummy
15341 = ffesymbol_dummyargs (s));
15342 ffeexpr_stack_->tokens[1] = NULL; /* !=NULL when > num_args. */
15343 }
15344 else if ((ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
15345 && !ffe_is_pedantic_not_90 ()
15346 && ((ffesymbol_implementation (s)
15347 == FFEINTRIN_impICHAR)
15348 || (ffesymbol_implementation (s)
15349 == FFEINTRIN_impIACHAR)
15350 || (ffesymbol_implementation (s)
15351 == FFEINTRIN_impLEN)))
15352 { /* Allow arbitrary concatenations. */
15353 return
15354 (ffelexHandler)
15355 ffeexpr_rhs (ffeexpr_stack_->pool,
15356 sfdef
15357 ? FFEEXPR_contextSFUNCDEF
15358 : FFEEXPR_contextLET,
15359 ffeexpr_token_arguments_);
15360 }
15361 return
15362 (ffelexHandler)
15363 ffeexpr_rhs (ffeexpr_stack_->pool,
15364 sfdef
15365 ? FFEEXPR_contextSFUNCDEFACTUALARG_
15366 : FFEEXPR_contextACTUALARG_,
15367 ffeexpr_token_arguments_);
15368
15369 case FFEEXPR_parentypeARRAY_:
15370 ffebld_set_info (e->u.operand,
15371 ffesymbol_info (ffebld_symter (e->u.operand)));
15372 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15373 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
15374 ffeexpr_stack_->rank = 0;
15375 ffeexpr_stack_->constant = TRUE;
15376 ffeexpr_stack_->immediate = TRUE;
15377 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
15378 sfdef
15379 ? FFEEXPR_contextSFUNCDEFINDEX_
15380 : FFEEXPR_contextINDEX_,
15381 ffeexpr_token_elements_);
15382
15383 case FFEEXPR_parentypeSUBSTRING_:
15384 ffebld_set_info (e->u.operand,
15385 ffesymbol_info (ffebld_symter (e->u.operand)));
15386 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
15387 ffeexpr_tokens_[0]);
15388 return
15389 (ffelexHandler)
15390 ffeexpr_rhs (ffeexpr_stack_->pool,
15391 sfdef
15392 ? FFEEXPR_contextSFUNCDEFINDEX_
15393 : FFEEXPR_contextINDEX_,
15394 ffeexpr_token_substring_);
15395
15396 case FFEEXPR_parentypeFUNSUBSTR_:
15397 return
15398 (ffelexHandler)
15399 ffeexpr_rhs (ffeexpr_stack_->pool,
15400 sfdef
15401 ? FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
15402 : FFEEXPR_contextINDEXORACTUALARG_,
15403 ffeexpr_token_funsubstr_);
15404
15405 case FFEEXPR_parentypeANY_:
15406 ffebld_set_info (e->u.operand, ffesymbol_info (s));
15407 return
15408 (ffelexHandler)
15409 ffeexpr_rhs (ffeexpr_stack_->pool,
15410 sfdef
15411 ? FFEEXPR_contextSFUNCDEFACTUALARG_
15412 : FFEEXPR_contextACTUALARG_,
15413 ffeexpr_token_anything_);
15414
15415 default:
15416 assert ("bad paren type" == NULL);
15417 break;
15418 }
15419
15420 case FFELEX_typeEQUALS: /* As in "VAR=". */
15421 switch (ffeexpr_stack_->context)
15422 {
15423 case FFEEXPR_contextIMPDOITEM_: /* "(,VAR=start,end[,incr])". */
15424 case FFEEXPR_contextIMPDOITEMDF_:
15425 ffeexpr_stack_->is_rhs = FALSE; /* Really an lhs construct. */
15426 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
15427 break;
15428
15429 default:
15430 break;
15431 }
15432 break;
15433
15434 #if 0
15435 case FFELEX_typePERIOD:
15436 case FFELEX_typePERCENT:
15437 ~~Support these two someday, though not required
15438 assert ("FOO%, FOO. not yet supported!~~" == NULL);
15439 break;
15440 #endif
15441
15442 default:
15443 break;
15444 }
15445
15446 switch (ffeexpr_stack_->context)
15447 {
15448 case FFEEXPR_contextINDEXORACTUALARG_:
15449 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15450 assert ("strange context" == NULL);
15451 break;
15452
15453 default:
15454 break;
15455 }
15456
15457 e = ffeexpr_expr_new_ ();
15458 e->type = FFEEXPR_exprtypeOPERAND_;
15459 e->token = ffeexpr_tokens_[0];
15460 s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0], FALSE);
15461 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15462 {
15463 e->u.operand = ffebld_new_any ();
15464 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15465 }
15466 else
15467 {
15468 e->u.operand = ffebld_new_symter (s, FFEINTRIN_genNONE,
15469 ffesymbol_specific (s),
15470 ffesymbol_implementation (s));
15471 if (ffesymbol_specific (s) == FFEINTRIN_specNONE)
15472 ffebld_set_info (e->u.operand, ffeinfo_use (ffesymbol_info (s)));
15473 else
15474 { /* Decorate the SYMTER with the actual type
15475 of the intrinsic. */
15476 ffebld_set_info (e->u.operand, ffeinfo_new
15477 (ffeintrin_basictype (ffesymbol_specific (s)),
15478 ffeintrin_kindtype (ffesymbol_specific (s)),
15479 0,
15480 ffesymbol_kind (s),
15481 ffesymbol_where (s),
15482 FFETARGET_charactersizeNONE));
15483 }
15484 if (ffesymbol_is_doiter (s))
15485 ffebld_symter_set_is_doiter (e->u.operand, TRUE);
15486 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
15487 ffeexpr_tokens_[0]);
15488 }
15489 ffeexpr_exprstack_push_operand_ (e);
15490 return (ffelexHandler) ffeexpr_token_binary_ (t);
15491 }
15492
15493 /* ffeexpr_token_name_apos_ -- Rhs NAME APOSTROPHE
15494
15495 Return a pointer to this function to the lexer (ffelex), which will
15496 invoke it for the next token.
15497
15498 Expecting a NAME token, analyze the previous NAME token to see what kind,
15499 if any, typeless constant we've got.
15500
15501 01-Sep-90 JCB 1.1
15502 Expect a NAME instead of CHARACTER in this situation. */
15503
15504 static ffelexHandler
15505 ffeexpr_token_name_apos_ (ffelexToken t)
15506 {
15507 ffeexprExpr_ e;
15508
15509 ffelex_set_hexnum (FALSE);
15510
15511 switch (ffelex_token_type (t))
15512 {
15513 case FFELEX_typeNAME:
15514 ffeexpr_tokens_[2] = ffelex_token_use (t);
15515 return (ffelexHandler) ffeexpr_token_name_apos_name_;
15516
15517 default:
15518 break;
15519 }
15520
15521 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
15522 {
15523 ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
15524 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15525 ffelex_token_where_column (ffeexpr_tokens_[0]));
15526 ffebad_here (1, ffelex_token_where_line (t),
15527 ffelex_token_where_column (t));
15528 ffebad_finish ();
15529 }
15530
15531 ffelex_token_kill (ffeexpr_tokens_[1]);
15532
15533 e = ffeexpr_expr_new_ ();
15534 e->type = FFEEXPR_exprtypeOPERAND_;
15535 e->u.operand = ffebld_new_any ();
15536 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15537 e->token = ffeexpr_tokens_[0];
15538 ffeexpr_exprstack_push_operand_ (e);
15539
15540 return (ffelexHandler) ffeexpr_token_binary_ (t);
15541 }
15542
15543 /* ffeexpr_token_name_apos_name_ -- Rhs NAME APOSTROPHE NAME
15544
15545 Return a pointer to this function to the lexer (ffelex), which will
15546 invoke it for the next token.
15547
15548 Expecting an APOSTROPHE token, analyze the previous NAME token to see
15549 what kind, if any, typeless constant we've got. */
15550
15551 static ffelexHandler
15552 ffeexpr_token_name_apos_name_ (ffelexToken t)
15553 {
15554 ffeexprExpr_ e;
15555 char c;
15556
15557 e = ffeexpr_expr_new_ ();
15558 e->type = FFEEXPR_exprtypeOPERAND_;
15559 e->token = ffeexpr_tokens_[0];
15560
15561 if ((ffelex_token_type (t) == ffelex_token_type (ffeexpr_tokens_[1]))
15562 && (ffelex_token_length (ffeexpr_tokens_[0]) == 1)
15563 && (ffesrc_char_match_init ((c = ffelex_token_text (ffeexpr_tokens_[0])[0]),
15564 'B', 'b')
15565 || ffesrc_char_match_init (c, 'O', 'o')
15566 || ffesrc_char_match_init (c, 'X', 'x')
15567 || ffesrc_char_match_init (c, 'Z', 'z')))
15568 {
15569 ffetargetCharacterSize size;
15570
15571 if (!ffe_is_typeless_boz ()) {
15572
15573 switch (c)
15574 {
15575 case FFESRC_CASE_MATCH_INIT ('B', 'b', imatch_b, no_imatch):
15576 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerbinary
15577 (ffeexpr_tokens_[2]));
15578 break;
15579
15580 case FFESRC_CASE_MATCH_INIT ('O', 'o', imatch_o, no_imatch):
15581 e->u.operand = ffebld_new_conter (ffebld_constant_new_integeroctal
15582 (ffeexpr_tokens_[2]));
15583 break;
15584
15585 case FFESRC_CASE_MATCH_INIT ('X', 'x', imatch_x, no_imatch):
15586 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
15587 (ffeexpr_tokens_[2]));
15588 break;
15589
15590 case FFESRC_CASE_MATCH_INIT ('Z', 'z', imatch_z, no_imatch):
15591 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
15592 (ffeexpr_tokens_[2]));
15593 break;
15594
15595 default:
15596 no_imatch: /* :::::::::::::::::::: */
15597 assert ("not BOXZ!" == NULL);
15598 abort ();
15599 }
15600
15601 ffebld_set_info (e->u.operand,
15602 ffeinfo_new (FFEINFO_basictypeINTEGER,
15603 FFEINFO_kindtypeINTEGERDEFAULT, 0,
15604 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
15605 FFETARGET_charactersizeNONE));
15606 ffeexpr_exprstack_push_operand_ (e);
15607 ffelex_token_kill (ffeexpr_tokens_[1]);
15608 ffelex_token_kill (ffeexpr_tokens_[2]);
15609 return (ffelexHandler) ffeexpr_token_binary_;
15610 }
15611
15612 switch (c)
15613 {
15614 case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
15615 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_bm
15616 (ffeexpr_tokens_[2]));
15617 size = ffetarget_size_typeless_binary (ffeexpr_tokens_[2]);
15618 break;
15619
15620 case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
15621 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_om
15622 (ffeexpr_tokens_[2]));
15623 size = ffetarget_size_typeless_octal (ffeexpr_tokens_[2]);
15624 break;
15625
15626 case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
15627 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hxm
15628 (ffeexpr_tokens_[2]));
15629 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15630 break;
15631
15632 case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
15633 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
15634 (ffeexpr_tokens_[2]));
15635 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15636 break;
15637
15638 default:
15639 no_match: /* :::::::::::::::::::: */
15640 assert ("not BOXZ!" == NULL);
15641 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
15642 (ffeexpr_tokens_[2]));
15643 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15644 break;
15645 }
15646 ffebld_set_info (e->u.operand,
15647 ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
15648 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
15649 ffeexpr_exprstack_push_operand_ (e);
15650 ffelex_token_kill (ffeexpr_tokens_[1]);
15651 ffelex_token_kill (ffeexpr_tokens_[2]);
15652 return (ffelexHandler) ffeexpr_token_binary_;
15653 }
15654
15655 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
15656 {
15657 ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
15658 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15659 ffelex_token_where_column (ffeexpr_tokens_[0]));
15660 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
15661 ffebad_finish ();
15662 }
15663
15664 ffelex_token_kill (ffeexpr_tokens_[1]);
15665 ffelex_token_kill (ffeexpr_tokens_[2]);
15666
15667 e->type = FFEEXPR_exprtypeOPERAND_;
15668 e->u.operand = ffebld_new_any ();
15669 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15670 e->token = ffeexpr_tokens_[0];
15671 ffeexpr_exprstack_push_operand_ (e);
15672
15673 switch (ffelex_token_type (t))
15674 {
15675 case FFELEX_typeAPOSTROPHE:
15676 case FFELEX_typeQUOTE:
15677 return (ffelexHandler) ffeexpr_token_binary_;
15678
15679 default:
15680 return (ffelexHandler) ffeexpr_token_binary_ (t);
15681 }
15682 }
15683
15684 /* ffeexpr_token_percent_ -- Rhs PERCENT
15685
15686 Handle a percent sign possibly followed by "LOC". If followed instead
15687 by "VAL", "REF", or "DESCR", issue an error message and substitute
15688 "LOC". If followed by something else, treat the percent sign as a
15689 spurious incorrect token and reprocess the token via _rhs_. */
15690
15691 static ffelexHandler
15692 ffeexpr_token_percent_ (ffelexToken t)
15693 {
15694 switch (ffelex_token_type (t))
15695 {
15696 case FFELEX_typeNAME:
15697 case FFELEX_typeNAMES:
15698 ffeexpr_stack_->percent = ffeexpr_percent_ (t);
15699 ffeexpr_tokens_[1] = ffelex_token_use (t);
15700 return (ffelexHandler) ffeexpr_token_percent_name_;
15701
15702 default:
15703 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
15704 {
15705 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15706 ffelex_token_where_column (ffeexpr_tokens_[0]));
15707 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
15708 ffelex_token_where_column (ffeexpr_stack_->first_token));
15709 ffebad_finish ();
15710 }
15711 ffelex_token_kill (ffeexpr_tokens_[0]);
15712 return (ffelexHandler) ffeexpr_token_rhs_ (t);
15713 }
15714 }
15715
15716 /* ffeexpr_token_percent_name_ -- Rhs PERCENT NAME
15717
15718 Make sure the token is OPEN_PAREN and prepare for the one-item list of
15719 LHS expressions. Else display an error message. */
15720
15721 static ffelexHandler
15722 ffeexpr_token_percent_name_ (ffelexToken t)
15723 {
15724 ffelexHandler nexthandler;
15725
15726 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
15727 {
15728 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
15729 {
15730 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15731 ffelex_token_where_column (ffeexpr_tokens_[0]));
15732 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
15733 ffelex_token_where_column (ffeexpr_stack_->first_token));
15734 ffebad_finish ();
15735 }
15736 ffelex_token_kill (ffeexpr_tokens_[0]);
15737 nexthandler = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_tokens_[1]);
15738 ffelex_token_kill (ffeexpr_tokens_[1]);
15739 return (ffelexHandler) (*nexthandler) (t);
15740 }
15741
15742 switch (ffeexpr_stack_->percent)
15743 {
15744 default:
15745 if (ffest_ffebad_start (FFEBAD_INVALID_PERCENT))
15746 {
15747 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15748 ffelex_token_where_column (ffeexpr_tokens_[0]));
15749 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
15750 ffebad_finish ();
15751 }
15752 ffeexpr_stack_->percent = FFEEXPR_percentLOC_;
15753 /* Fall through. */
15754 case FFEEXPR_percentLOC_:
15755 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
15756 ffelex_token_kill (ffeexpr_tokens_[1]);
15757 ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
15758 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
15759 FFEEXPR_contextLOC_,
15760 ffeexpr_cb_end_loc_);
15761 }
15762 }
15763
15764 /* ffeexpr_make_float_const_ -- Make a floating-point constant
15765
15766 See prototype.
15767
15768 Pass 'E', 'D', or 'Q' for exponent letter. */
15769
15770 static void
15771 ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
15772 ffelexToken decimal, ffelexToken fraction,
15773 ffelexToken exponent, ffelexToken exponent_sign,
15774 ffelexToken exponent_digits)
15775 {
15776 ffeexprExpr_ e;
15777
15778 e = ffeexpr_expr_new_ ();
15779 e->type = FFEEXPR_exprtypeOPERAND_;
15780 if (integer != NULL)
15781 e->token = ffelex_token_use (integer);
15782 else
15783 {
15784 assert (decimal != NULL);
15785 e->token = ffelex_token_use (decimal);
15786 }
15787
15788 switch (exp_letter)
15789 {
15790 #if !FFETARGET_okREALQUAD
15791 case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
15792 if (ffebad_start (FFEBAD_QUAD_UNSUPPORTED))
15793 {
15794 ffebad_here (0, ffelex_token_where_line (e->token),
15795 ffelex_token_where_column (e->token));
15796 ffebad_finish ();
15797 }
15798 goto match_d; /* The FFESRC_CASE_* macros don't
15799 allow fall-through! */
15800 #endif
15801
15802 case FFESRC_CASE_MATCH_INIT ('D', 'd', match_d, no_match):
15803 e->u.operand = ffebld_new_conter (ffebld_constant_new_realdouble
15804 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15805 ffebld_set_info (e->u.operand,
15806 ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
15807 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15808 break;
15809
15810 case FFESRC_CASE_MATCH_INIT ('E', 'e', match_e, no_match):
15811 e->u.operand = ffebld_new_conter (ffebld_constant_new_realdefault
15812 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15813 ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeREAL,
15814 FFEINFO_kindtypeREALDEFAULT, 0, FFEINFO_kindENTITY,
15815 FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15816 break;
15817
15818 #if FFETARGET_okREALQUAD
15819 case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
15820 e->u.operand = ffebld_new_conter (ffebld_constant_new_realquad
15821 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15822 ffebld_set_info (e->u.operand,
15823 ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALQUAD,
15824 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15825 break;
15826 #endif
15827
15828 case 'I': /* Make an integer. */
15829 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
15830 (ffeexpr_tokens_[0]));
15831 ffebld_set_info (e->u.operand,
15832 ffeinfo_new (FFEINFO_basictypeINTEGER,
15833 FFEINFO_kindtypeINTEGERDEFAULT, 0,
15834 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
15835 FFETARGET_charactersizeNONE));
15836 break;
15837
15838 default:
15839 no_match: /* :::::::::::::::::::: */
15840 assert ("Lost the exponent letter!" == NULL);
15841 }
15842
15843 ffeexpr_exprstack_push_operand_ (e);
15844 }
15845
15846 /* Just like ffesymbol_declare_local, except performs any implicit info
15847 assignment necessary. */
15848
15849 static ffesymbol
15850 ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin)
15851 {
15852 ffesymbol s;
15853 ffeinfoKind k;
15854 bool bad;
15855
15856 s = ffesymbol_declare_local (t, maybe_intrin);
15857
15858 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15859 /* Special-case these since they can involve a different concept
15860 of "state" (in the stmtfunc name space). */
15861 {
15862 case FFEEXPR_contextDATAIMPDOINDEX_:
15863 case FFEEXPR_contextDATAIMPDOCTRL_:
15864 if (ffeexpr_context_outer_ (ffeexpr_stack_)
15865 == FFEEXPR_contextDATAIMPDOINDEX_)
15866 s = ffeexpr_sym_impdoitem_ (s, t);
15867 else
15868 if (ffeexpr_stack_->is_rhs)
15869 s = ffeexpr_sym_impdoitem_ (s, t);
15870 else
15871 s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
15872 bad = (ffesymbol_kind (s) != FFEINFO_kindENTITY)
15873 || ((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
15874 && (ffesymbol_where (s) != FFEINFO_whereIMMEDIATE));
15875 if (bad && (ffesymbol_kind (s) != FFEINFO_kindANY))
15876 ffesymbol_error (s, t);
15877 return s;
15878
15879 default:
15880 break;
15881 }
15882
15883 switch ((ffesymbol_sfdummyparent (s) == NULL)
15884 ? ffesymbol_state (s)
15885 : FFESYMBOL_stateUNDERSTOOD)
15886 {
15887 case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr
15888 context. */
15889 if (!ffest_seen_first_exec ())
15890 goto seen; /* :::::::::::::::::::: */
15891 /* Fall through. */
15892 case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */
15893 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15894 {
15895 case FFEEXPR_contextSUBROUTINEREF:
15896 s = ffeexpr_sym_lhs_call_ (s, t);
15897 break;
15898
15899 case FFEEXPR_contextFILEEXTFUNC:
15900 s = ffeexpr_sym_lhs_extfunc_ (s, t);
15901 break;
15902
15903 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15904 s = ffecom_sym_exec_transition (s);
15905 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15906 goto understood; /* :::::::::::::::::::: */
15907 /* Fall through. */
15908 case FFEEXPR_contextACTUALARG_:
15909 s = ffeexpr_sym_rhs_actualarg_ (s, t);
15910 break;
15911
15912 case FFEEXPR_contextDATA:
15913 if (ffeexpr_stack_->is_rhs)
15914 s = ffeexpr_sym_rhs_let_ (s, t);
15915 else
15916 s = ffeexpr_sym_lhs_data_ (s, t);
15917 break;
15918
15919 case FFEEXPR_contextDATAIMPDOITEM_:
15920 s = ffeexpr_sym_lhs_data_ (s, t);
15921 break;
15922
15923 case FFEEXPR_contextSFUNCDEF:
15924 case FFEEXPR_contextSFUNCDEFINDEX_:
15925 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15926 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15927 s = ffecom_sym_exec_transition (s);
15928 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15929 goto understood; /* :::::::::::::::::::: */
15930 /* Fall through. */
15931 case FFEEXPR_contextLET:
15932 case FFEEXPR_contextPAREN_:
15933 case FFEEXPR_contextACTUALARGEXPR_:
15934 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15935 case FFEEXPR_contextASSIGN:
15936 case FFEEXPR_contextIOLIST:
15937 case FFEEXPR_contextIOLISTDF:
15938 case FFEEXPR_contextDO:
15939 case FFEEXPR_contextDOWHILE:
15940 case FFEEXPR_contextAGOTO:
15941 case FFEEXPR_contextCGOTO:
15942 case FFEEXPR_contextIF:
15943 case FFEEXPR_contextARITHIF:
15944 case FFEEXPR_contextFORMAT:
15945 case FFEEXPR_contextSTOP:
15946 case FFEEXPR_contextRETURN:
15947 case FFEEXPR_contextSELECTCASE:
15948 case FFEEXPR_contextCASE:
15949 case FFEEXPR_contextFILEASSOC:
15950 case FFEEXPR_contextFILEINT:
15951 case FFEEXPR_contextFILEDFINT:
15952 case FFEEXPR_contextFILELOG:
15953 case FFEEXPR_contextFILENUM:
15954 case FFEEXPR_contextFILENUMAMBIG:
15955 case FFEEXPR_contextFILECHAR:
15956 case FFEEXPR_contextFILENUMCHAR:
15957 case FFEEXPR_contextFILEDFCHAR:
15958 case FFEEXPR_contextFILEKEY:
15959 case FFEEXPR_contextFILEUNIT:
15960 case FFEEXPR_contextFILEUNIT_DF:
15961 case FFEEXPR_contextFILEUNITAMBIG:
15962 case FFEEXPR_contextFILEFORMAT:
15963 case FFEEXPR_contextFILENAMELIST:
15964 case FFEEXPR_contextFILEVXTCODE:
15965 case FFEEXPR_contextINDEX_:
15966 case FFEEXPR_contextIMPDOITEM_:
15967 case FFEEXPR_contextIMPDOITEMDF_:
15968 case FFEEXPR_contextIMPDOCTRL_:
15969 case FFEEXPR_contextLOC_:
15970 if (ffeexpr_stack_->is_rhs)
15971 s = ffeexpr_sym_rhs_let_ (s, t);
15972 else
15973 s = ffeexpr_sym_lhs_let_ (s, t);
15974 break;
15975
15976 case FFEEXPR_contextCHARACTERSIZE:
15977 case FFEEXPR_contextEQUIVALENCE:
15978 case FFEEXPR_contextINCLUDE:
15979 case FFEEXPR_contextPARAMETER:
15980 case FFEEXPR_contextDIMLIST:
15981 case FFEEXPR_contextDIMLISTCOMMON:
15982 case FFEEXPR_contextKINDTYPE:
15983 case FFEEXPR_contextINITVAL:
15984 case FFEEXPR_contextEQVINDEX_:
15985 break; /* Will turn into errors below. */
15986
15987 default:
15988 ffesymbol_error (s, t);
15989 break;
15990 }
15991 /* Fall through. */
15992 case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */
15993 understood: /* :::::::::::::::::::: */
15994 k = ffesymbol_kind (s);
15995 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15996 {
15997 case FFEEXPR_contextSUBROUTINEREF:
15998 bad = ((k != FFEINFO_kindSUBROUTINE)
15999 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
16000 || (k != FFEINFO_kindNONE)));
16001 break;
16002
16003 case FFEEXPR_contextFILEEXTFUNC:
16004 bad = (k != FFEINFO_kindFUNCTION)
16005 || (ffesymbol_where (s) != FFEINFO_whereGLOBAL);
16006 break;
16007
16008 case FFEEXPR_contextSFUNCDEFACTUALARG_:
16009 case FFEEXPR_contextACTUALARG_:
16010 switch (k)
16011 {
16012 case FFEINFO_kindENTITY:
16013 bad = FALSE;
16014 break;
16015
16016 case FFEINFO_kindFUNCTION:
16017 case FFEINFO_kindSUBROUTINE:
16018 bad
16019 = ((ffesymbol_where (s) != FFEINFO_whereGLOBAL)
16020 && (ffesymbol_where (s) != FFEINFO_whereDUMMY)
16021 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
16022 || !ffeintrin_is_actualarg (ffesymbol_specific (s))));
16023 break;
16024
16025 case FFEINFO_kindNONE:
16026 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
16027 {
16028 bad = !(ffeintrin_is_actualarg (ffesymbol_specific (s)));
16029 break;
16030 }
16031
16032 /* If state is UNDERSTOOD here, it's CHAR*(*) or attrsANY,
16033 and in the former case, attrsTYPE is set, so we
16034 see this as an error as we should, since CHAR*(*)
16035 cannot be actually referenced in a main/block data
16036 program unit. */
16037
16038 if ((ffesymbol_attrs (s) & (FFESYMBOL_attrsANY
16039 | FFESYMBOL_attrsEXTERNAL
16040 | FFESYMBOL_attrsTYPE))
16041 == FFESYMBOL_attrsEXTERNAL)
16042 bad = FALSE;
16043 else
16044 bad = TRUE;
16045 break;
16046
16047 default:
16048 bad = TRUE;
16049 break;
16050 }
16051 break;
16052
16053 case FFEEXPR_contextDATA:
16054 if (ffeexpr_stack_->is_rhs)
16055 bad = (k != FFEINFO_kindENTITY)
16056 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16057 else
16058 bad = (k != FFEINFO_kindENTITY)
16059 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
16060 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
16061 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
16062 break;
16063
16064 case FFEEXPR_contextDATAIMPDOITEM_:
16065 bad = TRUE; /* Unadorned item never valid. */
16066 break;
16067
16068 case FFEEXPR_contextSFUNCDEF:
16069 case FFEEXPR_contextSFUNCDEFINDEX_:
16070 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16071 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16072 case FFEEXPR_contextLET:
16073 case FFEEXPR_contextPAREN_:
16074 case FFEEXPR_contextACTUALARGEXPR_:
16075 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16076 case FFEEXPR_contextASSIGN:
16077 case FFEEXPR_contextIOLIST:
16078 case FFEEXPR_contextIOLISTDF:
16079 case FFEEXPR_contextDO:
16080 case FFEEXPR_contextDOWHILE:
16081 case FFEEXPR_contextAGOTO:
16082 case FFEEXPR_contextCGOTO:
16083 case FFEEXPR_contextIF:
16084 case FFEEXPR_contextARITHIF:
16085 case FFEEXPR_contextFORMAT:
16086 case FFEEXPR_contextSTOP:
16087 case FFEEXPR_contextRETURN:
16088 case FFEEXPR_contextSELECTCASE:
16089 case FFEEXPR_contextCASE:
16090 case FFEEXPR_contextFILEASSOC:
16091 case FFEEXPR_contextFILEINT:
16092 case FFEEXPR_contextFILEDFINT:
16093 case FFEEXPR_contextFILELOG:
16094 case FFEEXPR_contextFILENUM:
16095 case FFEEXPR_contextFILENUMAMBIG:
16096 case FFEEXPR_contextFILECHAR:
16097 case FFEEXPR_contextFILENUMCHAR:
16098 case FFEEXPR_contextFILEDFCHAR:
16099 case FFEEXPR_contextFILEKEY:
16100 case FFEEXPR_contextFILEUNIT:
16101 case FFEEXPR_contextFILEUNIT_DF:
16102 case FFEEXPR_contextFILEUNITAMBIG:
16103 case FFEEXPR_contextFILEFORMAT:
16104 case FFEEXPR_contextFILENAMELIST:
16105 case FFEEXPR_contextFILEVXTCODE:
16106 case FFEEXPR_contextINDEX_:
16107 case FFEEXPR_contextIMPDOITEM_:
16108 case FFEEXPR_contextIMPDOITEMDF_:
16109 case FFEEXPR_contextIMPDOCTRL_:
16110 case FFEEXPR_contextLOC_:
16111 bad = (k != FFEINFO_kindENTITY); /* This catches "SUBROUTINE
16112 X(A);EXTERNAL A;CALL
16113 Y(A);B=A", for example. */
16114 break;
16115
16116 case FFEEXPR_contextCHARACTERSIZE:
16117 case FFEEXPR_contextEQUIVALENCE:
16118 case FFEEXPR_contextPARAMETER:
16119 case FFEEXPR_contextDIMLIST:
16120 case FFEEXPR_contextDIMLISTCOMMON:
16121 case FFEEXPR_contextKINDTYPE:
16122 case FFEEXPR_contextINITVAL:
16123 case FFEEXPR_contextEQVINDEX_:
16124 bad = (k != FFEINFO_kindENTITY)
16125 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16126 break;
16127
16128 case FFEEXPR_contextINCLUDE:
16129 bad = TRUE;
16130 break;
16131
16132 default:
16133 bad = TRUE;
16134 break;
16135 }
16136 if (bad && (k != FFEINFO_kindANY))
16137 ffesymbol_error (s, t);
16138 return s;
16139
16140 case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */
16141 seen: /* :::::::::::::::::::: */
16142 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16143 {
16144 case FFEEXPR_contextPARAMETER:
16145 if (ffeexpr_stack_->is_rhs)
16146 ffesymbol_error (s, t);
16147 else
16148 s = ffeexpr_sym_lhs_parameter_ (s, t);
16149 break;
16150
16151 case FFEEXPR_contextDATA:
16152 s = ffecom_sym_exec_transition (s);
16153 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16154 goto understood; /* :::::::::::::::::::: */
16155 if (ffeexpr_stack_->is_rhs)
16156 ffesymbol_error (s, t);
16157 else
16158 s = ffeexpr_sym_lhs_data_ (s, t);
16159 goto understood; /* :::::::::::::::::::: */
16160
16161 case FFEEXPR_contextDATAIMPDOITEM_:
16162 s = ffecom_sym_exec_transition (s);
16163 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16164 goto understood; /* :::::::::::::::::::: */
16165 s = ffeexpr_sym_lhs_data_ (s, t);
16166 goto understood; /* :::::::::::::::::::: */
16167
16168 case FFEEXPR_contextEQUIVALENCE:
16169 s = ffeexpr_sym_lhs_equivalence_ (s, t);
16170 break;
16171
16172 case FFEEXPR_contextDIMLIST:
16173 s = ffeexpr_sym_rhs_dimlist_ (s, t);
16174 break;
16175
16176 case FFEEXPR_contextCHARACTERSIZE:
16177 case FFEEXPR_contextKINDTYPE:
16178 case FFEEXPR_contextDIMLISTCOMMON:
16179 case FFEEXPR_contextINITVAL:
16180 case FFEEXPR_contextEQVINDEX_:
16181 ffesymbol_error (s, t);
16182 break;
16183
16184 case FFEEXPR_contextINCLUDE:
16185 ffesymbol_error (s, t);
16186 break;
16187
16188 case FFEEXPR_contextACTUALARG_: /* E.g. I in REAL A(Y(I)). */
16189 case FFEEXPR_contextSFUNCDEFACTUALARG_:
16190 s = ffecom_sym_exec_transition (s);
16191 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16192 goto understood; /* :::::::::::::::::::: */
16193 s = ffeexpr_sym_rhs_actualarg_ (s, t);
16194 goto understood; /* :::::::::::::::::::: */
16195
16196 case FFEEXPR_contextINDEX_:
16197 case FFEEXPR_contextACTUALARGEXPR_:
16198 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16199 case FFEEXPR_contextSFUNCDEF:
16200 case FFEEXPR_contextSFUNCDEFINDEX_:
16201 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16202 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16203 assert (ffeexpr_stack_->is_rhs);
16204 s = ffecom_sym_exec_transition (s);
16205 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16206 goto understood; /* :::::::::::::::::::: */
16207 s = ffeexpr_sym_rhs_let_ (s, t);
16208 goto understood; /* :::::::::::::::::::: */
16209
16210 default:
16211 ffesymbol_error (s, t);
16212 break;
16213 }
16214 return s;
16215
16216 default:
16217 assert ("bad symbol state" == NULL);
16218 return NULL;
16219 break;
16220 }
16221 }
16222
16223 /* Have FOO in DATA (XYZ(FOO),...)/.../ or DATA (...,XYZ=FOO,BAR,BLETCH).
16224 Could be found via the "statement-function" name space (in which case
16225 it should become an iterator) or the local name space (in which case
16226 it should be either a named constant, or a variable that will have an
16227 sfunc name space sibling that should become an iterator). */
16228
16229 static ffesymbol
16230 ffeexpr_sym_impdoitem_ (ffesymbol sp, ffelexToken t)
16231 {
16232 ffesymbol s;
16233 ffesymbolAttrs sa;
16234 ffesymbolAttrs na;
16235 ffesymbolState ss;
16236 ffesymbolState ns;
16237 ffeinfoKind kind;
16238 ffeinfoWhere where;
16239
16240 ss = ffesymbol_state (sp);
16241
16242 if (ffesymbol_sfdummyparent (sp) != NULL)
16243 { /* Have symbol in sfunc name space. */
16244 switch (ss)
16245 {
16246 case FFESYMBOL_stateNONE: /* Used as iterator already. */
16247 if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
16248 ffesymbol_error (sp, t); /* Can't use dead iterator. */
16249 else
16250 { /* Can use dead iterator because we're at at
16251 least an innermore (higher-numbered) level
16252 than the iterator's outermost
16253 (lowest-numbered) level. */
16254 ffesymbol_signal_change (sp);
16255 ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
16256 ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
16257 ffesymbol_signal_unreported (sp);
16258 }
16259 break;
16260
16261 case FFESYMBOL_stateSEEN: /* Seen already in this or other
16262 implied-DO. Set symbol level
16263 number to outermost value, as that
16264 tells us we can see it as iterator
16265 at that level at the innermost. */
16266 if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
16267 {
16268 ffesymbol_signal_change (sp);
16269 ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
16270 ffesymbol_signal_unreported (sp);
16271 }
16272 break;
16273
16274 case FFESYMBOL_stateUNCERTAIN: /* Iterator. */
16275 assert (ffeexpr_level_ == ffesymbol_maxentrynum (sp));
16276 ffesymbol_error (sp, t); /* (,,,I=I,10). */
16277 break;
16278
16279 case FFESYMBOL_stateUNDERSTOOD:
16280 break; /* ANY. */
16281
16282 default:
16283 assert ("Foo Bar!!" == NULL);
16284 break;
16285 }
16286
16287 return sp;
16288 }
16289
16290 /* Got symbol in local name space, so we haven't seen it in impdo yet.
16291 First, if it is brand-new and we're in executable statements, set the
16292 attributes and exec-transition it to set state UNCERTAIN or UNDERSTOOD.
16293 Second, if it is now a constant (PARAMETER), then just return it, it
16294 can't be an implied-do iterator. If it is understood, complain if it is
16295 not a valid variable, but make the inner name space iterator anyway and
16296 return that. If it is not understood, improve understanding of the
16297 symbol accordingly, complain accordingly, in either case make the inner
16298 name space iterator and return that. */
16299
16300 sa = ffesymbol_attrs (sp);
16301
16302 if (ffesymbol_state_is_specable (ss)
16303 && ffest_seen_first_exec ())
16304 {
16305 assert (sa == FFESYMBOL_attrsetNONE);
16306 ffesymbol_signal_change (sp);
16307 ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
16308 ffesymbol_resolve_intrin (sp);
16309 if (ffeimplic_establish_symbol (sp))
16310 ffesymbol_set_attr (sp, FFESYMBOL_attrSFARG);
16311 else
16312 ffesymbol_error (sp, t);
16313
16314 /* After the exec transition, the state will either be UNCERTAIN (could
16315 be a dummy or local var) or UNDERSTOOD (local var, because this is a
16316 PROGRAM/BLOCKDATA program unit). */
16317
16318 sp = ffecom_sym_exec_transition (sp);
16319 sa = ffesymbol_attrs (sp);
16320 ss = ffesymbol_state (sp);
16321 }
16322
16323 ns = ss;
16324 kind = ffesymbol_kind (sp);
16325 where = ffesymbol_where (sp);
16326
16327 if (ss == FFESYMBOL_stateUNDERSTOOD)
16328 {
16329 if (kind != FFEINFO_kindENTITY)
16330 ffesymbol_error (sp, t);
16331 if (where == FFEINFO_whereCONSTANT)
16332 return sp;
16333 }
16334 else
16335 {
16336 /* Enhance understanding of local symbol. This used to imply exec
16337 transition, but that doesn't seem necessary, since the local symbol
16338 doesn't actually get put into an ffebld tree here -- we just learn
16339 more about it, just like when we see a local symbol's name in the
16340 dummy-arg list of a statement function. */
16341
16342 if (ss != FFESYMBOL_stateUNCERTAIN)
16343 {
16344 /* Figure out what kind of object we've got based on previous
16345 declarations of or references to the object. */
16346
16347 ns = FFESYMBOL_stateSEEN;
16348
16349 if (sa & FFESYMBOL_attrsANY)
16350 na = sa;
16351 else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
16352 | FFESYMBOL_attrsANY
16353 | FFESYMBOL_attrsCOMMON
16354 | FFESYMBOL_attrsDUMMY
16355 | FFESYMBOL_attrsEQUIV
16356 | FFESYMBOL_attrsINIT
16357 | FFESYMBOL_attrsNAMELIST
16358 | FFESYMBOL_attrsRESULT
16359 | FFESYMBOL_attrsSAVE
16360 | FFESYMBOL_attrsSFARG
16361 | FFESYMBOL_attrsTYPE)))
16362 na = sa | FFESYMBOL_attrsSFARG;
16363 else
16364 na = FFESYMBOL_attrsetNONE;
16365 }
16366 else
16367 { /* stateUNCERTAIN. */
16368 na = sa | FFESYMBOL_attrsSFARG;
16369 ns = FFESYMBOL_stateUNDERSTOOD;
16370
16371 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16372 | FFESYMBOL_attrsADJUSTABLE
16373 | FFESYMBOL_attrsANYLEN
16374 | FFESYMBOL_attrsARRAY
16375 | FFESYMBOL_attrsDUMMY
16376 | FFESYMBOL_attrsEXTERNAL
16377 | FFESYMBOL_attrsSFARG
16378 | FFESYMBOL_attrsTYPE)));
16379
16380 if (sa & FFESYMBOL_attrsEXTERNAL)
16381 {
16382 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16383 | FFESYMBOL_attrsDUMMY
16384 | FFESYMBOL_attrsEXTERNAL
16385 | FFESYMBOL_attrsTYPE)));
16386
16387 na = FFESYMBOL_attrsetNONE;
16388 }
16389 else if (sa & FFESYMBOL_attrsDUMMY)
16390 {
16391 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16392 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16393 | FFESYMBOL_attrsEXTERNAL
16394 | FFESYMBOL_attrsTYPE)));
16395
16396 kind = FFEINFO_kindENTITY;
16397 }
16398 else if (sa & FFESYMBOL_attrsARRAY)
16399 {
16400 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16401 | FFESYMBOL_attrsADJUSTABLE
16402 | FFESYMBOL_attrsTYPE)));
16403
16404 na = FFESYMBOL_attrsetNONE;
16405 }
16406 else if (sa & FFESYMBOL_attrsSFARG)
16407 {
16408 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16409 | FFESYMBOL_attrsTYPE)));
16410
16411 ns = FFESYMBOL_stateUNCERTAIN;
16412 }
16413 else if (sa & FFESYMBOL_attrsTYPE)
16414 {
16415 assert (!(sa & (FFESYMBOL_attrsARRAY
16416 | FFESYMBOL_attrsDUMMY
16417 | FFESYMBOL_attrsEXTERNAL
16418 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16419 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16420 | FFESYMBOL_attrsADJUSTABLE
16421 | FFESYMBOL_attrsANYLEN
16422 | FFESYMBOL_attrsARRAY
16423 | FFESYMBOL_attrsDUMMY
16424 | FFESYMBOL_attrsEXTERNAL
16425 | FFESYMBOL_attrsSFARG)));
16426
16427 kind = FFEINFO_kindENTITY;
16428
16429 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16430 na = FFESYMBOL_attrsetNONE;
16431 else if (ffest_is_entry_valid ())
16432 ns = FFESYMBOL_stateUNCERTAIN; /* Could be DUMMY or LOCAL. */
16433 else
16434 where = FFEINFO_whereLOCAL;
16435 }
16436 else
16437 na = FFESYMBOL_attrsetNONE; /* Error. */
16438 }
16439
16440 /* Now see what we've got for a new object: NONE means a new error
16441 cropped up; ANY means an old error to be ignored; otherwise,
16442 everything's ok, update the object (symbol) and continue on. */
16443
16444 if (na == FFESYMBOL_attrsetNONE)
16445 ffesymbol_error (sp, t);
16446 else if (!(na & FFESYMBOL_attrsANY))
16447 {
16448 ffesymbol_signal_change (sp); /* May need to back up to previous
16449 version. */
16450 if (!ffeimplic_establish_symbol (sp))
16451 ffesymbol_error (sp, t);
16452 else
16453 {
16454 ffesymbol_set_info (sp,
16455 ffeinfo_new (ffesymbol_basictype (sp),
16456 ffesymbol_kindtype (sp),
16457 ffesymbol_rank (sp),
16458 kind,
16459 where,
16460 ffesymbol_size (sp)));
16461 ffesymbol_set_attrs (sp, na);
16462 ffesymbol_set_state (sp, ns);
16463 ffesymbol_resolve_intrin (sp);
16464 if (!ffesymbol_state_is_specable (ns))
16465 sp = ffecom_sym_learned (sp);
16466 ffesymbol_signal_unreported (sp); /* For debugging purposes. */
16467 }
16468 }
16469 }
16470
16471 /* Here we create the sfunc-name-space symbol representing what should
16472 become an iterator in this name space at this or an outermore (lower-
16473 numbered) expression level, else the implied-DO construct is in error. */
16474
16475 s = ffesymbol_declare_sfdummy (t); /* Sets maxentrynum to 0 for new obj;
16476 also sets sfa_dummy_parent to
16477 parent symbol. */
16478 assert (sp == ffesymbol_sfdummyparent (s));
16479
16480 ffesymbol_signal_change (s);
16481 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
16482 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
16483 ffesymbol_set_info (s,
16484 ffeinfo_new (FFEINFO_basictypeINTEGER,
16485 FFEINFO_kindtypeINTEGERDEFAULT,
16486 0,
16487 FFEINFO_kindENTITY,
16488 FFEINFO_whereIMMEDIATE,
16489 FFETARGET_charactersizeNONE));
16490 ffesymbol_signal_unreported (s);
16491
16492 if (((ffesymbol_basictype (sp) != FFEINFO_basictypeINTEGER)
16493 && (ffesymbol_basictype (sp) != FFEINFO_basictypeANY))
16494 || ((ffesymbol_kindtype (sp) != FFEINFO_kindtypeINTEGERDEFAULT)
16495 && (ffesymbol_kindtype (sp) != FFEINFO_kindtypeANY)))
16496 ffesymbol_error (s, t);
16497
16498 return s;
16499 }
16500
16501 /* Have FOO in CALL FOO. Local name space, executable context only. */
16502
16503 static ffesymbol
16504 ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t)
16505 {
16506 ffesymbolAttrs sa;
16507 ffesymbolAttrs na;
16508 ffeinfoKind kind;
16509 ffeinfoWhere where;
16510 ffeintrinGen gen;
16511 ffeintrinSpec spec;
16512 ffeintrinImp imp;
16513 bool error = FALSE;
16514
16515 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16516 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16517
16518 na = sa = ffesymbol_attrs (s);
16519
16520 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16521 | FFESYMBOL_attrsADJUSTABLE
16522 | FFESYMBOL_attrsANYLEN
16523 | FFESYMBOL_attrsARRAY
16524 | FFESYMBOL_attrsDUMMY
16525 | FFESYMBOL_attrsEXTERNAL
16526 | FFESYMBOL_attrsSFARG
16527 | FFESYMBOL_attrsTYPE)));
16528
16529 kind = ffesymbol_kind (s);
16530 where = ffesymbol_where (s);
16531
16532 /* Figure out what kind of object we've got based on previous declarations
16533 of or references to the object. */
16534
16535 if (sa & FFESYMBOL_attrsEXTERNAL)
16536 {
16537 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16538 | FFESYMBOL_attrsDUMMY
16539 | FFESYMBOL_attrsEXTERNAL
16540 | FFESYMBOL_attrsTYPE)));
16541
16542 if (sa & FFESYMBOL_attrsTYPE)
16543 error = TRUE;
16544 else
16545 /* Not TYPE. */
16546 {
16547 kind = FFEINFO_kindSUBROUTINE;
16548
16549 if (sa & FFESYMBOL_attrsDUMMY)
16550 ; /* Not TYPE. */
16551 else if (sa & FFESYMBOL_attrsACTUALARG)
16552 ; /* Not DUMMY or TYPE. */
16553 else /* Not ACTUALARG, DUMMY, or TYPE. */
16554 where = FFEINFO_whereGLOBAL;
16555 }
16556 }
16557 else if (sa & FFESYMBOL_attrsDUMMY)
16558 {
16559 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16560 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16561 | FFESYMBOL_attrsEXTERNAL
16562 | FFESYMBOL_attrsTYPE)));
16563
16564 if (sa & FFESYMBOL_attrsTYPE)
16565 error = TRUE;
16566 else
16567 kind = FFEINFO_kindSUBROUTINE;
16568 }
16569 else if (sa & FFESYMBOL_attrsARRAY)
16570 {
16571 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16572 | FFESYMBOL_attrsADJUSTABLE
16573 | FFESYMBOL_attrsTYPE)));
16574
16575 error = TRUE;
16576 }
16577 else if (sa & FFESYMBOL_attrsSFARG)
16578 {
16579 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16580 | FFESYMBOL_attrsTYPE)));
16581
16582 error = TRUE;
16583 }
16584 else if (sa & FFESYMBOL_attrsTYPE)
16585 {
16586 assert (!(sa & (FFESYMBOL_attrsARRAY
16587 | FFESYMBOL_attrsDUMMY
16588 | FFESYMBOL_attrsEXTERNAL
16589 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16590 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16591 | FFESYMBOL_attrsADJUSTABLE
16592 | FFESYMBOL_attrsANYLEN
16593 | FFESYMBOL_attrsARRAY
16594 | FFESYMBOL_attrsDUMMY
16595 | FFESYMBOL_attrsEXTERNAL
16596 | FFESYMBOL_attrsSFARG)));
16597
16598 error = TRUE;
16599 }
16600 else if (sa == FFESYMBOL_attrsetNONE)
16601 {
16602 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16603
16604 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
16605 &gen, &spec, &imp))
16606 {
16607 ffesymbol_signal_change (s); /* May need to back up to previous
16608 version. */
16609 ffesymbol_set_generic (s, gen);
16610 ffesymbol_set_specific (s, spec);
16611 ffesymbol_set_implementation (s, imp);
16612 ffesymbol_set_info (s,
16613 ffeinfo_new (FFEINFO_basictypeNONE,
16614 FFEINFO_kindtypeNONE,
16615 0,
16616 FFEINFO_kindSUBROUTINE,
16617 FFEINFO_whereINTRINSIC,
16618 FFETARGET_charactersizeNONE));
16619 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16620 ffesymbol_resolve_intrin (s);
16621 ffesymbol_reference (s, t, FALSE);
16622 s = ffecom_sym_learned (s);
16623 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16624
16625 return s;
16626 }
16627
16628 kind = FFEINFO_kindSUBROUTINE;
16629 where = FFEINFO_whereGLOBAL;
16630 }
16631 else
16632 error = TRUE;
16633
16634 /* Now see what we've got for a new object: NONE means a new error cropped
16635 up; ANY means an old error to be ignored; otherwise, everything's ok,
16636 update the object (symbol) and continue on. */
16637
16638 if (error)
16639 ffesymbol_error (s, t);
16640 else if (!(na & FFESYMBOL_attrsANY))
16641 {
16642 ffesymbol_signal_change (s); /* May need to back up to previous
16643 version. */
16644 ffesymbol_set_info (s,
16645 ffeinfo_new (ffesymbol_basictype (s),
16646 ffesymbol_kindtype (s),
16647 ffesymbol_rank (s),
16648 kind, /* SUBROUTINE. */
16649 where, /* GLOBAL or DUMMY. */
16650 ffesymbol_size (s)));
16651 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16652 ffesymbol_resolve_intrin (s);
16653 ffesymbol_reference (s, t, FALSE);
16654 s = ffecom_sym_learned (s);
16655 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16656 }
16657
16658 return s;
16659 }
16660
16661 /* Have FOO in DATA FOO/.../. Local name space and executable context
16662 only. (This will change in the future when DATA FOO may be followed
16663 by COMMON FOO or even INTEGER FOO(10), etc.) */
16664
16665 static ffesymbol
16666 ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t)
16667 {
16668 ffesymbolAttrs sa;
16669 ffesymbolAttrs na;
16670 ffeinfoKind kind;
16671 ffeinfoWhere where;
16672 bool error = FALSE;
16673
16674 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16675 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16676
16677 na = sa = ffesymbol_attrs (s);
16678
16679 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16680 | FFESYMBOL_attrsADJUSTABLE
16681 | FFESYMBOL_attrsANYLEN
16682 | FFESYMBOL_attrsARRAY
16683 | FFESYMBOL_attrsDUMMY
16684 | FFESYMBOL_attrsEXTERNAL
16685 | FFESYMBOL_attrsSFARG
16686 | FFESYMBOL_attrsTYPE)));
16687
16688 kind = ffesymbol_kind (s);
16689 where = ffesymbol_where (s);
16690
16691 /* Figure out what kind of object we've got based on previous declarations
16692 of or references to the object. */
16693
16694 if (sa & FFESYMBOL_attrsEXTERNAL)
16695 {
16696 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16697 | FFESYMBOL_attrsDUMMY
16698 | FFESYMBOL_attrsEXTERNAL
16699 | FFESYMBOL_attrsTYPE)));
16700
16701 error = TRUE;
16702 }
16703 else if (sa & FFESYMBOL_attrsDUMMY)
16704 {
16705 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16706 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16707 | FFESYMBOL_attrsEXTERNAL
16708 | FFESYMBOL_attrsTYPE)));
16709
16710 error = TRUE;
16711 }
16712 else if (sa & FFESYMBOL_attrsARRAY)
16713 {
16714 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16715 | FFESYMBOL_attrsADJUSTABLE
16716 | FFESYMBOL_attrsTYPE)));
16717
16718 if (sa & FFESYMBOL_attrsADJUSTABLE)
16719 error = TRUE;
16720 where = FFEINFO_whereLOCAL;
16721 }
16722 else if (sa & FFESYMBOL_attrsSFARG)
16723 {
16724 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16725 | FFESYMBOL_attrsTYPE)));
16726
16727 where = FFEINFO_whereLOCAL;
16728 }
16729 else if (sa & FFESYMBOL_attrsTYPE)
16730 {
16731 assert (!(sa & (FFESYMBOL_attrsARRAY
16732 | FFESYMBOL_attrsDUMMY
16733 | FFESYMBOL_attrsEXTERNAL
16734 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16735 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16736 | FFESYMBOL_attrsADJUSTABLE
16737 | FFESYMBOL_attrsANYLEN
16738 | FFESYMBOL_attrsARRAY
16739 | FFESYMBOL_attrsDUMMY
16740 | FFESYMBOL_attrsEXTERNAL
16741 | FFESYMBOL_attrsSFARG)));
16742
16743 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16744 error = TRUE;
16745 else
16746 {
16747 kind = FFEINFO_kindENTITY;
16748 where = FFEINFO_whereLOCAL;
16749 }
16750 }
16751 else if (sa == FFESYMBOL_attrsetNONE)
16752 {
16753 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16754 kind = FFEINFO_kindENTITY;
16755 where = FFEINFO_whereLOCAL;
16756 }
16757 else
16758 error = TRUE;
16759
16760 /* Now see what we've got for a new object: NONE means a new error cropped
16761 up; ANY means an old error to be ignored; otherwise, everything's ok,
16762 update the object (symbol) and continue on. */
16763
16764 if (error)
16765 ffesymbol_error (s, t);
16766 else if (!(na & FFESYMBOL_attrsANY))
16767 {
16768 ffesymbol_signal_change (s); /* May need to back up to previous
16769 version. */
16770 if (!ffeimplic_establish_symbol (s))
16771 {
16772 ffesymbol_error (s, t);
16773 return s;
16774 }
16775 ffesymbol_set_info (s,
16776 ffeinfo_new (ffesymbol_basictype (s),
16777 ffesymbol_kindtype (s),
16778 ffesymbol_rank (s),
16779 kind, /* ENTITY. */
16780 where, /* LOCAL. */
16781 ffesymbol_size (s)));
16782 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16783 ffesymbol_resolve_intrin (s);
16784 s = ffecom_sym_learned (s);
16785 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16786 }
16787
16788 return s;
16789 }
16790
16791 /* Have FOO in EQUIVALENCE (...,FOO,...). Does not include
16792 EQUIVALENCE (...,BAR(FOO),...). */
16793
16794 static ffesymbol
16795 ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t)
16796 {
16797 ffesymbolAttrs sa;
16798 ffesymbolAttrs na;
16799 ffeinfoKind kind;
16800 ffeinfoWhere where;
16801
16802 na = sa = ffesymbol_attrs (s);
16803 kind = FFEINFO_kindENTITY;
16804 where = ffesymbol_where (s);
16805
16806 /* Figure out what kind of object we've got based on previous declarations
16807 of or references to the object. */
16808
16809 if (!(sa & ~(FFESYMBOL_attrsADJUSTS
16810 | FFESYMBOL_attrsARRAY
16811 | FFESYMBOL_attrsCOMMON
16812 | FFESYMBOL_attrsEQUIV
16813 | FFESYMBOL_attrsINIT
16814 | FFESYMBOL_attrsNAMELIST
16815 | FFESYMBOL_attrsSAVE
16816 | FFESYMBOL_attrsSFARG
16817 | FFESYMBOL_attrsTYPE)))
16818 na = sa | FFESYMBOL_attrsEQUIV;
16819 else
16820 na = FFESYMBOL_attrsetNONE;
16821
16822 /* Don't know why we're bothering to set kind and where in this code, but
16823 added the following to make it complete, in case it's really important.
16824 Generally this is left up to symbol exec transition. */
16825
16826 if (where == FFEINFO_whereNONE)
16827 {
16828 if (na & (FFESYMBOL_attrsADJUSTS
16829 | FFESYMBOL_attrsCOMMON))
16830 where = FFEINFO_whereCOMMON;
16831 else if (na & FFESYMBOL_attrsSAVE)
16832 where = FFEINFO_whereLOCAL;
16833 }
16834
16835 /* Now see what we've got for a new object: NONE means a new error cropped
16836 up; ANY means an old error to be ignored; otherwise, everything's ok,
16837 update the object (symbol) and continue on. */
16838
16839 if (na == FFESYMBOL_attrsetNONE)
16840 ffesymbol_error (s, t);
16841 else if (!(na & FFESYMBOL_attrsANY))
16842 {
16843 ffesymbol_signal_change (s); /* May need to back up to previous
16844 version. */
16845 ffesymbol_set_info (s,
16846 ffeinfo_new (ffesymbol_basictype (s),
16847 ffesymbol_kindtype (s),
16848 ffesymbol_rank (s),
16849 kind, /* Always ENTITY. */
16850 where, /* NONE, COMMON, or LOCAL. */
16851 ffesymbol_size (s)));
16852 ffesymbol_set_attrs (s, na);
16853 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
16854 ffesymbol_resolve_intrin (s);
16855 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16856 }
16857
16858 return s;
16859 }
16860
16861 /* Have FOO in OPEN(...,USEROPEN=FOO,...). Executable context only.
16862
16863 Note that I think this should be considered semantically similar to
16864 doing CALL XYZ(FOO), in that it should be considered like an
16865 ACTUALARG context. In particular, without EXTERNAL being specified,
16866 it should not be allowed. */
16867
16868 static ffesymbol
16869 ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t)
16870 {
16871 ffesymbolAttrs sa;
16872 ffesymbolAttrs na;
16873 ffeinfoKind kind;
16874 ffeinfoWhere where;
16875 bool needs_type = FALSE;
16876 bool error = FALSE;
16877
16878 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16879 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16880
16881 na = sa = ffesymbol_attrs (s);
16882
16883 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16884 | FFESYMBOL_attrsADJUSTABLE
16885 | FFESYMBOL_attrsANYLEN
16886 | FFESYMBOL_attrsARRAY
16887 | FFESYMBOL_attrsDUMMY
16888 | FFESYMBOL_attrsEXTERNAL
16889 | FFESYMBOL_attrsSFARG
16890 | FFESYMBOL_attrsTYPE)));
16891
16892 kind = ffesymbol_kind (s);
16893 where = ffesymbol_where (s);
16894
16895 /* Figure out what kind of object we've got based on previous declarations
16896 of or references to the object. */
16897
16898 if (sa & FFESYMBOL_attrsEXTERNAL)
16899 {
16900 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16901 | FFESYMBOL_attrsDUMMY
16902 | FFESYMBOL_attrsEXTERNAL
16903 | FFESYMBOL_attrsTYPE)));
16904
16905 if (sa & FFESYMBOL_attrsTYPE)
16906 where = FFEINFO_whereGLOBAL;
16907 else
16908 /* Not TYPE. */
16909 {
16910 kind = FFEINFO_kindFUNCTION;
16911 needs_type = TRUE;
16912
16913 if (sa & FFESYMBOL_attrsDUMMY)
16914 ; /* Not TYPE. */
16915 else if (sa & FFESYMBOL_attrsACTUALARG)
16916 ; /* Not DUMMY or TYPE. */
16917 else /* Not ACTUALARG, DUMMY, or TYPE. */
16918 where = FFEINFO_whereGLOBAL;
16919 }
16920 }
16921 else if (sa & FFESYMBOL_attrsDUMMY)
16922 {
16923 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16924 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16925 | FFESYMBOL_attrsEXTERNAL
16926 | FFESYMBOL_attrsTYPE)));
16927
16928 kind = FFEINFO_kindFUNCTION;
16929 if (!(sa & FFESYMBOL_attrsTYPE))
16930 needs_type = TRUE;
16931 }
16932 else if (sa & FFESYMBOL_attrsARRAY)
16933 {
16934 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16935 | FFESYMBOL_attrsADJUSTABLE
16936 | FFESYMBOL_attrsTYPE)));
16937
16938 error = TRUE;
16939 }
16940 else if (sa & FFESYMBOL_attrsSFARG)
16941 {
16942 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16943 | FFESYMBOL_attrsTYPE)));
16944
16945 error = TRUE;
16946 }
16947 else if (sa & FFESYMBOL_attrsTYPE)
16948 {
16949 assert (!(sa & (FFESYMBOL_attrsARRAY
16950 | FFESYMBOL_attrsDUMMY
16951 | FFESYMBOL_attrsEXTERNAL
16952 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16953 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16954 | FFESYMBOL_attrsADJUSTABLE
16955 | FFESYMBOL_attrsANYLEN
16956 | FFESYMBOL_attrsARRAY
16957 | FFESYMBOL_attrsDUMMY
16958 | FFESYMBOL_attrsEXTERNAL
16959 | FFESYMBOL_attrsSFARG)));
16960
16961 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16962 error = TRUE;
16963 else
16964 {
16965 kind = FFEINFO_kindFUNCTION;
16966 where = FFEINFO_whereGLOBAL;
16967 }
16968 }
16969 else if (sa == FFESYMBOL_attrsetNONE)
16970 {
16971 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16972 kind = FFEINFO_kindFUNCTION;
16973 where = FFEINFO_whereGLOBAL;
16974 needs_type = TRUE;
16975 }
16976 else
16977 error = TRUE;
16978
16979 /* Now see what we've got for a new object: NONE means a new error cropped
16980 up; ANY means an old error to be ignored; otherwise, everything's ok,
16981 update the object (symbol) and continue on. */
16982
16983 if (error)
16984 ffesymbol_error (s, t);
16985 else if (!(na & FFESYMBOL_attrsANY))
16986 {
16987 ffesymbol_signal_change (s); /* May need to back up to previous
16988 version. */
16989 if (needs_type && !ffeimplic_establish_symbol (s))
16990 {
16991 ffesymbol_error (s, t);
16992 return s;
16993 }
16994 if (!ffesymbol_explicitwhere (s))
16995 {
16996 ffebad_start (FFEBAD_NEED_EXTERNAL);
16997 ffebad_here (0, ffelex_token_where_line (t),
16998 ffelex_token_where_column (t));
16999 ffebad_string (ffesymbol_text (s));
17000 ffebad_finish ();
17001 ffesymbol_set_explicitwhere (s, TRUE);
17002 }
17003 ffesymbol_set_info (s,
17004 ffeinfo_new (ffesymbol_basictype (s),
17005 ffesymbol_kindtype (s),
17006 ffesymbol_rank (s),
17007 kind, /* FUNCTION. */
17008 where, /* GLOBAL or DUMMY. */
17009 ffesymbol_size (s)));
17010 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17011 ffesymbol_resolve_intrin (s);
17012 ffesymbol_reference (s, t, FALSE);
17013 s = ffecom_sym_learned (s);
17014 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17015 }
17016
17017 return s;
17018 }
17019
17020 /* Have FOO in DATA (stuff,FOO=1,10)/.../. */
17021
17022 static ffesymbol
17023 ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t)
17024 {
17025 ffesymbolState ss;
17026
17027 /* If the symbol isn't in the sfunc name space, pretend as though we saw a
17028 reference to it already within the imp-DO construct at this level, so as
17029 to get a symbol that is in the sfunc name space. But this is an
17030 erroneous construct, and should be caught elsewhere. */
17031
17032 if (ffesymbol_sfdummyparent (s) == NULL)
17033 {
17034 s = ffeexpr_sym_impdoitem_ (s, t);
17035 if (ffesymbol_sfdummyparent (s) == NULL)
17036 { /* PARAMETER FOO...DATA (A(I),FOO=...). */
17037 ffesymbol_error (s, t);
17038 return s;
17039 }
17040 }
17041
17042 ss = ffesymbol_state (s);
17043
17044 switch (ss)
17045 {
17046 case FFESYMBOL_stateNONE: /* Used as iterator already. */
17047 if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
17048 ffesymbol_error (s, t); /* Can't reuse dead iterator. F90 disallows
17049 this; F77 allows it but it is a stupid
17050 feature. */
17051 else
17052 { /* Can use dead iterator because we're at at
17053 least a innermore (higher-numbered) level
17054 than the iterator's outermost
17055 (lowest-numbered) level. This should be
17056 diagnosed later, because it means an item
17057 in this list didn't reference this
17058 iterator. */
17059 #if 1
17060 ffesymbol_error (s, t); /* For now, complain. */
17061 #else /* Someday will detect all cases where initializer doesn't reference
17062 all applicable iterators, in which case reenable this code. */
17063 ffesymbol_signal_change (s);
17064 ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
17065 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
17066 ffesymbol_signal_unreported (s);
17067 #endif
17068 }
17069 break;
17070
17071 case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO.
17072 If seen in outermore level, can't be an
17073 iterator here, so complain. If not seen
17074 at current level, complain for now,
17075 because that indicates something F90
17076 rejects (though we currently don't detect
17077 all such cases for now). */
17078 if (ffeexpr_level_ <= ffesymbol_maxentrynum (s))
17079 {
17080 ffesymbol_signal_change (s);
17081 ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
17082 ffesymbol_signal_unreported (s);
17083 }
17084 else
17085 ffesymbol_error (s, t);
17086 break;
17087
17088 case FFESYMBOL_stateUNCERTAIN: /* Already iterator! */
17089 assert ("DATA implied-DO control var seen twice!!" == NULL);
17090 ffesymbol_error (s, t);
17091 break;
17092
17093 case FFESYMBOL_stateUNDERSTOOD:
17094 break; /* ANY. */
17095
17096 default:
17097 assert ("Foo Bletch!!" == NULL);
17098 break;
17099 }
17100
17101 return s;
17102 }
17103
17104 /* Have FOO in PARAMETER (FOO=...). */
17105
17106 static ffesymbol
17107 ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t)
17108 {
17109 ffesymbolAttrs sa;
17110
17111 sa = ffesymbol_attrs (s);
17112
17113 /* Figure out what kind of object we've got based on previous declarations
17114 of or references to the object. */
17115
17116 if (sa & ~(FFESYMBOL_attrsANYLEN
17117 | FFESYMBOL_attrsTYPE))
17118 {
17119 if (!(sa & FFESYMBOL_attrsANY))
17120 ffesymbol_error (s, t);
17121 }
17122 else
17123 {
17124 ffesymbol_signal_change (s); /* May need to back up to previous
17125 version. */
17126 if (!ffeimplic_establish_symbol (s))
17127 {
17128 ffesymbol_error (s, t);
17129 return s;
17130 }
17131 ffesymbol_set_info (s,
17132 ffeinfo_new (ffesymbol_basictype (s),
17133 ffesymbol_kindtype (s),
17134 ffesymbol_rank (s),
17135 FFEINFO_kindENTITY,
17136 FFEINFO_whereCONSTANT,
17137 ffesymbol_size (s)));
17138 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17139 ffesymbol_resolve_intrin (s);
17140 s = ffecom_sym_learned (s);
17141 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17142 }
17143
17144 return s;
17145 }
17146
17147 /* Have FOO in CALL XYZ(...,FOO,...). Does not include any other
17148 embedding of FOO, such as CALL XYZ((FOO)) or CALL XYZ(FOO+1). */
17149
17150 static ffesymbol
17151 ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t)
17152 {
17153 ffesymbolAttrs sa;
17154 ffesymbolAttrs na;
17155 ffeinfoKind kind;
17156 ffeinfoWhere where;
17157 ffesymbolState ns;
17158 bool needs_type = FALSE;
17159
17160 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
17161 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
17162
17163 na = sa = ffesymbol_attrs (s);
17164
17165 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17166 | FFESYMBOL_attrsADJUSTABLE
17167 | FFESYMBOL_attrsANYLEN
17168 | FFESYMBOL_attrsARRAY
17169 | FFESYMBOL_attrsDUMMY
17170 | FFESYMBOL_attrsEXTERNAL
17171 | FFESYMBOL_attrsSFARG
17172 | FFESYMBOL_attrsTYPE)));
17173
17174 kind = ffesymbol_kind (s);
17175 where = ffesymbol_where (s);
17176
17177 /* Figure out what kind of object we've got based on previous declarations
17178 of or references to the object. */
17179
17180 ns = FFESYMBOL_stateUNDERSTOOD;
17181
17182 if (sa & FFESYMBOL_attrsEXTERNAL)
17183 {
17184 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17185 | FFESYMBOL_attrsDUMMY
17186 | FFESYMBOL_attrsEXTERNAL
17187 | FFESYMBOL_attrsTYPE)));
17188
17189 if (sa & FFESYMBOL_attrsTYPE)
17190 where = FFEINFO_whereGLOBAL;
17191 else
17192 /* Not TYPE. */
17193 {
17194 ns = FFESYMBOL_stateUNCERTAIN;
17195
17196 if (sa & FFESYMBOL_attrsDUMMY)
17197 assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */
17198 else if (sa & FFESYMBOL_attrsACTUALARG)
17199 ; /* Not DUMMY or TYPE. */
17200 else
17201 /* Not ACTUALARG, DUMMY, or TYPE. */
17202 {
17203 assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */
17204 na |= FFESYMBOL_attrsACTUALARG;
17205 where = FFEINFO_whereGLOBAL;
17206 }
17207 }
17208 }
17209 else if (sa & FFESYMBOL_attrsDUMMY)
17210 {
17211 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
17212 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
17213 | FFESYMBOL_attrsEXTERNAL
17214 | FFESYMBOL_attrsTYPE)));
17215
17216 kind = FFEINFO_kindENTITY;
17217 if (!(sa & FFESYMBOL_attrsTYPE))
17218 needs_type = TRUE;
17219 }
17220 else if (sa & FFESYMBOL_attrsARRAY)
17221 {
17222 assert (!(sa & ~(FFESYMBOL_attrsARRAY
17223 | FFESYMBOL_attrsADJUSTABLE
17224 | FFESYMBOL_attrsTYPE)));
17225
17226 where = FFEINFO_whereLOCAL;
17227 }
17228 else if (sa & FFESYMBOL_attrsSFARG)
17229 {
17230 assert (!(sa & ~(FFESYMBOL_attrsSFARG
17231 | FFESYMBOL_attrsTYPE)));
17232
17233 where = FFEINFO_whereLOCAL;
17234 }
17235 else if (sa & FFESYMBOL_attrsTYPE)
17236 {
17237 assert (!(sa & (FFESYMBOL_attrsARRAY
17238 | FFESYMBOL_attrsDUMMY
17239 | FFESYMBOL_attrsEXTERNAL
17240 | FFESYMBOL_attrsSFARG))); /* Handled above. */
17241 assert (!(sa & ~(FFESYMBOL_attrsTYPE
17242 | FFESYMBOL_attrsADJUSTABLE
17243 | FFESYMBOL_attrsANYLEN
17244 | FFESYMBOL_attrsARRAY
17245 | FFESYMBOL_attrsDUMMY
17246 | FFESYMBOL_attrsEXTERNAL
17247 | FFESYMBOL_attrsSFARG)));
17248
17249 if (sa & FFESYMBOL_attrsANYLEN)
17250 ns = FFESYMBOL_stateNONE;
17251 else
17252 {
17253 kind = FFEINFO_kindENTITY;
17254 where = FFEINFO_whereLOCAL;
17255 }
17256 }
17257 else if (sa == FFESYMBOL_attrsetNONE)
17258 {
17259 /* New state is left empty because there isn't any state flag to
17260 set for this case, and it's UNDERSTOOD after all. */
17261 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
17262 kind = FFEINFO_kindENTITY;
17263 where = FFEINFO_whereLOCAL;
17264 needs_type = TRUE;
17265 }
17266 else
17267 ns = FFESYMBOL_stateNONE; /* Error. */
17268
17269 /* Now see what we've got for a new object: NONE means a new error cropped
17270 up; ANY means an old error to be ignored; otherwise, everything's ok,
17271 update the object (symbol) and continue on. */
17272
17273 if (ns == FFESYMBOL_stateNONE)
17274 ffesymbol_error (s, t);
17275 else if (!(na & FFESYMBOL_attrsANY))
17276 {
17277 ffesymbol_signal_change (s); /* May need to back up to previous
17278 version. */
17279 if (needs_type && !ffeimplic_establish_symbol (s))
17280 {
17281 ffesymbol_error (s, t);
17282 return s;
17283 }
17284 ffesymbol_set_info (s,
17285 ffeinfo_new (ffesymbol_basictype (s),
17286 ffesymbol_kindtype (s),
17287 ffesymbol_rank (s),
17288 kind,
17289 where,
17290 ffesymbol_size (s)));
17291 ffesymbol_set_attrs (s, na);
17292 ffesymbol_set_state (s, ns);
17293 s = ffecom_sym_learned (s);
17294 ffesymbol_reference (s, t, FALSE);
17295 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17296 }
17297
17298 return s;
17299 }
17300
17301 /* Have FOO in DIMENSION XYZ(FOO) or any array declarator containing
17302 a reference to FOO. */
17303
17304 static ffesymbol
17305 ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t)
17306 {
17307 ffesymbolAttrs sa;
17308 ffesymbolAttrs na;
17309 ffeinfoKind kind;
17310 ffeinfoWhere where;
17311
17312 na = sa = ffesymbol_attrs (s);
17313 kind = FFEINFO_kindENTITY;
17314 where = ffesymbol_where (s);
17315
17316 /* Figure out what kind of object we've got based on previous declarations
17317 of or references to the object. */
17318
17319 if (!(sa & ~(FFESYMBOL_attrsADJUSTS
17320 | FFESYMBOL_attrsCOMMON
17321 | FFESYMBOL_attrsDUMMY
17322 | FFESYMBOL_attrsEQUIV
17323 | FFESYMBOL_attrsINIT
17324 | FFESYMBOL_attrsNAMELIST
17325 | FFESYMBOL_attrsSFARG
17326 | FFESYMBOL_attrsTYPE)))
17327 na = sa | FFESYMBOL_attrsADJUSTS;
17328 else
17329 na = FFESYMBOL_attrsetNONE;
17330
17331 /* Since this symbol definitely is going into an expression (the
17332 dimension-list for some dummy array, presumably), figure out WHERE if
17333 possible. */
17334
17335 if (where == FFEINFO_whereNONE)
17336 {
17337 if (na & (FFESYMBOL_attrsCOMMON
17338 | FFESYMBOL_attrsEQUIV
17339 | FFESYMBOL_attrsINIT
17340 | FFESYMBOL_attrsNAMELIST))
17341 where = FFEINFO_whereCOMMON;
17342 else if (na & FFESYMBOL_attrsDUMMY)
17343 where = FFEINFO_whereDUMMY;
17344 }
17345
17346 /* Now see what we've got for a new object: NONE means a new error cropped
17347 up; ANY means an old error to be ignored; otherwise, everything's ok,
17348 update the object (symbol) and continue on. */
17349
17350 if (na == FFESYMBOL_attrsetNONE)
17351 ffesymbol_error (s, t);
17352 else if (!(na & FFESYMBOL_attrsANY))
17353 {
17354 ffesymbol_signal_change (s); /* May need to back up to previous
17355 version. */
17356 if (!ffeimplic_establish_symbol (s))
17357 {
17358 ffesymbol_error (s, t);
17359 return s;
17360 }
17361 ffesymbol_set_info (s,
17362 ffeinfo_new (ffesymbol_basictype (s),
17363 ffesymbol_kindtype (s),
17364 ffesymbol_rank (s),
17365 kind, /* Always ENTITY. */
17366 where, /* NONE, COMMON, or DUMMY. */
17367 ffesymbol_size (s)));
17368 ffesymbol_set_attrs (s, na);
17369 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
17370 ffesymbol_resolve_intrin (s);
17371 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17372 }
17373
17374 return s;
17375 }
17376
17377 /* Have FOO in XYZ = ...FOO.... Does not include cases like FOO in
17378 XYZ = BAR(FOO), as such cases are handled elsewhere. */
17379
17380 static ffesymbol
17381 ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t)
17382 {
17383 ffesymbolAttrs sa;
17384 ffesymbolAttrs na;
17385 ffeinfoKind kind;
17386 ffeinfoWhere where;
17387 bool error = FALSE;
17388
17389 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
17390 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
17391
17392 na = sa = ffesymbol_attrs (s);
17393
17394 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17395 | FFESYMBOL_attrsADJUSTABLE
17396 | FFESYMBOL_attrsANYLEN
17397 | FFESYMBOL_attrsARRAY
17398 | FFESYMBOL_attrsDUMMY
17399 | FFESYMBOL_attrsEXTERNAL
17400 | FFESYMBOL_attrsSFARG
17401 | FFESYMBOL_attrsTYPE)));
17402
17403 kind = ffesymbol_kind (s);
17404 where = ffesymbol_where (s);
17405
17406 /* Figure out what kind of object we've got based on previous declarations
17407 of or references to the object. */
17408
17409 if (sa & FFESYMBOL_attrsEXTERNAL)
17410 {
17411 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17412 | FFESYMBOL_attrsDUMMY
17413 | FFESYMBOL_attrsEXTERNAL
17414 | FFESYMBOL_attrsTYPE)));
17415
17416 error = TRUE;
17417 }
17418 else if (sa & FFESYMBOL_attrsDUMMY)
17419 {
17420 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
17421 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
17422 | FFESYMBOL_attrsEXTERNAL
17423 | FFESYMBOL_attrsTYPE)));
17424
17425 kind = FFEINFO_kindENTITY;
17426 }
17427 else if (sa & FFESYMBOL_attrsARRAY)
17428 {
17429 assert (!(sa & ~(FFESYMBOL_attrsARRAY
17430 | FFESYMBOL_attrsADJUSTABLE
17431 | FFESYMBOL_attrsTYPE)));
17432
17433 where = FFEINFO_whereLOCAL;
17434 }
17435 else if (sa & FFESYMBOL_attrsSFARG)
17436 {
17437 assert (!(sa & ~(FFESYMBOL_attrsSFARG
17438 | FFESYMBOL_attrsTYPE)));
17439
17440 where = FFEINFO_whereLOCAL;
17441 }
17442 else if (sa & FFESYMBOL_attrsTYPE)
17443 {
17444 assert (!(sa & (FFESYMBOL_attrsARRAY
17445 | FFESYMBOL_attrsDUMMY
17446 | FFESYMBOL_attrsEXTERNAL
17447 | FFESYMBOL_attrsSFARG))); /* Handled above. */
17448 assert (!(sa & ~(FFESYMBOL_attrsTYPE
17449 | FFESYMBOL_attrsADJUSTABLE
17450 | FFESYMBOL_attrsANYLEN
17451 | FFESYMBOL_attrsARRAY
17452 | FFESYMBOL_attrsDUMMY
17453 | FFESYMBOL_attrsEXTERNAL
17454 | FFESYMBOL_attrsSFARG)));
17455
17456 if (sa & FFESYMBOL_attrsANYLEN)
17457 error = TRUE;
17458 else
17459 {
17460 kind = FFEINFO_kindENTITY;
17461 where = FFEINFO_whereLOCAL;
17462 }
17463 }
17464 else if (sa == FFESYMBOL_attrsetNONE)
17465 {
17466 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
17467 kind = FFEINFO_kindENTITY;
17468 where = FFEINFO_whereLOCAL;
17469 }
17470 else
17471 error = TRUE;
17472
17473 /* Now see what we've got for a new object: NONE means a new error cropped
17474 up; ANY means an old error to be ignored; otherwise, everything's ok,
17475 update the object (symbol) and continue on. */
17476
17477 if (error)
17478 ffesymbol_error (s, t);
17479 else if (!(na & FFESYMBOL_attrsANY))
17480 {
17481 ffesymbol_signal_change (s); /* May need to back up to previous
17482 version. */
17483 if (!ffeimplic_establish_symbol (s))
17484 {
17485 ffesymbol_error (s, t);
17486 return s;
17487 }
17488 ffesymbol_set_info (s,
17489 ffeinfo_new (ffesymbol_basictype (s),
17490 ffesymbol_kindtype (s),
17491 ffesymbol_rank (s),
17492 kind, /* ENTITY. */
17493 where, /* LOCAL. */
17494 ffesymbol_size (s)));
17495 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17496 ffesymbol_resolve_intrin (s);
17497 s = ffecom_sym_learned (s);
17498 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17499 }
17500
17501 return s;
17502 }
17503
17504 /* ffeexpr_declare_parenthesized_ -- ffesymbol wrapper for NAME(...) operand
17505
17506 ffelexToken t;
17507 bool maybe_intrin;
17508 ffeexprParenType_ paren_type;
17509 ffesymbol s;
17510 s = ffeexpr_declare_parenthesized_ (t, maybe_intrin, &paren_type);
17511
17512 Just like ffesymbol_declare_local, except performs any implicit info
17513 assignment necessary, and it returns the type of the parenthesized list
17514 (list of function args, list of array args, or substring spec). */
17515
17516 static ffesymbol
17517 ffeexpr_declare_parenthesized_ (ffelexToken t, bool maybe_intrin,
17518 ffeexprParenType_ *paren_type)
17519 {
17520 ffesymbol s;
17521 ffesymbolState st; /* Effective state. */
17522 ffeinfoKind k;
17523 bool bad;
17524
17525 if (maybe_intrin && ffesrc_check_symbol ())
17526 { /* Knock off some easy cases. */
17527 switch (ffeexpr_stack_->context)
17528 {
17529 case FFEEXPR_contextSUBROUTINEREF:
17530 case FFEEXPR_contextDATA:
17531 case FFEEXPR_contextDATAIMPDOINDEX_:
17532 case FFEEXPR_contextSFUNCDEF:
17533 case FFEEXPR_contextSFUNCDEFINDEX_:
17534 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17535 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17536 case FFEEXPR_contextLET:
17537 case FFEEXPR_contextPAREN_:
17538 case FFEEXPR_contextACTUALARGEXPR_:
17539 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17540 case FFEEXPR_contextIOLIST:
17541 case FFEEXPR_contextIOLISTDF:
17542 case FFEEXPR_contextDO:
17543 case FFEEXPR_contextDOWHILE:
17544 case FFEEXPR_contextACTUALARG_:
17545 case FFEEXPR_contextCGOTO:
17546 case FFEEXPR_contextIF:
17547 case FFEEXPR_contextARITHIF:
17548 case FFEEXPR_contextFORMAT:
17549 case FFEEXPR_contextSTOP:
17550 case FFEEXPR_contextRETURN:
17551 case FFEEXPR_contextSELECTCASE:
17552 case FFEEXPR_contextCASE:
17553 case FFEEXPR_contextFILEASSOC:
17554 case FFEEXPR_contextFILEINT:
17555 case FFEEXPR_contextFILEDFINT:
17556 case FFEEXPR_contextFILELOG:
17557 case FFEEXPR_contextFILENUM:
17558 case FFEEXPR_contextFILENUMAMBIG:
17559 case FFEEXPR_contextFILECHAR:
17560 case FFEEXPR_contextFILENUMCHAR:
17561 case FFEEXPR_contextFILEDFCHAR:
17562 case FFEEXPR_contextFILEKEY:
17563 case FFEEXPR_contextFILEUNIT:
17564 case FFEEXPR_contextFILEUNIT_DF:
17565 case FFEEXPR_contextFILEUNITAMBIG:
17566 case FFEEXPR_contextFILEFORMAT:
17567 case FFEEXPR_contextFILENAMELIST:
17568 case FFEEXPR_contextFILEVXTCODE:
17569 case FFEEXPR_contextINDEX_:
17570 case FFEEXPR_contextIMPDOITEM_:
17571 case FFEEXPR_contextIMPDOITEMDF_:
17572 case FFEEXPR_contextIMPDOCTRL_:
17573 case FFEEXPR_contextDATAIMPDOCTRL_:
17574 case FFEEXPR_contextCHARACTERSIZE:
17575 case FFEEXPR_contextPARAMETER:
17576 case FFEEXPR_contextDIMLIST:
17577 case FFEEXPR_contextDIMLISTCOMMON:
17578 case FFEEXPR_contextKINDTYPE:
17579 case FFEEXPR_contextINITVAL:
17580 case FFEEXPR_contextEQVINDEX_:
17581 break; /* These could be intrinsic invocations. */
17582
17583 case FFEEXPR_contextAGOTO:
17584 case FFEEXPR_contextFILEFORMATNML:
17585 case FFEEXPR_contextALLOCATE:
17586 case FFEEXPR_contextDEALLOCATE:
17587 case FFEEXPR_contextHEAPSTAT:
17588 case FFEEXPR_contextNULLIFY:
17589 case FFEEXPR_contextINCLUDE:
17590 case FFEEXPR_contextDATAIMPDOITEM_:
17591 case FFEEXPR_contextLOC_:
17592 case FFEEXPR_contextINDEXORACTUALARG_:
17593 case FFEEXPR_contextSFUNCDEFACTUALARG_:
17594 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
17595 case FFEEXPR_contextPARENFILENUM_:
17596 case FFEEXPR_contextPARENFILEUNIT_:
17597 maybe_intrin = FALSE;
17598 break; /* Can't be intrinsic invocation. */
17599
17600 default:
17601 assert ("blah! blah! waaauuggh!" == NULL);
17602 break;
17603 }
17604 }
17605
17606 s = ffesymbol_declare_local (t, maybe_intrin);
17607
17608 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17609 /* Special-case these since they can involve a different concept
17610 of "state" (in the stmtfunc name space). */
17611 {
17612 case FFEEXPR_contextDATAIMPDOINDEX_:
17613 case FFEEXPR_contextDATAIMPDOCTRL_:
17614 if (ffeexpr_context_outer_ (ffeexpr_stack_)
17615 == FFEEXPR_contextDATAIMPDOINDEX_)
17616 s = ffeexpr_sym_impdoitem_ (s, t);
17617 else
17618 if (ffeexpr_stack_->is_rhs)
17619 s = ffeexpr_sym_impdoitem_ (s, t);
17620 else
17621 s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
17622 if (ffesymbol_kind (s) != FFEINFO_kindANY)
17623 ffesymbol_error (s, t);
17624 return s;
17625
17626 default:
17627 break;
17628 }
17629
17630 switch ((ffesymbol_sfdummyparent (s) == NULL)
17631 ? ffesymbol_state (s)
17632 : FFESYMBOL_stateUNDERSTOOD)
17633 {
17634 case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr
17635 context. */
17636 if (!ffest_seen_first_exec ())
17637 goto seen; /* :::::::::::::::::::: */
17638 /* Fall through. */
17639 case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */
17640 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17641 {
17642 case FFEEXPR_contextSUBROUTINEREF:
17643 s = ffeexpr_sym_lhs_call_ (s, t); /* "CALL FOO"=="CALL
17644 FOO(...)". */
17645 break;
17646
17647 case FFEEXPR_contextDATA:
17648 if (ffeexpr_stack_->is_rhs)
17649 s = ffeexpr_sym_rhs_let_ (s, t);
17650 else
17651 s = ffeexpr_sym_lhs_data_ (s, t);
17652 break;
17653
17654 case FFEEXPR_contextDATAIMPDOITEM_:
17655 s = ffeexpr_sym_lhs_data_ (s, t);
17656 break;
17657
17658 case FFEEXPR_contextSFUNCDEF:
17659 case FFEEXPR_contextSFUNCDEFINDEX_:
17660 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17661 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17662 s = ffecom_sym_exec_transition (s);
17663 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17664 goto understood; /* :::::::::::::::::::: */
17665 /* Fall through. */
17666 case FFEEXPR_contextLET:
17667 case FFEEXPR_contextPAREN_:
17668 case FFEEXPR_contextACTUALARGEXPR_:
17669 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17670 case FFEEXPR_contextIOLIST:
17671 case FFEEXPR_contextIOLISTDF:
17672 case FFEEXPR_contextDO:
17673 case FFEEXPR_contextDOWHILE:
17674 case FFEEXPR_contextACTUALARG_:
17675 case FFEEXPR_contextCGOTO:
17676 case FFEEXPR_contextIF:
17677 case FFEEXPR_contextARITHIF:
17678 case FFEEXPR_contextFORMAT:
17679 case FFEEXPR_contextSTOP:
17680 case FFEEXPR_contextRETURN:
17681 case FFEEXPR_contextSELECTCASE:
17682 case FFEEXPR_contextCASE:
17683 case FFEEXPR_contextFILEASSOC:
17684 case FFEEXPR_contextFILEINT:
17685 case FFEEXPR_contextFILEDFINT:
17686 case FFEEXPR_contextFILELOG:
17687 case FFEEXPR_contextFILENUM:
17688 case FFEEXPR_contextFILENUMAMBIG:
17689 case FFEEXPR_contextFILECHAR:
17690 case FFEEXPR_contextFILENUMCHAR:
17691 case FFEEXPR_contextFILEDFCHAR:
17692 case FFEEXPR_contextFILEKEY:
17693 case FFEEXPR_contextFILEUNIT:
17694 case FFEEXPR_contextFILEUNIT_DF:
17695 case FFEEXPR_contextFILEUNITAMBIG:
17696 case FFEEXPR_contextFILEFORMAT:
17697 case FFEEXPR_contextFILENAMELIST:
17698 case FFEEXPR_contextFILEVXTCODE:
17699 case FFEEXPR_contextINDEX_:
17700 case FFEEXPR_contextIMPDOITEM_:
17701 case FFEEXPR_contextIMPDOITEMDF_:
17702 case FFEEXPR_contextIMPDOCTRL_:
17703 case FFEEXPR_contextLOC_:
17704 if (ffeexpr_stack_->is_rhs)
17705 s = ffeexpr_paren_rhs_let_ (s, t);
17706 else
17707 s = ffeexpr_paren_lhs_let_ (s, t);
17708 break;
17709
17710 case FFEEXPR_contextASSIGN:
17711 case FFEEXPR_contextAGOTO:
17712 case FFEEXPR_contextCHARACTERSIZE:
17713 case FFEEXPR_contextEQUIVALENCE:
17714 case FFEEXPR_contextINCLUDE:
17715 case FFEEXPR_contextPARAMETER:
17716 case FFEEXPR_contextDIMLIST:
17717 case FFEEXPR_contextDIMLISTCOMMON:
17718 case FFEEXPR_contextKINDTYPE:
17719 case FFEEXPR_contextINITVAL:
17720 case FFEEXPR_contextEQVINDEX_:
17721 break; /* Will turn into errors below. */
17722
17723 default:
17724 ffesymbol_error (s, t);
17725 break;
17726 }
17727 /* Fall through. */
17728 case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */
17729 understood: /* :::::::::::::::::::: */
17730
17731 /* State might have changed, update it. */
17732 st = ((ffesymbol_sfdummyparent (s) == NULL)
17733 ? ffesymbol_state (s)
17734 : FFESYMBOL_stateUNDERSTOOD);
17735
17736 k = ffesymbol_kind (s);
17737 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17738 {
17739 case FFEEXPR_contextSUBROUTINEREF:
17740 bad = ((k != FFEINFO_kindSUBROUTINE)
17741 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
17742 || (k != FFEINFO_kindNONE)));
17743 break;
17744
17745 case FFEEXPR_contextDATA:
17746 if (ffeexpr_stack_->is_rhs)
17747 bad = (k != FFEINFO_kindENTITY)
17748 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
17749 else
17750 bad = (k != FFEINFO_kindENTITY)
17751 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
17752 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
17753 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
17754 break;
17755
17756 case FFEEXPR_contextDATAIMPDOITEM_:
17757 bad = (k != FFEINFO_kindENTITY) || (ffesymbol_rank (s) == 0)
17758 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
17759 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
17760 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
17761 break;
17762
17763 case FFEEXPR_contextSFUNCDEF:
17764 case FFEEXPR_contextSFUNCDEFINDEX_:
17765 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17766 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17767 case FFEEXPR_contextLET:
17768 case FFEEXPR_contextPAREN_:
17769 case FFEEXPR_contextACTUALARGEXPR_:
17770 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17771 case FFEEXPR_contextIOLIST:
17772 case FFEEXPR_contextIOLISTDF:
17773 case FFEEXPR_contextDO:
17774 case FFEEXPR_contextDOWHILE:
17775 case FFEEXPR_contextACTUALARG_:
17776 case FFEEXPR_contextCGOTO:
17777 case FFEEXPR_contextIF:
17778 case FFEEXPR_contextARITHIF:
17779 case FFEEXPR_contextFORMAT:
17780 case FFEEXPR_contextSTOP:
17781 case FFEEXPR_contextRETURN:
17782 case FFEEXPR_contextSELECTCASE:
17783 case FFEEXPR_contextCASE:
17784 case FFEEXPR_contextFILEASSOC:
17785 case FFEEXPR_contextFILEINT:
17786 case FFEEXPR_contextFILEDFINT:
17787 case FFEEXPR_contextFILELOG:
17788 case FFEEXPR_contextFILENUM:
17789 case FFEEXPR_contextFILENUMAMBIG:
17790 case FFEEXPR_contextFILECHAR:
17791 case FFEEXPR_contextFILENUMCHAR:
17792 case FFEEXPR_contextFILEDFCHAR:
17793 case FFEEXPR_contextFILEKEY:
17794 case FFEEXPR_contextFILEUNIT:
17795 case FFEEXPR_contextFILEUNIT_DF:
17796 case FFEEXPR_contextFILEUNITAMBIG:
17797 case FFEEXPR_contextFILEFORMAT:
17798 case FFEEXPR_contextFILENAMELIST:
17799 case FFEEXPR_contextFILEVXTCODE:
17800 case FFEEXPR_contextINDEX_:
17801 case FFEEXPR_contextIMPDOITEM_:
17802 case FFEEXPR_contextIMPDOITEMDF_:
17803 case FFEEXPR_contextIMPDOCTRL_:
17804 case FFEEXPR_contextLOC_:
17805 bad = FALSE; /* Let paren-switch handle the cases. */
17806 break;
17807
17808 case FFEEXPR_contextASSIGN:
17809 case FFEEXPR_contextAGOTO:
17810 case FFEEXPR_contextCHARACTERSIZE:
17811 case FFEEXPR_contextEQUIVALENCE:
17812 case FFEEXPR_contextPARAMETER:
17813 case FFEEXPR_contextDIMLIST:
17814 case FFEEXPR_contextDIMLISTCOMMON:
17815 case FFEEXPR_contextKINDTYPE:
17816 case FFEEXPR_contextINITVAL:
17817 case FFEEXPR_contextEQVINDEX_:
17818 bad = (k != FFEINFO_kindENTITY)
17819 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
17820 break;
17821
17822 case FFEEXPR_contextINCLUDE:
17823 bad = TRUE;
17824 break;
17825
17826 default:
17827 bad = TRUE;
17828 break;
17829 }
17830
17831 switch (bad ? FFEINFO_kindANY : k)
17832 {
17833 case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */
17834 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
17835 {
17836 if (ffeexpr_context_outer_ (ffeexpr_stack_)
17837 == FFEEXPR_contextSUBROUTINEREF)
17838 *paren_type = FFEEXPR_parentypeSUBROUTINE_;
17839 else
17840 *paren_type = FFEEXPR_parentypeFUNCTION_;
17841 break;
17842 }
17843 if (st == FFESYMBOL_stateUNDERSTOOD)
17844 {
17845 bad = TRUE;
17846 *paren_type = FFEEXPR_parentypeANY_;
17847 }
17848 else
17849 *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
17850 break;
17851
17852 case FFEINFO_kindFUNCTION:
17853 *paren_type = FFEEXPR_parentypeFUNCTION_;
17854 switch (ffesymbol_where (s))
17855 {
17856 case FFEINFO_whereLOCAL:
17857 bad = TRUE; /* Attempt to recurse! */
17858 break;
17859
17860 case FFEINFO_whereCONSTANT:
17861 bad = ((ffesymbol_sfexpr (s) == NULL)
17862 || (ffebld_op (ffesymbol_sfexpr (s))
17863 == FFEBLD_opANY)); /* Attempt to recurse! */
17864 break;
17865
17866 default:
17867 break;
17868 }
17869 break;
17870
17871 case FFEINFO_kindSUBROUTINE:
17872 if ((ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
17873 || (ffeexpr_stack_->previous != NULL))
17874 {
17875 bad = TRUE;
17876 *paren_type = FFEEXPR_parentypeANY_;
17877 break;
17878 }
17879
17880 *paren_type = FFEEXPR_parentypeSUBROUTINE_;
17881 switch (ffesymbol_where (s))
17882 {
17883 case FFEINFO_whereLOCAL:
17884 case FFEINFO_whereCONSTANT:
17885 bad = TRUE; /* Attempt to recurse! */
17886 break;
17887
17888 default:
17889 break;
17890 }
17891 break;
17892
17893 case FFEINFO_kindENTITY:
17894 if (ffesymbol_rank (s) == 0)
17895 {
17896 if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
17897 *paren_type = FFEEXPR_parentypeSUBSTRING_;
17898 else
17899 {
17900 bad = TRUE;
17901 *paren_type = FFEEXPR_parentypeANY_;
17902 }
17903 }
17904 else
17905 *paren_type = FFEEXPR_parentypeARRAY_;
17906 break;
17907
17908 default:
17909 case FFEINFO_kindANY:
17910 bad = TRUE;
17911 *paren_type = FFEEXPR_parentypeANY_;
17912 break;
17913 }
17914
17915 if (bad)
17916 {
17917 if (k == FFEINFO_kindANY)
17918 ffest_shutdown ();
17919 else
17920 ffesymbol_error (s, t);
17921 }
17922
17923 return s;
17924
17925 case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */
17926 seen: /* :::::::::::::::::::: */
17927 bad = TRUE;
17928 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17929 {
17930 case FFEEXPR_contextPARAMETER:
17931 if (ffeexpr_stack_->is_rhs)
17932 ffesymbol_error (s, t);
17933 else
17934 s = ffeexpr_sym_lhs_parameter_ (s, t);
17935 break;
17936
17937 case FFEEXPR_contextDATA:
17938 s = ffecom_sym_exec_transition (s);
17939 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17940 goto understood; /* :::::::::::::::::::: */
17941 if (ffeexpr_stack_->is_rhs)
17942 ffesymbol_error (s, t);
17943 else
17944 s = ffeexpr_sym_lhs_data_ (s, t);
17945 goto understood; /* :::::::::::::::::::: */
17946
17947 case FFEEXPR_contextDATAIMPDOITEM_:
17948 s = ffecom_sym_exec_transition (s);
17949 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17950 goto understood; /* :::::::::::::::::::: */
17951 s = ffeexpr_sym_lhs_data_ (s, t);
17952 goto understood; /* :::::::::::::::::::: */
17953
17954 case FFEEXPR_contextEQUIVALENCE:
17955 s = ffeexpr_sym_lhs_equivalence_ (s, t);
17956 bad = FALSE;
17957 break;
17958
17959 case FFEEXPR_contextDIMLIST:
17960 s = ffeexpr_sym_rhs_dimlist_ (s, t);
17961 break;
17962
17963 case FFEEXPR_contextCHARACTERSIZE:
17964 case FFEEXPR_contextKINDTYPE:
17965 case FFEEXPR_contextDIMLISTCOMMON:
17966 case FFEEXPR_contextINITVAL:
17967 case FFEEXPR_contextEQVINDEX_:
17968 break;
17969
17970 case FFEEXPR_contextINCLUDE:
17971 break;
17972
17973 case FFEEXPR_contextINDEX_:
17974 case FFEEXPR_contextACTUALARGEXPR_:
17975 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17976 case FFEEXPR_contextSFUNCDEF:
17977 case FFEEXPR_contextSFUNCDEFINDEX_:
17978 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17979 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17980 assert (ffeexpr_stack_->is_rhs);
17981 s = ffecom_sym_exec_transition (s);
17982 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17983 goto understood; /* :::::::::::::::::::: */
17984 s = ffeexpr_paren_rhs_let_ (s, t);
17985 goto understood; /* :::::::::::::::::::: */
17986
17987 default:
17988 break;
17989 }
17990 k = ffesymbol_kind (s);
17991 switch (bad ? FFEINFO_kindANY : k)
17992 {
17993 case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */
17994 *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
17995 break;
17996
17997 case FFEINFO_kindFUNCTION:
17998 *paren_type = FFEEXPR_parentypeFUNCTION_;
17999 switch (ffesymbol_where (s))
18000 {
18001 case FFEINFO_whereLOCAL:
18002 bad = TRUE; /* Attempt to recurse! */
18003 break;
18004
18005 case FFEINFO_whereCONSTANT:
18006 bad = ((ffesymbol_sfexpr (s) == NULL)
18007 || (ffebld_op (ffesymbol_sfexpr (s))
18008 == FFEBLD_opANY)); /* Attempt to recurse! */
18009 break;
18010
18011 default:
18012 break;
18013 }
18014 break;
18015
18016 case FFEINFO_kindSUBROUTINE:
18017 *paren_type = FFEEXPR_parentypeANY_;
18018 bad = TRUE; /* Cannot possibly be in
18019 contextSUBROUTINEREF. */
18020 break;
18021
18022 case FFEINFO_kindENTITY:
18023 if (ffesymbol_rank (s) == 0)
18024 {
18025 if (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE)
18026 *paren_type = FFEEXPR_parentypeEQUIVALENCE_;
18027 else if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
18028 *paren_type = FFEEXPR_parentypeSUBSTRING_;
18029 else
18030 {
18031 bad = TRUE;
18032 *paren_type = FFEEXPR_parentypeANY_;
18033 }
18034 }
18035 else
18036 *paren_type = FFEEXPR_parentypeARRAY_;
18037 break;
18038
18039 default:
18040 case FFEINFO_kindANY:
18041 bad = TRUE;
18042 *paren_type = FFEEXPR_parentypeANY_;
18043 break;
18044 }
18045
18046 if (bad)
18047 {
18048 if (k == FFEINFO_kindANY)
18049 ffest_shutdown ();
18050 else
18051 ffesymbol_error (s, t);
18052 }
18053
18054 return s;
18055
18056 default:
18057 assert ("bad symbol state" == NULL);
18058 return NULL;
18059 }
18060 }
18061
18062 /* Have FOO in XYZ = ...FOO(...).... Executable context only. */
18063
18064 static ffesymbol
18065 ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t)
18066 {
18067 ffesymbolAttrs sa;
18068 ffesymbolAttrs na;
18069 ffeinfoKind kind;
18070 ffeinfoWhere where;
18071 ffeintrinGen gen;
18072 ffeintrinSpec spec;
18073 ffeintrinImp imp;
18074 bool maybe_ambig = FALSE;
18075 bool error = FALSE;
18076
18077 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
18078 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
18079
18080 na = sa = ffesymbol_attrs (s);
18081
18082 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
18083 | FFESYMBOL_attrsADJUSTABLE
18084 | FFESYMBOL_attrsANYLEN
18085 | FFESYMBOL_attrsARRAY
18086 | FFESYMBOL_attrsDUMMY
18087 | FFESYMBOL_attrsEXTERNAL
18088 | FFESYMBOL_attrsSFARG
18089 | FFESYMBOL_attrsTYPE)));
18090
18091 kind = ffesymbol_kind (s);
18092 where = ffesymbol_where (s);
18093
18094 /* Figure out what kind of object we've got based on previous declarations
18095 of or references to the object. */
18096
18097 if (sa & FFESYMBOL_attrsEXTERNAL)
18098 {
18099 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
18100 | FFESYMBOL_attrsDUMMY
18101 | FFESYMBOL_attrsEXTERNAL
18102 | FFESYMBOL_attrsTYPE)));
18103
18104 if (sa & FFESYMBOL_attrsTYPE)
18105 where = FFEINFO_whereGLOBAL;
18106 else
18107 /* Not TYPE. */
18108 {
18109 kind = FFEINFO_kindFUNCTION;
18110
18111 if (sa & FFESYMBOL_attrsDUMMY)
18112 ; /* Not TYPE. */
18113 else if (sa & FFESYMBOL_attrsACTUALARG)
18114 ; /* Not DUMMY or TYPE. */
18115 else /* Not ACTUALARG, DUMMY, or TYPE. */
18116 where = FFEINFO_whereGLOBAL;
18117 }
18118 }
18119 else if (sa & FFESYMBOL_attrsDUMMY)
18120 {
18121 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
18122 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
18123 | FFESYMBOL_attrsEXTERNAL
18124 | FFESYMBOL_attrsTYPE)));
18125
18126 kind = FFEINFO_kindFUNCTION;
18127 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure; kind
18128 could be ENTITY w/substring ref. */
18129 }
18130 else if (sa & FFESYMBOL_attrsARRAY)
18131 {
18132 assert (!(sa & ~(FFESYMBOL_attrsARRAY
18133 | FFESYMBOL_attrsADJUSTABLE
18134 | FFESYMBOL_attrsTYPE)));
18135
18136 where = FFEINFO_whereLOCAL;
18137 }
18138 else if (sa & FFESYMBOL_attrsSFARG)
18139 {
18140 assert (!(sa & ~(FFESYMBOL_attrsSFARG
18141 | FFESYMBOL_attrsTYPE)));
18142
18143 where = FFEINFO_whereLOCAL; /* Actually an error, but at least we
18144 know it's a local var. */
18145 }
18146 else if (sa & FFESYMBOL_attrsTYPE)
18147 {
18148 assert (!(sa & (FFESYMBOL_attrsARRAY
18149 | FFESYMBOL_attrsDUMMY
18150 | FFESYMBOL_attrsEXTERNAL
18151 | FFESYMBOL_attrsSFARG))); /* Handled above. */
18152 assert (!(sa & ~(FFESYMBOL_attrsTYPE
18153 | FFESYMBOL_attrsADJUSTABLE
18154 | FFESYMBOL_attrsANYLEN
18155 | FFESYMBOL_attrsARRAY
18156 | FFESYMBOL_attrsDUMMY
18157 | FFESYMBOL_attrsEXTERNAL
18158 | FFESYMBOL_attrsSFARG)));
18159
18160 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
18161 &gen, &spec, &imp))
18162 {
18163 if (!(sa & FFESYMBOL_attrsANYLEN)
18164 && (ffeimplic_peek_symbol_type (s, NULL)
18165 == FFEINFO_basictypeCHARACTER))
18166 return s; /* Haven't learned anything yet. */
18167
18168 ffesymbol_signal_change (s); /* May need to back up to previous
18169 version. */
18170 ffesymbol_set_generic (s, gen);
18171 ffesymbol_set_specific (s, spec);
18172 ffesymbol_set_implementation (s, imp);
18173 ffesymbol_set_info (s,
18174 ffeinfo_new (ffesymbol_basictype (s),
18175 ffesymbol_kindtype (s),
18176 0,
18177 FFEINFO_kindFUNCTION,
18178 FFEINFO_whereINTRINSIC,
18179 ffesymbol_size (s)));
18180 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18181 ffesymbol_resolve_intrin (s);
18182 ffesymbol_reference (s, t, FALSE);
18183 s = ffecom_sym_learned (s);
18184 ffesymbol_signal_unreported (s); /* For debugging purposes. */
18185
18186 return s;
18187 }
18188 if (sa & FFESYMBOL_attrsANYLEN)
18189 error = TRUE; /* Error, since the only way we can,
18190 given CHARACTER*(*) FOO, accept
18191 FOO(...) is for FOO to be a dummy
18192 arg or constant, but it can't
18193 become either now. */
18194 else if (sa & FFESYMBOL_attrsADJUSTABLE)
18195 {
18196 kind = FFEINFO_kindENTITY;
18197 where = FFEINFO_whereLOCAL;
18198 }
18199 else
18200 {
18201 kind = FFEINFO_kindFUNCTION;
18202 where = FFEINFO_whereGLOBAL;
18203 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure;
18204 could be ENTITY/LOCAL w/substring ref. */
18205 }
18206 }
18207 else if (sa == FFESYMBOL_attrsetNONE)
18208 {
18209 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
18210
18211 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
18212 &gen, &spec, &imp))
18213 {
18214 if (ffeimplic_peek_symbol_type (s, NULL)
18215 == FFEINFO_basictypeCHARACTER)
18216 return s; /* Haven't learned anything yet. */
18217
18218 ffesymbol_signal_change (s); /* May need to back up to previous
18219 version. */
18220 ffesymbol_set_generic (s, gen);
18221 ffesymbol_set_specific (s, spec);
18222 ffesymbol_set_implementation (s, imp);
18223 ffesymbol_set_info (s,
18224 ffeinfo_new (ffesymbol_basictype (s),
18225 ffesymbol_kindtype (s),
18226 0,
18227 FFEINFO_kindFUNCTION,
18228 FFEINFO_whereINTRINSIC,
18229 ffesymbol_size (s)));
18230 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18231 ffesymbol_resolve_intrin (s);
18232 s = ffecom_sym_learned (s);
18233 ffesymbol_reference (s, t, FALSE);
18234 ffesymbol_signal_unreported (s); /* For debugging purposes. */
18235 return s;
18236 }
18237
18238 kind = FFEINFO_kindFUNCTION;
18239 where = FFEINFO_whereGLOBAL;
18240 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure;
18241 could be ENTITY/LOCAL w/substring ref. */
18242 }
18243 else
18244 error = TRUE;
18245
18246 /* Now see what we've got for a new object: NONE means a new error cropped
18247 up; ANY means an old error to be ignored; otherwise, everything's ok,
18248 update the object (symbol) and continue on. */
18249
18250 if (error)
18251 ffesymbol_error (s, t);
18252 else if (!(na & FFESYMBOL_attrsANY))
18253 {
18254 ffesymbol_signal_change (s); /* May need to back up to previous
18255 version. */
18256 if (!ffeimplic_establish_symbol (s))
18257 {
18258 ffesymbol_error (s, t);
18259 return s;
18260 }
18261 if (maybe_ambig
18262 && (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
18263 return s; /* Still not sure, let caller deal with it
18264 based on (...). */
18265
18266 ffesymbol_set_info (s,
18267 ffeinfo_new (ffesymbol_basictype (s),
18268 ffesymbol_kindtype (s),
18269 ffesymbol_rank (s),
18270 kind,
18271 where,
18272 ffesymbol_size (s)));
18273 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18274 ffesymbol_resolve_intrin (s);
18275 s = ffecom_sym_learned (s);
18276 ffesymbol_reference (s, t, FALSE);
18277 ffesymbol_signal_unreported (s); /* For debugging purposes. */
18278 }
18279
18280 return s;
18281 }
18282
18283 /* ffeexpr_token_arguments_ -- OPEN_PAREN [expr COMMA]...expr
18284
18285 Return a pointer to this function to the lexer (ffelex), which will
18286 invoke it for the next token.
18287
18288 Handle expression (which might be null) and COMMA or CLOSE_PAREN. */
18289
18290 static ffelexHandler
18291 ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr, ffelexToken t)
18292 {
18293 ffeexprExpr_ procedure;
18294 ffebld reduced;
18295 ffeinfo info;
18296 ffeexprContext ctx;
18297 bool check_intrin = FALSE; /* Set TRUE if intrinsic is REAL(Z) or AIMAG(Z). */
18298
18299 procedure = ffeexpr_stack_->exprstack;
18300 info = ffebld_info (procedure->u.operand);
18301
18302 /* Is there an expression to add? If the expression is nil,
18303 it might still be an argument. It is if:
18304
18305 - The current token is comma, or
18306
18307 - The -fugly-comma flag was specified *and* the procedure
18308 being invoked is external.
18309
18310 Otherwise, if neither of the above is the case, just
18311 ignore this (nil) expression. */
18312
18313 if ((expr != NULL)
18314 || (ffelex_token_type (t) == FFELEX_typeCOMMA)
18315 || (ffe_is_ugly_comma ()
18316 && (ffeinfo_where (info) == FFEINFO_whereGLOBAL)))
18317 {
18318 /* This expression, even if nil, is apparently intended as an argument. */
18319
18320 /* Internal procedure (CONTAINS, or statement function)? */
18321
18322 if (ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18323 {
18324 if ((expr == NULL)
18325 && ffebad_start (FFEBAD_NULL_ARGUMENT))
18326 {
18327 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18328 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18329 ffebad_here (1, ffelex_token_where_line (t),
18330 ffelex_token_where_column (t));
18331 ffebad_finish ();
18332 }
18333
18334 if (expr == NULL)
18335 ;
18336 else
18337 {
18338 if (ffeexpr_stack_->next_dummy == NULL)
18339 { /* Report later which was the first extra argument. */
18340 if (ffeexpr_stack_->tokens[1] == NULL)
18341 {
18342 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
18343 ffeexpr_stack_->num_args = 0;
18344 }
18345 ++ffeexpr_stack_->num_args; /* Count # of extra arguments. */
18346 }
18347 else
18348 {
18349 if ((ffeinfo_rank (ffebld_info (expr)) != 0)
18350 && ffebad_start (FFEBAD_ARRAY_AS_SFARG))
18351 {
18352 ffebad_here (0,
18353 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18354 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18355 ffebad_here (1, ffelex_token_where_line (ft),
18356 ffelex_token_where_column (ft));
18357 ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent
18358 (ffebld_symter (ffebld_head
18359 (ffeexpr_stack_->next_dummy)))));
18360 ffebad_finish ();
18361 }
18362 else
18363 {
18364 expr = ffeexpr_convert_expr (expr, ft,
18365 ffebld_head (ffeexpr_stack_->next_dummy),
18366 ffeexpr_stack_->tokens[0],
18367 FFEEXPR_contextLET);
18368 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18369 }
18370 --ffeexpr_stack_->num_args; /* Count down # of args. */
18371 ffeexpr_stack_->next_dummy
18372 = ffebld_trail (ffeexpr_stack_->next_dummy);
18373 }
18374 }
18375 }
18376 else
18377 {
18378 if ((expr == NULL)
18379 && ffe_is_pedantic ()
18380 && ffebad_start (FFEBAD_NULL_ARGUMENT_W))
18381 {
18382 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18383 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18384 ffebad_here (1, ffelex_token_where_line (t),
18385 ffelex_token_where_column (t));
18386 ffebad_finish ();
18387 }
18388 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18389 }
18390 }
18391
18392 switch (ffelex_token_type (t))
18393 {
18394 case FFELEX_typeCOMMA:
18395 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
18396 {
18397 case FFEEXPR_contextSFUNCDEF:
18398 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
18399 case FFEEXPR_contextSFUNCDEFINDEX_:
18400 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
18401 ctx = FFEEXPR_contextSFUNCDEFACTUALARG_;
18402 break;
18403
18404 case FFEEXPR_contextSFUNCDEFACTUALARG_:
18405 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18406 assert ("bad context" == NULL);
18407 ctx = FFEEXPR_context;
18408 break;
18409
18410 default:
18411 ctx = FFEEXPR_contextACTUALARG_;
18412 break;
18413 }
18414 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18415 ffeexpr_token_arguments_);
18416
18417 default:
18418 break;
18419 }
18420
18421 if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18422 && (ffeexpr_stack_->next_dummy != NULL))
18423 { /* Too few arguments. */
18424 if (ffebad_start (FFEBAD_TOO_FEW_ARGUMENTS))
18425 {
18426 char num[10];
18427
18428 sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
18429
18430 ffebad_here (0, ffelex_token_where_line (t),
18431 ffelex_token_where_column (t));
18432 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18433 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18434 ffebad_string (num);
18435 ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent (ffebld_symter
18436 (ffebld_head (ffeexpr_stack_->next_dummy)))));
18437 ffebad_finish ();
18438 }
18439 for (;
18440 ffeexpr_stack_->next_dummy != NULL;
18441 ffeexpr_stack_->next_dummy
18442 = ffebld_trail (ffeexpr_stack_->next_dummy))
18443 {
18444 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0));
18445 ffebld_set_info (expr, ffeinfo_new_any ());
18446 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18447 }
18448 }
18449
18450 if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18451 && (ffeexpr_stack_->tokens[1] != NULL))
18452 { /* Too many arguments to statement function. */
18453 if (ffebad_start (FFEBAD_TOO_MANY_ARGUMENTS))
18454 {
18455 char num[10];
18456
18457 sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
18458
18459 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
18460 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
18461 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18462 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18463 ffebad_string (num);
18464 ffebad_finish ();
18465 }
18466 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
18467 }
18468 ffebld_end_list (&ffeexpr_stack_->bottom);
18469
18470 if (ffebld_op (procedure->u.operand) == FFEBLD_opANY)
18471 {
18472 reduced = ffebld_new_any ();
18473 ffebld_set_info (reduced, ffeinfo_new_any ());
18474 }
18475 else
18476 {
18477 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
18478 reduced = ffebld_new_funcref (procedure->u.operand,
18479 ffeexpr_stack_->expr);
18480 else
18481 reduced = ffebld_new_subrref (procedure->u.operand,
18482 ffeexpr_stack_->expr);
18483 if (ffebld_symter_generic (procedure->u.operand) != FFEINTRIN_genNONE)
18484 ffeintrin_fulfill_generic (&reduced, &info, ffeexpr_stack_->tokens[0]);
18485 else if (ffebld_symter_specific (procedure->u.operand)
18486 != FFEINTRIN_specNONE)
18487 ffeintrin_fulfill_specific (&reduced, &info, &check_intrin,
18488 ffeexpr_stack_->tokens[0]);
18489 else
18490 ffeexpr_fulfill_call_ (&reduced, ffeexpr_stack_->tokens[0]);
18491
18492 if (ffebld_op (reduced) != FFEBLD_opANY)
18493 ffebld_set_info (reduced,
18494 ffeinfo_new (ffeinfo_basictype (info),
18495 ffeinfo_kindtype (info),
18496 0,
18497 FFEINFO_kindENTITY,
18498 FFEINFO_whereFLEETING,
18499 ffeinfo_size (info)));
18500 else
18501 ffebld_set_info (reduced, ffeinfo_new_any ());
18502 }
18503 if (ffebld_op (reduced) == FFEBLD_opFUNCREF)
18504 reduced = ffeexpr_collapse_funcref (reduced, ffeexpr_stack_->tokens[0]);
18505 ffeexpr_stack_->exprstack = procedure->previous; /* Pops
18506 not-quite-operand off
18507 stack. */
18508 procedure->u.operand = reduced; /* Save the line/column ffewhere
18509 info. */
18510 ffeexpr_exprstack_push_operand_ (procedure); /* Push it back on stack. */
18511 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18512 {
18513 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18514 ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FUNC(3)(1:1)".... */
18515
18516 /* If the intrinsic needs checking (is REAL(Z) or AIMAG(Z), where
18517 Z is DOUBLE COMPLEX), and a command-line option doesn't already
18518 establish interpretation, probably complain. */
18519
18520 if (check_intrin
18521 && !ffe_is_90 ()
18522 && !ffe_is_ugly_complex ())
18523 {
18524 /* If the outer expression is REAL(me...), issue diagnostic
18525 only if next token isn't the close-paren for REAL(me). */
18526
18527 if ((ffeexpr_stack_->previous != NULL)
18528 && (ffeexpr_stack_->previous->exprstack != NULL)
18529 && (ffeexpr_stack_->previous->exprstack->type == FFEEXPR_exprtypeOPERAND_)
18530 && ((reduced = ffeexpr_stack_->previous->exprstack->u.operand) != NULL)
18531 && (ffebld_op (reduced) == FFEBLD_opSYMTER)
18532 && (ffebld_symter_implementation (reduced) == FFEINTRIN_impREAL))
18533 return (ffelexHandler) ffeexpr_token_intrincheck_;
18534
18535 /* Diagnose the ambiguity now. */
18536
18537 if (ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
18538 {
18539 ffebad_string (ffeintrin_name_implementation
18540 (ffebld_symter_implementation
18541 (ffebld_left
18542 (ffeexpr_stack_->exprstack->u.operand))));
18543 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
18544 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
18545 ffebad_finish ();
18546 }
18547 }
18548 return (ffelexHandler) ffeexpr_token_substrp_;
18549 }
18550
18551 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
18552 {
18553 ffebad_here (0, ffelex_token_where_line (t),
18554 ffelex_token_where_column (t));
18555 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18556 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18557 ffebad_finish ();
18558 }
18559 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18560 ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FUNC(3)(1:1)".... */
18561 return
18562 (ffelexHandler) ffeexpr_find_close_paren_ (t,
18563 (ffelexHandler)
18564 ffeexpr_token_substrp_);
18565 }
18566
18567 /* ffeexpr_token_elements_ -- OPEN_PAREN [expr COMMA]...expr
18568
18569 Return a pointer to this array to the lexer (ffelex), which will
18570 invoke it for the next token.
18571
18572 Handle expression and COMMA or CLOSE_PAREN. */
18573
18574 static ffelexHandler
18575 ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, ffelexToken t)
18576 {
18577 ffeexprExpr_ array;
18578 ffebld reduced;
18579 ffeinfo info;
18580 ffeinfoWhere where;
18581 ffetargetIntegerDefault val;
18582 ffetargetIntegerDefault lval = 0;
18583 ffetargetIntegerDefault uval = 0;
18584 ffebld lbound;
18585 ffebld ubound;
18586 bool lcheck;
18587 bool ucheck;
18588
18589 array = ffeexpr_stack_->exprstack;
18590 info = ffebld_info (array->u.operand);
18591
18592 if ((expr == NULL) /* && ((ffeexpr_stack_->rank != 0) ||
18593 (ffelex_token_type(t) ==
18594 FFELEX_typeCOMMA)) */ )
18595 {
18596 if (ffebad_start (FFEBAD_NULL_ELEMENT))
18597 {
18598 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18599 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18600 ffebad_here (1, ffelex_token_where_line (t),
18601 ffelex_token_where_column (t));
18602 ffebad_finish ();
18603 }
18604 if (ffeexpr_stack_->rank < ffeinfo_rank (info))
18605 { /* Don't bother if we're going to complain
18606 later! */
18607 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
18608 ffebld_set_info (expr, ffeinfo_new_any ());
18609 }
18610 }
18611
18612 if (expr == NULL)
18613 ;
18614 else if (ffeinfo_rank (info) == 0)
18615 { /* In EQUIVALENCE context, ffeinfo_rank(info)
18616 may == 0. */
18617 ++ffeexpr_stack_->rank; /* Track anyway, may need for new VXT
18618 feature. */
18619 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18620 }
18621 else
18622 {
18623 ++ffeexpr_stack_->rank;
18624 if (ffeexpr_stack_->rank > ffeinfo_rank (info))
18625 { /* Report later which was the first extra
18626 element. */
18627 if (ffeexpr_stack_->rank == ffeinfo_rank (info) + 1)
18628 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
18629 }
18630 else
18631 {
18632 switch (ffeinfo_where (ffebld_info (expr)))
18633 {
18634 case FFEINFO_whereCONSTANT:
18635 break;
18636
18637 case FFEINFO_whereIMMEDIATE:
18638 ffeexpr_stack_->constant = FALSE;
18639 break;
18640
18641 default:
18642 ffeexpr_stack_->constant = FALSE;
18643 ffeexpr_stack_->immediate = FALSE;
18644 break;
18645 }
18646 if (ffebld_op (expr) == FFEBLD_opCONTER
18647 && ffebld_kindtype (expr) == FFEINFO_kindtypeINTEGERDEFAULT)
18648 {
18649 val = ffebld_constant_integerdefault (ffebld_conter (expr));
18650
18651 lbound = ffebld_left (ffebld_head (ffeexpr_stack_->bound_list));
18652 if (lbound == NULL)
18653 {
18654 lcheck = TRUE;
18655 lval = 1;
18656 }
18657 else if (ffebld_op (lbound) == FFEBLD_opCONTER)
18658 {
18659 lcheck = TRUE;
18660 lval = ffebld_constant_integerdefault (ffebld_conter (lbound));
18661 }
18662 else
18663 lcheck = FALSE;
18664
18665 ubound = ffebld_right (ffebld_head (ffeexpr_stack_->bound_list));
18666 assert (ubound != NULL);
18667 if (ffebld_op (ubound) == FFEBLD_opCONTER)
18668 {
18669 ucheck = TRUE;
18670 uval = ffebld_constant_integerdefault (ffebld_conter (ubound));
18671 }
18672 else
18673 ucheck = FALSE;
18674
18675 if ((lcheck && (val < lval)) || (ucheck && (val > uval)))
18676 {
18677 ffebad_start (FFEBAD_RANGE_ARRAY);
18678 ffebad_here (0, ffelex_token_where_line (ft),
18679 ffelex_token_where_column (ft));
18680 ffebad_finish ();
18681 }
18682 }
18683 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18684 ffeexpr_stack_->bound_list = ffebld_trail (ffeexpr_stack_->bound_list);
18685 }
18686 }
18687
18688 switch (ffelex_token_type (t))
18689 {
18690 case FFELEX_typeCOMMA:
18691 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
18692 {
18693 case FFEEXPR_contextDATAIMPDOITEM_:
18694 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18695 FFEEXPR_contextDATAIMPDOINDEX_,
18696 ffeexpr_token_elements_);
18697
18698 case FFEEXPR_contextEQUIVALENCE:
18699 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18700 FFEEXPR_contextEQVINDEX_,
18701 ffeexpr_token_elements_);
18702
18703 case FFEEXPR_contextSFUNCDEF:
18704 case FFEEXPR_contextSFUNCDEFINDEX_:
18705 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18706 FFEEXPR_contextSFUNCDEFINDEX_,
18707 ffeexpr_token_elements_);
18708
18709 case FFEEXPR_contextSFUNCDEFACTUALARG_:
18710 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18711 assert ("bad context" == NULL);
18712 break;
18713
18714 default:
18715 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18716 FFEEXPR_contextINDEX_,
18717 ffeexpr_token_elements_);
18718 }
18719
18720 default:
18721 break;
18722 }
18723
18724 if ((ffeexpr_stack_->rank != ffeinfo_rank (info))
18725 && (ffeinfo_rank (info) != 0))
18726 {
18727 char num[10];
18728
18729 if (ffeexpr_stack_->rank < ffeinfo_rank (info))
18730 {
18731 if (ffebad_start (FFEBAD_TOO_FEW_ELEMENTS))
18732 {
18733 sprintf (num, "%d",
18734 (int) (ffeinfo_rank (info) - ffeexpr_stack_->rank));
18735
18736 ffebad_here (0, ffelex_token_where_line (t),
18737 ffelex_token_where_column (t));
18738 ffebad_here (1,
18739 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18740 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18741 ffebad_string (num);
18742 ffebad_finish ();
18743 }
18744 }
18745 else
18746 {
18747 if (ffebad_start (FFEBAD_TOO_MANY_ELEMENTS))
18748 {
18749 sprintf (num, "%d",
18750 (int) (ffeexpr_stack_->rank - ffeinfo_rank (info)));
18751
18752 ffebad_here (0,
18753 ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
18754 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
18755 ffebad_here (1,
18756 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18757 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18758 ffebad_string (num);
18759 ffebad_finish ();
18760 }
18761 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
18762 }
18763 while (ffeexpr_stack_->rank++ < ffeinfo_rank (info))
18764 {
18765 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
18766 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeINTEGER,
18767 FFEINFO_kindtypeINTEGERDEFAULT,
18768 0, FFEINFO_kindENTITY,
18769 FFEINFO_whereCONSTANT,
18770 FFETARGET_charactersizeNONE));
18771 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18772 }
18773 }
18774 ffebld_end_list (&ffeexpr_stack_->bottom);
18775
18776 if (ffebld_op (array->u.operand) == FFEBLD_opANY)
18777 {
18778 reduced = ffebld_new_any ();
18779 ffebld_set_info (reduced, ffeinfo_new_any ());
18780 }
18781 else
18782 {
18783 reduced = ffebld_new_arrayref (array->u.operand, ffeexpr_stack_->expr);
18784 if (ffeexpr_stack_->constant)
18785 where = FFEINFO_whereFLEETING_CADDR;
18786 else if (ffeexpr_stack_->immediate)
18787 where = FFEINFO_whereFLEETING_IADDR;
18788 else
18789 where = FFEINFO_whereFLEETING;
18790 ffebld_set_info (reduced,
18791 ffeinfo_new (ffeinfo_basictype (info),
18792 ffeinfo_kindtype (info),
18793 0,
18794 FFEINFO_kindENTITY,
18795 where,
18796 ffeinfo_size (info)));
18797 reduced = ffeexpr_collapse_arrayref (reduced, ffeexpr_stack_->tokens[0]);
18798 }
18799
18800 ffeexpr_stack_->exprstack = array->previous; /* Pops not-quite-operand off
18801 stack. */
18802 array->u.operand = reduced; /* Save the line/column ffewhere info. */
18803 ffeexpr_exprstack_push_operand_ (array); /* Push it back on stack. */
18804
18805 switch (ffeinfo_basictype (info))
18806 {
18807 case FFEINFO_basictypeCHARACTER:
18808 ffeexpr_is_substr_ok_ = TRUE; /* Everyone likes "FOO(3)(1:1)".... */
18809 break;
18810
18811 case FFEINFO_basictypeNONE:
18812 ffeexpr_is_substr_ok_ = TRUE;
18813 assert (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE);
18814 break;
18815
18816 default:
18817 ffeexpr_is_substr_ok_ = FALSE;
18818 break;
18819 }
18820
18821 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18822 {
18823 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18824 return (ffelexHandler) ffeexpr_token_substrp_;
18825 }
18826
18827 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
18828 {
18829 ffebad_here (0, ffelex_token_where_line (t),
18830 ffelex_token_where_column (t));
18831 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18832 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18833 ffebad_finish ();
18834 }
18835 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18836 return
18837 (ffelexHandler) ffeexpr_find_close_paren_ (t,
18838 (ffelexHandler)
18839 ffeexpr_token_substrp_);
18840 }
18841
18842 /* ffeexpr_token_equivalence_ -- OPEN_PAREN expr
18843
18844 Return a pointer to this array to the lexer (ffelex), which will
18845 invoke it for the next token.
18846
18847 If token is COLON, pass off to _substr_, else init list and pass off
18848 to _elements_. This handles the case "EQUIVALENCE (FOO(expr?", where
18849 ? marks the token, and where FOO's rank/type has not yet been established,
18850 meaning we could be in a list of indices or in a substring
18851 specification. */
18852
18853 static ffelexHandler
18854 ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr, ffelexToken t)
18855 {
18856 if (ffelex_token_type (t) == FFELEX_typeCOLON)
18857 return ffeexpr_token_substring_ (ft, expr, t);
18858
18859 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
18860 return ffeexpr_token_elements_ (ft, expr, t);
18861 }
18862
18863 /* ffeexpr_token_substring_ -- NAME(of kindENTITY) OPEN_PAREN expr
18864
18865 Return a pointer to this function to the lexer (ffelex), which will
18866 invoke it for the next token.
18867
18868 Handle expression (which may be null) and COLON. */
18869
18870 static ffelexHandler
18871 ffeexpr_token_substring_ (ffelexToken ft, ffebld expr, ffelexToken t)
18872 {
18873 ffeexprExpr_ string;
18874 ffeinfo info;
18875 ffetargetIntegerDefault i;
18876 ffeexprContext ctx;
18877 ffetargetCharacterSize size;
18878
18879 string = ffeexpr_stack_->exprstack;
18880 info = ffebld_info (string->u.operand);
18881 size = ffebld_size_max (string->u.operand);
18882
18883 if (ffelex_token_type (t) == FFELEX_typeCOLON)
18884 {
18885 if ((expr != NULL)
18886 && (ffebld_op (expr) == FFEBLD_opCONTER)
18887 && (((i = ffebld_constant_integerdefault (ffebld_conter (expr)))
18888 < 1)
18889 || ((size != FFETARGET_charactersizeNONE) && (i > size))))
18890 {
18891 ffebad_start (FFEBAD_RANGE_SUBSTR);
18892 ffebad_here (0, ffelex_token_where_line (ft),
18893 ffelex_token_where_column (ft));
18894 ffebad_finish ();
18895 }
18896 ffeexpr_stack_->expr = expr;
18897
18898 switch (ffeexpr_stack_->context)
18899 {
18900 case FFEEXPR_contextSFUNCDEF:
18901 case FFEEXPR_contextSFUNCDEFINDEX_:
18902 ctx = FFEEXPR_contextSFUNCDEFINDEX_;
18903 break;
18904
18905 case FFEEXPR_contextSFUNCDEFACTUALARG_:
18906 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18907 assert ("bad context" == NULL);
18908 ctx = FFEEXPR_context;
18909 break;
18910
18911 default:
18912 ctx = FFEEXPR_contextINDEX_;
18913 break;
18914 }
18915
18916 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18917 ffeexpr_token_substring_1_);
18918 }
18919
18920 if (ffest_ffebad_start (FFEBAD_MISSING_COLON_IN_SUBSTR))
18921 {
18922 ffebad_here (0, ffelex_token_where_line (t),
18923 ffelex_token_where_column (t));
18924 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18925 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18926 ffebad_finish ();
18927 }
18928
18929 ffeexpr_stack_->expr = NULL;
18930 return (ffelexHandler) ffeexpr_token_substring_1_ (ft, expr, t);
18931 }
18932
18933 /* ffeexpr_token_substring_1_ -- NAME OPEN_PAREN [expr COMMA]...expr
18934
18935 Return a pointer to this function to the lexer (ffelex), which will
18936 invoke it for the next token.
18937
18938 Handle expression (which might be null) and CLOSE_PAREN. */
18939
18940 static ffelexHandler
18941 ffeexpr_token_substring_1_ (ffelexToken ft, ffebld last, ffelexToken t)
18942 {
18943 ffeexprExpr_ string;
18944 ffebld reduced;
18945 ffebld substrlist;
18946 ffebld first = ffeexpr_stack_->expr;
18947 ffebld strop;
18948 ffeinfo info;
18949 ffeinfoWhere lwh;
18950 ffeinfoWhere rwh;
18951 ffeinfoWhere where;
18952 ffeinfoKindtype first_kt;
18953 ffeinfoKindtype last_kt;
18954 ffetargetIntegerDefault first_val;
18955 ffetargetIntegerDefault last_val;
18956 ffetargetCharacterSize size;
18957 ffetargetCharacterSize strop_size_max;
18958 bool first_known;
18959
18960 string = ffeexpr_stack_->exprstack;
18961 strop = string->u.operand;
18962 info = ffebld_info (strop);
18963
18964 if (first == NULL
18965 || (ffebld_op (first) == FFEBLD_opCONTER
18966 && ffebld_kindtype (first) == FFEINFO_kindtypeINTEGERDEFAULT))
18967 { /* The starting point is known. */
18968 first_val = (first == NULL) ? 1
18969 : ffebld_constant_integerdefault (ffebld_conter (first));
18970 first_known = TRUE;
18971 }
18972 else
18973 { /* Assume start of the entity. */
18974 first_val = 1;
18975 first_known = FALSE;
18976 }
18977
18978 if (last != NULL
18979 && (ffebld_op (last) == FFEBLD_opCONTER
18980 && ffebld_kindtype (last) == FFEINFO_kindtypeINTEGERDEFAULT))
18981 { /* The ending point is known. */
18982 last_val = ffebld_constant_integerdefault (ffebld_conter (last));
18983
18984 if (first_known)
18985 { /* The beginning point is a constant. */
18986 if (first_val <= last_val)
18987 size = last_val - first_val + 1;
18988 else
18989 {
18990 if (0 && ffe_is_90 ())
18991 size = 0;
18992 else
18993 {
18994 size = 1;
18995 ffebad_start (FFEBAD_ZERO_SIZE);
18996 ffebad_here (0, ffelex_token_where_line (ft),
18997 ffelex_token_where_column (ft));
18998 ffebad_finish ();
18999 }
19000 }
19001 }
19002 else
19003 size = FFETARGET_charactersizeNONE;
19004
19005 strop_size_max = ffebld_size_max (strop);
19006
19007 if ((strop_size_max != FFETARGET_charactersizeNONE)
19008 && (last_val > strop_size_max))
19009 { /* Beyond maximum possible end of string. */
19010 ffebad_start (FFEBAD_RANGE_SUBSTR);
19011 ffebad_here (0, ffelex_token_where_line (ft),
19012 ffelex_token_where_column (ft));
19013 ffebad_finish ();
19014 }
19015 }
19016 else
19017 size = FFETARGET_charactersizeNONE; /* The size is not known. */
19018
19019 #if 0 /* Don't do this, or "is size of target
19020 known?" would no longer be easily
19021 answerable. To see if there is a max
19022 size, use ffebld_size_max; to get only the
19023 known size, else NONE, use
19024 ffebld_size_known; use ffebld_size if
19025 values are sure to be the same (not
19026 opSUBSTR or opCONCATENATE or known to have
19027 known length). By getting rid of this
19028 "useful info" stuff, we don't end up
19029 blank-padding the constant in the
19030 assignment "A(I:J)='XYZ'" to the known
19031 length of A. */
19032 if (size == FFETARGET_charactersizeNONE)
19033 size = strop_size_max; /* Assume we use the entire string. */
19034 #endif
19035
19036 substrlist
19037 = ffebld_new_item
19038 (first,
19039 ffebld_new_item
19040 (last,
19041 NULL
19042 )
19043 )
19044 ;
19045
19046 if (first == NULL)
19047 lwh = FFEINFO_whereCONSTANT;
19048 else
19049 lwh = ffeinfo_where (ffebld_info (first));
19050 if (last == NULL)
19051 rwh = FFEINFO_whereCONSTANT;
19052 else
19053 rwh = ffeinfo_where (ffebld_info (last));
19054
19055 switch (lwh)
19056 {
19057 case FFEINFO_whereCONSTANT:
19058 switch (rwh)
19059 {
19060 case FFEINFO_whereCONSTANT:
19061 where = FFEINFO_whereCONSTANT;
19062 break;
19063
19064 case FFEINFO_whereIMMEDIATE:
19065 where = FFEINFO_whereIMMEDIATE;
19066 break;
19067
19068 default:
19069 where = FFEINFO_whereFLEETING;
19070 break;
19071 }
19072 break;
19073
19074 case FFEINFO_whereIMMEDIATE:
19075 switch (rwh)
19076 {
19077 case FFEINFO_whereCONSTANT:
19078 case FFEINFO_whereIMMEDIATE:
19079 where = FFEINFO_whereIMMEDIATE;
19080 break;
19081
19082 default:
19083 where = FFEINFO_whereFLEETING;
19084 break;
19085 }
19086 break;
19087
19088 default:
19089 where = FFEINFO_whereFLEETING;
19090 break;
19091 }
19092
19093 if (first == NULL)
19094 first_kt = FFEINFO_kindtypeINTEGERDEFAULT;
19095 else
19096 first_kt = ffeinfo_kindtype (ffebld_info (first));
19097 if (last == NULL)
19098 last_kt = FFEINFO_kindtypeINTEGERDEFAULT;
19099 else
19100 last_kt = ffeinfo_kindtype (ffebld_info (last));
19101
19102 switch (where)
19103 {
19104 case FFEINFO_whereCONSTANT:
19105 switch (ffeinfo_where (info))
19106 {
19107 case FFEINFO_whereCONSTANT:
19108 break;
19109
19110 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
19111 where = FFEINFO_whereIMMEDIATE;
19112 break;
19113
19114 default:
19115 where = FFEINFO_whereFLEETING_CADDR;
19116 break;
19117 }
19118 break;
19119
19120 case FFEINFO_whereIMMEDIATE:
19121 switch (ffeinfo_where (info))
19122 {
19123 case FFEINFO_whereCONSTANT:
19124 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
19125 break;
19126
19127 default:
19128 where = FFEINFO_whereFLEETING_IADDR;
19129 break;
19130 }
19131 break;
19132
19133 default:
19134 switch (ffeinfo_where (info))
19135 {
19136 case FFEINFO_whereCONSTANT:
19137 where = FFEINFO_whereCONSTANT_SUBOBJECT; /* An F90 concept. */
19138 break;
19139
19140 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
19141 default:
19142 where = FFEINFO_whereFLEETING;
19143 break;
19144 }
19145 break;
19146 }
19147
19148 if (ffebld_op (strop) == FFEBLD_opANY)
19149 {
19150 reduced = ffebld_new_any ();
19151 ffebld_set_info (reduced, ffeinfo_new_any ());
19152 }
19153 else
19154 {
19155 reduced = ffebld_new_substr (strop, substrlist);
19156 ffebld_set_info (reduced, ffeinfo_new
19157 (FFEINFO_basictypeCHARACTER,
19158 ffeinfo_kindtype (info),
19159 0,
19160 FFEINFO_kindENTITY,
19161 where,
19162 size));
19163 reduced = ffeexpr_collapse_substr (reduced, ffeexpr_stack_->tokens[0]);
19164 }
19165
19166 ffeexpr_stack_->exprstack = string->previous; /* Pops not-quite-operand off
19167 stack. */
19168 string->u.operand = reduced; /* Save the line/column ffewhere info. */
19169 ffeexpr_exprstack_push_operand_ (string); /* Push it back on stack. */
19170
19171 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
19172 {
19173 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19174 ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FOO(3:5)(1:1)".... */
19175 return (ffelexHandler) ffeexpr_token_substrp_;
19176 }
19177
19178 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
19179 {
19180 ffebad_here (0, ffelex_token_where_line (t),
19181 ffelex_token_where_column (t));
19182 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
19183 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
19184 ffebad_finish ();
19185 }
19186
19187 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19188 ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FOO(3:5)(1:1)".... */
19189 return
19190 (ffelexHandler) ffeexpr_find_close_paren_ (t,
19191 (ffelexHandler)
19192 ffeexpr_token_substrp_);
19193 }
19194
19195 /* ffeexpr_token_substrp_ -- Rhs <character entity>
19196
19197 Return a pointer to this function to the lexer (ffelex), which will
19198 invoke it for the next token.
19199
19200 If OPEN_PAREN, treat as start of a substring ("(3:4)") construct, and
19201 issue error message if flag (serves as argument) is set. Else, just
19202 forward token to binary_. */
19203
19204 static ffelexHandler
19205 ffeexpr_token_substrp_ (ffelexToken t)
19206 {
19207 ffeexprContext ctx;
19208
19209 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
19210 return (ffelexHandler) ffeexpr_token_binary_ (t);
19211
19212 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
19213
19214 switch (ffeexpr_stack_->context)
19215 {
19216 case FFEEXPR_contextSFUNCDEF:
19217 case FFEEXPR_contextSFUNCDEFINDEX_:
19218 ctx = FFEEXPR_contextSFUNCDEFINDEX_;
19219 break;
19220
19221 case FFEEXPR_contextSFUNCDEFACTUALARG_:
19222 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
19223 assert ("bad context" == NULL);
19224 ctx = FFEEXPR_context;
19225 break;
19226
19227 default:
19228 ctx = FFEEXPR_contextINDEX_;
19229 break;
19230 }
19231
19232 if (!ffeexpr_is_substr_ok_)
19233 {
19234 if (ffebad_start (FFEBAD_BAD_SUBSTR))
19235 {
19236 ffebad_here (0, ffelex_token_where_line (t),
19237 ffelex_token_where_column (t));
19238 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
19239 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
19240 ffebad_finish ();
19241 }
19242
19243 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
19244 ffeexpr_token_anything_);
19245 }
19246
19247 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
19248 ffeexpr_token_substring_);
19249 }
19250
19251 static ffelexHandler
19252 ffeexpr_token_intrincheck_ (ffelexToken t)
19253 {
19254 if ((ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
19255 && ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
19256 {
19257 ffebad_string (ffeintrin_name_implementation
19258 (ffebld_symter_implementation
19259 (ffebld_left
19260 (ffeexpr_stack_->exprstack->u.operand))));
19261 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
19262 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
19263 ffebad_finish ();
19264 }
19265
19266 return (ffelexHandler) ffeexpr_token_substrp_ (t);
19267 }
19268
19269 /* ffeexpr_token_funsubstr_ -- NAME OPEN_PAREN expr
19270
19271 Return a pointer to this function to the lexer (ffelex), which will
19272 invoke it for the next token.
19273
19274 If COLON, do everything we would have done since _parenthesized_ if
19275 we had known NAME represented a kindENTITY instead of a kindFUNCTION.
19276 If not COLON, do likewise for kindFUNCTION instead. */
19277
19278 static ffelexHandler
19279 ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr, ffelexToken t)
19280 {
19281 ffeinfoWhere where;
19282 ffesymbol s;
19283 ffesymbolAttrs sa;
19284 ffebld symter = ffeexpr_stack_->exprstack->u.operand;
19285 bool needs_type;
19286 ffeintrinGen gen;
19287 ffeintrinSpec spec;
19288 ffeintrinImp imp;
19289
19290 s = ffebld_symter (symter);
19291 sa = ffesymbol_attrs (s);
19292 where = ffesymbol_where (s);
19293
19294 /* We get here only if we don't already know enough about FOO when seeing a
19295 FOO(stuff) reference, and FOO might turn out to be a CHARACTER type. If
19296 "stuff" is a substring reference, then FOO is a CHARACTER scalar type.
19297 Else FOO is a function, either intrinsic or external. If intrinsic, it
19298 wouldn't necessarily be CHARACTER type, so unless it has already been
19299 declared DUMMY, it hasn't had its type established yet. It can't be
19300 CHAR*(*) in any case, though it can have an explicit CHAR*n type. */
19301
19302 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
19303 | FFESYMBOL_attrsTYPE)));
19304
19305 needs_type = !(ffesymbol_attrs (s) & FFESYMBOL_attrsDUMMY);
19306
19307 ffesymbol_signal_change (s); /* Probably already done, but in case.... */
19308
19309 if (ffelex_token_type (t) == FFELEX_typeCOLON)
19310 { /* Definitely an ENTITY (char substring). */
19311 if (needs_type && !ffeimplic_establish_symbol (s))
19312 {
19313 ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
19314 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19315 }
19316
19317 ffesymbol_set_info (s,
19318 ffeinfo_new (ffesymbol_basictype (s),
19319 ffesymbol_kindtype (s),
19320 ffesymbol_rank (s),
19321 FFEINFO_kindENTITY,
19322 (where == FFEINFO_whereNONE)
19323 ? FFEINFO_whereLOCAL
19324 : where,
19325 ffesymbol_size (s)));
19326 ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
19327
19328 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
19329 ffesymbol_resolve_intrin (s);
19330 s = ffecom_sym_learned (s);
19331 ffesymbol_signal_unreported (s); /* For debugging purposes. */
19332
19333 ffeexpr_stack_->exprstack->u.operand
19334 = ffeexpr_collapse_symter (symter, ffeexpr_tokens_[0]);
19335
19336 return (ffelexHandler) ffeexpr_token_substring_ (ft, expr, t);
19337 }
19338
19339 /* The "stuff" isn't a substring notation, so we now know the overall
19340 reference is to a function. */
19341
19342 if (ffeintrin_is_intrinsic (ffesymbol_text (s), ffeexpr_stack_->tokens[0],
19343 FALSE, &gen, &spec, &imp))
19344 {
19345 ffebld_symter_set_generic (symter, gen);
19346 ffebld_symter_set_specific (symter, spec);
19347 ffebld_symter_set_implementation (symter, imp);
19348 ffesymbol_set_generic (s, gen);
19349 ffesymbol_set_specific (s, spec);
19350 ffesymbol_set_implementation (s, imp);
19351 ffesymbol_set_info (s,
19352 ffeinfo_new (ffesymbol_basictype (s),
19353 ffesymbol_kindtype (s),
19354 0,
19355 FFEINFO_kindFUNCTION,
19356 FFEINFO_whereINTRINSIC,
19357 ffesymbol_size (s)));
19358 }
19359 else
19360 { /* Not intrinsic, now needs CHAR type. */
19361 if (!ffeimplic_establish_symbol (s))
19362 {
19363 ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
19364 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19365 }
19366
19367 ffesymbol_set_info (s,
19368 ffeinfo_new (ffesymbol_basictype (s),
19369 ffesymbol_kindtype (s),
19370 ffesymbol_rank (s),
19371 FFEINFO_kindFUNCTION,
19372 (where == FFEINFO_whereNONE)
19373 ? FFEINFO_whereGLOBAL
19374 : where,
19375 ffesymbol_size (s)));
19376 }
19377
19378 ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
19379
19380 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
19381 ffesymbol_resolve_intrin (s);
19382 s = ffecom_sym_learned (s);
19383 ffesymbol_reference (s, ffeexpr_stack_->tokens[0], FALSE);
19384 ffesymbol_signal_unreported (s); /* For debugging purposes. */
19385 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
19386 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19387 }
19388
19389 /* ffeexpr_token_anything_ -- NAME OPEN_PAREN any-expr
19390
19391 Handle basically any expression, looking for CLOSE_PAREN. */
19392
19393 static ffelexHandler
19394 ffeexpr_token_anything_ (ffelexToken ft UNUSED, ffebld expr UNUSED,
19395 ffelexToken t)
19396 {
19397 ffeexprExpr_ e = ffeexpr_stack_->exprstack;
19398
19399 switch (ffelex_token_type (t))
19400 {
19401 case FFELEX_typeCOMMA:
19402 case FFELEX_typeCOLON:
19403 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
19404 FFEEXPR_contextACTUALARG_,
19405 ffeexpr_token_anything_);
19406
19407 default:
19408 e->u.operand = ffebld_new_any ();
19409 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
19410 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19411 ffeexpr_is_substr_ok_ = FALSE;
19412 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
19413 return (ffelexHandler) ffeexpr_token_substrp_;
19414 return (ffelexHandler) ffeexpr_token_substrp_ (t);
19415 }
19416 }
19417
19418 /* Terminate module. */
19419
19420 void
19421 ffeexpr_terminate_2 ()
19422 {
19423 assert (ffeexpr_stack_ == NULL);
19424 assert (ffeexpr_level_ == 0);
19425 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org