]> 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
* bad.c: Convert () to (void) in function definitions.
[thirdparty/gcc.git] / gcc / f / expr.c
1 /* expr.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 1997, 1998, 2001, 2002, 2003
3 Free Software Foundation, Inc.
4 Contributed by James Craig Burley.
5
6 This file is part of GNU Fortran.
7
8 GNU Fortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
11 any later version.
12
13 GNU Fortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GNU Fortran; see the file COPYING. If not, write to
20 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
21 02111-1307, USA.
22
23 Related Modules:
24 None.
25
26 Description:
27 Handles syntactic and semantic analysis of Fortran expressions.
28
29 Modifications:
30 */
31
32 /* Include files. */
33
34 #include "proj.h"
35 #include "expr.h"
36 #include "bad.h"
37 #include "bld.h"
38 #include "com.h"
39 #include "global.h"
40 #include "implic.h"
41 #include "intrin.h"
42 #include "info.h"
43 #include "lex.h"
44 #include "malloc.h"
45 #include "src.h"
46 #include "st.h"
47 #include "symbol.h"
48 #include "str.h"
49 #include "target.h"
50 #include "where.h"
51 #include "real.h"
52
53 /* Externals defined here. */
54
55
56 /* Simple definitions and enumerations. */
57
58 typedef enum
59 {
60 FFEEXPR_exprtypeUNKNOWN_,
61 FFEEXPR_exprtypeOPERAND_,
62 FFEEXPR_exprtypeUNARY_,
63 FFEEXPR_exprtypeBINARY_,
64 FFEEXPR_exprtype_
65 } ffeexprExprtype_;
66
67 typedef enum
68 {
69 FFEEXPR_operatorPOWER_,
70 FFEEXPR_operatorMULTIPLY_,
71 FFEEXPR_operatorDIVIDE_,
72 FFEEXPR_operatorADD_,
73 FFEEXPR_operatorSUBTRACT_,
74 FFEEXPR_operatorCONCATENATE_,
75 FFEEXPR_operatorLT_,
76 FFEEXPR_operatorLE_,
77 FFEEXPR_operatorEQ_,
78 FFEEXPR_operatorNE_,
79 FFEEXPR_operatorGT_,
80 FFEEXPR_operatorGE_,
81 FFEEXPR_operatorNOT_,
82 FFEEXPR_operatorAND_,
83 FFEEXPR_operatorOR_,
84 FFEEXPR_operatorXOR_,
85 FFEEXPR_operatorEQV_,
86 FFEEXPR_operatorNEQV_,
87 FFEEXPR_operator_
88 } ffeexprOperator_;
89
90 typedef enum
91 {
92 FFEEXPR_operatorprecedenceHIGHEST_ = 1,
93 FFEEXPR_operatorprecedencePOWER_ = 1,
94 FFEEXPR_operatorprecedenceMULTIPLY_ = 2,
95 FFEEXPR_operatorprecedenceDIVIDE_ = 2,
96 FFEEXPR_operatorprecedenceADD_ = 3,
97 FFEEXPR_operatorprecedenceSUBTRACT_ = 3,
98 FFEEXPR_operatorprecedenceLOWARITH_ = 3,
99 FFEEXPR_operatorprecedenceCONCATENATE_ = 3,
100 FFEEXPR_operatorprecedenceLT_ = 4,
101 FFEEXPR_operatorprecedenceLE_ = 4,
102 FFEEXPR_operatorprecedenceEQ_ = 4,
103 FFEEXPR_operatorprecedenceNE_ = 4,
104 FFEEXPR_operatorprecedenceGT_ = 4,
105 FFEEXPR_operatorprecedenceGE_ = 4,
106 FFEEXPR_operatorprecedenceNOT_ = 5,
107 FFEEXPR_operatorprecedenceAND_ = 6,
108 FFEEXPR_operatorprecedenceOR_ = 7,
109 FFEEXPR_operatorprecedenceXOR_ = 8,
110 FFEEXPR_operatorprecedenceEQV_ = 8,
111 FFEEXPR_operatorprecedenceNEQV_ = 8,
112 FFEEXPR_operatorprecedenceLOWEST_ = 8,
113 FFEEXPR_operatorprecedence_
114 } ffeexprOperatorPrecedence_;
115
116 #define FFEEXPR_operatorassociativityL2R_ TRUE
117 #define FFEEXPR_operatorassociativityR2L_ FALSE
118 #define FFEEXPR_operatorassociativityPOWER_ FFEEXPR_operatorassociativityR2L_
119 #define FFEEXPR_operatorassociativityMULTIPLY_ FFEEXPR_operatorassociativityL2R_
120 #define FFEEXPR_operatorassociativityDIVIDE_ FFEEXPR_operatorassociativityL2R_
121 #define FFEEXPR_operatorassociativityADD_ FFEEXPR_operatorassociativityL2R_
122 #define FFEEXPR_operatorassociativitySUBTRACT_ FFEEXPR_operatorassociativityL2R_
123 #define FFEEXPR_operatorassociativityCONCATENATE_ FFEEXPR_operatorassociativityL2R_
124 #define FFEEXPR_operatorassociativityLT_ FFEEXPR_operatorassociativityL2R_
125 #define FFEEXPR_operatorassociativityLE_ FFEEXPR_operatorassociativityL2R_
126 #define FFEEXPR_operatorassociativityEQ_ FFEEXPR_operatorassociativityL2R_
127 #define FFEEXPR_operatorassociativityNE_ FFEEXPR_operatorassociativityL2R_
128 #define FFEEXPR_operatorassociativityGT_ FFEEXPR_operatorassociativityL2R_
129 #define FFEEXPR_operatorassociativityGE_ FFEEXPR_operatorassociativityL2R_
130 #define FFEEXPR_operatorassociativityNOT_ FFEEXPR_operatorassociativityL2R_
131 #define FFEEXPR_operatorassociativityAND_ FFEEXPR_operatorassociativityL2R_
132 #define FFEEXPR_operatorassociativityOR_ FFEEXPR_operatorassociativityL2R_
133 #define FFEEXPR_operatorassociativityXOR_ FFEEXPR_operatorassociativityL2R_
134 #define FFEEXPR_operatorassociativityEQV_ FFEEXPR_operatorassociativityL2R_
135 #define FFEEXPR_operatorassociativityNEQV_ FFEEXPR_operatorassociativityL2R_
136
137 typedef enum
138 {
139 FFEEXPR_parentypeFUNCTION_,
140 FFEEXPR_parentypeSUBROUTINE_,
141 FFEEXPR_parentypeARRAY_,
142 FFEEXPR_parentypeSUBSTRING_,
143 FFEEXPR_parentypeFUNSUBSTR_,/* Ambig: check for colon after first expr. */
144 FFEEXPR_parentypeEQUIVALENCE_, /* Ambig: ARRAY_ or SUBSTRING_. */
145 FFEEXPR_parentypeANY_, /* Allow basically anything. */
146 FFEEXPR_parentype_
147 } ffeexprParenType_;
148
149 typedef enum
150 {
151 FFEEXPR_percentNONE_,
152 FFEEXPR_percentLOC_,
153 FFEEXPR_percentVAL_,
154 FFEEXPR_percentREF_,
155 FFEEXPR_percentDESCR_,
156 FFEEXPR_percent_
157 } ffeexprPercent_;
158
159 /* Internal typedefs. */
160
161 typedef struct _ffeexpr_expr_ *ffeexprExpr_;
162 typedef bool ffeexprOperatorAssociativity_;
163 typedef struct _ffeexpr_stack_ *ffeexprStack_;
164
165 /* Private include files. */
166
167
168 /* Internal structure definitions. */
169
170 struct _ffeexpr_expr_
171 {
172 ffeexprExpr_ previous;
173 ffelexToken token;
174 ffeexprExprtype_ type;
175 union
176 {
177 struct
178 {
179 ffeexprOperator_ op;
180 ffeexprOperatorPrecedence_ prec;
181 ffeexprOperatorAssociativity_ as;
182 }
183 operator;
184 ffebld operand;
185 }
186 u;
187 };
188
189 struct _ffeexpr_stack_
190 {
191 ffeexprStack_ previous;
192 mallocPool pool;
193 ffeexprContext context;
194 ffeexprCallback callback;
195 ffelexToken first_token;
196 ffeexprExpr_ exprstack;
197 ffelexToken tokens[10]; /* Used in certain cases, like (unary)
198 open-paren. */
199 ffebld expr; /* For first of
200 complex/implied-do/substring/array-elements
201 / actual-args expression. */
202 ffebld bound_list; /* For tracking dimension bounds list of
203 array. */
204 ffebldListBottom bottom; /* For building lists. */
205 ffeinfoRank rank; /* For elements in an array reference. */
206 bool constant; /* TRUE while elements seen so far are
207 constants. */
208 bool immediate; /* TRUE while elements seen so far are
209 immediate/constants. */
210 ffebld next_dummy; /* Next SFUNC dummy arg in arg list. */
211 ffebldListLength num_args; /* Number of dummy args expected in arg list. */
212 bool is_rhs; /* TRUE if rhs context, FALSE otherwise. */
213 ffeexprPercent_ percent; /* Current %FOO keyword. */
214 };
215
216 struct _ffeexpr_find_
217 {
218 ffelexToken t;
219 ffelexHandler after;
220 int level;
221 };
222
223 /* Static objects accessed by functions in this module. */
224
225 static ffeexprStack_ ffeexpr_stack_; /* Expression stack for semantic. */
226 static ffelexToken ffeexpr_tokens_[10]; /* Scratchpad tokens for syntactic. */
227 static ffestrOther ffeexpr_current_dotdot_; /* Current .FOO. keyword. */
228 static long ffeexpr_hollerith_count_; /* ffeexpr_token_number_ and caller. */
229 static int ffeexpr_level_; /* Level of DATA implied-DO construct. */
230 static bool ffeexpr_is_substr_ok_; /* If OPEN_PAREN as binary "op" ok. */
231 static struct _ffeexpr_find_ ffeexpr_find_;
232
233 /* Static functions (internal). */
234
235 static ffelexHandler ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr,
236 ffelexToken t);
237 static ffelexHandler ffeexpr_cb_close_paren_ambig_ (ffelexToken ft,
238 ffebld expr,
239 ffelexToken t);
240 static ffelexHandler ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t);
241 static ffelexHandler ffeexpr_cb_close_paren_c_ (ffelexToken ft,
242 ffebld expr, ffelexToken t);
243 static ffelexHandler ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr,
244 ffelexToken t);
245 static ffelexHandler ffeexpr_cb_close_paren_ci_ (ffelexToken ft,
246 ffebld expr, ffelexToken t);
247 static ffelexHandler ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr,
248 ffelexToken t);
249 static ffelexHandler ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr,
250 ffelexToken t);
251 static ffelexHandler ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr,
252 ffelexToken t);
253 static ffelexHandler ffeexpr_cb_comma_i_2_ (ffelexToken ft, ffebld expr,
254 ffelexToken t);
255 static ffelexHandler ffeexpr_cb_comma_i_3_ (ffelexToken ft, ffebld expr,
256 ffelexToken t);
257 static ffelexHandler ffeexpr_cb_comma_i_4_ (ffelexToken ft, ffebld expr,
258 ffelexToken t);
259 static ffelexHandler ffeexpr_cb_comma_i_5_ (ffelexToken t);
260 static ffelexHandler ffeexpr_cb_end_loc_ (ffelexToken ft, ffebld expr,
261 ffelexToken t);
262 static ffelexHandler ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr,
263 ffelexToken t);
264 static ffelexHandler ffeexpr_cb_end_notloc_1_ (ffelexToken t);
265 static ffesymbol ffeexpr_check_impctrl_ (ffesymbol s);
266 static void ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
267 ffebld dovar, ffelexToken dovar_t);
268 static void ffeexpr_update_impdo_ (ffebld expr, ffebld dovar);
269 static void ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar);
270 static ffeexprContext ffeexpr_context_outer_ (ffeexprStack_ s);
271 static ffeexprExpr_ ffeexpr_expr_new_ (void);
272 static void ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t);
273 static bool ffeexpr_isdigits_ (const char *p);
274 static ffelexHandler ffeexpr_token_first_lhs_ (ffelexToken t);
275 static ffelexHandler ffeexpr_token_first_lhs_1_ (ffelexToken t);
276 static ffelexHandler ffeexpr_token_first_rhs_ (ffelexToken t);
277 static ffelexHandler ffeexpr_token_first_rhs_1_ (ffelexToken t);
278 static ffelexHandler ffeexpr_token_first_rhs_2_ (ffelexToken t);
279 static ffelexHandler ffeexpr_token_first_rhs_3_ (ffelexToken t);
280 static ffelexHandler ffeexpr_token_first_rhs_4_ (ffelexToken t);
281 static ffelexHandler ffeexpr_token_first_rhs_5_ (ffelexToken t);
282 static ffelexHandler ffeexpr_token_first_rhs_6_ (ffelexToken t);
283 static ffelexHandler ffeexpr_token_namelist_ (ffelexToken t);
284 static void ffeexpr_expr_kill_ (ffeexprExpr_ e);
285 static void ffeexpr_exprstack_push_ (ffeexprExpr_ e);
286 static void ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e);
287 static void ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e);
288 static void ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e);
289 static void ffeexpr_reduce_ (void);
290 static ffebld ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op,
291 ffeexprExpr_ r);
292 static ffebld ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l,
293 ffeexprExpr_ op, ffeexprExpr_ r);
294 static ffebld ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l,
295 ffeexprExpr_ op, ffeexprExpr_ r);
296 static ffebld ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l,
297 ffeexprExpr_ op, ffeexprExpr_ r);
298 static ffebld ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op,
299 ffeexprExpr_ r);
300 static ffebld ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l,
301 ffeexprExpr_ op, ffeexprExpr_ r);
302 static ffebld ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l,
303 ffeexprExpr_ op, ffeexprExpr_ r);
304 static ffebld ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l,
305 ffeexprExpr_ op, ffeexprExpr_ r);
306 static ffebld ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r);
307 static ffebld ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op,
308 ffeexprExpr_ r);
309 static ffebld ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l,
310 ffeexprExpr_ op, ffeexprExpr_ r);
311 static ffebld ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l,
312 ffeexprExpr_ op, ffeexprExpr_ r);
313 static ffelexHandler ffeexpr_find_close_paren_ (ffelexToken t,
314 ffelexHandler after);
315 static ffelexHandler ffeexpr_nil_finished_ (ffelexToken t);
316 static ffelexHandler ffeexpr_nil_rhs_ (ffelexToken t);
317 static ffelexHandler ffeexpr_nil_period_ (ffelexToken t);
318 static ffelexHandler ffeexpr_nil_end_period_ (ffelexToken t);
319 static ffelexHandler ffeexpr_nil_swallow_period_ (ffelexToken t);
320 static ffelexHandler ffeexpr_nil_real_ (ffelexToken t);
321 static ffelexHandler ffeexpr_nil_real_exponent_ (ffelexToken t);
322 static ffelexHandler ffeexpr_nil_real_exp_sign_ (ffelexToken t);
323 static ffelexHandler ffeexpr_nil_number_ (ffelexToken t);
324 static ffelexHandler ffeexpr_nil_number_exponent_ (ffelexToken t);
325 static ffelexHandler ffeexpr_nil_number_exp_sign_ (ffelexToken t);
326 static ffelexHandler ffeexpr_nil_number_period_ (ffelexToken t);
327 static ffelexHandler ffeexpr_nil_number_per_exp_ (ffelexToken t);
328 static ffelexHandler ffeexpr_nil_number_real_ (ffelexToken t);
329 static ffelexHandler ffeexpr_nil_num_per_exp_sign_ (ffelexToken t);
330 static ffelexHandler ffeexpr_nil_number_real_exp_ (ffelexToken t);
331 static ffelexHandler ffeexpr_nil_num_real_exp_sn_ (ffelexToken t);
332 static ffelexHandler ffeexpr_nil_binary_ (ffelexToken t);
333 static ffelexHandler ffeexpr_nil_binary_period_ (ffelexToken t);
334 static ffelexHandler ffeexpr_nil_binary_end_per_ (ffelexToken t);
335 static ffelexHandler ffeexpr_nil_binary_sw_per_ (ffelexToken t);
336 static ffelexHandler ffeexpr_nil_quote_ (ffelexToken t);
337 static ffelexHandler ffeexpr_nil_apostrophe_ (ffelexToken t);
338 static ffelexHandler ffeexpr_nil_apos_char_ (ffelexToken t);
339 static ffelexHandler ffeexpr_nil_name_rhs_ (ffelexToken t);
340 static ffelexHandler ffeexpr_nil_name_apos_ (ffelexToken t);
341 static ffelexHandler ffeexpr_nil_name_apos_name_ (ffelexToken t);
342 static ffelexHandler ffeexpr_nil_percent_ (ffelexToken t);
343 static ffelexHandler ffeexpr_nil_percent_name_ (ffelexToken t);
344 static ffelexHandler ffeexpr_nil_substrp_ (ffelexToken t);
345 static ffelexHandler ffeexpr_finished_ (ffelexToken t);
346 static ffebld ffeexpr_finished_ambig_ (ffelexToken t, ffebld expr);
347 static ffelexHandler ffeexpr_token_lhs_ (ffelexToken t);
348 static ffelexHandler ffeexpr_token_rhs_ (ffelexToken t);
349 static ffelexHandler ffeexpr_token_binary_ (ffelexToken t);
350 static ffelexHandler ffeexpr_token_period_ (ffelexToken t);
351 static ffelexHandler ffeexpr_token_end_period_ (ffelexToken t);
352 static ffelexHandler ffeexpr_token_swallow_period_ (ffelexToken t);
353 static ffelexHandler ffeexpr_token_real_ (ffelexToken t);
354 static ffelexHandler ffeexpr_token_real_exponent_ (ffelexToken t);
355 static ffelexHandler ffeexpr_token_real_exp_sign_ (ffelexToken t);
356 static ffelexHandler ffeexpr_token_number_ (ffelexToken t);
357 static ffelexHandler ffeexpr_token_number_exponent_ (ffelexToken t);
358 static ffelexHandler ffeexpr_token_number_exp_sign_ (ffelexToken t);
359 static ffelexHandler ffeexpr_token_number_period_ (ffelexToken t);
360 static ffelexHandler ffeexpr_token_number_per_exp_ (ffelexToken t);
361 static ffelexHandler ffeexpr_token_number_real_ (ffelexToken t);
362 static ffelexHandler ffeexpr_token_num_per_exp_sign_ (ffelexToken t);
363 static ffelexHandler ffeexpr_token_number_real_exp_ (ffelexToken t);
364 static ffelexHandler ffeexpr_token_num_real_exp_sn_ (ffelexToken t);
365 static ffelexHandler ffeexpr_token_binary_period_ (ffelexToken t);
366 static ffelexHandler ffeexpr_token_binary_end_per_ (ffelexToken t);
367 static ffelexHandler ffeexpr_token_binary_sw_per_ (ffelexToken t);
368 static ffelexHandler ffeexpr_token_quote_ (ffelexToken t);
369 static ffelexHandler ffeexpr_token_apostrophe_ (ffelexToken t);
370 static ffelexHandler ffeexpr_token_apos_char_ (ffelexToken t);
371 static ffelexHandler ffeexpr_token_name_lhs_ (ffelexToken t);
372 static ffelexHandler ffeexpr_token_name_arg_ (ffelexToken t);
373 static ffelexHandler ffeexpr_token_name_rhs_ (ffelexToken t);
374 static ffelexHandler ffeexpr_token_name_apos_ (ffelexToken t);
375 static ffelexHandler ffeexpr_token_name_apos_name_ (ffelexToken t);
376 static ffelexHandler ffeexpr_token_percent_ (ffelexToken t);
377 static ffelexHandler ffeexpr_token_percent_name_ (ffelexToken t);
378 static ffelexHandler ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr,
379 ffelexToken t);
380 static ffelexHandler ffeexpr_token_elements_ (ffelexToken ft, ffebld expr,
381 ffelexToken t);
382 static ffelexHandler ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr,
383 ffelexToken t);
384 static ffelexHandler ffeexpr_token_substring_ (ffelexToken ft, ffebld expr,
385 ffelexToken t);
386 static ffelexHandler ffeexpr_token_substring_1_ (ffelexToken ft, ffebld expr,
387 ffelexToken t);
388 static ffelexHandler ffeexpr_token_substrp_ (ffelexToken t);
389 static ffelexHandler ffeexpr_token_intrincheck_ (ffelexToken t);
390 static ffelexHandler ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr,
391 ffelexToken t);
392 static ffelexHandler ffeexpr_token_anything_ (ffelexToken ft, ffebld expr,
393 ffelexToken t);
394 static void ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
395 ffelexToken decimal, ffelexToken fraction, ffelexToken exponent,
396 ffelexToken exponent_sign, ffelexToken exponent_digits);
397 static ffesymbol ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin);
398 static ffesymbol ffeexpr_sym_impdoitem_ (ffesymbol s, ffelexToken t);
399 static ffesymbol ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t);
400 static ffesymbol ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t);
401 static ffesymbol ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t);
402 static ffesymbol ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t);
403 static ffesymbol ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t);
404 static ffesymbol ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t);
405 static ffesymbol ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t);
406 static ffesymbol ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t);
407 static ffesymbol ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t);
408 static ffesymbol ffeexpr_declare_parenthesized_ (ffelexToken t,
409 bool maybe_intrin,
410 ffeexprParenType_ *paren_type);
411 static ffesymbol ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t);
412
413 /* Internal macros. */
414
415 #define ffeexpr_paren_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
416 #define ffeexpr_sym_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
417 \f
418 /* ffeexpr_collapse_convert -- Collapse convert expr
419
420 ffebld expr;
421 ffelexToken token;
422 expr = ffeexpr_collapse_convert(expr,token);
423
424 If the result of the expr is a constant, replaces the expr with the
425 computed constant. */
426
427 ffebld
428 ffeexpr_collapse_convert (ffebld expr, ffelexToken t)
429 {
430 ffebad error = FFEBAD;
431 ffebld l;
432 ffebldConstantUnion u;
433 ffeinfoBasictype bt;
434 ffeinfoKindtype kt;
435 ffetargetCharacterSize sz;
436 ffetargetCharacterSize sz2;
437
438 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
439 return expr;
440
441 l = ffebld_left (expr);
442
443 if (ffebld_op (l) != FFEBLD_opCONTER)
444 return expr;
445
446 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
447 {
448 case FFEINFO_basictypeANY:
449 return expr;
450
451 case FFEINFO_basictypeINTEGER:
452 sz = FFETARGET_charactersizeNONE;
453 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
454 {
455 #if FFETARGET_okINTEGER1
456 case FFEINFO_kindtypeINTEGER1:
457 switch (ffeinfo_basictype (ffebld_info (l)))
458 {
459 case FFEINFO_basictypeINTEGER:
460 switch (ffeinfo_kindtype (ffebld_info (l)))
461 {
462 #if FFETARGET_okINTEGER2
463 case FFEINFO_kindtypeINTEGER2:
464 error = ffetarget_convert_integer1_integer2
465 (ffebld_cu_ptr_integer1 (u),
466 ffebld_constant_integer2 (ffebld_conter (l)));
467 break;
468 #endif
469
470 #if FFETARGET_okINTEGER3
471 case FFEINFO_kindtypeINTEGER3:
472 error = ffetarget_convert_integer1_integer3
473 (ffebld_cu_ptr_integer1 (u),
474 ffebld_constant_integer3 (ffebld_conter (l)));
475 break;
476 #endif
477
478 #if FFETARGET_okINTEGER4
479 case FFEINFO_kindtypeINTEGER4:
480 error = ffetarget_convert_integer1_integer4
481 (ffebld_cu_ptr_integer1 (u),
482 ffebld_constant_integer4 (ffebld_conter (l)));
483 break;
484 #endif
485
486 default:
487 assert ("INTEGER1/INTEGER bad source kind type" == NULL);
488 break;
489 }
490 break;
491
492 case FFEINFO_basictypeREAL:
493 switch (ffeinfo_kindtype (ffebld_info (l)))
494 {
495 #if FFETARGET_okREAL1
496 case FFEINFO_kindtypeREAL1:
497 error = ffetarget_convert_integer1_real1
498 (ffebld_cu_ptr_integer1 (u),
499 ffebld_constant_real1 (ffebld_conter (l)));
500 break;
501 #endif
502
503 #if FFETARGET_okREAL2
504 case FFEINFO_kindtypeREAL2:
505 error = ffetarget_convert_integer1_real2
506 (ffebld_cu_ptr_integer1 (u),
507 ffebld_constant_real2 (ffebld_conter (l)));
508 break;
509 #endif
510
511 #if FFETARGET_okREAL3
512 case FFEINFO_kindtypeREAL3:
513 error = ffetarget_convert_integer1_real3
514 (ffebld_cu_ptr_integer1 (u),
515 ffebld_constant_real3 (ffebld_conter (l)));
516 break;
517 #endif
518
519 default:
520 assert ("INTEGER1/REAL bad source kind type" == NULL);
521 break;
522 }
523 break;
524
525 case FFEINFO_basictypeCOMPLEX:
526 switch (ffeinfo_kindtype (ffebld_info (l)))
527 {
528 #if FFETARGET_okCOMPLEX1
529 case FFEINFO_kindtypeREAL1:
530 error = ffetarget_convert_integer1_complex1
531 (ffebld_cu_ptr_integer1 (u),
532 ffebld_constant_complex1 (ffebld_conter (l)));
533 break;
534 #endif
535
536 #if FFETARGET_okCOMPLEX2
537 case FFEINFO_kindtypeREAL2:
538 error = ffetarget_convert_integer1_complex2
539 (ffebld_cu_ptr_integer1 (u),
540 ffebld_constant_complex2 (ffebld_conter (l)));
541 break;
542 #endif
543
544 #if FFETARGET_okCOMPLEX3
545 case FFEINFO_kindtypeREAL3:
546 error = ffetarget_convert_integer1_complex3
547 (ffebld_cu_ptr_integer1 (u),
548 ffebld_constant_complex3 (ffebld_conter (l)));
549 break;
550 #endif
551
552 default:
553 assert ("INTEGER1/COMPLEX bad source kind type" == NULL);
554 break;
555 }
556 break;
557
558 case FFEINFO_basictypeLOGICAL:
559 switch (ffeinfo_kindtype (ffebld_info (l)))
560 {
561 #if FFETARGET_okLOGICAL1
562 case FFEINFO_kindtypeLOGICAL1:
563 error = ffetarget_convert_integer1_logical1
564 (ffebld_cu_ptr_integer1 (u),
565 ffebld_constant_logical1 (ffebld_conter (l)));
566 break;
567 #endif
568
569 #if FFETARGET_okLOGICAL2
570 case FFEINFO_kindtypeLOGICAL2:
571 error = ffetarget_convert_integer1_logical2
572 (ffebld_cu_ptr_integer1 (u),
573 ffebld_constant_logical2 (ffebld_conter (l)));
574 break;
575 #endif
576
577 #if FFETARGET_okLOGICAL3
578 case FFEINFO_kindtypeLOGICAL3:
579 error = ffetarget_convert_integer1_logical3
580 (ffebld_cu_ptr_integer1 (u),
581 ffebld_constant_logical3 (ffebld_conter (l)));
582 break;
583 #endif
584
585 #if FFETARGET_okLOGICAL4
586 case FFEINFO_kindtypeLOGICAL4:
587 error = ffetarget_convert_integer1_logical4
588 (ffebld_cu_ptr_integer1 (u),
589 ffebld_constant_logical4 (ffebld_conter (l)));
590 break;
591 #endif
592
593 default:
594 assert ("INTEGER1/LOGICAL bad source kind type" == NULL);
595 break;
596 }
597 break;
598
599 case FFEINFO_basictypeCHARACTER:
600 error = ffetarget_convert_integer1_character1
601 (ffebld_cu_ptr_integer1 (u),
602 ffebld_constant_character1 (ffebld_conter (l)));
603 break;
604
605 case FFEINFO_basictypeHOLLERITH:
606 error = ffetarget_convert_integer1_hollerith
607 (ffebld_cu_ptr_integer1 (u),
608 ffebld_constant_hollerith (ffebld_conter (l)));
609 break;
610
611 case FFEINFO_basictypeTYPELESS:
612 error = ffetarget_convert_integer1_typeless
613 (ffebld_cu_ptr_integer1 (u),
614 ffebld_constant_typeless (ffebld_conter (l)));
615 break;
616
617 default:
618 assert ("INTEGER1 bad type" == NULL);
619 break;
620 }
621
622 /* If conversion operation is not implemented, return original expr. */
623 if (error == FFEBAD_NOCANDO)
624 return expr;
625
626 expr = ffebld_new_conter_with_orig
627 (ffebld_constant_new_integer1_val
628 (ffebld_cu_val_integer1 (u)), expr);
629 break;
630 #endif
631
632 #if FFETARGET_okINTEGER2
633 case FFEINFO_kindtypeINTEGER2:
634 switch (ffeinfo_basictype (ffebld_info (l)))
635 {
636 case FFEINFO_basictypeINTEGER:
637 switch (ffeinfo_kindtype (ffebld_info (l)))
638 {
639 #if FFETARGET_okINTEGER1
640 case FFEINFO_kindtypeINTEGER1:
641 error = ffetarget_convert_integer2_integer1
642 (ffebld_cu_ptr_integer2 (u),
643 ffebld_constant_integer1 (ffebld_conter (l)));
644 break;
645 #endif
646
647 #if FFETARGET_okINTEGER3
648 case FFEINFO_kindtypeINTEGER3:
649 error = ffetarget_convert_integer2_integer3
650 (ffebld_cu_ptr_integer2 (u),
651 ffebld_constant_integer3 (ffebld_conter (l)));
652 break;
653 #endif
654
655 #if FFETARGET_okINTEGER4
656 case FFEINFO_kindtypeINTEGER4:
657 error = ffetarget_convert_integer2_integer4
658 (ffebld_cu_ptr_integer2 (u),
659 ffebld_constant_integer4 (ffebld_conter (l)));
660 break;
661 #endif
662
663 default:
664 assert ("INTEGER2/INTEGER bad source kind type" == NULL);
665 break;
666 }
667 break;
668
669 case FFEINFO_basictypeREAL:
670 switch (ffeinfo_kindtype (ffebld_info (l)))
671 {
672 #if FFETARGET_okREAL1
673 case FFEINFO_kindtypeREAL1:
674 error = ffetarget_convert_integer2_real1
675 (ffebld_cu_ptr_integer2 (u),
676 ffebld_constant_real1 (ffebld_conter (l)));
677 break;
678 #endif
679
680 #if FFETARGET_okREAL2
681 case FFEINFO_kindtypeREAL2:
682 error = ffetarget_convert_integer2_real2
683 (ffebld_cu_ptr_integer2 (u),
684 ffebld_constant_real2 (ffebld_conter (l)));
685 break;
686 #endif
687
688 #if FFETARGET_okREAL3
689 case FFEINFO_kindtypeREAL3:
690 error = ffetarget_convert_integer2_real3
691 (ffebld_cu_ptr_integer2 (u),
692 ffebld_constant_real3 (ffebld_conter (l)));
693 break;
694 #endif
695
696 default:
697 assert ("INTEGER2/REAL bad source kind type" == NULL);
698 break;
699 }
700 break;
701
702 case FFEINFO_basictypeCOMPLEX:
703 switch (ffeinfo_kindtype (ffebld_info (l)))
704 {
705 #if FFETARGET_okCOMPLEX1
706 case FFEINFO_kindtypeREAL1:
707 error = ffetarget_convert_integer2_complex1
708 (ffebld_cu_ptr_integer2 (u),
709 ffebld_constant_complex1 (ffebld_conter (l)));
710 break;
711 #endif
712
713 #if FFETARGET_okCOMPLEX2
714 case FFEINFO_kindtypeREAL2:
715 error = ffetarget_convert_integer2_complex2
716 (ffebld_cu_ptr_integer2 (u),
717 ffebld_constant_complex2 (ffebld_conter (l)));
718 break;
719 #endif
720
721 #if FFETARGET_okCOMPLEX3
722 case FFEINFO_kindtypeREAL3:
723 error = ffetarget_convert_integer2_complex3
724 (ffebld_cu_ptr_integer2 (u),
725 ffebld_constant_complex3 (ffebld_conter (l)));
726 break;
727 #endif
728
729 default:
730 assert ("INTEGER2/COMPLEX bad source kind type" == NULL);
731 break;
732 }
733 break;
734
735 case FFEINFO_basictypeLOGICAL:
736 switch (ffeinfo_kindtype (ffebld_info (l)))
737 {
738 #if FFETARGET_okLOGICAL1
739 case FFEINFO_kindtypeLOGICAL1:
740 error = ffetarget_convert_integer2_logical1
741 (ffebld_cu_ptr_integer2 (u),
742 ffebld_constant_logical1 (ffebld_conter (l)));
743 break;
744 #endif
745
746 #if FFETARGET_okLOGICAL2
747 case FFEINFO_kindtypeLOGICAL2:
748 error = ffetarget_convert_integer2_logical2
749 (ffebld_cu_ptr_integer2 (u),
750 ffebld_constant_logical2 (ffebld_conter (l)));
751 break;
752 #endif
753
754 #if FFETARGET_okLOGICAL3
755 case FFEINFO_kindtypeLOGICAL3:
756 error = ffetarget_convert_integer2_logical3
757 (ffebld_cu_ptr_integer2 (u),
758 ffebld_constant_logical3 (ffebld_conter (l)));
759 break;
760 #endif
761
762 #if FFETARGET_okLOGICAL4
763 case FFEINFO_kindtypeLOGICAL4:
764 error = ffetarget_convert_integer2_logical4
765 (ffebld_cu_ptr_integer2 (u),
766 ffebld_constant_logical4 (ffebld_conter (l)));
767 break;
768 #endif
769
770 default:
771 assert ("INTEGER2/LOGICAL bad source kind type" == NULL);
772 break;
773 }
774 break;
775
776 case FFEINFO_basictypeCHARACTER:
777 error = ffetarget_convert_integer2_character1
778 (ffebld_cu_ptr_integer2 (u),
779 ffebld_constant_character1 (ffebld_conter (l)));
780 break;
781
782 case FFEINFO_basictypeHOLLERITH:
783 error = ffetarget_convert_integer2_hollerith
784 (ffebld_cu_ptr_integer2 (u),
785 ffebld_constant_hollerith (ffebld_conter (l)));
786 break;
787
788 case FFEINFO_basictypeTYPELESS:
789 error = ffetarget_convert_integer2_typeless
790 (ffebld_cu_ptr_integer2 (u),
791 ffebld_constant_typeless (ffebld_conter (l)));
792 break;
793
794 default:
795 assert ("INTEGER2 bad type" == NULL);
796 break;
797 }
798
799 /* If conversion operation is not implemented, return original expr. */
800 if (error == FFEBAD_NOCANDO)
801 return expr;
802
803 expr = ffebld_new_conter_with_orig
804 (ffebld_constant_new_integer2_val
805 (ffebld_cu_val_integer2 (u)), expr);
806 break;
807 #endif
808
809 #if FFETARGET_okINTEGER3
810 case FFEINFO_kindtypeINTEGER3:
811 switch (ffeinfo_basictype (ffebld_info (l)))
812 {
813 case FFEINFO_basictypeINTEGER:
814 switch (ffeinfo_kindtype (ffebld_info (l)))
815 {
816 #if FFETARGET_okINTEGER1
817 case FFEINFO_kindtypeINTEGER1:
818 error = ffetarget_convert_integer3_integer1
819 (ffebld_cu_ptr_integer3 (u),
820 ffebld_constant_integer1 (ffebld_conter (l)));
821 break;
822 #endif
823
824 #if FFETARGET_okINTEGER2
825 case FFEINFO_kindtypeINTEGER2:
826 error = ffetarget_convert_integer3_integer2
827 (ffebld_cu_ptr_integer3 (u),
828 ffebld_constant_integer2 (ffebld_conter (l)));
829 break;
830 #endif
831
832 #if FFETARGET_okINTEGER4
833 case FFEINFO_kindtypeINTEGER4:
834 error = ffetarget_convert_integer3_integer4
835 (ffebld_cu_ptr_integer3 (u),
836 ffebld_constant_integer4 (ffebld_conter (l)));
837 break;
838 #endif
839
840 default:
841 assert ("INTEGER3/INTEGER bad source kind type" == NULL);
842 break;
843 }
844 break;
845
846 case FFEINFO_basictypeREAL:
847 switch (ffeinfo_kindtype (ffebld_info (l)))
848 {
849 #if FFETARGET_okREAL1
850 case FFEINFO_kindtypeREAL1:
851 error = ffetarget_convert_integer3_real1
852 (ffebld_cu_ptr_integer3 (u),
853 ffebld_constant_real1 (ffebld_conter (l)));
854 break;
855 #endif
856
857 #if FFETARGET_okREAL2
858 case FFEINFO_kindtypeREAL2:
859 error = ffetarget_convert_integer3_real2
860 (ffebld_cu_ptr_integer3 (u),
861 ffebld_constant_real2 (ffebld_conter (l)));
862 break;
863 #endif
864
865 #if FFETARGET_okREAL3
866 case FFEINFO_kindtypeREAL3:
867 error = ffetarget_convert_integer3_real3
868 (ffebld_cu_ptr_integer3 (u),
869 ffebld_constant_real3 (ffebld_conter (l)));
870 break;
871 #endif
872
873 default:
874 assert ("INTEGER3/REAL bad source kind type" == NULL);
875 break;
876 }
877 break;
878
879 case FFEINFO_basictypeCOMPLEX:
880 switch (ffeinfo_kindtype (ffebld_info (l)))
881 {
882 #if FFETARGET_okCOMPLEX1
883 case FFEINFO_kindtypeREAL1:
884 error = ffetarget_convert_integer3_complex1
885 (ffebld_cu_ptr_integer3 (u),
886 ffebld_constant_complex1 (ffebld_conter (l)));
887 break;
888 #endif
889
890 #if FFETARGET_okCOMPLEX2
891 case FFEINFO_kindtypeREAL2:
892 error = ffetarget_convert_integer3_complex2
893 (ffebld_cu_ptr_integer3 (u),
894 ffebld_constant_complex2 (ffebld_conter (l)));
895 break;
896 #endif
897
898 #if FFETARGET_okCOMPLEX3
899 case FFEINFO_kindtypeREAL3:
900 error = ffetarget_convert_integer3_complex3
901 (ffebld_cu_ptr_integer3 (u),
902 ffebld_constant_complex3 (ffebld_conter (l)));
903 break;
904 #endif
905
906 default:
907 assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
908 break;
909 }
910 break;
911
912 case FFEINFO_basictypeLOGICAL:
913 switch (ffeinfo_kindtype (ffebld_info (l)))
914 {
915 #if FFETARGET_okLOGICAL1
916 case FFEINFO_kindtypeLOGICAL1:
917 error = ffetarget_convert_integer3_logical1
918 (ffebld_cu_ptr_integer3 (u),
919 ffebld_constant_logical1 (ffebld_conter (l)));
920 break;
921 #endif
922
923 #if FFETARGET_okLOGICAL2
924 case FFEINFO_kindtypeLOGICAL2:
925 error = ffetarget_convert_integer3_logical2
926 (ffebld_cu_ptr_integer3 (u),
927 ffebld_constant_logical2 (ffebld_conter (l)));
928 break;
929 #endif
930
931 #if FFETARGET_okLOGICAL3
932 case FFEINFO_kindtypeLOGICAL3:
933 error = ffetarget_convert_integer3_logical3
934 (ffebld_cu_ptr_integer3 (u),
935 ffebld_constant_logical3 (ffebld_conter (l)));
936 break;
937 #endif
938
939 #if FFETARGET_okLOGICAL4
940 case FFEINFO_kindtypeLOGICAL4:
941 error = ffetarget_convert_integer3_logical4
942 (ffebld_cu_ptr_integer3 (u),
943 ffebld_constant_logical4 (ffebld_conter (l)));
944 break;
945 #endif
946
947 default:
948 assert ("INTEGER3/LOGICAL bad source kind type" == NULL);
949 break;
950 }
951 break;
952
953 case FFEINFO_basictypeCHARACTER:
954 error = ffetarget_convert_integer3_character1
955 (ffebld_cu_ptr_integer3 (u),
956 ffebld_constant_character1 (ffebld_conter (l)));
957 break;
958
959 case FFEINFO_basictypeHOLLERITH:
960 error = ffetarget_convert_integer3_hollerith
961 (ffebld_cu_ptr_integer3 (u),
962 ffebld_constant_hollerith (ffebld_conter (l)));
963 break;
964
965 case FFEINFO_basictypeTYPELESS:
966 error = ffetarget_convert_integer3_typeless
967 (ffebld_cu_ptr_integer3 (u),
968 ffebld_constant_typeless (ffebld_conter (l)));
969 break;
970
971 default:
972 assert ("INTEGER3 bad type" == NULL);
973 break;
974 }
975
976 /* If conversion operation is not implemented, return original expr. */
977 if (error == FFEBAD_NOCANDO)
978 return expr;
979
980 expr = ffebld_new_conter_with_orig
981 (ffebld_constant_new_integer3_val
982 (ffebld_cu_val_integer3 (u)), expr);
983 break;
984 #endif
985
986 #if FFETARGET_okINTEGER4
987 case FFEINFO_kindtypeINTEGER4:
988 switch (ffeinfo_basictype (ffebld_info (l)))
989 {
990 case FFEINFO_basictypeINTEGER:
991 switch (ffeinfo_kindtype (ffebld_info (l)))
992 {
993 #if FFETARGET_okINTEGER1
994 case FFEINFO_kindtypeINTEGER1:
995 error = ffetarget_convert_integer4_integer1
996 (ffebld_cu_ptr_integer4 (u),
997 ffebld_constant_integer1 (ffebld_conter (l)));
998 break;
999 #endif
1000
1001 #if FFETARGET_okINTEGER2
1002 case FFEINFO_kindtypeINTEGER2:
1003 error = ffetarget_convert_integer4_integer2
1004 (ffebld_cu_ptr_integer4 (u),
1005 ffebld_constant_integer2 (ffebld_conter (l)));
1006 break;
1007 #endif
1008
1009 #if FFETARGET_okINTEGER3
1010 case FFEINFO_kindtypeINTEGER3:
1011 error = ffetarget_convert_integer4_integer3
1012 (ffebld_cu_ptr_integer4 (u),
1013 ffebld_constant_integer3 (ffebld_conter (l)));
1014 break;
1015 #endif
1016
1017 default:
1018 assert ("INTEGER4/INTEGER bad source kind type" == NULL);
1019 break;
1020 }
1021 break;
1022
1023 case FFEINFO_basictypeREAL:
1024 switch (ffeinfo_kindtype (ffebld_info (l)))
1025 {
1026 #if FFETARGET_okREAL1
1027 case FFEINFO_kindtypeREAL1:
1028 error = ffetarget_convert_integer4_real1
1029 (ffebld_cu_ptr_integer4 (u),
1030 ffebld_constant_real1 (ffebld_conter (l)));
1031 break;
1032 #endif
1033
1034 #if FFETARGET_okREAL2
1035 case FFEINFO_kindtypeREAL2:
1036 error = ffetarget_convert_integer4_real2
1037 (ffebld_cu_ptr_integer4 (u),
1038 ffebld_constant_real2 (ffebld_conter (l)));
1039 break;
1040 #endif
1041
1042 #if FFETARGET_okREAL3
1043 case FFEINFO_kindtypeREAL3:
1044 error = ffetarget_convert_integer4_real3
1045 (ffebld_cu_ptr_integer4 (u),
1046 ffebld_constant_real3 (ffebld_conter (l)));
1047 break;
1048 #endif
1049
1050 default:
1051 assert ("INTEGER4/REAL bad source kind type" == NULL);
1052 break;
1053 }
1054 break;
1055
1056 case FFEINFO_basictypeCOMPLEX:
1057 switch (ffeinfo_kindtype (ffebld_info (l)))
1058 {
1059 #if FFETARGET_okCOMPLEX1
1060 case FFEINFO_kindtypeREAL1:
1061 error = ffetarget_convert_integer4_complex1
1062 (ffebld_cu_ptr_integer4 (u),
1063 ffebld_constant_complex1 (ffebld_conter (l)));
1064 break;
1065 #endif
1066
1067 #if FFETARGET_okCOMPLEX2
1068 case FFEINFO_kindtypeREAL2:
1069 error = ffetarget_convert_integer4_complex2
1070 (ffebld_cu_ptr_integer4 (u),
1071 ffebld_constant_complex2 (ffebld_conter (l)));
1072 break;
1073 #endif
1074
1075 #if FFETARGET_okCOMPLEX3
1076 case FFEINFO_kindtypeREAL3:
1077 error = ffetarget_convert_integer4_complex3
1078 (ffebld_cu_ptr_integer4 (u),
1079 ffebld_constant_complex3 (ffebld_conter (l)));
1080 break;
1081 #endif
1082
1083 default:
1084 assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
1085 break;
1086 }
1087 break;
1088
1089 case FFEINFO_basictypeLOGICAL:
1090 switch (ffeinfo_kindtype (ffebld_info (l)))
1091 {
1092 #if FFETARGET_okLOGICAL1
1093 case FFEINFO_kindtypeLOGICAL1:
1094 error = ffetarget_convert_integer4_logical1
1095 (ffebld_cu_ptr_integer4 (u),
1096 ffebld_constant_logical1 (ffebld_conter (l)));
1097 break;
1098 #endif
1099
1100 #if FFETARGET_okLOGICAL2
1101 case FFEINFO_kindtypeLOGICAL2:
1102 error = ffetarget_convert_integer4_logical2
1103 (ffebld_cu_ptr_integer4 (u),
1104 ffebld_constant_logical2 (ffebld_conter (l)));
1105 break;
1106 #endif
1107
1108 #if FFETARGET_okLOGICAL3
1109 case FFEINFO_kindtypeLOGICAL3:
1110 error = ffetarget_convert_integer4_logical3
1111 (ffebld_cu_ptr_integer4 (u),
1112 ffebld_constant_logical3 (ffebld_conter (l)));
1113 break;
1114 #endif
1115
1116 #if FFETARGET_okLOGICAL4
1117 case FFEINFO_kindtypeLOGICAL4:
1118 error = ffetarget_convert_integer4_logical4
1119 (ffebld_cu_ptr_integer4 (u),
1120 ffebld_constant_logical4 (ffebld_conter (l)));
1121 break;
1122 #endif
1123
1124 default:
1125 assert ("INTEGER4/LOGICAL bad source kind type" == NULL);
1126 break;
1127 }
1128 break;
1129
1130 case FFEINFO_basictypeCHARACTER:
1131 error = ffetarget_convert_integer4_character1
1132 (ffebld_cu_ptr_integer4 (u),
1133 ffebld_constant_character1 (ffebld_conter (l)));
1134 break;
1135
1136 case FFEINFO_basictypeHOLLERITH:
1137 error = ffetarget_convert_integer4_hollerith
1138 (ffebld_cu_ptr_integer4 (u),
1139 ffebld_constant_hollerith (ffebld_conter (l)));
1140 break;
1141
1142 case FFEINFO_basictypeTYPELESS:
1143 error = ffetarget_convert_integer4_typeless
1144 (ffebld_cu_ptr_integer4 (u),
1145 ffebld_constant_typeless (ffebld_conter (l)));
1146 break;
1147
1148 default:
1149 assert ("INTEGER4 bad type" == NULL);
1150 break;
1151 }
1152
1153 /* If conversion operation is not implemented, return original expr. */
1154 if (error == FFEBAD_NOCANDO)
1155 return expr;
1156
1157 expr = ffebld_new_conter_with_orig
1158 (ffebld_constant_new_integer4_val
1159 (ffebld_cu_val_integer4 (u)), expr);
1160 break;
1161 #endif
1162
1163 default:
1164 assert ("bad integer kind type" == NULL);
1165 break;
1166 }
1167 break;
1168
1169 case FFEINFO_basictypeLOGICAL:
1170 sz = FFETARGET_charactersizeNONE;
1171 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1172 {
1173 #if FFETARGET_okLOGICAL1
1174 case FFEINFO_kindtypeLOGICAL1:
1175 switch (ffeinfo_basictype (ffebld_info (l)))
1176 {
1177 case FFEINFO_basictypeLOGICAL:
1178 switch (ffeinfo_kindtype (ffebld_info (l)))
1179 {
1180 #if FFETARGET_okLOGICAL2
1181 case FFEINFO_kindtypeLOGICAL2:
1182 error = ffetarget_convert_logical1_logical2
1183 (ffebld_cu_ptr_logical1 (u),
1184 ffebld_constant_logical2 (ffebld_conter (l)));
1185 break;
1186 #endif
1187
1188 #if FFETARGET_okLOGICAL3
1189 case FFEINFO_kindtypeLOGICAL3:
1190 error = ffetarget_convert_logical1_logical3
1191 (ffebld_cu_ptr_logical1 (u),
1192 ffebld_constant_logical3 (ffebld_conter (l)));
1193 break;
1194 #endif
1195
1196 #if FFETARGET_okLOGICAL4
1197 case FFEINFO_kindtypeLOGICAL4:
1198 error = ffetarget_convert_logical1_logical4
1199 (ffebld_cu_ptr_logical1 (u),
1200 ffebld_constant_logical4 (ffebld_conter (l)));
1201 break;
1202 #endif
1203
1204 default:
1205 assert ("LOGICAL1/LOGICAL bad source kind type" == NULL);
1206 break;
1207 }
1208 break;
1209
1210 case FFEINFO_basictypeINTEGER:
1211 switch (ffeinfo_kindtype (ffebld_info (l)))
1212 {
1213 #if FFETARGET_okINTEGER1
1214 case FFEINFO_kindtypeINTEGER1:
1215 error = ffetarget_convert_logical1_integer1
1216 (ffebld_cu_ptr_logical1 (u),
1217 ffebld_constant_integer1 (ffebld_conter (l)));
1218 break;
1219 #endif
1220
1221 #if FFETARGET_okINTEGER2
1222 case FFEINFO_kindtypeINTEGER2:
1223 error = ffetarget_convert_logical1_integer2
1224 (ffebld_cu_ptr_logical1 (u),
1225 ffebld_constant_integer2 (ffebld_conter (l)));
1226 break;
1227 #endif
1228
1229 #if FFETARGET_okINTEGER3
1230 case FFEINFO_kindtypeINTEGER3:
1231 error = ffetarget_convert_logical1_integer3
1232 (ffebld_cu_ptr_logical1 (u),
1233 ffebld_constant_integer3 (ffebld_conter (l)));
1234 break;
1235 #endif
1236
1237 #if FFETARGET_okINTEGER4
1238 case FFEINFO_kindtypeINTEGER4:
1239 error = ffetarget_convert_logical1_integer4
1240 (ffebld_cu_ptr_logical1 (u),
1241 ffebld_constant_integer4 (ffebld_conter (l)));
1242 break;
1243 #endif
1244
1245 default:
1246 assert ("LOGICAL1/INTEGER bad source kind type" == NULL);
1247 break;
1248 }
1249 break;
1250
1251 case FFEINFO_basictypeCHARACTER:
1252 error = ffetarget_convert_logical1_character1
1253 (ffebld_cu_ptr_logical1 (u),
1254 ffebld_constant_character1 (ffebld_conter (l)));
1255 break;
1256
1257 case FFEINFO_basictypeHOLLERITH:
1258 error = ffetarget_convert_logical1_hollerith
1259 (ffebld_cu_ptr_logical1 (u),
1260 ffebld_constant_hollerith (ffebld_conter (l)));
1261 break;
1262
1263 case FFEINFO_basictypeTYPELESS:
1264 error = ffetarget_convert_logical1_typeless
1265 (ffebld_cu_ptr_logical1 (u),
1266 ffebld_constant_typeless (ffebld_conter (l)));
1267 break;
1268
1269 default:
1270 assert ("LOGICAL1 bad type" == NULL);
1271 break;
1272 }
1273
1274 /* If conversion operation is not implemented, return original expr. */
1275 if (error == FFEBAD_NOCANDO)
1276 return expr;
1277
1278 expr = ffebld_new_conter_with_orig
1279 (ffebld_constant_new_logical1_val
1280 (ffebld_cu_val_logical1 (u)), expr);
1281 break;
1282 #endif
1283
1284 #if FFETARGET_okLOGICAL2
1285 case FFEINFO_kindtypeLOGICAL2:
1286 switch (ffeinfo_basictype (ffebld_info (l)))
1287 {
1288 case FFEINFO_basictypeLOGICAL:
1289 switch (ffeinfo_kindtype (ffebld_info (l)))
1290 {
1291 #if FFETARGET_okLOGICAL1
1292 case FFEINFO_kindtypeLOGICAL1:
1293 error = ffetarget_convert_logical2_logical1
1294 (ffebld_cu_ptr_logical2 (u),
1295 ffebld_constant_logical1 (ffebld_conter (l)));
1296 break;
1297 #endif
1298
1299 #if FFETARGET_okLOGICAL3
1300 case FFEINFO_kindtypeLOGICAL3:
1301 error = ffetarget_convert_logical2_logical3
1302 (ffebld_cu_ptr_logical2 (u),
1303 ffebld_constant_logical3 (ffebld_conter (l)));
1304 break;
1305 #endif
1306
1307 #if FFETARGET_okLOGICAL4
1308 case FFEINFO_kindtypeLOGICAL4:
1309 error = ffetarget_convert_logical2_logical4
1310 (ffebld_cu_ptr_logical2 (u),
1311 ffebld_constant_logical4 (ffebld_conter (l)));
1312 break;
1313 #endif
1314
1315 default:
1316 assert ("LOGICAL2/LOGICAL bad source kind type" == NULL);
1317 break;
1318 }
1319 break;
1320
1321 case FFEINFO_basictypeINTEGER:
1322 switch (ffeinfo_kindtype (ffebld_info (l)))
1323 {
1324 #if FFETARGET_okINTEGER1
1325 case FFEINFO_kindtypeINTEGER1:
1326 error = ffetarget_convert_logical2_integer1
1327 (ffebld_cu_ptr_logical2 (u),
1328 ffebld_constant_integer1 (ffebld_conter (l)));
1329 break;
1330 #endif
1331
1332 #if FFETARGET_okINTEGER2
1333 case FFEINFO_kindtypeINTEGER2:
1334 error = ffetarget_convert_logical2_integer2
1335 (ffebld_cu_ptr_logical2 (u),
1336 ffebld_constant_integer2 (ffebld_conter (l)));
1337 break;
1338 #endif
1339
1340 #if FFETARGET_okINTEGER3
1341 case FFEINFO_kindtypeINTEGER3:
1342 error = ffetarget_convert_logical2_integer3
1343 (ffebld_cu_ptr_logical2 (u),
1344 ffebld_constant_integer3 (ffebld_conter (l)));
1345 break;
1346 #endif
1347
1348 #if FFETARGET_okINTEGER4
1349 case FFEINFO_kindtypeINTEGER4:
1350 error = ffetarget_convert_logical2_integer4
1351 (ffebld_cu_ptr_logical2 (u),
1352 ffebld_constant_integer4 (ffebld_conter (l)));
1353 break;
1354 #endif
1355
1356 default:
1357 assert ("LOGICAL2/INTEGER bad source kind type" == NULL);
1358 break;
1359 }
1360 break;
1361
1362 case FFEINFO_basictypeCHARACTER:
1363 error = ffetarget_convert_logical2_character1
1364 (ffebld_cu_ptr_logical2 (u),
1365 ffebld_constant_character1 (ffebld_conter (l)));
1366 break;
1367
1368 case FFEINFO_basictypeHOLLERITH:
1369 error = ffetarget_convert_logical2_hollerith
1370 (ffebld_cu_ptr_logical2 (u),
1371 ffebld_constant_hollerith (ffebld_conter (l)));
1372 break;
1373
1374 case FFEINFO_basictypeTYPELESS:
1375 error = ffetarget_convert_logical2_typeless
1376 (ffebld_cu_ptr_logical2 (u),
1377 ffebld_constant_typeless (ffebld_conter (l)));
1378 break;
1379
1380 default:
1381 assert ("LOGICAL2 bad type" == NULL);
1382 break;
1383 }
1384
1385 /* If conversion operation is not implemented, return original expr. */
1386 if (error == FFEBAD_NOCANDO)
1387 return expr;
1388
1389 expr = ffebld_new_conter_with_orig
1390 (ffebld_constant_new_logical2_val
1391 (ffebld_cu_val_logical2 (u)), expr);
1392 break;
1393 #endif
1394
1395 #if FFETARGET_okLOGICAL3
1396 case FFEINFO_kindtypeLOGICAL3:
1397 switch (ffeinfo_basictype (ffebld_info (l)))
1398 {
1399 case FFEINFO_basictypeLOGICAL:
1400 switch (ffeinfo_kindtype (ffebld_info (l)))
1401 {
1402 #if FFETARGET_okLOGICAL1
1403 case FFEINFO_kindtypeLOGICAL1:
1404 error = ffetarget_convert_logical3_logical1
1405 (ffebld_cu_ptr_logical3 (u),
1406 ffebld_constant_logical1 (ffebld_conter (l)));
1407 break;
1408 #endif
1409
1410 #if FFETARGET_okLOGICAL2
1411 case FFEINFO_kindtypeLOGICAL2:
1412 error = ffetarget_convert_logical3_logical2
1413 (ffebld_cu_ptr_logical3 (u),
1414 ffebld_constant_logical2 (ffebld_conter (l)));
1415 break;
1416 #endif
1417
1418 #if FFETARGET_okLOGICAL4
1419 case FFEINFO_kindtypeLOGICAL4:
1420 error = ffetarget_convert_logical3_logical4
1421 (ffebld_cu_ptr_logical3 (u),
1422 ffebld_constant_logical4 (ffebld_conter (l)));
1423 break;
1424 #endif
1425
1426 default:
1427 assert ("LOGICAL3/LOGICAL bad source kind type" == NULL);
1428 break;
1429 }
1430 break;
1431
1432 case FFEINFO_basictypeINTEGER:
1433 switch (ffeinfo_kindtype (ffebld_info (l)))
1434 {
1435 #if FFETARGET_okINTEGER1
1436 case FFEINFO_kindtypeINTEGER1:
1437 error = ffetarget_convert_logical3_integer1
1438 (ffebld_cu_ptr_logical3 (u),
1439 ffebld_constant_integer1 (ffebld_conter (l)));
1440 break;
1441 #endif
1442
1443 #if FFETARGET_okINTEGER2
1444 case FFEINFO_kindtypeINTEGER2:
1445 error = ffetarget_convert_logical3_integer2
1446 (ffebld_cu_ptr_logical3 (u),
1447 ffebld_constant_integer2 (ffebld_conter (l)));
1448 break;
1449 #endif
1450
1451 #if FFETARGET_okINTEGER3
1452 case FFEINFO_kindtypeINTEGER3:
1453 error = ffetarget_convert_logical3_integer3
1454 (ffebld_cu_ptr_logical3 (u),
1455 ffebld_constant_integer3 (ffebld_conter (l)));
1456 break;
1457 #endif
1458
1459 #if FFETARGET_okINTEGER4
1460 case FFEINFO_kindtypeINTEGER4:
1461 error = ffetarget_convert_logical3_integer4
1462 (ffebld_cu_ptr_logical3 (u),
1463 ffebld_constant_integer4 (ffebld_conter (l)));
1464 break;
1465 #endif
1466
1467 default:
1468 assert ("LOGICAL3/INTEGER bad source kind type" == NULL);
1469 break;
1470 }
1471 break;
1472
1473 case FFEINFO_basictypeCHARACTER:
1474 error = ffetarget_convert_logical3_character1
1475 (ffebld_cu_ptr_logical3 (u),
1476 ffebld_constant_character1 (ffebld_conter (l)));
1477 break;
1478
1479 case FFEINFO_basictypeHOLLERITH:
1480 error = ffetarget_convert_logical3_hollerith
1481 (ffebld_cu_ptr_logical3 (u),
1482 ffebld_constant_hollerith (ffebld_conter (l)));
1483 break;
1484
1485 case FFEINFO_basictypeTYPELESS:
1486 error = ffetarget_convert_logical3_typeless
1487 (ffebld_cu_ptr_logical3 (u),
1488 ffebld_constant_typeless (ffebld_conter (l)));
1489 break;
1490
1491 default:
1492 assert ("LOGICAL3 bad type" == NULL);
1493 break;
1494 }
1495
1496 /* If conversion operation is not implemented, return original expr. */
1497 if (error == FFEBAD_NOCANDO)
1498 return expr;
1499
1500 expr = ffebld_new_conter_with_orig
1501 (ffebld_constant_new_logical3_val
1502 (ffebld_cu_val_logical3 (u)), expr);
1503 break;
1504 #endif
1505
1506 #if FFETARGET_okLOGICAL4
1507 case FFEINFO_kindtypeLOGICAL4:
1508 switch (ffeinfo_basictype (ffebld_info (l)))
1509 {
1510 case FFEINFO_basictypeLOGICAL:
1511 switch (ffeinfo_kindtype (ffebld_info (l)))
1512 {
1513 #if FFETARGET_okLOGICAL1
1514 case FFEINFO_kindtypeLOGICAL1:
1515 error = ffetarget_convert_logical4_logical1
1516 (ffebld_cu_ptr_logical4 (u),
1517 ffebld_constant_logical1 (ffebld_conter (l)));
1518 break;
1519 #endif
1520
1521 #if FFETARGET_okLOGICAL2
1522 case FFEINFO_kindtypeLOGICAL2:
1523 error = ffetarget_convert_logical4_logical2
1524 (ffebld_cu_ptr_logical4 (u),
1525 ffebld_constant_logical2 (ffebld_conter (l)));
1526 break;
1527 #endif
1528
1529 #if FFETARGET_okLOGICAL3
1530 case FFEINFO_kindtypeLOGICAL3:
1531 error = ffetarget_convert_logical4_logical3
1532 (ffebld_cu_ptr_logical4 (u),
1533 ffebld_constant_logical3 (ffebld_conter (l)));
1534 break;
1535 #endif
1536
1537 default:
1538 assert ("LOGICAL4/LOGICAL bad source kind type" == NULL);
1539 break;
1540 }
1541 break;
1542
1543 case FFEINFO_basictypeINTEGER:
1544 switch (ffeinfo_kindtype (ffebld_info (l)))
1545 {
1546 #if FFETARGET_okINTEGER1
1547 case FFEINFO_kindtypeINTEGER1:
1548 error = ffetarget_convert_logical4_integer1
1549 (ffebld_cu_ptr_logical4 (u),
1550 ffebld_constant_integer1 (ffebld_conter (l)));
1551 break;
1552 #endif
1553
1554 #if FFETARGET_okINTEGER2
1555 case FFEINFO_kindtypeINTEGER2:
1556 error = ffetarget_convert_logical4_integer2
1557 (ffebld_cu_ptr_logical4 (u),
1558 ffebld_constant_integer2 (ffebld_conter (l)));
1559 break;
1560 #endif
1561
1562 #if FFETARGET_okINTEGER3
1563 case FFEINFO_kindtypeINTEGER3:
1564 error = ffetarget_convert_logical4_integer3
1565 (ffebld_cu_ptr_logical4 (u),
1566 ffebld_constant_integer3 (ffebld_conter (l)));
1567 break;
1568 #endif
1569
1570 #if FFETARGET_okINTEGER4
1571 case FFEINFO_kindtypeINTEGER4:
1572 error = ffetarget_convert_logical4_integer4
1573 (ffebld_cu_ptr_logical4 (u),
1574 ffebld_constant_integer4 (ffebld_conter (l)));
1575 break;
1576 #endif
1577
1578 default:
1579 assert ("LOGICAL4/INTEGER bad source kind type" == NULL);
1580 break;
1581 }
1582 break;
1583
1584 case FFEINFO_basictypeCHARACTER:
1585 error = ffetarget_convert_logical4_character1
1586 (ffebld_cu_ptr_logical4 (u),
1587 ffebld_constant_character1 (ffebld_conter (l)));
1588 break;
1589
1590 case FFEINFO_basictypeHOLLERITH:
1591 error = ffetarget_convert_logical4_hollerith
1592 (ffebld_cu_ptr_logical4 (u),
1593 ffebld_constant_hollerith (ffebld_conter (l)));
1594 break;
1595
1596 case FFEINFO_basictypeTYPELESS:
1597 error = ffetarget_convert_logical4_typeless
1598 (ffebld_cu_ptr_logical4 (u),
1599 ffebld_constant_typeless (ffebld_conter (l)));
1600 break;
1601
1602 default:
1603 assert ("LOGICAL4 bad type" == NULL);
1604 break;
1605 }
1606
1607 /* If conversion operation is not implemented, return original expr. */
1608 if (error == FFEBAD_NOCANDO)
1609 return expr;
1610
1611 expr = ffebld_new_conter_with_orig
1612 (ffebld_constant_new_logical4_val
1613 (ffebld_cu_val_logical4 (u)), expr);
1614 break;
1615 #endif
1616
1617 default:
1618 assert ("bad logical kind type" == NULL);
1619 break;
1620 }
1621 break;
1622
1623 case FFEINFO_basictypeREAL:
1624 sz = FFETARGET_charactersizeNONE;
1625 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1626 {
1627 #if FFETARGET_okREAL1
1628 case FFEINFO_kindtypeREAL1:
1629 switch (ffeinfo_basictype (ffebld_info (l)))
1630 {
1631 case FFEINFO_basictypeINTEGER:
1632 switch (ffeinfo_kindtype (ffebld_info (l)))
1633 {
1634 #if FFETARGET_okINTEGER1
1635 case FFEINFO_kindtypeINTEGER1:
1636 error = ffetarget_convert_real1_integer1
1637 (ffebld_cu_ptr_real1 (u),
1638 ffebld_constant_integer1 (ffebld_conter (l)));
1639 break;
1640 #endif
1641
1642 #if FFETARGET_okINTEGER2
1643 case FFEINFO_kindtypeINTEGER2:
1644 error = ffetarget_convert_real1_integer2
1645 (ffebld_cu_ptr_real1 (u),
1646 ffebld_constant_integer2 (ffebld_conter (l)));
1647 break;
1648 #endif
1649
1650 #if FFETARGET_okINTEGER3
1651 case FFEINFO_kindtypeINTEGER3:
1652 error = ffetarget_convert_real1_integer3
1653 (ffebld_cu_ptr_real1 (u),
1654 ffebld_constant_integer3 (ffebld_conter (l)));
1655 break;
1656 #endif
1657
1658 #if FFETARGET_okINTEGER4
1659 case FFEINFO_kindtypeINTEGER4:
1660 error = ffetarget_convert_real1_integer4
1661 (ffebld_cu_ptr_real1 (u),
1662 ffebld_constant_integer4 (ffebld_conter (l)));
1663 break;
1664 #endif
1665
1666 default:
1667 assert ("REAL1/INTEGER bad source kind type" == NULL);
1668 break;
1669 }
1670 break;
1671
1672 case FFEINFO_basictypeREAL:
1673 switch (ffeinfo_kindtype (ffebld_info (l)))
1674 {
1675 #if FFETARGET_okREAL2
1676 case FFEINFO_kindtypeREAL2:
1677 error = ffetarget_convert_real1_real2
1678 (ffebld_cu_ptr_real1 (u),
1679 ffebld_constant_real2 (ffebld_conter (l)));
1680 break;
1681 #endif
1682
1683 #if FFETARGET_okREAL3
1684 case FFEINFO_kindtypeREAL3:
1685 error = ffetarget_convert_real1_real3
1686 (ffebld_cu_ptr_real1 (u),
1687 ffebld_constant_real3 (ffebld_conter (l)));
1688 break;
1689 #endif
1690
1691 default:
1692 assert ("REAL1/REAL bad source kind type" == NULL);
1693 break;
1694 }
1695 break;
1696
1697 case FFEINFO_basictypeCOMPLEX:
1698 switch (ffeinfo_kindtype (ffebld_info (l)))
1699 {
1700 #if FFETARGET_okCOMPLEX1
1701 case FFEINFO_kindtypeREAL1:
1702 error = ffetarget_convert_real1_complex1
1703 (ffebld_cu_ptr_real1 (u),
1704 ffebld_constant_complex1 (ffebld_conter (l)));
1705 break;
1706 #endif
1707
1708 #if FFETARGET_okCOMPLEX2
1709 case FFEINFO_kindtypeREAL2:
1710 error = ffetarget_convert_real1_complex2
1711 (ffebld_cu_ptr_real1 (u),
1712 ffebld_constant_complex2 (ffebld_conter (l)));
1713 break;
1714 #endif
1715
1716 #if FFETARGET_okCOMPLEX3
1717 case FFEINFO_kindtypeREAL3:
1718 error = ffetarget_convert_real1_complex3
1719 (ffebld_cu_ptr_real1 (u),
1720 ffebld_constant_complex3 (ffebld_conter (l)));
1721 break;
1722 #endif
1723
1724 default:
1725 assert ("REAL1/COMPLEX bad source kind type" == NULL);
1726 break;
1727 }
1728 break;
1729
1730 case FFEINFO_basictypeCHARACTER:
1731 error = ffetarget_convert_real1_character1
1732 (ffebld_cu_ptr_real1 (u),
1733 ffebld_constant_character1 (ffebld_conter (l)));
1734 break;
1735
1736 case FFEINFO_basictypeHOLLERITH:
1737 error = ffetarget_convert_real1_hollerith
1738 (ffebld_cu_ptr_real1 (u),
1739 ffebld_constant_hollerith (ffebld_conter (l)));
1740 break;
1741
1742 case FFEINFO_basictypeTYPELESS:
1743 error = ffetarget_convert_real1_typeless
1744 (ffebld_cu_ptr_real1 (u),
1745 ffebld_constant_typeless (ffebld_conter (l)));
1746 break;
1747
1748 default:
1749 assert ("REAL1 bad type" == NULL);
1750 break;
1751 }
1752
1753 /* If conversion operation is not implemented, return original expr. */
1754 if (error == FFEBAD_NOCANDO)
1755 return expr;
1756
1757 expr = ffebld_new_conter_with_orig
1758 (ffebld_constant_new_real1_val
1759 (ffebld_cu_val_real1 (u)), expr);
1760 break;
1761 #endif
1762
1763 #if FFETARGET_okREAL2
1764 case FFEINFO_kindtypeREAL2:
1765 switch (ffeinfo_basictype (ffebld_info (l)))
1766 {
1767 case FFEINFO_basictypeINTEGER:
1768 switch (ffeinfo_kindtype (ffebld_info (l)))
1769 {
1770 #if FFETARGET_okINTEGER1
1771 case FFEINFO_kindtypeINTEGER1:
1772 error = ffetarget_convert_real2_integer1
1773 (ffebld_cu_ptr_real2 (u),
1774 ffebld_constant_integer1 (ffebld_conter (l)));
1775 break;
1776 #endif
1777
1778 #if FFETARGET_okINTEGER2
1779 case FFEINFO_kindtypeINTEGER2:
1780 error = ffetarget_convert_real2_integer2
1781 (ffebld_cu_ptr_real2 (u),
1782 ffebld_constant_integer2 (ffebld_conter (l)));
1783 break;
1784 #endif
1785
1786 #if FFETARGET_okINTEGER3
1787 case FFEINFO_kindtypeINTEGER3:
1788 error = ffetarget_convert_real2_integer3
1789 (ffebld_cu_ptr_real2 (u),
1790 ffebld_constant_integer3 (ffebld_conter (l)));
1791 break;
1792 #endif
1793
1794 #if FFETARGET_okINTEGER4
1795 case FFEINFO_kindtypeINTEGER4:
1796 error = ffetarget_convert_real2_integer4
1797 (ffebld_cu_ptr_real2 (u),
1798 ffebld_constant_integer4 (ffebld_conter (l)));
1799 break;
1800 #endif
1801
1802 default:
1803 assert ("REAL2/INTEGER bad source kind type" == NULL);
1804 break;
1805 }
1806 break;
1807
1808 case FFEINFO_basictypeREAL:
1809 switch (ffeinfo_kindtype (ffebld_info (l)))
1810 {
1811 #if FFETARGET_okREAL1
1812 case FFEINFO_kindtypeREAL1:
1813 error = ffetarget_convert_real2_real1
1814 (ffebld_cu_ptr_real2 (u),
1815 ffebld_constant_real1 (ffebld_conter (l)));
1816 break;
1817 #endif
1818
1819 #if FFETARGET_okREAL3
1820 case FFEINFO_kindtypeREAL3:
1821 error = ffetarget_convert_real2_real3
1822 (ffebld_cu_ptr_real2 (u),
1823 ffebld_constant_real3 (ffebld_conter (l)));
1824 break;
1825 #endif
1826
1827 default:
1828 assert ("REAL2/REAL bad source kind type" == NULL);
1829 break;
1830 }
1831 break;
1832
1833 case FFEINFO_basictypeCOMPLEX:
1834 switch (ffeinfo_kindtype (ffebld_info (l)))
1835 {
1836 #if FFETARGET_okCOMPLEX1
1837 case FFEINFO_kindtypeREAL1:
1838 error = ffetarget_convert_real2_complex1
1839 (ffebld_cu_ptr_real2 (u),
1840 ffebld_constant_complex1 (ffebld_conter (l)));
1841 break;
1842 #endif
1843
1844 #if FFETARGET_okCOMPLEX2
1845 case FFEINFO_kindtypeREAL2:
1846 error = ffetarget_convert_real2_complex2
1847 (ffebld_cu_ptr_real2 (u),
1848 ffebld_constant_complex2 (ffebld_conter (l)));
1849 break;
1850 #endif
1851
1852 #if FFETARGET_okCOMPLEX3
1853 case FFEINFO_kindtypeREAL3:
1854 error = ffetarget_convert_real2_complex3
1855 (ffebld_cu_ptr_real2 (u),
1856 ffebld_constant_complex3 (ffebld_conter (l)));
1857 break;
1858 #endif
1859
1860 default:
1861 assert ("REAL2/COMPLEX bad source kind type" == NULL);
1862 break;
1863 }
1864 break;
1865
1866 case FFEINFO_basictypeCHARACTER:
1867 error = ffetarget_convert_real2_character1
1868 (ffebld_cu_ptr_real2 (u),
1869 ffebld_constant_character1 (ffebld_conter (l)));
1870 break;
1871
1872 case FFEINFO_basictypeHOLLERITH:
1873 error = ffetarget_convert_real2_hollerith
1874 (ffebld_cu_ptr_real2 (u),
1875 ffebld_constant_hollerith (ffebld_conter (l)));
1876 break;
1877
1878 case FFEINFO_basictypeTYPELESS:
1879 error = ffetarget_convert_real2_typeless
1880 (ffebld_cu_ptr_real2 (u),
1881 ffebld_constant_typeless (ffebld_conter (l)));
1882 break;
1883
1884 default:
1885 assert ("REAL2 bad type" == NULL);
1886 break;
1887 }
1888
1889 /* If conversion operation is not implemented, return original expr. */
1890 if (error == FFEBAD_NOCANDO)
1891 return expr;
1892
1893 expr = ffebld_new_conter_with_orig
1894 (ffebld_constant_new_real2_val
1895 (ffebld_cu_val_real2 (u)), expr);
1896 break;
1897 #endif
1898
1899 #if FFETARGET_okREAL3
1900 case FFEINFO_kindtypeREAL3:
1901 switch (ffeinfo_basictype (ffebld_info (l)))
1902 {
1903 case FFEINFO_basictypeINTEGER:
1904 switch (ffeinfo_kindtype (ffebld_info (l)))
1905 {
1906 #if FFETARGET_okINTEGER1
1907 case FFEINFO_kindtypeINTEGER1:
1908 error = ffetarget_convert_real3_integer1
1909 (ffebld_cu_ptr_real3 (u),
1910 ffebld_constant_integer1 (ffebld_conter (l)));
1911 break;
1912 #endif
1913
1914 #if FFETARGET_okINTEGER2
1915 case FFEINFO_kindtypeINTEGER2:
1916 error = ffetarget_convert_real3_integer2
1917 (ffebld_cu_ptr_real3 (u),
1918 ffebld_constant_integer2 (ffebld_conter (l)));
1919 break;
1920 #endif
1921
1922 #if FFETARGET_okINTEGER3
1923 case FFEINFO_kindtypeINTEGER3:
1924 error = ffetarget_convert_real3_integer3
1925 (ffebld_cu_ptr_real3 (u),
1926 ffebld_constant_integer3 (ffebld_conter (l)));
1927 break;
1928 #endif
1929
1930 #if FFETARGET_okINTEGER4
1931 case FFEINFO_kindtypeINTEGER4:
1932 error = ffetarget_convert_real3_integer4
1933 (ffebld_cu_ptr_real3 (u),
1934 ffebld_constant_integer4 (ffebld_conter (l)));
1935 break;
1936 #endif
1937
1938 default:
1939 assert ("REAL3/INTEGER bad source kind type" == NULL);
1940 break;
1941 }
1942 break;
1943
1944 case FFEINFO_basictypeREAL:
1945 switch (ffeinfo_kindtype (ffebld_info (l)))
1946 {
1947 #if FFETARGET_okREAL1
1948 case FFEINFO_kindtypeREAL1:
1949 error = ffetarget_convert_real3_real1
1950 (ffebld_cu_ptr_real3 (u),
1951 ffebld_constant_real1 (ffebld_conter (l)));
1952 break;
1953 #endif
1954
1955 #if FFETARGET_okREAL2
1956 case FFEINFO_kindtypeREAL2:
1957 error = ffetarget_convert_real3_real2
1958 (ffebld_cu_ptr_real3 (u),
1959 ffebld_constant_real2 (ffebld_conter (l)));
1960 break;
1961 #endif
1962
1963 default:
1964 assert ("REAL3/REAL bad source kind type" == NULL);
1965 break;
1966 }
1967 break;
1968
1969 case FFEINFO_basictypeCOMPLEX:
1970 switch (ffeinfo_kindtype (ffebld_info (l)))
1971 {
1972 #if FFETARGET_okCOMPLEX1
1973 case FFEINFO_kindtypeREAL1:
1974 error = ffetarget_convert_real3_complex1
1975 (ffebld_cu_ptr_real3 (u),
1976 ffebld_constant_complex1 (ffebld_conter (l)));
1977 break;
1978 #endif
1979
1980 #if FFETARGET_okCOMPLEX2
1981 case FFEINFO_kindtypeREAL2:
1982 error = ffetarget_convert_real3_complex2
1983 (ffebld_cu_ptr_real3 (u),
1984 ffebld_constant_complex2 (ffebld_conter (l)));
1985 break;
1986 #endif
1987
1988 #if FFETARGET_okCOMPLEX3
1989 case FFEINFO_kindtypeREAL3:
1990 error = ffetarget_convert_real3_complex3
1991 (ffebld_cu_ptr_real3 (u),
1992 ffebld_constant_complex3 (ffebld_conter (l)));
1993 break;
1994 #endif
1995
1996 default:
1997 assert ("REAL3/COMPLEX bad source kind type" == NULL);
1998 break;
1999 }
2000 break;
2001
2002 case FFEINFO_basictypeCHARACTER:
2003 error = ffetarget_convert_real3_character1
2004 (ffebld_cu_ptr_real3 (u),
2005 ffebld_constant_character1 (ffebld_conter (l)));
2006 break;
2007
2008 case FFEINFO_basictypeHOLLERITH:
2009 error = ffetarget_convert_real3_hollerith
2010 (ffebld_cu_ptr_real3 (u),
2011 ffebld_constant_hollerith (ffebld_conter (l)));
2012 break;
2013
2014 case FFEINFO_basictypeTYPELESS:
2015 error = ffetarget_convert_real3_typeless
2016 (ffebld_cu_ptr_real3 (u),
2017 ffebld_constant_typeless (ffebld_conter (l)));
2018 break;
2019
2020 default:
2021 assert ("REAL3 bad type" == NULL);
2022 break;
2023 }
2024
2025 /* If conversion operation is not implemented, return original expr. */
2026 if (error == FFEBAD_NOCANDO)
2027 return expr;
2028
2029 expr = ffebld_new_conter_with_orig
2030 (ffebld_constant_new_real3_val
2031 (ffebld_cu_val_real3 (u)), expr);
2032 break;
2033 #endif
2034
2035 default:
2036 assert ("bad real kind type" == NULL);
2037 break;
2038 }
2039 break;
2040
2041 case FFEINFO_basictypeCOMPLEX:
2042 sz = FFETARGET_charactersizeNONE;
2043 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2044 {
2045 #if FFETARGET_okCOMPLEX1
2046 case FFEINFO_kindtypeREAL1:
2047 switch (ffeinfo_basictype (ffebld_info (l)))
2048 {
2049 case FFEINFO_basictypeINTEGER:
2050 switch (ffeinfo_kindtype (ffebld_info (l)))
2051 {
2052 #if FFETARGET_okINTEGER1
2053 case FFEINFO_kindtypeINTEGER1:
2054 error = ffetarget_convert_complex1_integer1
2055 (ffebld_cu_ptr_complex1 (u),
2056 ffebld_constant_integer1 (ffebld_conter (l)));
2057 break;
2058 #endif
2059
2060 #if FFETARGET_okINTEGER2
2061 case FFEINFO_kindtypeINTEGER2:
2062 error = ffetarget_convert_complex1_integer2
2063 (ffebld_cu_ptr_complex1 (u),
2064 ffebld_constant_integer2 (ffebld_conter (l)));
2065 break;
2066 #endif
2067
2068 #if FFETARGET_okINTEGER3
2069 case FFEINFO_kindtypeINTEGER3:
2070 error = ffetarget_convert_complex1_integer3
2071 (ffebld_cu_ptr_complex1 (u),
2072 ffebld_constant_integer3 (ffebld_conter (l)));
2073 break;
2074 #endif
2075
2076 #if FFETARGET_okINTEGER4
2077 case FFEINFO_kindtypeINTEGER4:
2078 error = ffetarget_convert_complex1_integer4
2079 (ffebld_cu_ptr_complex1 (u),
2080 ffebld_constant_integer4 (ffebld_conter (l)));
2081 break;
2082 #endif
2083
2084 default:
2085 assert ("COMPLEX1/INTEGER bad source kind type" == NULL);
2086 break;
2087 }
2088 break;
2089
2090 case FFEINFO_basictypeREAL:
2091 switch (ffeinfo_kindtype (ffebld_info (l)))
2092 {
2093 #if FFETARGET_okREAL1
2094 case FFEINFO_kindtypeREAL1:
2095 error = ffetarget_convert_complex1_real1
2096 (ffebld_cu_ptr_complex1 (u),
2097 ffebld_constant_real1 (ffebld_conter (l)));
2098 break;
2099 #endif
2100
2101 #if FFETARGET_okREAL2
2102 case FFEINFO_kindtypeREAL2:
2103 error = ffetarget_convert_complex1_real2
2104 (ffebld_cu_ptr_complex1 (u),
2105 ffebld_constant_real2 (ffebld_conter (l)));
2106 break;
2107 #endif
2108
2109 #if FFETARGET_okREAL3
2110 case FFEINFO_kindtypeREAL3:
2111 error = ffetarget_convert_complex1_real3
2112 (ffebld_cu_ptr_complex1 (u),
2113 ffebld_constant_real3 (ffebld_conter (l)));
2114 break;
2115 #endif
2116
2117 default:
2118 assert ("COMPLEX1/REAL bad source kind type" == NULL);
2119 break;
2120 }
2121 break;
2122
2123 case FFEINFO_basictypeCOMPLEX:
2124 switch (ffeinfo_kindtype (ffebld_info (l)))
2125 {
2126 #if FFETARGET_okCOMPLEX2
2127 case FFEINFO_kindtypeREAL2:
2128 error = ffetarget_convert_complex1_complex2
2129 (ffebld_cu_ptr_complex1 (u),
2130 ffebld_constant_complex2 (ffebld_conter (l)));
2131 break;
2132 #endif
2133
2134 #if FFETARGET_okCOMPLEX3
2135 case FFEINFO_kindtypeREAL3:
2136 error = ffetarget_convert_complex1_complex3
2137 (ffebld_cu_ptr_complex1 (u),
2138 ffebld_constant_complex3 (ffebld_conter (l)));
2139 break;
2140 #endif
2141
2142 default:
2143 assert ("COMPLEX1/COMPLEX bad source kind type" == NULL);
2144 break;
2145 }
2146 break;
2147
2148 case FFEINFO_basictypeCHARACTER:
2149 error = ffetarget_convert_complex1_character1
2150 (ffebld_cu_ptr_complex1 (u),
2151 ffebld_constant_character1 (ffebld_conter (l)));
2152 break;
2153
2154 case FFEINFO_basictypeHOLLERITH:
2155 error = ffetarget_convert_complex1_hollerith
2156 (ffebld_cu_ptr_complex1 (u),
2157 ffebld_constant_hollerith (ffebld_conter (l)));
2158 break;
2159
2160 case FFEINFO_basictypeTYPELESS:
2161 error = ffetarget_convert_complex1_typeless
2162 (ffebld_cu_ptr_complex1 (u),
2163 ffebld_constant_typeless (ffebld_conter (l)));
2164 break;
2165
2166 default:
2167 assert ("COMPLEX1 bad type" == NULL);
2168 break;
2169 }
2170
2171 /* If conversion operation is not implemented, return original expr. */
2172 if (error == FFEBAD_NOCANDO)
2173 return expr;
2174
2175 expr = ffebld_new_conter_with_orig
2176 (ffebld_constant_new_complex1_val
2177 (ffebld_cu_val_complex1 (u)), expr);
2178 break;
2179 #endif
2180
2181 #if FFETARGET_okCOMPLEX2
2182 case FFEINFO_kindtypeREAL2:
2183 switch (ffeinfo_basictype (ffebld_info (l)))
2184 {
2185 case FFEINFO_basictypeINTEGER:
2186 switch (ffeinfo_kindtype (ffebld_info (l)))
2187 {
2188 #if FFETARGET_okINTEGER1
2189 case FFEINFO_kindtypeINTEGER1:
2190 error = ffetarget_convert_complex2_integer1
2191 (ffebld_cu_ptr_complex2 (u),
2192 ffebld_constant_integer1 (ffebld_conter (l)));
2193 break;
2194 #endif
2195
2196 #if FFETARGET_okINTEGER2
2197 case FFEINFO_kindtypeINTEGER2:
2198 error = ffetarget_convert_complex2_integer2
2199 (ffebld_cu_ptr_complex2 (u),
2200 ffebld_constant_integer2 (ffebld_conter (l)));
2201 break;
2202 #endif
2203
2204 #if FFETARGET_okINTEGER3
2205 case FFEINFO_kindtypeINTEGER3:
2206 error = ffetarget_convert_complex2_integer3
2207 (ffebld_cu_ptr_complex2 (u),
2208 ffebld_constant_integer3 (ffebld_conter (l)));
2209 break;
2210 #endif
2211
2212 #if FFETARGET_okINTEGER4
2213 case FFEINFO_kindtypeINTEGER4:
2214 error = ffetarget_convert_complex2_integer4
2215 (ffebld_cu_ptr_complex2 (u),
2216 ffebld_constant_integer4 (ffebld_conter (l)));
2217 break;
2218 #endif
2219
2220 default:
2221 assert ("COMPLEX2/INTEGER bad source kind type" == NULL);
2222 break;
2223 }
2224 break;
2225
2226 case FFEINFO_basictypeREAL:
2227 switch (ffeinfo_kindtype (ffebld_info (l)))
2228 {
2229 #if FFETARGET_okREAL1
2230 case FFEINFO_kindtypeREAL1:
2231 error = ffetarget_convert_complex2_real1
2232 (ffebld_cu_ptr_complex2 (u),
2233 ffebld_constant_real1 (ffebld_conter (l)));
2234 break;
2235 #endif
2236
2237 #if FFETARGET_okREAL2
2238 case FFEINFO_kindtypeREAL2:
2239 error = ffetarget_convert_complex2_real2
2240 (ffebld_cu_ptr_complex2 (u),
2241 ffebld_constant_real2 (ffebld_conter (l)));
2242 break;
2243 #endif
2244
2245 #if FFETARGET_okREAL3
2246 case FFEINFO_kindtypeREAL3:
2247 error = ffetarget_convert_complex2_real3
2248 (ffebld_cu_ptr_complex2 (u),
2249 ffebld_constant_real3 (ffebld_conter (l)));
2250 break;
2251 #endif
2252
2253 default:
2254 assert ("COMPLEX2/REAL bad source kind type" == NULL);
2255 break;
2256 }
2257 break;
2258
2259 case FFEINFO_basictypeCOMPLEX:
2260 switch (ffeinfo_kindtype (ffebld_info (l)))
2261 {
2262 #if FFETARGET_okCOMPLEX1
2263 case FFEINFO_kindtypeREAL1:
2264 error = ffetarget_convert_complex2_complex1
2265 (ffebld_cu_ptr_complex2 (u),
2266 ffebld_constant_complex1 (ffebld_conter (l)));
2267 break;
2268 #endif
2269
2270 #if FFETARGET_okCOMPLEX3
2271 case FFEINFO_kindtypeREAL3:
2272 error = ffetarget_convert_complex2_complex3
2273 (ffebld_cu_ptr_complex2 (u),
2274 ffebld_constant_complex3 (ffebld_conter (l)));
2275 break;
2276 #endif
2277
2278 default:
2279 assert ("COMPLEX2/COMPLEX bad source kind type" == NULL);
2280 break;
2281 }
2282 break;
2283
2284 case FFEINFO_basictypeCHARACTER:
2285 error = ffetarget_convert_complex2_character1
2286 (ffebld_cu_ptr_complex2 (u),
2287 ffebld_constant_character1 (ffebld_conter (l)));
2288 break;
2289
2290 case FFEINFO_basictypeHOLLERITH:
2291 error = ffetarget_convert_complex2_hollerith
2292 (ffebld_cu_ptr_complex2 (u),
2293 ffebld_constant_hollerith (ffebld_conter (l)));
2294 break;
2295
2296 case FFEINFO_basictypeTYPELESS:
2297 error = ffetarget_convert_complex2_typeless
2298 (ffebld_cu_ptr_complex2 (u),
2299 ffebld_constant_typeless (ffebld_conter (l)));
2300 break;
2301
2302 default:
2303 assert ("COMPLEX2 bad type" == NULL);
2304 break;
2305 }
2306
2307 /* If conversion operation is not implemented, return original expr. */
2308 if (error == FFEBAD_NOCANDO)
2309 return expr;
2310
2311 expr = ffebld_new_conter_with_orig
2312 (ffebld_constant_new_complex2_val
2313 (ffebld_cu_val_complex2 (u)), expr);
2314 break;
2315 #endif
2316
2317 #if FFETARGET_okCOMPLEX3
2318 case FFEINFO_kindtypeREAL3:
2319 switch (ffeinfo_basictype (ffebld_info (l)))
2320 {
2321 case FFEINFO_basictypeINTEGER:
2322 switch (ffeinfo_kindtype (ffebld_info (l)))
2323 {
2324 #if FFETARGET_okINTEGER1
2325 case FFEINFO_kindtypeINTEGER1:
2326 error = ffetarget_convert_complex3_integer1
2327 (ffebld_cu_ptr_complex3 (u),
2328 ffebld_constant_integer1 (ffebld_conter (l)));
2329 break;
2330 #endif
2331
2332 #if FFETARGET_okINTEGER2
2333 case FFEINFO_kindtypeINTEGER2:
2334 error = ffetarget_convert_complex3_integer2
2335 (ffebld_cu_ptr_complex3 (u),
2336 ffebld_constant_integer2 (ffebld_conter (l)));
2337 break;
2338 #endif
2339
2340 #if FFETARGET_okINTEGER3
2341 case FFEINFO_kindtypeINTEGER3:
2342 error = ffetarget_convert_complex3_integer3
2343 (ffebld_cu_ptr_complex3 (u),
2344 ffebld_constant_integer3 (ffebld_conter (l)));
2345 break;
2346 #endif
2347
2348 #if FFETARGET_okINTEGER4
2349 case FFEINFO_kindtypeINTEGER4:
2350 error = ffetarget_convert_complex3_integer4
2351 (ffebld_cu_ptr_complex3 (u),
2352 ffebld_constant_integer4 (ffebld_conter (l)));
2353 break;
2354 #endif
2355
2356 default:
2357 assert ("COMPLEX3/INTEGER bad source kind type" == NULL);
2358 break;
2359 }
2360 break;
2361
2362 case FFEINFO_basictypeREAL:
2363 switch (ffeinfo_kindtype (ffebld_info (l)))
2364 {
2365 #if FFETARGET_okREAL1
2366 case FFEINFO_kindtypeREAL1:
2367 error = ffetarget_convert_complex3_real1
2368 (ffebld_cu_ptr_complex3 (u),
2369 ffebld_constant_real1 (ffebld_conter (l)));
2370 break;
2371 #endif
2372
2373 #if FFETARGET_okREAL2
2374 case FFEINFO_kindtypeREAL2:
2375 error = ffetarget_convert_complex3_real2
2376 (ffebld_cu_ptr_complex3 (u),
2377 ffebld_constant_real2 (ffebld_conter (l)));
2378 break;
2379 #endif
2380
2381 #if FFETARGET_okREAL3
2382 case FFEINFO_kindtypeREAL3:
2383 error = ffetarget_convert_complex3_real3
2384 (ffebld_cu_ptr_complex3 (u),
2385 ffebld_constant_real3 (ffebld_conter (l)));
2386 break;
2387 #endif
2388
2389 default:
2390 assert ("COMPLEX3/REAL bad source kind type" == NULL);
2391 break;
2392 }
2393 break;
2394
2395 case FFEINFO_basictypeCOMPLEX:
2396 switch (ffeinfo_kindtype (ffebld_info (l)))
2397 {
2398 #if FFETARGET_okCOMPLEX1
2399 case FFEINFO_kindtypeREAL1:
2400 error = ffetarget_convert_complex3_complex1
2401 (ffebld_cu_ptr_complex3 (u),
2402 ffebld_constant_complex1 (ffebld_conter (l)));
2403 break;
2404 #endif
2405
2406 #if FFETARGET_okCOMPLEX2
2407 case FFEINFO_kindtypeREAL2:
2408 error = ffetarget_convert_complex3_complex2
2409 (ffebld_cu_ptr_complex3 (u),
2410 ffebld_constant_complex2 (ffebld_conter (l)));
2411 break;
2412 #endif
2413
2414 default:
2415 assert ("COMPLEX3/COMPLEX bad source kind type" == NULL);
2416 break;
2417 }
2418 break;
2419
2420 case FFEINFO_basictypeCHARACTER:
2421 error = ffetarget_convert_complex3_character1
2422 (ffebld_cu_ptr_complex3 (u),
2423 ffebld_constant_character1 (ffebld_conter (l)));
2424 break;
2425
2426 case FFEINFO_basictypeHOLLERITH:
2427 error = ffetarget_convert_complex3_hollerith
2428 (ffebld_cu_ptr_complex3 (u),
2429 ffebld_constant_hollerith (ffebld_conter (l)));
2430 break;
2431
2432 case FFEINFO_basictypeTYPELESS:
2433 error = ffetarget_convert_complex3_typeless
2434 (ffebld_cu_ptr_complex3 (u),
2435 ffebld_constant_typeless (ffebld_conter (l)));
2436 break;
2437
2438 default:
2439 assert ("COMPLEX3 bad type" == NULL);
2440 break;
2441 }
2442
2443 /* If conversion operation is not implemented, return original expr. */
2444 if (error == FFEBAD_NOCANDO)
2445 return expr;
2446
2447 expr = ffebld_new_conter_with_orig
2448 (ffebld_constant_new_complex3_val
2449 (ffebld_cu_val_complex3 (u)), expr);
2450 break;
2451 #endif
2452
2453 default:
2454 assert ("bad complex kind type" == NULL);
2455 break;
2456 }
2457 break;
2458
2459 case FFEINFO_basictypeCHARACTER:
2460 if ((sz = ffebld_size (expr)) == FFETARGET_charactersizeNONE)
2461 return expr;
2462 kt = ffeinfo_kindtype (ffebld_info (expr));
2463 switch (kt)
2464 {
2465 #if FFETARGET_okCHARACTER1
2466 case FFEINFO_kindtypeCHARACTER1:
2467 switch (ffeinfo_basictype (ffebld_info (l)))
2468 {
2469 case FFEINFO_basictypeCHARACTER:
2470 if ((sz2 = ffebld_size (l)) == FFETARGET_charactersizeNONE)
2471 return expr;
2472 assert (kt == ffeinfo_kindtype (ffebld_info (l)));
2473 assert (sz2 == ffetarget_length_character1
2474 (ffebld_constant_character1
2475 (ffebld_conter (l))));
2476 error
2477 = ffetarget_convert_character1_character1
2478 (ffebld_cu_ptr_character1 (u), sz,
2479 ffebld_constant_character1 (ffebld_conter (l)),
2480 ffebld_constant_pool ());
2481 break;
2482
2483 case FFEINFO_basictypeINTEGER:
2484 switch (ffeinfo_kindtype (ffebld_info (l)))
2485 {
2486 #if FFETARGET_okINTEGER1
2487 case FFEINFO_kindtypeINTEGER1:
2488 error
2489 = ffetarget_convert_character1_integer1
2490 (ffebld_cu_ptr_character1 (u),
2491 sz,
2492 ffebld_constant_integer1 (ffebld_conter (l)),
2493 ffebld_constant_pool ());
2494 break;
2495 #endif
2496
2497 #if FFETARGET_okINTEGER2
2498 case FFEINFO_kindtypeINTEGER2:
2499 error
2500 = ffetarget_convert_character1_integer2
2501 (ffebld_cu_ptr_character1 (u),
2502 sz,
2503 ffebld_constant_integer2 (ffebld_conter (l)),
2504 ffebld_constant_pool ());
2505 break;
2506 #endif
2507
2508 #if FFETARGET_okINTEGER3
2509 case FFEINFO_kindtypeINTEGER3:
2510 error
2511 = ffetarget_convert_character1_integer3
2512 (ffebld_cu_ptr_character1 (u),
2513 sz,
2514 ffebld_constant_integer3 (ffebld_conter (l)),
2515 ffebld_constant_pool ());
2516 break;
2517 #endif
2518
2519 #if FFETARGET_okINTEGER4
2520 case FFEINFO_kindtypeINTEGER4:
2521 error
2522 = ffetarget_convert_character1_integer4
2523 (ffebld_cu_ptr_character1 (u),
2524 sz,
2525 ffebld_constant_integer4 (ffebld_conter (l)),
2526 ffebld_constant_pool ());
2527 break;
2528 #endif
2529
2530 default:
2531 assert ("CHARACTER1/INTEGER bad source kind type" == NULL);
2532 break;
2533 }
2534 break;
2535
2536 case FFEINFO_basictypeLOGICAL:
2537 switch (ffeinfo_kindtype (ffebld_info (l)))
2538 {
2539 #if FFETARGET_okLOGICAL1
2540 case FFEINFO_kindtypeLOGICAL1:
2541 error
2542 = ffetarget_convert_character1_logical1
2543 (ffebld_cu_ptr_character1 (u),
2544 sz,
2545 ffebld_constant_logical1 (ffebld_conter (l)),
2546 ffebld_constant_pool ());
2547 break;
2548 #endif
2549
2550 #if FFETARGET_okLOGICAL2
2551 case FFEINFO_kindtypeLOGICAL2:
2552 error
2553 = ffetarget_convert_character1_logical2
2554 (ffebld_cu_ptr_character1 (u),
2555 sz,
2556 ffebld_constant_logical2 (ffebld_conter (l)),
2557 ffebld_constant_pool ());
2558 break;
2559 #endif
2560
2561 #if FFETARGET_okLOGICAL3
2562 case FFEINFO_kindtypeLOGICAL3:
2563 error
2564 = ffetarget_convert_character1_logical3
2565 (ffebld_cu_ptr_character1 (u),
2566 sz,
2567 ffebld_constant_logical3 (ffebld_conter (l)),
2568 ffebld_constant_pool ());
2569 break;
2570 #endif
2571
2572 #if FFETARGET_okLOGICAL4
2573 case FFEINFO_kindtypeLOGICAL4:
2574 error
2575 = ffetarget_convert_character1_logical4
2576 (ffebld_cu_ptr_character1 (u),
2577 sz,
2578 ffebld_constant_logical4 (ffebld_conter (l)),
2579 ffebld_constant_pool ());
2580 break;
2581 #endif
2582
2583 default:
2584 assert ("CHARACTER1/LOGICAL bad source kind type" == NULL);
2585 break;
2586 }
2587 break;
2588
2589 case FFEINFO_basictypeHOLLERITH:
2590 error
2591 = ffetarget_convert_character1_hollerith
2592 (ffebld_cu_ptr_character1 (u),
2593 sz,
2594 ffebld_constant_hollerith (ffebld_conter (l)),
2595 ffebld_constant_pool ());
2596 break;
2597
2598 case FFEINFO_basictypeTYPELESS:
2599 error
2600 = ffetarget_convert_character1_typeless
2601 (ffebld_cu_ptr_character1 (u),
2602 sz,
2603 ffebld_constant_typeless (ffebld_conter (l)),
2604 ffebld_constant_pool ());
2605 break;
2606
2607 default:
2608 assert ("CHARACTER1 bad type" == NULL);
2609 }
2610
2611 expr
2612 = ffebld_new_conter_with_orig
2613 (ffebld_constant_new_character1_val
2614 (ffebld_cu_val_character1 (u)),
2615 expr);
2616 break;
2617 #endif
2618
2619 default:
2620 assert ("bad character kind type" == NULL);
2621 break;
2622 }
2623 break;
2624
2625 default:
2626 assert ("bad type" == NULL);
2627 return expr;
2628 }
2629
2630 ffebld_set_info (expr, ffeinfo_new
2631 (bt,
2632 kt,
2633 0,
2634 FFEINFO_kindENTITY,
2635 FFEINFO_whereCONSTANT,
2636 sz));
2637
2638 if ((error != FFEBAD)
2639 && ffebad_start (error))
2640 {
2641 assert (t != NULL);
2642 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
2643 ffebad_finish ();
2644 }
2645
2646 return expr;
2647 }
2648
2649 /* ffeexpr_collapse_paren -- Collapse paren expr
2650
2651 ffebld expr;
2652 ffelexToken token;
2653 expr = ffeexpr_collapse_paren(expr,token);
2654
2655 If the result of the expr is a constant, replaces the expr with the
2656 computed constant. */
2657
2658 ffebld
2659 ffeexpr_collapse_paren (ffebld expr, ffelexToken t UNUSED)
2660 {
2661 ffebld r;
2662 ffeinfoBasictype bt;
2663 ffeinfoKindtype kt;
2664 ffetargetCharacterSize len;
2665
2666 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
2667 return expr;
2668
2669 r = ffebld_left (expr);
2670
2671 if (ffebld_op (r) != FFEBLD_opCONTER)
2672 return expr;
2673
2674 bt = ffeinfo_basictype (ffebld_info (r));
2675 kt = ffeinfo_kindtype (ffebld_info (r));
2676 len = ffebld_size (r);
2677
2678 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
2679 expr);
2680
2681 ffebld_set_info (expr, ffeinfo_new
2682 (bt,
2683 kt,
2684 0,
2685 FFEINFO_kindENTITY,
2686 FFEINFO_whereCONSTANT,
2687 len));
2688
2689 return expr;
2690 }
2691
2692 /* ffeexpr_collapse_uplus -- Collapse uplus expr
2693
2694 ffebld expr;
2695 ffelexToken token;
2696 expr = ffeexpr_collapse_uplus(expr,token);
2697
2698 If the result of the expr is a constant, replaces the expr with the
2699 computed constant. */
2700
2701 ffebld
2702 ffeexpr_collapse_uplus (ffebld expr, ffelexToken t UNUSED)
2703 {
2704 ffebld r;
2705 ffeinfoBasictype bt;
2706 ffeinfoKindtype kt;
2707 ffetargetCharacterSize len;
2708
2709 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
2710 return expr;
2711
2712 r = ffebld_left (expr);
2713
2714 if (ffebld_op (r) != FFEBLD_opCONTER)
2715 return expr;
2716
2717 bt = ffeinfo_basictype (ffebld_info (r));
2718 kt = ffeinfo_kindtype (ffebld_info (r));
2719 len = ffebld_size (r);
2720
2721 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
2722 expr);
2723
2724 ffebld_set_info (expr, ffeinfo_new
2725 (bt,
2726 kt,
2727 0,
2728 FFEINFO_kindENTITY,
2729 FFEINFO_whereCONSTANT,
2730 len));
2731
2732 return expr;
2733 }
2734
2735 /* ffeexpr_collapse_uminus -- Collapse uminus expr
2736
2737 ffebld expr;
2738 ffelexToken token;
2739 expr = ffeexpr_collapse_uminus(expr,token);
2740
2741 If the result of the expr is a constant, replaces the expr with the
2742 computed constant. */
2743
2744 ffebld
2745 ffeexpr_collapse_uminus (ffebld expr, ffelexToken t)
2746 {
2747 ffebad error = FFEBAD;
2748 ffebld r;
2749 ffebldConstantUnion u;
2750 ffeinfoBasictype bt;
2751 ffeinfoKindtype kt;
2752
2753 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
2754 return expr;
2755
2756 r = ffebld_left (expr);
2757
2758 if (ffebld_op (r) != FFEBLD_opCONTER)
2759 return expr;
2760
2761 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
2762 {
2763 case FFEINFO_basictypeANY:
2764 return expr;
2765
2766 case FFEINFO_basictypeINTEGER:
2767 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2768 {
2769 #if FFETARGET_okINTEGER1
2770 case FFEINFO_kindtypeINTEGER1:
2771 error = ffetarget_uminus_integer1 (ffebld_cu_ptr_integer1 (u),
2772 ffebld_constant_integer1 (ffebld_conter (r)));
2773 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
2774 (ffebld_cu_val_integer1 (u)), expr);
2775 break;
2776 #endif
2777
2778 #if FFETARGET_okINTEGER2
2779 case FFEINFO_kindtypeINTEGER2:
2780 error = ffetarget_uminus_integer2 (ffebld_cu_ptr_integer2 (u),
2781 ffebld_constant_integer2 (ffebld_conter (r)));
2782 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
2783 (ffebld_cu_val_integer2 (u)), expr);
2784 break;
2785 #endif
2786
2787 #if FFETARGET_okINTEGER3
2788 case FFEINFO_kindtypeINTEGER3:
2789 error = ffetarget_uminus_integer3 (ffebld_cu_ptr_integer3 (u),
2790 ffebld_constant_integer3 (ffebld_conter (r)));
2791 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
2792 (ffebld_cu_val_integer3 (u)), expr);
2793 break;
2794 #endif
2795
2796 #if FFETARGET_okINTEGER4
2797 case FFEINFO_kindtypeINTEGER4:
2798 error = ffetarget_uminus_integer4 (ffebld_cu_ptr_integer4 (u),
2799 ffebld_constant_integer4 (ffebld_conter (r)));
2800 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
2801 (ffebld_cu_val_integer4 (u)), expr);
2802 break;
2803 #endif
2804
2805 default:
2806 assert ("bad integer kind type" == NULL);
2807 break;
2808 }
2809 break;
2810
2811 case FFEINFO_basictypeREAL:
2812 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2813 {
2814 #if FFETARGET_okREAL1
2815 case FFEINFO_kindtypeREAL1:
2816 error = ffetarget_uminus_real1 (ffebld_cu_ptr_real1 (u),
2817 ffebld_constant_real1 (ffebld_conter (r)));
2818 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
2819 (ffebld_cu_val_real1 (u)), expr);
2820 break;
2821 #endif
2822
2823 #if FFETARGET_okREAL2
2824 case FFEINFO_kindtypeREAL2:
2825 error = ffetarget_uminus_real2 (ffebld_cu_ptr_real2 (u),
2826 ffebld_constant_real2 (ffebld_conter (r)));
2827 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
2828 (ffebld_cu_val_real2 (u)), expr);
2829 break;
2830 #endif
2831
2832 #if FFETARGET_okREAL3
2833 case FFEINFO_kindtypeREAL3:
2834 error = ffetarget_uminus_real3 (ffebld_cu_ptr_real3 (u),
2835 ffebld_constant_real3 (ffebld_conter (r)));
2836 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
2837 (ffebld_cu_val_real3 (u)), expr);
2838 break;
2839 #endif
2840
2841 default:
2842 assert ("bad real kind type" == NULL);
2843 break;
2844 }
2845 break;
2846
2847 case FFEINFO_basictypeCOMPLEX:
2848 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2849 {
2850 #if FFETARGET_okCOMPLEX1
2851 case FFEINFO_kindtypeREAL1:
2852 error = ffetarget_uminus_complex1 (ffebld_cu_ptr_complex1 (u),
2853 ffebld_constant_complex1 (ffebld_conter (r)));
2854 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
2855 (ffebld_cu_val_complex1 (u)), expr);
2856 break;
2857 #endif
2858
2859 #if FFETARGET_okCOMPLEX2
2860 case FFEINFO_kindtypeREAL2:
2861 error = ffetarget_uminus_complex2 (ffebld_cu_ptr_complex2 (u),
2862 ffebld_constant_complex2 (ffebld_conter (r)));
2863 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
2864 (ffebld_cu_val_complex2 (u)), expr);
2865 break;
2866 #endif
2867
2868 #if FFETARGET_okCOMPLEX3
2869 case FFEINFO_kindtypeREAL3:
2870 error = ffetarget_uminus_complex3 (ffebld_cu_ptr_complex3 (u),
2871 ffebld_constant_complex3 (ffebld_conter (r)));
2872 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
2873 (ffebld_cu_val_complex3 (u)), expr);
2874 break;
2875 #endif
2876
2877 default:
2878 assert ("bad complex kind type" == NULL);
2879 break;
2880 }
2881 break;
2882
2883 default:
2884 assert ("bad type" == NULL);
2885 return expr;
2886 }
2887
2888 ffebld_set_info (expr, ffeinfo_new
2889 (bt,
2890 kt,
2891 0,
2892 FFEINFO_kindENTITY,
2893 FFEINFO_whereCONSTANT,
2894 FFETARGET_charactersizeNONE));
2895
2896 if ((error != FFEBAD)
2897 && ffebad_start (error))
2898 {
2899 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
2900 ffebad_finish ();
2901 }
2902
2903 return expr;
2904 }
2905
2906 /* ffeexpr_collapse_not -- Collapse not expr
2907
2908 ffebld expr;
2909 ffelexToken token;
2910 expr = ffeexpr_collapse_not(expr,token);
2911
2912 If the result of the expr is a constant, replaces the expr with the
2913 computed constant. */
2914
2915 ffebld
2916 ffeexpr_collapse_not (ffebld expr, ffelexToken t)
2917 {
2918 ffebad error = FFEBAD;
2919 ffebld r;
2920 ffebldConstantUnion u;
2921 ffeinfoBasictype bt;
2922 ffeinfoKindtype kt;
2923
2924 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
2925 return expr;
2926
2927 r = ffebld_left (expr);
2928
2929 if (ffebld_op (r) != FFEBLD_opCONTER)
2930 return expr;
2931
2932 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
2933 {
2934 case FFEINFO_basictypeANY:
2935 return expr;
2936
2937 case FFEINFO_basictypeINTEGER:
2938 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2939 {
2940 #if FFETARGET_okINTEGER1
2941 case FFEINFO_kindtypeINTEGER1:
2942 error = ffetarget_not_integer1 (ffebld_cu_ptr_integer1 (u),
2943 ffebld_constant_integer1 (ffebld_conter (r)));
2944 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
2945 (ffebld_cu_val_integer1 (u)), expr);
2946 break;
2947 #endif
2948
2949 #if FFETARGET_okINTEGER2
2950 case FFEINFO_kindtypeINTEGER2:
2951 error = ffetarget_not_integer2 (ffebld_cu_ptr_integer2 (u),
2952 ffebld_constant_integer2 (ffebld_conter (r)));
2953 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
2954 (ffebld_cu_val_integer2 (u)), expr);
2955 break;
2956 #endif
2957
2958 #if FFETARGET_okINTEGER3
2959 case FFEINFO_kindtypeINTEGER3:
2960 error = ffetarget_not_integer3 (ffebld_cu_ptr_integer3 (u),
2961 ffebld_constant_integer3 (ffebld_conter (r)));
2962 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
2963 (ffebld_cu_val_integer3 (u)), expr);
2964 break;
2965 #endif
2966
2967 #if FFETARGET_okINTEGER4
2968 case FFEINFO_kindtypeINTEGER4:
2969 error = ffetarget_not_integer4 (ffebld_cu_ptr_integer4 (u),
2970 ffebld_constant_integer4 (ffebld_conter (r)));
2971 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
2972 (ffebld_cu_val_integer4 (u)), expr);
2973 break;
2974 #endif
2975
2976 default:
2977 assert ("bad integer kind type" == NULL);
2978 break;
2979 }
2980 break;
2981
2982 case FFEINFO_basictypeLOGICAL:
2983 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2984 {
2985 #if FFETARGET_okLOGICAL1
2986 case FFEINFO_kindtypeLOGICAL1:
2987 error = ffetarget_not_logical1 (ffebld_cu_ptr_logical1 (u),
2988 ffebld_constant_logical1 (ffebld_conter (r)));
2989 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
2990 (ffebld_cu_val_logical1 (u)), expr);
2991 break;
2992 #endif
2993
2994 #if FFETARGET_okLOGICAL2
2995 case FFEINFO_kindtypeLOGICAL2:
2996 error = ffetarget_not_logical2 (ffebld_cu_ptr_logical2 (u),
2997 ffebld_constant_logical2 (ffebld_conter (r)));
2998 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
2999 (ffebld_cu_val_logical2 (u)), expr);
3000 break;
3001 #endif
3002
3003 #if FFETARGET_okLOGICAL3
3004 case FFEINFO_kindtypeLOGICAL3:
3005 error = ffetarget_not_logical3 (ffebld_cu_ptr_logical3 (u),
3006 ffebld_constant_logical3 (ffebld_conter (r)));
3007 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
3008 (ffebld_cu_val_logical3 (u)), expr);
3009 break;
3010 #endif
3011
3012 #if FFETARGET_okLOGICAL4
3013 case FFEINFO_kindtypeLOGICAL4:
3014 error = ffetarget_not_logical4 (ffebld_cu_ptr_logical4 (u),
3015 ffebld_constant_logical4 (ffebld_conter (r)));
3016 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
3017 (ffebld_cu_val_logical4 (u)), expr);
3018 break;
3019 #endif
3020
3021 default:
3022 assert ("bad logical kind type" == NULL);
3023 break;
3024 }
3025 break;
3026
3027 default:
3028 assert ("bad type" == NULL);
3029 return expr;
3030 }
3031
3032 ffebld_set_info (expr, ffeinfo_new
3033 (bt,
3034 kt,
3035 0,
3036 FFEINFO_kindENTITY,
3037 FFEINFO_whereCONSTANT,
3038 FFETARGET_charactersizeNONE));
3039
3040 if ((error != FFEBAD)
3041 && ffebad_start (error))
3042 {
3043 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3044 ffebad_finish ();
3045 }
3046
3047 return expr;
3048 }
3049
3050 /* ffeexpr_collapse_add -- Collapse add expr
3051
3052 ffebld expr;
3053 ffelexToken token;
3054 expr = ffeexpr_collapse_add(expr,token);
3055
3056 If the result of the expr is a constant, replaces the expr with the
3057 computed constant. */
3058
3059 ffebld
3060 ffeexpr_collapse_add (ffebld expr, ffelexToken t)
3061 {
3062 ffebad error = FFEBAD;
3063 ffebld l;
3064 ffebld r;
3065 ffebldConstantUnion u;
3066 ffeinfoBasictype bt;
3067 ffeinfoKindtype kt;
3068
3069 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3070 return expr;
3071
3072 l = ffebld_left (expr);
3073 r = ffebld_right (expr);
3074
3075 if (ffebld_op (l) != FFEBLD_opCONTER)
3076 return expr;
3077 if (ffebld_op (r) != FFEBLD_opCONTER)
3078 return expr;
3079
3080 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3081 {
3082 case FFEINFO_basictypeANY:
3083 return expr;
3084
3085 case FFEINFO_basictypeINTEGER:
3086 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3087 {
3088 #if FFETARGET_okINTEGER1
3089 case FFEINFO_kindtypeINTEGER1:
3090 error = ffetarget_add_integer1 (ffebld_cu_ptr_integer1 (u),
3091 ffebld_constant_integer1 (ffebld_conter (l)),
3092 ffebld_constant_integer1 (ffebld_conter (r)));
3093 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3094 (ffebld_cu_val_integer1 (u)), expr);
3095 break;
3096 #endif
3097
3098 #if FFETARGET_okINTEGER2
3099 case FFEINFO_kindtypeINTEGER2:
3100 error = ffetarget_add_integer2 (ffebld_cu_ptr_integer2 (u),
3101 ffebld_constant_integer2 (ffebld_conter (l)),
3102 ffebld_constant_integer2 (ffebld_conter (r)));
3103 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3104 (ffebld_cu_val_integer2 (u)), expr);
3105 break;
3106 #endif
3107
3108 #if FFETARGET_okINTEGER3
3109 case FFEINFO_kindtypeINTEGER3:
3110 error = ffetarget_add_integer3 (ffebld_cu_ptr_integer3 (u),
3111 ffebld_constant_integer3 (ffebld_conter (l)),
3112 ffebld_constant_integer3 (ffebld_conter (r)));
3113 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3114 (ffebld_cu_val_integer3 (u)), expr);
3115 break;
3116 #endif
3117
3118 #if FFETARGET_okINTEGER4
3119 case FFEINFO_kindtypeINTEGER4:
3120 error = ffetarget_add_integer4 (ffebld_cu_ptr_integer4 (u),
3121 ffebld_constant_integer4 (ffebld_conter (l)),
3122 ffebld_constant_integer4 (ffebld_conter (r)));
3123 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3124 (ffebld_cu_val_integer4 (u)), expr);
3125 break;
3126 #endif
3127
3128 default:
3129 assert ("bad integer kind type" == NULL);
3130 break;
3131 }
3132 break;
3133
3134 case FFEINFO_basictypeREAL:
3135 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3136 {
3137 #if FFETARGET_okREAL1
3138 case FFEINFO_kindtypeREAL1:
3139 error = ffetarget_add_real1 (ffebld_cu_ptr_real1 (u),
3140 ffebld_constant_real1 (ffebld_conter (l)),
3141 ffebld_constant_real1 (ffebld_conter (r)));
3142 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3143 (ffebld_cu_val_real1 (u)), expr);
3144 break;
3145 #endif
3146
3147 #if FFETARGET_okREAL2
3148 case FFEINFO_kindtypeREAL2:
3149 error = ffetarget_add_real2 (ffebld_cu_ptr_real2 (u),
3150 ffebld_constant_real2 (ffebld_conter (l)),
3151 ffebld_constant_real2 (ffebld_conter (r)));
3152 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3153 (ffebld_cu_val_real2 (u)), expr);
3154 break;
3155 #endif
3156
3157 #if FFETARGET_okREAL3
3158 case FFEINFO_kindtypeREAL3:
3159 error = ffetarget_add_real3 (ffebld_cu_ptr_real3 (u),
3160 ffebld_constant_real3 (ffebld_conter (l)),
3161 ffebld_constant_real3 (ffebld_conter (r)));
3162 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3163 (ffebld_cu_val_real3 (u)), expr);
3164 break;
3165 #endif
3166
3167 default:
3168 assert ("bad real kind type" == NULL);
3169 break;
3170 }
3171 break;
3172
3173 case FFEINFO_basictypeCOMPLEX:
3174 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3175 {
3176 #if FFETARGET_okCOMPLEX1
3177 case FFEINFO_kindtypeREAL1:
3178 error = ffetarget_add_complex1 (ffebld_cu_ptr_complex1 (u),
3179 ffebld_constant_complex1 (ffebld_conter (l)),
3180 ffebld_constant_complex1 (ffebld_conter (r)));
3181 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3182 (ffebld_cu_val_complex1 (u)), expr);
3183 break;
3184 #endif
3185
3186 #if FFETARGET_okCOMPLEX2
3187 case FFEINFO_kindtypeREAL2:
3188 error = ffetarget_add_complex2 (ffebld_cu_ptr_complex2 (u),
3189 ffebld_constant_complex2 (ffebld_conter (l)),
3190 ffebld_constant_complex2 (ffebld_conter (r)));
3191 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3192 (ffebld_cu_val_complex2 (u)), expr);
3193 break;
3194 #endif
3195
3196 #if FFETARGET_okCOMPLEX3
3197 case FFEINFO_kindtypeREAL3:
3198 error = ffetarget_add_complex3 (ffebld_cu_ptr_complex3 (u),
3199 ffebld_constant_complex3 (ffebld_conter (l)),
3200 ffebld_constant_complex3 (ffebld_conter (r)));
3201 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3202 (ffebld_cu_val_complex3 (u)), expr);
3203 break;
3204 #endif
3205
3206 default:
3207 assert ("bad complex kind type" == NULL);
3208 break;
3209 }
3210 break;
3211
3212 default:
3213 assert ("bad type" == NULL);
3214 return expr;
3215 }
3216
3217 ffebld_set_info (expr, ffeinfo_new
3218 (bt,
3219 kt,
3220 0,
3221 FFEINFO_kindENTITY,
3222 FFEINFO_whereCONSTANT,
3223 FFETARGET_charactersizeNONE));
3224
3225 if ((error != FFEBAD)
3226 && ffebad_start (error))
3227 {
3228 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3229 ffebad_finish ();
3230 }
3231
3232 return expr;
3233 }
3234
3235 /* ffeexpr_collapse_subtract -- Collapse subtract expr
3236
3237 ffebld expr;
3238 ffelexToken token;
3239 expr = ffeexpr_collapse_subtract(expr,token);
3240
3241 If the result of the expr is a constant, replaces the expr with the
3242 computed constant. */
3243
3244 ffebld
3245 ffeexpr_collapse_subtract (ffebld expr, ffelexToken t)
3246 {
3247 ffebad error = FFEBAD;
3248 ffebld l;
3249 ffebld r;
3250 ffebldConstantUnion u;
3251 ffeinfoBasictype bt;
3252 ffeinfoKindtype kt;
3253
3254 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3255 return expr;
3256
3257 l = ffebld_left (expr);
3258 r = ffebld_right (expr);
3259
3260 if (ffebld_op (l) != FFEBLD_opCONTER)
3261 return expr;
3262 if (ffebld_op (r) != FFEBLD_opCONTER)
3263 return expr;
3264
3265 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3266 {
3267 case FFEINFO_basictypeANY:
3268 return expr;
3269
3270 case FFEINFO_basictypeINTEGER:
3271 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3272 {
3273 #if FFETARGET_okINTEGER1
3274 case FFEINFO_kindtypeINTEGER1:
3275 error = ffetarget_subtract_integer1 (ffebld_cu_ptr_integer1 (u),
3276 ffebld_constant_integer1 (ffebld_conter (l)),
3277 ffebld_constant_integer1 (ffebld_conter (r)));
3278 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3279 (ffebld_cu_val_integer1 (u)), expr);
3280 break;
3281 #endif
3282
3283 #if FFETARGET_okINTEGER2
3284 case FFEINFO_kindtypeINTEGER2:
3285 error = ffetarget_subtract_integer2 (ffebld_cu_ptr_integer2 (u),
3286 ffebld_constant_integer2 (ffebld_conter (l)),
3287 ffebld_constant_integer2 (ffebld_conter (r)));
3288 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3289 (ffebld_cu_val_integer2 (u)), expr);
3290 break;
3291 #endif
3292
3293 #if FFETARGET_okINTEGER3
3294 case FFEINFO_kindtypeINTEGER3:
3295 error = ffetarget_subtract_integer3 (ffebld_cu_ptr_integer3 (u),
3296 ffebld_constant_integer3 (ffebld_conter (l)),
3297 ffebld_constant_integer3 (ffebld_conter (r)));
3298 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3299 (ffebld_cu_val_integer3 (u)), expr);
3300 break;
3301 #endif
3302
3303 #if FFETARGET_okINTEGER4
3304 case FFEINFO_kindtypeINTEGER4:
3305 error = ffetarget_subtract_integer4 (ffebld_cu_ptr_integer4 (u),
3306 ffebld_constant_integer4 (ffebld_conter (l)),
3307 ffebld_constant_integer4 (ffebld_conter (r)));
3308 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3309 (ffebld_cu_val_integer4 (u)), expr);
3310 break;
3311 #endif
3312
3313 default:
3314 assert ("bad integer kind type" == NULL);
3315 break;
3316 }
3317 break;
3318
3319 case FFEINFO_basictypeREAL:
3320 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3321 {
3322 #if FFETARGET_okREAL1
3323 case FFEINFO_kindtypeREAL1:
3324 error = ffetarget_subtract_real1 (ffebld_cu_ptr_real1 (u),
3325 ffebld_constant_real1 (ffebld_conter (l)),
3326 ffebld_constant_real1 (ffebld_conter (r)));
3327 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3328 (ffebld_cu_val_real1 (u)), expr);
3329 break;
3330 #endif
3331
3332 #if FFETARGET_okREAL2
3333 case FFEINFO_kindtypeREAL2:
3334 error = ffetarget_subtract_real2 (ffebld_cu_ptr_real2 (u),
3335 ffebld_constant_real2 (ffebld_conter (l)),
3336 ffebld_constant_real2 (ffebld_conter (r)));
3337 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3338 (ffebld_cu_val_real2 (u)), expr);
3339 break;
3340 #endif
3341
3342 #if FFETARGET_okREAL3
3343 case FFEINFO_kindtypeREAL3:
3344 error = ffetarget_subtract_real3 (ffebld_cu_ptr_real3 (u),
3345 ffebld_constant_real3 (ffebld_conter (l)),
3346 ffebld_constant_real3 (ffebld_conter (r)));
3347 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3348 (ffebld_cu_val_real3 (u)), expr);
3349 break;
3350 #endif
3351
3352 default:
3353 assert ("bad real kind type" == NULL);
3354 break;
3355 }
3356 break;
3357
3358 case FFEINFO_basictypeCOMPLEX:
3359 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3360 {
3361 #if FFETARGET_okCOMPLEX1
3362 case FFEINFO_kindtypeREAL1:
3363 error = ffetarget_subtract_complex1 (ffebld_cu_ptr_complex1 (u),
3364 ffebld_constant_complex1 (ffebld_conter (l)),
3365 ffebld_constant_complex1 (ffebld_conter (r)));
3366 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3367 (ffebld_cu_val_complex1 (u)), expr);
3368 break;
3369 #endif
3370
3371 #if FFETARGET_okCOMPLEX2
3372 case FFEINFO_kindtypeREAL2:
3373 error = ffetarget_subtract_complex2 (ffebld_cu_ptr_complex2 (u),
3374 ffebld_constant_complex2 (ffebld_conter (l)),
3375 ffebld_constant_complex2 (ffebld_conter (r)));
3376 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3377 (ffebld_cu_val_complex2 (u)), expr);
3378 break;
3379 #endif
3380
3381 #if FFETARGET_okCOMPLEX3
3382 case FFEINFO_kindtypeREAL3:
3383 error = ffetarget_subtract_complex3 (ffebld_cu_ptr_complex3 (u),
3384 ffebld_constant_complex3 (ffebld_conter (l)),
3385 ffebld_constant_complex3 (ffebld_conter (r)));
3386 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3387 (ffebld_cu_val_complex3 (u)), expr);
3388 break;
3389 #endif
3390
3391 default:
3392 assert ("bad complex kind type" == NULL);
3393 break;
3394 }
3395 break;
3396
3397 default:
3398 assert ("bad type" == NULL);
3399 return expr;
3400 }
3401
3402 ffebld_set_info (expr, ffeinfo_new
3403 (bt,
3404 kt,
3405 0,
3406 FFEINFO_kindENTITY,
3407 FFEINFO_whereCONSTANT,
3408 FFETARGET_charactersizeNONE));
3409
3410 if ((error != FFEBAD)
3411 && ffebad_start (error))
3412 {
3413 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3414 ffebad_finish ();
3415 }
3416
3417 return expr;
3418 }
3419
3420 /* ffeexpr_collapse_multiply -- Collapse multiply expr
3421
3422 ffebld expr;
3423 ffelexToken token;
3424 expr = ffeexpr_collapse_multiply(expr,token);
3425
3426 If the result of the expr is a constant, replaces the expr with the
3427 computed constant. */
3428
3429 ffebld
3430 ffeexpr_collapse_multiply (ffebld expr, ffelexToken t)
3431 {
3432 ffebad error = FFEBAD;
3433 ffebld l;
3434 ffebld r;
3435 ffebldConstantUnion u;
3436 ffeinfoBasictype bt;
3437 ffeinfoKindtype kt;
3438
3439 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3440 return expr;
3441
3442 l = ffebld_left (expr);
3443 r = ffebld_right (expr);
3444
3445 if (ffebld_op (l) != FFEBLD_opCONTER)
3446 return expr;
3447 if (ffebld_op (r) != FFEBLD_opCONTER)
3448 return expr;
3449
3450 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3451 {
3452 case FFEINFO_basictypeANY:
3453 return expr;
3454
3455 case FFEINFO_basictypeINTEGER:
3456 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3457 {
3458 #if FFETARGET_okINTEGER1
3459 case FFEINFO_kindtypeINTEGER1:
3460 error = ffetarget_multiply_integer1 (ffebld_cu_ptr_integer1 (u),
3461 ffebld_constant_integer1 (ffebld_conter (l)),
3462 ffebld_constant_integer1 (ffebld_conter (r)));
3463 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3464 (ffebld_cu_val_integer1 (u)), expr);
3465 break;
3466 #endif
3467
3468 #if FFETARGET_okINTEGER2
3469 case FFEINFO_kindtypeINTEGER2:
3470 error = ffetarget_multiply_integer2 (ffebld_cu_ptr_integer2 (u),
3471 ffebld_constant_integer2 (ffebld_conter (l)),
3472 ffebld_constant_integer2 (ffebld_conter (r)));
3473 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3474 (ffebld_cu_val_integer2 (u)), expr);
3475 break;
3476 #endif
3477
3478 #if FFETARGET_okINTEGER3
3479 case FFEINFO_kindtypeINTEGER3:
3480 error = ffetarget_multiply_integer3 (ffebld_cu_ptr_integer3 (u),
3481 ffebld_constant_integer3 (ffebld_conter (l)),
3482 ffebld_constant_integer3 (ffebld_conter (r)));
3483 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3484 (ffebld_cu_val_integer3 (u)), expr);
3485 break;
3486 #endif
3487
3488 #if FFETARGET_okINTEGER4
3489 case FFEINFO_kindtypeINTEGER4:
3490 error = ffetarget_multiply_integer4 (ffebld_cu_ptr_integer4 (u),
3491 ffebld_constant_integer4 (ffebld_conter (l)),
3492 ffebld_constant_integer4 (ffebld_conter (r)));
3493 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3494 (ffebld_cu_val_integer4 (u)), expr);
3495 break;
3496 #endif
3497
3498 default:
3499 assert ("bad integer kind type" == NULL);
3500 break;
3501 }
3502 break;
3503
3504 case FFEINFO_basictypeREAL:
3505 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3506 {
3507 #if FFETARGET_okREAL1
3508 case FFEINFO_kindtypeREAL1:
3509 error = ffetarget_multiply_real1 (ffebld_cu_ptr_real1 (u),
3510 ffebld_constant_real1 (ffebld_conter (l)),
3511 ffebld_constant_real1 (ffebld_conter (r)));
3512 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3513 (ffebld_cu_val_real1 (u)), expr);
3514 break;
3515 #endif
3516
3517 #if FFETARGET_okREAL2
3518 case FFEINFO_kindtypeREAL2:
3519 error = ffetarget_multiply_real2 (ffebld_cu_ptr_real2 (u),
3520 ffebld_constant_real2 (ffebld_conter (l)),
3521 ffebld_constant_real2 (ffebld_conter (r)));
3522 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3523 (ffebld_cu_val_real2 (u)), expr);
3524 break;
3525 #endif
3526
3527 #if FFETARGET_okREAL3
3528 case FFEINFO_kindtypeREAL3:
3529 error = ffetarget_multiply_real3 (ffebld_cu_ptr_real3 (u),
3530 ffebld_constant_real3 (ffebld_conter (l)),
3531 ffebld_constant_real3 (ffebld_conter (r)));
3532 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3533 (ffebld_cu_val_real3 (u)), expr);
3534 break;
3535 #endif
3536
3537 default:
3538 assert ("bad real kind type" == NULL);
3539 break;
3540 }
3541 break;
3542
3543 case FFEINFO_basictypeCOMPLEX:
3544 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3545 {
3546 #if FFETARGET_okCOMPLEX1
3547 case FFEINFO_kindtypeREAL1:
3548 error = ffetarget_multiply_complex1 (ffebld_cu_ptr_complex1 (u),
3549 ffebld_constant_complex1 (ffebld_conter (l)),
3550 ffebld_constant_complex1 (ffebld_conter (r)));
3551 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3552 (ffebld_cu_val_complex1 (u)), expr);
3553 break;
3554 #endif
3555
3556 #if FFETARGET_okCOMPLEX2
3557 case FFEINFO_kindtypeREAL2:
3558 error = ffetarget_multiply_complex2 (ffebld_cu_ptr_complex2 (u),
3559 ffebld_constant_complex2 (ffebld_conter (l)),
3560 ffebld_constant_complex2 (ffebld_conter (r)));
3561 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3562 (ffebld_cu_val_complex2 (u)), expr);
3563 break;
3564 #endif
3565
3566 #if FFETARGET_okCOMPLEX3
3567 case FFEINFO_kindtypeREAL3:
3568 error = ffetarget_multiply_complex3 (ffebld_cu_ptr_complex3 (u),
3569 ffebld_constant_complex3 (ffebld_conter (l)),
3570 ffebld_constant_complex3 (ffebld_conter (r)));
3571 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3572 (ffebld_cu_val_complex3 (u)), expr);
3573 break;
3574 #endif
3575
3576 default:
3577 assert ("bad complex kind type" == NULL);
3578 break;
3579 }
3580 break;
3581
3582 default:
3583 assert ("bad type" == NULL);
3584 return expr;
3585 }
3586
3587 ffebld_set_info (expr, ffeinfo_new
3588 (bt,
3589 kt,
3590 0,
3591 FFEINFO_kindENTITY,
3592 FFEINFO_whereCONSTANT,
3593 FFETARGET_charactersizeNONE));
3594
3595 if ((error != FFEBAD)
3596 && ffebad_start (error))
3597 {
3598 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3599 ffebad_finish ();
3600 }
3601
3602 return expr;
3603 }
3604
3605 /* ffeexpr_collapse_divide -- Collapse divide expr
3606
3607 ffebld expr;
3608 ffelexToken token;
3609 expr = ffeexpr_collapse_divide(expr,token);
3610
3611 If the result of the expr is a constant, replaces the expr with the
3612 computed constant. */
3613
3614 ffebld
3615 ffeexpr_collapse_divide (ffebld expr, ffelexToken t)
3616 {
3617 ffebad error = FFEBAD;
3618 ffebld l;
3619 ffebld r;
3620 ffebldConstantUnion u;
3621 ffeinfoBasictype bt;
3622 ffeinfoKindtype kt;
3623
3624 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3625 return expr;
3626
3627 l = ffebld_left (expr);
3628 r = ffebld_right (expr);
3629
3630 if (ffebld_op (l) != FFEBLD_opCONTER)
3631 return expr;
3632 if (ffebld_op (r) != FFEBLD_opCONTER)
3633 return expr;
3634
3635 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3636 {
3637 case FFEINFO_basictypeANY:
3638 return expr;
3639
3640 case FFEINFO_basictypeINTEGER:
3641 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3642 {
3643 #if FFETARGET_okINTEGER1
3644 case FFEINFO_kindtypeINTEGER1:
3645 error = ffetarget_divide_integer1 (ffebld_cu_ptr_integer1 (u),
3646 ffebld_constant_integer1 (ffebld_conter (l)),
3647 ffebld_constant_integer1 (ffebld_conter (r)));
3648 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3649 (ffebld_cu_val_integer1 (u)), expr);
3650 break;
3651 #endif
3652
3653 #if FFETARGET_okINTEGER2
3654 case FFEINFO_kindtypeINTEGER2:
3655 error = ffetarget_divide_integer2 (ffebld_cu_ptr_integer2 (u),
3656 ffebld_constant_integer2 (ffebld_conter (l)),
3657 ffebld_constant_integer2 (ffebld_conter (r)));
3658 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3659 (ffebld_cu_val_integer2 (u)), expr);
3660 break;
3661 #endif
3662
3663 #if FFETARGET_okINTEGER3
3664 case FFEINFO_kindtypeINTEGER3:
3665 error = ffetarget_divide_integer3 (ffebld_cu_ptr_integer3 (u),
3666 ffebld_constant_integer3 (ffebld_conter (l)),
3667 ffebld_constant_integer3 (ffebld_conter (r)));
3668 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3669 (ffebld_cu_val_integer3 (u)), expr);
3670 break;
3671 #endif
3672
3673 #if FFETARGET_okINTEGER4
3674 case FFEINFO_kindtypeINTEGER4:
3675 error = ffetarget_divide_integer4 (ffebld_cu_ptr_integer4 (u),
3676 ffebld_constant_integer4 (ffebld_conter (l)),
3677 ffebld_constant_integer4 (ffebld_conter (r)));
3678 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3679 (ffebld_cu_val_integer4 (u)), expr);
3680 break;
3681 #endif
3682
3683 default:
3684 assert ("bad integer kind type" == NULL);
3685 break;
3686 }
3687 break;
3688
3689 case FFEINFO_basictypeREAL:
3690 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3691 {
3692 #if FFETARGET_okREAL1
3693 case FFEINFO_kindtypeREAL1:
3694 error = ffetarget_divide_real1 (ffebld_cu_ptr_real1 (u),
3695 ffebld_constant_real1 (ffebld_conter (l)),
3696 ffebld_constant_real1 (ffebld_conter (r)));
3697 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3698 (ffebld_cu_val_real1 (u)), expr);
3699 break;
3700 #endif
3701
3702 #if FFETARGET_okREAL2
3703 case FFEINFO_kindtypeREAL2:
3704 error = ffetarget_divide_real2 (ffebld_cu_ptr_real2 (u),
3705 ffebld_constant_real2 (ffebld_conter (l)),
3706 ffebld_constant_real2 (ffebld_conter (r)));
3707 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3708 (ffebld_cu_val_real2 (u)), expr);
3709 break;
3710 #endif
3711
3712 #if FFETARGET_okREAL3
3713 case FFEINFO_kindtypeREAL3:
3714 error = ffetarget_divide_real3 (ffebld_cu_ptr_real3 (u),
3715 ffebld_constant_real3 (ffebld_conter (l)),
3716 ffebld_constant_real3 (ffebld_conter (r)));
3717 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3718 (ffebld_cu_val_real3 (u)), expr);
3719 break;
3720 #endif
3721
3722 default:
3723 assert ("bad real kind type" == NULL);
3724 break;
3725 }
3726 break;
3727
3728 case FFEINFO_basictypeCOMPLEX:
3729 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3730 {
3731 #if FFETARGET_okCOMPLEX1
3732 case FFEINFO_kindtypeREAL1:
3733 error = ffetarget_divide_complex1 (ffebld_cu_ptr_complex1 (u),
3734 ffebld_constant_complex1 (ffebld_conter (l)),
3735 ffebld_constant_complex1 (ffebld_conter (r)));
3736 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3737 (ffebld_cu_val_complex1 (u)), expr);
3738 break;
3739 #endif
3740
3741 #if FFETARGET_okCOMPLEX2
3742 case FFEINFO_kindtypeREAL2:
3743 error = ffetarget_divide_complex2 (ffebld_cu_ptr_complex2 (u),
3744 ffebld_constant_complex2 (ffebld_conter (l)),
3745 ffebld_constant_complex2 (ffebld_conter (r)));
3746 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3747 (ffebld_cu_val_complex2 (u)), expr);
3748 break;
3749 #endif
3750
3751 #if FFETARGET_okCOMPLEX3
3752 case FFEINFO_kindtypeREAL3:
3753 error = ffetarget_divide_complex3 (ffebld_cu_ptr_complex3 (u),
3754 ffebld_constant_complex3 (ffebld_conter (l)),
3755 ffebld_constant_complex3 (ffebld_conter (r)));
3756 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3757 (ffebld_cu_val_complex3 (u)), expr);
3758 break;
3759 #endif
3760
3761 default:
3762 assert ("bad complex kind type" == NULL);
3763 break;
3764 }
3765 break;
3766
3767 default:
3768 assert ("bad type" == NULL);
3769 return expr;
3770 }
3771
3772 ffebld_set_info (expr, ffeinfo_new
3773 (bt,
3774 kt,
3775 0,
3776 FFEINFO_kindENTITY,
3777 FFEINFO_whereCONSTANT,
3778 FFETARGET_charactersizeNONE));
3779
3780 if ((error != FFEBAD)
3781 && ffebad_start (error))
3782 {
3783 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3784 ffebad_finish ();
3785 }
3786
3787 return expr;
3788 }
3789
3790 /* ffeexpr_collapse_power -- Collapse power expr
3791
3792 ffebld expr;
3793 ffelexToken token;
3794 expr = ffeexpr_collapse_power(expr,token);
3795
3796 If the result of the expr is a constant, replaces the expr with the
3797 computed constant. */
3798
3799 ffebld
3800 ffeexpr_collapse_power (ffebld expr, ffelexToken t)
3801 {
3802 ffebad error = FFEBAD;
3803 ffebld l;
3804 ffebld r;
3805 ffebldConstantUnion u;
3806 ffeinfoBasictype bt;
3807 ffeinfoKindtype kt;
3808
3809 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3810 return expr;
3811
3812 l = ffebld_left (expr);
3813 r = ffebld_right (expr);
3814
3815 if (ffebld_op (l) != FFEBLD_opCONTER)
3816 return expr;
3817 if (ffebld_op (r) != FFEBLD_opCONTER)
3818 return expr;
3819
3820 if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER)
3821 || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT))
3822 return expr;
3823
3824 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3825 {
3826 case FFEINFO_basictypeANY:
3827 return expr;
3828
3829 case FFEINFO_basictypeINTEGER:
3830 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3831 {
3832 case FFEINFO_kindtypeINTEGERDEFAULT:
3833 error = ffetarget_power_integerdefault_integerdefault
3834 (ffebld_cu_ptr_integerdefault (u),
3835 ffebld_constant_integerdefault (ffebld_conter (l)),
3836 ffebld_constant_integerdefault (ffebld_conter (r)));
3837 expr = ffebld_new_conter_with_orig
3838 (ffebld_constant_new_integerdefault_val
3839 (ffebld_cu_val_integerdefault (u)), expr);
3840 break;
3841
3842 default:
3843 assert ("bad integer kind type" == NULL);
3844 break;
3845 }
3846 break;
3847
3848 case FFEINFO_basictypeREAL:
3849 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3850 {
3851 case FFEINFO_kindtypeREALDEFAULT:
3852 error = ffetarget_power_realdefault_integerdefault
3853 (ffebld_cu_ptr_realdefault (u),
3854 ffebld_constant_realdefault (ffebld_conter (l)),
3855 ffebld_constant_integerdefault (ffebld_conter (r)));
3856 expr = ffebld_new_conter_with_orig
3857 (ffebld_constant_new_realdefault_val
3858 (ffebld_cu_val_realdefault (u)), expr);
3859 break;
3860
3861 case FFEINFO_kindtypeREALDOUBLE:
3862 error = ffetarget_power_realdouble_integerdefault
3863 (ffebld_cu_ptr_realdouble (u),
3864 ffebld_constant_realdouble (ffebld_conter (l)),
3865 ffebld_constant_integerdefault (ffebld_conter (r)));
3866 expr = ffebld_new_conter_with_orig
3867 (ffebld_constant_new_realdouble_val
3868 (ffebld_cu_val_realdouble (u)), expr);
3869 break;
3870
3871 #if FFETARGET_okREALQUAD
3872 case FFEINFO_kindtypeREALQUAD:
3873 error = ffetarget_power_realquad_integerdefault
3874 (ffebld_cu_ptr_realquad (u),
3875 ffebld_constant_realquad (ffebld_conter (l)),
3876 ffebld_constant_integerdefault (ffebld_conter (r)));
3877 expr = ffebld_new_conter_with_orig
3878 (ffebld_constant_new_realquad_val
3879 (ffebld_cu_val_realquad (u)), expr);
3880 break;
3881 #endif
3882 default:
3883 assert ("bad real kind type" == NULL);
3884 break;
3885 }
3886 break;
3887
3888 case FFEINFO_basictypeCOMPLEX:
3889 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3890 {
3891 case FFEINFO_kindtypeREALDEFAULT:
3892 error = ffetarget_power_complexdefault_integerdefault
3893 (ffebld_cu_ptr_complexdefault (u),
3894 ffebld_constant_complexdefault (ffebld_conter (l)),
3895 ffebld_constant_integerdefault (ffebld_conter (r)));
3896 expr = ffebld_new_conter_with_orig
3897 (ffebld_constant_new_complexdefault_val
3898 (ffebld_cu_val_complexdefault (u)), expr);
3899 break;
3900
3901 #if FFETARGET_okCOMPLEXDOUBLE
3902 case FFEINFO_kindtypeREALDOUBLE:
3903 error = ffetarget_power_complexdouble_integerdefault
3904 (ffebld_cu_ptr_complexdouble (u),
3905 ffebld_constant_complexdouble (ffebld_conter (l)),
3906 ffebld_constant_integerdefault (ffebld_conter (r)));
3907 expr = ffebld_new_conter_with_orig
3908 (ffebld_constant_new_complexdouble_val
3909 (ffebld_cu_val_complexdouble (u)), expr);
3910 break;
3911 #endif
3912
3913 #if FFETARGET_okCOMPLEXQUAD
3914 case FFEINFO_kindtypeREALQUAD:
3915 error = ffetarget_power_complexquad_integerdefault
3916 (ffebld_cu_ptr_complexquad (u),
3917 ffebld_constant_complexquad (ffebld_conter (l)),
3918 ffebld_constant_integerdefault (ffebld_conter (r)));
3919 expr = ffebld_new_conter_with_orig
3920 (ffebld_constant_new_complexquad_val
3921 (ffebld_cu_val_complexquad (u)), expr);
3922 break;
3923 #endif
3924
3925 default:
3926 assert ("bad complex kind type" == NULL);
3927 break;
3928 }
3929 break;
3930
3931 default:
3932 assert ("bad type" == NULL);
3933 return expr;
3934 }
3935
3936 ffebld_set_info (expr, ffeinfo_new
3937 (bt,
3938 kt,
3939 0,
3940 FFEINFO_kindENTITY,
3941 FFEINFO_whereCONSTANT,
3942 FFETARGET_charactersizeNONE));
3943
3944 if ((error != FFEBAD)
3945 && ffebad_start (error))
3946 {
3947 ffebad_here (0, ffelex_token_where_line (t),
3948 ffelex_token_where_column (t));
3949 ffebad_finish ();
3950 }
3951
3952 return expr;
3953 }
3954
3955 /* ffeexpr_collapse_concatenate -- Collapse concatenate expr
3956
3957 ffebld expr;
3958 ffelexToken token;
3959 expr = ffeexpr_collapse_concatenate(expr,token);
3960
3961 If the result of the expr is a constant, replaces the expr with the
3962 computed constant. */
3963
3964 ffebld
3965 ffeexpr_collapse_concatenate (ffebld expr, ffelexToken t)
3966 {
3967 ffebad error = FFEBAD;
3968 ffebld l;
3969 ffebld r;
3970 ffebldConstantUnion u;
3971 ffeinfoKindtype kt;
3972 ffetargetCharacterSize len;
3973
3974 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3975 return expr;
3976
3977 l = ffebld_left (expr);
3978 r = ffebld_right (expr);
3979
3980 if (ffebld_op (l) != FFEBLD_opCONTER)
3981 return expr;
3982 if (ffebld_op (r) != FFEBLD_opCONTER)
3983 return expr;
3984
3985 switch (ffeinfo_basictype (ffebld_info (expr)))
3986 {
3987 case FFEINFO_basictypeANY:
3988 return expr;
3989
3990 case FFEINFO_basictypeCHARACTER:
3991 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3992 {
3993 #if FFETARGET_okCHARACTER1
3994 case FFEINFO_kindtypeCHARACTER1:
3995 error = ffetarget_concatenate_character1 (ffebld_cu_ptr_character1 (u),
3996 ffebld_constant_character1 (ffebld_conter (l)),
3997 ffebld_constant_character1 (ffebld_conter (r)),
3998 ffebld_constant_pool (), &len);
3999 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
4000 (ffebld_cu_val_character1 (u)), expr);
4001 break;
4002 #endif
4003
4004 default:
4005 assert ("bad character kind type" == NULL);
4006 break;
4007 }
4008 break;
4009
4010 default:
4011 assert ("bad type" == NULL);
4012 return expr;
4013 }
4014
4015 ffebld_set_info (expr, ffeinfo_new
4016 (FFEINFO_basictypeCHARACTER,
4017 kt,
4018 0,
4019 FFEINFO_kindENTITY,
4020 FFEINFO_whereCONSTANT,
4021 len));
4022
4023 if ((error != FFEBAD)
4024 && ffebad_start (error))
4025 {
4026 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4027 ffebad_finish ();
4028 }
4029
4030 return expr;
4031 }
4032
4033 /* ffeexpr_collapse_eq -- Collapse eq expr
4034
4035 ffebld expr;
4036 ffelexToken token;
4037 expr = ffeexpr_collapse_eq(expr,token);
4038
4039 If the result of the expr is a constant, replaces the expr with the
4040 computed constant. */
4041
4042 ffebld
4043 ffeexpr_collapse_eq (ffebld expr, ffelexToken t)
4044 {
4045 ffebad error = FFEBAD;
4046 ffebld l;
4047 ffebld r;
4048 bool val;
4049
4050 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4051 return expr;
4052
4053 l = ffebld_left (expr);
4054 r = ffebld_right (expr);
4055
4056 if (ffebld_op (l) != FFEBLD_opCONTER)
4057 return expr;
4058 if (ffebld_op (r) != FFEBLD_opCONTER)
4059 return expr;
4060
4061 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4062 {
4063 case FFEINFO_basictypeANY:
4064 return expr;
4065
4066 case FFEINFO_basictypeINTEGER:
4067 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4068 {
4069 #if FFETARGET_okINTEGER1
4070 case FFEINFO_kindtypeINTEGER1:
4071 error = ffetarget_eq_integer1 (&val,
4072 ffebld_constant_integer1 (ffebld_conter (l)),
4073 ffebld_constant_integer1 (ffebld_conter (r)));
4074 expr = ffebld_new_conter_with_orig
4075 (ffebld_constant_new_logicaldefault (val), expr);
4076 break;
4077 #endif
4078
4079 #if FFETARGET_okINTEGER2
4080 case FFEINFO_kindtypeINTEGER2:
4081 error = ffetarget_eq_integer2 (&val,
4082 ffebld_constant_integer2 (ffebld_conter (l)),
4083 ffebld_constant_integer2 (ffebld_conter (r)));
4084 expr = ffebld_new_conter_with_orig
4085 (ffebld_constant_new_logicaldefault (val), expr);
4086 break;
4087 #endif
4088
4089 #if FFETARGET_okINTEGER3
4090 case FFEINFO_kindtypeINTEGER3:
4091 error = ffetarget_eq_integer3 (&val,
4092 ffebld_constant_integer3 (ffebld_conter (l)),
4093 ffebld_constant_integer3 (ffebld_conter (r)));
4094 expr = ffebld_new_conter_with_orig
4095 (ffebld_constant_new_logicaldefault (val), expr);
4096 break;
4097 #endif
4098
4099 #if FFETARGET_okINTEGER4
4100 case FFEINFO_kindtypeINTEGER4:
4101 error = ffetarget_eq_integer4 (&val,
4102 ffebld_constant_integer4 (ffebld_conter (l)),
4103 ffebld_constant_integer4 (ffebld_conter (r)));
4104 expr = ffebld_new_conter_with_orig
4105 (ffebld_constant_new_logicaldefault (val), expr);
4106 break;
4107 #endif
4108
4109 default:
4110 assert ("bad integer kind type" == NULL);
4111 break;
4112 }
4113 break;
4114
4115 case FFEINFO_basictypeREAL:
4116 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4117 {
4118 #if FFETARGET_okREAL1
4119 case FFEINFO_kindtypeREAL1:
4120 error = ffetarget_eq_real1 (&val,
4121 ffebld_constant_real1 (ffebld_conter (l)),
4122 ffebld_constant_real1 (ffebld_conter (r)));
4123 expr = ffebld_new_conter_with_orig
4124 (ffebld_constant_new_logicaldefault (val), expr);
4125 break;
4126 #endif
4127
4128 #if FFETARGET_okREAL2
4129 case FFEINFO_kindtypeREAL2:
4130 error = ffetarget_eq_real2 (&val,
4131 ffebld_constant_real2 (ffebld_conter (l)),
4132 ffebld_constant_real2 (ffebld_conter (r)));
4133 expr = ffebld_new_conter_with_orig
4134 (ffebld_constant_new_logicaldefault (val), expr);
4135 break;
4136 #endif
4137
4138 #if FFETARGET_okREAL3
4139 case FFEINFO_kindtypeREAL3:
4140 error = ffetarget_eq_real3 (&val,
4141 ffebld_constant_real3 (ffebld_conter (l)),
4142 ffebld_constant_real3 (ffebld_conter (r)));
4143 expr = ffebld_new_conter_with_orig
4144 (ffebld_constant_new_logicaldefault (val), expr);
4145 break;
4146 #endif
4147
4148 default:
4149 assert ("bad real kind type" == NULL);
4150 break;
4151 }
4152 break;
4153
4154 case FFEINFO_basictypeCOMPLEX:
4155 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4156 {
4157 #if FFETARGET_okCOMPLEX1
4158 case FFEINFO_kindtypeREAL1:
4159 error = ffetarget_eq_complex1 (&val,
4160 ffebld_constant_complex1 (ffebld_conter (l)),
4161 ffebld_constant_complex1 (ffebld_conter (r)));
4162 expr = ffebld_new_conter_with_orig
4163 (ffebld_constant_new_logicaldefault (val), expr);
4164 break;
4165 #endif
4166
4167 #if FFETARGET_okCOMPLEX2
4168 case FFEINFO_kindtypeREAL2:
4169 error = ffetarget_eq_complex2 (&val,
4170 ffebld_constant_complex2 (ffebld_conter (l)),
4171 ffebld_constant_complex2 (ffebld_conter (r)));
4172 expr = ffebld_new_conter_with_orig
4173 (ffebld_constant_new_logicaldefault (val), expr);
4174 break;
4175 #endif
4176
4177 #if FFETARGET_okCOMPLEX3
4178 case FFEINFO_kindtypeREAL3:
4179 error = ffetarget_eq_complex3 (&val,
4180 ffebld_constant_complex3 (ffebld_conter (l)),
4181 ffebld_constant_complex3 (ffebld_conter (r)));
4182 expr = ffebld_new_conter_with_orig
4183 (ffebld_constant_new_logicaldefault (val), expr);
4184 break;
4185 #endif
4186
4187 default:
4188 assert ("bad complex kind type" == NULL);
4189 break;
4190 }
4191 break;
4192
4193 case FFEINFO_basictypeCHARACTER:
4194 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4195 {
4196 #if FFETARGET_okCHARACTER1
4197 case FFEINFO_kindtypeCHARACTER1:
4198 error = ffetarget_eq_character1 (&val,
4199 ffebld_constant_character1 (ffebld_conter (l)),
4200 ffebld_constant_character1 (ffebld_conter (r)));
4201 expr = ffebld_new_conter_with_orig
4202 (ffebld_constant_new_logicaldefault (val), expr);
4203 break;
4204 #endif
4205
4206 default:
4207 assert ("bad character kind type" == NULL);
4208 break;
4209 }
4210 break;
4211
4212 default:
4213 assert ("bad type" == NULL);
4214 return expr;
4215 }
4216
4217 ffebld_set_info (expr, ffeinfo_new
4218 (FFEINFO_basictypeLOGICAL,
4219 FFEINFO_kindtypeLOGICALDEFAULT,
4220 0,
4221 FFEINFO_kindENTITY,
4222 FFEINFO_whereCONSTANT,
4223 FFETARGET_charactersizeNONE));
4224
4225 if ((error != FFEBAD)
4226 && ffebad_start (error))
4227 {
4228 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4229 ffebad_finish ();
4230 }
4231
4232 return expr;
4233 }
4234
4235 /* ffeexpr_collapse_ne -- Collapse ne expr
4236
4237 ffebld expr;
4238 ffelexToken token;
4239 expr = ffeexpr_collapse_ne(expr,token);
4240
4241 If the result of the expr is a constant, replaces the expr with the
4242 computed constant. */
4243
4244 ffebld
4245 ffeexpr_collapse_ne (ffebld expr, ffelexToken t)
4246 {
4247 ffebad error = FFEBAD;
4248 ffebld l;
4249 ffebld r;
4250 bool val;
4251
4252 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4253 return expr;
4254
4255 l = ffebld_left (expr);
4256 r = ffebld_right (expr);
4257
4258 if (ffebld_op (l) != FFEBLD_opCONTER)
4259 return expr;
4260 if (ffebld_op (r) != FFEBLD_opCONTER)
4261 return expr;
4262
4263 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4264 {
4265 case FFEINFO_basictypeANY:
4266 return expr;
4267
4268 case FFEINFO_basictypeINTEGER:
4269 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4270 {
4271 #if FFETARGET_okINTEGER1
4272 case FFEINFO_kindtypeINTEGER1:
4273 error = ffetarget_ne_integer1 (&val,
4274 ffebld_constant_integer1 (ffebld_conter (l)),
4275 ffebld_constant_integer1 (ffebld_conter (r)));
4276 expr = ffebld_new_conter_with_orig
4277 (ffebld_constant_new_logicaldefault (val), expr);
4278 break;
4279 #endif
4280
4281 #if FFETARGET_okINTEGER2
4282 case FFEINFO_kindtypeINTEGER2:
4283 error = ffetarget_ne_integer2 (&val,
4284 ffebld_constant_integer2 (ffebld_conter (l)),
4285 ffebld_constant_integer2 (ffebld_conter (r)));
4286 expr = ffebld_new_conter_with_orig
4287 (ffebld_constant_new_logicaldefault (val), expr);
4288 break;
4289 #endif
4290
4291 #if FFETARGET_okINTEGER3
4292 case FFEINFO_kindtypeINTEGER3:
4293 error = ffetarget_ne_integer3 (&val,
4294 ffebld_constant_integer3 (ffebld_conter (l)),
4295 ffebld_constant_integer3 (ffebld_conter (r)));
4296 expr = ffebld_new_conter_with_orig
4297 (ffebld_constant_new_logicaldefault (val), expr);
4298 break;
4299 #endif
4300
4301 #if FFETARGET_okINTEGER4
4302 case FFEINFO_kindtypeINTEGER4:
4303 error = ffetarget_ne_integer4 (&val,
4304 ffebld_constant_integer4 (ffebld_conter (l)),
4305 ffebld_constant_integer4 (ffebld_conter (r)));
4306 expr = ffebld_new_conter_with_orig
4307 (ffebld_constant_new_logicaldefault (val), expr);
4308 break;
4309 #endif
4310
4311 default:
4312 assert ("bad integer kind type" == NULL);
4313 break;
4314 }
4315 break;
4316
4317 case FFEINFO_basictypeREAL:
4318 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4319 {
4320 #if FFETARGET_okREAL1
4321 case FFEINFO_kindtypeREAL1:
4322 error = ffetarget_ne_real1 (&val,
4323 ffebld_constant_real1 (ffebld_conter (l)),
4324 ffebld_constant_real1 (ffebld_conter (r)));
4325 expr = ffebld_new_conter_with_orig
4326 (ffebld_constant_new_logicaldefault (val), expr);
4327 break;
4328 #endif
4329
4330 #if FFETARGET_okREAL2
4331 case FFEINFO_kindtypeREAL2:
4332 error = ffetarget_ne_real2 (&val,
4333 ffebld_constant_real2 (ffebld_conter (l)),
4334 ffebld_constant_real2 (ffebld_conter (r)));
4335 expr = ffebld_new_conter_with_orig
4336 (ffebld_constant_new_logicaldefault (val), expr);
4337 break;
4338 #endif
4339
4340 #if FFETARGET_okREAL3
4341 case FFEINFO_kindtypeREAL3:
4342 error = ffetarget_ne_real3 (&val,
4343 ffebld_constant_real3 (ffebld_conter (l)),
4344 ffebld_constant_real3 (ffebld_conter (r)));
4345 expr = ffebld_new_conter_with_orig
4346 (ffebld_constant_new_logicaldefault (val), expr);
4347 break;
4348 #endif
4349
4350 default:
4351 assert ("bad real kind type" == NULL);
4352 break;
4353 }
4354 break;
4355
4356 case FFEINFO_basictypeCOMPLEX:
4357 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4358 {
4359 #if FFETARGET_okCOMPLEX1
4360 case FFEINFO_kindtypeREAL1:
4361 error = ffetarget_ne_complex1 (&val,
4362 ffebld_constant_complex1 (ffebld_conter (l)),
4363 ffebld_constant_complex1 (ffebld_conter (r)));
4364 expr = ffebld_new_conter_with_orig
4365 (ffebld_constant_new_logicaldefault (val), expr);
4366 break;
4367 #endif
4368
4369 #if FFETARGET_okCOMPLEX2
4370 case FFEINFO_kindtypeREAL2:
4371 error = ffetarget_ne_complex2 (&val,
4372 ffebld_constant_complex2 (ffebld_conter (l)),
4373 ffebld_constant_complex2 (ffebld_conter (r)));
4374 expr = ffebld_new_conter_with_orig
4375 (ffebld_constant_new_logicaldefault (val), expr);
4376 break;
4377 #endif
4378
4379 #if FFETARGET_okCOMPLEX3
4380 case FFEINFO_kindtypeREAL3:
4381 error = ffetarget_ne_complex3 (&val,
4382 ffebld_constant_complex3 (ffebld_conter (l)),
4383 ffebld_constant_complex3 (ffebld_conter (r)));
4384 expr = ffebld_new_conter_with_orig
4385 (ffebld_constant_new_logicaldefault (val), expr);
4386 break;
4387 #endif
4388
4389 default:
4390 assert ("bad complex kind type" == NULL);
4391 break;
4392 }
4393 break;
4394
4395 case FFEINFO_basictypeCHARACTER:
4396 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4397 {
4398 #if FFETARGET_okCHARACTER1
4399 case FFEINFO_kindtypeCHARACTER1:
4400 error = ffetarget_ne_character1 (&val,
4401 ffebld_constant_character1 (ffebld_conter (l)),
4402 ffebld_constant_character1 (ffebld_conter (r)));
4403 expr = ffebld_new_conter_with_orig
4404 (ffebld_constant_new_logicaldefault (val), expr);
4405 break;
4406 #endif
4407
4408 default:
4409 assert ("bad character kind type" == NULL);
4410 break;
4411 }
4412 break;
4413
4414 default:
4415 assert ("bad type" == NULL);
4416 return expr;
4417 }
4418
4419 ffebld_set_info (expr, ffeinfo_new
4420 (FFEINFO_basictypeLOGICAL,
4421 FFEINFO_kindtypeLOGICALDEFAULT,
4422 0,
4423 FFEINFO_kindENTITY,
4424 FFEINFO_whereCONSTANT,
4425 FFETARGET_charactersizeNONE));
4426
4427 if ((error != FFEBAD)
4428 && ffebad_start (error))
4429 {
4430 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4431 ffebad_finish ();
4432 }
4433
4434 return expr;
4435 }
4436
4437 /* ffeexpr_collapse_ge -- Collapse ge expr
4438
4439 ffebld expr;
4440 ffelexToken token;
4441 expr = ffeexpr_collapse_ge(expr,token);
4442
4443 If the result of the expr is a constant, replaces the expr with the
4444 computed constant. */
4445
4446 ffebld
4447 ffeexpr_collapse_ge (ffebld expr, ffelexToken t)
4448 {
4449 ffebad error = FFEBAD;
4450 ffebld l;
4451 ffebld r;
4452 bool val;
4453
4454 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4455 return expr;
4456
4457 l = ffebld_left (expr);
4458 r = ffebld_right (expr);
4459
4460 if (ffebld_op (l) != FFEBLD_opCONTER)
4461 return expr;
4462 if (ffebld_op (r) != FFEBLD_opCONTER)
4463 return expr;
4464
4465 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4466 {
4467 case FFEINFO_basictypeANY:
4468 return expr;
4469
4470 case FFEINFO_basictypeINTEGER:
4471 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4472 {
4473 #if FFETARGET_okINTEGER1
4474 case FFEINFO_kindtypeINTEGER1:
4475 error = ffetarget_ge_integer1 (&val,
4476 ffebld_constant_integer1 (ffebld_conter (l)),
4477 ffebld_constant_integer1 (ffebld_conter (r)));
4478 expr = ffebld_new_conter_with_orig
4479 (ffebld_constant_new_logicaldefault (val), expr);
4480 break;
4481 #endif
4482
4483 #if FFETARGET_okINTEGER2
4484 case FFEINFO_kindtypeINTEGER2:
4485 error = ffetarget_ge_integer2 (&val,
4486 ffebld_constant_integer2 (ffebld_conter (l)),
4487 ffebld_constant_integer2 (ffebld_conter (r)));
4488 expr = ffebld_new_conter_with_orig
4489 (ffebld_constant_new_logicaldefault (val), expr);
4490 break;
4491 #endif
4492
4493 #if FFETARGET_okINTEGER3
4494 case FFEINFO_kindtypeINTEGER3:
4495 error = ffetarget_ge_integer3 (&val,
4496 ffebld_constant_integer3 (ffebld_conter (l)),
4497 ffebld_constant_integer3 (ffebld_conter (r)));
4498 expr = ffebld_new_conter_with_orig
4499 (ffebld_constant_new_logicaldefault (val), expr);
4500 break;
4501 #endif
4502
4503 #if FFETARGET_okINTEGER4
4504 case FFEINFO_kindtypeINTEGER4:
4505 error = ffetarget_ge_integer4 (&val,
4506 ffebld_constant_integer4 (ffebld_conter (l)),
4507 ffebld_constant_integer4 (ffebld_conter (r)));
4508 expr = ffebld_new_conter_with_orig
4509 (ffebld_constant_new_logicaldefault (val), expr);
4510 break;
4511 #endif
4512
4513 default:
4514 assert ("bad integer kind type" == NULL);
4515 break;
4516 }
4517 break;
4518
4519 case FFEINFO_basictypeREAL:
4520 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4521 {
4522 #if FFETARGET_okREAL1
4523 case FFEINFO_kindtypeREAL1:
4524 error = ffetarget_ge_real1 (&val,
4525 ffebld_constant_real1 (ffebld_conter (l)),
4526 ffebld_constant_real1 (ffebld_conter (r)));
4527 expr = ffebld_new_conter_with_orig
4528 (ffebld_constant_new_logicaldefault (val), expr);
4529 break;
4530 #endif
4531
4532 #if FFETARGET_okREAL2
4533 case FFEINFO_kindtypeREAL2:
4534 error = ffetarget_ge_real2 (&val,
4535 ffebld_constant_real2 (ffebld_conter (l)),
4536 ffebld_constant_real2 (ffebld_conter (r)));
4537 expr = ffebld_new_conter_with_orig
4538 (ffebld_constant_new_logicaldefault (val), expr);
4539 break;
4540 #endif
4541
4542 #if FFETARGET_okREAL3
4543 case FFEINFO_kindtypeREAL3:
4544 error = ffetarget_ge_real3 (&val,
4545 ffebld_constant_real3 (ffebld_conter (l)),
4546 ffebld_constant_real3 (ffebld_conter (r)));
4547 expr = ffebld_new_conter_with_orig
4548 (ffebld_constant_new_logicaldefault (val), expr);
4549 break;
4550 #endif
4551
4552 default:
4553 assert ("bad real kind type" == NULL);
4554 break;
4555 }
4556 break;
4557
4558 case FFEINFO_basictypeCHARACTER:
4559 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4560 {
4561 #if FFETARGET_okCHARACTER1
4562 case FFEINFO_kindtypeCHARACTER1:
4563 error = ffetarget_ge_character1 (&val,
4564 ffebld_constant_character1 (ffebld_conter (l)),
4565 ffebld_constant_character1 (ffebld_conter (r)));
4566 expr = ffebld_new_conter_with_orig
4567 (ffebld_constant_new_logicaldefault (val), expr);
4568 break;
4569 #endif
4570
4571 default:
4572 assert ("bad character kind type" == NULL);
4573 break;
4574 }
4575 break;
4576
4577 default:
4578 assert ("bad type" == NULL);
4579 return expr;
4580 }
4581
4582 ffebld_set_info (expr, ffeinfo_new
4583 (FFEINFO_basictypeLOGICAL,
4584 FFEINFO_kindtypeLOGICALDEFAULT,
4585 0,
4586 FFEINFO_kindENTITY,
4587 FFEINFO_whereCONSTANT,
4588 FFETARGET_charactersizeNONE));
4589
4590 if ((error != FFEBAD)
4591 && ffebad_start (error))
4592 {
4593 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4594 ffebad_finish ();
4595 }
4596
4597 return expr;
4598 }
4599
4600 /* ffeexpr_collapse_gt -- Collapse gt expr
4601
4602 ffebld expr;
4603 ffelexToken token;
4604 expr = ffeexpr_collapse_gt(expr,token);
4605
4606 If the result of the expr is a constant, replaces the expr with the
4607 computed constant. */
4608
4609 ffebld
4610 ffeexpr_collapse_gt (ffebld expr, ffelexToken t)
4611 {
4612 ffebad error = FFEBAD;
4613 ffebld l;
4614 ffebld r;
4615 bool val;
4616
4617 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4618 return expr;
4619
4620 l = ffebld_left (expr);
4621 r = ffebld_right (expr);
4622
4623 if (ffebld_op (l) != FFEBLD_opCONTER)
4624 return expr;
4625 if (ffebld_op (r) != FFEBLD_opCONTER)
4626 return expr;
4627
4628 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4629 {
4630 case FFEINFO_basictypeANY:
4631 return expr;
4632
4633 case FFEINFO_basictypeINTEGER:
4634 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4635 {
4636 #if FFETARGET_okINTEGER1
4637 case FFEINFO_kindtypeINTEGER1:
4638 error = ffetarget_gt_integer1 (&val,
4639 ffebld_constant_integer1 (ffebld_conter (l)),
4640 ffebld_constant_integer1 (ffebld_conter (r)));
4641 expr = ffebld_new_conter_with_orig
4642 (ffebld_constant_new_logicaldefault (val), expr);
4643 break;
4644 #endif
4645
4646 #if FFETARGET_okINTEGER2
4647 case FFEINFO_kindtypeINTEGER2:
4648 error = ffetarget_gt_integer2 (&val,
4649 ffebld_constant_integer2 (ffebld_conter (l)),
4650 ffebld_constant_integer2 (ffebld_conter (r)));
4651 expr = ffebld_new_conter_with_orig
4652 (ffebld_constant_new_logicaldefault (val), expr);
4653 break;
4654 #endif
4655
4656 #if FFETARGET_okINTEGER3
4657 case FFEINFO_kindtypeINTEGER3:
4658 error = ffetarget_gt_integer3 (&val,
4659 ffebld_constant_integer3 (ffebld_conter (l)),
4660 ffebld_constant_integer3 (ffebld_conter (r)));
4661 expr = ffebld_new_conter_with_orig
4662 (ffebld_constant_new_logicaldefault (val), expr);
4663 break;
4664 #endif
4665
4666 #if FFETARGET_okINTEGER4
4667 case FFEINFO_kindtypeINTEGER4:
4668 error = ffetarget_gt_integer4 (&val,
4669 ffebld_constant_integer4 (ffebld_conter (l)),
4670 ffebld_constant_integer4 (ffebld_conter (r)));
4671 expr = ffebld_new_conter_with_orig
4672 (ffebld_constant_new_logicaldefault (val), expr);
4673 break;
4674 #endif
4675
4676 default:
4677 assert ("bad integer kind type" == NULL);
4678 break;
4679 }
4680 break;
4681
4682 case FFEINFO_basictypeREAL:
4683 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4684 {
4685 #if FFETARGET_okREAL1
4686 case FFEINFO_kindtypeREAL1:
4687 error = ffetarget_gt_real1 (&val,
4688 ffebld_constant_real1 (ffebld_conter (l)),
4689 ffebld_constant_real1 (ffebld_conter (r)));
4690 expr = ffebld_new_conter_with_orig
4691 (ffebld_constant_new_logicaldefault (val), expr);
4692 break;
4693 #endif
4694
4695 #if FFETARGET_okREAL2
4696 case FFEINFO_kindtypeREAL2:
4697 error = ffetarget_gt_real2 (&val,
4698 ffebld_constant_real2 (ffebld_conter (l)),
4699 ffebld_constant_real2 (ffebld_conter (r)));
4700 expr = ffebld_new_conter_with_orig
4701 (ffebld_constant_new_logicaldefault (val), expr);
4702 break;
4703 #endif
4704
4705 #if FFETARGET_okREAL3
4706 case FFEINFO_kindtypeREAL3:
4707 error = ffetarget_gt_real3 (&val,
4708 ffebld_constant_real3 (ffebld_conter (l)),
4709 ffebld_constant_real3 (ffebld_conter (r)));
4710 expr = ffebld_new_conter_with_orig
4711 (ffebld_constant_new_logicaldefault (val), expr);
4712 break;
4713 #endif
4714
4715 default:
4716 assert ("bad real kind type" == NULL);
4717 break;
4718 }
4719 break;
4720
4721 case FFEINFO_basictypeCHARACTER:
4722 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4723 {
4724 #if FFETARGET_okCHARACTER1
4725 case FFEINFO_kindtypeCHARACTER1:
4726 error = ffetarget_gt_character1 (&val,
4727 ffebld_constant_character1 (ffebld_conter (l)),
4728 ffebld_constant_character1 (ffebld_conter (r)));
4729 expr = ffebld_new_conter_with_orig
4730 (ffebld_constant_new_logicaldefault (val), expr);
4731 break;
4732 #endif
4733
4734 default:
4735 assert ("bad character kind type" == NULL);
4736 break;
4737 }
4738 break;
4739
4740 default:
4741 assert ("bad type" == NULL);
4742 return expr;
4743 }
4744
4745 ffebld_set_info (expr, ffeinfo_new
4746 (FFEINFO_basictypeLOGICAL,
4747 FFEINFO_kindtypeLOGICALDEFAULT,
4748 0,
4749 FFEINFO_kindENTITY,
4750 FFEINFO_whereCONSTANT,
4751 FFETARGET_charactersizeNONE));
4752
4753 if ((error != FFEBAD)
4754 && ffebad_start (error))
4755 {
4756 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4757 ffebad_finish ();
4758 }
4759
4760 return expr;
4761 }
4762
4763 /* ffeexpr_collapse_le -- Collapse le expr
4764
4765 ffebld expr;
4766 ffelexToken token;
4767 expr = ffeexpr_collapse_le(expr,token);
4768
4769 If the result of the expr is a constant, replaces the expr with the
4770 computed constant. */
4771
4772 ffebld
4773 ffeexpr_collapse_le (ffebld expr, ffelexToken t)
4774 {
4775 ffebad error = FFEBAD;
4776 ffebld l;
4777 ffebld r;
4778 bool val;
4779
4780 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4781 return expr;
4782
4783 l = ffebld_left (expr);
4784 r = ffebld_right (expr);
4785
4786 if (ffebld_op (l) != FFEBLD_opCONTER)
4787 return expr;
4788 if (ffebld_op (r) != FFEBLD_opCONTER)
4789 return expr;
4790
4791 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4792 {
4793 case FFEINFO_basictypeANY:
4794 return expr;
4795
4796 case FFEINFO_basictypeINTEGER:
4797 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4798 {
4799 #if FFETARGET_okINTEGER1
4800 case FFEINFO_kindtypeINTEGER1:
4801 error = ffetarget_le_integer1 (&val,
4802 ffebld_constant_integer1 (ffebld_conter (l)),
4803 ffebld_constant_integer1 (ffebld_conter (r)));
4804 expr = ffebld_new_conter_with_orig
4805 (ffebld_constant_new_logicaldefault (val), expr);
4806 break;
4807 #endif
4808
4809 #if FFETARGET_okINTEGER2
4810 case FFEINFO_kindtypeINTEGER2:
4811 error = ffetarget_le_integer2 (&val,
4812 ffebld_constant_integer2 (ffebld_conter (l)),
4813 ffebld_constant_integer2 (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_okINTEGER3
4820 case FFEINFO_kindtypeINTEGER3:
4821 error = ffetarget_le_integer3 (&val,
4822 ffebld_constant_integer3 (ffebld_conter (l)),
4823 ffebld_constant_integer3 (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_okINTEGER4
4830 case FFEINFO_kindtypeINTEGER4:
4831 error = ffetarget_le_integer4 (&val,
4832 ffebld_constant_integer4 (ffebld_conter (l)),
4833 ffebld_constant_integer4 (ffebld_conter (r)));
4834 expr = ffebld_new_conter_with_orig
4835 (ffebld_constant_new_logicaldefault (val), expr);
4836 break;
4837 #endif
4838
4839 default:
4840 assert ("bad integer kind type" == NULL);
4841 break;
4842 }
4843 break;
4844
4845 case FFEINFO_basictypeREAL:
4846 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4847 {
4848 #if FFETARGET_okREAL1
4849 case FFEINFO_kindtypeREAL1:
4850 error = ffetarget_le_real1 (&val,
4851 ffebld_constant_real1 (ffebld_conter (l)),
4852 ffebld_constant_real1 (ffebld_conter (r)));
4853 expr = ffebld_new_conter_with_orig
4854 (ffebld_constant_new_logicaldefault (val), expr);
4855 break;
4856 #endif
4857
4858 #if FFETARGET_okREAL2
4859 case FFEINFO_kindtypeREAL2:
4860 error = ffetarget_le_real2 (&val,
4861 ffebld_constant_real2 (ffebld_conter (l)),
4862 ffebld_constant_real2 (ffebld_conter (r)));
4863 expr = ffebld_new_conter_with_orig
4864 (ffebld_constant_new_logicaldefault (val), expr);
4865 break;
4866 #endif
4867
4868 #if FFETARGET_okREAL3
4869 case FFEINFO_kindtypeREAL3:
4870 error = ffetarget_le_real3 (&val,
4871 ffebld_constant_real3 (ffebld_conter (l)),
4872 ffebld_constant_real3 (ffebld_conter (r)));
4873 expr = ffebld_new_conter_with_orig
4874 (ffebld_constant_new_logicaldefault (val), expr);
4875 break;
4876 #endif
4877
4878 default:
4879 assert ("bad real kind type" == NULL);
4880 break;
4881 }
4882 break;
4883
4884 case FFEINFO_basictypeCHARACTER:
4885 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4886 {
4887 #if FFETARGET_okCHARACTER1
4888 case FFEINFO_kindtypeCHARACTER1:
4889 error = ffetarget_le_character1 (&val,
4890 ffebld_constant_character1 (ffebld_conter (l)),
4891 ffebld_constant_character1 (ffebld_conter (r)));
4892 expr = ffebld_new_conter_with_orig
4893 (ffebld_constant_new_logicaldefault (val), expr);
4894 break;
4895 #endif
4896
4897 default:
4898 assert ("bad character kind type" == NULL);
4899 break;
4900 }
4901 break;
4902
4903 default:
4904 assert ("bad type" == NULL);
4905 return expr;
4906 }
4907
4908 ffebld_set_info (expr, ffeinfo_new
4909 (FFEINFO_basictypeLOGICAL,
4910 FFEINFO_kindtypeLOGICALDEFAULT,
4911 0,
4912 FFEINFO_kindENTITY,
4913 FFEINFO_whereCONSTANT,
4914 FFETARGET_charactersizeNONE));
4915
4916 if ((error != FFEBAD)
4917 && ffebad_start (error))
4918 {
4919 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4920 ffebad_finish ();
4921 }
4922
4923 return expr;
4924 }
4925
4926 /* ffeexpr_collapse_lt -- Collapse lt expr
4927
4928 ffebld expr;
4929 ffelexToken token;
4930 expr = ffeexpr_collapse_lt(expr,token);
4931
4932 If the result of the expr is a constant, replaces the expr with the
4933 computed constant. */
4934
4935 ffebld
4936 ffeexpr_collapse_lt (ffebld expr, ffelexToken t)
4937 {
4938 ffebad error = FFEBAD;
4939 ffebld l;
4940 ffebld r;
4941 bool val;
4942
4943 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4944 return expr;
4945
4946 l = ffebld_left (expr);
4947 r = ffebld_right (expr);
4948
4949 if (ffebld_op (l) != FFEBLD_opCONTER)
4950 return expr;
4951 if (ffebld_op (r) != FFEBLD_opCONTER)
4952 return expr;
4953
4954 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4955 {
4956 case FFEINFO_basictypeANY:
4957 return expr;
4958
4959 case FFEINFO_basictypeINTEGER:
4960 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4961 {
4962 #if FFETARGET_okINTEGER1
4963 case FFEINFO_kindtypeINTEGER1:
4964 error = ffetarget_lt_integer1 (&val,
4965 ffebld_constant_integer1 (ffebld_conter (l)),
4966 ffebld_constant_integer1 (ffebld_conter (r)));
4967 expr = ffebld_new_conter_with_orig
4968 (ffebld_constant_new_logicaldefault (val), expr);
4969 break;
4970 #endif
4971
4972 #if FFETARGET_okINTEGER2
4973 case FFEINFO_kindtypeINTEGER2:
4974 error = ffetarget_lt_integer2 (&val,
4975 ffebld_constant_integer2 (ffebld_conter (l)),
4976 ffebld_constant_integer2 (ffebld_conter (r)));
4977 expr = ffebld_new_conter_with_orig
4978 (ffebld_constant_new_logicaldefault (val), expr);
4979 break;
4980 #endif
4981
4982 #if FFETARGET_okINTEGER3
4983 case FFEINFO_kindtypeINTEGER3:
4984 error = ffetarget_lt_integer3 (&val,
4985 ffebld_constant_integer3 (ffebld_conter (l)),
4986 ffebld_constant_integer3 (ffebld_conter (r)));
4987 expr = ffebld_new_conter_with_orig
4988 (ffebld_constant_new_logicaldefault (val), expr);
4989 break;
4990 #endif
4991
4992 #if FFETARGET_okINTEGER4
4993 case FFEINFO_kindtypeINTEGER4:
4994 error = ffetarget_lt_integer4 (&val,
4995 ffebld_constant_integer4 (ffebld_conter (l)),
4996 ffebld_constant_integer4 (ffebld_conter (r)));
4997 expr = ffebld_new_conter_with_orig
4998 (ffebld_constant_new_logicaldefault (val), expr);
4999 break;
5000 #endif
5001
5002 default:
5003 assert ("bad integer kind type" == NULL);
5004 break;
5005 }
5006 break;
5007
5008 case FFEINFO_basictypeREAL:
5009 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5010 {
5011 #if FFETARGET_okREAL1
5012 case FFEINFO_kindtypeREAL1:
5013 error = ffetarget_lt_real1 (&val,
5014 ffebld_constant_real1 (ffebld_conter (l)),
5015 ffebld_constant_real1 (ffebld_conter (r)));
5016 expr = ffebld_new_conter_with_orig
5017 (ffebld_constant_new_logicaldefault (val), expr);
5018 break;
5019 #endif
5020
5021 #if FFETARGET_okREAL2
5022 case FFEINFO_kindtypeREAL2:
5023 error = ffetarget_lt_real2 (&val,
5024 ffebld_constant_real2 (ffebld_conter (l)),
5025 ffebld_constant_real2 (ffebld_conter (r)));
5026 expr = ffebld_new_conter_with_orig
5027 (ffebld_constant_new_logicaldefault (val), expr);
5028 break;
5029 #endif
5030
5031 #if FFETARGET_okREAL3
5032 case FFEINFO_kindtypeREAL3:
5033 error = ffetarget_lt_real3 (&val,
5034 ffebld_constant_real3 (ffebld_conter (l)),
5035 ffebld_constant_real3 (ffebld_conter (r)));
5036 expr = ffebld_new_conter_with_orig
5037 (ffebld_constant_new_logicaldefault (val), expr);
5038 break;
5039 #endif
5040
5041 default:
5042 assert ("bad real kind type" == NULL);
5043 break;
5044 }
5045 break;
5046
5047 case FFEINFO_basictypeCHARACTER:
5048 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5049 {
5050 #if FFETARGET_okCHARACTER1
5051 case FFEINFO_kindtypeCHARACTER1:
5052 error = ffetarget_lt_character1 (&val,
5053 ffebld_constant_character1 (ffebld_conter (l)),
5054 ffebld_constant_character1 (ffebld_conter (r)));
5055 expr = ffebld_new_conter_with_orig
5056 (ffebld_constant_new_logicaldefault (val), expr);
5057 break;
5058 #endif
5059
5060 default:
5061 assert ("bad character kind type" == NULL);
5062 break;
5063 }
5064 break;
5065
5066 default:
5067 assert ("bad type" == NULL);
5068 return expr;
5069 }
5070
5071 ffebld_set_info (expr, ffeinfo_new
5072 (FFEINFO_basictypeLOGICAL,
5073 FFEINFO_kindtypeLOGICALDEFAULT,
5074 0,
5075 FFEINFO_kindENTITY,
5076 FFEINFO_whereCONSTANT,
5077 FFETARGET_charactersizeNONE));
5078
5079 if ((error != FFEBAD)
5080 && ffebad_start (error))
5081 {
5082 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5083 ffebad_finish ();
5084 }
5085
5086 return expr;
5087 }
5088
5089 /* ffeexpr_collapse_and -- Collapse and expr
5090
5091 ffebld expr;
5092 ffelexToken token;
5093 expr = ffeexpr_collapse_and(expr,token);
5094
5095 If the result of the expr is a constant, replaces the expr with the
5096 computed constant. */
5097
5098 ffebld
5099 ffeexpr_collapse_and (ffebld expr, ffelexToken t)
5100 {
5101 ffebad error = FFEBAD;
5102 ffebld l;
5103 ffebld r;
5104 ffebldConstantUnion u;
5105 ffeinfoBasictype bt;
5106 ffeinfoKindtype kt;
5107
5108 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5109 return expr;
5110
5111 l = ffebld_left (expr);
5112 r = ffebld_right (expr);
5113
5114 if (ffebld_op (l) != FFEBLD_opCONTER)
5115 return expr;
5116 if (ffebld_op (r) != FFEBLD_opCONTER)
5117 return expr;
5118
5119 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5120 {
5121 case FFEINFO_basictypeANY:
5122 return expr;
5123
5124 case FFEINFO_basictypeINTEGER:
5125 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5126 {
5127 #if FFETARGET_okINTEGER1
5128 case FFEINFO_kindtypeINTEGER1:
5129 error = ffetarget_and_integer1 (ffebld_cu_ptr_integer1 (u),
5130 ffebld_constant_integer1 (ffebld_conter (l)),
5131 ffebld_constant_integer1 (ffebld_conter (r)));
5132 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5133 (ffebld_cu_val_integer1 (u)), expr);
5134 break;
5135 #endif
5136
5137 #if FFETARGET_okINTEGER2
5138 case FFEINFO_kindtypeINTEGER2:
5139 error = ffetarget_and_integer2 (ffebld_cu_ptr_integer2 (u),
5140 ffebld_constant_integer2 (ffebld_conter (l)),
5141 ffebld_constant_integer2 (ffebld_conter (r)));
5142 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5143 (ffebld_cu_val_integer2 (u)), expr);
5144 break;
5145 #endif
5146
5147 #if FFETARGET_okINTEGER3
5148 case FFEINFO_kindtypeINTEGER3:
5149 error = ffetarget_and_integer3 (ffebld_cu_ptr_integer3 (u),
5150 ffebld_constant_integer3 (ffebld_conter (l)),
5151 ffebld_constant_integer3 (ffebld_conter (r)));
5152 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5153 (ffebld_cu_val_integer3 (u)), expr);
5154 break;
5155 #endif
5156
5157 #if FFETARGET_okINTEGER4
5158 case FFEINFO_kindtypeINTEGER4:
5159 error = ffetarget_and_integer4 (ffebld_cu_ptr_integer4 (u),
5160 ffebld_constant_integer4 (ffebld_conter (l)),
5161 ffebld_constant_integer4 (ffebld_conter (r)));
5162 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5163 (ffebld_cu_val_integer4 (u)), expr);
5164 break;
5165 #endif
5166
5167 default:
5168 assert ("bad integer kind type" == NULL);
5169 break;
5170 }
5171 break;
5172
5173 case FFEINFO_basictypeLOGICAL:
5174 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5175 {
5176 #if FFETARGET_okLOGICAL1
5177 case FFEINFO_kindtypeLOGICAL1:
5178 error = ffetarget_and_logical1 (ffebld_cu_ptr_logical1 (u),
5179 ffebld_constant_logical1 (ffebld_conter (l)),
5180 ffebld_constant_logical1 (ffebld_conter (r)));
5181 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5182 (ffebld_cu_val_logical1 (u)), expr);
5183 break;
5184 #endif
5185
5186 #if FFETARGET_okLOGICAL2
5187 case FFEINFO_kindtypeLOGICAL2:
5188 error = ffetarget_and_logical2 (ffebld_cu_ptr_logical2 (u),
5189 ffebld_constant_logical2 (ffebld_conter (l)),
5190 ffebld_constant_logical2 (ffebld_conter (r)));
5191 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5192 (ffebld_cu_val_logical2 (u)), expr);
5193 break;
5194 #endif
5195
5196 #if FFETARGET_okLOGICAL3
5197 case FFEINFO_kindtypeLOGICAL3:
5198 error = ffetarget_and_logical3 (ffebld_cu_ptr_logical3 (u),
5199 ffebld_constant_logical3 (ffebld_conter (l)),
5200 ffebld_constant_logical3 (ffebld_conter (r)));
5201 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5202 (ffebld_cu_val_logical3 (u)), expr);
5203 break;
5204 #endif
5205
5206 #if FFETARGET_okLOGICAL4
5207 case FFEINFO_kindtypeLOGICAL4:
5208 error = ffetarget_and_logical4 (ffebld_cu_ptr_logical4 (u),
5209 ffebld_constant_logical4 (ffebld_conter (l)),
5210 ffebld_constant_logical4 (ffebld_conter (r)));
5211 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5212 (ffebld_cu_val_logical4 (u)), expr);
5213 break;
5214 #endif
5215
5216 default:
5217 assert ("bad logical kind type" == NULL);
5218 break;
5219 }
5220 break;
5221
5222 default:
5223 assert ("bad type" == NULL);
5224 return expr;
5225 }
5226
5227 ffebld_set_info (expr, ffeinfo_new
5228 (bt,
5229 kt,
5230 0,
5231 FFEINFO_kindENTITY,
5232 FFEINFO_whereCONSTANT,
5233 FFETARGET_charactersizeNONE));
5234
5235 if ((error != FFEBAD)
5236 && ffebad_start (error))
5237 {
5238 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5239 ffebad_finish ();
5240 }
5241
5242 return expr;
5243 }
5244
5245 /* ffeexpr_collapse_or -- Collapse or expr
5246
5247 ffebld expr;
5248 ffelexToken token;
5249 expr = ffeexpr_collapse_or(expr,token);
5250
5251 If the result of the expr is a constant, replaces the expr with the
5252 computed constant. */
5253
5254 ffebld
5255 ffeexpr_collapse_or (ffebld expr, ffelexToken t)
5256 {
5257 ffebad error = FFEBAD;
5258 ffebld l;
5259 ffebld r;
5260 ffebldConstantUnion u;
5261 ffeinfoBasictype bt;
5262 ffeinfoKindtype kt;
5263
5264 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5265 return expr;
5266
5267 l = ffebld_left (expr);
5268 r = ffebld_right (expr);
5269
5270 if (ffebld_op (l) != FFEBLD_opCONTER)
5271 return expr;
5272 if (ffebld_op (r) != FFEBLD_opCONTER)
5273 return expr;
5274
5275 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5276 {
5277 case FFEINFO_basictypeANY:
5278 return expr;
5279
5280 case FFEINFO_basictypeINTEGER:
5281 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5282 {
5283 #if FFETARGET_okINTEGER1
5284 case FFEINFO_kindtypeINTEGER1:
5285 error = ffetarget_or_integer1 (ffebld_cu_ptr_integer1 (u),
5286 ffebld_constant_integer1 (ffebld_conter (l)),
5287 ffebld_constant_integer1 (ffebld_conter (r)));
5288 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5289 (ffebld_cu_val_integer1 (u)), expr);
5290 break;
5291 #endif
5292
5293 #if FFETARGET_okINTEGER2
5294 case FFEINFO_kindtypeINTEGER2:
5295 error = ffetarget_or_integer2 (ffebld_cu_ptr_integer2 (u),
5296 ffebld_constant_integer2 (ffebld_conter (l)),
5297 ffebld_constant_integer2 (ffebld_conter (r)));
5298 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5299 (ffebld_cu_val_integer2 (u)), expr);
5300 break;
5301 #endif
5302
5303 #if FFETARGET_okINTEGER3
5304 case FFEINFO_kindtypeINTEGER3:
5305 error = ffetarget_or_integer3 (ffebld_cu_ptr_integer3 (u),
5306 ffebld_constant_integer3 (ffebld_conter (l)),
5307 ffebld_constant_integer3 (ffebld_conter (r)));
5308 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5309 (ffebld_cu_val_integer3 (u)), expr);
5310 break;
5311 #endif
5312
5313 #if FFETARGET_okINTEGER4
5314 case FFEINFO_kindtypeINTEGER4:
5315 error = ffetarget_or_integer4 (ffebld_cu_ptr_integer4 (u),
5316 ffebld_constant_integer4 (ffebld_conter (l)),
5317 ffebld_constant_integer4 (ffebld_conter (r)));
5318 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5319 (ffebld_cu_val_integer4 (u)), expr);
5320 break;
5321 #endif
5322
5323 default:
5324 assert ("bad integer kind type" == NULL);
5325 break;
5326 }
5327 break;
5328
5329 case FFEINFO_basictypeLOGICAL:
5330 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5331 {
5332 #if FFETARGET_okLOGICAL1
5333 case FFEINFO_kindtypeLOGICAL1:
5334 error = ffetarget_or_logical1 (ffebld_cu_ptr_logical1 (u),
5335 ffebld_constant_logical1 (ffebld_conter (l)),
5336 ffebld_constant_logical1 (ffebld_conter (r)));
5337 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5338 (ffebld_cu_val_logical1 (u)), expr);
5339 break;
5340 #endif
5341
5342 #if FFETARGET_okLOGICAL2
5343 case FFEINFO_kindtypeLOGICAL2:
5344 error = ffetarget_or_logical2 (ffebld_cu_ptr_logical2 (u),
5345 ffebld_constant_logical2 (ffebld_conter (l)),
5346 ffebld_constant_logical2 (ffebld_conter (r)));
5347 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5348 (ffebld_cu_val_logical2 (u)), expr);
5349 break;
5350 #endif
5351
5352 #if FFETARGET_okLOGICAL3
5353 case FFEINFO_kindtypeLOGICAL3:
5354 error = ffetarget_or_logical3 (ffebld_cu_ptr_logical3 (u),
5355 ffebld_constant_logical3 (ffebld_conter (l)),
5356 ffebld_constant_logical3 (ffebld_conter (r)));
5357 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5358 (ffebld_cu_val_logical3 (u)), expr);
5359 break;
5360 #endif
5361
5362 #if FFETARGET_okLOGICAL4
5363 case FFEINFO_kindtypeLOGICAL4:
5364 error = ffetarget_or_logical4 (ffebld_cu_ptr_logical4 (u),
5365 ffebld_constant_logical4 (ffebld_conter (l)),
5366 ffebld_constant_logical4 (ffebld_conter (r)));
5367 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5368 (ffebld_cu_val_logical4 (u)), expr);
5369 break;
5370 #endif
5371
5372 default:
5373 assert ("bad logical kind type" == NULL);
5374 break;
5375 }
5376 break;
5377
5378 default:
5379 assert ("bad type" == NULL);
5380 return expr;
5381 }
5382
5383 ffebld_set_info (expr, ffeinfo_new
5384 (bt,
5385 kt,
5386 0,
5387 FFEINFO_kindENTITY,
5388 FFEINFO_whereCONSTANT,
5389 FFETARGET_charactersizeNONE));
5390
5391 if ((error != FFEBAD)
5392 && ffebad_start (error))
5393 {
5394 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5395 ffebad_finish ();
5396 }
5397
5398 return expr;
5399 }
5400
5401 /* ffeexpr_collapse_xor -- Collapse xor expr
5402
5403 ffebld expr;
5404 ffelexToken token;
5405 expr = ffeexpr_collapse_xor(expr,token);
5406
5407 If the result of the expr is a constant, replaces the expr with the
5408 computed constant. */
5409
5410 ffebld
5411 ffeexpr_collapse_xor (ffebld expr, ffelexToken t)
5412 {
5413 ffebad error = FFEBAD;
5414 ffebld l;
5415 ffebld r;
5416 ffebldConstantUnion u;
5417 ffeinfoBasictype bt;
5418 ffeinfoKindtype kt;
5419
5420 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5421 return expr;
5422
5423 l = ffebld_left (expr);
5424 r = ffebld_right (expr);
5425
5426 if (ffebld_op (l) != FFEBLD_opCONTER)
5427 return expr;
5428 if (ffebld_op (r) != FFEBLD_opCONTER)
5429 return expr;
5430
5431 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5432 {
5433 case FFEINFO_basictypeANY:
5434 return expr;
5435
5436 case FFEINFO_basictypeINTEGER:
5437 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5438 {
5439 #if FFETARGET_okINTEGER1
5440 case FFEINFO_kindtypeINTEGER1:
5441 error = ffetarget_xor_integer1 (ffebld_cu_ptr_integer1 (u),
5442 ffebld_constant_integer1 (ffebld_conter (l)),
5443 ffebld_constant_integer1 (ffebld_conter (r)));
5444 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5445 (ffebld_cu_val_integer1 (u)), expr);
5446 break;
5447 #endif
5448
5449 #if FFETARGET_okINTEGER2
5450 case FFEINFO_kindtypeINTEGER2:
5451 error = ffetarget_xor_integer2 (ffebld_cu_ptr_integer2 (u),
5452 ffebld_constant_integer2 (ffebld_conter (l)),
5453 ffebld_constant_integer2 (ffebld_conter (r)));
5454 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5455 (ffebld_cu_val_integer2 (u)), expr);
5456 break;
5457 #endif
5458
5459 #if FFETARGET_okINTEGER3
5460 case FFEINFO_kindtypeINTEGER3:
5461 error = ffetarget_xor_integer3 (ffebld_cu_ptr_integer3 (u),
5462 ffebld_constant_integer3 (ffebld_conter (l)),
5463 ffebld_constant_integer3 (ffebld_conter (r)));
5464 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5465 (ffebld_cu_val_integer3 (u)), expr);
5466 break;
5467 #endif
5468
5469 #if FFETARGET_okINTEGER4
5470 case FFEINFO_kindtypeINTEGER4:
5471 error = ffetarget_xor_integer4 (ffebld_cu_ptr_integer4 (u),
5472 ffebld_constant_integer4 (ffebld_conter (l)),
5473 ffebld_constant_integer4 (ffebld_conter (r)));
5474 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5475 (ffebld_cu_val_integer4 (u)), expr);
5476 break;
5477 #endif
5478
5479 default:
5480 assert ("bad integer kind type" == NULL);
5481 break;
5482 }
5483 break;
5484
5485 case FFEINFO_basictypeLOGICAL:
5486 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5487 {
5488 #if FFETARGET_okLOGICAL1
5489 case FFEINFO_kindtypeLOGICAL1:
5490 error = ffetarget_xor_logical1 (ffebld_cu_ptr_logical1 (u),
5491 ffebld_constant_logical1 (ffebld_conter (l)),
5492 ffebld_constant_logical1 (ffebld_conter (r)));
5493 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5494 (ffebld_cu_val_logical1 (u)), expr);
5495 break;
5496 #endif
5497
5498 #if FFETARGET_okLOGICAL2
5499 case FFEINFO_kindtypeLOGICAL2:
5500 error = ffetarget_xor_logical2 (ffebld_cu_ptr_logical2 (u),
5501 ffebld_constant_logical2 (ffebld_conter (l)),
5502 ffebld_constant_logical2 (ffebld_conter (r)));
5503 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5504 (ffebld_cu_val_logical2 (u)), expr);
5505 break;
5506 #endif
5507
5508 #if FFETARGET_okLOGICAL3
5509 case FFEINFO_kindtypeLOGICAL3:
5510 error = ffetarget_xor_logical3 (ffebld_cu_ptr_logical3 (u),
5511 ffebld_constant_logical3 (ffebld_conter (l)),
5512 ffebld_constant_logical3 (ffebld_conter (r)));
5513 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5514 (ffebld_cu_val_logical3 (u)), expr);
5515 break;
5516 #endif
5517
5518 #if FFETARGET_okLOGICAL4
5519 case FFEINFO_kindtypeLOGICAL4:
5520 error = ffetarget_xor_logical4 (ffebld_cu_ptr_logical4 (u),
5521 ffebld_constant_logical4 (ffebld_conter (l)),
5522 ffebld_constant_logical4 (ffebld_conter (r)));
5523 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5524 (ffebld_cu_val_logical4 (u)), expr);
5525 break;
5526 #endif
5527
5528 default:
5529 assert ("bad logical kind type" == NULL);
5530 break;
5531 }
5532 break;
5533
5534 default:
5535 assert ("bad type" == NULL);
5536 return expr;
5537 }
5538
5539 ffebld_set_info (expr, ffeinfo_new
5540 (bt,
5541 kt,
5542 0,
5543 FFEINFO_kindENTITY,
5544 FFEINFO_whereCONSTANT,
5545 FFETARGET_charactersizeNONE));
5546
5547 if ((error != FFEBAD)
5548 && ffebad_start (error))
5549 {
5550 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5551 ffebad_finish ();
5552 }
5553
5554 return expr;
5555 }
5556
5557 /* ffeexpr_collapse_eqv -- Collapse eqv expr
5558
5559 ffebld expr;
5560 ffelexToken token;
5561 expr = ffeexpr_collapse_eqv(expr,token);
5562
5563 If the result of the expr is a constant, replaces the expr with the
5564 computed constant. */
5565
5566 ffebld
5567 ffeexpr_collapse_eqv (ffebld expr, ffelexToken t)
5568 {
5569 ffebad error = FFEBAD;
5570 ffebld l;
5571 ffebld r;
5572 ffebldConstantUnion u;
5573 ffeinfoBasictype bt;
5574 ffeinfoKindtype kt;
5575
5576 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5577 return expr;
5578
5579 l = ffebld_left (expr);
5580 r = ffebld_right (expr);
5581
5582 if (ffebld_op (l) != FFEBLD_opCONTER)
5583 return expr;
5584 if (ffebld_op (r) != FFEBLD_opCONTER)
5585 return expr;
5586
5587 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5588 {
5589 case FFEINFO_basictypeANY:
5590 return expr;
5591
5592 case FFEINFO_basictypeINTEGER:
5593 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5594 {
5595 #if FFETARGET_okINTEGER1
5596 case FFEINFO_kindtypeINTEGER1:
5597 error = ffetarget_eqv_integer1 (ffebld_cu_ptr_integer1 (u),
5598 ffebld_constant_integer1 (ffebld_conter (l)),
5599 ffebld_constant_integer1 (ffebld_conter (r)));
5600 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5601 (ffebld_cu_val_integer1 (u)), expr);
5602 break;
5603 #endif
5604
5605 #if FFETARGET_okINTEGER2
5606 case FFEINFO_kindtypeINTEGER2:
5607 error = ffetarget_eqv_integer2 (ffebld_cu_ptr_integer2 (u),
5608 ffebld_constant_integer2 (ffebld_conter (l)),
5609 ffebld_constant_integer2 (ffebld_conter (r)));
5610 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5611 (ffebld_cu_val_integer2 (u)), expr);
5612 break;
5613 #endif
5614
5615 #if FFETARGET_okINTEGER3
5616 case FFEINFO_kindtypeINTEGER3:
5617 error = ffetarget_eqv_integer3 (ffebld_cu_ptr_integer3 (u),
5618 ffebld_constant_integer3 (ffebld_conter (l)),
5619 ffebld_constant_integer3 (ffebld_conter (r)));
5620 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5621 (ffebld_cu_val_integer3 (u)), expr);
5622 break;
5623 #endif
5624
5625 #if FFETARGET_okINTEGER4
5626 case FFEINFO_kindtypeINTEGER4:
5627 error = ffetarget_eqv_integer4 (ffebld_cu_ptr_integer4 (u),
5628 ffebld_constant_integer4 (ffebld_conter (l)),
5629 ffebld_constant_integer4 (ffebld_conter (r)));
5630 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5631 (ffebld_cu_val_integer4 (u)), expr);
5632 break;
5633 #endif
5634
5635 default:
5636 assert ("bad integer kind type" == NULL);
5637 break;
5638 }
5639 break;
5640
5641 case FFEINFO_basictypeLOGICAL:
5642 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5643 {
5644 #if FFETARGET_okLOGICAL1
5645 case FFEINFO_kindtypeLOGICAL1:
5646 error = ffetarget_eqv_logical1 (ffebld_cu_ptr_logical1 (u),
5647 ffebld_constant_logical1 (ffebld_conter (l)),
5648 ffebld_constant_logical1 (ffebld_conter (r)));
5649 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5650 (ffebld_cu_val_logical1 (u)), expr);
5651 break;
5652 #endif
5653
5654 #if FFETARGET_okLOGICAL2
5655 case FFEINFO_kindtypeLOGICAL2:
5656 error = ffetarget_eqv_logical2 (ffebld_cu_ptr_logical2 (u),
5657 ffebld_constant_logical2 (ffebld_conter (l)),
5658 ffebld_constant_logical2 (ffebld_conter (r)));
5659 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5660 (ffebld_cu_val_logical2 (u)), expr);
5661 break;
5662 #endif
5663
5664 #if FFETARGET_okLOGICAL3
5665 case FFEINFO_kindtypeLOGICAL3:
5666 error = ffetarget_eqv_logical3 (ffebld_cu_ptr_logical3 (u),
5667 ffebld_constant_logical3 (ffebld_conter (l)),
5668 ffebld_constant_logical3 (ffebld_conter (r)));
5669 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5670 (ffebld_cu_val_logical3 (u)), expr);
5671 break;
5672 #endif
5673
5674 #if FFETARGET_okLOGICAL4
5675 case FFEINFO_kindtypeLOGICAL4:
5676 error = ffetarget_eqv_logical4 (ffebld_cu_ptr_logical4 (u),
5677 ffebld_constant_logical4 (ffebld_conter (l)),
5678 ffebld_constant_logical4 (ffebld_conter (r)));
5679 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5680 (ffebld_cu_val_logical4 (u)), expr);
5681 break;
5682 #endif
5683
5684 default:
5685 assert ("bad logical kind type" == NULL);
5686 break;
5687 }
5688 break;
5689
5690 default:
5691 assert ("bad type" == NULL);
5692 return expr;
5693 }
5694
5695 ffebld_set_info (expr, ffeinfo_new
5696 (bt,
5697 kt,
5698 0,
5699 FFEINFO_kindENTITY,
5700 FFEINFO_whereCONSTANT,
5701 FFETARGET_charactersizeNONE));
5702
5703 if ((error != FFEBAD)
5704 && ffebad_start (error))
5705 {
5706 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5707 ffebad_finish ();
5708 }
5709
5710 return expr;
5711 }
5712
5713 /* ffeexpr_collapse_neqv -- Collapse neqv expr
5714
5715 ffebld expr;
5716 ffelexToken token;
5717 expr = ffeexpr_collapse_neqv(expr,token);
5718
5719 If the result of the expr is a constant, replaces the expr with the
5720 computed constant. */
5721
5722 ffebld
5723 ffeexpr_collapse_neqv (ffebld expr, ffelexToken t)
5724 {
5725 ffebad error = FFEBAD;
5726 ffebld l;
5727 ffebld r;
5728 ffebldConstantUnion u;
5729 ffeinfoBasictype bt;
5730 ffeinfoKindtype kt;
5731
5732 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5733 return expr;
5734
5735 l = ffebld_left (expr);
5736 r = ffebld_right (expr);
5737
5738 if (ffebld_op (l) != FFEBLD_opCONTER)
5739 return expr;
5740 if (ffebld_op (r) != FFEBLD_opCONTER)
5741 return expr;
5742
5743 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5744 {
5745 case FFEINFO_basictypeANY:
5746 return expr;
5747
5748 case FFEINFO_basictypeINTEGER:
5749 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5750 {
5751 #if FFETARGET_okINTEGER1
5752 case FFEINFO_kindtypeINTEGER1:
5753 error = ffetarget_neqv_integer1 (ffebld_cu_ptr_integer1 (u),
5754 ffebld_constant_integer1 (ffebld_conter (l)),
5755 ffebld_constant_integer1 (ffebld_conter (r)));
5756 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5757 (ffebld_cu_val_integer1 (u)), expr);
5758 break;
5759 #endif
5760
5761 #if FFETARGET_okINTEGER2
5762 case FFEINFO_kindtypeINTEGER2:
5763 error = ffetarget_neqv_integer2 (ffebld_cu_ptr_integer2 (u),
5764 ffebld_constant_integer2 (ffebld_conter (l)),
5765 ffebld_constant_integer2 (ffebld_conter (r)));
5766 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5767 (ffebld_cu_val_integer2 (u)), expr);
5768 break;
5769 #endif
5770
5771 #if FFETARGET_okINTEGER3
5772 case FFEINFO_kindtypeINTEGER3:
5773 error = ffetarget_neqv_integer3 (ffebld_cu_ptr_integer3 (u),
5774 ffebld_constant_integer3 (ffebld_conter (l)),
5775 ffebld_constant_integer3 (ffebld_conter (r)));
5776 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5777 (ffebld_cu_val_integer3 (u)), expr);
5778 break;
5779 #endif
5780
5781 #if FFETARGET_okINTEGER4
5782 case FFEINFO_kindtypeINTEGER4:
5783 error = ffetarget_neqv_integer4 (ffebld_cu_ptr_integer4 (u),
5784 ffebld_constant_integer4 (ffebld_conter (l)),
5785 ffebld_constant_integer4 (ffebld_conter (r)));
5786 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5787 (ffebld_cu_val_integer4 (u)), expr);
5788 break;
5789 #endif
5790
5791 default:
5792 assert ("bad integer kind type" == NULL);
5793 break;
5794 }
5795 break;
5796
5797 case FFEINFO_basictypeLOGICAL:
5798 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5799 {
5800 #if FFETARGET_okLOGICAL1
5801 case FFEINFO_kindtypeLOGICAL1:
5802 error = ffetarget_neqv_logical1 (ffebld_cu_ptr_logical1 (u),
5803 ffebld_constant_logical1 (ffebld_conter (l)),
5804 ffebld_constant_logical1 (ffebld_conter (r)));
5805 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5806 (ffebld_cu_val_logical1 (u)), expr);
5807 break;
5808 #endif
5809
5810 #if FFETARGET_okLOGICAL2
5811 case FFEINFO_kindtypeLOGICAL2:
5812 error = ffetarget_neqv_logical2 (ffebld_cu_ptr_logical2 (u),
5813 ffebld_constant_logical2 (ffebld_conter (l)),
5814 ffebld_constant_logical2 (ffebld_conter (r)));
5815 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5816 (ffebld_cu_val_logical2 (u)), expr);
5817 break;
5818 #endif
5819
5820 #if FFETARGET_okLOGICAL3
5821 case FFEINFO_kindtypeLOGICAL3:
5822 error = ffetarget_neqv_logical3 (ffebld_cu_ptr_logical3 (u),
5823 ffebld_constant_logical3 (ffebld_conter (l)),
5824 ffebld_constant_logical3 (ffebld_conter (r)));
5825 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5826 (ffebld_cu_val_logical3 (u)), expr);
5827 break;
5828 #endif
5829
5830 #if FFETARGET_okLOGICAL4
5831 case FFEINFO_kindtypeLOGICAL4:
5832 error = ffetarget_neqv_logical4 (ffebld_cu_ptr_logical4 (u),
5833 ffebld_constant_logical4 (ffebld_conter (l)),
5834 ffebld_constant_logical4 (ffebld_conter (r)));
5835 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5836 (ffebld_cu_val_logical4 (u)), expr);
5837 break;
5838 #endif
5839
5840 default:
5841 assert ("bad logical kind type" == NULL);
5842 break;
5843 }
5844 break;
5845
5846 default:
5847 assert ("bad type" == NULL);
5848 return expr;
5849 }
5850
5851 ffebld_set_info (expr, ffeinfo_new
5852 (bt,
5853 kt,
5854 0,
5855 FFEINFO_kindENTITY,
5856 FFEINFO_whereCONSTANT,
5857 FFETARGET_charactersizeNONE));
5858
5859 if ((error != FFEBAD)
5860 && ffebad_start (error))
5861 {
5862 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5863 ffebad_finish ();
5864 }
5865
5866 return expr;
5867 }
5868
5869 /* ffeexpr_collapse_symter -- Collapse symter expr
5870
5871 ffebld expr;
5872 ffelexToken token;
5873 expr = ffeexpr_collapse_symter(expr,token);
5874
5875 If the result of the expr is a constant, replaces the expr with the
5876 computed constant. */
5877
5878 ffebld
5879 ffeexpr_collapse_symter (ffebld expr, ffelexToken t UNUSED)
5880 {
5881 ffebld r;
5882 ffeinfoBasictype bt;
5883 ffeinfoKindtype kt;
5884 ffetargetCharacterSize len;
5885
5886 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5887 return expr;
5888
5889 if ((r = ffesymbol_init (ffebld_symter (expr))) == NULL)
5890 return expr; /* A PARAMETER lhs in progress. */
5891
5892 switch (ffebld_op (r))
5893 {
5894 case FFEBLD_opCONTER:
5895 break;
5896
5897 case FFEBLD_opANY:
5898 return r;
5899
5900 default:
5901 return expr;
5902 }
5903
5904 bt = ffeinfo_basictype (ffebld_info (r));
5905 kt = ffeinfo_kindtype (ffebld_info (r));
5906 len = ffebld_size (r);
5907
5908 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
5909 expr);
5910
5911 ffebld_set_info (expr, ffeinfo_new
5912 (bt,
5913 kt,
5914 0,
5915 FFEINFO_kindENTITY,
5916 FFEINFO_whereCONSTANT,
5917 len));
5918
5919 return expr;
5920 }
5921
5922 /* ffeexpr_collapse_funcref -- Collapse funcref expr
5923
5924 ffebld expr;
5925 ffelexToken token;
5926 expr = ffeexpr_collapse_funcref(expr,token);
5927
5928 If the result of the expr is a constant, replaces the expr with the
5929 computed constant. */
5930
5931 ffebld
5932 ffeexpr_collapse_funcref (ffebld expr, ffelexToken t UNUSED)
5933 {
5934 return expr; /* ~~someday go ahead and collapse these,
5935 though not required */
5936 }
5937
5938 /* ffeexpr_collapse_arrayref -- Collapse arrayref expr
5939
5940 ffebld expr;
5941 ffelexToken token;
5942 expr = ffeexpr_collapse_arrayref(expr,token);
5943
5944 If the result of the expr is a constant, replaces the expr with the
5945 computed constant. */
5946
5947 ffebld
5948 ffeexpr_collapse_arrayref (ffebld expr, ffelexToken t UNUSED)
5949 {
5950 return expr;
5951 }
5952
5953 /* ffeexpr_collapse_substr -- Collapse substr expr
5954
5955 ffebld expr;
5956 ffelexToken token;
5957 expr = ffeexpr_collapse_substr(expr,token);
5958
5959 If the result of the expr is a constant, replaces the expr with the
5960 computed constant. */
5961
5962 ffebld
5963 ffeexpr_collapse_substr (ffebld expr, ffelexToken t)
5964 {
5965 ffebad error = FFEBAD;
5966 ffebld l;
5967 ffebld r;
5968 ffebld start;
5969 ffebld stop;
5970 ffebldConstantUnion u;
5971 ffeinfoKindtype kt;
5972 ffetargetCharacterSize len;
5973 ffetargetIntegerDefault first;
5974 ffetargetIntegerDefault last;
5975
5976 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5977 return expr;
5978
5979 l = ffebld_left (expr);
5980 r = ffebld_right (expr); /* opITEM. */
5981
5982 if (ffebld_op (l) != FFEBLD_opCONTER)
5983 return expr;
5984
5985 kt = ffeinfo_kindtype (ffebld_info (l));
5986 len = ffebld_size (l);
5987
5988 start = ffebld_head (r);
5989 stop = ffebld_head (ffebld_trail (r));
5990 if (start == NULL)
5991 first = 1;
5992 else
5993 {
5994 if ((ffebld_op (start) != FFEBLD_opCONTER)
5995 || (ffeinfo_basictype (ffebld_info (start)) != FFEINFO_basictypeINTEGER)
5996 || (ffeinfo_kindtype (ffebld_info (start))
5997 != FFEINFO_kindtypeINTEGERDEFAULT))
5998 return expr;
5999 first = ffebld_constant_integerdefault (ffebld_conter (start));
6000 }
6001 if (stop == NULL)
6002 last = len;
6003 else
6004 {
6005 if ((ffebld_op (stop) != FFEBLD_opCONTER)
6006 || (ffeinfo_basictype (ffebld_info (stop)) != FFEINFO_basictypeINTEGER)
6007 || (ffeinfo_kindtype (ffebld_info (stop))
6008 != FFEINFO_kindtypeINTEGERDEFAULT))
6009 return expr;
6010 last = ffebld_constant_integerdefault (ffebld_conter (stop));
6011 }
6012
6013 /* Handle problems that should have already been diagnosed, but
6014 left in the expression tree. */
6015
6016 if (first <= 0)
6017 first = 1;
6018 if (last < first)
6019 last = first + len - 1;
6020
6021 if ((first == 1) && (last == len))
6022 { /* Same as original. */
6023 expr = ffebld_new_conter_with_orig (ffebld_constant_copy
6024 (ffebld_conter (l)), expr);
6025 ffebld_set_info (expr, ffeinfo_new
6026 (FFEINFO_basictypeCHARACTER,
6027 kt,
6028 0,
6029 FFEINFO_kindENTITY,
6030 FFEINFO_whereCONSTANT,
6031 len));
6032
6033 return expr;
6034 }
6035
6036 switch (ffeinfo_basictype (ffebld_info (expr)))
6037 {
6038 case FFEINFO_basictypeANY:
6039 return expr;
6040
6041 case FFEINFO_basictypeCHARACTER:
6042 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6043 {
6044 #if FFETARGET_okCHARACTER1
6045 case FFEINFO_kindtypeCHARACTER1:
6046 error = ffetarget_substr_character1 (ffebld_cu_ptr_character1 (u),
6047 ffebld_constant_character1 (ffebld_conter (l)), first, last,
6048 ffebld_constant_pool (), &len);
6049 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
6050 (ffebld_cu_val_character1 (u)), expr);
6051 break;
6052 #endif
6053
6054 default:
6055 assert ("bad character kind type" == NULL);
6056 break;
6057 }
6058 break;
6059
6060 default:
6061 assert ("bad type" == NULL);
6062 return expr;
6063 }
6064
6065 ffebld_set_info (expr, ffeinfo_new
6066 (FFEINFO_basictypeCHARACTER,
6067 kt,
6068 0,
6069 FFEINFO_kindENTITY,
6070 FFEINFO_whereCONSTANT,
6071 len));
6072
6073 if ((error != FFEBAD)
6074 && ffebad_start (error))
6075 {
6076 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6077 ffebad_finish ();
6078 }
6079
6080 return expr;
6081 }
6082
6083 /* ffeexpr_convert -- Convert source expression to given type
6084
6085 ffebld source;
6086 ffelexToken source_token;
6087 ffelexToken dest_token; // Any appropriate token for "destination".
6088 ffeinfoBasictype bt;
6089 ffeinfoKindtype kt;
6090 ffetargetCharactersize sz;
6091 ffeexprContext context; // Mainly LET or DATA.
6092 source = ffeexpr_convert(source,source_token,dest_token,bt,kt,sz,context);
6093
6094 If the expression conforms, returns the source expression. Otherwise
6095 returns source wrapped in a convert node doing the conversion, or
6096 ANY wrapped in convert if there is a conversion error (and issues an
6097 error message). Be sensitive to the context for certain aspects of
6098 the conversion. */
6099
6100 ffebld
6101 ffeexpr_convert (ffebld source, ffelexToken source_token, ffelexToken dest_token,
6102 ffeinfoBasictype bt, ffeinfoKindtype kt, ffeinfoRank rk,
6103 ffetargetCharacterSize sz, ffeexprContext context)
6104 {
6105 bool bad;
6106 ffeinfo info;
6107 ffeinfoWhere wh;
6108
6109 info = ffebld_info (source);
6110 if ((bt != ffeinfo_basictype (info))
6111 || (kt != ffeinfo_kindtype (info))
6112 || (rk != 0) /* Can't convert from or to arrays yet. */
6113 || (ffeinfo_rank (info) != 0)
6114 || (sz != ffebld_size_known (source)))
6115 #if 0 /* Nobody seems to need this spurious CONVERT node. */
6116 || ((context != FFEEXPR_contextLET)
6117 && (bt == FFEINFO_basictypeCHARACTER)
6118 && (sz == FFETARGET_charactersizeNONE)))
6119 #endif
6120 {
6121 switch (ffeinfo_basictype (info))
6122 {
6123 case FFEINFO_basictypeLOGICAL:
6124 switch (bt)
6125 {
6126 case FFEINFO_basictypeLOGICAL:
6127 bad = FALSE;
6128 break;
6129
6130 case FFEINFO_basictypeINTEGER:
6131 bad = !ffe_is_ugly_logint ();
6132 break;
6133
6134 case FFEINFO_basictypeCHARACTER:
6135 bad = ffe_is_pedantic ()
6136 || !(ffe_is_ugly_init ()
6137 && (context == FFEEXPR_contextDATA));
6138 break;
6139
6140 default:
6141 bad = TRUE;
6142 break;
6143 }
6144 break;
6145
6146 case FFEINFO_basictypeINTEGER:
6147 switch (bt)
6148 {
6149 case FFEINFO_basictypeINTEGER:
6150 case FFEINFO_basictypeREAL:
6151 case FFEINFO_basictypeCOMPLEX:
6152 bad = FALSE;
6153 break;
6154
6155 case FFEINFO_basictypeLOGICAL:
6156 bad = !ffe_is_ugly_logint ();
6157 break;
6158
6159 case FFEINFO_basictypeCHARACTER:
6160 bad = ffe_is_pedantic ()
6161 || !(ffe_is_ugly_init ()
6162 && (context == FFEEXPR_contextDATA));
6163 break;
6164
6165 default:
6166 bad = TRUE;
6167 break;
6168 }
6169 break;
6170
6171 case FFEINFO_basictypeREAL:
6172 case FFEINFO_basictypeCOMPLEX:
6173 switch (bt)
6174 {
6175 case FFEINFO_basictypeINTEGER:
6176 case FFEINFO_basictypeREAL:
6177 case FFEINFO_basictypeCOMPLEX:
6178 bad = FALSE;
6179 break;
6180
6181 case FFEINFO_basictypeCHARACTER:
6182 bad = TRUE;
6183 break;
6184
6185 default:
6186 bad = TRUE;
6187 break;
6188 }
6189 break;
6190
6191 case FFEINFO_basictypeCHARACTER:
6192 bad = (bt != FFEINFO_basictypeCHARACTER)
6193 && (ffe_is_pedantic ()
6194 || (bt != FFEINFO_basictypeINTEGER)
6195 || !(ffe_is_ugly_init ()
6196 && (context == FFEEXPR_contextDATA)));
6197 break;
6198
6199 case FFEINFO_basictypeTYPELESS:
6200 case FFEINFO_basictypeHOLLERITH:
6201 bad = ffe_is_pedantic ()
6202 || !(ffe_is_ugly_init ()
6203 && ((context == FFEEXPR_contextDATA)
6204 || (context == FFEEXPR_contextLET)));
6205 break;
6206
6207 default:
6208 bad = TRUE;
6209 break;
6210 }
6211
6212 if (!bad && ((rk != 0) || (ffeinfo_rank (info) != 0)))
6213 bad = TRUE;
6214
6215 if (bad && (bt != FFEINFO_basictypeANY) && (kt != FFEINFO_kindtypeANY)
6216 && (ffeinfo_basictype (info) != FFEINFO_basictypeANY)
6217 && (ffeinfo_kindtype (info) != FFEINFO_kindtypeANY)
6218 && (ffeinfo_where (info) != FFEINFO_whereANY))
6219 {
6220 if (ffebad_start (FFEBAD_BAD_TYPES))
6221 {
6222 if (dest_token == NULL)
6223 ffebad_here (0, ffewhere_line_unknown (),
6224 ffewhere_column_unknown ());
6225 else
6226 ffebad_here (0, ffelex_token_where_line (dest_token),
6227 ffelex_token_where_column (dest_token));
6228 assert (source_token != NULL);
6229 ffebad_here (1, ffelex_token_where_line (source_token),
6230 ffelex_token_where_column (source_token));
6231 ffebad_finish ();
6232 }
6233
6234 source = ffebld_new_any ();
6235 ffebld_set_info (source, ffeinfo_new_any ());
6236 }
6237 else
6238 {
6239 switch (ffeinfo_where (info))
6240 {
6241 case FFEINFO_whereCONSTANT:
6242 wh = FFEINFO_whereCONSTANT;
6243 break;
6244
6245 case FFEINFO_whereIMMEDIATE:
6246 wh = FFEINFO_whereIMMEDIATE;
6247 break;
6248
6249 default:
6250 wh = FFEINFO_whereFLEETING;
6251 break;
6252 }
6253 source = ffebld_new_convert (source);
6254 ffebld_set_info (source, ffeinfo_new
6255 (bt,
6256 kt,
6257 0,
6258 FFEINFO_kindENTITY,
6259 wh,
6260 sz));
6261 source = ffeexpr_collapse_convert (source, source_token);
6262 }
6263 }
6264
6265 return source;
6266 }
6267
6268 /* ffeexpr_convert_expr -- Convert source expr to conform to dest expr
6269
6270 ffebld source;
6271 ffebld dest;
6272 ffelexToken source_token;
6273 ffelexToken dest_token;
6274 ffeexprContext context;
6275 source = ffeexpr_convert_expr(source,source_token,dest,dest_token,context);
6276
6277 If the expressions conform, returns the source expression. Otherwise
6278 returns source wrapped in a convert node doing the conversion, or
6279 ANY wrapped in convert if there is a conversion error (and issues an
6280 error message). Be sensitive to the context, such as LET or DATA. */
6281
6282 ffebld
6283 ffeexpr_convert_expr (ffebld source, ffelexToken source_token, ffebld dest,
6284 ffelexToken dest_token, ffeexprContext context)
6285 {
6286 ffeinfo info;
6287
6288 info = ffebld_info (dest);
6289 return ffeexpr_convert (source, source_token, dest_token,
6290 ffeinfo_basictype (info),
6291 ffeinfo_kindtype (info),
6292 ffeinfo_rank (info),
6293 ffebld_size_known (dest),
6294 context);
6295 }
6296
6297 /* ffeexpr_convert_to_sym -- Convert source expression to conform to symbol
6298
6299 ffebld source;
6300 ffesymbol dest;
6301 ffelexToken source_token;
6302 ffelexToken dest_token;
6303 source = ffeexpr_convert_to_sym(source,source_token,dest,dest_token);
6304
6305 If the expressions conform, returns the source expression. Otherwise
6306 returns source wrapped in a convert node doing the conversion, or
6307 ANY wrapped in convert if there is a conversion error (and issues an
6308 error message). */
6309
6310 ffebld
6311 ffeexpr_convert_to_sym (ffebld source, ffelexToken source_token,
6312 ffesymbol dest, ffelexToken dest_token)
6313 {
6314 return ffeexpr_convert (source, source_token, dest_token, ffesymbol_basictype (dest),
6315 ffesymbol_kindtype (dest), ffesymbol_rank (dest), ffesymbol_size (dest),
6316 FFEEXPR_contextLET);
6317 }
6318
6319 /* Initializes the module. */
6320
6321 void
6322 ffeexpr_init_2 (void)
6323 {
6324 ffeexpr_stack_ = NULL;
6325 ffeexpr_level_ = 0;
6326 }
6327
6328 /* ffeexpr_lhs -- Begin processing left-hand-side-context expression
6329
6330 Prepares cluster for delivery of lexer tokens representing an expression
6331 in a left-hand-side context (A in A=B, for example). ffebld is used
6332 to build expressions in the given pool. The appropriate lexer-token
6333 handling routine within ffeexpr is returned. When the end of the
6334 expression is detected, mycallbackroutine is called with the resulting
6335 single ffebld object specifying the entire expression and the first
6336 lexer token that is not considered part of the expression. This caller-
6337 supplied routine itself returns a lexer-token handling routine. Thus,
6338 if necessary, ffeexpr can return several tokens as end-of-expression
6339 tokens if it needs to scan forward more than one in any instance. */
6340
6341 ffelexHandler
6342 ffeexpr_lhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
6343 {
6344 ffeexprStack_ s;
6345
6346 ffebld_pool_push (pool);
6347 s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
6348 s->previous = ffeexpr_stack_;
6349 s->pool = pool;
6350 s->context = context;
6351 s->callback = callback;
6352 s->first_token = NULL;
6353 s->exprstack = NULL;
6354 s->is_rhs = FALSE;
6355 ffeexpr_stack_ = s;
6356 return (ffelexHandler) ffeexpr_token_first_lhs_;
6357 }
6358
6359 /* ffeexpr_rhs -- Begin processing right-hand-side-context expression
6360
6361 return ffeexpr_rhs(malloc_pool_image(),mycallbackroutine); // to lexer.
6362
6363 Prepares cluster for delivery of lexer tokens representing an expression
6364 in a right-hand-side context (B in A=B, for example). ffebld is used
6365 to build expressions in the given pool. The appropriate lexer-token
6366 handling routine within ffeexpr is returned. When the end of the
6367 expression is detected, mycallbackroutine is called with the resulting
6368 single ffebld object specifying the entire expression and the first
6369 lexer token that is not considered part of the expression. This caller-
6370 supplied routine itself returns a lexer-token handling routine. Thus,
6371 if necessary, ffeexpr can return several tokens as end-of-expression
6372 tokens if it needs to scan forward more than one in any instance. */
6373
6374 ffelexHandler
6375 ffeexpr_rhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
6376 {
6377 ffeexprStack_ s;
6378
6379 ffebld_pool_push (pool);
6380 s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
6381 s->previous = ffeexpr_stack_;
6382 s->pool = pool;
6383 s->context = context;
6384 s->callback = callback;
6385 s->first_token = NULL;
6386 s->exprstack = NULL;
6387 s->is_rhs = TRUE;
6388 ffeexpr_stack_ = s;
6389 return (ffelexHandler) ffeexpr_token_first_rhs_;
6390 }
6391
6392 /* ffeexpr_cb_close_paren_ -- OPEN_PAREN expr
6393
6394 Pass it to ffeexpr_rhs as the callback routine.
6395
6396 Makes sure the end token is close-paren and swallows it, else issues
6397 an error message and doesn't swallow the token (passing it along instead).
6398 In either case wraps up subexpression construction by enclosing the
6399 ffebld expression in a paren. */
6400
6401 static ffelexHandler
6402 ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr, ffelexToken t)
6403 {
6404 ffeexprExpr_ e;
6405
6406 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
6407 {
6408 /* Oops, naughty user didn't specify the close paren! */
6409
6410 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
6411 {
6412 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6413 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
6414 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
6415 ffebad_finish ();
6416 }
6417
6418 e = ffeexpr_expr_new_ ();
6419 e->type = FFEEXPR_exprtypeOPERAND_;
6420 e->u.operand = ffebld_new_any ();
6421 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
6422 ffeexpr_exprstack_push_operand_ (e);
6423
6424 return
6425 (ffelexHandler) ffeexpr_find_close_paren_ (t,
6426 (ffelexHandler)
6427 ffeexpr_token_binary_);
6428 }
6429
6430 if (expr->op == FFEBLD_opIMPDO)
6431 {
6432 if (ffest_ffebad_start (FFEBAD_IMPDO_PAREN))
6433 {
6434 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
6435 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
6436 ffebad_finish ();
6437 }
6438 }
6439 else
6440 {
6441 expr = ffebld_new_paren (expr);
6442 ffebld_set_info (expr, ffeinfo_use (ffebld_info (ffebld_left (expr))));
6443 }
6444
6445 /* Now push the (parenthesized) expression as an operand onto the
6446 expression stack. */
6447
6448 e = ffeexpr_expr_new_ ();
6449 e->type = FFEEXPR_exprtypeOPERAND_;
6450 e->u.operand = expr;
6451 e->u.operand = ffeexpr_collapse_paren (e->u.operand, ft);
6452 e->token = ffeexpr_stack_->tokens[0];
6453 ffeexpr_exprstack_push_operand_ (e);
6454
6455 return (ffelexHandler) ffeexpr_token_binary_;
6456 }
6457
6458 /* ffeexpr_cb_close_paren_ambig_ -- OPEN_PAREN expr
6459
6460 Pass it to ffeexpr_rhs as the callback routine.
6461
6462 We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
6463 with the next token in t. If the next token is possibly a binary
6464 operator, continue processing the outer expression. If the next
6465 token is COMMA, then the expression is a unit specifier, and
6466 parentheses should not be added to it because it surrounds the
6467 I/O control list that starts with the unit specifier (and continues
6468 on from here -- we haven't seen the CLOSE_PAREN that matches the
6469 OPEN_PAREN, it is up to the callback function to expect to see it
6470 at some point). In this case, we notify the callback function that
6471 the COMMA is inside, not outside, the parens by wrapping the expression
6472 in an opITEM (with a NULL trail) -- the callback function presumably
6473 unwraps it after seeing this kludgey indicator.
6474
6475 If the next token is CLOSE_PAREN, then we go to the _1_ state to
6476 decide what to do with the token after that.
6477
6478 15-Feb-91 JCB 1.1
6479 Use an extra state for the CLOSE_PAREN case to make READ &co really
6480 work right. */
6481
6482 static ffelexHandler
6483 ffeexpr_cb_close_paren_ambig_ (ffelexToken ft, ffebld expr, ffelexToken t)
6484 {
6485 ffeexprCallback callback;
6486 ffeexprStack_ s;
6487
6488 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
6489 { /* Need to see the next token before we
6490 decide anything. */
6491 ffeexpr_stack_->expr = expr;
6492 ffeexpr_tokens_[0] = ffelex_token_use (ft);
6493 ffeexpr_tokens_[1] = ffelex_token_use (t);
6494 return (ffelexHandler) ffeexpr_cb_close_paren_ambig_1_;
6495 }
6496
6497 expr = ffeexpr_finished_ambig_ (ft, expr);
6498
6499 /* Let the callback function handle the case where t isn't COMMA. */
6500
6501 /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
6502 that preceded the expression starts a list of expressions, and the expr
6503 hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
6504 node. The callback function should extract the real expr from the head
6505 of this opITEM node after testing it. */
6506
6507 expr = ffebld_new_item (expr, NULL);
6508
6509 ffebld_pool_pop ();
6510 callback = ffeexpr_stack_->callback;
6511 ffelex_token_kill (ffeexpr_stack_->first_token);
6512 s = ffeexpr_stack_->previous;
6513 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
6514 ffeexpr_stack_ = s;
6515 return (ffelexHandler) (*callback) (ft, expr, t);
6516 }
6517
6518 /* ffeexpr_cb_close_paren_ambig_1_ -- OPEN_PAREN expr CLOSE_PAREN
6519
6520 See ffeexpr_cb_close_paren_ambig_.
6521
6522 We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
6523 with the next token in t. If the next token is possibly a binary
6524 operator, continue processing the outer expression. If the next
6525 token is COMMA, the expression is a parenthesized format specifier.
6526 If the next token is not EOS or SEMICOLON, then because it is not a
6527 binary operator (it is NAME, OPEN_PAREN, &c), the expression is
6528 a unit specifier, and parentheses should not be added to it because
6529 they surround the I/O control list that consists of only the unit
6530 specifier. If the next token is EOS or SEMICOLON, the statement
6531 must be disambiguated by looking at the type of the expression -- a
6532 character expression is a parenthesized format specifier, while a
6533 non-character expression is a unit specifier.
6534
6535 Another issue is how to do the callback so the recipient of the
6536 next token knows how to handle it if it is a COMMA. In all other
6537 cases, disambiguation is straightforward: the same approach as the
6538 above is used.
6539
6540 EXTENSION: in COMMA case, if not pedantic, use same disambiguation
6541 as for EOS/SEMICOLON case; f2c allows "READ (cilist) [[,]iolist]"
6542 and apparently other compilers do, as well, and some code out there
6543 uses this "feature".
6544
6545 19-Feb-91 JCB 1.1
6546 Extend to allow COMMA as nondisambiguating by itself. Remember
6547 to not try and check info field for opSTAR, since that expr doesn't
6548 have a valid info field. */
6549
6550 static ffelexHandler
6551 ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t)
6552 {
6553 ffeexprCallback callback;
6554 ffeexprStack_ s;
6555 ffelexHandler next;
6556 ffelexToken orig_ft = ffeexpr_tokens_[0]; /* In case callback clobbers
6557 these. */
6558 ffelexToken orig_t = ffeexpr_tokens_[1];
6559 ffebld expr = ffeexpr_stack_->expr;
6560
6561 switch (ffelex_token_type (t))
6562 {
6563 case FFELEX_typeCOMMA: /* Subexpr is parenthesized format specifier. */
6564 if (ffe_is_pedantic ())
6565 goto pedantic_comma; /* :::::::::::::::::::: */
6566 /* Fall through. */
6567 case FFELEX_typeEOS: /* Ambiguous; use type of expr to
6568 disambiguate. */
6569 case FFELEX_typeSEMICOLON:
6570 if ((expr == NULL) || (ffebld_op (expr) == FFEBLD_opANY)
6571 || (ffebld_op (expr) == FFEBLD_opSTAR)
6572 || (ffeinfo_basictype (ffebld_info (expr))
6573 != FFEINFO_basictypeCHARACTER))
6574 break; /* Not a valid CHARACTER entity, can't be a
6575 format spec. */
6576 /* Fall through. */
6577 default: /* Binary op (we assume; error otherwise);
6578 format specifier. */
6579
6580 pedantic_comma: /* :::::::::::::::::::: */
6581
6582 switch (ffeexpr_stack_->context)
6583 {
6584 case FFEEXPR_contextFILENUMAMBIG:
6585 ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
6586 break;
6587
6588 case FFEEXPR_contextFILEUNITAMBIG:
6589 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
6590 break;
6591
6592 default:
6593 assert ("bad context" == NULL);
6594 break;
6595 }
6596
6597 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
6598 next = (ffelexHandler) ffeexpr_cb_close_paren_ (orig_ft, expr, orig_t);
6599 ffelex_token_kill (orig_ft);
6600 ffelex_token_kill (orig_t);
6601 return (ffelexHandler) (*next) (t);
6602
6603 case FFELEX_typeOPEN_PAREN:/* Non-binary op; beginning of I/O list. */
6604 case FFELEX_typeNAME:
6605 break;
6606 }
6607
6608 expr = ffeexpr_finished_ambig_ (orig_ft, expr);
6609
6610 /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
6611 that preceded the expression starts a list of expressions, and the expr
6612 hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
6613 node. The callback function should extract the real expr from the head
6614 of this opITEM node after testing it. */
6615
6616 expr = ffebld_new_item (expr, NULL);
6617
6618 ffebld_pool_pop ();
6619 callback = ffeexpr_stack_->callback;
6620 ffelex_token_kill (ffeexpr_stack_->first_token);
6621 s = ffeexpr_stack_->previous;
6622 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
6623 ffeexpr_stack_ = s;
6624 next = (ffelexHandler) (*callback) (orig_ft, expr, orig_t);
6625 ffelex_token_kill (orig_ft);
6626 ffelex_token_kill (orig_t);
6627 return (ffelexHandler) (*next) (t);
6628 }
6629
6630 /* ffeexpr_cb_close_paren_c_ -- OPEN_PAREN expr (possible complex)
6631
6632 Pass it to ffeexpr_rhs as the callback routine.
6633
6634 Makes sure the end token is close-paren and swallows it, or a comma
6635 and handles complex/implied-do possibilities, else issues
6636 an error message and doesn't swallow the token (passing it along instead). */
6637
6638 static ffelexHandler
6639 ffeexpr_cb_close_paren_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
6640 {
6641 /* First check to see if this is a possible complex entity. It is if the
6642 token is a comma. */
6643
6644 if (ffelex_token_type (t) == FFELEX_typeCOMMA)
6645 {
6646 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
6647 ffeexpr_stack_->expr = expr;
6648 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
6649 FFEEXPR_contextPAREN_, ffeexpr_cb_comma_c_);
6650 }
6651
6652 return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
6653 }
6654
6655 /* ffeexpr_cb_comma_c_ -- OPEN_PAREN expr COMMA expr
6656
6657 Pass it to ffeexpr_rhs as the callback routine.
6658
6659 If this token is not a comma, we have a complex constant (or an attempt
6660 at one), so handle it accordingly, displaying error messages if the token
6661 is not a close-paren. */
6662
6663 static ffelexHandler
6664 ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
6665 {
6666 ffeexprExpr_ e;
6667 ffeinfoBasictype lty = (ffeexpr_stack_->expr == NULL)
6668 ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (ffeexpr_stack_->expr));
6669 ffeinfoBasictype rty = (expr == NULL)
6670 ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (expr));
6671 ffeinfoKindtype lkt;
6672 ffeinfoKindtype rkt;
6673 ffeinfoKindtype nkt;
6674 bool ok = TRUE;
6675 ffebld orig;
6676
6677 if ((ffeexpr_stack_->expr == NULL)
6678 || (ffebld_op (ffeexpr_stack_->expr) != FFEBLD_opCONTER)
6679 || (((orig = ffebld_conter_orig (ffeexpr_stack_->expr)) != NULL)
6680 && (((ffebld_op (orig) != FFEBLD_opUMINUS)
6681 && (ffebld_op (orig) != FFEBLD_opUPLUS))
6682 || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
6683 || ((lty != FFEINFO_basictypeINTEGER)
6684 && (lty != FFEINFO_basictypeREAL)))
6685 {
6686 if ((lty != FFEINFO_basictypeANY)
6687 && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
6688 {
6689 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
6690 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
6691 ffebad_string ("Real");
6692 ffebad_finish ();
6693 }
6694 ok = FALSE;
6695 }
6696 if ((expr == NULL)
6697 || (ffebld_op (expr) != FFEBLD_opCONTER)
6698 || (((orig = ffebld_conter_orig (expr)) != NULL)
6699 && (((ffebld_op (orig) != FFEBLD_opUMINUS)
6700 && (ffebld_op (orig) != FFEBLD_opUPLUS))
6701 || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
6702 || ((rty != FFEINFO_basictypeINTEGER)
6703 && (rty != FFEINFO_basictypeREAL)))
6704 {
6705 if ((rty != FFEINFO_basictypeANY)
6706 && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
6707 {
6708 ffebad_here (0, ffelex_token_where_line (ft),
6709 ffelex_token_where_column (ft));
6710 ffebad_string ("Imaginary");
6711 ffebad_finish ();
6712 }
6713 ok = FALSE;
6714 }
6715
6716 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
6717
6718 /* Push the (parenthesized) expression as an operand onto the expression
6719 stack. */
6720
6721 e = ffeexpr_expr_new_ ();
6722 e->type = FFEEXPR_exprtypeOPERAND_;
6723 e->token = ffeexpr_stack_->tokens[0];
6724
6725 if (ok)
6726 {
6727 if (lty == FFEINFO_basictypeINTEGER)
6728 lkt = FFEINFO_kindtypeREALDEFAULT;
6729 else
6730 lkt = ffeinfo_kindtype (ffebld_info (ffeexpr_stack_->expr));
6731 if (rty == FFEINFO_basictypeINTEGER)
6732 rkt = FFEINFO_kindtypeREALDEFAULT;
6733 else
6734 rkt = ffeinfo_kindtype (ffebld_info (expr));
6735
6736 nkt = ffeinfo_kindtype_max (FFEINFO_basictypeCOMPLEX, lkt, rkt);
6737 ffeexpr_stack_->expr = ffeexpr_convert (ffeexpr_stack_->expr,
6738 ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
6739 FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
6740 FFEEXPR_contextLET);
6741 expr = ffeexpr_convert (expr,
6742 ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
6743 FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
6744 FFEEXPR_contextLET);
6745 }
6746 else
6747 nkt = FFEINFO_kindtypeANY;
6748
6749 switch (nkt)
6750 {
6751 #if FFETARGET_okCOMPLEX1
6752 case FFEINFO_kindtypeREAL1:
6753 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex1
6754 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
6755 ffebld_set_info (e->u.operand,
6756 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
6757 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
6758 FFETARGET_charactersizeNONE));
6759 break;
6760 #endif
6761
6762 #if FFETARGET_okCOMPLEX2
6763 case FFEINFO_kindtypeREAL2:
6764 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex2
6765 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
6766 ffebld_set_info (e->u.operand,
6767 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
6768 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
6769 FFETARGET_charactersizeNONE));
6770 break;
6771 #endif
6772
6773 #if FFETARGET_okCOMPLEX3
6774 case FFEINFO_kindtypeREAL3:
6775 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex3
6776 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
6777 ffebld_set_info (e->u.operand,
6778 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
6779 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
6780 FFETARGET_charactersizeNONE));
6781 break;
6782 #endif
6783
6784 default:
6785 if (ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
6786 ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX))
6787 {
6788 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
6789 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
6790 ffebad_finish ();
6791 }
6792 /* Fall through. */
6793 case FFEINFO_kindtypeANY:
6794 e->u.operand = ffebld_new_any ();
6795 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
6796 break;
6797 }
6798 ffeexpr_exprstack_push_operand_ (e);
6799
6800 /* Now, if the token is a close parenthese, we're in great shape so return
6801 the next handler. */
6802
6803 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
6804 return (ffelexHandler) ffeexpr_token_binary_;
6805
6806 /* Oops, naughty user didn't specify the close paren! */
6807
6808 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
6809 {
6810 ffebad_here (0, ffelex_token_where_line (t),
6811 ffelex_token_where_column (t));
6812 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
6813 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
6814 ffebad_finish ();
6815 }
6816
6817 return
6818 (ffelexHandler) ffeexpr_find_close_paren_ (t,
6819 (ffelexHandler)
6820 ffeexpr_token_binary_);
6821 }
6822
6823 /* ffeexpr_cb_close_paren_ci_ -- OPEN_PAREN expr (possible complex or
6824 implied-DO construct)
6825
6826 Pass it to ffeexpr_rhs as the callback routine.
6827
6828 Makes sure the end token is close-paren and swallows it, or a comma
6829 and handles complex/implied-do possibilities, else issues
6830 an error message and doesn't swallow the token (passing it along instead). */
6831
6832 static ffelexHandler
6833 ffeexpr_cb_close_paren_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
6834 {
6835 ffeexprContext ctx;
6836
6837 /* First check to see if this is a possible complex or implied-DO entity.
6838 It is if the token is a comma. */
6839
6840 if (ffelex_token_type (t) == FFELEX_typeCOMMA)
6841 {
6842 switch (ffeexpr_stack_->context)
6843 {
6844 case FFEEXPR_contextIOLIST:
6845 case FFEEXPR_contextIMPDOITEM_:
6846 ctx = FFEEXPR_contextIMPDOITEM_;
6847 break;
6848
6849 case FFEEXPR_contextIOLISTDF:
6850 case FFEEXPR_contextIMPDOITEMDF_:
6851 ctx = FFEEXPR_contextIMPDOITEMDF_;
6852 break;
6853
6854 default:
6855 assert ("bad context" == NULL);
6856 ctx = FFEEXPR_contextIMPDOITEM_;
6857 break;
6858 }
6859
6860 ffeexpr_stack_->tokens[0] = ffelex_token_use (ft);
6861 ffeexpr_stack_->expr = expr;
6862 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
6863 ctx, ffeexpr_cb_comma_ci_);
6864 }
6865
6866 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
6867 return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
6868 }
6869
6870 /* ffeexpr_cb_comma_ci_ -- OPEN_PAREN expr COMMA expr
6871
6872 Pass it to ffeexpr_rhs as the callback routine.
6873
6874 If this token is not a comma, we have a complex constant (or an attempt
6875 at one), so handle it accordingly, displaying error messages if the token
6876 is not a close-paren. If we have a comma here, it is an attempt at an
6877 implied-DO, so start making a list accordingly. Oh, it might be an
6878 equal sign also, meaning an implied-DO with only one item in its list. */
6879
6880 static ffelexHandler
6881 ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
6882 {
6883 ffebld fexpr;
6884
6885 /* First check to see if this is a possible complex constant. It is if the
6886 token is not a comma or an equals sign, in which case it should be a
6887 close-paren. */
6888
6889 if ((ffelex_token_type (t) != FFELEX_typeCOMMA)
6890 && (ffelex_token_type (t) != FFELEX_typeEQUALS))
6891 {
6892 ffeexpr_stack_->tokens[1] = ffeexpr_stack_->tokens[0];
6893 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
6894 return (ffelexHandler) ffeexpr_cb_comma_c_ (ft, expr, t);
6895 }
6896
6897 /* Here we have either EQUALS or COMMA, meaning we are in an implied-DO
6898 construct. Make a list and handle accordingly. */
6899
6900 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
6901 fexpr = ffeexpr_stack_->expr;
6902 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
6903 ffebld_append_item (&ffeexpr_stack_->bottom, fexpr);
6904 return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
6905 }
6906
6907 /* ffeexpr_cb_comma_i_ -- OPEN_PAREN expr
6908
6909 Pass it to ffeexpr_rhs as the callback routine.
6910
6911 Handle first item in an implied-DO construct. */
6912
6913 static ffelexHandler
6914 ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr, ffelexToken t)
6915 {
6916 if (ffelex_token_type (t) != FFELEX_typeCOMMA)
6917 {
6918 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
6919 {
6920 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6921 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
6922 ffelex_token_where_column (ffeexpr_stack_->first_token));
6923 ffebad_finish ();
6924 }
6925 ffebld_end_list (&ffeexpr_stack_->bottom);
6926 ffeexpr_stack_->expr = ffebld_new_any ();
6927 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
6928 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
6929 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
6930 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
6931 }
6932
6933 return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
6934 }
6935
6936 /* ffeexpr_cb_comma_i_1_ -- OPEN_PAREN expr
6937
6938 Pass it to ffeexpr_rhs as the callback routine.
6939
6940 Handle first item in an implied-DO construct. */
6941
6942 static ffelexHandler
6943 ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr, ffelexToken t)
6944 {
6945 ffeexprContext ctxi;
6946 ffeexprContext ctxc;
6947
6948 switch (ffeexpr_stack_->context)
6949 {
6950 case FFEEXPR_contextDATA:
6951 case FFEEXPR_contextDATAIMPDOITEM_:
6952 ctxi = FFEEXPR_contextDATAIMPDOITEM_;
6953 ctxc = FFEEXPR_contextDATAIMPDOCTRL_;
6954 break;
6955
6956 case FFEEXPR_contextIOLIST:
6957 case FFEEXPR_contextIMPDOITEM_:
6958 ctxi = FFEEXPR_contextIMPDOITEM_;
6959 ctxc = FFEEXPR_contextIMPDOCTRL_;
6960 break;
6961
6962 case FFEEXPR_contextIOLISTDF:
6963 case FFEEXPR_contextIMPDOITEMDF_:
6964 ctxi = FFEEXPR_contextIMPDOITEMDF_;
6965 ctxc = FFEEXPR_contextIMPDOCTRL_;
6966 break;
6967
6968 default:
6969 assert ("bad context" == NULL);
6970 ctxi = FFEEXPR_context;
6971 ctxc = FFEEXPR_context;
6972 break;
6973 }
6974
6975 switch (ffelex_token_type (t))
6976 {
6977 case FFELEX_typeCOMMA:
6978 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
6979 if (ffeexpr_stack_->is_rhs)
6980 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
6981 ctxi, ffeexpr_cb_comma_i_1_);
6982 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
6983 ctxi, ffeexpr_cb_comma_i_1_);
6984
6985 case FFELEX_typeEQUALS:
6986 ffebld_end_list (&ffeexpr_stack_->bottom);
6987
6988 /* Complain if implied-DO variable in list of items to be read. */
6989
6990 if ((ctxc == FFEEXPR_contextIMPDOCTRL_) && !ffeexpr_stack_->is_rhs)
6991 ffeexpr_check_impdo_ (ffeexpr_stack_->expr,
6992 ffeexpr_stack_->first_token, expr, ft);
6993
6994 /* Set doiter flag for all appropriate SYMTERs. */
6995
6996 ffeexpr_update_impdo_ (ffeexpr_stack_->expr, expr);
6997
6998 ffeexpr_stack_->expr = ffebld_new_impdo (ffeexpr_stack_->expr, NULL);
6999 ffebld_set_info (ffeexpr_stack_->expr,
7000 ffeinfo_new (FFEINFO_basictypeNONE,
7001 FFEINFO_kindtypeNONE,
7002 0,
7003 FFEINFO_kindNONE,
7004 FFEINFO_whereNONE,
7005 FFETARGET_charactersizeNONE));
7006 ffebld_init_list (&(ffebld_right (ffeexpr_stack_->expr)),
7007 &ffeexpr_stack_->bottom);
7008 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7009 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7010 ctxc, ffeexpr_cb_comma_i_2_);
7011
7012 default:
7013 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7014 {
7015 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7016 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7017 ffelex_token_where_column (ffeexpr_stack_->first_token));
7018 ffebad_finish ();
7019 }
7020 ffebld_end_list (&ffeexpr_stack_->bottom);
7021 ffeexpr_stack_->expr = ffebld_new_any ();
7022 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7023 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7024 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7025 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7026 }
7027 }
7028
7029 /* ffeexpr_cb_comma_i_2_ -- OPEN_PAREN expr-list EQUALS expr
7030
7031 Pass it to ffeexpr_rhs as the callback routine.
7032
7033 Handle start-value in an implied-DO construct. */
7034
7035 static ffelexHandler
7036 ffeexpr_cb_comma_i_2_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7037 {
7038 ffeexprContext ctx;
7039
7040 switch (ffeexpr_stack_->context)
7041 {
7042 case FFEEXPR_contextDATA:
7043 case FFEEXPR_contextDATAIMPDOITEM_:
7044 ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7045 break;
7046
7047 case FFEEXPR_contextIOLIST:
7048 case FFEEXPR_contextIOLISTDF:
7049 case FFEEXPR_contextIMPDOITEM_:
7050 case FFEEXPR_contextIMPDOITEMDF_:
7051 ctx = FFEEXPR_contextIMPDOCTRL_;
7052 break;
7053
7054 default:
7055 assert ("bad context" == NULL);
7056 ctx = FFEEXPR_context;
7057 break;
7058 }
7059
7060 switch (ffelex_token_type (t))
7061 {
7062 case FFELEX_typeCOMMA:
7063 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7064 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7065 ctx, ffeexpr_cb_comma_i_3_);
7066 break;
7067
7068 default:
7069 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7070 {
7071 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7072 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7073 ffelex_token_where_column (ffeexpr_stack_->first_token));
7074 ffebad_finish ();
7075 }
7076 ffebld_end_list (&ffeexpr_stack_->bottom);
7077 ffeexpr_stack_->expr = ffebld_new_any ();
7078 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7079 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7080 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7081 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7082 }
7083 }
7084
7085 /* ffeexpr_cb_comma_i_3_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7086
7087 Pass it to ffeexpr_rhs as the callback routine.
7088
7089 Handle end-value in an implied-DO construct. */
7090
7091 static ffelexHandler
7092 ffeexpr_cb_comma_i_3_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7093 {
7094 ffeexprContext ctx;
7095
7096 switch (ffeexpr_stack_->context)
7097 {
7098 case FFEEXPR_contextDATA:
7099 case FFEEXPR_contextDATAIMPDOITEM_:
7100 ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7101 break;
7102
7103 case FFEEXPR_contextIOLIST:
7104 case FFEEXPR_contextIOLISTDF:
7105 case FFEEXPR_contextIMPDOITEM_:
7106 case FFEEXPR_contextIMPDOITEMDF_:
7107 ctx = FFEEXPR_contextIMPDOCTRL_;
7108 break;
7109
7110 default:
7111 assert ("bad context" == NULL);
7112 ctx = FFEEXPR_context;
7113 break;
7114 }
7115
7116 switch (ffelex_token_type (t))
7117 {
7118 case FFELEX_typeCOMMA:
7119 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7120 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7121 ctx, ffeexpr_cb_comma_i_4_);
7122 break;
7123
7124 case FFELEX_typeCLOSE_PAREN:
7125 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7126 return (ffelexHandler) ffeexpr_cb_comma_i_4_ (NULL, NULL, t);
7127 break;
7128
7129 default:
7130 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7131 {
7132 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7133 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7134 ffelex_token_where_column (ffeexpr_stack_->first_token));
7135 ffebad_finish ();
7136 }
7137 ffebld_end_list (&ffeexpr_stack_->bottom);
7138 ffeexpr_stack_->expr = ffebld_new_any ();
7139 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7140 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7141 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7142 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7143 }
7144 }
7145
7146 /* ffeexpr_cb_comma_i_4_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7147 [COMMA expr]
7148
7149 Pass it to ffeexpr_rhs as the callback routine.
7150
7151 Handle incr-value in an implied-DO construct. */
7152
7153 static ffelexHandler
7154 ffeexpr_cb_comma_i_4_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7155 {
7156 switch (ffelex_token_type (t))
7157 {
7158 case FFELEX_typeCLOSE_PAREN:
7159 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7160 ffebld_end_list (&ffeexpr_stack_->bottom);
7161 {
7162 ffebld item;
7163
7164 for (item = ffebld_left (ffeexpr_stack_->expr);
7165 item != NULL;
7166 item = ffebld_trail (item))
7167 if (ffebld_op (ffebld_head (item)) == FFEBLD_opANY)
7168 goto replace_with_any; /* :::::::::::::::::::: */
7169
7170 for (item = ffebld_right (ffeexpr_stack_->expr);
7171 item != NULL;
7172 item = ffebld_trail (item))
7173 if ((ffebld_head (item) != NULL) /* Increment may be NULL. */
7174 && (ffebld_op (ffebld_head (item)) == FFEBLD_opANY))
7175 goto replace_with_any; /* :::::::::::::::::::: */
7176 }
7177 break;
7178
7179 default:
7180 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7181 {
7182 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7183 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7184 ffelex_token_where_column (ffeexpr_stack_->first_token));
7185 ffebad_finish ();
7186 }
7187 ffebld_end_list (&ffeexpr_stack_->bottom);
7188
7189 replace_with_any: /* :::::::::::::::::::: */
7190
7191 ffeexpr_stack_->expr = ffebld_new_any ();
7192 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7193 break;
7194 }
7195
7196 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7197 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7198 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7199 }
7200
7201 /* ffeexpr_cb_comma_i_5_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7202 [COMMA expr] CLOSE_PAREN
7203
7204 Pass it to ffeexpr_rhs as the callback routine.
7205
7206 Collects token following implied-DO construct for callback function. */
7207
7208 static ffelexHandler
7209 ffeexpr_cb_comma_i_5_ (ffelexToken t)
7210 {
7211 ffeexprCallback callback;
7212 ffeexprStack_ s;
7213 ffelexHandler next;
7214 ffelexToken ft;
7215 ffebld expr;
7216 bool terminate;
7217
7218 switch (ffeexpr_stack_->context)
7219 {
7220 case FFEEXPR_contextDATA:
7221 case FFEEXPR_contextDATAIMPDOITEM_:
7222 terminate = TRUE;
7223 break;
7224
7225 case FFEEXPR_contextIOLIST:
7226 case FFEEXPR_contextIOLISTDF:
7227 case FFEEXPR_contextIMPDOITEM_:
7228 case FFEEXPR_contextIMPDOITEMDF_:
7229 terminate = FALSE;
7230 break;
7231
7232 default:
7233 assert ("bad context" == NULL);
7234 terminate = FALSE;
7235 break;
7236 }
7237
7238 ffebld_pool_pop ();
7239 callback = ffeexpr_stack_->callback;
7240 ft = ffeexpr_stack_->first_token;
7241 expr = ffeexpr_stack_->expr;
7242 s = ffeexpr_stack_->previous;
7243 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
7244 sizeof (*ffeexpr_stack_));
7245 ffeexpr_stack_ = s;
7246 next = (ffelexHandler) (*callback) (ft, expr, t);
7247 ffelex_token_kill (ft);
7248 if (terminate)
7249 {
7250 ffesymbol_drive_sfnames (ffeexpr_check_impctrl_);
7251 --ffeexpr_level_;
7252 if (ffeexpr_level_ == 0)
7253 ffe_terminate_4 ();
7254 }
7255 return (ffelexHandler) next;
7256 }
7257
7258 /* ffeexpr_cb_end_loc_ -- Handle end of %LOC subexpression
7259
7260 Makes sure the end token is close-paren and swallows it, else issues
7261 an error message and doesn't swallow the token (passing it along instead).
7262 In either case wraps up subexpression construction by enclosing the
7263 ffebld expression in a %LOC. */
7264
7265 static ffelexHandler
7266 ffeexpr_cb_end_loc_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7267 {
7268 ffeexprExpr_ e;
7269
7270 /* First push the (%LOC) expression as an operand onto the expression
7271 stack. */
7272
7273 e = ffeexpr_expr_new_ ();
7274 e->type = FFEEXPR_exprtypeOPERAND_;
7275 e->token = ffeexpr_stack_->tokens[0];
7276 e->u.operand = ffebld_new_percent_loc (expr);
7277 ffebld_set_info (e->u.operand,
7278 ffeinfo_new (FFEINFO_basictypeINTEGER,
7279 ffecom_pointer_kind (),
7280 0,
7281 FFEINFO_kindENTITY,
7282 FFEINFO_whereFLEETING,
7283 FFETARGET_charactersizeNONE));
7284 #if 0 /* ~~ */
7285 e->u.operand = ffeexpr_collapse_percent_loc (e->u.operand, ft);
7286 #endif
7287 ffeexpr_exprstack_push_operand_ (e);
7288
7289 /* Now, if the token is a close parenthese, we're in great shape so return
7290 the next handler. */
7291
7292 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7293 {
7294 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7295 return (ffelexHandler) ffeexpr_token_binary_;
7296 }
7297
7298 /* Oops, naughty user didn't specify the close paren! */
7299
7300 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7301 {
7302 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7303 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
7304 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
7305 ffebad_finish ();
7306 }
7307
7308 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7309 return
7310 (ffelexHandler) ffeexpr_find_close_paren_ (t,
7311 (ffelexHandler)
7312 ffeexpr_token_binary_);
7313 }
7314
7315 /* ffeexpr_cb_end_notloc_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
7316
7317 Should be CLOSE_PAREN, and make sure expr isn't a %(VAL,REF,DESCR). */
7318
7319 static ffelexHandler
7320 ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr, ffelexToken t)
7321 {
7322 ffeexprExpr_ e;
7323 ffebldOp op;
7324
7325 /* If expression is itself a %(VAL,REF,DESCR), complain and strip off all
7326 such things until the lowest-level expression is reached. */
7327
7328 op = ffebld_op (expr);
7329 if ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
7330 || (op == FFEBLD_opPERCENT_DESCR))
7331 {
7332 if (ffebad_start (FFEBAD_NESTED_PERCENT))
7333 {
7334 ffebad_here (0, ffelex_token_where_line (ft),
7335 ffelex_token_where_column (ft));
7336 ffebad_finish ();
7337 }
7338
7339 do
7340 {
7341 expr = ffebld_left (expr);
7342 op = ffebld_op (expr);
7343 }
7344 while ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
7345 || (op == FFEBLD_opPERCENT_DESCR));
7346 }
7347
7348 /* Push the expression as an operand onto the expression stack. */
7349
7350 e = ffeexpr_expr_new_ ();
7351 e->type = FFEEXPR_exprtypeOPERAND_;
7352 e->token = ffeexpr_stack_->tokens[0];
7353 switch (ffeexpr_stack_->percent)
7354 {
7355 case FFEEXPR_percentVAL_:
7356 e->u.operand = ffebld_new_percent_val (expr);
7357 break;
7358
7359 case FFEEXPR_percentREF_:
7360 e->u.operand = ffebld_new_percent_ref (expr);
7361 break;
7362
7363 case FFEEXPR_percentDESCR_:
7364 e->u.operand = ffebld_new_percent_descr (expr);
7365 break;
7366
7367 default:
7368 assert ("%lossage" == NULL);
7369 e->u.operand = expr;
7370 break;
7371 }
7372 ffebld_set_info (e->u.operand, ffebld_info (expr));
7373 #if 0 /* ~~ */
7374 e->u.operand = ffeexpr_collapse_percent_ ? ? ? (e->u.operand, ft);
7375 #endif
7376 ffeexpr_exprstack_push_operand_ (e);
7377
7378 /* Now, if the token is a close parenthese, we're in great shape so return
7379 the next handler. */
7380
7381 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7382 return (ffelexHandler) ffeexpr_cb_end_notloc_1_;
7383
7384 /* Oops, naughty user didn't specify the close paren! */
7385
7386 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7387 {
7388 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7389 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
7390 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
7391 ffebad_finish ();
7392 }
7393
7394 ffebld_set_op (e->u.operand, FFEBLD_opPERCENT_LOC);
7395
7396 switch (ffeexpr_stack_->context)
7397 {
7398 case FFEEXPR_contextACTUALARG_:
7399 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
7400 break;
7401
7402 case FFEEXPR_contextINDEXORACTUALARG_:
7403 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
7404 break;
7405
7406 case FFEEXPR_contextSFUNCDEFACTUALARG_:
7407 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
7408 break;
7409
7410 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
7411 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
7412 break;
7413
7414 default:
7415 assert ("bad context?!?!" == NULL);
7416 break;
7417 }
7418
7419 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7420 return
7421 (ffelexHandler) ffeexpr_find_close_paren_ (t,
7422 (ffelexHandler)
7423 ffeexpr_cb_end_notloc_1_);
7424 }
7425
7426 /* ffeexpr_cb_end_notloc_1_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
7427 CLOSE_PAREN
7428
7429 Should be COMMA or CLOSE_PAREN, else change back to %LOC. */
7430
7431 static ffelexHandler
7432 ffeexpr_cb_end_notloc_1_ (ffelexToken t)
7433 {
7434 switch (ffelex_token_type (t))
7435 {
7436 case FFELEX_typeCOMMA:
7437 case FFELEX_typeCLOSE_PAREN:
7438 switch (ffeexpr_stack_->context)
7439 {
7440 case FFEEXPR_contextACTUALARG_:
7441 case FFEEXPR_contextSFUNCDEFACTUALARG_:
7442 break;
7443
7444 case FFEEXPR_contextINDEXORACTUALARG_:
7445 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
7446 break;
7447
7448 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
7449 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
7450 break;
7451
7452 default:
7453 assert ("bad context?!?!" == NULL);
7454 break;
7455 }
7456 break;
7457
7458 default:
7459 if (ffebad_start (FFEBAD_INVALID_PERCENT))
7460 {
7461 ffebad_here (0,
7462 ffelex_token_where_line (ffeexpr_stack_->first_token),
7463 ffelex_token_where_column (ffeexpr_stack_->first_token));
7464 ffebad_string (ffelex_token_text (ffeexpr_stack_->tokens[1]));
7465 ffebad_finish ();
7466 }
7467
7468 ffebld_set_op (ffeexpr_stack_->exprstack->u.operand,
7469 FFEBLD_opPERCENT_LOC);
7470
7471 switch (ffeexpr_stack_->context)
7472 {
7473 case FFEEXPR_contextACTUALARG_:
7474 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
7475 break;
7476
7477 case FFEEXPR_contextINDEXORACTUALARG_:
7478 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
7479 break;
7480
7481 case FFEEXPR_contextSFUNCDEFACTUALARG_:
7482 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
7483 break;
7484
7485 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
7486 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
7487 break;
7488
7489 default:
7490 assert ("bad context?!?!" == NULL);
7491 break;
7492 }
7493 }
7494
7495 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7496 return
7497 (ffelexHandler) ffeexpr_token_binary_ (t);
7498 }
7499
7500 /* Process DATA implied-DO iterator variables as this implied-DO level
7501 terminates. At this point, ffeexpr_level_ == 1 when we see the
7502 last right-paren in "DATA (A(I),I=1,10)/.../". */
7503
7504 static ffesymbol
7505 ffeexpr_check_impctrl_ (ffesymbol s)
7506 {
7507 assert (s != NULL);
7508 assert (ffesymbol_sfdummyparent (s) != NULL);
7509
7510 switch (ffesymbol_state (s))
7511 {
7512 case FFESYMBOL_stateNONE: /* Used as iterator already. Now let symbol
7513 be used as iterator at any level at or
7514 innermore than the outermost of the
7515 current level and the symbol's current
7516 level. */
7517 if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
7518 {
7519 ffesymbol_signal_change (s);
7520 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
7521 ffesymbol_signal_unreported (s);
7522 }
7523 break;
7524
7525 case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO.
7526 Error if at outermost level, else it can
7527 still become an iterator. */
7528 if ((ffeexpr_level_ == 1)
7529 && ffebad_start (FFEBAD_BAD_IMPDCL))
7530 {
7531 ffebad_string (ffesymbol_text (s));
7532 ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
7533 ffebad_finish ();
7534 }
7535 break;
7536
7537 case FFESYMBOL_stateUNCERTAIN: /* Iterator. */
7538 assert (ffeexpr_level_ <= ffesymbol_maxentrynum (s));
7539 ffesymbol_signal_change (s);
7540 ffesymbol_set_state (s, FFESYMBOL_stateNONE);
7541 ffesymbol_signal_unreported (s);
7542 break;
7543
7544 case FFESYMBOL_stateUNDERSTOOD:
7545 break; /* ANY. */
7546
7547 default:
7548 assert ("Sasha Foo!!" == NULL);
7549 break;
7550 }
7551
7552 return s;
7553 }
7554
7555 /* Issue diagnostic if implied-DO variable appears in list of lhs
7556 expressions (as in "READ *, (I,I=1,10)"). */
7557
7558 static void
7559 ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
7560 ffebld dovar, ffelexToken dovar_t)
7561 {
7562 ffebld item;
7563 ffesymbol dovar_sym;
7564 int itemnum;
7565
7566 if (ffebld_op (dovar) != FFEBLD_opSYMTER)
7567 return; /* Presumably opANY. */
7568
7569 dovar_sym = ffebld_symter (dovar);
7570
7571 for (itemnum = 1; list != NULL; list = ffebld_trail (list), ++itemnum)
7572 {
7573 if (((item = ffebld_head (list)) != NULL)
7574 && (ffebld_op (item) == FFEBLD_opSYMTER)
7575 && (ffebld_symter (item) == dovar_sym))
7576 {
7577 char itemno[20];
7578
7579 sprintf (&itemno[0], "%d", itemnum);
7580 if (ffebad_start (FFEBAD_DOITER_IMPDO))
7581 {
7582 ffebad_here (0, ffelex_token_where_line (list_t),
7583 ffelex_token_where_column (list_t));
7584 ffebad_here (1, ffelex_token_where_line (dovar_t),
7585 ffelex_token_where_column (dovar_t));
7586 ffebad_string (ffesymbol_text (dovar_sym));
7587 ffebad_string (itemno);
7588 ffebad_finish ();
7589 }
7590 }
7591 }
7592 }
7593
7594 /* Decorate any SYMTERs referencing the DO variable with the "doiter"
7595 flag. */
7596
7597 static void
7598 ffeexpr_update_impdo_ (ffebld list, ffebld dovar)
7599 {
7600 ffesymbol dovar_sym;
7601
7602 if (ffebld_op (dovar) != FFEBLD_opSYMTER)
7603 return; /* Presumably opANY. */
7604
7605 dovar_sym = ffebld_symter (dovar);
7606
7607 ffeexpr_update_impdo_sym_ (list, dovar_sym); /* Recurse! */
7608 }
7609
7610 /* Recursive function to update any expr so SYMTERs have "doiter" flag
7611 if they refer to the given variable. */
7612
7613 static void
7614 ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar)
7615 {
7616 tail_recurse: /* :::::::::::::::::::: */
7617
7618 if (expr == NULL)
7619 return;
7620
7621 switch (ffebld_op (expr))
7622 {
7623 case FFEBLD_opSYMTER:
7624 if (ffebld_symter (expr) == dovar)
7625 ffebld_symter_set_is_doiter (expr, TRUE);
7626 break;
7627
7628 case FFEBLD_opITEM:
7629 ffeexpr_update_impdo_sym_ (ffebld_head (expr), dovar);
7630 expr = ffebld_trail (expr);
7631 goto tail_recurse; /* :::::::::::::::::::: */
7632
7633 default:
7634 break;
7635 }
7636
7637 switch (ffebld_arity (expr))
7638 {
7639 case 2:
7640 ffeexpr_update_impdo_sym_ (ffebld_left (expr), dovar);
7641 expr = ffebld_right (expr);
7642 goto tail_recurse; /* :::::::::::::::::::: */
7643
7644 case 1:
7645 expr = ffebld_left (expr);
7646 goto tail_recurse; /* :::::::::::::::::::: */
7647
7648 default:
7649 break;
7650 }
7651
7652 return;
7653 }
7654
7655 /* ffeexpr_context_outer_ -- Determine context of stack entry, skipping PARENs
7656
7657 if (ffeexpr_context_outer_(ffeexpr_stack_) == FFEEXPR_contextIF)
7658 // After zero or more PAREN_ contexts, an IF context exists */
7659
7660 static ffeexprContext
7661 ffeexpr_context_outer_ (ffeexprStack_ s)
7662 {
7663 assert (s != NULL);
7664
7665 for (;;)
7666 {
7667 switch (s->context)
7668 {
7669 case FFEEXPR_contextPAREN_:
7670 case FFEEXPR_contextPARENFILENUM_:
7671 case FFEEXPR_contextPARENFILEUNIT_:
7672 break;
7673
7674 default:
7675 return s->context;
7676 }
7677 s = s->previous;
7678 assert (s != NULL);
7679 }
7680 }
7681
7682 /* ffeexpr_percent_ -- Look up name in list of %FOO possibilities
7683
7684 ffeexprPercent_ p;
7685 ffelexToken t;
7686 p = ffeexpr_percent_(t);
7687
7688 Returns the identifier for the name, or the NONE identifier. */
7689
7690 static ffeexprPercent_
7691 ffeexpr_percent_ (ffelexToken t)
7692 {
7693 const char *p;
7694
7695 switch (ffelex_token_length (t))
7696 {
7697 case 3:
7698 switch (*(p = ffelex_token_text (t)))
7699 {
7700 case FFESRC_CASE_MATCH_INIT ('L', 'l', match_3l, no_match_3):
7701 if ((ffesrc_char_match_noninit (*++p, 'O', 'o'))
7702 && (ffesrc_char_match_noninit (*++p, 'C', 'c')))
7703 return FFEEXPR_percentLOC_;
7704 return FFEEXPR_percentNONE_;
7705
7706 case FFESRC_CASE_MATCH_INIT ('R', 'r', match_3r, no_match_3):
7707 if ((ffesrc_char_match_noninit (*++p, 'E', 'e'))
7708 && (ffesrc_char_match_noninit (*++p, 'F', 'f')))
7709 return FFEEXPR_percentREF_;
7710 return FFEEXPR_percentNONE_;
7711
7712 case FFESRC_CASE_MATCH_INIT ('V', 'v', match_3v, no_match_3):
7713 if ((ffesrc_char_match_noninit (*++p, 'A', 'a'))
7714 && (ffesrc_char_match_noninit (*++p, 'L', 'l')))
7715 return FFEEXPR_percentVAL_;
7716 return FFEEXPR_percentNONE_;
7717
7718 default:
7719 no_match_3: /* :::::::::::::::::::: */
7720 return FFEEXPR_percentNONE_;
7721 }
7722
7723 case 5:
7724 if (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "DESCR",
7725 "descr", "Descr") == 0)
7726 return FFEEXPR_percentDESCR_;
7727 return FFEEXPR_percentNONE_;
7728
7729 default:
7730 return FFEEXPR_percentNONE_;
7731 }
7732 }
7733
7734 /* ffeexpr_type_combine -- Binop combine types, check for mythical new COMPLEX
7735
7736 See prototype.
7737
7738 If combining the two basictype/kindtype pairs produces a COMPLEX with an
7739 unsupported kind type, complain and use the default kind type for
7740 COMPLEX. */
7741
7742 void
7743 ffeexpr_type_combine (ffeinfoBasictype *xnbt, ffeinfoKindtype *xnkt,
7744 ffeinfoBasictype lbt, ffeinfoKindtype lkt,
7745 ffeinfoBasictype rbt, ffeinfoKindtype rkt,
7746 ffelexToken t)
7747 {
7748 ffeinfoBasictype nbt;
7749 ffeinfoKindtype nkt;
7750
7751 nbt = ffeinfo_basictype_combine (lbt, rbt);
7752 if ((nbt == FFEINFO_basictypeCOMPLEX)
7753 && ((lbt == nbt) || (lbt == FFEINFO_basictypeREAL))
7754 && ((rbt == nbt) || (rbt == FFEINFO_basictypeREAL)))
7755 {
7756 nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
7757 if (ffe_is_pedantic_not_90 () && (nkt == FFEINFO_kindtypeREALDOUBLE))
7758 nkt = FFEINFO_kindtypeNONE; /* Force error. */
7759 switch (nkt)
7760 {
7761 #if FFETARGET_okCOMPLEX1
7762 case FFEINFO_kindtypeREAL1:
7763 #endif
7764 #if FFETARGET_okCOMPLEX2
7765 case FFEINFO_kindtypeREAL2:
7766 #endif
7767 #if FFETARGET_okCOMPLEX3
7768 case FFEINFO_kindtypeREAL3:
7769 #endif
7770 break; /* Fine and dandy. */
7771
7772 default:
7773 if (t != NULL)
7774 {
7775 ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
7776 ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX);
7777 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7778 ffebad_finish ();
7779 }
7780 nbt = FFEINFO_basictypeNONE;
7781 nkt = FFEINFO_kindtypeNONE;
7782 break;
7783
7784 case FFEINFO_kindtypeANY:
7785 nkt = FFEINFO_kindtypeREALDEFAULT;
7786 break;
7787 }
7788 }
7789 else
7790 { /* The normal stuff. */
7791 if (nbt == lbt)
7792 {
7793 if (nbt == rbt)
7794 nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
7795 else
7796 nkt = lkt;
7797 }
7798 else if (nbt == rbt)
7799 nkt = rkt;
7800 else
7801 { /* Let the caller do the complaining. */
7802 nbt = FFEINFO_basictypeNONE;
7803 nkt = FFEINFO_kindtypeNONE;
7804 }
7805 }
7806
7807 /* Always a good idea to avoid aliasing problems. */
7808
7809 *xnbt = nbt;
7810 *xnkt = nkt;
7811 }
7812
7813 /* ffeexpr_token_first_lhs_ -- First state for lhs expression
7814
7815 Return a pointer to this function to the lexer (ffelex), which will
7816 invoke it for the next token.
7817
7818 Record line and column of first token in expression, then invoke the
7819 initial-state lhs handler. */
7820
7821 static ffelexHandler
7822 ffeexpr_token_first_lhs_ (ffelexToken t)
7823 {
7824 ffeexpr_stack_->first_token = ffelex_token_use (t);
7825
7826 /* When changing the list of valid initial lhs tokens, check whether to
7827 update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
7828 READ (expr) <token> case -- it assumes it knows which tokens <token> can
7829 be to indicate an lhs (or implied DO), which right now is the set
7830 {NAME,OPEN_PAREN}.
7831
7832 This comment also appears in ffeexpr_token_lhs_. */
7833
7834 switch (ffelex_token_type (t))
7835 {
7836 case FFELEX_typeOPEN_PAREN:
7837 switch (ffeexpr_stack_->context)
7838 {
7839 case FFEEXPR_contextDATA:
7840 ffe_init_4 ();
7841 ffeexpr_level_ = 1; /* Level of DATA implied-DO construct. */
7842 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7843 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7844 FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
7845
7846 case FFEEXPR_contextDATAIMPDOITEM_:
7847 ++ffeexpr_level_; /* Level of DATA implied-DO construct. */
7848 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7849 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7850 FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
7851
7852 case FFEEXPR_contextIOLIST:
7853 case FFEEXPR_contextIMPDOITEM_:
7854 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7855 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7856 FFEEXPR_contextIMPDOITEM_, ffeexpr_cb_comma_i_);
7857
7858 case FFEEXPR_contextIOLISTDF:
7859 case FFEEXPR_contextIMPDOITEMDF_:
7860 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7861 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7862 FFEEXPR_contextIMPDOITEMDF_, ffeexpr_cb_comma_i_);
7863
7864 case FFEEXPR_contextFILEEXTFUNC:
7865 assert (ffeexpr_stack_->exprstack == NULL);
7866 return (ffelexHandler) ffeexpr_token_first_lhs_1_;
7867
7868 default:
7869 break;
7870 }
7871 break;
7872
7873 case FFELEX_typeNAME:
7874 switch (ffeexpr_stack_->context)
7875 {
7876 case FFEEXPR_contextFILENAMELIST:
7877 assert (ffeexpr_stack_->exprstack == NULL);
7878 return (ffelexHandler) ffeexpr_token_namelist_;
7879
7880 case FFEEXPR_contextFILEEXTFUNC:
7881 assert (ffeexpr_stack_->exprstack == NULL);
7882 return (ffelexHandler) ffeexpr_token_first_lhs_1_;
7883
7884 default:
7885 break;
7886 }
7887 break;
7888
7889 default:
7890 switch (ffeexpr_stack_->context)
7891 {
7892 case FFEEXPR_contextFILEEXTFUNC:
7893 assert (ffeexpr_stack_->exprstack == NULL);
7894 return (ffelexHandler) ffeexpr_token_first_lhs_1_;
7895
7896 default:
7897 break;
7898 }
7899 break;
7900 }
7901
7902 return (ffelexHandler) ffeexpr_token_lhs_ (t);
7903 }
7904
7905 /* ffeexpr_token_first_lhs_1_ -- NAME
7906
7907 return ffeexpr_token_first_lhs_1_; // to lexer
7908
7909 Handle NAME as an external function (USEROPEN= VXT extension to OPEN
7910 statement). */
7911
7912 static ffelexHandler
7913 ffeexpr_token_first_lhs_1_ (ffelexToken t)
7914 {
7915 ffeexprCallback callback;
7916 ffeexprStack_ s;
7917 ffelexHandler next;
7918 ffelexToken ft;
7919 ffesymbol sy = NULL;
7920 ffebld expr;
7921
7922 ffebld_pool_pop ();
7923 callback = ffeexpr_stack_->callback;
7924 ft = ffeexpr_stack_->first_token;
7925 s = ffeexpr_stack_->previous;
7926
7927 if ((ffelex_token_type (ft) != FFELEX_typeNAME)
7928 || (ffesymbol_attrs (sy = ffeexpr_declare_unadorned_ (ft, FALSE))
7929 & FFESYMBOL_attrANY))
7930 {
7931 if ((ffelex_token_type (ft) != FFELEX_typeNAME)
7932 || !(ffesymbol_attrs (sy) & FFESYMBOL_attrsANY))
7933 {
7934 ffebad_start (FFEBAD_EXPR_WRONG);
7935 ffebad_here (0, ffelex_token_where_line (ft),
7936 ffelex_token_where_column (ft));
7937 ffebad_finish ();
7938 }
7939 expr = ffebld_new_any ();
7940 ffebld_set_info (expr, ffeinfo_new_any ());
7941 }
7942 else
7943 {
7944 expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
7945 FFEINTRIN_impNONE);
7946 ffebld_set_info (expr, ffesymbol_info (sy));
7947 }
7948
7949 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
7950 sizeof (*ffeexpr_stack_));
7951 ffeexpr_stack_ = s;
7952
7953 next = (ffelexHandler) (*callback) (ft, expr, t);
7954 ffelex_token_kill (ft);
7955 return (ffelexHandler) next;
7956 }
7957
7958 /* ffeexpr_token_first_rhs_ -- First state for rhs expression
7959
7960 Record line and column of first token in expression, then invoke the
7961 initial-state rhs handler.
7962
7963 19-Feb-91 JCB 1.1
7964 Allow ASTERISK in PARENFILEUNIT_ case, but only on second level only
7965 (i.e. only as in READ(*), not READ((*))). */
7966
7967 static ffelexHandler
7968 ffeexpr_token_first_rhs_ (ffelexToken t)
7969 {
7970 ffesymbol s;
7971
7972 ffeexpr_stack_->first_token = ffelex_token_use (t);
7973
7974 switch (ffelex_token_type (t))
7975 {
7976 case FFELEX_typeASTERISK:
7977 switch (ffeexpr_stack_->context)
7978 {
7979 case FFEEXPR_contextFILEFORMATNML:
7980 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
7981 /* Fall through. */
7982 case FFEEXPR_contextFILEUNIT:
7983 case FFEEXPR_contextDIMLIST:
7984 case FFEEXPR_contextFILEFORMAT:
7985 case FFEEXPR_contextCHARACTERSIZE:
7986 if (ffeexpr_stack_->previous != NULL)
7987 break; /* Valid only on first level. */
7988 assert (ffeexpr_stack_->exprstack == NULL);
7989 return (ffelexHandler) ffeexpr_token_first_rhs_1_;
7990
7991 case FFEEXPR_contextPARENFILEUNIT_:
7992 if (ffeexpr_stack_->previous->previous != NULL)
7993 break; /* Valid only on second level. */
7994 assert (ffeexpr_stack_->exprstack == NULL);
7995 return (ffelexHandler) ffeexpr_token_first_rhs_1_;
7996
7997 case FFEEXPR_contextACTUALARG_:
7998 if (ffeexpr_stack_->previous->context
7999 != FFEEXPR_contextSUBROUTINEREF)
8000 {
8001 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8002 break;
8003 }
8004 assert (ffeexpr_stack_->exprstack == NULL);
8005 return (ffelexHandler) ffeexpr_token_first_rhs_3_;
8006
8007 case FFEEXPR_contextINDEXORACTUALARG_:
8008 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8009 break;
8010
8011 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8012 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8013 break;
8014
8015 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8016 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8017 break;
8018
8019 default:
8020 break;
8021 }
8022 break;
8023
8024 case FFELEX_typeOPEN_PAREN:
8025 switch (ffeexpr_stack_->context)
8026 {
8027 case FFEEXPR_contextFILENUMAMBIG:
8028 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8029 FFEEXPR_contextPARENFILENUM_,
8030 ffeexpr_cb_close_paren_ambig_);
8031
8032 case FFEEXPR_contextFILEUNITAMBIG:
8033 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8034 FFEEXPR_contextPARENFILEUNIT_,
8035 ffeexpr_cb_close_paren_ambig_);
8036
8037 case FFEEXPR_contextIOLIST:
8038 case FFEEXPR_contextIMPDOITEM_:
8039 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8040 FFEEXPR_contextIMPDOITEM_,
8041 ffeexpr_cb_close_paren_ci_);
8042
8043 case FFEEXPR_contextIOLISTDF:
8044 case FFEEXPR_contextIMPDOITEMDF_:
8045 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8046 FFEEXPR_contextIMPDOITEMDF_,
8047 ffeexpr_cb_close_paren_ci_);
8048
8049 case FFEEXPR_contextFILEFORMATNML:
8050 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8051 break;
8052
8053 case FFEEXPR_contextACTUALARG_:
8054 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8055 break;
8056
8057 case FFEEXPR_contextINDEXORACTUALARG_:
8058 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8059 break;
8060
8061 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8062 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8063 break;
8064
8065 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8066 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8067 break;
8068
8069 default:
8070 break;
8071 }
8072 break;
8073
8074 case FFELEX_typeNUMBER:
8075 switch (ffeexpr_stack_->context)
8076 {
8077 case FFEEXPR_contextFILEFORMATNML:
8078 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8079 /* Fall through. */
8080 case FFEEXPR_contextFILEFORMAT:
8081 if (ffeexpr_stack_->previous != NULL)
8082 break; /* Valid only on first level. */
8083 assert (ffeexpr_stack_->exprstack == NULL);
8084 return (ffelexHandler) ffeexpr_token_first_rhs_2_;
8085
8086 case FFEEXPR_contextACTUALARG_:
8087 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8088 break;
8089
8090 case FFEEXPR_contextINDEXORACTUALARG_:
8091 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8092 break;
8093
8094 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8095 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8096 break;
8097
8098 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8099 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8100 break;
8101
8102 default:
8103 break;
8104 }
8105 break;
8106
8107 case FFELEX_typeNAME:
8108 switch (ffeexpr_stack_->context)
8109 {
8110 case FFEEXPR_contextFILEFORMATNML:
8111 assert (ffeexpr_stack_->exprstack == NULL);
8112 s = ffesymbol_lookup_local (t);
8113 if ((s != NULL) && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST))
8114 return (ffelexHandler) ffeexpr_token_namelist_;
8115 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8116 break;
8117
8118 default:
8119 break;
8120 }
8121 break;
8122
8123 case FFELEX_typePERCENT:
8124 switch (ffeexpr_stack_->context)
8125 {
8126 case FFEEXPR_contextACTUALARG_:
8127 case FFEEXPR_contextINDEXORACTUALARG_:
8128 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8129 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8130 return (ffelexHandler) ffeexpr_token_first_rhs_5_;
8131
8132 case FFEEXPR_contextFILEFORMATNML:
8133 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8134 break;
8135
8136 default:
8137 break;
8138 }
8139
8140 default:
8141 switch (ffeexpr_stack_->context)
8142 {
8143 case FFEEXPR_contextACTUALARG_:
8144 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8145 break;
8146
8147 case FFEEXPR_contextINDEXORACTUALARG_:
8148 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8149 break;
8150
8151 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8152 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8153 break;
8154
8155 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8156 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8157 break;
8158
8159 case FFEEXPR_contextFILEFORMATNML:
8160 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8161 break;
8162
8163 default:
8164 break;
8165 }
8166 break;
8167 }
8168
8169 return (ffelexHandler) ffeexpr_token_rhs_ (t);
8170 }
8171
8172 /* ffeexpr_token_first_rhs_1_ -- ASTERISK
8173
8174 return ffeexpr_token_first_rhs_1_; // to lexer
8175
8176 Return STAR as expression. */
8177
8178 static ffelexHandler
8179 ffeexpr_token_first_rhs_1_ (ffelexToken t)
8180 {
8181 ffebld expr;
8182 ffeexprCallback callback;
8183 ffeexprStack_ s;
8184 ffelexHandler next;
8185 ffelexToken ft;
8186
8187 expr = ffebld_new_star ();
8188 ffebld_pool_pop ();
8189 callback = ffeexpr_stack_->callback;
8190 ft = ffeexpr_stack_->first_token;
8191 s = ffeexpr_stack_->previous;
8192 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
8193 ffeexpr_stack_ = s;
8194 next = (ffelexHandler) (*callback) (ft, expr, t);
8195 ffelex_token_kill (ft);
8196 return (ffelexHandler) next;
8197 }
8198
8199 /* ffeexpr_token_first_rhs_2_ -- NUMBER
8200
8201 return ffeexpr_token_first_rhs_2_; // to lexer
8202
8203 Return NULL as expression; NUMBER as first (and only) token, unless the
8204 current token is not a terminating token, in which case run normal
8205 expression handling. */
8206
8207 static ffelexHandler
8208 ffeexpr_token_first_rhs_2_ (ffelexToken t)
8209 {
8210 ffeexprCallback callback;
8211 ffeexprStack_ s;
8212 ffelexHandler next;
8213 ffelexToken ft;
8214
8215 switch (ffelex_token_type (t))
8216 {
8217 case FFELEX_typeCLOSE_PAREN:
8218 case FFELEX_typeCOMMA:
8219 case FFELEX_typeEOS:
8220 case FFELEX_typeSEMICOLON:
8221 break;
8222
8223 default:
8224 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
8225 return (ffelexHandler) (*next) (t);
8226 }
8227
8228 ffebld_pool_pop ();
8229 callback = ffeexpr_stack_->callback;
8230 ft = ffeexpr_stack_->first_token;
8231 s = ffeexpr_stack_->previous;
8232 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
8233 sizeof (*ffeexpr_stack_));
8234 ffeexpr_stack_ = s;
8235 next = (ffelexHandler) (*callback) (ft, NULL, t);
8236 ffelex_token_kill (ft);
8237 return (ffelexHandler) next;
8238 }
8239
8240 /* ffeexpr_token_first_rhs_3_ -- ASTERISK
8241
8242 return ffeexpr_token_first_rhs_3_; // to lexer
8243
8244 Expect NUMBER, make LABTOK (with copy of token if not inhibited after
8245 confirming, else NULL). */
8246
8247 static ffelexHandler
8248 ffeexpr_token_first_rhs_3_ (ffelexToken t)
8249 {
8250 ffelexHandler next;
8251
8252 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
8253 { /* An error, but let normal processing handle
8254 it. */
8255 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
8256 return (ffelexHandler) (*next) (t);
8257 }
8258
8259 /* Special case: when we see "*10" as an argument to a subroutine
8260 reference, we confirm the current statement and, if not inhibited at
8261 this point, put a copy of the token into a LABTOK node. We do this
8262 instead of just resolving the label directly via ffelab and putting it
8263 into a LABTER simply to improve error reporting and consistency in
8264 ffestc. We put NULL in the LABTOK if we're still inhibited, so ffestb
8265 doesn't have to worry about killing off any tokens when retracting. */
8266
8267 ffest_confirmed ();
8268 if (ffest_is_inhibited ())
8269 ffeexpr_stack_->expr = ffebld_new_labtok (NULL);
8270 else
8271 ffeexpr_stack_->expr = ffebld_new_labtok (ffelex_token_use (t));
8272 ffebld_set_info (ffeexpr_stack_->expr,
8273 ffeinfo_new (FFEINFO_basictypeNONE,
8274 FFEINFO_kindtypeNONE,
8275 0,
8276 FFEINFO_kindNONE,
8277 FFEINFO_whereNONE,
8278 FFETARGET_charactersizeNONE));
8279
8280 return (ffelexHandler) ffeexpr_token_first_rhs_4_;
8281 }
8282
8283 /* ffeexpr_token_first_rhs_4_ -- ASTERISK NUMBER
8284
8285 return ffeexpr_token_first_rhs_4_; // to lexer
8286
8287 Collect/flush appropriate stuff, send token to callback function. */
8288
8289 static ffelexHandler
8290 ffeexpr_token_first_rhs_4_ (ffelexToken t)
8291 {
8292 ffebld expr;
8293 ffeexprCallback callback;
8294 ffeexprStack_ s;
8295 ffelexHandler next;
8296 ffelexToken ft;
8297
8298 expr = ffeexpr_stack_->expr;
8299 ffebld_pool_pop ();
8300 callback = ffeexpr_stack_->callback;
8301 ft = ffeexpr_stack_->first_token;
8302 s = ffeexpr_stack_->previous;
8303 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
8304 ffeexpr_stack_ = s;
8305 next = (ffelexHandler) (*callback) (ft, expr, t);
8306 ffelex_token_kill (ft);
8307 return (ffelexHandler) next;
8308 }
8309
8310 /* ffeexpr_token_first_rhs_5_ -- PERCENT
8311
8312 Should be NAME, or pass through original mechanism. If NAME is LOC,
8313 pass through original mechanism, otherwise must be VAL, REF, or DESCR,
8314 in which case handle the argument (in parentheses), etc. */
8315
8316 static ffelexHandler
8317 ffeexpr_token_first_rhs_5_ (ffelexToken t)
8318 {
8319 ffelexHandler next;
8320
8321 if (ffelex_token_type (t) == FFELEX_typeNAME)
8322 {
8323 ffeexprPercent_ p = ffeexpr_percent_ (t);
8324
8325 switch (p)
8326 {
8327 case FFEEXPR_percentNONE_:
8328 case FFEEXPR_percentLOC_:
8329 break; /* Treat %LOC as any other expression. */
8330
8331 case FFEEXPR_percentVAL_:
8332 case FFEEXPR_percentREF_:
8333 case FFEEXPR_percentDESCR_:
8334 ffeexpr_stack_->percent = p;
8335 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
8336 return (ffelexHandler) ffeexpr_token_first_rhs_6_;
8337
8338 default:
8339 assert ("bad percent?!?" == NULL);
8340 break;
8341 }
8342 }
8343
8344 switch (ffeexpr_stack_->context)
8345 {
8346 case FFEEXPR_contextACTUALARG_:
8347 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8348 break;
8349
8350 case FFEEXPR_contextINDEXORACTUALARG_:
8351 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8352 break;
8353
8354 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8355 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8356 break;
8357
8358 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8359 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8360 break;
8361
8362 default:
8363 assert ("bad context?!?!" == NULL);
8364 break;
8365 }
8366
8367 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
8368 return (ffelexHandler) (*next) (t);
8369 }
8370
8371 /* ffeexpr_token_first_rhs_6_ -- PERCENT NAME(VAL,REF,DESCR)
8372
8373 Should be OPEN_PAREN, or pass through original mechanism. */
8374
8375 static ffelexHandler
8376 ffeexpr_token_first_rhs_6_ (ffelexToken t)
8377 {
8378 ffelexHandler next;
8379 ffelexToken ft;
8380
8381 if (ffelex_token_type (t) == FFELEX_typeOPEN_PAREN)
8382 {
8383 ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
8384 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8385 ffeexpr_stack_->context,
8386 ffeexpr_cb_end_notloc_);
8387 }
8388
8389 switch (ffeexpr_stack_->context)
8390 {
8391 case FFEEXPR_contextACTUALARG_:
8392 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8393 break;
8394
8395 case FFEEXPR_contextINDEXORACTUALARG_:
8396 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8397 break;
8398
8399 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8400 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8401 break;
8402
8403 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8404 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8405 break;
8406
8407 default:
8408 assert ("bad context?!?!" == NULL);
8409 break;
8410 }
8411
8412 ft = ffeexpr_stack_->tokens[0];
8413 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
8414 next = (ffelexHandler) (*next) (ft);
8415 ffelex_token_kill (ft);
8416 return (ffelexHandler) (*next) (t);
8417 }
8418
8419 /* ffeexpr_token_namelist_ -- NAME
8420
8421 return ffeexpr_token_namelist_; // to lexer
8422
8423 Make sure NAME was a valid namelist object, wrap it in a SYMTER and
8424 return. */
8425
8426 static ffelexHandler
8427 ffeexpr_token_namelist_ (ffelexToken t)
8428 {
8429 ffeexprCallback callback;
8430 ffeexprStack_ s;
8431 ffelexHandler next;
8432 ffelexToken ft;
8433 ffesymbol sy;
8434 ffebld expr;
8435
8436 ffebld_pool_pop ();
8437 callback = ffeexpr_stack_->callback;
8438 ft = ffeexpr_stack_->first_token;
8439 s = ffeexpr_stack_->previous;
8440 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
8441 ffeexpr_stack_ = s;
8442
8443 sy = ffesymbol_lookup_local (ft);
8444 if ((sy == NULL) || (ffesymbol_kind (sy) != FFEINFO_kindNAMELIST))
8445 {
8446 ffebad_start (FFEBAD_EXPR_WRONG);
8447 ffebad_here (0, ffelex_token_where_line (ft),
8448 ffelex_token_where_column (ft));
8449 ffebad_finish ();
8450 expr = ffebld_new_any ();
8451 ffebld_set_info (expr, ffeinfo_new_any ());
8452 }
8453 else
8454 {
8455 expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
8456 FFEINTRIN_impNONE);
8457 ffebld_set_info (expr, ffesymbol_info (sy));
8458 }
8459 next = (ffelexHandler) (*callback) (ft, expr, t);
8460 ffelex_token_kill (ft);
8461 return (ffelexHandler) next;
8462 }
8463
8464 /* ffeexpr_expr_kill_ -- Kill an existing internal expression object
8465
8466 ffeexprExpr_ e;
8467 ffeexpr_expr_kill_(e);
8468
8469 Kills the ffewhere info, if necessary, then kills the object. */
8470
8471 static void
8472 ffeexpr_expr_kill_ (ffeexprExpr_ e)
8473 {
8474 if (e->token != NULL)
8475 ffelex_token_kill (e->token);
8476 malloc_kill_ks (ffe_pool_program_unit (), e, sizeof (*e));
8477 }
8478
8479 /* ffeexpr_expr_new_ -- Make a new internal expression object
8480
8481 ffeexprExpr_ e;
8482 e = ffeexpr_expr_new_();
8483
8484 Allocates and initializes a new expression object, returns it. */
8485
8486 static ffeexprExpr_
8487 ffeexpr_expr_new_ (void)
8488 {
8489 ffeexprExpr_ e;
8490
8491 e = (ffeexprExpr_) malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR expr",
8492 sizeof (*e));
8493 e->previous = NULL;
8494 e->type = FFEEXPR_exprtypeUNKNOWN_;
8495 e->token = NULL;
8496 return e;
8497 }
8498
8499 /* Verify that call to global is valid, and register whatever
8500 new information about a global might be discoverable by looking
8501 at the call. */
8502
8503 static void
8504 ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t)
8505 {
8506 int n_args;
8507 ffebld list;
8508 ffebld item;
8509 ffesymbol s;
8510
8511 assert ((ffebld_op (*expr) == FFEBLD_opSUBRREF)
8512 || (ffebld_op (*expr) == FFEBLD_opFUNCREF));
8513
8514 if (ffebld_op (ffebld_left (*expr)) != FFEBLD_opSYMTER)
8515 return;
8516
8517 if (ffesymbol_retractable ())
8518 return;
8519
8520 s = ffebld_symter (ffebld_left (*expr));
8521 if (ffesymbol_global (s) == NULL)
8522 return;
8523
8524 for (n_args = 0, list = ffebld_right (*expr);
8525 list != NULL;
8526 list = ffebld_trail (list), ++n_args)
8527 ;
8528
8529 if (ffeglobal_proc_ref_nargs (s, n_args, t))
8530 {
8531 ffeglobalArgSummary as;
8532 ffeinfoBasictype bt;
8533 ffeinfoKindtype kt;
8534 bool array;
8535 bool fail = FALSE;
8536
8537 for (n_args = 0, list = ffebld_right (*expr);
8538 list != NULL;
8539 list = ffebld_trail (list), ++n_args)
8540 {
8541 item = ffebld_head (list);
8542 if (item != NULL)
8543 {
8544 bt = ffeinfo_basictype (ffebld_info (item));
8545 kt = ffeinfo_kindtype (ffebld_info (item));
8546 array = (ffeinfo_rank (ffebld_info (item)) > 0);
8547 switch (ffebld_op (item))
8548 {
8549 case FFEBLD_opLABTOK:
8550 case FFEBLD_opLABTER:
8551 as = FFEGLOBAL_argsummaryALTRTN;
8552 break;
8553
8554 #if 0
8555 /* No, %LOC(foo) is just like any INTEGER(KIND=7)
8556 expression, so don't treat it specially. */
8557 case FFEBLD_opPERCENT_LOC:
8558 as = FFEGLOBAL_argsummaryPTR;
8559 break;
8560 #endif
8561
8562 case FFEBLD_opPERCENT_VAL:
8563 as = FFEGLOBAL_argsummaryVAL;
8564 break;
8565
8566 case FFEBLD_opPERCENT_REF:
8567 as = FFEGLOBAL_argsummaryREF;
8568 break;
8569
8570 case FFEBLD_opPERCENT_DESCR:
8571 as = FFEGLOBAL_argsummaryDESCR;
8572 break;
8573
8574 case FFEBLD_opFUNCREF:
8575 #if 0
8576 /* No, LOC(foo) is just like any INTEGER(KIND=7)
8577 expression, so don't treat it specially. */
8578 if ((ffebld_op (ffebld_left (item)) == FFEBLD_opSYMTER)
8579 && (ffesymbol_specific (ffebld_symter (ffebld_left (item)))
8580 == FFEINTRIN_specLOC))
8581 {
8582 as = FFEGLOBAL_argsummaryPTR;
8583 break;
8584 }
8585 #endif
8586 /* Fall through. */
8587 default:
8588 if (ffebld_op (item) == FFEBLD_opSYMTER)
8589 {
8590 as = FFEGLOBAL_argsummaryNONE;
8591
8592 switch (ffeinfo_kind (ffebld_info (item)))
8593 {
8594 case FFEINFO_kindFUNCTION:
8595 as = FFEGLOBAL_argsummaryFUNC;
8596 break;
8597
8598 case FFEINFO_kindSUBROUTINE:
8599 as = FFEGLOBAL_argsummarySUBR;
8600 break;
8601
8602 case FFEINFO_kindNONE:
8603 as = FFEGLOBAL_argsummaryPROC;
8604 break;
8605
8606 default:
8607 break;
8608 }
8609
8610 if (as != FFEGLOBAL_argsummaryNONE)
8611 break;
8612 }
8613
8614 if (bt == FFEINFO_basictypeCHARACTER)
8615 as = FFEGLOBAL_argsummaryDESCR;
8616 else
8617 as = FFEGLOBAL_argsummaryREF;
8618 break;
8619 }
8620 }
8621 else
8622 {
8623 array = FALSE;
8624 as = FFEGLOBAL_argsummaryNONE;
8625 bt = FFEINFO_basictypeNONE;
8626 kt = FFEINFO_kindtypeNONE;
8627 }
8628
8629 if (! ffeglobal_proc_ref_arg (s, n_args, as, bt, kt, array, t))
8630 fail = TRUE;
8631 }
8632 if (! fail)
8633 return;
8634 }
8635
8636 *expr = ffebld_new_any ();
8637 ffebld_set_info (*expr, ffeinfo_new_any ());
8638 }
8639
8640 /* Check whether rest of string is all decimal digits. */
8641
8642 static bool
8643 ffeexpr_isdigits_ (const char *p)
8644 {
8645 for (; *p != '\0'; ++p)
8646 if (! ISDIGIT (*p))
8647 return FALSE;
8648 return TRUE;
8649 }
8650
8651 /* ffeexpr_exprstack_push_ -- Push an arbitrary expression object onto the stack
8652
8653 ffeexprExpr_ e;
8654 ffeexpr_exprstack_push_(e);
8655
8656 Pushes the expression onto the stack without any analysis of the existing
8657 contents of the stack. */
8658
8659 static void
8660 ffeexpr_exprstack_push_ (ffeexprExpr_ e)
8661 {
8662 e->previous = ffeexpr_stack_->exprstack;
8663 ffeexpr_stack_->exprstack = e;
8664 }
8665
8666 /* ffeexpr_exprstack_push_operand_ -- Push an operand onto the stack, reduce?
8667
8668 ffeexprExpr_ e;
8669 ffeexpr_exprstack_push_operand_(e);
8670
8671 Pushes the expression already containing an operand (a constant, variable,
8672 or more complicated expression that has already been fully resolved) after
8673 analyzing the stack and checking for possible reduction (which will never
8674 happen here since the highest precedence operator is ** and it has right-
8675 to-left associativity). */
8676
8677 static void
8678 ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e)
8679 {
8680 ffeexpr_exprstack_push_ (e);
8681 }
8682
8683 /* ffeexpr_exprstack_push_unary_ -- Push a unary operator onto the stack
8684
8685 ffeexprExpr_ e;
8686 ffeexpr_exprstack_push_unary_(e);
8687
8688 Pushes the expression already containing a unary operator. Reduction can
8689 never happen since unary operators are themselves always R-L; that is, the
8690 top of the expression stack is not an operand, in that it is either empty,
8691 has a binary operator at the top, or a unary operator at the top. In any
8692 of these cases, reduction is impossible. */
8693
8694 static void
8695 ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e)
8696 {
8697 if ((ffe_is_pedantic ()
8698 || ffe_is_warn_surprising ())
8699 && (ffeexpr_stack_->exprstack != NULL)
8700 && (ffeexpr_stack_->exprstack->type != FFEEXPR_exprtypeOPERAND_)
8701 && (ffeexpr_stack_->exprstack->u.operator.prec
8702 <= FFEEXPR_operatorprecedenceLOWARITH_)
8703 && (e->u.operator.prec <= FFEEXPR_operatorprecedenceLOWARITH_))
8704 {
8705 /* xgettext:no-c-format */
8706 ffebad_start_msg ("Two arithmetic operators in a row at %0 and %1 -- use parentheses",
8707 ffe_is_pedantic ()
8708 ? FFEBAD_severityPEDANTIC
8709 : FFEBAD_severityWARNING);
8710 ffebad_here (0,
8711 ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
8712 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
8713 ffebad_here (1,
8714 ffelex_token_where_line (e->token),
8715 ffelex_token_where_column (e->token));
8716 ffebad_finish ();
8717 }
8718
8719 ffeexpr_exprstack_push_ (e);
8720 }
8721
8722 /* ffeexpr_exprstack_push_binary_ -- Push a binary operator onto the stack, reduce?
8723
8724 ffeexprExpr_ e;
8725 ffeexpr_exprstack_push_binary_(e);
8726
8727 Pushes the expression already containing a binary operator after checking
8728 whether reduction is possible. If the stack is not empty, the top of the
8729 stack must be an operand or syntactic analysis has failed somehow. If
8730 the operand is preceded by a unary operator of higher (or equal and L-R
8731 associativity) precedence than the new binary operator, then reduce that
8732 preceding operator and its operand(s) before pushing the new binary
8733 operator. */
8734
8735 static void
8736 ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e)
8737 {
8738 ffeexprExpr_ ce;
8739
8740 if (ffe_is_warn_surprising ()
8741 /* These next two are always true (see assertions below). */
8742 && (ffeexpr_stack_->exprstack != NULL)
8743 && (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_)
8744 /* If the previous operator is a unary minus, and the binary op
8745 is of higher precedence, might not do what user expects,
8746 e.g. "-2**2" is "-(2**2)", i.e. "-4", not "(-2)**2", which would
8747 yield "4". */
8748 && (ffeexpr_stack_->exprstack->previous != NULL)
8749 && (ffeexpr_stack_->exprstack->previous->type == FFEEXPR_exprtypeUNARY_)
8750 && (ffeexpr_stack_->exprstack->previous->u.operator.op
8751 == FFEEXPR_operatorSUBTRACT_)
8752 && (e->u.operator.prec
8753 < ffeexpr_stack_->exprstack->previous->u.operator.prec))
8754 {
8755 /* xgettext:no-c-format */
8756 ffebad_start_msg ("Operator at %0 has lower precedence than that at %1 -- use parentheses", FFEBAD_severityWARNING);
8757 ffebad_here (0,
8758 ffelex_token_where_line (ffeexpr_stack_->exprstack->previous->token),
8759 ffelex_token_where_column (ffeexpr_stack_->exprstack->previous->token));
8760 ffebad_here (1,
8761 ffelex_token_where_line (e->token),
8762 ffelex_token_where_column (e->token));
8763 ffebad_finish ();
8764 }
8765
8766 again:
8767 assert (ffeexpr_stack_->exprstack != NULL);
8768 assert (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_);
8769 if ((ce = ffeexpr_stack_->exprstack->previous) != NULL)
8770 {
8771 assert (ce->type != FFEEXPR_exprtypeOPERAND_);
8772 if ((ce->u.operator.prec < e->u.operator.prec)
8773 || ((ce->u.operator.prec == e->u.operator.prec)
8774 && (e->u.operator.as == FFEEXPR_operatorassociativityL2R_)))
8775 {
8776 ffeexpr_reduce_ ();
8777 goto again; /* :::::::::::::::::::: */
8778 }
8779 }
8780
8781 ffeexpr_exprstack_push_ (e);
8782 }
8783
8784 /* ffeexpr_reduce_ -- Reduce highest operator w/operands on stack
8785
8786 ffeexpr_reduce_();
8787
8788 Converts operand binop operand or unop operand at top of stack to a
8789 single operand having the appropriate ffebld expression, and makes
8790 sure that the expression is proper (like not trying to add two character
8791 variables, not trying to concatenate two numbers). Also does the
8792 requisite type-assignment. */
8793
8794 static void
8795 ffeexpr_reduce_ (void)
8796 {
8797 ffeexprExpr_ operand; /* This is B in -B or A+B. */
8798 ffeexprExpr_ left_operand; /* When operator is binary, this is A in A+B. */
8799 ffeexprExpr_ operator; /* This is + in A+B. */
8800 ffebld reduced; /* This is +(A,B) in A+B or u-(B) in -B. */
8801 ffebldConstant constnode; /* For checking magical numbers (where mag ==
8802 -mag). */
8803 ffebld expr;
8804 ffebld left_expr;
8805 bool submag = FALSE;
8806
8807 operand = ffeexpr_stack_->exprstack;
8808 assert (operand != NULL);
8809 assert (operand->type == FFEEXPR_exprtypeOPERAND_);
8810 operator = operand->previous;
8811 assert (operator != NULL);
8812 assert (operator->type != FFEEXPR_exprtypeOPERAND_);
8813 if (operator->type == FFEEXPR_exprtypeUNARY_)
8814 {
8815 expr = operand->u.operand;
8816 switch (operator->u.operator.op)
8817 {
8818 case FFEEXPR_operatorADD_:
8819 reduced = ffebld_new_uplus (expr);
8820 if (ffe_is_ugly_logint ())
8821 reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
8822 reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
8823 reduced = ffeexpr_collapse_uplus (reduced, operator->token);
8824 break;
8825
8826 case FFEEXPR_operatorSUBTRACT_:
8827 submag = TRUE; /* Ok to negate a magic number. */
8828 reduced = ffebld_new_uminus (expr);
8829 if (ffe_is_ugly_logint ())
8830 reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
8831 reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
8832 reduced = ffeexpr_collapse_uminus (reduced, operator->token);
8833 break;
8834
8835 case FFEEXPR_operatorNOT_:
8836 reduced = ffebld_new_not (expr);
8837 if (ffe_is_ugly_logint ())
8838 reduced = ffeexpr_reduced_ugly1log_ (reduced, operator, operand);
8839 reduced = ffeexpr_reduced_bool1_ (reduced, operator, operand);
8840 reduced = ffeexpr_collapse_not (reduced, operator->token);
8841 break;
8842
8843 default:
8844 assert ("unexpected unary op" != NULL);
8845 reduced = NULL;
8846 break;
8847 }
8848 if (!submag
8849 && (ffebld_op (expr) == FFEBLD_opCONTER)
8850 && (ffebld_conter_orig (expr) == NULL)
8851 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
8852 {
8853 ffetarget_integer_bad_magical (operand->token);
8854 }
8855 ffeexpr_stack_->exprstack = operator->previous; /* Pops unary-op operand
8856 off stack. */
8857 ffeexpr_expr_kill_ (operand);
8858 operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but
8859 save */
8860 operator->u.operand = reduced; /* the line/column ffewhere info. */
8861 ffeexpr_exprstack_push_operand_ (operator); /* Push it back on
8862 stack. */
8863 }
8864 else
8865 {
8866 assert (operator->type == FFEEXPR_exprtypeBINARY_);
8867 left_operand = operator->previous;
8868 assert (left_operand != NULL);
8869 assert (left_operand->type == FFEEXPR_exprtypeOPERAND_);
8870 expr = operand->u.operand;
8871 left_expr = left_operand->u.operand;
8872 switch (operator->u.operator.op)
8873 {
8874 case FFEEXPR_operatorADD_:
8875 reduced = ffebld_new_add (left_expr, expr);
8876 if (ffe_is_ugly_logint ())
8877 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8878 operand);
8879 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
8880 operand);
8881 reduced = ffeexpr_collapse_add (reduced, operator->token);
8882 break;
8883
8884 case FFEEXPR_operatorSUBTRACT_:
8885 submag = TRUE; /* Just to pick the right error if magic
8886 number. */
8887 reduced = ffebld_new_subtract (left_expr, expr);
8888 if (ffe_is_ugly_logint ())
8889 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8890 operand);
8891 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
8892 operand);
8893 reduced = ffeexpr_collapse_subtract (reduced, operator->token);
8894 break;
8895
8896 case FFEEXPR_operatorMULTIPLY_:
8897 reduced = ffebld_new_multiply (left_expr, expr);
8898 if (ffe_is_ugly_logint ())
8899 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8900 operand);
8901 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
8902 operand);
8903 reduced = ffeexpr_collapse_multiply (reduced, operator->token);
8904 break;
8905
8906 case FFEEXPR_operatorDIVIDE_:
8907 reduced = ffebld_new_divide (left_expr, expr);
8908 if (ffe_is_ugly_logint ())
8909 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8910 operand);
8911 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
8912 operand);
8913 reduced = ffeexpr_collapse_divide (reduced, operator->token);
8914 break;
8915
8916 case FFEEXPR_operatorPOWER_:
8917 reduced = ffebld_new_power (left_expr, expr);
8918 if (ffe_is_ugly_logint ())
8919 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8920 operand);
8921 reduced = ffeexpr_reduced_power_ (reduced, left_operand, operator,
8922 operand);
8923 reduced = ffeexpr_collapse_power (reduced, operator->token);
8924 break;
8925
8926 case FFEEXPR_operatorCONCATENATE_:
8927 reduced = ffebld_new_concatenate (left_expr, expr);
8928 reduced = ffeexpr_reduced_concatenate_ (reduced, left_operand, operator,
8929 operand);
8930 reduced = ffeexpr_collapse_concatenate (reduced, operator->token);
8931 break;
8932
8933 case FFEEXPR_operatorLT_:
8934 reduced = ffebld_new_lt (left_expr, expr);
8935 if (ffe_is_ugly_logint ())
8936 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8937 operand);
8938 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
8939 operand);
8940 reduced = ffeexpr_collapse_lt (reduced, operator->token);
8941 break;
8942
8943 case FFEEXPR_operatorLE_:
8944 reduced = ffebld_new_le (left_expr, expr);
8945 if (ffe_is_ugly_logint ())
8946 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8947 operand);
8948 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
8949 operand);
8950 reduced = ffeexpr_collapse_le (reduced, operator->token);
8951 break;
8952
8953 case FFEEXPR_operatorEQ_:
8954 reduced = ffebld_new_eq (left_expr, expr);
8955 if (ffe_is_ugly_logint ())
8956 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8957 operand);
8958 reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
8959 operand);
8960 reduced = ffeexpr_collapse_eq (reduced, operator->token);
8961 break;
8962
8963 case FFEEXPR_operatorNE_:
8964 reduced = ffebld_new_ne (left_expr, expr);
8965 if (ffe_is_ugly_logint ())
8966 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8967 operand);
8968 reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
8969 operand);
8970 reduced = ffeexpr_collapse_ne (reduced, operator->token);
8971 break;
8972
8973 case FFEEXPR_operatorGT_:
8974 reduced = ffebld_new_gt (left_expr, expr);
8975 if (ffe_is_ugly_logint ())
8976 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8977 operand);
8978 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
8979 operand);
8980 reduced = ffeexpr_collapse_gt (reduced, operator->token);
8981 break;
8982
8983 case FFEEXPR_operatorGE_:
8984 reduced = ffebld_new_ge (left_expr, expr);
8985 if (ffe_is_ugly_logint ())
8986 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8987 operand);
8988 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
8989 operand);
8990 reduced = ffeexpr_collapse_ge (reduced, operator->token);
8991 break;
8992
8993 case FFEEXPR_operatorAND_:
8994 reduced = ffebld_new_and (left_expr, expr);
8995 if (ffe_is_ugly_logint ())
8996 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
8997 operand);
8998 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
8999 operand);
9000 reduced = ffeexpr_collapse_and (reduced, operator->token);
9001 break;
9002
9003 case FFEEXPR_operatorOR_:
9004 reduced = ffebld_new_or (left_expr, expr);
9005 if (ffe_is_ugly_logint ())
9006 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9007 operand);
9008 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9009 operand);
9010 reduced = ffeexpr_collapse_or (reduced, operator->token);
9011 break;
9012
9013 case FFEEXPR_operatorXOR_:
9014 reduced = ffebld_new_xor (left_expr, expr);
9015 if (ffe_is_ugly_logint ())
9016 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9017 operand);
9018 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9019 operand);
9020 reduced = ffeexpr_collapse_xor (reduced, operator->token);
9021 break;
9022
9023 case FFEEXPR_operatorEQV_:
9024 reduced = ffebld_new_eqv (left_expr, expr);
9025 if (ffe_is_ugly_logint ())
9026 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9027 operand);
9028 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9029 operand);
9030 reduced = ffeexpr_collapse_eqv (reduced, operator->token);
9031 break;
9032
9033 case FFEEXPR_operatorNEQV_:
9034 reduced = ffebld_new_neqv (left_expr, expr);
9035 if (ffe_is_ugly_logint ())
9036 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9037 operand);
9038 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9039 operand);
9040 reduced = ffeexpr_collapse_neqv (reduced, operator->token);
9041 break;
9042
9043 default:
9044 assert ("bad bin op" == NULL);
9045 reduced = expr;
9046 break;
9047 }
9048 if ((ffebld_op (left_expr) == FFEBLD_opCONTER)
9049 && (ffebld_conter_orig (expr) == NULL)
9050 && ffebld_constant_is_magical (constnode = ffebld_conter (left_expr)))
9051 {
9052 if ((left_operand->previous != NULL)
9053 && (left_operand->previous->type != FFEEXPR_exprtypeOPERAND_)
9054 && (left_operand->previous->u.operator.op
9055 == FFEEXPR_operatorSUBTRACT_))
9056 {
9057 if (left_operand->previous->type == FFEEXPR_exprtypeUNARY_)
9058 ffetarget_integer_bad_magical_precedence (left_operand->token,
9059 left_operand->previous->token,
9060 operator->token);
9061 else
9062 ffetarget_integer_bad_magical_precedence_binary
9063 (left_operand->token,
9064 left_operand->previous->token,
9065 operator->token);
9066 }
9067 else
9068 ffetarget_integer_bad_magical (left_operand->token);
9069 }
9070 if ((ffebld_op (expr) == FFEBLD_opCONTER)
9071 && (ffebld_conter_orig (expr) == NULL)
9072 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
9073 {
9074 if (submag)
9075 ffetarget_integer_bad_magical_binary (operand->token,
9076 operator->token);
9077 else
9078 ffetarget_integer_bad_magical (operand->token);
9079 }
9080 ffeexpr_stack_->exprstack = left_operand->previous; /* Pops binary-op
9081 operands off stack. */
9082 ffeexpr_expr_kill_ (left_operand);
9083 ffeexpr_expr_kill_ (operand);
9084 operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but
9085 save */
9086 operator->u.operand = reduced; /* the line/column ffewhere info. */
9087 ffeexpr_exprstack_push_operand_ (operator); /* Push it back on
9088 stack. */
9089 }
9090 }
9091
9092 /* ffeexpr_reduced_bool1_ -- Wrap up reduction of NOT operator
9093
9094 reduced = ffeexpr_reduced_bool1_(reduced,op,r);
9095
9096 Makes sure the argument for reduced has basictype of
9097 LOGICAL or (ugly) INTEGER. If
9098 argument has where of CONSTANT, assign where CONSTANT to
9099 reduced, else assign where FLEETING.
9100
9101 If these requirements cannot be met, generate error message. */
9102
9103 static ffebld
9104 ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
9105 {
9106 ffeinfo rinfo, ninfo;
9107 ffeinfoBasictype rbt;
9108 ffeinfoKindtype rkt;
9109 ffeinfoRank rrk;
9110 ffeinfoKind rkd;
9111 ffeinfoWhere rwh, nwh;
9112
9113 rinfo = ffebld_info (ffebld_left (reduced));
9114 rbt = ffeinfo_basictype (rinfo);
9115 rkt = ffeinfo_kindtype (rinfo);
9116 rrk = ffeinfo_rank (rinfo);
9117 rkd = ffeinfo_kind (rinfo);
9118 rwh = ffeinfo_where (rinfo);
9119
9120 if (((rbt == FFEINFO_basictypeLOGICAL)
9121 || (ffe_is_ugly_logint () && (rbt == FFEINFO_basictypeINTEGER)))
9122 && (rrk == 0))
9123 {
9124 switch (rwh)
9125 {
9126 case FFEINFO_whereCONSTANT:
9127 nwh = FFEINFO_whereCONSTANT;
9128 break;
9129
9130 case FFEINFO_whereIMMEDIATE:
9131 nwh = FFEINFO_whereIMMEDIATE;
9132 break;
9133
9134 default:
9135 nwh = FFEINFO_whereFLEETING;
9136 break;
9137 }
9138
9139 ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
9140 FFETARGET_charactersizeNONE);
9141 ffebld_set_info (reduced, ninfo);
9142 return reduced;
9143 }
9144
9145 if ((rbt != FFEINFO_basictypeLOGICAL)
9146 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
9147 {
9148 if ((rbt != FFEINFO_basictypeANY)
9149 && ffebad_start (FFEBAD_NOT_ARG_TYPE))
9150 {
9151 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9152 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9153 ffebad_finish ();
9154 }
9155 }
9156 else
9157 {
9158 if ((rkd != FFEINFO_kindANY)
9159 && ffebad_start (FFEBAD_NOT_ARG_KIND))
9160 {
9161 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9162 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9163 ffebad_string ("an array");
9164 ffebad_finish ();
9165 }
9166 }
9167
9168 reduced = ffebld_new_any ();
9169 ffebld_set_info (reduced, ffeinfo_new_any ());
9170 return reduced;
9171 }
9172
9173 /* ffeexpr_reduced_bool2_ -- Wrap up reduction of boolean operators
9174
9175 reduced = ffeexpr_reduced_bool2_(reduced,l,op,r);
9176
9177 Makes sure the left and right arguments for reduced have basictype of
9178 LOGICAL or (ugly) INTEGER. Determine common basictype and
9179 size for reduction (flag expression for combined hollerith/typeless
9180 situations for later determination of effective basictype). If both left
9181 and right arguments have where of CONSTANT, assign where CONSTANT to
9182 reduced, else assign where FLEETING. Create CONVERT ops for args where
9183 needed. Convert typeless
9184 constants to the desired type/size explicitly.
9185
9186 If these requirements cannot be met, generate error message. */
9187
9188 static ffebld
9189 ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9190 ffeexprExpr_ r)
9191 {
9192 ffeinfo linfo, rinfo, ninfo;
9193 ffeinfoBasictype lbt, rbt, nbt;
9194 ffeinfoKindtype lkt, rkt, nkt;
9195 ffeinfoRank lrk, rrk;
9196 ffeinfoKind lkd, rkd;
9197 ffeinfoWhere lwh, rwh, nwh;
9198
9199 linfo = ffebld_info (ffebld_left (reduced));
9200 lbt = ffeinfo_basictype (linfo);
9201 lkt = ffeinfo_kindtype (linfo);
9202 lrk = ffeinfo_rank (linfo);
9203 lkd = ffeinfo_kind (linfo);
9204 lwh = ffeinfo_where (linfo);
9205
9206 rinfo = ffebld_info (ffebld_right (reduced));
9207 rbt = ffeinfo_basictype (rinfo);
9208 rkt = ffeinfo_kindtype (rinfo);
9209 rrk = ffeinfo_rank (rinfo);
9210 rkd = ffeinfo_kind (rinfo);
9211 rwh = ffeinfo_where (rinfo);
9212
9213 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
9214
9215 if (((nbt == FFEINFO_basictypeLOGICAL)
9216 || (ffe_is_ugly_logint () && (nbt == FFEINFO_basictypeINTEGER)))
9217 && (lrk == 0) && (rrk == 0))
9218 {
9219 switch (lwh)
9220 {
9221 case FFEINFO_whereCONSTANT:
9222 switch (rwh)
9223 {
9224 case FFEINFO_whereCONSTANT:
9225 nwh = FFEINFO_whereCONSTANT;
9226 break;
9227
9228 case FFEINFO_whereIMMEDIATE:
9229 nwh = FFEINFO_whereIMMEDIATE;
9230 break;
9231
9232 default:
9233 nwh = FFEINFO_whereFLEETING;
9234 break;
9235 }
9236 break;
9237
9238 case FFEINFO_whereIMMEDIATE:
9239 switch (rwh)
9240 {
9241 case FFEINFO_whereCONSTANT:
9242 case FFEINFO_whereIMMEDIATE:
9243 nwh = FFEINFO_whereIMMEDIATE;
9244 break;
9245
9246 default:
9247 nwh = FFEINFO_whereFLEETING;
9248 break;
9249 }
9250 break;
9251
9252 default:
9253 nwh = FFEINFO_whereFLEETING;
9254 break;
9255 }
9256
9257 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
9258 FFETARGET_charactersizeNONE);
9259 ffebld_set_info (reduced, ninfo);
9260 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
9261 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
9262 FFEEXPR_contextLET));
9263 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
9264 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
9265 FFEEXPR_contextLET));
9266 return reduced;
9267 }
9268
9269 if ((lbt != FFEINFO_basictypeLOGICAL)
9270 && (!ffe_is_ugly_logint () || (lbt != FFEINFO_basictypeINTEGER)))
9271 {
9272 if ((rbt != FFEINFO_basictypeLOGICAL)
9273 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
9274 {
9275 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
9276 && ffebad_start (FFEBAD_BOOL_ARGS_TYPE))
9277 {
9278 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9279 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9280 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9281 ffebad_finish ();
9282 }
9283 }
9284 else
9285 {
9286 if ((lbt != FFEINFO_basictypeANY)
9287 && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
9288 {
9289 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9290 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9291 ffebad_finish ();
9292 }
9293 }
9294 }
9295 else if ((rbt != FFEINFO_basictypeLOGICAL)
9296 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
9297 {
9298 if ((rbt != FFEINFO_basictypeANY)
9299 && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
9300 {
9301 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9302 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9303 ffebad_finish ();
9304 }
9305 }
9306 else if (lrk != 0)
9307 {
9308 if ((lkd != FFEINFO_kindANY)
9309 && ffebad_start (FFEBAD_BOOL_ARG_KIND))
9310 {
9311 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9312 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9313 ffebad_string ("an array");
9314 ffebad_finish ();
9315 }
9316 }
9317 else
9318 {
9319 if ((rkd != FFEINFO_kindANY)
9320 && ffebad_start (FFEBAD_BOOL_ARG_KIND))
9321 {
9322 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9323 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9324 ffebad_string ("an array");
9325 ffebad_finish ();
9326 }
9327 }
9328
9329 reduced = ffebld_new_any ();
9330 ffebld_set_info (reduced, ffeinfo_new_any ());
9331 return reduced;
9332 }
9333
9334 /* ffeexpr_reduced_concatenate_ -- Wrap up reduction of concatenate operator
9335
9336 reduced = ffeexpr_reduced_concatenate_(reduced,l,op,r);
9337
9338 Makes sure the left and right arguments for reduced have basictype of
9339 CHARACTER and kind of SCALAR, FUNCTION, or STATEMENT FUNCTION. Assign
9340 basictype of CHARACTER and kind of SCALAR to reduced. Calculate effective
9341 size of concatenation and assign that size to reduced. If both left and
9342 right arguments have where of CONSTANT, assign where CONSTANT to reduced,
9343 else assign where FLEETING.
9344
9345 If these requirements cannot be met, generate error message using the
9346 info in l, op, and r arguments and assign basictype, size, kind, and where
9347 of ANY. */
9348
9349 static ffebld
9350 ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9351 ffeexprExpr_ r)
9352 {
9353 ffeinfo linfo, rinfo, ninfo;
9354 ffeinfoBasictype lbt, rbt, nbt;
9355 ffeinfoKindtype lkt, rkt, nkt;
9356 ffeinfoRank lrk, rrk;
9357 ffeinfoKind lkd, rkd, nkd;
9358 ffeinfoWhere lwh, rwh, nwh;
9359 ffetargetCharacterSize lszm, lszk, rszm, rszk, nszk;
9360
9361 linfo = ffebld_info (ffebld_left (reduced));
9362 lbt = ffeinfo_basictype (linfo);
9363 lkt = ffeinfo_kindtype (linfo);
9364 lrk = ffeinfo_rank (linfo);
9365 lkd = ffeinfo_kind (linfo);
9366 lwh = ffeinfo_where (linfo);
9367 lszk = ffeinfo_size (linfo); /* Known size. */
9368 lszm = ffebld_size_max (ffebld_left (reduced));
9369
9370 rinfo = ffebld_info (ffebld_right (reduced));
9371 rbt = ffeinfo_basictype (rinfo);
9372 rkt = ffeinfo_kindtype (rinfo);
9373 rrk = ffeinfo_rank (rinfo);
9374 rkd = ffeinfo_kind (rinfo);
9375 rwh = ffeinfo_where (rinfo);
9376 rszk = ffeinfo_size (rinfo); /* Known size. */
9377 rszm = ffebld_size_max (ffebld_right (reduced));
9378
9379 if ((lbt == FFEINFO_basictypeCHARACTER) && (rbt == FFEINFO_basictypeCHARACTER)
9380 && (lkt == rkt) && (lrk == 0) && (rrk == 0)
9381 && (((lszm != FFETARGET_charactersizeNONE)
9382 && (rszm != FFETARGET_charactersizeNONE))
9383 || (ffeexpr_context_outer_ (ffeexpr_stack_)
9384 == FFEEXPR_contextLET)
9385 || (ffeexpr_context_outer_ (ffeexpr_stack_)
9386 == FFEEXPR_contextSFUNCDEF)))
9387 {
9388 nbt = FFEINFO_basictypeCHARACTER;
9389 nkd = FFEINFO_kindENTITY;
9390 if ((lszk == FFETARGET_charactersizeNONE)
9391 || (rszk == FFETARGET_charactersizeNONE))
9392 nszk = FFETARGET_charactersizeNONE; /* Ok only in rhs of LET
9393 stmt. */
9394 else
9395 nszk = lszk + rszk;
9396
9397 switch (lwh)
9398 {
9399 case FFEINFO_whereCONSTANT:
9400 switch (rwh)
9401 {
9402 case FFEINFO_whereCONSTANT:
9403 nwh = FFEINFO_whereCONSTANT;
9404 break;
9405
9406 case FFEINFO_whereIMMEDIATE:
9407 nwh = FFEINFO_whereIMMEDIATE;
9408 break;
9409
9410 default:
9411 nwh = FFEINFO_whereFLEETING;
9412 break;
9413 }
9414 break;
9415
9416 case FFEINFO_whereIMMEDIATE:
9417 switch (rwh)
9418 {
9419 case FFEINFO_whereCONSTANT:
9420 case FFEINFO_whereIMMEDIATE:
9421 nwh = FFEINFO_whereIMMEDIATE;
9422 break;
9423
9424 default:
9425 nwh = FFEINFO_whereFLEETING;
9426 break;
9427 }
9428 break;
9429
9430 default:
9431 nwh = FFEINFO_whereFLEETING;
9432 break;
9433 }
9434
9435 nkt = lkt;
9436 ninfo = ffeinfo_new (nbt, nkt, 0, nkd, nwh, nszk);
9437 ffebld_set_info (reduced, ninfo);
9438 return reduced;
9439 }
9440
9441 if ((lbt != FFEINFO_basictypeCHARACTER) && (rbt != FFEINFO_basictypeCHARACTER))
9442 {
9443 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
9444 && ffebad_start (FFEBAD_CONCAT_ARGS_TYPE))
9445 {
9446 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9447 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9448 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9449 ffebad_finish ();
9450 }
9451 }
9452 else if (lbt != FFEINFO_basictypeCHARACTER)
9453 {
9454 if ((lbt != FFEINFO_basictypeANY)
9455 && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
9456 {
9457 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9458 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9459 ffebad_finish ();
9460 }
9461 }
9462 else if (rbt != FFEINFO_basictypeCHARACTER)
9463 {
9464 if ((rbt != FFEINFO_basictypeANY)
9465 && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
9466 {
9467 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9468 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9469 ffebad_finish ();
9470 }
9471 }
9472 else if ((lrk != 0) || (lszm == FFETARGET_charactersizeNONE))
9473 {
9474 if ((lkd != FFEINFO_kindANY)
9475 && ffebad_start (FFEBAD_CONCAT_ARG_KIND))
9476 {
9477 const char *what;
9478
9479 if (lrk != 0)
9480 what = "an array";
9481 else
9482 what = "of indeterminate length";
9483 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9484 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9485 ffebad_string (what);
9486 ffebad_finish ();
9487 }
9488 }
9489 else
9490 {
9491 if (ffebad_start (FFEBAD_CONCAT_ARG_KIND))
9492 {
9493 const char *what;
9494
9495 if (rrk != 0)
9496 what = "an array";
9497 else
9498 what = "of indeterminate length";
9499 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9500 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9501 ffebad_string (what);
9502 ffebad_finish ();
9503 }
9504 }
9505
9506 reduced = ffebld_new_any ();
9507 ffebld_set_info (reduced, ffeinfo_new_any ());
9508 return reduced;
9509 }
9510
9511 /* ffeexpr_reduced_eqop2_ -- Wrap up reduction of EQ and NE operators
9512
9513 reduced = ffeexpr_reduced_eqop2_(reduced,l,op,r);
9514
9515 Makes sure the left and right arguments for reduced have basictype of
9516 INTEGER, REAL, COMPLEX, or CHARACTER. Determine common basictype and
9517 size for reduction. If both left
9518 and right arguments have where of CONSTANT, assign where CONSTANT to
9519 reduced, else assign where FLEETING. Create CONVERT ops for args where
9520 needed. Convert typeless
9521 constants to the desired type/size explicitly.
9522
9523 If these requirements cannot be met, generate error message. */
9524
9525 static ffebld
9526 ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9527 ffeexprExpr_ r)
9528 {
9529 ffeinfo linfo, rinfo, ninfo;
9530 ffeinfoBasictype lbt, rbt, nbt;
9531 ffeinfoKindtype lkt, rkt, nkt;
9532 ffeinfoRank lrk, rrk;
9533 ffeinfoKind lkd, rkd;
9534 ffeinfoWhere lwh, rwh, nwh;
9535 ffetargetCharacterSize lsz, rsz;
9536
9537 linfo = ffebld_info (ffebld_left (reduced));
9538 lbt = ffeinfo_basictype (linfo);
9539 lkt = ffeinfo_kindtype (linfo);
9540 lrk = ffeinfo_rank (linfo);
9541 lkd = ffeinfo_kind (linfo);
9542 lwh = ffeinfo_where (linfo);
9543 lsz = ffebld_size_known (ffebld_left (reduced));
9544
9545 rinfo = ffebld_info (ffebld_right (reduced));
9546 rbt = ffeinfo_basictype (rinfo);
9547 rkt = ffeinfo_kindtype (rinfo);
9548 rrk = ffeinfo_rank (rinfo);
9549 rkd = ffeinfo_kind (rinfo);
9550 rwh = ffeinfo_where (rinfo);
9551 rsz = ffebld_size_known (ffebld_right (reduced));
9552
9553 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
9554
9555 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
9556 || (nbt == FFEINFO_basictypeCOMPLEX) || (nbt == FFEINFO_basictypeCHARACTER))
9557 && (lrk == 0) && (rrk == 0))
9558 {
9559 switch (lwh)
9560 {
9561 case FFEINFO_whereCONSTANT:
9562 switch (rwh)
9563 {
9564 case FFEINFO_whereCONSTANT:
9565 nwh = FFEINFO_whereCONSTANT;
9566 break;
9567
9568 case FFEINFO_whereIMMEDIATE:
9569 nwh = FFEINFO_whereIMMEDIATE;
9570 break;
9571
9572 default:
9573 nwh = FFEINFO_whereFLEETING;
9574 break;
9575 }
9576 break;
9577
9578 case FFEINFO_whereIMMEDIATE:
9579 switch (rwh)
9580 {
9581 case FFEINFO_whereCONSTANT:
9582 case FFEINFO_whereIMMEDIATE:
9583 nwh = FFEINFO_whereIMMEDIATE;
9584 break;
9585
9586 default:
9587 nwh = FFEINFO_whereFLEETING;
9588 break;
9589 }
9590 break;
9591
9592 default:
9593 nwh = FFEINFO_whereFLEETING;
9594 break;
9595 }
9596
9597 if ((lsz != FFETARGET_charactersizeNONE)
9598 && (rsz != FFETARGET_charactersizeNONE))
9599 lsz = rsz = (lsz > rsz) ? lsz : rsz;
9600
9601 ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
9602 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
9603 ffebld_set_info (reduced, ninfo);
9604 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
9605 l->token, op->token, nbt, nkt, 0, lsz,
9606 FFEEXPR_contextLET));
9607 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
9608 r->token, op->token, nbt, nkt, 0, rsz,
9609 FFEEXPR_contextLET));
9610 return reduced;
9611 }
9612
9613 if ((lbt == FFEINFO_basictypeLOGICAL)
9614 && (rbt == FFEINFO_basictypeLOGICAL))
9615 {
9616 /* xgettext:no-c-format */
9617 if (ffebad_start_msg ("Use .EQV./.NEQV. instead of .EQ./.NE. at %0 for LOGICAL operands at %1 and %2",
9618 FFEBAD_severityFATAL))
9619 {
9620 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9621 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9622 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9623 ffebad_finish ();
9624 }
9625 }
9626 else if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
9627 && (lbt != FFEINFO_basictypeCOMPLEX) && (lbt != FFEINFO_basictypeCHARACTER))
9628 {
9629 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
9630 && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
9631 {
9632 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
9633 && ffebad_start (FFEBAD_EQOP_ARGS_TYPE))
9634 {
9635 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9636 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9637 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9638 ffebad_finish ();
9639 }
9640 }
9641 else
9642 {
9643 if ((lbt != FFEINFO_basictypeANY)
9644 && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
9645 {
9646 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9647 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9648 ffebad_finish ();
9649 }
9650 }
9651 }
9652 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
9653 && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
9654 {
9655 if ((rbt != FFEINFO_basictypeANY)
9656 && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
9657 {
9658 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9659 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9660 ffebad_finish ();
9661 }
9662 }
9663 else if (lrk != 0)
9664 {
9665 if ((lkd != FFEINFO_kindANY)
9666 && ffebad_start (FFEBAD_EQOP_ARG_KIND))
9667 {
9668 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9669 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9670 ffebad_string ("an array");
9671 ffebad_finish ();
9672 }
9673 }
9674 else
9675 {
9676 if ((rkd != FFEINFO_kindANY)
9677 && ffebad_start (FFEBAD_EQOP_ARG_KIND))
9678 {
9679 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9680 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9681 ffebad_string ("an array");
9682 ffebad_finish ();
9683 }
9684 }
9685
9686 reduced = ffebld_new_any ();
9687 ffebld_set_info (reduced, ffeinfo_new_any ());
9688 return reduced;
9689 }
9690
9691 /* ffeexpr_reduced_math1_ -- Wrap up reduction of + - unary operators
9692
9693 reduced = ffeexpr_reduced_math1_(reduced,op,r);
9694
9695 Makes sure the argument for reduced has basictype of
9696 INTEGER, REAL, or COMPLEX. If the argument has where of CONSTANT,
9697 assign where CONSTANT to
9698 reduced, else assign where FLEETING.
9699
9700 If these requirements cannot be met, generate error message. */
9701
9702 static ffebld
9703 ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
9704 {
9705 ffeinfo rinfo, ninfo;
9706 ffeinfoBasictype rbt;
9707 ffeinfoKindtype rkt;
9708 ffeinfoRank rrk;
9709 ffeinfoKind rkd;
9710 ffeinfoWhere rwh, nwh;
9711
9712 rinfo = ffebld_info (ffebld_left (reduced));
9713 rbt = ffeinfo_basictype (rinfo);
9714 rkt = ffeinfo_kindtype (rinfo);
9715 rrk = ffeinfo_rank (rinfo);
9716 rkd = ffeinfo_kind (rinfo);
9717 rwh = ffeinfo_where (rinfo);
9718
9719 if (((rbt == FFEINFO_basictypeINTEGER) || (rbt == FFEINFO_basictypeREAL)
9720 || (rbt == FFEINFO_basictypeCOMPLEX)) && (rrk == 0))
9721 {
9722 switch (rwh)
9723 {
9724 case FFEINFO_whereCONSTANT:
9725 nwh = FFEINFO_whereCONSTANT;
9726 break;
9727
9728 case FFEINFO_whereIMMEDIATE:
9729 nwh = FFEINFO_whereIMMEDIATE;
9730 break;
9731
9732 default:
9733 nwh = FFEINFO_whereFLEETING;
9734 break;
9735 }
9736
9737 ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
9738 FFETARGET_charactersizeNONE);
9739 ffebld_set_info (reduced, ninfo);
9740 return reduced;
9741 }
9742
9743 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
9744 && (rbt != FFEINFO_basictypeCOMPLEX))
9745 {
9746 if ((rbt != FFEINFO_basictypeANY)
9747 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
9748 {
9749 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9750 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9751 ffebad_finish ();
9752 }
9753 }
9754 else
9755 {
9756 if ((rkd != FFEINFO_kindANY)
9757 && ffebad_start (FFEBAD_MATH_ARG_KIND))
9758 {
9759 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9760 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9761 ffebad_string ("an array");
9762 ffebad_finish ();
9763 }
9764 }
9765
9766 reduced = ffebld_new_any ();
9767 ffebld_set_info (reduced, ffeinfo_new_any ());
9768 return reduced;
9769 }
9770
9771 /* ffeexpr_reduced_math2_ -- Wrap up reduction of + - * / operators
9772
9773 reduced = ffeexpr_reduced_math2_(reduced,l,op,r);
9774
9775 Makes sure the left and right arguments for reduced have basictype of
9776 INTEGER, REAL, or COMPLEX. Determine common basictype and
9777 size for reduction (flag expression for combined hollerith/typeless
9778 situations for later determination of effective basictype). If both left
9779 and right arguments have where of CONSTANT, assign where CONSTANT to
9780 reduced, else assign where FLEETING. Create CONVERT ops for args where
9781 needed. Convert typeless
9782 constants to the desired type/size explicitly.
9783
9784 If these requirements cannot be met, generate error message. */
9785
9786 static ffebld
9787 ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9788 ffeexprExpr_ r)
9789 {
9790 ffeinfo linfo, rinfo, ninfo;
9791 ffeinfoBasictype lbt, rbt, nbt;
9792 ffeinfoKindtype lkt, rkt, nkt;
9793 ffeinfoRank lrk, rrk;
9794 ffeinfoKind lkd, rkd;
9795 ffeinfoWhere lwh, rwh, nwh;
9796
9797 linfo = ffebld_info (ffebld_left (reduced));
9798 lbt = ffeinfo_basictype (linfo);
9799 lkt = ffeinfo_kindtype (linfo);
9800 lrk = ffeinfo_rank (linfo);
9801 lkd = ffeinfo_kind (linfo);
9802 lwh = ffeinfo_where (linfo);
9803
9804 rinfo = ffebld_info (ffebld_right (reduced));
9805 rbt = ffeinfo_basictype (rinfo);
9806 rkt = ffeinfo_kindtype (rinfo);
9807 rrk = ffeinfo_rank (rinfo);
9808 rkd = ffeinfo_kind (rinfo);
9809 rwh = ffeinfo_where (rinfo);
9810
9811 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
9812
9813 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
9814 || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
9815 {
9816 switch (lwh)
9817 {
9818 case FFEINFO_whereCONSTANT:
9819 switch (rwh)
9820 {
9821 case FFEINFO_whereCONSTANT:
9822 nwh = FFEINFO_whereCONSTANT;
9823 break;
9824
9825 case FFEINFO_whereIMMEDIATE:
9826 nwh = FFEINFO_whereIMMEDIATE;
9827 break;
9828
9829 default:
9830 nwh = FFEINFO_whereFLEETING;
9831 break;
9832 }
9833 break;
9834
9835 case FFEINFO_whereIMMEDIATE:
9836 switch (rwh)
9837 {
9838 case FFEINFO_whereCONSTANT:
9839 case FFEINFO_whereIMMEDIATE:
9840 nwh = FFEINFO_whereIMMEDIATE;
9841 break;
9842
9843 default:
9844 nwh = FFEINFO_whereFLEETING;
9845 break;
9846 }
9847 break;
9848
9849 default:
9850 nwh = FFEINFO_whereFLEETING;
9851 break;
9852 }
9853
9854 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
9855 FFETARGET_charactersizeNONE);
9856 ffebld_set_info (reduced, ninfo);
9857 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
9858 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
9859 FFEEXPR_contextLET));
9860 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
9861 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
9862 FFEEXPR_contextLET));
9863 return reduced;
9864 }
9865
9866 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
9867 && (lbt != FFEINFO_basictypeCOMPLEX))
9868 {
9869 if ((rbt != FFEINFO_basictypeINTEGER)
9870 && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
9871 {
9872 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
9873 && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
9874 {
9875 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9876 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9877 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9878 ffebad_finish ();
9879 }
9880 }
9881 else
9882 {
9883 if ((lbt != FFEINFO_basictypeANY)
9884 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
9885 {
9886 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9887 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9888 ffebad_finish ();
9889 }
9890 }
9891 }
9892 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
9893 && (rbt != FFEINFO_basictypeCOMPLEX))
9894 {
9895 if ((rbt != FFEINFO_basictypeANY)
9896 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
9897 {
9898 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9899 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9900 ffebad_finish ();
9901 }
9902 }
9903 else if (lrk != 0)
9904 {
9905 if ((lkd != FFEINFO_kindANY)
9906 && ffebad_start (FFEBAD_MATH_ARG_KIND))
9907 {
9908 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9909 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9910 ffebad_string ("an array");
9911 ffebad_finish ();
9912 }
9913 }
9914 else
9915 {
9916 if ((rkd != FFEINFO_kindANY)
9917 && ffebad_start (FFEBAD_MATH_ARG_KIND))
9918 {
9919 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9920 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9921 ffebad_string ("an array");
9922 ffebad_finish ();
9923 }
9924 }
9925
9926 reduced = ffebld_new_any ();
9927 ffebld_set_info (reduced, ffeinfo_new_any ());
9928 return reduced;
9929 }
9930
9931 /* ffeexpr_reduced_power_ -- Wrap up reduction of ** operator
9932
9933 reduced = ffeexpr_reduced_power_(reduced,l,op,r);
9934
9935 Makes sure the left and right arguments for reduced have basictype of
9936 INTEGER, REAL, or COMPLEX. Determine common basictype and
9937 size for reduction (flag expression for combined hollerith/typeless
9938 situations for later determination of effective basictype). If both left
9939 and right arguments have where of CONSTANT, assign where CONSTANT to
9940 reduced, else assign where FLEETING. Create CONVERT ops for args where
9941 needed. Note that real**int or complex**int
9942 comes out as int = real**int etc with no conversions.
9943
9944 If these requirements cannot be met, generate error message using the
9945 info in l, op, and r arguments and assign basictype, size, kind, and where
9946 of ANY. */
9947
9948 static ffebld
9949 ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9950 ffeexprExpr_ r)
9951 {
9952 ffeinfo linfo, rinfo, ninfo;
9953 ffeinfoBasictype lbt, rbt, nbt;
9954 ffeinfoKindtype lkt, rkt, nkt;
9955 ffeinfoRank lrk, rrk;
9956 ffeinfoKind lkd, rkd;
9957 ffeinfoWhere lwh, rwh, nwh;
9958
9959 linfo = ffebld_info (ffebld_left (reduced));
9960 lbt = ffeinfo_basictype (linfo);
9961 lkt = ffeinfo_kindtype (linfo);
9962 lrk = ffeinfo_rank (linfo);
9963 lkd = ffeinfo_kind (linfo);
9964 lwh = ffeinfo_where (linfo);
9965
9966 rinfo = ffebld_info (ffebld_right (reduced));
9967 rbt = ffeinfo_basictype (rinfo);
9968 rkt = ffeinfo_kindtype (rinfo);
9969 rrk = ffeinfo_rank (rinfo);
9970 rkd = ffeinfo_kind (rinfo);
9971 rwh = ffeinfo_where (rinfo);
9972
9973 if ((rbt == FFEINFO_basictypeINTEGER)
9974 && ((lbt == FFEINFO_basictypeREAL)
9975 || (lbt == FFEINFO_basictypeCOMPLEX)))
9976 {
9977 nbt = lbt;
9978 nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDEFAULT);
9979 if (nkt != FFEINFO_kindtypeREALDEFAULT)
9980 {
9981 nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDOUBLE);
9982 if (nkt != FFEINFO_kindtypeREALDOUBLE)
9983 nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */
9984 }
9985 if (rkt == FFEINFO_kindtypeINTEGER4)
9986 {
9987 /* xgettext:no-c-format */
9988 ffebad_start_msg ("Unsupported operand for ** at %1 -- converting to default INTEGER",
9989 FFEBAD_severityWARNING);
9990 ffebad_here (0, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9991 ffebad_finish ();
9992 }
9993 if (rkt != FFEINFO_kindtypeINTEGERDEFAULT)
9994 {
9995 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
9996 r->token, op->token,
9997 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0,
9998 FFETARGET_charactersizeNONE,
9999 FFEEXPR_contextLET));
10000 rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10001 }
10002 }
10003 else
10004 {
10005 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10006
10007 #if 0 /* INTEGER4**INTEGER4 works now. */
10008 if ((nbt == FFEINFO_basictypeINTEGER)
10009 && (nkt != FFEINFO_kindtypeINTEGERDEFAULT))
10010 nkt = FFEINFO_kindtypeINTEGERDEFAULT; /* Highest kt we can power! */
10011 #endif
10012 if (((nbt == FFEINFO_basictypeREAL)
10013 || (nbt == FFEINFO_basictypeCOMPLEX))
10014 && (nkt != FFEINFO_kindtypeREALDEFAULT))
10015 {
10016 nkt = ffeinfo_kindtype_max (nbt, nkt, FFEINFO_kindtypeREALDOUBLE);
10017 if (nkt != FFEINFO_kindtypeREALDOUBLE)
10018 nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */
10019 }
10020 /* else Gonna turn into an error below. */
10021 }
10022
10023 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10024 || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
10025 {
10026 switch (lwh)
10027 {
10028 case FFEINFO_whereCONSTANT:
10029 switch (rwh)
10030 {
10031 case FFEINFO_whereCONSTANT:
10032 nwh = FFEINFO_whereCONSTANT;
10033 break;
10034
10035 case FFEINFO_whereIMMEDIATE:
10036 nwh = FFEINFO_whereIMMEDIATE;
10037 break;
10038
10039 default:
10040 nwh = FFEINFO_whereFLEETING;
10041 break;
10042 }
10043 break;
10044
10045 case FFEINFO_whereIMMEDIATE:
10046 switch (rwh)
10047 {
10048 case FFEINFO_whereCONSTANT:
10049 case FFEINFO_whereIMMEDIATE:
10050 nwh = FFEINFO_whereIMMEDIATE;
10051 break;
10052
10053 default:
10054 nwh = FFEINFO_whereFLEETING;
10055 break;
10056 }
10057 break;
10058
10059 default:
10060 nwh = FFEINFO_whereFLEETING;
10061 break;
10062 }
10063
10064 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10065 FFETARGET_charactersizeNONE);
10066 ffebld_set_info (reduced, ninfo);
10067 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10068 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10069 FFEEXPR_contextLET));
10070 if (rbt != FFEINFO_basictypeINTEGER)
10071 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10072 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10073 FFEEXPR_contextLET));
10074 return reduced;
10075 }
10076
10077 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10078 && (lbt != FFEINFO_basictypeCOMPLEX))
10079 {
10080 if ((rbt != FFEINFO_basictypeINTEGER)
10081 && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
10082 {
10083 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10084 && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
10085 {
10086 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10087 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10088 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10089 ffebad_finish ();
10090 }
10091 }
10092 else
10093 {
10094 if ((lbt != FFEINFO_basictypeANY)
10095 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10096 {
10097 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10098 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10099 ffebad_finish ();
10100 }
10101 }
10102 }
10103 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10104 && (rbt != FFEINFO_basictypeCOMPLEX))
10105 {
10106 if ((rbt != FFEINFO_basictypeANY)
10107 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10108 {
10109 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10110 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10111 ffebad_finish ();
10112 }
10113 }
10114 else if (lrk != 0)
10115 {
10116 if ((lkd != FFEINFO_kindANY)
10117 && ffebad_start (FFEBAD_MATH_ARG_KIND))
10118 {
10119 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10120 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10121 ffebad_string ("an array");
10122 ffebad_finish ();
10123 }
10124 }
10125 else
10126 {
10127 if ((rkd != FFEINFO_kindANY)
10128 && ffebad_start (FFEBAD_MATH_ARG_KIND))
10129 {
10130 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10131 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10132 ffebad_string ("an array");
10133 ffebad_finish ();
10134 }
10135 }
10136
10137 reduced = ffebld_new_any ();
10138 ffebld_set_info (reduced, ffeinfo_new_any ());
10139 return reduced;
10140 }
10141
10142 /* ffeexpr_reduced_relop2_ -- Wrap up reduction of LT, LE, GE, and GT operators
10143
10144 reduced = ffeexpr_reduced_relop2_(reduced,l,op,r);
10145
10146 Makes sure the left and right arguments for reduced have basictype of
10147 INTEGER, REAL, or CHARACTER. Determine common basictype and
10148 size for reduction. If both left
10149 and right arguments have where of CONSTANT, assign where CONSTANT to
10150 reduced, else assign where FLEETING. Create CONVERT ops for args where
10151 needed. Convert typeless
10152 constants to the desired type/size explicitly.
10153
10154 If these requirements cannot be met, generate error message. */
10155
10156 static ffebld
10157 ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10158 ffeexprExpr_ r)
10159 {
10160 ffeinfo linfo, rinfo, ninfo;
10161 ffeinfoBasictype lbt, rbt, nbt;
10162 ffeinfoKindtype lkt, rkt, nkt;
10163 ffeinfoRank lrk, rrk;
10164 ffeinfoKind lkd, rkd;
10165 ffeinfoWhere lwh, rwh, nwh;
10166 ffetargetCharacterSize lsz, rsz;
10167
10168 linfo = ffebld_info (ffebld_left (reduced));
10169 lbt = ffeinfo_basictype (linfo);
10170 lkt = ffeinfo_kindtype (linfo);
10171 lrk = ffeinfo_rank (linfo);
10172 lkd = ffeinfo_kind (linfo);
10173 lwh = ffeinfo_where (linfo);
10174 lsz = ffebld_size_known (ffebld_left (reduced));
10175
10176 rinfo = ffebld_info (ffebld_right (reduced));
10177 rbt = ffeinfo_basictype (rinfo);
10178 rkt = ffeinfo_kindtype (rinfo);
10179 rrk = ffeinfo_rank (rinfo);
10180 rkd = ffeinfo_kind (rinfo);
10181 rwh = ffeinfo_where (rinfo);
10182 rsz = ffebld_size_known (ffebld_right (reduced));
10183
10184 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10185
10186 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10187 || (nbt == FFEINFO_basictypeCHARACTER))
10188 && (lrk == 0) && (rrk == 0))
10189 {
10190 switch (lwh)
10191 {
10192 case FFEINFO_whereCONSTANT:
10193 switch (rwh)
10194 {
10195 case FFEINFO_whereCONSTANT:
10196 nwh = FFEINFO_whereCONSTANT;
10197 break;
10198
10199 case FFEINFO_whereIMMEDIATE:
10200 nwh = FFEINFO_whereIMMEDIATE;
10201 break;
10202
10203 default:
10204 nwh = FFEINFO_whereFLEETING;
10205 break;
10206 }
10207 break;
10208
10209 case FFEINFO_whereIMMEDIATE:
10210 switch (rwh)
10211 {
10212 case FFEINFO_whereCONSTANT:
10213 case FFEINFO_whereIMMEDIATE:
10214 nwh = FFEINFO_whereIMMEDIATE;
10215 break;
10216
10217 default:
10218 nwh = FFEINFO_whereFLEETING;
10219 break;
10220 }
10221 break;
10222
10223 default:
10224 nwh = FFEINFO_whereFLEETING;
10225 break;
10226 }
10227
10228 if ((lsz != FFETARGET_charactersizeNONE)
10229 && (rsz != FFETARGET_charactersizeNONE))
10230 lsz = rsz = (lsz > rsz) ? lsz : rsz;
10231
10232 ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
10233 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
10234 ffebld_set_info (reduced, ninfo);
10235 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10236 l->token, op->token, nbt, nkt, 0, lsz,
10237 FFEEXPR_contextLET));
10238 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10239 r->token, op->token, nbt, nkt, 0, rsz,
10240 FFEEXPR_contextLET));
10241 return reduced;
10242 }
10243
10244 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10245 && (lbt != FFEINFO_basictypeCHARACTER))
10246 {
10247 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10248 && (rbt != FFEINFO_basictypeCHARACTER))
10249 {
10250 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10251 && ffebad_start (FFEBAD_RELOP_ARGS_TYPE))
10252 {
10253 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10254 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10255 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10256 ffebad_finish ();
10257 }
10258 }
10259 else
10260 {
10261 if ((lbt != FFEINFO_basictypeANY)
10262 && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
10263 {
10264 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10265 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10266 ffebad_finish ();
10267 }
10268 }
10269 }
10270 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10271 && (rbt != FFEINFO_basictypeCHARACTER))
10272 {
10273 if ((rbt != FFEINFO_basictypeANY)
10274 && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
10275 {
10276 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10277 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10278 ffebad_finish ();
10279 }
10280 }
10281 else if (lrk != 0)
10282 {
10283 if ((lkd != FFEINFO_kindANY)
10284 && ffebad_start (FFEBAD_RELOP_ARG_KIND))
10285 {
10286 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10287 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10288 ffebad_string ("an array");
10289 ffebad_finish ();
10290 }
10291 }
10292 else
10293 {
10294 if ((rkd != FFEINFO_kindANY)
10295 && ffebad_start (FFEBAD_RELOP_ARG_KIND))
10296 {
10297 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10298 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10299 ffebad_string ("an array");
10300 ffebad_finish ();
10301 }
10302 }
10303
10304 reduced = ffebld_new_any ();
10305 ffebld_set_info (reduced, ffeinfo_new_any ());
10306 return reduced;
10307 }
10308
10309 /* ffeexpr_reduced_ugly1_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
10310
10311 reduced = ffeexpr_reduced_ugly1_(reduced,op,r);
10312
10313 Sigh. */
10314
10315 static ffebld
10316 ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10317 {
10318 ffeinfo rinfo;
10319 ffeinfoBasictype rbt;
10320 ffeinfoKindtype rkt;
10321 ffeinfoRank rrk;
10322 ffeinfoKind rkd;
10323 ffeinfoWhere rwh;
10324
10325 rinfo = ffebld_info (ffebld_left (reduced));
10326 rbt = ffeinfo_basictype (rinfo);
10327 rkt = ffeinfo_kindtype (rinfo);
10328 rrk = ffeinfo_rank (rinfo);
10329 rkd = ffeinfo_kind (rinfo);
10330 rwh = ffeinfo_where (rinfo);
10331
10332 if ((rbt == FFEINFO_basictypeTYPELESS)
10333 || (rbt == FFEINFO_basictypeHOLLERITH))
10334 {
10335 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10336 r->token, op->token, FFEINFO_basictypeINTEGER,
10337 FFEINFO_kindtypeINTEGERDEFAULT, 0,
10338 FFETARGET_charactersizeNONE,
10339 FFEEXPR_contextLET));
10340 rinfo = ffebld_info (ffebld_left (reduced));
10341 rbt = FFEINFO_basictypeINTEGER;
10342 rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10343 rrk = 0;
10344 rkd = FFEINFO_kindENTITY;
10345 rwh = ffeinfo_where (rinfo);
10346 }
10347
10348 if (rbt == FFEINFO_basictypeLOGICAL)
10349 {
10350 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10351 r->token, op->token, FFEINFO_basictypeINTEGER,
10352 FFEINFO_kindtypeINTEGERDEFAULT, 0,
10353 FFETARGET_charactersizeNONE,
10354 FFEEXPR_contextLET));
10355 }
10356
10357 return reduced;
10358 }
10359
10360 /* ffeexpr_reduced_ugly1log_ -- Deal with TYPELESS and HOLLERITH
10361
10362 reduced = ffeexpr_reduced_ugly1log_(reduced,op,r);
10363
10364 Sigh. */
10365
10366 static ffebld
10367 ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10368 {
10369 ffeinfo rinfo;
10370 ffeinfoBasictype rbt;
10371 ffeinfoKindtype rkt;
10372 ffeinfoRank rrk;
10373 ffeinfoKind rkd;
10374 ffeinfoWhere rwh;
10375
10376 rinfo = ffebld_info (ffebld_left (reduced));
10377 rbt = ffeinfo_basictype (rinfo);
10378 rkt = ffeinfo_kindtype (rinfo);
10379 rrk = ffeinfo_rank (rinfo);
10380 rkd = ffeinfo_kind (rinfo);
10381 rwh = ffeinfo_where (rinfo);
10382
10383 if ((rbt == FFEINFO_basictypeTYPELESS)
10384 || (rbt == FFEINFO_basictypeHOLLERITH))
10385 {
10386 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10387 r->token, op->token, FFEINFO_basictypeLOGICAL, 0,
10388 FFEINFO_kindtypeLOGICALDEFAULT,
10389 FFETARGET_charactersizeNONE,
10390 FFEEXPR_contextLET));
10391 rinfo = ffebld_info (ffebld_left (reduced));
10392 rbt = FFEINFO_basictypeLOGICAL;
10393 rkt = FFEINFO_kindtypeLOGICALDEFAULT;
10394 rrk = 0;
10395 rkd = FFEINFO_kindENTITY;
10396 rwh = ffeinfo_where (rinfo);
10397 }
10398
10399 return reduced;
10400 }
10401
10402 /* ffeexpr_reduced_ugly2_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
10403
10404 reduced = ffeexpr_reduced_ugly2_(reduced,l,op,r);
10405
10406 Sigh. */
10407
10408 static ffebld
10409 ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10410 ffeexprExpr_ r)
10411 {
10412 ffeinfo linfo, rinfo;
10413 ffeinfoBasictype lbt, rbt;
10414 ffeinfoKindtype lkt, rkt;
10415 ffeinfoRank lrk, rrk;
10416 ffeinfoKind lkd, rkd;
10417 ffeinfoWhere lwh, rwh;
10418
10419 linfo = ffebld_info (ffebld_left (reduced));
10420 lbt = ffeinfo_basictype (linfo);
10421 lkt = ffeinfo_kindtype (linfo);
10422 lrk = ffeinfo_rank (linfo);
10423 lkd = ffeinfo_kind (linfo);
10424 lwh = ffeinfo_where (linfo);
10425
10426 rinfo = ffebld_info (ffebld_right (reduced));
10427 rbt = ffeinfo_basictype (rinfo);
10428 rkt = ffeinfo_kindtype (rinfo);
10429 rrk = ffeinfo_rank (rinfo);
10430 rkd = ffeinfo_kind (rinfo);
10431 rwh = ffeinfo_where (rinfo);
10432
10433 if ((lbt == FFEINFO_basictypeTYPELESS)
10434 || (lbt == FFEINFO_basictypeHOLLERITH))
10435 {
10436 if ((rbt == FFEINFO_basictypeTYPELESS)
10437 || (rbt == FFEINFO_basictypeHOLLERITH))
10438 {
10439 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10440 l->token, op->token, FFEINFO_basictypeINTEGER,
10441 FFEINFO_kindtypeINTEGERDEFAULT, 0,
10442 FFETARGET_charactersizeNONE,
10443 FFEEXPR_contextLET));
10444 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10445 r->token, op->token, FFEINFO_basictypeINTEGER, 0,
10446 FFEINFO_kindtypeINTEGERDEFAULT,
10447 FFETARGET_charactersizeNONE,
10448 FFEEXPR_contextLET));
10449 linfo = ffebld_info (ffebld_left (reduced));
10450 rinfo = ffebld_info (ffebld_right (reduced));
10451 lbt = rbt = FFEINFO_basictypeINTEGER;
10452 lkt = rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10453 lrk = rrk = 0;
10454 lkd = rkd = FFEINFO_kindENTITY;
10455 lwh = ffeinfo_where (linfo);
10456 rwh = ffeinfo_where (rinfo);
10457 }
10458 else
10459 {
10460 ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
10461 l->token, ffebld_right (reduced), r->token,
10462 FFEEXPR_contextLET));
10463 linfo = ffebld_info (ffebld_left (reduced));
10464 lbt = ffeinfo_basictype (linfo);
10465 lkt = ffeinfo_kindtype (linfo);
10466 lrk = ffeinfo_rank (linfo);
10467 lkd = ffeinfo_kind (linfo);
10468 lwh = ffeinfo_where (linfo);
10469 }
10470 }
10471 else
10472 {
10473 if ((rbt == FFEINFO_basictypeTYPELESS)
10474 || (rbt == FFEINFO_basictypeHOLLERITH))
10475 {
10476 ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
10477 r->token, ffebld_left (reduced), l->token,
10478 FFEEXPR_contextLET));
10479 rinfo = ffebld_info (ffebld_right (reduced));
10480 rbt = ffeinfo_basictype (rinfo);
10481 rkt = ffeinfo_kindtype (rinfo);
10482 rrk = ffeinfo_rank (rinfo);
10483 rkd = ffeinfo_kind (rinfo);
10484 rwh = ffeinfo_where (rinfo);
10485 }
10486 /* else Leave it alone. */
10487 }
10488
10489 if (lbt == FFEINFO_basictypeLOGICAL)
10490 {
10491 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10492 l->token, op->token, FFEINFO_basictypeINTEGER,
10493 FFEINFO_kindtypeINTEGERDEFAULT, 0,
10494 FFETARGET_charactersizeNONE,
10495 FFEEXPR_contextLET));
10496 }
10497
10498 if (rbt == FFEINFO_basictypeLOGICAL)
10499 {
10500 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10501 r->token, op->token, FFEINFO_basictypeINTEGER,
10502 FFEINFO_kindtypeINTEGERDEFAULT, 0,
10503 FFETARGET_charactersizeNONE,
10504 FFEEXPR_contextLET));
10505 }
10506
10507 return reduced;
10508 }
10509
10510 /* ffeexpr_reduced_ugly2log_ -- Deal with TYPELESS and HOLLERITH
10511
10512 reduced = ffeexpr_reduced_ugly2log_(reduced,l,op,r);
10513
10514 Sigh. */
10515
10516 static ffebld
10517 ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10518 ffeexprExpr_ r)
10519 {
10520 ffeinfo linfo, rinfo;
10521 ffeinfoBasictype lbt, rbt;
10522 ffeinfoKindtype lkt, rkt;
10523 ffeinfoRank lrk, rrk;
10524 ffeinfoKind lkd, rkd;
10525 ffeinfoWhere lwh, rwh;
10526
10527 linfo = ffebld_info (ffebld_left (reduced));
10528 lbt = ffeinfo_basictype (linfo);
10529 lkt = ffeinfo_kindtype (linfo);
10530 lrk = ffeinfo_rank (linfo);
10531 lkd = ffeinfo_kind (linfo);
10532 lwh = ffeinfo_where (linfo);
10533
10534 rinfo = ffebld_info (ffebld_right (reduced));
10535 rbt = ffeinfo_basictype (rinfo);
10536 rkt = ffeinfo_kindtype (rinfo);
10537 rrk = ffeinfo_rank (rinfo);
10538 rkd = ffeinfo_kind (rinfo);
10539 rwh = ffeinfo_where (rinfo);
10540
10541 if ((lbt == FFEINFO_basictypeTYPELESS)
10542 || (lbt == FFEINFO_basictypeHOLLERITH))
10543 {
10544 if ((rbt == FFEINFO_basictypeTYPELESS)
10545 || (rbt == FFEINFO_basictypeHOLLERITH))
10546 {
10547 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10548 l->token, op->token, FFEINFO_basictypeLOGICAL,
10549 FFEINFO_kindtypeLOGICALDEFAULT, 0,
10550 FFETARGET_charactersizeNONE,
10551 FFEEXPR_contextLET));
10552 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10553 r->token, op->token, FFEINFO_basictypeLOGICAL,
10554 FFEINFO_kindtypeLOGICALDEFAULT, 0,
10555 FFETARGET_charactersizeNONE,
10556 FFEEXPR_contextLET));
10557 linfo = ffebld_info (ffebld_left (reduced));
10558 rinfo = ffebld_info (ffebld_right (reduced));
10559 lbt = rbt = FFEINFO_basictypeLOGICAL;
10560 lkt = rkt = FFEINFO_kindtypeLOGICALDEFAULT;
10561 lrk = rrk = 0;
10562 lkd = rkd = FFEINFO_kindENTITY;
10563 lwh = ffeinfo_where (linfo);
10564 rwh = ffeinfo_where (rinfo);
10565 }
10566 else
10567 {
10568 ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
10569 l->token, ffebld_right (reduced), r->token,
10570 FFEEXPR_contextLET));
10571 linfo = ffebld_info (ffebld_left (reduced));
10572 lbt = ffeinfo_basictype (linfo);
10573 lkt = ffeinfo_kindtype (linfo);
10574 lrk = ffeinfo_rank (linfo);
10575 lkd = ffeinfo_kind (linfo);
10576 lwh = ffeinfo_where (linfo);
10577 }
10578 }
10579 else
10580 {
10581 if ((rbt == FFEINFO_basictypeTYPELESS)
10582 || (rbt == FFEINFO_basictypeHOLLERITH))
10583 {
10584 ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
10585 r->token, ffebld_left (reduced), l->token,
10586 FFEEXPR_contextLET));
10587 rinfo = ffebld_info (ffebld_right (reduced));
10588 rbt = ffeinfo_basictype (rinfo);
10589 rkt = ffeinfo_kindtype (rinfo);
10590 rrk = ffeinfo_rank (rinfo);
10591 rkd = ffeinfo_kind (rinfo);
10592 rwh = ffeinfo_where (rinfo);
10593 }
10594 /* else Leave it alone. */
10595 }
10596
10597 if (lbt == FFEINFO_basictypeLOGICAL)
10598 {
10599 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10600 l->token, op->token, FFEINFO_basictypeINTEGER,
10601 FFEINFO_kindtypeINTEGERDEFAULT, 0,
10602 FFETARGET_charactersizeNONE,
10603 FFEEXPR_contextLET));
10604 }
10605
10606 if (rbt == FFEINFO_basictypeLOGICAL)
10607 {
10608 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10609 r->token, op->token, FFEINFO_basictypeINTEGER,
10610 FFEINFO_kindtypeINTEGERDEFAULT, 0,
10611 FFETARGET_charactersizeNONE,
10612 FFEEXPR_contextLET));
10613 }
10614
10615 return reduced;
10616 }
10617
10618 /* Fumble through tokens until a nonmatching CLOSE_PAREN, EOS, or SEMICOLON
10619 is found.
10620
10621 The idea is to process the tokens as they would be done by normal
10622 expression processing, with the key things being telling the lexer
10623 when hollerith/character constants are about to happen, until the
10624 true closing token is found. */
10625
10626 static ffelexHandler
10627 ffeexpr_find_close_paren_ (ffelexToken t,
10628 ffelexHandler after)
10629 {
10630 ffeexpr_find_.after = after;
10631 ffeexpr_find_.level = 1;
10632 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10633 }
10634
10635 static ffelexHandler
10636 ffeexpr_nil_finished_ (ffelexToken t)
10637 {
10638 switch (ffelex_token_type (t))
10639 {
10640 case FFELEX_typeCLOSE_PAREN:
10641 if (--ffeexpr_find_.level == 0)
10642 return (ffelexHandler) ffeexpr_find_.after;
10643 return (ffelexHandler) ffeexpr_nil_binary_;
10644
10645 case FFELEX_typeCOMMA:
10646 case FFELEX_typeCOLON:
10647 case FFELEX_typeEQUALS:
10648 case FFELEX_typePOINTS:
10649 return (ffelexHandler) ffeexpr_nil_rhs_;
10650
10651 default:
10652 if (--ffeexpr_find_.level == 0)
10653 return (ffelexHandler) ffeexpr_find_.after (t);
10654 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10655 }
10656 }
10657
10658 static ffelexHandler
10659 ffeexpr_nil_rhs_ (ffelexToken t)
10660 {
10661 switch (ffelex_token_type (t))
10662 {
10663 case FFELEX_typeQUOTE:
10664 if (ffe_is_vxt ())
10665 return (ffelexHandler) ffeexpr_nil_quote_;
10666 ffelex_set_expecting_hollerith (-1, '\"',
10667 ffelex_token_where_line (t),
10668 ffelex_token_where_column (t));
10669 return (ffelexHandler) ffeexpr_nil_apostrophe_;
10670
10671 case FFELEX_typeAPOSTROPHE:
10672 ffelex_set_expecting_hollerith (-1, '\'',
10673 ffelex_token_where_line (t),
10674 ffelex_token_where_column (t));
10675 return (ffelexHandler) ffeexpr_nil_apostrophe_;
10676
10677 case FFELEX_typePERCENT:
10678 return (ffelexHandler) ffeexpr_nil_percent_;
10679
10680 case FFELEX_typeOPEN_PAREN:
10681 ++ffeexpr_find_.level;
10682 return (ffelexHandler) ffeexpr_nil_rhs_;
10683
10684 case FFELEX_typePLUS:
10685 case FFELEX_typeMINUS:
10686 return (ffelexHandler) ffeexpr_nil_rhs_;
10687
10688 case FFELEX_typePERIOD:
10689 return (ffelexHandler) ffeexpr_nil_period_;
10690
10691 case FFELEX_typeNUMBER:
10692 ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
10693 if (ffeexpr_hollerith_count_ > 0)
10694 ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
10695 '\0',
10696 ffelex_token_where_line (t),
10697 ffelex_token_where_column (t));
10698 return (ffelexHandler) ffeexpr_nil_number_;
10699
10700 case FFELEX_typeNAME:
10701 case FFELEX_typeNAMES:
10702 return (ffelexHandler) ffeexpr_nil_name_rhs_;
10703
10704 case FFELEX_typeASTERISK:
10705 case FFELEX_typeSLASH:
10706 case FFELEX_typePOWER:
10707 case FFELEX_typeCONCAT:
10708 case FFELEX_typeREL_EQ:
10709 case FFELEX_typeREL_NE:
10710 case FFELEX_typeREL_LE:
10711 case FFELEX_typeREL_GE:
10712 return (ffelexHandler) ffeexpr_nil_rhs_;
10713
10714 default:
10715 return (ffelexHandler) ffeexpr_nil_finished_ (t);
10716 }
10717 }
10718
10719 static ffelexHandler
10720 ffeexpr_nil_period_ (ffelexToken t)
10721 {
10722 switch (ffelex_token_type (t))
10723 {
10724 case FFELEX_typeNAME:
10725 case FFELEX_typeNAMES:
10726 ffeexpr_current_dotdot_ = ffestr_other (t);
10727 switch (ffeexpr_current_dotdot_)
10728 {
10729 case FFESTR_otherNone:
10730 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10731
10732 case FFESTR_otherTRUE:
10733 case FFESTR_otherFALSE:
10734 case FFESTR_otherNOT:
10735 return (ffelexHandler) ffeexpr_nil_end_period_;
10736
10737 default:
10738 return (ffelexHandler) ffeexpr_nil_swallow_period_;
10739 }
10740 break; /* Nothing really reaches here. */
10741
10742 case FFELEX_typeNUMBER:
10743 return (ffelexHandler) ffeexpr_nil_real_;
10744
10745 default:
10746 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10747 }
10748 }
10749
10750 static ffelexHandler
10751 ffeexpr_nil_end_period_ (ffelexToken t)
10752 {
10753 switch (ffeexpr_current_dotdot_)
10754 {
10755 case FFESTR_otherNOT:
10756 if (ffelex_token_type (t) != FFELEX_typePERIOD)
10757 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10758 return (ffelexHandler) ffeexpr_nil_rhs_;
10759
10760 case FFESTR_otherTRUE:
10761 case FFESTR_otherFALSE:
10762 if (ffelex_token_type (t) != FFELEX_typePERIOD)
10763 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10764 return (ffelexHandler) ffeexpr_nil_binary_;
10765
10766 default:
10767 assert ("Bad [nil] unary dotdot in ffeexpr_current_dotdot_" == NULL);
10768 exit (0);
10769 return NULL;
10770 }
10771 }
10772
10773 static ffelexHandler
10774 ffeexpr_nil_swallow_period_ (ffelexToken t)
10775 {
10776 if (ffelex_token_type (t) != FFELEX_typePERIOD)
10777 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10778 return (ffelexHandler) ffeexpr_nil_rhs_;
10779 }
10780
10781 static ffelexHandler
10782 ffeexpr_nil_real_ (ffelexToken t)
10783 {
10784 char d;
10785 const char *p;
10786
10787 if (((ffelex_token_type (t) != FFELEX_typeNAME)
10788 && (ffelex_token_type (t) != FFELEX_typeNAMES))
10789 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
10790 'D', 'd')
10791 || ffesrc_char_match_init (d, 'E', 'e')
10792 || ffesrc_char_match_init (d, 'Q', 'q')))
10793 && ffeexpr_isdigits_ (++p)))
10794 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10795
10796 if (*p == '\0')
10797 return (ffelexHandler) ffeexpr_nil_real_exponent_;
10798 return (ffelexHandler) ffeexpr_nil_binary_;
10799 }
10800
10801 static ffelexHandler
10802 ffeexpr_nil_real_exponent_ (ffelexToken t)
10803 {
10804 if ((ffelex_token_type (t) != FFELEX_typePLUS)
10805 && (ffelex_token_type (t) != FFELEX_typeMINUS))
10806 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10807
10808 return (ffelexHandler) ffeexpr_nil_real_exp_sign_;
10809 }
10810
10811 static ffelexHandler
10812 ffeexpr_nil_real_exp_sign_ (ffelexToken t)
10813 {
10814 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
10815 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10816 return (ffelexHandler) ffeexpr_nil_binary_;
10817 }
10818
10819 static ffelexHandler
10820 ffeexpr_nil_number_ (ffelexToken t)
10821 {
10822 char d;
10823 const char *p;
10824
10825 if (ffeexpr_hollerith_count_ > 0)
10826 ffelex_set_expecting_hollerith (0, '\0',
10827 ffewhere_line_unknown (),
10828 ffewhere_column_unknown ());
10829
10830 switch (ffelex_token_type (t))
10831 {
10832 case FFELEX_typeNAME:
10833 case FFELEX_typeNAMES:
10834 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
10835 'D', 'd')
10836 || ffesrc_char_match_init (d, 'E', 'e')
10837 || ffesrc_char_match_init (d, 'Q', 'q'))
10838 && ffeexpr_isdigits_ (++p))
10839 {
10840 if (*p == '\0')
10841 {
10842 ffeexpr_find_.t = ffelex_token_use (t);
10843 return (ffelexHandler) ffeexpr_nil_number_exponent_;
10844 }
10845 return (ffelexHandler) ffeexpr_nil_binary_;
10846 }
10847 break;
10848
10849 case FFELEX_typePERIOD:
10850 ffeexpr_find_.t = ffelex_token_use (t);
10851 return (ffelexHandler) ffeexpr_nil_number_period_;
10852
10853 case FFELEX_typeHOLLERITH:
10854 return (ffelexHandler) ffeexpr_nil_binary_;
10855
10856 default:
10857 break;
10858 }
10859 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10860 }
10861
10862 /* Expects ffeexpr_find_.t. */
10863
10864 static ffelexHandler
10865 ffeexpr_nil_number_exponent_ (ffelexToken t)
10866 {
10867 ffelexHandler nexthandler;
10868
10869 if ((ffelex_token_type (t) != FFELEX_typePLUS)
10870 && (ffelex_token_type (t) != FFELEX_typeMINUS))
10871 {
10872 nexthandler
10873 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
10874 ffelex_token_kill (ffeexpr_find_.t);
10875 return (ffelexHandler) (*nexthandler) (t);
10876 }
10877
10878 ffelex_token_kill (ffeexpr_find_.t);
10879 return (ffelexHandler) ffeexpr_nil_number_exp_sign_;
10880 }
10881
10882 static ffelexHandler
10883 ffeexpr_nil_number_exp_sign_ (ffelexToken t)
10884 {
10885 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
10886 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10887
10888 return (ffelexHandler) ffeexpr_nil_binary_;
10889 }
10890
10891 /* Expects ffeexpr_find_.t. */
10892
10893 static ffelexHandler
10894 ffeexpr_nil_number_period_ (ffelexToken t)
10895 {
10896 ffelexHandler nexthandler;
10897 char d;
10898 const char *p;
10899
10900 switch (ffelex_token_type (t))
10901 {
10902 case FFELEX_typeNAME:
10903 case FFELEX_typeNAMES:
10904 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
10905 'D', 'd')
10906 || ffesrc_char_match_init (d, 'E', 'e')
10907 || ffesrc_char_match_init (d, 'Q', 'q'))
10908 && ffeexpr_isdigits_ (++p))
10909 {
10910 if (*p == '\0')
10911 return (ffelexHandler) ffeexpr_nil_number_per_exp_;
10912 ffelex_token_kill (ffeexpr_find_.t);
10913 return (ffelexHandler) ffeexpr_nil_binary_;
10914 }
10915 nexthandler
10916 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
10917 ffelex_token_kill (ffeexpr_find_.t);
10918 return (ffelexHandler) (*nexthandler) (t);
10919
10920 case FFELEX_typeNUMBER:
10921 ffelex_token_kill (ffeexpr_find_.t);
10922 return (ffelexHandler) ffeexpr_nil_number_real_;
10923
10924 default:
10925 break;
10926 }
10927 ffelex_token_kill (ffeexpr_find_.t);
10928 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10929 }
10930
10931 /* Expects ffeexpr_find_.t. */
10932
10933 static ffelexHandler
10934 ffeexpr_nil_number_per_exp_ (ffelexToken t)
10935 {
10936 if ((ffelex_token_type (t) != FFELEX_typePLUS)
10937 && (ffelex_token_type (t) != FFELEX_typeMINUS))
10938 {
10939 ffelexHandler nexthandler;
10940
10941 nexthandler
10942 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
10943 ffelex_token_kill (ffeexpr_find_.t);
10944 return (ffelexHandler) (*nexthandler) (t);
10945 }
10946
10947 ffelex_token_kill (ffeexpr_find_.t);
10948 return (ffelexHandler) ffeexpr_nil_num_per_exp_sign_;
10949 }
10950
10951 static ffelexHandler
10952 ffeexpr_nil_number_real_ (ffelexToken t)
10953 {
10954 char d;
10955 const char *p;
10956
10957 if (((ffelex_token_type (t) != FFELEX_typeNAME)
10958 && (ffelex_token_type (t) != FFELEX_typeNAMES))
10959 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
10960 'D', 'd')
10961 || ffesrc_char_match_init (d, 'E', 'e')
10962 || ffesrc_char_match_init (d, 'Q', 'q')))
10963 && ffeexpr_isdigits_ (++p)))
10964 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10965
10966 if (*p == '\0')
10967 return (ffelexHandler) ffeexpr_nil_number_real_exp_;
10968
10969 return (ffelexHandler) ffeexpr_nil_binary_;
10970 }
10971
10972 static ffelexHandler
10973 ffeexpr_nil_num_per_exp_sign_ (ffelexToken t)
10974 {
10975 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
10976 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10977 return (ffelexHandler) ffeexpr_nil_binary_;
10978 }
10979
10980 static ffelexHandler
10981 ffeexpr_nil_number_real_exp_ (ffelexToken t)
10982 {
10983 if ((ffelex_token_type (t) != FFELEX_typePLUS)
10984 && (ffelex_token_type (t) != FFELEX_typeMINUS))
10985 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10986 return (ffelexHandler) ffeexpr_nil_num_real_exp_sn_;
10987 }
10988
10989 static ffelexHandler
10990 ffeexpr_nil_num_real_exp_sn_ (ffelexToken t)
10991 {
10992 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
10993 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10994 return (ffelexHandler) ffeexpr_nil_binary_;
10995 }
10996
10997 static ffelexHandler
10998 ffeexpr_nil_binary_ (ffelexToken t)
10999 {
11000 switch (ffelex_token_type (t))
11001 {
11002 case FFELEX_typePLUS:
11003 case FFELEX_typeMINUS:
11004 case FFELEX_typeASTERISK:
11005 case FFELEX_typeSLASH:
11006 case FFELEX_typePOWER:
11007 case FFELEX_typeCONCAT:
11008 case FFELEX_typeOPEN_ANGLE:
11009 case FFELEX_typeCLOSE_ANGLE:
11010 case FFELEX_typeREL_EQ:
11011 case FFELEX_typeREL_NE:
11012 case FFELEX_typeREL_GE:
11013 case FFELEX_typeREL_LE:
11014 return (ffelexHandler) ffeexpr_nil_rhs_;
11015
11016 case FFELEX_typePERIOD:
11017 return (ffelexHandler) ffeexpr_nil_binary_period_;
11018
11019 default:
11020 return (ffelexHandler) ffeexpr_nil_finished_ (t);
11021 }
11022 }
11023
11024 static ffelexHandler
11025 ffeexpr_nil_binary_period_ (ffelexToken t)
11026 {
11027 switch (ffelex_token_type (t))
11028 {
11029 case FFELEX_typeNAME:
11030 case FFELEX_typeNAMES:
11031 ffeexpr_current_dotdot_ = ffestr_other (t);
11032 switch (ffeexpr_current_dotdot_)
11033 {
11034 case FFESTR_otherTRUE:
11035 case FFESTR_otherFALSE:
11036 case FFESTR_otherNOT:
11037 return (ffelexHandler) ffeexpr_nil_binary_sw_per_;
11038
11039 default:
11040 return (ffelexHandler) ffeexpr_nil_binary_end_per_;
11041 }
11042 break; /* Nothing really reaches here. */
11043
11044 default:
11045 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11046 }
11047 }
11048
11049 static ffelexHandler
11050 ffeexpr_nil_binary_end_per_ (ffelexToken t)
11051 {
11052 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11053 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11054 return (ffelexHandler) ffeexpr_nil_rhs_;
11055 }
11056
11057 static ffelexHandler
11058 ffeexpr_nil_binary_sw_per_ (ffelexToken t)
11059 {
11060 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11061 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11062 return (ffelexHandler) ffeexpr_nil_binary_;
11063 }
11064
11065 static ffelexHandler
11066 ffeexpr_nil_quote_ (ffelexToken t)
11067 {
11068 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11069 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11070 return (ffelexHandler) ffeexpr_nil_binary_;
11071 }
11072
11073 static ffelexHandler
11074 ffeexpr_nil_apostrophe_ (ffelexToken t)
11075 {
11076 assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
11077 return (ffelexHandler) ffeexpr_nil_apos_char_;
11078 }
11079
11080 static ffelexHandler
11081 ffeexpr_nil_apos_char_ (ffelexToken t)
11082 {
11083 char c;
11084
11085 if ((ffelex_token_type (t) == FFELEX_typeNAME)
11086 || (ffelex_token_type (t) == FFELEX_typeNAMES))
11087 {
11088 if ((ffelex_token_length (t) == 1)
11089 && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]),
11090 'B', 'b')
11091 || ffesrc_char_match_init (c, 'O', 'o')
11092 || ffesrc_char_match_init (c, 'X', 'x')
11093 || ffesrc_char_match_init (c, 'Z', 'z')))
11094 return (ffelexHandler) ffeexpr_nil_binary_;
11095 }
11096 if ((ffelex_token_type (t) == FFELEX_typeNAME)
11097 || (ffelex_token_type (t) == FFELEX_typeNAMES))
11098 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11099 return (ffelexHandler) ffeexpr_nil_substrp_ (t);
11100 }
11101
11102 static ffelexHandler
11103 ffeexpr_nil_name_rhs_ (ffelexToken t)
11104 {
11105 switch (ffelex_token_type (t))
11106 {
11107 case FFELEX_typeQUOTE:
11108 case FFELEX_typeAPOSTROPHE:
11109 ffelex_set_hexnum (TRUE);
11110 return (ffelexHandler) ffeexpr_nil_name_apos_;
11111
11112 case FFELEX_typeOPEN_PAREN:
11113 ++ffeexpr_find_.level;
11114 return (ffelexHandler) ffeexpr_nil_rhs_;
11115
11116 default:
11117 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11118 }
11119 }
11120
11121 static ffelexHandler
11122 ffeexpr_nil_name_apos_ (ffelexToken t)
11123 {
11124 if (ffelex_token_type (t) == FFELEX_typeNAME)
11125 return (ffelexHandler) ffeexpr_nil_name_apos_name_;
11126 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11127 }
11128
11129 static ffelexHandler
11130 ffeexpr_nil_name_apos_name_ (ffelexToken t)
11131 {
11132 switch (ffelex_token_type (t))
11133 {
11134 case FFELEX_typeAPOSTROPHE:
11135 case FFELEX_typeQUOTE:
11136 return (ffelexHandler) ffeexpr_nil_finished_;
11137
11138 default:
11139 return (ffelexHandler) ffeexpr_nil_finished_ (t);
11140 }
11141 }
11142
11143 static ffelexHandler
11144 ffeexpr_nil_percent_ (ffelexToken t)
11145 {
11146 switch (ffelex_token_type (t))
11147 {
11148 case FFELEX_typeNAME:
11149 case FFELEX_typeNAMES:
11150 ffeexpr_stack_->percent = ffeexpr_percent_ (t);
11151 ffeexpr_find_.t = ffelex_token_use (t);
11152 return (ffelexHandler) ffeexpr_nil_percent_name_;
11153
11154 default:
11155 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11156 }
11157 }
11158
11159 /* Expects ffeexpr_find_.t. */
11160
11161 static ffelexHandler
11162 ffeexpr_nil_percent_name_ (ffelexToken t)
11163 {
11164 ffelexHandler nexthandler;
11165
11166 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
11167 {
11168 nexthandler
11169 = (ffelexHandler) ffeexpr_nil_rhs_ (ffeexpr_find_.t);
11170 ffelex_token_kill (ffeexpr_find_.t);
11171 return (ffelexHandler) (*nexthandler) (t);
11172 }
11173
11174 ffelex_token_kill (ffeexpr_find_.t);
11175 ++ffeexpr_find_.level;
11176 return (ffelexHandler) ffeexpr_nil_rhs_;
11177 }
11178
11179 static ffelexHandler
11180 ffeexpr_nil_substrp_ (ffelexToken t)
11181 {
11182 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
11183 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11184
11185 ++ffeexpr_find_.level;
11186 return (ffelexHandler) ffeexpr_nil_rhs_;
11187 }
11188
11189 /* ffeexpr_finished_ -- Reduce expression stack to one expr, finish
11190
11191 ffelexToken t;
11192 return ffeexpr_finished_(t);
11193
11194 Reduces expression stack to one (or zero) elements by repeatedly reducing
11195 the top operator on the stack (or, if the top element on the stack is
11196 itself an operator, issuing an error message and discarding it). Calls
11197 finishing routine with the expression, returning the ffelexHandler it
11198 returns to the caller. */
11199
11200 static ffelexHandler
11201 ffeexpr_finished_ (ffelexToken t)
11202 {
11203 ffeexprExpr_ operand; /* This is B in -B or A+B. */
11204 ffebld expr;
11205 ffeexprCallback callback;
11206 ffeexprStack_ s;
11207 ffebldConstant constnode; /* For detecting magical number. */
11208 ffelexToken ft; /* Temporary copy of first token in
11209 expression. */
11210 ffelexHandler next;
11211 ffeinfo info;
11212 bool error = FALSE;
11213
11214 while (((operand = ffeexpr_stack_->exprstack) != NULL)
11215 && ((operand->previous != NULL) || (operand->type != FFEEXPR_exprtypeOPERAND_)))
11216 {
11217 if (operand->type == FFEEXPR_exprtypeOPERAND_)
11218 ffeexpr_reduce_ ();
11219 else
11220 {
11221 if (ffest_ffebad_start (FFEBAD_MISSING_OPERAND_FOR_OPERATOR))
11222 {
11223 ffebad_here (0, ffelex_token_where_line (t),
11224 ffelex_token_where_column (t));
11225 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
11226 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
11227 ffebad_finish ();
11228 }
11229 ffeexpr_stack_->exprstack = operand->previous; /* Pop the useless
11230 operator. */
11231 ffeexpr_expr_kill_ (operand);
11232 }
11233 }
11234
11235 assert ((operand == NULL) || (operand->previous == NULL));
11236
11237 ffebld_pool_pop ();
11238 if (operand == NULL)
11239 expr = NULL;
11240 else
11241 {
11242 expr = operand->u.operand;
11243 info = ffebld_info (expr);
11244 if ((ffebld_op (expr) == FFEBLD_opCONTER)
11245 && (ffebld_conter_orig (expr) == NULL)
11246 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
11247 {
11248 ffetarget_integer_bad_magical (operand->token);
11249 }
11250 ffeexpr_expr_kill_ (operand);
11251 ffeexpr_stack_->exprstack = NULL;
11252 }
11253
11254 ft = ffeexpr_stack_->first_token;
11255
11256 again: /* :::::::::::::::::::: */
11257 switch (ffeexpr_stack_->context)
11258 {
11259 case FFEEXPR_contextLET:
11260 case FFEEXPR_contextSFUNCDEF:
11261 error = (expr == NULL)
11262 || (ffeinfo_rank (info) != 0);
11263 break;
11264
11265 case FFEEXPR_contextPAREN_:
11266 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11267 break;
11268 switch (ffeinfo_basictype (info))
11269 {
11270 case FFEINFO_basictypeHOLLERITH:
11271 case FFEINFO_basictypeTYPELESS:
11272 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11273 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11274 FFEEXPR_contextLET);
11275 break;
11276
11277 default:
11278 break;
11279 }
11280 break;
11281
11282 case FFEEXPR_contextPARENFILENUM_:
11283 if (ffelex_token_type (t) != FFELEX_typeCOMMA)
11284 ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
11285 else
11286 ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
11287 goto again; /* :::::::::::::::::::: */
11288
11289 case FFEEXPR_contextPARENFILEUNIT_:
11290 if (ffelex_token_type (t) != FFELEX_typeCOMMA)
11291 ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
11292 else
11293 ffeexpr_stack_->context = FFEEXPR_contextFILEUNIT;
11294 goto again; /* :::::::::::::::::::: */
11295
11296 case FFEEXPR_contextACTUALARGEXPR_:
11297 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
11298 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11299 : ffeinfo_basictype (info))
11300 {
11301 case FFEINFO_basictypeHOLLERITH:
11302 case FFEINFO_basictypeTYPELESS:
11303 if (!ffe_is_ugly_args ()
11304 && ffebad_start (FFEBAD_ACTUALARG))
11305 {
11306 ffebad_here (0, ffelex_token_where_line (ft),
11307 ffelex_token_where_column (ft));
11308 ffebad_finish ();
11309 }
11310 break;
11311
11312 default:
11313 break;
11314 }
11315 error = (expr != NULL) && (ffeinfo_rank (info) != 0);
11316 break;
11317
11318 case FFEEXPR_contextACTUALARG_:
11319 case FFEEXPR_contextSFUNCDEFACTUALARG_:
11320 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11321 : ffeinfo_basictype (info))
11322 {
11323 case FFEINFO_basictypeHOLLERITH:
11324 case FFEINFO_basictypeTYPELESS:
11325 #if 0 /* Should never get here. */
11326 expr = ffeexpr_convert (expr, ft, ft,
11327 FFEINFO_basictypeINTEGER,
11328 FFEINFO_kindtypeINTEGERDEFAULT,
11329 0,
11330 FFETARGET_charactersizeNONE,
11331 FFEEXPR_contextLET);
11332 #else
11333 assert ("why hollerith/typeless in actualarg_?" == NULL);
11334 #endif
11335 break;
11336
11337 default:
11338 break;
11339 }
11340 switch ((expr == NULL) ? FFEBLD_opANY : ffebld_op (expr))
11341 {
11342 case FFEBLD_opSYMTER:
11343 case FFEBLD_opPERCENT_LOC:
11344 case FFEBLD_opPERCENT_VAL:
11345 case FFEBLD_opPERCENT_REF:
11346 case FFEBLD_opPERCENT_DESCR:
11347 error = FALSE;
11348 break;
11349
11350 default:
11351 error = (expr != NULL) && (ffeinfo_rank (info) != 0);
11352 break;
11353 }
11354 {
11355 ffesymbol s;
11356 ffeinfoWhere where;
11357 ffeinfoKind kind;
11358
11359 if (!error
11360 && (expr != NULL)
11361 && (ffebld_op (expr) == FFEBLD_opSYMTER)
11362 && ((s = ffebld_symter (expr)), (where = ffesymbol_where (s)),
11363 (where == FFEINFO_whereINTRINSIC)
11364 || (where == FFEINFO_whereGLOBAL)
11365 || ((where == FFEINFO_whereDUMMY)
11366 && ((kind = ffesymbol_kind (s)),
11367 (kind == FFEINFO_kindFUNCTION)
11368 || (kind == FFEINFO_kindSUBROUTINE))))
11369 && !ffesymbol_explicitwhere (s))
11370 {
11371 ffebad_start (where == FFEINFO_whereINTRINSIC
11372 ? FFEBAD_NEED_INTRINSIC : FFEBAD_NEED_EXTERNAL);
11373 ffebad_here (0, ffelex_token_where_line (ft),
11374 ffelex_token_where_column (ft));
11375 ffebad_string (ffesymbol_text (s));
11376 ffebad_finish ();
11377 ffesymbol_signal_change (s);
11378 ffesymbol_set_explicitwhere (s, TRUE);
11379 ffesymbol_signal_unreported (s);
11380 }
11381 }
11382 break;
11383
11384 case FFEEXPR_contextINDEX_:
11385 case FFEEXPR_contextSFUNCDEFINDEX_:
11386 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11387 break;
11388 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11389 : ffeinfo_basictype (info))
11390 {
11391 case FFEINFO_basictypeNONE:
11392 error = FALSE;
11393 break;
11394
11395 case FFEINFO_basictypeLOGICAL:
11396 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11397 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11398 FFEEXPR_contextLET);
11399 /* Fall through. */
11400 case FFEINFO_basictypeREAL:
11401 case FFEINFO_basictypeCOMPLEX:
11402 if (ffe_is_pedantic ())
11403 {
11404 error = TRUE;
11405 break;
11406 }
11407 /* Fall through. */
11408 case FFEINFO_basictypeHOLLERITH:
11409 case FFEINFO_basictypeTYPELESS:
11410 error = FALSE;
11411 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11412 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11413 FFEEXPR_contextLET);
11414 break;
11415
11416 case FFEINFO_basictypeINTEGER:
11417 /* Specifically, allow INTEGER(KIND=2), aka INTEGER*8, through
11418 unmolested. Leave it to downstream to handle kinds. */
11419 break;
11420
11421 default:
11422 error = TRUE;
11423 break;
11424 }
11425 break; /* expr==NULL ok for substring; element case
11426 caught by callback. */
11427
11428 case FFEEXPR_contextRETURN:
11429 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11430 break;
11431 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11432 : ffeinfo_basictype (info))
11433 {
11434 case FFEINFO_basictypeNONE:
11435 error = FALSE;
11436 break;
11437
11438 case FFEINFO_basictypeLOGICAL:
11439 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11440 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11441 FFEEXPR_contextLET);
11442 /* Fall through. */
11443 case FFEINFO_basictypeREAL:
11444 case FFEINFO_basictypeCOMPLEX:
11445 if (ffe_is_pedantic ())
11446 {
11447 error = TRUE;
11448 break;
11449 }
11450 /* Fall through. */
11451 case FFEINFO_basictypeINTEGER:
11452 case FFEINFO_basictypeHOLLERITH:
11453 case FFEINFO_basictypeTYPELESS:
11454 error = FALSE;
11455 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11456 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11457 FFEEXPR_contextLET);
11458 break;
11459
11460 default:
11461 error = TRUE;
11462 break;
11463 }
11464 break;
11465
11466 case FFEEXPR_contextDO:
11467 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11468 break;
11469 switch (ffeinfo_basictype (info))
11470 {
11471 case FFEINFO_basictypeLOGICAL:
11472 error = !ffe_is_ugly_logint ();
11473 if (!ffeexpr_stack_->is_rhs)
11474 break; /* Don't convert lhs variable. */
11475 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11476 ffeinfo_kindtype (ffebld_info (expr)), 0,
11477 FFETARGET_charactersizeNONE,
11478 FFEEXPR_contextLET);
11479 break;
11480
11481 case FFEINFO_basictypeHOLLERITH:
11482 case FFEINFO_basictypeTYPELESS:
11483 if (!ffeexpr_stack_->is_rhs)
11484 {
11485 error = TRUE;
11486 break; /* Don't convert lhs variable. */
11487 }
11488 break;
11489
11490 case FFEINFO_basictypeINTEGER:
11491 case FFEINFO_basictypeREAL:
11492 break;
11493
11494 default:
11495 error = TRUE;
11496 break;
11497 }
11498 if (!ffeexpr_stack_->is_rhs
11499 && (ffebld_op (expr) != FFEBLD_opSYMTER))
11500 error = TRUE;
11501 break;
11502
11503 case FFEEXPR_contextDOWHILE:
11504 case FFEEXPR_contextIF:
11505 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11506 break;
11507 switch (ffeinfo_basictype (info))
11508 {
11509 case FFEINFO_basictypeINTEGER:
11510 error = FALSE;
11511 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11512 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11513 FFEEXPR_contextLET);
11514 /* Fall through. */
11515 case FFEINFO_basictypeLOGICAL:
11516 case FFEINFO_basictypeHOLLERITH:
11517 case FFEINFO_basictypeTYPELESS:
11518 error = FALSE;
11519 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11520 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11521 FFEEXPR_contextLET);
11522 break;
11523
11524 default:
11525 error = TRUE;
11526 break;
11527 }
11528 break;
11529
11530 case FFEEXPR_contextASSIGN:
11531 case FFEEXPR_contextAGOTO:
11532 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11533 : ffeinfo_basictype (info))
11534 {
11535 case FFEINFO_basictypeINTEGER:
11536 error = (ffeinfo_kindtype (info) != ffecom_label_kind ());
11537 break;
11538
11539 case FFEINFO_basictypeLOGICAL:
11540 error = !ffe_is_ugly_logint ()
11541 || (ffeinfo_kindtype (info) != ffecom_label_kind ());
11542 break;
11543
11544 default:
11545 error = TRUE;
11546 break;
11547 }
11548 if ((expr == NULL) || (ffeinfo_rank (info) != 0)
11549 || (ffebld_op (expr) != FFEBLD_opSYMTER))
11550 error = TRUE;
11551 break;
11552
11553 case FFEEXPR_contextCGOTO:
11554 case FFEEXPR_contextFORMAT:
11555 case FFEEXPR_contextDIMLIST:
11556 case FFEEXPR_contextFILENUM: /* See equiv code in _ambig_. */
11557 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11558 break;
11559 switch (ffeinfo_basictype (info))
11560 {
11561 case FFEINFO_basictypeLOGICAL:
11562 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11563 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11564 FFEEXPR_contextLET);
11565 /* Fall through. */
11566 case FFEINFO_basictypeREAL:
11567 case FFEINFO_basictypeCOMPLEX:
11568 if (ffe_is_pedantic ())
11569 {
11570 error = TRUE;
11571 break;
11572 }
11573 /* Fall through. */
11574 case FFEINFO_basictypeINTEGER:
11575 case FFEINFO_basictypeHOLLERITH:
11576 case FFEINFO_basictypeTYPELESS:
11577 error = FALSE;
11578 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11579 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11580 FFEEXPR_contextLET);
11581 break;
11582
11583 default:
11584 error = TRUE;
11585 break;
11586 }
11587 break;
11588
11589 case FFEEXPR_contextARITHIF:
11590 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11591 break;
11592 switch (ffeinfo_basictype (info))
11593 {
11594 case FFEINFO_basictypeLOGICAL:
11595 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11596 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11597 FFEEXPR_contextLET);
11598 if (ffe_is_pedantic ())
11599 {
11600 error = TRUE;
11601 break;
11602 }
11603 /* Fall through. */
11604 case FFEINFO_basictypeHOLLERITH:
11605 case FFEINFO_basictypeTYPELESS:
11606 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11607 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11608 FFEEXPR_contextLET);
11609 /* Fall through. */
11610 case FFEINFO_basictypeINTEGER:
11611 case FFEINFO_basictypeREAL:
11612 error = FALSE;
11613 break;
11614
11615 default:
11616 error = TRUE;
11617 break;
11618 }
11619 break;
11620
11621 case FFEEXPR_contextSTOP:
11622 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11623 break;
11624 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11625 : ffeinfo_basictype (info))
11626 {
11627 case FFEINFO_basictypeINTEGER:
11628 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
11629 break;
11630
11631 case FFEINFO_basictypeCHARACTER:
11632 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT);
11633 break;
11634
11635 case FFEINFO_basictypeHOLLERITH:
11636 case FFEINFO_basictypeTYPELESS:
11637 error = FALSE;
11638 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11639 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11640 FFEEXPR_contextLET);
11641 break;
11642
11643 case FFEINFO_basictypeNONE:
11644 error = FALSE;
11645 break;
11646
11647 default:
11648 error = TRUE;
11649 break;
11650 }
11651 if ((expr != NULL) && ((ffebld_op (expr) != FFEBLD_opCONTER)
11652 || (ffebld_conter_orig (expr) != NULL)))
11653 error = TRUE;
11654 break;
11655
11656 case FFEEXPR_contextINCLUDE:
11657 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
11658 || (ffeinfo_basictype (info) != FFEINFO_basictypeCHARACTER)
11659 || (ffebld_op (expr) != FFEBLD_opCONTER)
11660 || (ffebld_conter_orig (expr) != NULL);
11661 break;
11662
11663 case FFEEXPR_contextSELECTCASE:
11664 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11665 break;
11666 switch (ffeinfo_basictype (info))
11667 {
11668 case FFEINFO_basictypeINTEGER:
11669 case FFEINFO_basictypeCHARACTER:
11670 case FFEINFO_basictypeLOGICAL:
11671 error = FALSE;
11672 break;
11673
11674 case FFEINFO_basictypeHOLLERITH:
11675 case FFEINFO_basictypeTYPELESS:
11676 error = FALSE;
11677 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11678 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11679 FFEEXPR_contextLET);
11680 break;
11681
11682 default:
11683 error = TRUE;
11684 break;
11685 }
11686 break;
11687
11688 case FFEEXPR_contextCASE:
11689 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11690 break;
11691 switch ((expr == NULL) ? FFEINFO_basictypeINTEGER
11692 : ffeinfo_basictype (info))
11693 {
11694 case FFEINFO_basictypeINTEGER:
11695 case FFEINFO_basictypeCHARACTER:
11696 case FFEINFO_basictypeLOGICAL:
11697 error = FALSE;
11698 break;
11699
11700 case FFEINFO_basictypeHOLLERITH:
11701 case FFEINFO_basictypeTYPELESS:
11702 error = FALSE;
11703 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11704 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11705 FFEEXPR_contextLET);
11706 break;
11707
11708 default:
11709 error = TRUE;
11710 break;
11711 }
11712 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
11713 error = TRUE;
11714 break;
11715
11716 case FFEEXPR_contextCHARACTERSIZE:
11717 case FFEEXPR_contextKINDTYPE:
11718 case FFEEXPR_contextDIMLISTCOMMON:
11719 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11720 break;
11721 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11722 : ffeinfo_basictype (info))
11723 {
11724 case FFEINFO_basictypeLOGICAL:
11725 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11726 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11727 FFEEXPR_contextLET);
11728 /* Fall through. */
11729 case FFEINFO_basictypeREAL:
11730 case FFEINFO_basictypeCOMPLEX:
11731 if (ffe_is_pedantic ())
11732 {
11733 error = TRUE;
11734 break;
11735 }
11736 /* Fall through. */
11737 case FFEINFO_basictypeINTEGER:
11738 case FFEINFO_basictypeHOLLERITH:
11739 case FFEINFO_basictypeTYPELESS:
11740 error = FALSE;
11741 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11742 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11743 FFEEXPR_contextLET);
11744 break;
11745
11746 default:
11747 error = TRUE;
11748 break;
11749 }
11750 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
11751 error = TRUE;
11752 break;
11753
11754 case FFEEXPR_contextEQVINDEX_:
11755 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11756 break;
11757 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11758 : ffeinfo_basictype (info))
11759 {
11760 case FFEINFO_basictypeNONE:
11761 error = FALSE;
11762 break;
11763
11764 case FFEINFO_basictypeLOGICAL:
11765 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11766 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11767 FFEEXPR_contextLET);
11768 /* Fall through. */
11769 case FFEINFO_basictypeREAL:
11770 case FFEINFO_basictypeCOMPLEX:
11771 if (ffe_is_pedantic ())
11772 {
11773 error = TRUE;
11774 break;
11775 }
11776 /* Fall through. */
11777 case FFEINFO_basictypeINTEGER:
11778 case FFEINFO_basictypeHOLLERITH:
11779 case FFEINFO_basictypeTYPELESS:
11780 error = FALSE;
11781 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11782 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11783 FFEEXPR_contextLET);
11784 break;
11785
11786 default:
11787 error = TRUE;
11788 break;
11789 }
11790 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
11791 error = TRUE;
11792 break;
11793
11794 case FFEEXPR_contextPARAMETER:
11795 if (ffeexpr_stack_->is_rhs)
11796 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
11797 || (ffebld_op (expr) != FFEBLD_opCONTER);
11798 else
11799 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
11800 || (ffebld_op (expr) != FFEBLD_opSYMTER);
11801 break;
11802
11803 case FFEEXPR_contextINDEXORACTUALARG_:
11804 if (ffelex_token_type (t) == FFELEX_typeCOLON)
11805 ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
11806 else
11807 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
11808 goto again; /* :::::::::::::::::::: */
11809
11810 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
11811 if (ffelex_token_type (t) == FFELEX_typeCOLON)
11812 ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
11813 else
11814 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
11815 goto again; /* :::::::::::::::::::: */
11816
11817 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
11818 if (ffelex_token_type (t) == FFELEX_typeCOLON)
11819 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
11820 else
11821 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
11822 goto again; /* :::::::::::::::::::: */
11823
11824 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
11825 if (ffelex_token_type (t) == FFELEX_typeCOLON)
11826 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
11827 else
11828 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
11829 goto again; /* :::::::::::::::::::: */
11830
11831 case FFEEXPR_contextIMPDOCTRL_:
11832 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11833 break;
11834 if (!ffeexpr_stack_->is_rhs
11835 && (ffebld_op (expr) != FFEBLD_opSYMTER))
11836 error = TRUE;
11837 switch (ffeinfo_basictype (info))
11838 {
11839 case FFEINFO_basictypeLOGICAL:
11840 if (! ffe_is_ugly_logint ())
11841 error = TRUE;
11842 if (! ffeexpr_stack_->is_rhs)
11843 break;
11844 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11845 ffeinfo_kindtype (info), 0,
11846 FFETARGET_charactersizeNONE,
11847 FFEEXPR_contextLET);
11848 break;
11849
11850 case FFEINFO_basictypeINTEGER:
11851 case FFEINFO_basictypeHOLLERITH:
11852 case FFEINFO_basictypeTYPELESS:
11853 break;
11854
11855 case FFEINFO_basictypeREAL:
11856 if (!ffeexpr_stack_->is_rhs
11857 && ffe_is_warn_surprising ()
11858 && !error)
11859 {
11860 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
11861 ffebad_here (0, ffelex_token_where_line (ft),
11862 ffelex_token_where_column (ft));
11863 ffebad_string (ffelex_token_text (ft));
11864 ffebad_finish ();
11865 }
11866 break;
11867
11868 default:
11869 error = TRUE;
11870 break;
11871 }
11872 break;
11873
11874 case FFEEXPR_contextDATAIMPDOCTRL_:
11875 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11876 break;
11877 if (ffeexpr_stack_->is_rhs)
11878 {
11879 if ((ffebld_op (expr) != FFEBLD_opCONTER)
11880 && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
11881 error = TRUE;
11882 }
11883 else if ((ffebld_op (expr) != FFEBLD_opSYMTER)
11884 || (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
11885 error = TRUE;
11886 switch (ffeinfo_basictype (info))
11887 {
11888 case FFEINFO_basictypeLOGICAL:
11889 if (! ffeexpr_stack_->is_rhs)
11890 break;
11891 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11892 ffeinfo_kindtype (info), 0,
11893 FFETARGET_charactersizeNONE,
11894 FFEEXPR_contextLET);
11895 /* Fall through. */
11896 case FFEINFO_basictypeINTEGER:
11897 if (ffeexpr_stack_->is_rhs
11898 && (ffeinfo_kindtype (ffebld_info (expr))
11899 != FFEINFO_kindtypeINTEGERDEFAULT))
11900 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11901 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11902 FFETARGET_charactersizeNONE,
11903 FFEEXPR_contextLET);
11904 break;
11905
11906 case FFEINFO_basictypeHOLLERITH:
11907 case FFEINFO_basictypeTYPELESS:
11908 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11909 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11910 FFEEXPR_contextLET);
11911 break;
11912
11913 case FFEINFO_basictypeREAL:
11914 if (!ffeexpr_stack_->is_rhs
11915 && ffe_is_warn_surprising ()
11916 && !error)
11917 {
11918 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
11919 ffebad_here (0, ffelex_token_where_line (ft),
11920 ffelex_token_where_column (ft));
11921 ffebad_string (ffelex_token_text (ft));
11922 ffebad_finish ();
11923 }
11924 break;
11925
11926 default:
11927 error = TRUE;
11928 break;
11929 }
11930 break;
11931
11932 case FFEEXPR_contextIMPDOITEM_:
11933 if (ffelex_token_type (t) == FFELEX_typeEQUALS)
11934 {
11935 ffeexpr_stack_->is_rhs = FALSE;
11936 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
11937 goto again; /* :::::::::::::::::::: */
11938 }
11939 /* Fall through. */
11940 case FFEEXPR_contextIOLIST:
11941 case FFEEXPR_contextFILEVXTCODE:
11942 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11943 : ffeinfo_basictype (info))
11944 {
11945 case FFEINFO_basictypeHOLLERITH:
11946 case FFEINFO_basictypeTYPELESS:
11947 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11948 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11949 FFEEXPR_contextLET);
11950 break;
11951
11952 default:
11953 break;
11954 }
11955 error = (expr == NULL)
11956 || ((ffeinfo_rank (info) != 0)
11957 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
11958 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
11959 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
11960 == FFEBLD_opSTAR))); /* Bad if null expr, or if
11961 array that is not a SYMTER
11962 (can't happen yet, I
11963 think) or has a NULL or
11964 STAR (assumed) array
11965 size. */
11966 break;
11967
11968 case FFEEXPR_contextIMPDOITEMDF_:
11969 if (ffelex_token_type (t) == FFELEX_typeEQUALS)
11970 {
11971 ffeexpr_stack_->is_rhs = FALSE;
11972 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
11973 goto again; /* :::::::::::::::::::: */
11974 }
11975 /* Fall through. */
11976 case FFEEXPR_contextIOLISTDF:
11977 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11978 : ffeinfo_basictype (info))
11979 {
11980 case FFEINFO_basictypeHOLLERITH:
11981 case FFEINFO_basictypeTYPELESS:
11982 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11983 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11984 FFEEXPR_contextLET);
11985 break;
11986
11987 default:
11988 break;
11989 }
11990 error
11991 = (expr == NULL)
11992 || ((ffeinfo_basictype (info) == FFEINFO_basictypeCHARACTER)
11993 && (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT))
11994 || ((ffeinfo_rank (info) != 0)
11995 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
11996 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
11997 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
11998 == FFEBLD_opSTAR))); /* Bad if null expr,
11999 non-default-kindtype
12000 character expr, or if
12001 array that is not a SYMTER
12002 (can't happen yet, I
12003 think) or has a NULL or
12004 STAR (assumed) array
12005 size. */
12006 break;
12007
12008 case FFEEXPR_contextDATAIMPDOITEM_:
12009 error = (expr == NULL)
12010 || (ffebld_op (expr) != FFEBLD_opARRAYREF)
12011 || ((ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR)
12012 && (ffeinfo_where (info) != FFEINFO_whereFLEETING_IADDR));
12013 break;
12014
12015 case FFEEXPR_contextDATAIMPDOINDEX_:
12016 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12017 break;
12018 switch (ffeinfo_basictype (info))
12019 {
12020 case FFEINFO_basictypeLOGICAL:
12021 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12022 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12023 FFEEXPR_contextLET);
12024 /* Fall through. */
12025 case FFEINFO_basictypeREAL:
12026 case FFEINFO_basictypeCOMPLEX:
12027 if (ffe_is_pedantic ())
12028 {
12029 error = TRUE;
12030 break;
12031 }
12032 /* Fall through. */
12033 case FFEINFO_basictypeINTEGER:
12034 case FFEINFO_basictypeHOLLERITH:
12035 case FFEINFO_basictypeTYPELESS:
12036 error = FALSE;
12037 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12038 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12039 FFEEXPR_contextLET);
12040 break;
12041
12042 default:
12043 error = TRUE;
12044 break;
12045 }
12046 if ((ffeinfo_where (info) != FFEINFO_whereCONSTANT)
12047 && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12048 error = TRUE;
12049 break;
12050
12051 case FFEEXPR_contextDATA:
12052 if (expr == NULL)
12053 error = TRUE;
12054 else if (ffeexpr_stack_->is_rhs)
12055 error = (ffebld_op (expr) != FFEBLD_opCONTER);
12056 else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12057 error = FALSE;
12058 else
12059 error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12060 break;
12061
12062 case FFEEXPR_contextINITVAL:
12063 error = (expr == NULL) || (ffebld_op (expr) != FFEBLD_opCONTER);
12064 break;
12065
12066 case FFEEXPR_contextEQUIVALENCE:
12067 if (expr == NULL)
12068 error = TRUE;
12069 else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12070 error = FALSE;
12071 else
12072 error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12073 break;
12074
12075 case FFEEXPR_contextFILEASSOC:
12076 case FFEEXPR_contextFILEINT:
12077 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12078 : ffeinfo_basictype (info))
12079 {
12080 case FFEINFO_basictypeINTEGER:
12081 /* Maybe this should be supported someday, but, right now,
12082 g77 can't generate a call to libf2c to write to an
12083 integer other than the default size. */
12084 error = ((! ffeexpr_stack_->is_rhs)
12085 && ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12086 break;
12087
12088 default:
12089 error = TRUE;
12090 break;
12091 }
12092 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12093 error = TRUE;
12094 break;
12095
12096 case FFEEXPR_contextFILEDFINT:
12097 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12098 : ffeinfo_basictype (info))
12099 {
12100 case FFEINFO_basictypeINTEGER:
12101 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12102 break;
12103
12104 default:
12105 error = TRUE;
12106 break;
12107 }
12108 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12109 error = TRUE;
12110 break;
12111
12112 case FFEEXPR_contextFILELOG:
12113 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12114 : ffeinfo_basictype (info))
12115 {
12116 case FFEINFO_basictypeLOGICAL:
12117 error = FALSE;
12118 break;
12119
12120 default:
12121 error = TRUE;
12122 break;
12123 }
12124 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12125 error = TRUE;
12126 break;
12127
12128 case FFEEXPR_contextFILECHAR:
12129 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12130 : ffeinfo_basictype (info))
12131 {
12132 case FFEINFO_basictypeCHARACTER:
12133 error = FALSE;
12134 break;
12135
12136 default:
12137 error = TRUE;
12138 break;
12139 }
12140 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12141 error = TRUE;
12142 break;
12143
12144 case FFEEXPR_contextFILENUMCHAR:
12145 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12146 break;
12147 switch (ffeinfo_basictype (info))
12148 {
12149 case FFEINFO_basictypeLOGICAL:
12150 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12151 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12152 FFEEXPR_contextLET);
12153 /* Fall through. */
12154 case FFEINFO_basictypeREAL:
12155 case FFEINFO_basictypeCOMPLEX:
12156 if (ffe_is_pedantic ())
12157 {
12158 error = TRUE;
12159 break;
12160 }
12161 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12162 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12163 FFEEXPR_contextLET);
12164 break;
12165
12166 case FFEINFO_basictypeINTEGER:
12167 case FFEINFO_basictypeCHARACTER:
12168 error = FALSE;
12169 break;
12170
12171 default:
12172 error = TRUE;
12173 break;
12174 }
12175 break;
12176
12177 case FFEEXPR_contextFILEDFCHAR:
12178 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12179 break;
12180 switch (ffeinfo_basictype (info))
12181 {
12182 case FFEINFO_basictypeCHARACTER:
12183 error
12184 = (ffeinfo_kindtype (info)
12185 != FFEINFO_kindtypeCHARACTERDEFAULT);
12186 break;
12187
12188 default:
12189 error = TRUE;
12190 break;
12191 }
12192 if (!ffeexpr_stack_->is_rhs
12193 && (ffebld_op (expr) == FFEBLD_opSUBSTR))
12194 error = TRUE;
12195 break;
12196
12197 case FFEEXPR_contextFILEUNIT: /* See equiv code in _ambig_. */
12198 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12199 : ffeinfo_basictype (info))
12200 {
12201 case FFEINFO_basictypeLOGICAL:
12202 if ((error = (ffeinfo_rank (info) != 0)))
12203 break;
12204 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12205 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12206 FFEEXPR_contextLET);
12207 /* Fall through. */
12208 case FFEINFO_basictypeREAL:
12209 case FFEINFO_basictypeCOMPLEX:
12210 if ((error = (ffeinfo_rank (info) != 0)))
12211 break;
12212 if (ffe_is_pedantic ())
12213 {
12214 error = TRUE;
12215 break;
12216 }
12217 /* Fall through. */
12218 case FFEINFO_basictypeINTEGER:
12219 case FFEINFO_basictypeHOLLERITH:
12220 case FFEINFO_basictypeTYPELESS:
12221 if ((error = (ffeinfo_rank (info) != 0)))
12222 break;
12223 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12224 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12225 FFEEXPR_contextLET);
12226 break;
12227
12228 case FFEINFO_basictypeCHARACTER:
12229 switch (ffebld_op (expr))
12230 { /* As if _lhs had been called instead of
12231 _rhs. */
12232 case FFEBLD_opSYMTER:
12233 error
12234 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
12235 break;
12236
12237 case FFEBLD_opSUBSTR:
12238 error = (ffeinfo_where (ffebld_info (expr))
12239 == FFEINFO_whereCONSTANT_SUBOBJECT);
12240 break;
12241
12242 case FFEBLD_opARRAYREF:
12243 error = FALSE;
12244 break;
12245
12246 default:
12247 error = TRUE;
12248 break;
12249 }
12250 if (!error
12251 && ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
12252 || ((ffeinfo_rank (info) != 0)
12253 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12254 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12255 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12256 == FFEBLD_opSTAR))))) /* Bad if
12257 non-default-kindtype
12258 character expr, or if
12259 array that is not a SYMTER
12260 (can't happen yet, I
12261 think), or has a NULL or
12262 STAR (assumed) array
12263 size. */
12264 error = TRUE;
12265 break;
12266
12267 default:
12268 error = TRUE;
12269 break;
12270 }
12271 break;
12272
12273 case FFEEXPR_contextFILEFORMAT:
12274 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12275 : ffeinfo_basictype (info))
12276 {
12277 case FFEINFO_basictypeINTEGER:
12278 error = (expr == NULL)
12279 || ((ffeinfo_rank (info) != 0) ?
12280 ffe_is_pedantic () /* F77 C5. */
12281 : (bool) (ffeinfo_kindtype (info) != ffecom_label_kind ()))
12282 || (ffebld_op (expr) != FFEBLD_opSYMTER);
12283 break;
12284
12285 case FFEINFO_basictypeLOGICAL:
12286 case FFEINFO_basictypeREAL:
12287 case FFEINFO_basictypeCOMPLEX:
12288 /* F77 C5 -- must be an array of hollerith. */
12289 error
12290 = ffe_is_pedantic ()
12291 || (ffeinfo_rank (info) == 0);
12292 break;
12293
12294 case FFEINFO_basictypeCHARACTER:
12295 if ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
12296 || ((ffeinfo_rank (info) != 0)
12297 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12298 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12299 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12300 == FFEBLD_opSTAR)))) /* Bad if
12301 non-default-kindtype
12302 character expr, or if
12303 array that is not a SYMTER
12304 (can't happen yet, I
12305 think), or has a NULL or
12306 STAR (assumed) array
12307 size. */
12308 error = TRUE;
12309 else
12310 error = FALSE;
12311 break;
12312
12313 default:
12314 error = TRUE;
12315 break;
12316 }
12317 break;
12318
12319 case FFEEXPR_contextLOC_:
12320 /* See also ffeintrin_check_loc_. */
12321 if ((expr == NULL)
12322 || (ffeinfo_kind (info) != FFEINFO_kindENTITY)
12323 || ((ffebld_op (expr) != FFEBLD_opSYMTER)
12324 && (ffebld_op (expr) != FFEBLD_opSUBSTR)
12325 && (ffebld_op (expr) != FFEBLD_opARRAYREF)))
12326 error = TRUE;
12327 break;
12328
12329 default:
12330 error = FALSE;
12331 break;
12332 }
12333
12334 if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
12335 {
12336 ffebad_start (FFEBAD_EXPR_WRONG);
12337 ffebad_here (0, ffelex_token_where_line (ft),
12338 ffelex_token_where_column (ft));
12339 ffebad_finish ();
12340 expr = ffebld_new_any ();
12341 ffebld_set_info (expr, ffeinfo_new_any ());
12342 }
12343
12344 callback = ffeexpr_stack_->callback;
12345 s = ffeexpr_stack_->previous;
12346 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
12347 sizeof (*ffeexpr_stack_));
12348 ffeexpr_stack_ = s;
12349 next = (ffelexHandler) (*callback) (ft, expr, t);
12350 ffelex_token_kill (ft);
12351 return (ffelexHandler) next;
12352 }
12353
12354 /* ffeexpr_finished_ambig_ -- Check validity of ambiguous unit/form spec
12355
12356 ffebld expr;
12357 expr = ffeexpr_finished_ambig_(expr);
12358
12359 Replicates a bit of ffeexpr_finished_'s task when in a context
12360 of UNIT or FORMAT. */
12361
12362 static ffebld
12363 ffeexpr_finished_ambig_ (ffelexToken ft, ffebld expr)
12364 {
12365 ffeinfo info = ffebld_info (expr);
12366 bool error;
12367
12368 switch (ffeexpr_stack_->context)
12369 {
12370 case FFEEXPR_contextFILENUMAMBIG: /* Same as FILENUM in _finished_. */
12371 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12372 : ffeinfo_basictype (info))
12373 {
12374 case FFEINFO_basictypeLOGICAL:
12375 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12376 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12377 FFEEXPR_contextLET);
12378 /* Fall through. */
12379 case FFEINFO_basictypeREAL:
12380 case FFEINFO_basictypeCOMPLEX:
12381 if (ffe_is_pedantic ())
12382 {
12383 error = TRUE;
12384 break;
12385 }
12386 /* Fall through. */
12387 case FFEINFO_basictypeINTEGER:
12388 case FFEINFO_basictypeHOLLERITH:
12389 case FFEINFO_basictypeTYPELESS:
12390 error = FALSE;
12391 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12392 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12393 FFEEXPR_contextLET);
12394 break;
12395
12396 default:
12397 error = TRUE;
12398 break;
12399 }
12400 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12401 error = TRUE;
12402 break;
12403
12404 case FFEEXPR_contextFILEUNITAMBIG: /* Same as FILEUNIT in _finished_. */
12405 if ((expr != NULL) && (ffebld_op (expr) == FFEBLD_opSTAR))
12406 {
12407 error = FALSE;
12408 break;
12409 }
12410 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12411 : ffeinfo_basictype (info))
12412 {
12413 case FFEINFO_basictypeLOGICAL:
12414 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12415 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12416 FFEEXPR_contextLET);
12417 /* Fall through. */
12418 case FFEINFO_basictypeREAL:
12419 case FFEINFO_basictypeCOMPLEX:
12420 if (ffe_is_pedantic ())
12421 {
12422 error = TRUE;
12423 break;
12424 }
12425 /* Fall through. */
12426 case FFEINFO_basictypeINTEGER:
12427 case FFEINFO_basictypeHOLLERITH:
12428 case FFEINFO_basictypeTYPELESS:
12429 error = (ffeinfo_rank (info) != 0);
12430 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12431 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12432 FFEEXPR_contextLET);
12433 break;
12434
12435 case FFEINFO_basictypeCHARACTER:
12436 switch (ffebld_op (expr))
12437 { /* As if _lhs had been called instead of
12438 _rhs. */
12439 case FFEBLD_opSYMTER:
12440 error
12441 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
12442 break;
12443
12444 case FFEBLD_opSUBSTR:
12445 error = (ffeinfo_where (ffebld_info (expr))
12446 == FFEINFO_whereCONSTANT_SUBOBJECT);
12447 break;
12448
12449 case FFEBLD_opARRAYREF:
12450 error = FALSE;
12451 break;
12452
12453 default:
12454 error = TRUE;
12455 break;
12456 }
12457 break;
12458
12459 default:
12460 error = TRUE;
12461 break;
12462 }
12463 break;
12464
12465 default:
12466 assert ("bad context" == NULL);
12467 error = TRUE;
12468 break;
12469 }
12470
12471 if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
12472 {
12473 ffebad_start (FFEBAD_EXPR_WRONG);
12474 ffebad_here (0, ffelex_token_where_line (ft),
12475 ffelex_token_where_column (ft));
12476 ffebad_finish ();
12477 expr = ffebld_new_any ();
12478 ffebld_set_info (expr, ffeinfo_new_any ());
12479 }
12480
12481 return expr;
12482 }
12483
12484 /* ffeexpr_token_lhs_ -- Initial state for lhs expression
12485
12486 Return a pointer to this function to the lexer (ffelex), which will
12487 invoke it for the next token.
12488
12489 Basically a smaller version of _rhs_; keep them both in sync, of course. */
12490
12491 static ffelexHandler
12492 ffeexpr_token_lhs_ (ffelexToken t)
12493 {
12494
12495 /* When changing the list of valid initial lhs tokens, check whether to
12496 update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
12497 READ (expr) <token> case -- it assumes it knows which tokens <token> can
12498 be to indicate an lhs (or implied DO), which right now is the set
12499 {NAME,OPEN_PAREN}.
12500
12501 This comment also appears in ffeexpr_token_first_lhs_. */
12502
12503 switch (ffelex_token_type (t))
12504 {
12505 case FFELEX_typeNAME:
12506 case FFELEX_typeNAMES:
12507 ffeexpr_tokens_[0] = ffelex_token_use (t);
12508 return (ffelexHandler) ffeexpr_token_name_lhs_;
12509
12510 default:
12511 return (ffelexHandler) ffeexpr_finished_ (t);
12512 }
12513 }
12514
12515 /* ffeexpr_token_rhs_ -- Initial state for rhs expression
12516
12517 Return a pointer to this function to the lexer (ffelex), which will
12518 invoke it for the next token.
12519
12520 The initial state and the post-binary-operator state are the same and
12521 both handled here, with the expression stack used to distinguish
12522 between them. Binary operators are invalid here; unary operators,
12523 constants, subexpressions, and name references are valid. */
12524
12525 static ffelexHandler
12526 ffeexpr_token_rhs_ (ffelexToken t)
12527 {
12528 ffeexprExpr_ e;
12529
12530 switch (ffelex_token_type (t))
12531 {
12532 case FFELEX_typeQUOTE:
12533 if (ffe_is_vxt ())
12534 {
12535 ffeexpr_tokens_[0] = ffelex_token_use (t);
12536 return (ffelexHandler) ffeexpr_token_quote_;
12537 }
12538 ffeexpr_tokens_[0] = ffelex_token_use (t);
12539 ffelex_set_expecting_hollerith (-1, '\"',
12540 ffelex_token_where_line (t),
12541 ffelex_token_where_column (t));
12542 /* Don't have to unset this one. */
12543 return (ffelexHandler) ffeexpr_token_apostrophe_;
12544
12545 case FFELEX_typeAPOSTROPHE:
12546 ffeexpr_tokens_[0] = ffelex_token_use (t);
12547 ffelex_set_expecting_hollerith (-1, '\'',
12548 ffelex_token_where_line (t),
12549 ffelex_token_where_column (t));
12550 /* Don't have to unset this one. */
12551 return (ffelexHandler) ffeexpr_token_apostrophe_;
12552
12553 case FFELEX_typePERCENT:
12554 ffeexpr_tokens_[0] = ffelex_token_use (t);
12555 return (ffelexHandler) ffeexpr_token_percent_;
12556
12557 case FFELEX_typeOPEN_PAREN:
12558 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
12559 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
12560 FFEEXPR_contextPAREN_,
12561 ffeexpr_cb_close_paren_c_);
12562
12563 case FFELEX_typePLUS:
12564 e = ffeexpr_expr_new_ ();
12565 e->type = FFEEXPR_exprtypeUNARY_;
12566 e->token = ffelex_token_use (t);
12567 e->u.operator.op = FFEEXPR_operatorADD_;
12568 e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
12569 e->u.operator.as = FFEEXPR_operatorassociativityADD_;
12570 ffeexpr_exprstack_push_unary_ (e);
12571 return (ffelexHandler) ffeexpr_token_rhs_;
12572
12573 case FFELEX_typeMINUS:
12574 e = ffeexpr_expr_new_ ();
12575 e->type = FFEEXPR_exprtypeUNARY_;
12576 e->token = ffelex_token_use (t);
12577 e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
12578 e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
12579 e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
12580 ffeexpr_exprstack_push_unary_ (e);
12581 return (ffelexHandler) ffeexpr_token_rhs_;
12582
12583 case FFELEX_typePERIOD:
12584 ffeexpr_tokens_[0] = ffelex_token_use (t);
12585 return (ffelexHandler) ffeexpr_token_period_;
12586
12587 case FFELEX_typeNUMBER:
12588 ffeexpr_tokens_[0] = ffelex_token_use (t);
12589 ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
12590 if (ffeexpr_hollerith_count_ > 0)
12591 ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
12592 '\0',
12593 ffelex_token_where_line (t),
12594 ffelex_token_where_column (t));
12595 return (ffelexHandler) ffeexpr_token_number_;
12596
12597 case FFELEX_typeNAME:
12598 case FFELEX_typeNAMES:
12599 ffeexpr_tokens_[0] = ffelex_token_use (t);
12600 switch (ffeexpr_stack_->context)
12601 {
12602 case FFEEXPR_contextACTUALARG_:
12603 case FFEEXPR_contextINDEXORACTUALARG_:
12604 case FFEEXPR_contextSFUNCDEFACTUALARG_:
12605 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
12606 return (ffelexHandler) ffeexpr_token_name_arg_;
12607
12608 default:
12609 return (ffelexHandler) ffeexpr_token_name_rhs_;
12610 }
12611
12612 case FFELEX_typeASTERISK:
12613 case FFELEX_typeSLASH:
12614 case FFELEX_typePOWER:
12615 case FFELEX_typeCONCAT:
12616 case FFELEX_typeREL_EQ:
12617 case FFELEX_typeREL_NE:
12618 case FFELEX_typeREL_LE:
12619 case FFELEX_typeREL_GE:
12620 if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
12621 {
12622 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
12623 ffebad_finish ();
12624 }
12625 return (ffelexHandler) ffeexpr_token_rhs_;
12626
12627 #if 0
12628 case FFELEX_typeEQUALS:
12629 case FFELEX_typePOINTS:
12630 case FFELEX_typeCLOSE_ANGLE:
12631 case FFELEX_typeCLOSE_PAREN:
12632 case FFELEX_typeCOMMA:
12633 case FFELEX_typeCOLON:
12634 case FFELEX_typeEOS:
12635 case FFELEX_typeSEMICOLON:
12636 #endif
12637 default:
12638 return (ffelexHandler) ffeexpr_finished_ (t);
12639 }
12640 }
12641
12642 /* ffeexpr_token_period_ -- Rhs PERIOD
12643
12644 Return a pointer to this function to the lexer (ffelex), which will
12645 invoke it for the next token.
12646
12647 Handle a period detected at rhs (expecting unary op or operand) state.
12648 Must begin a floating-point value (as in .12) or a dot-dot name, of
12649 which only .NOT., .TRUE., and .FALSE. are truly valid. Other sort-of-
12650 valid names represent binary operators, which are invalid here because
12651 there isn't an operand at the top of the stack. */
12652
12653 static ffelexHandler
12654 ffeexpr_token_period_ (ffelexToken t)
12655 {
12656 switch (ffelex_token_type (t))
12657 {
12658 case FFELEX_typeNAME:
12659 case FFELEX_typeNAMES:
12660 ffeexpr_current_dotdot_ = ffestr_other (t);
12661 switch (ffeexpr_current_dotdot_)
12662 {
12663 case FFESTR_otherNone:
12664 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
12665 {
12666 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
12667 ffelex_token_where_column (ffeexpr_tokens_[0]));
12668 ffebad_finish ();
12669 }
12670 ffelex_token_kill (ffeexpr_tokens_[0]);
12671 return (ffelexHandler) ffeexpr_token_rhs_ (t);
12672
12673 case FFESTR_otherTRUE:
12674 case FFESTR_otherFALSE:
12675 case FFESTR_otherNOT:
12676 ffeexpr_tokens_[1] = ffelex_token_use (t);
12677 return (ffelexHandler) ffeexpr_token_end_period_;
12678
12679 default:
12680 if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
12681 {
12682 ffebad_here (0, ffelex_token_where_line (t),
12683 ffelex_token_where_column (t));
12684 ffebad_finish ();
12685 }
12686 ffelex_token_kill (ffeexpr_tokens_[0]);
12687 return (ffelexHandler) ffeexpr_token_swallow_period_;
12688 }
12689 break; /* Nothing really reaches here. */
12690
12691 case FFELEX_typeNUMBER:
12692 ffeexpr_tokens_[1] = ffelex_token_use (t);
12693 return (ffelexHandler) ffeexpr_token_real_;
12694
12695 default:
12696 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
12697 {
12698 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
12699 ffelex_token_where_column (ffeexpr_tokens_[0]));
12700 ffebad_finish ();
12701 }
12702 ffelex_token_kill (ffeexpr_tokens_[0]);
12703 return (ffelexHandler) ffeexpr_token_rhs_ (t);
12704 }
12705 }
12706
12707 /* ffeexpr_token_end_period_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
12708
12709 Return a pointer to this function to the lexer (ffelex), which will
12710 invoke it for the next token.
12711
12712 Expecting a period to close a .NOT, .TRUE, or .FALSE at rhs (unary op
12713 or operator) state. If period isn't found, issue a diagnostic but
12714 pretend we saw one. ffeexpr_current_dotdot_ must already contained the
12715 dotdot representation of the name in between the two PERIOD tokens. */
12716
12717 static ffelexHandler
12718 ffeexpr_token_end_period_ (ffelexToken t)
12719 {
12720 ffeexprExpr_ e;
12721
12722 if (ffelex_token_type (t) != FFELEX_typePERIOD)
12723 {
12724 if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
12725 {
12726 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
12727 ffelex_token_where_column (ffeexpr_tokens_[0]));
12728 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
12729 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
12730 ffebad_finish ();
12731 }
12732 }
12733
12734 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill "NOT"/"TRUE"/"FALSE"
12735 token. */
12736
12737 e = ffeexpr_expr_new_ ();
12738 e->token = ffeexpr_tokens_[0];
12739
12740 switch (ffeexpr_current_dotdot_)
12741 {
12742 case FFESTR_otherNOT:
12743 e->type = FFEEXPR_exprtypeUNARY_;
12744 e->u.operator.op = FFEEXPR_operatorNOT_;
12745 e->u.operator.prec = FFEEXPR_operatorprecedenceNOT_;
12746 e->u.operator.as = FFEEXPR_operatorassociativityNOT_;
12747 ffeexpr_exprstack_push_unary_ (e);
12748 if (ffelex_token_type (t) != FFELEX_typePERIOD)
12749 return (ffelexHandler) ffeexpr_token_rhs_ (t);
12750 return (ffelexHandler) ffeexpr_token_rhs_;
12751
12752 case FFESTR_otherTRUE:
12753 e->type = FFEEXPR_exprtypeOPERAND_;
12754 e->u.operand
12755 = ffebld_new_conter (ffebld_constant_new_logicaldefault (TRUE));
12756 ffebld_set_info (e->u.operand,
12757 ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
12758 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
12759 ffeexpr_exprstack_push_operand_ (e);
12760 if (ffelex_token_type (t) != FFELEX_typePERIOD)
12761 return (ffelexHandler) ffeexpr_token_binary_ (t);
12762 return (ffelexHandler) ffeexpr_token_binary_;
12763
12764 case FFESTR_otherFALSE:
12765 e->type = FFEEXPR_exprtypeOPERAND_;
12766 e->u.operand
12767 = ffebld_new_conter (ffebld_constant_new_logicaldefault (FALSE));
12768 ffebld_set_info (e->u.operand,
12769 ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
12770 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
12771 ffeexpr_exprstack_push_operand_ (e);
12772 if (ffelex_token_type (t) != FFELEX_typePERIOD)
12773 return (ffelexHandler) ffeexpr_token_binary_ (t);
12774 return (ffelexHandler) ffeexpr_token_binary_;
12775
12776 default:
12777 assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL);
12778 exit (0);
12779 return NULL;
12780 }
12781 }
12782
12783 /* ffeexpr_token_swallow_period_ -- Rhs PERIOD NAME(not NOT, TRUE, or FALSE)
12784
12785 Return a pointer to this function to the lexer (ffelex), which will
12786 invoke it for the next token.
12787
12788 A diagnostic has already been issued; just swallow a period if there is
12789 one, then continue with ffeexpr_token_rhs_. */
12790
12791 static ffelexHandler
12792 ffeexpr_token_swallow_period_ (ffelexToken t)
12793 {
12794 if (ffelex_token_type (t) != FFELEX_typePERIOD)
12795 return (ffelexHandler) ffeexpr_token_rhs_ (t);
12796
12797 return (ffelexHandler) ffeexpr_token_rhs_;
12798 }
12799
12800 /* ffeexpr_token_real_ -- Rhs PERIOD NUMBER
12801
12802 Return a pointer to this function to the lexer (ffelex), which will
12803 invoke it for the next token.
12804
12805 After a period and a string of digits, check next token for possible
12806 exponent designation (D, E, or Q as first/only character) and continue
12807 real-number handling accordingly. Else form basic real constant, push
12808 onto expression stack, and enter binary state using current token (which,
12809 if it is a name not beginning with D, E, or Q, will certainly result
12810 in an error, but that's not for this routine to deal with). */
12811
12812 static ffelexHandler
12813 ffeexpr_token_real_ (ffelexToken t)
12814 {
12815 char d;
12816 const char *p;
12817
12818 if (((ffelex_token_type (t) != FFELEX_typeNAME)
12819 && (ffelex_token_type (t) != FFELEX_typeNAMES))
12820 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
12821 'D', 'd')
12822 || ffesrc_char_match_init (d, 'E', 'e')
12823 || ffesrc_char_match_init (d, 'Q', 'q')))
12824 && ffeexpr_isdigits_ (++p)))
12825 {
12826 #if 0
12827 /* This code has been removed because it seems inconsistent to
12828 produce a diagnostic in this case, but not all of the other
12829 ones that look for an exponent and cannot recognize one. */
12830 if (((ffelex_token_type (t) == FFELEX_typeNAME)
12831 || (ffelex_token_type (t) == FFELEX_typeNAMES))
12832 && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
12833 {
12834 char bad[2];
12835
12836 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
12837 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
12838 ffelex_token_where_column (ffeexpr_tokens_[0]));
12839 bad[0] = *(p - 1);
12840 bad[1] = '\0';
12841 ffebad_string (bad);
12842 ffebad_finish ();
12843 }
12844 #endif
12845 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
12846 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
12847 NULL, NULL, NULL);
12848
12849 ffelex_token_kill (ffeexpr_tokens_[0]);
12850 ffelex_token_kill (ffeexpr_tokens_[1]);
12851 return (ffelexHandler) ffeexpr_token_binary_ (t);
12852 }
12853
12854 /* Just exponent character by itself? In which case, PLUS or MINUS must
12855 surely be next, followed by a NUMBER token. */
12856
12857 if (*p == '\0')
12858 {
12859 ffeexpr_tokens_[2] = ffelex_token_use (t);
12860 return (ffelexHandler) ffeexpr_token_real_exponent_;
12861 }
12862
12863 ffeexpr_make_float_const_ (d, NULL, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
12864 t, NULL, NULL);
12865
12866 ffelex_token_kill (ffeexpr_tokens_[0]);
12867 ffelex_token_kill (ffeexpr_tokens_[1]);
12868 return (ffelexHandler) ffeexpr_token_binary_;
12869 }
12870
12871 /* ffeexpr_token_real_exponent_ -- Rhs PERIOD NUMBER NAME(D, E, or Q)
12872
12873 Return a pointer to this function to the lexer (ffelex), which will
12874 invoke it for the next token.
12875
12876 Ensures this token is PLUS or MINUS, preserves it, goes to final state
12877 for real number (exponent digits). Else issues diagnostic, assumes a
12878 zero exponent field for number, passes token on to binary state as if
12879 previous token had been "E0" instead of "E", for example. */
12880
12881 static ffelexHandler
12882 ffeexpr_token_real_exponent_ (ffelexToken t)
12883 {
12884 if ((ffelex_token_type (t) != FFELEX_typePLUS)
12885 && (ffelex_token_type (t) != FFELEX_typeMINUS))
12886 {
12887 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
12888 {
12889 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
12890 ffelex_token_where_column (ffeexpr_tokens_[2]));
12891 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
12892 ffebad_finish ();
12893 }
12894
12895 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
12896 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
12897 NULL, NULL, NULL);
12898
12899 ffelex_token_kill (ffeexpr_tokens_[0]);
12900 ffelex_token_kill (ffeexpr_tokens_[1]);
12901 ffelex_token_kill (ffeexpr_tokens_[2]);
12902 return (ffelexHandler) ffeexpr_token_binary_ (t);
12903 }
12904
12905 ffeexpr_tokens_[3] = ffelex_token_use (t);
12906 return (ffelexHandler) ffeexpr_token_real_exp_sign_;
12907 }
12908
12909 /* ffeexpr_token_real_exp_sign_ -- Rhs PERIOD NUMBER NAME(D,E,Q) PLUS/MINUS
12910
12911 Return a pointer to this function to the lexer (ffelex), which will
12912 invoke it for the next token.
12913
12914 Make sure token is a NUMBER, make a real constant out of all we have and
12915 push it onto the expression stack. Else issue diagnostic and pretend
12916 exponent field was a zero. */
12917
12918 static ffelexHandler
12919 ffeexpr_token_real_exp_sign_ (ffelexToken t)
12920 {
12921 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
12922 {
12923 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
12924 {
12925 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
12926 ffelex_token_where_column (ffeexpr_tokens_[2]));
12927 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
12928 ffebad_finish ();
12929 }
12930
12931 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
12932 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
12933 NULL, NULL, NULL);
12934
12935 ffelex_token_kill (ffeexpr_tokens_[0]);
12936 ffelex_token_kill (ffeexpr_tokens_[1]);
12937 ffelex_token_kill (ffeexpr_tokens_[2]);
12938 ffelex_token_kill (ffeexpr_tokens_[3]);
12939 return (ffelexHandler) ffeexpr_token_binary_ (t);
12940 }
12941
12942 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0], NULL,
12943 ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2],
12944 ffeexpr_tokens_[3], t);
12945
12946 ffelex_token_kill (ffeexpr_tokens_[0]);
12947 ffelex_token_kill (ffeexpr_tokens_[1]);
12948 ffelex_token_kill (ffeexpr_tokens_[2]);
12949 ffelex_token_kill (ffeexpr_tokens_[3]);
12950 return (ffelexHandler) ffeexpr_token_binary_;
12951 }
12952
12953 /* ffeexpr_token_number_ -- Rhs NUMBER
12954
12955 Return a pointer to this function to the lexer (ffelex), which will
12956 invoke it for the next token.
12957
12958 If the token is a period, we may have a floating-point number, or an
12959 integer followed by a dotdot binary operator. If the token is a name
12960 beginning with D, E, or Q, we definitely have a floating-point number.
12961 If the token is a hollerith constant, that's what we've got, so push
12962 it onto the expression stack and continue with the binary state.
12963
12964 Otherwise, we have an integer followed by something the binary state
12965 should be able to swallow. */
12966
12967 static ffelexHandler
12968 ffeexpr_token_number_ (ffelexToken t)
12969 {
12970 ffeexprExpr_ e;
12971 ffeinfo ni;
12972 char d;
12973 const char *p;
12974
12975 if (ffeexpr_hollerith_count_ > 0)
12976 ffelex_set_expecting_hollerith (0, '\0',
12977 ffewhere_line_unknown (),
12978 ffewhere_column_unknown ());
12979
12980 /* See if we've got a floating-point number here. */
12981
12982 switch (ffelex_token_type (t))
12983 {
12984 case FFELEX_typeNAME:
12985 case FFELEX_typeNAMES:
12986 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
12987 'D', 'd')
12988 || ffesrc_char_match_init (d, 'E', 'e')
12989 || ffesrc_char_match_init (d, 'Q', 'q'))
12990 && ffeexpr_isdigits_ (++p))
12991 {
12992
12993 /* Just exponent character by itself? In which case, PLUS or MINUS
12994 must surely be next, followed by a NUMBER token. */
12995
12996 if (*p == '\0')
12997 {
12998 ffeexpr_tokens_[1] = ffelex_token_use (t);
12999 return (ffelexHandler) ffeexpr_token_number_exponent_;
13000 }
13001 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], NULL, NULL, t,
13002 NULL, NULL);
13003
13004 ffelex_token_kill (ffeexpr_tokens_[0]);
13005 return (ffelexHandler) ffeexpr_token_binary_;
13006 }
13007 break;
13008
13009 case FFELEX_typePERIOD:
13010 ffeexpr_tokens_[1] = ffelex_token_use (t);
13011 return (ffelexHandler) ffeexpr_token_number_period_;
13012
13013 case FFELEX_typeHOLLERITH:
13014 e = ffeexpr_expr_new_ ();
13015 e->type = FFEEXPR_exprtypeOPERAND_;
13016 e->token = ffeexpr_tokens_[0];
13017 e->u.operand = ffebld_new_conter (ffebld_constant_new_hollerith (t));
13018 ni = ffeinfo_new (FFEINFO_basictypeHOLLERITH, FFEINFO_kindtypeNONE,
13019 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
13020 ffelex_token_length (t));
13021 ffebld_set_info (e->u.operand, ni);
13022 ffeexpr_exprstack_push_operand_ (e);
13023 return (ffelexHandler) ffeexpr_token_binary_;
13024
13025 default:
13026 break;
13027 }
13028
13029 /* Nothing specific we were looking for, so make an integer and pass the
13030 current token to the binary state. */
13031
13032 ffeexpr_make_float_const_ ('I', ffeexpr_tokens_[0], NULL, NULL,
13033 NULL, NULL, NULL);
13034 return (ffelexHandler) ffeexpr_token_binary_ (t);
13035 }
13036
13037 /* ffeexpr_token_number_exponent_ -- Rhs NUMBER NAME(D, E, or Q)
13038
13039 Return a pointer to this function to the lexer (ffelex), which will
13040 invoke it for the next token.
13041
13042 Ensures this token is PLUS or MINUS, preserves it, goes to final state
13043 for real number (exponent digits). Else treats number as integer, passes
13044 name to binary, passes current token to subsequent handler. */
13045
13046 static ffelexHandler
13047 ffeexpr_token_number_exponent_ (ffelexToken t)
13048 {
13049 if ((ffelex_token_type (t) != FFELEX_typePLUS)
13050 && (ffelex_token_type (t) != FFELEX_typeMINUS))
13051 {
13052 ffeexprExpr_ e;
13053 ffelexHandler nexthandler;
13054
13055 e = ffeexpr_expr_new_ ();
13056 e->type = FFEEXPR_exprtypeOPERAND_;
13057 e->token = ffeexpr_tokens_[0];
13058 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
13059 (ffeexpr_tokens_[0]));
13060 ffebld_set_info (e->u.operand,
13061 ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT,
13062 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13063 ffeexpr_exprstack_push_operand_ (e);
13064 nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[1]);
13065 ffelex_token_kill (ffeexpr_tokens_[1]);
13066 return (ffelexHandler) (*nexthandler) (t);
13067 }
13068
13069 ffeexpr_tokens_[2] = ffelex_token_use (t);
13070 return (ffelexHandler) ffeexpr_token_number_exp_sign_;
13071 }
13072
13073 /* ffeexpr_token_number_exp_sign_ -- Rhs NUMBER NAME(D,E,Q) PLUS/MINUS
13074
13075 Return a pointer to this function to the lexer (ffelex), which will
13076 invoke it for the next token.
13077
13078 Make sure token is a NUMBER, make a real constant out of all we have and
13079 push it onto the expression stack. Else issue diagnostic and pretend
13080 exponent field was a zero. */
13081
13082 static ffelexHandler
13083 ffeexpr_token_number_exp_sign_ (ffelexToken t)
13084 {
13085 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13086 {
13087 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13088 {
13089 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[1]),
13090 ffelex_token_where_column (ffeexpr_tokens_[1]));
13091 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13092 ffebad_finish ();
13093 }
13094
13095 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
13096 ffeexpr_tokens_[0], NULL, NULL,
13097 ffeexpr_tokens_[1], ffeexpr_tokens_[2],
13098 NULL);
13099
13100 ffelex_token_kill (ffeexpr_tokens_[0]);
13101 ffelex_token_kill (ffeexpr_tokens_[1]);
13102 ffelex_token_kill (ffeexpr_tokens_[2]);
13103 return (ffelexHandler) ffeexpr_token_binary_ (t);
13104 }
13105
13106 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
13107 ffeexpr_tokens_[0], NULL, NULL,
13108 ffeexpr_tokens_[1], ffeexpr_tokens_[2], t);
13109
13110 ffelex_token_kill (ffeexpr_tokens_[0]);
13111 ffelex_token_kill (ffeexpr_tokens_[1]);
13112 ffelex_token_kill (ffeexpr_tokens_[2]);
13113 return (ffelexHandler) ffeexpr_token_binary_;
13114 }
13115
13116 /* ffeexpr_token_number_period_ -- Rhs NUMBER PERIOD
13117
13118 Return a pointer to this function to the lexer (ffelex), which will
13119 invoke it for the next token.
13120
13121 Handle a period detected following a number at rhs state. Must begin a
13122 floating-point value (as in 1., 1.2, 1.E3, or 1.E+3) or a dot-dot name. */
13123
13124 static ffelexHandler
13125 ffeexpr_token_number_period_ (ffelexToken t)
13126 {
13127 ffeexprExpr_ e;
13128 ffelexHandler nexthandler;
13129 const char *p;
13130 char d;
13131
13132 switch (ffelex_token_type (t))
13133 {
13134 case FFELEX_typeNAME:
13135 case FFELEX_typeNAMES:
13136 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13137 'D', 'd')
13138 || ffesrc_char_match_init (d, 'E', 'e')
13139 || ffesrc_char_match_init (d, 'Q', 'q'))
13140 && ffeexpr_isdigits_ (++p))
13141 {
13142
13143 /* Just exponent character by itself? In which case, PLUS or MINUS
13144 must surely be next, followed by a NUMBER token. */
13145
13146 if (*p == '\0')
13147 {
13148 ffeexpr_tokens_[2] = ffelex_token_use (t);
13149 return (ffelexHandler) ffeexpr_token_number_per_exp_;
13150 }
13151 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0],
13152 ffeexpr_tokens_[1], NULL, t, NULL,
13153 NULL);
13154
13155 ffelex_token_kill (ffeexpr_tokens_[0]);
13156 ffelex_token_kill (ffeexpr_tokens_[1]);
13157 return (ffelexHandler) ffeexpr_token_binary_;
13158 }
13159 /* A name not representing an exponent, so assume it will be something
13160 like EQ, make an integer from the number, pass the period to binary
13161 state and the current token to the resulting state. */
13162
13163 e = ffeexpr_expr_new_ ();
13164 e->type = FFEEXPR_exprtypeOPERAND_;
13165 e->token = ffeexpr_tokens_[0];
13166 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
13167 (ffeexpr_tokens_[0]));
13168 ffebld_set_info (e->u.operand,
13169 ffeinfo_new (FFEINFO_basictypeINTEGER,
13170 FFEINFO_kindtypeINTEGERDEFAULT, 0,
13171 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
13172 FFETARGET_charactersizeNONE));
13173 ffeexpr_exprstack_push_operand_ (e);
13174 nexthandler = (ffelexHandler) ffeexpr_token_binary_
13175 (ffeexpr_tokens_[1]);
13176 ffelex_token_kill (ffeexpr_tokens_[1]);
13177 return (ffelexHandler) (*nexthandler) (t);
13178
13179 case FFELEX_typeNUMBER:
13180 ffeexpr_tokens_[2] = ffelex_token_use (t);
13181 return (ffelexHandler) ffeexpr_token_number_real_;
13182
13183 default:
13184 break;
13185 }
13186
13187 /* Nothing specific we were looking for, so make a real number and pass the
13188 period and then the current token to the binary state. */
13189
13190 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13191 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13192 NULL, NULL, NULL, NULL);
13193
13194 ffelex_token_kill (ffeexpr_tokens_[0]);
13195 ffelex_token_kill (ffeexpr_tokens_[1]);
13196 return (ffelexHandler) ffeexpr_token_binary_ (t);
13197 }
13198
13199 /* ffeexpr_token_number_per_exp_ -- Rhs NUMBER PERIOD NAME(D, E, or Q)
13200
13201 Return a pointer to this function to the lexer (ffelex), which will
13202 invoke it for the next token.
13203
13204 Ensures this token is PLUS or MINUS, preserves it, goes to final state
13205 for real number (exponent digits). Else treats number as real, passes
13206 name to binary, passes current token to subsequent handler. */
13207
13208 static ffelexHandler
13209 ffeexpr_token_number_per_exp_ (ffelexToken t)
13210 {
13211 if ((ffelex_token_type (t) != FFELEX_typePLUS)
13212 && (ffelex_token_type (t) != FFELEX_typeMINUS))
13213 {
13214 ffelexHandler nexthandler;
13215
13216 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13217 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13218 NULL, NULL, NULL, NULL);
13219
13220 ffelex_token_kill (ffeexpr_tokens_[0]);
13221 ffelex_token_kill (ffeexpr_tokens_[1]);
13222 nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[2]);
13223 ffelex_token_kill (ffeexpr_tokens_[2]);
13224 return (ffelexHandler) (*nexthandler) (t);
13225 }
13226
13227 ffeexpr_tokens_[3] = ffelex_token_use (t);
13228 return (ffelexHandler) ffeexpr_token_num_per_exp_sign_;
13229 }
13230
13231 /* ffeexpr_token_number_real_ -- Rhs NUMBER PERIOD NUMBER
13232
13233 Return a pointer to this function to the lexer (ffelex), which will
13234 invoke it for the next token.
13235
13236 After a number, period, and number, check next token for possible
13237 exponent designation (D, E, or Q as first/only character) and continue
13238 real-number handling accordingly. Else form basic real constant, push
13239 onto expression stack, and enter binary state using current token (which,
13240 if it is a name not beginning with D, E, or Q, will certainly result
13241 in an error, but that's not for this routine to deal with). */
13242
13243 static ffelexHandler
13244 ffeexpr_token_number_real_ (ffelexToken t)
13245 {
13246 char d;
13247 const char *p;
13248
13249 if (((ffelex_token_type (t) != FFELEX_typeNAME)
13250 && (ffelex_token_type (t) != FFELEX_typeNAMES))
13251 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13252 'D', 'd')
13253 || ffesrc_char_match_init (d, 'E', 'e')
13254 || ffesrc_char_match_init (d, 'Q', 'q')))
13255 && ffeexpr_isdigits_ (++p)))
13256 {
13257 #if 0
13258 /* This code has been removed because it seems inconsistent to
13259 produce a diagnostic in this case, but not all of the other
13260 ones that look for an exponent and cannot recognize one. */
13261 if (((ffelex_token_type (t) == FFELEX_typeNAME)
13262 || (ffelex_token_type (t) == FFELEX_typeNAMES))
13263 && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
13264 {
13265 char bad[2];
13266
13267 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13268 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
13269 ffelex_token_where_column (ffeexpr_tokens_[0]));
13270 bad[0] = *(p - 1);
13271 bad[1] = '\0';
13272 ffebad_string (bad);
13273 ffebad_finish ();
13274 }
13275 #endif
13276 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13277 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13278 ffeexpr_tokens_[2], NULL, NULL, NULL);
13279
13280 ffelex_token_kill (ffeexpr_tokens_[0]);
13281 ffelex_token_kill (ffeexpr_tokens_[1]);
13282 ffelex_token_kill (ffeexpr_tokens_[2]);
13283 return (ffelexHandler) ffeexpr_token_binary_ (t);
13284 }
13285
13286 /* Just exponent character by itself? In which case, PLUS or MINUS must
13287 surely be next, followed by a NUMBER token. */
13288
13289 if (*p == '\0')
13290 {
13291 ffeexpr_tokens_[3] = ffelex_token_use (t);
13292 return (ffelexHandler) ffeexpr_token_number_real_exp_;
13293 }
13294
13295 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13296 ffeexpr_tokens_[2], t, NULL, NULL);
13297
13298 ffelex_token_kill (ffeexpr_tokens_[0]);
13299 ffelex_token_kill (ffeexpr_tokens_[1]);
13300 ffelex_token_kill (ffeexpr_tokens_[2]);
13301 return (ffelexHandler) ffeexpr_token_binary_;
13302 }
13303
13304 /* ffeexpr_token_num_per_exp_sign_ -- Rhs NUMBER PERIOD NAME(D,E,Q) PLUS/MINUS
13305
13306 Return a pointer to this function to the lexer (ffelex), which will
13307 invoke it for the next token.
13308
13309 Make sure token is a NUMBER, make a real constant out of all we have and
13310 push it onto the expression stack. Else issue diagnostic and pretend
13311 exponent field was a zero. */
13312
13313 static ffelexHandler
13314 ffeexpr_token_num_per_exp_sign_ (ffelexToken t)
13315 {
13316 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13317 {
13318 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13319 {
13320 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
13321 ffelex_token_where_column (ffeexpr_tokens_[2]));
13322 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13323 ffebad_finish ();
13324 }
13325
13326 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13327 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13328 NULL, NULL, NULL, NULL);
13329
13330 ffelex_token_kill (ffeexpr_tokens_[0]);
13331 ffelex_token_kill (ffeexpr_tokens_[1]);
13332 ffelex_token_kill (ffeexpr_tokens_[2]);
13333 ffelex_token_kill (ffeexpr_tokens_[3]);
13334 return (ffelexHandler) ffeexpr_token_binary_ (t);
13335 }
13336
13337 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0],
13338 ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL,
13339 ffeexpr_tokens_[2], ffeexpr_tokens_[3], t);
13340
13341 ffelex_token_kill (ffeexpr_tokens_[0]);
13342 ffelex_token_kill (ffeexpr_tokens_[1]);
13343 ffelex_token_kill (ffeexpr_tokens_[2]);
13344 ffelex_token_kill (ffeexpr_tokens_[3]);
13345 return (ffelexHandler) ffeexpr_token_binary_;
13346 }
13347
13348 /* ffeexpr_token_number_real_exp_ -- Rhs NUMBER PERIOD NUMBER NAME(D, E, or Q)
13349
13350 Return a pointer to this function to the lexer (ffelex), which will
13351 invoke it for the next token.
13352
13353 Ensures this token is PLUS or MINUS, preserves it, goes to final state
13354 for real number (exponent digits). Else issues diagnostic, assumes a
13355 zero exponent field for number, passes token on to binary state as if
13356 previous token had been "E0" instead of "E", for example. */
13357
13358 static ffelexHandler
13359 ffeexpr_token_number_real_exp_ (ffelexToken t)
13360 {
13361 if ((ffelex_token_type (t) != FFELEX_typePLUS)
13362 && (ffelex_token_type (t) != FFELEX_typeMINUS))
13363 {
13364 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13365 {
13366 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
13367 ffelex_token_where_column (ffeexpr_tokens_[3]));
13368 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13369 ffebad_finish ();
13370 }
13371
13372 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13373 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13374 ffeexpr_tokens_[2], NULL, NULL, NULL);
13375
13376 ffelex_token_kill (ffeexpr_tokens_[0]);
13377 ffelex_token_kill (ffeexpr_tokens_[1]);
13378 ffelex_token_kill (ffeexpr_tokens_[2]);
13379 ffelex_token_kill (ffeexpr_tokens_[3]);
13380 return (ffelexHandler) ffeexpr_token_binary_ (t);
13381 }
13382
13383 ffeexpr_tokens_[4] = ffelex_token_use (t);
13384 return (ffelexHandler) ffeexpr_token_num_real_exp_sn_;
13385 }
13386
13387 /* ffeexpr_token_num_real_exp_sn_ -- Rhs NUMBER PERIOD NUMBER NAME(D,E,Q)
13388 PLUS/MINUS
13389
13390 Return a pointer to this function to the lexer (ffelex), which will
13391 invoke it for the next token.
13392
13393 Make sure token is a NUMBER, make a real constant out of all we have and
13394 push it onto the expression stack. Else issue diagnostic and pretend
13395 exponent field was a zero. */
13396
13397 static ffelexHandler
13398 ffeexpr_token_num_real_exp_sn_ (ffelexToken t)
13399 {
13400 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13401 {
13402 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13403 {
13404 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
13405 ffelex_token_where_column (ffeexpr_tokens_[3]));
13406 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13407 ffebad_finish ();
13408 }
13409
13410 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13411 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13412 ffeexpr_tokens_[2], NULL, NULL, NULL);
13413
13414 ffelex_token_kill (ffeexpr_tokens_[0]);
13415 ffelex_token_kill (ffeexpr_tokens_[1]);
13416 ffelex_token_kill (ffeexpr_tokens_[2]);
13417 ffelex_token_kill (ffeexpr_tokens_[3]);
13418 ffelex_token_kill (ffeexpr_tokens_[4]);
13419 return (ffelexHandler) ffeexpr_token_binary_ (t);
13420 }
13421
13422 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[3])[0],
13423 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13424 ffeexpr_tokens_[2], ffeexpr_tokens_[3],
13425 ffeexpr_tokens_[4], t);
13426
13427 ffelex_token_kill (ffeexpr_tokens_[0]);
13428 ffelex_token_kill (ffeexpr_tokens_[1]);
13429 ffelex_token_kill (ffeexpr_tokens_[2]);
13430 ffelex_token_kill (ffeexpr_tokens_[3]);
13431 ffelex_token_kill (ffeexpr_tokens_[4]);
13432 return (ffelexHandler) ffeexpr_token_binary_;
13433 }
13434
13435 /* ffeexpr_token_binary_ -- Handle binary operator possibility
13436
13437 Return a pointer to this function to the lexer (ffelex), which will
13438 invoke it for the next token.
13439
13440 The possibility of a binary operator is handled here, meaning the previous
13441 token was an operand. */
13442
13443 static ffelexHandler
13444 ffeexpr_token_binary_ (ffelexToken t)
13445 {
13446 ffeexprExpr_ e;
13447
13448 if (!ffeexpr_stack_->is_rhs)
13449 return (ffelexHandler) ffeexpr_finished_ (t); /* For now. */
13450
13451 switch (ffelex_token_type (t))
13452 {
13453 case FFELEX_typePLUS:
13454 e = ffeexpr_expr_new_ ();
13455 e->type = FFEEXPR_exprtypeBINARY_;
13456 e->token = ffelex_token_use (t);
13457 e->u.operator.op = FFEEXPR_operatorADD_;
13458 e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
13459 e->u.operator.as = FFEEXPR_operatorassociativityADD_;
13460 ffeexpr_exprstack_push_binary_ (e);
13461 return (ffelexHandler) ffeexpr_token_rhs_;
13462
13463 case FFELEX_typeMINUS:
13464 e = ffeexpr_expr_new_ ();
13465 e->type = FFEEXPR_exprtypeBINARY_;
13466 e->token = ffelex_token_use (t);
13467 e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
13468 e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
13469 e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
13470 ffeexpr_exprstack_push_binary_ (e);
13471 return (ffelexHandler) ffeexpr_token_rhs_;
13472
13473 case FFELEX_typeASTERISK:
13474 switch (ffeexpr_stack_->context)
13475 {
13476 case FFEEXPR_contextDATA:
13477 return (ffelexHandler) ffeexpr_finished_ (t);
13478
13479 default:
13480 break;
13481 }
13482 e = ffeexpr_expr_new_ ();
13483 e->type = FFEEXPR_exprtypeBINARY_;
13484 e->token = ffelex_token_use (t);
13485 e->u.operator.op = FFEEXPR_operatorMULTIPLY_;
13486 e->u.operator.prec = FFEEXPR_operatorprecedenceMULTIPLY_;
13487 e->u.operator.as = FFEEXPR_operatorassociativityMULTIPLY_;
13488 ffeexpr_exprstack_push_binary_ (e);
13489 return (ffelexHandler) ffeexpr_token_rhs_;
13490
13491 case FFELEX_typeSLASH:
13492 switch (ffeexpr_stack_->context)
13493 {
13494 case FFEEXPR_contextDATA:
13495 return (ffelexHandler) ffeexpr_finished_ (t);
13496
13497 default:
13498 break;
13499 }
13500 e = ffeexpr_expr_new_ ();
13501 e->type = FFEEXPR_exprtypeBINARY_;
13502 e->token = ffelex_token_use (t);
13503 e->u.operator.op = FFEEXPR_operatorDIVIDE_;
13504 e->u.operator.prec = FFEEXPR_operatorprecedenceDIVIDE_;
13505 e->u.operator.as = FFEEXPR_operatorassociativityDIVIDE_;
13506 ffeexpr_exprstack_push_binary_ (e);
13507 return (ffelexHandler) ffeexpr_token_rhs_;
13508
13509 case FFELEX_typePOWER:
13510 e = ffeexpr_expr_new_ ();
13511 e->type = FFEEXPR_exprtypeBINARY_;
13512 e->token = ffelex_token_use (t);
13513 e->u.operator.op = FFEEXPR_operatorPOWER_;
13514 e->u.operator.prec = FFEEXPR_operatorprecedencePOWER_;
13515 e->u.operator.as = FFEEXPR_operatorassociativityPOWER_;
13516 ffeexpr_exprstack_push_binary_ (e);
13517 return (ffelexHandler) ffeexpr_token_rhs_;
13518
13519 case FFELEX_typeCONCAT:
13520 e = ffeexpr_expr_new_ ();
13521 e->type = FFEEXPR_exprtypeBINARY_;
13522 e->token = ffelex_token_use (t);
13523 e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
13524 e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
13525 e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
13526 ffeexpr_exprstack_push_binary_ (e);
13527 return (ffelexHandler) ffeexpr_token_rhs_;
13528
13529 case FFELEX_typeOPEN_ANGLE:
13530 switch (ffeexpr_stack_->context)
13531 {
13532 case FFEEXPR_contextFORMAT:
13533 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13534 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13535 ffebad_finish ();
13536 break;
13537
13538 default:
13539 break;
13540 }
13541 e = ffeexpr_expr_new_ ();
13542 e->type = FFEEXPR_exprtypeBINARY_;
13543 e->token = ffelex_token_use (t);
13544 e->u.operator.op = FFEEXPR_operatorLT_;
13545 e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
13546 e->u.operator.as = FFEEXPR_operatorassociativityLT_;
13547 ffeexpr_exprstack_push_binary_ (e);
13548 return (ffelexHandler) ffeexpr_token_rhs_;
13549
13550 case FFELEX_typeCLOSE_ANGLE:
13551 switch (ffeexpr_stack_->context)
13552 {
13553 case FFEEXPR_contextFORMAT:
13554 return ffeexpr_finished_ (t);
13555
13556 default:
13557 break;
13558 }
13559 e = ffeexpr_expr_new_ ();
13560 e->type = FFEEXPR_exprtypeBINARY_;
13561 e->token = ffelex_token_use (t);
13562 e->u.operator.op = FFEEXPR_operatorGT_;
13563 e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
13564 e->u.operator.as = FFEEXPR_operatorassociativityGT_;
13565 ffeexpr_exprstack_push_binary_ (e);
13566 return (ffelexHandler) ffeexpr_token_rhs_;
13567
13568 case FFELEX_typeREL_EQ:
13569 switch (ffeexpr_stack_->context)
13570 {
13571 case FFEEXPR_contextFORMAT:
13572 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13573 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13574 ffebad_finish ();
13575 break;
13576
13577 default:
13578 break;
13579 }
13580 e = ffeexpr_expr_new_ ();
13581 e->type = FFEEXPR_exprtypeBINARY_;
13582 e->token = ffelex_token_use (t);
13583 e->u.operator.op = FFEEXPR_operatorEQ_;
13584 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
13585 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
13586 ffeexpr_exprstack_push_binary_ (e);
13587 return (ffelexHandler) ffeexpr_token_rhs_;
13588
13589 case FFELEX_typeREL_NE:
13590 switch (ffeexpr_stack_->context)
13591 {
13592 case FFEEXPR_contextFORMAT:
13593 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13594 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13595 ffebad_finish ();
13596 break;
13597
13598 default:
13599 break;
13600 }
13601 e = ffeexpr_expr_new_ ();
13602 e->type = FFEEXPR_exprtypeBINARY_;
13603 e->token = ffelex_token_use (t);
13604 e->u.operator.op = FFEEXPR_operatorNE_;
13605 e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
13606 e->u.operator.as = FFEEXPR_operatorassociativityNE_;
13607 ffeexpr_exprstack_push_binary_ (e);
13608 return (ffelexHandler) ffeexpr_token_rhs_;
13609
13610 case FFELEX_typeREL_LE:
13611 switch (ffeexpr_stack_->context)
13612 {
13613 case FFEEXPR_contextFORMAT:
13614 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13615 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13616 ffebad_finish ();
13617 break;
13618
13619 default:
13620 break;
13621 }
13622 e = ffeexpr_expr_new_ ();
13623 e->type = FFEEXPR_exprtypeBINARY_;
13624 e->token = ffelex_token_use (t);
13625 e->u.operator.op = FFEEXPR_operatorLE_;
13626 e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
13627 e->u.operator.as = FFEEXPR_operatorassociativityLE_;
13628 ffeexpr_exprstack_push_binary_ (e);
13629 return (ffelexHandler) ffeexpr_token_rhs_;
13630
13631 case FFELEX_typeREL_GE:
13632 switch (ffeexpr_stack_->context)
13633 {
13634 case FFEEXPR_contextFORMAT:
13635 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13636 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13637 ffebad_finish ();
13638 break;
13639
13640 default:
13641 break;
13642 }
13643 e = ffeexpr_expr_new_ ();
13644 e->type = FFEEXPR_exprtypeBINARY_;
13645 e->token = ffelex_token_use (t);
13646 e->u.operator.op = FFEEXPR_operatorGE_;
13647 e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
13648 e->u.operator.as = FFEEXPR_operatorassociativityGE_;
13649 ffeexpr_exprstack_push_binary_ (e);
13650 return (ffelexHandler) ffeexpr_token_rhs_;
13651
13652 case FFELEX_typePERIOD:
13653 ffeexpr_tokens_[0] = ffelex_token_use (t);
13654 return (ffelexHandler) ffeexpr_token_binary_period_;
13655
13656 #if 0
13657 case FFELEX_typeOPEN_PAREN:
13658 case FFELEX_typeCLOSE_PAREN:
13659 case FFELEX_typeEQUALS:
13660 case FFELEX_typePOINTS:
13661 case FFELEX_typeCOMMA:
13662 case FFELEX_typeCOLON:
13663 case FFELEX_typeEOS:
13664 case FFELEX_typeSEMICOLON:
13665 case FFELEX_typeNAME:
13666 case FFELEX_typeNAMES:
13667 #endif
13668 default:
13669 return (ffelexHandler) ffeexpr_finished_ (t);
13670 }
13671 }
13672
13673 /* ffeexpr_token_binary_period_ -- Binary PERIOD
13674
13675 Return a pointer to this function to the lexer (ffelex), which will
13676 invoke it for the next token.
13677
13678 Handle a period detected at binary (expecting binary op or end) state.
13679 Must begin a dot-dot name, of which .NOT., .TRUE., and .FALSE. are not
13680 valid. */
13681
13682 static ffelexHandler
13683 ffeexpr_token_binary_period_ (ffelexToken t)
13684 {
13685 ffeexprExpr_ operand;
13686
13687 switch (ffelex_token_type (t))
13688 {
13689 case FFELEX_typeNAME:
13690 case FFELEX_typeNAMES:
13691 ffeexpr_current_dotdot_ = ffestr_other (t);
13692 switch (ffeexpr_current_dotdot_)
13693 {
13694 case FFESTR_otherTRUE:
13695 case FFESTR_otherFALSE:
13696 case FFESTR_otherNOT:
13697 if (ffest_ffebad_start (FFEBAD_MISSING_BINARY_OPERATOR))
13698 {
13699 operand = ffeexpr_stack_->exprstack;
13700 assert (operand != NULL);
13701 assert (operand->type == FFEEXPR_exprtypeOPERAND_);
13702 ffebad_here (0, ffelex_token_where_line (operand->token), ffelex_token_where_column (operand->token));
13703 ffebad_here (1, ffelex_token_where_line (t),
13704 ffelex_token_where_column (t));
13705 ffebad_finish ();
13706 }
13707 ffelex_token_kill (ffeexpr_tokens_[0]);
13708 return (ffelexHandler) ffeexpr_token_binary_sw_per_;
13709
13710 default:
13711 ffeexpr_tokens_[1] = ffelex_token_use (t);
13712 return (ffelexHandler) ffeexpr_token_binary_end_per_;
13713 }
13714 break; /* Nothing really reaches here. */
13715
13716 default:
13717 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
13718 {
13719 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13720 ffelex_token_where_column (ffeexpr_tokens_[0]));
13721 ffebad_finish ();
13722 }
13723 ffelex_token_kill (ffeexpr_tokens_[0]);
13724 return (ffelexHandler) ffeexpr_token_binary_ (t);
13725 }
13726 }
13727
13728 /* ffeexpr_token_binary_end_per_ -- Binary PERIOD NAME(not NOT, TRUE, or FALSE)
13729
13730 Return a pointer to this function to the lexer (ffelex), which will
13731 invoke it for the next token.
13732
13733 Expecting a period to close a dot-dot at binary (binary op
13734 or operator) state. If period isn't found, issue a diagnostic but
13735 pretend we saw one. ffeexpr_current_dotdot_ must already contained the
13736 dotdot representation of the name in between the two PERIOD tokens. */
13737
13738 static ffelexHandler
13739 ffeexpr_token_binary_end_per_ (ffelexToken t)
13740 {
13741 ffeexprExpr_ e;
13742
13743 e = ffeexpr_expr_new_ ();
13744 e->type = FFEEXPR_exprtypeBINARY_;
13745 e->token = ffeexpr_tokens_[0];
13746
13747 switch (ffeexpr_current_dotdot_)
13748 {
13749 case FFESTR_otherAND:
13750 e->u.operator.op = FFEEXPR_operatorAND_;
13751 e->u.operator.prec = FFEEXPR_operatorprecedenceAND_;
13752 e->u.operator.as = FFEEXPR_operatorassociativityAND_;
13753 break;
13754
13755 case FFESTR_otherOR:
13756 e->u.operator.op = FFEEXPR_operatorOR_;
13757 e->u.operator.prec = FFEEXPR_operatorprecedenceOR_;
13758 e->u.operator.as = FFEEXPR_operatorassociativityOR_;
13759 break;
13760
13761 case FFESTR_otherXOR:
13762 e->u.operator.op = FFEEXPR_operatorXOR_;
13763 e->u.operator.prec = FFEEXPR_operatorprecedenceXOR_;
13764 e->u.operator.as = FFEEXPR_operatorassociativityXOR_;
13765 break;
13766
13767 case FFESTR_otherEQV:
13768 e->u.operator.op = FFEEXPR_operatorEQV_;
13769 e->u.operator.prec = FFEEXPR_operatorprecedenceEQV_;
13770 e->u.operator.as = FFEEXPR_operatorassociativityEQV_;
13771 break;
13772
13773 case FFESTR_otherNEQV:
13774 e->u.operator.op = FFEEXPR_operatorNEQV_;
13775 e->u.operator.prec = FFEEXPR_operatorprecedenceNEQV_;
13776 e->u.operator.as = FFEEXPR_operatorassociativityNEQV_;
13777 break;
13778
13779 case FFESTR_otherLT:
13780 e->u.operator.op = FFEEXPR_operatorLT_;
13781 e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
13782 e->u.operator.as = FFEEXPR_operatorassociativityLT_;
13783 break;
13784
13785 case FFESTR_otherLE:
13786 e->u.operator.op = FFEEXPR_operatorLE_;
13787 e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
13788 e->u.operator.as = FFEEXPR_operatorassociativityLE_;
13789 break;
13790
13791 case FFESTR_otherEQ:
13792 e->u.operator.op = FFEEXPR_operatorEQ_;
13793 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
13794 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
13795 break;
13796
13797 case FFESTR_otherNE:
13798 e->u.operator.op = FFEEXPR_operatorNE_;
13799 e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
13800 e->u.operator.as = FFEEXPR_operatorassociativityNE_;
13801 break;
13802
13803 case FFESTR_otherGT:
13804 e->u.operator.op = FFEEXPR_operatorGT_;
13805 e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
13806 e->u.operator.as = FFEEXPR_operatorassociativityGT_;
13807 break;
13808
13809 case FFESTR_otherGE:
13810 e->u.operator.op = FFEEXPR_operatorGE_;
13811 e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
13812 e->u.operator.as = FFEEXPR_operatorassociativityGE_;
13813 break;
13814
13815 default:
13816 if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT))
13817 {
13818 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13819 ffelex_token_where_column (ffeexpr_tokens_[0]));
13820 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
13821 ffebad_finish ();
13822 }
13823 e->u.operator.op = FFEEXPR_operatorEQ_;
13824 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
13825 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
13826 break;
13827 }
13828
13829 ffeexpr_exprstack_push_binary_ (e);
13830
13831 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13832 {
13833 if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
13834 {
13835 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13836 ffelex_token_where_column (ffeexpr_tokens_[0]));
13837 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13838 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
13839 ffebad_finish ();
13840 }
13841 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */
13842 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13843 }
13844
13845 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */
13846 return (ffelexHandler) ffeexpr_token_rhs_;
13847 }
13848
13849 /* ffeexpr_token_binary_sw_per_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
13850
13851 Return a pointer to this function to the lexer (ffelex), which will
13852 invoke it for the next token.
13853
13854 A diagnostic has already been issued; just swallow a period if there is
13855 one, then continue with ffeexpr_token_binary_. */
13856
13857 static ffelexHandler
13858 ffeexpr_token_binary_sw_per_ (ffelexToken t)
13859 {
13860 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13861 return (ffelexHandler) ffeexpr_token_binary_ (t);
13862
13863 return (ffelexHandler) ffeexpr_token_binary_;
13864 }
13865
13866 /* ffeexpr_token_quote_ -- Rhs QUOTE
13867
13868 Return a pointer to this function to the lexer (ffelex), which will
13869 invoke it for the next token.
13870
13871 Expecting a NUMBER that we'll treat as an octal integer. */
13872
13873 static ffelexHandler
13874 ffeexpr_token_quote_ (ffelexToken t)
13875 {
13876 ffeexprExpr_ e;
13877 ffebld anyexpr;
13878
13879 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13880 {
13881 if (ffest_ffebad_start (FFEBAD_QUOTE_MISSES_DIGITS))
13882 {
13883 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13884 ffelex_token_where_column (ffeexpr_tokens_[0]));
13885 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13886 ffebad_finish ();
13887 }
13888 ffelex_token_kill (ffeexpr_tokens_[0]);
13889 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13890 }
13891
13892 /* This is kind of a kludge to prevent any whining about magical numbers
13893 that start out as these octal integers, so "20000000000 (on a 32-bit
13894 2's-complement machine) by itself won't produce an error. */
13895
13896 anyexpr = ffebld_new_any ();
13897 ffebld_set_info (anyexpr, ffeinfo_new_any ());
13898
13899 e = ffeexpr_expr_new_ ();
13900 e->type = FFEEXPR_exprtypeOPERAND_;
13901 e->token = ffeexpr_tokens_[0];
13902 e->u.operand = ffebld_new_conter_with_orig
13903 (ffebld_constant_new_integeroctal (t), anyexpr);
13904 ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER,
13905 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY,
13906 FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13907 ffeexpr_exprstack_push_operand_ (e);
13908 return (ffelexHandler) ffeexpr_token_binary_;
13909 }
13910
13911 /* ffeexpr_token_apostrophe_ -- Rhs APOSTROPHE
13912
13913 Return a pointer to this function to the lexer (ffelex), which will
13914 invoke it for the next token.
13915
13916 Handle an open-apostrophe, which begins either a character ('char-const'),
13917 typeless octal ('octal-const'O), or typeless hexadecimal ('hex-const'Z or
13918 'hex-const'X) constant. */
13919
13920 static ffelexHandler
13921 ffeexpr_token_apostrophe_ (ffelexToken t)
13922 {
13923 assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
13924 if (ffe_is_pedantic_not_90 () && (ffelex_token_length (t) == 0))
13925 {
13926 ffebad_start (FFEBAD_NULL_CHAR_CONST);
13927 ffebad_here (0, ffelex_token_where_line (t),
13928 ffelex_token_where_column (t));
13929 ffebad_finish ();
13930 }
13931 ffeexpr_tokens_[1] = ffelex_token_use (t);
13932 return (ffelexHandler) ffeexpr_token_apos_char_;
13933 }
13934
13935 /* ffeexpr_token_apos_char_ -- Rhs APOSTROPHE CHARACTER
13936
13937 Return a pointer to this function to the lexer (ffelex), which will
13938 invoke it for the next token.
13939
13940 Close-apostrophe is implicit; if this token is NAME, it is a possible
13941 typeless-constant radix specifier. */
13942
13943 static ffelexHandler
13944 ffeexpr_token_apos_char_ (ffelexToken t)
13945 {
13946 ffeexprExpr_ e;
13947 ffeinfo ni;
13948 char c;
13949 ffetargetCharacterSize size;
13950
13951 if ((ffelex_token_type (t) == FFELEX_typeNAME)
13952 || (ffelex_token_type (t) == FFELEX_typeNAMES))
13953 {
13954 if ((ffelex_token_length (t) == 1)
13955 && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]), 'B',
13956 'b')
13957 || ffesrc_char_match_init (c, 'O', 'o')
13958 || ffesrc_char_match_init (c, 'X', 'x')
13959 || ffesrc_char_match_init (c, 'Z', 'z')))
13960 {
13961 e = ffeexpr_expr_new_ ();
13962 e->type = FFEEXPR_exprtypeOPERAND_;
13963 e->token = ffeexpr_tokens_[0];
13964 switch (c)
13965 {
13966 case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
13967 e->u.operand = ffebld_new_conter
13968 (ffebld_constant_new_typeless_bv (ffeexpr_tokens_[1]));
13969 size = ffetarget_size_typeless_binary (ffeexpr_tokens_[1]);
13970 break;
13971
13972 case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
13973 e->u.operand = ffebld_new_conter
13974 (ffebld_constant_new_typeless_ov (ffeexpr_tokens_[1]));
13975 size = ffetarget_size_typeless_octal (ffeexpr_tokens_[1]);
13976 break;
13977
13978 case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
13979 e->u.operand = ffebld_new_conter
13980 (ffebld_constant_new_typeless_hxv (ffeexpr_tokens_[1]));
13981 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
13982 break;
13983
13984 case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
13985 e->u.operand = ffebld_new_conter
13986 (ffebld_constant_new_typeless_hzv (ffeexpr_tokens_[1]));
13987 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
13988 break;
13989
13990 default:
13991 no_match: /* :::::::::::::::::::: */
13992 assert ("not BOXZ!" == NULL);
13993 size = 0;
13994 break;
13995 }
13996 ffebld_set_info (e->u.operand,
13997 ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
13998 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
13999 ffeexpr_exprstack_push_operand_ (e);
14000 ffelex_token_kill (ffeexpr_tokens_[1]);
14001 return (ffelexHandler) ffeexpr_token_binary_;
14002 }
14003 }
14004 e = ffeexpr_expr_new_ ();
14005 e->type = FFEEXPR_exprtypeOPERAND_;
14006 e->token = ffeexpr_tokens_[0];
14007 e->u.operand = ffebld_new_conter (ffebld_constant_new_characterdefault
14008 (ffeexpr_tokens_[1]));
14009 ni = ffeinfo_new (FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTERDEFAULT,
14010 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14011 ffelex_token_length (ffeexpr_tokens_[1]));
14012 ffebld_set_info (e->u.operand, ni);
14013 ffelex_token_kill (ffeexpr_tokens_[1]);
14014 ffeexpr_exprstack_push_operand_ (e);
14015 if ((ffelex_token_type (t) == FFELEX_typeNAME)
14016 || (ffelex_token_type (t) == FFELEX_typeNAMES))
14017 {
14018 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14019 {
14020 ffebad_string (ffelex_token_text (t));
14021 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14022 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
14023 ffelex_token_where_column (ffeexpr_tokens_[0]));
14024 ffebad_finish ();
14025 }
14026 e = ffeexpr_expr_new_ ();
14027 e->type = FFEEXPR_exprtypeBINARY_;
14028 e->token = ffelex_token_use (t);
14029 e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
14030 e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
14031 e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
14032 ffeexpr_exprstack_push_binary_ (e);
14033 return (ffelexHandler) ffeexpr_token_rhs_ (t);
14034 }
14035 ffeexpr_is_substr_ok_ = !ffe_is_pedantic_not_90 (); /* Allow "'hello'(3:5)". */
14036 return (ffelexHandler) ffeexpr_token_substrp_ (t);
14037 }
14038
14039 /* ffeexpr_token_name_lhs_ -- Lhs NAME
14040
14041 Return a pointer to this function to the lexer (ffelex), which will
14042 invoke it for the next token.
14043
14044 Handle a name followed by open-paren, period (RECORD.MEMBER), percent
14045 (RECORD%MEMBER), or nothing at all. */
14046
14047 static ffelexHandler
14048 ffeexpr_token_name_lhs_ (ffelexToken t)
14049 {
14050 ffeexprExpr_ e;
14051 ffeexprParenType_ paren_type;
14052 ffesymbol s;
14053 ffebld expr;
14054 ffeinfo info;
14055
14056 switch (ffelex_token_type (t))
14057 {
14058 case FFELEX_typeOPEN_PAREN:
14059 switch (ffeexpr_stack_->context)
14060 {
14061 case FFEEXPR_contextASSIGN:
14062 case FFEEXPR_contextAGOTO:
14063 case FFEEXPR_contextFILEUNIT_DF:
14064 goto just_name; /* :::::::::::::::::::: */
14065
14066 default:
14067 break;
14068 }
14069 e = ffeexpr_expr_new_ ();
14070 e->type = FFEEXPR_exprtypeOPERAND_;
14071 e->token = ffelex_token_use (ffeexpr_tokens_[0]);
14072 s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], FALSE,
14073 &paren_type);
14074
14075 switch (ffesymbol_where (s))
14076 {
14077 case FFEINFO_whereLOCAL:
14078 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14079 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recursion. */
14080 break;
14081
14082 case FFEINFO_whereINTRINSIC:
14083 case FFEINFO_whereGLOBAL:
14084 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
14085 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */
14086 break;
14087
14088 case FFEINFO_whereCOMMON:
14089 case FFEINFO_whereDUMMY:
14090 case FFEINFO_whereRESULT:
14091 break;
14092
14093 case FFEINFO_whereNONE:
14094 case FFEINFO_whereANY:
14095 break;
14096
14097 default:
14098 ffesymbol_error (s, ffeexpr_tokens_[0]);
14099 break;
14100 }
14101
14102 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14103 {
14104 e->u.operand = ffebld_new_any ();
14105 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14106 }
14107 else
14108 {
14109 e->u.operand = ffebld_new_symter (s,
14110 ffesymbol_generic (s),
14111 ffesymbol_specific (s),
14112 ffesymbol_implementation (s));
14113 ffebld_set_info (e->u.operand, ffesymbol_info (s));
14114 }
14115 ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */
14116 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
14117 switch (paren_type)
14118 {
14119 case FFEEXPR_parentypeSUBROUTINE_:
14120 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14121 return
14122 (ffelexHandler)
14123 ffeexpr_rhs (ffeexpr_stack_->pool,
14124 FFEEXPR_contextACTUALARG_,
14125 ffeexpr_token_arguments_);
14126
14127 case FFEEXPR_parentypeARRAY_:
14128 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14129 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
14130 ffeexpr_stack_->rank = 0;
14131 ffeexpr_stack_->constant = TRUE;
14132 ffeexpr_stack_->immediate = TRUE;
14133 switch (ffeexpr_stack_->context)
14134 {
14135 case FFEEXPR_contextDATAIMPDOITEM_:
14136 return
14137 (ffelexHandler)
14138 ffeexpr_rhs (ffeexpr_stack_->pool,
14139 FFEEXPR_contextDATAIMPDOINDEX_,
14140 ffeexpr_token_elements_);
14141
14142 case FFEEXPR_contextEQUIVALENCE:
14143 return
14144 (ffelexHandler)
14145 ffeexpr_rhs (ffeexpr_stack_->pool,
14146 FFEEXPR_contextEQVINDEX_,
14147 ffeexpr_token_elements_);
14148
14149 default:
14150 return
14151 (ffelexHandler)
14152 ffeexpr_rhs (ffeexpr_stack_->pool,
14153 FFEEXPR_contextINDEX_,
14154 ffeexpr_token_elements_);
14155 }
14156
14157 case FFEEXPR_parentypeSUBSTRING_:
14158 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
14159 ffeexpr_tokens_[0]);
14160 return
14161 (ffelexHandler)
14162 ffeexpr_rhs (ffeexpr_stack_->pool,
14163 FFEEXPR_contextINDEX_,
14164 ffeexpr_token_substring_);
14165
14166 case FFEEXPR_parentypeEQUIVALENCE_:
14167 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14168 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
14169 ffeexpr_stack_->rank = 0;
14170 ffeexpr_stack_->constant = TRUE;
14171 ffeexpr_stack_->immediate = TRUE;
14172 return
14173 (ffelexHandler)
14174 ffeexpr_rhs (ffeexpr_stack_->pool,
14175 FFEEXPR_contextEQVINDEX_,
14176 ffeexpr_token_equivalence_);
14177
14178 case FFEEXPR_parentypeFUNCTION_: /* Invalid case. */
14179 case FFEEXPR_parentypeFUNSUBSTR_: /* Invalid case. */
14180 ffesymbol_error (s, ffeexpr_tokens_[0]);
14181 /* Fall through. */
14182 case FFEEXPR_parentypeANY_:
14183 e->u.operand = ffebld_new_any ();
14184 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14185 return
14186 (ffelexHandler)
14187 ffeexpr_rhs (ffeexpr_stack_->pool,
14188 FFEEXPR_contextACTUALARG_,
14189 ffeexpr_token_anything_);
14190
14191 default:
14192 assert ("bad paren type" == NULL);
14193 break;
14194 }
14195
14196 case FFELEX_typeEQUALS: /* As in "VAR=". */
14197 switch (ffeexpr_stack_->context)
14198 {
14199 case FFEEXPR_contextIMPDOITEM_: /* within
14200 "(,VAR=start,end[,incr])". */
14201 case FFEEXPR_contextIMPDOITEMDF_:
14202 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
14203 break;
14204
14205 case FFEEXPR_contextDATAIMPDOITEM_:
14206 ffeexpr_stack_->context = FFEEXPR_contextDATAIMPDOCTRL_;
14207 break;
14208
14209 default:
14210 break;
14211 }
14212 break;
14213
14214 #if 0
14215 case FFELEX_typePERIOD:
14216 case FFELEX_typePERCENT:
14217 assert ("FOO%, FOO. not yet supported!~~" == NULL);
14218 break;
14219 #endif
14220
14221 default:
14222 break;
14223 }
14224
14225 just_name: /* :::::::::::::::::::: */
14226 e = ffeexpr_expr_new_ ();
14227 e->type = FFEEXPR_exprtypeOPERAND_;
14228 e->token = ffeexpr_tokens_[0];
14229 s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0],
14230 (ffeexpr_stack_->context
14231 == FFEEXPR_contextSUBROUTINEREF));
14232
14233 switch (ffesymbol_where (s))
14234 {
14235 case FFEINFO_whereCONSTANT:
14236 if ((ffeexpr_stack_->context != FFEEXPR_contextPARAMETER)
14237 || (ffesymbol_kind (s) != FFEINFO_kindENTITY))
14238 ffesymbol_error (s, ffeexpr_tokens_[0]);
14239 break;
14240
14241 case FFEINFO_whereIMMEDIATE:
14242 if ((ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOCTRL_)
14243 && (ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOINDEX_))
14244 ffesymbol_error (s, ffeexpr_tokens_[0]);
14245 break;
14246
14247 case FFEINFO_whereLOCAL:
14248 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14249 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recurse!. */
14250 break;
14251
14252 case FFEINFO_whereINTRINSIC:
14253 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
14254 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */
14255 break;
14256
14257 default:
14258 break;
14259 }
14260
14261 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14262 {
14263 expr = ffebld_new_any ();
14264 info = ffeinfo_new_any ();
14265 ffebld_set_info (expr, info);
14266 }
14267 else
14268 {
14269 expr = ffebld_new_symter (s,
14270 ffesymbol_generic (s),
14271 ffesymbol_specific (s),
14272 ffesymbol_implementation (s));
14273 info = ffesymbol_info (s);
14274 ffebld_set_info (expr, info);
14275 if (ffesymbol_is_doiter (s))
14276 {
14277 ffebad_start (FFEBAD_DOITER);
14278 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14279 ffelex_token_where_column (ffeexpr_tokens_[0]));
14280 ffest_ffebad_here_doiter (1, s);
14281 ffebad_string (ffesymbol_text (s));
14282 ffebad_finish ();
14283 }
14284 expr = ffeexpr_collapse_symter (expr, ffeexpr_tokens_[0]);
14285 }
14286
14287 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14288 {
14289 if (ffebld_op (expr) == FFEBLD_opANY)
14290 {
14291 expr = ffebld_new_any ();
14292 ffebld_set_info (expr, ffeinfo_new_any ());
14293 }
14294 else
14295 {
14296 expr = ffebld_new_subrref (expr, NULL); /* No argument list. */
14297 if (ffesymbol_generic (s) != FFEINTRIN_genNONE)
14298 ffeintrin_fulfill_generic (&expr, &info, e->token);
14299 else if (ffesymbol_specific (s) != FFEINTRIN_specNONE)
14300 ffeintrin_fulfill_specific (&expr, &info, NULL, e->token);
14301 else
14302 ffeexpr_fulfill_call_ (&expr, e->token);
14303
14304 if (ffebld_op (expr) != FFEBLD_opANY)
14305 ffebld_set_info (expr,
14306 ffeinfo_new (ffeinfo_basictype (info),
14307 ffeinfo_kindtype (info),
14308 0,
14309 FFEINFO_kindENTITY,
14310 FFEINFO_whereFLEETING,
14311 ffeinfo_size (info)));
14312 else
14313 ffebld_set_info (expr, ffeinfo_new_any ());
14314 }
14315 }
14316
14317 e->u.operand = expr;
14318 ffeexpr_exprstack_push_operand_ (e);
14319 return (ffelexHandler) ffeexpr_finished_ (t);
14320 }
14321
14322 /* ffeexpr_token_name_arg_ -- Rhs NAME
14323
14324 Return a pointer to this function to the lexer (ffelex), which will
14325 invoke it for the next token.
14326
14327 Handle first token in an actual-arg (or possible actual-arg) context
14328 being a NAME, and use second token to refine the context. */
14329
14330 static ffelexHandler
14331 ffeexpr_token_name_arg_ (ffelexToken t)
14332 {
14333 switch (ffelex_token_type (t))
14334 {
14335 case FFELEX_typeCLOSE_PAREN:
14336 case FFELEX_typeCOMMA:
14337 switch (ffeexpr_stack_->context)
14338 {
14339 case FFEEXPR_contextINDEXORACTUALARG_:
14340 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
14341 break;
14342
14343 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
14344 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
14345 break;
14346
14347 default:
14348 break;
14349 }
14350 break;
14351
14352 default:
14353 switch (ffeexpr_stack_->context)
14354 {
14355 case FFEEXPR_contextACTUALARG_:
14356 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
14357 break;
14358
14359 case FFEEXPR_contextINDEXORACTUALARG_:
14360 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
14361 break;
14362
14363 case FFEEXPR_contextSFUNCDEFACTUALARG_:
14364 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
14365 break;
14366
14367 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
14368 ffeexpr_stack_->context
14369 = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
14370 break;
14371
14372 default:
14373 assert ("bad context in _name_arg_" == NULL);
14374 break;
14375 }
14376 break;
14377 }
14378
14379 return (ffelexHandler) ffeexpr_token_name_rhs_ (t);
14380 }
14381
14382 /* ffeexpr_token_name_rhs_ -- Rhs NAME
14383
14384 Return a pointer to this function to the lexer (ffelex), which will
14385 invoke it for the next token.
14386
14387 Handle a name followed by open-paren, apostrophe (O'octal-const',
14388 Z'hex-const', or X'hex-const'), period (RECORD.MEMBER).
14389
14390 26-Nov-91 JCB 1.2
14391 When followed by apostrophe or quote, set lex hexnum flag on so
14392 [0-9] as first char of next token seen as starting a potentially
14393 hex number (NAME).
14394 04-Oct-91 JCB 1.1
14395 In case of intrinsic, decorate its SYMTER with the type info for
14396 the specific intrinsic. */
14397
14398 static ffelexHandler
14399 ffeexpr_token_name_rhs_ (ffelexToken t)
14400 {
14401 ffeexprExpr_ e;
14402 ffeexprParenType_ paren_type;
14403 ffesymbol s;
14404 bool sfdef;
14405
14406 switch (ffelex_token_type (t))
14407 {
14408 case FFELEX_typeQUOTE:
14409 case FFELEX_typeAPOSTROPHE:
14410 ffeexpr_tokens_[1] = ffelex_token_use (t);
14411 ffelex_set_hexnum (TRUE);
14412 return (ffelexHandler) ffeexpr_token_name_apos_;
14413
14414 case FFELEX_typeOPEN_PAREN:
14415 e = ffeexpr_expr_new_ ();
14416 e->type = FFEEXPR_exprtypeOPERAND_;
14417 e->token = ffelex_token_use (ffeexpr_tokens_[0]);
14418 s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], TRUE,
14419 &paren_type);
14420 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14421 e->u.operand = ffebld_new_any ();
14422 else
14423 e->u.operand = ffebld_new_symter (s, ffesymbol_generic (s),
14424 ffesymbol_specific (s),
14425 ffesymbol_implementation (s));
14426 ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */
14427 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
14428 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
14429 {
14430 case FFEEXPR_contextSFUNCDEF:
14431 case FFEEXPR_contextSFUNCDEFINDEX_:
14432 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
14433 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
14434 sfdef = TRUE;
14435 break;
14436
14437 case FFEEXPR_contextSFUNCDEFACTUALARG_:
14438 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
14439 assert ("weird context!" == NULL);
14440 sfdef = FALSE;
14441 break;
14442
14443 default:
14444 sfdef = FALSE;
14445 break;
14446 }
14447 switch (paren_type)
14448 {
14449 case FFEEXPR_parentypeFUNCTION_:
14450 ffebld_set_info (e->u.operand, ffesymbol_info (s));
14451 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14452 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
14453 { /* A statement function. */
14454 ffeexpr_stack_->num_args
14455 = ffebld_list_length
14456 (ffeexpr_stack_->next_dummy
14457 = ffesymbol_dummyargs (s));
14458 ffeexpr_stack_->tokens[1] = NULL; /* !=NULL when > num_args. */
14459 }
14460 else if ((ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
14461 && !ffe_is_pedantic_not_90 ()
14462 && ((ffesymbol_implementation (s)
14463 == FFEINTRIN_impICHAR)
14464 || (ffesymbol_implementation (s)
14465 == FFEINTRIN_impIACHAR)
14466 || (ffesymbol_implementation (s)
14467 == FFEINTRIN_impLEN)))
14468 { /* Allow arbitrary concatenations. */
14469 return
14470 (ffelexHandler)
14471 ffeexpr_rhs (ffeexpr_stack_->pool,
14472 sfdef
14473 ? FFEEXPR_contextSFUNCDEF
14474 : FFEEXPR_contextLET,
14475 ffeexpr_token_arguments_);
14476 }
14477 return
14478 (ffelexHandler)
14479 ffeexpr_rhs (ffeexpr_stack_->pool,
14480 sfdef
14481 ? FFEEXPR_contextSFUNCDEFACTUALARG_
14482 : FFEEXPR_contextACTUALARG_,
14483 ffeexpr_token_arguments_);
14484
14485 case FFEEXPR_parentypeARRAY_:
14486 ffebld_set_info (e->u.operand,
14487 ffesymbol_info (ffebld_symter (e->u.operand)));
14488 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14489 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
14490 ffeexpr_stack_->rank = 0;
14491 ffeexpr_stack_->constant = TRUE;
14492 ffeexpr_stack_->immediate = TRUE;
14493 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
14494 sfdef
14495 ? FFEEXPR_contextSFUNCDEFINDEX_
14496 : FFEEXPR_contextINDEX_,
14497 ffeexpr_token_elements_);
14498
14499 case FFEEXPR_parentypeSUBSTRING_:
14500 ffebld_set_info (e->u.operand,
14501 ffesymbol_info (ffebld_symter (e->u.operand)));
14502 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
14503 ffeexpr_tokens_[0]);
14504 return
14505 (ffelexHandler)
14506 ffeexpr_rhs (ffeexpr_stack_->pool,
14507 sfdef
14508 ? FFEEXPR_contextSFUNCDEFINDEX_
14509 : FFEEXPR_contextINDEX_,
14510 ffeexpr_token_substring_);
14511
14512 case FFEEXPR_parentypeFUNSUBSTR_:
14513 return
14514 (ffelexHandler)
14515 ffeexpr_rhs (ffeexpr_stack_->pool,
14516 sfdef
14517 ? FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
14518 : FFEEXPR_contextINDEXORACTUALARG_,
14519 ffeexpr_token_funsubstr_);
14520
14521 case FFEEXPR_parentypeANY_:
14522 ffebld_set_info (e->u.operand, ffesymbol_info (s));
14523 return
14524 (ffelexHandler)
14525 ffeexpr_rhs (ffeexpr_stack_->pool,
14526 sfdef
14527 ? FFEEXPR_contextSFUNCDEFACTUALARG_
14528 : FFEEXPR_contextACTUALARG_,
14529 ffeexpr_token_anything_);
14530
14531 default:
14532 assert ("bad paren type" == NULL);
14533 break;
14534 }
14535
14536 case FFELEX_typeEQUALS: /* As in "VAR=". */
14537 switch (ffeexpr_stack_->context)
14538 {
14539 case FFEEXPR_contextIMPDOITEM_: /* "(,VAR=start,end[,incr])". */
14540 case FFEEXPR_contextIMPDOITEMDF_:
14541 ffeexpr_stack_->is_rhs = FALSE; /* Really an lhs construct. */
14542 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
14543 break;
14544
14545 default:
14546 break;
14547 }
14548 break;
14549
14550 #if 0
14551 case FFELEX_typePERIOD:
14552 case FFELEX_typePERCENT:
14553 ~~Support these two someday, though not required
14554 assert ("FOO%, FOO. not yet supported!~~" == NULL);
14555 break;
14556 #endif
14557
14558 default:
14559 break;
14560 }
14561
14562 switch (ffeexpr_stack_->context)
14563 {
14564 case FFEEXPR_contextINDEXORACTUALARG_:
14565 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
14566 assert ("strange context" == NULL);
14567 break;
14568
14569 default:
14570 break;
14571 }
14572
14573 e = ffeexpr_expr_new_ ();
14574 e->type = FFEEXPR_exprtypeOPERAND_;
14575 e->token = ffeexpr_tokens_[0];
14576 s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0], FALSE);
14577 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14578 {
14579 e->u.operand = ffebld_new_any ();
14580 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14581 }
14582 else
14583 {
14584 e->u.operand = ffebld_new_symter (s, FFEINTRIN_genNONE,
14585 ffesymbol_specific (s),
14586 ffesymbol_implementation (s));
14587 if (ffesymbol_specific (s) == FFEINTRIN_specNONE)
14588 ffebld_set_info (e->u.operand, ffeinfo_use (ffesymbol_info (s)));
14589 else
14590 { /* Decorate the SYMTER with the actual type
14591 of the intrinsic. */
14592 ffebld_set_info (e->u.operand, ffeinfo_new
14593 (ffeintrin_basictype (ffesymbol_specific (s)),
14594 ffeintrin_kindtype (ffesymbol_specific (s)),
14595 0,
14596 ffesymbol_kind (s),
14597 ffesymbol_where (s),
14598 FFETARGET_charactersizeNONE));
14599 }
14600 if (ffesymbol_is_doiter (s))
14601 ffebld_symter_set_is_doiter (e->u.operand, TRUE);
14602 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
14603 ffeexpr_tokens_[0]);
14604 }
14605 ffeexpr_exprstack_push_operand_ (e);
14606 return (ffelexHandler) ffeexpr_token_binary_ (t);
14607 }
14608
14609 /* ffeexpr_token_name_apos_ -- Rhs NAME APOSTROPHE
14610
14611 Return a pointer to this function to the lexer (ffelex), which will
14612 invoke it for the next token.
14613
14614 Expecting a NAME token, analyze the previous NAME token to see what kind,
14615 if any, typeless constant we've got.
14616
14617 01-Sep-90 JCB 1.1
14618 Expect a NAME instead of CHARACTER in this situation. */
14619
14620 static ffelexHandler
14621 ffeexpr_token_name_apos_ (ffelexToken t)
14622 {
14623 ffeexprExpr_ e;
14624
14625 ffelex_set_hexnum (FALSE);
14626
14627 switch (ffelex_token_type (t))
14628 {
14629 case FFELEX_typeNAME:
14630 ffeexpr_tokens_[2] = ffelex_token_use (t);
14631 return (ffelexHandler) ffeexpr_token_name_apos_name_;
14632
14633 default:
14634 break;
14635 }
14636
14637 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14638 {
14639 ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
14640 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14641 ffelex_token_where_column (ffeexpr_tokens_[0]));
14642 ffebad_here (1, ffelex_token_where_line (t),
14643 ffelex_token_where_column (t));
14644 ffebad_finish ();
14645 }
14646
14647 ffelex_token_kill (ffeexpr_tokens_[1]);
14648
14649 e = ffeexpr_expr_new_ ();
14650 e->type = FFEEXPR_exprtypeOPERAND_;
14651 e->u.operand = ffebld_new_any ();
14652 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14653 e->token = ffeexpr_tokens_[0];
14654 ffeexpr_exprstack_push_operand_ (e);
14655
14656 return (ffelexHandler) ffeexpr_token_binary_ (t);
14657 }
14658
14659 /* ffeexpr_token_name_apos_name_ -- Rhs NAME APOSTROPHE NAME
14660
14661 Return a pointer to this function to the lexer (ffelex), which will
14662 invoke it for the next token.
14663
14664 Expecting an APOSTROPHE token, analyze the previous NAME token to see
14665 what kind, if any, typeless constant we've got. */
14666
14667 static ffelexHandler
14668 ffeexpr_token_name_apos_name_ (ffelexToken t)
14669 {
14670 ffeexprExpr_ e;
14671 char c;
14672
14673 e = ffeexpr_expr_new_ ();
14674 e->type = FFEEXPR_exprtypeOPERAND_;
14675 e->token = ffeexpr_tokens_[0];
14676
14677 if ((ffelex_token_type (t) == ffelex_token_type (ffeexpr_tokens_[1]))
14678 && (ffelex_token_length (ffeexpr_tokens_[0]) == 1)
14679 && (ffesrc_char_match_init ((c = ffelex_token_text (ffeexpr_tokens_[0])[0]),
14680 'B', 'b')
14681 || ffesrc_char_match_init (c, 'O', 'o')
14682 || ffesrc_char_match_init (c, 'X', 'x')
14683 || ffesrc_char_match_init (c, 'Z', 'z')))
14684 {
14685 ffetargetCharacterSize size;
14686
14687 if (!ffe_is_typeless_boz ()) {
14688
14689 switch (c)
14690 {
14691 case FFESRC_CASE_MATCH_INIT ('B', 'b', imatch_b, no_imatch):
14692 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerbinary
14693 (ffeexpr_tokens_[2]));
14694 break;
14695
14696 case FFESRC_CASE_MATCH_INIT ('O', 'o', imatch_o, no_imatch):
14697 e->u.operand = ffebld_new_conter (ffebld_constant_new_integeroctal
14698 (ffeexpr_tokens_[2]));
14699 break;
14700
14701 case FFESRC_CASE_MATCH_INIT ('X', 'x', imatch_x, no_imatch):
14702 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
14703 (ffeexpr_tokens_[2]));
14704 break;
14705
14706 case FFESRC_CASE_MATCH_INIT ('Z', 'z', imatch_z, no_imatch):
14707 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
14708 (ffeexpr_tokens_[2]));
14709 break;
14710
14711 default:
14712 no_imatch: /* :::::::::::::::::::: */
14713 assert ("not BOXZ!" == NULL);
14714 abort ();
14715 }
14716
14717 ffebld_set_info (e->u.operand,
14718 ffeinfo_new (FFEINFO_basictypeINTEGER,
14719 FFEINFO_kindtypeINTEGERDEFAULT, 0,
14720 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14721 FFETARGET_charactersizeNONE));
14722 ffeexpr_exprstack_push_operand_ (e);
14723 ffelex_token_kill (ffeexpr_tokens_[1]);
14724 ffelex_token_kill (ffeexpr_tokens_[2]);
14725 return (ffelexHandler) ffeexpr_token_binary_;
14726 }
14727
14728 switch (c)
14729 {
14730 case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
14731 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_bm
14732 (ffeexpr_tokens_[2]));
14733 size = ffetarget_size_typeless_binary (ffeexpr_tokens_[2]);
14734 break;
14735
14736 case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
14737 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_om
14738 (ffeexpr_tokens_[2]));
14739 size = ffetarget_size_typeless_octal (ffeexpr_tokens_[2]);
14740 break;
14741
14742 case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
14743 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hxm
14744 (ffeexpr_tokens_[2]));
14745 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
14746 break;
14747
14748 case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
14749 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
14750 (ffeexpr_tokens_[2]));
14751 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
14752 break;
14753
14754 default:
14755 no_match: /* :::::::::::::::::::: */
14756 assert ("not BOXZ!" == NULL);
14757 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
14758 (ffeexpr_tokens_[2]));
14759 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
14760 break;
14761 }
14762 ffebld_set_info (e->u.operand,
14763 ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
14764 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
14765 ffeexpr_exprstack_push_operand_ (e);
14766 ffelex_token_kill (ffeexpr_tokens_[1]);
14767 ffelex_token_kill (ffeexpr_tokens_[2]);
14768 return (ffelexHandler) ffeexpr_token_binary_;
14769 }
14770
14771 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14772 {
14773 ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
14774 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14775 ffelex_token_where_column (ffeexpr_tokens_[0]));
14776 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14777 ffebad_finish ();
14778 }
14779
14780 ffelex_token_kill (ffeexpr_tokens_[1]);
14781 ffelex_token_kill (ffeexpr_tokens_[2]);
14782
14783 e->type = FFEEXPR_exprtypeOPERAND_;
14784 e->u.operand = ffebld_new_any ();
14785 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14786 e->token = ffeexpr_tokens_[0];
14787 ffeexpr_exprstack_push_operand_ (e);
14788
14789 switch (ffelex_token_type (t))
14790 {
14791 case FFELEX_typeAPOSTROPHE:
14792 case FFELEX_typeQUOTE:
14793 return (ffelexHandler) ffeexpr_token_binary_;
14794
14795 default:
14796 return (ffelexHandler) ffeexpr_token_binary_ (t);
14797 }
14798 }
14799
14800 /* ffeexpr_token_percent_ -- Rhs PERCENT
14801
14802 Handle a percent sign possibly followed by "LOC". If followed instead
14803 by "VAL", "REF", or "DESCR", issue an error message and substitute
14804 "LOC". If followed by something else, treat the percent sign as a
14805 spurious incorrect token and reprocess the token via _rhs_. */
14806
14807 static ffelexHandler
14808 ffeexpr_token_percent_ (ffelexToken t)
14809 {
14810 switch (ffelex_token_type (t))
14811 {
14812 case FFELEX_typeNAME:
14813 case FFELEX_typeNAMES:
14814 ffeexpr_stack_->percent = ffeexpr_percent_ (t);
14815 ffeexpr_tokens_[1] = ffelex_token_use (t);
14816 return (ffelexHandler) ffeexpr_token_percent_name_;
14817
14818 default:
14819 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
14820 {
14821 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14822 ffelex_token_where_column (ffeexpr_tokens_[0]));
14823 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
14824 ffelex_token_where_column (ffeexpr_stack_->first_token));
14825 ffebad_finish ();
14826 }
14827 ffelex_token_kill (ffeexpr_tokens_[0]);
14828 return (ffelexHandler) ffeexpr_token_rhs_ (t);
14829 }
14830 }
14831
14832 /* ffeexpr_token_percent_name_ -- Rhs PERCENT NAME
14833
14834 Make sure the token is OPEN_PAREN and prepare for the one-item list of
14835 LHS expressions. Else display an error message. */
14836
14837 static ffelexHandler
14838 ffeexpr_token_percent_name_ (ffelexToken t)
14839 {
14840 ffelexHandler nexthandler;
14841
14842 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
14843 {
14844 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
14845 {
14846 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14847 ffelex_token_where_column (ffeexpr_tokens_[0]));
14848 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
14849 ffelex_token_where_column (ffeexpr_stack_->first_token));
14850 ffebad_finish ();
14851 }
14852 ffelex_token_kill (ffeexpr_tokens_[0]);
14853 nexthandler = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_tokens_[1]);
14854 ffelex_token_kill (ffeexpr_tokens_[1]);
14855 return (ffelexHandler) (*nexthandler) (t);
14856 }
14857
14858 switch (ffeexpr_stack_->percent)
14859 {
14860 default:
14861 if (ffest_ffebad_start (FFEBAD_INVALID_PERCENT))
14862 {
14863 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14864 ffelex_token_where_column (ffeexpr_tokens_[0]));
14865 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
14866 ffebad_finish ();
14867 }
14868 ffeexpr_stack_->percent = FFEEXPR_percentLOC_;
14869 /* Fall through. */
14870 case FFEEXPR_percentLOC_:
14871 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
14872 ffelex_token_kill (ffeexpr_tokens_[1]);
14873 ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
14874 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
14875 FFEEXPR_contextLOC_,
14876 ffeexpr_cb_end_loc_);
14877 }
14878 }
14879
14880 /* ffeexpr_make_float_const_ -- Make a floating-point constant
14881
14882 See prototype.
14883
14884 Pass 'E', 'D', or 'Q' for exponent letter. */
14885
14886 static void
14887 ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
14888 ffelexToken decimal, ffelexToken fraction,
14889 ffelexToken exponent, ffelexToken exponent_sign,
14890 ffelexToken exponent_digits)
14891 {
14892 ffeexprExpr_ e;
14893
14894 e = ffeexpr_expr_new_ ();
14895 e->type = FFEEXPR_exprtypeOPERAND_;
14896 if (integer != NULL)
14897 e->token = ffelex_token_use (integer);
14898 else
14899 {
14900 assert (decimal != NULL);
14901 e->token = ffelex_token_use (decimal);
14902 }
14903
14904 switch (exp_letter)
14905 {
14906 #if !FFETARGET_okREALQUAD
14907 case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
14908 if (ffebad_start (FFEBAD_QUAD_UNSUPPORTED))
14909 {
14910 ffebad_here (0, ffelex_token_where_line (e->token),
14911 ffelex_token_where_column (e->token));
14912 ffebad_finish ();
14913 }
14914 goto match_d; /* The FFESRC_CASE_* macros don't
14915 allow fall-through! */
14916 #endif
14917
14918 case FFESRC_CASE_MATCH_INIT ('D', 'd', match_d, no_match):
14919 e->u.operand = ffebld_new_conter (ffebld_constant_new_realdouble
14920 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
14921 ffebld_set_info (e->u.operand,
14922 ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
14923 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14924 break;
14925
14926 case FFESRC_CASE_MATCH_INIT ('E', 'e', match_e, no_match):
14927 e->u.operand = ffebld_new_conter (ffebld_constant_new_realdefault
14928 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
14929 ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeREAL,
14930 FFEINFO_kindtypeREALDEFAULT, 0, FFEINFO_kindENTITY,
14931 FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14932 break;
14933
14934 #if FFETARGET_okREALQUAD
14935 case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
14936 e->u.operand = ffebld_new_conter (ffebld_constant_new_realquad
14937 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
14938 ffebld_set_info (e->u.operand,
14939 ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALQUAD,
14940 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14941 break;
14942 #endif
14943
14944 case 'I': /* Make an integer. */
14945 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
14946 (ffeexpr_tokens_[0]));
14947 ffebld_set_info (e->u.operand,
14948 ffeinfo_new (FFEINFO_basictypeINTEGER,
14949 FFEINFO_kindtypeINTEGERDEFAULT, 0,
14950 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14951 FFETARGET_charactersizeNONE));
14952 break;
14953
14954 default:
14955 no_match: /* :::::::::::::::::::: */
14956 assert ("Lost the exponent letter!" == NULL);
14957 }
14958
14959 ffeexpr_exprstack_push_operand_ (e);
14960 }
14961
14962 /* Just like ffesymbol_declare_local, except performs any implicit info
14963 assignment necessary. */
14964
14965 static ffesymbol
14966 ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin)
14967 {
14968 ffesymbol s;
14969 ffeinfoKind k;
14970 bool bad;
14971
14972 s = ffesymbol_declare_local (t, maybe_intrin);
14973
14974 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
14975 /* Special-case these since they can involve a different concept
14976 of "state" (in the stmtfunc name space). */
14977 {
14978 case FFEEXPR_contextDATAIMPDOINDEX_:
14979 case FFEEXPR_contextDATAIMPDOCTRL_:
14980 if (ffeexpr_context_outer_ (ffeexpr_stack_)
14981 == FFEEXPR_contextDATAIMPDOINDEX_)
14982 s = ffeexpr_sym_impdoitem_ (s, t);
14983 else
14984 if (ffeexpr_stack_->is_rhs)
14985 s = ffeexpr_sym_impdoitem_ (s, t);
14986 else
14987 s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
14988 bad = (ffesymbol_kind (s) != FFEINFO_kindENTITY)
14989 || ((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
14990 && (ffesymbol_where (s) != FFEINFO_whereIMMEDIATE));
14991 if (bad && (ffesymbol_kind (s) != FFEINFO_kindANY))
14992 ffesymbol_error (s, t);
14993 return s;
14994
14995 default:
14996 break;
14997 }
14998
14999 switch ((ffesymbol_sfdummyparent (s) == NULL)
15000 ? ffesymbol_state (s)
15001 : FFESYMBOL_stateUNDERSTOOD)
15002 {
15003 case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr
15004 context. */
15005 if (!ffest_seen_first_exec ())
15006 goto seen; /* :::::::::::::::::::: */
15007 /* Fall through. */
15008 case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */
15009 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15010 {
15011 case FFEEXPR_contextSUBROUTINEREF:
15012 s = ffeexpr_sym_lhs_call_ (s, t);
15013 break;
15014
15015 case FFEEXPR_contextFILEEXTFUNC:
15016 s = ffeexpr_sym_lhs_extfunc_ (s, t);
15017 break;
15018
15019 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15020 s = ffecom_sym_exec_transition (s);
15021 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15022 goto understood; /* :::::::::::::::::::: */
15023 /* Fall through. */
15024 case FFEEXPR_contextACTUALARG_:
15025 s = ffeexpr_sym_rhs_actualarg_ (s, t);
15026 break;
15027
15028 case FFEEXPR_contextDATA:
15029 if (ffeexpr_stack_->is_rhs)
15030 s = ffeexpr_sym_rhs_let_ (s, t);
15031 else
15032 s = ffeexpr_sym_lhs_data_ (s, t);
15033 break;
15034
15035 case FFEEXPR_contextDATAIMPDOITEM_:
15036 s = ffeexpr_sym_lhs_data_ (s, t);
15037 break;
15038
15039 case FFEEXPR_contextSFUNCDEF:
15040 case FFEEXPR_contextSFUNCDEFINDEX_:
15041 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15042 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15043 s = ffecom_sym_exec_transition (s);
15044 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15045 goto understood; /* :::::::::::::::::::: */
15046 /* Fall through. */
15047 case FFEEXPR_contextLET:
15048 case FFEEXPR_contextPAREN_:
15049 case FFEEXPR_contextACTUALARGEXPR_:
15050 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15051 case FFEEXPR_contextASSIGN:
15052 case FFEEXPR_contextIOLIST:
15053 case FFEEXPR_contextIOLISTDF:
15054 case FFEEXPR_contextDO:
15055 case FFEEXPR_contextDOWHILE:
15056 case FFEEXPR_contextAGOTO:
15057 case FFEEXPR_contextCGOTO:
15058 case FFEEXPR_contextIF:
15059 case FFEEXPR_contextARITHIF:
15060 case FFEEXPR_contextFORMAT:
15061 case FFEEXPR_contextSTOP:
15062 case FFEEXPR_contextRETURN:
15063 case FFEEXPR_contextSELECTCASE:
15064 case FFEEXPR_contextCASE:
15065 case FFEEXPR_contextFILEASSOC:
15066 case FFEEXPR_contextFILEINT:
15067 case FFEEXPR_contextFILEDFINT:
15068 case FFEEXPR_contextFILELOG:
15069 case FFEEXPR_contextFILENUM:
15070 case FFEEXPR_contextFILENUMAMBIG:
15071 case FFEEXPR_contextFILECHAR:
15072 case FFEEXPR_contextFILENUMCHAR:
15073 case FFEEXPR_contextFILEDFCHAR:
15074 case FFEEXPR_contextFILEKEY:
15075 case FFEEXPR_contextFILEUNIT:
15076 case FFEEXPR_contextFILEUNIT_DF:
15077 case FFEEXPR_contextFILEUNITAMBIG:
15078 case FFEEXPR_contextFILEFORMAT:
15079 case FFEEXPR_contextFILENAMELIST:
15080 case FFEEXPR_contextFILEVXTCODE:
15081 case FFEEXPR_contextINDEX_:
15082 case FFEEXPR_contextIMPDOITEM_:
15083 case FFEEXPR_contextIMPDOITEMDF_:
15084 case FFEEXPR_contextIMPDOCTRL_:
15085 case FFEEXPR_contextLOC_:
15086 if (ffeexpr_stack_->is_rhs)
15087 s = ffeexpr_sym_rhs_let_ (s, t);
15088 else
15089 s = ffeexpr_sym_lhs_let_ (s, t);
15090 break;
15091
15092 case FFEEXPR_contextCHARACTERSIZE:
15093 case FFEEXPR_contextEQUIVALENCE:
15094 case FFEEXPR_contextINCLUDE:
15095 case FFEEXPR_contextPARAMETER:
15096 case FFEEXPR_contextDIMLIST:
15097 case FFEEXPR_contextDIMLISTCOMMON:
15098 case FFEEXPR_contextKINDTYPE:
15099 case FFEEXPR_contextINITVAL:
15100 case FFEEXPR_contextEQVINDEX_:
15101 break; /* Will turn into errors below. */
15102
15103 default:
15104 ffesymbol_error (s, t);
15105 break;
15106 }
15107 /* Fall through. */
15108 case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */
15109 understood: /* :::::::::::::::::::: */
15110 k = ffesymbol_kind (s);
15111 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15112 {
15113 case FFEEXPR_contextSUBROUTINEREF:
15114 bad = ((k != FFEINFO_kindSUBROUTINE)
15115 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
15116 || (k != FFEINFO_kindNONE)));
15117 break;
15118
15119 case FFEEXPR_contextFILEEXTFUNC:
15120 bad = (k != FFEINFO_kindFUNCTION)
15121 || (ffesymbol_where (s) != FFEINFO_whereGLOBAL);
15122 break;
15123
15124 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15125 case FFEEXPR_contextACTUALARG_:
15126 switch (k)
15127 {
15128 case FFEINFO_kindENTITY:
15129 bad = FALSE;
15130 break;
15131
15132 case FFEINFO_kindFUNCTION:
15133 case FFEINFO_kindSUBROUTINE:
15134 bad
15135 = ((ffesymbol_where (s) != FFEINFO_whereGLOBAL)
15136 && (ffesymbol_where (s) != FFEINFO_whereDUMMY)
15137 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
15138 || !ffeintrin_is_actualarg (ffesymbol_specific (s))));
15139 break;
15140
15141 case FFEINFO_kindNONE:
15142 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
15143 {
15144 bad = !(ffeintrin_is_actualarg (ffesymbol_specific (s)));
15145 break;
15146 }
15147
15148 /* If state is UNDERSTOOD here, it's CHAR*(*) or attrsANY,
15149 and in the former case, attrsTYPE is set, so we
15150 see this as an error as we should, since CHAR*(*)
15151 cannot be actually referenced in a main/block data
15152 program unit. */
15153
15154 if ((ffesymbol_attrs (s) & (FFESYMBOL_attrsANY
15155 | FFESYMBOL_attrsEXTERNAL
15156 | FFESYMBOL_attrsTYPE))
15157 == FFESYMBOL_attrsEXTERNAL)
15158 bad = FALSE;
15159 else
15160 bad = TRUE;
15161 break;
15162
15163 default:
15164 bad = TRUE;
15165 break;
15166 }
15167 break;
15168
15169 case FFEEXPR_contextDATA:
15170 if (ffeexpr_stack_->is_rhs)
15171 bad = (k != FFEINFO_kindENTITY)
15172 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
15173 else
15174 bad = (k != FFEINFO_kindENTITY)
15175 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
15176 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
15177 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
15178 break;
15179
15180 case FFEEXPR_contextDATAIMPDOITEM_:
15181 bad = TRUE; /* Unadorned item never valid. */
15182 break;
15183
15184 case FFEEXPR_contextSFUNCDEF:
15185 case FFEEXPR_contextSFUNCDEFINDEX_:
15186 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15187 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15188 case FFEEXPR_contextLET:
15189 case FFEEXPR_contextPAREN_:
15190 case FFEEXPR_contextACTUALARGEXPR_:
15191 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15192 case FFEEXPR_contextASSIGN:
15193 case FFEEXPR_contextIOLIST:
15194 case FFEEXPR_contextIOLISTDF:
15195 case FFEEXPR_contextDO:
15196 case FFEEXPR_contextDOWHILE:
15197 case FFEEXPR_contextAGOTO:
15198 case FFEEXPR_contextCGOTO:
15199 case FFEEXPR_contextIF:
15200 case FFEEXPR_contextARITHIF:
15201 case FFEEXPR_contextFORMAT:
15202 case FFEEXPR_contextSTOP:
15203 case FFEEXPR_contextRETURN:
15204 case FFEEXPR_contextSELECTCASE:
15205 case FFEEXPR_contextCASE:
15206 case FFEEXPR_contextFILEASSOC:
15207 case FFEEXPR_contextFILEINT:
15208 case FFEEXPR_contextFILEDFINT:
15209 case FFEEXPR_contextFILELOG:
15210 case FFEEXPR_contextFILENUM:
15211 case FFEEXPR_contextFILENUMAMBIG:
15212 case FFEEXPR_contextFILECHAR:
15213 case FFEEXPR_contextFILENUMCHAR:
15214 case FFEEXPR_contextFILEDFCHAR:
15215 case FFEEXPR_contextFILEKEY:
15216 case FFEEXPR_contextFILEUNIT:
15217 case FFEEXPR_contextFILEUNIT_DF:
15218 case FFEEXPR_contextFILEUNITAMBIG:
15219 case FFEEXPR_contextFILEFORMAT:
15220 case FFEEXPR_contextFILENAMELIST:
15221 case FFEEXPR_contextFILEVXTCODE:
15222 case FFEEXPR_contextINDEX_:
15223 case FFEEXPR_contextIMPDOITEM_:
15224 case FFEEXPR_contextIMPDOITEMDF_:
15225 case FFEEXPR_contextIMPDOCTRL_:
15226 case FFEEXPR_contextLOC_:
15227 bad = (k != FFEINFO_kindENTITY); /* This catches "SUBROUTINE
15228 X(A);EXTERNAL A;CALL
15229 Y(A);B=A", for example. */
15230 break;
15231
15232 case FFEEXPR_contextCHARACTERSIZE:
15233 case FFEEXPR_contextEQUIVALENCE:
15234 case FFEEXPR_contextPARAMETER:
15235 case FFEEXPR_contextDIMLIST:
15236 case FFEEXPR_contextDIMLISTCOMMON:
15237 case FFEEXPR_contextKINDTYPE:
15238 case FFEEXPR_contextINITVAL:
15239 case FFEEXPR_contextEQVINDEX_:
15240 bad = (k != FFEINFO_kindENTITY)
15241 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
15242 break;
15243
15244 case FFEEXPR_contextINCLUDE:
15245 bad = TRUE;
15246 break;
15247
15248 default:
15249 bad = TRUE;
15250 break;
15251 }
15252 if (bad && (k != FFEINFO_kindANY))
15253 ffesymbol_error (s, t);
15254 return s;
15255
15256 case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */
15257 seen: /* :::::::::::::::::::: */
15258 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15259 {
15260 case FFEEXPR_contextPARAMETER:
15261 if (ffeexpr_stack_->is_rhs)
15262 ffesymbol_error (s, t);
15263 else
15264 s = ffeexpr_sym_lhs_parameter_ (s, t);
15265 break;
15266
15267 case FFEEXPR_contextDATA:
15268 s = ffecom_sym_exec_transition (s);
15269 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15270 goto understood; /* :::::::::::::::::::: */
15271 if (ffeexpr_stack_->is_rhs)
15272 ffesymbol_error (s, t);
15273 else
15274 s = ffeexpr_sym_lhs_data_ (s, t);
15275 goto understood; /* :::::::::::::::::::: */
15276
15277 case FFEEXPR_contextDATAIMPDOITEM_:
15278 s = ffecom_sym_exec_transition (s);
15279 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15280 goto understood; /* :::::::::::::::::::: */
15281 s = ffeexpr_sym_lhs_data_ (s, t);
15282 goto understood; /* :::::::::::::::::::: */
15283
15284 case FFEEXPR_contextEQUIVALENCE:
15285 s = ffeexpr_sym_lhs_equivalence_ (s, t);
15286 break;
15287
15288 case FFEEXPR_contextDIMLIST:
15289 s = ffeexpr_sym_rhs_dimlist_ (s, t);
15290 break;
15291
15292 case FFEEXPR_contextCHARACTERSIZE:
15293 case FFEEXPR_contextKINDTYPE:
15294 case FFEEXPR_contextDIMLISTCOMMON:
15295 case FFEEXPR_contextINITVAL:
15296 case FFEEXPR_contextEQVINDEX_:
15297 ffesymbol_error (s, t);
15298 break;
15299
15300 case FFEEXPR_contextINCLUDE:
15301 ffesymbol_error (s, t);
15302 break;
15303
15304 case FFEEXPR_contextACTUALARG_: /* E.g. I in REAL A(Y(I)). */
15305 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15306 s = ffecom_sym_exec_transition (s);
15307 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15308 goto understood; /* :::::::::::::::::::: */
15309 s = ffeexpr_sym_rhs_actualarg_ (s, t);
15310 goto understood; /* :::::::::::::::::::: */
15311
15312 case FFEEXPR_contextINDEX_:
15313 case FFEEXPR_contextACTUALARGEXPR_:
15314 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15315 case FFEEXPR_contextSFUNCDEF:
15316 case FFEEXPR_contextSFUNCDEFINDEX_:
15317 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15318 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15319 assert (ffeexpr_stack_->is_rhs);
15320 s = ffecom_sym_exec_transition (s);
15321 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15322 goto understood; /* :::::::::::::::::::: */
15323 s = ffeexpr_sym_rhs_let_ (s, t);
15324 goto understood; /* :::::::::::::::::::: */
15325
15326 default:
15327 ffesymbol_error (s, t);
15328 break;
15329 }
15330 return s;
15331
15332 default:
15333 assert ("bad symbol state" == NULL);
15334 return NULL;
15335 break;
15336 }
15337 }
15338
15339 /* Have FOO in DATA (XYZ(FOO),...)/.../ or DATA (...,XYZ=FOO,BAR,BLETCH).
15340 Could be found via the "statement-function" name space (in which case
15341 it should become an iterator) or the local name space (in which case
15342 it should be either a named constant, or a variable that will have an
15343 sfunc name space sibling that should become an iterator). */
15344
15345 static ffesymbol
15346 ffeexpr_sym_impdoitem_ (ffesymbol sp, ffelexToken t)
15347 {
15348 ffesymbol s;
15349 ffesymbolAttrs sa;
15350 ffesymbolAttrs na;
15351 ffesymbolState ss;
15352 ffesymbolState ns;
15353 ffeinfoKind kind;
15354 ffeinfoWhere where;
15355
15356 ss = ffesymbol_state (sp);
15357
15358 if (ffesymbol_sfdummyparent (sp) != NULL)
15359 { /* Have symbol in sfunc name space. */
15360 switch (ss)
15361 {
15362 case FFESYMBOL_stateNONE: /* Used as iterator already. */
15363 if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
15364 ffesymbol_error (sp, t); /* Can't use dead iterator. */
15365 else
15366 { /* Can use dead iterator because we're at at
15367 least an innermore (higher-numbered) level
15368 than the iterator's outermost
15369 (lowest-numbered) level. */
15370 ffesymbol_signal_change (sp);
15371 ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
15372 ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
15373 ffesymbol_signal_unreported (sp);
15374 }
15375 break;
15376
15377 case FFESYMBOL_stateSEEN: /* Seen already in this or other
15378 implied-DO. Set symbol level
15379 number to outermost value, as that
15380 tells us we can see it as iterator
15381 at that level at the innermost. */
15382 if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
15383 {
15384 ffesymbol_signal_change (sp);
15385 ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
15386 ffesymbol_signal_unreported (sp);
15387 }
15388 break;
15389
15390 case FFESYMBOL_stateUNCERTAIN: /* Iterator. */
15391 assert (ffeexpr_level_ == ffesymbol_maxentrynum (sp));
15392 ffesymbol_error (sp, t); /* (,,,I=I,10). */
15393 break;
15394
15395 case FFESYMBOL_stateUNDERSTOOD:
15396 break; /* ANY. */
15397
15398 default:
15399 assert ("Foo Bar!!" == NULL);
15400 break;
15401 }
15402
15403 return sp;
15404 }
15405
15406 /* Got symbol in local name space, so we haven't seen it in impdo yet.
15407 First, if it is brand-new and we're in executable statements, set the
15408 attributes and exec-transition it to set state UNCERTAIN or UNDERSTOOD.
15409 Second, if it is now a constant (PARAMETER), then just return it, it
15410 can't be an implied-do iterator. If it is understood, complain if it is
15411 not a valid variable, but make the inner name space iterator anyway and
15412 return that. If it is not understood, improve understanding of the
15413 symbol accordingly, complain accordingly, in either case make the inner
15414 name space iterator and return that. */
15415
15416 sa = ffesymbol_attrs (sp);
15417
15418 if (ffesymbol_state_is_specable (ss)
15419 && ffest_seen_first_exec ())
15420 {
15421 assert (sa == FFESYMBOL_attrsetNONE);
15422 ffesymbol_signal_change (sp);
15423 ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
15424 ffesymbol_resolve_intrin (sp);
15425 if (ffeimplic_establish_symbol (sp))
15426 ffesymbol_set_attr (sp, FFESYMBOL_attrSFARG);
15427 else
15428 ffesymbol_error (sp, t);
15429
15430 /* After the exec transition, the state will either be UNCERTAIN (could
15431 be a dummy or local var) or UNDERSTOOD (local var, because this is a
15432 PROGRAM/BLOCKDATA program unit). */
15433
15434 sp = ffecom_sym_exec_transition (sp);
15435 sa = ffesymbol_attrs (sp);
15436 ss = ffesymbol_state (sp);
15437 }
15438
15439 ns = ss;
15440 kind = ffesymbol_kind (sp);
15441 where = ffesymbol_where (sp);
15442
15443 if (ss == FFESYMBOL_stateUNDERSTOOD)
15444 {
15445 if (kind != FFEINFO_kindENTITY)
15446 ffesymbol_error (sp, t);
15447 if (where == FFEINFO_whereCONSTANT)
15448 return sp;
15449 }
15450 else
15451 {
15452 /* Enhance understanding of local symbol. This used to imply exec
15453 transition, but that doesn't seem necessary, since the local symbol
15454 doesn't actually get put into an ffebld tree here -- we just learn
15455 more about it, just like when we see a local symbol's name in the
15456 dummy-arg list of a statement function. */
15457
15458 if (ss != FFESYMBOL_stateUNCERTAIN)
15459 {
15460 /* Figure out what kind of object we've got based on previous
15461 declarations of or references to the object. */
15462
15463 ns = FFESYMBOL_stateSEEN;
15464
15465 if (sa & FFESYMBOL_attrsANY)
15466 na = sa;
15467 else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
15468 | FFESYMBOL_attrsANY
15469 | FFESYMBOL_attrsCOMMON
15470 | FFESYMBOL_attrsDUMMY
15471 | FFESYMBOL_attrsEQUIV
15472 | FFESYMBOL_attrsINIT
15473 | FFESYMBOL_attrsNAMELIST
15474 | FFESYMBOL_attrsRESULT
15475 | FFESYMBOL_attrsSAVE
15476 | FFESYMBOL_attrsSFARG
15477 | FFESYMBOL_attrsTYPE)))
15478 na = sa | FFESYMBOL_attrsSFARG;
15479 else
15480 na = FFESYMBOL_attrsetNONE;
15481 }
15482 else
15483 { /* stateUNCERTAIN. */
15484 na = sa | FFESYMBOL_attrsSFARG;
15485 ns = FFESYMBOL_stateUNDERSTOOD;
15486
15487 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15488 | FFESYMBOL_attrsADJUSTABLE
15489 | FFESYMBOL_attrsANYLEN
15490 | FFESYMBOL_attrsARRAY
15491 | FFESYMBOL_attrsDUMMY
15492 | FFESYMBOL_attrsEXTERNAL
15493 | FFESYMBOL_attrsSFARG
15494 | FFESYMBOL_attrsTYPE)));
15495
15496 if (sa & FFESYMBOL_attrsEXTERNAL)
15497 {
15498 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15499 | FFESYMBOL_attrsDUMMY
15500 | FFESYMBOL_attrsEXTERNAL
15501 | FFESYMBOL_attrsTYPE)));
15502
15503 na = FFESYMBOL_attrsetNONE;
15504 }
15505 else if (sa & FFESYMBOL_attrsDUMMY)
15506 {
15507 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
15508 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
15509 | FFESYMBOL_attrsEXTERNAL
15510 | FFESYMBOL_attrsTYPE)));
15511
15512 kind = FFEINFO_kindENTITY;
15513 }
15514 else if (sa & FFESYMBOL_attrsARRAY)
15515 {
15516 assert (!(sa & ~(FFESYMBOL_attrsARRAY
15517 | FFESYMBOL_attrsADJUSTABLE
15518 | FFESYMBOL_attrsTYPE)));
15519
15520 na = FFESYMBOL_attrsetNONE;
15521 }
15522 else if (sa & FFESYMBOL_attrsSFARG)
15523 {
15524 assert (!(sa & ~(FFESYMBOL_attrsSFARG
15525 | FFESYMBOL_attrsTYPE)));
15526
15527 ns = FFESYMBOL_stateUNCERTAIN;
15528 }
15529 else if (sa & FFESYMBOL_attrsTYPE)
15530 {
15531 assert (!(sa & (FFESYMBOL_attrsARRAY
15532 | FFESYMBOL_attrsDUMMY
15533 | FFESYMBOL_attrsEXTERNAL
15534 | FFESYMBOL_attrsSFARG))); /* Handled above. */
15535 assert (!(sa & ~(FFESYMBOL_attrsTYPE
15536 | FFESYMBOL_attrsADJUSTABLE
15537 | FFESYMBOL_attrsANYLEN
15538 | FFESYMBOL_attrsARRAY
15539 | FFESYMBOL_attrsDUMMY
15540 | FFESYMBOL_attrsEXTERNAL
15541 | FFESYMBOL_attrsSFARG)));
15542
15543 kind = FFEINFO_kindENTITY;
15544
15545 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
15546 na = FFESYMBOL_attrsetNONE;
15547 else if (ffest_is_entry_valid ())
15548 ns = FFESYMBOL_stateUNCERTAIN; /* Could be DUMMY or LOCAL. */
15549 else
15550 where = FFEINFO_whereLOCAL;
15551 }
15552 else
15553 na = FFESYMBOL_attrsetNONE; /* Error. */
15554 }
15555
15556 /* Now see what we've got for a new object: NONE means a new error
15557 cropped up; ANY means an old error to be ignored; otherwise,
15558 everything's ok, update the object (symbol) and continue on. */
15559
15560 if (na == FFESYMBOL_attrsetNONE)
15561 ffesymbol_error (sp, t);
15562 else if (!(na & FFESYMBOL_attrsANY))
15563 {
15564 ffesymbol_signal_change (sp); /* May need to back up to previous
15565 version. */
15566 if (!ffeimplic_establish_symbol (sp))
15567 ffesymbol_error (sp, t);
15568 else
15569 {
15570 ffesymbol_set_info (sp,
15571 ffeinfo_new (ffesymbol_basictype (sp),
15572 ffesymbol_kindtype (sp),
15573 ffesymbol_rank (sp),
15574 kind,
15575 where,
15576 ffesymbol_size (sp)));
15577 ffesymbol_set_attrs (sp, na);
15578 ffesymbol_set_state (sp, ns);
15579 ffesymbol_resolve_intrin (sp);
15580 if (!ffesymbol_state_is_specable (ns))
15581 sp = ffecom_sym_learned (sp);
15582 ffesymbol_signal_unreported (sp); /* For debugging purposes. */
15583 }
15584 }
15585 }
15586
15587 /* Here we create the sfunc-name-space symbol representing what should
15588 become an iterator in this name space at this or an outermore (lower-
15589 numbered) expression level, else the implied-DO construct is in error. */
15590
15591 s = ffesymbol_declare_sfdummy (t); /* Sets maxentrynum to 0 for new obj;
15592 also sets sfa_dummy_parent to
15593 parent symbol. */
15594 assert (sp == ffesymbol_sfdummyparent (s));
15595
15596 ffesymbol_signal_change (s);
15597 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
15598 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
15599 ffesymbol_set_info (s,
15600 ffeinfo_new (FFEINFO_basictypeINTEGER,
15601 FFEINFO_kindtypeINTEGERDEFAULT,
15602 0,
15603 FFEINFO_kindENTITY,
15604 FFEINFO_whereIMMEDIATE,
15605 FFETARGET_charactersizeNONE));
15606 ffesymbol_signal_unreported (s);
15607
15608 if ((ffesymbol_basictype (sp) != FFEINFO_basictypeINTEGER)
15609 && (ffesymbol_basictype (sp) != FFEINFO_basictypeANY))
15610 ffesymbol_error (s, t);
15611
15612 return s;
15613 }
15614
15615 /* Have FOO in CALL FOO. Local name space, executable context only. */
15616
15617 static ffesymbol
15618 ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t)
15619 {
15620 ffesymbolAttrs sa;
15621 ffesymbolAttrs na;
15622 ffeinfoKind kind;
15623 ffeinfoWhere where;
15624 ffeintrinGen gen;
15625 ffeintrinSpec spec;
15626 ffeintrinImp imp;
15627 bool error = FALSE;
15628
15629 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
15630 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
15631
15632 na = sa = ffesymbol_attrs (s);
15633
15634 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15635 | FFESYMBOL_attrsADJUSTABLE
15636 | FFESYMBOL_attrsANYLEN
15637 | FFESYMBOL_attrsARRAY
15638 | FFESYMBOL_attrsDUMMY
15639 | FFESYMBOL_attrsEXTERNAL
15640 | FFESYMBOL_attrsSFARG
15641 | FFESYMBOL_attrsTYPE)));
15642
15643 kind = ffesymbol_kind (s);
15644 where = ffesymbol_where (s);
15645
15646 /* Figure out what kind of object we've got based on previous declarations
15647 of or references to the object. */
15648
15649 if (sa & FFESYMBOL_attrsEXTERNAL)
15650 {
15651 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15652 | FFESYMBOL_attrsDUMMY
15653 | FFESYMBOL_attrsEXTERNAL
15654 | FFESYMBOL_attrsTYPE)));
15655
15656 if (sa & FFESYMBOL_attrsTYPE)
15657 error = TRUE;
15658 else
15659 /* Not TYPE. */
15660 {
15661 kind = FFEINFO_kindSUBROUTINE;
15662
15663 if (sa & FFESYMBOL_attrsDUMMY)
15664 ; /* Not TYPE. */
15665 else if (sa & FFESYMBOL_attrsACTUALARG)
15666 ; /* Not DUMMY or TYPE. */
15667 else /* Not ACTUALARG, DUMMY, or TYPE. */
15668 where = FFEINFO_whereGLOBAL;
15669 }
15670 }
15671 else if (sa & FFESYMBOL_attrsDUMMY)
15672 {
15673 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
15674 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
15675 | FFESYMBOL_attrsEXTERNAL
15676 | FFESYMBOL_attrsTYPE)));
15677
15678 if (sa & FFESYMBOL_attrsTYPE)
15679 error = TRUE;
15680 else
15681 kind = FFEINFO_kindSUBROUTINE;
15682 }
15683 else if (sa & FFESYMBOL_attrsARRAY)
15684 {
15685 assert (!(sa & ~(FFESYMBOL_attrsARRAY
15686 | FFESYMBOL_attrsADJUSTABLE
15687 | FFESYMBOL_attrsTYPE)));
15688
15689 error = TRUE;
15690 }
15691 else if (sa & FFESYMBOL_attrsSFARG)
15692 {
15693 assert (!(sa & ~(FFESYMBOL_attrsSFARG
15694 | FFESYMBOL_attrsTYPE)));
15695
15696 error = TRUE;
15697 }
15698 else if (sa & FFESYMBOL_attrsTYPE)
15699 {
15700 assert (!(sa & (FFESYMBOL_attrsARRAY
15701 | FFESYMBOL_attrsDUMMY
15702 | FFESYMBOL_attrsEXTERNAL
15703 | FFESYMBOL_attrsSFARG))); /* Handled above. */
15704 assert (!(sa & ~(FFESYMBOL_attrsTYPE
15705 | FFESYMBOL_attrsADJUSTABLE
15706 | FFESYMBOL_attrsANYLEN
15707 | FFESYMBOL_attrsARRAY
15708 | FFESYMBOL_attrsDUMMY
15709 | FFESYMBOL_attrsEXTERNAL
15710 | FFESYMBOL_attrsSFARG)));
15711
15712 error = TRUE;
15713 }
15714 else if (sa == FFESYMBOL_attrsetNONE)
15715 {
15716 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
15717
15718 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
15719 &gen, &spec, &imp))
15720 {
15721 ffesymbol_signal_change (s); /* May need to back up to previous
15722 version. */
15723 ffesymbol_set_generic (s, gen);
15724 ffesymbol_set_specific (s, spec);
15725 ffesymbol_set_implementation (s, imp);
15726 ffesymbol_set_info (s,
15727 ffeinfo_new (FFEINFO_basictypeNONE,
15728 FFEINFO_kindtypeNONE,
15729 0,
15730 FFEINFO_kindSUBROUTINE,
15731 FFEINFO_whereINTRINSIC,
15732 FFETARGET_charactersizeNONE));
15733 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
15734 ffesymbol_resolve_intrin (s);
15735 ffesymbol_reference (s, t, FALSE);
15736 s = ffecom_sym_learned (s);
15737 ffesymbol_signal_unreported (s); /* For debugging purposes. */
15738
15739 return s;
15740 }
15741
15742 kind = FFEINFO_kindSUBROUTINE;
15743 where = FFEINFO_whereGLOBAL;
15744 }
15745 else
15746 error = TRUE;
15747
15748 /* Now see what we've got for a new object: NONE means a new error cropped
15749 up; ANY means an old error to be ignored; otherwise, everything's ok,
15750 update the object (symbol) and continue on. */
15751
15752 if (error)
15753 ffesymbol_error (s, t);
15754 else if (!(na & FFESYMBOL_attrsANY))
15755 {
15756 ffesymbol_signal_change (s); /* May need to back up to previous
15757 version. */
15758 ffesymbol_set_info (s,
15759 ffeinfo_new (ffesymbol_basictype (s),
15760 ffesymbol_kindtype (s),
15761 ffesymbol_rank (s),
15762 kind, /* SUBROUTINE. */
15763 where, /* GLOBAL or DUMMY. */
15764 ffesymbol_size (s)));
15765 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
15766 ffesymbol_resolve_intrin (s);
15767 ffesymbol_reference (s, t, FALSE);
15768 s = ffecom_sym_learned (s);
15769 ffesymbol_signal_unreported (s); /* For debugging purposes. */
15770 }
15771
15772 return s;
15773 }
15774
15775 /* Have FOO in DATA FOO/.../. Local name space and executable context
15776 only. (This will change in the future when DATA FOO may be followed
15777 by COMMON FOO or even INTEGER FOO(10), etc.) */
15778
15779 static ffesymbol
15780 ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t)
15781 {
15782 ffesymbolAttrs sa;
15783 ffesymbolAttrs na;
15784 ffeinfoKind kind;
15785 ffeinfoWhere where;
15786 bool error = FALSE;
15787
15788 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
15789 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
15790
15791 na = sa = ffesymbol_attrs (s);
15792
15793 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15794 | FFESYMBOL_attrsADJUSTABLE
15795 | FFESYMBOL_attrsANYLEN
15796 | FFESYMBOL_attrsARRAY
15797 | FFESYMBOL_attrsDUMMY
15798 | FFESYMBOL_attrsEXTERNAL
15799 | FFESYMBOL_attrsSFARG
15800 | FFESYMBOL_attrsTYPE)));
15801
15802 kind = ffesymbol_kind (s);
15803 where = ffesymbol_where (s);
15804
15805 /* Figure out what kind of object we've got based on previous declarations
15806 of or references to the object. */
15807
15808 if (sa & FFESYMBOL_attrsEXTERNAL)
15809 {
15810 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15811 | FFESYMBOL_attrsDUMMY
15812 | FFESYMBOL_attrsEXTERNAL
15813 | FFESYMBOL_attrsTYPE)));
15814
15815 error = TRUE;
15816 }
15817 else if (sa & FFESYMBOL_attrsDUMMY)
15818 {
15819 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
15820 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
15821 | FFESYMBOL_attrsEXTERNAL
15822 | FFESYMBOL_attrsTYPE)));
15823
15824 error = TRUE;
15825 }
15826 else if (sa & FFESYMBOL_attrsARRAY)
15827 {
15828 assert (!(sa & ~(FFESYMBOL_attrsARRAY
15829 | FFESYMBOL_attrsADJUSTABLE
15830 | FFESYMBOL_attrsTYPE)));
15831
15832 if (sa & FFESYMBOL_attrsADJUSTABLE)
15833 error = TRUE;
15834 where = FFEINFO_whereLOCAL;
15835 }
15836 else if (sa & FFESYMBOL_attrsSFARG)
15837 {
15838 assert (!(sa & ~(FFESYMBOL_attrsSFARG
15839 | FFESYMBOL_attrsTYPE)));
15840
15841 where = FFEINFO_whereLOCAL;
15842 }
15843 else if (sa & FFESYMBOL_attrsTYPE)
15844 {
15845 assert (!(sa & (FFESYMBOL_attrsARRAY
15846 | FFESYMBOL_attrsDUMMY
15847 | FFESYMBOL_attrsEXTERNAL
15848 | FFESYMBOL_attrsSFARG))); /* Handled above. */
15849 assert (!(sa & ~(FFESYMBOL_attrsTYPE
15850 | FFESYMBOL_attrsADJUSTABLE
15851 | FFESYMBOL_attrsANYLEN
15852 | FFESYMBOL_attrsARRAY
15853 | FFESYMBOL_attrsDUMMY
15854 | FFESYMBOL_attrsEXTERNAL
15855 | FFESYMBOL_attrsSFARG)));
15856
15857 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
15858 error = TRUE;
15859 else
15860 {
15861 kind = FFEINFO_kindENTITY;
15862 where = FFEINFO_whereLOCAL;
15863 }
15864 }
15865 else if (sa == FFESYMBOL_attrsetNONE)
15866 {
15867 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
15868 kind = FFEINFO_kindENTITY;
15869 where = FFEINFO_whereLOCAL;
15870 }
15871 else
15872 error = TRUE;
15873
15874 /* Now see what we've got for a new object: NONE means a new error cropped
15875 up; ANY means an old error to be ignored; otherwise, everything's ok,
15876 update the object (symbol) and continue on. */
15877
15878 if (error)
15879 ffesymbol_error (s, t);
15880 else if (!(na & FFESYMBOL_attrsANY))
15881 {
15882 ffesymbol_signal_change (s); /* May need to back up to previous
15883 version. */
15884 if (!ffeimplic_establish_symbol (s))
15885 {
15886 ffesymbol_error (s, t);
15887 return s;
15888 }
15889 ffesymbol_set_info (s,
15890 ffeinfo_new (ffesymbol_basictype (s),
15891 ffesymbol_kindtype (s),
15892 ffesymbol_rank (s),
15893 kind, /* ENTITY. */
15894 where, /* LOCAL. */
15895 ffesymbol_size (s)));
15896 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
15897 ffesymbol_resolve_intrin (s);
15898 s = ffecom_sym_learned (s);
15899 ffesymbol_signal_unreported (s); /* For debugging purposes. */
15900 }
15901
15902 return s;
15903 }
15904
15905 /* Have FOO in EQUIVALENCE (...,FOO,...). Does not include
15906 EQUIVALENCE (...,BAR(FOO),...). */
15907
15908 static ffesymbol
15909 ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t)
15910 {
15911 ffesymbolAttrs sa;
15912 ffesymbolAttrs na;
15913 ffeinfoKind kind;
15914 ffeinfoWhere where;
15915
15916 na = sa = ffesymbol_attrs (s);
15917 kind = FFEINFO_kindENTITY;
15918 where = ffesymbol_where (s);
15919
15920 /* Figure out what kind of object we've got based on previous declarations
15921 of or references to the object. */
15922
15923 if (!(sa & ~(FFESYMBOL_attrsADJUSTS
15924 | FFESYMBOL_attrsARRAY
15925 | FFESYMBOL_attrsCOMMON
15926 | FFESYMBOL_attrsEQUIV
15927 | FFESYMBOL_attrsINIT
15928 | FFESYMBOL_attrsNAMELIST
15929 | FFESYMBOL_attrsSAVE
15930 | FFESYMBOL_attrsSFARG
15931 | FFESYMBOL_attrsTYPE)))
15932 na = sa | FFESYMBOL_attrsEQUIV;
15933 else
15934 na = FFESYMBOL_attrsetNONE;
15935
15936 /* Don't know why we're bothering to set kind and where in this code, but
15937 added the following to make it complete, in case it's really important.
15938 Generally this is left up to symbol exec transition. */
15939
15940 if (where == FFEINFO_whereNONE)
15941 {
15942 if (na & (FFESYMBOL_attrsADJUSTS
15943 | FFESYMBOL_attrsCOMMON))
15944 where = FFEINFO_whereCOMMON;
15945 else if (na & FFESYMBOL_attrsSAVE)
15946 where = FFEINFO_whereLOCAL;
15947 }
15948
15949 /* Now see what we've got for a new object: NONE means a new error cropped
15950 up; ANY means an old error to be ignored; otherwise, everything's ok,
15951 update the object (symbol) and continue on. */
15952
15953 if (na == FFESYMBOL_attrsetNONE)
15954 ffesymbol_error (s, t);
15955 else if (!(na & FFESYMBOL_attrsANY))
15956 {
15957 ffesymbol_signal_change (s); /* May need to back up to previous
15958 version. */
15959 ffesymbol_set_info (s,
15960 ffeinfo_new (ffesymbol_basictype (s),
15961 ffesymbol_kindtype (s),
15962 ffesymbol_rank (s),
15963 kind, /* Always ENTITY. */
15964 where, /* NONE, COMMON, or LOCAL. */
15965 ffesymbol_size (s)));
15966 ffesymbol_set_attrs (s, na);
15967 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
15968 ffesymbol_resolve_intrin (s);
15969 ffesymbol_signal_unreported (s); /* For debugging purposes. */
15970 }
15971
15972 return s;
15973 }
15974
15975 /* Have FOO in OPEN(...,USEROPEN=FOO,...). Executable context only.
15976
15977 Note that I think this should be considered semantically similar to
15978 doing CALL XYZ(FOO), in that it should be considered like an
15979 ACTUALARG context. In particular, without EXTERNAL being specified,
15980 it should not be allowed. */
15981
15982 static ffesymbol
15983 ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t)
15984 {
15985 ffesymbolAttrs sa;
15986 ffesymbolAttrs na;
15987 ffeinfoKind kind;
15988 ffeinfoWhere where;
15989 bool needs_type = FALSE;
15990 bool error = FALSE;
15991
15992 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
15993 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
15994
15995 na = sa = ffesymbol_attrs (s);
15996
15997 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15998 | FFESYMBOL_attrsADJUSTABLE
15999 | FFESYMBOL_attrsANYLEN
16000 | FFESYMBOL_attrsARRAY
16001 | FFESYMBOL_attrsDUMMY
16002 | FFESYMBOL_attrsEXTERNAL
16003 | FFESYMBOL_attrsSFARG
16004 | FFESYMBOL_attrsTYPE)));
16005
16006 kind = ffesymbol_kind (s);
16007 where = ffesymbol_where (s);
16008
16009 /* Figure out what kind of object we've got based on previous declarations
16010 of or references to the object. */
16011
16012 if (sa & FFESYMBOL_attrsEXTERNAL)
16013 {
16014 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16015 | FFESYMBOL_attrsDUMMY
16016 | FFESYMBOL_attrsEXTERNAL
16017 | FFESYMBOL_attrsTYPE)));
16018
16019 if (sa & FFESYMBOL_attrsTYPE)
16020 where = FFEINFO_whereGLOBAL;
16021 else
16022 /* Not TYPE. */
16023 {
16024 kind = FFEINFO_kindFUNCTION;
16025 needs_type = TRUE;
16026
16027 if (sa & FFESYMBOL_attrsDUMMY)
16028 ; /* Not TYPE. */
16029 else if (sa & FFESYMBOL_attrsACTUALARG)
16030 ; /* Not DUMMY or TYPE. */
16031 else /* Not ACTUALARG, DUMMY, or TYPE. */
16032 where = FFEINFO_whereGLOBAL;
16033 }
16034 }
16035 else if (sa & FFESYMBOL_attrsDUMMY)
16036 {
16037 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16038 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16039 | FFESYMBOL_attrsEXTERNAL
16040 | FFESYMBOL_attrsTYPE)));
16041
16042 kind = FFEINFO_kindFUNCTION;
16043 if (!(sa & FFESYMBOL_attrsTYPE))
16044 needs_type = TRUE;
16045 }
16046 else if (sa & FFESYMBOL_attrsARRAY)
16047 {
16048 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16049 | FFESYMBOL_attrsADJUSTABLE
16050 | FFESYMBOL_attrsTYPE)));
16051
16052 error = TRUE;
16053 }
16054 else if (sa & FFESYMBOL_attrsSFARG)
16055 {
16056 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16057 | FFESYMBOL_attrsTYPE)));
16058
16059 error = TRUE;
16060 }
16061 else if (sa & FFESYMBOL_attrsTYPE)
16062 {
16063 assert (!(sa & (FFESYMBOL_attrsARRAY
16064 | FFESYMBOL_attrsDUMMY
16065 | FFESYMBOL_attrsEXTERNAL
16066 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16067 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16068 | FFESYMBOL_attrsADJUSTABLE
16069 | FFESYMBOL_attrsANYLEN
16070 | FFESYMBOL_attrsARRAY
16071 | FFESYMBOL_attrsDUMMY
16072 | FFESYMBOL_attrsEXTERNAL
16073 | FFESYMBOL_attrsSFARG)));
16074
16075 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16076 error = TRUE;
16077 else
16078 {
16079 kind = FFEINFO_kindFUNCTION;
16080 where = FFEINFO_whereGLOBAL;
16081 }
16082 }
16083 else if (sa == FFESYMBOL_attrsetNONE)
16084 {
16085 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16086 kind = FFEINFO_kindFUNCTION;
16087 where = FFEINFO_whereGLOBAL;
16088 needs_type = TRUE;
16089 }
16090 else
16091 error = TRUE;
16092
16093 /* Now see what we've got for a new object: NONE means a new error cropped
16094 up; ANY means an old error to be ignored; otherwise, everything's ok,
16095 update the object (symbol) and continue on. */
16096
16097 if (error)
16098 ffesymbol_error (s, t);
16099 else if (!(na & FFESYMBOL_attrsANY))
16100 {
16101 ffesymbol_signal_change (s); /* May need to back up to previous
16102 version. */
16103 if (needs_type && !ffeimplic_establish_symbol (s))
16104 {
16105 ffesymbol_error (s, t);
16106 return s;
16107 }
16108 if (!ffesymbol_explicitwhere (s))
16109 {
16110 ffebad_start (FFEBAD_NEED_EXTERNAL);
16111 ffebad_here (0, ffelex_token_where_line (t),
16112 ffelex_token_where_column (t));
16113 ffebad_string (ffesymbol_text (s));
16114 ffebad_finish ();
16115 ffesymbol_set_explicitwhere (s, TRUE);
16116 }
16117 ffesymbol_set_info (s,
16118 ffeinfo_new (ffesymbol_basictype (s),
16119 ffesymbol_kindtype (s),
16120 ffesymbol_rank (s),
16121 kind, /* FUNCTION. */
16122 where, /* GLOBAL or DUMMY. */
16123 ffesymbol_size (s)));
16124 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16125 ffesymbol_resolve_intrin (s);
16126 ffesymbol_reference (s, t, FALSE);
16127 s = ffecom_sym_learned (s);
16128 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16129 }
16130
16131 return s;
16132 }
16133
16134 /* Have FOO in DATA (stuff,FOO=1,10)/.../. */
16135
16136 static ffesymbol
16137 ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t)
16138 {
16139 ffesymbolState ss;
16140
16141 /* If the symbol isn't in the sfunc name space, pretend as though we saw a
16142 reference to it already within the imp-DO construct at this level, so as
16143 to get a symbol that is in the sfunc name space. But this is an
16144 erroneous construct, and should be caught elsewhere. */
16145
16146 if (ffesymbol_sfdummyparent (s) == NULL)
16147 {
16148 s = ffeexpr_sym_impdoitem_ (s, t);
16149 if (ffesymbol_sfdummyparent (s) == NULL)
16150 { /* PARAMETER FOO...DATA (A(I),FOO=...). */
16151 ffesymbol_error (s, t);
16152 return s;
16153 }
16154 }
16155
16156 ss = ffesymbol_state (s);
16157
16158 switch (ss)
16159 {
16160 case FFESYMBOL_stateNONE: /* Used as iterator already. */
16161 if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
16162 ffesymbol_error (s, t); /* Can't reuse dead iterator. F90 disallows
16163 this; F77 allows it but it is a stupid
16164 feature. */
16165 else
16166 { /* Can use dead iterator because we're at at
16167 least a innermore (higher-numbered) level
16168 than the iterator's outermost
16169 (lowest-numbered) level. This should be
16170 diagnosed later, because it means an item
16171 in this list didn't reference this
16172 iterator. */
16173 #if 1
16174 ffesymbol_error (s, t); /* For now, complain. */
16175 #else /* Someday will detect all cases where initializer doesn't reference
16176 all applicable iterators, in which case reenable this code. */
16177 ffesymbol_signal_change (s);
16178 ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
16179 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
16180 ffesymbol_signal_unreported (s);
16181 #endif
16182 }
16183 break;
16184
16185 case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO.
16186 If seen in outermore level, can't be an
16187 iterator here, so complain. If not seen
16188 at current level, complain for now,
16189 because that indicates something F90
16190 rejects (though we currently don't detect
16191 all such cases for now). */
16192 if (ffeexpr_level_ <= ffesymbol_maxentrynum (s))
16193 {
16194 ffesymbol_signal_change (s);
16195 ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
16196 ffesymbol_signal_unreported (s);
16197 }
16198 else
16199 ffesymbol_error (s, t);
16200 break;
16201
16202 case FFESYMBOL_stateUNCERTAIN: /* Already iterator! */
16203 assert ("DATA implied-DO control var seen twice!!" == NULL);
16204 ffesymbol_error (s, t);
16205 break;
16206
16207 case FFESYMBOL_stateUNDERSTOOD:
16208 break; /* ANY. */
16209
16210 default:
16211 assert ("Foo Bletch!!" == NULL);
16212 break;
16213 }
16214
16215 return s;
16216 }
16217
16218 /* Have FOO in PARAMETER (FOO=...). */
16219
16220 static ffesymbol
16221 ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t)
16222 {
16223 ffesymbolAttrs sa;
16224
16225 sa = ffesymbol_attrs (s);
16226
16227 /* Figure out what kind of object we've got based on previous declarations
16228 of or references to the object. */
16229
16230 if (sa & ~(FFESYMBOL_attrsANYLEN
16231 | FFESYMBOL_attrsTYPE))
16232 {
16233 if (!(sa & FFESYMBOL_attrsANY))
16234 ffesymbol_error (s, t);
16235 }
16236 else
16237 {
16238 ffesymbol_signal_change (s); /* May need to back up to previous
16239 version. */
16240 if (!ffeimplic_establish_symbol (s))
16241 {
16242 ffesymbol_error (s, t);
16243 return s;
16244 }
16245 ffesymbol_set_info (s,
16246 ffeinfo_new (ffesymbol_basictype (s),
16247 ffesymbol_kindtype (s),
16248 ffesymbol_rank (s),
16249 FFEINFO_kindENTITY,
16250 FFEINFO_whereCONSTANT,
16251 ffesymbol_size (s)));
16252 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16253 ffesymbol_resolve_intrin (s);
16254 s = ffecom_sym_learned (s);
16255 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16256 }
16257
16258 return s;
16259 }
16260
16261 /* Have FOO in CALL XYZ(...,FOO,...). Does not include any other
16262 embedding of FOO, such as CALL XYZ((FOO)) or CALL XYZ(FOO+1). */
16263
16264 static ffesymbol
16265 ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t)
16266 {
16267 ffesymbolAttrs sa;
16268 ffesymbolAttrs na;
16269 ffeinfoKind kind;
16270 ffeinfoWhere where;
16271 ffesymbolState ns;
16272 bool needs_type = FALSE;
16273
16274 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16275 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16276
16277 na = sa = ffesymbol_attrs (s);
16278
16279 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16280 | FFESYMBOL_attrsADJUSTABLE
16281 | FFESYMBOL_attrsANYLEN
16282 | FFESYMBOL_attrsARRAY
16283 | FFESYMBOL_attrsDUMMY
16284 | FFESYMBOL_attrsEXTERNAL
16285 | FFESYMBOL_attrsSFARG
16286 | FFESYMBOL_attrsTYPE)));
16287
16288 kind = ffesymbol_kind (s);
16289 where = ffesymbol_where (s);
16290
16291 /* Figure out what kind of object we've got based on previous declarations
16292 of or references to the object. */
16293
16294 ns = FFESYMBOL_stateUNDERSTOOD;
16295
16296 if (sa & FFESYMBOL_attrsEXTERNAL)
16297 {
16298 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16299 | FFESYMBOL_attrsDUMMY
16300 | FFESYMBOL_attrsEXTERNAL
16301 | FFESYMBOL_attrsTYPE)));
16302
16303 if (sa & FFESYMBOL_attrsTYPE)
16304 where = FFEINFO_whereGLOBAL;
16305 else
16306 /* Not TYPE. */
16307 {
16308 ns = FFESYMBOL_stateUNCERTAIN;
16309
16310 if (sa & FFESYMBOL_attrsDUMMY)
16311 assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */
16312 else if (sa & FFESYMBOL_attrsACTUALARG)
16313 ; /* Not DUMMY or TYPE. */
16314 else
16315 /* Not ACTUALARG, DUMMY, or TYPE. */
16316 {
16317 assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */
16318 na |= FFESYMBOL_attrsACTUALARG;
16319 where = FFEINFO_whereGLOBAL;
16320 }
16321 }
16322 }
16323 else if (sa & FFESYMBOL_attrsDUMMY)
16324 {
16325 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16326 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16327 | FFESYMBOL_attrsEXTERNAL
16328 | FFESYMBOL_attrsTYPE)));
16329
16330 kind = FFEINFO_kindENTITY;
16331 if (!(sa & FFESYMBOL_attrsTYPE))
16332 needs_type = TRUE;
16333 }
16334 else if (sa & FFESYMBOL_attrsARRAY)
16335 {
16336 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16337 | FFESYMBOL_attrsADJUSTABLE
16338 | FFESYMBOL_attrsTYPE)));
16339
16340 where = FFEINFO_whereLOCAL;
16341 }
16342 else if (sa & FFESYMBOL_attrsSFARG)
16343 {
16344 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16345 | FFESYMBOL_attrsTYPE)));
16346
16347 where = FFEINFO_whereLOCAL;
16348 }
16349 else if (sa & FFESYMBOL_attrsTYPE)
16350 {
16351 assert (!(sa & (FFESYMBOL_attrsARRAY
16352 | FFESYMBOL_attrsDUMMY
16353 | FFESYMBOL_attrsEXTERNAL
16354 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16355 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16356 | FFESYMBOL_attrsADJUSTABLE
16357 | FFESYMBOL_attrsANYLEN
16358 | FFESYMBOL_attrsARRAY
16359 | FFESYMBOL_attrsDUMMY
16360 | FFESYMBOL_attrsEXTERNAL
16361 | FFESYMBOL_attrsSFARG)));
16362
16363 if (sa & FFESYMBOL_attrsANYLEN)
16364 ns = FFESYMBOL_stateNONE;
16365 else
16366 {
16367 kind = FFEINFO_kindENTITY;
16368 where = FFEINFO_whereLOCAL;
16369 }
16370 }
16371 else if (sa == FFESYMBOL_attrsetNONE)
16372 {
16373 /* New state is left empty because there isn't any state flag to
16374 set for this case, and it's UNDERSTOOD after all. */
16375 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16376 kind = FFEINFO_kindENTITY;
16377 where = FFEINFO_whereLOCAL;
16378 needs_type = TRUE;
16379 }
16380 else
16381 ns = FFESYMBOL_stateNONE; /* Error. */
16382
16383 /* Now see what we've got for a new object: NONE means a new error cropped
16384 up; ANY means an old error to be ignored; otherwise, everything's ok,
16385 update the object (symbol) and continue on. */
16386
16387 if (ns == FFESYMBOL_stateNONE)
16388 ffesymbol_error (s, t);
16389 else if (!(na & FFESYMBOL_attrsANY))
16390 {
16391 ffesymbol_signal_change (s); /* May need to back up to previous
16392 version. */
16393 if (needs_type && !ffeimplic_establish_symbol (s))
16394 {
16395 ffesymbol_error (s, t);
16396 return s;
16397 }
16398 ffesymbol_set_info (s,
16399 ffeinfo_new (ffesymbol_basictype (s),
16400 ffesymbol_kindtype (s),
16401 ffesymbol_rank (s),
16402 kind,
16403 where,
16404 ffesymbol_size (s)));
16405 ffesymbol_set_attrs (s, na);
16406 ffesymbol_set_state (s, ns);
16407 s = ffecom_sym_learned (s);
16408 ffesymbol_reference (s, t, FALSE);
16409 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16410 }
16411
16412 return s;
16413 }
16414
16415 /* Have FOO in DIMENSION XYZ(FOO) or any array declarator containing
16416 a reference to FOO. */
16417
16418 static ffesymbol
16419 ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t)
16420 {
16421 ffesymbolAttrs sa;
16422 ffesymbolAttrs na;
16423 ffeinfoKind kind;
16424 ffeinfoWhere where;
16425
16426 na = sa = ffesymbol_attrs (s);
16427 kind = FFEINFO_kindENTITY;
16428 where = ffesymbol_where (s);
16429
16430 /* Figure out what kind of object we've got based on previous declarations
16431 of or references to the object. */
16432
16433 if (!(sa & ~(FFESYMBOL_attrsADJUSTS
16434 | FFESYMBOL_attrsCOMMON
16435 | FFESYMBOL_attrsDUMMY
16436 | FFESYMBOL_attrsEQUIV
16437 | FFESYMBOL_attrsINIT
16438 | FFESYMBOL_attrsNAMELIST
16439 | FFESYMBOL_attrsSFARG
16440 | FFESYMBOL_attrsARRAY
16441 | FFESYMBOL_attrsTYPE)))
16442 na = sa | FFESYMBOL_attrsADJUSTS;
16443 else
16444 na = FFESYMBOL_attrsetNONE;
16445
16446 /* Since this symbol definitely is going into an expression (the
16447 dimension-list for some dummy array, presumably), figure out WHERE if
16448 possible. */
16449
16450 if (where == FFEINFO_whereNONE)
16451 {
16452 if (na & (FFESYMBOL_attrsCOMMON
16453 | FFESYMBOL_attrsEQUIV
16454 | FFESYMBOL_attrsINIT
16455 | FFESYMBOL_attrsNAMELIST))
16456 where = FFEINFO_whereCOMMON;
16457 else if (na & FFESYMBOL_attrsDUMMY)
16458 where = FFEINFO_whereDUMMY;
16459 }
16460
16461 /* Now see what we've got for a new object: NONE means a new error cropped
16462 up; ANY means an old error to be ignored; otherwise, everything's ok,
16463 update the object (symbol) and continue on. */
16464
16465 if (na == FFESYMBOL_attrsetNONE)
16466 ffesymbol_error (s, t);
16467 else if (!(na & FFESYMBOL_attrsANY))
16468 {
16469 ffesymbol_signal_change (s); /* May need to back up to previous
16470 version. */
16471 if (!ffeimplic_establish_symbol (s))
16472 {
16473 ffesymbol_error (s, t);
16474 return s;
16475 }
16476 ffesymbol_set_info (s,
16477 ffeinfo_new (ffesymbol_basictype (s),
16478 ffesymbol_kindtype (s),
16479 ffesymbol_rank (s),
16480 kind, /* Always ENTITY. */
16481 where, /* NONE, COMMON, or DUMMY. */
16482 ffesymbol_size (s)));
16483 ffesymbol_set_attrs (s, na);
16484 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
16485 ffesymbol_resolve_intrin (s);
16486 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16487 }
16488
16489 return s;
16490 }
16491
16492 /* Have FOO in XYZ = ...FOO.... Does not include cases like FOO in
16493 XYZ = BAR(FOO), as such cases are handled elsewhere. */
16494
16495 static ffesymbol
16496 ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t)
16497 {
16498 ffesymbolAttrs sa;
16499 ffesymbolAttrs na;
16500 ffeinfoKind kind;
16501 ffeinfoWhere where;
16502 bool error = FALSE;
16503
16504 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16505 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16506
16507 na = sa = ffesymbol_attrs (s);
16508
16509 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16510 | FFESYMBOL_attrsADJUSTABLE
16511 | FFESYMBOL_attrsANYLEN
16512 | FFESYMBOL_attrsARRAY
16513 | FFESYMBOL_attrsDUMMY
16514 | FFESYMBOL_attrsEXTERNAL
16515 | FFESYMBOL_attrsSFARG
16516 | FFESYMBOL_attrsTYPE)));
16517
16518 kind = ffesymbol_kind (s);
16519 where = ffesymbol_where (s);
16520
16521 /* Figure out what kind of object we've got based on previous declarations
16522 of or references to the object. */
16523
16524 if (sa & FFESYMBOL_attrsEXTERNAL)
16525 {
16526 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16527 | FFESYMBOL_attrsDUMMY
16528 | FFESYMBOL_attrsEXTERNAL
16529 | FFESYMBOL_attrsTYPE)));
16530
16531 error = TRUE;
16532 }
16533 else if (sa & FFESYMBOL_attrsDUMMY)
16534 {
16535 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16536 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16537 | FFESYMBOL_attrsEXTERNAL
16538 | FFESYMBOL_attrsTYPE)));
16539
16540 kind = FFEINFO_kindENTITY;
16541 }
16542 else if (sa & FFESYMBOL_attrsARRAY)
16543 {
16544 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16545 | FFESYMBOL_attrsADJUSTABLE
16546 | FFESYMBOL_attrsTYPE)));
16547
16548 where = FFEINFO_whereLOCAL;
16549 }
16550 else if (sa & FFESYMBOL_attrsSFARG)
16551 {
16552 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16553 | FFESYMBOL_attrsTYPE)));
16554
16555 where = FFEINFO_whereLOCAL;
16556 }
16557 else if (sa & FFESYMBOL_attrsTYPE)
16558 {
16559 assert (!(sa & (FFESYMBOL_attrsARRAY
16560 | FFESYMBOL_attrsDUMMY
16561 | FFESYMBOL_attrsEXTERNAL
16562 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16563 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16564 | FFESYMBOL_attrsADJUSTABLE
16565 | FFESYMBOL_attrsANYLEN
16566 | FFESYMBOL_attrsARRAY
16567 | FFESYMBOL_attrsDUMMY
16568 | FFESYMBOL_attrsEXTERNAL
16569 | FFESYMBOL_attrsSFARG)));
16570
16571 if (sa & FFESYMBOL_attrsANYLEN)
16572 error = TRUE;
16573 else
16574 {
16575 kind = FFEINFO_kindENTITY;
16576 where = FFEINFO_whereLOCAL;
16577 }
16578 }
16579 else if (sa == FFESYMBOL_attrsetNONE)
16580 {
16581 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16582 kind = FFEINFO_kindENTITY;
16583 where = FFEINFO_whereLOCAL;
16584 }
16585 else
16586 error = TRUE;
16587
16588 /* Now see what we've got for a new object: NONE means a new error cropped
16589 up; ANY means an old error to be ignored; otherwise, everything's ok,
16590 update the object (symbol) and continue on. */
16591
16592 if (error)
16593 ffesymbol_error (s, t);
16594 else if (!(na & FFESYMBOL_attrsANY))
16595 {
16596 ffesymbol_signal_change (s); /* May need to back up to previous
16597 version. */
16598 if (!ffeimplic_establish_symbol (s))
16599 {
16600 ffesymbol_error (s, t);
16601 return s;
16602 }
16603 ffesymbol_set_info (s,
16604 ffeinfo_new (ffesymbol_basictype (s),
16605 ffesymbol_kindtype (s),
16606 ffesymbol_rank (s),
16607 kind, /* ENTITY. */
16608 where, /* LOCAL. */
16609 ffesymbol_size (s)));
16610 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16611 ffesymbol_resolve_intrin (s);
16612 s = ffecom_sym_learned (s);
16613 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16614 }
16615
16616 return s;
16617 }
16618
16619 /* ffeexpr_declare_parenthesized_ -- ffesymbol wrapper for NAME(...) operand
16620
16621 ffelexToken t;
16622 bool maybe_intrin;
16623 ffeexprParenType_ paren_type;
16624 ffesymbol s;
16625 s = ffeexpr_declare_parenthesized_ (t, maybe_intrin, &paren_type);
16626
16627 Just like ffesymbol_declare_local, except performs any implicit info
16628 assignment necessary, and it returns the type of the parenthesized list
16629 (list of function args, list of array args, or substring spec). */
16630
16631 static ffesymbol
16632 ffeexpr_declare_parenthesized_ (ffelexToken t, bool maybe_intrin,
16633 ffeexprParenType_ *paren_type)
16634 {
16635 ffesymbol s;
16636 ffesymbolState st; /* Effective state. */
16637 ffeinfoKind k;
16638 bool bad;
16639
16640 if (maybe_intrin && ffesrc_check_symbol ())
16641 { /* Knock off some easy cases. */
16642 switch (ffeexpr_stack_->context)
16643 {
16644 case FFEEXPR_contextSUBROUTINEREF:
16645 case FFEEXPR_contextDATA:
16646 case FFEEXPR_contextDATAIMPDOINDEX_:
16647 case FFEEXPR_contextSFUNCDEF:
16648 case FFEEXPR_contextSFUNCDEFINDEX_:
16649 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16650 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16651 case FFEEXPR_contextLET:
16652 case FFEEXPR_contextPAREN_:
16653 case FFEEXPR_contextACTUALARGEXPR_:
16654 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16655 case FFEEXPR_contextIOLIST:
16656 case FFEEXPR_contextIOLISTDF:
16657 case FFEEXPR_contextDO:
16658 case FFEEXPR_contextDOWHILE:
16659 case FFEEXPR_contextACTUALARG_:
16660 case FFEEXPR_contextCGOTO:
16661 case FFEEXPR_contextIF:
16662 case FFEEXPR_contextARITHIF:
16663 case FFEEXPR_contextFORMAT:
16664 case FFEEXPR_contextSTOP:
16665 case FFEEXPR_contextRETURN:
16666 case FFEEXPR_contextSELECTCASE:
16667 case FFEEXPR_contextCASE:
16668 case FFEEXPR_contextFILEASSOC:
16669 case FFEEXPR_contextFILEINT:
16670 case FFEEXPR_contextFILEDFINT:
16671 case FFEEXPR_contextFILELOG:
16672 case FFEEXPR_contextFILENUM:
16673 case FFEEXPR_contextFILENUMAMBIG:
16674 case FFEEXPR_contextFILECHAR:
16675 case FFEEXPR_contextFILENUMCHAR:
16676 case FFEEXPR_contextFILEDFCHAR:
16677 case FFEEXPR_contextFILEKEY:
16678 case FFEEXPR_contextFILEUNIT:
16679 case FFEEXPR_contextFILEUNIT_DF:
16680 case FFEEXPR_contextFILEUNITAMBIG:
16681 case FFEEXPR_contextFILEFORMAT:
16682 case FFEEXPR_contextFILENAMELIST:
16683 case FFEEXPR_contextFILEVXTCODE:
16684 case FFEEXPR_contextINDEX_:
16685 case FFEEXPR_contextIMPDOITEM_:
16686 case FFEEXPR_contextIMPDOITEMDF_:
16687 case FFEEXPR_contextIMPDOCTRL_:
16688 case FFEEXPR_contextDATAIMPDOCTRL_:
16689 case FFEEXPR_contextCHARACTERSIZE:
16690 case FFEEXPR_contextPARAMETER:
16691 case FFEEXPR_contextDIMLIST:
16692 case FFEEXPR_contextDIMLISTCOMMON:
16693 case FFEEXPR_contextKINDTYPE:
16694 case FFEEXPR_contextINITVAL:
16695 case FFEEXPR_contextEQVINDEX_:
16696 break; /* These could be intrinsic invocations. */
16697
16698 case FFEEXPR_contextAGOTO:
16699 case FFEEXPR_contextFILEFORMATNML:
16700 case FFEEXPR_contextALLOCATE:
16701 case FFEEXPR_contextDEALLOCATE:
16702 case FFEEXPR_contextHEAPSTAT:
16703 case FFEEXPR_contextNULLIFY:
16704 case FFEEXPR_contextINCLUDE:
16705 case FFEEXPR_contextDATAIMPDOITEM_:
16706 case FFEEXPR_contextLOC_:
16707 case FFEEXPR_contextINDEXORACTUALARG_:
16708 case FFEEXPR_contextSFUNCDEFACTUALARG_:
16709 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
16710 case FFEEXPR_contextPARENFILENUM_:
16711 case FFEEXPR_contextPARENFILEUNIT_:
16712 maybe_intrin = FALSE;
16713 break; /* Can't be intrinsic invocation. */
16714
16715 default:
16716 assert ("blah! blah! waaauuggh!" == NULL);
16717 break;
16718 }
16719 }
16720
16721 s = ffesymbol_declare_local (t, maybe_intrin);
16722
16723 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16724 /* Special-case these since they can involve a different concept
16725 of "state" (in the stmtfunc name space). */
16726 {
16727 case FFEEXPR_contextDATAIMPDOINDEX_:
16728 case FFEEXPR_contextDATAIMPDOCTRL_:
16729 if (ffeexpr_context_outer_ (ffeexpr_stack_)
16730 == FFEEXPR_contextDATAIMPDOINDEX_)
16731 s = ffeexpr_sym_impdoitem_ (s, t);
16732 else
16733 if (ffeexpr_stack_->is_rhs)
16734 s = ffeexpr_sym_impdoitem_ (s, t);
16735 else
16736 s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
16737 if (ffesymbol_kind (s) != FFEINFO_kindANY)
16738 ffesymbol_error (s, t);
16739 return s;
16740
16741 default:
16742 break;
16743 }
16744
16745 switch ((ffesymbol_sfdummyparent (s) == NULL)
16746 ? ffesymbol_state (s)
16747 : FFESYMBOL_stateUNDERSTOOD)
16748 {
16749 case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr
16750 context. */
16751 if (!ffest_seen_first_exec ())
16752 goto seen; /* :::::::::::::::::::: */
16753 /* Fall through. */
16754 case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */
16755 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16756 {
16757 case FFEEXPR_contextSUBROUTINEREF:
16758 s = ffeexpr_sym_lhs_call_ (s, t); /* "CALL FOO"=="CALL
16759 FOO(...)". */
16760 break;
16761
16762 case FFEEXPR_contextDATA:
16763 if (ffeexpr_stack_->is_rhs)
16764 s = ffeexpr_sym_rhs_let_ (s, t);
16765 else
16766 s = ffeexpr_sym_lhs_data_ (s, t);
16767 break;
16768
16769 case FFEEXPR_contextDATAIMPDOITEM_:
16770 s = ffeexpr_sym_lhs_data_ (s, t);
16771 break;
16772
16773 case FFEEXPR_contextSFUNCDEF:
16774 case FFEEXPR_contextSFUNCDEFINDEX_:
16775 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16776 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16777 s = ffecom_sym_exec_transition (s);
16778 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16779 goto understood; /* :::::::::::::::::::: */
16780 /* Fall through. */
16781 case FFEEXPR_contextLET:
16782 case FFEEXPR_contextPAREN_:
16783 case FFEEXPR_contextACTUALARGEXPR_:
16784 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16785 case FFEEXPR_contextIOLIST:
16786 case FFEEXPR_contextIOLISTDF:
16787 case FFEEXPR_contextDO:
16788 case FFEEXPR_contextDOWHILE:
16789 case FFEEXPR_contextACTUALARG_:
16790 case FFEEXPR_contextCGOTO:
16791 case FFEEXPR_contextIF:
16792 case FFEEXPR_contextARITHIF:
16793 case FFEEXPR_contextFORMAT:
16794 case FFEEXPR_contextSTOP:
16795 case FFEEXPR_contextRETURN:
16796 case FFEEXPR_contextSELECTCASE:
16797 case FFEEXPR_contextCASE:
16798 case FFEEXPR_contextFILEASSOC:
16799 case FFEEXPR_contextFILEINT:
16800 case FFEEXPR_contextFILEDFINT:
16801 case FFEEXPR_contextFILELOG:
16802 case FFEEXPR_contextFILENUM:
16803 case FFEEXPR_contextFILENUMAMBIG:
16804 case FFEEXPR_contextFILECHAR:
16805 case FFEEXPR_contextFILENUMCHAR:
16806 case FFEEXPR_contextFILEDFCHAR:
16807 case FFEEXPR_contextFILEKEY:
16808 case FFEEXPR_contextFILEUNIT:
16809 case FFEEXPR_contextFILEUNIT_DF:
16810 case FFEEXPR_contextFILEUNITAMBIG:
16811 case FFEEXPR_contextFILEFORMAT:
16812 case FFEEXPR_contextFILENAMELIST:
16813 case FFEEXPR_contextFILEVXTCODE:
16814 case FFEEXPR_contextINDEX_:
16815 case FFEEXPR_contextIMPDOITEM_:
16816 case FFEEXPR_contextIMPDOITEMDF_:
16817 case FFEEXPR_contextIMPDOCTRL_:
16818 case FFEEXPR_contextLOC_:
16819 if (ffeexpr_stack_->is_rhs)
16820 s = ffeexpr_paren_rhs_let_ (s, t);
16821 else
16822 s = ffeexpr_paren_lhs_let_ (s, t);
16823 break;
16824
16825 case FFEEXPR_contextASSIGN:
16826 case FFEEXPR_contextAGOTO:
16827 case FFEEXPR_contextCHARACTERSIZE:
16828 case FFEEXPR_contextEQUIVALENCE:
16829 case FFEEXPR_contextINCLUDE:
16830 case FFEEXPR_contextPARAMETER:
16831 case FFEEXPR_contextDIMLIST:
16832 case FFEEXPR_contextDIMLISTCOMMON:
16833 case FFEEXPR_contextKINDTYPE:
16834 case FFEEXPR_contextINITVAL:
16835 case FFEEXPR_contextEQVINDEX_:
16836 break; /* Will turn into errors below. */
16837
16838 default:
16839 ffesymbol_error (s, t);
16840 break;
16841 }
16842 /* Fall through. */
16843 case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */
16844 understood: /* :::::::::::::::::::: */
16845
16846 /* State might have changed, update it. */
16847 st = ((ffesymbol_sfdummyparent (s) == NULL)
16848 ? ffesymbol_state (s)
16849 : FFESYMBOL_stateUNDERSTOOD);
16850
16851 k = ffesymbol_kind (s);
16852 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16853 {
16854 case FFEEXPR_contextSUBROUTINEREF:
16855 bad = ((k != FFEINFO_kindSUBROUTINE)
16856 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
16857 || (k != FFEINFO_kindNONE)));
16858 break;
16859
16860 case FFEEXPR_contextDATA:
16861 if (ffeexpr_stack_->is_rhs)
16862 bad = (k != FFEINFO_kindENTITY)
16863 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16864 else
16865 bad = (k != FFEINFO_kindENTITY)
16866 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
16867 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
16868 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
16869 break;
16870
16871 case FFEEXPR_contextDATAIMPDOITEM_:
16872 bad = (k != FFEINFO_kindENTITY) || (ffesymbol_rank (s) == 0)
16873 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
16874 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
16875 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
16876 break;
16877
16878 case FFEEXPR_contextSFUNCDEF:
16879 case FFEEXPR_contextSFUNCDEFINDEX_:
16880 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16881 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16882 case FFEEXPR_contextLET:
16883 case FFEEXPR_contextPAREN_:
16884 case FFEEXPR_contextACTUALARGEXPR_:
16885 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16886 case FFEEXPR_contextIOLIST:
16887 case FFEEXPR_contextIOLISTDF:
16888 case FFEEXPR_contextDO:
16889 case FFEEXPR_contextDOWHILE:
16890 case FFEEXPR_contextACTUALARG_:
16891 case FFEEXPR_contextCGOTO:
16892 case FFEEXPR_contextIF:
16893 case FFEEXPR_contextARITHIF:
16894 case FFEEXPR_contextFORMAT:
16895 case FFEEXPR_contextSTOP:
16896 case FFEEXPR_contextRETURN:
16897 case FFEEXPR_contextSELECTCASE:
16898 case FFEEXPR_contextCASE:
16899 case FFEEXPR_contextFILEASSOC:
16900 case FFEEXPR_contextFILEINT:
16901 case FFEEXPR_contextFILEDFINT:
16902 case FFEEXPR_contextFILELOG:
16903 case FFEEXPR_contextFILENUM:
16904 case FFEEXPR_contextFILENUMAMBIG:
16905 case FFEEXPR_contextFILECHAR:
16906 case FFEEXPR_contextFILENUMCHAR:
16907 case FFEEXPR_contextFILEDFCHAR:
16908 case FFEEXPR_contextFILEKEY:
16909 case FFEEXPR_contextFILEUNIT:
16910 case FFEEXPR_contextFILEUNIT_DF:
16911 case FFEEXPR_contextFILEUNITAMBIG:
16912 case FFEEXPR_contextFILEFORMAT:
16913 case FFEEXPR_contextFILENAMELIST:
16914 case FFEEXPR_contextFILEVXTCODE:
16915 case FFEEXPR_contextINDEX_:
16916 case FFEEXPR_contextIMPDOITEM_:
16917 case FFEEXPR_contextIMPDOITEMDF_:
16918 case FFEEXPR_contextIMPDOCTRL_:
16919 case FFEEXPR_contextLOC_:
16920 bad = FALSE; /* Let paren-switch handle the cases. */
16921 break;
16922
16923 case FFEEXPR_contextASSIGN:
16924 case FFEEXPR_contextAGOTO:
16925 case FFEEXPR_contextCHARACTERSIZE:
16926 case FFEEXPR_contextEQUIVALENCE:
16927 case FFEEXPR_contextPARAMETER:
16928 case FFEEXPR_contextDIMLIST:
16929 case FFEEXPR_contextDIMLISTCOMMON:
16930 case FFEEXPR_contextKINDTYPE:
16931 case FFEEXPR_contextINITVAL:
16932 case FFEEXPR_contextEQVINDEX_:
16933 bad = (k != FFEINFO_kindENTITY)
16934 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16935 break;
16936
16937 case FFEEXPR_contextINCLUDE:
16938 bad = TRUE;
16939 break;
16940
16941 default:
16942 bad = TRUE;
16943 break;
16944 }
16945
16946 switch (bad ? FFEINFO_kindANY : k)
16947 {
16948 case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */
16949 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
16950 {
16951 if (ffeexpr_context_outer_ (ffeexpr_stack_)
16952 == FFEEXPR_contextSUBROUTINEREF)
16953 *paren_type = FFEEXPR_parentypeSUBROUTINE_;
16954 else
16955 *paren_type = FFEEXPR_parentypeFUNCTION_;
16956 break;
16957 }
16958 if (st == FFESYMBOL_stateUNDERSTOOD)
16959 {
16960 bad = TRUE;
16961 *paren_type = FFEEXPR_parentypeANY_;
16962 }
16963 else
16964 *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
16965 break;
16966
16967 case FFEINFO_kindFUNCTION:
16968 *paren_type = FFEEXPR_parentypeFUNCTION_;
16969 switch (ffesymbol_where (s))
16970 {
16971 case FFEINFO_whereLOCAL:
16972 bad = TRUE; /* Attempt to recurse! */
16973 break;
16974
16975 case FFEINFO_whereCONSTANT:
16976 bad = ((ffesymbol_sfexpr (s) == NULL)
16977 || (ffebld_op (ffesymbol_sfexpr (s))
16978 == FFEBLD_opANY)); /* Attempt to recurse! */
16979 break;
16980
16981 default:
16982 break;
16983 }
16984 break;
16985
16986 case FFEINFO_kindSUBROUTINE:
16987 if ((ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
16988 || (ffeexpr_stack_->previous != NULL))
16989 {
16990 bad = TRUE;
16991 *paren_type = FFEEXPR_parentypeANY_;
16992 break;
16993 }
16994
16995 *paren_type = FFEEXPR_parentypeSUBROUTINE_;
16996 switch (ffesymbol_where (s))
16997 {
16998 case FFEINFO_whereLOCAL:
16999 case FFEINFO_whereCONSTANT:
17000 bad = TRUE; /* Attempt to recurse! */
17001 break;
17002
17003 default:
17004 break;
17005 }
17006 break;
17007
17008 case FFEINFO_kindENTITY:
17009 if (ffesymbol_rank (s) == 0)
17010 {
17011 if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
17012 *paren_type = FFEEXPR_parentypeSUBSTRING_;
17013 else
17014 {
17015 bad = TRUE;
17016 *paren_type = FFEEXPR_parentypeANY_;
17017 }
17018 }
17019 else
17020 *paren_type = FFEEXPR_parentypeARRAY_;
17021 break;
17022
17023 default:
17024 case FFEINFO_kindANY:
17025 bad = TRUE;
17026 *paren_type = FFEEXPR_parentypeANY_;
17027 break;
17028 }
17029
17030 if (bad)
17031 {
17032 if (k == FFEINFO_kindANY)
17033 ffest_shutdown ();
17034 else
17035 ffesymbol_error (s, t);
17036 }
17037
17038 return s;
17039
17040 case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */
17041 seen: /* :::::::::::::::::::: */
17042 bad = TRUE;
17043 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17044 {
17045 case FFEEXPR_contextPARAMETER:
17046 if (ffeexpr_stack_->is_rhs)
17047 ffesymbol_error (s, t);
17048 else
17049 s = ffeexpr_sym_lhs_parameter_ (s, t);
17050 break;
17051
17052 case FFEEXPR_contextDATA:
17053 s = ffecom_sym_exec_transition (s);
17054 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17055 goto understood; /* :::::::::::::::::::: */
17056 if (ffeexpr_stack_->is_rhs)
17057 ffesymbol_error (s, t);
17058 else
17059 s = ffeexpr_sym_lhs_data_ (s, t);
17060 goto understood; /* :::::::::::::::::::: */
17061
17062 case FFEEXPR_contextDATAIMPDOITEM_:
17063 s = ffecom_sym_exec_transition (s);
17064 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17065 goto understood; /* :::::::::::::::::::: */
17066 s = ffeexpr_sym_lhs_data_ (s, t);
17067 goto understood; /* :::::::::::::::::::: */
17068
17069 case FFEEXPR_contextEQUIVALENCE:
17070 s = ffeexpr_sym_lhs_equivalence_ (s, t);
17071 bad = FALSE;
17072 break;
17073
17074 case FFEEXPR_contextDIMLIST:
17075 s = ffeexpr_sym_rhs_dimlist_ (s, t);
17076 bad = FALSE;
17077 break;
17078
17079 case FFEEXPR_contextCHARACTERSIZE:
17080 case FFEEXPR_contextKINDTYPE:
17081 case FFEEXPR_contextDIMLISTCOMMON:
17082 case FFEEXPR_contextINITVAL:
17083 case FFEEXPR_contextEQVINDEX_:
17084 break;
17085
17086 case FFEEXPR_contextINCLUDE:
17087 break;
17088
17089 case FFEEXPR_contextINDEX_:
17090 case FFEEXPR_contextACTUALARGEXPR_:
17091 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17092 case FFEEXPR_contextSFUNCDEF:
17093 case FFEEXPR_contextSFUNCDEFINDEX_:
17094 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17095 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17096 assert (ffeexpr_stack_->is_rhs);
17097 s = ffecom_sym_exec_transition (s);
17098 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17099 goto understood; /* :::::::::::::::::::: */
17100 s = ffeexpr_paren_rhs_let_ (s, t);
17101 goto understood; /* :::::::::::::::::::: */
17102
17103 default:
17104 break;
17105 }
17106 k = ffesymbol_kind (s);
17107 switch (bad ? FFEINFO_kindANY : k)
17108 {
17109 case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */
17110 *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
17111 break;
17112
17113 case FFEINFO_kindFUNCTION:
17114 *paren_type = FFEEXPR_parentypeFUNCTION_;
17115 switch (ffesymbol_where (s))
17116 {
17117 case FFEINFO_whereLOCAL:
17118 bad = TRUE; /* Attempt to recurse! */
17119 break;
17120
17121 case FFEINFO_whereCONSTANT:
17122 bad = ((ffesymbol_sfexpr (s) == NULL)
17123 || (ffebld_op (ffesymbol_sfexpr (s))
17124 == FFEBLD_opANY)); /* Attempt to recurse! */
17125 break;
17126
17127 default:
17128 break;
17129 }
17130 break;
17131
17132 case FFEINFO_kindSUBROUTINE:
17133 *paren_type = FFEEXPR_parentypeANY_;
17134 bad = TRUE; /* Cannot possibly be in
17135 contextSUBROUTINEREF. */
17136 break;
17137
17138 case FFEINFO_kindENTITY:
17139 if (ffesymbol_rank (s) == 0)
17140 {
17141 if (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE)
17142 *paren_type = FFEEXPR_parentypeEQUIVALENCE_;
17143 else if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
17144 *paren_type = FFEEXPR_parentypeSUBSTRING_;
17145 else
17146 {
17147 bad = TRUE;
17148 *paren_type = FFEEXPR_parentypeANY_;
17149 }
17150 }
17151 else
17152 *paren_type = FFEEXPR_parentypeARRAY_;
17153 break;
17154
17155 default:
17156 case FFEINFO_kindANY:
17157 bad = TRUE;
17158 *paren_type = FFEEXPR_parentypeANY_;
17159 break;
17160 }
17161
17162 if (bad)
17163 {
17164 if (k == FFEINFO_kindANY)
17165 ffest_shutdown ();
17166 else
17167 ffesymbol_error (s, t);
17168 }
17169
17170 return s;
17171
17172 default:
17173 assert ("bad symbol state" == NULL);
17174 return NULL;
17175 }
17176 }
17177
17178 /* Have FOO in XYZ = ...FOO(...).... Executable context only. */
17179
17180 static ffesymbol
17181 ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t)
17182 {
17183 ffesymbolAttrs sa;
17184 ffesymbolAttrs na;
17185 ffeinfoKind kind;
17186 ffeinfoWhere where;
17187 ffeintrinGen gen;
17188 ffeintrinSpec spec;
17189 ffeintrinImp imp;
17190 bool maybe_ambig = FALSE;
17191 bool error = FALSE;
17192
17193 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
17194 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
17195
17196 na = sa = ffesymbol_attrs (s);
17197
17198 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17199 | FFESYMBOL_attrsADJUSTABLE
17200 | FFESYMBOL_attrsANYLEN
17201 | FFESYMBOL_attrsARRAY
17202 | FFESYMBOL_attrsDUMMY
17203 | FFESYMBOL_attrsEXTERNAL
17204 | FFESYMBOL_attrsSFARG
17205 | FFESYMBOL_attrsTYPE)));
17206
17207 kind = ffesymbol_kind (s);
17208 where = ffesymbol_where (s);
17209
17210 /* Figure out what kind of object we've got based on previous declarations
17211 of or references to the object. */
17212
17213 if (sa & FFESYMBOL_attrsEXTERNAL)
17214 {
17215 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17216 | FFESYMBOL_attrsDUMMY
17217 | FFESYMBOL_attrsEXTERNAL
17218 | FFESYMBOL_attrsTYPE)));
17219
17220 if (sa & FFESYMBOL_attrsTYPE)
17221 where = FFEINFO_whereGLOBAL;
17222 else
17223 /* Not TYPE. */
17224 {
17225 kind = FFEINFO_kindFUNCTION;
17226
17227 if (sa & FFESYMBOL_attrsDUMMY)
17228 ; /* Not TYPE. */
17229 else if (sa & FFESYMBOL_attrsACTUALARG)
17230 ; /* Not DUMMY or TYPE. */
17231 else /* Not ACTUALARG, DUMMY, or TYPE. */
17232 where = FFEINFO_whereGLOBAL;
17233 }
17234 }
17235 else if (sa & FFESYMBOL_attrsDUMMY)
17236 {
17237 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
17238 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
17239 | FFESYMBOL_attrsEXTERNAL
17240 | FFESYMBOL_attrsTYPE)));
17241
17242 kind = FFEINFO_kindFUNCTION;
17243 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure; kind
17244 could be ENTITY w/substring ref. */
17245 }
17246 else if (sa & FFESYMBOL_attrsARRAY)
17247 {
17248 assert (!(sa & ~(FFESYMBOL_attrsARRAY
17249 | FFESYMBOL_attrsADJUSTABLE
17250 | FFESYMBOL_attrsTYPE)));
17251
17252 where = FFEINFO_whereLOCAL;
17253 }
17254 else if (sa & FFESYMBOL_attrsSFARG)
17255 {
17256 assert (!(sa & ~(FFESYMBOL_attrsSFARG
17257 | FFESYMBOL_attrsTYPE)));
17258
17259 where = FFEINFO_whereLOCAL; /* Actually an error, but at least we
17260 know it's a local var. */
17261 }
17262 else if (sa & FFESYMBOL_attrsTYPE)
17263 {
17264 assert (!(sa & (FFESYMBOL_attrsARRAY
17265 | FFESYMBOL_attrsDUMMY
17266 | FFESYMBOL_attrsEXTERNAL
17267 | FFESYMBOL_attrsSFARG))); /* Handled above. */
17268 assert (!(sa & ~(FFESYMBOL_attrsTYPE
17269 | FFESYMBOL_attrsADJUSTABLE
17270 | FFESYMBOL_attrsANYLEN
17271 | FFESYMBOL_attrsARRAY
17272 | FFESYMBOL_attrsDUMMY
17273 | FFESYMBOL_attrsEXTERNAL
17274 | FFESYMBOL_attrsSFARG)));
17275
17276 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
17277 &gen, &spec, &imp))
17278 {
17279 if (!(sa & FFESYMBOL_attrsANYLEN)
17280 && (ffeimplic_peek_symbol_type (s, NULL)
17281 == FFEINFO_basictypeCHARACTER))
17282 return s; /* Haven't learned anything yet. */
17283
17284 ffesymbol_signal_change (s); /* May need to back up to previous
17285 version. */
17286 ffesymbol_set_generic (s, gen);
17287 ffesymbol_set_specific (s, spec);
17288 ffesymbol_set_implementation (s, imp);
17289 ffesymbol_set_info (s,
17290 ffeinfo_new (ffesymbol_basictype (s),
17291 ffesymbol_kindtype (s),
17292 0,
17293 FFEINFO_kindFUNCTION,
17294 FFEINFO_whereINTRINSIC,
17295 ffesymbol_size (s)));
17296 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17297 ffesymbol_resolve_intrin (s);
17298 ffesymbol_reference (s, t, FALSE);
17299 s = ffecom_sym_learned (s);
17300 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17301
17302 return s;
17303 }
17304 if (sa & FFESYMBOL_attrsANYLEN)
17305 error = TRUE; /* Error, since the only way we can,
17306 given CHARACTER*(*) FOO, accept
17307 FOO(...) is for FOO to be a dummy
17308 arg or constant, but it can't
17309 become either now. */
17310 else if (sa & FFESYMBOL_attrsADJUSTABLE)
17311 {
17312 kind = FFEINFO_kindENTITY;
17313 where = FFEINFO_whereLOCAL;
17314 }
17315 else
17316 {
17317 kind = FFEINFO_kindFUNCTION;
17318 where = FFEINFO_whereGLOBAL;
17319 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure;
17320 could be ENTITY/LOCAL w/substring ref. */
17321 }
17322 }
17323 else if (sa == FFESYMBOL_attrsetNONE)
17324 {
17325 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
17326
17327 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
17328 &gen, &spec, &imp))
17329 {
17330 if (ffeimplic_peek_symbol_type (s, NULL)
17331 == FFEINFO_basictypeCHARACTER)
17332 return s; /* Haven't learned anything yet. */
17333
17334 ffesymbol_signal_change (s); /* May need to back up to previous
17335 version. */
17336 ffesymbol_set_generic (s, gen);
17337 ffesymbol_set_specific (s, spec);
17338 ffesymbol_set_implementation (s, imp);
17339 ffesymbol_set_info (s,
17340 ffeinfo_new (ffesymbol_basictype (s),
17341 ffesymbol_kindtype (s),
17342 0,
17343 FFEINFO_kindFUNCTION,
17344 FFEINFO_whereINTRINSIC,
17345 ffesymbol_size (s)));
17346 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17347 ffesymbol_resolve_intrin (s);
17348 s = ffecom_sym_learned (s);
17349 ffesymbol_reference (s, t, FALSE);
17350 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17351 return s;
17352 }
17353
17354 kind = FFEINFO_kindFUNCTION;
17355 where = FFEINFO_whereGLOBAL;
17356 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure;
17357 could be ENTITY/LOCAL w/substring ref. */
17358 }
17359 else
17360 error = TRUE;
17361
17362 /* Now see what we've got for a new object: NONE means a new error cropped
17363 up; ANY means an old error to be ignored; otherwise, everything's ok,
17364 update the object (symbol) and continue on. */
17365
17366 if (error)
17367 ffesymbol_error (s, t);
17368 else if (!(na & FFESYMBOL_attrsANY))
17369 {
17370 ffesymbol_signal_change (s); /* May need to back up to previous
17371 version. */
17372 if (!ffeimplic_establish_symbol (s))
17373 {
17374 ffesymbol_error (s, t);
17375 return s;
17376 }
17377 if (maybe_ambig
17378 && (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
17379 return s; /* Still not sure, let caller deal with it
17380 based on (...). */
17381
17382 ffesymbol_set_info (s,
17383 ffeinfo_new (ffesymbol_basictype (s),
17384 ffesymbol_kindtype (s),
17385 ffesymbol_rank (s),
17386 kind,
17387 where,
17388 ffesymbol_size (s)));
17389 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17390 ffesymbol_resolve_intrin (s);
17391 s = ffecom_sym_learned (s);
17392 ffesymbol_reference (s, t, FALSE);
17393 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17394 }
17395
17396 return s;
17397 }
17398
17399 /* ffeexpr_token_arguments_ -- OPEN_PAREN [expr COMMA]...expr
17400
17401 Return a pointer to this function to the lexer (ffelex), which will
17402 invoke it for the next token.
17403
17404 Handle expression (which might be null) and COMMA or CLOSE_PAREN. */
17405
17406 static ffelexHandler
17407 ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr, ffelexToken t)
17408 {
17409 ffeexprExpr_ procedure;
17410 ffebld reduced;
17411 ffeinfo info;
17412 ffeexprContext ctx;
17413 bool check_intrin = FALSE; /* Set TRUE if intrinsic is REAL(Z) or AIMAG(Z). */
17414
17415 procedure = ffeexpr_stack_->exprstack;
17416 info = ffebld_info (procedure->u.operand);
17417
17418 /* Is there an expression to add? If the expression is nil,
17419 it might still be an argument. It is if:
17420
17421 - The current token is comma, or
17422
17423 - The -fugly-comma flag was specified *and* the procedure
17424 being invoked is external.
17425
17426 Otherwise, if neither of the above is the case, just
17427 ignore this (nil) expression. */
17428
17429 if ((expr != NULL)
17430 || (ffelex_token_type (t) == FFELEX_typeCOMMA)
17431 || (ffe_is_ugly_comma ()
17432 && (ffeinfo_where (info) == FFEINFO_whereGLOBAL)))
17433 {
17434 /* This expression, even if nil, is apparently intended as an argument. */
17435
17436 /* Internal procedure (CONTAINS, or statement function)? */
17437
17438 if (ffeinfo_where (info) == FFEINFO_whereCONSTANT)
17439 {
17440 if ((expr == NULL)
17441 && ffebad_start (FFEBAD_NULL_ARGUMENT))
17442 {
17443 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17444 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17445 ffebad_here (1, ffelex_token_where_line (t),
17446 ffelex_token_where_column (t));
17447 ffebad_finish ();
17448 }
17449
17450 if (expr == NULL)
17451 ;
17452 else
17453 {
17454 if (ffeexpr_stack_->next_dummy == NULL)
17455 { /* Report later which was the first extra argument. */
17456 if (ffeexpr_stack_->tokens[1] == NULL)
17457 {
17458 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
17459 ffeexpr_stack_->num_args = 0;
17460 }
17461 ++ffeexpr_stack_->num_args; /* Count # of extra arguments. */
17462 }
17463 else
17464 {
17465 if ((ffeinfo_rank (ffebld_info (expr)) != 0)
17466 && ffebad_start (FFEBAD_ARRAY_AS_SFARG))
17467 {
17468 ffebad_here (0,
17469 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17470 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17471 ffebad_here (1, ffelex_token_where_line (ft),
17472 ffelex_token_where_column (ft));
17473 ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent
17474 (ffebld_symter (ffebld_head
17475 (ffeexpr_stack_->next_dummy)))));
17476 ffebad_finish ();
17477 }
17478 else
17479 {
17480 expr = ffeexpr_convert_expr (expr, ft,
17481 ffebld_head (ffeexpr_stack_->next_dummy),
17482 ffeexpr_stack_->tokens[0],
17483 FFEEXPR_contextLET);
17484 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17485 }
17486 --ffeexpr_stack_->num_args; /* Count down # of args. */
17487 ffeexpr_stack_->next_dummy
17488 = ffebld_trail (ffeexpr_stack_->next_dummy);
17489 }
17490 }
17491 }
17492 else
17493 {
17494 if ((expr == NULL)
17495 && ffe_is_pedantic ()
17496 && ffebad_start (FFEBAD_NULL_ARGUMENT_W))
17497 {
17498 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17499 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17500 ffebad_here (1, ffelex_token_where_line (t),
17501 ffelex_token_where_column (t));
17502 ffebad_finish ();
17503 }
17504 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17505 }
17506 }
17507
17508 switch (ffelex_token_type (t))
17509 {
17510 case FFELEX_typeCOMMA:
17511 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17512 {
17513 case FFEEXPR_contextSFUNCDEF:
17514 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17515 case FFEEXPR_contextSFUNCDEFINDEX_:
17516 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17517 ctx = FFEEXPR_contextSFUNCDEFACTUALARG_;
17518 break;
17519
17520 case FFEEXPR_contextSFUNCDEFACTUALARG_:
17521 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
17522 assert ("bad context" == NULL);
17523 ctx = FFEEXPR_context;
17524 break;
17525
17526 default:
17527 ctx = FFEEXPR_contextACTUALARG_;
17528 break;
17529 }
17530 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
17531 ffeexpr_token_arguments_);
17532
17533 default:
17534 break;
17535 }
17536
17537 if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
17538 && (ffeexpr_stack_->next_dummy != NULL))
17539 { /* Too few arguments. */
17540 if (ffebad_start (FFEBAD_TOO_FEW_ARGUMENTS))
17541 {
17542 char num[10];
17543
17544 sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
17545
17546 ffebad_here (0, ffelex_token_where_line (t),
17547 ffelex_token_where_column (t));
17548 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17549 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17550 ffebad_string (num);
17551 ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent (ffebld_symter
17552 (ffebld_head (ffeexpr_stack_->next_dummy)))));
17553 ffebad_finish ();
17554 }
17555 for (;
17556 ffeexpr_stack_->next_dummy != NULL;
17557 ffeexpr_stack_->next_dummy
17558 = ffebld_trail (ffeexpr_stack_->next_dummy))
17559 {
17560 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0));
17561 ffebld_set_info (expr, ffeinfo_new_any ());
17562 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17563 }
17564 }
17565
17566 if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
17567 && (ffeexpr_stack_->tokens[1] != NULL))
17568 { /* Too many arguments to statement function. */
17569 if (ffebad_start (FFEBAD_TOO_MANY_ARGUMENTS))
17570 {
17571 char num[10];
17572
17573 sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
17574
17575 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
17576 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
17577 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17578 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17579 ffebad_string (num);
17580 ffebad_finish ();
17581 }
17582 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
17583 }
17584 ffebld_end_list (&ffeexpr_stack_->bottom);
17585
17586 if (ffebld_op (procedure->u.operand) == FFEBLD_opANY)
17587 {
17588 reduced = ffebld_new_any ();
17589 ffebld_set_info (reduced, ffeinfo_new_any ());
17590 }
17591 else
17592 {
17593 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
17594 reduced = ffebld_new_funcref (procedure->u.operand,
17595 ffeexpr_stack_->expr);
17596 else
17597 reduced = ffebld_new_subrref (procedure->u.operand,
17598 ffeexpr_stack_->expr);
17599 if (ffebld_symter_generic (procedure->u.operand) != FFEINTRIN_genNONE)
17600 ffeintrin_fulfill_generic (&reduced, &info, ffeexpr_stack_->tokens[0]);
17601 else if (ffebld_symter_specific (procedure->u.operand)
17602 != FFEINTRIN_specNONE)
17603 ffeintrin_fulfill_specific (&reduced, &info, &check_intrin,
17604 ffeexpr_stack_->tokens[0]);
17605 else
17606 ffeexpr_fulfill_call_ (&reduced, ffeexpr_stack_->tokens[0]);
17607
17608 if (ffebld_op (reduced) != FFEBLD_opANY)
17609 ffebld_set_info (reduced,
17610 ffeinfo_new (ffeinfo_basictype (info),
17611 ffeinfo_kindtype (info),
17612 0,
17613 FFEINFO_kindENTITY,
17614 FFEINFO_whereFLEETING,
17615 ffeinfo_size (info)));
17616 else
17617 ffebld_set_info (reduced, ffeinfo_new_any ());
17618 }
17619 if (ffebld_op (reduced) == FFEBLD_opFUNCREF)
17620 reduced = ffeexpr_collapse_funcref (reduced, ffeexpr_stack_->tokens[0]);
17621 ffeexpr_stack_->exprstack = procedure->previous; /* Pops
17622 not-quite-operand off
17623 stack. */
17624 procedure->u.operand = reduced; /* Save the line/column ffewhere
17625 info. */
17626 ffeexpr_exprstack_push_operand_ (procedure); /* Push it back on stack. */
17627 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
17628 {
17629 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
17630 ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FUNC(3)(1:1)".... */
17631
17632 /* If the intrinsic needs checking (is REAL(Z) or AIMAG(Z), where
17633 Z is DOUBLE COMPLEX), and a command-line option doesn't already
17634 establish interpretation, probably complain. */
17635
17636 if (check_intrin
17637 && !ffe_is_90 ()
17638 && !ffe_is_ugly_complex ())
17639 {
17640 /* If the outer expression is REAL(me...), issue diagnostic
17641 only if next token isn't the close-paren for REAL(me). */
17642
17643 if ((ffeexpr_stack_->previous != NULL)
17644 && (ffeexpr_stack_->previous->exprstack != NULL)
17645 && (ffeexpr_stack_->previous->exprstack->type == FFEEXPR_exprtypeOPERAND_)
17646 && ((reduced = ffeexpr_stack_->previous->exprstack->u.operand) != NULL)
17647 && (ffebld_op (reduced) == FFEBLD_opSYMTER)
17648 && (ffebld_symter_implementation (reduced) == FFEINTRIN_impREAL))
17649 return (ffelexHandler) ffeexpr_token_intrincheck_;
17650
17651 /* Diagnose the ambiguity now. */
17652
17653 if (ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
17654 {
17655 ffebad_string (ffeintrin_name_implementation
17656 (ffebld_symter_implementation
17657 (ffebld_left
17658 (ffeexpr_stack_->exprstack->u.operand))));
17659 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
17660 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
17661 ffebad_finish ();
17662 }
17663 }
17664 return (ffelexHandler) ffeexpr_token_substrp_;
17665 }
17666
17667 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
17668 {
17669 ffebad_here (0, ffelex_token_where_line (t),
17670 ffelex_token_where_column (t));
17671 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17672 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17673 ffebad_finish ();
17674 }
17675 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
17676 ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FUNC(3)(1:1)".... */
17677 return
17678 (ffelexHandler) ffeexpr_find_close_paren_ (t,
17679 (ffelexHandler)
17680 ffeexpr_token_substrp_);
17681 }
17682
17683 /* ffeexpr_token_elements_ -- OPEN_PAREN [expr COMMA]...expr
17684
17685 Return a pointer to this array to the lexer (ffelex), which will
17686 invoke it for the next token.
17687
17688 Handle expression and COMMA or CLOSE_PAREN. */
17689
17690 static ffelexHandler
17691 ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, ffelexToken t)
17692 {
17693 ffeexprExpr_ array;
17694 ffebld reduced;
17695 ffeinfo info;
17696 ffeinfoWhere where;
17697 ffetargetIntegerDefault val;
17698 ffetargetIntegerDefault lval = 0;
17699 ffetargetIntegerDefault uval = 0;
17700 ffebld lbound;
17701 ffebld ubound;
17702 bool lcheck;
17703 bool ucheck;
17704
17705 array = ffeexpr_stack_->exprstack;
17706 info = ffebld_info (array->u.operand);
17707
17708 if ((expr == NULL) /* && ((ffeexpr_stack_->rank != 0) ||
17709 (ffelex_token_type(t) ==
17710 FFELEX_typeCOMMA)) */ )
17711 {
17712 if (ffebad_start (FFEBAD_NULL_ELEMENT))
17713 {
17714 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17715 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17716 ffebad_here (1, ffelex_token_where_line (t),
17717 ffelex_token_where_column (t));
17718 ffebad_finish ();
17719 }
17720 if (ffeexpr_stack_->rank < ffeinfo_rank (info))
17721 { /* Don't bother if we're going to complain
17722 later! */
17723 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
17724 ffebld_set_info (expr, ffeinfo_new_any ());
17725 }
17726 }
17727
17728 if (expr == NULL)
17729 ;
17730 else if (ffeinfo_rank (info) == 0)
17731 { /* In EQUIVALENCE context, ffeinfo_rank(info)
17732 may == 0. */
17733 ++ffeexpr_stack_->rank; /* Track anyway, may need for new VXT
17734 feature. */
17735 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17736 }
17737 else
17738 {
17739 ++ffeexpr_stack_->rank;
17740 if (ffeexpr_stack_->rank > ffeinfo_rank (info))
17741 { /* Report later which was the first extra
17742 element. */
17743 if (ffeexpr_stack_->rank == ffeinfo_rank (info) + 1)
17744 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
17745 }
17746 else
17747 {
17748 switch (ffeinfo_where (ffebld_info (expr)))
17749 {
17750 case FFEINFO_whereCONSTANT:
17751 break;
17752
17753 case FFEINFO_whereIMMEDIATE:
17754 ffeexpr_stack_->constant = FALSE;
17755 break;
17756
17757 default:
17758 ffeexpr_stack_->constant = FALSE;
17759 ffeexpr_stack_->immediate = FALSE;
17760 break;
17761 }
17762 if (ffebld_op (expr) == FFEBLD_opCONTER
17763 && ffebld_kindtype (expr) == FFEINFO_kindtypeINTEGERDEFAULT)
17764 {
17765 val = ffebld_constant_integerdefault (ffebld_conter (expr));
17766
17767 lbound = ffebld_left (ffebld_head (ffeexpr_stack_->bound_list));
17768 if (lbound == NULL)
17769 {
17770 lcheck = TRUE;
17771 lval = 1;
17772 }
17773 else if (ffebld_op (lbound) == FFEBLD_opCONTER)
17774 {
17775 lcheck = TRUE;
17776 lval = ffebld_constant_integerdefault (ffebld_conter (lbound));
17777 }
17778 else
17779 lcheck = FALSE;
17780
17781 ubound = ffebld_right (ffebld_head (ffeexpr_stack_->bound_list));
17782 assert (ubound != NULL);
17783 if (ffebld_op (ubound) == FFEBLD_opCONTER)
17784 {
17785 ucheck = TRUE;
17786 uval = ffebld_constant_integerdefault (ffebld_conter (ubound));
17787 }
17788 else
17789 ucheck = FALSE;
17790
17791 if ((lcheck && (val < lval)) || (ucheck && (val > uval)))
17792 {
17793 ffebad_start (FFEBAD_RANGE_ARRAY);
17794 ffebad_here (0, ffelex_token_where_line (ft),
17795 ffelex_token_where_column (ft));
17796 ffebad_finish ();
17797 }
17798 }
17799 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17800 ffeexpr_stack_->bound_list = ffebld_trail (ffeexpr_stack_->bound_list);
17801 }
17802 }
17803
17804 switch (ffelex_token_type (t))
17805 {
17806 case FFELEX_typeCOMMA:
17807 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17808 {
17809 case FFEEXPR_contextDATAIMPDOITEM_:
17810 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
17811 FFEEXPR_contextDATAIMPDOINDEX_,
17812 ffeexpr_token_elements_);
17813
17814 case FFEEXPR_contextEQUIVALENCE:
17815 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
17816 FFEEXPR_contextEQVINDEX_,
17817 ffeexpr_token_elements_);
17818
17819 case FFEEXPR_contextSFUNCDEF:
17820 case FFEEXPR_contextSFUNCDEFINDEX_:
17821 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
17822 FFEEXPR_contextSFUNCDEFINDEX_,
17823 ffeexpr_token_elements_);
17824
17825 case FFEEXPR_contextSFUNCDEFACTUALARG_:
17826 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
17827 assert ("bad context" == NULL);
17828 break;
17829
17830 default:
17831 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
17832 FFEEXPR_contextINDEX_,
17833 ffeexpr_token_elements_);
17834 }
17835
17836 default:
17837 break;
17838 }
17839
17840 if ((ffeexpr_stack_->rank != ffeinfo_rank (info))
17841 && (ffeinfo_rank (info) != 0))
17842 {
17843 char num[10];
17844
17845 if (ffeexpr_stack_->rank < ffeinfo_rank (info))
17846 {
17847 if (ffebad_start (FFEBAD_TOO_FEW_ELEMENTS))
17848 {
17849 sprintf (num, "%d",
17850 (int) (ffeinfo_rank (info) - ffeexpr_stack_->rank));
17851
17852 ffebad_here (0, ffelex_token_where_line (t),
17853 ffelex_token_where_column (t));
17854 ffebad_here (1,
17855 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17856 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17857 ffebad_string (num);
17858 ffebad_finish ();
17859 }
17860 }
17861 else
17862 {
17863 if (ffebad_start (FFEBAD_TOO_MANY_ELEMENTS))
17864 {
17865 sprintf (num, "%d",
17866 (int) (ffeexpr_stack_->rank - ffeinfo_rank (info)));
17867
17868 ffebad_here (0,
17869 ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
17870 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
17871 ffebad_here (1,
17872 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17873 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17874 ffebad_string (num);
17875 ffebad_finish ();
17876 }
17877 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
17878 }
17879 while (ffeexpr_stack_->rank++ < ffeinfo_rank (info))
17880 {
17881 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
17882 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeINTEGER,
17883 FFEINFO_kindtypeINTEGERDEFAULT,
17884 0, FFEINFO_kindENTITY,
17885 FFEINFO_whereCONSTANT,
17886 FFETARGET_charactersizeNONE));
17887 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17888 }
17889 }
17890 ffebld_end_list (&ffeexpr_stack_->bottom);
17891
17892 if (ffebld_op (array->u.operand) == FFEBLD_opANY)
17893 {
17894 reduced = ffebld_new_any ();
17895 ffebld_set_info (reduced, ffeinfo_new_any ());
17896 }
17897 else
17898 {
17899 reduced = ffebld_new_arrayref (array->u.operand, ffeexpr_stack_->expr);
17900 if (ffeexpr_stack_->constant)
17901 where = FFEINFO_whereFLEETING_CADDR;
17902 else if (ffeexpr_stack_->immediate)
17903 where = FFEINFO_whereFLEETING_IADDR;
17904 else
17905 where = FFEINFO_whereFLEETING;
17906 ffebld_set_info (reduced,
17907 ffeinfo_new (ffeinfo_basictype (info),
17908 ffeinfo_kindtype (info),
17909 0,
17910 FFEINFO_kindENTITY,
17911 where,
17912 ffeinfo_size (info)));
17913 reduced = ffeexpr_collapse_arrayref (reduced, ffeexpr_stack_->tokens[0]);
17914 }
17915
17916 ffeexpr_stack_->exprstack = array->previous; /* Pops not-quite-operand off
17917 stack. */
17918 array->u.operand = reduced; /* Save the line/column ffewhere info. */
17919 ffeexpr_exprstack_push_operand_ (array); /* Push it back on stack. */
17920
17921 switch (ffeinfo_basictype (info))
17922 {
17923 case FFEINFO_basictypeCHARACTER:
17924 ffeexpr_is_substr_ok_ = TRUE; /* Everyone likes "FOO(3)(1:1)".... */
17925 break;
17926
17927 case FFEINFO_basictypeNONE:
17928 ffeexpr_is_substr_ok_ = TRUE;
17929 assert (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE);
17930 break;
17931
17932 default:
17933 ffeexpr_is_substr_ok_ = FALSE;
17934 break;
17935 }
17936
17937 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
17938 {
17939 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
17940 return (ffelexHandler) ffeexpr_token_substrp_;
17941 }
17942
17943 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
17944 {
17945 ffebad_here (0, ffelex_token_where_line (t),
17946 ffelex_token_where_column (t));
17947 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17948 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17949 ffebad_finish ();
17950 }
17951 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
17952 return
17953 (ffelexHandler) ffeexpr_find_close_paren_ (t,
17954 (ffelexHandler)
17955 ffeexpr_token_substrp_);
17956 }
17957
17958 /* ffeexpr_token_equivalence_ -- OPEN_PAREN expr
17959
17960 Return a pointer to this array to the lexer (ffelex), which will
17961 invoke it for the next token.
17962
17963 If token is COLON, pass off to _substr_, else init list and pass off
17964 to _elements_. This handles the case "EQUIVALENCE (FOO(expr?", where
17965 ? marks the token, and where FOO's rank/type has not yet been established,
17966 meaning we could be in a list of indices or in a substring
17967 specification. */
17968
17969 static ffelexHandler
17970 ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr, ffelexToken t)
17971 {
17972 if (ffelex_token_type (t) == FFELEX_typeCOLON)
17973 return ffeexpr_token_substring_ (ft, expr, t);
17974
17975 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
17976 return ffeexpr_token_elements_ (ft, expr, t);
17977 }
17978
17979 /* ffeexpr_token_substring_ -- NAME(of kindENTITY) OPEN_PAREN expr
17980
17981 Return a pointer to this function to the lexer (ffelex), which will
17982 invoke it for the next token.
17983
17984 Handle expression (which may be null) and COLON. */
17985
17986 static ffelexHandler
17987 ffeexpr_token_substring_ (ffelexToken ft, ffebld expr, ffelexToken t)
17988 {
17989 ffeexprExpr_ string;
17990 ffeinfo info;
17991 ffetargetIntegerDefault i;
17992 ffeexprContext ctx;
17993 ffetargetCharacterSize size;
17994
17995 string = ffeexpr_stack_->exprstack;
17996 info = ffebld_info (string->u.operand);
17997 size = ffebld_size_max (string->u.operand);
17998
17999 if (ffelex_token_type (t) == FFELEX_typeCOLON)
18000 {
18001 if ((expr != NULL)
18002 && (ffebld_op (expr) == FFEBLD_opCONTER)
18003 && (((i = ffebld_constant_integerdefault (ffebld_conter (expr)))
18004 < 1)
18005 || ((size != FFETARGET_charactersizeNONE) && (i > size))))
18006 {
18007 ffebad_start (FFEBAD_RANGE_SUBSTR);
18008 ffebad_here (0, ffelex_token_where_line (ft),
18009 ffelex_token_where_column (ft));
18010 ffebad_finish ();
18011 }
18012 ffeexpr_stack_->expr = expr;
18013
18014 switch (ffeexpr_stack_->context)
18015 {
18016 case FFEEXPR_contextSFUNCDEF:
18017 case FFEEXPR_contextSFUNCDEFINDEX_:
18018 ctx = FFEEXPR_contextSFUNCDEFINDEX_;
18019 break;
18020
18021 case FFEEXPR_contextSFUNCDEFACTUALARG_:
18022 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18023 assert ("bad context" == NULL);
18024 ctx = FFEEXPR_context;
18025 break;
18026
18027 default:
18028 ctx = FFEEXPR_contextINDEX_;
18029 break;
18030 }
18031
18032 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18033 ffeexpr_token_substring_1_);
18034 }
18035
18036 if (ffest_ffebad_start (FFEBAD_MISSING_COLON_IN_SUBSTR))
18037 {
18038 ffebad_here (0, ffelex_token_where_line (t),
18039 ffelex_token_where_column (t));
18040 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18041 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18042 ffebad_finish ();
18043 }
18044
18045 ffeexpr_stack_->expr = NULL;
18046 return (ffelexHandler) ffeexpr_token_substring_1_ (ft, expr, t);
18047 }
18048
18049 /* ffeexpr_token_substring_1_ -- NAME OPEN_PAREN [expr COMMA]...expr
18050
18051 Return a pointer to this function to the lexer (ffelex), which will
18052 invoke it for the next token.
18053
18054 Handle expression (which might be null) and CLOSE_PAREN. */
18055
18056 static ffelexHandler
18057 ffeexpr_token_substring_1_ (ffelexToken ft, ffebld last, ffelexToken t)
18058 {
18059 ffeexprExpr_ string;
18060 ffebld reduced;
18061 ffebld substrlist;
18062 ffebld first = ffeexpr_stack_->expr;
18063 ffebld strop;
18064 ffeinfo info;
18065 ffeinfoWhere lwh;
18066 ffeinfoWhere rwh;
18067 ffeinfoWhere where;
18068 ffeinfoKindtype first_kt;
18069 ffeinfoKindtype last_kt;
18070 ffetargetIntegerDefault first_val;
18071 ffetargetIntegerDefault last_val;
18072 ffetargetCharacterSize size;
18073 ffetargetCharacterSize strop_size_max;
18074 bool first_known;
18075
18076 string = ffeexpr_stack_->exprstack;
18077 strop = string->u.operand;
18078 info = ffebld_info (strop);
18079
18080 if (first == NULL
18081 || (ffebld_op (first) == FFEBLD_opCONTER
18082 && ffebld_kindtype (first) == FFEINFO_kindtypeINTEGERDEFAULT))
18083 { /* The starting point is known. */
18084 first_val = (first == NULL) ? 1
18085 : ffebld_constant_integerdefault (ffebld_conter (first));
18086 first_known = TRUE;
18087 }
18088 else
18089 { /* Assume start of the entity. */
18090 first_val = 1;
18091 first_known = FALSE;
18092 }
18093
18094 if (last != NULL
18095 && (ffebld_op (last) == FFEBLD_opCONTER
18096 && ffebld_kindtype (last) == FFEINFO_kindtypeINTEGERDEFAULT))
18097 { /* The ending point is known. */
18098 last_val = ffebld_constant_integerdefault (ffebld_conter (last));
18099
18100 if (first_known)
18101 { /* The beginning point is a constant. */
18102 if (first_val <= last_val)
18103 size = last_val - first_val + 1;
18104 else
18105 {
18106 if (0 && ffe_is_90 ())
18107 size = 0;
18108 else
18109 {
18110 size = 1;
18111 ffebad_start (FFEBAD_ZERO_SIZE);
18112 ffebad_here (0, ffelex_token_where_line (ft),
18113 ffelex_token_where_column (ft));
18114 ffebad_finish ();
18115 }
18116 }
18117 }
18118 else
18119 size = FFETARGET_charactersizeNONE;
18120
18121 strop_size_max = ffebld_size_max (strop);
18122
18123 if ((strop_size_max != FFETARGET_charactersizeNONE)
18124 && (last_val > strop_size_max))
18125 { /* Beyond maximum possible end of string. */
18126 ffebad_start (FFEBAD_RANGE_SUBSTR);
18127 ffebad_here (0, ffelex_token_where_line (ft),
18128 ffelex_token_where_column (ft));
18129 ffebad_finish ();
18130 }
18131 }
18132 else
18133 size = FFETARGET_charactersizeNONE; /* The size is not known. */
18134
18135 #if 0 /* Don't do this, or "is size of target
18136 known?" would no longer be easily
18137 answerable. To see if there is a max
18138 size, use ffebld_size_max; to get only the
18139 known size, else NONE, use
18140 ffebld_size_known; use ffebld_size if
18141 values are sure to be the same (not
18142 opSUBSTR or opCONCATENATE or known to have
18143 known length). By getting rid of this
18144 "useful info" stuff, we don't end up
18145 blank-padding the constant in the
18146 assignment "A(I:J)='XYZ'" to the known
18147 length of A. */
18148 if (size == FFETARGET_charactersizeNONE)
18149 size = strop_size_max; /* Assume we use the entire string. */
18150 #endif
18151
18152 substrlist
18153 = ffebld_new_item
18154 (first,
18155 ffebld_new_item
18156 (last,
18157 NULL
18158 )
18159 )
18160 ;
18161
18162 if (first == NULL)
18163 lwh = FFEINFO_whereCONSTANT;
18164 else
18165 lwh = ffeinfo_where (ffebld_info (first));
18166 if (last == NULL)
18167 rwh = FFEINFO_whereCONSTANT;
18168 else
18169 rwh = ffeinfo_where (ffebld_info (last));
18170
18171 switch (lwh)
18172 {
18173 case FFEINFO_whereCONSTANT:
18174 switch (rwh)
18175 {
18176 case FFEINFO_whereCONSTANT:
18177 where = FFEINFO_whereCONSTANT;
18178 break;
18179
18180 case FFEINFO_whereIMMEDIATE:
18181 where = FFEINFO_whereIMMEDIATE;
18182 break;
18183
18184 default:
18185 where = FFEINFO_whereFLEETING;
18186 break;
18187 }
18188 break;
18189
18190 case FFEINFO_whereIMMEDIATE:
18191 switch (rwh)
18192 {
18193 case FFEINFO_whereCONSTANT:
18194 case FFEINFO_whereIMMEDIATE:
18195 where = FFEINFO_whereIMMEDIATE;
18196 break;
18197
18198 default:
18199 where = FFEINFO_whereFLEETING;
18200 break;
18201 }
18202 break;
18203
18204 default:
18205 where = FFEINFO_whereFLEETING;
18206 break;
18207 }
18208
18209 if (first == NULL)
18210 first_kt = FFEINFO_kindtypeINTEGERDEFAULT;
18211 else
18212 first_kt = ffeinfo_kindtype (ffebld_info (first));
18213 if (last == NULL)
18214 last_kt = FFEINFO_kindtypeINTEGERDEFAULT;
18215 else
18216 last_kt = ffeinfo_kindtype (ffebld_info (last));
18217
18218 switch (where)
18219 {
18220 case FFEINFO_whereCONSTANT:
18221 switch (ffeinfo_where (info))
18222 {
18223 case FFEINFO_whereCONSTANT:
18224 break;
18225
18226 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
18227 where = FFEINFO_whereIMMEDIATE;
18228 break;
18229
18230 default:
18231 where = FFEINFO_whereFLEETING_CADDR;
18232 break;
18233 }
18234 break;
18235
18236 case FFEINFO_whereIMMEDIATE:
18237 switch (ffeinfo_where (info))
18238 {
18239 case FFEINFO_whereCONSTANT:
18240 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
18241 break;
18242
18243 default:
18244 where = FFEINFO_whereFLEETING_IADDR;
18245 break;
18246 }
18247 break;
18248
18249 default:
18250 switch (ffeinfo_where (info))
18251 {
18252 case FFEINFO_whereCONSTANT:
18253 where = FFEINFO_whereCONSTANT_SUBOBJECT; /* An F90 concept. */
18254 break;
18255
18256 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
18257 default:
18258 where = FFEINFO_whereFLEETING;
18259 break;
18260 }
18261 break;
18262 }
18263
18264 if (ffebld_op (strop) == FFEBLD_opANY)
18265 {
18266 reduced = ffebld_new_any ();
18267 ffebld_set_info (reduced, ffeinfo_new_any ());
18268 }
18269 else
18270 {
18271 reduced = ffebld_new_substr (strop, substrlist);
18272 ffebld_set_info (reduced, ffeinfo_new
18273 (FFEINFO_basictypeCHARACTER,
18274 ffeinfo_kindtype (info),
18275 0,
18276 FFEINFO_kindENTITY,
18277 where,
18278 size));
18279 reduced = ffeexpr_collapse_substr (reduced, ffeexpr_stack_->tokens[0]);
18280 }
18281
18282 ffeexpr_stack_->exprstack = string->previous; /* Pops not-quite-operand off
18283 stack. */
18284 string->u.operand = reduced; /* Save the line/column ffewhere info. */
18285 ffeexpr_exprstack_push_operand_ (string); /* Push it back on stack. */
18286
18287 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18288 {
18289 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18290 ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FOO(3:5)(1:1)".... */
18291 return (ffelexHandler) ffeexpr_token_substrp_;
18292 }
18293
18294 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
18295 {
18296 ffebad_here (0, ffelex_token_where_line (t),
18297 ffelex_token_where_column (t));
18298 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18299 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18300 ffebad_finish ();
18301 }
18302
18303 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18304 ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FOO(3:5)(1:1)".... */
18305 return
18306 (ffelexHandler) ffeexpr_find_close_paren_ (t,
18307 (ffelexHandler)
18308 ffeexpr_token_substrp_);
18309 }
18310
18311 /* ffeexpr_token_substrp_ -- Rhs <character entity>
18312
18313 Return a pointer to this function to the lexer (ffelex), which will
18314 invoke it for the next token.
18315
18316 If OPEN_PAREN, treat as start of a substring ("(3:4)") construct, and
18317 issue error message if flag (serves as argument) is set. Else, just
18318 forward token to binary_. */
18319
18320 static ffelexHandler
18321 ffeexpr_token_substrp_ (ffelexToken t)
18322 {
18323 ffeexprContext ctx;
18324
18325 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
18326 return (ffelexHandler) ffeexpr_token_binary_ (t);
18327
18328 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
18329
18330 switch (ffeexpr_stack_->context)
18331 {
18332 case FFEEXPR_contextSFUNCDEF:
18333 case FFEEXPR_contextSFUNCDEFINDEX_:
18334 ctx = FFEEXPR_contextSFUNCDEFINDEX_;
18335 break;
18336
18337 case FFEEXPR_contextSFUNCDEFACTUALARG_:
18338 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18339 assert ("bad context" == NULL);
18340 ctx = FFEEXPR_context;
18341 break;
18342
18343 default:
18344 ctx = FFEEXPR_contextINDEX_;
18345 break;
18346 }
18347
18348 if (!ffeexpr_is_substr_ok_)
18349 {
18350 if (ffebad_start (FFEBAD_BAD_SUBSTR))
18351 {
18352 ffebad_here (0, ffelex_token_where_line (t),
18353 ffelex_token_where_column (t));
18354 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
18355 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
18356 ffebad_finish ();
18357 }
18358
18359 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18360 ffeexpr_token_anything_);
18361 }
18362
18363 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18364 ffeexpr_token_substring_);
18365 }
18366
18367 static ffelexHandler
18368 ffeexpr_token_intrincheck_ (ffelexToken t)
18369 {
18370 if ((ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
18371 && ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
18372 {
18373 ffebad_string (ffeintrin_name_implementation
18374 (ffebld_symter_implementation
18375 (ffebld_left
18376 (ffeexpr_stack_->exprstack->u.operand))));
18377 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
18378 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
18379 ffebad_finish ();
18380 }
18381
18382 return (ffelexHandler) ffeexpr_token_substrp_ (t);
18383 }
18384
18385 /* ffeexpr_token_funsubstr_ -- NAME OPEN_PAREN expr
18386
18387 Return a pointer to this function to the lexer (ffelex), which will
18388 invoke it for the next token.
18389
18390 If COLON, do everything we would have done since _parenthesized_ if
18391 we had known NAME represented a kindENTITY instead of a kindFUNCTION.
18392 If not COLON, do likewise for kindFUNCTION instead. */
18393
18394 static ffelexHandler
18395 ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr, ffelexToken t)
18396 {
18397 ffeinfoWhere where;
18398 ffesymbol s;
18399 ffesymbolAttrs sa;
18400 ffebld symter = ffeexpr_stack_->exprstack->u.operand;
18401 bool needs_type;
18402 ffeintrinGen gen;
18403 ffeintrinSpec spec;
18404 ffeintrinImp imp;
18405
18406 s = ffebld_symter (symter);
18407 sa = ffesymbol_attrs (s);
18408 where = ffesymbol_where (s);
18409
18410 /* We get here only if we don't already know enough about FOO when seeing a
18411 FOO(stuff) reference, and FOO might turn out to be a CHARACTER type. If
18412 "stuff" is a substring reference, then FOO is a CHARACTER scalar type.
18413 Else FOO is a function, either intrinsic or external. If intrinsic, it
18414 wouldn't necessarily be CHARACTER type, so unless it has already been
18415 declared DUMMY, it hasn't had its type established yet. It can't be
18416 CHAR*(*) in any case, though it can have an explicit CHAR*n type. */
18417
18418 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
18419 | FFESYMBOL_attrsTYPE)));
18420
18421 needs_type = !(ffesymbol_attrs (s) & FFESYMBOL_attrsDUMMY);
18422
18423 ffesymbol_signal_change (s); /* Probably already done, but in case.... */
18424
18425 if (ffelex_token_type (t) == FFELEX_typeCOLON)
18426 { /* Definitely an ENTITY (char substring). */
18427 if (needs_type && !ffeimplic_establish_symbol (s))
18428 {
18429 ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
18430 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
18431 }
18432
18433 ffesymbol_set_info (s,
18434 ffeinfo_new (ffesymbol_basictype (s),
18435 ffesymbol_kindtype (s),
18436 ffesymbol_rank (s),
18437 FFEINFO_kindENTITY,
18438 (where == FFEINFO_whereNONE)
18439 ? FFEINFO_whereLOCAL
18440 : where,
18441 ffesymbol_size (s)));
18442 ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
18443
18444 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18445 ffesymbol_resolve_intrin (s);
18446 s = ffecom_sym_learned (s);
18447 ffesymbol_signal_unreported (s); /* For debugging purposes. */
18448
18449 ffeexpr_stack_->exprstack->u.operand
18450 = ffeexpr_collapse_symter (symter, ffeexpr_tokens_[0]);
18451
18452 return (ffelexHandler) ffeexpr_token_substring_ (ft, expr, t);
18453 }
18454
18455 /* The "stuff" isn't a substring notation, so we now know the overall
18456 reference is to a function. */
18457
18458 if (ffeintrin_is_intrinsic (ffesymbol_text (s), ffeexpr_stack_->tokens[0],
18459 FALSE, &gen, &spec, &imp))
18460 {
18461 ffebld_symter_set_generic (symter, gen);
18462 ffebld_symter_set_specific (symter, spec);
18463 ffebld_symter_set_implementation (symter, imp);
18464 ffesymbol_set_generic (s, gen);
18465 ffesymbol_set_specific (s, spec);
18466 ffesymbol_set_implementation (s, imp);
18467 ffesymbol_set_info (s,
18468 ffeinfo_new (ffesymbol_basictype (s),
18469 ffesymbol_kindtype (s),
18470 0,
18471 FFEINFO_kindFUNCTION,
18472 FFEINFO_whereINTRINSIC,
18473 ffesymbol_size (s)));
18474 }
18475 else
18476 { /* Not intrinsic, now needs CHAR type. */
18477 if (!ffeimplic_establish_symbol (s))
18478 {
18479 ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
18480 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
18481 }
18482
18483 ffesymbol_set_info (s,
18484 ffeinfo_new (ffesymbol_basictype (s),
18485 ffesymbol_kindtype (s),
18486 ffesymbol_rank (s),
18487 FFEINFO_kindFUNCTION,
18488 (where == FFEINFO_whereNONE)
18489 ? FFEINFO_whereGLOBAL
18490 : where,
18491 ffesymbol_size (s)));
18492 }
18493
18494 ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
18495
18496 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18497 ffesymbol_resolve_intrin (s);
18498 s = ffecom_sym_learned (s);
18499 ffesymbol_reference (s, ffeexpr_stack_->tokens[0], FALSE);
18500 ffesymbol_signal_unreported (s); /* For debugging purposes. */
18501 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
18502 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
18503 }
18504
18505 /* ffeexpr_token_anything_ -- NAME OPEN_PAREN any-expr
18506
18507 Handle basically any expression, looking for CLOSE_PAREN. */
18508
18509 static ffelexHandler
18510 ffeexpr_token_anything_ (ffelexToken ft UNUSED, ffebld expr UNUSED,
18511 ffelexToken t)
18512 {
18513 ffeexprExpr_ e = ffeexpr_stack_->exprstack;
18514
18515 switch (ffelex_token_type (t))
18516 {
18517 case FFELEX_typeCOMMA:
18518 case FFELEX_typeCOLON:
18519 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18520 FFEEXPR_contextACTUALARG_,
18521 ffeexpr_token_anything_);
18522
18523 default:
18524 e->u.operand = ffebld_new_any ();
18525 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
18526 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18527 ffeexpr_is_substr_ok_ = FALSE;
18528 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18529 return (ffelexHandler) ffeexpr_token_substrp_;
18530 return (ffelexHandler) ffeexpr_token_substrp_ (t);
18531 }
18532 }
18533
18534 /* Terminate module. */
18535
18536 void
18537 ffeexpr_terminate_2 (void)
18538 {
18539 assert (ffeexpr_stack_ == NULL);
18540 assert (ffeexpr_level_ == 0);
18541 }
Mirror of https://gcc.gnu.org/git/gcc.git