?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2003-12-26 Guilhem Lavaux <guilhem@kaffe.org>
[official-gcc.git] / gcc / f / expr.c
blobf7ee46bb56bf3ec87e0f28473bb92cf32c880415
1 /* expr.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 1997, 1998, 2001, 2002, 2003
3 Free Software Foundation, Inc.
4 Contributed by James Craig Burley.
5
6 This file is part of GNU Fortran.
7
8 GNU Fortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
11 any later version.
12
13 GNU Fortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GNU Fortran; see the file COPYING. If not, write to
20 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
21 02111-1307, USA.
22
23 Related Modules:
24 None.
25
26 Description:
27 Handles syntactic and semantic analysis of Fortran expressions.
28
29 Modifications:
30 */
31
32 /* Include files. */
33
34 #include "proj.h"
35 #include "expr.h"
36 #include "bad.h"
37 #include "bld.h"
38 #include "com.h"
39 #include "global.h"
40 #include "implic.h"
41 #include "intrin.h"
42 #include "info.h"
43 #include "lex.h"
44 #include "malloc.h"
45 #include "src.h"
46 #include "st.h"
47 #include "symbol.h"
48 #include "str.h"
49 #include "target.h"
50 #include "where.h"
51 #include "real.h"
52
53 /* Externals defined here. */
54
55
56 /* Simple definitions and enumerations. */
57
58 typedef enum
59 {
60 FFEEXPR_exprtypeUNKNOWN_,
61 FFEEXPR_exprtypeOPERAND_,
62 FFEEXPR_exprtypeUNARY_,
63 FFEEXPR_exprtypeBINARY_,
64 FFEEXPR_exprtype_
65 } ffeexprExprtype_;
66
67 typedef enum
68 {
69 FFEEXPR_operatorPOWER_,
70 FFEEXPR_operatorMULTIPLY_,
71 FFEEXPR_operatorDIVIDE_,
72 FFEEXPR_operatorADD_,
73 FFEEXPR_operatorSUBTRACT_,
74 FFEEXPR_operatorCONCATENATE_,
75 FFEEXPR_operatorLT_,
76 FFEEXPR_operatorLE_,
77 FFEEXPR_operatorEQ_,
78 FFEEXPR_operatorNE_,
79 FFEEXPR_operatorGT_,
80 FFEEXPR_operatorGE_,
81 FFEEXPR_operatorNOT_,
82 FFEEXPR_operatorAND_,
83 FFEEXPR_operatorOR_,
84 FFEEXPR_operatorXOR_,
85 FFEEXPR_operatorEQV_,
86 FFEEXPR_operatorNEQV_,
87 FFEEXPR_operator_
88 } ffeexprOperator_;
89
90 typedef enum
91 {
92 FFEEXPR_operatorprecedenceHIGHEST_ = 1,
93 FFEEXPR_operatorprecedencePOWER_ = 1,
94 FFEEXPR_operatorprecedenceMULTIPLY_ = 2,
95 FFEEXPR_operatorprecedenceDIVIDE_ = 2,
96 FFEEXPR_operatorprecedenceADD_ = 3,
97 FFEEXPR_operatorprecedenceSUBTRACT_ = 3,
98 FFEEXPR_operatorprecedenceLOWARITH_ = 3,
99 FFEEXPR_operatorprecedenceCONCATENATE_ = 3,
100 FFEEXPR_operatorprecedenceLT_ = 4,
101 FFEEXPR_operatorprecedenceLE_ = 4,
102 FFEEXPR_operatorprecedenceEQ_ = 4,
103 FFEEXPR_operatorprecedenceNE_ = 4,
104 FFEEXPR_operatorprecedenceGT_ = 4,
105 FFEEXPR_operatorprecedenceGE_ = 4,
106 FFEEXPR_operatorprecedenceNOT_ = 5,
107 FFEEXPR_operatorprecedenceAND_ = 6,
108 FFEEXPR_operatorprecedenceOR_ = 7,
109 FFEEXPR_operatorprecedenceXOR_ = 8,
110 FFEEXPR_operatorprecedenceEQV_ = 8,
111 FFEEXPR_operatorprecedenceNEQV_ = 8,
112 FFEEXPR_operatorprecedenceLOWEST_ = 8,
113 FFEEXPR_operatorprecedence_
114 } ffeexprOperatorPrecedence_;
115
116 #define FFEEXPR_operatorassociativityL2R_ TRUE
117 #define FFEEXPR_operatorassociativityR2L_ FALSE
118 #define FFEEXPR_operatorassociativityPOWER_ FFEEXPR_operatorassociativityR2L_
119 #define FFEEXPR_operatorassociativityMULTIPLY_ FFEEXPR_operatorassociativityL2R_
120 #define FFEEXPR_operatorassociativityDIVIDE_ FFEEXPR_operatorassociativityL2R_
121 #define FFEEXPR_operatorassociativityADD_ FFEEXPR_operatorassociativityL2R_
122 #define FFEEXPR_operatorassociativitySUBTRACT_ FFEEXPR_operatorassociativityL2R_
123 #define FFEEXPR_operatorassociativityCONCATENATE_ FFEEXPR_operatorassociativityL2R_
124 #define FFEEXPR_operatorassociativityLT_ FFEEXPR_operatorassociativityL2R_
125 #define FFEEXPR_operatorassociativityLE_ FFEEXPR_operatorassociativityL2R_
126 #define FFEEXPR_operatorassociativityEQ_ FFEEXPR_operatorassociativityL2R_
127 #define FFEEXPR_operatorassociativityNE_ FFEEXPR_operatorassociativityL2R_
128 #define FFEEXPR_operatorassociativityGT_ FFEEXPR_operatorassociativityL2R_
129 #define FFEEXPR_operatorassociativityGE_ FFEEXPR_operatorassociativityL2R_
130 #define FFEEXPR_operatorassociativityNOT_ FFEEXPR_operatorassociativityL2R_
131 #define FFEEXPR_operatorassociativityAND_ FFEEXPR_operatorassociativityL2R_
132 #define FFEEXPR_operatorassociativityOR_ FFEEXPR_operatorassociativityL2R_
133 #define FFEEXPR_operatorassociativityXOR_ FFEEXPR_operatorassociativityL2R_
134 #define FFEEXPR_operatorassociativityEQV_ FFEEXPR_operatorassociativityL2R_
135 #define FFEEXPR_operatorassociativityNEQV_ FFEEXPR_operatorassociativityL2R_
136
137 typedef enum
138 {
139 FFEEXPR_parentypeFUNCTION_,
140 FFEEXPR_parentypeSUBROUTINE_,
141 FFEEXPR_parentypeARRAY_,
142 FFEEXPR_parentypeSUBSTRING_,
143 FFEEXPR_parentypeFUNSUBSTR_,/* Ambig: check for colon after first expr. */
144 FFEEXPR_parentypeEQUIVALENCE_, /* Ambig: ARRAY_ or SUBSTRING_. */
145 FFEEXPR_parentypeANY_, /* Allow basically anything. */
146 FFEEXPR_parentype_
147 } ffeexprParenType_;
148
149 typedef enum
150 {
151 FFEEXPR_percentNONE_,
152 FFEEXPR_percentLOC_,
153 FFEEXPR_percentVAL_,
154 FFEEXPR_percentREF_,
155 FFEEXPR_percentDESCR_,
156 FFEEXPR_percent_
157 } ffeexprPercent_;
158
159 /* Internal typedefs. */
160
161 typedef struct _ffeexpr_expr_ *ffeexprExpr_;
162 typedef bool ffeexprOperatorAssociativity_;
163 typedef struct _ffeexpr_stack_ *ffeexprStack_;
164
165 /* Private include files. */
166
167
168 /* Internal structure definitions. */
169
170 struct _ffeexpr_expr_
171 {
172 ffeexprExpr_ previous;
173 ffelexToken token;
174 ffeexprExprtype_ type;
175 union
176 {
177 struct
178 {
179 ffeexprOperator_ op;
180 ffeexprOperatorPrecedence_ prec;
181 ffeexprOperatorAssociativity_ as;
182 }
183 operator;
184 ffebld operand;
185 }
186 u;
187 };
188
189 struct _ffeexpr_stack_
190 {
191 ffeexprStack_ previous;
192 mallocPool pool;
193 ffeexprContext context;
194 ffeexprCallback callback;
195 ffelexToken first_token;
196 ffeexprExpr_ exprstack;
197 ffelexToken tokens[10]; /* Used in certain cases, like (unary)
198 open-paren. */
199 ffebld expr; /* For first of
200 complex/implied-do/substring/array-elements
201 / actual-args expression. */
202 ffebld bound_list; /* For tracking dimension bounds list of
203 array. */
204 ffebldListBottom bottom; /* For building lists. */
205 ffeinfoRank rank; /* For elements in an array reference. */
206 bool constant; /* TRUE while elements seen so far are
207 constants. */
208 bool immediate; /* TRUE while elements seen so far are
209 immediate/constants. */
210 ffebld next_dummy; /* Next SFUNC dummy arg in arg list. */
211 ffebldListLength num_args; /* Number of dummy args expected in arg list. */
212 bool is_rhs; /* TRUE if rhs context, FALSE otherwise. */
213 ffeexprPercent_ percent; /* Current %FOO keyword. */
214 };
215
216 struct _ffeexpr_find_
217 {
218 ffelexToken t;
219 ffelexHandler after;
220 int level;
221 };
222
223 /* Static objects accessed by functions in this module. */
224
225 static ffeexprStack_ ffeexpr_stack_; /* Expression stack for semantic. */
226 static ffelexToken ffeexpr_tokens_[10]; /* Scratchpad tokens for syntactic. */
227 static ffestrOther ffeexpr_current_dotdot_; /* Current .FOO. keyword. */
228 static long ffeexpr_hollerith_count_; /* ffeexpr_token_number_ and caller. */
229 static int ffeexpr_level_; /* Level of DATA implied-DO construct. */
230 static bool ffeexpr_is_substr_ok_; /* If OPEN_PAREN as binary "op" ok. */
231 static struct _ffeexpr_find_ ffeexpr_find_;
232
233 /* Static functions (internal). */
234
235 static ffelexHandler ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr,
236 ffelexToken t);
237 static ffelexHandler ffeexpr_cb_close_paren_ambig_ (ffelexToken ft,
238 ffebld expr,
239 ffelexToken t);
240 static ffelexHandler ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t);
241 static ffelexHandler ffeexpr_cb_close_paren_c_ (ffelexToken ft,
242 ffebld expr, ffelexToken t);
243 static ffelexHandler ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr,
244 ffelexToken t);
245 static ffelexHandler ffeexpr_cb_close_paren_ci_ (ffelexToken ft,
246 ffebld expr, ffelexToken t);
247 static ffelexHandler ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr,
248 ffelexToken t);
249 static ffelexHandler ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr,
250 ffelexToken t);
251 static ffelexHandler ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr,
252 ffelexToken t);
253 static ffelexHandler ffeexpr_cb_comma_i_2_ (ffelexToken ft, ffebld expr,
254 ffelexToken t);
255 static ffelexHandler ffeexpr_cb_comma_i_3_ (ffelexToken ft, ffebld expr,
256 ffelexToken t);
257 static ffelexHandler ffeexpr_cb_comma_i_4_ (ffelexToken ft, ffebld expr,
258 ffelexToken t);
259 static ffelexHandler ffeexpr_cb_comma_i_5_ (ffelexToken t);
260 static ffelexHandler ffeexpr_cb_end_loc_ (ffelexToken ft, ffebld expr,
261 ffelexToken t);
262 static ffelexHandler ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr,
263 ffelexToken t);
264 static ffelexHandler ffeexpr_cb_end_notloc_1_ (ffelexToken t);
265 static ffesymbol ffeexpr_check_impctrl_ (ffesymbol s);
266 static void ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
267 ffebld dovar, ffelexToken dovar_t);
268 static void ffeexpr_update_impdo_ (ffebld expr, ffebld dovar);
269 static void ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar);
270 static ffeexprContext ffeexpr_context_outer_ (ffeexprStack_ s);
271 static ffeexprExpr_ ffeexpr_expr_new_ (void);
272 static void ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t);
273 static bool ffeexpr_isdigits_ (const char *p);
274 static ffelexHandler ffeexpr_token_first_lhs_ (ffelexToken t);
275 static ffelexHandler ffeexpr_token_first_lhs_1_ (ffelexToken t);
276 static ffelexHandler ffeexpr_token_first_rhs_ (ffelexToken t);
277 static ffelexHandler ffeexpr_token_first_rhs_1_ (ffelexToken t);
278 static ffelexHandler ffeexpr_token_first_rhs_2_ (ffelexToken t);
279 static ffelexHandler ffeexpr_token_first_rhs_3_ (ffelexToken t);
280 static ffelexHandler ffeexpr_token_first_rhs_4_ (ffelexToken t);
281 static ffelexHandler ffeexpr_token_first_rhs_5_ (ffelexToken t);
282 static ffelexHandler ffeexpr_token_first_rhs_6_ (ffelexToken t);
283 static ffelexHandler ffeexpr_token_namelist_ (ffelexToken t);
284 static void ffeexpr_expr_kill_ (ffeexprExpr_ e);
285 static void ffeexpr_exprstack_push_ (ffeexprExpr_ e);
286 static void ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e);
287 static void ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e);
288 static void ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e);
289 static void ffeexpr_reduce_ (void);
290 static ffebld ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op,
291 ffeexprExpr_ r);
292 static ffebld ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l,
293 ffeexprExpr_ op, ffeexprExpr_ r);
294 static ffebld ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l,
295 ffeexprExpr_ op, ffeexprExpr_ r);
296 static ffebld ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l,
297 ffeexprExpr_ op, ffeexprExpr_ r);
298 static ffebld ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op,
299 ffeexprExpr_ r);
300 static ffebld ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l,
301 ffeexprExpr_ op, ffeexprExpr_ r);
302 static ffebld ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l,
303 ffeexprExpr_ op, ffeexprExpr_ r);
304 static ffebld ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l,
305 ffeexprExpr_ op, ffeexprExpr_ r);
306 static ffebld ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r);
307 static ffebld ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op,
308 ffeexprExpr_ r);
309 static ffebld ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l,
310 ffeexprExpr_ op, ffeexprExpr_ r);
311 static ffebld ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l,
312 ffeexprExpr_ op, ffeexprExpr_ r);
313 static ffelexHandler ffeexpr_find_close_paren_ (ffelexToken t,
314 ffelexHandler after);
315 static ffelexHandler ffeexpr_nil_finished_ (ffelexToken t);
316 static ffelexHandler ffeexpr_nil_rhs_ (ffelexToken t);
317 static ffelexHandler ffeexpr_nil_period_ (ffelexToken t);
318 static ffelexHandler ffeexpr_nil_end_period_ (ffelexToken t);
319 static ffelexHandler ffeexpr_nil_swallow_period_ (ffelexToken t);
320 static ffelexHandler ffeexpr_nil_real_ (ffelexToken t);
321 static ffelexHandler ffeexpr_nil_real_exponent_ (ffelexToken t);
322 static ffelexHandler ffeexpr_nil_real_exp_sign_ (ffelexToken t);
323 static ffelexHandler ffeexpr_nil_number_ (ffelexToken t);
324 static ffelexHandler ffeexpr_nil_number_exponent_ (ffelexToken t);
325 static ffelexHandler ffeexpr_nil_number_exp_sign_ (ffelexToken t);
326 static ffelexHandler ffeexpr_nil_number_period_ (ffelexToken t);
327 static ffelexHandler ffeexpr_nil_number_per_exp_ (ffelexToken t);
328 static ffelexHandler ffeexpr_nil_number_real_ (ffelexToken t);
329 static ffelexHandler ffeexpr_nil_num_per_exp_sign_ (ffelexToken t);
330 static ffelexHandler ffeexpr_nil_number_real_exp_ (ffelexToken t);
331 static ffelexHandler ffeexpr_nil_num_real_exp_sn_ (ffelexToken t);
332 static ffelexHandler ffeexpr_nil_binary_ (ffelexToken t);
333 static ffelexHandler ffeexpr_nil_binary_period_ (ffelexToken t);
334 static ffelexHandler ffeexpr_nil_binary_end_per_ (ffelexToken t);
335 static ffelexHandler ffeexpr_nil_binary_sw_per_ (ffelexToken t);
336 static ffelexHandler ffeexpr_nil_quote_ (ffelexToken t);
337 static ffelexHandler ffeexpr_nil_apostrophe_ (ffelexToken t);
338 static ffelexHandler ffeexpr_nil_apos_char_ (ffelexToken t);
339 static ffelexHandler ffeexpr_nil_name_rhs_ (ffelexToken t);
340 static ffelexHandler ffeexpr_nil_name_apos_ (ffelexToken t);
341 static ffelexHandler ffeexpr_nil_name_apos_name_ (ffelexToken t);
342 static ffelexHandler ffeexpr_nil_percent_ (ffelexToken t);
343 static ffelexHandler ffeexpr_nil_percent_name_ (ffelexToken t);
344 static ffelexHandler ffeexpr_nil_substrp_ (ffelexToken t);
345 static ffelexHandler ffeexpr_finished_ (ffelexToken t);
346 static ffebld ffeexpr_finished_ambig_ (ffelexToken t, ffebld expr);
347 static ffelexHandler ffeexpr_token_lhs_ (ffelexToken t);
348 static ffelexHandler ffeexpr_token_rhs_ (ffelexToken t);
349 static ffelexHandler ffeexpr_token_binary_ (ffelexToken t);
350 static ffelexHandler ffeexpr_token_period_ (ffelexToken t);
351 static ffelexHandler ffeexpr_token_end_period_ (ffelexToken t);
352 static ffelexHandler ffeexpr_token_swallow_period_ (ffelexToken t);
353 static ffelexHandler ffeexpr_token_real_ (ffelexToken t);
354 static ffelexHandler ffeexpr_token_real_exponent_ (ffelexToken t);
355 static ffelexHandler ffeexpr_token_real_exp_sign_ (ffelexToken t);
356 static ffelexHandler ffeexpr_token_number_ (ffelexToken t);
357 static ffelexHandler ffeexpr_token_number_exponent_ (ffelexToken t);
358 static ffelexHandler ffeexpr_token_number_exp_sign_ (ffelexToken t);
359 static ffelexHandler ffeexpr_token_number_period_ (ffelexToken t);
360 static ffelexHandler ffeexpr_token_number_per_exp_ (ffelexToken t);
361 static ffelexHandler ffeexpr_token_number_real_ (ffelexToken t);
362 static ffelexHandler ffeexpr_token_num_per_exp_sign_ (ffelexToken t);
363 static ffelexHandler ffeexpr_token_number_real_exp_ (ffelexToken t);
364 static ffelexHandler ffeexpr_token_num_real_exp_sn_ (ffelexToken t);
365 static ffelexHandler ffeexpr_token_binary_period_ (ffelexToken t);
366 static ffelexHandler ffeexpr_token_binary_end_per_ (ffelexToken t);
367 static ffelexHandler ffeexpr_token_binary_sw_per_ (ffelexToken t);
368 static ffelexHandler ffeexpr_token_quote_ (ffelexToken t);
369 static ffelexHandler ffeexpr_token_apostrophe_ (ffelexToken t);
370 static ffelexHandler ffeexpr_token_apos_char_ (ffelexToken t);
371 static ffelexHandler ffeexpr_token_name_lhs_ (ffelexToken t);
372 static ffelexHandler ffeexpr_token_name_arg_ (ffelexToken t);
373 static ffelexHandler ffeexpr_token_name_rhs_ (ffelexToken t);
374 static ffelexHandler ffeexpr_token_name_apos_ (ffelexToken t);
375 static ffelexHandler ffeexpr_token_name_apos_name_ (ffelexToken t);
376 static ffelexHandler ffeexpr_token_percent_ (ffelexToken t);
377 static ffelexHandler ffeexpr_token_percent_name_ (ffelexToken t);
378 static ffelexHandler ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr,
379 ffelexToken t);
380 static ffelexHandler ffeexpr_token_elements_ (ffelexToken ft, ffebld expr,
381 ffelexToken t);
382 static ffelexHandler ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr,
383 ffelexToken t);
384 static ffelexHandler ffeexpr_token_substring_ (ffelexToken ft, ffebld expr,
385 ffelexToken t);
386 static ffelexHandler ffeexpr_token_substring_1_ (ffelexToken ft, ffebld expr,
387 ffelexToken t);
388 static ffelexHandler ffeexpr_token_substrp_ (ffelexToken t);
389 static ffelexHandler ffeexpr_token_intrincheck_ (ffelexToken t);
390 static ffelexHandler ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr,
391 ffelexToken t);
392 static ffelexHandler ffeexpr_token_anything_ (ffelexToken ft, ffebld expr,
393 ffelexToken t);
394 static void ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
395 ffelexToken decimal, ffelexToken fraction, ffelexToken exponent,
396 ffelexToken exponent_sign, ffelexToken exponent_digits);
397 static ffesymbol ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin);
398 static ffesymbol ffeexpr_sym_impdoitem_ (ffesymbol s, ffelexToken t);
399 static ffesymbol ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t);
400 static ffesymbol ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t);
401 static ffesymbol ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t);
402 static ffesymbol ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t);
403 static ffesymbol ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t);
404 static ffesymbol ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t);
405 static ffesymbol ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t);
406 static ffesymbol ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t);
407 static ffesymbol ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t);
408 static ffesymbol ffeexpr_declare_parenthesized_ (ffelexToken t,
409 bool maybe_intrin,
410 ffeexprParenType_ *paren_type);
411 static ffesymbol ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t);
412
413 /* Internal macros. */
414
415 #define ffeexpr_paren_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
416 #define ffeexpr_sym_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
417 \f
418 /* ffeexpr_collapse_convert -- Collapse convert expr
419
420 ffebld expr;
421 ffelexToken token;
422 expr = ffeexpr_collapse_convert(expr,token);
423
424 If the result of the expr is a constant, replaces the expr with the
425 computed constant. */
426
427 ffebld
428 ffeexpr_collapse_convert (ffebld expr, ffelexToken t)
429 {
430 ffebad error = FFEBAD;
431 ffebld l;
432 ffebldConstantUnion u;
433 ffeinfoBasictype bt;
434 ffeinfoKindtype kt;
435 ffetargetCharacterSize sz;
436 ffetargetCharacterSize sz2;
437
438 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
439 return expr;
440
441 l = ffebld_left (expr);
442
443 if (ffebld_op (l) != FFEBLD_opCONTER)
444 return expr;
445
446 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
447 {
448 case FFEINFO_basictypeANY:
449 return expr;
450
451 case FFEINFO_basictypeINTEGER:
452 sz = FFETARGET_charactersizeNONE;
453 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
454 {
455 #if FFETARGET_okINTEGER1
456 case FFEINFO_kindtypeINTEGER1:
457 switch (ffeinfo_basictype (ffebld_info (l)))
458 {
459 case FFEINFO_basictypeINTEGER:
460 switch (ffeinfo_kindtype (ffebld_info (l)))
461 {
462 #if FFETARGET_okINTEGER2
463 case FFEINFO_kindtypeINTEGER2:
464 error = ffetarget_convert_integer1_integer2
465 (ffebld_cu_ptr_integer1 (u),
466 ffebld_constant_integer2 (ffebld_conter (l)));
467 break;
468 #endif
469
470 #if FFETARGET_okINTEGER3
471 case FFEINFO_kindtypeINTEGER3:
472 error = ffetarget_convert_integer1_integer3
473 (ffebld_cu_ptr_integer1 (u),
474 ffebld_constant_integer3 (ffebld_conter (l)));
475 break;
476 #endif
477
478 #if FFETARGET_okINTEGER4
479 case FFEINFO_kindtypeINTEGER4:
480 error = ffetarget_convert_integer1_integer4
481 (ffebld_cu_ptr_integer1 (u),
482 ffebld_constant_integer4 (ffebld_conter (l)));
483 break;
484 #endif
485
486 default:
487 assert ("INTEGER1/INTEGER bad source kind type" == NULL);
488 break;
489 }
490 break;
491
492 case FFEINFO_basictypeREAL:
493 switch (ffeinfo_kindtype (ffebld_info (l)))
494 {
495 #if FFETARGET_okREAL1
496 case FFEINFO_kindtypeREAL1:
497 error = ffetarget_convert_integer1_real1
498 (ffebld_cu_ptr_integer1 (u),
499 ffebld_constant_real1 (ffebld_conter (l)));
500 break;
501 #endif
502
503 #if FFETARGET_okREAL2
504 case FFEINFO_kindtypeREAL2:
505 error = ffetarget_convert_integer1_real2
506 (ffebld_cu_ptr_integer1 (u),
507 ffebld_constant_real2 (ffebld_conter (l)));
508 break;
509 #endif
510
511 #if FFETARGET_okREAL3
512 case FFEINFO_kindtypeREAL3:
513 error = ffetarget_convert_integer1_real3
514 (ffebld_cu_ptr_integer1 (u),
515 ffebld_constant_real3 (ffebld_conter (l)));
516 break;
517 #endif
518
519 default:
520 assert ("INTEGER1/REAL bad source kind type" == NULL);
521 break;
522 }
523 break;
524
525 case FFEINFO_basictypeCOMPLEX:
526 switch (ffeinfo_kindtype (ffebld_info (l)))
527 {
528 #if FFETARGET_okCOMPLEX1
529 case FFEINFO_kindtypeREAL1:
530 error = ffetarget_convert_integer1_complex1
531 (ffebld_cu_ptr_integer1 (u),
532 ffebld_constant_complex1 (ffebld_conter (l)));
533 break;
534 #endif
535
536 #if FFETARGET_okCOMPLEX2
537 case FFEINFO_kindtypeREAL2:
538 error = ffetarget_convert_integer1_complex2
539 (ffebld_cu_ptr_integer1 (u),
540 ffebld_constant_complex2 (ffebld_conter (l)));
541 break;
542 #endif
543
544 #if FFETARGET_okCOMPLEX3
545 case FFEINFO_kindtypeREAL3:
546 error = ffetarget_convert_integer1_complex3
547 (ffebld_cu_ptr_integer1 (u),
548 ffebld_constant_complex3 (ffebld_conter (l)));
549 break;
550 #endif
551
552 default:
553 assert ("INTEGER1/COMPLEX bad source kind type" == NULL);
554 break;
555 }
556 break;
557
558 case FFEINFO_basictypeLOGICAL:
559 switch (ffeinfo_kindtype (ffebld_info (l)))
560 {
561 #if FFETARGET_okLOGICAL1
562 case FFEINFO_kindtypeLOGICAL1:
563 error = ffetarget_convert_integer1_logical1
564 (ffebld_cu_ptr_integer1 (u),
565 ffebld_constant_logical1 (ffebld_conter (l)));
566 break;
567 #endif
568
569 #if FFETARGET_okLOGICAL2
570 case FFEINFO_kindtypeLOGICAL2:
571 error = ffetarget_convert_integer1_logical2
572 (ffebld_cu_ptr_integer1 (u),
573 ffebld_constant_logical2 (ffebld_conter (l)));
574 break;
575 #endif
576
577 #if FFETARGET_okLOGICAL3
578 case FFEINFO_kindtypeLOGICAL3:
579 error = ffetarget_convert_integer1_logical3
580 (ffebld_cu_ptr_integer1 (u),
581 ffebld_constant_logical3 (ffebld_conter (l)));
582 break;
583 #endif
584
585 #if FFETARGET_okLOGICAL4
586 case FFEINFO_kindtypeLOGICAL4:
587 error = ffetarget_convert_integer1_logical4
588 (ffebld_cu_ptr_integer1 (u),
589 ffebld_constant_logical4 (ffebld_conter (l)));
590 break;
591 #endif
592
593 default:
594 assert ("INTEGER1/LOGICAL bad source kind type" == NULL);
595 break;
596 }
597 break;
598
599 case FFEINFO_basictypeCHARACTER:
600 error = ffetarget_convert_integer1_character1
601 (ffebld_cu_ptr_integer1 (u),
602 ffebld_constant_character1 (ffebld_conter (l)));
603 break;
604
605 case FFEINFO_basictypeHOLLERITH:
606 error = ffetarget_convert_integer1_hollerith
607 (ffebld_cu_ptr_integer1 (u),
608 ffebld_constant_hollerith (ffebld_conter (l)));
609 break;
610
611 case FFEINFO_basictypeTYPELESS:
612 error = ffetarget_convert_integer1_typeless
613 (ffebld_cu_ptr_integer1 (u),
614 ffebld_constant_typeless (ffebld_conter (l)));
615 break;
616
617 default:
618 assert ("INTEGER1 bad type" == NULL);
619 break;
620 }
621
622 /* If conversion operation is not implemented, return original expr. */
623 if (error == FFEBAD_NOCANDO)
624 return expr;
625
626 expr = ffebld_new_conter_with_orig
627 (ffebld_constant_new_integer1_val
628 (ffebld_cu_val_integer1 (u)), expr);
629 break;
630 #endif
631
632 #if FFETARGET_okINTEGER2
633 case FFEINFO_kindtypeINTEGER2:
634 switch (ffeinfo_basictype (ffebld_info (l)))
635 {
636 case FFEINFO_basictypeINTEGER:
637 switch (ffeinfo_kindtype (ffebld_info (l)))
638 {
639 #if FFETARGET_okINTEGER1
640 case FFEINFO_kindtypeINTEGER1:
641 error = ffetarget_convert_integer2_integer1
642 (ffebld_cu_ptr_integer2 (u),
643 ffebld_constant_integer1 (ffebld_conter (l)));
644 break;
645 #endif
646
647 #if FFETARGET_okINTEGER3
648 case FFEINFO_kindtypeINTEGER3:
649 error = ffetarget_convert_integer2_integer3
650 (ffebld_cu_ptr_integer2 (u),
651 ffebld_constant_integer3 (ffebld_conter (l)));
652 break;
653 #endif
654
655 #if FFETARGET_okINTEGER4
656 case FFEINFO_kindtypeINTEGER4:
657 error = ffetarget_convert_integer2_integer4
658 (ffebld_cu_ptr_integer2 (u),
659 ffebld_constant_integer4 (ffebld_conter (l)));
660 break;
661 #endif
662
663 default:
664 assert ("INTEGER2/INTEGER bad source kind type" == NULL);
665 break;
666 }
667 break;
668
669 case FFEINFO_basictypeREAL:
670 switch (ffeinfo_kindtype (ffebld_info (l)))
671 {
672 #if FFETARGET_okREAL1
673 case FFEINFO_kindtypeREAL1:
674 error = ffetarget_convert_integer2_real1
675 (ffebld_cu_ptr_integer2 (u),
676 ffebld_constant_real1 (ffebld_conter (l)));
677 break;
678 #endif
679
680 #if FFETARGET_okREAL2
681 case FFEINFO_kindtypeREAL2:
682 error = ffetarget_convert_integer2_real2
683 (ffebld_cu_ptr_integer2 (u),
684 ffebld_constant_real2 (ffebld_conter (l)));
685 break;
686 #endif
687
688 #if FFETARGET_okREAL3
689 case FFEINFO_kindtypeREAL3:
690 error = ffetarget_convert_integer2_real3
691 (ffebld_cu_ptr_integer2 (u),
692 ffebld_constant_real3 (ffebld_conter (l)));
693 break;
694 #endif
695
696 default:
697 assert ("INTEGER2/REAL bad source kind type" == NULL);
698 break;
699 }
700 break;
701
702 case FFEINFO_basictypeCOMPLEX:
703 switch (ffeinfo_kindtype (ffebld_info (l)))
704 {
705 #if FFETARGET_okCOMPLEX1
706 case FFEINFO_kindtypeREAL1:
707 error = ffetarget_convert_integer2_complex1
708 (ffebld_cu_ptr_integer2 (u),
709 ffebld_constant_complex1 (ffebld_conter (l)));
710 break;
711 #endif
712
713 #if FFETARGET_okCOMPLEX2
714 case FFEINFO_kindtypeREAL2:
715 error = ffetarget_convert_integer2_complex2
716 (ffebld_cu_ptr_integer2 (u),
717 ffebld_constant_complex2 (ffebld_conter (l)));
718 break;
719 #endif
720
721 #if FFETARGET_okCOMPLEX3
722 case FFEINFO_kindtypeREAL3:
723 error = ffetarget_convert_integer2_complex3
724 (ffebld_cu_ptr_integer2 (u),
725 ffebld_constant_complex3 (ffebld_conter (l)));
726 break;
727 #endif
728
729 default:
730 assert ("INTEGER2/COMPLEX bad source kind type" == NULL);
731 break;
732 }
733 break;
734
735 case FFEINFO_basictypeLOGICAL:
736 switch (ffeinfo_kindtype (ffebld_info (l)))
737 {
738 #if FFETARGET_okLOGICAL1
739 case FFEINFO_kindtypeLOGICAL1:
740 error = ffetarget_convert_integer2_logical1
741 (ffebld_cu_ptr_integer2 (u),
742 ffebld_constant_logical1 (ffebld_conter (l)));
743 break;
744 #endif
745
746 #if FFETARGET_okLOGICAL2
747 case FFEINFO_kindtypeLOGICAL2:
748 error = ffetarget_convert_integer2_logical2
749 (ffebld_cu_ptr_integer2 (u),
750 ffebld_constant_logical2 (ffebld_conter (l)));
751 break;
752 #endif
753
754 #if FFETARGET_okLOGICAL3
755 case FFEINFO_kindtypeLOGICAL3:
756 error = ffetarget_convert_integer2_logical3
757 (ffebld_cu_ptr_integer2 (u),
758 ffebld_constant_logical3 (ffebld_conter (l)));
759 break;
760 #endif
761
762 #if FFETARGET_okLOGICAL4
763 case FFEINFO_kindtypeLOGICAL4:
764 error = ffetarget_convert_integer2_logical4
765 (ffebld_cu_ptr_integer2 (u),
766 ffebld_constant_logical4 (ffebld_conter (l)));
767 break;
768 #endif
769
770 default:
771 assert ("INTEGER2/LOGICAL bad source kind type" == NULL);
772 break;
773 }
774 break;
775
776 case FFEINFO_basictypeCHARACTER:
777 error = ffetarget_convert_integer2_character1
778 (ffebld_cu_ptr_integer2 (u),
779 ffebld_constant_character1 (ffebld_conter (l)));
780 break;
781
782 case FFEINFO_basictypeHOLLERITH:
783 error = ffetarget_convert_integer2_hollerith
784 (ffebld_cu_ptr_integer2 (u),
785 ffebld_constant_hollerith (ffebld_conter (l)));
786 break;
787
788 case FFEINFO_basictypeTYPELESS:
789 error = ffetarget_convert_integer2_typeless
790 (ffebld_cu_ptr_integer2 (u),
791 ffebld_constant_typeless (ffebld_conter (l)));
792 break;
793
794 default:
795 assert ("INTEGER2 bad type" == NULL);
796 break;
797 }
798
799 /* If conversion operation is not implemented, return original expr. */
800 if (error == FFEBAD_NOCANDO)
801 return expr;
802
803 expr = ffebld_new_conter_with_orig
804 (ffebld_constant_new_integer2_val
805 (ffebld_cu_val_integer2 (u)), expr);
806 break;
807 #endif
808
809 #if FFETARGET_okINTEGER3
810 case FFEINFO_kindtypeINTEGER3:
811 switch (ffeinfo_basictype (ffebld_info (l)))
812 {
813 case FFEINFO_basictypeINTEGER:
814 switch (ffeinfo_kindtype (ffebld_info (l)))
815 {
816 #if FFETARGET_okINTEGER1
817 case FFEINFO_kindtypeINTEGER1:
818 error = ffetarget_convert_integer3_integer1
819 (ffebld_cu_ptr_integer3 (u),
820 ffebld_constant_integer1 (ffebld_conter (l)));
821 break;
822 #endif
823
824 #if FFETARGET_okINTEGER2
825 case FFEINFO_kindtypeINTEGER2:
826 error = ffetarget_convert_integer3_integer2
827 (ffebld_cu_ptr_integer3 (u),
828 ffebld_constant_integer2 (ffebld_conter (l)));
829 break;
830 #endif
831
832 #if FFETARGET_okINTEGER4
833 case FFEINFO_kindtypeINTEGER4:
834 error = ffetarget_convert_integer3_integer4
835 (ffebld_cu_ptr_integer3 (u),
836 ffebld_constant_integer4 (ffebld_conter (l)));
837 break;
838 #endif
839
840 default:
841 assert ("INTEGER3/INTEGER bad source kind type" == NULL);
842 break;
843 }
844 break;
845
846 case FFEINFO_basictypeREAL:
847 switch (ffeinfo_kindtype (ffebld_info (l)))
848 {
849 #if FFETARGET_okREAL1
850 case FFEINFO_kindtypeREAL1:
851 error = ffetarget_convert_integer3_real1
852 (ffebld_cu_ptr_integer3 (u),
853 ffebld_constant_real1 (ffebld_conter (l)));
854 break;
855 #endif
856
857 #if FFETARGET_okREAL2
858 case FFEINFO_kindtypeREAL2:
859 error = ffetarget_convert_integer3_real2
860 (ffebld_cu_ptr_integer3 (u),
861 ffebld_constant_real2 (ffebld_conter (l)));
862 break;
863 #endif
864
865 #if FFETARGET_okREAL3
866 case FFEINFO_kindtypeREAL3:
867 error = ffetarget_convert_integer3_real3
868 (ffebld_cu_ptr_integer3 (u),
869 ffebld_constant_real3 (ffebld_conter (l)));
870 break;
871 #endif
872
873 default:
874 assert ("INTEGER3/REAL bad source kind type" == NULL);
875 break;
876 }
877 break;
878
879 case FFEINFO_basictypeCOMPLEX:
880 switch (ffeinfo_kindtype (ffebld_info (l)))
881 {
882 #if FFETARGET_okCOMPLEX1
883 case FFEINFO_kindtypeREAL1:
884 error = ffetarget_convert_integer3_complex1
885 (ffebld_cu_ptr_integer3 (u),
886 ffebld_constant_complex1 (ffebld_conter (l)));
887 break;
888 #endif
889
890 #if FFETARGET_okCOMPLEX2
891 case FFEINFO_kindtypeREAL2:
892 error = ffetarget_convert_integer3_complex2
893 (ffebld_cu_ptr_integer3 (u),
894 ffebld_constant_complex2 (ffebld_conter (l)));
895 break;
896 #endif
897
898 #if FFETARGET_okCOMPLEX3
899 case FFEINFO_kindtypeREAL3:
900 error = ffetarget_convert_integer3_complex3
901 (ffebld_cu_ptr_integer3 (u),
902 ffebld_constant_complex3 (ffebld_conter (l)));
903 break;
904 #endif
905
906 default:
907 assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
908 break;
909 }
910 break;
911
912 case FFEINFO_basictypeLOGICAL:
913 switch (ffeinfo_kindtype (ffebld_info (l)))
914 {
915 #if FFETARGET_okLOGICAL1
916 case FFEINFO_kindtypeLOGICAL1:
917 error = ffetarget_convert_integer3_logical1
918 (ffebld_cu_ptr_integer3 (u),
919 ffebld_constant_logical1 (ffebld_conter (l)));
920 break;
921 #endif
922
923 #if FFETARGET_okLOGICAL2
924 case FFEINFO_kindtypeLOGICAL2:
925 error = ffetarget_convert_integer3_logical2
926 (ffebld_cu_ptr_integer3 (u),
927 ffebld_constant_logical2 (ffebld_conter (l)));
928 break;
929 #endif
930
931 #if FFETARGET_okLOGICAL3
932 case FFEINFO_kindtypeLOGICAL3:
933 error = ffetarget_convert_integer3_logical3
934 (ffebld_cu_ptr_integer3 (u),
935 ffebld_constant_logical3 (ffebld_conter (l)));
936 break;
937 #endif
938
939 #if FFETARGET_okLOGICAL4
940 case FFEINFO_kindtypeLOGICAL4:
941 error = ffetarget_convert_integer3_logical4
942 (ffebld_cu_ptr_integer3 (u),
943 ffebld_constant_logical4 (ffebld_conter (l)));
944 break;
945 #endif
946
947 default:
948 assert ("INTEGER3/LOGICAL bad source kind type" == NULL);
949 break;
950 }
951 break;
952
953 case FFEINFO_basictypeCHARACTER:
954 error = ffetarget_convert_integer3_character1
955 (ffebld_cu_ptr_integer3 (u),
956 ffebld_constant_character1 (ffebld_conter (l)));
957 break;
958
959 case FFEINFO_basictypeHOLLERITH:
960 error = ffetarget_convert_integer3_hollerith
961 (ffebld_cu_ptr_integer3 (u),
962 ffebld_constant_hollerith (ffebld_conter (l)));
963 break;
964
965 case FFEINFO_basictypeTYPELESS:
966 error = ffetarget_convert_integer3_typeless
967 (ffebld_cu_ptr_integer3 (u),
968 ffebld_constant_typeless (ffebld_conter (l)));
969 break;
970
971 default:
972 assert ("INTEGER3 bad type" == NULL);
973 break;
974 }
975
976 /* If conversion operation is not implemented, return original expr. */
977 if (error == FFEBAD_NOCANDO)
978 return expr;
979
980 expr = ffebld_new_conter_with_orig
981 (ffebld_constant_new_integer3_val
982 (ffebld_cu_val_integer3 (u)), expr);
983 break;
984 #endif
985
986 #if FFETARGET_okINTEGER4
987 case FFEINFO_kindtypeINTEGER4:
988 switch (ffeinfo_basictype (ffebld_info (l)))
989 {
990 case FFEINFO_basictypeINTEGER:
991 switch (ffeinfo_kindtype (ffebld_info (l)))
992 {
993 #if FFETARGET_okINTEGER1
994 case FFEINFO_kindtypeINTEGER1:
995 error = ffetarget_convert_integer4_integer1
996 (ffebld_cu_ptr_integer4 (u),
997 ffebld_constant_integer1 (ffebld_conter (l)));
998 break;
999 #endif
1000
1001 #if FFETARGET_okINTEGER2
1002 case FFEINFO_kindtypeINTEGER2:
1003 error = ffetarget_convert_integer4_integer2
1004 (ffebld_cu_ptr_integer4 (u),
1005 ffebld_constant_integer2 (ffebld_conter (l)));
1006 break;
1007 #endif
1008
1009 #if FFETARGET_okINTEGER3
1010 case FFEINFO_kindtypeINTEGER3:
1011 error = ffetarget_convert_integer4_integer3
1012 (ffebld_cu_ptr_integer4 (u),
1013 ffebld_constant_integer3 (ffebld_conter (l)));
1014 break;
1015 #endif
1016
1017 default:
1018 assert ("INTEGER4/INTEGER bad source kind type" == NULL);
1019 break;
1020 }
1021 break;
1022
1023 case FFEINFO_basictypeREAL:
1024 switch (ffeinfo_kindtype (ffebld_info (l)))
1025 {
1026 #if FFETARGET_okREAL1
1027 case FFEINFO_kindtypeREAL1:
1028 error = ffetarget_convert_integer4_real1
1029 (ffebld_cu_ptr_integer4 (u),
1030 ffebld_constant_real1 (ffebld_conter (l)));
1031 break;
1032 #endif
1033
1034 #if FFETARGET_okREAL2
1035 case FFEINFO_kindtypeREAL2:
1036 error = ffetarget_convert_integer4_real2
1037 (ffebld_cu_ptr_integer4 (u),
1038 ffebld_constant_real2 (ffebld_conter (l)));
1039 break;
1040 #endif
1041
1042 #if FFETARGET_okREAL3
1043 case FFEINFO_kindtypeREAL3:
1044 error = ffetarget_convert_integer4_real3
1045 (ffebld_cu_ptr_integer4 (u),
1046 ffebld_constant_real3 (ffebld_conter (l)));
1047 break;
1048 #endif
1049
1050 default:
1051 assert ("INTEGER4/REAL bad source kind type" == NULL);
1052 break;
1053 }
1054 break;
1055
1056 case FFEINFO_basictypeCOMPLEX:
1057 switch (ffeinfo_kindtype (ffebld_info (l)))
1058 {
1059 #if FFETARGET_okCOMPLEX1
1060 case FFEINFO_kindtypeREAL1:
1061 error = ffetarget_convert_integer4_complex1
1062 (ffebld_cu_ptr_integer4 (u),
1063 ffebld_constant_complex1 (ffebld_conter (l)));
1064 break;
1065 #endif
1066
1067 #if FFETARGET_okCOMPLEX2
1068 case FFEINFO_kindtypeREAL2:
1069 error = ffetarget_convert_integer4_complex2
1070 (ffebld_cu_ptr_integer4 (u),
1071 ffebld_constant_complex2 (ffebld_conter (l)));
1072 break;
1073 #endif
1074
1075 #if FFETARGET_okCOMPLEX3
1076 case FFEINFO_kindtypeREAL3:
1077 error = ffetarget_convert_integer4_complex3
1078 (ffebld_cu_ptr_integer4 (u),
1079 ffebld_constant_complex3 (ffebld_conter (l)));
1080 break;
1081 #endif
1082
1083 default:
1084 assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
1085 break;
1086 }
1087 break;
1088
1089 case FFEINFO_basictypeLOGICAL:
1090 switch (ffeinfo_kindtype (ffebld_info (l)))
1091 {
1092 #if FFETARGET_okLOGICAL1
1093 case FFEINFO_kindtypeLOGICAL1:
1094 error = ffetarget_convert_integer4_logical1
1095 (ffebld_cu_ptr_integer4 (u),
1096 ffebld_constant_logical1 (ffebld_conter (l)));
1097 break;
1098 #endif
1099
1100 #if FFETARGET_okLOGICAL2
1101 case FFEINFO_kindtypeLOGICAL2:
1102 error = ffetarget_convert_integer4_logical2
1103 (ffebld_cu_ptr_integer4 (u),
1104 ffebld_constant_logical2 (ffebld_conter (l)));
1105 break;
1106 #endif
1107
1108 #if FFETARGET_okLOGICAL3
1109 case FFEINFO_kindtypeLOGICAL3:
1110 error = ffetarget_convert_integer4_logical3
1111 (ffebld_cu_ptr_integer4 (u),
1112 ffebld_constant_logical3 (ffebld_conter (l)));
1113 break;
1114 #endif
1115
1116 #if FFETARGET_okLOGICAL4
1117 case FFEINFO_kindtypeLOGICAL4:
1118 error = ffetarget_convert_integer4_logical4
1119 (ffebld_cu_ptr_integer4 (u),
1120 ffebld_constant_logical4 (ffebld_conter (l)));
1121 break;
1122 #endif
1123
1124 default:
1125 assert ("INTEGER4/LOGICAL bad source kind type" == NULL);
1126 break;
1127 }
1128 break;
1129
1130 case FFEINFO_basictypeCHARACTER:
1131 error = ffetarget_convert_integer4_character1
1132 (ffebld_cu_ptr_integer4 (u),
1133 ffebld_constant_character1 (ffebld_conter (l)));
1134 break;
1135
1136 case FFEINFO_basictypeHOLLERITH:
1137 error = ffetarget_convert_integer4_hollerith
1138 (ffebld_cu_ptr_integer4 (u),
1139 ffebld_constant_hollerith (ffebld_conter (l)));
1140 break;
1141
1142 case FFEINFO_basictypeTYPELESS:
1143 error = ffetarget_convert_integer4_typeless
1144 (ffebld_cu_ptr_integer4 (u),
1145 ffebld_constant_typeless (ffebld_conter (l)));
1146 break;
1147
1148 default:
1149 assert ("INTEGER4 bad type" == NULL);
1150 break;
1151 }
1152
1153 /* If conversion operation is not implemented, return original expr. */
1154 if (error == FFEBAD_NOCANDO)
1155 return expr;
1156
1157 expr = ffebld_new_conter_with_orig
1158 (ffebld_constant_new_integer4_val
1159 (ffebld_cu_val_integer4 (u)), expr);
1160 break;
1161 #endif
1162
1163 default:
1164 assert ("bad integer kind type" == NULL);
1165 break;
1166 }
1167 break;
1168
1169 case FFEINFO_basictypeLOGICAL:
1170 sz = FFETARGET_charactersizeNONE;
1171 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1172 {
1173 #if FFETARGET_okLOGICAL1
1174 case FFEINFO_kindtypeLOGICAL1:
1175 switch (ffeinfo_basictype (ffebld_info (l)))
1176 {
1177 case FFEINFO_basictypeLOGICAL:
1178 switch (ffeinfo_kindtype (ffebld_info (l)))
1179 {
1180 #if FFETARGET_okLOGICAL2
1181 case FFEINFO_kindtypeLOGICAL2:
1182 error = ffetarget_convert_logical1_logical2
1183 (ffebld_cu_ptr_logical1 (u),
1184 ffebld_constant_logical2 (ffebld_conter (l)));
1185 break;
1186 #endif
1187
1188 #if FFETARGET_okLOGICAL3
1189 case FFEINFO_kindtypeLOGICAL3:
1190 error = ffetarget_convert_logical1_logical3
1191 (ffebld_cu_ptr_logical1 (u),
1192 ffebld_constant_logical3 (ffebld_conter (l)));
1193 break;
1194 #endif
1195
1196 #if FFETARGET_okLOGICAL4
1197 case FFEINFO_kindtypeLOGICAL4:
1198 error = ffetarget_convert_logical1_logical4
1199 (ffebld_cu_ptr_logical1 (u),
1200 ffebld_constant_logical4 (ffebld_conter (l)));
1201 break;
1202 #endif
1203
1204 default:
1205 assert ("LOGICAL1/LOGICAL bad source kind type" == NULL);
1206 break;
1207 }
1208 break;
1209
1210 case FFEINFO_basictypeINTEGER:
1211 switch (ffeinfo_kindtype (ffebld_info (l)))
1212 {
1213 #if FFETARGET_okINTEGER1
1214 case FFEINFO_kindtypeINTEGER1:
1215 error = ffetarget_convert_logical1_integer1
1216 (ffebld_cu_ptr_logical1 (u),
1217 ffebld_constant_integer1 (ffebld_conter (l)));
1218 break;
1219 #endif
1220
1221 #if FFETARGET_okINTEGER2
1222 case FFEINFO_kindtypeINTEGER2:
1223 error = ffetarget_convert_logical1_integer2
1224 (ffebld_cu_ptr_logical1 (u),
1225 ffebld_constant_integer2 (ffebld_conter (l)));
1226 break;
1227 #endif
1228
1229 #if FFETARGET_okINTEGER3
1230 case FFEINFO_kindtypeINTEGER3:
1231 error = ffetarget_convert_logical1_integer3
1232 (ffebld_cu_ptr_logical1 (u),
1233 ffebld_constant_integer3 (ffebld_conter (l)));
1234 break;
1235 #endif
1236
1237 #if FFETARGET_okINTEGER4
1238 case FFEINFO_kindtypeINTEGER4:
1239 error = ffetarget_convert_logical1_integer4
1240 (ffebld_cu_ptr_logical1 (u),
1241 ffebld_constant_integer4 (ffebld_conter (l)));
1242 break;
1243 #endif
1244
1245 default:
1246 assert ("LOGICAL1/INTEGER bad source kind type" == NULL);
1247 break;
1248 }
1249 break;
1250
1251 case FFEINFO_basictypeCHARACTER:
1252 error = ffetarget_convert_logical1_character1
1253 (ffebld_cu_ptr_logical1 (u),
1254 ffebld_constant_character1 (ffebld_conter (l)));
1255 break;
1256
1257 case FFEINFO_basictypeHOLLERITH:
1258 error = ffetarget_convert_logical1_hollerith
1259 (ffebld_cu_ptr_logical1 (u),
1260 ffebld_constant_hollerith (ffebld_conter (l)));
1261 break;
1262
1263 case FFEINFO_basictypeTYPELESS:
1264 error = ffetarget_convert_logical1_typeless
1265 (ffebld_cu_ptr_logical1 (u),
1266 ffebld_constant_typeless (ffebld_conter (l)));
1267 break;
1268
1269 default:
1270 assert ("LOGICAL1 bad type" == NULL);
1271 break;
1272 }
1273
1274 /* If conversion operation is not implemented, return original expr. */
1275 if (error == FFEBAD_NOCANDO)
1276 return expr;
1277
1278 expr = ffebld_new_conter_with_orig
1279 (ffebld_constant_new_logical1_val
1280 (ffebld_cu_val_logical1 (u)), expr);
1281 break;
1282 #endif
1283
1284 #if FFETARGET_okLOGICAL2
1285 case FFEINFO_kindtypeLOGICAL2:
1286 switch (ffeinfo_basictype (ffebld_info (l)))
1287 {
1288 case FFEINFO_basictypeLOGICAL:
1289 switch (ffeinfo_kindtype (ffebld_info (l)))
1290 {
1291 #if FFETARGET_okLOGICAL1
1292 case FFEINFO_kindtypeLOGICAL1:
1293 error = ffetarget_convert_logical2_logical1
1294 (ffebld_cu_ptr_logical2 (u),
1295 ffebld_constant_logical1 (ffebld_conter (l)));
1296 break;
1297 #endif
1298
1299 #if FFETARGET_okLOGICAL3
1300 case FFEINFO_kindtypeLOGICAL3:
1301 error = ffetarget_convert_logical2_logical3
1302 (ffebld_cu_ptr_logical2 (u),
1303 ffebld_constant_logical3 (ffebld_conter (l)));
1304 break;
1305 #endif
1306
1307 #if FFETARGET_okLOGICAL4
1308 case FFEINFO_kindtypeLOGICAL4:
1309 error = ffetarget_convert_logical2_logical4
1310 (ffebld_cu_ptr_logical2 (u),
1311 ffebld_constant_logical4 (ffebld_conter (l)));
1312 break;
1313 #endif
1314
1315 default:
1316 assert ("LOGICAL2/LOGICAL bad source kind type" == NULL);
1317 break;
1318 }
1319 break;
1320
1321 case FFEINFO_basictypeINTEGER:
1322 switch (ffeinfo_kindtype (ffebld_info (l)))
1323 {
1324 #if FFETARGET_okINTEGER1
1325 case FFEINFO_kindtypeINTEGER1:
1326 error = ffetarget_convert_logical2_integer1
1327 (ffebld_cu_ptr_logical2 (u),
1328 ffebld_constant_integer1 (ffebld_conter (l)));
1329 break;
1330 #endif
1331
1332 #if FFETARGET_okINTEGER2
1333 case FFEINFO_kindtypeINTEGER2:
1334 error = ffetarget_convert_logical2_integer2
1335 (ffebld_cu_ptr_logical2 (u),
1336 ffebld_constant_integer2 (ffebld_conter (l)));
1337 break;
1338 #endif
1339
1340 #if FFETARGET_okINTEGER3
1341 case FFEINFO_kindtypeINTEGER3:
1342 error = ffetarget_convert_logical2_integer3
1343 (ffebld_cu_ptr_logical2 (u),
1344 ffebld_constant_integer3 (ffebld_conter (l)));
1345 break;
1346 #endif
1347
1348 #if FFETARGET_okINTEGER4
1349 case FFEINFO_kindtypeINTEGER4:
1350 error = ffetarget_convert_logical2_integer4
1351 (ffebld_cu_ptr_logical2 (u),
1352 ffebld_constant_integer4 (ffebld_conter (l)));
1353 break;
1354 #endif
1355
1356 default:
1357 assert ("LOGICAL2/INTEGER bad source kind type" == NULL);
1358 break;
1359 }
1360 break;
1361
1362 case FFEINFO_basictypeCHARACTER:
1363 error = ffetarget_convert_logical2_character1
1364 (ffebld_cu_ptr_logical2 (u),
1365 ffebld_constant_character1 (ffebld_conter (l)));
1366 break;
1367
1368 case FFEINFO_basictypeHOLLERITH:
1369 error = ffetarget_convert_logical2_hollerith
1370 (ffebld_cu_ptr_logical2 (u),
1371 ffebld_constant_hollerith (ffebld_conter (l)));
1372 break;
1373
1374 case FFEINFO_basictypeTYPELESS:
1375 error = ffetarget_convert_logical2_typeless
1376 (ffebld_cu_ptr_logical2 (u),
1377 ffebld_constant_typeless (ffebld_conter (l)));
1378 break;
1379
1380 default:
1381 assert ("LOGICAL2 bad type" == NULL);
1382 break;
1383 }
1384
1385 /* If conversion operation is not implemented, return original expr. */
1386 if (error == FFEBAD_NOCANDO)
1387 return expr;
1388
1389 expr = ffebld_new_conter_with_orig
1390 (ffebld_constant_new_logical2_val
1391 (ffebld_cu_val_logical2 (u)), expr);
1392 break;
1393 #endif
1394
1395 #if FFETARGET_okLOGICAL3
1396 case FFEINFO_kindtypeLOGICAL3:
1397 switch (ffeinfo_basictype (ffebld_info (l)))
1398 {
1399 case FFEINFO_basictypeLOGICAL:
1400 switch (ffeinfo_kindtype (ffebld_info (l)))
1401 {
1402 #if FFETARGET_okLOGICAL1
1403 case FFEINFO_kindtypeLOGICAL1:
1404 error = ffetarget_convert_logical3_logical1
1405 (ffebld_cu_ptr_logical3 (u),
1406 ffebld_constant_logical1 (ffebld_conter (l)));
1407 break;
1408 #endif
1409
1410 #if FFETARGET_okLOGICAL2
1411 case FFEINFO_kindtypeLOGICAL2:
1412 error = ffetarget_convert_logical3_logical2
1413 (ffebld_cu_ptr_logical3 (u),
1414 ffebld_constant_logical2 (ffebld_conter (l)));
1415 break;
1416 #endif
1417
1418 #if FFETARGET_okLOGICAL4
1419 case FFEINFO_kindtypeLOGICAL4:
1420 error = ffetarget_convert_logical3_logical4
1421 (ffebld_cu_ptr_logical3 (u),
1422 ffebld_constant_logical4 (ffebld_conter (l)));
1423 break;
1424 #endif
1425
1426 default:
1427 assert ("LOGICAL3/LOGICAL bad source kind type" == NULL);
1428 break;
1429 }
1430 break;
1431
1432 case FFEINFO_basictypeINTEGER:
1433 switch (ffeinfo_kindtype (ffebld_info (l)))
1434 {
1435 #if FFETARGET_okINTEGER1
1436 case FFEINFO_kindtypeINTEGER1:
1437 error = ffetarget_convert_logical3_integer1
1438 (ffebld_cu_ptr_logical3 (u),
1439 ffebld_constant_integer1 (ffebld_conter (l)));
1440 break;
1441 #endif
1442
1443 #if FFETARGET_okINTEGER2
1444 case FFEINFO_kindtypeINTEGER2:
1445 error = ffetarget_convert_logical3_integer2
1446 (ffebld_cu_ptr_logical3 (u),
1447 ffebld_constant_integer2 (ffebld_conter (l)));
1448 break;
1449 #endif
1450
1451 #if FFETARGET_okINTEGER3
1452 case FFEINFO_kindtypeINTEGER3:
1453 error = ffetarget_convert_logical3_integer3
1454 (ffebld_cu_ptr_logical3 (u),
1455 ffebld_constant_integer3 (ffebld_conter (l)));
1456 break;
1457 #endif
1458
1459 #if FFETARGET_okINTEGER4
1460 case FFEINFO_kindtypeINTEGER4:
1461 error = ffetarget_convert_logical3_integer4
1462 (ffebld_cu_ptr_logical3 (u),
1463 ffebld_constant_integer4 (ffebld_conter (l)));
1464 break;
1465 #endif
1466
1467 default:
1468 assert ("LOGICAL3/INTEGER bad source kind type" == NULL);
1469 break;
1470 }
1471 break;
1472
1473 case FFEINFO_basictypeCHARACTER:
1474 error = ffetarget_convert_logical3_character1
1475 (ffebld_cu_ptr_logical3 (u),
1476 ffebld_constant_character1 (ffebld_conter (l)));
1477 break;
1478
1479 case FFEINFO_basictypeHOLLERITH:
1480 error = ffetarget_convert_logical3_hollerith
1481 (ffebld_cu_ptr_logical3 (u),
1482 ffebld_constant_hollerith (ffebld_conter (l)));
1483 break;
1484
1485 case FFEINFO_basictypeTYPELESS:
1486 error = ffetarget_convert_logical3_typeless
1487 (ffebld_cu_ptr_logical3 (u),
1488 ffebld_constant_typeless (ffebld_conter (l)));
1489 break;
1490
1491 default:
1492 assert ("LOGICAL3 bad type" == NULL);
1493 break;
1494 }
1495
1496 /* If conversion operation is not implemented, return original expr. */
1497 if (error == FFEBAD_NOCANDO)
1498 return expr;
1499
1500 expr = ffebld_new_conter_with_orig
1501 (ffebld_constant_new_logical3_val
1502 (ffebld_cu_val_logical3 (u)), expr);
1503 break;
1504 #endif
1505
1506 #if FFETARGET_okLOGICAL4
1507 case FFEINFO_kindtypeLOGICAL4:
1508 switch (ffeinfo_basictype (ffebld_info (l)))
1509 {
1510 case FFEINFO_basictypeLOGICAL:
1511 switch (ffeinfo_kindtype (ffebld_info (l)))
1512 {
1513 #if FFETARGET_okLOGICAL1
1514 case FFEINFO_kindtypeLOGICAL1:
1515 error = ffetarget_convert_logical4_logical1
1516 (ffebld_cu_ptr_logical4 (u),
1517 ffebld_constant_logical1 (ffebld_conter (l)));
1518 break;
1519 #endif
1520
1521 #if FFETARGET_okLOGICAL2
1522 case FFEINFO_kindtypeLOGICAL2:
1523 error = ffetarget_convert_logical4_logical2
1524 (ffebld_cu_ptr_logical4 (u),
1525 ffebld_constant_logical2 (ffebld_conter (l)));
1526 break;
1527 #endif
1528
1529 #if FFETARGET_okLOGICAL3
1530 case FFEINFO_kindtypeLOGICAL3:
1531 error = ffetarget_convert_logical4_logical3
1532 (ffebld_cu_ptr_logical4 (u),
1533 ffebld_constant_logical3 (ffebld_conter (l)));
1534 break;
1535 #endif
1536
1537 default:
1538 assert ("LOGICAL4/LOGICAL bad source kind type" == NULL);
1539 break;
1540 }
1541 break;
1542
1543 case FFEINFO_basictypeINTEGER:
1544 switch (ffeinfo_kindtype (ffebld_info (l)))
1545 {
1546 #if FFETARGET_okINTEGER1
1547 case FFEINFO_kindtypeINTEGER1:
1548 error = ffetarget_convert_logical4_integer1
1549 (ffebld_cu_ptr_logical4 (u),
1550 ffebld_constant_integer1 (ffebld_conter (l)));
1551 break;
1552 #endif
1553
1554 #if FFETARGET_okINTEGER2
1555 case FFEINFO_kindtypeINTEGER2:
1556 error = ffetarget_convert_logical4_integer2
1557 (ffebld_cu_ptr_logical4 (u),
1558 ffebld_constant_integer2 (ffebld_conter (l)));
1559 break;
1560 #endif
1561
1562 #if FFETARGET_okINTEGER3
1563 case FFEINFO_kindtypeINTEGER3:
1564 error = ffetarget_convert_logical4_integer3
1565 (ffebld_cu_ptr_logical4 (u),
1566 ffebld_constant_integer3 (ffebld_conter (l)));
1567 break;
1568 #endif
1569
1570 #if FFETARGET_okINTEGER4
1571 case FFEINFO_kindtypeINTEGER4:
1572 error = ffetarget_convert_logical4_integer4
1573 (ffebld_cu_ptr_logical4 (u),
1574 ffebld_constant_integer4 (ffebld_conter (l)));
1575 break;
1576 #endif
1577
1578 default:
1579 assert ("LOGICAL4/INTEGER bad source kind type" == NULL);
1580 break;
1581 }
1582 break;
1583
1584 case FFEINFO_basictypeCHARACTER:
1585 error = ffetarget_convert_logical4_character1
1586 (ffebld_cu_ptr_logical4 (u),
1587 ffebld_constant_character1 (ffebld_conter (l)));
1588 break;
1589
1590 case FFEINFO_basictypeHOLLERITH:
1591 error = ffetarget_convert_logical4_hollerith
1592 (ffebld_cu_ptr_logical4 (u),
1593 ffebld_constant_hollerith (ffebld_conter (l)));
1594 break;
1595
1596 case FFEINFO_basictypeTYPELESS:
1597 error = ffetarget_convert_logical4_typeless
1598 (ffebld_cu_ptr_logical4 (u),
1599 ffebld_constant_typeless (ffebld_conter (l)));
1600 break;
1601
1602 default:
1603 assert ("LOGICAL4 bad type" == NULL);
1604 break;
1605 }
1606
1607 /* If conversion operation is not implemented, return original expr. */
1608 if (error == FFEBAD_NOCANDO)
1609 return expr;
1610
1611 expr = ffebld_new_conter_with_orig
1612 (ffebld_constant_new_logical4_val
1613 (ffebld_cu_val_logical4 (u)), expr);
1614 break;
1615 #endif
1616
1617 default:
1618 assert ("bad logical kind type" == NULL);
1619 break;
1620 }
1621 break;
1622
1623 case FFEINFO_basictypeREAL:
1624 sz = FFETARGET_charactersizeNONE;
1625 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1626 {
1627 #if FFETARGET_okREAL1
1628 case FFEINFO_kindtypeREAL1:
1629 switch (ffeinfo_basictype (ffebld_info (l)))
1630 {
1631 case FFEINFO_basictypeINTEGER:
1632 switch (ffeinfo_kindtype (ffebld_info (l)))
1633 {
1634 #if FFETARGET_okINTEGER1
1635 case FFEINFO_kindtypeINTEGER1:
1636 error = ffetarget_convert_real1_integer1
1637 (ffebld_cu_ptr_real1 (u),
1638 ffebld_constant_integer1 (ffebld_conter (l)));
1639 break;
1640 #endif
1641
1642 #if FFETARGET_okINTEGER2
1643 case FFEINFO_kindtypeINTEGER2:
1644 error = ffetarget_convert_real1_integer2
1645 (ffebld_cu_ptr_real1 (u),
1646 ffebld_constant_integer2 (ffebld_conter (l)));
1647 break;
1648 #endif
1649
1650 #if FFETARGET_okINTEGER3
1651 case FFEINFO_kindtypeINTEGER3:
1652 error = ffetarget_convert_real1_integer3
1653 (ffebld_cu_ptr_real1 (u),
1654 ffebld_constant_integer3 (ffebld_conter (l)));
1655 break;
1656 #endif
1657
1658 #if FFETARGET_okINTEGER4
1659 case FFEINFO_kindtypeINTEGER4:
1660 error = ffetarget_convert_real1_integer4
1661 (ffebld_cu_ptr_real1 (u),
1662 ffebld_constant_integer4 (ffebld_conter (l)));
1663 break;
1664 #endif
1665
1666 default:
1667 assert ("REAL1/INTEGER bad source kind type" == NULL);
1668 break;
1669 }
1670 break;
1671
1672 case FFEINFO_basictypeREAL:
1673 switch (ffeinfo_kindtype (ffebld_info (l)))
1674 {
1675 #if FFETARGET_okREAL2
1676 case FFEINFO_kindtypeREAL2:
1677 error = ffetarget_convert_real1_real2
1678 (ffebld_cu_ptr_real1 (u),
1679 ffebld_constant_real2 (ffebld_conter (l)));
1680 break;
1681 #endif
1682
1683 #if FFETARGET_okREAL3
1684 case FFEINFO_kindtypeREAL3:
1685 error = ffetarget_convert_real1_real3
1686 (ffebld_cu_ptr_real1 (u),
1687 ffebld_constant_real3 (ffebld_conter (l)));
1688 break;
1689 #endif
1690
1691 default:
1692 assert ("REAL1/REAL bad source kind type" == NULL);
1693 break;
1694 }
1695 break;
1696
1697 case FFEINFO_basictypeCOMPLEX:
1698 switch (ffeinfo_kindtype (ffebld_info (l)))
1699 {
1700 #if FFETARGET_okCOMPLEX1
1701 case FFEINFO_kindtypeREAL1:
1702 error = ffetarget_convert_real1_complex1
1703 (ffebld_cu_ptr_real1 (u),
1704 ffebld_constant_complex1 (ffebld_conter (l)));
1705 break;
1706 #endif
1707
1708 #if FFETARGET_okCOMPLEX2
1709 case FFEINFO_kindtypeREAL2:
1710 error = ffetarget_convert_real1_complex2
1711 (ffebld_cu_ptr_real1 (u),
1712 ffebld_constant_complex2 (ffebld_conter (l)));
1713 break;
1714 #endif
1715
1716 #if FFETARGET_okCOMPLEX3
1717 case FFEINFO_kindtypeREAL3:
1718 error = ffetarget_convert_real1_complex3
1719 (ffebld_cu_ptr_real1 (u),
1720 ffebld_constant_complex3 (ffebld_conter (l)));
1721 break;
1722 #endif
1723
1724 default:
1725 assert ("REAL1/COMPLEX bad source kind type" == NULL);
1726 break;
1727 }
1728 break;
1729
1730 case FFEINFO_basictypeCHARACTER:
1731 error = ffetarget_convert_real1_character1
1732 (ffebld_cu_ptr_real1 (u),
1733 ffebld_constant_character1 (ffebld_conter (l)));
1734 break;
1735
1736 case FFEINFO_basictypeHOLLERITH:
1737 error = ffetarget_convert_real1_hollerith
1738 (ffebld_cu_ptr_real1 (u),
1739 ffebld_constant_hollerith (ffebld_conter (l)));
1740 break;
1741
1742 case FFEINFO_basictypeTYPELESS:
1743 error = ffetarget_convert_real1_typeless
1744 (ffebld_cu_ptr_real1 (u),
1745 ffebld_constant_typeless (ffebld_conter (l)));
1746 break;
1747
1748 default:
1749 assert ("REAL1 bad type" == NULL);
1750 break;
1751 }
1752
1753 /* If conversion operation is not implemented, return original expr. */
1754 if (error == FFEBAD_NOCANDO)
1755 return expr;
1756
1757 expr = ffebld_new_conter_with_orig
1758 (ffebld_constant_new_real1_val
1759 (ffebld_cu_val_real1 (u)), expr);
1760 break;
1761 #endif
1762
1763 #if FFETARGET_okREAL2
1764 case FFEINFO_kindtypeREAL2:
1765 switch (ffeinfo_basictype (ffebld_info (l)))
1766 {
1767 case FFEINFO_basictypeINTEGER:
1768 switch (ffeinfo_kindtype (ffebld_info (l)))
1769 {
1770 #if FFETARGET_okINTEGER1
1771 case FFEINFO_kindtypeINTEGER1:
1772 error = ffetarget_convert_real2_integer1
1773 (ffebld_cu_ptr_real2 (u),
1774 ffebld_constant_integer1 (ffebld_conter (l)));
1775 break;
1776 #endif
1777
1778 #if FFETARGET_okINTEGER2
1779 case FFEINFO_kindtypeINTEGER2:
1780 error = ffetarget_convert_real2_integer2
1781 (ffebld_cu_ptr_real2 (u),
1782 ffebld_constant_integer2 (ffebld_conter (l)));
1783 break;
1784 #endif
1785
1786 #if FFETARGET_okINTEGER3
1787 case FFEINFO_kindtypeINTEGER3:
1788 error = ffetarget_convert_real2_integer3
1789 (ffebld_cu_ptr_real2 (u),
1790 ffebld_constant_integer3 (ffebld_conter (l)));
1791 break;
1792 #endif
1793
1794 #if FFETARGET_okINTEGER4
1795 case FFEINFO_kindtypeINTEGER4:
1796 error = ffetarget_convert_real2_integer4
1797 (ffebld_cu_ptr_real2 (u),
1798 ffebld_constant_integer4 (ffebld_conter (l)));
1799 break;
1800 #endif
1801
1802 default:
1803 assert ("REAL2/INTEGER bad source kind type" == NULL);
1804 break;
1805 }
1806 break;
1807
1808 case FFEINFO_basictypeREAL:
1809 switch (ffeinfo_kindtype (ffebld_info (l)))
1810 {
1811 #if FFETARGET_okREAL1
1812 case FFEINFO_kindtypeREAL1:
1813 error = ffetarget_convert_real2_real1
1814 (ffebld_cu_ptr_real2 (u),
1815 ffebld_constant_real1 (ffebld_conter (l)));
1816 break;
1817 #endif
1818
1819 #if FFETARGET_okREAL3
1820 case FFEINFO_kindtypeREAL3:
1821 error = ffetarget_convert_real2_real3
1822 (ffebld_cu_ptr_real2 (u),
1823 ffebld_constant_real3 (ffebld_conter (l)));
1824 break;
1825 #endif
1826
1827 default:
1828 assert ("REAL2/REAL bad source kind type" == NULL);
1829 break;
1830 }
1831 break;
1832
1833 case FFEINFO_basictypeCOMPLEX:
1834 switch (ffeinfo_kindtype (ffebld_info (l)))
1835 {
1836 #if FFETARGET_okCOMPLEX1
1837 case FFEINFO_kindtypeREAL1:
1838 error = ffetarget_convert_real2_complex1
1839 (ffebld_cu_ptr_real2 (u),
1840 ffebld_constant_complex1 (ffebld_conter (l)));
1841 break;
1842 #endif
1843
1844 #if FFETARGET_okCOMPLEX2
1845 case FFEINFO_kindtypeREAL2:
1846 error = ffetarget_convert_real2_complex2
1847 (ffebld_cu_ptr_real2 (u),
1848 ffebld_constant_complex2 (ffebld_conter (l)));
1849 break;
1850 #endif
1851
1852 #if FFETARGET_okCOMPLEX3
1853 case FFEINFO_kindtypeREAL3:
1854 error = ffetarget_convert_real2_complex3
1855 (ffebld_cu_ptr_real2 (u),
1856 ffebld_constant_complex3 (ffebld_conter (l)));
1857 break;
1858 #endif
1859
1860 default:
1861 assert ("REAL2/COMPLEX bad source kind type" == NULL);
1862 break;
1863 }
1864 break;
1865
1866 case FFEINFO_basictypeCHARACTER:
1867 error = ffetarget_convert_real2_character1
1868 (ffebld_cu_ptr_real2 (u),
1869 ffebld_constant_character1 (ffebld_conter (l)));
1870 break;
1871
1872 case FFEINFO_basictypeHOLLERITH:
1873 error = ffetarget_convert_real2_hollerith
1874 (ffebld_cu_ptr_real2 (u),
1875 ffebld_constant_hollerith (ffebld_conter (l)));
1876 break;
1877
1878 case FFEINFO_basictypeTYPELESS:
1879 error = ffetarget_convert_real2_typeless
1880 (ffebld_cu_ptr_real2 (u),
1881 ffebld_constant_typeless (ffebld_conter (l)));
1882 break;
1883
1884 default:
1885 assert ("REAL2 bad type" == NULL);
1886 break;
1887 }
1888
1889 /* If conversion operation is not implemented, return original expr. */
1890 if (error == FFEBAD_NOCANDO)
1891 return expr;
1892
1893 expr = ffebld_new_conter_with_orig
1894 (ffebld_constant_new_real2_val
1895 (ffebld_cu_val_real2 (u)), expr);
1896 break;
1897 #endif
1898
1899 #if FFETARGET_okREAL3
1900 case FFEINFO_kindtypeREAL3:
1901 switch (ffeinfo_basictype (ffebld_info (l)))
1902 {
1903 case FFEINFO_basictypeINTEGER:
1904 switch (ffeinfo_kindtype (ffebld_info (l)))
1905 {
1906 #if FFETARGET_okINTEGER1
1907 case FFEINFO_kindtypeINTEGER1:
1908 error = ffetarget_convert_real3_integer1
1909 (ffebld_cu_ptr_real3 (u),
1910 ffebld_constant_integer1 (ffebld_conter (l)));
1911 break;
1912 #endif
1913
1914 #if FFETARGET_okINTEGER2
1915 case FFEINFO_kindtypeINTEGER2:
1916 error = ffetarget_convert_real3_integer2
1917 (ffebld_cu_ptr_real3 (u),
1918 ffebld_constant_integer2 (ffebld_conter (l)));
1919 break;
1920 #endif
1921
1922 #if FFETARGET_okINTEGER3
1923 case FFEINFO_kindtypeINTEGER3:
1924 error = ffetarget_convert_real3_integer3
1925 (ffebld_cu_ptr_real3 (u),
1926 ffebld_constant_integer3 (ffebld_conter (l)));
1927 break;
1928 #endif
1929
1930 #if FFETARGET_okINTEGER4
1931 case FFEINFO_kindtypeINTEGER4:
1932 error = ffetarget_convert_real3_integer4
1933 (ffebld_cu_ptr_real3 (u),
1934 ffebld_constant_integer4 (ffebld_conter (l)));
1935 break;
1936 #endif
1937
1938 default:
1939 assert ("REAL3/INTEGER bad source kind type" == NULL);
1940 break;
1941 }
1942 break;
1943
1944 case FFEINFO_basictypeREAL:
1945 switch (ffeinfo_kindtype (ffebld_info (l)))
1946 {
1947 #if FFETARGET_okREAL1
1948 case FFEINFO_kindtypeREAL1:
1949 error = ffetarget_convert_real3_real1
1950 (ffebld_cu_ptr_real3 (u),
1951 ffebld_constant_real1 (ffebld_conter (l)));
1952 break;
1953 #endif
1954
1955 #if FFETARGET_okREAL2
1956 case FFEINFO_kindtypeREAL2:
1957 error = ffetarget_convert_real3_real2
1958 (ffebld_cu_ptr_real3 (u),
1959 ffebld_constant_real2 (ffebld_conter (l)));
1960 break;
1961 #endif
1962
1963 default:
1964 assert ("REAL3/REAL bad source kind type" == NULL);
1965 break;
1966 }
1967 break;
1968
1969 case FFEINFO_basictypeCOMPLEX:
1970 switch (ffeinfo_kindtype (ffebld_info (l)))
1971 {
1972 #if FFETARGET_okCOMPLEX1
1973 case FFEINFO_kindtypeREAL1:
1974 error = ffetarget_convert_real3_complex1
1975 (ffebld_cu_ptr_real3 (u),
1976 ffebld_constant_complex1 (ffebld_conter (l)));
1977 break;
1978 #endif
1979
1980 #if FFETARGET_okCOMPLEX2
1981 case FFEINFO_kindtypeREAL2:
1982 error = ffetarget_convert_real3_complex2
1983 (ffebld_cu_ptr_real3 (u),
1984 ffebld_constant_complex2 (ffebld_conter (l)));
1985 break;
1986 #endif
1987
1988 #if FFETARGET_okCOMPLEX3
1989 case FFEINFO_kindtypeREAL3:
1990 error = ffetarget_convert_real3_complex3
1991 (ffebld_cu_ptr_real3 (u),
1992 ffebld_constant_complex3 (ffebld_conter (l)));
1993 break;
1994 #endif
1995
1996 default:
1997 assert ("REAL3/COMPLEX bad source kind type" == NULL);
1998 break;
1999 }
2000 break;
2001
2002 case FFEINFO_basictypeCHARACTER:
2003 error = ffetarget_convert_real3_character1
2004 (ffebld_cu_ptr_real3 (u),
2005 ffebld_constant_character1 (ffebld_conter (l)));
2006 break;
2007
2008 case FFEINFO_basictypeHOLLERITH:
2009 error = ffetarget_convert_real3_hollerith
2010 (ffebld_cu_ptr_real3 (u),
2011 ffebld_constant_hollerith (ffebld_conter (l)));
2012 break;
2013
2014 case FFEINFO_basictypeTYPELESS:
2015 error = ffetarget_convert_real3_typeless
2016 (ffebld_cu_ptr_real3 (u),
2017 ffebld_constant_typeless (ffebld_conter (l)));
2018 break;
2019
2020 default:
2021 assert ("REAL3 bad type" == NULL);
2022 break;
2023 }
2024
2025 /* If conversion operation is not implemented, return original expr. */
2026 if (error == FFEBAD_NOCANDO)
2027 return expr;
2028
2029 expr = ffebld_new_conter_with_orig
2030 (ffebld_constant_new_real3_val
2031 (ffebld_cu_val_real3 (u)), expr);
2032 break;
2033 #endif
2034
2035 default:
2036 assert ("bad real kind type" == NULL);
2037 break;
2038 }
2039 break;
2040
2041 case FFEINFO_basictypeCOMPLEX:
2042 sz = FFETARGET_charactersizeNONE;
2043 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2044 {
2045 #if FFETARGET_okCOMPLEX1
2046 case FFEINFO_kindtypeREAL1:
2047 switch (ffeinfo_basictype (ffebld_info (l)))
2048 {
2049 case FFEINFO_basictypeINTEGER:
2050 switch (ffeinfo_kindtype (ffebld_info (l)))
2051 {
2052 #if FFETARGET_okINTEGER1
2053 case FFEINFO_kindtypeINTEGER1:
2054 error = ffetarget_convert_complex1_integer1
2055 (ffebld_cu_ptr_complex1 (u),
2056 ffebld_constant_integer1 (ffebld_conter (l)));
2057 break;
2058 #endif
2059
2060 #if FFETARGET_okINTEGER2
2061 case FFEINFO_kindtypeINTEGER2:
2062 error = ffetarget_convert_complex1_integer2
2063 (ffebld_cu_ptr_complex1 (u),
2064 ffebld_constant_integer2 (ffebld_conter (l)));
2065 break;
2066 #endif
2067
2068 #if FFETARGET_okINTEGER3
2069 case FFEINFO_kindtypeINTEGER3:
2070 error = ffetarget_convert_complex1_integer3
2071 (ffebld_cu_ptr_complex1 (u),
2072 ffebld_constant_integer3 (ffebld_conter (l)));
2073 break;
2074 #endif
2075
2076 #if FFETARGET_okINTEGER4
2077 case FFEINFO_kindtypeINTEGER4:
2078 error = ffetarget_convert_complex1_integer4
2079 (ffebld_cu_ptr_complex1 (u),
2080 ffebld_constant_integer4 (ffebld_conter (l)));
2081 break;
2082 #endif
2083
2084 default:
2085 assert ("COMPLEX1/INTEGER bad source kind type" == NULL);
2086 break;
2087 }
2088 break;
2089
2090 case FFEINFO_basictypeREAL:
2091 switch (ffeinfo_kindtype (ffebld_info (l)))
2092 {
2093 #if FFETARGET_okREAL1
2094 case FFEINFO_kindtypeREAL1:
2095 error = ffetarget_convert_complex1_real1
2096 (ffebld_cu_ptr_complex1 (u),
2097 ffebld_constant_real1 (ffebld_conter (l)));
2098 break;
2099 #endif
2100
2101 #if FFETARGET_okREAL2
2102 case FFEINFO_kindtypeREAL2:
2103 error = ffetarget_convert_complex1_real2
2104 (ffebld_cu_ptr_complex1 (u),
2105 ffebld_constant_real2 (ffebld_conter (l)));
2106 break;
2107 #endif
2108
2109 #if FFETARGET_okREAL3
2110 case FFEINFO_kindtypeREAL3:
2111 error = ffetarget_convert_complex1_real3
2112 (ffebld_cu_ptr_complex1 (u),
2113 ffebld_constant_real3 (ffebld_conter (l)));
2114 break;
2115 #endif
2116
2117 default:
2118 assert ("COMPLEX1/REAL bad source kind type" == NULL);
2119 break;
2120 }
2121 break;
2122
2123 case FFEINFO_basictypeCOMPLEX:
2124 switch (ffeinfo_kindtype (ffebld_info (l)))
2125 {
2126 #if FFETARGET_okCOMPLEX2
2127 case FFEINFO_kindtypeREAL2:
2128 error = ffetarget_convert_complex1_complex2
2129 (ffebld_cu_ptr_complex1 (u),
2130 ffebld_constant_complex2 (ffebld_conter (l)));
2131 break;
2132 #endif
2133
2134 #if FFETARGET_okCOMPLEX3
2135 case FFEINFO_kindtypeREAL3:
2136 error = ffetarget_convert_complex1_complex3
2137 (ffebld_cu_ptr_complex1 (u),
2138 ffebld_constant_complex3 (ffebld_conter (l)));
2139 break;
2140 #endif
2141
2142 default:
2143 assert ("COMPLEX1/COMPLEX bad source kind type" == NULL);
2144 break;
2145 }
2146 break;
2147
2148 case FFEINFO_basictypeCHARACTER:
2149 error = ffetarget_convert_complex1_character1
2150 (ffebld_cu_ptr_complex1 (u),
2151 ffebld_constant_character1 (ffebld_conter (l)));
2152 break;
2153
2154 case FFEINFO_basictypeHOLLERITH:
2155 error = ffetarget_convert_complex1_hollerith
2156 (ffebld_cu_ptr_complex1 (u),
2157 ffebld_constant_hollerith (ffebld_conter (l)));
2158 break;
2159
2160 case FFEINFO_basictypeTYPELESS:
2161 error = ffetarget_convert_complex1_typeless
2162 (ffebld_cu_ptr_complex1 (u),
2163 ffebld_constant_typeless (ffebld_conter (l)));
2164 break;
2165
2166 default:
2167 assert ("COMPLEX1 bad type" == NULL);
2168 break;
2169 }
2170
2171 /* If conversion operation is not implemented, return original expr. */
2172 if (error == FFEBAD_NOCANDO)
2173 return expr;
2174
2175 expr = ffebld_new_conter_with_orig
2176 (ffebld_constant_new_complex1_val
2177 (ffebld_cu_val_complex1 (u)), expr);
2178 break;
2179 #endif
2180
2181 #if FFETARGET_okCOMPLEX2
2182 case FFEINFO_kindtypeREAL2:
2183 switch (ffeinfo_basictype (ffebld_info (l)))
2184 {
2185 case FFEINFO_basictypeINTEGER:
2186 switch (ffeinfo_kindtype (ffebld_info (l)))
2187 {
2188 #if FFETARGET_okINTEGER1
2189 case FFEINFO_kindtypeINTEGER1:
2190 error = ffetarget_convert_complex2_integer1
2191 (ffebld_cu_ptr_complex2 (u),
2192 ffebld_constant_integer1 (ffebld_conter (l)));
2193 break;
2194 #endif
2195
2196 #if FFETARGET_okINTEGER2
2197 case FFEINFO_kindtypeINTEGER2:
2198 error = ffetarget_convert_complex2_integer2
2199 (ffebld_cu_ptr_complex2 (u),
2200 ffebld_constant_integer2 (ffebld_conter (l)));
2201 break;
2202 #endif
2203
2204 #if FFETARGET_okINTEGER3
2205 case FFEINFO_kindtypeINTEGER3:
2206 error = ffetarget_convert_complex2_integer3
2207 (ffebld_cu_ptr_complex2 (u),
2208 ffebld_constant_integer3 (ffebld_conter (l)));
2209 break;
2210 #endif
2211
2212 #if FFETARGET_okINTEGER4
2213 case FFEINFO_kindtypeINTEGER4:
2214 error = ffetarget_convert_complex2_integer4
2215 (ffebld_cu_ptr_complex2 (u),
2216 ffebld_constant_integer4 (ffebld_conter (l)));
2217 break;
2218 #endif
2219
2220 default:
2221 assert ("COMPLEX2/INTEGER bad source kind type" == NULL);
2222 break;
2223 }
2224 break;
2225
2226 case FFEINFO_basictypeREAL:
2227 switch (ffeinfo_kindtype (ffebld_info (l)))
2228 {
2229 #if FFETARGET_okREAL1
2230 case FFEINFO_kindtypeREAL1:
2231 error = ffetarget_convert_complex2_real1
2232 (ffebld_cu_ptr_complex2 (u),
2233 ffebld_constant_real1 (ffebld_conter (l)));
2234 break;
2235 #endif
2236
2237 #if FFETARGET_okREAL2
2238 case FFEINFO_kindtypeREAL2:
2239 error = ffetarget_convert_complex2_real2
2240 (ffebld_cu_ptr_complex2 (u),
2241 ffebld_constant_real2 (ffebld_conter (l)));
2242 break;
2243 #endif
2244
2245 #if FFETARGET_okREAL3
2246 case FFEINFO_kindtypeREAL3:
2247 error = ffetarget_convert_complex2_real3
2248 (ffebld_cu_ptr_complex2 (u),
2249 ffebld_constant_real3 (ffebld_conter (l)));
2250 break;
2251 #endif
2252
2253 default:
2254 assert ("COMPLEX2/REAL bad source kind type" == NULL);
2255 break;
2256 }
2257 break;
2258
2259 case FFEINFO_basictypeCOMPLEX:
2260 switch (ffeinfo_kindtype (ffebld_info (l)))
2261 {
2262 #if FFETARGET_okCOMPLEX1
2263 case FFEINFO_kindtypeREAL1:
2264 error = ffetarget_convert_complex2_complex1
2265 (ffebld_cu_ptr_complex2 (u),
2266 ffebld_constant_complex1 (ffebld_conter (l)));
2267 break;
2268 #endif
2269
2270 #if FFETARGET_okCOMPLEX3
2271 case FFEINFO_kindtypeREAL3:
2272 error = ffetarget_convert_complex2_complex3
2273 (ffebld_cu_ptr_complex2 (u),
2274 ffebld_constant_complex3 (ffebld_conter (l)));
2275 break;
2276 #endif
2277
2278 default:
2279 assert ("COMPLEX2/COMPLEX bad source kind type" == NULL);
2280 break;
2281 }
2282 break;
2283
2284 case FFEINFO_basictypeCHARACTER:
2285 error = ffetarget_convert_complex2_character1
2286 (ffebld_cu_ptr_complex2 (u),
2287 ffebld_constant_character1 (ffebld_conter (l)));
2288 break;
2289
2290 case FFEINFO_basictypeHOLLERITH:
2291 error = ffetarget_convert_complex2_hollerith
2292 (ffebld_cu_ptr_complex2 (u),
2293 ffebld_constant_hollerith (ffebld_conter (l)));
2294 break;
2295
2296 case FFEINFO_basictypeTYPELESS:
2297 error = ffetarget_convert_complex2_typeless
2298 (ffebld_cu_ptr_complex2 (u),
2299 ffebld_constant_typeless (ffebld_conter (l)));
2300 break;
2301
2302 default:
2303 assert ("COMPLEX2 bad type" == NULL);
2304 break;
2305 }
2306
2307 /* If conversion operation is not implemented, return original expr. */
2308 if (error == FFEBAD_NOCANDO)
2309 return expr;
2310
2311 expr = ffebld_new_conter_with_orig
2312 (ffebld_constant_new_complex2_val
2313 (ffebld_cu_val_complex2 (u)), expr);
2314 break;
2315 #endif
2316
2317 #if FFETARGET_okCOMPLEX3
2318 case FFEINFO_kindtypeREAL3:
2319 switch (ffeinfo_basictype (ffebld_info (l)))
2320 {
2321 case FFEINFO_basictypeINTEGER:
2322 switch (ffeinfo_kindtype (ffebld_info (l)))
2323 {
2324 #if FFETARGET_okINTEGER1
2325 case FFEINFO_kindtypeINTEGER1:
2326 error = ffetarget_convert_complex3_integer1
2327 (ffebld_cu_ptr_complex3 (u),
2328 ffebld_constant_integer1 (ffebld_conter (l)));
2329 break;
2330 #endif
2331
2332 #if FFETARGET_okINTEGER2
2333 case FFEINFO_kindtypeINTEGER2:
2334 error = ffetarget_convert_complex3_integer2
2335 (ffebld_cu_ptr_complex3 (u),
2336 ffebld_constant_integer2 (ffebld_conter (l)));
2337 break;
2338 #endif
2339
2340 #if FFETARGET_okINTEGER3
2341 case FFEINFO_kindtypeINTEGER3:
2342 error = ffetarget_convert_complex3_integer3
2343 (ffebld_cu_ptr_complex3 (u),
2344 ffebld_constant_integer3 (ffebld_conter (l)));
2345 break;
2346 #endif
2347
2348 #if FFETARGET_okINTEGER4
2349 case FFEINFO_kindtypeINTEGER4:
2350 error = ffetarget_convert_complex3_integer4
2351 (ffebld_cu_ptr_complex3 (u),
2352 ffebld_constant_integer4 (ffebld_conter (l)));
2353 break;
2354 #endif
2355
2356 default:
2357 assert ("COMPLEX3/INTEGER bad source kind type" == NULL);
2358 break;
2359 }
2360 break;
2361
2362 case FFEINFO_basictypeREAL:
2363 switch (ffeinfo_kindtype (ffebld_info (l)))
2364 {
2365 #if FFETARGET_okREAL1
2366 case FFEINFO_kindtypeREAL1:
2367 error = ffetarget_convert_complex3_real1
2368 (ffebld_cu_ptr_complex3 (u),
2369 ffebld_constant_real1 (ffebld_conter (l)));
2370 break;
2371 #endif
2372
2373 #if FFETARGET_okREAL2
2374 case FFEINFO_kindtypeREAL2:
2375 error = ffetarget_convert_complex3_real2
2376 (ffebld_cu_ptr_complex3 (u),
2377 ffebld_constant_real2 (ffebld_conter (l)));
2378 break;
2379 #endif
2380
2381 #if FFETARGET_okREAL3
2382 case FFEINFO_kindtypeREAL3:
2383 error = ffetarget_convert_complex3_real3
2384 (ffebld_cu_ptr_complex3 (u),
2385 ffebld_constant_real3 (ffebld_conter (l)));
2386 break;
2387 #endif
2388
2389 default:
2390 assert ("COMPLEX3/REAL bad source kind type" == NULL);
2391 break;
2392 }
2393 break;
2394
2395 case FFEINFO_basictypeCOMPLEX:
2396 switch (ffeinfo_kindtype (ffebld_info (l)))
2397 {
2398 #if FFETARGET_okCOMPLEX1
2399 case FFEINFO_kindtypeREAL1:
2400 error = ffetarget_convert_complex3_complex1
2401 (ffebld_cu_ptr_complex3 (u),
2402 ffebld_constant_complex1 (ffebld_conter (l)));
2403 break;
2404 #endif
2405
2406 #if FFETARGET_okCOMPLEX2
2407 case FFEINFO_kindtypeREAL2:
2408 error = ffetarget_convert_complex3_complex2
2409 (ffebld_cu_ptr_complex3 (u),
2410 ffebld_constant_complex2 (ffebld_conter (l)));
2411 break;
2412 #endif
2413
2414 default:
2415 assert ("COMPLEX3/COMPLEX bad source kind type" == NULL);
2416 break;
2417 }
2418 break;
2419
2420 case FFEINFO_basictypeCHARACTER:
2421 error = ffetarget_convert_complex3_character1
2422 (ffebld_cu_ptr_complex3 (u),
2423 ffebld_constant_character1 (ffebld_conter (l)));
2424 break;
2425
2426 case FFEINFO_basictypeHOLLERITH:
2427 error = ffetarget_convert_complex3_hollerith
2428 (ffebld_cu_ptr_complex3 (u),
2429 ffebld_constant_hollerith (ffebld_conter (l)));
2430 break;
2431
2432 case FFEINFO_basictypeTYPELESS:
2433 error = ffetarget_convert_complex3_typeless
2434 (ffebld_cu_ptr_complex3 (u),
2435 ffebld_constant_typeless (ffebld_conter (l)));
2436 break;
2437
2438 default:
2439 assert ("COMPLEX3 bad type" == NULL);
2440 break;
2441 }
2442
2443 /* If conversion operation is not implemented, return original expr. */
2444 if (error == FFEBAD_NOCANDO)
2445 return expr;
2446
2447 expr = ffebld_new_conter_with_orig
2448 (ffebld_constant_new_complex3_val
2449 (ffebld_cu_val_complex3 (u)), expr);
2450 break;
2451 #endif
2452
2453 default:
2454 assert ("bad complex kind type" == NULL);
2455 break;
2456 }
2457 break;
2458
2459 case FFEINFO_basictypeCHARACTER:
2460 if ((sz = ffebld_size (expr)) == FFETARGET_charactersizeNONE)
2461 return expr;
2462 kt = ffeinfo_kindtype (ffebld_info (expr));
2463 switch (kt)
2464 {
2465 #if FFETARGET_okCHARACTER1
2466 case FFEINFO_kindtypeCHARACTER1:
2467 switch (ffeinfo_basictype (ffebld_info (l)))
2468 {
2469 case FFEINFO_basictypeCHARACTER:
2470 if ((sz2 = ffebld_size (l)) == FFETARGET_charactersizeNONE)
2471 return expr;
2472 assert (kt == ffeinfo_kindtype (ffebld_info (l)));
2473 assert (sz2 == ffetarget_length_character1
2474 (ffebld_constant_character1
2475 (ffebld_conter (l))));
2476 error
2477 = ffetarget_convert_character1_character1
2478 (ffebld_cu_ptr_character1 (u), sz,
2479 ffebld_constant_character1 (ffebld_conter (l)),
2480 ffebld_constant_pool ());
2481 break;
2482
2483 case FFEINFO_basictypeINTEGER:
2484 switch (ffeinfo_kindtype (ffebld_info (l)))
2485 {
2486 #if FFETARGET_okINTEGER1
2487 case FFEINFO_kindtypeINTEGER1:
2488 error
2489 = ffetarget_convert_character1_integer1
2490 (ffebld_cu_ptr_character1 (u),
2491 sz,
2492 ffebld_constant_integer1 (ffebld_conter (l)),
2493 ffebld_constant_pool ());
2494 break;
2495 #endif
2496
2497 #if FFETARGET_okINTEGER2
2498 case FFEINFO_kindtypeINTEGER2:
2499 error
2500 = ffetarget_convert_character1_integer2
2501 (ffebld_cu_ptr_character1 (u),
2502 sz,
2503 ffebld_constant_integer2 (ffebld_conter (l)),
2504 ffebld_constant_pool ());
2505 break;
2506 #endif
2507
2508 #if FFETARGET_okINTEGER3
2509 case FFEINFO_kindtypeINTEGER3:
2510 error
2511 = ffetarget_convert_character1_integer3
2512 (ffebld_cu_ptr_character1 (u),
2513 sz,
2514 ffebld_constant_integer3 (ffebld_conter (l)),
2515 ffebld_constant_pool ());
2516 break;
2517 #endif
2518
2519 #if FFETARGET_okINTEGER4
2520 case FFEINFO_kindtypeINTEGER4:
2521 error
2522 = ffetarget_convert_character1_integer4
2523 (ffebld_cu_ptr_character1 (u),
2524 sz,
2525 ffebld_constant_integer4 (ffebld_conter (l)),
2526 ffebld_constant_pool ());
2527 break;
2528 #endif
2529
2530 default:
2531 assert ("CHARACTER1/INTEGER bad source kind type" == NULL);
2532 break;
2533 }
2534 break;
2535
2536 case FFEINFO_basictypeLOGICAL:
2537 switch (ffeinfo_kindtype (ffebld_info (l)))
2538 {
2539 #if FFETARGET_okLOGICAL1
2540 case FFEINFO_kindtypeLOGICAL1:
2541 error
2542 = ffetarget_convert_character1_logical1
2543 (ffebld_cu_ptr_character1 (u),
2544 sz,
2545 ffebld_constant_logical1 (ffebld_conter (l)),
2546 ffebld_constant_pool ());
2547 break;
2548 #endif
2549
2550 #if FFETARGET_okLOGICAL2
2551 case FFEINFO_kindtypeLOGICAL2:
2552 error
2553 = ffetarget_convert_character1_logical2
2554 (ffebld_cu_ptr_character1 (u),
2555 sz,
2556 ffebld_constant_logical2 (ffebld_conter (l)),
2557 ffebld_constant_pool ());
2558 break;
2559 #endif
2560
2561 #if FFETARGET_okLOGICAL3
2562 case FFEINFO_kindtypeLOGICAL3:
2563 error
2564 = ffetarget_convert_character1_logical3
2565 (ffebld_cu_ptr_character1 (u),
2566 sz,
2567 ffebld_constant_logical3 (ffebld_conter (l)),
2568 ffebld_constant_pool ());
2569 break;
2570 #endif
2571
2572 #if FFETARGET_okLOGICAL4
2573 case FFEINFO_kindtypeLOGICAL4:
2574 error
2575 = ffetarget_convert_character1_logical4
2576 (ffebld_cu_ptr_character1 (u),
2577 sz,
2578 ffebld_constant_logical4 (ffebld_conter (l)),
2579 ffebld_constant_pool ());
2580 break;
2581 #endif
2582
2583 default:
2584 assert ("CHARACTER1/LOGICAL bad source kind type" == NULL);
2585 break;
2586 }
2587 break;
2588
2589 case FFEINFO_basictypeHOLLERITH:
2590 error
2591 = ffetarget_convert_character1_hollerith
2592 (ffebld_cu_ptr_character1 (u),
2593 sz,
2594 ffebld_constant_hollerith (ffebld_conter (l)),
2595 ffebld_constant_pool ());
2596 break;
2597
2598 case FFEINFO_basictypeTYPELESS:
2599 error
2600 = ffetarget_convert_character1_typeless
2601 (ffebld_cu_ptr_character1 (u),
2602 sz,
2603 ffebld_constant_typeless (ffebld_conter (l)),
2604 ffebld_constant_pool ());
2605 break;
2606
2607 default:
2608 assert ("CHARACTER1 bad type" == NULL);
2609 }
2610
2611 expr
2612 = ffebld_new_conter_with_orig
2613 (ffebld_constant_new_character1_val
2614 (ffebld_cu_val_character1 (u)),
2615 expr);
2616 break;
2617 #endif
2618
2619 default:
2620 assert ("bad character kind type" == NULL);
2621 break;
2622 }
2623 break;
2624
2625 default:
2626 assert ("bad type" == NULL);
2627 return expr;
2628 }
2629
2630 ffebld_set_info (expr, ffeinfo_new
2631 (bt,
2632 kt,
2633 0,
2634 FFEINFO_kindENTITY,
2635 FFEINFO_whereCONSTANT,
2636 sz));
2637
2638 if ((error != FFEBAD)
2639 && ffebad_start (error))
2640 {
2641 assert (t != NULL);
2642 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
2643 ffebad_finish ();
2644 }
2645
2646 return expr;
2647 }
2648
2649 /* ffeexpr_collapse_paren -- Collapse paren expr
2650
2651 ffebld expr;
2652 ffelexToken token;
2653 expr = ffeexpr_collapse_paren(expr,token);
2654
2655 If the result of the expr is a constant, replaces the expr with the
2656 computed constant. */
2657
2658 ffebld
2659 ffeexpr_collapse_paren (ffebld expr, ffelexToken t UNUSED)
2660 {
2661 ffebld r;
2662 ffeinfoBasictype bt;
2663 ffeinfoKindtype kt;
2664 ffetargetCharacterSize len;
2665
2666 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
2667 return expr;
2668
2669 r = ffebld_left (expr);
2670
2671 if (ffebld_op (r) != FFEBLD_opCONTER)
2672 return expr;
2673
2674 bt = ffeinfo_basictype (ffebld_info (r));
2675 kt = ffeinfo_kindtype (ffebld_info (r));
2676 len = ffebld_size (r);
2677
2678 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
2679 expr);
2680
2681 ffebld_set_info (expr, ffeinfo_new
2682 (bt,
2683 kt,
2684 0,
2685 FFEINFO_kindENTITY,
2686 FFEINFO_whereCONSTANT,
2687 len));
2688
2689 return expr;
2690 }
2691
2692 /* ffeexpr_collapse_uplus -- Collapse uplus expr
2693
2694 ffebld expr;
2695 ffelexToken token;
2696 expr = ffeexpr_collapse_uplus(expr,token);
2697
2698 If the result of the expr is a constant, replaces the expr with the
2699 computed constant. */
2700
2701 ffebld
2702 ffeexpr_collapse_uplus (ffebld expr, ffelexToken t UNUSED)
2703 {
2704 ffebld r;
2705 ffeinfoBasictype bt;
2706 ffeinfoKindtype kt;
2707 ffetargetCharacterSize len;
2708
2709 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
2710 return expr;
2711
2712 r = ffebld_left (expr);
2713
2714 if (ffebld_op (r) != FFEBLD_opCONTER)
2715 return expr;
2716
2717 bt = ffeinfo_basictype (ffebld_info (r));
2718 kt = ffeinfo_kindtype (ffebld_info (r));
2719 len = ffebld_size (r);
2720
2721 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
2722 expr);
2723
2724 ffebld_set_info (expr, ffeinfo_new
2725 (bt,
2726 kt,
2727 0,
2728 FFEINFO_kindENTITY,
2729 FFEINFO_whereCONSTANT,
2730 len));
2731
2732 return expr;
2733 }
2734
2735 /* ffeexpr_collapse_uminus -- Collapse uminus expr
2736
2737 ffebld expr;
2738 ffelexToken token;
2739 expr = ffeexpr_collapse_uminus(expr,token);
2740
2741 If the result of the expr is a constant, replaces the expr with the
2742 computed constant. */
2743
2744 ffebld
2745 ffeexpr_collapse_uminus (ffebld expr, ffelexToken t)
2746 {
2747 ffebad error = FFEBAD;
2748 ffebld r;
2749 ffebldConstantUnion u;
2750 ffeinfoBasictype bt;
2751 ffeinfoKindtype kt;
2752
2753 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
2754 return expr;
2755
2756 r = ffebld_left (expr);
2757
2758 if (ffebld_op (r) != FFEBLD_opCONTER)
2759 return expr;
2760
2761 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
2762 {
2763 case FFEINFO_basictypeANY:
2764 return expr;
2765
2766 case FFEINFO_basictypeINTEGER:
2767 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2768 {
2769 #if FFETARGET_okINTEGER1
2770 case FFEINFO_kindtypeINTEGER1:
2771 error = ffetarget_uminus_integer1 (ffebld_cu_ptr_integer1 (u),
2772 ffebld_constant_integer1 (ffebld_conter (r)));
2773 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
2774 (ffebld_cu_val_integer1 (u)), expr);
2775 break;
2776 #endif
2777
2778 #if FFETARGET_okINTEGER2
2779 case FFEINFO_kindtypeINTEGER2:
2780 error = ffetarget_uminus_integer2 (ffebld_cu_ptr_integer2 (u),
2781 ffebld_constant_integer2 (ffebld_conter (r)));
2782 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
2783 (ffebld_cu_val_integer2 (u)), expr);
2784 break;
2785 #endif
2786
2787 #if FFETARGET_okINTEGER3
2788 case FFEINFO_kindtypeINTEGER3:
2789 error = ffetarget_uminus_integer3 (ffebld_cu_ptr_integer3 (u),
2790 ffebld_constant_integer3 (ffebld_conter (r)));
2791 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
2792 (ffebld_cu_val_integer3 (u)), expr);
2793 break;
2794 #endif
2795
2796 #if FFETARGET_okINTEGER4
2797 case FFEINFO_kindtypeINTEGER4:
2798 error = ffetarget_uminus_integer4 (ffebld_cu_ptr_integer4 (u),
2799 ffebld_constant_integer4 (ffebld_conter (r)));
2800 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
2801 (ffebld_cu_val_integer4 (u)), expr);
2802 break;
2803 #endif
2804
2805 default:
2806 assert ("bad integer kind type" == NULL);
2807 break;
2808 }
2809 break;
2810
2811 case FFEINFO_basictypeREAL:
2812 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2813 {
2814 #if FFETARGET_okREAL1
2815 case FFEINFO_kindtypeREAL1:
2816 error = ffetarget_uminus_real1 (ffebld_cu_ptr_real1 (u),
2817 ffebld_constant_real1 (ffebld_conter (r)));
2818 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
2819 (ffebld_cu_val_real1 (u)), expr);
2820 break;
2821 #endif
2822
2823 #if FFETARGET_okREAL2
2824 case FFEINFO_kindtypeREAL2:
2825 error = ffetarget_uminus_real2 (ffebld_cu_ptr_real2 (u),
2826 ffebld_constant_real2 (ffebld_conter (r)));
2827 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
2828 (ffebld_cu_val_real2 (u)), expr);
2829 break;
2830 #endif
2831
2832 #if FFETARGET_okREAL3
2833 case FFEINFO_kindtypeREAL3:
2834 error = ffetarget_uminus_real3 (ffebld_cu_ptr_real3 (u),
2835 ffebld_constant_real3 (ffebld_conter (r)));
2836 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
2837 (ffebld_cu_val_real3 (u)), expr);
2838 break;
2839 #endif
2840
2841 default:
2842 assert ("bad real kind type" == NULL);
2843 break;
2844 }
2845 break;
2846
2847 case FFEINFO_basictypeCOMPLEX:
2848 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2849 {
2850 #if FFETARGET_okCOMPLEX1
2851 case FFEINFO_kindtypeREAL1:
2852 error = ffetarget_uminus_complex1 (ffebld_cu_ptr_complex1 (u),
2853 ffebld_constant_complex1 (ffebld_conter (r)));
2854 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
2855 (ffebld_cu_val_complex1 (u)), expr);
2856 break;
2857 #endif
2858
2859 #if FFETARGET_okCOMPLEX2
2860 case FFEINFO_kindtypeREAL2:
2861 error = ffetarget_uminus_complex2 (ffebld_cu_ptr_complex2 (u),
2862 ffebld_constant_complex2 (ffebld_conter (r)));
2863 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
2864 (ffebld_cu_val_complex2 (u)), expr);
2865 break;
2866 #endif
2867
2868 #if FFETARGET_okCOMPLEX3
2869 case FFEINFO_kindtypeREAL3:
2870 error = ffetarget_uminus_complex3 (ffebld_cu_ptr_complex3 (u),
2871 ffebld_constant_complex3 (ffebld_conter (r)));
2872 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
2873 (ffebld_cu_val_complex3 (u)), expr);
2874 break;
2875 #endif
2876
2877 default:
2878 assert ("bad complex kind type" == NULL);
2879 break;
2880 }
2881 break;
2882
2883 default:
2884 assert ("bad type" == NULL);
2885 return expr;
2886 }
2887
2888 ffebld_set_info (expr, ffeinfo_new
2889 (bt,
2890 kt,
2891 0,
2892 FFEINFO_kindENTITY,
2893 FFEINFO_whereCONSTANT,
2894 FFETARGET_charactersizeNONE));
2895
2896 if ((error != FFEBAD)
2897 && ffebad_start (error))
2898 {
2899 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
2900 ffebad_finish ();
2901 }
2902
2903 return expr;
2904 }
2905
2906 /* ffeexpr_collapse_not -- Collapse not expr
2907
2908 ffebld expr;
2909 ffelexToken token;
2910 expr = ffeexpr_collapse_not(expr,token);
2911
2912 If the result of the expr is a constant, replaces the expr with the
2913 computed constant. */
2914
2915 ffebld
2916 ffeexpr_collapse_not (ffebld expr, ffelexToken t)
2917 {
2918 ffebad error = FFEBAD;
2919 ffebld r;
2920 ffebldConstantUnion u;
2921 ffeinfoBasictype bt;
2922 ffeinfoKindtype kt;
2923
2924 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
2925 return expr;
2926
2927 r = ffebld_left (expr);
2928
2929 if (ffebld_op (r) != FFEBLD_opCONTER)
2930 return expr;
2931
2932 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
2933 {
2934 case FFEINFO_basictypeANY:
2935 return expr;
2936
2937 case FFEINFO_basictypeINTEGER:
2938 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2939 {
2940 #if FFETARGET_okINTEGER1
2941 case FFEINFO_kindtypeINTEGER1:
2942 error = ffetarget_not_integer1 (ffebld_cu_ptr_integer1 (u),
2943 ffebld_constant_integer1 (ffebld_conter (r)));
2944 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
2945 (ffebld_cu_val_integer1 (u)), expr);
2946 break;
2947 #endif
2948
2949 #if FFETARGET_okINTEGER2
2950 case FFEINFO_kindtypeINTEGER2:
2951 error = ffetarget_not_integer2 (ffebld_cu_ptr_integer2 (u),
2952 ffebld_constant_integer2 (ffebld_conter (r)));
2953 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
2954 (ffebld_cu_val_integer2 (u)), expr);
2955 break;
2956 #endif
2957
2958 #if FFETARGET_okINTEGER3
2959 case FFEINFO_kindtypeINTEGER3:
2960 error = ffetarget_not_integer3 (ffebld_cu_ptr_integer3 (u),
2961 ffebld_constant_integer3 (ffebld_conter (r)));
2962 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
2963 (ffebld_cu_val_integer3 (u)), expr);
2964 break;
2965 #endif
2966
2967 #if FFETARGET_okINTEGER4
2968 case FFEINFO_kindtypeINTEGER4:
2969 error = ffetarget_not_integer4 (ffebld_cu_ptr_integer4 (u),
2970 ffebld_constant_integer4 (ffebld_conter (r)));
2971 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
2972 (ffebld_cu_val_integer4 (u)), expr);
2973 break;
2974 #endif
2975
2976 default:
2977 assert ("bad integer kind type" == NULL);
2978 break;
2979 }
2980 break;
2981
2982 case FFEINFO_basictypeLOGICAL:
2983 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2984 {
2985 #if FFETARGET_okLOGICAL1
2986 case FFEINFO_kindtypeLOGICAL1:
2987 error = ffetarget_not_logical1 (ffebld_cu_ptr_logical1 (u),
2988 ffebld_constant_logical1 (ffebld_conter (r)));
2989 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
2990 (ffebld_cu_val_logical1 (u)), expr);
2991 break;
2992 #endif
2993
2994 #if FFETARGET_okLOGICAL2
2995 case FFEINFO_kindtypeLOGICAL2:
2996 error = ffetarget_not_logical2 (ffebld_cu_ptr_logical2 (u),
2997 ffebld_constant_logical2 (ffebld_conter (r)));
2998 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
2999 (ffebld_cu_val_logical2 (u)), expr);
3000 break;
3001 #endif
3002
3003 #if FFETARGET_okLOGICAL3
3004 case FFEINFO_kindtypeLOGICAL3:
3005 error = ffetarget_not_logical3 (ffebld_cu_ptr_logical3 (u),
3006 ffebld_constant_logical3 (ffebld_conter (r)));
3007 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
3008 (ffebld_cu_val_logical3 (u)), expr);
3009 break;
3010 #endif
3011
3012 #if FFETARGET_okLOGICAL4
3013 case FFEINFO_kindtypeLOGICAL4:
3014 error = ffetarget_not_logical4 (ffebld_cu_ptr_logical4 (u),
3015 ffebld_constant_logical4 (ffebld_conter (r)));
3016 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
3017 (ffebld_cu_val_logical4 (u)), expr);
3018 break;
3019 #endif
3020
3021 default:
3022 assert ("bad logical kind type" == NULL);
3023 break;
3024 }
3025 break;
3026
3027 default:
3028 assert ("bad type" == NULL);
3029 return expr;
3030 }
3031
3032 ffebld_set_info (expr, ffeinfo_new
3033 (bt,
3034 kt,
3035 0,
3036 FFEINFO_kindENTITY,
3037 FFEINFO_whereCONSTANT,
3038 FFETARGET_charactersizeNONE));
3039
3040 if ((error != FFEBAD)
3041 && ffebad_start (error))
3042 {
3043 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3044 ffebad_finish ();
3045 }
3046
3047 return expr;
3048 }
3049
3050 /* ffeexpr_collapse_add -- Collapse add expr
3051
3052 ffebld expr;
3053 ffelexToken token;
3054 expr = ffeexpr_collapse_add(expr,token);
3055
3056 If the result of the expr is a constant, replaces the expr with the
3057 computed constant. */
3058
3059 ffebld
3060 ffeexpr_collapse_add (ffebld expr, ffelexToken t)
3061 {
3062 ffebad error = FFEBAD;
3063 ffebld l;
3064 ffebld r;
3065 ffebldConstantUnion u;
3066 ffeinfoBasictype bt;
3067 ffeinfoKindtype kt;
3068
3069 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3070 return expr;
3071
3072 l = ffebld_left (expr);
3073 r = ffebld_right (expr);
3074
3075 if (ffebld_op (l) != FFEBLD_opCONTER)
3076 return expr;
3077 if (ffebld_op (r) != FFEBLD_opCONTER)
3078 return expr;
3079
3080 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3081 {
3082 case FFEINFO_basictypeANY:
3083 return expr;
3084
3085 case FFEINFO_basictypeINTEGER:
3086 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3087 {
3088 #if FFETARGET_okINTEGER1
3089 case FFEINFO_kindtypeINTEGER1:
3090 error = ffetarget_add_integer1 (ffebld_cu_ptr_integer1 (u),
3091 ffebld_constant_integer1 (ffebld_conter (l)),
3092 ffebld_constant_integer1 (ffebld_conter (r)));
3093 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3094 (ffebld_cu_val_integer1 (u)), expr);
3095 break;
3096 #endif
3097
3098 #if FFETARGET_okINTEGER2
3099 case FFEINFO_kindtypeINTEGER2:
3100 error = ffetarget_add_integer2 (ffebld_cu_ptr_integer2 (u),
3101 ffebld_constant_integer2 (ffebld_conter (l)),
3102 ffebld_constant_integer2 (ffebld_conter (r)));
3103 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3104 (ffebld_cu_val_integer2 (u)), expr);
3105 break;
3106 #endif
3107
3108 #if FFETARGET_okINTEGER3
3109 case FFEINFO_kindtypeINTEGER3:
3110 error = ffetarget_add_integer3 (ffebld_cu_ptr_integer3 (u),
3111 ffebld_constant_integer3 (ffebld_conter (l)),
3112 ffebld_constant_integer3 (ffebld_conter (r)));
3113 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3114 (ffebld_cu_val_integer3 (u)), expr);
3115 break;
3116 #endif
3117
3118 #if FFETARGET_okINTEGER4
3119 case FFEINFO_kindtypeINTEGER4:
3120 error = ffetarget_add_integer4 (ffebld_cu_ptr_integer4 (u),
3121 ffebld_constant_integer4 (ffebld_conter (l)),
3122 ffebld_constant_integer4 (ffebld_conter (r)));
3123 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3124 (ffebld_cu_val_integer4 (u)), expr);
3125 break;
3126 #endif
3127
3128 default:
3129 assert ("bad integer kind type" == NULL);
3130 break;
3131 }
3132 break;
3133
3134 case FFEINFO_basictypeREAL:
3135 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3136 {
3137 #if FFETARGET_okREAL1
3138 case FFEINFO_kindtypeREAL1:
3139 error = ffetarget_add_real1 (ffebld_cu_ptr_real1 (u),
3140 ffebld_constant_real1 (ffebld_conter (l)),
3141 ffebld_constant_real1 (ffebld_conter (r)));
3142 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3143 (ffebld_cu_val_real1 (u)), expr);
3144 break;
3145 #endif
3146
3147 #if FFETARGET_okREAL2
3148 case FFEINFO_kindtypeREAL2:
3149 error = ffetarget_add_real2 (ffebld_cu_ptr_real2 (u),
3150 ffebld_constant_real2 (ffebld_conter (l)),
3151 ffebld_constant_real2 (ffebld_conter (r)));
3152 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3153 (ffebld_cu_val_real2 (u)), expr);
3154 break;
3155 #endif
3156
3157 #if FFETARGET_okREAL3
3158 case FFEINFO_kindtypeREAL3:
3159 error = ffetarget_add_real3 (ffebld_cu_ptr_real3 (u),
3160 ffebld_constant_real3 (ffebld_conter (l)),
3161 ffebld_constant_real3 (ffebld_conter (r)));
3162 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3163 (ffebld_cu_val_real3 (u)), expr);
3164 break;
3165 #endif
3166
3167 default:
3168 assert ("bad real kind type" == NULL);
3169 break;
3170 }
3171 break;
3172
3173 case FFEINFO_basictypeCOMPLEX:
3174 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3175 {
3176 #if FFETARGET_okCOMPLEX1
3177 case FFEINFO_kindtypeREAL1:
3178 error = ffetarget_add_complex1 (ffebld_cu_ptr_complex1 (u),
3179 ffebld_constant_complex1 (ffebld_conter (l)),
3180 ffebld_constant_complex1 (ffebld_conter (r)));
3181 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3182 (ffebld_cu_val_complex1 (u)), expr);
3183 break;
3184 #endif
3185
3186 #if FFETARGET_okCOMPLEX2
3187 case FFEINFO_kindtypeREAL2:
3188 error = ffetarget_add_complex2 (ffebld_cu_ptr_complex2 (u),
3189 ffebld_constant_complex2 (ffebld_conter (l)),
3190 ffebld_constant_complex2 (ffebld_conter (r)));
3191 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3192 (ffebld_cu_val_complex2 (u)), expr);
3193 break;
3194 #endif
3195
3196 #if FFETARGET_okCOMPLEX3
3197 case FFEINFO_kindtypeREAL3:
3198 error = ffetarget_add_complex3 (ffebld_cu_ptr_complex3 (u),
3199 ffebld_constant_complex3 (ffebld_conter (l)),
3200 ffebld_constant_complex3 (ffebld_conter (r)));
3201 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3202 (ffebld_cu_val_complex3 (u)), expr);
3203 break;
3204 #endif
3205
3206 default:
3207 assert ("bad complex kind type" == NULL);
3208 break;
3209 }
3210 break;
3211
3212 default:
3213 assert ("bad type" == NULL);
3214 return expr;
3215 }
3216
3217 ffebld_set_info (expr, ffeinfo_new
3218 (bt,
3219 kt,
3220 0,
3221 FFEINFO_kindENTITY,
3222 FFEINFO_whereCONSTANT,
3223 FFETARGET_charactersizeNONE));
3224
3225 if ((error != FFEBAD)
3226 && ffebad_start (error))
3227 {
3228 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3229 ffebad_finish ();
3230 }
3231
3232 return expr;
3233 }
3234
3235 /* ffeexpr_collapse_subtract -- Collapse subtract expr
3236
3237 ffebld expr;
3238 ffelexToken token;
3239 expr = ffeexpr_collapse_subtract(expr,token);
3240
3241 If the result of the expr is a constant, replaces the expr with the
3242 computed constant. */
3243
3244 ffebld
3245 ffeexpr_collapse_subtract (ffebld expr, ffelexToken t)
3246 {
3247 ffebad error = FFEBAD;
3248 ffebld l;
3249 ffebld r;
3250 ffebldConstantUnion u;
3251 ffeinfoBasictype bt;
3252 ffeinfoKindtype kt;
3253
3254 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3255 return expr;
3256
3257 l = ffebld_left (expr);
3258 r = ffebld_right (expr);
3259
3260 if (ffebld_op (l) != FFEBLD_opCONTER)
3261 return expr;
3262 if (ffebld_op (r) != FFEBLD_opCONTER)
3263 return expr;
3264
3265 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3266 {
3267 case FFEINFO_basictypeANY:
3268 return expr;
3269
3270 case FFEINFO_basictypeINTEGER:
3271 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3272 {
3273 #if FFETARGET_okINTEGER1
3274 case FFEINFO_kindtypeINTEGER1:
3275 error = ffetarget_subtract_integer1 (ffebld_cu_ptr_integer1 (u),
3276 ffebld_constant_integer1 (ffebld_conter (l)),
3277 ffebld_constant_integer1 (ffebld_conter (r)));
3278 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3279 (ffebld_cu_val_integer1 (u)), expr);
3280 break;
3281 #endif
3282
3283 #if FFETARGET_okINTEGER2
3284 case FFEINFO_kindtypeINTEGER2:
3285 error = ffetarget_subtract_integer2 (ffebld_cu_ptr_integer2 (u),
3286 ffebld_constant_integer2 (ffebld_conter (l)),
3287 ffebld_constant_integer2 (ffebld_conter (r)));
3288 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3289 (ffebld_cu_val_integer2 (u)), expr);
3290 break;
3291 #endif
3292
3293 #if FFETARGET_okINTEGER3
3294 case FFEINFO_kindtypeINTEGER3:
3295 error = ffetarget_subtract_integer3 (ffebld_cu_ptr_integer3 (u),
3296 ffebld_constant_integer3 (ffebld_conter (l)),
3297 ffebld_constant_integer3 (ffebld_conter (r)));
3298 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3299 (ffebld_cu_val_integer3 (u)), expr);
3300 break;
3301 #endif
3302
3303 #if FFETARGET_okINTEGER4
3304 case FFEINFO_kindtypeINTEGER4:
3305 error = ffetarget_subtract_integer4 (ffebld_cu_ptr_integer4 (u),
3306 ffebld_constant_integer4 (ffebld_conter (l)),
3307 ffebld_constant_integer4 (ffebld_conter (r)));
3308 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3309 (ffebld_cu_val_integer4 (u)), expr);
3310 break;
3311 #endif
3312
3313 default:
3314 assert ("bad integer kind type" == NULL);
3315 break;
3316 }
3317 break;
3318
3319 case FFEINFO_basictypeREAL:
3320 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3321 {
3322 #if FFETARGET_okREAL1
3323 case FFEINFO_kindtypeREAL1:
3324 error = ffetarget_subtract_real1 (ffebld_cu_ptr_real1 (u),
3325 ffebld_constant_real1 (ffebld_conter (l)),
3326 ffebld_constant_real1 (ffebld_conter (r)));
3327 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3328 (ffebld_cu_val_real1 (u)), expr);
3329 break;
3330 #endif
3331
3332 #if FFETARGET_okREAL2
3333 case FFEINFO_kindtypeREAL2:
3334 error = ffetarget_subtract_real2 (ffebld_cu_ptr_real2 (u),
3335 ffebld_constant_real2 (ffebld_conter (l)),
3336 ffebld_constant_real2 (ffebld_conter (r)));
3337 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3338 (ffebld_cu_val_real2 (u)), expr);
3339 break;
3340 #endif
3341
3342 #if FFETARGET_okREAL3
3343 case FFEINFO_kindtypeREAL3:
3344 error = ffetarget_subtract_real3 (ffebld_cu_ptr_real3 (u),
3345 ffebld_constant_real3 (ffebld_conter (l)),
3346 ffebld_constant_real3 (ffebld_conter (r)));
3347 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3348 (ffebld_cu_val_real3 (u)), expr);
3349 break;
3350 #endif
3351
3352 default:
3353 assert ("bad real kind type" == NULL);
3354 break;
3355 }
3356 break;
3357
3358 case FFEINFO_basictypeCOMPLEX:
3359 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3360 {
3361 #if FFETARGET_okCOMPLEX1
3362 case FFEINFO_kindtypeREAL1:
3363 error = ffetarget_subtract_complex1 (ffebld_cu_ptr_complex1 (u),
3364 ffebld_constant_complex1 (ffebld_conter (l)),
3365 ffebld_constant_complex1 (ffebld_conter (r)));
3366 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3367 (ffebld_cu_val_complex1 (u)), expr);
3368 break;
3369 #endif
3370
3371 #if FFETARGET_okCOMPLEX2
3372 case FFEINFO_kindtypeREAL2:
3373 error = ffetarget_subtract_complex2 (ffebld_cu_ptr_complex2 (u),
3374 ffebld_constant_complex2 (ffebld_conter (l)),
3375 ffebld_constant_complex2 (ffebld_conter (r)));
3376 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3377 (ffebld_cu_val_complex2 (u)), expr);
3378 break;
3379 #endif
3380
3381 #if FFETARGET_okCOMPLEX3
3382 case FFEINFO_kindtypeREAL3:
3383 error = ffetarget_subtract_complex3 (ffebld_cu_ptr_complex3 (u),
3384 ffebld_constant_complex3 (ffebld_conter (l)),
3385 ffebld_constant_complex3 (ffebld_conter (r)));
3386 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3387 (ffebld_cu_val_complex3 (u)), expr);
3388 break;
3389 #endif
3390
3391 default:
3392 assert ("bad complex kind type" == NULL);
3393 break;
3394 }
3395 break;
3396
3397 default:
3398 assert ("bad type" == NULL);
3399 return expr;
3400 }
3401
3402 ffebld_set_info (expr, ffeinfo_new
3403 (bt,
3404 kt,
3405 0,
3406 FFEINFO_kindENTITY,
3407 FFEINFO_whereCONSTANT,
3408 FFETARGET_charactersizeNONE));
3409
3410 if ((error != FFEBAD)
3411 && ffebad_start (error))
3412 {
3413 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3414 ffebad_finish ();
3415 }
3416
3417 return expr;
3418 }
3419
3420 /* ffeexpr_collapse_multiply -- Collapse multiply expr
3421
3422 ffebld expr;
3423 ffelexToken token;
3424 expr = ffeexpr_collapse_multiply(expr,token);
3425
3426 If the result of the expr is a constant, replaces the expr with the
3427 computed constant. */
3428
3429 ffebld
3430 ffeexpr_collapse_multiply (ffebld expr, ffelexToken t)
3431 {
3432 ffebad error = FFEBAD;
3433 ffebld l;
3434 ffebld r;
3435 ffebldConstantUnion u;
3436 ffeinfoBasictype bt;
3437 ffeinfoKindtype kt;
3438
3439 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3440 return expr;
3441
3442 l = ffebld_left (expr);
3443 r = ffebld_right (expr);
3444
3445 if (ffebld_op (l) != FFEBLD_opCONTER)
3446 return expr;
3447 if (ffebld_op (r) != FFEBLD_opCONTER)
3448 return expr;
3449
3450 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3451 {
3452 case FFEINFO_basictypeANY:
3453 return expr;
3454
3455 case FFEINFO_basictypeINTEGER:
3456 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3457 {
3458 #if FFETARGET_okINTEGER1
3459 case FFEINFO_kindtypeINTEGER1:
3460 error = ffetarget_multiply_integer1 (ffebld_cu_ptr_integer1 (u),
3461 ffebld_constant_integer1 (ffebld_conter (l)),
3462 ffebld_constant_integer1 (ffebld_conter (r)));
3463 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3464 (ffebld_cu_val_integer1 (u)), expr);
3465 break;
3466 #endif
3467
3468 #if FFETARGET_okINTEGER2
3469 case FFEINFO_kindtypeINTEGER2:
3470 error = ffetarget_multiply_integer2 (ffebld_cu_ptr_integer2 (u),
3471 ffebld_constant_integer2 (ffebld_conter (l)),
3472 ffebld_constant_integer2 (ffebld_conter (r)));
3473 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3474 (ffebld_cu_val_integer2 (u)), expr);
3475 break;
3476 #endif
3477
3478 #if FFETARGET_okINTEGER3
3479 case FFEINFO_kindtypeINTEGER3:
3480 error = ffetarget_multiply_integer3 (ffebld_cu_ptr_integer3 (u),
3481 ffebld_constant_integer3 (ffebld_conter (l)),
3482 ffebld_constant_integer3 (ffebld_conter (r)));
3483 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3484 (ffebld_cu_val_integer3 (u)), expr);
3485 break;
3486 #endif
3487
3488 #if FFETARGET_okINTEGER4
3489 case FFEINFO_kindtypeINTEGER4:
3490 error = ffetarget_multiply_integer4 (ffebld_cu_ptr_integer4 (u),
3491 ffebld_constant_integer4 (ffebld_conter (l)),
3492 ffebld_constant_integer4 (ffebld_conter (r)));
3493 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3494 (ffebld_cu_val_integer4 (u)), expr);
3495 break;
3496 #endif
3497
3498 default:
3499 assert ("bad integer kind type" == NULL);
3500 break;
3501 }
3502 break;
3503
3504 case FFEINFO_basictypeREAL:
3505 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3506 {
3507 #if FFETARGET_okREAL1
3508 case FFEINFO_kindtypeREAL1:
3509 error = ffetarget_multiply_real1 (ffebld_cu_ptr_real1 (u),
3510 ffebld_constant_real1 (ffebld_conter (l)),
3511 ffebld_constant_real1 (ffebld_conter (r)));
3512 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3513 (ffebld_cu_val_real1 (u)), expr);
3514 break;
3515 #endif
3516
3517 #if FFETARGET_okREAL2
3518 case FFEINFO_kindtypeREAL2:
3519 error = ffetarget_multiply_real2 (ffebld_cu_ptr_real2 (u),
3520 ffebld_constant_real2 (ffebld_conter (l)),
3521 ffebld_constant_real2 (ffebld_conter (r)));
3522 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3523 (ffebld_cu_val_real2 (u)), expr);
3524 break;
3525 #endif
3526
3527 #if FFETARGET_okREAL3
3528 case FFEINFO_kindtypeREAL3:
3529 error = ffetarget_multiply_real3 (ffebld_cu_ptr_real3 (u),
3530 ffebld_constant_real3 (ffebld_conter (l)),
3531 ffebld_constant_real3 (ffebld_conter (r)));
3532 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3533 (ffebld_cu_val_real3 (u)), expr);
3534 break;
3535 #endif
3536
3537 default:
3538 assert ("bad real kind type" == NULL);
3539 break;
3540 }
3541 break;
3542
3543 case FFEINFO_basictypeCOMPLEX:
3544 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3545 {
3546 #if FFETARGET_okCOMPLEX1
3547 case FFEINFO_kindtypeREAL1:
3548 error = ffetarget_multiply_complex1 (ffebld_cu_ptr_complex1 (u),
3549 ffebld_constant_complex1 (ffebld_conter (l)),
3550 ffebld_constant_complex1 (ffebld_conter (r)));
3551 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3552 (ffebld_cu_val_complex1 (u)), expr);
3553 break;
3554 #endif
3555
3556 #if FFETARGET_okCOMPLEX2
3557 case FFEINFO_kindtypeREAL2:
3558 error = ffetarget_multiply_complex2 (ffebld_cu_ptr_complex2 (u),
3559 ffebld_constant_complex2 (ffebld_conter (l)),
3560 ffebld_constant_complex2 (ffebld_conter (r)));
3561 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3562 (ffebld_cu_val_complex2 (u)), expr);
3563 break;
3564 #endif
3565
3566 #if FFETARGET_okCOMPLEX3
3567 case FFEINFO_kindtypeREAL3:
3568 error = ffetarget_multiply_complex3 (ffebld_cu_ptr_complex3 (u),
3569 ffebld_constant_complex3 (ffebld_conter (l)),
3570 ffebld_constant_complex3 (ffebld_conter (r)));
3571 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3572 (ffebld_cu_val_complex3 (u)), expr);
3573 break;
3574 #endif
3575
3576 default:
3577 assert ("bad complex kind type" == NULL);
3578 break;
3579 }
3580 break;
3581
3582 default:
3583 assert ("bad type" == NULL);
3584 return expr;
3585 }
3586
3587 ffebld_set_info (expr, ffeinfo_new
3588 (bt,
3589 kt,
3590 0,
3591 FFEINFO_kindENTITY,
3592 FFEINFO_whereCONSTANT,
3593 FFETARGET_charactersizeNONE));
3594
3595 if ((error != FFEBAD)
3596 && ffebad_start (error))
3597 {
3598 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3599 ffebad_finish ();
3600 }
3601
3602 return expr;
3603 }
3604
3605 /* ffeexpr_collapse_divide -- Collapse divide expr
3606
3607 ffebld expr;
3608 ffelexToken token;
3609 expr = ffeexpr_collapse_divide(expr,token);
3610
3611 If the result of the expr is a constant, replaces the expr with the
3612 computed constant. */
3613
3614 ffebld
3615 ffeexpr_collapse_divide (ffebld expr, ffelexToken t)
3616 {
3617 ffebad error = FFEBAD;
3618 ffebld l;
3619 ffebld r;
3620 ffebldConstantUnion u;
3621 ffeinfoBasictype bt;
3622 ffeinfoKindtype kt;
3623
3624 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3625 return expr;
3626
3627 l = ffebld_left (expr);
3628 r = ffebld_right (expr);
3629
3630 if (ffebld_op (l) != FFEBLD_opCONTER)
3631 return expr;
3632 if (ffebld_op (r) != FFEBLD_opCONTER)
3633 return expr;
3634
3635 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3636 {
3637 case FFEINFO_basictypeANY:
3638 return expr;
3639
3640 case FFEINFO_basictypeINTEGER:
3641 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3642 {
3643 #if FFETARGET_okINTEGER1
3644 case FFEINFO_kindtypeINTEGER1:
3645 error = ffetarget_divide_integer1 (ffebld_cu_ptr_integer1 (u),
3646 ffebld_constant_integer1 (ffebld_conter (l)),
3647 ffebld_constant_integer1 (ffebld_conter (r)));
3648 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3649 (ffebld_cu_val_integer1 (u)), expr);
3650 break;
3651 #endif
3652
3653 #if FFETARGET_okINTEGER2
3654 case FFEINFO_kindtypeINTEGER2:
3655 error = ffetarget_divide_integer2 (ffebld_cu_ptr_integer2 (u),
3656 ffebld_constant_integer2 (ffebld_conter (l)),
3657 ffebld_constant_integer2 (ffebld_conter (r)));
3658 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3659 (ffebld_cu_val_integer2 (u)), expr);
3660 break;
3661 #endif
3662
3663 #if FFETARGET_okINTEGER3
3664 case FFEINFO_kindtypeINTEGER3:
3665 error = ffetarget_divide_integer3 (ffebld_cu_ptr_integer3 (u),
3666 ffebld_constant_integer3 (ffebld_conter (l)),
3667 ffebld_constant_integer3 (ffebld_conter (r)));
3668 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3669 (ffebld_cu_val_integer3 (u)), expr);
3670 break;
3671 #endif
3672
3673 #if FFETARGET_okINTEGER4
3674 case FFEINFO_kindtypeINTEGER4:
3675 error = ffetarget_divide_integer4 (ffebld_cu_ptr_integer4 (u),
3676 ffebld_constant_integer4 (ffebld_conter (l)),
3677 ffebld_constant_integer4 (ffebld_conter (r)));
3678 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3679 (ffebld_cu_val_integer4 (u)), expr);
3680 break;
3681 #endif
3682
3683 default:
3684 assert ("bad integer kind type" == NULL);
3685 break;
3686 }
3687 break;
3688
3689 case FFEINFO_basictypeREAL:
3690 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3691 {
3692 #if FFETARGET_okREAL1
3693 case FFEINFO_kindtypeREAL1:
3694 error = ffetarget_divide_real1 (ffebld_cu_ptr_real1 (u),
3695 ffebld_constant_real1 (ffebld_conter (l)),
3696 ffebld_constant_real1 (ffebld_conter (r)));
3697 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3698 (ffebld_cu_val_real1 (u)), expr);
3699 break;
3700 #endif
3701
3702 #if FFETARGET_okREAL2
3703 case FFEINFO_kindtypeREAL2:
3704 error = ffetarget_divide_real2 (ffebld_cu_ptr_real2 (u),
3705 ffebld_constant_real2 (ffebld_conter (l)),
3706 ffebld_constant_real2 (ffebld_conter (r)));
3707 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3708 (ffebld_cu_val_real2 (u)), expr);
3709 break;
3710 #endif
3711
3712 #if FFETARGET_okREAL3
3713 case FFEINFO_kindtypeREAL3:
3714 error = ffetarget_divide_real3 (ffebld_cu_ptr_real3 (u),
3715 ffebld_constant_real3 (ffebld_conter (l)),
3716 ffebld_constant_real3 (ffebld_conter (r)));
3717 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3718 (ffebld_cu_val_real3 (u)), expr);
3719 break;
3720 #endif
3721
3722 default:
3723 assert ("bad real kind type" == NULL);
3724 break;
3725 }
3726 break;
3727
3728 case FFEINFO_basictypeCOMPLEX:
3729 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3730 {
3731 #if FFETARGET_okCOMPLEX1
3732 case FFEINFO_kindtypeREAL1:
3733 error = ffetarget_divide_complex1 (ffebld_cu_ptr_complex1 (u),
3734 ffebld_constant_complex1 (ffebld_conter (l)),
3735 ffebld_constant_complex1 (ffebld_conter (r)));
3736 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3737 (ffebld_cu_val_complex1 (u)), expr);
3738 break;
3739 #endif
3740
3741 #if FFETARGET_okCOMPLEX2
3742 case FFEINFO_kindtypeREAL2:
3743 error = ffetarget_divide_complex2 (ffebld_cu_ptr_complex2 (u),
3744 ffebld_constant_complex2 (ffebld_conter (l)),
3745 ffebld_constant_complex2 (ffebld_conter (r)));
3746 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3747 (ffebld_cu_val_complex2 (u)), expr);
3748 break;
3749 #endif
3750
3751 #if FFETARGET_okCOMPLEX3
3752 case FFEINFO_kindtypeREAL3:
3753 error = ffetarget_divide_complex3 (ffebld_cu_ptr_complex3 (u),
3754 ffebld_constant_complex3 (ffebld_conter (l)),
3755 ffebld_constant_complex3 (ffebld_conter (r)));
3756 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3757 (ffebld_cu_val_complex3 (u)), expr);
3758 break;
3759 #endif
3760
3761 default:
3762 assert ("bad complex kind type" == NULL);
3763 break;
3764 }
3765 break;
3766
3767 default:
3768 assert ("bad type" == NULL);
3769 return expr;
3770 }
3771
3772 ffebld_set_info (expr, ffeinfo_new
3773 (bt,
3774 kt,
3775 0,
3776 FFEINFO_kindENTITY,
3777 FFEINFO_whereCONSTANT,
3778 FFETARGET_charactersizeNONE));
3779
3780 if ((error != FFEBAD)
3781 && ffebad_start (error))
3782 {
3783 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3784 ffebad_finish ();
3785 }
3786
3787 return expr;
3788 }
3789
3790 /* ffeexpr_collapse_power -- Collapse power expr
3791
3792 ffebld expr;
3793 ffelexToken token;
3794 expr = ffeexpr_collapse_power(expr,token);
3795
3796 If the result of the expr is a constant, replaces the expr with the
3797 computed constant. */
3798
3799 ffebld
3800 ffeexpr_collapse_power (ffebld expr, ffelexToken t)
3801 {
3802 ffebad error = FFEBAD;
3803 ffebld l;
3804 ffebld r;
3805 ffebldConstantUnion u;
3806 ffeinfoBasictype bt;
3807 ffeinfoKindtype kt;
3808
3809 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3810 return expr;
3811
3812 l = ffebld_left (expr);
3813 r = ffebld_right (expr);
3814
3815 if (ffebld_op (l) != FFEBLD_opCONTER)
3816 return expr;
3817 if (ffebld_op (r) != FFEBLD_opCONTER)
3818 return expr;
3819
3820 if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER)
3821 || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT))
3822 return expr;
3823
3824 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3825 {
3826 case FFEINFO_basictypeANY:
3827 return expr;
3828
3829 case FFEINFO_basictypeINTEGER:
3830 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3831 {
3832 case FFEINFO_kindtypeINTEGERDEFAULT:
3833 error = ffetarget_power_integerdefault_integerdefault
3834 (ffebld_cu_ptr_integerdefault (u),
3835 ffebld_constant_integerdefault (ffebld_conter (l)),
3836 ffebld_constant_integerdefault (ffebld_conter (r)));
3837 expr = ffebld_new_conter_with_orig
3838 (ffebld_constant_new_integerdefault_val
3839 (ffebld_cu_val_integerdefault (u)), expr);
3840 break;
3841
3842 default:
3843 assert ("bad integer kind type" == NULL);
3844 break;
3845 }
3846 break;
3847
3848 case FFEINFO_basictypeREAL:
3849 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3850 {
3851 case FFEINFO_kindtypeREALDEFAULT:
3852 error = ffetarget_power_realdefault_integerdefault
3853 (ffebld_cu_ptr_realdefault (u),
3854 ffebld_constant_realdefault (ffebld_conter (l)),
3855 ffebld_constant_integerdefault (ffebld_conter (r)));
3856 expr = ffebld_new_conter_with_orig
3857 (ffebld_constant_new_realdefault_val
3858 (ffebld_cu_val_realdefault (u)), expr);
3859 break;
3860
3861 case FFEINFO_kindtypeREALDOUBLE:
3862 error = ffetarget_power_realdouble_integerdefault
3863 (ffebld_cu_ptr_realdouble (u),
3864 ffebld_constant_realdouble (ffebld_conter (l)),
3865 ffebld_constant_integerdefault (ffebld_conter (r)));
3866 expr = ffebld_new_conter_with_orig
3867 (ffebld_constant_new_realdouble_val
3868 (ffebld_cu_val_realdouble (u)), expr);
3869 break;
3870
3871 #if FFETARGET_okREALQUAD
3872 case FFEINFO_kindtypeREALQUAD:
3873 error = ffetarget_power_realquad_integerdefault
3874 (ffebld_cu_ptr_realquad (u),
3875 ffebld_constant_realquad (ffebld_conter (l)),
3876 ffebld_constant_integerdefault (ffebld_conter (r)));
3877 expr = ffebld_new_conter_with_orig
3878 (ffebld_constant_new_realquad_val
3879 (ffebld_cu_val_realquad (u)), expr);
3880 break;
3881 #endif
3882 default:
3883 assert ("bad real kind type" == NULL);
3884 break;
3885 }
3886 break;
3887
3888 case FFEINFO_basictypeCOMPLEX:
3889 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3890 {
3891 case FFEINFO_kindtypeREALDEFAULT:
3892 error = ffetarget_power_complexdefault_integerdefault
3893 (ffebld_cu_ptr_complexdefault (u),
3894 ffebld_constant_complexdefault (ffebld_conter (l)),
3895 ffebld_constant_integerdefault (ffebld_conter (r)));
3896 expr = ffebld_new_conter_with_orig
3897 (ffebld_constant_new_complexdefault_val
3898 (ffebld_cu_val_complexdefault (u)), expr);
3899 break;
3900
3901 #if FFETARGET_okCOMPLEXDOUBLE
3902 case FFEINFO_kindtypeREALDOUBLE:
3903 error = ffetarget_power_complexdouble_integerdefault
3904 (ffebld_cu_ptr_complexdouble (u),
3905 ffebld_constant_complexdouble (ffebld_conter (l)),
3906 ffebld_constant_integerdefault (ffebld_conter (r)));
3907 expr = ffebld_new_conter_with_orig
3908 (ffebld_constant_new_complexdouble_val
3909 (ffebld_cu_val_complexdouble (u)), expr);
3910 break;
3911 #endif
3912
3913 #if FFETARGET_okCOMPLEXQUAD
3914 case FFEINFO_kindtypeREALQUAD:
3915 error = ffetarget_power_complexquad_integerdefault
3916 (ffebld_cu_ptr_complexquad (u),
3917 ffebld_constant_complexquad (ffebld_conter (l)),
3918 ffebld_constant_integerdefault (ffebld_conter (r)));
3919 expr = ffebld_new_conter_with_orig
3920 (ffebld_constant_new_complexquad_val
3921 (ffebld_cu_val_complexquad (u)), expr);
3922 break;
3923 #endif
3924
3925 default:
3926 assert ("bad complex kind type" == NULL);
3927 break;
3928 }
3929 break;
3930
3931 default:
3932 assert ("bad type" == NULL);
3933 return expr;
3934 }
3935
3936 ffebld_set_info (expr, ffeinfo_new
3937 (bt,
3938 kt,
3939 0,
3940 FFEINFO_kindENTITY,
3941 FFEINFO_whereCONSTANT,
3942 FFETARGET_charactersizeNONE));
3943
3944 if ((error != FFEBAD)
3945 && ffebad_start (error))
3946 {
3947 ffebad_here (0, ffelex_token_where_line (t),
3948 ffelex_token_where_column (t));
3949 ffebad_finish ();
3950 }
3951
3952 return expr;
3953 }
3954
3955 /* ffeexpr_collapse_concatenate -- Collapse concatenate expr
3956
3957 ffebld expr;
3958 ffelexToken token;
3959 expr = ffeexpr_collapse_concatenate(expr,token);
3960
3961 If the result of the expr is a constant, replaces the expr with the
3962 computed constant. */
3963
3964 ffebld
3965 ffeexpr_collapse_concatenate (ffebld expr, ffelexToken t)
3966 {
3967 ffebad error = FFEBAD;
3968 ffebld l;
3969 ffebld r;
3970 ffebldConstantUnion u;
3971 ffeinfoKindtype kt;
3972 ffetargetCharacterSize len;
3973
3974 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3975 return expr;
3976
3977 l = ffebld_left (expr);
3978 r = ffebld_right (expr);
3979
3980 if (ffebld_op (l) != FFEBLD_opCONTER)
3981 return expr;
3982 if (ffebld_op (r) != FFEBLD_opCONTER)
3983 return expr;
3984
3985 switch (ffeinfo_basictype (ffebld_info (expr)))
3986 {
3987 case FFEINFO_basictypeANY:
3988 return expr;
3989
3990 case FFEINFO_basictypeCHARACTER:
3991 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3992 {
3993 #if FFETARGET_okCHARACTER1
3994 case FFEINFO_kindtypeCHARACTER1:
3995 error = ffetarget_concatenate_character1 (ffebld_cu_ptr_character1 (u),
3996 ffebld_constant_character1 (ffebld_conter (l)),
3997 ffebld_constant_character1 (ffebld_conter (r)),
3998 ffebld_constant_pool (), &len);
3999 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
4000 (ffebld_cu_val_character1 (u)), expr);
4001 break;
4002 #endif
4003
4004 default:
4005 assert ("bad character kind type" == NULL);
4006 break;
4007 }
4008 break;
4009
4010 default:
4011 assert ("bad type" == NULL);
4012 return expr;
4013 }
4014
4015 ffebld_set_info (expr, ffeinfo_new
4016 (FFEINFO_basictypeCHARACTER,
4017 kt,
4018 0,
4019 FFEINFO_kindENTITY,
4020 FFEINFO_whereCONSTANT,
4021 len));
4022
4023 if ((error != FFEBAD)
4024 && ffebad_start (error))
4025 {
4026 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4027 ffebad_finish ();
4028 }
4029
4030 return expr;
4031 }
4032
4033 /* ffeexpr_collapse_eq -- Collapse eq expr
4034
4035 ffebld expr;
4036 ffelexToken token;
4037 expr = ffeexpr_collapse_eq(expr,token);
4038
4039 If the result of the expr is a constant, replaces the expr with the
4040 computed constant. */
4041
4042 ffebld
4043 ffeexpr_collapse_eq (ffebld expr, ffelexToken t)
4044 {
4045 ffebad error = FFEBAD;
4046 ffebld l;
4047 ffebld r;
4048 bool val;
4049
4050 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4051 return expr;
4052
4053 l = ffebld_left (expr);
4054 r = ffebld_right (expr);
4055
4056 if (ffebld_op (l) != FFEBLD_opCONTER)
4057 return expr;
4058 if (ffebld_op (r) != FFEBLD_opCONTER)
4059 return expr;
4060
4061 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4062 {
4063 case FFEINFO_basictypeANY:
4064 return expr;
4065
4066 case FFEINFO_basictypeINTEGER:
4067 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4068 {
4069 #if FFETARGET_okINTEGER1
4070 case FFEINFO_kindtypeINTEGER1:
4071 error = ffetarget_eq_integer1 (&val,
4072 ffebld_constant_integer1 (ffebld_conter (l)),
4073 ffebld_constant_integer1 (ffebld_conter (r)));
4074 expr = ffebld_new_conter_with_orig
4075 (ffebld_constant_new_logicaldefault (val), expr);
4076 break;
4077 #endif
4078
4079 #if FFETARGET_okINTEGER2
4080 case FFEINFO_kindtypeINTEGER2:
4081 error = ffetarget_eq_integer2 (&val,
4082 ffebld_constant_integer2 (ffebld_conter (l)),
4083 ffebld_constant_integer2 (ffebld_conter (r)));
4084 expr = ffebld_new_conter_with_orig
4085 (ffebld_constant_new_logicaldefault (val), expr);
4086 break;
4087 #endif
4088
4089 #if FFETARGET_okINTEGER3
4090 case FFEINFO_kindtypeINTEGER3:
4091 error = ffetarget_eq_integer3 (&val,
4092 ffebld_constant_integer3 (ffebld_conter (l)),
4093 ffebld_constant_integer3 (ffebld_conter (r)));
4094 expr = ffebld_new_conter_with_orig
4095 (ffebld_constant_new_logicaldefault (val), expr);
4096 break;
4097 #endif
4098
4099 #if FFETARGET_okINTEGER4
4100 case FFEINFO_kindtypeINTEGER4:
4101 error = ffetarget_eq_integer4 (&val,
4102 ffebld_constant_integer4 (ffebld_conter (l)),
4103 ffebld_constant_integer4 (ffebld_conter (r)));
4104 expr = ffebld_new_conter_with_orig
4105 (ffebld_constant_new_logicaldefault (val), expr);
4106 break;
4107 #endif
4108
4109 default:
4110 assert ("bad integer kind type" == NULL);
4111 break;
4112 }
4113 break;
4114
4115 case FFEINFO_basictypeREAL:
4116 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4117 {
4118 #if FFETARGET_okREAL1
4119 case FFEINFO_kindtypeREAL1:
4120 error = ffetarget_eq_real1 (&val,
4121 ffebld_constant_real1 (ffebld_conter (l)),
4122 ffebld_constant_real1 (ffebld_conter (r)));
4123 expr = ffebld_new_conter_with_orig
4124 (ffebld_constant_new_logicaldefault (val), expr);
4125 break;
4126 #endif
4127
4128 #if FFETARGET_okREAL2
4129 case FFEINFO_kindtypeREAL2:
4130 error = ffetarget_eq_real2 (&val,
4131 ffebld_constant_real2 (ffebld_conter (l)),
4132 ffebld_constant_real2 (ffebld_conter (r)));
4133 expr = ffebld_new_conter_with_orig
4134 (ffebld_constant_new_logicaldefault (val), expr);
4135 break;
4136 #endif
4137
4138 #if FFETARGET_okREAL3
4139 case FFEINFO_kindtypeREAL3:
4140 error = ffetarget_eq_real3 (&val,
4141 ffebld_constant_real3 (ffebld_conter (l)),
4142 ffebld_constant_real3 (ffebld_conter (r)));
4143 expr = ffebld_new_conter_with_orig
4144 (ffebld_constant_new_logicaldefault (val), expr);
4145 break;
4146 #endif
4147
4148 default:
4149 assert ("bad real kind type" == NULL);
4150 break;
4151 }
4152 break;
4153
4154 case FFEINFO_basictypeCOMPLEX:
4155 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4156 {
4157 #if FFETARGET_okCOMPLEX1
4158 case FFEINFO_kindtypeREAL1:
4159 error = ffetarget_eq_complex1 (&val,
4160 ffebld_constant_complex1 (ffebld_conter (l)),
4161 ffebld_constant_complex1 (ffebld_conter (r)));
4162 expr = ffebld_new_conter_with_orig
4163 (ffebld_constant_new_logicaldefault (val), expr);
4164 break;
4165 #endif
4166
4167 #if FFETARGET_okCOMPLEX2
4168 case FFEINFO_kindtypeREAL2:
4169 error = ffetarget_eq_complex2 (&val,
4170 ffebld_constant_complex2 (ffebld_conter (l)),
4171 ffebld_constant_complex2 (ffebld_conter (r)));
4172 expr = ffebld_new_conter_with_orig
4173 (ffebld_constant_new_logicaldefault (val), expr);
4174 break;
4175 #endif
4176
4177 #if FFETARGET_okCOMPLEX3
4178 case FFEINFO_kindtypeREAL3:
4179 error = ffetarget_eq_complex3 (&val,
4180 ffebld_constant_complex3 (ffebld_conter (l)),
4181 ffebld_constant_complex3 (ffebld_conter (r)));
4182 expr = ffebld_new_conter_with_orig
4183 (ffebld_constant_new_logicaldefault (val), expr);
4184 break;
4185 #endif
4186
4187 default:
4188 assert ("bad complex kind type" == NULL);
4189 break;
4190 }
4191 break;
4192
4193 case FFEINFO_basictypeCHARACTER:
4194 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4195 {
4196 #if FFETARGET_okCHARACTER1
4197 case FFEINFO_kindtypeCHARACTER1:
4198 error = ffetarget_eq_character1 (&val,
4199 ffebld_constant_character1 (ffebld_conter (l)),
4200 ffebld_constant_character1 (ffebld_conter (r)));
4201 expr = ffebld_new_conter_with_orig
4202 (ffebld_constant_new_logicaldefault (val), expr);
4203 break;
4204 #endif
4205
4206 default:
4207 assert ("bad character kind type" == NULL);
4208 break;
4209 }
4210 break;
4211
4212 default:
4213 assert ("bad type" == NULL);
4214 return expr;
4215 }
4216
4217 ffebld_set_info (expr, ffeinfo_new
4218 (FFEINFO_basictypeLOGICAL,
4219 FFEINFO_kindtypeLOGICALDEFAULT,
4220 0,
4221 FFEINFO_kindENTITY,
4222 FFEINFO_whereCONSTANT,
4223 FFETARGET_charactersizeNONE));
4224
4225 if ((error != FFEBAD)
4226 && ffebad_start (error))
4227 {
4228 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4229 ffebad_finish ();
4230 }
4231
4232 return expr;
4233 }
4234
4235 /* ffeexpr_collapse_ne -- Collapse ne expr
4236
4237 ffebld expr;
4238 ffelexToken token;
4239 expr = ffeexpr_collapse_ne(expr,token);
4240
4241 If the result of the expr is a constant, replaces the expr with the
4242 computed constant. */
4243
4244 ffebld
4245 ffeexpr_collapse_ne (ffebld expr, ffelexToken t)
4246 {
4247 ffebad error = FFEBAD;
4248 ffebld l;
4249 ffebld r;
4250 bool val;
4251
4252 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4253 return expr;
4254
4255 l = ffebld_left (expr);
4256 r = ffebld_right (expr);
4257
4258 if (ffebld_op (l) != FFEBLD_opCONTER)
4259 return expr;
4260 if (ffebld_op (r) != FFEBLD_opCONTER)
4261 return expr;
4262
4263 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4264 {
4265 case FFEINFO_basictypeANY:
4266 return expr;
4267
4268 case FFEINFO_basictypeINTEGER:
4269 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4270 {
4271 #if FFETARGET_okINTEGER1
4272 case FFEINFO_kindtypeINTEGER1:
4273 error = ffetarget_ne_integer1 (&val,
4274 ffebld_constant_integer1 (ffebld_conter (l)),
4275 ffebld_constant_integer1 (ffebld_conter (r)));
4276 expr = ffebld_new_conter_with_orig
4277 (ffebld_constant_new_logicaldefault (val), expr);
4278 break;
4279 #endif
4280
4281 #if FFETARGET_okINTEGER2
4282 case FFEINFO_kindtypeINTEGER2:
4283 error = ffetarget_ne_integer2 (&val,
4284 ffebld_constant_integer2 (ffebld_conter (l)),
4285 ffebld_constant_integer2 (ffebld_conter (r)));
4286 expr = ffebld_new_conter_with_orig
4287 (ffebld_constant_new_logicaldefault (val), expr);
4288 break;
4289 #endif
4290
4291 #if FFETARGET_okINTEGER3
4292 case FFEINFO_kindtypeINTEGER3:
4293 error = ffetarget_ne_integer3 (&val,
4294 ffebld_constant_integer3 (ffebld_conter (l)),
4295 ffebld_constant_integer3 (ffebld_conter (r)));
4296 expr = ffebld_new_conter_with_orig
4297 (ffebld_constant_new_logicaldefault (val), expr);
4298 break;
4299 #endif
4300
4301 #if FFETARGET_okINTEGER4
4302 case FFEINFO_kindtypeINTEGER4:
4303 error = ffetarget_ne_integer4 (&val,
4304 ffebld_constant_integer4 (ffebld_conter (l)),
4305 ffebld_constant_integer4 (ffebld_conter (r)));
4306 expr = ffebld_new_conter_with_orig
4307 (ffebld_constant_new_logicaldefault (val), expr);
4308 break;
4309 #endif
4310
4311 default:
4312 assert ("bad integer kind type" == NULL);
4313 break;
4314 }
4315 break;
4316
4317 case FFEINFO_basictypeREAL:
4318 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4319 {
4320 #if FFETARGET_okREAL1
4321 case FFEINFO_kindtypeREAL1:
4322 error = ffetarget_ne_real1 (&val,
4323 ffebld_constant_real1 (ffebld_conter (l)),
4324 ffebld_constant_real1 (ffebld_conter (r)));
4325 expr = ffebld_new_conter_with_orig
4326 (ffebld_constant_new_logicaldefault (val), expr);
4327 break;
4328 #endif
4329
4330 #if FFETARGET_okREAL2
4331 case FFEINFO_kindtypeREAL2:
4332 error = ffetarget_ne_real2 (&val,
4333 ffebld_constant_real2 (ffebld_conter (l)),
4334 ffebld_constant_real2 (ffebld_conter (r)));
4335 expr = ffebld_new_conter_with_orig
4336 (ffebld_constant_new_logicaldefault (val), expr);
4337 break;
4338 #endif
4339
4340 #if FFETARGET_okREAL3
4341 case FFEINFO_kindtypeREAL3:
4342 error = ffetarget_ne_real3 (&val,
4343 ffebld_constant_real3 (ffebld_conter (l)),
4344 ffebld_constant_real3 (ffebld_conter (r)));
4345 expr = ffebld_new_conter_with_orig
4346 (ffebld_constant_new_logicaldefault (val), expr);
4347 break;
4348 #endif
4349
4350 default:
4351 assert ("bad real kind type" == NULL);
4352 break;
4353 }
4354 break;
4355
4356 case FFEINFO_basictypeCOMPLEX:
4357 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4358 {
4359 #if FFETARGET_okCOMPLEX1
4360 case FFEINFO_kindtypeREAL1:
4361 error = ffetarget_ne_complex1 (&val,
4362 ffebld_constant_complex1 (ffebld_conter (l)),
4363 ffebld_constant_complex1 (ffebld_conter (r)));
4364 expr = ffebld_new_conter_with_orig
4365 (ffebld_constant_new_logicaldefault (val), expr);
4366 break;
4367 #endif
4368
4369 #if FFETARGET_okCOMPLEX2
4370 case FFEINFO_kindtypeREAL2:
4371 error = ffetarget_ne_complex2 (&val,
4372 ffebld_constant_complex2 (ffebld_conter (l)),
4373 ffebld_constant_complex2 (ffebld_conter (r)));
4374 expr = ffebld_new_conter_with_orig
4375 (ffebld_constant_new_logicaldefault (val), expr);
4376 break;
4377 #endif
4378
4379 #if FFETARGET_okCOMPLEX3
4380 case FFEINFO_kindtypeREAL3:
4381 error = ffetarget_ne_complex3 (&val,
4382 ffebld_constant_complex3 (ffebld_conter (l)),
4383 ffebld_constant_complex3 (ffebld_conter (r)));
4384 expr = ffebld_new_conter_with_orig
4385 (ffebld_constant_new_logicaldefault (val), expr);
4386 break;
4387 #endif
4388
4389 default:
4390 assert ("bad complex kind type" == NULL);
4391 break;
4392 }
4393 break;
4394
4395 case FFEINFO_basictypeCHARACTER:
4396 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4397 {
4398 #if FFETARGET_okCHARACTER1
4399 case FFEINFO_kindtypeCHARACTER1:
4400 error = ffetarget_ne_character1 (&val,
4401 ffebld_constant_character1 (ffebld_conter (l)),
4402 ffebld_constant_character1 (ffebld_conter (r)));
4403 expr = ffebld_new_conter_with_orig
4404 (ffebld_constant_new_logicaldefault (val), expr);
4405 break;
4406 #endif
4407
4408 default:
4409 assert ("bad character kind type" == NULL);
4410 break;
4411 }
4412 break;
4413
4414 default:
4415 assert ("bad type" == NULL);
4416 return expr;
4417 }
4418
4419 ffebld_set_info (expr, ffeinfo_new
4420 (FFEINFO_basictypeLOGICAL,
4421 FFEINFO_kindtypeLOGICALDEFAULT,
4422 0,
4423 FFEINFO_kindENTITY,
4424 FFEINFO_whereCONSTANT,
4425 FFETARGET_charactersizeNONE));
4426
4427 if ((error != FFEBAD)
4428 && ffebad_start (error))
4429 {
4430 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4431 ffebad_finish ();
4432 }
4433
4434 return expr;
4435 }
4436
4437 /* ffeexpr_collapse_ge -- Collapse ge expr
4438
4439 ffebld expr;
4440 ffelexToken token;
4441 expr = ffeexpr_collapse_ge(expr,token);
4442
4443 If the result of the expr is a constant, replaces the expr with the
4444 computed constant. */
4445
4446 ffebld
4447 ffeexpr_collapse_ge (ffebld expr, ffelexToken t)
4448 {
4449 ffebad error = FFEBAD;
4450 ffebld l;
4451 ffebld r;
4452 bool val;
4453
4454 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4455 return expr;
4456
4457 l = ffebld_left (expr);
4458 r = ffebld_right (expr);
4459
4460 if (ffebld_op (l) != FFEBLD_opCONTER)
4461 return expr;
4462 if (ffebld_op (r) != FFEBLD_opCONTER)
4463 return expr;
4464
4465 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4466 {
4467 case FFEINFO_basictypeANY:
4468 return expr;
4469
4470 case FFEINFO_basictypeINTEGER:
4471 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4472 {
4473 #if FFETARGET_okINTEGER1
4474 case FFEINFO_kindtypeINTEGER1:
4475 error = ffetarget_ge_integer1 (&val,
4476 ffebld_constant_integer1 (ffebld_conter (l)),
4477 ffebld_constant_integer1 (ffebld_conter (r)));
4478 expr = ffebld_new_conter_with_orig
4479 (ffebld_constant_new_logicaldefault (val), expr);
4480 break;
4481 #endif
4482
4483 #if FFETARGET_okINTEGER2
4484 case FFEINFO_kindtypeINTEGER2:
4485 error = ffetarget_ge_integer2 (&val,
4486 ffebld_constant_integer2 (ffebld_conter (l)),
4487 ffebld_constant_integer2 (ffebld_conter (r)));
4488 expr = ffebld_new_conter_with_orig
4489 (ffebld_constant_new_logicaldefault (val), expr);
4490 break;
4491 #endif
4492
4493 #if FFETARGET_okINTEGER3
4494 case FFEINFO_kindtypeINTEGER3:
4495 error = ffetarget_ge_integer3 (&val,
4496 ffebld_constant_integer3 (ffebld_conter (l)),
4497 ffebld_constant_integer3 (ffebld_conter (r)));
4498 expr = ffebld_new_conter_with_orig
4499 (ffebld_constant_new_logicaldefault (val), expr);
4500 break;
4501 #endif
4502
4503 #if FFETARGET_okINTEGER4
4504 case FFEINFO_kindtypeINTEGER4:
4505 error = ffetarget_ge_integer4 (&val,
4506 ffebld_constant_integer4 (ffebld_conter (l)),
4507 ffebld_constant_integer4 (ffebld_conter (r)));
4508 expr = ffebld_new_conter_with_orig
4509 (ffebld_constant_new_logicaldefault (val), expr);
4510 break;
4511 #endif
4512
4513 default:
4514 assert ("bad integer kind type" == NULL);
4515 break;
4516 }
4517 break;
4518
4519 case FFEINFO_basictypeREAL:
4520 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4521 {
4522 #if FFETARGET_okREAL1
4523 case FFEINFO_kindtypeREAL1:
4524 error = ffetarget_ge_real1 (&val,
4525 ffebld_constant_real1 (ffebld_conter (l)),
4526 ffebld_constant_real1 (ffebld_conter (r)));
4527 expr = ffebld_new_conter_with_orig
4528 (ffebld_constant_new_logicaldefault (val), expr);
4529 break;
4530 #endif
4531
4532 #if FFETARGET_okREAL2
4533 case FFEINFO_kindtypeREAL2:
4534 error = ffetarget_ge_real2 (&val,
4535 ffebld_constant_real2 (ffebld_conter (l)),
4536 ffebld_constant_real2 (ffebld_conter (r)));
4537 expr = ffebld_new_conter_with_orig
4538 (ffebld_constant_new_logicaldefault (val), expr);
4539 break;
4540 #endif
4541
4542 #if FFETARGET_okREAL3
4543 case FFEINFO_kindtypeREAL3:
4544 error = ffetarget_ge_real3 (&val,
4545 ffebld_constant_real3 (ffebld_conter (l)),
4546 ffebld_constant_real3 (ffebld_conter (r)));
4547 expr = ffebld_new_conter_with_orig
4548 (ffebld_constant_new_logicaldefault (val), expr);
4549 break;
4550 #endif
4551
4552 default:
4553 assert ("bad real kind type" == NULL);
4554 break;
4555 }
4556 break;
4557
4558 case FFEINFO_basictypeCHARACTER:
4559 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4560 {
4561 #if FFETARGET_okCHARACTER1
4562 case FFEINFO_kindtypeCHARACTER1:
4563 error = ffetarget_ge_character1 (&val,
4564 ffebld_constant_character1 (ffebld_conter (l)),
4565 ffebld_constant_character1 (ffebld_conter (r)));
4566 expr = ffebld_new_conter_with_orig
4567 (ffebld_constant_new_logicaldefault (val), expr);
4568 break;
4569 #endif
4570
4571 default:
4572 assert ("bad character kind type" == NULL);
4573 break;
4574 }
4575 break;
4576
4577 default:
4578 assert ("bad type" == NULL);
4579 return expr;
4580 }
4581
4582 ffebld_set_info (expr, ffeinfo_new
4583 (FFEINFO_basictypeLOGICAL,
4584 FFEINFO_kindtypeLOGICALDEFAULT,
4585 0,
4586 FFEINFO_kindENTITY,
4587 FFEINFO_whereCONSTANT,
4588 FFETARGET_charactersizeNONE));
4589
4590 if ((error != FFEBAD)
4591 && ffebad_start (error))
4592 {
4593 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4594 ffebad_finish ();
4595 }
4596
4597 return expr;
4598 }
4599
4600 /* ffeexpr_collapse_gt -- Collapse gt expr
4601
4602 ffebld expr;
4603 ffelexToken token;
4604 expr = ffeexpr_collapse_gt(expr,token);
4605
4606 If the result of the expr is a constant, replaces the expr with the
4607 computed constant. */
4608
4609 ffebld
4610 ffeexpr_collapse_gt (ffebld expr, ffelexToken t)
4611 {
4612 ffebad error = FFEBAD;
4613 ffebld l;
4614 ffebld r;
4615 bool val;
4616
4617 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4618 return expr;
4619
4620 l = ffebld_left (expr);
4621 r = ffebld_right (expr);
4622
4623 if (ffebld_op (l) != FFEBLD_opCONTER)
4624 return expr;
4625 if (ffebld_op (r) != FFEBLD_opCONTER)
4626 return expr;
4627
4628 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4629 {
4630 case FFEINFO_basictypeANY:
4631 return expr;
4632
4633 case FFEINFO_basictypeINTEGER:
4634 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4635 {
4636 #if FFETARGET_okINTEGER1
4637 case FFEINFO_kindtypeINTEGER1:
4638 error = ffetarget_gt_integer1 (&val,
4639 ffebld_constant_integer1 (ffebld_conter (l)),
4640 ffebld_constant_integer1 (ffebld_conter (r)));
4641 expr = ffebld_new_conter_with_orig
4642 (ffebld_constant_new_logicaldefault (val), expr);
4643 break;
4644 #endif
4645
4646 #if FFETARGET_okINTEGER2
4647 case FFEINFO_kindtypeINTEGER2:
4648 error = ffetarget_gt_integer2 (&val,
4649 ffebld_constant_integer2 (ffebld_conter (l)),
4650 ffebld_constant_integer2 (ffebld_conter (r)));
4651 expr = ffebld_new_conter_with_orig
4652 (ffebld_constant_new_logicaldefault (val), expr);
4653 break;
4654 #endif
4655
4656 #if FFETARGET_okINTEGER3
4657 case FFEINFO_kindtypeINTEGER3:
4658 error = ffetarget_gt_integer3 (&val,
4659 ffebld_constant_integer3 (ffebld_conter (l)),
4660 ffebld_constant_integer3 (ffebld_conter (r)));
4661 expr = ffebld_new_conter_with_orig
4662 (ffebld_constant_new_logicaldefault (val), expr);
4663 break;
4664 #endif
4665
4666 #if FFETARGET_okINTEGER4
4667 case FFEINFO_kindtypeINTEGER4:
4668 error = ffetarget_gt_integer4 (&val,
4669 ffebld_constant_integer4 (ffebld_conter (l)),
4670 ffebld_constant_integer4 (ffebld_conter (r)));
4671 expr = ffebld_new_conter_with_orig
4672 (ffebld_constant_new_logicaldefault (val), expr);
4673 break;
4674 #endif
4675
4676 default:
4677 assert ("bad integer kind type" == NULL);
4678 break;
4679 }
4680 break;
4681
4682 case FFEINFO_basictypeREAL:
4683 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4684 {
4685 #if FFETARGET_okREAL1
4686 case FFEINFO_kindtypeREAL1:
4687 error = ffetarget_gt_real1 (&val,
4688 ffebld_constant_real1 (ffebld_conter (l)),
4689 ffebld_constant_real1 (ffebld_conter (r)));
4690 expr = ffebld_new_conter_with_orig
4691 (ffebld_constant_new_logicaldefault (val), expr);
4692 break;
4693 #endif
4694
4695 #if FFETARGET_okREAL2
4696 case FFEINFO_kindtypeREAL2:
4697 error = ffetarget_gt_real2 (&val,
4698 ffebld_constant_real2 (ffebld_conter (l)),
4699 ffebld_constant_real2 (ffebld_conter (r)));
4700 expr = ffebld_new_conter_with_orig
4701 (ffebld_constant_new_logicaldefault (val), expr);
4702 break;
4703 #endif
4704
4705 #if FFETARGET_okREAL3
4706 case FFEINFO_kindtypeREAL3:
4707 error = ffetarget_gt_real3 (&val,
4708 ffebld_constant_real3 (ffebld_conter (l)),
4709 ffebld_constant_real3 (ffebld_conter (r)));
4710 expr = ffebld_new_conter_with_orig
4711 (ffebld_constant_new_logicaldefault (val), expr);
4712 break;
4713 #endif
4714
4715 default:
4716 assert ("bad real kind type" == NULL);
4717 break;
4718 }
4719 break;
4720
4721 case FFEINFO_basictypeCHARACTER:
4722 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4723 {
4724 #if FFETARGET_okCHARACTER1
4725 case FFEINFO_kindtypeCHARACTER1:
4726 error = ffetarget_gt_character1 (&val,
4727 ffebld_constant_character1 (ffebld_conter (l)),
4728 ffebld_constant_character1 (ffebld_conter (r)));
4729 expr = ffebld_new_conter_with_orig
4730 (ffebld_constant_new_logicaldefault (val), expr);
4731 break;
4732 #endif
4733
4734 default:
4735 assert ("bad character kind type" == NULL);
4736 break;
4737 }
4738 break;
4739
4740 default:
4741 assert ("bad type" == NULL);
4742 return expr;
4743 }
4744
4745 ffebld_set_info (expr, ffeinfo_new
4746 (FFEINFO_basictypeLOGICAL,
4747 FFEINFO_kindtypeLOGICALDEFAULT,
4748 0,
4749 FFEINFO_kindENTITY,
4750 FFEINFO_whereCONSTANT,
4751 FFETARGET_charactersizeNONE));
4752
4753 if ((error != FFEBAD)
4754 && ffebad_start (error))
4755 {
4756 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4757 ffebad_finish ();
4758 }
4759
4760 return expr;
4761 }
4762
4763 /* ffeexpr_collapse_le -- Collapse le expr
4764
4765 ffebld expr;
4766 ffelexToken token;
4767 expr = ffeexpr_collapse_le(expr,token);
4768
4769 If the result of the expr is a constant, replaces the expr with the
4770 computed constant. */
4771
4772 ffebld
4773 ffeexpr_collapse_le (ffebld expr, ffelexToken t)
4774 {
4775 ffebad error = FFEBAD;
4776 ffebld l;
4777 ffebld r;
4778 bool val;
4779
4780 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4781 return expr;
4782
4783 l = ffebld_left (expr);
4784 r = ffebld_right (expr);
4785
4786 if (ffebld_op (l) != FFEBLD_opCONTER)
4787 return expr;
4788 if (ffebld_op (r) != FFEBLD_opCONTER)
4789 return expr;
4790
4791 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4792 {
4793 case FFEINFO_basictypeANY:
4794 return expr;
4795
4796 case FFEINFO_basictypeINTEGER:
4797 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4798 {
4799 #if FFETARGET_okINTEGER1
4800 case FFEINFO_kindtypeINTEGER1:
4801 error = ffetarget_le_integer1 (&val,
4802 ffebld_constant_integer1 (ffebld_conter (l)),
4803 ffebld_constant_integer1 (ffebld_conter (r)));
4804 expr = ffebld_new_conter_with_orig
4805 (ffebld_constant_new_logicaldefault (val), expr);
4806 break;
4807 #endif
4808
4809 #if FFETARGET_okINTEGER2
4810 case FFEINFO_kindtypeINTEGER2:
4811 error = ffetarget_le_integer2 (&val,
4812 ffebld_constant_integer2 (ffebld_conter (l)),
4813 ffebld_constant_integer2 (ffebld_conter (r)));
4814 expr = ffebld_new_conter_with_orig
4815 (ffebld_constant_new_logicaldefault (val), expr);
4816 break;
4817 #endif
4818
4819 #if FFETARGET_okINTEGER3
4820 case FFEINFO_kindtypeINTEGER3:
4821 error = ffetarget_le_integer3 (&val,
4822 ffebld_constant_integer3 (ffebld_conter (l)),
4823 ffebld_constant_integer3 (ffebld_conter (r)));
4824 expr = ffebld_new_conter_with_orig
4825 (ffebld_constant_new_logicaldefault (val), expr);
4826 break;
4827 #endif
4828
4829 #if FFETARGET_okINTEGER4
4830 case FFEINFO_kindtypeINTEGER4:
4831 error = ffetarget_le_integer4 (&val,
4832 ffebld_constant_integer4 (ffebld_conter (l)),
4833 ffebld_constant_integer4 (ffebld_conter (r)));
4834 expr = ffebld_new_conter_with_orig
4835 (ffebld_constant_new_logicaldefault (val), expr);
4836 break;
4837 #endif
4838
4839 default:
4840 assert ("bad integer kind type" == NULL);
4841 break;
4842 }
4843 break;
4844
4845 case FFEINFO_basictypeREAL:
4846 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4847 {
4848 #if FFETARGET_okREAL1
4849 case FFEINFO_kindtypeREAL1:
4850 error = ffetarget_le_real1 (&val,
4851 ffebld_constant_real1 (ffebld_conter (l)),
4852 ffebld_constant_real1 (ffebld_conter (r)));
4853 expr = ffebld_new_conter_with_orig
4854 (ffebld_constant_new_logicaldefault (val), expr);
4855 break;
4856 #endif
4857
4858 #if FFETARGET_okREAL2
4859 case FFEINFO_kindtypeREAL2:
4860 error = ffetarget_le_real2 (&val,
4861 ffebld_constant_real2 (ffebld_conter (l)),
4862 ffebld_constant_real2 (ffebld_conter (r)));
4863 expr = ffebld_new_conter_with_orig
4864 (ffebld_constant_new_logicaldefault (val), expr);
4865 break;
4866 #endif
4867
4868 #if FFETARGET_okREAL3
4869 case FFEINFO_kindtypeREAL3:
4870 error = ffetarget_le_real3 (&val,
4871 ffebld_constant_real3 (ffebld_conter (l)),
4872 ffebld_constant_real3 (ffebld_conter (r)));
4873 expr = ffebld_new_conter_with_orig
4874 (ffebld_constant_new_logicaldefault (val), expr);
4875 break;
4876 #endif
4877
4878 default:
4879 assert ("bad real kind type" == NULL);
4880 break;
4881 }
4882 break;
4883
4884 case FFEINFO_basictypeCHARACTER:
4885 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4886 {
4887 #if FFETARGET_okCHARACTER1
4888 case FFEINFO_kindtypeCHARACTER1:
4889 error = ffetarget_le_character1 (&val,
4890 ffebld_constant_character1 (ffebld_conter (l)),
4891 ffebld_constant_character1 (ffebld_conter (r)));
4892 expr = ffebld_new_conter_with_orig
4893 (ffebld_constant_new_logicaldefault (val), expr);
4894 break;
4895 #endif
4896
4897 default:
4898 assert ("bad character kind type" == NULL);
4899 break;
4900 }
4901 break;
4902
4903 default:
4904 assert ("bad type" == NULL);
4905 return expr;
4906 }
4907
4908 ffebld_set_info (expr, ffeinfo_new
4909 (FFEINFO_basictypeLOGICAL,
4910 FFEINFO_kindtypeLOGICALDEFAULT,
4911 0,
4912 FFEINFO_kindENTITY,
4913 FFEINFO_whereCONSTANT,
4914 FFETARGET_charactersizeNONE));
4915
4916 if ((error != FFEBAD)
4917 && ffebad_start (error))
4918 {
4919 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4920 ffebad_finish ();
4921 }
4922
4923 return expr;
4924 }
4925
4926 /* ffeexpr_collapse_lt -- Collapse lt expr
4927
4928 ffebld expr;
4929 ffelexToken token;
4930 expr = ffeexpr_collapse_lt(expr,token);
4931
4932 If the result of the expr is a constant, replaces the expr with the
4933 computed constant. */
4934
4935 ffebld
4936 ffeexpr_collapse_lt (ffebld expr, ffelexToken t)
4937 {
4938 ffebad error = FFEBAD;
4939 ffebld l;
4940 ffebld r;
4941 bool val;
4942
4943 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4944 return expr;
4945
4946 l = ffebld_left (expr);
4947 r = ffebld_right (expr);
4948
4949 if (ffebld_op (l) != FFEBLD_opCONTER)
4950 return expr;
4951 if (ffebld_op (r) != FFEBLD_opCONTER)
4952 return expr;
4953
4954 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4955 {
4956 case FFEINFO_basictypeANY:
4957 return expr;
4958
4959 case FFEINFO_basictypeINTEGER:
4960 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4961 {
4962 #if FFETARGET_okINTEGER1
4963 case FFEINFO_kindtypeINTEGER1:
4964 error = ffetarget_lt_integer1 (&val,
4965 ffebld_constant_integer1 (ffebld_conter (l)),
4966 ffebld_constant_integer1 (ffebld_conter (r)));
4967 expr = ffebld_new_conter_with_orig
4968 (ffebld_constant_new_logicaldefault (val), expr);
4969 break;
4970 #endif
4971
4972 #if FFETARGET_okINTEGER2
4973 case FFEINFO_kindtypeINTEGER2:
4974 error = ffetarget_lt_integer2 (&val,
4975 ffebld_constant_integer2 (ffebld_conter (l)),
4976 ffebld_constant_integer2 (ffebld_conter (r)));
4977 expr = ffebld_new_conter_with_orig
4978 (ffebld_constant_new_logicaldefault (val), expr);
4979 break;
4980 #endif
4981
4982 #if FFETARGET_okINTEGER3
4983 case FFEINFO_kindtypeINTEGER3:
4984 error = ffetarget_lt_integer3 (&val,
4985 ffebld_constant_integer3 (ffebld_conter (l)),
4986 ffebld_constant_integer3 (ffebld_conter (r)));
4987 expr = ffebld_new_conter_with_orig
4988 (ffebld_constant_new_logicaldefault (val), expr);
4989 break;
4990 #endif
4991
4992 #if FFETARGET_okINTEGER4
4993 case FFEINFO_kindtypeINTEGER4:
4994 error = ffetarget_lt_integer4 (&val,
4995 ffebld_constant_integer4 (ffebld_conter (l)),
4996 ffebld_constant_integer4 (ffebld_conter (r)));
4997 expr = ffebld_new_conter_with_orig
4998 (ffebld_constant_new_logicaldefault (val), expr);
4999 break;
5000 #endif
5001
5002 default:
5003 assert ("bad integer kind type" == NULL);
5004 break;
5005 }
5006 break;
5007
5008 case FFEINFO_basictypeREAL:
5009 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5010 {
5011 #if FFETARGET_okREAL1
5012 case FFEINFO_kindtypeREAL1:
5013 error = ffetarget_lt_real1 (&val,
5014 ffebld_constant_real1 (ffebld_conter (l)),
5015 ffebld_constant_real1 (ffebld_conter (r)));
5016 expr = ffebld_new_conter_with_orig
5017 (ffebld_constant_new_logicaldefault (val), expr);
5018 break;
5019 #endif
5020
5021 #if FFETARGET_okREAL2
5022 case FFEINFO_kindtypeREAL2:
5023 error = ffetarget_lt_real2 (&val,
5024 ffebld_constant_real2 (ffebld_conter (l)),
5025 ffebld_constant_real2 (ffebld_conter (r)));
5026 expr = ffebld_new_conter_with_orig
5027 (ffebld_constant_new_logicaldefault (val), expr);
5028 break;
5029 #endif
5030
5031 #if FFETARGET_okREAL3
5032 case FFEINFO_kindtypeREAL3:
5033 error = ffetarget_lt_real3 (&val,
5034 ffebld_constant_real3 (ffebld_conter (l)),
5035 ffebld_constant_real3 (ffebld_conter (r)));
5036 expr = ffebld_new_conter_with_orig
5037 (ffebld_constant_new_logicaldefault (val), expr);
5038 break;
5039 #endif
5040
5041 default:
5042 assert ("bad real kind type" == NULL);
5043 break;
5044 }
5045 break;
5046
5047 case FFEINFO_basictypeCHARACTER:
5048 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5049 {
5050 #if FFETARGET_okCHARACTER1
5051 case FFEINFO_kindtypeCHARACTER1:
5052 error = ffetarget_lt_character1 (&val,
5053 ffebld_constant_character1 (ffebld_conter (l)),
5054 ffebld_constant_character1 (ffebld_conter (r)));
5055 expr = ffebld_new_conter_with_orig
5056 (ffebld_constant_new_logicaldefault (val), expr);
5057 break;
5058 #endif
5059
5060 default:
5061 assert ("bad character kind type" == NULL);
5062 break;
5063 }
5064 break;
5065
5066 default:
5067 assert ("bad type" == NULL);
5068 return expr;
5069 }
5070
5071 ffebld_set_info (expr, ffeinfo_new
5072 (FFEINFO_basictypeLOGICAL,
5073 FFEINFO_kindtypeLOGICALDEFAULT,
5074 0,
5075 FFEINFO_kindENTITY,
5076 FFEINFO_whereCONSTANT,
5077 FFETARGET_charactersizeNONE));
5078
5079 if ((error != FFEBAD)
5080 && ffebad_start (error))
5081 {
5082 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5083 ffebad_finish ();
5084 }
5085
5086 return expr;
5087 }
5088
5089 /* ffeexpr_collapse_and -- Collapse and expr
5090
5091 ffebld expr;
5092 ffelexToken token;
5093 expr = ffeexpr_collapse_and(expr,token);
5094
5095 If the result of the expr is a constant, replaces the expr with the
5096 computed constant. */
5097
5098 ffebld
5099 ffeexpr_collapse_and (ffebld expr, ffelexToken t)
5100 {
5101 ffebad error = FFEBAD;
5102 ffebld l;
5103 ffebld r;
5104 ffebldConstantUnion u;
5105 ffeinfoBasictype bt;
5106 ffeinfoKindtype kt;
5107
5108 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5109 return expr;
5110
5111 l = ffebld_left (expr);
5112 r = ffebld_right (expr);
5113
5114 if (ffebld_op (l) != FFEBLD_opCONTER)
5115 return expr;
5116 if (ffebld_op (r) != FFEBLD_opCONTER)
5117 return expr;
5118
5119 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5120 {
5121 case FFEINFO_basictypeANY:
5122 return expr;
5123
5124 case FFEINFO_basictypeINTEGER:
5125 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5126 {
5127 #if FFETARGET_okINTEGER1
5128 case FFEINFO_kindtypeINTEGER1:
5129 error = ffetarget_and_integer1 (ffebld_cu_ptr_integer1 (u),
5130 ffebld_constant_integer1 (ffebld_conter (l)),
5131 ffebld_constant_integer1 (ffebld_conter (r)));
5132 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5133 (ffebld_cu_val_integer1 (u)), expr);
5134 break;
5135 #endif
5136
5137 #if FFETARGET_okINTEGER2
5138 case FFEINFO_kindtypeINTEGER2:
5139 error = ffetarget_and_integer2 (ffebld_cu_ptr_integer2 (u),
5140 ffebld_constant_integer2 (ffebld_conter (l)),
5141 ffebld_constant_integer2 (ffebld_conter (r)));
5142 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5143 (ffebld_cu_val_integer2 (u)), expr);
5144 break;
5145 #endif
5146
5147 #if FFETARGET_okINTEGER3
5148 case FFEINFO_kindtypeINTEGER3:
5149 error = ffetarget_and_integer3 (ffebld_cu_ptr_integer3 (u),
5150 ffebld_constant_integer3 (ffebld_conter (l)),
5151 ffebld_constant_integer3 (ffebld_conter (r)));
5152 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5153 (ffebld_cu_val_integer3 (u)), expr);
5154 break;
5155 #endif
5156
5157 #if FFETARGET_okINTEGER4
5158 case FFEINFO_kindtypeINTEGER4:
5159 error = ffetarget_and_integer4 (ffebld_cu_ptr_integer4 (u),
5160 ffebld_constant_integer4 (ffebld_conter (l)),
5161 ffebld_constant_integer4 (ffebld_conter (r)));
5162 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5163 (ffebld_cu_val_integer4 (u)), expr);
5164 break;
5165 #endif
5166
5167 default:
5168 assert ("bad integer kind type" == NULL);
5169 break;
5170 }
5171 break;
5172
5173 case FFEINFO_basictypeLOGICAL:
5174 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5175 {
5176 #if FFETARGET_okLOGICAL1
5177 case FFEINFO_kindtypeLOGICAL1:
5178 error = ffetarget_and_logical1 (ffebld_cu_ptr_logical1 (u),
5179 ffebld_constant_logical1 (ffebld_conter (l)),
5180 ffebld_constant_logical1 (ffebld_conter (r)));
5181 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5182 (ffebld_cu_val_logical1 (u)), expr);
5183 break;
5184 #endif
5185
5186 #if FFETARGET_okLOGICAL2
5187 case FFEINFO_kindtypeLOGICAL2:
5188 error = ffetarget_and_logical2 (ffebld_cu_ptr_logical2 (u),
5189 ffebld_constant_logical2 (ffebld_conter (l)),
5190 ffebld_constant_logical2 (ffebld_conter (r)));
5191 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5192 (ffebld_cu_val_logical2 (u)), expr);
5193 break;
5194 #endif
5195
5196 #if FFETARGET_okLOGICAL3
5197 case FFEINFO_kindtypeLOGICAL3:
5198 error = ffetarget_and_logical3 (ffebld_cu_ptr_logical3 (u),
5199 ffebld_constant_logical3 (ffebld_conter (l)),
5200 ffebld_constant_logical3 (ffebld_conter (r)));
5201 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5202 (ffebld_cu_val_logical3 (u)), expr);
5203 break;
5204 #endif
5205
5206 #if FFETARGET_okLOGICAL4
5207 case FFEINFO_kindtypeLOGICAL4:
5208 error = ffetarget_and_logical4 (ffebld_cu_ptr_logical4 (u),
5209 ffebld_constant_logical4 (ffebld_conter (l)),
5210 ffebld_constant_logical4 (ffebld_conter (r)));
5211 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5212 (ffebld_cu_val_logical4 (u)), expr);
5213 break;
5214 #endif
5215
5216 default:
5217 assert ("bad logical kind type" == NULL);
5218 break;
5219 }
5220 break;
5221
5222 default:
5223 assert ("bad type" == NULL);
5224 return expr;
5225 }
5226
5227 ffebld_set_info (expr, ffeinfo_new
5228 (bt,
5229 kt,
5230 0,
5231 FFEINFO_kindENTITY,
5232 FFEINFO_whereCONSTANT,
5233 FFETARGET_charactersizeNONE));
5234
5235 if ((error != FFEBAD)
5236 && ffebad_start (error))
5237 {
5238 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5239 ffebad_finish ();
5240 }
5241
5242 return expr;
5243 }
5244
5245 /* ffeexpr_collapse_or -- Collapse or expr
5246
5247 ffebld expr;
5248 ffelexToken token;
5249 expr = ffeexpr_collapse_or(expr,token);
5250
5251 If the result of the expr is a constant, replaces the expr with the
5252 computed constant. */
5253
5254 ffebld
5255 ffeexpr_collapse_or (ffebld expr, ffelexToken t)
5256 {
5257 ffebad error = FFEBAD;
5258 ffebld l;
5259 ffebld r;
5260 ffebldConstantUnion u;
5261 ffeinfoBasictype bt;
5262 ffeinfoKindtype kt;
5263
5264 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5265 return expr;
5266
5267 l = ffebld_left (expr);
5268 r = ffebld_right (expr);
5269
5270 if (ffebld_op (l) != FFEBLD_opCONTER)
5271 return expr;
5272 if (ffebld_op (r) != FFEBLD_opCONTER)
5273 return expr;
5274
5275 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5276 {
5277 case FFEINFO_basictypeANY:
5278 return expr;
5279
5280 case FFEINFO_basictypeINTEGER:
5281 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5282 {
5283 #if FFETARGET_okINTEGER1
5284 case FFEINFO_kindtypeINTEGER1:
5285 error = ffetarget_or_integer1 (ffebld_cu_ptr_integer1 (u),
5286 ffebld_constant_integer1 (ffebld_conter (l)),
5287 ffebld_constant_integer1 (ffebld_conter (r)));
5288 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5289 (ffebld_cu_val_integer1 (u)), expr);
5290 break;
5291 #endif
5292
5293 #if FFETARGET_okINTEGER2
5294 case FFEINFO_kindtypeINTEGER2:
5295 error = ffetarget_or_integer2 (ffebld_cu_ptr_integer2 (u),
5296 ffebld_constant_integer2 (ffebld_conter (l)),
5297 ffebld_constant_integer2 (ffebld_conter (r)));
5298 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5299 (ffebld_cu_val_integer2 (u)), expr);
5300 break;
5301 #endif
5302
5303 #if FFETARGET_okINTEGER3
5304 case FFEINFO_kindtypeINTEGER3:
5305 error = ffetarget_or_integer3 (ffebld_cu_ptr_integer3 (u),
5306 ffebld_constant_integer3 (ffebld_conter (l)),
5307 ffebld_constant_integer3 (ffebld_conter (r)));
5308 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5309 (ffebld_cu_val_integer3 (u)), expr);
5310 break;
5311 #endif
5312
5313 #if FFETARGET_okINTEGER4
5314 case FFEINFO_kindtypeINTEGER4:
5315 error = ffetarget_or_integer4 (ffebld_cu_ptr_integer4 (u),
5316 ffebld_constant_integer4 (ffebld_conter (l)),
5317 ffebld_constant_integer4 (ffebld_conter (r)));
5318 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5319 (ffebld_cu_val_integer4 (u)), expr);
5320 break;
5321 #endif
5322
5323 default:
5324 assert ("bad integer kind type" == NULL);
5325 break;
5326 }
5327 break;
5328
5329 case FFEINFO_basictypeLOGICAL:
5330 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5331 {
5332 #if FFETARGET_okLOGICAL1
5333 case FFEINFO_kindtypeLOGICAL1:
5334 error = ffetarget_or_logical1 (ffebld_cu_ptr_logical1 (u),
5335 ffebld_constant_logical1 (ffebld_conter (l)),
5336 ffebld_constant_logical1 (ffebld_conter (r)));
5337 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5338 (ffebld_cu_val_logical1 (u)), expr);
5339 break;
5340 #endif
5341
5342 #if FFETARGET_okLOGICAL2
5343 case FFEINFO_kindtypeLOGICAL2:
5344 error = ffetarget_or_logical2 (ffebld_cu_ptr_logical2 (u),
5345 ffebld_constant_logical2 (ffebld_conter (l)),
5346 ffebld_constant_logical2 (ffebld_conter (r)));
5347 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5348 (ffebld_cu_val_logical2 (u)), expr);
5349 break;
5350 #endif
5351
5352 #if FFETARGET_okLOGICAL3
5353 case FFEINFO_kindtypeLOGICAL3:
5354 error = ffetarget_or_logical3 (ffebld_cu_ptr_logical3 (u),
5355 ffebld_constant_logical3 (ffebld_conter (l)),
5356 ffebld_constant_logical3 (ffebld_conter (r)));
5357 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5358 (ffebld_cu_val_logical3 (u)), expr);
5359 break;
5360 #endif
5361
5362 #if FFETARGET_okLOGICAL4
5363 case FFEINFO_kindtypeLOGICAL4:
5364 error = ffetarget_or_logical4 (ffebld_cu_ptr_logical4 (u),
5365 ffebld_constant_logical4 (ffebld_conter (l)),
5366 ffebld_constant_logical4 (ffebld_conter (r)));
5367 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5368 (ffebld_cu_val_logical4 (u)), expr);
5369 break;
5370 #endif
5371
5372 default:
5373 assert ("bad logical kind type" == NULL);
5374 break;
5375 }
5376 break;
5377
5378 default:
5379 assert ("bad type" == NULL);
5380 return expr;
5381 }
5382
5383 ffebld_set_info (expr, ffeinfo_new
5384 (bt,
5385 kt,
5386 0,
5387 FFEINFO_kindENTITY,
5388 FFEINFO_whereCONSTANT,
5389 FFETARGET_charactersizeNONE));
5390
5391 if ((error != FFEBAD)
5392 && ffebad_start (error))
5393 {
5394 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5395 ffebad_finish ();
5396 }
5397
5398 return expr;
5399 }
5400
5401 /* ffeexpr_collapse_xor -- Collapse xor expr
5402
5403 ffebld expr;
5404 ffelexToken token;
5405 expr = ffeexpr_collapse_xor(expr,token);
5406
5407 If the result of the expr is a constant, replaces the expr with the
5408 computed constant. */
5409
5410 ffebld
5411 ffeexpr_collapse_xor (ffebld expr, ffelexToken t)
5412 {
5413 ffebad error = FFEBAD;
5414 ffebld l;
5415 ffebld r;
5416 ffebldConstantUnion u;
5417 ffeinfoBasictype bt;
5418 ffeinfoKindtype kt;
5419
5420 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5421 return expr;
5422
5423 l = ffebld_left (expr);
5424 r = ffebld_right (expr);
5425
5426 if (ffebld_op (l) != FFEBLD_opCONTER)
5427 return expr;
5428 if (ffebld_op (r) != FFEBLD_opCONTER)
5429 return expr;
5430
5431 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5432 {
5433 case FFEINFO_basictypeANY:
5434 return expr;
5435
5436 case FFEINFO_basictypeINTEGER:
5437 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5438 {
5439 #if FFETARGET_okINTEGER1
5440 case FFEINFO_kindtypeINTEGER1:
5441 error = ffetarget_xor_integer1 (ffebld_cu_ptr_integer1 (u),
5442 ffebld_constant_integer1 (ffebld_conter (l)),
5443 ffebld_constant_integer1 (ffebld_conter (r)));
5444 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5445 (ffebld_cu_val_integer1 (u)), expr);
5446 break;
5447 #endif
5448
5449 #if FFETARGET_okINTEGER2
5450 case FFEINFO_kindtypeINTEGER2:
5451 error = ffetarget_xor_integer2 (ffebld_cu_ptr_integer2 (u),
5452 ffebld_constant_integer2 (ffebld_conter (l)),
5453 ffebld_constant_integer2 (ffebld_conter (r)));
5454 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5455 (ffebld_cu_val_integer2 (u)), expr);
5456 break;
5457 #endif
5458
5459 #if FFETARGET_okINTEGER3
5460 case FFEINFO_kindtypeINTEGER3:
5461 error = ffetarget_xor_integer3 (ffebld_cu_ptr_integer3 (u),
5462 ffebld_constant_integer3 (ffebld_conter (l)),
5463 ffebld_constant_integer3 (ffebld_conter (r)));
5464 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5465 (ffebld_cu_val_integer3 (u)), expr);
5466 break;
5467 #endif
5468
5469 #if FFETARGET_okINTEGER4
5470 case FFEINFO_kindtypeINTEGER4:
5471 error = ffetarget_xor_integer4 (ffebld_cu_ptr_integer4 (u),
5472 ffebld_constant_integer4 (ffebld_conter (l)),
5473 ffebld_constant_integer4 (ffebld_conter (r)));
5474 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5475 (ffebld_cu_val_integer4 (u)), expr);
5476 break;
5477 #endif
5478
5479 default:
5480 assert ("bad integer kind type" == NULL);
5481 break;
5482 }
5483 break;
5484
5485 case FFEINFO_basictypeLOGICAL:
5486 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5487 {
5488 #if FFETARGET_okLOGICAL1
5489 case FFEINFO_kindtypeLOGICAL1:
5490 error = ffetarget_xor_logical1 (ffebld_cu_ptr_logical1 (u),
5491 ffebld_constant_logical1 (ffebld_conter (l)),
5492 ffebld_constant_logical1 (ffebld_conter (r)));
5493 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5494 (ffebld_cu_val_logical1 (u)), expr);
5495 break;
5496 #endif
5497
5498 #if FFETARGET_okLOGICAL2
5499 case FFEINFO_kindtypeLOGICAL2:
5500 error = ffetarget_xor_logical2 (ffebld_cu_ptr_logical2 (u),
5501 ffebld_constant_logical2 (ffebld_conter (l)),
5502 ffebld_constant_logical2 (ffebld_conter (r)));
5503 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5504 (ffebld_cu_val_logical2 (u)), expr);
5505 break;
5506 #endif
5507
5508 #if FFETARGET_okLOGICAL3
5509 case FFEINFO_kindtypeLOGICAL3:
5510 error = ffetarget_xor_logical3 (ffebld_cu_ptr_logical3 (u),
5511 ffebld_constant_logical3 (ffebld_conter (l)),
5512 ffebld_constant_logical3 (ffebld_conter (r)));
5513 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5514 (ffebld_cu_val_logical3 (u)), expr);
5515 break;
5516 #endif
5517
5518 #if FFETARGET_okLOGICAL4
5519 case FFEINFO_kindtypeLOGICAL4:
5520 error = ffetarget_xor_logical4 (ffebld_cu_ptr_logical4 (u),
5521 ffebld_constant_logical4 (ffebld_conter (l)),
5522 ffebld_constant_logical4 (ffebld_conter (r)));
5523 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5524 (ffebld_cu_val_logical4 (u)), expr);
5525 break;
5526 #endif
5527
5528 default:
5529 assert ("bad logical kind type" == NULL);
5530 break;
5531 }
5532 break;
5533
5534 default:
5535 assert ("bad type" == NULL);
5536 return expr;
5537 }
5538
5539 ffebld_set_info (expr, ffeinfo_new
5540 (bt,
5541 kt,
5542 0,
5543 FFEINFO_kindENTITY,
5544 FFEINFO_whereCONSTANT,
5545 FFETARGET_charactersizeNONE));
5546
5547 if ((error != FFEBAD)
5548 && ffebad_start (error))
5549 {
5550 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5551 ffebad_finish ();
5552 }
5553
5554 return expr;
5555 }
5556
5557 /* ffeexpr_collapse_eqv -- Collapse eqv expr
5558
5559 ffebld expr;
5560 ffelexToken token;
5561 expr = ffeexpr_collapse_eqv(expr,token);
5562
5563 If the result of the expr is a constant, replaces the expr with the
5564 computed constant. */
5565
5566 ffebld
5567 ffeexpr_collapse_eqv (ffebld expr, ffelexToken t)
5568 {
5569 ffebad error = FFEBAD;
5570 ffebld l;
5571 ffebld r;
5572 ffebldConstantUnion u;
5573 ffeinfoBasictype bt;
5574 ffeinfoKindtype kt;
5575
5576 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5577 return expr;
5578
5579 l = ffebld_left (expr);
5580 r = ffebld_right (expr);
5581
5582 if (ffebld_op (l) != FFEBLD_opCONTER)
5583 return expr;
5584 if (ffebld_op (r) != FFEBLD_opCONTER)
5585 return expr;
5586
5587 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5588 {
5589 case FFEINFO_basictypeANY:
5590 return expr;
5591
5592 case FFEINFO_basictypeINTEGER:
5593 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5594 {
5595 #if FFETARGET_okINTEGER1
5596 case FFEINFO_kindtypeINTEGER1:
5597 error = ffetarget_eqv_integer1 (ffebld_cu_ptr_integer1 (u),
5598 ffebld_constant_integer1 (ffebld_conter (l)),
5599 ffebld_constant_integer1 (ffebld_conter (r)));
5600 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5601 (ffebld_cu_val_integer1 (u)), expr);
5602 break;
5603 #endif
5604
5605 #if FFETARGET_okINTEGER2
5606 case FFEINFO_kindtypeINTEGER2:
5607 error = ffetarget_eqv_integer2 (ffebld_cu_ptr_integer2 (u),
5608 ffebld_constant_integer2 (ffebld_conter (l)),
5609 ffebld_constant_integer2 (ffebld_conter (r)));
5610 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5611 (ffebld_cu_val_integer2 (u)), expr);
5612 break;
5613 #endif
5614
5615 #if FFETARGET_okINTEGER3
5616 case FFEINFO_kindtypeINTEGER3:
5617 error = ffetarget_eqv_integer3 (ffebld_cu_ptr_integer3 (u),
5618 ffebld_constant_integer3 (ffebld_conter (l)),
5619 ffebld_constant_integer3 (ffebld_conter (r)));
5620 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5621 (ffebld_cu_val_integer3 (u)), expr);
5622 break;
5623 #endif
5624
5625 #if FFETARGET_okINTEGER4
5626 case FFEINFO_kindtypeINTEGER4:
5627 error = ffetarget_eqv_integer4 (ffebld_cu_ptr_integer4 (u),
5628 ffebld_constant_integer4 (ffebld_conter (l)),
5629 ffebld_constant_integer4 (ffebld_conter (r)));
5630 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5631 (ffebld_cu_val_integer4 (u)), expr);
5632 break;
5633 #endif
5634
5635 default:
5636 assert ("bad integer kind type" == NULL);
5637 break;
5638 }
5639 break;
5640
5641 case FFEINFO_basictypeLOGICAL:
5642 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5643 {
5644 #if FFETARGET_okLOGICAL1
5645 case FFEINFO_kindtypeLOGICAL1:
5646 error = ffetarget_eqv_logical1 (ffebld_cu_ptr_logical1 (u),
5647 ffebld_constant_logical1 (ffebld_conter (l)),
5648 ffebld_constant_logical1 (ffebld_conter (r)));
5649 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5650 (ffebld_cu_val_logical1 (u)), expr);
5651 break;
5652 #endif
5653
5654 #if FFETARGET_okLOGICAL2
5655 case FFEINFO_kindtypeLOGICAL2:
5656 error = ffetarget_eqv_logical2 (ffebld_cu_ptr_logical2 (u),
5657 ffebld_constant_logical2 (ffebld_conter (l)),
5658 ffebld_constant_logical2 (ffebld_conter (r)));
5659 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5660 (ffebld_cu_val_logical2 (u)), expr);
5661 break;
5662 #endif
5663
5664 #if FFETARGET_okLOGICAL3
5665 case FFEINFO_kindtypeLOGICAL3:
5666 error = ffetarget_eqv_logical3 (ffebld_cu_ptr_logical3 (u),
5667 ffebld_constant_logical3 (ffebld_conter (l)),
5668 ffebld_constant_logical3 (ffebld_conter (r)));
5669 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5670 (ffebld_cu_val_logical3 (u)), expr);
5671 break;
5672 #endif
5673
5674 #if FFETARGET_okLOGICAL4
5675 case FFEINFO_kindtypeLOGICAL4:
5676 error = ffetarget_eqv_logical4 (ffebld_cu_ptr_logical4 (u),
5677 ffebld_constant_logical4 (ffebld_conter (l)),
5678 ffebld_constant_logical4 (ffebld_conter (r)));
5679 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5680 (ffebld_cu_val_logical4 (u)), expr);
5681 break;
5682 #endif
5683
5684 default:
5685 assert ("bad logical kind type" == NULL);
5686 break;
5687 }
5688 break;
5689
5690 default:
5691 assert ("bad type" == NULL);
5692 return expr;
5693 }
5694
5695 ffebld_set_info (expr, ffeinfo_new
5696 (bt,
5697 kt,
5698 0,
5699 FFEINFO_kindENTITY,
5700 FFEINFO_whereCONSTANT,
5701 FFETARGET_charactersizeNONE));
5702
5703 if ((error != FFEBAD)
5704 && ffebad_start (error))
5705 {
5706 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5707 ffebad_finish ();
5708 }
5709
5710 return expr;
5711 }
5712
5713 /* ffeexpr_collapse_neqv -- Collapse neqv expr
5714
5715 ffebld expr;
5716 ffelexToken token;
5717 expr = ffeexpr_collapse_neqv(expr,token);
5718
5719 If the result of the expr is a constant, replaces the expr with the
5720 computed constant. */
5721
5722 ffebld
5723 ffeexpr_collapse_neqv (ffebld expr, ffelexToken t)
5724 {
5725 ffebad error = FFEBAD;
5726 ffebld l;
5727 ffebld r;
5728 ffebldConstantUnion u;
5729 ffeinfoBasictype bt;
5730 ffeinfoKindtype kt;
5731
5732 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5733 return expr;
5734
5735 l = ffebld_left (expr);
5736 r = ffebld_right (expr);
5737
5738 if (ffebld_op (l) != FFEBLD_opCONTER)
5739 return expr;
5740 if (ffebld_op (r) != FFEBLD_opCONTER)
5741 return expr;
5742
5743 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5744 {
5745 case FFEINFO_basictypeANY:
5746 return expr;
5747
5748 case FFEINFO_basictypeINTEGER:
5749 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5750 {
5751 #if FFETARGET_okINTEGER1
5752 case FFEINFO_kindtypeINTEGER1:
5753 error = ffetarget_neqv_integer1 (ffebld_cu_ptr_integer1 (u),
5754 ffebld_constant_integer1 (ffebld_conter (l)),
5755 ffebld_constant_integer1 (ffebld_conter (r)));
5756 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5757 (ffebld_cu_val_integer1 (u)), expr);
5758 break;
5759 #endif
5760
5761 #if FFETARGET_okINTEGER2
5762 case FFEINFO_kindtypeINTEGER2:
5763 error = ffetarget_neqv_integer2 (ffebld_cu_ptr_integer2 (u),
5764 ffebld_constant_integer2 (ffebld_conter (l)),
5765 ffebld_constant_integer2 (ffebld_conter (r)));
5766 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5767 (ffebld_cu_val_integer2 (u)), expr);
5768 break;
5769 #endif
5770
5771 #if FFETARGET_okINTEGER3
5772 case FFEINFO_kindtypeINTEGER3:
5773 error = ffetarget_neqv_integer3 (ffebld_cu_ptr_integer3 (u),
5774 ffebld_constant_integer3 (ffebld_conter (l)),
5775 ffebld_constant_integer3 (ffebld_conter (r)));
5776 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5777 (ffebld_cu_val_integer3 (u)), expr);
5778 break;
5779 #endif
5780
5781 #if FFETARGET_okINTEGER4
5782 case FFEINFO_kindtypeINTEGER4:
5783 error = ffetarget_neqv_integer4 (ffebld_cu_ptr_integer4 (u),
5784 ffebld_constant_integer4 (ffebld_conter (l)),
5785 ffebld_constant_integer4 (ffebld_conter (r)));
5786 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5787 (ffebld_cu_val_integer4 (u)), expr);
5788 break;
5789 #endif
5790
5791 default:
5792 assert ("bad integer kind type" == NULL);
5793 break;
5794 }
5795 break;
5796
5797 case FFEINFO_basictypeLOGICAL:
5798 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5799 {
5800 #if FFETARGET_okLOGICAL1
5801 case FFEINFO_kindtypeLOGICAL1:
5802 error = ffetarget_neqv_logical1 (ffebld_cu_ptr_logical1 (u),
5803 ffebld_constant_logical1 (ffebld_conter (l)),
5804 ffebld_constant_logical1 (ffebld_conter (r)));
5805 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5806 (ffebld_cu_val_logical1 (u)), expr);
5807 break;
5808 #endif
5809
5810 #if FFETARGET_okLOGICAL2
5811 case FFEINFO_kindtypeLOGICAL2:
5812 error = ffetarget_neqv_logical2 (ffebld_cu_ptr_logical2 (u),
5813 ffebld_constant_logical2 (ffebld_conter (l)),
5814 ffebld_constant_logical2 (ffebld_conter (r)));
5815 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5816 (ffebld_cu_val_logical2 (u)), expr);
5817 break;
5818 #endif
5819
5820 #if FFETARGET_okLOGICAL3
5821 case FFEINFO_kindtypeLOGICAL3:
5822 error = ffetarget_neqv_logical3 (ffebld_cu_ptr_logical3 (u),
5823 ffebld_constant_logical3 (ffebld_conter (l)),
5824 ffebld_constant_logical3 (ffebld_conter (r)));
5825 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5826 (ffebld_cu_val_logical3 (u)), expr);
5827 break;
5828 #endif
5829
5830 #if FFETARGET_okLOGICAL4
5831 case FFEINFO_kindtypeLOGICAL4:
5832 error = ffetarget_neqv_logical4 (ffebld_cu_ptr_logical4 (u),
5833 ffebld_constant_logical4 (ffebld_conter (l)),
5834 ffebld_constant_logical4 (ffebld_conter (r)));
5835 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5836 (ffebld_cu_val_logical4 (u)), expr);
5837 break;
5838 #endif
5839
5840 default:
5841 assert ("bad logical kind type" == NULL);
5842 break;
5843 }
5844 break;
5845
5846 default:
5847 assert ("bad type" == NULL);
5848 return expr;
5849 }
5850
5851 ffebld_set_info (expr, ffeinfo_new
5852 (bt,
5853 kt,
5854 0,
5855 FFEINFO_kindENTITY,
5856 FFEINFO_whereCONSTANT,
5857 FFETARGET_charactersizeNONE));
5858
5859 if ((error != FFEBAD)
5860 && ffebad_start (error))
5861 {
5862 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5863 ffebad_finish ();
5864 }
5865
5866 return expr;
5867 }
5868
5869 /* ffeexpr_collapse_symter -- Collapse symter expr
5870
5871 ffebld expr;
5872 ffelexToken token;
5873 expr = ffeexpr_collapse_symter(expr,token);
5874
5875 If the result of the expr is a constant, replaces the expr with the
5876 computed constant. */
5877
5878 ffebld
5879 ffeexpr_collapse_symter (ffebld expr, ffelexToken t UNUSED)
5880 {
5881 ffebld r;
5882 ffeinfoBasictype bt;
5883 ffeinfoKindtype kt;
5884 ffetargetCharacterSize len;
5885
5886 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5887 return expr;
5888
5889 if ((r = ffesymbol_init (ffebld_symter (expr))) == NULL)
5890 return expr; /* A PARAMETER lhs in progress. */
5891
5892 switch (ffebld_op (r))
5893 {
5894 case FFEBLD_opCONTER:
5895 break;
5896
5897 case FFEBLD_opANY:
5898 return r;
5899
5900 default:
5901 return expr;
5902 }
5903
5904 bt = ffeinfo_basictype (ffebld_info (r));
5905 kt = ffeinfo_kindtype (ffebld_info (r));
5906 len = ffebld_size (r);
5907
5908 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
5909 expr);
5910
5911 ffebld_set_info (expr, ffeinfo_new
5912 (bt,
5913 kt,
5914 0,
5915 FFEINFO_kindENTITY,
5916 FFEINFO_whereCONSTANT,
5917 len));
5918
5919 return expr;
5920 }
5921
5922 /* ffeexpr_collapse_funcref -- Collapse funcref expr
5923
5924 ffebld expr;
5925 ffelexToken token;
5926 expr = ffeexpr_collapse_funcref(expr,token);
5927
5928 If the result of the expr is a constant, replaces the expr with the
5929 computed constant. */
5930
5931 ffebld
5932 ffeexpr_collapse_funcref (ffebld expr, ffelexToken t UNUSED)
5933 {
5934 return expr; /* ~~someday go ahead and collapse these,
5935 though not required */
5936 }
5937
5938 /* ffeexpr_collapse_arrayref -- Collapse arrayref expr
5939
5940 ffebld expr;
5941 ffelexToken token;
5942 expr = ffeexpr_collapse_arrayref(expr,token);
5943
5944 If the result of the expr is a constant, replaces the expr with the
5945 computed constant. */
5946
5947 ffebld
5948 ffeexpr_collapse_arrayref (ffebld expr, ffelexToken t UNUSED)
5949 {
5950 return expr;
5951 }
5952
5953 /* ffeexpr_collapse_substr -- Collapse substr expr
5954
5955 ffebld expr;
5956 ffelexToken token;
5957 expr = ffeexpr_collapse_substr(expr,token);
5958
5959 If the result of the expr is a constant, replaces the expr with the
5960 computed constant. */
5961
5962 ffebld
5963 ffeexpr_collapse_substr (ffebld expr, ffelexToken t)
5964 {
5965 ffebad error = FFEBAD;
5966 ffebld l;
5967 ffebld r;
5968 ffebld start;
5969 ffebld stop;
5970 ffebldConstantUnion u;
5971 ffeinfoKindtype kt;
5972 ffetargetCharacterSize len;
5973 ffetargetIntegerDefault first;
5974 ffetargetIntegerDefault last;
5975
5976 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5977 return expr;
5978
5979 l = ffebld_left (expr);
5980 r = ffebld_right (expr); /* opITEM. */
5981
5982 if (ffebld_op (l) != FFEBLD_opCONTER)
5983 return expr;
5984
5985 kt = ffeinfo_kindtype (ffebld_info (l));
5986 len = ffebld_size (l);
5987
5988 start = ffebld_head (r);
5989 stop = ffebld_head (ffebld_trail (r));
5990 if (start == NULL)
5991 first = 1;
5992 else
5993 {
5994 if ((ffebld_op (start) != FFEBLD_opCONTER)
5995 || (ffeinfo_basictype (ffebld_info (start)) != FFEINFO_basictypeINTEGER)
5996 || (ffeinfo_kindtype (ffebld_info (start))
5997 != FFEINFO_kindtypeINTEGERDEFAULT))
5998 return expr;
5999 first = ffebld_constant_integerdefault (ffebld_conter (start));
6000 }
6001 if (stop == NULL)
6002 last = len;
6003 else
6004 {
6005 if ((ffebld_op (stop) != FFEBLD_opCONTER)
6006 || (ffeinfo_basictype (ffebld_info (stop)) != FFEINFO_basictypeINTEGER)
6007 || (ffeinfo_kindtype (ffebld_info (stop))
6008 != FFEINFO_kindtypeINTEGERDEFAULT))
6009 return expr;
6010 last = ffebld_constant_integerdefault (ffebld_conter (stop));
6011 }
6012
6013 /* Handle problems that should have already been diagnosed, but
6014 left in the expression tree. */
6015
6016 if (first <= 0)
6017 first = 1;
6018 if (last < first)
6019 last = first + len - 1;
6020
6021 if ((first == 1) && (last == len))
6022 { /* Same as original. */
6023 expr = ffebld_new_conter_with_orig (ffebld_constant_copy
6024 (ffebld_conter (l)), expr);
6025 ffebld_set_info (expr, ffeinfo_new
6026 (FFEINFO_basictypeCHARACTER,
6027 kt,
6028 0,
6029 FFEINFO_kindENTITY,
6030 FFEINFO_whereCONSTANT,
6031 len));
6032
6033 return expr;
6034 }
6035
6036 switch (ffeinfo_basictype (ffebld_info (expr)))
6037 {
6038 case FFEINFO_basictypeANY:
6039 return expr;
6040
6041 case FFEINFO_basictypeCHARACTER:
6042 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6043 {
6044 #if FFETARGET_okCHARACTER1
6045 case FFEINFO_kindtypeCHARACTER1:
6046 error = ffetarget_substr_character1 (ffebld_cu_ptr_character1 (u),
6047 ffebld_constant_character1 (ffebld_conter (l)), first, last,
6048 ffebld_constant_pool (), &len);
6049 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
6050 (ffebld_cu_val_character1 (u)), expr);
6051 break;
6052 #endif
6053
6054 default:
6055 assert ("bad character kind type" == NULL);
6056 break;
6057 }
6058 break;
6059
6060 default:
6061 assert ("bad type" == NULL);
6062 return expr;
6063 }
6064
6065 ffebld_set_info (expr, ffeinfo_new
6066 (FFEINFO_basictypeCHARACTER,
6067 kt,
6068 0,
6069 FFEINFO_kindENTITY,
6070 FFEINFO_whereCONSTANT,
6071 len));
6072
6073 if ((error != FFEBAD)
6074 && ffebad_start (error))
6075 {
6076 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6077 ffebad_finish ();
6078 }
6079
6080 return expr;
6081 }
6082
6083 /* ffeexpr_convert -- Convert source expression to given type
6084
6085 ffebld source;
6086 ffelexToken source_token;
6087 ffelexToken dest_token; // Any appropriate token for "destination".
6088 ffeinfoBasictype bt;
6089 ffeinfoKindtype kt;
6090 ffetargetCharactersize sz;
6091 ffeexprContext context; // Mainly LET or DATA.
6092 source = ffeexpr_convert(source,source_token,dest_token,bt,kt,sz,context);
6093
6094 If the expression conforms, returns the source expression. Otherwise
6095 returns source wrapped in a convert node doing the conversion, or
6096 ANY wrapped in convert if there is a conversion error (and issues an
6097 error message). Be sensitive to the context for certain aspects of
6098 the conversion. */
6099
6100 ffebld
6101 ffeexpr_convert (ffebld source, ffelexToken source_token, ffelexToken dest_token,
6102 ffeinfoBasictype bt, ffeinfoKindtype kt, ffeinfoRank rk,
6103 ffetargetCharacterSize sz, ffeexprContext context)
6104 {
6105 bool bad;
6106 ffeinfo info;
6107 ffeinfoWhere wh;
6108
6109 info = ffebld_info (source);
6110 if ((bt != ffeinfo_basictype (info))
6111 || (kt != ffeinfo_kindtype (info))
6112 || (rk != 0) /* Can't convert from or to arrays yet. */
6113 || (ffeinfo_rank (info) != 0)
6114 || (sz != ffebld_size_known (source)))
6115 #if 0 /* Nobody seems to need this spurious CONVERT node. */
6116 || ((context != FFEEXPR_contextLET)
6117 && (bt == FFEINFO_basictypeCHARACTER)
6118 && (sz == FFETARGET_charactersizeNONE)))
6119 #endif
6120 {
6121 switch (ffeinfo_basictype (info))
6122 {
6123 case FFEINFO_basictypeLOGICAL:
6124 switch (bt)
6125 {
6126 case FFEINFO_basictypeLOGICAL:
6127 bad = FALSE;
6128 break;
6129
6130 case FFEINFO_basictypeINTEGER:
6131 bad = !ffe_is_ugly_logint ();
6132 break;
6133
6134 case FFEINFO_basictypeCHARACTER:
6135 bad = ffe_is_pedantic ()
6136 || !(ffe_is_ugly_init ()
6137 && (context == FFEEXPR_contextDATA));
6138 break;
6139
6140 default:
6141 bad = TRUE;
6142 break;
6143 }
6144 break;
6145
6146 case FFEINFO_basictypeINTEGER:
6147 switch (bt)
6148 {
6149 case FFEINFO_basictypeINTEGER:
6150 case FFEINFO_basictypeREAL:
6151 case FFEINFO_basictypeCOMPLEX:
6152 bad = FALSE;
6153 break;
6154
6155 case FFEINFO_basictypeLOGICAL:
6156 bad = !ffe_is_ugly_logint ();
6157 break;
6158
6159 case FFEINFO_basictypeCHARACTER:
6160 bad = ffe_is_pedantic ()
6161 || !(ffe_is_ugly_init ()
6162 && (context == FFEEXPR_contextDATA));
6163 break;
6164
6165 default:
6166 bad = TRUE;
6167 break;
6168 }
6169 break;
6170
6171 case FFEINFO_basictypeREAL:
6172 case FFEINFO_basictypeCOMPLEX:
6173 switch (bt)
6174 {
6175 case FFEINFO_basictypeINTEGER:
6176 case FFEINFO_basictypeREAL:
6177 case FFEINFO_basictypeCOMPLEX:
6178 bad = FALSE;
6179 break;
6180
6181 case FFEINFO_basictypeCHARACTER:
6182 bad = TRUE;
6183 break;
6184
6185 default:
6186 bad = TRUE;
6187 break;
6188 }
6189 break;
6190
6191 case FFEINFO_basictypeCHARACTER:
6192 bad = (bt != FFEINFO_basictypeCHARACTER)
6193 && (ffe_is_pedantic ()
6194 || (bt != FFEINFO_basictypeINTEGER)
6195 || !(ffe_is_ugly_init ()
6196 && (context == FFEEXPR_contextDATA)));
6197 break;
6198
6199 case FFEINFO_basictypeTYPELESS:
6200 case FFEINFO_basictypeHOLLERITH:
6201 bad = ffe_is_pedantic ()
6202 || !(ffe_is_ugly_init ()
6203 && ((context == FFEEXPR_contextDATA)
6204 || (context == FFEEXPR_contextLET)));
6205 break;
6206
6207 default:
6208 bad = TRUE;
6209 break;
6210 }
6211
6212 if (!bad && ((rk != 0) || (ffeinfo_rank (info) != 0)))
6213 bad = TRUE;
6214
6215 if (bad && (bt != FFEINFO_basictypeANY) && (kt != FFEINFO_kindtypeANY)
6216 && (ffeinfo_basictype (info) != FFEINFO_basictypeANY)
6217 && (ffeinfo_kindtype (info) != FFEINFO_kindtypeANY)
6218 && (ffeinfo_where (info) != FFEINFO_whereANY))
6219 {
6220 if (ffebad_start (FFEBAD_BAD_TYPES))
6221 {
6222 if (dest_token == NULL)
6223 ffebad_here (0, ffewhere_line_unknown (),
6224 ffewhere_column_unknown ());
6225 else
6226 ffebad_here (0, ffelex_token_where_line (dest_token),
6227 ffelex_token_where_column (dest_token));
6228 assert (source_token != NULL);
6229 ffebad_here (1, ffelex_token_where_line (source_token),
6230 ffelex_token_where_column (source_token));
6231 ffebad_finish ();
6232 }
6233
6234 source = ffebld_new_any ();
6235 ffebld_set_info (source, ffeinfo_new_any ());
6236 }
6237 else
6238 {
6239 switch (ffeinfo_where (info))
6240 {
6241 case FFEINFO_whereCONSTANT:
6242 wh = FFEINFO_whereCONSTANT;
6243 break;
6244
6245 case FFEINFO_whereIMMEDIATE:
6246 wh = FFEINFO_whereIMMEDIATE;
6247 break;
6248
6249 default:
6250 wh = FFEINFO_whereFLEETING;
6251 break;
6252 }
6253 source = ffebld_new_convert (source);
6254 ffebld_set_info (source, ffeinfo_new
6255 (bt,
6256 kt,
6257 0,
6258 FFEINFO_kindENTITY,
6259 wh,
6260 sz));
6261 source = ffeexpr_collapse_convert (source, source_token);
6262 }
6263 }
6264
6265 return source;
6266 }
6267
6268 /* ffeexpr_convert_expr -- Convert source expr to conform to dest expr
6269
6270 ffebld source;
6271 ffebld dest;
6272 ffelexToken source_token;
6273 ffelexToken dest_token;
6274 ffeexprContext context;
6275 source = ffeexpr_convert_expr(source,source_token,dest,dest_token,context);
6276
6277 If the expressions conform, returns the source expression. Otherwise
6278 returns source wrapped in a convert node doing the conversion, or
6279 ANY wrapped in convert if there is a conversion error (and issues an
6280 error message). Be sensitive to the context, such as LET or DATA. */
6281
6282 ffebld
6283 ffeexpr_convert_expr (ffebld source, ffelexToken source_token, ffebld dest,
6284 ffelexToken dest_token, ffeexprContext context)
6285 {
6286 ffeinfo info;
6287
6288 info = ffebld_info (dest);
6289 return ffeexpr_convert (source, source_token, dest_token,
6290 ffeinfo_basictype (info),
6291 ffeinfo_kindtype (info),
6292 ffeinfo_rank (info),
6293 ffebld_size_known (dest),
6294 context);
6295 }
6296
6297 /* ffeexpr_convert_to_sym -- Convert source expression to conform to symbol
6298
6299 ffebld source;
6300 ffesymbol dest;
6301 ffelexToken source_token;
6302 ffelexToken dest_token;
6303 source = ffeexpr_convert_to_sym(source,source_token,dest,dest_token);
6304
6305 If the expressions conform, returns the source expression. Otherwise
6306 returns source wrapped in a convert node doing the conversion, or
6307 ANY wrapped in convert if there is a conversion error (and issues an
6308 error message). */
6309
6310 ffebld
6311 ffeexpr_convert_to_sym (ffebld source, ffelexToken source_token,
6312 ffesymbol dest, ffelexToken dest_token)
6313 {
6314 return ffeexpr_convert (source, source_token, dest_token, ffesymbol_basictype (dest),
6315 ffesymbol_kindtype (dest), ffesymbol_rank (dest), ffesymbol_size (dest),
6316 FFEEXPR_contextLET);
6317 }
6318
6319 /* Initializes the module. */
6320
6321 void
6322 ffeexpr_init_2 (void)
6323 {
6324 ffeexpr_stack_ = NULL;
6325 ffeexpr_level_ = 0;
6326 }
6327
6328 /* ffeexpr_lhs -- Begin processing left-hand-side-context expression
6329
6330 Prepares cluster for delivery of lexer tokens representing an expression
6331 in a left-hand-side context (A in A=B, for example). ffebld is used
6332 to build expressions in the given pool. The appropriate lexer-token
6333 handling routine within ffeexpr is returned. When the end of the
6334 expression is detected, mycallbackroutine is called with the resulting
6335 single ffebld object specifying the entire expression and the first
6336 lexer token that is not considered part of the expression. This caller-
6337 supplied routine itself returns a lexer-token handling routine. Thus,
6338 if necessary, ffeexpr can return several tokens as end-of-expression
6339 tokens if it needs to scan forward more than one in any instance. */
6340
6341 ffelexHandler
6342 ffeexpr_lhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
6343 {
6344 ffeexprStack_ s;
6345
6346 ffebld_pool_push (pool);
6347 s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
6348 s->previous = ffeexpr_stack_;
6349 s->pool = pool;
6350 s->context = context;
6351 s->callback = callback;
6352 s->first_token = NULL;
6353 s->exprstack = NULL;
6354 s->is_rhs = FALSE;
6355 ffeexpr_stack_ = s;
6356 return (ffelexHandler) ffeexpr_token_first_lhs_;
6357 }
6358
6359 /* ffeexpr_rhs -- Begin processing right-hand-side-context expression
6360
6361 return ffeexpr_rhs(malloc_pool_image(),mycallbackroutine); // to lexer.
6362
6363 Prepares cluster for delivery of lexer tokens representing an expression
6364 in a right-hand-side context (B in A=B, for example). ffebld is used
6365 to build expressions in the given pool. The appropriate lexer-token
6366 handling routine within ffeexpr is returned. When the end of the
6367 expression is detected, mycallbackroutine is called with the resulting
6368 single ffebld object specifying the entire expression and the first
6369 lexer token that is not considered part of the expression. This caller-
6370 supplied routine itself returns a lexer-token handling routine. Thus,
6371 if necessary, ffeexpr can return several tokens as end-of-expression
6372 tokens if it needs to scan forward more than one in any instance. */
6373
6374 ffelexHandler
6375 ffeexpr_rhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
6376 {
6377 ffeexprStack_ s;
6378
6379 ffebld_pool_push (pool);
6380 s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
6381 s->previous = ffeexpr_stack_;
6382 s->pool = pool;
6383 s->context = context;
6384 s->callback = callback;
6385 s->first_token = NULL;
6386 s->exprstack = NULL;
6387 s->is_rhs = TRUE;
6388 ffeexpr_stack_ = s;
6389 return (ffelexHandler) ffeexpr_token_first_rhs_;
6390 }
6391
6392 /* ffeexpr_cb_close_paren_ -- OPEN_PAREN expr
6393
6394 Pass it to ffeexpr_rhs as the callback routine.
6395
6396 Makes sure the end token is close-paren and swallows it, else issues
6397 an error message and doesn't swallow the token (passing it along instead).
6398 In either case wraps up subexpression construction by enclosing the
6399 ffebld expression in a paren. */
6400
6401 static ffelexHandler
6402 ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr, ffelexToken t)
6403 {
6404 ffeexprExpr_ e;
6405
6406 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
6407 {
6408 /* Oops, naughty user didn't specify the close paren! */
6409
6410 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
6411 {
6412 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6413 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
6414 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
6415 ffebad_finish ();
6416 }
6417
6418 e = ffeexpr_expr_new_ ();
6419 e->type = FFEEXPR_exprtypeOPERAND_;
6420 e->u.operand = ffebld_new_any ();
6421 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
6422 ffeexpr_exprstack_push_operand_ (e);
6423
6424 return
6425 (ffelexHandler) ffeexpr_find_close_paren_ (t,
6426 (ffelexHandler)
6427 ffeexpr_token_binary_);
6428 }
6429
6430 if (expr->op == FFEBLD_opIMPDO)
6431 {
6432 if (ffest_ffebad_start (FFEBAD_IMPDO_PAREN))
6433 {
6434 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
6435 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
6436 ffebad_finish ();
6437 }
6438 }
6439 else
6440 {
6441 expr = ffebld_new_paren (expr);
6442 ffebld_set_info (expr, ffeinfo_use (ffebld_info (ffebld_left (expr))));
6443 }
6444
6445 /* Now push the (parenthesized) expression as an operand onto the
6446 expression stack. */
6447
6448 e = ffeexpr_expr_new_ ();
6449 e->type = FFEEXPR_exprtypeOPERAND_;
6450 e->u.operand = expr;
6451 e->u.operand = ffeexpr_collapse_paren (e->u.operand, ft);
6452 e->token = ffeexpr_stack_->tokens[0];
6453 ffeexpr_exprstack_push_operand_ (e);
6454
6455 return (ffelexHandler) ffeexpr_token_binary_;
6456 }
6457
6458 /* ffeexpr_cb_close_paren_ambig_ -- OPEN_PAREN expr
6459
6460 Pass it to ffeexpr_rhs as the callback routine.
6461
6462 We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
6463 with the next token in t. If the next token is possibly a binary
6464 operator, continue processing the outer expression. If the next
6465 token is COMMA, then the expression is a unit specifier, and
6466 parentheses should not be added to it because it surrounds the
6467 I/O control list that starts with the unit specifier (and continues
6468 on from here -- we haven't seen the CLOSE_PAREN that matches the
6469 OPEN_PAREN, it is up to the callback function to expect to see it
6470 at some point). In this case, we notify the callback function that
6471 the COMMA is inside, not outside, the parens by wrapping the expression
6472 in an opITEM (with a NULL trail) -- the callback function presumably
6473 unwraps it after seeing this kludgey indicator.
6474
6475 If the next token is CLOSE_PAREN, then we go to the _1_ state to
6476 decide what to do with the token after that.
6477
6478 15-Feb-91 JCB 1.1
6479 Use an extra state for the CLOSE_PAREN case to make READ &co really
6480 work right. */
6481
6482 static ffelexHandler
6483 ffeexpr_cb_close_paren_ambig_ (ffelexToken ft, ffebld expr, ffelexToken t)
6484 {
6485 ffeexprCallback callback;
6486 ffeexprStack_ s;
6487
6488 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
6489 { /* Need to see the next token before we
6490 decide anything. */
6491 ffeexpr_stack_->expr = expr;
6492 ffeexpr_tokens_[0] = ffelex_token_use (ft);
6493 ffeexpr_tokens_[1] = ffelex_token_use (t);
6494 return (ffelexHandler) ffeexpr_cb_close_paren_ambig_1_;
6495 }
6496
6497 expr = ffeexpr_finished_ambig_ (ft, expr);
6498
6499 /* Let the callback function handle the case where t isn't COMMA. */
6500
6501 /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
6502 that preceded the expression starts a list of expressions, and the expr
6503 hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
6504 node. The callback function should extract the real expr from the head
6505 of this opITEM node after testing it. */
6506
6507 expr = ffebld_new_item (expr, NULL);
6508
6509 ffebld_pool_pop ();
6510 callback = ffeexpr_stack_->callback;
6511 ffelex_token_kill (ffeexpr_stack_->first_token);
6512 s = ffeexpr_stack_->previous;
6513 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
6514 ffeexpr_stack_ = s;
6515 return (ffelexHandler) (*callback) (ft, expr, t);
6516 }
6517
6518 /* ffeexpr_cb_close_paren_ambig_1_ -- OPEN_PAREN expr CLOSE_PAREN
6519
6520 See ffeexpr_cb_close_paren_ambig_.
6521
6522 We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
6523 with the next token in t. If the next token is possibly a binary
6524 operator, continue processing the outer expression. If the next
6525 token is COMMA, the expression is a parenthesized format specifier.
6526 If the next token is not EOS or SEMICOLON, then because it is not a
6527 binary operator (it is NAME, OPEN_PAREN, &c), the expression is
6528 a unit specifier, and parentheses should not be added to it because
6529 they surround the I/O control list that consists of only the unit
6530 specifier. If the next token is EOS or SEMICOLON, the statement
6531 must be disambiguated by looking at the type of the expression -- a
6532 character expression is a parenthesized format specifier, while a
6533 non-character expression is a unit specifier.
6534
6535 Another issue is how to do the callback so the recipient of the
6536 next token knows how to handle it if it is a COMMA. In all other
6537 cases, disambiguation is straightforward: the same approach as the
6538 above is used.
6539
6540 EXTENSION: in COMMA case, if not pedantic, use same disambiguation
6541 as for EOS/SEMICOLON case; f2c allows "READ (cilist) [[,]iolist]"
6542 and apparently other compilers do, as well, and some code out there
6543 uses this "feature".
6544
6545 19-Feb-91 JCB 1.1
6546 Extend to allow COMMA as nondisambiguating by itself. Remember
6547 to not try and check info field for opSTAR, since that expr doesn't
6548 have a valid info field. */
6549
6550 static ffelexHandler
6551 ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t)
6552 {
6553 ffeexprCallback callback;
6554 ffeexprStack_ s;
6555 ffelexHandler next;
6556 ffelexToken orig_ft = ffeexpr_tokens_[0]; /* In case callback clobbers
6557 these. */
6558 ffelexToken orig_t = ffeexpr_tokens_[1];
6559 ffebld expr = ffeexpr_stack_->expr;
6560
6561 switch (ffelex_token_type (t))
6562 {
6563 case FFELEX_typeCOMMA: /* Subexpr is parenthesized format specifier. */
6564 if (ffe_is_pedantic ())
6565 goto pedantic_comma; /* :::::::::::::::::::: */
6566 /* Fall through. */
6567 case FFELEX_typeEOS: /* Ambiguous; use type of expr to
6568 disambiguate. */
6569 case FFELEX_typeSEMICOLON:
6570 if ((expr == NULL) || (ffebld_op (expr) == FFEBLD_opANY)
6571 || (ffebld_op (expr) == FFEBLD_opSTAR)
6572 || (ffeinfo_basictype (ffebld_info (expr))
6573 != FFEINFO_basictypeCHARACTER))
6574 break; /* Not a valid CHARACTER entity, can't be a
6575 format spec. */
6576 /* Fall through. */
6577 default: /* Binary op (we assume; error otherwise);
6578 format specifier. */
6579
6580 pedantic_comma: /* :::::::::::::::::::: */
6581
6582 switch (ffeexpr_stack_->context)
6583 {
6584 case FFEEXPR_contextFILENUMAMBIG:
6585 ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
6586 break;
6587
6588 case FFEEXPR_contextFILEUNITAMBIG:
6589 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
6590 break;
6591
6592 default:
6593 assert ("bad context" == NULL);
6594 break;
6595 }
6596
6597 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
6598 next = (ffelexHandler) ffeexpr_cb_close_paren_ (orig_ft, expr, orig_t);
6599 ffelex_token_kill (orig_ft);
6600 ffelex_token_kill (orig_t);
6601 return (ffelexHandler) (*next) (t);
6602
6603 case FFELEX_typeOPEN_PAREN:/* Non-binary op; beginning of I/O list. */
6604 case FFELEX_typeNAME:
6605 break;
6606 }
6607
6608 expr = ffeexpr_finished_ambig_ (orig_ft, expr);
6609
6610 /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
6611 that preceded the expression starts a list of expressions, and the expr
6612 hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
6613 node. The callback function should extract the real expr from the head
6614 of this opITEM node after testing it. */
6615
6616 expr = ffebld_new_item (expr, NULL);
6617
6618 ffebld_pool_pop ();
6619 callback = ffeexpr_stack_->callback;
6620 ffelex_token_kill (ffeexpr_stack_->first_token);
6621 s = ffeexpr_stack_->previous;
6622 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
6623 ffeexpr_stack_ = s;
6624 next = (ffelexHandler) (*callback) (orig_ft, expr, orig_t);
6625 ffelex_token_kill (orig_ft);
6626 ffelex_token_kill (orig_t);
6627 return (ffelexHandler) (*next) (t);
6628 }
6629
6630 /* ffeexpr_cb_close_paren_c_ -- OPEN_PAREN expr (possible complex)
6631
6632 Pass it to ffeexpr_rhs as the callback routine.
6633
6634 Makes sure the end token is close-paren and swallows it, or a comma
6635 and handles complex/implied-do possibilities, else issues
6636 an error message and doesn't swallow the token (passing it along instead). */
6637
6638 static ffelexHandler
6639 ffeexpr_cb_close_paren_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
6640 {
6641 /* First check to see if this is a possible complex entity. It is if the
6642 token is a comma. */
6643
6644 if (ffelex_token_type (t) == FFELEX_typeCOMMA)
6645 {
6646 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
6647 ffeexpr_stack_->expr = expr;
6648 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
6649 FFEEXPR_contextPAREN_, ffeexpr_cb_comma_c_);
6650 }
6651
6652 return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
6653 }
6654
6655 /* ffeexpr_cb_comma_c_ -- OPEN_PAREN expr COMMA expr
6656
6657 Pass it to ffeexpr_rhs as the callback routine.
6658
6659 If this token is not a comma, we have a complex constant (or an attempt
6660 at one), so handle it accordingly, displaying error messages if the token
6661 is not a close-paren. */
6662
6663 static ffelexHandler
6664 ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
6665 {
6666 ffeexprExpr_ e;
6667 ffeinfoBasictype lty = (ffeexpr_stack_->expr == NULL)
6668 ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (ffeexpr_stack_->expr));
6669 ffeinfoBasictype rty = (expr == NULL)
6670 ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (expr));
6671 ffeinfoKindtype lkt;
6672 ffeinfoKindtype rkt;
6673 ffeinfoKindtype nkt;
6674 bool ok = TRUE;
6675 ffebld orig;
6676
6677 if ((ffeexpr_stack_->expr == NULL)
6678 || (ffebld_op (ffeexpr_stack_->expr) != FFEBLD_opCONTER)
6679 || (((orig = ffebld_conter_orig (ffeexpr_stack_->expr)) != NULL)
6680 && (((ffebld_op (orig) != FFEBLD_opUMINUS)
6681 && (ffebld_op (orig) != FFEBLD_opUPLUS))
6682 || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
6683 || ((lty != FFEINFO_basictypeINTEGER)
6684 && (lty != FFEINFO_basictypeREAL)))
6685 {
6686 if ((lty != FFEINFO_basictypeANY)
6687 && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
6688 {
6689 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
6690 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
6691 ffebad_string ("Real");
6692 ffebad_finish ();
6693 }
6694 ok = FALSE;
6695 }
6696 if ((expr == NULL)
6697 || (ffebld_op (expr) != FFEBLD_opCONTER)
6698 || (((orig = ffebld_conter_orig (expr)) != NULL)
6699 && (((ffebld_op (orig) != FFEBLD_opUMINUS)
6700 && (ffebld_op (orig) != FFEBLD_opUPLUS))
6701 || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
6702 || ((rty != FFEINFO_basictypeINTEGER)
6703 && (rty != FFEINFO_basictypeREAL)))
6704 {
6705 if ((rty != FFEINFO_basictypeANY)
6706 && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
6707 {
6708 ffebad_here (0, ffelex_token_where_line (ft),
6709 ffelex_token_where_column (ft));
6710 ffebad_string ("Imaginary");
6711 ffebad_finish ();
6712 }
6713 ok = FALSE;
6714 }
6715
6716 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
6717
6718 /* Push the (parenthesized) expression as an operand onto the expression
6719 stack. */
6720
6721 e = ffeexpr_expr_new_ ();
6722 e->type = FFEEXPR_exprtypeOPERAND_;
6723 e->token = ffeexpr_stack_->tokens[0];
6724
6725 if (ok)
6726 {
6727 if (lty == FFEINFO_basictypeINTEGER)
6728 lkt = FFEINFO_kindtypeREALDEFAULT;
6729 else
6730 lkt = ffeinfo_kindtype (ffebld_info (ffeexpr_stack_->expr));
6731 if (rty == FFEINFO_basictypeINTEGER)
6732 rkt = FFEINFO_kindtypeREALDEFAULT;
6733 else
6734 rkt = ffeinfo_kindtype (ffebld_info (expr));
6735
6736 nkt = ffeinfo_kindtype_max (FFEINFO_basictypeCOMPLEX, lkt, rkt);
6737 ffeexpr_stack_->expr = ffeexpr_convert (ffeexpr_stack_->expr,
6738 ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
6739 FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
6740 FFEEXPR_contextLET);
6741 expr = ffeexpr_convert (expr,
6742 ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
6743 FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
6744 FFEEXPR_contextLET);
6745 }
6746 else
6747 nkt = FFEINFO_kindtypeANY;
6748
6749 switch (nkt)
6750 {
6751 #if FFETARGET_okCOMPLEX1
6752 case FFEINFO_kindtypeREAL1:
6753 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex1
6754 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
6755 ffebld_set_info (e->u.operand,
6756 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
6757 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
6758 FFETARGET_charactersizeNONE));
6759 break;
6760 #endif
6761
6762 #if FFETARGET_okCOMPLEX2
6763 case FFEINFO_kindtypeREAL2:
6764 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex2
6765 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
6766 ffebld_set_info (e->u.operand,
6767 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
6768 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
6769 FFETARGET_charactersizeNONE));
6770 break;
6771 #endif
6772
6773 #if FFETARGET_okCOMPLEX3
6774 case FFEINFO_kindtypeREAL3:
6775 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex3
6776 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
6777 ffebld_set_info (e->u.operand,
6778 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
6779 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
6780 FFETARGET_charactersizeNONE));
6781 break;
6782 #endif
6783
6784 default:
6785 if (ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
6786 ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX))
6787 {
6788 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
6789 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
6790 ffebad_finish ();
6791 }
6792 /* Fall through. */
6793 case FFEINFO_kindtypeANY:
6794 e->u.operand = ffebld_new_any ();
6795 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
6796 break;
6797 }
6798 ffeexpr_exprstack_push_operand_ (e);
6799
6800 /* Now, if the token is a close parenthese, we're in great shape so return
6801 the next handler. */
6802
6803 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
6804 return (ffelexHandler) ffeexpr_token_binary_;
6805
6806 /* Oops, naughty user didn't specify the close paren! */
6807
6808 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
6809 {
6810 ffebad_here (0, ffelex_token_where_line (t),
6811 ffelex_token_where_column (t));
6812 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
6813 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
6814 ffebad_finish ();
6815 }
6816
6817 return
6818 (ffelexHandler) ffeexpr_find_close_paren_ (t,
6819 (ffelexHandler)
6820 ffeexpr_token_binary_);
6821 }
6822
6823 /* ffeexpr_cb_close_paren_ci_ -- OPEN_PAREN expr (possible complex or
6824 implied-DO construct)
6825
6826 Pass it to ffeexpr_rhs as the callback routine.
6827
6828 Makes sure the end token is close-paren and swallows it, or a comma
6829 and handles complex/implied-do possibilities, else issues
6830 an error message and doesn't swallow the token (passing it along instead). */
6831
6832 static ffelexHandler
6833 ffeexpr_cb_close_paren_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
6834 {
6835 ffeexprContext ctx;
6836
6837 /* First check to see if this is a possible complex or implied-DO entity.
6838 It is if the token is a comma. */
6839
6840 if (ffelex_token_type (t) == FFELEX_typeCOMMA)
6841 {
6842 switch (ffeexpr_stack_->context)
6843 {
6844 case FFEEXPR_contextIOLIST:
6845 case FFEEXPR_contextIMPDOITEM_:
6846 ctx = FFEEXPR_contextIMPDOITEM_;
6847 break;
6848
6849 case FFEEXPR_contextIOLISTDF:
6850 case FFEEXPR_contextIMPDOITEMDF_:
6851 ctx = FFEEXPR_contextIMPDOITEMDF_;
6852 break;
6853
6854 default:
6855 assert ("bad context" == NULL);
6856 ctx = FFEEXPR_contextIMPDOITEM_;
6857 break;
6858 }
6859
6860 ffeexpr_stack_->tokens[0] = ffelex_token_use (ft);
6861 ffeexpr_stack_->expr = expr;
6862 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
6863 ctx, ffeexpr_cb_comma_ci_);
6864 }
6865
6866 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
6867 return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
6868 }
6869
6870 /* ffeexpr_cb_comma_ci_ -- OPEN_PAREN expr COMMA expr
6871
6872 Pass it to ffeexpr_rhs as the callback routine.
6873
6874 If this token is not a comma, we have a complex constant (or an attempt
6875 at one), so handle it accordingly, displaying error messages if the token
6876 is not a close-paren. If we have a comma here, it is an attempt at an
6877 implied-DO, so start making a list accordingly. Oh, it might be an
6878 equal sign also, meaning an implied-DO with only one item in its list. */
6879
6880 static ffelexHandler
6881 ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
6882 {
6883 ffebld fexpr;
6884
6885 /* First check to see if this is a possible complex constant. It is if the
6886 token is not a comma or an equals sign, in which case it should be a
6887 close-paren. */
6888
6889 if ((ffelex_token_type (t) != FFELEX_typeCOMMA)
6890 && (ffelex_token_type (t) != FFELEX_typeEQUALS))
6891 {
6892 ffeexpr_stack_->tokens[1] = ffeexpr_stack_->tokens[0];
6893 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
6894 return (ffelexHandler) ffeexpr_cb_comma_c_ (ft, expr, t);
6895 }
6896
6897 /* Here we have either EQUALS or COMMA, meaning we are in an implied-DO
6898 construct. Make a list and handle accordingly. */
6899
6900 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
6901 fexpr = ffeexpr_stack_->expr;
6902 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
6903 ffebld_append_item (&ffeexpr_stack_->bottom, fexpr);
6904 return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
6905 }
6906
6907 /* ffeexpr_cb_comma_i_ -- OPEN_PAREN expr
6908
6909 Pass it to ffeexpr_rhs as the callback routine.
6910
6911 Handle first item in an implied-DO construct. */
6912
6913 static ffelexHandler
6914 ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr, ffelexToken t)
6915 {
6916 if (ffelex_token_type (t) != FFELEX_typeCOMMA)
6917 {
6918 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
6919 {
6920 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6921 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
6922 ffelex_token_where_column (ffeexpr_stack_->first_token));
6923 ffebad_finish ();
6924 }
6925 ffebld_end_list (&ffeexpr_stack_->bottom);
6926 ffeexpr_stack_->expr = ffebld_new_any ();
6927 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
6928 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
6929 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
6930 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
6931 }
6932
6933 return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
6934 }
6935
6936 /* ffeexpr_cb_comma_i_1_ -- OPEN_PAREN expr
6937
6938 Pass it to ffeexpr_rhs as the callback routine.
6939
6940 Handle first item in an implied-DO construct. */
6941
6942 static ffelexHandler
6943 ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr, ffelexToken t)
6944 {
6945 ffeexprContext ctxi;
6946 ffeexprContext ctxc;
6947
6948 switch (ffeexpr_stack_->context)
6949 {
6950 case FFEEXPR_contextDATA:
6951 case FFEEXPR_contextDATAIMPDOITEM_:
6952 ctxi = FFEEXPR_contextDATAIMPDOITEM_;
6953 ctxc = FFEEXPR_contextDATAIMPDOCTRL_;
6954 break;
6955
6956 case FFEEXPR_contextIOLIST:
6957 case FFEEXPR_contextIMPDOITEM_:
6958 ctxi = FFEEXPR_contextIMPDOITEM_;
6959 ctxc = FFEEXPR_contextIMPDOCTRL_;
6960 break;
6961
6962 case FFEEXPR_contextIOLISTDF:
6963 case FFEEXPR_contextIMPDOITEMDF_:
6964 ctxi = FFEEXPR_contextIMPDOITEMDF_;
6965 ctxc = FFEEXPR_contextIMPDOCTRL_;
6966 break;
6967
6968 default:
6969 assert ("bad context" == NULL);
6970 ctxi = FFEEXPR_context;
6971 ctxc = FFEEXPR_context;
6972 break;
6973 }
6974
6975 switch (ffelex_token_type (t))
6976 {
6977 case FFELEX_typeCOMMA:
6978 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
6979 if (ffeexpr_stack_->is_rhs)
6980 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
6981 ctxi, ffeexpr_cb_comma_i_1_);
6982 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
6983 ctxi, ffeexpr_cb_comma_i_1_);
6984
6985 case FFELEX_typeEQUALS:
6986 ffebld_end_list (&ffeexpr_stack_->bottom);
6987
6988 /* Complain if implied-DO variable in list of items to be read. */
6989
6990 if ((ctxc == FFEEXPR_contextIMPDOCTRL_) && !ffeexpr_stack_->is_rhs)
6991 ffeexpr_check_impdo_ (ffeexpr_stack_->expr,
6992 ffeexpr_stack_->first_token, expr, ft);
6993
6994 /* Set doiter flag for all appropriate SYMTERs. */
6995
6996 ffeexpr_update_impdo_ (ffeexpr_stack_->expr, expr);
6997
6998 ffeexpr_stack_->expr = ffebld_new_impdo (ffeexpr_stack_->expr, NULL);
6999 ffebld_set_info (ffeexpr_stack_->expr,
7000 ffeinfo_new (FFEINFO_basictypeNONE,
7001 FFEINFO_kindtypeNONE,
7002 0,
7003 FFEINFO_kindNONE,
7004 FFEINFO_whereNONE,
7005 FFETARGET_charactersizeNONE));
7006 ffebld_init_list (&(ffebld_right (ffeexpr_stack_->expr)),
7007 &ffeexpr_stack_->bottom);
7008 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7009 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7010 ctxc, ffeexpr_cb_comma_i_2_);
7011
7012 default:
7013 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7014 {
7015 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7016 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7017 ffelex_token_where_column (ffeexpr_stack_->first_token));
7018 ffebad_finish ();
7019 }
7020 ffebld_end_list (&ffeexpr_stack_->bottom);
7021 ffeexpr_stack_->expr = ffebld_new_any ();
7022 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7023 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7024 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7025 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7026 }
7027 }
7028
7029 /* ffeexpr_cb_comma_i_2_ -- OPEN_PAREN expr-list EQUALS expr
7030
7031 Pass it to ffeexpr_rhs as the callback routine.
7032
7033 Handle start-value in an implied-DO construct. */
7034
7035 static ffelexHandler
7036 ffeexpr_cb_comma_i_2_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7037 {
7038 ffeexprContext ctx;
7039
7040 switch (ffeexpr_stack_->context)
7041 {
7042 case FFEEXPR_contextDATA:
7043 case FFEEXPR_contextDATAIMPDOITEM_:
7044 ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7045 break;
7046
7047 case FFEEXPR_contextIOLIST:
7048 case FFEEXPR_contextIOLISTDF:
7049 case FFEEXPR_contextIMPDOITEM_:
7050 case FFEEXPR_contextIMPDOITEMDF_:
7051 ctx = FFEEXPR_contextIMPDOCTRL_;
7052 break;
7053
7054 default:
7055 assert ("bad context" == NULL);
7056 ctx = FFEEXPR_context;
7057 break;
7058 }
7059
7060 switch (ffelex_token_type (t))
7061 {
7062 case FFELEX_typeCOMMA:
7063 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7064 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7065 ctx, ffeexpr_cb_comma_i_3_);
7066 break;
7067
7068 default:
7069 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7070 {
7071 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7072 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7073 ffelex_token_where_column (ffeexpr_stack_->first_token));
7074 ffebad_finish ();
7075 }
7076 ffebld_end_list (&ffeexpr_stack_->bottom);
7077 ffeexpr_stack_->expr = ffebld_new_any ();
7078 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7079 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7080 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7081 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7082 }
7083 }
7084
7085 /* ffeexpr_cb_comma_i_3_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7086
7087 Pass it to ffeexpr_rhs as the callback routine.
7088
7089 Handle end-value in an implied-DO construct. */
7090
7091 static ffelexHandler
7092 ffeexpr_cb_comma_i_3_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7093 {
7094 ffeexprContext ctx;
7095
7096 switch (ffeexpr_stack_->context)
7097 {
7098 case FFEEXPR_contextDATA:
7099 case FFEEXPR_contextDATAIMPDOITEM_:
7100 ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7101 break;
7102
7103 case FFEEXPR_contextIOLIST:
7104 case FFEEXPR_contextIOLISTDF:
7105 case FFEEXPR_contextIMPDOITEM_:
7106 case FFEEXPR_contextIMPDOITEMDF_:
7107 ctx = FFEEXPR_contextIMPDOCTRL_;
7108 break;
7109
7110 default:
7111 assert ("bad context" == NULL);
7112 ctx = FFEEXPR_context;
7113 break;
7114 }
7115
7116 switch (ffelex_token_type (t))
7117 {
7118 case FFELEX_typeCOMMA:
7119 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7120 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7121 ctx, ffeexpr_cb_comma_i_4_);
7122 break;
7123
7124 case FFELEX_typeCLOSE_PAREN:
7125 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7126 return (ffelexHandler) ffeexpr_cb_comma_i_4_ (NULL, NULL, t);
7127 break;
7128
7129 default:
7130 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7131 {
7132 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7133 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7134 ffelex_token_where_column (ffeexpr_stack_->first_token));
7135 ffebad_finish ();
7136 }
7137 ffebld_end_list (&ffeexpr_stack_->bottom);
7138 ffeexpr_stack_->expr = ffebld_new_any ();
7139 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7140 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7141 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7142 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7143 }
7144 }
7145
7146 /* ffeexpr_cb_comma_i_4_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7147 [COMMA expr]
7148
7149 Pass it to ffeexpr_rhs as the callback routine.
7150
7151 Handle incr-value in an implied-DO construct. */
7152
7153 static ffelexHandler
7154 ffeexpr_cb_comma_i_4_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7155 {
7156 switch (ffelex_token_type (t))
7157 {
7158 case FFELEX_typeCLOSE_PAREN:
7159 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7160 ffebld_end_list (&ffeexpr_stack_->bottom);
7161 {
7162 ffebld item;
7163
7164 for (item = ffebld_left (ffeexpr_stack_->expr);
7165 item != NULL;
7166 item = ffebld_trail (item))
7167 if (ffebld_op (ffebld_head (item)) == FFEBLD_opANY)
7168 goto replace_with_any; /* :::::::::::::::::::: */
7169
7170 for (item = ffebld_right (ffeexpr_stack_->expr);
7171 item != NULL;
7172 item = ffebld_trail (item))
7173 if ((ffebld_head (item) != NULL) /* Increment may be NULL. */
7174 && (ffebld_op (ffebld_head (item)) == FFEBLD_opANY))
7175 goto replace_with_any; /* :::::::::::::::::::: */
7176 }
7177 break;
7178
7179 default:
7180 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7181 {
7182 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7183 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7184 ffelex_token_where_column (ffeexpr_stack_->first_token));
7185 ffebad_finish ();
7186 }
7187 ffebld_end_list (&ffeexpr_stack_->bottom);
7188
7189 replace_with_any: /* :::::::::::::::::::: */
7190
7191 ffeexpr_stack_->expr = ffebld_new_any ();
7192 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7193 break;
7194 }
7195
7196 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7197 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7198 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7199 }
7200
7201 /* ffeexpr_cb_comma_i_5_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7202 [COMMA expr] CLOSE_PAREN
7203
7204 Pass it to ffeexpr_rhs as the callback routine.
7205
7206 Collects token following implied-DO construct for callback function. */
7207
7208 static ffelexHandler
7209 ffeexpr_cb_comma_i_5_ (ffelexToken t)
7210 {
7211 ffeexprCallback callback;
7212 ffeexprStack_ s;
7213 ffelexHandler next;
7214 ffelexToken ft;
7215 ffebld expr;
7216 bool terminate;
7217
7218 switch (ffeexpr_stack_->context)
7219 {
7220 case FFEEXPR_contextDATA:
7221 case FFEEXPR_contextDATAIMPDOITEM_:
7222 terminate = TRUE;
7223 break;
7224
7225 case FFEEXPR_contextIOLIST:
7226 case FFEEXPR_contextIOLISTDF:
7227 case FFEEXPR_contextIMPDOITEM_:
7228 case FFEEXPR_contextIMPDOITEMDF_:
7229 terminate = FALSE;
7230 break;
7231
7232 default:
7233 assert ("bad context" == NULL);
7234 terminate = FALSE;
7235 break;
7236 }
7237
7238 ffebld_pool_pop ();
7239 callback = ffeexpr_stack_->callback;
7240 ft = ffeexpr_stack_->first_token;
7241 expr = ffeexpr_stack_->expr;
7242 s = ffeexpr_stack_->previous;
7243 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
7244 sizeof (*ffeexpr_stack_));
7245 ffeexpr_stack_ = s;
7246 next = (ffelexHandler) (*callback) (ft, expr, t);
7247 ffelex_token_kill (ft);
7248 if (terminate)
7249 {
7250 ffesymbol_drive_sfnames (ffeexpr_check_impctrl_);
7251 --ffeexpr_level_;
7252 if (ffeexpr_level_ == 0)
7253 ffe_terminate_4 ();
7254 }
7255 return (ffelexHandler) next;
7256 }
7257
7258 /* ffeexpr_cb_end_loc_ -- Handle end of %LOC subexpression
7259
7260 Makes sure the end token is close-paren and swallows it, else issues
7261 an error message and doesn't swallow the token (passing it along instead).
7262 In either case wraps up subexpression construction by enclosing the
7263 ffebld expression in a %LOC. */
7264
7265 static ffelexHandler
7266 ffeexpr_cb_end_loc_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7267 {
7268 ffeexprExpr_ e;
7269
7270 /* First push the (%LOC) expression as an operand onto the expression
7271 stack. */
7272
7273 e = ffeexpr_expr_new_ ();
7274 e->type = FFEEXPR_exprtypeOPERAND_;
7275 e->token = ffeexpr_stack_->tokens[0];
7276 e->u.operand = ffebld_new_percent_loc (expr);
7277 ffebld_set_info (e->u.operand,
7278 ffeinfo_new (FFEINFO_basictypeINTEGER,
7279 ffecom_pointer_kind (),
7280 0,
7281 FFEINFO_kindENTITY,
7282 FFEINFO_whereFLEETING,
7283 FFETARGET_charactersizeNONE));
7284 #if 0 /* ~~ */
7285 e->u.operand = ffeexpr_collapse_percent_loc (e->u.operand, ft);
7286 #endif
7287 ffeexpr_exprstack_push_operand_ (e);
7288
7289 /* Now, if the token is a close parenthese, we're in great shape so return
7290 the next handler. */
7291
7292 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7293 {
7294 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7295 return (ffelexHandler) ffeexpr_token_binary_;
7296 }
7297
7298 /* Oops, naughty user didn't specify the close paren! */
7299
7300 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7301 {
7302 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7303 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
7304 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
7305 ffebad_finish ();
7306 }
7307
7308 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7309 return
7310 (ffelexHandler) ffeexpr_find_close_paren_ (t,
7311 (ffelexHandler)
7312 ffeexpr_token_binary_);
7313 }
7314
7315 /* ffeexpr_cb_end_notloc_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
7316
7317 Should be CLOSE_PAREN, and make sure expr isn't a %(VAL,REF,DESCR). */
7318
7319 static ffelexHandler
7320 ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr, ffelexToken t)
7321 {
7322 ffeexprExpr_ e;
7323 ffebldOp op;
7324
7325 /* If expression is itself a %(VAL,REF,DESCR), complain and strip off all
7326 such things until the lowest-level expression is reached. */
7327
7328 op = ffebld_op (expr);
7329 if ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
7330 || (op == FFEBLD_opPERCENT_DESCR))
7331 {
7332 if (ffebad_start (FFEBAD_NESTED_PERCENT))
7333 {
7334 ffebad_here (0, ffelex_token_where_line (ft),
7335 ffelex_token_where_column (ft));
7336 ffebad_finish ();
7337 }
7338
7339 do
7340 {
7341 expr = ffebld_left (expr);
7342 op = ffebld_op (expr);
7343 }
7344 while ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
7345 || (op == FFEBLD_opPERCENT_DESCR));
7346 }
7347
7348 /* Push the expression as an operand onto the expression stack. */
7349
7350 e = ffeexpr_expr_new_ ();
7351 e->type = FFEEXPR_exprtypeOPERAND_;
7352 e->token = ffeexpr_stack_->tokens[0];
7353 switch (ffeexpr_stack_->percent)
7354 {
7355 case FFEEXPR_percentVAL_:
7356 e->u.operand = ffebld_new_percent_val (expr);
7357 break;
7358
7359 case FFEEXPR_percentREF_:
7360 e->u.operand = ffebld_new_percent_ref (expr);
7361 break;
7362
7363 case FFEEXPR_percentDESCR_:
7364 e->u.operand = ffebld_new_percent_descr (expr);
7365 break;
7366
7367 default:
7368 assert ("%lossage" == NULL);
7369 e->u.operand = expr;
7370 break;
7371 }
7372 ffebld_set_info (e->u.operand, ffebld_info (expr));
7373 #if 0 /* ~~ */
7374 e->u.operand = ffeexpr_collapse_percent_ ? ? ? (e->u.operand, ft);
7375 #endif
7376 ffeexpr_exprstack_push_operand_ (e);
7377
7378 /* Now, if the token is a close parenthese, we're in great shape so return
7379 the next handler. */
7380
7381 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7382 return (ffelexHandler) ffeexpr_cb_end_notloc_1_;
7383
7384 /* Oops, naughty user didn't specify the close paren! */
7385
7386 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7387 {
7388 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7389 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
7390 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
7391 ffebad_finish ();
7392 }
7393
7394 ffebld_set_op (e->u.operand, FFEBLD_opPERCENT_LOC);
7395
7396 switch (ffeexpr_stack_->context)
7397 {
7398 case FFEEXPR_contextACTUALARG_:
7399 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
7400 break;
7401
7402 case FFEEXPR_contextINDEXORACTUALARG_:
7403 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
7404 break;
7405
7406 case FFEEXPR_contextSFUNCDEFACTUALARG_:
7407 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
7408 break;
7409
7410 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
7411 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
7412 break;
7413
7414 default:
7415 assert ("bad context?!?!" == NULL);
7416 break;
7417 }
7418
7419 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7420 return
7421 (ffelexHandler) ffeexpr_find_close_paren_ (t,
7422 (ffelexHandler)
7423 ffeexpr_cb_end_notloc_1_);
7424 }
7425
7426 /* ffeexpr_cb_end_notloc_1_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
7427 CLOSE_PAREN
7428
7429 Should be COMMA or CLOSE_PAREN, else change back to %LOC. */
7430
7431 static ffelexHandler
7432 ffeexpr_cb_end_notloc_1_ (ffelexToken t)
7433 {
7434 switch (ffelex_token_type (t))
7435 {
7436 case FFELEX_typeCOMMA:
7437 case FFELEX_typeCLOSE_PAREN:
7438 switch (ffeexpr_stack_->context)
7439 {
7440 case FFEEXPR_contextACTUALARG_:
7441 case FFEEXPR_contextSFUNCDEFACTUALARG_:
7442 break;
7443
7444 case FFEEXPR_contextINDEXORACTUALARG_:
7445 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
7446 break;
7447
7448 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
7449 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
7450 break;
7451
7452 default:
7453 assert ("bad context?!?!" == NULL);
7454 break;
7455 }
7456 break;
7457
7458 default:
7459 if (ffebad_start (FFEBAD_INVALID_PERCENT))
7460 {
7461 ffebad_here (0,
7462 ffelex_token_where_line (ffeexpr_stack_->first_token),
7463 ffelex_token_where_column (ffeexpr_stack_->first_token));
7464 ffebad_string (ffelex_token_text (ffeexpr_stack_->tokens[1]));
7465 ffebad_finish ();
7466 }
7467
7468 ffebld_set_op (ffeexpr_stack_->exprstack->u.operand,
7469 FFEBLD_opPERCENT_LOC);
7470
7471 switch (ffeexpr_stack_->context)
7472 {
7473 case FFEEXPR_contextACTUALARG_:
7474 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
7475 break;
7476
7477 case FFEEXPR_contextINDEXORACTUALARG_:
7478 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
7479 break;
7480
7481 case FFEEXPR_contextSFUNCDEFACTUALARG_:
7482 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
7483 break;
7484
7485 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
7486 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
7487 break;
7488
7489 default:
7490 assert ("bad context?!?!" == NULL);
7491 break;
7492 }
7493 }
7494
7495 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7496 return
7497 (ffelexHandler) ffeexpr_token_binary_ (t);
7498 }
7499
7500 /* Process DATA implied-DO iterator variables as this implied-DO level
7501 terminates. At this point, ffeexpr_level_ == 1 when we see the
7502 last right-paren in "DATA (A(I),I=1,10)/.../". */
7503
7504 static ffesymbol
7505 ffeexpr_check_impctrl_ (ffesymbol s)
7506 {
7507 assert (s != NULL);
7508 assert (ffesymbol_sfdummyparent (s) != NULL);
7509
7510 switch (ffesymbol_state (s))
7511 {
7512 case FFESYMBOL_stateNONE: /* Used as iterator already. Now let symbol
7513 be used as iterator at any level at or
7514 innermore than the outermost of the
7515 current level and the symbol's current
7516 level. */
7517 if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
7518 {
7519 ffesymbol_signal_change (s);
7520 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
7521 ffesymbol_signal_unreported (s);
7522 }
7523 break;
7524
7525 case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO.
7526 Error if at outermost level, else it can
7527 still become an iterator. */
7528 if ((ffeexpr_level_ == 1)
7529 && ffebad_start (FFEBAD_BAD_IMPDCL))
7530 {
7531 ffebad_string (ffesymbol_text (s));
7532 ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
7533 ffebad_finish ();
7534 }
7535 break;
7536
7537 case FFESYMBOL_stateUNCERTAIN: /* Iterator. */
7538 assert (ffeexpr_level_ <= ffesymbol_maxentrynum (s));
7539 ffesymbol_signal_change (s);
7540 ffesymbol_set_state (s, FFESYMBOL_stateNONE);
7541 ffesymbol_signal_unreported (s);
7542 break;
7543
7544 case FFESYMBOL_stateUNDERSTOOD:
7545 break; /* ANY. */
7546
7547 default:
7548 assert ("Sasha Foo!!" == NULL);
7549 break;
7550 }
7551
7552 return s;
7553 }
7554
7555 /* Issue diagnostic if implied-DO variable appears in list of lhs
7556 expressions (as in "READ *, (I,I=1,10)"). */
7557
7558 static void
7559 ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
7560 ffebld dovar, ffelexToken dovar_t)
7561 {
7562 ffebld item;
7563 ffesymbol dovar_sym;
7564 int itemnum;
7565
7566 if (ffebld_op (dovar) != FFEBLD_opSYMTER)
7567 return; /* Presumably opANY. */
7568
7569 dovar_sym = ffebld_symter (dovar);
7570
7571 for (itemnum = 1; list != NULL; list = ffebld_trail (list), ++itemnum)
7572 {
7573 if (((item = ffebld_head (list)) != NULL)
7574 && (ffebld_op (item) == FFEBLD_opSYMTER)
7575 && (ffebld_symter (item) == dovar_sym))
7576 {
7577 char itemno[20];
7578
7579 sprintf (&itemno[0], "%d", itemnum);
7580 if (ffebad_start (FFEBAD_DOITER_IMPDO))
7581 {
7582 ffebad_here (0, ffelex_token_where_line (list_t),
7583 ffelex_token_where_column (list_t));
7584 ffebad_here (1, ffelex_token_where_line (dovar_t),
7585 ffelex_token_where_column (dovar_t));
7586 ffebad_string (ffesymbol_text (dovar_sym));
7587 ffebad_string (itemno);
7588 ffebad_finish ();
7589 }
7590 }
7591 }
7592 }
7593
7594 /* Decorate any SYMTERs referencing the DO variable with the "doiter"
7595 flag. */
7596
7597 static void
7598 ffeexpr_update_impdo_ (ffebld list, ffebld dovar)
7599 {
7600 ffesymbol dovar_sym;
7601
7602 if (ffebld_op (dovar) != FFEBLD_opSYMTER)
7603 return; /* Presumably opANY. */
7604
7605 dovar_sym = ffebld_symter (dovar);
7606
7607 ffeexpr_update_impdo_sym_ (list, dovar_sym); /* Recurse! */
7608 }
7609
7610 /* Recursive function to update any expr so SYMTERs have "doiter" flag
7611 if they refer to the given variable. */
7612
7613 static void
7614 ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar)
7615 {
7616 tail_recurse: /* :::::::::::::::::::: */
7617
7618 if (expr == NULL)
7619 return;
7620
7621 switch (ffebld_op (expr))
7622 {
7623 case FFEBLD_opSYMTER:
7624 if (ffebld_symter (expr) == dovar)
7625 ffebld_symter_set_is_doiter (expr, TRUE);
7626 break;
7627
7628 case FFEBLD_opITEM:
7629 ffeexpr_update_impdo_sym_ (ffebld_head (expr), dovar);
7630 expr = ffebld_trail (expr);
7631 goto tail_recurse; /* :::::::::::::::::::: */
7632
7633 default:
7634 break;
7635 }
7636
7637 switch (ffebld_arity (expr))
7638 {
7639 case 2:
7640 ffeexpr_update_impdo_sym_ (ffebld_left (expr), dovar);
7641 expr = ffebld_right (expr);
7642 goto tail_recurse; /* :::::::::::::::::::: */
7643
7644 case 1:
7645 expr = ffebld_left (expr);
7646 goto tail_recurse; /* :::::::::::::::::::: */
7647
7648 default:
7649 break;
7650 }
7651
7652 return;
7653 }
7654
7655 /* ffeexpr_context_outer_ -- Determine context of stack entry, skipping PARENs
7656
7657 if (ffeexpr_context_outer_(ffeexpr_stack_) == FFEEXPR_contextIF)
7658 // After zero or more PAREN_ contexts, an IF context exists */
7659
7660 static ffeexprContext
7661 ffeexpr_context_outer_ (ffeexprStack_ s)
7662 {
7663 assert (s != NULL);
7664
7665 for (;;)
7666 {
7667 switch (s->context)
7668 {
7669 case FFEEXPR_contextPAREN_:
7670 case FFEEXPR_contextPARENFILENUM_:
7671 case FFEEXPR_contextPARENFILEUNIT_:
7672 break;
7673
7674 default:
7675 return s->context;
7676 }
7677 s = s->previous;
7678 assert (s != NULL);
7679 }
7680 }
7681
7682 /* ffeexpr_percent_ -- Look up name in list of %FOO possibilities
7683
7684 ffeexprPercent_ p;
7685 ffelexToken t;
7686 p = ffeexpr_percent_(t);
7687
7688 Returns the identifier for the name, or the NONE identifier. */
7689
7690 static ffeexprPercent_
7691 ffeexpr_percent_ (ffelexToken t)
7692 {
7693 const char *p;
7694
7695 switch (ffelex_token_length (t))
7696 {
7697 case 3:
7698 switch (*(p = ffelex_token_text (t)))
7699 {
7700 case FFESRC_CASE_MATCH_INIT ('L', 'l', match_3l, no_match_3):
7701 if ((ffesrc_char_match_noninit (*++p, 'O', 'o'))
7702 && (ffesrc_char_match_noninit (*++p, 'C', 'c')))
7703 return FFEEXPR_percentLOC_;
7704 return FFEEXPR_percentNONE_;
7705
7706 case FFESRC_CASE_MATCH_INIT ('R', 'r', match_3r, no_match_3):
7707 if ((ffesrc_char_match_noninit (*++p, 'E', 'e'))
7708 && (ffesrc_char_match_noninit (*++p, 'F', 'f')))
7709 return FFEEXPR_percentREF_;
7710 return FFEEXPR_percentNONE_;
7711
7712 case FFESRC_CASE_MATCH_INIT ('V', 'v', match_3v, no_match_3):
7713 if ((ffesrc_char_match_noninit (*++p, 'A', 'a'))
7714 && (ffesrc_char_match_noninit (*++p, 'L', 'l')))
7715 return FFEEXPR_percentVAL_;
7716 return FFEEXPR_percentNONE_;
7717
7718 default:
7719 no_match_3: /* :::::::::::::::::::: */
7720 return FFEEXPR_percentNONE_;
7721 }
7722
7723 case 5:
7724 if (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "DESCR",
7725 "descr", "Descr") == 0)
7726 return FFEEXPR_percentDESCR_;
7727 return FFEEXPR_percentNONE_;
7728
7729 default:
7730 return FFEEXPR_percentNONE_;
7731 }
7732 }
7733
7734 /* ffeexpr_type_combine -- Binop combine types, check for mythical new COMPLEX
7735
7736 See prototype.
7737
7738 If combining the two basictype/kindtype pairs produces a COMPLEX with an
7739 unsupported kind type, complain and use the default kind type for
7740 COMPLEX. */
7741
7742 void
7743 ffeexpr_type_combine (ffeinfoBasictype *xnbt, ffeinfoKindtype *xnkt,
7744 ffeinfoBasictype lbt, ffeinfoKindtype lkt,
7745 ffeinfoBasictype rbt, ffeinfoKindtype rkt,
7746 ffelexToken t)
7747 {
7748 ffeinfoBasictype nbt;
7749 ffeinfoKindtype nkt;
7750
7751 nbt = ffeinfo_basictype_combine (lbt, rbt);
7752 if ((nbt == FFEINFO_basictypeCOMPLEX)
7753 && ((lbt == nbt) || (lbt == FFEINFO_basictypeREAL))
7754 && ((rbt == nbt) || (rbt == FFEINFO_basictypeREAL)))
7755 {
7756 nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
7757 if (ffe_is_pedantic_not_90 () && (nkt == FFEINFO_kindtypeREALDOUBLE))
7758 nkt = FFEINFO_kindtypeNONE; /* Force error. */
7759 switch (nkt)
7760 {
7761 #if FFETARGET_okCOMPLEX1
7762 case FFEINFO_kindtypeREAL1:
7763 #endif
7764 #if FFETARGET_okCOMPLEX2
7765 case FFEINFO_kindtypeREAL2:
7766 #endif
7767 #if FFETARGET_okCOMPLEX3
7768 case FFEINFO_kindtypeREAL3:
7769 #endif
7770 break; /* Fine and dandy. */
7771
7772 default:
7773 if (t != NULL)
7774 {
7775 ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
7776 ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX);
7777 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7778 ffebad_finish ();
7779 }
7780 nbt = FFEINFO_basictypeNONE;
7781 nkt = FFEINFO_kindtypeNONE;
7782 break;
7783
7784 case FFEINFO_kindtypeANY:
7785 nkt = FFEINFO_kindtypeREALDEFAULT;
7786 break;
7787 }
7788 }
7789 else
7790 { /* The normal stuff. */
7791 if (nbt == lbt)
7792 {
7793 if (nbt == rbt)
7794 nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
7795 else
7796 nkt = lkt;
7797 }
7798 else if (nbt == rbt)
7799 nkt = rkt;
7800 else
7801 { /* Let the caller do the complaining. */
7802 nbt = FFEINFO_basictypeNONE;
7803 nkt = FFEINFO_kindtypeNONE;
7804 }
7805 }
7806
7807 /* Always a good idea to avoid aliasing problems. */
7808
7809 *xnbt = nbt;
7810 *xnkt = nkt;
7811 }
7812
7813 /* ffeexpr_token_first_lhs_ -- First state for lhs expression
7814
7815 Return a pointer to this function to the lexer (ffelex), which will
7816 invoke it for the next token.
7817
7818 Record line and column of first token in expression, then invoke the
7819 initial-state lhs handler. */
7820
7821 static ffelexHandler
7822 ffeexpr_token_first_lhs_ (ffelexToken t)
7823 {
7824 ffeexpr_stack_->first_token = ffelex_token_use (t);
7825
7826 /* When changing the list of valid initial lhs tokens, check whether to
7827 update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
7828 READ (expr) <token> case -- it assumes it knows which tokens <token> can
7829 be to indicate an lhs (or implied DO), which right now is the set
7830 {NAME,OPEN_PAREN}.
7831
7832 This comment also appears in ffeexpr_token_lhs_. */
7833
7834 switch (ffelex_token_type (t))
7835 {
7836 case FFELEX_typeOPEN_PAREN:
7837 switch (ffeexpr_stack_->context)
7838 {
7839 case FFEEXPR_contextDATA:
7840 ffe_init_4 ();
7841 ffeexpr_level_ = 1; /* Level of DATA implied-DO construct. */
7842 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7843 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7844 FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
7845
7846 case FFEEXPR_contextDATAIMPDOITEM_:
7847 ++ffeexpr_level_; /* Level of DATA implied-DO construct. */
7848 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7849 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7850 FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
7851
7852 case FFEEXPR_contextIOLIST:
7853 case FFEEXPR_contextIMPDOITEM_:
7854 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7855 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7856 FFEEXPR_contextIMPDOITEM_, ffeexpr_cb_comma_i_);
7857
7858 case FFEEXPR_contextIOLISTDF:
7859 case FFEEXPR_contextIMPDOITEMDF_:
7860 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7861 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7862 FFEEXPR_contextIMPDOITEMDF_, ffeexpr_cb_comma_i_);
7863
7864 case FFEEXPR_contextFILEEXTFUNC:
7865 assert (ffeexpr_stack_->exprstack == NULL);
7866 return (ffelexHandler) ffeexpr_token_first_lhs_1_;
7867
7868 default:
7869 break;
7870 }
7871 break;
7872
7873 case FFELEX_typeNAME:
7874 switch (ffeexpr_stack_->context)
7875 {
7876 case FFEEXPR_contextFILENAMELIST:
7877 assert (ffeexpr_stack_->exprstack == NULL);
7878 return (ffelexHandler) ffeexpr_token_namelist_;
7879
7880 case FFEEXPR_contextFILEEXTFUNC:
7881 assert (ffeexpr_stack_->exprstack == NULL);
7882 return (ffelexHandler) ffeexpr_token_first_lhs_1_;
7883
7884 default:
7885 break;
7886 }
7887 break;
7888
7889 default:
7890 switch (ffeexpr_stack_->context)
7891 {
7892 case FFEEXPR_contextFILEEXTFUNC:
7893 assert (ffeexpr_stack_->exprstack == NULL);
7894 return (ffelexHandler) ffeexpr_token_first_lhs_1_;
7895
7896 default:
7897 break;
7898 }
7899 break;
7900 }
7901
7902 return (ffelexHandler) ffeexpr_token_lhs_ (t);
7903 }
7904
7905 /* ffeexpr_token_first_lhs_1_ -- NAME
7906
7907 return ffeexpr_token_first_lhs_1_; // to lexer
7908
7909 Handle NAME as an external function (USEROPEN= VXT extension to OPEN
7910 statement). */
7911
7912 static ffelexHandler
7913 ffeexpr_token_first_lhs_1_ (ffelexToken t)
7914 {
7915 ffeexprCallback callback;
7916 ffeexprStack_ s;
7917 ffelexHandler next;
7918 ffelexToken ft;
7919 ffesymbol sy = NULL;
7920 ffebld expr;
7921
7922 ffebld_pool_pop ();
7923 callback = ffeexpr_stack_->callback;
7924 ft = ffeexpr_stack_->first_token;
7925 s = ffeexpr_stack_->previous;
7926
7927 if ((ffelex_token_type (ft) != FFELEX_typeNAME)
7928 || (ffesymbol_attrs (sy = ffeexpr_declare_unadorned_ (ft, FALSE))
7929 & FFESYMBOL_attrANY))
7930 {
7931 if ((ffelex_token_type (ft) != FFELEX_typeNAME)
7932 || !(ffesymbol_attrs (sy) & FFESYMBOL_attrsANY))
7933 {
7934 ffebad_start (FFEBAD_EXPR_WRONG);
7935 ffebad_here (0, ffelex_token_where_line (ft),
7936 ffelex_token_where_column (ft));
7937 ffebad_finish ();
7938 }
7939 expr = ffebld_new_any ();
7940 ffebld_set_info (expr, ffeinfo_new_any ());
7941 }
7942 else
7943 {
7944 expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
7945 FFEINTRIN_impNONE);
7946 ffebld_set_info (expr, ffesymbol_info (sy));
7947 }
7948
7949 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
7950 sizeof (*ffeexpr_stack_));
7951 ffeexpr_stack_ = s;
7952
7953 next = (ffelexHandler) (*callback) (ft, expr, t);
7954 ffelex_token_kill (ft);
7955 return (ffelexHandler) next;
7956 }
7957
7958 /* ffeexpr_token_first_rhs_ -- First state for rhs expression
7959
7960 Record line and column of first token in expression, then invoke the
7961 initial-state rhs handler.
7962
7963 19-Feb-91 JCB 1.1
7964 Allow ASTERISK in PARENFILEUNIT_ case, but only on second level only
7965 (i.e. only as in READ(*), not READ((*))). */
7966
7967 static ffelexHandler
7968 ffeexpr_token_first_rhs_ (ffelexToken t)
7969 {
7970 ffesymbol s;
7971
7972 ffeexpr_stack_->first_token = ffelex_token_use (t);
7973
7974 switch (ffelex_token_type (t))
7975 {
7976 case FFELEX_typeASTERISK:
7977 switch (ffeexpr_stack_->context)
7978 {
7979 case FFEEXPR_contextFILEFORMATNML:
7980 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
7981 /* Fall through. */
7982 case FFEEXPR_contextFILEUNIT:
7983 case FFEEXPR_contextDIMLIST:
7984 case FFEEXPR_contextFILEFORMAT:
7985 case FFEEXPR_contextCHARACTERSIZE:
7986 if (ffeexpr_stack_->previous != NULL)
7987 break; /* Valid only on first level. */
7988 assert (ffeexpr_stack_->exprstack == NULL);
7989 return (ffelexHandler) ffeexpr_token_first_rhs_1_;
7990
7991 case FFEEXPR_contextPARENFILEUNIT_:
7992 if (ffeexpr_stack_->previous->previous != NULL)
7993 break; /* Valid only on second level. */
7994 assert (ffeexpr_stack_->exprstack == NULL);
7995 return (ffelexHandler) ffeexpr_token_first_rhs_1_;
7996
7997 case FFEEXPR_contextACTUALARG_:
7998 if (ffeexpr_stack_->previous->context
7999 != FFEEXPR_contextSUBROUTINEREF)
8000 {
8001 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8002 break;
8003 }
8004 assert (ffeexpr_stack_->exprstack == NULL);
8005 return (ffelexHandler) ffeexpr_token_first_rhs_3_;
8006
8007 case FFEEXPR_contextINDEXORACTUALARG_:
8008 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8009 break;
8010
8011 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8012 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8013 break;
8014
8015 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8016 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8017 break;
8018
8019 default:
8020 break;
8021 }
8022 break;
8023
8024 case FFELEX_typeOPEN_PAREN:
8025 switch (ffeexpr_stack_->context)
8026 {
8027 case FFEEXPR_contextFILENUMAMBIG:
8028 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8029 FFEEXPR_contextPARENFILENUM_,
8030 ffeexpr_cb_close_paren_ambig_);
8031
8032 case FFEEXPR_contextFILEUNITAMBIG:
8033 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8034 FFEEXPR_contextPARENFILEUNIT_,
8035 ffeexpr_cb_close_paren_ambig_);
8036
8037 case FFEEXPR_contextIOLIST:
8038 case FFEEXPR_contextIMPDOITEM_:
8039 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8040 FFEEXPR_contextIMPDOITEM_,
8041 ffeexpr_cb_close_paren_ci_);
8042
8043 case FFEEXPR_contextIOLISTDF:
8044 case FFEEXPR_contextIMPDOITEMDF_:
8045 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8046 FFEEXPR_contextIMPDOITEMDF_,
8047 ffeexpr_cb_close_paren_ci_);
8048
8049 case FFEEXPR_contextFILEFORMATNML:
8050 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8051 break;
8052
8053 case FFEEXPR_contextACTUALARG_:
8054 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8055 break;
8056
8057 case FFEEXPR_contextINDEXORACTUALARG_:
8058 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8059 break;
8060
8061 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8062 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8063 break;
8064
8065 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8066 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8067 break;
8068
8069 default:
8070 break;
8071 }
8072 break;
8073
8074 case FFELEX_typeNUMBER:
8075 switch (ffeexpr_stack_->context)
8076 {
8077 case FFEEXPR_contextFILEFORMATNML:
8078 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8079 /* Fall through. */
8080 case FFEEXPR_contextFILEFORMAT:
8081 if (ffeexpr_stack_->previous != NULL)
8082 break; /* Valid only on first level. */
8083 assert (ffeexpr_stack_->exprstack == NULL);
8084 return (ffelexHandler) ffeexpr_token_first_rhs_2_;
8085
8086 case FFEEXPR_contextACTUALARG_:
8087 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8088 break;
8089
8090 case FFEEXPR_contextINDEXORACTUALARG_:
8091 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8092 break;
8093
8094 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8095 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8096 break;
8097
8098 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8099 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8100 break;
8101
8102 default:
8103 break;
8104 }
8105 break;
8106
8107 case FFELEX_typeNAME:
8108 switch (ffeexpr_stack_->context)
8109 {
8110 case FFEEXPR_contextFILEFORMATNML:
8111 assert (ffeexpr_stack_->exprstack == NULL);
8112 s = ffesymbol_lookup_local (t);
8113 if ((s != NULL) && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST))
8114 return (ffelexHandler) ffeexpr_token_namelist_;
8115 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8116 break;
8117
8118 default:
8119 break;
8120 }
8121 break;
8122
8123 case FFELEX_typePERCENT:
8124 switch (ffeexpr_stack_->context)
8125 {
8126 case FFEEXPR_contextACTUALARG_:
8127 case FFEEXPR_contextINDEXORACTUALARG_:
8128 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8129 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8130 return (ffelexHandler) ffeexpr_token_first_rhs_5_;
8131
8132 case FFEEXPR_contextFILEFORMATNML:
8133 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8134 break;
8135
8136 default:
8137 break;
8138 }
8139
8140 default:
8141 switch (ffeexpr_stack_->context)
8142 {
8143 case FFEEXPR_contextACTUALARG_:
8144 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8145 break;
8146
8147 case FFEEXPR_contextINDEXORACTUALARG_:
8148 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8149 break;
8150
8151 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8152 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8153 break;
8154
8155 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8156 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8157 break;
8158
8159 case FFEEXPR_contextFILEFORMATNML:
8160 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8161 break;
8162
8163 default:
8164 break;
8165 }
8166 break;
8167 }
8168
8169 return (ffelexHandler) ffeexpr_token_rhs_ (t);
8170 }
8171
8172 /* ffeexpr_token_first_rhs_1_ -- ASTERISK
8173
8174 return ffeexpr_token_first_rhs_1_; // to lexer
8175
8176 Return STAR as expression. */
8177
8178 static ffelexHandler
8179 ffeexpr_token_first_rhs_1_ (ffelexToken t)
8180 {
8181 ffebld expr;
8182 ffeexprCallback callback;
8183 ffeexprStack_ s;
8184 ffelexHandler next;
8185 ffelexToken ft;
8186
8187 expr = ffebld_new_star ();
8188 ffebld_pool_pop ();
8189 callback = ffeexpr_stack_->callback;
8190 ft = ffeexpr_stack_->first_token;
8191 s = ffeexpr_stack_->previous;
8192 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
8193 ffeexpr_stack_ = s;
8194 next = (ffelexHandler) (*callback) (ft, expr, t);
8195 ffelex_token_kill (ft);
8196 return (ffelexHandler) next;
8197 }
8198
8199 /* ffeexpr_token_first_rhs_2_ -- NUMBER
8200
8201 return ffeexpr_token_first_rhs_2_; // to lexer
8202
8203 Return NULL as expression; NUMBER as first (and only) token, unless the
8204 current token is not a terminating token, in which case run normal
8205 expression handling. */
8206
8207 static ffelexHandler
8208 ffeexpr_token_first_rhs_2_ (ffelexToken t)
8209 {
8210 ffeexprCallback callback;
8211 ffeexprStack_ s;
8212 ffelexHandler next;
8213 ffelexToken ft;
8214
8215 switch (ffelex_token_type (t))
8216 {
8217 case FFELEX_typeCLOSE_PAREN:
8218 case FFELEX_typeCOMMA:
8219 case FFELEX_typeEOS:
8220 case FFELEX_typeSEMICOLON:
8221 break;
8222
8223 default:
8224 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
8225 return (ffelexHandler) (*next) (t);
8226 }
8227
8228 ffebld_pool_pop ();
8229 callback = ffeexpr_stack_->callback;
8230 ft = ffeexpr_stack_->first_token;
8231 s = ffeexpr_stack_->previous;
8232 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
8233 sizeof (*ffeexpr_stack_));
8234 ffeexpr_stack_ = s;
8235 next = (ffelexHandler) (*callback) (ft, NULL, t);
8236 ffelex_token_kill (ft);
8237 return (ffelexHandler) next;
8238 }
8239
8240 /* ffeexpr_token_first_rhs_3_ -- ASTERISK
8241
8242 return ffeexpr_token_first_rhs_3_; // to lexer
8243
8244 Expect NUMBER, make LABTOK (with copy of token if not inhibited after
8245 confirming, else NULL). */
8246
8247 static ffelexHandler
8248 ffeexpr_token_first_rhs_3_ (ffelexToken t)
8249 {
8250 ffelexHandler next;
8251
8252 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
8253 { /* An error, but let normal processing handle
8254 it. */
8255 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
8256 return (ffelexHandler) (*next) (t);
8257 }
8258
8259 /* Special case: when we see "*10" as an argument to a subroutine
8260 reference, we confirm the current statement and, if not inhibited at
8261 this point, put a copy of the token into a LABTOK node. We do this
8262 instead of just resolving the label directly via ffelab and putting it
8263 into a LABTER simply to improve error reporting and consistency in
8264 ffestc. We put NULL in the LABTOK if we're still inhibited, so ffestb
8265 doesn't have to worry about killing off any tokens when retracting. */
8266
8267 ffest_confirmed ();
8268 if (ffest_is_inhibited ())
8269 ffeexpr_stack_->expr = ffebld_new_labtok (NULL);
8270 else
8271 ffeexpr_stack_->expr = ffebld_new_labtok (ffelex_token_use (t));
8272 ffebld_set_info (ffeexpr_stack_->expr,
8273 ffeinfo_new (FFEINFO_basictypeNONE,
8274 FFEINFO_kindtypeNONE,
8275 0,
8276 FFEINFO_kindNONE,
8277 FFEINFO_whereNONE,
8278 FFETARGET_charactersizeNONE));
8279
8280 return (ffelexHandler) ffeexpr_token_first_rhs_4_;
8281 }
8282
8283 /* ffeexpr_token_first_rhs_4_ -- ASTERISK NUMBER
8284
8285 return ffeexpr_token_first_rhs_4_; // to lexer
8286
8287 Collect/flush appropriate stuff, send token to callback function. */
8288
8289 static ffelexHandler
8290 ffeexpr_token_first_rhs_4_ (ffelexToken t)
8291 {
8292 ffebld expr;
8293 ffeexprCallback callback;
8294 ffeexprStack_ s;
8295 ffelexHandler next;
8296 ffelexToken ft;
8297
8298 expr = ffeexpr_stack_->expr;
8299 ffebld_pool_pop ();
8300 callback = ffeexpr_stack_->callback;
8301 ft = ffeexpr_stack_->first_token;
8302 s = ffeexpr_stack_->previous;
8303 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
8304 ffeexpr_stack_ = s;
8305 next = (ffelexHandler) (*callback) (ft, expr, t);
8306 ffelex_token_kill (ft);
8307 return (ffelexHandler) next;
8308 }
8309
8310 /* ffeexpr_token_first_rhs_5_ -- PERCENT
8311
8312 Should be NAME, or pass through original mechanism. If NAME is LOC,
8313 pass through original mechanism, otherwise must be VAL, REF, or DESCR,
8314 in which case handle the argument (in parentheses), etc. */
8315
8316 static ffelexHandler
8317 ffeexpr_token_first_rhs_5_ (ffelexToken t)
8318 {
8319 ffelexHandler next;
8320
8321 if (ffelex_token_type (t) == FFELEX_typeNAME)
8322 {
8323 ffeexprPercent_ p = ffeexpr_percent_ (t);
8324
8325 switch (p)
8326 {
8327 case FFEEXPR_percentNONE_:
8328 case FFEEXPR_percentLOC_:
8329 break; /* Treat %LOC as any other expression. */
8330
8331 case FFEEXPR_percentVAL_:
8332 case FFEEXPR_percentREF_:
8333 case FFEEXPR_percentDESCR_:
8334 ffeexpr_stack_->percent = p;
8335 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
8336 return (ffelexHandler) ffeexpr_token_first_rhs_6_;
8337
8338 default:
8339 assert ("bad percent?!?" == NULL);
8340 break;
8341 }
8342 }
8343
8344 switch (ffeexpr_stack_->context)
8345 {
8346 case FFEEXPR_contextACTUALARG_:
8347 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8348 break;
8349
8350 case FFEEXPR_contextINDEXORACTUALARG_:
8351 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8352 break;
8353
8354 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8355 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8356 break;
8357
8358 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8359 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8360 break;
8361
8362 default:
8363 assert ("bad context?!?!" == NULL);
8364 break;
8365 }
8366
8367 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
8368 return (ffelexHandler) (*next) (t);
8369 }
8370
8371 /* ffeexpr_token_first_rhs_6_ -- PERCENT NAME(VAL,REF,DESCR)
8372
8373 Should be OPEN_PAREN, or pass through original mechanism. */
8374
8375 static ffelexHandler
8376 ffeexpr_token_first_rhs_6_ (ffelexToken t)
8377 {
8378 ffelexHandler next;
8379 ffelexToken ft;
8380
8381 if (ffelex_token_type (t) == FFELEX_typeOPEN_PAREN)
8382 {
8383 ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
8384 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8385 ffeexpr_stack_->context,
8386 ffeexpr_cb_end_notloc_);
8387 }
8388
8389 switch (ffeexpr_stack_->context)
8390 {
8391 case FFEEXPR_contextACTUALARG_:
8392 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8393 break;
8394
8395 case FFEEXPR_contextINDEXORACTUALARG_:
8396 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8397 break;
8398
8399 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8400 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8401 break;
8402
8403 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8404 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8405 break;
8406
8407 default:
8408 assert ("bad context?!?!" == NULL);
8409 break;
8410 }
8411
8412 ft = ffeexpr_stack_->tokens[0];
8413 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
8414 next = (ffelexHandler) (*next) (ft);
8415 ffelex_token_kill (ft);
8416 return (ffelexHandler) (*next) (t);
8417 }
8418
8419 /* ffeexpr_token_namelist_ -- NAME
8420
8421 return ffeexpr_token_namelist_; // to lexer
8422
8423 Make sure NAME was a valid namelist object, wrap it in a SYMTER and
8424 return. */
8425
8426 static ffelexHandler
8427 ffeexpr_token_namelist_ (ffelexToken t)
8428 {
8429 ffeexprCallback callback;
8430 ffeexprStack_ s;
8431 ffelexHandler next;
8432 ffelexToken ft;
8433 ffesymbol sy;
8434 ffebld expr;
8435
8436 ffebld_pool_pop ();
8437 callback = ffeexpr_stack_->callback;
8438 ft = ffeexpr_stack_->first_token;
8439 s = ffeexpr_stack_->previous;
8440 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
8441 ffeexpr_stack_ = s;
8442
8443 sy = ffesymbol_lookup_local (ft);
8444 if ((sy == NULL) || (ffesymbol_kind (sy) != FFEINFO_kindNAMELIST))
8445 {
8446 ffebad_start (FFEBAD_EXPR_WRONG);
8447 ffebad_here (0, ffelex_token_where_line (ft),
8448 ffelex_token_where_column (ft));
8449 ffebad_finish ();
8450 expr = ffebld_new_any ();
8451 ffebld_set_info (expr, ffeinfo_new_any ());
8452 }
8453 else
8454 {
8455 expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
8456 FFEINTRIN_impNONE);
8457 ffebld_set_info (expr, ffesymbol_info (sy));
8458 }
8459 next = (ffelexHandler) (*callback) (ft, expr, t);
8460 ffelex_token_kill (ft);
8461 return (ffelexHandler) next;
8462 }
8463
8464 /* ffeexpr_expr_kill_ -- Kill an existing internal expression object
8465
8466 ffeexprExpr_ e;
8467 ffeexpr_expr_kill_(e);
8468
8469 Kills the ffewhere info, if necessary, then kills the object. */
8470
8471 static void
8472 ffeexpr_expr_kill_ (ffeexprExpr_ e)
8473 {
8474 if (e->token != NULL)
8475 ffelex_token_kill (e->token);
8476 malloc_kill_ks (ffe_pool_program_unit (), e, sizeof (*e));
8477 }
8478
8479 /* ffeexpr_expr_new_ -- Make a new internal expression object
8480
8481 ffeexprExpr_ e;
8482 e = ffeexpr_expr_new_();
8483
8484 Allocates and initializes a new expression object, returns it. */
8485
8486 static ffeexprExpr_
8487 ffeexpr_expr_new_ (void)
8488 {
8489 ffeexprExpr_ e;
8490
8491 e = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR expr", sizeof (*e));
8492 e->previous = NULL;
8493 e->type = FFEEXPR_exprtypeUNKNOWN_;
8494 e->token = NULL;
8495 return e;
8496 }
8497
8498 /* Verify that call to global is valid, and register whatever
8499 new information about a global might be discoverable by looking
8500 at the call. */
8501
8502 static void
8503 ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t)
8504 {
8505 int n_args;
8506 ffebld list;
8507 ffebld item;
8508 ffesymbol s;
8509
8510 assert ((ffebld_op (*expr) == FFEBLD_opSUBRREF)
8511 || (ffebld_op (*expr) == FFEBLD_opFUNCREF));
8512
8513 if (ffebld_op (ffebld_left (*expr)) != FFEBLD_opSYMTER)
8514 return;
8515
8516 if (ffesymbol_retractable ())
8517 return;
8518
8519 s = ffebld_symter (ffebld_left (*expr));
8520 if (ffesymbol_global (s) == NULL)
8521 return;
8522
8523 for (n_args = 0, list = ffebld_right (*expr);
8524 list != NULL;
8525 list = ffebld_trail (list), ++n_args)
8526 ;
8527
8528 if (ffeglobal_proc_ref_nargs (s, n_args, t))
8529 {
8530 ffeglobalArgSummary as;
8531 ffeinfoBasictype bt;
8532 ffeinfoKindtype kt;
8533 bool array;
8534 bool fail = FALSE;
8535
8536 for (n_args = 0, list = ffebld_right (*expr);
8537 list != NULL;
8538 list = ffebld_trail (list), ++n_args)
8539 {
8540 item = ffebld_head (list);
8541 if (item != NULL)
8542 {
8543 bt = ffeinfo_basictype (ffebld_info (item));
8544 kt = ffeinfo_kindtype (ffebld_info (item));
8545 array = (ffeinfo_rank (ffebld_info (item)) > 0);
8546 switch (ffebld_op (item))
8547 {
8548 case FFEBLD_opLABTOK:
8549 case FFEBLD_opLABTER:
8550 as = FFEGLOBAL_argsummaryALTRTN;
8551 break;
8552
8553 #if 0
8554 /* No, %LOC(foo) is just like any INTEGER(KIND=7)
8555 expression, so don't treat it specially. */
8556 case FFEBLD_opPERCENT_LOC:
8557 as = FFEGLOBAL_argsummaryPTR;
8558 break;
8559 #endif
8560
8561 case FFEBLD_opPERCENT_VAL:
8562 as = FFEGLOBAL_argsummaryVAL;
8563 break;
8564
8565 case FFEBLD_opPERCENT_REF:
8566 as = FFEGLOBAL_argsummaryREF;
8567 break;
8568
8569 case FFEBLD_opPERCENT_DESCR:
8570 as = FFEGLOBAL_argsummaryDESCR;
8571 break;
8572
8573 case FFEBLD_opFUNCREF:
8574 #if 0
8575 /* No, LOC(foo) is just like any INTEGER(KIND=7)
8576 expression, so don't treat it specially. */
8577 if ((ffebld_op (ffebld_left (item)) == FFEBLD_opSYMTER)
8578 && (ffesymbol_specific (ffebld_symter (ffebld_left (item)))
8579 == FFEINTRIN_specLOC))
8580 {
8581 as = FFEGLOBAL_argsummaryPTR;
8582 break;
8583 }
8584 #endif
8585 /* Fall through. */
8586 default:
8587 if (ffebld_op (item) == FFEBLD_opSYMTER)
8588 {
8589 as = FFEGLOBAL_argsummaryNONE;
8590
8591 switch (ffeinfo_kind (ffebld_info (item)))
8592 {
8593 case FFEINFO_kindFUNCTION:
8594 as = FFEGLOBAL_argsummaryFUNC;
8595 break;
8596
8597 case FFEINFO_kindSUBROUTINE:
8598 as = FFEGLOBAL_argsummarySUBR;
8599 break;
8600
8601 case FFEINFO_kindNONE:
8602 as = FFEGLOBAL_argsummaryPROC;
8603 break;
8604
8605 default:
8606 break;
8607 }
8608
8609 if (as != FFEGLOBAL_argsummaryNONE)
8610 break;
8611 }
8612
8613 if (bt == FFEINFO_basictypeCHARACTER)
8614 as = FFEGLOBAL_argsummaryDESCR;
8615 else
8616 as = FFEGLOBAL_argsummaryREF;
8617 break;
8618 }
8619 }
8620 else
8621 {
8622 array = FALSE;
8623 as = FFEGLOBAL_argsummaryNONE;
8624 bt = FFEINFO_basictypeNONE;
8625 kt = FFEINFO_kindtypeNONE;
8626 }
8627
8628 if (! ffeglobal_proc_ref_arg (s, n_args, as, bt, kt, array, t))
8629 fail = TRUE;
8630 }
8631 if (! fail)
8632 return;
8633 }
8634
8635 *expr = ffebld_new_any ();
8636 ffebld_set_info (*expr, ffeinfo_new_any ());
8637 }
8638
8639 /* Check whether rest of string is all decimal digits. */
8640
8641 static bool
8642 ffeexpr_isdigits_ (const char *p)
8643 {
8644 for (; *p != '\0'; ++p)
8645 if (! ISDIGIT (*p))
8646 return FALSE;
8647 return TRUE;
8648 }
8649
8650 /* ffeexpr_exprstack_push_ -- Push an arbitrary expression object onto the stack
8651
8652 ffeexprExpr_ e;
8653 ffeexpr_exprstack_push_(e);
8654
8655 Pushes the expression onto the stack without any analysis of the existing
8656 contents of the stack. */
8657
8658 static void
8659 ffeexpr_exprstack_push_ (ffeexprExpr_ e)
8660 {
8661 e->previous = ffeexpr_stack_->exprstack;
8662 ffeexpr_stack_->exprstack = e;
8663 }
8664
8665 /* ffeexpr_exprstack_push_operand_ -- Push an operand onto the stack, reduce?
8666
8667 ffeexprExpr_ e;
8668 ffeexpr_exprstack_push_operand_(e);
8669
8670 Pushes the expression already containing an operand (a constant, variable,
8671 or more complicated expression that has already been fully resolved) after
8672 analyzing the stack and checking for possible reduction (which will never
8673 happen here since the highest precedence operator is ** and it has right-
8674 to-left associativity). */
8675
8676 static void
8677 ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e)
8678 {
8679 ffeexpr_exprstack_push_ (e);
8680 }
8681
8682 /* ffeexpr_exprstack_push_unary_ -- Push a unary operator onto the stack
8683
8684 ffeexprExpr_ e;
8685 ffeexpr_exprstack_push_unary_(e);
8686
8687 Pushes the expression already containing a unary operator. Reduction can
8688 never happen since unary operators are themselves always R-L; that is, the
8689 top of the expression stack is not an operand, in that it is either empty,
8690 has a binary operator at the top, or a unary operator at the top. In any
8691 of these cases, reduction is impossible. */
8692
8693 static void
8694 ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e)
8695 {
8696 if ((ffe_is_pedantic ()
8697 || ffe_is_warn_surprising ())
8698 && (ffeexpr_stack_->exprstack != NULL)
8699 && (ffeexpr_stack_->exprstack->type != FFEEXPR_exprtypeOPERAND_)
8700 && (ffeexpr_stack_->exprstack->u.operator.prec
8701 <= FFEEXPR_operatorprecedenceLOWARITH_)
8702 && (e->u.operator.prec <= FFEEXPR_operatorprecedenceLOWARITH_))
8703 {
8704 /* xgettext:no-c-format */
8705 ffebad_start_msg ("Two arithmetic operators in a row at %0 and %1 -- use parentheses",
8706 ffe_is_pedantic ()
8707 ? FFEBAD_severityPEDANTIC
8708 : FFEBAD_severityWARNING);
8709 ffebad_here (0,
8710 ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
8711 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
8712 ffebad_here (1,
8713 ffelex_token_where_line (e->token),
8714 ffelex_token_where_column (e->token));
8715 ffebad_finish ();
8716 }
8717
8718 ffeexpr_exprstack_push_ (e);
8719 }
8720
8721 /* ffeexpr_exprstack_push_binary_ -- Push a binary operator onto the stack, reduce?
8722
8723 ffeexprExpr_ e;
8724 ffeexpr_exprstack_push_binary_(e);
8725
8726 Pushes the expression already containing a binary operator after checking
8727 whether reduction is possible. If the stack is not empty, the top of the
8728 stack must be an operand or syntactic analysis has failed somehow. If
8729 the operand is preceded by a unary operator of higher (or equal and L-R
8730 associativity) precedence than the new binary operator, then reduce that
8731 preceding operator and its operand(s) before pushing the new binary
8732 operator. */
8733
8734 static void
8735 ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e)
8736 {
8737 ffeexprExpr_ ce;
8738
8739 if (ffe_is_warn_surprising ()
8740 /* These next two are always true (see assertions below). */
8741 && (ffeexpr_stack_->exprstack != NULL)
8742 && (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_)
8743 /* If the previous operator is a unary minus, and the binary op
8744 is of higher precedence, might not do what user expects,
8745 e.g. "-2**2" is "-(2**2)", i.e. "-4", not "(-2)**2", which would
8746 yield "4". */
8747 && (ffeexpr_stack_->exprstack->previous != NULL)
8748 && (ffeexpr_stack_->exprstack->previous->type == FFEEXPR_exprtypeUNARY_)
8749 && (ffeexpr_stack_->exprstack->previous->u.operator.op
8750 == FFEEXPR_operatorSUBTRACT_)
8751 && (e->u.operator.prec
8752 < ffeexpr_stack_->exprstack->previous->u.operator.prec))
8753 {
8754 /* xgettext:no-c-format */
8755 ffebad_start_msg ("Operator at %0 has lower precedence than that at %1 -- use parentheses", FFEBAD_severityWARNING);
8756 ffebad_here (0,
8757 ffelex_token_where_line (ffeexpr_stack_->exprstack->previous->token),
8758 ffelex_token_where_column (ffeexpr_stack_->exprstack->previous->token));
8759 ffebad_here (1,
8760 ffelex_token_where_line (e->token),
8761 ffelex_token_where_column (e->token));
8762 ffebad_finish ();
8763 }
8764
8765 again:
8766 assert (ffeexpr_stack_->exprstack != NULL);
8767 assert (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_);
8768 if ((ce = ffeexpr_stack_->exprstack->previous) != NULL)
8769 {
8770 assert (ce->type != FFEEXPR_exprtypeOPERAND_);
8771 if ((ce->u.operator.prec < e->u.operator.prec)
8772 || ((ce->u.operator.prec == e->u.operator.prec)
8773 && (e->u.operator.as == FFEEXPR_operatorassociativityL2R_)))
8774 {
8775 ffeexpr_reduce_ ();
8776 goto again; /* :::::::::::::::::::: */
8777 }
8778 }
8779
8780 ffeexpr_exprstack_push_ (e);
8781 }
8782
8783 /* ffeexpr_reduce_ -- Reduce highest operator w/operands on stack
8784
8785 ffeexpr_reduce_();
8786
8787 Converts operand binop operand or unop operand at top of stack to a
8788 single operand having the appropriate ffebld expression, and makes
8789 sure that the expression is proper (like not trying to add two character
8790 variables, not trying to concatenate two numbers). Also does the
8791 requisite type-assignment. */
8792
8793 static void
8794 ffeexpr_reduce_ (void)
8795 {
8796 ffeexprExpr_ operand; /* This is B in -B or A+B. */
8797 ffeexprExpr_ left_operand; /* When operator is binary, this is A in A+B. */
8798 ffeexprExpr_ operator; /* This is + in A+B. */
8799 ffebld reduced; /* This is +(A,B) in A+B or u-(B) in -B. */
8800 ffebldConstant constnode; /* For checking magical numbers (where mag ==
8801 -mag). */
8802 ffebld expr;
8803 ffebld left_expr;
8804 bool submag = FALSE;
8805
8806 operand = ffeexpr_stack_->exprstack;
8807 assert (operand != NULL);
8808 assert (operand->type == FFEEXPR_exprtypeOPERAND_);
8809 operator = operand->previous;
8810 assert (operator != NULL);
8811 assert (operator->type != FFEEXPR_exprtypeOPERAND_);
8812 if (operator->type == FFEEXPR_exprtypeUNARY_)
8813 {
8814 expr = operand->u.operand;
8815 switch (operator->u.operator.op)
8816 {
8817 case FFEEXPR_operatorADD_:
8818 reduced = ffebld_new_uplus (expr);
8819 if (ffe_is_ugly_logint ())
8820 reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
8821 reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
8822 reduced = ffeexpr_collapse_uplus (reduced, operator->token);
8823 break;
8824
8825 case FFEEXPR_operatorSUBTRACT_:
8826 submag = TRUE; /* Ok to negate a magic number. */
8827 reduced = ffebld_new_uminus (expr);
8828 if (ffe_is_ugly_logint ())
8829 reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
8830 reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
8831 reduced = ffeexpr_collapse_uminus (reduced, operator->token);
8832 break;
8833
8834 case FFEEXPR_operatorNOT_:
8835 reduced = ffebld_new_not (expr);
8836 if (ffe_is_ugly_logint ())
8837 reduced = ffeexpr_reduced_ugly1log_ (reduced, operator, operand);
8838 reduced = ffeexpr_reduced_bool1_ (reduced, operator, operand);
8839 reduced = ffeexpr_collapse_not (reduced, operator->token);
8840 break;
8841
8842 default:
8843 assert ("unexpected unary op" != NULL);
8844 reduced = NULL;
8845 break;
8846 }
8847 if (!submag
8848 && (ffebld_op (expr) == FFEBLD_opCONTER)
8849 && (ffebld_conter_orig (expr) == NULL)
8850 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
8851 {
8852 ffetarget_integer_bad_magical (operand->token);
8853 }
8854 ffeexpr_stack_->exprstack = operator->previous; /* Pops unary-op operand
8855 off stack. */
8856 ffeexpr_expr_kill_ (operand);
8857 operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but
8858 save */
8859 operator->u.operand = reduced; /* the line/column ffewhere info. */
8860 ffeexpr_exprstack_push_operand_ (operator); /* Push it back on
8861 stack. */
8862 }
8863 else
8864 {
8865 assert (operator->type == FFEEXPR_exprtypeBINARY_);
8866 left_operand = operator->previous;
8867 assert (left_operand != NULL);
8868 assert (left_operand->type == FFEEXPR_exprtypeOPERAND_);
8869 expr = operand->u.operand;
8870 left_expr = left_operand->u.operand;
8871 switch (operator->u.operator.op)
8872 {
8873 case FFEEXPR_operatorADD_:
8874 reduced = ffebld_new_add (left_expr, expr);
8875 if (ffe_is_ugly_logint ())
8876 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8877 operand);
8878 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
8879 operand);
8880 reduced = ffeexpr_collapse_add (reduced, operator->token);
8881 break;
8882
8883 case FFEEXPR_operatorSUBTRACT_:
8884 submag = TRUE; /* Just to pick the right error if magic
8885 number. */
8886 reduced = ffebld_new_subtract (left_expr, expr);
8887 if (ffe_is_ugly_logint ())
8888 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8889 operand);
8890 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
8891 operand);
8892 reduced = ffeexpr_collapse_subtract (reduced, operator->token);
8893 break;
8894
8895 case FFEEXPR_operatorMULTIPLY_:
8896 reduced = ffebld_new_multiply (left_expr, expr);
8897 if (ffe_is_ugly_logint ())
8898 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8899 operand);
8900 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
8901 operand);
8902 reduced = ffeexpr_collapse_multiply (reduced, operator->token);
8903 break;
8904
8905 case FFEEXPR_operatorDIVIDE_:
8906 reduced = ffebld_new_divide (left_expr, expr);
8907 if (ffe_is_ugly_logint ())
8908 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8909 operand);
8910 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
8911 operand);
8912 reduced = ffeexpr_collapse_divide (reduced, operator->token);
8913 break;
8914
8915 case FFEEXPR_operatorPOWER_:
8916 reduced = ffebld_new_power (left_expr, expr);
8917 if (ffe_is_ugly_logint ())
8918 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8919 operand);
8920 reduced = ffeexpr_reduced_power_ (reduced, left_operand, operator,
8921 operand);
8922 reduced = ffeexpr_collapse_power (reduced, operator->token);
8923 break;
8924
8925 case FFEEXPR_operatorCONCATENATE_:
8926 reduced = ffebld_new_concatenate (left_expr, expr);
8927 reduced = ffeexpr_reduced_concatenate_ (reduced, left_operand, operator,
8928 operand);
8929 reduced = ffeexpr_collapse_concatenate (reduced, operator->token);
8930 break;
8931
8932 case FFEEXPR_operatorLT_:
8933 reduced = ffebld_new_lt (left_expr, expr);
8934 if (ffe_is_ugly_logint ())
8935 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8936 operand);
8937 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
8938 operand);
8939 reduced = ffeexpr_collapse_lt (reduced, operator->token);
8940 break;
8941
8942 case FFEEXPR_operatorLE_:
8943 reduced = ffebld_new_le (left_expr, expr);
8944 if (ffe_is_ugly_logint ())
8945 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8946 operand);
8947 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
8948 operand);
8949 reduced = ffeexpr_collapse_le (reduced, operator->token);
8950 break;
8951
8952 case FFEEXPR_operatorEQ_:
8953 reduced = ffebld_new_eq (left_expr, expr);
8954 if (ffe_is_ugly_logint ())
8955 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8956 operand);
8957 reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
8958 operand);
8959 reduced = ffeexpr_collapse_eq (reduced, operator->token);
8960 break;
8961
8962 case FFEEXPR_operatorNE_:
8963 reduced = ffebld_new_ne (left_expr, expr);
8964 if (ffe_is_ugly_logint ())
8965 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8966 operand);
8967 reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
8968 operand);
8969 reduced = ffeexpr_collapse_ne (reduced, operator->token);
8970 break;
8971
8972 case FFEEXPR_operatorGT_:
8973 reduced = ffebld_new_gt (left_expr, expr);
8974 if (ffe_is_ugly_logint ())
8975 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8976 operand);
8977 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
8978 operand);
8979 reduced = ffeexpr_collapse_gt (reduced, operator->token);
8980 break;
8981
8982 case FFEEXPR_operatorGE_:
8983 reduced = ffebld_new_ge (left_expr, expr);
8984 if (ffe_is_ugly_logint ())
8985 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8986 operand);
8987 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
8988 operand);
8989 reduced = ffeexpr_collapse_ge (reduced, operator->token);
8990 break;
8991
8992 case FFEEXPR_operatorAND_:
8993 reduced = ffebld_new_and (left_expr, expr);
8994 if (ffe_is_ugly_logint ())
8995 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
8996 operand);
8997 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
8998 operand);
8999 reduced = ffeexpr_collapse_and (reduced, operator->token);
9000 break;
9001
9002 case FFEEXPR_operatorOR_:
9003 reduced = ffebld_new_or (left_expr, expr);
9004 if (ffe_is_ugly_logint ())
9005 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9006 operand);
9007 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9008 operand);
9009 reduced = ffeexpr_collapse_or (reduced, operator->token);
9010 break;
9011
9012 case FFEEXPR_operatorXOR_:
9013 reduced = ffebld_new_xor (left_expr, expr);
9014 if (ffe_is_ugly_logint ())
9015 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9016 operand);
9017 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9018 operand);
9019 reduced = ffeexpr_collapse_xor (reduced, operator->token);
9020 break;
9021
9022 case FFEEXPR_operatorEQV_:
9023 reduced = ffebld_new_eqv (left_expr, expr);
9024 if (ffe_is_ugly_logint ())
9025 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9026 operand);
9027 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9028 operand);
9029 reduced = ffeexpr_collapse_eqv (reduced, operator->token);
9030 break;
9031
9032 case FFEEXPR_operatorNEQV_:
9033 reduced = ffebld_new_neqv (left_expr, expr);
9034 if (ffe_is_ugly_logint ())
9035 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9036 operand);
9037 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9038 operand);
9039 reduced = ffeexpr_collapse_neqv (reduced, operator->token);
9040 break;
9041
9042 default:
9043 assert ("bad bin op" == NULL);
9044 reduced = expr;
9045 break;
9046 }
9047 if ((ffebld_op (left_expr) == FFEBLD_opCONTER)
9048 && (ffebld_conter_orig (expr) == NULL)
9049 && ffebld_constant_is_magical (constnode = ffebld_conter (left_expr)))
9050 {
9051 if ((left_operand->previous != NULL)
9052 && (left_operand->previous->type != FFEEXPR_exprtypeOPERAND_)
9053 && (left_operand->previous->u.operator.op
9054 == FFEEXPR_operatorSUBTRACT_))
9055 {
9056 if (left_operand->previous->type == FFEEXPR_exprtypeUNARY_)
9057 ffetarget_integer_bad_magical_precedence (left_operand->token,
9058 left_operand->previous->token,
9059 operator->token);
9060 else
9061 ffetarget_integer_bad_magical_precedence_binary
9062 (left_operand->token,
9063 left_operand->previous->token,
9064 operator->token);
9065 }
9066 else
9067 ffetarget_integer_bad_magical (left_operand->token);
9068 }
9069 if ((ffebld_op (expr) == FFEBLD_opCONTER)
9070 && (ffebld_conter_orig (expr) == NULL)
9071 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
9072 {
9073 if (submag)
9074 ffetarget_integer_bad_magical_binary (operand->token,
9075 operator->token);
9076 else
9077 ffetarget_integer_bad_magical (operand->token);
9078 }
9079 ffeexpr_stack_->exprstack = left_operand->previous; /* Pops binary-op
9080 operands off stack. */
9081 ffeexpr_expr_kill_ (left_operand);
9082 ffeexpr_expr_kill_ (operand);
9083 operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but
9084 save */
9085 operator->u.operand = reduced; /* the line/column ffewhere info. */
9086 ffeexpr_exprstack_push_operand_ (operator); /* Push it back on
9087 stack. */
9088 }
9089 }
9090
9091 /* ffeexpr_reduced_bool1_ -- Wrap up reduction of NOT operator
9092
9093 reduced = ffeexpr_reduced_bool1_(reduced,op,r);
9094
9095 Makes sure the argument for reduced has basictype of
9096 LOGICAL or (ugly) INTEGER. If
9097 argument has where of CONSTANT, assign where CONSTANT to
9098 reduced, else assign where FLEETING.
9099
9100 If these requirements cannot be met, generate error message. */
9101
9102 static ffebld
9103 ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
9104 {
9105 ffeinfo rinfo, ninfo;
9106 ffeinfoBasictype rbt;
9107 ffeinfoKindtype rkt;
9108 ffeinfoRank rrk;
9109 ffeinfoKind rkd;
9110 ffeinfoWhere rwh, nwh;
9111
9112 rinfo = ffebld_info (ffebld_left (reduced));
9113 rbt = ffeinfo_basictype (rinfo);
9114 rkt = ffeinfo_kindtype (rinfo);
9115 rrk = ffeinfo_rank (rinfo);
9116 rkd = ffeinfo_kind (rinfo);
9117 rwh = ffeinfo_where (rinfo);
9118
9119 if (((rbt == FFEINFO_basictypeLOGICAL)
9120 || (ffe_is_ugly_logint () && (rbt == FFEINFO_basictypeINTEGER)))
9121 && (rrk == 0))
9122 {
9123 switch (rwh)
9124 {
9125 case FFEINFO_whereCONSTANT:
9126 nwh = FFEINFO_whereCONSTANT;
9127 break;
9128
9129 case FFEINFO_whereIMMEDIATE:
9130 nwh = FFEINFO_whereIMMEDIATE;
9131 break;
9132
9133 default:
9134 nwh = FFEINFO_whereFLEETING;
9135 break;
9136 }
9137
9138 ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
9139 FFETARGET_charactersizeNONE);
9140 ffebld_set_info (reduced, ninfo);
9141 return reduced;
9142 }
9143
9144 if ((rbt != FFEINFO_basictypeLOGICAL)
9145 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
9146 {
9147 if ((rbt != FFEINFO_basictypeANY)
9148 && ffebad_start (FFEBAD_NOT_ARG_TYPE))
9149 {
9150 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9151 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9152 ffebad_finish ();
9153 }
9154 }
9155 else
9156 {
9157 if ((rkd != FFEINFO_kindANY)
9158 && ffebad_start (FFEBAD_NOT_ARG_KIND))
9159 {
9160 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9161 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9162 ffebad_string ("an array");
9163 ffebad_finish ();
9164 }
9165 }
9166
9167 reduced = ffebld_new_any ();
9168 ffebld_set_info (reduced, ffeinfo_new_any ());
9169 return reduced;
9170 }
9171
9172 /* ffeexpr_reduced_bool2_ -- Wrap up reduction of boolean operators
9173
9174 reduced = ffeexpr_reduced_bool2_(reduced,l,op,r);
9175
9176 Makes sure the left and right arguments for reduced have basictype of
9177 LOGICAL or (ugly) INTEGER. Determine common basictype and
9178 size for reduction (flag expression for combined hollerith/typeless
9179 situations for later determination of effective basictype). If both left
9180 and right arguments have where of CONSTANT, assign where CONSTANT to
9181 reduced, else assign where FLEETING. Create CONVERT ops for args where
9182 needed. Convert typeless
9183 constants to the desired type/size explicitly.
9184
9185 If these requirements cannot be met, generate error message. */
9186
9187 static ffebld
9188 ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9189 ffeexprExpr_ r)
9190 {
9191 ffeinfo linfo, rinfo, ninfo;
9192 ffeinfoBasictype lbt, rbt, nbt;
9193 ffeinfoKindtype lkt, rkt, nkt;
9194 ffeinfoRank lrk, rrk;
9195 ffeinfoKind lkd, rkd;
9196 ffeinfoWhere lwh, rwh, nwh;
9197
9198 linfo = ffebld_info (ffebld_left (reduced));
9199 lbt = ffeinfo_basictype (linfo);
9200 lkt = ffeinfo_kindtype (linfo);
9201 lrk = ffeinfo_rank (linfo);
9202 lkd = ffeinfo_kind (linfo);
9203 lwh = ffeinfo_where (linfo);
9204
9205 rinfo = ffebld_info (ffebld_right (reduced));
9206 rbt = ffeinfo_basictype (rinfo);
9207 rkt = ffeinfo_kindtype (rinfo);
9208 rrk = ffeinfo_rank (rinfo);
9209 rkd = ffeinfo_kind (rinfo);
9210 rwh = ffeinfo_where (rinfo);
9211
9212 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
9213
9214 if (((nbt == FFEINFO_basictypeLOGICAL)
9215 || (ffe_is_ugly_logint () && (nbt == FFEINFO_basictypeINTEGER)))
9216 && (lrk == 0) && (rrk == 0))
9217 {
9218 switch (lwh)
9219 {
9220 case FFEINFO_whereCONSTANT:
9221 switch (rwh)
9222 {
9223 case FFEINFO_whereCONSTANT:
9224 nwh = FFEINFO_whereCONSTANT;
9225 break;
9226
9227 case FFEINFO_whereIMMEDIATE:
9228 nwh = FFEINFO_whereIMMEDIATE;
9229 break;
9230
9231 default:
9232 nwh = FFEINFO_whereFLEETING;
9233 break;
9234 }
9235 break;
9236
9237 case FFEINFO_whereIMMEDIATE:
9238 switch (rwh)
9239 {
9240 case FFEINFO_whereCONSTANT:
9241 case FFEINFO_whereIMMEDIATE:
9242 nwh = FFEINFO_whereIMMEDIATE;
9243 break;
9244
9245 default:
9246 nwh = FFEINFO_whereFLEETING;
9247 break;
9248 }
9249 break;
9250
9251 default:
9252 nwh = FFEINFO_whereFLEETING;
9253 break;
9254 }
9255
9256 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
9257 FFETARGET_charactersizeNONE);
9258 ffebld_set_info (reduced, ninfo);
9259 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
9260 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
9261 FFEEXPR_contextLET));
9262 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
9263 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
9264 FFEEXPR_contextLET));
9265 return reduced;
9266 }
9267
9268 if ((lbt != FFEINFO_basictypeLOGICAL)
9269 && (!ffe_is_ugly_logint () || (lbt != FFEINFO_basictypeINTEGER)))
9270 {
9271 if ((rbt != FFEINFO_basictypeLOGICAL)
9272 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
9273 {
9274 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
9275 && ffebad_start (FFEBAD_BOOL_ARGS_TYPE))
9276 {
9277 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9278 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9279 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9280 ffebad_finish ();
9281 }
9282 }
9283 else
9284 {
9285 if ((lbt != FFEINFO_basictypeANY)
9286 && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
9287 {
9288 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9289 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9290 ffebad_finish ();
9291 }
9292 }
9293 }
9294 else if ((rbt != FFEINFO_basictypeLOGICAL)
9295 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
9296 {
9297 if ((rbt != FFEINFO_basictypeANY)
9298 && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
9299 {
9300 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9301 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9302 ffebad_finish ();
9303 }
9304 }
9305 else if (lrk != 0)
9306 {
9307 if ((lkd != FFEINFO_kindANY)
9308 && ffebad_start (FFEBAD_BOOL_ARG_KIND))
9309 {
9310 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9311 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9312 ffebad_string ("an array");
9313 ffebad_finish ();
9314 }
9315 }
9316 else
9317 {
9318 if ((rkd != FFEINFO_kindANY)
9319 && ffebad_start (FFEBAD_BOOL_ARG_KIND))
9320 {
9321 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9322 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9323 ffebad_string ("an array");
9324 ffebad_finish ();
9325 }
9326 }
9327
9328 reduced = ffebld_new_any ();
9329 ffebld_set_info (reduced, ffeinfo_new_any ());
9330 return reduced;
9331 }
9332
9333 /* ffeexpr_reduced_concatenate_ -- Wrap up reduction of concatenate operator
9334
9335 reduced = ffeexpr_reduced_concatenate_(reduced,l,op,r);
9336
9337 Makes sure the left and right arguments for reduced have basictype of
9338 CHARACTER and kind of SCALAR, FUNCTION, or STATEMENT FUNCTION. Assign
9339 basictype of CHARACTER and kind of SCALAR to reduced. Calculate effective
9340 size of concatenation and assign that size to reduced. If both left and
9341 right arguments have where of CONSTANT, assign where CONSTANT to reduced,
9342 else assign where FLEETING.
9343
9344 If these requirements cannot be met, generate error message using the
9345 info in l, op, and r arguments and assign basictype, size, kind, and where
9346 of ANY. */
9347
9348 static ffebld
9349 ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9350 ffeexprExpr_ r)
9351 {
9352 ffeinfo linfo, rinfo, ninfo;
9353 ffeinfoBasictype lbt, rbt, nbt;
9354 ffeinfoKindtype lkt, rkt, nkt;
9355 ffeinfoRank lrk, rrk;
9356 ffeinfoKind lkd, rkd, nkd;
9357 ffeinfoWhere lwh, rwh, nwh;
9358 ffetargetCharacterSize lszm, lszk, rszm, rszk, nszk;
9359
9360 linfo = ffebld_info (ffebld_left (reduced));
9361 lbt = ffeinfo_basictype (linfo);
9362 lkt = ffeinfo_kindtype (linfo);
9363 lrk = ffeinfo_rank (linfo);
9364 lkd = ffeinfo_kind (linfo);
9365 lwh = ffeinfo_where (linfo);
9366 lszk = ffeinfo_size (linfo); /* Known size. */
9367 lszm = ffebld_size_max (ffebld_left (reduced));
9368
9369 rinfo = ffebld_info (ffebld_right (reduced));
9370 rbt = ffeinfo_basictype (rinfo);
9371 rkt = ffeinfo_kindtype (rinfo);
9372 rrk = ffeinfo_rank (rinfo);
9373 rkd = ffeinfo_kind (rinfo);
9374 rwh = ffeinfo_where (rinfo);
9375 rszk = ffeinfo_size (rinfo); /* Known size. */
9376 rszm = ffebld_size_max (ffebld_right (reduced));
9377
9378 if ((lbt == FFEINFO_basictypeCHARACTER) && (rbt == FFEINFO_basictypeCHARACTER)
9379 && (lkt == rkt) && (lrk == 0) && (rrk == 0)
9380 && (((lszm != FFETARGET_charactersizeNONE)
9381 && (rszm != FFETARGET_charactersizeNONE))
9382 || (ffeexpr_context_outer_ (ffeexpr_stack_)
9383 == FFEEXPR_contextLET)
9384 || (ffeexpr_context_outer_ (ffeexpr_stack_)
9385 == FFEEXPR_contextSFUNCDEF)))
9386 {
9387 nbt = FFEINFO_basictypeCHARACTER;
9388 nkd = FFEINFO_kindENTITY;
9389 if ((lszk == FFETARGET_charactersizeNONE)
9390 || (rszk == FFETARGET_charactersizeNONE))
9391 nszk = FFETARGET_charactersizeNONE; /* Ok only in rhs of LET
9392 stmt. */
9393 else
9394 nszk = lszk + rszk;
9395
9396 switch (lwh)
9397 {
9398 case FFEINFO_whereCONSTANT:
9399 switch (rwh)
9400 {
9401 case FFEINFO_whereCONSTANT:
9402 nwh = FFEINFO_whereCONSTANT;
9403 break;
9404
9405 case FFEINFO_whereIMMEDIATE:
9406 nwh = FFEINFO_whereIMMEDIATE;
9407 break;
9408
9409 default:
9410 nwh = FFEINFO_whereFLEETING;
9411 break;
9412 }
9413 break;
9414
9415 case FFEINFO_whereIMMEDIATE:
9416 switch (rwh)
9417 {
9418 case FFEINFO_whereCONSTANT:
9419 case FFEINFO_whereIMMEDIATE:
9420 nwh = FFEINFO_whereIMMEDIATE;
9421 break;
9422
9423 default:
9424 nwh = FFEINFO_whereFLEETING;
9425 break;
9426 }
9427 break;
9428
9429 default:
9430 nwh = FFEINFO_whereFLEETING;
9431 break;
9432 }
9433
9434 nkt = lkt;
9435 ninfo = ffeinfo_new (nbt, nkt, 0, nkd, nwh, nszk);
9436 ffebld_set_info (reduced, ninfo);
9437 return reduced;
9438 }
9439
9440 if ((lbt != FFEINFO_basictypeCHARACTER) && (rbt != FFEINFO_basictypeCHARACTER))
9441 {
9442 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
9443 && ffebad_start (FFEBAD_CONCAT_ARGS_TYPE))
9444 {
9445 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9446 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9447 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9448 ffebad_finish ();
9449 }
9450 }
9451 else if (lbt != FFEINFO_basictypeCHARACTER)
9452 {
9453 if ((lbt != FFEINFO_basictypeANY)
9454 && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
9455 {
9456 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9457 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9458 ffebad_finish ();
9459 }
9460 }
9461 else if (rbt != FFEINFO_basictypeCHARACTER)
9462 {
9463 if ((rbt != FFEINFO_basictypeANY)
9464 && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
9465 {
9466 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9467 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9468 ffebad_finish ();
9469 }
9470 }
9471 else if ((lrk != 0) || (lszm == FFETARGET_charactersizeNONE))
9472 {
9473 if ((lkd != FFEINFO_kindANY)
9474 && ffebad_start (FFEBAD_CONCAT_ARG_KIND))
9475 {
9476 const char *what;
9477
9478 if (lrk != 0)
9479 what = "an array";
9480 else
9481 what = "of indeterminate length";
9482 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9483 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9484 ffebad_string (what);
9485 ffebad_finish ();
9486 }
9487 }
9488 else
9489 {
9490 if (ffebad_start (FFEBAD_CONCAT_ARG_KIND))
9491 {
9492 const char *what;
9493
9494 if (rrk != 0)
9495 what = "an array";
9496 else
9497 what = "of indeterminate length";
9498 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9499 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9500 ffebad_string (what);
9501 ffebad_finish ();
9502 }
9503 }
9504
9505 reduced = ffebld_new_any ();
9506 ffebld_set_info (reduced, ffeinfo_new_any ());
9507 return reduced;
9508 }
9509
9510 /* ffeexpr_reduced_eqop2_ -- Wrap up reduction of EQ and NE operators
9511
9512 reduced = ffeexpr_reduced_eqop2_(reduced,l,op,r);
9513
9514 Makes sure the left and right arguments for reduced have basictype of
9515 INTEGER, REAL, COMPLEX, or CHARACTER. Determine common basictype and
9516 size for reduction. If both left
9517 and right arguments have where of CONSTANT, assign where CONSTANT to
9518 reduced, else assign where FLEETING. Create CONVERT ops for args where
9519 needed. Convert typeless
9520 constants to the desired type/size explicitly.
9521
9522 If these requirements cannot be met, generate error message. */
9523
9524 static ffebld
9525 ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9526 ffeexprExpr_ r)
9527 {
9528 ffeinfo linfo, rinfo, ninfo;
9529 ffeinfoBasictype lbt, rbt, nbt;
9530 ffeinfoKindtype lkt, rkt, nkt;
9531 ffeinfoRank lrk, rrk;
9532 ffeinfoKind lkd, rkd;
9533 ffeinfoWhere lwh, rwh, nwh;
9534 ffetargetCharacterSize lsz, rsz;
9535
9536 linfo = ffebld_info (ffebld_left (reduced));
9537 lbt = ffeinfo_basictype (linfo);
9538 lkt = ffeinfo_kindtype (linfo);
9539 lrk = ffeinfo_rank (linfo);
9540 lkd = ffeinfo_kind (linfo);
9541 lwh = ffeinfo_where (linfo);
9542 lsz = ffebld_size_known (ffebld_left (reduced));
9543
9544 rinfo = ffebld_info (ffebld_right (reduced));
9545 rbt = ffeinfo_basictype (rinfo);
9546 rkt = ffeinfo_kindtype (rinfo);
9547 rrk = ffeinfo_rank (rinfo);
9548 rkd = ffeinfo_kind (rinfo);
9549 rwh = ffeinfo_where (rinfo);
9550 rsz = ffebld_size_known (ffebld_right (reduced));
9551
9552 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
9553
9554 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
9555 || (nbt == FFEINFO_basictypeCOMPLEX) || (nbt == FFEINFO_basictypeCHARACTER))
9556 && (lrk == 0) && (rrk == 0))
9557 {
9558 switch (lwh)
9559 {
9560 case FFEINFO_whereCONSTANT:
9561 switch (rwh)
9562 {
9563 case FFEINFO_whereCONSTANT:
9564 nwh = FFEINFO_whereCONSTANT;
9565 break;
9566
9567 case FFEINFO_whereIMMEDIATE:
9568 nwh = FFEINFO_whereIMMEDIATE;
9569 break;
9570
9571 default:
9572 nwh = FFEINFO_whereFLEETING;
9573 break;
9574 }
9575 break;
9576
9577 case FFEINFO_whereIMMEDIATE:
9578 switch (rwh)
9579 {
9580 case FFEINFO_whereCONSTANT:
9581 case FFEINFO_whereIMMEDIATE:
9582 nwh = FFEINFO_whereIMMEDIATE;
9583 break;
9584
9585 default:
9586 nwh = FFEINFO_whereFLEETING;
9587 break;
9588 }
9589 break;
9590
9591 default:
9592 nwh = FFEINFO_whereFLEETING;
9593 break;
9594 }
9595
9596 if ((lsz != FFETARGET_charactersizeNONE)
9597 && (rsz != FFETARGET_charactersizeNONE))
9598 lsz = rsz = (lsz > rsz) ? lsz : rsz;
9599
9600 ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
9601 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
9602 ffebld_set_info (reduced, ninfo);
9603 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
9604 l->token, op->token, nbt, nkt, 0, lsz,
9605 FFEEXPR_contextLET));
9606 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
9607 r->token, op->token, nbt, nkt, 0, rsz,
9608 FFEEXPR_contextLET));
9609 return reduced;
9610 }
9611
9612 if ((lbt == FFEINFO_basictypeLOGICAL)
9613 && (rbt == FFEINFO_basictypeLOGICAL))
9614 {
9615 /* xgettext:no-c-format */
9616 if (ffebad_start_msg ("Use .EQV./.NEQV. instead of .EQ./.NE. at %0 for LOGICAL operands at %1 and %2",
9617 FFEBAD_severityFATAL))
9618 {
9619 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9620 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9621 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9622 ffebad_finish ();
9623 }
9624 }
9625 else if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
9626 && (lbt != FFEINFO_basictypeCOMPLEX) && (lbt != FFEINFO_basictypeCHARACTER))
9627 {
9628 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
9629 && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
9630 {
9631 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
9632 && ffebad_start (FFEBAD_EQOP_ARGS_TYPE))
9633 {
9634 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9635 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9636 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9637 ffebad_finish ();
9638 }
9639 }
9640 else
9641 {
9642 if ((lbt != FFEINFO_basictypeANY)
9643 && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
9644 {
9645 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9646 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9647 ffebad_finish ();
9648 }
9649 }
9650 }
9651 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
9652 && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
9653 {
9654 if ((rbt != FFEINFO_basictypeANY)
9655 && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
9656 {
9657 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9658 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9659 ffebad_finish ();
9660 }
9661 }
9662 else if (lrk != 0)
9663 {
9664 if ((lkd != FFEINFO_kindANY)
9665 && ffebad_start (FFEBAD_EQOP_ARG_KIND))
9666 {
9667 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9668 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9669 ffebad_string ("an array");
9670 ffebad_finish ();
9671 }
9672 }
9673 else
9674 {
9675 if ((rkd != FFEINFO_kindANY)
9676 && ffebad_start (FFEBAD_EQOP_ARG_KIND))
9677 {
9678 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9679 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9680 ffebad_string ("an array");
9681 ffebad_finish ();
9682 }
9683 }
9684
9685 reduced = ffebld_new_any ();
9686 ffebld_set_info (reduced, ffeinfo_new_any ());
9687 return reduced;
9688 }
9689
9690 /* ffeexpr_reduced_math1_ -- Wrap up reduction of + - unary operators
9691
9692 reduced = ffeexpr_reduced_math1_(reduced,op,r);
9693
9694 Makes sure the argument for reduced has basictype of
9695 INTEGER, REAL, or COMPLEX. If the argument has where of CONSTANT,
9696 assign where CONSTANT to
9697 reduced, else assign where FLEETING.
9698
9699 If these requirements cannot be met, generate error message. */
9700
9701 static ffebld
9702 ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
9703 {
9704 ffeinfo rinfo, ninfo;
9705 ffeinfoBasictype rbt;
9706 ffeinfoKindtype rkt;
9707 ffeinfoRank rrk;
9708 ffeinfoKind rkd;
9709 ffeinfoWhere rwh, nwh;
9710
9711 rinfo = ffebld_info (ffebld_left (reduced));
9712 rbt = ffeinfo_basictype (rinfo);
9713 rkt = ffeinfo_kindtype (rinfo);
9714 rrk = ffeinfo_rank (rinfo);
9715 rkd = ffeinfo_kind (rinfo);
9716 rwh = ffeinfo_where (rinfo);
9717
9718 if (((rbt == FFEINFO_basictypeINTEGER) || (rbt == FFEINFO_basictypeREAL)
9719 || (rbt == FFEINFO_basictypeCOMPLEX)) && (rrk == 0))
9720 {
9721 switch (rwh)
9722 {
9723 case FFEINFO_whereCONSTANT:
9724 nwh = FFEINFO_whereCONSTANT;
9725 break;
9726
9727 case FFEINFO_whereIMMEDIATE:
9728 nwh = FFEINFO_whereIMMEDIATE;
9729 break;
9730
9731 default:
9732 nwh = FFEINFO_whereFLEETING;
9733 break;
9734 }
9735
9736 ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
9737 FFETARGET_charactersizeNONE);
9738 ffebld_set_info (reduced, ninfo);
9739 return reduced;
9740 }
9741
9742 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
9743 && (rbt != FFEINFO_basictypeCOMPLEX))
9744 {
9745 if ((rbt != FFEINFO_basictypeANY)
9746 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
9747 {
9748 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9749 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9750 ffebad_finish ();
9751 }
9752 }
9753 else
9754 {
9755 if ((rkd != FFEINFO_kindANY)
9756 && ffebad_start (FFEBAD_MATH_ARG_KIND))
9757 {
9758 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9759 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9760 ffebad_string ("an array");
9761 ffebad_finish ();
9762 }
9763 }
9764
9765 reduced = ffebld_new_any ();
9766 ffebld_set_info (reduced, ffeinfo_new_any ());
9767 return reduced;
9768 }
9769
9770 /* ffeexpr_reduced_math2_ -- Wrap up reduction of + - * / operators
9771
9772 reduced = ffeexpr_reduced_math2_(reduced,l,op,r);
9773
9774 Makes sure the left and right arguments for reduced have basictype of
9775 INTEGER, REAL, or COMPLEX. Determine common basictype and
9776 size for reduction (flag expression for combined hollerith/typeless
9777 situations for later determination of effective basictype). If both left
9778 and right arguments have where of CONSTANT, assign where CONSTANT to
9779 reduced, else assign where FLEETING. Create CONVERT ops for args where
9780 needed. Convert typeless
9781 constants to the desired type/size explicitly.
9782
9783 If these requirements cannot be met, generate error message. */
9784
9785 static ffebld
9786 ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9787 ffeexprExpr_ r)
9788 {
9789 ffeinfo linfo, rinfo, ninfo;
9790 ffeinfoBasictype lbt, rbt, nbt;
9791 ffeinfoKindtype lkt, rkt, nkt;
9792 ffeinfoRank lrk, rrk;
9793 ffeinfoKind lkd, rkd;
9794 ffeinfoWhere lwh, rwh, nwh;
9795
9796 linfo = ffebld_info (ffebld_left (reduced));
9797 lbt = ffeinfo_basictype (linfo);
9798 lkt = ffeinfo_kindtype (linfo);
9799 lrk = ffeinfo_rank (linfo);
9800 lkd = ffeinfo_kind (linfo);
9801 lwh = ffeinfo_where (linfo);
9802
9803 rinfo = ffebld_info (ffebld_right (reduced));
9804 rbt = ffeinfo_basictype (rinfo);
9805 rkt = ffeinfo_kindtype (rinfo);
9806 rrk = ffeinfo_rank (rinfo);
9807 rkd = ffeinfo_kind (rinfo);
9808 rwh = ffeinfo_where (rinfo);
9809
9810 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
9811
9812 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
9813 || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
9814 {
9815 switch (lwh)
9816 {
9817 case FFEINFO_whereCONSTANT:
9818 switch (rwh)
9819 {
9820 case FFEINFO_whereCONSTANT:
9821 nwh = FFEINFO_whereCONSTANT;
9822 break;
9823
9824 case FFEINFO_whereIMMEDIATE:
9825 nwh = FFEINFO_whereIMMEDIATE;
9826 break;
9827
9828 default:
9829 nwh = FFEINFO_whereFLEETING;
9830 break;
9831 }
9832 break;
9833
9834 case FFEINFO_whereIMMEDIATE:
9835 switch (rwh)
9836 {
9837 case FFEINFO_whereCONSTANT:
9838 case FFEINFO_whereIMMEDIATE:
9839 nwh = FFEINFO_whereIMMEDIATE;
9840 break;
9841
9842 default:
9843 nwh = FFEINFO_whereFLEETING;
9844 break;
9845 }
9846 break;
9847
9848 default:
9849 nwh = FFEINFO_whereFLEETING;
9850 break;
9851 }
9852
9853 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
9854 FFETARGET_charactersizeNONE);
9855 ffebld_set_info (reduced, ninfo);
9856 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
9857 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
9858 FFEEXPR_contextLET));
9859 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
9860 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
9861 FFEEXPR_contextLET));
9862 return reduced;
9863 }
9864
9865 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
9866 && (lbt != FFEINFO_basictypeCOMPLEX))
9867 {
9868 if ((rbt != FFEINFO_basictypeINTEGER)
9869 && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
9870 {
9871 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
9872 && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
9873 {
9874 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9875 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9876 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9877 ffebad_finish ();
9878 }
9879 }
9880 else
9881 {
9882 if ((lbt != FFEINFO_basictypeANY)
9883 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
9884 {
9885 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9886 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9887 ffebad_finish ();
9888 }
9889 }
9890 }
9891 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
9892 && (rbt != FFEINFO_basictypeCOMPLEX))
9893 {
9894 if ((rbt != FFEINFO_basictypeANY)
9895 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
9896 {
9897 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9898 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9899 ffebad_finish ();
9900 }
9901 }
9902 else if (lrk != 0)
9903 {
9904 if ((lkd != FFEINFO_kindANY)
9905 && ffebad_start (FFEBAD_MATH_ARG_KIND))
9906 {
9907 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9908 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9909 ffebad_string ("an array");
9910 ffebad_finish ();
9911 }
9912 }
9913 else
9914 {
9915 if ((rkd != FFEINFO_kindANY)
9916 && ffebad_start (FFEBAD_MATH_ARG_KIND))
9917 {
9918 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9919 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9920 ffebad_string ("an array");
9921 ffebad_finish ();
9922 }
9923 }
9924
9925 reduced = ffebld_new_any ();
9926 ffebld_set_info (reduced, ffeinfo_new_any ());
9927 return reduced;
9928 }
9929
9930 /* ffeexpr_reduced_power_ -- Wrap up reduction of ** operator
9931
9932 reduced = ffeexpr_reduced_power_(reduced,l,op,r);
9933
9934 Makes sure the left and right arguments for reduced have basictype of
9935 INTEGER, REAL, or COMPLEX. Determine common basictype and
9936 size for reduction (flag expression for combined hollerith/typeless
9937 situations for later determination of effective basictype). If both left
9938 and right arguments have where of CONSTANT, assign where CONSTANT to
9939 reduced, else assign where FLEETING. Create CONVERT ops for args where
9940 needed. Note that real**int or complex**int
9941 comes out as int = real**int etc with no conversions.
9942
9943 If these requirements cannot be met, generate error message using the
9944 info in l, op, and r arguments and assign basictype, size, kind, and where
9945 of ANY. */
9946
9947 static ffebld
9948 ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9949 ffeexprExpr_ r)
9950 {
9951 ffeinfo linfo, rinfo, ninfo;
9952 ffeinfoBasictype lbt, rbt, nbt;
9953 ffeinfoKindtype lkt, rkt, nkt;
9954 ffeinfoRank lrk, rrk;
9955 ffeinfoKind lkd, rkd;
9956 ffeinfoWhere lwh, rwh, nwh;
9957
9958 linfo = ffebld_info (ffebld_left (reduced));
9959 lbt = ffeinfo_basictype (linfo);
9960 lkt = ffeinfo_kindtype (linfo);
9961 lrk = ffeinfo_rank (linfo);
9962 lkd = ffeinfo_kind (linfo);
9963 lwh = ffeinfo_where (linfo);
9964
9965 rinfo = ffebld_info (ffebld_right (reduced));
9966 rbt = ffeinfo_basictype (rinfo);
9967 rkt = ffeinfo_kindtype (rinfo);
9968 rrk = ffeinfo_rank (rinfo);
9969 rkd = ffeinfo_kind (rinfo);
9970 rwh = ffeinfo_where (rinfo);
9971
9972 if ((rbt == FFEINFO_basictypeINTEGER)
9973 && ((lbt == FFEINFO_basictypeREAL)
9974 || (lbt == FFEINFO_basictypeCOMPLEX)))
9975 {
9976 nbt = lbt;
9977 nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDEFAULT);
9978 if (nkt != FFEINFO_kindtypeREALDEFAULT)
9979 {
9980 nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDOUBLE);
9981 if (nkt != FFEINFO_kindtypeREALDOUBLE)
9982 nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */
9983 }
9984 if (rkt == FFEINFO_kindtypeINTEGER4)
9985 {
9986 /* xgettext:no-c-format */
9987 ffebad_start_msg ("Unsupported operand for ** at %1 -- converting to default INTEGER",
9988 FFEBAD_severityWARNING);
9989 ffebad_here (0, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9990 ffebad_finish ();
9991 }
9992 if (rkt != FFEINFO_kindtypeINTEGERDEFAULT)
9993 {
9994 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
9995 r->token, op->token,
9996 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0,
9997 FFETARGET_charactersizeNONE,
9998 FFEEXPR_contextLET));
9999 rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10000 }
10001 }
10002 else
10003 {
10004 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10005
10006 #if 0 /* INTEGER4**INTEGER4 works now. */
10007 if ((nbt == FFEINFO_basictypeINTEGER)
10008 && (nkt != FFEINFO_kindtypeINTEGERDEFAULT))
10009 nkt = FFEINFO_kindtypeINTEGERDEFAULT; /* Highest kt we can power! */
10010 #endif
10011 if (((nbt == FFEINFO_basictypeREAL)
10012 || (nbt == FFEINFO_basictypeCOMPLEX))
10013 && (nkt != FFEINFO_kindtypeREALDEFAULT))
10014 {
10015 nkt = ffeinfo_kindtype_max (nbt, nkt, FFEINFO_kindtypeREALDOUBLE);
10016 if (nkt != FFEINFO_kindtypeREALDOUBLE)
10017 nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */
10018 }
10019 /* else Gonna turn into an error below. */
10020 }
10021
10022 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10023 || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
10024 {
10025 switch (lwh)
10026 {
10027 case FFEINFO_whereCONSTANT:
10028 switch (rwh)
10029 {
10030 case FFEINFO_whereCONSTANT:
10031 nwh = FFEINFO_whereCONSTANT;
10032 break;
10033
10034 case FFEINFO_whereIMMEDIATE:
10035 nwh = FFEINFO_whereIMMEDIATE;
10036 break;
10037
10038 default:
10039 nwh = FFEINFO_whereFLEETING;
10040 break;
10041 }
10042 break;
10043
10044 case FFEINFO_whereIMMEDIATE:
10045 switch (rwh)
10046 {
10047 case FFEINFO_whereCONSTANT:
10048 case FFEINFO_whereIMMEDIATE:
10049 nwh = FFEINFO_whereIMMEDIATE;
10050 break;
10051
10052 default:
10053 nwh = FFEINFO_whereFLEETING;
10054 break;
10055 }
10056 break;
10057
10058 default:
10059 nwh = FFEINFO_whereFLEETING;
10060 break;
10061 }
10062
10063 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10064 FFETARGET_charactersizeNONE);
10065 ffebld_set_info (reduced, ninfo);
10066 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10067 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10068 FFEEXPR_contextLET));
10069 if (rbt != FFEINFO_basictypeINTEGER)
10070 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10071 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10072 FFEEXPR_contextLET));
10073 return reduced;
10074 }
10075
10076 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10077 && (lbt != FFEINFO_basictypeCOMPLEX))
10078 {
10079 if ((rbt != FFEINFO_basictypeINTEGER)
10080 && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
10081 {
10082 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10083 && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
10084 {
10085 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10086 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10087 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10088 ffebad_finish ();
10089 }
10090 }
10091 else
10092 {
10093 if ((lbt != FFEINFO_basictypeANY)
10094 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10095 {
10096 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10097 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10098 ffebad_finish ();
10099 }
10100 }
10101 }
10102 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10103 && (rbt != FFEINFO_basictypeCOMPLEX))
10104 {
10105 if ((rbt != FFEINFO_basictypeANY)
10106 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10107 {
10108 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10109 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10110 ffebad_finish ();
10111 }
10112 }
10113 else if (lrk != 0)
10114 {
10115 if ((lkd != FFEINFO_kindANY)
10116 && ffebad_start (FFEBAD_MATH_ARG_KIND))
10117 {
10118 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10119 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10120 ffebad_string ("an array");
10121 ffebad_finish ();
10122 }
10123 }
10124 else
10125 {
10126 if ((rkd != FFEINFO_kindANY)
10127 && ffebad_start (FFEBAD_MATH_ARG_KIND))
10128 {
10129 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10130 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10131 ffebad_string ("an array");
10132 ffebad_finish ();
10133 }
10134 }
10135
10136 reduced = ffebld_new_any ();
10137 ffebld_set_info (reduced, ffeinfo_new_any ());
10138 return reduced;
10139 }
10140
10141 /* ffeexpr_reduced_relop2_ -- Wrap up reduction of LT, LE, GE, and GT operators
10142
10143 reduced = ffeexpr_reduced_relop2_(reduced,l,op,r);
10144
10145 Makes sure the left and right arguments for reduced have basictype of
10146 INTEGER, REAL, or CHARACTER. Determine common basictype and
10147 size for reduction. If both left
10148 and right arguments have where of CONSTANT, assign where CONSTANT to
10149 reduced, else assign where FLEETING. Create CONVERT ops for args where
10150 needed. Convert typeless
10151 constants to the desired type/size explicitly.
10152
10153 If these requirements cannot be met, generate error message. */
10154
10155 static ffebld
10156 ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10157 ffeexprExpr_ r)
10158 {
10159 ffeinfo linfo, rinfo, ninfo;
10160 ffeinfoBasictype lbt, rbt, nbt;
10161 ffeinfoKindtype lkt, rkt, nkt;
10162 ffeinfoRank lrk, rrk;
10163 ffeinfoKind lkd, rkd;
10164 ffeinfoWhere lwh, rwh, nwh;
10165 ffetargetCharacterSize lsz, rsz;
10166
10167 linfo = ffebld_info (ffebld_left (reduced));
10168 lbt = ffeinfo_basictype (linfo);
10169 lkt = ffeinfo_kindtype (linfo);
10170 lrk = ffeinfo_rank (linfo);
10171 lkd = ffeinfo_kind (linfo);
10172 lwh = ffeinfo_where (linfo);
10173 lsz = ffebld_size_known (ffebld_left (reduced));
10174
10175 rinfo = ffebld_info (ffebld_right (reduced));
10176 rbt = ffeinfo_basictype (rinfo);
10177 rkt = ffeinfo_kindtype (rinfo);
10178 rrk = ffeinfo_rank (rinfo);
10179 rkd = ffeinfo_kind (rinfo);
10180 rwh = ffeinfo_where (rinfo);
10181 rsz = ffebld_size_known (ffebld_right (reduced));
10182
10183 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10184
10185 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10186 || (nbt == FFEINFO_basictypeCHARACTER))
10187 && (lrk == 0) && (rrk == 0))
10188 {
10189 switch (lwh)
10190 {
10191 case FFEINFO_whereCONSTANT:
10192 switch (rwh)
10193 {
10194 case FFEINFO_whereCONSTANT:
10195 nwh = FFEINFO_whereCONSTANT;
10196 break;
10197
10198 case FFEINFO_whereIMMEDIATE:
10199 nwh = FFEINFO_whereIMMEDIATE;
10200 break;
10201
10202 default:
10203 nwh = FFEINFO_whereFLEETING;
10204 break;
10205 }
10206 break;
10207
10208 case FFEINFO_whereIMMEDIATE:
10209 switch (rwh)
10210 {
10211 case FFEINFO_whereCONSTANT:
10212 case FFEINFO_whereIMMEDIATE:
10213 nwh = FFEINFO_whereIMMEDIATE;
10214 break;
10215
10216 default:
10217 nwh = FFEINFO_whereFLEETING;
10218 break;
10219 }
10220 break;
10221
10222 default:
10223 nwh = FFEINFO_whereFLEETING;
10224 break;
10225 }
10226
10227 if ((lsz != FFETARGET_charactersizeNONE)
10228 && (rsz != FFETARGET_charactersizeNONE))
10229 lsz = rsz = (lsz > rsz) ? lsz : rsz;
10230
10231 ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
10232 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
10233 ffebld_set_info (reduced, ninfo);
10234 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10235 l->token, op->token, nbt, nkt, 0, lsz,
10236 FFEEXPR_contextLET));
10237 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10238 r->token, op->token, nbt, nkt, 0, rsz,
10239 FFEEXPR_contextLET));
10240 return reduced;
10241 }
10242
10243 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10244 && (lbt != FFEINFO_basictypeCHARACTER))
10245 {
10246 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10247 && (rbt != FFEINFO_basictypeCHARACTER))
10248 {
10249 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10250 && ffebad_start (FFEBAD_RELOP_ARGS_TYPE))
10251 {
10252 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10253 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10254 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10255 ffebad_finish ();
10256 }
10257 }
10258 else
10259 {
10260 if ((lbt != FFEINFO_basictypeANY)
10261 && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
10262 {
10263 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10264 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10265 ffebad_finish ();
10266 }
10267 }
10268 }
10269 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10270 && (rbt != FFEINFO_basictypeCHARACTER))
10271 {
10272 if ((rbt != FFEINFO_basictypeANY)
10273 && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
10274 {
10275 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10276 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10277 ffebad_finish ();
10278 }
10279 }
10280 else if (lrk != 0)
10281 {
10282 if ((lkd != FFEINFO_kindANY)
10283 && ffebad_start (FFEBAD_RELOP_ARG_KIND))
10284 {
10285 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10286 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10287 ffebad_string ("an array");
10288 ffebad_finish ();
10289 }
10290 }
10291 else
10292 {
10293 if ((rkd != FFEINFO_kindANY)
10294 && ffebad_start (FFEBAD_RELOP_ARG_KIND))
10295 {
10296 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10297 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10298 ffebad_string ("an array");
10299 ffebad_finish ();
10300 }
10301 }
10302
10303 reduced = ffebld_new_any ();
10304 ffebld_set_info (reduced, ffeinfo_new_any ());
10305 return reduced;
10306 }
10307
10308 /* ffeexpr_reduced_ugly1_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
10309
10310 reduced = ffeexpr_reduced_ugly1_(reduced,op,r);
10311
10312 Sigh. */
10313
10314 static ffebld
10315 ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10316 {
10317 ffeinfo rinfo;
10318 ffeinfoBasictype rbt;
10319 ffeinfoKindtype rkt;
10320 ffeinfoRank rrk;
10321 ffeinfoKind rkd;
10322 ffeinfoWhere rwh;
10323
10324 rinfo = ffebld_info (ffebld_left (reduced));
10325 rbt = ffeinfo_basictype (rinfo);
10326 rkt = ffeinfo_kindtype (rinfo);
10327 rrk = ffeinfo_rank (rinfo);
10328 rkd = ffeinfo_kind (rinfo);
10329 rwh = ffeinfo_where (rinfo);
10330
10331 if ((rbt == FFEINFO_basictypeTYPELESS)
10332 || (rbt == FFEINFO_basictypeHOLLERITH))
10333 {
10334 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10335 r->token, op->token, FFEINFO_basictypeINTEGER,
10336 FFEINFO_kindtypeINTEGERDEFAULT, 0,
10337 FFETARGET_charactersizeNONE,
10338 FFEEXPR_contextLET));
10339 rinfo = ffebld_info (ffebld_left (reduced));
10340 rbt = FFEINFO_basictypeINTEGER;
10341 rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10342 rrk = 0;
10343 rkd = FFEINFO_kindENTITY;
10344 rwh = ffeinfo_where (rinfo);
10345 }
10346
10347 if (rbt == FFEINFO_basictypeLOGICAL)
10348 {
10349 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10350 r->token, op->token, FFEINFO_basictypeINTEGER,
10351 FFEINFO_kindtypeINTEGERDEFAULT, 0,
10352 FFETARGET_charactersizeNONE,
10353 FFEEXPR_contextLET));
10354 }
10355
10356 return reduced;
10357 }
10358
10359 /* ffeexpr_reduced_ugly1log_ -- Deal with TYPELESS and HOLLERITH
10360
10361 reduced = ffeexpr_reduced_ugly1log_(reduced,op,r);
10362
10363 Sigh. */
10364
10365 static ffebld
10366 ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10367 {
10368 ffeinfo rinfo;
10369 ffeinfoBasictype rbt;
10370 ffeinfoKindtype rkt;
10371 ffeinfoRank rrk;
10372 ffeinfoKind rkd;
10373 ffeinfoWhere rwh;
10374
10375 rinfo = ffebld_info (ffebld_left (reduced));
10376 rbt = ffeinfo_basictype (rinfo);
10377 rkt = ffeinfo_kindtype (rinfo);
10378 rrk = ffeinfo_rank (rinfo);
10379 rkd = ffeinfo_kind (rinfo);
10380 rwh = ffeinfo_where (rinfo);
10381
10382 if ((rbt == FFEINFO_basictypeTYPELESS)
10383 || (rbt == FFEINFO_basictypeHOLLERITH))
10384 {
10385 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10386 r->token, op->token, FFEINFO_basictypeLOGICAL, 0,
10387 FFEINFO_kindtypeLOGICALDEFAULT,
10388 FFETARGET_charactersizeNONE,
10389 FFEEXPR_contextLET));
10390 rinfo = ffebld_info (ffebld_left (reduced));
10391 rbt = FFEINFO_basictypeLOGICAL;
10392 rkt = FFEINFO_kindtypeLOGICALDEFAULT;
10393 rrk = 0;
10394 rkd = FFEINFO_kindENTITY;
10395 rwh = ffeinfo_where (rinfo);
10396 }
10397
10398 return reduced;
10399 }
10400
10401 /* ffeexpr_reduced_ugly2_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
10402
10403 reduced = ffeexpr_reduced_ugly2_(reduced,l,op,r);
10404
10405 Sigh. */
10406
10407 static ffebld
10408 ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10409 ffeexprExpr_ r)
10410 {
10411 ffeinfo linfo, rinfo;
10412 ffeinfoBasictype lbt, rbt;
10413 ffeinfoKindtype lkt, rkt;
10414 ffeinfoRank lrk, rrk;
10415 ffeinfoKind lkd, rkd;
10416 ffeinfoWhere lwh, rwh;
10417
10418 linfo = ffebld_info (ffebld_left (reduced));
10419 lbt = ffeinfo_basictype (linfo);
10420 lkt = ffeinfo_kindtype (linfo);
10421 lrk = ffeinfo_rank (linfo);
10422 lkd = ffeinfo_kind (linfo);
10423 lwh = ffeinfo_where (linfo);
10424
10425 rinfo = ffebld_info (ffebld_right (reduced));
10426 rbt = ffeinfo_basictype (rinfo);
10427 rkt = ffeinfo_kindtype (rinfo);
10428 rrk = ffeinfo_rank (rinfo);
10429 rkd = ffeinfo_kind (rinfo);
10430 rwh = ffeinfo_where (rinfo);
10431
10432 if ((lbt == FFEINFO_basictypeTYPELESS)
10433 || (lbt == FFEINFO_basictypeHOLLERITH))
10434 {
10435 if ((rbt == FFEINFO_basictypeTYPELESS)
10436 || (rbt == FFEINFO_basictypeHOLLERITH))
10437 {
10438 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10439 l->token, op->token, FFEINFO_basictypeINTEGER,
10440 FFEINFO_kindtypeINTEGERDEFAULT, 0,
10441 FFETARGET_charactersizeNONE,
10442 FFEEXPR_contextLET));
10443 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10444 r->token, op->token, FFEINFO_basictypeINTEGER, 0,
10445 FFEINFO_kindtypeINTEGERDEFAULT,
10446 FFETARGET_charactersizeNONE,
10447 FFEEXPR_contextLET));
10448 linfo = ffebld_info (ffebld_left (reduced));
10449 rinfo = ffebld_info (ffebld_right (reduced));
10450 lbt = rbt = FFEINFO_basictypeINTEGER;
10451 lkt = rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10452 lrk = rrk = 0;
10453 lkd = rkd = FFEINFO_kindENTITY;
10454 lwh = ffeinfo_where (linfo);
10455 rwh = ffeinfo_where (rinfo);
10456 }
10457 else
10458 {
10459 ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
10460 l->token, ffebld_right (reduced), r->token,
10461 FFEEXPR_contextLET));
10462 linfo = ffebld_info (ffebld_left (reduced));
10463 lbt = ffeinfo_basictype (linfo);
10464 lkt = ffeinfo_kindtype (linfo);
10465 lrk = ffeinfo_rank (linfo);
10466 lkd = ffeinfo_kind (linfo);
10467 lwh = ffeinfo_where (linfo);
10468 }
10469 }
10470 else
10471 {
10472 if ((rbt == FFEINFO_basictypeTYPELESS)
10473 || (rbt == FFEINFO_basictypeHOLLERITH))
10474 {
10475 ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
10476 r->token, ffebld_left (reduced), l->token,
10477 FFEEXPR_contextLET));
10478 rinfo = ffebld_info (ffebld_right (reduced));
10479 rbt = ffeinfo_basictype (rinfo);
10480 rkt = ffeinfo_kindtype (rinfo);
10481 rrk = ffeinfo_rank (rinfo);
10482 rkd = ffeinfo_kind (rinfo);
10483 rwh = ffeinfo_where (rinfo);
10484 }
10485 /* else Leave it alone. */
10486 }
10487
10488 if (lbt == FFEINFO_basictypeLOGICAL)
10489 {
10490 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10491 l->token, op->token, FFEINFO_basictypeINTEGER,
10492 FFEINFO_kindtypeINTEGERDEFAULT, 0,
10493 FFETARGET_charactersizeNONE,
10494 FFEEXPR_contextLET));
10495 }
10496
10497 if (rbt == FFEINFO_basictypeLOGICAL)
10498 {
10499 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10500 r->token, op->token, FFEINFO_basictypeINTEGER,
10501 FFEINFO_kindtypeINTEGERDEFAULT, 0,
10502 FFETARGET_charactersizeNONE,
10503 FFEEXPR_contextLET));
10504 }
10505
10506 return reduced;
10507 }
10508
10509 /* ffeexpr_reduced_ugly2log_ -- Deal with TYPELESS and HOLLERITH
10510
10511 reduced = ffeexpr_reduced_ugly2log_(reduced,l,op,r);
10512
10513 Sigh. */
10514
10515 static ffebld
10516 ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10517 ffeexprExpr_ r)
10518 {
10519 ffeinfo linfo, rinfo;
10520 ffeinfoBasictype lbt, rbt;
10521 ffeinfoKindtype lkt, rkt;
10522 ffeinfoRank lrk, rrk;
10523 ffeinfoKind lkd, rkd;
10524 ffeinfoWhere lwh, rwh;
10525
10526 linfo = ffebld_info (ffebld_left (reduced));
10527 lbt = ffeinfo_basictype (linfo);
10528 lkt = ffeinfo_kindtype (linfo);
10529 lrk = ffeinfo_rank (linfo);
10530 lkd = ffeinfo_kind (linfo);
10531 lwh = ffeinfo_where (linfo);
10532
10533 rinfo = ffebld_info (ffebld_right (reduced));
10534 rbt = ffeinfo_basictype (rinfo);
10535 rkt = ffeinfo_kindtype (rinfo);
10536 rrk = ffeinfo_rank (rinfo);
10537 rkd = ffeinfo_kind (rinfo);
10538 rwh = ffeinfo_where (rinfo);
10539
10540 if ((lbt == FFEINFO_basictypeTYPELESS)
10541 || (lbt == FFEINFO_basictypeHOLLERITH))
10542 {
10543 if ((rbt == FFEINFO_basictypeTYPELESS)
10544 || (rbt == FFEINFO_basictypeHOLLERITH))
10545 {
10546 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10547 l->token, op->token, FFEINFO_basictypeLOGICAL,
10548 FFEINFO_kindtypeLOGICALDEFAULT, 0,
10549 FFETARGET_charactersizeNONE,
10550 FFEEXPR_contextLET));
10551 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10552 r->token, op->token, FFEINFO_basictypeLOGICAL,
10553 FFEINFO_kindtypeLOGICALDEFAULT, 0,
10554 FFETARGET_charactersizeNONE,
10555 FFEEXPR_contextLET));
10556 linfo = ffebld_info (ffebld_left (reduced));
10557 rinfo = ffebld_info (ffebld_right (reduced));
10558 lbt = rbt = FFEINFO_basictypeLOGICAL;
10559 lkt = rkt = FFEINFO_kindtypeLOGICALDEFAULT;
10560 lrk = rrk = 0;
10561 lkd = rkd = FFEINFO_kindENTITY;
10562 lwh = ffeinfo_where (linfo);
10563 rwh = ffeinfo_where (rinfo);
10564 }
10565 else
10566 {
10567 ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
10568 l->token, ffebld_right (reduced), r->token,
10569 FFEEXPR_contextLET));
10570 linfo = ffebld_info (ffebld_left (reduced));
10571 lbt = ffeinfo_basictype (linfo);
10572 lkt = ffeinfo_kindtype (linfo);
10573 lrk = ffeinfo_rank (linfo);
10574 lkd = ffeinfo_kind (linfo);
10575 lwh = ffeinfo_where (linfo);
10576 }
10577 }
10578 else
10579 {
10580 if ((rbt == FFEINFO_basictypeTYPELESS)
10581 || (rbt == FFEINFO_basictypeHOLLERITH))
10582 {
10583 ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
10584 r->token, ffebld_left (reduced), l->token,
10585 FFEEXPR_contextLET));
10586 rinfo = ffebld_info (ffebld_right (reduced));
10587 rbt = ffeinfo_basictype (rinfo);
10588 rkt = ffeinfo_kindtype (rinfo);
10589 rrk = ffeinfo_rank (rinfo);
10590 rkd = ffeinfo_kind (rinfo);
10591 rwh = ffeinfo_where (rinfo);
10592 }
10593 /* else Leave it alone. */
10594 }
10595
10596 return reduced;
10597 }
10598
10599 /* Fumble through tokens until a nonmatching CLOSE_PAREN, EOS, or SEMICOLON
10600 is found.
10601
10602 The idea is to process the tokens as they would be done by normal
10603 expression processing, with the key things being telling the lexer
10604 when hollerith/character constants are about to happen, until the
10605 true closing token is found. */
10606
10607 static ffelexHandler
10608 ffeexpr_find_close_paren_ (ffelexToken t,
10609 ffelexHandler after)
10610 {
10611 ffeexpr_find_.after = after;
10612 ffeexpr_find_.level = 1;
10613 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10614 }
10615
10616 static ffelexHandler
10617 ffeexpr_nil_finished_ (ffelexToken t)
10618 {
10619 switch (ffelex_token_type (t))
10620 {
10621 case FFELEX_typeCLOSE_PAREN:
10622 if (--ffeexpr_find_.level == 0)
10623 return (ffelexHandler) ffeexpr_find_.after;
10624 return (ffelexHandler) ffeexpr_nil_binary_;
10625
10626 case FFELEX_typeCOMMA:
10627 case FFELEX_typeCOLON:
10628 case FFELEX_typeEQUALS:
10629 case FFELEX_typePOINTS:
10630 return (ffelexHandler) ffeexpr_nil_rhs_;
10631
10632 default:
10633 if (--ffeexpr_find_.level == 0)
10634 return (ffelexHandler) ffeexpr_find_.after (t);
10635 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10636 }
10637 }
10638
10639 static ffelexHandler
10640 ffeexpr_nil_rhs_ (ffelexToken t)
10641 {
10642 switch (ffelex_token_type (t))
10643 {
10644 case FFELEX_typeQUOTE:
10645 if (ffe_is_vxt ())
10646 return (ffelexHandler) ffeexpr_nil_quote_;
10647 ffelex_set_expecting_hollerith (-1, '\"',
10648 ffelex_token_where_line (t),
10649 ffelex_token_where_column (t));
10650 return (ffelexHandler) ffeexpr_nil_apostrophe_;
10651
10652 case FFELEX_typeAPOSTROPHE:
10653 ffelex_set_expecting_hollerith (-1, '\'',
10654 ffelex_token_where_line (t),
10655 ffelex_token_where_column (t));
10656 return (ffelexHandler) ffeexpr_nil_apostrophe_;
10657
10658 case FFELEX_typePERCENT:
10659 return (ffelexHandler) ffeexpr_nil_percent_;
10660
10661 case FFELEX_typeOPEN_PAREN:
10662 ++ffeexpr_find_.level;
10663 return (ffelexHandler) ffeexpr_nil_rhs_;
10664
10665 case FFELEX_typePLUS:
10666 case FFELEX_typeMINUS:
10667 return (ffelexHandler) ffeexpr_nil_rhs_;
10668
10669 case FFELEX_typePERIOD:
10670 return (ffelexHandler) ffeexpr_nil_period_;
10671
10672 case FFELEX_typeNUMBER:
10673 ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
10674 if (ffeexpr_hollerith_count_ > 0)
10675 ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
10676 '\0',
10677 ffelex_token_where_line (t),
10678 ffelex_token_where_column (t));
10679 return (ffelexHandler) ffeexpr_nil_number_;
10680
10681 case FFELEX_typeNAME:
10682 case FFELEX_typeNAMES:
10683 return (ffelexHandler) ffeexpr_nil_name_rhs_;
10684
10685 case FFELEX_typeASTERISK:
10686 case FFELEX_typeSLASH:
10687 case FFELEX_typePOWER:
10688 case FFELEX_typeCONCAT:
10689 case FFELEX_typeREL_EQ:
10690 case FFELEX_typeREL_NE:
10691 case FFELEX_typeREL_LE:
10692 case FFELEX_typeREL_GE:
10693 return (ffelexHandler) ffeexpr_nil_rhs_;
10694
10695 default:
10696 return (ffelexHandler) ffeexpr_nil_finished_ (t);
10697 }
10698 }
10699
10700 static ffelexHandler
10701 ffeexpr_nil_period_ (ffelexToken t)
10702 {
10703 switch (ffelex_token_type (t))
10704 {
10705 case FFELEX_typeNAME:
10706 case FFELEX_typeNAMES:
10707 ffeexpr_current_dotdot_ = ffestr_other (t);
10708 switch (ffeexpr_current_dotdot_)
10709 {
10710 case FFESTR_otherNone:
10711 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10712
10713 case FFESTR_otherTRUE:
10714 case FFESTR_otherFALSE:
10715 case FFESTR_otherNOT:
10716 return (ffelexHandler) ffeexpr_nil_end_period_;
10717
10718 default:
10719 return (ffelexHandler) ffeexpr_nil_swallow_period_;
10720 }
10721 break; /* Nothing really reaches here. */
10722
10723 case FFELEX_typeNUMBER:
10724 return (ffelexHandler) ffeexpr_nil_real_;
10725
10726 default:
10727 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10728 }
10729 }
10730
10731 static ffelexHandler
10732 ffeexpr_nil_end_period_ (ffelexToken t)
10733 {
10734 switch (ffeexpr_current_dotdot_)
10735 {
10736 case FFESTR_otherNOT:
10737 if (ffelex_token_type (t) != FFELEX_typePERIOD)
10738 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10739 return (ffelexHandler) ffeexpr_nil_rhs_;
10740
10741 case FFESTR_otherTRUE:
10742 case FFESTR_otherFALSE:
10743 if (ffelex_token_type (t) != FFELEX_typePERIOD)
10744 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10745 return (ffelexHandler) ffeexpr_nil_binary_;
10746
10747 default:
10748 assert ("Bad [nil] unary dotdot in ffeexpr_current_dotdot_" == NULL);
10749 exit (0);
10750 return NULL;
10751 }
10752 }
10753
10754 static ffelexHandler
10755 ffeexpr_nil_swallow_period_ (ffelexToken t)
10756 {
10757 if (ffelex_token_type (t) != FFELEX_typePERIOD)
10758 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10759 return (ffelexHandler) ffeexpr_nil_rhs_;
10760 }
10761
10762 static ffelexHandler
10763 ffeexpr_nil_real_ (ffelexToken t)
10764 {
10765 char d;
10766 const char *p;
10767
10768 if (((ffelex_token_type (t) != FFELEX_typeNAME)
10769 && (ffelex_token_type (t) != FFELEX_typeNAMES))
10770 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
10771 'D', 'd')
10772 || ffesrc_char_match_init (d, 'E', 'e')
10773 || ffesrc_char_match_init (d, 'Q', 'q')))
10774 && ffeexpr_isdigits_ (++p)))
10775 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10776
10777 if (*p == '\0')
10778 return (ffelexHandler) ffeexpr_nil_real_exponent_;
10779 return (ffelexHandler) ffeexpr_nil_binary_;
10780 }
10781
10782 static ffelexHandler
10783 ffeexpr_nil_real_exponent_ (ffelexToken t)
10784 {
10785 if ((ffelex_token_type (t) != FFELEX_typePLUS)
10786 && (ffelex_token_type (t) != FFELEX_typeMINUS))
10787 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10788
10789 return (ffelexHandler) ffeexpr_nil_real_exp_sign_;
10790 }
10791
10792 static ffelexHandler
10793 ffeexpr_nil_real_exp_sign_ (ffelexToken t)
10794 {
10795 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
10796 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10797 return (ffelexHandler) ffeexpr_nil_binary_;
10798 }
10799
10800 static ffelexHandler
10801 ffeexpr_nil_number_ (ffelexToken t)
10802 {
10803 char d;
10804 const char *p;
10805
10806 if (ffeexpr_hollerith_count_ > 0)
10807 ffelex_set_expecting_hollerith (0, '\0',
10808 ffewhere_line_unknown (),
10809 ffewhere_column_unknown ());
10810
10811 switch (ffelex_token_type (t))
10812 {
10813 case FFELEX_typeNAME:
10814 case FFELEX_typeNAMES:
10815 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
10816 'D', 'd')
10817 || ffesrc_char_match_init (d, 'E', 'e')
10818 || ffesrc_char_match_init (d, 'Q', 'q'))
10819 && ffeexpr_isdigits_ (++p))
10820 {
10821 if (*p == '\0')
10822 {
10823 ffeexpr_find_.t = ffelex_token_use (t);
10824 return (ffelexHandler) ffeexpr_nil_number_exponent_;
10825 }
10826 return (ffelexHandler) ffeexpr_nil_binary_;
10827 }
10828 break;
10829
10830 case FFELEX_typePERIOD:
10831 ffeexpr_find_.t = ffelex_token_use (t);
10832 return (ffelexHandler) ffeexpr_nil_number_period_;
10833
10834 case FFELEX_typeHOLLERITH:
10835 return (ffelexHandler) ffeexpr_nil_binary_;
10836
10837 default:
10838 break;
10839 }
10840 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10841 }
10842
10843 /* Expects ffeexpr_find_.t. */
10844
10845 static ffelexHandler
10846 ffeexpr_nil_number_exponent_ (ffelexToken t)
10847 {
10848 ffelexHandler nexthandler;
10849
10850 if ((ffelex_token_type (t) != FFELEX_typePLUS)
10851 && (ffelex_token_type (t) != FFELEX_typeMINUS))
10852 {
10853 nexthandler
10854 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
10855 ffelex_token_kill (ffeexpr_find_.t);
10856 return (ffelexHandler) (*nexthandler) (t);
10857 }
10858
10859 ffelex_token_kill (ffeexpr_find_.t);
10860 return (ffelexHandler) ffeexpr_nil_number_exp_sign_;
10861 }
10862
10863 static ffelexHandler
10864 ffeexpr_nil_number_exp_sign_ (ffelexToken t)
10865 {
10866 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
10867 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10868
10869 return (ffelexHandler) ffeexpr_nil_binary_;
10870 }
10871
10872 /* Expects ffeexpr_find_.t. */
10873
10874 static ffelexHandler
10875 ffeexpr_nil_number_period_ (ffelexToken t)
10876 {
10877 ffelexHandler nexthandler;
10878 char d;
10879 const char *p;
10880
10881 switch (ffelex_token_type (t))
10882 {
10883 case FFELEX_typeNAME:
10884 case FFELEX_typeNAMES:
10885 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
10886 'D', 'd')
10887 || ffesrc_char_match_init (d, 'E', 'e')
10888 || ffesrc_char_match_init (d, 'Q', 'q'))
10889 && ffeexpr_isdigits_ (++p))
10890 {
10891 if (*p == '\0')
10892 return (ffelexHandler) ffeexpr_nil_number_per_exp_;
10893 ffelex_token_kill (ffeexpr_find_.t);
10894 return (ffelexHandler) ffeexpr_nil_binary_;
10895 }
10896 nexthandler
10897 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
10898 ffelex_token_kill (ffeexpr_find_.t);
10899 return (ffelexHandler) (*nexthandler) (t);
10900
10901 case FFELEX_typeNUMBER:
10902 ffelex_token_kill (ffeexpr_find_.t);
10903 return (ffelexHandler) ffeexpr_nil_number_real_;
10904
10905 default:
10906 break;
10907 }
10908 ffelex_token_kill (ffeexpr_find_.t);
10909 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10910 }
10911
10912 /* Expects ffeexpr_find_.t. */
10913
10914 static ffelexHandler
10915 ffeexpr_nil_number_per_exp_ (ffelexToken t)
10916 {
10917 if ((ffelex_token_type (t) != FFELEX_typePLUS)
10918 && (ffelex_token_type (t) != FFELEX_typeMINUS))
10919 {
10920 ffelexHandler nexthandler;
10921
10922 nexthandler
10923 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
10924 ffelex_token_kill (ffeexpr_find_.t);
10925 return (ffelexHandler) (*nexthandler) (t);
10926 }
10927
10928 ffelex_token_kill (ffeexpr_find_.t);
10929 return (ffelexHandler) ffeexpr_nil_num_per_exp_sign_;
10930 }
10931
10932 static ffelexHandler
10933 ffeexpr_nil_number_real_ (ffelexToken t)
10934 {
10935 char d;
10936 const char *p;
10937
10938 if (((ffelex_token_type (t) != FFELEX_typeNAME)
10939 && (ffelex_token_type (t) != FFELEX_typeNAMES))
10940 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
10941 'D', 'd')
10942 || ffesrc_char_match_init (d, 'E', 'e')
10943 || ffesrc_char_match_init (d, 'Q', 'q')))
10944 && ffeexpr_isdigits_ (++p)))
10945 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10946
10947 if (*p == '\0')
10948 return (ffelexHandler) ffeexpr_nil_number_real_exp_;
10949
10950 return (ffelexHandler) ffeexpr_nil_binary_;
10951 }
10952
10953 static ffelexHandler
10954 ffeexpr_nil_num_per_exp_sign_ (ffelexToken t)
10955 {
10956 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
10957 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10958 return (ffelexHandler) ffeexpr_nil_binary_;
10959 }
10960
10961 static ffelexHandler
10962 ffeexpr_nil_number_real_exp_ (ffelexToken t)
10963 {
10964 if ((ffelex_token_type (t) != FFELEX_typePLUS)
10965 && (ffelex_token_type (t) != FFELEX_typeMINUS))
10966 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10967 return (ffelexHandler) ffeexpr_nil_num_real_exp_sn_;
10968 }
10969
10970 static ffelexHandler
10971 ffeexpr_nil_num_real_exp_sn_ (ffelexToken t)
10972 {
10973 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
10974 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10975 return (ffelexHandler) ffeexpr_nil_binary_;
10976 }
10977
10978 static ffelexHandler
10979 ffeexpr_nil_binary_ (ffelexToken t)
10980 {
10981 switch (ffelex_token_type (t))
10982 {
10983 case FFELEX_typePLUS:
10984 case FFELEX_typeMINUS:
10985 case FFELEX_typeASTERISK:
10986 case FFELEX_typeSLASH:
10987 case FFELEX_typePOWER:
10988 case FFELEX_typeCONCAT:
10989 case FFELEX_typeOPEN_ANGLE:
10990 case FFELEX_typeCLOSE_ANGLE:
10991 case FFELEX_typeREL_EQ:
10992 case FFELEX_typeREL_NE:
10993 case FFELEX_typeREL_GE:
10994 case FFELEX_typeREL_LE:
10995 return (ffelexHandler) ffeexpr_nil_rhs_;
10996
10997 case FFELEX_typePERIOD:
10998 return (ffelexHandler) ffeexpr_nil_binary_period_;
10999
11000 default:
11001 return (ffelexHandler) ffeexpr_nil_finished_ (t);
11002 }
11003 }
11004
11005 static ffelexHandler
11006 ffeexpr_nil_binary_period_ (ffelexToken t)
11007 {
11008 switch (ffelex_token_type (t))
11009 {
11010 case FFELEX_typeNAME:
11011 case FFELEX_typeNAMES:
11012 ffeexpr_current_dotdot_ = ffestr_other (t);
11013 switch (ffeexpr_current_dotdot_)
11014 {
11015 case FFESTR_otherTRUE:
11016 case FFESTR_otherFALSE:
11017 case FFESTR_otherNOT:
11018 return (ffelexHandler) ffeexpr_nil_binary_sw_per_;
11019
11020 default:
11021 return (ffelexHandler) ffeexpr_nil_binary_end_per_;
11022 }
11023 break; /* Nothing really reaches here. */
11024
11025 default:
11026 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11027 }
11028 }
11029
11030 static ffelexHandler
11031 ffeexpr_nil_binary_end_per_ (ffelexToken t)
11032 {
11033 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11034 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11035 return (ffelexHandler) ffeexpr_nil_rhs_;
11036 }
11037
11038 static ffelexHandler
11039 ffeexpr_nil_binary_sw_per_ (ffelexToken t)
11040 {
11041 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11042 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11043 return (ffelexHandler) ffeexpr_nil_binary_;
11044 }
11045
11046 static ffelexHandler
11047 ffeexpr_nil_quote_ (ffelexToken t)
11048 {
11049 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11050 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11051 return (ffelexHandler) ffeexpr_nil_binary_;
11052 }
11053
11054 static ffelexHandler
11055 ffeexpr_nil_apostrophe_ (ffelexToken t)
11056 {
11057 assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
11058 return (ffelexHandler) ffeexpr_nil_apos_char_;
11059 }
11060
11061 static ffelexHandler
11062 ffeexpr_nil_apos_char_ (ffelexToken t)
11063 {
11064 char c;
11065
11066 if ((ffelex_token_type (t) == FFELEX_typeNAME)
11067 || (ffelex_token_type (t) == FFELEX_typeNAMES))
11068 {
11069 if ((ffelex_token_length (t) == 1)
11070 && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]),
11071 'B', 'b')
11072 || ffesrc_char_match_init (c, 'O', 'o')
11073 || ffesrc_char_match_init (c, 'X', 'x')
11074 || ffesrc_char_match_init (c, 'Z', 'z')))
11075 return (ffelexHandler) ffeexpr_nil_binary_;
11076 }
11077 if ((ffelex_token_type (t) == FFELEX_typeNAME)
11078 || (ffelex_token_type (t) == FFELEX_typeNAMES))
11079 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11080 return (ffelexHandler) ffeexpr_nil_substrp_ (t);
11081 }
11082
11083 static ffelexHandler
11084 ffeexpr_nil_name_rhs_ (ffelexToken t)
11085 {
11086 switch (ffelex_token_type (t))
11087 {
11088 case FFELEX_typeQUOTE:
11089 case FFELEX_typeAPOSTROPHE:
11090 ffelex_set_hexnum (TRUE);
11091 return (ffelexHandler) ffeexpr_nil_name_apos_;
11092
11093 case FFELEX_typeOPEN_PAREN:
11094 ++ffeexpr_find_.level;
11095 return (ffelexHandler) ffeexpr_nil_rhs_;
11096
11097 default:
11098 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11099 }
11100 }
11101
11102 static ffelexHandler
11103 ffeexpr_nil_name_apos_ (ffelexToken t)
11104 {
11105 if (ffelex_token_type (t) == FFELEX_typeNAME)
11106 return (ffelexHandler) ffeexpr_nil_name_apos_name_;
11107 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11108 }
11109
11110 static ffelexHandler
11111 ffeexpr_nil_name_apos_name_ (ffelexToken t)
11112 {
11113 switch (ffelex_token_type (t))
11114 {
11115 case FFELEX_typeAPOSTROPHE:
11116 case FFELEX_typeQUOTE:
11117 return (ffelexHandler) ffeexpr_nil_finished_;
11118
11119 default:
11120 return (ffelexHandler) ffeexpr_nil_finished_ (t);
11121 }
11122 }
11123
11124 static ffelexHandler
11125 ffeexpr_nil_percent_ (ffelexToken t)
11126 {
11127 switch (ffelex_token_type (t))
11128 {
11129 case FFELEX_typeNAME:
11130 case FFELEX_typeNAMES:
11131 ffeexpr_stack_->percent = ffeexpr_percent_ (t);
11132 ffeexpr_find_.t = ffelex_token_use (t);
11133 return (ffelexHandler) ffeexpr_nil_percent_name_;
11134
11135 default:
11136 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11137 }
11138 }
11139
11140 /* Expects ffeexpr_find_.t. */
11141
11142 static ffelexHandler
11143 ffeexpr_nil_percent_name_ (ffelexToken t)
11144 {
11145 ffelexHandler nexthandler;
11146
11147 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
11148 {
11149 nexthandler
11150 = (ffelexHandler) ffeexpr_nil_rhs_ (ffeexpr_find_.t);
11151 ffelex_token_kill (ffeexpr_find_.t);
11152 return (ffelexHandler) (*nexthandler) (t);
11153 }
11154
11155 ffelex_token_kill (ffeexpr_find_.t);
11156 ++ffeexpr_find_.level;
11157 return (ffelexHandler) ffeexpr_nil_rhs_;
11158 }
11159
11160 static ffelexHandler
11161 ffeexpr_nil_substrp_ (ffelexToken t)
11162 {
11163 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
11164 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11165
11166 ++ffeexpr_find_.level;
11167 return (ffelexHandler) ffeexpr_nil_rhs_;
11168 }
11169
11170 /* ffeexpr_finished_ -- Reduce expression stack to one expr, finish
11171
11172 ffelexToken t;
11173 return ffeexpr_finished_(t);
11174
11175 Reduces expression stack to one (or zero) elements by repeatedly reducing
11176 the top operator on the stack (or, if the top element on the stack is
11177 itself an operator, issuing an error message and discarding it). Calls
11178 finishing routine with the expression, returning the ffelexHandler it
11179 returns to the caller. */
11180
11181 static ffelexHandler
11182 ffeexpr_finished_ (ffelexToken t)
11183 {
11184 ffeexprExpr_ operand; /* This is B in -B or A+B. */
11185 ffebld expr;
11186 ffeexprCallback callback;
11187 ffeexprStack_ s;
11188 ffebldConstant constnode; /* For detecting magical number. */
11189 ffelexToken ft; /* Temporary copy of first token in
11190 expression. */
11191 ffelexHandler next;
11192 ffeinfo info;
11193 bool error = FALSE;
11194
11195 while (((operand = ffeexpr_stack_->exprstack) != NULL)
11196 && ((operand->previous != NULL) || (operand->type != FFEEXPR_exprtypeOPERAND_)))
11197 {
11198 if (operand->type == FFEEXPR_exprtypeOPERAND_)
11199 ffeexpr_reduce_ ();
11200 else
11201 {
11202 if (ffest_ffebad_start (FFEBAD_MISSING_OPERAND_FOR_OPERATOR))
11203 {
11204 ffebad_here (0, ffelex_token_where_line (t),
11205 ffelex_token_where_column (t));
11206 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
11207 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
11208 ffebad_finish ();
11209 }
11210 ffeexpr_stack_->exprstack = operand->previous; /* Pop the useless
11211 operator. */
11212 ffeexpr_expr_kill_ (operand);
11213 }
11214 }
11215
11216 assert ((operand == NULL) || (operand->previous == NULL));
11217
11218 ffebld_pool_pop ();
11219 if (operand == NULL)
11220 expr = NULL;
11221 else
11222 {
11223 expr = operand->u.operand;
11224 info = ffebld_info (expr);
11225 if ((ffebld_op (expr) == FFEBLD_opCONTER)
11226 && (ffebld_conter_orig (expr) == NULL)
11227 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
11228 {
11229 ffetarget_integer_bad_magical (operand->token);
11230 }
11231 ffeexpr_expr_kill_ (operand);
11232 ffeexpr_stack_->exprstack = NULL;
11233 }
11234
11235 ft = ffeexpr_stack_->first_token;
11236
11237 again: /* :::::::::::::::::::: */
11238 switch (ffeexpr_stack_->context)
11239 {
11240 case FFEEXPR_contextLET:
11241 case FFEEXPR_contextSFUNCDEF:
11242 error = (expr == NULL)
11243 || (ffeinfo_rank (info) != 0);
11244 break;
11245
11246 case FFEEXPR_contextPAREN_:
11247 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11248 break;
11249 switch (ffeinfo_basictype (info))
11250 {
11251 case FFEINFO_basictypeHOLLERITH:
11252 case FFEINFO_basictypeTYPELESS:
11253 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11254 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11255 FFEEXPR_contextLET);
11256 break;
11257
11258 default:
11259 break;
11260 }
11261 break;
11262
11263 case FFEEXPR_contextPARENFILENUM_:
11264 if (ffelex_token_type (t) != FFELEX_typeCOMMA)
11265 ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
11266 else
11267 ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
11268 goto again; /* :::::::::::::::::::: */
11269
11270 case FFEEXPR_contextPARENFILEUNIT_:
11271 if (ffelex_token_type (t) != FFELEX_typeCOMMA)
11272 ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
11273 else
11274 ffeexpr_stack_->context = FFEEXPR_contextFILEUNIT;
11275 goto again; /* :::::::::::::::::::: */
11276
11277 case FFEEXPR_contextACTUALARGEXPR_:
11278 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
11279 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11280 : ffeinfo_basictype (info))
11281 {
11282 case FFEINFO_basictypeHOLLERITH:
11283 case FFEINFO_basictypeTYPELESS:
11284 if (!ffe_is_ugly_args ()
11285 && ffebad_start (FFEBAD_ACTUALARG))
11286 {
11287 ffebad_here (0, ffelex_token_where_line (ft),
11288 ffelex_token_where_column (ft));
11289 ffebad_finish ();
11290 }
11291 break;
11292
11293 default:
11294 break;
11295 }
11296 error = (expr != NULL) && (ffeinfo_rank (info) != 0);
11297 break;
11298
11299 case FFEEXPR_contextACTUALARG_:
11300 case FFEEXPR_contextSFUNCDEFACTUALARG_:
11301 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11302 : ffeinfo_basictype (info))
11303 {
11304 case FFEINFO_basictypeHOLLERITH:
11305 case FFEINFO_basictypeTYPELESS:
11306 #if 0 /* Should never get here. */
11307 expr = ffeexpr_convert (expr, ft, ft,
11308 FFEINFO_basictypeINTEGER,
11309 FFEINFO_kindtypeINTEGERDEFAULT,
11310 0,
11311 FFETARGET_charactersizeNONE,
11312 FFEEXPR_contextLET);
11313 #else
11314 assert ("why hollerith/typeless in actualarg_?" == NULL);
11315 #endif
11316 break;
11317
11318 default:
11319 break;
11320 }
11321 switch ((expr == NULL) ? FFEBLD_opANY : ffebld_op (expr))
11322 {
11323 case FFEBLD_opSYMTER:
11324 case FFEBLD_opPERCENT_LOC:
11325 case FFEBLD_opPERCENT_VAL:
11326 case FFEBLD_opPERCENT_REF:
11327 case FFEBLD_opPERCENT_DESCR:
11328 error = FALSE;
11329 break;
11330
11331 default:
11332 error = (expr != NULL) && (ffeinfo_rank (info) != 0);
11333 break;
11334 }
11335 {
11336 ffesymbol s;
11337 ffeinfoWhere where;
11338 ffeinfoKind kind;
11339
11340 if (!error
11341 && (expr != NULL)
11342 && (ffebld_op (expr) == FFEBLD_opSYMTER)
11343 && ((s = ffebld_symter (expr)), (where = ffesymbol_where (s)),
11344 (where == FFEINFO_whereINTRINSIC)
11345 || (where == FFEINFO_whereGLOBAL)
11346 || ((where == FFEINFO_whereDUMMY)
11347 && ((kind = ffesymbol_kind (s)),
11348 (kind == FFEINFO_kindFUNCTION)
11349 || (kind == FFEINFO_kindSUBROUTINE))))
11350 && !ffesymbol_explicitwhere (s))
11351 {
11352 ffebad_start (where == FFEINFO_whereINTRINSIC
11353 ? FFEBAD_NEED_INTRINSIC : FFEBAD_NEED_EXTERNAL);
11354 ffebad_here (0, ffelex_token_where_line (ft),
11355 ffelex_token_where_column (ft));
11356 ffebad_string (ffesymbol_text (s));
11357 ffebad_finish ();
11358 ffesymbol_signal_change (s);
11359 ffesymbol_set_explicitwhere (s, TRUE);
11360 ffesymbol_signal_unreported (s);
11361 }
11362 }
11363 break;
11364
11365 case FFEEXPR_contextINDEX_:
11366 case FFEEXPR_contextSFUNCDEFINDEX_:
11367 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11368 break;
11369 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11370 : ffeinfo_basictype (info))
11371 {
11372 case FFEINFO_basictypeNONE:
11373 error = FALSE;
11374 break;
11375
11376 case FFEINFO_basictypeLOGICAL:
11377 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11378 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11379 FFEEXPR_contextLET);
11380 /* Fall through. */
11381 case FFEINFO_basictypeREAL:
11382 case FFEINFO_basictypeCOMPLEX:
11383 if (ffe_is_pedantic ())
11384 {
11385 error = TRUE;
11386 break;
11387 }
11388 /* Fall through. */
11389 case FFEINFO_basictypeHOLLERITH:
11390 case FFEINFO_basictypeTYPELESS:
11391 error = FALSE;
11392 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11393 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11394 FFEEXPR_contextLET);
11395 break;
11396
11397 case FFEINFO_basictypeINTEGER:
11398 /* Specifically, allow INTEGER(KIND=2), aka INTEGER*8, through
11399 unmolested. Leave it to downstream to handle kinds. */
11400 break;
11401
11402 default:
11403 error = TRUE;
11404 break;
11405 }
11406 break; /* expr==NULL ok for substring; element case
11407 caught by callback. */
11408
11409 case FFEEXPR_contextRETURN:
11410 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11411 break;
11412 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11413 : ffeinfo_basictype (info))
11414 {
11415 case FFEINFO_basictypeNONE:
11416 error = FALSE;
11417 break;
11418
11419 case FFEINFO_basictypeLOGICAL:
11420 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11421 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11422 FFEEXPR_contextLET);
11423 /* Fall through. */
11424 case FFEINFO_basictypeREAL:
11425 case FFEINFO_basictypeCOMPLEX:
11426 if (ffe_is_pedantic ())
11427 {
11428 error = TRUE;
11429 break;
11430 }
11431 /* Fall through. */
11432 case FFEINFO_basictypeINTEGER:
11433 case FFEINFO_basictypeHOLLERITH:
11434 case FFEINFO_basictypeTYPELESS:
11435 error = FALSE;
11436 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11437 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11438 FFEEXPR_contextLET);
11439 break;
11440
11441 default:
11442 error = TRUE;
11443 break;
11444 }
11445 break;
11446
11447 case FFEEXPR_contextDO:
11448 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11449 break;
11450 switch (ffeinfo_basictype (info))
11451 {
11452 case FFEINFO_basictypeLOGICAL:
11453 error = !ffe_is_ugly_logint ();
11454 if (!ffeexpr_stack_->is_rhs)
11455 break; /* Don't convert lhs variable. */
11456 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11457 ffeinfo_kindtype (ffebld_info (expr)), 0,
11458 FFETARGET_charactersizeNONE,
11459 FFEEXPR_contextLET);
11460 break;
11461
11462 case FFEINFO_basictypeHOLLERITH:
11463 case FFEINFO_basictypeTYPELESS:
11464 if (!ffeexpr_stack_->is_rhs)
11465 {
11466 error = TRUE;
11467 break; /* Don't convert lhs variable. */
11468 }
11469 break;
11470
11471 case FFEINFO_basictypeINTEGER:
11472 case FFEINFO_basictypeREAL:
11473 break;
11474
11475 default:
11476 error = TRUE;
11477 break;
11478 }
11479 if (!ffeexpr_stack_->is_rhs
11480 && (ffebld_op (expr) != FFEBLD_opSYMTER))
11481 error = TRUE;
11482 break;
11483
11484 case FFEEXPR_contextDOWHILE:
11485 case FFEEXPR_contextIF:
11486 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11487 break;
11488 switch (ffeinfo_basictype (info))
11489 {
11490 case FFEINFO_basictypeINTEGER:
11491 error = FALSE;
11492 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11493 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11494 FFEEXPR_contextLET);
11495 /* Fall through. */
11496 case FFEINFO_basictypeLOGICAL:
11497 case FFEINFO_basictypeHOLLERITH:
11498 case FFEINFO_basictypeTYPELESS:
11499 error = FALSE;
11500 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11501 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11502 FFEEXPR_contextLET);
11503 break;
11504
11505 default:
11506 error = TRUE;
11507 break;
11508 }
11509 break;
11510
11511 case FFEEXPR_contextASSIGN:
11512 case FFEEXPR_contextAGOTO:
11513 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11514 : ffeinfo_basictype (info))
11515 {
11516 case FFEINFO_basictypeINTEGER:
11517 error = (ffeinfo_kindtype (info) != ffecom_label_kind ());
11518 break;
11519
11520 case FFEINFO_basictypeLOGICAL:
11521 error = !ffe_is_ugly_logint ()
11522 || (ffeinfo_kindtype (info) != ffecom_label_kind ());
11523 break;
11524
11525 default:
11526 error = TRUE;
11527 break;
11528 }
11529 if ((expr == NULL) || (ffeinfo_rank (info) != 0)
11530 || (ffebld_op (expr) != FFEBLD_opSYMTER))
11531 error = TRUE;
11532 break;
11533
11534 case FFEEXPR_contextCGOTO:
11535 case FFEEXPR_contextFORMAT:
11536 case FFEEXPR_contextDIMLIST:
11537 case FFEEXPR_contextFILENUM: /* See equiv code in _ambig_. */
11538 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11539 break;
11540 switch (ffeinfo_basictype (info))
11541 {
11542 case FFEINFO_basictypeLOGICAL:
11543 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11544 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11545 FFEEXPR_contextLET);
11546 /* Fall through. */
11547 case FFEINFO_basictypeREAL:
11548 case FFEINFO_basictypeCOMPLEX:
11549 if (ffe_is_pedantic ())
11550 {
11551 error = TRUE;
11552 break;
11553 }
11554 /* Fall through. */
11555 case FFEINFO_basictypeINTEGER:
11556 case FFEINFO_basictypeHOLLERITH:
11557 case FFEINFO_basictypeTYPELESS:
11558 error = FALSE;
11559 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11560 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11561 FFEEXPR_contextLET);
11562 break;
11563
11564 default:
11565 error = TRUE;
11566 break;
11567 }
11568 break;
11569
11570 case FFEEXPR_contextARITHIF:
11571 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11572 break;
11573 switch (ffeinfo_basictype (info))
11574 {
11575 case FFEINFO_basictypeLOGICAL:
11576 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11577 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11578 FFEEXPR_contextLET);
11579 if (ffe_is_pedantic ())
11580 {
11581 error = TRUE;
11582 break;
11583 }
11584 /* Fall through. */
11585 case FFEINFO_basictypeHOLLERITH:
11586 case FFEINFO_basictypeTYPELESS:
11587 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11588 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11589 FFEEXPR_contextLET);
11590 /* Fall through. */
11591 case FFEINFO_basictypeINTEGER:
11592 case FFEINFO_basictypeREAL:
11593 error = FALSE;
11594 break;
11595
11596 default:
11597 error = TRUE;
11598 break;
11599 }
11600 break;
11601
11602 case FFEEXPR_contextSTOP:
11603 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11604 break;
11605 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11606 : ffeinfo_basictype (info))
11607 {
11608 case FFEINFO_basictypeINTEGER:
11609 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
11610 break;
11611
11612 case FFEINFO_basictypeCHARACTER:
11613 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT);
11614 break;
11615
11616 case FFEINFO_basictypeHOLLERITH:
11617 case FFEINFO_basictypeTYPELESS:
11618 error = FALSE;
11619 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11620 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11621 FFEEXPR_contextLET);
11622 break;
11623
11624 case FFEINFO_basictypeNONE:
11625 error = FALSE;
11626 break;
11627
11628 default:
11629 error = TRUE;
11630 break;
11631 }
11632 if ((expr != NULL) && ((ffebld_op (expr) != FFEBLD_opCONTER)
11633 || (ffebld_conter_orig (expr) != NULL)))
11634 error = TRUE;
11635 break;
11636
11637 case FFEEXPR_contextINCLUDE:
11638 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
11639 || (ffeinfo_basictype (info) != FFEINFO_basictypeCHARACTER)
11640 || (ffebld_op (expr) != FFEBLD_opCONTER)
11641 || (ffebld_conter_orig (expr) != NULL);
11642 break;
11643
11644 case FFEEXPR_contextSELECTCASE:
11645 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11646 break;
11647 switch (ffeinfo_basictype (info))
11648 {
11649 case FFEINFO_basictypeINTEGER:
11650 case FFEINFO_basictypeCHARACTER:
11651 case FFEINFO_basictypeLOGICAL:
11652 error = FALSE;
11653 break;
11654
11655 case FFEINFO_basictypeHOLLERITH:
11656 case FFEINFO_basictypeTYPELESS:
11657 error = FALSE;
11658 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11659 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11660 FFEEXPR_contextLET);
11661 break;
11662
11663 default:
11664 error = TRUE;
11665 break;
11666 }
11667 break;
11668
11669 case FFEEXPR_contextCASE:
11670 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11671 break;
11672 switch ((expr == NULL) ? FFEINFO_basictypeINTEGER
11673 : ffeinfo_basictype (info))
11674 {
11675 case FFEINFO_basictypeINTEGER:
11676 case FFEINFO_basictypeCHARACTER:
11677 case FFEINFO_basictypeLOGICAL:
11678 error = FALSE;
11679 break;
11680
11681 case FFEINFO_basictypeHOLLERITH:
11682 case FFEINFO_basictypeTYPELESS:
11683 error = FALSE;
11684 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11685 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11686 FFEEXPR_contextLET);
11687 break;
11688
11689 default:
11690 error = TRUE;
11691 break;
11692 }
11693 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
11694 error = TRUE;
11695 break;
11696
11697 case FFEEXPR_contextCHARACTERSIZE:
11698 case FFEEXPR_contextKINDTYPE:
11699 case FFEEXPR_contextDIMLISTCOMMON:
11700 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11701 break;
11702 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11703 : ffeinfo_basictype (info))
11704 {
11705 case FFEINFO_basictypeLOGICAL:
11706 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11707 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11708 FFEEXPR_contextLET);
11709 /* Fall through. */
11710 case FFEINFO_basictypeREAL:
11711 case FFEINFO_basictypeCOMPLEX:
11712 if (ffe_is_pedantic ())
11713 {
11714 error = TRUE;
11715 break;
11716 }
11717 /* Fall through. */
11718 case FFEINFO_basictypeINTEGER:
11719 case FFEINFO_basictypeHOLLERITH:
11720 case FFEINFO_basictypeTYPELESS:
11721 error = FALSE;
11722 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11723 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11724 FFEEXPR_contextLET);
11725 break;
11726
11727 default:
11728 error = TRUE;
11729 break;
11730 }
11731 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
11732 error = TRUE;
11733 break;
11734
11735 case FFEEXPR_contextEQVINDEX_:
11736 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11737 break;
11738 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11739 : ffeinfo_basictype (info))
11740 {
11741 case FFEINFO_basictypeNONE:
11742 error = FALSE;
11743 break;
11744
11745 case FFEINFO_basictypeLOGICAL:
11746 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11747 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11748 FFEEXPR_contextLET);
11749 /* Fall through. */
11750 case FFEINFO_basictypeREAL:
11751 case FFEINFO_basictypeCOMPLEX:
11752 if (ffe_is_pedantic ())
11753 {
11754 error = TRUE;
11755 break;
11756 }
11757 /* Fall through. */
11758 case FFEINFO_basictypeINTEGER:
11759 case FFEINFO_basictypeHOLLERITH:
11760 case FFEINFO_basictypeTYPELESS:
11761 error = FALSE;
11762 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11763 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11764 FFEEXPR_contextLET);
11765 break;
11766
11767 default:
11768 error = TRUE;
11769 break;
11770 }
11771 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
11772 error = TRUE;
11773 break;
11774
11775 case FFEEXPR_contextPARAMETER:
11776 if (ffeexpr_stack_->is_rhs)
11777 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
11778 || (ffebld_op (expr) != FFEBLD_opCONTER);
11779 else
11780 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
11781 || (ffebld_op (expr) != FFEBLD_opSYMTER);
11782 break;
11783
11784 case FFEEXPR_contextINDEXORACTUALARG_:
11785 if (ffelex_token_type (t) == FFELEX_typeCOLON)
11786 ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
11787 else
11788 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
11789 goto again; /* :::::::::::::::::::: */
11790
11791 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
11792 if (ffelex_token_type (t) == FFELEX_typeCOLON)
11793 ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
11794 else
11795 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
11796 goto again; /* :::::::::::::::::::: */
11797
11798 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
11799 if (ffelex_token_type (t) == FFELEX_typeCOLON)
11800 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
11801 else
11802 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
11803 goto again; /* :::::::::::::::::::: */
11804
11805 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
11806 if (ffelex_token_type (t) == FFELEX_typeCOLON)
11807 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
11808 else
11809 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
11810 goto again; /* :::::::::::::::::::: */
11811
11812 case FFEEXPR_contextIMPDOCTRL_:
11813 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11814 break;
11815 if (!ffeexpr_stack_->is_rhs
11816 && (ffebld_op (expr) != FFEBLD_opSYMTER))
11817 error = TRUE;
11818 switch (ffeinfo_basictype (info))
11819 {
11820 case FFEINFO_basictypeLOGICAL:
11821 if (! ffe_is_ugly_logint ())
11822 error = TRUE;
11823 if (! ffeexpr_stack_->is_rhs)
11824 break;
11825 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11826 ffeinfo_kindtype (info), 0,
11827 FFETARGET_charactersizeNONE,
11828 FFEEXPR_contextLET);
11829 break;
11830
11831 case FFEINFO_basictypeINTEGER:
11832 case FFEINFO_basictypeHOLLERITH:
11833 case FFEINFO_basictypeTYPELESS:
11834 break;
11835
11836 case FFEINFO_basictypeREAL:
11837 if (!ffeexpr_stack_->is_rhs
11838 && ffe_is_warn_surprising ()
11839 && !error)
11840 {
11841 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
11842 ffebad_here (0, ffelex_token_where_line (ft),
11843 ffelex_token_where_column (ft));
11844 ffebad_string (ffelex_token_text (ft));
11845 ffebad_finish ();
11846 }
11847 break;
11848
11849 default:
11850 error = TRUE;
11851 break;
11852 }
11853 break;
11854
11855 case FFEEXPR_contextDATAIMPDOCTRL_:
11856 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11857 break;
11858 if (ffeexpr_stack_->is_rhs)
11859 {
11860 if ((ffebld_op (expr) != FFEBLD_opCONTER)
11861 && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
11862 error = TRUE;
11863 }
11864 else if ((ffebld_op (expr) != FFEBLD_opSYMTER)
11865 || (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
11866 error = TRUE;
11867 switch (ffeinfo_basictype (info))
11868 {
11869 case FFEINFO_basictypeLOGICAL:
11870 if (! ffeexpr_stack_->is_rhs)
11871 break;
11872 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11873 ffeinfo_kindtype (info), 0,
11874 FFETARGET_charactersizeNONE,
11875 FFEEXPR_contextLET);
11876 /* Fall through. */
11877 case FFEINFO_basictypeINTEGER:
11878 if (ffeexpr_stack_->is_rhs
11879 && (ffeinfo_kindtype (ffebld_info (expr))
11880 != FFEINFO_kindtypeINTEGERDEFAULT))
11881 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11882 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11883 FFETARGET_charactersizeNONE,
11884 FFEEXPR_contextLET);
11885 break;
11886
11887 case FFEINFO_basictypeHOLLERITH:
11888 case FFEINFO_basictypeTYPELESS:
11889 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11890 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11891 FFEEXPR_contextLET);
11892 break;
11893
11894 case FFEINFO_basictypeREAL:
11895 if (!ffeexpr_stack_->is_rhs
11896 && ffe_is_warn_surprising ()
11897 && !error)
11898 {
11899 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
11900 ffebad_here (0, ffelex_token_where_line (ft),
11901 ffelex_token_where_column (ft));
11902 ffebad_string (ffelex_token_text (ft));
11903 ffebad_finish ();
11904 }
11905 break;
11906
11907 default:
11908 error = TRUE;
11909 break;
11910 }
11911 break;
11912
11913 case FFEEXPR_contextIMPDOITEM_:
11914 if (ffelex_token_type (t) == FFELEX_typeEQUALS)
11915 {
11916 ffeexpr_stack_->is_rhs = FALSE;
11917 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
11918 goto again; /* :::::::::::::::::::: */
11919 }
11920 /* Fall through. */
11921 case FFEEXPR_contextIOLIST:
11922 case FFEEXPR_contextFILEVXTCODE:
11923 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11924 : ffeinfo_basictype (info))
11925 {
11926 case FFEINFO_basictypeHOLLERITH:
11927 case FFEINFO_basictypeTYPELESS:
11928 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11929 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11930 FFEEXPR_contextLET);
11931 break;
11932
11933 default:
11934 break;
11935 }
11936 error = (expr == NULL)
11937 || ((ffeinfo_rank (info) != 0)
11938 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
11939 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
11940 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
11941 == FFEBLD_opSTAR))); /* Bad if null expr, or if
11942 array that is not a SYMTER
11943 (can't happen yet, I
11944 think) or has a NULL or
11945 STAR (assumed) array
11946 size. */
11947 break;
11948
11949 case FFEEXPR_contextIMPDOITEMDF_:
11950 if (ffelex_token_type (t) == FFELEX_typeEQUALS)
11951 {
11952 ffeexpr_stack_->is_rhs = FALSE;
11953 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
11954 goto again; /* :::::::::::::::::::: */
11955 }
11956 /* Fall through. */
11957 case FFEEXPR_contextIOLISTDF:
11958 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11959 : ffeinfo_basictype (info))
11960 {
11961 case FFEINFO_basictypeHOLLERITH:
11962 case FFEINFO_basictypeTYPELESS:
11963 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11964 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11965 FFEEXPR_contextLET);
11966 break;
11967
11968 default:
11969 break;
11970 }
11971 error
11972 = (expr == NULL)
11973 || ((ffeinfo_basictype (info) == FFEINFO_basictypeCHARACTER)
11974 && (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT))
11975 || ((ffeinfo_rank (info) != 0)
11976 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
11977 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
11978 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
11979 == FFEBLD_opSTAR))); /* Bad if null expr,
11980 non-default-kindtype
11981 character expr, or if
11982 array that is not a SYMTER
11983 (can't happen yet, I
11984 think) or has a NULL or
11985 STAR (assumed) array
11986 size. */
11987 break;
11988
11989 case FFEEXPR_contextDATAIMPDOITEM_:
11990 error = (expr == NULL)
11991 || (ffebld_op (expr) != FFEBLD_opARRAYREF)
11992 || ((ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR)
11993 && (ffeinfo_where (info) != FFEINFO_whereFLEETING_IADDR));
11994 break;
11995
11996 case FFEEXPR_contextDATAIMPDOINDEX_:
11997 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11998 break;
11999 switch (ffeinfo_basictype (info))
12000 {
12001 case FFEINFO_basictypeLOGICAL:
12002 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12003 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12004 FFEEXPR_contextLET);
12005 /* Fall through. */
12006 case FFEINFO_basictypeREAL:
12007 case FFEINFO_basictypeCOMPLEX:
12008 if (ffe_is_pedantic ())
12009 {
12010 error = TRUE;
12011 break;
12012 }
12013 /* Fall through. */
12014 case FFEINFO_basictypeINTEGER:
12015 case FFEINFO_basictypeHOLLERITH:
12016 case FFEINFO_basictypeTYPELESS:
12017 error = FALSE;
12018 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12019 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12020 FFEEXPR_contextLET);
12021 break;
12022
12023 default:
12024 error = TRUE;
12025 break;
12026 }
12027 if ((ffeinfo_where (info) != FFEINFO_whereCONSTANT)
12028 && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12029 error = TRUE;
12030 break;
12031
12032 case FFEEXPR_contextDATA:
12033 if (expr == NULL)
12034 error = TRUE;
12035 else if (ffeexpr_stack_->is_rhs)
12036 error = (ffebld_op (expr) != FFEBLD_opCONTER);
12037 else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12038 error = FALSE;
12039 else
12040 error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12041 break;
12042
12043 case FFEEXPR_contextINITVAL:
12044 error = (expr == NULL) || (ffebld_op (expr) != FFEBLD_opCONTER);
12045 break;
12046
12047 case FFEEXPR_contextEQUIVALENCE:
12048 if (expr == NULL)
12049 error = TRUE;
12050 else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12051 error = FALSE;
12052 else
12053 error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12054 break;
12055
12056 case FFEEXPR_contextFILEASSOC:
12057 case FFEEXPR_contextFILEINT:
12058 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12059 : ffeinfo_basictype (info))
12060 {
12061 case FFEINFO_basictypeINTEGER:
12062 /* Maybe this should be supported someday, but, right now,
12063 g77 can't generate a call to libf2c to write to an
12064 integer other than the default size. */
12065 error = ((! ffeexpr_stack_->is_rhs)
12066 && ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12067 break;
12068
12069 default:
12070 error = TRUE;
12071 break;
12072 }
12073 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12074 error = TRUE;
12075 break;
12076
12077 case FFEEXPR_contextFILEDFINT:
12078 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12079 : ffeinfo_basictype (info))
12080 {
12081 case FFEINFO_basictypeINTEGER:
12082 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12083 break;
12084
12085 default:
12086 error = TRUE;
12087 break;
12088 }
12089 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12090 error = TRUE;
12091 break;
12092
12093 case FFEEXPR_contextFILELOG:
12094 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12095 : ffeinfo_basictype (info))
12096 {
12097 case FFEINFO_basictypeLOGICAL:
12098 error = FALSE;
12099 break;
12100
12101 default:
12102 error = TRUE;
12103 break;
12104 }
12105 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12106 error = TRUE;
12107 break;
12108
12109 case FFEEXPR_contextFILECHAR:
12110 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12111 : ffeinfo_basictype (info))
12112 {
12113 case FFEINFO_basictypeCHARACTER:
12114 error = FALSE;
12115 break;
12116
12117 default:
12118 error = TRUE;
12119 break;
12120 }
12121 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12122 error = TRUE;
12123 break;
12124
12125 case FFEEXPR_contextFILENUMCHAR:
12126 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12127 break;
12128 switch (ffeinfo_basictype (info))
12129 {
12130 case FFEINFO_basictypeLOGICAL:
12131 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12132 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12133 FFEEXPR_contextLET);
12134 /* Fall through. */
12135 case FFEINFO_basictypeREAL:
12136 case FFEINFO_basictypeCOMPLEX:
12137 if (ffe_is_pedantic ())
12138 {
12139 error = TRUE;
12140 break;
12141 }
12142 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12143 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12144 FFEEXPR_contextLET);
12145 break;
12146
12147 case FFEINFO_basictypeINTEGER:
12148 case FFEINFO_basictypeCHARACTER:
12149 error = FALSE;
12150 break;
12151
12152 default:
12153 error = TRUE;
12154 break;
12155 }
12156 break;
12157
12158 case FFEEXPR_contextFILEDFCHAR:
12159 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12160 break;
12161 switch (ffeinfo_basictype (info))
12162 {
12163 case FFEINFO_basictypeCHARACTER:
12164 error
12165 = (ffeinfo_kindtype (info)
12166 != FFEINFO_kindtypeCHARACTERDEFAULT);
12167 break;
12168
12169 default:
12170 error = TRUE;
12171 break;
12172 }
12173 if (!ffeexpr_stack_->is_rhs
12174 && (ffebld_op (expr) == FFEBLD_opSUBSTR))
12175 error = TRUE;
12176 break;
12177
12178 case FFEEXPR_contextFILEUNIT: /* See equiv code in _ambig_. */
12179 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12180 : ffeinfo_basictype (info))
12181 {
12182 case FFEINFO_basictypeLOGICAL:
12183 if ((error = (ffeinfo_rank (info) != 0)))
12184 break;
12185 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12186 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12187 FFEEXPR_contextLET);
12188 /* Fall through. */
12189 case FFEINFO_basictypeREAL:
12190 case FFEINFO_basictypeCOMPLEX:
12191 if ((error = (ffeinfo_rank (info) != 0)))
12192 break;
12193 if (ffe_is_pedantic ())
12194 {
12195 error = TRUE;
12196 break;
12197 }
12198 /* Fall through. */
12199 case FFEINFO_basictypeINTEGER:
12200 case FFEINFO_basictypeHOLLERITH:
12201 case FFEINFO_basictypeTYPELESS:
12202 if ((error = (ffeinfo_rank (info) != 0)))
12203 break;
12204 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12205 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12206 FFEEXPR_contextLET);
12207 break;
12208
12209 case FFEINFO_basictypeCHARACTER:
12210 switch (ffebld_op (expr))
12211 { /* As if _lhs had been called instead of
12212 _rhs. */
12213 case FFEBLD_opSYMTER:
12214 error
12215 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
12216 break;
12217
12218 case FFEBLD_opSUBSTR:
12219 error = (ffeinfo_where (ffebld_info (expr))
12220 == FFEINFO_whereCONSTANT_SUBOBJECT);
12221 break;
12222
12223 case FFEBLD_opARRAYREF:
12224 error = FALSE;
12225 break;
12226
12227 default:
12228 error = TRUE;
12229 break;
12230 }
12231 if (!error
12232 && ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
12233 || ((ffeinfo_rank (info) != 0)
12234 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12235 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12236 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12237 == FFEBLD_opSTAR))))) /* Bad if
12238 non-default-kindtype
12239 character expr, or if
12240 array that is not a SYMTER
12241 (can't happen yet, I
12242 think), or has a NULL or
12243 STAR (assumed) array
12244 size. */
12245 error = TRUE;
12246 break;
12247
12248 default:
12249 error = TRUE;
12250 break;
12251 }
12252 break;
12253
12254 case FFEEXPR_contextFILEFORMAT:
12255 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12256 : ffeinfo_basictype (info))
12257 {
12258 case FFEINFO_basictypeINTEGER:
12259 error = (expr == NULL)
12260 || ((ffeinfo_rank (info) != 0) ?
12261 ffe_is_pedantic () /* F77 C5. */
12262 : (bool) (ffeinfo_kindtype (info) != ffecom_label_kind ()))
12263 || (ffebld_op (expr) != FFEBLD_opSYMTER);
12264 break;
12265
12266 case FFEINFO_basictypeLOGICAL:
12267 case FFEINFO_basictypeREAL:
12268 case FFEINFO_basictypeCOMPLEX:
12269 /* F77 C5 -- must be an array of hollerith. */
12270 error
12271 = ffe_is_pedantic ()
12272 || (ffeinfo_rank (info) == 0);
12273 break;
12274
12275 case FFEINFO_basictypeCHARACTER:
12276 if ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
12277 || ((ffeinfo_rank (info) != 0)
12278 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12279 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12280 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12281 == FFEBLD_opSTAR)))) /* Bad if
12282 non-default-kindtype
12283 character expr, or if
12284 array that is not a SYMTER
12285 (can't happen yet, I
12286 think), or has a NULL or
12287 STAR (assumed) array
12288 size. */
12289 error = TRUE;
12290 else
12291 error = FALSE;
12292 break;
12293
12294 default:
12295 error = TRUE;
12296 break;
12297 }
12298 break;
12299
12300 case FFEEXPR_contextLOC_:
12301 /* See also ffeintrin_check_loc_. */
12302 if ((expr == NULL)
12303 || (ffeinfo_kind (info) != FFEINFO_kindENTITY)
12304 || ((ffebld_op (expr) != FFEBLD_opSYMTER)
12305 && (ffebld_op (expr) != FFEBLD_opSUBSTR)
12306 && (ffebld_op (expr) != FFEBLD_opARRAYREF)))
12307 error = TRUE;
12308 break;
12309
12310 default:
12311 error = FALSE;
12312 break;
12313 }
12314
12315 if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
12316 {
12317 ffebad_start (FFEBAD_EXPR_WRONG);
12318 ffebad_here (0, ffelex_token_where_line (ft),
12319 ffelex_token_where_column (ft));
12320 ffebad_finish ();
12321 expr = ffebld_new_any ();
12322 ffebld_set_info (expr, ffeinfo_new_any ());
12323 }
12324
12325 callback = ffeexpr_stack_->callback;
12326 s = ffeexpr_stack_->previous;
12327 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
12328 sizeof (*ffeexpr_stack_));
12329 ffeexpr_stack_ = s;
12330 next = (ffelexHandler) (*callback) (ft, expr, t);
12331 ffelex_token_kill (ft);
12332 return (ffelexHandler) next;
12333 }
12334
12335 /* ffeexpr_finished_ambig_ -- Check validity of ambiguous unit/form spec
12336
12337 ffebld expr;
12338 expr = ffeexpr_finished_ambig_(expr);
12339
12340 Replicates a bit of ffeexpr_finished_'s task when in a context
12341 of UNIT or FORMAT. */
12342
12343 static ffebld
12344 ffeexpr_finished_ambig_ (ffelexToken ft, ffebld expr)
12345 {
12346 ffeinfo info = ffebld_info (expr);
12347 bool error;
12348
12349 switch (ffeexpr_stack_->context)
12350 {
12351 case FFEEXPR_contextFILENUMAMBIG: /* Same as FILENUM in _finished_. */
12352 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12353 : ffeinfo_basictype (info))
12354 {
12355 case FFEINFO_basictypeLOGICAL:
12356 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12357 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12358 FFEEXPR_contextLET);
12359 /* Fall through. */
12360 case FFEINFO_basictypeREAL:
12361 case FFEINFO_basictypeCOMPLEX:
12362 if (ffe_is_pedantic ())
12363 {
12364 error = TRUE;
12365 break;
12366 }
12367 /* Fall through. */
12368 case FFEINFO_basictypeINTEGER:
12369 case FFEINFO_basictypeHOLLERITH:
12370 case FFEINFO_basictypeTYPELESS:
12371 error = FALSE;
12372 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12373 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12374 FFEEXPR_contextLET);
12375 break;
12376
12377 default:
12378 error = TRUE;
12379 break;
12380 }
12381 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12382 error = TRUE;
12383 break;
12384
12385 case FFEEXPR_contextFILEUNITAMBIG: /* Same as FILEUNIT in _finished_. */
12386 if ((expr != NULL) && (ffebld_op (expr) == FFEBLD_opSTAR))
12387 {
12388 error = FALSE;
12389 break;
12390 }
12391 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12392 : ffeinfo_basictype (info))
12393 {
12394 case FFEINFO_basictypeLOGICAL:
12395 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12396 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12397 FFEEXPR_contextLET);
12398 /* Fall through. */
12399 case FFEINFO_basictypeREAL:
12400 case FFEINFO_basictypeCOMPLEX:
12401 if (ffe_is_pedantic ())
12402 {
12403 error = TRUE;
12404 break;
12405 }
12406 /* Fall through. */
12407 case FFEINFO_basictypeINTEGER:
12408 case FFEINFO_basictypeHOLLERITH:
12409 case FFEINFO_basictypeTYPELESS:
12410 error = (ffeinfo_rank (info) != 0);
12411 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12412 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12413 FFEEXPR_contextLET);
12414 break;
12415
12416 case FFEINFO_basictypeCHARACTER:
12417 switch (ffebld_op (expr))
12418 { /* As if _lhs had been called instead of
12419 _rhs. */
12420 case FFEBLD_opSYMTER:
12421 error
12422 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
12423 break;
12424
12425 case FFEBLD_opSUBSTR:
12426 error = (ffeinfo_where (ffebld_info (expr))
12427 == FFEINFO_whereCONSTANT_SUBOBJECT);
12428 break;
12429
12430 case FFEBLD_opARRAYREF:
12431 error = FALSE;
12432 break;
12433
12434 default:
12435 error = TRUE;
12436 break;
12437 }
12438 break;
12439
12440 default:
12441 error = TRUE;
12442 break;
12443 }
12444 break;
12445
12446 default:
12447 assert ("bad context" == NULL);
12448 error = TRUE;
12449 break;
12450 }
12451
12452 if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
12453 {
12454 ffebad_start (FFEBAD_EXPR_WRONG);
12455 ffebad_here (0, ffelex_token_where_line (ft),
12456 ffelex_token_where_column (ft));
12457 ffebad_finish ();
12458 expr = ffebld_new_any ();
12459 ffebld_set_info (expr, ffeinfo_new_any ());
12460 }
12461
12462 return expr;
12463 }
12464
12465 /* ffeexpr_token_lhs_ -- Initial state for lhs expression
12466
12467 Return a pointer to this function to the lexer (ffelex), which will
12468 invoke it for the next token.
12469
12470 Basically a smaller version of _rhs_; keep them both in sync, of course. */
12471
12472 static ffelexHandler
12473 ffeexpr_token_lhs_ (ffelexToken t)
12474 {
12475
12476 /* When changing the list of valid initial lhs tokens, check whether to
12477 update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
12478 READ (expr) <token> case -- it assumes it knows which tokens <token> can
12479 be to indicate an lhs (or implied DO), which right now is the set
12480 {NAME,OPEN_PAREN}.
12481
12482 This comment also appears in ffeexpr_token_first_lhs_. */
12483
12484 switch (ffelex_token_type (t))
12485 {
12486 case FFELEX_typeNAME:
12487 case FFELEX_typeNAMES:
12488 ffeexpr_tokens_[0] = ffelex_token_use (t);
12489 return (ffelexHandler) ffeexpr_token_name_lhs_;
12490
12491 default:
12492 return (ffelexHandler) ffeexpr_finished_ (t);
12493 }
12494 }
12495
12496 /* ffeexpr_token_rhs_ -- Initial state for rhs expression
12497
12498 Return a pointer to this function to the lexer (ffelex), which will
12499 invoke it for the next token.
12500
12501 The initial state and the post-binary-operator state are the same and
12502 both handled here, with the expression stack used to distinguish
12503 between them. Binary operators are invalid here; unary operators,
12504 constants, subexpressions, and name references are valid. */
12505
12506 static ffelexHandler
12507 ffeexpr_token_rhs_ (ffelexToken t)
12508 {
12509 ffeexprExpr_ e;
12510
12511 switch (ffelex_token_type (t))
12512 {
12513 case FFELEX_typeQUOTE:
12514 if (ffe_is_vxt ())
12515 {
12516 ffeexpr_tokens_[0] = ffelex_token_use (t);
12517 return (ffelexHandler) ffeexpr_token_quote_;
12518 }
12519 ffeexpr_tokens_[0] = ffelex_token_use (t);
12520 ffelex_set_expecting_hollerith (-1, '\"',
12521 ffelex_token_where_line (t),
12522 ffelex_token_where_column (t));
12523 /* Don't have to unset this one. */
12524 return (ffelexHandler) ffeexpr_token_apostrophe_;
12525
12526 case FFELEX_typeAPOSTROPHE:
12527 ffeexpr_tokens_[0] = ffelex_token_use (t);
12528 ffelex_set_expecting_hollerith (-1, '\'',
12529 ffelex_token_where_line (t),
12530 ffelex_token_where_column (t));
12531 /* Don't have to unset this one. */
12532 return (ffelexHandler) ffeexpr_token_apostrophe_;
12533
12534 case FFELEX_typePERCENT:
12535 ffeexpr_tokens_[0] = ffelex_token_use (t);
12536 return (ffelexHandler) ffeexpr_token_percent_;
12537
12538 case FFELEX_typeOPEN_PAREN:
12539 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
12540 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
12541 FFEEXPR_contextPAREN_,
12542 ffeexpr_cb_close_paren_c_);
12543
12544 case FFELEX_typePLUS:
12545 e = ffeexpr_expr_new_ ();
12546 e->type = FFEEXPR_exprtypeUNARY_;
12547 e->token = ffelex_token_use (t);
12548 e->u.operator.op = FFEEXPR_operatorADD_;
12549 e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
12550 e->u.operator.as = FFEEXPR_operatorassociativityADD_;
12551 ffeexpr_exprstack_push_unary_ (e);
12552 return (ffelexHandler) ffeexpr_token_rhs_;
12553
12554 case FFELEX_typeMINUS:
12555 e = ffeexpr_expr_new_ ();
12556 e->type = FFEEXPR_exprtypeUNARY_;
12557 e->token = ffelex_token_use (t);
12558 e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
12559 e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
12560 e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
12561 ffeexpr_exprstack_push_unary_ (e);
12562 return (ffelexHandler) ffeexpr_token_rhs_;
12563
12564 case FFELEX_typePERIOD:
12565 ffeexpr_tokens_[0] = ffelex_token_use (t);
12566 return (ffelexHandler) ffeexpr_token_period_;
12567
12568 case FFELEX_typeNUMBER:
12569 ffeexpr_tokens_[0] = ffelex_token_use (t);
12570 ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
12571 if (ffeexpr_hollerith_count_ > 0)
12572 ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
12573 '\0',
12574 ffelex_token_where_line (t),
12575 ffelex_token_where_column (t));
12576 return (ffelexHandler) ffeexpr_token_number_;
12577
12578 case FFELEX_typeNAME:
12579 case FFELEX_typeNAMES:
12580 ffeexpr_tokens_[0] = ffelex_token_use (t);
12581 switch (ffeexpr_stack_->context)
12582 {
12583 case FFEEXPR_contextACTUALARG_:
12584 case FFEEXPR_contextINDEXORACTUALARG_:
12585 case FFEEXPR_contextSFUNCDEFACTUALARG_:
12586 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
12587 return (ffelexHandler) ffeexpr_token_name_arg_;
12588
12589 default:
12590 return (ffelexHandler) ffeexpr_token_name_rhs_;
12591 }
12592
12593 case FFELEX_typeASTERISK:
12594 case FFELEX_typeSLASH:
12595 case FFELEX_typePOWER:
12596 case FFELEX_typeCONCAT:
12597 case FFELEX_typeREL_EQ:
12598 case FFELEX_typeREL_NE:
12599 case FFELEX_typeREL_LE:
12600 case FFELEX_typeREL_GE:
12601 if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
12602 {
12603 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
12604 ffebad_finish ();
12605 }
12606 return (ffelexHandler) ffeexpr_token_rhs_;
12607
12608 #if 0
12609 case FFELEX_typeEQUALS:
12610 case FFELEX_typePOINTS:
12611 case FFELEX_typeCLOSE_ANGLE:
12612 case FFELEX_typeCLOSE_PAREN:
12613 case FFELEX_typeCOMMA:
12614 case FFELEX_typeCOLON:
12615 case FFELEX_typeEOS:
12616 case FFELEX_typeSEMICOLON:
12617 #endif
12618 default:
12619 return (ffelexHandler) ffeexpr_finished_ (t);
12620 }
12621 }
12622
12623 /* ffeexpr_token_period_ -- Rhs PERIOD
12624
12625 Return a pointer to this function to the lexer (ffelex), which will
12626 invoke it for the next token.
12627
12628 Handle a period detected at rhs (expecting unary op or operand) state.
12629 Must begin a floating-point value (as in .12) or a dot-dot name, of
12630 which only .NOT., .TRUE., and .FALSE. are truly valid. Other sort-of-
12631 valid names represent binary operators, which are invalid here because
12632 there isn't an operand at the top of the stack. */
12633
12634 static ffelexHandler
12635 ffeexpr_token_period_ (ffelexToken t)
12636 {
12637 switch (ffelex_token_type (t))
12638 {
12639 case FFELEX_typeNAME:
12640 case FFELEX_typeNAMES:
12641 ffeexpr_current_dotdot_ = ffestr_other (t);
12642 switch (ffeexpr_current_dotdot_)
12643 {
12644 case FFESTR_otherNone:
12645 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
12646 {
12647 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
12648 ffelex_token_where_column (ffeexpr_tokens_[0]));
12649 ffebad_finish ();
12650 }
12651 ffelex_token_kill (ffeexpr_tokens_[0]);
12652 return (ffelexHandler) ffeexpr_token_rhs_ (t);
12653
12654 case FFESTR_otherTRUE:
12655 case FFESTR_otherFALSE:
12656 case FFESTR_otherNOT:
12657 ffeexpr_tokens_[1] = ffelex_token_use (t);
12658 return (ffelexHandler) ffeexpr_token_end_period_;
12659
12660 default:
12661 if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
12662 {
12663 ffebad_here (0, ffelex_token_where_line (t),
12664 ffelex_token_where_column (t));
12665 ffebad_finish ();
12666 }
12667 ffelex_token_kill (ffeexpr_tokens_[0]);
12668 return (ffelexHandler) ffeexpr_token_swallow_period_;
12669 }
12670 break; /* Nothing really reaches here. */
12671
12672 case FFELEX_typeNUMBER:
12673 ffeexpr_tokens_[1] = ffelex_token_use (t);
12674 return (ffelexHandler) ffeexpr_token_real_;
12675
12676 default:
12677 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
12678 {
12679 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
12680 ffelex_token_where_column (ffeexpr_tokens_[0]));
12681 ffebad_finish ();
12682 }
12683 ffelex_token_kill (ffeexpr_tokens_[0]);
12684 return (ffelexHandler) ffeexpr_token_rhs_ (t);
12685 }
12686 }
12687
12688 /* ffeexpr_token_end_period_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
12689
12690 Return a pointer to this function to the lexer (ffelex), which will
12691 invoke it for the next token.
12692
12693 Expecting a period to close a .NOT, .TRUE, or .FALSE at rhs (unary op
12694 or operator) state. If period isn't found, issue a diagnostic but
12695 pretend we saw one. ffeexpr_current_dotdot_ must already contained the
12696 dotdot representation of the name in between the two PERIOD tokens. */
12697
12698 static ffelexHandler
12699 ffeexpr_token_end_period_ (ffelexToken t)
12700 {
12701 ffeexprExpr_ e;
12702
12703 if (ffelex_token_type (t) != FFELEX_typePERIOD)
12704 {
12705 if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
12706 {
12707 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
12708 ffelex_token_where_column (ffeexpr_tokens_[0]));
12709 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
12710 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
12711 ffebad_finish ();
12712 }
12713 }
12714
12715 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill "NOT"/"TRUE"/"FALSE"
12716 token. */
12717
12718 e = ffeexpr_expr_new_ ();
12719 e->token = ffeexpr_tokens_[0];
12720
12721 switch (ffeexpr_current_dotdot_)
12722 {
12723 case FFESTR_otherNOT:
12724 e->type = FFEEXPR_exprtypeUNARY_;
12725 e->u.operator.op = FFEEXPR_operatorNOT_;
12726 e->u.operator.prec = FFEEXPR_operatorprecedenceNOT_;
12727 e->u.operator.as = FFEEXPR_operatorassociativityNOT_;
12728 ffeexpr_exprstack_push_unary_ (e);
12729 if (ffelex_token_type (t) != FFELEX_typePERIOD)
12730 return (ffelexHandler) ffeexpr_token_rhs_ (t);
12731 return (ffelexHandler) ffeexpr_token_rhs_;
12732
12733 case FFESTR_otherTRUE:
12734 e->type = FFEEXPR_exprtypeOPERAND_;
12735 e->u.operand
12736 = ffebld_new_conter (ffebld_constant_new_logicaldefault (TRUE));
12737 ffebld_set_info (e->u.operand,
12738 ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
12739 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
12740 ffeexpr_exprstack_push_operand_ (e);
12741 if (ffelex_token_type (t) != FFELEX_typePERIOD)
12742 return (ffelexHandler) ffeexpr_token_binary_ (t);
12743 return (ffelexHandler) ffeexpr_token_binary_;
12744
12745 case FFESTR_otherFALSE:
12746 e->type = FFEEXPR_exprtypeOPERAND_;
12747 e->u.operand
12748 = ffebld_new_conter (ffebld_constant_new_logicaldefault (FALSE));
12749 ffebld_set_info (e->u.operand,
12750 ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
12751 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
12752 ffeexpr_exprstack_push_operand_ (e);
12753 if (ffelex_token_type (t) != FFELEX_typePERIOD)
12754 return (ffelexHandler) ffeexpr_token_binary_ (t);
12755 return (ffelexHandler) ffeexpr_token_binary_;
12756
12757 default:
12758 assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL);
12759 exit (0);
12760 return NULL;
12761 }
12762 }
12763
12764 /* ffeexpr_token_swallow_period_ -- Rhs PERIOD NAME(not NOT, TRUE, or FALSE)
12765
12766 Return a pointer to this function to the lexer (ffelex), which will
12767 invoke it for the next token.
12768
12769 A diagnostic has already been issued; just swallow a period if there is
12770 one, then continue with ffeexpr_token_rhs_. */
12771
12772 static ffelexHandler
12773 ffeexpr_token_swallow_period_ (ffelexToken t)
12774 {
12775 if (ffelex_token_type (t) != FFELEX_typePERIOD)
12776 return (ffelexHandler) ffeexpr_token_rhs_ (t);
12777
12778 return (ffelexHandler) ffeexpr_token_rhs_;
12779 }
12780
12781 /* ffeexpr_token_real_ -- Rhs PERIOD NUMBER
12782
12783 Return a pointer to this function to the lexer (ffelex), which will
12784 invoke it for the next token.
12785
12786 After a period and a string of digits, check next token for possible
12787 exponent designation (D, E, or Q as first/only character) and continue
12788 real-number handling accordingly. Else form basic real constant, push
12789 onto expression stack, and enter binary state using current token (which,
12790 if it is a name not beginning with D, E, or Q, will certainly result
12791 in an error, but that's not for this routine to deal with). */
12792
12793 static ffelexHandler
12794 ffeexpr_token_real_ (ffelexToken t)
12795 {
12796 char d;
12797 const char *p;
12798
12799 if (((ffelex_token_type (t) != FFELEX_typeNAME)
12800 && (ffelex_token_type (t) != FFELEX_typeNAMES))
12801 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
12802 'D', 'd')
12803 || ffesrc_char_match_init (d, 'E', 'e')
12804 || ffesrc_char_match_init (d, 'Q', 'q')))
12805 && ffeexpr_isdigits_ (++p)))
12806 {
12807 #if 0
12808 /* This code has been removed because it seems inconsistent to
12809 produce a diagnostic in this case, but not all of the other
12810 ones that look for an exponent and cannot recognize one. */
12811 if (((ffelex_token_type (t) == FFELEX_typeNAME)
12812 || (ffelex_token_type (t) == FFELEX_typeNAMES))
12813 && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
12814 {
12815 char bad[2];
12816
12817 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
12818 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
12819 ffelex_token_where_column (ffeexpr_tokens_[0]));
12820 bad[0] = *(p - 1);
12821 bad[1] = '\0';
12822 ffebad_string (bad);
12823 ffebad_finish ();
12824 }
12825 #endif
12826 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
12827 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
12828 NULL, NULL, NULL);
12829
12830 ffelex_token_kill (ffeexpr_tokens_[0]);
12831 ffelex_token_kill (ffeexpr_tokens_[1]);
12832 return (ffelexHandler) ffeexpr_token_binary_ (t);
12833 }
12834
12835 /* Just exponent character by itself? In which case, PLUS or MINUS must
12836 surely be next, followed by a NUMBER token. */
12837
12838 if (*p == '\0')
12839 {
12840 ffeexpr_tokens_[2] = ffelex_token_use (t);
12841 return (ffelexHandler) ffeexpr_token_real_exponent_;
12842 }
12843
12844 ffeexpr_make_float_const_ (d, NULL, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
12845 t, NULL, NULL);
12846
12847 ffelex_token_kill (ffeexpr_tokens_[0]);
12848 ffelex_token_kill (ffeexpr_tokens_[1]);
12849 return (ffelexHandler) ffeexpr_token_binary_;
12850 }
12851
12852 /* ffeexpr_token_real_exponent_ -- Rhs PERIOD NUMBER NAME(D, E, or Q)
12853
12854 Return a pointer to this function to the lexer (ffelex), which will
12855 invoke it for the next token.
12856
12857 Ensures this token is PLUS or MINUS, preserves it, goes to final state
12858 for real number (exponent digits). Else issues diagnostic, assumes a
12859 zero exponent field for number, passes token on to binary state as if
12860 previous token had been "E0" instead of "E", for example. */
12861
12862 static ffelexHandler
12863 ffeexpr_token_real_exponent_ (ffelexToken t)
12864 {
12865 if ((ffelex_token_type (t) != FFELEX_typePLUS)
12866 && (ffelex_token_type (t) != FFELEX_typeMINUS))
12867 {
12868 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
12869 {
12870 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
12871 ffelex_token_where_column (ffeexpr_tokens_[2]));
12872 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
12873 ffebad_finish ();
12874 }
12875
12876 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
12877 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
12878 NULL, NULL, NULL);
12879
12880 ffelex_token_kill (ffeexpr_tokens_[0]);
12881 ffelex_token_kill (ffeexpr_tokens_[1]);
12882 ffelex_token_kill (ffeexpr_tokens_[2]);
12883 return (ffelexHandler) ffeexpr_token_binary_ (t);
12884 }
12885
12886 ffeexpr_tokens_[3] = ffelex_token_use (t);
12887 return (ffelexHandler) ffeexpr_token_real_exp_sign_;
12888 }
12889
12890 /* ffeexpr_token_real_exp_sign_ -- Rhs PERIOD NUMBER NAME(D,E,Q) PLUS/MINUS
12891
12892 Return a pointer to this function to the lexer (ffelex), which will
12893 invoke it for the next token.
12894
12895 Make sure token is a NUMBER, make a real constant out of all we have and
12896 push it onto the expression stack. Else issue diagnostic and pretend
12897 exponent field was a zero. */
12898
12899 static ffelexHandler
12900 ffeexpr_token_real_exp_sign_ (ffelexToken t)
12901 {
12902 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
12903 {
12904 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
12905 {
12906 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
12907 ffelex_token_where_column (ffeexpr_tokens_[2]));
12908 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
12909 ffebad_finish ();
12910 }
12911
12912 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
12913 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
12914 NULL, NULL, NULL);
12915
12916 ffelex_token_kill (ffeexpr_tokens_[0]);
12917 ffelex_token_kill (ffeexpr_tokens_[1]);
12918 ffelex_token_kill (ffeexpr_tokens_[2]);
12919 ffelex_token_kill (ffeexpr_tokens_[3]);
12920 return (ffelexHandler) ffeexpr_token_binary_ (t);
12921 }
12922
12923 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0], NULL,
12924 ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2],
12925 ffeexpr_tokens_[3], t);
12926
12927 ffelex_token_kill (ffeexpr_tokens_[0]);
12928 ffelex_token_kill (ffeexpr_tokens_[1]);
12929 ffelex_token_kill (ffeexpr_tokens_[2]);
12930 ffelex_token_kill (ffeexpr_tokens_[3]);
12931 return (ffelexHandler) ffeexpr_token_binary_;
12932 }
12933
12934 /* ffeexpr_token_number_ -- Rhs NUMBER
12935
12936 Return a pointer to this function to the lexer (ffelex), which will
12937 invoke it for the next token.
12938
12939 If the token is a period, we may have a floating-point number, or an
12940 integer followed by a dotdot binary operator. If the token is a name
12941 beginning with D, E, or Q, we definitely have a floating-point number.
12942 If the token is a hollerith constant, that's what we've got, so push
12943 it onto the expression stack and continue with the binary state.
12944
12945 Otherwise, we have an integer followed by something the binary state
12946 should be able to swallow. */
12947
12948 static ffelexHandler
12949 ffeexpr_token_number_ (ffelexToken t)
12950 {
12951 ffeexprExpr_ e;
12952 ffeinfo ni;
12953 char d;
12954 const char *p;
12955
12956 if (ffeexpr_hollerith_count_ > 0)
12957 ffelex_set_expecting_hollerith (0, '\0',
12958 ffewhere_line_unknown (),
12959 ffewhere_column_unknown ());
12960
12961 /* See if we've got a floating-point number here. */
12962
12963 switch (ffelex_token_type (t))
12964 {
12965 case FFELEX_typeNAME:
12966 case FFELEX_typeNAMES:
12967 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
12968 'D', 'd')
12969 || ffesrc_char_match_init (d, 'E', 'e')
12970 || ffesrc_char_match_init (d, 'Q', 'q'))
12971 && ffeexpr_isdigits_ (++p))
12972 {
12973
12974 /* Just exponent character by itself? In which case, PLUS or MINUS
12975 must surely be next, followed by a NUMBER token. */
12976
12977 if (*p == '\0')
12978 {
12979 ffeexpr_tokens_[1] = ffelex_token_use (t);
12980 return (ffelexHandler) ffeexpr_token_number_exponent_;
12981 }
12982 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], NULL, NULL, t,
12983 NULL, NULL);
12984
12985 ffelex_token_kill (ffeexpr_tokens_[0]);
12986 return (ffelexHandler) ffeexpr_token_binary_;
12987 }
12988 break;
12989
12990 case FFELEX_typePERIOD:
12991 ffeexpr_tokens_[1] = ffelex_token_use (t);
12992 return (ffelexHandler) ffeexpr_token_number_period_;
12993
12994 case FFELEX_typeHOLLERITH:
12995 e = ffeexpr_expr_new_ ();
12996 e->type = FFEEXPR_exprtypeOPERAND_;
12997 e->token = ffeexpr_tokens_[0];
12998 e->u.operand = ffebld_new_conter (ffebld_constant_new_hollerith (t));
12999 ni = ffeinfo_new (FFEINFO_basictypeHOLLERITH, FFEINFO_kindtypeNONE,
13000 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
13001 ffelex_token_length (t));
13002 ffebld_set_info (e->u.operand, ni);
13003 ffeexpr_exprstack_push_operand_ (e);
13004 return (ffelexHandler) ffeexpr_token_binary_;
13005
13006 default:
13007 break;
13008 }
13009
13010 /* Nothing specific we were looking for, so make an integer and pass the
13011 current token to the binary state. */
13012
13013 ffeexpr_make_float_const_ ('I', ffeexpr_tokens_[0], NULL, NULL,
13014 NULL, NULL, NULL);
13015 return (ffelexHandler) ffeexpr_token_binary_ (t);
13016 }
13017
13018 /* ffeexpr_token_number_exponent_ -- Rhs NUMBER NAME(D, E, or Q)
13019
13020 Return a pointer to this function to the lexer (ffelex), which will
13021 invoke it for the next token.
13022
13023 Ensures this token is PLUS or MINUS, preserves it, goes to final state
13024 for real number (exponent digits). Else treats number as integer, passes
13025 name to binary, passes current token to subsequent handler. */
13026
13027 static ffelexHandler
13028 ffeexpr_token_number_exponent_ (ffelexToken t)
13029 {
13030 if ((ffelex_token_type (t) != FFELEX_typePLUS)
13031 && (ffelex_token_type (t) != FFELEX_typeMINUS))
13032 {
13033 ffeexprExpr_ e;
13034 ffelexHandler nexthandler;
13035
13036 e = ffeexpr_expr_new_ ();
13037 e->type = FFEEXPR_exprtypeOPERAND_;
13038 e->token = ffeexpr_tokens_[0];
13039 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
13040 (ffeexpr_tokens_[0]));
13041 ffebld_set_info (e->u.operand,
13042 ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT,
13043 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13044 ffeexpr_exprstack_push_operand_ (e);
13045 nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[1]);
13046 ffelex_token_kill (ffeexpr_tokens_[1]);
13047 return (ffelexHandler) (*nexthandler) (t);
13048 }
13049
13050 ffeexpr_tokens_[2] = ffelex_token_use (t);
13051 return (ffelexHandler) ffeexpr_token_number_exp_sign_;
13052 }
13053
13054 /* ffeexpr_token_number_exp_sign_ -- Rhs NUMBER NAME(D,E,Q) PLUS/MINUS
13055
13056 Return a pointer to this function to the lexer (ffelex), which will
13057 invoke it for the next token.
13058
13059 Make sure token is a NUMBER, make a real constant out of all we have and
13060 push it onto the expression stack. Else issue diagnostic and pretend
13061 exponent field was a zero. */
13062
13063 static ffelexHandler
13064 ffeexpr_token_number_exp_sign_ (ffelexToken t)
13065 {
13066 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13067 {
13068 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13069 {
13070 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[1]),
13071 ffelex_token_where_column (ffeexpr_tokens_[1]));
13072 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13073 ffebad_finish ();
13074 }
13075
13076 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
13077 ffeexpr_tokens_[0], NULL, NULL,
13078 ffeexpr_tokens_[1], ffeexpr_tokens_[2],
13079 NULL);
13080
13081 ffelex_token_kill (ffeexpr_tokens_[0]);
13082 ffelex_token_kill (ffeexpr_tokens_[1]);
13083 ffelex_token_kill (ffeexpr_tokens_[2]);
13084 return (ffelexHandler) ffeexpr_token_binary_ (t);
13085 }
13086
13087 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
13088 ffeexpr_tokens_[0], NULL, NULL,
13089 ffeexpr_tokens_[1], ffeexpr_tokens_[2], t);
13090
13091 ffelex_token_kill (ffeexpr_tokens_[0]);
13092 ffelex_token_kill (ffeexpr_tokens_[1]);
13093 ffelex_token_kill (ffeexpr_tokens_[2]);
13094 return (ffelexHandler) ffeexpr_token_binary_;
13095 }
13096
13097 /* ffeexpr_token_number_period_ -- Rhs NUMBER PERIOD
13098
13099 Return a pointer to this function to the lexer (ffelex), which will
13100 invoke it for the next token.
13101
13102 Handle a period detected following a number at rhs state. Must begin a
13103 floating-point value (as in 1., 1.2, 1.E3, or 1.E+3) or a dot-dot name. */
13104
13105 static ffelexHandler
13106 ffeexpr_token_number_period_ (ffelexToken t)
13107 {
13108 ffeexprExpr_ e;
13109 ffelexHandler nexthandler;
13110 const char *p;
13111 char d;
13112
13113 switch (ffelex_token_type (t))
13114 {
13115 case FFELEX_typeNAME:
13116 case FFELEX_typeNAMES:
13117 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13118 'D', 'd')
13119 || ffesrc_char_match_init (d, 'E', 'e')
13120 || ffesrc_char_match_init (d, 'Q', 'q'))
13121 && ffeexpr_isdigits_ (++p))
13122 {
13123
13124 /* Just exponent character by itself? In which case, PLUS or MINUS
13125 must surely be next, followed by a NUMBER token. */
13126
13127 if (*p == '\0')
13128 {
13129 ffeexpr_tokens_[2] = ffelex_token_use (t);
13130 return (ffelexHandler) ffeexpr_token_number_per_exp_;
13131 }
13132 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0],
13133 ffeexpr_tokens_[1], NULL, t, NULL,
13134 NULL);
13135
13136 ffelex_token_kill (ffeexpr_tokens_[0]);
13137 ffelex_token_kill (ffeexpr_tokens_[1]);
13138 return (ffelexHandler) ffeexpr_token_binary_;
13139 }
13140 /* A name not representing an exponent, so assume it will be something
13141 like EQ, make an integer from the number, pass the period to binary
13142 state and the current token to the resulting state. */
13143
13144 e = ffeexpr_expr_new_ ();
13145 e->type = FFEEXPR_exprtypeOPERAND_;
13146 e->token = ffeexpr_tokens_[0];
13147 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
13148 (ffeexpr_tokens_[0]));
13149 ffebld_set_info (e->u.operand,
13150 ffeinfo_new (FFEINFO_basictypeINTEGER,
13151 FFEINFO_kindtypeINTEGERDEFAULT, 0,
13152 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
13153 FFETARGET_charactersizeNONE));
13154 ffeexpr_exprstack_push_operand_ (e);
13155 nexthandler = (ffelexHandler) ffeexpr_token_binary_
13156 (ffeexpr_tokens_[1]);
13157 ffelex_token_kill (ffeexpr_tokens_[1]);
13158 return (ffelexHandler) (*nexthandler) (t);
13159
13160 case FFELEX_typeNUMBER:
13161 ffeexpr_tokens_[2] = ffelex_token_use (t);
13162 return (ffelexHandler) ffeexpr_token_number_real_;
13163
13164 default:
13165 break;
13166 }
13167
13168 /* Nothing specific we were looking for, so make a real number and pass the
13169 period and then the current token to the binary state. */
13170
13171 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13172 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13173 NULL, NULL, NULL, NULL);
13174
13175 ffelex_token_kill (ffeexpr_tokens_[0]);
13176 ffelex_token_kill (ffeexpr_tokens_[1]);
13177 return (ffelexHandler) ffeexpr_token_binary_ (t);
13178 }
13179
13180 /* ffeexpr_token_number_per_exp_ -- Rhs NUMBER PERIOD NAME(D, E, or Q)
13181
13182 Return a pointer to this function to the lexer (ffelex), which will
13183 invoke it for the next token.
13184
13185 Ensures this token is PLUS or MINUS, preserves it, goes to final state
13186 for real number (exponent digits). Else treats number as real, passes
13187 name to binary, passes current token to subsequent handler. */
13188
13189 static ffelexHandler
13190 ffeexpr_token_number_per_exp_ (ffelexToken t)
13191 {
13192 if ((ffelex_token_type (t) != FFELEX_typePLUS)
13193 && (ffelex_token_type (t) != FFELEX_typeMINUS))
13194 {
13195 ffelexHandler nexthandler;
13196
13197 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13198 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13199 NULL, NULL, NULL, NULL);
13200
13201 ffelex_token_kill (ffeexpr_tokens_[0]);
13202 ffelex_token_kill (ffeexpr_tokens_[1]);
13203 nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[2]);
13204 ffelex_token_kill (ffeexpr_tokens_[2]);
13205 return (ffelexHandler) (*nexthandler) (t);
13206 }
13207
13208 ffeexpr_tokens_[3] = ffelex_token_use (t);
13209 return (ffelexHandler) ffeexpr_token_num_per_exp_sign_;
13210 }
13211
13212 /* ffeexpr_token_number_real_ -- Rhs NUMBER PERIOD NUMBER
13213
13214 Return a pointer to this function to the lexer (ffelex), which will
13215 invoke it for the next token.
13216
13217 After a number, period, and number, check next token for possible
13218 exponent designation (D, E, or Q as first/only character) and continue
13219 real-number handling accordingly. Else form basic real constant, push
13220 onto expression stack, and enter binary state using current token (which,
13221 if it is a name not beginning with D, E, or Q, will certainly result
13222 in an error, but that's not for this routine to deal with). */
13223
13224 static ffelexHandler
13225 ffeexpr_token_number_real_ (ffelexToken t)
13226 {
13227 char d;
13228 const char *p;
13229
13230 if (((ffelex_token_type (t) != FFELEX_typeNAME)
13231 && (ffelex_token_type (t) != FFELEX_typeNAMES))
13232 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13233 'D', 'd')
13234 || ffesrc_char_match_init (d, 'E', 'e')
13235 || ffesrc_char_match_init (d, 'Q', 'q')))
13236 && ffeexpr_isdigits_ (++p)))
13237 {
13238 #if 0
13239 /* This code has been removed because it seems inconsistent to
13240 produce a diagnostic in this case, but not all of the other
13241 ones that look for an exponent and cannot recognize one. */
13242 if (((ffelex_token_type (t) == FFELEX_typeNAME)
13243 || (ffelex_token_type (t) == FFELEX_typeNAMES))
13244 && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
13245 {
13246 char bad[2];
13247
13248 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13249 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
13250 ffelex_token_where_column (ffeexpr_tokens_[0]));
13251 bad[0] = *(p - 1);
13252 bad[1] = '\0';
13253 ffebad_string (bad);
13254 ffebad_finish ();
13255 }
13256 #endif
13257 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13258 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13259 ffeexpr_tokens_[2], NULL, NULL, NULL);
13260
13261 ffelex_token_kill (ffeexpr_tokens_[0]);
13262 ffelex_token_kill (ffeexpr_tokens_[1]);
13263 ffelex_token_kill (ffeexpr_tokens_[2]);
13264 return (ffelexHandler) ffeexpr_token_binary_ (t);
13265 }
13266
13267 /* Just exponent character by itself? In which case, PLUS or MINUS must
13268 surely be next, followed by a NUMBER token. */
13269
13270 if (*p == '\0')
13271 {
13272 ffeexpr_tokens_[3] = ffelex_token_use (t);
13273 return (ffelexHandler) ffeexpr_token_number_real_exp_;
13274 }
13275
13276 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13277 ffeexpr_tokens_[2], t, NULL, NULL);
13278
13279 ffelex_token_kill (ffeexpr_tokens_[0]);
13280 ffelex_token_kill (ffeexpr_tokens_[1]);
13281 ffelex_token_kill (ffeexpr_tokens_[2]);
13282 return (ffelexHandler) ffeexpr_token_binary_;
13283 }
13284
13285 /* ffeexpr_token_num_per_exp_sign_ -- Rhs NUMBER PERIOD NAME(D,E,Q) PLUS/MINUS
13286
13287 Return a pointer to this function to the lexer (ffelex), which will
13288 invoke it for the next token.
13289
13290 Make sure token is a NUMBER, make a real constant out of all we have and
13291 push it onto the expression stack. Else issue diagnostic and pretend
13292 exponent field was a zero. */
13293
13294 static ffelexHandler
13295 ffeexpr_token_num_per_exp_sign_ (ffelexToken t)
13296 {
13297 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13298 {
13299 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13300 {
13301 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
13302 ffelex_token_where_column (ffeexpr_tokens_[2]));
13303 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13304 ffebad_finish ();
13305 }
13306
13307 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13308 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13309 NULL, NULL, NULL, NULL);
13310
13311 ffelex_token_kill (ffeexpr_tokens_[0]);
13312 ffelex_token_kill (ffeexpr_tokens_[1]);
13313 ffelex_token_kill (ffeexpr_tokens_[2]);
13314 ffelex_token_kill (ffeexpr_tokens_[3]);
13315 return (ffelexHandler) ffeexpr_token_binary_ (t);
13316 }
13317
13318 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0],
13319 ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL,
13320 ffeexpr_tokens_[2], ffeexpr_tokens_[3], t);
13321
13322 ffelex_token_kill (ffeexpr_tokens_[0]);
13323 ffelex_token_kill (ffeexpr_tokens_[1]);
13324 ffelex_token_kill (ffeexpr_tokens_[2]);
13325 ffelex_token_kill (ffeexpr_tokens_[3]);
13326 return (ffelexHandler) ffeexpr_token_binary_;
13327 }
13328
13329 /* ffeexpr_token_number_real_exp_ -- Rhs NUMBER PERIOD NUMBER NAME(D, E, or Q)
13330
13331 Return a pointer to this function to the lexer (ffelex), which will
13332 invoke it for the next token.
13333
13334 Ensures this token is PLUS or MINUS, preserves it, goes to final state
13335 for real number (exponent digits). Else issues diagnostic, assumes a
13336 zero exponent field for number, passes token on to binary state as if
13337 previous token had been "E0" instead of "E", for example. */
13338
13339 static ffelexHandler
13340 ffeexpr_token_number_real_exp_ (ffelexToken t)
13341 {
13342 if ((ffelex_token_type (t) != FFELEX_typePLUS)
13343 && (ffelex_token_type (t) != FFELEX_typeMINUS))
13344 {
13345 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13346 {
13347 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
13348 ffelex_token_where_column (ffeexpr_tokens_[3]));
13349 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13350 ffebad_finish ();
13351 }
13352
13353 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13354 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13355 ffeexpr_tokens_[2], NULL, NULL, NULL);
13356
13357 ffelex_token_kill (ffeexpr_tokens_[0]);
13358 ffelex_token_kill (ffeexpr_tokens_[1]);
13359 ffelex_token_kill (ffeexpr_tokens_[2]);
13360 ffelex_token_kill (ffeexpr_tokens_[3]);
13361 return (ffelexHandler) ffeexpr_token_binary_ (t);
13362 }
13363
13364 ffeexpr_tokens_[4] = ffelex_token_use (t);
13365 return (ffelexHandler) ffeexpr_token_num_real_exp_sn_;
13366 }
13367
13368 /* ffeexpr_token_num_real_exp_sn_ -- Rhs NUMBER PERIOD NUMBER NAME(D,E,Q)
13369 PLUS/MINUS
13370
13371 Return a pointer to this function to the lexer (ffelex), which will
13372 invoke it for the next token.
13373
13374 Make sure token is a NUMBER, make a real constant out of all we have and
13375 push it onto the expression stack. Else issue diagnostic and pretend
13376 exponent field was a zero. */
13377
13378 static ffelexHandler
13379 ffeexpr_token_num_real_exp_sn_ (ffelexToken t)
13380 {
13381 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13382 {
13383 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13384 {
13385 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
13386 ffelex_token_where_column (ffeexpr_tokens_[3]));
13387 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13388 ffebad_finish ();
13389 }
13390
13391 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13392 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13393 ffeexpr_tokens_[2], NULL, NULL, NULL);
13394
13395 ffelex_token_kill (ffeexpr_tokens_[0]);
13396 ffelex_token_kill (ffeexpr_tokens_[1]);
13397 ffelex_token_kill (ffeexpr_tokens_[2]);
13398 ffelex_token_kill (ffeexpr_tokens_[3]);
13399 ffelex_token_kill (ffeexpr_tokens_[4]);
13400 return (ffelexHandler) ffeexpr_token_binary_ (t);
13401 }
13402
13403 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[3])[0],
13404 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13405 ffeexpr_tokens_[2], ffeexpr_tokens_[3],
13406 ffeexpr_tokens_[4], t);
13407
13408 ffelex_token_kill (ffeexpr_tokens_[0]);
13409 ffelex_token_kill (ffeexpr_tokens_[1]);
13410 ffelex_token_kill (ffeexpr_tokens_[2]);
13411 ffelex_token_kill (ffeexpr_tokens_[3]);
13412 ffelex_token_kill (ffeexpr_tokens_[4]);
13413 return (ffelexHandler) ffeexpr_token_binary_;
13414 }
13415
13416 /* ffeexpr_token_binary_ -- Handle binary operator possibility
13417
13418 Return a pointer to this function to the lexer (ffelex), which will
13419 invoke it for the next token.
13420
13421 The possibility of a binary operator is handled here, meaning the previous
13422 token was an operand. */
13423
13424 static ffelexHandler
13425 ffeexpr_token_binary_ (ffelexToken t)
13426 {
13427 ffeexprExpr_ e;
13428
13429 if (!ffeexpr_stack_->is_rhs)
13430 return (ffelexHandler) ffeexpr_finished_ (t); /* For now. */
13431
13432 switch (ffelex_token_type (t))
13433 {
13434 case FFELEX_typePLUS:
13435 e = ffeexpr_expr_new_ ();
13436 e->type = FFEEXPR_exprtypeBINARY_;
13437 e->token = ffelex_token_use (t);
13438 e->u.operator.op = FFEEXPR_operatorADD_;
13439 e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
13440 e->u.operator.as = FFEEXPR_operatorassociativityADD_;
13441 ffeexpr_exprstack_push_binary_ (e);
13442 return (ffelexHandler) ffeexpr_token_rhs_;
13443
13444 case FFELEX_typeMINUS:
13445 e = ffeexpr_expr_new_ ();
13446 e->type = FFEEXPR_exprtypeBINARY_;
13447 e->token = ffelex_token_use (t);
13448 e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
13449 e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
13450 e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
13451 ffeexpr_exprstack_push_binary_ (e);
13452 return (ffelexHandler) ffeexpr_token_rhs_;
13453
13454 case FFELEX_typeASTERISK:
13455 switch (ffeexpr_stack_->context)
13456 {
13457 case FFEEXPR_contextDATA:
13458 return (ffelexHandler) ffeexpr_finished_ (t);
13459
13460 default:
13461 break;
13462 }
13463 e = ffeexpr_expr_new_ ();
13464 e->type = FFEEXPR_exprtypeBINARY_;
13465 e->token = ffelex_token_use (t);
13466 e->u.operator.op = FFEEXPR_operatorMULTIPLY_;
13467 e->u.operator.prec = FFEEXPR_operatorprecedenceMULTIPLY_;
13468 e->u.operator.as = FFEEXPR_operatorassociativityMULTIPLY_;
13469 ffeexpr_exprstack_push_binary_ (e);
13470 return (ffelexHandler) ffeexpr_token_rhs_;
13471
13472 case FFELEX_typeSLASH:
13473 switch (ffeexpr_stack_->context)
13474 {
13475 case FFEEXPR_contextDATA:
13476 return (ffelexHandler) ffeexpr_finished_ (t);
13477
13478 default:
13479 break;
13480 }
13481 e = ffeexpr_expr_new_ ();
13482 e->type = FFEEXPR_exprtypeBINARY_;
13483 e->token = ffelex_token_use (t);
13484 e->u.operator.op = FFEEXPR_operatorDIVIDE_;
13485 e->u.operator.prec = FFEEXPR_operatorprecedenceDIVIDE_;
13486 e->u.operator.as = FFEEXPR_operatorassociativityDIVIDE_;
13487 ffeexpr_exprstack_push_binary_ (e);
13488 return (ffelexHandler) ffeexpr_token_rhs_;
13489
13490 case FFELEX_typePOWER:
13491 e = ffeexpr_expr_new_ ();
13492 e->type = FFEEXPR_exprtypeBINARY_;
13493 e->token = ffelex_token_use (t);
13494 e->u.operator.op = FFEEXPR_operatorPOWER_;
13495 e->u.operator.prec = FFEEXPR_operatorprecedencePOWER_;
13496 e->u.operator.as = FFEEXPR_operatorassociativityPOWER_;
13497 ffeexpr_exprstack_push_binary_ (e);
13498 return (ffelexHandler) ffeexpr_token_rhs_;
13499
13500 case FFELEX_typeCONCAT:
13501 e = ffeexpr_expr_new_ ();
13502 e->type = FFEEXPR_exprtypeBINARY_;
13503 e->token = ffelex_token_use (t);
13504 e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
13505 e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
13506 e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
13507 ffeexpr_exprstack_push_binary_ (e);
13508 return (ffelexHandler) ffeexpr_token_rhs_;
13509
13510 case FFELEX_typeOPEN_ANGLE:
13511 switch (ffeexpr_stack_->context)
13512 {
13513 case FFEEXPR_contextFORMAT:
13514 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13515 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13516 ffebad_finish ();
13517 break;
13518
13519 default:
13520 break;
13521 }
13522 e = ffeexpr_expr_new_ ();
13523 e->type = FFEEXPR_exprtypeBINARY_;
13524 e->token = ffelex_token_use (t);
13525 e->u.operator.op = FFEEXPR_operatorLT_;
13526 e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
13527 e->u.operator.as = FFEEXPR_operatorassociativityLT_;
13528 ffeexpr_exprstack_push_binary_ (e);
13529 return (ffelexHandler) ffeexpr_token_rhs_;
13530
13531 case FFELEX_typeCLOSE_ANGLE:
13532 switch (ffeexpr_stack_->context)
13533 {
13534 case FFEEXPR_contextFORMAT:
13535 return ffeexpr_finished_ (t);
13536
13537 default:
13538 break;
13539 }
13540 e = ffeexpr_expr_new_ ();
13541 e->type = FFEEXPR_exprtypeBINARY_;
13542 e->token = ffelex_token_use (t);
13543 e->u.operator.op = FFEEXPR_operatorGT_;
13544 e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
13545 e->u.operator.as = FFEEXPR_operatorassociativityGT_;
13546 ffeexpr_exprstack_push_binary_ (e);
13547 return (ffelexHandler) ffeexpr_token_rhs_;
13548
13549 case FFELEX_typeREL_EQ:
13550 switch (ffeexpr_stack_->context)
13551 {
13552 case FFEEXPR_contextFORMAT:
13553 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13554 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13555 ffebad_finish ();
13556 break;
13557
13558 default:
13559 break;
13560 }
13561 e = ffeexpr_expr_new_ ();
13562 e->type = FFEEXPR_exprtypeBINARY_;
13563 e->token = ffelex_token_use (t);
13564 e->u.operator.op = FFEEXPR_operatorEQ_;
13565 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
13566 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
13567 ffeexpr_exprstack_push_binary_ (e);
13568 return (ffelexHandler) ffeexpr_token_rhs_;
13569
13570 case FFELEX_typeREL_NE:
13571 switch (ffeexpr_stack_->context)
13572 {
13573 case FFEEXPR_contextFORMAT:
13574 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13575 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13576 ffebad_finish ();
13577 break;
13578
13579 default:
13580 break;
13581 }
13582 e = ffeexpr_expr_new_ ();
13583 e->type = FFEEXPR_exprtypeBINARY_;
13584 e->token = ffelex_token_use (t);
13585 e->u.operator.op = FFEEXPR_operatorNE_;
13586 e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
13587 e->u.operator.as = FFEEXPR_operatorassociativityNE_;
13588 ffeexpr_exprstack_push_binary_ (e);
13589 return (ffelexHandler) ffeexpr_token_rhs_;
13590
13591 case FFELEX_typeREL_LE:
13592 switch (ffeexpr_stack_->context)
13593 {
13594 case FFEEXPR_contextFORMAT:
13595 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13596 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13597 ffebad_finish ();
13598 break;
13599
13600 default:
13601 break;
13602 }
13603 e = ffeexpr_expr_new_ ();
13604 e->type = FFEEXPR_exprtypeBINARY_;
13605 e->token = ffelex_token_use (t);
13606 e->u.operator.op = FFEEXPR_operatorLE_;
13607 e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
13608 e->u.operator.as = FFEEXPR_operatorassociativityLE_;
13609 ffeexpr_exprstack_push_binary_ (e);
13610 return (ffelexHandler) ffeexpr_token_rhs_;
13611
13612 case FFELEX_typeREL_GE:
13613 switch (ffeexpr_stack_->context)
13614 {
13615 case FFEEXPR_contextFORMAT:
13616 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13617 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13618 ffebad_finish ();
13619 break;
13620
13621 default:
13622 break;
13623 }
13624 e = ffeexpr_expr_new_ ();
13625 e->type = FFEEXPR_exprtypeBINARY_;
13626 e->token = ffelex_token_use (t);
13627 e->u.operator.op = FFEEXPR_operatorGE_;
13628 e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
13629 e->u.operator.as = FFEEXPR_operatorassociativityGE_;
13630 ffeexpr_exprstack_push_binary_ (e);
13631 return (ffelexHandler) ffeexpr_token_rhs_;
13632
13633 case FFELEX_typePERIOD:
13634 ffeexpr_tokens_[0] = ffelex_token_use (t);
13635 return (ffelexHandler) ffeexpr_token_binary_period_;
13636
13637 #if 0
13638 case FFELEX_typeOPEN_PAREN:
13639 case FFELEX_typeCLOSE_PAREN:
13640 case FFELEX_typeEQUALS:
13641 case FFELEX_typePOINTS:
13642 case FFELEX_typeCOMMA:
13643 case FFELEX_typeCOLON:
13644 case FFELEX_typeEOS:
13645 case FFELEX_typeSEMICOLON:
13646 case FFELEX_typeNAME:
13647 case FFELEX_typeNAMES:
13648 #endif
13649 default:
13650 return (ffelexHandler) ffeexpr_finished_ (t);
13651 }
13652 }
13653
13654 /* ffeexpr_token_binary_period_ -- Binary PERIOD
13655
13656 Return a pointer to this function to the lexer (ffelex), which will
13657 invoke it for the next token.
13658
13659 Handle a period detected at binary (expecting binary op or end) state.
13660 Must begin a dot-dot name, of which .NOT., .TRUE., and .FALSE. are not
13661 valid. */
13662
13663 static ffelexHandler
13664 ffeexpr_token_binary_period_ (ffelexToken t)
13665 {
13666 ffeexprExpr_ operand;
13667
13668 switch (ffelex_token_type (t))
13669 {
13670 case FFELEX_typeNAME:
13671 case FFELEX_typeNAMES:
13672 ffeexpr_current_dotdot_ = ffestr_other (t);
13673 switch (ffeexpr_current_dotdot_)
13674 {
13675 case FFESTR_otherTRUE:
13676 case FFESTR_otherFALSE:
13677 case FFESTR_otherNOT:
13678 if (ffest_ffebad_start (FFEBAD_MISSING_BINARY_OPERATOR))
13679 {
13680 operand = ffeexpr_stack_->exprstack;
13681 assert (operand != NULL);
13682 assert (operand->type == FFEEXPR_exprtypeOPERAND_);
13683 ffebad_here (0, ffelex_token_where_line (operand->token), ffelex_token_where_column (operand->token));
13684 ffebad_here (1, ffelex_token_where_line (t),
13685 ffelex_token_where_column (t));
13686 ffebad_finish ();
13687 }
13688 ffelex_token_kill (ffeexpr_tokens_[0]);
13689 return (ffelexHandler) ffeexpr_token_binary_sw_per_;
13690
13691 default:
13692 ffeexpr_tokens_[1] = ffelex_token_use (t);
13693 return (ffelexHandler) ffeexpr_token_binary_end_per_;
13694 }
13695 break; /* Nothing really reaches here. */
13696
13697 default:
13698 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
13699 {
13700 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13701 ffelex_token_where_column (ffeexpr_tokens_[0]));
13702 ffebad_finish ();
13703 }
13704 ffelex_token_kill (ffeexpr_tokens_[0]);
13705 return (ffelexHandler) ffeexpr_token_binary_ (t);
13706 }
13707 }
13708
13709 /* ffeexpr_token_binary_end_per_ -- Binary PERIOD NAME(not NOT, TRUE, or FALSE)
13710
13711 Return a pointer to this function to the lexer (ffelex), which will
13712 invoke it for the next token.
13713
13714 Expecting a period to close a dot-dot at binary (binary op
13715 or operator) state. If period isn't found, issue a diagnostic but
13716 pretend we saw one. ffeexpr_current_dotdot_ must already contained the
13717 dotdot representation of the name in between the two PERIOD tokens. */
13718
13719 static ffelexHandler
13720 ffeexpr_token_binary_end_per_ (ffelexToken t)
13721 {
13722 ffeexprExpr_ e;
13723
13724 e = ffeexpr_expr_new_ ();
13725 e->type = FFEEXPR_exprtypeBINARY_;
13726 e->token = ffeexpr_tokens_[0];
13727
13728 switch (ffeexpr_current_dotdot_)
13729 {
13730 case FFESTR_otherAND:
13731 e->u.operator.op = FFEEXPR_operatorAND_;
13732 e->u.operator.prec = FFEEXPR_operatorprecedenceAND_;
13733 e->u.operator.as = FFEEXPR_operatorassociativityAND_;
13734 break;
13735
13736 case FFESTR_otherOR:
13737 e->u.operator.op = FFEEXPR_operatorOR_;
13738 e->u.operator.prec = FFEEXPR_operatorprecedenceOR_;
13739 e->u.operator.as = FFEEXPR_operatorassociativityOR_;
13740 break;
13741
13742 case FFESTR_otherXOR:
13743 e->u.operator.op = FFEEXPR_operatorXOR_;
13744 e->u.operator.prec = FFEEXPR_operatorprecedenceXOR_;
13745 e->u.operator.as = FFEEXPR_operatorassociativityXOR_;
13746 break;
13747
13748 case FFESTR_otherEQV:
13749 e->u.operator.op = FFEEXPR_operatorEQV_;
13750 e->u.operator.prec = FFEEXPR_operatorprecedenceEQV_;
13751 e->u.operator.as = FFEEXPR_operatorassociativityEQV_;
13752 break;
13753
13754 case FFESTR_otherNEQV:
13755 e->u.operator.op = FFEEXPR_operatorNEQV_;
13756 e->u.operator.prec = FFEEXPR_operatorprecedenceNEQV_;
13757 e->u.operator.as = FFEEXPR_operatorassociativityNEQV_;
13758 break;
13759
13760 case FFESTR_otherLT:
13761 e->u.operator.op = FFEEXPR_operatorLT_;
13762 e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
13763 e->u.operator.as = FFEEXPR_operatorassociativityLT_;
13764 break;
13765
13766 case FFESTR_otherLE:
13767 e->u.operator.op = FFEEXPR_operatorLE_;
13768 e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
13769 e->u.operator.as = FFEEXPR_operatorassociativityLE_;
13770 break;
13771
13772 case FFESTR_otherEQ:
13773 e->u.operator.op = FFEEXPR_operatorEQ_;
13774 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
13775 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
13776 break;
13777
13778 case FFESTR_otherNE:
13779 e->u.operator.op = FFEEXPR_operatorNE_;
13780 e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
13781 e->u.operator.as = FFEEXPR_operatorassociativityNE_;
13782 break;
13783
13784 case FFESTR_otherGT:
13785 e->u.operator.op = FFEEXPR_operatorGT_;
13786 e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
13787 e->u.operator.as = FFEEXPR_operatorassociativityGT_;
13788 break;
13789
13790 case FFESTR_otherGE:
13791 e->u.operator.op = FFEEXPR_operatorGE_;
13792 e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
13793 e->u.operator.as = FFEEXPR_operatorassociativityGE_;
13794 break;
13795
13796 default:
13797 if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT))
13798 {
13799 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13800 ffelex_token_where_column (ffeexpr_tokens_[0]));
13801 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
13802 ffebad_finish ();
13803 }
13804 e->u.operator.op = FFEEXPR_operatorEQ_;
13805 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
13806 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
13807 break;
13808 }
13809
13810 ffeexpr_exprstack_push_binary_ (e);
13811
13812 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13813 {
13814 if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
13815 {
13816 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13817 ffelex_token_where_column (ffeexpr_tokens_[0]));
13818 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13819 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
13820 ffebad_finish ();
13821 }
13822 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */
13823 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13824 }
13825
13826 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */
13827 return (ffelexHandler) ffeexpr_token_rhs_;
13828 }
13829
13830 /* ffeexpr_token_binary_sw_per_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
13831
13832 Return a pointer to this function to the lexer (ffelex), which will
13833 invoke it for the next token.
13834
13835 A diagnostic has already been issued; just swallow a period if there is
13836 one, then continue with ffeexpr_token_binary_. */
13837
13838 static ffelexHandler
13839 ffeexpr_token_binary_sw_per_ (ffelexToken t)
13840 {
13841 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13842 return (ffelexHandler) ffeexpr_token_binary_ (t);
13843
13844 return (ffelexHandler) ffeexpr_token_binary_;
13845 }
13846
13847 /* ffeexpr_token_quote_ -- Rhs QUOTE
13848
13849 Return a pointer to this function to the lexer (ffelex), which will
13850 invoke it for the next token.
13851
13852 Expecting a NUMBER that we'll treat as an octal integer. */
13853
13854 static ffelexHandler
13855 ffeexpr_token_quote_ (ffelexToken t)
13856 {
13857 ffeexprExpr_ e;
13858 ffebld anyexpr;
13859
13860 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13861 {
13862 if (ffest_ffebad_start (FFEBAD_QUOTE_MISSES_DIGITS))
13863 {
13864 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13865 ffelex_token_where_column (ffeexpr_tokens_[0]));
13866 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13867 ffebad_finish ();
13868 }
13869 ffelex_token_kill (ffeexpr_tokens_[0]);
13870 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13871 }
13872
13873 /* This is kind of a kludge to prevent any whining about magical numbers
13874 that start out as these octal integers, so "20000000000 (on a 32-bit
13875 2's-complement machine) by itself won't produce an error. */
13876
13877 anyexpr = ffebld_new_any ();
13878 ffebld_set_info (anyexpr, ffeinfo_new_any ());
13879
13880 e = ffeexpr_expr_new_ ();
13881 e->type = FFEEXPR_exprtypeOPERAND_;
13882 e->token = ffeexpr_tokens_[0];
13883 e->u.operand = ffebld_new_conter_with_orig
13884 (ffebld_constant_new_integeroctal (t), anyexpr);
13885 ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER,
13886 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY,
13887 FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13888 ffeexpr_exprstack_push_operand_ (e);
13889 return (ffelexHandler) ffeexpr_token_binary_;
13890 }
13891
13892 /* ffeexpr_token_apostrophe_ -- Rhs APOSTROPHE
13893
13894 Return a pointer to this function to the lexer (ffelex), which will
13895 invoke it for the next token.
13896
13897 Handle an open-apostrophe, which begins either a character ('char-const'),
13898 typeless octal ('octal-const'O), or typeless hexadecimal ('hex-const'Z or
13899 'hex-const'X) constant. */
13900
13901 static ffelexHandler
13902 ffeexpr_token_apostrophe_ (ffelexToken t)
13903 {
13904 assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
13905 if (ffe_is_pedantic_not_90 () && (ffelex_token_length (t) == 0))
13906 {
13907 ffebad_start (FFEBAD_NULL_CHAR_CONST);
13908 ffebad_here (0, ffelex_token_where_line (t),
13909 ffelex_token_where_column (t));
13910 ffebad_finish ();
13911 }
13912 ffeexpr_tokens_[1] = ffelex_token_use (t);
13913 return (ffelexHandler) ffeexpr_token_apos_char_;
13914 }
13915
13916 /* ffeexpr_token_apos_char_ -- Rhs APOSTROPHE CHARACTER
13917
13918 Return a pointer to this function to the lexer (ffelex), which will
13919 invoke it for the next token.
13920
13921 Close-apostrophe is implicit; if this token is NAME, it is a possible
13922 typeless-constant radix specifier. */
13923
13924 static ffelexHandler
13925 ffeexpr_token_apos_char_ (ffelexToken t)
13926 {
13927 ffeexprExpr_ e;
13928 ffeinfo ni;
13929 char c;
13930 ffetargetCharacterSize size;
13931
13932 if ((ffelex_token_type (t) == FFELEX_typeNAME)
13933 || (ffelex_token_type (t) == FFELEX_typeNAMES))
13934 {
13935 if ((ffelex_token_length (t) == 1)
13936 && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]), 'B',
13937 'b')
13938 || ffesrc_char_match_init (c, 'O', 'o')
13939 || ffesrc_char_match_init (c, 'X', 'x')
13940 || ffesrc_char_match_init (c, 'Z', 'z')))
13941 {
13942 e = ffeexpr_expr_new_ ();
13943 e->type = FFEEXPR_exprtypeOPERAND_;
13944 e->token = ffeexpr_tokens_[0];
13945 switch (c)
13946 {
13947 case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
13948 e->u.operand = ffebld_new_conter
13949 (ffebld_constant_new_typeless_bv (ffeexpr_tokens_[1]));
13950 size = ffetarget_size_typeless_binary (ffeexpr_tokens_[1]);
13951 break;
13952
13953 case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
13954 e->u.operand = ffebld_new_conter
13955 (ffebld_constant_new_typeless_ov (ffeexpr_tokens_[1]));
13956 size = ffetarget_size_typeless_octal (ffeexpr_tokens_[1]);
13957 break;
13958
13959 case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
13960 e->u.operand = ffebld_new_conter
13961 (ffebld_constant_new_typeless_hxv (ffeexpr_tokens_[1]));
13962 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
13963 break;
13964
13965 case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
13966 e->u.operand = ffebld_new_conter
13967 (ffebld_constant_new_typeless_hzv (ffeexpr_tokens_[1]));
13968 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
13969 break;
13970
13971 default:
13972 no_match: /* :::::::::::::::::::: */
13973 assert ("not BOXZ!" == NULL);
13974 size = 0;
13975 break;
13976 }
13977 ffebld_set_info (e->u.operand,
13978 ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
13979 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
13980 ffeexpr_exprstack_push_operand_ (e);
13981 ffelex_token_kill (ffeexpr_tokens_[1]);
13982 return (ffelexHandler) ffeexpr_token_binary_;
13983 }
13984 }
13985 e = ffeexpr_expr_new_ ();
13986 e->type = FFEEXPR_exprtypeOPERAND_;
13987 e->token = ffeexpr_tokens_[0];
13988 e->u.operand = ffebld_new_conter (ffebld_constant_new_characterdefault
13989 (ffeexpr_tokens_[1]));
13990 ni = ffeinfo_new (FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTERDEFAULT,
13991 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
13992 ffelex_token_length (ffeexpr_tokens_[1]));
13993 ffebld_set_info (e->u.operand, ni);
13994 ffelex_token_kill (ffeexpr_tokens_[1]);
13995 ffeexpr_exprstack_push_operand_ (e);
13996 if ((ffelex_token_type (t) == FFELEX_typeNAME)
13997 || (ffelex_token_type (t) == FFELEX_typeNAMES))
13998 {
13999 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14000 {
14001 ffebad_string (ffelex_token_text (t));
14002 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14003 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
14004 ffelex_token_where_column (ffeexpr_tokens_[0]));
14005 ffebad_finish ();
14006 }
14007 e = ffeexpr_expr_new_ ();
14008 e->type = FFEEXPR_exprtypeBINARY_;
14009 e->token = ffelex_token_use (t);
14010 e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
14011 e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
14012 e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
14013 ffeexpr_exprstack_push_binary_ (e);
14014 return (ffelexHandler) ffeexpr_token_rhs_ (t);
14015 }
14016 ffeexpr_is_substr_ok_ = !ffe_is_pedantic_not_90 (); /* Allow "'hello'(3:5)". */
14017 return (ffelexHandler) ffeexpr_token_substrp_ (t);
14018 }
14019
14020 /* ffeexpr_token_name_lhs_ -- Lhs NAME
14021
14022 Return a pointer to this function to the lexer (ffelex), which will
14023 invoke it for the next token.
14024
14025 Handle a name followed by open-paren, period (RECORD.MEMBER), percent
14026 (RECORD%MEMBER), or nothing at all. */
14027
14028 static ffelexHandler
14029 ffeexpr_token_name_lhs_ (ffelexToken t)
14030 {
14031 ffeexprExpr_ e;
14032 ffeexprParenType_ paren_type;
14033 ffesymbol s;
14034 ffebld expr;
14035 ffeinfo info;
14036
14037 switch (ffelex_token_type (t))
14038 {
14039 case FFELEX_typeOPEN_PAREN:
14040 switch (ffeexpr_stack_->context)
14041 {
14042 case FFEEXPR_contextASSIGN:
14043 case FFEEXPR_contextAGOTO:
14044 case FFEEXPR_contextFILEUNIT_DF:
14045 goto just_name; /* :::::::::::::::::::: */
14046
14047 default:
14048 break;
14049 }
14050 e = ffeexpr_expr_new_ ();
14051 e->type = FFEEXPR_exprtypeOPERAND_;
14052 e->token = ffelex_token_use (ffeexpr_tokens_[0]);
14053 s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], FALSE,
14054 &paren_type);
14055
14056 switch (ffesymbol_where (s))
14057 {
14058 case FFEINFO_whereLOCAL:
14059 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14060 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recursion. */
14061 break;
14062
14063 case FFEINFO_whereINTRINSIC:
14064 case FFEINFO_whereGLOBAL:
14065 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
14066 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */
14067 break;
14068
14069 case FFEINFO_whereCOMMON:
14070 case FFEINFO_whereDUMMY:
14071 case FFEINFO_whereRESULT:
14072 break;
14073
14074 case FFEINFO_whereNONE:
14075 case FFEINFO_whereANY:
14076 break;
14077
14078 default:
14079 ffesymbol_error (s, ffeexpr_tokens_[0]);
14080 break;
14081 }
14082
14083 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14084 {
14085 e->u.operand = ffebld_new_any ();
14086 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14087 }
14088 else
14089 {
14090 e->u.operand = ffebld_new_symter (s,
14091 ffesymbol_generic (s),
14092 ffesymbol_specific (s),
14093 ffesymbol_implementation (s));
14094 ffebld_set_info (e->u.operand, ffesymbol_info (s));
14095 }
14096 ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */
14097 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
14098 switch (paren_type)
14099 {
14100 case FFEEXPR_parentypeSUBROUTINE_:
14101 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14102 return
14103 (ffelexHandler)
14104 ffeexpr_rhs (ffeexpr_stack_->pool,
14105 FFEEXPR_contextACTUALARG_,
14106 ffeexpr_token_arguments_);
14107
14108 case FFEEXPR_parentypeARRAY_:
14109 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14110 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
14111 ffeexpr_stack_->rank = 0;
14112 ffeexpr_stack_->constant = TRUE;
14113 ffeexpr_stack_->immediate = TRUE;
14114 switch (ffeexpr_stack_->context)
14115 {
14116 case FFEEXPR_contextDATAIMPDOITEM_:
14117 return
14118 (ffelexHandler)
14119 ffeexpr_rhs (ffeexpr_stack_->pool,
14120 FFEEXPR_contextDATAIMPDOINDEX_,
14121 ffeexpr_token_elements_);
14122
14123 case FFEEXPR_contextEQUIVALENCE:
14124 return
14125 (ffelexHandler)
14126 ffeexpr_rhs (ffeexpr_stack_->pool,
14127 FFEEXPR_contextEQVINDEX_,
14128 ffeexpr_token_elements_);
14129
14130 default:
14131 return
14132 (ffelexHandler)
14133 ffeexpr_rhs (ffeexpr_stack_->pool,
14134 FFEEXPR_contextINDEX_,
14135 ffeexpr_token_elements_);
14136 }
14137
14138 case FFEEXPR_parentypeSUBSTRING_:
14139 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
14140 ffeexpr_tokens_[0]);
14141 return
14142 (ffelexHandler)
14143 ffeexpr_rhs (ffeexpr_stack_->pool,
14144 FFEEXPR_contextINDEX_,
14145 ffeexpr_token_substring_);
14146
14147 case FFEEXPR_parentypeEQUIVALENCE_:
14148 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14149 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
14150 ffeexpr_stack_->rank = 0;
14151 ffeexpr_stack_->constant = TRUE;
14152 ffeexpr_stack_->immediate = TRUE;
14153 return
14154 (ffelexHandler)
14155 ffeexpr_rhs (ffeexpr_stack_->pool,
14156 FFEEXPR_contextEQVINDEX_,
14157 ffeexpr_token_equivalence_);
14158
14159 case FFEEXPR_parentypeFUNCTION_: /* Invalid case. */
14160 case FFEEXPR_parentypeFUNSUBSTR_: /* Invalid case. */
14161 ffesymbol_error (s, ffeexpr_tokens_[0]);
14162 /* Fall through. */
14163 case FFEEXPR_parentypeANY_:
14164 e->u.operand = ffebld_new_any ();
14165 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14166 return
14167 (ffelexHandler)
14168 ffeexpr_rhs (ffeexpr_stack_->pool,
14169 FFEEXPR_contextACTUALARG_,
14170 ffeexpr_token_anything_);
14171
14172 default:
14173 assert ("bad paren type" == NULL);
14174 break;
14175 }
14176
14177 case FFELEX_typeEQUALS: /* As in "VAR=". */
14178 switch (ffeexpr_stack_->context)
14179 {
14180 case FFEEXPR_contextIMPDOITEM_: /* within
14181 "(,VAR=start,end[,incr])". */
14182 case FFEEXPR_contextIMPDOITEMDF_:
14183 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
14184 break;
14185
14186 case FFEEXPR_contextDATAIMPDOITEM_:
14187 ffeexpr_stack_->context = FFEEXPR_contextDATAIMPDOCTRL_;
14188 break;
14189
14190 default:
14191 break;
14192 }
14193 break;
14194
14195 #if 0
14196 case FFELEX_typePERIOD:
14197 case FFELEX_typePERCENT:
14198 assert ("FOO%, FOO. not yet supported!~~" == NULL);
14199 break;
14200 #endif
14201
14202 default:
14203 break;
14204 }
14205
14206 just_name: /* :::::::::::::::::::: */
14207 e = ffeexpr_expr_new_ ();
14208 e->type = FFEEXPR_exprtypeOPERAND_;
14209 e->token = ffeexpr_tokens_[0];
14210 s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0],
14211 (ffeexpr_stack_->context
14212 == FFEEXPR_contextSUBROUTINEREF));
14213
14214 switch (ffesymbol_where (s))
14215 {
14216 case FFEINFO_whereCONSTANT:
14217 if ((ffeexpr_stack_->context != FFEEXPR_contextPARAMETER)
14218 || (ffesymbol_kind (s) != FFEINFO_kindENTITY))
14219 ffesymbol_error (s, ffeexpr_tokens_[0]);
14220 break;
14221
14222 case FFEINFO_whereIMMEDIATE:
14223 if ((ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOCTRL_)
14224 && (ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOINDEX_))
14225 ffesymbol_error (s, ffeexpr_tokens_[0]);
14226 break;
14227
14228 case FFEINFO_whereLOCAL:
14229 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14230 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recurse!. */
14231 break;
14232
14233 case FFEINFO_whereINTRINSIC:
14234 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
14235 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */
14236 break;
14237
14238 default:
14239 break;
14240 }
14241
14242 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14243 {
14244 expr = ffebld_new_any ();
14245 info = ffeinfo_new_any ();
14246 ffebld_set_info (expr, info);
14247 }
14248 else
14249 {
14250 expr = ffebld_new_symter (s,
14251 ffesymbol_generic (s),
14252 ffesymbol_specific (s),
14253 ffesymbol_implementation (s));
14254 info = ffesymbol_info (s);
14255 ffebld_set_info (expr, info);
14256 if (ffesymbol_is_doiter (s))
14257 {
14258 ffebad_start (FFEBAD_DOITER);
14259 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14260 ffelex_token_where_column (ffeexpr_tokens_[0]));
14261 ffest_ffebad_here_doiter (1, s);
14262 ffebad_string (ffesymbol_text (s));
14263 ffebad_finish ();
14264 }
14265 expr = ffeexpr_collapse_symter (expr, ffeexpr_tokens_[0]);
14266 }
14267
14268 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14269 {
14270 if (ffebld_op (expr) == FFEBLD_opANY)
14271 {
14272 expr = ffebld_new_any ();
14273 ffebld_set_info (expr, ffeinfo_new_any ());
14274 }
14275 else
14276 {
14277 expr = ffebld_new_subrref (expr, NULL); /* No argument list. */
14278 if (ffesymbol_generic (s) != FFEINTRIN_genNONE)
14279 ffeintrin_fulfill_generic (&expr, &info, e->token);
14280 else if (ffesymbol_specific (s) != FFEINTRIN_specNONE)
14281 ffeintrin_fulfill_specific (&expr, &info, NULL, e->token);
14282 else
14283 ffeexpr_fulfill_call_ (&expr, e->token);
14284
14285 if (ffebld_op (expr) != FFEBLD_opANY)
14286 ffebld_set_info (expr,
14287 ffeinfo_new (ffeinfo_basictype (info),
14288 ffeinfo_kindtype (info),
14289 0,
14290 FFEINFO_kindENTITY,
14291 FFEINFO_whereFLEETING,
14292 ffeinfo_size (info)));
14293 else
14294 ffebld_set_info (expr, ffeinfo_new_any ());
14295 }
14296 }
14297
14298 e->u.operand = expr;
14299 ffeexpr_exprstack_push_operand_ (e);
14300 return (ffelexHandler) ffeexpr_finished_ (t);
14301 }
14302
14303 /* ffeexpr_token_name_arg_ -- Rhs NAME
14304
14305 Return a pointer to this function to the lexer (ffelex), which will
14306 invoke it for the next token.
14307
14308 Handle first token in an actual-arg (or possible actual-arg) context
14309 being a NAME, and use second token to refine the context. */
14310
14311 static ffelexHandler
14312 ffeexpr_token_name_arg_ (ffelexToken t)
14313 {
14314 switch (ffelex_token_type (t))
14315 {
14316 case FFELEX_typeCLOSE_PAREN:
14317 case FFELEX_typeCOMMA:
14318 switch (ffeexpr_stack_->context)
14319 {
14320 case FFEEXPR_contextINDEXORACTUALARG_:
14321 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
14322 break;
14323
14324 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
14325 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
14326 break;
14327
14328 default:
14329 break;
14330 }
14331 break;
14332
14333 default:
14334 switch (ffeexpr_stack_->context)
14335 {
14336 case FFEEXPR_contextACTUALARG_:
14337 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
14338 break;
14339
14340 case FFEEXPR_contextINDEXORACTUALARG_:
14341 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
14342 break;
14343
14344 case FFEEXPR_contextSFUNCDEFACTUALARG_:
14345 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
14346 break;
14347
14348 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
14349 ffeexpr_stack_->context
14350 = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
14351 break;
14352
14353 default:
14354 assert ("bad context in _name_arg_" == NULL);
14355 break;
14356 }
14357 break;
14358 }
14359
14360 return (ffelexHandler) ffeexpr_token_name_rhs_ (t);
14361 }
14362
14363 /* ffeexpr_token_name_rhs_ -- Rhs NAME
14364
14365 Return a pointer to this function to the lexer (ffelex), which will
14366 invoke it for the next token.
14367
14368 Handle a name followed by open-paren, apostrophe (O'octal-const',
14369 Z'hex-const', or X'hex-const'), period (RECORD.MEMBER).
14370
14371 26-Nov-91 JCB 1.2
14372 When followed by apostrophe or quote, set lex hexnum flag on so
14373 [0-9] as first char of next token seen as starting a potentially
14374 hex number (NAME).
14375 04-Oct-91 JCB 1.1
14376 In case of intrinsic, decorate its SYMTER with the type info for
14377 the specific intrinsic. */
14378
14379 static ffelexHandler
14380 ffeexpr_token_name_rhs_ (ffelexToken t)
14381 {
14382 ffeexprExpr_ e;
14383 ffeexprParenType_ paren_type;
14384 ffesymbol s;
14385 bool sfdef;
14386
14387 switch (ffelex_token_type (t))
14388 {
14389 case FFELEX_typeQUOTE:
14390 case FFELEX_typeAPOSTROPHE:
14391 ffeexpr_tokens_[1] = ffelex_token_use (t);
14392 ffelex_set_hexnum (TRUE);
14393 return (ffelexHandler) ffeexpr_token_name_apos_;
14394
14395 case FFELEX_typeOPEN_PAREN:
14396 e = ffeexpr_expr_new_ ();
14397 e->type = FFEEXPR_exprtypeOPERAND_;
14398 e->token = ffelex_token_use (ffeexpr_tokens_[0]);
14399 s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], TRUE,
14400 &paren_type);
14401 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14402 e->u.operand = ffebld_new_any ();
14403 else
14404 e->u.operand = ffebld_new_symter (s, ffesymbol_generic (s),
14405 ffesymbol_specific (s),
14406 ffesymbol_implementation (s));
14407 ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */
14408 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
14409 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
14410 {
14411 case FFEEXPR_contextSFUNCDEF:
14412 case FFEEXPR_contextSFUNCDEFINDEX_:
14413 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
14414 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
14415 sfdef = TRUE;
14416 break;
14417
14418 case FFEEXPR_contextSFUNCDEFACTUALARG_:
14419 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
14420 assert ("weird context!" == NULL);
14421 sfdef = FALSE;
14422 break;
14423
14424 default:
14425 sfdef = FALSE;
14426 break;
14427 }
14428 switch (paren_type)
14429 {
14430 case FFEEXPR_parentypeFUNCTION_:
14431 ffebld_set_info (e->u.operand, ffesymbol_info (s));
14432 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14433 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
14434 { /* A statement function. */
14435 ffeexpr_stack_->num_args
14436 = ffebld_list_length
14437 (ffeexpr_stack_->next_dummy
14438 = ffesymbol_dummyargs (s));
14439 ffeexpr_stack_->tokens[1] = NULL; /* !=NULL when > num_args. */
14440 }
14441 else if ((ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
14442 && !ffe_is_pedantic_not_90 ()
14443 && ((ffesymbol_implementation (s)
14444 == FFEINTRIN_impICHAR)
14445 || (ffesymbol_implementation (s)
14446 == FFEINTRIN_impIACHAR)
14447 || (ffesymbol_implementation (s)
14448 == FFEINTRIN_impLEN)))
14449 { /* Allow arbitrary concatenations. */
14450 return
14451 (ffelexHandler)
14452 ffeexpr_rhs (ffeexpr_stack_->pool,
14453 sfdef
14454 ? FFEEXPR_contextSFUNCDEF
14455 : FFEEXPR_contextLET,
14456 ffeexpr_token_arguments_);
14457 }
14458 return
14459 (ffelexHandler)
14460 ffeexpr_rhs (ffeexpr_stack_->pool,
14461 sfdef
14462 ? FFEEXPR_contextSFUNCDEFACTUALARG_
14463 : FFEEXPR_contextACTUALARG_,
14464 ffeexpr_token_arguments_);
14465
14466 case FFEEXPR_parentypeARRAY_:
14467 ffebld_set_info (e->u.operand,
14468 ffesymbol_info (ffebld_symter (e->u.operand)));
14469 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14470 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
14471 ffeexpr_stack_->rank = 0;
14472 ffeexpr_stack_->constant = TRUE;
14473 ffeexpr_stack_->immediate = TRUE;
14474 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
14475 sfdef
14476 ? FFEEXPR_contextSFUNCDEFINDEX_
14477 : FFEEXPR_contextINDEX_,
14478 ffeexpr_token_elements_);
14479
14480 case FFEEXPR_parentypeSUBSTRING_:
14481 ffebld_set_info (e->u.operand,
14482 ffesymbol_info (ffebld_symter (e->u.operand)));
14483 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
14484 ffeexpr_tokens_[0]);
14485 return
14486 (ffelexHandler)
14487 ffeexpr_rhs (ffeexpr_stack_->pool,
14488 sfdef
14489 ? FFEEXPR_contextSFUNCDEFINDEX_
14490 : FFEEXPR_contextINDEX_,
14491 ffeexpr_token_substring_);
14492
14493 case FFEEXPR_parentypeFUNSUBSTR_:
14494 return
14495 (ffelexHandler)
14496 ffeexpr_rhs (ffeexpr_stack_->pool,
14497 sfdef
14498 ? FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
14499 : FFEEXPR_contextINDEXORACTUALARG_,
14500 ffeexpr_token_funsubstr_);
14501
14502 case FFEEXPR_parentypeANY_:
14503 ffebld_set_info (e->u.operand, ffesymbol_info (s));
14504 return
14505 (ffelexHandler)
14506 ffeexpr_rhs (ffeexpr_stack_->pool,
14507 sfdef
14508 ? FFEEXPR_contextSFUNCDEFACTUALARG_
14509 : FFEEXPR_contextACTUALARG_,
14510 ffeexpr_token_anything_);
14511
14512 default:
14513 assert ("bad paren type" == NULL);
14514 break;
14515 }
14516
14517 case FFELEX_typeEQUALS: /* As in "VAR=". */
14518 switch (ffeexpr_stack_->context)
14519 {
14520 case FFEEXPR_contextIMPDOITEM_: /* "(,VAR=start,end[,incr])". */
14521 case FFEEXPR_contextIMPDOITEMDF_:
14522 ffeexpr_stack_->is_rhs = FALSE; /* Really an lhs construct. */
14523 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
14524 break;
14525
14526 default:
14527 break;
14528 }
14529 break;
14530
14531 #if 0
14532 case FFELEX_typePERIOD:
14533 case FFELEX_typePERCENT:
14534 ~~Support these two someday, though not required
14535 assert ("FOO%, FOO. not yet supported!~~" == NULL);
14536 break;
14537 #endif
14538
14539 default:
14540 break;
14541 }
14542
14543 switch (ffeexpr_stack_->context)
14544 {
14545 case FFEEXPR_contextINDEXORACTUALARG_:
14546 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
14547 assert ("strange context" == NULL);
14548 break;
14549
14550 default:
14551 break;
14552 }
14553
14554 e = ffeexpr_expr_new_ ();
14555 e->type = FFEEXPR_exprtypeOPERAND_;
14556 e->token = ffeexpr_tokens_[0];
14557 s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0], FALSE);
14558 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14559 {
14560 e->u.operand = ffebld_new_any ();
14561 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14562 }
14563 else
14564 {
14565 e->u.operand = ffebld_new_symter (s, FFEINTRIN_genNONE,
14566 ffesymbol_specific (s),
14567 ffesymbol_implementation (s));
14568 if (ffesymbol_specific (s) == FFEINTRIN_specNONE)
14569 ffebld_set_info (e->u.operand, ffeinfo_use (ffesymbol_info (s)));
14570 else
14571 { /* Decorate the SYMTER with the actual type
14572 of the intrinsic. */
14573 ffebld_set_info (e->u.operand, ffeinfo_new
14574 (ffeintrin_basictype (ffesymbol_specific (s)),
14575 ffeintrin_kindtype (ffesymbol_specific (s)),
14576 0,
14577 ffesymbol_kind (s),
14578 ffesymbol_where (s),
14579 FFETARGET_charactersizeNONE));
14580 }
14581 if (ffesymbol_is_doiter (s))
14582 ffebld_symter_set_is_doiter (e->u.operand, TRUE);
14583 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
14584 ffeexpr_tokens_[0]);
14585 }
14586 ffeexpr_exprstack_push_operand_ (e);
14587 return (ffelexHandler) ffeexpr_token_binary_ (t);
14588 }
14589
14590 /* ffeexpr_token_name_apos_ -- Rhs NAME APOSTROPHE
14591
14592 Return a pointer to this function to the lexer (ffelex), which will
14593 invoke it for the next token.
14594
14595 Expecting a NAME token, analyze the previous NAME token to see what kind,
14596 if any, typeless constant we've got.
14597
14598 01-Sep-90 JCB 1.1
14599 Expect a NAME instead of CHARACTER in this situation. */
14600
14601 static ffelexHandler
14602 ffeexpr_token_name_apos_ (ffelexToken t)
14603 {
14604 ffeexprExpr_ e;
14605
14606 ffelex_set_hexnum (FALSE);
14607
14608 switch (ffelex_token_type (t))
14609 {
14610 case FFELEX_typeNAME:
14611 ffeexpr_tokens_[2] = ffelex_token_use (t);
14612 return (ffelexHandler) ffeexpr_token_name_apos_name_;
14613
14614 default:
14615 break;
14616 }
14617
14618 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14619 {
14620 ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
14621 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14622 ffelex_token_where_column (ffeexpr_tokens_[0]));
14623 ffebad_here (1, ffelex_token_where_line (t),
14624 ffelex_token_where_column (t));
14625 ffebad_finish ();
14626 }
14627
14628 ffelex_token_kill (ffeexpr_tokens_[1]);
14629
14630 e = ffeexpr_expr_new_ ();
14631 e->type = FFEEXPR_exprtypeOPERAND_;
14632 e->u.operand = ffebld_new_any ();
14633 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14634 e->token = ffeexpr_tokens_[0];
14635 ffeexpr_exprstack_push_operand_ (e);
14636
14637 return (ffelexHandler) ffeexpr_token_binary_ (t);
14638 }
14639
14640 /* ffeexpr_token_name_apos_name_ -- Rhs NAME APOSTROPHE NAME
14641
14642 Return a pointer to this function to the lexer (ffelex), which will
14643 invoke it for the next token.
14644
14645 Expecting an APOSTROPHE token, analyze the previous NAME token to see
14646 what kind, if any, typeless constant we've got. */
14647
14648 static ffelexHandler
14649 ffeexpr_token_name_apos_name_ (ffelexToken t)
14650 {
14651 ffeexprExpr_ e;
14652 char c;
14653
14654 e = ffeexpr_expr_new_ ();
14655 e->type = FFEEXPR_exprtypeOPERAND_;
14656 e->token = ffeexpr_tokens_[0];
14657
14658 if ((ffelex_token_type (t) == ffelex_token_type (ffeexpr_tokens_[1]))
14659 && (ffelex_token_length (ffeexpr_tokens_[0]) == 1)
14660 && (ffesrc_char_match_init ((c = ffelex_token_text (ffeexpr_tokens_[0])[0]),
14661 'B', 'b')
14662 || ffesrc_char_match_init (c, 'O', 'o')
14663 || ffesrc_char_match_init (c, 'X', 'x')
14664 || ffesrc_char_match_init (c, 'Z', 'z')))
14665 {
14666 ffetargetCharacterSize size;
14667
14668 if (!ffe_is_typeless_boz ()) {
14669
14670 switch (c)
14671 {
14672 case FFESRC_CASE_MATCH_INIT ('B', 'b', imatch_b, no_imatch):
14673 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerbinary
14674 (ffeexpr_tokens_[2]));
14675 break;
14676
14677 case FFESRC_CASE_MATCH_INIT ('O', 'o', imatch_o, no_imatch):
14678 e->u.operand = ffebld_new_conter (ffebld_constant_new_integeroctal
14679 (ffeexpr_tokens_[2]));
14680 break;
14681
14682 case FFESRC_CASE_MATCH_INIT ('X', 'x', imatch_x, no_imatch):
14683 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
14684 (ffeexpr_tokens_[2]));
14685 break;
14686
14687 case FFESRC_CASE_MATCH_INIT ('Z', 'z', imatch_z, no_imatch):
14688 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
14689 (ffeexpr_tokens_[2]));
14690 break;
14691
14692 default:
14693 no_imatch: /* :::::::::::::::::::: */
14694 assert ("not BOXZ!" == NULL);
14695 abort ();
14696 }
14697
14698 ffebld_set_info (e->u.operand,
14699 ffeinfo_new (FFEINFO_basictypeINTEGER,
14700 FFEINFO_kindtypeINTEGERDEFAULT, 0,
14701 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14702 FFETARGET_charactersizeNONE));
14703 ffeexpr_exprstack_push_operand_ (e);
14704 ffelex_token_kill (ffeexpr_tokens_[1]);
14705 ffelex_token_kill (ffeexpr_tokens_[2]);
14706 return (ffelexHandler) ffeexpr_token_binary_;
14707 }
14708
14709 switch (c)
14710 {
14711 case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
14712 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_bm
14713 (ffeexpr_tokens_[2]));
14714 size = ffetarget_size_typeless_binary (ffeexpr_tokens_[2]);
14715 break;
14716
14717 case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
14718 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_om
14719 (ffeexpr_tokens_[2]));
14720 size = ffetarget_size_typeless_octal (ffeexpr_tokens_[2]);
14721 break;
14722
14723 case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
14724 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hxm
14725 (ffeexpr_tokens_[2]));
14726 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
14727 break;
14728
14729 case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
14730 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
14731 (ffeexpr_tokens_[2]));
14732 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
14733 break;
14734
14735 default:
14736 no_match: /* :::::::::::::::::::: */
14737 assert ("not BOXZ!" == NULL);
14738 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
14739 (ffeexpr_tokens_[2]));
14740 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
14741 break;
14742 }
14743 ffebld_set_info (e->u.operand,
14744 ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
14745 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
14746 ffeexpr_exprstack_push_operand_ (e);
14747 ffelex_token_kill (ffeexpr_tokens_[1]);
14748 ffelex_token_kill (ffeexpr_tokens_[2]);
14749 return (ffelexHandler) ffeexpr_token_binary_;
14750 }
14751
14752 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14753 {
14754 ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
14755 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14756 ffelex_token_where_column (ffeexpr_tokens_[0]));
14757 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14758 ffebad_finish ();
14759 }
14760
14761 ffelex_token_kill (ffeexpr_tokens_[1]);
14762 ffelex_token_kill (ffeexpr_tokens_[2]);
14763
14764 e->type = FFEEXPR_exprtypeOPERAND_;
14765 e->u.operand = ffebld_new_any ();
14766 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14767 e->token = ffeexpr_tokens_[0];
14768 ffeexpr_exprstack_push_operand_ (e);
14769
14770 switch (ffelex_token_type (t))
14771 {
14772 case FFELEX_typeAPOSTROPHE:
14773 case FFELEX_typeQUOTE:
14774 return (ffelexHandler) ffeexpr_token_binary_;
14775
14776 default:
14777 return (ffelexHandler) ffeexpr_token_binary_ (t);
14778 }
14779 }
14780
14781 /* ffeexpr_token_percent_ -- Rhs PERCENT
14782
14783 Handle a percent sign possibly followed by "LOC". If followed instead
14784 by "VAL", "REF", or "DESCR", issue an error message and substitute
14785 "LOC". If followed by something else, treat the percent sign as a
14786 spurious incorrect token and reprocess the token via _rhs_. */
14787
14788 static ffelexHandler
14789 ffeexpr_token_percent_ (ffelexToken t)
14790 {
14791 switch (ffelex_token_type (t))
14792 {
14793 case FFELEX_typeNAME:
14794 case FFELEX_typeNAMES:
14795 ffeexpr_stack_->percent = ffeexpr_percent_ (t);
14796 ffeexpr_tokens_[1] = ffelex_token_use (t);
14797 return (ffelexHandler) ffeexpr_token_percent_name_;
14798
14799 default:
14800 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
14801 {
14802 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14803 ffelex_token_where_column (ffeexpr_tokens_[0]));
14804 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
14805 ffelex_token_where_column (ffeexpr_stack_->first_token));
14806 ffebad_finish ();
14807 }
14808 ffelex_token_kill (ffeexpr_tokens_[0]);
14809 return (ffelexHandler) ffeexpr_token_rhs_ (t);
14810 }
14811 }
14812
14813 /* ffeexpr_token_percent_name_ -- Rhs PERCENT NAME
14814
14815 Make sure the token is OPEN_PAREN and prepare for the one-item list of
14816 LHS expressions. Else display an error message. */
14817
14818 static ffelexHandler
14819 ffeexpr_token_percent_name_ (ffelexToken t)
14820 {
14821 ffelexHandler nexthandler;
14822
14823 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
14824 {
14825 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
14826 {
14827 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14828 ffelex_token_where_column (ffeexpr_tokens_[0]));
14829 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
14830 ffelex_token_where_column (ffeexpr_stack_->first_token));
14831 ffebad_finish ();
14832 }
14833 ffelex_token_kill (ffeexpr_tokens_[0]);
14834 nexthandler = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_tokens_[1]);
14835 ffelex_token_kill (ffeexpr_tokens_[1]);
14836 return (ffelexHandler) (*nexthandler) (t);
14837 }
14838
14839 switch (ffeexpr_stack_->percent)
14840 {
14841 default:
14842 if (ffest_ffebad_start (FFEBAD_INVALID_PERCENT))
14843 {
14844 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14845 ffelex_token_where_column (ffeexpr_tokens_[0]));
14846 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
14847 ffebad_finish ();
14848 }
14849 ffeexpr_stack_->percent = FFEEXPR_percentLOC_;
14850 /* Fall through. */
14851 case FFEEXPR_percentLOC_:
14852 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
14853 ffelex_token_kill (ffeexpr_tokens_[1]);
14854 ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
14855 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
14856 FFEEXPR_contextLOC_,
14857 ffeexpr_cb_end_loc_);
14858 }
14859 }
14860
14861 /* ffeexpr_make_float_const_ -- Make a floating-point constant
14862
14863 See prototype.
14864
14865 Pass 'E', 'D', or 'Q' for exponent letter. */
14866
14867 static void
14868 ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
14869 ffelexToken decimal, ffelexToken fraction,
14870 ffelexToken exponent, ffelexToken exponent_sign,
14871 ffelexToken exponent_digits)
14872 {
14873 ffeexprExpr_ e;
14874
14875 e = ffeexpr_expr_new_ ();
14876 e->type = FFEEXPR_exprtypeOPERAND_;
14877 if (integer != NULL)
14878 e->token = ffelex_token_use (integer);
14879 else
14880 {
14881 assert (decimal != NULL);
14882 e->token = ffelex_token_use (decimal);
14883 }
14884
14885 switch (exp_letter)
14886 {
14887 #if !FFETARGET_okREALQUAD
14888 case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
14889 if (ffebad_start (FFEBAD_QUAD_UNSUPPORTED))
14890 {
14891 ffebad_here (0, ffelex_token_where_line (e->token),
14892 ffelex_token_where_column (e->token));
14893 ffebad_finish ();
14894 }
14895 goto match_d; /* The FFESRC_CASE_* macros don't
14896 allow fall-through! */
14897 #endif
14898
14899 case FFESRC_CASE_MATCH_INIT ('D', 'd', match_d, no_match):
14900 e->u.operand = ffebld_new_conter (ffebld_constant_new_realdouble
14901 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
14902 ffebld_set_info (e->u.operand,
14903 ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
14904 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14905 break;
14906
14907 case FFESRC_CASE_MATCH_INIT ('E', 'e', match_e, no_match):
14908 e->u.operand = ffebld_new_conter (ffebld_constant_new_realdefault
14909 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
14910 ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeREAL,
14911 FFEINFO_kindtypeREALDEFAULT, 0, FFEINFO_kindENTITY,
14912 FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14913 break;
14914
14915 #if FFETARGET_okREALQUAD
14916 case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
14917 e->u.operand = ffebld_new_conter (ffebld_constant_new_realquad
14918 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
14919 ffebld_set_info (e->u.operand,
14920 ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALQUAD,
14921 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14922 break;
14923 #endif
14924
14925 case 'I': /* Make an integer. */
14926 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
14927 (ffeexpr_tokens_[0]));
14928 ffebld_set_info (e->u.operand,
14929 ffeinfo_new (FFEINFO_basictypeINTEGER,
14930 FFEINFO_kindtypeINTEGERDEFAULT, 0,
14931 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14932 FFETARGET_charactersizeNONE));
14933 break;
14934
14935 default:
14936 no_match: /* :::::::::::::::::::: */
14937 assert ("Lost the exponent letter!" == NULL);
14938 }
14939
14940 ffeexpr_exprstack_push_operand_ (e);
14941 }
14942
14943 /* Just like ffesymbol_declare_local, except performs any implicit info
14944 assignment necessary. */
14945
14946 static ffesymbol
14947 ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin)
14948 {
14949 ffesymbol s;
14950 ffeinfoKind k;
14951 bool bad;
14952
14953 s = ffesymbol_declare_local (t, maybe_intrin);
14954
14955 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
14956 /* Special-case these since they can involve a different concept
14957 of "state" (in the stmtfunc name space). */
14958 {
14959 case FFEEXPR_contextDATAIMPDOINDEX_:
14960 case FFEEXPR_contextDATAIMPDOCTRL_:
14961 if (ffeexpr_context_outer_ (ffeexpr_stack_)
14962 == FFEEXPR_contextDATAIMPDOINDEX_)
14963 s = ffeexpr_sym_impdoitem_ (s, t);
14964 else
14965 if (ffeexpr_stack_->is_rhs)
14966 s = ffeexpr_sym_impdoitem_ (s, t);
14967 else
14968 s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
14969 bad = (ffesymbol_kind (s) != FFEINFO_kindENTITY)
14970 || ((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
14971 && (ffesymbol_where (s) != FFEINFO_whereIMMEDIATE));
14972 if (bad && (ffesymbol_kind (s) != FFEINFO_kindANY))
14973 ffesymbol_error (s, t);
14974 return s;
14975
14976 default:
14977 break;
14978 }
14979
14980 switch ((ffesymbol_sfdummyparent (s) == NULL)
14981 ? ffesymbol_state (s)
14982 : FFESYMBOL_stateUNDERSTOOD)
14983 {
14984 case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr
14985 context. */
14986 if (!ffest_seen_first_exec ())
14987 goto seen; /* :::::::::::::::::::: */
14988 /* Fall through. */
14989 case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */
14990 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
14991 {
14992 case FFEEXPR_contextSUBROUTINEREF:
14993 s = ffeexpr_sym_lhs_call_ (s, t);
14994 break;
14995
14996 case FFEEXPR_contextFILEEXTFUNC:
14997 s = ffeexpr_sym_lhs_extfunc_ (s, t);
14998 break;
14999
15000 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15001 s = ffecom_sym_exec_transition (s);
15002 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15003 goto understood; /* :::::::::::::::::::: */
15004 /* Fall through. */
15005 case FFEEXPR_contextACTUALARG_:
15006 s = ffeexpr_sym_rhs_actualarg_ (s, t);
15007 break;
15008
15009 case FFEEXPR_contextDATA:
15010 if (ffeexpr_stack_->is_rhs)
15011 s = ffeexpr_sym_rhs_let_ (s, t);
15012 else
15013 s = ffeexpr_sym_lhs_data_ (s, t);
15014 break;
15015
15016 case FFEEXPR_contextDATAIMPDOITEM_:
15017 s = ffeexpr_sym_lhs_data_ (s, t);
15018 break;
15019
15020 case FFEEXPR_contextSFUNCDEF:
15021 case FFEEXPR_contextSFUNCDEFINDEX_:
15022 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15023 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15024 s = ffecom_sym_exec_transition (s);
15025 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15026 goto understood; /* :::::::::::::::::::: */
15027 /* Fall through. */
15028 case FFEEXPR_contextLET:
15029 case FFEEXPR_contextPAREN_:
15030 case FFEEXPR_contextACTUALARGEXPR_:
15031 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15032 case FFEEXPR_contextASSIGN:
15033 case FFEEXPR_contextIOLIST:
15034 case FFEEXPR_contextIOLISTDF:
15035 case FFEEXPR_contextDO:
15036 case FFEEXPR_contextDOWHILE:
15037 case FFEEXPR_contextAGOTO:
15038 case FFEEXPR_contextCGOTO:
15039 case FFEEXPR_contextIF:
15040 case FFEEXPR_contextARITHIF:
15041 case FFEEXPR_contextFORMAT:
15042 case FFEEXPR_contextSTOP:
15043 case FFEEXPR_contextRETURN:
15044 case FFEEXPR_contextSELECTCASE:
15045 case FFEEXPR_contextCASE:
15046 case FFEEXPR_contextFILEASSOC:
15047 case FFEEXPR_contextFILEINT:
15048 case FFEEXPR_contextFILEDFINT:
15049 case FFEEXPR_contextFILELOG:
15050 case FFEEXPR_contextFILENUM:
15051 case FFEEXPR_contextFILENUMAMBIG:
15052 case FFEEXPR_contextFILECHAR:
15053 case FFEEXPR_contextFILENUMCHAR:
15054 case FFEEXPR_contextFILEDFCHAR:
15055 case FFEEXPR_contextFILEKEY:
15056 case FFEEXPR_contextFILEUNIT:
15057 case FFEEXPR_contextFILEUNIT_DF:
15058 case FFEEXPR_contextFILEUNITAMBIG:
15059 case FFEEXPR_contextFILEFORMAT:
15060 case FFEEXPR_contextFILENAMELIST:
15061 case FFEEXPR_contextFILEVXTCODE:
15062 case FFEEXPR_contextINDEX_:
15063 case FFEEXPR_contextIMPDOITEM_:
15064 case FFEEXPR_contextIMPDOITEMDF_:
15065 case FFEEXPR_contextIMPDOCTRL_:
15066 case FFEEXPR_contextLOC_:
15067 if (ffeexpr_stack_->is_rhs)
15068 s = ffeexpr_sym_rhs_let_ (s, t);
15069 else
15070 s = ffeexpr_sym_lhs_let_ (s, t);
15071 break;
15072
15073 case FFEEXPR_contextCHARACTERSIZE:
15074 case FFEEXPR_contextEQUIVALENCE:
15075 case FFEEXPR_contextINCLUDE:
15076 case FFEEXPR_contextPARAMETER:
15077 case FFEEXPR_contextDIMLIST:
15078 case FFEEXPR_contextDIMLISTCOMMON:
15079 case FFEEXPR_contextKINDTYPE:
15080 case FFEEXPR_contextINITVAL:
15081 case FFEEXPR_contextEQVINDEX_:
15082 break; /* Will turn into errors below. */
15083
15084 default:
15085 ffesymbol_error (s, t);
15086 break;
15087 }
15088 /* Fall through. */
15089 case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */
15090 understood: /* :::::::::::::::::::: */
15091 k = ffesymbol_kind (s);
15092 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15093 {
15094 case FFEEXPR_contextSUBROUTINEREF:
15095 bad = ((k != FFEINFO_kindSUBROUTINE)
15096 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
15097 || (k != FFEINFO_kindNONE)));
15098 break;
15099
15100 case FFEEXPR_contextFILEEXTFUNC:
15101 bad = (k != FFEINFO_kindFUNCTION)
15102 || (ffesymbol_where (s) != FFEINFO_whereGLOBAL);
15103 break;
15104
15105 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15106 case FFEEXPR_contextACTUALARG_:
15107 switch (k)
15108 {
15109 case FFEINFO_kindENTITY:
15110 bad = FALSE;
15111 break;
15112
15113 case FFEINFO_kindFUNCTION:
15114 case FFEINFO_kindSUBROUTINE:
15115 bad
15116 = ((ffesymbol_where (s) != FFEINFO_whereGLOBAL)
15117 && (ffesymbol_where (s) != FFEINFO_whereDUMMY)
15118 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
15119 || !ffeintrin_is_actualarg (ffesymbol_specific (s))));
15120 break;
15121
15122 case FFEINFO_kindNONE:
15123 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
15124 {
15125 bad = !(ffeintrin_is_actualarg (ffesymbol_specific (s)));
15126 break;
15127 }
15128
15129 /* If state is UNDERSTOOD here, it's CHAR*(*) or attrsANY,
15130 and in the former case, attrsTYPE is set, so we
15131 see this as an error as we should, since CHAR*(*)
15132 cannot be actually referenced in a main/block data
15133 program unit. */
15134
15135 if ((ffesymbol_attrs (s) & (FFESYMBOL_attrsANY
15136 | FFESYMBOL_attrsEXTERNAL
15137 | FFESYMBOL_attrsTYPE))
15138 == FFESYMBOL_attrsEXTERNAL)
15139 bad = FALSE;
15140 else
15141 bad = TRUE;
15142 break;
15143
15144 default:
15145 bad = TRUE;
15146 break;
15147 }
15148 break;
15149
15150 case FFEEXPR_contextDATA:
15151 if (ffeexpr_stack_->is_rhs)
15152 bad = (k != FFEINFO_kindENTITY)
15153 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
15154 else
15155 bad = (k != FFEINFO_kindENTITY)
15156 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
15157 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
15158 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
15159 break;
15160
15161 case FFEEXPR_contextDATAIMPDOITEM_:
15162 bad = TRUE; /* Unadorned item never valid. */
15163 break;
15164
15165 case FFEEXPR_contextSFUNCDEF:
15166 case FFEEXPR_contextSFUNCDEFINDEX_:
15167 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15168 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15169 case FFEEXPR_contextLET:
15170 case FFEEXPR_contextPAREN_:
15171 case FFEEXPR_contextACTUALARGEXPR_:
15172 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15173 case FFEEXPR_contextASSIGN:
15174 case FFEEXPR_contextIOLIST:
15175 case FFEEXPR_contextIOLISTDF:
15176 case FFEEXPR_contextDO:
15177 case FFEEXPR_contextDOWHILE:
15178 case FFEEXPR_contextAGOTO:
15179 case FFEEXPR_contextCGOTO:
15180 case FFEEXPR_contextIF:
15181 case FFEEXPR_contextARITHIF:
15182 case FFEEXPR_contextFORMAT:
15183 case FFEEXPR_contextSTOP:
15184 case FFEEXPR_contextRETURN:
15185 case FFEEXPR_contextSELECTCASE:
15186 case FFEEXPR_contextCASE:
15187 case FFEEXPR_contextFILEASSOC:
15188 case FFEEXPR_contextFILEINT:
15189 case FFEEXPR_contextFILEDFINT:
15190 case FFEEXPR_contextFILELOG:
15191 case FFEEXPR_contextFILENUM:
15192 case FFEEXPR_contextFILENUMAMBIG:
15193 case FFEEXPR_contextFILECHAR:
15194 case FFEEXPR_contextFILENUMCHAR:
15195 case FFEEXPR_contextFILEDFCHAR:
15196 case FFEEXPR_contextFILEKEY:
15197 case FFEEXPR_contextFILEUNIT:
15198 case FFEEXPR_contextFILEUNIT_DF:
15199 case FFEEXPR_contextFILEUNITAMBIG:
15200 case FFEEXPR_contextFILEFORMAT:
15201 case FFEEXPR_contextFILENAMELIST:
15202 case FFEEXPR_contextFILEVXTCODE:
15203 case FFEEXPR_contextINDEX_:
15204 case FFEEXPR_contextIMPDOITEM_:
15205 case FFEEXPR_contextIMPDOITEMDF_:
15206 case FFEEXPR_contextIMPDOCTRL_:
15207 case FFEEXPR_contextLOC_:
15208 bad = (k != FFEINFO_kindENTITY); /* This catches "SUBROUTINE
15209 X(A);EXTERNAL A;CALL
15210 Y(A);B=A", for example. */
15211 break;
15212
15213 case FFEEXPR_contextCHARACTERSIZE:
15214 case FFEEXPR_contextEQUIVALENCE:
15215 case FFEEXPR_contextPARAMETER:
15216 case FFEEXPR_contextDIMLIST:
15217 case FFEEXPR_contextDIMLISTCOMMON:
15218 case FFEEXPR_contextKINDTYPE:
15219 case FFEEXPR_contextINITVAL:
15220 case FFEEXPR_contextEQVINDEX_:
15221 bad = (k != FFEINFO_kindENTITY)
15222 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
15223 break;
15224
15225 case FFEEXPR_contextINCLUDE:
15226 bad = TRUE;
15227 break;
15228
15229 default:
15230 bad = TRUE;
15231 break;
15232 }
15233 if (bad && (k != FFEINFO_kindANY))
15234 ffesymbol_error (s, t);
15235 return s;
15236
15237 case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */
15238 seen: /* :::::::::::::::::::: */
15239 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15240 {
15241 case FFEEXPR_contextPARAMETER:
15242 if (ffeexpr_stack_->is_rhs)
15243 ffesymbol_error (s, t);
15244 else
15245 s = ffeexpr_sym_lhs_parameter_ (s, t);
15246 break;
15247
15248 case FFEEXPR_contextDATA:
15249 s = ffecom_sym_exec_transition (s);
15250 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15251 goto understood; /* :::::::::::::::::::: */
15252 if (ffeexpr_stack_->is_rhs)
15253 ffesymbol_error (s, t);
15254 else
15255 s = ffeexpr_sym_lhs_data_ (s, t);
15256 goto understood; /* :::::::::::::::::::: */
15257
15258 case FFEEXPR_contextDATAIMPDOITEM_:
15259 s = ffecom_sym_exec_transition (s);
15260 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15261 goto understood; /* :::::::::::::::::::: */
15262 s = ffeexpr_sym_lhs_data_ (s, t);
15263 goto understood; /* :::::::::::::::::::: */
15264
15265 case FFEEXPR_contextEQUIVALENCE:
15266 s = ffeexpr_sym_lhs_equivalence_ (s, t);
15267 break;
15268
15269 case FFEEXPR_contextDIMLIST:
15270 s = ffeexpr_sym_rhs_dimlist_ (s, t);
15271 break;
15272
15273 case FFEEXPR_contextCHARACTERSIZE:
15274 case FFEEXPR_contextKINDTYPE:
15275 case FFEEXPR_contextDIMLISTCOMMON:
15276 case FFEEXPR_contextINITVAL:
15277 case FFEEXPR_contextEQVINDEX_:
15278 ffesymbol_error (s, t);
15279 break;
15280
15281 case FFEEXPR_contextINCLUDE:
15282 ffesymbol_error (s, t);
15283 break;
15284
15285 case FFEEXPR_contextACTUALARG_: /* E.g. I in REAL A(Y(I)). */
15286 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15287 s = ffecom_sym_exec_transition (s);
15288 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15289 goto understood; /* :::::::::::::::::::: */
15290 s = ffeexpr_sym_rhs_actualarg_ (s, t);
15291 goto understood; /* :::::::::::::::::::: */
15292
15293 case FFEEXPR_contextINDEX_:
15294 case FFEEXPR_contextACTUALARGEXPR_:
15295 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15296 case FFEEXPR_contextSFUNCDEF:
15297 case FFEEXPR_contextSFUNCDEFINDEX_:
15298 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15299 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15300 assert (ffeexpr_stack_->is_rhs);
15301 s = ffecom_sym_exec_transition (s);
15302 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15303 goto understood; /* :::::::::::::::::::: */
15304 s = ffeexpr_sym_rhs_let_ (s, t);
15305 goto understood; /* :::::::::::::::::::: */
15306
15307 default:
15308 ffesymbol_error (s, t);
15309 break;
15310 }
15311 return s;
15312
15313 default:
15314 assert ("bad symbol state" == NULL);
15315 return NULL;
15316 break;
15317 }
15318 }
15319
15320 /* Have FOO in DATA (XYZ(FOO),...)/.../ or DATA (...,XYZ=FOO,BAR,BLETCH).
15321 Could be found via the "statement-function" name space (in which case
15322 it should become an iterator) or the local name space (in which case
15323 it should be either a named constant, or a variable that will have an
15324 sfunc name space sibling that should become an iterator). */
15325
15326 static ffesymbol
15327 ffeexpr_sym_impdoitem_ (ffesymbol sp, ffelexToken t)
15328 {
15329 ffesymbol s;
15330 ffesymbolAttrs sa;
15331 ffesymbolAttrs na;
15332 ffesymbolState ss;
15333 ffesymbolState ns;
15334 ffeinfoKind kind;
15335 ffeinfoWhere where;
15336
15337 ss = ffesymbol_state (sp);
15338
15339 if (ffesymbol_sfdummyparent (sp) != NULL)
15340 { /* Have symbol in sfunc name space. */
15341 switch (ss)
15342 {
15343 case FFESYMBOL_stateNONE: /* Used as iterator already. */
15344 if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
15345 ffesymbol_error (sp, t); /* Can't use dead iterator. */
15346 else
15347 { /* Can use dead iterator because we're at at
15348 least an innermore (higher-numbered) level
15349 than the iterator's outermost
15350 (lowest-numbered) level. */
15351 ffesymbol_signal_change (sp);
15352 ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
15353 ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
15354 ffesymbol_signal_unreported (sp);
15355 }
15356 break;
15357
15358 case FFESYMBOL_stateSEEN: /* Seen already in this or other
15359 implied-DO. Set symbol level
15360 number to outermost value, as that
15361 tells us we can see it as iterator
15362 at that level at the innermost. */
15363 if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
15364 {
15365 ffesymbol_signal_change (sp);
15366 ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
15367 ffesymbol_signal_unreported (sp);
15368 }
15369 break;
15370
15371 case FFESYMBOL_stateUNCERTAIN: /* Iterator. */
15372 assert (ffeexpr_level_ == ffesymbol_maxentrynum (sp));
15373 ffesymbol_error (sp, t); /* (,,,I=I,10). */
15374 break;
15375
15376 case FFESYMBOL_stateUNDERSTOOD:
15377 break; /* ANY. */
15378
15379 default:
15380 assert ("Foo Bar!!" == NULL);
15381 break;
15382 }
15383
15384 return sp;
15385 }
15386
15387 /* Got symbol in local name space, so we haven't seen it in impdo yet.
15388 First, if it is brand-new and we're in executable statements, set the
15389 attributes and exec-transition it to set state UNCERTAIN or UNDERSTOOD.
15390 Second, if it is now a constant (PARAMETER), then just return it, it
15391 can't be an implied-do iterator. If it is understood, complain if it is
15392 not a valid variable, but make the inner name space iterator anyway and
15393 return that. If it is not understood, improve understanding of the
15394 symbol accordingly, complain accordingly, in either case make the inner
15395 name space iterator and return that. */
15396
15397 sa = ffesymbol_attrs (sp);
15398
15399 if (ffesymbol_state_is_specable (ss)
15400 && ffest_seen_first_exec ())
15401 {
15402 assert (sa == FFESYMBOL_attrsetNONE);
15403 ffesymbol_signal_change (sp);
15404 ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
15405 ffesymbol_resolve_intrin (sp);
15406 if (ffeimplic_establish_symbol (sp))
15407 ffesymbol_set_attr (sp, FFESYMBOL_attrSFARG);
15408 else
15409 ffesymbol_error (sp, t);
15410
15411 /* After the exec transition, the state will either be UNCERTAIN (could
15412 be a dummy or local var) or UNDERSTOOD (local var, because this is a
15413 PROGRAM/BLOCKDATA program unit). */
15414
15415 sp = ffecom_sym_exec_transition (sp);
15416 sa = ffesymbol_attrs (sp);
15417 ss = ffesymbol_state (sp);
15418 }
15419
15420 ns = ss;
15421 kind = ffesymbol_kind (sp);
15422 where = ffesymbol_where (sp);
15423
15424 if (ss == FFESYMBOL_stateUNDERSTOOD)
15425 {
15426 if (kind != FFEINFO_kindENTITY)
15427 ffesymbol_error (sp, t);
15428 if (where == FFEINFO_whereCONSTANT)
15429 return sp;
15430 }
15431 else
15432 {
15433 /* Enhance understanding of local symbol. This used to imply exec
15434 transition, but that doesn't seem necessary, since the local symbol
15435 doesn't actually get put into an ffebld tree here -- we just learn
15436 more about it, just like when we see a local symbol's name in the
15437 dummy-arg list of a statement function. */
15438
15439 if (ss != FFESYMBOL_stateUNCERTAIN)
15440 {
15441 /* Figure out what kind of object we've got based on previous
15442 declarations of or references to the object. */
15443
15444 ns = FFESYMBOL_stateSEEN;
15445
15446 if (sa & FFESYMBOL_attrsANY)
15447 na = sa;
15448 else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
15449 | FFESYMBOL_attrsANY
15450 | FFESYMBOL_attrsCOMMON
15451 | FFESYMBOL_attrsDUMMY
15452 | FFESYMBOL_attrsEQUIV
15453 | FFESYMBOL_attrsINIT
15454 | FFESYMBOL_attrsNAMELIST
15455 | FFESYMBOL_attrsRESULT
15456 | FFESYMBOL_attrsSAVE
15457 | FFESYMBOL_attrsSFARG
15458 | FFESYMBOL_attrsTYPE)))
15459 na = sa | FFESYMBOL_attrsSFARG;
15460 else
15461 na = FFESYMBOL_attrsetNONE;
15462 }
15463 else
15464 { /* stateUNCERTAIN. */
15465 na = sa | FFESYMBOL_attrsSFARG;
15466 ns = FFESYMBOL_stateUNDERSTOOD;
15467
15468 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15469 | FFESYMBOL_attrsADJUSTABLE
15470 | FFESYMBOL_attrsANYLEN
15471 | FFESYMBOL_attrsARRAY
15472 | FFESYMBOL_attrsDUMMY
15473 | FFESYMBOL_attrsEXTERNAL
15474 | FFESYMBOL_attrsSFARG
15475 | FFESYMBOL_attrsTYPE)));
15476
15477 if (sa & FFESYMBOL_attrsEXTERNAL)
15478 {
15479 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15480 | FFESYMBOL_attrsDUMMY
15481 | FFESYMBOL_attrsEXTERNAL
15482 | FFESYMBOL_attrsTYPE)));
15483
15484 na = FFESYMBOL_attrsetNONE;
15485 }
15486 else if (sa & FFESYMBOL_attrsDUMMY)
15487 {
15488 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
15489 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
15490 | FFESYMBOL_attrsEXTERNAL
15491 | FFESYMBOL_attrsTYPE)));
15492
15493 kind = FFEINFO_kindENTITY;
15494 }
15495 else if (sa & FFESYMBOL_attrsARRAY)
15496 {
15497 assert (!(sa & ~(FFESYMBOL_attrsARRAY
15498 | FFESYMBOL_attrsADJUSTABLE
15499 | FFESYMBOL_attrsTYPE)));
15500
15501 na = FFESYMBOL_attrsetNONE;
15502 }
15503 else if (sa & FFESYMBOL_attrsSFARG)
15504 {
15505 assert (!(sa & ~(FFESYMBOL_attrsSFARG
15506 | FFESYMBOL_attrsTYPE)));
15507
15508 ns = FFESYMBOL_stateUNCERTAIN;
15509 }
15510 else if (sa & FFESYMBOL_attrsTYPE)
15511 {
15512 assert (!(sa & (FFESYMBOL_attrsARRAY
15513 | FFESYMBOL_attrsDUMMY
15514 | FFESYMBOL_attrsEXTERNAL
15515 | FFESYMBOL_attrsSFARG))); /* Handled above. */
15516 assert (!(sa & ~(FFESYMBOL_attrsTYPE
15517 | FFESYMBOL_attrsADJUSTABLE
15518 | FFESYMBOL_attrsANYLEN
15519 | FFESYMBOL_attrsARRAY
15520 | FFESYMBOL_attrsDUMMY
15521 | FFESYMBOL_attrsEXTERNAL
15522 | FFESYMBOL_attrsSFARG)));
15523
15524 kind = FFEINFO_kindENTITY;
15525
15526 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
15527 na = FFESYMBOL_attrsetNONE;
15528 else if (ffest_is_entry_valid ())
15529 ns = FFESYMBOL_stateUNCERTAIN; /* Could be DUMMY or LOCAL. */
15530 else
15531 where = FFEINFO_whereLOCAL;
15532 }
15533 else
15534 na = FFESYMBOL_attrsetNONE; /* Error. */
15535 }
15536
15537 /* Now see what we've got for a new object: NONE means a new error
15538 cropped up; ANY means an old error to be ignored; otherwise,
15539 everything's ok, update the object (symbol) and continue on. */
15540
15541 if (na == FFESYMBOL_attrsetNONE)
15542 ffesymbol_error (sp, t);
15543 else if (!(na & FFESYMBOL_attrsANY))
15544 {
15545 ffesymbol_signal_change (sp); /* May need to back up to previous
15546 version. */
15547 if (!ffeimplic_establish_symbol (sp))
15548 ffesymbol_error (sp, t);
15549 else
15550 {
15551 ffesymbol_set_info (sp,
15552 ffeinfo_new (ffesymbol_basictype (sp),
15553 ffesymbol_kindtype (sp),
15554 ffesymbol_rank (sp),
15555 kind,
15556 where,
15557 ffesymbol_size (sp)));
15558 ffesymbol_set_attrs (sp, na);
15559 ffesymbol_set_state (sp, ns);
15560 ffesymbol_resolve_intrin (sp);
15561 if (!ffesymbol_state_is_specable (ns))
15562 sp = ffecom_sym_learned (sp);
15563 ffesymbol_signal_unreported (sp); /* For debugging purposes. */
15564 }
15565 }
15566 }
15567
15568 /* Here we create the sfunc-name-space symbol representing what should
15569 become an iterator in this name space at this or an outermore (lower-
15570 numbered) expression level, else the implied-DO construct is in error. */
15571
15572 s = ffesymbol_declare_sfdummy (t); /* Sets maxentrynum to 0 for new obj;
15573 also sets sfa_dummy_parent to
15574 parent symbol. */
15575 assert (sp == ffesymbol_sfdummyparent (s));
15576
15577 ffesymbol_signal_change (s);
15578 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
15579 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
15580 ffesymbol_set_info (s,
15581 ffeinfo_new (FFEINFO_basictypeINTEGER,
15582 FFEINFO_kindtypeINTEGERDEFAULT,
15583 0,
15584 FFEINFO_kindENTITY,
15585 FFEINFO_whereIMMEDIATE,
15586 FFETARGET_charactersizeNONE));
15587 ffesymbol_signal_unreported (s);
15588
15589 if ((ffesymbol_basictype (sp) != FFEINFO_basictypeINTEGER)
15590 && (ffesymbol_basictype (sp) != FFEINFO_basictypeANY))
15591 ffesymbol_error (s, t);
15592
15593 return s;
15594 }
15595
15596 /* Have FOO in CALL FOO. Local name space, executable context only. */
15597
15598 static ffesymbol
15599 ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t)
15600 {
15601 ffesymbolAttrs sa;
15602 ffesymbolAttrs na;
15603 ffeinfoKind kind;
15604 ffeinfoWhere where;
15605 ffeintrinGen gen;
15606 ffeintrinSpec spec;
15607 ffeintrinImp imp;
15608 bool error = FALSE;
15609
15610 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
15611 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
15612
15613 na = sa = ffesymbol_attrs (s);
15614
15615 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15616 | FFESYMBOL_attrsADJUSTABLE
15617 | FFESYMBOL_attrsANYLEN
15618 | FFESYMBOL_attrsARRAY
15619 | FFESYMBOL_attrsDUMMY
15620 | FFESYMBOL_attrsEXTERNAL
15621 | FFESYMBOL_attrsSFARG
15622 | FFESYMBOL_attrsTYPE)));
15623
15624 kind = ffesymbol_kind (s);
15625 where = ffesymbol_where (s);
15626
15627 /* Figure out what kind of object we've got based on previous declarations
15628 of or references to the object. */
15629
15630 if (sa & FFESYMBOL_attrsEXTERNAL)
15631 {
15632 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15633 | FFESYMBOL_attrsDUMMY
15634 | FFESYMBOL_attrsEXTERNAL
15635 | FFESYMBOL_attrsTYPE)));
15636
15637 if (sa & FFESYMBOL_attrsTYPE)
15638 error = TRUE;
15639 else
15640 /* Not TYPE. */
15641 {
15642 kind = FFEINFO_kindSUBROUTINE;
15643
15644 if (sa & FFESYMBOL_attrsDUMMY)
15645 ; /* Not TYPE. */
15646 else if (sa & FFESYMBOL_attrsACTUALARG)
15647 ; /* Not DUMMY or TYPE. */
15648 else /* Not ACTUALARG, DUMMY, or TYPE. */
15649 where = FFEINFO_whereGLOBAL;
15650 }
15651 }
15652 else if (sa & FFESYMBOL_attrsDUMMY)
15653 {
15654 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
15655 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
15656 | FFESYMBOL_attrsEXTERNAL
15657 | FFESYMBOL_attrsTYPE)));
15658
15659 if (sa & FFESYMBOL_attrsTYPE)
15660 error = TRUE;
15661 else
15662 kind = FFEINFO_kindSUBROUTINE;
15663 }
15664 else if (sa & FFESYMBOL_attrsARRAY)
15665 {
15666 assert (!(sa & ~(FFESYMBOL_attrsARRAY
15667 | FFESYMBOL_attrsADJUSTABLE
15668 | FFESYMBOL_attrsTYPE)));
15669
15670 error = TRUE;
15671 }
15672 else if (sa & FFESYMBOL_attrsSFARG)
15673 {
15674 assert (!(sa & ~(FFESYMBOL_attrsSFARG
15675 | FFESYMBOL_attrsTYPE)));
15676
15677 error = TRUE;
15678 }
15679 else if (sa & FFESYMBOL_attrsTYPE)
15680 {
15681 assert (!(sa & (FFESYMBOL_attrsARRAY
15682 | FFESYMBOL_attrsDUMMY
15683 | FFESYMBOL_attrsEXTERNAL
15684 | FFESYMBOL_attrsSFARG))); /* Handled above. */
15685 assert (!(sa & ~(FFESYMBOL_attrsTYPE
15686 | FFESYMBOL_attrsADJUSTABLE
15687 | FFESYMBOL_attrsANYLEN
15688 | FFESYMBOL_attrsARRAY
15689 | FFESYMBOL_attrsDUMMY
15690 | FFESYMBOL_attrsEXTERNAL
15691 | FFESYMBOL_attrsSFARG)));
15692
15693 error = TRUE;
15694 }
15695 else if (sa == FFESYMBOL_attrsetNONE)
15696 {
15697 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
15698
15699 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
15700 &gen, &spec, &imp))
15701 {
15702 ffesymbol_signal_change (s); /* May need to back up to previous
15703 version. */
15704 ffesymbol_set_generic (s, gen);
15705 ffesymbol_set_specific (s, spec);
15706 ffesymbol_set_implementation (s, imp);
15707 ffesymbol_set_info (s,
15708 ffeinfo_new (FFEINFO_basictypeNONE,
15709 FFEINFO_kindtypeNONE,
15710 0,
15711 FFEINFO_kindSUBROUTINE,
15712 FFEINFO_whereINTRINSIC,
15713 FFETARGET_charactersizeNONE));
15714 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
15715 ffesymbol_resolve_intrin (s);
15716 ffesymbol_reference (s, t, FALSE);
15717 s = ffecom_sym_learned (s);
15718 ffesymbol_signal_unreported (s); /* For debugging purposes. */
15719
15720 return s;
15721 }
15722
15723 kind = FFEINFO_kindSUBROUTINE;
15724 where = FFEINFO_whereGLOBAL;
15725 }
15726 else
15727 error = TRUE;
15728
15729 /* Now see what we've got for a new object: NONE means a new error cropped
15730 up; ANY means an old error to be ignored; otherwise, everything's ok,
15731 update the object (symbol) and continue on. */
15732
15733 if (error)
15734 ffesymbol_error (s, t);
15735 else if (!(na & FFESYMBOL_attrsANY))
15736 {
15737 ffesymbol_signal_change (s); /* May need to back up to previous
15738 version. */
15739 ffesymbol_set_info (s,
15740 ffeinfo_new (ffesymbol_basictype (s),
15741 ffesymbol_kindtype (s),
15742 ffesymbol_rank (s),
15743 kind, /* SUBROUTINE. */
15744 where, /* GLOBAL or DUMMY. */
15745 ffesymbol_size (s)));
15746 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
15747 ffesymbol_resolve_intrin (s);
15748 ffesymbol_reference (s, t, FALSE);
15749 s = ffecom_sym_learned (s);
15750 ffesymbol_signal_unreported (s); /* For debugging purposes. */
15751 }
15752
15753 return s;
15754 }
15755
15756 /* Have FOO in DATA FOO/.../. Local name space and executable context
15757 only. (This will change in the future when DATA FOO may be followed
15758 by COMMON FOO or even INTEGER FOO(10), etc.) */
15759
15760 static ffesymbol
15761 ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t)
15762 {
15763 ffesymbolAttrs sa;
15764 ffesymbolAttrs na;
15765 ffeinfoKind kind;
15766 ffeinfoWhere where;
15767 bool error = FALSE;
15768
15769 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
15770 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
15771
15772 na = sa = ffesymbol_attrs (s);
15773
15774 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15775 | FFESYMBOL_attrsADJUSTABLE
15776 | FFESYMBOL_attrsANYLEN
15777 | FFESYMBOL_attrsARRAY
15778 | FFESYMBOL_attrsDUMMY
15779 | FFESYMBOL_attrsEXTERNAL
15780 | FFESYMBOL_attrsSFARG
15781 | FFESYMBOL_attrsTYPE)));
15782
15783 kind = ffesymbol_kind (s);
15784 where = ffesymbol_where (s);
15785
15786 /* Figure out what kind of object we've got based on previous declarations
15787 of or references to the object. */
15788
15789 if (sa & FFESYMBOL_attrsEXTERNAL)
15790 {
15791 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15792 | FFESYMBOL_attrsDUMMY
15793 | FFESYMBOL_attrsEXTERNAL
15794 | FFESYMBOL_attrsTYPE)));
15795
15796 error = TRUE;
15797 }
15798 else if (sa & FFESYMBOL_attrsDUMMY)
15799 {
15800 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
15801 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
15802 | FFESYMBOL_attrsEXTERNAL
15803 | FFESYMBOL_attrsTYPE)));
15804
15805 error = TRUE;
15806 }
15807 else if (sa & FFESYMBOL_attrsARRAY)
15808 {
15809 assert (!(sa & ~(FFESYMBOL_attrsARRAY
15810 | FFESYMBOL_attrsADJUSTABLE
15811 | FFESYMBOL_attrsTYPE)));
15812
15813 if (sa & FFESYMBOL_attrsADJUSTABLE)
15814 error = TRUE;
15815 where = FFEINFO_whereLOCAL;
15816 }
15817 else if (sa & FFESYMBOL_attrsSFARG)
15818 {
15819 assert (!(sa & ~(FFESYMBOL_attrsSFARG
15820 | FFESYMBOL_attrsTYPE)));
15821
15822 where = FFEINFO_whereLOCAL;
15823 }
15824 else if (sa & FFESYMBOL_attrsTYPE)
15825 {
15826 assert (!(sa & (FFESYMBOL_attrsARRAY
15827 | FFESYMBOL_attrsDUMMY
15828 | FFESYMBOL_attrsEXTERNAL
15829 | FFESYMBOL_attrsSFARG))); /* Handled above. */
15830 assert (!(sa & ~(FFESYMBOL_attrsTYPE
15831 | FFESYMBOL_attrsADJUSTABLE
15832 | FFESYMBOL_attrsANYLEN
15833 | FFESYMBOL_attrsARRAY
15834 | FFESYMBOL_attrsDUMMY
15835 | FFESYMBOL_attrsEXTERNAL
15836 | FFESYMBOL_attrsSFARG)));
15837
15838 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
15839 error = TRUE;
15840 else
15841 {
15842 kind = FFEINFO_kindENTITY;
15843 where = FFEINFO_whereLOCAL;
15844 }
15845 }
15846 else if (sa == FFESYMBOL_attrsetNONE)
15847 {
15848 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
15849 kind = FFEINFO_kindENTITY;
15850 where = FFEINFO_whereLOCAL;
15851 }
15852 else
15853 error = TRUE;
15854
15855 /* Now see what we've got for a new object: NONE means a new error cropped
15856 up; ANY means an old error to be ignored; otherwise, everything's ok,
15857 update the object (symbol) and continue on. */
15858
15859 if (error)
15860 ffesymbol_error (s, t);
15861 else if (!(na & FFESYMBOL_attrsANY))
15862 {
15863 ffesymbol_signal_change (s); /* May need to back up to previous
15864 version. */
15865 if (!ffeimplic_establish_symbol (s))
15866 {
15867 ffesymbol_error (s, t);
15868 return s;
15869 }
15870 ffesymbol_set_info (s,
15871 ffeinfo_new (ffesymbol_basictype (s),
15872 ffesymbol_kindtype (s),
15873 ffesymbol_rank (s),
15874 kind, /* ENTITY. */
15875 where, /* LOCAL. */
15876 ffesymbol_size (s)));
15877 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
15878 ffesymbol_resolve_intrin (s);
15879 s = ffecom_sym_learned (s);
15880 ffesymbol_signal_unreported (s); /* For debugging purposes. */
15881 }
15882
15883 return s;
15884 }
15885
15886 /* Have FOO in EQUIVALENCE (...,FOO,...). Does not include
15887 EQUIVALENCE (...,BAR(FOO),...). */
15888
15889 static ffesymbol
15890 ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t)
15891 {
15892 ffesymbolAttrs sa;
15893 ffesymbolAttrs na;
15894 ffeinfoKind kind;
15895 ffeinfoWhere where;
15896
15897 na = sa = ffesymbol_attrs (s);
15898 kind = FFEINFO_kindENTITY;
15899 where = ffesymbol_where (s);
15900
15901 /* Figure out what kind of object we've got based on previous declarations
15902 of or references to the object. */
15903
15904 if (!(sa & ~(FFESYMBOL_attrsADJUSTS
15905 | FFESYMBOL_attrsARRAY
15906 | FFESYMBOL_attrsCOMMON
15907 | FFESYMBOL_attrsEQUIV
15908 | FFESYMBOL_attrsINIT
15909 | FFESYMBOL_attrsNAMELIST
15910 | FFESYMBOL_attrsSAVE
15911 | FFESYMBOL_attrsSFARG
15912 | FFESYMBOL_attrsTYPE)))
15913 na = sa | FFESYMBOL_attrsEQUIV;
15914 else
15915 na = FFESYMBOL_attrsetNONE;
15916
15917 /* Don't know why we're bothering to set kind and where in this code, but
15918 added the following to make it complete, in case it's really important.
15919 Generally this is left up to symbol exec transition. */
15920
15921 if (where == FFEINFO_whereNONE)
15922 {
15923 if (na & (FFESYMBOL_attrsADJUSTS
15924 | FFESYMBOL_attrsCOMMON))
15925 where = FFEINFO_whereCOMMON;
15926 else if (na & FFESYMBOL_attrsSAVE)
15927 where = FFEINFO_whereLOCAL;
15928 }
15929
15930 /* Now see what we've got for a new object: NONE means a new error cropped
15931 up; ANY means an old error to be ignored; otherwise, everything's ok,
15932 update the object (symbol) and continue on. */
15933
15934 if (na == FFESYMBOL_attrsetNONE)
15935 ffesymbol_error (s, t);
15936 else if (!(na & FFESYMBOL_attrsANY))
15937 {
15938 ffesymbol_signal_change (s); /* May need to back up to previous
15939 version. */
15940 ffesymbol_set_info (s,
15941 ffeinfo_new (ffesymbol_basictype (s),
15942 ffesymbol_kindtype (s),
15943 ffesymbol_rank (s),
15944 kind, /* Always ENTITY. */
15945 where, /* NONE, COMMON, or LOCAL. */
15946 ffesymbol_size (s)));
15947 ffesymbol_set_attrs (s, na);
15948 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
15949 ffesymbol_resolve_intrin (s);
15950 ffesymbol_signal_unreported (s); /* For debugging purposes. */
15951 }
15952
15953 return s;
15954 }
15955
15956 /* Have FOO in OPEN(...,USEROPEN=FOO,...). Executable context only.
15957
15958 Note that I think this should be considered semantically similar to
15959 doing CALL XYZ(FOO), in that it should be considered like an
15960 ACTUALARG context. In particular, without EXTERNAL being specified,
15961 it should not be allowed. */
15962
15963 static ffesymbol
15964 ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t)
15965 {
15966 ffesymbolAttrs sa;
15967 ffesymbolAttrs na;
15968 ffeinfoKind kind;
15969 ffeinfoWhere where;
15970 bool needs_type = FALSE;
15971 bool error = FALSE;
15972
15973 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
15974 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
15975
15976 na = sa = ffesymbol_attrs (s);
15977
15978 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15979 | FFESYMBOL_attrsADJUSTABLE
15980 | FFESYMBOL_attrsANYLEN
15981 | FFESYMBOL_attrsARRAY
15982 | FFESYMBOL_attrsDUMMY
15983 | FFESYMBOL_attrsEXTERNAL
15984 | FFESYMBOL_attrsSFARG
15985 | FFESYMBOL_attrsTYPE)));
15986
15987 kind = ffesymbol_kind (s);
15988 where = ffesymbol_where (s);
15989
15990 /* Figure out what kind of object we've got based on previous declarations
15991 of or references to the object. */
15992
15993 if (sa & FFESYMBOL_attrsEXTERNAL)
15994 {
15995 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15996 | FFESYMBOL_attrsDUMMY
15997 | FFESYMBOL_attrsEXTERNAL
15998 | FFESYMBOL_attrsTYPE)));
15999
16000 if (sa & FFESYMBOL_attrsTYPE)
16001 where = FFEINFO_whereGLOBAL;
16002 else
16003 /* Not TYPE. */
16004 {
16005 kind = FFEINFO_kindFUNCTION;
16006 needs_type = TRUE;
16007
16008 if (sa & FFESYMBOL_attrsDUMMY)
16009 ; /* Not TYPE. */
16010 else if (sa & FFESYMBOL_attrsACTUALARG)
16011 ; /* Not DUMMY or TYPE. */
16012 else /* Not ACTUALARG, DUMMY, or TYPE. */
16013 where = FFEINFO_whereGLOBAL;
16014 }
16015 }
16016 else if (sa & FFESYMBOL_attrsDUMMY)
16017 {
16018 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16019 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16020 | FFESYMBOL_attrsEXTERNAL
16021 | FFESYMBOL_attrsTYPE)));
16022
16023 kind = FFEINFO_kindFUNCTION;
16024 if (!(sa & FFESYMBOL_attrsTYPE))
16025 needs_type = TRUE;
16026 }
16027 else if (sa & FFESYMBOL_attrsARRAY)
16028 {
16029 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16030 | FFESYMBOL_attrsADJUSTABLE
16031 | FFESYMBOL_attrsTYPE)));
16032
16033 error = TRUE;
16034 }
16035 else if (sa & FFESYMBOL_attrsSFARG)
16036 {
16037 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16038 | FFESYMBOL_attrsTYPE)));
16039
16040 error = TRUE;
16041 }
16042 else if (sa & FFESYMBOL_attrsTYPE)
16043 {
16044 assert (!(sa & (FFESYMBOL_attrsARRAY
16045 | FFESYMBOL_attrsDUMMY
16046 | FFESYMBOL_attrsEXTERNAL
16047 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16048 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16049 | FFESYMBOL_attrsADJUSTABLE
16050 | FFESYMBOL_attrsANYLEN
16051 | FFESYMBOL_attrsARRAY
16052 | FFESYMBOL_attrsDUMMY
16053 | FFESYMBOL_attrsEXTERNAL
16054 | FFESYMBOL_attrsSFARG)));
16055
16056 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16057 error = TRUE;
16058 else
16059 {
16060 kind = FFEINFO_kindFUNCTION;
16061 where = FFEINFO_whereGLOBAL;
16062 }
16063 }
16064 else if (sa == FFESYMBOL_attrsetNONE)
16065 {
16066 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16067 kind = FFEINFO_kindFUNCTION;
16068 where = FFEINFO_whereGLOBAL;
16069 needs_type = TRUE;
16070 }
16071 else
16072 error = TRUE;
16073
16074 /* Now see what we've got for a new object: NONE means a new error cropped
16075 up; ANY means an old error to be ignored; otherwise, everything's ok,
16076 update the object (symbol) and continue on. */
16077
16078 if (error)
16079 ffesymbol_error (s, t);
16080 else if (!(na & FFESYMBOL_attrsANY))
16081 {
16082 ffesymbol_signal_change (s); /* May need to back up to previous
16083 version. */
16084 if (needs_type && !ffeimplic_establish_symbol (s))
16085 {
16086 ffesymbol_error (s, t);
16087 return s;
16088 }
16089 if (!ffesymbol_explicitwhere (s))
16090 {
16091 ffebad_start (FFEBAD_NEED_EXTERNAL);
16092 ffebad_here (0, ffelex_token_where_line (t),
16093 ffelex_token_where_column (t));
16094 ffebad_string (ffesymbol_text (s));
16095 ffebad_finish ();
16096 ffesymbol_set_explicitwhere (s, TRUE);
16097 }
16098 ffesymbol_set_info (s,
16099 ffeinfo_new (ffesymbol_basictype (s),
16100 ffesymbol_kindtype (s),
16101 ffesymbol_rank (s),
16102 kind, /* FUNCTION. */
16103 where, /* GLOBAL or DUMMY. */
16104 ffesymbol_size (s)));
16105 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16106 ffesymbol_resolve_intrin (s);
16107 ffesymbol_reference (s, t, FALSE);
16108 s = ffecom_sym_learned (s);
16109 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16110 }
16111
16112 return s;
16113 }
16114
16115 /* Have FOO in DATA (stuff,FOO=1,10)/.../. */
16116
16117 static ffesymbol
16118 ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t)
16119 {
16120 ffesymbolState ss;
16121
16122 /* If the symbol isn't in the sfunc name space, pretend as though we saw a
16123 reference to it already within the imp-DO construct at this level, so as
16124 to get a symbol that is in the sfunc name space. But this is an
16125 erroneous construct, and should be caught elsewhere. */
16126
16127 if (ffesymbol_sfdummyparent (s) == NULL)
16128 {
16129 s = ffeexpr_sym_impdoitem_ (s, t);
16130 if (ffesymbol_sfdummyparent (s) == NULL)
16131 { /* PARAMETER FOO...DATA (A(I),FOO=...). */
16132 ffesymbol_error (s, t);
16133 return s;
16134 }
16135 }
16136
16137 ss = ffesymbol_state (s);
16138
16139 switch (ss)
16140 {
16141 case FFESYMBOL_stateNONE: /* Used as iterator already. */
16142 if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
16143 ffesymbol_error (s, t); /* Can't reuse dead iterator. F90 disallows
16144 this; F77 allows it but it is a stupid
16145 feature. */
16146 else
16147 { /* Can use dead iterator because we're at at
16148 least a innermore (higher-numbered) level
16149 than the iterator's outermost
16150 (lowest-numbered) level. This should be
16151 diagnosed later, because it means an item
16152 in this list didn't reference this
16153 iterator. */
16154 #if 1
16155 ffesymbol_error (s, t); /* For now, complain. */
16156 #else /* Someday will detect all cases where initializer doesn't reference
16157 all applicable iterators, in which case reenable this code. */
16158 ffesymbol_signal_change (s);
16159 ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
16160 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
16161 ffesymbol_signal_unreported (s);
16162 #endif
16163 }
16164 break;
16165
16166 case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO.
16167 If seen in outermore level, can't be an
16168 iterator here, so complain. If not seen
16169 at current level, complain for now,
16170 because that indicates something F90
16171 rejects (though we currently don't detect
16172 all such cases for now). */
16173 if (ffeexpr_level_ <= ffesymbol_maxentrynum (s))
16174 {
16175 ffesymbol_signal_change (s);
16176 ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
16177 ffesymbol_signal_unreported (s);
16178 }
16179 else
16180 ffesymbol_error (s, t);
16181 break;
16182
16183 case FFESYMBOL_stateUNCERTAIN: /* Already iterator! */
16184 assert ("DATA implied-DO control var seen twice!!" == NULL);
16185 ffesymbol_error (s, t);
16186 break;
16187
16188 case FFESYMBOL_stateUNDERSTOOD:
16189 break; /* ANY. */
16190
16191 default:
16192 assert ("Foo Bletch!!" == NULL);
16193 break;
16194 }
16195
16196 return s;
16197 }
16198
16199 /* Have FOO in PARAMETER (FOO=...). */
16200
16201 static ffesymbol
16202 ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t)
16203 {
16204 ffesymbolAttrs sa;
16205
16206 sa = ffesymbol_attrs (s);
16207
16208 /* Figure out what kind of object we've got based on previous declarations
16209 of or references to the object. */
16210
16211 if (sa & ~(FFESYMBOL_attrsANYLEN
16212 | FFESYMBOL_attrsTYPE))
16213 {
16214 if (!(sa & FFESYMBOL_attrsANY))
16215 ffesymbol_error (s, t);
16216 }
16217 else
16218 {
16219 ffesymbol_signal_change (s); /* May need to back up to previous
16220 version. */
16221 if (!ffeimplic_establish_symbol (s))
16222 {
16223 ffesymbol_error (s, t);
16224 return s;
16225 }
16226 ffesymbol_set_info (s,
16227 ffeinfo_new (ffesymbol_basictype (s),
16228 ffesymbol_kindtype (s),
16229 ffesymbol_rank (s),
16230 FFEINFO_kindENTITY,
16231 FFEINFO_whereCONSTANT,
16232 ffesymbol_size (s)));
16233 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16234 ffesymbol_resolve_intrin (s);
16235 s = ffecom_sym_learned (s);
16236 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16237 }
16238
16239 return s;
16240 }
16241
16242 /* Have FOO in CALL XYZ(...,FOO,...). Does not include any other
16243 embedding of FOO, such as CALL XYZ((FOO)) or CALL XYZ(FOO+1). */
16244
16245 static ffesymbol
16246 ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t)
16247 {
16248 ffesymbolAttrs sa;
16249 ffesymbolAttrs na;
16250 ffeinfoKind kind;
16251 ffeinfoWhere where;
16252 ffesymbolState ns;
16253 bool needs_type = FALSE;
16254
16255 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16256 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16257
16258 na = sa = ffesymbol_attrs (s);
16259
16260 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16261 | FFESYMBOL_attrsADJUSTABLE
16262 | FFESYMBOL_attrsANYLEN
16263 | FFESYMBOL_attrsARRAY
16264 | FFESYMBOL_attrsDUMMY
16265 | FFESYMBOL_attrsEXTERNAL
16266 | FFESYMBOL_attrsSFARG
16267 | FFESYMBOL_attrsTYPE)));
16268
16269 kind = ffesymbol_kind (s);
16270 where = ffesymbol_where (s);
16271
16272 /* Figure out what kind of object we've got based on previous declarations
16273 of or references to the object. */
16274
16275 ns = FFESYMBOL_stateUNDERSTOOD;
16276
16277 if (sa & FFESYMBOL_attrsEXTERNAL)
16278 {
16279 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16280 | FFESYMBOL_attrsDUMMY
16281 | FFESYMBOL_attrsEXTERNAL
16282 | FFESYMBOL_attrsTYPE)));
16283
16284 if (sa & FFESYMBOL_attrsTYPE)
16285 where = FFEINFO_whereGLOBAL;
16286 else
16287 /* Not TYPE. */
16288 {
16289 ns = FFESYMBOL_stateUNCERTAIN;
16290
16291 if (sa & FFESYMBOL_attrsDUMMY)
16292 assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */
16293 else if (sa & FFESYMBOL_attrsACTUALARG)
16294 ; /* Not DUMMY or TYPE. */
16295 else
16296 /* Not ACTUALARG, DUMMY, or TYPE. */
16297 {
16298 assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */
16299 na |= FFESYMBOL_attrsACTUALARG;
16300 where = FFEINFO_whereGLOBAL;
16301 }
16302 }
16303 }
16304 else if (sa & FFESYMBOL_attrsDUMMY)
16305 {
16306 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16307 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16308 | FFESYMBOL_attrsEXTERNAL
16309 | FFESYMBOL_attrsTYPE)));
16310
16311 kind = FFEINFO_kindENTITY;
16312 if (!(sa & FFESYMBOL_attrsTYPE))
16313 needs_type = TRUE;
16314 }
16315 else if (sa & FFESYMBOL_attrsARRAY)
16316 {
16317 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16318 | FFESYMBOL_attrsADJUSTABLE
16319 | FFESYMBOL_attrsTYPE)));
16320
16321 where = FFEINFO_whereLOCAL;
16322 }
16323 else if (sa & FFESYMBOL_attrsSFARG)
16324 {
16325 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16326 | FFESYMBOL_attrsTYPE)));
16327
16328 where = FFEINFO_whereLOCAL;
16329 }
16330 else if (sa & FFESYMBOL_attrsTYPE)
16331 {
16332 assert (!(sa & (FFESYMBOL_attrsARRAY
16333 | FFESYMBOL_attrsDUMMY
16334 | FFESYMBOL_attrsEXTERNAL
16335 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16336 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16337 | FFESYMBOL_attrsADJUSTABLE
16338 | FFESYMBOL_attrsANYLEN
16339 | FFESYMBOL_attrsARRAY
16340 | FFESYMBOL_attrsDUMMY
16341 | FFESYMBOL_attrsEXTERNAL
16342 | FFESYMBOL_attrsSFARG)));
16343
16344 if (sa & FFESYMBOL_attrsANYLEN)
16345 ns = FFESYMBOL_stateNONE;
16346 else
16347 {
16348 kind = FFEINFO_kindENTITY;
16349 where = FFEINFO_whereLOCAL;
16350 }
16351 }
16352 else if (sa == FFESYMBOL_attrsetNONE)
16353 {
16354 /* New state is left empty because there isn't any state flag to
16355 set for this case, and it's UNDERSTOOD after all. */
16356 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16357 kind = FFEINFO_kindENTITY;
16358 where = FFEINFO_whereLOCAL;
16359 needs_type = TRUE;
16360 }
16361 else
16362 ns = FFESYMBOL_stateNONE; /* Error. */
16363
16364 /* Now see what we've got for a new object: NONE means a new error cropped
16365 up; ANY means an old error to be ignored; otherwise, everything's ok,
16366 update the object (symbol) and continue on. */
16367
16368 if (ns == FFESYMBOL_stateNONE)
16369 ffesymbol_error (s, t);
16370 else if (!(na & FFESYMBOL_attrsANY))
16371 {
16372 ffesymbol_signal_change (s); /* May need to back up to previous
16373 version. */
16374 if (needs_type && !ffeimplic_establish_symbol (s))
16375 {
16376 ffesymbol_error (s, t);
16377 return s;
16378 }
16379 ffesymbol_set_info (s,
16380 ffeinfo_new (ffesymbol_basictype (s),
16381 ffesymbol_kindtype (s),
16382 ffesymbol_rank (s),
16383 kind,
16384 where,
16385 ffesymbol_size (s)));
16386 ffesymbol_set_attrs (s, na);
16387 ffesymbol_set_state (s, ns);
16388 s = ffecom_sym_learned (s);
16389 ffesymbol_reference (s, t, FALSE);
16390 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16391 }
16392
16393 return s;
16394 }
16395
16396 /* Have FOO in DIMENSION XYZ(FOO) or any array declarator containing
16397 a reference to FOO. */
16398
16399 static ffesymbol
16400 ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t)
16401 {
16402 ffesymbolAttrs sa;
16403 ffesymbolAttrs na;
16404 ffeinfoKind kind;
16405 ffeinfoWhere where;
16406
16407 na = sa = ffesymbol_attrs (s);
16408 kind = FFEINFO_kindENTITY;
16409 where = ffesymbol_where (s);
16410
16411 /* Figure out what kind of object we've got based on previous declarations
16412 of or references to the object. */
16413
16414 if (!(sa & ~(FFESYMBOL_attrsADJUSTS
16415 | FFESYMBOL_attrsCOMMON
16416 | FFESYMBOL_attrsDUMMY
16417 | FFESYMBOL_attrsEQUIV
16418 | FFESYMBOL_attrsINIT
16419 | FFESYMBOL_attrsNAMELIST
16420 | FFESYMBOL_attrsSFARG
16421 | FFESYMBOL_attrsARRAY
16422 | FFESYMBOL_attrsTYPE)))
16423 na = sa | FFESYMBOL_attrsADJUSTS;
16424 else
16425 na = FFESYMBOL_attrsetNONE;
16426
16427 /* Since this symbol definitely is going into an expression (the
16428 dimension-list for some dummy array, presumably), figure out WHERE if
16429 possible. */
16430
16431 if (where == FFEINFO_whereNONE)
16432 {
16433 if (na & (FFESYMBOL_attrsCOMMON
16434 | FFESYMBOL_attrsEQUIV
16435 | FFESYMBOL_attrsINIT
16436 | FFESYMBOL_attrsNAMELIST))
16437 where = FFEINFO_whereCOMMON;
16438 else if (na & FFESYMBOL_attrsDUMMY)
16439 where = FFEINFO_whereDUMMY;
16440 }
16441
16442 /* Now see what we've got for a new object: NONE means a new error cropped
16443 up; ANY means an old error to be ignored; otherwise, everything's ok,
16444 update the object (symbol) and continue on. */
16445
16446 if (na == FFESYMBOL_attrsetNONE)
16447 ffesymbol_error (s, t);
16448 else if (!(na & FFESYMBOL_attrsANY))
16449 {
16450 ffesymbol_signal_change (s); /* May need to back up to previous
16451 version. */
16452 if (!ffeimplic_establish_symbol (s))
16453 {
16454 ffesymbol_error (s, t);
16455 return s;
16456 }
16457 ffesymbol_set_info (s,
16458 ffeinfo_new (ffesymbol_basictype (s),
16459 ffesymbol_kindtype (s),
16460 ffesymbol_rank (s),
16461 kind, /* Always ENTITY. */
16462 where, /* NONE, COMMON, or DUMMY. */
16463 ffesymbol_size (s)));
16464 ffesymbol_set_attrs (s, na);
16465 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
16466 ffesymbol_resolve_intrin (s);
16467 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16468 }
16469
16470 return s;
16471 }
16472
16473 /* Have FOO in XYZ = ...FOO.... Does not include cases like FOO in
16474 XYZ = BAR(FOO), as such cases are handled elsewhere. */
16475
16476 static ffesymbol
16477 ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t)
16478 {
16479 ffesymbolAttrs sa;
16480 ffesymbolAttrs na;
16481 ffeinfoKind kind;
16482 ffeinfoWhere where;
16483 bool error = FALSE;
16484
16485 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16486 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16487
16488 na = sa = ffesymbol_attrs (s);
16489
16490 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16491 | FFESYMBOL_attrsADJUSTABLE
16492 | FFESYMBOL_attrsANYLEN
16493 | FFESYMBOL_attrsARRAY
16494 | FFESYMBOL_attrsDUMMY
16495 | FFESYMBOL_attrsEXTERNAL
16496 | FFESYMBOL_attrsSFARG
16497 | FFESYMBOL_attrsTYPE)));
16498
16499 kind = ffesymbol_kind (s);
16500 where = ffesymbol_where (s);
16501
16502 /* Figure out what kind of object we've got based on previous declarations
16503 of or references to the object. */
16504
16505 if (sa & FFESYMBOL_attrsEXTERNAL)
16506 {
16507 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16508 | FFESYMBOL_attrsDUMMY
16509 | FFESYMBOL_attrsEXTERNAL
16510 | FFESYMBOL_attrsTYPE)));
16511
16512 error = TRUE;
16513 }
16514 else if (sa & FFESYMBOL_attrsDUMMY)
16515 {
16516 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16517 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16518 | FFESYMBOL_attrsEXTERNAL
16519 | FFESYMBOL_attrsTYPE)));
16520
16521 kind = FFEINFO_kindENTITY;
16522 }
16523 else if (sa & FFESYMBOL_attrsARRAY)
16524 {
16525 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16526 | FFESYMBOL_attrsADJUSTABLE
16527 | FFESYMBOL_attrsTYPE)));
16528
16529 where = FFEINFO_whereLOCAL;
16530 }
16531 else if (sa & FFESYMBOL_attrsSFARG)
16532 {
16533 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16534 | FFESYMBOL_attrsTYPE)));
16535
16536 where = FFEINFO_whereLOCAL;
16537 }
16538 else if (sa & FFESYMBOL_attrsTYPE)
16539 {
16540 assert (!(sa & (FFESYMBOL_attrsARRAY
16541 | FFESYMBOL_attrsDUMMY
16542 | FFESYMBOL_attrsEXTERNAL
16543 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16544 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16545 | FFESYMBOL_attrsADJUSTABLE
16546 | FFESYMBOL_attrsANYLEN
16547 | FFESYMBOL_attrsARRAY
16548 | FFESYMBOL_attrsDUMMY
16549 | FFESYMBOL_attrsEXTERNAL
16550 | FFESYMBOL_attrsSFARG)));
16551
16552 if (sa & FFESYMBOL_attrsANYLEN)
16553 error = TRUE;
16554 else
16555 {
16556 kind = FFEINFO_kindENTITY;
16557 where = FFEINFO_whereLOCAL;
16558 }
16559 }
16560 else if (sa == FFESYMBOL_attrsetNONE)
16561 {
16562 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16563 kind = FFEINFO_kindENTITY;
16564 where = FFEINFO_whereLOCAL;
16565 }
16566 else
16567 error = TRUE;
16568
16569 /* Now see what we've got for a new object: NONE means a new error cropped
16570 up; ANY means an old error to be ignored; otherwise, everything's ok,
16571 update the object (symbol) and continue on. */
16572
16573 if (error)
16574 ffesymbol_error (s, t);
16575 else if (!(na & FFESYMBOL_attrsANY))
16576 {
16577 ffesymbol_signal_change (s); /* May need to back up to previous
16578 version. */
16579 if (!ffeimplic_establish_symbol (s))
16580 {
16581 ffesymbol_error (s, t);
16582 return s;
16583 }
16584 ffesymbol_set_info (s,
16585 ffeinfo_new (ffesymbol_basictype (s),
16586 ffesymbol_kindtype (s),
16587 ffesymbol_rank (s),
16588 kind, /* ENTITY. */
16589 where, /* LOCAL. */
16590 ffesymbol_size (s)));
16591 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16592 ffesymbol_resolve_intrin (s);
16593 s = ffecom_sym_learned (s);
16594 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16595 }
16596
16597 return s;
16598 }
16599
16600 /* ffeexpr_declare_parenthesized_ -- ffesymbol wrapper for NAME(...) operand
16601
16602 ffelexToken t;
16603 bool maybe_intrin;
16604 ffeexprParenType_ paren_type;
16605 ffesymbol s;
16606 s = ffeexpr_declare_parenthesized_ (t, maybe_intrin, &paren_type);
16607
16608 Just like ffesymbol_declare_local, except performs any implicit info
16609 assignment necessary, and it returns the type of the parenthesized list
16610 (list of function args, list of array args, or substring spec). */
16611
16612 static ffesymbol
16613 ffeexpr_declare_parenthesized_ (ffelexToken t, bool maybe_intrin,
16614 ffeexprParenType_ *paren_type)
16615 {
16616 ffesymbol s;
16617 ffesymbolState st; /* Effective state. */
16618 ffeinfoKind k;
16619 bool bad;
16620
16621 if (maybe_intrin && ffesrc_check_symbol ())
16622 { /* Knock off some easy cases. */
16623 switch (ffeexpr_stack_->context)
16624 {
16625 case FFEEXPR_contextSUBROUTINEREF:
16626 case FFEEXPR_contextDATA:
16627 case FFEEXPR_contextDATAIMPDOINDEX_:
16628 case FFEEXPR_contextSFUNCDEF:
16629 case FFEEXPR_contextSFUNCDEFINDEX_:
16630 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16631 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16632 case FFEEXPR_contextLET:
16633 case FFEEXPR_contextPAREN_:
16634 case FFEEXPR_contextACTUALARGEXPR_:
16635 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16636 case FFEEXPR_contextIOLIST:
16637 case FFEEXPR_contextIOLISTDF:
16638 case FFEEXPR_contextDO:
16639 case FFEEXPR_contextDOWHILE:
16640 case FFEEXPR_contextACTUALARG_:
16641 case FFEEXPR_contextCGOTO:
16642 case FFEEXPR_contextIF:
16643 case FFEEXPR_contextARITHIF:
16644 case FFEEXPR_contextFORMAT:
16645 case FFEEXPR_contextSTOP:
16646 case FFEEXPR_contextRETURN:
16647 case FFEEXPR_contextSELECTCASE:
16648 case FFEEXPR_contextCASE:
16649 case FFEEXPR_contextFILEASSOC:
16650 case FFEEXPR_contextFILEINT:
16651 case FFEEXPR_contextFILEDFINT:
16652 case FFEEXPR_contextFILELOG:
16653 case FFEEXPR_contextFILENUM:
16654 case FFEEXPR_contextFILENUMAMBIG:
16655 case FFEEXPR_contextFILECHAR:
16656 case FFEEXPR_contextFILENUMCHAR:
16657 case FFEEXPR_contextFILEDFCHAR:
16658 case FFEEXPR_contextFILEKEY:
16659 case FFEEXPR_contextFILEUNIT:
16660 case FFEEXPR_contextFILEUNIT_DF:
16661 case FFEEXPR_contextFILEUNITAMBIG:
16662 case FFEEXPR_contextFILEFORMAT:
16663 case FFEEXPR_contextFILENAMELIST:
16664 case FFEEXPR_contextFILEVXTCODE:
16665 case FFEEXPR_contextINDEX_:
16666 case FFEEXPR_contextIMPDOITEM_:
16667 case FFEEXPR_contextIMPDOITEMDF_:
16668 case FFEEXPR_contextIMPDOCTRL_:
16669 case FFEEXPR_contextDATAIMPDOCTRL_:
16670 case FFEEXPR_contextCHARACTERSIZE:
16671 case FFEEXPR_contextPARAMETER:
16672 case FFEEXPR_contextDIMLIST:
16673 case FFEEXPR_contextDIMLISTCOMMON:
16674 case FFEEXPR_contextKINDTYPE:
16675 case FFEEXPR_contextINITVAL:
16676 case FFEEXPR_contextEQVINDEX_:
16677 break; /* These could be intrinsic invocations. */
16678
16679 case FFEEXPR_contextAGOTO:
16680 case FFEEXPR_contextFILEFORMATNML:
16681 case FFEEXPR_contextALLOCATE:
16682 case FFEEXPR_contextDEALLOCATE:
16683 case FFEEXPR_contextHEAPSTAT:
16684 case FFEEXPR_contextNULLIFY:
16685 case FFEEXPR_contextINCLUDE:
16686 case FFEEXPR_contextDATAIMPDOITEM_:
16687 case FFEEXPR_contextLOC_:
16688 case FFEEXPR_contextINDEXORACTUALARG_:
16689 case FFEEXPR_contextSFUNCDEFACTUALARG_:
16690 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
16691 case FFEEXPR_contextPARENFILENUM_:
16692 case FFEEXPR_contextPARENFILEUNIT_:
16693 maybe_intrin = FALSE;
16694 break; /* Can't be intrinsic invocation. */
16695
16696 default:
16697 assert ("blah! blah! waaauuggh!" == NULL);
16698 break;
16699 }
16700 }
16701
16702 s = ffesymbol_declare_local (t, maybe_intrin);
16703
16704 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16705 /* Special-case these since they can involve a different concept
16706 of "state" (in the stmtfunc name space). */
16707 {
16708 case FFEEXPR_contextDATAIMPDOINDEX_:
16709 case FFEEXPR_contextDATAIMPDOCTRL_:
16710 if (ffeexpr_context_outer_ (ffeexpr_stack_)
16711 == FFEEXPR_contextDATAIMPDOINDEX_)
16712 s = ffeexpr_sym_impdoitem_ (s, t);
16713 else
16714 if (ffeexpr_stack_->is_rhs)
16715 s = ffeexpr_sym_impdoitem_ (s, t);
16716 else
16717 s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
16718 if (ffesymbol_kind (s) != FFEINFO_kindANY)
16719 ffesymbol_error (s, t);
16720 return s;
16721
16722 default:
16723 break;
16724 }
16725
16726 switch ((ffesymbol_sfdummyparent (s) == NULL)
16727 ? ffesymbol_state (s)
16728 : FFESYMBOL_stateUNDERSTOOD)
16729 {
16730 case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr
16731 context. */
16732 if (!ffest_seen_first_exec ())
16733 goto seen; /* :::::::::::::::::::: */
16734 /* Fall through. */
16735 case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */
16736 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16737 {
16738 case FFEEXPR_contextSUBROUTINEREF:
16739 s = ffeexpr_sym_lhs_call_ (s, t); /* "CALL FOO"=="CALL
16740 FOO(...)". */
16741 break;
16742
16743 case FFEEXPR_contextDATA:
16744 if (ffeexpr_stack_->is_rhs)
16745 s = ffeexpr_sym_rhs_let_ (s, t);
16746 else
16747 s = ffeexpr_sym_lhs_data_ (s, t);
16748 break;
16749
16750 case FFEEXPR_contextDATAIMPDOITEM_:
16751 s = ffeexpr_sym_lhs_data_ (s, t);
16752 break;
16753
16754 case FFEEXPR_contextSFUNCDEF:
16755 case FFEEXPR_contextSFUNCDEFINDEX_:
16756 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16757 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16758 s = ffecom_sym_exec_transition (s);
16759 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16760 goto understood; /* :::::::::::::::::::: */
16761 /* Fall through. */
16762 case FFEEXPR_contextLET:
16763 case FFEEXPR_contextPAREN_:
16764 case FFEEXPR_contextACTUALARGEXPR_:
16765 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16766 case FFEEXPR_contextIOLIST:
16767 case FFEEXPR_contextIOLISTDF:
16768 case FFEEXPR_contextDO:
16769 case FFEEXPR_contextDOWHILE:
16770 case FFEEXPR_contextACTUALARG_:
16771 case FFEEXPR_contextCGOTO:
16772 case FFEEXPR_contextIF:
16773 case FFEEXPR_contextARITHIF:
16774 case FFEEXPR_contextFORMAT:
16775 case FFEEXPR_contextSTOP:
16776 case FFEEXPR_contextRETURN:
16777 case FFEEXPR_contextSELECTCASE:
16778 case FFEEXPR_contextCASE:
16779 case FFEEXPR_contextFILEASSOC:
16780 case FFEEXPR_contextFILEINT:
16781 case FFEEXPR_contextFILEDFINT:
16782 case FFEEXPR_contextFILELOG:
16783 case FFEEXPR_contextFILENUM:
16784 case FFEEXPR_contextFILENUMAMBIG:
16785 case FFEEXPR_contextFILECHAR:
16786 case FFEEXPR_contextFILENUMCHAR:
16787 case FFEEXPR_contextFILEDFCHAR:
16788 case FFEEXPR_contextFILEKEY:
16789 case FFEEXPR_contextFILEUNIT:
16790 case FFEEXPR_contextFILEUNIT_DF:
16791 case FFEEXPR_contextFILEUNITAMBIG:
16792 case FFEEXPR_contextFILEFORMAT:
16793 case FFEEXPR_contextFILENAMELIST:
16794 case FFEEXPR_contextFILEVXTCODE:
16795 case FFEEXPR_contextINDEX_:
16796 case FFEEXPR_contextIMPDOITEM_:
16797 case FFEEXPR_contextIMPDOITEMDF_:
16798 case FFEEXPR_contextIMPDOCTRL_:
16799 case FFEEXPR_contextLOC_:
16800 if (ffeexpr_stack_->is_rhs)
16801 s = ffeexpr_paren_rhs_let_ (s, t);
16802 else
16803 s = ffeexpr_paren_lhs_let_ (s, t);
16804 break;
16805
16806 case FFEEXPR_contextASSIGN:
16807 case FFEEXPR_contextAGOTO:
16808 case FFEEXPR_contextCHARACTERSIZE:
16809 case FFEEXPR_contextEQUIVALENCE:
16810 case FFEEXPR_contextINCLUDE:
16811 case FFEEXPR_contextPARAMETER:
16812 case FFEEXPR_contextDIMLIST:
16813 case FFEEXPR_contextDIMLISTCOMMON:
16814 case FFEEXPR_contextKINDTYPE:
16815 case FFEEXPR_contextINITVAL:
16816 case FFEEXPR_contextEQVINDEX_:
16817 break; /* Will turn into errors below. */
16818
16819 default:
16820 ffesymbol_error (s, t);
16821 break;
16822 }
16823 /* Fall through. */
16824 case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */
16825 understood: /* :::::::::::::::::::: */
16826
16827 /* State might have changed, update it. */
16828 st = ((ffesymbol_sfdummyparent (s) == NULL)
16829 ? ffesymbol_state (s)
16830 : FFESYMBOL_stateUNDERSTOOD);
16831
16832 k = ffesymbol_kind (s);
16833 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16834 {
16835 case FFEEXPR_contextSUBROUTINEREF:
16836 bad = ((k != FFEINFO_kindSUBROUTINE)
16837 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
16838 || (k != FFEINFO_kindNONE)));
16839 break;
16840
16841 case FFEEXPR_contextDATA:
16842 if (ffeexpr_stack_->is_rhs)
16843 bad = (k != FFEINFO_kindENTITY)
16844 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16845 else
16846 bad = (k != FFEINFO_kindENTITY)
16847 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
16848 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
16849 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
16850 break;
16851
16852 case FFEEXPR_contextDATAIMPDOITEM_:
16853 bad = (k != FFEINFO_kindENTITY) || (ffesymbol_rank (s) == 0)
16854 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
16855 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
16856 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
16857 break;
16858
16859 case FFEEXPR_contextSFUNCDEF:
16860 case FFEEXPR_contextSFUNCDEFINDEX_:
16861 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16862 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16863 case FFEEXPR_contextLET:
16864 case FFEEXPR_contextPAREN_:
16865 case FFEEXPR_contextACTUALARGEXPR_:
16866 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16867 case FFEEXPR_contextIOLIST:
16868 case FFEEXPR_contextIOLISTDF:
16869 case FFEEXPR_contextDO:
16870 case FFEEXPR_contextDOWHILE:
16871 case FFEEXPR_contextACTUALARG_:
16872 case FFEEXPR_contextCGOTO:
16873 case FFEEXPR_contextIF:
16874 case FFEEXPR_contextARITHIF:
16875 case FFEEXPR_contextFORMAT:
16876 case FFEEXPR_contextSTOP:
16877 case FFEEXPR_contextRETURN:
16878 case FFEEXPR_contextSELECTCASE:
16879 case FFEEXPR_contextCASE:
16880 case FFEEXPR_contextFILEASSOC:
16881 case FFEEXPR_contextFILEINT:
16882 case FFEEXPR_contextFILEDFINT:
16883 case FFEEXPR_contextFILELOG:
16884 case FFEEXPR_contextFILENUM:
16885 case FFEEXPR_contextFILENUMAMBIG:
16886 case FFEEXPR_contextFILECHAR:
16887 case FFEEXPR_contextFILENUMCHAR:
16888 case FFEEXPR_contextFILEDFCHAR:
16889 case FFEEXPR_contextFILEKEY:
16890 case FFEEXPR_contextFILEUNIT:
16891 case FFEEXPR_contextFILEUNIT_DF:
16892 case FFEEXPR_contextFILEUNITAMBIG:
16893 case FFEEXPR_contextFILEFORMAT:
16894 case FFEEXPR_contextFILENAMELIST:
16895 case FFEEXPR_contextFILEVXTCODE:
16896 case FFEEXPR_contextINDEX_:
16897 case FFEEXPR_contextIMPDOITEM_:
16898 case FFEEXPR_contextIMPDOITEMDF_:
16899 case FFEEXPR_contextIMPDOCTRL_:
16900 case FFEEXPR_contextLOC_:
16901 bad = FALSE; /* Let paren-switch handle the cases. */
16902 break;
16903
16904 case FFEEXPR_contextASSIGN:
16905 case FFEEXPR_contextAGOTO:
16906 case FFEEXPR_contextCHARACTERSIZE:
16907 case FFEEXPR_contextEQUIVALENCE:
16908 case FFEEXPR_contextPARAMETER:
16909 case FFEEXPR_contextDIMLIST:
16910 case FFEEXPR_contextDIMLISTCOMMON:
16911 case FFEEXPR_contextKINDTYPE:
16912 case FFEEXPR_contextINITVAL:
16913 case FFEEXPR_contextEQVINDEX_:
16914 bad = (k != FFEINFO_kindENTITY)
16915 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16916 break;
16917
16918 case FFEEXPR_contextINCLUDE:
16919 bad = TRUE;
16920 break;
16921
16922 default:
16923 bad = TRUE;
16924 break;
16925 }
16926
16927 switch (bad ? FFEINFO_kindANY : k)
16928 {
16929 case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */
16930 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
16931 {
16932 if (ffeexpr_context_outer_ (ffeexpr_stack_)
16933 == FFEEXPR_contextSUBROUTINEREF)
16934 *paren_type = FFEEXPR_parentypeSUBROUTINE_;
16935 else
16936 *paren_type = FFEEXPR_parentypeFUNCTION_;
16937 break;
16938 }
16939 if (st == FFESYMBOL_stateUNDERSTOOD)
16940 {
16941 bad = TRUE;
16942 *paren_type = FFEEXPR_parentypeANY_;
16943 }
16944 else
16945 *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
16946 break;
16947
16948 case FFEINFO_kindFUNCTION:
16949 *paren_type = FFEEXPR_parentypeFUNCTION_;
16950 switch (ffesymbol_where (s))
16951 {
16952 case FFEINFO_whereLOCAL:
16953 bad = TRUE; /* Attempt to recurse! */
16954 break;
16955
16956 case FFEINFO_whereCONSTANT:
16957 bad = ((ffesymbol_sfexpr (s) == NULL)
16958 || (ffebld_op (ffesymbol_sfexpr (s))
16959 == FFEBLD_opANY)); /* Attempt to recurse! */
16960 break;
16961
16962 default:
16963 break;
16964 }
16965 break;
16966
16967 case FFEINFO_kindSUBROUTINE:
16968 if ((ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
16969 || (ffeexpr_stack_->previous != NULL))
16970 {
16971 bad = TRUE;
16972 *paren_type = FFEEXPR_parentypeANY_;
16973 break;
16974 }
16975
16976 *paren_type = FFEEXPR_parentypeSUBROUTINE_;
16977 switch (ffesymbol_where (s))
16978 {
16979 case FFEINFO_whereLOCAL:
16980 case FFEINFO_whereCONSTANT:
16981 bad = TRUE; /* Attempt to recurse! */
16982 break;
16983
16984 default:
16985 break;
16986 }
16987 break;
16988
16989 case FFEINFO_kindENTITY:
16990 if (ffesymbol_rank (s) == 0)
16991 {
16992 if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
16993 *paren_type = FFEEXPR_parentypeSUBSTRING_;
16994 else
16995 {
16996 bad = TRUE;
16997 *paren_type = FFEEXPR_parentypeANY_;
16998 }
16999 }
17000 else
17001 *paren_type = FFEEXPR_parentypeARRAY_;
17002 break;
17003
17004 default:
17005 case FFEINFO_kindANY:
17006 bad = TRUE;
17007 *paren_type = FFEEXPR_parentypeANY_;
17008 break;
17009 }
17010
17011 if (bad)
17012 {
17013 if (k == FFEINFO_kindANY)
17014 ffest_shutdown ();
17015 else
17016 ffesymbol_error (s, t);
17017 }
17018
17019 return s;
17020
17021 case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */
17022 seen: /* :::::::::::::::::::: */
17023 bad = TRUE;
17024 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17025 {
17026 case FFEEXPR_contextPARAMETER:
17027 if (ffeexpr_stack_->is_rhs)
17028 ffesymbol_error (s, t);
17029 else
17030 s = ffeexpr_sym_lhs_parameter_ (s, t);
17031 break;
17032
17033 case FFEEXPR_contextDATA:
17034 s = ffecom_sym_exec_transition (s);
17035 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17036 goto understood; /* :::::::::::::::::::: */
17037 if (ffeexpr_stack_->is_rhs)
17038 ffesymbol_error (s, t);
17039 else
17040 s = ffeexpr_sym_lhs_data_ (s, t);
17041 goto understood; /* :::::::::::::::::::: */
17042
17043 case FFEEXPR_contextDATAIMPDOITEM_:
17044 s = ffecom_sym_exec_transition (s);
17045 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17046 goto understood; /* :::::::::::::::::::: */
17047 s = ffeexpr_sym_lhs_data_ (s, t);
17048 goto understood; /* :::::::::::::::::::: */
17049
17050 case FFEEXPR_contextEQUIVALENCE:
17051 s = ffeexpr_sym_lhs_equivalence_ (s, t);
17052 bad = FALSE;
17053 break;
17054
17055 case FFEEXPR_contextDIMLIST:
17056 s = ffeexpr_sym_rhs_dimlist_ (s, t);
17057 bad = FALSE;
17058 break;
17059
17060 case FFEEXPR_contextCHARACTERSIZE:
17061 case FFEEXPR_contextKINDTYPE:
17062 case FFEEXPR_contextDIMLISTCOMMON:
17063 case FFEEXPR_contextINITVAL:
17064 case FFEEXPR_contextEQVINDEX_:
17065 break;
17066
17067 case FFEEXPR_contextINCLUDE:
17068 break;
17069
17070 case FFEEXPR_contextINDEX_:
17071 case FFEEXPR_contextACTUALARGEXPR_:
17072 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17073 case FFEEXPR_contextSFUNCDEF:
17074 case FFEEXPR_contextSFUNCDEFINDEX_:
17075 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17076 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17077 assert (ffeexpr_stack_->is_rhs);
17078 s = ffecom_sym_exec_transition (s);
17079 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17080 goto understood; /* :::::::::::::::::::: */
17081 s = ffeexpr_paren_rhs_let_ (s, t);
17082 goto understood; /* :::::::::::::::::::: */
17083
17084 default:
17085 break;
17086 }
17087 k = ffesymbol_kind (s);
17088 switch (bad ? FFEINFO_kindANY : k)
17089 {
17090 case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */
17091 *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
17092 break;
17093
17094 case FFEINFO_kindFUNCTION:
17095 *paren_type = FFEEXPR_parentypeFUNCTION_;
17096 switch (ffesymbol_where (s))
17097 {
17098 case FFEINFO_whereLOCAL:
17099 bad = TRUE; /* Attempt to recurse! */
17100 break;
17101
17102 case FFEINFO_whereCONSTANT:
17103 bad = ((ffesymbol_sfexpr (s) == NULL)
17104 || (ffebld_op (ffesymbol_sfexpr (s))
17105 == FFEBLD_opANY)); /* Attempt to recurse! */
17106 break;
17107
17108 default:
17109 break;
17110 }
17111 break;
17112
17113 case FFEINFO_kindSUBROUTINE:
17114 *paren_type = FFEEXPR_parentypeANY_;
17115 bad = TRUE; /* Cannot possibly be in
17116 contextSUBROUTINEREF. */
17117 break;
17118
17119 case FFEINFO_kindENTITY:
17120 if (ffesymbol_rank (s) == 0)
17121 {
17122 if (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE)
17123 *paren_type = FFEEXPR_parentypeEQUIVALENCE_;
17124 else if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
17125 *paren_type = FFEEXPR_parentypeSUBSTRING_;
17126 else
17127 {
17128 bad = TRUE;
17129 *paren_type = FFEEXPR_parentypeANY_;
17130 }
17131 }
17132 else
17133 *paren_type = FFEEXPR_parentypeARRAY_;
17134 break;
17135
17136 default:
17137 case FFEINFO_kindANY:
17138 bad = TRUE;
17139 *paren_type = FFEEXPR_parentypeANY_;
17140 break;
17141 }
17142
17143 if (bad)
17144 {
17145 if (k == FFEINFO_kindANY)
17146 ffest_shutdown ();
17147 else
17148 ffesymbol_error (s, t);
17149 }
17150
17151 return s;
17152
17153 default:
17154 assert ("bad symbol state" == NULL);
17155 return NULL;
17156 }
17157 }
17158
17159 /* Have FOO in XYZ = ...FOO(...).... Executable context only. */
17160
17161 static ffesymbol
17162 ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t)
17163 {
17164 ffesymbolAttrs sa;
17165 ffesymbolAttrs na;
17166 ffeinfoKind kind;
17167 ffeinfoWhere where;
17168 ffeintrinGen gen;
17169 ffeintrinSpec spec;
17170 ffeintrinImp imp;
17171 bool maybe_ambig = FALSE;
17172 bool error = FALSE;
17173
17174 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
17175 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
17176
17177 na = sa = ffesymbol_attrs (s);
17178
17179 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17180 | FFESYMBOL_attrsADJUSTABLE
17181 | FFESYMBOL_attrsANYLEN
17182 | FFESYMBOL_attrsARRAY
17183 | FFESYMBOL_attrsDUMMY
17184 | FFESYMBOL_attrsEXTERNAL
17185 | FFESYMBOL_attrsSFARG
17186 | FFESYMBOL_attrsTYPE)));
17187
17188 kind = ffesymbol_kind (s);
17189 where = ffesymbol_where (s);
17190
17191 /* Figure out what kind of object we've got based on previous declarations
17192 of or references to the object. */
17193
17194 if (sa & FFESYMBOL_attrsEXTERNAL)
17195 {
17196 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17197 | FFESYMBOL_attrsDUMMY
17198 | FFESYMBOL_attrsEXTERNAL
17199 | FFESYMBOL_attrsTYPE)));
17200
17201 if (sa & FFESYMBOL_attrsTYPE)
17202 where = FFEINFO_whereGLOBAL;
17203 else
17204 /* Not TYPE. */
17205 {
17206 kind = FFEINFO_kindFUNCTION;
17207
17208 if (sa & FFESYMBOL_attrsDUMMY)
17209 ; /* Not TYPE. */
17210 else if (sa & FFESYMBOL_attrsACTUALARG)
17211 ; /* Not DUMMY or TYPE. */
17212 else /* Not ACTUALARG, DUMMY, or TYPE. */
17213 where = FFEINFO_whereGLOBAL;
17214 }
17215 }
17216 else if (sa & FFESYMBOL_attrsDUMMY)
17217 {
17218 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
17219 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
17220 | FFESYMBOL_attrsEXTERNAL
17221 | FFESYMBOL_attrsTYPE)));
17222
17223 kind = FFEINFO_kindFUNCTION;
17224 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure; kind
17225 could be ENTITY w/substring ref. */
17226 }
17227 else if (sa & FFESYMBOL_attrsARRAY)
17228 {
17229 assert (!(sa & ~(FFESYMBOL_attrsARRAY
17230 | FFESYMBOL_attrsADJUSTABLE
17231 | FFESYMBOL_attrsTYPE)));
17232
17233 where = FFEINFO_whereLOCAL;
17234 }
17235 else if (sa & FFESYMBOL_attrsSFARG)
17236 {
17237 assert (!(sa & ~(FFESYMBOL_attrsSFARG
17238 | FFESYMBOL_attrsTYPE)));
17239
17240 where = FFEINFO_whereLOCAL; /* Actually an error, but at least we
17241 know it's a local var. */
17242 }
17243 else if (sa & FFESYMBOL_attrsTYPE)
17244 {
17245 assert (!(sa & (FFESYMBOL_attrsARRAY
17246 | FFESYMBOL_attrsDUMMY
17247 | FFESYMBOL_attrsEXTERNAL
17248 | FFESYMBOL_attrsSFARG))); /* Handled above. */
17249 assert (!(sa & ~(FFESYMBOL_attrsTYPE
17250 | FFESYMBOL_attrsADJUSTABLE
17251 | FFESYMBOL_attrsANYLEN
17252 | FFESYMBOL_attrsARRAY
17253 | FFESYMBOL_attrsDUMMY
17254 | FFESYMBOL_attrsEXTERNAL
17255 | FFESYMBOL_attrsSFARG)));
17256
17257 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
17258 &gen, &spec, &imp))
17259 {
17260 if (!(sa & FFESYMBOL_attrsANYLEN)
17261 && (ffeimplic_peek_symbol_type (s, NULL)
17262 == FFEINFO_basictypeCHARACTER))
17263 return s; /* Haven't learned anything yet. */
17264
17265 ffesymbol_signal_change (s); /* May need to back up to previous
17266 version. */
17267 ffesymbol_set_generic (s, gen);
17268 ffesymbol_set_specific (s, spec);
17269 ffesymbol_set_implementation (s, imp);
17270 ffesymbol_set_info (s,
17271 ffeinfo_new (ffesymbol_basictype (s),
17272 ffesymbol_kindtype (s),
17273 0,
17274 FFEINFO_kindFUNCTION,
17275 FFEINFO_whereINTRINSIC,
17276 ffesymbol_size (s)));
17277 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17278 ffesymbol_resolve_intrin (s);
17279 ffesymbol_reference (s, t, FALSE);
17280 s = ffecom_sym_learned (s);
17281 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17282
17283 return s;
17284 }
17285 if (sa & FFESYMBOL_attrsANYLEN)
17286 error = TRUE; /* Error, since the only way we can,
17287 given CHARACTER*(*) FOO, accept
17288 FOO(...) is for FOO to be a dummy
17289 arg or constant, but it can't
17290 become either now. */
17291 else if (sa & FFESYMBOL_attrsADJUSTABLE)
17292 {
17293 kind = FFEINFO_kindENTITY;
17294 where = FFEINFO_whereLOCAL;
17295 }
17296 else
17297 {
17298 kind = FFEINFO_kindFUNCTION;
17299 where = FFEINFO_whereGLOBAL;
17300 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure;
17301 could be ENTITY/LOCAL w/substring ref. */
17302 }
17303 }
17304 else if (sa == FFESYMBOL_attrsetNONE)
17305 {
17306 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
17307
17308 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
17309 &gen, &spec, &imp))
17310 {
17311 if (ffeimplic_peek_symbol_type (s, NULL)
17312 == FFEINFO_basictypeCHARACTER)
17313 return s; /* Haven't learned anything yet. */
17314
17315 ffesymbol_signal_change (s); /* May need to back up to previous
17316 version. */
17317 ffesymbol_set_generic (s, gen);
17318 ffesymbol_set_specific (s, spec);
17319 ffesymbol_set_implementation (s, imp);
17320 ffesymbol_set_info (s,
17321 ffeinfo_new (ffesymbol_basictype (s),
17322 ffesymbol_kindtype (s),
17323 0,
17324 FFEINFO_kindFUNCTION,
17325 FFEINFO_whereINTRINSIC,
17326 ffesymbol_size (s)));
17327 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17328 ffesymbol_resolve_intrin (s);
17329 s = ffecom_sym_learned (s);
17330 ffesymbol_reference (s, t, FALSE);
17331 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17332 return s;
17333 }
17334
17335 kind = FFEINFO_kindFUNCTION;
17336 where = FFEINFO_whereGLOBAL;
17337 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure;
17338 could be ENTITY/LOCAL w/substring ref. */
17339 }
17340 else
17341 error = TRUE;
17342
17343 /* Now see what we've got for a new object: NONE means a new error cropped
17344 up; ANY means an old error to be ignored; otherwise, everything's ok,
17345 update the object (symbol) and continue on. */
17346
17347 if (error)
17348 ffesymbol_error (s, t);
17349 else if (!(na & FFESYMBOL_attrsANY))
17350 {
17351 ffesymbol_signal_change (s); /* May need to back up to previous
17352 version. */
17353 if (!ffeimplic_establish_symbol (s))
17354 {
17355 ffesymbol_error (s, t);
17356 return s;
17357 }
17358 if (maybe_ambig
17359 && (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
17360 return s; /* Still not sure, let caller deal with it
17361 based on (...). */
17362
17363 ffesymbol_set_info (s,
17364 ffeinfo_new (ffesymbol_basictype (s),
17365 ffesymbol_kindtype (s),
17366 ffesymbol_rank (s),
17367 kind,
17368 where,
17369 ffesymbol_size (s)));
17370 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17371 ffesymbol_resolve_intrin (s);
17372 s = ffecom_sym_learned (s);
17373 ffesymbol_reference (s, t, FALSE);
17374 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17375 }
17376
17377 return s;
17378 }
17379
17380 /* ffeexpr_token_arguments_ -- OPEN_PAREN [expr COMMA]...expr
17381
17382 Return a pointer to this function to the lexer (ffelex), which will
17383 invoke it for the next token.
17384
17385 Handle expression (which might be null) and COMMA or CLOSE_PAREN. */
17386
17387 static ffelexHandler
17388 ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr, ffelexToken t)
17389 {
17390 ffeexprExpr_ procedure;
17391 ffebld reduced;
17392 ffeinfo info;
17393 ffeexprContext ctx;
17394 bool check_intrin = FALSE; /* Set TRUE if intrinsic is REAL(Z) or AIMAG(Z). */
17395
17396 procedure = ffeexpr_stack_->exprstack;
17397 info = ffebld_info (procedure->u.operand);
17398
17399 /* Is there an expression to add? If the expression is nil,
17400 it might still be an argument. It is if:
17401
17402 - The current token is comma, or
17403
17404 - The -fugly-comma flag was specified *and* the procedure
17405 being invoked is external.
17406
17407 Otherwise, if neither of the above is the case, just
17408 ignore this (nil) expression. */
17409
17410 if ((expr != NULL)
17411 || (ffelex_token_type (t) == FFELEX_typeCOMMA)
17412 || (ffe_is_ugly_comma ()
17413 && (ffeinfo_where (info) == FFEINFO_whereGLOBAL)))
17414 {
17415 /* This expression, even if nil, is apparently intended as an argument. */
17416
17417 /* Internal procedure (CONTAINS, or statement function)? */
17418
17419 if (ffeinfo_where (info) == FFEINFO_whereCONSTANT)
17420 {
17421 if ((expr == NULL)
17422 && ffebad_start (FFEBAD_NULL_ARGUMENT))
17423 {
17424 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17425 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17426 ffebad_here (1, ffelex_token_where_line (t),
17427 ffelex_token_where_column (t));
17428 ffebad_finish ();
17429 }
17430
17431 if (expr == NULL)
17432 ;
17433 else
17434 {
17435 if (ffeexpr_stack_->next_dummy == NULL)
17436 { /* Report later which was the first extra argument. */
17437 if (ffeexpr_stack_->tokens[1] == NULL)
17438 {
17439 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
17440 ffeexpr_stack_->num_args = 0;
17441 }
17442 ++ffeexpr_stack_->num_args; /* Count # of extra arguments. */
17443 }
17444 else
17445 {
17446 if ((ffeinfo_rank (ffebld_info (expr)) != 0)
17447 && ffebad_start (FFEBAD_ARRAY_AS_SFARG))
17448 {
17449 ffebad_here (0,
17450 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17451 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17452 ffebad_here (1, ffelex_token_where_line (ft),
17453 ffelex_token_where_column (ft));
17454 ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent
17455 (ffebld_symter (ffebld_head
17456 (ffeexpr_stack_->next_dummy)))));
17457 ffebad_finish ();
17458 }
17459 else
17460 {
17461 expr = ffeexpr_convert_expr (expr, ft,
17462 ffebld_head (ffeexpr_stack_->next_dummy),
17463 ffeexpr_stack_->tokens[0],
17464 FFEEXPR_contextLET);
17465 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17466 }
17467 --ffeexpr_stack_->num_args; /* Count down # of args. */
17468 ffeexpr_stack_->next_dummy
17469 = ffebld_trail (ffeexpr_stack_->next_dummy);
17470 }
17471 }
17472 }
17473 else
17474 {
17475 if ((expr == NULL)
17476 && ffe_is_pedantic ()
17477 && ffebad_start (FFEBAD_NULL_ARGUMENT_W))
17478 {
17479 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17480 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17481 ffebad_here (1, ffelex_token_where_line (t),
17482 ffelex_token_where_column (t));
17483 ffebad_finish ();
17484 }
17485 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17486 }
17487 }
17488
17489 switch (ffelex_token_type (t))
17490 {
17491 case FFELEX_typeCOMMA:
17492 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17493 {
17494 case FFEEXPR_contextSFUNCDEF:
17495 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17496 case FFEEXPR_contextSFUNCDEFINDEX_:
17497 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17498 ctx = FFEEXPR_contextSFUNCDEFACTUALARG_;
17499 break;
17500
17501 case FFEEXPR_contextSFUNCDEFACTUALARG_:
17502 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
17503 assert ("bad context" == NULL);
17504 ctx = FFEEXPR_context;
17505 break;
17506
17507 default:
17508 ctx = FFEEXPR_contextACTUALARG_;
17509 break;
17510 }
17511 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
17512 ffeexpr_token_arguments_);
17513
17514 default:
17515 break;
17516 }
17517
17518 if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
17519 && (ffeexpr_stack_->next_dummy != NULL))
17520 { /* Too few arguments. */
17521 if (ffebad_start (FFEBAD_TOO_FEW_ARGUMENTS))
17522 {
17523 char num[10];
17524
17525 sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
17526
17527 ffebad_here (0, ffelex_token_where_line (t),
17528 ffelex_token_where_column (t));
17529 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17530 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17531 ffebad_string (num);
17532 ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent (ffebld_symter
17533 (ffebld_head (ffeexpr_stack_->next_dummy)))));
17534 ffebad_finish ();
17535 }
17536 for (;
17537 ffeexpr_stack_->next_dummy != NULL;
17538 ffeexpr_stack_->next_dummy
17539 = ffebld_trail (ffeexpr_stack_->next_dummy))
17540 {
17541 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0));
17542 ffebld_set_info (expr, ffeinfo_new_any ());
17543 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17544 }
17545 }
17546
17547 if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
17548 && (ffeexpr_stack_->tokens[1] != NULL))
17549 { /* Too many arguments to statement function. */
17550 if (ffebad_start (FFEBAD_TOO_MANY_ARGUMENTS))
17551 {
17552 char num[10];
17553
17554 sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
17555
17556 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
17557 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
17558 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17559 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17560 ffebad_string (num);
17561 ffebad_finish ();
17562 }
17563 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
17564 }
17565 ffebld_end_list (&ffeexpr_stack_->bottom);
17566
17567 if (ffebld_op (procedure->u.operand) == FFEBLD_opANY)
17568 {
17569 reduced = ffebld_new_any ();
17570 ffebld_set_info (reduced, ffeinfo_new_any ());
17571 }
17572 else
17573 {
17574 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
17575 reduced = ffebld_new_funcref (procedure->u.operand,
17576 ffeexpr_stack_->expr);
17577 else
17578 reduced = ffebld_new_subrref (procedure->u.operand,
17579 ffeexpr_stack_->expr);
17580 if (ffebld_symter_generic (procedure->u.operand) != FFEINTRIN_genNONE)
17581 ffeintrin_fulfill_generic (&reduced, &info, ffeexpr_stack_->tokens[0]);
17582 else if (ffebld_symter_specific (procedure->u.operand)
17583 != FFEINTRIN_specNONE)
17584 ffeintrin_fulfill_specific (&reduced, &info, &check_intrin,
17585 ffeexpr_stack_->tokens[0]);
17586 else
17587 ffeexpr_fulfill_call_ (&reduced, ffeexpr_stack_->tokens[0]);
17588
17589 if (ffebld_op (reduced) != FFEBLD_opANY)
17590 ffebld_set_info (reduced,
17591 ffeinfo_new (ffeinfo_basictype (info),
17592 ffeinfo_kindtype (info),
17593 0,
17594 FFEINFO_kindENTITY,
17595 FFEINFO_whereFLEETING,
17596 ffeinfo_size (info)));
17597 else
17598 ffebld_set_info (reduced, ffeinfo_new_any ());
17599 }
17600 if (ffebld_op (reduced) == FFEBLD_opFUNCREF)
17601 reduced = ffeexpr_collapse_funcref (reduced, ffeexpr_stack_->tokens[0]);
17602 ffeexpr_stack_->exprstack = procedure->previous; /* Pops
17603 not-quite-operand off
17604 stack. */
17605 procedure->u.operand = reduced; /* Save the line/column ffewhere
17606 info. */
17607 ffeexpr_exprstack_push_operand_ (procedure); /* Push it back on stack. */
17608 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
17609 {
17610 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
17611 ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FUNC(3)(1:1)".... */
17612
17613 /* If the intrinsic needs checking (is REAL(Z) or AIMAG(Z), where
17614 Z is DOUBLE COMPLEX), and a command-line option doesn't already
17615 establish interpretation, probably complain. */
17616
17617 if (check_intrin
17618 && !ffe_is_90 ()
17619 && !ffe_is_ugly_complex ())
17620 {
17621 /* If the outer expression is REAL(me...), issue diagnostic
17622 only if next token isn't the close-paren for REAL(me). */
17623
17624 if ((ffeexpr_stack_->previous != NULL)
17625 && (ffeexpr_stack_->previous->exprstack != NULL)
17626 && (ffeexpr_stack_->previous->exprstack->type == FFEEXPR_exprtypeOPERAND_)
17627 && ((reduced = ffeexpr_stack_->previous->exprstack->u.operand) != NULL)
17628 && (ffebld_op (reduced) == FFEBLD_opSYMTER)
17629 && (ffebld_symter_implementation (reduced) == FFEINTRIN_impREAL))
17630 return (ffelexHandler) ffeexpr_token_intrincheck_;
17631
17632 /* Diagnose the ambiguity now. */
17633
17634 if (ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
17635 {
17636 ffebad_string (ffeintrin_name_implementation
17637 (ffebld_symter_implementation
17638 (ffebld_left
17639 (ffeexpr_stack_->exprstack->u.operand))));
17640 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
17641 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
17642 ffebad_finish ();
17643 }
17644 }
17645 return (ffelexHandler) ffeexpr_token_substrp_;
17646 }
17647
17648 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
17649 {
17650 ffebad_here (0, ffelex_token_where_line (t),
17651 ffelex_token_where_column (t));
17652 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17653 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17654 ffebad_finish ();
17655 }
17656 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
17657 ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FUNC(3)(1:1)".... */
17658 return
17659 (ffelexHandler) ffeexpr_find_close_paren_ (t,
17660 (ffelexHandler)
17661 ffeexpr_token_substrp_);
17662 }
17663
17664 /* ffeexpr_token_elements_ -- OPEN_PAREN [expr COMMA]...expr
17665
17666 Return a pointer to this array to the lexer (ffelex), which will
17667 invoke it for the next token.
17668
17669 Handle expression and COMMA or CLOSE_PAREN. */
17670
17671 static ffelexHandler
17672 ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, ffelexToken t)
17673 {
17674 ffeexprExpr_ array;
17675 ffebld reduced;
17676 ffeinfo info;
17677 ffeinfoWhere where;
17678 ffetargetIntegerDefault val;
17679 ffetargetIntegerDefault lval = 0;
17680 ffetargetIntegerDefault uval = 0;
17681 ffebld lbound;
17682 ffebld ubound;
17683 bool lcheck;
17684 bool ucheck;
17685
17686 array = ffeexpr_stack_->exprstack;
17687 info = ffebld_info (array->u.operand);
17688
17689 if ((expr == NULL) /* && ((ffeexpr_stack_->rank != 0) ||
17690 (ffelex_token_type(t) ==
17691 FFELEX_typeCOMMA)) */ )
17692 {
17693 if (ffebad_start (FFEBAD_NULL_ELEMENT))
17694 {
17695 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17696 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17697 ffebad_here (1, ffelex_token_where_line (t),
17698 ffelex_token_where_column (t));
17699 ffebad_finish ();
17700 }
17701 if (ffeexpr_stack_->rank < ffeinfo_rank (info))
17702 { /* Don't bother if we're going to complain
17703 later! */
17704 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
17705 ffebld_set_info (expr, ffeinfo_new_any ());
17706 }
17707 }
17708
17709 if (expr == NULL)
17710 ;
17711 else if (ffeinfo_rank (info) == 0)
17712 { /* In EQUIVALENCE context, ffeinfo_rank(info)
17713 may == 0. */
17714 ++ffeexpr_stack_->rank; /* Track anyway, may need for new VXT
17715 feature. */
17716 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17717 }
17718 else
17719 {
17720 ++ffeexpr_stack_->rank;
17721 if (ffeexpr_stack_->rank > ffeinfo_rank (info))
17722 { /* Report later which was the first extra
17723 element. */
17724 if (ffeexpr_stack_->rank == ffeinfo_rank (info) + 1)
17725 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
17726 }
17727 else
17728 {
17729 switch (ffeinfo_where (ffebld_info (expr)))
17730 {
17731 case FFEINFO_whereCONSTANT:
17732 break;
17733
17734 case FFEINFO_whereIMMEDIATE:
17735 ffeexpr_stack_->constant = FALSE;
17736 break;
17737
17738 default:
17739 ffeexpr_stack_->constant = FALSE;
17740 ffeexpr_stack_->immediate = FALSE;
17741 break;
17742 }
17743 if (ffebld_op (expr) == FFEBLD_opCONTER
17744 && ffebld_kindtype (expr) == FFEINFO_kindtypeINTEGERDEFAULT)
17745 {
17746 val = ffebld_constant_integerdefault (ffebld_conter (expr));
17747
17748 lbound = ffebld_left (ffebld_head (ffeexpr_stack_->bound_list));
17749 if (lbound == NULL)
17750 {
17751 lcheck = TRUE;
17752 lval = 1;
17753 }
17754 else if (ffebld_op (lbound) == FFEBLD_opCONTER)
17755 {
17756 lcheck = TRUE;
17757 lval = ffebld_constant_integerdefault (ffebld_conter (lbound));
17758 }
17759 else
17760 lcheck = FALSE;
17761
17762 ubound = ffebld_right (ffebld_head (ffeexpr_stack_->bound_list));
17763 assert (ubound != NULL);
17764 if (ffebld_op (ubound) == FFEBLD_opCONTER)
17765 {
17766 ucheck = TRUE;
17767 uval = ffebld_constant_integerdefault (ffebld_conter (ubound));
17768 }
17769 else
17770 ucheck = FALSE;
17771
17772 if ((lcheck && (val < lval)) || (ucheck && (val > uval)))
17773 {
17774 ffebad_start (FFEBAD_RANGE_ARRAY);
17775 ffebad_here (0, ffelex_token_where_line (ft),
17776 ffelex_token_where_column (ft));
17777 ffebad_finish ();
17778 }
17779 }
17780 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17781 ffeexpr_stack_->bound_list = ffebld_trail (ffeexpr_stack_->bound_list);
17782 }
17783 }
17784
17785 switch (ffelex_token_type (t))
17786 {
17787 case FFELEX_typeCOMMA:
17788 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17789 {
17790 case FFEEXPR_contextDATAIMPDOITEM_:
17791 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
17792 FFEEXPR_contextDATAIMPDOINDEX_,
17793 ffeexpr_token_elements_);
17794
17795 case FFEEXPR_contextEQUIVALENCE:
17796 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
17797 FFEEXPR_contextEQVINDEX_,
17798 ffeexpr_token_elements_);
17799
17800 case FFEEXPR_contextSFUNCDEF:
17801 case FFEEXPR_contextSFUNCDEFINDEX_:
17802 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
17803 FFEEXPR_contextSFUNCDEFINDEX_,
17804 ffeexpr_token_elements_);
17805
17806 case FFEEXPR_contextSFUNCDEFACTUALARG_:
17807 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
17808 assert ("bad context" == NULL);
17809 break;
17810
17811 default:
17812 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
17813 FFEEXPR_contextINDEX_,
17814 ffeexpr_token_elements_);
17815 }
17816
17817 default:
17818 break;
17819 }
17820
17821 if ((ffeexpr_stack_->rank != ffeinfo_rank (info))
17822 && (ffeinfo_rank (info) != 0))
17823 {
17824 char num[10];
17825
17826 if (ffeexpr_stack_->rank < ffeinfo_rank (info))
17827 {
17828 if (ffebad_start (FFEBAD_TOO_FEW_ELEMENTS))
17829 {
17830 sprintf (num, "%d",
17831 (int) (ffeinfo_rank (info) - ffeexpr_stack_->rank));
17832
17833 ffebad_here (0, ffelex_token_where_line (t),
17834 ffelex_token_where_column (t));
17835 ffebad_here (1,
17836 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17837 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17838 ffebad_string (num);
17839 ffebad_finish ();
17840 }
17841 }
17842 else
17843 {
17844 if (ffebad_start (FFEBAD_TOO_MANY_ELEMENTS))
17845 {
17846 sprintf (num, "%d",
17847 (int) (ffeexpr_stack_->rank - ffeinfo_rank (info)));
17848
17849 ffebad_here (0,
17850 ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
17851 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
17852 ffebad_here (1,
17853 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17854 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17855 ffebad_string (num);
17856 ffebad_finish ();
17857 }
17858 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
17859 }
17860 while (ffeexpr_stack_->rank++ < ffeinfo_rank (info))
17861 {
17862 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
17863 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeINTEGER,
17864 FFEINFO_kindtypeINTEGERDEFAULT,
17865 0, FFEINFO_kindENTITY,
17866 FFEINFO_whereCONSTANT,
17867 FFETARGET_charactersizeNONE));
17868 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17869 }
17870 }
17871 ffebld_end_list (&ffeexpr_stack_->bottom);
17872
17873 if (ffebld_op (array->u.operand) == FFEBLD_opANY)
17874 {
17875 reduced = ffebld_new_any ();
17876 ffebld_set_info (reduced, ffeinfo_new_any ());
17877 }
17878 else
17879 {
17880 reduced = ffebld_new_arrayref (array->u.operand, ffeexpr_stack_->expr);
17881 if (ffeexpr_stack_->constant)
17882 where = FFEINFO_whereFLEETING_CADDR;
17883 else if (ffeexpr_stack_->immediate)
17884 where = FFEINFO_whereFLEETING_IADDR;
17885 else
17886 where = FFEINFO_whereFLEETING;
17887 ffebld_set_info (reduced,
17888 ffeinfo_new (ffeinfo_basictype (info),
17889 ffeinfo_kindtype (info),
17890 0,
17891 FFEINFO_kindENTITY,
17892 where,
17893 ffeinfo_size (info)));
17894 reduced = ffeexpr_collapse_arrayref (reduced, ffeexpr_stack_->tokens[0]);
17895 }
17896
17897 ffeexpr_stack_->exprstack = array->previous; /* Pops not-quite-operand off
17898 stack. */
17899 array->u.operand = reduced; /* Save the line/column ffewhere info. */
17900 ffeexpr_exprstack_push_operand_ (array); /* Push it back on stack. */
17901
17902 switch (ffeinfo_basictype (info))
17903 {
17904 case FFEINFO_basictypeCHARACTER:
17905 ffeexpr_is_substr_ok_ = TRUE; /* Everyone likes "FOO(3)(1:1)".... */
17906 break;
17907
17908 case FFEINFO_basictypeNONE:
17909 ffeexpr_is_substr_ok_ = TRUE;
17910 assert (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE);
17911 break;
17912
17913 default:
17914 ffeexpr_is_substr_ok_ = FALSE;
17915 break;
17916 }
17917
17918 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
17919 {
17920 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
17921 return (ffelexHandler) ffeexpr_token_substrp_;
17922 }
17923
17924 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
17925 {
17926 ffebad_here (0, ffelex_token_where_line (t),
17927 ffelex_token_where_column (t));
17928 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17929 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17930 ffebad_finish ();
17931 }
17932 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
17933 return
17934 (ffelexHandler) ffeexpr_find_close_paren_ (t,
17935 (ffelexHandler)
17936 ffeexpr_token_substrp_);
17937 }
17938
17939 /* ffeexpr_token_equivalence_ -- OPEN_PAREN expr
17940
17941 Return a pointer to this array to the lexer (ffelex), which will
17942 invoke it for the next token.
17943
17944 If token is COLON, pass off to _substr_, else init list and pass off
17945 to _elements_. This handles the case "EQUIVALENCE (FOO(expr?", where
17946 ? marks the token, and where FOO's rank/type has not yet been established,
17947 meaning we could be in a list of indices or in a substring
17948 specification. */
17949
17950 static ffelexHandler
17951 ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr, ffelexToken t)
17952 {
17953 if (ffelex_token_type (t) == FFELEX_typeCOLON)
17954 return ffeexpr_token_substring_ (ft, expr, t);
17955
17956 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
17957 return ffeexpr_token_elements_ (ft, expr, t);
17958 }
17959
17960 /* ffeexpr_token_substring_ -- NAME(of kindENTITY) OPEN_PAREN expr
17961
17962 Return a pointer to this function to the lexer (ffelex), which will
17963 invoke it for the next token.
17964
17965 Handle expression (which may be null) and COLON. */
17966
17967 static ffelexHandler
17968 ffeexpr_token_substring_ (ffelexToken ft, ffebld expr, ffelexToken t)
17969 {
17970 ffeexprExpr_ string;
17971 ffeinfo info;
17972 ffetargetIntegerDefault i;
17973 ffeexprContext ctx;
17974 ffetargetCharacterSize size;
17975
17976 string = ffeexpr_stack_->exprstack;
17977 info = ffebld_info (string->u.operand);
17978 size = ffebld_size_max (string->u.operand);
17979
17980 if (ffelex_token_type (t) == FFELEX_typeCOLON)
17981 {
17982 if ((expr != NULL)
17983 && (ffebld_op (expr) == FFEBLD_opCONTER)
17984 && (((i = ffebld_constant_integerdefault (ffebld_conter (expr)))
17985 < 1)
17986 || ((size != FFETARGET_charactersizeNONE) && (i > size))))
17987 {
17988 ffebad_start (FFEBAD_RANGE_SUBSTR);
17989 ffebad_here (0, ffelex_token_where_line (ft),
17990 ffelex_token_where_column (ft));
17991 ffebad_finish ();
17992 }
17993 ffeexpr_stack_->expr = expr;
17994
17995 switch (ffeexpr_stack_->context)
17996 {
17997 case FFEEXPR_contextSFUNCDEF:
17998 case FFEEXPR_contextSFUNCDEFINDEX_:
17999 ctx = FFEEXPR_contextSFUNCDEFINDEX_;
18000 break;
18001
18002 case FFEEXPR_contextSFUNCDEFACTUALARG_:
18003 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18004 assert ("bad context" == NULL);
18005 ctx = FFEEXPR_context;
18006 break;
18007
18008 default:
18009 ctx = FFEEXPR_contextINDEX_;
18010 break;
18011 }
18012
18013 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18014 ffeexpr_token_substring_1_);
18015 }
18016
18017 if (ffest_ffebad_start (FFEBAD_MISSING_COLON_IN_SUBSTR))
18018 {
18019 ffebad_here (0, ffelex_token_where_line (t),
18020 ffelex_token_where_column (t));
18021 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18022 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18023 ffebad_finish ();
18024 }
18025
18026 ffeexpr_stack_->expr = NULL;
18027 return (ffelexHandler) ffeexpr_token_substring_1_ (ft, expr, t);
18028 }
18029
18030 /* ffeexpr_token_substring_1_ -- NAME OPEN_PAREN [expr COMMA]...expr
18031
18032 Return a pointer to this function to the lexer (ffelex), which will
18033 invoke it for the next token.
18034
18035 Handle expression (which might be null) and CLOSE_PAREN. */
18036
18037 static ffelexHandler
18038 ffeexpr_token_substring_1_ (ffelexToken ft, ffebld last, ffelexToken t)
18039 {
18040 ffeexprExpr_ string;
18041 ffebld reduced;
18042 ffebld substrlist;
18043 ffebld first = ffeexpr_stack_->expr;
18044 ffebld strop;
18045 ffeinfo info;
18046 ffeinfoWhere lwh;
18047 ffeinfoWhere rwh;
18048 ffeinfoWhere where;
18049 ffeinfoKindtype first_kt;
18050 ffeinfoKindtype last_kt;
18051 ffetargetIntegerDefault first_val;
18052 ffetargetIntegerDefault last_val;
18053 ffetargetCharacterSize size;
18054 ffetargetCharacterSize strop_size_max;
18055 bool first_known;
18056
18057 string = ffeexpr_stack_->exprstack;
18058 strop = string->u.operand;
18059 info = ffebld_info (strop);
18060
18061 if (first == NULL
18062 || (ffebld_op (first) == FFEBLD_opCONTER
18063 && ffebld_kindtype (first) == FFEINFO_kindtypeINTEGERDEFAULT))
18064 { /* The starting point is known. */
18065 first_val = (first == NULL) ? 1
18066 : ffebld_constant_integerdefault (ffebld_conter (first));
18067 first_known = TRUE;
18068 }
18069 else
18070 { /* Assume start of the entity. */
18071 first_val = 1;
18072 first_known = FALSE;
18073 }
18074
18075 if (last != NULL
18076 && (ffebld_op (last) == FFEBLD_opCONTER
18077 && ffebld_kindtype (last) == FFEINFO_kindtypeINTEGERDEFAULT))
18078 { /* The ending point is known. */
18079 last_val = ffebld_constant_integerdefault (ffebld_conter (last));
18080
18081 if (first_known)
18082 { /* The beginning point is a constant. */
18083 if (first_val <= last_val)
18084 size = last_val - first_val + 1;
18085 else
18086 {
18087 if (0 && ffe_is_90 ())
18088 size = 0;
18089 else
18090 {
18091 size = 1;
18092 ffebad_start (FFEBAD_ZERO_SIZE);
18093 ffebad_here (0, ffelex_token_where_line (ft),
18094 ffelex_token_where_column (ft));
18095 ffebad_finish ();
18096 }
18097 }
18098 }
18099 else
18100 size = FFETARGET_charactersizeNONE;
18101
18102 strop_size_max = ffebld_size_max (strop);
18103
18104 if ((strop_size_max != FFETARGET_charactersizeNONE)
18105 && (last_val > strop_size_max))
18106 { /* Beyond maximum possible end of string. */
18107 ffebad_start (FFEBAD_RANGE_SUBSTR);
18108 ffebad_here (0, ffelex_token_where_line (ft),
18109 ffelex_token_where_column (ft));
18110 ffebad_finish ();
18111 }
18112 }
18113 else
18114 size = FFETARGET_charactersizeNONE; /* The size is not known. */
18115
18116 #if 0 /* Don't do this, or "is size of target
18117 known?" would no longer be easily
18118 answerable. To see if there is a max
18119 size, use ffebld_size_max; to get only the
18120 known size, else NONE, use
18121 ffebld_size_known; use ffebld_size if
18122 values are sure to be the same (not
18123 opSUBSTR or opCONCATENATE or known to have
18124 known length). By getting rid of this
18125 "useful info" stuff, we don't end up
18126 blank-padding the constant in the
18127 assignment "A(I:J)='XYZ'" to the known
18128 length of A. */
18129 if (size == FFETARGET_charactersizeNONE)
18130 size = strop_size_max; /* Assume we use the entire string. */
18131 #endif
18132
18133 substrlist
18134 = ffebld_new_item
18135 (first,
18136 ffebld_new_item
18137 (last,
18138 NULL
18139 )
18140 )
18141 ;
18142
18143 if (first == NULL)
18144 lwh = FFEINFO_whereCONSTANT;
18145 else
18146 lwh = ffeinfo_where (ffebld_info (first));
18147 if (last == NULL)
18148 rwh = FFEINFO_whereCONSTANT;
18149 else
18150 rwh = ffeinfo_where (ffebld_info (last));
18151
18152 switch (lwh)
18153 {
18154 case FFEINFO_whereCONSTANT:
18155 switch (rwh)
18156 {
18157 case FFEINFO_whereCONSTANT:
18158 where = FFEINFO_whereCONSTANT;
18159 break;
18160
18161 case FFEINFO_whereIMMEDIATE:
18162 where = FFEINFO_whereIMMEDIATE;
18163 break;
18164
18165 default:
18166 where = FFEINFO_whereFLEETING;
18167 break;
18168 }
18169 break;
18170
18171 case FFEINFO_whereIMMEDIATE:
18172 switch (rwh)
18173 {
18174 case FFEINFO_whereCONSTANT:
18175 case FFEINFO_whereIMMEDIATE:
18176 where = FFEINFO_whereIMMEDIATE;
18177 break;
18178
18179 default:
18180 where = FFEINFO_whereFLEETING;
18181 break;
18182 }
18183 break;
18184
18185 default:
18186 where = FFEINFO_whereFLEETING;
18187 break;
18188 }
18189
18190 if (first == NULL)
18191 first_kt = FFEINFO_kindtypeINTEGERDEFAULT;
18192 else
18193 first_kt = ffeinfo_kindtype (ffebld_info (first));
18194 if (last == NULL)
18195 last_kt = FFEINFO_kindtypeINTEGERDEFAULT;
18196 else
18197 last_kt = ffeinfo_kindtype (ffebld_info (last));
18198
18199 switch (where)
18200 {
18201 case FFEINFO_whereCONSTANT:
18202 switch (ffeinfo_where (info))
18203 {
18204 case FFEINFO_whereCONSTANT:
18205 break;
18206
18207 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
18208 where = FFEINFO_whereIMMEDIATE;
18209 break;
18210
18211 default:
18212 where = FFEINFO_whereFLEETING_CADDR;
18213 break;
18214 }
18215 break;
18216
18217 case FFEINFO_whereIMMEDIATE:
18218 switch (ffeinfo_where (info))
18219 {
18220 case FFEINFO_whereCONSTANT:
18221 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
18222 break;
18223
18224 default:
18225 where = FFEINFO_whereFLEETING_IADDR;
18226 break;
18227 }
18228 break;
18229
18230 default:
18231 switch (ffeinfo_where (info))
18232 {
18233 case FFEINFO_whereCONSTANT:
18234 where = FFEINFO_whereCONSTANT_SUBOBJECT; /* An F90 concept. */
18235 break;
18236
18237 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
18238 default:
18239 where = FFEINFO_whereFLEETING;
18240 break;
18241 }
18242 break;
18243 }
18244
18245 if (ffebld_op (strop) == FFEBLD_opANY)
18246 {
18247 reduced = ffebld_new_any ();
18248 ffebld_set_info (reduced, ffeinfo_new_any ());
18249 }
18250 else
18251 {
18252 reduced = ffebld_new_substr (strop, substrlist);
18253 ffebld_set_info (reduced, ffeinfo_new
18254 (FFEINFO_basictypeCHARACTER,
18255 ffeinfo_kindtype (info),
18256 0,
18257 FFEINFO_kindENTITY,
18258 where,
18259 size));
18260 reduced = ffeexpr_collapse_substr (reduced, ffeexpr_stack_->tokens[0]);
18261 }
18262
18263 ffeexpr_stack_->exprstack = string->previous; /* Pops not-quite-operand off
18264 stack. */
18265 string->u.operand = reduced; /* Save the line/column ffewhere info. */
18266 ffeexpr_exprstack_push_operand_ (string); /* Push it back on stack. */
18267
18268 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18269 {
18270 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18271 ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FOO(3:5)(1:1)".... */
18272 return (ffelexHandler) ffeexpr_token_substrp_;
18273 }
18274
18275 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
18276 {
18277 ffebad_here (0, ffelex_token_where_line (t),
18278 ffelex_token_where_column (t));
18279 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18280 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18281 ffebad_finish ();
18282 }
18283
18284 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18285 ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FOO(3:5)(1:1)".... */
18286 return
18287 (ffelexHandler) ffeexpr_find_close_paren_ (t,
18288 (ffelexHandler)
18289 ffeexpr_token_substrp_);
18290 }
18291
18292 /* ffeexpr_token_substrp_ -- Rhs <character entity>
18293
18294 Return a pointer to this function to the lexer (ffelex), which will
18295 invoke it for the next token.
18296
18297 If OPEN_PAREN, treat as start of a substring ("(3:4)") construct, and
18298 issue error message if flag (serves as argument) is set. Else, just
18299 forward token to binary_. */
18300
18301 static ffelexHandler
18302 ffeexpr_token_substrp_ (ffelexToken t)
18303 {
18304 ffeexprContext ctx;
18305
18306 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
18307 return (ffelexHandler) ffeexpr_token_binary_ (t);
18308
18309 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
18310
18311 switch (ffeexpr_stack_->context)
18312 {
18313 case FFEEXPR_contextSFUNCDEF:
18314 case FFEEXPR_contextSFUNCDEFINDEX_:
18315 ctx = FFEEXPR_contextSFUNCDEFINDEX_;
18316 break;
18317
18318 case FFEEXPR_contextSFUNCDEFACTUALARG_:
18319 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18320 assert ("bad context" == NULL);
18321 ctx = FFEEXPR_context;
18322 break;
18323
18324 default:
18325 ctx = FFEEXPR_contextINDEX_;
18326 break;
18327 }
18328
18329 if (!ffeexpr_is_substr_ok_)
18330 {
18331 if (ffebad_start (FFEBAD_BAD_SUBSTR))
18332 {
18333 ffebad_here (0, ffelex_token_where_line (t),
18334 ffelex_token_where_column (t));
18335 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
18336 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
18337 ffebad_finish ();
18338 }
18339
18340 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18341 ffeexpr_token_anything_);
18342 }
18343
18344 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18345 ffeexpr_token_substring_);
18346 }
18347
18348 static ffelexHandler
18349 ffeexpr_token_intrincheck_ (ffelexToken t)
18350 {
18351 if ((ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
18352 && ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
18353 {
18354 ffebad_string (ffeintrin_name_implementation
18355 (ffebld_symter_implementation
18356 (ffebld_left
18357 (ffeexpr_stack_->exprstack->u.operand))));
18358 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
18359 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
18360 ffebad_finish ();
18361 }
18362
18363 return (ffelexHandler) ffeexpr_token_substrp_ (t);
18364 }
18365
18366 /* ffeexpr_token_funsubstr_ -- NAME OPEN_PAREN expr
18367
18368 Return a pointer to this function to the lexer (ffelex), which will
18369 invoke it for the next token.
18370
18371 If COLON, do everything we would have done since _parenthesized_ if
18372 we had known NAME represented a kindENTITY instead of a kindFUNCTION.
18373 If not COLON, do likewise for kindFUNCTION instead. */
18374
18375 static ffelexHandler
18376 ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr, ffelexToken t)
18377 {
18378 ffeinfoWhere where;
18379 ffesymbol s;
18380 ffesymbolAttrs sa;
18381 ffebld symter = ffeexpr_stack_->exprstack->u.operand;
18382 bool needs_type;
18383 ffeintrinGen gen;
18384 ffeintrinSpec spec;
18385 ffeintrinImp imp;
18386
18387 s = ffebld_symter (symter);
18388 sa = ffesymbol_attrs (s);
18389 where = ffesymbol_where (s);
18390
18391 /* We get here only if we don't already know enough about FOO when seeing a
18392 FOO(stuff) reference, and FOO might turn out to be a CHARACTER type. If
18393 "stuff" is a substring reference, then FOO is a CHARACTER scalar type.
18394 Else FOO is a function, either intrinsic or external. If intrinsic, it
18395 wouldn't necessarily be CHARACTER type, so unless it has already been
18396 declared DUMMY, it hasn't had its type established yet. It can't be
18397 CHAR*(*) in any case, though it can have an explicit CHAR*n type. */
18398
18399 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
18400 | FFESYMBOL_attrsTYPE)));
18401
18402 needs_type = !(ffesymbol_attrs (s) & FFESYMBOL_attrsDUMMY);
18403
18404 ffesymbol_signal_change (s); /* Probably already done, but in case.... */
18405
18406 if (ffelex_token_type (t) == FFELEX_typeCOLON)
18407 { /* Definitely an ENTITY (char substring). */
18408 if (needs_type && !ffeimplic_establish_symbol (s))
18409 {
18410 ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
18411 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
18412 }
18413
18414 ffesymbol_set_info (s,
18415 ffeinfo_new (ffesymbol_basictype (s),
18416 ffesymbol_kindtype (s),
18417 ffesymbol_rank (s),
18418 FFEINFO_kindENTITY,
18419 (where == FFEINFO_whereNONE)
18420 ? FFEINFO_whereLOCAL
18421 : where,
18422 ffesymbol_size (s)));
18423 ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
18424
18425 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18426 ffesymbol_resolve_intrin (s);
18427 s = ffecom_sym_learned (s);
18428 ffesymbol_signal_unreported (s); /* For debugging purposes. */
18429
18430 ffeexpr_stack_->exprstack->u.operand
18431 = ffeexpr_collapse_symter (symter, ffeexpr_tokens_[0]);
18432
18433 return (ffelexHandler) ffeexpr_token_substring_ (ft, expr, t);
18434 }
18435
18436 /* The "stuff" isn't a substring notation, so we now know the overall
18437 reference is to a function. */
18438
18439 if (ffeintrin_is_intrinsic (ffesymbol_text (s), ffeexpr_stack_->tokens[0],
18440 FALSE, &gen, &spec, &imp))
18441 {
18442 ffebld_symter_set_generic (symter, gen);
18443 ffebld_symter_set_specific (symter, spec);
18444 ffebld_symter_set_implementation (symter, imp);
18445 ffesymbol_set_generic (s, gen);
18446 ffesymbol_set_specific (s, spec);
18447 ffesymbol_set_implementation (s, imp);
18448 ffesymbol_set_info (s,
18449 ffeinfo_new (ffesymbol_basictype (s),
18450 ffesymbol_kindtype (s),
18451 0,
18452 FFEINFO_kindFUNCTION,
18453 FFEINFO_whereINTRINSIC,
18454 ffesymbol_size (s)));
18455 }
18456 else
18457 { /* Not intrinsic, now needs CHAR type. */
18458 if (!ffeimplic_establish_symbol (s))
18459 {
18460 ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
18461 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
18462 }
18463
18464 ffesymbol_set_info (s,
18465 ffeinfo_new (ffesymbol_basictype (s),
18466 ffesymbol_kindtype (s),
18467 ffesymbol_rank (s),
18468 FFEINFO_kindFUNCTION,
18469 (where == FFEINFO_whereNONE)
18470 ? FFEINFO_whereGLOBAL
18471 : where,
18472 ffesymbol_size (s)));
18473 }
18474
18475 ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
18476
18477 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18478 ffesymbol_resolve_intrin (s);
18479 s = ffecom_sym_learned (s);
18480 ffesymbol_reference (s, ffeexpr_stack_->tokens[0], FALSE);
18481 ffesymbol_signal_unreported (s); /* For debugging purposes. */
18482 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
18483 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
18484 }
18485
18486 /* ffeexpr_token_anything_ -- NAME OPEN_PAREN any-expr
18487
18488 Handle basically any expression, looking for CLOSE_PAREN. */
18489
18490 static ffelexHandler
18491 ffeexpr_token_anything_ (ffelexToken ft UNUSED, ffebld expr UNUSED,
18492 ffelexToken t)
18493 {
18494 ffeexprExpr_ e = ffeexpr_stack_->exprstack;
18495
18496 switch (ffelex_token_type (t))
18497 {
18498 case FFELEX_typeCOMMA:
18499 case FFELEX_typeCOLON:
18500 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18501 FFEEXPR_contextACTUALARG_,
18502 ffeexpr_token_anything_);
18503
18504 default:
18505 e->u.operand = ffebld_new_any ();
18506 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
18507 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18508 ffeexpr_is_substr_ok_ = FALSE;
18509 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18510 return (ffelexHandler) ffeexpr_token_substrp_;
18511 return (ffelexHandler) ffeexpr_token_substrp_ (t);
18512 }
18513 }
18514
18515 /* Terminate module. */
18516
18517 void
18518 ffeexpr_terminate_2 (void)
18519 {
18520 assert (ffeexpr_stack_ == NULL);
18521 assert (ffeexpr_level_ == 0);
18522 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org