]> git.ipfire.org Git - thirdparty/gcc.git/blob - gcc/f/expr.c
projects / thirdparty / gcc.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
Fix INTEGER*8 conversion bugs
[thirdparty/gcc.git] / gcc / f / expr.c
1 /* expr.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995-1998 Free Software Foundation, Inc.
3 Contributed by James Craig Burley.
4
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_ (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 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_ (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 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 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 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 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 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 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 case FFEEXPR_contextRETURN:
12271 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12272 break;
12273 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12274 : ffeinfo_basictype (info))
12275 {
12276 case FFEINFO_basictypeNONE:
12277 error = FALSE;
12278 break;
12279
12280 case FFEINFO_basictypeLOGICAL:
12281 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12282 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12283 FFEEXPR_contextLET);
12284 /* Fall through. */
12285 case FFEINFO_basictypeREAL:
12286 case FFEINFO_basictypeCOMPLEX:
12287 if (ffe_is_pedantic ())
12288 {
12289 error = TRUE;
12290 break;
12291 }
12292 /* Fall through. */
12293 case FFEINFO_basictypeINTEGER:
12294 case FFEINFO_basictypeHOLLERITH:
12295 case FFEINFO_basictypeTYPELESS:
12296 error = FALSE;
12297 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12298 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12299 FFEEXPR_contextLET);
12300 break;
12301
12302 default:
12303 error = TRUE;
12304 break;
12305 }
12306 break; /* expr==NULL ok for substring; element case
12307 caught by callback. */
12308
12309 case FFEEXPR_contextDO:
12310 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12311 break;
12312 switch (ffeinfo_basictype (info))
12313 {
12314 case FFEINFO_basictypeLOGICAL:
12315 error = !ffe_is_ugly_logint ();
12316 if (!ffeexpr_stack_->is_rhs)
12317 break; /* Don't convert lhs variable. */
12318 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12319 ffeinfo_kindtype (ffebld_info (expr)), 0,
12320 FFETARGET_charactersizeNONE,
12321 FFEEXPR_contextLET);
12322 break;
12323
12324 case FFEINFO_basictypeHOLLERITH:
12325 case FFEINFO_basictypeTYPELESS:
12326 if (!ffeexpr_stack_->is_rhs)
12327 {
12328 error = TRUE;
12329 break; /* Don't convert lhs variable. */
12330 }
12331 break;
12332
12333 case FFEINFO_basictypeINTEGER:
12334 case FFEINFO_basictypeREAL:
12335 break;
12336
12337 default:
12338 error = TRUE;
12339 break;
12340 }
12341 if (!ffeexpr_stack_->is_rhs
12342 && (ffebld_op (expr) != FFEBLD_opSYMTER))
12343 error = TRUE;
12344 break;
12345
12346 case FFEEXPR_contextDOWHILE:
12347 case FFEEXPR_contextIF:
12348 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12349 break;
12350 switch (ffeinfo_basictype (info))
12351 {
12352 case FFEINFO_basictypeINTEGER:
12353 error = FALSE;
12354 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12355 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12356 FFEEXPR_contextLET);
12357 /* Fall through. */
12358 case FFEINFO_basictypeLOGICAL:
12359 case FFEINFO_basictypeHOLLERITH:
12360 case FFEINFO_basictypeTYPELESS:
12361 error = FALSE;
12362 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12363 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12364 FFEEXPR_contextLET);
12365 break;
12366
12367 default:
12368 error = TRUE;
12369 break;
12370 }
12371 break;
12372
12373 case FFEEXPR_contextASSIGN:
12374 case FFEEXPR_contextAGOTO:
12375 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12376 : ffeinfo_basictype (info))
12377 {
12378 case FFEINFO_basictypeINTEGER:
12379 error = (ffeinfo_kindtype (info) != ffecom_label_kind ());
12380 break;
12381
12382 case FFEINFO_basictypeLOGICAL:
12383 error = !ffe_is_ugly_logint ()
12384 || (ffeinfo_kindtype (info) != ffecom_label_kind ());
12385 break;
12386
12387 default:
12388 error = TRUE;
12389 break;
12390 }
12391 if ((expr == NULL) || (ffeinfo_rank (info) != 0)
12392 || (ffebld_op (expr) != FFEBLD_opSYMTER))
12393 error = TRUE;
12394 break;
12395
12396 case FFEEXPR_contextCGOTO:
12397 case FFEEXPR_contextFORMAT:
12398 case FFEEXPR_contextDIMLIST:
12399 case FFEEXPR_contextFILENUM: /* See equiv code in _ambig_. */
12400 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12401 break;
12402 switch (ffeinfo_basictype (info))
12403 {
12404 case FFEINFO_basictypeLOGICAL:
12405 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12406 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12407 FFEEXPR_contextLET);
12408 /* Fall through. */
12409 case FFEINFO_basictypeREAL:
12410 case FFEINFO_basictypeCOMPLEX:
12411 if (ffe_is_pedantic ())
12412 {
12413 error = TRUE;
12414 break;
12415 }
12416 /* Fall through. */
12417 case FFEINFO_basictypeINTEGER:
12418 case FFEINFO_basictypeHOLLERITH:
12419 case FFEINFO_basictypeTYPELESS:
12420 error = FALSE;
12421 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12422 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12423 FFEEXPR_contextLET);
12424 break;
12425
12426 default:
12427 error = TRUE;
12428 break;
12429 }
12430 break;
12431
12432 case FFEEXPR_contextARITHIF:
12433 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12434 break;
12435 switch (ffeinfo_basictype (info))
12436 {
12437 case FFEINFO_basictypeLOGICAL:
12438 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12439 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12440 FFEEXPR_contextLET);
12441 if (ffe_is_pedantic ())
12442 {
12443 error = TRUE;
12444 break;
12445 }
12446 /* Fall through. */
12447 case FFEINFO_basictypeHOLLERITH:
12448 case FFEINFO_basictypeTYPELESS:
12449 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12450 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12451 FFEEXPR_contextLET);
12452 /* Fall through. */
12453 case FFEINFO_basictypeINTEGER:
12454 case FFEINFO_basictypeREAL:
12455 error = FALSE;
12456 break;
12457
12458 default:
12459 error = TRUE;
12460 break;
12461 }
12462 break;
12463
12464 case FFEEXPR_contextSTOP:
12465 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12466 break;
12467 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12468 : ffeinfo_basictype (info))
12469 {
12470 case FFEINFO_basictypeINTEGER:
12471 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12472 break;
12473
12474 case FFEINFO_basictypeCHARACTER:
12475 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT);
12476 break;
12477
12478 case FFEINFO_basictypeHOLLERITH:
12479 case FFEINFO_basictypeTYPELESS:
12480 error = FALSE;
12481 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12482 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12483 FFEEXPR_contextLET);
12484 break;
12485
12486 case FFEINFO_basictypeNONE:
12487 error = FALSE;
12488 break;
12489
12490 default:
12491 error = TRUE;
12492 break;
12493 }
12494 if ((expr != NULL) && ((ffebld_op (expr) != FFEBLD_opCONTER)
12495 || (ffebld_conter_orig (expr) != NULL)))
12496 error = TRUE;
12497 break;
12498
12499 case FFEEXPR_contextINCLUDE:
12500 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12501 || (ffeinfo_basictype (info) != FFEINFO_basictypeCHARACTER)
12502 || (ffebld_op (expr) != FFEBLD_opCONTER)
12503 || (ffebld_conter_orig (expr) != NULL);
12504 break;
12505
12506 case FFEEXPR_contextSELECTCASE:
12507 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12508 break;
12509 switch (ffeinfo_basictype (info))
12510 {
12511 case FFEINFO_basictypeINTEGER:
12512 case FFEINFO_basictypeCHARACTER:
12513 case FFEINFO_basictypeLOGICAL:
12514 error = FALSE;
12515 break;
12516
12517 case FFEINFO_basictypeHOLLERITH:
12518 case FFEINFO_basictypeTYPELESS:
12519 error = FALSE;
12520 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12521 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12522 FFEEXPR_contextLET);
12523 break;
12524
12525 default:
12526 error = TRUE;
12527 break;
12528 }
12529 break;
12530
12531 case FFEEXPR_contextCASE:
12532 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12533 break;
12534 switch ((expr == NULL) ? FFEINFO_basictypeINTEGER
12535 : ffeinfo_basictype (info))
12536 {
12537 case FFEINFO_basictypeINTEGER:
12538 case FFEINFO_basictypeCHARACTER:
12539 case FFEINFO_basictypeLOGICAL:
12540 error = FALSE;
12541 break;
12542
12543 case FFEINFO_basictypeHOLLERITH:
12544 case FFEINFO_basictypeTYPELESS:
12545 error = FALSE;
12546 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12547 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12548 FFEEXPR_contextLET);
12549 break;
12550
12551 default:
12552 error = TRUE;
12553 break;
12554 }
12555 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12556 error = TRUE;
12557 break;
12558
12559 case FFEEXPR_contextCHARACTERSIZE:
12560 case FFEEXPR_contextKINDTYPE:
12561 case FFEEXPR_contextDIMLISTCOMMON:
12562 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12563 break;
12564 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12565 : ffeinfo_basictype (info))
12566 {
12567 case FFEINFO_basictypeLOGICAL:
12568 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12569 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12570 FFEEXPR_contextLET);
12571 /* Fall through. */
12572 case FFEINFO_basictypeREAL:
12573 case FFEINFO_basictypeCOMPLEX:
12574 if (ffe_is_pedantic ())
12575 {
12576 error = TRUE;
12577 break;
12578 }
12579 /* Fall through. */
12580 case FFEINFO_basictypeINTEGER:
12581 case FFEINFO_basictypeHOLLERITH:
12582 case FFEINFO_basictypeTYPELESS:
12583 error = FALSE;
12584 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12585 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12586 FFEEXPR_contextLET);
12587 break;
12588
12589 default:
12590 error = TRUE;
12591 break;
12592 }
12593 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12594 error = TRUE;
12595 break;
12596
12597 case FFEEXPR_contextEQVINDEX_:
12598 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12599 break;
12600 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12601 : ffeinfo_basictype (info))
12602 {
12603 case FFEINFO_basictypeNONE:
12604 error = FALSE;
12605 break;
12606
12607 case FFEINFO_basictypeLOGICAL:
12608 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12609 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12610 FFEEXPR_contextLET);
12611 /* Fall through. */
12612 case FFEINFO_basictypeREAL:
12613 case FFEINFO_basictypeCOMPLEX:
12614 if (ffe_is_pedantic ())
12615 {
12616 error = TRUE;
12617 break;
12618 }
12619 /* Fall through. */
12620 case FFEINFO_basictypeINTEGER:
12621 case FFEINFO_basictypeHOLLERITH:
12622 case FFEINFO_basictypeTYPELESS:
12623 error = FALSE;
12624 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12625 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12626 FFEEXPR_contextLET);
12627 break;
12628
12629 default:
12630 error = TRUE;
12631 break;
12632 }
12633 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12634 error = TRUE;
12635 break;
12636
12637 case FFEEXPR_contextPARAMETER:
12638 if (ffeexpr_stack_->is_rhs)
12639 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12640 || (ffebld_op (expr) != FFEBLD_opCONTER);
12641 else
12642 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12643 || (ffebld_op (expr) != FFEBLD_opSYMTER);
12644 break;
12645
12646 case FFEEXPR_contextINDEXORACTUALARG_:
12647 if (ffelex_token_type (t) == FFELEX_typeCOLON)
12648 ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
12649 else
12650 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
12651 goto again; /* :::::::::::::::::::: */
12652
12653 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
12654 if (ffelex_token_type (t) == FFELEX_typeCOLON)
12655 ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
12656 else
12657 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
12658 goto again; /* :::::::::::::::::::: */
12659
12660 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
12661 if (ffelex_token_type (t) == FFELEX_typeCOLON)
12662 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
12663 else
12664 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
12665 goto again; /* :::::::::::::::::::: */
12666
12667 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
12668 if (ffelex_token_type (t) == FFELEX_typeCOLON)
12669 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
12670 else
12671 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
12672 goto again; /* :::::::::::::::::::: */
12673
12674 case FFEEXPR_contextIMPDOCTRL_:
12675 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12676 break;
12677 if (!ffeexpr_stack_->is_rhs
12678 && (ffebld_op (expr) != FFEBLD_opSYMTER))
12679 error = TRUE;
12680 switch (ffeinfo_basictype (info))
12681 {
12682 case FFEINFO_basictypeLOGICAL:
12683 error = error && !ffe_is_ugly_logint ();
12684 if (!ffeexpr_stack_->is_rhs)
12685 break; /* Don't convert lhs variable. */
12686 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12687 ffeinfo_kindtype (ffebld_info (expr)), 0,
12688 FFETARGET_charactersizeNONE,
12689 FFEEXPR_contextLET);
12690 break;
12691
12692 case FFEINFO_basictypeINTEGER:
12693 case FFEINFO_basictypeHOLLERITH:
12694 case FFEINFO_basictypeTYPELESS:
12695 break;
12696
12697 case FFEINFO_basictypeREAL:
12698 if (!ffeexpr_stack_->is_rhs
12699 && ffe_is_warn_surprising ()
12700 && !error)
12701 {
12702 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
12703 ffebad_here (0, ffelex_token_where_line (ft),
12704 ffelex_token_where_column (ft));
12705 ffebad_string (ffelex_token_text (ft));
12706 ffebad_finish ();
12707 }
12708 break;
12709
12710 default:
12711 error = TRUE;
12712 break;
12713 }
12714 break;
12715
12716 case FFEEXPR_contextDATAIMPDOCTRL_:
12717 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12718 break;
12719 if (ffeexpr_stack_->is_rhs)
12720 {
12721 if ((ffebld_op (expr) != FFEBLD_opCONTER)
12722 && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12723 error = TRUE;
12724 }
12725 else if ((ffebld_op (expr) != FFEBLD_opSYMTER)
12726 || (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12727 error = TRUE;
12728 switch (ffeinfo_basictype (info))
12729 {
12730 case FFEINFO_basictypeLOGICAL:
12731 error = error
12732 && (ffeinfo_kindtype (info) != FFEINFO_kindtypeLOGICALDEFAULT);
12733 if (!ffeexpr_stack_->is_rhs)
12734 break; /* Don't convert lhs variable. */
12735 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12736 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12737 FFEEXPR_contextLET);
12738 break;
12739
12740 case FFEINFO_basictypeINTEGER:
12741 error = error &&
12742 (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12743 break;
12744
12745 case FFEINFO_basictypeHOLLERITH:
12746 case FFEINFO_basictypeTYPELESS:
12747 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12748 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12749 FFEEXPR_contextLET);
12750 break;
12751
12752 case FFEINFO_basictypeREAL:
12753 if (!ffeexpr_stack_->is_rhs
12754 && ffe_is_warn_surprising ()
12755 && !error)
12756 {
12757 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
12758 ffebad_here (0, ffelex_token_where_line (ft),
12759 ffelex_token_where_column (ft));
12760 ffebad_string (ffelex_token_text (ft));
12761 ffebad_finish ();
12762 }
12763 break;
12764
12765 default:
12766 error = TRUE;
12767 break;
12768 }
12769 break;
12770
12771 case FFEEXPR_contextIMPDOITEM_:
12772 if (ffelex_token_type (t) == FFELEX_typeEQUALS)
12773 {
12774 ffeexpr_stack_->is_rhs = FALSE;
12775 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
12776 goto again; /* :::::::::::::::::::: */
12777 }
12778 /* Fall through. */
12779 case FFEEXPR_contextIOLIST:
12780 case FFEEXPR_contextFILEVXTCODE:
12781 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12782 : ffeinfo_basictype (info))
12783 {
12784 case FFEINFO_basictypeHOLLERITH:
12785 case FFEINFO_basictypeTYPELESS:
12786 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12787 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12788 FFEEXPR_contextLET);
12789 break;
12790
12791 default:
12792 break;
12793 }
12794 error = (expr == NULL)
12795 || ((ffeinfo_rank (info) != 0)
12796 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12797 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12798 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12799 == FFEBLD_opSTAR))); /* Bad if null expr, or if
12800 array that is not a SYMTER
12801 (can't happen yet, I
12802 think) or has a NULL or
12803 STAR (assumed) array
12804 size. */
12805 break;
12806
12807 case FFEEXPR_contextIMPDOITEMDF_:
12808 if (ffelex_token_type (t) == FFELEX_typeEQUALS)
12809 {
12810 ffeexpr_stack_->is_rhs = FALSE;
12811 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
12812 goto again; /* :::::::::::::::::::: */
12813 }
12814 /* Fall through. */
12815 case FFEEXPR_contextIOLISTDF:
12816 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12817 : ffeinfo_basictype (info))
12818 {
12819 case FFEINFO_basictypeHOLLERITH:
12820 case FFEINFO_basictypeTYPELESS:
12821 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12822 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12823 FFEEXPR_contextLET);
12824 break;
12825
12826 default:
12827 break;
12828 }
12829 error
12830 = (expr == NULL)
12831 || ((ffeinfo_basictype (info) == FFEINFO_basictypeCHARACTER)
12832 && (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT))
12833 || ((ffeinfo_rank (info) != 0)
12834 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12835 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12836 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12837 == FFEBLD_opSTAR))); /* Bad if null expr,
12838 non-default-kindtype
12839 character expr, or if
12840 array that is not a SYMTER
12841 (can't happen yet, I
12842 think) or has a NULL or
12843 STAR (assumed) array
12844 size. */
12845 break;
12846
12847 case FFEEXPR_contextDATAIMPDOITEM_:
12848 error = (expr == NULL)
12849 || (ffebld_op (expr) != FFEBLD_opARRAYREF)
12850 || ((ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR)
12851 && (ffeinfo_where (info) != FFEINFO_whereFLEETING_IADDR));
12852 break;
12853
12854 case FFEEXPR_contextDATAIMPDOINDEX_:
12855 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12856 break;
12857 switch (ffeinfo_basictype (info))
12858 {
12859 case FFEINFO_basictypeLOGICAL:
12860 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12861 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12862 FFEEXPR_contextLET);
12863 /* Fall through. */
12864 case FFEINFO_basictypeREAL:
12865 case FFEINFO_basictypeCOMPLEX:
12866 if (ffe_is_pedantic ())
12867 {
12868 error = TRUE;
12869 break;
12870 }
12871 /* Fall through. */
12872 case FFEINFO_basictypeINTEGER:
12873 case FFEINFO_basictypeHOLLERITH:
12874 case FFEINFO_basictypeTYPELESS:
12875 error = FALSE;
12876 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12877 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12878 FFEEXPR_contextLET);
12879 break;
12880
12881 default:
12882 error = TRUE;
12883 break;
12884 }
12885 if ((ffeinfo_where (info) != FFEINFO_whereCONSTANT)
12886 && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12887 error = TRUE;
12888 break;
12889
12890 case FFEEXPR_contextDATA:
12891 if (expr == NULL)
12892 error = TRUE;
12893 else if (ffeexpr_stack_->is_rhs)
12894 error = (ffebld_op (expr) != FFEBLD_opCONTER);
12895 else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12896 error = FALSE;
12897 else
12898 error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12899 break;
12900
12901 case FFEEXPR_contextINITVAL:
12902 error = (expr == NULL) || (ffebld_op (expr) != FFEBLD_opCONTER);
12903 break;
12904
12905 case FFEEXPR_contextEQUIVALENCE:
12906 if (expr == NULL)
12907 error = TRUE;
12908 else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12909 error = FALSE;
12910 else
12911 error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12912 break;
12913
12914 case FFEEXPR_contextFILEASSOC:
12915 case FFEEXPR_contextFILEINT:
12916 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12917 : ffeinfo_basictype (info))
12918 {
12919 case FFEINFO_basictypeINTEGER:
12920 /* Maybe this should be supported someday, but, right now,
12921 g77 can't generate a call to libf2c to write to an
12922 integer other than the default size. */
12923 error = ((! ffeexpr_stack_->is_rhs)
12924 && ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12925 break;
12926
12927 default:
12928 error = TRUE;
12929 break;
12930 }
12931 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12932 error = TRUE;
12933 break;
12934
12935 case FFEEXPR_contextFILEDFINT:
12936 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12937 : ffeinfo_basictype (info))
12938 {
12939 case FFEINFO_basictypeINTEGER:
12940 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12941 break;
12942
12943 default:
12944 error = TRUE;
12945 break;
12946 }
12947 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12948 error = TRUE;
12949 break;
12950
12951 case FFEEXPR_contextFILELOG:
12952 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12953 : ffeinfo_basictype (info))
12954 {
12955 case FFEINFO_basictypeLOGICAL:
12956 error = FALSE;
12957 break;
12958
12959 default:
12960 error = TRUE;
12961 break;
12962 }
12963 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12964 error = TRUE;
12965 break;
12966
12967 case FFEEXPR_contextFILECHAR:
12968 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12969 : ffeinfo_basictype (info))
12970 {
12971 case FFEINFO_basictypeCHARACTER:
12972 error = FALSE;
12973 break;
12974
12975 default:
12976 error = TRUE;
12977 break;
12978 }
12979 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12980 error = TRUE;
12981 break;
12982
12983 case FFEEXPR_contextFILENUMCHAR:
12984 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12985 break;
12986 switch (ffeinfo_basictype (info))
12987 {
12988 case FFEINFO_basictypeLOGICAL:
12989 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12990 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12991 FFEEXPR_contextLET);
12992 /* Fall through. */
12993 case FFEINFO_basictypeREAL:
12994 case FFEINFO_basictypeCOMPLEX:
12995 if (ffe_is_pedantic ())
12996 {
12997 error = TRUE;
12998 break;
12999 }
13000 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13001 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13002 FFEEXPR_contextLET);
13003 break;
13004
13005 case FFEINFO_basictypeINTEGER:
13006 case FFEINFO_basictypeCHARACTER:
13007 error = FALSE;
13008 break;
13009
13010 default:
13011 error = TRUE;
13012 break;
13013 }
13014 break;
13015
13016 case FFEEXPR_contextFILEDFCHAR:
13017 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
13018 break;
13019 switch (ffeinfo_basictype (info))
13020 {
13021 case FFEINFO_basictypeCHARACTER:
13022 error
13023 = (ffeinfo_kindtype (info)
13024 != FFEINFO_kindtypeCHARACTERDEFAULT);
13025 break;
13026
13027 default:
13028 error = TRUE;
13029 break;
13030 }
13031 if (!ffeexpr_stack_->is_rhs
13032 && (ffebld_op (expr) == FFEBLD_opSUBSTR))
13033 error = TRUE;
13034 break;
13035
13036 case FFEEXPR_contextFILEUNIT: /* See equiv code in _ambig_. */
13037 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13038 : ffeinfo_basictype (info))
13039 {
13040 case FFEINFO_basictypeLOGICAL:
13041 if ((error = (ffeinfo_rank (info) != 0)))
13042 break;
13043 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13044 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13045 FFEEXPR_contextLET);
13046 /* Fall through. */
13047 case FFEINFO_basictypeREAL:
13048 case FFEINFO_basictypeCOMPLEX:
13049 if ((error = (ffeinfo_rank (info) != 0)))
13050 break;
13051 if (ffe_is_pedantic ())
13052 {
13053 error = TRUE;
13054 break;
13055 }
13056 /* Fall through. */
13057 case FFEINFO_basictypeINTEGER:
13058 case FFEINFO_basictypeHOLLERITH:
13059 case FFEINFO_basictypeTYPELESS:
13060 if ((error = (ffeinfo_rank (info) != 0)))
13061 break;
13062 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13063 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13064 FFEEXPR_contextLET);
13065 break;
13066
13067 case FFEINFO_basictypeCHARACTER:
13068 switch (ffebld_op (expr))
13069 { /* As if _lhs had been called instead of
13070 _rhs. */
13071 case FFEBLD_opSYMTER:
13072 error
13073 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
13074 break;
13075
13076 case FFEBLD_opSUBSTR:
13077 error = (ffeinfo_where (ffebld_info (expr))
13078 == FFEINFO_whereCONSTANT_SUBOBJECT);
13079 break;
13080
13081 case FFEBLD_opARRAYREF:
13082 error = FALSE;
13083 break;
13084
13085 default:
13086 error = TRUE;
13087 break;
13088 }
13089 if (!error
13090 && ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
13091 || ((ffeinfo_rank (info) != 0)
13092 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
13093 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
13094 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
13095 == FFEBLD_opSTAR))))) /* Bad if
13096 non-default-kindtype
13097 character expr, or if
13098 array that is not a SYMTER
13099 (can't happen yet, I
13100 think), or has a NULL or
13101 STAR (assumed) array
13102 size. */
13103 error = TRUE;
13104 break;
13105
13106 default:
13107 error = TRUE;
13108 break;
13109 }
13110 break;
13111
13112 case FFEEXPR_contextFILEFORMAT:
13113 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13114 : ffeinfo_basictype (info))
13115 {
13116 case FFEINFO_basictypeINTEGER:
13117 error = (expr == NULL)
13118 || ((ffeinfo_rank (info) != 0) ?
13119 ffe_is_pedantic () /* F77 C5. */
13120 : (ffeinfo_kindtype (info) != ffecom_label_kind ()))
13121 || (ffebld_op (expr) != FFEBLD_opSYMTER);
13122 break;
13123
13124 case FFEINFO_basictypeLOGICAL:
13125 case FFEINFO_basictypeREAL:
13126 case FFEINFO_basictypeCOMPLEX:
13127 /* F77 C5 -- must be an array of hollerith. */
13128 error
13129 = ffe_is_pedantic ()
13130 || (ffeinfo_rank (info) == 0);
13131 break;
13132
13133 case FFEINFO_basictypeCHARACTER:
13134 if ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
13135 || ((ffeinfo_rank (info) != 0)
13136 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
13137 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
13138 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
13139 == FFEBLD_opSTAR)))) /* Bad if
13140 non-default-kindtype
13141 character expr, or if
13142 array that is not a SYMTER
13143 (can't happen yet, I
13144 think), or has a NULL or
13145 STAR (assumed) array
13146 size. */
13147 error = TRUE;
13148 else
13149 error = FALSE;
13150 break;
13151
13152 default:
13153 error = TRUE;
13154 break;
13155 }
13156 break;
13157
13158 case FFEEXPR_contextLOC_:
13159 /* See also ffeintrin_check_loc_. */
13160 if ((expr == NULL)
13161 || (ffeinfo_kind (info) != FFEINFO_kindENTITY)
13162 || ((ffebld_op (expr) != FFEBLD_opSYMTER)
13163 && (ffebld_op (expr) != FFEBLD_opSUBSTR)
13164 && (ffebld_op (expr) != FFEBLD_opARRAYREF)))
13165 error = TRUE;
13166 break;
13167
13168 default:
13169 error = FALSE;
13170 break;
13171 }
13172
13173 if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
13174 {
13175 ffebad_start (FFEBAD_EXPR_WRONG);
13176 ffebad_here (0, ffelex_token_where_line (ft),
13177 ffelex_token_where_column (ft));
13178 ffebad_finish ();
13179 expr = ffebld_new_any ();
13180 ffebld_set_info (expr, ffeinfo_new_any ());
13181 }
13182
13183 callback = ffeexpr_stack_->callback;
13184 s = ffeexpr_stack_->previous;
13185 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
13186 sizeof (*ffeexpr_stack_));
13187 ffeexpr_stack_ = s;
13188 next = (ffelexHandler) (*callback) (ft, expr, t);
13189 ffelex_token_kill (ft);
13190 return (ffelexHandler) next;
13191 }
13192
13193 /* ffeexpr_finished_ambig_ -- Check validity of ambiguous unit/form spec
13194
13195 ffebld expr;
13196 expr = ffeexpr_finished_ambig_(expr);
13197
13198 Replicates a bit of ffeexpr_finished_'s task when in a context
13199 of UNIT or FORMAT. */
13200
13201 static ffebld
13202 ffeexpr_finished_ambig_ (ffelexToken ft, ffebld expr)
13203 {
13204 ffeinfo info = ffebld_info (expr);
13205 bool error;
13206
13207 switch (ffeexpr_stack_->context)
13208 {
13209 case FFEEXPR_contextFILENUMAMBIG: /* Same as FILENUM in _finished_. */
13210 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13211 : ffeinfo_basictype (info))
13212 {
13213 case FFEINFO_basictypeLOGICAL:
13214 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13215 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13216 FFEEXPR_contextLET);
13217 /* Fall through. */
13218 case FFEINFO_basictypeREAL:
13219 case FFEINFO_basictypeCOMPLEX:
13220 if (ffe_is_pedantic ())
13221 {
13222 error = TRUE;
13223 break;
13224 }
13225 /* Fall through. */
13226 case FFEINFO_basictypeINTEGER:
13227 case FFEINFO_basictypeHOLLERITH:
13228 case FFEINFO_basictypeTYPELESS:
13229 error = FALSE;
13230 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13231 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13232 FFEEXPR_contextLET);
13233 break;
13234
13235 default:
13236 error = TRUE;
13237 break;
13238 }
13239 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13240 error = TRUE;
13241 break;
13242
13243 case FFEEXPR_contextFILEUNITAMBIG: /* Same as FILEUNIT in _finished_. */
13244 if ((expr != NULL) && (ffebld_op (expr) == FFEBLD_opSTAR))
13245 {
13246 error = FALSE;
13247 break;
13248 }
13249 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13250 : ffeinfo_basictype (info))
13251 {
13252 case FFEINFO_basictypeLOGICAL:
13253 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13254 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13255 FFEEXPR_contextLET);
13256 /* Fall through. */
13257 case FFEINFO_basictypeREAL:
13258 case FFEINFO_basictypeCOMPLEX:
13259 if (ffe_is_pedantic ())
13260 {
13261 error = TRUE;
13262 break;
13263 }
13264 /* Fall through. */
13265 case FFEINFO_basictypeINTEGER:
13266 case FFEINFO_basictypeHOLLERITH:
13267 case FFEINFO_basictypeTYPELESS:
13268 error = (ffeinfo_rank (info) != 0);
13269 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13270 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13271 FFEEXPR_contextLET);
13272 break;
13273
13274 case FFEINFO_basictypeCHARACTER:
13275 switch (ffebld_op (expr))
13276 { /* As if _lhs had been called instead of
13277 _rhs. */
13278 case FFEBLD_opSYMTER:
13279 error
13280 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
13281 break;
13282
13283 case FFEBLD_opSUBSTR:
13284 error = (ffeinfo_where (ffebld_info (expr))
13285 == FFEINFO_whereCONSTANT_SUBOBJECT);
13286 break;
13287
13288 case FFEBLD_opARRAYREF:
13289 error = FALSE;
13290 break;
13291
13292 default:
13293 error = TRUE;
13294 break;
13295 }
13296 break;
13297
13298 default:
13299 error = TRUE;
13300 break;
13301 }
13302 break;
13303
13304 default:
13305 assert ("bad context" == NULL);
13306 error = TRUE;
13307 break;
13308 }
13309
13310 if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
13311 {
13312 ffebad_start (FFEBAD_EXPR_WRONG);
13313 ffebad_here (0, ffelex_token_where_line (ft),
13314 ffelex_token_where_column (ft));
13315 ffebad_finish ();
13316 expr = ffebld_new_any ();
13317 ffebld_set_info (expr, ffeinfo_new_any ());
13318 }
13319
13320 return expr;
13321 }
13322
13323 /* ffeexpr_token_lhs_ -- Initial state for lhs expression
13324
13325 Return a pointer to this function to the lexer (ffelex), which will
13326 invoke it for the next token.
13327
13328 Basically a smaller version of _rhs_; keep them both in sync, of course. */
13329
13330 static ffelexHandler
13331 ffeexpr_token_lhs_ (ffelexToken t)
13332 {
13333
13334 /* When changing the list of valid initial lhs tokens, check whether to
13335 update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
13336 READ (expr) <token> case -- it assumes it knows which tokens <token> can
13337 be to indicate an lhs (or implied DO), which right now is the set
13338 {NAME,OPEN_PAREN}.
13339
13340 This comment also appears in ffeexpr_token_first_lhs_. */
13341
13342 switch (ffelex_token_type (t))
13343 {
13344 case FFELEX_typeNAME:
13345 case FFELEX_typeNAMES:
13346 ffeexpr_tokens_[0] = ffelex_token_use (t);
13347 return (ffelexHandler) ffeexpr_token_name_lhs_;
13348
13349 default:
13350 return (ffelexHandler) ffeexpr_finished_ (t);
13351 }
13352 }
13353
13354 /* ffeexpr_token_rhs_ -- Initial state for rhs expression
13355
13356 Return a pointer to this function to the lexer (ffelex), which will
13357 invoke it for the next token.
13358
13359 The initial state and the post-binary-operator state are the same and
13360 both handled here, with the expression stack used to distinguish
13361 between them. Binary operators are invalid here; unary operators,
13362 constants, subexpressions, and name references are valid. */
13363
13364 static ffelexHandler
13365 ffeexpr_token_rhs_ (ffelexToken t)
13366 {
13367 ffeexprExpr_ e;
13368
13369 switch (ffelex_token_type (t))
13370 {
13371 case FFELEX_typeQUOTE:
13372 if (ffe_is_vxt ())
13373 {
13374 ffeexpr_tokens_[0] = ffelex_token_use (t);
13375 return (ffelexHandler) ffeexpr_token_quote_;
13376 }
13377 ffeexpr_tokens_[0] = ffelex_token_use (t);
13378 ffelex_set_expecting_hollerith (-1, '\"',
13379 ffelex_token_where_line (t),
13380 ffelex_token_where_column (t));
13381 /* Don't have to unset this one. */
13382 return (ffelexHandler) ffeexpr_token_apostrophe_;
13383
13384 case FFELEX_typeAPOSTROPHE:
13385 ffeexpr_tokens_[0] = ffelex_token_use (t);
13386 ffelex_set_expecting_hollerith (-1, '\'',
13387 ffelex_token_where_line (t),
13388 ffelex_token_where_column (t));
13389 /* Don't have to unset this one. */
13390 return (ffelexHandler) ffeexpr_token_apostrophe_;
13391
13392 case FFELEX_typePERCENT:
13393 ffeexpr_tokens_[0] = ffelex_token_use (t);
13394 return (ffelexHandler) ffeexpr_token_percent_;
13395
13396 case FFELEX_typeOPEN_PAREN:
13397 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
13398 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
13399 FFEEXPR_contextPAREN_,
13400 ffeexpr_cb_close_paren_c_);
13401
13402 case FFELEX_typePLUS:
13403 e = ffeexpr_expr_new_ ();
13404 e->type = FFEEXPR_exprtypeUNARY_;
13405 e->token = ffelex_token_use (t);
13406 e->u.operator.op = FFEEXPR_operatorADD_;
13407 e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
13408 e->u.operator.as = FFEEXPR_operatorassociativityADD_;
13409 ffeexpr_exprstack_push_unary_ (e);
13410 return (ffelexHandler) ffeexpr_token_rhs_;
13411
13412 case FFELEX_typeMINUS:
13413 e = ffeexpr_expr_new_ ();
13414 e->type = FFEEXPR_exprtypeUNARY_;
13415 e->token = ffelex_token_use (t);
13416 e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
13417 e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
13418 e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
13419 ffeexpr_exprstack_push_unary_ (e);
13420 return (ffelexHandler) ffeexpr_token_rhs_;
13421
13422 case FFELEX_typePERIOD:
13423 ffeexpr_tokens_[0] = ffelex_token_use (t);
13424 return (ffelexHandler) ffeexpr_token_period_;
13425
13426 case FFELEX_typeNUMBER:
13427 ffeexpr_tokens_[0] = ffelex_token_use (t);
13428 ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
13429 if (ffeexpr_hollerith_count_ > 0)
13430 ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
13431 '\0',
13432 ffelex_token_where_line (t),
13433 ffelex_token_where_column (t));
13434 return (ffelexHandler) ffeexpr_token_number_;
13435
13436 case FFELEX_typeNAME:
13437 case FFELEX_typeNAMES:
13438 ffeexpr_tokens_[0] = ffelex_token_use (t);
13439 switch (ffeexpr_stack_->context)
13440 {
13441 case FFEEXPR_contextACTUALARG_:
13442 case FFEEXPR_contextINDEXORACTUALARG_:
13443 case FFEEXPR_contextSFUNCDEFACTUALARG_:
13444 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
13445 return (ffelexHandler) ffeexpr_token_name_arg_;
13446
13447 default:
13448 return (ffelexHandler) ffeexpr_token_name_rhs_;
13449 }
13450
13451 case FFELEX_typeASTERISK:
13452 case FFELEX_typeSLASH:
13453 case FFELEX_typePOWER:
13454 case FFELEX_typeCONCAT:
13455 case FFELEX_typeREL_EQ:
13456 case FFELEX_typeREL_NE:
13457 case FFELEX_typeREL_LE:
13458 case FFELEX_typeREL_GE:
13459 if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
13460 {
13461 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13462 ffebad_finish ();
13463 }
13464 return (ffelexHandler) ffeexpr_token_rhs_;
13465
13466 #if 0
13467 case FFELEX_typeEQUALS:
13468 case FFELEX_typePOINTS:
13469 case FFELEX_typeCLOSE_ANGLE:
13470 case FFELEX_typeCLOSE_PAREN:
13471 case FFELEX_typeCOMMA:
13472 case FFELEX_typeCOLON:
13473 case FFELEX_typeEOS:
13474 case FFELEX_typeSEMICOLON:
13475 #endif
13476 default:
13477 return (ffelexHandler) ffeexpr_finished_ (t);
13478 }
13479 }
13480
13481 /* ffeexpr_token_period_ -- Rhs PERIOD
13482
13483 Return a pointer to this function to the lexer (ffelex), which will
13484 invoke it for the next token.
13485
13486 Handle a period detected at rhs (expecting unary op or operand) state.
13487 Must begin a floating-point value (as in .12) or a dot-dot name, of
13488 which only .NOT., .TRUE., and .FALSE. are truly valid. Other sort-of-
13489 valid names represent binary operators, which are invalid here because
13490 there isn't an operand at the top of the stack. */
13491
13492 static ffelexHandler
13493 ffeexpr_token_period_ (ffelexToken t)
13494 {
13495 switch (ffelex_token_type (t))
13496 {
13497 case FFELEX_typeNAME:
13498 case FFELEX_typeNAMES:
13499 ffeexpr_current_dotdot_ = ffestr_other (t);
13500 switch (ffeexpr_current_dotdot_)
13501 {
13502 case FFESTR_otherNone:
13503 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
13504 {
13505 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13506 ffelex_token_where_column (ffeexpr_tokens_[0]));
13507 ffebad_finish ();
13508 }
13509 ffelex_token_kill (ffeexpr_tokens_[0]);
13510 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13511
13512 case FFESTR_otherTRUE:
13513 case FFESTR_otherFALSE:
13514 case FFESTR_otherNOT:
13515 ffeexpr_tokens_[1] = ffelex_token_use (t);
13516 return (ffelexHandler) ffeexpr_token_end_period_;
13517
13518 default:
13519 if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
13520 {
13521 ffebad_here (0, ffelex_token_where_line (t),
13522 ffelex_token_where_column (t));
13523 ffebad_finish ();
13524 }
13525 ffelex_token_kill (ffeexpr_tokens_[0]);
13526 return (ffelexHandler) ffeexpr_token_swallow_period_;
13527 }
13528 break; /* Nothing really reaches here. */
13529
13530 case FFELEX_typeNUMBER:
13531 ffeexpr_tokens_[1] = ffelex_token_use (t);
13532 return (ffelexHandler) ffeexpr_token_real_;
13533
13534 default:
13535 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
13536 {
13537 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13538 ffelex_token_where_column (ffeexpr_tokens_[0]));
13539 ffebad_finish ();
13540 }
13541 ffelex_token_kill (ffeexpr_tokens_[0]);
13542 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13543 }
13544 }
13545
13546 /* ffeexpr_token_end_period_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
13547
13548 Return a pointer to this function to the lexer (ffelex), which will
13549 invoke it for the next token.
13550
13551 Expecting a period to close a .NOT, .TRUE, or .FALSE at rhs (unary op
13552 or operator) state. If period isn't found, issue a diagnostic but
13553 pretend we saw one. ffeexpr_current_dotdot_ must already contained the
13554 dotdot representation of the name in between the two PERIOD tokens. */
13555
13556 static ffelexHandler
13557 ffeexpr_token_end_period_ (ffelexToken t)
13558 {
13559 ffeexprExpr_ e;
13560
13561 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13562 {
13563 if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
13564 {
13565 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13566 ffelex_token_where_column (ffeexpr_tokens_[0]));
13567 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13568 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
13569 ffebad_finish ();
13570 }
13571 }
13572
13573 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill "NOT"/"TRUE"/"FALSE"
13574 token. */
13575
13576 e = ffeexpr_expr_new_ ();
13577 e->token = ffeexpr_tokens_[0];
13578
13579 switch (ffeexpr_current_dotdot_)
13580 {
13581 case FFESTR_otherNOT:
13582 e->type = FFEEXPR_exprtypeUNARY_;
13583 e->u.operator.op = FFEEXPR_operatorNOT_;
13584 e->u.operator.prec = FFEEXPR_operatorprecedenceNOT_;
13585 e->u.operator.as = FFEEXPR_operatorassociativityNOT_;
13586 ffeexpr_exprstack_push_unary_ (e);
13587 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13588 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13589 return (ffelexHandler) ffeexpr_token_rhs_;
13590
13591 case FFESTR_otherTRUE:
13592 e->type = FFEEXPR_exprtypeOPERAND_;
13593 e->u.operand
13594 = ffebld_new_conter (ffebld_constant_new_logicaldefault (TRUE));
13595 ffebld_set_info (e->u.operand,
13596 ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
13597 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13598 ffeexpr_exprstack_push_operand_ (e);
13599 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13600 return (ffelexHandler) ffeexpr_token_binary_ (t);
13601 return (ffelexHandler) ffeexpr_token_binary_;
13602
13603 case FFESTR_otherFALSE:
13604 e->type = FFEEXPR_exprtypeOPERAND_;
13605 e->u.operand
13606 = ffebld_new_conter (ffebld_constant_new_logicaldefault (FALSE));
13607 ffebld_set_info (e->u.operand,
13608 ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
13609 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13610 ffeexpr_exprstack_push_operand_ (e);
13611 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13612 return (ffelexHandler) ffeexpr_token_binary_ (t);
13613 return (ffelexHandler) ffeexpr_token_binary_;
13614
13615 default:
13616 assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL);
13617 exit (0);
13618 return NULL;
13619 }
13620 }
13621
13622 /* ffeexpr_token_swallow_period_ -- Rhs PERIOD NAME(not NOT, TRUE, or FALSE)
13623
13624 Return a pointer to this function to the lexer (ffelex), which will
13625 invoke it for the next token.
13626
13627 A diagnostic has already been issued; just swallow a period if there is
13628 one, then continue with ffeexpr_token_rhs_. */
13629
13630 static ffelexHandler
13631 ffeexpr_token_swallow_period_ (ffelexToken t)
13632 {
13633 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13634 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13635
13636 return (ffelexHandler) ffeexpr_token_rhs_;
13637 }
13638
13639 /* ffeexpr_token_real_ -- Rhs PERIOD NUMBER
13640
13641 Return a pointer to this function to the lexer (ffelex), which will
13642 invoke it for the next token.
13643
13644 After a period and a string of digits, check next token for possible
13645 exponent designation (D, E, or Q as first/only character) and continue
13646 real-number handling accordingly. Else form basic real constant, push
13647 onto expression stack, and enter binary state using current token (which,
13648 if it is a name not beginning with D, E, or Q, will certainly result
13649 in an error, but that's not for this routine to deal with). */
13650
13651 static ffelexHandler
13652 ffeexpr_token_real_ (ffelexToken t)
13653 {
13654 char d;
13655 char *p;
13656
13657 if (((ffelex_token_type (t) != FFELEX_typeNAME)
13658 && (ffelex_token_type (t) != FFELEX_typeNAMES))
13659 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13660 'D', 'd')
13661 || ffesrc_char_match_init (d, 'E', 'e')
13662 || ffesrc_char_match_init (d, 'Q', 'q')))
13663 && ffeexpr_isdigits_ (++p)))
13664 {
13665 #if 0
13666 /* This code has been removed because it seems inconsistent to
13667 produce a diagnostic in this case, but not all of the other
13668 ones that look for an exponent and cannot recognize one. */
13669 if (((ffelex_token_type (t) == FFELEX_typeNAME)
13670 || (ffelex_token_type (t) == FFELEX_typeNAMES))
13671 && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
13672 {
13673 char bad[2];
13674
13675 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13676 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
13677 ffelex_token_where_column (ffeexpr_tokens_[0]));
13678 bad[0] = *(p - 1);
13679 bad[1] = '\0';
13680 ffebad_string (bad);
13681 ffebad_finish ();
13682 }
13683 #endif
13684 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13685 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13686 NULL, NULL, NULL);
13687
13688 ffelex_token_kill (ffeexpr_tokens_[0]);
13689 ffelex_token_kill (ffeexpr_tokens_[1]);
13690 return (ffelexHandler) ffeexpr_token_binary_ (t);
13691 }
13692
13693 /* Just exponent character by itself? In which case, PLUS or MINUS must
13694 surely be next, followed by a NUMBER token. */
13695
13696 if (*p == '\0')
13697 {
13698 ffeexpr_tokens_[2] = ffelex_token_use (t);
13699 return (ffelexHandler) ffeexpr_token_real_exponent_;
13700 }
13701
13702 ffeexpr_make_float_const_ (d, NULL, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13703 t, NULL, NULL);
13704
13705 ffelex_token_kill (ffeexpr_tokens_[0]);
13706 ffelex_token_kill (ffeexpr_tokens_[1]);
13707 return (ffelexHandler) ffeexpr_token_binary_;
13708 }
13709
13710 /* ffeexpr_token_real_exponent_ -- Rhs PERIOD NUMBER NAME(D, E, or Q)
13711
13712 Return a pointer to this function to the lexer (ffelex), which will
13713 invoke it for the next token.
13714
13715 Ensures this token is PLUS or MINUS, preserves it, goes to final state
13716 for real number (exponent digits). Else issues diagnostic, assumes a
13717 zero exponent field for number, passes token on to binary state as if
13718 previous token had been "E0" instead of "E", for example. */
13719
13720 static ffelexHandler
13721 ffeexpr_token_real_exponent_ (ffelexToken t)
13722 {
13723 if ((ffelex_token_type (t) != FFELEX_typePLUS)
13724 && (ffelex_token_type (t) != FFELEX_typeMINUS))
13725 {
13726 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13727 {
13728 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
13729 ffelex_token_where_column (ffeexpr_tokens_[2]));
13730 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13731 ffebad_finish ();
13732 }
13733
13734 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13735 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13736 NULL, NULL, NULL);
13737
13738 ffelex_token_kill (ffeexpr_tokens_[0]);
13739 ffelex_token_kill (ffeexpr_tokens_[1]);
13740 ffelex_token_kill (ffeexpr_tokens_[2]);
13741 return (ffelexHandler) ffeexpr_token_binary_ (t);
13742 }
13743
13744 ffeexpr_tokens_[3] = ffelex_token_use (t);
13745 return (ffelexHandler) ffeexpr_token_real_exp_sign_;
13746 }
13747
13748 /* ffeexpr_token_real_exp_sign_ -- Rhs PERIOD NUMBER NAME(D,E,Q) PLUS/MINUS
13749
13750 Return a pointer to this function to the lexer (ffelex), which will
13751 invoke it for the next token.
13752
13753 Make sure token is a NUMBER, make a real constant out of all we have and
13754 push it onto the expression stack. Else issue diagnostic and pretend
13755 exponent field was a zero. */
13756
13757 static ffelexHandler
13758 ffeexpr_token_real_exp_sign_ (ffelexToken t)
13759 {
13760 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13761 {
13762 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13763 {
13764 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
13765 ffelex_token_where_column (ffeexpr_tokens_[2]));
13766 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13767 ffebad_finish ();
13768 }
13769
13770 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13771 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13772 NULL, NULL, NULL);
13773
13774 ffelex_token_kill (ffeexpr_tokens_[0]);
13775 ffelex_token_kill (ffeexpr_tokens_[1]);
13776 ffelex_token_kill (ffeexpr_tokens_[2]);
13777 ffelex_token_kill (ffeexpr_tokens_[3]);
13778 return (ffelexHandler) ffeexpr_token_binary_ (t);
13779 }
13780
13781 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0], NULL,
13782 ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2],
13783 ffeexpr_tokens_[3], t);
13784
13785 ffelex_token_kill (ffeexpr_tokens_[0]);
13786 ffelex_token_kill (ffeexpr_tokens_[1]);
13787 ffelex_token_kill (ffeexpr_tokens_[2]);
13788 ffelex_token_kill (ffeexpr_tokens_[3]);
13789 return (ffelexHandler) ffeexpr_token_binary_;
13790 }
13791
13792 /* ffeexpr_token_number_ -- Rhs NUMBER
13793
13794 Return a pointer to this function to the lexer (ffelex), which will
13795 invoke it for the next token.
13796
13797 If the token is a period, we may have a floating-point number, or an
13798 integer followed by a dotdot binary operator. If the token is a name
13799 beginning with D, E, or Q, we definitely have a floating-point number.
13800 If the token is a hollerith constant, that's what we've got, so push
13801 it onto the expression stack and continue with the binary state.
13802
13803 Otherwise, we have an integer followed by something the binary state
13804 should be able to swallow. */
13805
13806 static ffelexHandler
13807 ffeexpr_token_number_ (ffelexToken t)
13808 {
13809 ffeexprExpr_ e;
13810 ffeinfo ni;
13811 char d;
13812 char *p;
13813
13814 if (ffeexpr_hollerith_count_ > 0)
13815 ffelex_set_expecting_hollerith (0, '\0',
13816 ffewhere_line_unknown (),
13817 ffewhere_column_unknown ());
13818
13819 /* See if we've got a floating-point number here. */
13820
13821 switch (ffelex_token_type (t))
13822 {
13823 case FFELEX_typeNAME:
13824 case FFELEX_typeNAMES:
13825 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13826 'D', 'd')
13827 || ffesrc_char_match_init (d, 'E', 'e')
13828 || ffesrc_char_match_init (d, 'Q', 'q'))
13829 && ffeexpr_isdigits_ (++p))
13830 {
13831
13832 /* Just exponent character by itself? In which case, PLUS or MINUS
13833 must surely be next, followed by a NUMBER token. */
13834
13835 if (*p == '\0')
13836 {
13837 ffeexpr_tokens_[1] = ffelex_token_use (t);
13838 return (ffelexHandler) ffeexpr_token_number_exponent_;
13839 }
13840 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], NULL, NULL, t,
13841 NULL, NULL);
13842
13843 ffelex_token_kill (ffeexpr_tokens_[0]);
13844 return (ffelexHandler) ffeexpr_token_binary_;
13845 }
13846 break;
13847
13848 case FFELEX_typePERIOD:
13849 ffeexpr_tokens_[1] = ffelex_token_use (t);
13850 return (ffelexHandler) ffeexpr_token_number_period_;
13851
13852 case FFELEX_typeHOLLERITH:
13853 e = ffeexpr_expr_new_ ();
13854 e->type = FFEEXPR_exprtypeOPERAND_;
13855 e->token = ffeexpr_tokens_[0];
13856 e->u.operand = ffebld_new_conter (ffebld_constant_new_hollerith (t));
13857 ni = ffeinfo_new (FFEINFO_basictypeHOLLERITH, FFEINFO_kindtypeNONE,
13858 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
13859 ffelex_token_length (t));
13860 ffebld_set_info (e->u.operand, ni);
13861 ffeexpr_exprstack_push_operand_ (e);
13862 return (ffelexHandler) ffeexpr_token_binary_;
13863
13864 default:
13865 break;
13866 }
13867
13868 /* Nothing specific we were looking for, so make an integer and pass the
13869 current token to the binary state. */
13870
13871 ffeexpr_make_float_const_ ('I', ffeexpr_tokens_[0], NULL, NULL,
13872 NULL, NULL, NULL);
13873 return (ffelexHandler) ffeexpr_token_binary_ (t);
13874 }
13875
13876 /* ffeexpr_token_number_exponent_ -- Rhs NUMBER NAME(D, E, or Q)
13877
13878 Return a pointer to this function to the lexer (ffelex), which will
13879 invoke it for the next token.
13880
13881 Ensures this token is PLUS or MINUS, preserves it, goes to final state
13882 for real number (exponent digits). Else treats number as integer, passes
13883 name to binary, passes current token to subsequent handler. */
13884
13885 static ffelexHandler
13886 ffeexpr_token_number_exponent_ (ffelexToken t)
13887 {
13888 if ((ffelex_token_type (t) != FFELEX_typePLUS)
13889 && (ffelex_token_type (t) != FFELEX_typeMINUS))
13890 {
13891 ffeexprExpr_ e;
13892 ffelexHandler nexthandler;
13893
13894 e = ffeexpr_expr_new_ ();
13895 e->type = FFEEXPR_exprtypeOPERAND_;
13896 e->token = ffeexpr_tokens_[0];
13897 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
13898 (ffeexpr_tokens_[0]));
13899 ffebld_set_info (e->u.operand,
13900 ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT,
13901 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13902 ffeexpr_exprstack_push_operand_ (e);
13903 nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[1]);
13904 ffelex_token_kill (ffeexpr_tokens_[1]);
13905 return (ffelexHandler) (*nexthandler) (t);
13906 }
13907
13908 ffeexpr_tokens_[2] = ffelex_token_use (t);
13909 return (ffelexHandler) ffeexpr_token_number_exp_sign_;
13910 }
13911
13912 /* ffeexpr_token_number_exp_sign_ -- Rhs NUMBER NAME(D,E,Q) PLUS/MINUS
13913
13914 Return a pointer to this function to the lexer (ffelex), which will
13915 invoke it for the next token.
13916
13917 Make sure token is a NUMBER, make a real constant out of all we have and
13918 push it onto the expression stack. Else issue diagnostic and pretend
13919 exponent field was a zero. */
13920
13921 static ffelexHandler
13922 ffeexpr_token_number_exp_sign_ (ffelexToken t)
13923 {
13924 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13925 {
13926 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13927 {
13928 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[1]),
13929 ffelex_token_where_column (ffeexpr_tokens_[1]));
13930 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13931 ffebad_finish ();
13932 }
13933
13934 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
13935 ffeexpr_tokens_[0], NULL, NULL,
13936 ffeexpr_tokens_[1], ffeexpr_tokens_[2],
13937 NULL);
13938
13939 ffelex_token_kill (ffeexpr_tokens_[0]);
13940 ffelex_token_kill (ffeexpr_tokens_[1]);
13941 ffelex_token_kill (ffeexpr_tokens_[2]);
13942 return (ffelexHandler) ffeexpr_token_binary_ (t);
13943 }
13944
13945 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
13946 ffeexpr_tokens_[0], NULL, NULL,
13947 ffeexpr_tokens_[1], ffeexpr_tokens_[2], t);
13948
13949 ffelex_token_kill (ffeexpr_tokens_[0]);
13950 ffelex_token_kill (ffeexpr_tokens_[1]);
13951 ffelex_token_kill (ffeexpr_tokens_[2]);
13952 return (ffelexHandler) ffeexpr_token_binary_;
13953 }
13954
13955 /* ffeexpr_token_number_period_ -- Rhs NUMBER PERIOD
13956
13957 Return a pointer to this function to the lexer (ffelex), which will
13958 invoke it for the next token.
13959
13960 Handle a period detected following a number at rhs state. Must begin a
13961 floating-point value (as in 1., 1.2, 1.E3, or 1.E+3) or a dot-dot name. */
13962
13963 static ffelexHandler
13964 ffeexpr_token_number_period_ (ffelexToken t)
13965 {
13966 ffeexprExpr_ e;
13967 ffelexHandler nexthandler;
13968 char *p;
13969 char d;
13970
13971 switch (ffelex_token_type (t))
13972 {
13973 case FFELEX_typeNAME:
13974 case FFELEX_typeNAMES:
13975 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13976 'D', 'd')
13977 || ffesrc_char_match_init (d, 'E', 'e')
13978 || ffesrc_char_match_init (d, 'Q', 'q'))
13979 && ffeexpr_isdigits_ (++p))
13980 {
13981
13982 /* Just exponent character by itself? In which case, PLUS or MINUS
13983 must surely be next, followed by a NUMBER token. */
13984
13985 if (*p == '\0')
13986 {
13987 ffeexpr_tokens_[2] = ffelex_token_use (t);
13988 return (ffelexHandler) ffeexpr_token_number_per_exp_;
13989 }
13990 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0],
13991 ffeexpr_tokens_[1], NULL, t, NULL,
13992 NULL);
13993
13994 ffelex_token_kill (ffeexpr_tokens_[0]);
13995 ffelex_token_kill (ffeexpr_tokens_[1]);
13996 return (ffelexHandler) ffeexpr_token_binary_;
13997 }
13998 /* A name not representing an exponent, so assume it will be something
13999 like EQ, make an integer from the number, pass the period to binary
14000 state and the current token to the resulting state. */
14001
14002 e = ffeexpr_expr_new_ ();
14003 e->type = FFEEXPR_exprtypeOPERAND_;
14004 e->token = ffeexpr_tokens_[0];
14005 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
14006 (ffeexpr_tokens_[0]));
14007 ffebld_set_info (e->u.operand,
14008 ffeinfo_new (FFEINFO_basictypeINTEGER,
14009 FFEINFO_kindtypeINTEGERDEFAULT, 0,
14010 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14011 FFETARGET_charactersizeNONE));
14012 ffeexpr_exprstack_push_operand_ (e);
14013 nexthandler = (ffelexHandler) ffeexpr_token_binary_
14014 (ffeexpr_tokens_[1]);
14015 ffelex_token_kill (ffeexpr_tokens_[1]);
14016 return (ffelexHandler) (*nexthandler) (t);
14017
14018 case FFELEX_typeNUMBER:
14019 ffeexpr_tokens_[2] = ffelex_token_use (t);
14020 return (ffelexHandler) ffeexpr_token_number_real_;
14021
14022 default:
14023 break;
14024 }
14025
14026 /* Nothing specific we were looking for, so make a real number and pass the
14027 period and then the current token to the binary state. */
14028
14029 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14030 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14031 NULL, NULL, NULL, NULL);
14032
14033 ffelex_token_kill (ffeexpr_tokens_[0]);
14034 ffelex_token_kill (ffeexpr_tokens_[1]);
14035 return (ffelexHandler) ffeexpr_token_binary_ (t);
14036 }
14037
14038 /* ffeexpr_token_number_per_exp_ -- Rhs NUMBER PERIOD NAME(D, E, or Q)
14039
14040 Return a pointer to this function to the lexer (ffelex), which will
14041 invoke it for the next token.
14042
14043 Ensures this token is PLUS or MINUS, preserves it, goes to final state
14044 for real number (exponent digits). Else treats number as real, passes
14045 name to binary, passes current token to subsequent handler. */
14046
14047 static ffelexHandler
14048 ffeexpr_token_number_per_exp_ (ffelexToken t)
14049 {
14050 if ((ffelex_token_type (t) != FFELEX_typePLUS)
14051 && (ffelex_token_type (t) != FFELEX_typeMINUS))
14052 {
14053 ffelexHandler nexthandler;
14054
14055 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14056 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14057 NULL, NULL, NULL, NULL);
14058
14059 ffelex_token_kill (ffeexpr_tokens_[0]);
14060 ffelex_token_kill (ffeexpr_tokens_[1]);
14061 nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[2]);
14062 ffelex_token_kill (ffeexpr_tokens_[2]);
14063 return (ffelexHandler) (*nexthandler) (t);
14064 }
14065
14066 ffeexpr_tokens_[3] = ffelex_token_use (t);
14067 return (ffelexHandler) ffeexpr_token_num_per_exp_sign_;
14068 }
14069
14070 /* ffeexpr_token_number_real_ -- Rhs NUMBER PERIOD NUMBER
14071
14072 Return a pointer to this function to the lexer (ffelex), which will
14073 invoke it for the next token.
14074
14075 After a number, period, and number, check next token for possible
14076 exponent designation (D, E, or Q as first/only character) and continue
14077 real-number handling accordingly. Else form basic real constant, push
14078 onto expression stack, and enter binary state using current token (which,
14079 if it is a name not beginning with D, E, or Q, will certainly result
14080 in an error, but that's not for this routine to deal with). */
14081
14082 static ffelexHandler
14083 ffeexpr_token_number_real_ (ffelexToken t)
14084 {
14085 char d;
14086 char *p;
14087
14088 if (((ffelex_token_type (t) != FFELEX_typeNAME)
14089 && (ffelex_token_type (t) != FFELEX_typeNAMES))
14090 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
14091 'D', 'd')
14092 || ffesrc_char_match_init (d, 'E', 'e')
14093 || ffesrc_char_match_init (d, 'Q', 'q')))
14094 && ffeexpr_isdigits_ (++p)))
14095 {
14096 #if 0
14097 /* This code has been removed because it seems inconsistent to
14098 produce a diagnostic in this case, but not all of the other
14099 ones that look for an exponent and cannot recognize one. */
14100 if (((ffelex_token_type (t) == FFELEX_typeNAME)
14101 || (ffelex_token_type (t) == FFELEX_typeNAMES))
14102 && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
14103 {
14104 char bad[2];
14105
14106 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14107 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
14108 ffelex_token_where_column (ffeexpr_tokens_[0]));
14109 bad[0] = *(p - 1);
14110 bad[1] = '\0';
14111 ffebad_string (bad);
14112 ffebad_finish ();
14113 }
14114 #endif
14115 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14116 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14117 ffeexpr_tokens_[2], NULL, NULL, NULL);
14118
14119 ffelex_token_kill (ffeexpr_tokens_[0]);
14120 ffelex_token_kill (ffeexpr_tokens_[1]);
14121 ffelex_token_kill (ffeexpr_tokens_[2]);
14122 return (ffelexHandler) ffeexpr_token_binary_ (t);
14123 }
14124
14125 /* Just exponent character by itself? In which case, PLUS or MINUS must
14126 surely be next, followed by a NUMBER token. */
14127
14128 if (*p == '\0')
14129 {
14130 ffeexpr_tokens_[3] = ffelex_token_use (t);
14131 return (ffelexHandler) ffeexpr_token_number_real_exp_;
14132 }
14133
14134 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14135 ffeexpr_tokens_[2], t, NULL, NULL);
14136
14137 ffelex_token_kill (ffeexpr_tokens_[0]);
14138 ffelex_token_kill (ffeexpr_tokens_[1]);
14139 ffelex_token_kill (ffeexpr_tokens_[2]);
14140 return (ffelexHandler) ffeexpr_token_binary_;
14141 }
14142
14143 /* ffeexpr_token_num_per_exp_sign_ -- Rhs NUMBER PERIOD NAME(D,E,Q) PLUS/MINUS
14144
14145 Return a pointer to this function to the lexer (ffelex), which will
14146 invoke it for the next token.
14147
14148 Make sure token is a NUMBER, make a real constant out of all we have and
14149 push it onto the expression stack. Else issue diagnostic and pretend
14150 exponent field was a zero. */
14151
14152 static ffelexHandler
14153 ffeexpr_token_num_per_exp_sign_ (ffelexToken t)
14154 {
14155 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14156 {
14157 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14158 {
14159 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
14160 ffelex_token_where_column (ffeexpr_tokens_[2]));
14161 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14162 ffebad_finish ();
14163 }
14164
14165 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14166 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14167 NULL, NULL, NULL, NULL);
14168
14169 ffelex_token_kill (ffeexpr_tokens_[0]);
14170 ffelex_token_kill (ffeexpr_tokens_[1]);
14171 ffelex_token_kill (ffeexpr_tokens_[2]);
14172 ffelex_token_kill (ffeexpr_tokens_[3]);
14173 return (ffelexHandler) ffeexpr_token_binary_ (t);
14174 }
14175
14176 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0],
14177 ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL,
14178 ffeexpr_tokens_[2], ffeexpr_tokens_[3], t);
14179
14180 ffelex_token_kill (ffeexpr_tokens_[0]);
14181 ffelex_token_kill (ffeexpr_tokens_[1]);
14182 ffelex_token_kill (ffeexpr_tokens_[2]);
14183 ffelex_token_kill (ffeexpr_tokens_[3]);
14184 return (ffelexHandler) ffeexpr_token_binary_;
14185 }
14186
14187 /* ffeexpr_token_number_real_exp_ -- Rhs NUMBER PERIOD NUMBER NAME(D, E, or Q)
14188
14189 Return a pointer to this function to the lexer (ffelex), which will
14190 invoke it for the next token.
14191
14192 Ensures this token is PLUS or MINUS, preserves it, goes to final state
14193 for real number (exponent digits). Else issues diagnostic, assumes a
14194 zero exponent field for number, passes token on to binary state as if
14195 previous token had been "E0" instead of "E", for example. */
14196
14197 static ffelexHandler
14198 ffeexpr_token_number_real_exp_ (ffelexToken t)
14199 {
14200 if ((ffelex_token_type (t) != FFELEX_typePLUS)
14201 && (ffelex_token_type (t) != FFELEX_typeMINUS))
14202 {
14203 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14204 {
14205 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
14206 ffelex_token_where_column (ffeexpr_tokens_[3]));
14207 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14208 ffebad_finish ();
14209 }
14210
14211 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14212 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14213 ffeexpr_tokens_[2], NULL, NULL, NULL);
14214
14215 ffelex_token_kill (ffeexpr_tokens_[0]);
14216 ffelex_token_kill (ffeexpr_tokens_[1]);
14217 ffelex_token_kill (ffeexpr_tokens_[2]);
14218 ffelex_token_kill (ffeexpr_tokens_[3]);
14219 return (ffelexHandler) ffeexpr_token_binary_ (t);
14220 }
14221
14222 ffeexpr_tokens_[4] = ffelex_token_use (t);
14223 return (ffelexHandler) ffeexpr_token_num_real_exp_sn_;
14224 }
14225
14226 /* ffeexpr_token_num_real_exp_sn_ -- Rhs NUMBER PERIOD NUMBER NAME(D,E,Q)
14227 PLUS/MINUS
14228
14229 Return a pointer to this function to the lexer (ffelex), which will
14230 invoke it for the next token.
14231
14232 Make sure token is a NUMBER, make a real constant out of all we have and
14233 push it onto the expression stack. Else issue diagnostic and pretend
14234 exponent field was a zero. */
14235
14236 static ffelexHandler
14237 ffeexpr_token_num_real_exp_sn_ (ffelexToken t)
14238 {
14239 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14240 {
14241 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14242 {
14243 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
14244 ffelex_token_where_column (ffeexpr_tokens_[3]));
14245 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14246 ffebad_finish ();
14247 }
14248
14249 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14250 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14251 ffeexpr_tokens_[2], NULL, NULL, NULL);
14252
14253 ffelex_token_kill (ffeexpr_tokens_[0]);
14254 ffelex_token_kill (ffeexpr_tokens_[1]);
14255 ffelex_token_kill (ffeexpr_tokens_[2]);
14256 ffelex_token_kill (ffeexpr_tokens_[3]);
14257 ffelex_token_kill (ffeexpr_tokens_[4]);
14258 return (ffelexHandler) ffeexpr_token_binary_ (t);
14259 }
14260
14261 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[3])[0],
14262 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14263 ffeexpr_tokens_[2], ffeexpr_tokens_[3],
14264 ffeexpr_tokens_[4], t);
14265
14266 ffelex_token_kill (ffeexpr_tokens_[0]);
14267 ffelex_token_kill (ffeexpr_tokens_[1]);
14268 ffelex_token_kill (ffeexpr_tokens_[2]);
14269 ffelex_token_kill (ffeexpr_tokens_[3]);
14270 ffelex_token_kill (ffeexpr_tokens_[4]);
14271 return (ffelexHandler) ffeexpr_token_binary_;
14272 }
14273
14274 /* ffeexpr_token_binary_ -- Handle binary operator possibility
14275
14276 Return a pointer to this function to the lexer (ffelex), which will
14277 invoke it for the next token.
14278
14279 The possibility of a binary operator is handled here, meaning the previous
14280 token was an operand. */
14281
14282 static ffelexHandler
14283 ffeexpr_token_binary_ (ffelexToken t)
14284 {
14285 ffeexprExpr_ e;
14286
14287 if (!ffeexpr_stack_->is_rhs)
14288 return (ffelexHandler) ffeexpr_finished_ (t); /* For now. */
14289
14290 switch (ffelex_token_type (t))
14291 {
14292 case FFELEX_typePLUS:
14293 e = ffeexpr_expr_new_ ();
14294 e->type = FFEEXPR_exprtypeBINARY_;
14295 e->token = ffelex_token_use (t);
14296 e->u.operator.op = FFEEXPR_operatorADD_;
14297 e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
14298 e->u.operator.as = FFEEXPR_operatorassociativityADD_;
14299 ffeexpr_exprstack_push_binary_ (e);
14300 return (ffelexHandler) ffeexpr_token_rhs_;
14301
14302 case FFELEX_typeMINUS:
14303 e = ffeexpr_expr_new_ ();
14304 e->type = FFEEXPR_exprtypeBINARY_;
14305 e->token = ffelex_token_use (t);
14306 e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
14307 e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
14308 e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
14309 ffeexpr_exprstack_push_binary_ (e);
14310 return (ffelexHandler) ffeexpr_token_rhs_;
14311
14312 case FFELEX_typeASTERISK:
14313 switch (ffeexpr_stack_->context)
14314 {
14315 case FFEEXPR_contextDATA:
14316 return (ffelexHandler) ffeexpr_finished_ (t);
14317
14318 default:
14319 break;
14320 }
14321 e = ffeexpr_expr_new_ ();
14322 e->type = FFEEXPR_exprtypeBINARY_;
14323 e->token = ffelex_token_use (t);
14324 e->u.operator.op = FFEEXPR_operatorMULTIPLY_;
14325 e->u.operator.prec = FFEEXPR_operatorprecedenceMULTIPLY_;
14326 e->u.operator.as = FFEEXPR_operatorassociativityMULTIPLY_;
14327 ffeexpr_exprstack_push_binary_ (e);
14328 return (ffelexHandler) ffeexpr_token_rhs_;
14329
14330 case FFELEX_typeSLASH:
14331 switch (ffeexpr_stack_->context)
14332 {
14333 case FFEEXPR_contextDATA:
14334 return (ffelexHandler) ffeexpr_finished_ (t);
14335
14336 default:
14337 break;
14338 }
14339 e = ffeexpr_expr_new_ ();
14340 e->type = FFEEXPR_exprtypeBINARY_;
14341 e->token = ffelex_token_use (t);
14342 e->u.operator.op = FFEEXPR_operatorDIVIDE_;
14343 e->u.operator.prec = FFEEXPR_operatorprecedenceDIVIDE_;
14344 e->u.operator.as = FFEEXPR_operatorassociativityDIVIDE_;
14345 ffeexpr_exprstack_push_binary_ (e);
14346 return (ffelexHandler) ffeexpr_token_rhs_;
14347
14348 case FFELEX_typePOWER:
14349 e = ffeexpr_expr_new_ ();
14350 e->type = FFEEXPR_exprtypeBINARY_;
14351 e->token = ffelex_token_use (t);
14352 e->u.operator.op = FFEEXPR_operatorPOWER_;
14353 e->u.operator.prec = FFEEXPR_operatorprecedencePOWER_;
14354 e->u.operator.as = FFEEXPR_operatorassociativityPOWER_;
14355 ffeexpr_exprstack_push_binary_ (e);
14356 return (ffelexHandler) ffeexpr_token_rhs_;
14357
14358 case FFELEX_typeCONCAT:
14359 e = ffeexpr_expr_new_ ();
14360 e->type = FFEEXPR_exprtypeBINARY_;
14361 e->token = ffelex_token_use (t);
14362 e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
14363 e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
14364 e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
14365 ffeexpr_exprstack_push_binary_ (e);
14366 return (ffelexHandler) ffeexpr_token_rhs_;
14367
14368 case FFELEX_typeOPEN_ANGLE:
14369 switch (ffeexpr_stack_->context)
14370 {
14371 case FFEEXPR_contextFORMAT:
14372 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14373 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14374 ffebad_finish ();
14375 break;
14376
14377 default:
14378 break;
14379 }
14380 e = ffeexpr_expr_new_ ();
14381 e->type = FFEEXPR_exprtypeBINARY_;
14382 e->token = ffelex_token_use (t);
14383 e->u.operator.op = FFEEXPR_operatorLT_;
14384 e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
14385 e->u.operator.as = FFEEXPR_operatorassociativityLT_;
14386 ffeexpr_exprstack_push_binary_ (e);
14387 return (ffelexHandler) ffeexpr_token_rhs_;
14388
14389 case FFELEX_typeCLOSE_ANGLE:
14390 switch (ffeexpr_stack_->context)
14391 {
14392 case FFEEXPR_contextFORMAT:
14393 return ffeexpr_finished_ (t);
14394
14395 default:
14396 break;
14397 }
14398 e = ffeexpr_expr_new_ ();
14399 e->type = FFEEXPR_exprtypeBINARY_;
14400 e->token = ffelex_token_use (t);
14401 e->u.operator.op = FFEEXPR_operatorGT_;
14402 e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
14403 e->u.operator.as = FFEEXPR_operatorassociativityGT_;
14404 ffeexpr_exprstack_push_binary_ (e);
14405 return (ffelexHandler) ffeexpr_token_rhs_;
14406
14407 case FFELEX_typeREL_EQ:
14408 switch (ffeexpr_stack_->context)
14409 {
14410 case FFEEXPR_contextFORMAT:
14411 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14412 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14413 ffebad_finish ();
14414 break;
14415
14416 default:
14417 break;
14418 }
14419 e = ffeexpr_expr_new_ ();
14420 e->type = FFEEXPR_exprtypeBINARY_;
14421 e->token = ffelex_token_use (t);
14422 e->u.operator.op = FFEEXPR_operatorEQ_;
14423 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
14424 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
14425 ffeexpr_exprstack_push_binary_ (e);
14426 return (ffelexHandler) ffeexpr_token_rhs_;
14427
14428 case FFELEX_typeREL_NE:
14429 switch (ffeexpr_stack_->context)
14430 {
14431 case FFEEXPR_contextFORMAT:
14432 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14433 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14434 ffebad_finish ();
14435 break;
14436
14437 default:
14438 break;
14439 }
14440 e = ffeexpr_expr_new_ ();
14441 e->type = FFEEXPR_exprtypeBINARY_;
14442 e->token = ffelex_token_use (t);
14443 e->u.operator.op = FFEEXPR_operatorNE_;
14444 e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
14445 e->u.operator.as = FFEEXPR_operatorassociativityNE_;
14446 ffeexpr_exprstack_push_binary_ (e);
14447 return (ffelexHandler) ffeexpr_token_rhs_;
14448
14449 case FFELEX_typeREL_LE:
14450 switch (ffeexpr_stack_->context)
14451 {
14452 case FFEEXPR_contextFORMAT:
14453 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14454 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14455 ffebad_finish ();
14456 break;
14457
14458 default:
14459 break;
14460 }
14461 e = ffeexpr_expr_new_ ();
14462 e->type = FFEEXPR_exprtypeBINARY_;
14463 e->token = ffelex_token_use (t);
14464 e->u.operator.op = FFEEXPR_operatorLE_;
14465 e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
14466 e->u.operator.as = FFEEXPR_operatorassociativityLE_;
14467 ffeexpr_exprstack_push_binary_ (e);
14468 return (ffelexHandler) ffeexpr_token_rhs_;
14469
14470 case FFELEX_typeREL_GE:
14471 switch (ffeexpr_stack_->context)
14472 {
14473 case FFEEXPR_contextFORMAT:
14474 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14475 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14476 ffebad_finish ();
14477 break;
14478
14479 default:
14480 break;
14481 }
14482 e = ffeexpr_expr_new_ ();
14483 e->type = FFEEXPR_exprtypeBINARY_;
14484 e->token = ffelex_token_use (t);
14485 e->u.operator.op = FFEEXPR_operatorGE_;
14486 e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
14487 e->u.operator.as = FFEEXPR_operatorassociativityGE_;
14488 ffeexpr_exprstack_push_binary_ (e);
14489 return (ffelexHandler) ffeexpr_token_rhs_;
14490
14491 case FFELEX_typePERIOD:
14492 ffeexpr_tokens_[0] = ffelex_token_use (t);
14493 return (ffelexHandler) ffeexpr_token_binary_period_;
14494
14495 #if 0
14496 case FFELEX_typeOPEN_PAREN:
14497 case FFELEX_typeCLOSE_PAREN:
14498 case FFELEX_typeEQUALS:
14499 case FFELEX_typePOINTS:
14500 case FFELEX_typeCOMMA:
14501 case FFELEX_typeCOLON:
14502 case FFELEX_typeEOS:
14503 case FFELEX_typeSEMICOLON:
14504 case FFELEX_typeNAME:
14505 case FFELEX_typeNAMES:
14506 #endif
14507 default:
14508 return (ffelexHandler) ffeexpr_finished_ (t);
14509 }
14510 }
14511
14512 /* ffeexpr_token_binary_period_ -- Binary PERIOD
14513
14514 Return a pointer to this function to the lexer (ffelex), which will
14515 invoke it for the next token.
14516
14517 Handle a period detected at binary (expecting binary op or end) state.
14518 Must begin a dot-dot name, of which .NOT., .TRUE., and .FALSE. are not
14519 valid. */
14520
14521 static ffelexHandler
14522 ffeexpr_token_binary_period_ (ffelexToken t)
14523 {
14524 ffeexprExpr_ operand;
14525
14526 switch (ffelex_token_type (t))
14527 {
14528 case FFELEX_typeNAME:
14529 case FFELEX_typeNAMES:
14530 ffeexpr_current_dotdot_ = ffestr_other (t);
14531 switch (ffeexpr_current_dotdot_)
14532 {
14533 case FFESTR_otherTRUE:
14534 case FFESTR_otherFALSE:
14535 case FFESTR_otherNOT:
14536 if (ffest_ffebad_start (FFEBAD_MISSING_BINARY_OPERATOR))
14537 {
14538 operand = ffeexpr_stack_->exprstack;
14539 assert (operand != NULL);
14540 assert (operand->type == FFEEXPR_exprtypeOPERAND_);
14541 ffebad_here (0, ffelex_token_where_line (operand->token), ffelex_token_where_column (operand->token));
14542 ffebad_here (1, ffelex_token_where_line (t),
14543 ffelex_token_where_column (t));
14544 ffebad_finish ();
14545 }
14546 ffelex_token_kill (ffeexpr_tokens_[0]);
14547 return (ffelexHandler) ffeexpr_token_binary_sw_per_;
14548
14549 default:
14550 ffeexpr_tokens_[1] = ffelex_token_use (t);
14551 return (ffelexHandler) ffeexpr_token_binary_end_per_;
14552 }
14553 break; /* Nothing really reaches here. */
14554
14555 default:
14556 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
14557 {
14558 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14559 ffelex_token_where_column (ffeexpr_tokens_[0]));
14560 ffebad_finish ();
14561 }
14562 ffelex_token_kill (ffeexpr_tokens_[0]);
14563 return (ffelexHandler) ffeexpr_token_binary_ (t);
14564 }
14565 }
14566
14567 /* ffeexpr_token_binary_end_per_ -- Binary PERIOD NAME(not NOT, TRUE, or FALSE)
14568
14569 Return a pointer to this function to the lexer (ffelex), which will
14570 invoke it for the next token.
14571
14572 Expecting a period to close a dot-dot at binary (binary op
14573 or operator) state. If period isn't found, issue a diagnostic but
14574 pretend we saw one. ffeexpr_current_dotdot_ must already contained the
14575 dotdot representation of the name in between the two PERIOD tokens. */
14576
14577 static ffelexHandler
14578 ffeexpr_token_binary_end_per_ (ffelexToken t)
14579 {
14580 ffeexprExpr_ e;
14581
14582 e = ffeexpr_expr_new_ ();
14583 e->type = FFEEXPR_exprtypeBINARY_;
14584 e->token = ffeexpr_tokens_[0];
14585
14586 switch (ffeexpr_current_dotdot_)
14587 {
14588 case FFESTR_otherAND:
14589 e->u.operator.op = FFEEXPR_operatorAND_;
14590 e->u.operator.prec = FFEEXPR_operatorprecedenceAND_;
14591 e->u.operator.as = FFEEXPR_operatorassociativityAND_;
14592 break;
14593
14594 case FFESTR_otherOR:
14595 e->u.operator.op = FFEEXPR_operatorOR_;
14596 e->u.operator.prec = FFEEXPR_operatorprecedenceOR_;
14597 e->u.operator.as = FFEEXPR_operatorassociativityOR_;
14598 break;
14599
14600 case FFESTR_otherXOR:
14601 e->u.operator.op = FFEEXPR_operatorXOR_;
14602 e->u.operator.prec = FFEEXPR_operatorprecedenceXOR_;
14603 e->u.operator.as = FFEEXPR_operatorassociativityXOR_;
14604 break;
14605
14606 case FFESTR_otherEQV:
14607 e->u.operator.op = FFEEXPR_operatorEQV_;
14608 e->u.operator.prec = FFEEXPR_operatorprecedenceEQV_;
14609 e->u.operator.as = FFEEXPR_operatorassociativityEQV_;
14610 break;
14611
14612 case FFESTR_otherNEQV:
14613 e->u.operator.op = FFEEXPR_operatorNEQV_;
14614 e->u.operator.prec = FFEEXPR_operatorprecedenceNEQV_;
14615 e->u.operator.as = FFEEXPR_operatorassociativityNEQV_;
14616 break;
14617
14618 case FFESTR_otherLT:
14619 e->u.operator.op = FFEEXPR_operatorLT_;
14620 e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
14621 e->u.operator.as = FFEEXPR_operatorassociativityLT_;
14622 break;
14623
14624 case FFESTR_otherLE:
14625 e->u.operator.op = FFEEXPR_operatorLE_;
14626 e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
14627 e->u.operator.as = FFEEXPR_operatorassociativityLE_;
14628 break;
14629
14630 case FFESTR_otherEQ:
14631 e->u.operator.op = FFEEXPR_operatorEQ_;
14632 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
14633 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
14634 break;
14635
14636 case FFESTR_otherNE:
14637 e->u.operator.op = FFEEXPR_operatorNE_;
14638 e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
14639 e->u.operator.as = FFEEXPR_operatorassociativityNE_;
14640 break;
14641
14642 case FFESTR_otherGT:
14643 e->u.operator.op = FFEEXPR_operatorGT_;
14644 e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
14645 e->u.operator.as = FFEEXPR_operatorassociativityGT_;
14646 break;
14647
14648 case FFESTR_otherGE:
14649 e->u.operator.op = FFEEXPR_operatorGE_;
14650 e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
14651 e->u.operator.as = FFEEXPR_operatorassociativityGE_;
14652 break;
14653
14654 default:
14655 if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT))
14656 {
14657 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14658 ffelex_token_where_column (ffeexpr_tokens_[0]));
14659 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
14660 ffebad_finish ();
14661 }
14662 e->u.operator.op = FFEEXPR_operatorEQ_;
14663 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
14664 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
14665 break;
14666 }
14667
14668 ffeexpr_exprstack_push_binary_ (e);
14669
14670 if (ffelex_token_type (t) != FFELEX_typePERIOD)
14671 {
14672 if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
14673 {
14674 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14675 ffelex_token_where_column (ffeexpr_tokens_[0]));
14676 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14677 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
14678 ffebad_finish ();
14679 }
14680 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */
14681 return (ffelexHandler) ffeexpr_token_rhs_ (t);
14682 }
14683
14684 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */
14685 return (ffelexHandler) ffeexpr_token_rhs_;
14686 }
14687
14688 /* ffeexpr_token_binary_sw_per_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
14689
14690 Return a pointer to this function to the lexer (ffelex), which will
14691 invoke it for the next token.
14692
14693 A diagnostic has already been issued; just swallow a period if there is
14694 one, then continue with ffeexpr_token_binary_. */
14695
14696 static ffelexHandler
14697 ffeexpr_token_binary_sw_per_ (ffelexToken t)
14698 {
14699 if (ffelex_token_type (t) != FFELEX_typePERIOD)
14700 return (ffelexHandler) ffeexpr_token_binary_ (t);
14701
14702 return (ffelexHandler) ffeexpr_token_binary_;
14703 }
14704
14705 /* ffeexpr_token_quote_ -- Rhs QUOTE
14706
14707 Return a pointer to this function to the lexer (ffelex), which will
14708 invoke it for the next token.
14709
14710 Expecting a NUMBER that we'll treat as an octal integer. */
14711
14712 static ffelexHandler
14713 ffeexpr_token_quote_ (ffelexToken t)
14714 {
14715 ffeexprExpr_ e;
14716 ffebld anyexpr;
14717
14718 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14719 {
14720 if (ffest_ffebad_start (FFEBAD_QUOTE_MISSES_DIGITS))
14721 {
14722 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14723 ffelex_token_where_column (ffeexpr_tokens_[0]));
14724 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14725 ffebad_finish ();
14726 }
14727 ffelex_token_kill (ffeexpr_tokens_[0]);
14728 return (ffelexHandler) ffeexpr_token_rhs_ (t);
14729 }
14730
14731 /* This is kind of a kludge to prevent any whining about magical numbers
14732 that start out as these octal integers, so "20000000000 (on a 32-bit
14733 2's-complement machine) by itself won't produce an error. */
14734
14735 anyexpr = ffebld_new_any ();
14736 ffebld_set_info (anyexpr, ffeinfo_new_any ());
14737
14738 e = ffeexpr_expr_new_ ();
14739 e->type = FFEEXPR_exprtypeOPERAND_;
14740 e->token = ffeexpr_tokens_[0];
14741 e->u.operand = ffebld_new_conter_with_orig
14742 (ffebld_constant_new_integeroctal (t), anyexpr);
14743 ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER,
14744 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY,
14745 FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14746 ffeexpr_exprstack_push_operand_ (e);
14747 return (ffelexHandler) ffeexpr_token_binary_;
14748 }
14749
14750 /* ffeexpr_token_apostrophe_ -- Rhs APOSTROPHE
14751
14752 Return a pointer to this function to the lexer (ffelex), which will
14753 invoke it for the next token.
14754
14755 Handle an open-apostrophe, which begins either a character ('char-const'),
14756 typeless octal ('octal-const'O), or typeless hexadecimal ('hex-const'Z or
14757 'hex-const'X) constant. */
14758
14759 static ffelexHandler
14760 ffeexpr_token_apostrophe_ (ffelexToken t)
14761 {
14762 assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
14763 if (ffe_is_pedantic_not_90 () && (ffelex_token_length (t) == 0))
14764 {
14765 ffebad_start (FFEBAD_NULL_CHAR_CONST);
14766 ffebad_here (0, ffelex_token_where_line (t),
14767 ffelex_token_where_column (t));
14768 ffebad_finish ();
14769 }
14770 ffeexpr_tokens_[1] = ffelex_token_use (t);
14771 return (ffelexHandler) ffeexpr_token_apos_char_;
14772 }
14773
14774 /* ffeexpr_token_apos_char_ -- Rhs APOSTROPHE CHARACTER
14775
14776 Return a pointer to this function to the lexer (ffelex), which will
14777 invoke it for the next token.
14778
14779 Close-apostrophe is implicit; if this token is NAME, it is a possible
14780 typeless-constant radix specifier. */
14781
14782 static ffelexHandler
14783 ffeexpr_token_apos_char_ (ffelexToken t)
14784 {
14785 ffeexprExpr_ e;
14786 ffeinfo ni;
14787 char c;
14788 ffetargetCharacterSize size;
14789
14790 if ((ffelex_token_type (t) == FFELEX_typeNAME)
14791 || (ffelex_token_type (t) == FFELEX_typeNAMES))
14792 {
14793 if ((ffelex_token_length (t) == 1)
14794 && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]), 'B',
14795 'b')
14796 || ffesrc_char_match_init (c, 'O', 'o')
14797 || ffesrc_char_match_init (c, 'X', 'x')
14798 || ffesrc_char_match_init (c, 'Z', 'z')))
14799 {
14800 e = ffeexpr_expr_new_ ();
14801 e->type = FFEEXPR_exprtypeOPERAND_;
14802 e->token = ffeexpr_tokens_[0];
14803 switch (c)
14804 {
14805 case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
14806 e->u.operand = ffebld_new_conter
14807 (ffebld_constant_new_typeless_bv (ffeexpr_tokens_[1]));
14808 size = ffetarget_size_typeless_binary (ffeexpr_tokens_[1]);
14809 break;
14810
14811 case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
14812 e->u.operand = ffebld_new_conter
14813 (ffebld_constant_new_typeless_ov (ffeexpr_tokens_[1]));
14814 size = ffetarget_size_typeless_octal (ffeexpr_tokens_[1]);
14815 break;
14816
14817 case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
14818 e->u.operand = ffebld_new_conter
14819 (ffebld_constant_new_typeless_hxv (ffeexpr_tokens_[1]));
14820 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
14821 break;
14822
14823 case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
14824 e->u.operand = ffebld_new_conter
14825 (ffebld_constant_new_typeless_hzv (ffeexpr_tokens_[1]));
14826 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
14827 break;
14828
14829 default:
14830 no_match: /* :::::::::::::::::::: */
14831 assert ("not BOXZ!" == NULL);
14832 size = 0;
14833 break;
14834 }
14835 ffebld_set_info (e->u.operand,
14836 ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
14837 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
14838 ffeexpr_exprstack_push_operand_ (e);
14839 ffelex_token_kill (ffeexpr_tokens_[1]);
14840 return (ffelexHandler) ffeexpr_token_binary_;
14841 }
14842 }
14843 e = ffeexpr_expr_new_ ();
14844 e->type = FFEEXPR_exprtypeOPERAND_;
14845 e->token = ffeexpr_tokens_[0];
14846 e->u.operand = ffebld_new_conter (ffebld_constant_new_characterdefault
14847 (ffeexpr_tokens_[1]));
14848 ni = ffeinfo_new (FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTERDEFAULT,
14849 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14850 ffelex_token_length (ffeexpr_tokens_[1]));
14851 ffebld_set_info (e->u.operand, ni);
14852 ffelex_token_kill (ffeexpr_tokens_[1]);
14853 ffeexpr_exprstack_push_operand_ (e);
14854 if ((ffelex_token_type (t) == FFELEX_typeNAME)
14855 || (ffelex_token_type (t) == FFELEX_typeNAMES))
14856 {
14857 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14858 {
14859 ffebad_string (ffelex_token_text (t));
14860 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14861 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
14862 ffelex_token_where_column (ffeexpr_tokens_[0]));
14863 ffebad_finish ();
14864 }
14865 e = ffeexpr_expr_new_ ();
14866 e->type = FFEEXPR_exprtypeBINARY_;
14867 e->token = ffelex_token_use (t);
14868 e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
14869 e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
14870 e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
14871 ffeexpr_exprstack_push_binary_ (e);
14872 return (ffelexHandler) ffeexpr_token_rhs_ (t);
14873 }
14874 ffeexpr_is_substr_ok_ = !ffe_is_pedantic_not_90 (); /* Allow "'hello'(3:5)". */
14875 return (ffelexHandler) ffeexpr_token_substrp_ (t);
14876 }
14877
14878 /* ffeexpr_token_name_lhs_ -- Lhs NAME
14879
14880 Return a pointer to this function to the lexer (ffelex), which will
14881 invoke it for the next token.
14882
14883 Handle a name followed by open-paren, period (RECORD.MEMBER), percent
14884 (RECORD%MEMBER), or nothing at all. */
14885
14886 static ffelexHandler
14887 ffeexpr_token_name_lhs_ (ffelexToken t)
14888 {
14889 ffeexprExpr_ e;
14890 ffeexprParenType_ paren_type;
14891 ffesymbol s;
14892 ffebld expr;
14893 ffeinfo info;
14894
14895 switch (ffelex_token_type (t))
14896 {
14897 case FFELEX_typeOPEN_PAREN:
14898 switch (ffeexpr_stack_->context)
14899 {
14900 case FFEEXPR_contextASSIGN:
14901 case FFEEXPR_contextAGOTO:
14902 case FFEEXPR_contextFILEUNIT_DF:
14903 goto just_name; /* :::::::::::::::::::: */
14904
14905 default:
14906 break;
14907 }
14908 e = ffeexpr_expr_new_ ();
14909 e->type = FFEEXPR_exprtypeOPERAND_;
14910 e->token = ffelex_token_use (ffeexpr_tokens_[0]);
14911 s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], FALSE,
14912 &paren_type);
14913
14914 switch (ffesymbol_where (s))
14915 {
14916 case FFEINFO_whereLOCAL:
14917 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14918 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recursion. */
14919 break;
14920
14921 case FFEINFO_whereINTRINSIC:
14922 case FFEINFO_whereGLOBAL:
14923 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
14924 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */
14925 break;
14926
14927 case FFEINFO_whereCOMMON:
14928 case FFEINFO_whereDUMMY:
14929 case FFEINFO_whereRESULT:
14930 break;
14931
14932 case FFEINFO_whereNONE:
14933 case FFEINFO_whereANY:
14934 break;
14935
14936 default:
14937 ffesymbol_error (s, ffeexpr_tokens_[0]);
14938 break;
14939 }
14940
14941 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14942 {
14943 e->u.operand = ffebld_new_any ();
14944 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14945 }
14946 else
14947 {
14948 e->u.operand = ffebld_new_symter (s,
14949 ffesymbol_generic (s),
14950 ffesymbol_specific (s),
14951 ffesymbol_implementation (s));
14952 ffebld_set_info (e->u.operand, ffesymbol_info (s));
14953 }
14954 ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */
14955 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
14956 switch (paren_type)
14957 {
14958 case FFEEXPR_parentypeSUBROUTINE_:
14959 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14960 return
14961 (ffelexHandler)
14962 ffeexpr_rhs (ffeexpr_stack_->pool,
14963 FFEEXPR_contextACTUALARG_,
14964 ffeexpr_token_arguments_);
14965
14966 case FFEEXPR_parentypeARRAY_:
14967 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14968 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
14969 ffeexpr_stack_->rank = 0;
14970 ffeexpr_stack_->constant = TRUE;
14971 ffeexpr_stack_->immediate = TRUE;
14972 switch (ffeexpr_stack_->context)
14973 {
14974 case FFEEXPR_contextDATAIMPDOITEM_:
14975 return
14976 (ffelexHandler)
14977 ffeexpr_rhs (ffeexpr_stack_->pool,
14978 FFEEXPR_contextDATAIMPDOINDEX_,
14979 ffeexpr_token_elements_);
14980
14981 case FFEEXPR_contextEQUIVALENCE:
14982 return
14983 (ffelexHandler)
14984 ffeexpr_rhs (ffeexpr_stack_->pool,
14985 FFEEXPR_contextEQVINDEX_,
14986 ffeexpr_token_elements_);
14987
14988 default:
14989 return
14990 (ffelexHandler)
14991 ffeexpr_rhs (ffeexpr_stack_->pool,
14992 FFEEXPR_contextINDEX_,
14993 ffeexpr_token_elements_);
14994 }
14995
14996 case FFEEXPR_parentypeSUBSTRING_:
14997 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
14998 ffeexpr_tokens_[0]);
14999 return
15000 (ffelexHandler)
15001 ffeexpr_rhs (ffeexpr_stack_->pool,
15002 FFEEXPR_contextINDEX_,
15003 ffeexpr_token_substring_);
15004
15005 case FFEEXPR_parentypeEQUIVALENCE_:
15006 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15007 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
15008 ffeexpr_stack_->rank = 0;
15009 ffeexpr_stack_->constant = TRUE;
15010 ffeexpr_stack_->immediate = TRUE;
15011 return
15012 (ffelexHandler)
15013 ffeexpr_rhs (ffeexpr_stack_->pool,
15014 FFEEXPR_contextEQVINDEX_,
15015 ffeexpr_token_equivalence_);
15016
15017 case FFEEXPR_parentypeFUNCTION_: /* Invalid case. */
15018 case FFEEXPR_parentypeFUNSUBSTR_: /* Invalid case. */
15019 ffesymbol_error (s, ffeexpr_tokens_[0]);
15020 /* Fall through. */
15021 case FFEEXPR_parentypeANY_:
15022 e->u.operand = ffebld_new_any ();
15023 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15024 return
15025 (ffelexHandler)
15026 ffeexpr_rhs (ffeexpr_stack_->pool,
15027 FFEEXPR_contextACTUALARG_,
15028 ffeexpr_token_anything_);
15029
15030 default:
15031 assert ("bad paren type" == NULL);
15032 break;
15033 }
15034
15035 case FFELEX_typeEQUALS: /* As in "VAR=". */
15036 switch (ffeexpr_stack_->context)
15037 {
15038 case FFEEXPR_contextIMPDOITEM_: /* within
15039 "(,VAR=start,end[,incr])". */
15040 case FFEEXPR_contextIMPDOITEMDF_:
15041 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
15042 break;
15043
15044 case FFEEXPR_contextDATAIMPDOITEM_:
15045 ffeexpr_stack_->context = FFEEXPR_contextDATAIMPDOCTRL_;
15046 break;
15047
15048 default:
15049 break;
15050 }
15051 break;
15052
15053 #if 0
15054 case FFELEX_typePERIOD:
15055 case FFELEX_typePERCENT:
15056 assert ("FOO%, FOO. not yet supported!~~" == NULL);
15057 break;
15058 #endif
15059
15060 default:
15061 break;
15062 }
15063
15064 just_name: /* :::::::::::::::::::: */
15065 e = ffeexpr_expr_new_ ();
15066 e->type = FFEEXPR_exprtypeOPERAND_;
15067 e->token = ffeexpr_tokens_[0];
15068 s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0],
15069 (ffeexpr_stack_->context
15070 == FFEEXPR_contextSUBROUTINEREF));
15071
15072 switch (ffesymbol_where (s))
15073 {
15074 case FFEINFO_whereCONSTANT:
15075 if ((ffeexpr_stack_->context != FFEEXPR_contextPARAMETER)
15076 || (ffesymbol_kind (s) != FFEINFO_kindENTITY))
15077 ffesymbol_error (s, ffeexpr_tokens_[0]);
15078 break;
15079
15080 case FFEINFO_whereIMMEDIATE:
15081 if ((ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOCTRL_)
15082 && (ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOINDEX_))
15083 ffesymbol_error (s, ffeexpr_tokens_[0]);
15084 break;
15085
15086 case FFEINFO_whereLOCAL:
15087 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
15088 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recurse!. */
15089 break;
15090
15091 case FFEINFO_whereINTRINSIC:
15092 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
15093 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */
15094 break;
15095
15096 default:
15097 break;
15098 }
15099
15100 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15101 {
15102 expr = ffebld_new_any ();
15103 info = ffeinfo_new_any ();
15104 ffebld_set_info (expr, info);
15105 }
15106 else
15107 {
15108 expr = ffebld_new_symter (s,
15109 ffesymbol_generic (s),
15110 ffesymbol_specific (s),
15111 ffesymbol_implementation (s));
15112 info = ffesymbol_info (s);
15113 ffebld_set_info (expr, info);
15114 if (ffesymbol_is_doiter (s))
15115 {
15116 ffebad_start (FFEBAD_DOITER);
15117 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15118 ffelex_token_where_column (ffeexpr_tokens_[0]));
15119 ffest_ffebad_here_doiter (1, s);
15120 ffebad_string (ffesymbol_text (s));
15121 ffebad_finish ();
15122 }
15123 expr = ffeexpr_collapse_symter (expr, ffeexpr_tokens_[0]);
15124 }
15125
15126 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
15127 {
15128 if (ffebld_op (expr) == FFEBLD_opANY)
15129 {
15130 expr = ffebld_new_any ();
15131 ffebld_set_info (expr, ffeinfo_new_any ());
15132 }
15133 else
15134 {
15135 expr = ffebld_new_subrref (expr, NULL); /* No argument list. */
15136 if (ffesymbol_generic (s) != FFEINTRIN_genNONE)
15137 ffeintrin_fulfill_generic (&expr, &info, e->token);
15138 else if (ffesymbol_specific (s) != FFEINTRIN_specNONE)
15139 ffeintrin_fulfill_specific (&expr, &info, NULL, e->token);
15140 else
15141 ffeexpr_fulfill_call_ (&expr, e->token);
15142
15143 if (ffebld_op (expr) != FFEBLD_opANY)
15144 ffebld_set_info (expr,
15145 ffeinfo_new (ffeinfo_basictype (info),
15146 ffeinfo_kindtype (info),
15147 0,
15148 FFEINFO_kindENTITY,
15149 FFEINFO_whereFLEETING,
15150 ffeinfo_size (info)));
15151 else
15152 ffebld_set_info (expr, ffeinfo_new_any ());
15153 }
15154 }
15155
15156 e->u.operand = expr;
15157 ffeexpr_exprstack_push_operand_ (e);
15158 return (ffelexHandler) ffeexpr_finished_ (t);
15159 }
15160
15161 /* ffeexpr_token_name_arg_ -- Rhs NAME
15162
15163 Return a pointer to this function to the lexer (ffelex), which will
15164 invoke it for the next token.
15165
15166 Handle first token in an actual-arg (or possible actual-arg) context
15167 being a NAME, and use second token to refine the context. */
15168
15169 static ffelexHandler
15170 ffeexpr_token_name_arg_ (ffelexToken t)
15171 {
15172 switch (ffelex_token_type (t))
15173 {
15174 case FFELEX_typeCLOSE_PAREN:
15175 case FFELEX_typeCOMMA:
15176 switch (ffeexpr_stack_->context)
15177 {
15178 case FFEEXPR_contextINDEXORACTUALARG_:
15179 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
15180 break;
15181
15182 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15183 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
15184 break;
15185
15186 default:
15187 break;
15188 }
15189 break;
15190
15191 default:
15192 switch (ffeexpr_stack_->context)
15193 {
15194 case FFEEXPR_contextACTUALARG_:
15195 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
15196 break;
15197
15198 case FFEEXPR_contextINDEXORACTUALARG_:
15199 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
15200 break;
15201
15202 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15203 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
15204 break;
15205
15206 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15207 ffeexpr_stack_->context
15208 = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
15209 break;
15210
15211 default:
15212 assert ("bad context in _name_arg_" == NULL);
15213 break;
15214 }
15215 break;
15216 }
15217
15218 return (ffelexHandler) ffeexpr_token_name_rhs_ (t);
15219 }
15220
15221 /* ffeexpr_token_name_rhs_ -- Rhs NAME
15222
15223 Return a pointer to this function to the lexer (ffelex), which will
15224 invoke it for the next token.
15225
15226 Handle a name followed by open-paren, apostrophe (O'octal-const',
15227 Z'hex-const', or X'hex-const'), period (RECORD.MEMBER).
15228
15229 26-Nov-91 JCB 1.2
15230 When followed by apostrophe or quote, set lex hexnum flag on so
15231 [0-9] as first char of next token seen as starting a potentially
15232 hex number (NAME).
15233 04-Oct-91 JCB 1.1
15234 In case of intrinsic, decorate its SYMTER with the type info for
15235 the specific intrinsic. */
15236
15237 static ffelexHandler
15238 ffeexpr_token_name_rhs_ (ffelexToken t)
15239 {
15240 ffeexprExpr_ e;
15241 ffeexprParenType_ paren_type;
15242 ffesymbol s;
15243 bool sfdef;
15244
15245 switch (ffelex_token_type (t))
15246 {
15247 case FFELEX_typeQUOTE:
15248 case FFELEX_typeAPOSTROPHE:
15249 ffeexpr_tokens_[1] = ffelex_token_use (t);
15250 ffelex_set_hexnum (TRUE);
15251 return (ffelexHandler) ffeexpr_token_name_apos_;
15252
15253 case FFELEX_typeOPEN_PAREN:
15254 e = ffeexpr_expr_new_ ();
15255 e->type = FFEEXPR_exprtypeOPERAND_;
15256 e->token = ffelex_token_use (ffeexpr_tokens_[0]);
15257 s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], TRUE,
15258 &paren_type);
15259 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15260 e->u.operand = ffebld_new_any ();
15261 else
15262 e->u.operand = ffebld_new_symter (s, ffesymbol_generic (s),
15263 ffesymbol_specific (s),
15264 ffesymbol_implementation (s));
15265 ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */
15266 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
15267 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15268 {
15269 case FFEEXPR_contextSFUNCDEF:
15270 case FFEEXPR_contextSFUNCDEFINDEX_:
15271 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15272 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15273 sfdef = TRUE;
15274 break;
15275
15276 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15277 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15278 assert ("weird context!" == NULL);
15279 sfdef = FALSE;
15280 break;
15281
15282 default:
15283 sfdef = FALSE;
15284 break;
15285 }
15286 switch (paren_type)
15287 {
15288 case FFEEXPR_parentypeFUNCTION_:
15289 ffebld_set_info (e->u.operand, ffesymbol_info (s));
15290 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15291 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
15292 { /* A statement function. */
15293 ffeexpr_stack_->num_args
15294 = ffebld_list_length
15295 (ffeexpr_stack_->next_dummy
15296 = ffesymbol_dummyargs (s));
15297 ffeexpr_stack_->tokens[1] = NULL; /* !=NULL when > num_args. */
15298 }
15299 else if ((ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
15300 && !ffe_is_pedantic_not_90 ()
15301 && ((ffesymbol_implementation (s)
15302 == FFEINTRIN_impICHAR)
15303 || (ffesymbol_implementation (s)
15304 == FFEINTRIN_impIACHAR)
15305 || (ffesymbol_implementation (s)
15306 == FFEINTRIN_impLEN)))
15307 { /* Allow arbitrary concatenations. */
15308 return
15309 (ffelexHandler)
15310 ffeexpr_rhs (ffeexpr_stack_->pool,
15311 sfdef
15312 ? FFEEXPR_contextSFUNCDEF
15313 : FFEEXPR_contextLET,
15314 ffeexpr_token_arguments_);
15315 }
15316 return
15317 (ffelexHandler)
15318 ffeexpr_rhs (ffeexpr_stack_->pool,
15319 sfdef
15320 ? FFEEXPR_contextSFUNCDEFACTUALARG_
15321 : FFEEXPR_contextACTUALARG_,
15322 ffeexpr_token_arguments_);
15323
15324 case FFEEXPR_parentypeARRAY_:
15325 ffebld_set_info (e->u.operand,
15326 ffesymbol_info (ffebld_symter (e->u.operand)));
15327 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15328 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
15329 ffeexpr_stack_->rank = 0;
15330 ffeexpr_stack_->constant = TRUE;
15331 ffeexpr_stack_->immediate = TRUE;
15332 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
15333 sfdef
15334 ? FFEEXPR_contextSFUNCDEFINDEX_
15335 : FFEEXPR_contextINDEX_,
15336 ffeexpr_token_elements_);
15337
15338 case FFEEXPR_parentypeSUBSTRING_:
15339 ffebld_set_info (e->u.operand,
15340 ffesymbol_info (ffebld_symter (e->u.operand)));
15341 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
15342 ffeexpr_tokens_[0]);
15343 return
15344 (ffelexHandler)
15345 ffeexpr_rhs (ffeexpr_stack_->pool,
15346 sfdef
15347 ? FFEEXPR_contextSFUNCDEFINDEX_
15348 : FFEEXPR_contextINDEX_,
15349 ffeexpr_token_substring_);
15350
15351 case FFEEXPR_parentypeFUNSUBSTR_:
15352 return
15353 (ffelexHandler)
15354 ffeexpr_rhs (ffeexpr_stack_->pool,
15355 sfdef
15356 ? FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
15357 : FFEEXPR_contextINDEXORACTUALARG_,
15358 ffeexpr_token_funsubstr_);
15359
15360 case FFEEXPR_parentypeANY_:
15361 ffebld_set_info (e->u.operand, ffesymbol_info (s));
15362 return
15363 (ffelexHandler)
15364 ffeexpr_rhs (ffeexpr_stack_->pool,
15365 sfdef
15366 ? FFEEXPR_contextSFUNCDEFACTUALARG_
15367 : FFEEXPR_contextACTUALARG_,
15368 ffeexpr_token_anything_);
15369
15370 default:
15371 assert ("bad paren type" == NULL);
15372 break;
15373 }
15374
15375 case FFELEX_typeEQUALS: /* As in "VAR=". */
15376 switch (ffeexpr_stack_->context)
15377 {
15378 case FFEEXPR_contextIMPDOITEM_: /* "(,VAR=start,end[,incr])". */
15379 case FFEEXPR_contextIMPDOITEMDF_:
15380 ffeexpr_stack_->is_rhs = FALSE; /* Really an lhs construct. */
15381 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
15382 break;
15383
15384 default:
15385 break;
15386 }
15387 break;
15388
15389 #if 0
15390 case FFELEX_typePERIOD:
15391 case FFELEX_typePERCENT:
15392 ~~Support these two someday, though not required
15393 assert ("FOO%, FOO. not yet supported!~~" == NULL);
15394 break;
15395 #endif
15396
15397 default:
15398 break;
15399 }
15400
15401 switch (ffeexpr_stack_->context)
15402 {
15403 case FFEEXPR_contextINDEXORACTUALARG_:
15404 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15405 assert ("strange context" == NULL);
15406 break;
15407
15408 default:
15409 break;
15410 }
15411
15412 e = ffeexpr_expr_new_ ();
15413 e->type = FFEEXPR_exprtypeOPERAND_;
15414 e->token = ffeexpr_tokens_[0];
15415 s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0], FALSE);
15416 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15417 {
15418 e->u.operand = ffebld_new_any ();
15419 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15420 }
15421 else
15422 {
15423 e->u.operand = ffebld_new_symter (s, FFEINTRIN_genNONE,
15424 ffesymbol_specific (s),
15425 ffesymbol_implementation (s));
15426 if (ffesymbol_specific (s) == FFEINTRIN_specNONE)
15427 ffebld_set_info (e->u.operand, ffeinfo_use (ffesymbol_info (s)));
15428 else
15429 { /* Decorate the SYMTER with the actual type
15430 of the intrinsic. */
15431 ffebld_set_info (e->u.operand, ffeinfo_new
15432 (ffeintrin_basictype (ffesymbol_specific (s)),
15433 ffeintrin_kindtype (ffesymbol_specific (s)),
15434 0,
15435 ffesymbol_kind (s),
15436 ffesymbol_where (s),
15437 FFETARGET_charactersizeNONE));
15438 }
15439 if (ffesymbol_is_doiter (s))
15440 ffebld_symter_set_is_doiter (e->u.operand, TRUE);
15441 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
15442 ffeexpr_tokens_[0]);
15443 }
15444 ffeexpr_exprstack_push_operand_ (e);
15445 return (ffelexHandler) ffeexpr_token_binary_ (t);
15446 }
15447
15448 /* ffeexpr_token_name_apos_ -- Rhs NAME APOSTROPHE
15449
15450 Return a pointer to this function to the lexer (ffelex), which will
15451 invoke it for the next token.
15452
15453 Expecting a NAME token, analyze the previous NAME token to see what kind,
15454 if any, typeless constant we've got.
15455
15456 01-Sep-90 JCB 1.1
15457 Expect a NAME instead of CHARACTER in this situation. */
15458
15459 static ffelexHandler
15460 ffeexpr_token_name_apos_ (ffelexToken t)
15461 {
15462 ffeexprExpr_ e;
15463
15464 ffelex_set_hexnum (FALSE);
15465
15466 switch (ffelex_token_type (t))
15467 {
15468 case FFELEX_typeNAME:
15469 ffeexpr_tokens_[2] = ffelex_token_use (t);
15470 return (ffelexHandler) ffeexpr_token_name_apos_name_;
15471
15472 default:
15473 break;
15474 }
15475
15476 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
15477 {
15478 ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
15479 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15480 ffelex_token_where_column (ffeexpr_tokens_[0]));
15481 ffebad_here (1, ffelex_token_where_line (t),
15482 ffelex_token_where_column (t));
15483 ffebad_finish ();
15484 }
15485
15486 ffelex_token_kill (ffeexpr_tokens_[1]);
15487
15488 e = ffeexpr_expr_new_ ();
15489 e->type = FFEEXPR_exprtypeOPERAND_;
15490 e->u.operand = ffebld_new_any ();
15491 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15492 e->token = ffeexpr_tokens_[0];
15493 ffeexpr_exprstack_push_operand_ (e);
15494
15495 return (ffelexHandler) ffeexpr_token_binary_ (t);
15496 }
15497
15498 /* ffeexpr_token_name_apos_name_ -- Rhs NAME APOSTROPHE NAME
15499
15500 Return a pointer to this function to the lexer (ffelex), which will
15501 invoke it for the next token.
15502
15503 Expecting an APOSTROPHE token, analyze the previous NAME token to see
15504 what kind, if any, typeless constant we've got. */
15505
15506 static ffelexHandler
15507 ffeexpr_token_name_apos_name_ (ffelexToken t)
15508 {
15509 ffeexprExpr_ e;
15510 char c;
15511
15512 e = ffeexpr_expr_new_ ();
15513 e->type = FFEEXPR_exprtypeOPERAND_;
15514 e->token = ffeexpr_tokens_[0];
15515
15516 if ((ffelex_token_type (t) == ffelex_token_type (ffeexpr_tokens_[1]))
15517 && (ffelex_token_length (ffeexpr_tokens_[0]) == 1)
15518 && (ffesrc_char_match_init ((c = ffelex_token_text (ffeexpr_tokens_[0])[0]),
15519 'B', 'b')
15520 || ffesrc_char_match_init (c, 'O', 'o')
15521 || ffesrc_char_match_init (c, 'X', 'x')
15522 || ffesrc_char_match_init (c, 'Z', 'z')))
15523 {
15524 ffetargetCharacterSize size;
15525
15526 if (!ffe_is_typeless_boz ()) {
15527
15528 switch (c)
15529 {
15530 case FFESRC_CASE_MATCH_INIT ('B', 'b', imatch_b, no_imatch):
15531 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerbinary
15532 (ffeexpr_tokens_[2]));
15533 break;
15534
15535 case FFESRC_CASE_MATCH_INIT ('O', 'o', imatch_o, no_imatch):
15536 e->u.operand = ffebld_new_conter (ffebld_constant_new_integeroctal
15537 (ffeexpr_tokens_[2]));
15538 break;
15539
15540 case FFESRC_CASE_MATCH_INIT ('X', 'x', imatch_x, no_imatch):
15541 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
15542 (ffeexpr_tokens_[2]));
15543 break;
15544
15545 case FFESRC_CASE_MATCH_INIT ('Z', 'z', imatch_z, no_imatch):
15546 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
15547 (ffeexpr_tokens_[2]));
15548 break;
15549
15550 default:
15551 no_imatch: /* :::::::::::::::::::: */
15552 assert ("not BOXZ!" == NULL);
15553 abort ();
15554 }
15555
15556 ffebld_set_info (e->u.operand,
15557 ffeinfo_new (FFEINFO_basictypeINTEGER,
15558 FFEINFO_kindtypeINTEGERDEFAULT, 0,
15559 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
15560 FFETARGET_charactersizeNONE));
15561 ffeexpr_exprstack_push_operand_ (e);
15562 ffelex_token_kill (ffeexpr_tokens_[1]);
15563 ffelex_token_kill (ffeexpr_tokens_[2]);
15564 return (ffelexHandler) ffeexpr_token_binary_;
15565 }
15566
15567 switch (c)
15568 {
15569 case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
15570 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_bm
15571 (ffeexpr_tokens_[2]));
15572 size = ffetarget_size_typeless_binary (ffeexpr_tokens_[2]);
15573 break;
15574
15575 case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
15576 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_om
15577 (ffeexpr_tokens_[2]));
15578 size = ffetarget_size_typeless_octal (ffeexpr_tokens_[2]);
15579 break;
15580
15581 case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
15582 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hxm
15583 (ffeexpr_tokens_[2]));
15584 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15585 break;
15586
15587 case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
15588 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
15589 (ffeexpr_tokens_[2]));
15590 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15591 break;
15592
15593 default:
15594 no_match: /* :::::::::::::::::::: */
15595 assert ("not BOXZ!" == NULL);
15596 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
15597 (ffeexpr_tokens_[2]));
15598 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15599 break;
15600 }
15601 ffebld_set_info (e->u.operand,
15602 ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
15603 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
15604 ffeexpr_exprstack_push_operand_ (e);
15605 ffelex_token_kill (ffeexpr_tokens_[1]);
15606 ffelex_token_kill (ffeexpr_tokens_[2]);
15607 return (ffelexHandler) ffeexpr_token_binary_;
15608 }
15609
15610 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
15611 {
15612 ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
15613 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15614 ffelex_token_where_column (ffeexpr_tokens_[0]));
15615 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
15616 ffebad_finish ();
15617 }
15618
15619 ffelex_token_kill (ffeexpr_tokens_[1]);
15620 ffelex_token_kill (ffeexpr_tokens_[2]);
15621
15622 e->type = FFEEXPR_exprtypeOPERAND_;
15623 e->u.operand = ffebld_new_any ();
15624 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15625 e->token = ffeexpr_tokens_[0];
15626 ffeexpr_exprstack_push_operand_ (e);
15627
15628 switch (ffelex_token_type (t))
15629 {
15630 case FFELEX_typeAPOSTROPHE:
15631 case FFELEX_typeQUOTE:
15632 return (ffelexHandler) ffeexpr_token_binary_;
15633
15634 default:
15635 return (ffelexHandler) ffeexpr_token_binary_ (t);
15636 }
15637 }
15638
15639 /* ffeexpr_token_percent_ -- Rhs PERCENT
15640
15641 Handle a percent sign possibly followed by "LOC". If followed instead
15642 by "VAL", "REF", or "DESCR", issue an error message and substitute
15643 "LOC". If followed by something else, treat the percent sign as a
15644 spurious incorrect token and reprocess the token via _rhs_. */
15645
15646 static ffelexHandler
15647 ffeexpr_token_percent_ (ffelexToken t)
15648 {
15649 switch (ffelex_token_type (t))
15650 {
15651 case FFELEX_typeNAME:
15652 case FFELEX_typeNAMES:
15653 ffeexpr_stack_->percent = ffeexpr_percent_ (t);
15654 ffeexpr_tokens_[1] = ffelex_token_use (t);
15655 return (ffelexHandler) ffeexpr_token_percent_name_;
15656
15657 default:
15658 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
15659 {
15660 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15661 ffelex_token_where_column (ffeexpr_tokens_[0]));
15662 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
15663 ffelex_token_where_column (ffeexpr_stack_->first_token));
15664 ffebad_finish ();
15665 }
15666 ffelex_token_kill (ffeexpr_tokens_[0]);
15667 return (ffelexHandler) ffeexpr_token_rhs_ (t);
15668 }
15669 }
15670
15671 /* ffeexpr_token_percent_name_ -- Rhs PERCENT NAME
15672
15673 Make sure the token is OPEN_PAREN and prepare for the one-item list of
15674 LHS expressions. Else display an error message. */
15675
15676 static ffelexHandler
15677 ffeexpr_token_percent_name_ (ffelexToken t)
15678 {
15679 ffelexHandler nexthandler;
15680
15681 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
15682 {
15683 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
15684 {
15685 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15686 ffelex_token_where_column (ffeexpr_tokens_[0]));
15687 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
15688 ffelex_token_where_column (ffeexpr_stack_->first_token));
15689 ffebad_finish ();
15690 }
15691 ffelex_token_kill (ffeexpr_tokens_[0]);
15692 nexthandler = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_tokens_[1]);
15693 ffelex_token_kill (ffeexpr_tokens_[1]);
15694 return (ffelexHandler) (*nexthandler) (t);
15695 }
15696
15697 switch (ffeexpr_stack_->percent)
15698 {
15699 default:
15700 if (ffest_ffebad_start (FFEBAD_INVALID_PERCENT))
15701 {
15702 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15703 ffelex_token_where_column (ffeexpr_tokens_[0]));
15704 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
15705 ffebad_finish ();
15706 }
15707 ffeexpr_stack_->percent = FFEEXPR_percentLOC_;
15708 /* Fall through. */
15709 case FFEEXPR_percentLOC_:
15710 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
15711 ffelex_token_kill (ffeexpr_tokens_[1]);
15712 ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
15713 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
15714 FFEEXPR_contextLOC_,
15715 ffeexpr_cb_end_loc_);
15716 }
15717 }
15718
15719 /* ffeexpr_make_float_const_ -- Make a floating-point constant
15720
15721 See prototype.
15722
15723 Pass 'E', 'D', or 'Q' for exponent letter. */
15724
15725 static void
15726 ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
15727 ffelexToken decimal, ffelexToken fraction,
15728 ffelexToken exponent, ffelexToken exponent_sign,
15729 ffelexToken exponent_digits)
15730 {
15731 ffeexprExpr_ e;
15732
15733 e = ffeexpr_expr_new_ ();
15734 e->type = FFEEXPR_exprtypeOPERAND_;
15735 if (integer != NULL)
15736 e->token = ffelex_token_use (integer);
15737 else
15738 {
15739 assert (decimal != NULL);
15740 e->token = ffelex_token_use (decimal);
15741 }
15742
15743 switch (exp_letter)
15744 {
15745 #if !FFETARGET_okREALQUAD
15746 case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
15747 if (ffebad_start (FFEBAD_QUAD_UNSUPPORTED))
15748 {
15749 ffebad_here (0, ffelex_token_where_line (e->token),
15750 ffelex_token_where_column (e->token));
15751 ffebad_finish ();
15752 }
15753 goto match_d; /* The FFESRC_CASE_* macros don't
15754 allow fall-through! */
15755 #endif
15756
15757 case FFESRC_CASE_MATCH_INIT ('D', 'd', match_d, no_match):
15758 e->u.operand = ffebld_new_conter (ffebld_constant_new_realdouble
15759 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15760 ffebld_set_info (e->u.operand,
15761 ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
15762 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15763 break;
15764
15765 case FFESRC_CASE_MATCH_INIT ('E', 'e', match_e, no_match):
15766 e->u.operand = ffebld_new_conter (ffebld_constant_new_realdefault
15767 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15768 ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeREAL,
15769 FFEINFO_kindtypeREALDEFAULT, 0, FFEINFO_kindENTITY,
15770 FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15771 break;
15772
15773 #if FFETARGET_okREALQUAD
15774 case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
15775 e->u.operand = ffebld_new_conter (ffebld_constant_new_realquad
15776 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15777 ffebld_set_info (e->u.operand,
15778 ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALQUAD,
15779 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15780 break;
15781 #endif
15782
15783 case 'I': /* Make an integer. */
15784 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
15785 (ffeexpr_tokens_[0]));
15786 ffebld_set_info (e->u.operand,
15787 ffeinfo_new (FFEINFO_basictypeINTEGER,
15788 FFEINFO_kindtypeINTEGERDEFAULT, 0,
15789 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
15790 FFETARGET_charactersizeNONE));
15791 break;
15792
15793 default:
15794 no_match: /* :::::::::::::::::::: */
15795 assert ("Lost the exponent letter!" == NULL);
15796 }
15797
15798 ffeexpr_exprstack_push_operand_ (e);
15799 }
15800
15801 /* Just like ffesymbol_declare_local, except performs any implicit info
15802 assignment necessary. */
15803
15804 static ffesymbol
15805 ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin)
15806 {
15807 ffesymbol s;
15808 ffeinfoKind k;
15809 bool bad;
15810
15811 s = ffesymbol_declare_local (t, maybe_intrin);
15812
15813 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15814 /* Special-case these since they can involve a different concept
15815 of "state" (in the stmtfunc name space). */
15816 {
15817 case FFEEXPR_contextDATAIMPDOINDEX_:
15818 case FFEEXPR_contextDATAIMPDOCTRL_:
15819 if (ffeexpr_context_outer_ (ffeexpr_stack_)
15820 == FFEEXPR_contextDATAIMPDOINDEX_)
15821 s = ffeexpr_sym_impdoitem_ (s, t);
15822 else
15823 if (ffeexpr_stack_->is_rhs)
15824 s = ffeexpr_sym_impdoitem_ (s, t);
15825 else
15826 s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
15827 bad = (ffesymbol_kind (s) != FFEINFO_kindENTITY)
15828 || ((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
15829 && (ffesymbol_where (s) != FFEINFO_whereIMMEDIATE));
15830 if (bad && (ffesymbol_kind (s) != FFEINFO_kindANY))
15831 ffesymbol_error (s, t);
15832 return s;
15833
15834 default:
15835 break;
15836 }
15837
15838 switch ((ffesymbol_sfdummyparent (s) == NULL)
15839 ? ffesymbol_state (s)
15840 : FFESYMBOL_stateUNDERSTOOD)
15841 {
15842 case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr
15843 context. */
15844 if (!ffest_seen_first_exec ())
15845 goto seen; /* :::::::::::::::::::: */
15846 /* Fall through. */
15847 case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */
15848 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15849 {
15850 case FFEEXPR_contextSUBROUTINEREF:
15851 s = ffeexpr_sym_lhs_call_ (s, t);
15852 break;
15853
15854 case FFEEXPR_contextFILEEXTFUNC:
15855 s = ffeexpr_sym_lhs_extfunc_ (s, t);
15856 break;
15857
15858 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15859 s = ffecom_sym_exec_transition (s);
15860 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15861 goto understood; /* :::::::::::::::::::: */
15862 /* Fall through. */
15863 case FFEEXPR_contextACTUALARG_:
15864 s = ffeexpr_sym_rhs_actualarg_ (s, t);
15865 break;
15866
15867 case FFEEXPR_contextDATA:
15868 if (ffeexpr_stack_->is_rhs)
15869 s = ffeexpr_sym_rhs_let_ (s, t);
15870 else
15871 s = ffeexpr_sym_lhs_data_ (s, t);
15872 break;
15873
15874 case FFEEXPR_contextDATAIMPDOITEM_:
15875 s = ffeexpr_sym_lhs_data_ (s, t);
15876 break;
15877
15878 case FFEEXPR_contextSFUNCDEF:
15879 case FFEEXPR_contextSFUNCDEFINDEX_:
15880 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15881 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15882 s = ffecom_sym_exec_transition (s);
15883 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15884 goto understood; /* :::::::::::::::::::: */
15885 /* Fall through. */
15886 case FFEEXPR_contextLET:
15887 case FFEEXPR_contextPAREN_:
15888 case FFEEXPR_contextACTUALARGEXPR_:
15889 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15890 case FFEEXPR_contextASSIGN:
15891 case FFEEXPR_contextIOLIST:
15892 case FFEEXPR_contextIOLISTDF:
15893 case FFEEXPR_contextDO:
15894 case FFEEXPR_contextDOWHILE:
15895 case FFEEXPR_contextAGOTO:
15896 case FFEEXPR_contextCGOTO:
15897 case FFEEXPR_contextIF:
15898 case FFEEXPR_contextARITHIF:
15899 case FFEEXPR_contextFORMAT:
15900 case FFEEXPR_contextSTOP:
15901 case FFEEXPR_contextRETURN:
15902 case FFEEXPR_contextSELECTCASE:
15903 case FFEEXPR_contextCASE:
15904 case FFEEXPR_contextFILEASSOC:
15905 case FFEEXPR_contextFILEINT:
15906 case FFEEXPR_contextFILEDFINT:
15907 case FFEEXPR_contextFILELOG:
15908 case FFEEXPR_contextFILENUM:
15909 case FFEEXPR_contextFILENUMAMBIG:
15910 case FFEEXPR_contextFILECHAR:
15911 case FFEEXPR_contextFILENUMCHAR:
15912 case FFEEXPR_contextFILEDFCHAR:
15913 case FFEEXPR_contextFILEKEY:
15914 case FFEEXPR_contextFILEUNIT:
15915 case FFEEXPR_contextFILEUNIT_DF:
15916 case FFEEXPR_contextFILEUNITAMBIG:
15917 case FFEEXPR_contextFILEFORMAT:
15918 case FFEEXPR_contextFILENAMELIST:
15919 case FFEEXPR_contextFILEVXTCODE:
15920 case FFEEXPR_contextINDEX_:
15921 case FFEEXPR_contextIMPDOITEM_:
15922 case FFEEXPR_contextIMPDOITEMDF_:
15923 case FFEEXPR_contextIMPDOCTRL_:
15924 case FFEEXPR_contextLOC_:
15925 if (ffeexpr_stack_->is_rhs)
15926 s = ffeexpr_sym_rhs_let_ (s, t);
15927 else
15928 s = ffeexpr_sym_lhs_let_ (s, t);
15929 break;
15930
15931 case FFEEXPR_contextCHARACTERSIZE:
15932 case FFEEXPR_contextEQUIVALENCE:
15933 case FFEEXPR_contextINCLUDE:
15934 case FFEEXPR_contextPARAMETER:
15935 case FFEEXPR_contextDIMLIST:
15936 case FFEEXPR_contextDIMLISTCOMMON:
15937 case FFEEXPR_contextKINDTYPE:
15938 case FFEEXPR_contextINITVAL:
15939 case FFEEXPR_contextEQVINDEX_:
15940 break; /* Will turn into errors below. */
15941
15942 default:
15943 ffesymbol_error (s, t);
15944 break;
15945 }
15946 /* Fall through. */
15947 case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */
15948 understood: /* :::::::::::::::::::: */
15949 k = ffesymbol_kind (s);
15950 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15951 {
15952 case FFEEXPR_contextSUBROUTINEREF:
15953 bad = ((k != FFEINFO_kindSUBROUTINE)
15954 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
15955 || (k != FFEINFO_kindNONE)));
15956 break;
15957
15958 case FFEEXPR_contextFILEEXTFUNC:
15959 bad = (k != FFEINFO_kindFUNCTION)
15960 || (ffesymbol_where (s) != FFEINFO_whereGLOBAL);
15961 break;
15962
15963 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15964 case FFEEXPR_contextACTUALARG_:
15965 switch (k)
15966 {
15967 case FFEINFO_kindENTITY:
15968 bad = FALSE;
15969 break;
15970
15971 case FFEINFO_kindFUNCTION:
15972 case FFEINFO_kindSUBROUTINE:
15973 bad
15974 = ((ffesymbol_where (s) != FFEINFO_whereGLOBAL)
15975 && (ffesymbol_where (s) != FFEINFO_whereDUMMY)
15976 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
15977 || !ffeintrin_is_actualarg (ffesymbol_specific (s))));
15978 break;
15979
15980 case FFEINFO_kindNONE:
15981 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
15982 {
15983 bad = !(ffeintrin_is_actualarg (ffesymbol_specific (s)));
15984 break;
15985 }
15986
15987 /* If state is UNDERSTOOD here, it's CHAR*(*) or attrsANY,
15988 and in the former case, attrsTYPE is set, so we
15989 see this as an error as we should, since CHAR*(*)
15990 cannot be actually referenced in a main/block data
15991 program unit. */
15992
15993 if ((ffesymbol_attrs (s) & (FFESYMBOL_attrsANY
15994 | FFESYMBOL_attrsEXTERNAL
15995 | FFESYMBOL_attrsTYPE))
15996 == FFESYMBOL_attrsEXTERNAL)
15997 bad = FALSE;
15998 else
15999 bad = TRUE;
16000 break;
16001
16002 default:
16003 bad = TRUE;
16004 break;
16005 }
16006 break;
16007
16008 case FFEEXPR_contextDATA:
16009 if (ffeexpr_stack_->is_rhs)
16010 bad = (k != FFEINFO_kindENTITY)
16011 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16012 else
16013 bad = (k != FFEINFO_kindENTITY)
16014 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
16015 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
16016 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
16017 break;
16018
16019 case FFEEXPR_contextDATAIMPDOITEM_:
16020 bad = TRUE; /* Unadorned item never valid. */
16021 break;
16022
16023 case FFEEXPR_contextSFUNCDEF:
16024 case FFEEXPR_contextSFUNCDEFINDEX_:
16025 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16026 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16027 case FFEEXPR_contextLET:
16028 case FFEEXPR_contextPAREN_:
16029 case FFEEXPR_contextACTUALARGEXPR_:
16030 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16031 case FFEEXPR_contextASSIGN:
16032 case FFEEXPR_contextIOLIST:
16033 case FFEEXPR_contextIOLISTDF:
16034 case FFEEXPR_contextDO:
16035 case FFEEXPR_contextDOWHILE:
16036 case FFEEXPR_contextAGOTO:
16037 case FFEEXPR_contextCGOTO:
16038 case FFEEXPR_contextIF:
16039 case FFEEXPR_contextARITHIF:
16040 case FFEEXPR_contextFORMAT:
16041 case FFEEXPR_contextSTOP:
16042 case FFEEXPR_contextRETURN:
16043 case FFEEXPR_contextSELECTCASE:
16044 case FFEEXPR_contextCASE:
16045 case FFEEXPR_contextFILEASSOC:
16046 case FFEEXPR_contextFILEINT:
16047 case FFEEXPR_contextFILEDFINT:
16048 case FFEEXPR_contextFILELOG:
16049 case FFEEXPR_contextFILENUM:
16050 case FFEEXPR_contextFILENUMAMBIG:
16051 case FFEEXPR_contextFILECHAR:
16052 case FFEEXPR_contextFILENUMCHAR:
16053 case FFEEXPR_contextFILEDFCHAR:
16054 case FFEEXPR_contextFILEKEY:
16055 case FFEEXPR_contextFILEUNIT:
16056 case FFEEXPR_contextFILEUNIT_DF:
16057 case FFEEXPR_contextFILEUNITAMBIG:
16058 case FFEEXPR_contextFILEFORMAT:
16059 case FFEEXPR_contextFILENAMELIST:
16060 case FFEEXPR_contextFILEVXTCODE:
16061 case FFEEXPR_contextINDEX_:
16062 case FFEEXPR_contextIMPDOITEM_:
16063 case FFEEXPR_contextIMPDOITEMDF_:
16064 case FFEEXPR_contextIMPDOCTRL_:
16065 case FFEEXPR_contextLOC_:
16066 bad = (k != FFEINFO_kindENTITY); /* This catches "SUBROUTINE
16067 X(A);EXTERNAL A;CALL
16068 Y(A);B=A", for example. */
16069 break;
16070
16071 case FFEEXPR_contextCHARACTERSIZE:
16072 case FFEEXPR_contextEQUIVALENCE:
16073 case FFEEXPR_contextPARAMETER:
16074 case FFEEXPR_contextDIMLIST:
16075 case FFEEXPR_contextDIMLISTCOMMON:
16076 case FFEEXPR_contextKINDTYPE:
16077 case FFEEXPR_contextINITVAL:
16078 case FFEEXPR_contextEQVINDEX_:
16079 bad = (k != FFEINFO_kindENTITY)
16080 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16081 break;
16082
16083 case FFEEXPR_contextINCLUDE:
16084 bad = TRUE;
16085 break;
16086
16087 default:
16088 bad = TRUE;
16089 break;
16090 }
16091 if (bad && (k != FFEINFO_kindANY))
16092 ffesymbol_error (s, t);
16093 return s;
16094
16095 case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */
16096 seen: /* :::::::::::::::::::: */
16097 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16098 {
16099 case FFEEXPR_contextPARAMETER:
16100 if (ffeexpr_stack_->is_rhs)
16101 ffesymbol_error (s, t);
16102 else
16103 s = ffeexpr_sym_lhs_parameter_ (s, t);
16104 break;
16105
16106 case FFEEXPR_contextDATA:
16107 s = ffecom_sym_exec_transition (s);
16108 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16109 goto understood; /* :::::::::::::::::::: */
16110 if (ffeexpr_stack_->is_rhs)
16111 ffesymbol_error (s, t);
16112 else
16113 s = ffeexpr_sym_lhs_data_ (s, t);
16114 goto understood; /* :::::::::::::::::::: */
16115
16116 case FFEEXPR_contextDATAIMPDOITEM_:
16117 s = ffecom_sym_exec_transition (s);
16118 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16119 goto understood; /* :::::::::::::::::::: */
16120 s = ffeexpr_sym_lhs_data_ (s, t);
16121 goto understood; /* :::::::::::::::::::: */
16122
16123 case FFEEXPR_contextEQUIVALENCE:
16124 s = ffeexpr_sym_lhs_equivalence_ (s, t);
16125 break;
16126
16127 case FFEEXPR_contextDIMLIST:
16128 s = ffeexpr_sym_rhs_dimlist_ (s, t);
16129 break;
16130
16131 case FFEEXPR_contextCHARACTERSIZE:
16132 case FFEEXPR_contextKINDTYPE:
16133 case FFEEXPR_contextDIMLISTCOMMON:
16134 case FFEEXPR_contextINITVAL:
16135 case FFEEXPR_contextEQVINDEX_:
16136 ffesymbol_error (s, t);
16137 break;
16138
16139 case FFEEXPR_contextINCLUDE:
16140 ffesymbol_error (s, t);
16141 break;
16142
16143 case FFEEXPR_contextACTUALARG_: /* E.g. I in REAL A(Y(I)). */
16144 case FFEEXPR_contextSFUNCDEFACTUALARG_:
16145 s = ffecom_sym_exec_transition (s);
16146 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16147 goto understood; /* :::::::::::::::::::: */
16148 s = ffeexpr_sym_rhs_actualarg_ (s, t);
16149 goto understood; /* :::::::::::::::::::: */
16150
16151 case FFEEXPR_contextINDEX_:
16152 case FFEEXPR_contextACTUALARGEXPR_:
16153 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16154 case FFEEXPR_contextSFUNCDEF:
16155 case FFEEXPR_contextSFUNCDEFINDEX_:
16156 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16157 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16158 assert (ffeexpr_stack_->is_rhs);
16159 s = ffecom_sym_exec_transition (s);
16160 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16161 goto understood; /* :::::::::::::::::::: */
16162 s = ffeexpr_sym_rhs_let_ (s, t);
16163 goto understood; /* :::::::::::::::::::: */
16164
16165 default:
16166 ffesymbol_error (s, t);
16167 break;
16168 }
16169 return s;
16170
16171 default:
16172 assert ("bad symbol state" == NULL);
16173 return NULL;
16174 break;
16175 }
16176 }
16177
16178 /* Have FOO in DATA (XYZ(FOO),...)/.../ or DATA (...,XYZ=FOO,BAR,BLETCH).
16179 Could be found via the "statement-function" name space (in which case
16180 it should become an iterator) or the local name space (in which case
16181 it should be either a named constant, or a variable that will have an
16182 sfunc name space sibling that should become an iterator). */
16183
16184 static ffesymbol
16185 ffeexpr_sym_impdoitem_ (ffesymbol sp, ffelexToken t)
16186 {
16187 ffesymbol s;
16188 ffesymbolAttrs sa;
16189 ffesymbolAttrs na;
16190 ffesymbolState ss;
16191 ffesymbolState ns;
16192 ffeinfoKind kind;
16193 ffeinfoWhere where;
16194
16195 ss = ffesymbol_state (sp);
16196
16197 if (ffesymbol_sfdummyparent (sp) != NULL)
16198 { /* Have symbol in sfunc name space. */
16199 switch (ss)
16200 {
16201 case FFESYMBOL_stateNONE: /* Used as iterator already. */
16202 if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
16203 ffesymbol_error (sp, t); /* Can't use dead iterator. */
16204 else
16205 { /* Can use dead iterator because we're at at
16206 least an innermore (higher-numbered) level
16207 than the iterator's outermost
16208 (lowest-numbered) level. */
16209 ffesymbol_signal_change (sp);
16210 ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
16211 ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
16212 ffesymbol_signal_unreported (sp);
16213 }
16214 break;
16215
16216 case FFESYMBOL_stateSEEN: /* Seen already in this or other
16217 implied-DO. Set symbol level
16218 number to outermost value, as that
16219 tells us we can see it as iterator
16220 at that level at the innermost. */
16221 if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
16222 {
16223 ffesymbol_signal_change (sp);
16224 ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
16225 ffesymbol_signal_unreported (sp);
16226 }
16227 break;
16228
16229 case FFESYMBOL_stateUNCERTAIN: /* Iterator. */
16230 assert (ffeexpr_level_ == ffesymbol_maxentrynum (sp));
16231 ffesymbol_error (sp, t); /* (,,,I=I,10). */
16232 break;
16233
16234 case FFESYMBOL_stateUNDERSTOOD:
16235 break; /* ANY. */
16236
16237 default:
16238 assert ("Foo Bar!!" == NULL);
16239 break;
16240 }
16241
16242 return sp;
16243 }
16244
16245 /* Got symbol in local name space, so we haven't seen it in impdo yet.
16246 First, if it is brand-new and we're in executable statements, set the
16247 attributes and exec-transition it to set state UNCERTAIN or UNDERSTOOD.
16248 Second, if it is now a constant (PARAMETER), then just return it, it
16249 can't be an implied-do iterator. If it is understood, complain if it is
16250 not a valid variable, but make the inner name space iterator anyway and
16251 return that. If it is not understood, improve understanding of the
16252 symbol accordingly, complain accordingly, in either case make the inner
16253 name space iterator and return that. */
16254
16255 sa = ffesymbol_attrs (sp);
16256
16257 if (ffesymbol_state_is_specable (ss)
16258 && ffest_seen_first_exec ())
16259 {
16260 assert (sa == FFESYMBOL_attrsetNONE);
16261 ffesymbol_signal_change (sp);
16262 ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
16263 ffesymbol_resolve_intrin (sp);
16264 if (ffeimplic_establish_symbol (sp))
16265 ffesymbol_set_attr (sp, FFESYMBOL_attrSFARG);
16266 else
16267 ffesymbol_error (sp, t);
16268
16269 /* After the exec transition, the state will either be UNCERTAIN (could
16270 be a dummy or local var) or UNDERSTOOD (local var, because this is a
16271 PROGRAM/BLOCKDATA program unit). */
16272
16273 sp = ffecom_sym_exec_transition (sp);
16274 sa = ffesymbol_attrs (sp);
16275 ss = ffesymbol_state (sp);
16276 }
16277
16278 ns = ss;
16279 kind = ffesymbol_kind (sp);
16280 where = ffesymbol_where (sp);
16281
16282 if (ss == FFESYMBOL_stateUNDERSTOOD)
16283 {
16284 if (kind != FFEINFO_kindENTITY)
16285 ffesymbol_error (sp, t);
16286 if (where == FFEINFO_whereCONSTANT)
16287 return sp;
16288 }
16289 else
16290 {
16291 /* Enhance understanding of local symbol. This used to imply exec
16292 transition, but that doesn't seem necessary, since the local symbol
16293 doesn't actually get put into an ffebld tree here -- we just learn
16294 more about it, just like when we see a local symbol's name in the
16295 dummy-arg list of a statement function. */
16296
16297 if (ss != FFESYMBOL_stateUNCERTAIN)
16298 {
16299 /* Figure out what kind of object we've got based on previous
16300 declarations of or references to the object. */
16301
16302 ns = FFESYMBOL_stateSEEN;
16303
16304 if (sa & FFESYMBOL_attrsANY)
16305 na = sa;
16306 else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
16307 | FFESYMBOL_attrsANY
16308 | FFESYMBOL_attrsCOMMON
16309 | FFESYMBOL_attrsDUMMY
16310 | FFESYMBOL_attrsEQUIV
16311 | FFESYMBOL_attrsINIT
16312 | FFESYMBOL_attrsNAMELIST
16313 | FFESYMBOL_attrsRESULT
16314 | FFESYMBOL_attrsSAVE
16315 | FFESYMBOL_attrsSFARG
16316 | FFESYMBOL_attrsTYPE)))
16317 na = sa | FFESYMBOL_attrsSFARG;
16318 else
16319 na = FFESYMBOL_attrsetNONE;
16320 }
16321 else
16322 { /* stateUNCERTAIN. */
16323 na = sa | FFESYMBOL_attrsSFARG;
16324 ns = FFESYMBOL_stateUNDERSTOOD;
16325
16326 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16327 | FFESYMBOL_attrsADJUSTABLE
16328 | FFESYMBOL_attrsANYLEN
16329 | FFESYMBOL_attrsARRAY
16330 | FFESYMBOL_attrsDUMMY
16331 | FFESYMBOL_attrsEXTERNAL
16332 | FFESYMBOL_attrsSFARG
16333 | FFESYMBOL_attrsTYPE)));
16334
16335 if (sa & FFESYMBOL_attrsEXTERNAL)
16336 {
16337 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16338 | FFESYMBOL_attrsDUMMY
16339 | FFESYMBOL_attrsEXTERNAL
16340 | FFESYMBOL_attrsTYPE)));
16341
16342 na = FFESYMBOL_attrsetNONE;
16343 }
16344 else if (sa & FFESYMBOL_attrsDUMMY)
16345 {
16346 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16347 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16348 | FFESYMBOL_attrsEXTERNAL
16349 | FFESYMBOL_attrsTYPE)));
16350
16351 kind = FFEINFO_kindENTITY;
16352 }
16353 else if (sa & FFESYMBOL_attrsARRAY)
16354 {
16355 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16356 | FFESYMBOL_attrsADJUSTABLE
16357 | FFESYMBOL_attrsTYPE)));
16358
16359 na = FFESYMBOL_attrsetNONE;
16360 }
16361 else if (sa & FFESYMBOL_attrsSFARG)
16362 {
16363 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16364 | FFESYMBOL_attrsTYPE)));
16365
16366 ns = FFESYMBOL_stateUNCERTAIN;
16367 }
16368 else if (sa & FFESYMBOL_attrsTYPE)
16369 {
16370 assert (!(sa & (FFESYMBOL_attrsARRAY
16371 | FFESYMBOL_attrsDUMMY
16372 | FFESYMBOL_attrsEXTERNAL
16373 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16374 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16375 | FFESYMBOL_attrsADJUSTABLE
16376 | FFESYMBOL_attrsANYLEN
16377 | FFESYMBOL_attrsARRAY
16378 | FFESYMBOL_attrsDUMMY
16379 | FFESYMBOL_attrsEXTERNAL
16380 | FFESYMBOL_attrsSFARG)));
16381
16382 kind = FFEINFO_kindENTITY;
16383
16384 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16385 na = FFESYMBOL_attrsetNONE;
16386 else if (ffest_is_entry_valid ())
16387 ns = FFESYMBOL_stateUNCERTAIN; /* Could be DUMMY or LOCAL. */
16388 else
16389 where = FFEINFO_whereLOCAL;
16390 }
16391 else
16392 na = FFESYMBOL_attrsetNONE; /* Error. */
16393 }
16394
16395 /* Now see what we've got for a new object: NONE means a new error
16396 cropped up; ANY means an old error to be ignored; otherwise,
16397 everything's ok, update the object (symbol) and continue on. */
16398
16399 if (na == FFESYMBOL_attrsetNONE)
16400 ffesymbol_error (sp, t);
16401 else if (!(na & FFESYMBOL_attrsANY))
16402 {
16403 ffesymbol_signal_change (sp); /* May need to back up to previous
16404 version. */
16405 if (!ffeimplic_establish_symbol (sp))
16406 ffesymbol_error (sp, t);
16407 else
16408 {
16409 ffesymbol_set_info (sp,
16410 ffeinfo_new (ffesymbol_basictype (sp),
16411 ffesymbol_kindtype (sp),
16412 ffesymbol_rank (sp),
16413 kind,
16414 where,
16415 ffesymbol_size (sp)));
16416 ffesymbol_set_attrs (sp, na);
16417 ffesymbol_set_state (sp, ns);
16418 ffesymbol_resolve_intrin (sp);
16419 if (!ffesymbol_state_is_specable (ns))
16420 sp = ffecom_sym_learned (sp);
16421 ffesymbol_signal_unreported (sp); /* For debugging purposes. */
16422 }
16423 }
16424 }
16425
16426 /* Here we create the sfunc-name-space symbol representing what should
16427 become an iterator in this name space at this or an outermore (lower-
16428 numbered) expression level, else the implied-DO construct is in error. */
16429
16430 s = ffesymbol_declare_sfdummy (t); /* Sets maxentrynum to 0 for new obj;
16431 also sets sfa_dummy_parent to
16432 parent symbol. */
16433 assert (sp == ffesymbol_sfdummyparent (s));
16434
16435 ffesymbol_signal_change (s);
16436 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
16437 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
16438 ffesymbol_set_info (s,
16439 ffeinfo_new (FFEINFO_basictypeINTEGER,
16440 FFEINFO_kindtypeINTEGERDEFAULT,
16441 0,
16442 FFEINFO_kindENTITY,
16443 FFEINFO_whereIMMEDIATE,
16444 FFETARGET_charactersizeNONE));
16445 ffesymbol_signal_unreported (s);
16446
16447 if (((ffesymbol_basictype (sp) != FFEINFO_basictypeINTEGER)
16448 && (ffesymbol_basictype (sp) != FFEINFO_basictypeANY))
16449 || ((ffesymbol_kindtype (sp) != FFEINFO_kindtypeINTEGERDEFAULT)
16450 && (ffesymbol_kindtype (sp) != FFEINFO_kindtypeANY)))
16451 ffesymbol_error (s, t);
16452
16453 return s;
16454 }
16455
16456 /* Have FOO in CALL FOO. Local name space, executable context only. */
16457
16458 static ffesymbol
16459 ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t)
16460 {
16461 ffesymbolAttrs sa;
16462 ffesymbolAttrs na;
16463 ffeinfoKind kind;
16464 ffeinfoWhere where;
16465 ffeintrinGen gen;
16466 ffeintrinSpec spec;
16467 ffeintrinImp imp;
16468 bool error = FALSE;
16469
16470 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16471 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16472
16473 na = sa = ffesymbol_attrs (s);
16474
16475 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16476 | FFESYMBOL_attrsADJUSTABLE
16477 | FFESYMBOL_attrsANYLEN
16478 | FFESYMBOL_attrsARRAY
16479 | FFESYMBOL_attrsDUMMY
16480 | FFESYMBOL_attrsEXTERNAL
16481 | FFESYMBOL_attrsSFARG
16482 | FFESYMBOL_attrsTYPE)));
16483
16484 kind = ffesymbol_kind (s);
16485 where = ffesymbol_where (s);
16486
16487 /* Figure out what kind of object we've got based on previous declarations
16488 of or references to the object. */
16489
16490 if (sa & FFESYMBOL_attrsEXTERNAL)
16491 {
16492 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16493 | FFESYMBOL_attrsDUMMY
16494 | FFESYMBOL_attrsEXTERNAL
16495 | FFESYMBOL_attrsTYPE)));
16496
16497 if (sa & FFESYMBOL_attrsTYPE)
16498 error = TRUE;
16499 else
16500 /* Not TYPE. */
16501 {
16502 kind = FFEINFO_kindSUBROUTINE;
16503
16504 if (sa & FFESYMBOL_attrsDUMMY)
16505 ; /* Not TYPE. */
16506 else if (sa & FFESYMBOL_attrsACTUALARG)
16507 ; /* Not DUMMY or TYPE. */
16508 else /* Not ACTUALARG, DUMMY, or TYPE. */
16509 where = FFEINFO_whereGLOBAL;
16510 }
16511 }
16512 else if (sa & FFESYMBOL_attrsDUMMY)
16513 {
16514 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16515 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16516 | FFESYMBOL_attrsEXTERNAL
16517 | FFESYMBOL_attrsTYPE)));
16518
16519 if (sa & FFESYMBOL_attrsTYPE)
16520 error = TRUE;
16521 else
16522 kind = FFEINFO_kindSUBROUTINE;
16523 }
16524 else if (sa & FFESYMBOL_attrsARRAY)
16525 {
16526 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16527 | FFESYMBOL_attrsADJUSTABLE
16528 | FFESYMBOL_attrsTYPE)));
16529
16530 error = TRUE;
16531 }
16532 else if (sa & FFESYMBOL_attrsSFARG)
16533 {
16534 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16535 | FFESYMBOL_attrsTYPE)));
16536
16537 error = TRUE;
16538 }
16539 else if (sa & FFESYMBOL_attrsTYPE)
16540 {
16541 assert (!(sa & (FFESYMBOL_attrsARRAY
16542 | FFESYMBOL_attrsDUMMY
16543 | FFESYMBOL_attrsEXTERNAL
16544 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16545 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16546 | FFESYMBOL_attrsADJUSTABLE
16547 | FFESYMBOL_attrsANYLEN
16548 | FFESYMBOL_attrsARRAY
16549 | FFESYMBOL_attrsDUMMY
16550 | FFESYMBOL_attrsEXTERNAL
16551 | FFESYMBOL_attrsSFARG)));
16552
16553 error = TRUE;
16554 }
16555 else if (sa == FFESYMBOL_attrsetNONE)
16556 {
16557 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16558
16559 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
16560 &gen, &spec, &imp))
16561 {
16562 ffesymbol_signal_change (s); /* May need to back up to previous
16563 version. */
16564 ffesymbol_set_generic (s, gen);
16565 ffesymbol_set_specific (s, spec);
16566 ffesymbol_set_implementation (s, imp);
16567 ffesymbol_set_info (s,
16568 ffeinfo_new (FFEINFO_basictypeNONE,
16569 FFEINFO_kindtypeNONE,
16570 0,
16571 FFEINFO_kindSUBROUTINE,
16572 FFEINFO_whereINTRINSIC,
16573 FFETARGET_charactersizeNONE));
16574 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16575 ffesymbol_resolve_intrin (s);
16576 ffesymbol_reference (s, t, FALSE);
16577 s = ffecom_sym_learned (s);
16578 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16579
16580 return s;
16581 }
16582
16583 kind = FFEINFO_kindSUBROUTINE;
16584 where = FFEINFO_whereGLOBAL;
16585 }
16586 else
16587 error = TRUE;
16588
16589 /* Now see what we've got for a new object: NONE means a new error cropped
16590 up; ANY means an old error to be ignored; otherwise, everything's ok,
16591 update the object (symbol) and continue on. */
16592
16593 if (error)
16594 ffesymbol_error (s, t);
16595 else if (!(na & FFESYMBOL_attrsANY))
16596 {
16597 ffesymbol_signal_change (s); /* May need to back up to previous
16598 version. */
16599 ffesymbol_set_info (s,
16600 ffeinfo_new (ffesymbol_basictype (s),
16601 ffesymbol_kindtype (s),
16602 ffesymbol_rank (s),
16603 kind, /* SUBROUTINE. */
16604 where, /* GLOBAL or DUMMY. */
16605 ffesymbol_size (s)));
16606 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16607 ffesymbol_resolve_intrin (s);
16608 ffesymbol_reference (s, t, FALSE);
16609 s = ffecom_sym_learned (s);
16610 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16611 }
16612
16613 return s;
16614 }
16615
16616 /* Have FOO in DATA FOO/.../. Local name space and executable context
16617 only. (This will change in the future when DATA FOO may be followed
16618 by COMMON FOO or even INTEGER FOO(10), etc.) */
16619
16620 static ffesymbol
16621 ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t)
16622 {
16623 ffesymbolAttrs sa;
16624 ffesymbolAttrs na;
16625 ffeinfoKind kind;
16626 ffeinfoWhere where;
16627 bool error = FALSE;
16628
16629 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16630 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16631
16632 na = sa = ffesymbol_attrs (s);
16633
16634 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16635 | FFESYMBOL_attrsADJUSTABLE
16636 | FFESYMBOL_attrsANYLEN
16637 | FFESYMBOL_attrsARRAY
16638 | FFESYMBOL_attrsDUMMY
16639 | FFESYMBOL_attrsEXTERNAL
16640 | FFESYMBOL_attrsSFARG
16641 | FFESYMBOL_attrsTYPE)));
16642
16643 kind = ffesymbol_kind (s);
16644 where = ffesymbol_where (s);
16645
16646 /* Figure out what kind of object we've got based on previous declarations
16647 of or references to the object. */
16648
16649 if (sa & FFESYMBOL_attrsEXTERNAL)
16650 {
16651 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16652 | FFESYMBOL_attrsDUMMY
16653 | FFESYMBOL_attrsEXTERNAL
16654 | FFESYMBOL_attrsTYPE)));
16655
16656 error = TRUE;
16657 }
16658 else if (sa & FFESYMBOL_attrsDUMMY)
16659 {
16660 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16661 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16662 | FFESYMBOL_attrsEXTERNAL
16663 | FFESYMBOL_attrsTYPE)));
16664
16665 error = TRUE;
16666 }
16667 else if (sa & FFESYMBOL_attrsARRAY)
16668 {
16669 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16670 | FFESYMBOL_attrsADJUSTABLE
16671 | FFESYMBOL_attrsTYPE)));
16672
16673 if (sa & FFESYMBOL_attrsADJUSTABLE)
16674 error = TRUE;
16675 where = FFEINFO_whereLOCAL;
16676 }
16677 else if (sa & FFESYMBOL_attrsSFARG)
16678 {
16679 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16680 | FFESYMBOL_attrsTYPE)));
16681
16682 where = FFEINFO_whereLOCAL;
16683 }
16684 else if (sa & FFESYMBOL_attrsTYPE)
16685 {
16686 assert (!(sa & (FFESYMBOL_attrsARRAY
16687 | FFESYMBOL_attrsDUMMY
16688 | FFESYMBOL_attrsEXTERNAL
16689 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16690 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16691 | FFESYMBOL_attrsADJUSTABLE
16692 | FFESYMBOL_attrsANYLEN
16693 | FFESYMBOL_attrsARRAY
16694 | FFESYMBOL_attrsDUMMY
16695 | FFESYMBOL_attrsEXTERNAL
16696 | FFESYMBOL_attrsSFARG)));
16697
16698 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16699 error = TRUE;
16700 else
16701 {
16702 kind = FFEINFO_kindENTITY;
16703 where = FFEINFO_whereLOCAL;
16704 }
16705 }
16706 else if (sa == FFESYMBOL_attrsetNONE)
16707 {
16708 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16709 kind = FFEINFO_kindENTITY;
16710 where = FFEINFO_whereLOCAL;
16711 }
16712 else
16713 error = TRUE;
16714
16715 /* Now see what we've got for a new object: NONE means a new error cropped
16716 up; ANY means an old error to be ignored; otherwise, everything's ok,
16717 update the object (symbol) and continue on. */
16718
16719 if (error)
16720 ffesymbol_error (s, t);
16721 else if (!(na & FFESYMBOL_attrsANY))
16722 {
16723 ffesymbol_signal_change (s); /* May need to back up to previous
16724 version. */
16725 if (!ffeimplic_establish_symbol (s))
16726 {
16727 ffesymbol_error (s, t);
16728 return s;
16729 }
16730 ffesymbol_set_info (s,
16731 ffeinfo_new (ffesymbol_basictype (s),
16732 ffesymbol_kindtype (s),
16733 ffesymbol_rank (s),
16734 kind, /* ENTITY. */
16735 where, /* LOCAL. */
16736 ffesymbol_size (s)));
16737 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16738 ffesymbol_resolve_intrin (s);
16739 s = ffecom_sym_learned (s);
16740 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16741 }
16742
16743 return s;
16744 }
16745
16746 /* Have FOO in EQUIVALENCE (...,FOO,...). Does not include
16747 EQUIVALENCE (...,BAR(FOO),...). */
16748
16749 static ffesymbol
16750 ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t)
16751 {
16752 ffesymbolAttrs sa;
16753 ffesymbolAttrs na;
16754 ffeinfoKind kind;
16755 ffeinfoWhere where;
16756
16757 na = sa = ffesymbol_attrs (s);
16758 kind = FFEINFO_kindENTITY;
16759 where = ffesymbol_where (s);
16760
16761 /* Figure out what kind of object we've got based on previous declarations
16762 of or references to the object. */
16763
16764 if (!(sa & ~(FFESYMBOL_attrsADJUSTS
16765 | FFESYMBOL_attrsARRAY
16766 | FFESYMBOL_attrsCOMMON
16767 | FFESYMBOL_attrsEQUIV
16768 | FFESYMBOL_attrsINIT
16769 | FFESYMBOL_attrsNAMELIST
16770 | FFESYMBOL_attrsSAVE
16771 | FFESYMBOL_attrsSFARG
16772 | FFESYMBOL_attrsTYPE)))
16773 na = sa | FFESYMBOL_attrsEQUIV;
16774 else
16775 na = FFESYMBOL_attrsetNONE;
16776
16777 /* Don't know why we're bothering to set kind and where in this code, but
16778 added the following to make it complete, in case it's really important.
16779 Generally this is left up to symbol exec transition. */
16780
16781 if (where == FFEINFO_whereNONE)
16782 {
16783 if (na & (FFESYMBOL_attrsADJUSTS
16784 | FFESYMBOL_attrsCOMMON))
16785 where = FFEINFO_whereCOMMON;
16786 else if (na & FFESYMBOL_attrsSAVE)
16787 where = FFEINFO_whereLOCAL;
16788 }
16789
16790 /* Now see what we've got for a new object: NONE means a new error cropped
16791 up; ANY means an old error to be ignored; otherwise, everything's ok,
16792 update the object (symbol) and continue on. */
16793
16794 if (na == FFESYMBOL_attrsetNONE)
16795 ffesymbol_error (s, t);
16796 else if (!(na & FFESYMBOL_attrsANY))
16797 {
16798 ffesymbol_signal_change (s); /* May need to back up to previous
16799 version. */
16800 ffesymbol_set_info (s,
16801 ffeinfo_new (ffesymbol_basictype (s),
16802 ffesymbol_kindtype (s),
16803 ffesymbol_rank (s),
16804 kind, /* Always ENTITY. */
16805 where, /* NONE, COMMON, or LOCAL. */
16806 ffesymbol_size (s)));
16807 ffesymbol_set_attrs (s, na);
16808 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
16809 ffesymbol_resolve_intrin (s);
16810 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16811 }
16812
16813 return s;
16814 }
16815
16816 /* Have FOO in OPEN(...,USEROPEN=FOO,...). Executable context only.
16817
16818 Note that I think this should be considered semantically similar to
16819 doing CALL XYZ(FOO), in that it should be considered like an
16820 ACTUALARG context. In particular, without EXTERNAL being specified,
16821 it should not be allowed. */
16822
16823 static ffesymbol
16824 ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t)
16825 {
16826 ffesymbolAttrs sa;
16827 ffesymbolAttrs na;
16828 ffeinfoKind kind;
16829 ffeinfoWhere where;
16830 bool needs_type = FALSE;
16831 bool error = FALSE;
16832
16833 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16834 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16835
16836 na = sa = ffesymbol_attrs (s);
16837
16838 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16839 | FFESYMBOL_attrsADJUSTABLE
16840 | FFESYMBOL_attrsANYLEN
16841 | FFESYMBOL_attrsARRAY
16842 | FFESYMBOL_attrsDUMMY
16843 | FFESYMBOL_attrsEXTERNAL
16844 | FFESYMBOL_attrsSFARG
16845 | FFESYMBOL_attrsTYPE)));
16846
16847 kind = ffesymbol_kind (s);
16848 where = ffesymbol_where (s);
16849
16850 /* Figure out what kind of object we've got based on previous declarations
16851 of or references to the object. */
16852
16853 if (sa & FFESYMBOL_attrsEXTERNAL)
16854 {
16855 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16856 | FFESYMBOL_attrsDUMMY
16857 | FFESYMBOL_attrsEXTERNAL
16858 | FFESYMBOL_attrsTYPE)));
16859
16860 if (sa & FFESYMBOL_attrsTYPE)
16861 where = FFEINFO_whereGLOBAL;
16862 else
16863 /* Not TYPE. */
16864 {
16865 kind = FFEINFO_kindFUNCTION;
16866 needs_type = TRUE;
16867
16868 if (sa & FFESYMBOL_attrsDUMMY)
16869 ; /* Not TYPE. */
16870 else if (sa & FFESYMBOL_attrsACTUALARG)
16871 ; /* Not DUMMY or TYPE. */
16872 else /* Not ACTUALARG, DUMMY, or TYPE. */
16873 where = FFEINFO_whereGLOBAL;
16874 }
16875 }
16876 else if (sa & FFESYMBOL_attrsDUMMY)
16877 {
16878 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16879 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16880 | FFESYMBOL_attrsEXTERNAL
16881 | FFESYMBOL_attrsTYPE)));
16882
16883 kind = FFEINFO_kindFUNCTION;
16884 if (!(sa & FFESYMBOL_attrsTYPE))
16885 needs_type = TRUE;
16886 }
16887 else if (sa & FFESYMBOL_attrsARRAY)
16888 {
16889 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16890 | FFESYMBOL_attrsADJUSTABLE
16891 | FFESYMBOL_attrsTYPE)));
16892
16893 error = TRUE;
16894 }
16895 else if (sa & FFESYMBOL_attrsSFARG)
16896 {
16897 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16898 | FFESYMBOL_attrsTYPE)));
16899
16900 error = TRUE;
16901 }
16902 else if (sa & FFESYMBOL_attrsTYPE)
16903 {
16904 assert (!(sa & (FFESYMBOL_attrsARRAY
16905 | FFESYMBOL_attrsDUMMY
16906 | FFESYMBOL_attrsEXTERNAL
16907 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16908 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16909 | FFESYMBOL_attrsADJUSTABLE
16910 | FFESYMBOL_attrsANYLEN
16911 | FFESYMBOL_attrsARRAY
16912 | FFESYMBOL_attrsDUMMY
16913 | FFESYMBOL_attrsEXTERNAL
16914 | FFESYMBOL_attrsSFARG)));
16915
16916 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16917 error = TRUE;
16918 else
16919 {
16920 kind = FFEINFO_kindFUNCTION;
16921 where = FFEINFO_whereGLOBAL;
16922 }
16923 }
16924 else if (sa == FFESYMBOL_attrsetNONE)
16925 {
16926 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16927 kind = FFEINFO_kindFUNCTION;
16928 where = FFEINFO_whereGLOBAL;
16929 needs_type = TRUE;
16930 }
16931 else
16932 error = TRUE;
16933
16934 /* Now see what we've got for a new object: NONE means a new error cropped
16935 up; ANY means an old error to be ignored; otherwise, everything's ok,
16936 update the object (symbol) and continue on. */
16937
16938 if (error)
16939 ffesymbol_error (s, t);
16940 else if (!(na & FFESYMBOL_attrsANY))
16941 {
16942 ffesymbol_signal_change (s); /* May need to back up to previous
16943 version. */
16944 if (needs_type && !ffeimplic_establish_symbol (s))
16945 {
16946 ffesymbol_error (s, t);
16947 return s;
16948 }
16949 if (!ffesymbol_explicitwhere (s))
16950 {
16951 ffebad_start (FFEBAD_NEED_EXTERNAL);
16952 ffebad_here (0, ffelex_token_where_line (t),
16953 ffelex_token_where_column (t));
16954 ffebad_string (ffesymbol_text (s));
16955 ffebad_finish ();
16956 ffesymbol_set_explicitwhere (s, TRUE);
16957 }
16958 ffesymbol_set_info (s,
16959 ffeinfo_new (ffesymbol_basictype (s),
16960 ffesymbol_kindtype (s),
16961 ffesymbol_rank (s),
16962 kind, /* FUNCTION. */
16963 where, /* GLOBAL or DUMMY. */
16964 ffesymbol_size (s)));
16965 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16966 ffesymbol_resolve_intrin (s);
16967 ffesymbol_reference (s, t, FALSE);
16968 s = ffecom_sym_learned (s);
16969 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16970 }
16971
16972 return s;
16973 }
16974
16975 /* Have FOO in DATA (stuff,FOO=1,10)/.../. */
16976
16977 static ffesymbol
16978 ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t)
16979 {
16980 ffesymbolState ss;
16981
16982 /* If the symbol isn't in the sfunc name space, pretend as though we saw a
16983 reference to it already within the imp-DO construct at this level, so as
16984 to get a symbol that is in the sfunc name space. But this is an
16985 erroneous construct, and should be caught elsewhere. */
16986
16987 if (ffesymbol_sfdummyparent (s) == NULL)
16988 {
16989 s = ffeexpr_sym_impdoitem_ (s, t);
16990 if (ffesymbol_sfdummyparent (s) == NULL)
16991 { /* PARAMETER FOO...DATA (A(I),FOO=...). */
16992 ffesymbol_error (s, t);
16993 return s;
16994 }
16995 }
16996
16997 ss = ffesymbol_state (s);
16998
16999 switch (ss)
17000 {
17001 case FFESYMBOL_stateNONE: /* Used as iterator already. */
17002 if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
17003 ffesymbol_error (s, t); /* Can't reuse dead iterator. F90 disallows
17004 this; F77 allows it but it is a stupid
17005 feature. */
17006 else
17007 { /* Can use dead iterator because we're at at
17008 least a innermore (higher-numbered) level
17009 than the iterator's outermost
17010 (lowest-numbered) level. This should be
17011 diagnosed later, because it means an item
17012 in this list didn't reference this
17013 iterator. */
17014 #if 1
17015 ffesymbol_error (s, t); /* For now, complain. */
17016 #else /* Someday will detect all cases where initializer doesn't reference
17017 all applicable iterators, in which case reenable this code. */
17018 ffesymbol_signal_change (s);
17019 ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
17020 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
17021 ffesymbol_signal_unreported (s);
17022 #endif
17023 }
17024 break;
17025
17026 case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO.
17027 If seen in outermore level, can't be an
17028 iterator here, so complain. If not seen
17029 at current level, complain for now,
17030 because that indicates something F90
17031 rejects (though we currently don't detect
17032 all such cases for now). */
17033 if (ffeexpr_level_ <= ffesymbol_maxentrynum (s))
17034 {
17035 ffesymbol_signal_change (s);
17036 ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
17037 ffesymbol_signal_unreported (s);
17038 }
17039 else
17040 ffesymbol_error (s, t);
17041 break;
17042
17043 case FFESYMBOL_stateUNCERTAIN: /* Already iterator! */
17044 assert ("DATA implied-DO control var seen twice!!" == NULL);
17045 ffesymbol_error (s, t);
17046 break;
17047
17048 case FFESYMBOL_stateUNDERSTOOD:
17049 break; /* ANY. */
17050
17051 default:
17052 assert ("Foo Bletch!!" == NULL);
17053 break;
17054 }
17055
17056 return s;
17057 }
17058
17059 /* Have FOO in PARAMETER (FOO=...). */
17060
17061 static ffesymbol
17062 ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t)
17063 {
17064 ffesymbolAttrs sa;
17065
17066 sa = ffesymbol_attrs (s);
17067
17068 /* Figure out what kind of object we've got based on previous declarations
17069 of or references to the object. */
17070
17071 if (sa & ~(FFESYMBOL_attrsANYLEN
17072 | FFESYMBOL_attrsTYPE))
17073 {
17074 if (!(sa & FFESYMBOL_attrsANY))
17075 ffesymbol_error (s, t);
17076 }
17077 else
17078 {
17079 ffesymbol_signal_change (s); /* May need to back up to previous
17080 version. */
17081 if (!ffeimplic_establish_symbol (s))
17082 {
17083 ffesymbol_error (s, t);
17084 return s;
17085 }
17086 ffesymbol_set_info (s,
17087 ffeinfo_new (ffesymbol_basictype (s),
17088 ffesymbol_kindtype (s),
17089 ffesymbol_rank (s),
17090 FFEINFO_kindENTITY,
17091 FFEINFO_whereCONSTANT,
17092 ffesymbol_size (s)));
17093 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17094 ffesymbol_resolve_intrin (s);
17095 s = ffecom_sym_learned (s);
17096 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17097 }
17098
17099 return s;
17100 }
17101
17102 /* Have FOO in CALL XYZ(...,FOO,...). Does not include any other
17103 embedding of FOO, such as CALL XYZ((FOO)) or CALL XYZ(FOO+1). */
17104
17105 static ffesymbol
17106 ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t)
17107 {
17108 ffesymbolAttrs sa;
17109 ffesymbolAttrs na;
17110 ffeinfoKind kind;
17111 ffeinfoWhere where;
17112 ffesymbolState ns;
17113 bool needs_type = FALSE;
17114
17115 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
17116 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
17117
17118 na = sa = ffesymbol_attrs (s);
17119
17120 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17121 | FFESYMBOL_attrsADJUSTABLE
17122 | FFESYMBOL_attrsANYLEN
17123 | FFESYMBOL_attrsARRAY
17124 | FFESYMBOL_attrsDUMMY
17125 | FFESYMBOL_attrsEXTERNAL
17126 | FFESYMBOL_attrsSFARG
17127 | FFESYMBOL_attrsTYPE)));
17128
17129 kind = ffesymbol_kind (s);
17130 where = ffesymbol_where (s);
17131
17132 /* Figure out what kind of object we've got based on previous declarations
17133 of or references to the object. */
17134
17135 ns = FFESYMBOL_stateUNDERSTOOD;
17136
17137 if (sa & FFESYMBOL_attrsEXTERNAL)
17138 {
17139 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17140 | FFESYMBOL_attrsDUMMY
17141 | FFESYMBOL_attrsEXTERNAL
17142 | FFESYMBOL_attrsTYPE)));
17143
17144 if (sa & FFESYMBOL_attrsTYPE)
17145 where = FFEINFO_whereGLOBAL;
17146 else
17147 /* Not TYPE. */
17148 {
17149 ns = FFESYMBOL_stateUNCERTAIN;
17150
17151 if (sa & FFESYMBOL_attrsDUMMY)
17152 assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */
17153 else if (sa & FFESYMBOL_attrsACTUALARG)
17154 ; /* Not DUMMY or TYPE. */
17155 else
17156 /* Not ACTUALARG, DUMMY, or TYPE. */
17157 {
17158 assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */
17159 na |= FFESYMBOL_attrsACTUALARG;
17160 where = FFEINFO_whereGLOBAL;
17161 }
17162 }
17163 }
17164 else if (sa & FFESYMBOL_attrsDUMMY)
17165 {
17166 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
17167 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
17168 | FFESYMBOL_attrsEXTERNAL
17169 | FFESYMBOL_attrsTYPE)));
17170
17171 kind = FFEINFO_kindENTITY;
17172 if (!(sa & FFESYMBOL_attrsTYPE))
17173 needs_type = TRUE;
17174 }
17175 else if (sa & FFESYMBOL_attrsARRAY)
17176 {
17177 assert (!(sa & ~(FFESYMBOL_attrsARRAY
17178 | FFESYMBOL_attrsADJUSTABLE
17179 | FFESYMBOL_attrsTYPE)));
17180
17181 where = FFEINFO_whereLOCAL;
17182 }
17183 else if (sa & FFESYMBOL_attrsSFARG)
17184 {
17185 assert (!(sa & ~(FFESYMBOL_attrsSFARG
17186 | FFESYMBOL_attrsTYPE)));
17187
17188 where = FFEINFO_whereLOCAL;
17189 }
17190 else if (sa & FFESYMBOL_attrsTYPE)
17191 {
17192 assert (!(sa & (FFESYMBOL_attrsARRAY
17193 | FFESYMBOL_attrsDUMMY
17194 | FFESYMBOL_attrsEXTERNAL
17195 | FFESYMBOL_attrsSFARG))); /* Handled above. */
17196 assert (!(sa & ~(FFESYMBOL_attrsTYPE
17197 | FFESYMBOL_attrsADJUSTABLE
17198 | FFESYMBOL_attrsANYLEN
17199 | FFESYMBOL_attrsARRAY
17200 | FFESYMBOL_attrsDUMMY
17201 | FFESYMBOL_attrsEXTERNAL
17202 | FFESYMBOL_attrsSFARG)));
17203
17204 if (sa & FFESYMBOL_attrsANYLEN)
17205 ns = FFESYMBOL_stateNONE;
17206 else
17207 {
17208 kind = FFEINFO_kindENTITY;
17209 where = FFEINFO_whereLOCAL;
17210 }
17211 }
17212 else if (sa == FFESYMBOL_attrsetNONE)
17213 {
17214 /* New state is left empty because there isn't any state flag to
17215 set for this case, and it's UNDERSTOOD after all. */
17216 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
17217 kind = FFEINFO_kindENTITY;
17218 where = FFEINFO_whereLOCAL;
17219 needs_type = TRUE;
17220 }
17221 else
17222 ns = FFESYMBOL_stateNONE; /* Error. */
17223
17224 /* Now see what we've got for a new object: NONE means a new error cropped
17225 up; ANY means an old error to be ignored; otherwise, everything's ok,
17226 update the object (symbol) and continue on. */
17227
17228 if (ns == FFESYMBOL_stateNONE)
17229 ffesymbol_error (s, t);
17230 else if (!(na & FFESYMBOL_attrsANY))
17231 {
17232 ffesymbol_signal_change (s); /* May need to back up to previous
17233 version. */
17234 if (needs_type && !ffeimplic_establish_symbol (s))
17235 {
17236 ffesymbol_error (s, t);
17237 return s;
17238 }
17239 ffesymbol_set_info (s,
17240 ffeinfo_new (ffesymbol_basictype (s),
17241 ffesymbol_kindtype (s),
17242 ffesymbol_rank (s),
17243 kind,
17244 where,
17245 ffesymbol_size (s)));
17246 ffesymbol_set_attrs (s, na);
17247 ffesymbol_set_state (s, ns);
17248 s = ffecom_sym_learned (s);
17249 ffesymbol_reference (s, t, FALSE);
17250 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17251 }
17252
17253 return s;
17254 }
17255
17256 /* Have FOO in DIMENSION XYZ(FOO) or any array declarator containing
17257 a reference to FOO. */
17258
17259 static ffesymbol
17260 ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t)
17261 {
17262 ffesymbolAttrs sa;
17263 ffesymbolAttrs na;
17264 ffeinfoKind kind;
17265 ffeinfoWhere where;
17266
17267 na = sa = ffesymbol_attrs (s);
17268 kind = FFEINFO_kindENTITY;
17269 where = ffesymbol_where (s);
17270
17271 /* Figure out what kind of object we've got based on previous declarations
17272 of or references to the object. */
17273
17274 if (!(sa & ~(FFESYMBOL_attrsADJUSTS
17275 | FFESYMBOL_attrsCOMMON
17276 | FFESYMBOL_attrsDUMMY
17277 | FFESYMBOL_attrsEQUIV
17278 | FFESYMBOL_attrsINIT
17279 | FFESYMBOL_attrsNAMELIST
17280 | FFESYMBOL_attrsSFARG
17281 | FFESYMBOL_attrsTYPE)))
17282 na = sa | FFESYMBOL_attrsADJUSTS;
17283 else
17284 na = FFESYMBOL_attrsetNONE;
17285
17286 /* Since this symbol definitely is going into an expression (the
17287 dimension-list for some dummy array, presumably), figure out WHERE if
17288 possible. */
17289
17290 if (where == FFEINFO_whereNONE)
17291 {
17292 if (na & (FFESYMBOL_attrsCOMMON
17293 | FFESYMBOL_attrsEQUIV
17294 | FFESYMBOL_attrsINIT
17295 | FFESYMBOL_attrsNAMELIST))
17296 where = FFEINFO_whereCOMMON;
17297 else if (na & FFESYMBOL_attrsDUMMY)
17298 where = FFEINFO_whereDUMMY;
17299 }
17300
17301 /* Now see what we've got for a new object: NONE means a new error cropped
17302 up; ANY means an old error to be ignored; otherwise, everything's ok,
17303 update the object (symbol) and continue on. */
17304
17305 if (na == FFESYMBOL_attrsetNONE)
17306 ffesymbol_error (s, t);
17307 else if (!(na & FFESYMBOL_attrsANY))
17308 {
17309 ffesymbol_signal_change (s); /* May need to back up to previous
17310 version. */
17311 if (!ffeimplic_establish_symbol (s))
17312 {
17313 ffesymbol_error (s, t);
17314 return s;
17315 }
17316 ffesymbol_set_info (s,
17317 ffeinfo_new (ffesymbol_basictype (s),
17318 ffesymbol_kindtype (s),
17319 ffesymbol_rank (s),
17320 kind, /* Always ENTITY. */
17321 where, /* NONE, COMMON, or DUMMY. */
17322 ffesymbol_size (s)));
17323 ffesymbol_set_attrs (s, na);
17324 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
17325 ffesymbol_resolve_intrin (s);
17326 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17327 }
17328
17329 return s;
17330 }
17331
17332 /* Have FOO in XYZ = ...FOO.... Does not include cases like FOO in
17333 XYZ = BAR(FOO), as such cases are handled elsewhere. */
17334
17335 static ffesymbol
17336 ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t)
17337 {
17338 ffesymbolAttrs sa;
17339 ffesymbolAttrs na;
17340 ffeinfoKind kind;
17341 ffeinfoWhere where;
17342 bool error = FALSE;
17343
17344 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
17345 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
17346
17347 na = sa = ffesymbol_attrs (s);
17348
17349 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17350 | FFESYMBOL_attrsADJUSTABLE
17351 | FFESYMBOL_attrsANYLEN
17352 | FFESYMBOL_attrsARRAY
17353 | FFESYMBOL_attrsDUMMY
17354 | FFESYMBOL_attrsEXTERNAL
17355 | FFESYMBOL_attrsSFARG
17356 | FFESYMBOL_attrsTYPE)));
17357
17358 kind = ffesymbol_kind (s);
17359 where = ffesymbol_where (s);
17360
17361 /* Figure out what kind of object we've got based on previous declarations
17362 of or references to the object. */
17363
17364 if (sa & FFESYMBOL_attrsEXTERNAL)
17365 {
17366 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17367 | FFESYMBOL_attrsDUMMY
17368 | FFESYMBOL_attrsEXTERNAL
17369 | FFESYMBOL_attrsTYPE)));
17370
17371 error = TRUE;
17372 }
17373 else if (sa & FFESYMBOL_attrsDUMMY)
17374 {
17375 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
17376 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
17377 | FFESYMBOL_attrsEXTERNAL
17378 | FFESYMBOL_attrsTYPE)));
17379
17380 kind = FFEINFO_kindENTITY;
17381 }
17382 else if (sa & FFESYMBOL_attrsARRAY)
17383 {
17384 assert (!(sa & ~(FFESYMBOL_attrsARRAY
17385 | FFESYMBOL_attrsADJUSTABLE
17386 | FFESYMBOL_attrsTYPE)));
17387
17388 where = FFEINFO_whereLOCAL;
17389 }
17390 else if (sa & FFESYMBOL_attrsSFARG)
17391 {
17392 assert (!(sa & ~(FFESYMBOL_attrsSFARG
17393 | FFESYMBOL_attrsTYPE)));
17394
17395 where = FFEINFO_whereLOCAL;
17396 }
17397 else if (sa & FFESYMBOL_attrsTYPE)
17398 {
17399 assert (!(sa & (FFESYMBOL_attrsARRAY
17400 | FFESYMBOL_attrsDUMMY
17401 | FFESYMBOL_attrsEXTERNAL
17402 | FFESYMBOL_attrsSFARG))); /* Handled above. */
17403 assert (!(sa & ~(FFESYMBOL_attrsTYPE
17404 | FFESYMBOL_attrsADJUSTABLE
17405 | FFESYMBOL_attrsANYLEN
17406 | FFESYMBOL_attrsARRAY
17407 | FFESYMBOL_attrsDUMMY
17408 | FFESYMBOL_attrsEXTERNAL
17409 | FFESYMBOL_attrsSFARG)));
17410
17411 if (sa & FFESYMBOL_attrsANYLEN)
17412 error = TRUE;
17413 else
17414 {
17415 kind = FFEINFO_kindENTITY;
17416 where = FFEINFO_whereLOCAL;
17417 }
17418 }
17419 else if (sa == FFESYMBOL_attrsetNONE)
17420 {
17421 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
17422 kind = FFEINFO_kindENTITY;
17423 where = FFEINFO_whereLOCAL;
17424 }
17425 else
17426 error = TRUE;
17427
17428 /* Now see what we've got for a new object: NONE means a new error cropped
17429 up; ANY means an old error to be ignored; otherwise, everything's ok,
17430 update the object (symbol) and continue on. */
17431
17432 if (error)
17433 ffesymbol_error (s, t);
17434 else if (!(na & FFESYMBOL_attrsANY))
17435 {
17436 ffesymbol_signal_change (s); /* May need to back up to previous
17437 version. */
17438 if (!ffeimplic_establish_symbol (s))
17439 {
17440 ffesymbol_error (s, t);
17441 return s;
17442 }
17443 ffesymbol_set_info (s,
17444 ffeinfo_new (ffesymbol_basictype (s),
17445 ffesymbol_kindtype (s),
17446 ffesymbol_rank (s),
17447 kind, /* ENTITY. */
17448 where, /* LOCAL. */
17449 ffesymbol_size (s)));
17450 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17451 ffesymbol_resolve_intrin (s);
17452 s = ffecom_sym_learned (s);
17453 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17454 }
17455
17456 return s;
17457 }
17458
17459 /* ffeexpr_declare_parenthesized_ -- ffesymbol wrapper for NAME(...) operand
17460
17461 ffelexToken t;
17462 bool maybe_intrin;
17463 ffeexprParenType_ paren_type;
17464 ffesymbol s;
17465 s = ffeexpr_declare_parenthesized_ (t, maybe_intrin, &paren_type);
17466
17467 Just like ffesymbol_declare_local, except performs any implicit info
17468 assignment necessary, and it returns the type of the parenthesized list
17469 (list of function args, list of array args, or substring spec). */
17470
17471 static ffesymbol
17472 ffeexpr_declare_parenthesized_ (ffelexToken t, bool maybe_intrin,
17473 ffeexprParenType_ *paren_type)
17474 {
17475 ffesymbol s;
17476 ffesymbolState st; /* Effective state. */
17477 ffeinfoKind k;
17478 bool bad;
17479
17480 if (maybe_intrin && ffesrc_check_symbol ())
17481 { /* Knock off some easy cases. */
17482 switch (ffeexpr_stack_->context)
17483 {
17484 case FFEEXPR_contextSUBROUTINEREF:
17485 case FFEEXPR_contextDATA:
17486 case FFEEXPR_contextDATAIMPDOINDEX_:
17487 case FFEEXPR_contextSFUNCDEF:
17488 case FFEEXPR_contextSFUNCDEFINDEX_:
17489 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17490 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17491 case FFEEXPR_contextLET:
17492 case FFEEXPR_contextPAREN_:
17493 case FFEEXPR_contextACTUALARGEXPR_:
17494 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17495 case FFEEXPR_contextIOLIST:
17496 case FFEEXPR_contextIOLISTDF:
17497 case FFEEXPR_contextDO:
17498 case FFEEXPR_contextDOWHILE:
17499 case FFEEXPR_contextACTUALARG_:
17500 case FFEEXPR_contextCGOTO:
17501 case FFEEXPR_contextIF:
17502 case FFEEXPR_contextARITHIF:
17503 case FFEEXPR_contextFORMAT:
17504 case FFEEXPR_contextSTOP:
17505 case FFEEXPR_contextRETURN:
17506 case FFEEXPR_contextSELECTCASE:
17507 case FFEEXPR_contextCASE:
17508 case FFEEXPR_contextFILEASSOC:
17509 case FFEEXPR_contextFILEINT:
17510 case FFEEXPR_contextFILEDFINT:
17511 case FFEEXPR_contextFILELOG:
17512 case FFEEXPR_contextFILENUM:
17513 case FFEEXPR_contextFILENUMAMBIG:
17514 case FFEEXPR_contextFILECHAR:
17515 case FFEEXPR_contextFILENUMCHAR:
17516 case FFEEXPR_contextFILEDFCHAR:
17517 case FFEEXPR_contextFILEKEY:
17518 case FFEEXPR_contextFILEUNIT:
17519 case FFEEXPR_contextFILEUNIT_DF:
17520 case FFEEXPR_contextFILEUNITAMBIG:
17521 case FFEEXPR_contextFILEFORMAT:
17522 case FFEEXPR_contextFILENAMELIST:
17523 case FFEEXPR_contextFILEVXTCODE:
17524 case FFEEXPR_contextINDEX_:
17525 case FFEEXPR_contextIMPDOITEM_:
17526 case FFEEXPR_contextIMPDOITEMDF_:
17527 case FFEEXPR_contextIMPDOCTRL_:
17528 case FFEEXPR_contextDATAIMPDOCTRL_:
17529 case FFEEXPR_contextCHARACTERSIZE:
17530 case FFEEXPR_contextPARAMETER:
17531 case FFEEXPR_contextDIMLIST:
17532 case FFEEXPR_contextDIMLISTCOMMON:
17533 case FFEEXPR_contextKINDTYPE:
17534 case FFEEXPR_contextINITVAL:
17535 case FFEEXPR_contextEQVINDEX_:
17536 break; /* These could be intrinsic invocations. */
17537
17538 case FFEEXPR_contextAGOTO:
17539 case FFEEXPR_contextFILEFORMATNML:
17540 case FFEEXPR_contextALLOCATE:
17541 case FFEEXPR_contextDEALLOCATE:
17542 case FFEEXPR_contextHEAPSTAT:
17543 case FFEEXPR_contextNULLIFY:
17544 case FFEEXPR_contextINCLUDE:
17545 case FFEEXPR_contextDATAIMPDOITEM_:
17546 case FFEEXPR_contextLOC_:
17547 case FFEEXPR_contextINDEXORACTUALARG_:
17548 case FFEEXPR_contextSFUNCDEFACTUALARG_:
17549 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
17550 case FFEEXPR_contextPARENFILENUM_:
17551 case FFEEXPR_contextPARENFILEUNIT_:
17552 maybe_intrin = FALSE;
17553 break; /* Can't be intrinsic invocation. */
17554
17555 default:
17556 assert ("blah! blah! waaauuggh!" == NULL);
17557 break;
17558 }
17559 }
17560
17561 s = ffesymbol_declare_local (t, maybe_intrin);
17562
17563 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17564 /* Special-case these since they can involve a different concept
17565 of "state" (in the stmtfunc name space). */
17566 {
17567 case FFEEXPR_contextDATAIMPDOINDEX_:
17568 case FFEEXPR_contextDATAIMPDOCTRL_:
17569 if (ffeexpr_context_outer_ (ffeexpr_stack_)
17570 == FFEEXPR_contextDATAIMPDOINDEX_)
17571 s = ffeexpr_sym_impdoitem_ (s, t);
17572 else
17573 if (ffeexpr_stack_->is_rhs)
17574 s = ffeexpr_sym_impdoitem_ (s, t);
17575 else
17576 s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
17577 if (ffesymbol_kind (s) != FFEINFO_kindANY)
17578 ffesymbol_error (s, t);
17579 return s;
17580
17581 default:
17582 break;
17583 }
17584
17585 switch ((ffesymbol_sfdummyparent (s) == NULL)
17586 ? ffesymbol_state (s)
17587 : FFESYMBOL_stateUNDERSTOOD)
17588 {
17589 case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr
17590 context. */
17591 if (!ffest_seen_first_exec ())
17592 goto seen; /* :::::::::::::::::::: */
17593 /* Fall through. */
17594 case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */
17595 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17596 {
17597 case FFEEXPR_contextSUBROUTINEREF:
17598 s = ffeexpr_sym_lhs_call_ (s, t); /* "CALL FOO"=="CALL
17599 FOO(...)". */
17600 break;
17601
17602 case FFEEXPR_contextDATA:
17603 if (ffeexpr_stack_->is_rhs)
17604 s = ffeexpr_sym_rhs_let_ (s, t);
17605 else
17606 s = ffeexpr_sym_lhs_data_ (s, t);
17607 break;
17608
17609 case FFEEXPR_contextDATAIMPDOITEM_:
17610 s = ffeexpr_sym_lhs_data_ (s, t);
17611 break;
17612
17613 case FFEEXPR_contextSFUNCDEF:
17614 case FFEEXPR_contextSFUNCDEFINDEX_:
17615 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17616 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17617 s = ffecom_sym_exec_transition (s);
17618 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17619 goto understood; /* :::::::::::::::::::: */
17620 /* Fall through. */
17621 case FFEEXPR_contextLET:
17622 case FFEEXPR_contextPAREN_:
17623 case FFEEXPR_contextACTUALARGEXPR_:
17624 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17625 case FFEEXPR_contextIOLIST:
17626 case FFEEXPR_contextIOLISTDF:
17627 case FFEEXPR_contextDO:
17628 case FFEEXPR_contextDOWHILE:
17629 case FFEEXPR_contextACTUALARG_:
17630 case FFEEXPR_contextCGOTO:
17631 case FFEEXPR_contextIF:
17632 case FFEEXPR_contextARITHIF:
17633 case FFEEXPR_contextFORMAT:
17634 case FFEEXPR_contextSTOP:
17635 case FFEEXPR_contextRETURN:
17636 case FFEEXPR_contextSELECTCASE:
17637 case FFEEXPR_contextCASE:
17638 case FFEEXPR_contextFILEASSOC:
17639 case FFEEXPR_contextFILEINT:
17640 case FFEEXPR_contextFILEDFINT:
17641 case FFEEXPR_contextFILELOG:
17642 case FFEEXPR_contextFILENUM:
17643 case FFEEXPR_contextFILENUMAMBIG:
17644 case FFEEXPR_contextFILECHAR:
17645 case FFEEXPR_contextFILENUMCHAR:
17646 case FFEEXPR_contextFILEDFCHAR:
17647 case FFEEXPR_contextFILEKEY:
17648 case FFEEXPR_contextFILEUNIT:
17649 case FFEEXPR_contextFILEUNIT_DF:
17650 case FFEEXPR_contextFILEUNITAMBIG:
17651 case FFEEXPR_contextFILEFORMAT:
17652 case FFEEXPR_contextFILENAMELIST:
17653 case FFEEXPR_contextFILEVXTCODE:
17654 case FFEEXPR_contextINDEX_:
17655 case FFEEXPR_contextIMPDOITEM_:
17656 case FFEEXPR_contextIMPDOITEMDF_:
17657 case FFEEXPR_contextIMPDOCTRL_:
17658 case FFEEXPR_contextLOC_:
17659 if (ffeexpr_stack_->is_rhs)
17660 s = ffeexpr_paren_rhs_let_ (s, t);
17661 else
17662 s = ffeexpr_paren_lhs_let_ (s, t);
17663 break;
17664
17665 case FFEEXPR_contextASSIGN:
17666 case FFEEXPR_contextAGOTO:
17667 case FFEEXPR_contextCHARACTERSIZE:
17668 case FFEEXPR_contextEQUIVALENCE:
17669 case FFEEXPR_contextINCLUDE:
17670 case FFEEXPR_contextPARAMETER:
17671 case FFEEXPR_contextDIMLIST:
17672 case FFEEXPR_contextDIMLISTCOMMON:
17673 case FFEEXPR_contextKINDTYPE:
17674 case FFEEXPR_contextINITVAL:
17675 case FFEEXPR_contextEQVINDEX_:
17676 break; /* Will turn into errors below. */
17677
17678 default:
17679 ffesymbol_error (s, t);
17680 break;
17681 }
17682 /* Fall through. */
17683 case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */
17684 understood: /* :::::::::::::::::::: */
17685
17686 /* State might have changed, update it. */
17687 st = ((ffesymbol_sfdummyparent (s) == NULL)
17688 ? ffesymbol_state (s)
17689 : FFESYMBOL_stateUNDERSTOOD);
17690
17691 k = ffesymbol_kind (s);
17692 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17693 {
17694 case FFEEXPR_contextSUBROUTINEREF:
17695 bad = ((k != FFEINFO_kindSUBROUTINE)
17696 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
17697 || (k != FFEINFO_kindNONE)));
17698 break;
17699
17700 case FFEEXPR_contextDATA:
17701 if (ffeexpr_stack_->is_rhs)
17702 bad = (k != FFEINFO_kindENTITY)
17703 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
17704 else
17705 bad = (k != FFEINFO_kindENTITY)
17706 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
17707 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
17708 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
17709 break;
17710
17711 case FFEEXPR_contextDATAIMPDOITEM_:
17712 bad = (k != FFEINFO_kindENTITY) || (ffesymbol_rank (s) == 0)
17713 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
17714 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
17715 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
17716 break;
17717
17718 case FFEEXPR_contextSFUNCDEF:
17719 case FFEEXPR_contextSFUNCDEFINDEX_:
17720 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17721 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17722 case FFEEXPR_contextLET:
17723 case FFEEXPR_contextPAREN_:
17724 case FFEEXPR_contextACTUALARGEXPR_:
17725 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17726 case FFEEXPR_contextIOLIST:
17727 case FFEEXPR_contextIOLISTDF:
17728 case FFEEXPR_contextDO:
17729 case FFEEXPR_contextDOWHILE:
17730 case FFEEXPR_contextACTUALARG_:
17731 case FFEEXPR_contextCGOTO:
17732 case FFEEXPR_contextIF:
17733 case FFEEXPR_contextARITHIF:
17734 case FFEEXPR_contextFORMAT:
17735 case FFEEXPR_contextSTOP:
17736 case FFEEXPR_contextRETURN:
17737 case FFEEXPR_contextSELECTCASE:
17738 case FFEEXPR_contextCASE:
17739 case FFEEXPR_contextFILEASSOC:
17740 case FFEEXPR_contextFILEINT:
17741 case FFEEXPR_contextFILEDFINT:
17742 case FFEEXPR_contextFILELOG:
17743 case FFEEXPR_contextFILENUM:
17744 case FFEEXPR_contextFILENUMAMBIG:
17745 case FFEEXPR_contextFILECHAR:
17746 case FFEEXPR_contextFILENUMCHAR:
17747 case FFEEXPR_contextFILEDFCHAR:
17748 case FFEEXPR_contextFILEKEY:
17749 case FFEEXPR_contextFILEUNIT:
17750 case FFEEXPR_contextFILEUNIT_DF:
17751 case FFEEXPR_contextFILEUNITAMBIG:
17752 case FFEEXPR_contextFILEFORMAT:
17753 case FFEEXPR_contextFILENAMELIST:
17754 case FFEEXPR_contextFILEVXTCODE:
17755 case FFEEXPR_contextINDEX_:
17756 case FFEEXPR_contextIMPDOITEM_:
17757 case FFEEXPR_contextIMPDOITEMDF_:
17758 case FFEEXPR_contextIMPDOCTRL_:
17759 case FFEEXPR_contextLOC_:
17760 bad = FALSE; /* Let paren-switch handle the cases. */
17761 break;
17762
17763 case FFEEXPR_contextASSIGN:
17764 case FFEEXPR_contextAGOTO:
17765 case FFEEXPR_contextCHARACTERSIZE:
17766 case FFEEXPR_contextEQUIVALENCE:
17767 case FFEEXPR_contextPARAMETER:
17768 case FFEEXPR_contextDIMLIST:
17769 case FFEEXPR_contextDIMLISTCOMMON:
17770 case FFEEXPR_contextKINDTYPE:
17771 case FFEEXPR_contextINITVAL:
17772 case FFEEXPR_contextEQVINDEX_:
17773 bad = (k != FFEINFO_kindENTITY)
17774 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
17775 break;
17776
17777 case FFEEXPR_contextINCLUDE:
17778 bad = TRUE;
17779 break;
17780
17781 default:
17782 bad = TRUE;
17783 break;
17784 }
17785
17786 switch (bad ? FFEINFO_kindANY : k)
17787 {
17788 case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */
17789 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
17790 {
17791 if (ffeexpr_context_outer_ (ffeexpr_stack_)
17792 == FFEEXPR_contextSUBROUTINEREF)
17793 *paren_type = FFEEXPR_parentypeSUBROUTINE_;
17794 else
17795 *paren_type = FFEEXPR_parentypeFUNCTION_;
17796 break;
17797 }
17798 if (st == FFESYMBOL_stateUNDERSTOOD)
17799 {
17800 bad = TRUE;
17801 *paren_type = FFEEXPR_parentypeANY_;
17802 }
17803 else
17804 *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
17805 break;
17806
17807 case FFEINFO_kindFUNCTION:
17808 *paren_type = FFEEXPR_parentypeFUNCTION_;
17809 switch (ffesymbol_where (s))
17810 {
17811 case FFEINFO_whereLOCAL:
17812 bad = TRUE; /* Attempt to recurse! */
17813 break;
17814
17815 case FFEINFO_whereCONSTANT:
17816 bad = ((ffesymbol_sfexpr (s) == NULL)
17817 || (ffebld_op (ffesymbol_sfexpr (s))
17818 == FFEBLD_opANY)); /* Attempt to recurse! */
17819 break;
17820
17821 default:
17822 break;
17823 }
17824 break;
17825
17826 case FFEINFO_kindSUBROUTINE:
17827 if ((ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
17828 || (ffeexpr_stack_->previous != NULL))
17829 {
17830 bad = TRUE;
17831 *paren_type = FFEEXPR_parentypeANY_;
17832 break;
17833 }
17834
17835 *paren_type = FFEEXPR_parentypeSUBROUTINE_;
17836 switch (ffesymbol_where (s))
17837 {
17838 case FFEINFO_whereLOCAL:
17839 case FFEINFO_whereCONSTANT:
17840 bad = TRUE; /* Attempt to recurse! */
17841 break;
17842
17843 default:
17844 break;
17845 }
17846 break;
17847
17848 case FFEINFO_kindENTITY:
17849 if (ffesymbol_rank (s) == 0)
17850 {
17851 if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
17852 *paren_type = FFEEXPR_parentypeSUBSTRING_;
17853 else
17854 {
17855 bad = TRUE;
17856 *paren_type = FFEEXPR_parentypeANY_;
17857 }
17858 }
17859 else
17860 *paren_type = FFEEXPR_parentypeARRAY_;
17861 break;
17862
17863 default:
17864 case FFEINFO_kindANY:
17865 bad = TRUE;
17866 *paren_type = FFEEXPR_parentypeANY_;
17867 break;
17868 }
17869
17870 if (bad)
17871 {
17872 if (k == FFEINFO_kindANY)
17873 ffest_shutdown ();
17874 else
17875 ffesymbol_error (s, t);
17876 }
17877
17878 return s;
17879
17880 case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */
17881 seen: /* :::::::::::::::::::: */
17882 bad = TRUE;
17883 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17884 {
17885 case FFEEXPR_contextPARAMETER:
17886 if (ffeexpr_stack_->is_rhs)
17887 ffesymbol_error (s, t);
17888 else
17889 s = ffeexpr_sym_lhs_parameter_ (s, t);
17890 break;
17891
17892 case FFEEXPR_contextDATA:
17893 s = ffecom_sym_exec_transition (s);
17894 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17895 goto understood; /* :::::::::::::::::::: */
17896 if (ffeexpr_stack_->is_rhs)
17897 ffesymbol_error (s, t);
17898 else
17899 s = ffeexpr_sym_lhs_data_ (s, t);
17900 goto understood; /* :::::::::::::::::::: */
17901
17902 case FFEEXPR_contextDATAIMPDOITEM_:
17903 s = ffecom_sym_exec_transition (s);
17904 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17905 goto understood; /* :::::::::::::::::::: */
17906 s = ffeexpr_sym_lhs_data_ (s, t);
17907 goto understood; /* :::::::::::::::::::: */
17908
17909 case FFEEXPR_contextEQUIVALENCE:
17910 s = ffeexpr_sym_lhs_equivalence_ (s, t);
17911 bad = FALSE;
17912 break;
17913
17914 case FFEEXPR_contextDIMLIST:
17915 s = ffeexpr_sym_rhs_dimlist_ (s, t);
17916 break;
17917
17918 case FFEEXPR_contextCHARACTERSIZE:
17919 case FFEEXPR_contextKINDTYPE:
17920 case FFEEXPR_contextDIMLISTCOMMON:
17921 case FFEEXPR_contextINITVAL:
17922 case FFEEXPR_contextEQVINDEX_:
17923 break;
17924
17925 case FFEEXPR_contextINCLUDE:
17926 break;
17927
17928 case FFEEXPR_contextINDEX_:
17929 case FFEEXPR_contextACTUALARGEXPR_:
17930 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17931 case FFEEXPR_contextSFUNCDEF:
17932 case FFEEXPR_contextSFUNCDEFINDEX_:
17933 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17934 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17935 assert (ffeexpr_stack_->is_rhs);
17936 s = ffecom_sym_exec_transition (s);
17937 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17938 goto understood; /* :::::::::::::::::::: */
17939 s = ffeexpr_paren_rhs_let_ (s, t);
17940 goto understood; /* :::::::::::::::::::: */
17941
17942 default:
17943 break;
17944 }
17945 k = ffesymbol_kind (s);
17946 switch (bad ? FFEINFO_kindANY : k)
17947 {
17948 case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */
17949 *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
17950 break;
17951
17952 case FFEINFO_kindFUNCTION:
17953 *paren_type = FFEEXPR_parentypeFUNCTION_;
17954 switch (ffesymbol_where (s))
17955 {
17956 case FFEINFO_whereLOCAL:
17957 bad = TRUE; /* Attempt to recurse! */
17958 break;
17959
17960 case FFEINFO_whereCONSTANT:
17961 bad = ((ffesymbol_sfexpr (s) == NULL)
17962 || (ffebld_op (ffesymbol_sfexpr (s))
17963 == FFEBLD_opANY)); /* Attempt to recurse! */
17964 break;
17965
17966 default:
17967 break;
17968 }
17969 break;
17970
17971 case FFEINFO_kindSUBROUTINE:
17972 *paren_type = FFEEXPR_parentypeANY_;
17973 bad = TRUE; /* Cannot possibly be in
17974 contextSUBROUTINEREF. */
17975 break;
17976
17977 case FFEINFO_kindENTITY:
17978 if (ffesymbol_rank (s) == 0)
17979 {
17980 if (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE)
17981 *paren_type = FFEEXPR_parentypeEQUIVALENCE_;
17982 else if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
17983 *paren_type = FFEEXPR_parentypeSUBSTRING_;
17984 else
17985 {
17986 bad = TRUE;
17987 *paren_type = FFEEXPR_parentypeANY_;
17988 }
17989 }
17990 else
17991 *paren_type = FFEEXPR_parentypeARRAY_;
17992 break;
17993
17994 default:
17995 case FFEINFO_kindANY:
17996 bad = TRUE;
17997 *paren_type = FFEEXPR_parentypeANY_;
17998 break;
17999 }
18000
18001 if (bad)
18002 {
18003 if (k == FFEINFO_kindANY)
18004 ffest_shutdown ();
18005 else
18006 ffesymbol_error (s, t);
18007 }
18008
18009 return s;
18010
18011 default:
18012 assert ("bad symbol state" == NULL);
18013 return NULL;
18014 }
18015 }
18016
18017 /* Have FOO in XYZ = ...FOO(...).... Executable context only. */
18018
18019 static ffesymbol
18020 ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t)
18021 {
18022 ffesymbolAttrs sa;
18023 ffesymbolAttrs na;
18024 ffeinfoKind kind;
18025 ffeinfoWhere where;
18026 ffeintrinGen gen;
18027 ffeintrinSpec spec;
18028 ffeintrinImp imp;
18029 bool maybe_ambig = FALSE;
18030 bool error = FALSE;
18031
18032 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
18033 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
18034
18035 na = sa = ffesymbol_attrs (s);
18036
18037 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
18038 | FFESYMBOL_attrsADJUSTABLE
18039 | FFESYMBOL_attrsANYLEN
18040 | FFESYMBOL_attrsARRAY
18041 | FFESYMBOL_attrsDUMMY
18042 | FFESYMBOL_attrsEXTERNAL
18043 | FFESYMBOL_attrsSFARG
18044 | FFESYMBOL_attrsTYPE)));
18045
18046 kind = ffesymbol_kind (s);
18047 where = ffesymbol_where (s);
18048
18049 /* Figure out what kind of object we've got based on previous declarations
18050 of or references to the object. */
18051
18052 if (sa & FFESYMBOL_attrsEXTERNAL)
18053 {
18054 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
18055 | FFESYMBOL_attrsDUMMY
18056 | FFESYMBOL_attrsEXTERNAL
18057 | FFESYMBOL_attrsTYPE)));
18058
18059 if (sa & FFESYMBOL_attrsTYPE)
18060 where = FFEINFO_whereGLOBAL;
18061 else
18062 /* Not TYPE. */
18063 {
18064 kind = FFEINFO_kindFUNCTION;
18065
18066 if (sa & FFESYMBOL_attrsDUMMY)
18067 ; /* Not TYPE. */
18068 else if (sa & FFESYMBOL_attrsACTUALARG)
18069 ; /* Not DUMMY or TYPE. */
18070 else /* Not ACTUALARG, DUMMY, or TYPE. */
18071 where = FFEINFO_whereGLOBAL;
18072 }
18073 }
18074 else if (sa & FFESYMBOL_attrsDUMMY)
18075 {
18076 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
18077 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
18078 | FFESYMBOL_attrsEXTERNAL
18079 | FFESYMBOL_attrsTYPE)));
18080
18081 kind = FFEINFO_kindFUNCTION;
18082 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure; kind
18083 could be ENTITY w/substring ref. */
18084 }
18085 else if (sa & FFESYMBOL_attrsARRAY)
18086 {
18087 assert (!(sa & ~(FFESYMBOL_attrsARRAY
18088 | FFESYMBOL_attrsADJUSTABLE
18089 | FFESYMBOL_attrsTYPE)));
18090
18091 where = FFEINFO_whereLOCAL;
18092 }
18093 else if (sa & FFESYMBOL_attrsSFARG)
18094 {
18095 assert (!(sa & ~(FFESYMBOL_attrsSFARG
18096 | FFESYMBOL_attrsTYPE)));
18097
18098 where = FFEINFO_whereLOCAL; /* Actually an error, but at least we
18099 know it's a local var. */
18100 }
18101 else if (sa & FFESYMBOL_attrsTYPE)
18102 {
18103 assert (!(sa & (FFESYMBOL_attrsARRAY
18104 | FFESYMBOL_attrsDUMMY
18105 | FFESYMBOL_attrsEXTERNAL
18106 | FFESYMBOL_attrsSFARG))); /* Handled above. */
18107 assert (!(sa & ~(FFESYMBOL_attrsTYPE
18108 | FFESYMBOL_attrsADJUSTABLE
18109 | FFESYMBOL_attrsANYLEN
18110 | FFESYMBOL_attrsARRAY
18111 | FFESYMBOL_attrsDUMMY
18112 | FFESYMBOL_attrsEXTERNAL
18113 | FFESYMBOL_attrsSFARG)));
18114
18115 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
18116 &gen, &spec, &imp))
18117 {
18118 if (!(sa & FFESYMBOL_attrsANYLEN)
18119 && (ffeimplic_peek_symbol_type (s, NULL)
18120 == FFEINFO_basictypeCHARACTER))
18121 return s; /* Haven't learned anything yet. */
18122
18123 ffesymbol_signal_change (s); /* May need to back up to previous
18124 version. */
18125 ffesymbol_set_generic (s, gen);
18126 ffesymbol_set_specific (s, spec);
18127 ffesymbol_set_implementation (s, imp);
18128 ffesymbol_set_info (s,
18129 ffeinfo_new (ffesymbol_basictype (s),
18130 ffesymbol_kindtype (s),
18131 0,
18132 FFEINFO_kindFUNCTION,
18133 FFEINFO_whereINTRINSIC,
18134 ffesymbol_size (s)));
18135 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18136 ffesymbol_resolve_intrin (s);
18137 ffesymbol_reference (s, t, FALSE);
18138 s = ffecom_sym_learned (s);
18139 ffesymbol_signal_unreported (s); /* For debugging purposes. */
18140
18141 return s;
18142 }
18143 if (sa & FFESYMBOL_attrsANYLEN)
18144 error = TRUE; /* Error, since the only way we can,
18145 given CHARACTER*(*) FOO, accept
18146 FOO(...) is for FOO to be a dummy
18147 arg or constant, but it can't
18148 become either now. */
18149 else if (sa & FFESYMBOL_attrsADJUSTABLE)
18150 {
18151 kind = FFEINFO_kindENTITY;
18152 where = FFEINFO_whereLOCAL;
18153 }
18154 else
18155 {
18156 kind = FFEINFO_kindFUNCTION;
18157 where = FFEINFO_whereGLOBAL;
18158 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure;
18159 could be ENTITY/LOCAL w/substring ref. */
18160 }
18161 }
18162 else if (sa == FFESYMBOL_attrsetNONE)
18163 {
18164 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
18165
18166 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
18167 &gen, &spec, &imp))
18168 {
18169 if (ffeimplic_peek_symbol_type (s, NULL)
18170 == FFEINFO_basictypeCHARACTER)
18171 return s; /* Haven't learned anything yet. */
18172
18173 ffesymbol_signal_change (s); /* May need to back up to previous
18174 version. */
18175 ffesymbol_set_generic (s, gen);
18176 ffesymbol_set_specific (s, spec);
18177 ffesymbol_set_implementation (s, imp);
18178 ffesymbol_set_info (s,
18179 ffeinfo_new (ffesymbol_basictype (s),
18180 ffesymbol_kindtype (s),
18181 0,
18182 FFEINFO_kindFUNCTION,
18183 FFEINFO_whereINTRINSIC,
18184 ffesymbol_size (s)));
18185 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18186 ffesymbol_resolve_intrin (s);
18187 s = ffecom_sym_learned (s);
18188 ffesymbol_reference (s, t, FALSE);
18189 ffesymbol_signal_unreported (s); /* For debugging purposes. */
18190 return s;
18191 }
18192
18193 kind = FFEINFO_kindFUNCTION;
18194 where = FFEINFO_whereGLOBAL;
18195 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure;
18196 could be ENTITY/LOCAL w/substring ref. */
18197 }
18198 else
18199 error = TRUE;
18200
18201 /* Now see what we've got for a new object: NONE means a new error cropped
18202 up; ANY means an old error to be ignored; otherwise, everything's ok,
18203 update the object (symbol) and continue on. */
18204
18205 if (error)
18206 ffesymbol_error (s, t);
18207 else if (!(na & FFESYMBOL_attrsANY))
18208 {
18209 ffesymbol_signal_change (s); /* May need to back up to previous
18210 version. */
18211 if (!ffeimplic_establish_symbol (s))
18212 {
18213 ffesymbol_error (s, t);
18214 return s;
18215 }
18216 if (maybe_ambig
18217 && (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
18218 return s; /* Still not sure, let caller deal with it
18219 based on (...). */
18220
18221 ffesymbol_set_info (s,
18222 ffeinfo_new (ffesymbol_basictype (s),
18223 ffesymbol_kindtype (s),
18224 ffesymbol_rank (s),
18225 kind,
18226 where,
18227 ffesymbol_size (s)));
18228 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18229 ffesymbol_resolve_intrin (s);
18230 s = ffecom_sym_learned (s);
18231 ffesymbol_reference (s, t, FALSE);
18232 ffesymbol_signal_unreported (s); /* For debugging purposes. */
18233 }
18234
18235 return s;
18236 }
18237
18238 /* ffeexpr_token_arguments_ -- OPEN_PAREN [expr COMMA]...expr
18239
18240 Return a pointer to this function to the lexer (ffelex), which will
18241 invoke it for the next token.
18242
18243 Handle expression (which might be null) and COMMA or CLOSE_PAREN. */
18244
18245 static ffelexHandler
18246 ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr, ffelexToken t)
18247 {
18248 ffeexprExpr_ procedure;
18249 ffebld reduced;
18250 ffeinfo info;
18251 ffeexprContext ctx;
18252 bool check_intrin = FALSE; /* Set TRUE if intrinsic is REAL(Z) or AIMAG(Z). */
18253
18254 procedure = ffeexpr_stack_->exprstack;
18255 info = ffebld_info (procedure->u.operand);
18256
18257 /* Is there an expression to add? If the expression is nil,
18258 it might still be an argument. It is if:
18259
18260 - The current token is comma, or
18261
18262 - The -fugly-comma flag was specified *and* the procedure
18263 being invoked is external.
18264
18265 Otherwise, if neither of the above is the case, just
18266 ignore this (nil) expression. */
18267
18268 if ((expr != NULL)
18269 || (ffelex_token_type (t) == FFELEX_typeCOMMA)
18270 || (ffe_is_ugly_comma ()
18271 && (ffeinfo_where (info) == FFEINFO_whereGLOBAL)))
18272 {
18273 /* This expression, even if nil, is apparently intended as an argument. */
18274
18275 /* Internal procedure (CONTAINS, or statement function)? */
18276
18277 if (ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18278 {
18279 if ((expr == NULL)
18280 && ffebad_start (FFEBAD_NULL_ARGUMENT))
18281 {
18282 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18283 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18284 ffebad_here (1, ffelex_token_where_line (t),
18285 ffelex_token_where_column (t));
18286 ffebad_finish ();
18287 }
18288
18289 if (expr == NULL)
18290 ;
18291 else
18292 {
18293 if (ffeexpr_stack_->next_dummy == NULL)
18294 { /* Report later which was the first extra argument. */
18295 if (ffeexpr_stack_->tokens[1] == NULL)
18296 {
18297 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
18298 ffeexpr_stack_->num_args = 0;
18299 }
18300 ++ffeexpr_stack_->num_args; /* Count # of extra arguments. */
18301 }
18302 else
18303 {
18304 if ((ffeinfo_rank (ffebld_info (expr)) != 0)
18305 && ffebad_start (FFEBAD_ARRAY_AS_SFARG))
18306 {
18307 ffebad_here (0,
18308 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18309 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18310 ffebad_here (1, ffelex_token_where_line (ft),
18311 ffelex_token_where_column (ft));
18312 ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent
18313 (ffebld_symter (ffebld_head
18314 (ffeexpr_stack_->next_dummy)))));
18315 ffebad_finish ();
18316 }
18317 else
18318 {
18319 expr = ffeexpr_convert_expr (expr, ft,
18320 ffebld_head (ffeexpr_stack_->next_dummy),
18321 ffeexpr_stack_->tokens[0],
18322 FFEEXPR_contextLET);
18323 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18324 }
18325 --ffeexpr_stack_->num_args; /* Count down # of args. */
18326 ffeexpr_stack_->next_dummy
18327 = ffebld_trail (ffeexpr_stack_->next_dummy);
18328 }
18329 }
18330 }
18331 else
18332 {
18333 if ((expr == NULL)
18334 && ffe_is_pedantic ()
18335 && ffebad_start (FFEBAD_NULL_ARGUMENT_W))
18336 {
18337 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18338 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18339 ffebad_here (1, ffelex_token_where_line (t),
18340 ffelex_token_where_column (t));
18341 ffebad_finish ();
18342 }
18343 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18344 }
18345 }
18346
18347 switch (ffelex_token_type (t))
18348 {
18349 case FFELEX_typeCOMMA:
18350 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
18351 {
18352 case FFEEXPR_contextSFUNCDEF:
18353 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
18354 case FFEEXPR_contextSFUNCDEFINDEX_:
18355 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
18356 ctx = FFEEXPR_contextSFUNCDEFACTUALARG_;
18357 break;
18358
18359 case FFEEXPR_contextSFUNCDEFACTUALARG_:
18360 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18361 assert ("bad context" == NULL);
18362 ctx = FFEEXPR_context;
18363 break;
18364
18365 default:
18366 ctx = FFEEXPR_contextACTUALARG_;
18367 break;
18368 }
18369 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18370 ffeexpr_token_arguments_);
18371
18372 default:
18373 break;
18374 }
18375
18376 if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18377 && (ffeexpr_stack_->next_dummy != NULL))
18378 { /* Too few arguments. */
18379 if (ffebad_start (FFEBAD_TOO_FEW_ARGUMENTS))
18380 {
18381 char num[10];
18382
18383 sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
18384
18385 ffebad_here (0, ffelex_token_where_line (t),
18386 ffelex_token_where_column (t));
18387 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18388 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18389 ffebad_string (num);
18390 ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent (ffebld_symter
18391 (ffebld_head (ffeexpr_stack_->next_dummy)))));
18392 ffebad_finish ();
18393 }
18394 for (;
18395 ffeexpr_stack_->next_dummy != NULL;
18396 ffeexpr_stack_->next_dummy
18397 = ffebld_trail (ffeexpr_stack_->next_dummy))
18398 {
18399 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0));
18400 ffebld_set_info (expr, ffeinfo_new_any ());
18401 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18402 }
18403 }
18404
18405 if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18406 && (ffeexpr_stack_->tokens[1] != NULL))
18407 { /* Too many arguments to statement function. */
18408 if (ffebad_start (FFEBAD_TOO_MANY_ARGUMENTS))
18409 {
18410 char num[10];
18411
18412 sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
18413
18414 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
18415 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
18416 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18417 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18418 ffebad_string (num);
18419 ffebad_finish ();
18420 }
18421 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
18422 }
18423 ffebld_end_list (&ffeexpr_stack_->bottom);
18424
18425 if (ffebld_op (procedure->u.operand) == FFEBLD_opANY)
18426 {
18427 reduced = ffebld_new_any ();
18428 ffebld_set_info (reduced, ffeinfo_new_any ());
18429 }
18430 else
18431 {
18432 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
18433 reduced = ffebld_new_funcref (procedure->u.operand,
18434 ffeexpr_stack_->expr);
18435 else
18436 reduced = ffebld_new_subrref (procedure->u.operand,
18437 ffeexpr_stack_->expr);
18438 if (ffebld_symter_generic (procedure->u.operand) != FFEINTRIN_genNONE)
18439 ffeintrin_fulfill_generic (&reduced, &info, ffeexpr_stack_->tokens[0]);
18440 else if (ffebld_symter_specific (procedure->u.operand)
18441 != FFEINTRIN_specNONE)
18442 ffeintrin_fulfill_specific (&reduced, &info, &check_intrin,
18443 ffeexpr_stack_->tokens[0]);
18444 else
18445 ffeexpr_fulfill_call_ (&reduced, ffeexpr_stack_->tokens[0]);
18446
18447 if (ffebld_op (reduced) != FFEBLD_opANY)
18448 ffebld_set_info (reduced,
18449 ffeinfo_new (ffeinfo_basictype (info),
18450 ffeinfo_kindtype (info),
18451 0,
18452 FFEINFO_kindENTITY,
18453 FFEINFO_whereFLEETING,
18454 ffeinfo_size (info)));
18455 else
18456 ffebld_set_info (reduced, ffeinfo_new_any ());
18457 }
18458 if (ffebld_op (reduced) == FFEBLD_opFUNCREF)
18459 reduced = ffeexpr_collapse_funcref (reduced, ffeexpr_stack_->tokens[0]);
18460 ffeexpr_stack_->exprstack = procedure->previous; /* Pops
18461 not-quite-operand off
18462 stack. */
18463 procedure->u.operand = reduced; /* Save the line/column ffewhere
18464 info. */
18465 ffeexpr_exprstack_push_operand_ (procedure); /* Push it back on stack. */
18466 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18467 {
18468 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18469 ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FUNC(3)(1:1)".... */
18470
18471 /* If the intrinsic needs checking (is REAL(Z) or AIMAG(Z), where
18472 Z is DOUBLE COMPLEX), and a command-line option doesn't already
18473 establish interpretation, probably complain. */
18474
18475 if (check_intrin
18476 && !ffe_is_90 ()
18477 && !ffe_is_ugly_complex ())
18478 {
18479 /* If the outer expression is REAL(me...), issue diagnostic
18480 only if next token isn't the close-paren for REAL(me). */
18481
18482 if ((ffeexpr_stack_->previous != NULL)
18483 && (ffeexpr_stack_->previous->exprstack != NULL)
18484 && (ffeexpr_stack_->previous->exprstack->type == FFEEXPR_exprtypeOPERAND_)
18485 && ((reduced = ffeexpr_stack_->previous->exprstack->u.operand) != NULL)
18486 && (ffebld_op (reduced) == FFEBLD_opSYMTER)
18487 && (ffebld_symter_implementation (reduced) == FFEINTRIN_impREAL))
18488 return (ffelexHandler) ffeexpr_token_intrincheck_;
18489
18490 /* Diagnose the ambiguity now. */
18491
18492 if (ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
18493 {
18494 ffebad_string (ffeintrin_name_implementation
18495 (ffebld_symter_implementation
18496 (ffebld_left
18497 (ffeexpr_stack_->exprstack->u.operand))));
18498 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
18499 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
18500 ffebad_finish ();
18501 }
18502 }
18503 return (ffelexHandler) ffeexpr_token_substrp_;
18504 }
18505
18506 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
18507 {
18508 ffebad_here (0, ffelex_token_where_line (t),
18509 ffelex_token_where_column (t));
18510 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18511 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18512 ffebad_finish ();
18513 }
18514 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18515 ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FUNC(3)(1:1)".... */
18516 return
18517 (ffelexHandler) ffeexpr_find_close_paren_ (t,
18518 (ffelexHandler)
18519 ffeexpr_token_substrp_);
18520 }
18521
18522 /* ffeexpr_token_elements_ -- OPEN_PAREN [expr COMMA]...expr
18523
18524 Return a pointer to this array to the lexer (ffelex), which will
18525 invoke it for the next token.
18526
18527 Handle expression and COMMA or CLOSE_PAREN. */
18528
18529 static ffelexHandler
18530 ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, ffelexToken t)
18531 {
18532 ffeexprExpr_ array;
18533 ffebld reduced;
18534 ffeinfo info;
18535 ffeinfoWhere where;
18536 ffetargetIntegerDefault val;
18537 ffetargetIntegerDefault lval = 0;
18538 ffetargetIntegerDefault uval = 0;
18539 ffebld lbound;
18540 ffebld ubound;
18541 bool lcheck;
18542 bool ucheck;
18543
18544 array = ffeexpr_stack_->exprstack;
18545 info = ffebld_info (array->u.operand);
18546
18547 if ((expr == NULL) /* && ((ffeexpr_stack_->rank != 0) ||
18548 (ffelex_token_type(t) ==
18549 FFELEX_typeCOMMA)) */ )
18550 {
18551 if (ffebad_start (FFEBAD_NULL_ELEMENT))
18552 {
18553 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18554 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18555 ffebad_here (1, ffelex_token_where_line (t),
18556 ffelex_token_where_column (t));
18557 ffebad_finish ();
18558 }
18559 if (ffeexpr_stack_->rank < ffeinfo_rank (info))
18560 { /* Don't bother if we're going to complain
18561 later! */
18562 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
18563 ffebld_set_info (expr, ffeinfo_new_any ());
18564 }
18565 }
18566
18567 if (expr == NULL)
18568 ;
18569 else if (ffeinfo_rank (info) == 0)
18570 { /* In EQUIVALENCE context, ffeinfo_rank(info)
18571 may == 0. */
18572 ++ffeexpr_stack_->rank; /* Track anyway, may need for new VXT
18573 feature. */
18574 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18575 }
18576 else
18577 {
18578 ++ffeexpr_stack_->rank;
18579 if (ffeexpr_stack_->rank > ffeinfo_rank (info))
18580 { /* Report later which was the first extra
18581 element. */
18582 if (ffeexpr_stack_->rank == ffeinfo_rank (info) + 1)
18583 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
18584 }
18585 else
18586 {
18587 switch (ffeinfo_where (ffebld_info (expr)))
18588 {
18589 case FFEINFO_whereCONSTANT:
18590 break;
18591
18592 case FFEINFO_whereIMMEDIATE:
18593 ffeexpr_stack_->constant = FALSE;
18594 break;
18595
18596 default:
18597 ffeexpr_stack_->constant = FALSE;
18598 ffeexpr_stack_->immediate = FALSE;
18599 break;
18600 }
18601 if (ffebld_op (expr) == FFEBLD_opCONTER)
18602 {
18603 val = ffebld_constant_integerdefault (ffebld_conter (expr));
18604
18605 lbound = ffebld_left (ffebld_head (ffeexpr_stack_->bound_list));
18606 if (lbound == NULL)
18607 {
18608 lcheck = TRUE;
18609 lval = 1;
18610 }
18611 else if (ffebld_op (lbound) == FFEBLD_opCONTER)
18612 {
18613 lcheck = TRUE;
18614 lval = ffebld_constant_integerdefault (ffebld_conter (lbound));
18615 }
18616 else
18617 lcheck = FALSE;
18618
18619 ubound = ffebld_right (ffebld_head (ffeexpr_stack_->bound_list));
18620 assert (ubound != NULL);
18621 if (ffebld_op (ubound) == FFEBLD_opCONTER)
18622 {
18623 ucheck = TRUE;
18624 uval = ffebld_constant_integerdefault (ffebld_conter (ubound));
18625 }
18626 else
18627 ucheck = FALSE;
18628
18629 if ((lcheck && (val < lval)) || (ucheck && (val > uval)))
18630 {
18631 ffebad_start (FFEBAD_RANGE_ARRAY);
18632 ffebad_here (0, ffelex_token_where_line (ft),
18633 ffelex_token_where_column (ft));
18634 ffebad_finish ();
18635 }
18636 }
18637 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18638 ffeexpr_stack_->bound_list = ffebld_trail (ffeexpr_stack_->bound_list);
18639 }
18640 }
18641
18642 switch (ffelex_token_type (t))
18643 {
18644 case FFELEX_typeCOMMA:
18645 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
18646 {
18647 case FFEEXPR_contextDATAIMPDOITEM_:
18648 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18649 FFEEXPR_contextDATAIMPDOINDEX_,
18650 ffeexpr_token_elements_);
18651
18652 case FFEEXPR_contextEQUIVALENCE:
18653 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18654 FFEEXPR_contextEQVINDEX_,
18655 ffeexpr_token_elements_);
18656
18657 case FFEEXPR_contextSFUNCDEF:
18658 case FFEEXPR_contextSFUNCDEFINDEX_:
18659 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18660 FFEEXPR_contextSFUNCDEFINDEX_,
18661 ffeexpr_token_elements_);
18662
18663 case FFEEXPR_contextSFUNCDEFACTUALARG_:
18664 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18665 assert ("bad context" == NULL);
18666 break;
18667
18668 default:
18669 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18670 FFEEXPR_contextINDEX_,
18671 ffeexpr_token_elements_);
18672 }
18673
18674 default:
18675 break;
18676 }
18677
18678 if ((ffeexpr_stack_->rank != ffeinfo_rank (info))
18679 && (ffeinfo_rank (info) != 0))
18680 {
18681 char num[10];
18682
18683 if (ffeexpr_stack_->rank < ffeinfo_rank (info))
18684 {
18685 if (ffebad_start (FFEBAD_TOO_FEW_ELEMENTS))
18686 {
18687 sprintf (num, "%d",
18688 (int) (ffeinfo_rank (info) - ffeexpr_stack_->rank));
18689
18690 ffebad_here (0, ffelex_token_where_line (t),
18691 ffelex_token_where_column (t));
18692 ffebad_here (1,
18693 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18694 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18695 ffebad_string (num);
18696 ffebad_finish ();
18697 }
18698 }
18699 else
18700 {
18701 if (ffebad_start (FFEBAD_TOO_MANY_ELEMENTS))
18702 {
18703 sprintf (num, "%d",
18704 (int) (ffeexpr_stack_->rank - ffeinfo_rank (info)));
18705
18706 ffebad_here (0,
18707 ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
18708 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
18709 ffebad_here (1,
18710 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18711 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18712 ffebad_string (num);
18713 ffebad_finish ();
18714 }
18715 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
18716 }
18717 while (ffeexpr_stack_->rank++ < ffeinfo_rank (info))
18718 {
18719 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
18720 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeINTEGER,
18721 FFEINFO_kindtypeINTEGERDEFAULT,
18722 0, FFEINFO_kindENTITY,
18723 FFEINFO_whereCONSTANT,
18724 FFETARGET_charactersizeNONE));
18725 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18726 }
18727 }
18728 ffebld_end_list (&ffeexpr_stack_->bottom);
18729
18730 if (ffebld_op (array->u.operand) == FFEBLD_opANY)
18731 {
18732 reduced = ffebld_new_any ();
18733 ffebld_set_info (reduced, ffeinfo_new_any ());
18734 }
18735 else
18736 {
18737 reduced = ffebld_new_arrayref (array->u.operand, ffeexpr_stack_->expr);
18738 if (ffeexpr_stack_->constant)
18739 where = FFEINFO_whereFLEETING_CADDR;
18740 else if (ffeexpr_stack_->immediate)
18741 where = FFEINFO_whereFLEETING_IADDR;
18742 else
18743 where = FFEINFO_whereFLEETING;
18744 ffebld_set_info (reduced,
18745 ffeinfo_new (ffeinfo_basictype (info),
18746 ffeinfo_kindtype (info),
18747 0,
18748 FFEINFO_kindENTITY,
18749 where,
18750 ffeinfo_size (info)));
18751 reduced = ffeexpr_collapse_arrayref (reduced, ffeexpr_stack_->tokens[0]);
18752 }
18753
18754 ffeexpr_stack_->exprstack = array->previous; /* Pops not-quite-operand off
18755 stack. */
18756 array->u.operand = reduced; /* Save the line/column ffewhere info. */
18757 ffeexpr_exprstack_push_operand_ (array); /* Push it back on stack. */
18758
18759 switch (ffeinfo_basictype (info))
18760 {
18761 case FFEINFO_basictypeCHARACTER:
18762 ffeexpr_is_substr_ok_ = TRUE; /* Everyone likes "FOO(3)(1:1)".... */
18763 break;
18764
18765 case FFEINFO_basictypeNONE:
18766 ffeexpr_is_substr_ok_ = TRUE;
18767 assert (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE);
18768 break;
18769
18770 default:
18771 ffeexpr_is_substr_ok_ = FALSE;
18772 break;
18773 }
18774
18775 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18776 {
18777 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18778 return (ffelexHandler) ffeexpr_token_substrp_;
18779 }
18780
18781 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
18782 {
18783 ffebad_here (0, ffelex_token_where_line (t),
18784 ffelex_token_where_column (t));
18785 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18786 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18787 ffebad_finish ();
18788 }
18789 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18790 return
18791 (ffelexHandler) ffeexpr_find_close_paren_ (t,
18792 (ffelexHandler)
18793 ffeexpr_token_substrp_);
18794 }
18795
18796 /* ffeexpr_token_equivalence_ -- OPEN_PAREN expr
18797
18798 Return a pointer to this array to the lexer (ffelex), which will
18799 invoke it for the next token.
18800
18801 If token is COLON, pass off to _substr_, else init list and pass off
18802 to _elements_. This handles the case "EQUIVALENCE (FOO(expr?", where
18803 ? marks the token, and where FOO's rank/type has not yet been established,
18804 meaning we could be in a list of indices or in a substring
18805 specification. */
18806
18807 static ffelexHandler
18808 ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr, ffelexToken t)
18809 {
18810 if (ffelex_token_type (t) == FFELEX_typeCOLON)
18811 return ffeexpr_token_substring_ (ft, expr, t);
18812
18813 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
18814 return ffeexpr_token_elements_ (ft, expr, t);
18815 }
18816
18817 /* ffeexpr_token_substring_ -- NAME(of kindENTITY) OPEN_PAREN expr
18818
18819 Return a pointer to this function to the lexer (ffelex), which will
18820 invoke it for the next token.
18821
18822 Handle expression (which may be null) and COLON. */
18823
18824 static ffelexHandler
18825 ffeexpr_token_substring_ (ffelexToken ft, ffebld expr, ffelexToken t)
18826 {
18827 ffeexprExpr_ string;
18828 ffeinfo info;
18829 ffetargetIntegerDefault i;
18830 ffeexprContext ctx;
18831 ffetargetCharacterSize size;
18832
18833 string = ffeexpr_stack_->exprstack;
18834 info = ffebld_info (string->u.operand);
18835 size = ffebld_size_max (string->u.operand);
18836
18837 if (ffelex_token_type (t) == FFELEX_typeCOLON)
18838 {
18839 if ((expr != NULL)
18840 && (ffebld_op (expr) == FFEBLD_opCONTER)
18841 && (((i = ffebld_constant_integerdefault (ffebld_conter (expr)))
18842 < 1)
18843 || ((size != FFETARGET_charactersizeNONE) && (i > size))))
18844 {
18845 ffebad_start (FFEBAD_RANGE_SUBSTR);
18846 ffebad_here (0, ffelex_token_where_line (ft),
18847 ffelex_token_where_column (ft));
18848 ffebad_finish ();
18849 }
18850 ffeexpr_stack_->expr = expr;
18851
18852 switch (ffeexpr_stack_->context)
18853 {
18854 case FFEEXPR_contextSFUNCDEF:
18855 case FFEEXPR_contextSFUNCDEFINDEX_:
18856 ctx = FFEEXPR_contextSFUNCDEFINDEX_;
18857 break;
18858
18859 case FFEEXPR_contextSFUNCDEFACTUALARG_:
18860 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18861 assert ("bad context" == NULL);
18862 ctx = FFEEXPR_context;
18863 break;
18864
18865 default:
18866 ctx = FFEEXPR_contextINDEX_;
18867 break;
18868 }
18869
18870 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18871 ffeexpr_token_substring_1_);
18872 }
18873
18874 if (ffest_ffebad_start (FFEBAD_MISSING_COLON_IN_SUBSTR))
18875 {
18876 ffebad_here (0, ffelex_token_where_line (t),
18877 ffelex_token_where_column (t));
18878 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18879 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18880 ffebad_finish ();
18881 }
18882
18883 ffeexpr_stack_->expr = NULL;
18884 return (ffelexHandler) ffeexpr_token_substring_1_ (ft, expr, t);
18885 }
18886
18887 /* ffeexpr_token_substring_1_ -- NAME OPEN_PAREN [expr COMMA]...expr
18888
18889 Return a pointer to this function to the lexer (ffelex), which will
18890 invoke it for the next token.
18891
18892 Handle expression (which might be null) and CLOSE_PAREN. */
18893
18894 static ffelexHandler
18895 ffeexpr_token_substring_1_ (ffelexToken ft, ffebld last, ffelexToken t)
18896 {
18897 ffeexprExpr_ string;
18898 ffebld reduced;
18899 ffebld substrlist;
18900 ffebld first = ffeexpr_stack_->expr;
18901 ffebld strop;
18902 ffeinfo info;
18903 ffeinfoWhere lwh;
18904 ffeinfoWhere rwh;
18905 ffeinfoWhere where;
18906 ffeinfoKindtype first_kt;
18907 ffeinfoKindtype last_kt;
18908 ffetargetIntegerDefault first_val;
18909 ffetargetIntegerDefault last_val;
18910 ffetargetCharacterSize size;
18911 ffetargetCharacterSize strop_size_max;
18912
18913 string = ffeexpr_stack_->exprstack;
18914 strop = string->u.operand;
18915 info = ffebld_info (strop);
18916
18917 if ((first == NULL) || (ffebld_op (first) == FFEBLD_opCONTER))
18918 { /* The starting point is known. */
18919 first_val = (first == NULL) ? 1
18920 : ffebld_constant_integerdefault (ffebld_conter (first));
18921 }
18922 else
18923 { /* Assume start of the entity. */
18924 first_val = 1;
18925 }
18926
18927 if ((last != NULL) && (ffebld_op (last) == FFEBLD_opCONTER))
18928 { /* The ending point is known. */
18929 last_val = ffebld_constant_integerdefault (ffebld_conter (last));
18930
18931 if ((first == NULL) || (ffebld_op (first) == FFEBLD_opCONTER))
18932 { /* The beginning point is a constant. */
18933 if (first_val <= last_val)
18934 size = last_val - first_val + 1;
18935 else
18936 {
18937 if (0 && ffe_is_90 ())
18938 size = 0;
18939 else
18940 {
18941 size = 1;
18942 ffebad_start (FFEBAD_ZERO_SIZE);
18943 ffebad_here (0, ffelex_token_where_line (ft),
18944 ffelex_token_where_column (ft));
18945 ffebad_finish ();
18946 }
18947 }
18948 }
18949 else
18950 size = FFETARGET_charactersizeNONE;
18951
18952 strop_size_max = ffebld_size_max (strop);
18953
18954 if ((strop_size_max != FFETARGET_charactersizeNONE)
18955 && (last_val > strop_size_max))
18956 { /* Beyond maximum possible end of string. */
18957 ffebad_start (FFEBAD_RANGE_SUBSTR);
18958 ffebad_here (0, ffelex_token_where_line (ft),
18959 ffelex_token_where_column (ft));
18960 ffebad_finish ();
18961 }
18962 }
18963 else
18964 size = FFETARGET_charactersizeNONE; /* The size is not known. */
18965
18966 #if 0 /* Don't do this, or "is size of target
18967 known?" would no longer be easily
18968 answerable. To see if there is a max
18969 size, use ffebld_size_max; to get only the
18970 known size, else NONE, use
18971 ffebld_size_known; use ffebld_size if
18972 values are sure to be the same (not
18973 opSUBSTR or opCONCATENATE or known to have
18974 known length). By getting rid of this
18975 "useful info" stuff, we don't end up
18976 blank-padding the constant in the
18977 assignment "A(I:J)='XYZ'" to the known
18978 length of A. */
18979 if (size == FFETARGET_charactersizeNONE)
18980 size = strop_size_max; /* Assume we use the entire string. */
18981 #endif
18982
18983 substrlist
18984 = ffebld_new_item
18985 (first,
18986 ffebld_new_item
18987 (last,
18988 NULL
18989 )
18990 )
18991 ;
18992
18993 if (first == NULL)
18994 lwh = FFEINFO_whereCONSTANT;
18995 else
18996 lwh = ffeinfo_where (ffebld_info (first));
18997 if (last == NULL)
18998 rwh = FFEINFO_whereCONSTANT;
18999 else
19000 rwh = ffeinfo_where (ffebld_info (last));
19001
19002 switch (lwh)
19003 {
19004 case FFEINFO_whereCONSTANT:
19005 switch (rwh)
19006 {
19007 case FFEINFO_whereCONSTANT:
19008 where = FFEINFO_whereCONSTANT;
19009 break;
19010
19011 case FFEINFO_whereIMMEDIATE:
19012 where = FFEINFO_whereIMMEDIATE;
19013 break;
19014
19015 default:
19016 where = FFEINFO_whereFLEETING;
19017 break;
19018 }
19019 break;
19020
19021 case FFEINFO_whereIMMEDIATE:
19022 switch (rwh)
19023 {
19024 case FFEINFO_whereCONSTANT:
19025 case FFEINFO_whereIMMEDIATE:
19026 where = FFEINFO_whereIMMEDIATE;
19027 break;
19028
19029 default:
19030 where = FFEINFO_whereFLEETING;
19031 break;
19032 }
19033 break;
19034
19035 default:
19036 where = FFEINFO_whereFLEETING;
19037 break;
19038 }
19039
19040 if (first == NULL)
19041 first_kt = FFEINFO_kindtypeINTEGERDEFAULT;
19042 else
19043 first_kt = ffeinfo_kindtype (ffebld_info (first));
19044 if (last == NULL)
19045 last_kt = FFEINFO_kindtypeINTEGERDEFAULT;
19046 else
19047 last_kt = ffeinfo_kindtype (ffebld_info (last));
19048
19049 switch (where)
19050 {
19051 case FFEINFO_whereCONSTANT:
19052 switch (ffeinfo_where (info))
19053 {
19054 case FFEINFO_whereCONSTANT:
19055 break;
19056
19057 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
19058 where = FFEINFO_whereIMMEDIATE;
19059 break;
19060
19061 default:
19062 where = FFEINFO_whereFLEETING_CADDR;
19063 break;
19064 }
19065 break;
19066
19067 case FFEINFO_whereIMMEDIATE:
19068 switch (ffeinfo_where (info))
19069 {
19070 case FFEINFO_whereCONSTANT:
19071 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
19072 break;
19073
19074 default:
19075 where = FFEINFO_whereFLEETING_IADDR;
19076 break;
19077 }
19078 break;
19079
19080 default:
19081 switch (ffeinfo_where (info))
19082 {
19083 case FFEINFO_whereCONSTANT:
19084 where = FFEINFO_whereCONSTANT_SUBOBJECT; /* An F90 concept. */
19085 break;
19086
19087 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
19088 default:
19089 where = FFEINFO_whereFLEETING;
19090 break;
19091 }
19092 break;
19093 }
19094
19095 if (ffebld_op (strop) == FFEBLD_opANY)
19096 {
19097 reduced = ffebld_new_any ();
19098 ffebld_set_info (reduced, ffeinfo_new_any ());
19099 }
19100 else
19101 {
19102 reduced = ffebld_new_substr (strop, substrlist);
19103 ffebld_set_info (reduced, ffeinfo_new
19104 (FFEINFO_basictypeCHARACTER,
19105 ffeinfo_kindtype (info),
19106 0,
19107 FFEINFO_kindENTITY,
19108 where,
19109 size));
19110 reduced = ffeexpr_collapse_substr (reduced, ffeexpr_stack_->tokens[0]);
19111 }
19112
19113 ffeexpr_stack_->exprstack = string->previous; /* Pops not-quite-operand off
19114 stack. */
19115 string->u.operand = reduced; /* Save the line/column ffewhere info. */
19116 ffeexpr_exprstack_push_operand_ (string); /* Push it back on stack. */
19117
19118 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
19119 {
19120 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19121 ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FOO(3:5)(1:1)".... */
19122 return (ffelexHandler) ffeexpr_token_substrp_;
19123 }
19124
19125 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
19126 {
19127 ffebad_here (0, ffelex_token_where_line (t),
19128 ffelex_token_where_column (t));
19129 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
19130 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
19131 ffebad_finish ();
19132 }
19133
19134 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19135 ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FOO(3:5)(1:1)".... */
19136 return
19137 (ffelexHandler) ffeexpr_find_close_paren_ (t,
19138 (ffelexHandler)
19139 ffeexpr_token_substrp_);
19140 }
19141
19142 /* ffeexpr_token_substrp_ -- Rhs <character entity>
19143
19144 Return a pointer to this function to the lexer (ffelex), which will
19145 invoke it for the next token.
19146
19147 If OPEN_PAREN, treat as start of a substring ("(3:4)") construct, and
19148 issue error message if flag (serves as argument) is set. Else, just
19149 forward token to binary_. */
19150
19151 static ffelexHandler
19152 ffeexpr_token_substrp_ (ffelexToken t)
19153 {
19154 ffeexprContext ctx;
19155
19156 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
19157 return (ffelexHandler) ffeexpr_token_binary_ (t);
19158
19159 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
19160
19161 switch (ffeexpr_stack_->context)
19162 {
19163 case FFEEXPR_contextSFUNCDEF:
19164 case FFEEXPR_contextSFUNCDEFINDEX_:
19165 ctx = FFEEXPR_contextSFUNCDEFINDEX_;
19166 break;
19167
19168 case FFEEXPR_contextSFUNCDEFACTUALARG_:
19169 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
19170 assert ("bad context" == NULL);
19171 ctx = FFEEXPR_context;
19172 break;
19173
19174 default:
19175 ctx = FFEEXPR_contextINDEX_;
19176 break;
19177 }
19178
19179 if (!ffeexpr_is_substr_ok_)
19180 {
19181 if (ffebad_start (FFEBAD_BAD_SUBSTR))
19182 {
19183 ffebad_here (0, ffelex_token_where_line (t),
19184 ffelex_token_where_column (t));
19185 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
19186 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
19187 ffebad_finish ();
19188 }
19189
19190 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
19191 ffeexpr_token_anything_);
19192 }
19193
19194 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
19195 ffeexpr_token_substring_);
19196 }
19197
19198 static ffelexHandler
19199 ffeexpr_token_intrincheck_ (ffelexToken t)
19200 {
19201 if ((ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
19202 && ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
19203 {
19204 ffebad_string (ffeintrin_name_implementation
19205 (ffebld_symter_implementation
19206 (ffebld_left
19207 (ffeexpr_stack_->exprstack->u.operand))));
19208 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
19209 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
19210 ffebad_finish ();
19211 }
19212
19213 return (ffelexHandler) ffeexpr_token_substrp_ (t);
19214 }
19215
19216 /* ffeexpr_token_funsubstr_ -- NAME OPEN_PAREN expr
19217
19218 Return a pointer to this function to the lexer (ffelex), which will
19219 invoke it for the next token.
19220
19221 If COLON, do everything we would have done since _parenthesized_ if
19222 we had known NAME represented a kindENTITY instead of a kindFUNCTION.
19223 If not COLON, do likewise for kindFUNCTION instead. */
19224
19225 static ffelexHandler
19226 ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr, ffelexToken t)
19227 {
19228 ffeinfoWhere where;
19229 ffesymbol s;
19230 ffesymbolAttrs sa;
19231 ffebld symter = ffeexpr_stack_->exprstack->u.operand;
19232 bool needs_type;
19233 ffeintrinGen gen;
19234 ffeintrinSpec spec;
19235 ffeintrinImp imp;
19236
19237 s = ffebld_symter (symter);
19238 sa = ffesymbol_attrs (s);
19239 where = ffesymbol_where (s);
19240
19241 /* We get here only if we don't already know enough about FOO when seeing a
19242 FOO(stuff) reference, and FOO might turn out to be a CHARACTER type. If
19243 "stuff" is a substring reference, then FOO is a CHARACTER scalar type.
19244 Else FOO is a function, either intrinsic or external. If intrinsic, it
19245 wouldn't necessarily be CHARACTER type, so unless it has already been
19246 declared DUMMY, it hasn't had its type established yet. It can't be
19247 CHAR*(*) in any case, though it can have an explicit CHAR*n type. */
19248
19249 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
19250 | FFESYMBOL_attrsTYPE)));
19251
19252 needs_type = !(ffesymbol_attrs (s) & FFESYMBOL_attrsDUMMY);
19253
19254 ffesymbol_signal_change (s); /* Probably already done, but in case.... */
19255
19256 if (ffelex_token_type (t) == FFELEX_typeCOLON)
19257 { /* Definitely an ENTITY (char substring). */
19258 if (needs_type && !ffeimplic_establish_symbol (s))
19259 {
19260 ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
19261 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19262 }
19263
19264 ffesymbol_set_info (s,
19265 ffeinfo_new (ffesymbol_basictype (s),
19266 ffesymbol_kindtype (s),
19267 ffesymbol_rank (s),
19268 FFEINFO_kindENTITY,
19269 (where == FFEINFO_whereNONE)
19270 ? FFEINFO_whereLOCAL
19271 : where,
19272 ffesymbol_size (s)));
19273 ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
19274
19275 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
19276 ffesymbol_resolve_intrin (s);
19277 s = ffecom_sym_learned (s);
19278 ffesymbol_signal_unreported (s); /* For debugging purposes. */
19279
19280 ffeexpr_stack_->exprstack->u.operand
19281 = ffeexpr_collapse_symter (symter, ffeexpr_tokens_[0]);
19282
19283 return (ffelexHandler) ffeexpr_token_substring_ (ft, expr, t);
19284 }
19285
19286 /* The "stuff" isn't a substring notation, so we now know the overall
19287 reference is to a function. */
19288
19289 if (ffeintrin_is_intrinsic (ffesymbol_text (s), ffeexpr_stack_->tokens[0],
19290 FALSE, &gen, &spec, &imp))
19291 {
19292 ffebld_symter_set_generic (symter, gen);
19293 ffebld_symter_set_specific (symter, spec);
19294 ffebld_symter_set_implementation (symter, imp);
19295 ffesymbol_set_generic (s, gen);
19296 ffesymbol_set_specific (s, spec);
19297 ffesymbol_set_implementation (s, imp);
19298 ffesymbol_set_info (s,
19299 ffeinfo_new (ffesymbol_basictype (s),
19300 ffesymbol_kindtype (s),
19301 0,
19302 FFEINFO_kindFUNCTION,
19303 FFEINFO_whereINTRINSIC,
19304 ffesymbol_size (s)));
19305 }
19306 else
19307 { /* Not intrinsic, now needs CHAR type. */
19308 if (!ffeimplic_establish_symbol (s))
19309 {
19310 ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
19311 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19312 }
19313
19314 ffesymbol_set_info (s,
19315 ffeinfo_new (ffesymbol_basictype (s),
19316 ffesymbol_kindtype (s),
19317 ffesymbol_rank (s),
19318 FFEINFO_kindFUNCTION,
19319 (where == FFEINFO_whereNONE)
19320 ? FFEINFO_whereGLOBAL
19321 : where,
19322 ffesymbol_size (s)));
19323 }
19324
19325 ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
19326
19327 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
19328 ffesymbol_resolve_intrin (s);
19329 s = ffecom_sym_learned (s);
19330 ffesymbol_reference (s, ffeexpr_stack_->tokens[0], FALSE);
19331 ffesymbol_signal_unreported (s); /* For debugging purposes. */
19332 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
19333 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19334 }
19335
19336 /* ffeexpr_token_anything_ -- NAME OPEN_PAREN any-expr
19337
19338 Handle basically any expression, looking for CLOSE_PAREN. */
19339
19340 static ffelexHandler
19341 ffeexpr_token_anything_ (ffelexToken ft UNUSED, ffebld expr UNUSED,
19342 ffelexToken t)
19343 {
19344 ffeexprExpr_ e = ffeexpr_stack_->exprstack;
19345
19346 switch (ffelex_token_type (t))
19347 {
19348 case FFELEX_typeCOMMA:
19349 case FFELEX_typeCOLON:
19350 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
19351 FFEEXPR_contextACTUALARG_,
19352 ffeexpr_token_anything_);
19353
19354 default:
19355 e->u.operand = ffebld_new_any ();
19356 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
19357 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19358 ffeexpr_is_substr_ok_ = FALSE;
19359 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
19360 return (ffelexHandler) ffeexpr_token_substrp_;
19361 return (ffelexHandler) ffeexpr_token_substrp_ (t);
19362 }
19363 }
19364
19365 /* Terminate module. */
19366
19367 void
19368 ffeexpr_terminate_2 ()
19369 {
19370 assert (ffeexpr_stack_ == NULL);
19371 assert (ffeexpr_level_ == 0);
19372 }
Mirror of https://gcc.gnu.org/git/gcc.git