1 /* expr.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 1997, 1998, 2001, 2002
3 Free Software Foundation, Inc.
4 Contributed by James Craig Burley.
5
6 This file is part of GNU Fortran.
7
8 GNU Fortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
11 any later version.
12
13 GNU Fortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GNU Fortran; see the file COPYING. If not, write to
20 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
21 02111-1307, USA.
22
23 Related Modules:
24 None.
25
26 Description:
27 Handles syntactic and semantic analysis of Fortran expressions.
28
29 Modifications:
30 */
31
32 /* Include files. */
33
34 #include "proj.h"
35 #include "expr.h"
36 #include "bad.h"
37 #include "bld.h"
38 #include "com.h"
39 #include "global.h"
40 #include "implic.h"
41 #include "intrin.h"
42 #include "info.h"
43 #include "lex.h"
44 #include "malloc.h"
45 #include "src.h"
46 #include "st.h"
47 #include "symbol.h"
48 #include "str.h"
49 #include "target.h"
50 #include "where.h"
51 #include "real.h"
52
53 /* Externals defined here. */
54
55
56 /* Simple definitions and enumerations. */
57
58 typedef enum
59 {
60 FFEEXPR_exprtypeUNKNOWN_,
61 FFEEXPR_exprtypeOPERAND_,
62 FFEEXPR_exprtypeUNARY_,
63 FFEEXPR_exprtypeBINARY_,
64 FFEEXPR_exprtype_
65 } ffeexprExprtype_;
66
67 typedef enum
68 {
69 FFEEXPR_operatorPOWER_,
70 FFEEXPR_operatorMULTIPLY_,
71 FFEEXPR_operatorDIVIDE_,
72 FFEEXPR_operatorADD_,
73 FFEEXPR_operatorSUBTRACT_,
74 FFEEXPR_operatorCONCATENATE_,
75 FFEEXPR_operatorLT_,
76 FFEEXPR_operatorLE_,
77 FFEEXPR_operatorEQ_,
78 FFEEXPR_operatorNE_,
79 FFEEXPR_operatorGT_,
80 FFEEXPR_operatorGE_,
81 FFEEXPR_operatorNOT_,
82 FFEEXPR_operatorAND_,
83 FFEEXPR_operatorOR_,
84 FFEEXPR_operatorXOR_,
85 FFEEXPR_operatorEQV_,
86 FFEEXPR_operatorNEQV_,
87 FFEEXPR_operator_
88 } ffeexprOperator_;
89
90 typedef enum
91 {
92 FFEEXPR_operatorprecedenceHIGHEST_ = 1,
93 FFEEXPR_operatorprecedencePOWER_ = 1,
94 FFEEXPR_operatorprecedenceMULTIPLY_ = 2,
95 FFEEXPR_operatorprecedenceDIVIDE_ = 2,
96 FFEEXPR_operatorprecedenceADD_ = 3,
97 FFEEXPR_operatorprecedenceSUBTRACT_ = 3,
98 FFEEXPR_operatorprecedenceLOWARITH_ = 3,
99 FFEEXPR_operatorprecedenceCONCATENATE_ = 3,
100 FFEEXPR_operatorprecedenceLT_ = 4,
101 FFEEXPR_operatorprecedenceLE_ = 4,
102 FFEEXPR_operatorprecedenceEQ_ = 4,
103 FFEEXPR_operatorprecedenceNE_ = 4,
104 FFEEXPR_operatorprecedenceGT_ = 4,
105 FFEEXPR_operatorprecedenceGE_ = 4,
106 FFEEXPR_operatorprecedenceNOT_ = 5,
107 FFEEXPR_operatorprecedenceAND_ = 6,
108 FFEEXPR_operatorprecedenceOR_ = 7,
109 FFEEXPR_operatorprecedenceXOR_ = 8,
110 FFEEXPR_operatorprecedenceEQV_ = 8,
111 FFEEXPR_operatorprecedenceNEQV_ = 8,
112 FFEEXPR_operatorprecedenceLOWEST_ = 8,
113 FFEEXPR_operatorprecedence_
114 } ffeexprOperatorPrecedence_;
115
116 #define FFEEXPR_operatorassociativityL2R_ TRUE
117 #define FFEEXPR_operatorassociativityR2L_ FALSE
118 #define FFEEXPR_operatorassociativityPOWER_ FFEEXPR_operatorassociativityR2L_
119 #define FFEEXPR_operatorassociativityMULTIPLY_ FFEEXPR_operatorassociativityL2R_
120 #define FFEEXPR_operatorassociativityDIVIDE_ FFEEXPR_operatorassociativityL2R_
121 #define FFEEXPR_operatorassociativityADD_ FFEEXPR_operatorassociativityL2R_
122 #define FFEEXPR_operatorassociativitySUBTRACT_ FFEEXPR_operatorassociativityL2R_
123 #define FFEEXPR_operatorassociativityCONCATENATE_ FFEEXPR_operatorassociativityL2R_
124 #define FFEEXPR_operatorassociativityLT_ FFEEXPR_operatorassociativityL2R_
125 #define FFEEXPR_operatorassociativityLE_ FFEEXPR_operatorassociativityL2R_
126 #define FFEEXPR_operatorassociativityEQ_ FFEEXPR_operatorassociativityL2R_
127 #define FFEEXPR_operatorassociativityNE_ FFEEXPR_operatorassociativityL2R_
128 #define FFEEXPR_operatorassociativityGT_ FFEEXPR_operatorassociativityL2R_
129 #define FFEEXPR_operatorassociativityGE_ FFEEXPR_operatorassociativityL2R_
130 #define FFEEXPR_operatorassociativityNOT_ FFEEXPR_operatorassociativityL2R_
131 #define FFEEXPR_operatorassociativityAND_ FFEEXPR_operatorassociativityL2R_
132 #define FFEEXPR_operatorassociativityOR_ FFEEXPR_operatorassociativityL2R_
133 #define FFEEXPR_operatorassociativityXOR_ FFEEXPR_operatorassociativityL2R_
134 #define FFEEXPR_operatorassociativityEQV_ FFEEXPR_operatorassociativityL2R_
135 #define FFEEXPR_operatorassociativityNEQV_ FFEEXPR_operatorassociativityL2R_
136
137 typedef enum
138 {
139 FFEEXPR_parentypeFUNCTION_,
140 FFEEXPR_parentypeSUBROUTINE_,
141 FFEEXPR_parentypeARRAY_,
142 FFEEXPR_parentypeSUBSTRING_,
143 FFEEXPR_parentypeFUNSUBSTR_,/* Ambig: check for colon after first expr. */
144 FFEEXPR_parentypeEQUIVALENCE_, /* Ambig: ARRAY_ or SUBSTRING_. */
145 FFEEXPR_parentypeANY_, /* Allow basically anything. */
146 FFEEXPR_parentype_
147 } ffeexprParenType_;
148
149 typedef enum
150 {
151 FFEEXPR_percentNONE_,
152 FFEEXPR_percentLOC_,
153 FFEEXPR_percentVAL_,
154 FFEEXPR_percentREF_,
155 FFEEXPR_percentDESCR_,
156 FFEEXPR_percent_
157 } ffeexprPercent_;
158
159 /* Internal typedefs. */
160
161 typedef struct _ffeexpr_expr_ *ffeexprExpr_;
162 typedef bool ffeexprOperatorAssociativity_;
163 typedef struct _ffeexpr_stack_ *ffeexprStack_;
164
165 /* Private include files. */
166
167
168 /* Internal structure definitions. */
169
170 struct _ffeexpr_expr_
171 {
172 ffeexprExpr_ previous;
173 ffelexToken token;
174 ffeexprExprtype_ type;
175 union
176 {
177 struct
178 {
179 ffeexprOperator_ op;
180 ffeexprOperatorPrecedence_ prec;
181 ffeexprOperatorAssociativity_ as;
182 }
183 operator;
184 ffebld operand;
185 }
186 u;
187 };
188
189 struct _ffeexpr_stack_
190 {
191 ffeexprStack_ previous;
192 mallocPool pool;
193 ffeexprContext context;
194 ffeexprCallback callback;
195 ffelexToken first_token;
196 ffeexprExpr_ exprstack;
197 ffelexToken tokens[10]; /* Used in certain cases, like (unary)
198 open-paren. */
199 ffebld expr; /* For first of
200 complex/implied-do/substring/array-elements
201 / actual-args expression. */
202 ffebld bound_list; /* For tracking dimension bounds list of
203 array. */
204 ffebldListBottom bottom; /* For building lists. */
205 ffeinfoRank rank; /* For elements in an array reference. */
206 bool constant; /* TRUE while elements seen so far are
207 constants. */
208 bool immediate; /* TRUE while elements seen so far are
209 immediate/constants. */
210 ffebld next_dummy; /* Next SFUNC dummy arg in arg list. */
211 ffebldListLength num_args; /* Number of dummy args expected in arg list. */
212 bool is_rhs; /* TRUE if rhs context, FALSE otherwise. */
213 ffeexprPercent_ percent; /* Current %FOO keyword. */
214 };
215
216 struct _ffeexpr_find_
217 {
218 ffelexToken t;
219 ffelexHandler after;
220 int level;
221 };
222
223 /* Static objects accessed by functions in this module. */
224
225 static ffeexprStack_ ffeexpr_stack_; /* Expression stack for semantic. */
226 static ffelexToken ffeexpr_tokens_[10]; /* Scratchpad tokens for syntactic. */
227 static ffestrOther ffeexpr_current_dotdot_; /* Current .FOO. keyword. */
228 static long ffeexpr_hollerith_count_; /* ffeexpr_token_number_ and caller. */
229 static int ffeexpr_level_; /* Level of DATA implied-DO construct. */
230 static bool ffeexpr_is_substr_ok_; /* If OPEN_PAREN as binary "op" ok. */
231 static struct _ffeexpr_find_ ffeexpr_find_;
232
233 /* Static functions (internal). */
234
235 static ffelexHandler ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr,
236 ffelexToken t);
237 static ffelexHandler ffeexpr_cb_close_paren_ambig_ (ffelexToken ft,
238 ffebld expr,
239 ffelexToken t);
240 static ffelexHandler ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t);
241 static ffelexHandler ffeexpr_cb_close_paren_c_ (ffelexToken ft,
242 ffebld expr, ffelexToken t);
243 static ffelexHandler ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr,
244 ffelexToken t);
245 static ffelexHandler ffeexpr_cb_close_paren_ci_ (ffelexToken ft,
246 ffebld expr, ffelexToken t);
247 static ffelexHandler ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr,
248 ffelexToken t);
249 static ffelexHandler ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr,
250 ffelexToken t);
251 static ffelexHandler ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr,
252 ffelexToken t);
253 static ffelexHandler ffeexpr_cb_comma_i_2_ (ffelexToken ft, ffebld expr,
254 ffelexToken t);
255 static ffelexHandler ffeexpr_cb_comma_i_3_ (ffelexToken ft, ffebld expr,
256 ffelexToken t);
257 static ffelexHandler ffeexpr_cb_comma_i_4_ (ffelexToken ft, ffebld expr,
258 ffelexToken t);
259 static ffelexHandler ffeexpr_cb_comma_i_5_ (ffelexToken t);
260 static ffelexHandler ffeexpr_cb_end_loc_ (ffelexToken ft, ffebld expr,
261 ffelexToken t);
262 static ffelexHandler ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr,
263 ffelexToken t);
264 static ffelexHandler ffeexpr_cb_end_notloc_1_ (ffelexToken t);
265 static ffesymbol ffeexpr_check_impctrl_ (ffesymbol s);
266 static void ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
267 ffebld dovar, ffelexToken dovar_t);
268 static void ffeexpr_update_impdo_ (ffebld expr, ffebld dovar);
269 static void ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar);
270 static ffeexprContext ffeexpr_context_outer_ (ffeexprStack_ s);
271 static ffeexprExpr_ ffeexpr_expr_new_ (void);
272 static void ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t);
273 static bool ffeexpr_isdigits_ (const char *p);
274 static ffelexHandler ffeexpr_token_first_lhs_ (ffelexToken t);
275 static ffelexHandler ffeexpr_token_first_lhs_1_ (ffelexToken t);
276 static ffelexHandler ffeexpr_token_first_rhs_ (ffelexToken t);
277 static ffelexHandler ffeexpr_token_first_rhs_1_ (ffelexToken t);
278 static ffelexHandler ffeexpr_token_first_rhs_2_ (ffelexToken t);
279 static ffelexHandler ffeexpr_token_first_rhs_3_ (ffelexToken t);
280 static ffelexHandler ffeexpr_token_first_rhs_4_ (ffelexToken t);
281 static ffelexHandler ffeexpr_token_first_rhs_5_ (ffelexToken t);
282 static ffelexHandler ffeexpr_token_first_rhs_6_ (ffelexToken t);
283 static ffelexHandler ffeexpr_token_namelist_ (ffelexToken t);
284 static void ffeexpr_expr_kill_ (ffeexprExpr_ e);
285 static void ffeexpr_exprstack_push_ (ffeexprExpr_ e);
286 static void ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e);
287 static void ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e);
288 static void ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e);
289 static void ffeexpr_reduce_ (void);
290 static ffebld ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op,
291 ffeexprExpr_ r);
292 static ffebld ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l,
293 ffeexprExpr_ op, ffeexprExpr_ r);
294 static ffebld ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l,
295 ffeexprExpr_ op, ffeexprExpr_ r);
296 static ffebld ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l,
297 ffeexprExpr_ op, ffeexprExpr_ r);
298 static ffebld ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op,
299 ffeexprExpr_ r);
300 static ffebld ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l,
301 ffeexprExpr_ op, ffeexprExpr_ r);
302 static ffebld ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l,
303 ffeexprExpr_ op, ffeexprExpr_ r);
304 static ffebld ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l,
305 ffeexprExpr_ op, ffeexprExpr_ r);
306 static ffebld ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r);
307 static ffebld ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op,
308 ffeexprExpr_ r);
309 static ffebld ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l,
310 ffeexprExpr_ op, ffeexprExpr_ r);
311 static ffebld ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l,
312 ffeexprExpr_ op, ffeexprExpr_ r);
313 static ffelexHandler ffeexpr_find_close_paren_ (ffelexToken t,
314 ffelexHandler after);
315 static ffelexHandler ffeexpr_nil_finished_ (ffelexToken t);
316 static ffelexHandler ffeexpr_nil_rhs_ (ffelexToken t);
317 static ffelexHandler ffeexpr_nil_period_ (ffelexToken t);
318 static ffelexHandler ffeexpr_nil_end_period_ (ffelexToken t);
319 static ffelexHandler ffeexpr_nil_swallow_period_ (ffelexToken t);
320 static ffelexHandler ffeexpr_nil_real_ (ffelexToken t);
321 static ffelexHandler ffeexpr_nil_real_exponent_ (ffelexToken t);
322 static ffelexHandler ffeexpr_nil_real_exp_sign_ (ffelexToken t);
323 static ffelexHandler ffeexpr_nil_number_ (ffelexToken t);
324 static ffelexHandler ffeexpr_nil_number_exponent_ (ffelexToken t);
325 static ffelexHandler ffeexpr_nil_number_exp_sign_ (ffelexToken t);
326 static ffelexHandler ffeexpr_nil_number_period_ (ffelexToken t);
327 static ffelexHandler ffeexpr_nil_number_per_exp_ (ffelexToken t);
328 static ffelexHandler ffeexpr_nil_number_real_ (ffelexToken t);
329 static ffelexHandler ffeexpr_nil_num_per_exp_sign_ (ffelexToken t);
330 static ffelexHandler ffeexpr_nil_number_real_exp_ (ffelexToken t);
331 static ffelexHandler ffeexpr_nil_num_real_exp_sn_ (ffelexToken t);
332 static ffelexHandler ffeexpr_nil_binary_ (ffelexToken t);
333 static ffelexHandler ffeexpr_nil_binary_period_ (ffelexToken t);
334 static ffelexHandler ffeexpr_nil_binary_end_per_ (ffelexToken t);
335 static ffelexHandler ffeexpr_nil_binary_sw_per_ (ffelexToken t);
336 static ffelexHandler ffeexpr_nil_quote_ (ffelexToken t);
337 static ffelexHandler ffeexpr_nil_apostrophe_ (ffelexToken t);
338 static ffelexHandler ffeexpr_nil_apos_char_ (ffelexToken t);
339 static ffelexHandler ffeexpr_nil_name_rhs_ (ffelexToken t);
340 static ffelexHandler ffeexpr_nil_name_apos_ (ffelexToken t);
341 static ffelexHandler ffeexpr_nil_name_apos_name_ (ffelexToken t);
342 static ffelexHandler ffeexpr_nil_percent_ (ffelexToken t);
343 static ffelexHandler ffeexpr_nil_percent_name_ (ffelexToken t);
344 static ffelexHandler ffeexpr_nil_substrp_ (ffelexToken t);
345 static ffelexHandler ffeexpr_finished_ (ffelexToken t);
346 static ffebld ffeexpr_finished_ambig_ (ffelexToken t, ffebld expr);
347 static ffelexHandler ffeexpr_token_lhs_ (ffelexToken t);
348 static ffelexHandler ffeexpr_token_rhs_ (ffelexToken t);
349 static ffelexHandler ffeexpr_token_binary_ (ffelexToken t);
350 static ffelexHandler ffeexpr_token_period_ (ffelexToken t);
351 static ffelexHandler ffeexpr_token_end_period_ (ffelexToken t);
352 static ffelexHandler ffeexpr_token_swallow_period_ (ffelexToken t);
353 static ffelexHandler ffeexpr_token_real_ (ffelexToken t);
354 static ffelexHandler ffeexpr_token_real_exponent_ (ffelexToken t);
355 static ffelexHandler ffeexpr_token_real_exp_sign_ (ffelexToken t);
356 static ffelexHandler ffeexpr_token_number_ (ffelexToken t);
357 static ffelexHandler ffeexpr_token_number_exponent_ (ffelexToken t);
358 static ffelexHandler ffeexpr_token_number_exp_sign_ (ffelexToken t);
359 static ffelexHandler ffeexpr_token_number_period_ (ffelexToken t);
360 static ffelexHandler ffeexpr_token_number_per_exp_ (ffelexToken t);
361 static ffelexHandler ffeexpr_token_number_real_ (ffelexToken t);
362 static ffelexHandler ffeexpr_token_num_per_exp_sign_ (ffelexToken t);
363 static ffelexHandler ffeexpr_token_number_real_exp_ (ffelexToken t);
364 static ffelexHandler ffeexpr_token_num_real_exp_sn_ (ffelexToken t);
365 static ffelexHandler ffeexpr_token_binary_period_ (ffelexToken t);
366 static ffelexHandler ffeexpr_token_binary_end_per_ (ffelexToken t);
367 static ffelexHandler ffeexpr_token_binary_sw_per_ (ffelexToken t);
368 static ffelexHandler ffeexpr_token_quote_ (ffelexToken t);
369 static ffelexHandler ffeexpr_token_apostrophe_ (ffelexToken t);
370 static ffelexHandler ffeexpr_token_apos_char_ (ffelexToken t);
371 static ffelexHandler ffeexpr_token_name_lhs_ (ffelexToken t);
372 static ffelexHandler ffeexpr_token_name_arg_ (ffelexToken t);
373 static ffelexHandler ffeexpr_token_name_rhs_ (ffelexToken t);
374 static ffelexHandler ffeexpr_token_name_apos_ (ffelexToken t);
375 static ffelexHandler ffeexpr_token_name_apos_name_ (ffelexToken t);
376 static ffelexHandler ffeexpr_token_percent_ (ffelexToken t);
377 static ffelexHandler ffeexpr_token_percent_name_ (ffelexToken t);
378 static ffelexHandler ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr,
379 ffelexToken t);
380 static ffelexHandler ffeexpr_token_elements_ (ffelexToken ft, ffebld expr,
381 ffelexToken t);
382 static ffelexHandler ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr,
383 ffelexToken t);
384 static ffelexHandler ffeexpr_token_substring_ (ffelexToken ft, ffebld expr,
385 ffelexToken t);
386 static ffelexHandler ffeexpr_token_substring_1_ (ffelexToken ft, ffebld expr,
387 ffelexToken t);
388 static ffelexHandler ffeexpr_token_substrp_ (ffelexToken t);
389 static ffelexHandler ffeexpr_token_intrincheck_ (ffelexToken t);
390 static ffelexHandler ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr,
391 ffelexToken t);
392 static ffelexHandler ffeexpr_token_anything_ (ffelexToken ft, ffebld expr,
393 ffelexToken t);
394 static void ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
395 ffelexToken decimal, ffelexToken fraction, ffelexToken exponent,
396 ffelexToken exponent_sign, ffelexToken exponent_digits);
397 static ffesymbol ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin);
398 static ffesymbol ffeexpr_sym_impdoitem_ (ffesymbol s, ffelexToken t);
399 static ffesymbol ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t);
400 static ffesymbol ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t);
401 static ffesymbol ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t);
402 static ffesymbol ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t);
403 static ffesymbol ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t);
404 static ffesymbol ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t);
405 static ffesymbol ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t);
406 static ffesymbol ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t);
407 static ffesymbol ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t);
408 static ffesymbol ffeexpr_declare_parenthesized_ (ffelexToken t,
409 bool maybe_intrin,
410 ffeexprParenType_ *paren_type);
411 static ffesymbol ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t);
412
413 /* Internal macros. */
414
415 #define ffeexpr_paren_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
416 #define ffeexpr_sym_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
417
418 /* ffeexpr_collapse_convert -- Collapse convert expr
419
420 ffebld expr;
421 ffelexToken token;
422 expr = ffeexpr_collapse_convert(expr,token);
423
424 If the result of the expr is a constant, replaces the expr with the
425 computed constant. */
426
427 ffebld
ffeexpr_collapse_convert(ffebld expr,ffelexToken t)428 ffeexpr_collapse_convert (ffebld expr, ffelexToken t)
429 {
430 ffebad error = FFEBAD;
431 ffebld l;
432 ffebldConstantUnion u;
433 ffeinfoBasictype bt;
434 ffeinfoKindtype kt;
435 ffetargetCharacterSize sz;
436 ffetargetCharacterSize sz2;
437
438 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
439 return expr;
440
441 l = ffebld_left (expr);
442
443 if (ffebld_op (l) != FFEBLD_opCONTER)
444 return expr;
445
446 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
447 {
448 case FFEINFO_basictypeANY:
449 return expr;
450
451 case FFEINFO_basictypeINTEGER:
452 sz = FFETARGET_charactersizeNONE;
453 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
454 {
455 #if FFETARGET_okINTEGER1
456 case FFEINFO_kindtypeINTEGER1:
457 switch (ffeinfo_basictype (ffebld_info (l)))
458 {
459 case FFEINFO_basictypeINTEGER:
460 switch (ffeinfo_kindtype (ffebld_info (l)))
461 {
462 #if FFETARGET_okINTEGER2
463 case FFEINFO_kindtypeINTEGER2:
464 error = ffetarget_convert_integer1_integer2
465 (ffebld_cu_ptr_integer1 (u),
466 ffebld_constant_integer2 (ffebld_conter (l)));
467 break;
468 #endif
469
470 #if FFETARGET_okINTEGER3
471 case FFEINFO_kindtypeINTEGER3:
472 error = ffetarget_convert_integer1_integer3
473 (ffebld_cu_ptr_integer1 (u),
474 ffebld_constant_integer3 (ffebld_conter (l)));
475 break;
476 #endif
477
478 #if FFETARGET_okINTEGER4
479 case FFEINFO_kindtypeINTEGER4:
480 error = ffetarget_convert_integer1_integer4
481 (ffebld_cu_ptr_integer1 (u),
482 ffebld_constant_integer4 (ffebld_conter (l)));
483 break;
484 #endif
485
486 default:
487 assert ("INTEGER1/INTEGER bad source kind type" == NULL);
488 break;
489 }
490 break;
491
492 case FFEINFO_basictypeREAL:
493 switch (ffeinfo_kindtype (ffebld_info (l)))
494 {
495 #if FFETARGET_okREAL1
496 case FFEINFO_kindtypeREAL1:
497 error = ffetarget_convert_integer1_real1
498 (ffebld_cu_ptr_integer1 (u),
499 ffebld_constant_real1 (ffebld_conter (l)));
500 break;
501 #endif
502
503 #if FFETARGET_okREAL2
504 case FFEINFO_kindtypeREAL2:
505 error = ffetarget_convert_integer1_real2
506 (ffebld_cu_ptr_integer1 (u),
507 ffebld_constant_real2 (ffebld_conter (l)));
508 break;
509 #endif
510
511 #if FFETARGET_okREAL3
512 case FFEINFO_kindtypeREAL3:
513 error = ffetarget_convert_integer1_real3
514 (ffebld_cu_ptr_integer1 (u),
515 ffebld_constant_real3 (ffebld_conter (l)));
516 break;
517 #endif
518
519 #if FFETARGET_okREAL4
520 case FFEINFO_kindtypeREAL4:
521 error = ffetarget_convert_integer1_real4
522 (ffebld_cu_ptr_integer1 (u),
523 ffebld_constant_real4 (ffebld_conter (l)));
524 break;
525 #endif
526
527 default:
528 assert ("INTEGER1/REAL bad source kind type" == NULL);
529 break;
530 }
531 break;
532
533 case FFEINFO_basictypeCOMPLEX:
534 switch (ffeinfo_kindtype (ffebld_info (l)))
535 {
536 #if FFETARGET_okCOMPLEX1
537 case FFEINFO_kindtypeREAL1:
538 error = ffetarget_convert_integer1_complex1
539 (ffebld_cu_ptr_integer1 (u),
540 ffebld_constant_complex1 (ffebld_conter (l)));
541 break;
542 #endif
543
544 #if FFETARGET_okCOMPLEX2
545 case FFEINFO_kindtypeREAL2:
546 error = ffetarget_convert_integer1_complex2
547 (ffebld_cu_ptr_integer1 (u),
548 ffebld_constant_complex2 (ffebld_conter (l)));
549 break;
550 #endif
551
552 #if FFETARGET_okCOMPLEX3
553 case FFEINFO_kindtypeREAL3:
554 error = ffetarget_convert_integer1_complex3
555 (ffebld_cu_ptr_integer1 (u),
556 ffebld_constant_complex3 (ffebld_conter (l)));
557 break;
558 #endif
559
560 #if FFETARGET_okCOMPLEX4
561 case FFEINFO_kindtypeREAL4:
562 error = ffetarget_convert_integer1_complex4
563 (ffebld_cu_ptr_integer1 (u),
564 ffebld_constant_complex4 (ffebld_conter (l)));
565 break;
566 #endif
567
568 default:
569 assert ("INTEGER1/COMPLEX bad source kind type" == NULL);
570 break;
571 }
572 break;
573
574 case FFEINFO_basictypeLOGICAL:
575 switch (ffeinfo_kindtype (ffebld_info (l)))
576 {
577 #if FFETARGET_okLOGICAL1
578 case FFEINFO_kindtypeLOGICAL1:
579 error = ffetarget_convert_integer1_logical1
580 (ffebld_cu_ptr_integer1 (u),
581 ffebld_constant_logical1 (ffebld_conter (l)));
582 break;
583 #endif
584
585 #if FFETARGET_okLOGICAL2
586 case FFEINFO_kindtypeLOGICAL2:
587 error = ffetarget_convert_integer1_logical2
588 (ffebld_cu_ptr_integer1 (u),
589 ffebld_constant_logical2 (ffebld_conter (l)));
590 break;
591 #endif
592
593 #if FFETARGET_okLOGICAL3
594 case FFEINFO_kindtypeLOGICAL3:
595 error = ffetarget_convert_integer1_logical3
596 (ffebld_cu_ptr_integer1 (u),
597 ffebld_constant_logical3 (ffebld_conter (l)));
598 break;
599 #endif
600
601 #if FFETARGET_okLOGICAL4
602 case FFEINFO_kindtypeLOGICAL4:
603 error = ffetarget_convert_integer1_logical4
604 (ffebld_cu_ptr_integer1 (u),
605 ffebld_constant_logical4 (ffebld_conter (l)));
606 break;
607 #endif
608
609 default:
610 assert ("INTEGER1/LOGICAL bad source kind type" == NULL);
611 break;
612 }
613 break;
614
615 case FFEINFO_basictypeCHARACTER:
616 error = ffetarget_convert_integer1_character1
617 (ffebld_cu_ptr_integer1 (u),
618 ffebld_constant_character1 (ffebld_conter (l)));
619 break;
620
621 case FFEINFO_basictypeHOLLERITH:
622 error = ffetarget_convert_integer1_hollerith
623 (ffebld_cu_ptr_integer1 (u),
624 ffebld_constant_hollerith (ffebld_conter (l)));
625 break;
626
627 case FFEINFO_basictypeTYPELESS:
628 error = ffetarget_convert_integer1_typeless
629 (ffebld_cu_ptr_integer1 (u),
630 ffebld_constant_typeless (ffebld_conter (l)));
631 break;
632
633 default:
634 assert ("INTEGER1 bad type" == NULL);
635 break;
636 }
637
638 /* If conversion operation is not implemented, return original expr. */
639 if (error == FFEBAD_NOCANDO)
640 return expr;
641
642 expr = ffebld_new_conter_with_orig
643 (ffebld_constant_new_integer1_val
644 (ffebld_cu_val_integer1 (u)), expr);
645 break;
646 #endif
647
648 #if FFETARGET_okINTEGER2
649 case FFEINFO_kindtypeINTEGER2:
650 switch (ffeinfo_basictype (ffebld_info (l)))
651 {
652 case FFEINFO_basictypeINTEGER:
653 switch (ffeinfo_kindtype (ffebld_info (l)))
654 {
655 #if FFETARGET_okINTEGER1
656 case FFEINFO_kindtypeINTEGER1:
657 error = ffetarget_convert_integer2_integer1
658 (ffebld_cu_ptr_integer2 (u),
659 ffebld_constant_integer1 (ffebld_conter (l)));
660 break;
661 #endif
662
663 #if FFETARGET_okINTEGER3
664 case FFEINFO_kindtypeINTEGER3:
665 error = ffetarget_convert_integer2_integer3
666 (ffebld_cu_ptr_integer2 (u),
667 ffebld_constant_integer3 (ffebld_conter (l)));
668 break;
669 #endif
670
671 #if FFETARGET_okINTEGER4
672 case FFEINFO_kindtypeINTEGER4:
673 error = ffetarget_convert_integer2_integer4
674 (ffebld_cu_ptr_integer2 (u),
675 ffebld_constant_integer4 (ffebld_conter (l)));
676 break;
677 #endif
678
679 default:
680 assert ("INTEGER2/INTEGER bad source kind type" == NULL);
681 break;
682 }
683 break;
684
685 case FFEINFO_basictypeREAL:
686 switch (ffeinfo_kindtype (ffebld_info (l)))
687 {
688 #if FFETARGET_okREAL1
689 case FFEINFO_kindtypeREAL1:
690 error = ffetarget_convert_integer2_real1
691 (ffebld_cu_ptr_integer2 (u),
692 ffebld_constant_real1 (ffebld_conter (l)));
693 break;
694 #endif
695
696 #if FFETARGET_okREAL2
697 case FFEINFO_kindtypeREAL2:
698 error = ffetarget_convert_integer2_real2
699 (ffebld_cu_ptr_integer2 (u),
700 ffebld_constant_real2 (ffebld_conter (l)));
701 break;
702 #endif
703
704 #if FFETARGET_okREAL3
705 case FFEINFO_kindtypeREAL3:
706 error = ffetarget_convert_integer2_real3
707 (ffebld_cu_ptr_integer2 (u),
708 ffebld_constant_real3 (ffebld_conter (l)));
709 break;
710 #endif
711
712 #if FFETARGET_okREAL4
713 case FFEINFO_kindtypeREAL4:
714 error = ffetarget_convert_integer2_real4
715 (ffebld_cu_ptr_integer2 (u),
716 ffebld_constant_real4 (ffebld_conter (l)));
717 break;
718 #endif
719
720 default:
721 assert ("INTEGER2/REAL bad source kind type" == NULL);
722 break;
723 }
724 break;
725
726 case FFEINFO_basictypeCOMPLEX:
727 switch (ffeinfo_kindtype (ffebld_info (l)))
728 {
729 #if FFETARGET_okCOMPLEX1
730 case FFEINFO_kindtypeREAL1:
731 error = ffetarget_convert_integer2_complex1
732 (ffebld_cu_ptr_integer2 (u),
733 ffebld_constant_complex1 (ffebld_conter (l)));
734 break;
735 #endif
736
737 #if FFETARGET_okCOMPLEX2
738 case FFEINFO_kindtypeREAL2:
739 error = ffetarget_convert_integer2_complex2
740 (ffebld_cu_ptr_integer2 (u),
741 ffebld_constant_complex2 (ffebld_conter (l)));
742 break;
743 #endif
744
745 #if FFETARGET_okCOMPLEX3
746 case FFEINFO_kindtypeREAL3:
747 error = ffetarget_convert_integer2_complex3
748 (ffebld_cu_ptr_integer2 (u),
749 ffebld_constant_complex3 (ffebld_conter (l)));
750 break;
751 #endif
752
753 #if FFETARGET_okCOMPLEX4
754 case FFEINFO_kindtypeREAL4:
755 error = ffetarget_convert_integer2_complex4
756 (ffebld_cu_ptr_integer2 (u),
757 ffebld_constant_complex4 (ffebld_conter (l)));
758 break;
759 #endif
760
761 default:
762 assert ("INTEGER2/COMPLEX bad source kind type" == NULL);
763 break;
764 }
765 break;
766
767 case FFEINFO_basictypeLOGICAL:
768 switch (ffeinfo_kindtype (ffebld_info (l)))
769 {
770 #if FFETARGET_okLOGICAL1
771 case FFEINFO_kindtypeLOGICAL1:
772 error = ffetarget_convert_integer2_logical1
773 (ffebld_cu_ptr_integer2 (u),
774 ffebld_constant_logical1 (ffebld_conter (l)));
775 break;
776 #endif
777
778 #if FFETARGET_okLOGICAL2
779 case FFEINFO_kindtypeLOGICAL2:
780 error = ffetarget_convert_integer2_logical2
781 (ffebld_cu_ptr_integer2 (u),
782 ffebld_constant_logical2 (ffebld_conter (l)));
783 break;
784 #endif
785
786 #if FFETARGET_okLOGICAL3
787 case FFEINFO_kindtypeLOGICAL3:
788 error = ffetarget_convert_integer2_logical3
789 (ffebld_cu_ptr_integer2 (u),
790 ffebld_constant_logical3 (ffebld_conter (l)));
791 break;
792 #endif
793
794 #if FFETARGET_okLOGICAL4
795 case FFEINFO_kindtypeLOGICAL4:
796 error = ffetarget_convert_integer2_logical4
797 (ffebld_cu_ptr_integer2 (u),
798 ffebld_constant_logical4 (ffebld_conter (l)));
799 break;
800 #endif
801
802 default:
803 assert ("INTEGER2/LOGICAL bad source kind type" == NULL);
804 break;
805 }
806 break;
807
808 case FFEINFO_basictypeCHARACTER:
809 error = ffetarget_convert_integer2_character1
810 (ffebld_cu_ptr_integer2 (u),
811 ffebld_constant_character1 (ffebld_conter (l)));
812 break;
813
814 case FFEINFO_basictypeHOLLERITH:
815 error = ffetarget_convert_integer2_hollerith
816 (ffebld_cu_ptr_integer2 (u),
817 ffebld_constant_hollerith (ffebld_conter (l)));
818 break;
819
820 case FFEINFO_basictypeTYPELESS:
821 error = ffetarget_convert_integer2_typeless
822 (ffebld_cu_ptr_integer2 (u),
823 ffebld_constant_typeless (ffebld_conter (l)));
824 break;
825
826 default:
827 assert ("INTEGER2 bad type" == NULL);
828 break;
829 }
830
831 /* If conversion operation is not implemented, return original expr. */
832 if (error == FFEBAD_NOCANDO)
833 return expr;
834
835 expr = ffebld_new_conter_with_orig
836 (ffebld_constant_new_integer2_val
837 (ffebld_cu_val_integer2 (u)), expr);
838 break;
839 #endif
840
841 #if FFETARGET_okINTEGER3
842 case FFEINFO_kindtypeINTEGER3:
843 switch (ffeinfo_basictype (ffebld_info (l)))
844 {
845 case FFEINFO_basictypeINTEGER:
846 switch (ffeinfo_kindtype (ffebld_info (l)))
847 {
848 #if FFETARGET_okINTEGER1
849 case FFEINFO_kindtypeINTEGER1:
850 error = ffetarget_convert_integer3_integer1
851 (ffebld_cu_ptr_integer3 (u),
852 ffebld_constant_integer1 (ffebld_conter (l)));
853 break;
854 #endif
855
856 #if FFETARGET_okINTEGER2
857 case FFEINFO_kindtypeINTEGER2:
858 error = ffetarget_convert_integer3_integer2
859 (ffebld_cu_ptr_integer3 (u),
860 ffebld_constant_integer2 (ffebld_conter (l)));
861 break;
862 #endif
863
864 #if FFETARGET_okINTEGER4
865 case FFEINFO_kindtypeINTEGER4:
866 error = ffetarget_convert_integer3_integer4
867 (ffebld_cu_ptr_integer3 (u),
868 ffebld_constant_integer4 (ffebld_conter (l)));
869 break;
870 #endif
871
872 default:
873 assert ("INTEGER3/INTEGER bad source kind type" == NULL);
874 break;
875 }
876 break;
877
878 case FFEINFO_basictypeREAL:
879 switch (ffeinfo_kindtype (ffebld_info (l)))
880 {
881 #if FFETARGET_okREAL1
882 case FFEINFO_kindtypeREAL1:
883 error = ffetarget_convert_integer3_real1
884 (ffebld_cu_ptr_integer3 (u),
885 ffebld_constant_real1 (ffebld_conter (l)));
886 break;
887 #endif
888
889 #if FFETARGET_okREAL2
890 case FFEINFO_kindtypeREAL2:
891 error = ffetarget_convert_integer3_real2
892 (ffebld_cu_ptr_integer3 (u),
893 ffebld_constant_real2 (ffebld_conter (l)));
894 break;
895 #endif
896
897 #if FFETARGET_okREAL3
898 case FFEINFO_kindtypeREAL3:
899 error = ffetarget_convert_integer3_real3
900 (ffebld_cu_ptr_integer3 (u),
901 ffebld_constant_real3 (ffebld_conter (l)));
902 break;
903 #endif
904
905 #if FFETARGET_okREAL4
906 case FFEINFO_kindtypeREAL4:
907 error = ffetarget_convert_integer3_real4
908 (ffebld_cu_ptr_integer3 (u),
909 ffebld_constant_real4 (ffebld_conter (l)));
910 break;
911 #endif
912
913 default:
914 assert ("INTEGER3/REAL bad source kind type" == NULL);
915 break;
916 }
917 break;
918
919 case FFEINFO_basictypeCOMPLEX:
920 switch (ffeinfo_kindtype (ffebld_info (l)))
921 {
922 #if FFETARGET_okCOMPLEX1
923 case FFEINFO_kindtypeREAL1:
924 error = ffetarget_convert_integer3_complex1
925 (ffebld_cu_ptr_integer3 (u),
926 ffebld_constant_complex1 (ffebld_conter (l)));
927 break;
928 #endif
929
930 #if FFETARGET_okCOMPLEX2
931 case FFEINFO_kindtypeREAL2:
932 error = ffetarget_convert_integer3_complex2
933 (ffebld_cu_ptr_integer3 (u),
934 ffebld_constant_complex2 (ffebld_conter (l)));
935 break;
936 #endif
937
938 #if FFETARGET_okCOMPLEX3
939 case FFEINFO_kindtypeREAL3:
940 error = ffetarget_convert_integer3_complex3
941 (ffebld_cu_ptr_integer3 (u),
942 ffebld_constant_complex3 (ffebld_conter (l)));
943 break;
944 #endif
945
946 #if FFETARGET_okCOMPLEX4
947 case FFEINFO_kindtypeREAL4:
948 error = ffetarget_convert_integer3_complex4
949 (ffebld_cu_ptr_integer3 (u),
950 ffebld_constant_complex4 (ffebld_conter (l)));
951 break;
952 #endif
953
954 default:
955 assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
956 break;
957 }
958 break;
959
960 case FFEINFO_basictypeLOGICAL:
961 switch (ffeinfo_kindtype (ffebld_info (l)))
962 {
963 #if FFETARGET_okLOGICAL1
964 case FFEINFO_kindtypeLOGICAL1:
965 error = ffetarget_convert_integer3_logical1
966 (ffebld_cu_ptr_integer3 (u),
967 ffebld_constant_logical1 (ffebld_conter (l)));
968 break;
969 #endif
970
971 #if FFETARGET_okLOGICAL2
972 case FFEINFO_kindtypeLOGICAL2:
973 error = ffetarget_convert_integer3_logical2
974 (ffebld_cu_ptr_integer3 (u),
975 ffebld_constant_logical2 (ffebld_conter (l)));
976 break;
977 #endif
978
979 #if FFETARGET_okLOGICAL3
980 case FFEINFO_kindtypeLOGICAL3:
981 error = ffetarget_convert_integer3_logical3
982 (ffebld_cu_ptr_integer3 (u),
983 ffebld_constant_logical3 (ffebld_conter (l)));
984 break;
985 #endif
986
987 #if FFETARGET_okLOGICAL4
988 case FFEINFO_kindtypeLOGICAL4:
989 error = ffetarget_convert_integer3_logical4
990 (ffebld_cu_ptr_integer3 (u),
991 ffebld_constant_logical4 (ffebld_conter (l)));
992 break;
993 #endif
994
995 default:
996 assert ("INTEGER3/LOGICAL bad source kind type" == NULL);
997 break;
998 }
999 break;
1000
1001 case FFEINFO_basictypeCHARACTER:
1002 error = ffetarget_convert_integer3_character1
1003 (ffebld_cu_ptr_integer3 (u),
1004 ffebld_constant_character1 (ffebld_conter (l)));
1005 break;
1006
1007 case FFEINFO_basictypeHOLLERITH:
1008 error = ffetarget_convert_integer3_hollerith
1009 (ffebld_cu_ptr_integer3 (u),
1010 ffebld_constant_hollerith (ffebld_conter (l)));
1011 break;
1012
1013 case FFEINFO_basictypeTYPELESS:
1014 error = ffetarget_convert_integer3_typeless
1015 (ffebld_cu_ptr_integer3 (u),
1016 ffebld_constant_typeless (ffebld_conter (l)));
1017 break;
1018
1019 default:
1020 assert ("INTEGER3 bad type" == NULL);
1021 break;
1022 }
1023
1024 /* If conversion operation is not implemented, return original expr. */
1025 if (error == FFEBAD_NOCANDO)
1026 return expr;
1027
1028 expr = ffebld_new_conter_with_orig
1029 (ffebld_constant_new_integer3_val
1030 (ffebld_cu_val_integer3 (u)), expr);
1031 break;
1032 #endif
1033
1034 #if FFETARGET_okINTEGER4
1035 case FFEINFO_kindtypeINTEGER4:
1036 switch (ffeinfo_basictype (ffebld_info (l)))
1037 {
1038 case FFEINFO_basictypeINTEGER:
1039 switch (ffeinfo_kindtype (ffebld_info (l)))
1040 {
1041 #if FFETARGET_okINTEGER1
1042 case FFEINFO_kindtypeINTEGER1:
1043 error = ffetarget_convert_integer4_integer1
1044 (ffebld_cu_ptr_integer4 (u),
1045 ffebld_constant_integer1 (ffebld_conter (l)));
1046 break;
1047 #endif
1048
1049 #if FFETARGET_okINTEGER2
1050 case FFEINFO_kindtypeINTEGER2:
1051 error = ffetarget_convert_integer4_integer2
1052 (ffebld_cu_ptr_integer4 (u),
1053 ffebld_constant_integer2 (ffebld_conter (l)));
1054 break;
1055 #endif
1056
1057 #if FFETARGET_okINTEGER3
1058 case FFEINFO_kindtypeINTEGER3:
1059 error = ffetarget_convert_integer4_integer3
1060 (ffebld_cu_ptr_integer4 (u),
1061 ffebld_constant_integer3 (ffebld_conter (l)));
1062 break;
1063 #endif
1064
1065 default:
1066 assert ("INTEGER4/INTEGER bad source kind type" == NULL);
1067 break;
1068 }
1069 break;
1070
1071 case FFEINFO_basictypeREAL:
1072 switch (ffeinfo_kindtype (ffebld_info (l)))
1073 {
1074 #if FFETARGET_okREAL1
1075 case FFEINFO_kindtypeREAL1:
1076 error = ffetarget_convert_integer4_real1
1077 (ffebld_cu_ptr_integer4 (u),
1078 ffebld_constant_real1 (ffebld_conter (l)));
1079 break;
1080 #endif
1081
1082 #if FFETARGET_okREAL2
1083 case FFEINFO_kindtypeREAL2:
1084 error = ffetarget_convert_integer4_real2
1085 (ffebld_cu_ptr_integer4 (u),
1086 ffebld_constant_real2 (ffebld_conter (l)));
1087 break;
1088 #endif
1089
1090 #if FFETARGET_okREAL3
1091 case FFEINFO_kindtypeREAL3:
1092 error = ffetarget_convert_integer4_real3
1093 (ffebld_cu_ptr_integer4 (u),
1094 ffebld_constant_real3 (ffebld_conter (l)));
1095 break;
1096 #endif
1097
1098 #if FFETARGET_okREAL4
1099 case FFEINFO_kindtypeREAL4:
1100 error = ffetarget_convert_integer4_real4
1101 (ffebld_cu_ptr_integer4 (u),
1102 ffebld_constant_real4 (ffebld_conter (l)));
1103 break;
1104 #endif
1105
1106 default:
1107 assert ("INTEGER4/REAL bad source kind type" == NULL);
1108 break;
1109 }
1110 break;
1111
1112 case FFEINFO_basictypeCOMPLEX:
1113 switch (ffeinfo_kindtype (ffebld_info (l)))
1114 {
1115 #if FFETARGET_okCOMPLEX1
1116 case FFEINFO_kindtypeREAL1:
1117 error = ffetarget_convert_integer4_complex1
1118 (ffebld_cu_ptr_integer4 (u),
1119 ffebld_constant_complex1 (ffebld_conter (l)));
1120 break;
1121 #endif
1122
1123 #if FFETARGET_okCOMPLEX2
1124 case FFEINFO_kindtypeREAL2:
1125 error = ffetarget_convert_integer4_complex2
1126 (ffebld_cu_ptr_integer4 (u),
1127 ffebld_constant_complex2 (ffebld_conter (l)));
1128 break;
1129 #endif
1130
1131 #if FFETARGET_okCOMPLEX3
1132 case FFEINFO_kindtypeREAL3:
1133 error = ffetarget_convert_integer4_complex3
1134 (ffebld_cu_ptr_integer4 (u),
1135 ffebld_constant_complex3 (ffebld_conter (l)));
1136 break;
1137 #endif
1138
1139 #if FFETARGET_okCOMPLEX4
1140 case FFEINFO_kindtypeREAL4:
1141 error = ffetarget_convert_integer4_complex4
1142 (ffebld_cu_ptr_integer4 (u),
1143 ffebld_constant_complex4 (ffebld_conter (l)));
1144 break;
1145 #endif
1146
1147 default:
1148 assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
1149 break;
1150 }
1151 break;
1152
1153 case FFEINFO_basictypeLOGICAL:
1154 switch (ffeinfo_kindtype (ffebld_info (l)))
1155 {
1156 #if FFETARGET_okLOGICAL1
1157 case FFEINFO_kindtypeLOGICAL1:
1158 error = ffetarget_convert_integer4_logical1
1159 (ffebld_cu_ptr_integer4 (u),
1160 ffebld_constant_logical1 (ffebld_conter (l)));
1161 break;
1162 #endif
1163
1164 #if FFETARGET_okLOGICAL2
1165 case FFEINFO_kindtypeLOGICAL2:
1166 error = ffetarget_convert_integer4_logical2
1167 (ffebld_cu_ptr_integer4 (u),
1168 ffebld_constant_logical2 (ffebld_conter (l)));
1169 break;
1170 #endif
1171
1172 #if FFETARGET_okLOGICAL3
1173 case FFEINFO_kindtypeLOGICAL3:
1174 error = ffetarget_convert_integer4_logical3
1175 (ffebld_cu_ptr_integer4 (u),
1176 ffebld_constant_logical3 (ffebld_conter (l)));
1177 break;
1178 #endif
1179
1180 #if FFETARGET_okLOGICAL4
1181 case FFEINFO_kindtypeLOGICAL4:
1182 error = ffetarget_convert_integer4_logical4
1183 (ffebld_cu_ptr_integer4 (u),
1184 ffebld_constant_logical4 (ffebld_conter (l)));
1185 break;
1186 #endif
1187
1188 default:
1189 assert ("INTEGER4/LOGICAL bad source kind type" == NULL);
1190 break;
1191 }
1192 break;
1193
1194 case FFEINFO_basictypeCHARACTER:
1195 error = ffetarget_convert_integer4_character1
1196 (ffebld_cu_ptr_integer4 (u),
1197 ffebld_constant_character1 (ffebld_conter (l)));
1198 break;
1199
1200 case FFEINFO_basictypeHOLLERITH:
1201 error = ffetarget_convert_integer4_hollerith
1202 (ffebld_cu_ptr_integer4 (u),
1203 ffebld_constant_hollerith (ffebld_conter (l)));
1204 break;
1205
1206 case FFEINFO_basictypeTYPELESS:
1207 error = ffetarget_convert_integer4_typeless
1208 (ffebld_cu_ptr_integer4 (u),
1209 ffebld_constant_typeless (ffebld_conter (l)));
1210 break;
1211
1212 default:
1213 assert ("INTEGER4 bad type" == NULL);
1214 break;
1215 }
1216
1217 /* If conversion operation is not implemented, return original expr. */
1218 if (error == FFEBAD_NOCANDO)
1219 return expr;
1220
1221 expr = ffebld_new_conter_with_orig
1222 (ffebld_constant_new_integer4_val
1223 (ffebld_cu_val_integer4 (u)), expr);
1224 break;
1225 #endif
1226
1227 default:
1228 assert ("bad integer kind type" == NULL);
1229 break;
1230 }
1231 break;
1232
1233 case FFEINFO_basictypeLOGICAL:
1234 sz = FFETARGET_charactersizeNONE;
1235 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1236 {
1237 #if FFETARGET_okLOGICAL1
1238 case FFEINFO_kindtypeLOGICAL1:
1239 switch (ffeinfo_basictype (ffebld_info (l)))
1240 {
1241 case FFEINFO_basictypeLOGICAL:
1242 switch (ffeinfo_kindtype (ffebld_info (l)))
1243 {
1244 #if FFETARGET_okLOGICAL2
1245 case FFEINFO_kindtypeLOGICAL2:
1246 error = ffetarget_convert_logical1_logical2
1247 (ffebld_cu_ptr_logical1 (u),
1248 ffebld_constant_logical2 (ffebld_conter (l)));
1249 break;
1250 #endif
1251
1252 #if FFETARGET_okLOGICAL3
1253 case FFEINFO_kindtypeLOGICAL3:
1254 error = ffetarget_convert_logical1_logical3
1255 (ffebld_cu_ptr_logical1 (u),
1256 ffebld_constant_logical3 (ffebld_conter (l)));
1257 break;
1258 #endif
1259
1260 #if FFETARGET_okLOGICAL4
1261 case FFEINFO_kindtypeLOGICAL4:
1262 error = ffetarget_convert_logical1_logical4
1263 (ffebld_cu_ptr_logical1 (u),
1264 ffebld_constant_logical4 (ffebld_conter (l)));
1265 break;
1266 #endif
1267
1268 default:
1269 assert ("LOGICAL1/LOGICAL bad source kind type" == NULL);
1270 break;
1271 }
1272 break;
1273
1274 case FFEINFO_basictypeINTEGER:
1275 switch (ffeinfo_kindtype (ffebld_info (l)))
1276 {
1277 #if FFETARGET_okINTEGER1
1278 case FFEINFO_kindtypeINTEGER1:
1279 error = ffetarget_convert_logical1_integer1
1280 (ffebld_cu_ptr_logical1 (u),
1281 ffebld_constant_integer1 (ffebld_conter (l)));
1282 break;
1283 #endif
1284
1285 #if FFETARGET_okINTEGER2
1286 case FFEINFO_kindtypeINTEGER2:
1287 error = ffetarget_convert_logical1_integer2
1288 (ffebld_cu_ptr_logical1 (u),
1289 ffebld_constant_integer2 (ffebld_conter (l)));
1290 break;
1291 #endif
1292
1293 #if FFETARGET_okINTEGER3
1294 case FFEINFO_kindtypeINTEGER3:
1295 error = ffetarget_convert_logical1_integer3
1296 (ffebld_cu_ptr_logical1 (u),
1297 ffebld_constant_integer3 (ffebld_conter (l)));
1298 break;
1299 #endif
1300
1301 #if FFETARGET_okINTEGER4
1302 case FFEINFO_kindtypeINTEGER4:
1303 error = ffetarget_convert_logical1_integer4
1304 (ffebld_cu_ptr_logical1 (u),
1305 ffebld_constant_integer4 (ffebld_conter (l)));
1306 break;
1307 #endif
1308
1309 default:
1310 assert ("LOGICAL1/INTEGER bad source kind type" == NULL);
1311 break;
1312 }
1313 break;
1314
1315 case FFEINFO_basictypeCHARACTER:
1316 error = ffetarget_convert_logical1_character1
1317 (ffebld_cu_ptr_logical1 (u),
1318 ffebld_constant_character1 (ffebld_conter (l)));
1319 break;
1320
1321 case FFEINFO_basictypeHOLLERITH:
1322 error = ffetarget_convert_logical1_hollerith
1323 (ffebld_cu_ptr_logical1 (u),
1324 ffebld_constant_hollerith (ffebld_conter (l)));
1325 break;
1326
1327 case FFEINFO_basictypeTYPELESS:
1328 error = ffetarget_convert_logical1_typeless
1329 (ffebld_cu_ptr_logical1 (u),
1330 ffebld_constant_typeless (ffebld_conter (l)));
1331 break;
1332
1333 default:
1334 assert ("LOGICAL1 bad type" == NULL);
1335 break;
1336 }
1337
1338 /* If conversion operation is not implemented, return original expr. */
1339 if (error == FFEBAD_NOCANDO)
1340 return expr;
1341
1342 expr = ffebld_new_conter_with_orig
1343 (ffebld_constant_new_logical1_val
1344 (ffebld_cu_val_logical1 (u)), expr);
1345 break;
1346 #endif
1347
1348 #if FFETARGET_okLOGICAL2
1349 case FFEINFO_kindtypeLOGICAL2:
1350 switch (ffeinfo_basictype (ffebld_info (l)))
1351 {
1352 case FFEINFO_basictypeLOGICAL:
1353 switch (ffeinfo_kindtype (ffebld_info (l)))
1354 {
1355 #if FFETARGET_okLOGICAL1
1356 case FFEINFO_kindtypeLOGICAL1:
1357 error = ffetarget_convert_logical2_logical1
1358 (ffebld_cu_ptr_logical2 (u),
1359 ffebld_constant_logical1 (ffebld_conter (l)));
1360 break;
1361 #endif
1362
1363 #if FFETARGET_okLOGICAL3
1364 case FFEINFO_kindtypeLOGICAL3:
1365 error = ffetarget_convert_logical2_logical3
1366 (ffebld_cu_ptr_logical2 (u),
1367 ffebld_constant_logical3 (ffebld_conter (l)));
1368 break;
1369 #endif
1370
1371 #if FFETARGET_okLOGICAL4
1372 case FFEINFO_kindtypeLOGICAL4:
1373 error = ffetarget_convert_logical2_logical4
1374 (ffebld_cu_ptr_logical2 (u),
1375 ffebld_constant_logical4 (ffebld_conter (l)));
1376 break;
1377 #endif
1378
1379 default:
1380 assert ("LOGICAL2/LOGICAL bad source kind type" == NULL);
1381 break;
1382 }
1383 break;
1384
1385 case FFEINFO_basictypeINTEGER:
1386 switch (ffeinfo_kindtype (ffebld_info (l)))
1387 {
1388 #if FFETARGET_okINTEGER1
1389 case FFEINFO_kindtypeINTEGER1:
1390 error = ffetarget_convert_logical2_integer1
1391 (ffebld_cu_ptr_logical2 (u),
1392 ffebld_constant_integer1 (ffebld_conter (l)));
1393 break;
1394 #endif
1395
1396 #if FFETARGET_okINTEGER2
1397 case FFEINFO_kindtypeINTEGER2:
1398 error = ffetarget_convert_logical2_integer2
1399 (ffebld_cu_ptr_logical2 (u),
1400 ffebld_constant_integer2 (ffebld_conter (l)));
1401 break;
1402 #endif
1403
1404 #if FFETARGET_okINTEGER3
1405 case FFEINFO_kindtypeINTEGER3:
1406 error = ffetarget_convert_logical2_integer3
1407 (ffebld_cu_ptr_logical2 (u),
1408 ffebld_constant_integer3 (ffebld_conter (l)));
1409 break;
1410 #endif
1411
1412 #if FFETARGET_okINTEGER4
1413 case FFEINFO_kindtypeINTEGER4:
1414 error = ffetarget_convert_logical2_integer4
1415 (ffebld_cu_ptr_logical2 (u),
1416 ffebld_constant_integer4 (ffebld_conter (l)));
1417 break;
1418 #endif
1419
1420 default:
1421 assert ("LOGICAL2/INTEGER bad source kind type" == NULL);
1422 break;
1423 }
1424 break;
1425
1426 case FFEINFO_basictypeCHARACTER:
1427 error = ffetarget_convert_logical2_character1
1428 (ffebld_cu_ptr_logical2 (u),
1429 ffebld_constant_character1 (ffebld_conter (l)));
1430 break;
1431
1432 case FFEINFO_basictypeHOLLERITH:
1433 error = ffetarget_convert_logical2_hollerith
1434 (ffebld_cu_ptr_logical2 (u),
1435 ffebld_constant_hollerith (ffebld_conter (l)));
1436 break;
1437
1438 case FFEINFO_basictypeTYPELESS:
1439 error = ffetarget_convert_logical2_typeless
1440 (ffebld_cu_ptr_logical2 (u),
1441 ffebld_constant_typeless (ffebld_conter (l)));
1442 break;
1443
1444 default:
1445 assert ("LOGICAL2 bad type" == NULL);
1446 break;
1447 }
1448
1449 /* If conversion operation is not implemented, return original expr. */
1450 if (error == FFEBAD_NOCANDO)
1451 return expr;
1452
1453 expr = ffebld_new_conter_with_orig
1454 (ffebld_constant_new_logical2_val
1455 (ffebld_cu_val_logical2 (u)), expr);
1456 break;
1457 #endif
1458
1459 #if FFETARGET_okLOGICAL3
1460 case FFEINFO_kindtypeLOGICAL3:
1461 switch (ffeinfo_basictype (ffebld_info (l)))
1462 {
1463 case FFEINFO_basictypeLOGICAL:
1464 switch (ffeinfo_kindtype (ffebld_info (l)))
1465 {
1466 #if FFETARGET_okLOGICAL1
1467 case FFEINFO_kindtypeLOGICAL1:
1468 error = ffetarget_convert_logical3_logical1
1469 (ffebld_cu_ptr_logical3 (u),
1470 ffebld_constant_logical1 (ffebld_conter (l)));
1471 break;
1472 #endif
1473
1474 #if FFETARGET_okLOGICAL2
1475 case FFEINFO_kindtypeLOGICAL2:
1476 error = ffetarget_convert_logical3_logical2
1477 (ffebld_cu_ptr_logical3 (u),
1478 ffebld_constant_logical2 (ffebld_conter (l)));
1479 break;
1480 #endif
1481
1482 #if FFETARGET_okLOGICAL4
1483 case FFEINFO_kindtypeLOGICAL4:
1484 error = ffetarget_convert_logical3_logical4
1485 (ffebld_cu_ptr_logical3 (u),
1486 ffebld_constant_logical4 (ffebld_conter (l)));
1487 break;
1488 #endif
1489
1490 default:
1491 assert ("LOGICAL3/LOGICAL bad source kind type" == NULL);
1492 break;
1493 }
1494 break;
1495
1496 case FFEINFO_basictypeINTEGER:
1497 switch (ffeinfo_kindtype (ffebld_info (l)))
1498 {
1499 #if FFETARGET_okINTEGER1
1500 case FFEINFO_kindtypeINTEGER1:
1501 error = ffetarget_convert_logical3_integer1
1502 (ffebld_cu_ptr_logical3 (u),
1503 ffebld_constant_integer1 (ffebld_conter (l)));
1504 break;
1505 #endif
1506
1507 #if FFETARGET_okINTEGER2
1508 case FFEINFO_kindtypeINTEGER2:
1509 error = ffetarget_convert_logical3_integer2
1510 (ffebld_cu_ptr_logical3 (u),
1511 ffebld_constant_integer2 (ffebld_conter (l)));
1512 break;
1513 #endif
1514
1515 #if FFETARGET_okINTEGER3
1516 case FFEINFO_kindtypeINTEGER3:
1517 error = ffetarget_convert_logical3_integer3
1518 (ffebld_cu_ptr_logical3 (u),
1519 ffebld_constant_integer3 (ffebld_conter (l)));
1520 break;
1521 #endif
1522
1523 #if FFETARGET_okINTEGER4
1524 case FFEINFO_kindtypeINTEGER4:
1525 error = ffetarget_convert_logical3_integer4
1526 (ffebld_cu_ptr_logical3 (u),
1527 ffebld_constant_integer4 (ffebld_conter (l)));
1528 break;
1529 #endif
1530
1531 default:
1532 assert ("LOGICAL3/INTEGER bad source kind type" == NULL);
1533 break;
1534 }
1535 break;
1536
1537 case FFEINFO_basictypeCHARACTER:
1538 error = ffetarget_convert_logical3_character1
1539 (ffebld_cu_ptr_logical3 (u),
1540 ffebld_constant_character1 (ffebld_conter (l)));
1541 break;
1542
1543 case FFEINFO_basictypeHOLLERITH:
1544 error = ffetarget_convert_logical3_hollerith
1545 (ffebld_cu_ptr_logical3 (u),
1546 ffebld_constant_hollerith (ffebld_conter (l)));
1547 break;
1548
1549 case FFEINFO_basictypeTYPELESS:
1550 error = ffetarget_convert_logical3_typeless
1551 (ffebld_cu_ptr_logical3 (u),
1552 ffebld_constant_typeless (ffebld_conter (l)));
1553 break;
1554
1555 default:
1556 assert ("LOGICAL3 bad type" == NULL);
1557 break;
1558 }
1559
1560 /* If conversion operation is not implemented, return original expr. */
1561 if (error == FFEBAD_NOCANDO)
1562 return expr;
1563
1564 expr = ffebld_new_conter_with_orig
1565 (ffebld_constant_new_logical3_val
1566 (ffebld_cu_val_logical3 (u)), expr);
1567 break;
1568 #endif
1569
1570 #if FFETARGET_okLOGICAL4
1571 case FFEINFO_kindtypeLOGICAL4:
1572 switch (ffeinfo_basictype (ffebld_info (l)))
1573 {
1574 case FFEINFO_basictypeLOGICAL:
1575 switch (ffeinfo_kindtype (ffebld_info (l)))
1576 {
1577 #if FFETARGET_okLOGICAL1
1578 case FFEINFO_kindtypeLOGICAL1:
1579 error = ffetarget_convert_logical4_logical1
1580 (ffebld_cu_ptr_logical4 (u),
1581 ffebld_constant_logical1 (ffebld_conter (l)));
1582 break;
1583 #endif
1584
1585 #if FFETARGET_okLOGICAL2
1586 case FFEINFO_kindtypeLOGICAL2:
1587 error = ffetarget_convert_logical4_logical2
1588 (ffebld_cu_ptr_logical4 (u),
1589 ffebld_constant_logical2 (ffebld_conter (l)));
1590 break;
1591 #endif
1592
1593 #if FFETARGET_okLOGICAL3
1594 case FFEINFO_kindtypeLOGICAL3:
1595 error = ffetarget_convert_logical4_logical3
1596 (ffebld_cu_ptr_logical4 (u),
1597 ffebld_constant_logical3 (ffebld_conter (l)));
1598 break;
1599 #endif
1600
1601 default:
1602 assert ("LOGICAL4/LOGICAL bad source kind type" == NULL);
1603 break;
1604 }
1605 break;
1606
1607 case FFEINFO_basictypeINTEGER:
1608 switch (ffeinfo_kindtype (ffebld_info (l)))
1609 {
1610 #if FFETARGET_okINTEGER1
1611 case FFEINFO_kindtypeINTEGER1:
1612 error = ffetarget_convert_logical4_integer1
1613 (ffebld_cu_ptr_logical4 (u),
1614 ffebld_constant_integer1 (ffebld_conter (l)));
1615 break;
1616 #endif
1617
1618 #if FFETARGET_okINTEGER2
1619 case FFEINFO_kindtypeINTEGER2:
1620 error = ffetarget_convert_logical4_integer2
1621 (ffebld_cu_ptr_logical4 (u),
1622 ffebld_constant_integer2 (ffebld_conter (l)));
1623 break;
1624 #endif
1625
1626 #if FFETARGET_okINTEGER3
1627 case FFEINFO_kindtypeINTEGER3:
1628 error = ffetarget_convert_logical4_integer3
1629 (ffebld_cu_ptr_logical4 (u),
1630 ffebld_constant_integer3 (ffebld_conter (l)));
1631 break;
1632 #endif
1633
1634 #if FFETARGET_okINTEGER4
1635 case FFEINFO_kindtypeINTEGER4:
1636 error = ffetarget_convert_logical4_integer4
1637 (ffebld_cu_ptr_logical4 (u),
1638 ffebld_constant_integer4 (ffebld_conter (l)));
1639 break;
1640 #endif
1641
1642 default:
1643 assert ("LOGICAL4/INTEGER bad source kind type" == NULL);
1644 break;
1645 }
1646 break;
1647
1648 case FFEINFO_basictypeCHARACTER:
1649 error = ffetarget_convert_logical4_character1
1650 (ffebld_cu_ptr_logical4 (u),
1651 ffebld_constant_character1 (ffebld_conter (l)));
1652 break;
1653
1654 case FFEINFO_basictypeHOLLERITH:
1655 error = ffetarget_convert_logical4_hollerith
1656 (ffebld_cu_ptr_logical4 (u),
1657 ffebld_constant_hollerith (ffebld_conter (l)));
1658 break;
1659
1660 case FFEINFO_basictypeTYPELESS:
1661 error = ffetarget_convert_logical4_typeless
1662 (ffebld_cu_ptr_logical4 (u),
1663 ffebld_constant_typeless (ffebld_conter (l)));
1664 break;
1665
1666 default:
1667 assert ("LOGICAL4 bad type" == NULL);
1668 break;
1669 }
1670
1671 /* If conversion operation is not implemented, return original expr. */
1672 if (error == FFEBAD_NOCANDO)
1673 return expr;
1674
1675 expr = ffebld_new_conter_with_orig
1676 (ffebld_constant_new_logical4_val
1677 (ffebld_cu_val_logical4 (u)), expr);
1678 break;
1679 #endif
1680
1681 default:
1682 assert ("bad logical kind type" == NULL);
1683 break;
1684 }
1685 break;
1686
1687 case FFEINFO_basictypeREAL:
1688 sz = FFETARGET_charactersizeNONE;
1689 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1690 {
1691 #if FFETARGET_okREAL1
1692 case FFEINFO_kindtypeREAL1:
1693 switch (ffeinfo_basictype (ffebld_info (l)))
1694 {
1695 case FFEINFO_basictypeINTEGER:
1696 switch (ffeinfo_kindtype (ffebld_info (l)))
1697 {
1698 #if FFETARGET_okINTEGER1
1699 case FFEINFO_kindtypeINTEGER1:
1700 error = ffetarget_convert_real1_integer1
1701 (ffebld_cu_ptr_real1 (u),
1702 ffebld_constant_integer1 (ffebld_conter (l)));
1703 break;
1704 #endif
1705
1706 #if FFETARGET_okINTEGER2
1707 case FFEINFO_kindtypeINTEGER2:
1708 error = ffetarget_convert_real1_integer2
1709 (ffebld_cu_ptr_real1 (u),
1710 ffebld_constant_integer2 (ffebld_conter (l)));
1711 break;
1712 #endif
1713
1714 #if FFETARGET_okINTEGER3
1715 case FFEINFO_kindtypeINTEGER3:
1716 error = ffetarget_convert_real1_integer3
1717 (ffebld_cu_ptr_real1 (u),
1718 ffebld_constant_integer3 (ffebld_conter (l)));
1719 break;
1720 #endif
1721
1722 #if FFETARGET_okINTEGER4
1723 case FFEINFO_kindtypeINTEGER4:
1724 error = ffetarget_convert_real1_integer4
1725 (ffebld_cu_ptr_real1 (u),
1726 ffebld_constant_integer4 (ffebld_conter (l)));
1727 break;
1728 #endif
1729
1730 default:
1731 assert ("REAL1/INTEGER bad source kind type" == NULL);
1732 break;
1733 }
1734 break;
1735
1736 case FFEINFO_basictypeREAL:
1737 switch (ffeinfo_kindtype (ffebld_info (l)))
1738 {
1739 #if FFETARGET_okREAL2
1740 case FFEINFO_kindtypeREAL2:
1741 error = ffetarget_convert_real1_real2
1742 (ffebld_cu_ptr_real1 (u),
1743 ffebld_constant_real2 (ffebld_conter (l)));
1744 break;
1745 #endif
1746
1747 #if FFETARGET_okREAL3
1748 case FFEINFO_kindtypeREAL3:
1749 error = ffetarget_convert_real1_real3
1750 (ffebld_cu_ptr_real1 (u),
1751 ffebld_constant_real3 (ffebld_conter (l)));
1752 break;
1753 #endif
1754
1755 #if FFETARGET_okREAL4
1756 case FFEINFO_kindtypeREAL4:
1757 error = ffetarget_convert_real1_real4
1758 (ffebld_cu_ptr_real1 (u),
1759 ffebld_constant_real4 (ffebld_conter (l)));
1760 break;
1761 #endif
1762
1763 default:
1764 assert ("REAL1/REAL bad source kind type" == NULL);
1765 break;
1766 }
1767 break;
1768
1769 case FFEINFO_basictypeCOMPLEX:
1770 switch (ffeinfo_kindtype (ffebld_info (l)))
1771 {
1772 #if FFETARGET_okCOMPLEX1
1773 case FFEINFO_kindtypeREAL1:
1774 error = ffetarget_convert_real1_complex1
1775 (ffebld_cu_ptr_real1 (u),
1776 ffebld_constant_complex1 (ffebld_conter (l)));
1777 break;
1778 #endif
1779
1780 #if FFETARGET_okCOMPLEX2
1781 case FFEINFO_kindtypeREAL2:
1782 error = ffetarget_convert_real1_complex2
1783 (ffebld_cu_ptr_real1 (u),
1784 ffebld_constant_complex2 (ffebld_conter (l)));
1785 break;
1786 #endif
1787
1788 #if FFETARGET_okCOMPLEX3
1789 case FFEINFO_kindtypeREAL3:
1790 error = ffetarget_convert_real1_complex3
1791 (ffebld_cu_ptr_real1 (u),
1792 ffebld_constant_complex3 (ffebld_conter (l)));
1793 break;
1794 #endif
1795
1796 #if FFETARGET_okCOMPLEX4
1797 case FFEINFO_kindtypeREAL4:
1798 error = ffetarget_convert_real1_complex4
1799 (ffebld_cu_ptr_real1 (u),
1800 ffebld_constant_complex4 (ffebld_conter (l)));
1801 break;
1802 #endif
1803
1804 default:
1805 assert ("REAL1/COMPLEX bad source kind type" == NULL);
1806 break;
1807 }
1808 break;
1809
1810 case FFEINFO_basictypeCHARACTER:
1811 error = ffetarget_convert_real1_character1
1812 (ffebld_cu_ptr_real1 (u),
1813 ffebld_constant_character1 (ffebld_conter (l)));
1814 break;
1815
1816 case FFEINFO_basictypeHOLLERITH:
1817 error = ffetarget_convert_real1_hollerith
1818 (ffebld_cu_ptr_real1 (u),
1819 ffebld_constant_hollerith (ffebld_conter (l)));
1820 break;
1821
1822 case FFEINFO_basictypeTYPELESS:
1823 error = ffetarget_convert_real1_typeless
1824 (ffebld_cu_ptr_real1 (u),
1825 ffebld_constant_typeless (ffebld_conter (l)));
1826 break;
1827
1828 default:
1829 assert ("REAL1 bad type" == NULL);
1830 break;
1831 }
1832
1833 /* If conversion operation is not implemented, return original expr. */
1834 if (error == FFEBAD_NOCANDO)
1835 return expr;
1836
1837 expr = ffebld_new_conter_with_orig
1838 (ffebld_constant_new_real1_val
1839 (ffebld_cu_val_real1 (u)), expr);
1840 break;
1841 #endif
1842
1843 #if FFETARGET_okREAL2
1844 case FFEINFO_kindtypeREAL2:
1845 switch (ffeinfo_basictype (ffebld_info (l)))
1846 {
1847 case FFEINFO_basictypeINTEGER:
1848 switch (ffeinfo_kindtype (ffebld_info (l)))
1849 {
1850 #if FFETARGET_okINTEGER1
1851 case FFEINFO_kindtypeINTEGER1:
1852 error = ffetarget_convert_real2_integer1
1853 (ffebld_cu_ptr_real2 (u),
1854 ffebld_constant_integer1 (ffebld_conter (l)));
1855 break;
1856 #endif
1857
1858 #if FFETARGET_okINTEGER2
1859 case FFEINFO_kindtypeINTEGER2:
1860 error = ffetarget_convert_real2_integer2
1861 (ffebld_cu_ptr_real2 (u),
1862 ffebld_constant_integer2 (ffebld_conter (l)));
1863 break;
1864 #endif
1865
1866 #if FFETARGET_okINTEGER3
1867 case FFEINFO_kindtypeINTEGER3:
1868 error = ffetarget_convert_real2_integer3
1869 (ffebld_cu_ptr_real2 (u),
1870 ffebld_constant_integer3 (ffebld_conter (l)));
1871 break;
1872 #endif
1873
1874 #if FFETARGET_okINTEGER4
1875 case FFEINFO_kindtypeINTEGER4:
1876 error = ffetarget_convert_real2_integer4
1877 (ffebld_cu_ptr_real2 (u),
1878 ffebld_constant_integer4 (ffebld_conter (l)));
1879 break;
1880 #endif
1881
1882 default:
1883 assert ("REAL2/INTEGER bad source kind type" == NULL);
1884 break;
1885 }
1886 break;
1887
1888 case FFEINFO_basictypeREAL:
1889 switch (ffeinfo_kindtype (ffebld_info (l)))
1890 {
1891 #if FFETARGET_okREAL1
1892 case FFEINFO_kindtypeREAL1:
1893 error = ffetarget_convert_real2_real1
1894 (ffebld_cu_ptr_real2 (u),
1895 ffebld_constant_real1 (ffebld_conter (l)));
1896 break;
1897 #endif
1898
1899 #if FFETARGET_okREAL3
1900 case FFEINFO_kindtypeREAL3:
1901 error = ffetarget_convert_real2_real3
1902 (ffebld_cu_ptr_real2 (u),
1903 ffebld_constant_real3 (ffebld_conter (l)));
1904 break;
1905 #endif
1906
1907 #if FFETARGET_okREAL4
1908 case FFEINFO_kindtypeREAL4:
1909 error = ffetarget_convert_real2_real4
1910 (ffebld_cu_ptr_real2 (u),
1911 ffebld_constant_real4 (ffebld_conter (l)));
1912 break;
1913 #endif
1914
1915 default:
1916 assert ("REAL2/REAL bad source kind type" == NULL);
1917 break;
1918 }
1919 break;
1920
1921 case FFEINFO_basictypeCOMPLEX:
1922 switch (ffeinfo_kindtype (ffebld_info (l)))
1923 {
1924 #if FFETARGET_okCOMPLEX1
1925 case FFEINFO_kindtypeREAL1:
1926 error = ffetarget_convert_real2_complex1
1927 (ffebld_cu_ptr_real2 (u),
1928 ffebld_constant_complex1 (ffebld_conter (l)));
1929 break;
1930 #endif
1931
1932 #if FFETARGET_okCOMPLEX2
1933 case FFEINFO_kindtypeREAL2:
1934 error = ffetarget_convert_real2_complex2
1935 (ffebld_cu_ptr_real2 (u),
1936 ffebld_constant_complex2 (ffebld_conter (l)));
1937 break;
1938 #endif
1939
1940 #if FFETARGET_okCOMPLEX3
1941 case FFEINFO_kindtypeREAL3:
1942 error = ffetarget_convert_real2_complex3
1943 (ffebld_cu_ptr_real2 (u),
1944 ffebld_constant_complex3 (ffebld_conter (l)));
1945 break;
1946 #endif
1947
1948 #if FFETARGET_okCOMPLEX4
1949 case FFEINFO_kindtypeREAL4:
1950 error = ffetarget_convert_real2_complex4
1951 (ffebld_cu_ptr_real2 (u),
1952 ffebld_constant_complex4 (ffebld_conter (l)));
1953 break;
1954 #endif
1955
1956 default:
1957 assert ("REAL2/COMPLEX bad source kind type" == NULL);
1958 break;
1959 }
1960 break;
1961
1962 case FFEINFO_basictypeCHARACTER:
1963 error = ffetarget_convert_real2_character1
1964 (ffebld_cu_ptr_real2 (u),
1965 ffebld_constant_character1 (ffebld_conter (l)));
1966 break;
1967
1968 case FFEINFO_basictypeHOLLERITH:
1969 error = ffetarget_convert_real2_hollerith
1970 (ffebld_cu_ptr_real2 (u),
1971 ffebld_constant_hollerith (ffebld_conter (l)));
1972 break;
1973
1974 case FFEINFO_basictypeTYPELESS:
1975 error = ffetarget_convert_real2_typeless
1976 (ffebld_cu_ptr_real2 (u),
1977 ffebld_constant_typeless (ffebld_conter (l)));
1978 break;
1979
1980 default:
1981 assert ("REAL2 bad type" == NULL);
1982 break;
1983 }
1984
1985 /* If conversion operation is not implemented, return original expr. */
1986 if (error == FFEBAD_NOCANDO)
1987 return expr;
1988
1989 expr = ffebld_new_conter_with_orig
1990 (ffebld_constant_new_real2_val
1991 (ffebld_cu_val_real2 (u)), expr);
1992 break;
1993 #endif
1994
1995 #if FFETARGET_okREAL3
1996 case FFEINFO_kindtypeREAL3:
1997 switch (ffeinfo_basictype (ffebld_info (l)))
1998 {
1999 case FFEINFO_basictypeINTEGER:
2000 switch (ffeinfo_kindtype (ffebld_info (l)))
2001 {
2002 #if FFETARGET_okINTEGER1
2003 case FFEINFO_kindtypeINTEGER1:
2004 error = ffetarget_convert_real3_integer1
2005 (ffebld_cu_ptr_real3 (u),
2006 ffebld_constant_integer1 (ffebld_conter (l)));
2007 break;
2008 #endif
2009
2010 #if FFETARGET_okINTEGER2
2011 case FFEINFO_kindtypeINTEGER2:
2012 error = ffetarget_convert_real3_integer2
2013 (ffebld_cu_ptr_real3 (u),
2014 ffebld_constant_integer2 (ffebld_conter (l)));
2015 break;
2016 #endif
2017
2018 #if FFETARGET_okINTEGER3
2019 case FFEINFO_kindtypeINTEGER3:
2020 error = ffetarget_convert_real3_integer3
2021 (ffebld_cu_ptr_real3 (u),
2022 ffebld_constant_integer3 (ffebld_conter (l)));
2023 break;
2024 #endif
2025
2026 #if FFETARGET_okINTEGER4
2027 case FFEINFO_kindtypeINTEGER4:
2028 error = ffetarget_convert_real3_integer4
2029 (ffebld_cu_ptr_real3 (u),
2030 ffebld_constant_integer4 (ffebld_conter (l)));
2031 break;
2032 #endif
2033
2034 default:
2035 assert ("REAL3/INTEGER bad source kind type" == NULL);
2036 break;
2037 }
2038 break;
2039
2040 case FFEINFO_basictypeREAL:
2041 switch (ffeinfo_kindtype (ffebld_info (l)))
2042 {
2043 #if FFETARGET_okREAL1
2044 case FFEINFO_kindtypeREAL1:
2045 error = ffetarget_convert_real3_real1
2046 (ffebld_cu_ptr_real3 (u),
2047 ffebld_constant_real1 (ffebld_conter (l)));
2048 break;
2049 #endif
2050
2051 #if FFETARGET_okREAL2
2052 case FFEINFO_kindtypeREAL2:
2053 error = ffetarget_convert_real3_real2
2054 (ffebld_cu_ptr_real3 (u),
2055 ffebld_constant_real2 (ffebld_conter (l)));
2056 break;
2057 #endif
2058
2059 #if FFETARGET_okREAL4
2060 case FFEINFO_kindtypeREAL4:
2061 error = ffetarget_convert_real3_real4
2062 (ffebld_cu_ptr_real3 (u),
2063 ffebld_constant_real4 (ffebld_conter (l)));
2064 break;
2065 #endif
2066
2067 default:
2068 assert ("REAL3/REAL bad source kind type" == NULL);
2069 break;
2070 }
2071 break;
2072
2073 case FFEINFO_basictypeCOMPLEX:
2074 switch (ffeinfo_kindtype (ffebld_info (l)))
2075 {
2076 #if FFETARGET_okCOMPLEX1
2077 case FFEINFO_kindtypeREAL1:
2078 error = ffetarget_convert_real3_complex1
2079 (ffebld_cu_ptr_real3 (u),
2080 ffebld_constant_complex1 (ffebld_conter (l)));
2081 break;
2082 #endif
2083
2084 #if FFETARGET_okCOMPLEX2
2085 case FFEINFO_kindtypeREAL2:
2086 error = ffetarget_convert_real3_complex2
2087 (ffebld_cu_ptr_real3 (u),
2088 ffebld_constant_complex2 (ffebld_conter (l)));
2089 break;
2090 #endif
2091
2092 #if FFETARGET_okCOMPLEX3
2093 case FFEINFO_kindtypeREAL3:
2094 error = ffetarget_convert_real3_complex3
2095 (ffebld_cu_ptr_real3 (u),
2096 ffebld_constant_complex3 (ffebld_conter (l)));
2097 break;
2098 #endif
2099
2100 #if FFETARGET_okCOMPLEX4
2101 case FFEINFO_kindtypeREAL4:
2102 error = ffetarget_convert_real3_complex4
2103 (ffebld_cu_ptr_real3 (u),
2104 ffebld_constant_complex4 (ffebld_conter (l)));
2105 break;
2106 #endif
2107
2108 default:
2109 assert ("REAL3/COMPLEX bad source kind type" == NULL);
2110 break;
2111 }
2112 break;
2113
2114 case FFEINFO_basictypeCHARACTER:
2115 error = ffetarget_convert_real3_character1
2116 (ffebld_cu_ptr_real3 (u),
2117 ffebld_constant_character1 (ffebld_conter (l)));
2118 break;
2119
2120 case FFEINFO_basictypeHOLLERITH:
2121 error = ffetarget_convert_real3_hollerith
2122 (ffebld_cu_ptr_real3 (u),
2123 ffebld_constant_hollerith (ffebld_conter (l)));
2124 break;
2125
2126 case FFEINFO_basictypeTYPELESS:
2127 error = ffetarget_convert_real3_typeless
2128 (ffebld_cu_ptr_real3 (u),
2129 ffebld_constant_typeless (ffebld_conter (l)));
2130 break;
2131
2132 default:
2133 assert ("REAL3 bad type" == NULL);
2134 break;
2135 }
2136
2137 /* If conversion operation is not implemented, return original expr. */
2138 if (error == FFEBAD_NOCANDO)
2139 return expr;
2140
2141 expr = ffebld_new_conter_with_orig
2142 (ffebld_constant_new_real3_val
2143 (ffebld_cu_val_real3 (u)), expr);
2144 break;
2145 #endif
2146
2147 #if FFETARGET_okREAL4
2148 case FFEINFO_kindtypeREAL4:
2149 switch (ffeinfo_basictype (ffebld_info (l)))
2150 {
2151 case FFEINFO_basictypeINTEGER:
2152 switch (ffeinfo_kindtype (ffebld_info (l)))
2153 {
2154 #if FFETARGET_okINTEGER1
2155 case FFEINFO_kindtypeINTEGER1:
2156 error = ffetarget_convert_real4_integer1
2157 (ffebld_cu_ptr_real4 (u),
2158 ffebld_constant_integer1 (ffebld_conter (l)));
2159 break;
2160 #endif
2161
2162 #if FFETARGET_okINTEGER2
2163 case FFEINFO_kindtypeINTEGER2:
2164 error = ffetarget_convert_real4_integer2
2165 (ffebld_cu_ptr_real4 (u),
2166 ffebld_constant_integer2 (ffebld_conter (l)));
2167 break;
2168 #endif
2169
2170 #if FFETARGET_okINTEGER3
2171 case FFEINFO_kindtypeINTEGER3:
2172 error = ffetarget_convert_real4_integer3
2173 (ffebld_cu_ptr_real4 (u),
2174 ffebld_constant_integer3 (ffebld_conter (l)));
2175 break;
2176 #endif
2177
2178 #if FFETARGET_okINTEGER4
2179 case FFEINFO_kindtypeINTEGER4:
2180 error = ffetarget_convert_real4_integer4
2181 (ffebld_cu_ptr_real4 (u),
2182 ffebld_constant_integer4 (ffebld_conter (l)));
2183 break;
2184 #endif
2185
2186 default:
2187 assert ("REAL4/INTEGER bad source kind type" == NULL);
2188 break;
2189 }
2190 break;
2191
2192 case FFEINFO_basictypeREAL:
2193 switch (ffeinfo_kindtype (ffebld_info (l)))
2194 {
2195 #if FFETARGET_okREAL1
2196 case FFEINFO_kindtypeREAL1:
2197 error = ffetarget_convert_real4_real1
2198 (ffebld_cu_ptr_real4 (u),
2199 ffebld_constant_real1 (ffebld_conter (l)));
2200 break;
2201 #endif
2202
2203 #if FFETARGET_okREAL2
2204 case FFEINFO_kindtypeREAL2:
2205 error = ffetarget_convert_real4_real2
2206 (ffebld_cu_ptr_real4 (u),
2207 ffebld_constant_real2 (ffebld_conter (l)));
2208 break;
2209 #endif
2210
2211 #if FFETARGET_okREAL3
2212 case FFEINFO_kindtypeREAL3:
2213 error = ffetarget_convert_real4_real3
2214 (ffebld_cu_ptr_real4 (u),
2215 ffebld_constant_real3 (ffebld_conter (l)));
2216 break;
2217 #endif
2218
2219 default:
2220 assert ("REAL4/REAL bad source kind type" == NULL);
2221 break;
2222 }
2223 break;
2224
2225 case FFEINFO_basictypeCOMPLEX:
2226 switch (ffeinfo_kindtype (ffebld_info (l)))
2227 {
2228 #if FFETARGET_okCOMPLEX1
2229 case FFEINFO_kindtypeREAL1:
2230 error = ffetarget_convert_real4_complex1
2231 (ffebld_cu_ptr_real4 (u),
2232 ffebld_constant_complex1 (ffebld_conter (l)));
2233 break;
2234 #endif
2235
2236 #if FFETARGET_okCOMPLEX2
2237 case FFEINFO_kindtypeREAL2:
2238 error = ffetarget_convert_real4_complex2
2239 (ffebld_cu_ptr_real4 (u),
2240 ffebld_constant_complex2 (ffebld_conter (l)));
2241 break;
2242 #endif
2243
2244 #if FFETARGET_okCOMPLEX3
2245 case FFEINFO_kindtypeREAL3:
2246 error = ffetarget_convert_real4_complex3
2247 (ffebld_cu_ptr_real4 (u),
2248 ffebld_constant_complex3 (ffebld_conter (l)));
2249 break;
2250 #endif
2251
2252 #if FFETARGET_okCOMPLEX4
2253 case FFEINFO_kindtypeREAL4:
2254 error = ffetarget_convert_real4_complex4
2255 (ffebld_cu_ptr_real4 (u),
2256 ffebld_constant_complex4 (ffebld_conter (l)));
2257 break;
2258 #endif
2259
2260 default:
2261 assert ("REAL4/COMPLEX bad source kind type" == NULL);
2262 break;
2263 }
2264 break;
2265
2266 case FFEINFO_basictypeCHARACTER:
2267 error = ffetarget_convert_real4_character1
2268 (ffebld_cu_ptr_real4 (u),
2269 ffebld_constant_character1 (ffebld_conter (l)));
2270 break;
2271
2272 case FFEINFO_basictypeHOLLERITH:
2273 error = ffetarget_convert_real4_hollerith
2274 (ffebld_cu_ptr_real4 (u),
2275 ffebld_constant_hollerith (ffebld_conter (l)));
2276 break;
2277
2278 case FFEINFO_basictypeTYPELESS:
2279 error = ffetarget_convert_real4_typeless
2280 (ffebld_cu_ptr_real4 (u),
2281 ffebld_constant_typeless (ffebld_conter (l)));
2282 break;
2283
2284 default:
2285 assert ("REAL4 bad type" == NULL);
2286 break;
2287 }
2288
2289 /* If conversion operation is not implemented, return original expr. */
2290 if (error == FFEBAD_NOCANDO)
2291 return expr;
2292
2293 expr = ffebld_new_conter_with_orig
2294 (ffebld_constant_new_real4_val
2295 (ffebld_cu_val_real4 (u)), expr);
2296 break;
2297 #endif
2298
2299 default:
2300 assert ("bad real kind type" == NULL);
2301 break;
2302 }
2303 break;
2304
2305 case FFEINFO_basictypeCOMPLEX:
2306 sz = FFETARGET_charactersizeNONE;
2307 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2308 {
2309 #if FFETARGET_okCOMPLEX1
2310 case FFEINFO_kindtypeREAL1:
2311 switch (ffeinfo_basictype (ffebld_info (l)))
2312 {
2313 case FFEINFO_basictypeINTEGER:
2314 switch (ffeinfo_kindtype (ffebld_info (l)))
2315 {
2316 #if FFETARGET_okINTEGER1
2317 case FFEINFO_kindtypeINTEGER1:
2318 error = ffetarget_convert_complex1_integer1
2319 (ffebld_cu_ptr_complex1 (u),
2320 ffebld_constant_integer1 (ffebld_conter (l)));
2321 break;
2322 #endif
2323
2324 #if FFETARGET_okINTEGER2
2325 case FFEINFO_kindtypeINTEGER2:
2326 error = ffetarget_convert_complex1_integer2
2327 (ffebld_cu_ptr_complex1 (u),
2328 ffebld_constant_integer2 (ffebld_conter (l)));
2329 break;
2330 #endif
2331
2332 #if FFETARGET_okINTEGER3
2333 case FFEINFO_kindtypeINTEGER3:
2334 error = ffetarget_convert_complex1_integer3
2335 (ffebld_cu_ptr_complex1 (u),
2336 ffebld_constant_integer3 (ffebld_conter (l)));
2337 break;
2338 #endif
2339
2340 #if FFETARGET_okINTEGER4
2341 case FFEINFO_kindtypeINTEGER4:
2342 error = ffetarget_convert_complex1_integer4
2343 (ffebld_cu_ptr_complex1 (u),
2344 ffebld_constant_integer4 (ffebld_conter (l)));
2345 break;
2346 #endif
2347
2348 default:
2349 assert ("COMPLEX1/INTEGER bad source kind type" == NULL);
2350 break;
2351 }
2352 break;
2353
2354 case FFEINFO_basictypeREAL:
2355 switch (ffeinfo_kindtype (ffebld_info (l)))
2356 {
2357 #if FFETARGET_okREAL1
2358 case FFEINFO_kindtypeREAL1:
2359 error = ffetarget_convert_complex1_real1
2360 (ffebld_cu_ptr_complex1 (u),
2361 ffebld_constant_real1 (ffebld_conter (l)));
2362 break;
2363 #endif
2364
2365 #if FFETARGET_okREAL2
2366 case FFEINFO_kindtypeREAL2:
2367 error = ffetarget_convert_complex1_real2
2368 (ffebld_cu_ptr_complex1 (u),
2369 ffebld_constant_real2 (ffebld_conter (l)));
2370 break;
2371 #endif
2372
2373 #if FFETARGET_okREAL3
2374 case FFEINFO_kindtypeREAL3:
2375 error = ffetarget_convert_complex1_real3
2376 (ffebld_cu_ptr_complex1 (u),
2377 ffebld_constant_real3 (ffebld_conter (l)));
2378 break;
2379 #endif
2380
2381 #if FFETARGET_okREAL4
2382 case FFEINFO_kindtypeREAL4:
2383 error = ffetarget_convert_complex1_real4
2384 (ffebld_cu_ptr_complex1 (u),
2385 ffebld_constant_real4 (ffebld_conter (l)));
2386 break;
2387 #endif
2388
2389 default:
2390 assert ("COMPLEX1/REAL bad source kind type" == NULL);
2391 break;
2392 }
2393 break;
2394
2395 case FFEINFO_basictypeCOMPLEX:
2396 switch (ffeinfo_kindtype (ffebld_info (l)))
2397 {
2398 #if FFETARGET_okCOMPLEX2
2399 case FFEINFO_kindtypeREAL2:
2400 error = ffetarget_convert_complex1_complex2
2401 (ffebld_cu_ptr_complex1 (u),
2402 ffebld_constant_complex2 (ffebld_conter (l)));
2403 break;
2404 #endif
2405
2406 #if FFETARGET_okCOMPLEX3
2407 case FFEINFO_kindtypeREAL3:
2408 error = ffetarget_convert_complex1_complex3
2409 (ffebld_cu_ptr_complex1 (u),
2410 ffebld_constant_complex3 (ffebld_conter (l)));
2411 break;
2412 #endif
2413
2414 #if FFETARGET_okCOMPLEX4
2415 case FFEINFO_kindtypeREAL4:
2416 error = ffetarget_convert_complex1_complex4
2417 (ffebld_cu_ptr_complex1 (u),
2418 ffebld_constant_complex4 (ffebld_conter (l)));
2419 break;
2420 #endif
2421
2422 default:
2423 assert ("COMPLEX1/COMPLEX bad source kind type" == NULL);
2424 break;
2425 }
2426 break;
2427
2428 case FFEINFO_basictypeCHARACTER:
2429 error = ffetarget_convert_complex1_character1
2430 (ffebld_cu_ptr_complex1 (u),
2431 ffebld_constant_character1 (ffebld_conter (l)));
2432 break;
2433
2434 case FFEINFO_basictypeHOLLERITH:
2435 error = ffetarget_convert_complex1_hollerith
2436 (ffebld_cu_ptr_complex1 (u),
2437 ffebld_constant_hollerith (ffebld_conter (l)));
2438 break;
2439
2440 case FFEINFO_basictypeTYPELESS:
2441 error = ffetarget_convert_complex1_typeless
2442 (ffebld_cu_ptr_complex1 (u),
2443 ffebld_constant_typeless (ffebld_conter (l)));
2444 break;
2445
2446 default:
2447 assert ("COMPLEX1 bad type" == NULL);
2448 break;
2449 }
2450
2451 /* If conversion operation is not implemented, return original expr. */
2452 if (error == FFEBAD_NOCANDO)
2453 return expr;
2454
2455 expr = ffebld_new_conter_with_orig
2456 (ffebld_constant_new_complex1_val
2457 (ffebld_cu_val_complex1 (u)), expr);
2458 break;
2459 #endif
2460
2461 #if FFETARGET_okCOMPLEX2
2462 case FFEINFO_kindtypeREAL2:
2463 switch (ffeinfo_basictype (ffebld_info (l)))
2464 {
2465 case FFEINFO_basictypeINTEGER:
2466 switch (ffeinfo_kindtype (ffebld_info (l)))
2467 {
2468 #if FFETARGET_okINTEGER1
2469 case FFEINFO_kindtypeINTEGER1:
2470 error = ffetarget_convert_complex2_integer1
2471 (ffebld_cu_ptr_complex2 (u),
2472 ffebld_constant_integer1 (ffebld_conter (l)));
2473 break;
2474 #endif
2475
2476 #if FFETARGET_okINTEGER2
2477 case FFEINFO_kindtypeINTEGER2:
2478 error = ffetarget_convert_complex2_integer2
2479 (ffebld_cu_ptr_complex2 (u),
2480 ffebld_constant_integer2 (ffebld_conter (l)));
2481 break;
2482 #endif
2483
2484 #if FFETARGET_okINTEGER3
2485 case FFEINFO_kindtypeINTEGER3:
2486 error = ffetarget_convert_complex2_integer3
2487 (ffebld_cu_ptr_complex2 (u),
2488 ffebld_constant_integer3 (ffebld_conter (l)));
2489 break;
2490 #endif
2491
2492 #if FFETARGET_okINTEGER4
2493 case FFEINFO_kindtypeINTEGER4:
2494 error = ffetarget_convert_complex2_integer4
2495 (ffebld_cu_ptr_complex2 (u),
2496 ffebld_constant_integer4 (ffebld_conter (l)));
2497 break;
2498 #endif
2499
2500 default:
2501 assert ("COMPLEX2/INTEGER bad source kind type" == NULL);
2502 break;
2503 }
2504 break;
2505
2506 case FFEINFO_basictypeREAL:
2507 switch (ffeinfo_kindtype (ffebld_info (l)))
2508 {
2509 #if FFETARGET_okREAL1
2510 case FFEINFO_kindtypeREAL1:
2511 error = ffetarget_convert_complex2_real1
2512 (ffebld_cu_ptr_complex2 (u),
2513 ffebld_constant_real1 (ffebld_conter (l)));
2514 break;
2515 #endif
2516
2517 #if FFETARGET_okREAL2
2518 case FFEINFO_kindtypeREAL2:
2519 error = ffetarget_convert_complex2_real2
2520 (ffebld_cu_ptr_complex2 (u),
2521 ffebld_constant_real2 (ffebld_conter (l)));
2522 break;
2523 #endif
2524
2525 #if FFETARGET_okREAL3
2526 case FFEINFO_kindtypeREAL3:
2527 error = ffetarget_convert_complex2_real3
2528 (ffebld_cu_ptr_complex2 (u),
2529 ffebld_constant_real3 (ffebld_conter (l)));
2530 break;
2531 #endif
2532
2533 #if FFETARGET_okREAL4
2534 case FFEINFO_kindtypeREAL4:
2535 error = ffetarget_convert_complex2_real4
2536 (ffebld_cu_ptr_complex2 (u),
2537 ffebld_constant_real4 (ffebld_conter (l)));
2538 break;
2539 #endif
2540
2541 default:
2542 assert ("COMPLEX2/REAL bad source kind type" == NULL);
2543 break;
2544 }
2545 break;
2546
2547 case FFEINFO_basictypeCOMPLEX:
2548 switch (ffeinfo_kindtype (ffebld_info (l)))
2549 {
2550 #if FFETARGET_okCOMPLEX1
2551 case FFEINFO_kindtypeREAL1:
2552 error = ffetarget_convert_complex2_complex1
2553 (ffebld_cu_ptr_complex2 (u),
2554 ffebld_constant_complex1 (ffebld_conter (l)));
2555 break;
2556 #endif
2557
2558 #if FFETARGET_okCOMPLEX3
2559 case FFEINFO_kindtypeREAL3:
2560 error = ffetarget_convert_complex2_complex3
2561 (ffebld_cu_ptr_complex2 (u),
2562 ffebld_constant_complex3 (ffebld_conter (l)));
2563 break;
2564 #endif
2565
2566 #if FFETARGET_okCOMPLEX4
2567 case FFEINFO_kindtypeREAL4:
2568 error = ffetarget_convert_complex2_complex4
2569 (ffebld_cu_ptr_complex2 (u),
2570 ffebld_constant_complex4 (ffebld_conter (l)));
2571 break;
2572 #endif
2573
2574 default:
2575 assert ("COMPLEX2/COMPLEX bad source kind type" == NULL);
2576 break;
2577 }
2578 break;
2579
2580 case FFEINFO_basictypeCHARACTER:
2581 error = ffetarget_convert_complex2_character1
2582 (ffebld_cu_ptr_complex2 (u),
2583 ffebld_constant_character1 (ffebld_conter (l)));
2584 break;
2585
2586 case FFEINFO_basictypeHOLLERITH:
2587 error = ffetarget_convert_complex2_hollerith
2588 (ffebld_cu_ptr_complex2 (u),
2589 ffebld_constant_hollerith (ffebld_conter (l)));
2590 break;
2591
2592 case FFEINFO_basictypeTYPELESS:
2593 error = ffetarget_convert_complex2_typeless
2594 (ffebld_cu_ptr_complex2 (u),
2595 ffebld_constant_typeless (ffebld_conter (l)));
2596 break;
2597
2598 default:
2599 assert ("COMPLEX2 bad type" == NULL);
2600 break;
2601 }
2602
2603 /* If conversion operation is not implemented, return original expr. */
2604 if (error == FFEBAD_NOCANDO)
2605 return expr;
2606
2607 expr = ffebld_new_conter_with_orig
2608 (ffebld_constant_new_complex2_val
2609 (ffebld_cu_val_complex2 (u)), expr);
2610 break;
2611 #endif
2612
2613 #if FFETARGET_okCOMPLEX3
2614 case FFEINFO_kindtypeREAL3:
2615 switch (ffeinfo_basictype (ffebld_info (l)))
2616 {
2617 case FFEINFO_basictypeINTEGER:
2618 switch (ffeinfo_kindtype (ffebld_info (l)))
2619 {
2620 #if FFETARGET_okINTEGER1
2621 case FFEINFO_kindtypeINTEGER1:
2622 error = ffetarget_convert_complex3_integer1
2623 (ffebld_cu_ptr_complex3 (u),
2624 ffebld_constant_integer1 (ffebld_conter (l)));
2625 break;
2626 #endif
2627
2628 #if FFETARGET_okINTEGER2
2629 case FFEINFO_kindtypeINTEGER2:
2630 error = ffetarget_convert_complex3_integer2
2631 (ffebld_cu_ptr_complex3 (u),
2632 ffebld_constant_integer2 (ffebld_conter (l)));
2633 break;
2634 #endif
2635
2636 #if FFETARGET_okINTEGER3
2637 case FFEINFO_kindtypeINTEGER3:
2638 error = ffetarget_convert_complex3_integer3
2639 (ffebld_cu_ptr_complex3 (u),
2640 ffebld_constant_integer3 (ffebld_conter (l)));
2641 break;
2642 #endif
2643
2644 #if FFETARGET_okINTEGER4
2645 case FFEINFO_kindtypeINTEGER4:
2646 error = ffetarget_convert_complex3_integer4
2647 (ffebld_cu_ptr_complex3 (u),
2648 ffebld_constant_integer4 (ffebld_conter (l)));
2649 break;
2650 #endif
2651
2652 default:
2653 assert ("COMPLEX3/INTEGER bad source kind type" == NULL);
2654 break;
2655 }
2656 break;
2657
2658 case FFEINFO_basictypeREAL:
2659 switch (ffeinfo_kindtype (ffebld_info (l)))
2660 {
2661 #if FFETARGET_okREAL1
2662 case FFEINFO_kindtypeREAL1:
2663 error = ffetarget_convert_complex3_real1
2664 (ffebld_cu_ptr_complex3 (u),
2665 ffebld_constant_real1 (ffebld_conter (l)));
2666 break;
2667 #endif
2668
2669 #if FFETARGET_okREAL2
2670 case FFEINFO_kindtypeREAL2:
2671 error = ffetarget_convert_complex3_real2
2672 (ffebld_cu_ptr_complex3 (u),
2673 ffebld_constant_real2 (ffebld_conter (l)));
2674 break;
2675 #endif
2676
2677 #if FFETARGET_okREAL3
2678 case FFEINFO_kindtypeREAL3:
2679 error = ffetarget_convert_complex3_real3
2680 (ffebld_cu_ptr_complex3 (u),
2681 ffebld_constant_real3 (ffebld_conter (l)));
2682 break;
2683 #endif
2684
2685 #if FFETARGET_okREAL4
2686 case FFEINFO_kindtypeREAL4:
2687 error = ffetarget_convert_complex3_real4
2688 (ffebld_cu_ptr_complex3 (u),
2689 ffebld_constant_real4 (ffebld_conter (l)));
2690 break;
2691 #endif
2692
2693 default:
2694 assert ("COMPLEX3/REAL bad source kind type" == NULL);
2695 break;
2696 }
2697 break;
2698
2699 case FFEINFO_basictypeCOMPLEX:
2700 switch (ffeinfo_kindtype (ffebld_info (l)))
2701 {
2702 #if FFETARGET_okCOMPLEX1
2703 case FFEINFO_kindtypeREAL1:
2704 error = ffetarget_convert_complex3_complex1
2705 (ffebld_cu_ptr_complex3 (u),
2706 ffebld_constant_complex1 (ffebld_conter (l)));
2707 break;
2708 #endif
2709
2710 #if FFETARGET_okCOMPLEX2
2711 case FFEINFO_kindtypeREAL2:
2712 error = ffetarget_convert_complex3_complex2
2713 (ffebld_cu_ptr_complex3 (u),
2714 ffebld_constant_complex2 (ffebld_conter (l)));
2715 break;
2716 #endif
2717
2718 #if FFETARGET_okCOMPLEX4
2719 case FFEINFO_kindtypeREAL4:
2720 error = ffetarget_convert_complex3_complex4
2721 (ffebld_cu_ptr_complex3 (u),
2722 ffebld_constant_complex4 (ffebld_conter (l)));
2723 break;
2724 #endif
2725
2726 default:
2727 assert ("COMPLEX3/COMPLEX bad source kind type" == NULL);
2728 break;
2729 }
2730 break;
2731
2732 case FFEINFO_basictypeCHARACTER:
2733 error = ffetarget_convert_complex3_character1
2734 (ffebld_cu_ptr_complex3 (u),
2735 ffebld_constant_character1 (ffebld_conter (l)));
2736 break;
2737
2738 case FFEINFO_basictypeHOLLERITH:
2739 error = ffetarget_convert_complex3_hollerith
2740 (ffebld_cu_ptr_complex3 (u),
2741 ffebld_constant_hollerith (ffebld_conter (l)));
2742 break;
2743
2744 case FFEINFO_basictypeTYPELESS:
2745 error = ffetarget_convert_complex3_typeless
2746 (ffebld_cu_ptr_complex3 (u),
2747 ffebld_constant_typeless (ffebld_conter (l)));
2748 break;
2749
2750 default:
2751 assert ("COMPLEX3 bad type" == NULL);
2752 break;
2753 }
2754
2755 /* If conversion operation is not implemented, return original expr. */
2756 if (error == FFEBAD_NOCANDO)
2757 return expr;
2758
2759 expr = ffebld_new_conter_with_orig
2760 (ffebld_constant_new_complex3_val
2761 (ffebld_cu_val_complex3 (u)), expr);
2762 break;
2763 #endif
2764
2765 #if FFETARGET_okCOMPLEX4
2766 case FFEINFO_kindtypeREAL4:
2767 switch (ffeinfo_basictype (ffebld_info (l)))
2768 {
2769 case FFEINFO_basictypeINTEGER:
2770 switch (ffeinfo_kindtype (ffebld_info (l)))
2771 {
2772 #if FFETARGET_okINTEGER1
2773 case FFEINFO_kindtypeINTEGER1:
2774 error = ffetarget_convert_complex4_integer1
2775 (ffebld_cu_ptr_complex4 (u),
2776 ffebld_constant_integer1 (ffebld_conter (l)));
2777 break;
2778 #endif
2779
2780 #if FFETARGET_okINTEGER2
2781 case FFEINFO_kindtypeINTEGER2:
2782 error = ffetarget_convert_complex4_integer2
2783 (ffebld_cu_ptr_complex4 (u),
2784 ffebld_constant_integer2 (ffebld_conter (l)));
2785 break;
2786 #endif
2787
2788 #if FFETARGET_okINTEGER3
2789 case FFEINFO_kindtypeINTEGER3:
2790 error = ffetarget_convert_complex4_integer3
2791 (ffebld_cu_ptr_complex4 (u),
2792 ffebld_constant_integer3 (ffebld_conter (l)));
2793 break;
2794 #endif
2795
2796 #if FFETARGET_okINTEGER4
2797 case FFEINFO_kindtypeINTEGER4:
2798 error = ffetarget_convert_complex4_integer4
2799 (ffebld_cu_ptr_complex4 (u),
2800 ffebld_constant_integer4 (ffebld_conter (l)));
2801 break;
2802 #endif
2803
2804 default:
2805 assert ("COMPLEX4/INTEGER bad source kind type" == NULL);
2806 break;
2807 }
2808 break;
2809
2810 case FFEINFO_basictypeREAL:
2811 switch (ffeinfo_kindtype (ffebld_info (l)))
2812 {
2813 #if FFETARGET_okREAL1
2814 case FFEINFO_kindtypeREAL1:
2815 error = ffetarget_convert_complex4_real1
2816 (ffebld_cu_ptr_complex4 (u),
2817 ffebld_constant_real1 (ffebld_conter (l)));
2818 break;
2819 #endif
2820
2821 #if FFETARGET_okREAL2
2822 case FFEINFO_kindtypeREAL2:
2823 error = ffetarget_convert_complex4_real2
2824 (ffebld_cu_ptr_complex4 (u),
2825 ffebld_constant_real2 (ffebld_conter (l)));
2826 break;
2827 #endif
2828
2829 #if FFETARGET_okREAL3
2830 case FFEINFO_kindtypeREAL3:
2831 error = ffetarget_convert_complex4_real3
2832 (ffebld_cu_ptr_complex4 (u),
2833 ffebld_constant_real3 (ffebld_conter (l)));
2834 break;
2835 #endif
2836
2837 #if FFETARGET_okREAL4
2838 case FFEINFO_kindtypeREAL4:
2839 error = ffetarget_convert_complex4_real4
2840 (ffebld_cu_ptr_complex4 (u),
2841 ffebld_constant_real4 (ffebld_conter (l)));
2842 break;
2843 #endif
2844
2845 default:
2846 assert ("COMPLEX4/REAL bad source kind type" == NULL);
2847 break;
2848 }
2849 break;
2850
2851 case FFEINFO_basictypeCOMPLEX:
2852 switch (ffeinfo_kindtype (ffebld_info (l)))
2853 {
2854 #if FFETARGET_okCOMPLEX1
2855 case FFEINFO_kindtypeREAL1:
2856 error = ffetarget_convert_complex4_complex1
2857 (ffebld_cu_ptr_complex4 (u),
2858 ffebld_constant_complex1 (ffebld_conter (l)));
2859 break;
2860 #endif
2861
2862 #if FFETARGET_okCOMPLEX2
2863 case FFEINFO_kindtypeREAL2:
2864 error = ffetarget_convert_complex4_complex2
2865 (ffebld_cu_ptr_complex4 (u),
2866 ffebld_constant_complex2 (ffebld_conter (l)));
2867 break;
2868 #endif
2869
2870 #if FFETARGET_okCOMPLEX3
2871 case FFEINFO_kindtypeREAL3:
2872 error = ffetarget_convert_complex4_complex3
2873 (ffebld_cu_ptr_complex4 (u),
2874 ffebld_constant_complex3 (ffebld_conter (l)));
2875 break;
2876 #endif
2877
2878 default:
2879 assert ("COMPLEX4/COMPLEX bad source kind type" == NULL);
2880 break;
2881 }
2882 break;
2883
2884 case FFEINFO_basictypeCHARACTER:
2885 error = ffetarget_convert_complex4_character1
2886 (ffebld_cu_ptr_complex4 (u),
2887 ffebld_constant_character1 (ffebld_conter (l)));
2888 break;
2889
2890 case FFEINFO_basictypeHOLLERITH:
2891 error = ffetarget_convert_complex4_hollerith
2892 (ffebld_cu_ptr_complex4 (u),
2893 ffebld_constant_hollerith (ffebld_conter (l)));
2894 break;
2895
2896 case FFEINFO_basictypeTYPELESS:
2897 error = ffetarget_convert_complex4_typeless
2898 (ffebld_cu_ptr_complex4 (u),
2899 ffebld_constant_typeless (ffebld_conter (l)));
2900 break;
2901
2902 default:
2903 assert ("COMPLEX4 bad type" == NULL);
2904 break;
2905 }
2906
2907 /* If conversion operation is not implemented, return original expr. */
2908 if (error == FFEBAD_NOCANDO)
2909 return expr;
2910
2911 expr = ffebld_new_conter_with_orig
2912 (ffebld_constant_new_complex4_val
2913 (ffebld_cu_val_complex4 (u)), expr);
2914 break;
2915 #endif
2916
2917 default:
2918 assert ("bad complex kind type" == NULL);
2919 break;
2920 }
2921 break;
2922
2923 case FFEINFO_basictypeCHARACTER:
2924 if ((sz = ffebld_size (expr)) == FFETARGET_charactersizeNONE)
2925 return expr;
2926 kt = ffeinfo_kindtype (ffebld_info (expr));
2927 switch (kt)
2928 {
2929 #if FFETARGET_okCHARACTER1
2930 case FFEINFO_kindtypeCHARACTER1:
2931 switch (ffeinfo_basictype (ffebld_info (l)))
2932 {
2933 case FFEINFO_basictypeCHARACTER:
2934 if ((sz2 = ffebld_size (l)) == FFETARGET_charactersizeNONE)
2935 return expr;
2936 assert (kt == ffeinfo_kindtype (ffebld_info (l)));
2937 assert (sz2 == ffetarget_length_character1
2938 (ffebld_constant_character1
2939 (ffebld_conter (l))));
2940 error
2941 = ffetarget_convert_character1_character1
2942 (ffebld_cu_ptr_character1 (u), sz,
2943 ffebld_constant_character1 (ffebld_conter (l)),
2944 ffebld_constant_pool ());
2945 break;
2946
2947 case FFEINFO_basictypeINTEGER:
2948 switch (ffeinfo_kindtype (ffebld_info (l)))
2949 {
2950 #if FFETARGET_okINTEGER1
2951 case FFEINFO_kindtypeINTEGER1:
2952 error
2953 = ffetarget_convert_character1_integer1
2954 (ffebld_cu_ptr_character1 (u),
2955 sz,
2956 ffebld_constant_integer1 (ffebld_conter (l)),
2957 ffebld_constant_pool ());
2958 break;
2959 #endif
2960
2961 #if FFETARGET_okINTEGER2
2962 case FFEINFO_kindtypeINTEGER2:
2963 error
2964 = ffetarget_convert_character1_integer2
2965 (ffebld_cu_ptr_character1 (u),
2966 sz,
2967 ffebld_constant_integer2 (ffebld_conter (l)),
2968 ffebld_constant_pool ());
2969 break;
2970 #endif
2971
2972 #if FFETARGET_okINTEGER3
2973 case FFEINFO_kindtypeINTEGER3:
2974 error
2975 = ffetarget_convert_character1_integer3
2976 (ffebld_cu_ptr_character1 (u),
2977 sz,
2978 ffebld_constant_integer3 (ffebld_conter (l)),
2979 ffebld_constant_pool ());
2980 break;
2981 #endif
2982
2983 #if FFETARGET_okINTEGER4
2984 case FFEINFO_kindtypeINTEGER4:
2985 error
2986 = ffetarget_convert_character1_integer4
2987 (ffebld_cu_ptr_character1 (u),
2988 sz,
2989 ffebld_constant_integer4 (ffebld_conter (l)),
2990 ffebld_constant_pool ());
2991 break;
2992 #endif
2993
2994 default:
2995 assert ("CHARACTER1/INTEGER bad source kind type" == NULL);
2996 break;
2997 }
2998 break;
2999
3000 case FFEINFO_basictypeLOGICAL:
3001 switch (ffeinfo_kindtype (ffebld_info (l)))
3002 {
3003 #if FFETARGET_okLOGICAL1
3004 case FFEINFO_kindtypeLOGICAL1:
3005 error
3006 = ffetarget_convert_character1_logical1
3007 (ffebld_cu_ptr_character1 (u),
3008 sz,
3009 ffebld_constant_logical1 (ffebld_conter (l)),
3010 ffebld_constant_pool ());
3011 break;
3012 #endif
3013
3014 #if FFETARGET_okLOGICAL2
3015 case FFEINFO_kindtypeLOGICAL2:
3016 error
3017 = ffetarget_convert_character1_logical2
3018 (ffebld_cu_ptr_character1 (u),
3019 sz,
3020 ffebld_constant_logical2 (ffebld_conter (l)),
3021 ffebld_constant_pool ());
3022 break;
3023 #endif
3024
3025 #if FFETARGET_okLOGICAL3
3026 case FFEINFO_kindtypeLOGICAL3:
3027 error
3028 = ffetarget_convert_character1_logical3
3029 (ffebld_cu_ptr_character1 (u),
3030 sz,
3031 ffebld_constant_logical3 (ffebld_conter (l)),
3032 ffebld_constant_pool ());
3033 break;
3034 #endif
3035
3036 #if FFETARGET_okLOGICAL4
3037 case FFEINFO_kindtypeLOGICAL4:
3038 error
3039 = ffetarget_convert_character1_logical4
3040 (ffebld_cu_ptr_character1 (u),
3041 sz,
3042 ffebld_constant_logical4 (ffebld_conter (l)),
3043 ffebld_constant_pool ());
3044 break;
3045 #endif
3046
3047 default:
3048 assert ("CHARACTER1/LOGICAL bad source kind type" == NULL);
3049 break;
3050 }
3051 break;
3052
3053 case FFEINFO_basictypeHOLLERITH:
3054 error
3055 = ffetarget_convert_character1_hollerith
3056 (ffebld_cu_ptr_character1 (u),
3057 sz,
3058 ffebld_constant_hollerith (ffebld_conter (l)),
3059 ffebld_constant_pool ());
3060 break;
3061
3062 case FFEINFO_basictypeTYPELESS:
3063 error
3064 = ffetarget_convert_character1_typeless
3065 (ffebld_cu_ptr_character1 (u),
3066 sz,
3067 ffebld_constant_typeless (ffebld_conter (l)),
3068 ffebld_constant_pool ());
3069 break;
3070
3071 default:
3072 assert ("CHARACTER1 bad type" == NULL);
3073 }
3074
3075 expr
3076 = ffebld_new_conter_with_orig
3077 (ffebld_constant_new_character1_val
3078 (ffebld_cu_val_character1 (u)),
3079 expr);
3080 break;
3081 #endif
3082
3083 default:
3084 assert ("bad character kind type" == NULL);
3085 break;
3086 }
3087 break;
3088
3089 default:
3090 assert ("bad type" == NULL);
3091 return expr;
3092 }
3093
3094 ffebld_set_info (expr, ffeinfo_new
3095 (bt,
3096 kt,
3097 0,
3098 FFEINFO_kindENTITY,
3099 FFEINFO_whereCONSTANT,
3100 sz));
3101
3102 if ((error != FFEBAD)
3103 && ffebad_start (error))
3104 {
3105 assert (t != NULL);
3106 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3107 ffebad_finish ();
3108 }
3109
3110 return expr;
3111 }
3112
3113 /* ffeexpr_collapse_paren -- Collapse paren expr
3114
3115 ffebld expr;
3116 ffelexToken token;
3117 expr = ffeexpr_collapse_paren(expr,token);
3118
3119 If the result of the expr is a constant, replaces the expr with the
3120 computed constant. */
3121
3122 ffebld
ffeexpr_collapse_paren(ffebld expr,ffelexToken t UNUSED)3123 ffeexpr_collapse_paren (ffebld expr, ffelexToken t UNUSED)
3124 {
3125 ffebld r;
3126 ffeinfoBasictype bt;
3127 ffeinfoKindtype kt;
3128 ffetargetCharacterSize len;
3129
3130 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3131 return expr;
3132
3133 r = ffebld_left (expr);
3134
3135 if (ffebld_op (r) != FFEBLD_opCONTER)
3136 return expr;
3137
3138 bt = ffeinfo_basictype (ffebld_info (r));
3139 kt = ffeinfo_kindtype (ffebld_info (r));
3140 len = ffebld_size (r);
3141
3142 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
3143 expr);
3144
3145 ffebld_set_info (expr, ffeinfo_new
3146 (bt,
3147 kt,
3148 0,
3149 FFEINFO_kindENTITY,
3150 FFEINFO_whereCONSTANT,
3151 len));
3152
3153 return expr;
3154 }
3155
3156 /* ffeexpr_collapse_uplus -- Collapse uplus expr
3157
3158 ffebld expr;
3159 ffelexToken token;
3160 expr = ffeexpr_collapse_uplus(expr,token);
3161
3162 If the result of the expr is a constant, replaces the expr with the
3163 computed constant. */
3164
3165 ffebld
ffeexpr_collapse_uplus(ffebld expr,ffelexToken t UNUSED)3166 ffeexpr_collapse_uplus (ffebld expr, ffelexToken t UNUSED)
3167 {
3168 ffebld r;
3169 ffeinfoBasictype bt;
3170 ffeinfoKindtype kt;
3171 ffetargetCharacterSize len;
3172
3173 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3174 return expr;
3175
3176 r = ffebld_left (expr);
3177
3178 if (ffebld_op (r) != FFEBLD_opCONTER)
3179 return expr;
3180
3181 bt = ffeinfo_basictype (ffebld_info (r));
3182 kt = ffeinfo_kindtype (ffebld_info (r));
3183 len = ffebld_size (r);
3184
3185 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
3186 expr);
3187
3188 ffebld_set_info (expr, ffeinfo_new
3189 (bt,
3190 kt,
3191 0,
3192 FFEINFO_kindENTITY,
3193 FFEINFO_whereCONSTANT,
3194 len));
3195
3196 return expr;
3197 }
3198
3199 /* ffeexpr_collapse_uminus -- Collapse uminus expr
3200
3201 ffebld expr;
3202 ffelexToken token;
3203 expr = ffeexpr_collapse_uminus(expr,token);
3204
3205 If the result of the expr is a constant, replaces the expr with the
3206 computed constant. */
3207
3208 ffebld
ffeexpr_collapse_uminus(ffebld expr,ffelexToken t)3209 ffeexpr_collapse_uminus (ffebld expr, ffelexToken t)
3210 {
3211 ffebad error = FFEBAD;
3212 ffebld r;
3213 ffebldConstantUnion u;
3214 ffeinfoBasictype bt;
3215 ffeinfoKindtype kt;
3216
3217 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3218 return expr;
3219
3220 r = ffebld_left (expr);
3221
3222 if (ffebld_op (r) != FFEBLD_opCONTER)
3223 return expr;
3224
3225 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3226 {
3227 case FFEINFO_basictypeANY:
3228 return expr;
3229
3230 case FFEINFO_basictypeINTEGER:
3231 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3232 {
3233 #if FFETARGET_okINTEGER1
3234 case FFEINFO_kindtypeINTEGER1:
3235 error = ffetarget_uminus_integer1 (ffebld_cu_ptr_integer1 (u),
3236 ffebld_constant_integer1 (ffebld_conter (r)));
3237 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3238 (ffebld_cu_val_integer1 (u)), expr);
3239 break;
3240 #endif
3241
3242 #if FFETARGET_okINTEGER2
3243 case FFEINFO_kindtypeINTEGER2:
3244 error = ffetarget_uminus_integer2 (ffebld_cu_ptr_integer2 (u),
3245 ffebld_constant_integer2 (ffebld_conter (r)));
3246 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3247 (ffebld_cu_val_integer2 (u)), expr);
3248 break;
3249 #endif
3250
3251 #if FFETARGET_okINTEGER3
3252 case FFEINFO_kindtypeINTEGER3:
3253 error = ffetarget_uminus_integer3 (ffebld_cu_ptr_integer3 (u),
3254 ffebld_constant_integer3 (ffebld_conter (r)));
3255 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3256 (ffebld_cu_val_integer3 (u)), expr);
3257 break;
3258 #endif
3259
3260 #if FFETARGET_okINTEGER4
3261 case FFEINFO_kindtypeINTEGER4:
3262 error = ffetarget_uminus_integer4 (ffebld_cu_ptr_integer4 (u),
3263 ffebld_constant_integer4 (ffebld_conter (r)));
3264 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3265 (ffebld_cu_val_integer4 (u)), expr);
3266 break;
3267 #endif
3268
3269 default:
3270 assert ("bad integer kind type" == NULL);
3271 break;
3272 }
3273 break;
3274
3275 case FFEINFO_basictypeREAL:
3276 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3277 {
3278 #if FFETARGET_okREAL1
3279 case FFEINFO_kindtypeREAL1:
3280 error = ffetarget_uminus_real1 (ffebld_cu_ptr_real1 (u),
3281 ffebld_constant_real1 (ffebld_conter (r)));
3282 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3283 (ffebld_cu_val_real1 (u)), expr);
3284 break;
3285 #endif
3286
3287 #if FFETARGET_okREAL2
3288 case FFEINFO_kindtypeREAL2:
3289 error = ffetarget_uminus_real2 (ffebld_cu_ptr_real2 (u),
3290 ffebld_constant_real2 (ffebld_conter (r)));
3291 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3292 (ffebld_cu_val_real2 (u)), expr);
3293 break;
3294 #endif
3295
3296 #if FFETARGET_okREAL3
3297 case FFEINFO_kindtypeREAL3:
3298 error = ffetarget_uminus_real3 (ffebld_cu_ptr_real3 (u),
3299 ffebld_constant_real3 (ffebld_conter (r)));
3300 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3301 (ffebld_cu_val_real3 (u)), expr);
3302 break;
3303 #endif
3304
3305 #if FFETARGET_okREAL4
3306 case FFEINFO_kindtypeREAL4:
3307 error = ffetarget_uminus_real4 (ffebld_cu_ptr_real4 (u),
3308 ffebld_constant_real4 (ffebld_conter (r)));
3309 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
3310 (ffebld_cu_val_real4 (u)), expr);
3311 break;
3312 #endif
3313
3314 default:
3315 assert ("bad real kind type" == NULL);
3316 break;
3317 }
3318 break;
3319
3320 case FFEINFO_basictypeCOMPLEX:
3321 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3322 {
3323 #if FFETARGET_okCOMPLEX1
3324 case FFEINFO_kindtypeREAL1:
3325 error = ffetarget_uminus_complex1 (ffebld_cu_ptr_complex1 (u),
3326 ffebld_constant_complex1 (ffebld_conter (r)));
3327 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3328 (ffebld_cu_val_complex1 (u)), expr);
3329 break;
3330 #endif
3331
3332 #if FFETARGET_okCOMPLEX2
3333 case FFEINFO_kindtypeREAL2:
3334 error = ffetarget_uminus_complex2 (ffebld_cu_ptr_complex2 (u),
3335 ffebld_constant_complex2 (ffebld_conter (r)));
3336 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3337 (ffebld_cu_val_complex2 (u)), expr);
3338 break;
3339 #endif
3340
3341 #if FFETARGET_okCOMPLEX3
3342 case FFEINFO_kindtypeREAL3:
3343 error = ffetarget_uminus_complex3 (ffebld_cu_ptr_complex3 (u),
3344 ffebld_constant_complex3 (ffebld_conter (r)));
3345 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3346 (ffebld_cu_val_complex3 (u)), expr);
3347 break;
3348 #endif
3349
3350 #if FFETARGET_okCOMPLEX4
3351 case FFEINFO_kindtypeREAL4:
3352 error = ffetarget_uminus_complex4 (ffebld_cu_ptr_complex4 (u),
3353 ffebld_constant_complex4 (ffebld_conter (r)));
3354 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
3355 (ffebld_cu_val_complex4 (u)), expr);
3356 break;
3357 #endif
3358
3359 default:
3360 assert ("bad complex kind type" == NULL);
3361 break;
3362 }
3363 break;
3364
3365 default:
3366 assert ("bad type" == NULL);
3367 return expr;
3368 }
3369
3370 ffebld_set_info (expr, ffeinfo_new
3371 (bt,
3372 kt,
3373 0,
3374 FFEINFO_kindENTITY,
3375 FFEINFO_whereCONSTANT,
3376 FFETARGET_charactersizeNONE));
3377
3378 if ((error != FFEBAD)
3379 && ffebad_start (error))
3380 {
3381 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3382 ffebad_finish ();
3383 }
3384
3385 return expr;
3386 }
3387
3388 /* ffeexpr_collapse_not -- Collapse not expr
3389
3390 ffebld expr;
3391 ffelexToken token;
3392 expr = ffeexpr_collapse_not(expr,token);
3393
3394 If the result of the expr is a constant, replaces the expr with the
3395 computed constant. */
3396
3397 ffebld
ffeexpr_collapse_not(ffebld expr,ffelexToken t)3398 ffeexpr_collapse_not (ffebld expr, ffelexToken t)
3399 {
3400 ffebad error = FFEBAD;
3401 ffebld r;
3402 ffebldConstantUnion u;
3403 ffeinfoBasictype bt;
3404 ffeinfoKindtype kt;
3405
3406 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3407 return expr;
3408
3409 r = ffebld_left (expr);
3410
3411 if (ffebld_op (r) != FFEBLD_opCONTER)
3412 return expr;
3413
3414 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3415 {
3416 case FFEINFO_basictypeANY:
3417 return expr;
3418
3419 case FFEINFO_basictypeINTEGER:
3420 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3421 {
3422 #if FFETARGET_okINTEGER1
3423 case FFEINFO_kindtypeINTEGER1:
3424 error = ffetarget_not_integer1 (ffebld_cu_ptr_integer1 (u),
3425 ffebld_constant_integer1 (ffebld_conter (r)));
3426 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3427 (ffebld_cu_val_integer1 (u)), expr);
3428 break;
3429 #endif
3430
3431 #if FFETARGET_okINTEGER2
3432 case FFEINFO_kindtypeINTEGER2:
3433 error = ffetarget_not_integer2 (ffebld_cu_ptr_integer2 (u),
3434 ffebld_constant_integer2 (ffebld_conter (r)));
3435 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3436 (ffebld_cu_val_integer2 (u)), expr);
3437 break;
3438 #endif
3439
3440 #if FFETARGET_okINTEGER3
3441 case FFEINFO_kindtypeINTEGER3:
3442 error = ffetarget_not_integer3 (ffebld_cu_ptr_integer3 (u),
3443 ffebld_constant_integer3 (ffebld_conter (r)));
3444 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3445 (ffebld_cu_val_integer3 (u)), expr);
3446 break;
3447 #endif
3448
3449 #if FFETARGET_okINTEGER4
3450 case FFEINFO_kindtypeINTEGER4:
3451 error = ffetarget_not_integer4 (ffebld_cu_ptr_integer4 (u),
3452 ffebld_constant_integer4 (ffebld_conter (r)));
3453 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3454 (ffebld_cu_val_integer4 (u)), expr);
3455 break;
3456 #endif
3457
3458 default:
3459 assert ("bad integer kind type" == NULL);
3460 break;
3461 }
3462 break;
3463
3464 case FFEINFO_basictypeLOGICAL:
3465 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3466 {
3467 #if FFETARGET_okLOGICAL1
3468 case FFEINFO_kindtypeLOGICAL1:
3469 error = ffetarget_not_logical1 (ffebld_cu_ptr_logical1 (u),
3470 ffebld_constant_logical1 (ffebld_conter (r)));
3471 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
3472 (ffebld_cu_val_logical1 (u)), expr);
3473 break;
3474 #endif
3475
3476 #if FFETARGET_okLOGICAL2
3477 case FFEINFO_kindtypeLOGICAL2:
3478 error = ffetarget_not_logical2 (ffebld_cu_ptr_logical2 (u),
3479 ffebld_constant_logical2 (ffebld_conter (r)));
3480 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
3481 (ffebld_cu_val_logical2 (u)), expr);
3482 break;
3483 #endif
3484
3485 #if FFETARGET_okLOGICAL3
3486 case FFEINFO_kindtypeLOGICAL3:
3487 error = ffetarget_not_logical3 (ffebld_cu_ptr_logical3 (u),
3488 ffebld_constant_logical3 (ffebld_conter (r)));
3489 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
3490 (ffebld_cu_val_logical3 (u)), expr);
3491 break;
3492 #endif
3493
3494 #if FFETARGET_okLOGICAL4
3495 case FFEINFO_kindtypeLOGICAL4:
3496 error = ffetarget_not_logical4 (ffebld_cu_ptr_logical4 (u),
3497 ffebld_constant_logical4 (ffebld_conter (r)));
3498 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
3499 (ffebld_cu_val_logical4 (u)), expr);
3500 break;
3501 #endif
3502
3503 default:
3504 assert ("bad logical kind type" == NULL);
3505 break;
3506 }
3507 break;
3508
3509 default:
3510 assert ("bad type" == NULL);
3511 return expr;
3512 }
3513
3514 ffebld_set_info (expr, ffeinfo_new
3515 (bt,
3516 kt,
3517 0,
3518 FFEINFO_kindENTITY,
3519 FFEINFO_whereCONSTANT,
3520 FFETARGET_charactersizeNONE));
3521
3522 if ((error != FFEBAD)
3523 && ffebad_start (error))
3524 {
3525 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3526 ffebad_finish ();
3527 }
3528
3529 return expr;
3530 }
3531
3532 /* ffeexpr_collapse_add -- Collapse add expr
3533
3534 ffebld expr;
3535 ffelexToken token;
3536 expr = ffeexpr_collapse_add(expr,token);
3537
3538 If the result of the expr is a constant, replaces the expr with the
3539 computed constant. */
3540
3541 ffebld
ffeexpr_collapse_add(ffebld expr,ffelexToken t)3542 ffeexpr_collapse_add (ffebld expr, ffelexToken t)
3543 {
3544 ffebad error = FFEBAD;
3545 ffebld l;
3546 ffebld r;
3547 ffebldConstantUnion u;
3548 ffeinfoBasictype bt;
3549 ffeinfoKindtype kt;
3550
3551 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3552 return expr;
3553
3554 l = ffebld_left (expr);
3555 r = ffebld_right (expr);
3556
3557 if (ffebld_op (l) != FFEBLD_opCONTER)
3558 return expr;
3559 if (ffebld_op (r) != FFEBLD_opCONTER)
3560 return expr;
3561
3562 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3563 {
3564 case FFEINFO_basictypeANY:
3565 return expr;
3566
3567 case FFEINFO_basictypeINTEGER:
3568 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3569 {
3570 #if FFETARGET_okINTEGER1
3571 case FFEINFO_kindtypeINTEGER1:
3572 error = ffetarget_add_integer1 (ffebld_cu_ptr_integer1 (u),
3573 ffebld_constant_integer1 (ffebld_conter (l)),
3574 ffebld_constant_integer1 (ffebld_conter (r)));
3575 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3576 (ffebld_cu_val_integer1 (u)), expr);
3577 break;
3578 #endif
3579
3580 #if FFETARGET_okINTEGER2
3581 case FFEINFO_kindtypeINTEGER2:
3582 error = ffetarget_add_integer2 (ffebld_cu_ptr_integer2 (u),
3583 ffebld_constant_integer2 (ffebld_conter (l)),
3584 ffebld_constant_integer2 (ffebld_conter (r)));
3585 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3586 (ffebld_cu_val_integer2 (u)), expr);
3587 break;
3588 #endif
3589
3590 #if FFETARGET_okINTEGER3
3591 case FFEINFO_kindtypeINTEGER3:
3592 error = ffetarget_add_integer3 (ffebld_cu_ptr_integer3 (u),
3593 ffebld_constant_integer3 (ffebld_conter (l)),
3594 ffebld_constant_integer3 (ffebld_conter (r)));
3595 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3596 (ffebld_cu_val_integer3 (u)), expr);
3597 break;
3598 #endif
3599
3600 #if FFETARGET_okINTEGER4
3601 case FFEINFO_kindtypeINTEGER4:
3602 error = ffetarget_add_integer4 (ffebld_cu_ptr_integer4 (u),
3603 ffebld_constant_integer4 (ffebld_conter (l)),
3604 ffebld_constant_integer4 (ffebld_conter (r)));
3605 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3606 (ffebld_cu_val_integer4 (u)), expr);
3607 break;
3608 #endif
3609
3610 default:
3611 assert ("bad integer kind type" == NULL);
3612 break;
3613 }
3614 break;
3615
3616 case FFEINFO_basictypeREAL:
3617 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3618 {
3619 #if FFETARGET_okREAL1
3620 case FFEINFO_kindtypeREAL1:
3621 error = ffetarget_add_real1 (ffebld_cu_ptr_real1 (u),
3622 ffebld_constant_real1 (ffebld_conter (l)),
3623 ffebld_constant_real1 (ffebld_conter (r)));
3624 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3625 (ffebld_cu_val_real1 (u)), expr);
3626 break;
3627 #endif
3628
3629 #if FFETARGET_okREAL2
3630 case FFEINFO_kindtypeREAL2:
3631 error = ffetarget_add_real2 (ffebld_cu_ptr_real2 (u),
3632 ffebld_constant_real2 (ffebld_conter (l)),
3633 ffebld_constant_real2 (ffebld_conter (r)));
3634 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3635 (ffebld_cu_val_real2 (u)), expr);
3636 break;
3637 #endif
3638
3639 #if FFETARGET_okREAL3
3640 case FFEINFO_kindtypeREAL3:
3641 error = ffetarget_add_real3 (ffebld_cu_ptr_real3 (u),
3642 ffebld_constant_real3 (ffebld_conter (l)),
3643 ffebld_constant_real3 (ffebld_conter (r)));
3644 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3645 (ffebld_cu_val_real3 (u)), expr);
3646 break;
3647 #endif
3648
3649 #if FFETARGET_okREAL4
3650 case FFEINFO_kindtypeREAL4:
3651 error = ffetarget_add_real4 (ffebld_cu_ptr_real4 (u),
3652 ffebld_constant_real4 (ffebld_conter (l)),
3653 ffebld_constant_real4 (ffebld_conter (r)));
3654 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
3655 (ffebld_cu_val_real4 (u)), expr);
3656 break;
3657 #endif
3658
3659 default:
3660 assert ("bad real kind type" == NULL);
3661 break;
3662 }
3663 break;
3664
3665 case FFEINFO_basictypeCOMPLEX:
3666 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3667 {
3668 #if FFETARGET_okCOMPLEX1
3669 case FFEINFO_kindtypeREAL1:
3670 error = ffetarget_add_complex1 (ffebld_cu_ptr_complex1 (u),
3671 ffebld_constant_complex1 (ffebld_conter (l)),
3672 ffebld_constant_complex1 (ffebld_conter (r)));
3673 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3674 (ffebld_cu_val_complex1 (u)), expr);
3675 break;
3676 #endif
3677
3678 #if FFETARGET_okCOMPLEX2
3679 case FFEINFO_kindtypeREAL2:
3680 error = ffetarget_add_complex2 (ffebld_cu_ptr_complex2 (u),
3681 ffebld_constant_complex2 (ffebld_conter (l)),
3682 ffebld_constant_complex2 (ffebld_conter (r)));
3683 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3684 (ffebld_cu_val_complex2 (u)), expr);
3685 break;
3686 #endif
3687
3688 #if FFETARGET_okCOMPLEX3
3689 case FFEINFO_kindtypeREAL3:
3690 error = ffetarget_add_complex3 (ffebld_cu_ptr_complex3 (u),
3691 ffebld_constant_complex3 (ffebld_conter (l)),
3692 ffebld_constant_complex3 (ffebld_conter (r)));
3693 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3694 (ffebld_cu_val_complex3 (u)), expr);
3695 break;
3696 #endif
3697
3698 #if FFETARGET_okCOMPLEX4
3699 case FFEINFO_kindtypeREAL4:
3700 error = ffetarget_add_complex4 (ffebld_cu_ptr_complex4 (u),
3701 ffebld_constant_complex4 (ffebld_conter (l)),
3702 ffebld_constant_complex4 (ffebld_conter (r)));
3703 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
3704 (ffebld_cu_val_complex4 (u)), expr);
3705 break;
3706 #endif
3707
3708 default:
3709 assert ("bad complex kind type" == NULL);
3710 break;
3711 }
3712 break;
3713
3714 default:
3715 assert ("bad type" == NULL);
3716 return expr;
3717 }
3718
3719 ffebld_set_info (expr, ffeinfo_new
3720 (bt,
3721 kt,
3722 0,
3723 FFEINFO_kindENTITY,
3724 FFEINFO_whereCONSTANT,
3725 FFETARGET_charactersizeNONE));
3726
3727 if ((error != FFEBAD)
3728 && ffebad_start (error))
3729 {
3730 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3731 ffebad_finish ();
3732 }
3733
3734 return expr;
3735 }
3736
3737 /* ffeexpr_collapse_subtract -- Collapse subtract expr
3738
3739 ffebld expr;
3740 ffelexToken token;
3741 expr = ffeexpr_collapse_subtract(expr,token);
3742
3743 If the result of the expr is a constant, replaces the expr with the
3744 computed constant. */
3745
3746 ffebld
ffeexpr_collapse_subtract(ffebld expr,ffelexToken t)3747 ffeexpr_collapse_subtract (ffebld expr, ffelexToken t)
3748 {
3749 ffebad error = FFEBAD;
3750 ffebld l;
3751 ffebld r;
3752 ffebldConstantUnion u;
3753 ffeinfoBasictype bt;
3754 ffeinfoKindtype kt;
3755
3756 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3757 return expr;
3758
3759 l = ffebld_left (expr);
3760 r = ffebld_right (expr);
3761
3762 if (ffebld_op (l) != FFEBLD_opCONTER)
3763 return expr;
3764 if (ffebld_op (r) != FFEBLD_opCONTER)
3765 return expr;
3766
3767 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3768 {
3769 case FFEINFO_basictypeANY:
3770 return expr;
3771
3772 case FFEINFO_basictypeINTEGER:
3773 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3774 {
3775 #if FFETARGET_okINTEGER1
3776 case FFEINFO_kindtypeINTEGER1:
3777 error = ffetarget_subtract_integer1 (ffebld_cu_ptr_integer1 (u),
3778 ffebld_constant_integer1 (ffebld_conter (l)),
3779 ffebld_constant_integer1 (ffebld_conter (r)));
3780 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3781 (ffebld_cu_val_integer1 (u)), expr);
3782 break;
3783 #endif
3784
3785 #if FFETARGET_okINTEGER2
3786 case FFEINFO_kindtypeINTEGER2:
3787 error = ffetarget_subtract_integer2 (ffebld_cu_ptr_integer2 (u),
3788 ffebld_constant_integer2 (ffebld_conter (l)),
3789 ffebld_constant_integer2 (ffebld_conter (r)));
3790 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3791 (ffebld_cu_val_integer2 (u)), expr);
3792 break;
3793 #endif
3794
3795 #if FFETARGET_okINTEGER3
3796 case FFEINFO_kindtypeINTEGER3:
3797 error = ffetarget_subtract_integer3 (ffebld_cu_ptr_integer3 (u),
3798 ffebld_constant_integer3 (ffebld_conter (l)),
3799 ffebld_constant_integer3 (ffebld_conter (r)));
3800 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3801 (ffebld_cu_val_integer3 (u)), expr);
3802 break;
3803 #endif
3804
3805 #if FFETARGET_okINTEGER4
3806 case FFEINFO_kindtypeINTEGER4:
3807 error = ffetarget_subtract_integer4 (ffebld_cu_ptr_integer4 (u),
3808 ffebld_constant_integer4 (ffebld_conter (l)),
3809 ffebld_constant_integer4 (ffebld_conter (r)));
3810 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3811 (ffebld_cu_val_integer4 (u)), expr);
3812 break;
3813 #endif
3814
3815 default:
3816 assert ("bad integer kind type" == NULL);
3817 break;
3818 }
3819 break;
3820
3821 case FFEINFO_basictypeREAL:
3822 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3823 {
3824 #if FFETARGET_okREAL1
3825 case FFEINFO_kindtypeREAL1:
3826 error = ffetarget_subtract_real1 (ffebld_cu_ptr_real1 (u),
3827 ffebld_constant_real1 (ffebld_conter (l)),
3828 ffebld_constant_real1 (ffebld_conter (r)));
3829 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3830 (ffebld_cu_val_real1 (u)), expr);
3831 break;
3832 #endif
3833
3834 #if FFETARGET_okREAL2
3835 case FFEINFO_kindtypeREAL2:
3836 error = ffetarget_subtract_real2 (ffebld_cu_ptr_real2 (u),
3837 ffebld_constant_real2 (ffebld_conter (l)),
3838 ffebld_constant_real2 (ffebld_conter (r)));
3839 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3840 (ffebld_cu_val_real2 (u)), expr);
3841 break;
3842 #endif
3843
3844 #if FFETARGET_okREAL3
3845 case FFEINFO_kindtypeREAL3:
3846 error = ffetarget_subtract_real3 (ffebld_cu_ptr_real3 (u),
3847 ffebld_constant_real3 (ffebld_conter (l)),
3848 ffebld_constant_real3 (ffebld_conter (r)));
3849 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3850 (ffebld_cu_val_real3 (u)), expr);
3851 break;
3852 #endif
3853
3854 #if FFETARGET_okREAL4
3855 case FFEINFO_kindtypeREAL4:
3856 error = ffetarget_subtract_real4 (ffebld_cu_ptr_real4 (u),
3857 ffebld_constant_real4 (ffebld_conter (l)),
3858 ffebld_constant_real4 (ffebld_conter (r)));
3859 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
3860 (ffebld_cu_val_real4 (u)), expr);
3861 break;
3862 #endif
3863
3864 default:
3865 assert ("bad real kind type" == NULL);
3866 break;
3867 }
3868 break;
3869
3870 case FFEINFO_basictypeCOMPLEX:
3871 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3872 {
3873 #if FFETARGET_okCOMPLEX1
3874 case FFEINFO_kindtypeREAL1:
3875 error = ffetarget_subtract_complex1 (ffebld_cu_ptr_complex1 (u),
3876 ffebld_constant_complex1 (ffebld_conter (l)),
3877 ffebld_constant_complex1 (ffebld_conter (r)));
3878 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3879 (ffebld_cu_val_complex1 (u)), expr);
3880 break;
3881 #endif
3882
3883 #if FFETARGET_okCOMPLEX2
3884 case FFEINFO_kindtypeREAL2:
3885 error = ffetarget_subtract_complex2 (ffebld_cu_ptr_complex2 (u),
3886 ffebld_constant_complex2 (ffebld_conter (l)),
3887 ffebld_constant_complex2 (ffebld_conter (r)));
3888 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3889 (ffebld_cu_val_complex2 (u)), expr);
3890 break;
3891 #endif
3892
3893 #if FFETARGET_okCOMPLEX3
3894 case FFEINFO_kindtypeREAL3:
3895 error = ffetarget_subtract_complex3 (ffebld_cu_ptr_complex3 (u),
3896 ffebld_constant_complex3 (ffebld_conter (l)),
3897 ffebld_constant_complex3 (ffebld_conter (r)));
3898 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3899 (ffebld_cu_val_complex3 (u)), expr);
3900 break;
3901 #endif
3902
3903 #if FFETARGET_okCOMPLEX4
3904 case FFEINFO_kindtypeREAL4:
3905 error = ffetarget_subtract_complex4 (ffebld_cu_ptr_complex4 (u),
3906 ffebld_constant_complex4 (ffebld_conter (l)),
3907 ffebld_constant_complex4 (ffebld_conter (r)));
3908 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
3909 (ffebld_cu_val_complex4 (u)), expr);
3910 break;
3911 #endif
3912
3913 default:
3914 assert ("bad complex kind type" == NULL);
3915 break;
3916 }
3917 break;
3918
3919 default:
3920 assert ("bad type" == NULL);
3921 return expr;
3922 }
3923
3924 ffebld_set_info (expr, ffeinfo_new
3925 (bt,
3926 kt,
3927 0,
3928 FFEINFO_kindENTITY,
3929 FFEINFO_whereCONSTANT,
3930 FFETARGET_charactersizeNONE));
3931
3932 if ((error != FFEBAD)
3933 && ffebad_start (error))
3934 {
3935 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3936 ffebad_finish ();
3937 }
3938
3939 return expr;
3940 }
3941
3942 /* ffeexpr_collapse_multiply -- Collapse multiply expr
3943
3944 ffebld expr;
3945 ffelexToken token;
3946 expr = ffeexpr_collapse_multiply(expr,token);
3947
3948 If the result of the expr is a constant, replaces the expr with the
3949 computed constant. */
3950
3951 ffebld
ffeexpr_collapse_multiply(ffebld expr,ffelexToken t)3952 ffeexpr_collapse_multiply (ffebld expr, ffelexToken t)
3953 {
3954 ffebad error = FFEBAD;
3955 ffebld l;
3956 ffebld r;
3957 ffebldConstantUnion u;
3958 ffeinfoBasictype bt;
3959 ffeinfoKindtype kt;
3960
3961 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3962 return expr;
3963
3964 l = ffebld_left (expr);
3965 r = ffebld_right (expr);
3966
3967 if (ffebld_op (l) != FFEBLD_opCONTER)
3968 return expr;
3969 if (ffebld_op (r) != FFEBLD_opCONTER)
3970 return expr;
3971
3972 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3973 {
3974 case FFEINFO_basictypeANY:
3975 return expr;
3976
3977 case FFEINFO_basictypeINTEGER:
3978 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3979 {
3980 #if FFETARGET_okINTEGER1
3981 case FFEINFO_kindtypeINTEGER1:
3982 error = ffetarget_multiply_integer1 (ffebld_cu_ptr_integer1 (u),
3983 ffebld_constant_integer1 (ffebld_conter (l)),
3984 ffebld_constant_integer1 (ffebld_conter (r)));
3985 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3986 (ffebld_cu_val_integer1 (u)), expr);
3987 break;
3988 #endif
3989
3990 #if FFETARGET_okINTEGER2
3991 case FFEINFO_kindtypeINTEGER2:
3992 error = ffetarget_multiply_integer2 (ffebld_cu_ptr_integer2 (u),
3993 ffebld_constant_integer2 (ffebld_conter (l)),
3994 ffebld_constant_integer2 (ffebld_conter (r)));
3995 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3996 (ffebld_cu_val_integer2 (u)), expr);
3997 break;
3998 #endif
3999
4000 #if FFETARGET_okINTEGER3
4001 case FFEINFO_kindtypeINTEGER3:
4002 error = ffetarget_multiply_integer3 (ffebld_cu_ptr_integer3 (u),
4003 ffebld_constant_integer3 (ffebld_conter (l)),
4004 ffebld_constant_integer3 (ffebld_conter (r)));
4005 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
4006 (ffebld_cu_val_integer3 (u)), expr);
4007 break;
4008 #endif
4009
4010 #if FFETARGET_okINTEGER4
4011 case FFEINFO_kindtypeINTEGER4:
4012 error = ffetarget_multiply_integer4 (ffebld_cu_ptr_integer4 (u),
4013 ffebld_constant_integer4 (ffebld_conter (l)),
4014 ffebld_constant_integer4 (ffebld_conter (r)));
4015 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
4016 (ffebld_cu_val_integer4 (u)), expr);
4017 break;
4018 #endif
4019
4020 default:
4021 assert ("bad integer kind type" == NULL);
4022 break;
4023 }
4024 break;
4025
4026 case FFEINFO_basictypeREAL:
4027 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4028 {
4029 #if FFETARGET_okREAL1
4030 case FFEINFO_kindtypeREAL1:
4031 error = ffetarget_multiply_real1 (ffebld_cu_ptr_real1 (u),
4032 ffebld_constant_real1 (ffebld_conter (l)),
4033 ffebld_constant_real1 (ffebld_conter (r)));
4034 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
4035 (ffebld_cu_val_real1 (u)), expr);
4036 break;
4037 #endif
4038
4039 #if FFETARGET_okREAL2
4040 case FFEINFO_kindtypeREAL2:
4041 error = ffetarget_multiply_real2 (ffebld_cu_ptr_real2 (u),
4042 ffebld_constant_real2 (ffebld_conter (l)),
4043 ffebld_constant_real2 (ffebld_conter (r)));
4044 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
4045 (ffebld_cu_val_real2 (u)), expr);
4046 break;
4047 #endif
4048
4049 #if FFETARGET_okREAL3
4050 case FFEINFO_kindtypeREAL3:
4051 error = ffetarget_multiply_real3 (ffebld_cu_ptr_real3 (u),
4052 ffebld_constant_real3 (ffebld_conter (l)),
4053 ffebld_constant_real3 (ffebld_conter (r)));
4054 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
4055 (ffebld_cu_val_real3 (u)), expr);
4056 break;
4057 #endif
4058
4059 #if FFETARGET_okREAL4
4060 case FFEINFO_kindtypeREAL4:
4061 error = ffetarget_multiply_real4 (ffebld_cu_ptr_real4 (u),
4062 ffebld_constant_real4 (ffebld_conter (l)),
4063 ffebld_constant_real4 (ffebld_conter (r)));
4064 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
4065 (ffebld_cu_val_real4 (u)), expr);
4066 break;
4067 #endif
4068
4069 default:
4070 assert ("bad real kind type" == NULL);
4071 break;
4072 }
4073 break;
4074
4075 case FFEINFO_basictypeCOMPLEX:
4076 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4077 {
4078 #if FFETARGET_okCOMPLEX1
4079 case FFEINFO_kindtypeREAL1:
4080 error = ffetarget_multiply_complex1 (ffebld_cu_ptr_complex1 (u),
4081 ffebld_constant_complex1 (ffebld_conter (l)),
4082 ffebld_constant_complex1 (ffebld_conter (r)));
4083 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
4084 (ffebld_cu_val_complex1 (u)), expr);
4085 break;
4086 #endif
4087
4088 #if FFETARGET_okCOMPLEX2
4089 case FFEINFO_kindtypeREAL2:
4090 error = ffetarget_multiply_complex2 (ffebld_cu_ptr_complex2 (u),
4091 ffebld_constant_complex2 (ffebld_conter (l)),
4092 ffebld_constant_complex2 (ffebld_conter (r)));
4093 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
4094 (ffebld_cu_val_complex2 (u)), expr);
4095 break;
4096 #endif
4097
4098 #if FFETARGET_okCOMPLEX3
4099 case FFEINFO_kindtypeREAL3:
4100 error = ffetarget_multiply_complex3 (ffebld_cu_ptr_complex3 (u),
4101 ffebld_constant_complex3 (ffebld_conter (l)),
4102 ffebld_constant_complex3 (ffebld_conter (r)));
4103 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
4104 (ffebld_cu_val_complex3 (u)), expr);
4105 break;
4106 #endif
4107
4108 #if FFETARGET_okCOMPLEX4
4109 case FFEINFO_kindtypeREAL4:
4110 error = ffetarget_multiply_complex4 (ffebld_cu_ptr_complex4 (u),
4111 ffebld_constant_complex4 (ffebld_conter (l)),
4112 ffebld_constant_complex4 (ffebld_conter (r)));
4113 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
4114 (ffebld_cu_val_complex4 (u)), expr);
4115 break;
4116 #endif
4117
4118 default:
4119 assert ("bad complex kind type" == NULL);
4120 break;
4121 }
4122 break;
4123
4124 default:
4125 assert ("bad type" == NULL);
4126 return expr;
4127 }
4128
4129 ffebld_set_info (expr, ffeinfo_new
4130 (bt,
4131 kt,
4132 0,
4133 FFEINFO_kindENTITY,
4134 FFEINFO_whereCONSTANT,
4135 FFETARGET_charactersizeNONE));
4136
4137 if ((error != FFEBAD)
4138 && ffebad_start (error))
4139 {
4140 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4141 ffebad_finish ();
4142 }
4143
4144 return expr;
4145 }
4146
4147 /* ffeexpr_collapse_divide -- Collapse divide expr
4148
4149 ffebld expr;
4150 ffelexToken token;
4151 expr = ffeexpr_collapse_divide(expr,token);
4152
4153 If the result of the expr is a constant, replaces the expr with the
4154 computed constant. */
4155
4156 ffebld
ffeexpr_collapse_divide(ffebld expr,ffelexToken t)4157 ffeexpr_collapse_divide (ffebld expr, ffelexToken t)
4158 {
4159 ffebad error = FFEBAD;
4160 ffebld l;
4161 ffebld r;
4162 ffebldConstantUnion u;
4163 ffeinfoBasictype bt;
4164 ffeinfoKindtype kt;
4165
4166 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4167 return expr;
4168
4169 l = ffebld_left (expr);
4170 r = ffebld_right (expr);
4171
4172 if (ffebld_op (l) != FFEBLD_opCONTER)
4173 return expr;
4174 if (ffebld_op (r) != FFEBLD_opCONTER)
4175 return expr;
4176
4177 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
4178 {
4179 case FFEINFO_basictypeANY:
4180 return expr;
4181
4182 case FFEINFO_basictypeINTEGER:
4183 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4184 {
4185 #if FFETARGET_okINTEGER1
4186 case FFEINFO_kindtypeINTEGER1:
4187 error = ffetarget_divide_integer1 (ffebld_cu_ptr_integer1 (u),
4188 ffebld_constant_integer1 (ffebld_conter (l)),
4189 ffebld_constant_integer1 (ffebld_conter (r)));
4190 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
4191 (ffebld_cu_val_integer1 (u)), expr);
4192 break;
4193 #endif
4194
4195 #if FFETARGET_okINTEGER2
4196 case FFEINFO_kindtypeINTEGER2:
4197 error = ffetarget_divide_integer2 (ffebld_cu_ptr_integer2 (u),
4198 ffebld_constant_integer2 (ffebld_conter (l)),
4199 ffebld_constant_integer2 (ffebld_conter (r)));
4200 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
4201 (ffebld_cu_val_integer2 (u)), expr);
4202 break;
4203 #endif
4204
4205 #if FFETARGET_okINTEGER3
4206 case FFEINFO_kindtypeINTEGER3:
4207 error = ffetarget_divide_integer3 (ffebld_cu_ptr_integer3 (u),
4208 ffebld_constant_integer3 (ffebld_conter (l)),
4209 ffebld_constant_integer3 (ffebld_conter (r)));
4210 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
4211 (ffebld_cu_val_integer3 (u)), expr);
4212 break;
4213 #endif
4214
4215 #if FFETARGET_okINTEGER4
4216 case FFEINFO_kindtypeINTEGER4:
4217 error = ffetarget_divide_integer4 (ffebld_cu_ptr_integer4 (u),
4218 ffebld_constant_integer4 (ffebld_conter (l)),
4219 ffebld_constant_integer4 (ffebld_conter (r)));
4220 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
4221 (ffebld_cu_val_integer4 (u)), expr);
4222 break;
4223 #endif
4224
4225 default:
4226 assert ("bad integer kind type" == NULL);
4227 break;
4228 }
4229 break;
4230
4231 case FFEINFO_basictypeREAL:
4232 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4233 {
4234 #if FFETARGET_okREAL1
4235 case FFEINFO_kindtypeREAL1:
4236 error = ffetarget_divide_real1 (ffebld_cu_ptr_real1 (u),
4237 ffebld_constant_real1 (ffebld_conter (l)),
4238 ffebld_constant_real1 (ffebld_conter (r)));
4239 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
4240 (ffebld_cu_val_real1 (u)), expr);
4241 break;
4242 #endif
4243
4244 #if FFETARGET_okREAL2
4245 case FFEINFO_kindtypeREAL2:
4246 error = ffetarget_divide_real2 (ffebld_cu_ptr_real2 (u),
4247 ffebld_constant_real2 (ffebld_conter (l)),
4248 ffebld_constant_real2 (ffebld_conter (r)));
4249 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
4250 (ffebld_cu_val_real2 (u)), expr);
4251 break;
4252 #endif
4253
4254 #if FFETARGET_okREAL3
4255 case FFEINFO_kindtypeREAL3:
4256 error = ffetarget_divide_real3 (ffebld_cu_ptr_real3 (u),
4257 ffebld_constant_real3 (ffebld_conter (l)),
4258 ffebld_constant_real3 (ffebld_conter (r)));
4259 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
4260 (ffebld_cu_val_real3 (u)), expr);
4261 break;
4262 #endif
4263
4264 #if FFETARGET_okREAL4
4265 case FFEINFO_kindtypeREAL4:
4266 error = ffetarget_divide_real4 (ffebld_cu_ptr_real4 (u),
4267 ffebld_constant_real4 (ffebld_conter (l)),
4268 ffebld_constant_real4 (ffebld_conter (r)));
4269 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
4270 (ffebld_cu_val_real4 (u)), expr);
4271 break;
4272 #endif
4273
4274 default:
4275 assert ("bad real kind type" == NULL);
4276 break;
4277 }
4278 break;
4279
4280 case FFEINFO_basictypeCOMPLEX:
4281 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4282 {
4283 #if FFETARGET_okCOMPLEX1
4284 case FFEINFO_kindtypeREAL1:
4285 error = ffetarget_divide_complex1 (ffebld_cu_ptr_complex1 (u),
4286 ffebld_constant_complex1 (ffebld_conter (l)),
4287 ffebld_constant_complex1 (ffebld_conter (r)));
4288 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
4289 (ffebld_cu_val_complex1 (u)), expr);
4290 break;
4291 #endif
4292
4293 #if FFETARGET_okCOMPLEX2
4294 case FFEINFO_kindtypeREAL2:
4295 error = ffetarget_divide_complex2 (ffebld_cu_ptr_complex2 (u),
4296 ffebld_constant_complex2 (ffebld_conter (l)),
4297 ffebld_constant_complex2 (ffebld_conter (r)));
4298 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
4299 (ffebld_cu_val_complex2 (u)), expr);
4300 break;
4301 #endif
4302
4303 #if FFETARGET_okCOMPLEX3
4304 case FFEINFO_kindtypeREAL3:
4305 error = ffetarget_divide_complex3 (ffebld_cu_ptr_complex3 (u),
4306 ffebld_constant_complex3 (ffebld_conter (l)),
4307 ffebld_constant_complex3 (ffebld_conter (r)));
4308 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
4309 (ffebld_cu_val_complex3 (u)), expr);
4310 break;
4311 #endif
4312
4313 #if FFETARGET_okCOMPLEX4
4314 case FFEINFO_kindtypeREAL4:
4315 error = ffetarget_divide_complex4 (ffebld_cu_ptr_complex4 (u),
4316 ffebld_constant_complex4 (ffebld_conter (l)),
4317 ffebld_constant_complex4 (ffebld_conter (r)));
4318 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
4319 (ffebld_cu_val_complex4 (u)), expr);
4320 break;
4321 #endif
4322
4323 default:
4324 assert ("bad complex kind type" == NULL);
4325 break;
4326 }
4327 break;
4328
4329 default:
4330 assert ("bad type" == NULL);
4331 return expr;
4332 }
4333
4334 ffebld_set_info (expr, ffeinfo_new
4335 (bt,
4336 kt,
4337 0,
4338 FFEINFO_kindENTITY,
4339 FFEINFO_whereCONSTANT,
4340 FFETARGET_charactersizeNONE));
4341
4342 if ((error != FFEBAD)
4343 && ffebad_start (error))
4344 {
4345 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4346 ffebad_finish ();
4347 }
4348
4349 return expr;
4350 }
4351
4352 /* ffeexpr_collapse_power -- Collapse power expr
4353
4354 ffebld expr;
4355 ffelexToken token;
4356 expr = ffeexpr_collapse_power(expr,token);
4357
4358 If the result of the expr is a constant, replaces the expr with the
4359 computed constant. */
4360
4361 ffebld
ffeexpr_collapse_power(ffebld expr,ffelexToken t)4362 ffeexpr_collapse_power (ffebld expr, ffelexToken t)
4363 {
4364 ffebad error = FFEBAD;
4365 ffebld l;
4366 ffebld r;
4367 ffebldConstantUnion u;
4368 ffeinfoBasictype bt;
4369 ffeinfoKindtype kt;
4370
4371 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4372 return expr;
4373
4374 l = ffebld_left (expr);
4375 r = ffebld_right (expr);
4376
4377 if (ffebld_op (l) != FFEBLD_opCONTER)
4378 return expr;
4379 if (ffebld_op (r) != FFEBLD_opCONTER)
4380 return expr;
4381
4382 if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER)
4383 || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT))
4384 return expr;
4385
4386 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
4387 {
4388 case FFEINFO_basictypeANY:
4389 return expr;
4390
4391 case FFEINFO_basictypeINTEGER:
4392 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4393 {
4394 case FFEINFO_kindtypeINTEGERDEFAULT:
4395 error = ffetarget_power_integerdefault_integerdefault
4396 (ffebld_cu_ptr_integerdefault (u),
4397 ffebld_constant_integerdefault (ffebld_conter (l)),
4398 ffebld_constant_integerdefault (ffebld_conter (r)));
4399 expr = ffebld_new_conter_with_orig
4400 (ffebld_constant_new_integerdefault_val
4401 (ffebld_cu_val_integerdefault (u)), expr);
4402 break;
4403
4404 default:
4405 assert ("bad integer kind type" == NULL);
4406 break;
4407 }
4408 break;
4409
4410 case FFEINFO_basictypeREAL:
4411 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4412 {
4413 case FFEINFO_kindtypeREALDEFAULT:
4414 error = ffetarget_power_realdefault_integerdefault
4415 (ffebld_cu_ptr_realdefault (u),
4416 ffebld_constant_realdefault (ffebld_conter (l)),
4417 ffebld_constant_integerdefault (ffebld_conter (r)));
4418 expr = ffebld_new_conter_with_orig
4419 (ffebld_constant_new_realdefault_val
4420 (ffebld_cu_val_realdefault (u)), expr);
4421 break;
4422
4423 case FFEINFO_kindtypeREALDOUBLE:
4424 error = ffetarget_power_realdouble_integerdefault
4425 (ffebld_cu_ptr_realdouble (u),
4426 ffebld_constant_realdouble (ffebld_conter (l)),
4427 ffebld_constant_integerdefault (ffebld_conter (r)));
4428 expr = ffebld_new_conter_with_orig
4429 (ffebld_constant_new_realdouble_val
4430 (ffebld_cu_val_realdouble (u)), expr);
4431 break;
4432
4433 #if FFETARGET_okREALQUAD
4434 case FFEINFO_kindtypeREALQUAD:
4435 error = ffetarget_power_realquad_integerdefault
4436 (ffebld_cu_ptr_realquad (u),
4437 ffebld_constant_realquad (ffebld_conter (l)),
4438 ffebld_constant_integerdefault (ffebld_conter (r)));
4439 expr = ffebld_new_conter_with_orig
4440 (ffebld_constant_new_realquad_val
4441 (ffebld_cu_val_realquad (u)), expr);
4442 break;
4443 #endif
4444 default:
4445 assert ("bad real kind type" == NULL);
4446 break;
4447 }
4448 break;
4449
4450 case FFEINFO_basictypeCOMPLEX:
4451 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4452 {
4453 case FFEINFO_kindtypeREALDEFAULT:
4454 error = ffetarget_power_complexdefault_integerdefault
4455 (ffebld_cu_ptr_complexdefault (u),
4456 ffebld_constant_complexdefault (ffebld_conter (l)),
4457 ffebld_constant_integerdefault (ffebld_conter (r)));
4458 expr = ffebld_new_conter_with_orig
4459 (ffebld_constant_new_complexdefault_val
4460 (ffebld_cu_val_complexdefault (u)), expr);
4461 break;
4462
4463 #if FFETARGET_okCOMPLEXDOUBLE
4464 case FFEINFO_kindtypeREALDOUBLE:
4465 error = ffetarget_power_complexdouble_integerdefault
4466 (ffebld_cu_ptr_complexdouble (u),
4467 ffebld_constant_complexdouble (ffebld_conter (l)),
4468 ffebld_constant_integerdefault (ffebld_conter (r)));
4469 expr = ffebld_new_conter_with_orig
4470 (ffebld_constant_new_complexdouble_val
4471 (ffebld_cu_val_complexdouble (u)), expr);
4472 break;
4473 #endif
4474
4475 #if FFETARGET_okCOMPLEXQUAD
4476 case FFEINFO_kindtypeREALQUAD:
4477 error = ffetarget_power_complexquad_integerdefault
4478 (ffebld_cu_ptr_complexquad (u),
4479 ffebld_constant_complexquad (ffebld_conter (l)),
4480 ffebld_constant_integerdefault (ffebld_conter (r)));
4481 expr = ffebld_new_conter_with_orig
4482 (ffebld_constant_new_complexquad_val
4483 (ffebld_cu_val_complexquad (u)), expr);
4484 break;
4485 #endif
4486
4487 default:
4488 assert ("bad complex kind type" == NULL);
4489 break;
4490 }
4491 break;
4492
4493 default:
4494 assert ("bad type" == NULL);
4495 return expr;
4496 }
4497
4498 ffebld_set_info (expr, ffeinfo_new
4499 (bt,
4500 kt,
4501 0,
4502 FFEINFO_kindENTITY,
4503 FFEINFO_whereCONSTANT,
4504 FFETARGET_charactersizeNONE));
4505
4506 if ((error != FFEBAD)
4507 && ffebad_start (error))
4508 {
4509 ffebad_here (0, ffelex_token_where_line (t),
4510 ffelex_token_where_column (t));
4511 ffebad_finish ();
4512 }
4513
4514 return expr;
4515 }
4516
4517 /* ffeexpr_collapse_concatenate -- Collapse concatenate expr
4518
4519 ffebld expr;
4520 ffelexToken token;
4521 expr = ffeexpr_collapse_concatenate(expr,token);
4522
4523 If the result of the expr is a constant, replaces the expr with the
4524 computed constant. */
4525
4526 ffebld
ffeexpr_collapse_concatenate(ffebld expr,ffelexToken t)4527 ffeexpr_collapse_concatenate (ffebld expr, ffelexToken t)
4528 {
4529 ffebad error = FFEBAD;
4530 ffebld l;
4531 ffebld r;
4532 ffebldConstantUnion u;
4533 ffeinfoKindtype kt;
4534 ffetargetCharacterSize len;
4535
4536 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4537 return expr;
4538
4539 l = ffebld_left (expr);
4540 r = ffebld_right (expr);
4541
4542 if (ffebld_op (l) != FFEBLD_opCONTER)
4543 return expr;
4544 if (ffebld_op (r) != FFEBLD_opCONTER)
4545 return expr;
4546
4547 switch (ffeinfo_basictype (ffebld_info (expr)))
4548 {
4549 case FFEINFO_basictypeANY:
4550 return expr;
4551
4552 case FFEINFO_basictypeCHARACTER:
4553 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4554 {
4555 #if FFETARGET_okCHARACTER1
4556 case FFEINFO_kindtypeCHARACTER1:
4557 error = ffetarget_concatenate_character1 (ffebld_cu_ptr_character1 (u),
4558 ffebld_constant_character1 (ffebld_conter (l)),
4559 ffebld_constant_character1 (ffebld_conter (r)),
4560 ffebld_constant_pool (), &len);
4561 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
4562 (ffebld_cu_val_character1 (u)), expr);
4563 break;
4564 #endif
4565
4566 #if FFETARGET_okCHARACTER2
4567 case FFEINFO_kindtypeCHARACTER2:
4568 error = ffetarget_concatenate_character2 (ffebld_cu_ptr_character2 (u),
4569 ffebld_constant_character2 (ffebld_conter (l)),
4570 ffebld_constant_character2 (ffebld_conter (r)),
4571 ffebld_constant_pool (), &len);
4572 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val
4573 (ffebld_cu_val_character2 (u)), expr);
4574 break;
4575 #endif
4576
4577 #if FFETARGET_okCHARACTER3
4578 case FFEINFO_kindtypeCHARACTER3:
4579 error = ffetarget_concatenate_character3 (ffebld_cu_ptr_character3 (u),
4580 ffebld_constant_character3 (ffebld_conter (l)),
4581 ffebld_constant_character3 (ffebld_conter (r)),
4582 ffebld_constant_pool (), &len);
4583 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val
4584 (ffebld_cu_val_character3 (u)), expr);
4585 break;
4586 #endif
4587
4588 #if FFETARGET_okCHARACTER4
4589 case FFEINFO_kindtypeCHARACTER4:
4590 error = ffetarget_concatenate_character4 (ffebld_cu_ptr_character4 (u),
4591 ffebld_constant_character4 (ffebld_conter (l)),
4592 ffebld_constant_character4 (ffebld_conter (r)),
4593 ffebld_constant_pool (), &len);
4594 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val
4595 (ffebld_cu_val_character4 (u)), expr);
4596 break;
4597 #endif
4598
4599 default:
4600 assert ("bad character kind type" == NULL);
4601 break;
4602 }
4603 break;
4604
4605 default:
4606 assert ("bad type" == NULL);
4607 return expr;
4608 }
4609
4610 ffebld_set_info (expr, ffeinfo_new
4611 (FFEINFO_basictypeCHARACTER,
4612 kt,
4613 0,
4614 FFEINFO_kindENTITY,
4615 FFEINFO_whereCONSTANT,
4616 len));
4617
4618 if ((error != FFEBAD)
4619 && ffebad_start (error))
4620 {
4621 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4622 ffebad_finish ();
4623 }
4624
4625 return expr;
4626 }
4627
4628 /* ffeexpr_collapse_eq -- Collapse eq expr
4629
4630 ffebld expr;
4631 ffelexToken token;
4632 expr = ffeexpr_collapse_eq(expr,token);
4633
4634 If the result of the expr is a constant, replaces the expr with the
4635 computed constant. */
4636
4637 ffebld
ffeexpr_collapse_eq(ffebld expr,ffelexToken t)4638 ffeexpr_collapse_eq (ffebld expr, ffelexToken t)
4639 {
4640 ffebad error = FFEBAD;
4641 ffebld l;
4642 ffebld r;
4643 bool val;
4644
4645 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4646 return expr;
4647
4648 l = ffebld_left (expr);
4649 r = ffebld_right (expr);
4650
4651 if (ffebld_op (l) != FFEBLD_opCONTER)
4652 return expr;
4653 if (ffebld_op (r) != FFEBLD_opCONTER)
4654 return expr;
4655
4656 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4657 {
4658 case FFEINFO_basictypeANY:
4659 return expr;
4660
4661 case FFEINFO_basictypeINTEGER:
4662 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4663 {
4664 #if FFETARGET_okINTEGER1
4665 case FFEINFO_kindtypeINTEGER1:
4666 error = ffetarget_eq_integer1 (&val,
4667 ffebld_constant_integer1 (ffebld_conter (l)),
4668 ffebld_constant_integer1 (ffebld_conter (r)));
4669 expr = ffebld_new_conter_with_orig
4670 (ffebld_constant_new_logicaldefault (val), expr);
4671 break;
4672 #endif
4673
4674 #if FFETARGET_okINTEGER2
4675 case FFEINFO_kindtypeINTEGER2:
4676 error = ffetarget_eq_integer2 (&val,
4677 ffebld_constant_integer2 (ffebld_conter (l)),
4678 ffebld_constant_integer2 (ffebld_conter (r)));
4679 expr = ffebld_new_conter_with_orig
4680 (ffebld_constant_new_logicaldefault (val), expr);
4681 break;
4682 #endif
4683
4684 #if FFETARGET_okINTEGER3
4685 case FFEINFO_kindtypeINTEGER3:
4686 error = ffetarget_eq_integer3 (&val,
4687 ffebld_constant_integer3 (ffebld_conter (l)),
4688 ffebld_constant_integer3 (ffebld_conter (r)));
4689 expr = ffebld_new_conter_with_orig
4690 (ffebld_constant_new_logicaldefault (val), expr);
4691 break;
4692 #endif
4693
4694 #if FFETARGET_okINTEGER4
4695 case FFEINFO_kindtypeINTEGER4:
4696 error = ffetarget_eq_integer4 (&val,
4697 ffebld_constant_integer4 (ffebld_conter (l)),
4698 ffebld_constant_integer4 (ffebld_conter (r)));
4699 expr = ffebld_new_conter_with_orig
4700 (ffebld_constant_new_logicaldefault (val), expr);
4701 break;
4702 #endif
4703
4704 default:
4705 assert ("bad integer kind type" == NULL);
4706 break;
4707 }
4708 break;
4709
4710 case FFEINFO_basictypeREAL:
4711 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4712 {
4713 #if FFETARGET_okREAL1
4714 case FFEINFO_kindtypeREAL1:
4715 error = ffetarget_eq_real1 (&val,
4716 ffebld_constant_real1 (ffebld_conter (l)),
4717 ffebld_constant_real1 (ffebld_conter (r)));
4718 expr = ffebld_new_conter_with_orig
4719 (ffebld_constant_new_logicaldefault (val), expr);
4720 break;
4721 #endif
4722
4723 #if FFETARGET_okREAL2
4724 case FFEINFO_kindtypeREAL2:
4725 error = ffetarget_eq_real2 (&val,
4726 ffebld_constant_real2 (ffebld_conter (l)),
4727 ffebld_constant_real2 (ffebld_conter (r)));
4728 expr = ffebld_new_conter_with_orig
4729 (ffebld_constant_new_logicaldefault (val), expr);
4730 break;
4731 #endif
4732
4733 #if FFETARGET_okREAL3
4734 case FFEINFO_kindtypeREAL3:
4735 error = ffetarget_eq_real3 (&val,
4736 ffebld_constant_real3 (ffebld_conter (l)),
4737 ffebld_constant_real3 (ffebld_conter (r)));
4738 expr = ffebld_new_conter_with_orig
4739 (ffebld_constant_new_logicaldefault (val), expr);
4740 break;
4741 #endif
4742
4743 #if FFETARGET_okREAL4
4744 case FFEINFO_kindtypeREAL4:
4745 error = ffetarget_eq_real4 (&val,
4746 ffebld_constant_real4 (ffebld_conter (l)),
4747 ffebld_constant_real4 (ffebld_conter (r)));
4748 expr = ffebld_new_conter_with_orig
4749 (ffebld_constant_new_logicaldefault (val), expr);
4750 break;
4751 #endif
4752
4753 default:
4754 assert ("bad real kind type" == NULL);
4755 break;
4756 }
4757 break;
4758
4759 case FFEINFO_basictypeCOMPLEX:
4760 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4761 {
4762 #if FFETARGET_okCOMPLEX1
4763 case FFEINFO_kindtypeREAL1:
4764 error = ffetarget_eq_complex1 (&val,
4765 ffebld_constant_complex1 (ffebld_conter (l)),
4766 ffebld_constant_complex1 (ffebld_conter (r)));
4767 expr = ffebld_new_conter_with_orig
4768 (ffebld_constant_new_logicaldefault (val), expr);
4769 break;
4770 #endif
4771
4772 #if FFETARGET_okCOMPLEX2
4773 case FFEINFO_kindtypeREAL2:
4774 error = ffetarget_eq_complex2 (&val,
4775 ffebld_constant_complex2 (ffebld_conter (l)),
4776 ffebld_constant_complex2 (ffebld_conter (r)));
4777 expr = ffebld_new_conter_with_orig
4778 (ffebld_constant_new_logicaldefault (val), expr);
4779 break;
4780 #endif
4781
4782 #if FFETARGET_okCOMPLEX3
4783 case FFEINFO_kindtypeREAL3:
4784 error = ffetarget_eq_complex3 (&val,
4785 ffebld_constant_complex3 (ffebld_conter (l)),
4786 ffebld_constant_complex3 (ffebld_conter (r)));
4787 expr = ffebld_new_conter_with_orig
4788 (ffebld_constant_new_logicaldefault (val), expr);
4789 break;
4790 #endif
4791
4792 #if FFETARGET_okCOMPLEX4
4793 case FFEINFO_kindtypeREAL4:
4794 error = ffetarget_eq_complex4 (&val,
4795 ffebld_constant_complex4 (ffebld_conter (l)),
4796 ffebld_constant_complex4 (ffebld_conter (r)));
4797 expr = ffebld_new_conter_with_orig
4798 (ffebld_constant_new_logicaldefault (val), expr);
4799 break;
4800 #endif
4801
4802 default:
4803 assert ("bad complex kind type" == NULL);
4804 break;
4805 }
4806 break;
4807
4808 case FFEINFO_basictypeCHARACTER:
4809 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4810 {
4811 #if FFETARGET_okCHARACTER1
4812 case FFEINFO_kindtypeCHARACTER1:
4813 error = ffetarget_eq_character1 (&val,
4814 ffebld_constant_character1 (ffebld_conter (l)),
4815 ffebld_constant_character1 (ffebld_conter (r)));
4816 expr = ffebld_new_conter_with_orig
4817 (ffebld_constant_new_logicaldefault (val), expr);
4818 break;
4819 #endif
4820
4821 #if FFETARGET_okCHARACTER2
4822 case FFEINFO_kindtypeCHARACTER2:
4823 error = ffetarget_eq_character2 (&val,
4824 ffebld_constant_character2 (ffebld_conter (l)),
4825 ffebld_constant_character2 (ffebld_conter (r)));
4826 expr = ffebld_new_conter_with_orig
4827 (ffebld_constant_new_logicaldefault (val), expr);
4828 break;
4829 #endif
4830
4831 #if FFETARGET_okCHARACTER3
4832 case FFEINFO_kindtypeCHARACTER3:
4833 error = ffetarget_eq_character3 (&val,
4834 ffebld_constant_character3 (ffebld_conter (l)),
4835 ffebld_constant_character3 (ffebld_conter (r)));
4836 expr = ffebld_new_conter_with_orig
4837 (ffebld_constant_new_logicaldefault (val), expr);
4838 break;
4839 #endif
4840
4841 #if FFETARGET_okCHARACTER4
4842 case FFEINFO_kindtypeCHARACTER4:
4843 error = ffetarget_eq_character4 (&val,
4844 ffebld_constant_character4 (ffebld_conter (l)),
4845 ffebld_constant_character4 (ffebld_conter (r)));
4846 expr = ffebld_new_conter_with_orig
4847 (ffebld_constant_new_logicaldefault (val), expr);
4848 break;
4849 #endif
4850
4851 default:
4852 assert ("bad character kind type" == NULL);
4853 break;
4854 }
4855 break;
4856
4857 default:
4858 assert ("bad type" == NULL);
4859 return expr;
4860 }
4861
4862 ffebld_set_info (expr, ffeinfo_new
4863 (FFEINFO_basictypeLOGICAL,
4864 FFEINFO_kindtypeLOGICALDEFAULT,
4865 0,
4866 FFEINFO_kindENTITY,
4867 FFEINFO_whereCONSTANT,
4868 FFETARGET_charactersizeNONE));
4869
4870 if ((error != FFEBAD)
4871 && ffebad_start (error))
4872 {
4873 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4874 ffebad_finish ();
4875 }
4876
4877 return expr;
4878 }
4879
4880 /* ffeexpr_collapse_ne -- Collapse ne expr
4881
4882 ffebld expr;
4883 ffelexToken token;
4884 expr = ffeexpr_collapse_ne(expr,token);
4885
4886 If the result of the expr is a constant, replaces the expr with the
4887 computed constant. */
4888
4889 ffebld
ffeexpr_collapse_ne(ffebld expr,ffelexToken t)4890 ffeexpr_collapse_ne (ffebld expr, ffelexToken t)
4891 {
4892 ffebad error = FFEBAD;
4893 ffebld l;
4894 ffebld r;
4895 bool val;
4896
4897 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4898 return expr;
4899
4900 l = ffebld_left (expr);
4901 r = ffebld_right (expr);
4902
4903 if (ffebld_op (l) != FFEBLD_opCONTER)
4904 return expr;
4905 if (ffebld_op (r) != FFEBLD_opCONTER)
4906 return expr;
4907
4908 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4909 {
4910 case FFEINFO_basictypeANY:
4911 return expr;
4912
4913 case FFEINFO_basictypeINTEGER:
4914 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4915 {
4916 #if FFETARGET_okINTEGER1
4917 case FFEINFO_kindtypeINTEGER1:
4918 error = ffetarget_ne_integer1 (&val,
4919 ffebld_constant_integer1 (ffebld_conter (l)),
4920 ffebld_constant_integer1 (ffebld_conter (r)));
4921 expr = ffebld_new_conter_with_orig
4922 (ffebld_constant_new_logicaldefault (val), expr);
4923 break;
4924 #endif
4925
4926 #if FFETARGET_okINTEGER2
4927 case FFEINFO_kindtypeINTEGER2:
4928 error = ffetarget_ne_integer2 (&val,
4929 ffebld_constant_integer2 (ffebld_conter (l)),
4930 ffebld_constant_integer2 (ffebld_conter (r)));
4931 expr = ffebld_new_conter_with_orig
4932 (ffebld_constant_new_logicaldefault (val), expr);
4933 break;
4934 #endif
4935
4936 #if FFETARGET_okINTEGER3
4937 case FFEINFO_kindtypeINTEGER3:
4938 error = ffetarget_ne_integer3 (&val,
4939 ffebld_constant_integer3 (ffebld_conter (l)),
4940 ffebld_constant_integer3 (ffebld_conter (r)));
4941 expr = ffebld_new_conter_with_orig
4942 (ffebld_constant_new_logicaldefault (val), expr);
4943 break;
4944 #endif
4945
4946 #if FFETARGET_okINTEGER4
4947 case FFEINFO_kindtypeINTEGER4:
4948 error = ffetarget_ne_integer4 (&val,
4949 ffebld_constant_integer4 (ffebld_conter (l)),
4950 ffebld_constant_integer4 (ffebld_conter (r)));
4951 expr = ffebld_new_conter_with_orig
4952 (ffebld_constant_new_logicaldefault (val), expr);
4953 break;
4954 #endif
4955
4956 default:
4957 assert ("bad integer kind type" == NULL);
4958 break;
4959 }
4960 break;
4961
4962 case FFEINFO_basictypeREAL:
4963 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4964 {
4965 #if FFETARGET_okREAL1
4966 case FFEINFO_kindtypeREAL1:
4967 error = ffetarget_ne_real1 (&val,
4968 ffebld_constant_real1 (ffebld_conter (l)),
4969 ffebld_constant_real1 (ffebld_conter (r)));
4970 expr = ffebld_new_conter_with_orig
4971 (ffebld_constant_new_logicaldefault (val), expr);
4972 break;
4973 #endif
4974
4975 #if FFETARGET_okREAL2
4976 case FFEINFO_kindtypeREAL2:
4977 error = ffetarget_ne_real2 (&val,
4978 ffebld_constant_real2 (ffebld_conter (l)),
4979 ffebld_constant_real2 (ffebld_conter (r)));
4980 expr = ffebld_new_conter_with_orig
4981 (ffebld_constant_new_logicaldefault (val), expr);
4982 break;
4983 #endif
4984
4985 #if FFETARGET_okREAL3
4986 case FFEINFO_kindtypeREAL3:
4987 error = ffetarget_ne_real3 (&val,
4988 ffebld_constant_real3 (ffebld_conter (l)),
4989 ffebld_constant_real3 (ffebld_conter (r)));
4990 expr = ffebld_new_conter_with_orig
4991 (ffebld_constant_new_logicaldefault (val), expr);
4992 break;
4993 #endif
4994
4995 #if FFETARGET_okREAL4
4996 case FFEINFO_kindtypeREAL4:
4997 error = ffetarget_ne_real4 (&val,
4998 ffebld_constant_real4 (ffebld_conter (l)),
4999 ffebld_constant_real4 (ffebld_conter (r)));
5000 expr = ffebld_new_conter_with_orig
5001 (ffebld_constant_new_logicaldefault (val), expr);
5002 break;
5003 #endif
5004
5005 default:
5006 assert ("bad real kind type" == NULL);
5007 break;
5008 }
5009 break;
5010
5011 case FFEINFO_basictypeCOMPLEX:
5012 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5013 {
5014 #if FFETARGET_okCOMPLEX1
5015 case FFEINFO_kindtypeREAL1:
5016 error = ffetarget_ne_complex1 (&val,
5017 ffebld_constant_complex1 (ffebld_conter (l)),
5018 ffebld_constant_complex1 (ffebld_conter (r)));
5019 expr = ffebld_new_conter_with_orig
5020 (ffebld_constant_new_logicaldefault (val), expr);
5021 break;
5022 #endif
5023
5024 #if FFETARGET_okCOMPLEX2
5025 case FFEINFO_kindtypeREAL2:
5026 error = ffetarget_ne_complex2 (&val,
5027 ffebld_constant_complex2 (ffebld_conter (l)),
5028 ffebld_constant_complex2 (ffebld_conter (r)));
5029 expr = ffebld_new_conter_with_orig
5030 (ffebld_constant_new_logicaldefault (val), expr);
5031 break;
5032 #endif
5033
5034 #if FFETARGET_okCOMPLEX3
5035 case FFEINFO_kindtypeREAL3:
5036 error = ffetarget_ne_complex3 (&val,
5037 ffebld_constant_complex3 (ffebld_conter (l)),
5038 ffebld_constant_complex3 (ffebld_conter (r)));
5039 expr = ffebld_new_conter_with_orig
5040 (ffebld_constant_new_logicaldefault (val), expr);
5041 break;
5042 #endif
5043
5044 #if FFETARGET_okCOMPLEX4
5045 case FFEINFO_kindtypeREAL4:
5046 error = ffetarget_ne_complex4 (&val,
5047 ffebld_constant_complex4 (ffebld_conter (l)),
5048 ffebld_constant_complex4 (ffebld_conter (r)));
5049 expr = ffebld_new_conter_with_orig
5050 (ffebld_constant_new_logicaldefault (val), expr);
5051 break;
5052 #endif
5053
5054 default:
5055 assert ("bad complex kind type" == NULL);
5056 break;
5057 }
5058 break;
5059
5060 case FFEINFO_basictypeCHARACTER:
5061 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5062 {
5063 #if FFETARGET_okCHARACTER1
5064 case FFEINFO_kindtypeCHARACTER1:
5065 error = ffetarget_ne_character1 (&val,
5066 ffebld_constant_character1 (ffebld_conter (l)),
5067 ffebld_constant_character1 (ffebld_conter (r)));
5068 expr = ffebld_new_conter_with_orig
5069 (ffebld_constant_new_logicaldefault (val), expr);
5070 break;
5071 #endif
5072
5073 #if FFETARGET_okCHARACTER2
5074 case FFEINFO_kindtypeCHARACTER2:
5075 error = ffetarget_ne_character2 (&val,
5076 ffebld_constant_character2 (ffebld_conter (l)),
5077 ffebld_constant_character2 (ffebld_conter (r)));
5078 expr = ffebld_new_conter_with_orig
5079 (ffebld_constant_new_logicaldefault (val), expr);
5080 break;
5081 #endif
5082
5083 #if FFETARGET_okCHARACTER3
5084 case FFEINFO_kindtypeCHARACTER3:
5085 error = ffetarget_ne_character3 (&val,
5086 ffebld_constant_character3 (ffebld_conter (l)),
5087 ffebld_constant_character3 (ffebld_conter (r)));
5088 expr = ffebld_new_conter_with_orig
5089 (ffebld_constant_new_logicaldefault (val), expr);
5090 break;
5091 #endif
5092
5093 #if FFETARGET_okCHARACTER4
5094 case FFEINFO_kindtypeCHARACTER4:
5095 error = ffetarget_ne_character4 (&val,
5096 ffebld_constant_character4 (ffebld_conter (l)),
5097 ffebld_constant_character4 (ffebld_conter (r)));
5098 expr = ffebld_new_conter_with_orig
5099 (ffebld_constant_new_logicaldefault (val), expr);
5100 break;
5101 #endif
5102
5103 default:
5104 assert ("bad character kind type" == NULL);
5105 break;
5106 }
5107 break;
5108
5109 default:
5110 assert ("bad type" == NULL);
5111 return expr;
5112 }
5113
5114 ffebld_set_info (expr, ffeinfo_new
5115 (FFEINFO_basictypeLOGICAL,
5116 FFEINFO_kindtypeLOGICALDEFAULT,
5117 0,
5118 FFEINFO_kindENTITY,
5119 FFEINFO_whereCONSTANT,
5120 FFETARGET_charactersizeNONE));
5121
5122 if ((error != FFEBAD)
5123 && ffebad_start (error))
5124 {
5125 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5126 ffebad_finish ();
5127 }
5128
5129 return expr;
5130 }
5131
5132 /* ffeexpr_collapse_ge -- Collapse ge expr
5133
5134 ffebld expr;
5135 ffelexToken token;
5136 expr = ffeexpr_collapse_ge(expr,token);
5137
5138 If the result of the expr is a constant, replaces the expr with the
5139 computed constant. */
5140
5141 ffebld
ffeexpr_collapse_ge(ffebld expr,ffelexToken t)5142 ffeexpr_collapse_ge (ffebld expr, ffelexToken t)
5143 {
5144 ffebad error = FFEBAD;
5145 ffebld l;
5146 ffebld r;
5147 bool val;
5148
5149 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5150 return expr;
5151
5152 l = ffebld_left (expr);
5153 r = ffebld_right (expr);
5154
5155 if (ffebld_op (l) != FFEBLD_opCONTER)
5156 return expr;
5157 if (ffebld_op (r) != FFEBLD_opCONTER)
5158 return expr;
5159
5160 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5161 {
5162 case FFEINFO_basictypeANY:
5163 return expr;
5164
5165 case FFEINFO_basictypeINTEGER:
5166 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5167 {
5168 #if FFETARGET_okINTEGER1
5169 case FFEINFO_kindtypeINTEGER1:
5170 error = ffetarget_ge_integer1 (&val,
5171 ffebld_constant_integer1 (ffebld_conter (l)),
5172 ffebld_constant_integer1 (ffebld_conter (r)));
5173 expr = ffebld_new_conter_with_orig
5174 (ffebld_constant_new_logicaldefault (val), expr);
5175 break;
5176 #endif
5177
5178 #if FFETARGET_okINTEGER2
5179 case FFEINFO_kindtypeINTEGER2:
5180 error = ffetarget_ge_integer2 (&val,
5181 ffebld_constant_integer2 (ffebld_conter (l)),
5182 ffebld_constant_integer2 (ffebld_conter (r)));
5183 expr = ffebld_new_conter_with_orig
5184 (ffebld_constant_new_logicaldefault (val), expr);
5185 break;
5186 #endif
5187
5188 #if FFETARGET_okINTEGER3
5189 case FFEINFO_kindtypeINTEGER3:
5190 error = ffetarget_ge_integer3 (&val,
5191 ffebld_constant_integer3 (ffebld_conter (l)),
5192 ffebld_constant_integer3 (ffebld_conter (r)));
5193 expr = ffebld_new_conter_with_orig
5194 (ffebld_constant_new_logicaldefault (val), expr);
5195 break;
5196 #endif
5197
5198 #if FFETARGET_okINTEGER4
5199 case FFEINFO_kindtypeINTEGER4:
5200 error = ffetarget_ge_integer4 (&val,
5201 ffebld_constant_integer4 (ffebld_conter (l)),
5202 ffebld_constant_integer4 (ffebld_conter (r)));
5203 expr = ffebld_new_conter_with_orig
5204 (ffebld_constant_new_logicaldefault (val), expr);
5205 break;
5206 #endif
5207
5208 default:
5209 assert ("bad integer kind type" == NULL);
5210 break;
5211 }
5212 break;
5213
5214 case FFEINFO_basictypeREAL:
5215 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5216 {
5217 #if FFETARGET_okREAL1
5218 case FFEINFO_kindtypeREAL1:
5219 error = ffetarget_ge_real1 (&val,
5220 ffebld_constant_real1 (ffebld_conter (l)),
5221 ffebld_constant_real1 (ffebld_conter (r)));
5222 expr = ffebld_new_conter_with_orig
5223 (ffebld_constant_new_logicaldefault (val), expr);
5224 break;
5225 #endif
5226
5227 #if FFETARGET_okREAL2
5228 case FFEINFO_kindtypeREAL2:
5229 error = ffetarget_ge_real2 (&val,
5230 ffebld_constant_real2 (ffebld_conter (l)),
5231 ffebld_constant_real2 (ffebld_conter (r)));
5232 expr = ffebld_new_conter_with_orig
5233 (ffebld_constant_new_logicaldefault (val), expr);
5234 break;
5235 #endif
5236
5237 #if FFETARGET_okREAL3
5238 case FFEINFO_kindtypeREAL3:
5239 error = ffetarget_ge_real3 (&val,
5240 ffebld_constant_real3 (ffebld_conter (l)),
5241 ffebld_constant_real3 (ffebld_conter (r)));
5242 expr = ffebld_new_conter_with_orig
5243 (ffebld_constant_new_logicaldefault (val), expr);
5244 break;
5245 #endif
5246
5247 #if FFETARGET_okREAL4
5248 case FFEINFO_kindtypeREAL4:
5249 error = ffetarget_ge_real4 (&val,
5250 ffebld_constant_real4 (ffebld_conter (l)),
5251 ffebld_constant_real4 (ffebld_conter (r)));
5252 expr = ffebld_new_conter_with_orig
5253 (ffebld_constant_new_logicaldefault (val), expr);
5254 break;
5255 #endif
5256
5257 default:
5258 assert ("bad real kind type" == NULL);
5259 break;
5260 }
5261 break;
5262
5263 case FFEINFO_basictypeCHARACTER:
5264 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5265 {
5266 #if FFETARGET_okCHARACTER1
5267 case FFEINFO_kindtypeCHARACTER1:
5268 error = ffetarget_ge_character1 (&val,
5269 ffebld_constant_character1 (ffebld_conter (l)),
5270 ffebld_constant_character1 (ffebld_conter (r)));
5271 expr = ffebld_new_conter_with_orig
5272 (ffebld_constant_new_logicaldefault (val), expr);
5273 break;
5274 #endif
5275
5276 #if FFETARGET_okCHARACTER2
5277 case FFEINFO_kindtypeCHARACTER2:
5278 error = ffetarget_ge_character2 (&val,
5279 ffebld_constant_character2 (ffebld_conter (l)),
5280 ffebld_constant_character2 (ffebld_conter (r)));
5281 expr = ffebld_new_conter_with_orig
5282 (ffebld_constant_new_logicaldefault (val), expr);
5283 break;
5284 #endif
5285
5286 #if FFETARGET_okCHARACTER3
5287 case FFEINFO_kindtypeCHARACTER3:
5288 error = ffetarget_ge_character3 (&val,
5289 ffebld_constant_character3 (ffebld_conter (l)),
5290 ffebld_constant_character3 (ffebld_conter (r)));
5291 expr = ffebld_new_conter_with_orig
5292 (ffebld_constant_new_logicaldefault (val), expr);
5293 break;
5294 #endif
5295
5296 #if FFETARGET_okCHARACTER4
5297 case FFEINFO_kindtypeCHARACTER4:
5298 error = ffetarget_ge_character4 (&val,
5299 ffebld_constant_character4 (ffebld_conter (l)),
5300 ffebld_constant_character4 (ffebld_conter (r)));
5301 expr = ffebld_new_conter_with_orig
5302 (ffebld_constant_new_logicaldefault (val), expr);
5303 break;
5304 #endif
5305
5306 default:
5307 assert ("bad character kind type" == NULL);
5308 break;
5309 }
5310 break;
5311
5312 default:
5313 assert ("bad type" == NULL);
5314 return expr;
5315 }
5316
5317 ffebld_set_info (expr, ffeinfo_new
5318 (FFEINFO_basictypeLOGICAL,
5319 FFEINFO_kindtypeLOGICALDEFAULT,
5320 0,
5321 FFEINFO_kindENTITY,
5322 FFEINFO_whereCONSTANT,
5323 FFETARGET_charactersizeNONE));
5324
5325 if ((error != FFEBAD)
5326 && ffebad_start (error))
5327 {
5328 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5329 ffebad_finish ();
5330 }
5331
5332 return expr;
5333 }
5334
5335 /* ffeexpr_collapse_gt -- Collapse gt expr
5336
5337 ffebld expr;
5338 ffelexToken token;
5339 expr = ffeexpr_collapse_gt(expr,token);
5340
5341 If the result of the expr is a constant, replaces the expr with the
5342 computed constant. */
5343
5344 ffebld
ffeexpr_collapse_gt(ffebld expr,ffelexToken t)5345 ffeexpr_collapse_gt (ffebld expr, ffelexToken t)
5346 {
5347 ffebad error = FFEBAD;
5348 ffebld l;
5349 ffebld r;
5350 bool val;
5351
5352 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5353 return expr;
5354
5355 l = ffebld_left (expr);
5356 r = ffebld_right (expr);
5357
5358 if (ffebld_op (l) != FFEBLD_opCONTER)
5359 return expr;
5360 if (ffebld_op (r) != FFEBLD_opCONTER)
5361 return expr;
5362
5363 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5364 {
5365 case FFEINFO_basictypeANY:
5366 return expr;
5367
5368 case FFEINFO_basictypeINTEGER:
5369 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5370 {
5371 #if FFETARGET_okINTEGER1
5372 case FFEINFO_kindtypeINTEGER1:
5373 error = ffetarget_gt_integer1 (&val,
5374 ffebld_constant_integer1 (ffebld_conter (l)),
5375 ffebld_constant_integer1 (ffebld_conter (r)));
5376 expr = ffebld_new_conter_with_orig
5377 (ffebld_constant_new_logicaldefault (val), expr);
5378 break;
5379 #endif
5380
5381 #if FFETARGET_okINTEGER2
5382 case FFEINFO_kindtypeINTEGER2:
5383 error = ffetarget_gt_integer2 (&val,
5384 ffebld_constant_integer2 (ffebld_conter (l)),
5385 ffebld_constant_integer2 (ffebld_conter (r)));
5386 expr = ffebld_new_conter_with_orig
5387 (ffebld_constant_new_logicaldefault (val), expr);
5388 break;
5389 #endif
5390
5391 #if FFETARGET_okINTEGER3
5392 case FFEINFO_kindtypeINTEGER3:
5393 error = ffetarget_gt_integer3 (&val,
5394 ffebld_constant_integer3 (ffebld_conter (l)),
5395 ffebld_constant_integer3 (ffebld_conter (r)));
5396 expr = ffebld_new_conter_with_orig
5397 (ffebld_constant_new_logicaldefault (val), expr);
5398 break;
5399 #endif
5400
5401 #if FFETARGET_okINTEGER4
5402 case FFEINFO_kindtypeINTEGER4:
5403 error = ffetarget_gt_integer4 (&val,
5404 ffebld_constant_integer4 (ffebld_conter (l)),
5405 ffebld_constant_integer4 (ffebld_conter (r)));
5406 expr = ffebld_new_conter_with_orig
5407 (ffebld_constant_new_logicaldefault (val), expr);
5408 break;
5409 #endif
5410
5411 default:
5412 assert ("bad integer kind type" == NULL);
5413 break;
5414 }
5415 break;
5416
5417 case FFEINFO_basictypeREAL:
5418 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5419 {
5420 #if FFETARGET_okREAL1
5421 case FFEINFO_kindtypeREAL1:
5422 error = ffetarget_gt_real1 (&val,
5423 ffebld_constant_real1 (ffebld_conter (l)),
5424 ffebld_constant_real1 (ffebld_conter (r)));
5425 expr = ffebld_new_conter_with_orig
5426 (ffebld_constant_new_logicaldefault (val), expr);
5427 break;
5428 #endif
5429
5430 #if FFETARGET_okREAL2
5431 case FFEINFO_kindtypeREAL2:
5432 error = ffetarget_gt_real2 (&val,
5433 ffebld_constant_real2 (ffebld_conter (l)),
5434 ffebld_constant_real2 (ffebld_conter (r)));
5435 expr = ffebld_new_conter_with_orig
5436 (ffebld_constant_new_logicaldefault (val), expr);
5437 break;
5438 #endif
5439
5440 #if FFETARGET_okREAL3
5441 case FFEINFO_kindtypeREAL3:
5442 error = ffetarget_gt_real3 (&val,
5443 ffebld_constant_real3 (ffebld_conter (l)),
5444 ffebld_constant_real3 (ffebld_conter (r)));
5445 expr = ffebld_new_conter_with_orig
5446 (ffebld_constant_new_logicaldefault (val), expr);
5447 break;
5448 #endif
5449
5450 #if FFETARGET_okREAL4
5451 case FFEINFO_kindtypeREAL4:
5452 error = ffetarget_gt_real4 (&val,
5453 ffebld_constant_real4 (ffebld_conter (l)),
5454 ffebld_constant_real4 (ffebld_conter (r)));
5455 expr = ffebld_new_conter_with_orig
5456 (ffebld_constant_new_logicaldefault (val), expr);
5457 break;
5458 #endif
5459
5460 default:
5461 assert ("bad real kind type" == NULL);
5462 break;
5463 }
5464 break;
5465
5466 case FFEINFO_basictypeCHARACTER:
5467 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5468 {
5469 #if FFETARGET_okCHARACTER1
5470 case FFEINFO_kindtypeCHARACTER1:
5471 error = ffetarget_gt_character1 (&val,
5472 ffebld_constant_character1 (ffebld_conter (l)),
5473 ffebld_constant_character1 (ffebld_conter (r)));
5474 expr = ffebld_new_conter_with_orig
5475 (ffebld_constant_new_logicaldefault (val), expr);
5476 break;
5477 #endif
5478
5479 #if FFETARGET_okCHARACTER2
5480 case FFEINFO_kindtypeCHARACTER2:
5481 error = ffetarget_gt_character2 (&val,
5482 ffebld_constant_character2 (ffebld_conter (l)),
5483 ffebld_constant_character2 (ffebld_conter (r)));
5484 expr = ffebld_new_conter_with_orig
5485 (ffebld_constant_new_logicaldefault (val), expr);
5486 break;
5487 #endif
5488
5489 #if FFETARGET_okCHARACTER3
5490 case FFEINFO_kindtypeCHARACTER3:
5491 error = ffetarget_gt_character3 (&val,
5492 ffebld_constant_character3 (ffebld_conter (l)),
5493 ffebld_constant_character3 (ffebld_conter (r)));
5494 expr = ffebld_new_conter_with_orig
5495 (ffebld_constant_new_logicaldefault (val), expr);
5496 break;
5497 #endif
5498
5499 #if FFETARGET_okCHARACTER4
5500 case FFEINFO_kindtypeCHARACTER4:
5501 error = ffetarget_gt_character4 (&val,
5502 ffebld_constant_character4 (ffebld_conter (l)),
5503 ffebld_constant_character4 (ffebld_conter (r)));
5504 expr = ffebld_new_conter_with_orig
5505 (ffebld_constant_new_logicaldefault (val), expr);
5506 break;
5507 #endif
5508
5509 default:
5510 assert ("bad character kind type" == NULL);
5511 break;
5512 }
5513 break;
5514
5515 default:
5516 assert ("bad type" == NULL);
5517 return expr;
5518 }
5519
5520 ffebld_set_info (expr, ffeinfo_new
5521 (FFEINFO_basictypeLOGICAL,
5522 FFEINFO_kindtypeLOGICALDEFAULT,
5523 0,
5524 FFEINFO_kindENTITY,
5525 FFEINFO_whereCONSTANT,
5526 FFETARGET_charactersizeNONE));
5527
5528 if ((error != FFEBAD)
5529 && ffebad_start (error))
5530 {
5531 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5532 ffebad_finish ();
5533 }
5534
5535 return expr;
5536 }
5537
5538 /* ffeexpr_collapse_le -- Collapse le expr
5539
5540 ffebld expr;
5541 ffelexToken token;
5542 expr = ffeexpr_collapse_le(expr,token);
5543
5544 If the result of the expr is a constant, replaces the expr with the
5545 computed constant. */
5546
5547 ffebld
ffeexpr_collapse_le(ffebld expr,ffelexToken t)5548 ffeexpr_collapse_le (ffebld expr, ffelexToken t)
5549 {
5550 ffebad error = FFEBAD;
5551 ffebld l;
5552 ffebld r;
5553 bool val;
5554
5555 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5556 return expr;
5557
5558 l = ffebld_left (expr);
5559 r = ffebld_right (expr);
5560
5561 if (ffebld_op (l) != FFEBLD_opCONTER)
5562 return expr;
5563 if (ffebld_op (r) != FFEBLD_opCONTER)
5564 return expr;
5565
5566 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5567 {
5568 case FFEINFO_basictypeANY:
5569 return expr;
5570
5571 case FFEINFO_basictypeINTEGER:
5572 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5573 {
5574 #if FFETARGET_okINTEGER1
5575 case FFEINFO_kindtypeINTEGER1:
5576 error = ffetarget_le_integer1 (&val,
5577 ffebld_constant_integer1 (ffebld_conter (l)),
5578 ffebld_constant_integer1 (ffebld_conter (r)));
5579 expr = ffebld_new_conter_with_orig
5580 (ffebld_constant_new_logicaldefault (val), expr);
5581 break;
5582 #endif
5583
5584 #if FFETARGET_okINTEGER2
5585 case FFEINFO_kindtypeINTEGER2:
5586 error = ffetarget_le_integer2 (&val,
5587 ffebld_constant_integer2 (ffebld_conter (l)),
5588 ffebld_constant_integer2 (ffebld_conter (r)));
5589 expr = ffebld_new_conter_with_orig
5590 (ffebld_constant_new_logicaldefault (val), expr);
5591 break;
5592 #endif
5593
5594 #if FFETARGET_okINTEGER3
5595 case FFEINFO_kindtypeINTEGER3:
5596 error = ffetarget_le_integer3 (&val,
5597 ffebld_constant_integer3 (ffebld_conter (l)),
5598 ffebld_constant_integer3 (ffebld_conter (r)));
5599 expr = ffebld_new_conter_with_orig
5600 (ffebld_constant_new_logicaldefault (val), expr);
5601 break;
5602 #endif
5603
5604 #if FFETARGET_okINTEGER4
5605 case FFEINFO_kindtypeINTEGER4:
5606 error = ffetarget_le_integer4 (&val,
5607 ffebld_constant_integer4 (ffebld_conter (l)),
5608 ffebld_constant_integer4 (ffebld_conter (r)));
5609 expr = ffebld_new_conter_with_orig
5610 (ffebld_constant_new_logicaldefault (val), expr);
5611 break;
5612 #endif
5613
5614 default:
5615 assert ("bad integer kind type" == NULL);
5616 break;
5617 }
5618 break;
5619
5620 case FFEINFO_basictypeREAL:
5621 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5622 {
5623 #if FFETARGET_okREAL1
5624 case FFEINFO_kindtypeREAL1:
5625 error = ffetarget_le_real1 (&val,
5626 ffebld_constant_real1 (ffebld_conter (l)),
5627 ffebld_constant_real1 (ffebld_conter (r)));
5628 expr = ffebld_new_conter_with_orig
5629 (ffebld_constant_new_logicaldefault (val), expr);
5630 break;
5631 #endif
5632
5633 #if FFETARGET_okREAL2
5634 case FFEINFO_kindtypeREAL2:
5635 error = ffetarget_le_real2 (&val,
5636 ffebld_constant_real2 (ffebld_conter (l)),
5637 ffebld_constant_real2 (ffebld_conter (r)));
5638 expr = ffebld_new_conter_with_orig
5639 (ffebld_constant_new_logicaldefault (val), expr);
5640 break;
5641 #endif
5642
5643 #if FFETARGET_okREAL3
5644 case FFEINFO_kindtypeREAL3:
5645 error = ffetarget_le_real3 (&val,
5646 ffebld_constant_real3 (ffebld_conter (l)),
5647 ffebld_constant_real3 (ffebld_conter (r)));
5648 expr = ffebld_new_conter_with_orig
5649 (ffebld_constant_new_logicaldefault (val), expr);
5650 break;
5651 #endif
5652
5653 #if FFETARGET_okREAL4
5654 case FFEINFO_kindtypeREAL4:
5655 error = ffetarget_le_real4 (&val,
5656 ffebld_constant_real4 (ffebld_conter (l)),
5657 ffebld_constant_real4 (ffebld_conter (r)));
5658 expr = ffebld_new_conter_with_orig
5659 (ffebld_constant_new_logicaldefault (val), expr);
5660 break;
5661 #endif
5662
5663 default:
5664 assert ("bad real kind type" == NULL);
5665 break;
5666 }
5667 break;
5668
5669 case FFEINFO_basictypeCHARACTER:
5670 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5671 {
5672 #if FFETARGET_okCHARACTER1
5673 case FFEINFO_kindtypeCHARACTER1:
5674 error = ffetarget_le_character1 (&val,
5675 ffebld_constant_character1 (ffebld_conter (l)),
5676 ffebld_constant_character1 (ffebld_conter (r)));
5677 expr = ffebld_new_conter_with_orig
5678 (ffebld_constant_new_logicaldefault (val), expr);
5679 break;
5680 #endif
5681
5682 #if FFETARGET_okCHARACTER2
5683 case FFEINFO_kindtypeCHARACTER2:
5684 error = ffetarget_le_character2 (&val,
5685 ffebld_constant_character2 (ffebld_conter (l)),
5686 ffebld_constant_character2 (ffebld_conter (r)));
5687 expr = ffebld_new_conter_with_orig
5688 (ffebld_constant_new_logicaldefault (val), expr);
5689 break;
5690 #endif
5691
5692 #if FFETARGET_okCHARACTER3
5693 case FFEINFO_kindtypeCHARACTER3:
5694 error = ffetarget_le_character3 (&val,
5695 ffebld_constant_character3 (ffebld_conter (l)),
5696 ffebld_constant_character3 (ffebld_conter (r)));
5697 expr = ffebld_new_conter_with_orig
5698 (ffebld_constant_new_logicaldefault (val), expr);
5699 break;
5700 #endif
5701
5702 #if FFETARGET_okCHARACTER4
5703 case FFEINFO_kindtypeCHARACTER4:
5704 error = ffetarget_le_character4 (&val,
5705 ffebld_constant_character4 (ffebld_conter (l)),
5706 ffebld_constant_character4 (ffebld_conter (r)));
5707 expr = ffebld_new_conter_with_orig
5708 (ffebld_constant_new_logicaldefault (val), expr);
5709 break;
5710 #endif
5711
5712 default:
5713 assert ("bad character kind type" == NULL);
5714 break;
5715 }
5716 break;
5717
5718 default:
5719 assert ("bad type" == NULL);
5720 return expr;
5721 }
5722
5723 ffebld_set_info (expr, ffeinfo_new
5724 (FFEINFO_basictypeLOGICAL,
5725 FFEINFO_kindtypeLOGICALDEFAULT,
5726 0,
5727 FFEINFO_kindENTITY,
5728 FFEINFO_whereCONSTANT,
5729 FFETARGET_charactersizeNONE));
5730
5731 if ((error != FFEBAD)
5732 && ffebad_start (error))
5733 {
5734 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5735 ffebad_finish ();
5736 }
5737
5738 return expr;
5739 }
5740
5741 /* ffeexpr_collapse_lt -- Collapse lt expr
5742
5743 ffebld expr;
5744 ffelexToken token;
5745 expr = ffeexpr_collapse_lt(expr,token);
5746
5747 If the result of the expr is a constant, replaces the expr with the
5748 computed constant. */
5749
5750 ffebld
ffeexpr_collapse_lt(ffebld expr,ffelexToken t)5751 ffeexpr_collapse_lt (ffebld expr, ffelexToken t)
5752 {
5753 ffebad error = FFEBAD;
5754 ffebld l;
5755 ffebld r;
5756 bool val;
5757
5758 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5759 return expr;
5760
5761 l = ffebld_left (expr);
5762 r = ffebld_right (expr);
5763
5764 if (ffebld_op (l) != FFEBLD_opCONTER)
5765 return expr;
5766 if (ffebld_op (r) != FFEBLD_opCONTER)
5767 return expr;
5768
5769 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5770 {
5771 case FFEINFO_basictypeANY:
5772 return expr;
5773
5774 case FFEINFO_basictypeINTEGER:
5775 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5776 {
5777 #if FFETARGET_okINTEGER1
5778 case FFEINFO_kindtypeINTEGER1:
5779 error = ffetarget_lt_integer1 (&val,
5780 ffebld_constant_integer1 (ffebld_conter (l)),
5781 ffebld_constant_integer1 (ffebld_conter (r)));
5782 expr = ffebld_new_conter_with_orig
5783 (ffebld_constant_new_logicaldefault (val), expr);
5784 break;
5785 #endif
5786
5787 #if FFETARGET_okINTEGER2
5788 case FFEINFO_kindtypeINTEGER2:
5789 error = ffetarget_lt_integer2 (&val,
5790 ffebld_constant_integer2 (ffebld_conter (l)),
5791 ffebld_constant_integer2 (ffebld_conter (r)));
5792 expr = ffebld_new_conter_with_orig
5793 (ffebld_constant_new_logicaldefault (val), expr);
5794 break;
5795 #endif
5796
5797 #if FFETARGET_okINTEGER3
5798 case FFEINFO_kindtypeINTEGER3:
5799 error = ffetarget_lt_integer3 (&val,
5800 ffebld_constant_integer3 (ffebld_conter (l)),
5801 ffebld_constant_integer3 (ffebld_conter (r)));
5802 expr = ffebld_new_conter_with_orig
5803 (ffebld_constant_new_logicaldefault (val), expr);
5804 break;
5805 #endif
5806
5807 #if FFETARGET_okINTEGER4
5808 case FFEINFO_kindtypeINTEGER4:
5809 error = ffetarget_lt_integer4 (&val,
5810 ffebld_constant_integer4 (ffebld_conter (l)),
5811 ffebld_constant_integer4 (ffebld_conter (r)));
5812 expr = ffebld_new_conter_with_orig
5813 (ffebld_constant_new_logicaldefault (val), expr);
5814 break;
5815 #endif
5816
5817 default:
5818 assert ("bad integer kind type" == NULL);
5819 break;
5820 }
5821 break;
5822
5823 case FFEINFO_basictypeREAL:
5824 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5825 {
5826 #if FFETARGET_okREAL1
5827 case FFEINFO_kindtypeREAL1:
5828 error = ffetarget_lt_real1 (&val,
5829 ffebld_constant_real1 (ffebld_conter (l)),
5830 ffebld_constant_real1 (ffebld_conter (r)));
5831 expr = ffebld_new_conter_with_orig
5832 (ffebld_constant_new_logicaldefault (val), expr);
5833 break;
5834 #endif
5835
5836 #if FFETARGET_okREAL2
5837 case FFEINFO_kindtypeREAL2:
5838 error = ffetarget_lt_real2 (&val,
5839 ffebld_constant_real2 (ffebld_conter (l)),
5840 ffebld_constant_real2 (ffebld_conter (r)));
5841 expr = ffebld_new_conter_with_orig
5842 (ffebld_constant_new_logicaldefault (val), expr);
5843 break;
5844 #endif
5845
5846 #if FFETARGET_okREAL3
5847 case FFEINFO_kindtypeREAL3:
5848 error = ffetarget_lt_real3 (&val,
5849 ffebld_constant_real3 (ffebld_conter (l)),
5850 ffebld_constant_real3 (ffebld_conter (r)));
5851 expr = ffebld_new_conter_with_orig
5852 (ffebld_constant_new_logicaldefault (val), expr);
5853 break;
5854 #endif
5855
5856 #if FFETARGET_okREAL4
5857 case FFEINFO_kindtypeREAL4:
5858 error = ffetarget_lt_real4 (&val,
5859 ffebld_constant_real4 (ffebld_conter (l)),
5860 ffebld_constant_real4 (ffebld_conter (r)));
5861 expr = ffebld_new_conter_with_orig
5862 (ffebld_constant_new_logicaldefault (val), expr);
5863 break;
5864 #endif
5865
5866 default:
5867 assert ("bad real kind type" == NULL);
5868 break;
5869 }
5870 break;
5871
5872 case FFEINFO_basictypeCHARACTER:
5873 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5874 {
5875 #if FFETARGET_okCHARACTER1
5876 case FFEINFO_kindtypeCHARACTER1:
5877 error = ffetarget_lt_character1 (&val,
5878 ffebld_constant_character1 (ffebld_conter (l)),
5879 ffebld_constant_character1 (ffebld_conter (r)));
5880 expr = ffebld_new_conter_with_orig
5881 (ffebld_constant_new_logicaldefault (val), expr);
5882 break;
5883 #endif
5884
5885 #if FFETARGET_okCHARACTER2
5886 case FFEINFO_kindtypeCHARACTER2:
5887 error = ffetarget_lt_character2 (&val,
5888 ffebld_constant_character2 (ffebld_conter (l)),
5889 ffebld_constant_character2 (ffebld_conter (r)));
5890 expr = ffebld_new_conter_with_orig
5891 (ffebld_constant_new_logicaldefault (val), expr);
5892 break;
5893 #endif
5894
5895 #if FFETARGET_okCHARACTER3
5896 case FFEINFO_kindtypeCHARACTER3:
5897 error = ffetarget_lt_character3 (&val,
5898 ffebld_constant_character3 (ffebld_conter (l)),
5899 ffebld_constant_character3 (ffebld_conter (r)));
5900 expr = ffebld_new_conter_with_orig
5901 (ffebld_constant_new_logicaldefault (val), expr);
5902 break;
5903 #endif
5904
5905 #if FFETARGET_okCHARACTER4
5906 case FFEINFO_kindtypeCHARACTER4:
5907 error = ffetarget_lt_character4 (&val,
5908 ffebld_constant_character4 (ffebld_conter (l)),
5909 ffebld_constant_character4 (ffebld_conter (r)));
5910 expr = ffebld_new_conter_with_orig
5911 (ffebld_constant_new_logicaldefault (val), expr);
5912 break;
5913 #endif
5914
5915 default:
5916 assert ("bad character kind type" == NULL);
5917 break;
5918 }
5919 break;
5920
5921 default:
5922 assert ("bad type" == NULL);
5923 return expr;
5924 }
5925
5926 ffebld_set_info (expr, ffeinfo_new
5927 (FFEINFO_basictypeLOGICAL,
5928 FFEINFO_kindtypeLOGICALDEFAULT,
5929 0,
5930 FFEINFO_kindENTITY,
5931 FFEINFO_whereCONSTANT,
5932 FFETARGET_charactersizeNONE));
5933
5934 if ((error != FFEBAD)
5935 && ffebad_start (error))
5936 {
5937 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5938 ffebad_finish ();
5939 }
5940
5941 return expr;
5942 }
5943
5944 /* ffeexpr_collapse_and -- Collapse and expr
5945
5946 ffebld expr;
5947 ffelexToken token;
5948 expr = ffeexpr_collapse_and(expr,token);
5949
5950 If the result of the expr is a constant, replaces the expr with the
5951 computed constant. */
5952
5953 ffebld
ffeexpr_collapse_and(ffebld expr,ffelexToken t)5954 ffeexpr_collapse_and (ffebld expr, ffelexToken t)
5955 {
5956 ffebad error = FFEBAD;
5957 ffebld l;
5958 ffebld r;
5959 ffebldConstantUnion u;
5960 ffeinfoBasictype bt;
5961 ffeinfoKindtype kt;
5962
5963 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5964 return expr;
5965
5966 l = ffebld_left (expr);
5967 r = ffebld_right (expr);
5968
5969 if (ffebld_op (l) != FFEBLD_opCONTER)
5970 return expr;
5971 if (ffebld_op (r) != FFEBLD_opCONTER)
5972 return expr;
5973
5974 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5975 {
5976 case FFEINFO_basictypeANY:
5977 return expr;
5978
5979 case FFEINFO_basictypeINTEGER:
5980 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5981 {
5982 #if FFETARGET_okINTEGER1
5983 case FFEINFO_kindtypeINTEGER1:
5984 error = ffetarget_and_integer1 (ffebld_cu_ptr_integer1 (u),
5985 ffebld_constant_integer1 (ffebld_conter (l)),
5986 ffebld_constant_integer1 (ffebld_conter (r)));
5987 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5988 (ffebld_cu_val_integer1 (u)), expr);
5989 break;
5990 #endif
5991
5992 #if FFETARGET_okINTEGER2
5993 case FFEINFO_kindtypeINTEGER2:
5994 error = ffetarget_and_integer2 (ffebld_cu_ptr_integer2 (u),
5995 ffebld_constant_integer2 (ffebld_conter (l)),
5996 ffebld_constant_integer2 (ffebld_conter (r)));
5997 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5998 (ffebld_cu_val_integer2 (u)), expr);
5999 break;
6000 #endif
6001
6002 #if FFETARGET_okINTEGER3
6003 case FFEINFO_kindtypeINTEGER3:
6004 error = ffetarget_and_integer3 (ffebld_cu_ptr_integer3 (u),
6005 ffebld_constant_integer3 (ffebld_conter (l)),
6006 ffebld_constant_integer3 (ffebld_conter (r)));
6007 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6008 (ffebld_cu_val_integer3 (u)), expr);
6009 break;
6010 #endif
6011
6012 #if FFETARGET_okINTEGER4
6013 case FFEINFO_kindtypeINTEGER4:
6014 error = ffetarget_and_integer4 (ffebld_cu_ptr_integer4 (u),
6015 ffebld_constant_integer4 (ffebld_conter (l)),
6016 ffebld_constant_integer4 (ffebld_conter (r)));
6017 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6018 (ffebld_cu_val_integer4 (u)), expr);
6019 break;
6020 #endif
6021
6022 default:
6023 assert ("bad integer kind type" == NULL);
6024 break;
6025 }
6026 break;
6027
6028 case FFEINFO_basictypeLOGICAL:
6029 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6030 {
6031 #if FFETARGET_okLOGICAL1
6032 case FFEINFO_kindtypeLOGICAL1:
6033 error = ffetarget_and_logical1 (ffebld_cu_ptr_logical1 (u),
6034 ffebld_constant_logical1 (ffebld_conter (l)),
6035 ffebld_constant_logical1 (ffebld_conter (r)));
6036 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6037 (ffebld_cu_val_logical1 (u)), expr);
6038 break;
6039 #endif
6040
6041 #if FFETARGET_okLOGICAL2
6042 case FFEINFO_kindtypeLOGICAL2:
6043 error = ffetarget_and_logical2 (ffebld_cu_ptr_logical2 (u),
6044 ffebld_constant_logical2 (ffebld_conter (l)),
6045 ffebld_constant_logical2 (ffebld_conter (r)));
6046 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6047 (ffebld_cu_val_logical2 (u)), expr);
6048 break;
6049 #endif
6050
6051 #if FFETARGET_okLOGICAL3
6052 case FFEINFO_kindtypeLOGICAL3:
6053 error = ffetarget_and_logical3 (ffebld_cu_ptr_logical3 (u),
6054 ffebld_constant_logical3 (ffebld_conter (l)),
6055 ffebld_constant_logical3 (ffebld_conter (r)));
6056 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6057 (ffebld_cu_val_logical3 (u)), expr);
6058 break;
6059 #endif
6060
6061 #if FFETARGET_okLOGICAL4
6062 case FFEINFO_kindtypeLOGICAL4:
6063 error = ffetarget_and_logical4 (ffebld_cu_ptr_logical4 (u),
6064 ffebld_constant_logical4 (ffebld_conter (l)),
6065 ffebld_constant_logical4 (ffebld_conter (r)));
6066 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6067 (ffebld_cu_val_logical4 (u)), expr);
6068 break;
6069 #endif
6070
6071 default:
6072 assert ("bad logical kind type" == NULL);
6073 break;
6074 }
6075 break;
6076
6077 default:
6078 assert ("bad type" == NULL);
6079 return expr;
6080 }
6081
6082 ffebld_set_info (expr, ffeinfo_new
6083 (bt,
6084 kt,
6085 0,
6086 FFEINFO_kindENTITY,
6087 FFEINFO_whereCONSTANT,
6088 FFETARGET_charactersizeNONE));
6089
6090 if ((error != FFEBAD)
6091 && ffebad_start (error))
6092 {
6093 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6094 ffebad_finish ();
6095 }
6096
6097 return expr;
6098 }
6099
6100 /* ffeexpr_collapse_or -- Collapse or expr
6101
6102 ffebld expr;
6103 ffelexToken token;
6104 expr = ffeexpr_collapse_or(expr,token);
6105
6106 If the result of the expr is a constant, replaces the expr with the
6107 computed constant. */
6108
6109 ffebld
ffeexpr_collapse_or(ffebld expr,ffelexToken t)6110 ffeexpr_collapse_or (ffebld expr, ffelexToken t)
6111 {
6112 ffebad error = FFEBAD;
6113 ffebld l;
6114 ffebld r;
6115 ffebldConstantUnion u;
6116 ffeinfoBasictype bt;
6117 ffeinfoKindtype kt;
6118
6119 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6120 return expr;
6121
6122 l = ffebld_left (expr);
6123 r = ffebld_right (expr);
6124
6125 if (ffebld_op (l) != FFEBLD_opCONTER)
6126 return expr;
6127 if (ffebld_op (r) != FFEBLD_opCONTER)
6128 return expr;
6129
6130 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6131 {
6132 case FFEINFO_basictypeANY:
6133 return expr;
6134
6135 case FFEINFO_basictypeINTEGER:
6136 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6137 {
6138 #if FFETARGET_okINTEGER1
6139 case FFEINFO_kindtypeINTEGER1:
6140 error = ffetarget_or_integer1 (ffebld_cu_ptr_integer1 (u),
6141 ffebld_constant_integer1 (ffebld_conter (l)),
6142 ffebld_constant_integer1 (ffebld_conter (r)));
6143 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6144 (ffebld_cu_val_integer1 (u)), expr);
6145 break;
6146 #endif
6147
6148 #if FFETARGET_okINTEGER2
6149 case FFEINFO_kindtypeINTEGER2:
6150 error = ffetarget_or_integer2 (ffebld_cu_ptr_integer2 (u),
6151 ffebld_constant_integer2 (ffebld_conter (l)),
6152 ffebld_constant_integer2 (ffebld_conter (r)));
6153 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6154 (ffebld_cu_val_integer2 (u)), expr);
6155 break;
6156 #endif
6157
6158 #if FFETARGET_okINTEGER3
6159 case FFEINFO_kindtypeINTEGER3:
6160 error = ffetarget_or_integer3 (ffebld_cu_ptr_integer3 (u),
6161 ffebld_constant_integer3 (ffebld_conter (l)),
6162 ffebld_constant_integer3 (ffebld_conter (r)));
6163 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6164 (ffebld_cu_val_integer3 (u)), expr);
6165 break;
6166 #endif
6167
6168 #if FFETARGET_okINTEGER4
6169 case FFEINFO_kindtypeINTEGER4:
6170 error = ffetarget_or_integer4 (ffebld_cu_ptr_integer4 (u),
6171 ffebld_constant_integer4 (ffebld_conter (l)),
6172 ffebld_constant_integer4 (ffebld_conter (r)));
6173 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6174 (ffebld_cu_val_integer4 (u)), expr);
6175 break;
6176 #endif
6177
6178 default:
6179 assert ("bad integer kind type" == NULL);
6180 break;
6181 }
6182 break;
6183
6184 case FFEINFO_basictypeLOGICAL:
6185 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6186 {
6187 #if FFETARGET_okLOGICAL1
6188 case FFEINFO_kindtypeLOGICAL1:
6189 error = ffetarget_or_logical1 (ffebld_cu_ptr_logical1 (u),
6190 ffebld_constant_logical1 (ffebld_conter (l)),
6191 ffebld_constant_logical1 (ffebld_conter (r)));
6192 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6193 (ffebld_cu_val_logical1 (u)), expr);
6194 break;
6195 #endif
6196
6197 #if FFETARGET_okLOGICAL2
6198 case FFEINFO_kindtypeLOGICAL2:
6199 error = ffetarget_or_logical2 (ffebld_cu_ptr_logical2 (u),
6200 ffebld_constant_logical2 (ffebld_conter (l)),
6201 ffebld_constant_logical2 (ffebld_conter (r)));
6202 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6203 (ffebld_cu_val_logical2 (u)), expr);
6204 break;
6205 #endif
6206
6207 #if FFETARGET_okLOGICAL3
6208 case FFEINFO_kindtypeLOGICAL3:
6209 error = ffetarget_or_logical3 (ffebld_cu_ptr_logical3 (u),
6210 ffebld_constant_logical3 (ffebld_conter (l)),
6211 ffebld_constant_logical3 (ffebld_conter (r)));
6212 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6213 (ffebld_cu_val_logical3 (u)), expr);
6214 break;
6215 #endif
6216
6217 #if FFETARGET_okLOGICAL4
6218 case FFEINFO_kindtypeLOGICAL4:
6219 error = ffetarget_or_logical4 (ffebld_cu_ptr_logical4 (u),
6220 ffebld_constant_logical4 (ffebld_conter (l)),
6221 ffebld_constant_logical4 (ffebld_conter (r)));
6222 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6223 (ffebld_cu_val_logical4 (u)), expr);
6224 break;
6225 #endif
6226
6227 default:
6228 assert ("bad logical kind type" == NULL);
6229 break;
6230 }
6231 break;
6232
6233 default:
6234 assert ("bad type" == NULL);
6235 return expr;
6236 }
6237
6238 ffebld_set_info (expr, ffeinfo_new
6239 (bt,
6240 kt,
6241 0,
6242 FFEINFO_kindENTITY,
6243 FFEINFO_whereCONSTANT,
6244 FFETARGET_charactersizeNONE));
6245
6246 if ((error != FFEBAD)
6247 && ffebad_start (error))
6248 {
6249 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6250 ffebad_finish ();
6251 }
6252
6253 return expr;
6254 }
6255
6256 /* ffeexpr_collapse_xor -- Collapse xor expr
6257
6258 ffebld expr;
6259 ffelexToken token;
6260 expr = ffeexpr_collapse_xor(expr,token);
6261
6262 If the result of the expr is a constant, replaces the expr with the
6263 computed constant. */
6264
6265 ffebld
ffeexpr_collapse_xor(ffebld expr,ffelexToken t)6266 ffeexpr_collapse_xor (ffebld expr, ffelexToken t)
6267 {
6268 ffebad error = FFEBAD;
6269 ffebld l;
6270 ffebld r;
6271 ffebldConstantUnion u;
6272 ffeinfoBasictype bt;
6273 ffeinfoKindtype kt;
6274
6275 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6276 return expr;
6277
6278 l = ffebld_left (expr);
6279 r = ffebld_right (expr);
6280
6281 if (ffebld_op (l) != FFEBLD_opCONTER)
6282 return expr;
6283 if (ffebld_op (r) != FFEBLD_opCONTER)
6284 return expr;
6285
6286 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6287 {
6288 case FFEINFO_basictypeANY:
6289 return expr;
6290
6291 case FFEINFO_basictypeINTEGER:
6292 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6293 {
6294 #if FFETARGET_okINTEGER1
6295 case FFEINFO_kindtypeINTEGER1:
6296 error = ffetarget_xor_integer1 (ffebld_cu_ptr_integer1 (u),
6297 ffebld_constant_integer1 (ffebld_conter (l)),
6298 ffebld_constant_integer1 (ffebld_conter (r)));
6299 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6300 (ffebld_cu_val_integer1 (u)), expr);
6301 break;
6302 #endif
6303
6304 #if FFETARGET_okINTEGER2
6305 case FFEINFO_kindtypeINTEGER2:
6306 error = ffetarget_xor_integer2 (ffebld_cu_ptr_integer2 (u),
6307 ffebld_constant_integer2 (ffebld_conter (l)),
6308 ffebld_constant_integer2 (ffebld_conter (r)));
6309 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6310 (ffebld_cu_val_integer2 (u)), expr);
6311 break;
6312 #endif
6313
6314 #if FFETARGET_okINTEGER3
6315 case FFEINFO_kindtypeINTEGER3:
6316 error = ffetarget_xor_integer3 (ffebld_cu_ptr_integer3 (u),
6317 ffebld_constant_integer3 (ffebld_conter (l)),
6318 ffebld_constant_integer3 (ffebld_conter (r)));
6319 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6320 (ffebld_cu_val_integer3 (u)), expr);
6321 break;
6322 #endif
6323
6324 #if FFETARGET_okINTEGER4
6325 case FFEINFO_kindtypeINTEGER4:
6326 error = ffetarget_xor_integer4 (ffebld_cu_ptr_integer4 (u),
6327 ffebld_constant_integer4 (ffebld_conter (l)),
6328 ffebld_constant_integer4 (ffebld_conter (r)));
6329 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6330 (ffebld_cu_val_integer4 (u)), expr);
6331 break;
6332 #endif
6333
6334 default:
6335 assert ("bad integer kind type" == NULL);
6336 break;
6337 }
6338 break;
6339
6340 case FFEINFO_basictypeLOGICAL:
6341 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6342 {
6343 #if FFETARGET_okLOGICAL1
6344 case FFEINFO_kindtypeLOGICAL1:
6345 error = ffetarget_xor_logical1 (ffebld_cu_ptr_logical1 (u),
6346 ffebld_constant_logical1 (ffebld_conter (l)),
6347 ffebld_constant_logical1 (ffebld_conter (r)));
6348 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6349 (ffebld_cu_val_logical1 (u)), expr);
6350 break;
6351 #endif
6352
6353 #if FFETARGET_okLOGICAL2
6354 case FFEINFO_kindtypeLOGICAL2:
6355 error = ffetarget_xor_logical2 (ffebld_cu_ptr_logical2 (u),
6356 ffebld_constant_logical2 (ffebld_conter (l)),
6357 ffebld_constant_logical2 (ffebld_conter (r)));
6358 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6359 (ffebld_cu_val_logical2 (u)), expr);
6360 break;
6361 #endif
6362
6363 #if FFETARGET_okLOGICAL3
6364 case FFEINFO_kindtypeLOGICAL3:
6365 error = ffetarget_xor_logical3 (ffebld_cu_ptr_logical3 (u),
6366 ffebld_constant_logical3 (ffebld_conter (l)),
6367 ffebld_constant_logical3 (ffebld_conter (r)));
6368 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6369 (ffebld_cu_val_logical3 (u)), expr);
6370 break;
6371 #endif
6372
6373 #if FFETARGET_okLOGICAL4
6374 case FFEINFO_kindtypeLOGICAL4:
6375 error = ffetarget_xor_logical4 (ffebld_cu_ptr_logical4 (u),
6376 ffebld_constant_logical4 (ffebld_conter (l)),
6377 ffebld_constant_logical4 (ffebld_conter (r)));
6378 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6379 (ffebld_cu_val_logical4 (u)), expr);
6380 break;
6381 #endif
6382
6383 default:
6384 assert ("bad logical kind type" == NULL);
6385 break;
6386 }
6387 break;
6388
6389 default:
6390 assert ("bad type" == NULL);
6391 return expr;
6392 }
6393
6394 ffebld_set_info (expr, ffeinfo_new
6395 (bt,
6396 kt,
6397 0,
6398 FFEINFO_kindENTITY,
6399 FFEINFO_whereCONSTANT,
6400 FFETARGET_charactersizeNONE));
6401
6402 if ((error != FFEBAD)
6403 && ffebad_start (error))
6404 {
6405 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6406 ffebad_finish ();
6407 }
6408
6409 return expr;
6410 }
6411
6412 /* ffeexpr_collapse_eqv -- Collapse eqv expr
6413
6414 ffebld expr;
6415 ffelexToken token;
6416 expr = ffeexpr_collapse_eqv(expr,token);
6417
6418 If the result of the expr is a constant, replaces the expr with the
6419 computed constant. */
6420
6421 ffebld
ffeexpr_collapse_eqv(ffebld expr,ffelexToken t)6422 ffeexpr_collapse_eqv (ffebld expr, ffelexToken t)
6423 {
6424 ffebad error = FFEBAD;
6425 ffebld l;
6426 ffebld r;
6427 ffebldConstantUnion u;
6428 ffeinfoBasictype bt;
6429 ffeinfoKindtype kt;
6430
6431 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6432 return expr;
6433
6434 l = ffebld_left (expr);
6435 r = ffebld_right (expr);
6436
6437 if (ffebld_op (l) != FFEBLD_opCONTER)
6438 return expr;
6439 if (ffebld_op (r) != FFEBLD_opCONTER)
6440 return expr;
6441
6442 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6443 {
6444 case FFEINFO_basictypeANY:
6445 return expr;
6446
6447 case FFEINFO_basictypeINTEGER:
6448 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6449 {
6450 #if FFETARGET_okINTEGER1
6451 case FFEINFO_kindtypeINTEGER1:
6452 error = ffetarget_eqv_integer1 (ffebld_cu_ptr_integer1 (u),
6453 ffebld_constant_integer1 (ffebld_conter (l)),
6454 ffebld_constant_integer1 (ffebld_conter (r)));
6455 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6456 (ffebld_cu_val_integer1 (u)), expr);
6457 break;
6458 #endif
6459
6460 #if FFETARGET_okINTEGER2
6461 case FFEINFO_kindtypeINTEGER2:
6462 error = ffetarget_eqv_integer2 (ffebld_cu_ptr_integer2 (u),
6463 ffebld_constant_integer2 (ffebld_conter (l)),
6464 ffebld_constant_integer2 (ffebld_conter (r)));
6465 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6466 (ffebld_cu_val_integer2 (u)), expr);
6467 break;
6468 #endif
6469
6470 #if FFETARGET_okINTEGER3
6471 case FFEINFO_kindtypeINTEGER3:
6472 error = ffetarget_eqv_integer3 (ffebld_cu_ptr_integer3 (u),
6473 ffebld_constant_integer3 (ffebld_conter (l)),
6474 ffebld_constant_integer3 (ffebld_conter (r)));
6475 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6476 (ffebld_cu_val_integer3 (u)), expr);
6477 break;
6478 #endif
6479
6480 #if FFETARGET_okINTEGER4
6481 case FFEINFO_kindtypeINTEGER4:
6482 error = ffetarget_eqv_integer4 (ffebld_cu_ptr_integer4 (u),
6483 ffebld_constant_integer4 (ffebld_conter (l)),
6484 ffebld_constant_integer4 (ffebld_conter (r)));
6485 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6486 (ffebld_cu_val_integer4 (u)), expr);
6487 break;
6488 #endif
6489
6490 default:
6491 assert ("bad integer kind type" == NULL);
6492 break;
6493 }
6494 break;
6495
6496 case FFEINFO_basictypeLOGICAL:
6497 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6498 {
6499 #if FFETARGET_okLOGICAL1
6500 case FFEINFO_kindtypeLOGICAL1:
6501 error = ffetarget_eqv_logical1 (ffebld_cu_ptr_logical1 (u),
6502 ffebld_constant_logical1 (ffebld_conter (l)),
6503 ffebld_constant_logical1 (ffebld_conter (r)));
6504 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6505 (ffebld_cu_val_logical1 (u)), expr);
6506 break;
6507 #endif
6508
6509 #if FFETARGET_okLOGICAL2
6510 case FFEINFO_kindtypeLOGICAL2:
6511 error = ffetarget_eqv_logical2 (ffebld_cu_ptr_logical2 (u),
6512 ffebld_constant_logical2 (ffebld_conter (l)),
6513 ffebld_constant_logical2 (ffebld_conter (r)));
6514 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6515 (ffebld_cu_val_logical2 (u)), expr);
6516 break;
6517 #endif
6518
6519 #if FFETARGET_okLOGICAL3
6520 case FFEINFO_kindtypeLOGICAL3:
6521 error = ffetarget_eqv_logical3 (ffebld_cu_ptr_logical3 (u),
6522 ffebld_constant_logical3 (ffebld_conter (l)),
6523 ffebld_constant_logical3 (ffebld_conter (r)));
6524 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6525 (ffebld_cu_val_logical3 (u)), expr);
6526 break;
6527 #endif
6528
6529 #if FFETARGET_okLOGICAL4
6530 case FFEINFO_kindtypeLOGICAL4:
6531 error = ffetarget_eqv_logical4 (ffebld_cu_ptr_logical4 (u),
6532 ffebld_constant_logical4 (ffebld_conter (l)),
6533 ffebld_constant_logical4 (ffebld_conter (r)));
6534 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6535 (ffebld_cu_val_logical4 (u)), expr);
6536 break;
6537 #endif
6538
6539 default:
6540 assert ("bad logical kind type" == NULL);
6541 break;
6542 }
6543 break;
6544
6545 default:
6546 assert ("bad type" == NULL);
6547 return expr;
6548 }
6549
6550 ffebld_set_info (expr, ffeinfo_new
6551 (bt,
6552 kt,
6553 0,
6554 FFEINFO_kindENTITY,
6555 FFEINFO_whereCONSTANT,
6556 FFETARGET_charactersizeNONE));
6557
6558 if ((error != FFEBAD)
6559 && ffebad_start (error))
6560 {
6561 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6562 ffebad_finish ();
6563 }
6564
6565 return expr;
6566 }
6567
6568 /* ffeexpr_collapse_neqv -- Collapse neqv expr
6569
6570 ffebld expr;
6571 ffelexToken token;
6572 expr = ffeexpr_collapse_neqv(expr,token);
6573
6574 If the result of the expr is a constant, replaces the expr with the
6575 computed constant. */
6576
6577 ffebld
ffeexpr_collapse_neqv(ffebld expr,ffelexToken t)6578 ffeexpr_collapse_neqv (ffebld expr, ffelexToken t)
6579 {
6580 ffebad error = FFEBAD;
6581 ffebld l;
6582 ffebld r;
6583 ffebldConstantUnion u;
6584 ffeinfoBasictype bt;
6585 ffeinfoKindtype kt;
6586
6587 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6588 return expr;
6589
6590 l = ffebld_left (expr);
6591 r = ffebld_right (expr);
6592
6593 if (ffebld_op (l) != FFEBLD_opCONTER)
6594 return expr;
6595 if (ffebld_op (r) != FFEBLD_opCONTER)
6596 return expr;
6597
6598 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6599 {
6600 case FFEINFO_basictypeANY:
6601 return expr;
6602
6603 case FFEINFO_basictypeINTEGER:
6604 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6605 {
6606 #if FFETARGET_okINTEGER1
6607 case FFEINFO_kindtypeINTEGER1:
6608 error = ffetarget_neqv_integer1 (ffebld_cu_ptr_integer1 (u),
6609 ffebld_constant_integer1 (ffebld_conter (l)),
6610 ffebld_constant_integer1 (ffebld_conter (r)));
6611 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6612 (ffebld_cu_val_integer1 (u)), expr);
6613 break;
6614 #endif
6615
6616 #if FFETARGET_okINTEGER2
6617 case FFEINFO_kindtypeINTEGER2:
6618 error = ffetarget_neqv_integer2 (ffebld_cu_ptr_integer2 (u),
6619 ffebld_constant_integer2 (ffebld_conter (l)),
6620 ffebld_constant_integer2 (ffebld_conter (r)));
6621 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6622 (ffebld_cu_val_integer2 (u)), expr);
6623 break;
6624 #endif
6625
6626 #if FFETARGET_okINTEGER3
6627 case FFEINFO_kindtypeINTEGER3:
6628 error = ffetarget_neqv_integer3 (ffebld_cu_ptr_integer3 (u),
6629 ffebld_constant_integer3 (ffebld_conter (l)),
6630 ffebld_constant_integer3 (ffebld_conter (r)));
6631 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6632 (ffebld_cu_val_integer3 (u)), expr);
6633 break;
6634 #endif
6635
6636 #if FFETARGET_okINTEGER4
6637 case FFEINFO_kindtypeINTEGER4:
6638 error = ffetarget_neqv_integer4 (ffebld_cu_ptr_integer4 (u),
6639 ffebld_constant_integer4 (ffebld_conter (l)),
6640 ffebld_constant_integer4 (ffebld_conter (r)));
6641 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6642 (ffebld_cu_val_integer4 (u)), expr);
6643 break;
6644 #endif
6645
6646 default:
6647 assert ("bad integer kind type" == NULL);
6648 break;
6649 }
6650 break;
6651
6652 case FFEINFO_basictypeLOGICAL:
6653 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6654 {
6655 #if FFETARGET_okLOGICAL1
6656 case FFEINFO_kindtypeLOGICAL1:
6657 error = ffetarget_neqv_logical1 (ffebld_cu_ptr_logical1 (u),
6658 ffebld_constant_logical1 (ffebld_conter (l)),
6659 ffebld_constant_logical1 (ffebld_conter (r)));
6660 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6661 (ffebld_cu_val_logical1 (u)), expr);
6662 break;
6663 #endif
6664
6665 #if FFETARGET_okLOGICAL2
6666 case FFEINFO_kindtypeLOGICAL2:
6667 error = ffetarget_neqv_logical2 (ffebld_cu_ptr_logical2 (u),
6668 ffebld_constant_logical2 (ffebld_conter (l)),
6669 ffebld_constant_logical2 (ffebld_conter (r)));
6670 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6671 (ffebld_cu_val_logical2 (u)), expr);
6672 break;
6673 #endif
6674
6675 #if FFETARGET_okLOGICAL3
6676 case FFEINFO_kindtypeLOGICAL3:
6677 error = ffetarget_neqv_logical3 (ffebld_cu_ptr_logical3 (u),
6678 ffebld_constant_logical3 (ffebld_conter (l)),
6679 ffebld_constant_logical3 (ffebld_conter (r)));
6680 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6681 (ffebld_cu_val_logical3 (u)), expr);
6682 break;
6683 #endif
6684
6685 #if FFETARGET_okLOGICAL4
6686 case FFEINFO_kindtypeLOGICAL4:
6687 error = ffetarget_neqv_logical4 (ffebld_cu_ptr_logical4 (u),
6688 ffebld_constant_logical4 (ffebld_conter (l)),
6689 ffebld_constant_logical4 (ffebld_conter (r)));
6690 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6691 (ffebld_cu_val_logical4 (u)), expr);
6692 break;
6693 #endif
6694
6695 default:
6696 assert ("bad logical kind type" == NULL);
6697 break;
6698 }
6699 break;
6700
6701 default:
6702 assert ("bad type" == NULL);
6703 return expr;
6704 }
6705
6706 ffebld_set_info (expr, ffeinfo_new
6707 (bt,
6708 kt,
6709 0,
6710 FFEINFO_kindENTITY,
6711 FFEINFO_whereCONSTANT,
6712 FFETARGET_charactersizeNONE));
6713
6714 if ((error != FFEBAD)
6715 && ffebad_start (error))
6716 {
6717 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6718 ffebad_finish ();
6719 }
6720
6721 return expr;
6722 }
6723
6724 /* ffeexpr_collapse_symter -- Collapse symter expr
6725
6726 ffebld expr;
6727 ffelexToken token;
6728 expr = ffeexpr_collapse_symter(expr,token);
6729
6730 If the result of the expr is a constant, replaces the expr with the
6731 computed constant. */
6732
6733 ffebld
ffeexpr_collapse_symter(ffebld expr,ffelexToken t UNUSED)6734 ffeexpr_collapse_symter (ffebld expr, ffelexToken t UNUSED)
6735 {
6736 ffebld r;
6737 ffeinfoBasictype bt;
6738 ffeinfoKindtype kt;
6739 ffetargetCharacterSize len;
6740
6741 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6742 return expr;
6743
6744 if ((r = ffesymbol_init (ffebld_symter (expr))) == NULL)
6745 return expr; /* A PARAMETER lhs in progress. */
6746
6747 switch (ffebld_op (r))
6748 {
6749 case FFEBLD_opCONTER:
6750 break;
6751
6752 case FFEBLD_opANY:
6753 return r;
6754
6755 default:
6756 return expr;
6757 }
6758
6759 bt = ffeinfo_basictype (ffebld_info (r));
6760 kt = ffeinfo_kindtype (ffebld_info (r));
6761 len = ffebld_size (r);
6762
6763 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
6764 expr);
6765
6766 ffebld_set_info (expr, ffeinfo_new
6767 (bt,
6768 kt,
6769 0,
6770 FFEINFO_kindENTITY,
6771 FFEINFO_whereCONSTANT,
6772 len));
6773
6774 return expr;
6775 }
6776
6777 /* ffeexpr_collapse_funcref -- Collapse funcref expr
6778
6779 ffebld expr;
6780 ffelexToken token;
6781 expr = ffeexpr_collapse_funcref(expr,token);
6782
6783 If the result of the expr is a constant, replaces the expr with the
6784 computed constant. */
6785
6786 ffebld
ffeexpr_collapse_funcref(ffebld expr,ffelexToken t UNUSED)6787 ffeexpr_collapse_funcref (ffebld expr, ffelexToken t UNUSED)
6788 {
6789 return expr; /* ~~someday go ahead and collapse these,
6790 though not required */
6791 }
6792
6793 /* ffeexpr_collapse_arrayref -- Collapse arrayref expr
6794
6795 ffebld expr;
6796 ffelexToken token;
6797 expr = ffeexpr_collapse_arrayref(expr,token);
6798
6799 If the result of the expr is a constant, replaces the expr with the
6800 computed constant. */
6801
6802 ffebld
ffeexpr_collapse_arrayref(ffebld expr,ffelexToken t UNUSED)6803 ffeexpr_collapse_arrayref (ffebld expr, ffelexToken t UNUSED)
6804 {
6805 return expr;
6806 }
6807
6808 /* ffeexpr_collapse_substr -- Collapse substr expr
6809
6810 ffebld expr;
6811 ffelexToken token;
6812 expr = ffeexpr_collapse_substr(expr,token);
6813
6814 If the result of the expr is a constant, replaces the expr with the
6815 computed constant. */
6816
6817 ffebld
ffeexpr_collapse_substr(ffebld expr,ffelexToken t)6818 ffeexpr_collapse_substr (ffebld expr, ffelexToken t)
6819 {
6820 ffebad error = FFEBAD;
6821 ffebld l;
6822 ffebld r;
6823 ffebld start;
6824 ffebld stop;
6825 ffebldConstantUnion u;
6826 ffeinfoKindtype kt;
6827 ffetargetCharacterSize len;
6828 ffetargetIntegerDefault first;
6829 ffetargetIntegerDefault last;
6830
6831 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6832 return expr;
6833
6834 l = ffebld_left (expr);
6835 r = ffebld_right (expr); /* opITEM. */
6836
6837 if (ffebld_op (l) != FFEBLD_opCONTER)
6838 return expr;
6839
6840 kt = ffeinfo_kindtype (ffebld_info (l));
6841 len = ffebld_size (l);
6842
6843 start = ffebld_head (r);
6844 stop = ffebld_head (ffebld_trail (r));
6845 if (start == NULL)
6846 first = 1;
6847 else
6848 {
6849 if ((ffebld_op (start) != FFEBLD_opCONTER)
6850 || (ffeinfo_basictype (ffebld_info (start)) != FFEINFO_basictypeINTEGER)
6851 || (ffeinfo_kindtype (ffebld_info (start))
6852 != FFEINFO_kindtypeINTEGERDEFAULT))
6853 return expr;
6854 first = ffebld_constant_integerdefault (ffebld_conter (start));
6855 }
6856 if (stop == NULL)
6857 last = len;
6858 else
6859 {
6860 if ((ffebld_op (stop) != FFEBLD_opCONTER)
6861 || (ffeinfo_basictype (ffebld_info (stop)) != FFEINFO_basictypeINTEGER)
6862 || (ffeinfo_kindtype (ffebld_info (stop))
6863 != FFEINFO_kindtypeINTEGERDEFAULT))
6864 return expr;
6865 last = ffebld_constant_integerdefault (ffebld_conter (stop));
6866 }
6867
6868 /* Handle problems that should have already been diagnosed, but
6869 left in the expression tree. */
6870
6871 if (first <= 0)
6872 first = 1;
6873 if (last < first)
6874 last = first + len - 1;
6875
6876 if ((first == 1) && (last == len))
6877 { /* Same as original. */
6878 expr = ffebld_new_conter_with_orig (ffebld_constant_copy
6879 (ffebld_conter (l)), expr);
6880 ffebld_set_info (expr, ffeinfo_new
6881 (FFEINFO_basictypeCHARACTER,
6882 kt,
6883 0,
6884 FFEINFO_kindENTITY,
6885 FFEINFO_whereCONSTANT,
6886 len));
6887
6888 return expr;
6889 }
6890
6891 switch (ffeinfo_basictype (ffebld_info (expr)))
6892 {
6893 case FFEINFO_basictypeANY:
6894 return expr;
6895
6896 case FFEINFO_basictypeCHARACTER:
6897 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6898 {
6899 #if FFETARGET_okCHARACTER1
6900 case FFEINFO_kindtypeCHARACTER1:
6901 error = ffetarget_substr_character1 (ffebld_cu_ptr_character1 (u),
6902 ffebld_constant_character1 (ffebld_conter (l)), first, last,
6903 ffebld_constant_pool (), &len);
6904 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
6905 (ffebld_cu_val_character1 (u)), expr);
6906 break;
6907 #endif
6908
6909 #if FFETARGET_okCHARACTER2
6910 case FFEINFO_kindtypeCHARACTER2:
6911 error = ffetarget_substr_character2 (ffebld_cu_ptr_character2 (u),
6912 ffebld_constant_character2 (ffebld_conter (l)), first, last,
6913 ffebld_constant_pool (), &len);
6914 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val
6915 (ffebld_cu_val_character2 (u)), expr);
6916 break;
6917 #endif
6918
6919 #if FFETARGET_okCHARACTER3
6920 case FFEINFO_kindtypeCHARACTER3:
6921 error = ffetarget_substr_character3 (ffebld_cu_ptr_character3 (u),
6922 ffebld_constant_character3 (ffebld_conter (l)), first, last,
6923 ffebld_constant_pool (), &len);
6924 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val
6925 (ffebld_cu_val_character3 (u)), expr);
6926 break;
6927 #endif
6928
6929 #if FFETARGET_okCHARACTER4
6930 case FFEINFO_kindtypeCHARACTER4:
6931 error = ffetarget_substr_character4 (ffebld_cu_ptr_character4 (u),
6932 ffebld_constant_character4 (ffebld_conter (l)), first, last,
6933 ffebld_constant_pool (), &len);
6934 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val
6935 (ffebld_cu_val_character4 (u)), expr);
6936 break;
6937 #endif
6938
6939 default:
6940 assert ("bad character kind type" == NULL);
6941 break;
6942 }
6943 break;
6944
6945 default:
6946 assert ("bad type" == NULL);
6947 return expr;
6948 }
6949
6950 ffebld_set_info (expr, ffeinfo_new
6951 (FFEINFO_basictypeCHARACTER,
6952 kt,
6953 0,
6954 FFEINFO_kindENTITY,
6955 FFEINFO_whereCONSTANT,
6956 len));
6957
6958 if ((error != FFEBAD)
6959 && ffebad_start (error))
6960 {
6961 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6962 ffebad_finish ();
6963 }
6964
6965 return expr;
6966 }
6967
6968 /* ffeexpr_convert -- Convert source expression to given type
6969
6970 ffebld source;
6971 ffelexToken source_token;
6972 ffelexToken dest_token; // Any appropriate token for "destination".
6973 ffeinfoBasictype bt;
6974 ffeinfoKindtype kt;
6975 ffetargetCharactersize sz;
6976 ffeexprContext context; // Mainly LET or DATA.
6977 source = ffeexpr_convert(source,source_token,dest_token,bt,kt,sz,context);
6978
6979 If the expression conforms, returns the source expression. Otherwise
6980 returns source wrapped in a convert node doing the conversion, or
6981 ANY wrapped in convert if there is a conversion error (and issues an
6982 error message). Be sensitive to the context for certain aspects of
6983 the conversion. */
6984
6985 ffebld
ffeexpr_convert(ffebld source,ffelexToken source_token,ffelexToken dest_token,ffeinfoBasictype bt,ffeinfoKindtype kt,ffeinfoRank rk,ffetargetCharacterSize sz,ffeexprContext context)6986 ffeexpr_convert (ffebld source, ffelexToken source_token, ffelexToken dest_token,
6987 ffeinfoBasictype bt, ffeinfoKindtype kt, ffeinfoRank rk,
6988 ffetargetCharacterSize sz, ffeexprContext context)
6989 {
6990 bool bad;
6991 ffeinfo info;
6992 ffeinfoWhere wh;
6993
6994 info = ffebld_info (source);
6995 if ((bt != ffeinfo_basictype (info))
6996 || (kt != ffeinfo_kindtype (info))
6997 || (rk != 0) /* Can't convert from or to arrays yet. */
6998 || (ffeinfo_rank (info) != 0)
6999 || (sz != ffebld_size_known (source)))
7000 #if 0 /* Nobody seems to need this spurious CONVERT node. */
7001 || ((context != FFEEXPR_contextLET)
7002 && (bt == FFEINFO_basictypeCHARACTER)
7003 && (sz == FFETARGET_charactersizeNONE)))
7004 #endif
7005 {
7006 switch (ffeinfo_basictype (info))
7007 {
7008 case FFEINFO_basictypeLOGICAL:
7009 switch (bt)
7010 {
7011 case FFEINFO_basictypeLOGICAL:
7012 bad = FALSE;
7013 break;
7014
7015 case FFEINFO_basictypeINTEGER:
7016 bad = !ffe_is_ugly_logint ();
7017 break;
7018
7019 case FFEINFO_basictypeCHARACTER:
7020 bad = ffe_is_pedantic ()
7021 || !(ffe_is_ugly_init ()
7022 && (context == FFEEXPR_contextDATA));
7023 break;
7024
7025 default:
7026 bad = TRUE;
7027 break;
7028 }
7029 break;
7030
7031 case FFEINFO_basictypeINTEGER:
7032 switch (bt)
7033 {
7034 case FFEINFO_basictypeINTEGER:
7035 case FFEINFO_basictypeREAL:
7036 case FFEINFO_basictypeCOMPLEX:
7037 bad = FALSE;
7038 break;
7039
7040 case FFEINFO_basictypeLOGICAL:
7041 bad = !ffe_is_ugly_logint ();
7042 break;
7043
7044 case FFEINFO_basictypeCHARACTER:
7045 bad = ffe_is_pedantic ()
7046 || !(ffe_is_ugly_init ()
7047 && (context == FFEEXPR_contextDATA));
7048 break;
7049
7050 default:
7051 bad = TRUE;
7052 break;
7053 }
7054 break;
7055
7056 case FFEINFO_basictypeREAL:
7057 case FFEINFO_basictypeCOMPLEX:
7058 switch (bt)
7059 {
7060 case FFEINFO_basictypeINTEGER:
7061 case FFEINFO_basictypeREAL:
7062 case FFEINFO_basictypeCOMPLEX:
7063 bad = FALSE;
7064 break;
7065
7066 case FFEINFO_basictypeCHARACTER:
7067 bad = TRUE;
7068 break;
7069
7070 default:
7071 bad = TRUE;
7072 break;
7073 }
7074 break;
7075
7076 case FFEINFO_basictypeCHARACTER:
7077 bad = (bt != FFEINFO_basictypeCHARACTER)
7078 && (ffe_is_pedantic ()
7079 || (bt != FFEINFO_basictypeINTEGER)
7080 || !(ffe_is_ugly_init ()
7081 && (context == FFEEXPR_contextDATA)));
7082 break;
7083
7084 case FFEINFO_basictypeTYPELESS:
7085 case FFEINFO_basictypeHOLLERITH:
7086 bad = ffe_is_pedantic ()
7087 || !(ffe_is_ugly_init ()
7088 && ((context == FFEEXPR_contextDATA)
7089 || (context == FFEEXPR_contextLET)));
7090 break;
7091
7092 default:
7093 bad = TRUE;
7094 break;
7095 }
7096
7097 if (!bad && ((rk != 0) || (ffeinfo_rank (info) != 0)))
7098 bad = TRUE;
7099
7100 if (bad && (bt != FFEINFO_basictypeANY) && (kt != FFEINFO_kindtypeANY)
7101 && (ffeinfo_basictype (info) != FFEINFO_basictypeANY)
7102 && (ffeinfo_kindtype (info) != FFEINFO_kindtypeANY)
7103 && (ffeinfo_where (info) != FFEINFO_whereANY))
7104 {
7105 if (ffebad_start (FFEBAD_BAD_TYPES))
7106 {
7107 if (dest_token == NULL)
7108 ffebad_here (0, ffewhere_line_unknown (),
7109 ffewhere_column_unknown ());
7110 else
7111 ffebad_here (0, ffelex_token_where_line (dest_token),
7112 ffelex_token_where_column (dest_token));
7113 assert (source_token != NULL);
7114 ffebad_here (1, ffelex_token_where_line (source_token),
7115 ffelex_token_where_column (source_token));
7116 ffebad_finish ();
7117 }
7118
7119 source = ffebld_new_any ();
7120 ffebld_set_info (source, ffeinfo_new_any ());
7121 }
7122 else
7123 {
7124 switch (ffeinfo_where (info))
7125 {
7126 case FFEINFO_whereCONSTANT:
7127 wh = FFEINFO_whereCONSTANT;
7128 break;
7129
7130 case FFEINFO_whereIMMEDIATE:
7131 wh = FFEINFO_whereIMMEDIATE;
7132 break;
7133
7134 default:
7135 wh = FFEINFO_whereFLEETING;
7136 break;
7137 }
7138 source = ffebld_new_convert (source);
7139 ffebld_set_info (source, ffeinfo_new
7140 (bt,
7141 kt,
7142 0,
7143 FFEINFO_kindENTITY,
7144 wh,
7145 sz));
7146 source = ffeexpr_collapse_convert (source, source_token);
7147 }
7148 }
7149
7150 return source;
7151 }
7152
7153 /* ffeexpr_convert_expr -- Convert source expr to conform to dest expr
7154
7155 ffebld source;
7156 ffebld dest;
7157 ffelexToken source_token;
7158 ffelexToken dest_token;
7159 ffeexprContext context;
7160 source = ffeexpr_convert_expr(source,source_token,dest,dest_token,context);
7161
7162 If the expressions conform, returns the source expression. Otherwise
7163 returns source wrapped in a convert node doing the conversion, or
7164 ANY wrapped in convert if there is a conversion error (and issues an
7165 error message). Be sensitive to the context, such as LET or DATA. */
7166
7167 ffebld
ffeexpr_convert_expr(ffebld source,ffelexToken source_token,ffebld dest,ffelexToken dest_token,ffeexprContext context)7168 ffeexpr_convert_expr (ffebld source, ffelexToken source_token, ffebld dest,
7169 ffelexToken dest_token, ffeexprContext context)
7170 {
7171 ffeinfo info;
7172
7173 info = ffebld_info (dest);
7174 return ffeexpr_convert (source, source_token, dest_token,
7175 ffeinfo_basictype (info),
7176 ffeinfo_kindtype (info),
7177 ffeinfo_rank (info),
7178 ffebld_size_known (dest),
7179 context);
7180 }
7181
7182 /* ffeexpr_convert_to_sym -- Convert source expression to conform to symbol
7183
7184 ffebld source;
7185 ffesymbol dest;
7186 ffelexToken source_token;
7187 ffelexToken dest_token;
7188 source = ffeexpr_convert_to_sym(source,source_token,dest,dest_token);
7189
7190 If the expressions conform, returns the source expression. Otherwise
7191 returns source wrapped in a convert node doing the conversion, or
7192 ANY wrapped in convert if there is a conversion error (and issues an
7193 error message). */
7194
7195 ffebld
ffeexpr_convert_to_sym(ffebld source,ffelexToken source_token,ffesymbol dest,ffelexToken dest_token)7196 ffeexpr_convert_to_sym (ffebld source, ffelexToken source_token,
7197 ffesymbol dest, ffelexToken dest_token)
7198 {
7199 return ffeexpr_convert (source, source_token, dest_token, ffesymbol_basictype (dest),
7200 ffesymbol_kindtype (dest), ffesymbol_rank (dest), ffesymbol_size (dest),
7201 FFEEXPR_contextLET);
7202 }
7203
7204 /* Initializes the module. */
7205
7206 void
ffeexpr_init_2()7207 ffeexpr_init_2 ()
7208 {
7209 ffeexpr_stack_ = NULL;
7210 ffeexpr_level_ = 0;
7211 }
7212
7213 /* ffeexpr_lhs -- Begin processing left-hand-side-context expression
7214
7215 Prepares cluster for delivery of lexer tokens representing an expression
7216 in a left-hand-side context (A in A=B, for example). ffebld is used
7217 to build expressions in the given pool. The appropriate lexer-token
7218 handling routine within ffeexpr is returned. When the end of the
7219 expression is detected, mycallbackroutine is called with the resulting
7220 single ffebld object specifying the entire expression and the first
7221 lexer token that is not considered part of the expression. This caller-
7222 supplied routine itself returns a lexer-token handling routine. Thus,
7223 if necessary, ffeexpr can return several tokens as end-of-expression
7224 tokens if it needs to scan forward more than one in any instance. */
7225
7226 ffelexHandler
ffeexpr_lhs(mallocPool pool,ffeexprContext context,ffeexprCallback callback)7227 ffeexpr_lhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
7228 {
7229 ffeexprStack_ s;
7230
7231 ffebld_pool_push (pool);
7232 s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
7233 s->previous = ffeexpr_stack_;
7234 s->pool = pool;
7235 s->context = context;
7236 s->callback = callback;
7237 s->first_token = NULL;
7238 s->exprstack = NULL;
7239 s->is_rhs = FALSE;
7240 ffeexpr_stack_ = s;
7241 return (ffelexHandler) ffeexpr_token_first_lhs_;
7242 }
7243
7244 /* ffeexpr_rhs -- Begin processing right-hand-side-context expression
7245
7246 return ffeexpr_rhs(malloc_pool_image(),mycallbackroutine); // to lexer.
7247
7248 Prepares cluster for delivery of lexer tokens representing an expression
7249 in a right-hand-side context (B in A=B, for example). ffebld is used
7250 to build expressions in the given pool. The appropriate lexer-token
7251 handling routine within ffeexpr is returned. When the end of the
7252 expression is detected, mycallbackroutine is called with the resulting
7253 single ffebld object specifying the entire expression and the first
7254 lexer token that is not considered part of the expression. This caller-
7255 supplied routine itself returns a lexer-token handling routine. Thus,
7256 if necessary, ffeexpr can return several tokens as end-of-expression
7257 tokens if it needs to scan forward more than one in any instance. */
7258
7259 ffelexHandler
ffeexpr_rhs(mallocPool pool,ffeexprContext context,ffeexprCallback callback)7260 ffeexpr_rhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
7261 {
7262 ffeexprStack_ s;
7263
7264 ffebld_pool_push (pool);
7265 s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
7266 s->previous = ffeexpr_stack_;
7267 s->pool = pool;
7268 s->context = context;
7269 s->callback = callback;
7270 s->first_token = NULL;
7271 s->exprstack = NULL;
7272 s->is_rhs = TRUE;
7273 ffeexpr_stack_ = s;
7274 return (ffelexHandler) ffeexpr_token_first_rhs_;
7275 }
7276
7277 /* ffeexpr_cb_close_paren_ -- OPEN_PAREN expr
7278
7279 Pass it to ffeexpr_rhs as the callback routine.
7280
7281 Makes sure the end token is close-paren and swallows it, else issues
7282 an error message and doesn't swallow the token (passing it along instead).
7283 In either case wraps up subexpression construction by enclosing the
7284 ffebld expression in a paren. */
7285
7286 static ffelexHandler
ffeexpr_cb_close_paren_(ffelexToken ft,ffebld expr,ffelexToken t)7287 ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr, ffelexToken t)
7288 {
7289 ffeexprExpr_ e;
7290
7291 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7292 {
7293 /* Oops, naughty user didn't specify the close paren! */
7294
7295 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7296 {
7297 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7298 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7299 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7300 ffebad_finish ();
7301 }
7302
7303 e = ffeexpr_expr_new_ ();
7304 e->type = FFEEXPR_exprtypeOPERAND_;
7305 e->u.operand = ffebld_new_any ();
7306 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
7307 ffeexpr_exprstack_push_operand_ (e);
7308
7309 return
7310 (ffelexHandler) ffeexpr_find_close_paren_ (t,
7311 (ffelexHandler)
7312 ffeexpr_token_binary_);
7313 }
7314
7315 if (expr->op == FFEBLD_opIMPDO)
7316 {
7317 if (ffest_ffebad_start (FFEBAD_IMPDO_PAREN))
7318 {
7319 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7320 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7321 ffebad_finish ();
7322 }
7323 }
7324 else
7325 {
7326 expr = ffebld_new_paren (expr);
7327 ffebld_set_info (expr, ffeinfo_use (ffebld_info (ffebld_left (expr))));
7328 }
7329
7330 /* Now push the (parenthesized) expression as an operand onto the
7331 expression stack. */
7332
7333 e = ffeexpr_expr_new_ ();
7334 e->type = FFEEXPR_exprtypeOPERAND_;
7335 e->u.operand = expr;
7336 e->u.operand = ffeexpr_collapse_paren (e->u.operand, ft);
7337 e->token = ffeexpr_stack_->tokens[0];
7338 ffeexpr_exprstack_push_operand_ (e);
7339
7340 return (ffelexHandler) ffeexpr_token_binary_;
7341 }
7342
7343 /* ffeexpr_cb_close_paren_ambig_ -- OPEN_PAREN expr
7344
7345 Pass it to ffeexpr_rhs as the callback routine.
7346
7347 We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
7348 with the next token in t. If the next token is possibly a binary
7349 operator, continue processing the outer expression. If the next
7350 token is COMMA, then the expression is a unit specifier, and
7351 parentheses should not be added to it because it surrounds the
7352 I/O control list that starts with the unit specifier (and continues
7353 on from here -- we haven't seen the CLOSE_PAREN that matches the
7354 OPEN_PAREN, it is up to the callback function to expect to see it
7355 at some point). In this case, we notify the callback function that
7356 the COMMA is inside, not outside, the parens by wrapping the expression
7357 in an opITEM (with a NULL trail) -- the callback function presumably
7358 unwraps it after seeing this kludgey indicator.
7359
7360 If the next token is CLOSE_PAREN, then we go to the _1_ state to
7361 decide what to do with the token after that.
7362
7363 15-Feb-91 JCB 1.1
7364 Use an extra state for the CLOSE_PAREN case to make READ &co really
7365 work right. */
7366
7367 static ffelexHandler
ffeexpr_cb_close_paren_ambig_(ffelexToken ft,ffebld expr,ffelexToken t)7368 ffeexpr_cb_close_paren_ambig_ (ffelexToken ft, ffebld expr, ffelexToken t)
7369 {
7370 ffeexprCallback callback;
7371 ffeexprStack_ s;
7372
7373 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7374 { /* Need to see the next token before we
7375 decide anything. */
7376 ffeexpr_stack_->expr = expr;
7377 ffeexpr_tokens_[0] = ffelex_token_use (ft);
7378 ffeexpr_tokens_[1] = ffelex_token_use (t);
7379 return (ffelexHandler) ffeexpr_cb_close_paren_ambig_1_;
7380 }
7381
7382 expr = ffeexpr_finished_ambig_ (ft, expr);
7383
7384 /* Let the callback function handle the case where t isn't COMMA. */
7385
7386 /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
7387 that preceded the expression starts a list of expressions, and the expr
7388 hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
7389 node. The callback function should extract the real expr from the head
7390 of this opITEM node after testing it. */
7391
7392 expr = ffebld_new_item (expr, NULL);
7393
7394 ffebld_pool_pop ();
7395 callback = ffeexpr_stack_->callback;
7396 ffelex_token_kill (ffeexpr_stack_->first_token);
7397 s = ffeexpr_stack_->previous;
7398 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
7399 ffeexpr_stack_ = s;
7400 return (ffelexHandler) (*callback) (ft, expr, t);
7401 }
7402
7403 /* ffeexpr_cb_close_paren_ambig_1_ -- OPEN_PAREN expr CLOSE_PAREN
7404
7405 See ffeexpr_cb_close_paren_ambig_.
7406
7407 We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
7408 with the next token in t. If the next token is possibly a binary
7409 operator, continue processing the outer expression. If the next
7410 token is COMMA, the expression is a parenthesized format specifier.
7411 If the next token is not EOS or SEMICOLON, then because it is not a
7412 binary operator (it is NAME, OPEN_PAREN, &c), the expression is
7413 a unit specifier, and parentheses should not be added to it because
7414 they surround the I/O control list that consists of only the unit
7415 specifier. If the next token is EOS or SEMICOLON, the statement
7416 must be disambiguated by looking at the type of the expression -- a
7417 character expression is a parenthesized format specifier, while a
7418 non-character expression is a unit specifier.
7419
7420 Another issue is how to do the callback so the recipient of the
7421 next token knows how to handle it if it is a COMMA. In all other
7422 cases, disambiguation is straightforward: the same approach as the
7423 above is used.
7424
7425 EXTENSION: in COMMA case, if not pedantic, use same disambiguation
7426 as for EOS/SEMICOLON case; f2c allows "READ (cilist) [[,]iolist]"
7427 and apparently other compilers do, as well, and some code out there
7428 uses this "feature".
7429
7430 19-Feb-91 JCB 1.1
7431 Extend to allow COMMA as nondisambiguating by itself. Remember
7432 to not try and check info field for opSTAR, since that expr doesn't
7433 have a valid info field. */
7434
7435 static ffelexHandler
ffeexpr_cb_close_paren_ambig_1_(ffelexToken t)7436 ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t)
7437 {
7438 ffeexprCallback callback;
7439 ffeexprStack_ s;
7440 ffelexHandler next;
7441 ffelexToken orig_ft = ffeexpr_tokens_[0]; /* In case callback clobbers
7442 these. */
7443 ffelexToken orig_t = ffeexpr_tokens_[1];
7444 ffebld expr = ffeexpr_stack_->expr;
7445
7446 switch (ffelex_token_type (t))
7447 {
7448 case FFELEX_typeCOMMA: /* Subexpr is parenthesized format specifier. */
7449 if (ffe_is_pedantic ())
7450 goto pedantic_comma; /* :::::::::::::::::::: */
7451 /* Fall through. */
7452 case FFELEX_typeEOS: /* Ambiguous; use type of expr to
7453 disambiguate. */
7454 case FFELEX_typeSEMICOLON:
7455 if ((expr == NULL) || (ffebld_op (expr) == FFEBLD_opANY)
7456 || (ffebld_op (expr) == FFEBLD_opSTAR)
7457 || (ffeinfo_basictype (ffebld_info (expr))
7458 != FFEINFO_basictypeCHARACTER))
7459 break; /* Not a valid CHARACTER entity, can't be a
7460 format spec. */
7461 /* Fall through. */
7462 default: /* Binary op (we assume; error otherwise);
7463 format specifier. */
7464
7465 pedantic_comma: /* :::::::::::::::::::: */
7466
7467 switch (ffeexpr_stack_->context)
7468 {
7469 case FFEEXPR_contextFILENUMAMBIG:
7470 ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
7471 break;
7472
7473 case FFEEXPR_contextFILEUNITAMBIG:
7474 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
7475 break;
7476
7477 default:
7478 assert ("bad context" == NULL);
7479 break;
7480 }
7481
7482 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
7483 next = (ffelexHandler) ffeexpr_cb_close_paren_ (orig_ft, expr, orig_t);
7484 ffelex_token_kill (orig_ft);
7485 ffelex_token_kill (orig_t);
7486 return (ffelexHandler) (*next) (t);
7487
7488 case FFELEX_typeOPEN_PAREN:/* Non-binary op; beginning of I/O list. */
7489 case FFELEX_typeNAME:
7490 break;
7491 }
7492
7493 expr = ffeexpr_finished_ambig_ (orig_ft, expr);
7494
7495 /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
7496 that preceded the expression starts a list of expressions, and the expr
7497 hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
7498 node. The callback function should extract the real expr from the head
7499 of this opITEM node after testing it. */
7500
7501 expr = ffebld_new_item (expr, NULL);
7502
7503 ffebld_pool_pop ();
7504 callback = ffeexpr_stack_->callback;
7505 ffelex_token_kill (ffeexpr_stack_->first_token);
7506 s = ffeexpr_stack_->previous;
7507 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
7508 ffeexpr_stack_ = s;
7509 next = (ffelexHandler) (*callback) (orig_ft, expr, orig_t);
7510 ffelex_token_kill (orig_ft);
7511 ffelex_token_kill (orig_t);
7512 return (ffelexHandler) (*next) (t);
7513 }
7514
7515 /* ffeexpr_cb_close_paren_c_ -- OPEN_PAREN expr (possible complex)
7516
7517 Pass it to ffeexpr_rhs as the callback routine.
7518
7519 Makes sure the end token is close-paren and swallows it, or a comma
7520 and handles complex/implied-do possibilities, else issues
7521 an error message and doesn't swallow the token (passing it along instead). */
7522
7523 static ffelexHandler
ffeexpr_cb_close_paren_c_(ffelexToken ft,ffebld expr,ffelexToken t)7524 ffeexpr_cb_close_paren_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
7525 {
7526 /* First check to see if this is a possible complex entity. It is if the
7527 token is a comma. */
7528
7529 if (ffelex_token_type (t) == FFELEX_typeCOMMA)
7530 {
7531 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
7532 ffeexpr_stack_->expr = expr;
7533 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7534 FFEEXPR_contextPAREN_, ffeexpr_cb_comma_c_);
7535 }
7536
7537 return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
7538 }
7539
7540 /* ffeexpr_cb_comma_c_ -- OPEN_PAREN expr COMMA expr
7541
7542 Pass it to ffeexpr_rhs as the callback routine.
7543
7544 If this token is not a comma, we have a complex constant (or an attempt
7545 at one), so handle it accordingly, displaying error messages if the token
7546 is not a close-paren. */
7547
7548 static ffelexHandler
ffeexpr_cb_comma_c_(ffelexToken ft,ffebld expr,ffelexToken t)7549 ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
7550 {
7551 ffeexprExpr_ e;
7552 ffeinfoBasictype lty = (ffeexpr_stack_->expr == NULL)
7553 ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (ffeexpr_stack_->expr));
7554 ffeinfoBasictype rty = (expr == NULL)
7555 ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (expr));
7556 ffeinfoKindtype lkt;
7557 ffeinfoKindtype rkt;
7558 ffeinfoKindtype nkt;
7559 bool ok = TRUE;
7560 ffebld orig;
7561
7562 if ((ffeexpr_stack_->expr == NULL)
7563 || (ffebld_op (ffeexpr_stack_->expr) != FFEBLD_opCONTER)
7564 || (((orig = ffebld_conter_orig (ffeexpr_stack_->expr)) != NULL)
7565 && (((ffebld_op (orig) != FFEBLD_opUMINUS)
7566 && (ffebld_op (orig) != FFEBLD_opUPLUS))
7567 || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
7568 || ((lty != FFEINFO_basictypeINTEGER)
7569 && (lty != FFEINFO_basictypeREAL)))
7570 {
7571 if ((lty != FFEINFO_basictypeANY)
7572 && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
7573 {
7574 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
7575 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
7576 ffebad_string ("Real");
7577 ffebad_finish ();
7578 }
7579 ok = FALSE;
7580 }
7581 if ((expr == NULL)
7582 || (ffebld_op (expr) != FFEBLD_opCONTER)
7583 || (((orig = ffebld_conter_orig (expr)) != NULL)
7584 && (((ffebld_op (orig) != FFEBLD_opUMINUS)
7585 && (ffebld_op (orig) != FFEBLD_opUPLUS))
7586 || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
7587 || ((rty != FFEINFO_basictypeINTEGER)
7588 && (rty != FFEINFO_basictypeREAL)))
7589 {
7590 if ((rty != FFEINFO_basictypeANY)
7591 && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
7592 {
7593 ffebad_here (0, ffelex_token_where_line (ft),
7594 ffelex_token_where_column (ft));
7595 ffebad_string ("Imaginary");
7596 ffebad_finish ();
7597 }
7598 ok = FALSE;
7599 }
7600
7601 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7602
7603 /* Push the (parenthesized) expression as an operand onto the expression
7604 stack. */
7605
7606 e = ffeexpr_expr_new_ ();
7607 e->type = FFEEXPR_exprtypeOPERAND_;
7608 e->token = ffeexpr_stack_->tokens[0];
7609
7610 if (ok)
7611 {
7612 if (lty == FFEINFO_basictypeINTEGER)
7613 lkt = FFEINFO_kindtypeREALDEFAULT;
7614 else
7615 lkt = ffeinfo_kindtype (ffebld_info (ffeexpr_stack_->expr));
7616 if (rty == FFEINFO_basictypeINTEGER)
7617 rkt = FFEINFO_kindtypeREALDEFAULT;
7618 else
7619 rkt = ffeinfo_kindtype (ffebld_info (expr));
7620
7621 nkt = ffeinfo_kindtype_max (FFEINFO_basictypeCOMPLEX, lkt, rkt);
7622 ffeexpr_stack_->expr = ffeexpr_convert (ffeexpr_stack_->expr,
7623 ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
7624 FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
7625 FFEEXPR_contextLET);
7626 expr = ffeexpr_convert (expr,
7627 ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
7628 FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
7629 FFEEXPR_contextLET);
7630 }
7631 else
7632 nkt = FFEINFO_kindtypeANY;
7633
7634 switch (nkt)
7635 {
7636 #if FFETARGET_okCOMPLEX1
7637 case FFEINFO_kindtypeREAL1:
7638 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex1
7639 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7640 ffebld_set_info (e->u.operand,
7641 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7642 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7643 FFETARGET_charactersizeNONE));
7644 break;
7645 #endif
7646
7647 #if FFETARGET_okCOMPLEX2
7648 case FFEINFO_kindtypeREAL2:
7649 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex2
7650 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7651 ffebld_set_info (e->u.operand,
7652 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7653 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7654 FFETARGET_charactersizeNONE));
7655 break;
7656 #endif
7657
7658 #if FFETARGET_okCOMPLEX3
7659 case FFEINFO_kindtypeREAL3:
7660 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex3
7661 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7662 ffebld_set_info (e->u.operand,
7663 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7664 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7665 FFETARGET_charactersizeNONE));
7666 break;
7667 #endif
7668
7669 #if FFETARGET_okCOMPLEX4
7670 case FFEINFO_kindtypeREAL4:
7671 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex4
7672 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7673 ffebld_set_info (e->u.operand,
7674 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7675 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7676 FFETARGET_charactersizeNONE));
7677 break;
7678 #endif
7679
7680 default:
7681 if (ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
7682 ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX))
7683 {
7684 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7685 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7686 ffebad_finish ();
7687 }
7688 /* Fall through. */
7689 case FFEINFO_kindtypeANY:
7690 e->u.operand = ffebld_new_any ();
7691 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
7692 break;
7693 }
7694 ffeexpr_exprstack_push_operand_ (e);
7695
7696 /* Now, if the token is a close parenthese, we're in great shape so return
7697 the next handler. */
7698
7699 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7700 return (ffelexHandler) ffeexpr_token_binary_;
7701
7702 /* Oops, naughty user didn't specify the close paren! */
7703
7704 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7705 {
7706 ffebad_here (0, ffelex_token_where_line (t),
7707 ffelex_token_where_column (t));
7708 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7709 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7710 ffebad_finish ();
7711 }
7712
7713 return
7714 (ffelexHandler) ffeexpr_find_close_paren_ (t,
7715 (ffelexHandler)
7716 ffeexpr_token_binary_);
7717 }
7718
7719 /* ffeexpr_cb_close_paren_ci_ -- OPEN_PAREN expr (possible complex or
7720 implied-DO construct)
7721
7722 Pass it to ffeexpr_rhs as the callback routine.
7723
7724 Makes sure the end token is close-paren and swallows it, or a comma
7725 and handles complex/implied-do possibilities, else issues
7726 an error message and doesn't swallow the token (passing it along instead). */
7727
7728 static ffelexHandler
ffeexpr_cb_close_paren_ci_(ffelexToken ft,ffebld expr,ffelexToken t)7729 ffeexpr_cb_close_paren_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
7730 {
7731 ffeexprContext ctx;
7732
7733 /* First check to see if this is a possible complex or implied-DO entity.
7734 It is if the token is a comma. */
7735
7736 if (ffelex_token_type (t) == FFELEX_typeCOMMA)
7737 {
7738 switch (ffeexpr_stack_->context)
7739 {
7740 case FFEEXPR_contextIOLIST:
7741 case FFEEXPR_contextIMPDOITEM_:
7742 ctx = FFEEXPR_contextIMPDOITEM_;
7743 break;
7744
7745 case FFEEXPR_contextIOLISTDF:
7746 case FFEEXPR_contextIMPDOITEMDF_:
7747 ctx = FFEEXPR_contextIMPDOITEMDF_;
7748 break;
7749
7750 default:
7751 assert ("bad context" == NULL);
7752 ctx = FFEEXPR_contextIMPDOITEM_;
7753 break;
7754 }
7755
7756 ffeexpr_stack_->tokens[0] = ffelex_token_use (ft);
7757 ffeexpr_stack_->expr = expr;
7758 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7759 ctx, ffeexpr_cb_comma_ci_);
7760 }
7761
7762 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
7763 return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
7764 }
7765
7766 /* ffeexpr_cb_comma_ci_ -- OPEN_PAREN expr COMMA expr
7767
7768 Pass it to ffeexpr_rhs as the callback routine.
7769
7770 If this token is not a comma, we have a complex constant (or an attempt
7771 at one), so handle it accordingly, displaying error messages if the token
7772 is not a close-paren. If we have a comma here, it is an attempt at an
7773 implied-DO, so start making a list accordingly. Oh, it might be an
7774 equal sign also, meaning an implied-DO with only one item in its list. */
7775
7776 static ffelexHandler
ffeexpr_cb_comma_ci_(ffelexToken ft,ffebld expr,ffelexToken t)7777 ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
7778 {
7779 ffebld fexpr;
7780
7781 /* First check to see if this is a possible complex constant. It is if the
7782 token is not a comma or an equals sign, in which case it should be a
7783 close-paren. */
7784
7785 if ((ffelex_token_type (t) != FFELEX_typeCOMMA)
7786 && (ffelex_token_type (t) != FFELEX_typeEQUALS))
7787 {
7788 ffeexpr_stack_->tokens[1] = ffeexpr_stack_->tokens[0];
7789 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
7790 return (ffelexHandler) ffeexpr_cb_comma_c_ (ft, expr, t);
7791 }
7792
7793 /* Here we have either EQUALS or COMMA, meaning we are in an implied-DO
7794 construct. Make a list and handle accordingly. */
7795
7796 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
7797 fexpr = ffeexpr_stack_->expr;
7798 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7799 ffebld_append_item (&ffeexpr_stack_->bottom, fexpr);
7800 return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
7801 }
7802
7803 /* ffeexpr_cb_comma_i_ -- OPEN_PAREN expr
7804
7805 Pass it to ffeexpr_rhs as the callback routine.
7806
7807 Handle first item in an implied-DO construct. */
7808
7809 static ffelexHandler
ffeexpr_cb_comma_i_(ffelexToken ft,ffebld expr,ffelexToken t)7810 ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr, ffelexToken t)
7811 {
7812 if (ffelex_token_type (t) != FFELEX_typeCOMMA)
7813 {
7814 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7815 {
7816 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7817 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7818 ffelex_token_where_column (ffeexpr_stack_->first_token));
7819 ffebad_finish ();
7820 }
7821 ffebld_end_list (&ffeexpr_stack_->bottom);
7822 ffeexpr_stack_->expr = ffebld_new_any ();
7823 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7824 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7825 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7826 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7827 }
7828
7829 return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
7830 }
7831
7832 /* ffeexpr_cb_comma_i_1_ -- OPEN_PAREN expr
7833
7834 Pass it to ffeexpr_rhs as the callback routine.
7835
7836 Handle first item in an implied-DO construct. */
7837
7838 static ffelexHandler
ffeexpr_cb_comma_i_1_(ffelexToken ft,ffebld expr,ffelexToken t)7839 ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr, ffelexToken t)
7840 {
7841 ffeexprContext ctxi;
7842 ffeexprContext ctxc;
7843
7844 switch (ffeexpr_stack_->context)
7845 {
7846 case FFEEXPR_contextDATA:
7847 case FFEEXPR_contextDATAIMPDOITEM_:
7848 ctxi = FFEEXPR_contextDATAIMPDOITEM_;
7849 ctxc = FFEEXPR_contextDATAIMPDOCTRL_;
7850 break;
7851
7852 case FFEEXPR_contextIOLIST:
7853 case FFEEXPR_contextIMPDOITEM_:
7854 ctxi = FFEEXPR_contextIMPDOITEM_;
7855 ctxc = FFEEXPR_contextIMPDOCTRL_;
7856 break;
7857
7858 case FFEEXPR_contextIOLISTDF:
7859 case FFEEXPR_contextIMPDOITEMDF_:
7860 ctxi = FFEEXPR_contextIMPDOITEMDF_;
7861 ctxc = FFEEXPR_contextIMPDOCTRL_;
7862 break;
7863
7864 default:
7865 assert ("bad context" == NULL);
7866 ctxi = FFEEXPR_context;
7867 ctxc = FFEEXPR_context;
7868 break;
7869 }
7870
7871 switch (ffelex_token_type (t))
7872 {
7873 case FFELEX_typeCOMMA:
7874 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7875 if (ffeexpr_stack_->is_rhs)
7876 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7877 ctxi, ffeexpr_cb_comma_i_1_);
7878 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7879 ctxi, ffeexpr_cb_comma_i_1_);
7880
7881 case FFELEX_typeEQUALS:
7882 ffebld_end_list (&ffeexpr_stack_->bottom);
7883
7884 /* Complain if implied-DO variable in list of items to be read. */
7885
7886 if ((ctxc == FFEEXPR_contextIMPDOCTRL_) && !ffeexpr_stack_->is_rhs)
7887 ffeexpr_check_impdo_ (ffeexpr_stack_->expr,
7888 ffeexpr_stack_->first_token, expr, ft);
7889
7890 /* Set doiter flag for all appropriate SYMTERs. */
7891
7892 ffeexpr_update_impdo_ (ffeexpr_stack_->expr, expr);
7893
7894 ffeexpr_stack_->expr = ffebld_new_impdo (ffeexpr_stack_->expr, NULL);
7895 ffebld_set_info (ffeexpr_stack_->expr,
7896 ffeinfo_new (FFEINFO_basictypeNONE,
7897 FFEINFO_kindtypeNONE,
7898 0,
7899 FFEINFO_kindNONE,
7900 FFEINFO_whereNONE,
7901 FFETARGET_charactersizeNONE));
7902 ffebld_init_list (&(ffebld_right (ffeexpr_stack_->expr)),
7903 &ffeexpr_stack_->bottom);
7904 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7905 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7906 ctxc, ffeexpr_cb_comma_i_2_);
7907
7908 default:
7909 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7910 {
7911 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7912 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7913 ffelex_token_where_column (ffeexpr_stack_->first_token));
7914 ffebad_finish ();
7915 }
7916 ffebld_end_list (&ffeexpr_stack_->bottom);
7917 ffeexpr_stack_->expr = ffebld_new_any ();
7918 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7919 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7920 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7921 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7922 }
7923 }
7924
7925 /* ffeexpr_cb_comma_i_2_ -- OPEN_PAREN expr-list EQUALS expr
7926
7927 Pass it to ffeexpr_rhs as the callback routine.
7928
7929 Handle start-value in an implied-DO construct. */
7930
7931 static ffelexHandler
ffeexpr_cb_comma_i_2_(ffelexToken ft UNUSED,ffebld expr,ffelexToken t)7932 ffeexpr_cb_comma_i_2_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7933 {
7934 ffeexprContext ctx;
7935
7936 switch (ffeexpr_stack_->context)
7937 {
7938 case FFEEXPR_contextDATA:
7939 case FFEEXPR_contextDATAIMPDOITEM_:
7940 ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7941 break;
7942
7943 case FFEEXPR_contextIOLIST:
7944 case FFEEXPR_contextIOLISTDF:
7945 case FFEEXPR_contextIMPDOITEM_:
7946 case FFEEXPR_contextIMPDOITEMDF_:
7947 ctx = FFEEXPR_contextIMPDOCTRL_;
7948 break;
7949
7950 default:
7951 assert ("bad context" == NULL);
7952 ctx = FFEEXPR_context;
7953 break;
7954 }
7955
7956 switch (ffelex_token_type (t))
7957 {
7958 case FFELEX_typeCOMMA:
7959 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7960 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7961 ctx, ffeexpr_cb_comma_i_3_);
7962 break;
7963
7964 default:
7965 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7966 {
7967 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7968 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7969 ffelex_token_where_column (ffeexpr_stack_->first_token));
7970 ffebad_finish ();
7971 }
7972 ffebld_end_list (&ffeexpr_stack_->bottom);
7973 ffeexpr_stack_->expr = ffebld_new_any ();
7974 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7975 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7976 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7977 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7978 }
7979 }
7980
7981 /* ffeexpr_cb_comma_i_3_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7982
7983 Pass it to ffeexpr_rhs as the callback routine.
7984
7985 Handle end-value in an implied-DO construct. */
7986
7987 static ffelexHandler
ffeexpr_cb_comma_i_3_(ffelexToken ft UNUSED,ffebld expr,ffelexToken t)7988 ffeexpr_cb_comma_i_3_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7989 {
7990 ffeexprContext ctx;
7991
7992 switch (ffeexpr_stack_->context)
7993 {
7994 case FFEEXPR_contextDATA:
7995 case FFEEXPR_contextDATAIMPDOITEM_:
7996 ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7997 break;
7998
7999 case FFEEXPR_contextIOLIST:
8000 case FFEEXPR_contextIOLISTDF:
8001 case FFEEXPR_contextIMPDOITEM_:
8002 case FFEEXPR_contextIMPDOITEMDF_:
8003 ctx = FFEEXPR_contextIMPDOCTRL_;
8004 break;
8005
8006 default:
8007 assert ("bad context" == NULL);
8008 ctx = FFEEXPR_context;
8009 break;
8010 }
8011
8012 switch (ffelex_token_type (t))
8013 {
8014 case FFELEX_typeCOMMA:
8015 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
8016 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8017 ctx, ffeexpr_cb_comma_i_4_);
8018 break;
8019
8020 case FFELEX_typeCLOSE_PAREN:
8021 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
8022 return (ffelexHandler) ffeexpr_cb_comma_i_4_ (NULL, NULL, t);
8023 break;
8024
8025 default:
8026 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
8027 {
8028 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8029 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
8030 ffelex_token_where_column (ffeexpr_stack_->first_token));
8031 ffebad_finish ();
8032 }
8033 ffebld_end_list (&ffeexpr_stack_->bottom);
8034 ffeexpr_stack_->expr = ffebld_new_any ();
8035 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
8036 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
8037 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
8038 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
8039 }
8040 }
8041
8042 /* ffeexpr_cb_comma_i_4_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
8043 [COMMA expr]
8044
8045 Pass it to ffeexpr_rhs as the callback routine.
8046
8047 Handle incr-value in an implied-DO construct. */
8048
8049 static ffelexHandler
ffeexpr_cb_comma_i_4_(ffelexToken ft UNUSED,ffebld expr,ffelexToken t)8050 ffeexpr_cb_comma_i_4_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
8051 {
8052 switch (ffelex_token_type (t))
8053 {
8054 case FFELEX_typeCLOSE_PAREN:
8055 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
8056 ffebld_end_list (&ffeexpr_stack_->bottom);
8057 {
8058 ffebld item;
8059
8060 for (item = ffebld_left (ffeexpr_stack_->expr);
8061 item != NULL;
8062 item = ffebld_trail (item))
8063 if (ffebld_op (ffebld_head (item)) == FFEBLD_opANY)
8064 goto replace_with_any; /* :::::::::::::::::::: */
8065
8066 for (item = ffebld_right (ffeexpr_stack_->expr);
8067 item != NULL;
8068 item = ffebld_trail (item))
8069 if ((ffebld_head (item) != NULL) /* Increment may be NULL. */
8070 && (ffebld_op (ffebld_head (item)) == FFEBLD_opANY))
8071 goto replace_with_any; /* :::::::::::::::::::: */
8072 }
8073 break;
8074
8075 default:
8076 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
8077 {
8078 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8079 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
8080 ffelex_token_where_column (ffeexpr_stack_->first_token));
8081 ffebad_finish ();
8082 }
8083 ffebld_end_list (&ffeexpr_stack_->bottom);
8084
8085 replace_with_any: /* :::::::::::::::::::: */
8086
8087 ffeexpr_stack_->expr = ffebld_new_any ();
8088 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
8089 break;
8090 }
8091
8092 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
8093 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
8094 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
8095 }
8096
8097 /* ffeexpr_cb_comma_i_5_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
8098 [COMMA expr] CLOSE_PAREN
8099
8100 Pass it to ffeexpr_rhs as the callback routine.
8101
8102 Collects token following implied-DO construct for callback function. */
8103
8104 static ffelexHandler
ffeexpr_cb_comma_i_5_(ffelexToken t)8105 ffeexpr_cb_comma_i_5_ (ffelexToken t)
8106 {
8107 ffeexprCallback callback;
8108 ffeexprStack_ s;
8109 ffelexHandler next;
8110 ffelexToken ft;
8111 ffebld expr;
8112 bool terminate;
8113
8114 switch (ffeexpr_stack_->context)
8115 {
8116 case FFEEXPR_contextDATA:
8117 case FFEEXPR_contextDATAIMPDOITEM_:
8118 terminate = TRUE;
8119 break;
8120
8121 case FFEEXPR_contextIOLIST:
8122 case FFEEXPR_contextIOLISTDF:
8123 case FFEEXPR_contextIMPDOITEM_:
8124 case FFEEXPR_contextIMPDOITEMDF_:
8125 terminate = FALSE;
8126 break;
8127
8128 default:
8129 assert ("bad context" == NULL);
8130 terminate = FALSE;
8131 break;
8132 }
8133
8134 ffebld_pool_pop ();
8135 callback = ffeexpr_stack_->callback;
8136 ft = ffeexpr_stack_->first_token;
8137 expr = ffeexpr_stack_->expr;
8138 s = ffeexpr_stack_->previous;
8139 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
8140 sizeof (*ffeexpr_stack_));
8141 ffeexpr_stack_ = s;
8142 next = (ffelexHandler) (*callback) (ft, expr, t);
8143 ffelex_token_kill (ft);
8144 if (terminate)
8145 {
8146 ffesymbol_drive_sfnames (ffeexpr_check_impctrl_);
8147 --ffeexpr_level_;
8148 if (ffeexpr_level_ == 0)
8149 ffe_terminate_4 ();
8150 }
8151 return (ffelexHandler) next;
8152 }
8153
8154 /* ffeexpr_cb_end_loc_ -- Handle end of %LOC subexpression
8155
8156 Makes sure the end token is close-paren and swallows it, else issues
8157 an error message and doesn't swallow the token (passing it along instead).
8158 In either case wraps up subexpression construction by enclosing the
8159 ffebld expression in a %LOC. */
8160
8161 static ffelexHandler
ffeexpr_cb_end_loc_(ffelexToken ft UNUSED,ffebld expr,ffelexToken t)8162 ffeexpr_cb_end_loc_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
8163 {
8164 ffeexprExpr_ e;
8165
8166 /* First push the (%LOC) expression as an operand onto the expression
8167 stack. */
8168
8169 e = ffeexpr_expr_new_ ();
8170 e->type = FFEEXPR_exprtypeOPERAND_;
8171 e->token = ffeexpr_stack_->tokens[0];
8172 e->u.operand = ffebld_new_percent_loc (expr);
8173 ffebld_set_info (e->u.operand,
8174 ffeinfo_new (FFEINFO_basictypeINTEGER,
8175 ffecom_pointer_kind (),
8176 0,
8177 FFEINFO_kindENTITY,
8178 FFEINFO_whereFLEETING,
8179 FFETARGET_charactersizeNONE));
8180 #if 0 /* ~~ */
8181 e->u.operand = ffeexpr_collapse_percent_loc (e->u.operand, ft);
8182 #endif
8183 ffeexpr_exprstack_push_operand_ (e);
8184
8185 /* Now, if the token is a close parenthese, we're in great shape so return
8186 the next handler. */
8187
8188 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
8189 {
8190 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8191 return (ffelexHandler) ffeexpr_token_binary_;
8192 }
8193
8194 /* Oops, naughty user didn't specify the close paren! */
8195
8196 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
8197 {
8198 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8199 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
8200 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
8201 ffebad_finish ();
8202 }
8203
8204 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8205 return
8206 (ffelexHandler) ffeexpr_find_close_paren_ (t,
8207 (ffelexHandler)
8208 ffeexpr_token_binary_);
8209 }
8210
8211 /* ffeexpr_cb_end_notloc_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
8212
8213 Should be CLOSE_PAREN, and make sure expr isn't a %(VAL,REF,DESCR). */
8214
8215 static ffelexHandler
ffeexpr_cb_end_notloc_(ffelexToken ft,ffebld expr,ffelexToken t)8216 ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr, ffelexToken t)
8217 {
8218 ffeexprExpr_ e;
8219 ffebldOp op;
8220
8221 /* If expression is itself a %(VAL,REF,DESCR), complain and strip off all
8222 such things until the lowest-level expression is reached. */
8223
8224 op = ffebld_op (expr);
8225 if ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
8226 || (op == FFEBLD_opPERCENT_DESCR))
8227 {
8228 if (ffebad_start (FFEBAD_NESTED_PERCENT))
8229 {
8230 ffebad_here (0, ffelex_token_where_line (ft),
8231 ffelex_token_where_column (ft));
8232 ffebad_finish ();
8233 }
8234
8235 do
8236 {
8237 expr = ffebld_left (expr);
8238 op = ffebld_op (expr);
8239 }
8240 while ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
8241 || (op == FFEBLD_opPERCENT_DESCR));
8242 }
8243
8244 /* Push the expression as an operand onto the expression stack. */
8245
8246 e = ffeexpr_expr_new_ ();
8247 e->type = FFEEXPR_exprtypeOPERAND_;
8248 e->token = ffeexpr_stack_->tokens[0];
8249 switch (ffeexpr_stack_->percent)
8250 {
8251 case FFEEXPR_percentVAL_:
8252 e->u.operand = ffebld_new_percent_val (expr);
8253 break;
8254
8255 case FFEEXPR_percentREF_:
8256 e->u.operand = ffebld_new_percent_ref (expr);
8257 break;
8258
8259 case FFEEXPR_percentDESCR_:
8260 e->u.operand = ffebld_new_percent_descr (expr);
8261 break;
8262
8263 default:
8264 assert ("%lossage" == NULL);
8265 e->u.operand = expr;
8266 break;
8267 }
8268 ffebld_set_info (e->u.operand, ffebld_info (expr));
8269 #if 0 /* ~~ */
8270 e->u.operand = ffeexpr_collapse_percent_ ? ? ? (e->u.operand, ft);
8271 #endif
8272 ffeexpr_exprstack_push_operand_ (e);
8273
8274 /* Now, if the token is a close parenthese, we're in great shape so return
8275 the next handler. */
8276
8277 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
8278 return (ffelexHandler) ffeexpr_cb_end_notloc_1_;
8279
8280 /* Oops, naughty user didn't specify the close paren! */
8281
8282 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
8283 {
8284 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8285 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
8286 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
8287 ffebad_finish ();
8288 }
8289
8290 ffebld_set_op (e->u.operand, FFEBLD_opPERCENT_LOC);
8291
8292 switch (ffeexpr_stack_->context)
8293 {
8294 case FFEEXPR_contextACTUALARG_:
8295 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8296 break;
8297
8298 case FFEEXPR_contextINDEXORACTUALARG_:
8299 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8300 break;
8301
8302 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8303 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8304 break;
8305
8306 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8307 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8308 break;
8309
8310 default:
8311 assert ("bad context?!?!" == NULL);
8312 break;
8313 }
8314
8315 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8316 return
8317 (ffelexHandler) ffeexpr_find_close_paren_ (t,
8318 (ffelexHandler)
8319 ffeexpr_cb_end_notloc_1_);
8320 }
8321
8322 /* ffeexpr_cb_end_notloc_1_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
8323 CLOSE_PAREN
8324
8325 Should be COMMA or CLOSE_PAREN, else change back to %LOC. */
8326
8327 static ffelexHandler
ffeexpr_cb_end_notloc_1_(ffelexToken t)8328 ffeexpr_cb_end_notloc_1_ (ffelexToken t)
8329 {
8330 switch (ffelex_token_type (t))
8331 {
8332 case FFELEX_typeCOMMA:
8333 case FFELEX_typeCLOSE_PAREN:
8334 switch (ffeexpr_stack_->context)
8335 {
8336 case FFEEXPR_contextACTUALARG_:
8337 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8338 break;
8339
8340 case FFEEXPR_contextINDEXORACTUALARG_:
8341 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
8342 break;
8343
8344 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8345 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
8346 break;
8347
8348 default:
8349 assert ("bad context?!?!" == NULL);
8350 break;
8351 }
8352 break;
8353
8354 default:
8355 if (ffebad_start (FFEBAD_INVALID_PERCENT))
8356 {
8357 ffebad_here (0,
8358 ffelex_token_where_line (ffeexpr_stack_->first_token),
8359 ffelex_token_where_column (ffeexpr_stack_->first_token));
8360 ffebad_string (ffelex_token_text (ffeexpr_stack_->tokens[1]));
8361 ffebad_finish ();
8362 }
8363
8364 ffebld_set_op (ffeexpr_stack_->exprstack->u.operand,
8365 FFEBLD_opPERCENT_LOC);
8366
8367 switch (ffeexpr_stack_->context)
8368 {
8369 case FFEEXPR_contextACTUALARG_:
8370 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8371 break;
8372
8373 case FFEEXPR_contextINDEXORACTUALARG_:
8374 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8375 break;
8376
8377 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8378 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8379 break;
8380
8381 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8382 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8383 break;
8384
8385 default:
8386 assert ("bad context?!?!" == NULL);
8387 break;
8388 }
8389 }
8390
8391 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8392 return
8393 (ffelexHandler) ffeexpr_token_binary_ (t);
8394 }
8395
8396 /* Process DATA implied-DO iterator variables as this implied-DO level
8397 terminates. At this point, ffeexpr_level_ == 1 when we see the
8398 last right-paren in "DATA (A(I),I=1,10)/.../". */
8399
8400 static ffesymbol
ffeexpr_check_impctrl_(ffesymbol s)8401 ffeexpr_check_impctrl_ (ffesymbol s)
8402 {
8403 assert (s != NULL);
8404 assert (ffesymbol_sfdummyparent (s) != NULL);
8405
8406 switch (ffesymbol_state (s))
8407 {
8408 case FFESYMBOL_stateNONE: /* Used as iterator already. Now let symbol
8409 be used as iterator at any level at or
8410 innermore than the outermost of the
8411 current level and the symbol's current
8412 level. */
8413 if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
8414 {
8415 ffesymbol_signal_change (s);
8416 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
8417 ffesymbol_signal_unreported (s);
8418 }
8419 break;
8420
8421 case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO.
8422 Error if at outermost level, else it can
8423 still become an iterator. */
8424 if ((ffeexpr_level_ == 1)
8425 && ffebad_start (FFEBAD_BAD_IMPDCL))
8426 {
8427 ffebad_string (ffesymbol_text (s));
8428 ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
8429 ffebad_finish ();
8430 }
8431 break;
8432
8433 case FFESYMBOL_stateUNCERTAIN: /* Iterator. */
8434 assert (ffeexpr_level_ <= ffesymbol_maxentrynum (s));
8435 ffesymbol_signal_change (s);
8436 ffesymbol_set_state (s, FFESYMBOL_stateNONE);
8437 ffesymbol_signal_unreported (s);
8438 break;
8439
8440 case FFESYMBOL_stateUNDERSTOOD:
8441 break; /* ANY. */
8442
8443 default:
8444 assert ("Sasha Foo!!" == NULL);
8445 break;
8446 }
8447
8448 return s;
8449 }
8450
8451 /* Issue diagnostic if implied-DO variable appears in list of lhs
8452 expressions (as in "READ *, (I,I=1,10)"). */
8453
8454 static void
ffeexpr_check_impdo_(ffebld list,ffelexToken list_t,ffebld dovar,ffelexToken dovar_t)8455 ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
8456 ffebld dovar, ffelexToken dovar_t)
8457 {
8458 ffebld item;
8459 ffesymbol dovar_sym;
8460 int itemnum;
8461
8462 if (ffebld_op (dovar) != FFEBLD_opSYMTER)
8463 return; /* Presumably opANY. */
8464
8465 dovar_sym = ffebld_symter (dovar);
8466
8467 for (itemnum = 1; list != NULL; list = ffebld_trail (list), ++itemnum)
8468 {
8469 if (((item = ffebld_head (list)) != NULL)
8470 && (ffebld_op (item) == FFEBLD_opSYMTER)
8471 && (ffebld_symter (item) == dovar_sym))
8472 {
8473 char itemno[20];
8474
8475 sprintf (&itemno[0], "%d", itemnum);
8476 if (ffebad_start (FFEBAD_DOITER_IMPDO))
8477 {
8478 ffebad_here (0, ffelex_token_where_line (list_t),
8479 ffelex_token_where_column (list_t));
8480 ffebad_here (1, ffelex_token_where_line (dovar_t),
8481 ffelex_token_where_column (dovar_t));
8482 ffebad_string (ffesymbol_text (dovar_sym));
8483 ffebad_string (itemno);
8484 ffebad_finish ();
8485 }
8486 }
8487 }
8488 }
8489
8490 /* Decorate any SYMTERs referencing the DO variable with the "doiter"
8491 flag. */
8492
8493 static void
ffeexpr_update_impdo_(ffebld list,ffebld dovar)8494 ffeexpr_update_impdo_ (ffebld list, ffebld dovar)
8495 {
8496 ffesymbol dovar_sym;
8497
8498 if (ffebld_op (dovar) != FFEBLD_opSYMTER)
8499 return; /* Presumably opANY. */
8500
8501 dovar_sym = ffebld_symter (dovar);
8502
8503 ffeexpr_update_impdo_sym_ (list, dovar_sym); /* Recurse! */
8504 }
8505
8506 /* Recursive function to update any expr so SYMTERs have "doiter" flag
8507 if they refer to the given variable. */
8508
8509 static void
ffeexpr_update_impdo_sym_(ffebld expr,ffesymbol dovar)8510 ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar)
8511 {
8512 tail_recurse: /* :::::::::::::::::::: */
8513
8514 if (expr == NULL)
8515 return;
8516
8517 switch (ffebld_op (expr))
8518 {
8519 case FFEBLD_opSYMTER:
8520 if (ffebld_symter (expr) == dovar)
8521 ffebld_symter_set_is_doiter (expr, TRUE);
8522 break;
8523
8524 case FFEBLD_opITEM:
8525 ffeexpr_update_impdo_sym_ (ffebld_head (expr), dovar);
8526 expr = ffebld_trail (expr);
8527 goto tail_recurse; /* :::::::::::::::::::: */
8528
8529 default:
8530 break;
8531 }
8532
8533 switch (ffebld_arity (expr))
8534 {
8535 case 2:
8536 ffeexpr_update_impdo_sym_ (ffebld_left (expr), dovar);
8537 expr = ffebld_right (expr);
8538 goto tail_recurse; /* :::::::::::::::::::: */
8539
8540 case 1:
8541 expr = ffebld_left (expr);
8542 goto tail_recurse; /* :::::::::::::::::::: */
8543
8544 default:
8545 break;
8546 }
8547
8548 return;
8549 }
8550
8551 /* ffeexpr_context_outer_ -- Determine context of stack entry, skipping PARENs
8552
8553 if (ffeexpr_context_outer_(ffeexpr_stack_) == FFEEXPR_contextIF)
8554 // After zero or more PAREN_ contexts, an IF context exists */
8555
8556 static ffeexprContext
ffeexpr_context_outer_(ffeexprStack_ s)8557 ffeexpr_context_outer_ (ffeexprStack_ s)
8558 {
8559 assert (s != NULL);
8560
8561 for (;;)
8562 {
8563 switch (s->context)
8564 {
8565 case FFEEXPR_contextPAREN_:
8566 case FFEEXPR_contextPARENFILENUM_:
8567 case FFEEXPR_contextPARENFILEUNIT_:
8568 break;
8569
8570 default:
8571 return s->context;
8572 }
8573 s = s->previous;
8574 assert (s != NULL);
8575 }
8576 }
8577
8578 /* ffeexpr_percent_ -- Look up name in list of %FOO possibilities
8579
8580 ffeexprPercent_ p;
8581 ffelexToken t;
8582 p = ffeexpr_percent_(t);
8583
8584 Returns the identifier for the name, or the NONE identifier. */
8585
8586 static ffeexprPercent_
ffeexpr_percent_(ffelexToken t)8587 ffeexpr_percent_ (ffelexToken t)
8588 {
8589 const char *p;
8590
8591 switch (ffelex_token_length (t))
8592 {
8593 case 3:
8594 switch (*(p = ffelex_token_text (t)))
8595 {
8596 case FFESRC_CASE_MATCH_INIT ('L', 'l', match_3l, no_match_3):
8597 if ((ffesrc_char_match_noninit (*++p, 'O', 'o'))
8598 && (ffesrc_char_match_noninit (*++p, 'C', 'c')))
8599 return FFEEXPR_percentLOC_;
8600 return FFEEXPR_percentNONE_;
8601
8602 case FFESRC_CASE_MATCH_INIT ('R', 'r', match_3r, no_match_3):
8603 if ((ffesrc_char_match_noninit (*++p, 'E', 'e'))
8604 && (ffesrc_char_match_noninit (*++p, 'F', 'f')))
8605 return FFEEXPR_percentREF_;
8606 return FFEEXPR_percentNONE_;
8607
8608 case FFESRC_CASE_MATCH_INIT ('V', 'v', match_3v, no_match_3):
8609 if ((ffesrc_char_match_noninit (*++p, 'A', 'a'))
8610 && (ffesrc_char_match_noninit (*++p, 'L', 'l')))
8611 return FFEEXPR_percentVAL_;
8612 return FFEEXPR_percentNONE_;
8613
8614 default:
8615 no_match_3: /* :::::::::::::::::::: */
8616 return FFEEXPR_percentNONE_;
8617 }
8618
8619 case 5:
8620 if (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "DESCR",
8621 "descr", "Descr") == 0)
8622 return FFEEXPR_percentDESCR_;
8623 return FFEEXPR_percentNONE_;
8624
8625 default:
8626 return FFEEXPR_percentNONE_;
8627 }
8628 }
8629
8630 /* ffeexpr_type_combine -- Binop combine types, check for mythical new COMPLEX
8631
8632 See prototype.
8633
8634 If combining the two basictype/kindtype pairs produces a COMPLEX with an
8635 unsupported kind type, complain and use the default kind type for
8636 COMPLEX. */
8637
8638 void
ffeexpr_type_combine(ffeinfoBasictype * xnbt,ffeinfoKindtype * xnkt,ffeinfoBasictype lbt,ffeinfoKindtype lkt,ffeinfoBasictype rbt,ffeinfoKindtype rkt,ffelexToken t)8639 ffeexpr_type_combine (ffeinfoBasictype *xnbt, ffeinfoKindtype *xnkt,
8640 ffeinfoBasictype lbt, ffeinfoKindtype lkt,
8641 ffeinfoBasictype rbt, ffeinfoKindtype rkt,
8642 ffelexToken t)
8643 {
8644 ffeinfoBasictype nbt;
8645 ffeinfoKindtype nkt;
8646
8647 nbt = ffeinfo_basictype_combine (lbt, rbt);
8648 if ((nbt == FFEINFO_basictypeCOMPLEX)
8649 && ((lbt == nbt) || (lbt == FFEINFO_basictypeREAL))
8650 && ((rbt == nbt) || (rbt == FFEINFO_basictypeREAL)))
8651 {
8652 nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
8653 if (ffe_is_pedantic_not_90 () && (nkt == FFEINFO_kindtypeREALDOUBLE))
8654 nkt = FFEINFO_kindtypeNONE; /* Force error. */
8655 switch (nkt)
8656 {
8657 #if FFETARGET_okCOMPLEX1
8658 case FFEINFO_kindtypeREAL1:
8659 #endif
8660 #if FFETARGET_okCOMPLEX2
8661 case FFEINFO_kindtypeREAL2:
8662 #endif
8663 #if FFETARGET_okCOMPLEX3
8664 case FFEINFO_kindtypeREAL3:
8665 #endif
8666 #if FFETARGET_okCOMPLEX4
8667 case FFEINFO_kindtypeREAL4:
8668 #endif
8669 break; /* Fine and dandy. */
8670
8671 default:
8672 if (t != NULL)
8673 {
8674 ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
8675 ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX);
8676 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8677 ffebad_finish ();
8678 }
8679 nbt = FFEINFO_basictypeNONE;
8680 nkt = FFEINFO_kindtypeNONE;
8681 break;
8682
8683 case FFEINFO_kindtypeANY:
8684 nkt = FFEINFO_kindtypeREALDEFAULT;
8685 break;
8686 }
8687 }
8688 else
8689 { /* The normal stuff. */
8690 if (nbt == lbt)
8691 {
8692 if (nbt == rbt)
8693 nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
8694 else
8695 nkt = lkt;
8696 }
8697 else if (nbt == rbt)
8698 nkt = rkt;
8699 else
8700 { /* Let the caller do the complaining. */
8701 nbt = FFEINFO_basictypeNONE;
8702 nkt = FFEINFO_kindtypeNONE;
8703 }
8704 }
8705
8706 /* Always a good idea to avoid aliasing problems. */
8707
8708 *xnbt = nbt;
8709 *xnkt = nkt;
8710 }
8711
8712 /* ffeexpr_token_first_lhs_ -- First state for lhs expression
8713
8714 Return a pointer to this function to the lexer (ffelex), which will
8715 invoke it for the next token.
8716
8717 Record line and column of first token in expression, then invoke the
8718 initial-state lhs handler. */
8719
8720 static ffelexHandler
ffeexpr_token_first_lhs_(ffelexToken t)8721 ffeexpr_token_first_lhs_ (ffelexToken t)
8722 {
8723 ffeexpr_stack_->first_token = ffelex_token_use (t);
8724
8725 /* When changing the list of valid initial lhs tokens, check whether to
8726 update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
8727 READ (expr) <token> case -- it assumes it knows which tokens <token> can
8728 be to indicate an lhs (or implied DO), which right now is the set
8729 {NAME,OPEN_PAREN}.
8730
8731 This comment also appears in ffeexpr_token_lhs_. */
8732
8733 switch (ffelex_token_type (t))
8734 {
8735 case FFELEX_typeOPEN_PAREN:
8736 switch (ffeexpr_stack_->context)
8737 {
8738 case FFEEXPR_contextDATA:
8739 ffe_init_4 ();
8740 ffeexpr_level_ = 1; /* Level of DATA implied-DO construct. */
8741 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8742 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8743 FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
8744
8745 case FFEEXPR_contextDATAIMPDOITEM_:
8746 ++ffeexpr_level_; /* Level of DATA implied-DO construct. */
8747 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8748 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8749 FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
8750
8751 case FFEEXPR_contextIOLIST:
8752 case FFEEXPR_contextIMPDOITEM_:
8753 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8754 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8755 FFEEXPR_contextIMPDOITEM_, ffeexpr_cb_comma_i_);
8756
8757 case FFEEXPR_contextIOLISTDF:
8758 case FFEEXPR_contextIMPDOITEMDF_:
8759 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8760 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8761 FFEEXPR_contextIMPDOITEMDF_, ffeexpr_cb_comma_i_);
8762
8763 case FFEEXPR_contextFILEEXTFUNC:
8764 assert (ffeexpr_stack_->exprstack == NULL);
8765 return (ffelexHandler) ffeexpr_token_first_lhs_1_;
8766
8767 default:
8768 break;
8769 }
8770 break;
8771
8772 case FFELEX_typeNAME:
8773 switch (ffeexpr_stack_->context)
8774 {
8775 case FFEEXPR_contextFILENAMELIST:
8776 assert (ffeexpr_stack_->exprstack == NULL);
8777 return (ffelexHandler) ffeexpr_token_namelist_;
8778
8779 case FFEEXPR_contextFILEEXTFUNC:
8780 assert (ffeexpr_stack_->exprstack == NULL);
8781 return (ffelexHandler) ffeexpr_token_first_lhs_1_;
8782
8783 default:
8784 break;
8785 }
8786 break;
8787
8788 default:
8789 switch (ffeexpr_stack_->context)
8790 {
8791 case FFEEXPR_contextFILEEXTFUNC:
8792 assert (ffeexpr_stack_->exprstack == NULL);
8793 return (ffelexHandler) ffeexpr_token_first_lhs_1_;
8794
8795 default:
8796 break;
8797 }
8798 break;
8799 }
8800
8801 return (ffelexHandler) ffeexpr_token_lhs_ (t);
8802 }
8803
8804 /* ffeexpr_token_first_lhs_1_ -- NAME
8805
8806 return ffeexpr_token_first_lhs_1_; // to lexer
8807
8808 Handle NAME as an external function (USEROPEN= VXT extension to OPEN
8809 statement). */
8810
8811 static ffelexHandler
ffeexpr_token_first_lhs_1_(ffelexToken t)8812 ffeexpr_token_first_lhs_1_ (ffelexToken t)
8813 {
8814 ffeexprCallback callback;
8815 ffeexprStack_ s;
8816 ffelexHandler next;
8817 ffelexToken ft;
8818 ffesymbol sy = NULL;
8819 ffebld expr;
8820
8821 ffebld_pool_pop ();
8822 callback = ffeexpr_stack_->callback;
8823 ft = ffeexpr_stack_->first_token;
8824 s = ffeexpr_stack_->previous;
8825
8826 if ((ffelex_token_type (ft) != FFELEX_typeNAME)
8827 || (ffesymbol_attrs (sy = ffeexpr_declare_unadorned_ (ft, FALSE))
8828 & FFESYMBOL_attrANY))
8829 {
8830 if ((ffelex_token_type (ft) != FFELEX_typeNAME)
8831 || !(ffesymbol_attrs (sy) & FFESYMBOL_attrsANY))
8832 {
8833 ffebad_start (FFEBAD_EXPR_WRONG);
8834 ffebad_here (0, ffelex_token_where_line (ft),
8835 ffelex_token_where_column (ft));
8836 ffebad_finish ();
8837 }
8838 expr = ffebld_new_any ();
8839 ffebld_set_info (expr, ffeinfo_new_any ());
8840 }
8841 else
8842 {
8843 expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
8844 FFEINTRIN_impNONE);
8845 ffebld_set_info (expr, ffesymbol_info (sy));
8846 }
8847
8848 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
8849 sizeof (*ffeexpr_stack_));
8850 ffeexpr_stack_ = s;
8851
8852 next = (ffelexHandler) (*callback) (ft, expr, t);
8853 ffelex_token_kill (ft);
8854 return (ffelexHandler) next;
8855 }
8856
8857 /* ffeexpr_token_first_rhs_ -- First state for rhs expression
8858
8859 Record line and column of first token in expression, then invoke the
8860 initial-state rhs handler.
8861
8862 19-Feb-91 JCB 1.1
8863 Allow ASTERISK in PARENFILEUNIT_ case, but only on second level only
8864 (i.e. only as in READ(*), not READ((*))). */
8865
8866 static ffelexHandler
ffeexpr_token_first_rhs_(ffelexToken t)8867 ffeexpr_token_first_rhs_ (ffelexToken t)
8868 {
8869 ffesymbol s;
8870
8871 ffeexpr_stack_->first_token = ffelex_token_use (t);
8872
8873 switch (ffelex_token_type (t))
8874 {
8875 case FFELEX_typeASTERISK:
8876 switch (ffeexpr_stack_->context)
8877 {
8878 case FFEEXPR_contextFILEFORMATNML:
8879 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8880 /* Fall through. */
8881 case FFEEXPR_contextFILEUNIT:
8882 case FFEEXPR_contextDIMLIST:
8883 case FFEEXPR_contextFILEFORMAT:
8884 case FFEEXPR_contextCHARACTERSIZE:
8885 if (ffeexpr_stack_->previous != NULL)
8886 break; /* Valid only on first level. */
8887 assert (ffeexpr_stack_->exprstack == NULL);
8888 return (ffelexHandler) ffeexpr_token_first_rhs_1_;
8889
8890 case FFEEXPR_contextPARENFILEUNIT_:
8891 if (ffeexpr_stack_->previous->previous != NULL)
8892 break; /* Valid only on second level. */
8893 assert (ffeexpr_stack_->exprstack == NULL);
8894 return (ffelexHandler) ffeexpr_token_first_rhs_1_;
8895
8896 case FFEEXPR_contextACTUALARG_:
8897 if (ffeexpr_stack_->previous->context
8898 != FFEEXPR_contextSUBROUTINEREF)
8899 {
8900 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8901 break;
8902 }
8903 assert (ffeexpr_stack_->exprstack == NULL);
8904 return (ffelexHandler) ffeexpr_token_first_rhs_3_;
8905
8906 case FFEEXPR_contextINDEXORACTUALARG_:
8907 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8908 break;
8909
8910 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8911 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8912 break;
8913
8914 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8915 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8916 break;
8917
8918 default:
8919 break;
8920 }
8921 break;
8922
8923 case FFELEX_typeOPEN_PAREN:
8924 switch (ffeexpr_stack_->context)
8925 {
8926 case FFEEXPR_contextFILENUMAMBIG:
8927 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8928 FFEEXPR_contextPARENFILENUM_,
8929 ffeexpr_cb_close_paren_ambig_);
8930
8931 case FFEEXPR_contextFILEUNITAMBIG:
8932 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8933 FFEEXPR_contextPARENFILEUNIT_,
8934 ffeexpr_cb_close_paren_ambig_);
8935
8936 case FFEEXPR_contextIOLIST:
8937 case FFEEXPR_contextIMPDOITEM_:
8938 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8939 FFEEXPR_contextIMPDOITEM_,
8940 ffeexpr_cb_close_paren_ci_);
8941
8942 case FFEEXPR_contextIOLISTDF:
8943 case FFEEXPR_contextIMPDOITEMDF_:
8944 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8945 FFEEXPR_contextIMPDOITEMDF_,
8946 ffeexpr_cb_close_paren_ci_);
8947
8948 case FFEEXPR_contextFILEFORMATNML:
8949 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8950 break;
8951
8952 case FFEEXPR_contextACTUALARG_:
8953 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8954 break;
8955
8956 case FFEEXPR_contextINDEXORACTUALARG_:
8957 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8958 break;
8959
8960 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8961 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8962 break;
8963
8964 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8965 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8966 break;
8967
8968 default:
8969 break;
8970 }
8971 break;
8972
8973 case FFELEX_typeNUMBER:
8974 switch (ffeexpr_stack_->context)
8975 {
8976 case FFEEXPR_contextFILEFORMATNML:
8977 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8978 /* Fall through. */
8979 case FFEEXPR_contextFILEFORMAT:
8980 if (ffeexpr_stack_->previous != NULL)
8981 break; /* Valid only on first level. */
8982 assert (ffeexpr_stack_->exprstack == NULL);
8983 return (ffelexHandler) ffeexpr_token_first_rhs_2_;
8984
8985 case FFEEXPR_contextACTUALARG_:
8986 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8987 break;
8988
8989 case FFEEXPR_contextINDEXORACTUALARG_:
8990 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8991 break;
8992
8993 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8994 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8995 break;
8996
8997 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8998 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8999 break;
9000
9001 default:
9002 break;
9003 }
9004 break;
9005
9006 case FFELEX_typeNAME:
9007 switch (ffeexpr_stack_->context)
9008 {
9009 case FFEEXPR_contextFILEFORMATNML:
9010 assert (ffeexpr_stack_->exprstack == NULL);
9011 s = ffesymbol_lookup_local (t);
9012 if ((s != NULL) && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST))
9013 return (ffelexHandler) ffeexpr_token_namelist_;
9014 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
9015 break;
9016
9017 default:
9018 break;
9019 }
9020 break;
9021
9022 case FFELEX_typePERCENT:
9023 switch (ffeexpr_stack_->context)
9024 {
9025 case FFEEXPR_contextACTUALARG_:
9026 case FFEEXPR_contextINDEXORACTUALARG_:
9027 case FFEEXPR_contextSFUNCDEFACTUALARG_:
9028 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9029 return (ffelexHandler) ffeexpr_token_first_rhs_5_;
9030
9031 case FFEEXPR_contextFILEFORMATNML:
9032 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
9033 break;
9034
9035 default:
9036 break;
9037 }
9038
9039 default:
9040 switch (ffeexpr_stack_->context)
9041 {
9042 case FFEEXPR_contextACTUALARG_:
9043 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
9044 break;
9045
9046 case FFEEXPR_contextINDEXORACTUALARG_:
9047 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
9048 break;
9049
9050 case FFEEXPR_contextSFUNCDEFACTUALARG_:
9051 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
9052 break;
9053
9054 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9055 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
9056 break;
9057
9058 case FFEEXPR_contextFILEFORMATNML:
9059 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
9060 break;
9061
9062 default:
9063 break;
9064 }
9065 break;
9066 }
9067
9068 return (ffelexHandler) ffeexpr_token_rhs_ (t);
9069 }
9070
9071 /* ffeexpr_token_first_rhs_1_ -- ASTERISK
9072
9073 return ffeexpr_token_first_rhs_1_; // to lexer
9074
9075 Return STAR as expression. */
9076
9077 static ffelexHandler
ffeexpr_token_first_rhs_1_(ffelexToken t)9078 ffeexpr_token_first_rhs_1_ (ffelexToken t)
9079 {
9080 ffebld expr;
9081 ffeexprCallback callback;
9082 ffeexprStack_ s;
9083 ffelexHandler next;
9084 ffelexToken ft;
9085
9086 expr = ffebld_new_star ();
9087 ffebld_pool_pop ();
9088 callback = ffeexpr_stack_->callback;
9089 ft = ffeexpr_stack_->first_token;
9090 s = ffeexpr_stack_->previous;
9091 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
9092 ffeexpr_stack_ = s;
9093 next = (ffelexHandler) (*callback) (ft, expr, t);
9094 ffelex_token_kill (ft);
9095 return (ffelexHandler) next;
9096 }
9097
9098 /* ffeexpr_token_first_rhs_2_ -- NUMBER
9099
9100 return ffeexpr_token_first_rhs_2_; // to lexer
9101
9102 Return NULL as expression; NUMBER as first (and only) token, unless the
9103 current token is not a terminating token, in which case run normal
9104 expression handling. */
9105
9106 static ffelexHandler
ffeexpr_token_first_rhs_2_(ffelexToken t)9107 ffeexpr_token_first_rhs_2_ (ffelexToken t)
9108 {
9109 ffeexprCallback callback;
9110 ffeexprStack_ s;
9111 ffelexHandler next;
9112 ffelexToken ft;
9113
9114 switch (ffelex_token_type (t))
9115 {
9116 case FFELEX_typeCLOSE_PAREN:
9117 case FFELEX_typeCOMMA:
9118 case FFELEX_typeEOS:
9119 case FFELEX_typeSEMICOLON:
9120 break;
9121
9122 default:
9123 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9124 return (ffelexHandler) (*next) (t);
9125 }
9126
9127 ffebld_pool_pop ();
9128 callback = ffeexpr_stack_->callback;
9129 ft = ffeexpr_stack_->first_token;
9130 s = ffeexpr_stack_->previous;
9131 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
9132 sizeof (*ffeexpr_stack_));
9133 ffeexpr_stack_ = s;
9134 next = (ffelexHandler) (*callback) (ft, NULL, t);
9135 ffelex_token_kill (ft);
9136 return (ffelexHandler) next;
9137 }
9138
9139 /* ffeexpr_token_first_rhs_3_ -- ASTERISK
9140
9141 return ffeexpr_token_first_rhs_3_; // to lexer
9142
9143 Expect NUMBER, make LABTOK (with copy of token if not inhibited after
9144 confirming, else NULL). */
9145
9146 static ffelexHandler
ffeexpr_token_first_rhs_3_(ffelexToken t)9147 ffeexpr_token_first_rhs_3_ (ffelexToken t)
9148 {
9149 ffelexHandler next;
9150
9151 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
9152 { /* An error, but let normal processing handle
9153 it. */
9154 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9155 return (ffelexHandler) (*next) (t);
9156 }
9157
9158 /* Special case: when we see "*10" as an argument to a subroutine
9159 reference, we confirm the current statement and, if not inhibited at
9160 this point, put a copy of the token into a LABTOK node. We do this
9161 instead of just resolving the label directly via ffelab and putting it
9162 into a LABTER simply to improve error reporting and consistency in
9163 ffestc. We put NULL in the LABTOK if we're still inhibited, so ffestb
9164 doesn't have to worry about killing off any tokens when retracting. */
9165
9166 ffest_confirmed ();
9167 if (ffest_is_inhibited ())
9168 ffeexpr_stack_->expr = ffebld_new_labtok (NULL);
9169 else
9170 ffeexpr_stack_->expr = ffebld_new_labtok (ffelex_token_use (t));
9171 ffebld_set_info (ffeexpr_stack_->expr,
9172 ffeinfo_new (FFEINFO_basictypeNONE,
9173 FFEINFO_kindtypeNONE,
9174 0,
9175 FFEINFO_kindNONE,
9176 FFEINFO_whereNONE,
9177 FFETARGET_charactersizeNONE));
9178
9179 return (ffelexHandler) ffeexpr_token_first_rhs_4_;
9180 }
9181
9182 /* ffeexpr_token_first_rhs_4_ -- ASTERISK NUMBER
9183
9184 return ffeexpr_token_first_rhs_4_; // to lexer
9185
9186 Collect/flush appropriate stuff, send token to callback function. */
9187
9188 static ffelexHandler
ffeexpr_token_first_rhs_4_(ffelexToken t)9189 ffeexpr_token_first_rhs_4_ (ffelexToken t)
9190 {
9191 ffebld expr;
9192 ffeexprCallback callback;
9193 ffeexprStack_ s;
9194 ffelexHandler next;
9195 ffelexToken ft;
9196
9197 expr = ffeexpr_stack_->expr;
9198 ffebld_pool_pop ();
9199 callback = ffeexpr_stack_->callback;
9200 ft = ffeexpr_stack_->first_token;
9201 s = ffeexpr_stack_->previous;
9202 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
9203 ffeexpr_stack_ = s;
9204 next = (ffelexHandler) (*callback) (ft, expr, t);
9205 ffelex_token_kill (ft);
9206 return (ffelexHandler) next;
9207 }
9208
9209 /* ffeexpr_token_first_rhs_5_ -- PERCENT
9210
9211 Should be NAME, or pass through original mechanism. If NAME is LOC,
9212 pass through original mechanism, otherwise must be VAL, REF, or DESCR,
9213 in which case handle the argument (in parentheses), etc. */
9214
9215 static ffelexHandler
ffeexpr_token_first_rhs_5_(ffelexToken t)9216 ffeexpr_token_first_rhs_5_ (ffelexToken t)
9217 {
9218 ffelexHandler next;
9219
9220 if (ffelex_token_type (t) == FFELEX_typeNAME)
9221 {
9222 ffeexprPercent_ p = ffeexpr_percent_ (t);
9223
9224 switch (p)
9225 {
9226 case FFEEXPR_percentNONE_:
9227 case FFEEXPR_percentLOC_:
9228 break; /* Treat %LOC as any other expression. */
9229
9230 case FFEEXPR_percentVAL_:
9231 case FFEEXPR_percentREF_:
9232 case FFEEXPR_percentDESCR_:
9233 ffeexpr_stack_->percent = p;
9234 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
9235 return (ffelexHandler) ffeexpr_token_first_rhs_6_;
9236
9237 default:
9238 assert ("bad percent?!?" == NULL);
9239 break;
9240 }
9241 }
9242
9243 switch (ffeexpr_stack_->context)
9244 {
9245 case FFEEXPR_contextACTUALARG_:
9246 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
9247 break;
9248
9249 case FFEEXPR_contextINDEXORACTUALARG_:
9250 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
9251 break;
9252
9253 case FFEEXPR_contextSFUNCDEFACTUALARG_:
9254 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
9255 break;
9256
9257 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9258 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
9259 break;
9260
9261 default:
9262 assert ("bad context?!?!" == NULL);
9263 break;
9264 }
9265
9266 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9267 return (ffelexHandler) (*next) (t);
9268 }
9269
9270 /* ffeexpr_token_first_rhs_6_ -- PERCENT NAME(VAL,REF,DESCR)
9271
9272 Should be OPEN_PAREN, or pass through original mechanism. */
9273
9274 static ffelexHandler
ffeexpr_token_first_rhs_6_(ffelexToken t)9275 ffeexpr_token_first_rhs_6_ (ffelexToken t)
9276 {
9277 ffelexHandler next;
9278 ffelexToken ft;
9279
9280 if (ffelex_token_type (t) == FFELEX_typeOPEN_PAREN)
9281 {
9282 ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
9283 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
9284 ffeexpr_stack_->context,
9285 ffeexpr_cb_end_notloc_);
9286 }
9287
9288 switch (ffeexpr_stack_->context)
9289 {
9290 case FFEEXPR_contextACTUALARG_:
9291 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
9292 break;
9293
9294 case FFEEXPR_contextINDEXORACTUALARG_:
9295 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
9296 break;
9297
9298 case FFEEXPR_contextSFUNCDEFACTUALARG_:
9299 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
9300 break;
9301
9302 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9303 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
9304 break;
9305
9306 default:
9307 assert ("bad context?!?!" == NULL);
9308 break;
9309 }
9310
9311 ft = ffeexpr_stack_->tokens[0];
9312 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9313 next = (ffelexHandler) (*next) (ft);
9314 ffelex_token_kill (ft);
9315 return (ffelexHandler) (*next) (t);
9316 }
9317
9318 /* ffeexpr_token_namelist_ -- NAME
9319
9320 return ffeexpr_token_namelist_; // to lexer
9321
9322 Make sure NAME was a valid namelist object, wrap it in a SYMTER and
9323 return. */
9324
9325 static ffelexHandler
ffeexpr_token_namelist_(ffelexToken t)9326 ffeexpr_token_namelist_ (ffelexToken t)
9327 {
9328 ffeexprCallback callback;
9329 ffeexprStack_ s;
9330 ffelexHandler next;
9331 ffelexToken ft;
9332 ffesymbol sy;
9333 ffebld expr;
9334
9335 ffebld_pool_pop ();
9336 callback = ffeexpr_stack_->callback;
9337 ft = ffeexpr_stack_->first_token;
9338 s = ffeexpr_stack_->previous;
9339 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
9340 ffeexpr_stack_ = s;
9341
9342 sy = ffesymbol_lookup_local (ft);
9343 if ((sy == NULL) || (ffesymbol_kind (sy) != FFEINFO_kindNAMELIST))
9344 {
9345 ffebad_start (FFEBAD_EXPR_WRONG);
9346 ffebad_here (0, ffelex_token_where_line (ft),
9347 ffelex_token_where_column (ft));
9348 ffebad_finish ();
9349 expr = ffebld_new_any ();
9350 ffebld_set_info (expr, ffeinfo_new_any ());
9351 }
9352 else
9353 {
9354 expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
9355 FFEINTRIN_impNONE);
9356 ffebld_set_info (expr, ffesymbol_info (sy));
9357 }
9358 next = (ffelexHandler) (*callback) (ft, expr, t);
9359 ffelex_token_kill (ft);
9360 return (ffelexHandler) next;
9361 }
9362
9363 /* ffeexpr_expr_kill_ -- Kill an existing internal expression object
9364
9365 ffeexprExpr_ e;
9366 ffeexpr_expr_kill_(e);
9367
9368 Kills the ffewhere info, if necessary, then kills the object. */
9369
9370 static void
ffeexpr_expr_kill_(ffeexprExpr_ e)9371 ffeexpr_expr_kill_ (ffeexprExpr_ e)
9372 {
9373 if (e->token != NULL)
9374 ffelex_token_kill (e->token);
9375 malloc_kill_ks (ffe_pool_program_unit (), e, sizeof (*e));
9376 }
9377
9378 /* ffeexpr_expr_new_ -- Make a new internal expression object
9379
9380 ffeexprExpr_ e;
9381 e = ffeexpr_expr_new_();
9382
9383 Allocates and initializes a new expression object, returns it. */
9384
9385 static ffeexprExpr_
ffeexpr_expr_new_()9386 ffeexpr_expr_new_ ()
9387 {
9388 ffeexprExpr_ e;
9389
9390 e = (ffeexprExpr_) malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR expr",
9391 sizeof (*e));
9392 e->previous = NULL;
9393 e->type = FFEEXPR_exprtypeUNKNOWN_;
9394 e->token = NULL;
9395 return e;
9396 }
9397
9398 /* Verify that call to global is valid, and register whatever
9399 new information about a global might be discoverable by looking
9400 at the call. */
9401
9402 static void
ffeexpr_fulfill_call_(ffebld * expr,ffelexToken t)9403 ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t)
9404 {
9405 int n_args;
9406 ffebld list;
9407 ffebld item;
9408 ffesymbol s;
9409
9410 assert ((ffebld_op (*expr) == FFEBLD_opSUBRREF)
9411 || (ffebld_op (*expr) == FFEBLD_opFUNCREF));
9412
9413 if (ffebld_op (ffebld_left (*expr)) != FFEBLD_opSYMTER)
9414 return;
9415
9416 if (ffesymbol_retractable ())
9417 return;
9418
9419 s = ffebld_symter (ffebld_left (*expr));
9420 if (ffesymbol_global (s) == NULL)
9421 return;
9422
9423 for (n_args = 0, list = ffebld_right (*expr);
9424 list != NULL;
9425 list = ffebld_trail (list), ++n_args)
9426 ;
9427
9428 if (ffeglobal_proc_ref_nargs (s, n_args, t))
9429 {
9430 ffeglobalArgSummary as;
9431 ffeinfoBasictype bt;
9432 ffeinfoKindtype kt;
9433 bool array;
9434 bool fail = FALSE;
9435
9436 for (n_args = 0, list = ffebld_right (*expr);
9437 list != NULL;
9438 list = ffebld_trail (list), ++n_args)
9439 {
9440 item = ffebld_head (list);
9441 if (item != NULL)
9442 {
9443 bt = ffeinfo_basictype (ffebld_info (item));
9444 kt = ffeinfo_kindtype (ffebld_info (item));
9445 array = (ffeinfo_rank (ffebld_info (item)) > 0);
9446 switch (ffebld_op (item))
9447 {
9448 case FFEBLD_opLABTOK:
9449 case FFEBLD_opLABTER:
9450 as = FFEGLOBAL_argsummaryALTRTN;
9451 break;
9452
9453 #if 0
9454 /* No, %LOC(foo) is just like any INTEGER(KIND=7)
9455 expression, so don't treat it specially. */
9456 case FFEBLD_opPERCENT_LOC:
9457 as = FFEGLOBAL_argsummaryPTR;
9458 break;
9459 #endif
9460
9461 case FFEBLD_opPERCENT_VAL:
9462 as = FFEGLOBAL_argsummaryVAL;
9463 break;
9464
9465 case FFEBLD_opPERCENT_REF:
9466 as = FFEGLOBAL_argsummaryREF;
9467 break;
9468
9469 case FFEBLD_opPERCENT_DESCR:
9470 as = FFEGLOBAL_argsummaryDESCR;
9471 break;
9472
9473 case FFEBLD_opFUNCREF:
9474 #if 0
9475 /* No, LOC(foo) is just like any INTEGER(KIND=7)
9476 expression, so don't treat it specially. */
9477 if ((ffebld_op (ffebld_left (item)) == FFEBLD_opSYMTER)
9478 && (ffesymbol_specific (ffebld_symter (ffebld_left (item)))
9479 == FFEINTRIN_specLOC))
9480 {
9481 as = FFEGLOBAL_argsummaryPTR;
9482 break;
9483 }
9484 #endif
9485 /* Fall through. */
9486 default:
9487 if (ffebld_op (item) == FFEBLD_opSYMTER)
9488 {
9489 as = FFEGLOBAL_argsummaryNONE;
9490
9491 switch (ffeinfo_kind (ffebld_info (item)))
9492 {
9493 case FFEINFO_kindFUNCTION:
9494 as = FFEGLOBAL_argsummaryFUNC;
9495 break;
9496
9497 case FFEINFO_kindSUBROUTINE:
9498 as = FFEGLOBAL_argsummarySUBR;
9499 break;
9500
9501 case FFEINFO_kindNONE:
9502 as = FFEGLOBAL_argsummaryPROC;
9503 break;
9504
9505 default:
9506 break;
9507 }
9508
9509 if (as != FFEGLOBAL_argsummaryNONE)
9510 break;
9511 }
9512
9513 if (bt == FFEINFO_basictypeCHARACTER)
9514 as = FFEGLOBAL_argsummaryDESCR;
9515 else
9516 as = FFEGLOBAL_argsummaryREF;
9517 break;
9518 }
9519 }
9520 else
9521 {
9522 array = FALSE;
9523 as = FFEGLOBAL_argsummaryNONE;
9524 bt = FFEINFO_basictypeNONE;
9525 kt = FFEINFO_kindtypeNONE;
9526 }
9527
9528 if (! ffeglobal_proc_ref_arg (s, n_args, as, bt, kt, array, t))
9529 fail = TRUE;
9530 }
9531 if (! fail)
9532 return;
9533 }
9534
9535 *expr = ffebld_new_any ();
9536 ffebld_set_info (*expr, ffeinfo_new_any ());
9537 }
9538
9539 /* Check whether rest of string is all decimal digits. */
9540
9541 static bool
ffeexpr_isdigits_(const char * p)9542 ffeexpr_isdigits_ (const char *p)
9543 {
9544 for (; *p != '\0'; ++p)
9545 if (! ISDIGIT (*p))
9546 return FALSE;
9547 return TRUE;
9548 }
9549
9550 /* ffeexpr_exprstack_push_ -- Push an arbitrary expression object onto the stack
9551
9552 ffeexprExpr_ e;
9553 ffeexpr_exprstack_push_(e);
9554
9555 Pushes the expression onto the stack without any analysis of the existing
9556 contents of the stack. */
9557
9558 static void
ffeexpr_exprstack_push_(ffeexprExpr_ e)9559 ffeexpr_exprstack_push_ (ffeexprExpr_ e)
9560 {
9561 e->previous = ffeexpr_stack_->exprstack;
9562 ffeexpr_stack_->exprstack = e;
9563 }
9564
9565 /* ffeexpr_exprstack_push_operand_ -- Push an operand onto the stack, reduce?
9566
9567 ffeexprExpr_ e;
9568 ffeexpr_exprstack_push_operand_(e);
9569
9570 Pushes the expression already containing an operand (a constant, variable,
9571 or more complicated expression that has already been fully resolved) after
9572 analyzing the stack and checking for possible reduction (which will never
9573 happen here since the highest precedence operator is ** and it has right-
9574 to-left associativity). */
9575
9576 static void
ffeexpr_exprstack_push_operand_(ffeexprExpr_ e)9577 ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e)
9578 {
9579 ffeexpr_exprstack_push_ (e);
9580 #ifdef WEIRD_NONFORTRAN_RULES
9581 if ((ffeexpr_stack_->exprstack != NULL)
9582 && (ffeexpr_stack_->exprstack->expr->type == FFEEXPR_exprtypeBINARY_)
9583 && (ffeexpr_stack_->exprstack->expr->u.operator.prec
9584 == FFEEXPR_operatorprecedenceHIGHEST_)
9585 && (ffeexpr_stack_->exprstack->expr->u.operator.as
9586 == FFEEXPR_operatorassociativityL2R_))
9587 ffeexpr_reduce_ ();
9588 #endif
9589 }
9590
9591 /* ffeexpr_exprstack_push_unary_ -- Push a unary operator onto the stack
9592
9593 ffeexprExpr_ e;
9594 ffeexpr_exprstack_push_unary_(e);
9595
9596 Pushes the expression already containing a unary operator. Reduction can
9597 never happen since unary operators are themselves always R-L; that is, the
9598 top of the expression stack is not an operand, in that it is either empty,
9599 has a binary operator at the top, or a unary operator at the top. In any
9600 of these cases, reduction is impossible. */
9601
9602 static void
ffeexpr_exprstack_push_unary_(ffeexprExpr_ e)9603 ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e)
9604 {
9605 if ((ffe_is_pedantic ()
9606 || ffe_is_warn_surprising ())
9607 && (ffeexpr_stack_->exprstack != NULL)
9608 && (ffeexpr_stack_->exprstack->type != FFEEXPR_exprtypeOPERAND_)
9609 && (ffeexpr_stack_->exprstack->u.operator.prec
9610 <= FFEEXPR_operatorprecedenceLOWARITH_)
9611 && (e->u.operator.prec <= FFEEXPR_operatorprecedenceLOWARITH_))
9612 {
9613 /* xgettext:no-c-format */
9614 ffebad_start_msg ("Two arithmetic operators in a row at %0 and %1 -- use parentheses",
9615 ffe_is_pedantic ()
9616 ? FFEBAD_severityPEDANTIC
9617 : FFEBAD_severityWARNING);
9618 ffebad_here (0,
9619 ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
9620 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
9621 ffebad_here (1,
9622 ffelex_token_where_line (e->token),
9623 ffelex_token_where_column (e->token));
9624 ffebad_finish ();
9625 }
9626
9627 ffeexpr_exprstack_push_ (e);
9628 }
9629
9630 /* ffeexpr_exprstack_push_binary_ -- Push a binary operator onto the stack, reduce?
9631
9632 ffeexprExpr_ e;
9633 ffeexpr_exprstack_push_binary_(e);
9634
9635 Pushes the expression already containing a binary operator after checking
9636 whether reduction is possible. If the stack is not empty, the top of the
9637 stack must be an operand or syntactic analysis has failed somehow. If
9638 the operand is preceded by a unary operator of higher (or equal and L-R
9639 associativity) precedence than the new binary operator, then reduce that
9640 preceding operator and its operand(s) before pushing the new binary
9641 operator. */
9642
9643 static void
ffeexpr_exprstack_push_binary_(ffeexprExpr_ e)9644 ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e)
9645 {
9646 ffeexprExpr_ ce;
9647
9648 if (ffe_is_warn_surprising ()
9649 /* These next two are always true (see assertions below). */
9650 && (ffeexpr_stack_->exprstack != NULL)
9651 && (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_)
9652 /* If the previous operator is a unary minus, and the binary op
9653 is of higher precedence, might not do what user expects,
9654 e.g. "-2**2" is "-(2**2)", i.e. "-4", not "(-2)**2", which would
9655 yield "4". */
9656 && (ffeexpr_stack_->exprstack->previous != NULL)
9657 && (ffeexpr_stack_->exprstack->previous->type == FFEEXPR_exprtypeUNARY_)
9658 && (ffeexpr_stack_->exprstack->previous->u.operator.op
9659 == FFEEXPR_operatorSUBTRACT_)
9660 && (e->u.operator.prec
9661 < ffeexpr_stack_->exprstack->previous->u.operator.prec))
9662 {
9663 /* xgettext:no-c-format */
9664 ffebad_start_msg ("Operator at %0 has lower precedence than that at %1 -- use parentheses", FFEBAD_severityWARNING);
9665 ffebad_here (0,
9666 ffelex_token_where_line (ffeexpr_stack_->exprstack->previous->token),
9667 ffelex_token_where_column (ffeexpr_stack_->exprstack->previous->token));
9668 ffebad_here (1,
9669 ffelex_token_where_line (e->token),
9670 ffelex_token_where_column (e->token));
9671 ffebad_finish ();
9672 }
9673
9674 again:
9675 assert (ffeexpr_stack_->exprstack != NULL);
9676 assert (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_);
9677 if ((ce = ffeexpr_stack_->exprstack->previous) != NULL)
9678 {
9679 assert (ce->type != FFEEXPR_exprtypeOPERAND_);
9680 if ((ce->u.operator.prec < e->u.operator.prec)
9681 || ((ce->u.operator.prec == e->u.operator.prec)
9682 && (e->u.operator.as == FFEEXPR_operatorassociativityL2R_)))
9683 {
9684 ffeexpr_reduce_ ();
9685 goto again; /* :::::::::::::::::::: */
9686 }
9687 }
9688
9689 ffeexpr_exprstack_push_ (e);
9690 }
9691
9692 /* ffeexpr_reduce_ -- Reduce highest operator w/operands on stack
9693
9694 ffeexpr_reduce_();
9695
9696 Converts operand binop operand or unop operand at top of stack to a
9697 single operand having the appropriate ffebld expression, and makes
9698 sure that the expression is proper (like not trying to add two character
9699 variables, not trying to concatenate two numbers). Also does the
9700 requisite type-assignment. */
9701
9702 static void
ffeexpr_reduce_()9703 ffeexpr_reduce_ ()
9704 {
9705 ffeexprExpr_ operand; /* This is B in -B or A+B. */
9706 ffeexprExpr_ left_operand; /* When operator is binary, this is A in A+B. */
9707 ffeexprExpr_ operator; /* This is + in A+B. */
9708 ffebld reduced; /* This is +(A,B) in A+B or u-(B) in -B. */
9709 ffebldConstant constnode; /* For checking magical numbers (where mag ==
9710 -mag). */
9711 ffebld expr;
9712 ffebld left_expr;
9713 bool submag = FALSE;
9714
9715 operand = ffeexpr_stack_->exprstack;
9716 assert (operand != NULL);
9717 assert (operand->type == FFEEXPR_exprtypeOPERAND_);
9718 operator = operand->previous;
9719 assert (operator != NULL);
9720 assert (operator->type != FFEEXPR_exprtypeOPERAND_);
9721 if (operator->type == FFEEXPR_exprtypeUNARY_)
9722 {
9723 expr = operand->u.operand;
9724 switch (operator->u.operator.op)
9725 {
9726 case FFEEXPR_operatorADD_:
9727 reduced = ffebld_new_uplus (expr);
9728 if (ffe_is_ugly_logint ())
9729 reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
9730 reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
9731 reduced = ffeexpr_collapse_uplus (reduced, operator->token);
9732 break;
9733
9734 case FFEEXPR_operatorSUBTRACT_:
9735 submag = TRUE; /* Ok to negate a magic number. */
9736 reduced = ffebld_new_uminus (expr);
9737 if (ffe_is_ugly_logint ())
9738 reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
9739 reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
9740 reduced = ffeexpr_collapse_uminus (reduced, operator->token);
9741 break;
9742
9743 case FFEEXPR_operatorNOT_:
9744 reduced = ffebld_new_not (expr);
9745 if (ffe_is_ugly_logint ())
9746 reduced = ffeexpr_reduced_ugly1log_ (reduced, operator, operand);
9747 reduced = ffeexpr_reduced_bool1_ (reduced, operator, operand);
9748 reduced = ffeexpr_collapse_not (reduced, operator->token);
9749 break;
9750
9751 default:
9752 assert ("unexpected unary op" != NULL);
9753 reduced = NULL;
9754 break;
9755 }
9756 if (!submag
9757 && (ffebld_op (expr) == FFEBLD_opCONTER)
9758 && (ffebld_conter_orig (expr) == NULL)
9759 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
9760 {
9761 ffetarget_integer_bad_magical (operand->token);
9762 }
9763 ffeexpr_stack_->exprstack = operator->previous; /* Pops unary-op operand
9764 off stack. */
9765 ffeexpr_expr_kill_ (operand);
9766 operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but
9767 save */
9768 operator->u.operand = reduced; /* the line/column ffewhere info. */
9769 ffeexpr_exprstack_push_operand_ (operator); /* Push it back on
9770 stack. */
9771 }
9772 else
9773 {
9774 assert (operator->type == FFEEXPR_exprtypeBINARY_);
9775 left_operand = operator->previous;
9776 assert (left_operand != NULL);
9777 assert (left_operand->type == FFEEXPR_exprtypeOPERAND_);
9778 expr = operand->u.operand;
9779 left_expr = left_operand->u.operand;
9780 switch (operator->u.operator.op)
9781 {
9782 case FFEEXPR_operatorADD_:
9783 reduced = ffebld_new_add (left_expr, expr);
9784 if (ffe_is_ugly_logint ())
9785 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9786 operand);
9787 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9788 operand);
9789 reduced = ffeexpr_collapse_add (reduced, operator->token);
9790 break;
9791
9792 case FFEEXPR_operatorSUBTRACT_:
9793 submag = TRUE; /* Just to pick the right error if magic
9794 number. */
9795 reduced = ffebld_new_subtract (left_expr, expr);
9796 if (ffe_is_ugly_logint ())
9797 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9798 operand);
9799 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9800 operand);
9801 reduced = ffeexpr_collapse_subtract (reduced, operator->token);
9802 break;
9803
9804 case FFEEXPR_operatorMULTIPLY_:
9805 reduced = ffebld_new_multiply (left_expr, expr);
9806 if (ffe_is_ugly_logint ())
9807 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9808 operand);
9809 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9810 operand);
9811 reduced = ffeexpr_collapse_multiply (reduced, operator->token);
9812 break;
9813
9814 case FFEEXPR_operatorDIVIDE_:
9815 reduced = ffebld_new_divide (left_expr, expr);
9816 if (ffe_is_ugly_logint ())
9817 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9818 operand);
9819 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9820 operand);
9821 reduced = ffeexpr_collapse_divide (reduced, operator->token);
9822 break;
9823
9824 case FFEEXPR_operatorPOWER_:
9825 reduced = ffebld_new_power (left_expr, expr);
9826 if (ffe_is_ugly_logint ())
9827 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9828 operand);
9829 reduced = ffeexpr_reduced_power_ (reduced, left_operand, operator,
9830 operand);
9831 reduced = ffeexpr_collapse_power (reduced, operator->token);
9832 break;
9833
9834 case FFEEXPR_operatorCONCATENATE_:
9835 reduced = ffebld_new_concatenate (left_expr, expr);
9836 reduced = ffeexpr_reduced_concatenate_ (reduced, left_operand, operator,
9837 operand);
9838 reduced = ffeexpr_collapse_concatenate (reduced, operator->token);
9839 break;
9840
9841 case FFEEXPR_operatorLT_:
9842 reduced = ffebld_new_lt (left_expr, expr);
9843 if (ffe_is_ugly_logint ())
9844 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9845 operand);
9846 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9847 operand);
9848 reduced = ffeexpr_collapse_lt (reduced, operator->token);
9849 break;
9850
9851 case FFEEXPR_operatorLE_:
9852 reduced = ffebld_new_le (left_expr, expr);
9853 if (ffe_is_ugly_logint ())
9854 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9855 operand);
9856 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9857 operand);
9858 reduced = ffeexpr_collapse_le (reduced, operator->token);
9859 break;
9860
9861 case FFEEXPR_operatorEQ_:
9862 reduced = ffebld_new_eq (left_expr, expr);
9863 if (ffe_is_ugly_logint ())
9864 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9865 operand);
9866 reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
9867 operand);
9868 reduced = ffeexpr_collapse_eq (reduced, operator->token);
9869 break;
9870
9871 case FFEEXPR_operatorNE_:
9872 reduced = ffebld_new_ne (left_expr, expr);
9873 if (ffe_is_ugly_logint ())
9874 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9875 operand);
9876 reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
9877 operand);
9878 reduced = ffeexpr_collapse_ne (reduced, operator->token);
9879 break;
9880
9881 case FFEEXPR_operatorGT_:
9882 reduced = ffebld_new_gt (left_expr, expr);
9883 if (ffe_is_ugly_logint ())
9884 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9885 operand);
9886 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9887 operand);
9888 reduced = ffeexpr_collapse_gt (reduced, operator->token);
9889 break;
9890
9891 case FFEEXPR_operatorGE_:
9892 reduced = ffebld_new_ge (left_expr, expr);
9893 if (ffe_is_ugly_logint ())
9894 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9895 operand);
9896 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9897 operand);
9898 reduced = ffeexpr_collapse_ge (reduced, operator->token);
9899 break;
9900
9901 case FFEEXPR_operatorAND_:
9902 reduced = ffebld_new_and (left_expr, expr);
9903 if (ffe_is_ugly_logint ())
9904 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9905 operand);
9906 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9907 operand);
9908 reduced = ffeexpr_collapse_and (reduced, operator->token);
9909 break;
9910
9911 case FFEEXPR_operatorOR_:
9912 reduced = ffebld_new_or (left_expr, expr);
9913 if (ffe_is_ugly_logint ())
9914 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9915 operand);
9916 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9917 operand);
9918 reduced = ffeexpr_collapse_or (reduced, operator->token);
9919 break;
9920
9921 case FFEEXPR_operatorXOR_:
9922 reduced = ffebld_new_xor (left_expr, expr);
9923 if (ffe_is_ugly_logint ())
9924 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9925 operand);
9926 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9927 operand);
9928 reduced = ffeexpr_collapse_xor (reduced, operator->token);
9929 break;
9930
9931 case FFEEXPR_operatorEQV_:
9932 reduced = ffebld_new_eqv (left_expr, expr);
9933 if (ffe_is_ugly_logint ())
9934 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9935 operand);
9936 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9937 operand);
9938 reduced = ffeexpr_collapse_eqv (reduced, operator->token);
9939 break;
9940
9941 case FFEEXPR_operatorNEQV_:
9942 reduced = ffebld_new_neqv (left_expr, expr);
9943 if (ffe_is_ugly_logint ())
9944 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9945 operand);
9946 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9947 operand);
9948 reduced = ffeexpr_collapse_neqv (reduced, operator->token);
9949 break;
9950
9951 default:
9952 assert ("bad bin op" == NULL);
9953 reduced = expr;
9954 break;
9955 }
9956 if ((ffebld_op (left_expr) == FFEBLD_opCONTER)
9957 && (ffebld_conter_orig (expr) == NULL)
9958 && ffebld_constant_is_magical (constnode = ffebld_conter (left_expr)))
9959 {
9960 if ((left_operand->previous != NULL)
9961 && (left_operand->previous->type != FFEEXPR_exprtypeOPERAND_)
9962 && (left_operand->previous->u.operator.op
9963 == FFEEXPR_operatorSUBTRACT_))
9964 {
9965 if (left_operand->previous->type == FFEEXPR_exprtypeUNARY_)
9966 ffetarget_integer_bad_magical_precedence (left_operand->token,
9967 left_operand->previous->token,
9968 operator->token);
9969 else
9970 ffetarget_integer_bad_magical_precedence_binary
9971 (left_operand->token,
9972 left_operand->previous->token,
9973 operator->token);
9974 }
9975 else
9976 ffetarget_integer_bad_magical (left_operand->token);
9977 }
9978 if ((ffebld_op (expr) == FFEBLD_opCONTER)
9979 && (ffebld_conter_orig (expr) == NULL)
9980 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
9981 {
9982 if (submag)
9983 ffetarget_integer_bad_magical_binary (operand->token,
9984 operator->token);
9985 else
9986 ffetarget_integer_bad_magical (operand->token);
9987 }
9988 ffeexpr_stack_->exprstack = left_operand->previous; /* Pops binary-op
9989 operands off stack. */
9990 ffeexpr_expr_kill_ (left_operand);
9991 ffeexpr_expr_kill_ (operand);
9992 operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but
9993 save */
9994 operator->u.operand = reduced; /* the line/column ffewhere info. */
9995 ffeexpr_exprstack_push_operand_ (operator); /* Push it back on
9996 stack. */
9997 }
9998 }
9999
10000 /* ffeexpr_reduced_bool1_ -- Wrap up reduction of NOT operator
10001
10002 reduced = ffeexpr_reduced_bool1_(reduced,op,r);
10003
10004 Makes sure the argument for reduced has basictype of
10005 LOGICAL or (ugly) INTEGER. If
10006 argument has where of CONSTANT, assign where CONSTANT to
10007 reduced, else assign where FLEETING.
10008
10009 If these requirements cannot be met, generate error message. */
10010
10011 static ffebld
ffeexpr_reduced_bool1_(ffebld reduced,ffeexprExpr_ op,ffeexprExpr_ r)10012 ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10013 {
10014 ffeinfo rinfo, ninfo;
10015 ffeinfoBasictype rbt;
10016 ffeinfoKindtype rkt;
10017 ffeinfoRank rrk;
10018 ffeinfoKind rkd;
10019 ffeinfoWhere rwh, nwh;
10020
10021 rinfo = ffebld_info (ffebld_left (reduced));
10022 rbt = ffeinfo_basictype (rinfo);
10023 rkt = ffeinfo_kindtype (rinfo);
10024 rrk = ffeinfo_rank (rinfo);
10025 rkd = ffeinfo_kind (rinfo);
10026 rwh = ffeinfo_where (rinfo);
10027
10028 if (((rbt == FFEINFO_basictypeLOGICAL)
10029 || (ffe_is_ugly_logint () && (rbt == FFEINFO_basictypeINTEGER)))
10030 && (rrk == 0))
10031 {
10032 switch (rwh)
10033 {
10034 case FFEINFO_whereCONSTANT:
10035 nwh = FFEINFO_whereCONSTANT;
10036 break;
10037
10038 case FFEINFO_whereIMMEDIATE:
10039 nwh = FFEINFO_whereIMMEDIATE;
10040 break;
10041
10042 default:
10043 nwh = FFEINFO_whereFLEETING;
10044 break;
10045 }
10046
10047 ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
10048 FFETARGET_charactersizeNONE);
10049 ffebld_set_info (reduced, ninfo);
10050 return reduced;
10051 }
10052
10053 if ((rbt != FFEINFO_basictypeLOGICAL)
10054 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
10055 {
10056 if ((rbt != FFEINFO_basictypeANY)
10057 && ffebad_start (FFEBAD_NOT_ARG_TYPE))
10058 {
10059 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10060 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10061 ffebad_finish ();
10062 }
10063 }
10064 else
10065 {
10066 if ((rkd != FFEINFO_kindANY)
10067 && ffebad_start (FFEBAD_NOT_ARG_KIND))
10068 {
10069 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10070 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10071 ffebad_string ("an array");
10072 ffebad_finish ();
10073 }
10074 }
10075
10076 reduced = ffebld_new_any ();
10077 ffebld_set_info (reduced, ffeinfo_new_any ());
10078 return reduced;
10079 }
10080
10081 /* ffeexpr_reduced_bool2_ -- Wrap up reduction of boolean operators
10082
10083 reduced = ffeexpr_reduced_bool2_(reduced,l,op,r);
10084
10085 Makes sure the left and right arguments for reduced have basictype of
10086 LOGICAL or (ugly) INTEGER. Determine common basictype and
10087 size for reduction (flag expression for combined hollerith/typeless
10088 situations for later determination of effective basictype). If both left
10089 and right arguments have where of CONSTANT, assign where CONSTANT to
10090 reduced, else assign where FLEETING. Create CONVERT ops for args where
10091 needed. Convert typeless
10092 constants to the desired type/size explicitly.
10093
10094 If these requirements cannot be met, generate error message. */
10095
10096 static ffebld
ffeexpr_reduced_bool2_(ffebld reduced,ffeexprExpr_ l,ffeexprExpr_ op,ffeexprExpr_ r)10097 ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10098 ffeexprExpr_ r)
10099 {
10100 ffeinfo linfo, rinfo, ninfo;
10101 ffeinfoBasictype lbt, rbt, nbt;
10102 ffeinfoKindtype lkt, rkt, nkt;
10103 ffeinfoRank lrk, rrk;
10104 ffeinfoKind lkd, rkd;
10105 ffeinfoWhere lwh, rwh, nwh;
10106
10107 linfo = ffebld_info (ffebld_left (reduced));
10108 lbt = ffeinfo_basictype (linfo);
10109 lkt = ffeinfo_kindtype (linfo);
10110 lrk = ffeinfo_rank (linfo);
10111 lkd = ffeinfo_kind (linfo);
10112 lwh = ffeinfo_where (linfo);
10113
10114 rinfo = ffebld_info (ffebld_right (reduced));
10115 rbt = ffeinfo_basictype (rinfo);
10116 rkt = ffeinfo_kindtype (rinfo);
10117 rrk = ffeinfo_rank (rinfo);
10118 rkd = ffeinfo_kind (rinfo);
10119 rwh = ffeinfo_where (rinfo);
10120
10121 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10122
10123 if (((nbt == FFEINFO_basictypeLOGICAL)
10124 || (ffe_is_ugly_logint () && (nbt == FFEINFO_basictypeINTEGER)))
10125 && (lrk == 0) && (rrk == 0))
10126 {
10127 switch (lwh)
10128 {
10129 case FFEINFO_whereCONSTANT:
10130 switch (rwh)
10131 {
10132 case FFEINFO_whereCONSTANT:
10133 nwh = FFEINFO_whereCONSTANT;
10134 break;
10135
10136 case FFEINFO_whereIMMEDIATE:
10137 nwh = FFEINFO_whereIMMEDIATE;
10138 break;
10139
10140 default:
10141 nwh = FFEINFO_whereFLEETING;
10142 break;
10143 }
10144 break;
10145
10146 case FFEINFO_whereIMMEDIATE:
10147 switch (rwh)
10148 {
10149 case FFEINFO_whereCONSTANT:
10150 case FFEINFO_whereIMMEDIATE:
10151 nwh = FFEINFO_whereIMMEDIATE;
10152 break;
10153
10154 default:
10155 nwh = FFEINFO_whereFLEETING;
10156 break;
10157 }
10158 break;
10159
10160 default:
10161 nwh = FFEINFO_whereFLEETING;
10162 break;
10163 }
10164
10165 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10166 FFETARGET_charactersizeNONE);
10167 ffebld_set_info (reduced, ninfo);
10168 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10169 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10170 FFEEXPR_contextLET));
10171 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10172 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10173 FFEEXPR_contextLET));
10174 return reduced;
10175 }
10176
10177 if ((lbt != FFEINFO_basictypeLOGICAL)
10178 && (!ffe_is_ugly_logint () || (lbt != FFEINFO_basictypeINTEGER)))
10179 {
10180 if ((rbt != FFEINFO_basictypeLOGICAL)
10181 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
10182 {
10183 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10184 && ffebad_start (FFEBAD_BOOL_ARGS_TYPE))
10185 {
10186 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10187 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10188 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10189 ffebad_finish ();
10190 }
10191 }
10192 else
10193 {
10194 if ((lbt != FFEINFO_basictypeANY)
10195 && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
10196 {
10197 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10198 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10199 ffebad_finish ();
10200 }
10201 }
10202 }
10203 else if ((rbt != FFEINFO_basictypeLOGICAL)
10204 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
10205 {
10206 if ((rbt != FFEINFO_basictypeANY)
10207 && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
10208 {
10209 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10210 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10211 ffebad_finish ();
10212 }
10213 }
10214 else if (lrk != 0)
10215 {
10216 if ((lkd != FFEINFO_kindANY)
10217 && ffebad_start (FFEBAD_BOOL_ARG_KIND))
10218 {
10219 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10220 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10221 ffebad_string ("an array");
10222 ffebad_finish ();
10223 }
10224 }
10225 else
10226 {
10227 if ((rkd != FFEINFO_kindANY)
10228 && ffebad_start (FFEBAD_BOOL_ARG_KIND))
10229 {
10230 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10231 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10232 ffebad_string ("an array");
10233 ffebad_finish ();
10234 }
10235 }
10236
10237 reduced = ffebld_new_any ();
10238 ffebld_set_info (reduced, ffeinfo_new_any ());
10239 return reduced;
10240 }
10241
10242 /* ffeexpr_reduced_concatenate_ -- Wrap up reduction of concatenate operator
10243
10244 reduced = ffeexpr_reduced_concatenate_(reduced,l,op,r);
10245
10246 Makes sure the left and right arguments for reduced have basictype of
10247 CHARACTER and kind of SCALAR, FUNCTION, or STATEMENT FUNCTION. Assign
10248 basictype of CHARACTER and kind of SCALAR to reduced. Calculate effective
10249 size of concatenation and assign that size to reduced. If both left and
10250 right arguments have where of CONSTANT, assign where CONSTANT to reduced,
10251 else assign where FLEETING.
10252
10253 If these requirements cannot be met, generate error message using the
10254 info in l, op, and r arguments and assign basictype, size, kind, and where
10255 of ANY. */
10256
10257 static ffebld
ffeexpr_reduced_concatenate_(ffebld reduced,ffeexprExpr_ l,ffeexprExpr_ op,ffeexprExpr_ r)10258 ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10259 ffeexprExpr_ r)
10260 {
10261 ffeinfo linfo, rinfo, ninfo;
10262 ffeinfoBasictype lbt, rbt, nbt;
10263 ffeinfoKindtype lkt, rkt, nkt;
10264 ffeinfoRank lrk, rrk;
10265 ffeinfoKind lkd, rkd, nkd;
10266 ffeinfoWhere lwh, rwh, nwh;
10267 ffetargetCharacterSize lszm, lszk, rszm, rszk, nszk;
10268
10269 linfo = ffebld_info (ffebld_left (reduced));
10270 lbt = ffeinfo_basictype (linfo);
10271 lkt = ffeinfo_kindtype (linfo);
10272 lrk = ffeinfo_rank (linfo);
10273 lkd = ffeinfo_kind (linfo);
10274 lwh = ffeinfo_where (linfo);
10275 lszk = ffeinfo_size (linfo); /* Known size. */
10276 lszm = ffebld_size_max (ffebld_left (reduced));
10277
10278 rinfo = ffebld_info (ffebld_right (reduced));
10279 rbt = ffeinfo_basictype (rinfo);
10280 rkt = ffeinfo_kindtype (rinfo);
10281 rrk = ffeinfo_rank (rinfo);
10282 rkd = ffeinfo_kind (rinfo);
10283 rwh = ffeinfo_where (rinfo);
10284 rszk = ffeinfo_size (rinfo); /* Known size. */
10285 rszm = ffebld_size_max (ffebld_right (reduced));
10286
10287 if ((lbt == FFEINFO_basictypeCHARACTER) && (rbt == FFEINFO_basictypeCHARACTER)
10288 && (lkt == rkt) && (lrk == 0) && (rrk == 0)
10289 && (((lszm != FFETARGET_charactersizeNONE)
10290 && (rszm != FFETARGET_charactersizeNONE))
10291 || (ffeexpr_context_outer_ (ffeexpr_stack_)
10292 == FFEEXPR_contextLET)
10293 || (ffeexpr_context_outer_ (ffeexpr_stack_)
10294 == FFEEXPR_contextSFUNCDEF)))
10295 {
10296 nbt = FFEINFO_basictypeCHARACTER;
10297 nkd = FFEINFO_kindENTITY;
10298 if ((lszk == FFETARGET_charactersizeNONE)
10299 || (rszk == FFETARGET_charactersizeNONE))
10300 nszk = FFETARGET_charactersizeNONE; /* Ok only in rhs of LET
10301 stmt. */
10302 else
10303 nszk = lszk + rszk;
10304
10305 switch (lwh)
10306 {
10307 case FFEINFO_whereCONSTANT:
10308 switch (rwh)
10309 {
10310 case FFEINFO_whereCONSTANT:
10311 nwh = FFEINFO_whereCONSTANT;
10312 break;
10313
10314 case FFEINFO_whereIMMEDIATE:
10315 nwh = FFEINFO_whereIMMEDIATE;
10316 break;
10317
10318 default:
10319 nwh = FFEINFO_whereFLEETING;
10320 break;
10321 }
10322 break;
10323
10324 case FFEINFO_whereIMMEDIATE:
10325 switch (rwh)
10326 {
10327 case FFEINFO_whereCONSTANT:
10328 case FFEINFO_whereIMMEDIATE:
10329 nwh = FFEINFO_whereIMMEDIATE;
10330 break;
10331
10332 default:
10333 nwh = FFEINFO_whereFLEETING;
10334 break;
10335 }
10336 break;
10337
10338 default:
10339 nwh = FFEINFO_whereFLEETING;
10340 break;
10341 }
10342
10343 nkt = lkt;
10344 ninfo = ffeinfo_new (nbt, nkt, 0, nkd, nwh, nszk);
10345 ffebld_set_info (reduced, ninfo);
10346 return reduced;
10347 }
10348
10349 if ((lbt != FFEINFO_basictypeCHARACTER) && (rbt != FFEINFO_basictypeCHARACTER))
10350 {
10351 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10352 && ffebad_start (FFEBAD_CONCAT_ARGS_TYPE))
10353 {
10354 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10355 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10356 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10357 ffebad_finish ();
10358 }
10359 }
10360 else if (lbt != FFEINFO_basictypeCHARACTER)
10361 {
10362 if ((lbt != FFEINFO_basictypeANY)
10363 && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
10364 {
10365 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10366 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10367 ffebad_finish ();
10368 }
10369 }
10370 else if (rbt != FFEINFO_basictypeCHARACTER)
10371 {
10372 if ((rbt != FFEINFO_basictypeANY)
10373 && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
10374 {
10375 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10376 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10377 ffebad_finish ();
10378 }
10379 }
10380 else if ((lrk != 0) || (lszm == FFETARGET_charactersizeNONE))
10381 {
10382 if ((lkd != FFEINFO_kindANY)
10383 && ffebad_start (FFEBAD_CONCAT_ARG_KIND))
10384 {
10385 const char *what;
10386
10387 if (lrk != 0)
10388 what = "an array";
10389 else
10390 what = "of indeterminate length";
10391 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10392 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10393 ffebad_string (what);
10394 ffebad_finish ();
10395 }
10396 }
10397 else
10398 {
10399 if (ffebad_start (FFEBAD_CONCAT_ARG_KIND))
10400 {
10401 const char *what;
10402
10403 if (rrk != 0)
10404 what = "an array";
10405 else
10406 what = "of indeterminate length";
10407 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10408 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10409 ffebad_string (what);
10410 ffebad_finish ();
10411 }
10412 }
10413
10414 reduced = ffebld_new_any ();
10415 ffebld_set_info (reduced, ffeinfo_new_any ());
10416 return reduced;
10417 }
10418
10419 /* ffeexpr_reduced_eqop2_ -- Wrap up reduction of EQ and NE operators
10420
10421 reduced = ffeexpr_reduced_eqop2_(reduced,l,op,r);
10422
10423 Makes sure the left and right arguments for reduced have basictype of
10424 INTEGER, REAL, COMPLEX, or CHARACTER. Determine common basictype and
10425 size for reduction. If both left
10426 and right arguments have where of CONSTANT, assign where CONSTANT to
10427 reduced, else assign where FLEETING. Create CONVERT ops for args where
10428 needed. Convert typeless
10429 constants to the desired type/size explicitly.
10430
10431 If these requirements cannot be met, generate error message. */
10432
10433 static ffebld
ffeexpr_reduced_eqop2_(ffebld reduced,ffeexprExpr_ l,ffeexprExpr_ op,ffeexprExpr_ r)10434 ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10435 ffeexprExpr_ r)
10436 {
10437 ffeinfo linfo, rinfo, ninfo;
10438 ffeinfoBasictype lbt, rbt, nbt;
10439 ffeinfoKindtype lkt, rkt, nkt;
10440 ffeinfoRank lrk, rrk;
10441 ffeinfoKind lkd, rkd;
10442 ffeinfoWhere lwh, rwh, nwh;
10443 ffetargetCharacterSize lsz, rsz;
10444
10445 linfo = ffebld_info (ffebld_left (reduced));
10446 lbt = ffeinfo_basictype (linfo);
10447 lkt = ffeinfo_kindtype (linfo);
10448 lrk = ffeinfo_rank (linfo);
10449 lkd = ffeinfo_kind (linfo);
10450 lwh = ffeinfo_where (linfo);
10451 lsz = ffebld_size_known (ffebld_left (reduced));
10452
10453 rinfo = ffebld_info (ffebld_right (reduced));
10454 rbt = ffeinfo_basictype (rinfo);
10455 rkt = ffeinfo_kindtype (rinfo);
10456 rrk = ffeinfo_rank (rinfo);
10457 rkd = ffeinfo_kind (rinfo);
10458 rwh = ffeinfo_where (rinfo);
10459 rsz = ffebld_size_known (ffebld_right (reduced));
10460
10461 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10462
10463 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10464 || (nbt == FFEINFO_basictypeCOMPLEX) || (nbt == FFEINFO_basictypeCHARACTER))
10465 && (lrk == 0) && (rrk == 0))
10466 {
10467 switch (lwh)
10468 {
10469 case FFEINFO_whereCONSTANT:
10470 switch (rwh)
10471 {
10472 case FFEINFO_whereCONSTANT:
10473 nwh = FFEINFO_whereCONSTANT;
10474 break;
10475
10476 case FFEINFO_whereIMMEDIATE:
10477 nwh = FFEINFO_whereIMMEDIATE;
10478 break;
10479
10480 default:
10481 nwh = FFEINFO_whereFLEETING;
10482 break;
10483 }
10484 break;
10485
10486 case FFEINFO_whereIMMEDIATE:
10487 switch (rwh)
10488 {
10489 case FFEINFO_whereCONSTANT:
10490 case FFEINFO_whereIMMEDIATE:
10491 nwh = FFEINFO_whereIMMEDIATE;
10492 break;
10493
10494 default:
10495 nwh = FFEINFO_whereFLEETING;
10496 break;
10497 }
10498 break;
10499
10500 default:
10501 nwh = FFEINFO_whereFLEETING;
10502 break;
10503 }
10504
10505 if ((lsz != FFETARGET_charactersizeNONE)
10506 && (rsz != FFETARGET_charactersizeNONE))
10507 lsz = rsz = (lsz > rsz) ? lsz : rsz;
10508
10509 ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
10510 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
10511 ffebld_set_info (reduced, ninfo);
10512 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10513 l->token, op->token, nbt, nkt, 0, lsz,
10514 FFEEXPR_contextLET));
10515 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10516 r->token, op->token, nbt, nkt, 0, rsz,
10517 FFEEXPR_contextLET));
10518 return reduced;
10519 }
10520
10521 if ((lbt == FFEINFO_basictypeLOGICAL)
10522 && (rbt == FFEINFO_basictypeLOGICAL))
10523 {
10524 /* xgettext:no-c-format */
10525 if (ffebad_start_msg ("Use .EQV./.NEQV. instead of .EQ./.NE. at %0 for LOGICAL operands at %1 and %2",
10526 FFEBAD_severityFATAL))
10527 {
10528 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10529 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10530 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10531 ffebad_finish ();
10532 }
10533 }
10534 else if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10535 && (lbt != FFEINFO_basictypeCOMPLEX) && (lbt != FFEINFO_basictypeCHARACTER))
10536 {
10537 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10538 && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
10539 {
10540 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10541 && ffebad_start (FFEBAD_EQOP_ARGS_TYPE))
10542 {
10543 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10544 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10545 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10546 ffebad_finish ();
10547 }
10548 }
10549 else
10550 {
10551 if ((lbt != FFEINFO_basictypeANY)
10552 && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
10553 {
10554 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10555 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10556 ffebad_finish ();
10557 }
10558 }
10559 }
10560 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10561 && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
10562 {
10563 if ((rbt != FFEINFO_basictypeANY)
10564 && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
10565 {
10566 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10567 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10568 ffebad_finish ();
10569 }
10570 }
10571 else if (lrk != 0)
10572 {
10573 if ((lkd != FFEINFO_kindANY)
10574 && ffebad_start (FFEBAD_EQOP_ARG_KIND))
10575 {
10576 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10577 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10578 ffebad_string ("an array");
10579 ffebad_finish ();
10580 }
10581 }
10582 else
10583 {
10584 if ((rkd != FFEINFO_kindANY)
10585 && ffebad_start (FFEBAD_EQOP_ARG_KIND))
10586 {
10587 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10588 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10589 ffebad_string ("an array");
10590 ffebad_finish ();
10591 }
10592 }
10593
10594 reduced = ffebld_new_any ();
10595 ffebld_set_info (reduced, ffeinfo_new_any ());
10596 return reduced;
10597 }
10598
10599 /* ffeexpr_reduced_math1_ -- Wrap up reduction of + - unary operators
10600
10601 reduced = ffeexpr_reduced_math1_(reduced,op,r);
10602
10603 Makes sure the argument for reduced has basictype of
10604 INTEGER, REAL, or COMPLEX. If the argument has where of CONSTANT,
10605 assign where CONSTANT to
10606 reduced, else assign where FLEETING.
10607
10608 If these requirements cannot be met, generate error message. */
10609
10610 static ffebld
ffeexpr_reduced_math1_(ffebld reduced,ffeexprExpr_ op,ffeexprExpr_ r)10611 ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10612 {
10613 ffeinfo rinfo, ninfo;
10614 ffeinfoBasictype rbt;
10615 ffeinfoKindtype rkt;
10616 ffeinfoRank rrk;
10617 ffeinfoKind rkd;
10618 ffeinfoWhere rwh, nwh;
10619
10620 rinfo = ffebld_info (ffebld_left (reduced));
10621 rbt = ffeinfo_basictype (rinfo);
10622 rkt = ffeinfo_kindtype (rinfo);
10623 rrk = ffeinfo_rank (rinfo);
10624 rkd = ffeinfo_kind (rinfo);
10625 rwh = ffeinfo_where (rinfo);
10626
10627 if (((rbt == FFEINFO_basictypeINTEGER) || (rbt == FFEINFO_basictypeREAL)
10628 || (rbt == FFEINFO_basictypeCOMPLEX)) && (rrk == 0))
10629 {
10630 switch (rwh)
10631 {
10632 case FFEINFO_whereCONSTANT:
10633 nwh = FFEINFO_whereCONSTANT;
10634 break;
10635
10636 case FFEINFO_whereIMMEDIATE:
10637 nwh = FFEINFO_whereIMMEDIATE;
10638 break;
10639
10640 default:
10641 nwh = FFEINFO_whereFLEETING;
10642 break;
10643 }
10644
10645 ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
10646 FFETARGET_charactersizeNONE);
10647 ffebld_set_info (reduced, ninfo);
10648 return reduced;
10649 }
10650
10651 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10652 && (rbt != FFEINFO_basictypeCOMPLEX))
10653 {
10654 if ((rbt != FFEINFO_basictypeANY)
10655 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10656 {
10657 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10658 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10659 ffebad_finish ();
10660 }
10661 }
10662 else
10663 {
10664 if ((rkd != FFEINFO_kindANY)
10665 && ffebad_start (FFEBAD_MATH_ARG_KIND))
10666 {
10667 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10668 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10669 ffebad_string ("an array");
10670 ffebad_finish ();
10671 }
10672 }
10673
10674 reduced = ffebld_new_any ();
10675 ffebld_set_info (reduced, ffeinfo_new_any ());
10676 return reduced;
10677 }
10678
10679 /* ffeexpr_reduced_math2_ -- Wrap up reduction of + - * / operators
10680
10681 reduced = ffeexpr_reduced_math2_(reduced,l,op,r);
10682
10683 Makes sure the left and right arguments for reduced have basictype of
10684 INTEGER, REAL, or COMPLEX. Determine common basictype and
10685 size for reduction (flag expression for combined hollerith/typeless
10686 situations for later determination of effective basictype). If both left
10687 and right arguments have where of CONSTANT, assign where CONSTANT to
10688 reduced, else assign where FLEETING. Create CONVERT ops for args where
10689 needed. Convert typeless
10690 constants to the desired type/size explicitly.
10691
10692 If these requirements cannot be met, generate error message. */
10693
10694 static ffebld
ffeexpr_reduced_math2_(ffebld reduced,ffeexprExpr_ l,ffeexprExpr_ op,ffeexprExpr_ r)10695 ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10696 ffeexprExpr_ r)
10697 {
10698 ffeinfo linfo, rinfo, ninfo;
10699 ffeinfoBasictype lbt, rbt, nbt;
10700 ffeinfoKindtype lkt, rkt, nkt;
10701 ffeinfoRank lrk, rrk;
10702 ffeinfoKind lkd, rkd;
10703 ffeinfoWhere lwh, rwh, nwh;
10704
10705 linfo = ffebld_info (ffebld_left (reduced));
10706 lbt = ffeinfo_basictype (linfo);
10707 lkt = ffeinfo_kindtype (linfo);
10708 lrk = ffeinfo_rank (linfo);
10709 lkd = ffeinfo_kind (linfo);
10710 lwh = ffeinfo_where (linfo);
10711
10712 rinfo = ffebld_info (ffebld_right (reduced));
10713 rbt = ffeinfo_basictype (rinfo);
10714 rkt = ffeinfo_kindtype (rinfo);
10715 rrk = ffeinfo_rank (rinfo);
10716 rkd = ffeinfo_kind (rinfo);
10717 rwh = ffeinfo_where (rinfo);
10718
10719 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10720
10721 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10722 || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
10723 {
10724 switch (lwh)
10725 {
10726 case FFEINFO_whereCONSTANT:
10727 switch (rwh)
10728 {
10729 case FFEINFO_whereCONSTANT:
10730 nwh = FFEINFO_whereCONSTANT;
10731 break;
10732
10733 case FFEINFO_whereIMMEDIATE:
10734 nwh = FFEINFO_whereIMMEDIATE;
10735 break;
10736
10737 default:
10738 nwh = FFEINFO_whereFLEETING;
10739 break;
10740 }
10741 break;
10742
10743 case FFEINFO_whereIMMEDIATE:
10744 switch (rwh)
10745 {
10746 case FFEINFO_whereCONSTANT:
10747 case FFEINFO_whereIMMEDIATE:
10748 nwh = FFEINFO_whereIMMEDIATE;
10749 break;
10750
10751 default:
10752 nwh = FFEINFO_whereFLEETING;
10753 break;
10754 }
10755 break;
10756
10757 default:
10758 nwh = FFEINFO_whereFLEETING;
10759 break;
10760 }
10761
10762 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10763 FFETARGET_charactersizeNONE);
10764 ffebld_set_info (reduced, ninfo);
10765 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10766 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10767 FFEEXPR_contextLET));
10768 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10769 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10770 FFEEXPR_contextLET));
10771 return reduced;
10772 }
10773
10774 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10775 && (lbt != FFEINFO_basictypeCOMPLEX))
10776 {
10777 if ((rbt != FFEINFO_basictypeINTEGER)
10778 && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
10779 {
10780 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10781 && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
10782 {
10783 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10784 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10785 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10786 ffebad_finish ();
10787 }
10788 }
10789 else
10790 {
10791 if ((lbt != FFEINFO_basictypeANY)
10792 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10793 {
10794 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10795 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10796 ffebad_finish ();
10797 }
10798 }
10799 }
10800 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10801 && (rbt != FFEINFO_basictypeCOMPLEX))
10802 {
10803 if ((rbt != FFEINFO_basictypeANY)
10804 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10805 {
10806 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10807 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10808 ffebad_finish ();
10809 }
10810 }
10811 else if (lrk != 0)
10812 {
10813 if ((lkd != FFEINFO_kindANY)
10814 && ffebad_start (FFEBAD_MATH_ARG_KIND))
10815 {
10816 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10817 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10818 ffebad_string ("an array");
10819 ffebad_finish ();
10820 }
10821 }
10822 else
10823 {
10824 if ((rkd != FFEINFO_kindANY)
10825 && ffebad_start (FFEBAD_MATH_ARG_KIND))
10826 {
10827 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10828 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10829 ffebad_string ("an array");
10830 ffebad_finish ();
10831 }
10832 }
10833
10834 reduced = ffebld_new_any ();
10835 ffebld_set_info (reduced, ffeinfo_new_any ());
10836 return reduced;
10837 }
10838
10839 /* ffeexpr_reduced_power_ -- Wrap up reduction of ** operator
10840
10841 reduced = ffeexpr_reduced_power_(reduced,l,op,r);
10842
10843 Makes sure the left and right arguments for reduced have basictype of
10844 INTEGER, REAL, or COMPLEX. Determine common basictype and
10845 size for reduction (flag expression for combined hollerith/typeless
10846 situations for later determination of effective basictype). If both left
10847 and right arguments have where of CONSTANT, assign where CONSTANT to
10848 reduced, else assign where FLEETING. Create CONVERT ops for args where
10849 needed. Note that real**int or complex**int
10850 comes out as int = real**int etc with no conversions.
10851
10852 If these requirements cannot be met, generate error message using the
10853 info in l, op, and r arguments and assign basictype, size, kind, and where
10854 of ANY. */
10855
10856 static ffebld
ffeexpr_reduced_power_(ffebld reduced,ffeexprExpr_ l,ffeexprExpr_ op,ffeexprExpr_ r)10857 ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10858 ffeexprExpr_ r)
10859 {
10860 ffeinfo linfo, rinfo, ninfo;
10861 ffeinfoBasictype lbt, rbt, nbt;
10862 ffeinfoKindtype lkt, rkt, nkt;
10863 ffeinfoRank lrk, rrk;
10864 ffeinfoKind lkd, rkd;
10865 ffeinfoWhere lwh, rwh, nwh;
10866
10867 linfo = ffebld_info (ffebld_left (reduced));
10868 lbt = ffeinfo_basictype (linfo);
10869 lkt = ffeinfo_kindtype (linfo);
10870 lrk = ffeinfo_rank (linfo);
10871 lkd = ffeinfo_kind (linfo);
10872 lwh = ffeinfo_where (linfo);
10873
10874 rinfo = ffebld_info (ffebld_right (reduced));
10875 rbt = ffeinfo_basictype (rinfo);
10876 rkt = ffeinfo_kindtype (rinfo);
10877 rrk = ffeinfo_rank (rinfo);
10878 rkd = ffeinfo_kind (rinfo);
10879 rwh = ffeinfo_where (rinfo);
10880
10881 if ((rbt == FFEINFO_basictypeINTEGER)
10882 && ((lbt == FFEINFO_basictypeREAL)
10883 || (lbt == FFEINFO_basictypeCOMPLEX)))
10884 {
10885 nbt = lbt;
10886 nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDEFAULT);
10887 if (nkt != FFEINFO_kindtypeREALDEFAULT)
10888 {
10889 nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDOUBLE);
10890 if (nkt != FFEINFO_kindtypeREALDOUBLE)
10891 nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */
10892 }
10893 if (rkt == FFEINFO_kindtypeINTEGER4)
10894 {
10895 /* xgettext:no-c-format */
10896 ffebad_start_msg ("Unsupported operand for ** at %1 -- converting to default INTEGER",
10897 FFEBAD_severityWARNING);
10898 ffebad_here (0, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10899 ffebad_finish ();
10900 }
10901 if (rkt != FFEINFO_kindtypeINTEGERDEFAULT)
10902 {
10903 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10904 r->token, op->token,
10905 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0,
10906 FFETARGET_charactersizeNONE,
10907 FFEEXPR_contextLET));
10908 rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10909 }
10910 }
10911 else
10912 {
10913 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10914
10915 #if 0 /* INTEGER4**INTEGER4 works now. */
10916 if ((nbt == FFEINFO_basictypeINTEGER)
10917 && (nkt != FFEINFO_kindtypeINTEGERDEFAULT))
10918 nkt = FFEINFO_kindtypeINTEGERDEFAULT; /* Highest kt we can power! */
10919 #endif
10920 if (((nbt == FFEINFO_basictypeREAL)
10921 || (nbt == FFEINFO_basictypeCOMPLEX))
10922 && (nkt != FFEINFO_kindtypeREALDEFAULT))
10923 {
10924 nkt = ffeinfo_kindtype_max (nbt, nkt, FFEINFO_kindtypeREALDOUBLE);
10925 if (nkt != FFEINFO_kindtypeREALDOUBLE)
10926 nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */
10927 }
10928 /* else Gonna turn into an error below. */
10929 }
10930
10931 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10932 || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
10933 {
10934 switch (lwh)
10935 {
10936 case FFEINFO_whereCONSTANT:
10937 switch (rwh)
10938 {
10939 case FFEINFO_whereCONSTANT:
10940 nwh = FFEINFO_whereCONSTANT;
10941 break;
10942
10943 case FFEINFO_whereIMMEDIATE:
10944 nwh = FFEINFO_whereIMMEDIATE;
10945 break;
10946
10947 default:
10948 nwh = FFEINFO_whereFLEETING;
10949 break;
10950 }
10951 break;
10952
10953 case FFEINFO_whereIMMEDIATE:
10954 switch (rwh)
10955 {
10956 case FFEINFO_whereCONSTANT:
10957 case FFEINFO_whereIMMEDIATE:
10958 nwh = FFEINFO_whereIMMEDIATE;
10959 break;
10960
10961 default:
10962 nwh = FFEINFO_whereFLEETING;
10963 break;
10964 }
10965 break;
10966
10967 default:
10968 nwh = FFEINFO_whereFLEETING;
10969 break;
10970 }
10971
10972 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10973 FFETARGET_charactersizeNONE);
10974 ffebld_set_info (reduced, ninfo);
10975 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10976 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10977 FFEEXPR_contextLET));
10978 if (rbt != FFEINFO_basictypeINTEGER)
10979 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10980 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10981 FFEEXPR_contextLET));
10982 return reduced;
10983 }
10984
10985 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10986 && (lbt != FFEINFO_basictypeCOMPLEX))
10987 {
10988 if ((rbt != FFEINFO_basictypeINTEGER)
10989 && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
10990 {
10991 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10992 && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
10993 {
10994 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10995 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10996 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10997 ffebad_finish ();
10998 }
10999 }
11000 else
11001 {
11002 if ((lbt != FFEINFO_basictypeANY)
11003 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
11004 {
11005 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11006 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11007 ffebad_finish ();
11008 }
11009 }
11010 }
11011 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
11012 && (rbt != FFEINFO_basictypeCOMPLEX))
11013 {
11014 if ((rbt != FFEINFO_basictypeANY)
11015 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
11016 {
11017 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11018 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11019 ffebad_finish ();
11020 }
11021 }
11022 else if (lrk != 0)
11023 {
11024 if ((lkd != FFEINFO_kindANY)
11025 && ffebad_start (FFEBAD_MATH_ARG_KIND))
11026 {
11027 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11028 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11029 ffebad_string ("an array");
11030 ffebad_finish ();
11031 }
11032 }
11033 else
11034 {
11035 if ((rkd != FFEINFO_kindANY)
11036 && ffebad_start (FFEBAD_MATH_ARG_KIND))
11037 {
11038 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11039 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11040 ffebad_string ("an array");
11041 ffebad_finish ();
11042 }
11043 }
11044
11045 reduced = ffebld_new_any ();
11046 ffebld_set_info (reduced, ffeinfo_new_any ());
11047 return reduced;
11048 }
11049
11050 /* ffeexpr_reduced_relop2_ -- Wrap up reduction of LT, LE, GE, and GT operators
11051
11052 reduced = ffeexpr_reduced_relop2_(reduced,l,op,r);
11053
11054 Makes sure the left and right arguments for reduced have basictype of
11055 INTEGER, REAL, or CHARACTER. Determine common basictype and
11056 size for reduction. If both left
11057 and right arguments have where of CONSTANT, assign where CONSTANT to
11058 reduced, else assign where FLEETING. Create CONVERT ops for args where
11059 needed. Convert typeless
11060 constants to the desired type/size explicitly.
11061
11062 If these requirements cannot be met, generate error message. */
11063
11064 static ffebld
ffeexpr_reduced_relop2_(ffebld reduced,ffeexprExpr_ l,ffeexprExpr_ op,ffeexprExpr_ r)11065 ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
11066 ffeexprExpr_ r)
11067 {
11068 ffeinfo linfo, rinfo, ninfo;
11069 ffeinfoBasictype lbt, rbt, nbt;
11070 ffeinfoKindtype lkt, rkt, nkt;
11071 ffeinfoRank lrk, rrk;
11072 ffeinfoKind lkd, rkd;
11073 ffeinfoWhere lwh, rwh, nwh;
11074 ffetargetCharacterSize lsz, rsz;
11075
11076 linfo = ffebld_info (ffebld_left (reduced));
11077 lbt = ffeinfo_basictype (linfo);
11078 lkt = ffeinfo_kindtype (linfo);
11079 lrk = ffeinfo_rank (linfo);
11080 lkd = ffeinfo_kind (linfo);
11081 lwh = ffeinfo_where (linfo);
11082 lsz = ffebld_size_known (ffebld_left (reduced));
11083
11084 rinfo = ffebld_info (ffebld_right (reduced));
11085 rbt = ffeinfo_basictype (rinfo);
11086 rkt = ffeinfo_kindtype (rinfo);
11087 rrk = ffeinfo_rank (rinfo);
11088 rkd = ffeinfo_kind (rinfo);
11089 rwh = ffeinfo_where (rinfo);
11090 rsz = ffebld_size_known (ffebld_right (reduced));
11091
11092 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
11093
11094 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
11095 || (nbt == FFEINFO_basictypeCHARACTER))
11096 && (lrk == 0) && (rrk == 0))
11097 {
11098 switch (lwh)
11099 {
11100 case FFEINFO_whereCONSTANT:
11101 switch (rwh)
11102 {
11103 case FFEINFO_whereCONSTANT:
11104 nwh = FFEINFO_whereCONSTANT;
11105 break;
11106
11107 case FFEINFO_whereIMMEDIATE:
11108 nwh = FFEINFO_whereIMMEDIATE;
11109 break;
11110
11111 default:
11112 nwh = FFEINFO_whereFLEETING;
11113 break;
11114 }
11115 break;
11116
11117 case FFEINFO_whereIMMEDIATE:
11118 switch (rwh)
11119 {
11120 case FFEINFO_whereCONSTANT:
11121 case FFEINFO_whereIMMEDIATE:
11122 nwh = FFEINFO_whereIMMEDIATE;
11123 break;
11124
11125 default:
11126 nwh = FFEINFO_whereFLEETING;
11127 break;
11128 }
11129 break;
11130
11131 default:
11132 nwh = FFEINFO_whereFLEETING;
11133 break;
11134 }
11135
11136 if ((lsz != FFETARGET_charactersizeNONE)
11137 && (rsz != FFETARGET_charactersizeNONE))
11138 lsz = rsz = (lsz > rsz) ? lsz : rsz;
11139
11140 ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
11141 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
11142 ffebld_set_info (reduced, ninfo);
11143 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11144 l->token, op->token, nbt, nkt, 0, lsz,
11145 FFEEXPR_contextLET));
11146 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11147 r->token, op->token, nbt, nkt, 0, rsz,
11148 FFEEXPR_contextLET));
11149 return reduced;
11150 }
11151
11152 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
11153 && (lbt != FFEINFO_basictypeCHARACTER))
11154 {
11155 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
11156 && (rbt != FFEINFO_basictypeCHARACTER))
11157 {
11158 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
11159 && ffebad_start (FFEBAD_RELOP_ARGS_TYPE))
11160 {
11161 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11162 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11163 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11164 ffebad_finish ();
11165 }
11166 }
11167 else
11168 {
11169 if ((lbt != FFEINFO_basictypeANY)
11170 && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
11171 {
11172 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11173 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11174 ffebad_finish ();
11175 }
11176 }
11177 }
11178 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
11179 && (rbt != FFEINFO_basictypeCHARACTER))
11180 {
11181 if ((rbt != FFEINFO_basictypeANY)
11182 && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
11183 {
11184 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11185 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11186 ffebad_finish ();
11187 }
11188 }
11189 else if (lrk != 0)
11190 {
11191 if ((lkd != FFEINFO_kindANY)
11192 && ffebad_start (FFEBAD_RELOP_ARG_KIND))
11193 {
11194 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11195 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11196 ffebad_string ("an array");
11197 ffebad_finish ();
11198 }
11199 }
11200 else
11201 {
11202 if ((rkd != FFEINFO_kindANY)
11203 && ffebad_start (FFEBAD_RELOP_ARG_KIND))
11204 {
11205 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11206 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11207 ffebad_string ("an array");
11208 ffebad_finish ();
11209 }
11210 }
11211
11212 reduced = ffebld_new_any ();
11213 ffebld_set_info (reduced, ffeinfo_new_any ());
11214 return reduced;
11215 }
11216
11217 /* ffeexpr_reduced_ugly1_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
11218
11219 reduced = ffeexpr_reduced_ugly1_(reduced,op,r);
11220
11221 Sigh. */
11222
11223 static ffebld
ffeexpr_reduced_ugly1_(ffebld reduced,ffeexprExpr_ op,ffeexprExpr_ r)11224 ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
11225 {
11226 ffeinfo rinfo;
11227 ffeinfoBasictype rbt;
11228 ffeinfoKindtype rkt;
11229 ffeinfoRank rrk;
11230 ffeinfoKind rkd;
11231 ffeinfoWhere rwh;
11232
11233 rinfo = ffebld_info (ffebld_left (reduced));
11234 rbt = ffeinfo_basictype (rinfo);
11235 rkt = ffeinfo_kindtype (rinfo);
11236 rrk = ffeinfo_rank (rinfo);
11237 rkd = ffeinfo_kind (rinfo);
11238 rwh = ffeinfo_where (rinfo);
11239
11240 if ((rbt == FFEINFO_basictypeTYPELESS)
11241 || (rbt == FFEINFO_basictypeHOLLERITH))
11242 {
11243 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11244 r->token, op->token, FFEINFO_basictypeINTEGER,
11245 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11246 FFETARGET_charactersizeNONE,
11247 FFEEXPR_contextLET));
11248 rinfo = ffebld_info (ffebld_left (reduced));
11249 rbt = FFEINFO_basictypeINTEGER;
11250 rkt = FFEINFO_kindtypeINTEGERDEFAULT;
11251 rrk = 0;
11252 rkd = FFEINFO_kindENTITY;
11253 rwh = ffeinfo_where (rinfo);
11254 }
11255
11256 if (rbt == FFEINFO_basictypeLOGICAL)
11257 {
11258 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11259 r->token, op->token, FFEINFO_basictypeINTEGER,
11260 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11261 FFETARGET_charactersizeNONE,
11262 FFEEXPR_contextLET));
11263 }
11264
11265 return reduced;
11266 }
11267
11268 /* ffeexpr_reduced_ugly1log_ -- Deal with TYPELESS and HOLLERITH
11269
11270 reduced = ffeexpr_reduced_ugly1log_(reduced,op,r);
11271
11272 Sigh. */
11273
11274 static ffebld
ffeexpr_reduced_ugly1log_(ffebld reduced,ffeexprExpr_ op,ffeexprExpr_ r)11275 ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
11276 {
11277 ffeinfo rinfo;
11278 ffeinfoBasictype rbt;
11279 ffeinfoKindtype rkt;
11280 ffeinfoRank rrk;
11281 ffeinfoKind rkd;
11282 ffeinfoWhere rwh;
11283
11284 rinfo = ffebld_info (ffebld_left (reduced));
11285 rbt = ffeinfo_basictype (rinfo);
11286 rkt = ffeinfo_kindtype (rinfo);
11287 rrk = ffeinfo_rank (rinfo);
11288 rkd = ffeinfo_kind (rinfo);
11289 rwh = ffeinfo_where (rinfo);
11290
11291 if ((rbt == FFEINFO_basictypeTYPELESS)
11292 || (rbt == FFEINFO_basictypeHOLLERITH))
11293 {
11294 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11295 r->token, op->token, FFEINFO_basictypeLOGICAL, 0,
11296 FFEINFO_kindtypeLOGICALDEFAULT,
11297 FFETARGET_charactersizeNONE,
11298 FFEEXPR_contextLET));
11299 rinfo = ffebld_info (ffebld_left (reduced));
11300 rbt = FFEINFO_basictypeLOGICAL;
11301 rkt = FFEINFO_kindtypeLOGICALDEFAULT;
11302 rrk = 0;
11303 rkd = FFEINFO_kindENTITY;
11304 rwh = ffeinfo_where (rinfo);
11305 }
11306
11307 return reduced;
11308 }
11309
11310 /* ffeexpr_reduced_ugly2_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
11311
11312 reduced = ffeexpr_reduced_ugly2_(reduced,l,op,r);
11313
11314 Sigh. */
11315
11316 static ffebld
ffeexpr_reduced_ugly2_(ffebld reduced,ffeexprExpr_ l,ffeexprExpr_ op,ffeexprExpr_ r)11317 ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
11318 ffeexprExpr_ r)
11319 {
11320 ffeinfo linfo, rinfo;
11321 ffeinfoBasictype lbt, rbt;
11322 ffeinfoKindtype lkt, rkt;
11323 ffeinfoRank lrk, rrk;
11324 ffeinfoKind lkd, rkd;
11325 ffeinfoWhere lwh, rwh;
11326
11327 linfo = ffebld_info (ffebld_left (reduced));
11328 lbt = ffeinfo_basictype (linfo);
11329 lkt = ffeinfo_kindtype (linfo);
11330 lrk = ffeinfo_rank (linfo);
11331 lkd = ffeinfo_kind (linfo);
11332 lwh = ffeinfo_where (linfo);
11333
11334 rinfo = ffebld_info (ffebld_right (reduced));
11335 rbt = ffeinfo_basictype (rinfo);
11336 rkt = ffeinfo_kindtype (rinfo);
11337 rrk = ffeinfo_rank (rinfo);
11338 rkd = ffeinfo_kind (rinfo);
11339 rwh = ffeinfo_where (rinfo);
11340
11341 if ((lbt == FFEINFO_basictypeTYPELESS)
11342 || (lbt == FFEINFO_basictypeHOLLERITH))
11343 {
11344 if ((rbt == FFEINFO_basictypeTYPELESS)
11345 || (rbt == FFEINFO_basictypeHOLLERITH))
11346 {
11347 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11348 l->token, op->token, FFEINFO_basictypeINTEGER,
11349 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11350 FFETARGET_charactersizeNONE,
11351 FFEEXPR_contextLET));
11352 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11353 r->token, op->token, FFEINFO_basictypeINTEGER, 0,
11354 FFEINFO_kindtypeINTEGERDEFAULT,
11355 FFETARGET_charactersizeNONE,
11356 FFEEXPR_contextLET));
11357 linfo = ffebld_info (ffebld_left (reduced));
11358 rinfo = ffebld_info (ffebld_right (reduced));
11359 lbt = rbt = FFEINFO_basictypeINTEGER;
11360 lkt = rkt = FFEINFO_kindtypeINTEGERDEFAULT;
11361 lrk = rrk = 0;
11362 lkd = rkd = FFEINFO_kindENTITY;
11363 lwh = ffeinfo_where (linfo);
11364 rwh = ffeinfo_where (rinfo);
11365 }
11366 else
11367 {
11368 ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
11369 l->token, ffebld_right (reduced), r->token,
11370 FFEEXPR_contextLET));
11371 linfo = ffebld_info (ffebld_left (reduced));
11372 lbt = ffeinfo_basictype (linfo);
11373 lkt = ffeinfo_kindtype (linfo);
11374 lrk = ffeinfo_rank (linfo);
11375 lkd = ffeinfo_kind (linfo);
11376 lwh = ffeinfo_where (linfo);
11377 }
11378 }
11379 else
11380 {
11381 if ((rbt == FFEINFO_basictypeTYPELESS)
11382 || (rbt == FFEINFO_basictypeHOLLERITH))
11383 {
11384 ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
11385 r->token, ffebld_left (reduced), l->token,
11386 FFEEXPR_contextLET));
11387 rinfo = ffebld_info (ffebld_right (reduced));
11388 rbt = ffeinfo_basictype (rinfo);
11389 rkt = ffeinfo_kindtype (rinfo);
11390 rrk = ffeinfo_rank (rinfo);
11391 rkd = ffeinfo_kind (rinfo);
11392 rwh = ffeinfo_where (rinfo);
11393 }
11394 /* else Leave it alone. */
11395 }
11396
11397 if (lbt == FFEINFO_basictypeLOGICAL)
11398 {
11399 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11400 l->token, op->token, FFEINFO_basictypeINTEGER,
11401 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11402 FFETARGET_charactersizeNONE,
11403 FFEEXPR_contextLET));
11404 }
11405
11406 if (rbt == FFEINFO_basictypeLOGICAL)
11407 {
11408 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11409 r->token, op->token, FFEINFO_basictypeINTEGER,
11410 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11411 FFETARGET_charactersizeNONE,
11412 FFEEXPR_contextLET));
11413 }
11414
11415 return reduced;
11416 }
11417
11418 /* ffeexpr_reduced_ugly2log_ -- Deal with TYPELESS and HOLLERITH
11419
11420 reduced = ffeexpr_reduced_ugly2log_(reduced,l,op,r);
11421
11422 Sigh. */
11423
11424 static ffebld
ffeexpr_reduced_ugly2log_(ffebld reduced,ffeexprExpr_ l,ffeexprExpr_ op,ffeexprExpr_ r)11425 ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
11426 ffeexprExpr_ r)
11427 {
11428 ffeinfo linfo, rinfo;
11429 ffeinfoBasictype lbt, rbt;
11430 ffeinfoKindtype lkt, rkt;
11431 ffeinfoRank lrk, rrk;
11432 ffeinfoKind lkd, rkd;
11433 ffeinfoWhere lwh, rwh;
11434
11435 linfo = ffebld_info (ffebld_left (reduced));
11436 lbt = ffeinfo_basictype (linfo);
11437 lkt = ffeinfo_kindtype (linfo);
11438 lrk = ffeinfo_rank (linfo);
11439 lkd = ffeinfo_kind (linfo);
11440 lwh = ffeinfo_where (linfo);
11441
11442 rinfo = ffebld_info (ffebld_right (reduced));
11443 rbt = ffeinfo_basictype (rinfo);
11444 rkt = ffeinfo_kindtype (rinfo);
11445 rrk = ffeinfo_rank (rinfo);
11446 rkd = ffeinfo_kind (rinfo);
11447 rwh = ffeinfo_where (rinfo);
11448
11449 if ((lbt == FFEINFO_basictypeTYPELESS)
11450 || (lbt == FFEINFO_basictypeHOLLERITH))
11451 {
11452 if ((rbt == FFEINFO_basictypeTYPELESS)
11453 || (rbt == FFEINFO_basictypeHOLLERITH))
11454 {
11455 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11456 l->token, op->token, FFEINFO_basictypeLOGICAL,
11457 FFEINFO_kindtypeLOGICALDEFAULT, 0,
11458 FFETARGET_charactersizeNONE,
11459 FFEEXPR_contextLET));
11460 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11461 r->token, op->token, FFEINFO_basictypeLOGICAL,
11462 FFEINFO_kindtypeLOGICALDEFAULT, 0,
11463 FFETARGET_charactersizeNONE,
11464 FFEEXPR_contextLET));
11465 linfo = ffebld_info (ffebld_left (reduced));
11466 rinfo = ffebld_info (ffebld_right (reduced));
11467 lbt = rbt = FFEINFO_basictypeLOGICAL;
11468 lkt = rkt = FFEINFO_kindtypeLOGICALDEFAULT;
11469 lrk = rrk = 0;
11470 lkd = rkd = FFEINFO_kindENTITY;
11471 lwh = ffeinfo_where (linfo);
11472 rwh = ffeinfo_where (rinfo);
11473 }
11474 else
11475 {
11476 ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
11477 l->token, ffebld_right (reduced), r->token,
11478 FFEEXPR_contextLET));
11479 linfo = ffebld_info (ffebld_left (reduced));
11480 lbt = ffeinfo_basictype (linfo);
11481 lkt = ffeinfo_kindtype (linfo);
11482 lrk = ffeinfo_rank (linfo);
11483 lkd = ffeinfo_kind (linfo);
11484 lwh = ffeinfo_where (linfo);
11485 }
11486 }
11487 else
11488 {
11489 if ((rbt == FFEINFO_basictypeTYPELESS)
11490 || (rbt == FFEINFO_basictypeHOLLERITH))
11491 {
11492 ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
11493 r->token, ffebld_left (reduced), l->token,
11494 FFEEXPR_contextLET));
11495 rinfo = ffebld_info (ffebld_right (reduced));
11496 rbt = ffeinfo_basictype (rinfo);
11497 rkt = ffeinfo_kindtype (rinfo);
11498 rrk = ffeinfo_rank (rinfo);
11499 rkd = ffeinfo_kind (rinfo);
11500 rwh = ffeinfo_where (rinfo);
11501 }
11502 /* else Leave it alone. */
11503 }
11504
11505 return reduced;
11506 }
11507
11508 /* Fumble through tokens until a nonmatching CLOSE_PAREN, EOS, or SEMICOLON
11509 is found.
11510
11511 The idea is to process the tokens as they would be done by normal
11512 expression processing, with the key things being telling the lexer
11513 when hollerith/character constants are about to happen, until the
11514 true closing token is found. */
11515
11516 static ffelexHandler
ffeexpr_find_close_paren_(ffelexToken t,ffelexHandler after)11517 ffeexpr_find_close_paren_ (ffelexToken t,
11518 ffelexHandler after)
11519 {
11520 ffeexpr_find_.after = after;
11521 ffeexpr_find_.level = 1;
11522 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11523 }
11524
11525 static ffelexHandler
ffeexpr_nil_finished_(ffelexToken t)11526 ffeexpr_nil_finished_ (ffelexToken t)
11527 {
11528 switch (ffelex_token_type (t))
11529 {
11530 case FFELEX_typeCLOSE_PAREN:
11531 if (--ffeexpr_find_.level == 0)
11532 return (ffelexHandler) ffeexpr_find_.after;
11533 return (ffelexHandler) ffeexpr_nil_binary_;
11534
11535 case FFELEX_typeCOMMA:
11536 case FFELEX_typeCOLON:
11537 case FFELEX_typeEQUALS:
11538 case FFELEX_typePOINTS:
11539 return (ffelexHandler) ffeexpr_nil_rhs_;
11540
11541 default:
11542 if (--ffeexpr_find_.level == 0)
11543 return (ffelexHandler) ffeexpr_find_.after (t);
11544 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11545 }
11546 }
11547
11548 static ffelexHandler
ffeexpr_nil_rhs_(ffelexToken t)11549 ffeexpr_nil_rhs_ (ffelexToken t)
11550 {
11551 switch (ffelex_token_type (t))
11552 {
11553 case FFELEX_typeQUOTE:
11554 if (ffe_is_vxt ())
11555 return (ffelexHandler) ffeexpr_nil_quote_;
11556 ffelex_set_expecting_hollerith (-1, '\"',
11557 ffelex_token_where_line (t),
11558 ffelex_token_where_column (t));
11559 return (ffelexHandler) ffeexpr_nil_apostrophe_;
11560
11561 case FFELEX_typeAPOSTROPHE:
11562 ffelex_set_expecting_hollerith (-1, '\'',
11563 ffelex_token_where_line (t),
11564 ffelex_token_where_column (t));
11565 return (ffelexHandler) ffeexpr_nil_apostrophe_;
11566
11567 case FFELEX_typePERCENT:
11568 return (ffelexHandler) ffeexpr_nil_percent_;
11569
11570 case FFELEX_typeOPEN_PAREN:
11571 ++ffeexpr_find_.level;
11572 return (ffelexHandler) ffeexpr_nil_rhs_;
11573
11574 case FFELEX_typePLUS:
11575 case FFELEX_typeMINUS:
11576 return (ffelexHandler) ffeexpr_nil_rhs_;
11577
11578 case FFELEX_typePERIOD:
11579 return (ffelexHandler) ffeexpr_nil_period_;
11580
11581 case FFELEX_typeNUMBER:
11582 ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
11583 if (ffeexpr_hollerith_count_ > 0)
11584 ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
11585 '\0',
11586 ffelex_token_where_line (t),
11587 ffelex_token_where_column (t));
11588 return (ffelexHandler) ffeexpr_nil_number_;
11589
11590 case FFELEX_typeNAME:
11591 case FFELEX_typeNAMES:
11592 return (ffelexHandler) ffeexpr_nil_name_rhs_;
11593
11594 case FFELEX_typeASTERISK:
11595 case FFELEX_typeSLASH:
11596 case FFELEX_typePOWER:
11597 case FFELEX_typeCONCAT:
11598 case FFELEX_typeREL_EQ:
11599 case FFELEX_typeREL_NE:
11600 case FFELEX_typeREL_LE:
11601 case FFELEX_typeREL_GE:
11602 return (ffelexHandler) ffeexpr_nil_rhs_;
11603
11604 default:
11605 return (ffelexHandler) ffeexpr_nil_finished_ (t);
11606 }
11607 }
11608
11609 static ffelexHandler
ffeexpr_nil_period_(ffelexToken t)11610 ffeexpr_nil_period_ (ffelexToken t)
11611 {
11612 switch (ffelex_token_type (t))
11613 {
11614 case FFELEX_typeNAME:
11615 case FFELEX_typeNAMES:
11616 ffeexpr_current_dotdot_ = ffestr_other (t);
11617 switch (ffeexpr_current_dotdot_)
11618 {
11619 case FFESTR_otherNone:
11620 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11621
11622 case FFESTR_otherTRUE:
11623 case FFESTR_otherFALSE:
11624 case FFESTR_otherNOT:
11625 return (ffelexHandler) ffeexpr_nil_end_period_;
11626
11627 default:
11628 return (ffelexHandler) ffeexpr_nil_swallow_period_;
11629 }
11630 break; /* Nothing really reaches here. */
11631
11632 case FFELEX_typeNUMBER:
11633 return (ffelexHandler) ffeexpr_nil_real_;
11634
11635 default:
11636 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11637 }
11638 }
11639
11640 static ffelexHandler
ffeexpr_nil_end_period_(ffelexToken t)11641 ffeexpr_nil_end_period_ (ffelexToken t)
11642 {
11643 switch (ffeexpr_current_dotdot_)
11644 {
11645 case FFESTR_otherNOT:
11646 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11647 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11648 return (ffelexHandler) ffeexpr_nil_rhs_;
11649
11650 case FFESTR_otherTRUE:
11651 case FFESTR_otherFALSE:
11652 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11653 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11654 return (ffelexHandler) ffeexpr_nil_binary_;
11655
11656 default:
11657 assert ("Bad [nil] unary dotdot in ffeexpr_current_dotdot_" == NULL);
11658 exit (0);
11659 return NULL;
11660 }
11661 }
11662
11663 static ffelexHandler
ffeexpr_nil_swallow_period_(ffelexToken t)11664 ffeexpr_nil_swallow_period_ (ffelexToken t)
11665 {
11666 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11667 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11668 return (ffelexHandler) ffeexpr_nil_rhs_;
11669 }
11670
11671 static ffelexHandler
ffeexpr_nil_real_(ffelexToken t)11672 ffeexpr_nil_real_ (ffelexToken t)
11673 {
11674 char d;
11675 const char *p;
11676
11677 if (((ffelex_token_type (t) != FFELEX_typeNAME)
11678 && (ffelex_token_type (t) != FFELEX_typeNAMES))
11679 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11680 'D', 'd')
11681 || ffesrc_char_match_init (d, 'E', 'e')
11682 || ffesrc_char_match_init (d, 'Q', 'q')))
11683 && ffeexpr_isdigits_ (++p)))
11684 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11685
11686 if (*p == '\0')
11687 return (ffelexHandler) ffeexpr_nil_real_exponent_;
11688 return (ffelexHandler) ffeexpr_nil_binary_;
11689 }
11690
11691 static ffelexHandler
ffeexpr_nil_real_exponent_(ffelexToken t)11692 ffeexpr_nil_real_exponent_ (ffelexToken t)
11693 {
11694 if ((ffelex_token_type (t) != FFELEX_typePLUS)
11695 && (ffelex_token_type (t) != FFELEX_typeMINUS))
11696 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11697
11698 return (ffelexHandler) ffeexpr_nil_real_exp_sign_;
11699 }
11700
11701 static ffelexHandler
ffeexpr_nil_real_exp_sign_(ffelexToken t)11702 ffeexpr_nil_real_exp_sign_ (ffelexToken t)
11703 {
11704 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11705 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11706 return (ffelexHandler) ffeexpr_nil_binary_;
11707 }
11708
11709 static ffelexHandler
ffeexpr_nil_number_(ffelexToken t)11710 ffeexpr_nil_number_ (ffelexToken t)
11711 {
11712 char d;
11713 const char *p;
11714
11715 if (ffeexpr_hollerith_count_ > 0)
11716 ffelex_set_expecting_hollerith (0, '\0',
11717 ffewhere_line_unknown (),
11718 ffewhere_column_unknown ());
11719
11720 switch (ffelex_token_type (t))
11721 {
11722 case FFELEX_typeNAME:
11723 case FFELEX_typeNAMES:
11724 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11725 'D', 'd')
11726 || ffesrc_char_match_init (d, 'E', 'e')
11727 || ffesrc_char_match_init (d, 'Q', 'q'))
11728 && ffeexpr_isdigits_ (++p))
11729 {
11730 if (*p == '\0')
11731 {
11732 ffeexpr_find_.t = ffelex_token_use (t);
11733 return (ffelexHandler) ffeexpr_nil_number_exponent_;
11734 }
11735 return (ffelexHandler) ffeexpr_nil_binary_;
11736 }
11737 break;
11738
11739 case FFELEX_typePERIOD:
11740 ffeexpr_find_.t = ffelex_token_use (t);
11741 return (ffelexHandler) ffeexpr_nil_number_period_;
11742
11743 case FFELEX_typeHOLLERITH:
11744 return (ffelexHandler) ffeexpr_nil_binary_;
11745
11746 default:
11747 break;
11748 }
11749 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11750 }
11751
11752 /* Expects ffeexpr_find_.t. */
11753
11754 static ffelexHandler
ffeexpr_nil_number_exponent_(ffelexToken t)11755 ffeexpr_nil_number_exponent_ (ffelexToken t)
11756 {
11757 ffelexHandler nexthandler;
11758
11759 if ((ffelex_token_type (t) != FFELEX_typePLUS)
11760 && (ffelex_token_type (t) != FFELEX_typeMINUS))
11761 {
11762 nexthandler
11763 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
11764 ffelex_token_kill (ffeexpr_find_.t);
11765 return (ffelexHandler) (*nexthandler) (t);
11766 }
11767
11768 ffelex_token_kill (ffeexpr_find_.t);
11769 return (ffelexHandler) ffeexpr_nil_number_exp_sign_;
11770 }
11771
11772 static ffelexHandler
ffeexpr_nil_number_exp_sign_(ffelexToken t)11773 ffeexpr_nil_number_exp_sign_ (ffelexToken t)
11774 {
11775 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11776 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11777
11778 return (ffelexHandler) ffeexpr_nil_binary_;
11779 }
11780
11781 /* Expects ffeexpr_find_.t. */
11782
11783 static ffelexHandler
ffeexpr_nil_number_period_(ffelexToken t)11784 ffeexpr_nil_number_period_ (ffelexToken t)
11785 {
11786 ffelexHandler nexthandler;
11787 char d;
11788 const char *p;
11789
11790 switch (ffelex_token_type (t))
11791 {
11792 case FFELEX_typeNAME:
11793 case FFELEX_typeNAMES:
11794 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11795 'D', 'd')
11796 || ffesrc_char_match_init (d, 'E', 'e')
11797 || ffesrc_char_match_init (d, 'Q', 'q'))
11798 && ffeexpr_isdigits_ (++p))
11799 {
11800 if (*p == '\0')
11801 return (ffelexHandler) ffeexpr_nil_number_per_exp_;
11802 ffelex_token_kill (ffeexpr_find_.t);
11803 return (ffelexHandler) ffeexpr_nil_binary_;
11804 }
11805 nexthandler
11806 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
11807 ffelex_token_kill (ffeexpr_find_.t);
11808 return (ffelexHandler) (*nexthandler) (t);
11809
11810 case FFELEX_typeNUMBER:
11811 ffelex_token_kill (ffeexpr_find_.t);
11812 return (ffelexHandler) ffeexpr_nil_number_real_;
11813
11814 default:
11815 break;
11816 }
11817 ffelex_token_kill (ffeexpr_find_.t);
11818 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11819 }
11820
11821 /* Expects ffeexpr_find_.t. */
11822
11823 static ffelexHandler
ffeexpr_nil_number_per_exp_(ffelexToken t)11824 ffeexpr_nil_number_per_exp_ (ffelexToken t)
11825 {
11826 if ((ffelex_token_type (t) != FFELEX_typePLUS)
11827 && (ffelex_token_type (t) != FFELEX_typeMINUS))
11828 {
11829 ffelexHandler nexthandler;
11830
11831 nexthandler
11832 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
11833 ffelex_token_kill (ffeexpr_find_.t);
11834 return (ffelexHandler) (*nexthandler) (t);
11835 }
11836
11837 ffelex_token_kill (ffeexpr_find_.t);
11838 return (ffelexHandler) ffeexpr_nil_num_per_exp_sign_;
11839 }
11840
11841 static ffelexHandler
ffeexpr_nil_number_real_(ffelexToken t)11842 ffeexpr_nil_number_real_ (ffelexToken t)
11843 {
11844 char d;
11845 const char *p;
11846
11847 if (((ffelex_token_type (t) != FFELEX_typeNAME)
11848 && (ffelex_token_type (t) != FFELEX_typeNAMES))
11849 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11850 'D', 'd')
11851 || ffesrc_char_match_init (d, 'E', 'e')
11852 || ffesrc_char_match_init (d, 'Q', 'q')))
11853 && ffeexpr_isdigits_ (++p)))
11854 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11855
11856 if (*p == '\0')
11857 return (ffelexHandler) ffeexpr_nil_number_real_exp_;
11858
11859 return (ffelexHandler) ffeexpr_nil_binary_;
11860 }
11861
11862 static ffelexHandler
ffeexpr_nil_num_per_exp_sign_(ffelexToken t)11863 ffeexpr_nil_num_per_exp_sign_ (ffelexToken t)
11864 {
11865 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11866 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11867 return (ffelexHandler) ffeexpr_nil_binary_;
11868 }
11869
11870 static ffelexHandler
ffeexpr_nil_number_real_exp_(ffelexToken t)11871 ffeexpr_nil_number_real_exp_ (ffelexToken t)
11872 {
11873 if ((ffelex_token_type (t) != FFELEX_typePLUS)
11874 && (ffelex_token_type (t) != FFELEX_typeMINUS))
11875 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11876 return (ffelexHandler) ffeexpr_nil_num_real_exp_sn_;
11877 }
11878
11879 static ffelexHandler
ffeexpr_nil_num_real_exp_sn_(ffelexToken t)11880 ffeexpr_nil_num_real_exp_sn_ (ffelexToken t)
11881 {
11882 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11883 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11884 return (ffelexHandler) ffeexpr_nil_binary_;
11885 }
11886
11887 static ffelexHandler
ffeexpr_nil_binary_(ffelexToken t)11888 ffeexpr_nil_binary_ (ffelexToken t)
11889 {
11890 switch (ffelex_token_type (t))
11891 {
11892 case FFELEX_typePLUS:
11893 case FFELEX_typeMINUS:
11894 case FFELEX_typeASTERISK:
11895 case FFELEX_typeSLASH:
11896 case FFELEX_typePOWER:
11897 case FFELEX_typeCONCAT:
11898 case FFELEX_typeOPEN_ANGLE:
11899 case FFELEX_typeCLOSE_ANGLE:
11900 case FFELEX_typeREL_EQ:
11901 case FFELEX_typeREL_NE:
11902 case FFELEX_typeREL_GE:
11903 case FFELEX_typeREL_LE:
11904 return (ffelexHandler) ffeexpr_nil_rhs_;
11905
11906 case FFELEX_typePERIOD:
11907 return (ffelexHandler) ffeexpr_nil_binary_period_;
11908
11909 default:
11910 return (ffelexHandler) ffeexpr_nil_finished_ (t);
11911 }
11912 }
11913
11914 static ffelexHandler
ffeexpr_nil_binary_period_(ffelexToken t)11915 ffeexpr_nil_binary_period_ (ffelexToken t)
11916 {
11917 switch (ffelex_token_type (t))
11918 {
11919 case FFELEX_typeNAME:
11920 case FFELEX_typeNAMES:
11921 ffeexpr_current_dotdot_ = ffestr_other (t);
11922 switch (ffeexpr_current_dotdot_)
11923 {
11924 case FFESTR_otherTRUE:
11925 case FFESTR_otherFALSE:
11926 case FFESTR_otherNOT:
11927 return (ffelexHandler) ffeexpr_nil_binary_sw_per_;
11928
11929 default:
11930 return (ffelexHandler) ffeexpr_nil_binary_end_per_;
11931 }
11932 break; /* Nothing really reaches here. */
11933
11934 default:
11935 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11936 }
11937 }
11938
11939 static ffelexHandler
ffeexpr_nil_binary_end_per_(ffelexToken t)11940 ffeexpr_nil_binary_end_per_ (ffelexToken t)
11941 {
11942 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11943 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11944 return (ffelexHandler) ffeexpr_nil_rhs_;
11945 }
11946
11947 static ffelexHandler
ffeexpr_nil_binary_sw_per_(ffelexToken t)11948 ffeexpr_nil_binary_sw_per_ (ffelexToken t)
11949 {
11950 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11951 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11952 return (ffelexHandler) ffeexpr_nil_binary_;
11953 }
11954
11955 static ffelexHandler
ffeexpr_nil_quote_(ffelexToken t)11956 ffeexpr_nil_quote_ (ffelexToken t)
11957 {
11958 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11959 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11960 return (ffelexHandler) ffeexpr_nil_binary_;
11961 }
11962
11963 static ffelexHandler
ffeexpr_nil_apostrophe_(ffelexToken t)11964 ffeexpr_nil_apostrophe_ (ffelexToken t)
11965 {
11966 assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
11967 return (ffelexHandler) ffeexpr_nil_apos_char_;
11968 }
11969
11970 static ffelexHandler
ffeexpr_nil_apos_char_(ffelexToken t)11971 ffeexpr_nil_apos_char_ (ffelexToken t)
11972 {
11973 char c;
11974
11975 if ((ffelex_token_type (t) == FFELEX_typeNAME)
11976 || (ffelex_token_type (t) == FFELEX_typeNAMES))
11977 {
11978 if ((ffelex_token_length (t) == 1)
11979 && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]),
11980 'B', 'b')
11981 || ffesrc_char_match_init (c, 'O', 'o')
11982 || ffesrc_char_match_init (c, 'X', 'x')
11983 || ffesrc_char_match_init (c, 'Z', 'z')))
11984 return (ffelexHandler) ffeexpr_nil_binary_;
11985 }
11986 if ((ffelex_token_type (t) == FFELEX_typeNAME)
11987 || (ffelex_token_type (t) == FFELEX_typeNAMES))
11988 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11989 return (ffelexHandler) ffeexpr_nil_substrp_ (t);
11990 }
11991
11992 static ffelexHandler
ffeexpr_nil_name_rhs_(ffelexToken t)11993 ffeexpr_nil_name_rhs_ (ffelexToken t)
11994 {
11995 switch (ffelex_token_type (t))
11996 {
11997 case FFELEX_typeQUOTE:
11998 case FFELEX_typeAPOSTROPHE:
11999 ffelex_set_hexnum (TRUE);
12000 return (ffelexHandler) ffeexpr_nil_name_apos_;
12001
12002 case FFELEX_typeOPEN_PAREN:
12003 ++ffeexpr_find_.level;
12004 return (ffelexHandler) ffeexpr_nil_rhs_;
12005
12006 default:
12007 return (ffelexHandler) ffeexpr_nil_binary_ (t);
12008 }
12009 }
12010
12011 static ffelexHandler
ffeexpr_nil_name_apos_(ffelexToken t)12012 ffeexpr_nil_name_apos_ (ffelexToken t)
12013 {
12014 if (ffelex_token_type (t) == FFELEX_typeNAME)
12015 return (ffelexHandler) ffeexpr_nil_name_apos_name_;
12016 return (ffelexHandler) ffeexpr_nil_binary_ (t);
12017 }
12018
12019 static ffelexHandler
ffeexpr_nil_name_apos_name_(ffelexToken t)12020 ffeexpr_nil_name_apos_name_ (ffelexToken t)
12021 {
12022 switch (ffelex_token_type (t))
12023 {
12024 case FFELEX_typeAPOSTROPHE:
12025 case FFELEX_typeQUOTE:
12026 return (ffelexHandler) ffeexpr_nil_finished_;
12027
12028 default:
12029 return (ffelexHandler) ffeexpr_nil_finished_ (t);
12030 }
12031 }
12032
12033 static ffelexHandler
ffeexpr_nil_percent_(ffelexToken t)12034 ffeexpr_nil_percent_ (ffelexToken t)
12035 {
12036 switch (ffelex_token_type (t))
12037 {
12038 case FFELEX_typeNAME:
12039 case FFELEX_typeNAMES:
12040 ffeexpr_stack_->percent = ffeexpr_percent_ (t);
12041 ffeexpr_find_.t = ffelex_token_use (t);
12042 return (ffelexHandler) ffeexpr_nil_percent_name_;
12043
12044 default:
12045 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
12046 }
12047 }
12048
12049 /* Expects ffeexpr_find_.t. */
12050
12051 static ffelexHandler
ffeexpr_nil_percent_name_(ffelexToken t)12052 ffeexpr_nil_percent_name_ (ffelexToken t)
12053 {
12054 ffelexHandler nexthandler;
12055
12056 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
12057 {
12058 nexthandler
12059 = (ffelexHandler) ffeexpr_nil_rhs_ (ffeexpr_find_.t);
12060 ffelex_token_kill (ffeexpr_find_.t);
12061 return (ffelexHandler) (*nexthandler) (t);
12062 }
12063
12064 ffelex_token_kill (ffeexpr_find_.t);
12065 ++ffeexpr_find_.level;
12066 return (ffelexHandler) ffeexpr_nil_rhs_;
12067 }
12068
12069 static ffelexHandler
ffeexpr_nil_substrp_(ffelexToken t)12070 ffeexpr_nil_substrp_ (ffelexToken t)
12071 {
12072 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
12073 return (ffelexHandler) ffeexpr_nil_binary_ (t);
12074
12075 ++ffeexpr_find_.level;
12076 return (ffelexHandler) ffeexpr_nil_rhs_;
12077 }
12078
12079 /* ffeexpr_finished_ -- Reduce expression stack to one expr, finish
12080
12081 ffelexToken t;
12082 return ffeexpr_finished_(t);
12083
12084 Reduces expression stack to one (or zero) elements by repeatedly reducing
12085 the top operator on the stack (or, if the top element on the stack is
12086 itself an operator, issuing an error message and discarding it). Calls
12087 finishing routine with the expression, returning the ffelexHandler it
12088 returns to the caller. */
12089
12090 static ffelexHandler
ffeexpr_finished_(ffelexToken t)12091 ffeexpr_finished_ (ffelexToken t)
12092 {
12093 ffeexprExpr_ operand; /* This is B in -B or A+B. */
12094 ffebld expr;
12095 ffeexprCallback callback;
12096 ffeexprStack_ s;
12097 ffebldConstant constnode; /* For detecting magical number. */
12098 ffelexToken ft; /* Temporary copy of first token in
12099 expression. */
12100 ffelexHandler next;
12101 ffeinfo info;
12102 bool error = FALSE;
12103
12104 while (((operand = ffeexpr_stack_->exprstack) != NULL)
12105 && ((operand->previous != NULL) || (operand->type != FFEEXPR_exprtypeOPERAND_)))
12106 {
12107 if (operand->type == FFEEXPR_exprtypeOPERAND_)
12108 ffeexpr_reduce_ ();
12109 else
12110 {
12111 if (ffest_ffebad_start (FFEBAD_MISSING_OPERAND_FOR_OPERATOR))
12112 {
12113 ffebad_here (0, ffelex_token_where_line (t),
12114 ffelex_token_where_column (t));
12115 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
12116 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
12117 ffebad_finish ();
12118 }
12119 ffeexpr_stack_->exprstack = operand->previous; /* Pop the useless
12120 operator. */
12121 ffeexpr_expr_kill_ (operand);
12122 }
12123 }
12124
12125 assert ((operand == NULL) || (operand->previous == NULL));
12126
12127 ffebld_pool_pop ();
12128 if (operand == NULL)
12129 expr = NULL;
12130 else
12131 {
12132 expr = operand->u.operand;
12133 info = ffebld_info (expr);
12134 if ((ffebld_op (expr) == FFEBLD_opCONTER)
12135 && (ffebld_conter_orig (expr) == NULL)
12136 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
12137 {
12138 ffetarget_integer_bad_magical (operand->token);
12139 }
12140 ffeexpr_expr_kill_ (operand);
12141 ffeexpr_stack_->exprstack = NULL;
12142 }
12143
12144 ft = ffeexpr_stack_->first_token;
12145
12146 again: /* :::::::::::::::::::: */
12147 switch (ffeexpr_stack_->context)
12148 {
12149 case FFEEXPR_contextLET:
12150 case FFEEXPR_contextSFUNCDEF:
12151 error = (expr == NULL)
12152 || (ffeinfo_rank (info) != 0);
12153 break;
12154
12155 case FFEEXPR_contextPAREN_:
12156 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12157 break;
12158 switch (ffeinfo_basictype (info))
12159 {
12160 case FFEINFO_basictypeHOLLERITH:
12161 case FFEINFO_basictypeTYPELESS:
12162 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12163 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12164 FFEEXPR_contextLET);
12165 break;
12166
12167 default:
12168 break;
12169 }
12170 break;
12171
12172 case FFEEXPR_contextPARENFILENUM_:
12173 if (ffelex_token_type (t) != FFELEX_typeCOMMA)
12174 ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
12175 else
12176 ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
12177 goto again; /* :::::::::::::::::::: */
12178
12179 case FFEEXPR_contextPARENFILEUNIT_:
12180 if (ffelex_token_type (t) != FFELEX_typeCOMMA)
12181 ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
12182 else
12183 ffeexpr_stack_->context = FFEEXPR_contextFILEUNIT;
12184 goto again; /* :::::::::::::::::::: */
12185
12186 case FFEEXPR_contextACTUALARGEXPR_:
12187 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
12188 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12189 : ffeinfo_basictype (info))
12190 {
12191 case FFEINFO_basictypeHOLLERITH:
12192 case FFEINFO_basictypeTYPELESS:
12193 if (!ffe_is_ugly_args ()
12194 && ffebad_start (FFEBAD_ACTUALARG))
12195 {
12196 ffebad_here (0, ffelex_token_where_line (ft),
12197 ffelex_token_where_column (ft));
12198 ffebad_finish ();
12199 }
12200 break;
12201
12202 default:
12203 break;
12204 }
12205 error = (expr != NULL) && (ffeinfo_rank (info) != 0);
12206 break;
12207
12208 case FFEEXPR_contextACTUALARG_:
12209 case FFEEXPR_contextSFUNCDEFACTUALARG_:
12210 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12211 : ffeinfo_basictype (info))
12212 {
12213 case FFEINFO_basictypeHOLLERITH:
12214 case FFEINFO_basictypeTYPELESS:
12215 #if 0 /* Should never get here. */
12216 expr = ffeexpr_convert (expr, ft, ft,
12217 FFEINFO_basictypeINTEGER,
12218 FFEINFO_kindtypeINTEGERDEFAULT,
12219 0,
12220 FFETARGET_charactersizeNONE,
12221 FFEEXPR_contextLET);
12222 #else
12223 assert ("why hollerith/typeless in actualarg_?" == NULL);
12224 #endif
12225 break;
12226
12227 default:
12228 break;
12229 }
12230 switch ((expr == NULL) ? FFEBLD_opANY : ffebld_op (expr))
12231 {
12232 case FFEBLD_opSYMTER:
12233 case FFEBLD_opPERCENT_LOC:
12234 case FFEBLD_opPERCENT_VAL:
12235 case FFEBLD_opPERCENT_REF:
12236 case FFEBLD_opPERCENT_DESCR:
12237 error = FALSE;
12238 break;
12239
12240 default:
12241 error = (expr != NULL) && (ffeinfo_rank (info) != 0);
12242 break;
12243 }
12244 {
12245 ffesymbol s;
12246 ffeinfoWhere where;
12247 ffeinfoKind kind;
12248
12249 if (!error
12250 && (expr != NULL)
12251 && (ffebld_op (expr) == FFEBLD_opSYMTER)
12252 && ((s = ffebld_symter (expr)), (where = ffesymbol_where (s)),
12253 (where == FFEINFO_whereINTRINSIC)
12254 || (where == FFEINFO_whereGLOBAL)
12255 || ((where == FFEINFO_whereDUMMY)
12256 && ((kind = ffesymbol_kind (s)),
12257 (kind == FFEINFO_kindFUNCTION)
12258 || (kind == FFEINFO_kindSUBROUTINE))))
12259 && !ffesymbol_explicitwhere (s))
12260 {
12261 ffebad_start (where == FFEINFO_whereINTRINSIC
12262 ? FFEBAD_NEED_INTRINSIC : FFEBAD_NEED_EXTERNAL);
12263 ffebad_here (0, ffelex_token_where_line (ft),
12264 ffelex_token_where_column (ft));
12265 ffebad_string (ffesymbol_text (s));
12266 ffebad_finish ();
12267 ffesymbol_signal_change (s);
12268 ffesymbol_set_explicitwhere (s, TRUE);
12269 ffesymbol_signal_unreported (s);
12270 }
12271 }
12272 break;
12273
12274 case FFEEXPR_contextINDEX_:
12275 case FFEEXPR_contextSFUNCDEFINDEX_:
12276 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12277 break;
12278 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12279 : ffeinfo_basictype (info))
12280 {
12281 case FFEINFO_basictypeNONE:
12282 error = FALSE;
12283 break;
12284
12285 case FFEINFO_basictypeLOGICAL:
12286 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12287 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12288 FFEEXPR_contextLET);
12289 /* Fall through. */
12290 case FFEINFO_basictypeREAL:
12291 case FFEINFO_basictypeCOMPLEX:
12292 if (ffe_is_pedantic ())
12293 {
12294 error = TRUE;
12295 break;
12296 }
12297 /* Fall through. */
12298 case FFEINFO_basictypeHOLLERITH:
12299 case FFEINFO_basictypeTYPELESS:
12300 error = FALSE;
12301 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12302 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12303 FFEEXPR_contextLET);
12304 break;
12305
12306 case FFEINFO_basictypeINTEGER:
12307 /* Specifically, allow INTEGER(KIND=2), aka INTEGER*8, through
12308 unmolested. Leave it to downstream to handle kinds. */
12309 break;
12310
12311 default:
12312 error = TRUE;
12313 break;
12314 }
12315 break; /* expr==NULL ok for substring; element case
12316 caught by callback. */
12317
12318 case FFEEXPR_contextRETURN:
12319 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12320 break;
12321 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12322 : ffeinfo_basictype (info))
12323 {
12324 case FFEINFO_basictypeNONE:
12325 error = FALSE;
12326 break;
12327
12328 case FFEINFO_basictypeLOGICAL:
12329 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12330 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12331 FFEEXPR_contextLET);
12332 /* Fall through. */
12333 case FFEINFO_basictypeREAL:
12334 case FFEINFO_basictypeCOMPLEX:
12335 if (ffe_is_pedantic ())
12336 {
12337 error = TRUE;
12338 break;
12339 }
12340 /* Fall through. */
12341 case FFEINFO_basictypeINTEGER:
12342 case FFEINFO_basictypeHOLLERITH:
12343 case FFEINFO_basictypeTYPELESS:
12344 error = FALSE;
12345 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12346 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12347 FFEEXPR_contextLET);
12348 break;
12349
12350 default:
12351 error = TRUE;
12352 break;
12353 }
12354 break;
12355
12356 case FFEEXPR_contextDO:
12357 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12358 break;
12359 switch (ffeinfo_basictype (info))
12360 {
12361 case FFEINFO_basictypeLOGICAL:
12362 error = !ffe_is_ugly_logint ();
12363 if (!ffeexpr_stack_->is_rhs)
12364 break; /* Don't convert lhs variable. */
12365 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12366 ffeinfo_kindtype (ffebld_info (expr)), 0,
12367 FFETARGET_charactersizeNONE,
12368 FFEEXPR_contextLET);
12369 break;
12370
12371 case FFEINFO_basictypeHOLLERITH:
12372 case FFEINFO_basictypeTYPELESS:
12373 if (!ffeexpr_stack_->is_rhs)
12374 {
12375 error = TRUE;
12376 break; /* Don't convert lhs variable. */
12377 }
12378 break;
12379
12380 case FFEINFO_basictypeINTEGER:
12381 case FFEINFO_basictypeREAL:
12382 break;
12383
12384 default:
12385 error = TRUE;
12386 break;
12387 }
12388 if (!ffeexpr_stack_->is_rhs
12389 && (ffebld_op (expr) != FFEBLD_opSYMTER))
12390 error = TRUE;
12391 break;
12392
12393 case FFEEXPR_contextDOWHILE:
12394 case FFEEXPR_contextIF:
12395 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12396 break;
12397 switch (ffeinfo_basictype (info))
12398 {
12399 case FFEINFO_basictypeINTEGER:
12400 error = FALSE;
12401 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12402 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12403 FFEEXPR_contextLET);
12404 /* Fall through. */
12405 case FFEINFO_basictypeLOGICAL:
12406 case FFEINFO_basictypeHOLLERITH:
12407 case FFEINFO_basictypeTYPELESS:
12408 error = FALSE;
12409 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12410 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12411 FFEEXPR_contextLET);
12412 break;
12413
12414 default:
12415 error = TRUE;
12416 break;
12417 }
12418 break;
12419
12420 case FFEEXPR_contextASSIGN:
12421 case FFEEXPR_contextAGOTO:
12422 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12423 : ffeinfo_basictype (info))
12424 {
12425 case FFEINFO_basictypeINTEGER:
12426 error = (ffeinfo_kindtype (info) != ffecom_label_kind ());
12427 break;
12428
12429 case FFEINFO_basictypeLOGICAL:
12430 error = !ffe_is_ugly_logint ()
12431 || (ffeinfo_kindtype (info) != ffecom_label_kind ());
12432 break;
12433
12434 default:
12435 error = TRUE;
12436 break;
12437 }
12438 if ((expr == NULL) || (ffeinfo_rank (info) != 0)
12439 || (ffebld_op (expr) != FFEBLD_opSYMTER))
12440 error = TRUE;
12441 break;
12442
12443 case FFEEXPR_contextCGOTO:
12444 case FFEEXPR_contextFORMAT:
12445 case FFEEXPR_contextDIMLIST:
12446 case FFEEXPR_contextFILENUM: /* See equiv code in _ambig_. */
12447 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12448 break;
12449 switch (ffeinfo_basictype (info))
12450 {
12451 case FFEINFO_basictypeLOGICAL:
12452 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12453 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12454 FFEEXPR_contextLET);
12455 /* Fall through. */
12456 case FFEINFO_basictypeREAL:
12457 case FFEINFO_basictypeCOMPLEX:
12458 if (ffe_is_pedantic ())
12459 {
12460 error = TRUE;
12461 break;
12462 }
12463 /* Fall through. */
12464 case FFEINFO_basictypeINTEGER:
12465 case FFEINFO_basictypeHOLLERITH:
12466 case FFEINFO_basictypeTYPELESS:
12467 error = FALSE;
12468 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12469 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12470 FFEEXPR_contextLET);
12471 break;
12472
12473 default:
12474 error = TRUE;
12475 break;
12476 }
12477 break;
12478
12479 case FFEEXPR_contextARITHIF:
12480 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12481 break;
12482 switch (ffeinfo_basictype (info))
12483 {
12484 case FFEINFO_basictypeLOGICAL:
12485 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12486 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12487 FFEEXPR_contextLET);
12488 if (ffe_is_pedantic ())
12489 {
12490 error = TRUE;
12491 break;
12492 }
12493 /* Fall through. */
12494 case FFEINFO_basictypeHOLLERITH:
12495 case FFEINFO_basictypeTYPELESS:
12496 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12497 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12498 FFEEXPR_contextLET);
12499 /* Fall through. */
12500 case FFEINFO_basictypeINTEGER:
12501 case FFEINFO_basictypeREAL:
12502 error = FALSE;
12503 break;
12504
12505 default:
12506 error = TRUE;
12507 break;
12508 }
12509 break;
12510
12511 case FFEEXPR_contextSTOP:
12512 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12513 break;
12514 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12515 : ffeinfo_basictype (info))
12516 {
12517 case FFEINFO_basictypeINTEGER:
12518 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12519 break;
12520
12521 case FFEINFO_basictypeCHARACTER:
12522 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT);
12523 break;
12524
12525 case FFEINFO_basictypeHOLLERITH:
12526 case FFEINFO_basictypeTYPELESS:
12527 error = FALSE;
12528 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12529 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12530 FFEEXPR_contextLET);
12531 break;
12532
12533 case FFEINFO_basictypeNONE:
12534 error = FALSE;
12535 break;
12536
12537 default:
12538 error = TRUE;
12539 break;
12540 }
12541 if ((expr != NULL) && ((ffebld_op (expr) != FFEBLD_opCONTER)
12542 || (ffebld_conter_orig (expr) != NULL)))
12543 error = TRUE;
12544 break;
12545
12546 case FFEEXPR_contextINCLUDE:
12547 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12548 || (ffeinfo_basictype (info) != FFEINFO_basictypeCHARACTER)
12549 || (ffebld_op (expr) != FFEBLD_opCONTER)
12550 || (ffebld_conter_orig (expr) != NULL);
12551 break;
12552
12553 case FFEEXPR_contextSELECTCASE:
12554 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12555 break;
12556 switch (ffeinfo_basictype (info))
12557 {
12558 case FFEINFO_basictypeINTEGER:
12559 case FFEINFO_basictypeCHARACTER:
12560 case FFEINFO_basictypeLOGICAL:
12561 error = FALSE;
12562 break;
12563
12564 case FFEINFO_basictypeHOLLERITH:
12565 case FFEINFO_basictypeTYPELESS:
12566 error = FALSE;
12567 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12568 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12569 FFEEXPR_contextLET);
12570 break;
12571
12572 default:
12573 error = TRUE;
12574 break;
12575 }
12576 break;
12577
12578 case FFEEXPR_contextCASE:
12579 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12580 break;
12581 switch ((expr == NULL) ? FFEINFO_basictypeINTEGER
12582 : ffeinfo_basictype (info))
12583 {
12584 case FFEINFO_basictypeINTEGER:
12585 case FFEINFO_basictypeCHARACTER:
12586 case FFEINFO_basictypeLOGICAL:
12587 error = FALSE;
12588 break;
12589
12590 case FFEINFO_basictypeHOLLERITH:
12591 case FFEINFO_basictypeTYPELESS:
12592 error = FALSE;
12593 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12594 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12595 FFEEXPR_contextLET);
12596 break;
12597
12598 default:
12599 error = TRUE;
12600 break;
12601 }
12602 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12603 error = TRUE;
12604 break;
12605
12606 case FFEEXPR_contextCHARACTERSIZE:
12607 case FFEEXPR_contextKINDTYPE:
12608 case FFEEXPR_contextDIMLISTCOMMON:
12609 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12610 break;
12611 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12612 : ffeinfo_basictype (info))
12613 {
12614 case FFEINFO_basictypeLOGICAL:
12615 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12616 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12617 FFEEXPR_contextLET);
12618 /* Fall through. */
12619 case FFEINFO_basictypeREAL:
12620 case FFEINFO_basictypeCOMPLEX:
12621 if (ffe_is_pedantic ())
12622 {
12623 error = TRUE;
12624 break;
12625 }
12626 /* Fall through. */
12627 case FFEINFO_basictypeINTEGER:
12628 case FFEINFO_basictypeHOLLERITH:
12629 case FFEINFO_basictypeTYPELESS:
12630 error = FALSE;
12631 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12632 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12633 FFEEXPR_contextLET);
12634 break;
12635
12636 default:
12637 error = TRUE;
12638 break;
12639 }
12640 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12641 error = TRUE;
12642 break;
12643
12644 case FFEEXPR_contextEQVINDEX_:
12645 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12646 break;
12647 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12648 : ffeinfo_basictype (info))
12649 {
12650 case FFEINFO_basictypeNONE:
12651 error = FALSE;
12652 break;
12653
12654 case FFEINFO_basictypeLOGICAL:
12655 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12656 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12657 FFEEXPR_contextLET);
12658 /* Fall through. */
12659 case FFEINFO_basictypeREAL:
12660 case FFEINFO_basictypeCOMPLEX:
12661 if (ffe_is_pedantic ())
12662 {
12663 error = TRUE;
12664 break;
12665 }
12666 /* Fall through. */
12667 case FFEINFO_basictypeINTEGER:
12668 case FFEINFO_basictypeHOLLERITH:
12669 case FFEINFO_basictypeTYPELESS:
12670 error = FALSE;
12671 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12672 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12673 FFEEXPR_contextLET);
12674 break;
12675
12676 default:
12677 error = TRUE;
12678 break;
12679 }
12680 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12681 error = TRUE;
12682 break;
12683
12684 case FFEEXPR_contextPARAMETER:
12685 if (ffeexpr_stack_->is_rhs)
12686 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12687 || (ffebld_op (expr) != FFEBLD_opCONTER);
12688 else
12689 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12690 || (ffebld_op (expr) != FFEBLD_opSYMTER);
12691 break;
12692
12693 case FFEEXPR_contextINDEXORACTUALARG_:
12694 if (ffelex_token_type (t) == FFELEX_typeCOLON)
12695 ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
12696 else
12697 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
12698 goto again; /* :::::::::::::::::::: */
12699
12700 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
12701 if (ffelex_token_type (t) == FFELEX_typeCOLON)
12702 ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
12703 else
12704 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
12705 goto again; /* :::::::::::::::::::: */
12706
12707 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
12708 if (ffelex_token_type (t) == FFELEX_typeCOLON)
12709 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
12710 else
12711 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
12712 goto again; /* :::::::::::::::::::: */
12713
12714 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
12715 if (ffelex_token_type (t) == FFELEX_typeCOLON)
12716 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
12717 else
12718 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
12719 goto again; /* :::::::::::::::::::: */
12720
12721 case FFEEXPR_contextIMPDOCTRL_:
12722 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12723 break;
12724 if (!ffeexpr_stack_->is_rhs
12725 && (ffebld_op (expr) != FFEBLD_opSYMTER))
12726 error = TRUE;
12727 switch (ffeinfo_basictype (info))
12728 {
12729 case FFEINFO_basictypeLOGICAL:
12730 if (! ffe_is_ugly_logint ())
12731 error = TRUE;
12732 if (! ffeexpr_stack_->is_rhs)
12733 break;
12734 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12735 ffeinfo_kindtype (info), 0,
12736 FFETARGET_charactersizeNONE,
12737 FFEEXPR_contextLET);
12738 break;
12739
12740 case FFEINFO_basictypeINTEGER:
12741 case FFEINFO_basictypeHOLLERITH:
12742 case FFEINFO_basictypeTYPELESS:
12743 break;
12744
12745 case FFEINFO_basictypeREAL:
12746 if (!ffeexpr_stack_->is_rhs
12747 && ffe_is_warn_surprising ()
12748 && !error)
12749 {
12750 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
12751 ffebad_here (0, ffelex_token_where_line (ft),
12752 ffelex_token_where_column (ft));
12753 ffebad_string (ffelex_token_text (ft));
12754 ffebad_finish ();
12755 }
12756 break;
12757
12758 default:
12759 error = TRUE;
12760 break;
12761 }
12762 break;
12763
12764 case FFEEXPR_contextDATAIMPDOCTRL_:
12765 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12766 break;
12767 if (ffeexpr_stack_->is_rhs)
12768 {
12769 if ((ffebld_op (expr) != FFEBLD_opCONTER)
12770 && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12771 error = TRUE;
12772 }
12773 else if ((ffebld_op (expr) != FFEBLD_opSYMTER)
12774 || (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12775 error = TRUE;
12776 switch (ffeinfo_basictype (info))
12777 {
12778 case FFEINFO_basictypeLOGICAL:
12779 if (! ffeexpr_stack_->is_rhs)
12780 break;
12781 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12782 ffeinfo_kindtype (info), 0,
12783 FFETARGET_charactersizeNONE,
12784 FFEEXPR_contextLET);
12785 /* Fall through. */
12786 case FFEINFO_basictypeINTEGER:
12787 if (ffeexpr_stack_->is_rhs
12788 && (ffeinfo_kindtype (ffebld_info (expr))
12789 != FFEINFO_kindtypeINTEGERDEFAULT))
12790 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12791 FFEINFO_kindtypeINTEGERDEFAULT, 0,
12792 FFETARGET_charactersizeNONE,
12793 FFEEXPR_contextLET);
12794 break;
12795
12796 case FFEINFO_basictypeHOLLERITH:
12797 case FFEINFO_basictypeTYPELESS:
12798 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12799 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12800 FFEEXPR_contextLET);
12801 break;
12802
12803 case FFEINFO_basictypeREAL:
12804 if (!ffeexpr_stack_->is_rhs
12805 && ffe_is_warn_surprising ()
12806 && !error)
12807 {
12808 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
12809 ffebad_here (0, ffelex_token_where_line (ft),
12810 ffelex_token_where_column (ft));
12811 ffebad_string (ffelex_token_text (ft));
12812 ffebad_finish ();
12813 }
12814 break;
12815
12816 default:
12817 error = TRUE;
12818 break;
12819 }
12820 break;
12821
12822 case FFEEXPR_contextIMPDOITEM_:
12823 if (ffelex_token_type (t) == FFELEX_typeEQUALS)
12824 {
12825 ffeexpr_stack_->is_rhs = FALSE;
12826 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
12827 goto again; /* :::::::::::::::::::: */
12828 }
12829 /* Fall through. */
12830 case FFEEXPR_contextIOLIST:
12831 case FFEEXPR_contextFILEVXTCODE:
12832 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12833 : ffeinfo_basictype (info))
12834 {
12835 case FFEINFO_basictypeHOLLERITH:
12836 case FFEINFO_basictypeTYPELESS:
12837 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12838 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12839 FFEEXPR_contextLET);
12840 break;
12841
12842 default:
12843 break;
12844 }
12845 error = (expr == NULL)
12846 || ((ffeinfo_rank (info) != 0)
12847 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12848 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12849 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12850 == FFEBLD_opSTAR))); /* Bad if null expr, or if
12851 array that is not a SYMTER
12852 (can't happen yet, I
12853 think) or has a NULL or
12854 STAR (assumed) array
12855 size. */
12856 break;
12857
12858 case FFEEXPR_contextIMPDOITEMDF_:
12859 if (ffelex_token_type (t) == FFELEX_typeEQUALS)
12860 {
12861 ffeexpr_stack_->is_rhs = FALSE;
12862 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
12863 goto again; /* :::::::::::::::::::: */
12864 }
12865 /* Fall through. */
12866 case FFEEXPR_contextIOLISTDF:
12867 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12868 : ffeinfo_basictype (info))
12869 {
12870 case FFEINFO_basictypeHOLLERITH:
12871 case FFEINFO_basictypeTYPELESS:
12872 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12873 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12874 FFEEXPR_contextLET);
12875 break;
12876
12877 default:
12878 break;
12879 }
12880 error
12881 = (expr == NULL)
12882 || ((ffeinfo_basictype (info) == FFEINFO_basictypeCHARACTER)
12883 && (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT))
12884 || ((ffeinfo_rank (info) != 0)
12885 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12886 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12887 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12888 == FFEBLD_opSTAR))); /* Bad if null expr,
12889 non-default-kindtype
12890 character expr, or if
12891 array that is not a SYMTER
12892 (can't happen yet, I
12893 think) or has a NULL or
12894 STAR (assumed) array
12895 size. */
12896 break;
12897
12898 case FFEEXPR_contextDATAIMPDOITEM_:
12899 error = (expr == NULL)
12900 || (ffebld_op (expr) != FFEBLD_opARRAYREF)
12901 || ((ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR)
12902 && (ffeinfo_where (info) != FFEINFO_whereFLEETING_IADDR));
12903 break;
12904
12905 case FFEEXPR_contextDATAIMPDOINDEX_:
12906 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12907 break;
12908 switch (ffeinfo_basictype (info))
12909 {
12910 case FFEINFO_basictypeLOGICAL:
12911 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12912 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12913 FFEEXPR_contextLET);
12914 /* Fall through. */
12915 case FFEINFO_basictypeREAL:
12916 case FFEINFO_basictypeCOMPLEX:
12917 if (ffe_is_pedantic ())
12918 {
12919 error = TRUE;
12920 break;
12921 }
12922 /* Fall through. */
12923 case FFEINFO_basictypeINTEGER:
12924 case FFEINFO_basictypeHOLLERITH:
12925 case FFEINFO_basictypeTYPELESS:
12926 error = FALSE;
12927 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12928 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12929 FFEEXPR_contextLET);
12930 break;
12931
12932 default:
12933 error = TRUE;
12934 break;
12935 }
12936 if ((ffeinfo_where (info) != FFEINFO_whereCONSTANT)
12937 && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12938 error = TRUE;
12939 break;
12940
12941 case FFEEXPR_contextDATA:
12942 if (expr == NULL)
12943 error = TRUE;
12944 else if (ffeexpr_stack_->is_rhs)
12945 error = (ffebld_op (expr) != FFEBLD_opCONTER);
12946 else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12947 error = FALSE;
12948 else
12949 error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12950 break;
12951
12952 case FFEEXPR_contextINITVAL:
12953 error = (expr == NULL) || (ffebld_op (expr) != FFEBLD_opCONTER);
12954 break;
12955
12956 case FFEEXPR_contextEQUIVALENCE:
12957 if (expr == NULL)
12958 error = TRUE;
12959 else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12960 error = FALSE;
12961 else
12962 error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12963 break;
12964
12965 case FFEEXPR_contextFILEASSOC:
12966 case FFEEXPR_contextFILEINT:
12967 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12968 : ffeinfo_basictype (info))
12969 {
12970 case FFEINFO_basictypeINTEGER:
12971 /* Maybe this should be supported someday, but, right now,
12972 g77 can't generate a call to libf2c to write to an
12973 integer other than the default size. */
12974 error = ((! ffeexpr_stack_->is_rhs)
12975 && ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12976 break;
12977
12978 default:
12979 error = TRUE;
12980 break;
12981 }
12982 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12983 error = TRUE;
12984 break;
12985
12986 case FFEEXPR_contextFILEDFINT:
12987 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12988 : ffeinfo_basictype (info))
12989 {
12990 case FFEINFO_basictypeINTEGER:
12991 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12992 break;
12993
12994 default:
12995 error = TRUE;
12996 break;
12997 }
12998 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12999 error = TRUE;
13000 break;
13001
13002 case FFEEXPR_contextFILELOG:
13003 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13004 : ffeinfo_basictype (info))
13005 {
13006 case FFEINFO_basictypeLOGICAL:
13007 error = FALSE;
13008 break;
13009
13010 default:
13011 error = TRUE;
13012 break;
13013 }
13014 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13015 error = TRUE;
13016 break;
13017
13018 case FFEEXPR_contextFILECHAR:
13019 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13020 : ffeinfo_basictype (info))
13021 {
13022 case FFEINFO_basictypeCHARACTER:
13023 error = FALSE;
13024 break;
13025
13026 default:
13027 error = TRUE;
13028 break;
13029 }
13030 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13031 error = TRUE;
13032 break;
13033
13034 case FFEEXPR_contextFILENUMCHAR:
13035 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
13036 break;
13037 switch (ffeinfo_basictype (info))
13038 {
13039 case FFEINFO_basictypeLOGICAL:
13040 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13041 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13042 FFEEXPR_contextLET);
13043 /* Fall through. */
13044 case FFEINFO_basictypeREAL:
13045 case FFEINFO_basictypeCOMPLEX:
13046 if (ffe_is_pedantic ())
13047 {
13048 error = TRUE;
13049 break;
13050 }
13051 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13052 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13053 FFEEXPR_contextLET);
13054 break;
13055
13056 case FFEINFO_basictypeINTEGER:
13057 case FFEINFO_basictypeCHARACTER:
13058 error = FALSE;
13059 break;
13060
13061 default:
13062 error = TRUE;
13063 break;
13064 }
13065 break;
13066
13067 case FFEEXPR_contextFILEDFCHAR:
13068 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
13069 break;
13070 switch (ffeinfo_basictype (info))
13071 {
13072 case FFEINFO_basictypeCHARACTER:
13073 error
13074 = (ffeinfo_kindtype (info)
13075 != FFEINFO_kindtypeCHARACTERDEFAULT);
13076 break;
13077
13078 default:
13079 error = TRUE;
13080 break;
13081 }
13082 if (!ffeexpr_stack_->is_rhs
13083 && (ffebld_op (expr) == FFEBLD_opSUBSTR))
13084 error = TRUE;
13085 break;
13086
13087 case FFEEXPR_contextFILEUNIT: /* See equiv code in _ambig_. */
13088 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13089 : ffeinfo_basictype (info))
13090 {
13091 case FFEINFO_basictypeLOGICAL:
13092 if ((error = (ffeinfo_rank (info) != 0)))
13093 break;
13094 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13095 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13096 FFEEXPR_contextLET);
13097 /* Fall through. */
13098 case FFEINFO_basictypeREAL:
13099 case FFEINFO_basictypeCOMPLEX:
13100 if ((error = (ffeinfo_rank (info) != 0)))
13101 break;
13102 if (ffe_is_pedantic ())
13103 {
13104 error = TRUE;
13105 break;
13106 }
13107 /* Fall through. */
13108 case FFEINFO_basictypeINTEGER:
13109 case FFEINFO_basictypeHOLLERITH:
13110 case FFEINFO_basictypeTYPELESS:
13111 if ((error = (ffeinfo_rank (info) != 0)))
13112 break;
13113 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13114 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13115 FFEEXPR_contextLET);
13116 break;
13117
13118 case FFEINFO_basictypeCHARACTER:
13119 switch (ffebld_op (expr))
13120 { /* As if _lhs had been called instead of
13121 _rhs. */
13122 case FFEBLD_opSYMTER:
13123 error
13124 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
13125 break;
13126
13127 case FFEBLD_opSUBSTR:
13128 error = (ffeinfo_where (ffebld_info (expr))
13129 == FFEINFO_whereCONSTANT_SUBOBJECT);
13130 break;
13131
13132 case FFEBLD_opARRAYREF:
13133 error = FALSE;
13134 break;
13135
13136 default:
13137 error = TRUE;
13138 break;
13139 }
13140 if (!error
13141 && ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
13142 || ((ffeinfo_rank (info) != 0)
13143 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
13144 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
13145 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
13146 == FFEBLD_opSTAR))))) /* Bad if
13147 non-default-kindtype
13148 character expr, or if
13149 array that is not a SYMTER
13150 (can't happen yet, I
13151 think), or has a NULL or
13152 STAR (assumed) array
13153 size. */
13154 error = TRUE;
13155 break;
13156
13157 default:
13158 error = TRUE;
13159 break;
13160 }
13161 break;
13162
13163 case FFEEXPR_contextFILEFORMAT:
13164 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13165 : ffeinfo_basictype (info))
13166 {
13167 case FFEINFO_basictypeINTEGER:
13168 error = (expr == NULL)
13169 || ((ffeinfo_rank (info) != 0) ?
13170 ffe_is_pedantic () /* F77 C5. */
13171 : (bool) (ffeinfo_kindtype (info) != ffecom_label_kind ()))
13172 || (ffebld_op (expr) != FFEBLD_opSYMTER);
13173 break;
13174
13175 case FFEINFO_basictypeLOGICAL:
13176 case FFEINFO_basictypeREAL:
13177 case FFEINFO_basictypeCOMPLEX:
13178 /* F77 C5 -- must be an array of hollerith. */
13179 error
13180 = ffe_is_pedantic ()
13181 || (ffeinfo_rank (info) == 0);
13182 break;
13183
13184 case FFEINFO_basictypeCHARACTER:
13185 if ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
13186 || ((ffeinfo_rank (info) != 0)
13187 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
13188 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
13189 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
13190 == FFEBLD_opSTAR)))) /* Bad if
13191 non-default-kindtype
13192 character expr, or if
13193 array that is not a SYMTER
13194 (can't happen yet, I
13195 think), or has a NULL or
13196 STAR (assumed) array
13197 size. */
13198 error = TRUE;
13199 else
13200 error = FALSE;
13201 break;
13202
13203 default:
13204 error = TRUE;
13205 break;
13206 }
13207 break;
13208
13209 case FFEEXPR_contextLOC_:
13210 /* See also ffeintrin_check_loc_. */
13211 if ((expr == NULL)
13212 || (ffeinfo_kind (info) != FFEINFO_kindENTITY)
13213 || ((ffebld_op (expr) != FFEBLD_opSYMTER)
13214 && (ffebld_op (expr) != FFEBLD_opSUBSTR)
13215 && (ffebld_op (expr) != FFEBLD_opARRAYREF)))
13216 error = TRUE;
13217 break;
13218
13219 default:
13220 error = FALSE;
13221 break;
13222 }
13223
13224 if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
13225 {
13226 ffebad_start (FFEBAD_EXPR_WRONG);
13227 ffebad_here (0, ffelex_token_where_line (ft),
13228 ffelex_token_where_column (ft));
13229 ffebad_finish ();
13230 expr = ffebld_new_any ();
13231 ffebld_set_info (expr, ffeinfo_new_any ());
13232 }
13233
13234 callback = ffeexpr_stack_->callback;
13235 s = ffeexpr_stack_->previous;
13236 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
13237 sizeof (*ffeexpr_stack_));
13238 ffeexpr_stack_ = s;
13239 next = (ffelexHandler) (*callback) (ft, expr, t);
13240 ffelex_token_kill (ft);
13241 return (ffelexHandler) next;
13242 }
13243
13244 /* ffeexpr_finished_ambig_ -- Check validity of ambiguous unit/form spec
13245
13246 ffebld expr;
13247 expr = ffeexpr_finished_ambig_(expr);
13248
13249 Replicates a bit of ffeexpr_finished_'s task when in a context
13250 of UNIT or FORMAT. */
13251
13252 static ffebld
ffeexpr_finished_ambig_(ffelexToken ft,ffebld expr)13253 ffeexpr_finished_ambig_ (ffelexToken ft, ffebld expr)
13254 {
13255 ffeinfo info = ffebld_info (expr);
13256 bool error;
13257
13258 switch (ffeexpr_stack_->context)
13259 {
13260 case FFEEXPR_contextFILENUMAMBIG: /* Same as FILENUM in _finished_. */
13261 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13262 : ffeinfo_basictype (info))
13263 {
13264 case FFEINFO_basictypeLOGICAL:
13265 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13266 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13267 FFEEXPR_contextLET);
13268 /* Fall through. */
13269 case FFEINFO_basictypeREAL:
13270 case FFEINFO_basictypeCOMPLEX:
13271 if (ffe_is_pedantic ())
13272 {
13273 error = TRUE;
13274 break;
13275 }
13276 /* Fall through. */
13277 case FFEINFO_basictypeINTEGER:
13278 case FFEINFO_basictypeHOLLERITH:
13279 case FFEINFO_basictypeTYPELESS:
13280 error = FALSE;
13281 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13282 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13283 FFEEXPR_contextLET);
13284 break;
13285
13286 default:
13287 error = TRUE;
13288 break;
13289 }
13290 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13291 error = TRUE;
13292 break;
13293
13294 case FFEEXPR_contextFILEUNITAMBIG: /* Same as FILEUNIT in _finished_. */
13295 if ((expr != NULL) && (ffebld_op (expr) == FFEBLD_opSTAR))
13296 {
13297 error = FALSE;
13298 break;
13299 }
13300 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13301 : ffeinfo_basictype (info))
13302 {
13303 case FFEINFO_basictypeLOGICAL:
13304 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13305 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13306 FFEEXPR_contextLET);
13307 /* Fall through. */
13308 case FFEINFO_basictypeREAL:
13309 case FFEINFO_basictypeCOMPLEX:
13310 if (ffe_is_pedantic ())
13311 {
13312 error = TRUE;
13313 break;
13314 }
13315 /* Fall through. */
13316 case FFEINFO_basictypeINTEGER:
13317 case FFEINFO_basictypeHOLLERITH:
13318 case FFEINFO_basictypeTYPELESS:
13319 error = (ffeinfo_rank (info) != 0);
13320 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13321 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13322 FFEEXPR_contextLET);
13323 break;
13324
13325 case FFEINFO_basictypeCHARACTER:
13326 switch (ffebld_op (expr))
13327 { /* As if _lhs had been called instead of
13328 _rhs. */
13329 case FFEBLD_opSYMTER:
13330 error
13331 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
13332 break;
13333
13334 case FFEBLD_opSUBSTR:
13335 error = (ffeinfo_where (ffebld_info (expr))
13336 == FFEINFO_whereCONSTANT_SUBOBJECT);
13337 break;
13338
13339 case FFEBLD_opARRAYREF:
13340 error = FALSE;
13341 break;
13342
13343 default:
13344 error = TRUE;
13345 break;
13346 }
13347 break;
13348
13349 default:
13350 error = TRUE;
13351 break;
13352 }
13353 break;
13354
13355 default:
13356 assert ("bad context" == NULL);
13357 error = TRUE;
13358 break;
13359 }
13360
13361 if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
13362 {
13363 ffebad_start (FFEBAD_EXPR_WRONG);
13364 ffebad_here (0, ffelex_token_where_line (ft),
13365 ffelex_token_where_column (ft));
13366 ffebad_finish ();
13367 expr = ffebld_new_any ();
13368 ffebld_set_info (expr, ffeinfo_new_any ());
13369 }
13370
13371 return expr;
13372 }
13373
13374 /* ffeexpr_token_lhs_ -- Initial state for lhs expression
13375
13376 Return a pointer to this function to the lexer (ffelex), which will
13377 invoke it for the next token.
13378
13379 Basically a smaller version of _rhs_; keep them both in sync, of course. */
13380
13381 static ffelexHandler
ffeexpr_token_lhs_(ffelexToken t)13382 ffeexpr_token_lhs_ (ffelexToken t)
13383 {
13384
13385 /* When changing the list of valid initial lhs tokens, check whether to
13386 update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
13387 READ (expr) <token> case -- it assumes it knows which tokens <token> can
13388 be to indicate an lhs (or implied DO), which right now is the set
13389 {NAME,OPEN_PAREN}.
13390
13391 This comment also appears in ffeexpr_token_first_lhs_. */
13392
13393 switch (ffelex_token_type (t))
13394 {
13395 case FFELEX_typeNAME:
13396 case FFELEX_typeNAMES:
13397 ffeexpr_tokens_[0] = ffelex_token_use (t);
13398 return (ffelexHandler) ffeexpr_token_name_lhs_;
13399
13400 default:
13401 return (ffelexHandler) ffeexpr_finished_ (t);
13402 }
13403 }
13404
13405 /* ffeexpr_token_rhs_ -- Initial state for rhs expression
13406
13407 Return a pointer to this function to the lexer (ffelex), which will
13408 invoke it for the next token.
13409
13410 The initial state and the post-binary-operator state are the same and
13411 both handled here, with the expression stack used to distinguish
13412 between them. Binary operators are invalid here; unary operators,
13413 constants, subexpressions, and name references are valid. */
13414
13415 static ffelexHandler
ffeexpr_token_rhs_(ffelexToken t)13416 ffeexpr_token_rhs_ (ffelexToken t)
13417 {
13418 ffeexprExpr_ e;
13419
13420 switch (ffelex_token_type (t))
13421 {
13422 case FFELEX_typeQUOTE:
13423 if (ffe_is_vxt ())
13424 {
13425 ffeexpr_tokens_[0] = ffelex_token_use (t);
13426 return (ffelexHandler) ffeexpr_token_quote_;
13427 }
13428 ffeexpr_tokens_[0] = ffelex_token_use (t);
13429 ffelex_set_expecting_hollerith (-1, '\"',
13430 ffelex_token_where_line (t),
13431 ffelex_token_where_column (t));
13432 /* Don't have to unset this one. */
13433 return (ffelexHandler) ffeexpr_token_apostrophe_;
13434
13435 case FFELEX_typeAPOSTROPHE:
13436 ffeexpr_tokens_[0] = ffelex_token_use (t);
13437 ffelex_set_expecting_hollerith (-1, '\'',
13438 ffelex_token_where_line (t),
13439 ffelex_token_where_column (t));
13440 /* Don't have to unset this one. */
13441 return (ffelexHandler) ffeexpr_token_apostrophe_;
13442
13443 case FFELEX_typePERCENT:
13444 ffeexpr_tokens_[0] = ffelex_token_use (t);
13445 return (ffelexHandler) ffeexpr_token_percent_;
13446
13447 case FFELEX_typeOPEN_PAREN:
13448 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
13449 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
13450 FFEEXPR_contextPAREN_,
13451 ffeexpr_cb_close_paren_c_);
13452
13453 case FFELEX_typePLUS:
13454 e = ffeexpr_expr_new_ ();
13455 e->type = FFEEXPR_exprtypeUNARY_;
13456 e->token = ffelex_token_use (t);
13457 e->u.operator.op = FFEEXPR_operatorADD_;
13458 e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
13459 e->u.operator.as = FFEEXPR_operatorassociativityADD_;
13460 ffeexpr_exprstack_push_unary_ (e);
13461 return (ffelexHandler) ffeexpr_token_rhs_;
13462
13463 case FFELEX_typeMINUS:
13464 e = ffeexpr_expr_new_ ();
13465 e->type = FFEEXPR_exprtypeUNARY_;
13466 e->token = ffelex_token_use (t);
13467 e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
13468 e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
13469 e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
13470 ffeexpr_exprstack_push_unary_ (e);
13471 return (ffelexHandler) ffeexpr_token_rhs_;
13472
13473 case FFELEX_typePERIOD:
13474 ffeexpr_tokens_[0] = ffelex_token_use (t);
13475 return (ffelexHandler) ffeexpr_token_period_;
13476
13477 case FFELEX_typeNUMBER:
13478 ffeexpr_tokens_[0] = ffelex_token_use (t);
13479 ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
13480 if (ffeexpr_hollerith_count_ > 0)
13481 ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
13482 '\0',
13483 ffelex_token_where_line (t),
13484 ffelex_token_where_column (t));
13485 return (ffelexHandler) ffeexpr_token_number_;
13486
13487 case FFELEX_typeNAME:
13488 case FFELEX_typeNAMES:
13489 ffeexpr_tokens_[0] = ffelex_token_use (t);
13490 switch (ffeexpr_stack_->context)
13491 {
13492 case FFEEXPR_contextACTUALARG_:
13493 case FFEEXPR_contextINDEXORACTUALARG_:
13494 case FFEEXPR_contextSFUNCDEFACTUALARG_:
13495 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
13496 return (ffelexHandler) ffeexpr_token_name_arg_;
13497
13498 default:
13499 return (ffelexHandler) ffeexpr_token_name_rhs_;
13500 }
13501
13502 case FFELEX_typeASTERISK:
13503 case FFELEX_typeSLASH:
13504 case FFELEX_typePOWER:
13505 case FFELEX_typeCONCAT:
13506 case FFELEX_typeREL_EQ:
13507 case FFELEX_typeREL_NE:
13508 case FFELEX_typeREL_LE:
13509 case FFELEX_typeREL_GE:
13510 if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
13511 {
13512 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13513 ffebad_finish ();
13514 }
13515 return (ffelexHandler) ffeexpr_token_rhs_;
13516
13517 #if 0
13518 case FFELEX_typeEQUALS:
13519 case FFELEX_typePOINTS:
13520 case FFELEX_typeCLOSE_ANGLE:
13521 case FFELEX_typeCLOSE_PAREN:
13522 case FFELEX_typeCOMMA:
13523 case FFELEX_typeCOLON:
13524 case FFELEX_typeEOS:
13525 case FFELEX_typeSEMICOLON:
13526 #endif
13527 default:
13528 return (ffelexHandler) ffeexpr_finished_ (t);
13529 }
13530 }
13531
13532 /* ffeexpr_token_period_ -- Rhs PERIOD
13533
13534 Return a pointer to this function to the lexer (ffelex), which will
13535 invoke it for the next token.
13536
13537 Handle a period detected at rhs (expecting unary op or operand) state.
13538 Must begin a floating-point value (as in .12) or a dot-dot name, of
13539 which only .NOT., .TRUE., and .FALSE. are truly valid. Other sort-of-
13540 valid names represent binary operators, which are invalid here because
13541 there isn't an operand at the top of the stack. */
13542
13543 static ffelexHandler
ffeexpr_token_period_(ffelexToken t)13544 ffeexpr_token_period_ (ffelexToken t)
13545 {
13546 switch (ffelex_token_type (t))
13547 {
13548 case FFELEX_typeNAME:
13549 case FFELEX_typeNAMES:
13550 ffeexpr_current_dotdot_ = ffestr_other (t);
13551 switch (ffeexpr_current_dotdot_)
13552 {
13553 case FFESTR_otherNone:
13554 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
13555 {
13556 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13557 ffelex_token_where_column (ffeexpr_tokens_[0]));
13558 ffebad_finish ();
13559 }
13560 ffelex_token_kill (ffeexpr_tokens_[0]);
13561 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13562
13563 case FFESTR_otherTRUE:
13564 case FFESTR_otherFALSE:
13565 case FFESTR_otherNOT:
13566 ffeexpr_tokens_[1] = ffelex_token_use (t);
13567 return (ffelexHandler) ffeexpr_token_end_period_;
13568
13569 default:
13570 if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
13571 {
13572 ffebad_here (0, ffelex_token_where_line (t),
13573 ffelex_token_where_column (t));
13574 ffebad_finish ();
13575 }
13576 ffelex_token_kill (ffeexpr_tokens_[0]);
13577 return (ffelexHandler) ffeexpr_token_swallow_period_;
13578 }
13579 break; /* Nothing really reaches here. */
13580
13581 case FFELEX_typeNUMBER:
13582 ffeexpr_tokens_[1] = ffelex_token_use (t);
13583 return (ffelexHandler) ffeexpr_token_real_;
13584
13585 default:
13586 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
13587 {
13588 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13589 ffelex_token_where_column (ffeexpr_tokens_[0]));
13590 ffebad_finish ();
13591 }
13592 ffelex_token_kill (ffeexpr_tokens_[0]);
13593 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13594 }
13595 }
13596
13597 /* ffeexpr_token_end_period_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
13598
13599 Return a pointer to this function to the lexer (ffelex), which will
13600 invoke it for the next token.
13601
13602 Expecting a period to close a .NOT, .TRUE, or .FALSE at rhs (unary op
13603 or operator) state. If period isn't found, issue a diagnostic but
13604 pretend we saw one. ffeexpr_current_dotdot_ must already contained the
13605 dotdot representation of the name in between the two PERIOD tokens. */
13606
13607 static ffelexHandler
ffeexpr_token_end_period_(ffelexToken t)13608 ffeexpr_token_end_period_ (ffelexToken t)
13609 {
13610 ffeexprExpr_ e;
13611
13612 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13613 {
13614 if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
13615 {
13616 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13617 ffelex_token_where_column (ffeexpr_tokens_[0]));
13618 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13619 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
13620 ffebad_finish ();
13621 }
13622 }
13623
13624 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill "NOT"/"TRUE"/"FALSE"
13625 token. */
13626
13627 e = ffeexpr_expr_new_ ();
13628 e->token = ffeexpr_tokens_[0];
13629
13630 switch (ffeexpr_current_dotdot_)
13631 {
13632 case FFESTR_otherNOT:
13633 e->type = FFEEXPR_exprtypeUNARY_;
13634 e->u.operator.op = FFEEXPR_operatorNOT_;
13635 e->u.operator.prec = FFEEXPR_operatorprecedenceNOT_;
13636 e->u.operator.as = FFEEXPR_operatorassociativityNOT_;
13637 ffeexpr_exprstack_push_unary_ (e);
13638 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13639 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13640 return (ffelexHandler) ffeexpr_token_rhs_;
13641
13642 case FFESTR_otherTRUE:
13643 e->type = FFEEXPR_exprtypeOPERAND_;
13644 e->u.operand
13645 = ffebld_new_conter (ffebld_constant_new_logicaldefault (TRUE));
13646 ffebld_set_info (e->u.operand,
13647 ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
13648 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13649 ffeexpr_exprstack_push_operand_ (e);
13650 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13651 return (ffelexHandler) ffeexpr_token_binary_ (t);
13652 return (ffelexHandler) ffeexpr_token_binary_;
13653
13654 case FFESTR_otherFALSE:
13655 e->type = FFEEXPR_exprtypeOPERAND_;
13656 e->u.operand
13657 = ffebld_new_conter (ffebld_constant_new_logicaldefault (FALSE));
13658 ffebld_set_info (e->u.operand,
13659 ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
13660 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13661 ffeexpr_exprstack_push_operand_ (e);
13662 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13663 return (ffelexHandler) ffeexpr_token_binary_ (t);
13664 return (ffelexHandler) ffeexpr_token_binary_;
13665
13666 default:
13667 assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL);
13668 exit (0);
13669 return NULL;
13670 }
13671 }
13672
13673 /* ffeexpr_token_swallow_period_ -- Rhs PERIOD NAME(not NOT, TRUE, or FALSE)
13674
13675 Return a pointer to this function to the lexer (ffelex), which will
13676 invoke it for the next token.
13677
13678 A diagnostic has already been issued; just swallow a period if there is
13679 one, then continue with ffeexpr_token_rhs_. */
13680
13681 static ffelexHandler
ffeexpr_token_swallow_period_(ffelexToken t)13682 ffeexpr_token_swallow_period_ (ffelexToken t)
13683 {
13684 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13685 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13686
13687 return (ffelexHandler) ffeexpr_token_rhs_;
13688 }
13689
13690 /* ffeexpr_token_real_ -- Rhs PERIOD NUMBER
13691
13692 Return a pointer to this function to the lexer (ffelex), which will
13693 invoke it for the next token.
13694
13695 After a period and a string of digits, check next token for possible
13696 exponent designation (D, E, or Q as first/only character) and continue
13697 real-number handling accordingly. Else form basic real constant, push
13698 onto expression stack, and enter binary state using current token (which,
13699 if it is a name not beginning with D, E, or Q, will certainly result
13700 in an error, but that's not for this routine to deal with). */
13701
13702 static ffelexHandler
ffeexpr_token_real_(ffelexToken t)13703 ffeexpr_token_real_ (ffelexToken t)
13704 {
13705 char d;
13706 const char *p;
13707
13708 if (((ffelex_token_type (t) != FFELEX_typeNAME)
13709 && (ffelex_token_type (t) != FFELEX_typeNAMES))
13710 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13711 'D', 'd')
13712 || ffesrc_char_match_init (d, 'E', 'e')
13713 || ffesrc_char_match_init (d, 'Q', 'q')))
13714 && ffeexpr_isdigits_ (++p)))
13715 {
13716 #if 0
13717 /* This code has been removed because it seems inconsistent to
13718 produce a diagnostic in this case, but not all of the other
13719 ones that look for an exponent and cannot recognize one. */
13720 if (((ffelex_token_type (t) == FFELEX_typeNAME)
13721 || (ffelex_token_type (t) == FFELEX_typeNAMES))
13722 && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
13723 {
13724 char bad[2];
13725
13726 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13727 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
13728 ffelex_token_where_column (ffeexpr_tokens_[0]));
13729 bad[0] = *(p - 1);
13730 bad[1] = '\0';
13731 ffebad_string (bad);
13732 ffebad_finish ();
13733 }
13734 #endif
13735 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13736 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13737 NULL, NULL, NULL);
13738
13739 ffelex_token_kill (ffeexpr_tokens_[0]);
13740 ffelex_token_kill (ffeexpr_tokens_[1]);
13741 return (ffelexHandler) ffeexpr_token_binary_ (t);
13742 }
13743
13744 /* Just exponent character by itself? In which case, PLUS or MINUS must
13745 surely be next, followed by a NUMBER token. */
13746
13747 if (*p == '\0')
13748 {
13749 ffeexpr_tokens_[2] = ffelex_token_use (t);
13750 return (ffelexHandler) ffeexpr_token_real_exponent_;
13751 }
13752
13753 ffeexpr_make_float_const_ (d, NULL, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13754 t, NULL, NULL);
13755
13756 ffelex_token_kill (ffeexpr_tokens_[0]);
13757 ffelex_token_kill (ffeexpr_tokens_[1]);
13758 return (ffelexHandler) ffeexpr_token_binary_;
13759 }
13760
13761 /* ffeexpr_token_real_exponent_ -- Rhs PERIOD NUMBER NAME(D, E, or Q)
13762
13763 Return a pointer to this function to the lexer (ffelex), which will
13764 invoke it for the next token.
13765
13766 Ensures this token is PLUS or MINUS, preserves it, goes to final state
13767 for real number (exponent digits). Else issues diagnostic, assumes a
13768 zero exponent field for number, passes token on to binary state as if
13769 previous token had been "E0" instead of "E", for example. */
13770
13771 static ffelexHandler
ffeexpr_token_real_exponent_(ffelexToken t)13772 ffeexpr_token_real_exponent_ (ffelexToken t)
13773 {
13774 if ((ffelex_token_type (t) != FFELEX_typePLUS)
13775 && (ffelex_token_type (t) != FFELEX_typeMINUS))
13776 {
13777 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13778 {
13779 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
13780 ffelex_token_where_column (ffeexpr_tokens_[2]));
13781 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13782 ffebad_finish ();
13783 }
13784
13785 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13786 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13787 NULL, NULL, NULL);
13788
13789 ffelex_token_kill (ffeexpr_tokens_[0]);
13790 ffelex_token_kill (ffeexpr_tokens_[1]);
13791 ffelex_token_kill (ffeexpr_tokens_[2]);
13792 return (ffelexHandler) ffeexpr_token_binary_ (t);
13793 }
13794
13795 ffeexpr_tokens_[3] = ffelex_token_use (t);
13796 return (ffelexHandler) ffeexpr_token_real_exp_sign_;
13797 }
13798
13799 /* ffeexpr_token_real_exp_sign_ -- Rhs PERIOD NUMBER NAME(D,E,Q) PLUS/MINUS
13800
13801 Return a pointer to this function to the lexer (ffelex), which will
13802 invoke it for the next token.
13803
13804 Make sure token is a NUMBER, make a real constant out of all we have and
13805 push it onto the expression stack. Else issue diagnostic and pretend
13806 exponent field was a zero. */
13807
13808 static ffelexHandler
ffeexpr_token_real_exp_sign_(ffelexToken t)13809 ffeexpr_token_real_exp_sign_ (ffelexToken t)
13810 {
13811 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13812 {
13813 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13814 {
13815 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
13816 ffelex_token_where_column (ffeexpr_tokens_[2]));
13817 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13818 ffebad_finish ();
13819 }
13820
13821 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13822 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13823 NULL, NULL, NULL);
13824
13825 ffelex_token_kill (ffeexpr_tokens_[0]);
13826 ffelex_token_kill (ffeexpr_tokens_[1]);
13827 ffelex_token_kill (ffeexpr_tokens_[2]);
13828 ffelex_token_kill (ffeexpr_tokens_[3]);
13829 return (ffelexHandler) ffeexpr_token_binary_ (t);
13830 }
13831
13832 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0], NULL,
13833 ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2],
13834 ffeexpr_tokens_[3], t);
13835
13836 ffelex_token_kill (ffeexpr_tokens_[0]);
13837 ffelex_token_kill (ffeexpr_tokens_[1]);
13838 ffelex_token_kill (ffeexpr_tokens_[2]);
13839 ffelex_token_kill (ffeexpr_tokens_[3]);
13840 return (ffelexHandler) ffeexpr_token_binary_;
13841 }
13842
13843 /* ffeexpr_token_number_ -- Rhs NUMBER
13844
13845 Return a pointer to this function to the lexer (ffelex), which will
13846 invoke it for the next token.
13847
13848 If the token is a period, we may have a floating-point number, or an
13849 integer followed by a dotdot binary operator. If the token is a name
13850 beginning with D, E, or Q, we definitely have a floating-point number.
13851 If the token is a hollerith constant, that's what we've got, so push
13852 it onto the expression stack and continue with the binary state.
13853
13854 Otherwise, we have an integer followed by something the binary state
13855 should be able to swallow. */
13856
13857 static ffelexHandler
ffeexpr_token_number_(ffelexToken t)13858 ffeexpr_token_number_ (ffelexToken t)
13859 {
13860 ffeexprExpr_ e;
13861 ffeinfo ni;
13862 char d;
13863 const char *p;
13864
13865 if (ffeexpr_hollerith_count_ > 0)
13866 ffelex_set_expecting_hollerith (0, '\0',
13867 ffewhere_line_unknown (),
13868 ffewhere_column_unknown ());
13869
13870 /* See if we've got a floating-point number here. */
13871
13872 switch (ffelex_token_type (t))
13873 {
13874 case FFELEX_typeNAME:
13875 case FFELEX_typeNAMES:
13876 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13877 'D', 'd')
13878 || ffesrc_char_match_init (d, 'E', 'e')
13879 || ffesrc_char_match_init (d, 'Q', 'q'))
13880 && ffeexpr_isdigits_ (++p))
13881 {
13882
13883 /* Just exponent character by itself? In which case, PLUS or MINUS
13884 must surely be next, followed by a NUMBER token. */
13885
13886 if (*p == '\0')
13887 {
13888 ffeexpr_tokens_[1] = ffelex_token_use (t);
13889 return (ffelexHandler) ffeexpr_token_number_exponent_;
13890 }
13891 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], NULL, NULL, t,
13892 NULL, NULL);
13893
13894 ffelex_token_kill (ffeexpr_tokens_[0]);
13895 return (ffelexHandler) ffeexpr_token_binary_;
13896 }
13897 break;
13898
13899 case FFELEX_typePERIOD:
13900 ffeexpr_tokens_[1] = ffelex_token_use (t);
13901 return (ffelexHandler) ffeexpr_token_number_period_;
13902
13903 case FFELEX_typeHOLLERITH:
13904 e = ffeexpr_expr_new_ ();
13905 e->type = FFEEXPR_exprtypeOPERAND_;
13906 e->token = ffeexpr_tokens_[0];
13907 e->u.operand = ffebld_new_conter (ffebld_constant_new_hollerith (t));
13908 ni = ffeinfo_new (FFEINFO_basictypeHOLLERITH, FFEINFO_kindtypeNONE,
13909 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
13910 ffelex_token_length (t));
13911 ffebld_set_info (e->u.operand, ni);
13912 ffeexpr_exprstack_push_operand_ (e);
13913 return (ffelexHandler) ffeexpr_token_binary_;
13914
13915 default:
13916 break;
13917 }
13918
13919 /* Nothing specific we were looking for, so make an integer and pass the
13920 current token to the binary state. */
13921
13922 ffeexpr_make_float_const_ ('I', ffeexpr_tokens_[0], NULL, NULL,
13923 NULL, NULL, NULL);
13924 return (ffelexHandler) ffeexpr_token_binary_ (t);
13925 }
13926
13927 /* ffeexpr_token_number_exponent_ -- Rhs NUMBER NAME(D, E, or Q)
13928
13929 Return a pointer to this function to the lexer (ffelex), which will
13930 invoke it for the next token.
13931
13932 Ensures this token is PLUS or MINUS, preserves it, goes to final state
13933 for real number (exponent digits). Else treats number as integer, passes
13934 name to binary, passes current token to subsequent handler. */
13935
13936 static ffelexHandler
ffeexpr_token_number_exponent_(ffelexToken t)13937 ffeexpr_token_number_exponent_ (ffelexToken t)
13938 {
13939 if ((ffelex_token_type (t) != FFELEX_typePLUS)
13940 && (ffelex_token_type (t) != FFELEX_typeMINUS))
13941 {
13942 ffeexprExpr_ e;
13943 ffelexHandler nexthandler;
13944
13945 e = ffeexpr_expr_new_ ();
13946 e->type = FFEEXPR_exprtypeOPERAND_;
13947 e->token = ffeexpr_tokens_[0];
13948 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
13949 (ffeexpr_tokens_[0]));
13950 ffebld_set_info (e->u.operand,
13951 ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT,
13952 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13953 ffeexpr_exprstack_push_operand_ (e);
13954 nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[1]);
13955 ffelex_token_kill (ffeexpr_tokens_[1]);
13956 return (ffelexHandler) (*nexthandler) (t);
13957 }
13958
13959 ffeexpr_tokens_[2] = ffelex_token_use (t);
13960 return (ffelexHandler) ffeexpr_token_number_exp_sign_;
13961 }
13962
13963 /* ffeexpr_token_number_exp_sign_ -- Rhs NUMBER NAME(D,E,Q) PLUS/MINUS
13964
13965 Return a pointer to this function to the lexer (ffelex), which will
13966 invoke it for the next token.
13967
13968 Make sure token is a NUMBER, make a real constant out of all we have and
13969 push it onto the expression stack. Else issue diagnostic and pretend
13970 exponent field was a zero. */
13971
13972 static ffelexHandler
ffeexpr_token_number_exp_sign_(ffelexToken t)13973 ffeexpr_token_number_exp_sign_ (ffelexToken t)
13974 {
13975 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13976 {
13977 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13978 {
13979 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[1]),
13980 ffelex_token_where_column (ffeexpr_tokens_[1]));
13981 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13982 ffebad_finish ();
13983 }
13984
13985 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
13986 ffeexpr_tokens_[0], NULL, NULL,
13987 ffeexpr_tokens_[1], ffeexpr_tokens_[2],
13988 NULL);
13989
13990 ffelex_token_kill (ffeexpr_tokens_[0]);
13991 ffelex_token_kill (ffeexpr_tokens_[1]);
13992 ffelex_token_kill (ffeexpr_tokens_[2]);
13993 return (ffelexHandler) ffeexpr_token_binary_ (t);
13994 }
13995
13996 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
13997 ffeexpr_tokens_[0], NULL, NULL,
13998 ffeexpr_tokens_[1], ffeexpr_tokens_[2], t);
13999
14000 ffelex_token_kill (ffeexpr_tokens_[0]);
14001 ffelex_token_kill (ffeexpr_tokens_[1]);
14002 ffelex_token_kill (ffeexpr_tokens_[2]);
14003 return (ffelexHandler) ffeexpr_token_binary_;
14004 }
14005
14006 /* ffeexpr_token_number_period_ -- Rhs NUMBER PERIOD
14007
14008 Return a pointer to this function to the lexer (ffelex), which will
14009 invoke it for the next token.
14010
14011 Handle a period detected following a number at rhs state. Must begin a
14012 floating-point value (as in 1., 1.2, 1.E3, or 1.E+3) or a dot-dot name. */
14013
14014 static ffelexHandler
ffeexpr_token_number_period_(ffelexToken t)14015 ffeexpr_token_number_period_ (ffelexToken t)
14016 {
14017 ffeexprExpr_ e;
14018 ffelexHandler nexthandler;
14019 const char *p;
14020 char d;
14021
14022 switch (ffelex_token_type (t))
14023 {
14024 case FFELEX_typeNAME:
14025 case FFELEX_typeNAMES:
14026 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
14027 'D', 'd')
14028 || ffesrc_char_match_init (d, 'E', 'e')
14029 || ffesrc_char_match_init (d, 'Q', 'q'))
14030 && ffeexpr_isdigits_ (++p))
14031 {
14032
14033 /* Just exponent character by itself? In which case, PLUS or MINUS
14034 must surely be next, followed by a NUMBER token. */
14035
14036 if (*p == '\0')
14037 {
14038 ffeexpr_tokens_[2] = ffelex_token_use (t);
14039 return (ffelexHandler) ffeexpr_token_number_per_exp_;
14040 }
14041 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0],
14042 ffeexpr_tokens_[1], NULL, t, NULL,
14043 NULL);
14044
14045 ffelex_token_kill (ffeexpr_tokens_[0]);
14046 ffelex_token_kill (ffeexpr_tokens_[1]);
14047 return (ffelexHandler) ffeexpr_token_binary_;
14048 }
14049 /* A name not representing an exponent, so assume it will be something
14050 like EQ, make an integer from the number, pass the period to binary
14051 state and the current token to the resulting state. */
14052
14053 e = ffeexpr_expr_new_ ();
14054 e->type = FFEEXPR_exprtypeOPERAND_;
14055 e->token = ffeexpr_tokens_[0];
14056 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
14057 (ffeexpr_tokens_[0]));
14058 ffebld_set_info (e->u.operand,
14059 ffeinfo_new (FFEINFO_basictypeINTEGER,
14060 FFEINFO_kindtypeINTEGERDEFAULT, 0,
14061 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14062 FFETARGET_charactersizeNONE));
14063 ffeexpr_exprstack_push_operand_ (e);
14064 nexthandler = (ffelexHandler) ffeexpr_token_binary_
14065 (ffeexpr_tokens_[1]);
14066 ffelex_token_kill (ffeexpr_tokens_[1]);
14067 return (ffelexHandler) (*nexthandler) (t);
14068
14069 case FFELEX_typeNUMBER:
14070 ffeexpr_tokens_[2] = ffelex_token_use (t);
14071 return (ffelexHandler) ffeexpr_token_number_real_;
14072
14073 default:
14074 break;
14075 }
14076
14077 /* Nothing specific we were looking for, so make a real number and pass the
14078 period and then the current token to the binary state. */
14079
14080 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14081 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14082 NULL, NULL, NULL, NULL);
14083
14084 ffelex_token_kill (ffeexpr_tokens_[0]);
14085 ffelex_token_kill (ffeexpr_tokens_[1]);
14086 return (ffelexHandler) ffeexpr_token_binary_ (t);
14087 }
14088
14089 /* ffeexpr_token_number_per_exp_ -- Rhs NUMBER PERIOD NAME(D, E, or Q)
14090
14091 Return a pointer to this function to the lexer (ffelex), which will
14092 invoke it for the next token.
14093
14094 Ensures this token is PLUS or MINUS, preserves it, goes to final state
14095 for real number (exponent digits). Else treats number as real, passes
14096 name to binary, passes current token to subsequent handler. */
14097
14098 static ffelexHandler
ffeexpr_token_number_per_exp_(ffelexToken t)14099 ffeexpr_token_number_per_exp_ (ffelexToken t)
14100 {
14101 if ((ffelex_token_type (t) != FFELEX_typePLUS)
14102 && (ffelex_token_type (t) != FFELEX_typeMINUS))
14103 {
14104 ffelexHandler nexthandler;
14105
14106 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14107 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14108 NULL, NULL, NULL, NULL);
14109
14110 ffelex_token_kill (ffeexpr_tokens_[0]);
14111 ffelex_token_kill (ffeexpr_tokens_[1]);
14112 nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[2]);
14113 ffelex_token_kill (ffeexpr_tokens_[2]);
14114 return (ffelexHandler) (*nexthandler) (t);
14115 }
14116
14117 ffeexpr_tokens_[3] = ffelex_token_use (t);
14118 return (ffelexHandler) ffeexpr_token_num_per_exp_sign_;
14119 }
14120
14121 /* ffeexpr_token_number_real_ -- Rhs NUMBER PERIOD NUMBER
14122
14123 Return a pointer to this function to the lexer (ffelex), which will
14124 invoke it for the next token.
14125
14126 After a number, period, and number, check next token for possible
14127 exponent designation (D, E, or Q as first/only character) and continue
14128 real-number handling accordingly. Else form basic real constant, push
14129 onto expression stack, and enter binary state using current token (which,
14130 if it is a name not beginning with D, E, or Q, will certainly result
14131 in an error, but that's not for this routine to deal with). */
14132
14133 static ffelexHandler
ffeexpr_token_number_real_(ffelexToken t)14134 ffeexpr_token_number_real_ (ffelexToken t)
14135 {
14136 char d;
14137 const char *p;
14138
14139 if (((ffelex_token_type (t) != FFELEX_typeNAME)
14140 && (ffelex_token_type (t) != FFELEX_typeNAMES))
14141 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
14142 'D', 'd')
14143 || ffesrc_char_match_init (d, 'E', 'e')
14144 || ffesrc_char_match_init (d, 'Q', 'q')))
14145 && ffeexpr_isdigits_ (++p)))
14146 {
14147 #if 0
14148 /* This code has been removed because it seems inconsistent to
14149 produce a diagnostic in this case, but not all of the other
14150 ones that look for an exponent and cannot recognize one. */
14151 if (((ffelex_token_type (t) == FFELEX_typeNAME)
14152 || (ffelex_token_type (t) == FFELEX_typeNAMES))
14153 && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
14154 {
14155 char bad[2];
14156
14157 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14158 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
14159 ffelex_token_where_column (ffeexpr_tokens_[0]));
14160 bad[0] = *(p - 1);
14161 bad[1] = '\0';
14162 ffebad_string (bad);
14163 ffebad_finish ();
14164 }
14165 #endif
14166 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14167 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14168 ffeexpr_tokens_[2], NULL, NULL, NULL);
14169
14170 ffelex_token_kill (ffeexpr_tokens_[0]);
14171 ffelex_token_kill (ffeexpr_tokens_[1]);
14172 ffelex_token_kill (ffeexpr_tokens_[2]);
14173 return (ffelexHandler) ffeexpr_token_binary_ (t);
14174 }
14175
14176 /* Just exponent character by itself? In which case, PLUS or MINUS must
14177 surely be next, followed by a NUMBER token. */
14178
14179 if (*p == '\0')
14180 {
14181 ffeexpr_tokens_[3] = ffelex_token_use (t);
14182 return (ffelexHandler) ffeexpr_token_number_real_exp_;
14183 }
14184
14185 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14186 ffeexpr_tokens_[2], t, NULL, NULL);
14187
14188 ffelex_token_kill (ffeexpr_tokens_[0]);
14189 ffelex_token_kill (ffeexpr_tokens_[1]);
14190 ffelex_token_kill (ffeexpr_tokens_[2]);
14191 return (ffelexHandler) ffeexpr_token_binary_;
14192 }
14193
14194 /* ffeexpr_token_num_per_exp_sign_ -- Rhs NUMBER PERIOD NAME(D,E,Q) PLUS/MINUS
14195
14196 Return a pointer to this function to the lexer (ffelex), which will
14197 invoke it for the next token.
14198
14199 Make sure token is a NUMBER, make a real constant out of all we have and
14200 push it onto the expression stack. Else issue diagnostic and pretend
14201 exponent field was a zero. */
14202
14203 static ffelexHandler
ffeexpr_token_num_per_exp_sign_(ffelexToken t)14204 ffeexpr_token_num_per_exp_sign_ (ffelexToken t)
14205 {
14206 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14207 {
14208 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14209 {
14210 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
14211 ffelex_token_where_column (ffeexpr_tokens_[2]));
14212 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14213 ffebad_finish ();
14214 }
14215
14216 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14217 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14218 NULL, NULL, NULL, NULL);
14219
14220 ffelex_token_kill (ffeexpr_tokens_[0]);
14221 ffelex_token_kill (ffeexpr_tokens_[1]);
14222 ffelex_token_kill (ffeexpr_tokens_[2]);
14223 ffelex_token_kill (ffeexpr_tokens_[3]);
14224 return (ffelexHandler) ffeexpr_token_binary_ (t);
14225 }
14226
14227 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0],
14228 ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL,
14229 ffeexpr_tokens_[2], ffeexpr_tokens_[3], t);
14230
14231 ffelex_token_kill (ffeexpr_tokens_[0]);
14232 ffelex_token_kill (ffeexpr_tokens_[1]);
14233 ffelex_token_kill (ffeexpr_tokens_[2]);
14234 ffelex_token_kill (ffeexpr_tokens_[3]);
14235 return (ffelexHandler) ffeexpr_token_binary_;
14236 }
14237
14238 /* ffeexpr_token_number_real_exp_ -- Rhs NUMBER PERIOD NUMBER NAME(D, E, or Q)
14239
14240 Return a pointer to this function to the lexer (ffelex), which will
14241 invoke it for the next token.
14242
14243 Ensures this token is PLUS or MINUS, preserves it, goes to final state
14244 for real number (exponent digits). Else issues diagnostic, assumes a
14245 zero exponent field for number, passes token on to binary state as if
14246 previous token had been "E0" instead of "E", for example. */
14247
14248 static ffelexHandler
ffeexpr_token_number_real_exp_(ffelexToken t)14249 ffeexpr_token_number_real_exp_ (ffelexToken t)
14250 {
14251 if ((ffelex_token_type (t) != FFELEX_typePLUS)
14252 && (ffelex_token_type (t) != FFELEX_typeMINUS))
14253 {
14254 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14255 {
14256 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
14257 ffelex_token_where_column (ffeexpr_tokens_[3]));
14258 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14259 ffebad_finish ();
14260 }
14261
14262 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14263 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14264 ffeexpr_tokens_[2], NULL, NULL, NULL);
14265
14266 ffelex_token_kill (ffeexpr_tokens_[0]);
14267 ffelex_token_kill (ffeexpr_tokens_[1]);
14268 ffelex_token_kill (ffeexpr_tokens_[2]);
14269 ffelex_token_kill (ffeexpr_tokens_[3]);
14270 return (ffelexHandler) ffeexpr_token_binary_ (t);
14271 }
14272
14273 ffeexpr_tokens_[4] = ffelex_token_use (t);
14274 return (ffelexHandler) ffeexpr_token_num_real_exp_sn_;
14275 }
14276
14277 /* ffeexpr_token_num_real_exp_sn_ -- Rhs NUMBER PERIOD NUMBER NAME(D,E,Q)
14278 PLUS/MINUS
14279
14280 Return a pointer to this function to the lexer (ffelex), which will
14281 invoke it for the next token.
14282
14283 Make sure token is a NUMBER, make a real constant out of all we have and
14284 push it onto the expression stack. Else issue diagnostic and pretend
14285 exponent field was a zero. */
14286
14287 static ffelexHandler
ffeexpr_token_num_real_exp_sn_(ffelexToken t)14288 ffeexpr_token_num_real_exp_sn_ (ffelexToken t)
14289 {
14290 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14291 {
14292 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14293 {
14294 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
14295 ffelex_token_where_column (ffeexpr_tokens_[3]));
14296 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14297 ffebad_finish ();
14298 }
14299
14300 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14301 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14302 ffeexpr_tokens_[2], NULL, NULL, NULL);
14303
14304 ffelex_token_kill (ffeexpr_tokens_[0]);
14305 ffelex_token_kill (ffeexpr_tokens_[1]);
14306 ffelex_token_kill (ffeexpr_tokens_[2]);
14307 ffelex_token_kill (ffeexpr_tokens_[3]);
14308 ffelex_token_kill (ffeexpr_tokens_[4]);
14309 return (ffelexHandler) ffeexpr_token_binary_ (t);
14310 }
14311
14312 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[3])[0],
14313 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14314 ffeexpr_tokens_[2], ffeexpr_tokens_[3],
14315 ffeexpr_tokens_[4], t);
14316
14317 ffelex_token_kill (ffeexpr_tokens_[0]);
14318 ffelex_token_kill (ffeexpr_tokens_[1]);
14319 ffelex_token_kill (ffeexpr_tokens_[2]);
14320 ffelex_token_kill (ffeexpr_tokens_[3]);
14321 ffelex_token_kill (ffeexpr_tokens_[4]);
14322 return (ffelexHandler) ffeexpr_token_binary_;
14323 }
14324
14325 /* ffeexpr_token_binary_ -- Handle binary operator possibility
14326
14327 Return a pointer to this function to the lexer (ffelex), which will
14328 invoke it for the next token.
14329
14330 The possibility of a binary operator is handled here, meaning the previous
14331 token was an operand. */
14332
14333 static ffelexHandler
ffeexpr_token_binary_(ffelexToken t)14334 ffeexpr_token_binary_ (ffelexToken t)
14335 {
14336 ffeexprExpr_ e;
14337
14338 if (!ffeexpr_stack_->is_rhs)
14339 return (ffelexHandler) ffeexpr_finished_ (t); /* For now. */
14340
14341 switch (ffelex_token_type (t))
14342 {
14343 case FFELEX_typePLUS:
14344 e = ffeexpr_expr_new_ ();
14345 e->type = FFEEXPR_exprtypeBINARY_;
14346 e->token = ffelex_token_use (t);
14347 e->u.operator.op = FFEEXPR_operatorADD_;
14348 e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
14349 e->u.operator.as = FFEEXPR_operatorassociativityADD_;
14350 ffeexpr_exprstack_push_binary_ (e);
14351 return (ffelexHandler) ffeexpr_token_rhs_;
14352
14353 case FFELEX_typeMINUS:
14354 e = ffeexpr_expr_new_ ();
14355 e->type = FFEEXPR_exprtypeBINARY_;
14356 e->token = ffelex_token_use (t);
14357 e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
14358 e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
14359 e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
14360 ffeexpr_exprstack_push_binary_ (e);
14361 return (ffelexHandler) ffeexpr_token_rhs_;
14362
14363 case FFELEX_typeASTERISK:
14364 switch (ffeexpr_stack_->context)
14365 {
14366 case FFEEXPR_contextDATA:
14367 return (ffelexHandler) ffeexpr_finished_ (t);
14368
14369 default:
14370 break;
14371 }
14372 e = ffeexpr_expr_new_ ();
14373 e->type = FFEEXPR_exprtypeBINARY_;
14374 e->token = ffelex_token_use (t);
14375 e->u.operator.op = FFEEXPR_operatorMULTIPLY_;
14376 e->u.operator.prec = FFEEXPR_operatorprecedenceMULTIPLY_;
14377 e->u.operator.as = FFEEXPR_operatorassociativityMULTIPLY_;
14378 ffeexpr_exprstack_push_binary_ (e);
14379 return (ffelexHandler) ffeexpr_token_rhs_;
14380
14381 case FFELEX_typeSLASH:
14382 switch (ffeexpr_stack_->context)
14383 {
14384 case FFEEXPR_contextDATA:
14385 return (ffelexHandler) ffeexpr_finished_ (t);
14386
14387 default:
14388 break;
14389 }
14390 e = ffeexpr_expr_new_ ();
14391 e->type = FFEEXPR_exprtypeBINARY_;
14392 e->token = ffelex_token_use (t);
14393 e->u.operator.op = FFEEXPR_operatorDIVIDE_;
14394 e->u.operator.prec = FFEEXPR_operatorprecedenceDIVIDE_;
14395 e->u.operator.as = FFEEXPR_operatorassociativityDIVIDE_;
14396 ffeexpr_exprstack_push_binary_ (e);
14397 return (ffelexHandler) ffeexpr_token_rhs_;
14398
14399 case FFELEX_typePOWER:
14400 e = ffeexpr_expr_new_ ();
14401 e->type = FFEEXPR_exprtypeBINARY_;
14402 e->token = ffelex_token_use (t);
14403 e->u.operator.op = FFEEXPR_operatorPOWER_;
14404 e->u.operator.prec = FFEEXPR_operatorprecedencePOWER_;
14405 e->u.operator.as = FFEEXPR_operatorassociativityPOWER_;
14406 ffeexpr_exprstack_push_binary_ (e);
14407 return (ffelexHandler) ffeexpr_token_rhs_;
14408
14409 case FFELEX_typeCONCAT:
14410 e = ffeexpr_expr_new_ ();
14411 e->type = FFEEXPR_exprtypeBINARY_;
14412 e->token = ffelex_token_use (t);
14413 e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
14414 e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
14415 e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
14416 ffeexpr_exprstack_push_binary_ (e);
14417 return (ffelexHandler) ffeexpr_token_rhs_;
14418
14419 case FFELEX_typeOPEN_ANGLE:
14420 switch (ffeexpr_stack_->context)
14421 {
14422 case FFEEXPR_contextFORMAT:
14423 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14424 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14425 ffebad_finish ();
14426 break;
14427
14428 default:
14429 break;
14430 }
14431 e = ffeexpr_expr_new_ ();
14432 e->type = FFEEXPR_exprtypeBINARY_;
14433 e->token = ffelex_token_use (t);
14434 e->u.operator.op = FFEEXPR_operatorLT_;
14435 e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
14436 e->u.operator.as = FFEEXPR_operatorassociativityLT_;
14437 ffeexpr_exprstack_push_binary_ (e);
14438 return (ffelexHandler) ffeexpr_token_rhs_;
14439
14440 case FFELEX_typeCLOSE_ANGLE:
14441 switch (ffeexpr_stack_->context)
14442 {
14443 case FFEEXPR_contextFORMAT:
14444 return ffeexpr_finished_ (t);
14445
14446 default:
14447 break;
14448 }
14449 e = ffeexpr_expr_new_ ();
14450 e->type = FFEEXPR_exprtypeBINARY_;
14451 e->token = ffelex_token_use (t);
14452 e->u.operator.op = FFEEXPR_operatorGT_;
14453 e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
14454 e->u.operator.as = FFEEXPR_operatorassociativityGT_;
14455 ffeexpr_exprstack_push_binary_ (e);
14456 return (ffelexHandler) ffeexpr_token_rhs_;
14457
14458 case FFELEX_typeREL_EQ:
14459 switch (ffeexpr_stack_->context)
14460 {
14461 case FFEEXPR_contextFORMAT:
14462 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14463 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14464 ffebad_finish ();
14465 break;
14466
14467 default:
14468 break;
14469 }
14470 e = ffeexpr_expr_new_ ();
14471 e->type = FFEEXPR_exprtypeBINARY_;
14472 e->token = ffelex_token_use (t);
14473 e->u.operator.op = FFEEXPR_operatorEQ_;
14474 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
14475 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
14476 ffeexpr_exprstack_push_binary_ (e);
14477 return (ffelexHandler) ffeexpr_token_rhs_;
14478
14479 case FFELEX_typeREL_NE:
14480 switch (ffeexpr_stack_->context)
14481 {
14482 case FFEEXPR_contextFORMAT:
14483 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14484 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14485 ffebad_finish ();
14486 break;
14487
14488 default:
14489 break;
14490 }
14491 e = ffeexpr_expr_new_ ();
14492 e->type = FFEEXPR_exprtypeBINARY_;
14493 e->token = ffelex_token_use (t);
14494 e->u.operator.op = FFEEXPR_operatorNE_;
14495 e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
14496 e->u.operator.as = FFEEXPR_operatorassociativityNE_;
14497 ffeexpr_exprstack_push_binary_ (e);
14498 return (ffelexHandler) ffeexpr_token_rhs_;
14499
14500 case FFELEX_typeREL_LE:
14501 switch (ffeexpr_stack_->context)
14502 {
14503 case FFEEXPR_contextFORMAT:
14504 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14505 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14506 ffebad_finish ();
14507 break;
14508
14509 default:
14510 break;
14511 }
14512 e = ffeexpr_expr_new_ ();
14513 e->type = FFEEXPR_exprtypeBINARY_;
14514 e->token = ffelex_token_use (t);
14515 e->u.operator.op = FFEEXPR_operatorLE_;
14516 e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
14517 e->u.operator.as = FFEEXPR_operatorassociativityLE_;
14518 ffeexpr_exprstack_push_binary_ (e);
14519 return (ffelexHandler) ffeexpr_token_rhs_;
14520
14521 case FFELEX_typeREL_GE:
14522 switch (ffeexpr_stack_->context)
14523 {
14524 case FFEEXPR_contextFORMAT:
14525 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14526 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14527 ffebad_finish ();
14528 break;
14529
14530 default:
14531 break;
14532 }
14533 e = ffeexpr_expr_new_ ();
14534 e->type = FFEEXPR_exprtypeBINARY_;
14535 e->token = ffelex_token_use (t);
14536 e->u.operator.op = FFEEXPR_operatorGE_;
14537 e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
14538 e->u.operator.as = FFEEXPR_operatorassociativityGE_;
14539 ffeexpr_exprstack_push_binary_ (e);
14540 return (ffelexHandler) ffeexpr_token_rhs_;
14541
14542 case FFELEX_typePERIOD:
14543 ffeexpr_tokens_[0] = ffelex_token_use (t);
14544 return (ffelexHandler) ffeexpr_token_binary_period_;
14545
14546 #if 0
14547 case FFELEX_typeOPEN_PAREN:
14548 case FFELEX_typeCLOSE_PAREN:
14549 case FFELEX_typeEQUALS:
14550 case FFELEX_typePOINTS:
14551 case FFELEX_typeCOMMA:
14552 case FFELEX_typeCOLON:
14553 case FFELEX_typeEOS:
14554 case FFELEX_typeSEMICOLON:
14555 case FFELEX_typeNAME:
14556 case FFELEX_typeNAMES:
14557 #endif
14558 default:
14559 return (ffelexHandler) ffeexpr_finished_ (t);
14560 }
14561 }
14562
14563 /* ffeexpr_token_binary_period_ -- Binary PERIOD
14564
14565 Return a pointer to this function to the lexer (ffelex), which will
14566 invoke it for the next token.
14567
14568 Handle a period detected at binary (expecting binary op or end) state.
14569 Must begin a dot-dot name, of which .NOT., .TRUE., and .FALSE. are not
14570 valid. */
14571
14572 static ffelexHandler
ffeexpr_token_binary_period_(ffelexToken t)14573 ffeexpr_token_binary_period_ (ffelexToken t)
14574 {
14575 ffeexprExpr_ operand;
14576
14577 switch (ffelex_token_type (t))
14578 {
14579 case FFELEX_typeNAME:
14580 case FFELEX_typeNAMES:
14581 ffeexpr_current_dotdot_ = ffestr_other (t);
14582 switch (ffeexpr_current_dotdot_)
14583 {
14584 case FFESTR_otherTRUE:
14585 case FFESTR_otherFALSE:
14586 case FFESTR_otherNOT:
14587 if (ffest_ffebad_start (FFEBAD_MISSING_BINARY_OPERATOR))
14588 {
14589 operand = ffeexpr_stack_->exprstack;
14590 assert (operand != NULL);
14591 assert (operand->type == FFEEXPR_exprtypeOPERAND_);
14592 ffebad_here (0, ffelex_token_where_line (operand->token), ffelex_token_where_column (operand->token));
14593 ffebad_here (1, ffelex_token_where_line (t),
14594 ffelex_token_where_column (t));
14595 ffebad_finish ();
14596 }
14597 ffelex_token_kill (ffeexpr_tokens_[0]);
14598 return (ffelexHandler) ffeexpr_token_binary_sw_per_;
14599
14600 default:
14601 ffeexpr_tokens_[1] = ffelex_token_use (t);
14602 return (ffelexHandler) ffeexpr_token_binary_end_per_;
14603 }
14604 break; /* Nothing really reaches here. */
14605
14606 default:
14607 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
14608 {
14609 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14610 ffelex_token_where_column (ffeexpr_tokens_[0]));
14611 ffebad_finish ();
14612 }
14613 ffelex_token_kill (ffeexpr_tokens_[0]);
14614 return (ffelexHandler) ffeexpr_token_binary_ (t);
14615 }
14616 }
14617
14618 /* ffeexpr_token_binary_end_per_ -- Binary PERIOD NAME(not NOT, TRUE, or FALSE)
14619
14620 Return a pointer to this function to the lexer (ffelex), which will
14621 invoke it for the next token.
14622
14623 Expecting a period to close a dot-dot at binary (binary op
14624 or operator) state. If period isn't found, issue a diagnostic but
14625 pretend we saw one. ffeexpr_current_dotdot_ must already contained the
14626 dotdot representation of the name in between the two PERIOD tokens. */
14627
14628 static ffelexHandler
ffeexpr_token_binary_end_per_(ffelexToken t)14629 ffeexpr_token_binary_end_per_ (ffelexToken t)
14630 {
14631 ffeexprExpr_ e;
14632
14633 e = ffeexpr_expr_new_ ();
14634 e->type = FFEEXPR_exprtypeBINARY_;
14635 e->token = ffeexpr_tokens_[0];
14636
14637 switch (ffeexpr_current_dotdot_)
14638 {
14639 case FFESTR_otherAND:
14640 e->u.operator.op = FFEEXPR_operatorAND_;
14641 e->u.operator.prec = FFEEXPR_operatorprecedenceAND_;
14642 e->u.operator.as = FFEEXPR_operatorassociativityAND_;
14643 break;
14644
14645 case FFESTR_otherOR:
14646 e->u.operator.op = FFEEXPR_operatorOR_;
14647 e->u.operator.prec = FFEEXPR_operatorprecedenceOR_;
14648 e->u.operator.as = FFEEXPR_operatorassociativityOR_;
14649 break;
14650
14651 case FFESTR_otherXOR:
14652 e->u.operator.op = FFEEXPR_operatorXOR_;
14653 e->u.operator.prec = FFEEXPR_operatorprecedenceXOR_;
14654 e->u.operator.as = FFEEXPR_operatorassociativityXOR_;
14655 break;
14656
14657 case FFESTR_otherEQV:
14658 e->u.operator.op = FFEEXPR_operatorEQV_;
14659 e->u.operator.prec = FFEEXPR_operatorprecedenceEQV_;
14660 e->u.operator.as = FFEEXPR_operatorassociativityEQV_;
14661 break;
14662
14663 case FFESTR_otherNEQV:
14664 e->u.operator.op = FFEEXPR_operatorNEQV_;
14665 e->u.operator.prec = FFEEXPR_operatorprecedenceNEQV_;
14666 e->u.operator.as = FFEEXPR_operatorassociativityNEQV_;
14667 break;
14668
14669 case FFESTR_otherLT:
14670 e->u.operator.op = FFEEXPR_operatorLT_;
14671 e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
14672 e->u.operator.as = FFEEXPR_operatorassociativityLT_;
14673 break;
14674
14675 case FFESTR_otherLE:
14676 e->u.operator.op = FFEEXPR_operatorLE_;
14677 e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
14678 e->u.operator.as = FFEEXPR_operatorassociativityLE_;
14679 break;
14680
14681 case FFESTR_otherEQ:
14682 e->u.operator.op = FFEEXPR_operatorEQ_;
14683 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
14684 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
14685 break;
14686
14687 case FFESTR_otherNE:
14688 e->u.operator.op = FFEEXPR_operatorNE_;
14689 e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
14690 e->u.operator.as = FFEEXPR_operatorassociativityNE_;
14691 break;
14692
14693 case FFESTR_otherGT:
14694 e->u.operator.op = FFEEXPR_operatorGT_;
14695 e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
14696 e->u.operator.as = FFEEXPR_operatorassociativityGT_;
14697 break;
14698
14699 case FFESTR_otherGE:
14700 e->u.operator.op = FFEEXPR_operatorGE_;
14701 e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
14702 e->u.operator.as = FFEEXPR_operatorassociativityGE_;
14703 break;
14704
14705 default:
14706 if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT))
14707 {
14708 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14709 ffelex_token_where_column (ffeexpr_tokens_[0]));
14710 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
14711 ffebad_finish ();
14712 }
14713 e->u.operator.op = FFEEXPR_operatorEQ_;
14714 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
14715 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
14716 break;
14717 }
14718
14719 ffeexpr_exprstack_push_binary_ (e);
14720
14721 if (ffelex_token_type (t) != FFELEX_typePERIOD)
14722 {
14723 if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
14724 {
14725 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14726 ffelex_token_where_column (ffeexpr_tokens_[0]));
14727 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14728 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
14729 ffebad_finish ();
14730 }
14731 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */
14732 return (ffelexHandler) ffeexpr_token_rhs_ (t);
14733 }
14734
14735 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */
14736 return (ffelexHandler) ffeexpr_token_rhs_;
14737 }
14738
14739 /* ffeexpr_token_binary_sw_per_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
14740
14741 Return a pointer to this function to the lexer (ffelex), which will
14742 invoke it for the next token.
14743
14744 A diagnostic has already been issued; just swallow a period if there is
14745 one, then continue with ffeexpr_token_binary_. */
14746
14747 static ffelexHandler
ffeexpr_token_binary_sw_per_(ffelexToken t)14748 ffeexpr_token_binary_sw_per_ (ffelexToken t)
14749 {
14750 if (ffelex_token_type (t) != FFELEX_typePERIOD)
14751 return (ffelexHandler) ffeexpr_token_binary_ (t);
14752
14753 return (ffelexHandler) ffeexpr_token_binary_;
14754 }
14755
14756 /* ffeexpr_token_quote_ -- Rhs QUOTE
14757
14758 Return a pointer to this function to the lexer (ffelex), which will
14759 invoke it for the next token.
14760
14761 Expecting a NUMBER that we'll treat as an octal integer. */
14762
14763 static ffelexHandler
ffeexpr_token_quote_(ffelexToken t)14764 ffeexpr_token_quote_ (ffelexToken t)
14765 {
14766 ffeexprExpr_ e;
14767 ffebld anyexpr;
14768
14769 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14770 {
14771 if (ffest_ffebad_start (FFEBAD_QUOTE_MISSES_DIGITS))
14772 {
14773 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14774 ffelex_token_where_column (ffeexpr_tokens_[0]));
14775 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14776 ffebad_finish ();
14777 }
14778 ffelex_token_kill (ffeexpr_tokens_[0]);
14779 return (ffelexHandler) ffeexpr_token_rhs_ (t);
14780 }
14781
14782 /* This is kind of a kludge to prevent any whining about magical numbers
14783 that start out as these octal integers, so "20000000000 (on a 32-bit
14784 2's-complement machine) by itself won't produce an error. */
14785
14786 anyexpr = ffebld_new_any ();
14787 ffebld_set_info (anyexpr, ffeinfo_new_any ());
14788
14789 e = ffeexpr_expr_new_ ();
14790 e->type = FFEEXPR_exprtypeOPERAND_;
14791 e->token = ffeexpr_tokens_[0];
14792 e->u.operand = ffebld_new_conter_with_orig
14793 (ffebld_constant_new_integeroctal (t), anyexpr);
14794 ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER,
14795 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY,
14796 FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14797 ffeexpr_exprstack_push_operand_ (e);
14798 return (ffelexHandler) ffeexpr_token_binary_;
14799 }
14800
14801 /* ffeexpr_token_apostrophe_ -- Rhs APOSTROPHE
14802
14803 Return a pointer to this function to the lexer (ffelex), which will
14804 invoke it for the next token.
14805
14806 Handle an open-apostrophe, which begins either a character ('char-const'),
14807 typeless octal ('octal-const'O), or typeless hexadecimal ('hex-const'Z or
14808 'hex-const'X) constant. */
14809
14810 static ffelexHandler
ffeexpr_token_apostrophe_(ffelexToken t)14811 ffeexpr_token_apostrophe_ (ffelexToken t)
14812 {
14813 assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
14814 if (ffe_is_pedantic_not_90 () && (ffelex_token_length (t) == 0))
14815 {
14816 ffebad_start (FFEBAD_NULL_CHAR_CONST);
14817 ffebad_here (0, ffelex_token_where_line (t),
14818 ffelex_token_where_column (t));
14819 ffebad_finish ();
14820 }
14821 ffeexpr_tokens_[1] = ffelex_token_use (t);
14822 return (ffelexHandler) ffeexpr_token_apos_char_;
14823 }
14824
14825 /* ffeexpr_token_apos_char_ -- Rhs APOSTROPHE CHARACTER
14826
14827 Return a pointer to this function to the lexer (ffelex), which will
14828 invoke it for the next token.
14829
14830 Close-apostrophe is implicit; if this token is NAME, it is a possible
14831 typeless-constant radix specifier. */
14832
14833 static ffelexHandler
ffeexpr_token_apos_char_(ffelexToken t)14834 ffeexpr_token_apos_char_ (ffelexToken t)
14835 {
14836 ffeexprExpr_ e;
14837 ffeinfo ni;
14838 char c;
14839 ffetargetCharacterSize size;
14840
14841 if ((ffelex_token_type (t) == FFELEX_typeNAME)
14842 || (ffelex_token_type (t) == FFELEX_typeNAMES))
14843 {
14844 if ((ffelex_token_length (t) == 1)
14845 && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]), 'B',
14846 'b')
14847 || ffesrc_char_match_init (c, 'O', 'o')
14848 || ffesrc_char_match_init (c, 'X', 'x')
14849 || ffesrc_char_match_init (c, 'Z', 'z')))
14850 {
14851 e = ffeexpr_expr_new_ ();
14852 e->type = FFEEXPR_exprtypeOPERAND_;
14853 e->token = ffeexpr_tokens_[0];
14854 switch (c)
14855 {
14856 case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
14857 e->u.operand = ffebld_new_conter
14858 (ffebld_constant_new_typeless_bv (ffeexpr_tokens_[1]));
14859 size = ffetarget_size_typeless_binary (ffeexpr_tokens_[1]);
14860 break;
14861
14862 case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
14863 e->u.operand = ffebld_new_conter
14864 (ffebld_constant_new_typeless_ov (ffeexpr_tokens_[1]));
14865 size = ffetarget_size_typeless_octal (ffeexpr_tokens_[1]);
14866 break;
14867
14868 case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
14869 e->u.operand = ffebld_new_conter
14870 (ffebld_constant_new_typeless_hxv (ffeexpr_tokens_[1]));
14871 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
14872 break;
14873
14874 case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
14875 e->u.operand = ffebld_new_conter
14876 (ffebld_constant_new_typeless_hzv (ffeexpr_tokens_[1]));
14877 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
14878 break;
14879
14880 default:
14881 no_match: /* :::::::::::::::::::: */
14882 assert ("not BOXZ!" == NULL);
14883 size = 0;
14884 break;
14885 }
14886 ffebld_set_info (e->u.operand,
14887 ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
14888 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
14889 ffeexpr_exprstack_push_operand_ (e);
14890 ffelex_token_kill (ffeexpr_tokens_[1]);
14891 return (ffelexHandler) ffeexpr_token_binary_;
14892 }
14893 }
14894 e = ffeexpr_expr_new_ ();
14895 e->type = FFEEXPR_exprtypeOPERAND_;
14896 e->token = ffeexpr_tokens_[0];
14897 e->u.operand = ffebld_new_conter (ffebld_constant_new_characterdefault
14898 (ffeexpr_tokens_[1]));
14899 ni = ffeinfo_new (FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTERDEFAULT,
14900 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14901 ffelex_token_length (ffeexpr_tokens_[1]));
14902 ffebld_set_info (e->u.operand, ni);
14903 ffelex_token_kill (ffeexpr_tokens_[1]);
14904 ffeexpr_exprstack_push_operand_ (e);
14905 if ((ffelex_token_type (t) == FFELEX_typeNAME)
14906 || (ffelex_token_type (t) == FFELEX_typeNAMES))
14907 {
14908 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14909 {
14910 ffebad_string (ffelex_token_text (t));
14911 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14912 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
14913 ffelex_token_where_column (ffeexpr_tokens_[0]));
14914 ffebad_finish ();
14915 }
14916 e = ffeexpr_expr_new_ ();
14917 e->type = FFEEXPR_exprtypeBINARY_;
14918 e->token = ffelex_token_use (t);
14919 e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
14920 e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
14921 e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
14922 ffeexpr_exprstack_push_binary_ (e);
14923 return (ffelexHandler) ffeexpr_token_rhs_ (t);
14924 }
14925 ffeexpr_is_substr_ok_ = !ffe_is_pedantic_not_90 (); /* Allow "'hello'(3:5)". */
14926 return (ffelexHandler) ffeexpr_token_substrp_ (t);
14927 }
14928
14929 /* ffeexpr_token_name_lhs_ -- Lhs NAME
14930
14931 Return a pointer to this function to the lexer (ffelex), which will
14932 invoke it for the next token.
14933
14934 Handle a name followed by open-paren, period (RECORD.MEMBER), percent
14935 (RECORD%MEMBER), or nothing at all. */
14936
14937 static ffelexHandler
ffeexpr_token_name_lhs_(ffelexToken t)14938 ffeexpr_token_name_lhs_ (ffelexToken t)
14939 {
14940 ffeexprExpr_ e;
14941 ffeexprParenType_ paren_type;
14942 ffesymbol s;
14943 ffebld expr;
14944 ffeinfo info;
14945
14946 switch (ffelex_token_type (t))
14947 {
14948 case FFELEX_typeOPEN_PAREN:
14949 switch (ffeexpr_stack_->context)
14950 {
14951 case FFEEXPR_contextASSIGN:
14952 case FFEEXPR_contextAGOTO:
14953 case FFEEXPR_contextFILEUNIT_DF:
14954 goto just_name; /* :::::::::::::::::::: */
14955
14956 default:
14957 break;
14958 }
14959 e = ffeexpr_expr_new_ ();
14960 e->type = FFEEXPR_exprtypeOPERAND_;
14961 e->token = ffelex_token_use (ffeexpr_tokens_[0]);
14962 s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], FALSE,
14963 &paren_type);
14964
14965 switch (ffesymbol_where (s))
14966 {
14967 case FFEINFO_whereLOCAL:
14968 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14969 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recursion. */
14970 break;
14971
14972 case FFEINFO_whereINTRINSIC:
14973 case FFEINFO_whereGLOBAL:
14974 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
14975 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */
14976 break;
14977
14978 case FFEINFO_whereCOMMON:
14979 case FFEINFO_whereDUMMY:
14980 case FFEINFO_whereRESULT:
14981 break;
14982
14983 case FFEINFO_whereNONE:
14984 case FFEINFO_whereANY:
14985 break;
14986
14987 default:
14988 ffesymbol_error (s, ffeexpr_tokens_[0]);
14989 break;
14990 }
14991
14992 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14993 {
14994 e->u.operand = ffebld_new_any ();
14995 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14996 }
14997 else
14998 {
14999 e->u.operand = ffebld_new_symter (s,
15000 ffesymbol_generic (s),
15001 ffesymbol_specific (s),
15002 ffesymbol_implementation (s));
15003 ffebld_set_info (e->u.operand, ffesymbol_info (s));
15004 }
15005 ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */
15006 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
15007 switch (paren_type)
15008 {
15009 case FFEEXPR_parentypeSUBROUTINE_:
15010 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15011 return
15012 (ffelexHandler)
15013 ffeexpr_rhs (ffeexpr_stack_->pool,
15014 FFEEXPR_contextACTUALARG_,
15015 ffeexpr_token_arguments_);
15016
15017 case FFEEXPR_parentypeARRAY_:
15018 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15019 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
15020 ffeexpr_stack_->rank = 0;
15021 ffeexpr_stack_->constant = TRUE;
15022 ffeexpr_stack_->immediate = TRUE;
15023 switch (ffeexpr_stack_->context)
15024 {
15025 case FFEEXPR_contextDATAIMPDOITEM_:
15026 return
15027 (ffelexHandler)
15028 ffeexpr_rhs (ffeexpr_stack_->pool,
15029 FFEEXPR_contextDATAIMPDOINDEX_,
15030 ffeexpr_token_elements_);
15031
15032 case FFEEXPR_contextEQUIVALENCE:
15033 return
15034 (ffelexHandler)
15035 ffeexpr_rhs (ffeexpr_stack_->pool,
15036 FFEEXPR_contextEQVINDEX_,
15037 ffeexpr_token_elements_);
15038
15039 default:
15040 return
15041 (ffelexHandler)
15042 ffeexpr_rhs (ffeexpr_stack_->pool,
15043 FFEEXPR_contextINDEX_,
15044 ffeexpr_token_elements_);
15045 }
15046
15047 case FFEEXPR_parentypeSUBSTRING_:
15048 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
15049 ffeexpr_tokens_[0]);
15050 return
15051 (ffelexHandler)
15052 ffeexpr_rhs (ffeexpr_stack_->pool,
15053 FFEEXPR_contextINDEX_,
15054 ffeexpr_token_substring_);
15055
15056 case FFEEXPR_parentypeEQUIVALENCE_:
15057 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15058 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
15059 ffeexpr_stack_->rank = 0;
15060 ffeexpr_stack_->constant = TRUE;
15061 ffeexpr_stack_->immediate = TRUE;
15062 return
15063 (ffelexHandler)
15064 ffeexpr_rhs (ffeexpr_stack_->pool,
15065 FFEEXPR_contextEQVINDEX_,
15066 ffeexpr_token_equivalence_);
15067
15068 case FFEEXPR_parentypeFUNCTION_: /* Invalid case. */
15069 case FFEEXPR_parentypeFUNSUBSTR_: /* Invalid case. */
15070 ffesymbol_error (s, ffeexpr_tokens_[0]);
15071 /* Fall through. */
15072 case FFEEXPR_parentypeANY_:
15073 e->u.operand = ffebld_new_any ();
15074 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15075 return
15076 (ffelexHandler)
15077 ffeexpr_rhs (ffeexpr_stack_->pool,
15078 FFEEXPR_contextACTUALARG_,
15079 ffeexpr_token_anything_);
15080
15081 default:
15082 assert ("bad paren type" == NULL);
15083 break;
15084 }
15085
15086 case FFELEX_typeEQUALS: /* As in "VAR=". */
15087 switch (ffeexpr_stack_->context)
15088 {
15089 case FFEEXPR_contextIMPDOITEM_: /* within
15090 "(,VAR=start,end[,incr])". */
15091 case FFEEXPR_contextIMPDOITEMDF_:
15092 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
15093 break;
15094
15095 case FFEEXPR_contextDATAIMPDOITEM_:
15096 ffeexpr_stack_->context = FFEEXPR_contextDATAIMPDOCTRL_;
15097 break;
15098
15099 default:
15100 break;
15101 }
15102 break;
15103
15104 #if 0
15105 case FFELEX_typePERIOD:
15106 case FFELEX_typePERCENT:
15107 assert ("FOO%, FOO. not yet supported!~~" == NULL);
15108 break;
15109 #endif
15110
15111 default:
15112 break;
15113 }
15114
15115 just_name: /* :::::::::::::::::::: */
15116 e = ffeexpr_expr_new_ ();
15117 e->type = FFEEXPR_exprtypeOPERAND_;
15118 e->token = ffeexpr_tokens_[0];
15119 s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0],
15120 (ffeexpr_stack_->context
15121 == FFEEXPR_contextSUBROUTINEREF));
15122
15123 switch (ffesymbol_where (s))
15124 {
15125 case FFEINFO_whereCONSTANT:
15126 if ((ffeexpr_stack_->context != FFEEXPR_contextPARAMETER)
15127 || (ffesymbol_kind (s) != FFEINFO_kindENTITY))
15128 ffesymbol_error (s, ffeexpr_tokens_[0]);
15129 break;
15130
15131 case FFEINFO_whereIMMEDIATE:
15132 if ((ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOCTRL_)
15133 && (ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOINDEX_))
15134 ffesymbol_error (s, ffeexpr_tokens_[0]);
15135 break;
15136
15137 case FFEINFO_whereLOCAL:
15138 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
15139 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recurse!. */
15140 break;
15141
15142 case FFEINFO_whereINTRINSIC:
15143 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
15144 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */
15145 break;
15146
15147 default:
15148 break;
15149 }
15150
15151 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15152 {
15153 expr = ffebld_new_any ();
15154 info = ffeinfo_new_any ();
15155 ffebld_set_info (expr, info);
15156 }
15157 else
15158 {
15159 expr = ffebld_new_symter (s,
15160 ffesymbol_generic (s),
15161 ffesymbol_specific (s),
15162 ffesymbol_implementation (s));
15163 info = ffesymbol_info (s);
15164 ffebld_set_info (expr, info);
15165 if (ffesymbol_is_doiter (s))
15166 {
15167 ffebad_start (FFEBAD_DOITER);
15168 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15169 ffelex_token_where_column (ffeexpr_tokens_[0]));
15170 ffest_ffebad_here_doiter (1, s);
15171 ffebad_string (ffesymbol_text (s));
15172 ffebad_finish ();
15173 }
15174 expr = ffeexpr_collapse_symter (expr, ffeexpr_tokens_[0]);
15175 }
15176
15177 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
15178 {
15179 if (ffebld_op (expr) == FFEBLD_opANY)
15180 {
15181 expr = ffebld_new_any ();
15182 ffebld_set_info (expr, ffeinfo_new_any ());
15183 }
15184 else
15185 {
15186 expr = ffebld_new_subrref (expr, NULL); /* No argument list. */
15187 if (ffesymbol_generic (s) != FFEINTRIN_genNONE)
15188 ffeintrin_fulfill_generic (&expr, &info, e->token);
15189 else if (ffesymbol_specific (s) != FFEINTRIN_specNONE)
15190 ffeintrin_fulfill_specific (&expr, &info, NULL, e->token);
15191 else
15192 ffeexpr_fulfill_call_ (&expr, e->token);
15193
15194 if (ffebld_op (expr) != FFEBLD_opANY)
15195 ffebld_set_info (expr,
15196 ffeinfo_new (ffeinfo_basictype (info),
15197 ffeinfo_kindtype (info),
15198 0,
15199 FFEINFO_kindENTITY,
15200 FFEINFO_whereFLEETING,
15201 ffeinfo_size (info)));
15202 else
15203 ffebld_set_info (expr, ffeinfo_new_any ());
15204 }
15205 }
15206
15207 e->u.operand = expr;
15208 ffeexpr_exprstack_push_operand_ (e);
15209 return (ffelexHandler) ffeexpr_finished_ (t);
15210 }
15211
15212 /* ffeexpr_token_name_arg_ -- Rhs NAME
15213
15214 Return a pointer to this function to the lexer (ffelex), which will
15215 invoke it for the next token.
15216
15217 Handle first token in an actual-arg (or possible actual-arg) context
15218 being a NAME, and use second token to refine the context. */
15219
15220 static ffelexHandler
ffeexpr_token_name_arg_(ffelexToken t)15221 ffeexpr_token_name_arg_ (ffelexToken t)
15222 {
15223 switch (ffelex_token_type (t))
15224 {
15225 case FFELEX_typeCLOSE_PAREN:
15226 case FFELEX_typeCOMMA:
15227 switch (ffeexpr_stack_->context)
15228 {
15229 case FFEEXPR_contextINDEXORACTUALARG_:
15230 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
15231 break;
15232
15233 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15234 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
15235 break;
15236
15237 default:
15238 break;
15239 }
15240 break;
15241
15242 default:
15243 switch (ffeexpr_stack_->context)
15244 {
15245 case FFEEXPR_contextACTUALARG_:
15246 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
15247 break;
15248
15249 case FFEEXPR_contextINDEXORACTUALARG_:
15250 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
15251 break;
15252
15253 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15254 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
15255 break;
15256
15257 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15258 ffeexpr_stack_->context
15259 = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
15260 break;
15261
15262 default:
15263 assert ("bad context in _name_arg_" == NULL);
15264 break;
15265 }
15266 break;
15267 }
15268
15269 return (ffelexHandler) ffeexpr_token_name_rhs_ (t);
15270 }
15271
15272 /* ffeexpr_token_name_rhs_ -- Rhs NAME
15273
15274 Return a pointer to this function to the lexer (ffelex), which will
15275 invoke it for the next token.
15276
15277 Handle a name followed by open-paren, apostrophe (O'octal-const',
15278 Z'hex-const', or X'hex-const'), period (RECORD.MEMBER).
15279
15280 26-Nov-91 JCB 1.2
15281 When followed by apostrophe or quote, set lex hexnum flag on so
15282 [0-9] as first char of next token seen as starting a potentially
15283 hex number (NAME).
15284 04-Oct-91 JCB 1.1
15285 In case of intrinsic, decorate its SYMTER with the type info for
15286 the specific intrinsic. */
15287
15288 static ffelexHandler
ffeexpr_token_name_rhs_(ffelexToken t)15289 ffeexpr_token_name_rhs_ (ffelexToken t)
15290 {
15291 ffeexprExpr_ e;
15292 ffeexprParenType_ paren_type;
15293 ffesymbol s;
15294 bool sfdef;
15295
15296 switch (ffelex_token_type (t))
15297 {
15298 case FFELEX_typeQUOTE:
15299 case FFELEX_typeAPOSTROPHE:
15300 ffeexpr_tokens_[1] = ffelex_token_use (t);
15301 ffelex_set_hexnum (TRUE);
15302 return (ffelexHandler) ffeexpr_token_name_apos_;
15303
15304 case FFELEX_typeOPEN_PAREN:
15305 e = ffeexpr_expr_new_ ();
15306 e->type = FFEEXPR_exprtypeOPERAND_;
15307 e->token = ffelex_token_use (ffeexpr_tokens_[0]);
15308 s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], TRUE,
15309 &paren_type);
15310 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15311 e->u.operand = ffebld_new_any ();
15312 else
15313 e->u.operand = ffebld_new_symter (s, ffesymbol_generic (s),
15314 ffesymbol_specific (s),
15315 ffesymbol_implementation (s));
15316 ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */
15317 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
15318 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15319 {
15320 case FFEEXPR_contextSFUNCDEF:
15321 case FFEEXPR_contextSFUNCDEFINDEX_:
15322 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15323 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15324 sfdef = TRUE;
15325 break;
15326
15327 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15328 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15329 assert ("weird context!" == NULL);
15330 sfdef = FALSE;
15331 break;
15332
15333 default:
15334 sfdef = FALSE;
15335 break;
15336 }
15337 switch (paren_type)
15338 {
15339 case FFEEXPR_parentypeFUNCTION_:
15340 ffebld_set_info (e->u.operand, ffesymbol_info (s));
15341 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15342 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
15343 { /* A statement function. */
15344 ffeexpr_stack_->num_args
15345 = ffebld_list_length
15346 (ffeexpr_stack_->next_dummy
15347 = ffesymbol_dummyargs (s));
15348 ffeexpr_stack_->tokens[1] = NULL; /* !=NULL when > num_args. */
15349 }
15350 else if ((ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
15351 && !ffe_is_pedantic_not_90 ()
15352 && ((ffesymbol_implementation (s)
15353 == FFEINTRIN_impICHAR)
15354 || (ffesymbol_implementation (s)
15355 == FFEINTRIN_impIACHAR)
15356 || (ffesymbol_implementation (s)
15357 == FFEINTRIN_impLEN)))
15358 { /* Allow arbitrary concatenations. */
15359 return
15360 (ffelexHandler)
15361 ffeexpr_rhs (ffeexpr_stack_->pool,
15362 sfdef
15363 ? FFEEXPR_contextSFUNCDEF
15364 : FFEEXPR_contextLET,
15365 ffeexpr_token_arguments_);
15366 }
15367 return
15368 (ffelexHandler)
15369 ffeexpr_rhs (ffeexpr_stack_->pool,
15370 sfdef
15371 ? FFEEXPR_contextSFUNCDEFACTUALARG_
15372 : FFEEXPR_contextACTUALARG_,
15373 ffeexpr_token_arguments_);
15374
15375 case FFEEXPR_parentypeARRAY_:
15376 ffebld_set_info (e->u.operand,
15377 ffesymbol_info (ffebld_symter (e->u.operand)));
15378 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15379 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
15380 ffeexpr_stack_->rank = 0;
15381 ffeexpr_stack_->constant = TRUE;
15382 ffeexpr_stack_->immediate = TRUE;
15383 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
15384 sfdef
15385 ? FFEEXPR_contextSFUNCDEFINDEX_
15386 : FFEEXPR_contextINDEX_,
15387 ffeexpr_token_elements_);
15388
15389 case FFEEXPR_parentypeSUBSTRING_:
15390 ffebld_set_info (e->u.operand,
15391 ffesymbol_info (ffebld_symter (e->u.operand)));
15392 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
15393 ffeexpr_tokens_[0]);
15394 return
15395 (ffelexHandler)
15396 ffeexpr_rhs (ffeexpr_stack_->pool,
15397 sfdef
15398 ? FFEEXPR_contextSFUNCDEFINDEX_
15399 : FFEEXPR_contextINDEX_,
15400 ffeexpr_token_substring_);
15401
15402 case FFEEXPR_parentypeFUNSUBSTR_:
15403 return
15404 (ffelexHandler)
15405 ffeexpr_rhs (ffeexpr_stack_->pool,
15406 sfdef
15407 ? FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
15408 : FFEEXPR_contextINDEXORACTUALARG_,
15409 ffeexpr_token_funsubstr_);
15410
15411 case FFEEXPR_parentypeANY_:
15412 ffebld_set_info (e->u.operand, ffesymbol_info (s));
15413 return
15414 (ffelexHandler)
15415 ffeexpr_rhs (ffeexpr_stack_->pool,
15416 sfdef
15417 ? FFEEXPR_contextSFUNCDEFACTUALARG_
15418 : FFEEXPR_contextACTUALARG_,
15419 ffeexpr_token_anything_);
15420
15421 default:
15422 assert ("bad paren type" == NULL);
15423 break;
15424 }
15425
15426 case FFELEX_typeEQUALS: /* As in "VAR=". */
15427 switch (ffeexpr_stack_->context)
15428 {
15429 case FFEEXPR_contextIMPDOITEM_: /* "(,VAR=start,end[,incr])". */
15430 case FFEEXPR_contextIMPDOITEMDF_:
15431 ffeexpr_stack_->is_rhs = FALSE; /* Really an lhs construct. */
15432 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
15433 break;
15434
15435 default:
15436 break;
15437 }
15438 break;
15439
15440 #if 0
15441 case FFELEX_typePERIOD:
15442 case FFELEX_typePERCENT:
15443 ~~Support these two someday, though not required
15444 assert ("FOO%, FOO. not yet supported!~~" == NULL);
15445 break;
15446 #endif
15447
15448 default:
15449 break;
15450 }
15451
15452 switch (ffeexpr_stack_->context)
15453 {
15454 case FFEEXPR_contextINDEXORACTUALARG_:
15455 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15456 assert ("strange context" == NULL);
15457 break;
15458
15459 default:
15460 break;
15461 }
15462
15463 e = ffeexpr_expr_new_ ();
15464 e->type = FFEEXPR_exprtypeOPERAND_;
15465 e->token = ffeexpr_tokens_[0];
15466 s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0], FALSE);
15467 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15468 {
15469 e->u.operand = ffebld_new_any ();
15470 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15471 }
15472 else
15473 {
15474 e->u.operand = ffebld_new_symter (s, FFEINTRIN_genNONE,
15475 ffesymbol_specific (s),
15476 ffesymbol_implementation (s));
15477 if (ffesymbol_specific (s) == FFEINTRIN_specNONE)
15478 ffebld_set_info (e->u.operand, ffeinfo_use (ffesymbol_info (s)));
15479 else
15480 { /* Decorate the SYMTER with the actual type
15481 of the intrinsic. */
15482 ffebld_set_info (e->u.operand, ffeinfo_new
15483 (ffeintrin_basictype (ffesymbol_specific (s)),
15484 ffeintrin_kindtype (ffesymbol_specific (s)),
15485 0,
15486 ffesymbol_kind (s),
15487 ffesymbol_where (s),
15488 FFETARGET_charactersizeNONE));
15489 }
15490 if (ffesymbol_is_doiter (s))
15491 ffebld_symter_set_is_doiter (e->u.operand, TRUE);
15492 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
15493 ffeexpr_tokens_[0]);
15494 }
15495 ffeexpr_exprstack_push_operand_ (e);
15496 return (ffelexHandler) ffeexpr_token_binary_ (t);
15497 }
15498
15499 /* ffeexpr_token_name_apos_ -- Rhs NAME APOSTROPHE
15500
15501 Return a pointer to this function to the lexer (ffelex), which will
15502 invoke it for the next token.
15503
15504 Expecting a NAME token, analyze the previous NAME token to see what kind,
15505 if any, typeless constant we've got.
15506
15507 01-Sep-90 JCB 1.1
15508 Expect a NAME instead of CHARACTER in this situation. */
15509
15510 static ffelexHandler
ffeexpr_token_name_apos_(ffelexToken t)15511 ffeexpr_token_name_apos_ (ffelexToken t)
15512 {
15513 ffeexprExpr_ e;
15514
15515 ffelex_set_hexnum (FALSE);
15516
15517 switch (ffelex_token_type (t))
15518 {
15519 case FFELEX_typeNAME:
15520 ffeexpr_tokens_[2] = ffelex_token_use (t);
15521 return (ffelexHandler) ffeexpr_token_name_apos_name_;
15522
15523 default:
15524 break;
15525 }
15526
15527 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
15528 {
15529 ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
15530 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15531 ffelex_token_where_column (ffeexpr_tokens_[0]));
15532 ffebad_here (1, ffelex_token_where_line (t),
15533 ffelex_token_where_column (t));
15534 ffebad_finish ();
15535 }
15536
15537 ffelex_token_kill (ffeexpr_tokens_[1]);
15538
15539 e = ffeexpr_expr_new_ ();
15540 e->type = FFEEXPR_exprtypeOPERAND_;
15541 e->u.operand = ffebld_new_any ();
15542 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15543 e->token = ffeexpr_tokens_[0];
15544 ffeexpr_exprstack_push_operand_ (e);
15545
15546 return (ffelexHandler) ffeexpr_token_binary_ (t);
15547 }
15548
15549 /* ffeexpr_token_name_apos_name_ -- Rhs NAME APOSTROPHE NAME
15550
15551 Return a pointer to this function to the lexer (ffelex), which will
15552 invoke it for the next token.
15553
15554 Expecting an APOSTROPHE token, analyze the previous NAME token to see
15555 what kind, if any, typeless constant we've got. */
15556
15557 static ffelexHandler
ffeexpr_token_name_apos_name_(ffelexToken t)15558 ffeexpr_token_name_apos_name_ (ffelexToken t)
15559 {
15560 ffeexprExpr_ e;
15561 char c;
15562
15563 e = ffeexpr_expr_new_ ();
15564 e->type = FFEEXPR_exprtypeOPERAND_;
15565 e->token = ffeexpr_tokens_[0];
15566
15567 if ((ffelex_token_type (t) == ffelex_token_type (ffeexpr_tokens_[1]))
15568 && (ffelex_token_length (ffeexpr_tokens_[0]) == 1)
15569 && (ffesrc_char_match_init ((c = ffelex_token_text (ffeexpr_tokens_[0])[0]),
15570 'B', 'b')
15571 || ffesrc_char_match_init (c, 'O', 'o')
15572 || ffesrc_char_match_init (c, 'X', 'x')
15573 || ffesrc_char_match_init (c, 'Z', 'z')))
15574 {
15575 ffetargetCharacterSize size;
15576
15577 if (!ffe_is_typeless_boz ()) {
15578
15579 switch (c)
15580 {
15581 case FFESRC_CASE_MATCH_INIT ('B', 'b', imatch_b, no_imatch):
15582 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerbinary
15583 (ffeexpr_tokens_[2]));
15584 break;
15585
15586 case FFESRC_CASE_MATCH_INIT ('O', 'o', imatch_o, no_imatch):
15587 e->u.operand = ffebld_new_conter (ffebld_constant_new_integeroctal
15588 (ffeexpr_tokens_[2]));
15589 break;
15590
15591 case FFESRC_CASE_MATCH_INIT ('X', 'x', imatch_x, no_imatch):
15592 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
15593 (ffeexpr_tokens_[2]));
15594 break;
15595
15596 case FFESRC_CASE_MATCH_INIT ('Z', 'z', imatch_z, no_imatch):
15597 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
15598 (ffeexpr_tokens_[2]));
15599 break;
15600
15601 default:
15602 no_imatch: /* :::::::::::::::::::: */
15603 assert ("not BOXZ!" == NULL);
15604 abort ();
15605 }
15606
15607 ffebld_set_info (e->u.operand,
15608 ffeinfo_new (FFEINFO_basictypeINTEGER,
15609 FFEINFO_kindtypeINTEGERDEFAULT, 0,
15610 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
15611 FFETARGET_charactersizeNONE));
15612 ffeexpr_exprstack_push_operand_ (e);
15613 ffelex_token_kill (ffeexpr_tokens_[1]);
15614 ffelex_token_kill (ffeexpr_tokens_[2]);
15615 return (ffelexHandler) ffeexpr_token_binary_;
15616 }
15617
15618 switch (c)
15619 {
15620 case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
15621 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_bm
15622 (ffeexpr_tokens_[2]));
15623 size = ffetarget_size_typeless_binary (ffeexpr_tokens_[2]);
15624 break;
15625
15626 case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
15627 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_om
15628 (ffeexpr_tokens_[2]));
15629 size = ffetarget_size_typeless_octal (ffeexpr_tokens_[2]);
15630 break;
15631
15632 case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
15633 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hxm
15634 (ffeexpr_tokens_[2]));
15635 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15636 break;
15637
15638 case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
15639 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
15640 (ffeexpr_tokens_[2]));
15641 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15642 break;
15643
15644 default:
15645 no_match: /* :::::::::::::::::::: */
15646 assert ("not BOXZ!" == NULL);
15647 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
15648 (ffeexpr_tokens_[2]));
15649 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15650 break;
15651 }
15652 ffebld_set_info (e->u.operand,
15653 ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
15654 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
15655 ffeexpr_exprstack_push_operand_ (e);
15656 ffelex_token_kill (ffeexpr_tokens_[1]);
15657 ffelex_token_kill (ffeexpr_tokens_[2]);
15658 return (ffelexHandler) ffeexpr_token_binary_;
15659 }
15660
15661 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
15662 {
15663 ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
15664 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15665 ffelex_token_where_column (ffeexpr_tokens_[0]));
15666 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
15667 ffebad_finish ();
15668 }
15669
15670 ffelex_token_kill (ffeexpr_tokens_[1]);
15671 ffelex_token_kill (ffeexpr_tokens_[2]);
15672
15673 e->type = FFEEXPR_exprtypeOPERAND_;
15674 e->u.operand = ffebld_new_any ();
15675 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15676 e->token = ffeexpr_tokens_[0];
15677 ffeexpr_exprstack_push_operand_ (e);
15678
15679 switch (ffelex_token_type (t))
15680 {
15681 case FFELEX_typeAPOSTROPHE:
15682 case FFELEX_typeQUOTE:
15683 return (ffelexHandler) ffeexpr_token_binary_;
15684
15685 default:
15686 return (ffelexHandler) ffeexpr_token_binary_ (t);
15687 }
15688 }
15689
15690 /* ffeexpr_token_percent_ -- Rhs PERCENT
15691
15692 Handle a percent sign possibly followed by "LOC". If followed instead
15693 by "VAL", "REF", or "DESCR", issue an error message and substitute
15694 "LOC". If followed by something else, treat the percent sign as a
15695 spurious incorrect token and reprocess the token via _rhs_. */
15696
15697 static ffelexHandler
ffeexpr_token_percent_(ffelexToken t)15698 ffeexpr_token_percent_ (ffelexToken t)
15699 {
15700 switch (ffelex_token_type (t))
15701 {
15702 case FFELEX_typeNAME:
15703 case FFELEX_typeNAMES:
15704 ffeexpr_stack_->percent = ffeexpr_percent_ (t);
15705 ffeexpr_tokens_[1] = ffelex_token_use (t);
15706 return (ffelexHandler) ffeexpr_token_percent_name_;
15707
15708 default:
15709 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
15710 {
15711 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15712 ffelex_token_where_column (ffeexpr_tokens_[0]));
15713 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
15714 ffelex_token_where_column (ffeexpr_stack_->first_token));
15715 ffebad_finish ();
15716 }
15717 ffelex_token_kill (ffeexpr_tokens_[0]);
15718 return (ffelexHandler) ffeexpr_token_rhs_ (t);
15719 }
15720 }
15721
15722 /* ffeexpr_token_percent_name_ -- Rhs PERCENT NAME
15723
15724 Make sure the token is OPEN_PAREN and prepare for the one-item list of
15725 LHS expressions. Else display an error message. */
15726
15727 static ffelexHandler
ffeexpr_token_percent_name_(ffelexToken t)15728 ffeexpr_token_percent_name_ (ffelexToken t)
15729 {
15730 ffelexHandler nexthandler;
15731
15732 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
15733 {
15734 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
15735 {
15736 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15737 ffelex_token_where_column (ffeexpr_tokens_[0]));
15738 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
15739 ffelex_token_where_column (ffeexpr_stack_->first_token));
15740 ffebad_finish ();
15741 }
15742 ffelex_token_kill (ffeexpr_tokens_[0]);
15743 nexthandler = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_tokens_[1]);
15744 ffelex_token_kill (ffeexpr_tokens_[1]);
15745 return (ffelexHandler) (*nexthandler) (t);
15746 }
15747
15748 switch (ffeexpr_stack_->percent)
15749 {
15750 default:
15751 if (ffest_ffebad_start (FFEBAD_INVALID_PERCENT))
15752 {
15753 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15754 ffelex_token_where_column (ffeexpr_tokens_[0]));
15755 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
15756 ffebad_finish ();
15757 }
15758 ffeexpr_stack_->percent = FFEEXPR_percentLOC_;
15759 /* Fall through. */
15760 case FFEEXPR_percentLOC_:
15761 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
15762 ffelex_token_kill (ffeexpr_tokens_[1]);
15763 ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
15764 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
15765 FFEEXPR_contextLOC_,
15766 ffeexpr_cb_end_loc_);
15767 }
15768 }
15769
15770 /* ffeexpr_make_float_const_ -- Make a floating-point constant
15771
15772 See prototype.
15773
15774 Pass 'E', 'D', or 'Q' for exponent letter. */
15775
15776 static void
ffeexpr_make_float_const_(char exp_letter,ffelexToken integer,ffelexToken decimal,ffelexToken fraction,ffelexToken exponent,ffelexToken exponent_sign,ffelexToken exponent_digits)15777 ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
15778 ffelexToken decimal, ffelexToken fraction,
15779 ffelexToken exponent, ffelexToken exponent_sign,
15780 ffelexToken exponent_digits)
15781 {
15782 ffeexprExpr_ e;
15783
15784 e = ffeexpr_expr_new_ ();
15785 e->type = FFEEXPR_exprtypeOPERAND_;
15786 if (integer != NULL)
15787 e->token = ffelex_token_use (integer);
15788 else
15789 {
15790 assert (decimal != NULL);
15791 e->token = ffelex_token_use (decimal);
15792 }
15793
15794 switch (exp_letter)
15795 {
15796 #if !FFETARGET_okREALQUAD
15797 case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
15798 if (ffebad_start (FFEBAD_QUAD_UNSUPPORTED))
15799 {
15800 ffebad_here (0, ffelex_token_where_line (e->token),
15801 ffelex_token_where_column (e->token));
15802 ffebad_finish ();
15803 }
15804 goto match_d; /* The FFESRC_CASE_* macros don't
15805 allow fall-through! */
15806 #endif
15807
15808 case FFESRC_CASE_MATCH_INIT ('D', 'd', match_d, no_match):
15809 e->u.operand = ffebld_new_conter (ffebld_constant_new_realdouble
15810 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15811 ffebld_set_info (e->u.operand,
15812 ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
15813 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15814 break;
15815
15816 case FFESRC_CASE_MATCH_INIT ('E', 'e', match_e, no_match):
15817 e->u.operand = ffebld_new_conter (ffebld_constant_new_realdefault
15818 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15819 ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeREAL,
15820 FFEINFO_kindtypeREALDEFAULT, 0, FFEINFO_kindENTITY,
15821 FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15822 break;
15823
15824 #if FFETARGET_okREALQUAD
15825 case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
15826 e->u.operand = ffebld_new_conter (ffebld_constant_new_realquad
15827 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15828 ffebld_set_info (e->u.operand,
15829 ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALQUAD,
15830 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15831 break;
15832 #endif
15833
15834 case 'I': /* Make an integer. */
15835 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
15836 (ffeexpr_tokens_[0]));
15837 ffebld_set_info (e->u.operand,
15838 ffeinfo_new (FFEINFO_basictypeINTEGER,
15839 FFEINFO_kindtypeINTEGERDEFAULT, 0,
15840 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
15841 FFETARGET_charactersizeNONE));
15842 break;
15843
15844 default:
15845 no_match: /* :::::::::::::::::::: */
15846 assert ("Lost the exponent letter!" == NULL);
15847 }
15848
15849 ffeexpr_exprstack_push_operand_ (e);
15850 }
15851
15852 /* Just like ffesymbol_declare_local, except performs any implicit info
15853 assignment necessary. */
15854
15855 static ffesymbol
ffeexpr_declare_unadorned_(ffelexToken t,bool maybe_intrin)15856 ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin)
15857 {
15858 ffesymbol s;
15859 ffeinfoKind k;
15860 bool bad;
15861
15862 s = ffesymbol_declare_local (t, maybe_intrin);
15863
15864 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15865 /* Special-case these since they can involve a different concept
15866 of "state" (in the stmtfunc name space). */
15867 {
15868 case FFEEXPR_contextDATAIMPDOINDEX_:
15869 case FFEEXPR_contextDATAIMPDOCTRL_:
15870 if (ffeexpr_context_outer_ (ffeexpr_stack_)
15871 == FFEEXPR_contextDATAIMPDOINDEX_)
15872 s = ffeexpr_sym_impdoitem_ (s, t);
15873 else
15874 if (ffeexpr_stack_->is_rhs)
15875 s = ffeexpr_sym_impdoitem_ (s, t);
15876 else
15877 s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
15878 bad = (ffesymbol_kind (s) != FFEINFO_kindENTITY)
15879 || ((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
15880 && (ffesymbol_where (s) != FFEINFO_whereIMMEDIATE));
15881 if (bad && (ffesymbol_kind (s) != FFEINFO_kindANY))
15882 ffesymbol_error (s, t);
15883 return s;
15884
15885 default:
15886 break;
15887 }
15888
15889 switch ((ffesymbol_sfdummyparent (s) == NULL)
15890 ? ffesymbol_state (s)
15891 : FFESYMBOL_stateUNDERSTOOD)
15892 {
15893 case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr
15894 context. */
15895 if (!ffest_seen_first_exec ())
15896 goto seen; /* :::::::::::::::::::: */
15897 /* Fall through. */
15898 case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */
15899 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15900 {
15901 case FFEEXPR_contextSUBROUTINEREF:
15902 s = ffeexpr_sym_lhs_call_ (s, t);
15903 break;
15904
15905 case FFEEXPR_contextFILEEXTFUNC:
15906 s = ffeexpr_sym_lhs_extfunc_ (s, t);
15907 break;
15908
15909 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15910 s = ffecom_sym_exec_transition (s);
15911 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15912 goto understood; /* :::::::::::::::::::: */
15913 /* Fall through. */
15914 case FFEEXPR_contextACTUALARG_:
15915 s = ffeexpr_sym_rhs_actualarg_ (s, t);
15916 break;
15917
15918 case FFEEXPR_contextDATA:
15919 if (ffeexpr_stack_->is_rhs)
15920 s = ffeexpr_sym_rhs_let_ (s, t);
15921 else
15922 s = ffeexpr_sym_lhs_data_ (s, t);
15923 break;
15924
15925 case FFEEXPR_contextDATAIMPDOITEM_:
15926 s = ffeexpr_sym_lhs_data_ (s, t);
15927 break;
15928
15929 case FFEEXPR_contextSFUNCDEF:
15930 case FFEEXPR_contextSFUNCDEFINDEX_:
15931 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15932 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15933 s = ffecom_sym_exec_transition (s);
15934 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15935 goto understood; /* :::::::::::::::::::: */
15936 /* Fall through. */
15937 case FFEEXPR_contextLET:
15938 case FFEEXPR_contextPAREN_:
15939 case FFEEXPR_contextACTUALARGEXPR_:
15940 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15941 case FFEEXPR_contextASSIGN:
15942 case FFEEXPR_contextIOLIST:
15943 case FFEEXPR_contextIOLISTDF:
15944 case FFEEXPR_contextDO:
15945 case FFEEXPR_contextDOWHILE:
15946 case FFEEXPR_contextAGOTO:
15947 case FFEEXPR_contextCGOTO:
15948 case FFEEXPR_contextIF:
15949 case FFEEXPR_contextARITHIF:
15950 case FFEEXPR_contextFORMAT:
15951 case FFEEXPR_contextSTOP:
15952 case FFEEXPR_contextRETURN:
15953 case FFEEXPR_contextSELECTCASE:
15954 case FFEEXPR_contextCASE:
15955 case FFEEXPR_contextFILEASSOC:
15956 case FFEEXPR_contextFILEINT:
15957 case FFEEXPR_contextFILEDFINT:
15958 case FFEEXPR_contextFILELOG:
15959 case FFEEXPR_contextFILENUM:
15960 case FFEEXPR_contextFILENUMAMBIG:
15961 case FFEEXPR_contextFILECHAR:
15962 case FFEEXPR_contextFILENUMCHAR:
15963 case FFEEXPR_contextFILEDFCHAR:
15964 case FFEEXPR_contextFILEKEY:
15965 case FFEEXPR_contextFILEUNIT:
15966 case FFEEXPR_contextFILEUNIT_DF:
15967 case FFEEXPR_contextFILEUNITAMBIG:
15968 case FFEEXPR_contextFILEFORMAT:
15969 case FFEEXPR_contextFILENAMELIST:
15970 case FFEEXPR_contextFILEVXTCODE:
15971 case FFEEXPR_contextINDEX_:
15972 case FFEEXPR_contextIMPDOITEM_:
15973 case FFEEXPR_contextIMPDOITEMDF_:
15974 case FFEEXPR_contextIMPDOCTRL_:
15975 case FFEEXPR_contextLOC_:
15976 if (ffeexpr_stack_->is_rhs)
15977 s = ffeexpr_sym_rhs_let_ (s, t);
15978 else
15979 s = ffeexpr_sym_lhs_let_ (s, t);
15980 break;
15981
15982 case FFEEXPR_contextCHARACTERSIZE:
15983 case FFEEXPR_contextEQUIVALENCE:
15984 case FFEEXPR_contextINCLUDE:
15985 case FFEEXPR_contextPARAMETER:
15986 case FFEEXPR_contextDIMLIST:
15987 case FFEEXPR_contextDIMLISTCOMMON:
15988 case FFEEXPR_contextKINDTYPE:
15989 case FFEEXPR_contextINITVAL:
15990 case FFEEXPR_contextEQVINDEX_:
15991 break; /* Will turn into errors below. */
15992
15993 default:
15994 ffesymbol_error (s, t);
15995 break;
15996 }
15997 /* Fall through. */
15998 case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */
15999 understood: /* :::::::::::::::::::: */
16000 k = ffesymbol_kind (s);
16001 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16002 {
16003 case FFEEXPR_contextSUBROUTINEREF:
16004 bad = ((k != FFEINFO_kindSUBROUTINE)
16005 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
16006 || (k != FFEINFO_kindNONE)));
16007 break;
16008
16009 case FFEEXPR_contextFILEEXTFUNC:
16010 bad = (k != FFEINFO_kindFUNCTION)
16011 || (ffesymbol_where (s) != FFEINFO_whereGLOBAL);
16012 break;
16013
16014 case FFEEXPR_contextSFUNCDEFACTUALARG_:
16015 case FFEEXPR_contextACTUALARG_:
16016 switch (k)
16017 {
16018 case FFEINFO_kindENTITY:
16019 bad = FALSE;
16020 break;
16021
16022 case FFEINFO_kindFUNCTION:
16023 case FFEINFO_kindSUBROUTINE:
16024 bad
16025 = ((ffesymbol_where (s) != FFEINFO_whereGLOBAL)
16026 && (ffesymbol_where (s) != FFEINFO_whereDUMMY)
16027 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
16028 || !ffeintrin_is_actualarg (ffesymbol_specific (s))));
16029 break;
16030
16031 case FFEINFO_kindNONE:
16032 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
16033 {
16034 bad = !(ffeintrin_is_actualarg (ffesymbol_specific (s)));
16035 break;
16036 }
16037
16038 /* If state is UNDERSTOOD here, it's CHAR*(*) or attrsANY,
16039 and in the former case, attrsTYPE is set, so we
16040 see this as an error as we should, since CHAR*(*)
16041 cannot be actually referenced in a main/block data
16042 program unit. */
16043
16044 if ((ffesymbol_attrs (s) & (FFESYMBOL_attrsANY
16045 | FFESYMBOL_attrsEXTERNAL
16046 | FFESYMBOL_attrsTYPE))
16047 == FFESYMBOL_attrsEXTERNAL)
16048 bad = FALSE;
16049 else
16050 bad = TRUE;
16051 break;
16052
16053 default:
16054 bad = TRUE;
16055 break;
16056 }
16057 break;
16058
16059 case FFEEXPR_contextDATA:
16060 if (ffeexpr_stack_->is_rhs)
16061 bad = (k != FFEINFO_kindENTITY)
16062 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16063 else
16064 bad = (k != FFEINFO_kindENTITY)
16065 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
16066 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
16067 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
16068 break;
16069
16070 case FFEEXPR_contextDATAIMPDOITEM_:
16071 bad = TRUE; /* Unadorned item never valid. */
16072 break;
16073
16074 case FFEEXPR_contextSFUNCDEF:
16075 case FFEEXPR_contextSFUNCDEFINDEX_:
16076 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16077 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16078 case FFEEXPR_contextLET:
16079 case FFEEXPR_contextPAREN_:
16080 case FFEEXPR_contextACTUALARGEXPR_:
16081 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16082 case FFEEXPR_contextASSIGN:
16083 case FFEEXPR_contextIOLIST:
16084 case FFEEXPR_contextIOLISTDF:
16085 case FFEEXPR_contextDO:
16086 case FFEEXPR_contextDOWHILE:
16087 case FFEEXPR_contextAGOTO:
16088 case FFEEXPR_contextCGOTO:
16089 case FFEEXPR_contextIF:
16090 case FFEEXPR_contextARITHIF:
16091 case FFEEXPR_contextFORMAT:
16092 case FFEEXPR_contextSTOP:
16093 case FFEEXPR_contextRETURN:
16094 case FFEEXPR_contextSELECTCASE:
16095 case FFEEXPR_contextCASE:
16096 case FFEEXPR_contextFILEASSOC:
16097 case FFEEXPR_contextFILEINT:
16098 case FFEEXPR_contextFILEDFINT:
16099 case FFEEXPR_contextFILELOG:
16100 case FFEEXPR_contextFILENUM:
16101 case FFEEXPR_contextFILENUMAMBIG:
16102 case FFEEXPR_contextFILECHAR:
16103 case FFEEXPR_contextFILENUMCHAR:
16104 case FFEEXPR_contextFILEDFCHAR:
16105 case FFEEXPR_contextFILEKEY:
16106 case FFEEXPR_contextFILEUNIT:
16107 case FFEEXPR_contextFILEUNIT_DF:
16108 case FFEEXPR_contextFILEUNITAMBIG:
16109 case FFEEXPR_contextFILEFORMAT:
16110 case FFEEXPR_contextFILENAMELIST:
16111 case FFEEXPR_contextFILEVXTCODE:
16112 case FFEEXPR_contextINDEX_:
16113 case FFEEXPR_contextIMPDOITEM_:
16114 case FFEEXPR_contextIMPDOITEMDF_:
16115 case FFEEXPR_contextIMPDOCTRL_:
16116 case FFEEXPR_contextLOC_:
16117 bad = (k != FFEINFO_kindENTITY); /* This catches "SUBROUTINE
16118 X(A);EXTERNAL A;CALL
16119 Y(A);B=A", for example. */
16120 break;
16121
16122 case FFEEXPR_contextCHARACTERSIZE:
16123 case FFEEXPR_contextEQUIVALENCE:
16124 case FFEEXPR_contextPARAMETER:
16125 case FFEEXPR_contextDIMLIST:
16126 case FFEEXPR_contextDIMLISTCOMMON:
16127 case FFEEXPR_contextKINDTYPE:
16128 case FFEEXPR_contextINITVAL:
16129 case FFEEXPR_contextEQVINDEX_:
16130 bad = (k != FFEINFO_kindENTITY)
16131 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16132 break;
16133
16134 case FFEEXPR_contextINCLUDE:
16135 bad = TRUE;
16136 break;
16137
16138 default:
16139 bad = TRUE;
16140 break;
16141 }
16142 if (bad && (k != FFEINFO_kindANY))
16143 ffesymbol_error (s, t);
16144 return s;
16145
16146 case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */
16147 seen: /* :::::::::::::::::::: */
16148 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16149 {
16150 case FFEEXPR_contextPARAMETER:
16151 if (ffeexpr_stack_->is_rhs)
16152 ffesymbol_error (s, t);
16153 else
16154 s = ffeexpr_sym_lhs_parameter_ (s, t);
16155 break;
16156
16157 case FFEEXPR_contextDATA:
16158 s = ffecom_sym_exec_transition (s);
16159 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16160 goto understood; /* :::::::::::::::::::: */
16161 if (ffeexpr_stack_->is_rhs)
16162 ffesymbol_error (s, t);
16163 else
16164 s = ffeexpr_sym_lhs_data_ (s, t);
16165 goto understood; /* :::::::::::::::::::: */
16166
16167 case FFEEXPR_contextDATAIMPDOITEM_:
16168 s = ffecom_sym_exec_transition (s);
16169 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16170 goto understood; /* :::::::::::::::::::: */
16171 s = ffeexpr_sym_lhs_data_ (s, t);
16172 goto understood; /* :::::::::::::::::::: */
16173
16174 case FFEEXPR_contextEQUIVALENCE:
16175 s = ffeexpr_sym_lhs_equivalence_ (s, t);
16176 break;
16177
16178 case FFEEXPR_contextDIMLIST:
16179 s = ffeexpr_sym_rhs_dimlist_ (s, t);
16180 break;
16181
16182 case FFEEXPR_contextCHARACTERSIZE:
16183 case FFEEXPR_contextKINDTYPE:
16184 case FFEEXPR_contextDIMLISTCOMMON:
16185 case FFEEXPR_contextINITVAL:
16186 case FFEEXPR_contextEQVINDEX_:
16187 ffesymbol_error (s, t);
16188 break;
16189
16190 case FFEEXPR_contextINCLUDE:
16191 ffesymbol_error (s, t);
16192 break;
16193
16194 case FFEEXPR_contextACTUALARG_: /* E.g. I in REAL A(Y(I)). */
16195 case FFEEXPR_contextSFUNCDEFACTUALARG_:
16196 s = ffecom_sym_exec_transition (s);
16197 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16198 goto understood; /* :::::::::::::::::::: */
16199 s = ffeexpr_sym_rhs_actualarg_ (s, t);
16200 goto understood; /* :::::::::::::::::::: */
16201
16202 case FFEEXPR_contextINDEX_:
16203 case FFEEXPR_contextACTUALARGEXPR_:
16204 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16205 case FFEEXPR_contextSFUNCDEF:
16206 case FFEEXPR_contextSFUNCDEFINDEX_:
16207 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16208 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16209 assert (ffeexpr_stack_->is_rhs);
16210 s = ffecom_sym_exec_transition (s);
16211 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16212 goto understood; /* :::::::::::::::::::: */
16213 s = ffeexpr_sym_rhs_let_ (s, t);
16214 goto understood; /* :::::::::::::::::::: */
16215
16216 default:
16217 ffesymbol_error (s, t);
16218 break;
16219 }
16220 return s;
16221
16222 default:
16223 assert ("bad symbol state" == NULL);
16224 return NULL;
16225 break;
16226 }
16227 }
16228
16229 /* Have FOO in DATA (XYZ(FOO),...)/.../ or DATA (...,XYZ=FOO,BAR,BLETCH).
16230 Could be found via the "statement-function" name space (in which case
16231 it should become an iterator) or the local name space (in which case
16232 it should be either a named constant, or a variable that will have an
16233 sfunc name space sibling that should become an iterator). */
16234
16235 static ffesymbol
ffeexpr_sym_impdoitem_(ffesymbol sp,ffelexToken t)16236 ffeexpr_sym_impdoitem_ (ffesymbol sp, ffelexToken t)
16237 {
16238 ffesymbol s;
16239 ffesymbolAttrs sa;
16240 ffesymbolAttrs na;
16241 ffesymbolState ss;
16242 ffesymbolState ns;
16243 ffeinfoKind kind;
16244 ffeinfoWhere where;
16245
16246 ss = ffesymbol_state (sp);
16247
16248 if (ffesymbol_sfdummyparent (sp) != NULL)
16249 { /* Have symbol in sfunc name space. */
16250 switch (ss)
16251 {
16252 case FFESYMBOL_stateNONE: /* Used as iterator already. */
16253 if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
16254 ffesymbol_error (sp, t); /* Can't use dead iterator. */
16255 else
16256 { /* Can use dead iterator because we're at at
16257 least an innermore (higher-numbered) level
16258 than the iterator's outermost
16259 (lowest-numbered) level. */
16260 ffesymbol_signal_change (sp);
16261 ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
16262 ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
16263 ffesymbol_signal_unreported (sp);
16264 }
16265 break;
16266
16267 case FFESYMBOL_stateSEEN: /* Seen already in this or other
16268 implied-DO. Set symbol level
16269 number to outermost value, as that
16270 tells us we can see it as iterator
16271 at that level at the innermost. */
16272 if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
16273 {
16274 ffesymbol_signal_change (sp);
16275 ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
16276 ffesymbol_signal_unreported (sp);
16277 }
16278 break;
16279
16280 case FFESYMBOL_stateUNCERTAIN: /* Iterator. */
16281 assert (ffeexpr_level_ == ffesymbol_maxentrynum (sp));
16282 ffesymbol_error (sp, t); /* (,,,I=I,10). */
16283 break;
16284
16285 case FFESYMBOL_stateUNDERSTOOD:
16286 break; /* ANY. */
16287
16288 default:
16289 assert ("Foo Bar!!" == NULL);
16290 break;
16291 }
16292
16293 return sp;
16294 }
16295
16296 /* Got symbol in local name space, so we haven't seen it in impdo yet.
16297 First, if it is brand-new and we're in executable statements, set the
16298 attributes and exec-transition it to set state UNCERTAIN or UNDERSTOOD.
16299 Second, if it is now a constant (PARAMETER), then just return it, it
16300 can't be an implied-do iterator. If it is understood, complain if it is
16301 not a valid variable, but make the inner name space iterator anyway and
16302 return that. If it is not understood, improve understanding of the
16303 symbol accordingly, complain accordingly, in either case make the inner
16304 name space iterator and return that. */
16305
16306 sa = ffesymbol_attrs (sp);
16307
16308 if (ffesymbol_state_is_specable (ss)
16309 && ffest_seen_first_exec ())
16310 {
16311 assert (sa == FFESYMBOL_attrsetNONE);
16312 ffesymbol_signal_change (sp);
16313 ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
16314 ffesymbol_resolve_intrin (sp);
16315 if (ffeimplic_establish_symbol (sp))
16316 ffesymbol_set_attr (sp, FFESYMBOL_attrSFARG);
16317 else
16318 ffesymbol_error (sp, t);
16319
16320 /* After the exec transition, the state will either be UNCERTAIN (could
16321 be a dummy or local var) or UNDERSTOOD (local var, because this is a
16322 PROGRAM/BLOCKDATA program unit). */
16323
16324 sp = ffecom_sym_exec_transition (sp);
16325 sa = ffesymbol_attrs (sp);
16326 ss = ffesymbol_state (sp);
16327 }
16328
16329 ns = ss;
16330 kind = ffesymbol_kind (sp);
16331 where = ffesymbol_where (sp);
16332
16333 if (ss == FFESYMBOL_stateUNDERSTOOD)
16334 {
16335 if (kind != FFEINFO_kindENTITY)
16336 ffesymbol_error (sp, t);
16337 if (where == FFEINFO_whereCONSTANT)
16338 return sp;
16339 }
16340 else
16341 {
16342 /* Enhance understanding of local symbol. This used to imply exec
16343 transition, but that doesn't seem necessary, since the local symbol
16344 doesn't actually get put into an ffebld tree here -- we just learn
16345 more about it, just like when we see a local symbol's name in the
16346 dummy-arg list of a statement function. */
16347
16348 if (ss != FFESYMBOL_stateUNCERTAIN)
16349 {
16350 /* Figure out what kind of object we've got based on previous
16351 declarations of or references to the object. */
16352
16353 ns = FFESYMBOL_stateSEEN;
16354
16355 if (sa & FFESYMBOL_attrsANY)
16356 na = sa;
16357 else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
16358 | FFESYMBOL_attrsANY
16359 | FFESYMBOL_attrsCOMMON
16360 | FFESYMBOL_attrsDUMMY
16361 | FFESYMBOL_attrsEQUIV
16362 | FFESYMBOL_attrsINIT
16363 | FFESYMBOL_attrsNAMELIST
16364 | FFESYMBOL_attrsRESULT
16365 | FFESYMBOL_attrsSAVE
16366 | FFESYMBOL_attrsSFARG
16367 | FFESYMBOL_attrsTYPE)))
16368 na = sa | FFESYMBOL_attrsSFARG;
16369 else
16370 na = FFESYMBOL_attrsetNONE;
16371 }
16372 else
16373 { /* stateUNCERTAIN. */
16374 na = sa | FFESYMBOL_attrsSFARG;
16375 ns = FFESYMBOL_stateUNDERSTOOD;
16376
16377 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16378 | FFESYMBOL_attrsADJUSTABLE
16379 | FFESYMBOL_attrsANYLEN
16380 | FFESYMBOL_attrsARRAY
16381 | FFESYMBOL_attrsDUMMY
16382 | FFESYMBOL_attrsEXTERNAL
16383 | FFESYMBOL_attrsSFARG
16384 | FFESYMBOL_attrsTYPE)));
16385
16386 if (sa & FFESYMBOL_attrsEXTERNAL)
16387 {
16388 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16389 | FFESYMBOL_attrsDUMMY
16390 | FFESYMBOL_attrsEXTERNAL
16391 | FFESYMBOL_attrsTYPE)));
16392
16393 na = FFESYMBOL_attrsetNONE;
16394 }
16395 else if (sa & FFESYMBOL_attrsDUMMY)
16396 {
16397 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16398 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16399 | FFESYMBOL_attrsEXTERNAL
16400 | FFESYMBOL_attrsTYPE)));
16401
16402 kind = FFEINFO_kindENTITY;
16403 }
16404 else if (sa & FFESYMBOL_attrsARRAY)
16405 {
16406 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16407 | FFESYMBOL_attrsADJUSTABLE
16408 | FFESYMBOL_attrsTYPE)));
16409
16410 na = FFESYMBOL_attrsetNONE;
16411 }
16412 else if (sa & FFESYMBOL_attrsSFARG)
16413 {
16414 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16415 | FFESYMBOL_attrsTYPE)));
16416
16417 ns = FFESYMBOL_stateUNCERTAIN;
16418 }
16419 else if (sa & FFESYMBOL_attrsTYPE)
16420 {
16421 assert (!(sa & (FFESYMBOL_attrsARRAY
16422 | FFESYMBOL_attrsDUMMY
16423 | FFESYMBOL_attrsEXTERNAL
16424 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16425 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16426 | FFESYMBOL_attrsADJUSTABLE
16427 | FFESYMBOL_attrsANYLEN
16428 | FFESYMBOL_attrsARRAY
16429 | FFESYMBOL_attrsDUMMY
16430 | FFESYMBOL_attrsEXTERNAL
16431 | FFESYMBOL_attrsSFARG)));
16432
16433 kind = FFEINFO_kindENTITY;
16434
16435 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16436 na = FFESYMBOL_attrsetNONE;
16437 else if (ffest_is_entry_valid ())
16438 ns = FFESYMBOL_stateUNCERTAIN; /* Could be DUMMY or LOCAL. */
16439 else
16440 where = FFEINFO_whereLOCAL;
16441 }
16442 else
16443 na = FFESYMBOL_attrsetNONE; /* Error. */
16444 }
16445
16446 /* Now see what we've got for a new object: NONE means a new error
16447 cropped up; ANY means an old error to be ignored; otherwise,
16448 everything's ok, update the object (symbol) and continue on. */
16449
16450 if (na == FFESYMBOL_attrsetNONE)
16451 ffesymbol_error (sp, t);
16452 else if (!(na & FFESYMBOL_attrsANY))
16453 {
16454 ffesymbol_signal_change (sp); /* May need to back up to previous
16455 version. */
16456 if (!ffeimplic_establish_symbol (sp))
16457 ffesymbol_error (sp, t);
16458 else
16459 {
16460 ffesymbol_set_info (sp,
16461 ffeinfo_new (ffesymbol_basictype (sp),
16462 ffesymbol_kindtype (sp),
16463 ffesymbol_rank (sp),
16464 kind,
16465 where,
16466 ffesymbol_size (sp)));
16467 ffesymbol_set_attrs (sp, na);
16468 ffesymbol_set_state (sp, ns);
16469 ffesymbol_resolve_intrin (sp);
16470 if (!ffesymbol_state_is_specable (ns))
16471 sp = ffecom_sym_learned (sp);
16472 ffesymbol_signal_unreported (sp); /* For debugging purposes. */
16473 }
16474 }
16475 }
16476
16477 /* Here we create the sfunc-name-space symbol representing what should
16478 become an iterator in this name space at this or an outermore (lower-
16479 numbered) expression level, else the implied-DO construct is in error. */
16480
16481 s = ffesymbol_declare_sfdummy (t); /* Sets maxentrynum to 0 for new obj;
16482 also sets sfa_dummy_parent to
16483 parent symbol. */
16484 assert (sp == ffesymbol_sfdummyparent (s));
16485
16486 ffesymbol_signal_change (s);
16487 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
16488 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
16489 ffesymbol_set_info (s,
16490 ffeinfo_new (FFEINFO_basictypeINTEGER,
16491 FFEINFO_kindtypeINTEGERDEFAULT,
16492 0,
16493 FFEINFO_kindENTITY,
16494 FFEINFO_whereIMMEDIATE,
16495 FFETARGET_charactersizeNONE));
16496 ffesymbol_signal_unreported (s);
16497
16498 if ((ffesymbol_basictype (sp) != FFEINFO_basictypeINTEGER)
16499 && (ffesymbol_basictype (sp) != FFEINFO_basictypeANY))
16500 ffesymbol_error (s, t);
16501
16502 return s;
16503 }
16504
16505 /* Have FOO in CALL FOO. Local name space, executable context only. */
16506
16507 static ffesymbol
ffeexpr_sym_lhs_call_(ffesymbol s,ffelexToken t)16508 ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t)
16509 {
16510 ffesymbolAttrs sa;
16511 ffesymbolAttrs na;
16512 ffeinfoKind kind;
16513 ffeinfoWhere where;
16514 ffeintrinGen gen;
16515 ffeintrinSpec spec;
16516 ffeintrinImp imp;
16517 bool error = FALSE;
16518
16519 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16520 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16521
16522 na = sa = ffesymbol_attrs (s);
16523
16524 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16525 | FFESYMBOL_attrsADJUSTABLE
16526 | FFESYMBOL_attrsANYLEN
16527 | FFESYMBOL_attrsARRAY
16528 | FFESYMBOL_attrsDUMMY
16529 | FFESYMBOL_attrsEXTERNAL
16530 | FFESYMBOL_attrsSFARG
16531 | FFESYMBOL_attrsTYPE)));
16532
16533 kind = ffesymbol_kind (s);
16534 where = ffesymbol_where (s);
16535
16536 /* Figure out what kind of object we've got based on previous declarations
16537 of or references to the object. */
16538
16539 if (sa & FFESYMBOL_attrsEXTERNAL)
16540 {
16541 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16542 | FFESYMBOL_attrsDUMMY
16543 | FFESYMBOL_attrsEXTERNAL
16544 | FFESYMBOL_attrsTYPE)));
16545
16546 if (sa & FFESYMBOL_attrsTYPE)
16547 error = TRUE;
16548 else
16549 /* Not TYPE. */
16550 {
16551 kind = FFEINFO_kindSUBROUTINE;
16552
16553 if (sa & FFESYMBOL_attrsDUMMY)
16554 ; /* Not TYPE. */
16555 else if (sa & FFESYMBOL_attrsACTUALARG)
16556 ; /* Not DUMMY or TYPE. */
16557 else /* Not ACTUALARG, DUMMY, or TYPE. */
16558 where = FFEINFO_whereGLOBAL;
16559 }
16560 }
16561 else if (sa & FFESYMBOL_attrsDUMMY)
16562 {
16563 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16564 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16565 | FFESYMBOL_attrsEXTERNAL
16566 | FFESYMBOL_attrsTYPE)));
16567
16568 if (sa & FFESYMBOL_attrsTYPE)
16569 error = TRUE;
16570 else
16571 kind = FFEINFO_kindSUBROUTINE;
16572 }
16573 else if (sa & FFESYMBOL_attrsARRAY)
16574 {
16575 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16576 | FFESYMBOL_attrsADJUSTABLE
16577 | FFESYMBOL_attrsTYPE)));
16578
16579 error = TRUE;
16580 }
16581 else if (sa & FFESYMBOL_attrsSFARG)
16582 {
16583 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16584 | FFESYMBOL_attrsTYPE)));
16585
16586 error = TRUE;
16587 }
16588 else if (sa & FFESYMBOL_attrsTYPE)
16589 {
16590 assert (!(sa & (FFESYMBOL_attrsARRAY
16591 | FFESYMBOL_attrsDUMMY
16592 | FFESYMBOL_attrsEXTERNAL
16593 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16594 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16595 | FFESYMBOL_attrsADJUSTABLE
16596 | FFESYMBOL_attrsANYLEN
16597 | FFESYMBOL_attrsARRAY
16598 | FFESYMBOL_attrsDUMMY
16599 | FFESYMBOL_attrsEXTERNAL
16600 | FFESYMBOL_attrsSFARG)));
16601
16602 error = TRUE;
16603 }
16604 else if (sa == FFESYMBOL_attrsetNONE)
16605 {
16606 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16607
16608 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
16609 &gen, &spec, &imp))
16610 {
16611 ffesymbol_signal_change (s); /* May need to back up to previous
16612 version. */
16613 ffesymbol_set_generic (s, gen);
16614 ffesymbol_set_specific (s, spec);
16615 ffesymbol_set_implementation (s, imp);
16616 ffesymbol_set_info (s,
16617 ffeinfo_new (FFEINFO_basictypeNONE,
16618 FFEINFO_kindtypeNONE,
16619 0,
16620 FFEINFO_kindSUBROUTINE,
16621 FFEINFO_whereINTRINSIC,
16622 FFETARGET_charactersizeNONE));
16623 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16624 ffesymbol_resolve_intrin (s);
16625 ffesymbol_reference (s, t, FALSE);
16626 s = ffecom_sym_learned (s);
16627 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16628
16629 return s;
16630 }
16631
16632 kind = FFEINFO_kindSUBROUTINE;
16633 where = FFEINFO_whereGLOBAL;
16634 }
16635 else
16636 error = TRUE;
16637
16638 /* Now see what we've got for a new object: NONE means a new error cropped
16639 up; ANY means an old error to be ignored; otherwise, everything's ok,
16640 update the object (symbol) and continue on. */
16641
16642 if (error)
16643 ffesymbol_error (s, t);
16644 else if (!(na & FFESYMBOL_attrsANY))
16645 {
16646 ffesymbol_signal_change (s); /* May need to back up to previous
16647 version. */
16648 ffesymbol_set_info (s,
16649 ffeinfo_new (ffesymbol_basictype (s),
16650 ffesymbol_kindtype (s),
16651 ffesymbol_rank (s),
16652 kind, /* SUBROUTINE. */
16653 where, /* GLOBAL or DUMMY. */
16654 ffesymbol_size (s)));
16655 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16656 ffesymbol_resolve_intrin (s);
16657 ffesymbol_reference (s, t, FALSE);
16658 s = ffecom_sym_learned (s);
16659 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16660 }
16661
16662 return s;
16663 }
16664
16665 /* Have FOO in DATA FOO/.../. Local name space and executable context
16666 only. (This will change in the future when DATA FOO may be followed
16667 by COMMON FOO or even INTEGER FOO(10), etc.) */
16668
16669 static ffesymbol
ffeexpr_sym_lhs_data_(ffesymbol s,ffelexToken t)16670 ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t)
16671 {
16672 ffesymbolAttrs sa;
16673 ffesymbolAttrs na;
16674 ffeinfoKind kind;
16675 ffeinfoWhere where;
16676 bool error = FALSE;
16677
16678 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16679 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16680
16681 na = sa = ffesymbol_attrs (s);
16682
16683 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16684 | FFESYMBOL_attrsADJUSTABLE
16685 | FFESYMBOL_attrsANYLEN
16686 | FFESYMBOL_attrsARRAY
16687 | FFESYMBOL_attrsDUMMY
16688 | FFESYMBOL_attrsEXTERNAL
16689 | FFESYMBOL_attrsSFARG
16690 | FFESYMBOL_attrsTYPE)));
16691
16692 kind = ffesymbol_kind (s);
16693 where = ffesymbol_where (s);
16694
16695 /* Figure out what kind of object we've got based on previous declarations
16696 of or references to the object. */
16697
16698 if (sa & FFESYMBOL_attrsEXTERNAL)
16699 {
16700 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16701 | FFESYMBOL_attrsDUMMY
16702 | FFESYMBOL_attrsEXTERNAL
16703 | FFESYMBOL_attrsTYPE)));
16704
16705 error = TRUE;
16706 }
16707 else if (sa & FFESYMBOL_attrsDUMMY)
16708 {
16709 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16710 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16711 | FFESYMBOL_attrsEXTERNAL
16712 | FFESYMBOL_attrsTYPE)));
16713
16714 error = TRUE;
16715 }
16716 else if (sa & FFESYMBOL_attrsARRAY)
16717 {
16718 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16719 | FFESYMBOL_attrsADJUSTABLE
16720 | FFESYMBOL_attrsTYPE)));
16721
16722 if (sa & FFESYMBOL_attrsADJUSTABLE)
16723 error = TRUE;
16724 where = FFEINFO_whereLOCAL;
16725 }
16726 else if (sa & FFESYMBOL_attrsSFARG)
16727 {
16728 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16729 | FFESYMBOL_attrsTYPE)));
16730
16731 where = FFEINFO_whereLOCAL;
16732 }
16733 else if (sa & FFESYMBOL_attrsTYPE)
16734 {
16735 assert (!(sa & (FFESYMBOL_attrsARRAY
16736 | FFESYMBOL_attrsDUMMY
16737 | FFESYMBOL_attrsEXTERNAL
16738 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16739 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16740 | FFESYMBOL_attrsADJUSTABLE
16741 | FFESYMBOL_attrsANYLEN
16742 | FFESYMBOL_attrsARRAY
16743 | FFESYMBOL_attrsDUMMY
16744 | FFESYMBOL_attrsEXTERNAL
16745 | FFESYMBOL_attrsSFARG)));
16746
16747 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16748 error = TRUE;
16749 else
16750 {
16751 kind = FFEINFO_kindENTITY;
16752 where = FFEINFO_whereLOCAL;
16753 }
16754 }
16755 else if (sa == FFESYMBOL_attrsetNONE)
16756 {
16757 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16758 kind = FFEINFO_kindENTITY;
16759 where = FFEINFO_whereLOCAL;
16760 }
16761 else
16762 error = TRUE;
16763
16764 /* Now see what we've got for a new object: NONE means a new error cropped
16765 up; ANY means an old error to be ignored; otherwise, everything's ok,
16766 update the object (symbol) and continue on. */
16767
16768 if (error)
16769 ffesymbol_error (s, t);
16770 else if (!(na & FFESYMBOL_attrsANY))
16771 {
16772 ffesymbol_signal_change (s); /* May need to back up to previous
16773 version. */
16774 if (!ffeimplic_establish_symbol (s))
16775 {
16776 ffesymbol_error (s, t);
16777 return s;
16778 }
16779 ffesymbol_set_info (s,
16780 ffeinfo_new (ffesymbol_basictype (s),
16781 ffesymbol_kindtype (s),
16782 ffesymbol_rank (s),
16783 kind, /* ENTITY. */
16784 where, /* LOCAL. */
16785 ffesymbol_size (s)));
16786 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16787 ffesymbol_resolve_intrin (s);
16788 s = ffecom_sym_learned (s);
16789 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16790 }
16791
16792 return s;
16793 }
16794
16795 /* Have FOO in EQUIVALENCE (...,FOO,...). Does not include
16796 EQUIVALENCE (...,BAR(FOO),...). */
16797
16798 static ffesymbol
ffeexpr_sym_lhs_equivalence_(ffesymbol s,ffelexToken t)16799 ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t)
16800 {
16801 ffesymbolAttrs sa;
16802 ffesymbolAttrs na;
16803 ffeinfoKind kind;
16804 ffeinfoWhere where;
16805
16806 na = sa = ffesymbol_attrs (s);
16807 kind = FFEINFO_kindENTITY;
16808 where = ffesymbol_where (s);
16809
16810 /* Figure out what kind of object we've got based on previous declarations
16811 of or references to the object. */
16812
16813 if (!(sa & ~(FFESYMBOL_attrsADJUSTS
16814 | FFESYMBOL_attrsARRAY
16815 | FFESYMBOL_attrsCOMMON
16816 | FFESYMBOL_attrsEQUIV
16817 | FFESYMBOL_attrsINIT
16818 | FFESYMBOL_attrsNAMELIST
16819 | FFESYMBOL_attrsSAVE
16820 | FFESYMBOL_attrsSFARG
16821 | FFESYMBOL_attrsTYPE)))
16822 na = sa | FFESYMBOL_attrsEQUIV;
16823 else
16824 na = FFESYMBOL_attrsetNONE;
16825
16826 /* Don't know why we're bothering to set kind and where in this code, but
16827 added the following to make it complete, in case it's really important.
16828 Generally this is left up to symbol exec transition. */
16829
16830 if (where == FFEINFO_whereNONE)
16831 {
16832 if (na & (FFESYMBOL_attrsADJUSTS
16833 | FFESYMBOL_attrsCOMMON))
16834 where = FFEINFO_whereCOMMON;
16835 else if (na & FFESYMBOL_attrsSAVE)
16836 where = FFEINFO_whereLOCAL;
16837 }
16838
16839 /* Now see what we've got for a new object: NONE means a new error cropped
16840 up; ANY means an old error to be ignored; otherwise, everything's ok,
16841 update the object (symbol) and continue on. */
16842
16843 if (na == FFESYMBOL_attrsetNONE)
16844 ffesymbol_error (s, t);
16845 else if (!(na & FFESYMBOL_attrsANY))
16846 {
16847 ffesymbol_signal_change (s); /* May need to back up to previous
16848 version. */
16849 ffesymbol_set_info (s,
16850 ffeinfo_new (ffesymbol_basictype (s),
16851 ffesymbol_kindtype (s),
16852 ffesymbol_rank (s),
16853 kind, /* Always ENTITY. */
16854 where, /* NONE, COMMON, or LOCAL. */
16855 ffesymbol_size (s)));
16856 ffesymbol_set_attrs (s, na);
16857 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
16858 ffesymbol_resolve_intrin (s);
16859 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16860 }
16861
16862 return s;
16863 }
16864
16865 /* Have FOO in OPEN(...,USEROPEN=FOO,...). Executable context only.
16866
16867 Note that I think this should be considered semantically similar to
16868 doing CALL XYZ(FOO), in that it should be considered like an
16869 ACTUALARG context. In particular, without EXTERNAL being specified,
16870 it should not be allowed. */
16871
16872 static ffesymbol
ffeexpr_sym_lhs_extfunc_(ffesymbol s,ffelexToken t)16873 ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t)
16874 {
16875 ffesymbolAttrs sa;
16876 ffesymbolAttrs na;
16877 ffeinfoKind kind;
16878 ffeinfoWhere where;
16879 bool needs_type = FALSE;
16880 bool error = FALSE;
16881
16882 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16883 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16884
16885 na = sa = ffesymbol_attrs (s);
16886
16887 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16888 | FFESYMBOL_attrsADJUSTABLE
16889 | FFESYMBOL_attrsANYLEN
16890 | FFESYMBOL_attrsARRAY
16891 | FFESYMBOL_attrsDUMMY
16892 | FFESYMBOL_attrsEXTERNAL
16893 | FFESYMBOL_attrsSFARG
16894 | FFESYMBOL_attrsTYPE)));
16895
16896 kind = ffesymbol_kind (s);
16897 where = ffesymbol_where (s);
16898
16899 /* Figure out what kind of object we've got based on previous declarations
16900 of or references to the object. */
16901
16902 if (sa & FFESYMBOL_attrsEXTERNAL)
16903 {
16904 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16905 | FFESYMBOL_attrsDUMMY
16906 | FFESYMBOL_attrsEXTERNAL
16907 | FFESYMBOL_attrsTYPE)));
16908
16909 if (sa & FFESYMBOL_attrsTYPE)
16910 where = FFEINFO_whereGLOBAL;
16911 else
16912 /* Not TYPE. */
16913 {
16914 kind = FFEINFO_kindFUNCTION;
16915 needs_type = TRUE;
16916
16917 if (sa & FFESYMBOL_attrsDUMMY)
16918 ; /* Not TYPE. */
16919 else if (sa & FFESYMBOL_attrsACTUALARG)
16920 ; /* Not DUMMY or TYPE. */
16921 else /* Not ACTUALARG, DUMMY, or TYPE. */
16922 where = FFEINFO_whereGLOBAL;
16923 }
16924 }
16925 else if (sa & FFESYMBOL_attrsDUMMY)
16926 {
16927 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16928 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16929 | FFESYMBOL_attrsEXTERNAL
16930 | FFESYMBOL_attrsTYPE)));
16931
16932 kind = FFEINFO_kindFUNCTION;
16933 if (!(sa & FFESYMBOL_attrsTYPE))
16934 needs_type = TRUE;
16935 }
16936 else if (sa & FFESYMBOL_attrsARRAY)
16937 {
16938 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16939 | FFESYMBOL_attrsADJUSTABLE
16940 | FFESYMBOL_attrsTYPE)));
16941
16942 error = TRUE;
16943 }
16944 else if (sa & FFESYMBOL_attrsSFARG)
16945 {
16946 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16947 | FFESYMBOL_attrsTYPE)));
16948
16949 error = TRUE;
16950 }
16951 else if (sa & FFESYMBOL_attrsTYPE)
16952 {
16953 assert (!(sa & (FFESYMBOL_attrsARRAY
16954 | FFESYMBOL_attrsDUMMY
16955 | FFESYMBOL_attrsEXTERNAL
16956 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16957 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16958 | FFESYMBOL_attrsADJUSTABLE
16959 | FFESYMBOL_attrsANYLEN
16960 | FFESYMBOL_attrsARRAY
16961 | FFESYMBOL_attrsDUMMY
16962 | FFESYMBOL_attrsEXTERNAL
16963 | FFESYMBOL_attrsSFARG)));
16964
16965 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16966 error = TRUE;
16967 else
16968 {
16969 kind = FFEINFO_kindFUNCTION;
16970 where = FFEINFO_whereGLOBAL;
16971 }
16972 }
16973 else if (sa == FFESYMBOL_attrsetNONE)
16974 {
16975 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16976 kind = FFEINFO_kindFUNCTION;
16977 where = FFEINFO_whereGLOBAL;
16978 needs_type = TRUE;
16979 }
16980 else
16981 error = TRUE;
16982
16983 /* Now see what we've got for a new object: NONE means a new error cropped
16984 up; ANY means an old error to be ignored; otherwise, everything's ok,
16985 update the object (symbol) and continue on. */
16986
16987 if (error)
16988 ffesymbol_error (s, t);
16989 else if (!(na & FFESYMBOL_attrsANY))
16990 {
16991 ffesymbol_signal_change (s); /* May need to back up to previous
16992 version. */
16993 if (needs_type && !ffeimplic_establish_symbol (s))
16994 {
16995 ffesymbol_error (s, t);
16996 return s;
16997 }
16998 if (!ffesymbol_explicitwhere (s))
16999 {
17000 ffebad_start (FFEBAD_NEED_EXTERNAL);
17001 ffebad_here (0, ffelex_token_where_line (t),
17002 ffelex_token_where_column (t));
17003 ffebad_string (ffesymbol_text (s));
17004 ffebad_finish ();
17005 ffesymbol_set_explicitwhere (s, TRUE);
17006 }
17007 ffesymbol_set_info (s,
17008 ffeinfo_new (ffesymbol_basictype (s),
17009 ffesymbol_kindtype (s),
17010 ffesymbol_rank (s),
17011 kind, /* FUNCTION. */
17012 where, /* GLOBAL or DUMMY. */
17013 ffesymbol_size (s)));
17014 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17015 ffesymbol_resolve_intrin (s);
17016 ffesymbol_reference (s, t, FALSE);
17017 s = ffecom_sym_learned (s);
17018 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17019 }
17020
17021 return s;
17022 }
17023
17024 /* Have FOO in DATA (stuff,FOO=1,10)/.../. */
17025
17026 static ffesymbol
ffeexpr_sym_lhs_impdoctrl_(ffesymbol s,ffelexToken t)17027 ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t)
17028 {
17029 ffesymbolState ss;
17030
17031 /* If the symbol isn't in the sfunc name space, pretend as though we saw a
17032 reference to it already within the imp-DO construct at this level, so as
17033 to get a symbol that is in the sfunc name space. But this is an
17034 erroneous construct, and should be caught elsewhere. */
17035
17036 if (ffesymbol_sfdummyparent (s) == NULL)
17037 {
17038 s = ffeexpr_sym_impdoitem_ (s, t);
17039 if (ffesymbol_sfdummyparent (s) == NULL)
17040 { /* PARAMETER FOO...DATA (A(I),FOO=...). */
17041 ffesymbol_error (s, t);
17042 return s;
17043 }
17044 }
17045
17046 ss = ffesymbol_state (s);
17047
17048 switch (ss)
17049 {
17050 case FFESYMBOL_stateNONE: /* Used as iterator already. */
17051 if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
17052 ffesymbol_error (s, t); /* Can't reuse dead iterator. F90 disallows
17053 this; F77 allows it but it is a stupid
17054 feature. */
17055 else
17056 { /* Can use dead iterator because we're at at
17057 least a innermore (higher-numbered) level
17058 than the iterator's outermost
17059 (lowest-numbered) level. This should be
17060 diagnosed later, because it means an item
17061 in this list didn't reference this
17062 iterator. */
17063 #if 1
17064 ffesymbol_error (s, t); /* For now, complain. */
17065 #else /* Someday will detect all cases where initializer doesn't reference
17066 all applicable iterators, in which case reenable this code. */
17067 ffesymbol_signal_change (s);
17068 ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
17069 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
17070 ffesymbol_signal_unreported (s);
17071 #endif
17072 }
17073 break;
17074
17075 case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO.
17076 If seen in outermore level, can't be an
17077 iterator here, so complain. If not seen
17078 at current level, complain for now,
17079 because that indicates something F90
17080 rejects (though we currently don't detect
17081 all such cases for now). */
17082 if (ffeexpr_level_ <= ffesymbol_maxentrynum (s))
17083 {
17084 ffesymbol_signal_change (s);
17085 ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
17086 ffesymbol_signal_unreported (s);
17087 }
17088 else
17089 ffesymbol_error (s, t);
17090 break;
17091
17092 case FFESYMBOL_stateUNCERTAIN: /* Already iterator! */
17093 assert ("DATA implied-DO control var seen twice!!" == NULL);
17094 ffesymbol_error (s, t);
17095 break;
17096
17097 case FFESYMBOL_stateUNDERSTOOD:
17098 break; /* ANY. */
17099
17100 default:
17101 assert ("Foo Bletch!!" == NULL);
17102 break;
17103 }
17104
17105 return s;
17106 }
17107
17108 /* Have FOO in PARAMETER (FOO=...). */
17109
17110 static ffesymbol
ffeexpr_sym_lhs_parameter_(ffesymbol s,ffelexToken t)17111 ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t)
17112 {
17113 ffesymbolAttrs sa;
17114
17115 sa = ffesymbol_attrs (s);
17116
17117 /* Figure out what kind of object we've got based on previous declarations
17118 of or references to the object. */
17119
17120 if (sa & ~(FFESYMBOL_attrsANYLEN
17121 | FFESYMBOL_attrsTYPE))
17122 {
17123 if (!(sa & FFESYMBOL_attrsANY))
17124 ffesymbol_error (s, t);
17125 }
17126 else
17127 {
17128 ffesymbol_signal_change (s); /* May need to back up to previous
17129 version. */
17130 if (!ffeimplic_establish_symbol (s))
17131 {
17132 ffesymbol_error (s, t);
17133 return s;
17134 }
17135 ffesymbol_set_info (s,
17136 ffeinfo_new (ffesymbol_basictype (s),
17137 ffesymbol_kindtype (s),
17138 ffesymbol_rank (s),
17139 FFEINFO_kindENTITY,
17140 FFEINFO_whereCONSTANT,
17141 ffesymbol_size (s)));
17142 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17143 ffesymbol_resolve_intrin (s);
17144 s = ffecom_sym_learned (s);
17145 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17146 }
17147
17148 return s;
17149 }
17150
17151 /* Have FOO in CALL XYZ(...,FOO,...). Does not include any other
17152 embedding of FOO, such as CALL XYZ((FOO)) or CALL XYZ(FOO+1). */
17153
17154 static ffesymbol
ffeexpr_sym_rhs_actualarg_(ffesymbol s,ffelexToken t)17155 ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t)
17156 {
17157 ffesymbolAttrs sa;
17158 ffesymbolAttrs na;
17159 ffeinfoKind kind;
17160 ffeinfoWhere where;
17161 ffesymbolState ns;
17162 bool needs_type = FALSE;
17163
17164 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
17165 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
17166
17167 na = sa = ffesymbol_attrs (s);
17168
17169 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17170 | FFESYMBOL_attrsADJUSTABLE
17171 | FFESYMBOL_attrsANYLEN
17172 | FFESYMBOL_attrsARRAY
17173 | FFESYMBOL_attrsDUMMY
17174 | FFESYMBOL_attrsEXTERNAL
17175 | FFESYMBOL_attrsSFARG
17176 | FFESYMBOL_attrsTYPE)));
17177
17178 kind = ffesymbol_kind (s);
17179 where = ffesymbol_where (s);
17180
17181 /* Figure out what kind of object we've got based on previous declarations
17182 of or references to the object. */
17183
17184 ns = FFESYMBOL_stateUNDERSTOOD;
17185
17186 if (sa & FFESYMBOL_attrsEXTERNAL)
17187 {
17188 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17189 | FFESYMBOL_attrsDUMMY
17190 | FFESYMBOL_attrsEXTERNAL
17191 | FFESYMBOL_attrsTYPE)));
17192
17193 if (sa & FFESYMBOL_attrsTYPE)
17194 where = FFEINFO_whereGLOBAL;
17195 else
17196 /* Not TYPE. */
17197 {
17198 ns = FFESYMBOL_stateUNCERTAIN;
17199
17200 if (sa & FFESYMBOL_attrsDUMMY)
17201 assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */
17202 else if (sa & FFESYMBOL_attrsACTUALARG)
17203 ; /* Not DUMMY or TYPE. */
17204 else
17205 /* Not ACTUALARG, DUMMY, or TYPE. */
17206 {
17207 assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */
17208 na |= FFESYMBOL_attrsACTUALARG;
17209 where = FFEINFO_whereGLOBAL;
17210 }
17211 }
17212 }
17213 else if (sa & FFESYMBOL_attrsDUMMY)
17214 {
17215 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
17216 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
17217 | FFESYMBOL_attrsEXTERNAL
17218 | FFESYMBOL_attrsTYPE)));
17219
17220 kind = FFEINFO_kindENTITY;
17221 if (!(sa & FFESYMBOL_attrsTYPE))
17222 needs_type = TRUE;
17223 }
17224 else if (sa & FFESYMBOL_attrsARRAY)
17225 {
17226 assert (!(sa & ~(FFESYMBOL_attrsARRAY
17227 | FFESYMBOL_attrsADJUSTABLE
17228 | FFESYMBOL_attrsTYPE)));
17229
17230 where = FFEINFO_whereLOCAL;
17231 }
17232 else if (sa & FFESYMBOL_attrsSFARG)
17233 {
17234 assert (!(sa & ~(FFESYMBOL_attrsSFARG
17235 | FFESYMBOL_attrsTYPE)));
17236
17237 where = FFEINFO_whereLOCAL;
17238 }
17239 else if (sa & FFESYMBOL_attrsTYPE)
17240 {
17241 assert (!(sa & (FFESYMBOL_attrsARRAY
17242 | FFESYMBOL_attrsDUMMY
17243 | FFESYMBOL_attrsEXTERNAL
17244 | FFESYMBOL_attrsSFARG))); /* Handled above. */
17245 assert (!(sa & ~(FFESYMBOL_attrsTYPE
17246 | FFESYMBOL_attrsADJUSTABLE
17247 | FFESYMBOL_attrsANYLEN
17248 | FFESYMBOL_attrsARRAY
17249 | FFESYMBOL_attrsDUMMY
17250 | FFESYMBOL_attrsEXTERNAL
17251 | FFESYMBOL_attrsSFARG)));
17252
17253 if (sa & FFESYMBOL_attrsANYLEN)
17254 ns = FFESYMBOL_stateNONE;
17255 else
17256 {
17257 kind = FFEINFO_kindENTITY;
17258 where = FFEINFO_whereLOCAL;
17259 }
17260 }
17261 else if (sa == FFESYMBOL_attrsetNONE)
17262 {
17263 /* New state is left empty because there isn't any state flag to
17264 set for this case, and it's UNDERSTOOD after all. */
17265 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
17266 kind = FFEINFO_kindENTITY;
17267 where = FFEINFO_whereLOCAL;
17268 needs_type = TRUE;
17269 }
17270 else
17271 ns = FFESYMBOL_stateNONE; /* Error. */
17272
17273 /* Now see what we've got for a new object: NONE means a new error cropped
17274 up; ANY means an old error to be ignored; otherwise, everything's ok,
17275 update the object (symbol) and continue on. */
17276
17277 if (ns == FFESYMBOL_stateNONE)
17278 ffesymbol_error (s, t);
17279 else if (!(na & FFESYMBOL_attrsANY))
17280 {
17281 ffesymbol_signal_change (s); /* May need to back up to previous
17282 version. */
17283 if (needs_type && !ffeimplic_establish_symbol (s))
17284 {
17285 ffesymbol_error (s, t);
17286 return s;
17287 }
17288 ffesymbol_set_info (s,
17289 ffeinfo_new (ffesymbol_basictype (s),
17290 ffesymbol_kindtype (s),
17291 ffesymbol_rank (s),
17292 kind,
17293 where,
17294 ffesymbol_size (s)));
17295 ffesymbol_set_attrs (s, na);
17296 ffesymbol_set_state (s, ns);
17297 s = ffecom_sym_learned (s);
17298 ffesymbol_reference (s, t, FALSE);
17299 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17300 }
17301
17302 return s;
17303 }
17304
17305 /* Have FOO in DIMENSION XYZ(FOO) or any array declarator containing
17306 a reference to FOO. */
17307
17308 static ffesymbol
ffeexpr_sym_rhs_dimlist_(ffesymbol s,ffelexToken t)17309 ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t)
17310 {
17311 ffesymbolAttrs sa;
17312 ffesymbolAttrs na;
17313 ffeinfoKind kind;
17314 ffeinfoWhere where;
17315
17316 na = sa = ffesymbol_attrs (s);
17317 kind = FFEINFO_kindENTITY;
17318 where = ffesymbol_where (s);
17319
17320 /* Figure out what kind of object we've got based on previous declarations
17321 of or references to the object. */
17322
17323 if (!(sa & ~(FFESYMBOL_attrsADJUSTS
17324 | FFESYMBOL_attrsCOMMON
17325 | FFESYMBOL_attrsDUMMY
17326 | FFESYMBOL_attrsEQUIV
17327 | FFESYMBOL_attrsINIT
17328 | FFESYMBOL_attrsNAMELIST
17329 | FFESYMBOL_attrsSFARG
17330 | FFESYMBOL_attrsARRAY
17331 | FFESYMBOL_attrsTYPE)))
17332 na = sa | FFESYMBOL_attrsADJUSTS;
17333 else
17334 na = FFESYMBOL_attrsetNONE;
17335
17336 /* Since this symbol definitely is going into an expression (the
17337 dimension-list for some dummy array, presumably), figure out WHERE if
17338 possible. */
17339
17340 if (where == FFEINFO_whereNONE)
17341 {
17342 if (na & (FFESYMBOL_attrsCOMMON
17343 | FFESYMBOL_attrsEQUIV
17344 | FFESYMBOL_attrsINIT
17345 | FFESYMBOL_attrsNAMELIST))
17346 where = FFEINFO_whereCOMMON;
17347 else if (na & FFESYMBOL_attrsDUMMY)
17348 where = FFEINFO_whereDUMMY;
17349 }
17350
17351 /* Now see what we've got for a new object: NONE means a new error cropped
17352 up; ANY means an old error to be ignored; otherwise, everything's ok,
17353 update the object (symbol) and continue on. */
17354
17355 if (na == FFESYMBOL_attrsetNONE)
17356 ffesymbol_error (s, t);
17357 else if (!(na & FFESYMBOL_attrsANY))
17358 {
17359 ffesymbol_signal_change (s); /* May need to back up to previous
17360 version. */
17361 if (!ffeimplic_establish_symbol (s))
17362 {
17363 ffesymbol_error (s, t);
17364 return s;
17365 }
17366 ffesymbol_set_info (s,
17367 ffeinfo_new (ffesymbol_basictype (s),
17368 ffesymbol_kindtype (s),
17369 ffesymbol_rank (s),
17370 kind, /* Always ENTITY. */
17371 where, /* NONE, COMMON, or DUMMY. */
17372 ffesymbol_size (s)));
17373 ffesymbol_set_attrs (s, na);
17374 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
17375 ffesymbol_resolve_intrin (s);
17376 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17377 }
17378
17379 return s;
17380 }
17381
17382 /* Have FOO in XYZ = ...FOO.... Does not include cases like FOO in
17383 XYZ = BAR(FOO), as such cases are handled elsewhere. */
17384
17385 static ffesymbol
ffeexpr_sym_rhs_let_(ffesymbol s,ffelexToken t)17386 ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t)
17387 {
17388 ffesymbolAttrs sa;
17389 ffesymbolAttrs na;
17390 ffeinfoKind kind;
17391 ffeinfoWhere where;
17392 bool error = FALSE;
17393
17394 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
17395 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
17396
17397 na = sa = ffesymbol_attrs (s);
17398
17399 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17400 | FFESYMBOL_attrsADJUSTABLE
17401 | FFESYMBOL_attrsANYLEN
17402 | FFESYMBOL_attrsARRAY
17403 | FFESYMBOL_attrsDUMMY
17404 | FFESYMBOL_attrsEXTERNAL
17405 | FFESYMBOL_attrsSFARG
17406 | FFESYMBOL_attrsTYPE)));
17407
17408 kind = ffesymbol_kind (s);
17409 where = ffesymbol_where (s);
17410
17411 /* Figure out what kind of object we've got based on previous declarations
17412 of or references to the object. */
17413
17414 if (sa & FFESYMBOL_attrsEXTERNAL)
17415 {
17416 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17417 | FFESYMBOL_attrsDUMMY
17418 | FFESYMBOL_attrsEXTERNAL
17419 | FFESYMBOL_attrsTYPE)));
17420
17421 error = TRUE;
17422 }
17423 else if (sa & FFESYMBOL_attrsDUMMY)
17424 {
17425 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
17426 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
17427 | FFESYMBOL_attrsEXTERNAL
17428 | FFESYMBOL_attrsTYPE)));
17429
17430 kind = FFEINFO_kindENTITY;
17431 }
17432 else if (sa & FFESYMBOL_attrsARRAY)
17433 {
17434 assert (!(sa & ~(FFESYMBOL_attrsARRAY
17435 | FFESYMBOL_attrsADJUSTABLE
17436 | FFESYMBOL_attrsTYPE)));
17437
17438 where = FFEINFO_whereLOCAL;
17439 }
17440 else if (sa & FFESYMBOL_attrsSFARG)
17441 {
17442 assert (!(sa & ~(FFESYMBOL_attrsSFARG
17443 | FFESYMBOL_attrsTYPE)));
17444
17445 where = FFEINFO_whereLOCAL;
17446 }
17447 else if (sa & FFESYMBOL_attrsTYPE)
17448 {
17449 assert (!(sa & (FFESYMBOL_attrsARRAY
17450 | FFESYMBOL_attrsDUMMY
17451 | FFESYMBOL_attrsEXTERNAL
17452 | FFESYMBOL_attrsSFARG))); /* Handled above. */
17453 assert (!(sa & ~(FFESYMBOL_attrsTYPE
17454 | FFESYMBOL_attrsADJUSTABLE
17455 | FFESYMBOL_attrsANYLEN
17456 | FFESYMBOL_attrsARRAY
17457 | FFESYMBOL_attrsDUMMY
17458 | FFESYMBOL_attrsEXTERNAL
17459 | FFESYMBOL_attrsSFARG)));
17460
17461 if (sa & FFESYMBOL_attrsANYLEN)
17462 error = TRUE;
17463 else
17464 {
17465 kind = FFEINFO_kindENTITY;
17466 where = FFEINFO_whereLOCAL;
17467 }
17468 }
17469 else if (sa == FFESYMBOL_attrsetNONE)
17470 {
17471 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
17472 kind = FFEINFO_kindENTITY;
17473 where = FFEINFO_whereLOCAL;
17474 }
17475 else
17476 error = TRUE;
17477
17478 /* Now see what we've got for a new object: NONE means a new error cropped
17479 up; ANY means an old error to be ignored; otherwise, everything's ok,
17480 update the object (symbol) and continue on. */
17481
17482 if (error)
17483 ffesymbol_error (s, t);
17484 else if (!(na & FFESYMBOL_attrsANY))
17485 {
17486 ffesymbol_signal_change (s); /* May need to back up to previous
17487 version. */
17488 if (!ffeimplic_establish_symbol (s))
17489 {
17490 ffesymbol_error (s, t);
17491 return s;
17492 }
17493 ffesymbol_set_info (s,
17494 ffeinfo_new (ffesymbol_basictype (s),
17495 ffesymbol_kindtype (s),
17496 ffesymbol_rank (s),
17497 kind, /* ENTITY. */
17498 where, /* LOCAL. */
17499 ffesymbol_size (s)));
17500 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17501 ffesymbol_resolve_intrin (s);
17502 s = ffecom_sym_learned (s);
17503 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17504 }
17505
17506 return s;
17507 }
17508
17509 /* ffeexpr_declare_parenthesized_ -- ffesymbol wrapper for NAME(...) operand
17510
17511 ffelexToken t;
17512 bool maybe_intrin;
17513 ffeexprParenType_ paren_type;
17514 ffesymbol s;
17515 s = ffeexpr_declare_parenthesized_ (t, maybe_intrin, &paren_type);
17516
17517 Just like ffesymbol_declare_local, except performs any implicit info
17518 assignment necessary, and it returns the type of the parenthesized list
17519 (list of function args, list of array args, or substring spec). */
17520
17521 static ffesymbol
ffeexpr_declare_parenthesized_(ffelexToken t,bool maybe_intrin,ffeexprParenType_ * paren_type)17522 ffeexpr_declare_parenthesized_ (ffelexToken t, bool maybe_intrin,
17523 ffeexprParenType_ *paren_type)
17524 {
17525 ffesymbol s;
17526 ffesymbolState st; /* Effective state. */
17527 ffeinfoKind k;
17528 bool bad;
17529
17530 if (maybe_intrin && ffesrc_check_symbol ())
17531 { /* Knock off some easy cases. */
17532 switch (ffeexpr_stack_->context)
17533 {
17534 case FFEEXPR_contextSUBROUTINEREF:
17535 case FFEEXPR_contextDATA:
17536 case FFEEXPR_contextDATAIMPDOINDEX_:
17537 case FFEEXPR_contextSFUNCDEF:
17538 case FFEEXPR_contextSFUNCDEFINDEX_:
17539 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17540 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17541 case FFEEXPR_contextLET:
17542 case FFEEXPR_contextPAREN_:
17543 case FFEEXPR_contextACTUALARGEXPR_:
17544 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17545 case FFEEXPR_contextIOLIST:
17546 case FFEEXPR_contextIOLISTDF:
17547 case FFEEXPR_contextDO:
17548 case FFEEXPR_contextDOWHILE:
17549 case FFEEXPR_contextACTUALARG_:
17550 case FFEEXPR_contextCGOTO:
17551 case FFEEXPR_contextIF:
17552 case FFEEXPR_contextARITHIF:
17553 case FFEEXPR_contextFORMAT:
17554 case FFEEXPR_contextSTOP:
17555 case FFEEXPR_contextRETURN:
17556 case FFEEXPR_contextSELECTCASE:
17557 case FFEEXPR_contextCASE:
17558 case FFEEXPR_contextFILEASSOC:
17559 case FFEEXPR_contextFILEINT:
17560 case FFEEXPR_contextFILEDFINT:
17561 case FFEEXPR_contextFILELOG:
17562 case FFEEXPR_contextFILENUM:
17563 case FFEEXPR_contextFILENUMAMBIG:
17564 case FFEEXPR_contextFILECHAR:
17565 case FFEEXPR_contextFILENUMCHAR:
17566 case FFEEXPR_contextFILEDFCHAR:
17567 case FFEEXPR_contextFILEKEY:
17568 case FFEEXPR_contextFILEUNIT:
17569 case FFEEXPR_contextFILEUNIT_DF:
17570 case FFEEXPR_contextFILEUNITAMBIG:
17571 case FFEEXPR_contextFILEFORMAT:
17572 case FFEEXPR_contextFILENAMELIST:
17573 case FFEEXPR_contextFILEVXTCODE:
17574 case FFEEXPR_contextINDEX_:
17575 case FFEEXPR_contextIMPDOITEM_:
17576 case FFEEXPR_contextIMPDOITEMDF_:
17577 case FFEEXPR_contextIMPDOCTRL_:
17578 case FFEEXPR_contextDATAIMPDOCTRL_:
17579 case FFEEXPR_contextCHARACTERSIZE:
17580 case FFEEXPR_contextPARAMETER:
17581 case FFEEXPR_contextDIMLIST:
17582 case FFEEXPR_contextDIMLISTCOMMON:
17583 case FFEEXPR_contextKINDTYPE:
17584 case FFEEXPR_contextINITVAL:
17585 case FFEEXPR_contextEQVINDEX_:
17586 break; /* These could be intrinsic invocations. */
17587
17588 case FFEEXPR_contextAGOTO:
17589 case FFEEXPR_contextFILEFORMATNML:
17590 case FFEEXPR_contextALLOCATE:
17591 case FFEEXPR_contextDEALLOCATE:
17592 case FFEEXPR_contextHEAPSTAT:
17593 case FFEEXPR_contextNULLIFY:
17594 case FFEEXPR_contextINCLUDE:
17595 case FFEEXPR_contextDATAIMPDOITEM_:
17596 case FFEEXPR_contextLOC_:
17597 case FFEEXPR_contextINDEXORACTUALARG_:
17598 case FFEEXPR_contextSFUNCDEFACTUALARG_:
17599 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
17600 case FFEEXPR_contextPARENFILENUM_:
17601 case FFEEXPR_contextPARENFILEUNIT_:
17602 maybe_intrin = FALSE;
17603 break; /* Can't be intrinsic invocation. */
17604
17605 default:
17606 assert ("blah! blah! waaauuggh!" == NULL);
17607 break;
17608 }
17609 }
17610
17611 s = ffesymbol_declare_local (t, maybe_intrin);
17612
17613 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17614 /* Special-case these since they can involve a different concept
17615 of "state" (in the stmtfunc name space). */
17616 {
17617 case FFEEXPR_contextDATAIMPDOINDEX_:
17618 case FFEEXPR_contextDATAIMPDOCTRL_:
17619 if (ffeexpr_context_outer_ (ffeexpr_stack_)
17620 == FFEEXPR_contextDATAIMPDOINDEX_)
17621 s = ffeexpr_sym_impdoitem_ (s, t);
17622 else
17623 if (ffeexpr_stack_->is_rhs)
17624 s = ffeexpr_sym_impdoitem_ (s, t);
17625 else
17626 s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
17627 if (ffesymbol_kind (s) != FFEINFO_kindANY)
17628 ffesymbol_error (s, t);
17629 return s;
17630
17631 default:
17632 break;
17633 }
17634
17635 switch ((ffesymbol_sfdummyparent (s) == NULL)
17636 ? ffesymbol_state (s)
17637 : FFESYMBOL_stateUNDERSTOOD)
17638 {
17639 case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr
17640 context. */
17641 if (!ffest_seen_first_exec ())
17642 goto seen; /* :::::::::::::::::::: */
17643 /* Fall through. */
17644 case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */
17645 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17646 {
17647 case FFEEXPR_contextSUBROUTINEREF:
17648 s = ffeexpr_sym_lhs_call_ (s, t); /* "CALL FOO"=="CALL
17649 FOO(...)". */
17650 break;
17651
17652 case FFEEXPR_contextDATA:
17653 if (ffeexpr_stack_->is_rhs)
17654 s = ffeexpr_sym_rhs_let_ (s, t);
17655 else
17656 s = ffeexpr_sym_lhs_data_ (s, t);
17657 break;
17658
17659 case FFEEXPR_contextDATAIMPDOITEM_:
17660 s = ffeexpr_sym_lhs_data_ (s, t);
17661 break;
17662
17663 case FFEEXPR_contextSFUNCDEF:
17664 case FFEEXPR_contextSFUNCDEFINDEX_:
17665 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17666 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17667 s = ffecom_sym_exec_transition (s);
17668 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17669 goto understood; /* :::::::::::::::::::: */
17670 /* Fall through. */
17671 case FFEEXPR_contextLET:
17672 case FFEEXPR_contextPAREN_:
17673 case FFEEXPR_contextACTUALARGEXPR_:
17674 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17675 case FFEEXPR_contextIOLIST:
17676 case FFEEXPR_contextIOLISTDF:
17677 case FFEEXPR_contextDO:
17678 case FFEEXPR_contextDOWHILE:
17679 case FFEEXPR_contextACTUALARG_:
17680 case FFEEXPR_contextCGOTO:
17681 case FFEEXPR_contextIF:
17682 case FFEEXPR_contextARITHIF:
17683 case FFEEXPR_contextFORMAT:
17684 case FFEEXPR_contextSTOP:
17685 case FFEEXPR_contextRETURN:
17686 case FFEEXPR_contextSELECTCASE:
17687 case FFEEXPR_contextCASE:
17688 case FFEEXPR_contextFILEASSOC:
17689 case FFEEXPR_contextFILEINT:
17690 case FFEEXPR_contextFILEDFINT:
17691 case FFEEXPR_contextFILELOG:
17692 case FFEEXPR_contextFILENUM:
17693 case FFEEXPR_contextFILENUMAMBIG:
17694 case FFEEXPR_contextFILECHAR:
17695 case FFEEXPR_contextFILENUMCHAR:
17696 case FFEEXPR_contextFILEDFCHAR:
17697 case FFEEXPR_contextFILEKEY:
17698 case FFEEXPR_contextFILEUNIT:
17699 case FFEEXPR_contextFILEUNIT_DF:
17700 case FFEEXPR_contextFILEUNITAMBIG:
17701 case FFEEXPR_contextFILEFORMAT:
17702 case FFEEXPR_contextFILENAMELIST:
17703 case FFEEXPR_contextFILEVXTCODE:
17704 case FFEEXPR_contextINDEX_:
17705 case FFEEXPR_contextIMPDOITEM_:
17706 case FFEEXPR_contextIMPDOITEMDF_:
17707 case FFEEXPR_contextIMPDOCTRL_:
17708 case FFEEXPR_contextLOC_:
17709 if (ffeexpr_stack_->is_rhs)
17710 s = ffeexpr_paren_rhs_let_ (s, t);
17711 else
17712 s = ffeexpr_paren_lhs_let_ (s, t);
17713 break;
17714
17715 case FFEEXPR_contextASSIGN:
17716 case FFEEXPR_contextAGOTO:
17717 case FFEEXPR_contextCHARACTERSIZE:
17718 case FFEEXPR_contextEQUIVALENCE:
17719 case FFEEXPR_contextINCLUDE:
17720 case FFEEXPR_contextPARAMETER:
17721 case FFEEXPR_contextDIMLIST:
17722 case FFEEXPR_contextDIMLISTCOMMON:
17723 case FFEEXPR_contextKINDTYPE:
17724 case FFEEXPR_contextINITVAL:
17725 case FFEEXPR_contextEQVINDEX_:
17726 break; /* Will turn into errors below. */
17727
17728 default:
17729 ffesymbol_error (s, t);
17730 break;
17731 }
17732 /* Fall through. */
17733 case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */
17734 understood: /* :::::::::::::::::::: */
17735
17736 /* State might have changed, update it. */
17737 st = ((ffesymbol_sfdummyparent (s) == NULL)
17738 ? ffesymbol_state (s)
17739 : FFESYMBOL_stateUNDERSTOOD);
17740
17741 k = ffesymbol_kind (s);
17742 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17743 {
17744 case FFEEXPR_contextSUBROUTINEREF:
17745 bad = ((k != FFEINFO_kindSUBROUTINE)
17746 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
17747 || (k != FFEINFO_kindNONE)));
17748 break;
17749
17750 case FFEEXPR_contextDATA:
17751 if (ffeexpr_stack_->is_rhs)
17752 bad = (k != FFEINFO_kindENTITY)
17753 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
17754 else
17755 bad = (k != FFEINFO_kindENTITY)
17756 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
17757 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
17758 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
17759 break;
17760
17761 case FFEEXPR_contextDATAIMPDOITEM_:
17762 bad = (k != FFEINFO_kindENTITY) || (ffesymbol_rank (s) == 0)
17763 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
17764 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
17765 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
17766 break;
17767
17768 case FFEEXPR_contextSFUNCDEF:
17769 case FFEEXPR_contextSFUNCDEFINDEX_:
17770 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17771 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17772 case FFEEXPR_contextLET:
17773 case FFEEXPR_contextPAREN_:
17774 case FFEEXPR_contextACTUALARGEXPR_:
17775 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17776 case FFEEXPR_contextIOLIST:
17777 case FFEEXPR_contextIOLISTDF:
17778 case FFEEXPR_contextDO:
17779 case FFEEXPR_contextDOWHILE:
17780 case FFEEXPR_contextACTUALARG_:
17781 case FFEEXPR_contextCGOTO:
17782 case FFEEXPR_contextIF:
17783 case FFEEXPR_contextARITHIF:
17784 case FFEEXPR_contextFORMAT:
17785 case FFEEXPR_contextSTOP:
17786 case FFEEXPR_contextRETURN:
17787 case FFEEXPR_contextSELECTCASE:
17788 case FFEEXPR_contextCASE:
17789 case FFEEXPR_contextFILEASSOC:
17790 case FFEEXPR_contextFILEINT:
17791 case FFEEXPR_contextFILEDFINT:
17792 case FFEEXPR_contextFILELOG:
17793 case FFEEXPR_contextFILENUM:
17794 case FFEEXPR_contextFILENUMAMBIG:
17795 case FFEEXPR_contextFILECHAR:
17796 case FFEEXPR_contextFILENUMCHAR:
17797 case FFEEXPR_contextFILEDFCHAR:
17798 case FFEEXPR_contextFILEKEY:
17799 case FFEEXPR_contextFILEUNIT:
17800 case FFEEXPR_contextFILEUNIT_DF:
17801 case FFEEXPR_contextFILEUNITAMBIG:
17802 case FFEEXPR_contextFILEFORMAT:
17803 case FFEEXPR_contextFILENAMELIST:
17804 case FFEEXPR_contextFILEVXTCODE:
17805 case FFEEXPR_contextINDEX_:
17806 case FFEEXPR_contextIMPDOITEM_:
17807 case FFEEXPR_contextIMPDOITEMDF_:
17808 case FFEEXPR_contextIMPDOCTRL_:
17809 case FFEEXPR_contextLOC_:
17810 bad = FALSE; /* Let paren-switch handle the cases. */
17811 break;
17812
17813 case FFEEXPR_contextASSIGN:
17814 case FFEEXPR_contextAGOTO:
17815 case FFEEXPR_contextCHARACTERSIZE:
17816 case FFEEXPR_contextEQUIVALENCE:
17817 case FFEEXPR_contextPARAMETER:
17818 case FFEEXPR_contextDIMLIST:
17819 case FFEEXPR_contextDIMLISTCOMMON:
17820 case FFEEXPR_contextKINDTYPE:
17821 case FFEEXPR_contextINITVAL:
17822 case FFEEXPR_contextEQVINDEX_:
17823 bad = (k != FFEINFO_kindENTITY)
17824 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
17825 break;
17826
17827 case FFEEXPR_contextINCLUDE:
17828 bad = TRUE;
17829 break;
17830
17831 default:
17832 bad = TRUE;
17833 break;
17834 }
17835
17836 switch (bad ? FFEINFO_kindANY : k)
17837 {
17838 case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */
17839 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
17840 {
17841 if (ffeexpr_context_outer_ (ffeexpr_stack_)
17842 == FFEEXPR_contextSUBROUTINEREF)
17843 *paren_type = FFEEXPR_parentypeSUBROUTINE_;
17844 else
17845 *paren_type = FFEEXPR_parentypeFUNCTION_;
17846 break;
17847 }
17848 if (st == FFESYMBOL_stateUNDERSTOOD)
17849 {
17850 bad = TRUE;
17851 *paren_type = FFEEXPR_parentypeANY_;
17852 }
17853 else
17854 *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
17855 break;
17856
17857 case FFEINFO_kindFUNCTION:
17858 *paren_type = FFEEXPR_parentypeFUNCTION_;
17859 switch (ffesymbol_where (s))
17860 {
17861 case FFEINFO_whereLOCAL:
17862 bad = TRUE; /* Attempt to recurse! */
17863 break;
17864
17865 case FFEINFO_whereCONSTANT:
17866 bad = ((ffesymbol_sfexpr (s) == NULL)
17867 || (ffebld_op (ffesymbol_sfexpr (s))
17868 == FFEBLD_opANY)); /* Attempt to recurse! */
17869 break;
17870
17871 default:
17872 break;
17873 }
17874 break;
17875
17876 case FFEINFO_kindSUBROUTINE:
17877 if ((ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
17878 || (ffeexpr_stack_->previous != NULL))
17879 {
17880 bad = TRUE;
17881 *paren_type = FFEEXPR_parentypeANY_;
17882 break;
17883 }
17884
17885 *paren_type = FFEEXPR_parentypeSUBROUTINE_;
17886 switch (ffesymbol_where (s))
17887 {
17888 case FFEINFO_whereLOCAL:
17889 case FFEINFO_whereCONSTANT:
17890 bad = TRUE; /* Attempt to recurse! */
17891 break;
17892
17893 default:
17894 break;
17895 }
17896 break;
17897
17898 case FFEINFO_kindENTITY:
17899 if (ffesymbol_rank (s) == 0)
17900 {
17901 if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
17902 *paren_type = FFEEXPR_parentypeSUBSTRING_;
17903 else
17904 {
17905 bad = TRUE;
17906 *paren_type = FFEEXPR_parentypeANY_;
17907 }
17908 }
17909 else
17910 *paren_type = FFEEXPR_parentypeARRAY_;
17911 break;
17912
17913 default:
17914 case FFEINFO_kindANY:
17915 bad = TRUE;
17916 *paren_type = FFEEXPR_parentypeANY_;
17917 break;
17918 }
17919
17920 if (bad)
17921 {
17922 if (k == FFEINFO_kindANY)
17923 ffest_shutdown ();
17924 else
17925 ffesymbol_error (s, t);
17926 }
17927
17928 return s;
17929
17930 case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */
17931 seen: /* :::::::::::::::::::: */
17932 bad = TRUE;
17933 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17934 {
17935 case FFEEXPR_contextPARAMETER:
17936 if (ffeexpr_stack_->is_rhs)
17937 ffesymbol_error (s, t);
17938 else
17939 s = ffeexpr_sym_lhs_parameter_ (s, t);
17940 break;
17941
17942 case FFEEXPR_contextDATA:
17943 s = ffecom_sym_exec_transition (s);
17944 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17945 goto understood; /* :::::::::::::::::::: */
17946 if (ffeexpr_stack_->is_rhs)
17947 ffesymbol_error (s, t);
17948 else
17949 s = ffeexpr_sym_lhs_data_ (s, t);
17950 goto understood; /* :::::::::::::::::::: */
17951
17952 case FFEEXPR_contextDATAIMPDOITEM_:
17953 s = ffecom_sym_exec_transition (s);
17954 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17955 goto understood; /* :::::::::::::::::::: */
17956 s = ffeexpr_sym_lhs_data_ (s, t);
17957 goto understood; /* :::::::::::::::::::: */
17958
17959 case FFEEXPR_contextEQUIVALENCE:
17960 s = ffeexpr_sym_lhs_equivalence_ (s, t);
17961 bad = FALSE;
17962 break;
17963
17964 case FFEEXPR_contextDIMLIST:
17965 s = ffeexpr_sym_rhs_dimlist_ (s, t);
17966 bad = FALSE;
17967 break;
17968
17969 case FFEEXPR_contextCHARACTERSIZE:
17970 case FFEEXPR_contextKINDTYPE:
17971 case FFEEXPR_contextDIMLISTCOMMON:
17972 case FFEEXPR_contextINITVAL:
17973 case FFEEXPR_contextEQVINDEX_:
17974 break;
17975
17976 case FFEEXPR_contextINCLUDE:
17977 break;
17978
17979 case FFEEXPR_contextINDEX_:
17980 case FFEEXPR_contextACTUALARGEXPR_:
17981 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17982 case FFEEXPR_contextSFUNCDEF:
17983 case FFEEXPR_contextSFUNCDEFINDEX_:
17984 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17985 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17986 assert (ffeexpr_stack_->is_rhs);
17987 s = ffecom_sym_exec_transition (s);
17988 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17989 goto understood; /* :::::::::::::::::::: */
17990 s = ffeexpr_paren_rhs_let_ (s, t);
17991 goto understood; /* :::::::::::::::::::: */
17992
17993 default:
17994 break;
17995 }
17996 k = ffesymbol_kind (s);
17997 switch (bad ? FFEINFO_kindANY : k)
17998 {
17999 case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */
18000 *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
18001 break;
18002
18003 case FFEINFO_kindFUNCTION:
18004 *paren_type = FFEEXPR_parentypeFUNCTION_;
18005 switch (ffesymbol_where (s))
18006 {
18007 case FFEINFO_whereLOCAL:
18008 bad = TRUE; /* Attempt to recurse! */
18009 break;
18010
18011 case FFEINFO_whereCONSTANT:
18012 bad = ((ffesymbol_sfexpr (s) == NULL)
18013 || (ffebld_op (ffesymbol_sfexpr (s))
18014 == FFEBLD_opANY)); /* Attempt to recurse! */
18015 break;
18016
18017 default:
18018 break;
18019 }
18020 break;
18021
18022 case FFEINFO_kindSUBROUTINE:
18023 *paren_type = FFEEXPR_parentypeANY_;
18024 bad = TRUE; /* Cannot possibly be in
18025 contextSUBROUTINEREF. */
18026 break;
18027
18028 case FFEINFO_kindENTITY:
18029 if (ffesymbol_rank (s) == 0)
18030 {
18031 if (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE)
18032 *paren_type = FFEEXPR_parentypeEQUIVALENCE_;
18033 else if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
18034 *paren_type = FFEEXPR_parentypeSUBSTRING_;
18035 else
18036 {
18037 bad = TRUE;
18038 *paren_type = FFEEXPR_parentypeANY_;
18039 }
18040 }
18041 else
18042 *paren_type = FFEEXPR_parentypeARRAY_;
18043 break;
18044
18045 default:
18046 case FFEINFO_kindANY:
18047 bad = TRUE;
18048 *paren_type = FFEEXPR_parentypeANY_;
18049 break;
18050 }
18051
18052 if (bad)
18053 {
18054 if (k == FFEINFO_kindANY)
18055 ffest_shutdown ();
18056 else
18057 ffesymbol_error (s, t);
18058 }
18059
18060 return s;
18061
18062 default:
18063 assert ("bad symbol state" == NULL);
18064 return NULL;
18065 }
18066 }
18067
18068 /* Have FOO in XYZ = ...FOO(...).... Executable context only. */
18069
18070 static ffesymbol
ffeexpr_paren_rhs_let_(ffesymbol s,ffelexToken t)18071 ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t)
18072 {
18073 ffesymbolAttrs sa;
18074 ffesymbolAttrs na;
18075 ffeinfoKind kind;
18076 ffeinfoWhere where;
18077 ffeintrinGen gen;
18078 ffeintrinSpec spec;
18079 ffeintrinImp imp;
18080 bool maybe_ambig = FALSE;
18081 bool error = FALSE;
18082
18083 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
18084 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
18085
18086 na = sa = ffesymbol_attrs (s);
18087
18088 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
18089 | FFESYMBOL_attrsADJUSTABLE
18090 | FFESYMBOL_attrsANYLEN
18091 | FFESYMBOL_attrsARRAY
18092 | FFESYMBOL_attrsDUMMY
18093 | FFESYMBOL_attrsEXTERNAL
18094 | FFESYMBOL_attrsSFARG
18095 | FFESYMBOL_attrsTYPE)));
18096
18097 kind = ffesymbol_kind (s);
18098 where = ffesymbol_where (s);
18099
18100 /* Figure out what kind of object we've got based on previous declarations
18101 of or references to the object. */
18102
18103 if (sa & FFESYMBOL_attrsEXTERNAL)
18104 {
18105 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
18106 | FFESYMBOL_attrsDUMMY
18107 | FFESYMBOL_attrsEXTERNAL
18108 | FFESYMBOL_attrsTYPE)));
18109
18110 if (sa & FFESYMBOL_attrsTYPE)
18111 where = FFEINFO_whereGLOBAL;
18112 else
18113 /* Not TYPE. */
18114 {
18115 kind = FFEINFO_kindFUNCTION;
18116
18117 if (sa & FFESYMBOL_attrsDUMMY)
18118 ; /* Not TYPE. */
18119 else if (sa & FFESYMBOL_attrsACTUALARG)
18120 ; /* Not DUMMY or TYPE. */
18121 else /* Not ACTUALARG, DUMMY, or TYPE. */
18122 where = FFEINFO_whereGLOBAL;
18123 }
18124 }
18125 else if (sa & FFESYMBOL_attrsDUMMY)
18126 {
18127 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
18128 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
18129 | FFESYMBOL_attrsEXTERNAL
18130 | FFESYMBOL_attrsTYPE)));
18131
18132 kind = FFEINFO_kindFUNCTION;
18133 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure; kind
18134 could be ENTITY w/substring ref. */
18135 }
18136 else if (sa & FFESYMBOL_attrsARRAY)
18137 {
18138 assert (!(sa & ~(FFESYMBOL_attrsARRAY
18139 | FFESYMBOL_attrsADJUSTABLE
18140 | FFESYMBOL_attrsTYPE)));
18141
18142 where = FFEINFO_whereLOCAL;
18143 }
18144 else if (sa & FFESYMBOL_attrsSFARG)
18145 {
18146 assert (!(sa & ~(FFESYMBOL_attrsSFARG
18147 | FFESYMBOL_attrsTYPE)));
18148
18149 where = FFEINFO_whereLOCAL; /* Actually an error, but at least we
18150 know it's a local var. */
18151 }
18152 else if (sa & FFESYMBOL_attrsTYPE)
18153 {
18154 assert (!(sa & (FFESYMBOL_attrsARRAY
18155 | FFESYMBOL_attrsDUMMY
18156 | FFESYMBOL_attrsEXTERNAL
18157 | FFESYMBOL_attrsSFARG))); /* Handled above. */
18158 assert (!(sa & ~(FFESYMBOL_attrsTYPE
18159 | FFESYMBOL_attrsADJUSTABLE
18160 | FFESYMBOL_attrsANYLEN
18161 | FFESYMBOL_attrsARRAY
18162 | FFESYMBOL_attrsDUMMY
18163 | FFESYMBOL_attrsEXTERNAL
18164 | FFESYMBOL_attrsSFARG)));
18165
18166 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
18167 &gen, &spec, &imp))
18168 {
18169 if (!(sa & FFESYMBOL_attrsANYLEN)
18170 && (ffeimplic_peek_symbol_type (s, NULL)
18171 == FFEINFO_basictypeCHARACTER))
18172 return s; /* Haven't learned anything yet. */
18173
18174 ffesymbol_signal_change (s); /* May need to back up to previous
18175 version. */
18176 ffesymbol_set_generic (s, gen);
18177 ffesymbol_set_specific (s, spec);
18178 ffesymbol_set_implementation (s, imp);
18179 ffesymbol_set_info (s,
18180 ffeinfo_new (ffesymbol_basictype (s),
18181 ffesymbol_kindtype (s),
18182 0,
18183 FFEINFO_kindFUNCTION,
18184 FFEINFO_whereINTRINSIC,
18185 ffesymbol_size (s)));
18186 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18187 ffesymbol_resolve_intrin (s);
18188 ffesymbol_reference (s, t, FALSE);
18189 s = ffecom_sym_learned (s);
18190 ffesymbol_signal_unreported (s); /* For debugging purposes. */
18191
18192 return s;
18193 }
18194 if (sa & FFESYMBOL_attrsANYLEN)
18195 error = TRUE; /* Error, since the only way we can,
18196 given CHARACTER*(*) FOO, accept
18197 FOO(...) is for FOO to be a dummy
18198 arg or constant, but it can't
18199 become either now. */
18200 else if (sa & FFESYMBOL_attrsADJUSTABLE)
18201 {
18202 kind = FFEINFO_kindENTITY;
18203 where = FFEINFO_whereLOCAL;
18204 }
18205 else
18206 {
18207 kind = FFEINFO_kindFUNCTION;
18208 where = FFEINFO_whereGLOBAL;
18209 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure;
18210 could be ENTITY/LOCAL w/substring ref. */
18211 }
18212 }
18213 else if (sa == FFESYMBOL_attrsetNONE)
18214 {
18215 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
18216
18217 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
18218 &gen, &spec, &imp))
18219 {
18220 if (ffeimplic_peek_symbol_type (s, NULL)
18221 == FFEINFO_basictypeCHARACTER)
18222 return s; /* Haven't learned anything yet. */
18223
18224 ffesymbol_signal_change (s); /* May need to back up to previous
18225 version. */
18226 ffesymbol_set_generic (s, gen);
18227 ffesymbol_set_specific (s, spec);
18228 ffesymbol_set_implementation (s, imp);
18229 ffesymbol_set_info (s,
18230 ffeinfo_new (ffesymbol_basictype (s),
18231 ffesymbol_kindtype (s),
18232 0,
18233 FFEINFO_kindFUNCTION,
18234 FFEINFO_whereINTRINSIC,
18235 ffesymbol_size (s)));
18236 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18237 ffesymbol_resolve_intrin (s);
18238 s = ffecom_sym_learned (s);
18239 ffesymbol_reference (s, t, FALSE);
18240 ffesymbol_signal_unreported (s); /* For debugging purposes. */
18241 return s;
18242 }
18243
18244 kind = FFEINFO_kindFUNCTION;
18245 where = FFEINFO_whereGLOBAL;
18246 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure;
18247 could be ENTITY/LOCAL w/substring ref. */
18248 }
18249 else
18250 error = TRUE;
18251
18252 /* Now see what we've got for a new object: NONE means a new error cropped
18253 up; ANY means an old error to be ignored; otherwise, everything's ok,
18254 update the object (symbol) and continue on. */
18255
18256 if (error)
18257 ffesymbol_error (s, t);
18258 else if (!(na & FFESYMBOL_attrsANY))
18259 {
18260 ffesymbol_signal_change (s); /* May need to back up to previous
18261 version. */
18262 if (!ffeimplic_establish_symbol (s))
18263 {
18264 ffesymbol_error (s, t);
18265 return s;
18266 }
18267 if (maybe_ambig
18268 && (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
18269 return s; /* Still not sure, let caller deal with it
18270 based on (...). */
18271
18272 ffesymbol_set_info (s,
18273 ffeinfo_new (ffesymbol_basictype (s),
18274 ffesymbol_kindtype (s),
18275 ffesymbol_rank (s),
18276 kind,
18277 where,
18278 ffesymbol_size (s)));
18279 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18280 ffesymbol_resolve_intrin (s);
18281 s = ffecom_sym_learned (s);
18282 ffesymbol_reference (s, t, FALSE);
18283 ffesymbol_signal_unreported (s); /* For debugging purposes. */
18284 }
18285
18286 return s;
18287 }
18288
18289 /* ffeexpr_token_arguments_ -- OPEN_PAREN [expr COMMA]...expr
18290
18291 Return a pointer to this function to the lexer (ffelex), which will
18292 invoke it for the next token.
18293
18294 Handle expression (which might be null) and COMMA or CLOSE_PAREN. */
18295
18296 static ffelexHandler
ffeexpr_token_arguments_(ffelexToken ft,ffebld expr,ffelexToken t)18297 ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr, ffelexToken t)
18298 {
18299 ffeexprExpr_ procedure;
18300 ffebld reduced;
18301 ffeinfo info;
18302 ffeexprContext ctx;
18303 bool check_intrin = FALSE; /* Set TRUE if intrinsic is REAL(Z) or AIMAG(Z). */
18304
18305 procedure = ffeexpr_stack_->exprstack;
18306 info = ffebld_info (procedure->u.operand);
18307
18308 /* Is there an expression to add? If the expression is nil,
18309 it might still be an argument. It is if:
18310
18311 - The current token is comma, or
18312
18313 - The -fugly-comma flag was specified *and* the procedure
18314 being invoked is external.
18315
18316 Otherwise, if neither of the above is the case, just
18317 ignore this (nil) expression. */
18318
18319 if ((expr != NULL)
18320 || (ffelex_token_type (t) == FFELEX_typeCOMMA)
18321 || (ffe_is_ugly_comma ()
18322 && (ffeinfo_where (info) == FFEINFO_whereGLOBAL)))
18323 {
18324 /* This expression, even if nil, is apparently intended as an argument. */
18325
18326 /* Internal procedure (CONTAINS, or statement function)? */
18327
18328 if (ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18329 {
18330 if ((expr == NULL)
18331 && ffebad_start (FFEBAD_NULL_ARGUMENT))
18332 {
18333 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18334 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18335 ffebad_here (1, ffelex_token_where_line (t),
18336 ffelex_token_where_column (t));
18337 ffebad_finish ();
18338 }
18339
18340 if (expr == NULL)
18341 ;
18342 else
18343 {
18344 if (ffeexpr_stack_->next_dummy == NULL)
18345 { /* Report later which was the first extra argument. */
18346 if (ffeexpr_stack_->tokens[1] == NULL)
18347 {
18348 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
18349 ffeexpr_stack_->num_args = 0;
18350 }
18351 ++ffeexpr_stack_->num_args; /* Count # of extra arguments. */
18352 }
18353 else
18354 {
18355 if ((ffeinfo_rank (ffebld_info (expr)) != 0)
18356 && ffebad_start (FFEBAD_ARRAY_AS_SFARG))
18357 {
18358 ffebad_here (0,
18359 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18360 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18361 ffebad_here (1, ffelex_token_where_line (ft),
18362 ffelex_token_where_column (ft));
18363 ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent
18364 (ffebld_symter (ffebld_head
18365 (ffeexpr_stack_->next_dummy)))));
18366 ffebad_finish ();
18367 }
18368 else
18369 {
18370 expr = ffeexpr_convert_expr (expr, ft,
18371 ffebld_head (ffeexpr_stack_->next_dummy),
18372 ffeexpr_stack_->tokens[0],
18373 FFEEXPR_contextLET);
18374 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18375 }
18376 --ffeexpr_stack_->num_args; /* Count down # of args. */
18377 ffeexpr_stack_->next_dummy
18378 = ffebld_trail (ffeexpr_stack_->next_dummy);
18379 }
18380 }
18381 }
18382 else
18383 {
18384 if ((expr == NULL)
18385 && ffe_is_pedantic ()
18386 && ffebad_start (FFEBAD_NULL_ARGUMENT_W))
18387 {
18388 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18389 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18390 ffebad_here (1, ffelex_token_where_line (t),
18391 ffelex_token_where_column (t));
18392 ffebad_finish ();
18393 }
18394 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18395 }
18396 }
18397
18398 switch (ffelex_token_type (t))
18399 {
18400 case FFELEX_typeCOMMA:
18401 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
18402 {
18403 case FFEEXPR_contextSFUNCDEF:
18404 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
18405 case FFEEXPR_contextSFUNCDEFINDEX_:
18406 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
18407 ctx = FFEEXPR_contextSFUNCDEFACTUALARG_;
18408 break;
18409
18410 case FFEEXPR_contextSFUNCDEFACTUALARG_:
18411 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18412 assert ("bad context" == NULL);
18413 ctx = FFEEXPR_context;
18414 break;
18415
18416 default:
18417 ctx = FFEEXPR_contextACTUALARG_;
18418 break;
18419 }
18420 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18421 ffeexpr_token_arguments_);
18422
18423 default:
18424 break;
18425 }
18426
18427 if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18428 && (ffeexpr_stack_->next_dummy != NULL))
18429 { /* Too few arguments. */
18430 if (ffebad_start (FFEBAD_TOO_FEW_ARGUMENTS))
18431 {
18432 char num[10];
18433
18434 sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
18435
18436 ffebad_here (0, ffelex_token_where_line (t),
18437 ffelex_token_where_column (t));
18438 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18439 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18440 ffebad_string (num);
18441 ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent (ffebld_symter
18442 (ffebld_head (ffeexpr_stack_->next_dummy)))));
18443 ffebad_finish ();
18444 }
18445 for (;
18446 ffeexpr_stack_->next_dummy != NULL;
18447 ffeexpr_stack_->next_dummy
18448 = ffebld_trail (ffeexpr_stack_->next_dummy))
18449 {
18450 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0));
18451 ffebld_set_info (expr, ffeinfo_new_any ());
18452 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18453 }
18454 }
18455
18456 if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18457 && (ffeexpr_stack_->tokens[1] != NULL))
18458 { /* Too many arguments to statement function. */
18459 if (ffebad_start (FFEBAD_TOO_MANY_ARGUMENTS))
18460 {
18461 char num[10];
18462
18463 sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
18464
18465 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
18466 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
18467 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18468 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18469 ffebad_string (num);
18470 ffebad_finish ();
18471 }
18472 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
18473 }
18474 ffebld_end_list (&ffeexpr_stack_->bottom);
18475
18476 if (ffebld_op (procedure->u.operand) == FFEBLD_opANY)
18477 {
18478 reduced = ffebld_new_any ();
18479 ffebld_set_info (reduced, ffeinfo_new_any ());
18480 }
18481 else
18482 {
18483 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
18484 reduced = ffebld_new_funcref (procedure->u.operand,
18485 ffeexpr_stack_->expr);
18486 else
18487 reduced = ffebld_new_subrref (procedure->u.operand,
18488 ffeexpr_stack_->expr);
18489 if (ffebld_symter_generic (procedure->u.operand) != FFEINTRIN_genNONE)
18490 ffeintrin_fulfill_generic (&reduced, &info, ffeexpr_stack_->tokens[0]);
18491 else if (ffebld_symter_specific (procedure->u.operand)
18492 != FFEINTRIN_specNONE)
18493 ffeintrin_fulfill_specific (&reduced, &info, &check_intrin,
18494 ffeexpr_stack_->tokens[0]);
18495 else
18496 ffeexpr_fulfill_call_ (&reduced, ffeexpr_stack_->tokens[0]);
18497
18498 if (ffebld_op (reduced) != FFEBLD_opANY)
18499 ffebld_set_info (reduced,
18500 ffeinfo_new (ffeinfo_basictype (info),
18501 ffeinfo_kindtype (info),
18502 0,
18503 FFEINFO_kindENTITY,
18504 FFEINFO_whereFLEETING,
18505 ffeinfo_size (info)));
18506 else
18507 ffebld_set_info (reduced, ffeinfo_new_any ());
18508 }
18509 if (ffebld_op (reduced) == FFEBLD_opFUNCREF)
18510 reduced = ffeexpr_collapse_funcref (reduced, ffeexpr_stack_->tokens[0]);
18511 ffeexpr_stack_->exprstack = procedure->previous; /* Pops
18512 not-quite-operand off
18513 stack. */
18514 procedure->u.operand = reduced; /* Save the line/column ffewhere
18515 info. */
18516 ffeexpr_exprstack_push_operand_ (procedure); /* Push it back on stack. */
18517 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18518 {
18519 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18520 ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FUNC(3)(1:1)".... */
18521
18522 /* If the intrinsic needs checking (is REAL(Z) or AIMAG(Z), where
18523 Z is DOUBLE COMPLEX), and a command-line option doesn't already
18524 establish interpretation, probably complain. */
18525
18526 if (check_intrin
18527 && !ffe_is_90 ()
18528 && !ffe_is_ugly_complex ())
18529 {
18530 /* If the outer expression is REAL(me...), issue diagnostic
18531 only if next token isn't the close-paren for REAL(me). */
18532
18533 if ((ffeexpr_stack_->previous != NULL)
18534 && (ffeexpr_stack_->previous->exprstack != NULL)
18535 && (ffeexpr_stack_->previous->exprstack->type == FFEEXPR_exprtypeOPERAND_)
18536 && ((reduced = ffeexpr_stack_->previous->exprstack->u.operand) != NULL)
18537 && (ffebld_op (reduced) == FFEBLD_opSYMTER)
18538 && (ffebld_symter_implementation (reduced) == FFEINTRIN_impREAL))
18539 return (ffelexHandler) ffeexpr_token_intrincheck_;
18540
18541 /* Diagnose the ambiguity now. */
18542
18543 if (ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
18544 {
18545 ffebad_string (ffeintrin_name_implementation
18546 (ffebld_symter_implementation
18547 (ffebld_left
18548 (ffeexpr_stack_->exprstack->u.operand))));
18549 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
18550 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
18551 ffebad_finish ();
18552 }
18553 }
18554 return (ffelexHandler) ffeexpr_token_substrp_;
18555 }
18556
18557 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
18558 {
18559 ffebad_here (0, ffelex_token_where_line (t),
18560 ffelex_token_where_column (t));
18561 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18562 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18563 ffebad_finish ();
18564 }
18565 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18566 ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FUNC(3)(1:1)".... */
18567 return
18568 (ffelexHandler) ffeexpr_find_close_paren_ (t,
18569 (ffelexHandler)
18570 ffeexpr_token_substrp_);
18571 }
18572
18573 /* ffeexpr_token_elements_ -- OPEN_PAREN [expr COMMA]...expr
18574
18575 Return a pointer to this array to the lexer (ffelex), which will
18576 invoke it for the next token.
18577
18578 Handle expression and COMMA or CLOSE_PAREN. */
18579
18580 static ffelexHandler
ffeexpr_token_elements_(ffelexToken ft,ffebld expr,ffelexToken t)18581 ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, ffelexToken t)
18582 {
18583 ffeexprExpr_ array;
18584 ffebld reduced;
18585 ffeinfo info;
18586 ffeinfoWhere where;
18587 ffetargetIntegerDefault val;
18588 ffetargetIntegerDefault lval = 0;
18589 ffetargetIntegerDefault uval = 0;
18590 ffebld lbound;
18591 ffebld ubound;
18592 bool lcheck;
18593 bool ucheck;
18594
18595 array = ffeexpr_stack_->exprstack;
18596 info = ffebld_info (array->u.operand);
18597
18598 if ((expr == NULL) /* && ((ffeexpr_stack_->rank != 0) ||
18599 (ffelex_token_type(t) ==
18600 FFELEX_typeCOMMA)) */ )
18601 {
18602 if (ffebad_start (FFEBAD_NULL_ELEMENT))
18603 {
18604 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18605 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18606 ffebad_here (1, ffelex_token_where_line (t),
18607 ffelex_token_where_column (t));
18608 ffebad_finish ();
18609 }
18610 if (ffeexpr_stack_->rank < ffeinfo_rank (info))
18611 { /* Don't bother if we're going to complain
18612 later! */
18613 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
18614 ffebld_set_info (expr, ffeinfo_new_any ());
18615 }
18616 }
18617
18618 if (expr == NULL)
18619 ;
18620 else if (ffeinfo_rank (info) == 0)
18621 { /* In EQUIVALENCE context, ffeinfo_rank(info)
18622 may == 0. */
18623 ++ffeexpr_stack_->rank; /* Track anyway, may need for new VXT
18624 feature. */
18625 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18626 }
18627 else
18628 {
18629 ++ffeexpr_stack_->rank;
18630 if (ffeexpr_stack_->rank > ffeinfo_rank (info))
18631 { /* Report later which was the first extra
18632 element. */
18633 if (ffeexpr_stack_->rank == ffeinfo_rank (info) + 1)
18634 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
18635 }
18636 else
18637 {
18638 switch (ffeinfo_where (ffebld_info (expr)))
18639 {
18640 case FFEINFO_whereCONSTANT:
18641 break;
18642
18643 case FFEINFO_whereIMMEDIATE:
18644 ffeexpr_stack_->constant = FALSE;
18645 break;
18646
18647 default:
18648 ffeexpr_stack_->constant = FALSE;
18649 ffeexpr_stack_->immediate = FALSE;
18650 break;
18651 }
18652 if (ffebld_op (expr) == FFEBLD_opCONTER
18653 && ffebld_kindtype (expr) == FFEINFO_kindtypeINTEGERDEFAULT)
18654 {
18655 val = ffebld_constant_integerdefault (ffebld_conter (expr));
18656
18657 lbound = ffebld_left (ffebld_head (ffeexpr_stack_->bound_list));
18658 if (lbound == NULL)
18659 {
18660 lcheck = TRUE;
18661 lval = 1;
18662 }
18663 else if (ffebld_op (lbound) == FFEBLD_opCONTER)
18664 {
18665 lcheck = TRUE;
18666 lval = ffebld_constant_integerdefault (ffebld_conter (lbound));
18667 }
18668 else
18669 lcheck = FALSE;
18670
18671 ubound = ffebld_right (ffebld_head (ffeexpr_stack_->bound_list));
18672 assert (ubound != NULL);
18673 if (ffebld_op (ubound) == FFEBLD_opCONTER)
18674 {
18675 ucheck = TRUE;
18676 uval = ffebld_constant_integerdefault (ffebld_conter (ubound));
18677 }
18678 else
18679 ucheck = FALSE;
18680
18681 if ((lcheck && (val < lval)) || (ucheck && (val > uval)))
18682 {
18683 ffebad_start (FFEBAD_RANGE_ARRAY);
18684 ffebad_here (0, ffelex_token_where_line (ft),
18685 ffelex_token_where_column (ft));
18686 ffebad_finish ();
18687 }
18688 }
18689 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18690 ffeexpr_stack_->bound_list = ffebld_trail (ffeexpr_stack_->bound_list);
18691 }
18692 }
18693
18694 switch (ffelex_token_type (t))
18695 {
18696 case FFELEX_typeCOMMA:
18697 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
18698 {
18699 case FFEEXPR_contextDATAIMPDOITEM_:
18700 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18701 FFEEXPR_contextDATAIMPDOINDEX_,
18702 ffeexpr_token_elements_);
18703
18704 case FFEEXPR_contextEQUIVALENCE:
18705 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18706 FFEEXPR_contextEQVINDEX_,
18707 ffeexpr_token_elements_);
18708
18709 case FFEEXPR_contextSFUNCDEF:
18710 case FFEEXPR_contextSFUNCDEFINDEX_:
18711 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18712 FFEEXPR_contextSFUNCDEFINDEX_,
18713 ffeexpr_token_elements_);
18714
18715 case FFEEXPR_contextSFUNCDEFACTUALARG_:
18716 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18717 assert ("bad context" == NULL);
18718 break;
18719
18720 default:
18721 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18722 FFEEXPR_contextINDEX_,
18723 ffeexpr_token_elements_);
18724 }
18725
18726 default:
18727 break;
18728 }
18729
18730 if ((ffeexpr_stack_->rank != ffeinfo_rank (info))
18731 && (ffeinfo_rank (info) != 0))
18732 {
18733 char num[10];
18734
18735 if (ffeexpr_stack_->rank < ffeinfo_rank (info))
18736 {
18737 if (ffebad_start (FFEBAD_TOO_FEW_ELEMENTS))
18738 {
18739 sprintf (num, "%d",
18740 (int) (ffeinfo_rank (info) - ffeexpr_stack_->rank));
18741
18742 ffebad_here (0, ffelex_token_where_line (t),
18743 ffelex_token_where_column (t));
18744 ffebad_here (1,
18745 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18746 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18747 ffebad_string (num);
18748 ffebad_finish ();
18749 }
18750 }
18751 else
18752 {
18753 if (ffebad_start (FFEBAD_TOO_MANY_ELEMENTS))
18754 {
18755 sprintf (num, "%d",
18756 (int) (ffeexpr_stack_->rank - ffeinfo_rank (info)));
18757
18758 ffebad_here (0,
18759 ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
18760 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
18761 ffebad_here (1,
18762 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18763 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18764 ffebad_string (num);
18765 ffebad_finish ();
18766 }
18767 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
18768 }
18769 while (ffeexpr_stack_->rank++ < ffeinfo_rank (info))
18770 {
18771 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
18772 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeINTEGER,
18773 FFEINFO_kindtypeINTEGERDEFAULT,
18774 0, FFEINFO_kindENTITY,
18775 FFEINFO_whereCONSTANT,
18776 FFETARGET_charactersizeNONE));
18777 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18778 }
18779 }
18780 ffebld_end_list (&ffeexpr_stack_->bottom);
18781
18782 if (ffebld_op (array->u.operand) == FFEBLD_opANY)
18783 {
18784 reduced = ffebld_new_any ();
18785 ffebld_set_info (reduced, ffeinfo_new_any ());
18786 }
18787 else
18788 {
18789 reduced = ffebld_new_arrayref (array->u.operand, ffeexpr_stack_->expr);
18790 if (ffeexpr_stack_->constant)
18791 where = FFEINFO_whereFLEETING_CADDR;
18792 else if (ffeexpr_stack_->immediate)
18793 where = FFEINFO_whereFLEETING_IADDR;
18794 else
18795 where = FFEINFO_whereFLEETING;
18796 ffebld_set_info (reduced,
18797 ffeinfo_new (ffeinfo_basictype (info),
18798 ffeinfo_kindtype (info),
18799 0,
18800 FFEINFO_kindENTITY,
18801 where,
18802 ffeinfo_size (info)));
18803 reduced = ffeexpr_collapse_arrayref (reduced, ffeexpr_stack_->tokens[0]);
18804 }
18805
18806 ffeexpr_stack_->exprstack = array->previous; /* Pops not-quite-operand off
18807 stack. */
18808 array->u.operand = reduced; /* Save the line/column ffewhere info. */
18809 ffeexpr_exprstack_push_operand_ (array); /* Push it back on stack. */
18810
18811 switch (ffeinfo_basictype (info))
18812 {
18813 case FFEINFO_basictypeCHARACTER:
18814 ffeexpr_is_substr_ok_ = TRUE; /* Everyone likes "FOO(3)(1:1)".... */
18815 break;
18816
18817 case FFEINFO_basictypeNONE:
18818 ffeexpr_is_substr_ok_ = TRUE;
18819 assert (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE);
18820 break;
18821
18822 default:
18823 ffeexpr_is_substr_ok_ = FALSE;
18824 break;
18825 }
18826
18827 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18828 {
18829 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18830 return (ffelexHandler) ffeexpr_token_substrp_;
18831 }
18832
18833 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
18834 {
18835 ffebad_here (0, ffelex_token_where_line (t),
18836 ffelex_token_where_column (t));
18837 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18838 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18839 ffebad_finish ();
18840 }
18841 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18842 return
18843 (ffelexHandler) ffeexpr_find_close_paren_ (t,
18844 (ffelexHandler)
18845 ffeexpr_token_substrp_);
18846 }
18847
18848 /* ffeexpr_token_equivalence_ -- OPEN_PAREN expr
18849
18850 Return a pointer to this array to the lexer (ffelex), which will
18851 invoke it for the next token.
18852
18853 If token is COLON, pass off to _substr_, else init list and pass off
18854 to _elements_. This handles the case "EQUIVALENCE (FOO(expr?", where
18855 ? marks the token, and where FOO's rank/type has not yet been established,
18856 meaning we could be in a list of indices or in a substring
18857 specification. */
18858
18859 static ffelexHandler
ffeexpr_token_equivalence_(ffelexToken ft,ffebld expr,ffelexToken t)18860 ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr, ffelexToken t)
18861 {
18862 if (ffelex_token_type (t) == FFELEX_typeCOLON)
18863 return ffeexpr_token_substring_ (ft, expr, t);
18864
18865 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
18866 return ffeexpr_token_elements_ (ft, expr, t);
18867 }
18868
18869 /* ffeexpr_token_substring_ -- NAME(of kindENTITY) OPEN_PAREN expr
18870
18871 Return a pointer to this function to the lexer (ffelex), which will
18872 invoke it for the next token.
18873
18874 Handle expression (which may be null) and COLON. */
18875
18876 static ffelexHandler
ffeexpr_token_substring_(ffelexToken ft,ffebld expr,ffelexToken t)18877 ffeexpr_token_substring_ (ffelexToken ft, ffebld expr, ffelexToken t)
18878 {
18879 ffeexprExpr_ string;
18880 ffeinfo info;
18881 ffetargetIntegerDefault i;
18882 ffeexprContext ctx;
18883 ffetargetCharacterSize size;
18884
18885 string = ffeexpr_stack_->exprstack;
18886 info = ffebld_info (string->u.operand);
18887 size = ffebld_size_max (string->u.operand);
18888
18889 if (ffelex_token_type (t) == FFELEX_typeCOLON)
18890 {
18891 if ((expr != NULL)
18892 && (ffebld_op (expr) == FFEBLD_opCONTER)
18893 && (((i = ffebld_constant_integerdefault (ffebld_conter (expr)))
18894 < 1)
18895 || ((size != FFETARGET_charactersizeNONE) && (i > size))))
18896 {
18897 ffebad_start (FFEBAD_RANGE_SUBSTR);
18898 ffebad_here (0, ffelex_token_where_line (ft),
18899 ffelex_token_where_column (ft));
18900 ffebad_finish ();
18901 }
18902 ffeexpr_stack_->expr = expr;
18903
18904 switch (ffeexpr_stack_->context)
18905 {
18906 case FFEEXPR_contextSFUNCDEF:
18907 case FFEEXPR_contextSFUNCDEFINDEX_:
18908 ctx = FFEEXPR_contextSFUNCDEFINDEX_;
18909 break;
18910
18911 case FFEEXPR_contextSFUNCDEFACTUALARG_:
18912 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18913 assert ("bad context" == NULL);
18914 ctx = FFEEXPR_context;
18915 break;
18916
18917 default:
18918 ctx = FFEEXPR_contextINDEX_;
18919 break;
18920 }
18921
18922 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18923 ffeexpr_token_substring_1_);
18924 }
18925
18926 if (ffest_ffebad_start (FFEBAD_MISSING_COLON_IN_SUBSTR))
18927 {
18928 ffebad_here (0, ffelex_token_where_line (t),
18929 ffelex_token_where_column (t));
18930 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18931 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18932 ffebad_finish ();
18933 }
18934
18935 ffeexpr_stack_->expr = NULL;
18936 return (ffelexHandler) ffeexpr_token_substring_1_ (ft, expr, t);
18937 }
18938
18939 /* ffeexpr_token_substring_1_ -- NAME OPEN_PAREN [expr COMMA]...expr
18940
18941 Return a pointer to this function to the lexer (ffelex), which will
18942 invoke it for the next token.
18943
18944 Handle expression (which might be null) and CLOSE_PAREN. */
18945
18946 static ffelexHandler
ffeexpr_token_substring_1_(ffelexToken ft,ffebld last,ffelexToken t)18947 ffeexpr_token_substring_1_ (ffelexToken ft, ffebld last, ffelexToken t)
18948 {
18949 ffeexprExpr_ string;
18950 ffebld reduced;
18951 ffebld substrlist;
18952 ffebld first = ffeexpr_stack_->expr;
18953 ffebld strop;
18954 ffeinfo info;
18955 ffeinfoWhere lwh;
18956 ffeinfoWhere rwh;
18957 ffeinfoWhere where;
18958 ffeinfoKindtype first_kt;
18959 ffeinfoKindtype last_kt;
18960 ffetargetIntegerDefault first_val;
18961 ffetargetIntegerDefault last_val;
18962 ffetargetCharacterSize size;
18963 ffetargetCharacterSize strop_size_max;
18964 bool first_known;
18965
18966 string = ffeexpr_stack_->exprstack;
18967 strop = string->u.operand;
18968 info = ffebld_info (strop);
18969
18970 if (first == NULL
18971 || (ffebld_op (first) == FFEBLD_opCONTER
18972 && ffebld_kindtype (first) == FFEINFO_kindtypeINTEGERDEFAULT))
18973 { /* The starting point is known. */
18974 first_val = (first == NULL) ? 1
18975 : ffebld_constant_integerdefault (ffebld_conter (first));
18976 first_known = TRUE;
18977 }
18978 else
18979 { /* Assume start of the entity. */
18980 first_val = 1;
18981 first_known = FALSE;
18982 }
18983
18984 if (last != NULL
18985 && (ffebld_op (last) == FFEBLD_opCONTER
18986 && ffebld_kindtype (last) == FFEINFO_kindtypeINTEGERDEFAULT))
18987 { /* The ending point is known. */
18988 last_val = ffebld_constant_integerdefault (ffebld_conter (last));
18989
18990 if (first_known)
18991 { /* The beginning point is a constant. */
18992 if (first_val <= last_val)
18993 size = last_val - first_val + 1;
18994 else
18995 {
18996 if (0 && ffe_is_90 ())
18997 size = 0;
18998 else
18999 {
19000 size = 1;
19001 ffebad_start (FFEBAD_ZERO_SIZE);
19002 ffebad_here (0, ffelex_token_where_line (ft),
19003 ffelex_token_where_column (ft));
19004 ffebad_finish ();
19005 }
19006 }
19007 }
19008 else
19009 size = FFETARGET_charactersizeNONE;
19010
19011 strop_size_max = ffebld_size_max (strop);
19012
19013 if ((strop_size_max != FFETARGET_charactersizeNONE)
19014 && (last_val > strop_size_max))
19015 { /* Beyond maximum possible end of string. */
19016 ffebad_start (FFEBAD_RANGE_SUBSTR);
19017 ffebad_here (0, ffelex_token_where_line (ft),
19018 ffelex_token_where_column (ft));
19019 ffebad_finish ();
19020 }
19021 }
19022 else
19023 size = FFETARGET_charactersizeNONE; /* The size is not known. */
19024
19025 #if 0 /* Don't do this, or "is size of target
19026 known?" would no longer be easily
19027 answerable. To see if there is a max
19028 size, use ffebld_size_max; to get only the
19029 known size, else NONE, use
19030 ffebld_size_known; use ffebld_size if
19031 values are sure to be the same (not
19032 opSUBSTR or opCONCATENATE or known to have
19033 known length). By getting rid of this
19034 "useful info" stuff, we don't end up
19035 blank-padding the constant in the
19036 assignment "A(I:J)='XYZ'" to the known
19037 length of A. */
19038 if (size == FFETARGET_charactersizeNONE)
19039 size = strop_size_max; /* Assume we use the entire string. */
19040 #endif
19041
19042 substrlist
19043 = ffebld_new_item
19044 (first,
19045 ffebld_new_item
19046 (last,
19047 NULL
19048 )
19049 )
19050 ;
19051
19052 if (first == NULL)
19053 lwh = FFEINFO_whereCONSTANT;
19054 else
19055 lwh = ffeinfo_where (ffebld_info (first));
19056 if (last == NULL)
19057 rwh = FFEINFO_whereCONSTANT;
19058 else
19059 rwh = ffeinfo_where (ffebld_info (last));
19060
19061 switch (lwh)
19062 {
19063 case FFEINFO_whereCONSTANT:
19064 switch (rwh)
19065 {
19066 case FFEINFO_whereCONSTANT:
19067 where = FFEINFO_whereCONSTANT;
19068 break;
19069
19070 case FFEINFO_whereIMMEDIATE:
19071 where = FFEINFO_whereIMMEDIATE;
19072 break;
19073
19074 default:
19075 where = FFEINFO_whereFLEETING;
19076 break;
19077 }
19078 break;
19079
19080 case FFEINFO_whereIMMEDIATE:
19081 switch (rwh)
19082 {
19083 case FFEINFO_whereCONSTANT:
19084 case FFEINFO_whereIMMEDIATE:
19085 where = FFEINFO_whereIMMEDIATE;
19086 break;
19087
19088 default:
19089 where = FFEINFO_whereFLEETING;
19090 break;
19091 }
19092 break;
19093
19094 default:
19095 where = FFEINFO_whereFLEETING;
19096 break;
19097 }
19098
19099 if (first == NULL)
19100 first_kt = FFEINFO_kindtypeINTEGERDEFAULT;
19101 else
19102 first_kt = ffeinfo_kindtype (ffebld_info (first));
19103 if (last == NULL)
19104 last_kt = FFEINFO_kindtypeINTEGERDEFAULT;
19105 else
19106 last_kt = ffeinfo_kindtype (ffebld_info (last));
19107
19108 switch (where)
19109 {
19110 case FFEINFO_whereCONSTANT:
19111 switch (ffeinfo_where (info))
19112 {
19113 case FFEINFO_whereCONSTANT:
19114 break;
19115
19116 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
19117 where = FFEINFO_whereIMMEDIATE;
19118 break;
19119
19120 default:
19121 where = FFEINFO_whereFLEETING_CADDR;
19122 break;
19123 }
19124 break;
19125
19126 case FFEINFO_whereIMMEDIATE:
19127 switch (ffeinfo_where (info))
19128 {
19129 case FFEINFO_whereCONSTANT:
19130 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
19131 break;
19132
19133 default:
19134 where = FFEINFO_whereFLEETING_IADDR;
19135 break;
19136 }
19137 break;
19138
19139 default:
19140 switch (ffeinfo_where (info))
19141 {
19142 case FFEINFO_whereCONSTANT:
19143 where = FFEINFO_whereCONSTANT_SUBOBJECT; /* An F90 concept. */
19144 break;
19145
19146 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
19147 default:
19148 where = FFEINFO_whereFLEETING;
19149 break;
19150 }
19151 break;
19152 }
19153
19154 if (ffebld_op (strop) == FFEBLD_opANY)
19155 {
19156 reduced = ffebld_new_any ();
19157 ffebld_set_info (reduced, ffeinfo_new_any ());
19158 }
19159 else
19160 {
19161 reduced = ffebld_new_substr (strop, substrlist);
19162 ffebld_set_info (reduced, ffeinfo_new
19163 (FFEINFO_basictypeCHARACTER,
19164 ffeinfo_kindtype (info),
19165 0,
19166 FFEINFO_kindENTITY,
19167 where,
19168 size));
19169 reduced = ffeexpr_collapse_substr (reduced, ffeexpr_stack_->tokens[0]);
19170 }
19171
19172 ffeexpr_stack_->exprstack = string->previous; /* Pops not-quite-operand off
19173 stack. */
19174 string->u.operand = reduced; /* Save the line/column ffewhere info. */
19175 ffeexpr_exprstack_push_operand_ (string); /* Push it back on stack. */
19176
19177 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
19178 {
19179 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19180 ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FOO(3:5)(1:1)".... */
19181 return (ffelexHandler) ffeexpr_token_substrp_;
19182 }
19183
19184 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
19185 {
19186 ffebad_here (0, ffelex_token_where_line (t),
19187 ffelex_token_where_column (t));
19188 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
19189 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
19190 ffebad_finish ();
19191 }
19192
19193 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19194 ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FOO(3:5)(1:1)".... */
19195 return
19196 (ffelexHandler) ffeexpr_find_close_paren_ (t,
19197 (ffelexHandler)
19198 ffeexpr_token_substrp_);
19199 }
19200
19201 /* ffeexpr_token_substrp_ -- Rhs <character entity>
19202
19203 Return a pointer to this function to the lexer (ffelex), which will
19204 invoke it for the next token.
19205
19206 If OPEN_PAREN, treat as start of a substring ("(3:4)") construct, and
19207 issue error message if flag (serves as argument) is set. Else, just
19208 forward token to binary_. */
19209
19210 static ffelexHandler
ffeexpr_token_substrp_(ffelexToken t)19211 ffeexpr_token_substrp_ (ffelexToken t)
19212 {
19213 ffeexprContext ctx;
19214
19215 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
19216 return (ffelexHandler) ffeexpr_token_binary_ (t);
19217
19218 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
19219
19220 switch (ffeexpr_stack_->context)
19221 {
19222 case FFEEXPR_contextSFUNCDEF:
19223 case FFEEXPR_contextSFUNCDEFINDEX_:
19224 ctx = FFEEXPR_contextSFUNCDEFINDEX_;
19225 break;
19226
19227 case FFEEXPR_contextSFUNCDEFACTUALARG_:
19228 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
19229 assert ("bad context" == NULL);
19230 ctx = FFEEXPR_context;
19231 break;
19232
19233 default:
19234 ctx = FFEEXPR_contextINDEX_;
19235 break;
19236 }
19237
19238 if (!ffeexpr_is_substr_ok_)
19239 {
19240 if (ffebad_start (FFEBAD_BAD_SUBSTR))
19241 {
19242 ffebad_here (0, ffelex_token_where_line (t),
19243 ffelex_token_where_column (t));
19244 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
19245 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
19246 ffebad_finish ();
19247 }
19248
19249 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
19250 ffeexpr_token_anything_);
19251 }
19252
19253 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
19254 ffeexpr_token_substring_);
19255 }
19256
19257 static ffelexHandler
ffeexpr_token_intrincheck_(ffelexToken t)19258 ffeexpr_token_intrincheck_ (ffelexToken t)
19259 {
19260 if ((ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
19261 && ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
19262 {
19263 ffebad_string (ffeintrin_name_implementation
19264 (ffebld_symter_implementation
19265 (ffebld_left
19266 (ffeexpr_stack_->exprstack->u.operand))));
19267 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
19268 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
19269 ffebad_finish ();
19270 }
19271
19272 return (ffelexHandler) ffeexpr_token_substrp_ (t);
19273 }
19274
19275 /* ffeexpr_token_funsubstr_ -- NAME OPEN_PAREN expr
19276
19277 Return a pointer to this function to the lexer (ffelex), which will
19278 invoke it for the next token.
19279
19280 If COLON, do everything we would have done since _parenthesized_ if
19281 we had known NAME represented a kindENTITY instead of a kindFUNCTION.
19282 If not COLON, do likewise for kindFUNCTION instead. */
19283
19284 static ffelexHandler
ffeexpr_token_funsubstr_(ffelexToken ft,ffebld expr,ffelexToken t)19285 ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr, ffelexToken t)
19286 {
19287 ffeinfoWhere where;
19288 ffesymbol s;
19289 ffesymbolAttrs sa;
19290 ffebld symter = ffeexpr_stack_->exprstack->u.operand;
19291 bool needs_type;
19292 ffeintrinGen gen;
19293 ffeintrinSpec spec;
19294 ffeintrinImp imp;
19295
19296 s = ffebld_symter (symter);
19297 sa = ffesymbol_attrs (s);
19298 where = ffesymbol_where (s);
19299
19300 /* We get here only if we don't already know enough about FOO when seeing a
19301 FOO(stuff) reference, and FOO might turn out to be a CHARACTER type. If
19302 "stuff" is a substring reference, then FOO is a CHARACTER scalar type.
19303 Else FOO is a function, either intrinsic or external. If intrinsic, it
19304 wouldn't necessarily be CHARACTER type, so unless it has already been
19305 declared DUMMY, it hasn't had its type established yet. It can't be
19306 CHAR*(*) in any case, though it can have an explicit CHAR*n type. */
19307
19308 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
19309 | FFESYMBOL_attrsTYPE)));
19310
19311 needs_type = !(ffesymbol_attrs (s) & FFESYMBOL_attrsDUMMY);
19312
19313 ffesymbol_signal_change (s); /* Probably already done, but in case.... */
19314
19315 if (ffelex_token_type (t) == FFELEX_typeCOLON)
19316 { /* Definitely an ENTITY (char substring). */
19317 if (needs_type && !ffeimplic_establish_symbol (s))
19318 {
19319 ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
19320 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19321 }
19322
19323 ffesymbol_set_info (s,
19324 ffeinfo_new (ffesymbol_basictype (s),
19325 ffesymbol_kindtype (s),
19326 ffesymbol_rank (s),
19327 FFEINFO_kindENTITY,
19328 (where == FFEINFO_whereNONE)
19329 ? FFEINFO_whereLOCAL
19330 : where,
19331 ffesymbol_size (s)));
19332 ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
19333
19334 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
19335 ffesymbol_resolve_intrin (s);
19336 s = ffecom_sym_learned (s);
19337 ffesymbol_signal_unreported (s); /* For debugging purposes. */
19338
19339 ffeexpr_stack_->exprstack->u.operand
19340 = ffeexpr_collapse_symter (symter, ffeexpr_tokens_[0]);
19341
19342 return (ffelexHandler) ffeexpr_token_substring_ (ft, expr, t);
19343 }
19344
19345 /* The "stuff" isn't a substring notation, so we now know the overall
19346 reference is to a function. */
19347
19348 if (ffeintrin_is_intrinsic (ffesymbol_text (s), ffeexpr_stack_->tokens[0],
19349 FALSE, &gen, &spec, &imp))
19350 {
19351 ffebld_symter_set_generic (symter, gen);
19352 ffebld_symter_set_specific (symter, spec);
19353 ffebld_symter_set_implementation (symter, imp);
19354 ffesymbol_set_generic (s, gen);
19355 ffesymbol_set_specific (s, spec);
19356 ffesymbol_set_implementation (s, imp);
19357 ffesymbol_set_info (s,
19358 ffeinfo_new (ffesymbol_basictype (s),
19359 ffesymbol_kindtype (s),
19360 0,
19361 FFEINFO_kindFUNCTION,
19362 FFEINFO_whereINTRINSIC,
19363 ffesymbol_size (s)));
19364 }
19365 else
19366 { /* Not intrinsic, now needs CHAR type. */
19367 if (!ffeimplic_establish_symbol (s))
19368 {
19369 ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
19370 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19371 }
19372
19373 ffesymbol_set_info (s,
19374 ffeinfo_new (ffesymbol_basictype (s),
19375 ffesymbol_kindtype (s),
19376 ffesymbol_rank (s),
19377 FFEINFO_kindFUNCTION,
19378 (where == FFEINFO_whereNONE)
19379 ? FFEINFO_whereGLOBAL
19380 : where,
19381 ffesymbol_size (s)));
19382 }
19383
19384 ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
19385
19386 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
19387 ffesymbol_resolve_intrin (s);
19388 s = ffecom_sym_learned (s);
19389 ffesymbol_reference (s, ffeexpr_stack_->tokens[0], FALSE);
19390 ffesymbol_signal_unreported (s); /* For debugging purposes. */
19391 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
19392 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19393 }
19394
19395 /* ffeexpr_token_anything_ -- NAME OPEN_PAREN any-expr
19396
19397 Handle basically any expression, looking for CLOSE_PAREN. */
19398
19399 static ffelexHandler
ffeexpr_token_anything_(ffelexToken ft UNUSED,ffebld expr UNUSED,ffelexToken t)19400 ffeexpr_token_anything_ (ffelexToken ft UNUSED, ffebld expr UNUSED,
19401 ffelexToken t)
19402 {
19403 ffeexprExpr_ e = ffeexpr_stack_->exprstack;
19404
19405 switch (ffelex_token_type (t))
19406 {
19407 case FFELEX_typeCOMMA:
19408 case FFELEX_typeCOLON:
19409 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
19410 FFEEXPR_contextACTUALARG_,
19411 ffeexpr_token_anything_);
19412
19413 default:
19414 e->u.operand = ffebld_new_any ();
19415 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
19416 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19417 ffeexpr_is_substr_ok_ = FALSE;
19418 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
19419 return (ffelexHandler) ffeexpr_token_substrp_;
19420 return (ffelexHandler) ffeexpr_token_substrp_ (t);
19421 }
19422 }
19423
19424 /* Terminate module. */
19425
19426 void
ffeexpr_terminate_2()19427 ffeexpr_terminate_2 ()
19428 {
19429 assert (ffeexpr_stack_ == NULL);
19430 assert (ffeexpr_level_ == 0);
19431 }
19432