?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Fix incomplete stack traces by gdb.
[dragonfly.git] / contrib / gcc-3.4 / gcc / f / expr.c
blobef7661dc3ec3e95e60099e5b716b406fa3b17e3d
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 bool *);
314 static ffelexHandler ffeexpr_find_close_paren_ (ffelexToken t,
315 ffelexHandler after);
316 static ffelexHandler ffeexpr_nil_finished_ (ffelexToken t);
317 static ffelexHandler ffeexpr_nil_rhs_ (ffelexToken t);
318 static ffelexHandler ffeexpr_nil_period_ (ffelexToken t);
319 static ffelexHandler ffeexpr_nil_end_period_ (ffelexToken t);
320 static ffelexHandler ffeexpr_nil_swallow_period_ (ffelexToken t);
321 static ffelexHandler ffeexpr_nil_real_ (ffelexToken t);
322 static ffelexHandler ffeexpr_nil_real_exponent_ (ffelexToken t);
323 static ffelexHandler ffeexpr_nil_real_exp_sign_ (ffelexToken t);
324 static ffelexHandler ffeexpr_nil_number_ (ffelexToken t);
325 static ffelexHandler ffeexpr_nil_number_exponent_ (ffelexToken t);
326 static ffelexHandler ffeexpr_nil_number_exp_sign_ (ffelexToken t);
327 static ffelexHandler ffeexpr_nil_number_period_ (ffelexToken t);
328 static ffelexHandler ffeexpr_nil_number_per_exp_ (ffelexToken t);
329 static ffelexHandler ffeexpr_nil_number_real_ (ffelexToken t);
330 static ffelexHandler ffeexpr_nil_num_per_exp_sign_ (ffelexToken t);
331 static ffelexHandler ffeexpr_nil_number_real_exp_ (ffelexToken t);
332 static ffelexHandler ffeexpr_nil_num_real_exp_sn_ (ffelexToken t);
333 static ffelexHandler ffeexpr_nil_binary_ (ffelexToken t);
334 static ffelexHandler ffeexpr_nil_binary_period_ (ffelexToken t);
335 static ffelexHandler ffeexpr_nil_binary_end_per_ (ffelexToken t);
336 static ffelexHandler ffeexpr_nil_binary_sw_per_ (ffelexToken t);
337 static ffelexHandler ffeexpr_nil_quote_ (ffelexToken t);
338 static ffelexHandler ffeexpr_nil_apostrophe_ (ffelexToken t);
339 static ffelexHandler ffeexpr_nil_apos_char_ (ffelexToken t);
340 static ffelexHandler ffeexpr_nil_name_rhs_ (ffelexToken t);
341 static ffelexHandler ffeexpr_nil_name_apos_ (ffelexToken t);
342 static ffelexHandler ffeexpr_nil_name_apos_name_ (ffelexToken t);
343 static ffelexHandler ffeexpr_nil_percent_ (ffelexToken t);
344 static ffelexHandler ffeexpr_nil_percent_name_ (ffelexToken t);
345 static ffelexHandler ffeexpr_nil_substrp_ (ffelexToken t);
346 static ffelexHandler ffeexpr_finished_ (ffelexToken t);
347 static ffebld ffeexpr_finished_ambig_ (ffelexToken t, ffebld expr);
348 static ffelexHandler ffeexpr_token_lhs_ (ffelexToken t);
349 static ffelexHandler ffeexpr_token_rhs_ (ffelexToken t);
350 static ffelexHandler ffeexpr_token_binary_ (ffelexToken t);
351 static ffelexHandler ffeexpr_token_period_ (ffelexToken t);
352 static ffelexHandler ffeexpr_token_end_period_ (ffelexToken t);
353 static ffelexHandler ffeexpr_token_swallow_period_ (ffelexToken t);
354 static ffelexHandler ffeexpr_token_real_ (ffelexToken t);
355 static ffelexHandler ffeexpr_token_real_exponent_ (ffelexToken t);
356 static ffelexHandler ffeexpr_token_real_exp_sign_ (ffelexToken t);
357 static ffelexHandler ffeexpr_token_number_ (ffelexToken t);
358 static ffelexHandler ffeexpr_token_number_exponent_ (ffelexToken t);
359 static ffelexHandler ffeexpr_token_number_exp_sign_ (ffelexToken t);
360 static ffelexHandler ffeexpr_token_number_period_ (ffelexToken t);
361 static ffelexHandler ffeexpr_token_number_per_exp_ (ffelexToken t);
362 static ffelexHandler ffeexpr_token_number_real_ (ffelexToken t);
363 static ffelexHandler ffeexpr_token_num_per_exp_sign_ (ffelexToken t);
364 static ffelexHandler ffeexpr_token_number_real_exp_ (ffelexToken t);
365 static ffelexHandler ffeexpr_token_num_real_exp_sn_ (ffelexToken t);
366 static ffelexHandler ffeexpr_token_binary_period_ (ffelexToken t);
367 static ffelexHandler ffeexpr_token_binary_end_per_ (ffelexToken t);
368 static ffelexHandler ffeexpr_token_binary_sw_per_ (ffelexToken t);
369 static ffelexHandler ffeexpr_token_quote_ (ffelexToken t);
370 static ffelexHandler ffeexpr_token_apostrophe_ (ffelexToken t);
371 static ffelexHandler ffeexpr_token_apos_char_ (ffelexToken t);
372 static ffelexHandler ffeexpr_token_name_lhs_ (ffelexToken t);
373 static ffelexHandler ffeexpr_token_name_arg_ (ffelexToken t);
374 static ffelexHandler ffeexpr_token_name_rhs_ (ffelexToken t);
375 static ffelexHandler ffeexpr_token_name_apos_ (ffelexToken t);
376 static ffelexHandler ffeexpr_token_name_apos_name_ (ffelexToken t);
377 static ffelexHandler ffeexpr_token_percent_ (ffelexToken t);
378 static ffelexHandler ffeexpr_token_percent_name_ (ffelexToken t);
379 static ffelexHandler ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr,
380 ffelexToken t);
381 static ffelexHandler ffeexpr_token_elements_ (ffelexToken ft, ffebld expr,
382 ffelexToken t);
383 static ffelexHandler ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr,
384 ffelexToken t);
385 static ffelexHandler ffeexpr_token_substring_ (ffelexToken ft, ffebld expr,
386 ffelexToken t);
387 static ffelexHandler ffeexpr_token_substring_1_ (ffelexToken ft, ffebld expr,
388 ffelexToken t);
389 static ffelexHandler ffeexpr_token_substrp_ (ffelexToken t);
390 static ffelexHandler ffeexpr_token_intrincheck_ (ffelexToken t);
391 static ffelexHandler ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr,
392 ffelexToken t);
393 static ffelexHandler ffeexpr_token_anything_ (ffelexToken ft, ffebld expr,
394 ffelexToken t);
395 static void ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
396 ffelexToken decimal, ffelexToken fraction, ffelexToken exponent,
397 ffelexToken exponent_sign, ffelexToken exponent_digits);
398 static ffesymbol ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin);
399 static ffesymbol ffeexpr_sym_impdoitem_ (ffesymbol s, ffelexToken t);
400 static ffesymbol ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t);
401 static ffesymbol ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t);
402 static ffesymbol ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t);
403 static ffesymbol ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t);
404 static ffesymbol ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t);
405 static ffesymbol ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t);
406 static ffesymbol ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t);
407 static ffesymbol ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t);
408 static ffesymbol ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t);
409 static ffesymbol ffeexpr_declare_parenthesized_ (ffelexToken t,
410 bool maybe_intrin,
411 ffeexprParenType_ *paren_type);
412 static ffesymbol ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t);
413
414 /* Internal macros. */
415
416 #define ffeexpr_paren_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
417 #define ffeexpr_sym_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
418 \f
419 /* ffeexpr_collapse_convert -- Collapse convert expr
420
421 ffebld expr;
422 ffelexToken token;
423 expr = ffeexpr_collapse_convert(expr,token);
424
425 If the result of the expr is a constant, replaces the expr with the
426 computed constant. */
427
428 ffebld
429 ffeexpr_collapse_convert (ffebld expr, ffelexToken t)
430 {
431 ffebad error = FFEBAD;
432 ffebld l;
433 ffebldConstantUnion u;
434 ffeinfoBasictype bt;
435 ffeinfoKindtype kt;
436 ffetargetCharacterSize sz;
437 ffetargetCharacterSize sz2;
438
439 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
440 return expr;
441
442 l = ffebld_left (expr);
443
444 if (ffebld_op (l) != FFEBLD_opCONTER)
445 return expr;
446
447 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
448 {
449 case FFEINFO_basictypeANY:
450 return expr;
451
452 case FFEINFO_basictypeINTEGER:
453 sz = FFETARGET_charactersizeNONE;
454 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
455 {
456 #if FFETARGET_okINTEGER1
457 case FFEINFO_kindtypeINTEGER1:
458 switch (ffeinfo_basictype (ffebld_info (l)))
459 {
460 case FFEINFO_basictypeINTEGER:
461 switch (ffeinfo_kindtype (ffebld_info (l)))
462 {
463 #if FFETARGET_okINTEGER2
464 case FFEINFO_kindtypeINTEGER2:
465 error = ffetarget_convert_integer1_integer2
466 (ffebld_cu_ptr_integer1 (u),
467 ffebld_constant_integer2 (ffebld_conter (l)));
468 break;
469 #endif
470
471 #if FFETARGET_okINTEGER3
472 case FFEINFO_kindtypeINTEGER3:
473 error = ffetarget_convert_integer1_integer3
474 (ffebld_cu_ptr_integer1 (u),
475 ffebld_constant_integer3 (ffebld_conter (l)));
476 break;
477 #endif
478
479 #if FFETARGET_okINTEGER4
480 case FFEINFO_kindtypeINTEGER4:
481 error = ffetarget_convert_integer1_integer4
482 (ffebld_cu_ptr_integer1 (u),
483 ffebld_constant_integer4 (ffebld_conter (l)));
484 break;
485 #endif
486
487 default:
488 assert ("INTEGER1/INTEGER bad source kind type" == NULL);
489 break;
490 }
491 break;
492
493 case FFEINFO_basictypeREAL:
494 switch (ffeinfo_kindtype (ffebld_info (l)))
495 {
496 #if FFETARGET_okREAL1
497 case FFEINFO_kindtypeREAL1:
498 error = ffetarget_convert_integer1_real1
499 (ffebld_cu_ptr_integer1 (u),
500 ffebld_constant_real1 (ffebld_conter (l)));
501 break;
502 #endif
503
504 #if FFETARGET_okREAL2
505 case FFEINFO_kindtypeREAL2:
506 error = ffetarget_convert_integer1_real2
507 (ffebld_cu_ptr_integer1 (u),
508 ffebld_constant_real2 (ffebld_conter (l)));
509 break;
510 #endif
511
512 #if FFETARGET_okREAL3
513 case FFEINFO_kindtypeREAL3:
514 error = ffetarget_convert_integer1_real3
515 (ffebld_cu_ptr_integer1 (u),
516 ffebld_constant_real3 (ffebld_conter (l)));
517 break;
518 #endif
519
520 default:
521 assert ("INTEGER1/REAL bad source kind type" == NULL);
522 break;
523 }
524 break;
525
526 case FFEINFO_basictypeCOMPLEX:
527 switch (ffeinfo_kindtype (ffebld_info (l)))
528 {
529 #if FFETARGET_okCOMPLEX1
530 case FFEINFO_kindtypeREAL1:
531 error = ffetarget_convert_integer1_complex1
532 (ffebld_cu_ptr_integer1 (u),
533 ffebld_constant_complex1 (ffebld_conter (l)));
534 break;
535 #endif
536
537 #if FFETARGET_okCOMPLEX2
538 case FFEINFO_kindtypeREAL2:
539 error = ffetarget_convert_integer1_complex2
540 (ffebld_cu_ptr_integer1 (u),
541 ffebld_constant_complex2 (ffebld_conter (l)));
542 break;
543 #endif
544
545 #if FFETARGET_okCOMPLEX3
546 case FFEINFO_kindtypeREAL3:
547 error = ffetarget_convert_integer1_complex3
548 (ffebld_cu_ptr_integer1 (u),
549 ffebld_constant_complex3 (ffebld_conter (l)));
550 break;
551 #endif
552
553 default:
554 assert ("INTEGER1/COMPLEX bad source kind type" == NULL);
555 break;
556 }
557 break;
558
559 case FFEINFO_basictypeLOGICAL:
560 switch (ffeinfo_kindtype (ffebld_info (l)))
561 {
562 #if FFETARGET_okLOGICAL1
563 case FFEINFO_kindtypeLOGICAL1:
564 error = ffetarget_convert_integer1_logical1
565 (ffebld_cu_ptr_integer1 (u),
566 ffebld_constant_logical1 (ffebld_conter (l)));
567 break;
568 #endif
569
570 #if FFETARGET_okLOGICAL2
571 case FFEINFO_kindtypeLOGICAL2:
572 error = ffetarget_convert_integer1_logical2
573 (ffebld_cu_ptr_integer1 (u),
574 ffebld_constant_logical2 (ffebld_conter (l)));
575 break;
576 #endif
577
578 #if FFETARGET_okLOGICAL3
579 case FFEINFO_kindtypeLOGICAL3:
580 error = ffetarget_convert_integer1_logical3
581 (ffebld_cu_ptr_integer1 (u),
582 ffebld_constant_logical3 (ffebld_conter (l)));
583 break;
584 #endif
585
586 #if FFETARGET_okLOGICAL4
587 case FFEINFO_kindtypeLOGICAL4:
588 error = ffetarget_convert_integer1_logical4
589 (ffebld_cu_ptr_integer1 (u),
590 ffebld_constant_logical4 (ffebld_conter (l)));
591 break;
592 #endif
593
594 default:
595 assert ("INTEGER1/LOGICAL bad source kind type" == NULL);
596 break;
597 }
598 break;
599
600 case FFEINFO_basictypeCHARACTER:
601 error = ffetarget_convert_integer1_character1
602 (ffebld_cu_ptr_integer1 (u),
603 ffebld_constant_character1 (ffebld_conter (l)));
604 break;
605
606 case FFEINFO_basictypeHOLLERITH:
607 error = ffetarget_convert_integer1_hollerith
608 (ffebld_cu_ptr_integer1 (u),
609 ffebld_constant_hollerith (ffebld_conter (l)));
610 break;
611
612 case FFEINFO_basictypeTYPELESS:
613 error = ffetarget_convert_integer1_typeless
614 (ffebld_cu_ptr_integer1 (u),
615 ffebld_constant_typeless (ffebld_conter (l)));
616 break;
617
618 default:
619 assert ("INTEGER1 bad type" == NULL);
620 break;
621 }
622
623 /* If conversion operation is not implemented, return original expr. */
624 if (error == FFEBAD_NOCANDO)
625 return expr;
626
627 expr = ffebld_new_conter_with_orig
628 (ffebld_constant_new_integer1_val
629 (ffebld_cu_val_integer1 (u)), expr);
630 break;
631 #endif
632
633 #if FFETARGET_okINTEGER2
634 case FFEINFO_kindtypeINTEGER2:
635 switch (ffeinfo_basictype (ffebld_info (l)))
636 {
637 case FFEINFO_basictypeINTEGER:
638 switch (ffeinfo_kindtype (ffebld_info (l)))
639 {
640 #if FFETARGET_okINTEGER1
641 case FFEINFO_kindtypeINTEGER1:
642 error = ffetarget_convert_integer2_integer1
643 (ffebld_cu_ptr_integer2 (u),
644 ffebld_constant_integer1 (ffebld_conter (l)));
645 break;
646 #endif
647
648 #if FFETARGET_okINTEGER3
649 case FFEINFO_kindtypeINTEGER3:
650 error = ffetarget_convert_integer2_integer3
651 (ffebld_cu_ptr_integer2 (u),
652 ffebld_constant_integer3 (ffebld_conter (l)));
653 break;
654 #endif
655
656 #if FFETARGET_okINTEGER4
657 case FFEINFO_kindtypeINTEGER4:
658 error = ffetarget_convert_integer2_integer4
659 (ffebld_cu_ptr_integer2 (u),
660 ffebld_constant_integer4 (ffebld_conter (l)));
661 break;
662 #endif
663
664 default:
665 assert ("INTEGER2/INTEGER bad source kind type" == NULL);
666 break;
667 }
668 break;
669
670 case FFEINFO_basictypeREAL:
671 switch (ffeinfo_kindtype (ffebld_info (l)))
672 {
673 #if FFETARGET_okREAL1
674 case FFEINFO_kindtypeREAL1:
675 error = ffetarget_convert_integer2_real1
676 (ffebld_cu_ptr_integer2 (u),
677 ffebld_constant_real1 (ffebld_conter (l)));
678 break;
679 #endif
680
681 #if FFETARGET_okREAL2
682 case FFEINFO_kindtypeREAL2:
683 error = ffetarget_convert_integer2_real2
684 (ffebld_cu_ptr_integer2 (u),
685 ffebld_constant_real2 (ffebld_conter (l)));
686 break;
687 #endif
688
689 #if FFETARGET_okREAL3
690 case FFEINFO_kindtypeREAL3:
691 error = ffetarget_convert_integer2_real3
692 (ffebld_cu_ptr_integer2 (u),
693 ffebld_constant_real3 (ffebld_conter (l)));
694 break;
695 #endif
696
697 default:
698 assert ("INTEGER2/REAL bad source kind type" == NULL);
699 break;
700 }
701 break;
702
703 case FFEINFO_basictypeCOMPLEX:
704 switch (ffeinfo_kindtype (ffebld_info (l)))
705 {
706 #if FFETARGET_okCOMPLEX1
707 case FFEINFO_kindtypeREAL1:
708 error = ffetarget_convert_integer2_complex1
709 (ffebld_cu_ptr_integer2 (u),
710 ffebld_constant_complex1 (ffebld_conter (l)));
711 break;
712 #endif
713
714 #if FFETARGET_okCOMPLEX2
715 case FFEINFO_kindtypeREAL2:
716 error = ffetarget_convert_integer2_complex2
717 (ffebld_cu_ptr_integer2 (u),
718 ffebld_constant_complex2 (ffebld_conter (l)));
719 break;
720 #endif
721
722 #if FFETARGET_okCOMPLEX3
723 case FFEINFO_kindtypeREAL3:
724 error = ffetarget_convert_integer2_complex3
725 (ffebld_cu_ptr_integer2 (u),
726 ffebld_constant_complex3 (ffebld_conter (l)));
727 break;
728 #endif
729
730 default:
731 assert ("INTEGER2/COMPLEX bad source kind type" == NULL);
732 break;
733 }
734 break;
735
736 case FFEINFO_basictypeLOGICAL:
737 switch (ffeinfo_kindtype (ffebld_info (l)))
738 {
739 #if FFETARGET_okLOGICAL1
740 case FFEINFO_kindtypeLOGICAL1:
741 error = ffetarget_convert_integer2_logical1
742 (ffebld_cu_ptr_integer2 (u),
743 ffebld_constant_logical1 (ffebld_conter (l)));
744 break;
745 #endif
746
747 #if FFETARGET_okLOGICAL2
748 case FFEINFO_kindtypeLOGICAL2:
749 error = ffetarget_convert_integer2_logical2
750 (ffebld_cu_ptr_integer2 (u),
751 ffebld_constant_logical2 (ffebld_conter (l)));
752 break;
753 #endif
754
755 #if FFETARGET_okLOGICAL3
756 case FFEINFO_kindtypeLOGICAL3:
757 error = ffetarget_convert_integer2_logical3
758 (ffebld_cu_ptr_integer2 (u),
759 ffebld_constant_logical3 (ffebld_conter (l)));
760 break;
761 #endif
762
763 #if FFETARGET_okLOGICAL4
764 case FFEINFO_kindtypeLOGICAL4:
765 error = ffetarget_convert_integer2_logical4
766 (ffebld_cu_ptr_integer2 (u),
767 ffebld_constant_logical4 (ffebld_conter (l)));
768 break;
769 #endif
770
771 default:
772 assert ("INTEGER2/LOGICAL bad source kind type" == NULL);
773 break;
774 }
775 break;
776
777 case FFEINFO_basictypeCHARACTER:
778 error = ffetarget_convert_integer2_character1
779 (ffebld_cu_ptr_integer2 (u),
780 ffebld_constant_character1 (ffebld_conter (l)));
781 break;
782
783 case FFEINFO_basictypeHOLLERITH:
784 error = ffetarget_convert_integer2_hollerith
785 (ffebld_cu_ptr_integer2 (u),
786 ffebld_constant_hollerith (ffebld_conter (l)));
787 break;
788
789 case FFEINFO_basictypeTYPELESS:
790 error = ffetarget_convert_integer2_typeless
791 (ffebld_cu_ptr_integer2 (u),
792 ffebld_constant_typeless (ffebld_conter (l)));
793 break;
794
795 default:
796 assert ("INTEGER2 bad type" == NULL);
797 break;
798 }
799
800 /* If conversion operation is not implemented, return original expr. */
801 if (error == FFEBAD_NOCANDO)
802 return expr;
803
804 expr = ffebld_new_conter_with_orig
805 (ffebld_constant_new_integer2_val
806 (ffebld_cu_val_integer2 (u)), expr);
807 break;
808 #endif
809
810 #if FFETARGET_okINTEGER3
811 case FFEINFO_kindtypeINTEGER3:
812 switch (ffeinfo_basictype (ffebld_info (l)))
813 {
814 case FFEINFO_basictypeINTEGER:
815 switch (ffeinfo_kindtype (ffebld_info (l)))
816 {
817 #if FFETARGET_okINTEGER1
818 case FFEINFO_kindtypeINTEGER1:
819 error = ffetarget_convert_integer3_integer1
820 (ffebld_cu_ptr_integer3 (u),
821 ffebld_constant_integer1 (ffebld_conter (l)));
822 break;
823 #endif
824
825 #if FFETARGET_okINTEGER2
826 case FFEINFO_kindtypeINTEGER2:
827 error = ffetarget_convert_integer3_integer2
828 (ffebld_cu_ptr_integer3 (u),
829 ffebld_constant_integer2 (ffebld_conter (l)));
830 break;
831 #endif
832
833 #if FFETARGET_okINTEGER4
834 case FFEINFO_kindtypeINTEGER4:
835 error = ffetarget_convert_integer3_integer4
836 (ffebld_cu_ptr_integer3 (u),
837 ffebld_constant_integer4 (ffebld_conter (l)));
838 break;
839 #endif
840
841 default:
842 assert ("INTEGER3/INTEGER bad source kind type" == NULL);
843 break;
844 }
845 break;
846
847 case FFEINFO_basictypeREAL:
848 switch (ffeinfo_kindtype (ffebld_info (l)))
849 {
850 #if FFETARGET_okREAL1
851 case FFEINFO_kindtypeREAL1:
852 error = ffetarget_convert_integer3_real1
853 (ffebld_cu_ptr_integer3 (u),
854 ffebld_constant_real1 (ffebld_conter (l)));
855 break;
856 #endif
857
858 #if FFETARGET_okREAL2
859 case FFEINFO_kindtypeREAL2:
860 error = ffetarget_convert_integer3_real2
861 (ffebld_cu_ptr_integer3 (u),
862 ffebld_constant_real2 (ffebld_conter (l)));
863 break;
864 #endif
865
866 #if FFETARGET_okREAL3
867 case FFEINFO_kindtypeREAL3:
868 error = ffetarget_convert_integer3_real3
869 (ffebld_cu_ptr_integer3 (u),
870 ffebld_constant_real3 (ffebld_conter (l)));
871 break;
872 #endif
873
874 default:
875 assert ("INTEGER3/REAL bad source kind type" == NULL);
876 break;
877 }
878 break;
879
880 case FFEINFO_basictypeCOMPLEX:
881 switch (ffeinfo_kindtype (ffebld_info (l)))
882 {
883 #if FFETARGET_okCOMPLEX1
884 case FFEINFO_kindtypeREAL1:
885 error = ffetarget_convert_integer3_complex1
886 (ffebld_cu_ptr_integer3 (u),
887 ffebld_constant_complex1 (ffebld_conter (l)));
888 break;
889 #endif
890
891 #if FFETARGET_okCOMPLEX2
892 case FFEINFO_kindtypeREAL2:
893 error = ffetarget_convert_integer3_complex2
894 (ffebld_cu_ptr_integer3 (u),
895 ffebld_constant_complex2 (ffebld_conter (l)));
896 break;
897 #endif
898
899 #if FFETARGET_okCOMPLEX3
900 case FFEINFO_kindtypeREAL3:
901 error = ffetarget_convert_integer3_complex3
902 (ffebld_cu_ptr_integer3 (u),
903 ffebld_constant_complex3 (ffebld_conter (l)));
904 break;
905 #endif
906
907 default:
908 assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
909 break;
910 }
911 break;
912
913 case FFEINFO_basictypeLOGICAL:
914 switch (ffeinfo_kindtype (ffebld_info (l)))
915 {
916 #if FFETARGET_okLOGICAL1
917 case FFEINFO_kindtypeLOGICAL1:
918 error = ffetarget_convert_integer3_logical1
919 (ffebld_cu_ptr_integer3 (u),
920 ffebld_constant_logical1 (ffebld_conter (l)));
921 break;
922 #endif
923
924 #if FFETARGET_okLOGICAL2
925 case FFEINFO_kindtypeLOGICAL2:
926 error = ffetarget_convert_integer3_logical2
927 (ffebld_cu_ptr_integer3 (u),
928 ffebld_constant_logical2 (ffebld_conter (l)));
929 break;
930 #endif
931
932 #if FFETARGET_okLOGICAL3
933 case FFEINFO_kindtypeLOGICAL3:
934 error = ffetarget_convert_integer3_logical3
935 (ffebld_cu_ptr_integer3 (u),
936 ffebld_constant_logical3 (ffebld_conter (l)));
937 break;
938 #endif
939
940 #if FFETARGET_okLOGICAL4
941 case FFEINFO_kindtypeLOGICAL4:
942 error = ffetarget_convert_integer3_logical4
943 (ffebld_cu_ptr_integer3 (u),
944 ffebld_constant_logical4 (ffebld_conter (l)));
945 break;
946 #endif
947
948 default:
949 assert ("INTEGER3/LOGICAL bad source kind type" == NULL);
950 break;
951 }
952 break;
953
954 case FFEINFO_basictypeCHARACTER:
955 error = ffetarget_convert_integer3_character1
956 (ffebld_cu_ptr_integer3 (u),
957 ffebld_constant_character1 (ffebld_conter (l)));
958 break;
959
960 case FFEINFO_basictypeHOLLERITH:
961 error = ffetarget_convert_integer3_hollerith
962 (ffebld_cu_ptr_integer3 (u),
963 ffebld_constant_hollerith (ffebld_conter (l)));
964 break;
965
966 case FFEINFO_basictypeTYPELESS:
967 error = ffetarget_convert_integer3_typeless
968 (ffebld_cu_ptr_integer3 (u),
969 ffebld_constant_typeless (ffebld_conter (l)));
970 break;
971
972 default:
973 assert ("INTEGER3 bad type" == NULL);
974 break;
975 }
976
977 /* If conversion operation is not implemented, return original expr. */
978 if (error == FFEBAD_NOCANDO)
979 return expr;
980
981 expr = ffebld_new_conter_with_orig
982 (ffebld_constant_new_integer3_val
983 (ffebld_cu_val_integer3 (u)), expr);
984 break;
985 #endif
986
987 #if FFETARGET_okINTEGER4
988 case FFEINFO_kindtypeINTEGER4:
989 switch (ffeinfo_basictype (ffebld_info (l)))
990 {
991 case FFEINFO_basictypeINTEGER:
992 switch (ffeinfo_kindtype (ffebld_info (l)))
993 {
994 #if FFETARGET_okINTEGER1
995 case FFEINFO_kindtypeINTEGER1:
996 error = ffetarget_convert_integer4_integer1
997 (ffebld_cu_ptr_integer4 (u),
998 ffebld_constant_integer1 (ffebld_conter (l)));
999 break;
1000 #endif
1001
1002 #if FFETARGET_okINTEGER2
1003 case FFEINFO_kindtypeINTEGER2:
1004 error = ffetarget_convert_integer4_integer2
1005 (ffebld_cu_ptr_integer4 (u),
1006 ffebld_constant_integer2 (ffebld_conter (l)));
1007 break;
1008 #endif
1009
1010 #if FFETARGET_okINTEGER3
1011 case FFEINFO_kindtypeINTEGER3:
1012 error = ffetarget_convert_integer4_integer3
1013 (ffebld_cu_ptr_integer4 (u),
1014 ffebld_constant_integer3 (ffebld_conter (l)));
1015 break;
1016 #endif
1017
1018 default:
1019 assert ("INTEGER4/INTEGER bad source kind type" == NULL);
1020 break;
1021 }
1022 break;
1023
1024 case FFEINFO_basictypeREAL:
1025 switch (ffeinfo_kindtype (ffebld_info (l)))
1026 {
1027 #if FFETARGET_okREAL1
1028 case FFEINFO_kindtypeREAL1:
1029 error = ffetarget_convert_integer4_real1
1030 (ffebld_cu_ptr_integer4 (u),
1031 ffebld_constant_real1 (ffebld_conter (l)));
1032 break;
1033 #endif
1034
1035 #if FFETARGET_okREAL2
1036 case FFEINFO_kindtypeREAL2:
1037 error = ffetarget_convert_integer4_real2
1038 (ffebld_cu_ptr_integer4 (u),
1039 ffebld_constant_real2 (ffebld_conter (l)));
1040 break;
1041 #endif
1042
1043 #if FFETARGET_okREAL3
1044 case FFEINFO_kindtypeREAL3:
1045 error = ffetarget_convert_integer4_real3
1046 (ffebld_cu_ptr_integer4 (u),
1047 ffebld_constant_real3 (ffebld_conter (l)));
1048 break;
1049 #endif
1050
1051 default:
1052 assert ("INTEGER4/REAL bad source kind type" == NULL);
1053 break;
1054 }
1055 break;
1056
1057 case FFEINFO_basictypeCOMPLEX:
1058 switch (ffeinfo_kindtype (ffebld_info (l)))
1059 {
1060 #if FFETARGET_okCOMPLEX1
1061 case FFEINFO_kindtypeREAL1:
1062 error = ffetarget_convert_integer4_complex1
1063 (ffebld_cu_ptr_integer4 (u),
1064 ffebld_constant_complex1 (ffebld_conter (l)));
1065 break;
1066 #endif
1067
1068 #if FFETARGET_okCOMPLEX2
1069 case FFEINFO_kindtypeREAL2:
1070 error = ffetarget_convert_integer4_complex2
1071 (ffebld_cu_ptr_integer4 (u),
1072 ffebld_constant_complex2 (ffebld_conter (l)));
1073 break;
1074 #endif
1075
1076 #if FFETARGET_okCOMPLEX3
1077 case FFEINFO_kindtypeREAL3:
1078 error = ffetarget_convert_integer4_complex3
1079 (ffebld_cu_ptr_integer4 (u),
1080 ffebld_constant_complex3 (ffebld_conter (l)));
1081 break;
1082 #endif
1083
1084 default:
1085 assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
1086 break;
1087 }
1088 break;
1089
1090 case FFEINFO_basictypeLOGICAL:
1091 switch (ffeinfo_kindtype (ffebld_info (l)))
1092 {
1093 #if FFETARGET_okLOGICAL1
1094 case FFEINFO_kindtypeLOGICAL1:
1095 error = ffetarget_convert_integer4_logical1
1096 (ffebld_cu_ptr_integer4 (u),
1097 ffebld_constant_logical1 (ffebld_conter (l)));
1098 break;
1099 #endif
1100
1101 #if FFETARGET_okLOGICAL2
1102 case FFEINFO_kindtypeLOGICAL2:
1103 error = ffetarget_convert_integer4_logical2
1104 (ffebld_cu_ptr_integer4 (u),
1105 ffebld_constant_logical2 (ffebld_conter (l)));
1106 break;
1107 #endif
1108
1109 #if FFETARGET_okLOGICAL3
1110 case FFEINFO_kindtypeLOGICAL3:
1111 error = ffetarget_convert_integer4_logical3
1112 (ffebld_cu_ptr_integer4 (u),
1113 ffebld_constant_logical3 (ffebld_conter (l)));
1114 break;
1115 #endif
1116
1117 #if FFETARGET_okLOGICAL4
1118 case FFEINFO_kindtypeLOGICAL4:
1119 error = ffetarget_convert_integer4_logical4
1120 (ffebld_cu_ptr_integer4 (u),
1121 ffebld_constant_logical4 (ffebld_conter (l)));
1122 break;
1123 #endif
1124
1125 default:
1126 assert ("INTEGER4/LOGICAL bad source kind type" == NULL);
1127 break;
1128 }
1129 break;
1130
1131 case FFEINFO_basictypeCHARACTER:
1132 error = ffetarget_convert_integer4_character1
1133 (ffebld_cu_ptr_integer4 (u),
1134 ffebld_constant_character1 (ffebld_conter (l)));
1135 break;
1136
1137 case FFEINFO_basictypeHOLLERITH:
1138 error = ffetarget_convert_integer4_hollerith
1139 (ffebld_cu_ptr_integer4 (u),
1140 ffebld_constant_hollerith (ffebld_conter (l)));
1141 break;
1142
1143 case FFEINFO_basictypeTYPELESS:
1144 error = ffetarget_convert_integer4_typeless
1145 (ffebld_cu_ptr_integer4 (u),
1146 ffebld_constant_typeless (ffebld_conter (l)));
1147 break;
1148
1149 default:
1150 assert ("INTEGER4 bad type" == NULL);
1151 break;
1152 }
1153
1154 /* If conversion operation is not implemented, return original expr. */
1155 if (error == FFEBAD_NOCANDO)
1156 return expr;
1157
1158 expr = ffebld_new_conter_with_orig
1159 (ffebld_constant_new_integer4_val
1160 (ffebld_cu_val_integer4 (u)), expr);
1161 break;
1162 #endif
1163
1164 default:
1165 assert ("bad integer kind type" == NULL);
1166 break;
1167 }
1168 break;
1169
1170 case FFEINFO_basictypeLOGICAL:
1171 sz = FFETARGET_charactersizeNONE;
1172 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1173 {
1174 #if FFETARGET_okLOGICAL1
1175 case FFEINFO_kindtypeLOGICAL1:
1176 switch (ffeinfo_basictype (ffebld_info (l)))
1177 {
1178 case FFEINFO_basictypeLOGICAL:
1179 switch (ffeinfo_kindtype (ffebld_info (l)))
1180 {
1181 #if FFETARGET_okLOGICAL2
1182 case FFEINFO_kindtypeLOGICAL2:
1183 error = ffetarget_convert_logical1_logical2
1184 (ffebld_cu_ptr_logical1 (u),
1185 ffebld_constant_logical2 (ffebld_conter (l)));
1186 break;
1187 #endif
1188
1189 #if FFETARGET_okLOGICAL3
1190 case FFEINFO_kindtypeLOGICAL3:
1191 error = ffetarget_convert_logical1_logical3
1192 (ffebld_cu_ptr_logical1 (u),
1193 ffebld_constant_logical3 (ffebld_conter (l)));
1194 break;
1195 #endif
1196
1197 #if FFETARGET_okLOGICAL4
1198 case FFEINFO_kindtypeLOGICAL4:
1199 error = ffetarget_convert_logical1_logical4
1200 (ffebld_cu_ptr_logical1 (u),
1201 ffebld_constant_logical4 (ffebld_conter (l)));
1202 break;
1203 #endif
1204
1205 default:
1206 assert ("LOGICAL1/LOGICAL bad source kind type" == NULL);
1207 break;
1208 }
1209 break;
1210
1211 case FFEINFO_basictypeINTEGER:
1212 switch (ffeinfo_kindtype (ffebld_info (l)))
1213 {
1214 #if FFETARGET_okINTEGER1
1215 case FFEINFO_kindtypeINTEGER1:
1216 error = ffetarget_convert_logical1_integer1
1217 (ffebld_cu_ptr_logical1 (u),
1218 ffebld_constant_integer1 (ffebld_conter (l)));
1219 break;
1220 #endif
1221
1222 #if FFETARGET_okINTEGER2
1223 case FFEINFO_kindtypeINTEGER2:
1224 error = ffetarget_convert_logical1_integer2
1225 (ffebld_cu_ptr_logical1 (u),
1226 ffebld_constant_integer2 (ffebld_conter (l)));
1227 break;
1228 #endif
1229
1230 #if FFETARGET_okINTEGER3
1231 case FFEINFO_kindtypeINTEGER3:
1232 error = ffetarget_convert_logical1_integer3
1233 (ffebld_cu_ptr_logical1 (u),
1234 ffebld_constant_integer3 (ffebld_conter (l)));
1235 break;
1236 #endif
1237
1238 #if FFETARGET_okINTEGER4
1239 case FFEINFO_kindtypeINTEGER4:
1240 error = ffetarget_convert_logical1_integer4
1241 (ffebld_cu_ptr_logical1 (u),
1242 ffebld_constant_integer4 (ffebld_conter (l)));
1243 break;
1244 #endif
1245
1246 default:
1247 assert ("LOGICAL1/INTEGER bad source kind type" == NULL);
1248 break;
1249 }
1250 break;
1251
1252 case FFEINFO_basictypeCHARACTER:
1253 error = ffetarget_convert_logical1_character1
1254 (ffebld_cu_ptr_logical1 (u),
1255 ffebld_constant_character1 (ffebld_conter (l)));
1256 break;
1257
1258 case FFEINFO_basictypeHOLLERITH:
1259 error = ffetarget_convert_logical1_hollerith
1260 (ffebld_cu_ptr_logical1 (u),
1261 ffebld_constant_hollerith (ffebld_conter (l)));
1262 break;
1263
1264 case FFEINFO_basictypeTYPELESS:
1265 error = ffetarget_convert_logical1_typeless
1266 (ffebld_cu_ptr_logical1 (u),
1267 ffebld_constant_typeless (ffebld_conter (l)));
1268 break;
1269
1270 default:
1271 assert ("LOGICAL1 bad type" == NULL);
1272 break;
1273 }
1274
1275 /* If conversion operation is not implemented, return original expr. */
1276 if (error == FFEBAD_NOCANDO)
1277 return expr;
1278
1279 expr = ffebld_new_conter_with_orig
1280 (ffebld_constant_new_logical1_val
1281 (ffebld_cu_val_logical1 (u)), expr);
1282 break;
1283 #endif
1284
1285 #if FFETARGET_okLOGICAL2
1286 case FFEINFO_kindtypeLOGICAL2:
1287 switch (ffeinfo_basictype (ffebld_info (l)))
1288 {
1289 case FFEINFO_basictypeLOGICAL:
1290 switch (ffeinfo_kindtype (ffebld_info (l)))
1291 {
1292 #if FFETARGET_okLOGICAL1
1293 case FFEINFO_kindtypeLOGICAL1:
1294 error = ffetarget_convert_logical2_logical1
1295 (ffebld_cu_ptr_logical2 (u),
1296 ffebld_constant_logical1 (ffebld_conter (l)));
1297 break;
1298 #endif
1299
1300 #if FFETARGET_okLOGICAL3
1301 case FFEINFO_kindtypeLOGICAL3:
1302 error = ffetarget_convert_logical2_logical3
1303 (ffebld_cu_ptr_logical2 (u),
1304 ffebld_constant_logical3 (ffebld_conter (l)));
1305 break;
1306 #endif
1307
1308 #if FFETARGET_okLOGICAL4
1309 case FFEINFO_kindtypeLOGICAL4:
1310 error = ffetarget_convert_logical2_logical4
1311 (ffebld_cu_ptr_logical2 (u),
1312 ffebld_constant_logical4 (ffebld_conter (l)));
1313 break;
1314 #endif
1315
1316 default:
1317 assert ("LOGICAL2/LOGICAL bad source kind type" == NULL);
1318 break;
1319 }
1320 break;
1321
1322 case FFEINFO_basictypeINTEGER:
1323 switch (ffeinfo_kindtype (ffebld_info (l)))
1324 {
1325 #if FFETARGET_okINTEGER1
1326 case FFEINFO_kindtypeINTEGER1:
1327 error = ffetarget_convert_logical2_integer1
1328 (ffebld_cu_ptr_logical2 (u),
1329 ffebld_constant_integer1 (ffebld_conter (l)));
1330 break;
1331 #endif
1332
1333 #if FFETARGET_okINTEGER2
1334 case FFEINFO_kindtypeINTEGER2:
1335 error = ffetarget_convert_logical2_integer2
1336 (ffebld_cu_ptr_logical2 (u),
1337 ffebld_constant_integer2 (ffebld_conter (l)));
1338 break;
1339 #endif
1340
1341 #if FFETARGET_okINTEGER3
1342 case FFEINFO_kindtypeINTEGER3:
1343 error = ffetarget_convert_logical2_integer3
1344 (ffebld_cu_ptr_logical2 (u),
1345 ffebld_constant_integer3 (ffebld_conter (l)));
1346 break;
1347 #endif
1348
1349 #if FFETARGET_okINTEGER4
1350 case FFEINFO_kindtypeINTEGER4:
1351 error = ffetarget_convert_logical2_integer4
1352 (ffebld_cu_ptr_logical2 (u),
1353 ffebld_constant_integer4 (ffebld_conter (l)));
1354 break;
1355 #endif
1356
1357 default:
1358 assert ("LOGICAL2/INTEGER bad source kind type" == NULL);
1359 break;
1360 }
1361 break;
1362
1363 case FFEINFO_basictypeCHARACTER:
1364 error = ffetarget_convert_logical2_character1
1365 (ffebld_cu_ptr_logical2 (u),
1366 ffebld_constant_character1 (ffebld_conter (l)));
1367 break;
1368
1369 case FFEINFO_basictypeHOLLERITH:
1370 error = ffetarget_convert_logical2_hollerith
1371 (ffebld_cu_ptr_logical2 (u),
1372 ffebld_constant_hollerith (ffebld_conter (l)));
1373 break;
1374
1375 case FFEINFO_basictypeTYPELESS:
1376 error = ffetarget_convert_logical2_typeless
1377 (ffebld_cu_ptr_logical2 (u),
1378 ffebld_constant_typeless (ffebld_conter (l)));
1379 break;
1380
1381 default:
1382 assert ("LOGICAL2 bad type" == NULL);
1383 break;
1384 }
1385
1386 /* If conversion operation is not implemented, return original expr. */
1387 if (error == FFEBAD_NOCANDO)
1388 return expr;
1389
1390 expr = ffebld_new_conter_with_orig
1391 (ffebld_constant_new_logical2_val
1392 (ffebld_cu_val_logical2 (u)), expr);
1393 break;
1394 #endif
1395
1396 #if FFETARGET_okLOGICAL3
1397 case FFEINFO_kindtypeLOGICAL3:
1398 switch (ffeinfo_basictype (ffebld_info (l)))
1399 {
1400 case FFEINFO_basictypeLOGICAL:
1401 switch (ffeinfo_kindtype (ffebld_info (l)))
1402 {
1403 #if FFETARGET_okLOGICAL1
1404 case FFEINFO_kindtypeLOGICAL1:
1405 error = ffetarget_convert_logical3_logical1
1406 (ffebld_cu_ptr_logical3 (u),
1407 ffebld_constant_logical1 (ffebld_conter (l)));
1408 break;
1409 #endif
1410
1411 #if FFETARGET_okLOGICAL2
1412 case FFEINFO_kindtypeLOGICAL2:
1413 error = ffetarget_convert_logical3_logical2
1414 (ffebld_cu_ptr_logical3 (u),
1415 ffebld_constant_logical2 (ffebld_conter (l)));
1416 break;
1417 #endif
1418
1419 #if FFETARGET_okLOGICAL4
1420 case FFEINFO_kindtypeLOGICAL4:
1421 error = ffetarget_convert_logical3_logical4
1422 (ffebld_cu_ptr_logical3 (u),
1423 ffebld_constant_logical4 (ffebld_conter (l)));
1424 break;
1425 #endif
1426
1427 default:
1428 assert ("LOGICAL3/LOGICAL bad source kind type" == NULL);
1429 break;
1430 }
1431 break;
1432
1433 case FFEINFO_basictypeINTEGER:
1434 switch (ffeinfo_kindtype (ffebld_info (l)))
1435 {
1436 #if FFETARGET_okINTEGER1
1437 case FFEINFO_kindtypeINTEGER1:
1438 error = ffetarget_convert_logical3_integer1
1439 (ffebld_cu_ptr_logical3 (u),
1440 ffebld_constant_integer1 (ffebld_conter (l)));
1441 break;
1442 #endif
1443
1444 #if FFETARGET_okINTEGER2
1445 case FFEINFO_kindtypeINTEGER2:
1446 error = ffetarget_convert_logical3_integer2
1447 (ffebld_cu_ptr_logical3 (u),
1448 ffebld_constant_integer2 (ffebld_conter (l)));
1449 break;
1450 #endif
1451
1452 #if FFETARGET_okINTEGER3
1453 case FFEINFO_kindtypeINTEGER3:
1454 error = ffetarget_convert_logical3_integer3
1455 (ffebld_cu_ptr_logical3 (u),
1456 ffebld_constant_integer3 (ffebld_conter (l)));
1457 break;
1458 #endif
1459
1460 #if FFETARGET_okINTEGER4
1461 case FFEINFO_kindtypeINTEGER4:
1462 error = ffetarget_convert_logical3_integer4
1463 (ffebld_cu_ptr_logical3 (u),
1464 ffebld_constant_integer4 (ffebld_conter (l)));
1465 break;
1466 #endif
1467
1468 default:
1469 assert ("LOGICAL3/INTEGER bad source kind type" == NULL);
1470 break;
1471 }
1472 break;
1473
1474 case FFEINFO_basictypeCHARACTER:
1475 error = ffetarget_convert_logical3_character1
1476 (ffebld_cu_ptr_logical3 (u),
1477 ffebld_constant_character1 (ffebld_conter (l)));
1478 break;
1479
1480 case FFEINFO_basictypeHOLLERITH:
1481 error = ffetarget_convert_logical3_hollerith
1482 (ffebld_cu_ptr_logical3 (u),
1483 ffebld_constant_hollerith (ffebld_conter (l)));
1484 break;
1485
1486 case FFEINFO_basictypeTYPELESS:
1487 error = ffetarget_convert_logical3_typeless
1488 (ffebld_cu_ptr_logical3 (u),
1489 ffebld_constant_typeless (ffebld_conter (l)));
1490 break;
1491
1492 default:
1493 assert ("LOGICAL3 bad type" == NULL);
1494 break;
1495 }
1496
1497 /* If conversion operation is not implemented, return original expr. */
1498 if (error == FFEBAD_NOCANDO)
1499 return expr;
1500
1501 expr = ffebld_new_conter_with_orig
1502 (ffebld_constant_new_logical3_val
1503 (ffebld_cu_val_logical3 (u)), expr);
1504 break;
1505 #endif
1506
1507 #if FFETARGET_okLOGICAL4
1508 case FFEINFO_kindtypeLOGICAL4:
1509 switch (ffeinfo_basictype (ffebld_info (l)))
1510 {
1511 case FFEINFO_basictypeLOGICAL:
1512 switch (ffeinfo_kindtype (ffebld_info (l)))
1513 {
1514 #if FFETARGET_okLOGICAL1
1515 case FFEINFO_kindtypeLOGICAL1:
1516 error = ffetarget_convert_logical4_logical1
1517 (ffebld_cu_ptr_logical4 (u),
1518 ffebld_constant_logical1 (ffebld_conter (l)));
1519 break;
1520 #endif
1521
1522 #if FFETARGET_okLOGICAL2
1523 case FFEINFO_kindtypeLOGICAL2:
1524 error = ffetarget_convert_logical4_logical2
1525 (ffebld_cu_ptr_logical4 (u),
1526 ffebld_constant_logical2 (ffebld_conter (l)));
1527 break;
1528 #endif
1529
1530 #if FFETARGET_okLOGICAL3
1531 case FFEINFO_kindtypeLOGICAL3:
1532 error = ffetarget_convert_logical4_logical3
1533 (ffebld_cu_ptr_logical4 (u),
1534 ffebld_constant_logical3 (ffebld_conter (l)));
1535 break;
1536 #endif
1537
1538 default:
1539 assert ("LOGICAL4/LOGICAL bad source kind type" == NULL);
1540 break;
1541 }
1542 break;
1543
1544 case FFEINFO_basictypeINTEGER:
1545 switch (ffeinfo_kindtype (ffebld_info (l)))
1546 {
1547 #if FFETARGET_okINTEGER1
1548 case FFEINFO_kindtypeINTEGER1:
1549 error = ffetarget_convert_logical4_integer1
1550 (ffebld_cu_ptr_logical4 (u),
1551 ffebld_constant_integer1 (ffebld_conter (l)));
1552 break;
1553 #endif
1554
1555 #if FFETARGET_okINTEGER2
1556 case FFEINFO_kindtypeINTEGER2:
1557 error = ffetarget_convert_logical4_integer2
1558 (ffebld_cu_ptr_logical4 (u),
1559 ffebld_constant_integer2 (ffebld_conter (l)));
1560 break;
1561 #endif
1562
1563 #if FFETARGET_okINTEGER3
1564 case FFEINFO_kindtypeINTEGER3:
1565 error = ffetarget_convert_logical4_integer3
1566 (ffebld_cu_ptr_logical4 (u),
1567 ffebld_constant_integer3 (ffebld_conter (l)));
1568 break;
1569 #endif
1570
1571 #if FFETARGET_okINTEGER4
1572 case FFEINFO_kindtypeINTEGER4:
1573 error = ffetarget_convert_logical4_integer4
1574 (ffebld_cu_ptr_logical4 (u),
1575 ffebld_constant_integer4 (ffebld_conter (l)));
1576 break;
1577 #endif
1578
1579 default:
1580 assert ("LOGICAL4/INTEGER bad source kind type" == NULL);
1581 break;
1582 }
1583 break;
1584
1585 case FFEINFO_basictypeCHARACTER:
1586 error = ffetarget_convert_logical4_character1
1587 (ffebld_cu_ptr_logical4 (u),
1588 ffebld_constant_character1 (ffebld_conter (l)));
1589 break;
1590
1591 case FFEINFO_basictypeHOLLERITH:
1592 error = ffetarget_convert_logical4_hollerith
1593 (ffebld_cu_ptr_logical4 (u),
1594 ffebld_constant_hollerith (ffebld_conter (l)));
1595 break;
1596
1597 case FFEINFO_basictypeTYPELESS:
1598 error = ffetarget_convert_logical4_typeless
1599 (ffebld_cu_ptr_logical4 (u),
1600 ffebld_constant_typeless (ffebld_conter (l)));
1601 break;
1602
1603 default:
1604 assert ("LOGICAL4 bad type" == NULL);
1605 break;
1606 }
1607
1608 /* If conversion operation is not implemented, return original expr. */
1609 if (error == FFEBAD_NOCANDO)
1610 return expr;
1611
1612 expr = ffebld_new_conter_with_orig
1613 (ffebld_constant_new_logical4_val
1614 (ffebld_cu_val_logical4 (u)), expr);
1615 break;
1616 #endif
1617
1618 default:
1619 assert ("bad logical kind type" == NULL);
1620 break;
1621 }
1622 break;
1623
1624 case FFEINFO_basictypeREAL:
1625 sz = FFETARGET_charactersizeNONE;
1626 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1627 {
1628 #if FFETARGET_okREAL1
1629 case FFEINFO_kindtypeREAL1:
1630 switch (ffeinfo_basictype (ffebld_info (l)))
1631 {
1632 case FFEINFO_basictypeINTEGER:
1633 switch (ffeinfo_kindtype (ffebld_info (l)))
1634 {
1635 #if FFETARGET_okINTEGER1
1636 case FFEINFO_kindtypeINTEGER1:
1637 error = ffetarget_convert_real1_integer1
1638 (ffebld_cu_ptr_real1 (u),
1639 ffebld_constant_integer1 (ffebld_conter (l)));
1640 break;
1641 #endif
1642
1643 #if FFETARGET_okINTEGER2
1644 case FFEINFO_kindtypeINTEGER2:
1645 error = ffetarget_convert_real1_integer2
1646 (ffebld_cu_ptr_real1 (u),
1647 ffebld_constant_integer2 (ffebld_conter (l)));
1648 break;
1649 #endif
1650
1651 #if FFETARGET_okINTEGER3
1652 case FFEINFO_kindtypeINTEGER3:
1653 error = ffetarget_convert_real1_integer3
1654 (ffebld_cu_ptr_real1 (u),
1655 ffebld_constant_integer3 (ffebld_conter (l)));
1656 break;
1657 #endif
1658
1659 #if FFETARGET_okINTEGER4
1660 case FFEINFO_kindtypeINTEGER4:
1661 error = ffetarget_convert_real1_integer4
1662 (ffebld_cu_ptr_real1 (u),
1663 ffebld_constant_integer4 (ffebld_conter (l)));
1664 break;
1665 #endif
1666
1667 default:
1668 assert ("REAL1/INTEGER bad source kind type" == NULL);
1669 break;
1670 }
1671 break;
1672
1673 case FFEINFO_basictypeREAL:
1674 switch (ffeinfo_kindtype (ffebld_info (l)))
1675 {
1676 #if FFETARGET_okREAL2
1677 case FFEINFO_kindtypeREAL2:
1678 error = ffetarget_convert_real1_real2
1679 (ffebld_cu_ptr_real1 (u),
1680 ffebld_constant_real2 (ffebld_conter (l)));
1681 break;
1682 #endif
1683
1684 #if FFETARGET_okREAL3
1685 case FFEINFO_kindtypeREAL3:
1686 error = ffetarget_convert_real1_real3
1687 (ffebld_cu_ptr_real1 (u),
1688 ffebld_constant_real3 (ffebld_conter (l)));
1689 break;
1690 #endif
1691
1692 default:
1693 assert ("REAL1/REAL bad source kind type" == NULL);
1694 break;
1695 }
1696 break;
1697
1698 case FFEINFO_basictypeCOMPLEX:
1699 switch (ffeinfo_kindtype (ffebld_info (l)))
1700 {
1701 #if FFETARGET_okCOMPLEX1
1702 case FFEINFO_kindtypeREAL1:
1703 error = ffetarget_convert_real1_complex1
1704 (ffebld_cu_ptr_real1 (u),
1705 ffebld_constant_complex1 (ffebld_conter (l)));
1706 break;
1707 #endif
1708
1709 #if FFETARGET_okCOMPLEX2
1710 case FFEINFO_kindtypeREAL2:
1711 error = ffetarget_convert_real1_complex2
1712 (ffebld_cu_ptr_real1 (u),
1713 ffebld_constant_complex2 (ffebld_conter (l)));
1714 break;
1715 #endif
1716
1717 #if FFETARGET_okCOMPLEX3
1718 case FFEINFO_kindtypeREAL3:
1719 error = ffetarget_convert_real1_complex3
1720 (ffebld_cu_ptr_real1 (u),
1721 ffebld_constant_complex3 (ffebld_conter (l)));
1722 break;
1723 #endif
1724
1725 default:
1726 assert ("REAL1/COMPLEX bad source kind type" == NULL);
1727 break;
1728 }
1729 break;
1730
1731 case FFEINFO_basictypeCHARACTER:
1732 error = ffetarget_convert_real1_character1
1733 (ffebld_cu_ptr_real1 (u),
1734 ffebld_constant_character1 (ffebld_conter (l)));
1735 break;
1736
1737 case FFEINFO_basictypeHOLLERITH:
1738 error = ffetarget_convert_real1_hollerith
1739 (ffebld_cu_ptr_real1 (u),
1740 ffebld_constant_hollerith (ffebld_conter (l)));
1741 break;
1742
1743 case FFEINFO_basictypeTYPELESS:
1744 error = ffetarget_convert_real1_typeless
1745 (ffebld_cu_ptr_real1 (u),
1746 ffebld_constant_typeless (ffebld_conter (l)));
1747 break;
1748
1749 default:
1750 assert ("REAL1 bad type" == NULL);
1751 break;
1752 }
1753
1754 /* If conversion operation is not implemented, return original expr. */
1755 if (error == FFEBAD_NOCANDO)
1756 return expr;
1757
1758 expr = ffebld_new_conter_with_orig
1759 (ffebld_constant_new_real1_val
1760 (ffebld_cu_val_real1 (u)), expr);
1761 break;
1762 #endif
1763
1764 #if FFETARGET_okREAL2
1765 case FFEINFO_kindtypeREAL2:
1766 switch (ffeinfo_basictype (ffebld_info (l)))
1767 {
1768 case FFEINFO_basictypeINTEGER:
1769 switch (ffeinfo_kindtype (ffebld_info (l)))
1770 {
1771 #if FFETARGET_okINTEGER1
1772 case FFEINFO_kindtypeINTEGER1:
1773 error = ffetarget_convert_real2_integer1
1774 (ffebld_cu_ptr_real2 (u),
1775 ffebld_constant_integer1 (ffebld_conter (l)));
1776 break;
1777 #endif
1778
1779 #if FFETARGET_okINTEGER2
1780 case FFEINFO_kindtypeINTEGER2:
1781 error = ffetarget_convert_real2_integer2
1782 (ffebld_cu_ptr_real2 (u),
1783 ffebld_constant_integer2 (ffebld_conter (l)));
1784 break;
1785 #endif
1786
1787 #if FFETARGET_okINTEGER3
1788 case FFEINFO_kindtypeINTEGER3:
1789 error = ffetarget_convert_real2_integer3
1790 (ffebld_cu_ptr_real2 (u),
1791 ffebld_constant_integer3 (ffebld_conter (l)));
1792 break;
1793 #endif
1794
1795 #if FFETARGET_okINTEGER4
1796 case FFEINFO_kindtypeINTEGER4:
1797 error = ffetarget_convert_real2_integer4
1798 (ffebld_cu_ptr_real2 (u),
1799 ffebld_constant_integer4 (ffebld_conter (l)));
1800 break;
1801 #endif
1802
1803 default:
1804 assert ("REAL2/INTEGER bad source kind type" == NULL);
1805 break;
1806 }
1807 break;
1808
1809 case FFEINFO_basictypeREAL:
1810 switch (ffeinfo_kindtype (ffebld_info (l)))
1811 {
1812 #if FFETARGET_okREAL1
1813 case FFEINFO_kindtypeREAL1:
1814 error = ffetarget_convert_real2_real1
1815 (ffebld_cu_ptr_real2 (u),
1816 ffebld_constant_real1 (ffebld_conter (l)));
1817 break;
1818 #endif
1819
1820 #if FFETARGET_okREAL3
1821 case FFEINFO_kindtypeREAL3:
1822 error = ffetarget_convert_real2_real3
1823 (ffebld_cu_ptr_real2 (u),
1824 ffebld_constant_real3 (ffebld_conter (l)));
1825 break;
1826 #endif
1827
1828 default:
1829 assert ("REAL2/REAL bad source kind type" == NULL);
1830 break;
1831 }
1832 break;
1833
1834 case FFEINFO_basictypeCOMPLEX:
1835 switch (ffeinfo_kindtype (ffebld_info (l)))
1836 {
1837 #if FFETARGET_okCOMPLEX1
1838 case FFEINFO_kindtypeREAL1:
1839 error = ffetarget_convert_real2_complex1
1840 (ffebld_cu_ptr_real2 (u),
1841 ffebld_constant_complex1 (ffebld_conter (l)));
1842 break;
1843 #endif
1844
1845 #if FFETARGET_okCOMPLEX2
1846 case FFEINFO_kindtypeREAL2:
1847 error = ffetarget_convert_real2_complex2
1848 (ffebld_cu_ptr_real2 (u),
1849 ffebld_constant_complex2 (ffebld_conter (l)));
1850 break;
1851 #endif
1852
1853 #if FFETARGET_okCOMPLEX3
1854 case FFEINFO_kindtypeREAL3:
1855 error = ffetarget_convert_real2_complex3
1856 (ffebld_cu_ptr_real2 (u),
1857 ffebld_constant_complex3 (ffebld_conter (l)));
1858 break;
1859 #endif
1860
1861 default:
1862 assert ("REAL2/COMPLEX bad source kind type" == NULL);
1863 break;
1864 }
1865 break;
1866
1867 case FFEINFO_basictypeCHARACTER:
1868 error = ffetarget_convert_real2_character1
1869 (ffebld_cu_ptr_real2 (u),
1870 ffebld_constant_character1 (ffebld_conter (l)));
1871 break;
1872
1873 case FFEINFO_basictypeHOLLERITH:
1874 error = ffetarget_convert_real2_hollerith
1875 (ffebld_cu_ptr_real2 (u),
1876 ffebld_constant_hollerith (ffebld_conter (l)));
1877 break;
1878
1879 case FFEINFO_basictypeTYPELESS:
1880 error = ffetarget_convert_real2_typeless
1881 (ffebld_cu_ptr_real2 (u),
1882 ffebld_constant_typeless (ffebld_conter (l)));
1883 break;
1884
1885 default:
1886 assert ("REAL2 bad type" == NULL);
1887 break;
1888 }
1889
1890 /* If conversion operation is not implemented, return original expr. */
1891 if (error == FFEBAD_NOCANDO)
1892 return expr;
1893
1894 expr = ffebld_new_conter_with_orig
1895 (ffebld_constant_new_real2_val
1896 (ffebld_cu_val_real2 (u)), expr);
1897 break;
1898 #endif
1899
1900 #if FFETARGET_okREAL3
1901 case FFEINFO_kindtypeREAL3:
1902 switch (ffeinfo_basictype (ffebld_info (l)))
1903 {
1904 case FFEINFO_basictypeINTEGER:
1905 switch (ffeinfo_kindtype (ffebld_info (l)))
1906 {
1907 #if FFETARGET_okINTEGER1
1908 case FFEINFO_kindtypeINTEGER1:
1909 error = ffetarget_convert_real3_integer1
1910 (ffebld_cu_ptr_real3 (u),
1911 ffebld_constant_integer1 (ffebld_conter (l)));
1912 break;
1913 #endif
1914
1915 #if FFETARGET_okINTEGER2
1916 case FFEINFO_kindtypeINTEGER2:
1917 error = ffetarget_convert_real3_integer2
1918 (ffebld_cu_ptr_real3 (u),
1919 ffebld_constant_integer2 (ffebld_conter (l)));
1920 break;
1921 #endif
1922
1923 #if FFETARGET_okINTEGER3
1924 case FFEINFO_kindtypeINTEGER3:
1925 error = ffetarget_convert_real3_integer3
1926 (ffebld_cu_ptr_real3 (u),
1927 ffebld_constant_integer3 (ffebld_conter (l)));
1928 break;
1929 #endif
1930
1931 #if FFETARGET_okINTEGER4
1932 case FFEINFO_kindtypeINTEGER4:
1933 error = ffetarget_convert_real3_integer4
1934 (ffebld_cu_ptr_real3 (u),
1935 ffebld_constant_integer4 (ffebld_conter (l)));
1936 break;
1937 #endif
1938
1939 default:
1940 assert ("REAL3/INTEGER bad source kind type" == NULL);
1941 break;
1942 }
1943 break;
1944
1945 case FFEINFO_basictypeREAL:
1946 switch (ffeinfo_kindtype (ffebld_info (l)))
1947 {
1948 #if FFETARGET_okREAL1
1949 case FFEINFO_kindtypeREAL1:
1950 error = ffetarget_convert_real3_real1
1951 (ffebld_cu_ptr_real3 (u),
1952 ffebld_constant_real1 (ffebld_conter (l)));
1953 break;
1954 #endif
1955
1956 #if FFETARGET_okREAL2
1957 case FFEINFO_kindtypeREAL2:
1958 error = ffetarget_convert_real3_real2
1959 (ffebld_cu_ptr_real3 (u),
1960 ffebld_constant_real2 (ffebld_conter (l)));
1961 break;
1962 #endif
1963
1964 default:
1965 assert ("REAL3/REAL bad source kind type" == NULL);
1966 break;
1967 }
1968 break;
1969
1970 case FFEINFO_basictypeCOMPLEX:
1971 switch (ffeinfo_kindtype (ffebld_info (l)))
1972 {
1973 #if FFETARGET_okCOMPLEX1
1974 case FFEINFO_kindtypeREAL1:
1975 error = ffetarget_convert_real3_complex1
1976 (ffebld_cu_ptr_real3 (u),
1977 ffebld_constant_complex1 (ffebld_conter (l)));
1978 break;
1979 #endif
1980
1981 #if FFETARGET_okCOMPLEX2
1982 case FFEINFO_kindtypeREAL2:
1983 error = ffetarget_convert_real3_complex2
1984 (ffebld_cu_ptr_real3 (u),
1985 ffebld_constant_complex2 (ffebld_conter (l)));
1986 break;
1987 #endif
1988
1989 #if FFETARGET_okCOMPLEX3
1990 case FFEINFO_kindtypeREAL3:
1991 error = ffetarget_convert_real3_complex3
1992 (ffebld_cu_ptr_real3 (u),
1993 ffebld_constant_complex3 (ffebld_conter (l)));
1994 break;
1995 #endif
1996
1997 default:
1998 assert ("REAL3/COMPLEX bad source kind type" == NULL);
1999 break;
2000 }
2001 break;
2002
2003 case FFEINFO_basictypeCHARACTER:
2004 error = ffetarget_convert_real3_character1
2005 (ffebld_cu_ptr_real3 (u),
2006 ffebld_constant_character1 (ffebld_conter (l)));
2007 break;
2008
2009 case FFEINFO_basictypeHOLLERITH:
2010 error = ffetarget_convert_real3_hollerith
2011 (ffebld_cu_ptr_real3 (u),
2012 ffebld_constant_hollerith (ffebld_conter (l)));
2013 break;
2014
2015 case FFEINFO_basictypeTYPELESS:
2016 error = ffetarget_convert_real3_typeless
2017 (ffebld_cu_ptr_real3 (u),
2018 ffebld_constant_typeless (ffebld_conter (l)));
2019 break;
2020
2021 default:
2022 assert ("REAL3 bad type" == NULL);
2023 break;
2024 }
2025
2026 /* If conversion operation is not implemented, return original expr. */
2027 if (error == FFEBAD_NOCANDO)
2028 return expr;
2029
2030 expr = ffebld_new_conter_with_orig
2031 (ffebld_constant_new_real3_val
2032 (ffebld_cu_val_real3 (u)), expr);
2033 break;
2034 #endif
2035
2036 default:
2037 assert ("bad real kind type" == NULL);
2038 break;
2039 }
2040 break;
2041
2042 case FFEINFO_basictypeCOMPLEX:
2043 sz = FFETARGET_charactersizeNONE;
2044 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2045 {
2046 #if FFETARGET_okCOMPLEX1
2047 case FFEINFO_kindtypeREAL1:
2048 switch (ffeinfo_basictype (ffebld_info (l)))
2049 {
2050 case FFEINFO_basictypeINTEGER:
2051 switch (ffeinfo_kindtype (ffebld_info (l)))
2052 {
2053 #if FFETARGET_okINTEGER1
2054 case FFEINFO_kindtypeINTEGER1:
2055 error = ffetarget_convert_complex1_integer1
2056 (ffebld_cu_ptr_complex1 (u),
2057 ffebld_constant_integer1 (ffebld_conter (l)));
2058 break;
2059 #endif
2060
2061 #if FFETARGET_okINTEGER2
2062 case FFEINFO_kindtypeINTEGER2:
2063 error = ffetarget_convert_complex1_integer2
2064 (ffebld_cu_ptr_complex1 (u),
2065 ffebld_constant_integer2 (ffebld_conter (l)));
2066 break;
2067 #endif
2068
2069 #if FFETARGET_okINTEGER3
2070 case FFEINFO_kindtypeINTEGER3:
2071 error = ffetarget_convert_complex1_integer3
2072 (ffebld_cu_ptr_complex1 (u),
2073 ffebld_constant_integer3 (ffebld_conter (l)));
2074 break;
2075 #endif
2076
2077 #if FFETARGET_okINTEGER4
2078 case FFEINFO_kindtypeINTEGER4:
2079 error = ffetarget_convert_complex1_integer4
2080 (ffebld_cu_ptr_complex1 (u),
2081 ffebld_constant_integer4 (ffebld_conter (l)));
2082 break;
2083 #endif
2084
2085 default:
2086 assert ("COMPLEX1/INTEGER bad source kind type" == NULL);
2087 break;
2088 }
2089 break;
2090
2091 case FFEINFO_basictypeREAL:
2092 switch (ffeinfo_kindtype (ffebld_info (l)))
2093 {
2094 #if FFETARGET_okREAL1
2095 case FFEINFO_kindtypeREAL1:
2096 error = ffetarget_convert_complex1_real1
2097 (ffebld_cu_ptr_complex1 (u),
2098 ffebld_constant_real1 (ffebld_conter (l)));
2099 break;
2100 #endif
2101
2102 #if FFETARGET_okREAL2
2103 case FFEINFO_kindtypeREAL2:
2104 error = ffetarget_convert_complex1_real2
2105 (ffebld_cu_ptr_complex1 (u),
2106 ffebld_constant_real2 (ffebld_conter (l)));
2107 break;
2108 #endif
2109
2110 #if FFETARGET_okREAL3
2111 case FFEINFO_kindtypeREAL3:
2112 error = ffetarget_convert_complex1_real3
2113 (ffebld_cu_ptr_complex1 (u),
2114 ffebld_constant_real3 (ffebld_conter (l)));
2115 break;
2116 #endif
2117
2118 default:
2119 assert ("COMPLEX1/REAL bad source kind type" == NULL);
2120 break;
2121 }
2122 break;
2123
2124 case FFEINFO_basictypeCOMPLEX:
2125 switch (ffeinfo_kindtype (ffebld_info (l)))
2126 {
2127 #if FFETARGET_okCOMPLEX2
2128 case FFEINFO_kindtypeREAL2:
2129 error = ffetarget_convert_complex1_complex2
2130 (ffebld_cu_ptr_complex1 (u),
2131 ffebld_constant_complex2 (ffebld_conter (l)));
2132 break;
2133 #endif
2134
2135 #if FFETARGET_okCOMPLEX3
2136 case FFEINFO_kindtypeREAL3:
2137 error = ffetarget_convert_complex1_complex3
2138 (ffebld_cu_ptr_complex1 (u),
2139 ffebld_constant_complex3 (ffebld_conter (l)));
2140 break;
2141 #endif
2142
2143 default:
2144 assert ("COMPLEX1/COMPLEX bad source kind type" == NULL);
2145 break;
2146 }
2147 break;
2148
2149 case FFEINFO_basictypeCHARACTER:
2150 error = ffetarget_convert_complex1_character1
2151 (ffebld_cu_ptr_complex1 (u),
2152 ffebld_constant_character1 (ffebld_conter (l)));
2153 break;
2154
2155 case FFEINFO_basictypeHOLLERITH:
2156 error = ffetarget_convert_complex1_hollerith
2157 (ffebld_cu_ptr_complex1 (u),
2158 ffebld_constant_hollerith (ffebld_conter (l)));
2159 break;
2160
2161 case FFEINFO_basictypeTYPELESS:
2162 error = ffetarget_convert_complex1_typeless
2163 (ffebld_cu_ptr_complex1 (u),
2164 ffebld_constant_typeless (ffebld_conter (l)));
2165 break;
2166
2167 default:
2168 assert ("COMPLEX1 bad type" == NULL);
2169 break;
2170 }
2171
2172 /* If conversion operation is not implemented, return original expr. */
2173 if (error == FFEBAD_NOCANDO)
2174 return expr;
2175
2176 expr = ffebld_new_conter_with_orig
2177 (ffebld_constant_new_complex1_val
2178 (ffebld_cu_val_complex1 (u)), expr);
2179 break;
2180 #endif
2181
2182 #if FFETARGET_okCOMPLEX2
2183 case FFEINFO_kindtypeREAL2:
2184 switch (ffeinfo_basictype (ffebld_info (l)))
2185 {
2186 case FFEINFO_basictypeINTEGER:
2187 switch (ffeinfo_kindtype (ffebld_info (l)))
2188 {
2189 #if FFETARGET_okINTEGER1
2190 case FFEINFO_kindtypeINTEGER1:
2191 error = ffetarget_convert_complex2_integer1
2192 (ffebld_cu_ptr_complex2 (u),
2193 ffebld_constant_integer1 (ffebld_conter (l)));
2194 break;
2195 #endif
2196
2197 #if FFETARGET_okINTEGER2
2198 case FFEINFO_kindtypeINTEGER2:
2199 error = ffetarget_convert_complex2_integer2
2200 (ffebld_cu_ptr_complex2 (u),
2201 ffebld_constant_integer2 (ffebld_conter (l)));
2202 break;
2203 #endif
2204
2205 #if FFETARGET_okINTEGER3
2206 case FFEINFO_kindtypeINTEGER3:
2207 error = ffetarget_convert_complex2_integer3
2208 (ffebld_cu_ptr_complex2 (u),
2209 ffebld_constant_integer3 (ffebld_conter (l)));
2210 break;
2211 #endif
2212
2213 #if FFETARGET_okINTEGER4
2214 case FFEINFO_kindtypeINTEGER4:
2215 error = ffetarget_convert_complex2_integer4
2216 (ffebld_cu_ptr_complex2 (u),
2217 ffebld_constant_integer4 (ffebld_conter (l)));
2218 break;
2219 #endif
2220
2221 default:
2222 assert ("COMPLEX2/INTEGER bad source kind type" == NULL);
2223 break;
2224 }
2225 break;
2226
2227 case FFEINFO_basictypeREAL:
2228 switch (ffeinfo_kindtype (ffebld_info (l)))
2229 {
2230 #if FFETARGET_okREAL1
2231 case FFEINFO_kindtypeREAL1:
2232 error = ffetarget_convert_complex2_real1
2233 (ffebld_cu_ptr_complex2 (u),
2234 ffebld_constant_real1 (ffebld_conter (l)));
2235 break;
2236 #endif
2237
2238 #if FFETARGET_okREAL2
2239 case FFEINFO_kindtypeREAL2:
2240 error = ffetarget_convert_complex2_real2
2241 (ffebld_cu_ptr_complex2 (u),
2242 ffebld_constant_real2 (ffebld_conter (l)));
2243 break;
2244 #endif
2245
2246 #if FFETARGET_okREAL3
2247 case FFEINFO_kindtypeREAL3:
2248 error = ffetarget_convert_complex2_real3
2249 (ffebld_cu_ptr_complex2 (u),
2250 ffebld_constant_real3 (ffebld_conter (l)));
2251 break;
2252 #endif
2253
2254 default:
2255 assert ("COMPLEX2/REAL bad source kind type" == NULL);
2256 break;
2257 }
2258 break;
2259
2260 case FFEINFO_basictypeCOMPLEX:
2261 switch (ffeinfo_kindtype (ffebld_info (l)))
2262 {
2263 #if FFETARGET_okCOMPLEX1
2264 case FFEINFO_kindtypeREAL1:
2265 error = ffetarget_convert_complex2_complex1
2266 (ffebld_cu_ptr_complex2 (u),
2267 ffebld_constant_complex1 (ffebld_conter (l)));
2268 break;
2269 #endif
2270
2271 #if FFETARGET_okCOMPLEX3
2272 case FFEINFO_kindtypeREAL3:
2273 error = ffetarget_convert_complex2_complex3
2274 (ffebld_cu_ptr_complex2 (u),
2275 ffebld_constant_complex3 (ffebld_conter (l)));
2276 break;
2277 #endif
2278
2279 default:
2280 assert ("COMPLEX2/COMPLEX bad source kind type" == NULL);
2281 break;
2282 }
2283 break;
2284
2285 case FFEINFO_basictypeCHARACTER:
2286 error = ffetarget_convert_complex2_character1
2287 (ffebld_cu_ptr_complex2 (u),
2288 ffebld_constant_character1 (ffebld_conter (l)));
2289 break;
2290
2291 case FFEINFO_basictypeHOLLERITH:
2292 error = ffetarget_convert_complex2_hollerith
2293 (ffebld_cu_ptr_complex2 (u),
2294 ffebld_constant_hollerith (ffebld_conter (l)));
2295 break;
2296
2297 case FFEINFO_basictypeTYPELESS:
2298 error = ffetarget_convert_complex2_typeless
2299 (ffebld_cu_ptr_complex2 (u),
2300 ffebld_constant_typeless (ffebld_conter (l)));
2301 break;
2302
2303 default:
2304 assert ("COMPLEX2 bad type" == NULL);
2305 break;
2306 }
2307
2308 /* If conversion operation is not implemented, return original expr. */
2309 if (error == FFEBAD_NOCANDO)
2310 return expr;
2311
2312 expr = ffebld_new_conter_with_orig
2313 (ffebld_constant_new_complex2_val
2314 (ffebld_cu_val_complex2 (u)), expr);
2315 break;
2316 #endif
2317
2318 #if FFETARGET_okCOMPLEX3
2319 case FFEINFO_kindtypeREAL3:
2320 switch (ffeinfo_basictype (ffebld_info (l)))
2321 {
2322 case FFEINFO_basictypeINTEGER:
2323 switch (ffeinfo_kindtype (ffebld_info (l)))
2324 {
2325 #if FFETARGET_okINTEGER1
2326 case FFEINFO_kindtypeINTEGER1:
2327 error = ffetarget_convert_complex3_integer1
2328 (ffebld_cu_ptr_complex3 (u),
2329 ffebld_constant_integer1 (ffebld_conter (l)));
2330 break;
2331 #endif
2332
2333 #if FFETARGET_okINTEGER2
2334 case FFEINFO_kindtypeINTEGER2:
2335 error = ffetarget_convert_complex3_integer2
2336 (ffebld_cu_ptr_complex3 (u),
2337 ffebld_constant_integer2 (ffebld_conter (l)));
2338 break;
2339 #endif
2340
2341 #if FFETARGET_okINTEGER3
2342 case FFEINFO_kindtypeINTEGER3:
2343 error = ffetarget_convert_complex3_integer3
2344 (ffebld_cu_ptr_complex3 (u),
2345 ffebld_constant_integer3 (ffebld_conter (l)));
2346 break;
2347 #endif
2348
2349 #if FFETARGET_okINTEGER4
2350 case FFEINFO_kindtypeINTEGER4:
2351 error = ffetarget_convert_complex3_integer4
2352 (ffebld_cu_ptr_complex3 (u),
2353 ffebld_constant_integer4 (ffebld_conter (l)));
2354 break;
2355 #endif
2356
2357 default:
2358 assert ("COMPLEX3/INTEGER bad source kind type" == NULL);
2359 break;
2360 }
2361 break;
2362
2363 case FFEINFO_basictypeREAL:
2364 switch (ffeinfo_kindtype (ffebld_info (l)))
2365 {
2366 #if FFETARGET_okREAL1
2367 case FFEINFO_kindtypeREAL1:
2368 error = ffetarget_convert_complex3_real1
2369 (ffebld_cu_ptr_complex3 (u),
2370 ffebld_constant_real1 (ffebld_conter (l)));
2371 break;
2372 #endif
2373
2374 #if FFETARGET_okREAL2
2375 case FFEINFO_kindtypeREAL2:
2376 error = ffetarget_convert_complex3_real2
2377 (ffebld_cu_ptr_complex3 (u),
2378 ffebld_constant_real2 (ffebld_conter (l)));
2379 break;
2380 #endif
2381
2382 #if FFETARGET_okREAL3
2383 case FFEINFO_kindtypeREAL3:
2384 error = ffetarget_convert_complex3_real3
2385 (ffebld_cu_ptr_complex3 (u),
2386 ffebld_constant_real3 (ffebld_conter (l)));
2387 break;
2388 #endif
2389
2390 default:
2391 assert ("COMPLEX3/REAL bad source kind type" == NULL);
2392 break;
2393 }
2394 break;
2395
2396 case FFEINFO_basictypeCOMPLEX:
2397 switch (ffeinfo_kindtype (ffebld_info (l)))
2398 {
2399 #if FFETARGET_okCOMPLEX1
2400 case FFEINFO_kindtypeREAL1:
2401 error = ffetarget_convert_complex3_complex1
2402 (ffebld_cu_ptr_complex3 (u),
2403 ffebld_constant_complex1 (ffebld_conter (l)));
2404 break;
2405 #endif
2406
2407 #if FFETARGET_okCOMPLEX2
2408 case FFEINFO_kindtypeREAL2:
2409 error = ffetarget_convert_complex3_complex2
2410 (ffebld_cu_ptr_complex3 (u),
2411 ffebld_constant_complex2 (ffebld_conter (l)));
2412 break;
2413 #endif
2414
2415 default:
2416 assert ("COMPLEX3/COMPLEX bad source kind type" == NULL);
2417 break;
2418 }
2419 break;
2420
2421 case FFEINFO_basictypeCHARACTER:
2422 error = ffetarget_convert_complex3_character1
2423 (ffebld_cu_ptr_complex3 (u),
2424 ffebld_constant_character1 (ffebld_conter (l)));
2425 break;
2426
2427 case FFEINFO_basictypeHOLLERITH:
2428 error = ffetarget_convert_complex3_hollerith
2429 (ffebld_cu_ptr_complex3 (u),
2430 ffebld_constant_hollerith (ffebld_conter (l)));
2431 break;
2432
2433 case FFEINFO_basictypeTYPELESS:
2434 error = ffetarget_convert_complex3_typeless
2435 (ffebld_cu_ptr_complex3 (u),
2436 ffebld_constant_typeless (ffebld_conter (l)));
2437 break;
2438
2439 default:
2440 assert ("COMPLEX3 bad type" == NULL);
2441 break;
2442 }
2443
2444 /* If conversion operation is not implemented, return original expr. */
2445 if (error == FFEBAD_NOCANDO)
2446 return expr;
2447
2448 expr = ffebld_new_conter_with_orig
2449 (ffebld_constant_new_complex3_val
2450 (ffebld_cu_val_complex3 (u)), expr);
2451 break;
2452 #endif
2453
2454 default:
2455 assert ("bad complex kind type" == NULL);
2456 break;
2457 }
2458 break;
2459
2460 case FFEINFO_basictypeCHARACTER:
2461 if ((sz = ffebld_size (expr)) == FFETARGET_charactersizeNONE)
2462 return expr;
2463 kt = ffeinfo_kindtype (ffebld_info (expr));
2464 switch (kt)
2465 {
2466 #if FFETARGET_okCHARACTER1
2467 case FFEINFO_kindtypeCHARACTER1:
2468 switch (ffeinfo_basictype (ffebld_info (l)))
2469 {
2470 case FFEINFO_basictypeCHARACTER:
2471 if ((sz2 = ffebld_size (l)) == FFETARGET_charactersizeNONE)
2472 return expr;
2473 assert (kt == ffeinfo_kindtype (ffebld_info (l)));
2474 assert (sz2 == ffetarget_length_character1
2475 (ffebld_constant_character1
2476 (ffebld_conter (l))));
2477 error
2478 = ffetarget_convert_character1_character1
2479 (ffebld_cu_ptr_character1 (u), sz,
2480 ffebld_constant_character1 (ffebld_conter (l)),
2481 ffebld_constant_pool ());
2482 break;
2483
2484 case FFEINFO_basictypeINTEGER:
2485 switch (ffeinfo_kindtype (ffebld_info (l)))
2486 {
2487 #if FFETARGET_okINTEGER1
2488 case FFEINFO_kindtypeINTEGER1:
2489 error
2490 = ffetarget_convert_character1_integer1
2491 (ffebld_cu_ptr_character1 (u),
2492 sz,
2493 ffebld_constant_integer1 (ffebld_conter (l)),
2494 ffebld_constant_pool ());
2495 break;
2496 #endif
2497
2498 #if FFETARGET_okINTEGER2
2499 case FFEINFO_kindtypeINTEGER2:
2500 error
2501 = ffetarget_convert_character1_integer2
2502 (ffebld_cu_ptr_character1 (u),
2503 sz,
2504 ffebld_constant_integer2 (ffebld_conter (l)),
2505 ffebld_constant_pool ());
2506 break;
2507 #endif
2508
2509 #if FFETARGET_okINTEGER3
2510 case FFEINFO_kindtypeINTEGER3:
2511 error
2512 = ffetarget_convert_character1_integer3
2513 (ffebld_cu_ptr_character1 (u),
2514 sz,
2515 ffebld_constant_integer3 (ffebld_conter (l)),
2516 ffebld_constant_pool ());
2517 break;
2518 #endif
2519
2520 #if FFETARGET_okINTEGER4
2521 case FFEINFO_kindtypeINTEGER4:
2522 error
2523 = ffetarget_convert_character1_integer4
2524 (ffebld_cu_ptr_character1 (u),
2525 sz,
2526 ffebld_constant_integer4 (ffebld_conter (l)),
2527 ffebld_constant_pool ());
2528 break;
2529 #endif
2530
2531 default:
2532 assert ("CHARACTER1/INTEGER bad source kind type" == NULL);
2533 break;
2534 }
2535 break;
2536
2537 case FFEINFO_basictypeLOGICAL:
2538 switch (ffeinfo_kindtype (ffebld_info (l)))
2539 {
2540 #if FFETARGET_okLOGICAL1
2541 case FFEINFO_kindtypeLOGICAL1:
2542 error
2543 = ffetarget_convert_character1_logical1
2544 (ffebld_cu_ptr_character1 (u),
2545 sz,
2546 ffebld_constant_logical1 (ffebld_conter (l)),
2547 ffebld_constant_pool ());
2548 break;
2549 #endif
2550
2551 #if FFETARGET_okLOGICAL2
2552 case FFEINFO_kindtypeLOGICAL2:
2553 error
2554 = ffetarget_convert_character1_logical2
2555 (ffebld_cu_ptr_character1 (u),
2556 sz,
2557 ffebld_constant_logical2 (ffebld_conter (l)),
2558 ffebld_constant_pool ());
2559 break;
2560 #endif
2561
2562 #if FFETARGET_okLOGICAL3
2563 case FFEINFO_kindtypeLOGICAL3:
2564 error
2565 = ffetarget_convert_character1_logical3
2566 (ffebld_cu_ptr_character1 (u),
2567 sz,
2568 ffebld_constant_logical3 (ffebld_conter (l)),
2569 ffebld_constant_pool ());
2570 break;
2571 #endif
2572
2573 #if FFETARGET_okLOGICAL4
2574 case FFEINFO_kindtypeLOGICAL4:
2575 error
2576 = ffetarget_convert_character1_logical4
2577 (ffebld_cu_ptr_character1 (u),
2578 sz,
2579 ffebld_constant_logical4 (ffebld_conter (l)),
2580 ffebld_constant_pool ());
2581 break;
2582 #endif
2583
2584 default:
2585 assert ("CHARACTER1/LOGICAL bad source kind type" == NULL);
2586 break;
2587 }
2588 break;
2589
2590 case FFEINFO_basictypeHOLLERITH:
2591 error
2592 = ffetarget_convert_character1_hollerith
2593 (ffebld_cu_ptr_character1 (u),
2594 sz,
2595 ffebld_constant_hollerith (ffebld_conter (l)),
2596 ffebld_constant_pool ());
2597 break;
2598
2599 case FFEINFO_basictypeTYPELESS:
2600 error
2601 = ffetarget_convert_character1_typeless
2602 (ffebld_cu_ptr_character1 (u),
2603 sz,
2604 ffebld_constant_typeless (ffebld_conter (l)),
2605 ffebld_constant_pool ());
2606 break;
2607
2608 default:
2609 assert ("CHARACTER1 bad type" == NULL);
2610 }
2611
2612 expr
2613 = ffebld_new_conter_with_orig
2614 (ffebld_constant_new_character1_val
2615 (ffebld_cu_val_character1 (u)),
2616 expr);
2617 break;
2618 #endif
2619
2620 default:
2621 assert ("bad character kind type" == NULL);
2622 break;
2623 }
2624 break;
2625
2626 default:
2627 assert ("bad type" == NULL);
2628 return expr;
2629 }
2630
2631 ffebld_set_info (expr, ffeinfo_new
2632 (bt,
2633 kt,
2634 0,
2635 FFEINFO_kindENTITY,
2636 FFEINFO_whereCONSTANT,
2637 sz));
2638
2639 if ((error != FFEBAD)
2640 && ffebad_start (error))
2641 {
2642 assert (t != NULL);
2643 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
2644 ffebad_finish ();
2645 }
2646
2647 return expr;
2648 }
2649
2650 /* ffeexpr_collapse_paren -- Collapse paren expr
2651
2652 ffebld expr;
2653 ffelexToken token;
2654 expr = ffeexpr_collapse_paren(expr,token);
2655
2656 If the result of the expr is a constant, replaces the expr with the
2657 computed constant. */
2658
2659 ffebld
2660 ffeexpr_collapse_paren (ffebld expr, ffelexToken t UNUSED)
2661 {
2662 ffebld r;
2663 ffeinfoBasictype bt;
2664 ffeinfoKindtype kt;
2665 ffetargetCharacterSize len;
2666
2667 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
2668 return expr;
2669
2670 r = ffebld_left (expr);
2671
2672 if (ffebld_op (r) != FFEBLD_opCONTER)
2673 return expr;
2674
2675 bt = ffeinfo_basictype (ffebld_info (r));
2676 kt = ffeinfo_kindtype (ffebld_info (r));
2677 len = ffebld_size (r);
2678
2679 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
2680 expr);
2681
2682 ffebld_set_info (expr, ffeinfo_new
2683 (bt,
2684 kt,
2685 0,
2686 FFEINFO_kindENTITY,
2687 FFEINFO_whereCONSTANT,
2688 len));
2689
2690 return expr;
2691 }
2692
2693 /* ffeexpr_collapse_uplus -- Collapse uplus expr
2694
2695 ffebld expr;
2696 ffelexToken token;
2697 expr = ffeexpr_collapse_uplus(expr,token);
2698
2699 If the result of the expr is a constant, replaces the expr with the
2700 computed constant. */
2701
2702 ffebld
2703 ffeexpr_collapse_uplus (ffebld expr, ffelexToken t UNUSED)
2704 {
2705 ffebld r;
2706 ffeinfoBasictype bt;
2707 ffeinfoKindtype kt;
2708 ffetargetCharacterSize len;
2709
2710 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
2711 return expr;
2712
2713 r = ffebld_left (expr);
2714
2715 if (ffebld_op (r) != FFEBLD_opCONTER)
2716 return expr;
2717
2718 bt = ffeinfo_basictype (ffebld_info (r));
2719 kt = ffeinfo_kindtype (ffebld_info (r));
2720 len = ffebld_size (r);
2721
2722 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
2723 expr);
2724
2725 ffebld_set_info (expr, ffeinfo_new
2726 (bt,
2727 kt,
2728 0,
2729 FFEINFO_kindENTITY,
2730 FFEINFO_whereCONSTANT,
2731 len));
2732
2733 return expr;
2734 }
2735
2736 /* ffeexpr_collapse_uminus -- Collapse uminus expr
2737
2738 ffebld expr;
2739 ffelexToken token;
2740 expr = ffeexpr_collapse_uminus(expr,token);
2741
2742 If the result of the expr is a constant, replaces the expr with the
2743 computed constant. */
2744
2745 ffebld
2746 ffeexpr_collapse_uminus (ffebld expr, ffelexToken t)
2747 {
2748 ffebad error = FFEBAD;
2749 ffebld r;
2750 ffebldConstantUnion u;
2751 ffeinfoBasictype bt;
2752 ffeinfoKindtype kt;
2753
2754 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
2755 return expr;
2756
2757 r = ffebld_left (expr);
2758
2759 if (ffebld_op (r) != FFEBLD_opCONTER)
2760 return expr;
2761
2762 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
2763 {
2764 case FFEINFO_basictypeANY:
2765 return expr;
2766
2767 case FFEINFO_basictypeINTEGER:
2768 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2769 {
2770 #if FFETARGET_okINTEGER1
2771 case FFEINFO_kindtypeINTEGER1:
2772 error = ffetarget_uminus_integer1 (ffebld_cu_ptr_integer1 (u),
2773 ffebld_constant_integer1 (ffebld_conter (r)));
2774 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
2775 (ffebld_cu_val_integer1 (u)), expr);
2776 break;
2777 #endif
2778
2779 #if FFETARGET_okINTEGER2
2780 case FFEINFO_kindtypeINTEGER2:
2781 error = ffetarget_uminus_integer2 (ffebld_cu_ptr_integer2 (u),
2782 ffebld_constant_integer2 (ffebld_conter (r)));
2783 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
2784 (ffebld_cu_val_integer2 (u)), expr);
2785 break;
2786 #endif
2787
2788 #if FFETARGET_okINTEGER3
2789 case FFEINFO_kindtypeINTEGER3:
2790 error = ffetarget_uminus_integer3 (ffebld_cu_ptr_integer3 (u),
2791 ffebld_constant_integer3 (ffebld_conter (r)));
2792 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
2793 (ffebld_cu_val_integer3 (u)), expr);
2794 break;
2795 #endif
2796
2797 #if FFETARGET_okINTEGER4
2798 case FFEINFO_kindtypeINTEGER4:
2799 error = ffetarget_uminus_integer4 (ffebld_cu_ptr_integer4 (u),
2800 ffebld_constant_integer4 (ffebld_conter (r)));
2801 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
2802 (ffebld_cu_val_integer4 (u)), expr);
2803 break;
2804 #endif
2805
2806 default:
2807 assert ("bad integer kind type" == NULL);
2808 break;
2809 }
2810 break;
2811
2812 case FFEINFO_basictypeREAL:
2813 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2814 {
2815 #if FFETARGET_okREAL1
2816 case FFEINFO_kindtypeREAL1:
2817 error = ffetarget_uminus_real1 (ffebld_cu_ptr_real1 (u),
2818 ffebld_constant_real1 (ffebld_conter (r)));
2819 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
2820 (ffebld_cu_val_real1 (u)), expr);
2821 break;
2822 #endif
2823
2824 #if FFETARGET_okREAL2
2825 case FFEINFO_kindtypeREAL2:
2826 error = ffetarget_uminus_real2 (ffebld_cu_ptr_real2 (u),
2827 ffebld_constant_real2 (ffebld_conter (r)));
2828 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
2829 (ffebld_cu_val_real2 (u)), expr);
2830 break;
2831 #endif
2832
2833 #if FFETARGET_okREAL3
2834 case FFEINFO_kindtypeREAL3:
2835 error = ffetarget_uminus_real3 (ffebld_cu_ptr_real3 (u),
2836 ffebld_constant_real3 (ffebld_conter (r)));
2837 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
2838 (ffebld_cu_val_real3 (u)), expr);
2839 break;
2840 #endif
2841
2842 default:
2843 assert ("bad real kind type" == NULL);
2844 break;
2845 }
2846 break;
2847
2848 case FFEINFO_basictypeCOMPLEX:
2849 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2850 {
2851 #if FFETARGET_okCOMPLEX1
2852 case FFEINFO_kindtypeREAL1:
2853 error = ffetarget_uminus_complex1 (ffebld_cu_ptr_complex1 (u),
2854 ffebld_constant_complex1 (ffebld_conter (r)));
2855 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
2856 (ffebld_cu_val_complex1 (u)), expr);
2857 break;
2858 #endif
2859
2860 #if FFETARGET_okCOMPLEX2
2861 case FFEINFO_kindtypeREAL2:
2862 error = ffetarget_uminus_complex2 (ffebld_cu_ptr_complex2 (u),
2863 ffebld_constant_complex2 (ffebld_conter (r)));
2864 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
2865 (ffebld_cu_val_complex2 (u)), expr);
2866 break;
2867 #endif
2868
2869 #if FFETARGET_okCOMPLEX3
2870 case FFEINFO_kindtypeREAL3:
2871 error = ffetarget_uminus_complex3 (ffebld_cu_ptr_complex3 (u),
2872 ffebld_constant_complex3 (ffebld_conter (r)));
2873 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
2874 (ffebld_cu_val_complex3 (u)), expr);
2875 break;
2876 #endif
2877
2878 default:
2879 assert ("bad complex kind type" == NULL);
2880 break;
2881 }
2882 break;
2883
2884 default:
2885 assert ("bad type" == NULL);
2886 return expr;
2887 }
2888
2889 ffebld_set_info (expr, ffeinfo_new
2890 (bt,
2891 kt,
2892 0,
2893 FFEINFO_kindENTITY,
2894 FFEINFO_whereCONSTANT,
2895 FFETARGET_charactersizeNONE));
2896
2897 if ((error != FFEBAD)
2898 && ffebad_start (error))
2899 {
2900 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
2901 ffebad_finish ();
2902 }
2903
2904 return expr;
2905 }
2906
2907 /* ffeexpr_collapse_not -- Collapse not expr
2908
2909 ffebld expr;
2910 ffelexToken token;
2911 expr = ffeexpr_collapse_not(expr,token);
2912
2913 If the result of the expr is a constant, replaces the expr with the
2914 computed constant. */
2915
2916 ffebld
2917 ffeexpr_collapse_not (ffebld expr, ffelexToken t)
2918 {
2919 ffebad error = FFEBAD;
2920 ffebld r;
2921 ffebldConstantUnion u;
2922 ffeinfoBasictype bt;
2923 ffeinfoKindtype kt;
2924
2925 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
2926 return expr;
2927
2928 r = ffebld_left (expr);
2929
2930 if (ffebld_op (r) != FFEBLD_opCONTER)
2931 return expr;
2932
2933 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
2934 {
2935 case FFEINFO_basictypeANY:
2936 return expr;
2937
2938 case FFEINFO_basictypeINTEGER:
2939 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2940 {
2941 #if FFETARGET_okINTEGER1
2942 case FFEINFO_kindtypeINTEGER1:
2943 error = ffetarget_not_integer1 (ffebld_cu_ptr_integer1 (u),
2944 ffebld_constant_integer1 (ffebld_conter (r)));
2945 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
2946 (ffebld_cu_val_integer1 (u)), expr);
2947 break;
2948 #endif
2949
2950 #if FFETARGET_okINTEGER2
2951 case FFEINFO_kindtypeINTEGER2:
2952 error = ffetarget_not_integer2 (ffebld_cu_ptr_integer2 (u),
2953 ffebld_constant_integer2 (ffebld_conter (r)));
2954 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
2955 (ffebld_cu_val_integer2 (u)), expr);
2956 break;
2957 #endif
2958
2959 #if FFETARGET_okINTEGER3
2960 case FFEINFO_kindtypeINTEGER3:
2961 error = ffetarget_not_integer3 (ffebld_cu_ptr_integer3 (u),
2962 ffebld_constant_integer3 (ffebld_conter (r)));
2963 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
2964 (ffebld_cu_val_integer3 (u)), expr);
2965 break;
2966 #endif
2967
2968 #if FFETARGET_okINTEGER4
2969 case FFEINFO_kindtypeINTEGER4:
2970 error = ffetarget_not_integer4 (ffebld_cu_ptr_integer4 (u),
2971 ffebld_constant_integer4 (ffebld_conter (r)));
2972 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
2973 (ffebld_cu_val_integer4 (u)), expr);
2974 break;
2975 #endif
2976
2977 default:
2978 assert ("bad integer kind type" == NULL);
2979 break;
2980 }
2981 break;
2982
2983 case FFEINFO_basictypeLOGICAL:
2984 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2985 {
2986 #if FFETARGET_okLOGICAL1
2987 case FFEINFO_kindtypeLOGICAL1:
2988 error = ffetarget_not_logical1 (ffebld_cu_ptr_logical1 (u),
2989 ffebld_constant_logical1 (ffebld_conter (r)));
2990 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
2991 (ffebld_cu_val_logical1 (u)), expr);
2992 break;
2993 #endif
2994
2995 #if FFETARGET_okLOGICAL2
2996 case FFEINFO_kindtypeLOGICAL2:
2997 error = ffetarget_not_logical2 (ffebld_cu_ptr_logical2 (u),
2998 ffebld_constant_logical2 (ffebld_conter (r)));
2999 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
3000 (ffebld_cu_val_logical2 (u)), expr);
3001 break;
3002 #endif
3003
3004 #if FFETARGET_okLOGICAL3
3005 case FFEINFO_kindtypeLOGICAL3:
3006 error = ffetarget_not_logical3 (ffebld_cu_ptr_logical3 (u),
3007 ffebld_constant_logical3 (ffebld_conter (r)));
3008 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
3009 (ffebld_cu_val_logical3 (u)), expr);
3010 break;
3011 #endif
3012
3013 #if FFETARGET_okLOGICAL4
3014 case FFEINFO_kindtypeLOGICAL4:
3015 error = ffetarget_not_logical4 (ffebld_cu_ptr_logical4 (u),
3016 ffebld_constant_logical4 (ffebld_conter (r)));
3017 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
3018 (ffebld_cu_val_logical4 (u)), expr);
3019 break;
3020 #endif
3021
3022 default:
3023 assert ("bad logical kind type" == NULL);
3024 break;
3025 }
3026 break;
3027
3028 default:
3029 assert ("bad type" == NULL);
3030 return expr;
3031 }
3032
3033 ffebld_set_info (expr, ffeinfo_new
3034 (bt,
3035 kt,
3036 0,
3037 FFEINFO_kindENTITY,
3038 FFEINFO_whereCONSTANT,
3039 FFETARGET_charactersizeNONE));
3040
3041 if ((error != FFEBAD)
3042 && ffebad_start (error))
3043 {
3044 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3045 ffebad_finish ();
3046 }
3047
3048 return expr;
3049 }
3050
3051 /* ffeexpr_collapse_add -- Collapse add expr
3052
3053 ffebld expr;
3054 ffelexToken token;
3055 expr = ffeexpr_collapse_add(expr,token);
3056
3057 If the result of the expr is a constant, replaces the expr with the
3058 computed constant. */
3059
3060 ffebld
3061 ffeexpr_collapse_add (ffebld expr, ffelexToken t)
3062 {
3063 ffebad error = FFEBAD;
3064 ffebld l;
3065 ffebld r;
3066 ffebldConstantUnion u;
3067 ffeinfoBasictype bt;
3068 ffeinfoKindtype kt;
3069
3070 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3071 return expr;
3072
3073 l = ffebld_left (expr);
3074 r = ffebld_right (expr);
3075
3076 if (ffebld_op (l) != FFEBLD_opCONTER)
3077 return expr;
3078 if (ffebld_op (r) != FFEBLD_opCONTER)
3079 return expr;
3080
3081 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3082 {
3083 case FFEINFO_basictypeANY:
3084 return expr;
3085
3086 case FFEINFO_basictypeINTEGER:
3087 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3088 {
3089 #if FFETARGET_okINTEGER1
3090 case FFEINFO_kindtypeINTEGER1:
3091 error = ffetarget_add_integer1 (ffebld_cu_ptr_integer1 (u),
3092 ffebld_constant_integer1 (ffebld_conter (l)),
3093 ffebld_constant_integer1 (ffebld_conter (r)));
3094 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3095 (ffebld_cu_val_integer1 (u)), expr);
3096 break;
3097 #endif
3098
3099 #if FFETARGET_okINTEGER2
3100 case FFEINFO_kindtypeINTEGER2:
3101 error = ffetarget_add_integer2 (ffebld_cu_ptr_integer2 (u),
3102 ffebld_constant_integer2 (ffebld_conter (l)),
3103 ffebld_constant_integer2 (ffebld_conter (r)));
3104 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3105 (ffebld_cu_val_integer2 (u)), expr);
3106 break;
3107 #endif
3108
3109 #if FFETARGET_okINTEGER3
3110 case FFEINFO_kindtypeINTEGER3:
3111 error = ffetarget_add_integer3 (ffebld_cu_ptr_integer3 (u),
3112 ffebld_constant_integer3 (ffebld_conter (l)),
3113 ffebld_constant_integer3 (ffebld_conter (r)));
3114 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3115 (ffebld_cu_val_integer3 (u)), expr);
3116 break;
3117 #endif
3118
3119 #if FFETARGET_okINTEGER4
3120 case FFEINFO_kindtypeINTEGER4:
3121 error = ffetarget_add_integer4 (ffebld_cu_ptr_integer4 (u),
3122 ffebld_constant_integer4 (ffebld_conter (l)),
3123 ffebld_constant_integer4 (ffebld_conter (r)));
3124 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3125 (ffebld_cu_val_integer4 (u)), expr);
3126 break;
3127 #endif
3128
3129 default:
3130 assert ("bad integer kind type" == NULL);
3131 break;
3132 }
3133 break;
3134
3135 case FFEINFO_basictypeREAL:
3136 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3137 {
3138 #if FFETARGET_okREAL1
3139 case FFEINFO_kindtypeREAL1:
3140 error = ffetarget_add_real1 (ffebld_cu_ptr_real1 (u),
3141 ffebld_constant_real1 (ffebld_conter (l)),
3142 ffebld_constant_real1 (ffebld_conter (r)));
3143 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3144 (ffebld_cu_val_real1 (u)), expr);
3145 break;
3146 #endif
3147
3148 #if FFETARGET_okREAL2
3149 case FFEINFO_kindtypeREAL2:
3150 error = ffetarget_add_real2 (ffebld_cu_ptr_real2 (u),
3151 ffebld_constant_real2 (ffebld_conter (l)),
3152 ffebld_constant_real2 (ffebld_conter (r)));
3153 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3154 (ffebld_cu_val_real2 (u)), expr);
3155 break;
3156 #endif
3157
3158 #if FFETARGET_okREAL3
3159 case FFEINFO_kindtypeREAL3:
3160 error = ffetarget_add_real3 (ffebld_cu_ptr_real3 (u),
3161 ffebld_constant_real3 (ffebld_conter (l)),
3162 ffebld_constant_real3 (ffebld_conter (r)));
3163 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3164 (ffebld_cu_val_real3 (u)), expr);
3165 break;
3166 #endif
3167
3168 default:
3169 assert ("bad real kind type" == NULL);
3170 break;
3171 }
3172 break;
3173
3174 case FFEINFO_basictypeCOMPLEX:
3175 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3176 {
3177 #if FFETARGET_okCOMPLEX1
3178 case FFEINFO_kindtypeREAL1:
3179 error = ffetarget_add_complex1 (ffebld_cu_ptr_complex1 (u),
3180 ffebld_constant_complex1 (ffebld_conter (l)),
3181 ffebld_constant_complex1 (ffebld_conter (r)));
3182 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3183 (ffebld_cu_val_complex1 (u)), expr);
3184 break;
3185 #endif
3186
3187 #if FFETARGET_okCOMPLEX2
3188 case FFEINFO_kindtypeREAL2:
3189 error = ffetarget_add_complex2 (ffebld_cu_ptr_complex2 (u),
3190 ffebld_constant_complex2 (ffebld_conter (l)),
3191 ffebld_constant_complex2 (ffebld_conter (r)));
3192 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3193 (ffebld_cu_val_complex2 (u)), expr);
3194 break;
3195 #endif
3196
3197 #if FFETARGET_okCOMPLEX3
3198 case FFEINFO_kindtypeREAL3:
3199 error = ffetarget_add_complex3 (ffebld_cu_ptr_complex3 (u),
3200 ffebld_constant_complex3 (ffebld_conter (l)),
3201 ffebld_constant_complex3 (ffebld_conter (r)));
3202 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3203 (ffebld_cu_val_complex3 (u)), expr);
3204 break;
3205 #endif
3206
3207 default:
3208 assert ("bad complex kind type" == NULL);
3209 break;
3210 }
3211 break;
3212
3213 default:
3214 assert ("bad type" == NULL);
3215 return expr;
3216 }
3217
3218 ffebld_set_info (expr, ffeinfo_new
3219 (bt,
3220 kt,
3221 0,
3222 FFEINFO_kindENTITY,
3223 FFEINFO_whereCONSTANT,
3224 FFETARGET_charactersizeNONE));
3225
3226 if ((error != FFEBAD)
3227 && ffebad_start (error))
3228 {
3229 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3230 ffebad_finish ();
3231 }
3232
3233 return expr;
3234 }
3235
3236 /* ffeexpr_collapse_subtract -- Collapse subtract expr
3237
3238 ffebld expr;
3239 ffelexToken token;
3240 expr = ffeexpr_collapse_subtract(expr,token);
3241
3242 If the result of the expr is a constant, replaces the expr with the
3243 computed constant. */
3244
3245 ffebld
3246 ffeexpr_collapse_subtract (ffebld expr, ffelexToken t)
3247 {
3248 ffebad error = FFEBAD;
3249 ffebld l;
3250 ffebld r;
3251 ffebldConstantUnion u;
3252 ffeinfoBasictype bt;
3253 ffeinfoKindtype kt;
3254
3255 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3256 return expr;
3257
3258 l = ffebld_left (expr);
3259 r = ffebld_right (expr);
3260
3261 if (ffebld_op (l) != FFEBLD_opCONTER)
3262 return expr;
3263 if (ffebld_op (r) != FFEBLD_opCONTER)
3264 return expr;
3265
3266 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3267 {
3268 case FFEINFO_basictypeANY:
3269 return expr;
3270
3271 case FFEINFO_basictypeINTEGER:
3272 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3273 {
3274 #if FFETARGET_okINTEGER1
3275 case FFEINFO_kindtypeINTEGER1:
3276 error = ffetarget_subtract_integer1 (ffebld_cu_ptr_integer1 (u),
3277 ffebld_constant_integer1 (ffebld_conter (l)),
3278 ffebld_constant_integer1 (ffebld_conter (r)));
3279 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3280 (ffebld_cu_val_integer1 (u)), expr);
3281 break;
3282 #endif
3283
3284 #if FFETARGET_okINTEGER2
3285 case FFEINFO_kindtypeINTEGER2:
3286 error = ffetarget_subtract_integer2 (ffebld_cu_ptr_integer2 (u),
3287 ffebld_constant_integer2 (ffebld_conter (l)),
3288 ffebld_constant_integer2 (ffebld_conter (r)));
3289 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3290 (ffebld_cu_val_integer2 (u)), expr);
3291 break;
3292 #endif
3293
3294 #if FFETARGET_okINTEGER3
3295 case FFEINFO_kindtypeINTEGER3:
3296 error = ffetarget_subtract_integer3 (ffebld_cu_ptr_integer3 (u),
3297 ffebld_constant_integer3 (ffebld_conter (l)),
3298 ffebld_constant_integer3 (ffebld_conter (r)));
3299 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3300 (ffebld_cu_val_integer3 (u)), expr);
3301 break;
3302 #endif
3303
3304 #if FFETARGET_okINTEGER4
3305 case FFEINFO_kindtypeINTEGER4:
3306 error = ffetarget_subtract_integer4 (ffebld_cu_ptr_integer4 (u),
3307 ffebld_constant_integer4 (ffebld_conter (l)),
3308 ffebld_constant_integer4 (ffebld_conter (r)));
3309 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3310 (ffebld_cu_val_integer4 (u)), expr);
3311 break;
3312 #endif
3313
3314 default:
3315 assert ("bad integer kind type" == NULL);
3316 break;
3317 }
3318 break;
3319
3320 case FFEINFO_basictypeREAL:
3321 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3322 {
3323 #if FFETARGET_okREAL1
3324 case FFEINFO_kindtypeREAL1:
3325 error = ffetarget_subtract_real1 (ffebld_cu_ptr_real1 (u),
3326 ffebld_constant_real1 (ffebld_conter (l)),
3327 ffebld_constant_real1 (ffebld_conter (r)));
3328 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3329 (ffebld_cu_val_real1 (u)), expr);
3330 break;
3331 #endif
3332
3333 #if FFETARGET_okREAL2
3334 case FFEINFO_kindtypeREAL2:
3335 error = ffetarget_subtract_real2 (ffebld_cu_ptr_real2 (u),
3336 ffebld_constant_real2 (ffebld_conter (l)),
3337 ffebld_constant_real2 (ffebld_conter (r)));
3338 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3339 (ffebld_cu_val_real2 (u)), expr);
3340 break;
3341 #endif
3342
3343 #if FFETARGET_okREAL3
3344 case FFEINFO_kindtypeREAL3:
3345 error = ffetarget_subtract_real3 (ffebld_cu_ptr_real3 (u),
3346 ffebld_constant_real3 (ffebld_conter (l)),
3347 ffebld_constant_real3 (ffebld_conter (r)));
3348 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3349 (ffebld_cu_val_real3 (u)), expr);
3350 break;
3351 #endif
3352
3353 default:
3354 assert ("bad real kind type" == NULL);
3355 break;
3356 }
3357 break;
3358
3359 case FFEINFO_basictypeCOMPLEX:
3360 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3361 {
3362 #if FFETARGET_okCOMPLEX1
3363 case FFEINFO_kindtypeREAL1:
3364 error = ffetarget_subtract_complex1 (ffebld_cu_ptr_complex1 (u),
3365 ffebld_constant_complex1 (ffebld_conter (l)),
3366 ffebld_constant_complex1 (ffebld_conter (r)));
3367 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3368 (ffebld_cu_val_complex1 (u)), expr);
3369 break;
3370 #endif
3371
3372 #if FFETARGET_okCOMPLEX2
3373 case FFEINFO_kindtypeREAL2:
3374 error = ffetarget_subtract_complex2 (ffebld_cu_ptr_complex2 (u),
3375 ffebld_constant_complex2 (ffebld_conter (l)),
3376 ffebld_constant_complex2 (ffebld_conter (r)));
3377 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3378 (ffebld_cu_val_complex2 (u)), expr);
3379 break;
3380 #endif
3381
3382 #if FFETARGET_okCOMPLEX3
3383 case FFEINFO_kindtypeREAL3:
3384 error = ffetarget_subtract_complex3 (ffebld_cu_ptr_complex3 (u),
3385 ffebld_constant_complex3 (ffebld_conter (l)),
3386 ffebld_constant_complex3 (ffebld_conter (r)));
3387 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3388 (ffebld_cu_val_complex3 (u)), expr);
3389 break;
3390 #endif
3391
3392 default:
3393 assert ("bad complex kind type" == NULL);
3394 break;
3395 }
3396 break;
3397
3398 default:
3399 assert ("bad type" == NULL);
3400 return expr;
3401 }
3402
3403 ffebld_set_info (expr, ffeinfo_new
3404 (bt,
3405 kt,
3406 0,
3407 FFEINFO_kindENTITY,
3408 FFEINFO_whereCONSTANT,
3409 FFETARGET_charactersizeNONE));
3410
3411 if ((error != FFEBAD)
3412 && ffebad_start (error))
3413 {
3414 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3415 ffebad_finish ();
3416 }
3417
3418 return expr;
3419 }
3420
3421 /* ffeexpr_collapse_multiply -- Collapse multiply expr
3422
3423 ffebld expr;
3424 ffelexToken token;
3425 expr = ffeexpr_collapse_multiply(expr,token);
3426
3427 If the result of the expr is a constant, replaces the expr with the
3428 computed constant. */
3429
3430 ffebld
3431 ffeexpr_collapse_multiply (ffebld expr, ffelexToken t)
3432 {
3433 ffebad error = FFEBAD;
3434 ffebld l;
3435 ffebld r;
3436 ffebldConstantUnion u;
3437 ffeinfoBasictype bt;
3438 ffeinfoKindtype kt;
3439
3440 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3441 return expr;
3442
3443 l = ffebld_left (expr);
3444 r = ffebld_right (expr);
3445
3446 if (ffebld_op (l) != FFEBLD_opCONTER)
3447 return expr;
3448 if (ffebld_op (r) != FFEBLD_opCONTER)
3449 return expr;
3450
3451 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3452 {
3453 case FFEINFO_basictypeANY:
3454 return expr;
3455
3456 case FFEINFO_basictypeINTEGER:
3457 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3458 {
3459 #if FFETARGET_okINTEGER1
3460 case FFEINFO_kindtypeINTEGER1:
3461 error = ffetarget_multiply_integer1 (ffebld_cu_ptr_integer1 (u),
3462 ffebld_constant_integer1 (ffebld_conter (l)),
3463 ffebld_constant_integer1 (ffebld_conter (r)));
3464 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3465 (ffebld_cu_val_integer1 (u)), expr);
3466 break;
3467 #endif
3468
3469 #if FFETARGET_okINTEGER2
3470 case FFEINFO_kindtypeINTEGER2:
3471 error = ffetarget_multiply_integer2 (ffebld_cu_ptr_integer2 (u),
3472 ffebld_constant_integer2 (ffebld_conter (l)),
3473 ffebld_constant_integer2 (ffebld_conter (r)));
3474 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3475 (ffebld_cu_val_integer2 (u)), expr);
3476 break;
3477 #endif
3478
3479 #if FFETARGET_okINTEGER3
3480 case FFEINFO_kindtypeINTEGER3:
3481 error = ffetarget_multiply_integer3 (ffebld_cu_ptr_integer3 (u),
3482 ffebld_constant_integer3 (ffebld_conter (l)),
3483 ffebld_constant_integer3 (ffebld_conter (r)));
3484 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3485 (ffebld_cu_val_integer3 (u)), expr);
3486 break;
3487 #endif
3488
3489 #if FFETARGET_okINTEGER4
3490 case FFEINFO_kindtypeINTEGER4:
3491 error = ffetarget_multiply_integer4 (ffebld_cu_ptr_integer4 (u),
3492 ffebld_constant_integer4 (ffebld_conter (l)),
3493 ffebld_constant_integer4 (ffebld_conter (r)));
3494 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3495 (ffebld_cu_val_integer4 (u)), expr);
3496 break;
3497 #endif
3498
3499 default:
3500 assert ("bad integer kind type" == NULL);
3501 break;
3502 }
3503 break;
3504
3505 case FFEINFO_basictypeREAL:
3506 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3507 {
3508 #if FFETARGET_okREAL1
3509 case FFEINFO_kindtypeREAL1:
3510 error = ffetarget_multiply_real1 (ffebld_cu_ptr_real1 (u),
3511 ffebld_constant_real1 (ffebld_conter (l)),
3512 ffebld_constant_real1 (ffebld_conter (r)));
3513 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3514 (ffebld_cu_val_real1 (u)), expr);
3515 break;
3516 #endif
3517
3518 #if FFETARGET_okREAL2
3519 case FFEINFO_kindtypeREAL2:
3520 error = ffetarget_multiply_real2 (ffebld_cu_ptr_real2 (u),
3521 ffebld_constant_real2 (ffebld_conter (l)),
3522 ffebld_constant_real2 (ffebld_conter (r)));
3523 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3524 (ffebld_cu_val_real2 (u)), expr);
3525 break;
3526 #endif
3527
3528 #if FFETARGET_okREAL3
3529 case FFEINFO_kindtypeREAL3:
3530 error = ffetarget_multiply_real3 (ffebld_cu_ptr_real3 (u),
3531 ffebld_constant_real3 (ffebld_conter (l)),
3532 ffebld_constant_real3 (ffebld_conter (r)));
3533 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3534 (ffebld_cu_val_real3 (u)), expr);
3535 break;
3536 #endif
3537
3538 default:
3539 assert ("bad real kind type" == NULL);
3540 break;
3541 }
3542 break;
3543
3544 case FFEINFO_basictypeCOMPLEX:
3545 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3546 {
3547 #if FFETARGET_okCOMPLEX1
3548 case FFEINFO_kindtypeREAL1:
3549 error = ffetarget_multiply_complex1 (ffebld_cu_ptr_complex1 (u),
3550 ffebld_constant_complex1 (ffebld_conter (l)),
3551 ffebld_constant_complex1 (ffebld_conter (r)));
3552 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3553 (ffebld_cu_val_complex1 (u)), expr);
3554 break;
3555 #endif
3556
3557 #if FFETARGET_okCOMPLEX2
3558 case FFEINFO_kindtypeREAL2:
3559 error = ffetarget_multiply_complex2 (ffebld_cu_ptr_complex2 (u),
3560 ffebld_constant_complex2 (ffebld_conter (l)),
3561 ffebld_constant_complex2 (ffebld_conter (r)));
3562 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3563 (ffebld_cu_val_complex2 (u)), expr);
3564 break;
3565 #endif
3566
3567 #if FFETARGET_okCOMPLEX3
3568 case FFEINFO_kindtypeREAL3:
3569 error = ffetarget_multiply_complex3 (ffebld_cu_ptr_complex3 (u),
3570 ffebld_constant_complex3 (ffebld_conter (l)),
3571 ffebld_constant_complex3 (ffebld_conter (r)));
3572 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3573 (ffebld_cu_val_complex3 (u)), expr);
3574 break;
3575 #endif
3576
3577 default:
3578 assert ("bad complex kind type" == NULL);
3579 break;
3580 }
3581 break;
3582
3583 default:
3584 assert ("bad type" == NULL);
3585 return expr;
3586 }
3587
3588 ffebld_set_info (expr, ffeinfo_new
3589 (bt,
3590 kt,
3591 0,
3592 FFEINFO_kindENTITY,
3593 FFEINFO_whereCONSTANT,
3594 FFETARGET_charactersizeNONE));
3595
3596 if ((error != FFEBAD)
3597 && ffebad_start (error))
3598 {
3599 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3600 ffebad_finish ();
3601 }
3602
3603 return expr;
3604 }
3605
3606 /* ffeexpr_collapse_divide -- Collapse divide expr
3607
3608 ffebld expr;
3609 ffelexToken token;
3610 expr = ffeexpr_collapse_divide(expr,token);
3611
3612 If the result of the expr is a constant, replaces the expr with the
3613 computed constant. */
3614
3615 ffebld
3616 ffeexpr_collapse_divide (ffebld expr, ffelexToken t)
3617 {
3618 ffebad error = FFEBAD;
3619 ffebld l;
3620 ffebld r;
3621 ffebldConstantUnion u;
3622 ffeinfoBasictype bt;
3623 ffeinfoKindtype kt;
3624
3625 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3626 return expr;
3627
3628 l = ffebld_left (expr);
3629 r = ffebld_right (expr);
3630
3631 if (ffebld_op (l) != FFEBLD_opCONTER)
3632 return expr;
3633 if (ffebld_op (r) != FFEBLD_opCONTER)
3634 return expr;
3635
3636 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3637 {
3638 case FFEINFO_basictypeANY:
3639 return expr;
3640
3641 case FFEINFO_basictypeINTEGER:
3642 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3643 {
3644 #if FFETARGET_okINTEGER1
3645 case FFEINFO_kindtypeINTEGER1:
3646 error = ffetarget_divide_integer1 (ffebld_cu_ptr_integer1 (u),
3647 ffebld_constant_integer1 (ffebld_conter (l)),
3648 ffebld_constant_integer1 (ffebld_conter (r)));
3649 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3650 (ffebld_cu_val_integer1 (u)), expr);
3651 break;
3652 #endif
3653
3654 #if FFETARGET_okINTEGER2
3655 case FFEINFO_kindtypeINTEGER2:
3656 error = ffetarget_divide_integer2 (ffebld_cu_ptr_integer2 (u),
3657 ffebld_constant_integer2 (ffebld_conter (l)),
3658 ffebld_constant_integer2 (ffebld_conter (r)));
3659 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3660 (ffebld_cu_val_integer2 (u)), expr);
3661 break;
3662 #endif
3663
3664 #if FFETARGET_okINTEGER3
3665 case FFEINFO_kindtypeINTEGER3:
3666 error = ffetarget_divide_integer3 (ffebld_cu_ptr_integer3 (u),
3667 ffebld_constant_integer3 (ffebld_conter (l)),
3668 ffebld_constant_integer3 (ffebld_conter (r)));
3669 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3670 (ffebld_cu_val_integer3 (u)), expr);
3671 break;
3672 #endif
3673
3674 #if FFETARGET_okINTEGER4
3675 case FFEINFO_kindtypeINTEGER4:
3676 error = ffetarget_divide_integer4 (ffebld_cu_ptr_integer4 (u),
3677 ffebld_constant_integer4 (ffebld_conter (l)),
3678 ffebld_constant_integer4 (ffebld_conter (r)));
3679 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3680 (ffebld_cu_val_integer4 (u)), expr);
3681 break;
3682 #endif
3683
3684 default:
3685 assert ("bad integer kind type" == NULL);
3686 break;
3687 }
3688 break;
3689
3690 case FFEINFO_basictypeREAL:
3691 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3692 {
3693 #if FFETARGET_okREAL1
3694 case FFEINFO_kindtypeREAL1:
3695 error = ffetarget_divide_real1 (ffebld_cu_ptr_real1 (u),
3696 ffebld_constant_real1 (ffebld_conter (l)),
3697 ffebld_constant_real1 (ffebld_conter (r)));
3698 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3699 (ffebld_cu_val_real1 (u)), expr);
3700 break;
3701 #endif
3702
3703 #if FFETARGET_okREAL2
3704 case FFEINFO_kindtypeREAL2:
3705 error = ffetarget_divide_real2 (ffebld_cu_ptr_real2 (u),
3706 ffebld_constant_real2 (ffebld_conter (l)),
3707 ffebld_constant_real2 (ffebld_conter (r)));
3708 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3709 (ffebld_cu_val_real2 (u)), expr);
3710 break;
3711 #endif
3712
3713 #if FFETARGET_okREAL3
3714 case FFEINFO_kindtypeREAL3:
3715 error = ffetarget_divide_real3 (ffebld_cu_ptr_real3 (u),
3716 ffebld_constant_real3 (ffebld_conter (l)),
3717 ffebld_constant_real3 (ffebld_conter (r)));
3718 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3719 (ffebld_cu_val_real3 (u)), expr);
3720 break;
3721 #endif
3722
3723 default:
3724 assert ("bad real kind type" == NULL);
3725 break;
3726 }
3727 break;
3728
3729 case FFEINFO_basictypeCOMPLEX:
3730 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3731 {
3732 #if FFETARGET_okCOMPLEX1
3733 case FFEINFO_kindtypeREAL1:
3734 error = ffetarget_divide_complex1 (ffebld_cu_ptr_complex1 (u),
3735 ffebld_constant_complex1 (ffebld_conter (l)),
3736 ffebld_constant_complex1 (ffebld_conter (r)));
3737 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3738 (ffebld_cu_val_complex1 (u)), expr);
3739 break;
3740 #endif
3741
3742 #if FFETARGET_okCOMPLEX2
3743 case FFEINFO_kindtypeREAL2:
3744 error = ffetarget_divide_complex2 (ffebld_cu_ptr_complex2 (u),
3745 ffebld_constant_complex2 (ffebld_conter (l)),
3746 ffebld_constant_complex2 (ffebld_conter (r)));
3747 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3748 (ffebld_cu_val_complex2 (u)), expr);
3749 break;
3750 #endif
3751
3752 #if FFETARGET_okCOMPLEX3
3753 case FFEINFO_kindtypeREAL3:
3754 error = ffetarget_divide_complex3 (ffebld_cu_ptr_complex3 (u),
3755 ffebld_constant_complex3 (ffebld_conter (l)),
3756 ffebld_constant_complex3 (ffebld_conter (r)));
3757 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3758 (ffebld_cu_val_complex3 (u)), expr);
3759 break;
3760 #endif
3761
3762 default:
3763 assert ("bad complex kind type" == NULL);
3764 break;
3765 }
3766 break;
3767
3768 default:
3769 assert ("bad type" == NULL);
3770 return expr;
3771 }
3772
3773 ffebld_set_info (expr, ffeinfo_new
3774 (bt,
3775 kt,
3776 0,
3777 FFEINFO_kindENTITY,
3778 FFEINFO_whereCONSTANT,
3779 FFETARGET_charactersizeNONE));
3780
3781 if ((error != FFEBAD)
3782 && ffebad_start (error))
3783 {
3784 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3785 ffebad_finish ();
3786 }
3787
3788 return expr;
3789 }
3790
3791 /* ffeexpr_collapse_power -- Collapse power expr
3792
3793 ffebld expr;
3794 ffelexToken token;
3795 expr = ffeexpr_collapse_power(expr,token);
3796
3797 If the result of the expr is a constant, replaces the expr with the
3798 computed constant. */
3799
3800 ffebld
3801 ffeexpr_collapse_power (ffebld expr, ffelexToken t)
3802 {
3803 ffebad error = FFEBAD;
3804 ffebld l;
3805 ffebld r;
3806 ffebldConstantUnion u;
3807 ffeinfoBasictype bt;
3808 ffeinfoKindtype kt;
3809
3810 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3811 return expr;
3812
3813 l = ffebld_left (expr);
3814 r = ffebld_right (expr);
3815
3816 if (ffebld_op (l) != FFEBLD_opCONTER)
3817 return expr;
3818 if (ffebld_op (r) != FFEBLD_opCONTER)
3819 return expr;
3820
3821 if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER)
3822 || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT))
3823 return expr;
3824
3825 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3826 {
3827 case FFEINFO_basictypeANY:
3828 return expr;
3829
3830 case FFEINFO_basictypeINTEGER:
3831 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3832 {
3833 case FFEINFO_kindtypeINTEGERDEFAULT:
3834 error = ffetarget_power_integerdefault_integerdefault
3835 (ffebld_cu_ptr_integerdefault (u),
3836 ffebld_constant_integerdefault (ffebld_conter (l)),
3837 ffebld_constant_integerdefault (ffebld_conter (r)));
3838 expr = ffebld_new_conter_with_orig
3839 (ffebld_constant_new_integerdefault_val
3840 (ffebld_cu_val_integerdefault (u)), expr);
3841 break;
3842
3843 default:
3844 assert ("bad integer kind type" == NULL);
3845 break;
3846 }
3847 break;
3848
3849 case FFEINFO_basictypeREAL:
3850 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3851 {
3852 case FFEINFO_kindtypeREALDEFAULT:
3853 error = ffetarget_power_realdefault_integerdefault
3854 (ffebld_cu_ptr_realdefault (u),
3855 ffebld_constant_realdefault (ffebld_conter (l)),
3856 ffebld_constant_integerdefault (ffebld_conter (r)));
3857 expr = ffebld_new_conter_with_orig
3858 (ffebld_constant_new_realdefault_val
3859 (ffebld_cu_val_realdefault (u)), expr);
3860 break;
3861
3862 case FFEINFO_kindtypeREALDOUBLE:
3863 error = ffetarget_power_realdouble_integerdefault
3864 (ffebld_cu_ptr_realdouble (u),
3865 ffebld_constant_realdouble (ffebld_conter (l)),
3866 ffebld_constant_integerdefault (ffebld_conter (r)));
3867 expr = ffebld_new_conter_with_orig
3868 (ffebld_constant_new_realdouble_val
3869 (ffebld_cu_val_realdouble (u)), expr);
3870 break;
3871
3872 #if FFETARGET_okREALQUAD
3873 case FFEINFO_kindtypeREALQUAD:
3874 error = ffetarget_power_realquad_integerdefault
3875 (ffebld_cu_ptr_realquad (u),
3876 ffebld_constant_realquad (ffebld_conter (l)),
3877 ffebld_constant_integerdefault (ffebld_conter (r)));
3878 expr = ffebld_new_conter_with_orig
3879 (ffebld_constant_new_realquad_val
3880 (ffebld_cu_val_realquad (u)), expr);
3881 break;
3882 #endif
3883 default:
3884 assert ("bad real kind type" == NULL);
3885 break;
3886 }
3887 break;
3888
3889 case FFEINFO_basictypeCOMPLEX:
3890 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3891 {
3892 case FFEINFO_kindtypeREALDEFAULT:
3893 error = ffetarget_power_complexdefault_integerdefault
3894 (ffebld_cu_ptr_complexdefault (u),
3895 ffebld_constant_complexdefault (ffebld_conter (l)),
3896 ffebld_constant_integerdefault (ffebld_conter (r)));
3897 expr = ffebld_new_conter_with_orig
3898 (ffebld_constant_new_complexdefault_val
3899 (ffebld_cu_val_complexdefault (u)), expr);
3900 break;
3901
3902 #if FFETARGET_okCOMPLEXDOUBLE
3903 case FFEINFO_kindtypeREALDOUBLE:
3904 error = ffetarget_power_complexdouble_integerdefault
3905 (ffebld_cu_ptr_complexdouble (u),
3906 ffebld_constant_complexdouble (ffebld_conter (l)),
3907 ffebld_constant_integerdefault (ffebld_conter (r)));
3908 expr = ffebld_new_conter_with_orig
3909 (ffebld_constant_new_complexdouble_val
3910 (ffebld_cu_val_complexdouble (u)), expr);
3911 break;
3912 #endif
3913
3914 #if FFETARGET_okCOMPLEXQUAD
3915 case FFEINFO_kindtypeREALQUAD:
3916 error = ffetarget_power_complexquad_integerdefault
3917 (ffebld_cu_ptr_complexquad (u),
3918 ffebld_constant_complexquad (ffebld_conter (l)),
3919 ffebld_constant_integerdefault (ffebld_conter (r)));
3920 expr = ffebld_new_conter_with_orig
3921 (ffebld_constant_new_complexquad_val
3922 (ffebld_cu_val_complexquad (u)), expr);
3923 break;
3924 #endif
3925
3926 default:
3927 assert ("bad complex kind type" == NULL);
3928 break;
3929 }
3930 break;
3931
3932 default:
3933 assert ("bad type" == NULL);
3934 return expr;
3935 }
3936
3937 ffebld_set_info (expr, ffeinfo_new
3938 (bt,
3939 kt,
3940 0,
3941 FFEINFO_kindENTITY,
3942 FFEINFO_whereCONSTANT,
3943 FFETARGET_charactersizeNONE));
3944
3945 if ((error != FFEBAD)
3946 && ffebad_start (error))
3947 {
3948 ffebad_here (0, ffelex_token_where_line (t),
3949 ffelex_token_where_column (t));
3950 ffebad_finish ();
3951 }
3952
3953 return expr;
3954 }
3955
3956 /* ffeexpr_collapse_concatenate -- Collapse concatenate expr
3957
3958 ffebld expr;
3959 ffelexToken token;
3960 expr = ffeexpr_collapse_concatenate(expr,token);
3961
3962 If the result of the expr is a constant, replaces the expr with the
3963 computed constant. */
3964
3965 ffebld
3966 ffeexpr_collapse_concatenate (ffebld expr, ffelexToken t)
3967 {
3968 ffebad error = FFEBAD;
3969 ffebld l;
3970 ffebld r;
3971 ffebldConstantUnion u;
3972 ffeinfoKindtype kt;
3973 ffetargetCharacterSize len;
3974
3975 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3976 return expr;
3977
3978 l = ffebld_left (expr);
3979 r = ffebld_right (expr);
3980
3981 if (ffebld_op (l) != FFEBLD_opCONTER)
3982 return expr;
3983 if (ffebld_op (r) != FFEBLD_opCONTER)
3984 return expr;
3985
3986 switch (ffeinfo_basictype (ffebld_info (expr)))
3987 {
3988 case FFEINFO_basictypeANY:
3989 return expr;
3990
3991 case FFEINFO_basictypeCHARACTER:
3992 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3993 {
3994 #if FFETARGET_okCHARACTER1
3995 case FFEINFO_kindtypeCHARACTER1:
3996 error = ffetarget_concatenate_character1 (ffebld_cu_ptr_character1 (u),
3997 ffebld_constant_character1 (ffebld_conter (l)),
3998 ffebld_constant_character1 (ffebld_conter (r)),
3999 ffebld_constant_pool (), &len);
4000 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
4001 (ffebld_cu_val_character1 (u)), expr);
4002 break;
4003 #endif
4004
4005 default:
4006 assert ("bad character kind type" == NULL);
4007 break;
4008 }
4009 break;
4010
4011 default:
4012 assert ("bad type" == NULL);
4013 return expr;
4014 }
4015
4016 ffebld_set_info (expr, ffeinfo_new
4017 (FFEINFO_basictypeCHARACTER,
4018 kt,
4019 0,
4020 FFEINFO_kindENTITY,
4021 FFEINFO_whereCONSTANT,
4022 len));
4023
4024 if ((error != FFEBAD)
4025 && ffebad_start (error))
4026 {
4027 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4028 ffebad_finish ();
4029 }
4030
4031 return expr;
4032 }
4033
4034 /* ffeexpr_collapse_eq -- Collapse eq expr
4035
4036 ffebld expr;
4037 ffelexToken token;
4038 expr = ffeexpr_collapse_eq(expr,token);
4039
4040 If the result of the expr is a constant, replaces the expr with the
4041 computed constant. */
4042
4043 ffebld
4044 ffeexpr_collapse_eq (ffebld expr, ffelexToken t)
4045 {
4046 ffebad error = FFEBAD;
4047 ffebld l;
4048 ffebld r;
4049 bool val;
4050
4051 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4052 return expr;
4053
4054 l = ffebld_left (expr);
4055 r = ffebld_right (expr);
4056
4057 if (ffebld_op (l) != FFEBLD_opCONTER)
4058 return expr;
4059 if (ffebld_op (r) != FFEBLD_opCONTER)
4060 return expr;
4061
4062 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4063 {
4064 case FFEINFO_basictypeANY:
4065 return expr;
4066
4067 case FFEINFO_basictypeINTEGER:
4068 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4069 {
4070 #if FFETARGET_okINTEGER1
4071 case FFEINFO_kindtypeINTEGER1:
4072 error = ffetarget_eq_integer1 (&val,
4073 ffebld_constant_integer1 (ffebld_conter (l)),
4074 ffebld_constant_integer1 (ffebld_conter (r)));
4075 expr = ffebld_new_conter_with_orig
4076 (ffebld_constant_new_logicaldefault (val), expr);
4077 break;
4078 #endif
4079
4080 #if FFETARGET_okINTEGER2
4081 case FFEINFO_kindtypeINTEGER2:
4082 error = ffetarget_eq_integer2 (&val,
4083 ffebld_constant_integer2 (ffebld_conter (l)),
4084 ffebld_constant_integer2 (ffebld_conter (r)));
4085 expr = ffebld_new_conter_with_orig
4086 (ffebld_constant_new_logicaldefault (val), expr);
4087 break;
4088 #endif
4089
4090 #if FFETARGET_okINTEGER3
4091 case FFEINFO_kindtypeINTEGER3:
4092 error = ffetarget_eq_integer3 (&val,
4093 ffebld_constant_integer3 (ffebld_conter (l)),
4094 ffebld_constant_integer3 (ffebld_conter (r)));
4095 expr = ffebld_new_conter_with_orig
4096 (ffebld_constant_new_logicaldefault (val), expr);
4097 break;
4098 #endif
4099
4100 #if FFETARGET_okINTEGER4
4101 case FFEINFO_kindtypeINTEGER4:
4102 error = ffetarget_eq_integer4 (&val,
4103 ffebld_constant_integer4 (ffebld_conter (l)),
4104 ffebld_constant_integer4 (ffebld_conter (r)));
4105 expr = ffebld_new_conter_with_orig
4106 (ffebld_constant_new_logicaldefault (val), expr);
4107 break;
4108 #endif
4109
4110 default:
4111 assert ("bad integer kind type" == NULL);
4112 break;
4113 }
4114 break;
4115
4116 case FFEINFO_basictypeREAL:
4117 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4118 {
4119 #if FFETARGET_okREAL1
4120 case FFEINFO_kindtypeREAL1:
4121 error = ffetarget_eq_real1 (&val,
4122 ffebld_constant_real1 (ffebld_conter (l)),
4123 ffebld_constant_real1 (ffebld_conter (r)));
4124 expr = ffebld_new_conter_with_orig
4125 (ffebld_constant_new_logicaldefault (val), expr);
4126 break;
4127 #endif
4128
4129 #if FFETARGET_okREAL2
4130 case FFEINFO_kindtypeREAL2:
4131 error = ffetarget_eq_real2 (&val,
4132 ffebld_constant_real2 (ffebld_conter (l)),
4133 ffebld_constant_real2 (ffebld_conter (r)));
4134 expr = ffebld_new_conter_with_orig
4135 (ffebld_constant_new_logicaldefault (val), expr);
4136 break;
4137 #endif
4138
4139 #if FFETARGET_okREAL3
4140 case FFEINFO_kindtypeREAL3:
4141 error = ffetarget_eq_real3 (&val,
4142 ffebld_constant_real3 (ffebld_conter (l)),
4143 ffebld_constant_real3 (ffebld_conter (r)));
4144 expr = ffebld_new_conter_with_orig
4145 (ffebld_constant_new_logicaldefault (val), expr);
4146 break;
4147 #endif
4148
4149 default:
4150 assert ("bad real kind type" == NULL);
4151 break;
4152 }
4153 break;
4154
4155 case FFEINFO_basictypeCOMPLEX:
4156 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4157 {
4158 #if FFETARGET_okCOMPLEX1
4159 case FFEINFO_kindtypeREAL1:
4160 error = ffetarget_eq_complex1 (&val,
4161 ffebld_constant_complex1 (ffebld_conter (l)),
4162 ffebld_constant_complex1 (ffebld_conter (r)));
4163 expr = ffebld_new_conter_with_orig
4164 (ffebld_constant_new_logicaldefault (val), expr);
4165 break;
4166 #endif
4167
4168 #if FFETARGET_okCOMPLEX2
4169 case FFEINFO_kindtypeREAL2:
4170 error = ffetarget_eq_complex2 (&val,
4171 ffebld_constant_complex2 (ffebld_conter (l)),
4172 ffebld_constant_complex2 (ffebld_conter (r)));
4173 expr = ffebld_new_conter_with_orig
4174 (ffebld_constant_new_logicaldefault (val), expr);
4175 break;
4176 #endif
4177
4178 #if FFETARGET_okCOMPLEX3
4179 case FFEINFO_kindtypeREAL3:
4180 error = ffetarget_eq_complex3 (&val,
4181 ffebld_constant_complex3 (ffebld_conter (l)),
4182 ffebld_constant_complex3 (ffebld_conter (r)));
4183 expr = ffebld_new_conter_with_orig
4184 (ffebld_constant_new_logicaldefault (val), expr);
4185 break;
4186 #endif
4187
4188 default:
4189 assert ("bad complex kind type" == NULL);
4190 break;
4191 }
4192 break;
4193
4194 case FFEINFO_basictypeCHARACTER:
4195 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4196 {
4197 #if FFETARGET_okCHARACTER1
4198 case FFEINFO_kindtypeCHARACTER1:
4199 error = ffetarget_eq_character1 (&val,
4200 ffebld_constant_character1 (ffebld_conter (l)),
4201 ffebld_constant_character1 (ffebld_conter (r)));
4202 expr = ffebld_new_conter_with_orig
4203 (ffebld_constant_new_logicaldefault (val), expr);
4204 break;
4205 #endif
4206
4207 default:
4208 assert ("bad character kind type" == NULL);
4209 break;
4210 }
4211 break;
4212
4213 default:
4214 assert ("bad type" == NULL);
4215 return expr;
4216 }
4217
4218 ffebld_set_info (expr, ffeinfo_new
4219 (FFEINFO_basictypeLOGICAL,
4220 FFEINFO_kindtypeLOGICALDEFAULT,
4221 0,
4222 FFEINFO_kindENTITY,
4223 FFEINFO_whereCONSTANT,
4224 FFETARGET_charactersizeNONE));
4225
4226 if ((error != FFEBAD)
4227 && ffebad_start (error))
4228 {
4229 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4230 ffebad_finish ();
4231 }
4232
4233 return expr;
4234 }
4235
4236 /* ffeexpr_collapse_ne -- Collapse ne expr
4237
4238 ffebld expr;
4239 ffelexToken token;
4240 expr = ffeexpr_collapse_ne(expr,token);
4241
4242 If the result of the expr is a constant, replaces the expr with the
4243 computed constant. */
4244
4245 ffebld
4246 ffeexpr_collapse_ne (ffebld expr, ffelexToken t)
4247 {
4248 ffebad error = FFEBAD;
4249 ffebld l;
4250 ffebld r;
4251 bool val;
4252
4253 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4254 return expr;
4255
4256 l = ffebld_left (expr);
4257 r = ffebld_right (expr);
4258
4259 if (ffebld_op (l) != FFEBLD_opCONTER)
4260 return expr;
4261 if (ffebld_op (r) != FFEBLD_opCONTER)
4262 return expr;
4263
4264 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4265 {
4266 case FFEINFO_basictypeANY:
4267 return expr;
4268
4269 case FFEINFO_basictypeINTEGER:
4270 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4271 {
4272 #if FFETARGET_okINTEGER1
4273 case FFEINFO_kindtypeINTEGER1:
4274 error = ffetarget_ne_integer1 (&val,
4275 ffebld_constant_integer1 (ffebld_conter (l)),
4276 ffebld_constant_integer1 (ffebld_conter (r)));
4277 expr = ffebld_new_conter_with_orig
4278 (ffebld_constant_new_logicaldefault (val), expr);
4279 break;
4280 #endif
4281
4282 #if FFETARGET_okINTEGER2
4283 case FFEINFO_kindtypeINTEGER2:
4284 error = ffetarget_ne_integer2 (&val,
4285 ffebld_constant_integer2 (ffebld_conter (l)),
4286 ffebld_constant_integer2 (ffebld_conter (r)));
4287 expr = ffebld_new_conter_with_orig
4288 (ffebld_constant_new_logicaldefault (val), expr);
4289 break;
4290 #endif
4291
4292 #if FFETARGET_okINTEGER3
4293 case FFEINFO_kindtypeINTEGER3:
4294 error = ffetarget_ne_integer3 (&val,
4295 ffebld_constant_integer3 (ffebld_conter (l)),
4296 ffebld_constant_integer3 (ffebld_conter (r)));
4297 expr = ffebld_new_conter_with_orig
4298 (ffebld_constant_new_logicaldefault (val), expr);
4299 break;
4300 #endif
4301
4302 #if FFETARGET_okINTEGER4
4303 case FFEINFO_kindtypeINTEGER4:
4304 error = ffetarget_ne_integer4 (&val,
4305 ffebld_constant_integer4 (ffebld_conter (l)),
4306 ffebld_constant_integer4 (ffebld_conter (r)));
4307 expr = ffebld_new_conter_with_orig
4308 (ffebld_constant_new_logicaldefault (val), expr);
4309 break;
4310 #endif
4311
4312 default:
4313 assert ("bad integer kind type" == NULL);
4314 break;
4315 }
4316 break;
4317
4318 case FFEINFO_basictypeREAL:
4319 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4320 {
4321 #if FFETARGET_okREAL1
4322 case FFEINFO_kindtypeREAL1:
4323 error = ffetarget_ne_real1 (&val,
4324 ffebld_constant_real1 (ffebld_conter (l)),
4325 ffebld_constant_real1 (ffebld_conter (r)));
4326 expr = ffebld_new_conter_with_orig
4327 (ffebld_constant_new_logicaldefault (val), expr);
4328 break;
4329 #endif
4330
4331 #if FFETARGET_okREAL2
4332 case FFEINFO_kindtypeREAL2:
4333 error = ffetarget_ne_real2 (&val,
4334 ffebld_constant_real2 (ffebld_conter (l)),
4335 ffebld_constant_real2 (ffebld_conter (r)));
4336 expr = ffebld_new_conter_with_orig
4337 (ffebld_constant_new_logicaldefault (val), expr);
4338 break;
4339 #endif
4340
4341 #if FFETARGET_okREAL3
4342 case FFEINFO_kindtypeREAL3:
4343 error = ffetarget_ne_real3 (&val,
4344 ffebld_constant_real3 (ffebld_conter (l)),
4345 ffebld_constant_real3 (ffebld_conter (r)));
4346 expr = ffebld_new_conter_with_orig
4347 (ffebld_constant_new_logicaldefault (val), expr);
4348 break;
4349 #endif
4350
4351 default:
4352 assert ("bad real kind type" == NULL);
4353 break;
4354 }
4355 break;
4356
4357 case FFEINFO_basictypeCOMPLEX:
4358 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4359 {
4360 #if FFETARGET_okCOMPLEX1
4361 case FFEINFO_kindtypeREAL1:
4362 error = ffetarget_ne_complex1 (&val,
4363 ffebld_constant_complex1 (ffebld_conter (l)),
4364 ffebld_constant_complex1 (ffebld_conter (r)));
4365 expr = ffebld_new_conter_with_orig
4366 (ffebld_constant_new_logicaldefault (val), expr);
4367 break;
4368 #endif
4369
4370 #if FFETARGET_okCOMPLEX2
4371 case FFEINFO_kindtypeREAL2:
4372 error = ffetarget_ne_complex2 (&val,
4373 ffebld_constant_complex2 (ffebld_conter (l)),
4374 ffebld_constant_complex2 (ffebld_conter (r)));
4375 expr = ffebld_new_conter_with_orig
4376 (ffebld_constant_new_logicaldefault (val), expr);
4377 break;
4378 #endif
4379
4380 #if FFETARGET_okCOMPLEX3
4381 case FFEINFO_kindtypeREAL3:
4382 error = ffetarget_ne_complex3 (&val,
4383 ffebld_constant_complex3 (ffebld_conter (l)),
4384 ffebld_constant_complex3 (ffebld_conter (r)));
4385 expr = ffebld_new_conter_with_orig
4386 (ffebld_constant_new_logicaldefault (val), expr);
4387 break;
4388 #endif
4389
4390 default:
4391 assert ("bad complex kind type" == NULL);
4392 break;
4393 }
4394 break;
4395
4396 case FFEINFO_basictypeCHARACTER:
4397 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4398 {
4399 #if FFETARGET_okCHARACTER1
4400 case FFEINFO_kindtypeCHARACTER1:
4401 error = ffetarget_ne_character1 (&val,
4402 ffebld_constant_character1 (ffebld_conter (l)),
4403 ffebld_constant_character1 (ffebld_conter (r)));
4404 expr = ffebld_new_conter_with_orig
4405 (ffebld_constant_new_logicaldefault (val), expr);
4406 break;
4407 #endif
4408
4409 default:
4410 assert ("bad character kind type" == NULL);
4411 break;
4412 }
4413 break;
4414
4415 default:
4416 assert ("bad type" == NULL);
4417 return expr;
4418 }
4419
4420 ffebld_set_info (expr, ffeinfo_new
4421 (FFEINFO_basictypeLOGICAL,
4422 FFEINFO_kindtypeLOGICALDEFAULT,
4423 0,
4424 FFEINFO_kindENTITY,
4425 FFEINFO_whereCONSTANT,
4426 FFETARGET_charactersizeNONE));
4427
4428 if ((error != FFEBAD)
4429 && ffebad_start (error))
4430 {
4431 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4432 ffebad_finish ();
4433 }
4434
4435 return expr;
4436 }
4437
4438 /* ffeexpr_collapse_ge -- Collapse ge expr
4439
4440 ffebld expr;
4441 ffelexToken token;
4442 expr = ffeexpr_collapse_ge(expr,token);
4443
4444 If the result of the expr is a constant, replaces the expr with the
4445 computed constant. */
4446
4447 ffebld
4448 ffeexpr_collapse_ge (ffebld expr, ffelexToken t)
4449 {
4450 ffebad error = FFEBAD;
4451 ffebld l;
4452 ffebld r;
4453 bool val;
4454
4455 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4456 return expr;
4457
4458 l = ffebld_left (expr);
4459 r = ffebld_right (expr);
4460
4461 if (ffebld_op (l) != FFEBLD_opCONTER)
4462 return expr;
4463 if (ffebld_op (r) != FFEBLD_opCONTER)
4464 return expr;
4465
4466 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4467 {
4468 case FFEINFO_basictypeANY:
4469 return expr;
4470
4471 case FFEINFO_basictypeINTEGER:
4472 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4473 {
4474 #if FFETARGET_okINTEGER1
4475 case FFEINFO_kindtypeINTEGER1:
4476 error = ffetarget_ge_integer1 (&val,
4477 ffebld_constant_integer1 (ffebld_conter (l)),
4478 ffebld_constant_integer1 (ffebld_conter (r)));
4479 expr = ffebld_new_conter_with_orig
4480 (ffebld_constant_new_logicaldefault (val), expr);
4481 break;
4482 #endif
4483
4484 #if FFETARGET_okINTEGER2
4485 case FFEINFO_kindtypeINTEGER2:
4486 error = ffetarget_ge_integer2 (&val,
4487 ffebld_constant_integer2 (ffebld_conter (l)),
4488 ffebld_constant_integer2 (ffebld_conter (r)));
4489 expr = ffebld_new_conter_with_orig
4490 (ffebld_constant_new_logicaldefault (val), expr);
4491 break;
4492 #endif
4493
4494 #if FFETARGET_okINTEGER3
4495 case FFEINFO_kindtypeINTEGER3:
4496 error = ffetarget_ge_integer3 (&val,
4497 ffebld_constant_integer3 (ffebld_conter (l)),
4498 ffebld_constant_integer3 (ffebld_conter (r)));
4499 expr = ffebld_new_conter_with_orig
4500 (ffebld_constant_new_logicaldefault (val), expr);
4501 break;
4502 #endif
4503
4504 #if FFETARGET_okINTEGER4
4505 case FFEINFO_kindtypeINTEGER4:
4506 error = ffetarget_ge_integer4 (&val,
4507 ffebld_constant_integer4 (ffebld_conter (l)),
4508 ffebld_constant_integer4 (ffebld_conter (r)));
4509 expr = ffebld_new_conter_with_orig
4510 (ffebld_constant_new_logicaldefault (val), expr);
4511 break;
4512 #endif
4513
4514 default:
4515 assert ("bad integer kind type" == NULL);
4516 break;
4517 }
4518 break;
4519
4520 case FFEINFO_basictypeREAL:
4521 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4522 {
4523 #if FFETARGET_okREAL1
4524 case FFEINFO_kindtypeREAL1:
4525 error = ffetarget_ge_real1 (&val,
4526 ffebld_constant_real1 (ffebld_conter (l)),
4527 ffebld_constant_real1 (ffebld_conter (r)));
4528 expr = ffebld_new_conter_with_orig
4529 (ffebld_constant_new_logicaldefault (val), expr);
4530 break;
4531 #endif
4532
4533 #if FFETARGET_okREAL2
4534 case FFEINFO_kindtypeREAL2:
4535 error = ffetarget_ge_real2 (&val,
4536 ffebld_constant_real2 (ffebld_conter (l)),
4537 ffebld_constant_real2 (ffebld_conter (r)));
4538 expr = ffebld_new_conter_with_orig
4539 (ffebld_constant_new_logicaldefault (val), expr);
4540 break;
4541 #endif
4542
4543 #if FFETARGET_okREAL3
4544 case FFEINFO_kindtypeREAL3:
4545 error = ffetarget_ge_real3 (&val,
4546 ffebld_constant_real3 (ffebld_conter (l)),
4547 ffebld_constant_real3 (ffebld_conter (r)));
4548 expr = ffebld_new_conter_with_orig
4549 (ffebld_constant_new_logicaldefault (val), expr);
4550 break;
4551 #endif
4552
4553 default:
4554 assert ("bad real kind type" == NULL);
4555 break;
4556 }
4557 break;
4558
4559 case FFEINFO_basictypeCHARACTER:
4560 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4561 {
4562 #if FFETARGET_okCHARACTER1
4563 case FFEINFO_kindtypeCHARACTER1:
4564 error = ffetarget_ge_character1 (&val,
4565 ffebld_constant_character1 (ffebld_conter (l)),
4566 ffebld_constant_character1 (ffebld_conter (r)));
4567 expr = ffebld_new_conter_with_orig
4568 (ffebld_constant_new_logicaldefault (val), expr);
4569 break;
4570 #endif
4571
4572 default:
4573 assert ("bad character kind type" == NULL);
4574 break;
4575 }
4576 break;
4577
4578 default:
4579 assert ("bad type" == NULL);
4580 return expr;
4581 }
4582
4583 ffebld_set_info (expr, ffeinfo_new
4584 (FFEINFO_basictypeLOGICAL,
4585 FFEINFO_kindtypeLOGICALDEFAULT,
4586 0,
4587 FFEINFO_kindENTITY,
4588 FFEINFO_whereCONSTANT,
4589 FFETARGET_charactersizeNONE));
4590
4591 if ((error != FFEBAD)
4592 && ffebad_start (error))
4593 {
4594 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4595 ffebad_finish ();
4596 }
4597
4598 return expr;
4599 }
4600
4601 /* ffeexpr_collapse_gt -- Collapse gt expr
4602
4603 ffebld expr;
4604 ffelexToken token;
4605 expr = ffeexpr_collapse_gt(expr,token);
4606
4607 If the result of the expr is a constant, replaces the expr with the
4608 computed constant. */
4609
4610 ffebld
4611 ffeexpr_collapse_gt (ffebld expr, ffelexToken t)
4612 {
4613 ffebad error = FFEBAD;
4614 ffebld l;
4615 ffebld r;
4616 bool val;
4617
4618 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4619 return expr;
4620
4621 l = ffebld_left (expr);
4622 r = ffebld_right (expr);
4623
4624 if (ffebld_op (l) != FFEBLD_opCONTER)
4625 return expr;
4626 if (ffebld_op (r) != FFEBLD_opCONTER)
4627 return expr;
4628
4629 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4630 {
4631 case FFEINFO_basictypeANY:
4632 return expr;
4633
4634 case FFEINFO_basictypeINTEGER:
4635 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4636 {
4637 #if FFETARGET_okINTEGER1
4638 case FFEINFO_kindtypeINTEGER1:
4639 error = ffetarget_gt_integer1 (&val,
4640 ffebld_constant_integer1 (ffebld_conter (l)),
4641 ffebld_constant_integer1 (ffebld_conter (r)));
4642 expr = ffebld_new_conter_with_orig
4643 (ffebld_constant_new_logicaldefault (val), expr);
4644 break;
4645 #endif
4646
4647 #if FFETARGET_okINTEGER2
4648 case FFEINFO_kindtypeINTEGER2:
4649 error = ffetarget_gt_integer2 (&val,
4650 ffebld_constant_integer2 (ffebld_conter (l)),
4651 ffebld_constant_integer2 (ffebld_conter (r)));
4652 expr = ffebld_new_conter_with_orig
4653 (ffebld_constant_new_logicaldefault (val), expr);
4654 break;
4655 #endif
4656
4657 #if FFETARGET_okINTEGER3
4658 case FFEINFO_kindtypeINTEGER3:
4659 error = ffetarget_gt_integer3 (&val,
4660 ffebld_constant_integer3 (ffebld_conter (l)),
4661 ffebld_constant_integer3 (ffebld_conter (r)));
4662 expr = ffebld_new_conter_with_orig
4663 (ffebld_constant_new_logicaldefault (val), expr);
4664 break;
4665 #endif
4666
4667 #if FFETARGET_okINTEGER4
4668 case FFEINFO_kindtypeINTEGER4:
4669 error = ffetarget_gt_integer4 (&val,
4670 ffebld_constant_integer4 (ffebld_conter (l)),
4671 ffebld_constant_integer4 (ffebld_conter (r)));
4672 expr = ffebld_new_conter_with_orig
4673 (ffebld_constant_new_logicaldefault (val), expr);
4674 break;
4675 #endif
4676
4677 default:
4678 assert ("bad integer kind type" == NULL);
4679 break;
4680 }
4681 break;
4682
4683 case FFEINFO_basictypeREAL:
4684 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4685 {
4686 #if FFETARGET_okREAL1
4687 case FFEINFO_kindtypeREAL1:
4688 error = ffetarget_gt_real1 (&val,
4689 ffebld_constant_real1 (ffebld_conter (l)),
4690 ffebld_constant_real1 (ffebld_conter (r)));
4691 expr = ffebld_new_conter_with_orig
4692 (ffebld_constant_new_logicaldefault (val), expr);
4693 break;
4694 #endif
4695
4696 #if FFETARGET_okREAL2
4697 case FFEINFO_kindtypeREAL2:
4698 error = ffetarget_gt_real2 (&val,
4699 ffebld_constant_real2 (ffebld_conter (l)),
4700 ffebld_constant_real2 (ffebld_conter (r)));
4701 expr = ffebld_new_conter_with_orig
4702 (ffebld_constant_new_logicaldefault (val), expr);
4703 break;
4704 #endif
4705
4706 #if FFETARGET_okREAL3
4707 case FFEINFO_kindtypeREAL3:
4708 error = ffetarget_gt_real3 (&val,
4709 ffebld_constant_real3 (ffebld_conter (l)),
4710 ffebld_constant_real3 (ffebld_conter (r)));
4711 expr = ffebld_new_conter_with_orig
4712 (ffebld_constant_new_logicaldefault (val), expr);
4713 break;
4714 #endif
4715
4716 default:
4717 assert ("bad real kind type" == NULL);
4718 break;
4719 }
4720 break;
4721
4722 case FFEINFO_basictypeCHARACTER:
4723 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4724 {
4725 #if FFETARGET_okCHARACTER1
4726 case FFEINFO_kindtypeCHARACTER1:
4727 error = ffetarget_gt_character1 (&val,
4728 ffebld_constant_character1 (ffebld_conter (l)),
4729 ffebld_constant_character1 (ffebld_conter (r)));
4730 expr = ffebld_new_conter_with_orig
4731 (ffebld_constant_new_logicaldefault (val), expr);
4732 break;
4733 #endif
4734
4735 default:
4736 assert ("bad character kind type" == NULL);
4737 break;
4738 }
4739 break;
4740
4741 default:
4742 assert ("bad type" == NULL);
4743 return expr;
4744 }
4745
4746 ffebld_set_info (expr, ffeinfo_new
4747 (FFEINFO_basictypeLOGICAL,
4748 FFEINFO_kindtypeLOGICALDEFAULT,
4749 0,
4750 FFEINFO_kindENTITY,
4751 FFEINFO_whereCONSTANT,
4752 FFETARGET_charactersizeNONE));
4753
4754 if ((error != FFEBAD)
4755 && ffebad_start (error))
4756 {
4757 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4758 ffebad_finish ();
4759 }
4760
4761 return expr;
4762 }
4763
4764 /* ffeexpr_collapse_le -- Collapse le expr
4765
4766 ffebld expr;
4767 ffelexToken token;
4768 expr = ffeexpr_collapse_le(expr,token);
4769
4770 If the result of the expr is a constant, replaces the expr with the
4771 computed constant. */
4772
4773 ffebld
4774 ffeexpr_collapse_le (ffebld expr, ffelexToken t)
4775 {
4776 ffebad error = FFEBAD;
4777 ffebld l;
4778 ffebld r;
4779 bool val;
4780
4781 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4782 return expr;
4783
4784 l = ffebld_left (expr);
4785 r = ffebld_right (expr);
4786
4787 if (ffebld_op (l) != FFEBLD_opCONTER)
4788 return expr;
4789 if (ffebld_op (r) != FFEBLD_opCONTER)
4790 return expr;
4791
4792 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4793 {
4794 case FFEINFO_basictypeANY:
4795 return expr;
4796
4797 case FFEINFO_basictypeINTEGER:
4798 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4799 {
4800 #if FFETARGET_okINTEGER1
4801 case FFEINFO_kindtypeINTEGER1:
4802 error = ffetarget_le_integer1 (&val,
4803 ffebld_constant_integer1 (ffebld_conter (l)),
4804 ffebld_constant_integer1 (ffebld_conter (r)));
4805 expr = ffebld_new_conter_with_orig
4806 (ffebld_constant_new_logicaldefault (val), expr);
4807 break;
4808 #endif
4809
4810 #if FFETARGET_okINTEGER2
4811 case FFEINFO_kindtypeINTEGER2:
4812 error = ffetarget_le_integer2 (&val,
4813 ffebld_constant_integer2 (ffebld_conter (l)),
4814 ffebld_constant_integer2 (ffebld_conter (r)));
4815 expr = ffebld_new_conter_with_orig
4816 (ffebld_constant_new_logicaldefault (val), expr);
4817 break;
4818 #endif
4819
4820 #if FFETARGET_okINTEGER3
4821 case FFEINFO_kindtypeINTEGER3:
4822 error = ffetarget_le_integer3 (&val,
4823 ffebld_constant_integer3 (ffebld_conter (l)),
4824 ffebld_constant_integer3 (ffebld_conter (r)));
4825 expr = ffebld_new_conter_with_orig
4826 (ffebld_constant_new_logicaldefault (val), expr);
4827 break;
4828 #endif
4829
4830 #if FFETARGET_okINTEGER4
4831 case FFEINFO_kindtypeINTEGER4:
4832 error = ffetarget_le_integer4 (&val,
4833 ffebld_constant_integer4 (ffebld_conter (l)),
4834 ffebld_constant_integer4 (ffebld_conter (r)));
4835 expr = ffebld_new_conter_with_orig
4836 (ffebld_constant_new_logicaldefault (val), expr);
4837 break;
4838 #endif
4839
4840 default:
4841 assert ("bad integer kind type" == NULL);
4842 break;
4843 }
4844 break;
4845
4846 case FFEINFO_basictypeREAL:
4847 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4848 {
4849 #if FFETARGET_okREAL1
4850 case FFEINFO_kindtypeREAL1:
4851 error = ffetarget_le_real1 (&val,
4852 ffebld_constant_real1 (ffebld_conter (l)),
4853 ffebld_constant_real1 (ffebld_conter (r)));
4854 expr = ffebld_new_conter_with_orig
4855 (ffebld_constant_new_logicaldefault (val), expr);
4856 break;
4857 #endif
4858
4859 #if FFETARGET_okREAL2
4860 case FFEINFO_kindtypeREAL2:
4861 error = ffetarget_le_real2 (&val,
4862 ffebld_constant_real2 (ffebld_conter (l)),
4863 ffebld_constant_real2 (ffebld_conter (r)));
4864 expr = ffebld_new_conter_with_orig
4865 (ffebld_constant_new_logicaldefault (val), expr);
4866 break;
4867 #endif
4868
4869 #if FFETARGET_okREAL3
4870 case FFEINFO_kindtypeREAL3:
4871 error = ffetarget_le_real3 (&val,
4872 ffebld_constant_real3 (ffebld_conter (l)),
4873 ffebld_constant_real3 (ffebld_conter (r)));
4874 expr = ffebld_new_conter_with_orig
4875 (ffebld_constant_new_logicaldefault (val), expr);
4876 break;
4877 #endif
4878
4879 default:
4880 assert ("bad real kind type" == NULL);
4881 break;
4882 }
4883 break;
4884
4885 case FFEINFO_basictypeCHARACTER:
4886 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4887 {
4888 #if FFETARGET_okCHARACTER1
4889 case FFEINFO_kindtypeCHARACTER1:
4890 error = ffetarget_le_character1 (&val,
4891 ffebld_constant_character1 (ffebld_conter (l)),
4892 ffebld_constant_character1 (ffebld_conter (r)));
4893 expr = ffebld_new_conter_with_orig
4894 (ffebld_constant_new_logicaldefault (val), expr);
4895 break;
4896 #endif
4897
4898 default:
4899 assert ("bad character kind type" == NULL);
4900 break;
4901 }
4902 break;
4903
4904 default:
4905 assert ("bad type" == NULL);
4906 return expr;
4907 }
4908
4909 ffebld_set_info (expr, ffeinfo_new
4910 (FFEINFO_basictypeLOGICAL,
4911 FFEINFO_kindtypeLOGICALDEFAULT,
4912 0,
4913 FFEINFO_kindENTITY,
4914 FFEINFO_whereCONSTANT,
4915 FFETARGET_charactersizeNONE));
4916
4917 if ((error != FFEBAD)
4918 && ffebad_start (error))
4919 {
4920 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4921 ffebad_finish ();
4922 }
4923
4924 return expr;
4925 }
4926
4927 /* ffeexpr_collapse_lt -- Collapse lt expr
4928
4929 ffebld expr;
4930 ffelexToken token;
4931 expr = ffeexpr_collapse_lt(expr,token);
4932
4933 If the result of the expr is a constant, replaces the expr with the
4934 computed constant. */
4935
4936 ffebld
4937 ffeexpr_collapse_lt (ffebld expr, ffelexToken t)
4938 {
4939 ffebad error = FFEBAD;
4940 ffebld l;
4941 ffebld r;
4942 bool val;
4943
4944 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4945 return expr;
4946
4947 l = ffebld_left (expr);
4948 r = ffebld_right (expr);
4949
4950 if (ffebld_op (l) != FFEBLD_opCONTER)
4951 return expr;
4952 if (ffebld_op (r) != FFEBLD_opCONTER)
4953 return expr;
4954
4955 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4956 {
4957 case FFEINFO_basictypeANY:
4958 return expr;
4959
4960 case FFEINFO_basictypeINTEGER:
4961 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4962 {
4963 #if FFETARGET_okINTEGER1
4964 case FFEINFO_kindtypeINTEGER1:
4965 error = ffetarget_lt_integer1 (&val,
4966 ffebld_constant_integer1 (ffebld_conter (l)),
4967 ffebld_constant_integer1 (ffebld_conter (r)));
4968 expr = ffebld_new_conter_with_orig
4969 (ffebld_constant_new_logicaldefault (val), expr);
4970 break;
4971 #endif
4972
4973 #if FFETARGET_okINTEGER2
4974 case FFEINFO_kindtypeINTEGER2:
4975 error = ffetarget_lt_integer2 (&val,
4976 ffebld_constant_integer2 (ffebld_conter (l)),
4977 ffebld_constant_integer2 (ffebld_conter (r)));
4978 expr = ffebld_new_conter_with_orig
4979 (ffebld_constant_new_logicaldefault (val), expr);
4980 break;
4981 #endif
4982
4983 #if FFETARGET_okINTEGER3
4984 case FFEINFO_kindtypeINTEGER3:
4985 error = ffetarget_lt_integer3 (&val,
4986 ffebld_constant_integer3 (ffebld_conter (l)),
4987 ffebld_constant_integer3 (ffebld_conter (r)));
4988 expr = ffebld_new_conter_with_orig
4989 (ffebld_constant_new_logicaldefault (val), expr);
4990 break;
4991 #endif
4992
4993 #if FFETARGET_okINTEGER4
4994 case FFEINFO_kindtypeINTEGER4:
4995 error = ffetarget_lt_integer4 (&val,
4996 ffebld_constant_integer4 (ffebld_conter (l)),
4997 ffebld_constant_integer4 (ffebld_conter (r)));
4998 expr = ffebld_new_conter_with_orig
4999 (ffebld_constant_new_logicaldefault (val), expr);
5000 break;
5001 #endif
5002
5003 default:
5004 assert ("bad integer kind type" == NULL);
5005 break;
5006 }
5007 break;
5008
5009 case FFEINFO_basictypeREAL:
5010 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5011 {
5012 #if FFETARGET_okREAL1
5013 case FFEINFO_kindtypeREAL1:
5014 error = ffetarget_lt_real1 (&val,
5015 ffebld_constant_real1 (ffebld_conter (l)),
5016 ffebld_constant_real1 (ffebld_conter (r)));
5017 expr = ffebld_new_conter_with_orig
5018 (ffebld_constant_new_logicaldefault (val), expr);
5019 break;
5020 #endif
5021
5022 #if FFETARGET_okREAL2
5023 case FFEINFO_kindtypeREAL2:
5024 error = ffetarget_lt_real2 (&val,
5025 ffebld_constant_real2 (ffebld_conter (l)),
5026 ffebld_constant_real2 (ffebld_conter (r)));
5027 expr = ffebld_new_conter_with_orig
5028 (ffebld_constant_new_logicaldefault (val), expr);
5029 break;
5030 #endif
5031
5032 #if FFETARGET_okREAL3
5033 case FFEINFO_kindtypeREAL3:
5034 error = ffetarget_lt_real3 (&val,
5035 ffebld_constant_real3 (ffebld_conter (l)),
5036 ffebld_constant_real3 (ffebld_conter (r)));
5037 expr = ffebld_new_conter_with_orig
5038 (ffebld_constant_new_logicaldefault (val), expr);
5039 break;
5040 #endif
5041
5042 default:
5043 assert ("bad real kind type" == NULL);
5044 break;
5045 }
5046 break;
5047
5048 case FFEINFO_basictypeCHARACTER:
5049 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5050 {
5051 #if FFETARGET_okCHARACTER1
5052 case FFEINFO_kindtypeCHARACTER1:
5053 error = ffetarget_lt_character1 (&val,
5054 ffebld_constant_character1 (ffebld_conter (l)),
5055 ffebld_constant_character1 (ffebld_conter (r)));
5056 expr = ffebld_new_conter_with_orig
5057 (ffebld_constant_new_logicaldefault (val), expr);
5058 break;
5059 #endif
5060
5061 default:
5062 assert ("bad character kind type" == NULL);
5063 break;
5064 }
5065 break;
5066
5067 default:
5068 assert ("bad type" == NULL);
5069 return expr;
5070 }
5071
5072 ffebld_set_info (expr, ffeinfo_new
5073 (FFEINFO_basictypeLOGICAL,
5074 FFEINFO_kindtypeLOGICALDEFAULT,
5075 0,
5076 FFEINFO_kindENTITY,
5077 FFEINFO_whereCONSTANT,
5078 FFETARGET_charactersizeNONE));
5079
5080 if ((error != FFEBAD)
5081 && ffebad_start (error))
5082 {
5083 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5084 ffebad_finish ();
5085 }
5086
5087 return expr;
5088 }
5089
5090 /* ffeexpr_collapse_and -- Collapse and expr
5091
5092 ffebld expr;
5093 ffelexToken token;
5094 expr = ffeexpr_collapse_and(expr,token);
5095
5096 If the result of the expr is a constant, replaces the expr with the
5097 computed constant. */
5098
5099 ffebld
5100 ffeexpr_collapse_and (ffebld expr, ffelexToken t)
5101 {
5102 ffebad error = FFEBAD;
5103 ffebld l;
5104 ffebld r;
5105 ffebldConstantUnion u;
5106 ffeinfoBasictype bt;
5107 ffeinfoKindtype kt;
5108
5109 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5110 return expr;
5111
5112 l = ffebld_left (expr);
5113 r = ffebld_right (expr);
5114
5115 if (ffebld_op (l) != FFEBLD_opCONTER)
5116 return expr;
5117 if (ffebld_op (r) != FFEBLD_opCONTER)
5118 return expr;
5119
5120 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5121 {
5122 case FFEINFO_basictypeANY:
5123 return expr;
5124
5125 case FFEINFO_basictypeINTEGER:
5126 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5127 {
5128 #if FFETARGET_okINTEGER1
5129 case FFEINFO_kindtypeINTEGER1:
5130 error = ffetarget_and_integer1 (ffebld_cu_ptr_integer1 (u),
5131 ffebld_constant_integer1 (ffebld_conter (l)),
5132 ffebld_constant_integer1 (ffebld_conter (r)));
5133 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5134 (ffebld_cu_val_integer1 (u)), expr);
5135 break;
5136 #endif
5137
5138 #if FFETARGET_okINTEGER2
5139 case FFEINFO_kindtypeINTEGER2:
5140 error = ffetarget_and_integer2 (ffebld_cu_ptr_integer2 (u),
5141 ffebld_constant_integer2 (ffebld_conter (l)),
5142 ffebld_constant_integer2 (ffebld_conter (r)));
5143 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5144 (ffebld_cu_val_integer2 (u)), expr);
5145 break;
5146 #endif
5147
5148 #if FFETARGET_okINTEGER3
5149 case FFEINFO_kindtypeINTEGER3:
5150 error = ffetarget_and_integer3 (ffebld_cu_ptr_integer3 (u),
5151 ffebld_constant_integer3 (ffebld_conter (l)),
5152 ffebld_constant_integer3 (ffebld_conter (r)));
5153 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5154 (ffebld_cu_val_integer3 (u)), expr);
5155 break;
5156 #endif
5157
5158 #if FFETARGET_okINTEGER4
5159 case FFEINFO_kindtypeINTEGER4:
5160 error = ffetarget_and_integer4 (ffebld_cu_ptr_integer4 (u),
5161 ffebld_constant_integer4 (ffebld_conter (l)),
5162 ffebld_constant_integer4 (ffebld_conter (r)));
5163 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5164 (ffebld_cu_val_integer4 (u)), expr);
5165 break;
5166 #endif
5167
5168 default:
5169 assert ("bad integer kind type" == NULL);
5170 break;
5171 }
5172 break;
5173
5174 case FFEINFO_basictypeLOGICAL:
5175 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5176 {
5177 #if FFETARGET_okLOGICAL1
5178 case FFEINFO_kindtypeLOGICAL1:
5179 error = ffetarget_and_logical1 (ffebld_cu_ptr_logical1 (u),
5180 ffebld_constant_logical1 (ffebld_conter (l)),
5181 ffebld_constant_logical1 (ffebld_conter (r)));
5182 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5183 (ffebld_cu_val_logical1 (u)), expr);
5184 break;
5185 #endif
5186
5187 #if FFETARGET_okLOGICAL2
5188 case FFEINFO_kindtypeLOGICAL2:
5189 error = ffetarget_and_logical2 (ffebld_cu_ptr_logical2 (u),
5190 ffebld_constant_logical2 (ffebld_conter (l)),
5191 ffebld_constant_logical2 (ffebld_conter (r)));
5192 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5193 (ffebld_cu_val_logical2 (u)), expr);
5194 break;
5195 #endif
5196
5197 #if FFETARGET_okLOGICAL3
5198 case FFEINFO_kindtypeLOGICAL3:
5199 error = ffetarget_and_logical3 (ffebld_cu_ptr_logical3 (u),
5200 ffebld_constant_logical3 (ffebld_conter (l)),
5201 ffebld_constant_logical3 (ffebld_conter (r)));
5202 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5203 (ffebld_cu_val_logical3 (u)), expr);
5204 break;
5205 #endif
5206
5207 #if FFETARGET_okLOGICAL4
5208 case FFEINFO_kindtypeLOGICAL4:
5209 error = ffetarget_and_logical4 (ffebld_cu_ptr_logical4 (u),
5210 ffebld_constant_logical4 (ffebld_conter (l)),
5211 ffebld_constant_logical4 (ffebld_conter (r)));
5212 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5213 (ffebld_cu_val_logical4 (u)), expr);
5214 break;
5215 #endif
5216
5217 default:
5218 assert ("bad logical kind type" == NULL);
5219 break;
5220 }
5221 break;
5222
5223 default:
5224 assert ("bad type" == NULL);
5225 return expr;
5226 }
5227
5228 ffebld_set_info (expr, ffeinfo_new
5229 (bt,
5230 kt,
5231 0,
5232 FFEINFO_kindENTITY,
5233 FFEINFO_whereCONSTANT,
5234 FFETARGET_charactersizeNONE));
5235
5236 if ((error != FFEBAD)
5237 && ffebad_start (error))
5238 {
5239 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5240 ffebad_finish ();
5241 }
5242
5243 return expr;
5244 }
5245
5246 /* ffeexpr_collapse_or -- Collapse or expr
5247
5248 ffebld expr;
5249 ffelexToken token;
5250 expr = ffeexpr_collapse_or(expr,token);
5251
5252 If the result of the expr is a constant, replaces the expr with the
5253 computed constant. */
5254
5255 ffebld
5256 ffeexpr_collapse_or (ffebld expr, ffelexToken t)
5257 {
5258 ffebad error = FFEBAD;
5259 ffebld l;
5260 ffebld r;
5261 ffebldConstantUnion u;
5262 ffeinfoBasictype bt;
5263 ffeinfoKindtype kt;
5264
5265 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5266 return expr;
5267
5268 l = ffebld_left (expr);
5269 r = ffebld_right (expr);
5270
5271 if (ffebld_op (l) != FFEBLD_opCONTER)
5272 return expr;
5273 if (ffebld_op (r) != FFEBLD_opCONTER)
5274 return expr;
5275
5276 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5277 {
5278 case FFEINFO_basictypeANY:
5279 return expr;
5280
5281 case FFEINFO_basictypeINTEGER:
5282 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5283 {
5284 #if FFETARGET_okINTEGER1
5285 case FFEINFO_kindtypeINTEGER1:
5286 error = ffetarget_or_integer1 (ffebld_cu_ptr_integer1 (u),
5287 ffebld_constant_integer1 (ffebld_conter (l)),
5288 ffebld_constant_integer1 (ffebld_conter (r)));
5289 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5290 (ffebld_cu_val_integer1 (u)), expr);
5291 break;
5292 #endif
5293
5294 #if FFETARGET_okINTEGER2
5295 case FFEINFO_kindtypeINTEGER2:
5296 error = ffetarget_or_integer2 (ffebld_cu_ptr_integer2 (u),
5297 ffebld_constant_integer2 (ffebld_conter (l)),
5298 ffebld_constant_integer2 (ffebld_conter (r)));
5299 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5300 (ffebld_cu_val_integer2 (u)), expr);
5301 break;
5302 #endif
5303
5304 #if FFETARGET_okINTEGER3
5305 case FFEINFO_kindtypeINTEGER3:
5306 error = ffetarget_or_integer3 (ffebld_cu_ptr_integer3 (u),
5307 ffebld_constant_integer3 (ffebld_conter (l)),
5308 ffebld_constant_integer3 (ffebld_conter (r)));
5309 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5310 (ffebld_cu_val_integer3 (u)), expr);
5311 break;
5312 #endif
5313
5314 #if FFETARGET_okINTEGER4
5315 case FFEINFO_kindtypeINTEGER4:
5316 error = ffetarget_or_integer4 (ffebld_cu_ptr_integer4 (u),
5317 ffebld_constant_integer4 (ffebld_conter (l)),
5318 ffebld_constant_integer4 (ffebld_conter (r)));
5319 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5320 (ffebld_cu_val_integer4 (u)), expr);
5321 break;
5322 #endif
5323
5324 default:
5325 assert ("bad integer kind type" == NULL);
5326 break;
5327 }
5328 break;
5329
5330 case FFEINFO_basictypeLOGICAL:
5331 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5332 {
5333 #if FFETARGET_okLOGICAL1
5334 case FFEINFO_kindtypeLOGICAL1:
5335 error = ffetarget_or_logical1 (ffebld_cu_ptr_logical1 (u),
5336 ffebld_constant_logical1 (ffebld_conter (l)),
5337 ffebld_constant_logical1 (ffebld_conter (r)));
5338 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5339 (ffebld_cu_val_logical1 (u)), expr);
5340 break;
5341 #endif
5342
5343 #if FFETARGET_okLOGICAL2
5344 case FFEINFO_kindtypeLOGICAL2:
5345 error = ffetarget_or_logical2 (ffebld_cu_ptr_logical2 (u),
5346 ffebld_constant_logical2 (ffebld_conter (l)),
5347 ffebld_constant_logical2 (ffebld_conter (r)));
5348 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5349 (ffebld_cu_val_logical2 (u)), expr);
5350 break;
5351 #endif
5352
5353 #if FFETARGET_okLOGICAL3
5354 case FFEINFO_kindtypeLOGICAL3:
5355 error = ffetarget_or_logical3 (ffebld_cu_ptr_logical3 (u),
5356 ffebld_constant_logical3 (ffebld_conter (l)),
5357 ffebld_constant_logical3 (ffebld_conter (r)));
5358 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5359 (ffebld_cu_val_logical3 (u)), expr);
5360 break;
5361 #endif
5362
5363 #if FFETARGET_okLOGICAL4
5364 case FFEINFO_kindtypeLOGICAL4:
5365 error = ffetarget_or_logical4 (ffebld_cu_ptr_logical4 (u),
5366 ffebld_constant_logical4 (ffebld_conter (l)),
5367 ffebld_constant_logical4 (ffebld_conter (r)));
5368 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5369 (ffebld_cu_val_logical4 (u)), expr);
5370 break;
5371 #endif
5372
5373 default:
5374 assert ("bad logical kind type" == NULL);
5375 break;
5376 }
5377 break;
5378
5379 default:
5380 assert ("bad type" == NULL);
5381 return expr;
5382 }
5383
5384 ffebld_set_info (expr, ffeinfo_new
5385 (bt,
5386 kt,
5387 0,
5388 FFEINFO_kindENTITY,
5389 FFEINFO_whereCONSTANT,
5390 FFETARGET_charactersizeNONE));
5391
5392 if ((error != FFEBAD)
5393 && ffebad_start (error))
5394 {
5395 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5396 ffebad_finish ();
5397 }
5398
5399 return expr;
5400 }
5401
5402 /* ffeexpr_collapse_xor -- Collapse xor expr
5403
5404 ffebld expr;
5405 ffelexToken token;
5406 expr = ffeexpr_collapse_xor(expr,token);
5407
5408 If the result of the expr is a constant, replaces the expr with the
5409 computed constant. */
5410
5411 ffebld
5412 ffeexpr_collapse_xor (ffebld expr, ffelexToken t)
5413 {
5414 ffebad error = FFEBAD;
5415 ffebld l;
5416 ffebld r;
5417 ffebldConstantUnion u;
5418 ffeinfoBasictype bt;
5419 ffeinfoKindtype kt;
5420
5421 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5422 return expr;
5423
5424 l = ffebld_left (expr);
5425 r = ffebld_right (expr);
5426
5427 if (ffebld_op (l) != FFEBLD_opCONTER)
5428 return expr;
5429 if (ffebld_op (r) != FFEBLD_opCONTER)
5430 return expr;
5431
5432 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5433 {
5434 case FFEINFO_basictypeANY:
5435 return expr;
5436
5437 case FFEINFO_basictypeINTEGER:
5438 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5439 {
5440 #if FFETARGET_okINTEGER1
5441 case FFEINFO_kindtypeINTEGER1:
5442 error = ffetarget_xor_integer1 (ffebld_cu_ptr_integer1 (u),
5443 ffebld_constant_integer1 (ffebld_conter (l)),
5444 ffebld_constant_integer1 (ffebld_conter (r)));
5445 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5446 (ffebld_cu_val_integer1 (u)), expr);
5447 break;
5448 #endif
5449
5450 #if FFETARGET_okINTEGER2
5451 case FFEINFO_kindtypeINTEGER2:
5452 error = ffetarget_xor_integer2 (ffebld_cu_ptr_integer2 (u),
5453 ffebld_constant_integer2 (ffebld_conter (l)),
5454 ffebld_constant_integer2 (ffebld_conter (r)));
5455 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5456 (ffebld_cu_val_integer2 (u)), expr);
5457 break;
5458 #endif
5459
5460 #if FFETARGET_okINTEGER3
5461 case FFEINFO_kindtypeINTEGER3:
5462 error = ffetarget_xor_integer3 (ffebld_cu_ptr_integer3 (u),
5463 ffebld_constant_integer3 (ffebld_conter (l)),
5464 ffebld_constant_integer3 (ffebld_conter (r)));
5465 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5466 (ffebld_cu_val_integer3 (u)), expr);
5467 break;
5468 #endif
5469
5470 #if FFETARGET_okINTEGER4
5471 case FFEINFO_kindtypeINTEGER4:
5472 error = ffetarget_xor_integer4 (ffebld_cu_ptr_integer4 (u),
5473 ffebld_constant_integer4 (ffebld_conter (l)),
5474 ffebld_constant_integer4 (ffebld_conter (r)));
5475 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5476 (ffebld_cu_val_integer4 (u)), expr);
5477 break;
5478 #endif
5479
5480 default:
5481 assert ("bad integer kind type" == NULL);
5482 break;
5483 }
5484 break;
5485
5486 case FFEINFO_basictypeLOGICAL:
5487 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5488 {
5489 #if FFETARGET_okLOGICAL1
5490 case FFEINFO_kindtypeLOGICAL1:
5491 error = ffetarget_xor_logical1 (ffebld_cu_ptr_logical1 (u),
5492 ffebld_constant_logical1 (ffebld_conter (l)),
5493 ffebld_constant_logical1 (ffebld_conter (r)));
5494 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5495 (ffebld_cu_val_logical1 (u)), expr);
5496 break;
5497 #endif
5498
5499 #if FFETARGET_okLOGICAL2
5500 case FFEINFO_kindtypeLOGICAL2:
5501 error = ffetarget_xor_logical2 (ffebld_cu_ptr_logical2 (u),
5502 ffebld_constant_logical2 (ffebld_conter (l)),
5503 ffebld_constant_logical2 (ffebld_conter (r)));
5504 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5505 (ffebld_cu_val_logical2 (u)), expr);
5506 break;
5507 #endif
5508
5509 #if FFETARGET_okLOGICAL3
5510 case FFEINFO_kindtypeLOGICAL3:
5511 error = ffetarget_xor_logical3 (ffebld_cu_ptr_logical3 (u),
5512 ffebld_constant_logical3 (ffebld_conter (l)),
5513 ffebld_constant_logical3 (ffebld_conter (r)));
5514 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5515 (ffebld_cu_val_logical3 (u)), expr);
5516 break;
5517 #endif
5518
5519 #if FFETARGET_okLOGICAL4
5520 case FFEINFO_kindtypeLOGICAL4:
5521 error = ffetarget_xor_logical4 (ffebld_cu_ptr_logical4 (u),
5522 ffebld_constant_logical4 (ffebld_conter (l)),
5523 ffebld_constant_logical4 (ffebld_conter (r)));
5524 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5525 (ffebld_cu_val_logical4 (u)), expr);
5526 break;
5527 #endif
5528
5529 default:
5530 assert ("bad logical kind type" == NULL);
5531 break;
5532 }
5533 break;
5534
5535 default:
5536 assert ("bad type" == NULL);
5537 return expr;
5538 }
5539
5540 ffebld_set_info (expr, ffeinfo_new
5541 (bt,
5542 kt,
5543 0,
5544 FFEINFO_kindENTITY,
5545 FFEINFO_whereCONSTANT,
5546 FFETARGET_charactersizeNONE));
5547
5548 if ((error != FFEBAD)
5549 && ffebad_start (error))
5550 {
5551 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5552 ffebad_finish ();
5553 }
5554
5555 return expr;
5556 }
5557
5558 /* ffeexpr_collapse_eqv -- Collapse eqv expr
5559
5560 ffebld expr;
5561 ffelexToken token;
5562 expr = ffeexpr_collapse_eqv(expr,token);
5563
5564 If the result of the expr is a constant, replaces the expr with the
5565 computed constant. */
5566
5567 ffebld
5568 ffeexpr_collapse_eqv (ffebld expr, ffelexToken t)
5569 {
5570 ffebad error = FFEBAD;
5571 ffebld l;
5572 ffebld r;
5573 ffebldConstantUnion u;
5574 ffeinfoBasictype bt;
5575 ffeinfoKindtype kt;
5576
5577 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5578 return expr;
5579
5580 l = ffebld_left (expr);
5581 r = ffebld_right (expr);
5582
5583 if (ffebld_op (l) != FFEBLD_opCONTER)
5584 return expr;
5585 if (ffebld_op (r) != FFEBLD_opCONTER)
5586 return expr;
5587
5588 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5589 {
5590 case FFEINFO_basictypeANY:
5591 return expr;
5592
5593 case FFEINFO_basictypeINTEGER:
5594 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5595 {
5596 #if FFETARGET_okINTEGER1
5597 case FFEINFO_kindtypeINTEGER1:
5598 error = ffetarget_eqv_integer1 (ffebld_cu_ptr_integer1 (u),
5599 ffebld_constant_integer1 (ffebld_conter (l)),
5600 ffebld_constant_integer1 (ffebld_conter (r)));
5601 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5602 (ffebld_cu_val_integer1 (u)), expr);
5603 break;
5604 #endif
5605
5606 #if FFETARGET_okINTEGER2
5607 case FFEINFO_kindtypeINTEGER2:
5608 error = ffetarget_eqv_integer2 (ffebld_cu_ptr_integer2 (u),
5609 ffebld_constant_integer2 (ffebld_conter (l)),
5610 ffebld_constant_integer2 (ffebld_conter (r)));
5611 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5612 (ffebld_cu_val_integer2 (u)), expr);
5613 break;
5614 #endif
5615
5616 #if FFETARGET_okINTEGER3
5617 case FFEINFO_kindtypeINTEGER3:
5618 error = ffetarget_eqv_integer3 (ffebld_cu_ptr_integer3 (u),
5619 ffebld_constant_integer3 (ffebld_conter (l)),
5620 ffebld_constant_integer3 (ffebld_conter (r)));
5621 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5622 (ffebld_cu_val_integer3 (u)), expr);
5623 break;
5624 #endif
5625
5626 #if FFETARGET_okINTEGER4
5627 case FFEINFO_kindtypeINTEGER4:
5628 error = ffetarget_eqv_integer4 (ffebld_cu_ptr_integer4 (u),
5629 ffebld_constant_integer4 (ffebld_conter (l)),
5630 ffebld_constant_integer4 (ffebld_conter (r)));
5631 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5632 (ffebld_cu_val_integer4 (u)), expr);
5633 break;
5634 #endif
5635
5636 default:
5637 assert ("bad integer kind type" == NULL);
5638 break;
5639 }
5640 break;
5641
5642 case FFEINFO_basictypeLOGICAL:
5643 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5644 {
5645 #if FFETARGET_okLOGICAL1
5646 case FFEINFO_kindtypeLOGICAL1:
5647 error = ffetarget_eqv_logical1 (ffebld_cu_ptr_logical1 (u),
5648 ffebld_constant_logical1 (ffebld_conter (l)),
5649 ffebld_constant_logical1 (ffebld_conter (r)));
5650 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5651 (ffebld_cu_val_logical1 (u)), expr);
5652 break;
5653 #endif
5654
5655 #if FFETARGET_okLOGICAL2
5656 case FFEINFO_kindtypeLOGICAL2:
5657 error = ffetarget_eqv_logical2 (ffebld_cu_ptr_logical2 (u),
5658 ffebld_constant_logical2 (ffebld_conter (l)),
5659 ffebld_constant_logical2 (ffebld_conter (r)));
5660 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5661 (ffebld_cu_val_logical2 (u)), expr);
5662 break;
5663 #endif
5664
5665 #if FFETARGET_okLOGICAL3
5666 case FFEINFO_kindtypeLOGICAL3:
5667 error = ffetarget_eqv_logical3 (ffebld_cu_ptr_logical3 (u),
5668 ffebld_constant_logical3 (ffebld_conter (l)),
5669 ffebld_constant_logical3 (ffebld_conter (r)));
5670 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5671 (ffebld_cu_val_logical3 (u)), expr);
5672 break;
5673 #endif
5674
5675 #if FFETARGET_okLOGICAL4
5676 case FFEINFO_kindtypeLOGICAL4:
5677 error = ffetarget_eqv_logical4 (ffebld_cu_ptr_logical4 (u),
5678 ffebld_constant_logical4 (ffebld_conter (l)),
5679 ffebld_constant_logical4 (ffebld_conter (r)));
5680 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5681 (ffebld_cu_val_logical4 (u)), expr);
5682 break;
5683 #endif
5684
5685 default:
5686 assert ("bad logical kind type" == NULL);
5687 break;
5688 }
5689 break;
5690
5691 default:
5692 assert ("bad type" == NULL);
5693 return expr;
5694 }
5695
5696 ffebld_set_info (expr, ffeinfo_new
5697 (bt,
5698 kt,
5699 0,
5700 FFEINFO_kindENTITY,
5701 FFEINFO_whereCONSTANT,
5702 FFETARGET_charactersizeNONE));
5703
5704 if ((error != FFEBAD)
5705 && ffebad_start (error))
5706 {
5707 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5708 ffebad_finish ();
5709 }
5710
5711 return expr;
5712 }
5713
5714 /* ffeexpr_collapse_neqv -- Collapse neqv expr
5715
5716 ffebld expr;
5717 ffelexToken token;
5718 expr = ffeexpr_collapse_neqv(expr,token);
5719
5720 If the result of the expr is a constant, replaces the expr with the
5721 computed constant. */
5722
5723 ffebld
5724 ffeexpr_collapse_neqv (ffebld expr, ffelexToken t)
5725 {
5726 ffebad error = FFEBAD;
5727 ffebld l;
5728 ffebld r;
5729 ffebldConstantUnion u;
5730 ffeinfoBasictype bt;
5731 ffeinfoKindtype kt;
5732
5733 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5734 return expr;
5735
5736 l = ffebld_left (expr);
5737 r = ffebld_right (expr);
5738
5739 if (ffebld_op (l) != FFEBLD_opCONTER)
5740 return expr;
5741 if (ffebld_op (r) != FFEBLD_opCONTER)
5742 return expr;
5743
5744 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5745 {
5746 case FFEINFO_basictypeANY:
5747 return expr;
5748
5749 case FFEINFO_basictypeINTEGER:
5750 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5751 {
5752 #if FFETARGET_okINTEGER1
5753 case FFEINFO_kindtypeINTEGER1:
5754 error = ffetarget_neqv_integer1 (ffebld_cu_ptr_integer1 (u),
5755 ffebld_constant_integer1 (ffebld_conter (l)),
5756 ffebld_constant_integer1 (ffebld_conter (r)));
5757 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5758 (ffebld_cu_val_integer1 (u)), expr);
5759 break;
5760 #endif
5761
5762 #if FFETARGET_okINTEGER2
5763 case FFEINFO_kindtypeINTEGER2:
5764 error = ffetarget_neqv_integer2 (ffebld_cu_ptr_integer2 (u),
5765 ffebld_constant_integer2 (ffebld_conter (l)),
5766 ffebld_constant_integer2 (ffebld_conter (r)));
5767 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5768 (ffebld_cu_val_integer2 (u)), expr);
5769 break;
5770 #endif
5771
5772 #if FFETARGET_okINTEGER3
5773 case FFEINFO_kindtypeINTEGER3:
5774 error = ffetarget_neqv_integer3 (ffebld_cu_ptr_integer3 (u),
5775 ffebld_constant_integer3 (ffebld_conter (l)),
5776 ffebld_constant_integer3 (ffebld_conter (r)));
5777 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5778 (ffebld_cu_val_integer3 (u)), expr);
5779 break;
5780 #endif
5781
5782 #if FFETARGET_okINTEGER4
5783 case FFEINFO_kindtypeINTEGER4:
5784 error = ffetarget_neqv_integer4 (ffebld_cu_ptr_integer4 (u),
5785 ffebld_constant_integer4 (ffebld_conter (l)),
5786 ffebld_constant_integer4 (ffebld_conter (r)));
5787 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5788 (ffebld_cu_val_integer4 (u)), expr);
5789 break;
5790 #endif
5791
5792 default:
5793 assert ("bad integer kind type" == NULL);
5794 break;
5795 }
5796 break;
5797
5798 case FFEINFO_basictypeLOGICAL:
5799 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5800 {
5801 #if FFETARGET_okLOGICAL1
5802 case FFEINFO_kindtypeLOGICAL1:
5803 error = ffetarget_neqv_logical1 (ffebld_cu_ptr_logical1 (u),
5804 ffebld_constant_logical1 (ffebld_conter (l)),
5805 ffebld_constant_logical1 (ffebld_conter (r)));
5806 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5807 (ffebld_cu_val_logical1 (u)), expr);
5808 break;
5809 #endif
5810
5811 #if FFETARGET_okLOGICAL2
5812 case FFEINFO_kindtypeLOGICAL2:
5813 error = ffetarget_neqv_logical2 (ffebld_cu_ptr_logical2 (u),
5814 ffebld_constant_logical2 (ffebld_conter (l)),
5815 ffebld_constant_logical2 (ffebld_conter (r)));
5816 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5817 (ffebld_cu_val_logical2 (u)), expr);
5818 break;
5819 #endif
5820
5821 #if FFETARGET_okLOGICAL3
5822 case FFEINFO_kindtypeLOGICAL3:
5823 error = ffetarget_neqv_logical3 (ffebld_cu_ptr_logical3 (u),
5824 ffebld_constant_logical3 (ffebld_conter (l)),
5825 ffebld_constant_logical3 (ffebld_conter (r)));
5826 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5827 (ffebld_cu_val_logical3 (u)), expr);
5828 break;
5829 #endif
5830
5831 #if FFETARGET_okLOGICAL4
5832 case FFEINFO_kindtypeLOGICAL4:
5833 error = ffetarget_neqv_logical4 (ffebld_cu_ptr_logical4 (u),
5834 ffebld_constant_logical4 (ffebld_conter (l)),
5835 ffebld_constant_logical4 (ffebld_conter (r)));
5836 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5837 (ffebld_cu_val_logical4 (u)), expr);
5838 break;
5839 #endif
5840
5841 default:
5842 assert ("bad logical kind type" == NULL);
5843 break;
5844 }
5845 break;
5846
5847 default:
5848 assert ("bad type" == NULL);
5849 return expr;
5850 }
5851
5852 ffebld_set_info (expr, ffeinfo_new
5853 (bt,
5854 kt,
5855 0,
5856 FFEINFO_kindENTITY,
5857 FFEINFO_whereCONSTANT,
5858 FFETARGET_charactersizeNONE));
5859
5860 if ((error != FFEBAD)
5861 && ffebad_start (error))
5862 {
5863 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5864 ffebad_finish ();
5865 }
5866
5867 return expr;
5868 }
5869
5870 /* ffeexpr_collapse_symter -- Collapse symter expr
5871
5872 ffebld expr;
5873 ffelexToken token;
5874 expr = ffeexpr_collapse_symter(expr,token);
5875
5876 If the result of the expr is a constant, replaces the expr with the
5877 computed constant. */
5878
5879 ffebld
5880 ffeexpr_collapse_symter (ffebld expr, ffelexToken t UNUSED)
5881 {
5882 ffebld r;
5883 ffeinfoBasictype bt;
5884 ffeinfoKindtype kt;
5885 ffetargetCharacterSize len;
5886
5887 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5888 return expr;
5889
5890 if ((r = ffesymbol_init (ffebld_symter (expr))) == NULL)
5891 return expr; /* A PARAMETER lhs in progress. */
5892
5893 switch (ffebld_op (r))
5894 {
5895 case FFEBLD_opCONTER:
5896 break;
5897
5898 case FFEBLD_opANY:
5899 return r;
5900
5901 default:
5902 return expr;
5903 }
5904
5905 bt = ffeinfo_basictype (ffebld_info (r));
5906 kt = ffeinfo_kindtype (ffebld_info (r));
5907 len = ffebld_size (r);
5908
5909 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
5910 expr);
5911
5912 ffebld_set_info (expr, ffeinfo_new
5913 (bt,
5914 kt,
5915 0,
5916 FFEINFO_kindENTITY,
5917 FFEINFO_whereCONSTANT,
5918 len));
5919
5920 return expr;
5921 }
5922
5923 /* ffeexpr_collapse_funcref -- Collapse funcref expr
5924
5925 ffebld expr;
5926 ffelexToken token;
5927 expr = ffeexpr_collapse_funcref(expr,token);
5928
5929 If the result of the expr is a constant, replaces the expr with the
5930 computed constant. */
5931
5932 ffebld
5933 ffeexpr_collapse_funcref (ffebld expr, ffelexToken t UNUSED)
5934 {
5935 return expr; /* ~~someday go ahead and collapse these,
5936 though not required */
5937 }
5938
5939 /* ffeexpr_collapse_arrayref -- Collapse arrayref expr
5940
5941 ffebld expr;
5942 ffelexToken token;
5943 expr = ffeexpr_collapse_arrayref(expr,token);
5944
5945 If the result of the expr is a constant, replaces the expr with the
5946 computed constant. */
5947
5948 ffebld
5949 ffeexpr_collapse_arrayref (ffebld expr, ffelexToken t UNUSED)
5950 {
5951 return expr;
5952 }
5953
5954 /* ffeexpr_collapse_substr -- Collapse substr expr
5955
5956 ffebld expr;
5957 ffelexToken token;
5958 expr = ffeexpr_collapse_substr(expr,token);
5959
5960 If the result of the expr is a constant, replaces the expr with the
5961 computed constant. */
5962
5963 ffebld
5964 ffeexpr_collapse_substr (ffebld expr, ffelexToken t)
5965 {
5966 ffebad error = FFEBAD;
5967 ffebld l;
5968 ffebld r;
5969 ffebld start;
5970 ffebld stop;
5971 ffebldConstantUnion u;
5972 ffeinfoKindtype kt;
5973 ffetargetCharacterSize len;
5974 ffetargetIntegerDefault first;
5975 ffetargetIntegerDefault last;
5976
5977 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5978 return expr;
5979
5980 l = ffebld_left (expr);
5981 r = ffebld_right (expr); /* opITEM. */
5982
5983 if (ffebld_op (l) != FFEBLD_opCONTER)
5984 return expr;
5985
5986 kt = ffeinfo_kindtype (ffebld_info (l));
5987 len = ffebld_size (l);
5988
5989 start = ffebld_head (r);
5990 stop = ffebld_head (ffebld_trail (r));
5991 if (start == NULL)
5992 first = 1;
5993 else
5994 {
5995 if ((ffebld_op (start) != FFEBLD_opCONTER)
5996 || (ffeinfo_basictype (ffebld_info (start)) != FFEINFO_basictypeINTEGER)
5997 || (ffeinfo_kindtype (ffebld_info (start))
5998 != FFEINFO_kindtypeINTEGERDEFAULT))
5999 return expr;
6000 first = ffebld_constant_integerdefault (ffebld_conter (start));
6001 }
6002 if (stop == NULL)
6003 last = len;
6004 else
6005 {
6006 if ((ffebld_op (stop) != FFEBLD_opCONTER)
6007 || (ffeinfo_basictype (ffebld_info (stop)) != FFEINFO_basictypeINTEGER)
6008 || (ffeinfo_kindtype (ffebld_info (stop))
6009 != FFEINFO_kindtypeINTEGERDEFAULT))
6010 return expr;
6011 last = ffebld_constant_integerdefault (ffebld_conter (stop));
6012 }
6013
6014 /* Handle problems that should have already been diagnosed, but
6015 left in the expression tree. */
6016
6017 if (first <= 0)
6018 first = 1;
6019 if (last < first)
6020 last = first + len - 1;
6021
6022 if ((first == 1) && (last == len))
6023 { /* Same as original. */
6024 expr = ffebld_new_conter_with_orig (ffebld_constant_copy
6025 (ffebld_conter (l)), expr);
6026 ffebld_set_info (expr, ffeinfo_new
6027 (FFEINFO_basictypeCHARACTER,
6028 kt,
6029 0,
6030 FFEINFO_kindENTITY,
6031 FFEINFO_whereCONSTANT,
6032 len));
6033
6034 return expr;
6035 }
6036
6037 switch (ffeinfo_basictype (ffebld_info (expr)))
6038 {
6039 case FFEINFO_basictypeANY:
6040 return expr;
6041
6042 case FFEINFO_basictypeCHARACTER:
6043 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6044 {
6045 #if FFETARGET_okCHARACTER1
6046 case FFEINFO_kindtypeCHARACTER1:
6047 error = ffetarget_substr_character1 (ffebld_cu_ptr_character1 (u),
6048 ffebld_constant_character1 (ffebld_conter (l)), first, last,
6049 ffebld_constant_pool (), &len);
6050 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
6051 (ffebld_cu_val_character1 (u)), expr);
6052 break;
6053 #endif
6054
6055 default:
6056 assert ("bad character kind type" == NULL);
6057 break;
6058 }
6059 break;
6060
6061 default:
6062 assert ("bad type" == NULL);
6063 return expr;
6064 }
6065
6066 ffebld_set_info (expr, ffeinfo_new
6067 (FFEINFO_basictypeCHARACTER,
6068 kt,
6069 0,
6070 FFEINFO_kindENTITY,
6071 FFEINFO_whereCONSTANT,
6072 len));
6073
6074 if ((error != FFEBAD)
6075 && ffebad_start (error))
6076 {
6077 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6078 ffebad_finish ();
6079 }
6080
6081 return expr;
6082 }
6083
6084 /* ffeexpr_convert -- Convert source expression to given type
6085
6086 ffebld source;
6087 ffelexToken source_token;
6088 ffelexToken dest_token; // Any appropriate token for "destination".
6089 ffeinfoBasictype bt;
6090 ffeinfoKindtype kt;
6091 ffetargetCharactersize sz;
6092 ffeexprContext context; // Mainly LET or DATA.
6093 source = ffeexpr_convert(source,source_token,dest_token,bt,kt,sz,context);
6094
6095 If the expression conforms, returns the source expression. Otherwise
6096 returns source wrapped in a convert node doing the conversion, or
6097 ANY wrapped in convert if there is a conversion error (and issues an
6098 error message). Be sensitive to the context for certain aspects of
6099 the conversion. */
6100
6101 ffebld
6102 ffeexpr_convert (ffebld source, ffelexToken source_token, ffelexToken dest_token,
6103 ffeinfoBasictype bt, ffeinfoKindtype kt, ffeinfoRank rk,
6104 ffetargetCharacterSize sz, ffeexprContext context)
6105 {
6106 bool bad;
6107 ffeinfo info;
6108 ffeinfoWhere wh;
6109
6110 info = ffebld_info (source);
6111 if ((bt != ffeinfo_basictype (info))
6112 || (kt != ffeinfo_kindtype (info))
6113 || (rk != 0) /* Can't convert from or to arrays yet. */
6114 || (ffeinfo_rank (info) != 0)
6115 || (sz != ffebld_size_known (source)))
6116 #if 0 /* Nobody seems to need this spurious CONVERT node. */
6117 || ((context != FFEEXPR_contextLET)
6118 && (bt == FFEINFO_basictypeCHARACTER)
6119 && (sz == FFETARGET_charactersizeNONE)))
6120 #endif
6121 {
6122 switch (ffeinfo_basictype (info))
6123 {
6124 case FFEINFO_basictypeLOGICAL:
6125 switch (bt)
6126 {
6127 case FFEINFO_basictypeLOGICAL:
6128 bad = FALSE;
6129 break;
6130
6131 case FFEINFO_basictypeINTEGER:
6132 bad = !ffe_is_ugly_logint ();
6133 break;
6134
6135 case FFEINFO_basictypeCHARACTER:
6136 bad = ffe_is_pedantic ()
6137 || !(ffe_is_ugly_init ()
6138 && (context == FFEEXPR_contextDATA));
6139 break;
6140
6141 default:
6142 bad = TRUE;
6143 break;
6144 }
6145 break;
6146
6147 case FFEINFO_basictypeINTEGER:
6148 switch (bt)
6149 {
6150 case FFEINFO_basictypeINTEGER:
6151 case FFEINFO_basictypeREAL:
6152 case FFEINFO_basictypeCOMPLEX:
6153 bad = FALSE;
6154 break;
6155
6156 case FFEINFO_basictypeLOGICAL:
6157 bad = !ffe_is_ugly_logint ();
6158 break;
6159
6160 case FFEINFO_basictypeCHARACTER:
6161 bad = ffe_is_pedantic ()
6162 || !(ffe_is_ugly_init ()
6163 && (context == FFEEXPR_contextDATA));
6164 break;
6165
6166 default:
6167 bad = TRUE;
6168 break;
6169 }
6170 break;
6171
6172 case FFEINFO_basictypeREAL:
6173 case FFEINFO_basictypeCOMPLEX:
6174 switch (bt)
6175 {
6176 case FFEINFO_basictypeINTEGER:
6177 case FFEINFO_basictypeREAL:
6178 case FFEINFO_basictypeCOMPLEX:
6179 bad = FALSE;
6180 break;
6181
6182 case FFEINFO_basictypeCHARACTER:
6183 bad = TRUE;
6184 break;
6185
6186 default:
6187 bad = TRUE;
6188 break;
6189 }
6190 break;
6191
6192 case FFEINFO_basictypeCHARACTER:
6193 bad = (bt != FFEINFO_basictypeCHARACTER)
6194 && (ffe_is_pedantic ()
6195 || (bt != FFEINFO_basictypeINTEGER)
6196 || !(ffe_is_ugly_init ()
6197 && (context == FFEEXPR_contextDATA)));
6198 break;
6199
6200 case FFEINFO_basictypeTYPELESS:
6201 case FFEINFO_basictypeHOLLERITH:
6202 bad = ffe_is_pedantic ()
6203 || !(ffe_is_ugly_init ()
6204 && ((context == FFEEXPR_contextDATA)
6205 || (context == FFEEXPR_contextLET)));
6206 break;
6207
6208 default:
6209 bad = TRUE;
6210 break;
6211 }
6212
6213 if (!bad && ((rk != 0) || (ffeinfo_rank (info) != 0)))
6214 bad = TRUE;
6215
6216 if (bad && (bt != FFEINFO_basictypeANY) && (kt != FFEINFO_kindtypeANY)
6217 && (ffeinfo_basictype (info) != FFEINFO_basictypeANY)
6218 && (ffeinfo_kindtype (info) != FFEINFO_kindtypeANY)
6219 && (ffeinfo_where (info) != FFEINFO_whereANY))
6220 {
6221 if (ffebad_start (FFEBAD_BAD_TYPES))
6222 {
6223 if (dest_token == NULL)
6224 ffebad_here (0, ffewhere_line_unknown (),
6225 ffewhere_column_unknown ());
6226 else
6227 ffebad_here (0, ffelex_token_where_line (dest_token),
6228 ffelex_token_where_column (dest_token));
6229 assert (source_token != NULL);
6230 ffebad_here (1, ffelex_token_where_line (source_token),
6231 ffelex_token_where_column (source_token));
6232 ffebad_finish ();
6233 }
6234
6235 source = ffebld_new_any ();
6236 ffebld_set_info (source, ffeinfo_new_any ());
6237 }
6238 else
6239 {
6240 switch (ffeinfo_where (info))
6241 {
6242 case FFEINFO_whereCONSTANT:
6243 wh = FFEINFO_whereCONSTANT;
6244 break;
6245
6246 case FFEINFO_whereIMMEDIATE:
6247 wh = FFEINFO_whereIMMEDIATE;
6248 break;
6249
6250 default:
6251 wh = FFEINFO_whereFLEETING;
6252 break;
6253 }
6254 source = ffebld_new_convert (source);
6255 ffebld_set_info (source, ffeinfo_new
6256 (bt,
6257 kt,
6258 0,
6259 FFEINFO_kindENTITY,
6260 wh,
6261 sz));
6262 source = ffeexpr_collapse_convert (source, source_token);
6263 }
6264 }
6265
6266 return source;
6267 }
6268
6269 /* ffeexpr_convert_expr -- Convert source expr to conform to dest expr
6270
6271 ffebld source;
6272 ffebld dest;
6273 ffelexToken source_token;
6274 ffelexToken dest_token;
6275 ffeexprContext context;
6276 source = ffeexpr_convert_expr(source,source_token,dest,dest_token,context);
6277
6278 If the expressions conform, returns the source expression. Otherwise
6279 returns source wrapped in a convert node doing the conversion, or
6280 ANY wrapped in convert if there is a conversion error (and issues an
6281 error message). Be sensitive to the context, such as LET or DATA. */
6282
6283 ffebld
6284 ffeexpr_convert_expr (ffebld source, ffelexToken source_token, ffebld dest,
6285 ffelexToken dest_token, ffeexprContext context)
6286 {
6287 ffeinfo info;
6288
6289 info = ffebld_info (dest);
6290 return ffeexpr_convert (source, source_token, dest_token,
6291 ffeinfo_basictype (info),
6292 ffeinfo_kindtype (info),
6293 ffeinfo_rank (info),
6294 ffebld_size_known (dest),
6295 context);
6296 }
6297
6298 /* ffeexpr_convert_to_sym -- Convert source expression to conform to symbol
6299
6300 ffebld source;
6301 ffesymbol dest;
6302 ffelexToken source_token;
6303 ffelexToken dest_token;
6304 source = ffeexpr_convert_to_sym(source,source_token,dest,dest_token);
6305
6306 If the expressions conform, returns the source expression. Otherwise
6307 returns source wrapped in a convert node doing the conversion, or
6308 ANY wrapped in convert if there is a conversion error (and issues an
6309 error message). */
6310
6311 ffebld
6312 ffeexpr_convert_to_sym (ffebld source, ffelexToken source_token,
6313 ffesymbol dest, ffelexToken dest_token)
6314 {
6315 return ffeexpr_convert (source, source_token, dest_token, ffesymbol_basictype (dest),
6316 ffesymbol_kindtype (dest), ffesymbol_rank (dest), ffesymbol_size (dest),
6317 FFEEXPR_contextLET);
6318 }
6319
6320 /* Initializes the module. */
6321
6322 void
6323 ffeexpr_init_2 (void)
6324 {
6325 ffeexpr_stack_ = NULL;
6326 ffeexpr_level_ = 0;
6327 }
6328
6329 /* ffeexpr_lhs -- Begin processing left-hand-side-context expression
6330
6331 Prepares cluster for delivery of lexer tokens representing an expression
6332 in a left-hand-side context (A in A=B, for example). ffebld is used
6333 to build expressions in the given pool. The appropriate lexer-token
6334 handling routine within ffeexpr is returned. When the end of the
6335 expression is detected, mycallbackroutine is called with the resulting
6336 single ffebld object specifying the entire expression and the first
6337 lexer token that is not considered part of the expression. This caller-
6338 supplied routine itself returns a lexer-token handling routine. Thus,
6339 if necessary, ffeexpr can return several tokens as end-of-expression
6340 tokens if it needs to scan forward more than one in any instance. */
6341
6342 ffelexHandler
6343 ffeexpr_lhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
6344 {
6345 ffeexprStack_ s;
6346
6347 ffebld_pool_push (pool);
6348 s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
6349 s->previous = ffeexpr_stack_;
6350 s->pool = pool;
6351 s->context = context;
6352 s->callback = callback;
6353 s->first_token = NULL;
6354 s->exprstack = NULL;
6355 s->is_rhs = FALSE;
6356 ffeexpr_stack_ = s;
6357 return (ffelexHandler) ffeexpr_token_first_lhs_;
6358 }
6359
6360 /* ffeexpr_rhs -- Begin processing right-hand-side-context expression
6361
6362 return ffeexpr_rhs(malloc_pool_image(),mycallbackroutine); // to lexer.
6363
6364 Prepares cluster for delivery of lexer tokens representing an expression
6365 in a right-hand-side context (B in A=B, for example). ffebld is used
6366 to build expressions in the given pool. The appropriate lexer-token
6367 handling routine within ffeexpr is returned. When the end of the
6368 expression is detected, mycallbackroutine is called with the resulting
6369 single ffebld object specifying the entire expression and the first
6370 lexer token that is not considered part of the expression. This caller-
6371 supplied routine itself returns a lexer-token handling routine. Thus,
6372 if necessary, ffeexpr can return several tokens as end-of-expression
6373 tokens if it needs to scan forward more than one in any instance. */
6374
6375 ffelexHandler
6376 ffeexpr_rhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
6377 {
6378 ffeexprStack_ s;
6379
6380 ffebld_pool_push (pool);
6381 s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
6382 s->previous = ffeexpr_stack_;
6383 s->pool = pool;
6384 s->context = context;
6385 s->callback = callback;
6386 s->first_token = NULL;
6387 s->exprstack = NULL;
6388 s->is_rhs = TRUE;
6389 ffeexpr_stack_ = s;
6390 return (ffelexHandler) ffeexpr_token_first_rhs_;
6391 }
6392
6393 /* ffeexpr_cb_close_paren_ -- OPEN_PAREN expr
6394
6395 Pass it to ffeexpr_rhs as the callback routine.
6396
6397 Makes sure the end token is close-paren and swallows it, else issues
6398 an error message and doesn't swallow the token (passing it along instead).
6399 In either case wraps up subexpression construction by enclosing the
6400 ffebld expression in a paren. */
6401
6402 static ffelexHandler
6403 ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr, ffelexToken t)
6404 {
6405 ffeexprExpr_ e;
6406
6407 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
6408 {
6409 /* Oops, naughty user didn't specify the close paren! */
6410
6411 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
6412 {
6413 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6414 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
6415 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
6416 ffebad_finish ();
6417 }
6418
6419 e = ffeexpr_expr_new_ ();
6420 e->type = FFEEXPR_exprtypeOPERAND_;
6421 e->u.operand = ffebld_new_any ();
6422 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
6423 ffeexpr_exprstack_push_operand_ (e);
6424
6425 return
6426 (ffelexHandler) ffeexpr_find_close_paren_ (t,
6427 (ffelexHandler)
6428 ffeexpr_token_binary_);
6429 }
6430
6431 if (expr->op == FFEBLD_opIMPDO)
6432 {
6433 if (ffest_ffebad_start (FFEBAD_IMPDO_PAREN))
6434 {
6435 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
6436 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
6437 ffebad_finish ();
6438 }
6439 }
6440 else
6441 {
6442 expr = ffebld_new_paren (expr);
6443 ffebld_set_info (expr, ffeinfo_use (ffebld_info (ffebld_left (expr))));
6444 }
6445
6446 /* Now push the (parenthesized) expression as an operand onto the
6447 expression stack. */
6448
6449 e = ffeexpr_expr_new_ ();
6450 e->type = FFEEXPR_exprtypeOPERAND_;
6451 e->u.operand = expr;
6452 e->u.operand = ffeexpr_collapse_paren (e->u.operand, ft);
6453 e->token = ffeexpr_stack_->tokens[0];
6454 ffeexpr_exprstack_push_operand_ (e);
6455
6456 return (ffelexHandler) ffeexpr_token_binary_;
6457 }
6458
6459 /* ffeexpr_cb_close_paren_ambig_ -- OPEN_PAREN expr
6460
6461 Pass it to ffeexpr_rhs as the callback routine.
6462
6463 We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
6464 with the next token in t. If the next token is possibly a binary
6465 operator, continue processing the outer expression. If the next
6466 token is COMMA, then the expression is a unit specifier, and
6467 parentheses should not be added to it because it surrounds the
6468 I/O control list that starts with the unit specifier (and continues
6469 on from here -- we haven't seen the CLOSE_PAREN that matches the
6470 OPEN_PAREN, it is up to the callback function to expect to see it
6471 at some point). In this case, we notify the callback function that
6472 the COMMA is inside, not outside, the parens by wrapping the expression
6473 in an opITEM (with a NULL trail) -- the callback function presumably
6474 unwraps it after seeing this kludgey indicator.
6475
6476 If the next token is CLOSE_PAREN, then we go to the _1_ state to
6477 decide what to do with the token after that.
6478
6479 15-Feb-91 JCB 1.1
6480 Use an extra state for the CLOSE_PAREN case to make READ &co really
6481 work right. */
6482
6483 static ffelexHandler
6484 ffeexpr_cb_close_paren_ambig_ (ffelexToken ft, ffebld expr, ffelexToken t)
6485 {
6486 ffeexprCallback callback;
6487 ffeexprStack_ s;
6488
6489 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
6490 { /* Need to see the next token before we
6491 decide anything. */
6492 ffeexpr_stack_->expr = expr;
6493 ffeexpr_tokens_[0] = ffelex_token_use (ft);
6494 ffeexpr_tokens_[1] = ffelex_token_use (t);
6495 return (ffelexHandler) ffeexpr_cb_close_paren_ambig_1_;
6496 }
6497
6498 expr = ffeexpr_finished_ambig_ (ft, expr);
6499
6500 /* Let the callback function handle the case where t isn't COMMA. */
6501
6502 /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
6503 that preceded the expression starts a list of expressions, and the expr
6504 hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
6505 node. The callback function should extract the real expr from the head
6506 of this opITEM node after testing it. */
6507
6508 expr = ffebld_new_item (expr, NULL);
6509
6510 ffebld_pool_pop ();
6511 callback = ffeexpr_stack_->callback;
6512 ffelex_token_kill (ffeexpr_stack_->first_token);
6513 s = ffeexpr_stack_->previous;
6514 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
6515 ffeexpr_stack_ = s;
6516 return (ffelexHandler) (*callback) (ft, expr, t);
6517 }
6518
6519 /* ffeexpr_cb_close_paren_ambig_1_ -- OPEN_PAREN expr CLOSE_PAREN
6520
6521 See ffeexpr_cb_close_paren_ambig_.
6522
6523 We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
6524 with the next token in t. If the next token is possibly a binary
6525 operator, continue processing the outer expression. If the next
6526 token is COMMA, the expression is a parenthesized format specifier.
6527 If the next token is not EOS or SEMICOLON, then because it is not a
6528 binary operator (it is NAME, OPEN_PAREN, &c), the expression is
6529 a unit specifier, and parentheses should not be added to it because
6530 they surround the I/O control list that consists of only the unit
6531 specifier. If the next token is EOS or SEMICOLON, the statement
6532 must be disambiguated by looking at the type of the expression -- a
6533 character expression is a parenthesized format specifier, while a
6534 non-character expression is a unit specifier.
6535
6536 Another issue is how to do the callback so the recipient of the
6537 next token knows how to handle it if it is a COMMA. In all other
6538 cases, disambiguation is straightforward: the same approach as the
6539 above is used.
6540
6541 EXTENSION: in COMMA case, if not pedantic, use same disambiguation
6542 as for EOS/SEMICOLON case; f2c allows "READ (cilist) [[,]iolist]"
6543 and apparently other compilers do, as well, and some code out there
6544 uses this "feature".
6545
6546 19-Feb-91 JCB 1.1
6547 Extend to allow COMMA as nondisambiguating by itself. Remember
6548 to not try and check info field for opSTAR, since that expr doesn't
6549 have a valid info field. */
6550
6551 static ffelexHandler
6552 ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t)
6553 {
6554 ffeexprCallback callback;
6555 ffeexprStack_ s;
6556 ffelexHandler next;
6557 ffelexToken orig_ft = ffeexpr_tokens_[0]; /* In case callback clobbers
6558 these. */
6559 ffelexToken orig_t = ffeexpr_tokens_[1];
6560 ffebld expr = ffeexpr_stack_->expr;
6561
6562 switch (ffelex_token_type (t))
6563 {
6564 case FFELEX_typeCOMMA: /* Subexpr is parenthesized format specifier. */
6565 if (ffe_is_pedantic ())
6566 goto pedantic_comma; /* :::::::::::::::::::: */
6567 /* Fall through. */
6568 case FFELEX_typeEOS: /* Ambiguous; use type of expr to
6569 disambiguate. */
6570 case FFELEX_typeSEMICOLON:
6571 if ((expr == NULL) || (ffebld_op (expr) == FFEBLD_opANY)
6572 || (ffebld_op (expr) == FFEBLD_opSTAR)
6573 || (ffeinfo_basictype (ffebld_info (expr))
6574 != FFEINFO_basictypeCHARACTER))
6575 break; /* Not a valid CHARACTER entity, can't be a
6576 format spec. */
6577 /* Fall through. */
6578 default: /* Binary op (we assume; error otherwise);
6579 format specifier. */
6580
6581 pedantic_comma: /* :::::::::::::::::::: */
6582
6583 switch (ffeexpr_stack_->context)
6584 {
6585 case FFEEXPR_contextFILENUMAMBIG:
6586 ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
6587 break;
6588
6589 case FFEEXPR_contextFILEUNITAMBIG:
6590 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
6591 break;
6592
6593 default:
6594 assert ("bad context" == NULL);
6595 break;
6596 }
6597
6598 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
6599 next = (ffelexHandler) ffeexpr_cb_close_paren_ (orig_ft, expr, orig_t);
6600 ffelex_token_kill (orig_ft);
6601 ffelex_token_kill (orig_t);
6602 return (ffelexHandler) (*next) (t);
6603
6604 case FFELEX_typeOPEN_PAREN:/* Non-binary op; beginning of I/O list. */
6605 case FFELEX_typeNAME:
6606 break;
6607 }
6608
6609 expr = ffeexpr_finished_ambig_ (orig_ft, expr);
6610
6611 /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
6612 that preceded the expression starts a list of expressions, and the expr
6613 hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
6614 node. The callback function should extract the real expr from the head
6615 of this opITEM node after testing it. */
6616
6617 expr = ffebld_new_item (expr, NULL);
6618
6619 ffebld_pool_pop ();
6620 callback = ffeexpr_stack_->callback;
6621 ffelex_token_kill (ffeexpr_stack_->first_token);
6622 s = ffeexpr_stack_->previous;
6623 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
6624 ffeexpr_stack_ = s;
6625 next = (ffelexHandler) (*callback) (orig_ft, expr, orig_t);
6626 ffelex_token_kill (orig_ft);
6627 ffelex_token_kill (orig_t);
6628 return (ffelexHandler) (*next) (t);
6629 }
6630
6631 /* ffeexpr_cb_close_paren_c_ -- OPEN_PAREN expr (possible complex)
6632
6633 Pass it to ffeexpr_rhs as the callback routine.
6634
6635 Makes sure the end token is close-paren and swallows it, or a comma
6636 and handles complex/implied-do possibilities, else issues
6637 an error message and doesn't swallow the token (passing it along instead). */
6638
6639 static ffelexHandler
6640 ffeexpr_cb_close_paren_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
6641 {
6642 /* First check to see if this is a possible complex entity. It is if the
6643 token is a comma. */
6644
6645 if (ffelex_token_type (t) == FFELEX_typeCOMMA)
6646 {
6647 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
6648 ffeexpr_stack_->expr = expr;
6649 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
6650 FFEEXPR_contextPAREN_, ffeexpr_cb_comma_c_);
6651 }
6652
6653 return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
6654 }
6655
6656 /* ffeexpr_cb_comma_c_ -- OPEN_PAREN expr COMMA expr
6657
6658 Pass it to ffeexpr_rhs as the callback routine.
6659
6660 If this token is not a comma, we have a complex constant (or an attempt
6661 at one), so handle it accordingly, displaying error messages if the token
6662 is not a close-paren. */
6663
6664 static ffelexHandler
6665 ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
6666 {
6667 ffeexprExpr_ e;
6668 ffeinfoBasictype lty = (ffeexpr_stack_->expr == NULL)
6669 ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (ffeexpr_stack_->expr));
6670 ffeinfoBasictype rty = (expr == NULL)
6671 ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (expr));
6672 ffeinfoKindtype lkt;
6673 ffeinfoKindtype rkt;
6674 ffeinfoKindtype nkt;
6675 bool ok = TRUE;
6676 ffebld orig;
6677
6678 if ((ffeexpr_stack_->expr == NULL)
6679 || (ffebld_op (ffeexpr_stack_->expr) != FFEBLD_opCONTER)
6680 || (((orig = ffebld_conter_orig (ffeexpr_stack_->expr)) != NULL)
6681 && (((ffebld_op (orig) != FFEBLD_opUMINUS)
6682 && (ffebld_op (orig) != FFEBLD_opUPLUS))
6683 || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
6684 || ((lty != FFEINFO_basictypeINTEGER)
6685 && (lty != FFEINFO_basictypeREAL)))
6686 {
6687 if ((lty != FFEINFO_basictypeANY)
6688 && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
6689 {
6690 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
6691 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
6692 ffebad_string ("Real");
6693 ffebad_finish ();
6694 }
6695 ok = FALSE;
6696 }
6697 if ((expr == NULL)
6698 || (ffebld_op (expr) != FFEBLD_opCONTER)
6699 || (((orig = ffebld_conter_orig (expr)) != NULL)
6700 && (((ffebld_op (orig) != FFEBLD_opUMINUS)
6701 && (ffebld_op (orig) != FFEBLD_opUPLUS))
6702 || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
6703 || ((rty != FFEINFO_basictypeINTEGER)
6704 && (rty != FFEINFO_basictypeREAL)))
6705 {
6706 if ((rty != FFEINFO_basictypeANY)
6707 && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
6708 {
6709 ffebad_here (0, ffelex_token_where_line (ft),
6710 ffelex_token_where_column (ft));
6711 ffebad_string ("Imaginary");
6712 ffebad_finish ();
6713 }
6714 ok = FALSE;
6715 }
6716
6717 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
6718
6719 /* Push the (parenthesized) expression as an operand onto the expression
6720 stack. */
6721
6722 e = ffeexpr_expr_new_ ();
6723 e->type = FFEEXPR_exprtypeOPERAND_;
6724 e->token = ffeexpr_stack_->tokens[0];
6725
6726 if (ok)
6727 {
6728 if (lty == FFEINFO_basictypeINTEGER)
6729 lkt = FFEINFO_kindtypeREALDEFAULT;
6730 else
6731 lkt = ffeinfo_kindtype (ffebld_info (ffeexpr_stack_->expr));
6732 if (rty == FFEINFO_basictypeINTEGER)
6733 rkt = FFEINFO_kindtypeREALDEFAULT;
6734 else
6735 rkt = ffeinfo_kindtype (ffebld_info (expr));
6736
6737 nkt = ffeinfo_kindtype_max (FFEINFO_basictypeCOMPLEX, lkt, rkt);
6738 ffeexpr_stack_->expr = ffeexpr_convert (ffeexpr_stack_->expr,
6739 ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
6740 FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
6741 FFEEXPR_contextLET);
6742 expr = ffeexpr_convert (expr,
6743 ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
6744 FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
6745 FFEEXPR_contextLET);
6746 }
6747 else
6748 nkt = FFEINFO_kindtypeANY;
6749
6750 switch (nkt)
6751 {
6752 #if FFETARGET_okCOMPLEX1
6753 case FFEINFO_kindtypeREAL1:
6754 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex1
6755 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
6756 ffebld_set_info (e->u.operand,
6757 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
6758 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
6759 FFETARGET_charactersizeNONE));
6760 break;
6761 #endif
6762
6763 #if FFETARGET_okCOMPLEX2
6764 case FFEINFO_kindtypeREAL2:
6765 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex2
6766 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
6767 ffebld_set_info (e->u.operand,
6768 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
6769 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
6770 FFETARGET_charactersizeNONE));
6771 break;
6772 #endif
6773
6774 #if FFETARGET_okCOMPLEX3
6775 case FFEINFO_kindtypeREAL3:
6776 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex3
6777 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
6778 ffebld_set_info (e->u.operand,
6779 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
6780 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
6781 FFETARGET_charactersizeNONE));
6782 break;
6783 #endif
6784
6785 default:
6786 if (ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
6787 ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX))
6788 {
6789 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
6790 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
6791 ffebad_finish ();
6792 }
6793 /* Fall through. */
6794 case FFEINFO_kindtypeANY:
6795 e->u.operand = ffebld_new_any ();
6796 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
6797 break;
6798 }
6799 ffeexpr_exprstack_push_operand_ (e);
6800
6801 /* Now, if the token is a close parenthese, we're in great shape so return
6802 the next handler. */
6803
6804 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
6805 return (ffelexHandler) ffeexpr_token_binary_;
6806
6807 /* Oops, naughty user didn't specify the close paren! */
6808
6809 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
6810 {
6811 ffebad_here (0, ffelex_token_where_line (t),
6812 ffelex_token_where_column (t));
6813 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
6814 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
6815 ffebad_finish ();
6816 }
6817
6818 return
6819 (ffelexHandler) ffeexpr_find_close_paren_ (t,
6820 (ffelexHandler)
6821 ffeexpr_token_binary_);
6822 }
6823
6824 /* ffeexpr_cb_close_paren_ci_ -- OPEN_PAREN expr (possible complex or
6825 implied-DO construct)
6826
6827 Pass it to ffeexpr_rhs as the callback routine.
6828
6829 Makes sure the end token is close-paren and swallows it, or a comma
6830 and handles complex/implied-do possibilities, else issues
6831 an error message and doesn't swallow the token (passing it along instead). */
6832
6833 static ffelexHandler
6834 ffeexpr_cb_close_paren_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
6835 {
6836 ffeexprContext ctx;
6837
6838 /* First check to see if this is a possible complex or implied-DO entity.
6839 It is if the token is a comma. */
6840
6841 if (ffelex_token_type (t) == FFELEX_typeCOMMA)
6842 {
6843 switch (ffeexpr_stack_->context)
6844 {
6845 case FFEEXPR_contextIOLIST:
6846 case FFEEXPR_contextIMPDOITEM_:
6847 ctx = FFEEXPR_contextIMPDOITEM_;
6848 break;
6849
6850 case FFEEXPR_contextIOLISTDF:
6851 case FFEEXPR_contextIMPDOITEMDF_:
6852 ctx = FFEEXPR_contextIMPDOITEMDF_;
6853 break;
6854
6855 default:
6856 assert ("bad context" == NULL);
6857 ctx = FFEEXPR_contextIMPDOITEM_;
6858 break;
6859 }
6860
6861 ffeexpr_stack_->tokens[0] = ffelex_token_use (ft);
6862 ffeexpr_stack_->expr = expr;
6863 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
6864 ctx, ffeexpr_cb_comma_ci_);
6865 }
6866
6867 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
6868 return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
6869 }
6870
6871 /* ffeexpr_cb_comma_ci_ -- OPEN_PAREN expr COMMA expr
6872
6873 Pass it to ffeexpr_rhs as the callback routine.
6874
6875 If this token is not a comma, we have a complex constant (or an attempt
6876 at one), so handle it accordingly, displaying error messages if the token
6877 is not a close-paren. If we have a comma here, it is an attempt at an
6878 implied-DO, so start making a list accordingly. Oh, it might be an
6879 equal sign also, meaning an implied-DO with only one item in its list. */
6880
6881 static ffelexHandler
6882 ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
6883 {
6884 ffebld fexpr;
6885
6886 /* First check to see if this is a possible complex constant. It is if the
6887 token is not a comma or an equals sign, in which case it should be a
6888 close-paren. */
6889
6890 if ((ffelex_token_type (t) != FFELEX_typeCOMMA)
6891 && (ffelex_token_type (t) != FFELEX_typeEQUALS))
6892 {
6893 ffeexpr_stack_->tokens[1] = ffeexpr_stack_->tokens[0];
6894 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
6895 return (ffelexHandler) ffeexpr_cb_comma_c_ (ft, expr, t);
6896 }
6897
6898 /* Here we have either EQUALS or COMMA, meaning we are in an implied-DO
6899 construct. Make a list and handle accordingly. */
6900
6901 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
6902 fexpr = ffeexpr_stack_->expr;
6903 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
6904 ffebld_append_item (&ffeexpr_stack_->bottom, fexpr);
6905 return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
6906 }
6907
6908 /* ffeexpr_cb_comma_i_ -- OPEN_PAREN expr
6909
6910 Pass it to ffeexpr_rhs as the callback routine.
6911
6912 Handle first item in an implied-DO construct. */
6913
6914 static ffelexHandler
6915 ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr, ffelexToken t)
6916 {
6917 if (ffelex_token_type (t) != FFELEX_typeCOMMA)
6918 {
6919 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
6920 {
6921 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6922 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
6923 ffelex_token_where_column (ffeexpr_stack_->first_token));
6924 ffebad_finish ();
6925 }
6926 ffebld_end_list (&ffeexpr_stack_->bottom);
6927 ffeexpr_stack_->expr = ffebld_new_any ();
6928 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
6929 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
6930 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
6931 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
6932 }
6933
6934 return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
6935 }
6936
6937 /* ffeexpr_cb_comma_i_1_ -- OPEN_PAREN expr
6938
6939 Pass it to ffeexpr_rhs as the callback routine.
6940
6941 Handle first item in an implied-DO construct. */
6942
6943 static ffelexHandler
6944 ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr, ffelexToken t)
6945 {
6946 ffeexprContext ctxi;
6947 ffeexprContext ctxc;
6948
6949 switch (ffeexpr_stack_->context)
6950 {
6951 case FFEEXPR_contextDATA:
6952 case FFEEXPR_contextDATAIMPDOITEM_:
6953 ctxi = FFEEXPR_contextDATAIMPDOITEM_;
6954 ctxc = FFEEXPR_contextDATAIMPDOCTRL_;
6955 break;
6956
6957 case FFEEXPR_contextIOLIST:
6958 case FFEEXPR_contextIMPDOITEM_:
6959 ctxi = FFEEXPR_contextIMPDOITEM_;
6960 ctxc = FFEEXPR_contextIMPDOCTRL_;
6961 break;
6962
6963 case FFEEXPR_contextIOLISTDF:
6964 case FFEEXPR_contextIMPDOITEMDF_:
6965 ctxi = FFEEXPR_contextIMPDOITEMDF_;
6966 ctxc = FFEEXPR_contextIMPDOCTRL_;
6967 break;
6968
6969 default:
6970 assert ("bad context" == NULL);
6971 ctxi = FFEEXPR_context;
6972 ctxc = FFEEXPR_context;
6973 break;
6974 }
6975
6976 switch (ffelex_token_type (t))
6977 {
6978 case FFELEX_typeCOMMA:
6979 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
6980 if (ffeexpr_stack_->is_rhs)
6981 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
6982 ctxi, ffeexpr_cb_comma_i_1_);
6983 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
6984 ctxi, ffeexpr_cb_comma_i_1_);
6985
6986 case FFELEX_typeEQUALS:
6987 ffebld_end_list (&ffeexpr_stack_->bottom);
6988
6989 /* Complain if implied-DO variable in list of items to be read. */
6990
6991 if ((ctxc == FFEEXPR_contextIMPDOCTRL_) && !ffeexpr_stack_->is_rhs)
6992 ffeexpr_check_impdo_ (ffeexpr_stack_->expr,
6993 ffeexpr_stack_->first_token, expr, ft);
6994
6995 /* Set doiter flag for all appropriate SYMTERs. */
6996
6997 ffeexpr_update_impdo_ (ffeexpr_stack_->expr, expr);
6998
6999 ffeexpr_stack_->expr = ffebld_new_impdo (ffeexpr_stack_->expr, NULL);
7000 ffebld_set_info (ffeexpr_stack_->expr,
7001 ffeinfo_new (FFEINFO_basictypeNONE,
7002 FFEINFO_kindtypeNONE,
7003 0,
7004 FFEINFO_kindNONE,
7005 FFEINFO_whereNONE,
7006 FFETARGET_charactersizeNONE));
7007 ffebld_init_list (&(ffebld_right (ffeexpr_stack_->expr)),
7008 &ffeexpr_stack_->bottom);
7009 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7010 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7011 ctxc, ffeexpr_cb_comma_i_2_);
7012
7013 default:
7014 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7015 {
7016 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7017 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7018 ffelex_token_where_column (ffeexpr_stack_->first_token));
7019 ffebad_finish ();
7020 }
7021 ffebld_end_list (&ffeexpr_stack_->bottom);
7022 ffeexpr_stack_->expr = ffebld_new_any ();
7023 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7024 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7025 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7026 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7027 }
7028 }
7029
7030 /* ffeexpr_cb_comma_i_2_ -- OPEN_PAREN expr-list EQUALS expr
7031
7032 Pass it to ffeexpr_rhs as the callback routine.
7033
7034 Handle start-value in an implied-DO construct. */
7035
7036 static ffelexHandler
7037 ffeexpr_cb_comma_i_2_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7038 {
7039 ffeexprContext ctx;
7040
7041 switch (ffeexpr_stack_->context)
7042 {
7043 case FFEEXPR_contextDATA:
7044 case FFEEXPR_contextDATAIMPDOITEM_:
7045 ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7046 break;
7047
7048 case FFEEXPR_contextIOLIST:
7049 case FFEEXPR_contextIOLISTDF:
7050 case FFEEXPR_contextIMPDOITEM_:
7051 case FFEEXPR_contextIMPDOITEMDF_:
7052 ctx = FFEEXPR_contextIMPDOCTRL_;
7053 break;
7054
7055 default:
7056 assert ("bad context" == NULL);
7057 ctx = FFEEXPR_context;
7058 break;
7059 }
7060
7061 switch (ffelex_token_type (t))
7062 {
7063 case FFELEX_typeCOMMA:
7064 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7065 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7066 ctx, ffeexpr_cb_comma_i_3_);
7067 break;
7068
7069 default:
7070 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7071 {
7072 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7073 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7074 ffelex_token_where_column (ffeexpr_stack_->first_token));
7075 ffebad_finish ();
7076 }
7077 ffebld_end_list (&ffeexpr_stack_->bottom);
7078 ffeexpr_stack_->expr = ffebld_new_any ();
7079 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7080 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7081 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7082 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7083 }
7084 }
7085
7086 /* ffeexpr_cb_comma_i_3_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7087
7088 Pass it to ffeexpr_rhs as the callback routine.
7089
7090 Handle end-value in an implied-DO construct. */
7091
7092 static ffelexHandler
7093 ffeexpr_cb_comma_i_3_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7094 {
7095 ffeexprContext ctx;
7096
7097 switch (ffeexpr_stack_->context)
7098 {
7099 case FFEEXPR_contextDATA:
7100 case FFEEXPR_contextDATAIMPDOITEM_:
7101 ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7102 break;
7103
7104 case FFEEXPR_contextIOLIST:
7105 case FFEEXPR_contextIOLISTDF:
7106 case FFEEXPR_contextIMPDOITEM_:
7107 case FFEEXPR_contextIMPDOITEMDF_:
7108 ctx = FFEEXPR_contextIMPDOCTRL_;
7109 break;
7110
7111 default:
7112 assert ("bad context" == NULL);
7113 ctx = FFEEXPR_context;
7114 break;
7115 }
7116
7117 switch (ffelex_token_type (t))
7118 {
7119 case FFELEX_typeCOMMA:
7120 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7121 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7122 ctx, ffeexpr_cb_comma_i_4_);
7123 break;
7124
7125 case FFELEX_typeCLOSE_PAREN:
7126 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7127 return (ffelexHandler) ffeexpr_cb_comma_i_4_ (NULL, NULL, t);
7128 break;
7129
7130 default:
7131 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7132 {
7133 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7134 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7135 ffelex_token_where_column (ffeexpr_stack_->first_token));
7136 ffebad_finish ();
7137 }
7138 ffebld_end_list (&ffeexpr_stack_->bottom);
7139 ffeexpr_stack_->expr = ffebld_new_any ();
7140 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7141 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7142 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7143 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7144 }
7145 }
7146
7147 /* ffeexpr_cb_comma_i_4_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7148 [COMMA expr]
7149
7150 Pass it to ffeexpr_rhs as the callback routine.
7151
7152 Handle incr-value in an implied-DO construct. */
7153
7154 static ffelexHandler
7155 ffeexpr_cb_comma_i_4_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7156 {
7157 switch (ffelex_token_type (t))
7158 {
7159 case FFELEX_typeCLOSE_PAREN:
7160 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7161 ffebld_end_list (&ffeexpr_stack_->bottom);
7162 {
7163 ffebld item;
7164
7165 for (item = ffebld_left (ffeexpr_stack_->expr);
7166 item != NULL;
7167 item = ffebld_trail (item))
7168 if (ffebld_op (ffebld_head (item)) == FFEBLD_opANY)
7169 goto replace_with_any; /* :::::::::::::::::::: */
7170
7171 for (item = ffebld_right (ffeexpr_stack_->expr);
7172 item != NULL;
7173 item = ffebld_trail (item))
7174 if ((ffebld_head (item) != NULL) /* Increment may be NULL. */
7175 && (ffebld_op (ffebld_head (item)) == FFEBLD_opANY))
7176 goto replace_with_any; /* :::::::::::::::::::: */
7177 }
7178 break;
7179
7180 default:
7181 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7182 {
7183 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7184 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7185 ffelex_token_where_column (ffeexpr_stack_->first_token));
7186 ffebad_finish ();
7187 }
7188 ffebld_end_list (&ffeexpr_stack_->bottom);
7189
7190 replace_with_any: /* :::::::::::::::::::: */
7191
7192 ffeexpr_stack_->expr = ffebld_new_any ();
7193 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7194 break;
7195 }
7196
7197 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7198 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7199 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7200 }
7201
7202 /* ffeexpr_cb_comma_i_5_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7203 [COMMA expr] CLOSE_PAREN
7204
7205 Pass it to ffeexpr_rhs as the callback routine.
7206
7207 Collects token following implied-DO construct for callback function. */
7208
7209 static ffelexHandler
7210 ffeexpr_cb_comma_i_5_ (ffelexToken t)
7211 {
7212 ffeexprCallback callback;
7213 ffeexprStack_ s;
7214 ffelexHandler next;
7215 ffelexToken ft;
7216 ffebld expr;
7217 bool terminate;
7218
7219 switch (ffeexpr_stack_->context)
7220 {
7221 case FFEEXPR_contextDATA:
7222 case FFEEXPR_contextDATAIMPDOITEM_:
7223 terminate = TRUE;
7224 break;
7225
7226 case FFEEXPR_contextIOLIST:
7227 case FFEEXPR_contextIOLISTDF:
7228 case FFEEXPR_contextIMPDOITEM_:
7229 case FFEEXPR_contextIMPDOITEMDF_:
7230 terminate = FALSE;
7231 break;
7232
7233 default:
7234 assert ("bad context" == NULL);
7235 terminate = FALSE;
7236 break;
7237 }
7238
7239 ffebld_pool_pop ();
7240 callback = ffeexpr_stack_->callback;
7241 ft = ffeexpr_stack_->first_token;
7242 expr = ffeexpr_stack_->expr;
7243 s = ffeexpr_stack_->previous;
7244 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
7245 sizeof (*ffeexpr_stack_));
7246 ffeexpr_stack_ = s;
7247 next = (ffelexHandler) (*callback) (ft, expr, t);
7248 ffelex_token_kill (ft);
7249 if (terminate)
7250 {
7251 ffesymbol_drive_sfnames (ffeexpr_check_impctrl_);
7252 --ffeexpr_level_;
7253 if (ffeexpr_level_ == 0)
7254 ffe_terminate_4 ();
7255 }
7256 return (ffelexHandler) next;
7257 }
7258
7259 /* ffeexpr_cb_end_loc_ -- Handle end of %LOC subexpression
7260
7261 Makes sure the end token is close-paren and swallows it, else issues
7262 an error message and doesn't swallow the token (passing it along instead).
7263 In either case wraps up subexpression construction by enclosing the
7264 ffebld expression in a %LOC. */
7265
7266 static ffelexHandler
7267 ffeexpr_cb_end_loc_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7268 {
7269 ffeexprExpr_ e;
7270
7271 /* First push the (%LOC) expression as an operand onto the expression
7272 stack. */
7273
7274 e = ffeexpr_expr_new_ ();
7275 e->type = FFEEXPR_exprtypeOPERAND_;
7276 e->token = ffeexpr_stack_->tokens[0];
7277 e->u.operand = ffebld_new_percent_loc (expr);
7278 ffebld_set_info (e->u.operand,
7279 ffeinfo_new (FFEINFO_basictypeINTEGER,
7280 ffecom_pointer_kind (),
7281 0,
7282 FFEINFO_kindENTITY,
7283 FFEINFO_whereFLEETING,
7284 FFETARGET_charactersizeNONE));
7285 #if 0 /* ~~ */
7286 e->u.operand = ffeexpr_collapse_percent_loc (e->u.operand, ft);
7287 #endif
7288 ffeexpr_exprstack_push_operand_ (e);
7289
7290 /* Now, if the token is a close parenthese, we're in great shape so return
7291 the next handler. */
7292
7293 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7294 {
7295 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7296 return (ffelexHandler) ffeexpr_token_binary_;
7297 }
7298
7299 /* Oops, naughty user didn't specify the close paren! */
7300
7301 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7302 {
7303 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7304 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
7305 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
7306 ffebad_finish ();
7307 }
7308
7309 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7310 return
7311 (ffelexHandler) ffeexpr_find_close_paren_ (t,
7312 (ffelexHandler)
7313 ffeexpr_token_binary_);
7314 }
7315
7316 /* ffeexpr_cb_end_notloc_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
7317
7318 Should be CLOSE_PAREN, and make sure expr isn't a %(VAL,REF,DESCR). */
7319
7320 static ffelexHandler
7321 ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr, ffelexToken t)
7322 {
7323 ffeexprExpr_ e;
7324 ffebldOp op;
7325
7326 /* If expression is itself a %(VAL,REF,DESCR), complain and strip off all
7327 such things until the lowest-level expression is reached. */
7328
7329 op = ffebld_op (expr);
7330 if ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
7331 || (op == FFEBLD_opPERCENT_DESCR))
7332 {
7333 if (ffebad_start (FFEBAD_NESTED_PERCENT))
7334 {
7335 ffebad_here (0, ffelex_token_where_line (ft),
7336 ffelex_token_where_column (ft));
7337 ffebad_finish ();
7338 }
7339
7340 do
7341 {
7342 expr = ffebld_left (expr);
7343 op = ffebld_op (expr);
7344 }
7345 while ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
7346 || (op == FFEBLD_opPERCENT_DESCR));
7347 }
7348
7349 /* Push the expression as an operand onto the expression stack. */
7350
7351 e = ffeexpr_expr_new_ ();
7352 e->type = FFEEXPR_exprtypeOPERAND_;
7353 e->token = ffeexpr_stack_->tokens[0];
7354 switch (ffeexpr_stack_->percent)
7355 {
7356 case FFEEXPR_percentVAL_:
7357 e->u.operand = ffebld_new_percent_val (expr);
7358 break;
7359
7360 case FFEEXPR_percentREF_:
7361 e->u.operand = ffebld_new_percent_ref (expr);
7362 break;
7363
7364 case FFEEXPR_percentDESCR_:
7365 e->u.operand = ffebld_new_percent_descr (expr);
7366 break;
7367
7368 default:
7369 assert ("%lossage" == NULL);
7370 e->u.operand = expr;
7371 break;
7372 }
7373 ffebld_set_info (e->u.operand, ffebld_info (expr));
7374 #if 0 /* ~~ */
7375 e->u.operand = ffeexpr_collapse_percent_ ? ? ? (e->u.operand, ft);
7376 #endif
7377 ffeexpr_exprstack_push_operand_ (e);
7378
7379 /* Now, if the token is a close parenthese, we're in great shape so return
7380 the next handler. */
7381
7382 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7383 return (ffelexHandler) ffeexpr_cb_end_notloc_1_;
7384
7385 /* Oops, naughty user didn't specify the close paren! */
7386
7387 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7388 {
7389 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7390 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
7391 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
7392 ffebad_finish ();
7393 }
7394
7395 ffebld_set_op (e->u.operand, FFEBLD_opPERCENT_LOC);
7396
7397 switch (ffeexpr_stack_->context)
7398 {
7399 case FFEEXPR_contextACTUALARG_:
7400 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
7401 break;
7402
7403 case FFEEXPR_contextINDEXORACTUALARG_:
7404 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
7405 break;
7406
7407 case FFEEXPR_contextSFUNCDEFACTUALARG_:
7408 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
7409 break;
7410
7411 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
7412 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
7413 break;
7414
7415 default:
7416 assert ("bad context?!?!" == NULL);
7417 break;
7418 }
7419
7420 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7421 return
7422 (ffelexHandler) ffeexpr_find_close_paren_ (t,
7423 (ffelexHandler)
7424 ffeexpr_cb_end_notloc_1_);
7425 }
7426
7427 /* ffeexpr_cb_end_notloc_1_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
7428 CLOSE_PAREN
7429
7430 Should be COMMA or CLOSE_PAREN, else change back to %LOC. */
7431
7432 static ffelexHandler
7433 ffeexpr_cb_end_notloc_1_ (ffelexToken t)
7434 {
7435 switch (ffelex_token_type (t))
7436 {
7437 case FFELEX_typeCOMMA:
7438 case FFELEX_typeCLOSE_PAREN:
7439 switch (ffeexpr_stack_->context)
7440 {
7441 case FFEEXPR_contextACTUALARG_:
7442 case FFEEXPR_contextSFUNCDEFACTUALARG_:
7443 break;
7444
7445 case FFEEXPR_contextINDEXORACTUALARG_:
7446 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
7447 break;
7448
7449 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
7450 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
7451 break;
7452
7453 default:
7454 assert ("bad context?!?!" == NULL);
7455 break;
7456 }
7457 break;
7458
7459 default:
7460 if (ffebad_start (FFEBAD_INVALID_PERCENT))
7461 {
7462 ffebad_here (0,
7463 ffelex_token_where_line (ffeexpr_stack_->first_token),
7464 ffelex_token_where_column (ffeexpr_stack_->first_token));
7465 ffebad_string (ffelex_token_text (ffeexpr_stack_->tokens[1]));
7466 ffebad_finish ();
7467 }
7468
7469 ffebld_set_op (ffeexpr_stack_->exprstack->u.operand,
7470 FFEBLD_opPERCENT_LOC);
7471
7472 switch (ffeexpr_stack_->context)
7473 {
7474 case FFEEXPR_contextACTUALARG_:
7475 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
7476 break;
7477
7478 case FFEEXPR_contextINDEXORACTUALARG_:
7479 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
7480 break;
7481
7482 case FFEEXPR_contextSFUNCDEFACTUALARG_:
7483 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
7484 break;
7485
7486 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
7487 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
7488 break;
7489
7490 default:
7491 assert ("bad context?!?!" == NULL);
7492 break;
7493 }
7494 }
7495
7496 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7497 return
7498 (ffelexHandler) ffeexpr_token_binary_ (t);
7499 }
7500
7501 /* Process DATA implied-DO iterator variables as this implied-DO level
7502 terminates. At this point, ffeexpr_level_ == 1 when we see the
7503 last right-paren in "DATA (A(I),I=1,10)/.../". */
7504
7505 static ffesymbol
7506 ffeexpr_check_impctrl_ (ffesymbol s)
7507 {
7508 assert (s != NULL);
7509 assert (ffesymbol_sfdummyparent (s) != NULL);
7510
7511 switch (ffesymbol_state (s))
7512 {
7513 case FFESYMBOL_stateNONE: /* Used as iterator already. Now let symbol
7514 be used as iterator at any level at or
7515 innermore than the outermost of the
7516 current level and the symbol's current
7517 level. */
7518 if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
7519 {
7520 ffesymbol_signal_change (s);
7521 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
7522 ffesymbol_signal_unreported (s);
7523 }
7524 break;
7525
7526 case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO.
7527 Error if at outermost level, else it can
7528 still become an iterator. */
7529 if ((ffeexpr_level_ == 1)
7530 && ffebad_start (FFEBAD_BAD_IMPDCL))
7531 {
7532 ffebad_string (ffesymbol_text (s));
7533 ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
7534 ffebad_finish ();
7535 }
7536 break;
7537
7538 case FFESYMBOL_stateUNCERTAIN: /* Iterator. */
7539 assert (ffeexpr_level_ <= ffesymbol_maxentrynum (s));
7540 ffesymbol_signal_change (s);
7541 ffesymbol_set_state (s, FFESYMBOL_stateNONE);
7542 ffesymbol_signal_unreported (s);
7543 break;
7544
7545 case FFESYMBOL_stateUNDERSTOOD:
7546 break; /* ANY. */
7547
7548 default:
7549 assert ("Sasha Foo!!" == NULL);
7550 break;
7551 }
7552
7553 return s;
7554 }
7555
7556 /* Issue diagnostic if implied-DO variable appears in list of lhs
7557 expressions (as in "READ *, (I,I=1,10)"). */
7558
7559 static void
7560 ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
7561 ffebld dovar, ffelexToken dovar_t)
7562 {
7563 ffebld item;
7564 ffesymbol dovar_sym;
7565 int itemnum;
7566
7567 if (ffebld_op (dovar) != FFEBLD_opSYMTER)
7568 return; /* Presumably opANY. */
7569
7570 dovar_sym = ffebld_symter (dovar);
7571
7572 for (itemnum = 1; list != NULL; list = ffebld_trail (list), ++itemnum)
7573 {
7574 if (((item = ffebld_head (list)) != NULL)
7575 && (ffebld_op (item) == FFEBLD_opSYMTER)
7576 && (ffebld_symter (item) == dovar_sym))
7577 {
7578 char itemno[20];
7579
7580 sprintf (&itemno[0], "%d", itemnum);
7581 if (ffebad_start (FFEBAD_DOITER_IMPDO))
7582 {
7583 ffebad_here (0, ffelex_token_where_line (list_t),
7584 ffelex_token_where_column (list_t));
7585 ffebad_here (1, ffelex_token_where_line (dovar_t),
7586 ffelex_token_where_column (dovar_t));
7587 ffebad_string (ffesymbol_text (dovar_sym));
7588 ffebad_string (itemno);
7589 ffebad_finish ();
7590 }
7591 }
7592 }
7593 }
7594
7595 /* Decorate any SYMTERs referencing the DO variable with the "doiter"
7596 flag. */
7597
7598 static void
7599 ffeexpr_update_impdo_ (ffebld list, ffebld dovar)
7600 {
7601 ffesymbol dovar_sym;
7602
7603 if (ffebld_op (dovar) != FFEBLD_opSYMTER)
7604 return; /* Presumably opANY. */
7605
7606 dovar_sym = ffebld_symter (dovar);
7607
7608 ffeexpr_update_impdo_sym_ (list, dovar_sym); /* Recurse! */
7609 }
7610
7611 /* Recursive function to update any expr so SYMTERs have "doiter" flag
7612 if they refer to the given variable. */
7613
7614 static void
7615 ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar)
7616 {
7617 tail_recurse: /* :::::::::::::::::::: */
7618
7619 if (expr == NULL)
7620 return;
7621
7622 switch (ffebld_op (expr))
7623 {
7624 case FFEBLD_opSYMTER:
7625 if (ffebld_symter (expr) == dovar)
7626 ffebld_symter_set_is_doiter (expr, TRUE);
7627 break;
7628
7629 case FFEBLD_opITEM:
7630 ffeexpr_update_impdo_sym_ (ffebld_head (expr), dovar);
7631 expr = ffebld_trail (expr);
7632 goto tail_recurse; /* :::::::::::::::::::: */
7633
7634 default:
7635 break;
7636 }
7637
7638 switch (ffebld_arity (expr))
7639 {
7640 case 2:
7641 ffeexpr_update_impdo_sym_ (ffebld_left (expr), dovar);
7642 expr = ffebld_right (expr);
7643 goto tail_recurse; /* :::::::::::::::::::: */
7644
7645 case 1:
7646 expr = ffebld_left (expr);
7647 goto tail_recurse; /* :::::::::::::::::::: */
7648
7649 default:
7650 break;
7651 }
7652
7653 return;
7654 }
7655
7656 /* ffeexpr_context_outer_ -- Determine context of stack entry, skipping PARENs
7657
7658 if (ffeexpr_context_outer_(ffeexpr_stack_) == FFEEXPR_contextIF)
7659 // After zero or more PAREN_ contexts, an IF context exists */
7660
7661 static ffeexprContext
7662 ffeexpr_context_outer_ (ffeexprStack_ s)
7663 {
7664 assert (s != NULL);
7665
7666 for (;;)
7667 {
7668 switch (s->context)
7669 {
7670 case FFEEXPR_contextPAREN_:
7671 case FFEEXPR_contextPARENFILENUM_:
7672 case FFEEXPR_contextPARENFILEUNIT_:
7673 break;
7674
7675 default:
7676 return s->context;
7677 }
7678 s = s->previous;
7679 assert (s != NULL);
7680 }
7681 }
7682
7683 /* ffeexpr_percent_ -- Look up name in list of %FOO possibilities
7684
7685 ffeexprPercent_ p;
7686 ffelexToken t;
7687 p = ffeexpr_percent_(t);
7688
7689 Returns the identifier for the name, or the NONE identifier. */
7690
7691 static ffeexprPercent_
7692 ffeexpr_percent_ (ffelexToken t)
7693 {
7694 const char *p;
7695
7696 switch (ffelex_token_length (t))
7697 {
7698 case 3:
7699 switch (*(p = ffelex_token_text (t)))
7700 {
7701 case FFESRC_CASE_MATCH_INIT ('L', 'l', match_3l, no_match_3):
7702 if ((ffesrc_char_match_noninit (*++p, 'O', 'o'))
7703 && (ffesrc_char_match_noninit (*++p, 'C', 'c')))
7704 return FFEEXPR_percentLOC_;
7705 return FFEEXPR_percentNONE_;
7706
7707 case FFESRC_CASE_MATCH_INIT ('R', 'r', match_3r, no_match_3):
7708 if ((ffesrc_char_match_noninit (*++p, 'E', 'e'))
7709 && (ffesrc_char_match_noninit (*++p, 'F', 'f')))
7710 return FFEEXPR_percentREF_;
7711 return FFEEXPR_percentNONE_;
7712
7713 case FFESRC_CASE_MATCH_INIT ('V', 'v', match_3v, no_match_3):
7714 if ((ffesrc_char_match_noninit (*++p, 'A', 'a'))
7715 && (ffesrc_char_match_noninit (*++p, 'L', 'l')))
7716 return FFEEXPR_percentVAL_;
7717 return FFEEXPR_percentNONE_;
7718
7719 default:
7720 no_match_3: /* :::::::::::::::::::: */
7721 return FFEEXPR_percentNONE_;
7722 }
7723
7724 case 5:
7725 if (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "DESCR",
7726 "descr", "Descr") == 0)
7727 return FFEEXPR_percentDESCR_;
7728 return FFEEXPR_percentNONE_;
7729
7730 default:
7731 return FFEEXPR_percentNONE_;
7732 }
7733 }
7734
7735 /* ffeexpr_type_combine -- Binop combine types, check for mythical new COMPLEX
7736
7737 See prototype.
7738
7739 If combining the two basictype/kindtype pairs produces a COMPLEX with an
7740 unsupported kind type, complain and use the default kind type for
7741 COMPLEX. */
7742
7743 void
7744 ffeexpr_type_combine (ffeinfoBasictype *xnbt, ffeinfoKindtype *xnkt,
7745 ffeinfoBasictype lbt, ffeinfoKindtype lkt,
7746 ffeinfoBasictype rbt, ffeinfoKindtype rkt,
7747 ffelexToken t)
7748 {
7749 ffeinfoBasictype nbt;
7750 ffeinfoKindtype nkt;
7751
7752 nbt = ffeinfo_basictype_combine (lbt, rbt);
7753 if ((nbt == FFEINFO_basictypeCOMPLEX)
7754 && ((lbt == nbt) || (lbt == FFEINFO_basictypeREAL))
7755 && ((rbt == nbt) || (rbt == FFEINFO_basictypeREAL)))
7756 {
7757 nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
7758 if (ffe_is_pedantic_not_90 () && (nkt == FFEINFO_kindtypeREALDOUBLE))
7759 nkt = FFEINFO_kindtypeNONE; /* Force error. */
7760 switch (nkt)
7761 {
7762 #if FFETARGET_okCOMPLEX1
7763 case FFEINFO_kindtypeREAL1:
7764 #endif
7765 #if FFETARGET_okCOMPLEX2
7766 case FFEINFO_kindtypeREAL2:
7767 #endif
7768 #if FFETARGET_okCOMPLEX3
7769 case FFEINFO_kindtypeREAL3:
7770 #endif
7771 break; /* Fine and dandy. */
7772
7773 default:
7774 if (t != NULL)
7775 {
7776 ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
7777 ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX);
7778 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7779 ffebad_finish ();
7780 }
7781 nbt = FFEINFO_basictypeNONE;
7782 nkt = FFEINFO_kindtypeNONE;
7783 break;
7784
7785 case FFEINFO_kindtypeANY:
7786 nkt = FFEINFO_kindtypeREALDEFAULT;
7787 break;
7788 }
7789 }
7790 else
7791 { /* The normal stuff. */
7792 if (nbt == lbt)
7793 {
7794 if (nbt == rbt)
7795 nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
7796 else
7797 nkt = lkt;
7798 }
7799 else if (nbt == rbt)
7800 nkt = rkt;
7801 else
7802 { /* Let the caller do the complaining. */
7803 nbt = FFEINFO_basictypeNONE;
7804 nkt = FFEINFO_kindtypeNONE;
7805 }
7806 }
7807
7808 /* Always a good idea to avoid aliasing problems. */
7809
7810 *xnbt = nbt;
7811 *xnkt = nkt;
7812 }
7813
7814 /* ffeexpr_token_first_lhs_ -- First state for lhs expression
7815
7816 Return a pointer to this function to the lexer (ffelex), which will
7817 invoke it for the next token.
7818
7819 Record line and column of first token in expression, then invoke the
7820 initial-state lhs handler. */
7821
7822 static ffelexHandler
7823 ffeexpr_token_first_lhs_ (ffelexToken t)
7824 {
7825 ffeexpr_stack_->first_token = ffelex_token_use (t);
7826
7827 /* When changing the list of valid initial lhs tokens, check whether to
7828 update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
7829 READ (expr) <token> case -- it assumes it knows which tokens <token> can
7830 be to indicate an lhs (or implied DO), which right now is the set
7831 {NAME,OPEN_PAREN}.
7832
7833 This comment also appears in ffeexpr_token_lhs_. */
7834
7835 switch (ffelex_token_type (t))
7836 {
7837 case FFELEX_typeOPEN_PAREN:
7838 switch (ffeexpr_stack_->context)
7839 {
7840 case FFEEXPR_contextDATA:
7841 ffe_init_4 ();
7842 ffeexpr_level_ = 1; /* Level of DATA implied-DO construct. */
7843 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7844 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7845 FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
7846
7847 case FFEEXPR_contextDATAIMPDOITEM_:
7848 ++ffeexpr_level_; /* Level of DATA implied-DO construct. */
7849 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7850 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7851 FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
7852
7853 case FFEEXPR_contextIOLIST:
7854 case FFEEXPR_contextIMPDOITEM_:
7855 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7856 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7857 FFEEXPR_contextIMPDOITEM_, ffeexpr_cb_comma_i_);
7858
7859 case FFEEXPR_contextIOLISTDF:
7860 case FFEEXPR_contextIMPDOITEMDF_:
7861 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7862 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7863 FFEEXPR_contextIMPDOITEMDF_, ffeexpr_cb_comma_i_);
7864
7865 case FFEEXPR_contextFILEEXTFUNC:
7866 assert (ffeexpr_stack_->exprstack == NULL);
7867 return (ffelexHandler) ffeexpr_token_first_lhs_1_;
7868
7869 default:
7870 break;
7871 }
7872 break;
7873
7874 case FFELEX_typeNAME:
7875 switch (ffeexpr_stack_->context)
7876 {
7877 case FFEEXPR_contextFILENAMELIST:
7878 assert (ffeexpr_stack_->exprstack == NULL);
7879 return (ffelexHandler) ffeexpr_token_namelist_;
7880
7881 case FFEEXPR_contextFILEEXTFUNC:
7882 assert (ffeexpr_stack_->exprstack == NULL);
7883 return (ffelexHandler) ffeexpr_token_first_lhs_1_;
7884
7885 default:
7886 break;
7887 }
7888 break;
7889
7890 default:
7891 switch (ffeexpr_stack_->context)
7892 {
7893 case FFEEXPR_contextFILEEXTFUNC:
7894 assert (ffeexpr_stack_->exprstack == NULL);
7895 return (ffelexHandler) ffeexpr_token_first_lhs_1_;
7896
7897 default:
7898 break;
7899 }
7900 break;
7901 }
7902
7903 return (ffelexHandler) ffeexpr_token_lhs_ (t);
7904 }
7905
7906 /* ffeexpr_token_first_lhs_1_ -- NAME
7907
7908 return ffeexpr_token_first_lhs_1_; // to lexer
7909
7910 Handle NAME as an external function (USEROPEN= VXT extension to OPEN
7911 statement). */
7912
7913 static ffelexHandler
7914 ffeexpr_token_first_lhs_1_ (ffelexToken t)
7915 {
7916 ffeexprCallback callback;
7917 ffeexprStack_ s;
7918 ffelexHandler next;
7919 ffelexToken ft;
7920 ffesymbol sy = NULL;
7921 ffebld expr;
7922
7923 ffebld_pool_pop ();
7924 callback = ffeexpr_stack_->callback;
7925 ft = ffeexpr_stack_->first_token;
7926 s = ffeexpr_stack_->previous;
7927
7928 if ((ffelex_token_type (ft) != FFELEX_typeNAME)
7929 || (ffesymbol_attrs (sy = ffeexpr_declare_unadorned_ (ft, FALSE))
7930 & FFESYMBOL_attrANY))
7931 {
7932 if ((ffelex_token_type (ft) != FFELEX_typeNAME)
7933 || !(ffesymbol_attrs (sy) & FFESYMBOL_attrsANY))
7934 {
7935 ffebad_start (FFEBAD_EXPR_WRONG);
7936 ffebad_here (0, ffelex_token_where_line (ft),
7937 ffelex_token_where_column (ft));
7938 ffebad_finish ();
7939 }
7940 expr = ffebld_new_any ();
7941 ffebld_set_info (expr, ffeinfo_new_any ());
7942 }
7943 else
7944 {
7945 expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
7946 FFEINTRIN_impNONE);
7947 ffebld_set_info (expr, ffesymbol_info (sy));
7948 }
7949
7950 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
7951 sizeof (*ffeexpr_stack_));
7952 ffeexpr_stack_ = s;
7953
7954 next = (ffelexHandler) (*callback) (ft, expr, t);
7955 ffelex_token_kill (ft);
7956 return (ffelexHandler) next;
7957 }
7958
7959 /* ffeexpr_token_first_rhs_ -- First state for rhs expression
7960
7961 Record line and column of first token in expression, then invoke the
7962 initial-state rhs handler.
7963
7964 19-Feb-91 JCB 1.1
7965 Allow ASTERISK in PARENFILEUNIT_ case, but only on second level only
7966 (i.e. only as in READ(*), not READ((*))). */
7967
7968 static ffelexHandler
7969 ffeexpr_token_first_rhs_ (ffelexToken t)
7970 {
7971 ffesymbol s;
7972
7973 ffeexpr_stack_->first_token = ffelex_token_use (t);
7974
7975 switch (ffelex_token_type (t))
7976 {
7977 case FFELEX_typeASTERISK:
7978 switch (ffeexpr_stack_->context)
7979 {
7980 case FFEEXPR_contextFILEFORMATNML:
7981 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
7982 /* Fall through. */
7983 case FFEEXPR_contextFILEUNIT:
7984 case FFEEXPR_contextDIMLIST:
7985 case FFEEXPR_contextFILEFORMAT:
7986 case FFEEXPR_contextCHARACTERSIZE:
7987 if (ffeexpr_stack_->previous != NULL)
7988 break; /* Valid only on first level. */
7989 assert (ffeexpr_stack_->exprstack == NULL);
7990 return (ffelexHandler) ffeexpr_token_first_rhs_1_;
7991
7992 case FFEEXPR_contextPARENFILEUNIT_:
7993 if (ffeexpr_stack_->previous->previous != NULL)
7994 break; /* Valid only on second level. */
7995 assert (ffeexpr_stack_->exprstack == NULL);
7996 return (ffelexHandler) ffeexpr_token_first_rhs_1_;
7997
7998 case FFEEXPR_contextACTUALARG_:
7999 if (ffeexpr_stack_->previous->context
8000 != FFEEXPR_contextSUBROUTINEREF)
8001 {
8002 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8003 break;
8004 }
8005 assert (ffeexpr_stack_->exprstack == NULL);
8006 return (ffelexHandler) ffeexpr_token_first_rhs_3_;
8007
8008 case FFEEXPR_contextINDEXORACTUALARG_:
8009 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8010 break;
8011
8012 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8013 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8014 break;
8015
8016 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8017 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8018 break;
8019
8020 default:
8021 break;
8022 }
8023 break;
8024
8025 case FFELEX_typeOPEN_PAREN:
8026 switch (ffeexpr_stack_->context)
8027 {
8028 case FFEEXPR_contextFILENUMAMBIG:
8029 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8030 FFEEXPR_contextPARENFILENUM_,
8031 ffeexpr_cb_close_paren_ambig_);
8032
8033 case FFEEXPR_contextFILEUNITAMBIG:
8034 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8035 FFEEXPR_contextPARENFILEUNIT_,
8036 ffeexpr_cb_close_paren_ambig_);
8037
8038 case FFEEXPR_contextIOLIST:
8039 case FFEEXPR_contextIMPDOITEM_:
8040 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8041 FFEEXPR_contextIMPDOITEM_,
8042 ffeexpr_cb_close_paren_ci_);
8043
8044 case FFEEXPR_contextIOLISTDF:
8045 case FFEEXPR_contextIMPDOITEMDF_:
8046 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8047 FFEEXPR_contextIMPDOITEMDF_,
8048 ffeexpr_cb_close_paren_ci_);
8049
8050 case FFEEXPR_contextFILEFORMATNML:
8051 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8052 break;
8053
8054 case FFEEXPR_contextACTUALARG_:
8055 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8056 break;
8057
8058 case FFEEXPR_contextINDEXORACTUALARG_:
8059 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8060 break;
8061
8062 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8063 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8064 break;
8065
8066 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8067 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8068 break;
8069
8070 default:
8071 break;
8072 }
8073 break;
8074
8075 case FFELEX_typeNUMBER:
8076 switch (ffeexpr_stack_->context)
8077 {
8078 case FFEEXPR_contextFILEFORMATNML:
8079 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8080 /* Fall through. */
8081 case FFEEXPR_contextFILEFORMAT:
8082 if (ffeexpr_stack_->previous != NULL)
8083 break; /* Valid only on first level. */
8084 assert (ffeexpr_stack_->exprstack == NULL);
8085 return (ffelexHandler) ffeexpr_token_first_rhs_2_;
8086
8087 case FFEEXPR_contextACTUALARG_:
8088 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8089 break;
8090
8091 case FFEEXPR_contextINDEXORACTUALARG_:
8092 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8093 break;
8094
8095 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8096 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8097 break;
8098
8099 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8100 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8101 break;
8102
8103 default:
8104 break;
8105 }
8106 break;
8107
8108 case FFELEX_typeNAME:
8109 switch (ffeexpr_stack_->context)
8110 {
8111 case FFEEXPR_contextFILEFORMATNML:
8112 assert (ffeexpr_stack_->exprstack == NULL);
8113 s = ffesymbol_lookup_local (t);
8114 if ((s != NULL) && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST))
8115 return (ffelexHandler) ffeexpr_token_namelist_;
8116 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8117 break;
8118
8119 default:
8120 break;
8121 }
8122 break;
8123
8124 case FFELEX_typePERCENT:
8125 switch (ffeexpr_stack_->context)
8126 {
8127 case FFEEXPR_contextACTUALARG_:
8128 case FFEEXPR_contextINDEXORACTUALARG_:
8129 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8130 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8131 return (ffelexHandler) ffeexpr_token_first_rhs_5_;
8132
8133 case FFEEXPR_contextFILEFORMATNML:
8134 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8135 break;
8136
8137 default:
8138 break;
8139 }
8140
8141 default:
8142 switch (ffeexpr_stack_->context)
8143 {
8144 case FFEEXPR_contextACTUALARG_:
8145 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8146 break;
8147
8148 case FFEEXPR_contextINDEXORACTUALARG_:
8149 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8150 break;
8151
8152 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8153 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8154 break;
8155
8156 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8157 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8158 break;
8159
8160 case FFEEXPR_contextFILEFORMATNML:
8161 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8162 break;
8163
8164 default:
8165 break;
8166 }
8167 break;
8168 }
8169
8170 return (ffelexHandler) ffeexpr_token_rhs_ (t);
8171 }
8172
8173 /* ffeexpr_token_first_rhs_1_ -- ASTERISK
8174
8175 return ffeexpr_token_first_rhs_1_; // to lexer
8176
8177 Return STAR as expression. */
8178
8179 static ffelexHandler
8180 ffeexpr_token_first_rhs_1_ (ffelexToken t)
8181 {
8182 ffebld expr;
8183 ffeexprCallback callback;
8184 ffeexprStack_ s;
8185 ffelexHandler next;
8186 ffelexToken ft;
8187
8188 expr = ffebld_new_star ();
8189 ffebld_pool_pop ();
8190 callback = ffeexpr_stack_->callback;
8191 ft = ffeexpr_stack_->first_token;
8192 s = ffeexpr_stack_->previous;
8193 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
8194 ffeexpr_stack_ = s;
8195 next = (ffelexHandler) (*callback) (ft, expr, t);
8196 ffelex_token_kill (ft);
8197 return (ffelexHandler) next;
8198 }
8199
8200 /* ffeexpr_token_first_rhs_2_ -- NUMBER
8201
8202 return ffeexpr_token_first_rhs_2_; // to lexer
8203
8204 Return NULL as expression; NUMBER as first (and only) token, unless the
8205 current token is not a terminating token, in which case run normal
8206 expression handling. */
8207
8208 static ffelexHandler
8209 ffeexpr_token_first_rhs_2_ (ffelexToken t)
8210 {
8211 ffeexprCallback callback;
8212 ffeexprStack_ s;
8213 ffelexHandler next;
8214 ffelexToken ft;
8215
8216 switch (ffelex_token_type (t))
8217 {
8218 case FFELEX_typeCLOSE_PAREN:
8219 case FFELEX_typeCOMMA:
8220 case FFELEX_typeEOS:
8221 case FFELEX_typeSEMICOLON:
8222 break;
8223
8224 default:
8225 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
8226 return (ffelexHandler) (*next) (t);
8227 }
8228
8229 ffebld_pool_pop ();
8230 callback = ffeexpr_stack_->callback;
8231 ft = ffeexpr_stack_->first_token;
8232 s = ffeexpr_stack_->previous;
8233 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
8234 sizeof (*ffeexpr_stack_));
8235 ffeexpr_stack_ = s;
8236 next = (ffelexHandler) (*callback) (ft, NULL, t);
8237 ffelex_token_kill (ft);
8238 return (ffelexHandler) next;
8239 }
8240
8241 /* ffeexpr_token_first_rhs_3_ -- ASTERISK
8242
8243 return ffeexpr_token_first_rhs_3_; // to lexer
8244
8245 Expect NUMBER, make LABTOK (with copy of token if not inhibited after
8246 confirming, else NULL). */
8247
8248 static ffelexHandler
8249 ffeexpr_token_first_rhs_3_ (ffelexToken t)
8250 {
8251 ffelexHandler next;
8252
8253 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
8254 { /* An error, but let normal processing handle
8255 it. */
8256 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
8257 return (ffelexHandler) (*next) (t);
8258 }
8259
8260 /* Special case: when we see "*10" as an argument to a subroutine
8261 reference, we confirm the current statement and, if not inhibited at
8262 this point, put a copy of the token into a LABTOK node. We do this
8263 instead of just resolving the label directly via ffelab and putting it
8264 into a LABTER simply to improve error reporting and consistency in
8265 ffestc. We put NULL in the LABTOK if we're still inhibited, so ffestb
8266 doesn't have to worry about killing off any tokens when retracting. */
8267
8268 ffest_confirmed ();
8269 if (ffest_is_inhibited ())
8270 ffeexpr_stack_->expr = ffebld_new_labtok (NULL);
8271 else
8272 ffeexpr_stack_->expr = ffebld_new_labtok (ffelex_token_use (t));
8273 ffebld_set_info (ffeexpr_stack_->expr,
8274 ffeinfo_new (FFEINFO_basictypeNONE,
8275 FFEINFO_kindtypeNONE,
8276 0,
8277 FFEINFO_kindNONE,
8278 FFEINFO_whereNONE,
8279 FFETARGET_charactersizeNONE));
8280
8281 return (ffelexHandler) ffeexpr_token_first_rhs_4_;
8282 }
8283
8284 /* ffeexpr_token_first_rhs_4_ -- ASTERISK NUMBER
8285
8286 return ffeexpr_token_first_rhs_4_; // to lexer
8287
8288 Collect/flush appropriate stuff, send token to callback function. */
8289
8290 static ffelexHandler
8291 ffeexpr_token_first_rhs_4_ (ffelexToken t)
8292 {
8293 ffebld expr;
8294 ffeexprCallback callback;
8295 ffeexprStack_ s;
8296 ffelexHandler next;
8297 ffelexToken ft;
8298
8299 expr = ffeexpr_stack_->expr;
8300 ffebld_pool_pop ();
8301 callback = ffeexpr_stack_->callback;
8302 ft = ffeexpr_stack_->first_token;
8303 s = ffeexpr_stack_->previous;
8304 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
8305 ffeexpr_stack_ = s;
8306 next = (ffelexHandler) (*callback) (ft, expr, t);
8307 ffelex_token_kill (ft);
8308 return (ffelexHandler) next;
8309 }
8310
8311 /* ffeexpr_token_first_rhs_5_ -- PERCENT
8312
8313 Should be NAME, or pass through original mechanism. If NAME is LOC,
8314 pass through original mechanism, otherwise must be VAL, REF, or DESCR,
8315 in which case handle the argument (in parentheses), etc. */
8316
8317 static ffelexHandler
8318 ffeexpr_token_first_rhs_5_ (ffelexToken t)
8319 {
8320 ffelexHandler next;
8321
8322 if (ffelex_token_type (t) == FFELEX_typeNAME)
8323 {
8324 ffeexprPercent_ p = ffeexpr_percent_ (t);
8325
8326 switch (p)
8327 {
8328 case FFEEXPR_percentNONE_:
8329 case FFEEXPR_percentLOC_:
8330 break; /* Treat %LOC as any other expression. */
8331
8332 case FFEEXPR_percentVAL_:
8333 case FFEEXPR_percentREF_:
8334 case FFEEXPR_percentDESCR_:
8335 ffeexpr_stack_->percent = p;
8336 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
8337 return (ffelexHandler) ffeexpr_token_first_rhs_6_;
8338
8339 default:
8340 assert ("bad percent?!?" == NULL);
8341 break;
8342 }
8343 }
8344
8345 switch (ffeexpr_stack_->context)
8346 {
8347 case FFEEXPR_contextACTUALARG_:
8348 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8349 break;
8350
8351 case FFEEXPR_contextINDEXORACTUALARG_:
8352 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8353 break;
8354
8355 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8356 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8357 break;
8358
8359 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8360 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8361 break;
8362
8363 default:
8364 assert ("bad context?!?!" == NULL);
8365 break;
8366 }
8367
8368 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
8369 return (ffelexHandler) (*next) (t);
8370 }
8371
8372 /* ffeexpr_token_first_rhs_6_ -- PERCENT NAME(VAL,REF,DESCR)
8373
8374 Should be OPEN_PAREN, or pass through original mechanism. */
8375
8376 static ffelexHandler
8377 ffeexpr_token_first_rhs_6_ (ffelexToken t)
8378 {
8379 ffelexHandler next;
8380 ffelexToken ft;
8381
8382 if (ffelex_token_type (t) == FFELEX_typeOPEN_PAREN)
8383 {
8384 ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
8385 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8386 ffeexpr_stack_->context,
8387 ffeexpr_cb_end_notloc_);
8388 }
8389
8390 switch (ffeexpr_stack_->context)
8391 {
8392 case FFEEXPR_contextACTUALARG_:
8393 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8394 break;
8395
8396 case FFEEXPR_contextINDEXORACTUALARG_:
8397 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8398 break;
8399
8400 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8401 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8402 break;
8403
8404 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8405 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8406 break;
8407
8408 default:
8409 assert ("bad context?!?!" == NULL);
8410 break;
8411 }
8412
8413 ft = ffeexpr_stack_->tokens[0];
8414 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
8415 next = (ffelexHandler) (*next) (ft);
8416 ffelex_token_kill (ft);
8417 return (ffelexHandler) (*next) (t);
8418 }
8419
8420 /* ffeexpr_token_namelist_ -- NAME
8421
8422 return ffeexpr_token_namelist_; // to lexer
8423
8424 Make sure NAME was a valid namelist object, wrap it in a SYMTER and
8425 return. */
8426
8427 static ffelexHandler
8428 ffeexpr_token_namelist_ (ffelexToken t)
8429 {
8430 ffeexprCallback callback;
8431 ffeexprStack_ s;
8432 ffelexHandler next;
8433 ffelexToken ft;
8434 ffesymbol sy;
8435 ffebld expr;
8436
8437 ffebld_pool_pop ();
8438 callback = ffeexpr_stack_->callback;
8439 ft = ffeexpr_stack_->first_token;
8440 s = ffeexpr_stack_->previous;
8441 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
8442 ffeexpr_stack_ = s;
8443
8444 sy = ffesymbol_lookup_local (ft);
8445 if ((sy == NULL) || (ffesymbol_kind (sy) != FFEINFO_kindNAMELIST))
8446 {
8447 ffebad_start (FFEBAD_EXPR_WRONG);
8448 ffebad_here (0, ffelex_token_where_line (ft),
8449 ffelex_token_where_column (ft));
8450 ffebad_finish ();
8451 expr = ffebld_new_any ();
8452 ffebld_set_info (expr, ffeinfo_new_any ());
8453 }
8454 else
8455 {
8456 expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
8457 FFEINTRIN_impNONE);
8458 ffebld_set_info (expr, ffesymbol_info (sy));
8459 }
8460 next = (ffelexHandler) (*callback) (ft, expr, t);
8461 ffelex_token_kill (ft);
8462 return (ffelexHandler) next;
8463 }
8464
8465 /* ffeexpr_expr_kill_ -- Kill an existing internal expression object
8466
8467 ffeexprExpr_ e;
8468 ffeexpr_expr_kill_(e);
8469
8470 Kills the ffewhere info, if necessary, then kills the object. */
8471
8472 static void
8473 ffeexpr_expr_kill_ (ffeexprExpr_ e)
8474 {
8475 if (e->token != NULL)
8476 ffelex_token_kill (e->token);
8477 malloc_kill_ks (ffe_pool_program_unit (), e, sizeof (*e));
8478 }
8479
8480 /* ffeexpr_expr_new_ -- Make a new internal expression object
8481
8482 ffeexprExpr_ e;
8483 e = ffeexpr_expr_new_();
8484
8485 Allocates and initializes a new expression object, returns it. */
8486
8487 static ffeexprExpr_
8488 ffeexpr_expr_new_ (void)
8489 {
8490 ffeexprExpr_ e;
8491
8492 e = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR expr", 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 bool bothlogical;
8807
8808 operand = ffeexpr_stack_->exprstack;
8809 assert (operand != NULL);
8810 assert (operand->type == FFEEXPR_exprtypeOPERAND_);
8811 operator = operand->previous;
8812 assert (operator != NULL);
8813 assert (operator->type != FFEEXPR_exprtypeOPERAND_);
8814 if (operator->type == FFEEXPR_exprtypeUNARY_)
8815 {
8816 expr = operand->u.operand;
8817 switch (operator->u.operator.op)
8818 {
8819 case FFEEXPR_operatorADD_:
8820 reduced = ffebld_new_uplus (expr);
8821 if (ffe_is_ugly_logint ())
8822 reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
8823 reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
8824 reduced = ffeexpr_collapse_uplus (reduced, operator->token);
8825 break;
8826
8827 case FFEEXPR_operatorSUBTRACT_:
8828 submag = TRUE; /* Ok to negate a magic number. */
8829 reduced = ffebld_new_uminus (expr);
8830 if (ffe_is_ugly_logint ())
8831 reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
8832 reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
8833 reduced = ffeexpr_collapse_uminus (reduced, operator->token);
8834 break;
8835
8836 case FFEEXPR_operatorNOT_:
8837 reduced = ffebld_new_not (expr);
8838 if (ffe_is_ugly_logint ())
8839 reduced = ffeexpr_reduced_ugly1log_ (reduced, operator, operand);
8840 reduced = ffeexpr_reduced_bool1_ (reduced, operator, operand);
8841 reduced = ffeexpr_collapse_not (reduced, operator->token);
8842 break;
8843
8844 default:
8845 assert ("unexpected unary op" != NULL);
8846 reduced = NULL;
8847 break;
8848 }
8849 if (!submag
8850 && (ffebld_op (expr) == FFEBLD_opCONTER)
8851 && (ffebld_conter_orig (expr) == NULL)
8852 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
8853 {
8854 ffetarget_integer_bad_magical (operand->token);
8855 }
8856 ffeexpr_stack_->exprstack = operator->previous; /* Pops unary-op operand
8857 off stack. */
8858 ffeexpr_expr_kill_ (operand);
8859 operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but
8860 save */
8861 operator->u.operand = reduced; /* the line/column ffewhere info. */
8862 ffeexpr_exprstack_push_operand_ (operator); /* Push it back on
8863 stack. */
8864 }
8865 else
8866 {
8867 assert (operator->type == FFEEXPR_exprtypeBINARY_);
8868 left_operand = operator->previous;
8869 assert (left_operand != NULL);
8870 assert (left_operand->type == FFEEXPR_exprtypeOPERAND_);
8871 expr = operand->u.operand;
8872 left_expr = left_operand->u.operand;
8873 switch (operator->u.operator.op)
8874 {
8875 case FFEEXPR_operatorADD_:
8876 reduced = ffebld_new_add (left_expr, expr);
8877 if (ffe_is_ugly_logint ())
8878 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8879 operand);
8880 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
8881 operand);
8882 reduced = ffeexpr_collapse_add (reduced, operator->token);
8883 break;
8884
8885 case FFEEXPR_operatorSUBTRACT_:
8886 submag = TRUE; /* Just to pick the right error if magic
8887 number. */
8888 reduced = ffebld_new_subtract (left_expr, expr);
8889 if (ffe_is_ugly_logint ())
8890 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8891 operand);
8892 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
8893 operand);
8894 reduced = ffeexpr_collapse_subtract (reduced, operator->token);
8895 break;
8896
8897 case FFEEXPR_operatorMULTIPLY_:
8898 reduced = ffebld_new_multiply (left_expr, expr);
8899 if (ffe_is_ugly_logint ())
8900 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8901 operand);
8902 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
8903 operand);
8904 reduced = ffeexpr_collapse_multiply (reduced, operator->token);
8905 break;
8906
8907 case FFEEXPR_operatorDIVIDE_:
8908 reduced = ffebld_new_divide (left_expr, expr);
8909 if (ffe_is_ugly_logint ())
8910 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8911 operand);
8912 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
8913 operand);
8914 reduced = ffeexpr_collapse_divide (reduced, operator->token);
8915 break;
8916
8917 case FFEEXPR_operatorPOWER_:
8918 reduced = ffebld_new_power (left_expr, expr);
8919 if (ffe_is_ugly_logint ())
8920 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8921 operand);
8922 reduced = ffeexpr_reduced_power_ (reduced, left_operand, operator,
8923 operand);
8924 reduced = ffeexpr_collapse_power (reduced, operator->token);
8925 break;
8926
8927 case FFEEXPR_operatorCONCATENATE_:
8928 reduced = ffebld_new_concatenate (left_expr, expr);
8929 reduced = ffeexpr_reduced_concatenate_ (reduced, left_operand, operator,
8930 operand);
8931 reduced = ffeexpr_collapse_concatenate (reduced, operator->token);
8932 break;
8933
8934 case FFEEXPR_operatorLT_:
8935 reduced = ffebld_new_lt (left_expr, expr);
8936 if (ffe_is_ugly_logint ())
8937 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8938 operand);
8939 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
8940 operand);
8941 reduced = ffeexpr_collapse_lt (reduced, operator->token);
8942 break;
8943
8944 case FFEEXPR_operatorLE_:
8945 reduced = ffebld_new_le (left_expr, expr);
8946 if (ffe_is_ugly_logint ())
8947 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8948 operand);
8949 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
8950 operand);
8951 reduced = ffeexpr_collapse_le (reduced, operator->token);
8952 break;
8953
8954 case FFEEXPR_operatorEQ_:
8955 reduced = ffebld_new_eq (left_expr, expr);
8956 if (ffe_is_ugly_logint ())
8957 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8958 operand);
8959 reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
8960 operand);
8961 reduced = ffeexpr_collapse_eq (reduced, operator->token);
8962 break;
8963
8964 case FFEEXPR_operatorNE_:
8965 reduced = ffebld_new_ne (left_expr, expr);
8966 if (ffe_is_ugly_logint ())
8967 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8968 operand);
8969 reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
8970 operand);
8971 reduced = ffeexpr_collapse_ne (reduced, operator->token);
8972 break;
8973
8974 case FFEEXPR_operatorGT_:
8975 reduced = ffebld_new_gt (left_expr, expr);
8976 if (ffe_is_ugly_logint ())
8977 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8978 operand);
8979 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
8980 operand);
8981 reduced = ffeexpr_collapse_gt (reduced, operator->token);
8982 break;
8983
8984 case FFEEXPR_operatorGE_:
8985 reduced = ffebld_new_ge (left_expr, expr);
8986 if (ffe_is_ugly_logint ())
8987 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8988 operand);
8989 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
8990 operand);
8991 reduced = ffeexpr_collapse_ge (reduced, operator->token);
8992 break;
8993
8994 case FFEEXPR_operatorAND_:
8995 reduced = ffebld_new_and (left_expr, expr);
8996 if (ffe_is_ugly_logint ())
8997 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
8998 operand, &bothlogical);
8999 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9000 operand);
9001 reduced = ffeexpr_collapse_and (reduced, operator->token);
9002 if (ffe_is_ugly_logint() && bothlogical)
9003 reduced = ffeexpr_convert (reduced, left_operand->token,
9004 operator->token,
9005 FFEINFO_basictypeLOGICAL,
9006 FFEINFO_kindtypeLOGICALDEFAULT, 0,
9007 FFETARGET_charactersizeNONE,
9008 FFEEXPR_contextLET);
9009 break;
9010
9011 case FFEEXPR_operatorOR_:
9012 reduced = ffebld_new_or (left_expr, expr);
9013 if (ffe_is_ugly_logint ())
9014 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9015 operand, &bothlogical);
9016 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9017 operand);
9018 reduced = ffeexpr_collapse_or (reduced, operator->token);
9019 if (ffe_is_ugly_logint() && bothlogical)
9020 reduced = ffeexpr_convert (reduced, left_operand->token,
9021 operator->token,
9022 FFEINFO_basictypeLOGICAL,
9023 FFEINFO_kindtypeLOGICALDEFAULT, 0,
9024 FFETARGET_charactersizeNONE,
9025 FFEEXPR_contextLET);
9026 break;
9027
9028 case FFEEXPR_operatorXOR_:
9029 reduced = ffebld_new_xor (left_expr, expr);
9030 if (ffe_is_ugly_logint ())
9031 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9032 operand, &bothlogical);
9033 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9034 operand);
9035 reduced = ffeexpr_collapse_xor (reduced, operator->token);
9036 if (ffe_is_ugly_logint() && bothlogical)
9037 reduced = ffeexpr_convert (reduced, left_operand->token,
9038 operator->token,
9039 FFEINFO_basictypeLOGICAL,
9040 FFEINFO_kindtypeLOGICALDEFAULT, 0,
9041 FFETARGET_charactersizeNONE,
9042 FFEEXPR_contextLET);
9043 break;
9044
9045 case FFEEXPR_operatorEQV_:
9046 reduced = ffebld_new_eqv (left_expr, expr);
9047 if (ffe_is_ugly_logint ())
9048 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9049 operand, NULL);
9050 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9051 operand);
9052 reduced = ffeexpr_collapse_eqv (reduced, operator->token);
9053 break;
9054
9055 case FFEEXPR_operatorNEQV_:
9056 reduced = ffebld_new_neqv (left_expr, expr);
9057 if (ffe_is_ugly_logint ())
9058 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9059 operand, NULL);
9060 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9061 operand);
9062 reduced = ffeexpr_collapse_neqv (reduced, operator->token);
9063 break;
9064
9065 default:
9066 assert ("bad bin op" == NULL);
9067 reduced = expr;
9068 break;
9069 }
9070 if ((ffebld_op (left_expr) == FFEBLD_opCONTER)
9071 && (ffebld_conter_orig (expr) == NULL)
9072 && ffebld_constant_is_magical (constnode = ffebld_conter (left_expr)))
9073 {
9074 if ((left_operand->previous != NULL)
9075 && (left_operand->previous->type != FFEEXPR_exprtypeOPERAND_)
9076 && (left_operand->previous->u.operator.op
9077 == FFEEXPR_operatorSUBTRACT_))
9078 {
9079 if (left_operand->previous->type == FFEEXPR_exprtypeUNARY_)
9080 ffetarget_integer_bad_magical_precedence (left_operand->token,
9081 left_operand->previous->token,
9082 operator->token);
9083 else
9084 ffetarget_integer_bad_magical_precedence_binary
9085 (left_operand->token,
9086 left_operand->previous->token,
9087 operator->token);
9088 }
9089 else
9090 ffetarget_integer_bad_magical (left_operand->token);
9091 }
9092 if ((ffebld_op (expr) == FFEBLD_opCONTER)
9093 && (ffebld_conter_orig (expr) == NULL)
9094 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
9095 {
9096 if (submag)
9097 ffetarget_integer_bad_magical_binary (operand->token,
9098 operator->token);
9099 else
9100 ffetarget_integer_bad_magical (operand->token);
9101 }
9102 ffeexpr_stack_->exprstack = left_operand->previous; /* Pops binary-op
9103 operands off stack. */
9104 ffeexpr_expr_kill_ (left_operand);
9105 ffeexpr_expr_kill_ (operand);
9106 operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but
9107 save */
9108 operator->u.operand = reduced; /* the line/column ffewhere info. */
9109 ffeexpr_exprstack_push_operand_ (operator); /* Push it back on
9110 stack. */
9111 }
9112 }
9113
9114 /* ffeexpr_reduced_bool1_ -- Wrap up reduction of NOT operator
9115
9116 reduced = ffeexpr_reduced_bool1_(reduced,op,r);
9117
9118 Makes sure the argument for reduced has basictype of
9119 LOGICAL or (ugly) INTEGER. If
9120 argument has where of CONSTANT, assign where CONSTANT to
9121 reduced, else assign where FLEETING.
9122
9123 If these requirements cannot be met, generate error message. */
9124
9125 static ffebld
9126 ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
9127 {
9128 ffeinfo rinfo, ninfo;
9129 ffeinfoBasictype rbt;
9130 ffeinfoKindtype rkt;
9131 ffeinfoRank rrk;
9132 ffeinfoKind rkd;
9133 ffeinfoWhere rwh, nwh;
9134
9135 rinfo = ffebld_info (ffebld_left (reduced));
9136 rbt = ffeinfo_basictype (rinfo);
9137 rkt = ffeinfo_kindtype (rinfo);
9138 rrk = ffeinfo_rank (rinfo);
9139 rkd = ffeinfo_kind (rinfo);
9140 rwh = ffeinfo_where (rinfo);
9141
9142 if (((rbt == FFEINFO_basictypeLOGICAL)
9143 || (ffe_is_ugly_logint () && (rbt == FFEINFO_basictypeINTEGER)))
9144 && (rrk == 0))
9145 {
9146 switch (rwh)
9147 {
9148 case FFEINFO_whereCONSTANT:
9149 nwh = FFEINFO_whereCONSTANT;
9150 break;
9151
9152 case FFEINFO_whereIMMEDIATE:
9153 nwh = FFEINFO_whereIMMEDIATE;
9154 break;
9155
9156 default:
9157 nwh = FFEINFO_whereFLEETING;
9158 break;
9159 }
9160
9161 ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
9162 FFETARGET_charactersizeNONE);
9163 ffebld_set_info (reduced, ninfo);
9164 return reduced;
9165 }
9166
9167 if ((rbt != FFEINFO_basictypeLOGICAL)
9168 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
9169 {
9170 if ((rbt != FFEINFO_basictypeANY)
9171 && ffebad_start (FFEBAD_NOT_ARG_TYPE))
9172 {
9173 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9174 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9175 ffebad_finish ();
9176 }
9177 }
9178 else
9179 {
9180 if ((rkd != FFEINFO_kindANY)
9181 && ffebad_start (FFEBAD_NOT_ARG_KIND))
9182 {
9183 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9184 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9185 ffebad_string ("an array");
9186 ffebad_finish ();
9187 }
9188 }
9189
9190 reduced = ffebld_new_any ();
9191 ffebld_set_info (reduced, ffeinfo_new_any ());
9192 return reduced;
9193 }
9194
9195 /* ffeexpr_reduced_bool2_ -- Wrap up reduction of boolean operators
9196
9197 reduced = ffeexpr_reduced_bool2_(reduced,l,op,r);
9198
9199 Makes sure the left and right arguments for reduced have basictype of
9200 LOGICAL or (ugly) INTEGER. Determine common basictype and
9201 size for reduction (flag expression for combined hollerith/typeless
9202 situations for later determination of effective basictype). If both left
9203 and right arguments have where of CONSTANT, assign where CONSTANT to
9204 reduced, else assign where FLEETING. Create CONVERT ops for args where
9205 needed. Convert typeless
9206 constants to the desired type/size explicitly.
9207
9208 If these requirements cannot be met, generate error message. */
9209
9210 static ffebld
9211 ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9212 ffeexprExpr_ r)
9213 {
9214 ffeinfo linfo, rinfo, ninfo;
9215 ffeinfoBasictype lbt, rbt, nbt;
9216 ffeinfoKindtype lkt, rkt, nkt;
9217 ffeinfoRank lrk, rrk;
9218 ffeinfoKind lkd, rkd;
9219 ffeinfoWhere lwh, rwh, nwh;
9220
9221 linfo = ffebld_info (ffebld_left (reduced));
9222 lbt = ffeinfo_basictype (linfo);
9223 lkt = ffeinfo_kindtype (linfo);
9224 lrk = ffeinfo_rank (linfo);
9225 lkd = ffeinfo_kind (linfo);
9226 lwh = ffeinfo_where (linfo);
9227
9228 rinfo = ffebld_info (ffebld_right (reduced));
9229 rbt = ffeinfo_basictype (rinfo);
9230 rkt = ffeinfo_kindtype (rinfo);
9231 rrk = ffeinfo_rank (rinfo);
9232 rkd = ffeinfo_kind (rinfo);
9233 rwh = ffeinfo_where (rinfo);
9234
9235 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
9236
9237 if (((nbt == FFEINFO_basictypeLOGICAL)
9238 || (ffe_is_ugly_logint () && (nbt == FFEINFO_basictypeINTEGER)))
9239 && (lrk == 0) && (rrk == 0))
9240 {
9241 switch (lwh)
9242 {
9243 case FFEINFO_whereCONSTANT:
9244 switch (rwh)
9245 {
9246 case FFEINFO_whereCONSTANT:
9247 nwh = FFEINFO_whereCONSTANT;
9248 break;
9249
9250 case FFEINFO_whereIMMEDIATE:
9251 nwh = FFEINFO_whereIMMEDIATE;
9252 break;
9253
9254 default:
9255 nwh = FFEINFO_whereFLEETING;
9256 break;
9257 }
9258 break;
9259
9260 case FFEINFO_whereIMMEDIATE:
9261 switch (rwh)
9262 {
9263 case FFEINFO_whereCONSTANT:
9264 case FFEINFO_whereIMMEDIATE:
9265 nwh = FFEINFO_whereIMMEDIATE;
9266 break;
9267
9268 default:
9269 nwh = FFEINFO_whereFLEETING;
9270 break;
9271 }
9272 break;
9273
9274 default:
9275 nwh = FFEINFO_whereFLEETING;
9276 break;
9277 }
9278
9279 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
9280 FFETARGET_charactersizeNONE);
9281 ffebld_set_info (reduced, ninfo);
9282 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
9283 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
9284 FFEEXPR_contextLET));
9285 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
9286 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
9287 FFEEXPR_contextLET));
9288 return reduced;
9289 }
9290
9291 if ((lbt != FFEINFO_basictypeLOGICAL)
9292 && (!ffe_is_ugly_logint () || (lbt != FFEINFO_basictypeINTEGER)))
9293 {
9294 if ((rbt != FFEINFO_basictypeLOGICAL)
9295 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
9296 {
9297 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
9298 && ffebad_start (FFEBAD_BOOL_ARGS_TYPE))
9299 {
9300 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9301 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9302 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9303 ffebad_finish ();
9304 }
9305 }
9306 else
9307 {
9308 if ((lbt != FFEINFO_basictypeANY)
9309 && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
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_finish ();
9314 }
9315 }
9316 }
9317 else if ((rbt != FFEINFO_basictypeLOGICAL)
9318 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
9319 {
9320 if ((rbt != FFEINFO_basictypeANY)
9321 && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
9322 {
9323 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9324 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9325 ffebad_finish ();
9326 }
9327 }
9328 else if (lrk != 0)
9329 {
9330 if ((lkd != FFEINFO_kindANY)
9331 && ffebad_start (FFEBAD_BOOL_ARG_KIND))
9332 {
9333 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9334 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9335 ffebad_string ("an array");
9336 ffebad_finish ();
9337 }
9338 }
9339 else
9340 {
9341 if ((rkd != FFEINFO_kindANY)
9342 && ffebad_start (FFEBAD_BOOL_ARG_KIND))
9343 {
9344 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9345 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9346 ffebad_string ("an array");
9347 ffebad_finish ();
9348 }
9349 }
9350
9351 reduced = ffebld_new_any ();
9352 ffebld_set_info (reduced, ffeinfo_new_any ());
9353 return reduced;
9354 }
9355
9356 /* ffeexpr_reduced_concatenate_ -- Wrap up reduction of concatenate operator
9357
9358 reduced = ffeexpr_reduced_concatenate_(reduced,l,op,r);
9359
9360 Makes sure the left and right arguments for reduced have basictype of
9361 CHARACTER and kind of SCALAR, FUNCTION, or STATEMENT FUNCTION. Assign
9362 basictype of CHARACTER and kind of SCALAR to reduced. Calculate effective
9363 size of concatenation and assign that size to reduced. If both left and
9364 right arguments have where of CONSTANT, assign where CONSTANT to reduced,
9365 else assign where FLEETING.
9366
9367 If these requirements cannot be met, generate error message using the
9368 info in l, op, and r arguments and assign basictype, size, kind, and where
9369 of ANY. */
9370
9371 static ffebld
9372 ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9373 ffeexprExpr_ r)
9374 {
9375 ffeinfo linfo, rinfo, ninfo;
9376 ffeinfoBasictype lbt, rbt, nbt;
9377 ffeinfoKindtype lkt, rkt, nkt;
9378 ffeinfoRank lrk, rrk;
9379 ffeinfoKind lkd, rkd, nkd;
9380 ffeinfoWhere lwh, rwh, nwh;
9381 ffetargetCharacterSize lszm, lszk, rszm, rszk, nszk;
9382
9383 linfo = ffebld_info (ffebld_left (reduced));
9384 lbt = ffeinfo_basictype (linfo);
9385 lkt = ffeinfo_kindtype (linfo);
9386 lrk = ffeinfo_rank (linfo);
9387 lkd = ffeinfo_kind (linfo);
9388 lwh = ffeinfo_where (linfo);
9389 lszk = ffeinfo_size (linfo); /* Known size. */
9390 lszm = ffebld_size_max (ffebld_left (reduced));
9391
9392 rinfo = ffebld_info (ffebld_right (reduced));
9393 rbt = ffeinfo_basictype (rinfo);
9394 rkt = ffeinfo_kindtype (rinfo);
9395 rrk = ffeinfo_rank (rinfo);
9396 rkd = ffeinfo_kind (rinfo);
9397 rwh = ffeinfo_where (rinfo);
9398 rszk = ffeinfo_size (rinfo); /* Known size. */
9399 rszm = ffebld_size_max (ffebld_right (reduced));
9400
9401 if ((lbt == FFEINFO_basictypeCHARACTER) && (rbt == FFEINFO_basictypeCHARACTER)
9402 && (lkt == rkt) && (lrk == 0) && (rrk == 0)
9403 && (((lszm != FFETARGET_charactersizeNONE)
9404 && (rszm != FFETARGET_charactersizeNONE))
9405 || (ffeexpr_context_outer_ (ffeexpr_stack_)
9406 == FFEEXPR_contextLET)
9407 || (ffeexpr_context_outer_ (ffeexpr_stack_)
9408 == FFEEXPR_contextSFUNCDEF)))
9409 {
9410 nbt = FFEINFO_basictypeCHARACTER;
9411 nkd = FFEINFO_kindENTITY;
9412 if ((lszk == FFETARGET_charactersizeNONE)
9413 || (rszk == FFETARGET_charactersizeNONE))
9414 nszk = FFETARGET_charactersizeNONE; /* Ok only in rhs of LET
9415 stmt. */
9416 else
9417 nszk = lszk + rszk;
9418
9419 switch (lwh)
9420 {
9421 case FFEINFO_whereCONSTANT:
9422 switch (rwh)
9423 {
9424 case FFEINFO_whereCONSTANT:
9425 nwh = FFEINFO_whereCONSTANT;
9426 break;
9427
9428 case FFEINFO_whereIMMEDIATE:
9429 nwh = FFEINFO_whereIMMEDIATE;
9430 break;
9431
9432 default:
9433 nwh = FFEINFO_whereFLEETING;
9434 break;
9435 }
9436 break;
9437
9438 case FFEINFO_whereIMMEDIATE:
9439 switch (rwh)
9440 {
9441 case FFEINFO_whereCONSTANT:
9442 case FFEINFO_whereIMMEDIATE:
9443 nwh = FFEINFO_whereIMMEDIATE;
9444 break;
9445
9446 default:
9447 nwh = FFEINFO_whereFLEETING;
9448 break;
9449 }
9450 break;
9451
9452 default:
9453 nwh = FFEINFO_whereFLEETING;
9454 break;
9455 }
9456
9457 nkt = lkt;
9458 ninfo = ffeinfo_new (nbt, nkt, 0, nkd, nwh, nszk);
9459 ffebld_set_info (reduced, ninfo);
9460 return reduced;
9461 }
9462
9463 if ((lbt != FFEINFO_basictypeCHARACTER) && (rbt != FFEINFO_basictypeCHARACTER))
9464 {
9465 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
9466 && ffebad_start (FFEBAD_CONCAT_ARGS_TYPE))
9467 {
9468 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9469 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9470 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9471 ffebad_finish ();
9472 }
9473 }
9474 else if (lbt != FFEINFO_basictypeCHARACTER)
9475 {
9476 if ((lbt != FFEINFO_basictypeANY)
9477 && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
9478 {
9479 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9480 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9481 ffebad_finish ();
9482 }
9483 }
9484 else if (rbt != FFEINFO_basictypeCHARACTER)
9485 {
9486 if ((rbt != FFEINFO_basictypeANY)
9487 && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
9488 {
9489 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9490 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9491 ffebad_finish ();
9492 }
9493 }
9494 else if ((lrk != 0) || (lszm == FFETARGET_charactersizeNONE))
9495 {
9496 if ((lkd != FFEINFO_kindANY)
9497 && ffebad_start (FFEBAD_CONCAT_ARG_KIND))
9498 {
9499 const char *what;
9500
9501 if (lrk != 0)
9502 what = "an array";
9503 else
9504 what = "of indeterminate length";
9505 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9506 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9507 ffebad_string (what);
9508 ffebad_finish ();
9509 }
9510 }
9511 else
9512 {
9513 if (ffebad_start (FFEBAD_CONCAT_ARG_KIND))
9514 {
9515 const char *what;
9516
9517 if (rrk != 0)
9518 what = "an array";
9519 else
9520 what = "of indeterminate length";
9521 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9522 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9523 ffebad_string (what);
9524 ffebad_finish ();
9525 }
9526 }
9527
9528 reduced = ffebld_new_any ();
9529 ffebld_set_info (reduced, ffeinfo_new_any ());
9530 return reduced;
9531 }
9532
9533 /* ffeexpr_reduced_eqop2_ -- Wrap up reduction of EQ and NE operators
9534
9535 reduced = ffeexpr_reduced_eqop2_(reduced,l,op,r);
9536
9537 Makes sure the left and right arguments for reduced have basictype of
9538 INTEGER, REAL, COMPLEX, or CHARACTER. Determine common basictype and
9539 size for reduction. If both left
9540 and right arguments have where of CONSTANT, assign where CONSTANT to
9541 reduced, else assign where FLEETING. Create CONVERT ops for args where
9542 needed. Convert typeless
9543 constants to the desired type/size explicitly.
9544
9545 If these requirements cannot be met, generate error message. */
9546
9547 static ffebld
9548 ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9549 ffeexprExpr_ r)
9550 {
9551 ffeinfo linfo, rinfo, ninfo;
9552 ffeinfoBasictype lbt, rbt, nbt;
9553 ffeinfoKindtype lkt, rkt, nkt;
9554 ffeinfoRank lrk, rrk;
9555 ffeinfoKind lkd, rkd;
9556 ffeinfoWhere lwh, rwh, nwh;
9557 ffetargetCharacterSize lsz, rsz;
9558
9559 linfo = ffebld_info (ffebld_left (reduced));
9560 lbt = ffeinfo_basictype (linfo);
9561 lkt = ffeinfo_kindtype (linfo);
9562 lrk = ffeinfo_rank (linfo);
9563 lkd = ffeinfo_kind (linfo);
9564 lwh = ffeinfo_where (linfo);
9565 lsz = ffebld_size_known (ffebld_left (reduced));
9566
9567 rinfo = ffebld_info (ffebld_right (reduced));
9568 rbt = ffeinfo_basictype (rinfo);
9569 rkt = ffeinfo_kindtype (rinfo);
9570 rrk = ffeinfo_rank (rinfo);
9571 rkd = ffeinfo_kind (rinfo);
9572 rwh = ffeinfo_where (rinfo);
9573 rsz = ffebld_size_known (ffebld_right (reduced));
9574
9575 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
9576
9577 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
9578 || (nbt == FFEINFO_basictypeCOMPLEX) || (nbt == FFEINFO_basictypeCHARACTER))
9579 && (lrk == 0) && (rrk == 0))
9580 {
9581 switch (lwh)
9582 {
9583 case FFEINFO_whereCONSTANT:
9584 switch (rwh)
9585 {
9586 case FFEINFO_whereCONSTANT:
9587 nwh = FFEINFO_whereCONSTANT;
9588 break;
9589
9590 case FFEINFO_whereIMMEDIATE:
9591 nwh = FFEINFO_whereIMMEDIATE;
9592 break;
9593
9594 default:
9595 nwh = FFEINFO_whereFLEETING;
9596 break;
9597 }
9598 break;
9599
9600 case FFEINFO_whereIMMEDIATE:
9601 switch (rwh)
9602 {
9603 case FFEINFO_whereCONSTANT:
9604 case FFEINFO_whereIMMEDIATE:
9605 nwh = FFEINFO_whereIMMEDIATE;
9606 break;
9607
9608 default:
9609 nwh = FFEINFO_whereFLEETING;
9610 break;
9611 }
9612 break;
9613
9614 default:
9615 nwh = FFEINFO_whereFLEETING;
9616 break;
9617 }
9618
9619 if ((lsz != FFETARGET_charactersizeNONE)
9620 && (rsz != FFETARGET_charactersizeNONE))
9621 lsz = rsz = (lsz > rsz) ? lsz : rsz;
9622
9623 ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
9624 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
9625 ffebld_set_info (reduced, ninfo);
9626 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
9627 l->token, op->token, nbt, nkt, 0, lsz,
9628 FFEEXPR_contextLET));
9629 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
9630 r->token, op->token, nbt, nkt, 0, rsz,
9631 FFEEXPR_contextLET));
9632 return reduced;
9633 }
9634
9635 if ((lbt == FFEINFO_basictypeLOGICAL)
9636 && (rbt == FFEINFO_basictypeLOGICAL))
9637 {
9638 /* xgettext:no-c-format */
9639 if (ffebad_start_msg ("Use .EQV./.NEQV. instead of .EQ./.NE. at %0 for LOGICAL operands at %1 and %2",
9640 FFEBAD_severityFATAL))
9641 {
9642 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9643 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9644 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9645 ffebad_finish ();
9646 }
9647 }
9648 else if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
9649 && (lbt != FFEINFO_basictypeCOMPLEX) && (lbt != FFEINFO_basictypeCHARACTER))
9650 {
9651 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
9652 && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
9653 {
9654 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
9655 && ffebad_start (FFEBAD_EQOP_ARGS_TYPE))
9656 {
9657 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9658 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9659 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9660 ffebad_finish ();
9661 }
9662 }
9663 else
9664 {
9665 if ((lbt != FFEINFO_basictypeANY)
9666 && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
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_finish ();
9671 }
9672 }
9673 }
9674 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
9675 && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
9676 {
9677 if ((rbt != FFEINFO_basictypeANY)
9678 && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
9679 {
9680 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9681 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9682 ffebad_finish ();
9683 }
9684 }
9685 else if (lrk != 0)
9686 {
9687 if ((lkd != FFEINFO_kindANY)
9688 && ffebad_start (FFEBAD_EQOP_ARG_KIND))
9689 {
9690 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9691 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9692 ffebad_string ("an array");
9693 ffebad_finish ();
9694 }
9695 }
9696 else
9697 {
9698 if ((rkd != FFEINFO_kindANY)
9699 && ffebad_start (FFEBAD_EQOP_ARG_KIND))
9700 {
9701 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9702 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9703 ffebad_string ("an array");
9704 ffebad_finish ();
9705 }
9706 }
9707
9708 reduced = ffebld_new_any ();
9709 ffebld_set_info (reduced, ffeinfo_new_any ());
9710 return reduced;
9711 }
9712
9713 /* ffeexpr_reduced_math1_ -- Wrap up reduction of + - unary operators
9714
9715 reduced = ffeexpr_reduced_math1_(reduced,op,r);
9716
9717 Makes sure the argument for reduced has basictype of
9718 INTEGER, REAL, or COMPLEX. If the argument has where of CONSTANT,
9719 assign where CONSTANT to
9720 reduced, else assign where FLEETING.
9721
9722 If these requirements cannot be met, generate error message. */
9723
9724 static ffebld
9725 ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
9726 {
9727 ffeinfo rinfo, ninfo;
9728 ffeinfoBasictype rbt;
9729 ffeinfoKindtype rkt;
9730 ffeinfoRank rrk;
9731 ffeinfoKind rkd;
9732 ffeinfoWhere rwh, nwh;
9733
9734 rinfo = ffebld_info (ffebld_left (reduced));
9735 rbt = ffeinfo_basictype (rinfo);
9736 rkt = ffeinfo_kindtype (rinfo);
9737 rrk = ffeinfo_rank (rinfo);
9738 rkd = ffeinfo_kind (rinfo);
9739 rwh = ffeinfo_where (rinfo);
9740
9741 if (((rbt == FFEINFO_basictypeINTEGER) || (rbt == FFEINFO_basictypeREAL)
9742 || (rbt == FFEINFO_basictypeCOMPLEX)) && (rrk == 0))
9743 {
9744 switch (rwh)
9745 {
9746 case FFEINFO_whereCONSTANT:
9747 nwh = FFEINFO_whereCONSTANT;
9748 break;
9749
9750 case FFEINFO_whereIMMEDIATE:
9751 nwh = FFEINFO_whereIMMEDIATE;
9752 break;
9753
9754 default:
9755 nwh = FFEINFO_whereFLEETING;
9756 break;
9757 }
9758
9759 ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
9760 FFETARGET_charactersizeNONE);
9761 ffebld_set_info (reduced, ninfo);
9762 return reduced;
9763 }
9764
9765 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
9766 && (rbt != FFEINFO_basictypeCOMPLEX))
9767 {
9768 if ((rbt != FFEINFO_basictypeANY)
9769 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
9770 {
9771 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9772 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9773 ffebad_finish ();
9774 }
9775 }
9776 else
9777 {
9778 if ((rkd != FFEINFO_kindANY)
9779 && ffebad_start (FFEBAD_MATH_ARG_KIND))
9780 {
9781 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9782 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9783 ffebad_string ("an array");
9784 ffebad_finish ();
9785 }
9786 }
9787
9788 reduced = ffebld_new_any ();
9789 ffebld_set_info (reduced, ffeinfo_new_any ());
9790 return reduced;
9791 }
9792
9793 /* ffeexpr_reduced_math2_ -- Wrap up reduction of + - * / operators
9794
9795 reduced = ffeexpr_reduced_math2_(reduced,l,op,r);
9796
9797 Makes sure the left and right arguments for reduced have basictype of
9798 INTEGER, REAL, or COMPLEX. Determine common basictype and
9799 size for reduction (flag expression for combined hollerith/typeless
9800 situations for later determination of effective basictype). If both left
9801 and right arguments have where of CONSTANT, assign where CONSTANT to
9802 reduced, else assign where FLEETING. Create CONVERT ops for args where
9803 needed. Convert typeless
9804 constants to the desired type/size explicitly.
9805
9806 If these requirements cannot be met, generate error message. */
9807
9808 static ffebld
9809 ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9810 ffeexprExpr_ r)
9811 {
9812 ffeinfo linfo, rinfo, ninfo;
9813 ffeinfoBasictype lbt, rbt, nbt;
9814 ffeinfoKindtype lkt, rkt, nkt;
9815 ffeinfoRank lrk, rrk;
9816 ffeinfoKind lkd, rkd;
9817 ffeinfoWhere lwh, rwh, nwh;
9818
9819 linfo = ffebld_info (ffebld_left (reduced));
9820 lbt = ffeinfo_basictype (linfo);
9821 lkt = ffeinfo_kindtype (linfo);
9822 lrk = ffeinfo_rank (linfo);
9823 lkd = ffeinfo_kind (linfo);
9824 lwh = ffeinfo_where (linfo);
9825
9826 rinfo = ffebld_info (ffebld_right (reduced));
9827 rbt = ffeinfo_basictype (rinfo);
9828 rkt = ffeinfo_kindtype (rinfo);
9829 rrk = ffeinfo_rank (rinfo);
9830 rkd = ffeinfo_kind (rinfo);
9831 rwh = ffeinfo_where (rinfo);
9832
9833 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
9834
9835 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
9836 || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
9837 {
9838 switch (lwh)
9839 {
9840 case FFEINFO_whereCONSTANT:
9841 switch (rwh)
9842 {
9843 case FFEINFO_whereCONSTANT:
9844 nwh = FFEINFO_whereCONSTANT;
9845 break;
9846
9847 case FFEINFO_whereIMMEDIATE:
9848 nwh = FFEINFO_whereIMMEDIATE;
9849 break;
9850
9851 default:
9852 nwh = FFEINFO_whereFLEETING;
9853 break;
9854 }
9855 break;
9856
9857 case FFEINFO_whereIMMEDIATE:
9858 switch (rwh)
9859 {
9860 case FFEINFO_whereCONSTANT:
9861 case FFEINFO_whereIMMEDIATE:
9862 nwh = FFEINFO_whereIMMEDIATE;
9863 break;
9864
9865 default:
9866 nwh = FFEINFO_whereFLEETING;
9867 break;
9868 }
9869 break;
9870
9871 default:
9872 nwh = FFEINFO_whereFLEETING;
9873 break;
9874 }
9875
9876 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
9877 FFETARGET_charactersizeNONE);
9878 ffebld_set_info (reduced, ninfo);
9879 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
9880 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
9881 FFEEXPR_contextLET));
9882 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
9883 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
9884 FFEEXPR_contextLET));
9885 return reduced;
9886 }
9887
9888 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
9889 && (lbt != FFEINFO_basictypeCOMPLEX))
9890 {
9891 if ((rbt != FFEINFO_basictypeINTEGER)
9892 && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
9893 {
9894 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
9895 && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
9896 {
9897 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9898 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9899 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9900 ffebad_finish ();
9901 }
9902 }
9903 else
9904 {
9905 if ((lbt != FFEINFO_basictypeANY)
9906 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
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_finish ();
9911 }
9912 }
9913 }
9914 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
9915 && (rbt != FFEINFO_basictypeCOMPLEX))
9916 {
9917 if ((rbt != FFEINFO_basictypeANY)
9918 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
9919 {
9920 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9921 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9922 ffebad_finish ();
9923 }
9924 }
9925 else if (lrk != 0)
9926 {
9927 if ((lkd != FFEINFO_kindANY)
9928 && ffebad_start (FFEBAD_MATH_ARG_KIND))
9929 {
9930 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9931 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9932 ffebad_string ("an array");
9933 ffebad_finish ();
9934 }
9935 }
9936 else
9937 {
9938 if ((rkd != FFEINFO_kindANY)
9939 && ffebad_start (FFEBAD_MATH_ARG_KIND))
9940 {
9941 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9942 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9943 ffebad_string ("an array");
9944 ffebad_finish ();
9945 }
9946 }
9947
9948 reduced = ffebld_new_any ();
9949 ffebld_set_info (reduced, ffeinfo_new_any ());
9950 return reduced;
9951 }
9952
9953 /* ffeexpr_reduced_power_ -- Wrap up reduction of ** operator
9954
9955 reduced = ffeexpr_reduced_power_(reduced,l,op,r);
9956
9957 Makes sure the left and right arguments for reduced have basictype of
9958 INTEGER, REAL, or COMPLEX. Determine common basictype and
9959 size for reduction (flag expression for combined hollerith/typeless
9960 situations for later determination of effective basictype). If both left
9961 and right arguments have where of CONSTANT, assign where CONSTANT to
9962 reduced, else assign where FLEETING. Create CONVERT ops for args where
9963 needed. Note that real**int or complex**int
9964 comes out as int = real**int etc with no conversions.
9965
9966 If these requirements cannot be met, generate error message using the
9967 info in l, op, and r arguments and assign basictype, size, kind, and where
9968 of ANY. */
9969
9970 static ffebld
9971 ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9972 ffeexprExpr_ r)
9973 {
9974 ffeinfo linfo, rinfo, ninfo;
9975 ffeinfoBasictype lbt, rbt, nbt;
9976 ffeinfoKindtype lkt, rkt, nkt;
9977 ffeinfoRank lrk, rrk;
9978 ffeinfoKind lkd, rkd;
9979 ffeinfoWhere lwh, rwh, nwh;
9980
9981 linfo = ffebld_info (ffebld_left (reduced));
9982 lbt = ffeinfo_basictype (linfo);
9983 lkt = ffeinfo_kindtype (linfo);
9984 lrk = ffeinfo_rank (linfo);
9985 lkd = ffeinfo_kind (linfo);
9986 lwh = ffeinfo_where (linfo);
9987
9988 rinfo = ffebld_info (ffebld_right (reduced));
9989 rbt = ffeinfo_basictype (rinfo);
9990 rkt = ffeinfo_kindtype (rinfo);
9991 rrk = ffeinfo_rank (rinfo);
9992 rkd = ffeinfo_kind (rinfo);
9993 rwh = ffeinfo_where (rinfo);
9994
9995 if ((rbt == FFEINFO_basictypeINTEGER)
9996 && ((lbt == FFEINFO_basictypeREAL)
9997 || (lbt == FFEINFO_basictypeCOMPLEX)))
9998 {
9999 nbt = lbt;
10000 nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDEFAULT);
10001 if (nkt != FFEINFO_kindtypeREALDEFAULT)
10002 {
10003 nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDOUBLE);
10004 if (nkt != FFEINFO_kindtypeREALDOUBLE)
10005 nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */
10006 }
10007 if (rkt == FFEINFO_kindtypeINTEGER4)
10008 {
10009 /* xgettext:no-c-format */
10010 ffebad_start_msg ("Unsupported operand for ** at %1 -- converting to default INTEGER",
10011 FFEBAD_severityWARNING);
10012 ffebad_here (0, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10013 ffebad_finish ();
10014 }
10015 if (rkt != FFEINFO_kindtypeINTEGERDEFAULT)
10016 {
10017 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10018 r->token, op->token,
10019 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0,
10020 FFETARGET_charactersizeNONE,
10021 FFEEXPR_contextLET));
10022 rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10023 }
10024 }
10025 else
10026 {
10027 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10028
10029 #if 0 /* INTEGER4**INTEGER4 works now. */
10030 if ((nbt == FFEINFO_basictypeINTEGER)
10031 && (nkt != FFEINFO_kindtypeINTEGERDEFAULT))
10032 nkt = FFEINFO_kindtypeINTEGERDEFAULT; /* Highest kt we can power! */
10033 #endif
10034 if (((nbt == FFEINFO_basictypeREAL)
10035 || (nbt == FFEINFO_basictypeCOMPLEX))
10036 && (nkt != FFEINFO_kindtypeREALDEFAULT))
10037 {
10038 nkt = ffeinfo_kindtype_max (nbt, nkt, FFEINFO_kindtypeREALDOUBLE);
10039 if (nkt != FFEINFO_kindtypeREALDOUBLE)
10040 nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */
10041 }
10042 /* else Gonna turn into an error below. */
10043 }
10044
10045 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10046 || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
10047 {
10048 switch (lwh)
10049 {
10050 case FFEINFO_whereCONSTANT:
10051 switch (rwh)
10052 {
10053 case FFEINFO_whereCONSTANT:
10054 nwh = FFEINFO_whereCONSTANT;
10055 break;
10056
10057 case FFEINFO_whereIMMEDIATE:
10058 nwh = FFEINFO_whereIMMEDIATE;
10059 break;
10060
10061 default:
10062 nwh = FFEINFO_whereFLEETING;
10063 break;
10064 }
10065 break;
10066
10067 case FFEINFO_whereIMMEDIATE:
10068 switch (rwh)
10069 {
10070 case FFEINFO_whereCONSTANT:
10071 case FFEINFO_whereIMMEDIATE:
10072 nwh = FFEINFO_whereIMMEDIATE;
10073 break;
10074
10075 default:
10076 nwh = FFEINFO_whereFLEETING;
10077 break;
10078 }
10079 break;
10080
10081 default:
10082 nwh = FFEINFO_whereFLEETING;
10083 break;
10084 }
10085
10086 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10087 FFETARGET_charactersizeNONE);
10088 ffebld_set_info (reduced, ninfo);
10089 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10090 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10091 FFEEXPR_contextLET));
10092 if (rbt != FFEINFO_basictypeINTEGER)
10093 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10094 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10095 FFEEXPR_contextLET));
10096 return reduced;
10097 }
10098
10099 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10100 && (lbt != FFEINFO_basictypeCOMPLEX))
10101 {
10102 if ((rbt != FFEINFO_basictypeINTEGER)
10103 && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
10104 {
10105 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10106 && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
10107 {
10108 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10109 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10110 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10111 ffebad_finish ();
10112 }
10113 }
10114 else
10115 {
10116 if ((lbt != FFEINFO_basictypeANY)
10117 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
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_finish ();
10122 }
10123 }
10124 }
10125 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10126 && (rbt != FFEINFO_basictypeCOMPLEX))
10127 {
10128 if ((rbt != FFEINFO_basictypeANY)
10129 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10130 {
10131 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10132 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10133 ffebad_finish ();
10134 }
10135 }
10136 else if (lrk != 0)
10137 {
10138 if ((lkd != FFEINFO_kindANY)
10139 && ffebad_start (FFEBAD_MATH_ARG_KIND))
10140 {
10141 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10142 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10143 ffebad_string ("an array");
10144 ffebad_finish ();
10145 }
10146 }
10147 else
10148 {
10149 if ((rkd != FFEINFO_kindANY)
10150 && ffebad_start (FFEBAD_MATH_ARG_KIND))
10151 {
10152 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10153 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10154 ffebad_string ("an array");
10155 ffebad_finish ();
10156 }
10157 }
10158
10159 reduced = ffebld_new_any ();
10160 ffebld_set_info (reduced, ffeinfo_new_any ());
10161 return reduced;
10162 }
10163
10164 /* ffeexpr_reduced_relop2_ -- Wrap up reduction of LT, LE, GE, and GT operators
10165
10166 reduced = ffeexpr_reduced_relop2_(reduced,l,op,r);
10167
10168 Makes sure the left and right arguments for reduced have basictype of
10169 INTEGER, REAL, or CHARACTER. Determine common basictype and
10170 size for reduction. If both left
10171 and right arguments have where of CONSTANT, assign where CONSTANT to
10172 reduced, else assign where FLEETING. Create CONVERT ops for args where
10173 needed. Convert typeless
10174 constants to the desired type/size explicitly.
10175
10176 If these requirements cannot be met, generate error message. */
10177
10178 static ffebld
10179 ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10180 ffeexprExpr_ r)
10181 {
10182 ffeinfo linfo, rinfo, ninfo;
10183 ffeinfoBasictype lbt, rbt, nbt;
10184 ffeinfoKindtype lkt, rkt, nkt;
10185 ffeinfoRank lrk, rrk;
10186 ffeinfoKind lkd, rkd;
10187 ffeinfoWhere lwh, rwh, nwh;
10188 ffetargetCharacterSize lsz, rsz;
10189
10190 linfo = ffebld_info (ffebld_left (reduced));
10191 lbt = ffeinfo_basictype (linfo);
10192 lkt = ffeinfo_kindtype (linfo);
10193 lrk = ffeinfo_rank (linfo);
10194 lkd = ffeinfo_kind (linfo);
10195 lwh = ffeinfo_where (linfo);
10196 lsz = ffebld_size_known (ffebld_left (reduced));
10197
10198 rinfo = ffebld_info (ffebld_right (reduced));
10199 rbt = ffeinfo_basictype (rinfo);
10200 rkt = ffeinfo_kindtype (rinfo);
10201 rrk = ffeinfo_rank (rinfo);
10202 rkd = ffeinfo_kind (rinfo);
10203 rwh = ffeinfo_where (rinfo);
10204 rsz = ffebld_size_known (ffebld_right (reduced));
10205
10206 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10207
10208 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10209 || (nbt == FFEINFO_basictypeCHARACTER))
10210 && (lrk == 0) && (rrk == 0))
10211 {
10212 switch (lwh)
10213 {
10214 case FFEINFO_whereCONSTANT:
10215 switch (rwh)
10216 {
10217 case FFEINFO_whereCONSTANT:
10218 nwh = FFEINFO_whereCONSTANT;
10219 break;
10220
10221 case FFEINFO_whereIMMEDIATE:
10222 nwh = FFEINFO_whereIMMEDIATE;
10223 break;
10224
10225 default:
10226 nwh = FFEINFO_whereFLEETING;
10227 break;
10228 }
10229 break;
10230
10231 case FFEINFO_whereIMMEDIATE:
10232 switch (rwh)
10233 {
10234 case FFEINFO_whereCONSTANT:
10235 case FFEINFO_whereIMMEDIATE:
10236 nwh = FFEINFO_whereIMMEDIATE;
10237 break;
10238
10239 default:
10240 nwh = FFEINFO_whereFLEETING;
10241 break;
10242 }
10243 break;
10244
10245 default:
10246 nwh = FFEINFO_whereFLEETING;
10247 break;
10248 }
10249
10250 if ((lsz != FFETARGET_charactersizeNONE)
10251 && (rsz != FFETARGET_charactersizeNONE))
10252 lsz = rsz = (lsz > rsz) ? lsz : rsz;
10253
10254 ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
10255 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
10256 ffebld_set_info (reduced, ninfo);
10257 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10258 l->token, op->token, nbt, nkt, 0, lsz,
10259 FFEEXPR_contextLET));
10260 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10261 r->token, op->token, nbt, nkt, 0, rsz,
10262 FFEEXPR_contextLET));
10263 return reduced;
10264 }
10265
10266 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10267 && (lbt != FFEINFO_basictypeCHARACTER))
10268 {
10269 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10270 && (rbt != FFEINFO_basictypeCHARACTER))
10271 {
10272 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10273 && ffebad_start (FFEBAD_RELOP_ARGS_TYPE))
10274 {
10275 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10276 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10277 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10278 ffebad_finish ();
10279 }
10280 }
10281 else
10282 {
10283 if ((lbt != FFEINFO_basictypeANY)
10284 && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
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_finish ();
10289 }
10290 }
10291 }
10292 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10293 && (rbt != FFEINFO_basictypeCHARACTER))
10294 {
10295 if ((rbt != FFEINFO_basictypeANY)
10296 && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
10297 {
10298 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10299 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10300 ffebad_finish ();
10301 }
10302 }
10303 else if (lrk != 0)
10304 {
10305 if ((lkd != FFEINFO_kindANY)
10306 && ffebad_start (FFEBAD_RELOP_ARG_KIND))
10307 {
10308 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10309 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10310 ffebad_string ("an array");
10311 ffebad_finish ();
10312 }
10313 }
10314 else
10315 {
10316 if ((rkd != FFEINFO_kindANY)
10317 && ffebad_start (FFEBAD_RELOP_ARG_KIND))
10318 {
10319 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10320 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10321 ffebad_string ("an array");
10322 ffebad_finish ();
10323 }
10324 }
10325
10326 reduced = ffebld_new_any ();
10327 ffebld_set_info (reduced, ffeinfo_new_any ());
10328 return reduced;
10329 }
10330
10331 /* ffeexpr_reduced_ugly1_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
10332
10333 reduced = ffeexpr_reduced_ugly1_(reduced,op,r);
10334
10335 Sigh. */
10336
10337 static ffebld
10338 ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10339 {
10340 ffeinfo rinfo;
10341 ffeinfoBasictype rbt;
10342 ffeinfoKindtype rkt;
10343 ffeinfoRank rrk;
10344 ffeinfoKind rkd;
10345 ffeinfoWhere rwh;
10346
10347 rinfo = ffebld_info (ffebld_left (reduced));
10348 rbt = ffeinfo_basictype (rinfo);
10349 rkt = ffeinfo_kindtype (rinfo);
10350 rrk = ffeinfo_rank (rinfo);
10351 rkd = ffeinfo_kind (rinfo);
10352 rwh = ffeinfo_where (rinfo);
10353
10354 if ((rbt == FFEINFO_basictypeTYPELESS)
10355 || (rbt == FFEINFO_basictypeHOLLERITH))
10356 {
10357 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10358 r->token, op->token, FFEINFO_basictypeINTEGER,
10359 FFEINFO_kindtypeINTEGERDEFAULT, 0,
10360 FFETARGET_charactersizeNONE,
10361 FFEEXPR_contextLET));
10362 rinfo = ffebld_info (ffebld_left (reduced));
10363 rbt = FFEINFO_basictypeINTEGER;
10364 rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10365 rrk = 0;
10366 rkd = FFEINFO_kindENTITY;
10367 rwh = ffeinfo_where (rinfo);
10368 }
10369
10370 if (rbt == FFEINFO_basictypeLOGICAL)
10371 {
10372 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10373 r->token, op->token, FFEINFO_basictypeINTEGER,
10374 FFEINFO_kindtypeINTEGERDEFAULT, 0,
10375 FFETARGET_charactersizeNONE,
10376 FFEEXPR_contextLET));
10377 }
10378
10379 return reduced;
10380 }
10381
10382 /* ffeexpr_reduced_ugly1log_ -- Deal with TYPELESS and HOLLERITH
10383
10384 reduced = ffeexpr_reduced_ugly1log_(reduced,op,r);
10385
10386 Sigh. */
10387
10388 static ffebld
10389 ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10390 {
10391 ffeinfo rinfo;
10392 ffeinfoBasictype rbt;
10393 ffeinfoKindtype rkt;
10394 ffeinfoRank rrk;
10395 ffeinfoKind rkd;
10396 ffeinfoWhere rwh;
10397
10398 rinfo = ffebld_info (ffebld_left (reduced));
10399 rbt = ffeinfo_basictype (rinfo);
10400 rkt = ffeinfo_kindtype (rinfo);
10401 rrk = ffeinfo_rank (rinfo);
10402 rkd = ffeinfo_kind (rinfo);
10403 rwh = ffeinfo_where (rinfo);
10404
10405 if ((rbt == FFEINFO_basictypeTYPELESS)
10406 || (rbt == FFEINFO_basictypeHOLLERITH))
10407 {
10408 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10409 r->token, op->token, FFEINFO_basictypeLOGICAL, 0,
10410 FFEINFO_kindtypeLOGICALDEFAULT,
10411 FFETARGET_charactersizeNONE,
10412 FFEEXPR_contextLET));
10413 rinfo = ffebld_info (ffebld_left (reduced));
10414 rbt = FFEINFO_basictypeLOGICAL;
10415 rkt = FFEINFO_kindtypeLOGICALDEFAULT;
10416 rrk = 0;
10417 rkd = FFEINFO_kindENTITY;
10418 rwh = ffeinfo_where (rinfo);
10419 }
10420
10421 return reduced;
10422 }
10423
10424 /* ffeexpr_reduced_ugly2_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
10425
10426 reduced = ffeexpr_reduced_ugly2_(reduced,l,op,r);
10427
10428 Sigh. */
10429
10430 static ffebld
10431 ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10432 ffeexprExpr_ r)
10433 {
10434 ffeinfo linfo, rinfo;
10435 ffeinfoBasictype lbt, rbt;
10436 ffeinfoKindtype lkt, rkt;
10437 ffeinfoRank lrk, rrk;
10438 ffeinfoKind lkd, rkd;
10439 ffeinfoWhere lwh, rwh;
10440
10441 linfo = ffebld_info (ffebld_left (reduced));
10442 lbt = ffeinfo_basictype (linfo);
10443 lkt = ffeinfo_kindtype (linfo);
10444 lrk = ffeinfo_rank (linfo);
10445 lkd = ffeinfo_kind (linfo);
10446 lwh = ffeinfo_where (linfo);
10447
10448 rinfo = ffebld_info (ffebld_right (reduced));
10449 rbt = ffeinfo_basictype (rinfo);
10450 rkt = ffeinfo_kindtype (rinfo);
10451 rrk = ffeinfo_rank (rinfo);
10452 rkd = ffeinfo_kind (rinfo);
10453 rwh = ffeinfo_where (rinfo);
10454
10455 if ((lbt == FFEINFO_basictypeTYPELESS)
10456 || (lbt == FFEINFO_basictypeHOLLERITH))
10457 {
10458 if ((rbt == FFEINFO_basictypeTYPELESS)
10459 || (rbt == FFEINFO_basictypeHOLLERITH))
10460 {
10461 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10462 l->token, op->token, FFEINFO_basictypeINTEGER,
10463 FFEINFO_kindtypeINTEGERDEFAULT, 0,
10464 FFETARGET_charactersizeNONE,
10465 FFEEXPR_contextLET));
10466 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10467 r->token, op->token, FFEINFO_basictypeINTEGER, 0,
10468 FFEINFO_kindtypeINTEGERDEFAULT,
10469 FFETARGET_charactersizeNONE,
10470 FFEEXPR_contextLET));
10471 linfo = ffebld_info (ffebld_left (reduced));
10472 rinfo = ffebld_info (ffebld_right (reduced));
10473 lbt = rbt = FFEINFO_basictypeINTEGER;
10474 lkt = rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10475 lrk = rrk = 0;
10476 lkd = rkd = FFEINFO_kindENTITY;
10477 lwh = ffeinfo_where (linfo);
10478 rwh = ffeinfo_where (rinfo);
10479 }
10480 else
10481 {
10482 ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
10483 l->token, ffebld_right (reduced), r->token,
10484 FFEEXPR_contextLET));
10485 linfo = ffebld_info (ffebld_left (reduced));
10486 lbt = ffeinfo_basictype (linfo);
10487 lkt = ffeinfo_kindtype (linfo);
10488 lrk = ffeinfo_rank (linfo);
10489 lkd = ffeinfo_kind (linfo);
10490 lwh = ffeinfo_where (linfo);
10491 }
10492 }
10493 else
10494 {
10495 if ((rbt == FFEINFO_basictypeTYPELESS)
10496 || (rbt == FFEINFO_basictypeHOLLERITH))
10497 {
10498 ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
10499 r->token, ffebld_left (reduced), l->token,
10500 FFEEXPR_contextLET));
10501 rinfo = ffebld_info (ffebld_right (reduced));
10502 rbt = ffeinfo_basictype (rinfo);
10503 rkt = ffeinfo_kindtype (rinfo);
10504 rrk = ffeinfo_rank (rinfo);
10505 rkd = ffeinfo_kind (rinfo);
10506 rwh = ffeinfo_where (rinfo);
10507 }
10508 /* else Leave it alone. */
10509 }
10510
10511 if (lbt == FFEINFO_basictypeLOGICAL)
10512 {
10513 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10514 l->token, op->token, FFEINFO_basictypeINTEGER,
10515 FFEINFO_kindtypeINTEGERDEFAULT, 0,
10516 FFETARGET_charactersizeNONE,
10517 FFEEXPR_contextLET));
10518 }
10519
10520 if (rbt == FFEINFO_basictypeLOGICAL)
10521 {
10522 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10523 r->token, op->token, FFEINFO_basictypeINTEGER,
10524 FFEINFO_kindtypeINTEGERDEFAULT, 0,
10525 FFETARGET_charactersizeNONE,
10526 FFEEXPR_contextLET));
10527 }
10528
10529 return reduced;
10530 }
10531
10532 /* ffeexpr_reduced_ugly2log_ -- Deal with TYPELESS and HOLLERITH
10533
10534 reduced = ffeexpr_reduced_ugly2log_(reduced,l,op,r);
10535
10536 Sigh. */
10537
10538 static ffebld
10539 ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10540 ffeexprExpr_ r, bool *bothlogical)
10541 {
10542 ffeinfo linfo, rinfo;
10543 ffeinfoBasictype lbt, rbt;
10544 ffeinfoKindtype lkt, rkt;
10545 ffeinfoRank lrk, rrk;
10546 ffeinfoKind lkd, rkd;
10547 ffeinfoWhere lwh, rwh;
10548
10549 linfo = ffebld_info (ffebld_left (reduced));
10550 lbt = ffeinfo_basictype (linfo);
10551 lkt = ffeinfo_kindtype (linfo);
10552 lrk = ffeinfo_rank (linfo);
10553 lkd = ffeinfo_kind (linfo);
10554 lwh = ffeinfo_where (linfo);
10555
10556 rinfo = ffebld_info (ffebld_right (reduced));
10557 rbt = ffeinfo_basictype (rinfo);
10558 rkt = ffeinfo_kindtype (rinfo);
10559 rrk = ffeinfo_rank (rinfo);
10560 rkd = ffeinfo_kind (rinfo);
10561 rwh = ffeinfo_where (rinfo);
10562
10563 if ((lbt == FFEINFO_basictypeTYPELESS)
10564 || (lbt == FFEINFO_basictypeHOLLERITH))
10565 {
10566 if ((rbt == FFEINFO_basictypeTYPELESS)
10567 || (rbt == FFEINFO_basictypeHOLLERITH))
10568 {
10569 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10570 l->token, op->token, FFEINFO_basictypeLOGICAL,
10571 FFEINFO_kindtypeLOGICALDEFAULT, 0,
10572 FFETARGET_charactersizeNONE,
10573 FFEEXPR_contextLET));
10574 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10575 r->token, op->token, FFEINFO_basictypeLOGICAL,
10576 FFEINFO_kindtypeLOGICALDEFAULT, 0,
10577 FFETARGET_charactersizeNONE,
10578 FFEEXPR_contextLET));
10579 linfo = ffebld_info (ffebld_left (reduced));
10580 rinfo = ffebld_info (ffebld_right (reduced));
10581 lbt = rbt = FFEINFO_basictypeLOGICAL;
10582 lkt = rkt = FFEINFO_kindtypeLOGICALDEFAULT;
10583 lrk = rrk = 0;
10584 lkd = rkd = FFEINFO_kindENTITY;
10585 lwh = ffeinfo_where (linfo);
10586 rwh = ffeinfo_where (rinfo);
10587 }
10588 else
10589 {
10590 ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
10591 l->token, ffebld_right (reduced), r->token,
10592 FFEEXPR_contextLET));
10593 linfo = ffebld_info (ffebld_left (reduced));
10594 lbt = ffeinfo_basictype (linfo);
10595 lkt = ffeinfo_kindtype (linfo);
10596 lrk = ffeinfo_rank (linfo);
10597 lkd = ffeinfo_kind (linfo);
10598 lwh = ffeinfo_where (linfo);
10599 }
10600 }
10601 else
10602 {
10603 if ((rbt == FFEINFO_basictypeTYPELESS)
10604 || (rbt == FFEINFO_basictypeHOLLERITH))
10605 {
10606 ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
10607 r->token, ffebld_left (reduced), l->token,
10608 FFEEXPR_contextLET));
10609 rinfo = ffebld_info (ffebld_right (reduced));
10610 rbt = ffeinfo_basictype (rinfo);
10611 rkt = ffeinfo_kindtype (rinfo);
10612 rrk = ffeinfo_rank (rinfo);
10613 rkd = ffeinfo_kind (rinfo);
10614 rwh = ffeinfo_where (rinfo);
10615 }
10616 /* else Leave it alone. */
10617 }
10618
10619 if (lbt == FFEINFO_basictypeLOGICAL)
10620 {
10621 ffebld_set_left (reduced,
10622 ffeexpr_convert (ffebld_left (reduced),
10623 l->token, op->token,
10624 FFEINFO_basictypeINTEGER,
10625 FFEINFO_kindtypeINTEGERDEFAULT, 0,
10626 FFETARGET_charactersizeNONE,
10627 FFEEXPR_contextLET));
10628 }
10629
10630 if (rbt == FFEINFO_basictypeLOGICAL)
10631 {
10632 ffebld_set_right (reduced,
10633 ffeexpr_convert (ffebld_right (reduced),
10634 r->token, op->token,
10635 FFEINFO_basictypeINTEGER,
10636 FFEINFO_kindtypeINTEGERDEFAULT, 0,
10637 FFETARGET_charactersizeNONE,
10638 FFEEXPR_contextLET));
10639 }
10640
10641 if (bothlogical != NULL)
10642 *bothlogical = (lbt == FFEINFO_basictypeLOGICAL
10643 && rbt == FFEINFO_basictypeLOGICAL);
10644
10645 return reduced;
10646 }
10647
10648 /* Fumble through tokens until a nonmatching CLOSE_PAREN, EOS, or SEMICOLON
10649 is found.
10650
10651 The idea is to process the tokens as they would be done by normal
10652 expression processing, with the key things being telling the lexer
10653 when hollerith/character constants are about to happen, until the
10654 true closing token is found. */
10655
10656 static ffelexHandler
10657 ffeexpr_find_close_paren_ (ffelexToken t,
10658 ffelexHandler after)
10659 {
10660 ffeexpr_find_.after = after;
10661 ffeexpr_find_.level = 1;
10662 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10663 }
10664
10665 static ffelexHandler
10666 ffeexpr_nil_finished_ (ffelexToken t)
10667 {
10668 switch (ffelex_token_type (t))
10669 {
10670 case FFELEX_typeCLOSE_PAREN:
10671 if (--ffeexpr_find_.level == 0)
10672 return (ffelexHandler) ffeexpr_find_.after;
10673 return (ffelexHandler) ffeexpr_nil_binary_;
10674
10675 case FFELEX_typeCOMMA:
10676 case FFELEX_typeCOLON:
10677 case FFELEX_typeEQUALS:
10678 case FFELEX_typePOINTS:
10679 return (ffelexHandler) ffeexpr_nil_rhs_;
10680
10681 default:
10682 if (--ffeexpr_find_.level == 0)
10683 return (ffelexHandler) ffeexpr_find_.after (t);
10684 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10685 }
10686 }
10687
10688 static ffelexHandler
10689 ffeexpr_nil_rhs_ (ffelexToken t)
10690 {
10691 switch (ffelex_token_type (t))
10692 {
10693 case FFELEX_typeQUOTE:
10694 if (ffe_is_vxt ())
10695 return (ffelexHandler) ffeexpr_nil_quote_;
10696 ffelex_set_expecting_hollerith (-1, '\"',
10697 ffelex_token_where_line (t),
10698 ffelex_token_where_column (t));
10699 return (ffelexHandler) ffeexpr_nil_apostrophe_;
10700
10701 case FFELEX_typeAPOSTROPHE:
10702 ffelex_set_expecting_hollerith (-1, '\'',
10703 ffelex_token_where_line (t),
10704 ffelex_token_where_column (t));
10705 return (ffelexHandler) ffeexpr_nil_apostrophe_;
10706
10707 case FFELEX_typePERCENT:
10708 return (ffelexHandler) ffeexpr_nil_percent_;
10709
10710 case FFELEX_typeOPEN_PAREN:
10711 ++ffeexpr_find_.level;
10712 return (ffelexHandler) ffeexpr_nil_rhs_;
10713
10714 case FFELEX_typePLUS:
10715 case FFELEX_typeMINUS:
10716 return (ffelexHandler) ffeexpr_nil_rhs_;
10717
10718 case FFELEX_typePERIOD:
10719 return (ffelexHandler) ffeexpr_nil_period_;
10720
10721 case FFELEX_typeNUMBER:
10722 ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
10723 if (ffeexpr_hollerith_count_ > 0)
10724 ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
10725 '\0',
10726 ffelex_token_where_line (t),
10727 ffelex_token_where_column (t));
10728 return (ffelexHandler) ffeexpr_nil_number_;
10729
10730 case FFELEX_typeNAME:
10731 case FFELEX_typeNAMES:
10732 return (ffelexHandler) ffeexpr_nil_name_rhs_;
10733
10734 case FFELEX_typeASTERISK:
10735 case FFELEX_typeSLASH:
10736 case FFELEX_typePOWER:
10737 case FFELEX_typeCONCAT:
10738 case FFELEX_typeREL_EQ:
10739 case FFELEX_typeREL_NE:
10740 case FFELEX_typeREL_LE:
10741 case FFELEX_typeREL_GE:
10742 return (ffelexHandler) ffeexpr_nil_rhs_;
10743
10744 default:
10745 return (ffelexHandler) ffeexpr_nil_finished_ (t);
10746 }
10747 }
10748
10749 static ffelexHandler
10750 ffeexpr_nil_period_ (ffelexToken t)
10751 {
10752 switch (ffelex_token_type (t))
10753 {
10754 case FFELEX_typeNAME:
10755 case FFELEX_typeNAMES:
10756 ffeexpr_current_dotdot_ = ffestr_other (t);
10757 switch (ffeexpr_current_dotdot_)
10758 {
10759 case FFESTR_otherNone:
10760 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10761
10762 case FFESTR_otherTRUE:
10763 case FFESTR_otherFALSE:
10764 case FFESTR_otherNOT:
10765 return (ffelexHandler) ffeexpr_nil_end_period_;
10766
10767 default:
10768 return (ffelexHandler) ffeexpr_nil_swallow_period_;
10769 }
10770 break; /* Nothing really reaches here. */
10771
10772 case FFELEX_typeNUMBER:
10773 return (ffelexHandler) ffeexpr_nil_real_;
10774
10775 default:
10776 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10777 }
10778 }
10779
10780 static ffelexHandler
10781 ffeexpr_nil_end_period_ (ffelexToken t)
10782 {
10783 switch (ffeexpr_current_dotdot_)
10784 {
10785 case FFESTR_otherNOT:
10786 if (ffelex_token_type (t) != FFELEX_typePERIOD)
10787 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10788 return (ffelexHandler) ffeexpr_nil_rhs_;
10789
10790 case FFESTR_otherTRUE:
10791 case FFESTR_otherFALSE:
10792 if (ffelex_token_type (t) != FFELEX_typePERIOD)
10793 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10794 return (ffelexHandler) ffeexpr_nil_binary_;
10795
10796 default:
10797 assert ("Bad [nil] unary dotdot in ffeexpr_current_dotdot_" == NULL);
10798 exit (0);
10799 return NULL;
10800 }
10801 }
10802
10803 static ffelexHandler
10804 ffeexpr_nil_swallow_period_ (ffelexToken t)
10805 {
10806 if (ffelex_token_type (t) != FFELEX_typePERIOD)
10807 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10808 return (ffelexHandler) ffeexpr_nil_rhs_;
10809 }
10810
10811 static ffelexHandler
10812 ffeexpr_nil_real_ (ffelexToken t)
10813 {
10814 char d;
10815 const char *p;
10816
10817 if (((ffelex_token_type (t) != FFELEX_typeNAME)
10818 && (ffelex_token_type (t) != FFELEX_typeNAMES))
10819 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
10820 'D', 'd')
10821 || ffesrc_char_match_init (d, 'E', 'e')
10822 || ffesrc_char_match_init (d, 'Q', 'q')))
10823 && ffeexpr_isdigits_ (++p)))
10824 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10825
10826 if (*p == '\0')
10827 return (ffelexHandler) ffeexpr_nil_real_exponent_;
10828 return (ffelexHandler) ffeexpr_nil_binary_;
10829 }
10830
10831 static ffelexHandler
10832 ffeexpr_nil_real_exponent_ (ffelexToken t)
10833 {
10834 if ((ffelex_token_type (t) != FFELEX_typePLUS)
10835 && (ffelex_token_type (t) != FFELEX_typeMINUS))
10836 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10837
10838 return (ffelexHandler) ffeexpr_nil_real_exp_sign_;
10839 }
10840
10841 static ffelexHandler
10842 ffeexpr_nil_real_exp_sign_ (ffelexToken t)
10843 {
10844 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
10845 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10846 return (ffelexHandler) ffeexpr_nil_binary_;
10847 }
10848
10849 static ffelexHandler
10850 ffeexpr_nil_number_ (ffelexToken t)
10851 {
10852 char d;
10853 const char *p;
10854
10855 if (ffeexpr_hollerith_count_ > 0)
10856 ffelex_set_expecting_hollerith (0, '\0',
10857 ffewhere_line_unknown (),
10858 ffewhere_column_unknown ());
10859
10860 switch (ffelex_token_type (t))
10861 {
10862 case FFELEX_typeNAME:
10863 case FFELEX_typeNAMES:
10864 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
10865 'D', 'd')
10866 || ffesrc_char_match_init (d, 'E', 'e')
10867 || ffesrc_char_match_init (d, 'Q', 'q'))
10868 && ffeexpr_isdigits_ (++p))
10869 {
10870 if (*p == '\0')
10871 {
10872 ffeexpr_find_.t = ffelex_token_use (t);
10873 return (ffelexHandler) ffeexpr_nil_number_exponent_;
10874 }
10875 return (ffelexHandler) ffeexpr_nil_binary_;
10876 }
10877 break;
10878
10879 case FFELEX_typePERIOD:
10880 ffeexpr_find_.t = ffelex_token_use (t);
10881 return (ffelexHandler) ffeexpr_nil_number_period_;
10882
10883 case FFELEX_typeHOLLERITH:
10884 return (ffelexHandler) ffeexpr_nil_binary_;
10885
10886 default:
10887 break;
10888 }
10889 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10890 }
10891
10892 /* Expects ffeexpr_find_.t. */
10893
10894 static ffelexHandler
10895 ffeexpr_nil_number_exponent_ (ffelexToken t)
10896 {
10897 ffelexHandler nexthandler;
10898
10899 if ((ffelex_token_type (t) != FFELEX_typePLUS)
10900 && (ffelex_token_type (t) != FFELEX_typeMINUS))
10901 {
10902 nexthandler
10903 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
10904 ffelex_token_kill (ffeexpr_find_.t);
10905 return (ffelexHandler) (*nexthandler) (t);
10906 }
10907
10908 ffelex_token_kill (ffeexpr_find_.t);
10909 return (ffelexHandler) ffeexpr_nil_number_exp_sign_;
10910 }
10911
10912 static ffelexHandler
10913 ffeexpr_nil_number_exp_sign_ (ffelexToken t)
10914 {
10915 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
10916 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10917
10918 return (ffelexHandler) ffeexpr_nil_binary_;
10919 }
10920
10921 /* Expects ffeexpr_find_.t. */
10922
10923 static ffelexHandler
10924 ffeexpr_nil_number_period_ (ffelexToken t)
10925 {
10926 ffelexHandler nexthandler;
10927 char d;
10928 const char *p;
10929
10930 switch (ffelex_token_type (t))
10931 {
10932 case FFELEX_typeNAME:
10933 case FFELEX_typeNAMES:
10934 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
10935 'D', 'd')
10936 || ffesrc_char_match_init (d, 'E', 'e')
10937 || ffesrc_char_match_init (d, 'Q', 'q'))
10938 && ffeexpr_isdigits_ (++p))
10939 {
10940 if (*p == '\0')
10941 return (ffelexHandler) ffeexpr_nil_number_per_exp_;
10942 ffelex_token_kill (ffeexpr_find_.t);
10943 return (ffelexHandler) ffeexpr_nil_binary_;
10944 }
10945 nexthandler
10946 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
10947 ffelex_token_kill (ffeexpr_find_.t);
10948 return (ffelexHandler) (*nexthandler) (t);
10949
10950 case FFELEX_typeNUMBER:
10951 ffelex_token_kill (ffeexpr_find_.t);
10952 return (ffelexHandler) ffeexpr_nil_number_real_;
10953
10954 default:
10955 break;
10956 }
10957 ffelex_token_kill (ffeexpr_find_.t);
10958 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10959 }
10960
10961 /* Expects ffeexpr_find_.t. */
10962
10963 static ffelexHandler
10964 ffeexpr_nil_number_per_exp_ (ffelexToken t)
10965 {
10966 if ((ffelex_token_type (t) != FFELEX_typePLUS)
10967 && (ffelex_token_type (t) != FFELEX_typeMINUS))
10968 {
10969 ffelexHandler nexthandler;
10970
10971 nexthandler
10972 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
10973 ffelex_token_kill (ffeexpr_find_.t);
10974 return (ffelexHandler) (*nexthandler) (t);
10975 }
10976
10977 ffelex_token_kill (ffeexpr_find_.t);
10978 return (ffelexHandler) ffeexpr_nil_num_per_exp_sign_;
10979 }
10980
10981 static ffelexHandler
10982 ffeexpr_nil_number_real_ (ffelexToken t)
10983 {
10984 char d;
10985 const char *p;
10986
10987 if (((ffelex_token_type (t) != FFELEX_typeNAME)
10988 && (ffelex_token_type (t) != FFELEX_typeNAMES))
10989 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
10990 'D', 'd')
10991 || ffesrc_char_match_init (d, 'E', 'e')
10992 || ffesrc_char_match_init (d, 'Q', 'q')))
10993 && ffeexpr_isdigits_ (++p)))
10994 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10995
10996 if (*p == '\0')
10997 return (ffelexHandler) ffeexpr_nil_number_real_exp_;
10998
10999 return (ffelexHandler) ffeexpr_nil_binary_;
11000 }
11001
11002 static ffelexHandler
11003 ffeexpr_nil_num_per_exp_sign_ (ffelexToken t)
11004 {
11005 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11006 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11007 return (ffelexHandler) ffeexpr_nil_binary_;
11008 }
11009
11010 static ffelexHandler
11011 ffeexpr_nil_number_real_exp_ (ffelexToken t)
11012 {
11013 if ((ffelex_token_type (t) != FFELEX_typePLUS)
11014 && (ffelex_token_type (t) != FFELEX_typeMINUS))
11015 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11016 return (ffelexHandler) ffeexpr_nil_num_real_exp_sn_;
11017 }
11018
11019 static ffelexHandler
11020 ffeexpr_nil_num_real_exp_sn_ (ffelexToken t)
11021 {
11022 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11023 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11024 return (ffelexHandler) ffeexpr_nil_binary_;
11025 }
11026
11027 static ffelexHandler
11028 ffeexpr_nil_binary_ (ffelexToken t)
11029 {
11030 switch (ffelex_token_type (t))
11031 {
11032 case FFELEX_typePLUS:
11033 case FFELEX_typeMINUS:
11034 case FFELEX_typeASTERISK:
11035 case FFELEX_typeSLASH:
11036 case FFELEX_typePOWER:
11037 case FFELEX_typeCONCAT:
11038 case FFELEX_typeOPEN_ANGLE:
11039 case FFELEX_typeCLOSE_ANGLE:
11040 case FFELEX_typeREL_EQ:
11041 case FFELEX_typeREL_NE:
11042 case FFELEX_typeREL_GE:
11043 case FFELEX_typeREL_LE:
11044 return (ffelexHandler) ffeexpr_nil_rhs_;
11045
11046 case FFELEX_typePERIOD:
11047 return (ffelexHandler) ffeexpr_nil_binary_period_;
11048
11049 default:
11050 return (ffelexHandler) ffeexpr_nil_finished_ (t);
11051 }
11052 }
11053
11054 static ffelexHandler
11055 ffeexpr_nil_binary_period_ (ffelexToken t)
11056 {
11057 switch (ffelex_token_type (t))
11058 {
11059 case FFELEX_typeNAME:
11060 case FFELEX_typeNAMES:
11061 ffeexpr_current_dotdot_ = ffestr_other (t);
11062 switch (ffeexpr_current_dotdot_)
11063 {
11064 case FFESTR_otherTRUE:
11065 case FFESTR_otherFALSE:
11066 case FFESTR_otherNOT:
11067 return (ffelexHandler) ffeexpr_nil_binary_sw_per_;
11068
11069 default:
11070 return (ffelexHandler) ffeexpr_nil_binary_end_per_;
11071 }
11072 break; /* Nothing really reaches here. */
11073
11074 default:
11075 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11076 }
11077 }
11078
11079 static ffelexHandler
11080 ffeexpr_nil_binary_end_per_ (ffelexToken t)
11081 {
11082 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11083 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11084 return (ffelexHandler) ffeexpr_nil_rhs_;
11085 }
11086
11087 static ffelexHandler
11088 ffeexpr_nil_binary_sw_per_ (ffelexToken t)
11089 {
11090 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11091 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11092 return (ffelexHandler) ffeexpr_nil_binary_;
11093 }
11094
11095 static ffelexHandler
11096 ffeexpr_nil_quote_ (ffelexToken t)
11097 {
11098 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11099 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11100 return (ffelexHandler) ffeexpr_nil_binary_;
11101 }
11102
11103 static ffelexHandler
11104 ffeexpr_nil_apostrophe_ (ffelexToken t)
11105 {
11106 assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
11107 return (ffelexHandler) ffeexpr_nil_apos_char_;
11108 }
11109
11110 static ffelexHandler
11111 ffeexpr_nil_apos_char_ (ffelexToken t)
11112 {
11113 char c;
11114
11115 if ((ffelex_token_type (t) == FFELEX_typeNAME)
11116 || (ffelex_token_type (t) == FFELEX_typeNAMES))
11117 {
11118 if ((ffelex_token_length (t) == 1)
11119 && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]),
11120 'B', 'b')
11121 || ffesrc_char_match_init (c, 'O', 'o')
11122 || ffesrc_char_match_init (c, 'X', 'x')
11123 || ffesrc_char_match_init (c, 'Z', 'z')))
11124 return (ffelexHandler) ffeexpr_nil_binary_;
11125 }
11126 if ((ffelex_token_type (t) == FFELEX_typeNAME)
11127 || (ffelex_token_type (t) == FFELEX_typeNAMES))
11128 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11129 return (ffelexHandler) ffeexpr_nil_substrp_ (t);
11130 }
11131
11132 static ffelexHandler
11133 ffeexpr_nil_name_rhs_ (ffelexToken t)
11134 {
11135 switch (ffelex_token_type (t))
11136 {
11137 case FFELEX_typeQUOTE:
11138 case FFELEX_typeAPOSTROPHE:
11139 ffelex_set_hexnum (TRUE);
11140 return (ffelexHandler) ffeexpr_nil_name_apos_;
11141
11142 case FFELEX_typeOPEN_PAREN:
11143 ++ffeexpr_find_.level;
11144 return (ffelexHandler) ffeexpr_nil_rhs_;
11145
11146 default:
11147 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11148 }
11149 }
11150
11151 static ffelexHandler
11152 ffeexpr_nil_name_apos_ (ffelexToken t)
11153 {
11154 if (ffelex_token_type (t) == FFELEX_typeNAME)
11155 return (ffelexHandler) ffeexpr_nil_name_apos_name_;
11156 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11157 }
11158
11159 static ffelexHandler
11160 ffeexpr_nil_name_apos_name_ (ffelexToken t)
11161 {
11162 switch (ffelex_token_type (t))
11163 {
11164 case FFELEX_typeAPOSTROPHE:
11165 case FFELEX_typeQUOTE:
11166 return (ffelexHandler) ffeexpr_nil_finished_;
11167
11168 default:
11169 return (ffelexHandler) ffeexpr_nil_finished_ (t);
11170 }
11171 }
11172
11173 static ffelexHandler
11174 ffeexpr_nil_percent_ (ffelexToken t)
11175 {
11176 switch (ffelex_token_type (t))
11177 {
11178 case FFELEX_typeNAME:
11179 case FFELEX_typeNAMES:
11180 ffeexpr_stack_->percent = ffeexpr_percent_ (t);
11181 ffeexpr_find_.t = ffelex_token_use (t);
11182 return (ffelexHandler) ffeexpr_nil_percent_name_;
11183
11184 default:
11185 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11186 }
11187 }
11188
11189 /* Expects ffeexpr_find_.t. */
11190
11191 static ffelexHandler
11192 ffeexpr_nil_percent_name_ (ffelexToken t)
11193 {
11194 ffelexHandler nexthandler;
11195
11196 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
11197 {
11198 nexthandler
11199 = (ffelexHandler) ffeexpr_nil_rhs_ (ffeexpr_find_.t);
11200 ffelex_token_kill (ffeexpr_find_.t);
11201 return (ffelexHandler) (*nexthandler) (t);
11202 }
11203
11204 ffelex_token_kill (ffeexpr_find_.t);
11205 ++ffeexpr_find_.level;
11206 return (ffelexHandler) ffeexpr_nil_rhs_;
11207 }
11208
11209 static ffelexHandler
11210 ffeexpr_nil_substrp_ (ffelexToken t)
11211 {
11212 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
11213 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11214
11215 ++ffeexpr_find_.level;
11216 return (ffelexHandler) ffeexpr_nil_rhs_;
11217 }
11218
11219 /* ffeexpr_finished_ -- Reduce expression stack to one expr, finish
11220
11221 ffelexToken t;
11222 return ffeexpr_finished_(t);
11223
11224 Reduces expression stack to one (or zero) elements by repeatedly reducing
11225 the top operator on the stack (or, if the top element on the stack is
11226 itself an operator, issuing an error message and discarding it). Calls
11227 finishing routine with the expression, returning the ffelexHandler it
11228 returns to the caller. */
11229
11230 static ffelexHandler
11231 ffeexpr_finished_ (ffelexToken t)
11232 {
11233 ffeexprExpr_ operand; /* This is B in -B or A+B. */
11234 ffebld expr;
11235 ffeexprCallback callback;
11236 ffeexprStack_ s;
11237 ffebldConstant constnode; /* For detecting magical number. */
11238 ffelexToken ft; /* Temporary copy of first token in
11239 expression. */
11240 ffelexHandler next;
11241 ffeinfo info;
11242 bool error = FALSE;
11243
11244 while (((operand = ffeexpr_stack_->exprstack) != NULL)
11245 && ((operand->previous != NULL) || (operand->type != FFEEXPR_exprtypeOPERAND_)))
11246 {
11247 if (operand->type == FFEEXPR_exprtypeOPERAND_)
11248 ffeexpr_reduce_ ();
11249 else
11250 {
11251 if (ffest_ffebad_start (FFEBAD_MISSING_OPERAND_FOR_OPERATOR))
11252 {
11253 ffebad_here (0, ffelex_token_where_line (t),
11254 ffelex_token_where_column (t));
11255 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
11256 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
11257 ffebad_finish ();
11258 }
11259 ffeexpr_stack_->exprstack = operand->previous; /* Pop the useless
11260 operator. */
11261 ffeexpr_expr_kill_ (operand);
11262 }
11263 }
11264
11265 assert ((operand == NULL) || (operand->previous == NULL));
11266
11267 ffebld_pool_pop ();
11268 if (operand == NULL)
11269 expr = NULL;
11270 else
11271 {
11272 expr = operand->u.operand;
11273 info = ffebld_info (expr);
11274 if ((ffebld_op (expr) == FFEBLD_opCONTER)
11275 && (ffebld_conter_orig (expr) == NULL)
11276 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
11277 {
11278 ffetarget_integer_bad_magical (operand->token);
11279 }
11280 ffeexpr_expr_kill_ (operand);
11281 ffeexpr_stack_->exprstack = NULL;
11282 }
11283
11284 ft = ffeexpr_stack_->first_token;
11285
11286 again: /* :::::::::::::::::::: */
11287 switch (ffeexpr_stack_->context)
11288 {
11289 case FFEEXPR_contextLET:
11290 case FFEEXPR_contextSFUNCDEF:
11291 error = (expr == NULL)
11292 || (ffeinfo_rank (info) != 0);
11293 break;
11294
11295 case FFEEXPR_contextPAREN_:
11296 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11297 break;
11298 switch (ffeinfo_basictype (info))
11299 {
11300 case FFEINFO_basictypeHOLLERITH:
11301 case FFEINFO_basictypeTYPELESS:
11302 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11303 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11304 FFEEXPR_contextLET);
11305 break;
11306
11307 default:
11308 break;
11309 }
11310 break;
11311
11312 case FFEEXPR_contextPARENFILENUM_:
11313 if (ffelex_token_type (t) != FFELEX_typeCOMMA)
11314 ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
11315 else
11316 ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
11317 goto again; /* :::::::::::::::::::: */
11318
11319 case FFEEXPR_contextPARENFILEUNIT_:
11320 if (ffelex_token_type (t) != FFELEX_typeCOMMA)
11321 ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
11322 else
11323 ffeexpr_stack_->context = FFEEXPR_contextFILEUNIT;
11324 goto again; /* :::::::::::::::::::: */
11325
11326 case FFEEXPR_contextACTUALARGEXPR_:
11327 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
11328 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11329 : ffeinfo_basictype (info))
11330 {
11331 case FFEINFO_basictypeHOLLERITH:
11332 case FFEINFO_basictypeTYPELESS:
11333 if (!ffe_is_ugly_args ()
11334 && ffebad_start (FFEBAD_ACTUALARG))
11335 {
11336 ffebad_here (0, ffelex_token_where_line (ft),
11337 ffelex_token_where_column (ft));
11338 ffebad_finish ();
11339 }
11340 break;
11341
11342 default:
11343 break;
11344 }
11345 error = (expr != NULL) && (ffeinfo_rank (info) != 0);
11346 break;
11347
11348 case FFEEXPR_contextACTUALARG_:
11349 case FFEEXPR_contextSFUNCDEFACTUALARG_:
11350 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11351 : ffeinfo_basictype (info))
11352 {
11353 case FFEINFO_basictypeHOLLERITH:
11354 case FFEINFO_basictypeTYPELESS:
11355 #if 0 /* Should never get here. */
11356 expr = ffeexpr_convert (expr, ft, ft,
11357 FFEINFO_basictypeINTEGER,
11358 FFEINFO_kindtypeINTEGERDEFAULT,
11359 0,
11360 FFETARGET_charactersizeNONE,
11361 FFEEXPR_contextLET);
11362 #else
11363 assert ("why hollerith/typeless in actualarg_?" == NULL);
11364 #endif
11365 break;
11366
11367 default:
11368 break;
11369 }
11370 switch ((expr == NULL) ? FFEBLD_opANY : ffebld_op (expr))
11371 {
11372 case FFEBLD_opSYMTER:
11373 case FFEBLD_opPERCENT_LOC:
11374 case FFEBLD_opPERCENT_VAL:
11375 case FFEBLD_opPERCENT_REF:
11376 case FFEBLD_opPERCENT_DESCR:
11377 error = FALSE;
11378 break;
11379
11380 default:
11381 error = (expr != NULL) && (ffeinfo_rank (info) != 0);
11382 break;
11383 }
11384 {
11385 ffesymbol s;
11386 ffeinfoWhere where;
11387 ffeinfoKind kind;
11388
11389 if (!error
11390 && (expr != NULL)
11391 && (ffebld_op (expr) == FFEBLD_opSYMTER)
11392 && ((s = ffebld_symter (expr)), (where = ffesymbol_where (s)),
11393 (where == FFEINFO_whereINTRINSIC)
11394 || (where == FFEINFO_whereGLOBAL)
11395 || ((where == FFEINFO_whereDUMMY)
11396 && ((kind = ffesymbol_kind (s)),
11397 (kind == FFEINFO_kindFUNCTION)
11398 || (kind == FFEINFO_kindSUBROUTINE))))
11399 && !ffesymbol_explicitwhere (s))
11400 {
11401 ffebad_start (where == FFEINFO_whereINTRINSIC
11402 ? FFEBAD_NEED_INTRINSIC : FFEBAD_NEED_EXTERNAL);
11403 ffebad_here (0, ffelex_token_where_line (ft),
11404 ffelex_token_where_column (ft));
11405 ffebad_string (ffesymbol_text (s));
11406 ffebad_finish ();
11407 ffesymbol_signal_change (s);
11408 ffesymbol_set_explicitwhere (s, TRUE);
11409 ffesymbol_signal_unreported (s);
11410 }
11411 }
11412 break;
11413
11414 case FFEEXPR_contextINDEX_:
11415 case FFEEXPR_contextSFUNCDEFINDEX_:
11416 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11417 break;
11418 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11419 : ffeinfo_basictype (info))
11420 {
11421 case FFEINFO_basictypeNONE:
11422 error = FALSE;
11423 break;
11424
11425 case FFEINFO_basictypeLOGICAL:
11426 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11427 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11428 FFEEXPR_contextLET);
11429 /* Fall through. */
11430 case FFEINFO_basictypeREAL:
11431 case FFEINFO_basictypeCOMPLEX:
11432 if (ffe_is_pedantic ())
11433 {
11434 error = TRUE;
11435 break;
11436 }
11437 /* Fall through. */
11438 case FFEINFO_basictypeHOLLERITH:
11439 case FFEINFO_basictypeTYPELESS:
11440 error = FALSE;
11441 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11442 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11443 FFEEXPR_contextLET);
11444 break;
11445
11446 case FFEINFO_basictypeINTEGER:
11447 /* Specifically, allow INTEGER(KIND=2), aka INTEGER*8, through
11448 unmolested. Leave it to downstream to handle kinds. */
11449 break;
11450
11451 default:
11452 error = TRUE;
11453 break;
11454 }
11455 break; /* expr==NULL ok for substring; element case
11456 caught by callback. */
11457
11458 case FFEEXPR_contextRETURN:
11459 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11460 break;
11461 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11462 : ffeinfo_basictype (info))
11463 {
11464 case FFEINFO_basictypeNONE:
11465 error = FALSE;
11466 break;
11467
11468 case FFEINFO_basictypeLOGICAL:
11469 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11470 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11471 FFEEXPR_contextLET);
11472 /* Fall through. */
11473 case FFEINFO_basictypeREAL:
11474 case FFEINFO_basictypeCOMPLEX:
11475 if (ffe_is_pedantic ())
11476 {
11477 error = TRUE;
11478 break;
11479 }
11480 /* Fall through. */
11481 case FFEINFO_basictypeINTEGER:
11482 case FFEINFO_basictypeHOLLERITH:
11483 case FFEINFO_basictypeTYPELESS:
11484 error = FALSE;
11485 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11486 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11487 FFEEXPR_contextLET);
11488 break;
11489
11490 default:
11491 error = TRUE;
11492 break;
11493 }
11494 break;
11495
11496 case FFEEXPR_contextDO:
11497 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11498 break;
11499 switch (ffeinfo_basictype (info))
11500 {
11501 case FFEINFO_basictypeLOGICAL:
11502 error = !ffe_is_ugly_logint ();
11503 if (!ffeexpr_stack_->is_rhs)
11504 break; /* Don't convert lhs variable. */
11505 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11506 ffeinfo_kindtype (ffebld_info (expr)), 0,
11507 FFETARGET_charactersizeNONE,
11508 FFEEXPR_contextLET);
11509 break;
11510
11511 case FFEINFO_basictypeHOLLERITH:
11512 case FFEINFO_basictypeTYPELESS:
11513 if (!ffeexpr_stack_->is_rhs)
11514 {
11515 error = TRUE;
11516 break; /* Don't convert lhs variable. */
11517 }
11518 break;
11519
11520 case FFEINFO_basictypeINTEGER:
11521 case FFEINFO_basictypeREAL:
11522 break;
11523
11524 default:
11525 error = TRUE;
11526 break;
11527 }
11528 if (!ffeexpr_stack_->is_rhs
11529 && (ffebld_op (expr) != FFEBLD_opSYMTER))
11530 error = TRUE;
11531 break;
11532
11533 case FFEEXPR_contextDOWHILE:
11534 case FFEEXPR_contextIF:
11535 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11536 break;
11537 switch (ffeinfo_basictype (info))
11538 {
11539 case FFEINFO_basictypeINTEGER:
11540 error = FALSE;
11541 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11542 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11543 FFEEXPR_contextLET);
11544 /* Fall through. */
11545 case FFEINFO_basictypeLOGICAL:
11546 case FFEINFO_basictypeHOLLERITH:
11547 case FFEINFO_basictypeTYPELESS:
11548 error = FALSE;
11549 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11550 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11551 FFEEXPR_contextLET);
11552 break;
11553
11554 default:
11555 error = TRUE;
11556 break;
11557 }
11558 break;
11559
11560 case FFEEXPR_contextASSIGN:
11561 case FFEEXPR_contextAGOTO:
11562 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11563 : ffeinfo_basictype (info))
11564 {
11565 case FFEINFO_basictypeINTEGER:
11566 error = (ffeinfo_kindtype (info) != ffecom_label_kind ());
11567 break;
11568
11569 case FFEINFO_basictypeLOGICAL:
11570 error = !ffe_is_ugly_logint ()
11571 || (ffeinfo_kindtype (info) != ffecom_label_kind ());
11572 break;
11573
11574 default:
11575 error = TRUE;
11576 break;
11577 }
11578 if ((expr == NULL) || (ffeinfo_rank (info) != 0)
11579 || (ffebld_op (expr) != FFEBLD_opSYMTER))
11580 error = TRUE;
11581 break;
11582
11583 case FFEEXPR_contextCGOTO:
11584 case FFEEXPR_contextFORMAT:
11585 case FFEEXPR_contextDIMLIST:
11586 case FFEEXPR_contextFILENUM: /* See equiv code in _ambig_. */
11587 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11588 break;
11589 switch (ffeinfo_basictype (info))
11590 {
11591 case FFEINFO_basictypeLOGICAL:
11592 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11593 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11594 FFEEXPR_contextLET);
11595 /* Fall through. */
11596 case FFEINFO_basictypeREAL:
11597 case FFEINFO_basictypeCOMPLEX:
11598 if (ffe_is_pedantic ())
11599 {
11600 error = TRUE;
11601 break;
11602 }
11603 /* Fall through. */
11604 case FFEINFO_basictypeINTEGER:
11605 case FFEINFO_basictypeHOLLERITH:
11606 case FFEINFO_basictypeTYPELESS:
11607 error = FALSE;
11608 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11609 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11610 FFEEXPR_contextLET);
11611 break;
11612
11613 default:
11614 error = TRUE;
11615 break;
11616 }
11617 break;
11618
11619 case FFEEXPR_contextARITHIF:
11620 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11621 break;
11622 switch (ffeinfo_basictype (info))
11623 {
11624 case FFEINFO_basictypeLOGICAL:
11625 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11626 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11627 FFEEXPR_contextLET);
11628 if (ffe_is_pedantic ())
11629 {
11630 error = TRUE;
11631 break;
11632 }
11633 /* Fall through. */
11634 case FFEINFO_basictypeHOLLERITH:
11635 case FFEINFO_basictypeTYPELESS:
11636 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11637 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11638 FFEEXPR_contextLET);
11639 /* Fall through. */
11640 case FFEINFO_basictypeINTEGER:
11641 case FFEINFO_basictypeREAL:
11642 error = FALSE;
11643 break;
11644
11645 default:
11646 error = TRUE;
11647 break;
11648 }
11649 break;
11650
11651 case FFEEXPR_contextSTOP:
11652 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11653 break;
11654 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11655 : ffeinfo_basictype (info))
11656 {
11657 case FFEINFO_basictypeINTEGER:
11658 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
11659 break;
11660
11661 case FFEINFO_basictypeCHARACTER:
11662 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT);
11663 break;
11664
11665 case FFEINFO_basictypeHOLLERITH:
11666 case FFEINFO_basictypeTYPELESS:
11667 error = FALSE;
11668 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11669 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11670 FFEEXPR_contextLET);
11671 break;
11672
11673 case FFEINFO_basictypeNONE:
11674 error = FALSE;
11675 break;
11676
11677 default:
11678 error = TRUE;
11679 break;
11680 }
11681 if ((expr != NULL) && ((ffebld_op (expr) != FFEBLD_opCONTER)
11682 || (ffebld_conter_orig (expr) != NULL)))
11683 error = TRUE;
11684 break;
11685
11686 case FFEEXPR_contextINCLUDE:
11687 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
11688 || (ffeinfo_basictype (info) != FFEINFO_basictypeCHARACTER)
11689 || (ffebld_op (expr) != FFEBLD_opCONTER)
11690 || (ffebld_conter_orig (expr) != NULL);
11691 break;
11692
11693 case FFEEXPR_contextSELECTCASE:
11694 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11695 break;
11696 switch (ffeinfo_basictype (info))
11697 {
11698 case FFEINFO_basictypeINTEGER:
11699 case FFEINFO_basictypeCHARACTER:
11700 case FFEINFO_basictypeLOGICAL:
11701 error = FALSE;
11702 break;
11703
11704 case FFEINFO_basictypeHOLLERITH:
11705 case FFEINFO_basictypeTYPELESS:
11706 error = FALSE;
11707 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11708 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11709 FFEEXPR_contextLET);
11710 break;
11711
11712 default:
11713 error = TRUE;
11714 break;
11715 }
11716 break;
11717
11718 case FFEEXPR_contextCASE:
11719 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11720 break;
11721 switch ((expr == NULL) ? FFEINFO_basictypeINTEGER
11722 : ffeinfo_basictype (info))
11723 {
11724 case FFEINFO_basictypeINTEGER:
11725 case FFEINFO_basictypeCHARACTER:
11726 case FFEINFO_basictypeLOGICAL:
11727 error = FALSE;
11728 break;
11729
11730 case FFEINFO_basictypeHOLLERITH:
11731 case FFEINFO_basictypeTYPELESS:
11732 error = FALSE;
11733 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11734 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11735 FFEEXPR_contextLET);
11736 break;
11737
11738 default:
11739 error = TRUE;
11740 break;
11741 }
11742 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
11743 error = TRUE;
11744 break;
11745
11746 case FFEEXPR_contextCHARACTERSIZE:
11747 case FFEEXPR_contextKINDTYPE:
11748 case FFEEXPR_contextDIMLISTCOMMON:
11749 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11750 break;
11751 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11752 : ffeinfo_basictype (info))
11753 {
11754 case FFEINFO_basictypeLOGICAL:
11755 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11756 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11757 FFEEXPR_contextLET);
11758 /* Fall through. */
11759 case FFEINFO_basictypeREAL:
11760 case FFEINFO_basictypeCOMPLEX:
11761 if (ffe_is_pedantic ())
11762 {
11763 error = TRUE;
11764 break;
11765 }
11766 /* Fall through. */
11767 case FFEINFO_basictypeINTEGER:
11768 case FFEINFO_basictypeHOLLERITH:
11769 case FFEINFO_basictypeTYPELESS:
11770 error = FALSE;
11771 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11772 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11773 FFEEXPR_contextLET);
11774 break;
11775
11776 default:
11777 error = TRUE;
11778 break;
11779 }
11780 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
11781 error = TRUE;
11782 break;
11783
11784 case FFEEXPR_contextEQVINDEX_:
11785 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11786 break;
11787 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11788 : ffeinfo_basictype (info))
11789 {
11790 case FFEINFO_basictypeNONE:
11791 error = FALSE;
11792 break;
11793
11794 case FFEINFO_basictypeLOGICAL:
11795 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11796 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11797 FFEEXPR_contextLET);
11798 /* Fall through. */
11799 case FFEINFO_basictypeREAL:
11800 case FFEINFO_basictypeCOMPLEX:
11801 if (ffe_is_pedantic ())
11802 {
11803 error = TRUE;
11804 break;
11805 }
11806 /* Fall through. */
11807 case FFEINFO_basictypeINTEGER:
11808 case FFEINFO_basictypeHOLLERITH:
11809 case FFEINFO_basictypeTYPELESS:
11810 error = FALSE;
11811 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11812 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11813 FFEEXPR_contextLET);
11814 break;
11815
11816 default:
11817 error = TRUE;
11818 break;
11819 }
11820 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
11821 error = TRUE;
11822 break;
11823
11824 case FFEEXPR_contextPARAMETER:
11825 if (ffeexpr_stack_->is_rhs)
11826 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
11827 || (ffebld_op (expr) != FFEBLD_opCONTER);
11828 else
11829 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
11830 || (ffebld_op (expr) != FFEBLD_opSYMTER);
11831 break;
11832
11833 case FFEEXPR_contextINDEXORACTUALARG_:
11834 if (ffelex_token_type (t) == FFELEX_typeCOLON)
11835 ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
11836 else
11837 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
11838 goto again; /* :::::::::::::::::::: */
11839
11840 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
11841 if (ffelex_token_type (t) == FFELEX_typeCOLON)
11842 ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
11843 else
11844 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
11845 goto again; /* :::::::::::::::::::: */
11846
11847 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
11848 if (ffelex_token_type (t) == FFELEX_typeCOLON)
11849 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
11850 else
11851 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
11852 goto again; /* :::::::::::::::::::: */
11853
11854 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
11855 if (ffelex_token_type (t) == FFELEX_typeCOLON)
11856 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
11857 else
11858 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
11859 goto again; /* :::::::::::::::::::: */
11860
11861 case FFEEXPR_contextIMPDOCTRL_:
11862 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11863 break;
11864 if (!ffeexpr_stack_->is_rhs
11865 && (ffebld_op (expr) != FFEBLD_opSYMTER))
11866 error = TRUE;
11867 switch (ffeinfo_basictype (info))
11868 {
11869 case FFEINFO_basictypeLOGICAL:
11870 if (! ffe_is_ugly_logint ())
11871 error = TRUE;
11872 if (! ffeexpr_stack_->is_rhs)
11873 break;
11874 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11875 ffeinfo_kindtype (info), 0,
11876 FFETARGET_charactersizeNONE,
11877 FFEEXPR_contextLET);
11878 break;
11879
11880 case FFEINFO_basictypeINTEGER:
11881 case FFEINFO_basictypeHOLLERITH:
11882 case FFEINFO_basictypeTYPELESS:
11883 break;
11884
11885 case FFEINFO_basictypeREAL:
11886 if (!ffeexpr_stack_->is_rhs
11887 && ffe_is_warn_surprising ()
11888 && !error)
11889 {
11890 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
11891 ffebad_here (0, ffelex_token_where_line (ft),
11892 ffelex_token_where_column (ft));
11893 ffebad_string (ffelex_token_text (ft));
11894 ffebad_finish ();
11895 }
11896 break;
11897
11898 default:
11899 error = TRUE;
11900 break;
11901 }
11902 break;
11903
11904 case FFEEXPR_contextDATAIMPDOCTRL_:
11905 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11906 break;
11907 if (ffeexpr_stack_->is_rhs)
11908 {
11909 if ((ffebld_op (expr) != FFEBLD_opCONTER)
11910 && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
11911 error = TRUE;
11912 }
11913 else if ((ffebld_op (expr) != FFEBLD_opSYMTER)
11914 || (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
11915 error = TRUE;
11916 switch (ffeinfo_basictype (info))
11917 {
11918 case FFEINFO_basictypeLOGICAL:
11919 if (! ffeexpr_stack_->is_rhs)
11920 break;
11921 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11922 ffeinfo_kindtype (info), 0,
11923 FFETARGET_charactersizeNONE,
11924 FFEEXPR_contextLET);
11925 /* Fall through. */
11926 case FFEINFO_basictypeINTEGER:
11927 if (ffeexpr_stack_->is_rhs
11928 && (ffeinfo_kindtype (ffebld_info (expr))
11929 != FFEINFO_kindtypeINTEGERDEFAULT))
11930 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11931 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11932 FFETARGET_charactersizeNONE,
11933 FFEEXPR_contextLET);
11934 break;
11935
11936 case FFEINFO_basictypeHOLLERITH:
11937 case FFEINFO_basictypeTYPELESS:
11938 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11939 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11940 FFEEXPR_contextLET);
11941 break;
11942
11943 case FFEINFO_basictypeREAL:
11944 if (!ffeexpr_stack_->is_rhs
11945 && ffe_is_warn_surprising ()
11946 && !error)
11947 {
11948 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
11949 ffebad_here (0, ffelex_token_where_line (ft),
11950 ffelex_token_where_column (ft));
11951 ffebad_string (ffelex_token_text (ft));
11952 ffebad_finish ();
11953 }
11954 break;
11955
11956 default:
11957 error = TRUE;
11958 break;
11959 }
11960 break;
11961
11962 case FFEEXPR_contextIMPDOITEM_:
11963 if (ffelex_token_type (t) == FFELEX_typeEQUALS)
11964 {
11965 ffeexpr_stack_->is_rhs = FALSE;
11966 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
11967 goto again; /* :::::::::::::::::::: */
11968 }
11969 /* Fall through. */
11970 case FFEEXPR_contextIOLIST:
11971 case FFEEXPR_contextFILEVXTCODE:
11972 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11973 : ffeinfo_basictype (info))
11974 {
11975 case FFEINFO_basictypeHOLLERITH:
11976 case FFEINFO_basictypeTYPELESS:
11977 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11978 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11979 FFEEXPR_contextLET);
11980 break;
11981
11982 default:
11983 break;
11984 }
11985 error = (expr == NULL)
11986 || ((ffeinfo_rank (info) != 0)
11987 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
11988 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
11989 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
11990 == FFEBLD_opSTAR))); /* Bad if null expr, or if
11991 array that is not a SYMTER
11992 (can't happen yet, I
11993 think) or has a NULL or
11994 STAR (assumed) array
11995 size. */
11996 break;
11997
11998 case FFEEXPR_contextIMPDOITEMDF_:
11999 if (ffelex_token_type (t) == FFELEX_typeEQUALS)
12000 {
12001 ffeexpr_stack_->is_rhs = FALSE;
12002 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
12003 goto again; /* :::::::::::::::::::: */
12004 }
12005 /* Fall through. */
12006 case FFEEXPR_contextIOLISTDF:
12007 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12008 : ffeinfo_basictype (info))
12009 {
12010 case FFEINFO_basictypeHOLLERITH:
12011 case FFEINFO_basictypeTYPELESS:
12012 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12013 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12014 FFEEXPR_contextLET);
12015 break;
12016
12017 default:
12018 break;
12019 }
12020 error
12021 = (expr == NULL)
12022 || ((ffeinfo_basictype (info) == FFEINFO_basictypeCHARACTER)
12023 && (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT))
12024 || ((ffeinfo_rank (info) != 0)
12025 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12026 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12027 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12028 == FFEBLD_opSTAR))); /* Bad if null expr,
12029 non-default-kindtype
12030 character expr, or if
12031 array that is not a SYMTER
12032 (can't happen yet, I
12033 think) or has a NULL or
12034 STAR (assumed) array
12035 size. */
12036 break;
12037
12038 case FFEEXPR_contextDATAIMPDOITEM_:
12039 error = (expr == NULL)
12040 || (ffebld_op (expr) != FFEBLD_opARRAYREF)
12041 || ((ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR)
12042 && (ffeinfo_where (info) != FFEINFO_whereFLEETING_IADDR));
12043 break;
12044
12045 case FFEEXPR_contextDATAIMPDOINDEX_:
12046 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12047 break;
12048 switch (ffeinfo_basictype (info))
12049 {
12050 case FFEINFO_basictypeLOGICAL:
12051 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12052 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12053 FFEEXPR_contextLET);
12054 /* Fall through. */
12055 case FFEINFO_basictypeREAL:
12056 case FFEINFO_basictypeCOMPLEX:
12057 if (ffe_is_pedantic ())
12058 {
12059 error = TRUE;
12060 break;
12061 }
12062 /* Fall through. */
12063 case FFEINFO_basictypeINTEGER:
12064 case FFEINFO_basictypeHOLLERITH:
12065 case FFEINFO_basictypeTYPELESS:
12066 error = FALSE;
12067 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12068 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12069 FFEEXPR_contextLET);
12070 break;
12071
12072 default:
12073 error = TRUE;
12074 break;
12075 }
12076 if ((ffeinfo_where (info) != FFEINFO_whereCONSTANT)
12077 && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12078 error = TRUE;
12079 break;
12080
12081 case FFEEXPR_contextDATA:
12082 if (expr == NULL)
12083 error = TRUE;
12084 else if (ffeexpr_stack_->is_rhs)
12085 error = (ffebld_op (expr) != FFEBLD_opCONTER);
12086 else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12087 error = FALSE;
12088 else
12089 error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12090 break;
12091
12092 case FFEEXPR_contextINITVAL:
12093 error = (expr == NULL) || (ffebld_op (expr) != FFEBLD_opCONTER);
12094 break;
12095
12096 case FFEEXPR_contextEQUIVALENCE:
12097 if (expr == NULL)
12098 error = TRUE;
12099 else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12100 error = FALSE;
12101 else
12102 error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12103 break;
12104
12105 case FFEEXPR_contextFILEASSOC:
12106 case FFEEXPR_contextFILEINT:
12107 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12108 : ffeinfo_basictype (info))
12109 {
12110 case FFEINFO_basictypeINTEGER:
12111 /* Maybe this should be supported someday, but, right now,
12112 g77 can't generate a call to libf2c to write to an
12113 integer other than the default size. */
12114 error = ((! ffeexpr_stack_->is_rhs)
12115 && ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12116 break;
12117
12118 default:
12119 error = TRUE;
12120 break;
12121 }
12122 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12123 error = TRUE;
12124 break;
12125
12126 case FFEEXPR_contextFILEDFINT:
12127 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12128 : ffeinfo_basictype (info))
12129 {
12130 case FFEINFO_basictypeINTEGER:
12131 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12132 break;
12133
12134 default:
12135 error = TRUE;
12136 break;
12137 }
12138 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12139 error = TRUE;
12140 break;
12141
12142 case FFEEXPR_contextFILELOG:
12143 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12144 : ffeinfo_basictype (info))
12145 {
12146 case FFEINFO_basictypeLOGICAL:
12147 error = FALSE;
12148 break;
12149
12150 default:
12151 error = TRUE;
12152 break;
12153 }
12154 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12155 error = TRUE;
12156 break;
12157
12158 case FFEEXPR_contextFILECHAR:
12159 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12160 : ffeinfo_basictype (info))
12161 {
12162 case FFEINFO_basictypeCHARACTER:
12163 error = FALSE;
12164 break;
12165
12166 default:
12167 error = TRUE;
12168 break;
12169 }
12170 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12171 error = TRUE;
12172 break;
12173
12174 case FFEEXPR_contextFILENUMCHAR:
12175 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12176 break;
12177 switch (ffeinfo_basictype (info))
12178 {
12179 case FFEINFO_basictypeLOGICAL:
12180 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12181 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12182 FFEEXPR_contextLET);
12183 /* Fall through. */
12184 case FFEINFO_basictypeREAL:
12185 case FFEINFO_basictypeCOMPLEX:
12186 if (ffe_is_pedantic ())
12187 {
12188 error = TRUE;
12189 break;
12190 }
12191 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12192 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12193 FFEEXPR_contextLET);
12194 break;
12195
12196 case FFEINFO_basictypeINTEGER:
12197 case FFEINFO_basictypeCHARACTER:
12198 error = FALSE;
12199 break;
12200
12201 default:
12202 error = TRUE;
12203 break;
12204 }
12205 break;
12206
12207 case FFEEXPR_contextFILEDFCHAR:
12208 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12209 break;
12210 switch (ffeinfo_basictype (info))
12211 {
12212 case FFEINFO_basictypeCHARACTER:
12213 error
12214 = (ffeinfo_kindtype (info)
12215 != FFEINFO_kindtypeCHARACTERDEFAULT);
12216 break;
12217
12218 default:
12219 error = TRUE;
12220 break;
12221 }
12222 if (!ffeexpr_stack_->is_rhs
12223 && (ffebld_op (expr) == FFEBLD_opSUBSTR))
12224 error = TRUE;
12225 break;
12226
12227 case FFEEXPR_contextFILEUNIT: /* See equiv code in _ambig_. */
12228 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12229 : ffeinfo_basictype (info))
12230 {
12231 case FFEINFO_basictypeLOGICAL:
12232 if ((error = (ffeinfo_rank (info) != 0)))
12233 break;
12234 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12235 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12236 FFEEXPR_contextLET);
12237 /* Fall through. */
12238 case FFEINFO_basictypeREAL:
12239 case FFEINFO_basictypeCOMPLEX:
12240 if ((error = (ffeinfo_rank (info) != 0)))
12241 break;
12242 if (ffe_is_pedantic ())
12243 {
12244 error = TRUE;
12245 break;
12246 }
12247 /* Fall through. */
12248 case FFEINFO_basictypeINTEGER:
12249 case FFEINFO_basictypeHOLLERITH:
12250 case FFEINFO_basictypeTYPELESS:
12251 if ((error = (ffeinfo_rank (info) != 0)))
12252 break;
12253 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12254 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12255 FFEEXPR_contextLET);
12256 break;
12257
12258 case FFEINFO_basictypeCHARACTER:
12259 switch (ffebld_op (expr))
12260 { /* As if _lhs had been called instead of
12261 _rhs. */
12262 case FFEBLD_opSYMTER:
12263 error
12264 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
12265 break;
12266
12267 case FFEBLD_opSUBSTR:
12268 error = (ffeinfo_where (ffebld_info (expr))
12269 == FFEINFO_whereCONSTANT_SUBOBJECT);
12270 break;
12271
12272 case FFEBLD_opARRAYREF:
12273 error = FALSE;
12274 break;
12275
12276 default:
12277 error = TRUE;
12278 break;
12279 }
12280 if (!error
12281 && ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
12282 || ((ffeinfo_rank (info) != 0)
12283 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12284 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12285 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12286 == FFEBLD_opSTAR))))) /* Bad if
12287 non-default-kindtype
12288 character expr, or if
12289 array that is not a SYMTER
12290 (can't happen yet, I
12291 think), or has a NULL or
12292 STAR (assumed) array
12293 size. */
12294 error = TRUE;
12295 break;
12296
12297 default:
12298 error = TRUE;
12299 break;
12300 }
12301 break;
12302
12303 case FFEEXPR_contextFILEFORMAT:
12304 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12305 : ffeinfo_basictype (info))
12306 {
12307 case FFEINFO_basictypeINTEGER:
12308 error = (expr == NULL)
12309 || ((ffeinfo_rank (info) != 0) ?
12310 ffe_is_pedantic () /* F77 C5. */
12311 : (bool) (ffeinfo_kindtype (info) != ffecom_label_kind ()))
12312 || (ffebld_op (expr) != FFEBLD_opSYMTER);
12313 break;
12314
12315 case FFEINFO_basictypeLOGICAL:
12316 case FFEINFO_basictypeREAL:
12317 case FFEINFO_basictypeCOMPLEX:
12318 /* F77 C5 -- must be an array of hollerith. */
12319 error
12320 = ffe_is_pedantic ()
12321 || (ffeinfo_rank (info) == 0);
12322 break;
12323
12324 case FFEINFO_basictypeCHARACTER:
12325 if ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
12326 || ((ffeinfo_rank (info) != 0)
12327 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12328 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12329 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12330 == FFEBLD_opSTAR)))) /* Bad if
12331 non-default-kindtype
12332 character expr, or if
12333 array that is not a SYMTER
12334 (can't happen yet, I
12335 think), or has a NULL or
12336 STAR (assumed) array
12337 size. */
12338 error = TRUE;
12339 else
12340 error = FALSE;
12341 break;
12342
12343 default:
12344 error = TRUE;
12345 break;
12346 }
12347 break;
12348
12349 case FFEEXPR_contextLOC_:
12350 /* See also ffeintrin_check_loc_. */
12351 if ((expr == NULL)
12352 || (ffeinfo_kind (info) != FFEINFO_kindENTITY)
12353 || ((ffebld_op (expr) != FFEBLD_opSYMTER)
12354 && (ffebld_op (expr) != FFEBLD_opSUBSTR)
12355 && (ffebld_op (expr) != FFEBLD_opARRAYREF)))
12356 error = TRUE;
12357 break;
12358
12359 default:
12360 error = FALSE;
12361 break;
12362 }
12363
12364 if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
12365 {
12366 ffebad_start (FFEBAD_EXPR_WRONG);
12367 ffebad_here (0, ffelex_token_where_line (ft),
12368 ffelex_token_where_column (ft));
12369 ffebad_finish ();
12370 expr = ffebld_new_any ();
12371 ffebld_set_info (expr, ffeinfo_new_any ());
12372 }
12373
12374 callback = ffeexpr_stack_->callback;
12375 s = ffeexpr_stack_->previous;
12376 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
12377 sizeof (*ffeexpr_stack_));
12378 ffeexpr_stack_ = s;
12379 next = (ffelexHandler) (*callback) (ft, expr, t);
12380 ffelex_token_kill (ft);
12381 return (ffelexHandler) next;
12382 }
12383
12384 /* ffeexpr_finished_ambig_ -- Check validity of ambiguous unit/form spec
12385
12386 ffebld expr;
12387 expr = ffeexpr_finished_ambig_(expr);
12388
12389 Replicates a bit of ffeexpr_finished_'s task when in a context
12390 of UNIT or FORMAT. */
12391
12392 static ffebld
12393 ffeexpr_finished_ambig_ (ffelexToken ft, ffebld expr)
12394 {
12395 ffeinfo info = ffebld_info (expr);
12396 bool error;
12397
12398 switch (ffeexpr_stack_->context)
12399 {
12400 case FFEEXPR_contextFILENUMAMBIG: /* Same as FILENUM in _finished_. */
12401 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12402 : ffeinfo_basictype (info))
12403 {
12404 case FFEINFO_basictypeLOGICAL:
12405 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12406 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12407 FFEEXPR_contextLET);
12408 /* Fall through. */
12409 case FFEINFO_basictypeREAL:
12410 case FFEINFO_basictypeCOMPLEX:
12411 if (ffe_is_pedantic ())
12412 {
12413 error = TRUE;
12414 break;
12415 }
12416 /* Fall through. */
12417 case FFEINFO_basictypeINTEGER:
12418 case FFEINFO_basictypeHOLLERITH:
12419 case FFEINFO_basictypeTYPELESS:
12420 error = FALSE;
12421 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12422 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12423 FFEEXPR_contextLET);
12424 break;
12425
12426 default:
12427 error = TRUE;
12428 break;
12429 }
12430 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12431 error = TRUE;
12432 break;
12433
12434 case FFEEXPR_contextFILEUNITAMBIG: /* Same as FILEUNIT in _finished_. */
12435 if ((expr != NULL) && (ffebld_op (expr) == FFEBLD_opSTAR))
12436 {
12437 error = FALSE;
12438 break;
12439 }
12440 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12441 : ffeinfo_basictype (info))
12442 {
12443 case FFEINFO_basictypeLOGICAL:
12444 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12445 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12446 FFEEXPR_contextLET);
12447 /* Fall through. */
12448 case FFEINFO_basictypeREAL:
12449 case FFEINFO_basictypeCOMPLEX:
12450 if (ffe_is_pedantic ())
12451 {
12452 error = TRUE;
12453 break;
12454 }
12455 /* Fall through. */
12456 case FFEINFO_basictypeINTEGER:
12457 case FFEINFO_basictypeHOLLERITH:
12458 case FFEINFO_basictypeTYPELESS:
12459 error = (ffeinfo_rank (info) != 0);
12460 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12461 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12462 FFEEXPR_contextLET);
12463 break;
12464
12465 case FFEINFO_basictypeCHARACTER:
12466 switch (ffebld_op (expr))
12467 { /* As if _lhs had been called instead of
12468 _rhs. */
12469 case FFEBLD_opSYMTER:
12470 error
12471 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
12472 break;
12473
12474 case FFEBLD_opSUBSTR:
12475 error = (ffeinfo_where (ffebld_info (expr))
12476 == FFEINFO_whereCONSTANT_SUBOBJECT);
12477 break;
12478
12479 case FFEBLD_opARRAYREF:
12480 error = FALSE;
12481 break;
12482
12483 default:
12484 error = TRUE;
12485 break;
12486 }
12487 break;
12488
12489 default:
12490 error = TRUE;
12491 break;
12492 }
12493 break;
12494
12495 default:
12496 assert ("bad context" == NULL);
12497 error = TRUE;
12498 break;
12499 }
12500
12501 if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
12502 {
12503 ffebad_start (FFEBAD_EXPR_WRONG);
12504 ffebad_here (0, ffelex_token_where_line (ft),
12505 ffelex_token_where_column (ft));
12506 ffebad_finish ();
12507 expr = ffebld_new_any ();
12508 ffebld_set_info (expr, ffeinfo_new_any ());
12509 }
12510
12511 return expr;
12512 }
12513
12514 /* ffeexpr_token_lhs_ -- Initial state for lhs expression
12515
12516 Return a pointer to this function to the lexer (ffelex), which will
12517 invoke it for the next token.
12518
12519 Basically a smaller version of _rhs_; keep them both in sync, of course. */
12520
12521 static ffelexHandler
12522 ffeexpr_token_lhs_ (ffelexToken t)
12523 {
12524
12525 /* When changing the list of valid initial lhs tokens, check whether to
12526 update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
12527 READ (expr) <token> case -- it assumes it knows which tokens <token> can
12528 be to indicate an lhs (or implied DO), which right now is the set
12529 {NAME,OPEN_PAREN}.
12530
12531 This comment also appears in ffeexpr_token_first_lhs_. */
12532
12533 switch (ffelex_token_type (t))
12534 {
12535 case FFELEX_typeNAME:
12536 case FFELEX_typeNAMES:
12537 ffeexpr_tokens_[0] = ffelex_token_use (t);
12538 return (ffelexHandler) ffeexpr_token_name_lhs_;
12539
12540 default:
12541 return (ffelexHandler) ffeexpr_finished_ (t);
12542 }
12543 }
12544
12545 /* ffeexpr_token_rhs_ -- Initial state for rhs expression
12546
12547 Return a pointer to this function to the lexer (ffelex), which will
12548 invoke it for the next token.
12549
12550 The initial state and the post-binary-operator state are the same and
12551 both handled here, with the expression stack used to distinguish
12552 between them. Binary operators are invalid here; unary operators,
12553 constants, subexpressions, and name references are valid. */
12554
12555 static ffelexHandler
12556 ffeexpr_token_rhs_ (ffelexToken t)
12557 {
12558 ffeexprExpr_ e;
12559
12560 switch (ffelex_token_type (t))
12561 {
12562 case FFELEX_typeQUOTE:
12563 if (ffe_is_vxt ())
12564 {
12565 ffeexpr_tokens_[0] = ffelex_token_use (t);
12566 return (ffelexHandler) ffeexpr_token_quote_;
12567 }
12568 ffeexpr_tokens_[0] = ffelex_token_use (t);
12569 ffelex_set_expecting_hollerith (-1, '\"',
12570 ffelex_token_where_line (t),
12571 ffelex_token_where_column (t));
12572 /* Don't have to unset this one. */
12573 return (ffelexHandler) ffeexpr_token_apostrophe_;
12574
12575 case FFELEX_typeAPOSTROPHE:
12576 ffeexpr_tokens_[0] = ffelex_token_use (t);
12577 ffelex_set_expecting_hollerith (-1, '\'',
12578 ffelex_token_where_line (t),
12579 ffelex_token_where_column (t));
12580 /* Don't have to unset this one. */
12581 return (ffelexHandler) ffeexpr_token_apostrophe_;
12582
12583 case FFELEX_typePERCENT:
12584 ffeexpr_tokens_[0] = ffelex_token_use (t);
12585 return (ffelexHandler) ffeexpr_token_percent_;
12586
12587 case FFELEX_typeOPEN_PAREN:
12588 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
12589 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
12590 FFEEXPR_contextPAREN_,
12591 ffeexpr_cb_close_paren_c_);
12592
12593 case FFELEX_typePLUS:
12594 e = ffeexpr_expr_new_ ();
12595 e->type = FFEEXPR_exprtypeUNARY_;
12596 e->token = ffelex_token_use (t);
12597 e->u.operator.op = FFEEXPR_operatorADD_;
12598 e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
12599 e->u.operator.as = FFEEXPR_operatorassociativityADD_;
12600 ffeexpr_exprstack_push_unary_ (e);
12601 return (ffelexHandler) ffeexpr_token_rhs_;
12602
12603 case FFELEX_typeMINUS:
12604 e = ffeexpr_expr_new_ ();
12605 e->type = FFEEXPR_exprtypeUNARY_;
12606 e->token = ffelex_token_use (t);
12607 e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
12608 e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
12609 e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
12610 ffeexpr_exprstack_push_unary_ (e);
12611 return (ffelexHandler) ffeexpr_token_rhs_;
12612
12613 case FFELEX_typePERIOD:
12614 ffeexpr_tokens_[0] = ffelex_token_use (t);
12615 return (ffelexHandler) ffeexpr_token_period_;
12616
12617 case FFELEX_typeNUMBER:
12618 ffeexpr_tokens_[0] = ffelex_token_use (t);
12619 ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
12620 if (ffeexpr_hollerith_count_ > 0)
12621 ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
12622 '\0',
12623 ffelex_token_where_line (t),
12624 ffelex_token_where_column (t));
12625 return (ffelexHandler) ffeexpr_token_number_;
12626
12627 case FFELEX_typeNAME:
12628 case FFELEX_typeNAMES:
12629 ffeexpr_tokens_[0] = ffelex_token_use (t);
12630 switch (ffeexpr_stack_->context)
12631 {
12632 case FFEEXPR_contextACTUALARG_:
12633 case FFEEXPR_contextINDEXORACTUALARG_:
12634 case FFEEXPR_contextSFUNCDEFACTUALARG_:
12635 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
12636 return (ffelexHandler) ffeexpr_token_name_arg_;
12637
12638 default:
12639 return (ffelexHandler) ffeexpr_token_name_rhs_;
12640 }
12641
12642 case FFELEX_typeASTERISK:
12643 case FFELEX_typeSLASH:
12644 case FFELEX_typePOWER:
12645 case FFELEX_typeCONCAT:
12646 case FFELEX_typeREL_EQ:
12647 case FFELEX_typeREL_NE:
12648 case FFELEX_typeREL_LE:
12649 case FFELEX_typeREL_GE:
12650 if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
12651 {
12652 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
12653 ffebad_finish ();
12654 }
12655 return (ffelexHandler) ffeexpr_token_rhs_;
12656
12657 #if 0
12658 case FFELEX_typeEQUALS:
12659 case FFELEX_typePOINTS:
12660 case FFELEX_typeCLOSE_ANGLE:
12661 case FFELEX_typeCLOSE_PAREN:
12662 case FFELEX_typeCOMMA:
12663 case FFELEX_typeCOLON:
12664 case FFELEX_typeEOS:
12665 case FFELEX_typeSEMICOLON:
12666 #endif
12667 default:
12668 return (ffelexHandler) ffeexpr_finished_ (t);
12669 }
12670 }
12671
12672 /* ffeexpr_token_period_ -- Rhs PERIOD
12673
12674 Return a pointer to this function to the lexer (ffelex), which will
12675 invoke it for the next token.
12676
12677 Handle a period detected at rhs (expecting unary op or operand) state.
12678 Must begin a floating-point value (as in .12) or a dot-dot name, of
12679 which only .NOT., .TRUE., and .FALSE. are truly valid. Other sort-of-
12680 valid names represent binary operators, which are invalid here because
12681 there isn't an operand at the top of the stack. */
12682
12683 static ffelexHandler
12684 ffeexpr_token_period_ (ffelexToken t)
12685 {
12686 switch (ffelex_token_type (t))
12687 {
12688 case FFELEX_typeNAME:
12689 case FFELEX_typeNAMES:
12690 ffeexpr_current_dotdot_ = ffestr_other (t);
12691 switch (ffeexpr_current_dotdot_)
12692 {
12693 case FFESTR_otherNone:
12694 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
12695 {
12696 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
12697 ffelex_token_where_column (ffeexpr_tokens_[0]));
12698 ffebad_finish ();
12699 }
12700 ffelex_token_kill (ffeexpr_tokens_[0]);
12701 return (ffelexHandler) ffeexpr_token_rhs_ (t);
12702
12703 case FFESTR_otherTRUE:
12704 case FFESTR_otherFALSE:
12705 case FFESTR_otherNOT:
12706 ffeexpr_tokens_[1] = ffelex_token_use (t);
12707 return (ffelexHandler) ffeexpr_token_end_period_;
12708
12709 default:
12710 if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
12711 {
12712 ffebad_here (0, ffelex_token_where_line (t),
12713 ffelex_token_where_column (t));
12714 ffebad_finish ();
12715 }
12716 ffelex_token_kill (ffeexpr_tokens_[0]);
12717 return (ffelexHandler) ffeexpr_token_swallow_period_;
12718 }
12719 break; /* Nothing really reaches here. */
12720
12721 case FFELEX_typeNUMBER:
12722 ffeexpr_tokens_[1] = ffelex_token_use (t);
12723 return (ffelexHandler) ffeexpr_token_real_;
12724
12725 default:
12726 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
12727 {
12728 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
12729 ffelex_token_where_column (ffeexpr_tokens_[0]));
12730 ffebad_finish ();
12731 }
12732 ffelex_token_kill (ffeexpr_tokens_[0]);
12733 return (ffelexHandler) ffeexpr_token_rhs_ (t);
12734 }
12735 }
12736
12737 /* ffeexpr_token_end_period_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
12738
12739 Return a pointer to this function to the lexer (ffelex), which will
12740 invoke it for the next token.
12741
12742 Expecting a period to close a .NOT, .TRUE, or .FALSE at rhs (unary op
12743 or operator) state. If period isn't found, issue a diagnostic but
12744 pretend we saw one. ffeexpr_current_dotdot_ must already contained the
12745 dotdot representation of the name in between the two PERIOD tokens. */
12746
12747 static ffelexHandler
12748 ffeexpr_token_end_period_ (ffelexToken t)
12749 {
12750 ffeexprExpr_ e;
12751
12752 if (ffelex_token_type (t) != FFELEX_typePERIOD)
12753 {
12754 if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
12755 {
12756 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
12757 ffelex_token_where_column (ffeexpr_tokens_[0]));
12758 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
12759 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
12760 ffebad_finish ();
12761 }
12762 }
12763
12764 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill "NOT"/"TRUE"/"FALSE"
12765 token. */
12766
12767 e = ffeexpr_expr_new_ ();
12768 e->token = ffeexpr_tokens_[0];
12769
12770 switch (ffeexpr_current_dotdot_)
12771 {
12772 case FFESTR_otherNOT:
12773 e->type = FFEEXPR_exprtypeUNARY_;
12774 e->u.operator.op = FFEEXPR_operatorNOT_;
12775 e->u.operator.prec = FFEEXPR_operatorprecedenceNOT_;
12776 e->u.operator.as = FFEEXPR_operatorassociativityNOT_;
12777 ffeexpr_exprstack_push_unary_ (e);
12778 if (ffelex_token_type (t) != FFELEX_typePERIOD)
12779 return (ffelexHandler) ffeexpr_token_rhs_ (t);
12780 return (ffelexHandler) ffeexpr_token_rhs_;
12781
12782 case FFESTR_otherTRUE:
12783 e->type = FFEEXPR_exprtypeOPERAND_;
12784 e->u.operand
12785 = ffebld_new_conter (ffebld_constant_new_logicaldefault (TRUE));
12786 ffebld_set_info (e->u.operand,
12787 ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
12788 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
12789 ffeexpr_exprstack_push_operand_ (e);
12790 if (ffelex_token_type (t) != FFELEX_typePERIOD)
12791 return (ffelexHandler) ffeexpr_token_binary_ (t);
12792 return (ffelexHandler) ffeexpr_token_binary_;
12793
12794 case FFESTR_otherFALSE:
12795 e->type = FFEEXPR_exprtypeOPERAND_;
12796 e->u.operand
12797 = ffebld_new_conter (ffebld_constant_new_logicaldefault (FALSE));
12798 ffebld_set_info (e->u.operand,
12799 ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
12800 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
12801 ffeexpr_exprstack_push_operand_ (e);
12802 if (ffelex_token_type (t) != FFELEX_typePERIOD)
12803 return (ffelexHandler) ffeexpr_token_binary_ (t);
12804 return (ffelexHandler) ffeexpr_token_binary_;
12805
12806 default:
12807 assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL);
12808 exit (0);
12809 return NULL;
12810 }
12811 }
12812
12813 /* ffeexpr_token_swallow_period_ -- Rhs PERIOD NAME(not NOT, TRUE, or FALSE)
12814
12815 Return a pointer to this function to the lexer (ffelex), which will
12816 invoke it for the next token.
12817
12818 A diagnostic has already been issued; just swallow a period if there is
12819 one, then continue with ffeexpr_token_rhs_. */
12820
12821 static ffelexHandler
12822 ffeexpr_token_swallow_period_ (ffelexToken t)
12823 {
12824 if (ffelex_token_type (t) != FFELEX_typePERIOD)
12825 return (ffelexHandler) ffeexpr_token_rhs_ (t);
12826
12827 return (ffelexHandler) ffeexpr_token_rhs_;
12828 }
12829
12830 /* ffeexpr_token_real_ -- Rhs PERIOD NUMBER
12831
12832 Return a pointer to this function to the lexer (ffelex), which will
12833 invoke it for the next token.
12834
12835 After a period and a string of digits, check next token for possible
12836 exponent designation (D, E, or Q as first/only character) and continue
12837 real-number handling accordingly. Else form basic real constant, push
12838 onto expression stack, and enter binary state using current token (which,
12839 if it is a name not beginning with D, E, or Q, will certainly result
12840 in an error, but that's not for this routine to deal with). */
12841
12842 static ffelexHandler
12843 ffeexpr_token_real_ (ffelexToken t)
12844 {
12845 char d;
12846 const char *p;
12847
12848 if (((ffelex_token_type (t) != FFELEX_typeNAME)
12849 && (ffelex_token_type (t) != FFELEX_typeNAMES))
12850 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
12851 'D', 'd')
12852 || ffesrc_char_match_init (d, 'E', 'e')
12853 || ffesrc_char_match_init (d, 'Q', 'q')))
12854 && ffeexpr_isdigits_ (++p)))
12855 {
12856 #if 0
12857 /* This code has been removed because it seems inconsistent to
12858 produce a diagnostic in this case, but not all of the other
12859 ones that look for an exponent and cannot recognize one. */
12860 if (((ffelex_token_type (t) == FFELEX_typeNAME)
12861 || (ffelex_token_type (t) == FFELEX_typeNAMES))
12862 && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
12863 {
12864 char bad[2];
12865
12866 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
12867 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
12868 ffelex_token_where_column (ffeexpr_tokens_[0]));
12869 bad[0] = *(p - 1);
12870 bad[1] = '\0';
12871 ffebad_string (bad);
12872 ffebad_finish ();
12873 }
12874 #endif
12875 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
12876 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
12877 NULL, NULL, NULL);
12878
12879 ffelex_token_kill (ffeexpr_tokens_[0]);
12880 ffelex_token_kill (ffeexpr_tokens_[1]);
12881 return (ffelexHandler) ffeexpr_token_binary_ (t);
12882 }
12883
12884 /* Just exponent character by itself? In which case, PLUS or MINUS must
12885 surely be next, followed by a NUMBER token. */
12886
12887 if (*p == '\0')
12888 {
12889 ffeexpr_tokens_[2] = ffelex_token_use (t);
12890 return (ffelexHandler) ffeexpr_token_real_exponent_;
12891 }
12892
12893 ffeexpr_make_float_const_ (d, NULL, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
12894 t, NULL, NULL);
12895
12896 ffelex_token_kill (ffeexpr_tokens_[0]);
12897 ffelex_token_kill (ffeexpr_tokens_[1]);
12898 return (ffelexHandler) ffeexpr_token_binary_;
12899 }
12900
12901 /* ffeexpr_token_real_exponent_ -- Rhs PERIOD NUMBER NAME(D, E, or Q)
12902
12903 Return a pointer to this function to the lexer (ffelex), which will
12904 invoke it for the next token.
12905
12906 Ensures this token is PLUS or MINUS, preserves it, goes to final state
12907 for real number (exponent digits). Else issues diagnostic, assumes a
12908 zero exponent field for number, passes token on to binary state as if
12909 previous token had been "E0" instead of "E", for example. */
12910
12911 static ffelexHandler
12912 ffeexpr_token_real_exponent_ (ffelexToken t)
12913 {
12914 if ((ffelex_token_type (t) != FFELEX_typePLUS)
12915 && (ffelex_token_type (t) != FFELEX_typeMINUS))
12916 {
12917 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
12918 {
12919 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
12920 ffelex_token_where_column (ffeexpr_tokens_[2]));
12921 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
12922 ffebad_finish ();
12923 }
12924
12925 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
12926 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
12927 NULL, NULL, NULL);
12928
12929 ffelex_token_kill (ffeexpr_tokens_[0]);
12930 ffelex_token_kill (ffeexpr_tokens_[1]);
12931 ffelex_token_kill (ffeexpr_tokens_[2]);
12932 return (ffelexHandler) ffeexpr_token_binary_ (t);
12933 }
12934
12935 ffeexpr_tokens_[3] = ffelex_token_use (t);
12936 return (ffelexHandler) ffeexpr_token_real_exp_sign_;
12937 }
12938
12939 /* ffeexpr_token_real_exp_sign_ -- Rhs PERIOD NUMBER NAME(D,E,Q) PLUS/MINUS
12940
12941 Return a pointer to this function to the lexer (ffelex), which will
12942 invoke it for the next token.
12943
12944 Make sure token is a NUMBER, make a real constant out of all we have and
12945 push it onto the expression stack. Else issue diagnostic and pretend
12946 exponent field was a zero. */
12947
12948 static ffelexHandler
12949 ffeexpr_token_real_exp_sign_ (ffelexToken t)
12950 {
12951 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
12952 {
12953 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
12954 {
12955 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
12956 ffelex_token_where_column (ffeexpr_tokens_[2]));
12957 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
12958 ffebad_finish ();
12959 }
12960
12961 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
12962 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
12963 NULL, NULL, NULL);
12964
12965 ffelex_token_kill (ffeexpr_tokens_[0]);
12966 ffelex_token_kill (ffeexpr_tokens_[1]);
12967 ffelex_token_kill (ffeexpr_tokens_[2]);
12968 ffelex_token_kill (ffeexpr_tokens_[3]);
12969 return (ffelexHandler) ffeexpr_token_binary_ (t);
12970 }
12971
12972 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0], NULL,
12973 ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2],
12974 ffeexpr_tokens_[3], t);
12975
12976 ffelex_token_kill (ffeexpr_tokens_[0]);
12977 ffelex_token_kill (ffeexpr_tokens_[1]);
12978 ffelex_token_kill (ffeexpr_tokens_[2]);
12979 ffelex_token_kill (ffeexpr_tokens_[3]);
12980 return (ffelexHandler) ffeexpr_token_binary_;
12981 }
12982
12983 /* ffeexpr_token_number_ -- Rhs NUMBER
12984
12985 Return a pointer to this function to the lexer (ffelex), which will
12986 invoke it for the next token.
12987
12988 If the token is a period, we may have a floating-point number, or an
12989 integer followed by a dotdot binary operator. If the token is a name
12990 beginning with D, E, or Q, we definitely have a floating-point number.
12991 If the token is a hollerith constant, that's what we've got, so push
12992 it onto the expression stack and continue with the binary state.
12993
12994 Otherwise, we have an integer followed by something the binary state
12995 should be able to swallow. */
12996
12997 static ffelexHandler
12998 ffeexpr_token_number_ (ffelexToken t)
12999 {
13000 ffeexprExpr_ e;
13001 ffeinfo ni;
13002 char d;
13003 const char *p;
13004
13005 if (ffeexpr_hollerith_count_ > 0)
13006 ffelex_set_expecting_hollerith (0, '\0',
13007 ffewhere_line_unknown (),
13008 ffewhere_column_unknown ());
13009
13010 /* See if we've got a floating-point number here. */
13011
13012 switch (ffelex_token_type (t))
13013 {
13014 case FFELEX_typeNAME:
13015 case FFELEX_typeNAMES:
13016 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13017 'D', 'd')
13018 || ffesrc_char_match_init (d, 'E', 'e')
13019 || ffesrc_char_match_init (d, 'Q', 'q'))
13020 && ffeexpr_isdigits_ (++p))
13021 {
13022
13023 /* Just exponent character by itself? In which case, PLUS or MINUS
13024 must surely be next, followed by a NUMBER token. */
13025
13026 if (*p == '\0')
13027 {
13028 ffeexpr_tokens_[1] = ffelex_token_use (t);
13029 return (ffelexHandler) ffeexpr_token_number_exponent_;
13030 }
13031 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], NULL, NULL, t,
13032 NULL, NULL);
13033
13034 ffelex_token_kill (ffeexpr_tokens_[0]);
13035 return (ffelexHandler) ffeexpr_token_binary_;
13036 }
13037 break;
13038
13039 case FFELEX_typePERIOD:
13040 ffeexpr_tokens_[1] = ffelex_token_use (t);
13041 return (ffelexHandler) ffeexpr_token_number_period_;
13042
13043 case FFELEX_typeHOLLERITH:
13044 e = ffeexpr_expr_new_ ();
13045 e->type = FFEEXPR_exprtypeOPERAND_;
13046 e->token = ffeexpr_tokens_[0];
13047 e->u.operand = ffebld_new_conter (ffebld_constant_new_hollerith (t));
13048 ni = ffeinfo_new (FFEINFO_basictypeHOLLERITH, FFEINFO_kindtypeNONE,
13049 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
13050 ffelex_token_length (t));
13051 ffebld_set_info (e->u.operand, ni);
13052 ffeexpr_exprstack_push_operand_ (e);
13053 return (ffelexHandler) ffeexpr_token_binary_;
13054
13055 default:
13056 break;
13057 }
13058
13059 /* Nothing specific we were looking for, so make an integer and pass the
13060 current token to the binary state. */
13061
13062 ffeexpr_make_float_const_ ('I', ffeexpr_tokens_[0], NULL, NULL,
13063 NULL, NULL, NULL);
13064 return (ffelexHandler) ffeexpr_token_binary_ (t);
13065 }
13066
13067 /* ffeexpr_token_number_exponent_ -- Rhs NUMBER NAME(D, E, or Q)
13068
13069 Return a pointer to this function to the lexer (ffelex), which will
13070 invoke it for the next token.
13071
13072 Ensures this token is PLUS or MINUS, preserves it, goes to final state
13073 for real number (exponent digits). Else treats number as integer, passes
13074 name to binary, passes current token to subsequent handler. */
13075
13076 static ffelexHandler
13077 ffeexpr_token_number_exponent_ (ffelexToken t)
13078 {
13079 if ((ffelex_token_type (t) != FFELEX_typePLUS)
13080 && (ffelex_token_type (t) != FFELEX_typeMINUS))
13081 {
13082 ffeexprExpr_ e;
13083 ffelexHandler nexthandler;
13084
13085 e = ffeexpr_expr_new_ ();
13086 e->type = FFEEXPR_exprtypeOPERAND_;
13087 e->token = ffeexpr_tokens_[0];
13088 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
13089 (ffeexpr_tokens_[0]));
13090 ffebld_set_info (e->u.operand,
13091 ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT,
13092 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13093 ffeexpr_exprstack_push_operand_ (e);
13094 nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[1]);
13095 ffelex_token_kill (ffeexpr_tokens_[1]);
13096 return (ffelexHandler) (*nexthandler) (t);
13097 }
13098
13099 ffeexpr_tokens_[2] = ffelex_token_use (t);
13100 return (ffelexHandler) ffeexpr_token_number_exp_sign_;
13101 }
13102
13103 /* ffeexpr_token_number_exp_sign_ -- Rhs NUMBER NAME(D,E,Q) PLUS/MINUS
13104
13105 Return a pointer to this function to the lexer (ffelex), which will
13106 invoke it for the next token.
13107
13108 Make sure token is a NUMBER, make a real constant out of all we have and
13109 push it onto the expression stack. Else issue diagnostic and pretend
13110 exponent field was a zero. */
13111
13112 static ffelexHandler
13113 ffeexpr_token_number_exp_sign_ (ffelexToken t)
13114 {
13115 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13116 {
13117 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13118 {
13119 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[1]),
13120 ffelex_token_where_column (ffeexpr_tokens_[1]));
13121 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13122 ffebad_finish ();
13123 }
13124
13125 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
13126 ffeexpr_tokens_[0], NULL, NULL,
13127 ffeexpr_tokens_[1], ffeexpr_tokens_[2],
13128 NULL);
13129
13130 ffelex_token_kill (ffeexpr_tokens_[0]);
13131 ffelex_token_kill (ffeexpr_tokens_[1]);
13132 ffelex_token_kill (ffeexpr_tokens_[2]);
13133 return (ffelexHandler) ffeexpr_token_binary_ (t);
13134 }
13135
13136 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
13137 ffeexpr_tokens_[0], NULL, NULL,
13138 ffeexpr_tokens_[1], ffeexpr_tokens_[2], t);
13139
13140 ffelex_token_kill (ffeexpr_tokens_[0]);
13141 ffelex_token_kill (ffeexpr_tokens_[1]);
13142 ffelex_token_kill (ffeexpr_tokens_[2]);
13143 return (ffelexHandler) ffeexpr_token_binary_;
13144 }
13145
13146 /* ffeexpr_token_number_period_ -- Rhs NUMBER PERIOD
13147
13148 Return a pointer to this function to the lexer (ffelex), which will
13149 invoke it for the next token.
13150
13151 Handle a period detected following a number at rhs state. Must begin a
13152 floating-point value (as in 1., 1.2, 1.E3, or 1.E+3) or a dot-dot name. */
13153
13154 static ffelexHandler
13155 ffeexpr_token_number_period_ (ffelexToken t)
13156 {
13157 ffeexprExpr_ e;
13158 ffelexHandler nexthandler;
13159 const char *p;
13160 char d;
13161
13162 switch (ffelex_token_type (t))
13163 {
13164 case FFELEX_typeNAME:
13165 case FFELEX_typeNAMES:
13166 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13167 'D', 'd')
13168 || ffesrc_char_match_init (d, 'E', 'e')
13169 || ffesrc_char_match_init (d, 'Q', 'q'))
13170 && ffeexpr_isdigits_ (++p))
13171 {
13172
13173 /* Just exponent character by itself? In which case, PLUS or MINUS
13174 must surely be next, followed by a NUMBER token. */
13175
13176 if (*p == '\0')
13177 {
13178 ffeexpr_tokens_[2] = ffelex_token_use (t);
13179 return (ffelexHandler) ffeexpr_token_number_per_exp_;
13180 }
13181 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0],
13182 ffeexpr_tokens_[1], NULL, t, NULL,
13183 NULL);
13184
13185 ffelex_token_kill (ffeexpr_tokens_[0]);
13186 ffelex_token_kill (ffeexpr_tokens_[1]);
13187 return (ffelexHandler) ffeexpr_token_binary_;
13188 }
13189 /* A name not representing an exponent, so assume it will be something
13190 like EQ, make an integer from the number, pass the period to binary
13191 state and the current token to the resulting state. */
13192
13193 e = ffeexpr_expr_new_ ();
13194 e->type = FFEEXPR_exprtypeOPERAND_;
13195 e->token = ffeexpr_tokens_[0];
13196 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
13197 (ffeexpr_tokens_[0]));
13198 ffebld_set_info (e->u.operand,
13199 ffeinfo_new (FFEINFO_basictypeINTEGER,
13200 FFEINFO_kindtypeINTEGERDEFAULT, 0,
13201 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
13202 FFETARGET_charactersizeNONE));
13203 ffeexpr_exprstack_push_operand_ (e);
13204 nexthandler = (ffelexHandler) ffeexpr_token_binary_
13205 (ffeexpr_tokens_[1]);
13206 ffelex_token_kill (ffeexpr_tokens_[1]);
13207 return (ffelexHandler) (*nexthandler) (t);
13208
13209 case FFELEX_typeNUMBER:
13210 ffeexpr_tokens_[2] = ffelex_token_use (t);
13211 return (ffelexHandler) ffeexpr_token_number_real_;
13212
13213 default:
13214 break;
13215 }
13216
13217 /* Nothing specific we were looking for, so make a real number and pass the
13218 period and then the current token to the binary state. */
13219
13220 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13221 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13222 NULL, NULL, NULL, NULL);
13223
13224 ffelex_token_kill (ffeexpr_tokens_[0]);
13225 ffelex_token_kill (ffeexpr_tokens_[1]);
13226 return (ffelexHandler) ffeexpr_token_binary_ (t);
13227 }
13228
13229 /* ffeexpr_token_number_per_exp_ -- Rhs NUMBER PERIOD NAME(D, E, or Q)
13230
13231 Return a pointer to this function to the lexer (ffelex), which will
13232 invoke it for the next token.
13233
13234 Ensures this token is PLUS or MINUS, preserves it, goes to final state
13235 for real number (exponent digits). Else treats number as real, passes
13236 name to binary, passes current token to subsequent handler. */
13237
13238 static ffelexHandler
13239 ffeexpr_token_number_per_exp_ (ffelexToken t)
13240 {
13241 if ((ffelex_token_type (t) != FFELEX_typePLUS)
13242 && (ffelex_token_type (t) != FFELEX_typeMINUS))
13243 {
13244 ffelexHandler nexthandler;
13245
13246 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13247 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13248 NULL, NULL, NULL, NULL);
13249
13250 ffelex_token_kill (ffeexpr_tokens_[0]);
13251 ffelex_token_kill (ffeexpr_tokens_[1]);
13252 nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[2]);
13253 ffelex_token_kill (ffeexpr_tokens_[2]);
13254 return (ffelexHandler) (*nexthandler) (t);
13255 }
13256
13257 ffeexpr_tokens_[3] = ffelex_token_use (t);
13258 return (ffelexHandler) ffeexpr_token_num_per_exp_sign_;
13259 }
13260
13261 /* ffeexpr_token_number_real_ -- Rhs NUMBER PERIOD NUMBER
13262
13263 Return a pointer to this function to the lexer (ffelex), which will
13264 invoke it for the next token.
13265
13266 After a number, period, and number, check next token for possible
13267 exponent designation (D, E, or Q as first/only character) and continue
13268 real-number handling accordingly. Else form basic real constant, push
13269 onto expression stack, and enter binary state using current token (which,
13270 if it is a name not beginning with D, E, or Q, will certainly result
13271 in an error, but that's not for this routine to deal with). */
13272
13273 static ffelexHandler
13274 ffeexpr_token_number_real_ (ffelexToken t)
13275 {
13276 char d;
13277 const char *p;
13278
13279 if (((ffelex_token_type (t) != FFELEX_typeNAME)
13280 && (ffelex_token_type (t) != FFELEX_typeNAMES))
13281 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13282 'D', 'd')
13283 || ffesrc_char_match_init (d, 'E', 'e')
13284 || ffesrc_char_match_init (d, 'Q', 'q')))
13285 && ffeexpr_isdigits_ (++p)))
13286 {
13287 #if 0
13288 /* This code has been removed because it seems inconsistent to
13289 produce a diagnostic in this case, but not all of the other
13290 ones that look for an exponent and cannot recognize one. */
13291 if (((ffelex_token_type (t) == FFELEX_typeNAME)
13292 || (ffelex_token_type (t) == FFELEX_typeNAMES))
13293 && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
13294 {
13295 char bad[2];
13296
13297 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13298 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
13299 ffelex_token_where_column (ffeexpr_tokens_[0]));
13300 bad[0] = *(p - 1);
13301 bad[1] = '\0';
13302 ffebad_string (bad);
13303 ffebad_finish ();
13304 }
13305 #endif
13306 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13307 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13308 ffeexpr_tokens_[2], NULL, NULL, NULL);
13309
13310 ffelex_token_kill (ffeexpr_tokens_[0]);
13311 ffelex_token_kill (ffeexpr_tokens_[1]);
13312 ffelex_token_kill (ffeexpr_tokens_[2]);
13313 return (ffelexHandler) ffeexpr_token_binary_ (t);
13314 }
13315
13316 /* Just exponent character by itself? In which case, PLUS or MINUS must
13317 surely be next, followed by a NUMBER token. */
13318
13319 if (*p == '\0')
13320 {
13321 ffeexpr_tokens_[3] = ffelex_token_use (t);
13322 return (ffelexHandler) ffeexpr_token_number_real_exp_;
13323 }
13324
13325 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13326 ffeexpr_tokens_[2], t, NULL, NULL);
13327
13328 ffelex_token_kill (ffeexpr_tokens_[0]);
13329 ffelex_token_kill (ffeexpr_tokens_[1]);
13330 ffelex_token_kill (ffeexpr_tokens_[2]);
13331 return (ffelexHandler) ffeexpr_token_binary_;
13332 }
13333
13334 /* ffeexpr_token_num_per_exp_sign_ -- Rhs NUMBER PERIOD NAME(D,E,Q) PLUS/MINUS
13335
13336 Return a pointer to this function to the lexer (ffelex), which will
13337 invoke it for the next token.
13338
13339 Make sure token is a NUMBER, make a real constant out of all we have and
13340 push it onto the expression stack. Else issue diagnostic and pretend
13341 exponent field was a zero. */
13342
13343 static ffelexHandler
13344 ffeexpr_token_num_per_exp_sign_ (ffelexToken t)
13345 {
13346 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13347 {
13348 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13349 {
13350 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
13351 ffelex_token_where_column (ffeexpr_tokens_[2]));
13352 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13353 ffebad_finish ();
13354 }
13355
13356 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13357 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13358 NULL, NULL, NULL, NULL);
13359
13360 ffelex_token_kill (ffeexpr_tokens_[0]);
13361 ffelex_token_kill (ffeexpr_tokens_[1]);
13362 ffelex_token_kill (ffeexpr_tokens_[2]);
13363 ffelex_token_kill (ffeexpr_tokens_[3]);
13364 return (ffelexHandler) ffeexpr_token_binary_ (t);
13365 }
13366
13367 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0],
13368 ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL,
13369 ffeexpr_tokens_[2], ffeexpr_tokens_[3], t);
13370
13371 ffelex_token_kill (ffeexpr_tokens_[0]);
13372 ffelex_token_kill (ffeexpr_tokens_[1]);
13373 ffelex_token_kill (ffeexpr_tokens_[2]);
13374 ffelex_token_kill (ffeexpr_tokens_[3]);
13375 return (ffelexHandler) ffeexpr_token_binary_;
13376 }
13377
13378 /* ffeexpr_token_number_real_exp_ -- Rhs NUMBER PERIOD NUMBER NAME(D, E, or Q)
13379
13380 Return a pointer to this function to the lexer (ffelex), which will
13381 invoke it for the next token.
13382
13383 Ensures this token is PLUS or MINUS, preserves it, goes to final state
13384 for real number (exponent digits). Else issues diagnostic, assumes a
13385 zero exponent field for number, passes token on to binary state as if
13386 previous token had been "E0" instead of "E", for example. */
13387
13388 static ffelexHandler
13389 ffeexpr_token_number_real_exp_ (ffelexToken t)
13390 {
13391 if ((ffelex_token_type (t) != FFELEX_typePLUS)
13392 && (ffelex_token_type (t) != FFELEX_typeMINUS))
13393 {
13394 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13395 {
13396 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
13397 ffelex_token_where_column (ffeexpr_tokens_[3]));
13398 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13399 ffebad_finish ();
13400 }
13401
13402 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13403 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13404 ffeexpr_tokens_[2], NULL, NULL, NULL);
13405
13406 ffelex_token_kill (ffeexpr_tokens_[0]);
13407 ffelex_token_kill (ffeexpr_tokens_[1]);
13408 ffelex_token_kill (ffeexpr_tokens_[2]);
13409 ffelex_token_kill (ffeexpr_tokens_[3]);
13410 return (ffelexHandler) ffeexpr_token_binary_ (t);
13411 }
13412
13413 ffeexpr_tokens_[4] = ffelex_token_use (t);
13414 return (ffelexHandler) ffeexpr_token_num_real_exp_sn_;
13415 }
13416
13417 /* ffeexpr_token_num_real_exp_sn_ -- Rhs NUMBER PERIOD NUMBER NAME(D,E,Q)
13418 PLUS/MINUS
13419
13420 Return a pointer to this function to the lexer (ffelex), which will
13421 invoke it for the next token.
13422
13423 Make sure token is a NUMBER, make a real constant out of all we have and
13424 push it onto the expression stack. Else issue diagnostic and pretend
13425 exponent field was a zero. */
13426
13427 static ffelexHandler
13428 ffeexpr_token_num_real_exp_sn_ (ffelexToken t)
13429 {
13430 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13431 {
13432 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13433 {
13434 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
13435 ffelex_token_where_column (ffeexpr_tokens_[3]));
13436 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13437 ffebad_finish ();
13438 }
13439
13440 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13441 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13442 ffeexpr_tokens_[2], NULL, NULL, NULL);
13443
13444 ffelex_token_kill (ffeexpr_tokens_[0]);
13445 ffelex_token_kill (ffeexpr_tokens_[1]);
13446 ffelex_token_kill (ffeexpr_tokens_[2]);
13447 ffelex_token_kill (ffeexpr_tokens_[3]);
13448 ffelex_token_kill (ffeexpr_tokens_[4]);
13449 return (ffelexHandler) ffeexpr_token_binary_ (t);
13450 }
13451
13452 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[3])[0],
13453 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13454 ffeexpr_tokens_[2], ffeexpr_tokens_[3],
13455 ffeexpr_tokens_[4], t);
13456
13457 ffelex_token_kill (ffeexpr_tokens_[0]);
13458 ffelex_token_kill (ffeexpr_tokens_[1]);
13459 ffelex_token_kill (ffeexpr_tokens_[2]);
13460 ffelex_token_kill (ffeexpr_tokens_[3]);
13461 ffelex_token_kill (ffeexpr_tokens_[4]);
13462 return (ffelexHandler) ffeexpr_token_binary_;
13463 }
13464
13465 /* ffeexpr_token_binary_ -- Handle binary operator possibility
13466
13467 Return a pointer to this function to the lexer (ffelex), which will
13468 invoke it for the next token.
13469
13470 The possibility of a binary operator is handled here, meaning the previous
13471 token was an operand. */
13472
13473 static ffelexHandler
13474 ffeexpr_token_binary_ (ffelexToken t)
13475 {
13476 ffeexprExpr_ e;
13477
13478 if (!ffeexpr_stack_->is_rhs)
13479 return (ffelexHandler) ffeexpr_finished_ (t); /* For now. */
13480
13481 switch (ffelex_token_type (t))
13482 {
13483 case FFELEX_typePLUS:
13484 e = ffeexpr_expr_new_ ();
13485 e->type = FFEEXPR_exprtypeBINARY_;
13486 e->token = ffelex_token_use (t);
13487 e->u.operator.op = FFEEXPR_operatorADD_;
13488 e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
13489 e->u.operator.as = FFEEXPR_operatorassociativityADD_;
13490 ffeexpr_exprstack_push_binary_ (e);
13491 return (ffelexHandler) ffeexpr_token_rhs_;
13492
13493 case FFELEX_typeMINUS:
13494 e = ffeexpr_expr_new_ ();
13495 e->type = FFEEXPR_exprtypeBINARY_;
13496 e->token = ffelex_token_use (t);
13497 e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
13498 e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
13499 e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
13500 ffeexpr_exprstack_push_binary_ (e);
13501 return (ffelexHandler) ffeexpr_token_rhs_;
13502
13503 case FFELEX_typeASTERISK:
13504 switch (ffeexpr_stack_->context)
13505 {
13506 case FFEEXPR_contextDATA:
13507 return (ffelexHandler) ffeexpr_finished_ (t);
13508
13509 default:
13510 break;
13511 }
13512 e = ffeexpr_expr_new_ ();
13513 e->type = FFEEXPR_exprtypeBINARY_;
13514 e->token = ffelex_token_use (t);
13515 e->u.operator.op = FFEEXPR_operatorMULTIPLY_;
13516 e->u.operator.prec = FFEEXPR_operatorprecedenceMULTIPLY_;
13517 e->u.operator.as = FFEEXPR_operatorassociativityMULTIPLY_;
13518 ffeexpr_exprstack_push_binary_ (e);
13519 return (ffelexHandler) ffeexpr_token_rhs_;
13520
13521 case FFELEX_typeSLASH:
13522 switch (ffeexpr_stack_->context)
13523 {
13524 case FFEEXPR_contextDATA:
13525 return (ffelexHandler) ffeexpr_finished_ (t);
13526
13527 default:
13528 break;
13529 }
13530 e = ffeexpr_expr_new_ ();
13531 e->type = FFEEXPR_exprtypeBINARY_;
13532 e->token = ffelex_token_use (t);
13533 e->u.operator.op = FFEEXPR_operatorDIVIDE_;
13534 e->u.operator.prec = FFEEXPR_operatorprecedenceDIVIDE_;
13535 e->u.operator.as = FFEEXPR_operatorassociativityDIVIDE_;
13536 ffeexpr_exprstack_push_binary_ (e);
13537 return (ffelexHandler) ffeexpr_token_rhs_;
13538
13539 case FFELEX_typePOWER:
13540 e = ffeexpr_expr_new_ ();
13541 e->type = FFEEXPR_exprtypeBINARY_;
13542 e->token = ffelex_token_use (t);
13543 e->u.operator.op = FFEEXPR_operatorPOWER_;
13544 e->u.operator.prec = FFEEXPR_operatorprecedencePOWER_;
13545 e->u.operator.as = FFEEXPR_operatorassociativityPOWER_;
13546 ffeexpr_exprstack_push_binary_ (e);
13547 return (ffelexHandler) ffeexpr_token_rhs_;
13548
13549 case FFELEX_typeCONCAT:
13550 e = ffeexpr_expr_new_ ();
13551 e->type = FFEEXPR_exprtypeBINARY_;
13552 e->token = ffelex_token_use (t);
13553 e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
13554 e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
13555 e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
13556 ffeexpr_exprstack_push_binary_ (e);
13557 return (ffelexHandler) ffeexpr_token_rhs_;
13558
13559 case FFELEX_typeOPEN_ANGLE:
13560 switch (ffeexpr_stack_->context)
13561 {
13562 case FFEEXPR_contextFORMAT:
13563 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13564 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13565 ffebad_finish ();
13566 break;
13567
13568 default:
13569 break;
13570 }
13571 e = ffeexpr_expr_new_ ();
13572 e->type = FFEEXPR_exprtypeBINARY_;
13573 e->token = ffelex_token_use (t);
13574 e->u.operator.op = FFEEXPR_operatorLT_;
13575 e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
13576 e->u.operator.as = FFEEXPR_operatorassociativityLT_;
13577 ffeexpr_exprstack_push_binary_ (e);
13578 return (ffelexHandler) ffeexpr_token_rhs_;
13579
13580 case FFELEX_typeCLOSE_ANGLE:
13581 switch (ffeexpr_stack_->context)
13582 {
13583 case FFEEXPR_contextFORMAT:
13584 return ffeexpr_finished_ (t);
13585
13586 default:
13587 break;
13588 }
13589 e = ffeexpr_expr_new_ ();
13590 e->type = FFEEXPR_exprtypeBINARY_;
13591 e->token = ffelex_token_use (t);
13592 e->u.operator.op = FFEEXPR_operatorGT_;
13593 e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
13594 e->u.operator.as = FFEEXPR_operatorassociativityGT_;
13595 ffeexpr_exprstack_push_binary_ (e);
13596 return (ffelexHandler) ffeexpr_token_rhs_;
13597
13598 case FFELEX_typeREL_EQ:
13599 switch (ffeexpr_stack_->context)
13600 {
13601 case FFEEXPR_contextFORMAT:
13602 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13603 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13604 ffebad_finish ();
13605 break;
13606
13607 default:
13608 break;
13609 }
13610 e = ffeexpr_expr_new_ ();
13611 e->type = FFEEXPR_exprtypeBINARY_;
13612 e->token = ffelex_token_use (t);
13613 e->u.operator.op = FFEEXPR_operatorEQ_;
13614 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
13615 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
13616 ffeexpr_exprstack_push_binary_ (e);
13617 return (ffelexHandler) ffeexpr_token_rhs_;
13618
13619 case FFELEX_typeREL_NE:
13620 switch (ffeexpr_stack_->context)
13621 {
13622 case FFEEXPR_contextFORMAT:
13623 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13624 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13625 ffebad_finish ();
13626 break;
13627
13628 default:
13629 break;
13630 }
13631 e = ffeexpr_expr_new_ ();
13632 e->type = FFEEXPR_exprtypeBINARY_;
13633 e->token = ffelex_token_use (t);
13634 e->u.operator.op = FFEEXPR_operatorNE_;
13635 e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
13636 e->u.operator.as = FFEEXPR_operatorassociativityNE_;
13637 ffeexpr_exprstack_push_binary_ (e);
13638 return (ffelexHandler) ffeexpr_token_rhs_;
13639
13640 case FFELEX_typeREL_LE:
13641 switch (ffeexpr_stack_->context)
13642 {
13643 case FFEEXPR_contextFORMAT:
13644 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13645 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13646 ffebad_finish ();
13647 break;
13648
13649 default:
13650 break;
13651 }
13652 e = ffeexpr_expr_new_ ();
13653 e->type = FFEEXPR_exprtypeBINARY_;
13654 e->token = ffelex_token_use (t);
13655 e->u.operator.op = FFEEXPR_operatorLE_;
13656 e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
13657 e->u.operator.as = FFEEXPR_operatorassociativityLE_;
13658 ffeexpr_exprstack_push_binary_ (e);
13659 return (ffelexHandler) ffeexpr_token_rhs_;
13660
13661 case FFELEX_typeREL_GE:
13662 switch (ffeexpr_stack_->context)
13663 {
13664 case FFEEXPR_contextFORMAT:
13665 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13666 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13667 ffebad_finish ();
13668 break;
13669
13670 default:
13671 break;
13672 }
13673 e = ffeexpr_expr_new_ ();
13674 e->type = FFEEXPR_exprtypeBINARY_;
13675 e->token = ffelex_token_use (t);
13676 e->u.operator.op = FFEEXPR_operatorGE_;
13677 e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
13678 e->u.operator.as = FFEEXPR_operatorassociativityGE_;
13679 ffeexpr_exprstack_push_binary_ (e);
13680 return (ffelexHandler) ffeexpr_token_rhs_;
13681
13682 case FFELEX_typePERIOD:
13683 ffeexpr_tokens_[0] = ffelex_token_use (t);
13684 return (ffelexHandler) ffeexpr_token_binary_period_;
13685
13686 #if 0
13687 case FFELEX_typeOPEN_PAREN:
13688 case FFELEX_typeCLOSE_PAREN:
13689 case FFELEX_typeEQUALS:
13690 case FFELEX_typePOINTS:
13691 case FFELEX_typeCOMMA:
13692 case FFELEX_typeCOLON:
13693 case FFELEX_typeEOS:
13694 case FFELEX_typeSEMICOLON:
13695 case FFELEX_typeNAME:
13696 case FFELEX_typeNAMES:
13697 #endif
13698 default:
13699 return (ffelexHandler) ffeexpr_finished_ (t);
13700 }
13701 }
13702
13703 /* ffeexpr_token_binary_period_ -- Binary PERIOD
13704
13705 Return a pointer to this function to the lexer (ffelex), which will
13706 invoke it for the next token.
13707
13708 Handle a period detected at binary (expecting binary op or end) state.
13709 Must begin a dot-dot name, of which .NOT., .TRUE., and .FALSE. are not
13710 valid. */
13711
13712 static ffelexHandler
13713 ffeexpr_token_binary_period_ (ffelexToken t)
13714 {
13715 ffeexprExpr_ operand;
13716
13717 switch (ffelex_token_type (t))
13718 {
13719 case FFELEX_typeNAME:
13720 case FFELEX_typeNAMES:
13721 ffeexpr_current_dotdot_ = ffestr_other (t);
13722 switch (ffeexpr_current_dotdot_)
13723 {
13724 case FFESTR_otherTRUE:
13725 case FFESTR_otherFALSE:
13726 case FFESTR_otherNOT:
13727 if (ffest_ffebad_start (FFEBAD_MISSING_BINARY_OPERATOR))
13728 {
13729 operand = ffeexpr_stack_->exprstack;
13730 assert (operand != NULL);
13731 assert (operand->type == FFEEXPR_exprtypeOPERAND_);
13732 ffebad_here (0, ffelex_token_where_line (operand->token), ffelex_token_where_column (operand->token));
13733 ffebad_here (1, ffelex_token_where_line (t),
13734 ffelex_token_where_column (t));
13735 ffebad_finish ();
13736 }
13737 ffelex_token_kill (ffeexpr_tokens_[0]);
13738 return (ffelexHandler) ffeexpr_token_binary_sw_per_;
13739
13740 default:
13741 ffeexpr_tokens_[1] = ffelex_token_use (t);
13742 return (ffelexHandler) ffeexpr_token_binary_end_per_;
13743 }
13744 break; /* Nothing really reaches here. */
13745
13746 default:
13747 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
13748 {
13749 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13750 ffelex_token_where_column (ffeexpr_tokens_[0]));
13751 ffebad_finish ();
13752 }
13753 ffelex_token_kill (ffeexpr_tokens_[0]);
13754 return (ffelexHandler) ffeexpr_token_binary_ (t);
13755 }
13756 }
13757
13758 /* ffeexpr_token_binary_end_per_ -- Binary PERIOD NAME(not NOT, TRUE, or FALSE)
13759
13760 Return a pointer to this function to the lexer (ffelex), which will
13761 invoke it for the next token.
13762
13763 Expecting a period to close a dot-dot at binary (binary op
13764 or operator) state. If period isn't found, issue a diagnostic but
13765 pretend we saw one. ffeexpr_current_dotdot_ must already contained the
13766 dotdot representation of the name in between the two PERIOD tokens. */
13767
13768 static ffelexHandler
13769 ffeexpr_token_binary_end_per_ (ffelexToken t)
13770 {
13771 ffeexprExpr_ e;
13772
13773 e = ffeexpr_expr_new_ ();
13774 e->type = FFEEXPR_exprtypeBINARY_;
13775 e->token = ffeexpr_tokens_[0];
13776
13777 switch (ffeexpr_current_dotdot_)
13778 {
13779 case FFESTR_otherAND:
13780 e->u.operator.op = FFEEXPR_operatorAND_;
13781 e->u.operator.prec = FFEEXPR_operatorprecedenceAND_;
13782 e->u.operator.as = FFEEXPR_operatorassociativityAND_;
13783 break;
13784
13785 case FFESTR_otherOR:
13786 e->u.operator.op = FFEEXPR_operatorOR_;
13787 e->u.operator.prec = FFEEXPR_operatorprecedenceOR_;
13788 e->u.operator.as = FFEEXPR_operatorassociativityOR_;
13789 break;
13790
13791 case FFESTR_otherXOR:
13792 e->u.operator.op = FFEEXPR_operatorXOR_;
13793 e->u.operator.prec = FFEEXPR_operatorprecedenceXOR_;
13794 e->u.operator.as = FFEEXPR_operatorassociativityXOR_;
13795 break;
13796
13797 case FFESTR_otherEQV:
13798 e->u.operator.op = FFEEXPR_operatorEQV_;
13799 e->u.operator.prec = FFEEXPR_operatorprecedenceEQV_;
13800 e->u.operator.as = FFEEXPR_operatorassociativityEQV_;
13801 break;
13802
13803 case FFESTR_otherNEQV:
13804 e->u.operator.op = FFEEXPR_operatorNEQV_;
13805 e->u.operator.prec = FFEEXPR_operatorprecedenceNEQV_;
13806 e->u.operator.as = FFEEXPR_operatorassociativityNEQV_;
13807 break;
13808
13809 case FFESTR_otherLT:
13810 e->u.operator.op = FFEEXPR_operatorLT_;
13811 e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
13812 e->u.operator.as = FFEEXPR_operatorassociativityLT_;
13813 break;
13814
13815 case FFESTR_otherLE:
13816 e->u.operator.op = FFEEXPR_operatorLE_;
13817 e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
13818 e->u.operator.as = FFEEXPR_operatorassociativityLE_;
13819 break;
13820
13821 case FFESTR_otherEQ:
13822 e->u.operator.op = FFEEXPR_operatorEQ_;
13823 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
13824 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
13825 break;
13826
13827 case FFESTR_otherNE:
13828 e->u.operator.op = FFEEXPR_operatorNE_;
13829 e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
13830 e->u.operator.as = FFEEXPR_operatorassociativityNE_;
13831 break;
13832
13833 case FFESTR_otherGT:
13834 e->u.operator.op = FFEEXPR_operatorGT_;
13835 e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
13836 e->u.operator.as = FFEEXPR_operatorassociativityGT_;
13837 break;
13838
13839 case FFESTR_otherGE:
13840 e->u.operator.op = FFEEXPR_operatorGE_;
13841 e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
13842 e->u.operator.as = FFEEXPR_operatorassociativityGE_;
13843 break;
13844
13845 default:
13846 if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT))
13847 {
13848 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13849 ffelex_token_where_column (ffeexpr_tokens_[0]));
13850 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
13851 ffebad_finish ();
13852 }
13853 e->u.operator.op = FFEEXPR_operatorEQ_;
13854 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
13855 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
13856 break;
13857 }
13858
13859 ffeexpr_exprstack_push_binary_ (e);
13860
13861 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13862 {
13863 if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
13864 {
13865 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13866 ffelex_token_where_column (ffeexpr_tokens_[0]));
13867 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13868 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
13869 ffebad_finish ();
13870 }
13871 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */
13872 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13873 }
13874
13875 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */
13876 return (ffelexHandler) ffeexpr_token_rhs_;
13877 }
13878
13879 /* ffeexpr_token_binary_sw_per_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
13880
13881 Return a pointer to this function to the lexer (ffelex), which will
13882 invoke it for the next token.
13883
13884 A diagnostic has already been issued; just swallow a period if there is
13885 one, then continue with ffeexpr_token_binary_. */
13886
13887 static ffelexHandler
13888 ffeexpr_token_binary_sw_per_ (ffelexToken t)
13889 {
13890 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13891 return (ffelexHandler) ffeexpr_token_binary_ (t);
13892
13893 return (ffelexHandler) ffeexpr_token_binary_;
13894 }
13895
13896 /* ffeexpr_token_quote_ -- Rhs QUOTE
13897
13898 Return a pointer to this function to the lexer (ffelex), which will
13899 invoke it for the next token.
13900
13901 Expecting a NUMBER that we'll treat as an octal integer. */
13902
13903 static ffelexHandler
13904 ffeexpr_token_quote_ (ffelexToken t)
13905 {
13906 ffeexprExpr_ e;
13907 ffebld anyexpr;
13908
13909 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13910 {
13911 if (ffest_ffebad_start (FFEBAD_QUOTE_MISSES_DIGITS))
13912 {
13913 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13914 ffelex_token_where_column (ffeexpr_tokens_[0]));
13915 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13916 ffebad_finish ();
13917 }
13918 ffelex_token_kill (ffeexpr_tokens_[0]);
13919 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13920 }
13921
13922 /* This is kind of a kludge to prevent any whining about magical numbers
13923 that start out as these octal integers, so "20000000000 (on a 32-bit
13924 2's-complement machine) by itself won't produce an error. */
13925
13926 anyexpr = ffebld_new_any ();
13927 ffebld_set_info (anyexpr, ffeinfo_new_any ());
13928
13929 e = ffeexpr_expr_new_ ();
13930 e->type = FFEEXPR_exprtypeOPERAND_;
13931 e->token = ffeexpr_tokens_[0];
13932 e->u.operand = ffebld_new_conter_with_orig
13933 (ffebld_constant_new_integeroctal (t), anyexpr);
13934 ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER,
13935 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY,
13936 FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13937 ffeexpr_exprstack_push_operand_ (e);
13938 return (ffelexHandler) ffeexpr_token_binary_;
13939 }
13940
13941 /* ffeexpr_token_apostrophe_ -- Rhs APOSTROPHE
13942
13943 Return a pointer to this function to the lexer (ffelex), which will
13944 invoke it for the next token.
13945
13946 Handle an open-apostrophe, which begins either a character ('char-const'),
13947 typeless octal ('octal-const'O), or typeless hexadecimal ('hex-const'Z or
13948 'hex-const'X) constant. */
13949
13950 static ffelexHandler
13951 ffeexpr_token_apostrophe_ (ffelexToken t)
13952 {
13953 assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
13954 if (ffe_is_pedantic_not_90 () && (ffelex_token_length (t) == 0))
13955 {
13956 ffebad_start (FFEBAD_NULL_CHAR_CONST);
13957 ffebad_here (0, ffelex_token_where_line (t),
13958 ffelex_token_where_column (t));
13959 ffebad_finish ();
13960 }
13961 ffeexpr_tokens_[1] = ffelex_token_use (t);
13962 return (ffelexHandler) ffeexpr_token_apos_char_;
13963 }
13964
13965 /* ffeexpr_token_apos_char_ -- Rhs APOSTROPHE CHARACTER
13966
13967 Return a pointer to this function to the lexer (ffelex), which will
13968 invoke it for the next token.
13969
13970 Close-apostrophe is implicit; if this token is NAME, it is a possible
13971 typeless-constant radix specifier. */
13972
13973 static ffelexHandler
13974 ffeexpr_token_apos_char_ (ffelexToken t)
13975 {
13976 ffeexprExpr_ e;
13977 ffeinfo ni;
13978 char c;
13979 ffetargetCharacterSize size;
13980
13981 if ((ffelex_token_type (t) == FFELEX_typeNAME)
13982 || (ffelex_token_type (t) == FFELEX_typeNAMES))
13983 {
13984 if ((ffelex_token_length (t) == 1)
13985 && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]), 'B',
13986 'b')
13987 || ffesrc_char_match_init (c, 'O', 'o')
13988 || ffesrc_char_match_init (c, 'X', 'x')
13989 || ffesrc_char_match_init (c, 'Z', 'z')))
13990 {
13991 e = ffeexpr_expr_new_ ();
13992 e->type = FFEEXPR_exprtypeOPERAND_;
13993 e->token = ffeexpr_tokens_[0];
13994 switch (c)
13995 {
13996 case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
13997 e->u.operand = ffebld_new_conter
13998 (ffebld_constant_new_typeless_bv (ffeexpr_tokens_[1]));
13999 size = ffetarget_size_typeless_binary (ffeexpr_tokens_[1]);
14000 break;
14001
14002 case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
14003 e->u.operand = ffebld_new_conter
14004 (ffebld_constant_new_typeless_ov (ffeexpr_tokens_[1]));
14005 size = ffetarget_size_typeless_octal (ffeexpr_tokens_[1]);
14006 break;
14007
14008 case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
14009 e->u.operand = ffebld_new_conter
14010 (ffebld_constant_new_typeless_hxv (ffeexpr_tokens_[1]));
14011 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
14012 break;
14013
14014 case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
14015 e->u.operand = ffebld_new_conter
14016 (ffebld_constant_new_typeless_hzv (ffeexpr_tokens_[1]));
14017 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
14018 break;
14019
14020 default:
14021 no_match: /* :::::::::::::::::::: */
14022 assert ("not BOXZ!" == NULL);
14023 size = 0;
14024 break;
14025 }
14026 ffebld_set_info (e->u.operand,
14027 ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
14028 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
14029 ffeexpr_exprstack_push_operand_ (e);
14030 ffelex_token_kill (ffeexpr_tokens_[1]);
14031 return (ffelexHandler) ffeexpr_token_binary_;
14032 }
14033 }
14034 e = ffeexpr_expr_new_ ();
14035 e->type = FFEEXPR_exprtypeOPERAND_;
14036 e->token = ffeexpr_tokens_[0];
14037 e->u.operand = ffebld_new_conter (ffebld_constant_new_characterdefault
14038 (ffeexpr_tokens_[1]));
14039 ni = ffeinfo_new (FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTERDEFAULT,
14040 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14041 ffelex_token_length (ffeexpr_tokens_[1]));
14042 ffebld_set_info (e->u.operand, ni);
14043 ffelex_token_kill (ffeexpr_tokens_[1]);
14044 ffeexpr_exprstack_push_operand_ (e);
14045 if ((ffelex_token_type (t) == FFELEX_typeNAME)
14046 || (ffelex_token_type (t) == FFELEX_typeNAMES))
14047 {
14048 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14049 {
14050 ffebad_string (ffelex_token_text (t));
14051 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14052 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
14053 ffelex_token_where_column (ffeexpr_tokens_[0]));
14054 ffebad_finish ();
14055 }
14056 e = ffeexpr_expr_new_ ();
14057 e->type = FFEEXPR_exprtypeBINARY_;
14058 e->token = ffelex_token_use (t);
14059 e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
14060 e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
14061 e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
14062 ffeexpr_exprstack_push_binary_ (e);
14063 return (ffelexHandler) ffeexpr_token_rhs_ (t);
14064 }
14065 ffeexpr_is_substr_ok_ = !ffe_is_pedantic_not_90 (); /* Allow "'hello'(3:5)". */
14066 return (ffelexHandler) ffeexpr_token_substrp_ (t);
14067 }
14068
14069 /* ffeexpr_token_name_lhs_ -- Lhs NAME
14070
14071 Return a pointer to this function to the lexer (ffelex), which will
14072 invoke it for the next token.
14073
14074 Handle a name followed by open-paren, period (RECORD.MEMBER), percent
14075 (RECORD%MEMBER), or nothing at all. */
14076
14077 static ffelexHandler
14078 ffeexpr_token_name_lhs_ (ffelexToken t)
14079 {
14080 ffeexprExpr_ e;
14081 ffeexprParenType_ paren_type;
14082 ffesymbol s;
14083 ffebld expr;
14084 ffeinfo info;
14085
14086 switch (ffelex_token_type (t))
14087 {
14088 case FFELEX_typeOPEN_PAREN:
14089 switch (ffeexpr_stack_->context)
14090 {
14091 case FFEEXPR_contextASSIGN:
14092 case FFEEXPR_contextAGOTO:
14093 case FFEEXPR_contextFILEUNIT_DF:
14094 goto just_name; /* :::::::::::::::::::: */
14095
14096 default:
14097 break;
14098 }
14099 e = ffeexpr_expr_new_ ();
14100 e->type = FFEEXPR_exprtypeOPERAND_;
14101 e->token = ffelex_token_use (ffeexpr_tokens_[0]);
14102 s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], FALSE,
14103 &paren_type);
14104
14105 switch (ffesymbol_where (s))
14106 {
14107 case FFEINFO_whereLOCAL:
14108 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14109 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recursion. */
14110 break;
14111
14112 case FFEINFO_whereINTRINSIC:
14113 case FFEINFO_whereGLOBAL:
14114 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
14115 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */
14116 break;
14117
14118 case FFEINFO_whereCOMMON:
14119 case FFEINFO_whereDUMMY:
14120 case FFEINFO_whereRESULT:
14121 break;
14122
14123 case FFEINFO_whereNONE:
14124 case FFEINFO_whereANY:
14125 break;
14126
14127 default:
14128 ffesymbol_error (s, ffeexpr_tokens_[0]);
14129 break;
14130 }
14131
14132 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14133 {
14134 e->u.operand = ffebld_new_any ();
14135 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14136 }
14137 else
14138 {
14139 e->u.operand = ffebld_new_symter (s,
14140 ffesymbol_generic (s),
14141 ffesymbol_specific (s),
14142 ffesymbol_implementation (s));
14143 ffebld_set_info (e->u.operand, ffesymbol_info (s));
14144 }
14145 ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */
14146 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
14147 switch (paren_type)
14148 {
14149 case FFEEXPR_parentypeSUBROUTINE_:
14150 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14151 return
14152 (ffelexHandler)
14153 ffeexpr_rhs (ffeexpr_stack_->pool,
14154 FFEEXPR_contextACTUALARG_,
14155 ffeexpr_token_arguments_);
14156
14157 case FFEEXPR_parentypeARRAY_:
14158 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14159 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
14160 ffeexpr_stack_->rank = 0;
14161 ffeexpr_stack_->constant = TRUE;
14162 ffeexpr_stack_->immediate = TRUE;
14163 switch (ffeexpr_stack_->context)
14164 {
14165 case FFEEXPR_contextDATAIMPDOITEM_:
14166 return
14167 (ffelexHandler)
14168 ffeexpr_rhs (ffeexpr_stack_->pool,
14169 FFEEXPR_contextDATAIMPDOINDEX_,
14170 ffeexpr_token_elements_);
14171
14172 case FFEEXPR_contextEQUIVALENCE:
14173 return
14174 (ffelexHandler)
14175 ffeexpr_rhs (ffeexpr_stack_->pool,
14176 FFEEXPR_contextEQVINDEX_,
14177 ffeexpr_token_elements_);
14178
14179 default:
14180 return
14181 (ffelexHandler)
14182 ffeexpr_rhs (ffeexpr_stack_->pool,
14183 FFEEXPR_contextINDEX_,
14184 ffeexpr_token_elements_);
14185 }
14186
14187 case FFEEXPR_parentypeSUBSTRING_:
14188 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
14189 ffeexpr_tokens_[0]);
14190 return
14191 (ffelexHandler)
14192 ffeexpr_rhs (ffeexpr_stack_->pool,
14193 FFEEXPR_contextINDEX_,
14194 ffeexpr_token_substring_);
14195
14196 case FFEEXPR_parentypeEQUIVALENCE_:
14197 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14198 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
14199 ffeexpr_stack_->rank = 0;
14200 ffeexpr_stack_->constant = TRUE;
14201 ffeexpr_stack_->immediate = TRUE;
14202 return
14203 (ffelexHandler)
14204 ffeexpr_rhs (ffeexpr_stack_->pool,
14205 FFEEXPR_contextEQVINDEX_,
14206 ffeexpr_token_equivalence_);
14207
14208 case FFEEXPR_parentypeFUNCTION_: /* Invalid case. */
14209 case FFEEXPR_parentypeFUNSUBSTR_: /* Invalid case. */
14210 ffesymbol_error (s, ffeexpr_tokens_[0]);
14211 /* Fall through. */
14212 case FFEEXPR_parentypeANY_:
14213 e->u.operand = ffebld_new_any ();
14214 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14215 return
14216 (ffelexHandler)
14217 ffeexpr_rhs (ffeexpr_stack_->pool,
14218 FFEEXPR_contextACTUALARG_,
14219 ffeexpr_token_anything_);
14220
14221 default:
14222 assert ("bad paren type" == NULL);
14223 break;
14224 }
14225
14226 case FFELEX_typeEQUALS: /* As in "VAR=". */
14227 switch (ffeexpr_stack_->context)
14228 {
14229 case FFEEXPR_contextIMPDOITEM_: /* within
14230 "(,VAR=start,end[,incr])". */
14231 case FFEEXPR_contextIMPDOITEMDF_:
14232 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
14233 break;
14234
14235 case FFEEXPR_contextDATAIMPDOITEM_:
14236 ffeexpr_stack_->context = FFEEXPR_contextDATAIMPDOCTRL_;
14237 break;
14238
14239 default:
14240 break;
14241 }
14242 break;
14243
14244 #if 0
14245 case FFELEX_typePERIOD:
14246 case FFELEX_typePERCENT:
14247 assert ("FOO%, FOO. not yet supported!~~" == NULL);
14248 break;
14249 #endif
14250
14251 default:
14252 break;
14253 }
14254
14255 just_name: /* :::::::::::::::::::: */
14256 e = ffeexpr_expr_new_ ();
14257 e->type = FFEEXPR_exprtypeOPERAND_;
14258 e->token = ffeexpr_tokens_[0];
14259 s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0],
14260 (ffeexpr_stack_->context
14261 == FFEEXPR_contextSUBROUTINEREF));
14262
14263 switch (ffesymbol_where (s))
14264 {
14265 case FFEINFO_whereCONSTANT:
14266 if ((ffeexpr_stack_->context != FFEEXPR_contextPARAMETER)
14267 || (ffesymbol_kind (s) != FFEINFO_kindENTITY))
14268 ffesymbol_error (s, ffeexpr_tokens_[0]);
14269 break;
14270
14271 case FFEINFO_whereIMMEDIATE:
14272 if ((ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOCTRL_)
14273 && (ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOINDEX_))
14274 ffesymbol_error (s, ffeexpr_tokens_[0]);
14275 break;
14276
14277 case FFEINFO_whereLOCAL:
14278 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14279 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recurse!. */
14280 break;
14281
14282 case FFEINFO_whereINTRINSIC:
14283 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
14284 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */
14285 break;
14286
14287 default:
14288 break;
14289 }
14290
14291 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14292 {
14293 expr = ffebld_new_any ();
14294 info = ffeinfo_new_any ();
14295 ffebld_set_info (expr, info);
14296 }
14297 else
14298 {
14299 expr = ffebld_new_symter (s,
14300 ffesymbol_generic (s),
14301 ffesymbol_specific (s),
14302 ffesymbol_implementation (s));
14303 info = ffesymbol_info (s);
14304 ffebld_set_info (expr, info);
14305 if (ffesymbol_is_doiter (s))
14306 {
14307 ffebad_start (FFEBAD_DOITER);
14308 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14309 ffelex_token_where_column (ffeexpr_tokens_[0]));
14310 ffest_ffebad_here_doiter (1, s);
14311 ffebad_string (ffesymbol_text (s));
14312 ffebad_finish ();
14313 }
14314 expr = ffeexpr_collapse_symter (expr, ffeexpr_tokens_[0]);
14315 }
14316
14317 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14318 {
14319 if (ffebld_op (expr) == FFEBLD_opANY)
14320 {
14321 expr = ffebld_new_any ();
14322 ffebld_set_info (expr, ffeinfo_new_any ());
14323 }
14324 else
14325 {
14326 expr = ffebld_new_subrref (expr, NULL); /* No argument list. */
14327 if (ffesymbol_generic (s) != FFEINTRIN_genNONE)
14328 ffeintrin_fulfill_generic (&expr, &info, e->token);
14329 else if (ffesymbol_specific (s) != FFEINTRIN_specNONE)
14330 ffeintrin_fulfill_specific (&expr, &info, NULL, e->token);
14331 else
14332 ffeexpr_fulfill_call_ (&expr, e->token);
14333
14334 if (ffebld_op (expr) != FFEBLD_opANY)
14335 ffebld_set_info (expr,
14336 ffeinfo_new (ffeinfo_basictype (info),
14337 ffeinfo_kindtype (info),
14338 0,
14339 FFEINFO_kindENTITY,
14340 FFEINFO_whereFLEETING,
14341 ffeinfo_size (info)));
14342 else
14343 ffebld_set_info (expr, ffeinfo_new_any ());
14344 }
14345 }
14346
14347 e->u.operand = expr;
14348 ffeexpr_exprstack_push_operand_ (e);
14349 return (ffelexHandler) ffeexpr_finished_ (t);
14350 }
14351
14352 /* ffeexpr_token_name_arg_ -- Rhs NAME
14353
14354 Return a pointer to this function to the lexer (ffelex), which will
14355 invoke it for the next token.
14356
14357 Handle first token in an actual-arg (or possible actual-arg) context
14358 being a NAME, and use second token to refine the context. */
14359
14360 static ffelexHandler
14361 ffeexpr_token_name_arg_ (ffelexToken t)
14362 {
14363 switch (ffelex_token_type (t))
14364 {
14365 case FFELEX_typeCLOSE_PAREN:
14366 case FFELEX_typeCOMMA:
14367 switch (ffeexpr_stack_->context)
14368 {
14369 case FFEEXPR_contextINDEXORACTUALARG_:
14370 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
14371 break;
14372
14373 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
14374 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
14375 break;
14376
14377 default:
14378 break;
14379 }
14380 break;
14381
14382 default:
14383 switch (ffeexpr_stack_->context)
14384 {
14385 case FFEEXPR_contextACTUALARG_:
14386 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
14387 break;
14388
14389 case FFEEXPR_contextINDEXORACTUALARG_:
14390 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
14391 break;
14392
14393 case FFEEXPR_contextSFUNCDEFACTUALARG_:
14394 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
14395 break;
14396
14397 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
14398 ffeexpr_stack_->context
14399 = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
14400 break;
14401
14402 default:
14403 assert ("bad context in _name_arg_" == NULL);
14404 break;
14405 }
14406 break;
14407 }
14408
14409 return (ffelexHandler) ffeexpr_token_name_rhs_ (t);
14410 }
14411
14412 /* ffeexpr_token_name_rhs_ -- Rhs NAME
14413
14414 Return a pointer to this function to the lexer (ffelex), which will
14415 invoke it for the next token.
14416
14417 Handle a name followed by open-paren, apostrophe (O'octal-const',
14418 Z'hex-const', or X'hex-const'), period (RECORD.MEMBER).
14419
14420 26-Nov-91 JCB 1.2
14421 When followed by apostrophe or quote, set lex hexnum flag on so
14422 [0-9] as first char of next token seen as starting a potentially
14423 hex number (NAME).
14424 04-Oct-91 JCB 1.1
14425 In case of intrinsic, decorate its SYMTER with the type info for
14426 the specific intrinsic. */
14427
14428 static ffelexHandler
14429 ffeexpr_token_name_rhs_ (ffelexToken t)
14430 {
14431 ffeexprExpr_ e;
14432 ffeexprParenType_ paren_type;
14433 ffesymbol s;
14434 bool sfdef;
14435
14436 switch (ffelex_token_type (t))
14437 {
14438 case FFELEX_typeQUOTE:
14439 case FFELEX_typeAPOSTROPHE:
14440 ffeexpr_tokens_[1] = ffelex_token_use (t);
14441 ffelex_set_hexnum (TRUE);
14442 return (ffelexHandler) ffeexpr_token_name_apos_;
14443
14444 case FFELEX_typeOPEN_PAREN:
14445 e = ffeexpr_expr_new_ ();
14446 e->type = FFEEXPR_exprtypeOPERAND_;
14447 e->token = ffelex_token_use (ffeexpr_tokens_[0]);
14448 s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], TRUE,
14449 &paren_type);
14450 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14451 e->u.operand = ffebld_new_any ();
14452 else
14453 e->u.operand = ffebld_new_symter (s, ffesymbol_generic (s),
14454 ffesymbol_specific (s),
14455 ffesymbol_implementation (s));
14456 ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */
14457 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
14458 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
14459 {
14460 case FFEEXPR_contextSFUNCDEF:
14461 case FFEEXPR_contextSFUNCDEFINDEX_:
14462 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
14463 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
14464 sfdef = TRUE;
14465 break;
14466
14467 case FFEEXPR_contextSFUNCDEFACTUALARG_:
14468 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
14469 assert ("weird context!" == NULL);
14470 sfdef = FALSE;
14471 break;
14472
14473 default:
14474 sfdef = FALSE;
14475 break;
14476 }
14477 switch (paren_type)
14478 {
14479 case FFEEXPR_parentypeFUNCTION_:
14480 ffebld_set_info (e->u.operand, ffesymbol_info (s));
14481 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14482 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
14483 { /* A statement function. */
14484 ffeexpr_stack_->num_args
14485 = ffebld_list_length
14486 (ffeexpr_stack_->next_dummy
14487 = ffesymbol_dummyargs (s));
14488 ffeexpr_stack_->tokens[1] = NULL; /* !=NULL when > num_args. */
14489 }
14490 else if ((ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
14491 && !ffe_is_pedantic_not_90 ()
14492 && ((ffesymbol_implementation (s)
14493 == FFEINTRIN_impICHAR)
14494 || (ffesymbol_implementation (s)
14495 == FFEINTRIN_impIACHAR)
14496 || (ffesymbol_implementation (s)
14497 == FFEINTRIN_impLEN)))
14498 { /* Allow arbitrary concatenations. */
14499 return
14500 (ffelexHandler)
14501 ffeexpr_rhs (ffeexpr_stack_->pool,
14502 sfdef
14503 ? FFEEXPR_contextSFUNCDEF
14504 : FFEEXPR_contextLET,
14505 ffeexpr_token_arguments_);
14506 }
14507 return
14508 (ffelexHandler)
14509 ffeexpr_rhs (ffeexpr_stack_->pool,
14510 sfdef
14511 ? FFEEXPR_contextSFUNCDEFACTUALARG_
14512 : FFEEXPR_contextACTUALARG_,
14513 ffeexpr_token_arguments_);
14514
14515 case FFEEXPR_parentypeARRAY_:
14516 ffebld_set_info (e->u.operand,
14517 ffesymbol_info (ffebld_symter (e->u.operand)));
14518 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14519 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
14520 ffeexpr_stack_->rank = 0;
14521 ffeexpr_stack_->constant = TRUE;
14522 ffeexpr_stack_->immediate = TRUE;
14523 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
14524 sfdef
14525 ? FFEEXPR_contextSFUNCDEFINDEX_
14526 : FFEEXPR_contextINDEX_,
14527 ffeexpr_token_elements_);
14528
14529 case FFEEXPR_parentypeSUBSTRING_:
14530 ffebld_set_info (e->u.operand,
14531 ffesymbol_info (ffebld_symter (e->u.operand)));
14532 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
14533 ffeexpr_tokens_[0]);
14534 return
14535 (ffelexHandler)
14536 ffeexpr_rhs (ffeexpr_stack_->pool,
14537 sfdef
14538 ? FFEEXPR_contextSFUNCDEFINDEX_
14539 : FFEEXPR_contextINDEX_,
14540 ffeexpr_token_substring_);
14541
14542 case FFEEXPR_parentypeFUNSUBSTR_:
14543 return
14544 (ffelexHandler)
14545 ffeexpr_rhs (ffeexpr_stack_->pool,
14546 sfdef
14547 ? FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
14548 : FFEEXPR_contextINDEXORACTUALARG_,
14549 ffeexpr_token_funsubstr_);
14550
14551 case FFEEXPR_parentypeANY_:
14552 ffebld_set_info (e->u.operand, ffesymbol_info (s));
14553 return
14554 (ffelexHandler)
14555 ffeexpr_rhs (ffeexpr_stack_->pool,
14556 sfdef
14557 ? FFEEXPR_contextSFUNCDEFACTUALARG_
14558 : FFEEXPR_contextACTUALARG_,
14559 ffeexpr_token_anything_);
14560
14561 default:
14562 assert ("bad paren type" == NULL);
14563 break;
14564 }
14565
14566 case FFELEX_typeEQUALS: /* As in "VAR=". */
14567 switch (ffeexpr_stack_->context)
14568 {
14569 case FFEEXPR_contextIMPDOITEM_: /* "(,VAR=start,end[,incr])". */
14570 case FFEEXPR_contextIMPDOITEMDF_:
14571 ffeexpr_stack_->is_rhs = FALSE; /* Really an lhs construct. */
14572 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
14573 break;
14574
14575 default:
14576 break;
14577 }
14578 break;
14579
14580 #if 0
14581 case FFELEX_typePERIOD:
14582 case FFELEX_typePERCENT:
14583 ~~Support these two someday, though not required
14584 assert ("FOO%, FOO. not yet supported!~~" == NULL);
14585 break;
14586 #endif
14587
14588 default:
14589 break;
14590 }
14591
14592 switch (ffeexpr_stack_->context)
14593 {
14594 case FFEEXPR_contextINDEXORACTUALARG_:
14595 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
14596 assert ("strange context" == NULL);
14597 break;
14598
14599 default:
14600 break;
14601 }
14602
14603 e = ffeexpr_expr_new_ ();
14604 e->type = FFEEXPR_exprtypeOPERAND_;
14605 e->token = ffeexpr_tokens_[0];
14606 s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0], FALSE);
14607 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14608 {
14609 e->u.operand = ffebld_new_any ();
14610 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14611 }
14612 else
14613 {
14614 e->u.operand = ffebld_new_symter (s, FFEINTRIN_genNONE,
14615 ffesymbol_specific (s),
14616 ffesymbol_implementation (s));
14617 if (ffesymbol_specific (s) == FFEINTRIN_specNONE)
14618 ffebld_set_info (e->u.operand, ffeinfo_use (ffesymbol_info (s)));
14619 else
14620 { /* Decorate the SYMTER with the actual type
14621 of the intrinsic. */
14622 ffebld_set_info (e->u.operand, ffeinfo_new
14623 (ffeintrin_basictype (ffesymbol_specific (s)),
14624 ffeintrin_kindtype (ffesymbol_specific (s)),
14625 0,
14626 ffesymbol_kind (s),
14627 ffesymbol_where (s),
14628 FFETARGET_charactersizeNONE));
14629 }
14630 if (ffesymbol_is_doiter (s))
14631 ffebld_symter_set_is_doiter (e->u.operand, TRUE);
14632 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
14633 ffeexpr_tokens_[0]);
14634 }
14635 ffeexpr_exprstack_push_operand_ (e);
14636 return (ffelexHandler) ffeexpr_token_binary_ (t);
14637 }
14638
14639 /* ffeexpr_token_name_apos_ -- Rhs NAME APOSTROPHE
14640
14641 Return a pointer to this function to the lexer (ffelex), which will
14642 invoke it for the next token.
14643
14644 Expecting a NAME token, analyze the previous NAME token to see what kind,
14645 if any, typeless constant we've got.
14646
14647 01-Sep-90 JCB 1.1
14648 Expect a NAME instead of CHARACTER in this situation. */
14649
14650 static ffelexHandler
14651 ffeexpr_token_name_apos_ (ffelexToken t)
14652 {
14653 ffeexprExpr_ e;
14654
14655 ffelex_set_hexnum (FALSE);
14656
14657 switch (ffelex_token_type (t))
14658 {
14659 case FFELEX_typeNAME:
14660 ffeexpr_tokens_[2] = ffelex_token_use (t);
14661 return (ffelexHandler) ffeexpr_token_name_apos_name_;
14662
14663 default:
14664 break;
14665 }
14666
14667 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14668 {
14669 ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
14670 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14671 ffelex_token_where_column (ffeexpr_tokens_[0]));
14672 ffebad_here (1, ffelex_token_where_line (t),
14673 ffelex_token_where_column (t));
14674 ffebad_finish ();
14675 }
14676
14677 ffelex_token_kill (ffeexpr_tokens_[1]);
14678
14679 e = ffeexpr_expr_new_ ();
14680 e->type = FFEEXPR_exprtypeOPERAND_;
14681 e->u.operand = ffebld_new_any ();
14682 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14683 e->token = ffeexpr_tokens_[0];
14684 ffeexpr_exprstack_push_operand_ (e);
14685
14686 return (ffelexHandler) ffeexpr_token_binary_ (t);
14687 }
14688
14689 /* ffeexpr_token_name_apos_name_ -- Rhs NAME APOSTROPHE NAME
14690
14691 Return a pointer to this function to the lexer (ffelex), which will
14692 invoke it for the next token.
14693
14694 Expecting an APOSTROPHE token, analyze the previous NAME token to see
14695 what kind, if any, typeless constant we've got. */
14696
14697 static ffelexHandler
14698 ffeexpr_token_name_apos_name_ (ffelexToken t)
14699 {
14700 ffeexprExpr_ e;
14701 char c;
14702
14703 e = ffeexpr_expr_new_ ();
14704 e->type = FFEEXPR_exprtypeOPERAND_;
14705 e->token = ffeexpr_tokens_[0];
14706
14707 if ((ffelex_token_type (t) == ffelex_token_type (ffeexpr_tokens_[1]))
14708 && (ffelex_token_length (ffeexpr_tokens_[0]) == 1)
14709 && (ffesrc_char_match_init ((c = ffelex_token_text (ffeexpr_tokens_[0])[0]),
14710 'B', 'b')
14711 || ffesrc_char_match_init (c, 'O', 'o')
14712 || ffesrc_char_match_init (c, 'X', 'x')
14713 || ffesrc_char_match_init (c, 'Z', 'z')))
14714 {
14715 ffetargetCharacterSize size;
14716
14717 if (!ffe_is_typeless_boz ()) {
14718
14719 switch (c)
14720 {
14721 case FFESRC_CASE_MATCH_INIT ('B', 'b', imatch_b, no_imatch):
14722 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerbinary
14723 (ffeexpr_tokens_[2]));
14724 break;
14725
14726 case FFESRC_CASE_MATCH_INIT ('O', 'o', imatch_o, no_imatch):
14727 e->u.operand = ffebld_new_conter (ffebld_constant_new_integeroctal
14728 (ffeexpr_tokens_[2]));
14729 break;
14730
14731 case FFESRC_CASE_MATCH_INIT ('X', 'x', imatch_x, no_imatch):
14732 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
14733 (ffeexpr_tokens_[2]));
14734 break;
14735
14736 case FFESRC_CASE_MATCH_INIT ('Z', 'z', imatch_z, no_imatch):
14737 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
14738 (ffeexpr_tokens_[2]));
14739 break;
14740
14741 default:
14742 no_imatch: /* :::::::::::::::::::: */
14743 assert ("not BOXZ!" == NULL);
14744 abort ();
14745 }
14746
14747 ffebld_set_info (e->u.operand,
14748 ffeinfo_new (FFEINFO_basictypeINTEGER,
14749 FFEINFO_kindtypeINTEGERDEFAULT, 0,
14750 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14751 FFETARGET_charactersizeNONE));
14752 ffeexpr_exprstack_push_operand_ (e);
14753 ffelex_token_kill (ffeexpr_tokens_[1]);
14754 ffelex_token_kill (ffeexpr_tokens_[2]);
14755 return (ffelexHandler) ffeexpr_token_binary_;
14756 }
14757
14758 switch (c)
14759 {
14760 case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
14761 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_bm
14762 (ffeexpr_tokens_[2]));
14763 size = ffetarget_size_typeless_binary (ffeexpr_tokens_[2]);
14764 break;
14765
14766 case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
14767 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_om
14768 (ffeexpr_tokens_[2]));
14769 size = ffetarget_size_typeless_octal (ffeexpr_tokens_[2]);
14770 break;
14771
14772 case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
14773 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hxm
14774 (ffeexpr_tokens_[2]));
14775 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
14776 break;
14777
14778 case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
14779 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
14780 (ffeexpr_tokens_[2]));
14781 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
14782 break;
14783
14784 default:
14785 no_match: /* :::::::::::::::::::: */
14786 assert ("not BOXZ!" == NULL);
14787 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
14788 (ffeexpr_tokens_[2]));
14789 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
14790 break;
14791 }
14792 ffebld_set_info (e->u.operand,
14793 ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
14794 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
14795 ffeexpr_exprstack_push_operand_ (e);
14796 ffelex_token_kill (ffeexpr_tokens_[1]);
14797 ffelex_token_kill (ffeexpr_tokens_[2]);
14798 return (ffelexHandler) ffeexpr_token_binary_;
14799 }
14800
14801 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14802 {
14803 ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
14804 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14805 ffelex_token_where_column (ffeexpr_tokens_[0]));
14806 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14807 ffebad_finish ();
14808 }
14809
14810 ffelex_token_kill (ffeexpr_tokens_[1]);
14811 ffelex_token_kill (ffeexpr_tokens_[2]);
14812
14813 e->type = FFEEXPR_exprtypeOPERAND_;
14814 e->u.operand = ffebld_new_any ();
14815 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14816 e->token = ffeexpr_tokens_[0];
14817 ffeexpr_exprstack_push_operand_ (e);
14818
14819 switch (ffelex_token_type (t))
14820 {
14821 case FFELEX_typeAPOSTROPHE:
14822 case FFELEX_typeQUOTE:
14823 return (ffelexHandler) ffeexpr_token_binary_;
14824
14825 default:
14826 return (ffelexHandler) ffeexpr_token_binary_ (t);
14827 }
14828 }
14829
14830 /* ffeexpr_token_percent_ -- Rhs PERCENT
14831
14832 Handle a percent sign possibly followed by "LOC". If followed instead
14833 by "VAL", "REF", or "DESCR", issue an error message and substitute
14834 "LOC". If followed by something else, treat the percent sign as a
14835 spurious incorrect token and reprocess the token via _rhs_. */
14836
14837 static ffelexHandler
14838 ffeexpr_token_percent_ (ffelexToken t)
14839 {
14840 switch (ffelex_token_type (t))
14841 {
14842 case FFELEX_typeNAME:
14843 case FFELEX_typeNAMES:
14844 ffeexpr_stack_->percent = ffeexpr_percent_ (t);
14845 ffeexpr_tokens_[1] = ffelex_token_use (t);
14846 return (ffelexHandler) ffeexpr_token_percent_name_;
14847
14848 default:
14849 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
14850 {
14851 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14852 ffelex_token_where_column (ffeexpr_tokens_[0]));
14853 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
14854 ffelex_token_where_column (ffeexpr_stack_->first_token));
14855 ffebad_finish ();
14856 }
14857 ffelex_token_kill (ffeexpr_tokens_[0]);
14858 return (ffelexHandler) ffeexpr_token_rhs_ (t);
14859 }
14860 }
14861
14862 /* ffeexpr_token_percent_name_ -- Rhs PERCENT NAME
14863
14864 Make sure the token is OPEN_PAREN and prepare for the one-item list of
14865 LHS expressions. Else display an error message. */
14866
14867 static ffelexHandler
14868 ffeexpr_token_percent_name_ (ffelexToken t)
14869 {
14870 ffelexHandler nexthandler;
14871
14872 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
14873 {
14874 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
14875 {
14876 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14877 ffelex_token_where_column (ffeexpr_tokens_[0]));
14878 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
14879 ffelex_token_where_column (ffeexpr_stack_->first_token));
14880 ffebad_finish ();
14881 }
14882 ffelex_token_kill (ffeexpr_tokens_[0]);
14883 nexthandler = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_tokens_[1]);
14884 ffelex_token_kill (ffeexpr_tokens_[1]);
14885 return (ffelexHandler) (*nexthandler) (t);
14886 }
14887
14888 switch (ffeexpr_stack_->percent)
14889 {
14890 default:
14891 if (ffest_ffebad_start (FFEBAD_INVALID_PERCENT))
14892 {
14893 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14894 ffelex_token_where_column (ffeexpr_tokens_[0]));
14895 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
14896 ffebad_finish ();
14897 }
14898 ffeexpr_stack_->percent = FFEEXPR_percentLOC_;
14899 /* Fall through. */
14900 case FFEEXPR_percentLOC_:
14901 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
14902 ffelex_token_kill (ffeexpr_tokens_[1]);
14903 ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
14904 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
14905 FFEEXPR_contextLOC_,
14906 ffeexpr_cb_end_loc_);
14907 }
14908 }
14909
14910 /* ffeexpr_make_float_const_ -- Make a floating-point constant
14911
14912 See prototype.
14913
14914 Pass 'E', 'D', or 'Q' for exponent letter. */
14915
14916 static void
14917 ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
14918 ffelexToken decimal, ffelexToken fraction,
14919 ffelexToken exponent, ffelexToken exponent_sign,
14920 ffelexToken exponent_digits)
14921 {
14922 ffeexprExpr_ e;
14923
14924 e = ffeexpr_expr_new_ ();
14925 e->type = FFEEXPR_exprtypeOPERAND_;
14926 if (integer != NULL)
14927 e->token = ffelex_token_use (integer);
14928 else
14929 {
14930 assert (decimal != NULL);
14931 e->token = ffelex_token_use (decimal);
14932 }
14933
14934 switch (exp_letter)
14935 {
14936 #if !FFETARGET_okREALQUAD
14937 case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
14938 if (ffebad_start (FFEBAD_QUAD_UNSUPPORTED))
14939 {
14940 ffebad_here (0, ffelex_token_where_line (e->token),
14941 ffelex_token_where_column (e->token));
14942 ffebad_finish ();
14943 }
14944 goto match_d; /* The FFESRC_CASE_* macros don't
14945 allow fall-through! */
14946 #endif
14947
14948 case FFESRC_CASE_MATCH_INIT ('D', 'd', match_d, no_match):
14949 e->u.operand = ffebld_new_conter (ffebld_constant_new_realdouble
14950 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
14951 ffebld_set_info (e->u.operand,
14952 ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
14953 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14954 break;
14955
14956 case FFESRC_CASE_MATCH_INIT ('E', 'e', match_e, no_match):
14957 e->u.operand = ffebld_new_conter (ffebld_constant_new_realdefault
14958 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
14959 ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeREAL,
14960 FFEINFO_kindtypeREALDEFAULT, 0, FFEINFO_kindENTITY,
14961 FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14962 break;
14963
14964 #if FFETARGET_okREALQUAD
14965 case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
14966 e->u.operand = ffebld_new_conter (ffebld_constant_new_realquad
14967 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
14968 ffebld_set_info (e->u.operand,
14969 ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALQUAD,
14970 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14971 break;
14972 #endif
14973
14974 case 'I': /* Make an integer. */
14975 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
14976 (ffeexpr_tokens_[0]));
14977 ffebld_set_info (e->u.operand,
14978 ffeinfo_new (FFEINFO_basictypeINTEGER,
14979 FFEINFO_kindtypeINTEGERDEFAULT, 0,
14980 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14981 FFETARGET_charactersizeNONE));
14982 break;
14983
14984 default:
14985 no_match: /* :::::::::::::::::::: */
14986 assert ("Lost the exponent letter!" == NULL);
14987 }
14988
14989 ffeexpr_exprstack_push_operand_ (e);
14990 }
14991
14992 /* Just like ffesymbol_declare_local, except performs any implicit info
14993 assignment necessary. */
14994
14995 static ffesymbol
14996 ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin)
14997 {
14998 ffesymbol s;
14999 ffeinfoKind k;
15000 bool bad;
15001
15002 s = ffesymbol_declare_local (t, maybe_intrin);
15003
15004 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15005 /* Special-case these since they can involve a different concept
15006 of "state" (in the stmtfunc name space). */
15007 {
15008 case FFEEXPR_contextDATAIMPDOINDEX_:
15009 case FFEEXPR_contextDATAIMPDOCTRL_:
15010 if (ffeexpr_context_outer_ (ffeexpr_stack_)
15011 == FFEEXPR_contextDATAIMPDOINDEX_)
15012 s = ffeexpr_sym_impdoitem_ (s, t);
15013 else
15014 if (ffeexpr_stack_->is_rhs)
15015 s = ffeexpr_sym_impdoitem_ (s, t);
15016 else
15017 s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
15018 bad = (ffesymbol_kind (s) != FFEINFO_kindENTITY)
15019 || ((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
15020 && (ffesymbol_where (s) != FFEINFO_whereIMMEDIATE));
15021 if (bad && (ffesymbol_kind (s) != FFEINFO_kindANY))
15022 ffesymbol_error (s, t);
15023 return s;
15024
15025 default:
15026 break;
15027 }
15028
15029 switch ((ffesymbol_sfdummyparent (s) == NULL)
15030 ? ffesymbol_state (s)
15031 : FFESYMBOL_stateUNDERSTOOD)
15032 {
15033 case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr
15034 context. */
15035 if (!ffest_seen_first_exec ())
15036 goto seen; /* :::::::::::::::::::: */
15037 /* Fall through. */
15038 case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */
15039 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15040 {
15041 case FFEEXPR_contextSUBROUTINEREF:
15042 s = ffeexpr_sym_lhs_call_ (s, t);
15043 break;
15044
15045 case FFEEXPR_contextFILEEXTFUNC:
15046 s = ffeexpr_sym_lhs_extfunc_ (s, t);
15047 break;
15048
15049 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15050 s = ffecom_sym_exec_transition (s);
15051 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15052 goto understood; /* :::::::::::::::::::: */
15053 /* Fall through. */
15054 case FFEEXPR_contextACTUALARG_:
15055 s = ffeexpr_sym_rhs_actualarg_ (s, t);
15056 break;
15057
15058 case FFEEXPR_contextDATA:
15059 if (ffeexpr_stack_->is_rhs)
15060 s = ffeexpr_sym_rhs_let_ (s, t);
15061 else
15062 s = ffeexpr_sym_lhs_data_ (s, t);
15063 break;
15064
15065 case FFEEXPR_contextDATAIMPDOITEM_:
15066 s = ffeexpr_sym_lhs_data_ (s, t);
15067 break;
15068
15069 case FFEEXPR_contextSFUNCDEF:
15070 case FFEEXPR_contextSFUNCDEFINDEX_:
15071 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15072 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15073 s = ffecom_sym_exec_transition (s);
15074 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15075 goto understood; /* :::::::::::::::::::: */
15076 /* Fall through. */
15077 case FFEEXPR_contextLET:
15078 case FFEEXPR_contextPAREN_:
15079 case FFEEXPR_contextACTUALARGEXPR_:
15080 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15081 case FFEEXPR_contextASSIGN:
15082 case FFEEXPR_contextIOLIST:
15083 case FFEEXPR_contextIOLISTDF:
15084 case FFEEXPR_contextDO:
15085 case FFEEXPR_contextDOWHILE:
15086 case FFEEXPR_contextAGOTO:
15087 case FFEEXPR_contextCGOTO:
15088 case FFEEXPR_contextIF:
15089 case FFEEXPR_contextARITHIF:
15090 case FFEEXPR_contextFORMAT:
15091 case FFEEXPR_contextSTOP:
15092 case FFEEXPR_contextRETURN:
15093 case FFEEXPR_contextSELECTCASE:
15094 case FFEEXPR_contextCASE:
15095 case FFEEXPR_contextFILEASSOC:
15096 case FFEEXPR_contextFILEINT:
15097 case FFEEXPR_contextFILEDFINT:
15098 case FFEEXPR_contextFILELOG:
15099 case FFEEXPR_contextFILENUM:
15100 case FFEEXPR_contextFILENUMAMBIG:
15101 case FFEEXPR_contextFILECHAR:
15102 case FFEEXPR_contextFILENUMCHAR:
15103 case FFEEXPR_contextFILEDFCHAR:
15104 case FFEEXPR_contextFILEKEY:
15105 case FFEEXPR_contextFILEUNIT:
15106 case FFEEXPR_contextFILEUNIT_DF:
15107 case FFEEXPR_contextFILEUNITAMBIG:
15108 case FFEEXPR_contextFILEFORMAT:
15109 case FFEEXPR_contextFILENAMELIST:
15110 case FFEEXPR_contextFILEVXTCODE:
15111 case FFEEXPR_contextINDEX_:
15112 case FFEEXPR_contextIMPDOITEM_:
15113 case FFEEXPR_contextIMPDOITEMDF_:
15114 case FFEEXPR_contextIMPDOCTRL_:
15115 case FFEEXPR_contextLOC_:
15116 if (ffeexpr_stack_->is_rhs)
15117 s = ffeexpr_sym_rhs_let_ (s, t);
15118 else
15119 s = ffeexpr_sym_lhs_let_ (s, t);
15120 break;
15121
15122 case FFEEXPR_contextCHARACTERSIZE:
15123 case FFEEXPR_contextEQUIVALENCE:
15124 case FFEEXPR_contextINCLUDE:
15125 case FFEEXPR_contextPARAMETER:
15126 case FFEEXPR_contextDIMLIST:
15127 case FFEEXPR_contextDIMLISTCOMMON:
15128 case FFEEXPR_contextKINDTYPE:
15129 case FFEEXPR_contextINITVAL:
15130 case FFEEXPR_contextEQVINDEX_:
15131 break; /* Will turn into errors below. */
15132
15133 default:
15134 ffesymbol_error (s, t);
15135 break;
15136 }
15137 /* Fall through. */
15138 case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */
15139 understood: /* :::::::::::::::::::: */
15140 k = ffesymbol_kind (s);
15141 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15142 {
15143 case FFEEXPR_contextSUBROUTINEREF:
15144 bad = ((k != FFEINFO_kindSUBROUTINE)
15145 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
15146 || (k != FFEINFO_kindNONE)));
15147 break;
15148
15149 case FFEEXPR_contextFILEEXTFUNC:
15150 bad = (k != FFEINFO_kindFUNCTION)
15151 || (ffesymbol_where (s) != FFEINFO_whereGLOBAL);
15152 break;
15153
15154 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15155 case FFEEXPR_contextACTUALARG_:
15156 switch (k)
15157 {
15158 case FFEINFO_kindENTITY:
15159 bad = FALSE;
15160 break;
15161
15162 case FFEINFO_kindFUNCTION:
15163 case FFEINFO_kindSUBROUTINE:
15164 bad
15165 = ((ffesymbol_where (s) != FFEINFO_whereGLOBAL)
15166 && (ffesymbol_where (s) != FFEINFO_whereDUMMY)
15167 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
15168 || !ffeintrin_is_actualarg (ffesymbol_specific (s))));
15169 break;
15170
15171 case FFEINFO_kindNONE:
15172 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
15173 {
15174 bad = !(ffeintrin_is_actualarg (ffesymbol_specific (s)));
15175 break;
15176 }
15177
15178 /* If state is UNDERSTOOD here, it's CHAR*(*) or attrsANY,
15179 and in the former case, attrsTYPE is set, so we
15180 see this as an error as we should, since CHAR*(*)
15181 cannot be actually referenced in a main/block data
15182 program unit. */
15183
15184 if ((ffesymbol_attrs (s) & (FFESYMBOL_attrsANY
15185 | FFESYMBOL_attrsEXTERNAL
15186 | FFESYMBOL_attrsTYPE))
15187 == FFESYMBOL_attrsEXTERNAL)
15188 bad = FALSE;
15189 else
15190 bad = TRUE;
15191 break;
15192
15193 default:
15194 bad = TRUE;
15195 break;
15196 }
15197 break;
15198
15199 case FFEEXPR_contextDATA:
15200 if (ffeexpr_stack_->is_rhs)
15201 bad = (k != FFEINFO_kindENTITY)
15202 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
15203 else
15204 bad = (k != FFEINFO_kindENTITY)
15205 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
15206 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
15207 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
15208 break;
15209
15210 case FFEEXPR_contextDATAIMPDOITEM_:
15211 bad = TRUE; /* Unadorned item never valid. */
15212 break;
15213
15214 case FFEEXPR_contextSFUNCDEF:
15215 case FFEEXPR_contextSFUNCDEFINDEX_:
15216 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15217 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15218 case FFEEXPR_contextLET:
15219 case FFEEXPR_contextPAREN_:
15220 case FFEEXPR_contextACTUALARGEXPR_:
15221 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15222 case FFEEXPR_contextASSIGN:
15223 case FFEEXPR_contextIOLIST:
15224 case FFEEXPR_contextIOLISTDF:
15225 case FFEEXPR_contextDO:
15226 case FFEEXPR_contextDOWHILE:
15227 case FFEEXPR_contextAGOTO:
15228 case FFEEXPR_contextCGOTO:
15229 case FFEEXPR_contextIF:
15230 case FFEEXPR_contextARITHIF:
15231 case FFEEXPR_contextFORMAT:
15232 case FFEEXPR_contextSTOP:
15233 case FFEEXPR_contextRETURN:
15234 case FFEEXPR_contextSELECTCASE:
15235 case FFEEXPR_contextCASE:
15236 case FFEEXPR_contextFILEASSOC:
15237 case FFEEXPR_contextFILEINT:
15238 case FFEEXPR_contextFILEDFINT:
15239 case FFEEXPR_contextFILELOG:
15240 case FFEEXPR_contextFILENUM:
15241 case FFEEXPR_contextFILENUMAMBIG:
15242 case FFEEXPR_contextFILECHAR:
15243 case FFEEXPR_contextFILENUMCHAR:
15244 case FFEEXPR_contextFILEDFCHAR:
15245 case FFEEXPR_contextFILEKEY:
15246 case FFEEXPR_contextFILEUNIT:
15247 case FFEEXPR_contextFILEUNIT_DF:
15248 case FFEEXPR_contextFILEUNITAMBIG:
15249 case FFEEXPR_contextFILEFORMAT:
15250 case FFEEXPR_contextFILENAMELIST:
15251 case FFEEXPR_contextFILEVXTCODE:
15252 case FFEEXPR_contextINDEX_:
15253 case FFEEXPR_contextIMPDOITEM_:
15254 case FFEEXPR_contextIMPDOITEMDF_:
15255 case FFEEXPR_contextIMPDOCTRL_:
15256 case FFEEXPR_contextLOC_:
15257 bad = (k != FFEINFO_kindENTITY); /* This catches "SUBROUTINE
15258 X(A);EXTERNAL A;CALL
15259 Y(A);B=A", for example. */
15260 break;
15261
15262 case FFEEXPR_contextCHARACTERSIZE:
15263 case FFEEXPR_contextEQUIVALENCE:
15264 case FFEEXPR_contextPARAMETER:
15265 case FFEEXPR_contextDIMLIST:
15266 case FFEEXPR_contextDIMLISTCOMMON:
15267 case FFEEXPR_contextKINDTYPE:
15268 case FFEEXPR_contextINITVAL:
15269 case FFEEXPR_contextEQVINDEX_:
15270 bad = (k != FFEINFO_kindENTITY)
15271 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
15272 break;
15273
15274 case FFEEXPR_contextINCLUDE:
15275 bad = TRUE;
15276 break;
15277
15278 default:
15279 bad = TRUE;
15280 break;
15281 }
15282 if (bad && (k != FFEINFO_kindANY))
15283 ffesymbol_error (s, t);
15284 return s;
15285
15286 case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */
15287 seen: /* :::::::::::::::::::: */
15288 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15289 {
15290 case FFEEXPR_contextPARAMETER:
15291 if (ffeexpr_stack_->is_rhs)
15292 ffesymbol_error (s, t);
15293 else
15294 s = ffeexpr_sym_lhs_parameter_ (s, t);
15295 break;
15296
15297 case FFEEXPR_contextDATA:
15298 s = ffecom_sym_exec_transition (s);
15299 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15300 goto understood; /* :::::::::::::::::::: */
15301 if (ffeexpr_stack_->is_rhs)
15302 ffesymbol_error (s, t);
15303 else
15304 s = ffeexpr_sym_lhs_data_ (s, t);
15305 goto understood; /* :::::::::::::::::::: */
15306
15307 case FFEEXPR_contextDATAIMPDOITEM_:
15308 s = ffecom_sym_exec_transition (s);
15309 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15310 goto understood; /* :::::::::::::::::::: */
15311 s = ffeexpr_sym_lhs_data_ (s, t);
15312 goto understood; /* :::::::::::::::::::: */
15313
15314 case FFEEXPR_contextEQUIVALENCE:
15315 s = ffeexpr_sym_lhs_equivalence_ (s, t);
15316 break;
15317
15318 case FFEEXPR_contextDIMLIST:
15319 s = ffeexpr_sym_rhs_dimlist_ (s, t);
15320 break;
15321
15322 case FFEEXPR_contextCHARACTERSIZE:
15323 case FFEEXPR_contextKINDTYPE:
15324 case FFEEXPR_contextDIMLISTCOMMON:
15325 case FFEEXPR_contextINITVAL:
15326 case FFEEXPR_contextEQVINDEX_:
15327 ffesymbol_error (s, t);
15328 break;
15329
15330 case FFEEXPR_contextINCLUDE:
15331 ffesymbol_error (s, t);
15332 break;
15333
15334 case FFEEXPR_contextACTUALARG_: /* E.g. I in REAL A(Y(I)). */
15335 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15336 s = ffecom_sym_exec_transition (s);
15337 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15338 goto understood; /* :::::::::::::::::::: */
15339 s = ffeexpr_sym_rhs_actualarg_ (s, t);
15340 goto understood; /* :::::::::::::::::::: */
15341
15342 case FFEEXPR_contextINDEX_:
15343 case FFEEXPR_contextACTUALARGEXPR_:
15344 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15345 case FFEEXPR_contextSFUNCDEF:
15346 case FFEEXPR_contextSFUNCDEFINDEX_:
15347 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15348 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15349 assert (ffeexpr_stack_->is_rhs);
15350 s = ffecom_sym_exec_transition (s);
15351 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15352 goto understood; /* :::::::::::::::::::: */
15353 s = ffeexpr_sym_rhs_let_ (s, t);
15354 goto understood; /* :::::::::::::::::::: */
15355
15356 default:
15357 ffesymbol_error (s, t);
15358 break;
15359 }
15360 return s;
15361
15362 default:
15363 assert ("bad symbol state" == NULL);
15364 return NULL;
15365 break;
15366 }
15367 }
15368
15369 /* Have FOO in DATA (XYZ(FOO),...)/.../ or DATA (...,XYZ=FOO,BAR,BLETCH).
15370 Could be found via the "statement-function" name space (in which case
15371 it should become an iterator) or the local name space (in which case
15372 it should be either a named constant, or a variable that will have an
15373 sfunc name space sibling that should become an iterator). */
15374
15375 static ffesymbol
15376 ffeexpr_sym_impdoitem_ (ffesymbol sp, ffelexToken t)
15377 {
15378 ffesymbol s;
15379 ffesymbolAttrs sa;
15380 ffesymbolAttrs na;
15381 ffesymbolState ss;
15382 ffesymbolState ns;
15383 ffeinfoKind kind;
15384 ffeinfoWhere where;
15385
15386 ss = ffesymbol_state (sp);
15387
15388 if (ffesymbol_sfdummyparent (sp) != NULL)
15389 { /* Have symbol in sfunc name space. */
15390 switch (ss)
15391 {
15392 case FFESYMBOL_stateNONE: /* Used as iterator already. */
15393 if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
15394 ffesymbol_error (sp, t); /* Can't use dead iterator. */
15395 else
15396 { /* Can use dead iterator because we're at at
15397 least an innermore (higher-numbered) level
15398 than the iterator's outermost
15399 (lowest-numbered) level. */
15400 ffesymbol_signal_change (sp);
15401 ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
15402 ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
15403 ffesymbol_signal_unreported (sp);
15404 }
15405 break;
15406
15407 case FFESYMBOL_stateSEEN: /* Seen already in this or other
15408 implied-DO. Set symbol level
15409 number to outermost value, as that
15410 tells us we can see it as iterator
15411 at that level at the innermost. */
15412 if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
15413 {
15414 ffesymbol_signal_change (sp);
15415 ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
15416 ffesymbol_signal_unreported (sp);
15417 }
15418 break;
15419
15420 case FFESYMBOL_stateUNCERTAIN: /* Iterator. */
15421 assert (ffeexpr_level_ == ffesymbol_maxentrynum (sp));
15422 ffesymbol_error (sp, t); /* (,,,I=I,10). */
15423 break;
15424
15425 case FFESYMBOL_stateUNDERSTOOD:
15426 break; /* ANY. */
15427
15428 default:
15429 assert ("Foo Bar!!" == NULL);
15430 break;
15431 }
15432
15433 return sp;
15434 }
15435
15436 /* Got symbol in local name space, so we haven't seen it in impdo yet.
15437 First, if it is brand-new and we're in executable statements, set the
15438 attributes and exec-transition it to set state UNCERTAIN or UNDERSTOOD.
15439 Second, if it is now a constant (PARAMETER), then just return it, it
15440 can't be an implied-do iterator. If it is understood, complain if it is
15441 not a valid variable, but make the inner name space iterator anyway and
15442 return that. If it is not understood, improve understanding of the
15443 symbol accordingly, complain accordingly, in either case make the inner
15444 name space iterator and return that. */
15445
15446 sa = ffesymbol_attrs (sp);
15447
15448 if (ffesymbol_state_is_specable (ss)
15449 && ffest_seen_first_exec ())
15450 {
15451 assert (sa == FFESYMBOL_attrsetNONE);
15452 ffesymbol_signal_change (sp);
15453 ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
15454 ffesymbol_resolve_intrin (sp);
15455 if (ffeimplic_establish_symbol (sp))
15456 ffesymbol_set_attr (sp, FFESYMBOL_attrSFARG);
15457 else
15458 ffesymbol_error (sp, t);
15459
15460 /* After the exec transition, the state will either be UNCERTAIN (could
15461 be a dummy or local var) or UNDERSTOOD (local var, because this is a
15462 PROGRAM/BLOCKDATA program unit). */
15463
15464 sp = ffecom_sym_exec_transition (sp);
15465 sa = ffesymbol_attrs (sp);
15466 ss = ffesymbol_state (sp);
15467 }
15468
15469 ns = ss;
15470 kind = ffesymbol_kind (sp);
15471 where = ffesymbol_where (sp);
15472
15473 if (ss == FFESYMBOL_stateUNDERSTOOD)
15474 {
15475 if (kind != FFEINFO_kindENTITY)
15476 ffesymbol_error (sp, t);
15477 if (where == FFEINFO_whereCONSTANT)
15478 return sp;
15479 }
15480 else
15481 {
15482 /* Enhance understanding of local symbol. This used to imply exec
15483 transition, but that doesn't seem necessary, since the local symbol
15484 doesn't actually get put into an ffebld tree here -- we just learn
15485 more about it, just like when we see a local symbol's name in the
15486 dummy-arg list of a statement function. */
15487
15488 if (ss != FFESYMBOL_stateUNCERTAIN)
15489 {
15490 /* Figure out what kind of object we've got based on previous
15491 declarations of or references to the object. */
15492
15493 ns = FFESYMBOL_stateSEEN;
15494
15495 if (sa & FFESYMBOL_attrsANY)
15496 na = sa;
15497 else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
15498 | FFESYMBOL_attrsANY
15499 | FFESYMBOL_attrsCOMMON
15500 | FFESYMBOL_attrsDUMMY
15501 | FFESYMBOL_attrsEQUIV
15502 | FFESYMBOL_attrsINIT
15503 | FFESYMBOL_attrsNAMELIST
15504 | FFESYMBOL_attrsRESULT
15505 | FFESYMBOL_attrsSAVE
15506 | FFESYMBOL_attrsSFARG
15507 | FFESYMBOL_attrsTYPE)))
15508 na = sa | FFESYMBOL_attrsSFARG;
15509 else
15510 na = FFESYMBOL_attrsetNONE;
15511 }
15512 else
15513 { /* stateUNCERTAIN. */
15514 na = sa | FFESYMBOL_attrsSFARG;
15515 ns = FFESYMBOL_stateUNDERSTOOD;
15516
15517 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15518 | FFESYMBOL_attrsADJUSTABLE
15519 | FFESYMBOL_attrsANYLEN
15520 | FFESYMBOL_attrsARRAY
15521 | FFESYMBOL_attrsDUMMY
15522 | FFESYMBOL_attrsEXTERNAL
15523 | FFESYMBOL_attrsSFARG
15524 | FFESYMBOL_attrsTYPE)));
15525
15526 if (sa & FFESYMBOL_attrsEXTERNAL)
15527 {
15528 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15529 | FFESYMBOL_attrsDUMMY
15530 | FFESYMBOL_attrsEXTERNAL
15531 | FFESYMBOL_attrsTYPE)));
15532
15533 na = FFESYMBOL_attrsetNONE;
15534 }
15535 else if (sa & FFESYMBOL_attrsDUMMY)
15536 {
15537 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
15538 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
15539 | FFESYMBOL_attrsEXTERNAL
15540 | FFESYMBOL_attrsTYPE)));
15541
15542 kind = FFEINFO_kindENTITY;
15543 }
15544 else if (sa & FFESYMBOL_attrsARRAY)
15545 {
15546 assert (!(sa & ~(FFESYMBOL_attrsARRAY
15547 | FFESYMBOL_attrsADJUSTABLE
15548 | FFESYMBOL_attrsTYPE)));
15549
15550 na = FFESYMBOL_attrsetNONE;
15551 }
15552 else if (sa & FFESYMBOL_attrsSFARG)
15553 {
15554 assert (!(sa & ~(FFESYMBOL_attrsSFARG
15555 | FFESYMBOL_attrsTYPE)));
15556
15557 ns = FFESYMBOL_stateUNCERTAIN;
15558 }
15559 else if (sa & FFESYMBOL_attrsTYPE)
15560 {
15561 assert (!(sa & (FFESYMBOL_attrsARRAY
15562 | FFESYMBOL_attrsDUMMY
15563 | FFESYMBOL_attrsEXTERNAL
15564 | FFESYMBOL_attrsSFARG))); /* Handled above. */
15565 assert (!(sa & ~(FFESYMBOL_attrsTYPE
15566 | FFESYMBOL_attrsADJUSTABLE
15567 | FFESYMBOL_attrsANYLEN
15568 | FFESYMBOL_attrsARRAY
15569 | FFESYMBOL_attrsDUMMY
15570 | FFESYMBOL_attrsEXTERNAL
15571 | FFESYMBOL_attrsSFARG)));
15572
15573 kind = FFEINFO_kindENTITY;
15574
15575 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
15576 na = FFESYMBOL_attrsetNONE;
15577 else if (ffest_is_entry_valid ())
15578 ns = FFESYMBOL_stateUNCERTAIN; /* Could be DUMMY or LOCAL. */
15579 else
15580 where = FFEINFO_whereLOCAL;
15581 }
15582 else
15583 na = FFESYMBOL_attrsetNONE; /* Error. */
15584 }
15585
15586 /* Now see what we've got for a new object: NONE means a new error
15587 cropped up; ANY means an old error to be ignored; otherwise,
15588 everything's ok, update the object (symbol) and continue on. */
15589
15590 if (na == FFESYMBOL_attrsetNONE)
15591 ffesymbol_error (sp, t);
15592 else if (!(na & FFESYMBOL_attrsANY))
15593 {
15594 ffesymbol_signal_change (sp); /* May need to back up to previous
15595 version. */
15596 if (!ffeimplic_establish_symbol (sp))
15597 ffesymbol_error (sp, t);
15598 else
15599 {
15600 ffesymbol_set_info (sp,
15601 ffeinfo_new (ffesymbol_basictype (sp),
15602 ffesymbol_kindtype (sp),
15603 ffesymbol_rank (sp),
15604 kind,
15605 where,
15606 ffesymbol_size (sp)));
15607 ffesymbol_set_attrs (sp, na);
15608 ffesymbol_set_state (sp, ns);
15609 ffesymbol_resolve_intrin (sp);
15610 if (!ffesymbol_state_is_specable (ns))
15611 sp = ffecom_sym_learned (sp);
15612 ffesymbol_signal_unreported (sp); /* For debugging purposes. */
15613 }
15614 }
15615 }
15616
15617 /* Here we create the sfunc-name-space symbol representing what should
15618 become an iterator in this name space at this or an outermore (lower-
15619 numbered) expression level, else the implied-DO construct is in error. */
15620
15621 s = ffesymbol_declare_sfdummy (t); /* Sets maxentrynum to 0 for new obj;
15622 also sets sfa_dummy_parent to
15623 parent symbol. */
15624 assert (sp == ffesymbol_sfdummyparent (s));
15625
15626 ffesymbol_signal_change (s);
15627 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
15628 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
15629 ffesymbol_set_info (s,
15630 ffeinfo_new (FFEINFO_basictypeINTEGER,
15631 FFEINFO_kindtypeINTEGERDEFAULT,
15632 0,
15633 FFEINFO_kindENTITY,
15634 FFEINFO_whereIMMEDIATE,
15635 FFETARGET_charactersizeNONE));
15636 ffesymbol_signal_unreported (s);
15637
15638 if ((ffesymbol_basictype (sp) != FFEINFO_basictypeINTEGER)
15639 && (ffesymbol_basictype (sp) != FFEINFO_basictypeANY))
15640 ffesymbol_error (s, t);
15641
15642 return s;
15643 }
15644
15645 /* Have FOO in CALL FOO. Local name space, executable context only. */
15646
15647 static ffesymbol
15648 ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t)
15649 {
15650 ffesymbolAttrs sa;
15651 ffesymbolAttrs na;
15652 ffeinfoKind kind;
15653 ffeinfoWhere where;
15654 ffeintrinGen gen;
15655 ffeintrinSpec spec;
15656 ffeintrinImp imp;
15657 bool error = FALSE;
15658
15659 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
15660 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
15661
15662 na = sa = ffesymbol_attrs (s);
15663
15664 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15665 | FFESYMBOL_attrsADJUSTABLE
15666 | FFESYMBOL_attrsANYLEN
15667 | FFESYMBOL_attrsARRAY
15668 | FFESYMBOL_attrsDUMMY
15669 | FFESYMBOL_attrsEXTERNAL
15670 | FFESYMBOL_attrsSFARG
15671 | FFESYMBOL_attrsTYPE)));
15672
15673 kind = ffesymbol_kind (s);
15674 where = ffesymbol_where (s);
15675
15676 /* Figure out what kind of object we've got based on previous declarations
15677 of or references to the object. */
15678
15679 if (sa & FFESYMBOL_attrsEXTERNAL)
15680 {
15681 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15682 | FFESYMBOL_attrsDUMMY
15683 | FFESYMBOL_attrsEXTERNAL
15684 | FFESYMBOL_attrsTYPE)));
15685
15686 if (sa & FFESYMBOL_attrsTYPE)
15687 error = TRUE;
15688 else
15689 /* Not TYPE. */
15690 {
15691 kind = FFEINFO_kindSUBROUTINE;
15692
15693 if (sa & FFESYMBOL_attrsDUMMY)
15694 ; /* Not TYPE. */
15695 else if (sa & FFESYMBOL_attrsACTUALARG)
15696 ; /* Not DUMMY or TYPE. */
15697 else /* Not ACTUALARG, DUMMY, or TYPE. */
15698 where = FFEINFO_whereGLOBAL;
15699 }
15700 }
15701 else if (sa & FFESYMBOL_attrsDUMMY)
15702 {
15703 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
15704 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
15705 | FFESYMBOL_attrsEXTERNAL
15706 | FFESYMBOL_attrsTYPE)));
15707
15708 if (sa & FFESYMBOL_attrsTYPE)
15709 error = TRUE;
15710 else
15711 kind = FFEINFO_kindSUBROUTINE;
15712 }
15713 else if (sa & FFESYMBOL_attrsARRAY)
15714 {
15715 assert (!(sa & ~(FFESYMBOL_attrsARRAY
15716 | FFESYMBOL_attrsADJUSTABLE
15717 | FFESYMBOL_attrsTYPE)));
15718
15719 error = TRUE;
15720 }
15721 else if (sa & FFESYMBOL_attrsSFARG)
15722 {
15723 assert (!(sa & ~(FFESYMBOL_attrsSFARG
15724 | FFESYMBOL_attrsTYPE)));
15725
15726 error = TRUE;
15727 }
15728 else if (sa & FFESYMBOL_attrsTYPE)
15729 {
15730 assert (!(sa & (FFESYMBOL_attrsARRAY
15731 | FFESYMBOL_attrsDUMMY
15732 | FFESYMBOL_attrsEXTERNAL
15733 | FFESYMBOL_attrsSFARG))); /* Handled above. */
15734 assert (!(sa & ~(FFESYMBOL_attrsTYPE
15735 | FFESYMBOL_attrsADJUSTABLE
15736 | FFESYMBOL_attrsANYLEN
15737 | FFESYMBOL_attrsARRAY
15738 | FFESYMBOL_attrsDUMMY
15739 | FFESYMBOL_attrsEXTERNAL
15740 | FFESYMBOL_attrsSFARG)));
15741
15742 error = TRUE;
15743 }
15744 else if (sa == FFESYMBOL_attrsetNONE)
15745 {
15746 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
15747
15748 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
15749 &gen, &spec, &imp))
15750 {
15751 ffesymbol_signal_change (s); /* May need to back up to previous
15752 version. */
15753 ffesymbol_set_generic (s, gen);
15754 ffesymbol_set_specific (s, spec);
15755 ffesymbol_set_implementation (s, imp);
15756 ffesymbol_set_info (s,
15757 ffeinfo_new (FFEINFO_basictypeNONE,
15758 FFEINFO_kindtypeNONE,
15759 0,
15760 FFEINFO_kindSUBROUTINE,
15761 FFEINFO_whereINTRINSIC,
15762 FFETARGET_charactersizeNONE));
15763 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
15764 ffesymbol_resolve_intrin (s);
15765 ffesymbol_reference (s, t, FALSE);
15766 s = ffecom_sym_learned (s);
15767 ffesymbol_signal_unreported (s); /* For debugging purposes. */
15768
15769 return s;
15770 }
15771
15772 kind = FFEINFO_kindSUBROUTINE;
15773 where = FFEINFO_whereGLOBAL;
15774 }
15775 else
15776 error = TRUE;
15777
15778 /* Now see what we've got for a new object: NONE means a new error cropped
15779 up; ANY means an old error to be ignored; otherwise, everything's ok,
15780 update the object (symbol) and continue on. */
15781
15782 if (error)
15783 ffesymbol_error (s, t);
15784 else if (!(na & FFESYMBOL_attrsANY))
15785 {
15786 ffesymbol_signal_change (s); /* May need to back up to previous
15787 version. */
15788 ffesymbol_set_info (s,
15789 ffeinfo_new (ffesymbol_basictype (s),
15790 ffesymbol_kindtype (s),
15791 ffesymbol_rank (s),
15792 kind, /* SUBROUTINE. */
15793 where, /* GLOBAL or DUMMY. */
15794 ffesymbol_size (s)));
15795 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
15796 ffesymbol_resolve_intrin (s);
15797 ffesymbol_reference (s, t, FALSE);
15798 s = ffecom_sym_learned (s);
15799 ffesymbol_signal_unreported (s); /* For debugging purposes. */
15800 }
15801
15802 return s;
15803 }
15804
15805 /* Have FOO in DATA FOO/.../. Local name space and executable context
15806 only. (This will change in the future when DATA FOO may be followed
15807 by COMMON FOO or even INTEGER FOO(10), etc.) */
15808
15809 static ffesymbol
15810 ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t)
15811 {
15812 ffesymbolAttrs sa;
15813 ffesymbolAttrs na;
15814 ffeinfoKind kind;
15815 ffeinfoWhere where;
15816 bool error = FALSE;
15817
15818 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
15819 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
15820
15821 na = sa = ffesymbol_attrs (s);
15822
15823 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15824 | FFESYMBOL_attrsADJUSTABLE
15825 | FFESYMBOL_attrsANYLEN
15826 | FFESYMBOL_attrsARRAY
15827 | FFESYMBOL_attrsDUMMY
15828 | FFESYMBOL_attrsEXTERNAL
15829 | FFESYMBOL_attrsSFARG
15830 | FFESYMBOL_attrsTYPE)));
15831
15832 kind = ffesymbol_kind (s);
15833 where = ffesymbol_where (s);
15834
15835 /* Figure out what kind of object we've got based on previous declarations
15836 of or references to the object. */
15837
15838 if (sa & FFESYMBOL_attrsEXTERNAL)
15839 {
15840 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15841 | FFESYMBOL_attrsDUMMY
15842 | FFESYMBOL_attrsEXTERNAL
15843 | FFESYMBOL_attrsTYPE)));
15844
15845 error = TRUE;
15846 }
15847 else if (sa & FFESYMBOL_attrsDUMMY)
15848 {
15849 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
15850 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
15851 | FFESYMBOL_attrsEXTERNAL
15852 | FFESYMBOL_attrsTYPE)));
15853
15854 error = TRUE;
15855 }
15856 else if (sa & FFESYMBOL_attrsARRAY)
15857 {
15858 assert (!(sa & ~(FFESYMBOL_attrsARRAY
15859 | FFESYMBOL_attrsADJUSTABLE
15860 | FFESYMBOL_attrsTYPE)));
15861
15862 if (sa & FFESYMBOL_attrsADJUSTABLE)
15863 error = TRUE;
15864 where = FFEINFO_whereLOCAL;
15865 }
15866 else if (sa & FFESYMBOL_attrsSFARG)
15867 {
15868 assert (!(sa & ~(FFESYMBOL_attrsSFARG
15869 | FFESYMBOL_attrsTYPE)));
15870
15871 where = FFEINFO_whereLOCAL;
15872 }
15873 else if (sa & FFESYMBOL_attrsTYPE)
15874 {
15875 assert (!(sa & (FFESYMBOL_attrsARRAY
15876 | FFESYMBOL_attrsDUMMY
15877 | FFESYMBOL_attrsEXTERNAL
15878 | FFESYMBOL_attrsSFARG))); /* Handled above. */
15879 assert (!(sa & ~(FFESYMBOL_attrsTYPE
15880 | FFESYMBOL_attrsADJUSTABLE
15881 | FFESYMBOL_attrsANYLEN
15882 | FFESYMBOL_attrsARRAY
15883 | FFESYMBOL_attrsDUMMY
15884 | FFESYMBOL_attrsEXTERNAL
15885 | FFESYMBOL_attrsSFARG)));
15886
15887 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
15888 error = TRUE;
15889 else
15890 {
15891 kind = FFEINFO_kindENTITY;
15892 where = FFEINFO_whereLOCAL;
15893 }
15894 }
15895 else if (sa == FFESYMBOL_attrsetNONE)
15896 {
15897 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
15898 kind = FFEINFO_kindENTITY;
15899 where = FFEINFO_whereLOCAL;
15900 }
15901 else
15902 error = TRUE;
15903
15904 /* Now see what we've got for a new object: NONE means a new error cropped
15905 up; ANY means an old error to be ignored; otherwise, everything's ok,
15906 update the object (symbol) and continue on. */
15907
15908 if (error)
15909 ffesymbol_error (s, t);
15910 else if (!(na & FFESYMBOL_attrsANY))
15911 {
15912 ffesymbol_signal_change (s); /* May need to back up to previous
15913 version. */
15914 if (!ffeimplic_establish_symbol (s))
15915 {
15916 ffesymbol_error (s, t);
15917 return s;
15918 }
15919 ffesymbol_set_info (s,
15920 ffeinfo_new (ffesymbol_basictype (s),
15921 ffesymbol_kindtype (s),
15922 ffesymbol_rank (s),
15923 kind, /* ENTITY. */
15924 where, /* LOCAL. */
15925 ffesymbol_size (s)));
15926 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
15927 ffesymbol_resolve_intrin (s);
15928 s = ffecom_sym_learned (s);
15929 ffesymbol_signal_unreported (s); /* For debugging purposes. */
15930 }
15931
15932 return s;
15933 }
15934
15935 /* Have FOO in EQUIVALENCE (...,FOO,...). Does not include
15936 EQUIVALENCE (...,BAR(FOO),...). */
15937
15938 static ffesymbol
15939 ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t)
15940 {
15941 ffesymbolAttrs sa;
15942 ffesymbolAttrs na;
15943 ffeinfoKind kind;
15944 ffeinfoWhere where;
15945
15946 na = sa = ffesymbol_attrs (s);
15947 kind = FFEINFO_kindENTITY;
15948 where = ffesymbol_where (s);
15949
15950 /* Figure out what kind of object we've got based on previous declarations
15951 of or references to the object. */
15952
15953 if (!(sa & ~(FFESYMBOL_attrsADJUSTS
15954 | FFESYMBOL_attrsARRAY
15955 | FFESYMBOL_attrsCOMMON
15956 | FFESYMBOL_attrsEQUIV
15957 | FFESYMBOL_attrsINIT
15958 | FFESYMBOL_attrsNAMELIST
15959 | FFESYMBOL_attrsSAVE
15960 | FFESYMBOL_attrsSFARG
15961 | FFESYMBOL_attrsTYPE)))
15962 na = sa | FFESYMBOL_attrsEQUIV;
15963 else
15964 na = FFESYMBOL_attrsetNONE;
15965
15966 /* Don't know why we're bothering to set kind and where in this code, but
15967 added the following to make it complete, in case it's really important.
15968 Generally this is left up to symbol exec transition. */
15969
15970 if (where == FFEINFO_whereNONE)
15971 {
15972 if (na & (FFESYMBOL_attrsADJUSTS
15973 | FFESYMBOL_attrsCOMMON))
15974 where = FFEINFO_whereCOMMON;
15975 else if (na & FFESYMBOL_attrsSAVE)
15976 where = FFEINFO_whereLOCAL;
15977 }
15978
15979 /* Now see what we've got for a new object: NONE means a new error cropped
15980 up; ANY means an old error to be ignored; otherwise, everything's ok,
15981 update the object (symbol) and continue on. */
15982
15983 if (na == FFESYMBOL_attrsetNONE)
15984 ffesymbol_error (s, t);
15985 else if (!(na & FFESYMBOL_attrsANY))
15986 {
15987 ffesymbol_signal_change (s); /* May need to back up to previous
15988 version. */
15989 ffesymbol_set_info (s,
15990 ffeinfo_new (ffesymbol_basictype (s),
15991 ffesymbol_kindtype (s),
15992 ffesymbol_rank (s),
15993 kind, /* Always ENTITY. */
15994 where, /* NONE, COMMON, or LOCAL. */
15995 ffesymbol_size (s)));
15996 ffesymbol_set_attrs (s, na);
15997 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
15998 ffesymbol_resolve_intrin (s);
15999 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16000 }
16001
16002 return s;
16003 }
16004
16005 /* Have FOO in OPEN(...,USEROPEN=FOO,...). Executable context only.
16006
16007 Note that I think this should be considered semantically similar to
16008 doing CALL XYZ(FOO), in that it should be considered like an
16009 ACTUALARG context. In particular, without EXTERNAL being specified,
16010 it should not be allowed. */
16011
16012 static ffesymbol
16013 ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t)
16014 {
16015 ffesymbolAttrs sa;
16016 ffesymbolAttrs na;
16017 ffeinfoKind kind;
16018 ffeinfoWhere where;
16019 bool needs_type = FALSE;
16020 bool error = FALSE;
16021
16022 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16023 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16024
16025 na = sa = ffesymbol_attrs (s);
16026
16027 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16028 | FFESYMBOL_attrsADJUSTABLE
16029 | FFESYMBOL_attrsANYLEN
16030 | FFESYMBOL_attrsARRAY
16031 | FFESYMBOL_attrsDUMMY
16032 | FFESYMBOL_attrsEXTERNAL
16033 | FFESYMBOL_attrsSFARG
16034 | FFESYMBOL_attrsTYPE)));
16035
16036 kind = ffesymbol_kind (s);
16037 where = ffesymbol_where (s);
16038
16039 /* Figure out what kind of object we've got based on previous declarations
16040 of or references to the object. */
16041
16042 if (sa & FFESYMBOL_attrsEXTERNAL)
16043 {
16044 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16045 | FFESYMBOL_attrsDUMMY
16046 | FFESYMBOL_attrsEXTERNAL
16047 | FFESYMBOL_attrsTYPE)));
16048
16049 if (sa & FFESYMBOL_attrsTYPE)
16050 where = FFEINFO_whereGLOBAL;
16051 else
16052 /* Not TYPE. */
16053 {
16054 kind = FFEINFO_kindFUNCTION;
16055 needs_type = TRUE;
16056
16057 if (sa & FFESYMBOL_attrsDUMMY)
16058 ; /* Not TYPE. */
16059 else if (sa & FFESYMBOL_attrsACTUALARG)
16060 ; /* Not DUMMY or TYPE. */
16061 else /* Not ACTUALARG, DUMMY, or TYPE. */
16062 where = FFEINFO_whereGLOBAL;
16063 }
16064 }
16065 else if (sa & FFESYMBOL_attrsDUMMY)
16066 {
16067 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16068 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16069 | FFESYMBOL_attrsEXTERNAL
16070 | FFESYMBOL_attrsTYPE)));
16071
16072 kind = FFEINFO_kindFUNCTION;
16073 if (!(sa & FFESYMBOL_attrsTYPE))
16074 needs_type = TRUE;
16075 }
16076 else if (sa & FFESYMBOL_attrsARRAY)
16077 {
16078 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16079 | FFESYMBOL_attrsADJUSTABLE
16080 | FFESYMBOL_attrsTYPE)));
16081
16082 error = TRUE;
16083 }
16084 else if (sa & FFESYMBOL_attrsSFARG)
16085 {
16086 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16087 | FFESYMBOL_attrsTYPE)));
16088
16089 error = TRUE;
16090 }
16091 else if (sa & FFESYMBOL_attrsTYPE)
16092 {
16093 assert (!(sa & (FFESYMBOL_attrsARRAY
16094 | FFESYMBOL_attrsDUMMY
16095 | FFESYMBOL_attrsEXTERNAL
16096 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16097 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16098 | FFESYMBOL_attrsADJUSTABLE
16099 | FFESYMBOL_attrsANYLEN
16100 | FFESYMBOL_attrsARRAY
16101 | FFESYMBOL_attrsDUMMY
16102 | FFESYMBOL_attrsEXTERNAL
16103 | FFESYMBOL_attrsSFARG)));
16104
16105 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16106 error = TRUE;
16107 else
16108 {
16109 kind = FFEINFO_kindFUNCTION;
16110 where = FFEINFO_whereGLOBAL;
16111 }
16112 }
16113 else if (sa == FFESYMBOL_attrsetNONE)
16114 {
16115 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16116 kind = FFEINFO_kindFUNCTION;
16117 where = FFEINFO_whereGLOBAL;
16118 needs_type = TRUE;
16119 }
16120 else
16121 error = TRUE;
16122
16123 /* Now see what we've got for a new object: NONE means a new error cropped
16124 up; ANY means an old error to be ignored; otherwise, everything's ok,
16125 update the object (symbol) and continue on. */
16126
16127 if (error)
16128 ffesymbol_error (s, t);
16129 else if (!(na & FFESYMBOL_attrsANY))
16130 {
16131 ffesymbol_signal_change (s); /* May need to back up to previous
16132 version. */
16133 if (needs_type && !ffeimplic_establish_symbol (s))
16134 {
16135 ffesymbol_error (s, t);
16136 return s;
16137 }
16138 if (!ffesymbol_explicitwhere (s))
16139 {
16140 ffebad_start (FFEBAD_NEED_EXTERNAL);
16141 ffebad_here (0, ffelex_token_where_line (t),
16142 ffelex_token_where_column (t));
16143 ffebad_string (ffesymbol_text (s));
16144 ffebad_finish ();
16145 ffesymbol_set_explicitwhere (s, TRUE);
16146 }
16147 ffesymbol_set_info (s,
16148 ffeinfo_new (ffesymbol_basictype (s),
16149 ffesymbol_kindtype (s),
16150 ffesymbol_rank (s),
16151 kind, /* FUNCTION. */
16152 where, /* GLOBAL or DUMMY. */
16153 ffesymbol_size (s)));
16154 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16155 ffesymbol_resolve_intrin (s);
16156 ffesymbol_reference (s, t, FALSE);
16157 s = ffecom_sym_learned (s);
16158 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16159 }
16160
16161 return s;
16162 }
16163
16164 /* Have FOO in DATA (stuff,FOO=1,10)/.../. */
16165
16166 static ffesymbol
16167 ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t)
16168 {
16169 ffesymbolState ss;
16170
16171 /* If the symbol isn't in the sfunc name space, pretend as though we saw a
16172 reference to it already within the imp-DO construct at this level, so as
16173 to get a symbol that is in the sfunc name space. But this is an
16174 erroneous construct, and should be caught elsewhere. */
16175
16176 if (ffesymbol_sfdummyparent (s) == NULL)
16177 {
16178 s = ffeexpr_sym_impdoitem_ (s, t);
16179 if (ffesymbol_sfdummyparent (s) == NULL)
16180 { /* PARAMETER FOO...DATA (A(I),FOO=...). */
16181 ffesymbol_error (s, t);
16182 return s;
16183 }
16184 }
16185
16186 ss = ffesymbol_state (s);
16187
16188 switch (ss)
16189 {
16190 case FFESYMBOL_stateNONE: /* Used as iterator already. */
16191 if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
16192 ffesymbol_error (s, t); /* Can't reuse dead iterator. F90 disallows
16193 this; F77 allows it but it is a stupid
16194 feature. */
16195 else
16196 { /* Can use dead iterator because we're at at
16197 least a innermore (higher-numbered) level
16198 than the iterator's outermost
16199 (lowest-numbered) level. This should be
16200 diagnosed later, because it means an item
16201 in this list didn't reference this
16202 iterator. */
16203 #if 1
16204 ffesymbol_error (s, t); /* For now, complain. */
16205 #else /* Someday will detect all cases where initializer doesn't reference
16206 all applicable iterators, in which case reenable this code. */
16207 ffesymbol_signal_change (s);
16208 ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
16209 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
16210 ffesymbol_signal_unreported (s);
16211 #endif
16212 }
16213 break;
16214
16215 case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO.
16216 If seen in outermore level, can't be an
16217 iterator here, so complain. If not seen
16218 at current level, complain for now,
16219 because that indicates something F90
16220 rejects (though we currently don't detect
16221 all such cases for now). */
16222 if (ffeexpr_level_ <= ffesymbol_maxentrynum (s))
16223 {
16224 ffesymbol_signal_change (s);
16225 ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
16226 ffesymbol_signal_unreported (s);
16227 }
16228 else
16229 ffesymbol_error (s, t);
16230 break;
16231
16232 case FFESYMBOL_stateUNCERTAIN: /* Already iterator! */
16233 assert ("DATA implied-DO control var seen twice!!" == NULL);
16234 ffesymbol_error (s, t);
16235 break;
16236
16237 case FFESYMBOL_stateUNDERSTOOD:
16238 break; /* ANY. */
16239
16240 default:
16241 assert ("Foo Bletch!!" == NULL);
16242 break;
16243 }
16244
16245 return s;
16246 }
16247
16248 /* Have FOO in PARAMETER (FOO=...). */
16249
16250 static ffesymbol
16251 ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t)
16252 {
16253 ffesymbolAttrs sa;
16254
16255 sa = ffesymbol_attrs (s);
16256
16257 /* Figure out what kind of object we've got based on previous declarations
16258 of or references to the object. */
16259
16260 if (sa & ~(FFESYMBOL_attrsANYLEN
16261 | FFESYMBOL_attrsTYPE))
16262 {
16263 if (!(sa & FFESYMBOL_attrsANY))
16264 ffesymbol_error (s, t);
16265 }
16266 else
16267 {
16268 ffesymbol_signal_change (s); /* May need to back up to previous
16269 version. */
16270 if (!ffeimplic_establish_symbol (s))
16271 {
16272 ffesymbol_error (s, t);
16273 return s;
16274 }
16275 ffesymbol_set_info (s,
16276 ffeinfo_new (ffesymbol_basictype (s),
16277 ffesymbol_kindtype (s),
16278 ffesymbol_rank (s),
16279 FFEINFO_kindENTITY,
16280 FFEINFO_whereCONSTANT,
16281 ffesymbol_size (s)));
16282 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16283 ffesymbol_resolve_intrin (s);
16284 s = ffecom_sym_learned (s);
16285 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16286 }
16287
16288 return s;
16289 }
16290
16291 /* Have FOO in CALL XYZ(...,FOO,...). Does not include any other
16292 embedding of FOO, such as CALL XYZ((FOO)) or CALL XYZ(FOO+1). */
16293
16294 static ffesymbol
16295 ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t)
16296 {
16297 ffesymbolAttrs sa;
16298 ffesymbolAttrs na;
16299 ffeinfoKind kind;
16300 ffeinfoWhere where;
16301 ffesymbolState ns;
16302 bool needs_type = FALSE;
16303
16304 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16305 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16306
16307 na = sa = ffesymbol_attrs (s);
16308
16309 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16310 | FFESYMBOL_attrsADJUSTABLE
16311 | FFESYMBOL_attrsANYLEN
16312 | FFESYMBOL_attrsARRAY
16313 | FFESYMBOL_attrsDUMMY
16314 | FFESYMBOL_attrsEXTERNAL
16315 | FFESYMBOL_attrsSFARG
16316 | FFESYMBOL_attrsTYPE)));
16317
16318 kind = ffesymbol_kind (s);
16319 where = ffesymbol_where (s);
16320
16321 /* Figure out what kind of object we've got based on previous declarations
16322 of or references to the object. */
16323
16324 ns = FFESYMBOL_stateUNDERSTOOD;
16325
16326 if (sa & FFESYMBOL_attrsEXTERNAL)
16327 {
16328 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16329 | FFESYMBOL_attrsDUMMY
16330 | FFESYMBOL_attrsEXTERNAL
16331 | FFESYMBOL_attrsTYPE)));
16332
16333 if (sa & FFESYMBOL_attrsTYPE)
16334 where = FFEINFO_whereGLOBAL;
16335 else
16336 /* Not TYPE. */
16337 {
16338 ns = FFESYMBOL_stateUNCERTAIN;
16339
16340 if (sa & FFESYMBOL_attrsDUMMY)
16341 assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */
16342 else if (sa & FFESYMBOL_attrsACTUALARG)
16343 ; /* Not DUMMY or TYPE. */
16344 else
16345 /* Not ACTUALARG, DUMMY, or TYPE. */
16346 {
16347 assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */
16348 na |= FFESYMBOL_attrsACTUALARG;
16349 where = FFEINFO_whereGLOBAL;
16350 }
16351 }
16352 }
16353 else if (sa & FFESYMBOL_attrsDUMMY)
16354 {
16355 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16356 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16357 | FFESYMBOL_attrsEXTERNAL
16358 | FFESYMBOL_attrsTYPE)));
16359
16360 kind = FFEINFO_kindENTITY;
16361 if (!(sa & FFESYMBOL_attrsTYPE))
16362 needs_type = TRUE;
16363 }
16364 else if (sa & FFESYMBOL_attrsARRAY)
16365 {
16366 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16367 | FFESYMBOL_attrsADJUSTABLE
16368 | FFESYMBOL_attrsTYPE)));
16369
16370 where = FFEINFO_whereLOCAL;
16371 }
16372 else if (sa & FFESYMBOL_attrsSFARG)
16373 {
16374 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16375 | FFESYMBOL_attrsTYPE)));
16376
16377 where = FFEINFO_whereLOCAL;
16378 }
16379 else if (sa & FFESYMBOL_attrsTYPE)
16380 {
16381 assert (!(sa & (FFESYMBOL_attrsARRAY
16382 | FFESYMBOL_attrsDUMMY
16383 | FFESYMBOL_attrsEXTERNAL
16384 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16385 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16386 | FFESYMBOL_attrsADJUSTABLE
16387 | FFESYMBOL_attrsANYLEN
16388 | FFESYMBOL_attrsARRAY
16389 | FFESYMBOL_attrsDUMMY
16390 | FFESYMBOL_attrsEXTERNAL
16391 | FFESYMBOL_attrsSFARG)));
16392
16393 if (sa & FFESYMBOL_attrsANYLEN)
16394 ns = FFESYMBOL_stateNONE;
16395 else
16396 {
16397 kind = FFEINFO_kindENTITY;
16398 where = FFEINFO_whereLOCAL;
16399 }
16400 }
16401 else if (sa == FFESYMBOL_attrsetNONE)
16402 {
16403 /* New state is left empty because there isn't any state flag to
16404 set for this case, and it's UNDERSTOOD after all. */
16405 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16406 kind = FFEINFO_kindENTITY;
16407 where = FFEINFO_whereLOCAL;
16408 needs_type = TRUE;
16409 }
16410 else
16411 ns = FFESYMBOL_stateNONE; /* Error. */
16412
16413 /* Now see what we've got for a new object: NONE means a new error cropped
16414 up; ANY means an old error to be ignored; otherwise, everything's ok,
16415 update the object (symbol) and continue on. */
16416
16417 if (ns == FFESYMBOL_stateNONE)
16418 ffesymbol_error (s, t);
16419 else if (!(na & FFESYMBOL_attrsANY))
16420 {
16421 ffesymbol_signal_change (s); /* May need to back up to previous
16422 version. */
16423 if (needs_type && !ffeimplic_establish_symbol (s))
16424 {
16425 ffesymbol_error (s, t);
16426 return s;
16427 }
16428 ffesymbol_set_info (s,
16429 ffeinfo_new (ffesymbol_basictype (s),
16430 ffesymbol_kindtype (s),
16431 ffesymbol_rank (s),
16432 kind,
16433 where,
16434 ffesymbol_size (s)));
16435 ffesymbol_set_attrs (s, na);
16436 ffesymbol_set_state (s, ns);
16437 s = ffecom_sym_learned (s);
16438 ffesymbol_reference (s, t, FALSE);
16439 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16440 }
16441
16442 return s;
16443 }
16444
16445 /* Have FOO in DIMENSION XYZ(FOO) or any array declarator containing
16446 a reference to FOO. */
16447
16448 static ffesymbol
16449 ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t)
16450 {
16451 ffesymbolAttrs sa;
16452 ffesymbolAttrs na;
16453 ffeinfoKind kind;
16454 ffeinfoWhere where;
16455
16456 na = sa = ffesymbol_attrs (s);
16457 kind = FFEINFO_kindENTITY;
16458 where = ffesymbol_where (s);
16459
16460 /* Figure out what kind of object we've got based on previous declarations
16461 of or references to the object. */
16462
16463 if (!(sa & ~(FFESYMBOL_attrsADJUSTS
16464 | FFESYMBOL_attrsCOMMON
16465 | FFESYMBOL_attrsDUMMY
16466 | FFESYMBOL_attrsEQUIV
16467 | FFESYMBOL_attrsINIT
16468 | FFESYMBOL_attrsNAMELIST
16469 | FFESYMBOL_attrsSFARG
16470 | FFESYMBOL_attrsARRAY
16471 | FFESYMBOL_attrsTYPE)))
16472 na = sa | FFESYMBOL_attrsADJUSTS;
16473 else
16474 na = FFESYMBOL_attrsetNONE;
16475
16476 /* Since this symbol definitely is going into an expression (the
16477 dimension-list for some dummy array, presumably), figure out WHERE if
16478 possible. */
16479
16480 if (where == FFEINFO_whereNONE)
16481 {
16482 if (na & (FFESYMBOL_attrsCOMMON
16483 | FFESYMBOL_attrsEQUIV
16484 | FFESYMBOL_attrsINIT
16485 | FFESYMBOL_attrsNAMELIST))
16486 where = FFEINFO_whereCOMMON;
16487 else if (na & FFESYMBOL_attrsDUMMY)
16488 where = FFEINFO_whereDUMMY;
16489 }
16490
16491 /* Now see what we've got for a new object: NONE means a new error cropped
16492 up; ANY means an old error to be ignored; otherwise, everything's ok,
16493 update the object (symbol) and continue on. */
16494
16495 if (na == FFESYMBOL_attrsetNONE)
16496 ffesymbol_error (s, t);
16497 else if (!(na & FFESYMBOL_attrsANY))
16498 {
16499 ffesymbol_signal_change (s); /* May need to back up to previous
16500 version. */
16501 if (!ffeimplic_establish_symbol (s))
16502 {
16503 ffesymbol_error (s, t);
16504 return s;
16505 }
16506 ffesymbol_set_info (s,
16507 ffeinfo_new (ffesymbol_basictype (s),
16508 ffesymbol_kindtype (s),
16509 ffesymbol_rank (s),
16510 kind, /* Always ENTITY. */
16511 where, /* NONE, COMMON, or DUMMY. */
16512 ffesymbol_size (s)));
16513 ffesymbol_set_attrs (s, na);
16514 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
16515 ffesymbol_resolve_intrin (s);
16516 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16517 }
16518
16519 return s;
16520 }
16521
16522 /* Have FOO in XYZ = ...FOO.... Does not include cases like FOO in
16523 XYZ = BAR(FOO), as such cases are handled elsewhere. */
16524
16525 static ffesymbol
16526 ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t)
16527 {
16528 ffesymbolAttrs sa;
16529 ffesymbolAttrs na;
16530 ffeinfoKind kind;
16531 ffeinfoWhere where;
16532 bool error = FALSE;
16533
16534 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16535 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16536
16537 na = sa = ffesymbol_attrs (s);
16538
16539 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16540 | FFESYMBOL_attrsADJUSTABLE
16541 | FFESYMBOL_attrsANYLEN
16542 | FFESYMBOL_attrsARRAY
16543 | FFESYMBOL_attrsDUMMY
16544 | FFESYMBOL_attrsEXTERNAL
16545 | FFESYMBOL_attrsSFARG
16546 | FFESYMBOL_attrsTYPE)));
16547
16548 kind = ffesymbol_kind (s);
16549 where = ffesymbol_where (s);
16550
16551 /* Figure out what kind of object we've got based on previous declarations
16552 of or references to the object. */
16553
16554 if (sa & FFESYMBOL_attrsEXTERNAL)
16555 {
16556 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16557 | FFESYMBOL_attrsDUMMY
16558 | FFESYMBOL_attrsEXTERNAL
16559 | FFESYMBOL_attrsTYPE)));
16560
16561 error = TRUE;
16562 }
16563 else if (sa & FFESYMBOL_attrsDUMMY)
16564 {
16565 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16566 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16567 | FFESYMBOL_attrsEXTERNAL
16568 | FFESYMBOL_attrsTYPE)));
16569
16570 kind = FFEINFO_kindENTITY;
16571 }
16572 else if (sa & FFESYMBOL_attrsARRAY)
16573 {
16574 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16575 | FFESYMBOL_attrsADJUSTABLE
16576 | FFESYMBOL_attrsTYPE)));
16577
16578 where = FFEINFO_whereLOCAL;
16579 }
16580 else if (sa & FFESYMBOL_attrsSFARG)
16581 {
16582 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16583 | FFESYMBOL_attrsTYPE)));
16584
16585 where = FFEINFO_whereLOCAL;
16586 }
16587 else if (sa & FFESYMBOL_attrsTYPE)
16588 {
16589 assert (!(sa & (FFESYMBOL_attrsARRAY
16590 | FFESYMBOL_attrsDUMMY
16591 | FFESYMBOL_attrsEXTERNAL
16592 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16593 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16594 | FFESYMBOL_attrsADJUSTABLE
16595 | FFESYMBOL_attrsANYLEN
16596 | FFESYMBOL_attrsARRAY
16597 | FFESYMBOL_attrsDUMMY
16598 | FFESYMBOL_attrsEXTERNAL
16599 | FFESYMBOL_attrsSFARG)));
16600
16601 if (sa & FFESYMBOL_attrsANYLEN)
16602 error = TRUE;
16603 else
16604 {
16605 kind = FFEINFO_kindENTITY;
16606 where = FFEINFO_whereLOCAL;
16607 }
16608 }
16609 else if (sa == FFESYMBOL_attrsetNONE)
16610 {
16611 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16612 kind = FFEINFO_kindENTITY;
16613 where = FFEINFO_whereLOCAL;
16614 }
16615 else
16616 error = TRUE;
16617
16618 /* Now see what we've got for a new object: NONE means a new error cropped
16619 up; ANY means an old error to be ignored; otherwise, everything's ok,
16620 update the object (symbol) and continue on. */
16621
16622 if (error)
16623 ffesymbol_error (s, t);
16624 else if (!(na & FFESYMBOL_attrsANY))
16625 {
16626 ffesymbol_signal_change (s); /* May need to back up to previous
16627 version. */
16628 if (!ffeimplic_establish_symbol (s))
16629 {
16630 ffesymbol_error (s, t);
16631 return s;
16632 }
16633 ffesymbol_set_info (s,
16634 ffeinfo_new (ffesymbol_basictype (s),
16635 ffesymbol_kindtype (s),
16636 ffesymbol_rank (s),
16637 kind, /* ENTITY. */
16638 where, /* LOCAL. */
16639 ffesymbol_size (s)));
16640 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16641 ffesymbol_resolve_intrin (s);
16642 s = ffecom_sym_learned (s);
16643 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16644 }
16645
16646 return s;
16647 }
16648
16649 /* ffeexpr_declare_parenthesized_ -- ffesymbol wrapper for NAME(...) operand
16650
16651 ffelexToken t;
16652 bool maybe_intrin;
16653 ffeexprParenType_ paren_type;
16654 ffesymbol s;
16655 s = ffeexpr_declare_parenthesized_ (t, maybe_intrin, &paren_type);
16656
16657 Just like ffesymbol_declare_local, except performs any implicit info
16658 assignment necessary, and it returns the type of the parenthesized list
16659 (list of function args, list of array args, or substring spec). */
16660
16661 static ffesymbol
16662 ffeexpr_declare_parenthesized_ (ffelexToken t, bool maybe_intrin,
16663 ffeexprParenType_ *paren_type)
16664 {
16665 ffesymbol s;
16666 ffesymbolState st; /* Effective state. */
16667 ffeinfoKind k;
16668 bool bad;
16669
16670 if (maybe_intrin && ffesrc_check_symbol ())
16671 { /* Knock off some easy cases. */
16672 switch (ffeexpr_stack_->context)
16673 {
16674 case FFEEXPR_contextSUBROUTINEREF:
16675 case FFEEXPR_contextDATA:
16676 case FFEEXPR_contextDATAIMPDOINDEX_:
16677 case FFEEXPR_contextSFUNCDEF:
16678 case FFEEXPR_contextSFUNCDEFINDEX_:
16679 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16680 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16681 case FFEEXPR_contextLET:
16682 case FFEEXPR_contextPAREN_:
16683 case FFEEXPR_contextACTUALARGEXPR_:
16684 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16685 case FFEEXPR_contextIOLIST:
16686 case FFEEXPR_contextIOLISTDF:
16687 case FFEEXPR_contextDO:
16688 case FFEEXPR_contextDOWHILE:
16689 case FFEEXPR_contextACTUALARG_:
16690 case FFEEXPR_contextCGOTO:
16691 case FFEEXPR_contextIF:
16692 case FFEEXPR_contextARITHIF:
16693 case FFEEXPR_contextFORMAT:
16694 case FFEEXPR_contextSTOP:
16695 case FFEEXPR_contextRETURN:
16696 case FFEEXPR_contextSELECTCASE:
16697 case FFEEXPR_contextCASE:
16698 case FFEEXPR_contextFILEASSOC:
16699 case FFEEXPR_contextFILEINT:
16700 case FFEEXPR_contextFILEDFINT:
16701 case FFEEXPR_contextFILELOG:
16702 case FFEEXPR_contextFILENUM:
16703 case FFEEXPR_contextFILENUMAMBIG:
16704 case FFEEXPR_contextFILECHAR:
16705 case FFEEXPR_contextFILENUMCHAR:
16706 case FFEEXPR_contextFILEDFCHAR:
16707 case FFEEXPR_contextFILEKEY:
16708 case FFEEXPR_contextFILEUNIT:
16709 case FFEEXPR_contextFILEUNIT_DF:
16710 case FFEEXPR_contextFILEUNITAMBIG:
16711 case FFEEXPR_contextFILEFORMAT:
16712 case FFEEXPR_contextFILENAMELIST:
16713 case FFEEXPR_contextFILEVXTCODE:
16714 case FFEEXPR_contextINDEX_:
16715 case FFEEXPR_contextIMPDOITEM_:
16716 case FFEEXPR_contextIMPDOITEMDF_:
16717 case FFEEXPR_contextIMPDOCTRL_:
16718 case FFEEXPR_contextDATAIMPDOCTRL_:
16719 case FFEEXPR_contextCHARACTERSIZE:
16720 case FFEEXPR_contextPARAMETER:
16721 case FFEEXPR_contextDIMLIST:
16722 case FFEEXPR_contextDIMLISTCOMMON:
16723 case FFEEXPR_contextKINDTYPE:
16724 case FFEEXPR_contextINITVAL:
16725 case FFEEXPR_contextEQVINDEX_:
16726 break; /* These could be intrinsic invocations. */
16727
16728 case FFEEXPR_contextAGOTO:
16729 case FFEEXPR_contextFILEFORMATNML:
16730 case FFEEXPR_contextALLOCATE:
16731 case FFEEXPR_contextDEALLOCATE:
16732 case FFEEXPR_contextHEAPSTAT:
16733 case FFEEXPR_contextNULLIFY:
16734 case FFEEXPR_contextINCLUDE:
16735 case FFEEXPR_contextDATAIMPDOITEM_:
16736 case FFEEXPR_contextLOC_:
16737 case FFEEXPR_contextINDEXORACTUALARG_:
16738 case FFEEXPR_contextSFUNCDEFACTUALARG_:
16739 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
16740 case FFEEXPR_contextPARENFILENUM_:
16741 case FFEEXPR_contextPARENFILEUNIT_:
16742 maybe_intrin = FALSE;
16743 break; /* Can't be intrinsic invocation. */
16744
16745 default:
16746 assert ("blah! blah! waaauuggh!" == NULL);
16747 break;
16748 }
16749 }
16750
16751 s = ffesymbol_declare_local (t, maybe_intrin);
16752
16753 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16754 /* Special-case these since they can involve a different concept
16755 of "state" (in the stmtfunc name space). */
16756 {
16757 case FFEEXPR_contextDATAIMPDOINDEX_:
16758 case FFEEXPR_contextDATAIMPDOCTRL_:
16759 if (ffeexpr_context_outer_ (ffeexpr_stack_)
16760 == FFEEXPR_contextDATAIMPDOINDEX_)
16761 s = ffeexpr_sym_impdoitem_ (s, t);
16762 else
16763 if (ffeexpr_stack_->is_rhs)
16764 s = ffeexpr_sym_impdoitem_ (s, t);
16765 else
16766 s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
16767 if (ffesymbol_kind (s) != FFEINFO_kindANY)
16768 ffesymbol_error (s, t);
16769 return s;
16770
16771 default:
16772 break;
16773 }
16774
16775 switch ((ffesymbol_sfdummyparent (s) == NULL)
16776 ? ffesymbol_state (s)
16777 : FFESYMBOL_stateUNDERSTOOD)
16778 {
16779 case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr
16780 context. */
16781 if (!ffest_seen_first_exec ())
16782 goto seen; /* :::::::::::::::::::: */
16783 /* Fall through. */
16784 case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */
16785 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16786 {
16787 case FFEEXPR_contextSUBROUTINEREF:
16788 s = ffeexpr_sym_lhs_call_ (s, t); /* "CALL FOO"=="CALL
16789 FOO(...)". */
16790 break;
16791
16792 case FFEEXPR_contextDATA:
16793 if (ffeexpr_stack_->is_rhs)
16794 s = ffeexpr_sym_rhs_let_ (s, t);
16795 else
16796 s = ffeexpr_sym_lhs_data_ (s, t);
16797 break;
16798
16799 case FFEEXPR_contextDATAIMPDOITEM_:
16800 s = ffeexpr_sym_lhs_data_ (s, t);
16801 break;
16802
16803 case FFEEXPR_contextSFUNCDEF:
16804 case FFEEXPR_contextSFUNCDEFINDEX_:
16805 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16806 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16807 s = ffecom_sym_exec_transition (s);
16808 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16809 goto understood; /* :::::::::::::::::::: */
16810 /* Fall through. */
16811 case FFEEXPR_contextLET:
16812 case FFEEXPR_contextPAREN_:
16813 case FFEEXPR_contextACTUALARGEXPR_:
16814 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16815 case FFEEXPR_contextIOLIST:
16816 case FFEEXPR_contextIOLISTDF:
16817 case FFEEXPR_contextDO:
16818 case FFEEXPR_contextDOWHILE:
16819 case FFEEXPR_contextACTUALARG_:
16820 case FFEEXPR_contextCGOTO:
16821 case FFEEXPR_contextIF:
16822 case FFEEXPR_contextARITHIF:
16823 case FFEEXPR_contextFORMAT:
16824 case FFEEXPR_contextSTOP:
16825 case FFEEXPR_contextRETURN:
16826 case FFEEXPR_contextSELECTCASE:
16827 case FFEEXPR_contextCASE:
16828 case FFEEXPR_contextFILEASSOC:
16829 case FFEEXPR_contextFILEINT:
16830 case FFEEXPR_contextFILEDFINT:
16831 case FFEEXPR_contextFILELOG:
16832 case FFEEXPR_contextFILENUM:
16833 case FFEEXPR_contextFILENUMAMBIG:
16834 case FFEEXPR_contextFILECHAR:
16835 case FFEEXPR_contextFILENUMCHAR:
16836 case FFEEXPR_contextFILEDFCHAR:
16837 case FFEEXPR_contextFILEKEY:
16838 case FFEEXPR_contextFILEUNIT:
16839 case FFEEXPR_contextFILEUNIT_DF:
16840 case FFEEXPR_contextFILEUNITAMBIG:
16841 case FFEEXPR_contextFILEFORMAT:
16842 case FFEEXPR_contextFILENAMELIST:
16843 case FFEEXPR_contextFILEVXTCODE:
16844 case FFEEXPR_contextINDEX_:
16845 case FFEEXPR_contextIMPDOITEM_:
16846 case FFEEXPR_contextIMPDOITEMDF_:
16847 case FFEEXPR_contextIMPDOCTRL_:
16848 case FFEEXPR_contextLOC_:
16849 if (ffeexpr_stack_->is_rhs)
16850 s = ffeexpr_paren_rhs_let_ (s, t);
16851 else
16852 s = ffeexpr_paren_lhs_let_ (s, t);
16853 break;
16854
16855 case FFEEXPR_contextASSIGN:
16856 case FFEEXPR_contextAGOTO:
16857 case FFEEXPR_contextCHARACTERSIZE:
16858 case FFEEXPR_contextEQUIVALENCE:
16859 case FFEEXPR_contextINCLUDE:
16860 case FFEEXPR_contextPARAMETER:
16861 case FFEEXPR_contextDIMLIST:
16862 case FFEEXPR_contextDIMLISTCOMMON:
16863 case FFEEXPR_contextKINDTYPE:
16864 case FFEEXPR_contextINITVAL:
16865 case FFEEXPR_contextEQVINDEX_:
16866 break; /* Will turn into errors below. */
16867
16868 default:
16869 ffesymbol_error (s, t);
16870 break;
16871 }
16872 /* Fall through. */
16873 case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */
16874 understood: /* :::::::::::::::::::: */
16875
16876 /* State might have changed, update it. */
16877 st = ((ffesymbol_sfdummyparent (s) == NULL)
16878 ? ffesymbol_state (s)
16879 : FFESYMBOL_stateUNDERSTOOD);
16880
16881 k = ffesymbol_kind (s);
16882 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16883 {
16884 case FFEEXPR_contextSUBROUTINEREF:
16885 bad = ((k != FFEINFO_kindSUBROUTINE)
16886 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
16887 || (k != FFEINFO_kindNONE)));
16888 break;
16889
16890 case FFEEXPR_contextDATA:
16891 if (ffeexpr_stack_->is_rhs)
16892 bad = (k != FFEINFO_kindENTITY)
16893 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16894 else
16895 bad = (k != FFEINFO_kindENTITY)
16896 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
16897 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
16898 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
16899 break;
16900
16901 case FFEEXPR_contextDATAIMPDOITEM_:
16902 bad = (k != FFEINFO_kindENTITY) || (ffesymbol_rank (s) == 0)
16903 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
16904 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
16905 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
16906 break;
16907
16908 case FFEEXPR_contextSFUNCDEF:
16909 case FFEEXPR_contextSFUNCDEFINDEX_:
16910 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16911 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16912 case FFEEXPR_contextLET:
16913 case FFEEXPR_contextPAREN_:
16914 case FFEEXPR_contextACTUALARGEXPR_:
16915 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16916 case FFEEXPR_contextIOLIST:
16917 case FFEEXPR_contextIOLISTDF:
16918 case FFEEXPR_contextDO:
16919 case FFEEXPR_contextDOWHILE:
16920 case FFEEXPR_contextACTUALARG_:
16921 case FFEEXPR_contextCGOTO:
16922 case FFEEXPR_contextIF:
16923 case FFEEXPR_contextARITHIF:
16924 case FFEEXPR_contextFORMAT:
16925 case FFEEXPR_contextSTOP:
16926 case FFEEXPR_contextRETURN:
16927 case FFEEXPR_contextSELECTCASE:
16928 case FFEEXPR_contextCASE:
16929 case FFEEXPR_contextFILEASSOC:
16930 case FFEEXPR_contextFILEINT:
16931 case FFEEXPR_contextFILEDFINT:
16932 case FFEEXPR_contextFILELOG:
16933 case FFEEXPR_contextFILENUM:
16934 case FFEEXPR_contextFILENUMAMBIG:
16935 case FFEEXPR_contextFILECHAR:
16936 case FFEEXPR_contextFILENUMCHAR:
16937 case FFEEXPR_contextFILEDFCHAR:
16938 case FFEEXPR_contextFILEKEY:
16939 case FFEEXPR_contextFILEUNIT:
16940 case FFEEXPR_contextFILEUNIT_DF:
16941 case FFEEXPR_contextFILEUNITAMBIG:
16942 case FFEEXPR_contextFILEFORMAT:
16943 case FFEEXPR_contextFILENAMELIST:
16944 case FFEEXPR_contextFILEVXTCODE:
16945 case FFEEXPR_contextINDEX_:
16946 case FFEEXPR_contextIMPDOITEM_:
16947 case FFEEXPR_contextIMPDOITEMDF_:
16948 case FFEEXPR_contextIMPDOCTRL_:
16949 case FFEEXPR_contextLOC_:
16950 bad = FALSE; /* Let paren-switch handle the cases. */
16951 break;
16952
16953 case FFEEXPR_contextASSIGN:
16954 case FFEEXPR_contextAGOTO:
16955 case FFEEXPR_contextCHARACTERSIZE:
16956 case FFEEXPR_contextEQUIVALENCE:
16957 case FFEEXPR_contextPARAMETER:
16958 case FFEEXPR_contextDIMLIST:
16959 case FFEEXPR_contextDIMLISTCOMMON:
16960 case FFEEXPR_contextKINDTYPE:
16961 case FFEEXPR_contextINITVAL:
16962 case FFEEXPR_contextEQVINDEX_:
16963 bad = (k != FFEINFO_kindENTITY)
16964 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16965 break;
16966
16967 case FFEEXPR_contextINCLUDE:
16968 bad = TRUE;
16969 break;
16970
16971 default:
16972 bad = TRUE;
16973 break;
16974 }
16975
16976 switch (bad ? FFEINFO_kindANY : k)
16977 {
16978 case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */
16979 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
16980 {
16981 if (ffeexpr_context_outer_ (ffeexpr_stack_)
16982 == FFEEXPR_contextSUBROUTINEREF)
16983 *paren_type = FFEEXPR_parentypeSUBROUTINE_;
16984 else
16985 *paren_type = FFEEXPR_parentypeFUNCTION_;
16986 break;
16987 }
16988 if (st == FFESYMBOL_stateUNDERSTOOD)
16989 {
16990 bad = TRUE;
16991 *paren_type = FFEEXPR_parentypeANY_;
16992 }
16993 else
16994 *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
16995 break;
16996
16997 case FFEINFO_kindFUNCTION:
16998 *paren_type = FFEEXPR_parentypeFUNCTION_;
16999 switch (ffesymbol_where (s))
17000 {
17001 case FFEINFO_whereLOCAL:
17002 bad = TRUE; /* Attempt to recurse! */
17003 break;
17004
17005 case FFEINFO_whereCONSTANT:
17006 bad = ((ffesymbol_sfexpr (s) == NULL)
17007 || (ffebld_op (ffesymbol_sfexpr (s))
17008 == FFEBLD_opANY)); /* Attempt to recurse! */
17009 break;
17010
17011 default:
17012 break;
17013 }
17014 break;
17015
17016 case FFEINFO_kindSUBROUTINE:
17017 if ((ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
17018 || (ffeexpr_stack_->previous != NULL))
17019 {
17020 bad = TRUE;
17021 *paren_type = FFEEXPR_parentypeANY_;
17022 break;
17023 }
17024
17025 *paren_type = FFEEXPR_parentypeSUBROUTINE_;
17026 switch (ffesymbol_where (s))
17027 {
17028 case FFEINFO_whereLOCAL:
17029 case FFEINFO_whereCONSTANT:
17030 bad = TRUE; /* Attempt to recurse! */
17031 break;
17032
17033 default:
17034 break;
17035 }
17036 break;
17037
17038 case FFEINFO_kindENTITY:
17039 if (ffesymbol_rank (s) == 0)
17040 {
17041 if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
17042 *paren_type = FFEEXPR_parentypeSUBSTRING_;
17043 else
17044 {
17045 bad = TRUE;
17046 *paren_type = FFEEXPR_parentypeANY_;
17047 }
17048 }
17049 else
17050 *paren_type = FFEEXPR_parentypeARRAY_;
17051 break;
17052
17053 default:
17054 case FFEINFO_kindANY:
17055 bad = TRUE;
17056 *paren_type = FFEEXPR_parentypeANY_;
17057 break;
17058 }
17059
17060 if (bad)
17061 {
17062 if (k == FFEINFO_kindANY)
17063 ffest_shutdown ();
17064 else
17065 ffesymbol_error (s, t);
17066 }
17067
17068 return s;
17069
17070 case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */
17071 seen: /* :::::::::::::::::::: */
17072 bad = TRUE;
17073 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17074 {
17075 case FFEEXPR_contextPARAMETER:
17076 if (ffeexpr_stack_->is_rhs)
17077 ffesymbol_error (s, t);
17078 else
17079 s = ffeexpr_sym_lhs_parameter_ (s, t);
17080 break;
17081
17082 case FFEEXPR_contextDATA:
17083 s = ffecom_sym_exec_transition (s);
17084 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17085 goto understood; /* :::::::::::::::::::: */
17086 if (ffeexpr_stack_->is_rhs)
17087 ffesymbol_error (s, t);
17088 else
17089 s = ffeexpr_sym_lhs_data_ (s, t);
17090 goto understood; /* :::::::::::::::::::: */
17091
17092 case FFEEXPR_contextDATAIMPDOITEM_:
17093 s = ffecom_sym_exec_transition (s);
17094 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17095 goto understood; /* :::::::::::::::::::: */
17096 s = ffeexpr_sym_lhs_data_ (s, t);
17097 goto understood; /* :::::::::::::::::::: */
17098
17099 case FFEEXPR_contextEQUIVALENCE:
17100 s = ffeexpr_sym_lhs_equivalence_ (s, t);
17101 bad = FALSE;
17102 break;
17103
17104 case FFEEXPR_contextDIMLIST:
17105 s = ffeexpr_sym_rhs_dimlist_ (s, t);
17106 bad = FALSE;
17107 break;
17108
17109 case FFEEXPR_contextCHARACTERSIZE:
17110 case FFEEXPR_contextKINDTYPE:
17111 case FFEEXPR_contextDIMLISTCOMMON:
17112 case FFEEXPR_contextINITVAL:
17113 case FFEEXPR_contextEQVINDEX_:
17114 break;
17115
17116 case FFEEXPR_contextINCLUDE:
17117 break;
17118
17119 case FFEEXPR_contextINDEX_:
17120 case FFEEXPR_contextACTUALARGEXPR_:
17121 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17122 case FFEEXPR_contextSFUNCDEF:
17123 case FFEEXPR_contextSFUNCDEFINDEX_:
17124 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17125 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17126 assert (ffeexpr_stack_->is_rhs);
17127 s = ffecom_sym_exec_transition (s);
17128 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17129 goto understood; /* :::::::::::::::::::: */
17130 s = ffeexpr_paren_rhs_let_ (s, t);
17131 goto understood; /* :::::::::::::::::::: */
17132
17133 default:
17134 break;
17135 }
17136 k = ffesymbol_kind (s);
17137 switch (bad ? FFEINFO_kindANY : k)
17138 {
17139 case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */
17140 *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
17141 break;
17142
17143 case FFEINFO_kindFUNCTION:
17144 *paren_type = FFEEXPR_parentypeFUNCTION_;
17145 switch (ffesymbol_where (s))
17146 {
17147 case FFEINFO_whereLOCAL:
17148 bad = TRUE; /* Attempt to recurse! */
17149 break;
17150
17151 case FFEINFO_whereCONSTANT:
17152 bad = ((ffesymbol_sfexpr (s) == NULL)
17153 || (ffebld_op (ffesymbol_sfexpr (s))
17154 == FFEBLD_opANY)); /* Attempt to recurse! */
17155 break;
17156
17157 default:
17158 break;
17159 }
17160 break;
17161
17162 case FFEINFO_kindSUBROUTINE:
17163 *paren_type = FFEEXPR_parentypeANY_;
17164 bad = TRUE; /* Cannot possibly be in
17165 contextSUBROUTINEREF. */
17166 break;
17167
17168 case FFEINFO_kindENTITY:
17169 if (ffesymbol_rank (s) == 0)
17170 {
17171 if (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE)
17172 *paren_type = FFEEXPR_parentypeEQUIVALENCE_;
17173 else if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
17174 *paren_type = FFEEXPR_parentypeSUBSTRING_;
17175 else
17176 {
17177 bad = TRUE;
17178 *paren_type = FFEEXPR_parentypeANY_;
17179 }
17180 }
17181 else
17182 *paren_type = FFEEXPR_parentypeARRAY_;
17183 break;
17184
17185 default:
17186 case FFEINFO_kindANY:
17187 bad = TRUE;
17188 *paren_type = FFEEXPR_parentypeANY_;
17189 break;
17190 }
17191
17192 if (bad)
17193 {
17194 if (k == FFEINFO_kindANY)
17195 ffest_shutdown ();
17196 else
17197 ffesymbol_error (s, t);
17198 }
17199
17200 return s;
17201
17202 default:
17203 assert ("bad symbol state" == NULL);
17204 return NULL;
17205 }
17206 }
17207
17208 /* Have FOO in XYZ = ...FOO(...).... Executable context only. */
17209
17210 static ffesymbol
17211 ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t)
17212 {
17213 ffesymbolAttrs sa;
17214 ffesymbolAttrs na;
17215 ffeinfoKind kind;
17216 ffeinfoWhere where;
17217 ffeintrinGen gen;
17218 ffeintrinSpec spec;
17219 ffeintrinImp imp;
17220 bool maybe_ambig = FALSE;
17221 bool error = FALSE;
17222
17223 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
17224 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
17225
17226 na = sa = ffesymbol_attrs (s);
17227
17228 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17229 | FFESYMBOL_attrsADJUSTABLE
17230 | FFESYMBOL_attrsANYLEN
17231 | FFESYMBOL_attrsARRAY
17232 | FFESYMBOL_attrsDUMMY
17233 | FFESYMBOL_attrsEXTERNAL
17234 | FFESYMBOL_attrsSFARG
17235 | FFESYMBOL_attrsTYPE)));
17236
17237 kind = ffesymbol_kind (s);
17238 where = ffesymbol_where (s);
17239
17240 /* Figure out what kind of object we've got based on previous declarations
17241 of or references to the object. */
17242
17243 if (sa & FFESYMBOL_attrsEXTERNAL)
17244 {
17245 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17246 | FFESYMBOL_attrsDUMMY
17247 | FFESYMBOL_attrsEXTERNAL
17248 | FFESYMBOL_attrsTYPE)));
17249
17250 if (sa & FFESYMBOL_attrsTYPE)
17251 where = FFEINFO_whereGLOBAL;
17252 else
17253 /* Not TYPE. */
17254 {
17255 kind = FFEINFO_kindFUNCTION;
17256
17257 if (sa & FFESYMBOL_attrsDUMMY)
17258 ; /* Not TYPE. */
17259 else if (sa & FFESYMBOL_attrsACTUALARG)
17260 ; /* Not DUMMY or TYPE. */
17261 else /* Not ACTUALARG, DUMMY, or TYPE. */
17262 where = FFEINFO_whereGLOBAL;
17263 }
17264 }
17265 else if (sa & FFESYMBOL_attrsDUMMY)
17266 {
17267 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
17268 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
17269 | FFESYMBOL_attrsEXTERNAL
17270 | FFESYMBOL_attrsTYPE)));
17271
17272 kind = FFEINFO_kindFUNCTION;
17273 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure; kind
17274 could be ENTITY w/substring ref. */
17275 }
17276 else if (sa & FFESYMBOL_attrsARRAY)
17277 {
17278 assert (!(sa & ~(FFESYMBOL_attrsARRAY
17279 | FFESYMBOL_attrsADJUSTABLE
17280 | FFESYMBOL_attrsTYPE)));
17281
17282 where = FFEINFO_whereLOCAL;
17283 }
17284 else if (sa & FFESYMBOL_attrsSFARG)
17285 {
17286 assert (!(sa & ~(FFESYMBOL_attrsSFARG
17287 | FFESYMBOL_attrsTYPE)));
17288
17289 where = FFEINFO_whereLOCAL; /* Actually an error, but at least we
17290 know it's a local var. */
17291 }
17292 else if (sa & FFESYMBOL_attrsTYPE)
17293 {
17294 assert (!(sa & (FFESYMBOL_attrsARRAY
17295 | FFESYMBOL_attrsDUMMY
17296 | FFESYMBOL_attrsEXTERNAL
17297 | FFESYMBOL_attrsSFARG))); /* Handled above. */
17298 assert (!(sa & ~(FFESYMBOL_attrsTYPE
17299 | FFESYMBOL_attrsADJUSTABLE
17300 | FFESYMBOL_attrsANYLEN
17301 | FFESYMBOL_attrsARRAY
17302 | FFESYMBOL_attrsDUMMY
17303 | FFESYMBOL_attrsEXTERNAL
17304 | FFESYMBOL_attrsSFARG)));
17305
17306 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
17307 &gen, &spec, &imp))
17308 {
17309 if (!(sa & FFESYMBOL_attrsANYLEN)
17310 && (ffeimplic_peek_symbol_type (s, NULL)
17311 == FFEINFO_basictypeCHARACTER))
17312 return s; /* Haven't learned anything yet. */
17313
17314 ffesymbol_signal_change (s); /* May need to back up to previous
17315 version. */
17316 ffesymbol_set_generic (s, gen);
17317 ffesymbol_set_specific (s, spec);
17318 ffesymbol_set_implementation (s, imp);
17319 ffesymbol_set_info (s,
17320 ffeinfo_new (ffesymbol_basictype (s),
17321 ffesymbol_kindtype (s),
17322 0,
17323 FFEINFO_kindFUNCTION,
17324 FFEINFO_whereINTRINSIC,
17325 ffesymbol_size (s)));
17326 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17327 ffesymbol_resolve_intrin (s);
17328 ffesymbol_reference (s, t, FALSE);
17329 s = ffecom_sym_learned (s);
17330 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17331
17332 return s;
17333 }
17334 if (sa & FFESYMBOL_attrsANYLEN)
17335 error = TRUE; /* Error, since the only way we can,
17336 given CHARACTER*(*) FOO, accept
17337 FOO(...) is for FOO to be a dummy
17338 arg or constant, but it can't
17339 become either now. */
17340 else if (sa & FFESYMBOL_attrsADJUSTABLE)
17341 {
17342 kind = FFEINFO_kindENTITY;
17343 where = FFEINFO_whereLOCAL;
17344 }
17345 else
17346 {
17347 kind = FFEINFO_kindFUNCTION;
17348 where = FFEINFO_whereGLOBAL;
17349 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure;
17350 could be ENTITY/LOCAL w/substring ref. */
17351 }
17352 }
17353 else if (sa == FFESYMBOL_attrsetNONE)
17354 {
17355 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
17356
17357 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
17358 &gen, &spec, &imp))
17359 {
17360 if (ffeimplic_peek_symbol_type (s, NULL)
17361 == FFEINFO_basictypeCHARACTER)
17362 return s; /* Haven't learned anything yet. */
17363
17364 ffesymbol_signal_change (s); /* May need to back up to previous
17365 version. */
17366 ffesymbol_set_generic (s, gen);
17367 ffesymbol_set_specific (s, spec);
17368 ffesymbol_set_implementation (s, imp);
17369 ffesymbol_set_info (s,
17370 ffeinfo_new (ffesymbol_basictype (s),
17371 ffesymbol_kindtype (s),
17372 0,
17373 FFEINFO_kindFUNCTION,
17374 FFEINFO_whereINTRINSIC,
17375 ffesymbol_size (s)));
17376 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17377 ffesymbol_resolve_intrin (s);
17378 s = ffecom_sym_learned (s);
17379 ffesymbol_reference (s, t, FALSE);
17380 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17381 return s;
17382 }
17383
17384 kind = FFEINFO_kindFUNCTION;
17385 where = FFEINFO_whereGLOBAL;
17386 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure;
17387 could be ENTITY/LOCAL w/substring ref. */
17388 }
17389 else
17390 error = TRUE;
17391
17392 /* Now see what we've got for a new object: NONE means a new error cropped
17393 up; ANY means an old error to be ignored; otherwise, everything's ok,
17394 update the object (symbol) and continue on. */
17395
17396 if (error)
17397 ffesymbol_error (s, t);
17398 else if (!(na & FFESYMBOL_attrsANY))
17399 {
17400 ffesymbol_signal_change (s); /* May need to back up to previous
17401 version. */
17402 if (!ffeimplic_establish_symbol (s))
17403 {
17404 ffesymbol_error (s, t);
17405 return s;
17406 }
17407 if (maybe_ambig
17408 && (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
17409 return s; /* Still not sure, let caller deal with it
17410 based on (...). */
17411
17412 ffesymbol_set_info (s,
17413 ffeinfo_new (ffesymbol_basictype (s),
17414 ffesymbol_kindtype (s),
17415 ffesymbol_rank (s),
17416 kind,
17417 where,
17418 ffesymbol_size (s)));
17419 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17420 ffesymbol_resolve_intrin (s);
17421 s = ffecom_sym_learned (s);
17422 ffesymbol_reference (s, t, FALSE);
17423 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17424 }
17425
17426 return s;
17427 }
17428
17429 /* ffeexpr_token_arguments_ -- OPEN_PAREN [expr COMMA]...expr
17430
17431 Return a pointer to this function to the lexer (ffelex), which will
17432 invoke it for the next token.
17433
17434 Handle expression (which might be null) and COMMA or CLOSE_PAREN. */
17435
17436 static ffelexHandler
17437 ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr, ffelexToken t)
17438 {
17439 ffeexprExpr_ procedure;
17440 ffebld reduced;
17441 ffeinfo info;
17442 ffeexprContext ctx;
17443 bool check_intrin = FALSE; /* Set TRUE if intrinsic is REAL(Z) or AIMAG(Z). */
17444
17445 procedure = ffeexpr_stack_->exprstack;
17446 info = ffebld_info (procedure->u.operand);
17447
17448 /* Is there an expression to add? If the expression is nil,
17449 it might still be an argument. It is if:
17450
17451 - The current token is comma, or
17452
17453 - The -fugly-comma flag was specified *and* the procedure
17454 being invoked is external.
17455
17456 Otherwise, if neither of the above is the case, just
17457 ignore this (nil) expression. */
17458
17459 if ((expr != NULL)
17460 || (ffelex_token_type (t) == FFELEX_typeCOMMA)
17461 || (ffe_is_ugly_comma ()
17462 && (ffeinfo_where (info) == FFEINFO_whereGLOBAL)))
17463 {
17464 /* This expression, even if nil, is apparently intended as an argument. */
17465
17466 /* Internal procedure (CONTAINS, or statement function)? */
17467
17468 if (ffeinfo_where (info) == FFEINFO_whereCONSTANT)
17469 {
17470 if ((expr == NULL)
17471 && ffebad_start (FFEBAD_NULL_ARGUMENT))
17472 {
17473 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17474 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17475 ffebad_here (1, ffelex_token_where_line (t),
17476 ffelex_token_where_column (t));
17477 ffebad_finish ();
17478 }
17479
17480 if (expr == NULL)
17481 ;
17482 else
17483 {
17484 if (ffeexpr_stack_->next_dummy == NULL)
17485 { /* Report later which was the first extra argument. */
17486 if (ffeexpr_stack_->tokens[1] == NULL)
17487 {
17488 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
17489 ffeexpr_stack_->num_args = 0;
17490 }
17491 ++ffeexpr_stack_->num_args; /* Count # of extra arguments. */
17492 }
17493 else
17494 {
17495 if ((ffeinfo_rank (ffebld_info (expr)) != 0)
17496 && ffebad_start (FFEBAD_ARRAY_AS_SFARG))
17497 {
17498 ffebad_here (0,
17499 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17500 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17501 ffebad_here (1, ffelex_token_where_line (ft),
17502 ffelex_token_where_column (ft));
17503 ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent
17504 (ffebld_symter (ffebld_head
17505 (ffeexpr_stack_->next_dummy)))));
17506 ffebad_finish ();
17507 }
17508 else
17509 {
17510 expr = ffeexpr_convert_expr (expr, ft,
17511 ffebld_head (ffeexpr_stack_->next_dummy),
17512 ffeexpr_stack_->tokens[0],
17513 FFEEXPR_contextLET);
17514 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17515 }
17516 --ffeexpr_stack_->num_args; /* Count down # of args. */
17517 ffeexpr_stack_->next_dummy
17518 = ffebld_trail (ffeexpr_stack_->next_dummy);
17519 }
17520 }
17521 }
17522 else
17523 {
17524 if ((expr == NULL)
17525 && ffe_is_pedantic ()
17526 && ffebad_start (FFEBAD_NULL_ARGUMENT_W))
17527 {
17528 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17529 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17530 ffebad_here (1, ffelex_token_where_line (t),
17531 ffelex_token_where_column (t));
17532 ffebad_finish ();
17533 }
17534 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17535 }
17536 }
17537
17538 switch (ffelex_token_type (t))
17539 {
17540 case FFELEX_typeCOMMA:
17541 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17542 {
17543 case FFEEXPR_contextSFUNCDEF:
17544 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17545 case FFEEXPR_contextSFUNCDEFINDEX_:
17546 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17547 ctx = FFEEXPR_contextSFUNCDEFACTUALARG_;
17548 break;
17549
17550 case FFEEXPR_contextSFUNCDEFACTUALARG_:
17551 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
17552 assert ("bad context" == NULL);
17553 ctx = FFEEXPR_context;
17554 break;
17555
17556 default:
17557 ctx = FFEEXPR_contextACTUALARG_;
17558 break;
17559 }
17560 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
17561 ffeexpr_token_arguments_);
17562
17563 default:
17564 break;
17565 }
17566
17567 if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
17568 && (ffeexpr_stack_->next_dummy != NULL))
17569 { /* Too few arguments. */
17570 if (ffebad_start (FFEBAD_TOO_FEW_ARGUMENTS))
17571 {
17572 char num[10];
17573
17574 sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
17575
17576 ffebad_here (0, ffelex_token_where_line (t),
17577 ffelex_token_where_column (t));
17578 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17579 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17580 ffebad_string (num);
17581 ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent (ffebld_symter
17582 (ffebld_head (ffeexpr_stack_->next_dummy)))));
17583 ffebad_finish ();
17584 }
17585 for (;
17586 ffeexpr_stack_->next_dummy != NULL;
17587 ffeexpr_stack_->next_dummy
17588 = ffebld_trail (ffeexpr_stack_->next_dummy))
17589 {
17590 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0));
17591 ffebld_set_info (expr, ffeinfo_new_any ());
17592 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17593 }
17594 }
17595
17596 if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
17597 && (ffeexpr_stack_->tokens[1] != NULL))
17598 { /* Too many arguments to statement function. */
17599 if (ffebad_start (FFEBAD_TOO_MANY_ARGUMENTS))
17600 {
17601 char num[10];
17602
17603 sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
17604
17605 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
17606 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
17607 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17608 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17609 ffebad_string (num);
17610 ffebad_finish ();
17611 }
17612 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
17613 }
17614 ffebld_end_list (&ffeexpr_stack_->bottom);
17615
17616 if (ffebld_op (procedure->u.operand) == FFEBLD_opANY)
17617 {
17618 reduced = ffebld_new_any ();
17619 ffebld_set_info (reduced, ffeinfo_new_any ());
17620 }
17621 else
17622 {
17623 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
17624 reduced = ffebld_new_funcref (procedure->u.operand,
17625 ffeexpr_stack_->expr);
17626 else
17627 reduced = ffebld_new_subrref (procedure->u.operand,
17628 ffeexpr_stack_->expr);
17629 if (ffebld_symter_generic (procedure->u.operand) != FFEINTRIN_genNONE)
17630 ffeintrin_fulfill_generic (&reduced, &info, ffeexpr_stack_->tokens[0]);
17631 else if (ffebld_symter_specific (procedure->u.operand)
17632 != FFEINTRIN_specNONE)
17633 ffeintrin_fulfill_specific (&reduced, &info, &check_intrin,
17634 ffeexpr_stack_->tokens[0]);
17635 else
17636 ffeexpr_fulfill_call_ (&reduced, ffeexpr_stack_->tokens[0]);
17637
17638 if (ffebld_op (reduced) != FFEBLD_opANY)
17639 ffebld_set_info (reduced,
17640 ffeinfo_new (ffeinfo_basictype (info),
17641 ffeinfo_kindtype (info),
17642 0,
17643 FFEINFO_kindENTITY,
17644 FFEINFO_whereFLEETING,
17645 ffeinfo_size (info)));
17646 else
17647 ffebld_set_info (reduced, ffeinfo_new_any ());
17648 }
17649 if (ffebld_op (reduced) == FFEBLD_opFUNCREF)
17650 reduced = ffeexpr_collapse_funcref (reduced, ffeexpr_stack_->tokens[0]);
17651 ffeexpr_stack_->exprstack = procedure->previous; /* Pops
17652 not-quite-operand off
17653 stack. */
17654 procedure->u.operand = reduced; /* Save the line/column ffewhere
17655 info. */
17656 ffeexpr_exprstack_push_operand_ (procedure); /* Push it back on stack. */
17657 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
17658 {
17659 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
17660 ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FUNC(3)(1:1)".... */
17661
17662 /* If the intrinsic needs checking (is REAL(Z) or AIMAG(Z), where
17663 Z is DOUBLE COMPLEX), and a command-line option doesn't already
17664 establish interpretation, probably complain. */
17665
17666 if (check_intrin
17667 && !ffe_is_90 ()
17668 && !ffe_is_ugly_complex ())
17669 {
17670 /* If the outer expression is REAL(me...), issue diagnostic
17671 only if next token isn't the close-paren for REAL(me). */
17672
17673 if ((ffeexpr_stack_->previous != NULL)
17674 && (ffeexpr_stack_->previous->exprstack != NULL)
17675 && (ffeexpr_stack_->previous->exprstack->type == FFEEXPR_exprtypeOPERAND_)
17676 && ((reduced = ffeexpr_stack_->previous->exprstack->u.operand) != NULL)
17677 && (ffebld_op (reduced) == FFEBLD_opSYMTER)
17678 && (ffebld_symter_implementation (reduced) == FFEINTRIN_impREAL))
17679 return (ffelexHandler) ffeexpr_token_intrincheck_;
17680
17681 /* Diagnose the ambiguity now. */
17682
17683 if (ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
17684 {
17685 ffebad_string (ffeintrin_name_implementation
17686 (ffebld_symter_implementation
17687 (ffebld_left
17688 (ffeexpr_stack_->exprstack->u.operand))));
17689 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
17690 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
17691 ffebad_finish ();
17692 }
17693 }
17694 return (ffelexHandler) ffeexpr_token_substrp_;
17695 }
17696
17697 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
17698 {
17699 ffebad_here (0, ffelex_token_where_line (t),
17700 ffelex_token_where_column (t));
17701 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17702 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17703 ffebad_finish ();
17704 }
17705 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
17706 ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FUNC(3)(1:1)".... */
17707 return
17708 (ffelexHandler) ffeexpr_find_close_paren_ (t,
17709 (ffelexHandler)
17710 ffeexpr_token_substrp_);
17711 }
17712
17713 /* ffeexpr_token_elements_ -- OPEN_PAREN [expr COMMA]...expr
17714
17715 Return a pointer to this array to the lexer (ffelex), which will
17716 invoke it for the next token.
17717
17718 Handle expression and COMMA or CLOSE_PAREN. */
17719
17720 static ffelexHandler
17721 ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, ffelexToken t)
17722 {
17723 ffeexprExpr_ array;
17724 ffebld reduced;
17725 ffeinfo info;
17726 ffeinfoWhere where;
17727 ffetargetIntegerDefault val;
17728 ffetargetIntegerDefault lval = 0;
17729 ffetargetIntegerDefault uval = 0;
17730 ffebld lbound;
17731 ffebld ubound;
17732 bool lcheck;
17733 bool ucheck;
17734
17735 array = ffeexpr_stack_->exprstack;
17736 info = ffebld_info (array->u.operand);
17737
17738 if ((expr == NULL) /* && ((ffeexpr_stack_->rank != 0) ||
17739 (ffelex_token_type(t) ==
17740 FFELEX_typeCOMMA)) */ )
17741 {
17742 if (ffebad_start (FFEBAD_NULL_ELEMENT))
17743 {
17744 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17745 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17746 ffebad_here (1, ffelex_token_where_line (t),
17747 ffelex_token_where_column (t));
17748 ffebad_finish ();
17749 }
17750 if (ffeexpr_stack_->rank < ffeinfo_rank (info))
17751 { /* Don't bother if we're going to complain
17752 later! */
17753 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
17754 ffebld_set_info (expr, ffeinfo_new_any ());
17755 }
17756 }
17757
17758 if (expr == NULL)
17759 ;
17760 else if (ffeinfo_rank (info) == 0)
17761 { /* In EQUIVALENCE context, ffeinfo_rank(info)
17762 may == 0. */
17763 ++ffeexpr_stack_->rank; /* Track anyway, may need for new VXT
17764 feature. */
17765 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17766 }
17767 else
17768 {
17769 ++ffeexpr_stack_->rank;
17770 if (ffeexpr_stack_->rank > ffeinfo_rank (info))
17771 { /* Report later which was the first extra
17772 element. */
17773 if (ffeexpr_stack_->rank == ffeinfo_rank (info) + 1)
17774 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
17775 }
17776 else
17777 {
17778 switch (ffeinfo_where (ffebld_info (expr)))
17779 {
17780 case FFEINFO_whereCONSTANT:
17781 break;
17782
17783 case FFEINFO_whereIMMEDIATE:
17784 ffeexpr_stack_->constant = FALSE;
17785 break;
17786
17787 default:
17788 ffeexpr_stack_->constant = FALSE;
17789 ffeexpr_stack_->immediate = FALSE;
17790 break;
17791 }
17792 if (ffebld_op (expr) == FFEBLD_opCONTER
17793 && ffebld_kindtype (expr) == FFEINFO_kindtypeINTEGERDEFAULT)
17794 {
17795 val = ffebld_constant_integerdefault (ffebld_conter (expr));
17796
17797 lbound = ffebld_left (ffebld_head (ffeexpr_stack_->bound_list));
17798 if (lbound == NULL)
17799 {
17800 lcheck = TRUE;
17801 lval = 1;
17802 }
17803 else if (ffebld_op (lbound) == FFEBLD_opCONTER)
17804 {
17805 lcheck = TRUE;
17806 lval = ffebld_constant_integerdefault (ffebld_conter (lbound));
17807 }
17808 else
17809 lcheck = FALSE;
17810
17811 ubound = ffebld_right (ffebld_head (ffeexpr_stack_->bound_list));
17812 assert (ubound != NULL);
17813 if (ffebld_op (ubound) == FFEBLD_opCONTER)
17814 {
17815 ucheck = TRUE;
17816 uval = ffebld_constant_integerdefault (ffebld_conter (ubound));
17817 }
17818 else
17819 ucheck = FALSE;
17820
17821 if ((lcheck && (val < lval)) || (ucheck && (val > uval)))
17822 {
17823 ffebad_start (FFEBAD_RANGE_ARRAY);
17824 ffebad_here (0, ffelex_token_where_line (ft),
17825 ffelex_token_where_column (ft));
17826 ffebad_finish ();
17827 }
17828 }
17829 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17830 ffeexpr_stack_->bound_list = ffebld_trail (ffeexpr_stack_->bound_list);
17831 }
17832 }
17833
17834 switch (ffelex_token_type (t))
17835 {
17836 case FFELEX_typeCOMMA:
17837 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17838 {
17839 case FFEEXPR_contextDATAIMPDOITEM_:
17840 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
17841 FFEEXPR_contextDATAIMPDOINDEX_,
17842 ffeexpr_token_elements_);
17843
17844 case FFEEXPR_contextEQUIVALENCE:
17845 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
17846 FFEEXPR_contextEQVINDEX_,
17847 ffeexpr_token_elements_);
17848
17849 case FFEEXPR_contextSFUNCDEF:
17850 case FFEEXPR_contextSFUNCDEFINDEX_:
17851 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
17852 FFEEXPR_contextSFUNCDEFINDEX_,
17853 ffeexpr_token_elements_);
17854
17855 case FFEEXPR_contextSFUNCDEFACTUALARG_:
17856 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
17857 assert ("bad context" == NULL);
17858 break;
17859
17860 default:
17861 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
17862 FFEEXPR_contextINDEX_,
17863 ffeexpr_token_elements_);
17864 }
17865
17866 default:
17867 break;
17868 }
17869
17870 if ((ffeexpr_stack_->rank != ffeinfo_rank (info))
17871 && (ffeinfo_rank (info) != 0))
17872 {
17873 char num[10];
17874
17875 if (ffeexpr_stack_->rank < ffeinfo_rank (info))
17876 {
17877 if (ffebad_start (FFEBAD_TOO_FEW_ELEMENTS))
17878 {
17879 sprintf (num, "%d",
17880 (int) (ffeinfo_rank (info) - ffeexpr_stack_->rank));
17881
17882 ffebad_here (0, ffelex_token_where_line (t),
17883 ffelex_token_where_column (t));
17884 ffebad_here (1,
17885 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17886 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17887 ffebad_string (num);
17888 ffebad_finish ();
17889 }
17890 }
17891 else
17892 {
17893 if (ffebad_start (FFEBAD_TOO_MANY_ELEMENTS))
17894 {
17895 sprintf (num, "%d",
17896 (int) (ffeexpr_stack_->rank - ffeinfo_rank (info)));
17897
17898 ffebad_here (0,
17899 ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
17900 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
17901 ffebad_here (1,
17902 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17903 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17904 ffebad_string (num);
17905 ffebad_finish ();
17906 }
17907 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
17908 }
17909 while (ffeexpr_stack_->rank++ < ffeinfo_rank (info))
17910 {
17911 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
17912 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeINTEGER,
17913 FFEINFO_kindtypeINTEGERDEFAULT,
17914 0, FFEINFO_kindENTITY,
17915 FFEINFO_whereCONSTANT,
17916 FFETARGET_charactersizeNONE));
17917 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17918 }
17919 }
17920 ffebld_end_list (&ffeexpr_stack_->bottom);
17921
17922 if (ffebld_op (array->u.operand) == FFEBLD_opANY)
17923 {
17924 reduced = ffebld_new_any ();
17925 ffebld_set_info (reduced, ffeinfo_new_any ());
17926 }
17927 else
17928 {
17929 reduced = ffebld_new_arrayref (array->u.operand, ffeexpr_stack_->expr);
17930 if (ffeexpr_stack_->constant)
17931 where = FFEINFO_whereFLEETING_CADDR;
17932 else if (ffeexpr_stack_->immediate)
17933 where = FFEINFO_whereFLEETING_IADDR;
17934 else
17935 where = FFEINFO_whereFLEETING;
17936 ffebld_set_info (reduced,
17937 ffeinfo_new (ffeinfo_basictype (info),
17938 ffeinfo_kindtype (info),
17939 0,
17940 FFEINFO_kindENTITY,
17941 where,
17942 ffeinfo_size (info)));
17943 reduced = ffeexpr_collapse_arrayref (reduced, ffeexpr_stack_->tokens[0]);
17944 }
17945
17946 ffeexpr_stack_->exprstack = array->previous; /* Pops not-quite-operand off
17947 stack. */
17948 array->u.operand = reduced; /* Save the line/column ffewhere info. */
17949 ffeexpr_exprstack_push_operand_ (array); /* Push it back on stack. */
17950
17951 switch (ffeinfo_basictype (info))
17952 {
17953 case FFEINFO_basictypeCHARACTER:
17954 ffeexpr_is_substr_ok_ = TRUE; /* Everyone likes "FOO(3)(1:1)".... */
17955 break;
17956
17957 case FFEINFO_basictypeNONE:
17958 ffeexpr_is_substr_ok_ = TRUE;
17959 assert (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE);
17960 break;
17961
17962 default:
17963 ffeexpr_is_substr_ok_ = FALSE;
17964 break;
17965 }
17966
17967 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
17968 {
17969 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
17970 return (ffelexHandler) ffeexpr_token_substrp_;
17971 }
17972
17973 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
17974 {
17975 ffebad_here (0, ffelex_token_where_line (t),
17976 ffelex_token_where_column (t));
17977 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17978 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17979 ffebad_finish ();
17980 }
17981 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
17982 return
17983 (ffelexHandler) ffeexpr_find_close_paren_ (t,
17984 (ffelexHandler)
17985 ffeexpr_token_substrp_);
17986 }
17987
17988 /* ffeexpr_token_equivalence_ -- OPEN_PAREN expr
17989
17990 Return a pointer to this array to the lexer (ffelex), which will
17991 invoke it for the next token.
17992
17993 If token is COLON, pass off to _substr_, else init list and pass off
17994 to _elements_. This handles the case "EQUIVALENCE (FOO(expr?", where
17995 ? marks the token, and where FOO's rank/type has not yet been established,
17996 meaning we could be in a list of indices or in a substring
17997 specification. */
17998
17999 static ffelexHandler
18000 ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr, ffelexToken t)
18001 {
18002 if (ffelex_token_type (t) == FFELEX_typeCOLON)
18003 return ffeexpr_token_substring_ (ft, expr, t);
18004
18005 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
18006 return ffeexpr_token_elements_ (ft, expr, t);
18007 }
18008
18009 /* ffeexpr_token_substring_ -- NAME(of kindENTITY) OPEN_PAREN expr
18010
18011 Return a pointer to this function to the lexer (ffelex), which will
18012 invoke it for the next token.
18013
18014 Handle expression (which may be null) and COLON. */
18015
18016 static ffelexHandler
18017 ffeexpr_token_substring_ (ffelexToken ft, ffebld expr, ffelexToken t)
18018 {
18019 ffeexprExpr_ string;
18020 ffeinfo info;
18021 ffetargetIntegerDefault i;
18022 ffeexprContext ctx;
18023 ffetargetCharacterSize size;
18024
18025 string = ffeexpr_stack_->exprstack;
18026 info = ffebld_info (string->u.operand);
18027 size = ffebld_size_max (string->u.operand);
18028
18029 if (ffelex_token_type (t) == FFELEX_typeCOLON)
18030 {
18031 if ((expr != NULL)
18032 && (ffebld_op (expr) == FFEBLD_opCONTER)
18033 && (((i = ffebld_constant_integerdefault (ffebld_conter (expr)))
18034 < 1)
18035 || ((size != FFETARGET_charactersizeNONE) && (i > size))))
18036 {
18037 ffebad_start (FFEBAD_RANGE_SUBSTR);
18038 ffebad_here (0, ffelex_token_where_line (ft),
18039 ffelex_token_where_column (ft));
18040 ffebad_finish ();
18041 }
18042 ffeexpr_stack_->expr = expr;
18043
18044 switch (ffeexpr_stack_->context)
18045 {
18046 case FFEEXPR_contextSFUNCDEF:
18047 case FFEEXPR_contextSFUNCDEFINDEX_:
18048 ctx = FFEEXPR_contextSFUNCDEFINDEX_;
18049 break;
18050
18051 case FFEEXPR_contextSFUNCDEFACTUALARG_:
18052 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18053 assert ("bad context" == NULL);
18054 ctx = FFEEXPR_context;
18055 break;
18056
18057 default:
18058 ctx = FFEEXPR_contextINDEX_;
18059 break;
18060 }
18061
18062 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18063 ffeexpr_token_substring_1_);
18064 }
18065
18066 if (ffest_ffebad_start (FFEBAD_MISSING_COLON_IN_SUBSTR))
18067 {
18068 ffebad_here (0, ffelex_token_where_line (t),
18069 ffelex_token_where_column (t));
18070 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18071 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18072 ffebad_finish ();
18073 }
18074
18075 ffeexpr_stack_->expr = NULL;
18076 return (ffelexHandler) ffeexpr_token_substring_1_ (ft, expr, t);
18077 }
18078
18079 /* ffeexpr_token_substring_1_ -- NAME OPEN_PAREN [expr COMMA]...expr
18080
18081 Return a pointer to this function to the lexer (ffelex), which will
18082 invoke it for the next token.
18083
18084 Handle expression (which might be null) and CLOSE_PAREN. */
18085
18086 static ffelexHandler
18087 ffeexpr_token_substring_1_ (ffelexToken ft, ffebld last, ffelexToken t)
18088 {
18089 ffeexprExpr_ string;
18090 ffebld reduced;
18091 ffebld substrlist;
18092 ffebld first = ffeexpr_stack_->expr;
18093 ffebld strop;
18094 ffeinfo info;
18095 ffeinfoWhere lwh;
18096 ffeinfoWhere rwh;
18097 ffeinfoWhere where;
18098 ffeinfoKindtype first_kt;
18099 ffeinfoKindtype last_kt;
18100 ffetargetIntegerDefault first_val;
18101 ffetargetIntegerDefault last_val;
18102 ffetargetCharacterSize size;
18103 ffetargetCharacterSize strop_size_max;
18104 bool first_known;
18105
18106 string = ffeexpr_stack_->exprstack;
18107 strop = string->u.operand;
18108 info = ffebld_info (strop);
18109
18110 if (first == NULL
18111 || (ffebld_op (first) == FFEBLD_opCONTER
18112 && ffebld_kindtype (first) == FFEINFO_kindtypeINTEGERDEFAULT))
18113 { /* The starting point is known. */
18114 first_val = (first == NULL) ? 1
18115 : ffebld_constant_integerdefault (ffebld_conter (first));
18116 first_known = TRUE;
18117 }
18118 else
18119 { /* Assume start of the entity. */
18120 first_val = 1;
18121 first_known = FALSE;
18122 }
18123
18124 if (last != NULL
18125 && (ffebld_op (last) == FFEBLD_opCONTER
18126 && ffebld_kindtype (last) == FFEINFO_kindtypeINTEGERDEFAULT))
18127 { /* The ending point is known. */
18128 last_val = ffebld_constant_integerdefault (ffebld_conter (last));
18129
18130 if (first_known)
18131 { /* The beginning point is a constant. */
18132 if (first_val <= last_val)
18133 size = last_val - first_val + 1;
18134 else
18135 {
18136 if (0 && ffe_is_90 ())
18137 size = 0;
18138 else
18139 {
18140 size = 1;
18141 ffebad_start (FFEBAD_ZERO_SIZE);
18142 ffebad_here (0, ffelex_token_where_line (ft),
18143 ffelex_token_where_column (ft));
18144 ffebad_finish ();
18145 }
18146 }
18147 }
18148 else
18149 size = FFETARGET_charactersizeNONE;
18150
18151 strop_size_max = ffebld_size_max (strop);
18152
18153 if ((strop_size_max != FFETARGET_charactersizeNONE)
18154 && (last_val > strop_size_max))
18155 { /* Beyond maximum possible end of string. */
18156 ffebad_start (FFEBAD_RANGE_SUBSTR);
18157 ffebad_here (0, ffelex_token_where_line (ft),
18158 ffelex_token_where_column (ft));
18159 ffebad_finish ();
18160 }
18161 }
18162 else
18163 size = FFETARGET_charactersizeNONE; /* The size is not known. */
18164
18165 #if 0 /* Don't do this, or "is size of target
18166 known?" would no longer be easily
18167 answerable. To see if there is a max
18168 size, use ffebld_size_max; to get only the
18169 known size, else NONE, use
18170 ffebld_size_known; use ffebld_size if
18171 values are sure to be the same (not
18172 opSUBSTR or opCONCATENATE or known to have
18173 known length). By getting rid of this
18174 "useful info" stuff, we don't end up
18175 blank-padding the constant in the
18176 assignment "A(I:J)='XYZ'" to the known
18177 length of A. */
18178 if (size == FFETARGET_charactersizeNONE)
18179 size = strop_size_max; /* Assume we use the entire string. */
18180 #endif
18181
18182 substrlist
18183 = ffebld_new_item
18184 (first,
18185 ffebld_new_item
18186 (last,
18187 NULL
18188 )
18189 )
18190 ;
18191
18192 if (first == NULL)
18193 lwh = FFEINFO_whereCONSTANT;
18194 else
18195 lwh = ffeinfo_where (ffebld_info (first));
18196 if (last == NULL)
18197 rwh = FFEINFO_whereCONSTANT;
18198 else
18199 rwh = ffeinfo_where (ffebld_info (last));
18200
18201 switch (lwh)
18202 {
18203 case FFEINFO_whereCONSTANT:
18204 switch (rwh)
18205 {
18206 case FFEINFO_whereCONSTANT:
18207 where = FFEINFO_whereCONSTANT;
18208 break;
18209
18210 case FFEINFO_whereIMMEDIATE:
18211 where = FFEINFO_whereIMMEDIATE;
18212 break;
18213
18214 default:
18215 where = FFEINFO_whereFLEETING;
18216 break;
18217 }
18218 break;
18219
18220 case FFEINFO_whereIMMEDIATE:
18221 switch (rwh)
18222 {
18223 case FFEINFO_whereCONSTANT:
18224 case FFEINFO_whereIMMEDIATE:
18225 where = FFEINFO_whereIMMEDIATE;
18226 break;
18227
18228 default:
18229 where = FFEINFO_whereFLEETING;
18230 break;
18231 }
18232 break;
18233
18234 default:
18235 where = FFEINFO_whereFLEETING;
18236 break;
18237 }
18238
18239 if (first == NULL)
18240 first_kt = FFEINFO_kindtypeINTEGERDEFAULT;
18241 else
18242 first_kt = ffeinfo_kindtype (ffebld_info (first));
18243 if (last == NULL)
18244 last_kt = FFEINFO_kindtypeINTEGERDEFAULT;
18245 else
18246 last_kt = ffeinfo_kindtype (ffebld_info (last));
18247
18248 switch (where)
18249 {
18250 case FFEINFO_whereCONSTANT:
18251 switch (ffeinfo_where (info))
18252 {
18253 case FFEINFO_whereCONSTANT:
18254 break;
18255
18256 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
18257 where = FFEINFO_whereIMMEDIATE;
18258 break;
18259
18260 default:
18261 where = FFEINFO_whereFLEETING_CADDR;
18262 break;
18263 }
18264 break;
18265
18266 case FFEINFO_whereIMMEDIATE:
18267 switch (ffeinfo_where (info))
18268 {
18269 case FFEINFO_whereCONSTANT:
18270 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
18271 break;
18272
18273 default:
18274 where = FFEINFO_whereFLEETING_IADDR;
18275 break;
18276 }
18277 break;
18278
18279 default:
18280 switch (ffeinfo_where (info))
18281 {
18282 case FFEINFO_whereCONSTANT:
18283 where = FFEINFO_whereCONSTANT_SUBOBJECT; /* An F90 concept. */
18284 break;
18285
18286 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
18287 default:
18288 where = FFEINFO_whereFLEETING;
18289 break;
18290 }
18291 break;
18292 }
18293
18294 if (ffebld_op (strop) == FFEBLD_opANY)
18295 {
18296 reduced = ffebld_new_any ();
18297 ffebld_set_info (reduced, ffeinfo_new_any ());
18298 }
18299 else
18300 {
18301 reduced = ffebld_new_substr (strop, substrlist);
18302 ffebld_set_info (reduced, ffeinfo_new
18303 (FFEINFO_basictypeCHARACTER,
18304 ffeinfo_kindtype (info),
18305 0,
18306 FFEINFO_kindENTITY,
18307 where,
18308 size));
18309 reduced = ffeexpr_collapse_substr (reduced, ffeexpr_stack_->tokens[0]);
18310 }
18311
18312 ffeexpr_stack_->exprstack = string->previous; /* Pops not-quite-operand off
18313 stack. */
18314 string->u.operand = reduced; /* Save the line/column ffewhere info. */
18315 ffeexpr_exprstack_push_operand_ (string); /* Push it back on stack. */
18316
18317 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18318 {
18319 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18320 ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FOO(3:5)(1:1)".... */
18321 return (ffelexHandler) ffeexpr_token_substrp_;
18322 }
18323
18324 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
18325 {
18326 ffebad_here (0, ffelex_token_where_line (t),
18327 ffelex_token_where_column (t));
18328 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18329 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18330 ffebad_finish ();
18331 }
18332
18333 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18334 ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FOO(3:5)(1:1)".... */
18335 return
18336 (ffelexHandler) ffeexpr_find_close_paren_ (t,
18337 (ffelexHandler)
18338 ffeexpr_token_substrp_);
18339 }
18340
18341 /* ffeexpr_token_substrp_ -- Rhs <character entity>
18342
18343 Return a pointer to this function to the lexer (ffelex), which will
18344 invoke it for the next token.
18345
18346 If OPEN_PAREN, treat as start of a substring ("(3:4)") construct, and
18347 issue error message if flag (serves as argument) is set. Else, just
18348 forward token to binary_. */
18349
18350 static ffelexHandler
18351 ffeexpr_token_substrp_ (ffelexToken t)
18352 {
18353 ffeexprContext ctx;
18354
18355 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
18356 return (ffelexHandler) ffeexpr_token_binary_ (t);
18357
18358 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
18359
18360 switch (ffeexpr_stack_->context)
18361 {
18362 case FFEEXPR_contextSFUNCDEF:
18363 case FFEEXPR_contextSFUNCDEFINDEX_:
18364 ctx = FFEEXPR_contextSFUNCDEFINDEX_;
18365 break;
18366
18367 case FFEEXPR_contextSFUNCDEFACTUALARG_:
18368 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18369 assert ("bad context" == NULL);
18370 ctx = FFEEXPR_context;
18371 break;
18372
18373 default:
18374 ctx = FFEEXPR_contextINDEX_;
18375 break;
18376 }
18377
18378 if (!ffeexpr_is_substr_ok_)
18379 {
18380 if (ffebad_start (FFEBAD_BAD_SUBSTR))
18381 {
18382 ffebad_here (0, ffelex_token_where_line (t),
18383 ffelex_token_where_column (t));
18384 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
18385 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
18386 ffebad_finish ();
18387 }
18388
18389 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18390 ffeexpr_token_anything_);
18391 }
18392
18393 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18394 ffeexpr_token_substring_);
18395 }
18396
18397 static ffelexHandler
18398 ffeexpr_token_intrincheck_ (ffelexToken t)
18399 {
18400 if ((ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
18401 && ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
18402 {
18403 ffebad_string (ffeintrin_name_implementation
18404 (ffebld_symter_implementation
18405 (ffebld_left
18406 (ffeexpr_stack_->exprstack->u.operand))));
18407 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
18408 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
18409 ffebad_finish ();
18410 }
18411
18412 return (ffelexHandler) ffeexpr_token_substrp_ (t);
18413 }
18414
18415 /* ffeexpr_token_funsubstr_ -- NAME OPEN_PAREN expr
18416
18417 Return a pointer to this function to the lexer (ffelex), which will
18418 invoke it for the next token.
18419
18420 If COLON, do everything we would have done since _parenthesized_ if
18421 we had known NAME represented a kindENTITY instead of a kindFUNCTION.
18422 If not COLON, do likewise for kindFUNCTION instead. */
18423
18424 static ffelexHandler
18425 ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr, ffelexToken t)
18426 {
18427 ffeinfoWhere where;
18428 ffesymbol s;
18429 ffesymbolAttrs sa;
18430 ffebld symter = ffeexpr_stack_->exprstack->u.operand;
18431 bool needs_type;
18432 ffeintrinGen gen;
18433 ffeintrinSpec spec;
18434 ffeintrinImp imp;
18435
18436 s = ffebld_symter (symter);
18437 sa = ffesymbol_attrs (s);
18438 where = ffesymbol_where (s);
18439
18440 /* We get here only if we don't already know enough about FOO when seeing a
18441 FOO(stuff) reference, and FOO might turn out to be a CHARACTER type. If
18442 "stuff" is a substring reference, then FOO is a CHARACTER scalar type.
18443 Else FOO is a function, either intrinsic or external. If intrinsic, it
18444 wouldn't necessarily be CHARACTER type, so unless it has already been
18445 declared DUMMY, it hasn't had its type established yet. It can't be
18446 CHAR*(*) in any case, though it can have an explicit CHAR*n type. */
18447
18448 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
18449 | FFESYMBOL_attrsTYPE)));
18450
18451 needs_type = !(ffesymbol_attrs (s) & FFESYMBOL_attrsDUMMY);
18452
18453 ffesymbol_signal_change (s); /* Probably already done, but in case.... */
18454
18455 if (ffelex_token_type (t) == FFELEX_typeCOLON)
18456 { /* Definitely an ENTITY (char substring). */
18457 if (needs_type && !ffeimplic_establish_symbol (s))
18458 {
18459 ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
18460 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
18461 }
18462
18463 ffesymbol_set_info (s,
18464 ffeinfo_new (ffesymbol_basictype (s),
18465 ffesymbol_kindtype (s),
18466 ffesymbol_rank (s),
18467 FFEINFO_kindENTITY,
18468 (where == FFEINFO_whereNONE)
18469 ? FFEINFO_whereLOCAL
18470 : where,
18471 ffesymbol_size (s)));
18472 ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
18473
18474 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18475 ffesymbol_resolve_intrin (s);
18476 s = ffecom_sym_learned (s);
18477 ffesymbol_signal_unreported (s); /* For debugging purposes. */
18478
18479 ffeexpr_stack_->exprstack->u.operand
18480 = ffeexpr_collapse_symter (symter, ffeexpr_tokens_[0]);
18481
18482 return (ffelexHandler) ffeexpr_token_substring_ (ft, expr, t);
18483 }
18484
18485 /* The "stuff" isn't a substring notation, so we now know the overall
18486 reference is to a function. */
18487
18488 if (ffeintrin_is_intrinsic (ffesymbol_text (s), ffeexpr_stack_->tokens[0],
18489 FALSE, &gen, &spec, &imp))
18490 {
18491 ffebld_symter_set_generic (symter, gen);
18492 ffebld_symter_set_specific (symter, spec);
18493 ffebld_symter_set_implementation (symter, imp);
18494 ffesymbol_set_generic (s, gen);
18495 ffesymbol_set_specific (s, spec);
18496 ffesymbol_set_implementation (s, imp);
18497 ffesymbol_set_info (s,
18498 ffeinfo_new (ffesymbol_basictype (s),
18499 ffesymbol_kindtype (s),
18500 0,
18501 FFEINFO_kindFUNCTION,
18502 FFEINFO_whereINTRINSIC,
18503 ffesymbol_size (s)));
18504 }
18505 else
18506 { /* Not intrinsic, now needs CHAR type. */
18507 if (!ffeimplic_establish_symbol (s))
18508 {
18509 ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
18510 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
18511 }
18512
18513 ffesymbol_set_info (s,
18514 ffeinfo_new (ffesymbol_basictype (s),
18515 ffesymbol_kindtype (s),
18516 ffesymbol_rank (s),
18517 FFEINFO_kindFUNCTION,
18518 (where == FFEINFO_whereNONE)
18519 ? FFEINFO_whereGLOBAL
18520 : where,
18521 ffesymbol_size (s)));
18522 }
18523
18524 ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
18525
18526 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18527 ffesymbol_resolve_intrin (s);
18528 s = ffecom_sym_learned (s);
18529 ffesymbol_reference (s, ffeexpr_stack_->tokens[0], FALSE);
18530 ffesymbol_signal_unreported (s); /* For debugging purposes. */
18531 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
18532 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
18533 }
18534
18535 /* ffeexpr_token_anything_ -- NAME OPEN_PAREN any-expr
18536
18537 Handle basically any expression, looking for CLOSE_PAREN. */
18538
18539 static ffelexHandler
18540 ffeexpr_token_anything_ (ffelexToken ft UNUSED, ffebld expr UNUSED,
18541 ffelexToken t)
18542 {
18543 ffeexprExpr_ e = ffeexpr_stack_->exprstack;
18544
18545 switch (ffelex_token_type (t))
18546 {
18547 case FFELEX_typeCOMMA:
18548 case FFELEX_typeCOLON:
18549 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18550 FFEEXPR_contextACTUALARG_,
18551 ffeexpr_token_anything_);
18552
18553 default:
18554 e->u.operand = ffebld_new_any ();
18555 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
18556 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18557 ffeexpr_is_substr_ok_ = FALSE;
18558 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18559 return (ffelexHandler) ffeexpr_token_substrp_;
18560 return (ffelexHandler) ffeexpr_token_substrp_ (t);
18561 }
18562 }
18563
18564 /* Terminate module. */
18565
18566 void
18567 ffeexpr_terminate_2 (void)
18568 {
18569 assert (ffeexpr_stack_ == NULL);
18570 assert (ffeexpr_level_ == 0);
18571 }
DragonFly BSD