]> git.ipfire.org Git - thirdparty/gcc.git/blob - gcc/f/expr.c
projects / thirdparty / gcc.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
* com.c (type_for_mode): Add explicit braces to avoid ambiguous `else'.
[thirdparty/gcc.git] / gcc / f / expr.c
1 /* expr.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995-1997 Free Software Foundation, Inc.
3 Contributed by James Craig Burley (burley@gnu.ai.mit.edu).
4
5 This file is part of GNU Fortran.
6
7 GNU Fortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
10 any later version.
11
12 GNU Fortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with GNU Fortran; see the file COPYING. If not, write to
19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
20 02111-1307, USA.
21
22 Related Modules:
23 None.
24
25 Description:
26 Handles syntactic and semantic analysis of Fortran expressions.
27
28 Modifications:
29 */
30
31 /* Include files. */
32
33 #include "proj.h"
34 #include <ctype.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 "target.h"
49 #include "where.h"
50
51 /* Externals defined here. */
52
53
54 /* Simple definitions and enumerations. */
55
56 typedef enum
57 {
58 FFEEXPR_dotdotNONE_,
59 FFEEXPR_dotdotTRUE_,
60 FFEEXPR_dotdotFALSE_,
61 FFEEXPR_dotdotNOT_,
62 FFEEXPR_dotdotAND_,
63 FFEEXPR_dotdotOR_,
64 FFEEXPR_dotdotXOR_,
65 FFEEXPR_dotdotEQV_,
66 FFEEXPR_dotdotNEQV_,
67 FFEEXPR_dotdotLT_,
68 FFEEXPR_dotdotLE_,
69 FFEEXPR_dotdotEQ_,
70 FFEEXPR_dotdotNE_,
71 FFEEXPR_dotdotGT_,
72 FFEEXPR_dotdotGE_,
73 FFEEXPR_dotdot
74 } ffeexprDotdot_;
75
76 typedef enum
77 {
78 FFEEXPR_exprtypeUNKNOWN_,
79 FFEEXPR_exprtypeOPERAND_,
80 FFEEXPR_exprtypeUNARY_,
81 FFEEXPR_exprtypeBINARY_,
82 FFEEXPR_exprtype_
83 } ffeexprExprtype_;
84
85 typedef enum
86 {
87 FFEEXPR_operatorPOWER_,
88 FFEEXPR_operatorMULTIPLY_,
89 FFEEXPR_operatorDIVIDE_,
90 FFEEXPR_operatorADD_,
91 FFEEXPR_operatorSUBTRACT_,
92 FFEEXPR_operatorCONCATENATE_,
93 FFEEXPR_operatorLT_,
94 FFEEXPR_operatorLE_,
95 FFEEXPR_operatorEQ_,
96 FFEEXPR_operatorNE_,
97 FFEEXPR_operatorGT_,
98 FFEEXPR_operatorGE_,
99 FFEEXPR_operatorNOT_,
100 FFEEXPR_operatorAND_,
101 FFEEXPR_operatorOR_,
102 FFEEXPR_operatorXOR_,
103 FFEEXPR_operatorEQV_,
104 FFEEXPR_operatorNEQV_,
105 FFEEXPR_operator_
106 } ffeexprOperator_;
107
108 typedef enum
109 {
110 FFEEXPR_operatorprecedenceHIGHEST_ = 1,
111 FFEEXPR_operatorprecedencePOWER_ = 1,
112 FFEEXPR_operatorprecedenceMULTIPLY_ = 2,
113 FFEEXPR_operatorprecedenceDIVIDE_ = 2,
114 FFEEXPR_operatorprecedenceADD_ = 3,
115 FFEEXPR_operatorprecedenceSUBTRACT_ = 3,
116 FFEEXPR_operatorprecedenceLOWARITH_ = 3,
117 FFEEXPR_operatorprecedenceCONCATENATE_ = 3,
118 FFEEXPR_operatorprecedenceLT_ = 4,
119 FFEEXPR_operatorprecedenceLE_ = 4,
120 FFEEXPR_operatorprecedenceEQ_ = 4,
121 FFEEXPR_operatorprecedenceNE_ = 4,
122 FFEEXPR_operatorprecedenceGT_ = 4,
123 FFEEXPR_operatorprecedenceGE_ = 4,
124 FFEEXPR_operatorprecedenceNOT_ = 5,
125 FFEEXPR_operatorprecedenceAND_ = 6,
126 FFEEXPR_operatorprecedenceOR_ = 7,
127 FFEEXPR_operatorprecedenceXOR_ = 8,
128 FFEEXPR_operatorprecedenceEQV_ = 8,
129 FFEEXPR_operatorprecedenceNEQV_ = 8,
130 FFEEXPR_operatorprecedenceLOWEST_ = 8,
131 FFEEXPR_operatorprecedence_
132 } ffeexprOperatorPrecedence_;
133
134 #define FFEEXPR_operatorassociativityL2R_ TRUE
135 #define FFEEXPR_operatorassociativityR2L_ FALSE
136 #define FFEEXPR_operatorassociativityPOWER_ FFEEXPR_operatorassociativityR2L_
137 #define FFEEXPR_operatorassociativityMULTIPLY_ FFEEXPR_operatorassociativityL2R_
138 #define FFEEXPR_operatorassociativityDIVIDE_ FFEEXPR_operatorassociativityL2R_
139 #define FFEEXPR_operatorassociativityADD_ FFEEXPR_operatorassociativityL2R_
140 #define FFEEXPR_operatorassociativitySUBTRACT_ FFEEXPR_operatorassociativityL2R_
141 #define FFEEXPR_operatorassociativityCONCATENATE_ FFEEXPR_operatorassociativityL2R_
142 #define FFEEXPR_operatorassociativityLT_ FFEEXPR_operatorassociativityL2R_
143 #define FFEEXPR_operatorassociativityLE_ FFEEXPR_operatorassociativityL2R_
144 #define FFEEXPR_operatorassociativityEQ_ FFEEXPR_operatorassociativityL2R_
145 #define FFEEXPR_operatorassociativityNE_ FFEEXPR_operatorassociativityL2R_
146 #define FFEEXPR_operatorassociativityGT_ FFEEXPR_operatorassociativityL2R_
147 #define FFEEXPR_operatorassociativityGE_ FFEEXPR_operatorassociativityL2R_
148 #define FFEEXPR_operatorassociativityNOT_ FFEEXPR_operatorassociativityL2R_
149 #define FFEEXPR_operatorassociativityAND_ FFEEXPR_operatorassociativityL2R_
150 #define FFEEXPR_operatorassociativityOR_ FFEEXPR_operatorassociativityL2R_
151 #define FFEEXPR_operatorassociativityXOR_ FFEEXPR_operatorassociativityL2R_
152 #define FFEEXPR_operatorassociativityEQV_ FFEEXPR_operatorassociativityL2R_
153 #define FFEEXPR_operatorassociativityNEQV_ FFEEXPR_operatorassociativityL2R_
154
155 typedef enum
156 {
157 FFEEXPR_parentypeFUNCTION_,
158 FFEEXPR_parentypeSUBROUTINE_,
159 FFEEXPR_parentypeARRAY_,
160 FFEEXPR_parentypeSUBSTRING_,
161 FFEEXPR_parentypeFUNSUBSTR_,/* Ambig: check for colon after first expr. */
162 FFEEXPR_parentypeEQUIVALENCE_, /* Ambig: ARRAY_ or SUBSTRING_. */
163 FFEEXPR_parentypeANY_, /* Allow basically anything. */
164 FFEEXPR_parentype_
165 } ffeexprParenType_;
166
167 typedef enum
168 {
169 FFEEXPR_percentNONE_,
170 FFEEXPR_percentLOC_,
171 FFEEXPR_percentVAL_,
172 FFEEXPR_percentREF_,
173 FFEEXPR_percentDESCR_,
174 FFEEXPR_percent_
175 } ffeexprPercent_;
176
177 /* Internal typedefs. */
178
179 typedef struct _ffeexpr_expr_ *ffeexprExpr_;
180 typedef bool ffeexprOperatorAssociativity_;
181 typedef struct _ffeexpr_stack_ *ffeexprStack_;
182
183 /* Private include files. */
184
185
186 /* Internal structure definitions. */
187
188 struct _ffeexpr_expr_
189 {
190 ffeexprExpr_ previous;
191 ffelexToken token;
192 ffeexprExprtype_ type;
193 union
194 {
195 struct
196 {
197 ffeexprOperator_ op;
198 ffeexprOperatorPrecedence_ prec;
199 ffeexprOperatorAssociativity_ as;
200 }
201 operator;
202 ffebld operand;
203 }
204 u;
205 };
206
207 struct _ffeexpr_stack_
208 {
209 ffeexprStack_ previous;
210 mallocPool pool;
211 ffeexprContext context;
212 ffeexprCallback callback;
213 ffelexToken first_token;
214 ffeexprExpr_ exprstack;
215 ffelexToken tokens[10]; /* Used in certain cases, like (unary)
216 open-paren. */
217 ffebld expr; /* For first of
218 complex/implied-do/substring/array-elements
219 / actual-args expression. */
220 ffebld bound_list; /* For tracking dimension bounds list of
221 array. */
222 ffebldListBottom bottom; /* For building lists. */
223 ffeinfoRank rank; /* For elements in an array reference. */
224 bool constant; /* TRUE while elements seen so far are
225 constants. */
226 bool immediate; /* TRUE while elements seen so far are
227 immediate/constants. */
228 ffebld next_dummy; /* Next SFUNC dummy arg in arg list. */
229 ffebldListLength num_args; /* Number of dummy args expected in arg list. */
230 bool is_rhs; /* TRUE if rhs context, FALSE otherwise. */
231 ffeexprPercent_ percent; /* Current %FOO keyword. */
232 };
233
234 struct _ffeexpr_find_
235 {
236 ffelexToken t;
237 ffelexHandler after;
238 int level;
239 };
240
241 /* Static objects accessed by functions in this module. */
242
243 static ffeexprStack_ ffeexpr_stack_; /* Expression stack for semantic. */
244 static ffelexToken ffeexpr_tokens_[10]; /* Scratchpad tokens for syntactic. */
245 static ffeexprDotdot_ ffeexpr_current_dotdot_; /* Current .FOO. keyword. */
246 static long ffeexpr_hollerith_count_; /* ffeexpr_token_number_ and caller. */
247 static int ffeexpr_level_; /* Level of DATA implied-DO construct. */
248 static bool ffeexpr_is_substr_ok_; /* If OPEN_PAREN as binary "op" ok. */
249 static struct _ffeexpr_find_ ffeexpr_find_;
250
251 /* Static functions (internal). */
252
253 static ffelexHandler ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr,
254 ffelexToken t);
255 static ffelexHandler ffeexpr_cb_close_paren_ambig_ (ffelexToken ft,
256 ffebld expr,
257 ffelexToken t);
258 static ffelexHandler ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t);
259 static ffelexHandler ffeexpr_cb_close_paren_c_ (ffelexToken ft,
260 ffebld expr, ffelexToken t);
261 static ffelexHandler ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr,
262 ffelexToken t);
263 static ffelexHandler ffeexpr_cb_close_paren_ci_ (ffelexToken ft,
264 ffebld expr, ffelexToken t);
265 static ffelexHandler ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr,
266 ffelexToken t);
267 static ffelexHandler ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr,
268 ffelexToken t);
269 static ffelexHandler ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr,
270 ffelexToken t);
271 static ffelexHandler ffeexpr_cb_comma_i_2_ (ffelexToken ft, ffebld expr,
272 ffelexToken t);
273 static ffelexHandler ffeexpr_cb_comma_i_3_ (ffelexToken ft, ffebld expr,
274 ffelexToken t);
275 static ffelexHandler ffeexpr_cb_comma_i_4_ (ffelexToken ft, ffebld expr,
276 ffelexToken t);
277 static ffelexHandler ffeexpr_cb_comma_i_5_ (ffelexToken t);
278 static ffelexHandler ffeexpr_cb_end_loc_ (ffelexToken ft, ffebld expr,
279 ffelexToken t);
280 static ffelexHandler ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr,
281 ffelexToken t);
282 static ffelexHandler ffeexpr_cb_end_notloc_1_ (ffelexToken t);
283 static ffesymbol ffeexpr_check_impctrl_ (ffesymbol s);
284 static void ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
285 ffebld dovar, ffelexToken dovar_t);
286 static void ffeexpr_update_impdo_ (ffebld expr, ffebld dovar);
287 static void ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar);
288 static ffeexprContext ffeexpr_context_outer_ (ffeexprStack_ s);
289 static ffeexprDotdot_ ffeexpr_dotdot_ (ffelexToken t);
290 static ffeexprExpr_ ffeexpr_expr_new_ (void);
291 static void ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t);
292 static bool ffeexpr_isdigits_ (char *p);
293 static ffelexHandler ffeexpr_token_first_lhs_ (ffelexToken t);
294 static ffelexHandler ffeexpr_token_first_lhs_1_ (ffelexToken t);
295 static ffelexHandler ffeexpr_token_first_rhs_ (ffelexToken t);
296 static ffelexHandler ffeexpr_token_first_rhs_1_ (ffelexToken t);
297 static ffelexHandler ffeexpr_token_first_rhs_2_ (ffelexToken t);
298 static ffelexHandler ffeexpr_token_first_rhs_3_ (ffelexToken t);
299 static ffelexHandler ffeexpr_token_first_rhs_4_ (ffelexToken t);
300 static ffelexHandler ffeexpr_token_first_rhs_5_ (ffelexToken t);
301 static ffelexHandler ffeexpr_token_first_rhs_6_ (ffelexToken t);
302 static ffelexHandler ffeexpr_token_namelist_ (ffelexToken t);
303 static void ffeexpr_expr_kill_ (ffeexprExpr_ e);
304 static void ffeexpr_exprstack_push_ (ffeexprExpr_ e);
305 static void ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e);
306 static void ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e);
307 static void ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e);
308 static void ffeexpr_reduce_ (void);
309 static ffebld ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op,
310 ffeexprExpr_ r);
311 static ffebld ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l,
312 ffeexprExpr_ op, ffeexprExpr_ r);
313 static ffebld ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l,
314 ffeexprExpr_ op, ffeexprExpr_ r);
315 static ffebld ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l,
316 ffeexprExpr_ op, ffeexprExpr_ r);
317 static ffebld ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op,
318 ffeexprExpr_ r);
319 static ffebld ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l,
320 ffeexprExpr_ op, ffeexprExpr_ r);
321 static ffebld ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l,
322 ffeexprExpr_ op, ffeexprExpr_ r);
323 static ffebld ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l,
324 ffeexprExpr_ op, ffeexprExpr_ r);
325 static ffebld ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r);
326 static ffebld ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op,
327 ffeexprExpr_ r);
328 static ffebld ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l,
329 ffeexprExpr_ op, ffeexprExpr_ r);
330 static ffebld ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l,
331 ffeexprExpr_ op, ffeexprExpr_ r);
332 static ffelexHandler ffeexpr_find_close_paren_ (ffelexToken t,
333 ffelexHandler after);
334 static ffelexHandler ffeexpr_nil_finished_ (ffelexToken t);
335 static ffelexHandler ffeexpr_nil_rhs_ (ffelexToken t);
336 static ffelexHandler ffeexpr_nil_period_ (ffelexToken t);
337 static ffelexHandler ffeexpr_nil_end_period_ (ffelexToken t);
338 static ffelexHandler ffeexpr_nil_swallow_period_ (ffelexToken t);
339 static ffelexHandler ffeexpr_nil_real_ (ffelexToken t);
340 static ffelexHandler ffeexpr_nil_real_exponent_ (ffelexToken t);
341 static ffelexHandler ffeexpr_nil_real_exp_sign_ (ffelexToken t);
342 static ffelexHandler ffeexpr_nil_number_ (ffelexToken t);
343 static ffelexHandler ffeexpr_nil_number_exponent_ (ffelexToken t);
344 static ffelexHandler ffeexpr_nil_number_exp_sign_ (ffelexToken t);
345 static ffelexHandler ffeexpr_nil_number_period_ (ffelexToken t);
346 static ffelexHandler ffeexpr_nil_number_per_exp_ (ffelexToken t);
347 static ffelexHandler ffeexpr_nil_number_real_ (ffelexToken t);
348 static ffelexHandler ffeexpr_nil_num_per_exp_sign_ (ffelexToken t);
349 static ffelexHandler ffeexpr_nil_number_real_exp_ (ffelexToken t);
350 static ffelexHandler ffeexpr_nil_num_real_exp_sn_ (ffelexToken t);
351 static ffelexHandler ffeexpr_nil_binary_ (ffelexToken t);
352 static ffelexHandler ffeexpr_nil_binary_period_ (ffelexToken t);
353 static ffelexHandler ffeexpr_nil_binary_end_per_ (ffelexToken t);
354 static ffelexHandler ffeexpr_nil_binary_sw_per_ (ffelexToken t);
355 static ffelexHandler ffeexpr_nil_quote_ (ffelexToken t);
356 static ffelexHandler ffeexpr_nil_apostrophe_ (ffelexToken t);
357 static ffelexHandler ffeexpr_nil_apos_char_ (ffelexToken t);
358 static ffelexHandler ffeexpr_nil_name_rhs_ (ffelexToken t);
359 static ffelexHandler ffeexpr_nil_name_apos_ (ffelexToken t);
360 static ffelexHandler ffeexpr_nil_name_apos_name_ (ffelexToken t);
361 static ffelexHandler ffeexpr_nil_percent_ (ffelexToken t);
362 static ffelexHandler ffeexpr_nil_percent_name_ (ffelexToken t);
363 static ffelexHandler ffeexpr_nil_substrp_ (ffelexToken t);
364 static ffelexHandler ffeexpr_finished_ (ffelexToken t);
365 static ffebld ffeexpr_finished_ambig_ (ffelexToken t, ffebld expr);
366 static ffelexHandler ffeexpr_token_lhs_ (ffelexToken t);
367 static ffelexHandler ffeexpr_token_rhs_ (ffelexToken t);
368 static ffelexHandler ffeexpr_token_binary_ (ffelexToken t);
369 static ffelexHandler ffeexpr_token_period_ (ffelexToken t);
370 static ffelexHandler ffeexpr_token_end_period_ (ffelexToken t);
371 static ffelexHandler ffeexpr_token_swallow_period_ (ffelexToken t);
372 static ffelexHandler ffeexpr_token_real_ (ffelexToken t);
373 static ffelexHandler ffeexpr_token_real_exponent_ (ffelexToken t);
374 static ffelexHandler ffeexpr_token_real_exp_sign_ (ffelexToken t);
375 static ffelexHandler ffeexpr_token_number_ (ffelexToken t);
376 static ffelexHandler ffeexpr_token_number_exponent_ (ffelexToken t);
377 static ffelexHandler ffeexpr_token_number_exp_sign_ (ffelexToken t);
378 static ffelexHandler ffeexpr_token_number_period_ (ffelexToken t);
379 static ffelexHandler ffeexpr_token_number_per_exp_ (ffelexToken t);
380 static ffelexHandler ffeexpr_token_number_real_ (ffelexToken t);
381 static ffelexHandler ffeexpr_token_num_per_exp_sign_ (ffelexToken t);
382 static ffelexHandler ffeexpr_token_number_real_exp_ (ffelexToken t);
383 static ffelexHandler ffeexpr_token_num_real_exp_sn_ (ffelexToken t);
384 static ffelexHandler ffeexpr_token_binary_period_ (ffelexToken t);
385 static ffelexHandler ffeexpr_token_binary_end_per_ (ffelexToken t);
386 static ffelexHandler ffeexpr_token_binary_sw_per_ (ffelexToken t);
387 static ffelexHandler ffeexpr_token_quote_ (ffelexToken t);
388 static ffelexHandler ffeexpr_token_apostrophe_ (ffelexToken t);
389 static ffelexHandler ffeexpr_token_apos_char_ (ffelexToken t);
390 static ffelexHandler ffeexpr_token_name_lhs_ (ffelexToken t);
391 static ffelexHandler ffeexpr_token_name_arg_ (ffelexToken t);
392 static ffelexHandler ffeexpr_token_name_rhs_ (ffelexToken t);
393 static ffelexHandler ffeexpr_token_name_apos_ (ffelexToken t);
394 static ffelexHandler ffeexpr_token_name_apos_name_ (ffelexToken t);
395 static ffelexHandler ffeexpr_token_percent_ (ffelexToken t);
396 static ffelexHandler ffeexpr_token_percent_name_ (ffelexToken t);
397 static ffelexHandler ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr,
398 ffelexToken t);
399 static ffelexHandler ffeexpr_token_elements_ (ffelexToken ft, ffebld expr,
400 ffelexToken t);
401 static ffelexHandler ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr,
402 ffelexToken t);
403 static ffelexHandler ffeexpr_token_substring_ (ffelexToken ft, ffebld expr,
404 ffelexToken t);
405 static ffelexHandler ffeexpr_token_substring_1_ (ffelexToken ft, ffebld expr,
406 ffelexToken t);
407 static ffelexHandler ffeexpr_token_substrp_ (ffelexToken t);
408 static ffelexHandler ffeexpr_token_intrincheck_ (ffelexToken t);
409 static ffelexHandler ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr,
410 ffelexToken t);
411 static ffelexHandler ffeexpr_token_anything_ (ffelexToken ft, ffebld expr,
412 ffelexToken t);
413 static void ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
414 ffelexToken decimal, ffelexToken fraction, ffelexToken exponent,
415 ffelexToken exponent_sign, ffelexToken exponent_digits);
416 static ffesymbol ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin);
417 static ffesymbol ffeexpr_sym_impdoitem_ (ffesymbol s, ffelexToken t);
418 static ffesymbol ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t);
419 static ffesymbol ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t);
420 static ffesymbol ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t);
421 static ffesymbol ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t);
422 static ffesymbol ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t);
423 static ffesymbol ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t);
424 static ffesymbol ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t);
425 static ffesymbol ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t);
426 static ffesymbol ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t);
427 static ffesymbol ffeexpr_declare_parenthesized_ (ffelexToken t,
428 bool maybe_intrin,
429 ffeexprParenType_ *paren_type);
430 static ffesymbol ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t);
431
432 /* Internal macros. */
433
434 #define ffeexpr_paren_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
435 #define ffeexpr_sym_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
436 \f
437 /* ffeexpr_collapse_convert -- Collapse convert expr
438
439 ffebld expr;
440 ffelexToken token;
441 expr = ffeexpr_collapse_convert(expr,token);
442
443 If the result of the expr is a constant, replaces the expr with the
444 computed constant. */
445
446 ffebld
447 ffeexpr_collapse_convert (ffebld expr, ffelexToken t)
448 {
449 ffebad error = FFEBAD;
450 ffebld l;
451 ffebldConstantUnion u;
452 ffeinfoBasictype bt;
453 ffeinfoKindtype kt;
454 ffetargetCharacterSize sz;
455 ffetargetCharacterSize sz2;
456
457 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
458 return expr;
459
460 l = ffebld_left (expr);
461
462 if (ffebld_op (l) != FFEBLD_opCONTER)
463 return expr;
464
465 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
466 {
467 case FFEINFO_basictypeANY:
468 return expr;
469
470 case FFEINFO_basictypeINTEGER:
471 sz = FFETARGET_charactersizeNONE;
472 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
473 {
474 #if FFETARGET_okINTEGER1
475 case FFEINFO_kindtypeINTEGER1:
476 switch (ffeinfo_basictype (ffebld_info (l)))
477 {
478 case FFEINFO_basictypeINTEGER:
479 switch (ffeinfo_kindtype (ffebld_info (l)))
480 {
481 #if FFETARGET_okINTEGER2
482 case FFEINFO_kindtypeINTEGER2:
483 error = ffetarget_convert_integer1_integer2
484 (ffebld_cu_ptr_integer1 (u),
485 ffebld_constant_integer2 (ffebld_conter (l)));
486 break;
487 #endif
488
489 #if FFETARGET_okINTEGER3
490 case FFEINFO_kindtypeINTEGER3:
491 error = ffetarget_convert_integer1_integer3
492 (ffebld_cu_ptr_integer1 (u),
493 ffebld_constant_integer3 (ffebld_conter (l)));
494 break;
495 #endif
496
497 #if FFETARGET_okINTEGER4
498 case FFEINFO_kindtypeINTEGER4:
499 error = ffetarget_convert_integer1_integer4
500 (ffebld_cu_ptr_integer1 (u),
501 ffebld_constant_integer4 (ffebld_conter (l)));
502 break;
503 #endif
504
505 default:
506 assert ("INTEGER1/INTEGER bad source kind type" == NULL);
507 break;
508 }
509 break;
510
511 case FFEINFO_basictypeREAL:
512 switch (ffeinfo_kindtype (ffebld_info (l)))
513 {
514 #if FFETARGET_okREAL1
515 case FFEINFO_kindtypeREAL1:
516 error = ffetarget_convert_integer1_real1
517 (ffebld_cu_ptr_integer1 (u),
518 ffebld_constant_real1 (ffebld_conter (l)));
519 break;
520 #endif
521
522 #if FFETARGET_okREAL2
523 case FFEINFO_kindtypeREAL2:
524 error = ffetarget_convert_integer1_real2
525 (ffebld_cu_ptr_integer1 (u),
526 ffebld_constant_real2 (ffebld_conter (l)));
527 break;
528 #endif
529
530 #if FFETARGET_okREAL3
531 case FFEINFO_kindtypeREAL3:
532 error = ffetarget_convert_integer1_real3
533 (ffebld_cu_ptr_integer1 (u),
534 ffebld_constant_real3 (ffebld_conter (l)));
535 break;
536 #endif
537
538 #if FFETARGET_okREAL4
539 case FFEINFO_kindtypeREAL4:
540 error = ffetarget_convert_integer1_real4
541 (ffebld_cu_ptr_integer1 (u),
542 ffebld_constant_real4 (ffebld_conter (l)));
543 break;
544 #endif
545
546 default:
547 assert ("INTEGER1/REAL bad source kind type" == NULL);
548 break;
549 }
550 break;
551
552 case FFEINFO_basictypeCOMPLEX:
553 switch (ffeinfo_kindtype (ffebld_info (l)))
554 {
555 #if FFETARGET_okCOMPLEX1
556 case FFEINFO_kindtypeREAL1:
557 error = ffetarget_convert_integer1_complex1
558 (ffebld_cu_ptr_integer1 (u),
559 ffebld_constant_complex1 (ffebld_conter (l)));
560 break;
561 #endif
562
563 #if FFETARGET_okCOMPLEX2
564 case FFEINFO_kindtypeREAL2:
565 error = ffetarget_convert_integer1_complex2
566 (ffebld_cu_ptr_integer1 (u),
567 ffebld_constant_complex2 (ffebld_conter (l)));
568 break;
569 #endif
570
571 #if FFETARGET_okCOMPLEX3
572 case FFEINFO_kindtypeREAL3:
573 error = ffetarget_convert_integer1_complex3
574 (ffebld_cu_ptr_integer1 (u),
575 ffebld_constant_complex3 (ffebld_conter (l)));
576 break;
577 #endif
578
579 #if FFETARGET_okCOMPLEX4
580 case FFEINFO_kindtypeREAL4:
581 error = ffetarget_convert_integer1_complex4
582 (ffebld_cu_ptr_integer1 (u),
583 ffebld_constant_complex4 (ffebld_conter (l)));
584 break;
585 #endif
586
587 default:
588 assert ("INTEGER1/COMPLEX bad source kind type" == NULL);
589 break;
590 }
591 break;
592
593 case FFEINFO_basictypeLOGICAL:
594 switch (ffeinfo_kindtype (ffebld_info (l)))
595 {
596 #if FFETARGET_okLOGICAL1
597 case FFEINFO_kindtypeLOGICAL1:
598 error = ffetarget_convert_integer1_logical1
599 (ffebld_cu_ptr_integer1 (u),
600 ffebld_constant_logical1 (ffebld_conter (l)));
601 break;
602 #endif
603
604 #if FFETARGET_okLOGICAL2
605 case FFEINFO_kindtypeLOGICAL2:
606 error = ffetarget_convert_integer1_logical2
607 (ffebld_cu_ptr_integer1 (u),
608 ffebld_constant_logical2 (ffebld_conter (l)));
609 break;
610 #endif
611
612 #if FFETARGET_okLOGICAL3
613 case FFEINFO_kindtypeLOGICAL3:
614 error = ffetarget_convert_integer1_logical3
615 (ffebld_cu_ptr_integer1 (u),
616 ffebld_constant_logical3 (ffebld_conter (l)));
617 break;
618 #endif
619
620 #if FFETARGET_okLOGICAL4
621 case FFEINFO_kindtypeLOGICAL4:
622 error = ffetarget_convert_integer1_logical4
623 (ffebld_cu_ptr_integer1 (u),
624 ffebld_constant_logical4 (ffebld_conter (l)));
625 break;
626 #endif
627
628 default:
629 assert ("INTEGER1/LOGICAL bad source kind type" == NULL);
630 break;
631 }
632 break;
633
634 case FFEINFO_basictypeCHARACTER:
635 error = ffetarget_convert_integer1_character1
636 (ffebld_cu_ptr_integer1 (u),
637 ffebld_constant_character1 (ffebld_conter (l)));
638 break;
639
640 case FFEINFO_basictypeHOLLERITH:
641 error = ffetarget_convert_integer1_hollerith
642 (ffebld_cu_ptr_integer1 (u),
643 ffebld_constant_hollerith (ffebld_conter (l)));
644 break;
645
646 case FFEINFO_basictypeTYPELESS:
647 error = ffetarget_convert_integer1_typeless
648 (ffebld_cu_ptr_integer1 (u),
649 ffebld_constant_typeless (ffebld_conter (l)));
650 break;
651
652 default:
653 assert ("INTEGER1 bad type" == NULL);
654 break;
655 }
656
657 expr = ffebld_new_conter_with_orig
658 (ffebld_constant_new_integer1_val
659 (ffebld_cu_val_integer1 (u)), expr);
660 break;
661 #endif
662
663 #if FFETARGET_okINTEGER2
664 case FFEINFO_kindtypeINTEGER2:
665 switch (ffeinfo_basictype (ffebld_info (l)))
666 {
667 case FFEINFO_basictypeINTEGER:
668 switch (ffeinfo_kindtype (ffebld_info (l)))
669 {
670 #if FFETARGET_okINTEGER1
671 case FFEINFO_kindtypeINTEGER1:
672 error = ffetarget_convert_integer2_integer1
673 (ffebld_cu_ptr_integer2 (u),
674 ffebld_constant_integer1 (ffebld_conter (l)));
675 break;
676 #endif
677
678 #if FFETARGET_okINTEGER3
679 case FFEINFO_kindtypeINTEGER3:
680 error = ffetarget_convert_integer2_integer3
681 (ffebld_cu_ptr_integer2 (u),
682 ffebld_constant_integer3 (ffebld_conter (l)));
683 break;
684 #endif
685
686 #if FFETARGET_okINTEGER4
687 case FFEINFO_kindtypeINTEGER4:
688 error = ffetarget_convert_integer2_integer4
689 (ffebld_cu_ptr_integer2 (u),
690 ffebld_constant_integer4 (ffebld_conter (l)));
691 break;
692 #endif
693
694 default:
695 assert ("INTEGER2/INTEGER bad source kind type" == NULL);
696 break;
697 }
698 break;
699
700 case FFEINFO_basictypeREAL:
701 switch (ffeinfo_kindtype (ffebld_info (l)))
702 {
703 #if FFETARGET_okREAL1
704 case FFEINFO_kindtypeREAL1:
705 error = ffetarget_convert_integer2_real1
706 (ffebld_cu_ptr_integer2 (u),
707 ffebld_constant_real1 (ffebld_conter (l)));
708 break;
709 #endif
710
711 #if FFETARGET_okREAL2
712 case FFEINFO_kindtypeREAL2:
713 error = ffetarget_convert_integer2_real2
714 (ffebld_cu_ptr_integer2 (u),
715 ffebld_constant_real2 (ffebld_conter (l)));
716 break;
717 #endif
718
719 #if FFETARGET_okREAL3
720 case FFEINFO_kindtypeREAL3:
721 error = ffetarget_convert_integer2_real3
722 (ffebld_cu_ptr_integer2 (u),
723 ffebld_constant_real3 (ffebld_conter (l)));
724 break;
725 #endif
726
727 #if FFETARGET_okREAL4
728 case FFEINFO_kindtypeREAL4:
729 error = ffetarget_convert_integer2_real4
730 (ffebld_cu_ptr_integer2 (u),
731 ffebld_constant_real4 (ffebld_conter (l)));
732 break;
733 #endif
734
735 default:
736 assert ("INTEGER2/REAL bad source kind type" == NULL);
737 break;
738 }
739 break;
740
741 case FFEINFO_basictypeCOMPLEX:
742 switch (ffeinfo_kindtype (ffebld_info (l)))
743 {
744 #if FFETARGET_okCOMPLEX1
745 case FFEINFO_kindtypeREAL1:
746 error = ffetarget_convert_integer2_complex1
747 (ffebld_cu_ptr_integer2 (u),
748 ffebld_constant_complex1 (ffebld_conter (l)));
749 break;
750 #endif
751
752 #if FFETARGET_okCOMPLEX2
753 case FFEINFO_kindtypeREAL2:
754 error = ffetarget_convert_integer2_complex2
755 (ffebld_cu_ptr_integer2 (u),
756 ffebld_constant_complex2 (ffebld_conter (l)));
757 break;
758 #endif
759
760 #if FFETARGET_okCOMPLEX3
761 case FFEINFO_kindtypeREAL3:
762 error = ffetarget_convert_integer2_complex3
763 (ffebld_cu_ptr_integer2 (u),
764 ffebld_constant_complex3 (ffebld_conter (l)));
765 break;
766 #endif
767
768 #if FFETARGET_okCOMPLEX4
769 case FFEINFO_kindtypeREAL4:
770 error = ffetarget_convert_integer2_complex4
771 (ffebld_cu_ptr_integer2 (u),
772 ffebld_constant_complex4 (ffebld_conter (l)));
773 break;
774 #endif
775
776 default:
777 assert ("INTEGER2/COMPLEX bad source kind type" == NULL);
778 break;
779 }
780 break;
781
782 case FFEINFO_basictypeLOGICAL:
783 switch (ffeinfo_kindtype (ffebld_info (l)))
784 {
785 #if FFETARGET_okLOGICAL1
786 case FFEINFO_kindtypeLOGICAL1:
787 error = ffetarget_convert_integer2_logical1
788 (ffebld_cu_ptr_integer2 (u),
789 ffebld_constant_logical1 (ffebld_conter (l)));
790 break;
791 #endif
792
793 #if FFETARGET_okLOGICAL2
794 case FFEINFO_kindtypeLOGICAL2:
795 error = ffetarget_convert_integer2_logical2
796 (ffebld_cu_ptr_integer2 (u),
797 ffebld_constant_logical2 (ffebld_conter (l)));
798 break;
799 #endif
800
801 #if FFETARGET_okLOGICAL3
802 case FFEINFO_kindtypeLOGICAL3:
803 error = ffetarget_convert_integer2_logical3
804 (ffebld_cu_ptr_integer2 (u),
805 ffebld_constant_logical3 (ffebld_conter (l)));
806 break;
807 #endif
808
809 #if FFETARGET_okLOGICAL4
810 case FFEINFO_kindtypeLOGICAL4:
811 error = ffetarget_convert_integer2_logical4
812 (ffebld_cu_ptr_integer2 (u),
813 ffebld_constant_logical4 (ffebld_conter (l)));
814 break;
815 #endif
816
817 default:
818 assert ("INTEGER2/LOGICAL bad source kind type" == NULL);
819 break;
820 }
821 break;
822
823 case FFEINFO_basictypeCHARACTER:
824 error = ffetarget_convert_integer2_character1
825 (ffebld_cu_ptr_integer2 (u),
826 ffebld_constant_character1 (ffebld_conter (l)));
827 break;
828
829 case FFEINFO_basictypeHOLLERITH:
830 error = ffetarget_convert_integer2_hollerith
831 (ffebld_cu_ptr_integer2 (u),
832 ffebld_constant_hollerith (ffebld_conter (l)));
833 break;
834
835 case FFEINFO_basictypeTYPELESS:
836 error = ffetarget_convert_integer2_typeless
837 (ffebld_cu_ptr_integer2 (u),
838 ffebld_constant_typeless (ffebld_conter (l)));
839 break;
840
841 default:
842 assert ("INTEGER2 bad type" == NULL);
843 break;
844 }
845
846 expr = ffebld_new_conter_with_orig
847 (ffebld_constant_new_integer2_val
848 (ffebld_cu_val_integer2 (u)), expr);
849 break;
850 #endif
851
852 #if FFETARGET_okINTEGER3
853 case FFEINFO_kindtypeINTEGER3:
854 switch (ffeinfo_basictype (ffebld_info (l)))
855 {
856 case FFEINFO_basictypeINTEGER:
857 switch (ffeinfo_kindtype (ffebld_info (l)))
858 {
859 #if FFETARGET_okINTEGER1
860 case FFEINFO_kindtypeINTEGER1:
861 error = ffetarget_convert_integer3_integer1
862 (ffebld_cu_ptr_integer3 (u),
863 ffebld_constant_integer1 (ffebld_conter (l)));
864 break;
865 #endif
866
867 #if FFETARGET_okINTEGER2
868 case FFEINFO_kindtypeINTEGER2:
869 error = ffetarget_convert_integer3_integer2
870 (ffebld_cu_ptr_integer3 (u),
871 ffebld_constant_integer2 (ffebld_conter (l)));
872 break;
873 #endif
874
875 #if FFETARGET_okINTEGER4
876 case FFEINFO_kindtypeINTEGER4:
877 error = ffetarget_convert_integer3_integer4
878 (ffebld_cu_ptr_integer3 (u),
879 ffebld_constant_integer4 (ffebld_conter (l)));
880 break;
881 #endif
882
883 default:
884 assert ("INTEGER3/INTEGER bad source kind type" == NULL);
885 break;
886 }
887 break;
888
889 case FFEINFO_basictypeREAL:
890 switch (ffeinfo_kindtype (ffebld_info (l)))
891 {
892 #if FFETARGET_okREAL1
893 case FFEINFO_kindtypeREAL1:
894 error = ffetarget_convert_integer3_real1
895 (ffebld_cu_ptr_integer3 (u),
896 ffebld_constant_real1 (ffebld_conter (l)));
897 break;
898 #endif
899
900 #if FFETARGET_okREAL2
901 case FFEINFO_kindtypeREAL2:
902 error = ffetarget_convert_integer3_real2
903 (ffebld_cu_ptr_integer3 (u),
904 ffebld_constant_real2 (ffebld_conter (l)));
905 break;
906 #endif
907
908 #if FFETARGET_okREAL3
909 case FFEINFO_kindtypeREAL3:
910 error = ffetarget_convert_integer3_real3
911 (ffebld_cu_ptr_integer3 (u),
912 ffebld_constant_real3 (ffebld_conter (l)));
913 break;
914 #endif
915
916 #if FFETARGET_okREAL4
917 case FFEINFO_kindtypeREAL4:
918 error = ffetarget_convert_integer3_real4
919 (ffebld_cu_ptr_integer3 (u),
920 ffebld_constant_real4 (ffebld_conter (l)));
921 break;
922 #endif
923
924 default:
925 assert ("INTEGER3/REAL bad source kind type" == NULL);
926 break;
927 }
928 break;
929
930 case FFEINFO_basictypeCOMPLEX:
931 switch (ffeinfo_kindtype (ffebld_info (l)))
932 {
933 #if FFETARGET_okCOMPLEX1
934 case FFEINFO_kindtypeREAL1:
935 error = ffetarget_convert_integer3_complex1
936 (ffebld_cu_ptr_integer3 (u),
937 ffebld_constant_complex1 (ffebld_conter (l)));
938 break;
939 #endif
940
941 #if FFETARGET_okCOMPLEX2
942 case FFEINFO_kindtypeREAL2:
943 error = ffetarget_convert_integer3_complex2
944 (ffebld_cu_ptr_integer3 (u),
945 ffebld_constant_complex2 (ffebld_conter (l)));
946 break;
947 #endif
948
949 #if FFETARGET_okCOMPLEX3
950 case FFEINFO_kindtypeREAL3:
951 error = ffetarget_convert_integer3_complex3
952 (ffebld_cu_ptr_integer3 (u),
953 ffebld_constant_complex3 (ffebld_conter (l)));
954 break;
955 #endif
956
957 #if FFETARGET_okCOMPLEX4
958 case FFEINFO_kindtypeREAL4:
959 error = ffetarget_convert_integer3_complex4
960 (ffebld_cu_ptr_integer3 (u),
961 ffebld_constant_complex4 (ffebld_conter (l)));
962 break;
963 #endif
964
965 default:
966 assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
967 break;
968 }
969 break;
970
971 case FFEINFO_basictypeLOGICAL:
972 switch (ffeinfo_kindtype (ffebld_info (l)))
973 {
974 #if FFETARGET_okLOGICAL1
975 case FFEINFO_kindtypeLOGICAL1:
976 error = ffetarget_convert_integer3_logical1
977 (ffebld_cu_ptr_integer3 (u),
978 ffebld_constant_logical1 (ffebld_conter (l)));
979 break;
980 #endif
981
982 #if FFETARGET_okLOGICAL2
983 case FFEINFO_kindtypeLOGICAL2:
984 error = ffetarget_convert_integer3_logical2
985 (ffebld_cu_ptr_integer3 (u),
986 ffebld_constant_logical2 (ffebld_conter (l)));
987 break;
988 #endif
989
990 #if FFETARGET_okLOGICAL3
991 case FFEINFO_kindtypeLOGICAL3:
992 error = ffetarget_convert_integer3_logical3
993 (ffebld_cu_ptr_integer3 (u),
994 ffebld_constant_logical3 (ffebld_conter (l)));
995 break;
996 #endif
997
998 #if FFETARGET_okLOGICAL4
999 case FFEINFO_kindtypeLOGICAL4:
1000 error = ffetarget_convert_integer3_logical4
1001 (ffebld_cu_ptr_integer3 (u),
1002 ffebld_constant_logical4 (ffebld_conter (l)));
1003 break;
1004 #endif
1005
1006 default:
1007 assert ("INTEGER3/LOGICAL bad source kind type" == NULL);
1008 break;
1009 }
1010 break;
1011
1012 case FFEINFO_basictypeCHARACTER:
1013 error = ffetarget_convert_integer3_character1
1014 (ffebld_cu_ptr_integer3 (u),
1015 ffebld_constant_character1 (ffebld_conter (l)));
1016 break;
1017
1018 case FFEINFO_basictypeHOLLERITH:
1019 error = ffetarget_convert_integer3_hollerith
1020 (ffebld_cu_ptr_integer3 (u),
1021 ffebld_constant_hollerith (ffebld_conter (l)));
1022 break;
1023
1024 case FFEINFO_basictypeTYPELESS:
1025 error = ffetarget_convert_integer3_typeless
1026 (ffebld_cu_ptr_integer3 (u),
1027 ffebld_constant_typeless (ffebld_conter (l)));
1028 break;
1029
1030 default:
1031 assert ("INTEGER3 bad type" == NULL);
1032 break;
1033 }
1034
1035 expr = ffebld_new_conter_with_orig
1036 (ffebld_constant_new_integer3_val
1037 (ffebld_cu_val_integer3 (u)), expr);
1038 break;
1039 #endif
1040
1041 #if FFETARGET_okINTEGER4
1042 case FFEINFO_kindtypeINTEGER4:
1043 switch (ffeinfo_basictype (ffebld_info (l)))
1044 {
1045 case FFEINFO_basictypeINTEGER:
1046 switch (ffeinfo_kindtype (ffebld_info (l)))
1047 {
1048 #if FFETARGET_okINTEGER1
1049 case FFEINFO_kindtypeINTEGER1:
1050 error = ffetarget_convert_integer4_integer1
1051 (ffebld_cu_ptr_integer4 (u),
1052 ffebld_constant_integer1 (ffebld_conter (l)));
1053 break;
1054 #endif
1055
1056 #if FFETARGET_okINTEGER2
1057 case FFEINFO_kindtypeINTEGER2:
1058 error = ffetarget_convert_integer4_integer2
1059 (ffebld_cu_ptr_integer4 (u),
1060 ffebld_constant_integer2 (ffebld_conter (l)));
1061 break;
1062 #endif
1063
1064 #if FFETARGET_okINTEGER3
1065 case FFEINFO_kindtypeINTEGER3:
1066 error = ffetarget_convert_integer4_integer3
1067 (ffebld_cu_ptr_integer4 (u),
1068 ffebld_constant_integer3 (ffebld_conter (l)));
1069 break;
1070 #endif
1071
1072 default:
1073 assert ("INTEGER4/INTEGER bad source kind type" == NULL);
1074 break;
1075 }
1076 break;
1077
1078 case FFEINFO_basictypeREAL:
1079 switch (ffeinfo_kindtype (ffebld_info (l)))
1080 {
1081 #if FFETARGET_okREAL1
1082 case FFEINFO_kindtypeREAL1:
1083 error = ffetarget_convert_integer4_real1
1084 (ffebld_cu_ptr_integer4 (u),
1085 ffebld_constant_real1 (ffebld_conter (l)));
1086 break;
1087 #endif
1088
1089 #if FFETARGET_okREAL2
1090 case FFEINFO_kindtypeREAL2:
1091 error = ffetarget_convert_integer4_real2
1092 (ffebld_cu_ptr_integer4 (u),
1093 ffebld_constant_real2 (ffebld_conter (l)));
1094 break;
1095 #endif
1096
1097 #if FFETARGET_okREAL3
1098 case FFEINFO_kindtypeREAL3:
1099 error = ffetarget_convert_integer4_real3
1100 (ffebld_cu_ptr_integer4 (u),
1101 ffebld_constant_real3 (ffebld_conter (l)));
1102 break;
1103 #endif
1104
1105 #if FFETARGET_okREAL4
1106 case FFEINFO_kindtypeREAL4:
1107 error = ffetarget_convert_integer4_real4
1108 (ffebld_cu_ptr_integer4 (u),
1109 ffebld_constant_real4 (ffebld_conter (l)));
1110 break;
1111 #endif
1112
1113 default:
1114 assert ("INTEGER4/REAL bad source kind type" == NULL);
1115 break;
1116 }
1117 break;
1118
1119 case FFEINFO_basictypeCOMPLEX:
1120 switch (ffeinfo_kindtype (ffebld_info (l)))
1121 {
1122 #if FFETARGET_okCOMPLEX1
1123 case FFEINFO_kindtypeREAL1:
1124 error = ffetarget_convert_integer4_complex1
1125 (ffebld_cu_ptr_integer4 (u),
1126 ffebld_constant_complex1 (ffebld_conter (l)));
1127 break;
1128 #endif
1129
1130 #if FFETARGET_okCOMPLEX2
1131 case FFEINFO_kindtypeREAL2:
1132 error = ffetarget_convert_integer4_complex2
1133 (ffebld_cu_ptr_integer4 (u),
1134 ffebld_constant_complex2 (ffebld_conter (l)));
1135 break;
1136 #endif
1137
1138 #if FFETARGET_okCOMPLEX3
1139 case FFEINFO_kindtypeREAL3:
1140 error = ffetarget_convert_integer4_complex3
1141 (ffebld_cu_ptr_integer4 (u),
1142 ffebld_constant_complex3 (ffebld_conter (l)));
1143 break;
1144 #endif
1145
1146 #if FFETARGET_okCOMPLEX4
1147 case FFEINFO_kindtypeREAL4:
1148 error = ffetarget_convert_integer4_complex4
1149 (ffebld_cu_ptr_integer4 (u),
1150 ffebld_constant_complex4 (ffebld_conter (l)));
1151 break;
1152 #endif
1153
1154 default:
1155 assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
1156 break;
1157 }
1158 break;
1159
1160 case FFEINFO_basictypeLOGICAL:
1161 switch (ffeinfo_kindtype (ffebld_info (l)))
1162 {
1163 #if FFETARGET_okLOGICAL1
1164 case FFEINFO_kindtypeLOGICAL1:
1165 error = ffetarget_convert_integer4_logical1
1166 (ffebld_cu_ptr_integer4 (u),
1167 ffebld_constant_logical1 (ffebld_conter (l)));
1168 break;
1169 #endif
1170
1171 #if FFETARGET_okLOGICAL2
1172 case FFEINFO_kindtypeLOGICAL2:
1173 error = ffetarget_convert_integer4_logical2
1174 (ffebld_cu_ptr_integer4 (u),
1175 ffebld_constant_logical2 (ffebld_conter (l)));
1176 break;
1177 #endif
1178
1179 #if FFETARGET_okLOGICAL3
1180 case FFEINFO_kindtypeLOGICAL3:
1181 error = ffetarget_convert_integer4_logical3
1182 (ffebld_cu_ptr_integer4 (u),
1183 ffebld_constant_logical3 (ffebld_conter (l)));
1184 break;
1185 #endif
1186
1187 #if FFETARGET_okLOGICAL4
1188 case FFEINFO_kindtypeLOGICAL4:
1189 error = ffetarget_convert_integer4_logical4
1190 (ffebld_cu_ptr_integer4 (u),
1191 ffebld_constant_logical4 (ffebld_conter (l)));
1192 break;
1193 #endif
1194
1195 default:
1196 assert ("INTEGER4/LOGICAL bad source kind type" == NULL);
1197 break;
1198 }
1199 break;
1200
1201 case FFEINFO_basictypeCHARACTER:
1202 error = ffetarget_convert_integer4_character1
1203 (ffebld_cu_ptr_integer4 (u),
1204 ffebld_constant_character1 (ffebld_conter (l)));
1205 break;
1206
1207 case FFEINFO_basictypeHOLLERITH:
1208 error = ffetarget_convert_integer4_hollerith
1209 (ffebld_cu_ptr_integer4 (u),
1210 ffebld_constant_hollerith (ffebld_conter (l)));
1211 break;
1212
1213 case FFEINFO_basictypeTYPELESS:
1214 error = ffetarget_convert_integer4_typeless
1215 (ffebld_cu_ptr_integer4 (u),
1216 ffebld_constant_typeless (ffebld_conter (l)));
1217 break;
1218
1219 default:
1220 assert ("INTEGER4 bad type" == NULL);
1221 break;
1222 }
1223
1224 expr = ffebld_new_conter_with_orig
1225 (ffebld_constant_new_integer4_val
1226 (ffebld_cu_val_integer4 (u)), expr);
1227 break;
1228 #endif
1229
1230 default:
1231 assert ("bad integer kind type" == NULL);
1232 break;
1233 }
1234 break;
1235
1236 case FFEINFO_basictypeLOGICAL:
1237 sz = FFETARGET_charactersizeNONE;
1238 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1239 {
1240 #if FFETARGET_okLOGICAL1
1241 case FFEINFO_kindtypeLOGICAL1:
1242 switch (ffeinfo_basictype (ffebld_info (l)))
1243 {
1244 case FFEINFO_basictypeLOGICAL:
1245 switch (ffeinfo_kindtype (ffebld_info (l)))
1246 {
1247 #if FFETARGET_okLOGICAL2
1248 case FFEINFO_kindtypeLOGICAL2:
1249 error = ffetarget_convert_logical1_logical2
1250 (ffebld_cu_ptr_logical1 (u),
1251 ffebld_constant_logical2 (ffebld_conter (l)));
1252 break;
1253 #endif
1254
1255 #if FFETARGET_okLOGICAL3
1256 case FFEINFO_kindtypeLOGICAL3:
1257 error = ffetarget_convert_logical1_logical3
1258 (ffebld_cu_ptr_logical1 (u),
1259 ffebld_constant_logical3 (ffebld_conter (l)));
1260 break;
1261 #endif
1262
1263 #if FFETARGET_okLOGICAL4
1264 case FFEINFO_kindtypeLOGICAL4:
1265 error = ffetarget_convert_logical1_logical4
1266 (ffebld_cu_ptr_logical1 (u),
1267 ffebld_constant_logical4 (ffebld_conter (l)));
1268 break;
1269 #endif
1270
1271 default:
1272 assert ("LOGICAL1/LOGICAL bad source kind type" == NULL);
1273 break;
1274 }
1275 break;
1276
1277 case FFEINFO_basictypeINTEGER:
1278 switch (ffeinfo_kindtype (ffebld_info (l)))
1279 {
1280 #if FFETARGET_okINTEGER1
1281 case FFEINFO_kindtypeINTEGER1:
1282 error = ffetarget_convert_logical1_integer1
1283 (ffebld_cu_ptr_logical1 (u),
1284 ffebld_constant_integer1 (ffebld_conter (l)));
1285 break;
1286 #endif
1287
1288 #if FFETARGET_okINTEGER2
1289 case FFEINFO_kindtypeINTEGER2:
1290 error = ffetarget_convert_logical1_integer2
1291 (ffebld_cu_ptr_logical1 (u),
1292 ffebld_constant_integer2 (ffebld_conter (l)));
1293 break;
1294 #endif
1295
1296 #if FFETARGET_okINTEGER3
1297 case FFEINFO_kindtypeINTEGER3:
1298 error = ffetarget_convert_logical1_integer3
1299 (ffebld_cu_ptr_logical1 (u),
1300 ffebld_constant_integer3 (ffebld_conter (l)));
1301 break;
1302 #endif
1303
1304 #if FFETARGET_okINTEGER4
1305 case FFEINFO_kindtypeINTEGER4:
1306 error = ffetarget_convert_logical1_integer4
1307 (ffebld_cu_ptr_logical1 (u),
1308 ffebld_constant_integer4 (ffebld_conter (l)));
1309 break;
1310 #endif
1311
1312 default:
1313 assert ("LOGICAL1/INTEGER bad source kind type" == NULL);
1314 break;
1315 }
1316 break;
1317
1318 case FFEINFO_basictypeCHARACTER:
1319 error = ffetarget_convert_logical1_character1
1320 (ffebld_cu_ptr_logical1 (u),
1321 ffebld_constant_character1 (ffebld_conter (l)));
1322 break;
1323
1324 case FFEINFO_basictypeHOLLERITH:
1325 error = ffetarget_convert_logical1_hollerith
1326 (ffebld_cu_ptr_logical1 (u),
1327 ffebld_constant_hollerith (ffebld_conter (l)));
1328 break;
1329
1330 case FFEINFO_basictypeTYPELESS:
1331 error = ffetarget_convert_logical1_typeless
1332 (ffebld_cu_ptr_logical1 (u),
1333 ffebld_constant_typeless (ffebld_conter (l)));
1334 break;
1335
1336 default:
1337 assert ("LOGICAL1 bad type" == NULL);
1338 break;
1339 }
1340
1341 expr = ffebld_new_conter_with_orig
1342 (ffebld_constant_new_logical1_val
1343 (ffebld_cu_val_logical1 (u)), expr);
1344 break;
1345 #endif
1346
1347 #if FFETARGET_okLOGICAL2
1348 case FFEINFO_kindtypeLOGICAL2:
1349 switch (ffeinfo_basictype (ffebld_info (l)))
1350 {
1351 case FFEINFO_basictypeLOGICAL:
1352 switch (ffeinfo_kindtype (ffebld_info (l)))
1353 {
1354 #if FFETARGET_okLOGICAL1
1355 case FFEINFO_kindtypeLOGICAL1:
1356 error = ffetarget_convert_logical2_logical1
1357 (ffebld_cu_ptr_logical2 (u),
1358 ffebld_constant_logical1 (ffebld_conter (l)));
1359 break;
1360 #endif
1361
1362 #if FFETARGET_okLOGICAL3
1363 case FFEINFO_kindtypeLOGICAL3:
1364 error = ffetarget_convert_logical2_logical3
1365 (ffebld_cu_ptr_logical2 (u),
1366 ffebld_constant_logical3 (ffebld_conter (l)));
1367 break;
1368 #endif
1369
1370 #if FFETARGET_okLOGICAL4
1371 case FFEINFO_kindtypeLOGICAL4:
1372 error = ffetarget_convert_logical2_logical4
1373 (ffebld_cu_ptr_logical2 (u),
1374 ffebld_constant_logical4 (ffebld_conter (l)));
1375 break;
1376 #endif
1377
1378 default:
1379 assert ("LOGICAL2/LOGICAL bad source kind type" == NULL);
1380 break;
1381 }
1382 break;
1383
1384 case FFEINFO_basictypeINTEGER:
1385 switch (ffeinfo_kindtype (ffebld_info (l)))
1386 {
1387 #if FFETARGET_okINTEGER1
1388 case FFEINFO_kindtypeINTEGER1:
1389 error = ffetarget_convert_logical2_integer1
1390 (ffebld_cu_ptr_logical2 (u),
1391 ffebld_constant_integer1 (ffebld_conter (l)));
1392 break;
1393 #endif
1394
1395 #if FFETARGET_okINTEGER2
1396 case FFEINFO_kindtypeINTEGER2:
1397 error = ffetarget_convert_logical2_integer2
1398 (ffebld_cu_ptr_logical2 (u),
1399 ffebld_constant_integer2 (ffebld_conter (l)));
1400 break;
1401 #endif
1402
1403 #if FFETARGET_okINTEGER3
1404 case FFEINFO_kindtypeINTEGER3:
1405 error = ffetarget_convert_logical2_integer3
1406 (ffebld_cu_ptr_logical2 (u),
1407 ffebld_constant_integer3 (ffebld_conter (l)));
1408 break;
1409 #endif
1410
1411 #if FFETARGET_okINTEGER4
1412 case FFEINFO_kindtypeINTEGER4:
1413 error = ffetarget_convert_logical2_integer4
1414 (ffebld_cu_ptr_logical2 (u),
1415 ffebld_constant_integer4 (ffebld_conter (l)));
1416 break;
1417 #endif
1418
1419 default:
1420 assert ("LOGICAL2/INTEGER bad source kind type" == NULL);
1421 break;
1422 }
1423 break;
1424
1425 case FFEINFO_basictypeCHARACTER:
1426 error = ffetarget_convert_logical2_character1
1427 (ffebld_cu_ptr_logical2 (u),
1428 ffebld_constant_character1 (ffebld_conter (l)));
1429 break;
1430
1431 case FFEINFO_basictypeHOLLERITH:
1432 error = ffetarget_convert_logical2_hollerith
1433 (ffebld_cu_ptr_logical2 (u),
1434 ffebld_constant_hollerith (ffebld_conter (l)));
1435 break;
1436
1437 case FFEINFO_basictypeTYPELESS:
1438 error = ffetarget_convert_logical2_typeless
1439 (ffebld_cu_ptr_logical2 (u),
1440 ffebld_constant_typeless (ffebld_conter (l)));
1441 break;
1442
1443 default:
1444 assert ("LOGICAL2 bad type" == NULL);
1445 break;
1446 }
1447
1448 expr = ffebld_new_conter_with_orig
1449 (ffebld_constant_new_logical2_val
1450 (ffebld_cu_val_logical2 (u)), expr);
1451 break;
1452 #endif
1453
1454 #if FFETARGET_okLOGICAL3
1455 case FFEINFO_kindtypeLOGICAL3:
1456 switch (ffeinfo_basictype (ffebld_info (l)))
1457 {
1458 case FFEINFO_basictypeLOGICAL:
1459 switch (ffeinfo_kindtype (ffebld_info (l)))
1460 {
1461 #if FFETARGET_okLOGICAL1
1462 case FFEINFO_kindtypeLOGICAL1:
1463 error = ffetarget_convert_logical3_logical1
1464 (ffebld_cu_ptr_logical3 (u),
1465 ffebld_constant_logical1 (ffebld_conter (l)));
1466 break;
1467 #endif
1468
1469 #if FFETARGET_okLOGICAL2
1470 case FFEINFO_kindtypeLOGICAL2:
1471 error = ffetarget_convert_logical3_logical2
1472 (ffebld_cu_ptr_logical3 (u),
1473 ffebld_constant_logical2 (ffebld_conter (l)));
1474 break;
1475 #endif
1476
1477 #if FFETARGET_okLOGICAL4
1478 case FFEINFO_kindtypeLOGICAL4:
1479 error = ffetarget_convert_logical3_logical4
1480 (ffebld_cu_ptr_logical3 (u),
1481 ffebld_constant_logical4 (ffebld_conter (l)));
1482 break;
1483 #endif
1484
1485 default:
1486 assert ("LOGICAL3/LOGICAL bad source kind type" == NULL);
1487 break;
1488 }
1489 break;
1490
1491 case FFEINFO_basictypeINTEGER:
1492 switch (ffeinfo_kindtype (ffebld_info (l)))
1493 {
1494 #if FFETARGET_okINTEGER1
1495 case FFEINFO_kindtypeINTEGER1:
1496 error = ffetarget_convert_logical3_integer1
1497 (ffebld_cu_ptr_logical3 (u),
1498 ffebld_constant_integer1 (ffebld_conter (l)));
1499 break;
1500 #endif
1501
1502 #if FFETARGET_okINTEGER2
1503 case FFEINFO_kindtypeINTEGER2:
1504 error = ffetarget_convert_logical3_integer2
1505 (ffebld_cu_ptr_logical3 (u),
1506 ffebld_constant_integer2 (ffebld_conter (l)));
1507 break;
1508 #endif
1509
1510 #if FFETARGET_okINTEGER3
1511 case FFEINFO_kindtypeINTEGER3:
1512 error = ffetarget_convert_logical3_integer3
1513 (ffebld_cu_ptr_logical3 (u),
1514 ffebld_constant_integer3 (ffebld_conter (l)));
1515 break;
1516 #endif
1517
1518 #if FFETARGET_okINTEGER4
1519 case FFEINFO_kindtypeINTEGER4:
1520 error = ffetarget_convert_logical3_integer4
1521 (ffebld_cu_ptr_logical3 (u),
1522 ffebld_constant_integer4 (ffebld_conter (l)));
1523 break;
1524 #endif
1525
1526 default:
1527 assert ("LOGICAL3/INTEGER bad source kind type" == NULL);
1528 break;
1529 }
1530 break;
1531
1532 case FFEINFO_basictypeCHARACTER:
1533 error = ffetarget_convert_logical3_character1
1534 (ffebld_cu_ptr_logical3 (u),
1535 ffebld_constant_character1 (ffebld_conter (l)));
1536 break;
1537
1538 case FFEINFO_basictypeHOLLERITH:
1539 error = ffetarget_convert_logical3_hollerith
1540 (ffebld_cu_ptr_logical3 (u),
1541 ffebld_constant_hollerith (ffebld_conter (l)));
1542 break;
1543
1544 case FFEINFO_basictypeTYPELESS:
1545 error = ffetarget_convert_logical3_typeless
1546 (ffebld_cu_ptr_logical3 (u),
1547 ffebld_constant_typeless (ffebld_conter (l)));
1548 break;
1549
1550 default:
1551 assert ("LOGICAL3 bad type" == NULL);
1552 break;
1553 }
1554
1555 expr = ffebld_new_conter_with_orig
1556 (ffebld_constant_new_logical3_val
1557 (ffebld_cu_val_logical3 (u)), expr);
1558 break;
1559 #endif
1560
1561 #if FFETARGET_okLOGICAL4
1562 case FFEINFO_kindtypeLOGICAL4:
1563 switch (ffeinfo_basictype (ffebld_info (l)))
1564 {
1565 case FFEINFO_basictypeLOGICAL:
1566 switch (ffeinfo_kindtype (ffebld_info (l)))
1567 {
1568 #if FFETARGET_okLOGICAL1
1569 case FFEINFO_kindtypeLOGICAL1:
1570 error = ffetarget_convert_logical4_logical1
1571 (ffebld_cu_ptr_logical4 (u),
1572 ffebld_constant_logical1 (ffebld_conter (l)));
1573 break;
1574 #endif
1575
1576 #if FFETARGET_okLOGICAL2
1577 case FFEINFO_kindtypeLOGICAL2:
1578 error = ffetarget_convert_logical4_logical2
1579 (ffebld_cu_ptr_logical4 (u),
1580 ffebld_constant_logical2 (ffebld_conter (l)));
1581 break;
1582 #endif
1583
1584 #if FFETARGET_okLOGICAL3
1585 case FFEINFO_kindtypeLOGICAL3:
1586 error = ffetarget_convert_logical4_logical3
1587 (ffebld_cu_ptr_logical4 (u),
1588 ffebld_constant_logical3 (ffebld_conter (l)));
1589 break;
1590 #endif
1591
1592 default:
1593 assert ("LOGICAL4/LOGICAL bad source kind type" == NULL);
1594 break;
1595 }
1596 break;
1597
1598 case FFEINFO_basictypeINTEGER:
1599 switch (ffeinfo_kindtype (ffebld_info (l)))
1600 {
1601 #if FFETARGET_okINTEGER1
1602 case FFEINFO_kindtypeINTEGER1:
1603 error = ffetarget_convert_logical4_integer1
1604 (ffebld_cu_ptr_logical4 (u),
1605 ffebld_constant_integer1 (ffebld_conter (l)));
1606 break;
1607 #endif
1608
1609 #if FFETARGET_okINTEGER2
1610 case FFEINFO_kindtypeINTEGER2:
1611 error = ffetarget_convert_logical4_integer2
1612 (ffebld_cu_ptr_logical4 (u),
1613 ffebld_constant_integer2 (ffebld_conter (l)));
1614 break;
1615 #endif
1616
1617 #if FFETARGET_okINTEGER3
1618 case FFEINFO_kindtypeINTEGER3:
1619 error = ffetarget_convert_logical4_integer3
1620 (ffebld_cu_ptr_logical4 (u),
1621 ffebld_constant_integer3 (ffebld_conter (l)));
1622 break;
1623 #endif
1624
1625 #if FFETARGET_okINTEGER4
1626 case FFEINFO_kindtypeINTEGER4:
1627 error = ffetarget_convert_logical4_integer4
1628 (ffebld_cu_ptr_logical4 (u),
1629 ffebld_constant_integer4 (ffebld_conter (l)));
1630 break;
1631 #endif
1632
1633 default:
1634 assert ("LOGICAL4/INTEGER bad source kind type" == NULL);
1635 break;
1636 }
1637 break;
1638
1639 case FFEINFO_basictypeCHARACTER:
1640 error = ffetarget_convert_logical4_character1
1641 (ffebld_cu_ptr_logical4 (u),
1642 ffebld_constant_character1 (ffebld_conter (l)));
1643 break;
1644
1645 case FFEINFO_basictypeHOLLERITH:
1646 error = ffetarget_convert_logical4_hollerith
1647 (ffebld_cu_ptr_logical4 (u),
1648 ffebld_constant_hollerith (ffebld_conter (l)));
1649 break;
1650
1651 case FFEINFO_basictypeTYPELESS:
1652 error = ffetarget_convert_logical4_typeless
1653 (ffebld_cu_ptr_logical4 (u),
1654 ffebld_constant_typeless (ffebld_conter (l)));
1655 break;
1656
1657 default:
1658 assert ("LOGICAL4 bad type" == NULL);
1659 break;
1660 }
1661
1662 expr = ffebld_new_conter_with_orig
1663 (ffebld_constant_new_logical4_val
1664 (ffebld_cu_val_logical4 (u)), expr);
1665 break;
1666 #endif
1667
1668 default:
1669 assert ("bad logical kind type" == NULL);
1670 break;
1671 }
1672 break;
1673
1674 case FFEINFO_basictypeREAL:
1675 sz = FFETARGET_charactersizeNONE;
1676 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1677 {
1678 #if FFETARGET_okREAL1
1679 case FFEINFO_kindtypeREAL1:
1680 switch (ffeinfo_basictype (ffebld_info (l)))
1681 {
1682 case FFEINFO_basictypeINTEGER:
1683 switch (ffeinfo_kindtype (ffebld_info (l)))
1684 {
1685 #if FFETARGET_okINTEGER1
1686 case FFEINFO_kindtypeINTEGER1:
1687 error = ffetarget_convert_real1_integer1
1688 (ffebld_cu_ptr_real1 (u),
1689 ffebld_constant_integer1 (ffebld_conter (l)));
1690 break;
1691 #endif
1692
1693 #if FFETARGET_okINTEGER2
1694 case FFEINFO_kindtypeINTEGER2:
1695 error = ffetarget_convert_real1_integer2
1696 (ffebld_cu_ptr_real1 (u),
1697 ffebld_constant_integer2 (ffebld_conter (l)));
1698 break;
1699 #endif
1700
1701 #if FFETARGET_okINTEGER3
1702 case FFEINFO_kindtypeINTEGER3:
1703 error = ffetarget_convert_real1_integer3
1704 (ffebld_cu_ptr_real1 (u),
1705 ffebld_constant_integer3 (ffebld_conter (l)));
1706 break;
1707 #endif
1708
1709 #if FFETARGET_okINTEGER4
1710 case FFEINFO_kindtypeINTEGER4:
1711 error = ffetarget_convert_real1_integer4
1712 (ffebld_cu_ptr_real1 (u),
1713 ffebld_constant_integer4 (ffebld_conter (l)));
1714 break;
1715 #endif
1716
1717 default:
1718 assert ("REAL1/INTEGER bad source kind type" == NULL);
1719 break;
1720 }
1721 break;
1722
1723 case FFEINFO_basictypeREAL:
1724 switch (ffeinfo_kindtype (ffebld_info (l)))
1725 {
1726 #if FFETARGET_okREAL2
1727 case FFEINFO_kindtypeREAL2:
1728 error = ffetarget_convert_real1_real2
1729 (ffebld_cu_ptr_real1 (u),
1730 ffebld_constant_real2 (ffebld_conter (l)));
1731 break;
1732 #endif
1733
1734 #if FFETARGET_okREAL3
1735 case FFEINFO_kindtypeREAL3:
1736 error = ffetarget_convert_real1_real3
1737 (ffebld_cu_ptr_real1 (u),
1738 ffebld_constant_real3 (ffebld_conter (l)));
1739 break;
1740 #endif
1741
1742 #if FFETARGET_okREAL4
1743 case FFEINFO_kindtypeREAL4:
1744 error = ffetarget_convert_real1_real4
1745 (ffebld_cu_ptr_real1 (u),
1746 ffebld_constant_real4 (ffebld_conter (l)));
1747 break;
1748 #endif
1749
1750 default:
1751 assert ("REAL1/REAL bad source kind type" == NULL);
1752 break;
1753 }
1754 break;
1755
1756 case FFEINFO_basictypeCOMPLEX:
1757 switch (ffeinfo_kindtype (ffebld_info (l)))
1758 {
1759 #if FFETARGET_okCOMPLEX1
1760 case FFEINFO_kindtypeREAL1:
1761 error = ffetarget_convert_real1_complex1
1762 (ffebld_cu_ptr_real1 (u),
1763 ffebld_constant_complex1 (ffebld_conter (l)));
1764 break;
1765 #endif
1766
1767 #if FFETARGET_okCOMPLEX2
1768 case FFEINFO_kindtypeREAL2:
1769 error = ffetarget_convert_real1_complex2
1770 (ffebld_cu_ptr_real1 (u),
1771 ffebld_constant_complex2 (ffebld_conter (l)));
1772 break;
1773 #endif
1774
1775 #if FFETARGET_okCOMPLEX3
1776 case FFEINFO_kindtypeREAL3:
1777 error = ffetarget_convert_real1_complex3
1778 (ffebld_cu_ptr_real1 (u),
1779 ffebld_constant_complex3 (ffebld_conter (l)));
1780 break;
1781 #endif
1782
1783 #if FFETARGET_okCOMPLEX4
1784 case FFEINFO_kindtypeREAL4:
1785 error = ffetarget_convert_real1_complex4
1786 (ffebld_cu_ptr_real1 (u),
1787 ffebld_constant_complex4 (ffebld_conter (l)));
1788 break;
1789 #endif
1790
1791 default:
1792 assert ("REAL1/COMPLEX bad source kind type" == NULL);
1793 break;
1794 }
1795 break;
1796
1797 case FFEINFO_basictypeCHARACTER:
1798 error = ffetarget_convert_real1_character1
1799 (ffebld_cu_ptr_real1 (u),
1800 ffebld_constant_character1 (ffebld_conter (l)));
1801 break;
1802
1803 case FFEINFO_basictypeHOLLERITH:
1804 error = ffetarget_convert_real1_hollerith
1805 (ffebld_cu_ptr_real1 (u),
1806 ffebld_constant_hollerith (ffebld_conter (l)));
1807 break;
1808
1809 case FFEINFO_basictypeTYPELESS:
1810 error = ffetarget_convert_real1_typeless
1811 (ffebld_cu_ptr_real1 (u),
1812 ffebld_constant_typeless (ffebld_conter (l)));
1813 break;
1814
1815 default:
1816 assert ("REAL1 bad type" == NULL);
1817 break;
1818 }
1819
1820 expr = ffebld_new_conter_with_orig
1821 (ffebld_constant_new_real1_val
1822 (ffebld_cu_val_real1 (u)), expr);
1823 break;
1824 #endif
1825
1826 #if FFETARGET_okREAL2
1827 case FFEINFO_kindtypeREAL2:
1828 switch (ffeinfo_basictype (ffebld_info (l)))
1829 {
1830 case FFEINFO_basictypeINTEGER:
1831 switch (ffeinfo_kindtype (ffebld_info (l)))
1832 {
1833 #if FFETARGET_okINTEGER1
1834 case FFEINFO_kindtypeINTEGER1:
1835 error = ffetarget_convert_real2_integer1
1836 (ffebld_cu_ptr_real2 (u),
1837 ffebld_constant_integer1 (ffebld_conter (l)));
1838 break;
1839 #endif
1840
1841 #if FFETARGET_okINTEGER2
1842 case FFEINFO_kindtypeINTEGER2:
1843 error = ffetarget_convert_real2_integer2
1844 (ffebld_cu_ptr_real2 (u),
1845 ffebld_constant_integer2 (ffebld_conter (l)));
1846 break;
1847 #endif
1848
1849 #if FFETARGET_okINTEGER3
1850 case FFEINFO_kindtypeINTEGER3:
1851 error = ffetarget_convert_real2_integer3
1852 (ffebld_cu_ptr_real2 (u),
1853 ffebld_constant_integer3 (ffebld_conter (l)));
1854 break;
1855 #endif
1856
1857 #if FFETARGET_okINTEGER4
1858 case FFEINFO_kindtypeINTEGER4:
1859 error = ffetarget_convert_real2_integer4
1860 (ffebld_cu_ptr_real2 (u),
1861 ffebld_constant_integer4 (ffebld_conter (l)));
1862 break;
1863 #endif
1864
1865 default:
1866 assert ("REAL2/INTEGER bad source kind type" == NULL);
1867 break;
1868 }
1869 break;
1870
1871 case FFEINFO_basictypeREAL:
1872 switch (ffeinfo_kindtype (ffebld_info (l)))
1873 {
1874 #if FFETARGET_okREAL1
1875 case FFEINFO_kindtypeREAL1:
1876 error = ffetarget_convert_real2_real1
1877 (ffebld_cu_ptr_real2 (u),
1878 ffebld_constant_real1 (ffebld_conter (l)));
1879 break;
1880 #endif
1881
1882 #if FFETARGET_okREAL3
1883 case FFEINFO_kindtypeREAL3:
1884 error = ffetarget_convert_real2_real3
1885 (ffebld_cu_ptr_real2 (u),
1886 ffebld_constant_real3 (ffebld_conter (l)));
1887 break;
1888 #endif
1889
1890 #if FFETARGET_okREAL4
1891 case FFEINFO_kindtypeREAL4:
1892 error = ffetarget_convert_real2_real4
1893 (ffebld_cu_ptr_real2 (u),
1894 ffebld_constant_real4 (ffebld_conter (l)));
1895 break;
1896 #endif
1897
1898 default:
1899 assert ("REAL2/REAL bad source kind type" == NULL);
1900 break;
1901 }
1902 break;
1903
1904 case FFEINFO_basictypeCOMPLEX:
1905 switch (ffeinfo_kindtype (ffebld_info (l)))
1906 {
1907 #if FFETARGET_okCOMPLEX1
1908 case FFEINFO_kindtypeREAL1:
1909 error = ffetarget_convert_real2_complex1
1910 (ffebld_cu_ptr_real2 (u),
1911 ffebld_constant_complex1 (ffebld_conter (l)));
1912 break;
1913 #endif
1914
1915 #if FFETARGET_okCOMPLEX2
1916 case FFEINFO_kindtypeREAL2:
1917 error = ffetarget_convert_real2_complex2
1918 (ffebld_cu_ptr_real2 (u),
1919 ffebld_constant_complex2 (ffebld_conter (l)));
1920 break;
1921 #endif
1922
1923 #if FFETARGET_okCOMPLEX3
1924 case FFEINFO_kindtypeREAL3:
1925 error = ffetarget_convert_real2_complex3
1926 (ffebld_cu_ptr_real2 (u),
1927 ffebld_constant_complex3 (ffebld_conter (l)));
1928 break;
1929 #endif
1930
1931 #if FFETARGET_okCOMPLEX4
1932 case FFEINFO_kindtypeREAL4:
1933 error = ffetarget_convert_real2_complex4
1934 (ffebld_cu_ptr_real2 (u),
1935 ffebld_constant_complex4 (ffebld_conter (l)));
1936 break;
1937 #endif
1938
1939 default:
1940 assert ("REAL2/COMPLEX bad source kind type" == NULL);
1941 break;
1942 }
1943 break;
1944
1945 case FFEINFO_basictypeCHARACTER:
1946 error = ffetarget_convert_real2_character1
1947 (ffebld_cu_ptr_real2 (u),
1948 ffebld_constant_character1 (ffebld_conter (l)));
1949 break;
1950
1951 case FFEINFO_basictypeHOLLERITH:
1952 error = ffetarget_convert_real2_hollerith
1953 (ffebld_cu_ptr_real2 (u),
1954 ffebld_constant_hollerith (ffebld_conter (l)));
1955 break;
1956
1957 case FFEINFO_basictypeTYPELESS:
1958 error = ffetarget_convert_real2_typeless
1959 (ffebld_cu_ptr_real2 (u),
1960 ffebld_constant_typeless (ffebld_conter (l)));
1961 break;
1962
1963 default:
1964 assert ("REAL2 bad type" == NULL);
1965 break;
1966 }
1967
1968 expr = ffebld_new_conter_with_orig
1969 (ffebld_constant_new_real2_val
1970 (ffebld_cu_val_real2 (u)), expr);
1971 break;
1972 #endif
1973
1974 #if FFETARGET_okREAL3
1975 case FFEINFO_kindtypeREAL3:
1976 switch (ffeinfo_basictype (ffebld_info (l)))
1977 {
1978 case FFEINFO_basictypeINTEGER:
1979 switch (ffeinfo_kindtype (ffebld_info (l)))
1980 {
1981 #if FFETARGET_okINTEGER1
1982 case FFEINFO_kindtypeINTEGER1:
1983 error = ffetarget_convert_real3_integer1
1984 (ffebld_cu_ptr_real3 (u),
1985 ffebld_constant_integer1 (ffebld_conter (l)));
1986 break;
1987 #endif
1988
1989 #if FFETARGET_okINTEGER2
1990 case FFEINFO_kindtypeINTEGER2:
1991 error = ffetarget_convert_real3_integer2
1992 (ffebld_cu_ptr_real3 (u),
1993 ffebld_constant_integer2 (ffebld_conter (l)));
1994 break;
1995 #endif
1996
1997 #if FFETARGET_okINTEGER3
1998 case FFEINFO_kindtypeINTEGER3:
1999 error = ffetarget_convert_real3_integer3
2000 (ffebld_cu_ptr_real3 (u),
2001 ffebld_constant_integer3 (ffebld_conter (l)));
2002 break;
2003 #endif
2004
2005 #if FFETARGET_okINTEGER4
2006 case FFEINFO_kindtypeINTEGER4:
2007 error = ffetarget_convert_real3_integer4
2008 (ffebld_cu_ptr_real3 (u),
2009 ffebld_constant_integer4 (ffebld_conter (l)));
2010 break;
2011 #endif
2012
2013 default:
2014 assert ("REAL3/INTEGER bad source kind type" == NULL);
2015 break;
2016 }
2017 break;
2018
2019 case FFEINFO_basictypeREAL:
2020 switch (ffeinfo_kindtype (ffebld_info (l)))
2021 {
2022 #if FFETARGET_okREAL1
2023 case FFEINFO_kindtypeREAL1:
2024 error = ffetarget_convert_real3_real1
2025 (ffebld_cu_ptr_real3 (u),
2026 ffebld_constant_real1 (ffebld_conter (l)));
2027 break;
2028 #endif
2029
2030 #if FFETARGET_okREAL2
2031 case FFEINFO_kindtypeREAL2:
2032 error = ffetarget_convert_real3_real2
2033 (ffebld_cu_ptr_real3 (u),
2034 ffebld_constant_real2 (ffebld_conter (l)));
2035 break;
2036 #endif
2037
2038 #if FFETARGET_okREAL4
2039 case FFEINFO_kindtypeREAL4:
2040 error = ffetarget_convert_real3_real4
2041 (ffebld_cu_ptr_real3 (u),
2042 ffebld_constant_real4 (ffebld_conter (l)));
2043 break;
2044 #endif
2045
2046 default:
2047 assert ("REAL3/REAL bad source kind type" == NULL);
2048 break;
2049 }
2050 break;
2051
2052 case FFEINFO_basictypeCOMPLEX:
2053 switch (ffeinfo_kindtype (ffebld_info (l)))
2054 {
2055 #if FFETARGET_okCOMPLEX1
2056 case FFEINFO_kindtypeREAL1:
2057 error = ffetarget_convert_real3_complex1
2058 (ffebld_cu_ptr_real3 (u),
2059 ffebld_constant_complex1 (ffebld_conter (l)));
2060 break;
2061 #endif
2062
2063 #if FFETARGET_okCOMPLEX2
2064 case FFEINFO_kindtypeREAL2:
2065 error = ffetarget_convert_real3_complex2
2066 (ffebld_cu_ptr_real3 (u),
2067 ffebld_constant_complex2 (ffebld_conter (l)));
2068 break;
2069 #endif
2070
2071 #if FFETARGET_okCOMPLEX3
2072 case FFEINFO_kindtypeREAL3:
2073 error = ffetarget_convert_real3_complex3
2074 (ffebld_cu_ptr_real3 (u),
2075 ffebld_constant_complex3 (ffebld_conter (l)));
2076 break;
2077 #endif
2078
2079 #if FFETARGET_okCOMPLEX4
2080 case FFEINFO_kindtypeREAL4:
2081 error = ffetarget_convert_real3_complex4
2082 (ffebld_cu_ptr_real3 (u),
2083 ffebld_constant_complex4 (ffebld_conter (l)));
2084 break;
2085 #endif
2086
2087 default:
2088 assert ("REAL3/COMPLEX bad source kind type" == NULL);
2089 break;
2090 }
2091 break;
2092
2093 case FFEINFO_basictypeCHARACTER:
2094 error = ffetarget_convert_real3_character1
2095 (ffebld_cu_ptr_real3 (u),
2096 ffebld_constant_character1 (ffebld_conter (l)));
2097 break;
2098
2099 case FFEINFO_basictypeHOLLERITH:
2100 error = ffetarget_convert_real3_hollerith
2101 (ffebld_cu_ptr_real3 (u),
2102 ffebld_constant_hollerith (ffebld_conter (l)));
2103 break;
2104
2105 case FFEINFO_basictypeTYPELESS:
2106 error = ffetarget_convert_real3_typeless
2107 (ffebld_cu_ptr_real3 (u),
2108 ffebld_constant_typeless (ffebld_conter (l)));
2109 break;
2110
2111 default:
2112 assert ("REAL3 bad type" == NULL);
2113 break;
2114 }
2115
2116 expr = ffebld_new_conter_with_orig
2117 (ffebld_constant_new_real3_val
2118 (ffebld_cu_val_real3 (u)), expr);
2119 break;
2120 #endif
2121
2122 #if FFETARGET_okREAL4
2123 case FFEINFO_kindtypeREAL4:
2124 switch (ffeinfo_basictype (ffebld_info (l)))
2125 {
2126 case FFEINFO_basictypeINTEGER:
2127 switch (ffeinfo_kindtype (ffebld_info (l)))
2128 {
2129 #if FFETARGET_okINTEGER1
2130 case FFEINFO_kindtypeINTEGER1:
2131 error = ffetarget_convert_real4_integer1
2132 (ffebld_cu_ptr_real4 (u),
2133 ffebld_constant_integer1 (ffebld_conter (l)));
2134 break;
2135 #endif
2136
2137 #if FFETARGET_okINTEGER2
2138 case FFEINFO_kindtypeINTEGER2:
2139 error = ffetarget_convert_real4_integer2
2140 (ffebld_cu_ptr_real4 (u),
2141 ffebld_constant_integer2 (ffebld_conter (l)));
2142 break;
2143 #endif
2144
2145 #if FFETARGET_okINTEGER3
2146 case FFEINFO_kindtypeINTEGER3:
2147 error = ffetarget_convert_real4_integer3
2148 (ffebld_cu_ptr_real4 (u),
2149 ffebld_constant_integer3 (ffebld_conter (l)));
2150 break;
2151 #endif
2152
2153 #if FFETARGET_okINTEGER4
2154 case FFEINFO_kindtypeINTEGER4:
2155 error = ffetarget_convert_real4_integer4
2156 (ffebld_cu_ptr_real4 (u),
2157 ffebld_constant_integer4 (ffebld_conter (l)));
2158 break;
2159 #endif
2160
2161 default:
2162 assert ("REAL4/INTEGER bad source kind type" == NULL);
2163 break;
2164 }
2165 break;
2166
2167 case FFEINFO_basictypeREAL:
2168 switch (ffeinfo_kindtype (ffebld_info (l)))
2169 {
2170 #if FFETARGET_okREAL1
2171 case FFEINFO_kindtypeREAL1:
2172 error = ffetarget_convert_real4_real1
2173 (ffebld_cu_ptr_real4 (u),
2174 ffebld_constant_real1 (ffebld_conter (l)));
2175 break;
2176 #endif
2177
2178 #if FFETARGET_okREAL2
2179 case FFEINFO_kindtypeREAL2:
2180 error = ffetarget_convert_real4_real2
2181 (ffebld_cu_ptr_real4 (u),
2182 ffebld_constant_real2 (ffebld_conter (l)));
2183 break;
2184 #endif
2185
2186 #if FFETARGET_okREAL3
2187 case FFEINFO_kindtypeREAL3:
2188 error = ffetarget_convert_real4_real3
2189 (ffebld_cu_ptr_real4 (u),
2190 ffebld_constant_real3 (ffebld_conter (l)));
2191 break;
2192 #endif
2193
2194 default:
2195 assert ("REAL4/REAL bad source kind type" == NULL);
2196 break;
2197 }
2198 break;
2199
2200 case FFEINFO_basictypeCOMPLEX:
2201 switch (ffeinfo_kindtype (ffebld_info (l)))
2202 {
2203 #if FFETARGET_okCOMPLEX1
2204 case FFEINFO_kindtypeREAL1:
2205 error = ffetarget_convert_real4_complex1
2206 (ffebld_cu_ptr_real4 (u),
2207 ffebld_constant_complex1 (ffebld_conter (l)));
2208 break;
2209 #endif
2210
2211 #if FFETARGET_okCOMPLEX2
2212 case FFEINFO_kindtypeREAL2:
2213 error = ffetarget_convert_real4_complex2
2214 (ffebld_cu_ptr_real4 (u),
2215 ffebld_constant_complex2 (ffebld_conter (l)));
2216 break;
2217 #endif
2218
2219 #if FFETARGET_okCOMPLEX3
2220 case FFEINFO_kindtypeREAL3:
2221 error = ffetarget_convert_real4_complex3
2222 (ffebld_cu_ptr_real4 (u),
2223 ffebld_constant_complex3 (ffebld_conter (l)));
2224 break;
2225 #endif
2226
2227 #if FFETARGET_okCOMPLEX4
2228 case FFEINFO_kindtypeREAL4:
2229 error = ffetarget_convert_real4_complex4
2230 (ffebld_cu_ptr_real4 (u),
2231 ffebld_constant_complex4 (ffebld_conter (l)));
2232 break;
2233 #endif
2234
2235 default:
2236 assert ("REAL4/COMPLEX bad source kind type" == NULL);
2237 break;
2238 }
2239 break;
2240
2241 case FFEINFO_basictypeCHARACTER:
2242 error = ffetarget_convert_real4_character1
2243 (ffebld_cu_ptr_real4 (u),
2244 ffebld_constant_character1 (ffebld_conter (l)));
2245 break;
2246
2247 case FFEINFO_basictypeHOLLERITH:
2248 error = ffetarget_convert_real4_hollerith
2249 (ffebld_cu_ptr_real4 (u),
2250 ffebld_constant_hollerith (ffebld_conter (l)));
2251 break;
2252
2253 case FFEINFO_basictypeTYPELESS:
2254 error = ffetarget_convert_real4_typeless
2255 (ffebld_cu_ptr_real4 (u),
2256 ffebld_constant_typeless (ffebld_conter (l)));
2257 break;
2258
2259 default:
2260 assert ("REAL4 bad type" == NULL);
2261 break;
2262 }
2263
2264 expr = ffebld_new_conter_with_orig
2265 (ffebld_constant_new_real4_val
2266 (ffebld_cu_val_real4 (u)), expr);
2267 break;
2268 #endif
2269
2270 default:
2271 assert ("bad real kind type" == NULL);
2272 break;
2273 }
2274 break;
2275
2276 case FFEINFO_basictypeCOMPLEX:
2277 sz = FFETARGET_charactersizeNONE;
2278 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2279 {
2280 #if FFETARGET_okCOMPLEX1
2281 case FFEINFO_kindtypeREAL1:
2282 switch (ffeinfo_basictype (ffebld_info (l)))
2283 {
2284 case FFEINFO_basictypeINTEGER:
2285 switch (ffeinfo_kindtype (ffebld_info (l)))
2286 {
2287 #if FFETARGET_okINTEGER1
2288 case FFEINFO_kindtypeINTEGER1:
2289 error = ffetarget_convert_complex1_integer1
2290 (ffebld_cu_ptr_complex1 (u),
2291 ffebld_constant_integer1 (ffebld_conter (l)));
2292 break;
2293 #endif
2294
2295 #if FFETARGET_okINTEGER2
2296 case FFEINFO_kindtypeINTEGER2:
2297 error = ffetarget_convert_complex1_integer2
2298 (ffebld_cu_ptr_complex1 (u),
2299 ffebld_constant_integer2 (ffebld_conter (l)));
2300 break;
2301 #endif
2302
2303 #if FFETARGET_okINTEGER3
2304 case FFEINFO_kindtypeINTEGER3:
2305 error = ffetarget_convert_complex1_integer3
2306 (ffebld_cu_ptr_complex1 (u),
2307 ffebld_constant_integer3 (ffebld_conter (l)));
2308 break;
2309 #endif
2310
2311 #if FFETARGET_okINTEGER4
2312 case FFEINFO_kindtypeINTEGER4:
2313 error = ffetarget_convert_complex1_integer4
2314 (ffebld_cu_ptr_complex1 (u),
2315 ffebld_constant_integer4 (ffebld_conter (l)));
2316 break;
2317 #endif
2318
2319 default:
2320 assert ("COMPLEX1/INTEGER bad source kind type" == NULL);
2321 break;
2322 }
2323 break;
2324
2325 case FFEINFO_basictypeREAL:
2326 switch (ffeinfo_kindtype (ffebld_info (l)))
2327 {
2328 #if FFETARGET_okREAL1
2329 case FFEINFO_kindtypeREAL1:
2330 error = ffetarget_convert_complex1_real1
2331 (ffebld_cu_ptr_complex1 (u),
2332 ffebld_constant_real1 (ffebld_conter (l)));
2333 break;
2334 #endif
2335
2336 #if FFETARGET_okREAL2
2337 case FFEINFO_kindtypeREAL2:
2338 error = ffetarget_convert_complex1_real2
2339 (ffebld_cu_ptr_complex1 (u),
2340 ffebld_constant_real2 (ffebld_conter (l)));
2341 break;
2342 #endif
2343
2344 #if FFETARGET_okREAL3
2345 case FFEINFO_kindtypeREAL3:
2346 error = ffetarget_convert_complex1_real3
2347 (ffebld_cu_ptr_complex1 (u),
2348 ffebld_constant_real3 (ffebld_conter (l)));
2349 break;
2350 #endif
2351
2352 #if FFETARGET_okREAL4
2353 case FFEINFO_kindtypeREAL4:
2354 error = ffetarget_convert_complex1_real4
2355 (ffebld_cu_ptr_complex1 (u),
2356 ffebld_constant_real4 (ffebld_conter (l)));
2357 break;
2358 #endif
2359
2360 default:
2361 assert ("COMPLEX1/REAL bad source kind type" == NULL);
2362 break;
2363 }
2364 break;
2365
2366 case FFEINFO_basictypeCOMPLEX:
2367 switch (ffeinfo_kindtype (ffebld_info (l)))
2368 {
2369 #if FFETARGET_okCOMPLEX2
2370 case FFEINFO_kindtypeREAL2:
2371 error = ffetarget_convert_complex1_complex2
2372 (ffebld_cu_ptr_complex1 (u),
2373 ffebld_constant_complex2 (ffebld_conter (l)));
2374 break;
2375 #endif
2376
2377 #if FFETARGET_okCOMPLEX3
2378 case FFEINFO_kindtypeREAL3:
2379 error = ffetarget_convert_complex1_complex3
2380 (ffebld_cu_ptr_complex1 (u),
2381 ffebld_constant_complex3 (ffebld_conter (l)));
2382 break;
2383 #endif
2384
2385 #if FFETARGET_okCOMPLEX4
2386 case FFEINFO_kindtypeREAL4:
2387 error = ffetarget_convert_complex1_complex4
2388 (ffebld_cu_ptr_complex1 (u),
2389 ffebld_constant_complex4 (ffebld_conter (l)));
2390 break;
2391 #endif
2392
2393 default:
2394 assert ("COMPLEX1/COMPLEX bad source kind type" == NULL);
2395 break;
2396 }
2397 break;
2398
2399 case FFEINFO_basictypeCHARACTER:
2400 error = ffetarget_convert_complex1_character1
2401 (ffebld_cu_ptr_complex1 (u),
2402 ffebld_constant_character1 (ffebld_conter (l)));
2403 break;
2404
2405 case FFEINFO_basictypeHOLLERITH:
2406 error = ffetarget_convert_complex1_hollerith
2407 (ffebld_cu_ptr_complex1 (u),
2408 ffebld_constant_hollerith (ffebld_conter (l)));
2409 break;
2410
2411 case FFEINFO_basictypeTYPELESS:
2412 error = ffetarget_convert_complex1_typeless
2413 (ffebld_cu_ptr_complex1 (u),
2414 ffebld_constant_typeless (ffebld_conter (l)));
2415 break;
2416
2417 default:
2418 assert ("COMPLEX1 bad type" == NULL);
2419 break;
2420 }
2421
2422 expr = ffebld_new_conter_with_orig
2423 (ffebld_constant_new_complex1_val
2424 (ffebld_cu_val_complex1 (u)), expr);
2425 break;
2426 #endif
2427
2428 #if FFETARGET_okCOMPLEX2
2429 case FFEINFO_kindtypeREAL2:
2430 switch (ffeinfo_basictype (ffebld_info (l)))
2431 {
2432 case FFEINFO_basictypeINTEGER:
2433 switch (ffeinfo_kindtype (ffebld_info (l)))
2434 {
2435 #if FFETARGET_okINTEGER1
2436 case FFEINFO_kindtypeINTEGER1:
2437 error = ffetarget_convert_complex2_integer1
2438 (ffebld_cu_ptr_complex2 (u),
2439 ffebld_constant_integer1 (ffebld_conter (l)));
2440 break;
2441 #endif
2442
2443 #if FFETARGET_okINTEGER2
2444 case FFEINFO_kindtypeINTEGER2:
2445 error = ffetarget_convert_complex2_integer2
2446 (ffebld_cu_ptr_complex2 (u),
2447 ffebld_constant_integer2 (ffebld_conter (l)));
2448 break;
2449 #endif
2450
2451 #if FFETARGET_okINTEGER3
2452 case FFEINFO_kindtypeINTEGER3:
2453 error = ffetarget_convert_complex2_integer3
2454 (ffebld_cu_ptr_complex2 (u),
2455 ffebld_constant_integer3 (ffebld_conter (l)));
2456 break;
2457 #endif
2458
2459 #if FFETARGET_okINTEGER4
2460 case FFEINFO_kindtypeINTEGER4:
2461 error = ffetarget_convert_complex2_integer4
2462 (ffebld_cu_ptr_complex2 (u),
2463 ffebld_constant_integer4 (ffebld_conter (l)));
2464 break;
2465 #endif
2466
2467 default:
2468 assert ("COMPLEX2/INTEGER bad source kind type" == NULL);
2469 break;
2470 }
2471 break;
2472
2473 case FFEINFO_basictypeREAL:
2474 switch (ffeinfo_kindtype (ffebld_info (l)))
2475 {
2476 #if FFETARGET_okREAL1
2477 case FFEINFO_kindtypeREAL1:
2478 error = ffetarget_convert_complex2_real1
2479 (ffebld_cu_ptr_complex2 (u),
2480 ffebld_constant_real1 (ffebld_conter (l)));
2481 break;
2482 #endif
2483
2484 #if FFETARGET_okREAL2
2485 case FFEINFO_kindtypeREAL2:
2486 error = ffetarget_convert_complex2_real2
2487 (ffebld_cu_ptr_complex2 (u),
2488 ffebld_constant_real2 (ffebld_conter (l)));
2489 break;
2490 #endif
2491
2492 #if FFETARGET_okREAL3
2493 case FFEINFO_kindtypeREAL3:
2494 error = ffetarget_convert_complex2_real3
2495 (ffebld_cu_ptr_complex2 (u),
2496 ffebld_constant_real3 (ffebld_conter (l)));
2497 break;
2498 #endif
2499
2500 #if FFETARGET_okREAL4
2501 case FFEINFO_kindtypeREAL4:
2502 error = ffetarget_convert_complex2_real4
2503 (ffebld_cu_ptr_complex2 (u),
2504 ffebld_constant_real4 (ffebld_conter (l)));
2505 break;
2506 #endif
2507
2508 default:
2509 assert ("COMPLEX2/REAL bad source kind type" == NULL);
2510 break;
2511 }
2512 break;
2513
2514 case FFEINFO_basictypeCOMPLEX:
2515 switch (ffeinfo_kindtype (ffebld_info (l)))
2516 {
2517 #if FFETARGET_okCOMPLEX1
2518 case FFEINFO_kindtypeREAL1:
2519 error = ffetarget_convert_complex2_complex1
2520 (ffebld_cu_ptr_complex2 (u),
2521 ffebld_constant_complex1 (ffebld_conter (l)));
2522 break;
2523 #endif
2524
2525 #if FFETARGET_okCOMPLEX3
2526 case FFEINFO_kindtypeREAL3:
2527 error = ffetarget_convert_complex2_complex3
2528 (ffebld_cu_ptr_complex2 (u),
2529 ffebld_constant_complex3 (ffebld_conter (l)));
2530 break;
2531 #endif
2532
2533 #if FFETARGET_okCOMPLEX4
2534 case FFEINFO_kindtypeREAL4:
2535 error = ffetarget_convert_complex2_complex4
2536 (ffebld_cu_ptr_complex2 (u),
2537 ffebld_constant_complex4 (ffebld_conter (l)));
2538 break;
2539 #endif
2540
2541 default:
2542 assert ("COMPLEX2/COMPLEX bad source kind type" == NULL);
2543 break;
2544 }
2545 break;
2546
2547 case FFEINFO_basictypeCHARACTER:
2548 error = ffetarget_convert_complex2_character1
2549 (ffebld_cu_ptr_complex2 (u),
2550 ffebld_constant_character1 (ffebld_conter (l)));
2551 break;
2552
2553 case FFEINFO_basictypeHOLLERITH:
2554 error = ffetarget_convert_complex2_hollerith
2555 (ffebld_cu_ptr_complex2 (u),
2556 ffebld_constant_hollerith (ffebld_conter (l)));
2557 break;
2558
2559 case FFEINFO_basictypeTYPELESS:
2560 error = ffetarget_convert_complex2_typeless
2561 (ffebld_cu_ptr_complex2 (u),
2562 ffebld_constant_typeless (ffebld_conter (l)));
2563 break;
2564
2565 default:
2566 assert ("COMPLEX2 bad type" == NULL);
2567 break;
2568 }
2569
2570 expr = ffebld_new_conter_with_orig
2571 (ffebld_constant_new_complex2_val
2572 (ffebld_cu_val_complex2 (u)), expr);
2573 break;
2574 #endif
2575
2576 #if FFETARGET_okCOMPLEX3
2577 case FFEINFO_kindtypeREAL3:
2578 switch (ffeinfo_basictype (ffebld_info (l)))
2579 {
2580 case FFEINFO_basictypeINTEGER:
2581 switch (ffeinfo_kindtype (ffebld_info (l)))
2582 {
2583 #if FFETARGET_okINTEGER1
2584 case FFEINFO_kindtypeINTEGER1:
2585 error = ffetarget_convert_complex3_integer1
2586 (ffebld_cu_ptr_complex3 (u),
2587 ffebld_constant_integer1 (ffebld_conter (l)));
2588 break;
2589 #endif
2590
2591 #if FFETARGET_okINTEGER2
2592 case FFEINFO_kindtypeINTEGER2:
2593 error = ffetarget_convert_complex3_integer2
2594 (ffebld_cu_ptr_complex3 (u),
2595 ffebld_constant_integer2 (ffebld_conter (l)));
2596 break;
2597 #endif
2598
2599 #if FFETARGET_okINTEGER3
2600 case FFEINFO_kindtypeINTEGER3:
2601 error = ffetarget_convert_complex3_integer3
2602 (ffebld_cu_ptr_complex3 (u),
2603 ffebld_constant_integer3 (ffebld_conter (l)));
2604 break;
2605 #endif
2606
2607 #if FFETARGET_okINTEGER4
2608 case FFEINFO_kindtypeINTEGER4:
2609 error = ffetarget_convert_complex3_integer4
2610 (ffebld_cu_ptr_complex3 (u),
2611 ffebld_constant_integer4 (ffebld_conter (l)));
2612 break;
2613 #endif
2614
2615 default:
2616 assert ("COMPLEX3/INTEGER bad source kind type" == NULL);
2617 break;
2618 }
2619 break;
2620
2621 case FFEINFO_basictypeREAL:
2622 switch (ffeinfo_kindtype (ffebld_info (l)))
2623 {
2624 #if FFETARGET_okREAL1
2625 case FFEINFO_kindtypeREAL1:
2626 error = ffetarget_convert_complex3_real1
2627 (ffebld_cu_ptr_complex3 (u),
2628 ffebld_constant_real1 (ffebld_conter (l)));
2629 break;
2630 #endif
2631
2632 #if FFETARGET_okREAL2
2633 case FFEINFO_kindtypeREAL2:
2634 error = ffetarget_convert_complex3_real2
2635 (ffebld_cu_ptr_complex3 (u),
2636 ffebld_constant_real2 (ffebld_conter (l)));
2637 break;
2638 #endif
2639
2640 #if FFETARGET_okREAL3
2641 case FFEINFO_kindtypeREAL3:
2642 error = ffetarget_convert_complex3_real3
2643 (ffebld_cu_ptr_complex3 (u),
2644 ffebld_constant_real3 (ffebld_conter (l)));
2645 break;
2646 #endif
2647
2648 #if FFETARGET_okREAL4
2649 case FFEINFO_kindtypeREAL4:
2650 error = ffetarget_convert_complex3_real4
2651 (ffebld_cu_ptr_complex3 (u),
2652 ffebld_constant_real4 (ffebld_conter (l)));
2653 break;
2654 #endif
2655
2656 default:
2657 assert ("COMPLEX3/REAL bad source kind type" == NULL);
2658 break;
2659 }
2660 break;
2661
2662 case FFEINFO_basictypeCOMPLEX:
2663 switch (ffeinfo_kindtype (ffebld_info (l)))
2664 {
2665 #if FFETARGET_okCOMPLEX1
2666 case FFEINFO_kindtypeREAL1:
2667 error = ffetarget_convert_complex3_complex1
2668 (ffebld_cu_ptr_complex3 (u),
2669 ffebld_constant_complex1 (ffebld_conter (l)));
2670 break;
2671 #endif
2672
2673 #if FFETARGET_okCOMPLEX2
2674 case FFEINFO_kindtypeREAL2:
2675 error = ffetarget_convert_complex3_complex2
2676 (ffebld_cu_ptr_complex3 (u),
2677 ffebld_constant_complex2 (ffebld_conter (l)));
2678 break;
2679 #endif
2680
2681 #if FFETARGET_okCOMPLEX4
2682 case FFEINFO_kindtypeREAL4:
2683 error = ffetarget_convert_complex3_complex4
2684 (ffebld_cu_ptr_complex3 (u),
2685 ffebld_constant_complex4 (ffebld_conter (l)));
2686 break;
2687 #endif
2688
2689 default:
2690 assert ("COMPLEX3/COMPLEX bad source kind type" == NULL);
2691 break;
2692 }
2693 break;
2694
2695 case FFEINFO_basictypeCHARACTER:
2696 error = ffetarget_convert_complex3_character1
2697 (ffebld_cu_ptr_complex3 (u),
2698 ffebld_constant_character1 (ffebld_conter (l)));
2699 break;
2700
2701 case FFEINFO_basictypeHOLLERITH:
2702 error = ffetarget_convert_complex3_hollerith
2703 (ffebld_cu_ptr_complex3 (u),
2704 ffebld_constant_hollerith (ffebld_conter (l)));
2705 break;
2706
2707 case FFEINFO_basictypeTYPELESS:
2708 error = ffetarget_convert_complex3_typeless
2709 (ffebld_cu_ptr_complex3 (u),
2710 ffebld_constant_typeless (ffebld_conter (l)));
2711 break;
2712
2713 default:
2714 assert ("COMPLEX3 bad type" == NULL);
2715 break;
2716 }
2717
2718 expr = ffebld_new_conter_with_orig
2719 (ffebld_constant_new_complex3_val
2720 (ffebld_cu_val_complex3 (u)), expr);
2721 break;
2722 #endif
2723
2724 #if FFETARGET_okCOMPLEX4
2725 case FFEINFO_kindtypeREAL4:
2726 switch (ffeinfo_basictype (ffebld_info (l)))
2727 {
2728 case FFEINFO_basictypeINTEGER:
2729 switch (ffeinfo_kindtype (ffebld_info (l)))
2730 {
2731 #if FFETARGET_okINTEGER1
2732 case FFEINFO_kindtypeINTEGER1:
2733 error = ffetarget_convert_complex4_integer1
2734 (ffebld_cu_ptr_complex4 (u),
2735 ffebld_constant_integer1 (ffebld_conter (l)));
2736 break;
2737 #endif
2738
2739 #if FFETARGET_okINTEGER2
2740 case FFEINFO_kindtypeINTEGER2:
2741 error = ffetarget_convert_complex4_integer2
2742 (ffebld_cu_ptr_complex4 (u),
2743 ffebld_constant_integer2 (ffebld_conter (l)));
2744 break;
2745 #endif
2746
2747 #if FFETARGET_okINTEGER3
2748 case FFEINFO_kindtypeINTEGER3:
2749 error = ffetarget_convert_complex4_integer3
2750 (ffebld_cu_ptr_complex4 (u),
2751 ffebld_constant_integer3 (ffebld_conter (l)));
2752 break;
2753 #endif
2754
2755 #if FFETARGET_okINTEGER4
2756 case FFEINFO_kindtypeINTEGER4:
2757 error = ffetarget_convert_complex4_integer4
2758 (ffebld_cu_ptr_complex4 (u),
2759 ffebld_constant_integer4 (ffebld_conter (l)));
2760 break;
2761 #endif
2762
2763 default:
2764 assert ("COMPLEX4/INTEGER bad source kind type" == NULL);
2765 break;
2766 }
2767 break;
2768
2769 case FFEINFO_basictypeREAL:
2770 switch (ffeinfo_kindtype (ffebld_info (l)))
2771 {
2772 #if FFETARGET_okREAL1
2773 case FFEINFO_kindtypeREAL1:
2774 error = ffetarget_convert_complex4_real1
2775 (ffebld_cu_ptr_complex4 (u),
2776 ffebld_constant_real1 (ffebld_conter (l)));
2777 break;
2778 #endif
2779
2780 #if FFETARGET_okREAL2
2781 case FFEINFO_kindtypeREAL2:
2782 error = ffetarget_convert_complex4_real2
2783 (ffebld_cu_ptr_complex4 (u),
2784 ffebld_constant_real2 (ffebld_conter (l)));
2785 break;
2786 #endif
2787
2788 #if FFETARGET_okREAL3
2789 case FFEINFO_kindtypeREAL3:
2790 error = ffetarget_convert_complex4_real3
2791 (ffebld_cu_ptr_complex4 (u),
2792 ffebld_constant_real3 (ffebld_conter (l)));
2793 break;
2794 #endif
2795
2796 #if FFETARGET_okREAL4
2797 case FFEINFO_kindtypeREAL4:
2798 error = ffetarget_convert_complex4_real4
2799 (ffebld_cu_ptr_complex4 (u),
2800 ffebld_constant_real4 (ffebld_conter (l)));
2801 break;
2802 #endif
2803
2804 default:
2805 assert ("COMPLEX4/REAL bad source kind type" == NULL);
2806 break;
2807 }
2808 break;
2809
2810 case FFEINFO_basictypeCOMPLEX:
2811 switch (ffeinfo_kindtype (ffebld_info (l)))
2812 {
2813 #if FFETARGET_okCOMPLEX1
2814 case FFEINFO_kindtypeREAL1:
2815 error = ffetarget_convert_complex4_complex1
2816 (ffebld_cu_ptr_complex4 (u),
2817 ffebld_constant_complex1 (ffebld_conter (l)));
2818 break;
2819 #endif
2820
2821 #if FFETARGET_okCOMPLEX2
2822 case FFEINFO_kindtypeREAL2:
2823 error = ffetarget_convert_complex4_complex2
2824 (ffebld_cu_ptr_complex4 (u),
2825 ffebld_constant_complex2 (ffebld_conter (l)));
2826 break;
2827 #endif
2828
2829 #if FFETARGET_okCOMPLEX3
2830 case FFEINFO_kindtypeREAL3:
2831 error = ffetarget_convert_complex4_complex3
2832 (ffebld_cu_ptr_complex4 (u),
2833 ffebld_constant_complex3 (ffebld_conter (l)));
2834 break;
2835 #endif
2836
2837 default:
2838 assert ("COMPLEX4/COMPLEX bad source kind type" == NULL);
2839 break;
2840 }
2841 break;
2842
2843 case FFEINFO_basictypeCHARACTER:
2844 error = ffetarget_convert_complex4_character1
2845 (ffebld_cu_ptr_complex4 (u),
2846 ffebld_constant_character1 (ffebld_conter (l)));
2847 break;
2848
2849 case FFEINFO_basictypeHOLLERITH:
2850 error = ffetarget_convert_complex4_hollerith
2851 (ffebld_cu_ptr_complex4 (u),
2852 ffebld_constant_hollerith (ffebld_conter (l)));
2853 break;
2854
2855 case FFEINFO_basictypeTYPELESS:
2856 error = ffetarget_convert_complex4_typeless
2857 (ffebld_cu_ptr_complex4 (u),
2858 ffebld_constant_typeless (ffebld_conter (l)));
2859 break;
2860
2861 default:
2862 assert ("COMPLEX4 bad type" == NULL);
2863 break;
2864 }
2865
2866 expr = ffebld_new_conter_with_orig
2867 (ffebld_constant_new_complex4_val
2868 (ffebld_cu_val_complex4 (u)), expr);
2869 break;
2870 #endif
2871
2872 default:
2873 assert ("bad complex kind type" == NULL);
2874 break;
2875 }
2876 break;
2877
2878 case FFEINFO_basictypeCHARACTER:
2879 if ((sz = ffebld_size (expr)) == FFETARGET_charactersizeNONE)
2880 return expr;
2881 kt = ffeinfo_kindtype (ffebld_info (expr));
2882 switch (kt)
2883 {
2884 #if FFETARGET_okCHARACTER1
2885 case FFEINFO_kindtypeCHARACTER1:
2886 switch (ffeinfo_basictype (ffebld_info (l)))
2887 {
2888 case FFEINFO_basictypeCHARACTER:
2889 if ((sz2 = ffebld_size (l)) == FFETARGET_charactersizeNONE)
2890 return expr;
2891 assert (kt == ffeinfo_kindtype (ffebld_info (l)));
2892 assert (sz2 == ffetarget_length_character1
2893 (ffebld_constant_character1
2894 (ffebld_conter (l))));
2895 error
2896 = ffetarget_convert_character1_character1
2897 (ffebld_cu_ptr_character1 (u), sz,
2898 ffebld_constant_character1 (ffebld_conter (l)),
2899 ffebld_constant_pool ());
2900 break;
2901
2902 case FFEINFO_basictypeINTEGER:
2903 switch (ffeinfo_kindtype (ffebld_info (l)))
2904 {
2905 #if FFETARGET_okINTEGER1
2906 case FFEINFO_kindtypeINTEGER1:
2907 error
2908 = ffetarget_convert_character1_integer1
2909 (ffebld_cu_ptr_character1 (u),
2910 sz,
2911 ffebld_constant_integer1 (ffebld_conter (l)),
2912 ffebld_constant_pool ());
2913 break;
2914 #endif
2915
2916 #if FFETARGET_okINTEGER2
2917 case FFEINFO_kindtypeINTEGER2:
2918 error
2919 = ffetarget_convert_character1_integer2
2920 (ffebld_cu_ptr_character1 (u),
2921 sz,
2922 ffebld_constant_integer2 (ffebld_conter (l)),
2923 ffebld_constant_pool ());
2924 break;
2925 #endif
2926
2927 #if FFETARGET_okINTEGER3
2928 case FFEINFO_kindtypeINTEGER3:
2929 error
2930 = ffetarget_convert_character1_integer3
2931 (ffebld_cu_ptr_character1 (u),
2932 sz,
2933 ffebld_constant_integer3 (ffebld_conter (l)),
2934 ffebld_constant_pool ());
2935 break;
2936 #endif
2937
2938 #if FFETARGET_okINTEGER4
2939 case FFEINFO_kindtypeINTEGER4:
2940 error
2941 = ffetarget_convert_character1_integer4
2942 (ffebld_cu_ptr_character1 (u),
2943 sz,
2944 ffebld_constant_integer4 (ffebld_conter (l)),
2945 ffebld_constant_pool ());
2946 break;
2947 #endif
2948
2949 default:
2950 assert ("CHARACTER1/INTEGER bad source kind type" == NULL);
2951 break;
2952 }
2953 break;
2954
2955 case FFEINFO_basictypeLOGICAL:
2956 switch (ffeinfo_kindtype (ffebld_info (l)))
2957 {
2958 #if FFETARGET_okLOGICAL1
2959 case FFEINFO_kindtypeLOGICAL1:
2960 error
2961 = ffetarget_convert_character1_logical1
2962 (ffebld_cu_ptr_character1 (u),
2963 sz,
2964 ffebld_constant_logical1 (ffebld_conter (l)),
2965 ffebld_constant_pool ());
2966 break;
2967 #endif
2968
2969 #if FFETARGET_okLOGICAL2
2970 case FFEINFO_kindtypeLOGICAL2:
2971 error
2972 = ffetarget_convert_character1_logical2
2973 (ffebld_cu_ptr_character1 (u),
2974 sz,
2975 ffebld_constant_logical2 (ffebld_conter (l)),
2976 ffebld_constant_pool ());
2977 break;
2978 #endif
2979
2980 #if FFETARGET_okLOGICAL3
2981 case FFEINFO_kindtypeLOGICAL3:
2982 error
2983 = ffetarget_convert_character1_logical3
2984 (ffebld_cu_ptr_character1 (u),
2985 sz,
2986 ffebld_constant_logical3 (ffebld_conter (l)),
2987 ffebld_constant_pool ());
2988 break;
2989 #endif
2990
2991 #if FFETARGET_okLOGICAL4
2992 case FFEINFO_kindtypeLOGICAL4:
2993 error
2994 = ffetarget_convert_character1_logical4
2995 (ffebld_cu_ptr_character1 (u),
2996 sz,
2997 ffebld_constant_logical4 (ffebld_conter (l)),
2998 ffebld_constant_pool ());
2999 break;
3000 #endif
3001
3002 default:
3003 assert ("CHARACTER1/LOGICAL bad source kind type" == NULL);
3004 break;
3005 }
3006 break;
3007
3008 case FFEINFO_basictypeHOLLERITH:
3009 error
3010 = ffetarget_convert_character1_hollerith
3011 (ffebld_cu_ptr_character1 (u),
3012 sz,
3013 ffebld_constant_hollerith (ffebld_conter (l)),
3014 ffebld_constant_pool ());
3015 break;
3016
3017 case FFEINFO_basictypeTYPELESS:
3018 error
3019 = ffetarget_convert_character1_typeless
3020 (ffebld_cu_ptr_character1 (u),
3021 sz,
3022 ffebld_constant_typeless (ffebld_conter (l)),
3023 ffebld_constant_pool ());
3024 break;
3025
3026 default:
3027 assert ("CHARACTER1 bad type" == NULL);
3028 }
3029
3030 expr
3031 = ffebld_new_conter_with_orig
3032 (ffebld_constant_new_character1_val
3033 (ffebld_cu_val_character1 (u)),
3034 expr);
3035 break;
3036 #endif
3037
3038 default:
3039 assert ("bad character kind type" == NULL);
3040 break;
3041 }
3042 break;
3043
3044 default:
3045 assert ("bad type" == NULL);
3046 return expr;
3047 }
3048
3049 ffebld_set_info (expr, ffeinfo_new
3050 (bt,
3051 kt,
3052 0,
3053 FFEINFO_kindENTITY,
3054 FFEINFO_whereCONSTANT,
3055 sz));
3056
3057 if ((error != FFEBAD)
3058 && ffebad_start (error))
3059 {
3060 assert (t != NULL);
3061 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3062 ffebad_finish ();
3063 }
3064
3065 return expr;
3066 }
3067
3068 /* ffeexpr_collapse_paren -- Collapse paren expr
3069
3070 ffebld expr;
3071 ffelexToken token;
3072 expr = ffeexpr_collapse_paren(expr,token);
3073
3074 If the result of the expr is a constant, replaces the expr with the
3075 computed constant. */
3076
3077 ffebld
3078 ffeexpr_collapse_paren (ffebld expr, ffelexToken t UNUSED)
3079 {
3080 ffebld r;
3081 ffeinfoBasictype bt;
3082 ffeinfoKindtype kt;
3083 ffetargetCharacterSize len;
3084
3085 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3086 return expr;
3087
3088 r = ffebld_left (expr);
3089
3090 if (ffebld_op (r) != FFEBLD_opCONTER)
3091 return expr;
3092
3093 bt = ffeinfo_basictype (ffebld_info (r));
3094 kt = ffeinfo_kindtype (ffebld_info (r));
3095 len = ffebld_size (r);
3096
3097 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
3098 expr);
3099
3100 ffebld_set_info (expr, ffeinfo_new
3101 (bt,
3102 kt,
3103 0,
3104 FFEINFO_kindENTITY,
3105 FFEINFO_whereCONSTANT,
3106 len));
3107
3108 return expr;
3109 }
3110
3111 /* ffeexpr_collapse_uplus -- Collapse uplus expr
3112
3113 ffebld expr;
3114 ffelexToken token;
3115 expr = ffeexpr_collapse_uplus(expr,token);
3116
3117 If the result of the expr is a constant, replaces the expr with the
3118 computed constant. */
3119
3120 ffebld
3121 ffeexpr_collapse_uplus (ffebld expr, ffelexToken t UNUSED)
3122 {
3123 ffebld r;
3124 ffeinfoBasictype bt;
3125 ffeinfoKindtype kt;
3126 ffetargetCharacterSize len;
3127
3128 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3129 return expr;
3130
3131 r = ffebld_left (expr);
3132
3133 if (ffebld_op (r) != FFEBLD_opCONTER)
3134 return expr;
3135
3136 bt = ffeinfo_basictype (ffebld_info (r));
3137 kt = ffeinfo_kindtype (ffebld_info (r));
3138 len = ffebld_size (r);
3139
3140 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
3141 expr);
3142
3143 ffebld_set_info (expr, ffeinfo_new
3144 (bt,
3145 kt,
3146 0,
3147 FFEINFO_kindENTITY,
3148 FFEINFO_whereCONSTANT,
3149 len));
3150
3151 return expr;
3152 }
3153
3154 /* ffeexpr_collapse_uminus -- Collapse uminus expr
3155
3156 ffebld expr;
3157 ffelexToken token;
3158 expr = ffeexpr_collapse_uminus(expr,token);
3159
3160 If the result of the expr is a constant, replaces the expr with the
3161 computed constant. */
3162
3163 ffebld
3164 ffeexpr_collapse_uminus (ffebld expr, ffelexToken t)
3165 {
3166 ffebad error = FFEBAD;
3167 ffebld r;
3168 ffebldConstantUnion u;
3169 ffeinfoBasictype bt;
3170 ffeinfoKindtype kt;
3171
3172 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3173 return expr;
3174
3175 r = ffebld_left (expr);
3176
3177 if (ffebld_op (r) != FFEBLD_opCONTER)
3178 return expr;
3179
3180 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3181 {
3182 case FFEINFO_basictypeANY:
3183 return expr;
3184
3185 case FFEINFO_basictypeINTEGER:
3186 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3187 {
3188 #if FFETARGET_okINTEGER1
3189 case FFEINFO_kindtypeINTEGER1:
3190 error = ffetarget_uminus_integer1 (ffebld_cu_ptr_integer1 (u),
3191 ffebld_constant_integer1 (ffebld_conter (r)));
3192 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3193 (ffebld_cu_val_integer1 (u)), expr);
3194 break;
3195 #endif
3196
3197 #if FFETARGET_okINTEGER2
3198 case FFEINFO_kindtypeINTEGER2:
3199 error = ffetarget_uminus_integer2 (ffebld_cu_ptr_integer2 (u),
3200 ffebld_constant_integer2 (ffebld_conter (r)));
3201 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3202 (ffebld_cu_val_integer2 (u)), expr);
3203 break;
3204 #endif
3205
3206 #if FFETARGET_okINTEGER3
3207 case FFEINFO_kindtypeINTEGER3:
3208 error = ffetarget_uminus_integer3 (ffebld_cu_ptr_integer3 (u),
3209 ffebld_constant_integer3 (ffebld_conter (r)));
3210 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3211 (ffebld_cu_val_integer3 (u)), expr);
3212 break;
3213 #endif
3214
3215 #if FFETARGET_okINTEGER4
3216 case FFEINFO_kindtypeINTEGER4:
3217 error = ffetarget_uminus_integer4 (ffebld_cu_ptr_integer4 (u),
3218 ffebld_constant_integer4 (ffebld_conter (r)));
3219 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3220 (ffebld_cu_val_integer4 (u)), expr);
3221 break;
3222 #endif
3223
3224 default:
3225 assert ("bad integer kind type" == NULL);
3226 break;
3227 }
3228 break;
3229
3230 case FFEINFO_basictypeREAL:
3231 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3232 {
3233 #if FFETARGET_okREAL1
3234 case FFEINFO_kindtypeREAL1:
3235 error = ffetarget_uminus_real1 (ffebld_cu_ptr_real1 (u),
3236 ffebld_constant_real1 (ffebld_conter (r)));
3237 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3238 (ffebld_cu_val_real1 (u)), expr);
3239 break;
3240 #endif
3241
3242 #if FFETARGET_okREAL2
3243 case FFEINFO_kindtypeREAL2:
3244 error = ffetarget_uminus_real2 (ffebld_cu_ptr_real2 (u),
3245 ffebld_constant_real2 (ffebld_conter (r)));
3246 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3247 (ffebld_cu_val_real2 (u)), expr);
3248 break;
3249 #endif
3250
3251 #if FFETARGET_okREAL3
3252 case FFEINFO_kindtypeREAL3:
3253 error = ffetarget_uminus_real3 (ffebld_cu_ptr_real3 (u),
3254 ffebld_constant_real3 (ffebld_conter (r)));
3255 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3256 (ffebld_cu_val_real3 (u)), expr);
3257 break;
3258 #endif
3259
3260 #if FFETARGET_okREAL4
3261 case FFEINFO_kindtypeREAL4:
3262 error = ffetarget_uminus_real4 (ffebld_cu_ptr_real4 (u),
3263 ffebld_constant_real4 (ffebld_conter (r)));
3264 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
3265 (ffebld_cu_val_real4 (u)), expr);
3266 break;
3267 #endif
3268
3269 default:
3270 assert ("bad real kind type" == NULL);
3271 break;
3272 }
3273 break;
3274
3275 case FFEINFO_basictypeCOMPLEX:
3276 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3277 {
3278 #if FFETARGET_okCOMPLEX1
3279 case FFEINFO_kindtypeREAL1:
3280 error = ffetarget_uminus_complex1 (ffebld_cu_ptr_complex1 (u),
3281 ffebld_constant_complex1 (ffebld_conter (r)));
3282 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3283 (ffebld_cu_val_complex1 (u)), expr);
3284 break;
3285 #endif
3286
3287 #if FFETARGET_okCOMPLEX2
3288 case FFEINFO_kindtypeREAL2:
3289 error = ffetarget_uminus_complex2 (ffebld_cu_ptr_complex2 (u),
3290 ffebld_constant_complex2 (ffebld_conter (r)));
3291 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3292 (ffebld_cu_val_complex2 (u)), expr);
3293 break;
3294 #endif
3295
3296 #if FFETARGET_okCOMPLEX3
3297 case FFEINFO_kindtypeREAL3:
3298 error = ffetarget_uminus_complex3 (ffebld_cu_ptr_complex3 (u),
3299 ffebld_constant_complex3 (ffebld_conter (r)));
3300 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3301 (ffebld_cu_val_complex3 (u)), expr);
3302 break;
3303 #endif
3304
3305 #if FFETARGET_okCOMPLEX4
3306 case FFEINFO_kindtypeREAL4:
3307 error = ffetarget_uminus_complex4 (ffebld_cu_ptr_complex4 (u),
3308 ffebld_constant_complex4 (ffebld_conter (r)));
3309 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
3310 (ffebld_cu_val_complex4 (u)), expr);
3311 break;
3312 #endif
3313
3314 default:
3315 assert ("bad complex kind type" == NULL);
3316 break;
3317 }
3318 break;
3319
3320 default:
3321 assert ("bad type" == NULL);
3322 return expr;
3323 }
3324
3325 ffebld_set_info (expr, ffeinfo_new
3326 (bt,
3327 kt,
3328 0,
3329 FFEINFO_kindENTITY,
3330 FFEINFO_whereCONSTANT,
3331 FFETARGET_charactersizeNONE));
3332
3333 if ((error != FFEBAD)
3334 && ffebad_start (error))
3335 {
3336 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3337 ffebad_finish ();
3338 }
3339
3340 return expr;
3341 }
3342
3343 /* ffeexpr_collapse_not -- Collapse not expr
3344
3345 ffebld expr;
3346 ffelexToken token;
3347 expr = ffeexpr_collapse_not(expr,token);
3348
3349 If the result of the expr is a constant, replaces the expr with the
3350 computed constant. */
3351
3352 ffebld
3353 ffeexpr_collapse_not (ffebld expr, ffelexToken t)
3354 {
3355 ffebad error = FFEBAD;
3356 ffebld r;
3357 ffebldConstantUnion u;
3358 ffeinfoBasictype bt;
3359 ffeinfoKindtype kt;
3360
3361 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3362 return expr;
3363
3364 r = ffebld_left (expr);
3365
3366 if (ffebld_op (r) != FFEBLD_opCONTER)
3367 return expr;
3368
3369 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3370 {
3371 case FFEINFO_basictypeANY:
3372 return expr;
3373
3374 case FFEINFO_basictypeINTEGER:
3375 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3376 {
3377 #if FFETARGET_okINTEGER1
3378 case FFEINFO_kindtypeINTEGER1:
3379 error = ffetarget_not_integer1 (ffebld_cu_ptr_integer1 (u),
3380 ffebld_constant_integer1 (ffebld_conter (r)));
3381 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3382 (ffebld_cu_val_integer1 (u)), expr);
3383 break;
3384 #endif
3385
3386 #if FFETARGET_okINTEGER2
3387 case FFEINFO_kindtypeINTEGER2:
3388 error = ffetarget_not_integer2 (ffebld_cu_ptr_integer2 (u),
3389 ffebld_constant_integer2 (ffebld_conter (r)));
3390 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3391 (ffebld_cu_val_integer2 (u)), expr);
3392 break;
3393 #endif
3394
3395 #if FFETARGET_okINTEGER3
3396 case FFEINFO_kindtypeINTEGER3:
3397 error = ffetarget_not_integer3 (ffebld_cu_ptr_integer3 (u),
3398 ffebld_constant_integer3 (ffebld_conter (r)));
3399 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3400 (ffebld_cu_val_integer3 (u)), expr);
3401 break;
3402 #endif
3403
3404 #if FFETARGET_okINTEGER4
3405 case FFEINFO_kindtypeINTEGER4:
3406 error = ffetarget_not_integer4 (ffebld_cu_ptr_integer4 (u),
3407 ffebld_constant_integer4 (ffebld_conter (r)));
3408 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3409 (ffebld_cu_val_integer4 (u)), expr);
3410 break;
3411 #endif
3412
3413 default:
3414 assert ("bad integer kind type" == NULL);
3415 break;
3416 }
3417 break;
3418
3419 case FFEINFO_basictypeLOGICAL:
3420 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3421 {
3422 #if FFETARGET_okLOGICAL1
3423 case FFEINFO_kindtypeLOGICAL1:
3424 error = ffetarget_not_logical1 (ffebld_cu_ptr_logical1 (u),
3425 ffebld_constant_logical1 (ffebld_conter (r)));
3426 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
3427 (ffebld_cu_val_logical1 (u)), expr);
3428 break;
3429 #endif
3430
3431 #if FFETARGET_okLOGICAL2
3432 case FFEINFO_kindtypeLOGICAL2:
3433 error = ffetarget_not_logical2 (ffebld_cu_ptr_logical2 (u),
3434 ffebld_constant_logical2 (ffebld_conter (r)));
3435 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
3436 (ffebld_cu_val_logical2 (u)), expr);
3437 break;
3438 #endif
3439
3440 #if FFETARGET_okLOGICAL3
3441 case FFEINFO_kindtypeLOGICAL3:
3442 error = ffetarget_not_logical3 (ffebld_cu_ptr_logical3 (u),
3443 ffebld_constant_logical3 (ffebld_conter (r)));
3444 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
3445 (ffebld_cu_val_logical3 (u)), expr);
3446 break;
3447 #endif
3448
3449 #if FFETARGET_okLOGICAL4
3450 case FFEINFO_kindtypeLOGICAL4:
3451 error = ffetarget_not_logical4 (ffebld_cu_ptr_logical4 (u),
3452 ffebld_constant_logical4 (ffebld_conter (r)));
3453 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
3454 (ffebld_cu_val_logical4 (u)), expr);
3455 break;
3456 #endif
3457
3458 default:
3459 assert ("bad logical kind type" == NULL);
3460 break;
3461 }
3462 break;
3463
3464 default:
3465 assert ("bad type" == NULL);
3466 return expr;
3467 }
3468
3469 ffebld_set_info (expr, ffeinfo_new
3470 (bt,
3471 kt,
3472 0,
3473 FFEINFO_kindENTITY,
3474 FFEINFO_whereCONSTANT,
3475 FFETARGET_charactersizeNONE));
3476
3477 if ((error != FFEBAD)
3478 && ffebad_start (error))
3479 {
3480 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3481 ffebad_finish ();
3482 }
3483
3484 return expr;
3485 }
3486
3487 /* ffeexpr_collapse_add -- Collapse add expr
3488
3489 ffebld expr;
3490 ffelexToken token;
3491 expr = ffeexpr_collapse_add(expr,token);
3492
3493 If the result of the expr is a constant, replaces the expr with the
3494 computed constant. */
3495
3496 ffebld
3497 ffeexpr_collapse_add (ffebld expr, ffelexToken t)
3498 {
3499 ffebad error = FFEBAD;
3500 ffebld l;
3501 ffebld r;
3502 ffebldConstantUnion u;
3503 ffeinfoBasictype bt;
3504 ffeinfoKindtype kt;
3505
3506 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3507 return expr;
3508
3509 l = ffebld_left (expr);
3510 r = ffebld_right (expr);
3511
3512 if (ffebld_op (l) != FFEBLD_opCONTER)
3513 return expr;
3514 if (ffebld_op (r) != FFEBLD_opCONTER)
3515 return expr;
3516
3517 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3518 {
3519 case FFEINFO_basictypeANY:
3520 return expr;
3521
3522 case FFEINFO_basictypeINTEGER:
3523 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3524 {
3525 #if FFETARGET_okINTEGER1
3526 case FFEINFO_kindtypeINTEGER1:
3527 error = ffetarget_add_integer1 (ffebld_cu_ptr_integer1 (u),
3528 ffebld_constant_integer1 (ffebld_conter (l)),
3529 ffebld_constant_integer1 (ffebld_conter (r)));
3530 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3531 (ffebld_cu_val_integer1 (u)), expr);
3532 break;
3533 #endif
3534
3535 #if FFETARGET_okINTEGER2
3536 case FFEINFO_kindtypeINTEGER2:
3537 error = ffetarget_add_integer2 (ffebld_cu_ptr_integer2 (u),
3538 ffebld_constant_integer2 (ffebld_conter (l)),
3539 ffebld_constant_integer2 (ffebld_conter (r)));
3540 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3541 (ffebld_cu_val_integer2 (u)), expr);
3542 break;
3543 #endif
3544
3545 #if FFETARGET_okINTEGER3
3546 case FFEINFO_kindtypeINTEGER3:
3547 error = ffetarget_add_integer3 (ffebld_cu_ptr_integer3 (u),
3548 ffebld_constant_integer3 (ffebld_conter (l)),
3549 ffebld_constant_integer3 (ffebld_conter (r)));
3550 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3551 (ffebld_cu_val_integer3 (u)), expr);
3552 break;
3553 #endif
3554
3555 #if FFETARGET_okINTEGER4
3556 case FFEINFO_kindtypeINTEGER4:
3557 error = ffetarget_add_integer4 (ffebld_cu_ptr_integer4 (u),
3558 ffebld_constant_integer4 (ffebld_conter (l)),
3559 ffebld_constant_integer4 (ffebld_conter (r)));
3560 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3561 (ffebld_cu_val_integer4 (u)), expr);
3562 break;
3563 #endif
3564
3565 default:
3566 assert ("bad integer kind type" == NULL);
3567 break;
3568 }
3569 break;
3570
3571 case FFEINFO_basictypeREAL:
3572 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3573 {
3574 #if FFETARGET_okREAL1
3575 case FFEINFO_kindtypeREAL1:
3576 error = ffetarget_add_real1 (ffebld_cu_ptr_real1 (u),
3577 ffebld_constant_real1 (ffebld_conter (l)),
3578 ffebld_constant_real1 (ffebld_conter (r)));
3579 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3580 (ffebld_cu_val_real1 (u)), expr);
3581 break;
3582 #endif
3583
3584 #if FFETARGET_okREAL2
3585 case FFEINFO_kindtypeREAL2:
3586 error = ffetarget_add_real2 (ffebld_cu_ptr_real2 (u),
3587 ffebld_constant_real2 (ffebld_conter (l)),
3588 ffebld_constant_real2 (ffebld_conter (r)));
3589 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3590 (ffebld_cu_val_real2 (u)), expr);
3591 break;
3592 #endif
3593
3594 #if FFETARGET_okREAL3
3595 case FFEINFO_kindtypeREAL3:
3596 error = ffetarget_add_real3 (ffebld_cu_ptr_real3 (u),
3597 ffebld_constant_real3 (ffebld_conter (l)),
3598 ffebld_constant_real3 (ffebld_conter (r)));
3599 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3600 (ffebld_cu_val_real3 (u)), expr);
3601 break;
3602 #endif
3603
3604 #if FFETARGET_okREAL4
3605 case FFEINFO_kindtypeREAL4:
3606 error = ffetarget_add_real4 (ffebld_cu_ptr_real4 (u),
3607 ffebld_constant_real4 (ffebld_conter (l)),
3608 ffebld_constant_real4 (ffebld_conter (r)));
3609 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
3610 (ffebld_cu_val_real4 (u)), expr);
3611 break;
3612 #endif
3613
3614 default:
3615 assert ("bad real kind type" == NULL);
3616 break;
3617 }
3618 break;
3619
3620 case FFEINFO_basictypeCOMPLEX:
3621 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3622 {
3623 #if FFETARGET_okCOMPLEX1
3624 case FFEINFO_kindtypeREAL1:
3625 error = ffetarget_add_complex1 (ffebld_cu_ptr_complex1 (u),
3626 ffebld_constant_complex1 (ffebld_conter (l)),
3627 ffebld_constant_complex1 (ffebld_conter (r)));
3628 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3629 (ffebld_cu_val_complex1 (u)), expr);
3630 break;
3631 #endif
3632
3633 #if FFETARGET_okCOMPLEX2
3634 case FFEINFO_kindtypeREAL2:
3635 error = ffetarget_add_complex2 (ffebld_cu_ptr_complex2 (u),
3636 ffebld_constant_complex2 (ffebld_conter (l)),
3637 ffebld_constant_complex2 (ffebld_conter (r)));
3638 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3639 (ffebld_cu_val_complex2 (u)), expr);
3640 break;
3641 #endif
3642
3643 #if FFETARGET_okCOMPLEX3
3644 case FFEINFO_kindtypeREAL3:
3645 error = ffetarget_add_complex3 (ffebld_cu_ptr_complex3 (u),
3646 ffebld_constant_complex3 (ffebld_conter (l)),
3647 ffebld_constant_complex3 (ffebld_conter (r)));
3648 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3649 (ffebld_cu_val_complex3 (u)), expr);
3650 break;
3651 #endif
3652
3653 #if FFETARGET_okCOMPLEX4
3654 case FFEINFO_kindtypeREAL4:
3655 error = ffetarget_add_complex4 (ffebld_cu_ptr_complex4 (u),
3656 ffebld_constant_complex4 (ffebld_conter (l)),
3657 ffebld_constant_complex4 (ffebld_conter (r)));
3658 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
3659 (ffebld_cu_val_complex4 (u)), expr);
3660 break;
3661 #endif
3662
3663 default:
3664 assert ("bad complex kind type" == NULL);
3665 break;
3666 }
3667 break;
3668
3669 default:
3670 assert ("bad type" == NULL);
3671 return expr;
3672 }
3673
3674 ffebld_set_info (expr, ffeinfo_new
3675 (bt,
3676 kt,
3677 0,
3678 FFEINFO_kindENTITY,
3679 FFEINFO_whereCONSTANT,
3680 FFETARGET_charactersizeNONE));
3681
3682 if ((error != FFEBAD)
3683 && ffebad_start (error))
3684 {
3685 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3686 ffebad_finish ();
3687 }
3688
3689 return expr;
3690 }
3691
3692 /* ffeexpr_collapse_subtract -- Collapse subtract expr
3693
3694 ffebld expr;
3695 ffelexToken token;
3696 expr = ffeexpr_collapse_subtract(expr,token);
3697
3698 If the result of the expr is a constant, replaces the expr with the
3699 computed constant. */
3700
3701 ffebld
3702 ffeexpr_collapse_subtract (ffebld expr, ffelexToken t)
3703 {
3704 ffebad error = FFEBAD;
3705 ffebld l;
3706 ffebld r;
3707 ffebldConstantUnion u;
3708 ffeinfoBasictype bt;
3709 ffeinfoKindtype kt;
3710
3711 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3712 return expr;
3713
3714 l = ffebld_left (expr);
3715 r = ffebld_right (expr);
3716
3717 if (ffebld_op (l) != FFEBLD_opCONTER)
3718 return expr;
3719 if (ffebld_op (r) != FFEBLD_opCONTER)
3720 return expr;
3721
3722 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3723 {
3724 case FFEINFO_basictypeANY:
3725 return expr;
3726
3727 case FFEINFO_basictypeINTEGER:
3728 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3729 {
3730 #if FFETARGET_okINTEGER1
3731 case FFEINFO_kindtypeINTEGER1:
3732 error = ffetarget_subtract_integer1 (ffebld_cu_ptr_integer1 (u),
3733 ffebld_constant_integer1 (ffebld_conter (l)),
3734 ffebld_constant_integer1 (ffebld_conter (r)));
3735 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3736 (ffebld_cu_val_integer1 (u)), expr);
3737 break;
3738 #endif
3739
3740 #if FFETARGET_okINTEGER2
3741 case FFEINFO_kindtypeINTEGER2:
3742 error = ffetarget_subtract_integer2 (ffebld_cu_ptr_integer2 (u),
3743 ffebld_constant_integer2 (ffebld_conter (l)),
3744 ffebld_constant_integer2 (ffebld_conter (r)));
3745 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3746 (ffebld_cu_val_integer2 (u)), expr);
3747 break;
3748 #endif
3749
3750 #if FFETARGET_okINTEGER3
3751 case FFEINFO_kindtypeINTEGER3:
3752 error = ffetarget_subtract_integer3 (ffebld_cu_ptr_integer3 (u),
3753 ffebld_constant_integer3 (ffebld_conter (l)),
3754 ffebld_constant_integer3 (ffebld_conter (r)));
3755 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3756 (ffebld_cu_val_integer3 (u)), expr);
3757 break;
3758 #endif
3759
3760 #if FFETARGET_okINTEGER4
3761 case FFEINFO_kindtypeINTEGER4:
3762 error = ffetarget_subtract_integer4 (ffebld_cu_ptr_integer4 (u),
3763 ffebld_constant_integer4 (ffebld_conter (l)),
3764 ffebld_constant_integer4 (ffebld_conter (r)));
3765 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3766 (ffebld_cu_val_integer4 (u)), expr);
3767 break;
3768 #endif
3769
3770 default:
3771 assert ("bad integer kind type" == NULL);
3772 break;
3773 }
3774 break;
3775
3776 case FFEINFO_basictypeREAL:
3777 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3778 {
3779 #if FFETARGET_okREAL1
3780 case FFEINFO_kindtypeREAL1:
3781 error = ffetarget_subtract_real1 (ffebld_cu_ptr_real1 (u),
3782 ffebld_constant_real1 (ffebld_conter (l)),
3783 ffebld_constant_real1 (ffebld_conter (r)));
3784 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3785 (ffebld_cu_val_real1 (u)), expr);
3786 break;
3787 #endif
3788
3789 #if FFETARGET_okREAL2
3790 case FFEINFO_kindtypeREAL2:
3791 error = ffetarget_subtract_real2 (ffebld_cu_ptr_real2 (u),
3792 ffebld_constant_real2 (ffebld_conter (l)),
3793 ffebld_constant_real2 (ffebld_conter (r)));
3794 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3795 (ffebld_cu_val_real2 (u)), expr);
3796 break;
3797 #endif
3798
3799 #if FFETARGET_okREAL3
3800 case FFEINFO_kindtypeREAL3:
3801 error = ffetarget_subtract_real3 (ffebld_cu_ptr_real3 (u),
3802 ffebld_constant_real3 (ffebld_conter (l)),
3803 ffebld_constant_real3 (ffebld_conter (r)));
3804 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3805 (ffebld_cu_val_real3 (u)), expr);
3806 break;
3807 #endif
3808
3809 #if FFETARGET_okREAL4
3810 case FFEINFO_kindtypeREAL4:
3811 error = ffetarget_subtract_real4 (ffebld_cu_ptr_real4 (u),
3812 ffebld_constant_real4 (ffebld_conter (l)),
3813 ffebld_constant_real4 (ffebld_conter (r)));
3814 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
3815 (ffebld_cu_val_real4 (u)), expr);
3816 break;
3817 #endif
3818
3819 default:
3820 assert ("bad real kind type" == NULL);
3821 break;
3822 }
3823 break;
3824
3825 case FFEINFO_basictypeCOMPLEX:
3826 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3827 {
3828 #if FFETARGET_okCOMPLEX1
3829 case FFEINFO_kindtypeREAL1:
3830 error = ffetarget_subtract_complex1 (ffebld_cu_ptr_complex1 (u),
3831 ffebld_constant_complex1 (ffebld_conter (l)),
3832 ffebld_constant_complex1 (ffebld_conter (r)));
3833 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3834 (ffebld_cu_val_complex1 (u)), expr);
3835 break;
3836 #endif
3837
3838 #if FFETARGET_okCOMPLEX2
3839 case FFEINFO_kindtypeREAL2:
3840 error = ffetarget_subtract_complex2 (ffebld_cu_ptr_complex2 (u),
3841 ffebld_constant_complex2 (ffebld_conter (l)),
3842 ffebld_constant_complex2 (ffebld_conter (r)));
3843 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3844 (ffebld_cu_val_complex2 (u)), expr);
3845 break;
3846 #endif
3847
3848 #if FFETARGET_okCOMPLEX3
3849 case FFEINFO_kindtypeREAL3:
3850 error = ffetarget_subtract_complex3 (ffebld_cu_ptr_complex3 (u),
3851 ffebld_constant_complex3 (ffebld_conter (l)),
3852 ffebld_constant_complex3 (ffebld_conter (r)));
3853 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3854 (ffebld_cu_val_complex3 (u)), expr);
3855 break;
3856 #endif
3857
3858 #if FFETARGET_okCOMPLEX4
3859 case FFEINFO_kindtypeREAL4:
3860 error = ffetarget_subtract_complex4 (ffebld_cu_ptr_complex4 (u),
3861 ffebld_constant_complex4 (ffebld_conter (l)),
3862 ffebld_constant_complex4 (ffebld_conter (r)));
3863 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
3864 (ffebld_cu_val_complex4 (u)), expr);
3865 break;
3866 #endif
3867
3868 default:
3869 assert ("bad complex kind type" == NULL);
3870 break;
3871 }
3872 break;
3873
3874 default:
3875 assert ("bad type" == NULL);
3876 return expr;
3877 }
3878
3879 ffebld_set_info (expr, ffeinfo_new
3880 (bt,
3881 kt,
3882 0,
3883 FFEINFO_kindENTITY,
3884 FFEINFO_whereCONSTANT,
3885 FFETARGET_charactersizeNONE));
3886
3887 if ((error != FFEBAD)
3888 && ffebad_start (error))
3889 {
3890 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3891 ffebad_finish ();
3892 }
3893
3894 return expr;
3895 }
3896
3897 /* ffeexpr_collapse_multiply -- Collapse multiply expr
3898
3899 ffebld expr;
3900 ffelexToken token;
3901 expr = ffeexpr_collapse_multiply(expr,token);
3902
3903 If the result of the expr is a constant, replaces the expr with the
3904 computed constant. */
3905
3906 ffebld
3907 ffeexpr_collapse_multiply (ffebld expr, ffelexToken t)
3908 {
3909 ffebad error = FFEBAD;
3910 ffebld l;
3911 ffebld r;
3912 ffebldConstantUnion u;
3913 ffeinfoBasictype bt;
3914 ffeinfoKindtype kt;
3915
3916 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3917 return expr;
3918
3919 l = ffebld_left (expr);
3920 r = ffebld_right (expr);
3921
3922 if (ffebld_op (l) != FFEBLD_opCONTER)
3923 return expr;
3924 if (ffebld_op (r) != FFEBLD_opCONTER)
3925 return expr;
3926
3927 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3928 {
3929 case FFEINFO_basictypeANY:
3930 return expr;
3931
3932 case FFEINFO_basictypeINTEGER:
3933 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3934 {
3935 #if FFETARGET_okINTEGER1
3936 case FFEINFO_kindtypeINTEGER1:
3937 error = ffetarget_multiply_integer1 (ffebld_cu_ptr_integer1 (u),
3938 ffebld_constant_integer1 (ffebld_conter (l)),
3939 ffebld_constant_integer1 (ffebld_conter (r)));
3940 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3941 (ffebld_cu_val_integer1 (u)), expr);
3942 break;
3943 #endif
3944
3945 #if FFETARGET_okINTEGER2
3946 case FFEINFO_kindtypeINTEGER2:
3947 error = ffetarget_multiply_integer2 (ffebld_cu_ptr_integer2 (u),
3948 ffebld_constant_integer2 (ffebld_conter (l)),
3949 ffebld_constant_integer2 (ffebld_conter (r)));
3950 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3951 (ffebld_cu_val_integer2 (u)), expr);
3952 break;
3953 #endif
3954
3955 #if FFETARGET_okINTEGER3
3956 case FFEINFO_kindtypeINTEGER3:
3957 error = ffetarget_multiply_integer3 (ffebld_cu_ptr_integer3 (u),
3958 ffebld_constant_integer3 (ffebld_conter (l)),
3959 ffebld_constant_integer3 (ffebld_conter (r)));
3960 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3961 (ffebld_cu_val_integer3 (u)), expr);
3962 break;
3963 #endif
3964
3965 #if FFETARGET_okINTEGER4
3966 case FFEINFO_kindtypeINTEGER4:
3967 error = ffetarget_multiply_integer4 (ffebld_cu_ptr_integer4 (u),
3968 ffebld_constant_integer4 (ffebld_conter (l)),
3969 ffebld_constant_integer4 (ffebld_conter (r)));
3970 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3971 (ffebld_cu_val_integer4 (u)), expr);
3972 break;
3973 #endif
3974
3975 default:
3976 assert ("bad integer kind type" == NULL);
3977 break;
3978 }
3979 break;
3980
3981 case FFEINFO_basictypeREAL:
3982 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3983 {
3984 #if FFETARGET_okREAL1
3985 case FFEINFO_kindtypeREAL1:
3986 error = ffetarget_multiply_real1 (ffebld_cu_ptr_real1 (u),
3987 ffebld_constant_real1 (ffebld_conter (l)),
3988 ffebld_constant_real1 (ffebld_conter (r)));
3989 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3990 (ffebld_cu_val_real1 (u)), expr);
3991 break;
3992 #endif
3993
3994 #if FFETARGET_okREAL2
3995 case FFEINFO_kindtypeREAL2:
3996 error = ffetarget_multiply_real2 (ffebld_cu_ptr_real2 (u),
3997 ffebld_constant_real2 (ffebld_conter (l)),
3998 ffebld_constant_real2 (ffebld_conter (r)));
3999 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
4000 (ffebld_cu_val_real2 (u)), expr);
4001 break;
4002 #endif
4003
4004 #if FFETARGET_okREAL3
4005 case FFEINFO_kindtypeREAL3:
4006 error = ffetarget_multiply_real3 (ffebld_cu_ptr_real3 (u),
4007 ffebld_constant_real3 (ffebld_conter (l)),
4008 ffebld_constant_real3 (ffebld_conter (r)));
4009 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
4010 (ffebld_cu_val_real3 (u)), expr);
4011 break;
4012 #endif
4013
4014 #if FFETARGET_okREAL4
4015 case FFEINFO_kindtypeREAL4:
4016 error = ffetarget_multiply_real4 (ffebld_cu_ptr_real4 (u),
4017 ffebld_constant_real4 (ffebld_conter (l)),
4018 ffebld_constant_real4 (ffebld_conter (r)));
4019 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
4020 (ffebld_cu_val_real4 (u)), expr);
4021 break;
4022 #endif
4023
4024 default:
4025 assert ("bad real kind type" == NULL);
4026 break;
4027 }
4028 break;
4029
4030 case FFEINFO_basictypeCOMPLEX:
4031 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4032 {
4033 #if FFETARGET_okCOMPLEX1
4034 case FFEINFO_kindtypeREAL1:
4035 error = ffetarget_multiply_complex1 (ffebld_cu_ptr_complex1 (u),
4036 ffebld_constant_complex1 (ffebld_conter (l)),
4037 ffebld_constant_complex1 (ffebld_conter (r)));
4038 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
4039 (ffebld_cu_val_complex1 (u)), expr);
4040 break;
4041 #endif
4042
4043 #if FFETARGET_okCOMPLEX2
4044 case FFEINFO_kindtypeREAL2:
4045 error = ffetarget_multiply_complex2 (ffebld_cu_ptr_complex2 (u),
4046 ffebld_constant_complex2 (ffebld_conter (l)),
4047 ffebld_constant_complex2 (ffebld_conter (r)));
4048 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
4049 (ffebld_cu_val_complex2 (u)), expr);
4050 break;
4051 #endif
4052
4053 #if FFETARGET_okCOMPLEX3
4054 case FFEINFO_kindtypeREAL3:
4055 error = ffetarget_multiply_complex3 (ffebld_cu_ptr_complex3 (u),
4056 ffebld_constant_complex3 (ffebld_conter (l)),
4057 ffebld_constant_complex3 (ffebld_conter (r)));
4058 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
4059 (ffebld_cu_val_complex3 (u)), expr);
4060 break;
4061 #endif
4062
4063 #if FFETARGET_okCOMPLEX4
4064 case FFEINFO_kindtypeREAL4:
4065 error = ffetarget_multiply_complex4 (ffebld_cu_ptr_complex4 (u),
4066 ffebld_constant_complex4 (ffebld_conter (l)),
4067 ffebld_constant_complex4 (ffebld_conter (r)));
4068 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
4069 (ffebld_cu_val_complex4 (u)), expr);
4070 break;
4071 #endif
4072
4073 default:
4074 assert ("bad complex kind type" == NULL);
4075 break;
4076 }
4077 break;
4078
4079 default:
4080 assert ("bad type" == NULL);
4081 return expr;
4082 }
4083
4084 ffebld_set_info (expr, ffeinfo_new
4085 (bt,
4086 kt,
4087 0,
4088 FFEINFO_kindENTITY,
4089 FFEINFO_whereCONSTANT,
4090 FFETARGET_charactersizeNONE));
4091
4092 if ((error != FFEBAD)
4093 && ffebad_start (error))
4094 {
4095 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4096 ffebad_finish ();
4097 }
4098
4099 return expr;
4100 }
4101
4102 /* ffeexpr_collapse_divide -- Collapse divide expr
4103
4104 ffebld expr;
4105 ffelexToken token;
4106 expr = ffeexpr_collapse_divide(expr,token);
4107
4108 If the result of the expr is a constant, replaces the expr with the
4109 computed constant. */
4110
4111 ffebld
4112 ffeexpr_collapse_divide (ffebld expr, ffelexToken t)
4113 {
4114 ffebad error = FFEBAD;
4115 ffebld l;
4116 ffebld r;
4117 ffebldConstantUnion u;
4118 ffeinfoBasictype bt;
4119 ffeinfoKindtype kt;
4120
4121 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4122 return expr;
4123
4124 l = ffebld_left (expr);
4125 r = ffebld_right (expr);
4126
4127 if (ffebld_op (l) != FFEBLD_opCONTER)
4128 return expr;
4129 if (ffebld_op (r) != FFEBLD_opCONTER)
4130 return expr;
4131
4132 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
4133 {
4134 case FFEINFO_basictypeANY:
4135 return expr;
4136
4137 case FFEINFO_basictypeINTEGER:
4138 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4139 {
4140 #if FFETARGET_okINTEGER1
4141 case FFEINFO_kindtypeINTEGER1:
4142 error = ffetarget_divide_integer1 (ffebld_cu_ptr_integer1 (u),
4143 ffebld_constant_integer1 (ffebld_conter (l)),
4144 ffebld_constant_integer1 (ffebld_conter (r)));
4145 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
4146 (ffebld_cu_val_integer1 (u)), expr);
4147 break;
4148 #endif
4149
4150 #if FFETARGET_okINTEGER2
4151 case FFEINFO_kindtypeINTEGER2:
4152 error = ffetarget_divide_integer2 (ffebld_cu_ptr_integer2 (u),
4153 ffebld_constant_integer2 (ffebld_conter (l)),
4154 ffebld_constant_integer2 (ffebld_conter (r)));
4155 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
4156 (ffebld_cu_val_integer2 (u)), expr);
4157 break;
4158 #endif
4159
4160 #if FFETARGET_okINTEGER3
4161 case FFEINFO_kindtypeINTEGER3:
4162 error = ffetarget_divide_integer3 (ffebld_cu_ptr_integer3 (u),
4163 ffebld_constant_integer3 (ffebld_conter (l)),
4164 ffebld_constant_integer3 (ffebld_conter (r)));
4165 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
4166 (ffebld_cu_val_integer3 (u)), expr);
4167 break;
4168 #endif
4169
4170 #if FFETARGET_okINTEGER4
4171 case FFEINFO_kindtypeINTEGER4:
4172 error = ffetarget_divide_integer4 (ffebld_cu_ptr_integer4 (u),
4173 ffebld_constant_integer4 (ffebld_conter (l)),
4174 ffebld_constant_integer4 (ffebld_conter (r)));
4175 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
4176 (ffebld_cu_val_integer4 (u)), expr);
4177 break;
4178 #endif
4179
4180 default:
4181 assert ("bad integer kind type" == NULL);
4182 break;
4183 }
4184 break;
4185
4186 case FFEINFO_basictypeREAL:
4187 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4188 {
4189 #if FFETARGET_okREAL1
4190 case FFEINFO_kindtypeREAL1:
4191 error = ffetarget_divide_real1 (ffebld_cu_ptr_real1 (u),
4192 ffebld_constant_real1 (ffebld_conter (l)),
4193 ffebld_constant_real1 (ffebld_conter (r)));
4194 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
4195 (ffebld_cu_val_real1 (u)), expr);
4196 break;
4197 #endif
4198
4199 #if FFETARGET_okREAL2
4200 case FFEINFO_kindtypeREAL2:
4201 error = ffetarget_divide_real2 (ffebld_cu_ptr_real2 (u),
4202 ffebld_constant_real2 (ffebld_conter (l)),
4203 ffebld_constant_real2 (ffebld_conter (r)));
4204 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
4205 (ffebld_cu_val_real2 (u)), expr);
4206 break;
4207 #endif
4208
4209 #if FFETARGET_okREAL3
4210 case FFEINFO_kindtypeREAL3:
4211 error = ffetarget_divide_real3 (ffebld_cu_ptr_real3 (u),
4212 ffebld_constant_real3 (ffebld_conter (l)),
4213 ffebld_constant_real3 (ffebld_conter (r)));
4214 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
4215 (ffebld_cu_val_real3 (u)), expr);
4216 break;
4217 #endif
4218
4219 #if FFETARGET_okREAL4
4220 case FFEINFO_kindtypeREAL4:
4221 error = ffetarget_divide_real4 (ffebld_cu_ptr_real4 (u),
4222 ffebld_constant_real4 (ffebld_conter (l)),
4223 ffebld_constant_real4 (ffebld_conter (r)));
4224 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
4225 (ffebld_cu_val_real4 (u)), expr);
4226 break;
4227 #endif
4228
4229 default:
4230 assert ("bad real kind type" == NULL);
4231 break;
4232 }
4233 break;
4234
4235 case FFEINFO_basictypeCOMPLEX:
4236 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4237 {
4238 #if FFETARGET_okCOMPLEX1
4239 case FFEINFO_kindtypeREAL1:
4240 error = ffetarget_divide_complex1 (ffebld_cu_ptr_complex1 (u),
4241 ffebld_constant_complex1 (ffebld_conter (l)),
4242 ffebld_constant_complex1 (ffebld_conter (r)));
4243 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
4244 (ffebld_cu_val_complex1 (u)), expr);
4245 break;
4246 #endif
4247
4248 #if FFETARGET_okCOMPLEX2
4249 case FFEINFO_kindtypeREAL2:
4250 error = ffetarget_divide_complex2 (ffebld_cu_ptr_complex2 (u),
4251 ffebld_constant_complex2 (ffebld_conter (l)),
4252 ffebld_constant_complex2 (ffebld_conter (r)));
4253 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
4254 (ffebld_cu_val_complex2 (u)), expr);
4255 break;
4256 #endif
4257
4258 #if FFETARGET_okCOMPLEX3
4259 case FFEINFO_kindtypeREAL3:
4260 error = ffetarget_divide_complex3 (ffebld_cu_ptr_complex3 (u),
4261 ffebld_constant_complex3 (ffebld_conter (l)),
4262 ffebld_constant_complex3 (ffebld_conter (r)));
4263 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
4264 (ffebld_cu_val_complex3 (u)), expr);
4265 break;
4266 #endif
4267
4268 #if FFETARGET_okCOMPLEX4
4269 case FFEINFO_kindtypeREAL4:
4270 error = ffetarget_divide_complex4 (ffebld_cu_ptr_complex4 (u),
4271 ffebld_constant_complex4 (ffebld_conter (l)),
4272 ffebld_constant_complex4 (ffebld_conter (r)));
4273 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
4274 (ffebld_cu_val_complex4 (u)), expr);
4275 break;
4276 #endif
4277
4278 default:
4279 assert ("bad complex kind type" == NULL);
4280 break;
4281 }
4282 break;
4283
4284 default:
4285 assert ("bad type" == NULL);
4286 return expr;
4287 }
4288
4289 ffebld_set_info (expr, ffeinfo_new
4290 (bt,
4291 kt,
4292 0,
4293 FFEINFO_kindENTITY,
4294 FFEINFO_whereCONSTANT,
4295 FFETARGET_charactersizeNONE));
4296
4297 if ((error != FFEBAD)
4298 && ffebad_start (error))
4299 {
4300 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4301 ffebad_finish ();
4302 }
4303
4304 return expr;
4305 }
4306
4307 /* ffeexpr_collapse_power -- Collapse power expr
4308
4309 ffebld expr;
4310 ffelexToken token;
4311 expr = ffeexpr_collapse_power(expr,token);
4312
4313 If the result of the expr is a constant, replaces the expr with the
4314 computed constant. */
4315
4316 ffebld
4317 ffeexpr_collapse_power (ffebld expr, ffelexToken t)
4318 {
4319 ffebad error = FFEBAD;
4320 ffebld l;
4321 ffebld r;
4322 ffebldConstantUnion u;
4323 ffeinfoBasictype bt;
4324 ffeinfoKindtype kt;
4325
4326 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4327 return expr;
4328
4329 l = ffebld_left (expr);
4330 r = ffebld_right (expr);
4331
4332 if (ffebld_op (l) != FFEBLD_opCONTER)
4333 return expr;
4334 if (ffebld_op (r) != FFEBLD_opCONTER)
4335 return expr;
4336
4337 if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER)
4338 || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT))
4339 return expr;
4340
4341 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
4342 {
4343 case FFEINFO_basictypeANY:
4344 return expr;
4345
4346 case FFEINFO_basictypeINTEGER:
4347 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4348 {
4349 case FFEINFO_kindtypeINTEGERDEFAULT:
4350 error = ffetarget_power_integerdefault_integerdefault
4351 (ffebld_cu_ptr_integerdefault (u),
4352 ffebld_constant_integerdefault (ffebld_conter (l)),
4353 ffebld_constant_integerdefault (ffebld_conter (r)));
4354 expr = ffebld_new_conter_with_orig
4355 (ffebld_constant_new_integerdefault_val
4356 (ffebld_cu_val_integerdefault (u)), expr);
4357 break;
4358
4359 default:
4360 assert ("bad integer kind type" == NULL);
4361 break;
4362 }
4363 break;
4364
4365 case FFEINFO_basictypeREAL:
4366 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4367 {
4368 case FFEINFO_kindtypeREALDEFAULT:
4369 error = ffetarget_power_realdefault_integerdefault
4370 (ffebld_cu_ptr_realdefault (u),
4371 ffebld_constant_realdefault (ffebld_conter (l)),
4372 ffebld_constant_integerdefault (ffebld_conter (r)));
4373 expr = ffebld_new_conter_with_orig
4374 (ffebld_constant_new_realdefault_val
4375 (ffebld_cu_val_realdefault (u)), expr);
4376 break;
4377
4378 case FFEINFO_kindtypeREALDOUBLE:
4379 error = ffetarget_power_realdouble_integerdefault
4380 (ffebld_cu_ptr_realdouble (u),
4381 ffebld_constant_realdouble (ffebld_conter (l)),
4382 ffebld_constant_integerdefault (ffebld_conter (r)));
4383 expr = ffebld_new_conter_with_orig
4384 (ffebld_constant_new_realdouble_val
4385 (ffebld_cu_val_realdouble (u)), expr);
4386 break;
4387
4388 #if FFETARGET_okREALQUAD
4389 case FFEINFO_kindtypeREALQUAD:
4390 error = ffetarget_power_realquad_integerdefault
4391 (ffebld_cu_ptr_realquad (u),
4392 ffebld_constant_realquad (ffebld_conter (l)),
4393 ffebld_constant_integerdefault (ffebld_conter (r)));
4394 expr = ffebld_new_conter_with_orig
4395 (ffebld_constant_new_realquad_val
4396 (ffebld_cu_val_realquad (u)), expr);
4397 break;
4398 #endif
4399 default:
4400 assert ("bad real kind type" == NULL);
4401 break;
4402 }
4403 break;
4404
4405 case FFEINFO_basictypeCOMPLEX:
4406 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4407 {
4408 case FFEINFO_kindtypeREALDEFAULT:
4409 error = ffetarget_power_complexdefault_integerdefault
4410 (ffebld_cu_ptr_complexdefault (u),
4411 ffebld_constant_complexdefault (ffebld_conter (l)),
4412 ffebld_constant_integerdefault (ffebld_conter (r)));
4413 expr = ffebld_new_conter_with_orig
4414 (ffebld_constant_new_complexdefault_val
4415 (ffebld_cu_val_complexdefault (u)), expr);
4416 break;
4417
4418 #if FFETARGET_okCOMPLEXDOUBLE
4419 case FFEINFO_kindtypeREALDOUBLE:
4420 error = ffetarget_power_complexdouble_integerdefault
4421 (ffebld_cu_ptr_complexdouble (u),
4422 ffebld_constant_complexdouble (ffebld_conter (l)),
4423 ffebld_constant_integerdefault (ffebld_conter (r)));
4424 expr = ffebld_new_conter_with_orig
4425 (ffebld_constant_new_complexdouble_val
4426 (ffebld_cu_val_complexdouble (u)), expr);
4427 break;
4428 #endif
4429
4430 #if FFETARGET_okCOMPLEXQUAD
4431 case FFEINFO_kindtypeREALQUAD:
4432 error = ffetarget_power_complexquad_integerdefault
4433 (ffebld_cu_ptr_complexquad (u),
4434 ffebld_constant_complexquad (ffebld_conter (l)),
4435 ffebld_constant_integerdefault (ffebld_conter (r)));
4436 expr = ffebld_new_conter_with_orig
4437 (ffebld_constant_new_complexquad_val
4438 (ffebld_cu_val_complexquad (u)), expr);
4439 break;
4440 #endif
4441
4442 default:
4443 assert ("bad complex kind type" == NULL);
4444 break;
4445 }
4446 break;
4447
4448 default:
4449 assert ("bad type" == NULL);
4450 return expr;
4451 }
4452
4453 ffebld_set_info (expr, ffeinfo_new
4454 (bt,
4455 kt,
4456 0,
4457 FFEINFO_kindENTITY,
4458 FFEINFO_whereCONSTANT,
4459 FFETARGET_charactersizeNONE));
4460
4461 if ((error != FFEBAD)
4462 && ffebad_start (error))
4463 {
4464 ffebad_here (0, ffelex_token_where_line (t),
4465 ffelex_token_where_column (t));
4466 ffebad_finish ();
4467 }
4468
4469 return expr;
4470 }
4471
4472 /* ffeexpr_collapse_concatenate -- Collapse concatenate expr
4473
4474 ffebld expr;
4475 ffelexToken token;
4476 expr = ffeexpr_collapse_concatenate(expr,token);
4477
4478 If the result of the expr is a constant, replaces the expr with the
4479 computed constant. */
4480
4481 ffebld
4482 ffeexpr_collapse_concatenate (ffebld expr, ffelexToken t)
4483 {
4484 ffebad error = FFEBAD;
4485 ffebld l;
4486 ffebld r;
4487 ffebldConstantUnion u;
4488 ffeinfoKindtype kt;
4489 ffetargetCharacterSize len;
4490
4491 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4492 return expr;
4493
4494 l = ffebld_left (expr);
4495 r = ffebld_right (expr);
4496
4497 if (ffebld_op (l) != FFEBLD_opCONTER)
4498 return expr;
4499 if (ffebld_op (r) != FFEBLD_opCONTER)
4500 return expr;
4501
4502 switch (ffeinfo_basictype (ffebld_info (expr)))
4503 {
4504 case FFEINFO_basictypeANY:
4505 return expr;
4506
4507 case FFEINFO_basictypeCHARACTER:
4508 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4509 {
4510 #if FFETARGET_okCHARACTER1
4511 case FFEINFO_kindtypeCHARACTER1:
4512 error = ffetarget_concatenate_character1 (ffebld_cu_ptr_character1 (u),
4513 ffebld_constant_character1 (ffebld_conter (l)),
4514 ffebld_constant_character1 (ffebld_conter (r)),
4515 ffebld_constant_pool (), &len);
4516 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
4517 (ffebld_cu_val_character1 (u)), expr);
4518 break;
4519 #endif
4520
4521 #if FFETARGET_okCHARACTER2
4522 case FFEINFO_kindtypeCHARACTER2:
4523 error = ffetarget_concatenate_character2 (ffebld_cu_ptr_character2 (u),
4524 ffebld_constant_character2 (ffebld_conter (l)),
4525 ffebld_constant_character2 (ffebld_conter (r)),
4526 ffebld_constant_pool (), &len);
4527 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val
4528 (ffebld_cu_val_character2 (u)), expr);
4529 break;
4530 #endif
4531
4532 #if FFETARGET_okCHARACTER3
4533 case FFEINFO_kindtypeCHARACTER3:
4534 error = ffetarget_concatenate_character3 (ffebld_cu_ptr_character3 (u),
4535 ffebld_constant_character3 (ffebld_conter (l)),
4536 ffebld_constant_character3 (ffebld_conter (r)),
4537 ffebld_constant_pool (), &len);
4538 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val
4539 (ffebld_cu_val_character3 (u)), expr);
4540 break;
4541 #endif
4542
4543 #if FFETARGET_okCHARACTER4
4544 case FFEINFO_kindtypeCHARACTER4:
4545 error = ffetarget_concatenate_character4 (ffebld_cu_ptr_character4 (u),
4546 ffebld_constant_character4 (ffebld_conter (l)),
4547 ffebld_constant_character4 (ffebld_conter (r)),
4548 ffebld_constant_pool (), &len);
4549 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val
4550 (ffebld_cu_val_character4 (u)), expr);
4551 break;
4552 #endif
4553
4554 default:
4555 assert ("bad character kind type" == NULL);
4556 break;
4557 }
4558 break;
4559
4560 default:
4561 assert ("bad type" == NULL);
4562 return expr;
4563 }
4564
4565 ffebld_set_info (expr, ffeinfo_new
4566 (FFEINFO_basictypeCHARACTER,
4567 kt,
4568 0,
4569 FFEINFO_kindENTITY,
4570 FFEINFO_whereCONSTANT,
4571 len));
4572
4573 if ((error != FFEBAD)
4574 && ffebad_start (error))
4575 {
4576 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4577 ffebad_finish ();
4578 }
4579
4580 return expr;
4581 }
4582
4583 /* ffeexpr_collapse_eq -- Collapse eq expr
4584
4585 ffebld expr;
4586 ffelexToken token;
4587 expr = ffeexpr_collapse_eq(expr,token);
4588
4589 If the result of the expr is a constant, replaces the expr with the
4590 computed constant. */
4591
4592 ffebld
4593 ffeexpr_collapse_eq (ffebld expr, ffelexToken t)
4594 {
4595 ffebad error = FFEBAD;
4596 ffebld l;
4597 ffebld r;
4598 bool val;
4599
4600 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4601 return expr;
4602
4603 l = ffebld_left (expr);
4604 r = ffebld_right (expr);
4605
4606 if (ffebld_op (l) != FFEBLD_opCONTER)
4607 return expr;
4608 if (ffebld_op (r) != FFEBLD_opCONTER)
4609 return expr;
4610
4611 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4612 {
4613 case FFEINFO_basictypeANY:
4614 return expr;
4615
4616 case FFEINFO_basictypeINTEGER:
4617 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4618 {
4619 #if FFETARGET_okINTEGER1
4620 case FFEINFO_kindtypeINTEGER1:
4621 error = ffetarget_eq_integer1 (&val,
4622 ffebld_constant_integer1 (ffebld_conter (l)),
4623 ffebld_constant_integer1 (ffebld_conter (r)));
4624 expr = ffebld_new_conter_with_orig
4625 (ffebld_constant_new_logicaldefault (val), expr);
4626 break;
4627 #endif
4628
4629 #if FFETARGET_okINTEGER2
4630 case FFEINFO_kindtypeINTEGER2:
4631 error = ffetarget_eq_integer2 (&val,
4632 ffebld_constant_integer2 (ffebld_conter (l)),
4633 ffebld_constant_integer2 (ffebld_conter (r)));
4634 expr = ffebld_new_conter_with_orig
4635 (ffebld_constant_new_logicaldefault (val), expr);
4636 break;
4637 #endif
4638
4639 #if FFETARGET_okINTEGER3
4640 case FFEINFO_kindtypeINTEGER3:
4641 error = ffetarget_eq_integer3 (&val,
4642 ffebld_constant_integer3 (ffebld_conter (l)),
4643 ffebld_constant_integer3 (ffebld_conter (r)));
4644 expr = ffebld_new_conter_with_orig
4645 (ffebld_constant_new_logicaldefault (val), expr);
4646 break;
4647 #endif
4648
4649 #if FFETARGET_okINTEGER4
4650 case FFEINFO_kindtypeINTEGER4:
4651 error = ffetarget_eq_integer4 (&val,
4652 ffebld_constant_integer4 (ffebld_conter (l)),
4653 ffebld_constant_integer4 (ffebld_conter (r)));
4654 expr = ffebld_new_conter_with_orig
4655 (ffebld_constant_new_logicaldefault (val), expr);
4656 break;
4657 #endif
4658
4659 default:
4660 assert ("bad integer kind type" == NULL);
4661 break;
4662 }
4663 break;
4664
4665 case FFEINFO_basictypeREAL:
4666 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4667 {
4668 #if FFETARGET_okREAL1
4669 case FFEINFO_kindtypeREAL1:
4670 error = ffetarget_eq_real1 (&val,
4671 ffebld_constant_real1 (ffebld_conter (l)),
4672 ffebld_constant_real1 (ffebld_conter (r)));
4673 expr = ffebld_new_conter_with_orig
4674 (ffebld_constant_new_logicaldefault (val), expr);
4675 break;
4676 #endif
4677
4678 #if FFETARGET_okREAL2
4679 case FFEINFO_kindtypeREAL2:
4680 error = ffetarget_eq_real2 (&val,
4681 ffebld_constant_real2 (ffebld_conter (l)),
4682 ffebld_constant_real2 (ffebld_conter (r)));
4683 expr = ffebld_new_conter_with_orig
4684 (ffebld_constant_new_logicaldefault (val), expr);
4685 break;
4686 #endif
4687
4688 #if FFETARGET_okREAL3
4689 case FFEINFO_kindtypeREAL3:
4690 error = ffetarget_eq_real3 (&val,
4691 ffebld_constant_real3 (ffebld_conter (l)),
4692 ffebld_constant_real3 (ffebld_conter (r)));
4693 expr = ffebld_new_conter_with_orig
4694 (ffebld_constant_new_logicaldefault (val), expr);
4695 break;
4696 #endif
4697
4698 #if FFETARGET_okREAL4
4699 case FFEINFO_kindtypeREAL4:
4700 error = ffetarget_eq_real4 (&val,
4701 ffebld_constant_real4 (ffebld_conter (l)),
4702 ffebld_constant_real4 (ffebld_conter (r)));
4703 expr = ffebld_new_conter_with_orig
4704 (ffebld_constant_new_logicaldefault (val), expr);
4705 break;
4706 #endif
4707
4708 default:
4709 assert ("bad real kind type" == NULL);
4710 break;
4711 }
4712 break;
4713
4714 case FFEINFO_basictypeCOMPLEX:
4715 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4716 {
4717 #if FFETARGET_okCOMPLEX1
4718 case FFEINFO_kindtypeREAL1:
4719 error = ffetarget_eq_complex1 (&val,
4720 ffebld_constant_complex1 (ffebld_conter (l)),
4721 ffebld_constant_complex1 (ffebld_conter (r)));
4722 expr = ffebld_new_conter_with_orig
4723 (ffebld_constant_new_logicaldefault (val), expr);
4724 break;
4725 #endif
4726
4727 #if FFETARGET_okCOMPLEX2
4728 case FFEINFO_kindtypeREAL2:
4729 error = ffetarget_eq_complex2 (&val,
4730 ffebld_constant_complex2 (ffebld_conter (l)),
4731 ffebld_constant_complex2 (ffebld_conter (r)));
4732 expr = ffebld_new_conter_with_orig
4733 (ffebld_constant_new_logicaldefault (val), expr);
4734 break;
4735 #endif
4736
4737 #if FFETARGET_okCOMPLEX3
4738 case FFEINFO_kindtypeREAL3:
4739 error = ffetarget_eq_complex3 (&val,
4740 ffebld_constant_complex3 (ffebld_conter (l)),
4741 ffebld_constant_complex3 (ffebld_conter (r)));
4742 expr = ffebld_new_conter_with_orig
4743 (ffebld_constant_new_logicaldefault (val), expr);
4744 break;
4745 #endif
4746
4747 #if FFETARGET_okCOMPLEX4
4748 case FFEINFO_kindtypeREAL4:
4749 error = ffetarget_eq_complex4 (&val,
4750 ffebld_constant_complex4 (ffebld_conter (l)),
4751 ffebld_constant_complex4 (ffebld_conter (r)));
4752 expr = ffebld_new_conter_with_orig
4753 (ffebld_constant_new_logicaldefault (val), expr);
4754 break;
4755 #endif
4756
4757 default:
4758 assert ("bad complex kind type" == NULL);
4759 break;
4760 }
4761 break;
4762
4763 case FFEINFO_basictypeCHARACTER:
4764 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4765 {
4766 #if FFETARGET_okCHARACTER1
4767 case FFEINFO_kindtypeCHARACTER1:
4768 error = ffetarget_eq_character1 (&val,
4769 ffebld_constant_character1 (ffebld_conter (l)),
4770 ffebld_constant_character1 (ffebld_conter (r)));
4771 expr = ffebld_new_conter_with_orig
4772 (ffebld_constant_new_logicaldefault (val), expr);
4773 break;
4774 #endif
4775
4776 #if FFETARGET_okCHARACTER2
4777 case FFEINFO_kindtypeCHARACTER2:
4778 error = ffetarget_eq_character2 (&val,
4779 ffebld_constant_character2 (ffebld_conter (l)),
4780 ffebld_constant_character2 (ffebld_conter (r)));
4781 expr = ffebld_new_conter_with_orig
4782 (ffebld_constant_new_logicaldefault (val), expr);
4783 break;
4784 #endif
4785
4786 #if FFETARGET_okCHARACTER3
4787 case FFEINFO_kindtypeCHARACTER3:
4788 error = ffetarget_eq_character3 (&val,
4789 ffebld_constant_character3 (ffebld_conter (l)),
4790 ffebld_constant_character3 (ffebld_conter (r)));
4791 expr = ffebld_new_conter_with_orig
4792 (ffebld_constant_new_logicaldefault (val), expr);
4793 break;
4794 #endif
4795
4796 #if FFETARGET_okCHARACTER4
4797 case FFEINFO_kindtypeCHARACTER4:
4798 error = ffetarget_eq_character4 (&val,
4799 ffebld_constant_character4 (ffebld_conter (l)),
4800 ffebld_constant_character4 (ffebld_conter (r)));
4801 expr = ffebld_new_conter_with_orig
4802 (ffebld_constant_new_logicaldefault (val), expr);
4803 break;
4804 #endif
4805
4806 default:
4807 assert ("bad character kind type" == NULL);
4808 break;
4809 }
4810 break;
4811
4812 default:
4813 assert ("bad type" == NULL);
4814 return expr;
4815 }
4816
4817 ffebld_set_info (expr, ffeinfo_new
4818 (FFEINFO_basictypeLOGICAL,
4819 FFEINFO_kindtypeLOGICALDEFAULT,
4820 0,
4821 FFEINFO_kindENTITY,
4822 FFEINFO_whereCONSTANT,
4823 FFETARGET_charactersizeNONE));
4824
4825 if ((error != FFEBAD)
4826 && ffebad_start (error))
4827 {
4828 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4829 ffebad_finish ();
4830 }
4831
4832 return expr;
4833 }
4834
4835 /* ffeexpr_collapse_ne -- Collapse ne expr
4836
4837 ffebld expr;
4838 ffelexToken token;
4839 expr = ffeexpr_collapse_ne(expr,token);
4840
4841 If the result of the expr is a constant, replaces the expr with the
4842 computed constant. */
4843
4844 ffebld
4845 ffeexpr_collapse_ne (ffebld expr, ffelexToken t)
4846 {
4847 ffebad error = FFEBAD;
4848 ffebld l;
4849 ffebld r;
4850 bool val;
4851
4852 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4853 return expr;
4854
4855 l = ffebld_left (expr);
4856 r = ffebld_right (expr);
4857
4858 if (ffebld_op (l) != FFEBLD_opCONTER)
4859 return expr;
4860 if (ffebld_op (r) != FFEBLD_opCONTER)
4861 return expr;
4862
4863 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4864 {
4865 case FFEINFO_basictypeANY:
4866 return expr;
4867
4868 case FFEINFO_basictypeINTEGER:
4869 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4870 {
4871 #if FFETARGET_okINTEGER1
4872 case FFEINFO_kindtypeINTEGER1:
4873 error = ffetarget_ne_integer1 (&val,
4874 ffebld_constant_integer1 (ffebld_conter (l)),
4875 ffebld_constant_integer1 (ffebld_conter (r)));
4876 expr = ffebld_new_conter_with_orig
4877 (ffebld_constant_new_logicaldefault (val), expr);
4878 break;
4879 #endif
4880
4881 #if FFETARGET_okINTEGER2
4882 case FFEINFO_kindtypeINTEGER2:
4883 error = ffetarget_ne_integer2 (&val,
4884 ffebld_constant_integer2 (ffebld_conter (l)),
4885 ffebld_constant_integer2 (ffebld_conter (r)));
4886 expr = ffebld_new_conter_with_orig
4887 (ffebld_constant_new_logicaldefault (val), expr);
4888 break;
4889 #endif
4890
4891 #if FFETARGET_okINTEGER3
4892 case FFEINFO_kindtypeINTEGER3:
4893 error = ffetarget_ne_integer3 (&val,
4894 ffebld_constant_integer3 (ffebld_conter (l)),
4895 ffebld_constant_integer3 (ffebld_conter (r)));
4896 expr = ffebld_new_conter_with_orig
4897 (ffebld_constant_new_logicaldefault (val), expr);
4898 break;
4899 #endif
4900
4901 #if FFETARGET_okINTEGER4
4902 case FFEINFO_kindtypeINTEGER4:
4903 error = ffetarget_ne_integer4 (&val,
4904 ffebld_constant_integer4 (ffebld_conter (l)),
4905 ffebld_constant_integer4 (ffebld_conter (r)));
4906 expr = ffebld_new_conter_with_orig
4907 (ffebld_constant_new_logicaldefault (val), expr);
4908 break;
4909 #endif
4910
4911 default:
4912 assert ("bad integer kind type" == NULL);
4913 break;
4914 }
4915 break;
4916
4917 case FFEINFO_basictypeREAL:
4918 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4919 {
4920 #if FFETARGET_okREAL1
4921 case FFEINFO_kindtypeREAL1:
4922 error = ffetarget_ne_real1 (&val,
4923 ffebld_constant_real1 (ffebld_conter (l)),
4924 ffebld_constant_real1 (ffebld_conter (r)));
4925 expr = ffebld_new_conter_with_orig
4926 (ffebld_constant_new_logicaldefault (val), expr);
4927 break;
4928 #endif
4929
4930 #if FFETARGET_okREAL2
4931 case FFEINFO_kindtypeREAL2:
4932 error = ffetarget_ne_real2 (&val,
4933 ffebld_constant_real2 (ffebld_conter (l)),
4934 ffebld_constant_real2 (ffebld_conter (r)));
4935 expr = ffebld_new_conter_with_orig
4936 (ffebld_constant_new_logicaldefault (val), expr);
4937 break;
4938 #endif
4939
4940 #if FFETARGET_okREAL3
4941 case FFEINFO_kindtypeREAL3:
4942 error = ffetarget_ne_real3 (&val,
4943 ffebld_constant_real3 (ffebld_conter (l)),
4944 ffebld_constant_real3 (ffebld_conter (r)));
4945 expr = ffebld_new_conter_with_orig
4946 (ffebld_constant_new_logicaldefault (val), expr);
4947 break;
4948 #endif
4949
4950 #if FFETARGET_okREAL4
4951 case FFEINFO_kindtypeREAL4:
4952 error = ffetarget_ne_real4 (&val,
4953 ffebld_constant_real4 (ffebld_conter (l)),
4954 ffebld_constant_real4 (ffebld_conter (r)));
4955 expr = ffebld_new_conter_with_orig
4956 (ffebld_constant_new_logicaldefault (val), expr);
4957 break;
4958 #endif
4959
4960 default:
4961 assert ("bad real kind type" == NULL);
4962 break;
4963 }
4964 break;
4965
4966 case FFEINFO_basictypeCOMPLEX:
4967 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4968 {
4969 #if FFETARGET_okCOMPLEX1
4970 case FFEINFO_kindtypeREAL1:
4971 error = ffetarget_ne_complex1 (&val,
4972 ffebld_constant_complex1 (ffebld_conter (l)),
4973 ffebld_constant_complex1 (ffebld_conter (r)));
4974 expr = ffebld_new_conter_with_orig
4975 (ffebld_constant_new_logicaldefault (val), expr);
4976 break;
4977 #endif
4978
4979 #if FFETARGET_okCOMPLEX2
4980 case FFEINFO_kindtypeREAL2:
4981 error = ffetarget_ne_complex2 (&val,
4982 ffebld_constant_complex2 (ffebld_conter (l)),
4983 ffebld_constant_complex2 (ffebld_conter (r)));
4984 expr = ffebld_new_conter_with_orig
4985 (ffebld_constant_new_logicaldefault (val), expr);
4986 break;
4987 #endif
4988
4989 #if FFETARGET_okCOMPLEX3
4990 case FFEINFO_kindtypeREAL3:
4991 error = ffetarget_ne_complex3 (&val,
4992 ffebld_constant_complex3 (ffebld_conter (l)),
4993 ffebld_constant_complex3 (ffebld_conter (r)));
4994 expr = ffebld_new_conter_with_orig
4995 (ffebld_constant_new_logicaldefault (val), expr);
4996 break;
4997 #endif
4998
4999 #if FFETARGET_okCOMPLEX4
5000 case FFEINFO_kindtypeREAL4:
5001 error = ffetarget_ne_complex4 (&val,
5002 ffebld_constant_complex4 (ffebld_conter (l)),
5003 ffebld_constant_complex4 (ffebld_conter (r)));
5004 expr = ffebld_new_conter_with_orig
5005 (ffebld_constant_new_logicaldefault (val), expr);
5006 break;
5007 #endif
5008
5009 default:
5010 assert ("bad complex kind type" == NULL);
5011 break;
5012 }
5013 break;
5014
5015 case FFEINFO_basictypeCHARACTER:
5016 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5017 {
5018 #if FFETARGET_okCHARACTER1
5019 case FFEINFO_kindtypeCHARACTER1:
5020 error = ffetarget_ne_character1 (&val,
5021 ffebld_constant_character1 (ffebld_conter (l)),
5022 ffebld_constant_character1 (ffebld_conter (r)));
5023 expr = ffebld_new_conter_with_orig
5024 (ffebld_constant_new_logicaldefault (val), expr);
5025 break;
5026 #endif
5027
5028 #if FFETARGET_okCHARACTER2
5029 case FFEINFO_kindtypeCHARACTER2:
5030 error = ffetarget_ne_character2 (&val,
5031 ffebld_constant_character2 (ffebld_conter (l)),
5032 ffebld_constant_character2 (ffebld_conter (r)));
5033 expr = ffebld_new_conter_with_orig
5034 (ffebld_constant_new_logicaldefault (val), expr);
5035 break;
5036 #endif
5037
5038 #if FFETARGET_okCHARACTER3
5039 case FFEINFO_kindtypeCHARACTER3:
5040 error = ffetarget_ne_character3 (&val,
5041 ffebld_constant_character3 (ffebld_conter (l)),
5042 ffebld_constant_character3 (ffebld_conter (r)));
5043 expr = ffebld_new_conter_with_orig
5044 (ffebld_constant_new_logicaldefault (val), expr);
5045 break;
5046 #endif
5047
5048 #if FFETARGET_okCHARACTER4
5049 case FFEINFO_kindtypeCHARACTER4:
5050 error = ffetarget_ne_character4 (&val,
5051 ffebld_constant_character4 (ffebld_conter (l)),
5052 ffebld_constant_character4 (ffebld_conter (r)));
5053 expr = ffebld_new_conter_with_orig
5054 (ffebld_constant_new_logicaldefault (val), expr);
5055 break;
5056 #endif
5057
5058 default:
5059 assert ("bad character kind type" == NULL);
5060 break;
5061 }
5062 break;
5063
5064 default:
5065 assert ("bad type" == NULL);
5066 return expr;
5067 }
5068
5069 ffebld_set_info (expr, ffeinfo_new
5070 (FFEINFO_basictypeLOGICAL,
5071 FFEINFO_kindtypeLOGICALDEFAULT,
5072 0,
5073 FFEINFO_kindENTITY,
5074 FFEINFO_whereCONSTANT,
5075 FFETARGET_charactersizeNONE));
5076
5077 if ((error != FFEBAD)
5078 && ffebad_start (error))
5079 {
5080 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5081 ffebad_finish ();
5082 }
5083
5084 return expr;
5085 }
5086
5087 /* ffeexpr_collapse_ge -- Collapse ge expr
5088
5089 ffebld expr;
5090 ffelexToken token;
5091 expr = ffeexpr_collapse_ge(expr,token);
5092
5093 If the result of the expr is a constant, replaces the expr with the
5094 computed constant. */
5095
5096 ffebld
5097 ffeexpr_collapse_ge (ffebld expr, ffelexToken t)
5098 {
5099 ffebad error = FFEBAD;
5100 ffebld l;
5101 ffebld r;
5102 bool val;
5103
5104 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5105 return expr;
5106
5107 l = ffebld_left (expr);
5108 r = ffebld_right (expr);
5109
5110 if (ffebld_op (l) != FFEBLD_opCONTER)
5111 return expr;
5112 if (ffebld_op (r) != FFEBLD_opCONTER)
5113 return expr;
5114
5115 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5116 {
5117 case FFEINFO_basictypeANY:
5118 return expr;
5119
5120 case FFEINFO_basictypeINTEGER:
5121 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5122 {
5123 #if FFETARGET_okINTEGER1
5124 case FFEINFO_kindtypeINTEGER1:
5125 error = ffetarget_ge_integer1 (&val,
5126 ffebld_constant_integer1 (ffebld_conter (l)),
5127 ffebld_constant_integer1 (ffebld_conter (r)));
5128 expr = ffebld_new_conter_with_orig
5129 (ffebld_constant_new_logicaldefault (val), expr);
5130 break;
5131 #endif
5132
5133 #if FFETARGET_okINTEGER2
5134 case FFEINFO_kindtypeINTEGER2:
5135 error = ffetarget_ge_integer2 (&val,
5136 ffebld_constant_integer2 (ffebld_conter (l)),
5137 ffebld_constant_integer2 (ffebld_conter (r)));
5138 expr = ffebld_new_conter_with_orig
5139 (ffebld_constant_new_logicaldefault (val), expr);
5140 break;
5141 #endif
5142
5143 #if FFETARGET_okINTEGER3
5144 case FFEINFO_kindtypeINTEGER3:
5145 error = ffetarget_ge_integer3 (&val,
5146 ffebld_constant_integer3 (ffebld_conter (l)),
5147 ffebld_constant_integer3 (ffebld_conter (r)));
5148 expr = ffebld_new_conter_with_orig
5149 (ffebld_constant_new_logicaldefault (val), expr);
5150 break;
5151 #endif
5152
5153 #if FFETARGET_okINTEGER4
5154 case FFEINFO_kindtypeINTEGER4:
5155 error = ffetarget_ge_integer4 (&val,
5156 ffebld_constant_integer4 (ffebld_conter (l)),
5157 ffebld_constant_integer4 (ffebld_conter (r)));
5158 expr = ffebld_new_conter_with_orig
5159 (ffebld_constant_new_logicaldefault (val), expr);
5160 break;
5161 #endif
5162
5163 default:
5164 assert ("bad integer kind type" == NULL);
5165 break;
5166 }
5167 break;
5168
5169 case FFEINFO_basictypeREAL:
5170 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5171 {
5172 #if FFETARGET_okREAL1
5173 case FFEINFO_kindtypeREAL1:
5174 error = ffetarget_ge_real1 (&val,
5175 ffebld_constant_real1 (ffebld_conter (l)),
5176 ffebld_constant_real1 (ffebld_conter (r)));
5177 expr = ffebld_new_conter_with_orig
5178 (ffebld_constant_new_logicaldefault (val), expr);
5179 break;
5180 #endif
5181
5182 #if FFETARGET_okREAL2
5183 case FFEINFO_kindtypeREAL2:
5184 error = ffetarget_ge_real2 (&val,
5185 ffebld_constant_real2 (ffebld_conter (l)),
5186 ffebld_constant_real2 (ffebld_conter (r)));
5187 expr = ffebld_new_conter_with_orig
5188 (ffebld_constant_new_logicaldefault (val), expr);
5189 break;
5190 #endif
5191
5192 #if FFETARGET_okREAL3
5193 case FFEINFO_kindtypeREAL3:
5194 error = ffetarget_ge_real3 (&val,
5195 ffebld_constant_real3 (ffebld_conter (l)),
5196 ffebld_constant_real3 (ffebld_conter (r)));
5197 expr = ffebld_new_conter_with_orig
5198 (ffebld_constant_new_logicaldefault (val), expr);
5199 break;
5200 #endif
5201
5202 #if FFETARGET_okREAL4
5203 case FFEINFO_kindtypeREAL4:
5204 error = ffetarget_ge_real4 (&val,
5205 ffebld_constant_real4 (ffebld_conter (l)),
5206 ffebld_constant_real4 (ffebld_conter (r)));
5207 expr = ffebld_new_conter_with_orig
5208 (ffebld_constant_new_logicaldefault (val), expr);
5209 break;
5210 #endif
5211
5212 default:
5213 assert ("bad real kind type" == NULL);
5214 break;
5215 }
5216 break;
5217
5218 case FFEINFO_basictypeCHARACTER:
5219 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5220 {
5221 #if FFETARGET_okCHARACTER1
5222 case FFEINFO_kindtypeCHARACTER1:
5223 error = ffetarget_ge_character1 (&val,
5224 ffebld_constant_character1 (ffebld_conter (l)),
5225 ffebld_constant_character1 (ffebld_conter (r)));
5226 expr = ffebld_new_conter_with_orig
5227 (ffebld_constant_new_logicaldefault (val), expr);
5228 break;
5229 #endif
5230
5231 #if FFETARGET_okCHARACTER2
5232 case FFEINFO_kindtypeCHARACTER2:
5233 error = ffetarget_ge_character2 (&val,
5234 ffebld_constant_character2 (ffebld_conter (l)),
5235 ffebld_constant_character2 (ffebld_conter (r)));
5236 expr = ffebld_new_conter_with_orig
5237 (ffebld_constant_new_logicaldefault (val), expr);
5238 break;
5239 #endif
5240
5241 #if FFETARGET_okCHARACTER3
5242 case FFEINFO_kindtypeCHARACTER3:
5243 error = ffetarget_ge_character3 (&val,
5244 ffebld_constant_character3 (ffebld_conter (l)),
5245 ffebld_constant_character3 (ffebld_conter (r)));
5246 expr = ffebld_new_conter_with_orig
5247 (ffebld_constant_new_logicaldefault (val), expr);
5248 break;
5249 #endif
5250
5251 #if FFETARGET_okCHARACTER4
5252 case FFEINFO_kindtypeCHARACTER4:
5253 error = ffetarget_ge_character4 (&val,
5254 ffebld_constant_character4 (ffebld_conter (l)),
5255 ffebld_constant_character4 (ffebld_conter (r)));
5256 expr = ffebld_new_conter_with_orig
5257 (ffebld_constant_new_logicaldefault (val), expr);
5258 break;
5259 #endif
5260
5261 default:
5262 assert ("bad character kind type" == NULL);
5263 break;
5264 }
5265 break;
5266
5267 default:
5268 assert ("bad type" == NULL);
5269 return expr;
5270 }
5271
5272 ffebld_set_info (expr, ffeinfo_new
5273 (FFEINFO_basictypeLOGICAL,
5274 FFEINFO_kindtypeLOGICALDEFAULT,
5275 0,
5276 FFEINFO_kindENTITY,
5277 FFEINFO_whereCONSTANT,
5278 FFETARGET_charactersizeNONE));
5279
5280 if ((error != FFEBAD)
5281 && ffebad_start (error))
5282 {
5283 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5284 ffebad_finish ();
5285 }
5286
5287 return expr;
5288 }
5289
5290 /* ffeexpr_collapse_gt -- Collapse gt expr
5291
5292 ffebld expr;
5293 ffelexToken token;
5294 expr = ffeexpr_collapse_gt(expr,token);
5295
5296 If the result of the expr is a constant, replaces the expr with the
5297 computed constant. */
5298
5299 ffebld
5300 ffeexpr_collapse_gt (ffebld expr, ffelexToken t)
5301 {
5302 ffebad error = FFEBAD;
5303 ffebld l;
5304 ffebld r;
5305 bool val;
5306
5307 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5308 return expr;
5309
5310 l = ffebld_left (expr);
5311 r = ffebld_right (expr);
5312
5313 if (ffebld_op (l) != FFEBLD_opCONTER)
5314 return expr;
5315 if (ffebld_op (r) != FFEBLD_opCONTER)
5316 return expr;
5317
5318 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5319 {
5320 case FFEINFO_basictypeANY:
5321 return expr;
5322
5323 case FFEINFO_basictypeINTEGER:
5324 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5325 {
5326 #if FFETARGET_okINTEGER1
5327 case FFEINFO_kindtypeINTEGER1:
5328 error = ffetarget_gt_integer1 (&val,
5329 ffebld_constant_integer1 (ffebld_conter (l)),
5330 ffebld_constant_integer1 (ffebld_conter (r)));
5331 expr = ffebld_new_conter_with_orig
5332 (ffebld_constant_new_logicaldefault (val), expr);
5333 break;
5334 #endif
5335
5336 #if FFETARGET_okINTEGER2
5337 case FFEINFO_kindtypeINTEGER2:
5338 error = ffetarget_gt_integer2 (&val,
5339 ffebld_constant_integer2 (ffebld_conter (l)),
5340 ffebld_constant_integer2 (ffebld_conter (r)));
5341 expr = ffebld_new_conter_with_orig
5342 (ffebld_constant_new_logicaldefault (val), expr);
5343 break;
5344 #endif
5345
5346 #if FFETARGET_okINTEGER3
5347 case FFEINFO_kindtypeINTEGER3:
5348 error = ffetarget_gt_integer3 (&val,
5349 ffebld_constant_integer3 (ffebld_conter (l)),
5350 ffebld_constant_integer3 (ffebld_conter (r)));
5351 expr = ffebld_new_conter_with_orig
5352 (ffebld_constant_new_logicaldefault (val), expr);
5353 break;
5354 #endif
5355
5356 #if FFETARGET_okINTEGER4
5357 case FFEINFO_kindtypeINTEGER4:
5358 error = ffetarget_gt_integer4 (&val,
5359 ffebld_constant_integer4 (ffebld_conter (l)),
5360 ffebld_constant_integer4 (ffebld_conter (r)));
5361 expr = ffebld_new_conter_with_orig
5362 (ffebld_constant_new_logicaldefault (val), expr);
5363 break;
5364 #endif
5365
5366 default:
5367 assert ("bad integer kind type" == NULL);
5368 break;
5369 }
5370 break;
5371
5372 case FFEINFO_basictypeREAL:
5373 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5374 {
5375 #if FFETARGET_okREAL1
5376 case FFEINFO_kindtypeREAL1:
5377 error = ffetarget_gt_real1 (&val,
5378 ffebld_constant_real1 (ffebld_conter (l)),
5379 ffebld_constant_real1 (ffebld_conter (r)));
5380 expr = ffebld_new_conter_with_orig
5381 (ffebld_constant_new_logicaldefault (val), expr);
5382 break;
5383 #endif
5384
5385 #if FFETARGET_okREAL2
5386 case FFEINFO_kindtypeREAL2:
5387 error = ffetarget_gt_real2 (&val,
5388 ffebld_constant_real2 (ffebld_conter (l)),
5389 ffebld_constant_real2 (ffebld_conter (r)));
5390 expr = ffebld_new_conter_with_orig
5391 (ffebld_constant_new_logicaldefault (val), expr);
5392 break;
5393 #endif
5394
5395 #if FFETARGET_okREAL3
5396 case FFEINFO_kindtypeREAL3:
5397 error = ffetarget_gt_real3 (&val,
5398 ffebld_constant_real3 (ffebld_conter (l)),
5399 ffebld_constant_real3 (ffebld_conter (r)));
5400 expr = ffebld_new_conter_with_orig
5401 (ffebld_constant_new_logicaldefault (val), expr);
5402 break;
5403 #endif
5404
5405 #if FFETARGET_okREAL4
5406 case FFEINFO_kindtypeREAL4:
5407 error = ffetarget_gt_real4 (&val,
5408 ffebld_constant_real4 (ffebld_conter (l)),
5409 ffebld_constant_real4 (ffebld_conter (r)));
5410 expr = ffebld_new_conter_with_orig
5411 (ffebld_constant_new_logicaldefault (val), expr);
5412 break;
5413 #endif
5414
5415 default:
5416 assert ("bad real kind type" == NULL);
5417 break;
5418 }
5419 break;
5420
5421 case FFEINFO_basictypeCHARACTER:
5422 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5423 {
5424 #if FFETARGET_okCHARACTER1
5425 case FFEINFO_kindtypeCHARACTER1:
5426 error = ffetarget_gt_character1 (&val,
5427 ffebld_constant_character1 (ffebld_conter (l)),
5428 ffebld_constant_character1 (ffebld_conter (r)));
5429 expr = ffebld_new_conter_with_orig
5430 (ffebld_constant_new_logicaldefault (val), expr);
5431 break;
5432 #endif
5433
5434 #if FFETARGET_okCHARACTER2
5435 case FFEINFO_kindtypeCHARACTER2:
5436 error = ffetarget_gt_character2 (&val,
5437 ffebld_constant_character2 (ffebld_conter (l)),
5438 ffebld_constant_character2 (ffebld_conter (r)));
5439 expr = ffebld_new_conter_with_orig
5440 (ffebld_constant_new_logicaldefault (val), expr);
5441 break;
5442 #endif
5443
5444 #if FFETARGET_okCHARACTER3
5445 case FFEINFO_kindtypeCHARACTER3:
5446 error = ffetarget_gt_character3 (&val,
5447 ffebld_constant_character3 (ffebld_conter (l)),
5448 ffebld_constant_character3 (ffebld_conter (r)));
5449 expr = ffebld_new_conter_with_orig
5450 (ffebld_constant_new_logicaldefault (val), expr);
5451 break;
5452 #endif
5453
5454 #if FFETARGET_okCHARACTER4
5455 case FFEINFO_kindtypeCHARACTER4:
5456 error = ffetarget_gt_character4 (&val,
5457 ffebld_constant_character4 (ffebld_conter (l)),
5458 ffebld_constant_character4 (ffebld_conter (r)));
5459 expr = ffebld_new_conter_with_orig
5460 (ffebld_constant_new_logicaldefault (val), expr);
5461 break;
5462 #endif
5463
5464 default:
5465 assert ("bad character kind type" == NULL);
5466 break;
5467 }
5468 break;
5469
5470 default:
5471 assert ("bad type" == NULL);
5472 return expr;
5473 }
5474
5475 ffebld_set_info (expr, ffeinfo_new
5476 (FFEINFO_basictypeLOGICAL,
5477 FFEINFO_kindtypeLOGICALDEFAULT,
5478 0,
5479 FFEINFO_kindENTITY,
5480 FFEINFO_whereCONSTANT,
5481 FFETARGET_charactersizeNONE));
5482
5483 if ((error != FFEBAD)
5484 && ffebad_start (error))
5485 {
5486 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5487 ffebad_finish ();
5488 }
5489
5490 return expr;
5491 }
5492
5493 /* ffeexpr_collapse_le -- Collapse le expr
5494
5495 ffebld expr;
5496 ffelexToken token;
5497 expr = ffeexpr_collapse_le(expr,token);
5498
5499 If the result of the expr is a constant, replaces the expr with the
5500 computed constant. */
5501
5502 ffebld
5503 ffeexpr_collapse_le (ffebld expr, ffelexToken t)
5504 {
5505 ffebad error = FFEBAD;
5506 ffebld l;
5507 ffebld r;
5508 bool val;
5509
5510 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5511 return expr;
5512
5513 l = ffebld_left (expr);
5514 r = ffebld_right (expr);
5515
5516 if (ffebld_op (l) != FFEBLD_opCONTER)
5517 return expr;
5518 if (ffebld_op (r) != FFEBLD_opCONTER)
5519 return expr;
5520
5521 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5522 {
5523 case FFEINFO_basictypeANY:
5524 return expr;
5525
5526 case FFEINFO_basictypeINTEGER:
5527 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5528 {
5529 #if FFETARGET_okINTEGER1
5530 case FFEINFO_kindtypeINTEGER1:
5531 error = ffetarget_le_integer1 (&val,
5532 ffebld_constant_integer1 (ffebld_conter (l)),
5533 ffebld_constant_integer1 (ffebld_conter (r)));
5534 expr = ffebld_new_conter_with_orig
5535 (ffebld_constant_new_logicaldefault (val), expr);
5536 break;
5537 #endif
5538
5539 #if FFETARGET_okINTEGER2
5540 case FFEINFO_kindtypeINTEGER2:
5541 error = ffetarget_le_integer2 (&val,
5542 ffebld_constant_integer2 (ffebld_conter (l)),
5543 ffebld_constant_integer2 (ffebld_conter (r)));
5544 expr = ffebld_new_conter_with_orig
5545 (ffebld_constant_new_logicaldefault (val), expr);
5546 break;
5547 #endif
5548
5549 #if FFETARGET_okINTEGER3
5550 case FFEINFO_kindtypeINTEGER3:
5551 error = ffetarget_le_integer3 (&val,
5552 ffebld_constant_integer3 (ffebld_conter (l)),
5553 ffebld_constant_integer3 (ffebld_conter (r)));
5554 expr = ffebld_new_conter_with_orig
5555 (ffebld_constant_new_logicaldefault (val), expr);
5556 break;
5557 #endif
5558
5559 #if FFETARGET_okINTEGER4
5560 case FFEINFO_kindtypeINTEGER4:
5561 error = ffetarget_le_integer4 (&val,
5562 ffebld_constant_integer4 (ffebld_conter (l)),
5563 ffebld_constant_integer4 (ffebld_conter (r)));
5564 expr = ffebld_new_conter_with_orig
5565 (ffebld_constant_new_logicaldefault (val), expr);
5566 break;
5567 #endif
5568
5569 default:
5570 assert ("bad integer kind type" == NULL);
5571 break;
5572 }
5573 break;
5574
5575 case FFEINFO_basictypeREAL:
5576 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5577 {
5578 #if FFETARGET_okREAL1
5579 case FFEINFO_kindtypeREAL1:
5580 error = ffetarget_le_real1 (&val,
5581 ffebld_constant_real1 (ffebld_conter (l)),
5582 ffebld_constant_real1 (ffebld_conter (r)));
5583 expr = ffebld_new_conter_with_orig
5584 (ffebld_constant_new_logicaldefault (val), expr);
5585 break;
5586 #endif
5587
5588 #if FFETARGET_okREAL2
5589 case FFEINFO_kindtypeREAL2:
5590 error = ffetarget_le_real2 (&val,
5591 ffebld_constant_real2 (ffebld_conter (l)),
5592 ffebld_constant_real2 (ffebld_conter (r)));
5593 expr = ffebld_new_conter_with_orig
5594 (ffebld_constant_new_logicaldefault (val), expr);
5595 break;
5596 #endif
5597
5598 #if FFETARGET_okREAL3
5599 case FFEINFO_kindtypeREAL3:
5600 error = ffetarget_le_real3 (&val,
5601 ffebld_constant_real3 (ffebld_conter (l)),
5602 ffebld_constant_real3 (ffebld_conter (r)));
5603 expr = ffebld_new_conter_with_orig
5604 (ffebld_constant_new_logicaldefault (val), expr);
5605 break;
5606 #endif
5607
5608 #if FFETARGET_okREAL4
5609 case FFEINFO_kindtypeREAL4:
5610 error = ffetarget_le_real4 (&val,
5611 ffebld_constant_real4 (ffebld_conter (l)),
5612 ffebld_constant_real4 (ffebld_conter (r)));
5613 expr = ffebld_new_conter_with_orig
5614 (ffebld_constant_new_logicaldefault (val), expr);
5615 break;
5616 #endif
5617
5618 default:
5619 assert ("bad real kind type" == NULL);
5620 break;
5621 }
5622 break;
5623
5624 case FFEINFO_basictypeCHARACTER:
5625 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5626 {
5627 #if FFETARGET_okCHARACTER1
5628 case FFEINFO_kindtypeCHARACTER1:
5629 error = ffetarget_le_character1 (&val,
5630 ffebld_constant_character1 (ffebld_conter (l)),
5631 ffebld_constant_character1 (ffebld_conter (r)));
5632 expr = ffebld_new_conter_with_orig
5633 (ffebld_constant_new_logicaldefault (val), expr);
5634 break;
5635 #endif
5636
5637 #if FFETARGET_okCHARACTER2
5638 case FFEINFO_kindtypeCHARACTER2:
5639 error = ffetarget_le_character2 (&val,
5640 ffebld_constant_character2 (ffebld_conter (l)),
5641 ffebld_constant_character2 (ffebld_conter (r)));
5642 expr = ffebld_new_conter_with_orig
5643 (ffebld_constant_new_logicaldefault (val), expr);
5644 break;
5645 #endif
5646
5647 #if FFETARGET_okCHARACTER3
5648 case FFEINFO_kindtypeCHARACTER3:
5649 error = ffetarget_le_character3 (&val,
5650 ffebld_constant_character3 (ffebld_conter (l)),
5651 ffebld_constant_character3 (ffebld_conter (r)));
5652 expr = ffebld_new_conter_with_orig
5653 (ffebld_constant_new_logicaldefault (val), expr);
5654 break;
5655 #endif
5656
5657 #if FFETARGET_okCHARACTER4
5658 case FFEINFO_kindtypeCHARACTER4:
5659 error = ffetarget_le_character4 (&val,
5660 ffebld_constant_character4 (ffebld_conter (l)),
5661 ffebld_constant_character4 (ffebld_conter (r)));
5662 expr = ffebld_new_conter_with_orig
5663 (ffebld_constant_new_logicaldefault (val), expr);
5664 break;
5665 #endif
5666
5667 default:
5668 assert ("bad character kind type" == NULL);
5669 break;
5670 }
5671 break;
5672
5673 default:
5674 assert ("bad type" == NULL);
5675 return expr;
5676 }
5677
5678 ffebld_set_info (expr, ffeinfo_new
5679 (FFEINFO_basictypeLOGICAL,
5680 FFEINFO_kindtypeLOGICALDEFAULT,
5681 0,
5682 FFEINFO_kindENTITY,
5683 FFEINFO_whereCONSTANT,
5684 FFETARGET_charactersizeNONE));
5685
5686 if ((error != FFEBAD)
5687 && ffebad_start (error))
5688 {
5689 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5690 ffebad_finish ();
5691 }
5692
5693 return expr;
5694 }
5695
5696 /* ffeexpr_collapse_lt -- Collapse lt expr
5697
5698 ffebld expr;
5699 ffelexToken token;
5700 expr = ffeexpr_collapse_lt(expr,token);
5701
5702 If the result of the expr is a constant, replaces the expr with the
5703 computed constant. */
5704
5705 ffebld
5706 ffeexpr_collapse_lt (ffebld expr, ffelexToken t)
5707 {
5708 ffebad error = FFEBAD;
5709 ffebld l;
5710 ffebld r;
5711 bool val;
5712
5713 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5714 return expr;
5715
5716 l = ffebld_left (expr);
5717 r = ffebld_right (expr);
5718
5719 if (ffebld_op (l) != FFEBLD_opCONTER)
5720 return expr;
5721 if (ffebld_op (r) != FFEBLD_opCONTER)
5722 return expr;
5723
5724 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5725 {
5726 case FFEINFO_basictypeANY:
5727 return expr;
5728
5729 case FFEINFO_basictypeINTEGER:
5730 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5731 {
5732 #if FFETARGET_okINTEGER1
5733 case FFEINFO_kindtypeINTEGER1:
5734 error = ffetarget_lt_integer1 (&val,
5735 ffebld_constant_integer1 (ffebld_conter (l)),
5736 ffebld_constant_integer1 (ffebld_conter (r)));
5737 expr = ffebld_new_conter_with_orig
5738 (ffebld_constant_new_logicaldefault (val), expr);
5739 break;
5740 #endif
5741
5742 #if FFETARGET_okINTEGER2
5743 case FFEINFO_kindtypeINTEGER2:
5744 error = ffetarget_lt_integer2 (&val,
5745 ffebld_constant_integer2 (ffebld_conter (l)),
5746 ffebld_constant_integer2 (ffebld_conter (r)));
5747 expr = ffebld_new_conter_with_orig
5748 (ffebld_constant_new_logicaldefault (val), expr);
5749 break;
5750 #endif
5751
5752 #if FFETARGET_okINTEGER3
5753 case FFEINFO_kindtypeINTEGER3:
5754 error = ffetarget_lt_integer3 (&val,
5755 ffebld_constant_integer3 (ffebld_conter (l)),
5756 ffebld_constant_integer3 (ffebld_conter (r)));
5757 expr = ffebld_new_conter_with_orig
5758 (ffebld_constant_new_logicaldefault (val), expr);
5759 break;
5760 #endif
5761
5762 #if FFETARGET_okINTEGER4
5763 case FFEINFO_kindtypeINTEGER4:
5764 error = ffetarget_lt_integer4 (&val,
5765 ffebld_constant_integer4 (ffebld_conter (l)),
5766 ffebld_constant_integer4 (ffebld_conter (r)));
5767 expr = ffebld_new_conter_with_orig
5768 (ffebld_constant_new_logicaldefault (val), expr);
5769 break;
5770 #endif
5771
5772 default:
5773 assert ("bad integer kind type" == NULL);
5774 break;
5775 }
5776 break;
5777
5778 case FFEINFO_basictypeREAL:
5779 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5780 {
5781 #if FFETARGET_okREAL1
5782 case FFEINFO_kindtypeREAL1:
5783 error = ffetarget_lt_real1 (&val,
5784 ffebld_constant_real1 (ffebld_conter (l)),
5785 ffebld_constant_real1 (ffebld_conter (r)));
5786 expr = ffebld_new_conter_with_orig
5787 (ffebld_constant_new_logicaldefault (val), expr);
5788 break;
5789 #endif
5790
5791 #if FFETARGET_okREAL2
5792 case FFEINFO_kindtypeREAL2:
5793 error = ffetarget_lt_real2 (&val,
5794 ffebld_constant_real2 (ffebld_conter (l)),
5795 ffebld_constant_real2 (ffebld_conter (r)));
5796 expr = ffebld_new_conter_with_orig
5797 (ffebld_constant_new_logicaldefault (val), expr);
5798 break;
5799 #endif
5800
5801 #if FFETARGET_okREAL3
5802 case FFEINFO_kindtypeREAL3:
5803 error = ffetarget_lt_real3 (&val,
5804 ffebld_constant_real3 (ffebld_conter (l)),
5805 ffebld_constant_real3 (ffebld_conter (r)));
5806 expr = ffebld_new_conter_with_orig
5807 (ffebld_constant_new_logicaldefault (val), expr);
5808 break;
5809 #endif
5810
5811 #if FFETARGET_okREAL4
5812 case FFEINFO_kindtypeREAL4:
5813 error = ffetarget_lt_real4 (&val,
5814 ffebld_constant_real4 (ffebld_conter (l)),
5815 ffebld_constant_real4 (ffebld_conter (r)));
5816 expr = ffebld_new_conter_with_orig
5817 (ffebld_constant_new_logicaldefault (val), expr);
5818 break;
5819 #endif
5820
5821 default:
5822 assert ("bad real kind type" == NULL);
5823 break;
5824 }
5825 break;
5826
5827 case FFEINFO_basictypeCHARACTER:
5828 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5829 {
5830 #if FFETARGET_okCHARACTER1
5831 case FFEINFO_kindtypeCHARACTER1:
5832 error = ffetarget_lt_character1 (&val,
5833 ffebld_constant_character1 (ffebld_conter (l)),
5834 ffebld_constant_character1 (ffebld_conter (r)));
5835 expr = ffebld_new_conter_with_orig
5836 (ffebld_constant_new_logicaldefault (val), expr);
5837 break;
5838 #endif
5839
5840 #if FFETARGET_okCHARACTER2
5841 case FFEINFO_kindtypeCHARACTER2:
5842 error = ffetarget_lt_character2 (&val,
5843 ffebld_constant_character2 (ffebld_conter (l)),
5844 ffebld_constant_character2 (ffebld_conter (r)));
5845 expr = ffebld_new_conter_with_orig
5846 (ffebld_constant_new_logicaldefault (val), expr);
5847 break;
5848 #endif
5849
5850 #if FFETARGET_okCHARACTER3
5851 case FFEINFO_kindtypeCHARACTER3:
5852 error = ffetarget_lt_character3 (&val,
5853 ffebld_constant_character3 (ffebld_conter (l)),
5854 ffebld_constant_character3 (ffebld_conter (r)));
5855 expr = ffebld_new_conter_with_orig
5856 (ffebld_constant_new_logicaldefault (val), expr);
5857 break;
5858 #endif
5859
5860 #if FFETARGET_okCHARACTER4
5861 case FFEINFO_kindtypeCHARACTER4:
5862 error = ffetarget_lt_character4 (&val,
5863 ffebld_constant_character4 (ffebld_conter (l)),
5864 ffebld_constant_character4 (ffebld_conter (r)));
5865 expr = ffebld_new_conter_with_orig
5866 (ffebld_constant_new_logicaldefault (val), expr);
5867 break;
5868 #endif
5869
5870 default:
5871 assert ("bad character kind type" == NULL);
5872 break;
5873 }
5874 break;
5875
5876 default:
5877 assert ("bad type" == NULL);
5878 return expr;
5879 }
5880
5881 ffebld_set_info (expr, ffeinfo_new
5882 (FFEINFO_basictypeLOGICAL,
5883 FFEINFO_kindtypeLOGICALDEFAULT,
5884 0,
5885 FFEINFO_kindENTITY,
5886 FFEINFO_whereCONSTANT,
5887 FFETARGET_charactersizeNONE));
5888
5889 if ((error != FFEBAD)
5890 && ffebad_start (error))
5891 {
5892 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5893 ffebad_finish ();
5894 }
5895
5896 return expr;
5897 }
5898
5899 /* ffeexpr_collapse_and -- Collapse and expr
5900
5901 ffebld expr;
5902 ffelexToken token;
5903 expr = ffeexpr_collapse_and(expr,token);
5904
5905 If the result of the expr is a constant, replaces the expr with the
5906 computed constant. */
5907
5908 ffebld
5909 ffeexpr_collapse_and (ffebld expr, ffelexToken t)
5910 {
5911 ffebad error = FFEBAD;
5912 ffebld l;
5913 ffebld r;
5914 ffebldConstantUnion u;
5915 ffeinfoBasictype bt;
5916 ffeinfoKindtype kt;
5917
5918 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5919 return expr;
5920
5921 l = ffebld_left (expr);
5922 r = ffebld_right (expr);
5923
5924 if (ffebld_op (l) != FFEBLD_opCONTER)
5925 return expr;
5926 if (ffebld_op (r) != FFEBLD_opCONTER)
5927 return expr;
5928
5929 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5930 {
5931 case FFEINFO_basictypeANY:
5932 return expr;
5933
5934 case FFEINFO_basictypeINTEGER:
5935 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5936 {
5937 #if FFETARGET_okINTEGER1
5938 case FFEINFO_kindtypeINTEGER1:
5939 error = ffetarget_and_integer1 (ffebld_cu_ptr_integer1 (u),
5940 ffebld_constant_integer1 (ffebld_conter (l)),
5941 ffebld_constant_integer1 (ffebld_conter (r)));
5942 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5943 (ffebld_cu_val_integer1 (u)), expr);
5944 break;
5945 #endif
5946
5947 #if FFETARGET_okINTEGER2
5948 case FFEINFO_kindtypeINTEGER2:
5949 error = ffetarget_and_integer2 (ffebld_cu_ptr_integer2 (u),
5950 ffebld_constant_integer2 (ffebld_conter (l)),
5951 ffebld_constant_integer2 (ffebld_conter (r)));
5952 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5953 (ffebld_cu_val_integer2 (u)), expr);
5954 break;
5955 #endif
5956
5957 #if FFETARGET_okINTEGER3
5958 case FFEINFO_kindtypeINTEGER3:
5959 error = ffetarget_and_integer3 (ffebld_cu_ptr_integer3 (u),
5960 ffebld_constant_integer3 (ffebld_conter (l)),
5961 ffebld_constant_integer3 (ffebld_conter (r)));
5962 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5963 (ffebld_cu_val_integer3 (u)), expr);
5964 break;
5965 #endif
5966
5967 #if FFETARGET_okINTEGER4
5968 case FFEINFO_kindtypeINTEGER4:
5969 error = ffetarget_and_integer4 (ffebld_cu_ptr_integer4 (u),
5970 ffebld_constant_integer4 (ffebld_conter (l)),
5971 ffebld_constant_integer4 (ffebld_conter (r)));
5972 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5973 (ffebld_cu_val_integer4 (u)), expr);
5974 break;
5975 #endif
5976
5977 default:
5978 assert ("bad integer kind type" == NULL);
5979 break;
5980 }
5981 break;
5982
5983 case FFEINFO_basictypeLOGICAL:
5984 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5985 {
5986 #if FFETARGET_okLOGICAL1
5987 case FFEINFO_kindtypeLOGICAL1:
5988 error = ffetarget_and_logical1 (ffebld_cu_ptr_logical1 (u),
5989 ffebld_constant_logical1 (ffebld_conter (l)),
5990 ffebld_constant_logical1 (ffebld_conter (r)));
5991 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5992 (ffebld_cu_val_logical1 (u)), expr);
5993 break;
5994 #endif
5995
5996 #if FFETARGET_okLOGICAL2
5997 case FFEINFO_kindtypeLOGICAL2:
5998 error = ffetarget_and_logical2 (ffebld_cu_ptr_logical2 (u),
5999 ffebld_constant_logical2 (ffebld_conter (l)),
6000 ffebld_constant_logical2 (ffebld_conter (r)));
6001 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6002 (ffebld_cu_val_logical2 (u)), expr);
6003 break;
6004 #endif
6005
6006 #if FFETARGET_okLOGICAL3
6007 case FFEINFO_kindtypeLOGICAL3:
6008 error = ffetarget_and_logical3 (ffebld_cu_ptr_logical3 (u),
6009 ffebld_constant_logical3 (ffebld_conter (l)),
6010 ffebld_constant_logical3 (ffebld_conter (r)));
6011 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6012 (ffebld_cu_val_logical3 (u)), expr);
6013 break;
6014 #endif
6015
6016 #if FFETARGET_okLOGICAL4
6017 case FFEINFO_kindtypeLOGICAL4:
6018 error = ffetarget_and_logical4 (ffebld_cu_ptr_logical4 (u),
6019 ffebld_constant_logical4 (ffebld_conter (l)),
6020 ffebld_constant_logical4 (ffebld_conter (r)));
6021 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6022 (ffebld_cu_val_logical4 (u)), expr);
6023 break;
6024 #endif
6025
6026 default:
6027 assert ("bad logical kind type" == NULL);
6028 break;
6029 }
6030 break;
6031
6032 default:
6033 assert ("bad type" == NULL);
6034 return expr;
6035 }
6036
6037 ffebld_set_info (expr, ffeinfo_new
6038 (bt,
6039 kt,
6040 0,
6041 FFEINFO_kindENTITY,
6042 FFEINFO_whereCONSTANT,
6043 FFETARGET_charactersizeNONE));
6044
6045 if ((error != FFEBAD)
6046 && ffebad_start (error))
6047 {
6048 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6049 ffebad_finish ();
6050 }
6051
6052 return expr;
6053 }
6054
6055 /* ffeexpr_collapse_or -- Collapse or expr
6056
6057 ffebld expr;
6058 ffelexToken token;
6059 expr = ffeexpr_collapse_or(expr,token);
6060
6061 If the result of the expr is a constant, replaces the expr with the
6062 computed constant. */
6063
6064 ffebld
6065 ffeexpr_collapse_or (ffebld expr, ffelexToken t)
6066 {
6067 ffebad error = FFEBAD;
6068 ffebld l;
6069 ffebld r;
6070 ffebldConstantUnion u;
6071 ffeinfoBasictype bt;
6072 ffeinfoKindtype kt;
6073
6074 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6075 return expr;
6076
6077 l = ffebld_left (expr);
6078 r = ffebld_right (expr);
6079
6080 if (ffebld_op (l) != FFEBLD_opCONTER)
6081 return expr;
6082 if (ffebld_op (r) != FFEBLD_opCONTER)
6083 return expr;
6084
6085 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6086 {
6087 case FFEINFO_basictypeANY:
6088 return expr;
6089
6090 case FFEINFO_basictypeINTEGER:
6091 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6092 {
6093 #if FFETARGET_okINTEGER1
6094 case FFEINFO_kindtypeINTEGER1:
6095 error = ffetarget_or_integer1 (ffebld_cu_ptr_integer1 (u),
6096 ffebld_constant_integer1 (ffebld_conter (l)),
6097 ffebld_constant_integer1 (ffebld_conter (r)));
6098 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6099 (ffebld_cu_val_integer1 (u)), expr);
6100 break;
6101 #endif
6102
6103 #if FFETARGET_okINTEGER2
6104 case FFEINFO_kindtypeINTEGER2:
6105 error = ffetarget_or_integer2 (ffebld_cu_ptr_integer2 (u),
6106 ffebld_constant_integer2 (ffebld_conter (l)),
6107 ffebld_constant_integer2 (ffebld_conter (r)));
6108 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6109 (ffebld_cu_val_integer2 (u)), expr);
6110 break;
6111 #endif
6112
6113 #if FFETARGET_okINTEGER3
6114 case FFEINFO_kindtypeINTEGER3:
6115 error = ffetarget_or_integer3 (ffebld_cu_ptr_integer3 (u),
6116 ffebld_constant_integer3 (ffebld_conter (l)),
6117 ffebld_constant_integer3 (ffebld_conter (r)));
6118 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6119 (ffebld_cu_val_integer3 (u)), expr);
6120 break;
6121 #endif
6122
6123 #if FFETARGET_okINTEGER4
6124 case FFEINFO_kindtypeINTEGER4:
6125 error = ffetarget_or_integer4 (ffebld_cu_ptr_integer4 (u),
6126 ffebld_constant_integer4 (ffebld_conter (l)),
6127 ffebld_constant_integer4 (ffebld_conter (r)));
6128 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6129 (ffebld_cu_val_integer4 (u)), expr);
6130 break;
6131 #endif
6132
6133 default:
6134 assert ("bad integer kind type" == NULL);
6135 break;
6136 }
6137 break;
6138
6139 case FFEINFO_basictypeLOGICAL:
6140 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6141 {
6142 #if FFETARGET_okLOGICAL1
6143 case FFEINFO_kindtypeLOGICAL1:
6144 error = ffetarget_or_logical1 (ffebld_cu_ptr_logical1 (u),
6145 ffebld_constant_logical1 (ffebld_conter (l)),
6146 ffebld_constant_logical1 (ffebld_conter (r)));
6147 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6148 (ffebld_cu_val_logical1 (u)), expr);
6149 break;
6150 #endif
6151
6152 #if FFETARGET_okLOGICAL2
6153 case FFEINFO_kindtypeLOGICAL2:
6154 error = ffetarget_or_logical2 (ffebld_cu_ptr_logical2 (u),
6155 ffebld_constant_logical2 (ffebld_conter (l)),
6156 ffebld_constant_logical2 (ffebld_conter (r)));
6157 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6158 (ffebld_cu_val_logical2 (u)), expr);
6159 break;
6160 #endif
6161
6162 #if FFETARGET_okLOGICAL3
6163 case FFEINFO_kindtypeLOGICAL3:
6164 error = ffetarget_or_logical3 (ffebld_cu_ptr_logical3 (u),
6165 ffebld_constant_logical3 (ffebld_conter (l)),
6166 ffebld_constant_logical3 (ffebld_conter (r)));
6167 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6168 (ffebld_cu_val_logical3 (u)), expr);
6169 break;
6170 #endif
6171
6172 #if FFETARGET_okLOGICAL4
6173 case FFEINFO_kindtypeLOGICAL4:
6174 error = ffetarget_or_logical4 (ffebld_cu_ptr_logical4 (u),
6175 ffebld_constant_logical4 (ffebld_conter (l)),
6176 ffebld_constant_logical4 (ffebld_conter (r)));
6177 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6178 (ffebld_cu_val_logical4 (u)), expr);
6179 break;
6180 #endif
6181
6182 default:
6183 assert ("bad logical kind type" == NULL);
6184 break;
6185 }
6186 break;
6187
6188 default:
6189 assert ("bad type" == NULL);
6190 return expr;
6191 }
6192
6193 ffebld_set_info (expr, ffeinfo_new
6194 (bt,
6195 kt,
6196 0,
6197 FFEINFO_kindENTITY,
6198 FFEINFO_whereCONSTANT,
6199 FFETARGET_charactersizeNONE));
6200
6201 if ((error != FFEBAD)
6202 && ffebad_start (error))
6203 {
6204 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6205 ffebad_finish ();
6206 }
6207
6208 return expr;
6209 }
6210
6211 /* ffeexpr_collapse_xor -- Collapse xor expr
6212
6213 ffebld expr;
6214 ffelexToken token;
6215 expr = ffeexpr_collapse_xor(expr,token);
6216
6217 If the result of the expr is a constant, replaces the expr with the
6218 computed constant. */
6219
6220 ffebld
6221 ffeexpr_collapse_xor (ffebld expr, ffelexToken t)
6222 {
6223 ffebad error = FFEBAD;
6224 ffebld l;
6225 ffebld r;
6226 ffebldConstantUnion u;
6227 ffeinfoBasictype bt;
6228 ffeinfoKindtype kt;
6229
6230 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6231 return expr;
6232
6233 l = ffebld_left (expr);
6234 r = ffebld_right (expr);
6235
6236 if (ffebld_op (l) != FFEBLD_opCONTER)
6237 return expr;
6238 if (ffebld_op (r) != FFEBLD_opCONTER)
6239 return expr;
6240
6241 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6242 {
6243 case FFEINFO_basictypeANY:
6244 return expr;
6245
6246 case FFEINFO_basictypeINTEGER:
6247 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6248 {
6249 #if FFETARGET_okINTEGER1
6250 case FFEINFO_kindtypeINTEGER1:
6251 error = ffetarget_xor_integer1 (ffebld_cu_ptr_integer1 (u),
6252 ffebld_constant_integer1 (ffebld_conter (l)),
6253 ffebld_constant_integer1 (ffebld_conter (r)));
6254 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6255 (ffebld_cu_val_integer1 (u)), expr);
6256 break;
6257 #endif
6258
6259 #if FFETARGET_okINTEGER2
6260 case FFEINFO_kindtypeINTEGER2:
6261 error = ffetarget_xor_integer2 (ffebld_cu_ptr_integer2 (u),
6262 ffebld_constant_integer2 (ffebld_conter (l)),
6263 ffebld_constant_integer2 (ffebld_conter (r)));
6264 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6265 (ffebld_cu_val_integer2 (u)), expr);
6266 break;
6267 #endif
6268
6269 #if FFETARGET_okINTEGER3
6270 case FFEINFO_kindtypeINTEGER3:
6271 error = ffetarget_xor_integer3 (ffebld_cu_ptr_integer3 (u),
6272 ffebld_constant_integer3 (ffebld_conter (l)),
6273 ffebld_constant_integer3 (ffebld_conter (r)));
6274 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6275 (ffebld_cu_val_integer3 (u)), expr);
6276 break;
6277 #endif
6278
6279 #if FFETARGET_okINTEGER4
6280 case FFEINFO_kindtypeINTEGER4:
6281 error = ffetarget_xor_integer4 (ffebld_cu_ptr_integer4 (u),
6282 ffebld_constant_integer4 (ffebld_conter (l)),
6283 ffebld_constant_integer4 (ffebld_conter (r)));
6284 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6285 (ffebld_cu_val_integer4 (u)), expr);
6286 break;
6287 #endif
6288
6289 default:
6290 assert ("bad integer kind type" == NULL);
6291 break;
6292 }
6293 break;
6294
6295 case FFEINFO_basictypeLOGICAL:
6296 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6297 {
6298 #if FFETARGET_okLOGICAL1
6299 case FFEINFO_kindtypeLOGICAL1:
6300 error = ffetarget_xor_logical1 (ffebld_cu_ptr_logical1 (u),
6301 ffebld_constant_logical1 (ffebld_conter (l)),
6302 ffebld_constant_logical1 (ffebld_conter (r)));
6303 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6304 (ffebld_cu_val_logical1 (u)), expr);
6305 break;
6306 #endif
6307
6308 #if FFETARGET_okLOGICAL2
6309 case FFEINFO_kindtypeLOGICAL2:
6310 error = ffetarget_xor_logical2 (ffebld_cu_ptr_logical2 (u),
6311 ffebld_constant_logical2 (ffebld_conter (l)),
6312 ffebld_constant_logical2 (ffebld_conter (r)));
6313 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6314 (ffebld_cu_val_logical2 (u)), expr);
6315 break;
6316 #endif
6317
6318 #if FFETARGET_okLOGICAL3
6319 case FFEINFO_kindtypeLOGICAL3:
6320 error = ffetarget_xor_logical3 (ffebld_cu_ptr_logical3 (u),
6321 ffebld_constant_logical3 (ffebld_conter (l)),
6322 ffebld_constant_logical3 (ffebld_conter (r)));
6323 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6324 (ffebld_cu_val_logical3 (u)), expr);
6325 break;
6326 #endif
6327
6328 #if FFETARGET_okLOGICAL4
6329 case FFEINFO_kindtypeLOGICAL4:
6330 error = ffetarget_xor_logical4 (ffebld_cu_ptr_logical4 (u),
6331 ffebld_constant_logical4 (ffebld_conter (l)),
6332 ffebld_constant_logical4 (ffebld_conter (r)));
6333 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6334 (ffebld_cu_val_logical4 (u)), expr);
6335 break;
6336 #endif
6337
6338 default:
6339 assert ("bad logical kind type" == NULL);
6340 break;
6341 }
6342 break;
6343
6344 default:
6345 assert ("bad type" == NULL);
6346 return expr;
6347 }
6348
6349 ffebld_set_info (expr, ffeinfo_new
6350 (bt,
6351 kt,
6352 0,
6353 FFEINFO_kindENTITY,
6354 FFEINFO_whereCONSTANT,
6355 FFETARGET_charactersizeNONE));
6356
6357 if ((error != FFEBAD)
6358 && ffebad_start (error))
6359 {
6360 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6361 ffebad_finish ();
6362 }
6363
6364 return expr;
6365 }
6366
6367 /* ffeexpr_collapse_eqv -- Collapse eqv expr
6368
6369 ffebld expr;
6370 ffelexToken token;
6371 expr = ffeexpr_collapse_eqv(expr,token);
6372
6373 If the result of the expr is a constant, replaces the expr with the
6374 computed constant. */
6375
6376 ffebld
6377 ffeexpr_collapse_eqv (ffebld expr, ffelexToken t)
6378 {
6379 ffebad error = FFEBAD;
6380 ffebld l;
6381 ffebld r;
6382 ffebldConstantUnion u;
6383 ffeinfoBasictype bt;
6384 ffeinfoKindtype kt;
6385
6386 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6387 return expr;
6388
6389 l = ffebld_left (expr);
6390 r = ffebld_right (expr);
6391
6392 if (ffebld_op (l) != FFEBLD_opCONTER)
6393 return expr;
6394 if (ffebld_op (r) != FFEBLD_opCONTER)
6395 return expr;
6396
6397 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6398 {
6399 case FFEINFO_basictypeANY:
6400 return expr;
6401
6402 case FFEINFO_basictypeINTEGER:
6403 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6404 {
6405 #if FFETARGET_okINTEGER1
6406 case FFEINFO_kindtypeINTEGER1:
6407 error = ffetarget_eqv_integer1 (ffebld_cu_ptr_integer1 (u),
6408 ffebld_constant_integer1 (ffebld_conter (l)),
6409 ffebld_constant_integer1 (ffebld_conter (r)));
6410 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6411 (ffebld_cu_val_integer1 (u)), expr);
6412 break;
6413 #endif
6414
6415 #if FFETARGET_okINTEGER2
6416 case FFEINFO_kindtypeINTEGER2:
6417 error = ffetarget_eqv_integer2 (ffebld_cu_ptr_integer2 (u),
6418 ffebld_constant_integer2 (ffebld_conter (l)),
6419 ffebld_constant_integer2 (ffebld_conter (r)));
6420 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6421 (ffebld_cu_val_integer2 (u)), expr);
6422 break;
6423 #endif
6424
6425 #if FFETARGET_okINTEGER3
6426 case FFEINFO_kindtypeINTEGER3:
6427 error = ffetarget_eqv_integer3 (ffebld_cu_ptr_integer3 (u),
6428 ffebld_constant_integer3 (ffebld_conter (l)),
6429 ffebld_constant_integer3 (ffebld_conter (r)));
6430 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6431 (ffebld_cu_val_integer3 (u)), expr);
6432 break;
6433 #endif
6434
6435 #if FFETARGET_okINTEGER4
6436 case FFEINFO_kindtypeINTEGER4:
6437 error = ffetarget_eqv_integer4 (ffebld_cu_ptr_integer4 (u),
6438 ffebld_constant_integer4 (ffebld_conter (l)),
6439 ffebld_constant_integer4 (ffebld_conter (r)));
6440 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6441 (ffebld_cu_val_integer4 (u)), expr);
6442 break;
6443 #endif
6444
6445 default:
6446 assert ("bad integer kind type" == NULL);
6447 break;
6448 }
6449 break;
6450
6451 case FFEINFO_basictypeLOGICAL:
6452 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6453 {
6454 #if FFETARGET_okLOGICAL1
6455 case FFEINFO_kindtypeLOGICAL1:
6456 error = ffetarget_eqv_logical1 (ffebld_cu_ptr_logical1 (u),
6457 ffebld_constant_logical1 (ffebld_conter (l)),
6458 ffebld_constant_logical1 (ffebld_conter (r)));
6459 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6460 (ffebld_cu_val_logical1 (u)), expr);
6461 break;
6462 #endif
6463
6464 #if FFETARGET_okLOGICAL2
6465 case FFEINFO_kindtypeLOGICAL2:
6466 error = ffetarget_eqv_logical2 (ffebld_cu_ptr_logical2 (u),
6467 ffebld_constant_logical2 (ffebld_conter (l)),
6468 ffebld_constant_logical2 (ffebld_conter (r)));
6469 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6470 (ffebld_cu_val_logical2 (u)), expr);
6471 break;
6472 #endif
6473
6474 #if FFETARGET_okLOGICAL3
6475 case FFEINFO_kindtypeLOGICAL3:
6476 error = ffetarget_eqv_logical3 (ffebld_cu_ptr_logical3 (u),
6477 ffebld_constant_logical3 (ffebld_conter (l)),
6478 ffebld_constant_logical3 (ffebld_conter (r)));
6479 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6480 (ffebld_cu_val_logical3 (u)), expr);
6481 break;
6482 #endif
6483
6484 #if FFETARGET_okLOGICAL4
6485 case FFEINFO_kindtypeLOGICAL4:
6486 error = ffetarget_eqv_logical4 (ffebld_cu_ptr_logical4 (u),
6487 ffebld_constant_logical4 (ffebld_conter (l)),
6488 ffebld_constant_logical4 (ffebld_conter (r)));
6489 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6490 (ffebld_cu_val_logical4 (u)), expr);
6491 break;
6492 #endif
6493
6494 default:
6495 assert ("bad logical kind type" == NULL);
6496 break;
6497 }
6498 break;
6499
6500 default:
6501 assert ("bad type" == NULL);
6502 return expr;
6503 }
6504
6505 ffebld_set_info (expr, ffeinfo_new
6506 (bt,
6507 kt,
6508 0,
6509 FFEINFO_kindENTITY,
6510 FFEINFO_whereCONSTANT,
6511 FFETARGET_charactersizeNONE));
6512
6513 if ((error != FFEBAD)
6514 && ffebad_start (error))
6515 {
6516 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6517 ffebad_finish ();
6518 }
6519
6520 return expr;
6521 }
6522
6523 /* ffeexpr_collapse_neqv -- Collapse neqv expr
6524
6525 ffebld expr;
6526 ffelexToken token;
6527 expr = ffeexpr_collapse_neqv(expr,token);
6528
6529 If the result of the expr is a constant, replaces the expr with the
6530 computed constant. */
6531
6532 ffebld
6533 ffeexpr_collapse_neqv (ffebld expr, ffelexToken t)
6534 {
6535 ffebad error = FFEBAD;
6536 ffebld l;
6537 ffebld r;
6538 ffebldConstantUnion u;
6539 ffeinfoBasictype bt;
6540 ffeinfoKindtype kt;
6541
6542 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6543 return expr;
6544
6545 l = ffebld_left (expr);
6546 r = ffebld_right (expr);
6547
6548 if (ffebld_op (l) != FFEBLD_opCONTER)
6549 return expr;
6550 if (ffebld_op (r) != FFEBLD_opCONTER)
6551 return expr;
6552
6553 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6554 {
6555 case FFEINFO_basictypeANY:
6556 return expr;
6557
6558 case FFEINFO_basictypeINTEGER:
6559 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6560 {
6561 #if FFETARGET_okINTEGER1
6562 case FFEINFO_kindtypeINTEGER1:
6563 error = ffetarget_neqv_integer1 (ffebld_cu_ptr_integer1 (u),
6564 ffebld_constant_integer1 (ffebld_conter (l)),
6565 ffebld_constant_integer1 (ffebld_conter (r)));
6566 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6567 (ffebld_cu_val_integer1 (u)), expr);
6568 break;
6569 #endif
6570
6571 #if FFETARGET_okINTEGER2
6572 case FFEINFO_kindtypeINTEGER2:
6573 error = ffetarget_neqv_integer2 (ffebld_cu_ptr_integer2 (u),
6574 ffebld_constant_integer2 (ffebld_conter (l)),
6575 ffebld_constant_integer2 (ffebld_conter (r)));
6576 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6577 (ffebld_cu_val_integer2 (u)), expr);
6578 break;
6579 #endif
6580
6581 #if FFETARGET_okINTEGER3
6582 case FFEINFO_kindtypeINTEGER3:
6583 error = ffetarget_neqv_integer3 (ffebld_cu_ptr_integer3 (u),
6584 ffebld_constant_integer3 (ffebld_conter (l)),
6585 ffebld_constant_integer3 (ffebld_conter (r)));
6586 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6587 (ffebld_cu_val_integer3 (u)), expr);
6588 break;
6589 #endif
6590
6591 #if FFETARGET_okINTEGER4
6592 case FFEINFO_kindtypeINTEGER4:
6593 error = ffetarget_neqv_integer4 (ffebld_cu_ptr_integer4 (u),
6594 ffebld_constant_integer4 (ffebld_conter (l)),
6595 ffebld_constant_integer4 (ffebld_conter (r)));
6596 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6597 (ffebld_cu_val_integer4 (u)), expr);
6598 break;
6599 #endif
6600
6601 default:
6602 assert ("bad integer kind type" == NULL);
6603 break;
6604 }
6605 break;
6606
6607 case FFEINFO_basictypeLOGICAL:
6608 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6609 {
6610 #if FFETARGET_okLOGICAL1
6611 case FFEINFO_kindtypeLOGICAL1:
6612 error = ffetarget_neqv_logical1 (ffebld_cu_ptr_logical1 (u),
6613 ffebld_constant_logical1 (ffebld_conter (l)),
6614 ffebld_constant_logical1 (ffebld_conter (r)));
6615 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6616 (ffebld_cu_val_logical1 (u)), expr);
6617 break;
6618 #endif
6619
6620 #if FFETARGET_okLOGICAL2
6621 case FFEINFO_kindtypeLOGICAL2:
6622 error = ffetarget_neqv_logical2 (ffebld_cu_ptr_logical2 (u),
6623 ffebld_constant_logical2 (ffebld_conter (l)),
6624 ffebld_constant_logical2 (ffebld_conter (r)));
6625 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6626 (ffebld_cu_val_logical2 (u)), expr);
6627 break;
6628 #endif
6629
6630 #if FFETARGET_okLOGICAL3
6631 case FFEINFO_kindtypeLOGICAL3:
6632 error = ffetarget_neqv_logical3 (ffebld_cu_ptr_logical3 (u),
6633 ffebld_constant_logical3 (ffebld_conter (l)),
6634 ffebld_constant_logical3 (ffebld_conter (r)));
6635 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6636 (ffebld_cu_val_logical3 (u)), expr);
6637 break;
6638 #endif
6639
6640 #if FFETARGET_okLOGICAL4
6641 case FFEINFO_kindtypeLOGICAL4:
6642 error = ffetarget_neqv_logical4 (ffebld_cu_ptr_logical4 (u),
6643 ffebld_constant_logical4 (ffebld_conter (l)),
6644 ffebld_constant_logical4 (ffebld_conter (r)));
6645 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6646 (ffebld_cu_val_logical4 (u)), expr);
6647 break;
6648 #endif
6649
6650 default:
6651 assert ("bad logical kind type" == NULL);
6652 break;
6653 }
6654 break;
6655
6656 default:
6657 assert ("bad type" == NULL);
6658 return expr;
6659 }
6660
6661 ffebld_set_info (expr, ffeinfo_new
6662 (bt,
6663 kt,
6664 0,
6665 FFEINFO_kindENTITY,
6666 FFEINFO_whereCONSTANT,
6667 FFETARGET_charactersizeNONE));
6668
6669 if ((error != FFEBAD)
6670 && ffebad_start (error))
6671 {
6672 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6673 ffebad_finish ();
6674 }
6675
6676 return expr;
6677 }
6678
6679 /* ffeexpr_collapse_symter -- Collapse symter expr
6680
6681 ffebld expr;
6682 ffelexToken token;
6683 expr = ffeexpr_collapse_symter(expr,token);
6684
6685 If the result of the expr is a constant, replaces the expr with the
6686 computed constant. */
6687
6688 ffebld
6689 ffeexpr_collapse_symter (ffebld expr, ffelexToken t UNUSED)
6690 {
6691 ffebld r;
6692 ffeinfoBasictype bt;
6693 ffeinfoKindtype kt;
6694 ffetargetCharacterSize len;
6695
6696 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6697 return expr;
6698
6699 if ((r = ffesymbol_init (ffebld_symter (expr))) == NULL)
6700 return expr; /* A PARAMETER lhs in progress. */
6701
6702 switch (ffebld_op (r))
6703 {
6704 case FFEBLD_opCONTER:
6705 break;
6706
6707 case FFEBLD_opANY:
6708 return r;
6709
6710 default:
6711 return expr;
6712 }
6713
6714 bt = ffeinfo_basictype (ffebld_info (r));
6715 kt = ffeinfo_kindtype (ffebld_info (r));
6716 len = ffebld_size (r);
6717
6718 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
6719 expr);
6720
6721 ffebld_set_info (expr, ffeinfo_new
6722 (bt,
6723 kt,
6724 0,
6725 FFEINFO_kindENTITY,
6726 FFEINFO_whereCONSTANT,
6727 len));
6728
6729 return expr;
6730 }
6731
6732 /* ffeexpr_collapse_funcref -- Collapse funcref expr
6733
6734 ffebld expr;
6735 ffelexToken token;
6736 expr = ffeexpr_collapse_funcref(expr,token);
6737
6738 If the result of the expr is a constant, replaces the expr with the
6739 computed constant. */
6740
6741 ffebld
6742 ffeexpr_collapse_funcref (ffebld expr, ffelexToken t UNUSED)
6743 {
6744 return expr; /* ~~someday go ahead and collapse these,
6745 though not required */
6746 }
6747
6748 /* ffeexpr_collapse_arrayref -- Collapse arrayref expr
6749
6750 ffebld expr;
6751 ffelexToken token;
6752 expr = ffeexpr_collapse_arrayref(expr,token);
6753
6754 If the result of the expr is a constant, replaces the expr with the
6755 computed constant. */
6756
6757 ffebld
6758 ffeexpr_collapse_arrayref (ffebld expr, ffelexToken t UNUSED)
6759 {
6760 return expr;
6761 }
6762
6763 /* ffeexpr_collapse_substr -- Collapse substr expr
6764
6765 ffebld expr;
6766 ffelexToken token;
6767 expr = ffeexpr_collapse_substr(expr,token);
6768
6769 If the result of the expr is a constant, replaces the expr with the
6770 computed constant. */
6771
6772 ffebld
6773 ffeexpr_collapse_substr (ffebld expr, ffelexToken t)
6774 {
6775 ffebad error = FFEBAD;
6776 ffebld l;
6777 ffebld r;
6778 ffebld start;
6779 ffebld stop;
6780 ffebldConstantUnion u;
6781 ffeinfoKindtype kt;
6782 ffetargetCharacterSize len;
6783 ffetargetIntegerDefault first;
6784 ffetargetIntegerDefault last;
6785
6786 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6787 return expr;
6788
6789 l = ffebld_left (expr);
6790 r = ffebld_right (expr); /* opITEM. */
6791
6792 if (ffebld_op (l) != FFEBLD_opCONTER)
6793 return expr;
6794
6795 kt = ffeinfo_kindtype (ffebld_info (l));
6796 len = ffebld_size (l);
6797
6798 start = ffebld_head (r);
6799 stop = ffebld_head (ffebld_trail (r));
6800 if (start == NULL)
6801 first = 1;
6802 else
6803 {
6804 if ((ffebld_op (start) != FFEBLD_opCONTER)
6805 || (ffeinfo_basictype (ffebld_info (start)) != FFEINFO_basictypeINTEGER)
6806 || (ffeinfo_kindtype (ffebld_info (start))
6807 != FFEINFO_kindtypeINTEGERDEFAULT))
6808 return expr;
6809 first = ffebld_constant_integerdefault (ffebld_conter (start));
6810 }
6811 if (stop == NULL)
6812 last = len;
6813 else
6814 {
6815 if ((ffebld_op (stop) != FFEBLD_opCONTER)
6816 || (ffeinfo_basictype (ffebld_info (stop)) != FFEINFO_basictypeINTEGER)
6817 || (ffeinfo_kindtype (ffebld_info (stop))
6818 != FFEINFO_kindtypeINTEGERDEFAULT))
6819 return expr;
6820 last = ffebld_constant_integerdefault (ffebld_conter (stop));
6821 }
6822
6823 /* Handle problems that should have already been diagnosed, but
6824 left in the expression tree. */
6825
6826 if (first <= 0)
6827 first = 1;
6828 if (last < first)
6829 last = first + len - 1;
6830
6831 if ((first == 1) && (last == len))
6832 { /* Same as original. */
6833 expr = ffebld_new_conter_with_orig (ffebld_constant_copy
6834 (ffebld_conter (l)), expr);
6835 ffebld_set_info (expr, ffeinfo_new
6836 (FFEINFO_basictypeCHARACTER,
6837 kt,
6838 0,
6839 FFEINFO_kindENTITY,
6840 FFEINFO_whereCONSTANT,
6841 len));
6842
6843 return expr;
6844 }
6845
6846 switch (ffeinfo_basictype (ffebld_info (expr)))
6847 {
6848 case FFEINFO_basictypeANY:
6849 return expr;
6850
6851 case FFEINFO_basictypeCHARACTER:
6852 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6853 {
6854 #if FFETARGET_okCHARACTER1
6855 case FFEINFO_kindtypeCHARACTER1:
6856 error = ffetarget_substr_character1 (ffebld_cu_ptr_character1 (u),
6857 ffebld_constant_character1 (ffebld_conter (l)), first, last,
6858 ffebld_constant_pool (), &len);
6859 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
6860 (ffebld_cu_val_character1 (u)), expr);
6861 break;
6862 #endif
6863
6864 #if FFETARGET_okCHARACTER2
6865 case FFEINFO_kindtypeCHARACTER2:
6866 error = ffetarget_substr_character2 (ffebld_cu_ptr_character2 (u),
6867 ffebld_constant_character2 (ffebld_conter (l)), first, last,
6868 ffebld_constant_pool (), &len);
6869 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val
6870 (ffebld_cu_val_character2 (u)), expr);
6871 break;
6872 #endif
6873
6874 #if FFETARGET_okCHARACTER3
6875 case FFEINFO_kindtypeCHARACTER3:
6876 error = ffetarget_substr_character3 (ffebld_cu_ptr_character3 (u),
6877 ffebld_constant_character3 (ffebld_conter (l)), first, last,
6878 ffebld_constant_pool (), &len);
6879 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val
6880 (ffebld_cu_val_character3 (u)), expr);
6881 break;
6882 #endif
6883
6884 #if FFETARGET_okCHARACTER4
6885 case FFEINFO_kindtypeCHARACTER4:
6886 error = ffetarget_substr_character4 (ffebld_cu_ptr_character4 (u),
6887 ffebld_constant_character4 (ffebld_conter (l)), first, last,
6888 ffebld_constant_pool (), &len);
6889 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val
6890 (ffebld_cu_val_character4 (u)), expr);
6891 break;
6892 #endif
6893
6894 default:
6895 assert ("bad character kind type" == NULL);
6896 break;
6897 }
6898 break;
6899
6900 default:
6901 assert ("bad type" == NULL);
6902 return expr;
6903 }
6904
6905 ffebld_set_info (expr, ffeinfo_new
6906 (FFEINFO_basictypeCHARACTER,
6907 kt,
6908 0,
6909 FFEINFO_kindENTITY,
6910 FFEINFO_whereCONSTANT,
6911 len));
6912
6913 if ((error != FFEBAD)
6914 && ffebad_start (error))
6915 {
6916 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6917 ffebad_finish ();
6918 }
6919
6920 return expr;
6921 }
6922
6923 /* ffeexpr_convert -- Convert source expression to given type
6924
6925 ffebld source;
6926 ffelexToken source_token;
6927 ffelexToken dest_token; // Any appropriate token for "destination".
6928 ffeinfoBasictype bt;
6929 ffeinfoKindtype kt;
6930 ffetargetCharactersize sz;
6931 ffeexprContext context; // Mainly LET or DATA.
6932 source = ffeexpr_convert(source,source_token,dest_token,bt,kt,sz,context);
6933
6934 If the expression conforms, returns the source expression. Otherwise
6935 returns source wrapped in a convert node doing the conversion, or
6936 ANY wrapped in convert if there is a conversion error (and issues an
6937 error message). Be sensitive to the context for certain aspects of
6938 the conversion. */
6939
6940 ffebld
6941 ffeexpr_convert (ffebld source, ffelexToken source_token, ffelexToken dest_token,
6942 ffeinfoBasictype bt, ffeinfoKindtype kt, ffeinfoRank rk,
6943 ffetargetCharacterSize sz, ffeexprContext context)
6944 {
6945 bool bad;
6946 ffeinfo info;
6947 ffeinfoWhere wh;
6948
6949 info = ffebld_info (source);
6950 if ((bt != ffeinfo_basictype (info))
6951 || (kt != ffeinfo_kindtype (info))
6952 || (rk != 0) /* Can't convert from or to arrays yet. */
6953 || (ffeinfo_rank (info) != 0)
6954 || (sz != ffebld_size_known (source)))
6955 #if 0 /* Nobody seems to need this spurious CONVERT node. */
6956 || ((context != FFEEXPR_contextLET)
6957 && (bt == FFEINFO_basictypeCHARACTER)
6958 && (sz == FFETARGET_charactersizeNONE)))
6959 #endif
6960 {
6961 switch (ffeinfo_basictype (info))
6962 {
6963 case FFEINFO_basictypeLOGICAL:
6964 switch (bt)
6965 {
6966 case FFEINFO_basictypeLOGICAL:
6967 bad = FALSE;
6968 break;
6969
6970 case FFEINFO_basictypeINTEGER:
6971 bad = !ffe_is_ugly_logint ();
6972 break;
6973
6974 case FFEINFO_basictypeCHARACTER:
6975 bad = ffe_is_pedantic ()
6976 || !(ffe_is_ugly_init ()
6977 && (context == FFEEXPR_contextDATA));
6978 break;
6979
6980 default:
6981 bad = TRUE;
6982 break;
6983 }
6984 break;
6985
6986 case FFEINFO_basictypeINTEGER:
6987 switch (bt)
6988 {
6989 case FFEINFO_basictypeINTEGER:
6990 case FFEINFO_basictypeREAL:
6991 case FFEINFO_basictypeCOMPLEX:
6992 bad = FALSE;
6993 break;
6994
6995 case FFEINFO_basictypeLOGICAL:
6996 bad = !ffe_is_ugly_logint ();
6997 break;
6998
6999 case FFEINFO_basictypeCHARACTER:
7000 bad = ffe_is_pedantic ()
7001 || !(ffe_is_ugly_init ()
7002 && (context == FFEEXPR_contextDATA));
7003 break;
7004
7005 default:
7006 bad = TRUE;
7007 break;
7008 }
7009 break;
7010
7011 case FFEINFO_basictypeREAL:
7012 case FFEINFO_basictypeCOMPLEX:
7013 switch (bt)
7014 {
7015 case FFEINFO_basictypeINTEGER:
7016 case FFEINFO_basictypeREAL:
7017 case FFEINFO_basictypeCOMPLEX:
7018 bad = FALSE;
7019 break;
7020
7021 case FFEINFO_basictypeCHARACTER:
7022 bad = TRUE;
7023 break;
7024
7025 default:
7026 bad = TRUE;
7027 break;
7028 }
7029 break;
7030
7031 case FFEINFO_basictypeCHARACTER:
7032 bad = (bt != FFEINFO_basictypeCHARACTER)
7033 && (ffe_is_pedantic ()
7034 || (bt != FFEINFO_basictypeINTEGER)
7035 || !(ffe_is_ugly_init ()
7036 && (context == FFEEXPR_contextDATA)));
7037 break;
7038
7039 case FFEINFO_basictypeTYPELESS:
7040 case FFEINFO_basictypeHOLLERITH:
7041 bad = ffe_is_pedantic ()
7042 || !(ffe_is_ugly_init ()
7043 && ((context == FFEEXPR_contextDATA)
7044 || (context == FFEEXPR_contextLET)));
7045 break;
7046
7047 default:
7048 bad = TRUE;
7049 break;
7050 }
7051
7052 if (!bad && ((rk != 0) || (ffeinfo_rank (info) != 0)))
7053 bad = TRUE;
7054
7055 if (bad && (bt != FFEINFO_basictypeANY) && (kt != FFEINFO_kindtypeANY)
7056 && (ffeinfo_basictype (info) != FFEINFO_basictypeANY)
7057 && (ffeinfo_kindtype (info) != FFEINFO_kindtypeANY)
7058 && (ffeinfo_where (info) != FFEINFO_whereANY))
7059 {
7060 if (ffebad_start (FFEBAD_BAD_TYPES))
7061 {
7062 if (dest_token == NULL)
7063 ffebad_here (0, ffewhere_line_unknown (),
7064 ffewhere_column_unknown ());
7065 else
7066 ffebad_here (0, ffelex_token_where_line (dest_token),
7067 ffelex_token_where_column (dest_token));
7068 assert (source_token != NULL);
7069 ffebad_here (1, ffelex_token_where_line (source_token),
7070 ffelex_token_where_column (source_token));
7071 ffebad_finish ();
7072 }
7073
7074 source = ffebld_new_any ();
7075 ffebld_set_info (source, ffeinfo_new_any ());
7076 }
7077 else
7078 {
7079 switch (ffeinfo_where (info))
7080 {
7081 case FFEINFO_whereCONSTANT:
7082 wh = FFEINFO_whereCONSTANT;
7083 break;
7084
7085 case FFEINFO_whereIMMEDIATE:
7086 wh = FFEINFO_whereIMMEDIATE;
7087 break;
7088
7089 default:
7090 wh = FFEINFO_whereFLEETING;
7091 break;
7092 }
7093 source = ffebld_new_convert (source);
7094 ffebld_set_info (source, ffeinfo_new
7095 (bt,
7096 kt,
7097 0,
7098 FFEINFO_kindENTITY,
7099 wh,
7100 sz));
7101 source = ffeexpr_collapse_convert (source, source_token);
7102 }
7103 }
7104
7105 return source;
7106 }
7107
7108 /* ffeexpr_convert_expr -- Convert source expr to conform to dest expr
7109
7110 ffebld source;
7111 ffebld dest;
7112 ffelexToken source_token;
7113 ffelexToken dest_token;
7114 ffeexprContext context;
7115 source = ffeexpr_convert_expr(source,source_token,dest,dest_token,context);
7116
7117 If the expressions conform, returns the source expression. Otherwise
7118 returns source wrapped in a convert node doing the conversion, or
7119 ANY wrapped in convert if there is a conversion error (and issues an
7120 error message). Be sensitive to the context, such as LET or DATA. */
7121
7122 ffebld
7123 ffeexpr_convert_expr (ffebld source, ffelexToken source_token, ffebld dest,
7124 ffelexToken dest_token, ffeexprContext context)
7125 {
7126 ffeinfo info;
7127
7128 info = ffebld_info (dest);
7129 return ffeexpr_convert (source, source_token, dest_token,
7130 ffeinfo_basictype (info),
7131 ffeinfo_kindtype (info),
7132 ffeinfo_rank (info),
7133 ffebld_size_known (dest),
7134 context);
7135 }
7136
7137 /* ffeexpr_convert_to_sym -- Convert source expression to conform to symbol
7138
7139 ffebld source;
7140 ffesymbol dest;
7141 ffelexToken source_token;
7142 ffelexToken dest_token;
7143 source = ffeexpr_convert_to_sym(source,source_token,dest,dest_token);
7144
7145 If the expressions conform, returns the source expression. Otherwise
7146 returns source wrapped in a convert node doing the conversion, or
7147 ANY wrapped in convert if there is a conversion error (and issues an
7148 error message). */
7149
7150 ffebld
7151 ffeexpr_convert_to_sym (ffebld source, ffelexToken source_token,
7152 ffesymbol dest, ffelexToken dest_token)
7153 {
7154 return ffeexpr_convert (source, source_token, dest_token, ffesymbol_basictype (dest),
7155 ffesymbol_kindtype (dest), ffesymbol_rank (dest), ffesymbol_size (dest),
7156 FFEEXPR_contextLET);
7157 }
7158
7159 /* Initializes the module. */
7160
7161 void
7162 ffeexpr_init_2 ()
7163 {
7164 ffeexpr_stack_ = NULL;
7165 ffeexpr_level_ = 0;
7166 }
7167
7168 /* ffeexpr_lhs -- Begin processing left-hand-side-context expression
7169
7170 Prepares cluster for delivery of lexer tokens representing an expression
7171 in a left-hand-side context (A in A=B, for example). ffebld is used
7172 to build expressions in the given pool. The appropriate lexer-token
7173 handling routine within ffeexpr is returned. When the end of the
7174 expression is detected, mycallbackroutine is called with the resulting
7175 single ffebld object specifying the entire expression and the first
7176 lexer token that is not considered part of the expression. This caller-
7177 supplied routine itself returns a lexer-token handling routine. Thus,
7178 if necessary, ffeexpr can return several tokens as end-of-expression
7179 tokens if it needs to scan forward more than one in any instance. */
7180
7181 ffelexHandler
7182 ffeexpr_lhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
7183 {
7184 ffeexprStack_ s;
7185
7186 ffebld_pool_push (pool);
7187 s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
7188 s->previous = ffeexpr_stack_;
7189 s->pool = pool;
7190 s->context = context;
7191 s->callback = callback;
7192 s->first_token = NULL;
7193 s->exprstack = NULL;
7194 s->is_rhs = FALSE;
7195 ffeexpr_stack_ = s;
7196 return (ffelexHandler) ffeexpr_token_first_lhs_;
7197 }
7198
7199 /* ffeexpr_rhs -- Begin processing right-hand-side-context expression
7200
7201 return ffeexpr_rhs(malloc_pool_image(),mycallbackroutine); // to lexer.
7202
7203 Prepares cluster for delivery of lexer tokens representing an expression
7204 in a right-hand-side context (B in A=B, for example). ffebld is used
7205 to build expressions in the given pool. The appropriate lexer-token
7206 handling routine within ffeexpr is returned. When the end of the
7207 expression is detected, mycallbackroutine is called with the resulting
7208 single ffebld object specifying the entire expression and the first
7209 lexer token that is not considered part of the expression. This caller-
7210 supplied routine itself returns a lexer-token handling routine. Thus,
7211 if necessary, ffeexpr can return several tokens as end-of-expression
7212 tokens if it needs to scan forward more than one in any instance. */
7213
7214 ffelexHandler
7215 ffeexpr_rhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
7216 {
7217 ffeexprStack_ s;
7218
7219 ffebld_pool_push (pool);
7220 s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
7221 s->previous = ffeexpr_stack_;
7222 s->pool = pool;
7223 s->context = context;
7224 s->callback = callback;
7225 s->first_token = NULL;
7226 s->exprstack = NULL;
7227 s->is_rhs = TRUE;
7228 ffeexpr_stack_ = s;
7229 return (ffelexHandler) ffeexpr_token_first_rhs_;
7230 }
7231
7232 /* ffeexpr_cb_close_paren_ -- OPEN_PAREN expr
7233
7234 Pass it to ffeexpr_rhs as the callback routine.
7235
7236 Makes sure the end token is close-paren and swallows it, else issues
7237 an error message and doesn't swallow the token (passing it along instead).
7238 In either case wraps up subexpression construction by enclosing the
7239 ffebld expression in a paren. */
7240
7241 static ffelexHandler
7242 ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr, ffelexToken t)
7243 {
7244 ffeexprExpr_ e;
7245
7246 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7247 {
7248 /* Oops, naughty user didn't specify the close paren! */
7249
7250 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7251 {
7252 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7253 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7254 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7255 ffebad_finish ();
7256 }
7257
7258 e = ffeexpr_expr_new_ ();
7259 e->type = FFEEXPR_exprtypeOPERAND_;
7260 e->u.operand = ffebld_new_any ();
7261 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
7262 ffeexpr_exprstack_push_operand_ (e);
7263
7264 return
7265 (ffelexHandler) ffeexpr_find_close_paren_ (t,
7266 (ffelexHandler)
7267 ffeexpr_token_binary_);
7268 }
7269
7270 if (expr->op == FFEBLD_opIMPDO)
7271 {
7272 if (ffest_ffebad_start (FFEBAD_IMPDO_PAREN))
7273 {
7274 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7275 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7276 ffebad_finish ();
7277 }
7278 }
7279 else
7280 {
7281 expr = ffebld_new_paren (expr);
7282 ffebld_set_info (expr, ffeinfo_use (ffebld_info (ffebld_left (expr))));
7283 }
7284
7285 /* Now push the (parenthesized) expression as an operand onto the
7286 expression stack. */
7287
7288 e = ffeexpr_expr_new_ ();
7289 e->type = FFEEXPR_exprtypeOPERAND_;
7290 e->u.operand = expr;
7291 e->u.operand = ffeexpr_collapse_paren (e->u.operand, ft);
7292 e->token = ffeexpr_stack_->tokens[0];
7293 ffeexpr_exprstack_push_operand_ (e);
7294
7295 return (ffelexHandler) ffeexpr_token_binary_;
7296 }
7297
7298 /* ffeexpr_cb_close_paren_ambig_ -- OPEN_PAREN expr
7299
7300 Pass it to ffeexpr_rhs as the callback routine.
7301
7302 We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
7303 with the next token in t. If the next token is possibly a binary
7304 operator, continue processing the outer expression. If the next
7305 token is COMMA, then the expression is a unit specifier, and
7306 parentheses should not be added to it because it surrounds the
7307 I/O control list that starts with the unit specifier (and continues
7308 on from here -- we haven't seen the CLOSE_PAREN that matches the
7309 OPEN_PAREN, it is up to the callback function to expect to see it
7310 at some point). In this case, we notify the callback function that
7311 the COMMA is inside, not outside, the parens by wrapping the expression
7312 in an opITEM (with a NULL trail) -- the callback function presumably
7313 unwraps it after seeing this kludgey indicator.
7314
7315 If the next token is CLOSE_PAREN, then we go to the _1_ state to
7316 decide what to do with the token after that.
7317
7318 15-Feb-91 JCB 1.1
7319 Use an extra state for the CLOSE_PAREN case to make READ &co really
7320 work right. */
7321
7322 static ffelexHandler
7323 ffeexpr_cb_close_paren_ambig_ (ffelexToken ft, ffebld expr, ffelexToken t)
7324 {
7325 ffeexprCallback callback;
7326 ffeexprStack_ s;
7327
7328 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7329 { /* Need to see the next token before we
7330 decide anything. */
7331 ffeexpr_stack_->expr = expr;
7332 ffeexpr_tokens_[0] = ffelex_token_use (ft);
7333 ffeexpr_tokens_[1] = ffelex_token_use (t);
7334 return (ffelexHandler) ffeexpr_cb_close_paren_ambig_1_;
7335 }
7336
7337 expr = ffeexpr_finished_ambig_ (ft, expr);
7338
7339 /* Let the callback function handle the case where t isn't COMMA. */
7340
7341 /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
7342 that preceded the expression starts a list of expressions, and the expr
7343 hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
7344 node. The callback function should extract the real expr from the head
7345 of this opITEM node after testing it. */
7346
7347 expr = ffebld_new_item (expr, NULL);
7348
7349 ffebld_pool_pop ();
7350 callback = ffeexpr_stack_->callback;
7351 ffelex_token_kill (ffeexpr_stack_->first_token);
7352 s = ffeexpr_stack_->previous;
7353 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
7354 ffeexpr_stack_ = s;
7355 return (ffelexHandler) (*callback) (ft, expr, t);
7356 }
7357
7358 /* ffeexpr_cb_close_paren_ambig_1_ -- OPEN_PAREN expr CLOSE_PAREN
7359
7360 See ffeexpr_cb_close_paren_ambig_.
7361
7362 We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
7363 with the next token in t. If the next token is possibly a binary
7364 operator, continue processing the outer expression. If the next
7365 token is COMMA, the expression is a parenthesized format specifier.
7366 If the next token is not EOS or SEMICOLON, then because it is not a
7367 binary operator (it is NAME, OPEN_PAREN, &c), the expression is
7368 a unit specifier, and parentheses should not be added to it because
7369 they surround the I/O control list that consists of only the unit
7370 specifier. If the next token is EOS or SEMICOLON, the statement
7371 must be disambiguated by looking at the type of the expression -- a
7372 character expression is a parenthesized format specifier, while a
7373 non-character expression is a unit specifier.
7374
7375 Another issue is how to do the callback so the recipient of the
7376 next token knows how to handle it if it is a COMMA. In all other
7377 cases, disambiguation is straightforward: the same approach as the
7378 above is used.
7379
7380 EXTENSION: in COMMA case, if not pedantic, use same disambiguation
7381 as for EOS/SEMICOLON case; f2c allows "READ (cilist) [[,]iolist]"
7382 and apparently other compilers do, as well, and some code out there
7383 uses this "feature".
7384
7385 19-Feb-91 JCB 1.1
7386 Extend to allow COMMA as nondisambiguating by itself. Remember
7387 to not try and check info field for opSTAR, since that expr doesn't
7388 have a valid info field. */
7389
7390 static ffelexHandler
7391 ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t)
7392 {
7393 ffeexprCallback callback;
7394 ffeexprStack_ s;
7395 ffelexHandler next;
7396 ffelexToken orig_ft = ffeexpr_tokens_[0]; /* In case callback clobbers
7397 these. */
7398 ffelexToken orig_t = ffeexpr_tokens_[1];
7399 ffebld expr = ffeexpr_stack_->expr;
7400
7401 switch (ffelex_token_type (t))
7402 {
7403 case FFELEX_typeCOMMA: /* Subexpr is parenthesized format specifier. */
7404 if (ffe_is_pedantic ())
7405 goto pedantic_comma; /* :::::::::::::::::::: */
7406 /* Fall through. */
7407 case FFELEX_typeEOS: /* Ambiguous; use type of expr to
7408 disambiguate. */
7409 case FFELEX_typeSEMICOLON:
7410 if ((expr == NULL) || (ffebld_op (expr) == FFEBLD_opANY)
7411 || (ffebld_op (expr) == FFEBLD_opSTAR)
7412 || (ffeinfo_basictype (ffebld_info (expr))
7413 != FFEINFO_basictypeCHARACTER))
7414 break; /* Not a valid CHARACTER entity, can't be a
7415 format spec. */
7416 /* Fall through. */
7417 default: /* Binary op (we assume; error otherwise);
7418 format specifier. */
7419
7420 pedantic_comma: /* :::::::::::::::::::: */
7421
7422 switch (ffeexpr_stack_->context)
7423 {
7424 case FFEEXPR_contextFILENUMAMBIG:
7425 ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
7426 break;
7427
7428 case FFEEXPR_contextFILEUNITAMBIG:
7429 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
7430 break;
7431
7432 default:
7433 assert ("bad context" == NULL);
7434 break;
7435 }
7436
7437 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
7438 next = (ffelexHandler) ffeexpr_cb_close_paren_ (orig_ft, expr, orig_t);
7439 ffelex_token_kill (orig_ft);
7440 ffelex_token_kill (orig_t);
7441 return (ffelexHandler) (*next) (t);
7442
7443 case FFELEX_typeOPEN_PAREN:/* Non-binary op; beginning of I/O list. */
7444 case FFELEX_typeNAME:
7445 break;
7446 }
7447
7448 expr = ffeexpr_finished_ambig_ (orig_ft, expr);
7449
7450 /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
7451 that preceded the expression starts a list of expressions, and the expr
7452 hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
7453 node. The callback function should extract the real expr from the head
7454 of this opITEM node after testing it. */
7455
7456 expr = ffebld_new_item (expr, NULL);
7457
7458 ffebld_pool_pop ();
7459 callback = ffeexpr_stack_->callback;
7460 ffelex_token_kill (ffeexpr_stack_->first_token);
7461 s = ffeexpr_stack_->previous;
7462 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
7463 ffeexpr_stack_ = s;
7464 next = (ffelexHandler) (*callback) (orig_ft, expr, orig_t);
7465 ffelex_token_kill (orig_ft);
7466 ffelex_token_kill (orig_t);
7467 return (ffelexHandler) (*next) (t);
7468 }
7469
7470 /* ffeexpr_cb_close_paren_c_ -- OPEN_PAREN expr (possible complex)
7471
7472 Pass it to ffeexpr_rhs as the callback routine.
7473
7474 Makes sure the end token is close-paren and swallows it, or a comma
7475 and handles complex/implied-do possibilities, else issues
7476 an error message and doesn't swallow the token (passing it along instead). */
7477
7478 static ffelexHandler
7479 ffeexpr_cb_close_paren_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
7480 {
7481 /* First check to see if this is a possible complex entity. It is if the
7482 token is a comma. */
7483
7484 if (ffelex_token_type (t) == FFELEX_typeCOMMA)
7485 {
7486 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
7487 ffeexpr_stack_->expr = expr;
7488 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7489 FFEEXPR_contextPAREN_, ffeexpr_cb_comma_c_);
7490 }
7491
7492 return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
7493 }
7494
7495 /* ffeexpr_cb_comma_c_ -- OPEN_PAREN expr COMMA expr
7496
7497 Pass it to ffeexpr_rhs as the callback routine.
7498
7499 If this token is not a comma, we have a complex constant (or an attempt
7500 at one), so handle it accordingly, displaying error messages if the token
7501 is not a close-paren. */
7502
7503 static ffelexHandler
7504 ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
7505 {
7506 ffeexprExpr_ e;
7507 ffeinfoBasictype lty = (ffeexpr_stack_->expr == NULL)
7508 ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (ffeexpr_stack_->expr));
7509 ffeinfoBasictype rty = (expr == NULL)
7510 ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (expr));
7511 ffeinfoKindtype lkt;
7512 ffeinfoKindtype rkt;
7513 ffeinfoKindtype nkt;
7514 bool ok = TRUE;
7515 ffebld orig;
7516
7517 if ((ffeexpr_stack_->expr == NULL)
7518 || (ffebld_op (ffeexpr_stack_->expr) != FFEBLD_opCONTER)
7519 || (((orig = ffebld_conter_orig (ffeexpr_stack_->expr)) != NULL)
7520 && (((ffebld_op (orig) != FFEBLD_opUMINUS)
7521 && (ffebld_op (orig) != FFEBLD_opUPLUS))
7522 || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
7523 || ((lty != FFEINFO_basictypeINTEGER)
7524 && (lty != FFEINFO_basictypeREAL)))
7525 {
7526 if ((lty != FFEINFO_basictypeANY)
7527 && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
7528 {
7529 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
7530 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
7531 ffebad_string ("Real");
7532 ffebad_finish ();
7533 }
7534 ok = FALSE;
7535 }
7536 if ((expr == NULL)
7537 || (ffebld_op (expr) != FFEBLD_opCONTER)
7538 || (((orig = ffebld_conter_orig (expr)) != NULL)
7539 && (((ffebld_op (orig) != FFEBLD_opUMINUS)
7540 && (ffebld_op (orig) != FFEBLD_opUPLUS))
7541 || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
7542 || ((rty != FFEINFO_basictypeINTEGER)
7543 && (rty != FFEINFO_basictypeREAL)))
7544 {
7545 if ((rty != FFEINFO_basictypeANY)
7546 && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
7547 {
7548 ffebad_here (0, ffelex_token_where_line (ft),
7549 ffelex_token_where_column (ft));
7550 ffebad_string ("Imaginary");
7551 ffebad_finish ();
7552 }
7553 ok = FALSE;
7554 }
7555
7556 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7557
7558 /* Push the (parenthesized) expression as an operand onto the expression
7559 stack. */
7560
7561 e = ffeexpr_expr_new_ ();
7562 e->type = FFEEXPR_exprtypeOPERAND_;
7563 e->token = ffeexpr_stack_->tokens[0];
7564
7565 if (ok)
7566 {
7567 if (lty == FFEINFO_basictypeINTEGER)
7568 lkt = FFEINFO_kindtypeREALDEFAULT;
7569 else
7570 lkt = ffeinfo_kindtype (ffebld_info (ffeexpr_stack_->expr));
7571 if (rty == FFEINFO_basictypeINTEGER)
7572 rkt = FFEINFO_kindtypeREALDEFAULT;
7573 else
7574 rkt = ffeinfo_kindtype (ffebld_info (expr));
7575
7576 nkt = ffeinfo_kindtype_max (FFEINFO_basictypeCOMPLEX, lkt, rkt);
7577 ffeexpr_stack_->expr = ffeexpr_convert (ffeexpr_stack_->expr,
7578 ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
7579 FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
7580 FFEEXPR_contextLET);
7581 expr = ffeexpr_convert (expr,
7582 ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
7583 FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
7584 FFEEXPR_contextLET);
7585 }
7586 else
7587 nkt = FFEINFO_kindtypeANY;
7588
7589 switch (nkt)
7590 {
7591 #if FFETARGET_okCOMPLEX1
7592 case FFEINFO_kindtypeREAL1:
7593 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex1
7594 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7595 ffebld_set_info (e->u.operand,
7596 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7597 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7598 FFETARGET_charactersizeNONE));
7599 break;
7600 #endif
7601
7602 #if FFETARGET_okCOMPLEX2
7603 case FFEINFO_kindtypeREAL2:
7604 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex2
7605 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7606 ffebld_set_info (e->u.operand,
7607 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7608 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7609 FFETARGET_charactersizeNONE));
7610 break;
7611 #endif
7612
7613 #if FFETARGET_okCOMPLEX3
7614 case FFEINFO_kindtypeREAL3:
7615 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex3
7616 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7617 ffebld_set_info (e->u.operand,
7618 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7619 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7620 FFETARGET_charactersizeNONE));
7621 break;
7622 #endif
7623
7624 #if FFETARGET_okCOMPLEX4
7625 case FFEINFO_kindtypeREAL4:
7626 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex4
7627 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7628 ffebld_set_info (e->u.operand,
7629 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7630 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7631 FFETARGET_charactersizeNONE));
7632 break;
7633 #endif
7634
7635 default:
7636 if (ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
7637 ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX))
7638 {
7639 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7640 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7641 ffebad_finish ();
7642 }
7643 /* Fall through. */
7644 case FFEINFO_kindtypeANY:
7645 e->u.operand = ffebld_new_any ();
7646 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
7647 break;
7648 }
7649 ffeexpr_exprstack_push_operand_ (e);
7650
7651 /* Now, if the token is a close parenthese, we're in great shape so return
7652 the next handler. */
7653
7654 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7655 return (ffelexHandler) ffeexpr_token_binary_;
7656
7657 /* Oops, naughty user didn't specify the close paren! */
7658
7659 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7660 {
7661 ffebad_here (0, ffelex_token_where_line (t),
7662 ffelex_token_where_column (t));
7663 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7664 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7665 ffebad_finish ();
7666 }
7667
7668 return
7669 (ffelexHandler) ffeexpr_find_close_paren_ (t,
7670 (ffelexHandler)
7671 ffeexpr_token_binary_);
7672 }
7673
7674 /* ffeexpr_cb_close_paren_ci_ -- OPEN_PAREN expr (possible complex or
7675 implied-DO construct)
7676
7677 Pass it to ffeexpr_rhs as the callback routine.
7678
7679 Makes sure the end token is close-paren and swallows it, or a comma
7680 and handles complex/implied-do possibilities, else issues
7681 an error message and doesn't swallow the token (passing it along instead). */
7682
7683 static ffelexHandler
7684 ffeexpr_cb_close_paren_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
7685 {
7686 ffeexprContext ctx;
7687
7688 /* First check to see if this is a possible complex or implied-DO entity.
7689 It is if the token is a comma. */
7690
7691 if (ffelex_token_type (t) == FFELEX_typeCOMMA)
7692 {
7693 switch (ffeexpr_stack_->context)
7694 {
7695 case FFEEXPR_contextIOLIST:
7696 case FFEEXPR_contextIMPDOITEM_:
7697 ctx = FFEEXPR_contextIMPDOITEM_;
7698 break;
7699
7700 case FFEEXPR_contextIOLISTDF:
7701 case FFEEXPR_contextIMPDOITEMDF_:
7702 ctx = FFEEXPR_contextIMPDOITEMDF_;
7703 break;
7704
7705 default:
7706 assert ("bad context" == NULL);
7707 ctx = FFEEXPR_contextIMPDOITEM_;
7708 break;
7709 }
7710
7711 ffeexpr_stack_->tokens[0] = ffelex_token_use (ft);
7712 ffeexpr_stack_->expr = expr;
7713 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7714 ctx, ffeexpr_cb_comma_ci_);
7715 }
7716
7717 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
7718 return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
7719 }
7720
7721 /* ffeexpr_cb_comma_ci_ -- OPEN_PAREN expr COMMA expr
7722
7723 Pass it to ffeexpr_rhs as the callback routine.
7724
7725 If this token is not a comma, we have a complex constant (or an attempt
7726 at one), so handle it accordingly, displaying error messages if the token
7727 is not a close-paren. If we have a comma here, it is an attempt at an
7728 implied-DO, so start making a list accordingly. Oh, it might be an
7729 equal sign also, meaning an implied-DO with only one item in its list. */
7730
7731 static ffelexHandler
7732 ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
7733 {
7734 ffebld fexpr;
7735
7736 /* First check to see if this is a possible complex constant. It is if the
7737 token is not a comma or an equals sign, in which case it should be a
7738 close-paren. */
7739
7740 if ((ffelex_token_type (t) != FFELEX_typeCOMMA)
7741 && (ffelex_token_type (t) != FFELEX_typeEQUALS))
7742 {
7743 ffeexpr_stack_->tokens[1] = ffeexpr_stack_->tokens[0];
7744 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
7745 return (ffelexHandler) ffeexpr_cb_comma_c_ (ft, expr, t);
7746 }
7747
7748 /* Here we have either EQUALS or COMMA, meaning we are in an implied-DO
7749 construct. Make a list and handle accordingly. */
7750
7751 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
7752 fexpr = ffeexpr_stack_->expr;
7753 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7754 ffebld_append_item (&ffeexpr_stack_->bottom, fexpr);
7755 return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
7756 }
7757
7758 /* ffeexpr_cb_comma_i_ -- OPEN_PAREN expr
7759
7760 Pass it to ffeexpr_rhs as the callback routine.
7761
7762 Handle first item in an implied-DO construct. */
7763
7764 static ffelexHandler
7765 ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr, ffelexToken t)
7766 {
7767 if (ffelex_token_type (t) != FFELEX_typeCOMMA)
7768 {
7769 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7770 {
7771 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7772 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7773 ffelex_token_where_column (ffeexpr_stack_->first_token));
7774 ffebad_finish ();
7775 }
7776 ffebld_end_list (&ffeexpr_stack_->bottom);
7777 ffeexpr_stack_->expr = ffebld_new_any ();
7778 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7779 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7780 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7781 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7782 }
7783
7784 return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
7785 }
7786
7787 /* ffeexpr_cb_comma_i_1_ -- OPEN_PAREN expr
7788
7789 Pass it to ffeexpr_rhs as the callback routine.
7790
7791 Handle first item in an implied-DO construct. */
7792
7793 static ffelexHandler
7794 ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr, ffelexToken t)
7795 {
7796 ffeexprContext ctxi;
7797 ffeexprContext ctxc;
7798
7799 switch (ffeexpr_stack_->context)
7800 {
7801 case FFEEXPR_contextDATA:
7802 case FFEEXPR_contextDATAIMPDOITEM_:
7803 ctxi = FFEEXPR_contextDATAIMPDOITEM_;
7804 ctxc = FFEEXPR_contextDATAIMPDOCTRL_;
7805 break;
7806
7807 case FFEEXPR_contextIOLIST:
7808 case FFEEXPR_contextIMPDOITEM_:
7809 ctxi = FFEEXPR_contextIMPDOITEM_;
7810 ctxc = FFEEXPR_contextIMPDOCTRL_;
7811 break;
7812
7813 case FFEEXPR_contextIOLISTDF:
7814 case FFEEXPR_contextIMPDOITEMDF_:
7815 ctxi = FFEEXPR_contextIMPDOITEMDF_;
7816 ctxc = FFEEXPR_contextIMPDOCTRL_;
7817 break;
7818
7819 default:
7820 assert ("bad context" == NULL);
7821 ctxi = FFEEXPR_context;
7822 ctxc = FFEEXPR_context;
7823 break;
7824 }
7825
7826 switch (ffelex_token_type (t))
7827 {
7828 case FFELEX_typeCOMMA:
7829 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7830 if (ffeexpr_stack_->is_rhs)
7831 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7832 ctxi, ffeexpr_cb_comma_i_1_);
7833 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7834 ctxi, ffeexpr_cb_comma_i_1_);
7835
7836 case FFELEX_typeEQUALS:
7837 ffebld_end_list (&ffeexpr_stack_->bottom);
7838
7839 /* Complain if implied-DO variable in list of items to be read. */
7840
7841 if ((ctxc == FFEEXPR_contextIMPDOCTRL_) && !ffeexpr_stack_->is_rhs)
7842 ffeexpr_check_impdo_ (ffeexpr_stack_->expr,
7843 ffeexpr_stack_->first_token, expr, ft);
7844
7845 /* Set doiter flag for all appropriate SYMTERs. */
7846
7847 ffeexpr_update_impdo_ (ffeexpr_stack_->expr, expr);
7848
7849 ffeexpr_stack_->expr = ffebld_new_impdo (ffeexpr_stack_->expr, NULL);
7850 ffebld_set_info (ffeexpr_stack_->expr,
7851 ffeinfo_new (FFEINFO_basictypeNONE,
7852 FFEINFO_kindtypeNONE,
7853 0,
7854 FFEINFO_kindNONE,
7855 FFEINFO_whereNONE,
7856 FFETARGET_charactersizeNONE));
7857 ffebld_init_list (&(ffebld_right (ffeexpr_stack_->expr)),
7858 &ffeexpr_stack_->bottom);
7859 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7860 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7861 ctxc, ffeexpr_cb_comma_i_2_);
7862
7863 default:
7864 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7865 {
7866 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7867 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7868 ffelex_token_where_column (ffeexpr_stack_->first_token));
7869 ffebad_finish ();
7870 }
7871 ffebld_end_list (&ffeexpr_stack_->bottom);
7872 ffeexpr_stack_->expr = ffebld_new_any ();
7873 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7874 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7875 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7876 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7877 }
7878 }
7879
7880 /* ffeexpr_cb_comma_i_2_ -- OPEN_PAREN expr-list EQUALS expr
7881
7882 Pass it to ffeexpr_rhs as the callback routine.
7883
7884 Handle start-value in an implied-DO construct. */
7885
7886 static ffelexHandler
7887 ffeexpr_cb_comma_i_2_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7888 {
7889 ffeexprContext ctx;
7890
7891 switch (ffeexpr_stack_->context)
7892 {
7893 case FFEEXPR_contextDATA:
7894 case FFEEXPR_contextDATAIMPDOITEM_:
7895 ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7896 break;
7897
7898 case FFEEXPR_contextIOLIST:
7899 case FFEEXPR_contextIOLISTDF:
7900 case FFEEXPR_contextIMPDOITEM_:
7901 case FFEEXPR_contextIMPDOITEMDF_:
7902 ctx = FFEEXPR_contextIMPDOCTRL_;
7903 break;
7904
7905 default:
7906 assert ("bad context" == NULL);
7907 ctx = FFEEXPR_context;
7908 break;
7909 }
7910
7911 switch (ffelex_token_type (t))
7912 {
7913 case FFELEX_typeCOMMA:
7914 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7915 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7916 ctx, ffeexpr_cb_comma_i_3_);
7917 break;
7918
7919 default:
7920 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7921 {
7922 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7923 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7924 ffelex_token_where_column (ffeexpr_stack_->first_token));
7925 ffebad_finish ();
7926 }
7927 ffebld_end_list (&ffeexpr_stack_->bottom);
7928 ffeexpr_stack_->expr = ffebld_new_any ();
7929 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7930 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7931 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7932 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7933 }
7934 }
7935
7936 /* ffeexpr_cb_comma_i_3_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7937
7938 Pass it to ffeexpr_rhs as the callback routine.
7939
7940 Handle end-value in an implied-DO construct. */
7941
7942 static ffelexHandler
7943 ffeexpr_cb_comma_i_3_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7944 {
7945 ffeexprContext ctx;
7946
7947 switch (ffeexpr_stack_->context)
7948 {
7949 case FFEEXPR_contextDATA:
7950 case FFEEXPR_contextDATAIMPDOITEM_:
7951 ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7952 break;
7953
7954 case FFEEXPR_contextIOLIST:
7955 case FFEEXPR_contextIOLISTDF:
7956 case FFEEXPR_contextIMPDOITEM_:
7957 case FFEEXPR_contextIMPDOITEMDF_:
7958 ctx = FFEEXPR_contextIMPDOCTRL_;
7959 break;
7960
7961 default:
7962 assert ("bad context" == NULL);
7963 ctx = FFEEXPR_context;
7964 break;
7965 }
7966
7967 switch (ffelex_token_type (t))
7968 {
7969 case FFELEX_typeCOMMA:
7970 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7971 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7972 ctx, ffeexpr_cb_comma_i_4_);
7973 break;
7974
7975 case FFELEX_typeCLOSE_PAREN:
7976 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7977 return (ffelexHandler) ffeexpr_cb_comma_i_4_ (NULL, NULL, t);
7978 break;
7979
7980 default:
7981 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7982 {
7983 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7984 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7985 ffelex_token_where_column (ffeexpr_stack_->first_token));
7986 ffebad_finish ();
7987 }
7988 ffebld_end_list (&ffeexpr_stack_->bottom);
7989 ffeexpr_stack_->expr = ffebld_new_any ();
7990 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7991 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7992 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7993 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7994 }
7995 }
7996
7997 /* ffeexpr_cb_comma_i_4_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7998 [COMMA expr]
7999
8000 Pass it to ffeexpr_rhs as the callback routine.
8001
8002 Handle incr-value in an implied-DO construct. */
8003
8004 static ffelexHandler
8005 ffeexpr_cb_comma_i_4_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
8006 {
8007 switch (ffelex_token_type (t))
8008 {
8009 case FFELEX_typeCLOSE_PAREN:
8010 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
8011 ffebld_end_list (&ffeexpr_stack_->bottom);
8012 {
8013 ffebld item;
8014
8015 for (item = ffebld_left (ffeexpr_stack_->expr);
8016 item != NULL;
8017 item = ffebld_trail (item))
8018 if (ffebld_op (ffebld_head (item)) == FFEBLD_opANY)
8019 goto replace_with_any; /* :::::::::::::::::::: */
8020
8021 for (item = ffebld_right (ffeexpr_stack_->expr);
8022 item != NULL;
8023 item = ffebld_trail (item))
8024 if ((ffebld_head (item) != NULL) /* Increment may be NULL. */
8025 && (ffebld_op (ffebld_head (item)) == FFEBLD_opANY))
8026 goto replace_with_any; /* :::::::::::::::::::: */
8027 }
8028 break;
8029
8030 default:
8031 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
8032 {
8033 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8034 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
8035 ffelex_token_where_column (ffeexpr_stack_->first_token));
8036 ffebad_finish ();
8037 }
8038 ffebld_end_list (&ffeexpr_stack_->bottom);
8039
8040 replace_with_any: /* :::::::::::::::::::: */
8041
8042 ffeexpr_stack_->expr = ffebld_new_any ();
8043 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
8044 break;
8045 }
8046
8047 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
8048 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
8049 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
8050 }
8051
8052 /* ffeexpr_cb_comma_i_5_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
8053 [COMMA expr] CLOSE_PAREN
8054
8055 Pass it to ffeexpr_rhs as the callback routine.
8056
8057 Collects token following implied-DO construct for callback function. */
8058
8059 static ffelexHandler
8060 ffeexpr_cb_comma_i_5_ (ffelexToken t)
8061 {
8062 ffeexprCallback callback;
8063 ffeexprStack_ s;
8064 ffelexHandler next;
8065 ffelexToken ft;
8066 ffebld expr;
8067 bool terminate;
8068
8069 switch (ffeexpr_stack_->context)
8070 {
8071 case FFEEXPR_contextDATA:
8072 case FFEEXPR_contextDATAIMPDOITEM_:
8073 terminate = TRUE;
8074 break;
8075
8076 case FFEEXPR_contextIOLIST:
8077 case FFEEXPR_contextIOLISTDF:
8078 case FFEEXPR_contextIMPDOITEM_:
8079 case FFEEXPR_contextIMPDOITEMDF_:
8080 terminate = FALSE;
8081 break;
8082
8083 default:
8084 assert ("bad context" == NULL);
8085 terminate = FALSE;
8086 break;
8087 }
8088
8089 ffebld_pool_pop ();
8090 callback = ffeexpr_stack_->callback;
8091 ft = ffeexpr_stack_->first_token;
8092 expr = ffeexpr_stack_->expr;
8093 s = ffeexpr_stack_->previous;
8094 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
8095 sizeof (*ffeexpr_stack_));
8096 ffeexpr_stack_ = s;
8097 next = (ffelexHandler) (*callback) (ft, expr, t);
8098 ffelex_token_kill (ft);
8099 if (terminate)
8100 {
8101 ffesymbol_drive_sfnames (ffeexpr_check_impctrl_);
8102 --ffeexpr_level_;
8103 if (ffeexpr_level_ == 0)
8104 ffe_terminate_4 ();
8105 }
8106 return (ffelexHandler) next;
8107 }
8108
8109 /* ffeexpr_cb_end_loc_ -- Handle end of %LOC subexpression
8110
8111 Makes sure the end token is close-paren and swallows it, else issues
8112 an error message and doesn't swallow the token (passing it along instead).
8113 In either case wraps up subexpression construction by enclosing the
8114 ffebld expression in a %LOC. */
8115
8116 static ffelexHandler
8117 ffeexpr_cb_end_loc_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
8118 {
8119 ffeexprExpr_ e;
8120
8121 /* First push the (%LOC) expression as an operand onto the expression
8122 stack. */
8123
8124 e = ffeexpr_expr_new_ ();
8125 e->type = FFEEXPR_exprtypeOPERAND_;
8126 e->token = ffeexpr_stack_->tokens[0];
8127 e->u.operand = ffebld_new_percent_loc (expr);
8128 ffebld_set_info (e->u.operand,
8129 ffeinfo_new (FFEINFO_basictypeINTEGER,
8130 ffecom_pointer_kind (),
8131 0,
8132 FFEINFO_kindENTITY,
8133 FFEINFO_whereFLEETING,
8134 FFETARGET_charactersizeNONE));
8135 #if 0 /* ~~ */
8136 e->u.operand = ffeexpr_collapse_percent_loc (e->u.operand, ft);
8137 #endif
8138 ffeexpr_exprstack_push_operand_ (e);
8139
8140 /* Now, if the token is a close parenthese, we're in great shape so return
8141 the next handler. */
8142
8143 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
8144 {
8145 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8146 return (ffelexHandler) ffeexpr_token_binary_;
8147 }
8148
8149 /* Oops, naughty user didn't specify the close paren! */
8150
8151 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
8152 {
8153 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8154 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
8155 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
8156 ffebad_finish ();
8157 }
8158
8159 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8160 return
8161 (ffelexHandler) ffeexpr_find_close_paren_ (t,
8162 (ffelexHandler)
8163 ffeexpr_token_binary_);
8164 }
8165
8166 /* ffeexpr_cb_end_notloc_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
8167
8168 Should be CLOSE_PAREN, and make sure expr isn't a %(VAL,REF,DESCR). */
8169
8170 static ffelexHandler
8171 ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr, ffelexToken t)
8172 {
8173 ffeexprExpr_ e;
8174 ffebldOp op;
8175
8176 /* If expression is itself a %(VAL,REF,DESCR), complain and strip off all
8177 such things until the lowest-level expression is reached. */
8178
8179 op = ffebld_op (expr);
8180 if ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
8181 || (op == FFEBLD_opPERCENT_DESCR))
8182 {
8183 if (ffebad_start (FFEBAD_NESTED_PERCENT))
8184 {
8185 ffebad_here (0, ffelex_token_where_line (ft),
8186 ffelex_token_where_column (ft));
8187 ffebad_finish ();
8188 }
8189
8190 do
8191 {
8192 expr = ffebld_left (expr);
8193 op = ffebld_op (expr);
8194 }
8195 while ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
8196 || (op == FFEBLD_opPERCENT_DESCR));
8197 }
8198
8199 /* Push the expression as an operand onto the expression stack. */
8200
8201 e = ffeexpr_expr_new_ ();
8202 e->type = FFEEXPR_exprtypeOPERAND_;
8203 e->token = ffeexpr_stack_->tokens[0];
8204 switch (ffeexpr_stack_->percent)
8205 {
8206 case FFEEXPR_percentVAL_:
8207 e->u.operand = ffebld_new_percent_val (expr);
8208 break;
8209
8210 case FFEEXPR_percentREF_:
8211 e->u.operand = ffebld_new_percent_ref (expr);
8212 break;
8213
8214 case FFEEXPR_percentDESCR_:
8215 e->u.operand = ffebld_new_percent_descr (expr);
8216 break;
8217
8218 default:
8219 assert ("%lossage" == NULL);
8220 e->u.operand = expr;
8221 break;
8222 }
8223 ffebld_set_info (e->u.operand, ffebld_info (expr));
8224 #if 0 /* ~~ */
8225 e->u.operand = ffeexpr_collapse_percent_ ? ? ? (e->u.operand, ft);
8226 #endif
8227 ffeexpr_exprstack_push_operand_ (e);
8228
8229 /* Now, if the token is a close parenthese, we're in great shape so return
8230 the next handler. */
8231
8232 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
8233 return (ffelexHandler) ffeexpr_cb_end_notloc_1_;
8234
8235 /* Oops, naughty user didn't specify the close paren! */
8236
8237 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
8238 {
8239 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8240 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
8241 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
8242 ffebad_finish ();
8243 }
8244
8245 ffebld_set_op (e->u.operand, FFEBLD_opPERCENT_LOC);
8246
8247 switch (ffeexpr_stack_->context)
8248 {
8249 case FFEEXPR_contextACTUALARG_:
8250 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8251 break;
8252
8253 case FFEEXPR_contextINDEXORACTUALARG_:
8254 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8255 break;
8256
8257 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8258 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8259 break;
8260
8261 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8262 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8263 break;
8264
8265 default:
8266 assert ("bad context?!?!" == NULL);
8267 break;
8268 }
8269
8270 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8271 return
8272 (ffelexHandler) ffeexpr_find_close_paren_ (t,
8273 (ffelexHandler)
8274 ffeexpr_cb_end_notloc_1_);
8275 }
8276
8277 /* ffeexpr_cb_end_notloc_1_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
8278 CLOSE_PAREN
8279
8280 Should be COMMA or CLOSE_PAREN, else change back to %LOC. */
8281
8282 static ffelexHandler
8283 ffeexpr_cb_end_notloc_1_ (ffelexToken t)
8284 {
8285 switch (ffelex_token_type (t))
8286 {
8287 case FFELEX_typeCOMMA:
8288 case FFELEX_typeCLOSE_PAREN:
8289 switch (ffeexpr_stack_->context)
8290 {
8291 case FFEEXPR_contextACTUALARG_:
8292 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8293 break;
8294
8295 case FFEEXPR_contextINDEXORACTUALARG_:
8296 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
8297 break;
8298
8299 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8300 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
8301 break;
8302
8303 default:
8304 assert ("bad context?!?!" == NULL);
8305 break;
8306 }
8307 break;
8308
8309 default:
8310 if (ffebad_start (FFEBAD_INVALID_PERCENT))
8311 {
8312 ffebad_here (0,
8313 ffelex_token_where_line (ffeexpr_stack_->first_token),
8314 ffelex_token_where_column (ffeexpr_stack_->first_token));
8315 ffebad_string (ffelex_token_text (ffeexpr_stack_->tokens[1]));
8316 ffebad_finish ();
8317 }
8318
8319 ffebld_set_op (ffeexpr_stack_->exprstack->u.operand,
8320 FFEBLD_opPERCENT_LOC);
8321
8322 switch (ffeexpr_stack_->context)
8323 {
8324 case FFEEXPR_contextACTUALARG_:
8325 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8326 break;
8327
8328 case FFEEXPR_contextINDEXORACTUALARG_:
8329 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8330 break;
8331
8332 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8333 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8334 break;
8335
8336 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8337 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8338 break;
8339
8340 default:
8341 assert ("bad context?!?!" == NULL);
8342 break;
8343 }
8344 }
8345
8346 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8347 return
8348 (ffelexHandler) ffeexpr_token_binary_ (t);
8349 }
8350
8351 /* Process DATA implied-DO iterator variables as this implied-DO level
8352 terminates. At this point, ffeexpr_level_ == 1 when we see the
8353 last right-paren in "DATA (A(I),I=1,10)/.../". */
8354
8355 static ffesymbol
8356 ffeexpr_check_impctrl_ (ffesymbol s)
8357 {
8358 assert (s != NULL);
8359 assert (ffesymbol_sfdummyparent (s) != NULL);
8360
8361 switch (ffesymbol_state (s))
8362 {
8363 case FFESYMBOL_stateNONE: /* Used as iterator already. Now let symbol
8364 be used as iterator at any level at or
8365 innermore than the outermost of the
8366 current level and the symbol's current
8367 level. */
8368 if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
8369 {
8370 ffesymbol_signal_change (s);
8371 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
8372 ffesymbol_signal_unreported (s);
8373 }
8374 break;
8375
8376 case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO.
8377 Error if at outermost level, else it can
8378 still become an iterator. */
8379 if ((ffeexpr_level_ == 1)
8380 && ffebad_start (FFEBAD_BAD_IMPDCL))
8381 {
8382 ffebad_string (ffesymbol_text (s));
8383 ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
8384 ffebad_finish ();
8385 }
8386 break;
8387
8388 case FFESYMBOL_stateUNCERTAIN: /* Iterator. */
8389 assert (ffeexpr_level_ <= ffesymbol_maxentrynum (s));
8390 ffesymbol_signal_change (s);
8391 ffesymbol_set_state (s, FFESYMBOL_stateNONE);
8392 ffesymbol_signal_unreported (s);
8393 break;
8394
8395 case FFESYMBOL_stateUNDERSTOOD:
8396 break; /* ANY. */
8397
8398 default:
8399 assert ("Sasha Foo!!" == NULL);
8400 break;
8401 }
8402
8403 return s;
8404 }
8405
8406 /* Issue diagnostic if implied-DO variable appears in list of lhs
8407 expressions (as in "READ *, (I,I=1,10)"). */
8408
8409 static void
8410 ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
8411 ffebld dovar, ffelexToken dovar_t)
8412 {
8413 ffebld item;
8414 ffesymbol dovar_sym;
8415 int itemnum;
8416
8417 if (ffebld_op (dovar) != FFEBLD_opSYMTER)
8418 return; /* Presumably opANY. */
8419
8420 dovar_sym = ffebld_symter (dovar);
8421
8422 for (itemnum = 1; list != NULL; list = ffebld_trail (list), ++itemnum)
8423 {
8424 if (((item = ffebld_head (list)) != NULL)
8425 && (ffebld_op (item) == FFEBLD_opSYMTER)
8426 && (ffebld_symter (item) == dovar_sym))
8427 {
8428 char itemno[20];
8429
8430 sprintf (&itemno[0], "%d", itemnum);
8431 if (ffebad_start (FFEBAD_DOITER_IMPDO))
8432 {
8433 ffebad_here (0, ffelex_token_where_line (list_t),
8434 ffelex_token_where_column (list_t));
8435 ffebad_here (1, ffelex_token_where_line (dovar_t),
8436 ffelex_token_where_column (dovar_t));
8437 ffebad_string (ffesymbol_text (dovar_sym));
8438 ffebad_string (itemno);
8439 ffebad_finish ();
8440 }
8441 }
8442 }
8443 }
8444
8445 /* Decorate any SYMTERs referencing the DO variable with the "doiter"
8446 flag. */
8447
8448 static void
8449 ffeexpr_update_impdo_ (ffebld list, ffebld dovar)
8450 {
8451 ffesymbol dovar_sym;
8452
8453 if (ffebld_op (dovar) != FFEBLD_opSYMTER)
8454 return; /* Presumably opANY. */
8455
8456 dovar_sym = ffebld_symter (dovar);
8457
8458 ffeexpr_update_impdo_sym_ (list, dovar_sym); /* Recurse! */
8459 }
8460
8461 /* Recursive function to update any expr so SYMTERs have "doiter" flag
8462 if they refer to the given variable. */
8463
8464 static void
8465 ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar)
8466 {
8467 tail_recurse: /* :::::::::::::::::::: */
8468
8469 if (expr == NULL)
8470 return;
8471
8472 switch (ffebld_op (expr))
8473 {
8474 case FFEBLD_opSYMTER:
8475 if (ffebld_symter (expr) == dovar)
8476 ffebld_symter_set_is_doiter (expr, TRUE);
8477 break;
8478
8479 case FFEBLD_opITEM:
8480 ffeexpr_update_impdo_sym_ (ffebld_head (expr), dovar);
8481 expr = ffebld_trail (expr);
8482 goto tail_recurse; /* :::::::::::::::::::: */
8483
8484 default:
8485 break;
8486 }
8487
8488 switch (ffebld_arity (expr))
8489 {
8490 case 2:
8491 ffeexpr_update_impdo_sym_ (ffebld_left (expr), dovar);
8492 expr = ffebld_right (expr);
8493 goto tail_recurse; /* :::::::::::::::::::: */
8494
8495 case 1:
8496 expr = ffebld_left (expr);
8497 goto tail_recurse; /* :::::::::::::::::::: */
8498
8499 default:
8500 break;
8501 }
8502
8503 return;
8504 }
8505
8506 /* ffeexpr_context_outer_ -- Determine context of stack entry, skipping PARENs
8507
8508 if (ffeexpr_context_outer_(ffeexpr_stack_) == FFEEXPR_contextIF)
8509 // After zero or more PAREN_ contexts, an IF context exists */
8510
8511 static ffeexprContext
8512 ffeexpr_context_outer_ (ffeexprStack_ s)
8513 {
8514 assert (s != NULL);
8515
8516 for (;;)
8517 {
8518 switch (s->context)
8519 {
8520 case FFEEXPR_contextPAREN_:
8521 case FFEEXPR_contextPARENFILENUM_:
8522 case FFEEXPR_contextPARENFILEUNIT_:
8523 break;
8524
8525 default:
8526 return s->context;
8527 }
8528 s = s->previous;
8529 assert (s != NULL);
8530 }
8531 }
8532
8533 /* ffeexpr_dotdot_ -- Look up name in list of .FOO. possibilities
8534
8535 ffeexprDotdot_ d;
8536 ffelexToken t;
8537 d = ffeexpr_dotdot_(t);
8538
8539 Returns the identifier for the name, or the NONE identifier. */
8540
8541 static ffeexprDotdot_
8542 ffeexpr_dotdot_ (ffelexToken t)
8543 {
8544 char *p;
8545
8546 switch (ffelex_token_length (t))
8547 {
8548 case 2:
8549 switch (*(p = ffelex_token_text (t)))
8550 {
8551 case FFESRC_CASE_MATCH_INIT ('E', 'e', match_2e, no_match_2):
8552 if (ffesrc_char_match_noninit (*++p, 'Q', 'q'))
8553 return FFEEXPR_dotdotEQ_;
8554 return FFEEXPR_dotdotNONE_;
8555
8556 case FFESRC_CASE_MATCH_INIT ('G', 'g', match_2g, no_match_2):
8557 if (ffesrc_char_match_noninit (*++p, 'E', 'e'))
8558 return FFEEXPR_dotdotGE_;
8559 if (ffesrc_char_match_noninit (*p, 'T', 't'))
8560 return FFEEXPR_dotdotGT_;
8561 return FFEEXPR_dotdotNONE_;
8562
8563 case FFESRC_CASE_MATCH_INIT ('L', 'l', match_2l, no_match_2):
8564 if (ffesrc_char_match_noninit (*++p, 'E', 'e'))
8565 return FFEEXPR_dotdotLE_;
8566 if (ffesrc_char_match_noninit (*p, 'T', 't'))
8567 return FFEEXPR_dotdotLT_;
8568 return FFEEXPR_dotdotNONE_;
8569
8570 case FFESRC_CASE_MATCH_INIT ('N', 'n', match_2n, no_match_2):
8571 if (ffesrc_char_match_noninit (*++p, 'E', 'e'))
8572 return FFEEXPR_dotdotNE_;
8573 return FFEEXPR_dotdotNONE_;
8574
8575 case FFESRC_CASE_MATCH_INIT ('O', 'o', match_2o, no_match_2):
8576 if (ffesrc_char_match_noninit (*++p, 'R', 'r'))
8577 return FFEEXPR_dotdotOR_;
8578 return FFEEXPR_dotdotNONE_;
8579
8580 default:
8581 no_match_2: /* :::::::::::::::::::: */
8582 return FFEEXPR_dotdotNONE_;
8583 }
8584
8585 case 3:
8586 switch (*(p = ffelex_token_text (t)))
8587 {
8588 case FFESRC_CASE_MATCH_INIT ('A', 'a', match_3a, no_match_3):
8589 if ((ffesrc_char_match_noninit (*++p, 'N', 'n'))
8590 && (ffesrc_char_match_noninit (*++p, 'D', 'd')))
8591 return FFEEXPR_dotdotAND_;
8592 return FFEEXPR_dotdotNONE_;
8593
8594 case FFESRC_CASE_MATCH_INIT ('E', 'e', match_3e, no_match_3):
8595 if ((ffesrc_char_match_noninit (*++p, 'Q', 'q'))
8596 && (ffesrc_char_match_noninit (*++p, 'V', 'v')))
8597 return FFEEXPR_dotdotEQV_;
8598 return FFEEXPR_dotdotNONE_;
8599
8600 case FFESRC_CASE_MATCH_INIT ('N', 'n', match_3n, no_match_3):
8601 if ((ffesrc_char_match_noninit (*++p, 'O', 'o'))
8602 && (ffesrc_char_match_noninit (*++p, 'T', 't')))
8603 return FFEEXPR_dotdotNOT_;
8604 return FFEEXPR_dotdotNONE_;
8605
8606 case FFESRC_CASE_MATCH_INIT ('X', 'x', match_3x, no_match_3):
8607 if ((ffesrc_char_match_noninit (*++p, 'O', 'o'))
8608 && (ffesrc_char_match_noninit (*++p, 'R', 'r')))
8609 return FFEEXPR_dotdotXOR_;
8610 return FFEEXPR_dotdotNONE_;
8611
8612 default:
8613 no_match_3: /* :::::::::::::::::::: */
8614 return FFEEXPR_dotdotNONE_;
8615 }
8616
8617 case 4:
8618 switch (*(p = ffelex_token_text (t)))
8619 {
8620 case FFESRC_CASE_MATCH_INIT ('N', 'n', match_4n, no_match_4):
8621 if ((ffesrc_char_match_noninit (*++p, 'E', 'e'))
8622 && (ffesrc_char_match_noninit (*++p, 'Q', 'q'))
8623 && (ffesrc_char_match_noninit (*++p, 'V', 'v')))
8624 return FFEEXPR_dotdotNEQV_;
8625 return FFEEXPR_dotdotNONE_;
8626
8627 case FFESRC_CASE_MATCH_INIT ('T', 't', match_4t, no_match_4):
8628 if ((ffesrc_char_match_noninit (*++p, 'R', 'r'))
8629 && (ffesrc_char_match_noninit (*++p, 'U', 'u'))
8630 && (ffesrc_char_match_noninit (*++p, 'E', 'e')))
8631 return FFEEXPR_dotdotTRUE_;
8632 return FFEEXPR_dotdotNONE_;
8633
8634 default:
8635 no_match_4: /* :::::::::::::::::::: */
8636 return FFEEXPR_dotdotNONE_;
8637 }
8638
8639 case 5:
8640 if (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "FALSE",
8641 "false", "False")
8642 == 0)
8643 return FFEEXPR_dotdotFALSE_;
8644 return FFEEXPR_dotdotNONE_;
8645
8646 default:
8647 return FFEEXPR_dotdotNONE_;
8648 }
8649 }
8650
8651 /* ffeexpr_percent_ -- Look up name in list of %FOO possibilities
8652
8653 ffeexprPercent_ p;
8654 ffelexToken t;
8655 p = ffeexpr_percent_(t);
8656
8657 Returns the identifier for the name, or the NONE identifier. */
8658
8659 static ffeexprPercent_
8660 ffeexpr_percent_ (ffelexToken t)
8661 {
8662 char *p;
8663
8664 switch (ffelex_token_length (t))
8665 {
8666 case 3:
8667 switch (*(p = ffelex_token_text (t)))
8668 {
8669 case FFESRC_CASE_MATCH_INIT ('L', 'l', match_3l, no_match_3):
8670 if ((ffesrc_char_match_noninit (*++p, 'O', 'o'))
8671 && (ffesrc_char_match_noninit (*++p, 'C', 'c')))
8672 return FFEEXPR_percentLOC_;
8673 return FFEEXPR_percentNONE_;
8674
8675 case FFESRC_CASE_MATCH_INIT ('R', 'r', match_3r, no_match_3):
8676 if ((ffesrc_char_match_noninit (*++p, 'E', 'e'))
8677 && (ffesrc_char_match_noninit (*++p, 'F', 'f')))
8678 return FFEEXPR_percentREF_;
8679 return FFEEXPR_percentNONE_;
8680
8681 case FFESRC_CASE_MATCH_INIT ('V', 'v', match_3v, no_match_3):
8682 if ((ffesrc_char_match_noninit (*++p, 'A', 'a'))
8683 && (ffesrc_char_match_noninit (*++p, 'L', 'l')))
8684 return FFEEXPR_percentVAL_;
8685 return FFEEXPR_percentNONE_;
8686
8687 default:
8688 no_match_3: /* :::::::::::::::::::: */
8689 return FFEEXPR_percentNONE_;
8690 }
8691
8692 case 5:
8693 if (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "DESCR",
8694 "descr", "Descr") == 0)
8695 return FFEEXPR_percentDESCR_;
8696 return FFEEXPR_percentNONE_;
8697
8698 default:
8699 return FFEEXPR_percentNONE_;
8700 }
8701 }
8702
8703 /* ffeexpr_type_combine -- Binop combine types, check for mythical new COMPLEX
8704
8705 See prototype.
8706
8707 If combining the two basictype/kindtype pairs produces a COMPLEX with an
8708 unsupported kind type, complain and use the default kind type for
8709 COMPLEX. */
8710
8711 void
8712 ffeexpr_type_combine (ffeinfoBasictype *xnbt, ffeinfoKindtype *xnkt,
8713 ffeinfoBasictype lbt, ffeinfoKindtype lkt,
8714 ffeinfoBasictype rbt, ffeinfoKindtype rkt,
8715 ffelexToken t)
8716 {
8717 ffeinfoBasictype nbt;
8718 ffeinfoKindtype nkt;
8719
8720 nbt = ffeinfo_basictype_combine (lbt, rbt);
8721 if ((nbt == FFEINFO_basictypeCOMPLEX)
8722 && ((lbt == nbt) || (lbt == FFEINFO_basictypeREAL))
8723 && ((rbt == nbt) || (rbt == FFEINFO_basictypeREAL)))
8724 {
8725 nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
8726 if (ffe_is_pedantic_not_90 () && (nkt == FFEINFO_kindtypeREALDOUBLE))
8727 nkt = FFEINFO_kindtypeNONE; /* Force error. */
8728 switch (nkt)
8729 {
8730 #if FFETARGET_okCOMPLEX1
8731 case FFEINFO_kindtypeREAL1:
8732 #endif
8733 #if FFETARGET_okCOMPLEX2
8734 case FFEINFO_kindtypeREAL2:
8735 #endif
8736 #if FFETARGET_okCOMPLEX3
8737 case FFEINFO_kindtypeREAL3:
8738 #endif
8739 #if FFETARGET_okCOMPLEX4
8740 case FFEINFO_kindtypeREAL4:
8741 #endif
8742 break; /* Fine and dandy. */
8743
8744 default:
8745 if (t != NULL)
8746 {
8747 ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
8748 ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX);
8749 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8750 ffebad_finish ();
8751 }
8752 nbt = FFEINFO_basictypeNONE;
8753 nkt = FFEINFO_kindtypeNONE;
8754 break;
8755
8756 case FFEINFO_kindtypeANY:
8757 nkt = FFEINFO_kindtypeREALDEFAULT;
8758 break;
8759 }
8760 }
8761 else
8762 { /* The normal stuff. */
8763 if (nbt == lbt)
8764 {
8765 if (nbt == rbt)
8766 nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
8767 else
8768 nkt = lkt;
8769 }
8770 else if (nbt == rbt)
8771 nkt = rkt;
8772 else
8773 { /* Let the caller do the complaining. */
8774 nbt = FFEINFO_basictypeNONE;
8775 nkt = FFEINFO_kindtypeNONE;
8776 }
8777 }
8778
8779 /* Always a good idea to avoid aliasing problems. */
8780
8781 *xnbt = nbt;
8782 *xnkt = nkt;
8783 }
8784
8785 /* ffeexpr_token_first_lhs_ -- First state for lhs expression
8786
8787 Return a pointer to this function to the lexer (ffelex), which will
8788 invoke it for the next token.
8789
8790 Record line and column of first token in expression, then invoke the
8791 initial-state lhs handler. */
8792
8793 static ffelexHandler
8794 ffeexpr_token_first_lhs_ (ffelexToken t)
8795 {
8796 ffeexpr_stack_->first_token = ffelex_token_use (t);
8797
8798 /* When changing the list of valid initial lhs tokens, check whether to
8799 update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
8800 READ (expr) <token> case -- it assumes it knows which tokens <token> can
8801 be to indicate an lhs (or implied DO), which right now is the set
8802 {NAME,OPEN_PAREN}.
8803
8804 This comment also appears in ffeexpr_token_lhs_. */
8805
8806 switch (ffelex_token_type (t))
8807 {
8808 case FFELEX_typeOPEN_PAREN:
8809 switch (ffeexpr_stack_->context)
8810 {
8811 case FFEEXPR_contextDATA:
8812 ffe_init_4 ();
8813 ffeexpr_level_ = 1; /* Level of DATA implied-DO construct. */
8814 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8815 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8816 FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
8817
8818 case FFEEXPR_contextDATAIMPDOITEM_:
8819 ++ffeexpr_level_; /* Level of DATA implied-DO construct. */
8820 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8821 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8822 FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
8823
8824 case FFEEXPR_contextIOLIST:
8825 case FFEEXPR_contextIMPDOITEM_:
8826 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8827 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8828 FFEEXPR_contextIMPDOITEM_, ffeexpr_cb_comma_i_);
8829
8830 case FFEEXPR_contextIOLISTDF:
8831 case FFEEXPR_contextIMPDOITEMDF_:
8832 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8833 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8834 FFEEXPR_contextIMPDOITEMDF_, ffeexpr_cb_comma_i_);
8835
8836 case FFEEXPR_contextFILEEXTFUNC:
8837 assert (ffeexpr_stack_->exprstack == NULL);
8838 return (ffelexHandler) ffeexpr_token_first_lhs_1_;
8839
8840 default:
8841 break;
8842 }
8843 break;
8844
8845 case FFELEX_typeNAME:
8846 switch (ffeexpr_stack_->context)
8847 {
8848 case FFEEXPR_contextFILENAMELIST:
8849 assert (ffeexpr_stack_->exprstack == NULL);
8850 return (ffelexHandler) ffeexpr_token_namelist_;
8851
8852 case FFEEXPR_contextFILEEXTFUNC:
8853 assert (ffeexpr_stack_->exprstack == NULL);
8854 return (ffelexHandler) ffeexpr_token_first_lhs_1_;
8855
8856 default:
8857 break;
8858 }
8859 break;
8860
8861 default:
8862 switch (ffeexpr_stack_->context)
8863 {
8864 case FFEEXPR_contextFILEEXTFUNC:
8865 assert (ffeexpr_stack_->exprstack == NULL);
8866 return (ffelexHandler) ffeexpr_token_first_lhs_1_;
8867
8868 default:
8869 break;
8870 }
8871 break;
8872 }
8873
8874 return (ffelexHandler) ffeexpr_token_lhs_ (t);
8875 }
8876
8877 /* ffeexpr_token_first_lhs_1_ -- NAME
8878
8879 return ffeexpr_token_first_lhs_1_; // to lexer
8880
8881 Handle NAME as an external function (USEROPEN= VXT extension to OPEN
8882 statement). */
8883
8884 static ffelexHandler
8885 ffeexpr_token_first_lhs_1_ (ffelexToken t)
8886 {
8887 ffeexprCallback callback;
8888 ffeexprStack_ s;
8889 ffelexHandler next;
8890 ffelexToken ft;
8891 ffesymbol sy = NULL;
8892 ffebld expr;
8893
8894 ffebld_pool_pop ();
8895 callback = ffeexpr_stack_->callback;
8896 ft = ffeexpr_stack_->first_token;
8897 s = ffeexpr_stack_->previous;
8898
8899 if ((ffelex_token_type (ft) != FFELEX_typeNAME)
8900 || (ffesymbol_attrs (sy = ffeexpr_declare_unadorned_ (ft, FALSE))
8901 & FFESYMBOL_attrANY))
8902 {
8903 if ((ffelex_token_type (ft) != FFELEX_typeNAME)
8904 || !(ffesymbol_attrs (sy) & FFESYMBOL_attrsANY))
8905 {
8906 ffebad_start (FFEBAD_EXPR_WRONG);
8907 ffebad_here (0, ffelex_token_where_line (ft),
8908 ffelex_token_where_column (ft));
8909 ffebad_finish ();
8910 }
8911 expr = ffebld_new_any ();
8912 ffebld_set_info (expr, ffeinfo_new_any ());
8913 }
8914 else
8915 {
8916 expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
8917 FFEINTRIN_impNONE);
8918 ffebld_set_info (expr, ffesymbol_info (sy));
8919 }
8920
8921 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
8922 sizeof (*ffeexpr_stack_));
8923 ffeexpr_stack_ = s;
8924
8925 next = (ffelexHandler) (*callback) (ft, expr, t);
8926 ffelex_token_kill (ft);
8927 return (ffelexHandler) next;
8928 }
8929
8930 /* ffeexpr_token_first_rhs_ -- First state for rhs expression
8931
8932 Record line and column of first token in expression, then invoke the
8933 initial-state rhs handler.
8934
8935 19-Feb-91 JCB 1.1
8936 Allow ASTERISK in PARENFILEUNIT_ case, but only on second level only
8937 (i.e. only as in READ(*), not READ((*))). */
8938
8939 static ffelexHandler
8940 ffeexpr_token_first_rhs_ (ffelexToken t)
8941 {
8942 ffesymbol s;
8943
8944 ffeexpr_stack_->first_token = ffelex_token_use (t);
8945
8946 switch (ffelex_token_type (t))
8947 {
8948 case FFELEX_typeASTERISK:
8949 switch (ffeexpr_stack_->context)
8950 {
8951 case FFEEXPR_contextFILEFORMATNML:
8952 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8953 /* Fall through. */
8954 case FFEEXPR_contextFILEUNIT:
8955 case FFEEXPR_contextDIMLIST:
8956 case FFEEXPR_contextFILEFORMAT:
8957 case FFEEXPR_contextCHARACTERSIZE:
8958 if (ffeexpr_stack_->previous != NULL)
8959 break; /* Valid only on first level. */
8960 assert (ffeexpr_stack_->exprstack == NULL);
8961 return (ffelexHandler) ffeexpr_token_first_rhs_1_;
8962
8963 case FFEEXPR_contextPARENFILEUNIT_:
8964 if (ffeexpr_stack_->previous->previous != NULL)
8965 break; /* Valid only on second level. */
8966 assert (ffeexpr_stack_->exprstack == NULL);
8967 return (ffelexHandler) ffeexpr_token_first_rhs_1_;
8968
8969 case FFEEXPR_contextACTUALARG_:
8970 if (ffeexpr_stack_->previous->context
8971 != FFEEXPR_contextSUBROUTINEREF)
8972 {
8973 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8974 break;
8975 }
8976 assert (ffeexpr_stack_->exprstack == NULL);
8977 return (ffelexHandler) ffeexpr_token_first_rhs_3_;
8978
8979 case FFEEXPR_contextINDEXORACTUALARG_:
8980 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8981 break;
8982
8983 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8984 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8985 break;
8986
8987 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8988 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8989 break;
8990
8991 default:
8992 break;
8993 }
8994 break;
8995
8996 case FFELEX_typeOPEN_PAREN:
8997 switch (ffeexpr_stack_->context)
8998 {
8999 case FFEEXPR_contextFILENUMAMBIG:
9000 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
9001 FFEEXPR_contextPARENFILENUM_,
9002 ffeexpr_cb_close_paren_ambig_);
9003
9004 case FFEEXPR_contextFILEUNITAMBIG:
9005 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
9006 FFEEXPR_contextPARENFILEUNIT_,
9007 ffeexpr_cb_close_paren_ambig_);
9008
9009 case FFEEXPR_contextIOLIST:
9010 case FFEEXPR_contextIMPDOITEM_:
9011 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
9012 FFEEXPR_contextIMPDOITEM_,
9013 ffeexpr_cb_close_paren_ci_);
9014
9015 case FFEEXPR_contextIOLISTDF:
9016 case FFEEXPR_contextIMPDOITEMDF_:
9017 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
9018 FFEEXPR_contextIMPDOITEMDF_,
9019 ffeexpr_cb_close_paren_ci_);
9020
9021 case FFEEXPR_contextFILEFORMATNML:
9022 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
9023 break;
9024
9025 case FFEEXPR_contextACTUALARG_:
9026 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
9027 break;
9028
9029 case FFEEXPR_contextINDEXORACTUALARG_:
9030 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
9031 break;
9032
9033 case FFEEXPR_contextSFUNCDEFACTUALARG_:
9034 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
9035 break;
9036
9037 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9038 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
9039 break;
9040
9041 default:
9042 break;
9043 }
9044 break;
9045
9046 case FFELEX_typeNUMBER:
9047 switch (ffeexpr_stack_->context)
9048 {
9049 case FFEEXPR_contextFILEFORMATNML:
9050 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
9051 /* Fall through. */
9052 case FFEEXPR_contextFILEFORMAT:
9053 if (ffeexpr_stack_->previous != NULL)
9054 break; /* Valid only on first level. */
9055 assert (ffeexpr_stack_->exprstack == NULL);
9056 return (ffelexHandler) ffeexpr_token_first_rhs_2_;
9057
9058 case FFEEXPR_contextACTUALARG_:
9059 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
9060 break;
9061
9062 case FFEEXPR_contextINDEXORACTUALARG_:
9063 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
9064 break;
9065
9066 case FFEEXPR_contextSFUNCDEFACTUALARG_:
9067 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
9068 break;
9069
9070 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9071 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
9072 break;
9073
9074 default:
9075 break;
9076 }
9077 break;
9078
9079 case FFELEX_typeNAME:
9080 switch (ffeexpr_stack_->context)
9081 {
9082 case FFEEXPR_contextFILEFORMATNML:
9083 assert (ffeexpr_stack_->exprstack == NULL);
9084 s = ffesymbol_lookup_local (t);
9085 if ((s != NULL) && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST))
9086 return (ffelexHandler) ffeexpr_token_namelist_;
9087 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
9088 break;
9089
9090 default:
9091 break;
9092 }
9093 break;
9094
9095 case FFELEX_typePERCENT:
9096 switch (ffeexpr_stack_->context)
9097 {
9098 case FFEEXPR_contextACTUALARG_:
9099 case FFEEXPR_contextINDEXORACTUALARG_:
9100 case FFEEXPR_contextSFUNCDEFACTUALARG_:
9101 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9102 return (ffelexHandler) ffeexpr_token_first_rhs_5_;
9103
9104 case FFEEXPR_contextFILEFORMATNML:
9105 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
9106 break;
9107
9108 default:
9109 break;
9110 }
9111
9112 default:
9113 switch (ffeexpr_stack_->context)
9114 {
9115 case FFEEXPR_contextACTUALARG_:
9116 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
9117 break;
9118
9119 case FFEEXPR_contextINDEXORACTUALARG_:
9120 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
9121 break;
9122
9123 case FFEEXPR_contextSFUNCDEFACTUALARG_:
9124 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
9125 break;
9126
9127 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9128 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
9129 break;
9130
9131 case FFEEXPR_contextFILEFORMATNML:
9132 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
9133 break;
9134
9135 default:
9136 break;
9137 }
9138 break;
9139 }
9140
9141 return (ffelexHandler) ffeexpr_token_rhs_ (t);
9142 }
9143
9144 /* ffeexpr_token_first_rhs_1_ -- ASTERISK
9145
9146 return ffeexpr_token_first_rhs_1_; // to lexer
9147
9148 Return STAR as expression. */
9149
9150 static ffelexHandler
9151 ffeexpr_token_first_rhs_1_ (ffelexToken t)
9152 {
9153 ffebld expr;
9154 ffeexprCallback callback;
9155 ffeexprStack_ s;
9156 ffelexHandler next;
9157 ffelexToken ft;
9158
9159 expr = ffebld_new_star ();
9160 ffebld_pool_pop ();
9161 callback = ffeexpr_stack_->callback;
9162 ft = ffeexpr_stack_->first_token;
9163 s = ffeexpr_stack_->previous;
9164 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
9165 ffeexpr_stack_ = s;
9166 next = (ffelexHandler) (*callback) (ft, expr, t);
9167 ffelex_token_kill (ft);
9168 return (ffelexHandler) next;
9169 }
9170
9171 /* ffeexpr_token_first_rhs_2_ -- NUMBER
9172
9173 return ffeexpr_token_first_rhs_2_; // to lexer
9174
9175 Return NULL as expression; NUMBER as first (and only) token, unless the
9176 current token is not a terminating token, in which case run normal
9177 expression handling. */
9178
9179 static ffelexHandler
9180 ffeexpr_token_first_rhs_2_ (ffelexToken t)
9181 {
9182 ffeexprCallback callback;
9183 ffeexprStack_ s;
9184 ffelexHandler next;
9185 ffelexToken ft;
9186
9187 switch (ffelex_token_type (t))
9188 {
9189 case FFELEX_typeCLOSE_PAREN:
9190 case FFELEX_typeCOMMA:
9191 case FFELEX_typeEOS:
9192 case FFELEX_typeSEMICOLON:
9193 break;
9194
9195 default:
9196 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9197 return (ffelexHandler) (*next) (t);
9198 }
9199
9200 ffebld_pool_pop ();
9201 callback = ffeexpr_stack_->callback;
9202 ft = ffeexpr_stack_->first_token;
9203 s = ffeexpr_stack_->previous;
9204 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
9205 sizeof (*ffeexpr_stack_));
9206 ffeexpr_stack_ = s;
9207 next = (ffelexHandler) (*callback) (ft, NULL, t);
9208 ffelex_token_kill (ft);
9209 return (ffelexHandler) next;
9210 }
9211
9212 /* ffeexpr_token_first_rhs_3_ -- ASTERISK
9213
9214 return ffeexpr_token_first_rhs_3_; // to lexer
9215
9216 Expect NUMBER, make LABTOK (with copy of token if not inhibited after
9217 confirming, else NULL). */
9218
9219 static ffelexHandler
9220 ffeexpr_token_first_rhs_3_ (ffelexToken t)
9221 {
9222 ffelexHandler next;
9223
9224 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
9225 { /* An error, but let normal processing handle
9226 it. */
9227 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9228 return (ffelexHandler) (*next) (t);
9229 }
9230
9231 /* Special case: when we see "*10" as an argument to a subroutine
9232 reference, we confirm the current statement and, if not inhibited at
9233 this point, put a copy of the token into a LABTOK node. We do this
9234 instead of just resolving the label directly via ffelab and putting it
9235 into a LABTER simply to improve error reporting and consistency in
9236 ffestc. We put NULL in the LABTOK if we're still inhibited, so ffestb
9237 doesn't have to worry about killing off any tokens when retracting. */
9238
9239 ffest_confirmed ();
9240 if (ffest_is_inhibited ())
9241 ffeexpr_stack_->expr = ffebld_new_labtok (NULL);
9242 else
9243 ffeexpr_stack_->expr = ffebld_new_labtok (ffelex_token_use (t));
9244 ffebld_set_info (ffeexpr_stack_->expr,
9245 ffeinfo_new (FFEINFO_basictypeNONE,
9246 FFEINFO_kindtypeNONE,
9247 0,
9248 FFEINFO_kindNONE,
9249 FFEINFO_whereNONE,
9250 FFETARGET_charactersizeNONE));
9251
9252 return (ffelexHandler) ffeexpr_token_first_rhs_4_;
9253 }
9254
9255 /* ffeexpr_token_first_rhs_4_ -- ASTERISK NUMBER
9256
9257 return ffeexpr_token_first_rhs_4_; // to lexer
9258
9259 Collect/flush appropriate stuff, send token to callback function. */
9260
9261 static ffelexHandler
9262 ffeexpr_token_first_rhs_4_ (ffelexToken t)
9263 {
9264 ffebld expr;
9265 ffeexprCallback callback;
9266 ffeexprStack_ s;
9267 ffelexHandler next;
9268 ffelexToken ft;
9269
9270 expr = ffeexpr_stack_->expr;
9271 ffebld_pool_pop ();
9272 callback = ffeexpr_stack_->callback;
9273 ft = ffeexpr_stack_->first_token;
9274 s = ffeexpr_stack_->previous;
9275 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
9276 ffeexpr_stack_ = s;
9277 next = (ffelexHandler) (*callback) (ft, expr, t);
9278 ffelex_token_kill (ft);
9279 return (ffelexHandler) next;
9280 }
9281
9282 /* ffeexpr_token_first_rhs_5_ -- PERCENT
9283
9284 Should be NAME, or pass through original mechanism. If NAME is LOC,
9285 pass through original mechanism, otherwise must be VAL, REF, or DESCR,
9286 in which case handle the argument (in parentheses), etc. */
9287
9288 static ffelexHandler
9289 ffeexpr_token_first_rhs_5_ (ffelexToken t)
9290 {
9291 ffelexHandler next;
9292
9293 if (ffelex_token_type (t) == FFELEX_typeNAME)
9294 {
9295 ffeexprPercent_ p = ffeexpr_percent_ (t);
9296
9297 switch (p)
9298 {
9299 case FFEEXPR_percentNONE_:
9300 case FFEEXPR_percentLOC_:
9301 break; /* Treat %LOC as any other expression. */
9302
9303 case FFEEXPR_percentVAL_:
9304 case FFEEXPR_percentREF_:
9305 case FFEEXPR_percentDESCR_:
9306 ffeexpr_stack_->percent = p;
9307 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
9308 return (ffelexHandler) ffeexpr_token_first_rhs_6_;
9309
9310 default:
9311 assert ("bad percent?!?" == NULL);
9312 break;
9313 }
9314 }
9315
9316 switch (ffeexpr_stack_->context)
9317 {
9318 case FFEEXPR_contextACTUALARG_:
9319 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
9320 break;
9321
9322 case FFEEXPR_contextINDEXORACTUALARG_:
9323 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
9324 break;
9325
9326 case FFEEXPR_contextSFUNCDEFACTUALARG_:
9327 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
9328 break;
9329
9330 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9331 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
9332 break;
9333
9334 default:
9335 assert ("bad context?!?!" == NULL);
9336 break;
9337 }
9338
9339 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9340 return (ffelexHandler) (*next) (t);
9341 }
9342
9343 /* ffeexpr_token_first_rhs_6_ -- PERCENT NAME(VAL,REF,DESCR)
9344
9345 Should be OPEN_PAREN, or pass through original mechanism. */
9346
9347 static ffelexHandler
9348 ffeexpr_token_first_rhs_6_ (ffelexToken t)
9349 {
9350 ffelexHandler next;
9351 ffelexToken ft;
9352
9353 if (ffelex_token_type (t) == FFELEX_typeOPEN_PAREN)
9354 {
9355 ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
9356 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
9357 ffeexpr_stack_->context,
9358 ffeexpr_cb_end_notloc_);
9359 }
9360
9361 switch (ffeexpr_stack_->context)
9362 {
9363 case FFEEXPR_contextACTUALARG_:
9364 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
9365 break;
9366
9367 case FFEEXPR_contextINDEXORACTUALARG_:
9368 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
9369 break;
9370
9371 case FFEEXPR_contextSFUNCDEFACTUALARG_:
9372 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
9373 break;
9374
9375 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9376 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
9377 break;
9378
9379 default:
9380 assert ("bad context?!?!" == NULL);
9381 break;
9382 }
9383
9384 ft = ffeexpr_stack_->tokens[0];
9385 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9386 next = (ffelexHandler) (*next) (ft);
9387 ffelex_token_kill (ft);
9388 return (ffelexHandler) (*next) (t);
9389 }
9390
9391 /* ffeexpr_token_namelist_ -- NAME
9392
9393 return ffeexpr_token_namelist_; // to lexer
9394
9395 Make sure NAME was a valid namelist object, wrap it in a SYMTER and
9396 return. */
9397
9398 static ffelexHandler
9399 ffeexpr_token_namelist_ (ffelexToken t)
9400 {
9401 ffeexprCallback callback;
9402 ffeexprStack_ s;
9403 ffelexHandler next;
9404 ffelexToken ft;
9405 ffesymbol sy;
9406 ffebld expr;
9407
9408 ffebld_pool_pop ();
9409 callback = ffeexpr_stack_->callback;
9410 ft = ffeexpr_stack_->first_token;
9411 s = ffeexpr_stack_->previous;
9412 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
9413 ffeexpr_stack_ = s;
9414
9415 sy = ffesymbol_lookup_local (ft);
9416 if ((sy == NULL) || (ffesymbol_kind (sy) != FFEINFO_kindNAMELIST))
9417 {
9418 ffebad_start (FFEBAD_EXPR_WRONG);
9419 ffebad_here (0, ffelex_token_where_line (ft),
9420 ffelex_token_where_column (ft));
9421 ffebad_finish ();
9422 expr = ffebld_new_any ();
9423 ffebld_set_info (expr, ffeinfo_new_any ());
9424 }
9425 else
9426 {
9427 expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
9428 FFEINTRIN_impNONE);
9429 ffebld_set_info (expr, ffesymbol_info (sy));
9430 }
9431 next = (ffelexHandler) (*callback) (ft, expr, t);
9432 ffelex_token_kill (ft);
9433 return (ffelexHandler) next;
9434 }
9435
9436 /* ffeexpr_expr_kill_ -- Kill an existing internal expression object
9437
9438 ffeexprExpr_ e;
9439 ffeexpr_expr_kill_(e);
9440
9441 Kills the ffewhere info, if necessary, then kills the object. */
9442
9443 static void
9444 ffeexpr_expr_kill_ (ffeexprExpr_ e)
9445 {
9446 if (e->token != NULL)
9447 ffelex_token_kill (e->token);
9448 malloc_kill_ks (ffe_pool_program_unit (), e, sizeof (*e));
9449 }
9450
9451 /* ffeexpr_expr_new_ -- Make a new internal expression object
9452
9453 ffeexprExpr_ e;
9454 e = ffeexpr_expr_new_();
9455
9456 Allocates and initializes a new expression object, returns it. */
9457
9458 static ffeexprExpr_
9459 ffeexpr_expr_new_ ()
9460 {
9461 ffeexprExpr_ e;
9462
9463 e = (ffeexprExpr_) malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR expr",
9464 sizeof (*e));
9465 e->previous = NULL;
9466 e->type = FFEEXPR_exprtypeUNKNOWN_;
9467 e->token = NULL;
9468 return e;
9469 }
9470
9471 /* Verify that call to global is valid, and register whatever
9472 new information about a global might be discoverable by looking
9473 at the call. */
9474
9475 static void
9476 ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t)
9477 {
9478 int n_args;
9479 ffebld list;
9480 ffebld item;
9481 ffesymbol s;
9482
9483 assert ((ffebld_op (*expr) == FFEBLD_opSUBRREF)
9484 || (ffebld_op (*expr) == FFEBLD_opFUNCREF));
9485
9486 if (ffebld_op (ffebld_left (*expr)) != FFEBLD_opSYMTER)
9487 return;
9488
9489 if (ffesymbol_retractable ())
9490 return;
9491
9492 s = ffebld_symter (ffebld_left (*expr));
9493 if (ffesymbol_global (s) == NULL)
9494 return;
9495
9496 for (n_args = 0, list = ffebld_right (*expr);
9497 list != NULL;
9498 list = ffebld_trail (list), ++n_args)
9499 ;
9500
9501 if (ffeglobal_proc_ref_nargs (s, n_args, t))
9502 {
9503 ffeglobalArgSummary as;
9504 ffeinfoBasictype bt;
9505 ffeinfoKindtype kt;
9506 bool array;
9507 bool fail = FALSE;
9508
9509 for (n_args = 0, list = ffebld_right (*expr);
9510 list != NULL;
9511 list = ffebld_trail (list), ++n_args)
9512 {
9513 item = ffebld_head (list);
9514 if (item != NULL)
9515 {
9516 bt = ffeinfo_basictype (ffebld_info (item));
9517 kt = ffeinfo_kindtype (ffebld_info (item));
9518 array = (ffeinfo_rank (ffebld_info (item)) > 0);
9519 switch (ffebld_op (item))
9520 {
9521 case FFEBLD_opLABTOK:
9522 case FFEBLD_opLABTER:
9523 as = FFEGLOBAL_argsummaryALTRTN;
9524 break;
9525
9526 case FFEBLD_opPERCENT_LOC:
9527 as = FFEGLOBAL_argsummaryPTR;
9528 break;
9529
9530 case FFEBLD_opPERCENT_VAL:
9531 as = FFEGLOBAL_argsummaryVAL;
9532 break;
9533
9534 case FFEBLD_opPERCENT_REF:
9535 as = FFEGLOBAL_argsummaryREF;
9536 break;
9537
9538 case FFEBLD_opPERCENT_DESCR:
9539 as = FFEGLOBAL_argsummaryDESCR;
9540 break;
9541
9542 case FFEBLD_opFUNCREF:
9543 if ((ffebld_op (ffebld_left (item)) == FFEBLD_opSYMTER)
9544 && (ffesymbol_specific (ffebld_symter (ffebld_left (item)))
9545 == FFEINTRIN_specLOC))
9546 {
9547 as = FFEGLOBAL_argsummaryPTR;
9548 break;
9549 }
9550 /* Fall through. */
9551 default:
9552 if (ffebld_op (item) == FFEBLD_opSYMTER)
9553 {
9554 as = FFEGLOBAL_argsummaryNONE;
9555
9556 switch (ffeinfo_kind (ffebld_info (item)))
9557 {
9558 case FFEINFO_kindFUNCTION:
9559 as = FFEGLOBAL_argsummaryFUNC;
9560 break;
9561
9562 case FFEINFO_kindSUBROUTINE:
9563 as = FFEGLOBAL_argsummarySUBR;
9564 break;
9565
9566 case FFEINFO_kindNONE:
9567 as = FFEGLOBAL_argsummaryPROC;
9568 break;
9569
9570 default:
9571 break;
9572 }
9573
9574 if (as != FFEGLOBAL_argsummaryNONE)
9575 break;
9576 }
9577
9578 if (bt == FFEINFO_basictypeCHARACTER)
9579 as = FFEGLOBAL_argsummaryDESCR;
9580 else
9581 as = FFEGLOBAL_argsummaryREF;
9582 break;
9583 }
9584 }
9585 else
9586 {
9587 array = FALSE;
9588 as = FFEGLOBAL_argsummaryNONE;
9589 bt = FFEINFO_basictypeNONE;
9590 kt = FFEINFO_kindtypeNONE;
9591 }
9592
9593 if (! ffeglobal_proc_ref_arg (s, n_args, as, bt, kt, array, t))
9594 fail = TRUE;
9595 }
9596 if (! fail)
9597 return;
9598 }
9599
9600 *expr = ffebld_new_any ();
9601 ffebld_set_info (*expr, ffeinfo_new_any ());
9602 }
9603
9604 /* Check whether rest of string is all decimal digits. */
9605
9606 static bool
9607 ffeexpr_isdigits_ (char *p)
9608 {
9609 for (; *p != '\0'; ++p)
9610 if (!isdigit (*p))
9611 return FALSE;
9612 return TRUE;
9613 }
9614
9615 /* ffeexpr_exprstack_push_ -- Push an arbitrary expression object onto the stack
9616
9617 ffeexprExpr_ e;
9618 ffeexpr_exprstack_push_(e);
9619
9620 Pushes the expression onto the stack without any analysis of the existing
9621 contents of the stack. */
9622
9623 static void
9624 ffeexpr_exprstack_push_ (ffeexprExpr_ e)
9625 {
9626 e->previous = ffeexpr_stack_->exprstack;
9627 ffeexpr_stack_->exprstack = e;
9628 }
9629
9630 /* ffeexpr_exprstack_push_operand_ -- Push an operand onto the stack, reduce?
9631
9632 ffeexprExpr_ e;
9633 ffeexpr_exprstack_push_operand_(e);
9634
9635 Pushes the expression already containing an operand (a constant, variable,
9636 or more complicated expression that has already been fully resolved) after
9637 analyzing the stack and checking for possible reduction (which will never
9638 happen here since the highest precedence operator is ** and it has right-
9639 to-left associativity). */
9640
9641 static void
9642 ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e)
9643 {
9644 ffeexpr_exprstack_push_ (e);
9645 #ifdef WEIRD_NONFORTRAN_RULES
9646 if ((ffeexpr_stack_->exprstack != NULL)
9647 && (ffeexpr_stack_->exprstack->expr->type == FFEEXPR_exprtypeBINARY_)
9648 && (ffeexpr_stack_->exprstack->expr->u.operator.prec
9649 == FFEEXPR_operatorprecedenceHIGHEST_)
9650 && (ffeexpr_stack_->exprstack->expr->u.operator.as
9651 == FFEEXPR_operatorassociativityL2R_))
9652 ffeexpr_reduce_ ();
9653 #endif
9654 }
9655
9656 /* ffeexpr_exprstack_push_unary_ -- Push a unary operator onto the stack
9657
9658 ffeexprExpr_ e;
9659 ffeexpr_exprstack_push_unary_(e);
9660
9661 Pushes the expression already containing a unary operator. Reduction can
9662 never happen since unary operators are themselves always R-L; that is, the
9663 top of the expression stack is not an operand, in that it is either empty,
9664 has a binary operator at the top, or a unary operator at the top. In any
9665 of these cases, reduction is impossible. */
9666
9667 static void
9668 ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e)
9669 {
9670 if ((ffe_is_pedantic ()
9671 || ffe_is_warn_surprising ())
9672 && (ffeexpr_stack_->exprstack != NULL)
9673 && (ffeexpr_stack_->exprstack->type != FFEEXPR_exprtypeOPERAND_)
9674 && (ffeexpr_stack_->exprstack->u.operator.prec
9675 <= FFEEXPR_operatorprecedenceLOWARITH_)
9676 && (e->u.operator.prec <= FFEEXPR_operatorprecedenceLOWARITH_))
9677 {
9678 ffebad_start_msg ("Two arithmetic operators in a row at %0 and %1 -- use parentheses",
9679 ffe_is_pedantic ()
9680 ? FFEBAD_severityPEDANTIC
9681 : FFEBAD_severityWARNING);
9682 ffebad_here (0,
9683 ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
9684 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
9685 ffebad_here (1,
9686 ffelex_token_where_line (e->token),
9687 ffelex_token_where_column (e->token));
9688 ffebad_finish ();
9689 }
9690
9691 ffeexpr_exprstack_push_ (e);
9692 }
9693
9694 /* ffeexpr_exprstack_push_binary_ -- Push a binary operator onto the stack, reduce?
9695
9696 ffeexprExpr_ e;
9697 ffeexpr_exprstack_push_binary_(e);
9698
9699 Pushes the expression already containing a binary operator after checking
9700 whether reduction is possible. If the stack is not empty, the top of the
9701 stack must be an operand or syntactic analysis has failed somehow. If
9702 the operand is preceded by a unary operator of higher (or equal and L-R
9703 associativity) precedence than the new binary operator, then reduce that
9704 preceding operator and its operand(s) before pushing the new binary
9705 operator. */
9706
9707 static void
9708 ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e)
9709 {
9710 ffeexprExpr_ ce;
9711
9712 if (ffe_is_warn_surprising ()
9713 /* These next two are always true (see assertions below). */
9714 && (ffeexpr_stack_->exprstack != NULL)
9715 && (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_)
9716 /* If the previous operator is a unary minus, and the binary op
9717 is of higher precedence, might not do what user expects,
9718 e.g. "-2**2" is "-(2**2)", i.e. "-4", not "(-2)**2", which would
9719 yield "4". */
9720 && (ffeexpr_stack_->exprstack->previous != NULL)
9721 && (ffeexpr_stack_->exprstack->previous->type == FFEEXPR_exprtypeUNARY_)
9722 && (ffeexpr_stack_->exprstack->previous->u.operator.op
9723 == FFEEXPR_operatorSUBTRACT_)
9724 && (e->u.operator.prec
9725 < ffeexpr_stack_->exprstack->previous->u.operator.prec))
9726 {
9727 ffebad_start_msg ("Operator at %0 has lower precedence than that at %1 -- use parentheses", FFEBAD_severityWARNING);
9728 ffebad_here (0,
9729 ffelex_token_where_line (ffeexpr_stack_->exprstack->previous->token),
9730 ffelex_token_where_column (ffeexpr_stack_->exprstack->previous->token));
9731 ffebad_here (1,
9732 ffelex_token_where_line (e->token),
9733 ffelex_token_where_column (e->token));
9734 ffebad_finish ();
9735 }
9736
9737 again:
9738 assert (ffeexpr_stack_->exprstack != NULL);
9739 assert (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_);
9740 if ((ce = ffeexpr_stack_->exprstack->previous) != NULL)
9741 {
9742 assert (ce->type != FFEEXPR_exprtypeOPERAND_);
9743 if ((ce->u.operator.prec < e->u.operator.prec)
9744 || ((ce->u.operator.prec == e->u.operator.prec)
9745 && (e->u.operator.as == FFEEXPR_operatorassociativityL2R_)))
9746 {
9747 ffeexpr_reduce_ ();
9748 goto again; /* :::::::::::::::::::: */
9749 }
9750 }
9751
9752 ffeexpr_exprstack_push_ (e);
9753 }
9754
9755 /* ffeexpr_reduce_ -- Reduce highest operator w/operands on stack
9756
9757 ffeexpr_reduce_();
9758
9759 Converts operand binop operand or unop operand at top of stack to a
9760 single operand having the appropriate ffebld expression, and makes
9761 sure that the expression is proper (like not trying to add two character
9762 variables, not trying to concatenate two numbers). Also does the
9763 requisite type-assignment. */
9764
9765 static void
9766 ffeexpr_reduce_ ()
9767 {
9768 ffeexprExpr_ operand; /* This is B in -B or A+B. */
9769 ffeexprExpr_ left_operand; /* When operator is binary, this is A in A+B. */
9770 ffeexprExpr_ operator; /* This is + in A+B. */
9771 ffebld reduced; /* This is +(A,B) in A+B or u-(B) in -B. */
9772 ffebldConstant constnode; /* For checking magical numbers (where mag ==
9773 -mag). */
9774 ffebld expr;
9775 ffebld left_expr;
9776 bool submag = FALSE;
9777
9778 operand = ffeexpr_stack_->exprstack;
9779 assert (operand != NULL);
9780 assert (operand->type == FFEEXPR_exprtypeOPERAND_);
9781 operator = operand->previous;
9782 assert (operator != NULL);
9783 assert (operator->type != FFEEXPR_exprtypeOPERAND_);
9784 if (operator->type == FFEEXPR_exprtypeUNARY_)
9785 {
9786 expr = operand->u.operand;
9787 switch (operator->u.operator.op)
9788 {
9789 case FFEEXPR_operatorADD_:
9790 reduced = ffebld_new_uplus (expr);
9791 if (ffe_is_ugly_logint ())
9792 reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
9793 reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
9794 reduced = ffeexpr_collapse_uplus (reduced, operator->token);
9795 break;
9796
9797 case FFEEXPR_operatorSUBTRACT_:
9798 submag = TRUE; /* Ok to negate a magic number. */
9799 reduced = ffebld_new_uminus (expr);
9800 if (ffe_is_ugly_logint ())
9801 reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
9802 reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
9803 reduced = ffeexpr_collapse_uminus (reduced, operator->token);
9804 break;
9805
9806 case FFEEXPR_operatorNOT_:
9807 reduced = ffebld_new_not (expr);
9808 if (ffe_is_ugly_logint ())
9809 reduced = ffeexpr_reduced_ugly1log_ (reduced, operator, operand);
9810 reduced = ffeexpr_reduced_bool1_ (reduced, operator, operand);
9811 reduced = ffeexpr_collapse_not (reduced, operator->token);
9812 break;
9813
9814 default:
9815 assert ("unexpected unary op" != NULL);
9816 reduced = NULL;
9817 break;
9818 }
9819 if (!submag
9820 && (ffebld_op (expr) == FFEBLD_opCONTER)
9821 && (ffebld_conter_orig (expr) == NULL)
9822 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
9823 {
9824 ffetarget_integer_bad_magical (operand->token);
9825 }
9826 ffeexpr_stack_->exprstack = operator->previous; /* Pops unary-op operand
9827 off stack. */
9828 ffeexpr_expr_kill_ (operand);
9829 operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but
9830 save */
9831 operator->u.operand = reduced; /* the line/column ffewhere info. */
9832 ffeexpr_exprstack_push_operand_ (operator); /* Push it back on
9833 stack. */
9834 }
9835 else
9836 {
9837 assert (operator->type == FFEEXPR_exprtypeBINARY_);
9838 left_operand = operator->previous;
9839 assert (left_operand != NULL);
9840 assert (left_operand->type == FFEEXPR_exprtypeOPERAND_);
9841 expr = operand->u.operand;
9842 left_expr = left_operand->u.operand;
9843 switch (operator->u.operator.op)
9844 {
9845 case FFEEXPR_operatorADD_:
9846 reduced = ffebld_new_add (left_expr, expr);
9847 if (ffe_is_ugly_logint ())
9848 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9849 operand);
9850 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9851 operand);
9852 reduced = ffeexpr_collapse_add (reduced, operator->token);
9853 break;
9854
9855 case FFEEXPR_operatorSUBTRACT_:
9856 submag = TRUE; /* Just to pick the right error if magic
9857 number. */
9858 reduced = ffebld_new_subtract (left_expr, expr);
9859 if (ffe_is_ugly_logint ())
9860 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9861 operand);
9862 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9863 operand);
9864 reduced = ffeexpr_collapse_subtract (reduced, operator->token);
9865 break;
9866
9867 case FFEEXPR_operatorMULTIPLY_:
9868 reduced = ffebld_new_multiply (left_expr, expr);
9869 if (ffe_is_ugly_logint ())
9870 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9871 operand);
9872 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9873 operand);
9874 reduced = ffeexpr_collapse_multiply (reduced, operator->token);
9875 break;
9876
9877 case FFEEXPR_operatorDIVIDE_:
9878 reduced = ffebld_new_divide (left_expr, expr);
9879 if (ffe_is_ugly_logint ())
9880 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9881 operand);
9882 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9883 operand);
9884 reduced = ffeexpr_collapse_divide (reduced, operator->token);
9885 break;
9886
9887 case FFEEXPR_operatorPOWER_:
9888 reduced = ffebld_new_power (left_expr, expr);
9889 if (ffe_is_ugly_logint ())
9890 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9891 operand);
9892 reduced = ffeexpr_reduced_power_ (reduced, left_operand, operator,
9893 operand);
9894 reduced = ffeexpr_collapse_power (reduced, operator->token);
9895 break;
9896
9897 case FFEEXPR_operatorCONCATENATE_:
9898 reduced = ffebld_new_concatenate (left_expr, expr);
9899 reduced = ffeexpr_reduced_concatenate_ (reduced, left_operand, operator,
9900 operand);
9901 reduced = ffeexpr_collapse_concatenate (reduced, operator->token);
9902 break;
9903
9904 case FFEEXPR_operatorLT_:
9905 reduced = ffebld_new_lt (left_expr, expr);
9906 if (ffe_is_ugly_logint ())
9907 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9908 operand);
9909 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9910 operand);
9911 reduced = ffeexpr_collapse_lt (reduced, operator->token);
9912 break;
9913
9914 case FFEEXPR_operatorLE_:
9915 reduced = ffebld_new_le (left_expr, expr);
9916 if (ffe_is_ugly_logint ())
9917 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9918 operand);
9919 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9920 operand);
9921 reduced = ffeexpr_collapse_le (reduced, operator->token);
9922 break;
9923
9924 case FFEEXPR_operatorEQ_:
9925 reduced = ffebld_new_eq (left_expr, expr);
9926 if (ffe_is_ugly_logint ())
9927 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9928 operand);
9929 reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
9930 operand);
9931 reduced = ffeexpr_collapse_eq (reduced, operator->token);
9932 break;
9933
9934 case FFEEXPR_operatorNE_:
9935 reduced = ffebld_new_ne (left_expr, expr);
9936 if (ffe_is_ugly_logint ())
9937 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9938 operand);
9939 reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
9940 operand);
9941 reduced = ffeexpr_collapse_ne (reduced, operator->token);
9942 break;
9943
9944 case FFEEXPR_operatorGT_:
9945 reduced = ffebld_new_gt (left_expr, expr);
9946 if (ffe_is_ugly_logint ())
9947 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9948 operand);
9949 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9950 operand);
9951 reduced = ffeexpr_collapse_gt (reduced, operator->token);
9952 break;
9953
9954 case FFEEXPR_operatorGE_:
9955 reduced = ffebld_new_ge (left_expr, expr);
9956 if (ffe_is_ugly_logint ())
9957 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9958 operand);
9959 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9960 operand);
9961 reduced = ffeexpr_collapse_ge (reduced, operator->token);
9962 break;
9963
9964 case FFEEXPR_operatorAND_:
9965 reduced = ffebld_new_and (left_expr, expr);
9966 if (ffe_is_ugly_logint ())
9967 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9968 operand);
9969 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9970 operand);
9971 reduced = ffeexpr_collapse_and (reduced, operator->token);
9972 break;
9973
9974 case FFEEXPR_operatorOR_:
9975 reduced = ffebld_new_or (left_expr, expr);
9976 if (ffe_is_ugly_logint ())
9977 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9978 operand);
9979 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9980 operand);
9981 reduced = ffeexpr_collapse_or (reduced, operator->token);
9982 break;
9983
9984 case FFEEXPR_operatorXOR_:
9985 reduced = ffebld_new_xor (left_expr, expr);
9986 if (ffe_is_ugly_logint ())
9987 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9988 operand);
9989 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9990 operand);
9991 reduced = ffeexpr_collapse_xor (reduced, operator->token);
9992 break;
9993
9994 case FFEEXPR_operatorEQV_:
9995 reduced = ffebld_new_eqv (left_expr, expr);
9996 if (ffe_is_ugly_logint ())
9997 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9998 operand);
9999 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
10000 operand);
10001 reduced = ffeexpr_collapse_eqv (reduced, operator->token);
10002 break;
10003
10004 case FFEEXPR_operatorNEQV_:
10005 reduced = ffebld_new_neqv (left_expr, expr);
10006 if (ffe_is_ugly_logint ())
10007 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
10008 operand);
10009 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
10010 operand);
10011 reduced = ffeexpr_collapse_neqv (reduced, operator->token);
10012 break;
10013
10014 default:
10015 assert ("bad bin op" == NULL);
10016 reduced = expr;
10017 break;
10018 }
10019 if ((ffebld_op (left_expr) == FFEBLD_opCONTER)
10020 && (ffebld_conter_orig (expr) == NULL)
10021 && ffebld_constant_is_magical (constnode = ffebld_conter (left_expr)))
10022 {
10023 if ((left_operand->previous != NULL)
10024 && (left_operand->previous->type != FFEEXPR_exprtypeOPERAND_)
10025 && (left_operand->previous->u.operator.op
10026 == FFEEXPR_operatorSUBTRACT_))
10027 {
10028 if (left_operand->previous->type == FFEEXPR_exprtypeUNARY_)
10029 ffetarget_integer_bad_magical_precedence (left_operand->token,
10030 left_operand->previous->token,
10031 operator->token);
10032 else
10033 ffetarget_integer_bad_magical_precedence_binary
10034 (left_operand->token,
10035 left_operand->previous->token,
10036 operator->token);
10037 }
10038 else
10039 ffetarget_integer_bad_magical (left_operand->token);
10040 }
10041 if ((ffebld_op (expr) == FFEBLD_opCONTER)
10042 && (ffebld_conter_orig (expr) == NULL)
10043 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
10044 {
10045 if (submag)
10046 ffetarget_integer_bad_magical_binary (operand->token,
10047 operator->token);
10048 else
10049 ffetarget_integer_bad_magical (operand->token);
10050 }
10051 ffeexpr_stack_->exprstack = left_operand->previous; /* Pops binary-op
10052 operands off stack. */
10053 ffeexpr_expr_kill_ (left_operand);
10054 ffeexpr_expr_kill_ (operand);
10055 operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but
10056 save */
10057 operator->u.operand = reduced; /* the line/column ffewhere info. */
10058 ffeexpr_exprstack_push_operand_ (operator); /* Push it back on
10059 stack. */
10060 }
10061 }
10062
10063 /* ffeexpr_reduced_bool1_ -- Wrap up reduction of NOT operator
10064
10065 reduced = ffeexpr_reduced_bool1_(reduced,op,r);
10066
10067 Makes sure the argument for reduced has basictype of
10068 LOGICAL or (ugly) INTEGER. If
10069 argument has where of CONSTANT, assign where CONSTANT to
10070 reduced, else assign where FLEETING.
10071
10072 If these requirements cannot be met, generate error message. */
10073
10074 static ffebld
10075 ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10076 {
10077 ffeinfo rinfo, ninfo;
10078 ffeinfoBasictype rbt;
10079 ffeinfoKindtype rkt;
10080 ffeinfoRank rrk;
10081 ffeinfoKind rkd;
10082 ffeinfoWhere rwh, nwh;
10083
10084 rinfo = ffebld_info (ffebld_left (reduced));
10085 rbt = ffeinfo_basictype (rinfo);
10086 rkt = ffeinfo_kindtype (rinfo);
10087 rrk = ffeinfo_rank (rinfo);
10088 rkd = ffeinfo_kind (rinfo);
10089 rwh = ffeinfo_where (rinfo);
10090
10091 if (((rbt == FFEINFO_basictypeLOGICAL)
10092 || (ffe_is_ugly_logint () && (rbt == FFEINFO_basictypeINTEGER)))
10093 && (rrk == 0))
10094 {
10095 switch (rwh)
10096 {
10097 case FFEINFO_whereCONSTANT:
10098 nwh = FFEINFO_whereCONSTANT;
10099 break;
10100
10101 case FFEINFO_whereIMMEDIATE:
10102 nwh = FFEINFO_whereIMMEDIATE;
10103 break;
10104
10105 default:
10106 nwh = FFEINFO_whereFLEETING;
10107 break;
10108 }
10109
10110 ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
10111 FFETARGET_charactersizeNONE);
10112 ffebld_set_info (reduced, ninfo);
10113 return reduced;
10114 }
10115
10116 if ((rbt != FFEINFO_basictypeLOGICAL)
10117 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
10118 {
10119 if ((rbt != FFEINFO_basictypeANY)
10120 && ffebad_start (FFEBAD_NOT_ARG_TYPE))
10121 {
10122 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10123 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10124 ffebad_finish ();
10125 }
10126 }
10127 else
10128 {
10129 if ((rkd != FFEINFO_kindANY)
10130 && ffebad_start (FFEBAD_NOT_ARG_KIND))
10131 {
10132 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10133 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10134 ffebad_string ("an array");
10135 ffebad_finish ();
10136 }
10137 }
10138
10139 reduced = ffebld_new_any ();
10140 ffebld_set_info (reduced, ffeinfo_new_any ());
10141 return reduced;
10142 }
10143
10144 /* ffeexpr_reduced_bool2_ -- Wrap up reduction of boolean operators
10145
10146 reduced = ffeexpr_reduced_bool2_(reduced,l,op,r);
10147
10148 Makes sure the left and right arguments for reduced have basictype of
10149 LOGICAL or (ugly) INTEGER. Determine common basictype and
10150 size for reduction (flag expression for combined hollerith/typeless
10151 situations for later determination of effective basictype). If both left
10152 and right arguments have where of CONSTANT, assign where CONSTANT to
10153 reduced, else assign where FLEETING. Create CONVERT ops for args where
10154 needed. Convert typeless
10155 constants to the desired type/size explicitly.
10156
10157 If these requirements cannot be met, generate error message. */
10158
10159 static ffebld
10160 ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10161 ffeexprExpr_ r)
10162 {
10163 ffeinfo linfo, rinfo, ninfo;
10164 ffeinfoBasictype lbt, rbt, nbt;
10165 ffeinfoKindtype lkt, rkt, nkt;
10166 ffeinfoRank lrk, rrk;
10167 ffeinfoKind lkd, rkd;
10168 ffeinfoWhere lwh, rwh, nwh;
10169
10170 linfo = ffebld_info (ffebld_left (reduced));
10171 lbt = ffeinfo_basictype (linfo);
10172 lkt = ffeinfo_kindtype (linfo);
10173 lrk = ffeinfo_rank (linfo);
10174 lkd = ffeinfo_kind (linfo);
10175 lwh = ffeinfo_where (linfo);
10176
10177 rinfo = ffebld_info (ffebld_right (reduced));
10178 rbt = ffeinfo_basictype (rinfo);
10179 rkt = ffeinfo_kindtype (rinfo);
10180 rrk = ffeinfo_rank (rinfo);
10181 rkd = ffeinfo_kind (rinfo);
10182 rwh = ffeinfo_where (rinfo);
10183
10184 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10185
10186 if (((nbt == FFEINFO_basictypeLOGICAL)
10187 || (ffe_is_ugly_logint () && (nbt == FFEINFO_basictypeINTEGER)))
10188 && (lrk == 0) && (rrk == 0))
10189 {
10190 switch (lwh)
10191 {
10192 case FFEINFO_whereCONSTANT:
10193 switch (rwh)
10194 {
10195 case FFEINFO_whereCONSTANT:
10196 nwh = FFEINFO_whereCONSTANT;
10197 break;
10198
10199 case FFEINFO_whereIMMEDIATE:
10200 nwh = FFEINFO_whereIMMEDIATE;
10201 break;
10202
10203 default:
10204 nwh = FFEINFO_whereFLEETING;
10205 break;
10206 }
10207 break;
10208
10209 case FFEINFO_whereIMMEDIATE:
10210 switch (rwh)
10211 {
10212 case FFEINFO_whereCONSTANT:
10213 case FFEINFO_whereIMMEDIATE:
10214 nwh = FFEINFO_whereIMMEDIATE;
10215 break;
10216
10217 default:
10218 nwh = FFEINFO_whereFLEETING;
10219 break;
10220 }
10221 break;
10222
10223 default:
10224 nwh = FFEINFO_whereFLEETING;
10225 break;
10226 }
10227
10228 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10229 FFETARGET_charactersizeNONE);
10230 ffebld_set_info (reduced, ninfo);
10231 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10232 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10233 FFEEXPR_contextLET));
10234 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10235 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10236 FFEEXPR_contextLET));
10237 return reduced;
10238 }
10239
10240 if ((lbt != FFEINFO_basictypeLOGICAL)
10241 && (!ffe_is_ugly_logint () || (lbt != FFEINFO_basictypeINTEGER)))
10242 {
10243 if ((rbt != FFEINFO_basictypeLOGICAL)
10244 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
10245 {
10246 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10247 && ffebad_start (FFEBAD_BOOL_ARGS_TYPE))
10248 {
10249 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10250 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10251 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10252 ffebad_finish ();
10253 }
10254 }
10255 else
10256 {
10257 if ((lbt != FFEINFO_basictypeANY)
10258 && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
10259 {
10260 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10261 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10262 ffebad_finish ();
10263 }
10264 }
10265 }
10266 else if ((rbt != FFEINFO_basictypeLOGICAL)
10267 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
10268 {
10269 if ((rbt != FFEINFO_basictypeANY)
10270 && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
10271 {
10272 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10273 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10274 ffebad_finish ();
10275 }
10276 }
10277 else if (lrk != 0)
10278 {
10279 if ((lkd != FFEINFO_kindANY)
10280 && ffebad_start (FFEBAD_BOOL_ARG_KIND))
10281 {
10282 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10283 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10284 ffebad_string ("an array");
10285 ffebad_finish ();
10286 }
10287 }
10288 else
10289 {
10290 if ((rkd != FFEINFO_kindANY)
10291 && ffebad_start (FFEBAD_BOOL_ARG_KIND))
10292 {
10293 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10294 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10295 ffebad_string ("an array");
10296 ffebad_finish ();
10297 }
10298 }
10299
10300 reduced = ffebld_new_any ();
10301 ffebld_set_info (reduced, ffeinfo_new_any ());
10302 return reduced;
10303 }
10304
10305 /* ffeexpr_reduced_concatenate_ -- Wrap up reduction of concatenate operator
10306
10307 reduced = ffeexpr_reduced_concatenate_(reduced,l,op,r);
10308
10309 Makes sure the left and right arguments for reduced have basictype of
10310 CHARACTER and kind of SCALAR, FUNCTION, or STATEMENT FUNCTION. Assign
10311 basictype of CHARACTER and kind of SCALAR to reduced. Calculate effective
10312 size of concatenation and assign that size to reduced. If both left and
10313 right arguments have where of CONSTANT, assign where CONSTANT to reduced,
10314 else assign where FLEETING.
10315
10316 If these requirements cannot be met, generate error message using the
10317 info in l, op, and r arguments and assign basictype, size, kind, and where
10318 of ANY. */
10319
10320 static ffebld
10321 ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10322 ffeexprExpr_ r)
10323 {
10324 ffeinfo linfo, rinfo, ninfo;
10325 ffeinfoBasictype lbt, rbt, nbt;
10326 ffeinfoKindtype lkt, rkt, nkt;
10327 ffeinfoRank lrk, rrk;
10328 ffeinfoKind lkd, rkd, nkd;
10329 ffeinfoWhere lwh, rwh, nwh;
10330 ffetargetCharacterSize lszm, lszk, rszm, rszk, nszk;
10331
10332 linfo = ffebld_info (ffebld_left (reduced));
10333 lbt = ffeinfo_basictype (linfo);
10334 lkt = ffeinfo_kindtype (linfo);
10335 lrk = ffeinfo_rank (linfo);
10336 lkd = ffeinfo_kind (linfo);
10337 lwh = ffeinfo_where (linfo);
10338 lszk = ffeinfo_size (linfo); /* Known size. */
10339 lszm = ffebld_size_max (ffebld_left (reduced));
10340
10341 rinfo = ffebld_info (ffebld_right (reduced));
10342 rbt = ffeinfo_basictype (rinfo);
10343 rkt = ffeinfo_kindtype (rinfo);
10344 rrk = ffeinfo_rank (rinfo);
10345 rkd = ffeinfo_kind (rinfo);
10346 rwh = ffeinfo_where (rinfo);
10347 rszk = ffeinfo_size (rinfo); /* Known size. */
10348 rszm = ffebld_size_max (ffebld_right (reduced));
10349
10350 if ((lbt == FFEINFO_basictypeCHARACTER) && (rbt == FFEINFO_basictypeCHARACTER)
10351 && (lkt == rkt) && (lrk == 0) && (rrk == 0)
10352 && (((lszm != FFETARGET_charactersizeNONE)
10353 && (rszm != FFETARGET_charactersizeNONE))
10354 || (ffeexpr_context_outer_ (ffeexpr_stack_)
10355 == FFEEXPR_contextLET)
10356 || (ffeexpr_context_outer_ (ffeexpr_stack_)
10357 == FFEEXPR_contextSFUNCDEF)))
10358 {
10359 nbt = FFEINFO_basictypeCHARACTER;
10360 nkd = FFEINFO_kindENTITY;
10361 if ((lszk == FFETARGET_charactersizeNONE)
10362 || (rszk == FFETARGET_charactersizeNONE))
10363 nszk = FFETARGET_charactersizeNONE; /* Ok only in rhs of LET
10364 stmt. */
10365 else
10366 nszk = lszk + rszk;
10367
10368 switch (lwh)
10369 {
10370 case FFEINFO_whereCONSTANT:
10371 switch (rwh)
10372 {
10373 case FFEINFO_whereCONSTANT:
10374 nwh = FFEINFO_whereCONSTANT;
10375 break;
10376
10377 case FFEINFO_whereIMMEDIATE:
10378 nwh = FFEINFO_whereIMMEDIATE;
10379 break;
10380
10381 default:
10382 nwh = FFEINFO_whereFLEETING;
10383 break;
10384 }
10385 break;
10386
10387 case FFEINFO_whereIMMEDIATE:
10388 switch (rwh)
10389 {
10390 case FFEINFO_whereCONSTANT:
10391 case FFEINFO_whereIMMEDIATE:
10392 nwh = FFEINFO_whereIMMEDIATE;
10393 break;
10394
10395 default:
10396 nwh = FFEINFO_whereFLEETING;
10397 break;
10398 }
10399 break;
10400
10401 default:
10402 nwh = FFEINFO_whereFLEETING;
10403 break;
10404 }
10405
10406 nkt = lkt;
10407 ninfo = ffeinfo_new (nbt, nkt, 0, nkd, nwh, nszk);
10408 ffebld_set_info (reduced, ninfo);
10409 return reduced;
10410 }
10411
10412 if ((lbt != FFEINFO_basictypeCHARACTER) && (rbt != FFEINFO_basictypeCHARACTER))
10413 {
10414 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10415 && ffebad_start (FFEBAD_CONCAT_ARGS_TYPE))
10416 {
10417 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10418 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10419 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10420 ffebad_finish ();
10421 }
10422 }
10423 else if (lbt != FFEINFO_basictypeCHARACTER)
10424 {
10425 if ((lbt != FFEINFO_basictypeANY)
10426 && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
10427 {
10428 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10429 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10430 ffebad_finish ();
10431 }
10432 }
10433 else if (rbt != FFEINFO_basictypeCHARACTER)
10434 {
10435 if ((rbt != FFEINFO_basictypeANY)
10436 && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
10437 {
10438 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10439 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10440 ffebad_finish ();
10441 }
10442 }
10443 else if ((lrk != 0) || (lszm == FFETARGET_charactersizeNONE))
10444 {
10445 if ((lkd != FFEINFO_kindANY)
10446 && ffebad_start (FFEBAD_CONCAT_ARG_KIND))
10447 {
10448 char *what;
10449
10450 if (lrk != 0)
10451 what = "an array";
10452 else
10453 what = "of indeterminate length";
10454 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10455 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10456 ffebad_string (what);
10457 ffebad_finish ();
10458 }
10459 }
10460 else
10461 {
10462 if (ffebad_start (FFEBAD_CONCAT_ARG_KIND))
10463 {
10464 char *what;
10465
10466 if (rrk != 0)
10467 what = "an array";
10468 else
10469 what = "of indeterminate length";
10470 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10471 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10472 ffebad_string (what);
10473 ffebad_finish ();
10474 }
10475 }
10476
10477 reduced = ffebld_new_any ();
10478 ffebld_set_info (reduced, ffeinfo_new_any ());
10479 return reduced;
10480 }
10481
10482 /* ffeexpr_reduced_eqop2_ -- Wrap up reduction of EQ and NE operators
10483
10484 reduced = ffeexpr_reduced_eqop2_(reduced,l,op,r);
10485
10486 Makes sure the left and right arguments for reduced have basictype of
10487 INTEGER, REAL, COMPLEX, or CHARACTER. Determine common basictype and
10488 size for reduction. If both left
10489 and right arguments have where of CONSTANT, assign where CONSTANT to
10490 reduced, else assign where FLEETING. Create CONVERT ops for args where
10491 needed. Convert typeless
10492 constants to the desired type/size explicitly.
10493
10494 If these requirements cannot be met, generate error message. */
10495
10496 static ffebld
10497 ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10498 ffeexprExpr_ r)
10499 {
10500 ffeinfo linfo, rinfo, ninfo;
10501 ffeinfoBasictype lbt, rbt, nbt;
10502 ffeinfoKindtype lkt, rkt, nkt;
10503 ffeinfoRank lrk, rrk;
10504 ffeinfoKind lkd, rkd;
10505 ffeinfoWhere lwh, rwh, nwh;
10506 ffetargetCharacterSize lsz, rsz;
10507
10508 linfo = ffebld_info (ffebld_left (reduced));
10509 lbt = ffeinfo_basictype (linfo);
10510 lkt = ffeinfo_kindtype (linfo);
10511 lrk = ffeinfo_rank (linfo);
10512 lkd = ffeinfo_kind (linfo);
10513 lwh = ffeinfo_where (linfo);
10514 lsz = ffebld_size_known (ffebld_left (reduced));
10515
10516 rinfo = ffebld_info (ffebld_right (reduced));
10517 rbt = ffeinfo_basictype (rinfo);
10518 rkt = ffeinfo_kindtype (rinfo);
10519 rrk = ffeinfo_rank (rinfo);
10520 rkd = ffeinfo_kind (rinfo);
10521 rwh = ffeinfo_where (rinfo);
10522 rsz = ffebld_size_known (ffebld_right (reduced));
10523
10524 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10525
10526 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10527 || (nbt == FFEINFO_basictypeCOMPLEX) || (nbt == FFEINFO_basictypeCHARACTER))
10528 && (lrk == 0) && (rrk == 0))
10529 {
10530 switch (lwh)
10531 {
10532 case FFEINFO_whereCONSTANT:
10533 switch (rwh)
10534 {
10535 case FFEINFO_whereCONSTANT:
10536 nwh = FFEINFO_whereCONSTANT;
10537 break;
10538
10539 case FFEINFO_whereIMMEDIATE:
10540 nwh = FFEINFO_whereIMMEDIATE;
10541 break;
10542
10543 default:
10544 nwh = FFEINFO_whereFLEETING;
10545 break;
10546 }
10547 break;
10548
10549 case FFEINFO_whereIMMEDIATE:
10550 switch (rwh)
10551 {
10552 case FFEINFO_whereCONSTANT:
10553 case FFEINFO_whereIMMEDIATE:
10554 nwh = FFEINFO_whereIMMEDIATE;
10555 break;
10556
10557 default:
10558 nwh = FFEINFO_whereFLEETING;
10559 break;
10560 }
10561 break;
10562
10563 default:
10564 nwh = FFEINFO_whereFLEETING;
10565 break;
10566 }
10567
10568 if ((lsz != FFETARGET_charactersizeNONE)
10569 && (rsz != FFETARGET_charactersizeNONE))
10570 lsz = rsz = (lsz > rsz) ? lsz : rsz;
10571
10572 ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
10573 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
10574 ffebld_set_info (reduced, ninfo);
10575 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10576 l->token, op->token, nbt, nkt, 0, lsz,
10577 FFEEXPR_contextLET));
10578 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10579 r->token, op->token, nbt, nkt, 0, rsz,
10580 FFEEXPR_contextLET));
10581 return reduced;
10582 }
10583
10584 if ((lbt == FFEINFO_basictypeLOGICAL)
10585 && (rbt == FFEINFO_basictypeLOGICAL))
10586 {
10587 if (ffebad_start_msg ("Use .EQV./.NEQV. instead of .EQ./.NE. at %0 for LOGICAL operands at %1 and %2",
10588 FFEBAD_severityFATAL))
10589 {
10590 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10591 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10592 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10593 ffebad_finish ();
10594 }
10595 }
10596 else if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10597 && (lbt != FFEINFO_basictypeCOMPLEX) && (lbt != FFEINFO_basictypeCHARACTER))
10598 {
10599 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10600 && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
10601 {
10602 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10603 && ffebad_start (FFEBAD_EQOP_ARGS_TYPE))
10604 {
10605 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10606 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10607 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10608 ffebad_finish ();
10609 }
10610 }
10611 else
10612 {
10613 if ((lbt != FFEINFO_basictypeANY)
10614 && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
10615 {
10616 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10617 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10618 ffebad_finish ();
10619 }
10620 }
10621 }
10622 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10623 && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
10624 {
10625 if ((rbt != FFEINFO_basictypeANY)
10626 && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
10627 {
10628 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10629 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10630 ffebad_finish ();
10631 }
10632 }
10633 else if (lrk != 0)
10634 {
10635 if ((lkd != FFEINFO_kindANY)
10636 && ffebad_start (FFEBAD_EQOP_ARG_KIND))
10637 {
10638 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10639 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10640 ffebad_string ("an array");
10641 ffebad_finish ();
10642 }
10643 }
10644 else
10645 {
10646 if ((rkd != FFEINFO_kindANY)
10647 && ffebad_start (FFEBAD_EQOP_ARG_KIND))
10648 {
10649 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10650 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10651 ffebad_string ("an array");
10652 ffebad_finish ();
10653 }
10654 }
10655
10656 reduced = ffebld_new_any ();
10657 ffebld_set_info (reduced, ffeinfo_new_any ());
10658 return reduced;
10659 }
10660
10661 /* ffeexpr_reduced_math1_ -- Wrap up reduction of + - unary operators
10662
10663 reduced = ffeexpr_reduced_math1_(reduced,op,r);
10664
10665 Makes sure the argument for reduced has basictype of
10666 INTEGER, REAL, or COMPLEX. If the argument has where of CONSTANT,
10667 assign where CONSTANT to
10668 reduced, else assign where FLEETING.
10669
10670 If these requirements cannot be met, generate error message. */
10671
10672 static ffebld
10673 ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10674 {
10675 ffeinfo rinfo, ninfo;
10676 ffeinfoBasictype rbt;
10677 ffeinfoKindtype rkt;
10678 ffeinfoRank rrk;
10679 ffeinfoKind rkd;
10680 ffeinfoWhere rwh, nwh;
10681
10682 rinfo = ffebld_info (ffebld_left (reduced));
10683 rbt = ffeinfo_basictype (rinfo);
10684 rkt = ffeinfo_kindtype (rinfo);
10685 rrk = ffeinfo_rank (rinfo);
10686 rkd = ffeinfo_kind (rinfo);
10687 rwh = ffeinfo_where (rinfo);
10688
10689 if (((rbt == FFEINFO_basictypeINTEGER) || (rbt == FFEINFO_basictypeREAL)
10690 || (rbt == FFEINFO_basictypeCOMPLEX)) && (rrk == 0))
10691 {
10692 switch (rwh)
10693 {
10694 case FFEINFO_whereCONSTANT:
10695 nwh = FFEINFO_whereCONSTANT;
10696 break;
10697
10698 case FFEINFO_whereIMMEDIATE:
10699 nwh = FFEINFO_whereIMMEDIATE;
10700 break;
10701
10702 default:
10703 nwh = FFEINFO_whereFLEETING;
10704 break;
10705 }
10706
10707 ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
10708 FFETARGET_charactersizeNONE);
10709 ffebld_set_info (reduced, ninfo);
10710 return reduced;
10711 }
10712
10713 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10714 && (rbt != FFEINFO_basictypeCOMPLEX))
10715 {
10716 if ((rbt != FFEINFO_basictypeANY)
10717 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10718 {
10719 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10720 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10721 ffebad_finish ();
10722 }
10723 }
10724 else
10725 {
10726 if ((rkd != FFEINFO_kindANY)
10727 && ffebad_start (FFEBAD_MATH_ARG_KIND))
10728 {
10729 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10730 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10731 ffebad_string ("an array");
10732 ffebad_finish ();
10733 }
10734 }
10735
10736 reduced = ffebld_new_any ();
10737 ffebld_set_info (reduced, ffeinfo_new_any ());
10738 return reduced;
10739 }
10740
10741 /* ffeexpr_reduced_math2_ -- Wrap up reduction of + - * / operators
10742
10743 reduced = ffeexpr_reduced_math2_(reduced,l,op,r);
10744
10745 Makes sure the left and right arguments for reduced have basictype of
10746 INTEGER, REAL, or COMPLEX. Determine common basictype and
10747 size for reduction (flag expression for combined hollerith/typeless
10748 situations for later determination of effective basictype). If both left
10749 and right arguments have where of CONSTANT, assign where CONSTANT to
10750 reduced, else assign where FLEETING. Create CONVERT ops for args where
10751 needed. Convert typeless
10752 constants to the desired type/size explicitly.
10753
10754 If these requirements cannot be met, generate error message. */
10755
10756 static ffebld
10757 ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10758 ffeexprExpr_ r)
10759 {
10760 ffeinfo linfo, rinfo, ninfo;
10761 ffeinfoBasictype lbt, rbt, nbt;
10762 ffeinfoKindtype lkt, rkt, nkt;
10763 ffeinfoRank lrk, rrk;
10764 ffeinfoKind lkd, rkd;
10765 ffeinfoWhere lwh, rwh, nwh;
10766
10767 linfo = ffebld_info (ffebld_left (reduced));
10768 lbt = ffeinfo_basictype (linfo);
10769 lkt = ffeinfo_kindtype (linfo);
10770 lrk = ffeinfo_rank (linfo);
10771 lkd = ffeinfo_kind (linfo);
10772 lwh = ffeinfo_where (linfo);
10773
10774 rinfo = ffebld_info (ffebld_right (reduced));
10775 rbt = ffeinfo_basictype (rinfo);
10776 rkt = ffeinfo_kindtype (rinfo);
10777 rrk = ffeinfo_rank (rinfo);
10778 rkd = ffeinfo_kind (rinfo);
10779 rwh = ffeinfo_where (rinfo);
10780
10781 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10782
10783 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10784 || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
10785 {
10786 switch (lwh)
10787 {
10788 case FFEINFO_whereCONSTANT:
10789 switch (rwh)
10790 {
10791 case FFEINFO_whereCONSTANT:
10792 nwh = FFEINFO_whereCONSTANT;
10793 break;
10794
10795 case FFEINFO_whereIMMEDIATE:
10796 nwh = FFEINFO_whereIMMEDIATE;
10797 break;
10798
10799 default:
10800 nwh = FFEINFO_whereFLEETING;
10801 break;
10802 }
10803 break;
10804
10805 case FFEINFO_whereIMMEDIATE:
10806 switch (rwh)
10807 {
10808 case FFEINFO_whereCONSTANT:
10809 case FFEINFO_whereIMMEDIATE:
10810 nwh = FFEINFO_whereIMMEDIATE;
10811 break;
10812
10813 default:
10814 nwh = FFEINFO_whereFLEETING;
10815 break;
10816 }
10817 break;
10818
10819 default:
10820 nwh = FFEINFO_whereFLEETING;
10821 break;
10822 }
10823
10824 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10825 FFETARGET_charactersizeNONE);
10826 ffebld_set_info (reduced, ninfo);
10827 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10828 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10829 FFEEXPR_contextLET));
10830 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10831 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10832 FFEEXPR_contextLET));
10833 return reduced;
10834 }
10835
10836 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10837 && (lbt != FFEINFO_basictypeCOMPLEX))
10838 {
10839 if ((rbt != FFEINFO_basictypeINTEGER)
10840 && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
10841 {
10842 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10843 && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
10844 {
10845 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10846 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10847 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10848 ffebad_finish ();
10849 }
10850 }
10851 else
10852 {
10853 if ((lbt != FFEINFO_basictypeANY)
10854 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10855 {
10856 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10857 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10858 ffebad_finish ();
10859 }
10860 }
10861 }
10862 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10863 && (rbt != FFEINFO_basictypeCOMPLEX))
10864 {
10865 if ((rbt != FFEINFO_basictypeANY)
10866 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10867 {
10868 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10869 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10870 ffebad_finish ();
10871 }
10872 }
10873 else if (lrk != 0)
10874 {
10875 if ((lkd != FFEINFO_kindANY)
10876 && ffebad_start (FFEBAD_MATH_ARG_KIND))
10877 {
10878 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10879 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10880 ffebad_string ("an array");
10881 ffebad_finish ();
10882 }
10883 }
10884 else
10885 {
10886 if ((rkd != FFEINFO_kindANY)
10887 && ffebad_start (FFEBAD_MATH_ARG_KIND))
10888 {
10889 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10890 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10891 ffebad_string ("an array");
10892 ffebad_finish ();
10893 }
10894 }
10895
10896 reduced = ffebld_new_any ();
10897 ffebld_set_info (reduced, ffeinfo_new_any ());
10898 return reduced;
10899 }
10900
10901 /* ffeexpr_reduced_power_ -- Wrap up reduction of ** operator
10902
10903 reduced = ffeexpr_reduced_power_(reduced,l,op,r);
10904
10905 Makes sure the left and right arguments for reduced have basictype of
10906 INTEGER, REAL, or COMPLEX. Determine common basictype and
10907 size for reduction (flag expression for combined hollerith/typeless
10908 situations for later determination of effective basictype). If both left
10909 and right arguments have where of CONSTANT, assign where CONSTANT to
10910 reduced, else assign where FLEETING. Create CONVERT ops for args where
10911 needed. Note that real**int or complex**int
10912 comes out as int = real**int etc with no conversions.
10913
10914 If these requirements cannot be met, generate error message using the
10915 info in l, op, and r arguments and assign basictype, size, kind, and where
10916 of ANY. */
10917
10918 static ffebld
10919 ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10920 ffeexprExpr_ r)
10921 {
10922 ffeinfo linfo, rinfo, ninfo;
10923 ffeinfoBasictype lbt, rbt, nbt;
10924 ffeinfoKindtype lkt, rkt, nkt;
10925 ffeinfoRank lrk, rrk;
10926 ffeinfoKind lkd, rkd;
10927 ffeinfoWhere lwh, rwh, nwh;
10928
10929 linfo = ffebld_info (ffebld_left (reduced));
10930 lbt = ffeinfo_basictype (linfo);
10931 lkt = ffeinfo_kindtype (linfo);
10932 lrk = ffeinfo_rank (linfo);
10933 lkd = ffeinfo_kind (linfo);
10934 lwh = ffeinfo_where (linfo);
10935
10936 rinfo = ffebld_info (ffebld_right (reduced));
10937 rbt = ffeinfo_basictype (rinfo);
10938 rkt = ffeinfo_kindtype (rinfo);
10939 rrk = ffeinfo_rank (rinfo);
10940 rkd = ffeinfo_kind (rinfo);
10941 rwh = ffeinfo_where (rinfo);
10942
10943 if ((rbt == FFEINFO_basictypeINTEGER)
10944 && ((lbt == FFEINFO_basictypeREAL)
10945 || (lbt == FFEINFO_basictypeCOMPLEX)))
10946 {
10947 nbt = lbt;
10948 nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDEFAULT);
10949 if (nkt != FFEINFO_kindtypeREALDEFAULT)
10950 {
10951 nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDOUBLE);
10952 if (nkt != FFEINFO_kindtypeREALDOUBLE)
10953 nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */
10954 }
10955 if (rkt == FFEINFO_kindtypeINTEGER4)
10956 {
10957 ffebad_start_msg ("Unsupported operand for ** at %1 -- converting to default INTEGER",
10958 FFEBAD_severityWARNING);
10959 ffebad_here (0, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10960 ffebad_finish ();
10961 }
10962 if (rkt != FFEINFO_kindtypeINTEGERDEFAULT)
10963 {
10964 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10965 r->token, op->token,
10966 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0,
10967 FFETARGET_charactersizeNONE,
10968 FFEEXPR_contextLET));
10969 rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10970 }
10971 }
10972 else
10973 {
10974 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10975
10976 #if 0 /* INTEGER4**INTEGER4 works now. */
10977 if ((nbt == FFEINFO_basictypeINTEGER)
10978 && (nkt != FFEINFO_kindtypeINTEGERDEFAULT))
10979 nkt = FFEINFO_kindtypeINTEGERDEFAULT; /* Highest kt we can power! */
10980 #endif
10981 if (((nbt == FFEINFO_basictypeREAL)
10982 || (nbt == FFEINFO_basictypeCOMPLEX))
10983 && (nkt != FFEINFO_kindtypeREALDEFAULT))
10984 {
10985 nkt = ffeinfo_kindtype_max (nbt, nkt, FFEINFO_kindtypeREALDOUBLE);
10986 if (nkt != FFEINFO_kindtypeREALDOUBLE)
10987 nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */
10988 }
10989 /* else Gonna turn into an error below. */
10990 }
10991
10992 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10993 || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
10994 {
10995 switch (lwh)
10996 {
10997 case FFEINFO_whereCONSTANT:
10998 switch (rwh)
10999 {
11000 case FFEINFO_whereCONSTANT:
11001 nwh = FFEINFO_whereCONSTANT;
11002 break;
11003
11004 case FFEINFO_whereIMMEDIATE:
11005 nwh = FFEINFO_whereIMMEDIATE;
11006 break;
11007
11008 default:
11009 nwh = FFEINFO_whereFLEETING;
11010 break;
11011 }
11012 break;
11013
11014 case FFEINFO_whereIMMEDIATE:
11015 switch (rwh)
11016 {
11017 case FFEINFO_whereCONSTANT:
11018 case FFEINFO_whereIMMEDIATE:
11019 nwh = FFEINFO_whereIMMEDIATE;
11020 break;
11021
11022 default:
11023 nwh = FFEINFO_whereFLEETING;
11024 break;
11025 }
11026 break;
11027
11028 default:
11029 nwh = FFEINFO_whereFLEETING;
11030 break;
11031 }
11032
11033 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
11034 FFETARGET_charactersizeNONE);
11035 ffebld_set_info (reduced, ninfo);
11036 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11037 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
11038 FFEEXPR_contextLET));
11039 if (rbt != FFEINFO_basictypeINTEGER)
11040 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11041 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
11042 FFEEXPR_contextLET));
11043 return reduced;
11044 }
11045
11046 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
11047 && (lbt != FFEINFO_basictypeCOMPLEX))
11048 {
11049 if ((rbt != FFEINFO_basictypeINTEGER)
11050 && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
11051 {
11052 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
11053 && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
11054 {
11055 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11056 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11057 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11058 ffebad_finish ();
11059 }
11060 }
11061 else
11062 {
11063 if ((lbt != FFEINFO_basictypeANY)
11064 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
11065 {
11066 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11067 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11068 ffebad_finish ();
11069 }
11070 }
11071 }
11072 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
11073 && (rbt != FFEINFO_basictypeCOMPLEX))
11074 {
11075 if ((rbt != FFEINFO_basictypeANY)
11076 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
11077 {
11078 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11079 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11080 ffebad_finish ();
11081 }
11082 }
11083 else if (lrk != 0)
11084 {
11085 if ((lkd != FFEINFO_kindANY)
11086 && ffebad_start (FFEBAD_MATH_ARG_KIND))
11087 {
11088 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11089 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11090 ffebad_string ("an array");
11091 ffebad_finish ();
11092 }
11093 }
11094 else
11095 {
11096 if ((rkd != FFEINFO_kindANY)
11097 && ffebad_start (FFEBAD_MATH_ARG_KIND))
11098 {
11099 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11100 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11101 ffebad_string ("an array");
11102 ffebad_finish ();
11103 }
11104 }
11105
11106 reduced = ffebld_new_any ();
11107 ffebld_set_info (reduced, ffeinfo_new_any ());
11108 return reduced;
11109 }
11110
11111 /* ffeexpr_reduced_relop2_ -- Wrap up reduction of LT, LE, GE, and GT operators
11112
11113 reduced = ffeexpr_reduced_relop2_(reduced,l,op,r);
11114
11115 Makes sure the left and right arguments for reduced have basictype of
11116 INTEGER, REAL, or CHARACTER. Determine common basictype and
11117 size for reduction. If both left
11118 and right arguments have where of CONSTANT, assign where CONSTANT to
11119 reduced, else assign where FLEETING. Create CONVERT ops for args where
11120 needed. Convert typeless
11121 constants to the desired type/size explicitly.
11122
11123 If these requirements cannot be met, generate error message. */
11124
11125 static ffebld
11126 ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
11127 ffeexprExpr_ r)
11128 {
11129 ffeinfo linfo, rinfo, ninfo;
11130 ffeinfoBasictype lbt, rbt, nbt;
11131 ffeinfoKindtype lkt, rkt, nkt;
11132 ffeinfoRank lrk, rrk;
11133 ffeinfoKind lkd, rkd;
11134 ffeinfoWhere lwh, rwh, nwh;
11135 ffetargetCharacterSize lsz, rsz;
11136
11137 linfo = ffebld_info (ffebld_left (reduced));
11138 lbt = ffeinfo_basictype (linfo);
11139 lkt = ffeinfo_kindtype (linfo);
11140 lrk = ffeinfo_rank (linfo);
11141 lkd = ffeinfo_kind (linfo);
11142 lwh = ffeinfo_where (linfo);
11143 lsz = ffebld_size_known (ffebld_left (reduced));
11144
11145 rinfo = ffebld_info (ffebld_right (reduced));
11146 rbt = ffeinfo_basictype (rinfo);
11147 rkt = ffeinfo_kindtype (rinfo);
11148 rrk = ffeinfo_rank (rinfo);
11149 rkd = ffeinfo_kind (rinfo);
11150 rwh = ffeinfo_where (rinfo);
11151 rsz = ffebld_size_known (ffebld_right (reduced));
11152
11153 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
11154
11155 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
11156 || (nbt == FFEINFO_basictypeCHARACTER))
11157 && (lrk == 0) && (rrk == 0))
11158 {
11159 switch (lwh)
11160 {
11161 case FFEINFO_whereCONSTANT:
11162 switch (rwh)
11163 {
11164 case FFEINFO_whereCONSTANT:
11165 nwh = FFEINFO_whereCONSTANT;
11166 break;
11167
11168 case FFEINFO_whereIMMEDIATE:
11169 nwh = FFEINFO_whereIMMEDIATE;
11170 break;
11171
11172 default:
11173 nwh = FFEINFO_whereFLEETING;
11174 break;
11175 }
11176 break;
11177
11178 case FFEINFO_whereIMMEDIATE:
11179 switch (rwh)
11180 {
11181 case FFEINFO_whereCONSTANT:
11182 case FFEINFO_whereIMMEDIATE:
11183 nwh = FFEINFO_whereIMMEDIATE;
11184 break;
11185
11186 default:
11187 nwh = FFEINFO_whereFLEETING;
11188 break;
11189 }
11190 break;
11191
11192 default:
11193 nwh = FFEINFO_whereFLEETING;
11194 break;
11195 }
11196
11197 if ((lsz != FFETARGET_charactersizeNONE)
11198 && (rsz != FFETARGET_charactersizeNONE))
11199 lsz = rsz = (lsz > rsz) ? lsz : rsz;
11200
11201 ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
11202 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
11203 ffebld_set_info (reduced, ninfo);
11204 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11205 l->token, op->token, nbt, nkt, 0, lsz,
11206 FFEEXPR_contextLET));
11207 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11208 r->token, op->token, nbt, nkt, 0, rsz,
11209 FFEEXPR_contextLET));
11210 return reduced;
11211 }
11212
11213 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
11214 && (lbt != FFEINFO_basictypeCHARACTER))
11215 {
11216 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
11217 && (rbt != FFEINFO_basictypeCHARACTER))
11218 {
11219 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
11220 && ffebad_start (FFEBAD_RELOP_ARGS_TYPE))
11221 {
11222 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11223 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11224 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11225 ffebad_finish ();
11226 }
11227 }
11228 else
11229 {
11230 if ((lbt != FFEINFO_basictypeANY)
11231 && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
11232 {
11233 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11234 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11235 ffebad_finish ();
11236 }
11237 }
11238 }
11239 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
11240 && (rbt != FFEINFO_basictypeCHARACTER))
11241 {
11242 if ((rbt != FFEINFO_basictypeANY)
11243 && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
11244 {
11245 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11246 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11247 ffebad_finish ();
11248 }
11249 }
11250 else if (lrk != 0)
11251 {
11252 if ((lkd != FFEINFO_kindANY)
11253 && ffebad_start (FFEBAD_RELOP_ARG_KIND))
11254 {
11255 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11256 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11257 ffebad_string ("an array");
11258 ffebad_finish ();
11259 }
11260 }
11261 else
11262 {
11263 if ((rkd != FFEINFO_kindANY)
11264 && ffebad_start (FFEBAD_RELOP_ARG_KIND))
11265 {
11266 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11267 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11268 ffebad_string ("an array");
11269 ffebad_finish ();
11270 }
11271 }
11272
11273 reduced = ffebld_new_any ();
11274 ffebld_set_info (reduced, ffeinfo_new_any ());
11275 return reduced;
11276 }
11277
11278 /* ffeexpr_reduced_ugly1_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
11279
11280 reduced = ffeexpr_reduced_ugly1_(reduced,op,r);
11281
11282 Sigh. */
11283
11284 static ffebld
11285 ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
11286 {
11287 ffeinfo rinfo;
11288 ffeinfoBasictype rbt;
11289 ffeinfoKindtype rkt;
11290 ffeinfoRank rrk;
11291 ffeinfoKind rkd;
11292 ffeinfoWhere rwh;
11293
11294 rinfo = ffebld_info (ffebld_left (reduced));
11295 rbt = ffeinfo_basictype (rinfo);
11296 rkt = ffeinfo_kindtype (rinfo);
11297 rrk = ffeinfo_rank (rinfo);
11298 rkd = ffeinfo_kind (rinfo);
11299 rwh = ffeinfo_where (rinfo);
11300
11301 if ((rbt == FFEINFO_basictypeTYPELESS)
11302 || (rbt == FFEINFO_basictypeHOLLERITH))
11303 {
11304 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11305 r->token, op->token, FFEINFO_basictypeINTEGER,
11306 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11307 FFETARGET_charactersizeNONE,
11308 FFEEXPR_contextLET));
11309 rinfo = ffebld_info (ffebld_left (reduced));
11310 rbt = FFEINFO_basictypeINTEGER;
11311 rkt = FFEINFO_kindtypeINTEGERDEFAULT;
11312 rrk = 0;
11313 rkd = FFEINFO_kindENTITY;
11314 rwh = ffeinfo_where (rinfo);
11315 }
11316
11317 if (rbt == FFEINFO_basictypeLOGICAL)
11318 {
11319 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11320 r->token, op->token, FFEINFO_basictypeINTEGER,
11321 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11322 FFETARGET_charactersizeNONE,
11323 FFEEXPR_contextLET));
11324 }
11325
11326 return reduced;
11327 }
11328
11329 /* ffeexpr_reduced_ugly1log_ -- Deal with TYPELESS and HOLLERITH
11330
11331 reduced = ffeexpr_reduced_ugly1log_(reduced,op,r);
11332
11333 Sigh. */
11334
11335 static ffebld
11336 ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
11337 {
11338 ffeinfo rinfo;
11339 ffeinfoBasictype rbt;
11340 ffeinfoKindtype rkt;
11341 ffeinfoRank rrk;
11342 ffeinfoKind rkd;
11343 ffeinfoWhere rwh;
11344
11345 rinfo = ffebld_info (ffebld_left (reduced));
11346 rbt = ffeinfo_basictype (rinfo);
11347 rkt = ffeinfo_kindtype (rinfo);
11348 rrk = ffeinfo_rank (rinfo);
11349 rkd = ffeinfo_kind (rinfo);
11350 rwh = ffeinfo_where (rinfo);
11351
11352 if ((rbt == FFEINFO_basictypeTYPELESS)
11353 || (rbt == FFEINFO_basictypeHOLLERITH))
11354 {
11355 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11356 r->token, op->token, FFEINFO_basictypeLOGICAL, 0,
11357 FFEINFO_kindtypeLOGICALDEFAULT,
11358 FFETARGET_charactersizeNONE,
11359 FFEEXPR_contextLET));
11360 rinfo = ffebld_info (ffebld_left (reduced));
11361 rbt = FFEINFO_basictypeLOGICAL;
11362 rkt = FFEINFO_kindtypeLOGICALDEFAULT;
11363 rrk = 0;
11364 rkd = FFEINFO_kindENTITY;
11365 rwh = ffeinfo_where (rinfo);
11366 }
11367
11368 return reduced;
11369 }
11370
11371 /* ffeexpr_reduced_ugly2_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
11372
11373 reduced = ffeexpr_reduced_ugly2_(reduced,l,op,r);
11374
11375 Sigh. */
11376
11377 static ffebld
11378 ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
11379 ffeexprExpr_ r)
11380 {
11381 ffeinfo linfo, rinfo;
11382 ffeinfoBasictype lbt, rbt;
11383 ffeinfoKindtype lkt, rkt;
11384 ffeinfoRank lrk, rrk;
11385 ffeinfoKind lkd, rkd;
11386 ffeinfoWhere lwh, rwh;
11387
11388 linfo = ffebld_info (ffebld_left (reduced));
11389 lbt = ffeinfo_basictype (linfo);
11390 lkt = ffeinfo_kindtype (linfo);
11391 lrk = ffeinfo_rank (linfo);
11392 lkd = ffeinfo_kind (linfo);
11393 lwh = ffeinfo_where (linfo);
11394
11395 rinfo = ffebld_info (ffebld_right (reduced));
11396 rbt = ffeinfo_basictype (rinfo);
11397 rkt = ffeinfo_kindtype (rinfo);
11398 rrk = ffeinfo_rank (rinfo);
11399 rkd = ffeinfo_kind (rinfo);
11400 rwh = ffeinfo_where (rinfo);
11401
11402 if ((lbt == FFEINFO_basictypeTYPELESS)
11403 || (lbt == FFEINFO_basictypeHOLLERITH))
11404 {
11405 if ((rbt == FFEINFO_basictypeTYPELESS)
11406 || (rbt == FFEINFO_basictypeHOLLERITH))
11407 {
11408 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11409 l->token, op->token, FFEINFO_basictypeINTEGER,
11410 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11411 FFETARGET_charactersizeNONE,
11412 FFEEXPR_contextLET));
11413 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11414 r->token, op->token, FFEINFO_basictypeINTEGER, 0,
11415 FFEINFO_kindtypeINTEGERDEFAULT,
11416 FFETARGET_charactersizeNONE,
11417 FFEEXPR_contextLET));
11418 linfo = ffebld_info (ffebld_left (reduced));
11419 rinfo = ffebld_info (ffebld_right (reduced));
11420 lbt = rbt = FFEINFO_basictypeINTEGER;
11421 lkt = rkt = FFEINFO_kindtypeINTEGERDEFAULT;
11422 lrk = rrk = 0;
11423 lkd = rkd = FFEINFO_kindENTITY;
11424 lwh = ffeinfo_where (linfo);
11425 rwh = ffeinfo_where (rinfo);
11426 }
11427 else
11428 {
11429 ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
11430 l->token, ffebld_right (reduced), r->token,
11431 FFEEXPR_contextLET));
11432 linfo = ffebld_info (ffebld_left (reduced));
11433 lbt = ffeinfo_basictype (linfo);
11434 lkt = ffeinfo_kindtype (linfo);
11435 lrk = ffeinfo_rank (linfo);
11436 lkd = ffeinfo_kind (linfo);
11437 lwh = ffeinfo_where (linfo);
11438 }
11439 }
11440 else
11441 {
11442 if ((rbt == FFEINFO_basictypeTYPELESS)
11443 || (rbt == FFEINFO_basictypeHOLLERITH))
11444 {
11445 ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
11446 r->token, ffebld_left (reduced), l->token,
11447 FFEEXPR_contextLET));
11448 rinfo = ffebld_info (ffebld_right (reduced));
11449 rbt = ffeinfo_basictype (rinfo);
11450 rkt = ffeinfo_kindtype (rinfo);
11451 rrk = ffeinfo_rank (rinfo);
11452 rkd = ffeinfo_kind (rinfo);
11453 rwh = ffeinfo_where (rinfo);
11454 }
11455 /* else Leave it alone. */
11456 }
11457
11458 if (lbt == FFEINFO_basictypeLOGICAL)
11459 {
11460 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11461 l->token, op->token, FFEINFO_basictypeINTEGER,
11462 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11463 FFETARGET_charactersizeNONE,
11464 FFEEXPR_contextLET));
11465 }
11466
11467 if (rbt == FFEINFO_basictypeLOGICAL)
11468 {
11469 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11470 r->token, op->token, FFEINFO_basictypeINTEGER,
11471 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11472 FFETARGET_charactersizeNONE,
11473 FFEEXPR_contextLET));
11474 }
11475
11476 return reduced;
11477 }
11478
11479 /* ffeexpr_reduced_ugly2log_ -- Deal with TYPELESS and HOLLERITH
11480
11481 reduced = ffeexpr_reduced_ugly2log_(reduced,l,op,r);
11482
11483 Sigh. */
11484
11485 static ffebld
11486 ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
11487 ffeexprExpr_ r)
11488 {
11489 ffeinfo linfo, rinfo;
11490 ffeinfoBasictype lbt, rbt;
11491 ffeinfoKindtype lkt, rkt;
11492 ffeinfoRank lrk, rrk;
11493 ffeinfoKind lkd, rkd;
11494 ffeinfoWhere lwh, rwh;
11495
11496 linfo = ffebld_info (ffebld_left (reduced));
11497 lbt = ffeinfo_basictype (linfo);
11498 lkt = ffeinfo_kindtype (linfo);
11499 lrk = ffeinfo_rank (linfo);
11500 lkd = ffeinfo_kind (linfo);
11501 lwh = ffeinfo_where (linfo);
11502
11503 rinfo = ffebld_info (ffebld_right (reduced));
11504 rbt = ffeinfo_basictype (rinfo);
11505 rkt = ffeinfo_kindtype (rinfo);
11506 rrk = ffeinfo_rank (rinfo);
11507 rkd = ffeinfo_kind (rinfo);
11508 rwh = ffeinfo_where (rinfo);
11509
11510 if ((lbt == FFEINFO_basictypeTYPELESS)
11511 || (lbt == FFEINFO_basictypeHOLLERITH))
11512 {
11513 if ((rbt == FFEINFO_basictypeTYPELESS)
11514 || (rbt == FFEINFO_basictypeHOLLERITH))
11515 {
11516 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11517 l->token, op->token, FFEINFO_basictypeLOGICAL,
11518 FFEINFO_kindtypeLOGICALDEFAULT, 0,
11519 FFETARGET_charactersizeNONE,
11520 FFEEXPR_contextLET));
11521 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11522 r->token, op->token, FFEINFO_basictypeLOGICAL,
11523 FFEINFO_kindtypeLOGICALDEFAULT, 0,
11524 FFETARGET_charactersizeNONE,
11525 FFEEXPR_contextLET));
11526 linfo = ffebld_info (ffebld_left (reduced));
11527 rinfo = ffebld_info (ffebld_right (reduced));
11528 lbt = rbt = FFEINFO_basictypeLOGICAL;
11529 lkt = rkt = FFEINFO_kindtypeLOGICALDEFAULT;
11530 lrk = rrk = 0;
11531 lkd = rkd = FFEINFO_kindENTITY;
11532 lwh = ffeinfo_where (linfo);
11533 rwh = ffeinfo_where (rinfo);
11534 }
11535 else
11536 {
11537 ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
11538 l->token, ffebld_right (reduced), r->token,
11539 FFEEXPR_contextLET));
11540 linfo = ffebld_info (ffebld_left (reduced));
11541 lbt = ffeinfo_basictype (linfo);
11542 lkt = ffeinfo_kindtype (linfo);
11543 lrk = ffeinfo_rank (linfo);
11544 lkd = ffeinfo_kind (linfo);
11545 lwh = ffeinfo_where (linfo);
11546 }
11547 }
11548 else
11549 {
11550 if ((rbt == FFEINFO_basictypeTYPELESS)
11551 || (rbt == FFEINFO_basictypeHOLLERITH))
11552 {
11553 ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
11554 r->token, ffebld_left (reduced), l->token,
11555 FFEEXPR_contextLET));
11556 rinfo = ffebld_info (ffebld_right (reduced));
11557 rbt = ffeinfo_basictype (rinfo);
11558 rkt = ffeinfo_kindtype (rinfo);
11559 rrk = ffeinfo_rank (rinfo);
11560 rkd = ffeinfo_kind (rinfo);
11561 rwh = ffeinfo_where (rinfo);
11562 }
11563 /* else Leave it alone. */
11564 }
11565
11566 return reduced;
11567 }
11568
11569 /* Fumble through tokens until a nonmatching CLOSE_PAREN, EOS, or SEMICOLON
11570 is found.
11571
11572 The idea is to process the tokens as they would be done by normal
11573 expression processing, with the key things being telling the lexer
11574 when hollerith/character constants are about to happen, until the
11575 true closing token is found. */
11576
11577 static ffelexHandler
11578 ffeexpr_find_close_paren_ (ffelexToken t,
11579 ffelexHandler after)
11580 {
11581 ffeexpr_find_.after = after;
11582 ffeexpr_find_.level = 1;
11583 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11584 }
11585
11586 static ffelexHandler
11587 ffeexpr_nil_finished_ (ffelexToken t)
11588 {
11589 switch (ffelex_token_type (t))
11590 {
11591 case FFELEX_typeCLOSE_PAREN:
11592 if (--ffeexpr_find_.level == 0)
11593 return (ffelexHandler) ffeexpr_find_.after;
11594 return (ffelexHandler) ffeexpr_nil_binary_;
11595
11596 case FFELEX_typeCOMMA:
11597 case FFELEX_typeCOLON:
11598 case FFELEX_typeEQUALS:
11599 case FFELEX_typePOINTS:
11600 return (ffelexHandler) ffeexpr_nil_rhs_;
11601
11602 default:
11603 if (--ffeexpr_find_.level == 0)
11604 return (ffelexHandler) ffeexpr_find_.after (t);
11605 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11606 }
11607 }
11608
11609 static ffelexHandler
11610 ffeexpr_nil_rhs_ (ffelexToken t)
11611 {
11612 switch (ffelex_token_type (t))
11613 {
11614 case FFELEX_typeQUOTE:
11615 if (ffe_is_vxt ())
11616 return (ffelexHandler) ffeexpr_nil_quote_;
11617 ffelex_set_expecting_hollerith (-1, '\"',
11618 ffelex_token_where_line (t),
11619 ffelex_token_where_column (t));
11620 return (ffelexHandler) ffeexpr_nil_apostrophe_;
11621
11622 case FFELEX_typeAPOSTROPHE:
11623 ffelex_set_expecting_hollerith (-1, '\'',
11624 ffelex_token_where_line (t),
11625 ffelex_token_where_column (t));
11626 return (ffelexHandler) ffeexpr_nil_apostrophe_;
11627
11628 case FFELEX_typePERCENT:
11629 return (ffelexHandler) ffeexpr_nil_percent_;
11630
11631 case FFELEX_typeOPEN_PAREN:
11632 ++ffeexpr_find_.level;
11633 return (ffelexHandler) ffeexpr_nil_rhs_;
11634
11635 case FFELEX_typePLUS:
11636 case FFELEX_typeMINUS:
11637 return (ffelexHandler) ffeexpr_nil_rhs_;
11638
11639 case FFELEX_typePERIOD:
11640 return (ffelexHandler) ffeexpr_nil_period_;
11641
11642 case FFELEX_typeNUMBER:
11643 ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
11644 if (ffeexpr_hollerith_count_ > 0)
11645 ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
11646 '\0',
11647 ffelex_token_where_line (t),
11648 ffelex_token_where_column (t));
11649 return (ffelexHandler) ffeexpr_nil_number_;
11650
11651 case FFELEX_typeNAME:
11652 case FFELEX_typeNAMES:
11653 return (ffelexHandler) ffeexpr_nil_name_rhs_;
11654
11655 case FFELEX_typeASTERISK:
11656 case FFELEX_typeSLASH:
11657 case FFELEX_typePOWER:
11658 case FFELEX_typeCONCAT:
11659 case FFELEX_typeREL_EQ:
11660 case FFELEX_typeREL_NE:
11661 case FFELEX_typeREL_LE:
11662 case FFELEX_typeREL_GE:
11663 return (ffelexHandler) ffeexpr_nil_rhs_;
11664
11665 default:
11666 return (ffelexHandler) ffeexpr_nil_finished_ (t);
11667 }
11668 }
11669
11670 static ffelexHandler
11671 ffeexpr_nil_period_ (ffelexToken t)
11672 {
11673 switch (ffelex_token_type (t))
11674 {
11675 case FFELEX_typeNAME:
11676 case FFELEX_typeNAMES:
11677 ffeexpr_current_dotdot_ = ffeexpr_dotdot_ (t);
11678 switch (ffeexpr_current_dotdot_)
11679 {
11680 case FFEEXPR_dotdotNONE_:
11681 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11682
11683 case FFEEXPR_dotdotTRUE_:
11684 case FFEEXPR_dotdotFALSE_:
11685 case FFEEXPR_dotdotNOT_:
11686 return (ffelexHandler) ffeexpr_nil_end_period_;
11687
11688 default:
11689 return (ffelexHandler) ffeexpr_nil_swallow_period_;
11690 }
11691 break; /* Nothing really reaches here. */
11692
11693 case FFELEX_typeNUMBER:
11694 return (ffelexHandler) ffeexpr_nil_real_;
11695
11696 default:
11697 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11698 }
11699 }
11700
11701 static ffelexHandler
11702 ffeexpr_nil_end_period_ (ffelexToken t)
11703 {
11704 switch (ffeexpr_current_dotdot_)
11705 {
11706 case FFEEXPR_dotdotNOT_:
11707 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11708 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11709 return (ffelexHandler) ffeexpr_nil_rhs_;
11710
11711 case FFEEXPR_dotdotTRUE_:
11712 case FFEEXPR_dotdotFALSE_:
11713 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11714 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11715 return (ffelexHandler) ffeexpr_nil_binary_;
11716
11717 default:
11718 assert ("Bad [nil] unary dotdot in ffeexpr_current_dotdot_" == NULL);
11719 exit (0);
11720 return NULL;
11721 }
11722 }
11723
11724 static ffelexHandler
11725 ffeexpr_nil_swallow_period_ (ffelexToken t)
11726 {
11727 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11728 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11729 return (ffelexHandler) ffeexpr_nil_rhs_;
11730 }
11731
11732 static ffelexHandler
11733 ffeexpr_nil_real_ (ffelexToken t)
11734 {
11735 char d;
11736 char *p;
11737
11738 if (((ffelex_token_type (t) != FFELEX_typeNAME)
11739 && (ffelex_token_type (t) != FFELEX_typeNAMES))
11740 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11741 'D', 'd')
11742 || ffesrc_char_match_init (d, 'E', 'e')
11743 || ffesrc_char_match_init (d, 'Q', 'q')))
11744 && ffeexpr_isdigits_ (++p)))
11745 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11746
11747 if (*p == '\0')
11748 return (ffelexHandler) ffeexpr_nil_real_exponent_;
11749 return (ffelexHandler) ffeexpr_nil_binary_;
11750 }
11751
11752 static ffelexHandler
11753 ffeexpr_nil_real_exponent_ (ffelexToken t)
11754 {
11755 if ((ffelex_token_type (t) != FFELEX_typePLUS)
11756 && (ffelex_token_type (t) != FFELEX_typeMINUS))
11757 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11758
11759 return (ffelexHandler) ffeexpr_nil_real_exp_sign_;
11760 }
11761
11762 static ffelexHandler
11763 ffeexpr_nil_real_exp_sign_ (ffelexToken t)
11764 {
11765 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11766 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11767 return (ffelexHandler) ffeexpr_nil_binary_;
11768 }
11769
11770 static ffelexHandler
11771 ffeexpr_nil_number_ (ffelexToken t)
11772 {
11773 char d;
11774 char *p;
11775
11776 if (ffeexpr_hollerith_count_ > 0)
11777 ffelex_set_expecting_hollerith (0, '\0',
11778 ffewhere_line_unknown (),
11779 ffewhere_column_unknown ());
11780
11781 switch (ffelex_token_type (t))
11782 {
11783 case FFELEX_typeNAME:
11784 case FFELEX_typeNAMES:
11785 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11786 'D', 'd')
11787 || ffesrc_char_match_init (d, 'E', 'e')
11788 || ffesrc_char_match_init (d, 'Q', 'q'))
11789 && ffeexpr_isdigits_ (++p))
11790 {
11791 if (*p == '\0')
11792 {
11793 ffeexpr_find_.t = ffelex_token_use (t);
11794 return (ffelexHandler) ffeexpr_nil_number_exponent_;
11795 }
11796 return (ffelexHandler) ffeexpr_nil_binary_;
11797 }
11798 break;
11799
11800 case FFELEX_typePERIOD:
11801 ffeexpr_find_.t = ffelex_token_use (t);
11802 return (ffelexHandler) ffeexpr_nil_number_period_;
11803
11804 case FFELEX_typeHOLLERITH:
11805 return (ffelexHandler) ffeexpr_nil_binary_;
11806
11807 default:
11808 break;
11809 }
11810 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11811 }
11812
11813 /* Expects ffeexpr_find_.t. */
11814
11815 static ffelexHandler
11816 ffeexpr_nil_number_exponent_ (ffelexToken t)
11817 {
11818 ffelexHandler nexthandler;
11819
11820 if ((ffelex_token_type (t) != FFELEX_typePLUS)
11821 && (ffelex_token_type (t) != FFELEX_typeMINUS))
11822 {
11823 nexthandler
11824 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
11825 ffelex_token_kill (ffeexpr_find_.t);
11826 return (ffelexHandler) (*nexthandler) (t);
11827 }
11828
11829 ffelex_token_kill (ffeexpr_find_.t);
11830 return (ffelexHandler) ffeexpr_nil_number_exp_sign_;
11831 }
11832
11833 static ffelexHandler
11834 ffeexpr_nil_number_exp_sign_ (ffelexToken t)
11835 {
11836 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11837 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11838
11839 return (ffelexHandler) ffeexpr_nil_binary_;
11840 }
11841
11842 /* Expects ffeexpr_find_.t. */
11843
11844 static ffelexHandler
11845 ffeexpr_nil_number_period_ (ffelexToken t)
11846 {
11847 ffelexHandler nexthandler;
11848 char d;
11849 char *p;
11850
11851 switch (ffelex_token_type (t))
11852 {
11853 case FFELEX_typeNAME:
11854 case FFELEX_typeNAMES:
11855 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11856 'D', 'd')
11857 || ffesrc_char_match_init (d, 'E', 'e')
11858 || ffesrc_char_match_init (d, 'Q', 'q'))
11859 && ffeexpr_isdigits_ (++p))
11860 {
11861 if (*p == '\0')
11862 return (ffelexHandler) ffeexpr_nil_number_per_exp_;
11863 ffelex_token_kill (ffeexpr_find_.t);
11864 return (ffelexHandler) ffeexpr_nil_binary_;
11865 }
11866 nexthandler
11867 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
11868 ffelex_token_kill (ffeexpr_find_.t);
11869 return (ffelexHandler) (*nexthandler) (t);
11870
11871 case FFELEX_typeNUMBER:
11872 ffelex_token_kill (ffeexpr_find_.t);
11873 return (ffelexHandler) ffeexpr_nil_number_real_;
11874
11875 default:
11876 break;
11877 }
11878 ffelex_token_kill (ffeexpr_find_.t);
11879 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11880 }
11881
11882 /* Expects ffeexpr_find_.t. */
11883
11884 static ffelexHandler
11885 ffeexpr_nil_number_per_exp_ (ffelexToken t)
11886 {
11887 if ((ffelex_token_type (t) != FFELEX_typePLUS)
11888 && (ffelex_token_type (t) != FFELEX_typeMINUS))
11889 {
11890 ffelexHandler nexthandler;
11891
11892 nexthandler
11893 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
11894 ffelex_token_kill (ffeexpr_find_.t);
11895 return (ffelexHandler) (*nexthandler) (t);
11896 }
11897
11898 ffelex_token_kill (ffeexpr_find_.t);
11899 return (ffelexHandler) ffeexpr_nil_num_per_exp_sign_;
11900 }
11901
11902 static ffelexHandler
11903 ffeexpr_nil_number_real_ (ffelexToken t)
11904 {
11905 char d;
11906 char *p;
11907
11908 if (((ffelex_token_type (t) != FFELEX_typeNAME)
11909 && (ffelex_token_type (t) != FFELEX_typeNAMES))
11910 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11911 'D', 'd')
11912 || ffesrc_char_match_init (d, 'E', 'e')
11913 || ffesrc_char_match_init (d, 'Q', 'q')))
11914 && ffeexpr_isdigits_ (++p)))
11915 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11916
11917 if (*p == '\0')
11918 return (ffelexHandler) ffeexpr_nil_number_real_exp_;
11919
11920 return (ffelexHandler) ffeexpr_nil_binary_;
11921 }
11922
11923 static ffelexHandler
11924 ffeexpr_nil_num_per_exp_sign_ (ffelexToken t)
11925 {
11926 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11927 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11928 return (ffelexHandler) ffeexpr_nil_binary_;
11929 }
11930
11931 static ffelexHandler
11932 ffeexpr_nil_number_real_exp_ (ffelexToken t)
11933 {
11934 if ((ffelex_token_type (t) != FFELEX_typePLUS)
11935 && (ffelex_token_type (t) != FFELEX_typeMINUS))
11936 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11937 return (ffelexHandler) ffeexpr_nil_num_real_exp_sn_;
11938 }
11939
11940 static ffelexHandler
11941 ffeexpr_nil_num_real_exp_sn_ (ffelexToken t)
11942 {
11943 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11944 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11945 return (ffelexHandler) ffeexpr_nil_binary_;
11946 }
11947
11948 static ffelexHandler
11949 ffeexpr_nil_binary_ (ffelexToken t)
11950 {
11951 switch (ffelex_token_type (t))
11952 {
11953 case FFELEX_typePLUS:
11954 case FFELEX_typeMINUS:
11955 case FFELEX_typeASTERISK:
11956 case FFELEX_typeSLASH:
11957 case FFELEX_typePOWER:
11958 case FFELEX_typeCONCAT:
11959 case FFELEX_typeOPEN_ANGLE:
11960 case FFELEX_typeCLOSE_ANGLE:
11961 case FFELEX_typeREL_EQ:
11962 case FFELEX_typeREL_NE:
11963 case FFELEX_typeREL_GE:
11964 case FFELEX_typeREL_LE:
11965 return (ffelexHandler) ffeexpr_nil_rhs_;
11966
11967 case FFELEX_typePERIOD:
11968 return (ffelexHandler) ffeexpr_nil_binary_period_;
11969
11970 default:
11971 return (ffelexHandler) ffeexpr_nil_finished_ (t);
11972 }
11973 }
11974
11975 static ffelexHandler
11976 ffeexpr_nil_binary_period_ (ffelexToken t)
11977 {
11978 switch (ffelex_token_type (t))
11979 {
11980 case FFELEX_typeNAME:
11981 case FFELEX_typeNAMES:
11982 ffeexpr_current_dotdot_ = ffeexpr_dotdot_ (t);
11983 switch (ffeexpr_current_dotdot_)
11984 {
11985 case FFEEXPR_dotdotTRUE_:
11986 case FFEEXPR_dotdotFALSE_:
11987 case FFEEXPR_dotdotNOT_:
11988 return (ffelexHandler) ffeexpr_nil_binary_sw_per_;
11989
11990 default:
11991 return (ffelexHandler) ffeexpr_nil_binary_end_per_;
11992 }
11993 break; /* Nothing really reaches here. */
11994
11995 default:
11996 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11997 }
11998 }
11999
12000 static ffelexHandler
12001 ffeexpr_nil_binary_end_per_ (ffelexToken t)
12002 {
12003 if (ffelex_token_type (t) != FFELEX_typePERIOD)
12004 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
12005 return (ffelexHandler) ffeexpr_nil_rhs_;
12006 }
12007
12008 static ffelexHandler
12009 ffeexpr_nil_binary_sw_per_ (ffelexToken t)
12010 {
12011 if (ffelex_token_type (t) != FFELEX_typePERIOD)
12012 return (ffelexHandler) ffeexpr_nil_binary_ (t);
12013 return (ffelexHandler) ffeexpr_nil_binary_;
12014 }
12015
12016 static ffelexHandler
12017 ffeexpr_nil_quote_ (ffelexToken t)
12018 {
12019 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
12020 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
12021 return (ffelexHandler) ffeexpr_nil_binary_;
12022 }
12023
12024 static ffelexHandler
12025 ffeexpr_nil_apostrophe_ (ffelexToken t)
12026 {
12027 assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
12028 return (ffelexHandler) ffeexpr_nil_apos_char_;
12029 }
12030
12031 static ffelexHandler
12032 ffeexpr_nil_apos_char_ (ffelexToken t)
12033 {
12034 char c;
12035
12036 if ((ffelex_token_type (t) == FFELEX_typeNAME)
12037 || (ffelex_token_type (t) == FFELEX_typeNAMES))
12038 {
12039 if ((ffelex_token_length (t) == 1)
12040 && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]),
12041 'B', 'b')
12042 || ffesrc_char_match_init (c, 'O', 'o')
12043 || ffesrc_char_match_init (c, 'X', 'x')
12044 || ffesrc_char_match_init (c, 'Z', 'z')))
12045 return (ffelexHandler) ffeexpr_nil_binary_;
12046 }
12047 if ((ffelex_token_type (t) == FFELEX_typeNAME)
12048 || (ffelex_token_type (t) == FFELEX_typeNAMES))
12049 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
12050 return (ffelexHandler) ffeexpr_nil_substrp_ (t);
12051 }
12052
12053 static ffelexHandler
12054 ffeexpr_nil_name_rhs_ (ffelexToken t)
12055 {
12056 switch (ffelex_token_type (t))
12057 {
12058 case FFELEX_typeQUOTE:
12059 case FFELEX_typeAPOSTROPHE:
12060 ffelex_set_hexnum (TRUE);
12061 return (ffelexHandler) ffeexpr_nil_name_apos_;
12062
12063 case FFELEX_typeOPEN_PAREN:
12064 ++ffeexpr_find_.level;
12065 return (ffelexHandler) ffeexpr_nil_rhs_;
12066
12067 default:
12068 return (ffelexHandler) ffeexpr_nil_binary_ (t);
12069 }
12070 }
12071
12072 static ffelexHandler
12073 ffeexpr_nil_name_apos_ (ffelexToken t)
12074 {
12075 if (ffelex_token_type (t) == FFELEX_typeNAME)
12076 return (ffelexHandler) ffeexpr_nil_name_apos_name_;
12077 return (ffelexHandler) ffeexpr_nil_binary_ (t);
12078 }
12079
12080 static ffelexHandler
12081 ffeexpr_nil_name_apos_name_ (ffelexToken t)
12082 {
12083 switch (ffelex_token_type (t))
12084 {
12085 case FFELEX_typeAPOSTROPHE:
12086 case FFELEX_typeQUOTE:
12087 return (ffelexHandler) ffeexpr_nil_finished_;
12088
12089 default:
12090 return (ffelexHandler) ffeexpr_nil_finished_ (t);
12091 }
12092 }
12093
12094 static ffelexHandler
12095 ffeexpr_nil_percent_ (ffelexToken t)
12096 {
12097 switch (ffelex_token_type (t))
12098 {
12099 case FFELEX_typeNAME:
12100 case FFELEX_typeNAMES:
12101 ffeexpr_stack_->percent = ffeexpr_percent_ (t);
12102 ffeexpr_find_.t = ffelex_token_use (t);
12103 return (ffelexHandler) ffeexpr_nil_percent_name_;
12104
12105 default:
12106 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
12107 }
12108 }
12109
12110 /* Expects ffeexpr_find_.t. */
12111
12112 static ffelexHandler
12113 ffeexpr_nil_percent_name_ (ffelexToken t)
12114 {
12115 ffelexHandler nexthandler;
12116
12117 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
12118 {
12119 nexthandler
12120 = (ffelexHandler) ffeexpr_nil_rhs_ (ffeexpr_find_.t);
12121 ffelex_token_kill (ffeexpr_find_.t);
12122 return (ffelexHandler) (*nexthandler) (t);
12123 }
12124
12125 ffelex_token_kill (ffeexpr_find_.t);
12126 ++ffeexpr_find_.level;
12127 return (ffelexHandler) ffeexpr_nil_rhs_;
12128 }
12129
12130 static ffelexHandler
12131 ffeexpr_nil_substrp_ (ffelexToken t)
12132 {
12133 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
12134 return (ffelexHandler) ffeexpr_nil_binary_ (t);
12135
12136 ++ffeexpr_find_.level;
12137 return (ffelexHandler) ffeexpr_nil_rhs_;
12138 }
12139
12140 /* ffeexpr_finished_ -- Reduce expression stack to one expr, finish
12141
12142 ffelexToken t;
12143 return ffeexpr_finished_(t);
12144
12145 Reduces expression stack to one (or zero) elements by repeatedly reducing
12146 the top operator on the stack (or, if the top element on the stack is
12147 itself an operator, issuing an error message and discarding it). Calls
12148 finishing routine with the expression, returning the ffelexHandler it
12149 returns to the caller. */
12150
12151 static ffelexHandler
12152 ffeexpr_finished_ (ffelexToken t)
12153 {
12154 ffeexprExpr_ operand; /* This is B in -B or A+B. */
12155 ffebld expr;
12156 ffeexprCallback callback;
12157 ffeexprStack_ s;
12158 ffebldConstant constnode; /* For detecting magical number. */
12159 ffelexToken ft; /* Temporary copy of first token in
12160 expression. */
12161 ffelexHandler next;
12162 ffeinfo info;
12163 bool error = FALSE;
12164
12165 while (((operand = ffeexpr_stack_->exprstack) != NULL)
12166 && ((operand->previous != NULL) || (operand->type != FFEEXPR_exprtypeOPERAND_)))
12167 {
12168 if (operand->type == FFEEXPR_exprtypeOPERAND_)
12169 ffeexpr_reduce_ ();
12170 else
12171 {
12172 if (ffest_ffebad_start (FFEBAD_MISSING_OPERAND_FOR_OPERATOR))
12173 {
12174 ffebad_here (0, ffelex_token_where_line (t),
12175 ffelex_token_where_column (t));
12176 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
12177 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
12178 ffebad_finish ();
12179 }
12180 ffeexpr_stack_->exprstack = operand->previous; /* Pop the useless
12181 operator. */
12182 ffeexpr_expr_kill_ (operand);
12183 }
12184 }
12185
12186 assert ((operand == NULL) || (operand->previous == NULL));
12187
12188 ffebld_pool_pop ();
12189 if (operand == NULL)
12190 expr = NULL;
12191 else
12192 {
12193 expr = operand->u.operand;
12194 info = ffebld_info (expr);
12195 if ((ffebld_op (expr) == FFEBLD_opCONTER)
12196 && (ffebld_conter_orig (expr) == NULL)
12197 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
12198 {
12199 ffetarget_integer_bad_magical (operand->token);
12200 }
12201 ffeexpr_expr_kill_ (operand);
12202 ffeexpr_stack_->exprstack = NULL;
12203 }
12204
12205 ft = ffeexpr_stack_->first_token;
12206
12207 again: /* :::::::::::::::::::: */
12208 switch (ffeexpr_stack_->context)
12209 {
12210 case FFEEXPR_contextLET:
12211 case FFEEXPR_contextSFUNCDEF:
12212 error = (expr == NULL)
12213 || (ffeinfo_rank (info) != 0);
12214 break;
12215
12216 case FFEEXPR_contextPAREN_:
12217 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12218 break;
12219 switch (ffeinfo_basictype (info))
12220 {
12221 case FFEINFO_basictypeHOLLERITH:
12222 case FFEINFO_basictypeTYPELESS:
12223 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12224 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12225 FFEEXPR_contextLET);
12226 break;
12227
12228 default:
12229 break;
12230 }
12231 break;
12232
12233 case FFEEXPR_contextPARENFILENUM_:
12234 if (ffelex_token_type (t) != FFELEX_typeCOMMA)
12235 ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
12236 else
12237 ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
12238 goto again; /* :::::::::::::::::::: */
12239
12240 case FFEEXPR_contextPARENFILEUNIT_:
12241 if (ffelex_token_type (t) != FFELEX_typeCOMMA)
12242 ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
12243 else
12244 ffeexpr_stack_->context = FFEEXPR_contextFILEUNIT;
12245 goto again; /* :::::::::::::::::::: */
12246
12247 case FFEEXPR_contextACTUALARGEXPR_:
12248 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
12249 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12250 : ffeinfo_basictype (info))
12251 {
12252 case FFEINFO_basictypeHOLLERITH:
12253 case FFEINFO_basictypeTYPELESS:
12254 if (!ffe_is_ugly_args ()
12255 && ffebad_start (FFEBAD_ACTUALARG))
12256 {
12257 ffebad_here (0, ffelex_token_where_line (ft),
12258 ffelex_token_where_column (ft));
12259 ffebad_finish ();
12260 }
12261 break;
12262
12263 default:
12264 break;
12265 }
12266 error = (expr != NULL) && (ffeinfo_rank (info) != 0);
12267 break;
12268
12269 case FFEEXPR_contextACTUALARG_:
12270 case FFEEXPR_contextSFUNCDEFACTUALARG_:
12271 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12272 : ffeinfo_basictype (info))
12273 {
12274 case FFEINFO_basictypeHOLLERITH:
12275 case FFEINFO_basictypeTYPELESS:
12276 #if 0 /* Should never get here. */
12277 expr = ffeexpr_convert (expr, ft, ft,
12278 FFEINFO_basictypeINTEGER,
12279 FFEINFO_kindtypeINTEGERDEFAULT,
12280 0,
12281 FFETARGET_charactersizeNONE,
12282 FFEEXPR_contextLET);
12283 #else
12284 assert ("why hollerith/typeless in actualarg_?" == NULL);
12285 #endif
12286 break;
12287
12288 default:
12289 break;
12290 }
12291 switch ((expr == NULL) ? FFEBLD_opANY : ffebld_op (expr))
12292 {
12293 case FFEBLD_opSYMTER:
12294 case FFEBLD_opPERCENT_LOC:
12295 case FFEBLD_opPERCENT_VAL:
12296 case FFEBLD_opPERCENT_REF:
12297 case FFEBLD_opPERCENT_DESCR:
12298 error = FALSE;
12299 break;
12300
12301 default:
12302 error = (expr != NULL) && (ffeinfo_rank (info) != 0);
12303 break;
12304 }
12305 {
12306 ffesymbol s;
12307 ffeinfoWhere where;
12308 ffeinfoKind kind;
12309
12310 if (!error
12311 && (expr != NULL)
12312 && (ffebld_op (expr) == FFEBLD_opSYMTER)
12313 && ((s = ffebld_symter (expr)), (where = ffesymbol_where (s)),
12314 (where == FFEINFO_whereINTRINSIC)
12315 || (where == FFEINFO_whereGLOBAL)
12316 || ((where == FFEINFO_whereDUMMY)
12317 && ((kind = ffesymbol_kind (s)),
12318 (kind == FFEINFO_kindFUNCTION)
12319 || (kind == FFEINFO_kindSUBROUTINE))))
12320 && !ffesymbol_explicitwhere (s))
12321 {
12322 ffebad_start (where == FFEINFO_whereINTRINSIC
12323 ? FFEBAD_NEED_INTRINSIC : FFEBAD_NEED_EXTERNAL);
12324 ffebad_here (0, ffelex_token_where_line (ft),
12325 ffelex_token_where_column (ft));
12326 ffebad_string (ffesymbol_text (s));
12327 ffebad_finish ();
12328 ffesymbol_signal_change (s);
12329 ffesymbol_set_explicitwhere (s, TRUE);
12330 ffesymbol_signal_unreported (s);
12331 }
12332 }
12333 break;
12334
12335 case FFEEXPR_contextINDEX_:
12336 case FFEEXPR_contextSFUNCDEFINDEX_:
12337 case FFEEXPR_contextRETURN:
12338 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12339 break;
12340 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12341 : ffeinfo_basictype (info))
12342 {
12343 case FFEINFO_basictypeNONE:
12344 error = FALSE;
12345 break;
12346
12347 case FFEINFO_basictypeLOGICAL:
12348 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12349 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12350 FFEEXPR_contextLET);
12351 /* Fall through. */
12352 case FFEINFO_basictypeREAL:
12353 case FFEINFO_basictypeCOMPLEX:
12354 if (ffe_is_pedantic ())
12355 {
12356 error = TRUE;
12357 break;
12358 }
12359 /* Fall through. */
12360 case FFEINFO_basictypeINTEGER:
12361 case FFEINFO_basictypeHOLLERITH:
12362 case FFEINFO_basictypeTYPELESS:
12363 error = FALSE;
12364 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12365 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12366 FFEEXPR_contextLET);
12367 break;
12368
12369 default:
12370 error = TRUE;
12371 break;
12372 }
12373 break; /* expr==NULL ok for substring; element case
12374 caught by callback. */
12375
12376 case FFEEXPR_contextDO:
12377 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12378 break;
12379 switch (ffeinfo_basictype (info))
12380 {
12381 case FFEINFO_basictypeLOGICAL:
12382 error = !ffe_is_ugly_logint ();
12383 if (!ffeexpr_stack_->is_rhs)
12384 break; /* Don't convert lhs variable. */
12385 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12386 ffeinfo_kindtype (ffebld_info (expr)), 0,
12387 FFETARGET_charactersizeNONE,
12388 FFEEXPR_contextLET);
12389 break;
12390
12391 case FFEINFO_basictypeHOLLERITH:
12392 case FFEINFO_basictypeTYPELESS:
12393 if (!ffeexpr_stack_->is_rhs)
12394 {
12395 error = TRUE;
12396 break; /* Don't convert lhs variable. */
12397 }
12398 break;
12399
12400 case FFEINFO_basictypeINTEGER:
12401 case FFEINFO_basictypeREAL:
12402 break;
12403
12404 default:
12405 error = TRUE;
12406 break;
12407 }
12408 if (!ffeexpr_stack_->is_rhs
12409 && (ffebld_op (expr) != FFEBLD_opSYMTER))
12410 error = TRUE;
12411 break;
12412
12413 case FFEEXPR_contextDOWHILE:
12414 case FFEEXPR_contextIF:
12415 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12416 break;
12417 switch (ffeinfo_basictype (info))
12418 {
12419 case FFEINFO_basictypeINTEGER:
12420 error = FALSE;
12421 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12422 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12423 FFEEXPR_contextLET);
12424 /* Fall through. */
12425 case FFEINFO_basictypeLOGICAL:
12426 case FFEINFO_basictypeHOLLERITH:
12427 case FFEINFO_basictypeTYPELESS:
12428 error = FALSE;
12429 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12430 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12431 FFEEXPR_contextLET);
12432 break;
12433
12434 default:
12435 error = TRUE;
12436 break;
12437 }
12438 break;
12439
12440 case FFEEXPR_contextASSIGN:
12441 case FFEEXPR_contextAGOTO:
12442 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12443 : ffeinfo_basictype (info))
12444 {
12445 case FFEINFO_basictypeINTEGER:
12446 error = (ffeinfo_kindtype (info) != ffecom_label_kind ());
12447 break;
12448
12449 case FFEINFO_basictypeLOGICAL:
12450 error = !ffe_is_ugly_logint ()
12451 || (ffeinfo_kindtype (info) != ffecom_label_kind ());
12452 break;
12453
12454 default:
12455 error = TRUE;
12456 break;
12457 }
12458 if ((expr == NULL) || (ffeinfo_rank (info) != 0)
12459 || (ffebld_op (expr) != FFEBLD_opSYMTER))
12460 error = TRUE;
12461 break;
12462
12463 case FFEEXPR_contextCGOTO:
12464 case FFEEXPR_contextFORMAT:
12465 case FFEEXPR_contextDIMLIST:
12466 case FFEEXPR_contextFILENUM: /* See equiv code in _ambig_. */
12467 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12468 break;
12469 switch (ffeinfo_basictype (info))
12470 {
12471 case FFEINFO_basictypeLOGICAL:
12472 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12473 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12474 FFEEXPR_contextLET);
12475 /* Fall through. */
12476 case FFEINFO_basictypeREAL:
12477 case FFEINFO_basictypeCOMPLEX:
12478 if (ffe_is_pedantic ())
12479 {
12480 error = TRUE;
12481 break;
12482 }
12483 /* Fall through. */
12484 case FFEINFO_basictypeINTEGER:
12485 case FFEINFO_basictypeHOLLERITH:
12486 case FFEINFO_basictypeTYPELESS:
12487 error = FALSE;
12488 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12489 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12490 FFEEXPR_contextLET);
12491 break;
12492
12493 default:
12494 error = TRUE;
12495 break;
12496 }
12497 break;
12498
12499 case FFEEXPR_contextARITHIF:
12500 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12501 break;
12502 switch (ffeinfo_basictype (info))
12503 {
12504 case FFEINFO_basictypeLOGICAL:
12505 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12506 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12507 FFEEXPR_contextLET);
12508 if (ffe_is_pedantic ())
12509 {
12510 error = TRUE;
12511 break;
12512 }
12513 /* Fall through. */
12514 case FFEINFO_basictypeHOLLERITH:
12515 case FFEINFO_basictypeTYPELESS:
12516 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12517 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12518 FFEEXPR_contextLET);
12519 /* Fall through. */
12520 case FFEINFO_basictypeINTEGER:
12521 case FFEINFO_basictypeREAL:
12522 error = FALSE;
12523 break;
12524
12525 default:
12526 error = TRUE;
12527 break;
12528 }
12529 break;
12530
12531 case FFEEXPR_contextSTOP:
12532 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12533 break;
12534 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12535 : ffeinfo_basictype (info))
12536 {
12537 case FFEINFO_basictypeINTEGER:
12538 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12539 break;
12540
12541 case FFEINFO_basictypeCHARACTER:
12542 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT);
12543 break;
12544
12545 case FFEINFO_basictypeHOLLERITH:
12546 case FFEINFO_basictypeTYPELESS:
12547 error = FALSE;
12548 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12549 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12550 FFEEXPR_contextLET);
12551 break;
12552
12553 case FFEINFO_basictypeNONE:
12554 error = FALSE;
12555 break;
12556
12557 default:
12558 error = TRUE;
12559 break;
12560 }
12561 if ((expr != NULL) && ((ffebld_op (expr) != FFEBLD_opCONTER)
12562 || (ffebld_conter_orig (expr) != NULL)))
12563 error = TRUE;
12564 break;
12565
12566 case FFEEXPR_contextINCLUDE:
12567 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12568 || (ffeinfo_basictype (info) != FFEINFO_basictypeCHARACTER)
12569 || (ffebld_op (expr) != FFEBLD_opCONTER)
12570 || (ffebld_conter_orig (expr) != NULL);
12571 break;
12572
12573 case FFEEXPR_contextSELECTCASE:
12574 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12575 break;
12576 switch (ffeinfo_basictype (info))
12577 {
12578 case FFEINFO_basictypeINTEGER:
12579 case FFEINFO_basictypeCHARACTER:
12580 case FFEINFO_basictypeLOGICAL:
12581 error = FALSE;
12582 break;
12583
12584 case FFEINFO_basictypeHOLLERITH:
12585 case FFEINFO_basictypeTYPELESS:
12586 error = FALSE;
12587 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12588 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12589 FFEEXPR_contextLET);
12590 break;
12591
12592 default:
12593 error = TRUE;
12594 break;
12595 }
12596 break;
12597
12598 case FFEEXPR_contextCASE:
12599 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12600 break;
12601 switch ((expr == NULL) ? FFEINFO_basictypeINTEGER
12602 : ffeinfo_basictype (info))
12603 {
12604 case FFEINFO_basictypeINTEGER:
12605 case FFEINFO_basictypeCHARACTER:
12606 case FFEINFO_basictypeLOGICAL:
12607 error = FALSE;
12608 break;
12609
12610 case FFEINFO_basictypeHOLLERITH:
12611 case FFEINFO_basictypeTYPELESS:
12612 error = FALSE;
12613 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12614 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12615 FFEEXPR_contextLET);
12616 break;
12617
12618 default:
12619 error = TRUE;
12620 break;
12621 }
12622 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12623 error = TRUE;
12624 break;
12625
12626 case FFEEXPR_contextCHARACTERSIZE:
12627 case FFEEXPR_contextKINDTYPE:
12628 case FFEEXPR_contextDIMLISTCOMMON:
12629 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12630 break;
12631 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12632 : ffeinfo_basictype (info))
12633 {
12634 case FFEINFO_basictypeLOGICAL:
12635 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12636 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12637 FFEEXPR_contextLET);
12638 /* Fall through. */
12639 case FFEINFO_basictypeREAL:
12640 case FFEINFO_basictypeCOMPLEX:
12641 if (ffe_is_pedantic ())
12642 {
12643 error = TRUE;
12644 break;
12645 }
12646 /* Fall through. */
12647 case FFEINFO_basictypeINTEGER:
12648 case FFEINFO_basictypeHOLLERITH:
12649 case FFEINFO_basictypeTYPELESS:
12650 error = FALSE;
12651 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12652 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12653 FFEEXPR_contextLET);
12654 break;
12655
12656 default:
12657 error = TRUE;
12658 break;
12659 }
12660 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12661 error = TRUE;
12662 break;
12663
12664 case FFEEXPR_contextEQVINDEX_:
12665 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12666 break;
12667 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12668 : ffeinfo_basictype (info))
12669 {
12670 case FFEINFO_basictypeNONE:
12671 error = FALSE;
12672 break;
12673
12674 case FFEINFO_basictypeLOGICAL:
12675 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12676 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12677 FFEEXPR_contextLET);
12678 /* Fall through. */
12679 case FFEINFO_basictypeREAL:
12680 case FFEINFO_basictypeCOMPLEX:
12681 if (ffe_is_pedantic ())
12682 {
12683 error = TRUE;
12684 break;
12685 }
12686 /* Fall through. */
12687 case FFEINFO_basictypeINTEGER:
12688 case FFEINFO_basictypeHOLLERITH:
12689 case FFEINFO_basictypeTYPELESS:
12690 error = FALSE;
12691 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12692 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12693 FFEEXPR_contextLET);
12694 break;
12695
12696 default:
12697 error = TRUE;
12698 break;
12699 }
12700 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12701 error = TRUE;
12702 break;
12703
12704 case FFEEXPR_contextPARAMETER:
12705 if (ffeexpr_stack_->is_rhs)
12706 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12707 || (ffebld_op (expr) != FFEBLD_opCONTER);
12708 else
12709 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12710 || (ffebld_op (expr) != FFEBLD_opSYMTER);
12711 break;
12712
12713 case FFEEXPR_contextINDEXORACTUALARG_:
12714 if (ffelex_token_type (t) == FFELEX_typeCOLON)
12715 ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
12716 else
12717 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
12718 goto again; /* :::::::::::::::::::: */
12719
12720 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
12721 if (ffelex_token_type (t) == FFELEX_typeCOLON)
12722 ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
12723 else
12724 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
12725 goto again; /* :::::::::::::::::::: */
12726
12727 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
12728 if (ffelex_token_type (t) == FFELEX_typeCOLON)
12729 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
12730 else
12731 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
12732 goto again; /* :::::::::::::::::::: */
12733
12734 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
12735 if (ffelex_token_type (t) == FFELEX_typeCOLON)
12736 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
12737 else
12738 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
12739 goto again; /* :::::::::::::::::::: */
12740
12741 case FFEEXPR_contextIMPDOCTRL_:
12742 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12743 break;
12744 if (!ffeexpr_stack_->is_rhs
12745 && (ffebld_op (expr) != FFEBLD_opSYMTER))
12746 error = TRUE;
12747 switch (ffeinfo_basictype (info))
12748 {
12749 case FFEINFO_basictypeLOGICAL:
12750 error = error && !ffe_is_ugly_logint ();
12751 if (!ffeexpr_stack_->is_rhs)
12752 break; /* Don't convert lhs variable. */
12753 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12754 ffeinfo_kindtype (ffebld_info (expr)), 0,
12755 FFETARGET_charactersizeNONE,
12756 FFEEXPR_contextLET);
12757 break;
12758
12759 case FFEINFO_basictypeINTEGER:
12760 case FFEINFO_basictypeHOLLERITH:
12761 case FFEINFO_basictypeTYPELESS:
12762 break;
12763
12764 case FFEINFO_basictypeREAL:
12765 if (!ffeexpr_stack_->is_rhs
12766 && ffe_is_warn_surprising ()
12767 && !error)
12768 {
12769 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
12770 ffebad_here (0, ffelex_token_where_line (ft),
12771 ffelex_token_where_column (ft));
12772 ffebad_string (ffelex_token_text (ft));
12773 ffebad_finish ();
12774 }
12775 break;
12776
12777 default:
12778 error = TRUE;
12779 break;
12780 }
12781 break;
12782
12783 case FFEEXPR_contextDATAIMPDOCTRL_:
12784 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12785 break;
12786 if (ffeexpr_stack_->is_rhs)
12787 {
12788 if ((ffebld_op (expr) != FFEBLD_opCONTER)
12789 && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12790 error = TRUE;
12791 }
12792 else if ((ffebld_op (expr) != FFEBLD_opSYMTER)
12793 || (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12794 error = TRUE;
12795 switch (ffeinfo_basictype (info))
12796 {
12797 case FFEINFO_basictypeLOGICAL:
12798 error = error
12799 && (ffeinfo_kindtype (info) != FFEINFO_kindtypeLOGICALDEFAULT);
12800 if (!ffeexpr_stack_->is_rhs)
12801 break; /* Don't convert lhs variable. */
12802 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12803 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12804 FFEEXPR_contextLET);
12805 break;
12806
12807 case FFEINFO_basictypeINTEGER:
12808 error = error &&
12809 (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12810 break;
12811
12812 case FFEINFO_basictypeHOLLERITH:
12813 case FFEINFO_basictypeTYPELESS:
12814 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12815 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12816 FFEEXPR_contextLET);
12817 break;
12818
12819 case FFEINFO_basictypeREAL:
12820 if (!ffeexpr_stack_->is_rhs
12821 && ffe_is_warn_surprising ()
12822 && !error)
12823 {
12824 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
12825 ffebad_here (0, ffelex_token_where_line (ft),
12826 ffelex_token_where_column (ft));
12827 ffebad_string (ffelex_token_text (ft));
12828 ffebad_finish ();
12829 }
12830 break;
12831
12832 default:
12833 error = TRUE;
12834 break;
12835 }
12836 break;
12837
12838 case FFEEXPR_contextIMPDOITEM_:
12839 if (ffelex_token_type (t) == FFELEX_typeEQUALS)
12840 {
12841 ffeexpr_stack_->is_rhs = FALSE;
12842 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
12843 goto again; /* :::::::::::::::::::: */
12844 }
12845 /* Fall through. */
12846 case FFEEXPR_contextIOLIST:
12847 case FFEEXPR_contextFILEVXTCODE:
12848 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12849 : ffeinfo_basictype (info))
12850 {
12851 case FFEINFO_basictypeHOLLERITH:
12852 case FFEINFO_basictypeTYPELESS:
12853 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12854 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12855 FFEEXPR_contextLET);
12856 break;
12857
12858 default:
12859 break;
12860 }
12861 error = (expr == NULL)
12862 || ((ffeinfo_rank (info) != 0)
12863 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12864 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12865 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12866 == FFEBLD_opSTAR))); /* Bad if null expr, or if
12867 array that is not a SYMTER
12868 (can't happen yet, I
12869 think) or has a NULL or
12870 STAR (assumed) array
12871 size. */
12872 break;
12873
12874 case FFEEXPR_contextIMPDOITEMDF_:
12875 if (ffelex_token_type (t) == FFELEX_typeEQUALS)
12876 {
12877 ffeexpr_stack_->is_rhs = FALSE;
12878 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
12879 goto again; /* :::::::::::::::::::: */
12880 }
12881 /* Fall through. */
12882 case FFEEXPR_contextIOLISTDF:
12883 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12884 : ffeinfo_basictype (info))
12885 {
12886 case FFEINFO_basictypeHOLLERITH:
12887 case FFEINFO_basictypeTYPELESS:
12888 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12889 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12890 FFEEXPR_contextLET);
12891 break;
12892
12893 default:
12894 break;
12895 }
12896 error
12897 = (expr == NULL)
12898 || ((ffeinfo_basictype (info) == FFEINFO_basictypeCHARACTER)
12899 && (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT))
12900 || ((ffeinfo_rank (info) != 0)
12901 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12902 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12903 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12904 == FFEBLD_opSTAR))); /* Bad if null expr,
12905 non-default-kindtype
12906 character expr, or if
12907 array that is not a SYMTER
12908 (can't happen yet, I
12909 think) or has a NULL or
12910 STAR (assumed) array
12911 size. */
12912 break;
12913
12914 case FFEEXPR_contextDATAIMPDOITEM_:
12915 error = (expr == NULL)
12916 || (ffebld_op (expr) != FFEBLD_opARRAYREF)
12917 || ((ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR)
12918 && (ffeinfo_where (info) != FFEINFO_whereFLEETING_IADDR));
12919 break;
12920
12921 case FFEEXPR_contextDATAIMPDOINDEX_:
12922 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12923 break;
12924 switch (ffeinfo_basictype (info))
12925 {
12926 case FFEINFO_basictypeLOGICAL:
12927 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12928 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12929 FFEEXPR_contextLET);
12930 /* Fall through. */
12931 case FFEINFO_basictypeREAL:
12932 case FFEINFO_basictypeCOMPLEX:
12933 if (ffe_is_pedantic ())
12934 {
12935 error = TRUE;
12936 break;
12937 }
12938 /* Fall through. */
12939 case FFEINFO_basictypeINTEGER:
12940 case FFEINFO_basictypeHOLLERITH:
12941 case FFEINFO_basictypeTYPELESS:
12942 error = FALSE;
12943 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12944 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12945 FFEEXPR_contextLET);
12946 break;
12947
12948 default:
12949 error = TRUE;
12950 break;
12951 }
12952 if ((ffeinfo_where (info) != FFEINFO_whereCONSTANT)
12953 && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12954 error = TRUE;
12955 break;
12956
12957 case FFEEXPR_contextDATA:
12958 if (expr == NULL)
12959 error = TRUE;
12960 else if (ffeexpr_stack_->is_rhs)
12961 error = (ffebld_op (expr) != FFEBLD_opCONTER);
12962 else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12963 error = FALSE;
12964 else
12965 error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12966 break;
12967
12968 case FFEEXPR_contextINITVAL:
12969 error = (expr == NULL) || (ffebld_op (expr) != FFEBLD_opCONTER);
12970 break;
12971
12972 case FFEEXPR_contextEQUIVALENCE:
12973 if (expr == NULL)
12974 error = TRUE;
12975 else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12976 error = FALSE;
12977 else
12978 error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12979 break;
12980
12981 case FFEEXPR_contextFILEASSOC:
12982 case FFEEXPR_contextFILEINT:
12983 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12984 : ffeinfo_basictype (info))
12985 {
12986 case FFEINFO_basictypeINTEGER:
12987 error = FALSE;
12988 break;
12989
12990 default:
12991 error = TRUE;
12992 break;
12993 }
12994 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12995 error = TRUE;
12996 break;
12997
12998 case FFEEXPR_contextFILEDFINT:
12999 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13000 : ffeinfo_basictype (info))
13001 {
13002 case FFEINFO_basictypeINTEGER:
13003 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
13004 break;
13005
13006 default:
13007 error = TRUE;
13008 break;
13009 }
13010 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13011 error = TRUE;
13012 break;
13013
13014 case FFEEXPR_contextFILELOG:
13015 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13016 : ffeinfo_basictype (info))
13017 {
13018 case FFEINFO_basictypeLOGICAL:
13019 error = FALSE;
13020 break;
13021
13022 default:
13023 error = TRUE;
13024 break;
13025 }
13026 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13027 error = TRUE;
13028 break;
13029
13030 case FFEEXPR_contextFILECHAR:
13031 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13032 : ffeinfo_basictype (info))
13033 {
13034 case FFEINFO_basictypeCHARACTER:
13035 error = FALSE;
13036 break;
13037
13038 default:
13039 error = TRUE;
13040 break;
13041 }
13042 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13043 error = TRUE;
13044 break;
13045
13046 case FFEEXPR_contextFILENUMCHAR:
13047 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
13048 break;
13049 switch (ffeinfo_basictype (info))
13050 {
13051 case FFEINFO_basictypeLOGICAL:
13052 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13053 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13054 FFEEXPR_contextLET);
13055 /* Fall through. */
13056 case FFEINFO_basictypeREAL:
13057 case FFEINFO_basictypeCOMPLEX:
13058 if (ffe_is_pedantic ())
13059 {
13060 error = TRUE;
13061 break;
13062 }
13063 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13064 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13065 FFEEXPR_contextLET);
13066 break;
13067
13068 case FFEINFO_basictypeINTEGER:
13069 case FFEINFO_basictypeCHARACTER:
13070 error = FALSE;
13071 break;
13072
13073 default:
13074 error = TRUE;
13075 break;
13076 }
13077 break;
13078
13079 case FFEEXPR_contextFILEDFCHAR:
13080 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
13081 break;
13082 switch (ffeinfo_basictype (info))
13083 {
13084 case FFEINFO_basictypeCHARACTER:
13085 error
13086 = (ffeinfo_kindtype (info)
13087 != FFEINFO_kindtypeCHARACTERDEFAULT);
13088 break;
13089
13090 default:
13091 error = TRUE;
13092 break;
13093 }
13094 if (!ffeexpr_stack_->is_rhs
13095 && (ffebld_op (expr) == FFEBLD_opSUBSTR))
13096 error = TRUE;
13097 break;
13098
13099 case FFEEXPR_contextFILEUNIT: /* See equiv code in _ambig_. */
13100 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13101 : ffeinfo_basictype (info))
13102 {
13103 case FFEINFO_basictypeLOGICAL:
13104 if ((error = (ffeinfo_rank (info) != 0)))
13105 break;
13106 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13107 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13108 FFEEXPR_contextLET);
13109 /* Fall through. */
13110 case FFEINFO_basictypeREAL:
13111 case FFEINFO_basictypeCOMPLEX:
13112 if ((error = (ffeinfo_rank (info) != 0)))
13113 break;
13114 if (ffe_is_pedantic ())
13115 {
13116 error = TRUE;
13117 break;
13118 }
13119 /* Fall through. */
13120 case FFEINFO_basictypeINTEGER:
13121 case FFEINFO_basictypeHOLLERITH:
13122 case FFEINFO_basictypeTYPELESS:
13123 if ((error = (ffeinfo_rank (info) != 0)))
13124 break;
13125 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13126 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13127 FFEEXPR_contextLET);
13128 break;
13129
13130 case FFEINFO_basictypeCHARACTER:
13131 switch (ffebld_op (expr))
13132 { /* As if _lhs had been called instead of
13133 _rhs. */
13134 case FFEBLD_opSYMTER:
13135 error
13136 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
13137 break;
13138
13139 case FFEBLD_opSUBSTR:
13140 error = (ffeinfo_where (ffebld_info (expr))
13141 == FFEINFO_whereCONSTANT_SUBOBJECT);
13142 break;
13143
13144 case FFEBLD_opARRAYREF:
13145 error = FALSE;
13146 break;
13147
13148 default:
13149 error = TRUE;
13150 break;
13151 }
13152 if (!error
13153 && ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
13154 || ((ffeinfo_rank (info) != 0)
13155 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
13156 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
13157 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
13158 == FFEBLD_opSTAR))))) /* Bad if
13159 non-default-kindtype
13160 character expr, or if
13161 array that is not a SYMTER
13162 (can't happen yet, I
13163 think), or has a NULL or
13164 STAR (assumed) array
13165 size. */
13166 error = TRUE;
13167 break;
13168
13169 default:
13170 error = TRUE;
13171 break;
13172 }
13173 break;
13174
13175 case FFEEXPR_contextFILEFORMAT:
13176 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13177 : ffeinfo_basictype (info))
13178 {
13179 case FFEINFO_basictypeINTEGER:
13180 error = (expr == NULL)
13181 || ((ffeinfo_rank (info) != 0) ?
13182 ffe_is_pedantic () /* F77 C5. */
13183 : (ffeinfo_kindtype (info) != ffecom_label_kind ()))
13184 || (ffebld_op (expr) != FFEBLD_opSYMTER);
13185 break;
13186
13187 case FFEINFO_basictypeLOGICAL:
13188 case FFEINFO_basictypeREAL:
13189 case FFEINFO_basictypeCOMPLEX:
13190 /* F77 C5 -- must be an array of hollerith. */
13191 error
13192 = ffe_is_pedantic ()
13193 || (ffeinfo_rank (info) == 0);
13194 break;
13195
13196 case FFEINFO_basictypeCHARACTER:
13197 if ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
13198 || ((ffeinfo_rank (info) != 0)
13199 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
13200 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
13201 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
13202 == FFEBLD_opSTAR)))) /* Bad if
13203 non-default-kindtype
13204 character expr, or if
13205 array that is not a SYMTER
13206 (can't happen yet, I
13207 think), or has a NULL or
13208 STAR (assumed) array
13209 size. */
13210 error = TRUE;
13211 else
13212 error = FALSE;
13213 break;
13214
13215 default:
13216 error = TRUE;
13217 break;
13218 }
13219 break;
13220
13221 case FFEEXPR_contextLOC_:
13222 /* See also ffeintrin_check_loc_. */
13223 if ((expr == NULL)
13224 || (ffeinfo_kind (info) != FFEINFO_kindENTITY)
13225 || ((ffebld_op (expr) != FFEBLD_opSYMTER)
13226 && (ffebld_op (expr) != FFEBLD_opSUBSTR)
13227 && (ffebld_op (expr) != FFEBLD_opARRAYREF)))
13228 error = TRUE;
13229 break;
13230
13231 default:
13232 error = FALSE;
13233 break;
13234 }
13235
13236 if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
13237 {
13238 ffebad_start (FFEBAD_EXPR_WRONG);
13239 ffebad_here (0, ffelex_token_where_line (ft),
13240 ffelex_token_where_column (ft));
13241 ffebad_finish ();
13242 expr = ffebld_new_any ();
13243 ffebld_set_info (expr, ffeinfo_new_any ());
13244 }
13245
13246 callback = ffeexpr_stack_->callback;
13247 s = ffeexpr_stack_->previous;
13248 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
13249 sizeof (*ffeexpr_stack_));
13250 ffeexpr_stack_ = s;
13251 next = (ffelexHandler) (*callback) (ft, expr, t);
13252 ffelex_token_kill (ft);
13253 return (ffelexHandler) next;
13254 }
13255
13256 /* ffeexpr_finished_ambig_ -- Check validity of ambiguous unit/form spec
13257
13258 ffebld expr;
13259 expr = ffeexpr_finished_ambig_(expr);
13260
13261 Replicates a bit of ffeexpr_finished_'s task when in a context
13262 of UNIT or FORMAT. */
13263
13264 static ffebld
13265 ffeexpr_finished_ambig_ (ffelexToken ft, ffebld expr)
13266 {
13267 ffeinfo info = ffebld_info (expr);
13268 bool error;
13269
13270 switch (ffeexpr_stack_->context)
13271 {
13272 case FFEEXPR_contextFILENUMAMBIG: /* Same as FILENUM in _finished_. */
13273 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13274 : ffeinfo_basictype (info))
13275 {
13276 case FFEINFO_basictypeLOGICAL:
13277 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13278 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13279 FFEEXPR_contextLET);
13280 /* Fall through. */
13281 case FFEINFO_basictypeREAL:
13282 case FFEINFO_basictypeCOMPLEX:
13283 if (ffe_is_pedantic ())
13284 {
13285 error = TRUE;
13286 break;
13287 }
13288 /* Fall through. */
13289 case FFEINFO_basictypeINTEGER:
13290 case FFEINFO_basictypeHOLLERITH:
13291 case FFEINFO_basictypeTYPELESS:
13292 error = FALSE;
13293 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13294 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13295 FFEEXPR_contextLET);
13296 break;
13297
13298 default:
13299 error = TRUE;
13300 break;
13301 }
13302 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13303 error = TRUE;
13304 break;
13305
13306 case FFEEXPR_contextFILEUNITAMBIG: /* Same as FILEUNIT in _finished_. */
13307 if ((expr != NULL) && (ffebld_op (expr) == FFEBLD_opSTAR))
13308 {
13309 error = FALSE;
13310 break;
13311 }
13312 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13313 : ffeinfo_basictype (info))
13314 {
13315 case FFEINFO_basictypeLOGICAL:
13316 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13317 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13318 FFEEXPR_contextLET);
13319 /* Fall through. */
13320 case FFEINFO_basictypeREAL:
13321 case FFEINFO_basictypeCOMPLEX:
13322 if (ffe_is_pedantic ())
13323 {
13324 error = TRUE;
13325 break;
13326 }
13327 /* Fall through. */
13328 case FFEINFO_basictypeINTEGER:
13329 case FFEINFO_basictypeHOLLERITH:
13330 case FFEINFO_basictypeTYPELESS:
13331 error = (ffeinfo_rank (info) != 0);
13332 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13333 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13334 FFEEXPR_contextLET);
13335 break;
13336
13337 case FFEINFO_basictypeCHARACTER:
13338 switch (ffebld_op (expr))
13339 { /* As if _lhs had been called instead of
13340 _rhs. */
13341 case FFEBLD_opSYMTER:
13342 error
13343 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
13344 break;
13345
13346 case FFEBLD_opSUBSTR:
13347 error = (ffeinfo_where (ffebld_info (expr))
13348 == FFEINFO_whereCONSTANT_SUBOBJECT);
13349 break;
13350
13351 case FFEBLD_opARRAYREF:
13352 error = FALSE;
13353 break;
13354
13355 default:
13356 error = TRUE;
13357 break;
13358 }
13359 break;
13360
13361 default:
13362 error = TRUE;
13363 break;
13364 }
13365 break;
13366
13367 default:
13368 assert ("bad context" == NULL);
13369 error = TRUE;
13370 break;
13371 }
13372
13373 if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
13374 {
13375 ffebad_start (FFEBAD_EXPR_WRONG);
13376 ffebad_here (0, ffelex_token_where_line (ft),
13377 ffelex_token_where_column (ft));
13378 ffebad_finish ();
13379 expr = ffebld_new_any ();
13380 ffebld_set_info (expr, ffeinfo_new_any ());
13381 }
13382
13383 return expr;
13384 }
13385
13386 /* ffeexpr_token_lhs_ -- Initial state for lhs expression
13387
13388 Return a pointer to this function to the lexer (ffelex), which will
13389 invoke it for the next token.
13390
13391 Basically a smaller version of _rhs_; keep them both in sync, of course. */
13392
13393 static ffelexHandler
13394 ffeexpr_token_lhs_ (ffelexToken t)
13395 {
13396
13397 /* When changing the list of valid initial lhs tokens, check whether to
13398 update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
13399 READ (expr) <token> case -- it assumes it knows which tokens <token> can
13400 be to indicate an lhs (or implied DO), which right now is the set
13401 {NAME,OPEN_PAREN}.
13402
13403 This comment also appears in ffeexpr_token_first_lhs_. */
13404
13405 switch (ffelex_token_type (t))
13406 {
13407 case FFELEX_typeNAME:
13408 case FFELEX_typeNAMES:
13409 ffeexpr_tokens_[0] = ffelex_token_use (t);
13410 return (ffelexHandler) ffeexpr_token_name_lhs_;
13411
13412 default:
13413 return (ffelexHandler) ffeexpr_finished_ (t);
13414 }
13415 }
13416
13417 /* ffeexpr_token_rhs_ -- Initial state for rhs expression
13418
13419 Return a pointer to this function to the lexer (ffelex), which will
13420 invoke it for the next token.
13421
13422 The initial state and the post-binary-operator state are the same and
13423 both handled here, with the expression stack used to distinguish
13424 between them. Binary operators are invalid here; unary operators,
13425 constants, subexpressions, and name references are valid. */
13426
13427 static ffelexHandler
13428 ffeexpr_token_rhs_ (ffelexToken t)
13429 {
13430 ffeexprExpr_ e;
13431
13432 switch (ffelex_token_type (t))
13433 {
13434 case FFELEX_typeQUOTE:
13435 if (ffe_is_vxt ())
13436 {
13437 ffeexpr_tokens_[0] = ffelex_token_use (t);
13438 return (ffelexHandler) ffeexpr_token_quote_;
13439 }
13440 ffeexpr_tokens_[0] = ffelex_token_use (t);
13441 ffelex_set_expecting_hollerith (-1, '\"',
13442 ffelex_token_where_line (t),
13443 ffelex_token_where_column (t));
13444 /* Don't have to unset this one. */
13445 return (ffelexHandler) ffeexpr_token_apostrophe_;
13446
13447 case FFELEX_typeAPOSTROPHE:
13448 ffeexpr_tokens_[0] = ffelex_token_use (t);
13449 ffelex_set_expecting_hollerith (-1, '\'',
13450 ffelex_token_where_line (t),
13451 ffelex_token_where_column (t));
13452 /* Don't have to unset this one. */
13453 return (ffelexHandler) ffeexpr_token_apostrophe_;
13454
13455 case FFELEX_typePERCENT:
13456 ffeexpr_tokens_[0] = ffelex_token_use (t);
13457 return (ffelexHandler) ffeexpr_token_percent_;
13458
13459 case FFELEX_typeOPEN_PAREN:
13460 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
13461 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
13462 FFEEXPR_contextPAREN_,
13463 ffeexpr_cb_close_paren_c_);
13464
13465 case FFELEX_typePLUS:
13466 e = ffeexpr_expr_new_ ();
13467 e->type = FFEEXPR_exprtypeUNARY_;
13468 e->token = ffelex_token_use (t);
13469 e->u.operator.op = FFEEXPR_operatorADD_;
13470 e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
13471 e->u.operator.as = FFEEXPR_operatorassociativityADD_;
13472 ffeexpr_exprstack_push_unary_ (e);
13473 return (ffelexHandler) ffeexpr_token_rhs_;
13474
13475 case FFELEX_typeMINUS:
13476 e = ffeexpr_expr_new_ ();
13477 e->type = FFEEXPR_exprtypeUNARY_;
13478 e->token = ffelex_token_use (t);
13479 e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
13480 e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
13481 e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
13482 ffeexpr_exprstack_push_unary_ (e);
13483 return (ffelexHandler) ffeexpr_token_rhs_;
13484
13485 case FFELEX_typePERIOD:
13486 ffeexpr_tokens_[0] = ffelex_token_use (t);
13487 return (ffelexHandler) ffeexpr_token_period_;
13488
13489 case FFELEX_typeNUMBER:
13490 ffeexpr_tokens_[0] = ffelex_token_use (t);
13491 ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
13492 if (ffeexpr_hollerith_count_ > 0)
13493 ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
13494 '\0',
13495 ffelex_token_where_line (t),
13496 ffelex_token_where_column (t));
13497 return (ffelexHandler) ffeexpr_token_number_;
13498
13499 case FFELEX_typeNAME:
13500 case FFELEX_typeNAMES:
13501 ffeexpr_tokens_[0] = ffelex_token_use (t);
13502 switch (ffeexpr_stack_->context)
13503 {
13504 case FFEEXPR_contextACTUALARG_:
13505 case FFEEXPR_contextINDEXORACTUALARG_:
13506 case FFEEXPR_contextSFUNCDEFACTUALARG_:
13507 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
13508 return (ffelexHandler) ffeexpr_token_name_arg_;
13509
13510 default:
13511 return (ffelexHandler) ffeexpr_token_name_rhs_;
13512 }
13513
13514 case FFELEX_typeASTERISK:
13515 case FFELEX_typeSLASH:
13516 case FFELEX_typePOWER:
13517 case FFELEX_typeCONCAT:
13518 case FFELEX_typeREL_EQ:
13519 case FFELEX_typeREL_NE:
13520 case FFELEX_typeREL_LE:
13521 case FFELEX_typeREL_GE:
13522 if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
13523 {
13524 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13525 ffebad_finish ();
13526 }
13527 return (ffelexHandler) ffeexpr_token_rhs_;
13528
13529 #if 0
13530 case FFELEX_typeEQUALS:
13531 case FFELEX_typePOINTS:
13532 case FFELEX_typeCLOSE_ANGLE:
13533 case FFELEX_typeCLOSE_PAREN:
13534 case FFELEX_typeCOMMA:
13535 case FFELEX_typeCOLON:
13536 case FFELEX_typeEOS:
13537 case FFELEX_typeSEMICOLON:
13538 #endif
13539 default:
13540 return (ffelexHandler) ffeexpr_finished_ (t);
13541 }
13542 }
13543
13544 /* ffeexpr_token_period_ -- Rhs PERIOD
13545
13546 Return a pointer to this function to the lexer (ffelex), which will
13547 invoke it for the next token.
13548
13549 Handle a period detected at rhs (expecting unary op or operand) state.
13550 Must begin a floating-point value (as in .12) or a dot-dot name, of
13551 which only .NOT., .TRUE., and .FALSE. are truly valid. Other sort-of-
13552 valid names represent binary operators, which are invalid here because
13553 there isn't an operand at the top of the stack. */
13554
13555 static ffelexHandler
13556 ffeexpr_token_period_ (ffelexToken t)
13557 {
13558 switch (ffelex_token_type (t))
13559 {
13560 case FFELEX_typeNAME:
13561 case FFELEX_typeNAMES:
13562 ffeexpr_current_dotdot_ = ffeexpr_dotdot_ (t);
13563 switch (ffeexpr_current_dotdot_)
13564 {
13565 case FFEEXPR_dotdotNONE_:
13566 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
13567 {
13568 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13569 ffelex_token_where_column (ffeexpr_tokens_[0]));
13570 ffebad_finish ();
13571 }
13572 ffelex_token_kill (ffeexpr_tokens_[0]);
13573 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13574
13575 case FFEEXPR_dotdotTRUE_:
13576 case FFEEXPR_dotdotFALSE_:
13577 case FFEEXPR_dotdotNOT_:
13578 ffeexpr_tokens_[1] = ffelex_token_use (t);
13579 return (ffelexHandler) ffeexpr_token_end_period_;
13580
13581 default:
13582 if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
13583 {
13584 ffebad_here (0, ffelex_token_where_line (t),
13585 ffelex_token_where_column (t));
13586 ffebad_finish ();
13587 }
13588 ffelex_token_kill (ffeexpr_tokens_[0]);
13589 return (ffelexHandler) ffeexpr_token_swallow_period_;
13590 }
13591 break; /* Nothing really reaches here. */
13592
13593 case FFELEX_typeNUMBER:
13594 ffeexpr_tokens_[1] = ffelex_token_use (t);
13595 return (ffelexHandler) ffeexpr_token_real_;
13596
13597 default:
13598 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
13599 {
13600 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13601 ffelex_token_where_column (ffeexpr_tokens_[0]));
13602 ffebad_finish ();
13603 }
13604 ffelex_token_kill (ffeexpr_tokens_[0]);
13605 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13606 }
13607 }
13608
13609 /* ffeexpr_token_end_period_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
13610
13611 Return a pointer to this function to the lexer (ffelex), which will
13612 invoke it for the next token.
13613
13614 Expecting a period to close a .NOT, .TRUE, or .FALSE at rhs (unary op
13615 or operator) state. If period isn't found, issue a diagnostic but
13616 pretend we saw one. ffeexpr_current_dotdot_ must already contained the
13617 dotdot representation of the name in between the two PERIOD tokens. */
13618
13619 static ffelexHandler
13620 ffeexpr_token_end_period_ (ffelexToken t)
13621 {
13622 ffeexprExpr_ e;
13623
13624 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13625 {
13626 if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
13627 {
13628 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13629 ffelex_token_where_column (ffeexpr_tokens_[0]));
13630 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13631 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
13632 ffebad_finish ();
13633 }
13634 }
13635
13636 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill "NOT"/"TRUE"/"FALSE"
13637 token. */
13638
13639 e = ffeexpr_expr_new_ ();
13640 e->token = ffeexpr_tokens_[0];
13641
13642 switch (ffeexpr_current_dotdot_)
13643 {
13644 case FFEEXPR_dotdotNOT_:
13645 e->type = FFEEXPR_exprtypeUNARY_;
13646 e->u.operator.op = FFEEXPR_operatorNOT_;
13647 e->u.operator.prec = FFEEXPR_operatorprecedenceNOT_;
13648 e->u.operator.as = FFEEXPR_operatorassociativityNOT_;
13649 ffeexpr_exprstack_push_unary_ (e);
13650 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13651 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13652 return (ffelexHandler) ffeexpr_token_rhs_;
13653
13654 case FFEEXPR_dotdotTRUE_:
13655 e->type = FFEEXPR_exprtypeOPERAND_;
13656 e->u.operand
13657 = ffebld_new_conter (ffebld_constant_new_logicaldefault (TRUE));
13658 ffebld_set_info (e->u.operand,
13659 ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
13660 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13661 ffeexpr_exprstack_push_operand_ (e);
13662 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13663 return (ffelexHandler) ffeexpr_token_binary_ (t);
13664 return (ffelexHandler) ffeexpr_token_binary_;
13665
13666 case FFEEXPR_dotdotFALSE_:
13667 e->type = FFEEXPR_exprtypeOPERAND_;
13668 e->u.operand
13669 = ffebld_new_conter (ffebld_constant_new_logicaldefault (FALSE));
13670 ffebld_set_info (e->u.operand,
13671 ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
13672 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13673 ffeexpr_exprstack_push_operand_ (e);
13674 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13675 return (ffelexHandler) ffeexpr_token_binary_ (t);
13676 return (ffelexHandler) ffeexpr_token_binary_;
13677
13678 default:
13679 assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL);
13680 exit (0);
13681 return NULL;
13682 }
13683 }
13684
13685 /* ffeexpr_token_swallow_period_ -- Rhs PERIOD NAME(not NOT, TRUE, or FALSE)
13686
13687 Return a pointer to this function to the lexer (ffelex), which will
13688 invoke it for the next token.
13689
13690 A diagnostic has already been issued; just swallow a period if there is
13691 one, then continue with ffeexpr_token_rhs_. */
13692
13693 static ffelexHandler
13694 ffeexpr_token_swallow_period_ (ffelexToken t)
13695 {
13696 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13697 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13698
13699 return (ffelexHandler) ffeexpr_token_rhs_;
13700 }
13701
13702 /* ffeexpr_token_real_ -- Rhs PERIOD NUMBER
13703
13704 Return a pointer to this function to the lexer (ffelex), which will
13705 invoke it for the next token.
13706
13707 After a period and a string of digits, check next token for possible
13708 exponent designation (D, E, or Q as first/only character) and continue
13709 real-number handling accordingly. Else form basic real constant, push
13710 onto expression stack, and enter binary state using current token (which,
13711 if it is a name not beginning with D, E, or Q, will certainly result
13712 in an error, but that's not for this routine to deal with). */
13713
13714 static ffelexHandler
13715 ffeexpr_token_real_ (ffelexToken t)
13716 {
13717 char d;
13718 char *p;
13719
13720 if (((ffelex_token_type (t) != FFELEX_typeNAME)
13721 && (ffelex_token_type (t) != FFELEX_typeNAMES))
13722 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13723 'D', 'd')
13724 || ffesrc_char_match_init (d, 'E', 'e')
13725 || ffesrc_char_match_init (d, 'Q', 'q')))
13726 && ffeexpr_isdigits_ (++p)))
13727 {
13728 #if 0
13729 /* This code has been removed because it seems inconsistent to
13730 produce a diagnostic in this case, but not all of the other
13731 ones that look for an exponent and cannot recognize one. */
13732 if (((ffelex_token_type (t) == FFELEX_typeNAME)
13733 || (ffelex_token_type (t) == FFELEX_typeNAMES))
13734 && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
13735 {
13736 char bad[2];
13737
13738 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13739 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
13740 ffelex_token_where_column (ffeexpr_tokens_[0]));
13741 bad[0] = *(p - 1);
13742 bad[1] = '\0';
13743 ffebad_string (bad);
13744 ffebad_finish ();
13745 }
13746 #endif
13747 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13748 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13749 NULL, NULL, NULL);
13750
13751 ffelex_token_kill (ffeexpr_tokens_[0]);
13752 ffelex_token_kill (ffeexpr_tokens_[1]);
13753 return (ffelexHandler) ffeexpr_token_binary_ (t);
13754 }
13755
13756 /* Just exponent character by itself? In which case, PLUS or MINUS must
13757 surely be next, followed by a NUMBER token. */
13758
13759 if (*p == '\0')
13760 {
13761 ffeexpr_tokens_[2] = ffelex_token_use (t);
13762 return (ffelexHandler) ffeexpr_token_real_exponent_;
13763 }
13764
13765 ffeexpr_make_float_const_ (d, NULL, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13766 t, NULL, NULL);
13767
13768 ffelex_token_kill (ffeexpr_tokens_[0]);
13769 ffelex_token_kill (ffeexpr_tokens_[1]);
13770 return (ffelexHandler) ffeexpr_token_binary_;
13771 }
13772
13773 /* ffeexpr_token_real_exponent_ -- Rhs PERIOD NUMBER NAME(D, E, or Q)
13774
13775 Return a pointer to this function to the lexer (ffelex), which will
13776 invoke it for the next token.
13777
13778 Ensures this token is PLUS or MINUS, preserves it, goes to final state
13779 for real number (exponent digits). Else issues diagnostic, assumes a
13780 zero exponent field for number, passes token on to binary state as if
13781 previous token had been "E0" instead of "E", for example. */
13782
13783 static ffelexHandler
13784 ffeexpr_token_real_exponent_ (ffelexToken t)
13785 {
13786 if ((ffelex_token_type (t) != FFELEX_typePLUS)
13787 && (ffelex_token_type (t) != FFELEX_typeMINUS))
13788 {
13789 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13790 {
13791 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
13792 ffelex_token_where_column (ffeexpr_tokens_[2]));
13793 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13794 ffebad_finish ();
13795 }
13796
13797 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13798 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13799 NULL, NULL, NULL);
13800
13801 ffelex_token_kill (ffeexpr_tokens_[0]);
13802 ffelex_token_kill (ffeexpr_tokens_[1]);
13803 ffelex_token_kill (ffeexpr_tokens_[2]);
13804 return (ffelexHandler) ffeexpr_token_binary_ (t);
13805 }
13806
13807 ffeexpr_tokens_[3] = ffelex_token_use (t);
13808 return (ffelexHandler) ffeexpr_token_real_exp_sign_;
13809 }
13810
13811 /* ffeexpr_token_real_exp_sign_ -- Rhs PERIOD NUMBER NAME(D,E,Q) PLUS/MINUS
13812
13813 Return a pointer to this function to the lexer (ffelex), which will
13814 invoke it for the next token.
13815
13816 Make sure token is a NUMBER, make a real constant out of all we have and
13817 push it onto the expression stack. Else issue diagnostic and pretend
13818 exponent field was a zero. */
13819
13820 static ffelexHandler
13821 ffeexpr_token_real_exp_sign_ (ffelexToken t)
13822 {
13823 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13824 {
13825 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13826 {
13827 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
13828 ffelex_token_where_column (ffeexpr_tokens_[2]));
13829 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13830 ffebad_finish ();
13831 }
13832
13833 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13834 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13835 NULL, NULL, NULL);
13836
13837 ffelex_token_kill (ffeexpr_tokens_[0]);
13838 ffelex_token_kill (ffeexpr_tokens_[1]);
13839 ffelex_token_kill (ffeexpr_tokens_[2]);
13840 ffelex_token_kill (ffeexpr_tokens_[3]);
13841 return (ffelexHandler) ffeexpr_token_binary_ (t);
13842 }
13843
13844 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0], NULL,
13845 ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2],
13846 ffeexpr_tokens_[3], t);
13847
13848 ffelex_token_kill (ffeexpr_tokens_[0]);
13849 ffelex_token_kill (ffeexpr_tokens_[1]);
13850 ffelex_token_kill (ffeexpr_tokens_[2]);
13851 ffelex_token_kill (ffeexpr_tokens_[3]);
13852 return (ffelexHandler) ffeexpr_token_binary_;
13853 }
13854
13855 /* ffeexpr_token_number_ -- Rhs NUMBER
13856
13857 Return a pointer to this function to the lexer (ffelex), which will
13858 invoke it for the next token.
13859
13860 If the token is a period, we may have a floating-point number, or an
13861 integer followed by a dotdot binary operator. If the token is a name
13862 beginning with D, E, or Q, we definitely have a floating-point number.
13863 If the token is a hollerith constant, that's what we've got, so push
13864 it onto the expression stack and continue with the binary state.
13865
13866 Otherwise, we have an integer followed by something the binary state
13867 should be able to swallow. */
13868
13869 static ffelexHandler
13870 ffeexpr_token_number_ (ffelexToken t)
13871 {
13872 ffeexprExpr_ e;
13873 ffeinfo ni;
13874 char d;
13875 char *p;
13876
13877 if (ffeexpr_hollerith_count_ > 0)
13878 ffelex_set_expecting_hollerith (0, '\0',
13879 ffewhere_line_unknown (),
13880 ffewhere_column_unknown ());
13881
13882 /* See if we've got a floating-point number here. */
13883
13884 switch (ffelex_token_type (t))
13885 {
13886 case FFELEX_typeNAME:
13887 case FFELEX_typeNAMES:
13888 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13889 'D', 'd')
13890 || ffesrc_char_match_init (d, 'E', 'e')
13891 || ffesrc_char_match_init (d, 'Q', 'q'))
13892 && ffeexpr_isdigits_ (++p))
13893 {
13894
13895 /* Just exponent character by itself? In which case, PLUS or MINUS
13896 must surely be next, followed by a NUMBER token. */
13897
13898 if (*p == '\0')
13899 {
13900 ffeexpr_tokens_[1] = ffelex_token_use (t);
13901 return (ffelexHandler) ffeexpr_token_number_exponent_;
13902 }
13903 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], NULL, NULL, t,
13904 NULL, NULL);
13905
13906 ffelex_token_kill (ffeexpr_tokens_[0]);
13907 return (ffelexHandler) ffeexpr_token_binary_;
13908 }
13909 break;
13910
13911 case FFELEX_typePERIOD:
13912 ffeexpr_tokens_[1] = ffelex_token_use (t);
13913 return (ffelexHandler) ffeexpr_token_number_period_;
13914
13915 case FFELEX_typeHOLLERITH:
13916 e = ffeexpr_expr_new_ ();
13917 e->type = FFEEXPR_exprtypeOPERAND_;
13918 e->token = ffeexpr_tokens_[0];
13919 e->u.operand = ffebld_new_conter (ffebld_constant_new_hollerith (t));
13920 ni = ffeinfo_new (FFEINFO_basictypeHOLLERITH, FFEINFO_kindtypeNONE,
13921 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
13922 ffelex_token_length (t));
13923 ffebld_set_info (e->u.operand, ni);
13924 ffeexpr_exprstack_push_operand_ (e);
13925 return (ffelexHandler) ffeexpr_token_binary_;
13926
13927 default:
13928 break;
13929 }
13930
13931 /* Nothing specific we were looking for, so make an integer and pass the
13932 current token to the binary state. */
13933
13934 e = ffeexpr_expr_new_ ();
13935 e->type = FFEEXPR_exprtypeOPERAND_;
13936 e->token = ffeexpr_tokens_[0];
13937 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
13938 (ffeexpr_tokens_[0]));
13939 ffebld_set_info (e->u.operand,
13940 ffeinfo_new (FFEINFO_basictypeINTEGER,
13941 FFEINFO_kindtypeINTEGERDEFAULT, 0,
13942 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
13943 FFETARGET_charactersizeNONE));
13944 ffeexpr_exprstack_push_operand_ (e);
13945 return (ffelexHandler) ffeexpr_token_binary_ (t);
13946 }
13947
13948 /* ffeexpr_token_number_exponent_ -- Rhs NUMBER NAME(D, E, or Q)
13949
13950 Return a pointer to this function to the lexer (ffelex), which will
13951 invoke it for the next token.
13952
13953 Ensures this token is PLUS or MINUS, preserves it, goes to final state
13954 for real number (exponent digits). Else treats number as integer, passes
13955 name to binary, passes current token to subsequent handler. */
13956
13957 static ffelexHandler
13958 ffeexpr_token_number_exponent_ (ffelexToken t)
13959 {
13960 if ((ffelex_token_type (t) != FFELEX_typePLUS)
13961 && (ffelex_token_type (t) != FFELEX_typeMINUS))
13962 {
13963 ffeexprExpr_ e;
13964 ffelexHandler nexthandler;
13965
13966 e = ffeexpr_expr_new_ ();
13967 e->type = FFEEXPR_exprtypeOPERAND_;
13968 e->token = ffeexpr_tokens_[0];
13969 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
13970 (ffeexpr_tokens_[0]));
13971 ffebld_set_info (e->u.operand,
13972 ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT,
13973 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13974 ffeexpr_exprstack_push_operand_ (e);
13975 nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[1]);
13976 ffelex_token_kill (ffeexpr_tokens_[1]);
13977 return (ffelexHandler) (*nexthandler) (t);
13978 }
13979
13980 ffeexpr_tokens_[2] = ffelex_token_use (t);
13981 return (ffelexHandler) ffeexpr_token_number_exp_sign_;
13982 }
13983
13984 /* ffeexpr_token_number_exp_sign_ -- Rhs NUMBER NAME(D,E,Q) PLUS/MINUS
13985
13986 Return a pointer to this function to the lexer (ffelex), which will
13987 invoke it for the next token.
13988
13989 Make sure token is a NUMBER, make a real constant out of all we have and
13990 push it onto the expression stack. Else issue diagnostic and pretend
13991 exponent field was a zero. */
13992
13993 static ffelexHandler
13994 ffeexpr_token_number_exp_sign_ (ffelexToken t)
13995 {
13996 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13997 {
13998 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13999 {
14000 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[1]),
14001 ffelex_token_where_column (ffeexpr_tokens_[1]));
14002 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14003 ffebad_finish ();
14004 }
14005
14006 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
14007 ffeexpr_tokens_[0], NULL, NULL,
14008 ffeexpr_tokens_[1], ffeexpr_tokens_[2],
14009 NULL);
14010
14011 ffelex_token_kill (ffeexpr_tokens_[0]);
14012 ffelex_token_kill (ffeexpr_tokens_[1]);
14013 ffelex_token_kill (ffeexpr_tokens_[2]);
14014 return (ffelexHandler) ffeexpr_token_binary_ (t);
14015 }
14016
14017 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
14018 ffeexpr_tokens_[0], NULL, NULL,
14019 ffeexpr_tokens_[1], ffeexpr_tokens_[2], t);
14020
14021 ffelex_token_kill (ffeexpr_tokens_[0]);
14022 ffelex_token_kill (ffeexpr_tokens_[1]);
14023 ffelex_token_kill (ffeexpr_tokens_[2]);
14024 return (ffelexHandler) ffeexpr_token_binary_;
14025 }
14026
14027 /* ffeexpr_token_number_period_ -- Rhs NUMBER PERIOD
14028
14029 Return a pointer to this function to the lexer (ffelex), which will
14030 invoke it for the next token.
14031
14032 Handle a period detected following a number at rhs state. Must begin a
14033 floating-point value (as in 1., 1.2, 1.E3, or 1.E+3) or a dot-dot name. */
14034
14035 static ffelexHandler
14036 ffeexpr_token_number_period_ (ffelexToken t)
14037 {
14038 ffeexprExpr_ e;
14039 ffelexHandler nexthandler;
14040 char *p;
14041 char d;
14042
14043 switch (ffelex_token_type (t))
14044 {
14045 case FFELEX_typeNAME:
14046 case FFELEX_typeNAMES:
14047 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
14048 'D', 'd')
14049 || ffesrc_char_match_init (d, 'E', 'e')
14050 || ffesrc_char_match_init (d, 'Q', 'q'))
14051 && ffeexpr_isdigits_ (++p))
14052 {
14053
14054 /* Just exponent character by itself? In which case, PLUS or MINUS
14055 must surely be next, followed by a NUMBER token. */
14056
14057 if (*p == '\0')
14058 {
14059 ffeexpr_tokens_[2] = ffelex_token_use (t);
14060 return (ffelexHandler) ffeexpr_token_number_per_exp_;
14061 }
14062 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0],
14063 ffeexpr_tokens_[1], NULL, t, NULL,
14064 NULL);
14065
14066 ffelex_token_kill (ffeexpr_tokens_[0]);
14067 ffelex_token_kill (ffeexpr_tokens_[1]);
14068 return (ffelexHandler) ffeexpr_token_binary_;
14069 }
14070 /* A name not representing an exponent, so assume it will be something
14071 like EQ, make an integer from the number, pass the period to binary
14072 state and the current token to the resulting state. */
14073
14074 e = ffeexpr_expr_new_ ();
14075 e->type = FFEEXPR_exprtypeOPERAND_;
14076 e->token = ffeexpr_tokens_[0];
14077 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
14078 (ffeexpr_tokens_[0]));
14079 ffebld_set_info (e->u.operand,
14080 ffeinfo_new (FFEINFO_basictypeINTEGER,
14081 FFEINFO_kindtypeINTEGERDEFAULT, 0,
14082 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14083 FFETARGET_charactersizeNONE));
14084 ffeexpr_exprstack_push_operand_ (e);
14085 nexthandler = (ffelexHandler) ffeexpr_token_binary_
14086 (ffeexpr_tokens_[1]);
14087 ffelex_token_kill (ffeexpr_tokens_[1]);
14088 return (ffelexHandler) (*nexthandler) (t);
14089
14090 case FFELEX_typeNUMBER:
14091 ffeexpr_tokens_[2] = ffelex_token_use (t);
14092 return (ffelexHandler) ffeexpr_token_number_real_;
14093
14094 default:
14095 break;
14096 }
14097
14098 /* Nothing specific we were looking for, so make a real number and pass the
14099 period and then the current token to the binary state. */
14100
14101 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14102 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14103 NULL, NULL, NULL, NULL);
14104
14105 ffelex_token_kill (ffeexpr_tokens_[0]);
14106 ffelex_token_kill (ffeexpr_tokens_[1]);
14107 return (ffelexHandler) ffeexpr_token_binary_ (t);
14108 }
14109
14110 /* ffeexpr_token_number_per_exp_ -- Rhs NUMBER PERIOD NAME(D, E, or Q)
14111
14112 Return a pointer to this function to the lexer (ffelex), which will
14113 invoke it for the next token.
14114
14115 Ensures this token is PLUS or MINUS, preserves it, goes to final state
14116 for real number (exponent digits). Else treats number as real, passes
14117 name to binary, passes current token to subsequent handler. */
14118
14119 static ffelexHandler
14120 ffeexpr_token_number_per_exp_ (ffelexToken t)
14121 {
14122 if ((ffelex_token_type (t) != FFELEX_typePLUS)
14123 && (ffelex_token_type (t) != FFELEX_typeMINUS))
14124 {
14125 ffelexHandler nexthandler;
14126
14127 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14128 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14129 NULL, NULL, NULL, NULL);
14130
14131 ffelex_token_kill (ffeexpr_tokens_[0]);
14132 ffelex_token_kill (ffeexpr_tokens_[1]);
14133 nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[2]);
14134 ffelex_token_kill (ffeexpr_tokens_[2]);
14135 return (ffelexHandler) (*nexthandler) (t);
14136 }
14137
14138 ffeexpr_tokens_[3] = ffelex_token_use (t);
14139 return (ffelexHandler) ffeexpr_token_num_per_exp_sign_;
14140 }
14141
14142 /* ffeexpr_token_number_real_ -- Rhs NUMBER PERIOD NUMBER
14143
14144 Return a pointer to this function to the lexer (ffelex), which will
14145 invoke it for the next token.
14146
14147 After a number, period, and number, check next token for possible
14148 exponent designation (D, E, or Q as first/only character) and continue
14149 real-number handling accordingly. Else form basic real constant, push
14150 onto expression stack, and enter binary state using current token (which,
14151 if it is a name not beginning with D, E, or Q, will certainly result
14152 in an error, but that's not for this routine to deal with). */
14153
14154 static ffelexHandler
14155 ffeexpr_token_number_real_ (ffelexToken t)
14156 {
14157 char d;
14158 char *p;
14159
14160 if (((ffelex_token_type (t) != FFELEX_typeNAME)
14161 && (ffelex_token_type (t) != FFELEX_typeNAMES))
14162 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
14163 'D', 'd')
14164 || ffesrc_char_match_init (d, 'E', 'e')
14165 || ffesrc_char_match_init (d, 'Q', 'q')))
14166 && ffeexpr_isdigits_ (++p)))
14167 {
14168 #if 0
14169 /* This code has been removed because it seems inconsistent to
14170 produce a diagnostic in this case, but not all of the other
14171 ones that look for an exponent and cannot recognize one. */
14172 if (((ffelex_token_type (t) == FFELEX_typeNAME)
14173 || (ffelex_token_type (t) == FFELEX_typeNAMES))
14174 && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
14175 {
14176 char bad[2];
14177
14178 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14179 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
14180 ffelex_token_where_column (ffeexpr_tokens_[0]));
14181 bad[0] = *(p - 1);
14182 bad[1] = '\0';
14183 ffebad_string (bad);
14184 ffebad_finish ();
14185 }
14186 #endif
14187 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14188 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14189 ffeexpr_tokens_[2], NULL, NULL, NULL);
14190
14191 ffelex_token_kill (ffeexpr_tokens_[0]);
14192 ffelex_token_kill (ffeexpr_tokens_[1]);
14193 ffelex_token_kill (ffeexpr_tokens_[2]);
14194 return (ffelexHandler) ffeexpr_token_binary_ (t);
14195 }
14196
14197 /* Just exponent character by itself? In which case, PLUS or MINUS must
14198 surely be next, followed by a NUMBER token. */
14199
14200 if (*p == '\0')
14201 {
14202 ffeexpr_tokens_[3] = ffelex_token_use (t);
14203 return (ffelexHandler) ffeexpr_token_number_real_exp_;
14204 }
14205
14206 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14207 ffeexpr_tokens_[2], t, NULL, NULL);
14208
14209 ffelex_token_kill (ffeexpr_tokens_[0]);
14210 ffelex_token_kill (ffeexpr_tokens_[1]);
14211 ffelex_token_kill (ffeexpr_tokens_[2]);
14212 return (ffelexHandler) ffeexpr_token_binary_;
14213 }
14214
14215 /* ffeexpr_token_num_per_exp_sign_ -- Rhs NUMBER PERIOD NAME(D,E,Q) PLUS/MINUS
14216
14217 Return a pointer to this function to the lexer (ffelex), which will
14218 invoke it for the next token.
14219
14220 Make sure token is a NUMBER, make a real constant out of all we have and
14221 push it onto the expression stack. Else issue diagnostic and pretend
14222 exponent field was a zero. */
14223
14224 static ffelexHandler
14225 ffeexpr_token_num_per_exp_sign_ (ffelexToken t)
14226 {
14227 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14228 {
14229 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14230 {
14231 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
14232 ffelex_token_where_column (ffeexpr_tokens_[2]));
14233 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14234 ffebad_finish ();
14235 }
14236
14237 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14238 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14239 NULL, NULL, NULL, NULL);
14240
14241 ffelex_token_kill (ffeexpr_tokens_[0]);
14242 ffelex_token_kill (ffeexpr_tokens_[1]);
14243 ffelex_token_kill (ffeexpr_tokens_[2]);
14244 ffelex_token_kill (ffeexpr_tokens_[3]);
14245 return (ffelexHandler) ffeexpr_token_binary_ (t);
14246 }
14247
14248 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0],
14249 ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL,
14250 ffeexpr_tokens_[2], ffeexpr_tokens_[3], t);
14251
14252 ffelex_token_kill (ffeexpr_tokens_[0]);
14253 ffelex_token_kill (ffeexpr_tokens_[1]);
14254 ffelex_token_kill (ffeexpr_tokens_[2]);
14255 ffelex_token_kill (ffeexpr_tokens_[3]);
14256 return (ffelexHandler) ffeexpr_token_binary_;
14257 }
14258
14259 /* ffeexpr_token_number_real_exp_ -- Rhs NUMBER PERIOD NUMBER NAME(D, E, or Q)
14260
14261 Return a pointer to this function to the lexer (ffelex), which will
14262 invoke it for the next token.
14263
14264 Ensures this token is PLUS or MINUS, preserves it, goes to final state
14265 for real number (exponent digits). Else issues diagnostic, assumes a
14266 zero exponent field for number, passes token on to binary state as if
14267 previous token had been "E0" instead of "E", for example. */
14268
14269 static ffelexHandler
14270 ffeexpr_token_number_real_exp_ (ffelexToken t)
14271 {
14272 if ((ffelex_token_type (t) != FFELEX_typePLUS)
14273 && (ffelex_token_type (t) != FFELEX_typeMINUS))
14274 {
14275 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14276 {
14277 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
14278 ffelex_token_where_column (ffeexpr_tokens_[3]));
14279 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14280 ffebad_finish ();
14281 }
14282
14283 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14284 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14285 ffeexpr_tokens_[2], NULL, NULL, NULL);
14286
14287 ffelex_token_kill (ffeexpr_tokens_[0]);
14288 ffelex_token_kill (ffeexpr_tokens_[1]);
14289 ffelex_token_kill (ffeexpr_tokens_[2]);
14290 ffelex_token_kill (ffeexpr_tokens_[3]);
14291 return (ffelexHandler) ffeexpr_token_binary_ (t);
14292 }
14293
14294 ffeexpr_tokens_[4] = ffelex_token_use (t);
14295 return (ffelexHandler) ffeexpr_token_num_real_exp_sn_;
14296 }
14297
14298 /* ffeexpr_token_num_real_exp_sn_ -- Rhs NUMBER PERIOD NUMBER NAME(D,E,Q)
14299 PLUS/MINUS
14300
14301 Return a pointer to this function to the lexer (ffelex), which will
14302 invoke it for the next token.
14303
14304 Make sure token is a NUMBER, make a real constant out of all we have and
14305 push it onto the expression stack. Else issue diagnostic and pretend
14306 exponent field was a zero. */
14307
14308 static ffelexHandler
14309 ffeexpr_token_num_real_exp_sn_ (ffelexToken t)
14310 {
14311 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14312 {
14313 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14314 {
14315 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
14316 ffelex_token_where_column (ffeexpr_tokens_[3]));
14317 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14318 ffebad_finish ();
14319 }
14320
14321 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14322 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14323 ffeexpr_tokens_[2], NULL, NULL, NULL);
14324
14325 ffelex_token_kill (ffeexpr_tokens_[0]);
14326 ffelex_token_kill (ffeexpr_tokens_[1]);
14327 ffelex_token_kill (ffeexpr_tokens_[2]);
14328 ffelex_token_kill (ffeexpr_tokens_[3]);
14329 ffelex_token_kill (ffeexpr_tokens_[4]);
14330 return (ffelexHandler) ffeexpr_token_binary_ (t);
14331 }
14332
14333 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[3])[0],
14334 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14335 ffeexpr_tokens_[2], ffeexpr_tokens_[3],
14336 ffeexpr_tokens_[4], t);
14337
14338 ffelex_token_kill (ffeexpr_tokens_[0]);
14339 ffelex_token_kill (ffeexpr_tokens_[1]);
14340 ffelex_token_kill (ffeexpr_tokens_[2]);
14341 ffelex_token_kill (ffeexpr_tokens_[3]);
14342 ffelex_token_kill (ffeexpr_tokens_[4]);
14343 return (ffelexHandler) ffeexpr_token_binary_;
14344 }
14345
14346 /* ffeexpr_token_binary_ -- Handle binary operator possibility
14347
14348 Return a pointer to this function to the lexer (ffelex), which will
14349 invoke it for the next token.
14350
14351 The possibility of a binary operator is handled here, meaning the previous
14352 token was an operand. */
14353
14354 static ffelexHandler
14355 ffeexpr_token_binary_ (ffelexToken t)
14356 {
14357 ffeexprExpr_ e;
14358
14359 if (!ffeexpr_stack_->is_rhs)
14360 return (ffelexHandler) ffeexpr_finished_ (t); /* For now. */
14361
14362 switch (ffelex_token_type (t))
14363 {
14364 case FFELEX_typePLUS:
14365 e = ffeexpr_expr_new_ ();
14366 e->type = FFEEXPR_exprtypeBINARY_;
14367 e->token = ffelex_token_use (t);
14368 e->u.operator.op = FFEEXPR_operatorADD_;
14369 e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
14370 e->u.operator.as = FFEEXPR_operatorassociativityADD_;
14371 ffeexpr_exprstack_push_binary_ (e);
14372 return (ffelexHandler) ffeexpr_token_rhs_;
14373
14374 case FFELEX_typeMINUS:
14375 e = ffeexpr_expr_new_ ();
14376 e->type = FFEEXPR_exprtypeBINARY_;
14377 e->token = ffelex_token_use (t);
14378 e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
14379 e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
14380 e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
14381 ffeexpr_exprstack_push_binary_ (e);
14382 return (ffelexHandler) ffeexpr_token_rhs_;
14383
14384 case FFELEX_typeASTERISK:
14385 switch (ffeexpr_stack_->context)
14386 {
14387 case FFEEXPR_contextDATA:
14388 return (ffelexHandler) ffeexpr_finished_ (t);
14389
14390 default:
14391 break;
14392 }
14393 e = ffeexpr_expr_new_ ();
14394 e->type = FFEEXPR_exprtypeBINARY_;
14395 e->token = ffelex_token_use (t);
14396 e->u.operator.op = FFEEXPR_operatorMULTIPLY_;
14397 e->u.operator.prec = FFEEXPR_operatorprecedenceMULTIPLY_;
14398 e->u.operator.as = FFEEXPR_operatorassociativityMULTIPLY_;
14399 ffeexpr_exprstack_push_binary_ (e);
14400 return (ffelexHandler) ffeexpr_token_rhs_;
14401
14402 case FFELEX_typeSLASH:
14403 switch (ffeexpr_stack_->context)
14404 {
14405 case FFEEXPR_contextDATA:
14406 return (ffelexHandler) ffeexpr_finished_ (t);
14407
14408 default:
14409 break;
14410 }
14411 e = ffeexpr_expr_new_ ();
14412 e->type = FFEEXPR_exprtypeBINARY_;
14413 e->token = ffelex_token_use (t);
14414 e->u.operator.op = FFEEXPR_operatorDIVIDE_;
14415 e->u.operator.prec = FFEEXPR_operatorprecedenceDIVIDE_;
14416 e->u.operator.as = FFEEXPR_operatorassociativityDIVIDE_;
14417 ffeexpr_exprstack_push_binary_ (e);
14418 return (ffelexHandler) ffeexpr_token_rhs_;
14419
14420 case FFELEX_typePOWER:
14421 e = ffeexpr_expr_new_ ();
14422 e->type = FFEEXPR_exprtypeBINARY_;
14423 e->token = ffelex_token_use (t);
14424 e->u.operator.op = FFEEXPR_operatorPOWER_;
14425 e->u.operator.prec = FFEEXPR_operatorprecedencePOWER_;
14426 e->u.operator.as = FFEEXPR_operatorassociativityPOWER_;
14427 ffeexpr_exprstack_push_binary_ (e);
14428 return (ffelexHandler) ffeexpr_token_rhs_;
14429
14430 case FFELEX_typeCONCAT:
14431 e = ffeexpr_expr_new_ ();
14432 e->type = FFEEXPR_exprtypeBINARY_;
14433 e->token = ffelex_token_use (t);
14434 e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
14435 e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
14436 e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
14437 ffeexpr_exprstack_push_binary_ (e);
14438 return (ffelexHandler) ffeexpr_token_rhs_;
14439
14440 case FFELEX_typeOPEN_ANGLE:
14441 switch (ffeexpr_stack_->context)
14442 {
14443 case FFEEXPR_contextFORMAT:
14444 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14445 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14446 ffebad_finish ();
14447 break;
14448
14449 default:
14450 break;
14451 }
14452 e = ffeexpr_expr_new_ ();
14453 e->type = FFEEXPR_exprtypeBINARY_;
14454 e->token = ffelex_token_use (t);
14455 e->u.operator.op = FFEEXPR_operatorLT_;
14456 e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
14457 e->u.operator.as = FFEEXPR_operatorassociativityLT_;
14458 ffeexpr_exprstack_push_binary_ (e);
14459 return (ffelexHandler) ffeexpr_token_rhs_;
14460
14461 case FFELEX_typeCLOSE_ANGLE:
14462 switch (ffeexpr_stack_->context)
14463 {
14464 case FFEEXPR_contextFORMAT:
14465 return ffeexpr_finished_ (t);
14466
14467 default:
14468 break;
14469 }
14470 e = ffeexpr_expr_new_ ();
14471 e->type = FFEEXPR_exprtypeBINARY_;
14472 e->token = ffelex_token_use (t);
14473 e->u.operator.op = FFEEXPR_operatorGT_;
14474 e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
14475 e->u.operator.as = FFEEXPR_operatorassociativityGT_;
14476 ffeexpr_exprstack_push_binary_ (e);
14477 return (ffelexHandler) ffeexpr_token_rhs_;
14478
14479 case FFELEX_typeREL_EQ:
14480 switch (ffeexpr_stack_->context)
14481 {
14482 case FFEEXPR_contextFORMAT:
14483 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14484 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14485 ffebad_finish ();
14486 break;
14487
14488 default:
14489 break;
14490 }
14491 e = ffeexpr_expr_new_ ();
14492 e->type = FFEEXPR_exprtypeBINARY_;
14493 e->token = ffelex_token_use (t);
14494 e->u.operator.op = FFEEXPR_operatorEQ_;
14495 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
14496 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
14497 ffeexpr_exprstack_push_binary_ (e);
14498 return (ffelexHandler) ffeexpr_token_rhs_;
14499
14500 case FFELEX_typeREL_NE:
14501 switch (ffeexpr_stack_->context)
14502 {
14503 case FFEEXPR_contextFORMAT:
14504 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14505 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14506 ffebad_finish ();
14507 break;
14508
14509 default:
14510 break;
14511 }
14512 e = ffeexpr_expr_new_ ();
14513 e->type = FFEEXPR_exprtypeBINARY_;
14514 e->token = ffelex_token_use (t);
14515 e->u.operator.op = FFEEXPR_operatorNE_;
14516 e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
14517 e->u.operator.as = FFEEXPR_operatorassociativityNE_;
14518 ffeexpr_exprstack_push_binary_ (e);
14519 return (ffelexHandler) ffeexpr_token_rhs_;
14520
14521 case FFELEX_typeREL_LE:
14522 switch (ffeexpr_stack_->context)
14523 {
14524 case FFEEXPR_contextFORMAT:
14525 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14526 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14527 ffebad_finish ();
14528 break;
14529
14530 default:
14531 break;
14532 }
14533 e = ffeexpr_expr_new_ ();
14534 e->type = FFEEXPR_exprtypeBINARY_;
14535 e->token = ffelex_token_use (t);
14536 e->u.operator.op = FFEEXPR_operatorLE_;
14537 e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
14538 e->u.operator.as = FFEEXPR_operatorassociativityLE_;
14539 ffeexpr_exprstack_push_binary_ (e);
14540 return (ffelexHandler) ffeexpr_token_rhs_;
14541
14542 case FFELEX_typeREL_GE:
14543 switch (ffeexpr_stack_->context)
14544 {
14545 case FFEEXPR_contextFORMAT:
14546 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14547 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14548 ffebad_finish ();
14549 break;
14550
14551 default:
14552 break;
14553 }
14554 e = ffeexpr_expr_new_ ();
14555 e->type = FFEEXPR_exprtypeBINARY_;
14556 e->token = ffelex_token_use (t);
14557 e->u.operator.op = FFEEXPR_operatorGE_;
14558 e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
14559 e->u.operator.as = FFEEXPR_operatorassociativityGE_;
14560 ffeexpr_exprstack_push_binary_ (e);
14561 return (ffelexHandler) ffeexpr_token_rhs_;
14562
14563 case FFELEX_typePERIOD:
14564 ffeexpr_tokens_[0] = ffelex_token_use (t);
14565 return (ffelexHandler) ffeexpr_token_binary_period_;
14566
14567 #if 0
14568 case FFELEX_typeOPEN_PAREN:
14569 case FFELEX_typeCLOSE_PAREN:
14570 case FFELEX_typeEQUALS:
14571 case FFELEX_typePOINTS:
14572 case FFELEX_typeCOMMA:
14573 case FFELEX_typeCOLON:
14574 case FFELEX_typeEOS:
14575 case FFELEX_typeSEMICOLON:
14576 case FFELEX_typeNAME:
14577 case FFELEX_typeNAMES:
14578 #endif
14579 default:
14580 return (ffelexHandler) ffeexpr_finished_ (t);
14581 }
14582 }
14583
14584 /* ffeexpr_token_binary_period_ -- Binary PERIOD
14585
14586 Return a pointer to this function to the lexer (ffelex), which will
14587 invoke it for the next token.
14588
14589 Handle a period detected at binary (expecting binary op or end) state.
14590 Must begin a dot-dot name, of which .NOT., .TRUE., and .FALSE. are not
14591 valid. */
14592
14593 static ffelexHandler
14594 ffeexpr_token_binary_period_ (ffelexToken t)
14595 {
14596 ffeexprExpr_ operand;
14597
14598 switch (ffelex_token_type (t))
14599 {
14600 case FFELEX_typeNAME:
14601 case FFELEX_typeNAMES:
14602 ffeexpr_current_dotdot_ = ffeexpr_dotdot_ (t);
14603 switch (ffeexpr_current_dotdot_)
14604 {
14605 case FFEEXPR_dotdotTRUE_:
14606 case FFEEXPR_dotdotFALSE_:
14607 case FFEEXPR_dotdotNOT_:
14608 if (ffest_ffebad_start (FFEBAD_MISSING_BINARY_OPERATOR))
14609 {
14610 operand = ffeexpr_stack_->exprstack;
14611 assert (operand != NULL);
14612 assert (operand->type == FFEEXPR_exprtypeOPERAND_);
14613 ffebad_here (0, ffelex_token_where_line (operand->token), ffelex_token_where_column (operand->token));
14614 ffebad_here (1, ffelex_token_where_line (t),
14615 ffelex_token_where_column (t));
14616 ffebad_finish ();
14617 }
14618 ffelex_token_kill (ffeexpr_tokens_[0]);
14619 return (ffelexHandler) ffeexpr_token_binary_sw_per_;
14620
14621 case FFEEXPR_dotdotNONE_:
14622 if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT))
14623 {
14624 ffebad_string (ffelex_token_text (t));
14625 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14626 ffelex_token_where_column (ffeexpr_tokens_[0]));
14627 ffebad_finish ();
14628 }
14629 ffeexpr_current_dotdot_ = FFEEXPR_dotdotEQ_;
14630 /* Fall through here, pretending we got a .EQ. operator. */
14631 default:
14632 ffeexpr_tokens_[1] = ffelex_token_use (t);
14633 return (ffelexHandler) ffeexpr_token_binary_end_per_;
14634 }
14635 break; /* Nothing really reaches here. */
14636
14637 default:
14638 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
14639 {
14640 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14641 ffelex_token_where_column (ffeexpr_tokens_[0]));
14642 ffebad_finish ();
14643 }
14644 ffelex_token_kill (ffeexpr_tokens_[0]);
14645 return (ffelexHandler) ffeexpr_token_binary_ (t);
14646 }
14647 }
14648
14649 /* ffeexpr_token_binary_end_per_ -- Binary PERIOD NAME(not NOT, TRUE, or FALSE)
14650
14651 Return a pointer to this function to the lexer (ffelex), which will
14652 invoke it for the next token.
14653
14654 Expecting a period to close a dot-dot at binary (binary op
14655 or operator) state. If period isn't found, issue a diagnostic but
14656 pretend we saw one. ffeexpr_current_dotdot_ must already contained the
14657 dotdot representation of the name in between the two PERIOD tokens. */
14658
14659 static ffelexHandler
14660 ffeexpr_token_binary_end_per_ (ffelexToken t)
14661 {
14662 ffeexprExpr_ e;
14663
14664 if (ffelex_token_type (t) != FFELEX_typePERIOD)
14665 {
14666 if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
14667 {
14668 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14669 ffelex_token_where_column (ffeexpr_tokens_[0]));
14670 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14671 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
14672 ffebad_finish ();
14673 }
14674 }
14675
14676 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */
14677
14678 e = ffeexpr_expr_new_ ();
14679 e->type = FFEEXPR_exprtypeBINARY_;
14680 e->token = ffeexpr_tokens_[0];
14681
14682 switch (ffeexpr_current_dotdot_)
14683 {
14684 case FFEEXPR_dotdotAND_:
14685 e->u.operator.op = FFEEXPR_operatorAND_;
14686 e->u.operator.prec = FFEEXPR_operatorprecedenceAND_;
14687 e->u.operator.as = FFEEXPR_operatorassociativityAND_;
14688 break;
14689
14690 case FFEEXPR_dotdotOR_:
14691 e->u.operator.op = FFEEXPR_operatorOR_;
14692 e->u.operator.prec = FFEEXPR_operatorprecedenceOR_;
14693 e->u.operator.as = FFEEXPR_operatorassociativityOR_;
14694 break;
14695
14696 case FFEEXPR_dotdotXOR_:
14697 e->u.operator.op = FFEEXPR_operatorXOR_;
14698 e->u.operator.prec = FFEEXPR_operatorprecedenceXOR_;
14699 e->u.operator.as = FFEEXPR_operatorassociativityXOR_;
14700 break;
14701
14702 case FFEEXPR_dotdotEQV_:
14703 e->u.operator.op = FFEEXPR_operatorEQV_;
14704 e->u.operator.prec = FFEEXPR_operatorprecedenceEQV_;
14705 e->u.operator.as = FFEEXPR_operatorassociativityEQV_;
14706 break;
14707
14708 case FFEEXPR_dotdotNEQV_:
14709 e->u.operator.op = FFEEXPR_operatorNEQV_;
14710 e->u.operator.prec = FFEEXPR_operatorprecedenceNEQV_;
14711 e->u.operator.as = FFEEXPR_operatorassociativityNEQV_;
14712 break;
14713
14714 case FFEEXPR_dotdotLT_:
14715 e->u.operator.op = FFEEXPR_operatorLT_;
14716 e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
14717 e->u.operator.as = FFEEXPR_operatorassociativityLT_;
14718 break;
14719
14720 case FFEEXPR_dotdotLE_:
14721 e->u.operator.op = FFEEXPR_operatorLE_;
14722 e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
14723 e->u.operator.as = FFEEXPR_operatorassociativityLE_;
14724 break;
14725
14726 case FFEEXPR_dotdotEQ_:
14727 e->u.operator.op = FFEEXPR_operatorEQ_;
14728 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
14729 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
14730 break;
14731
14732 case FFEEXPR_dotdotNE_:
14733 e->u.operator.op = FFEEXPR_operatorNE_;
14734 e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
14735 e->u.operator.as = FFEEXPR_operatorassociativityNE_;
14736 break;
14737
14738 case FFEEXPR_dotdotGT_:
14739 e->u.operator.op = FFEEXPR_operatorGT_;
14740 e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
14741 e->u.operator.as = FFEEXPR_operatorassociativityGT_;
14742 break;
14743
14744 case FFEEXPR_dotdotGE_:
14745 e->u.operator.op = FFEEXPR_operatorGE_;
14746 e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
14747 e->u.operator.as = FFEEXPR_operatorassociativityGE_;
14748 break;
14749
14750 default:
14751 assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL);
14752 }
14753
14754 ffeexpr_exprstack_push_binary_ (e);
14755
14756 if (ffelex_token_type (t) != FFELEX_typePERIOD)
14757 return (ffelexHandler) ffeexpr_token_rhs_ (t);
14758 return (ffelexHandler) ffeexpr_token_rhs_;
14759 }
14760
14761 /* ffeexpr_token_binary_sw_per_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
14762
14763 Return a pointer to this function to the lexer (ffelex), which will
14764 invoke it for the next token.
14765
14766 A diagnostic has already been issued; just swallow a period if there is
14767 one, then continue with ffeexpr_token_binary_. */
14768
14769 static ffelexHandler
14770 ffeexpr_token_binary_sw_per_ (ffelexToken t)
14771 {
14772 if (ffelex_token_type (t) != FFELEX_typePERIOD)
14773 return (ffelexHandler) ffeexpr_token_binary_ (t);
14774
14775 return (ffelexHandler) ffeexpr_token_binary_;
14776 }
14777
14778 /* ffeexpr_token_quote_ -- Rhs QUOTE
14779
14780 Return a pointer to this function to the lexer (ffelex), which will
14781 invoke it for the next token.
14782
14783 Expecting a NUMBER that we'll treat as an octal integer. */
14784
14785 static ffelexHandler
14786 ffeexpr_token_quote_ (ffelexToken t)
14787 {
14788 ffeexprExpr_ e;
14789 ffebld anyexpr;
14790
14791 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14792 {
14793 if (ffest_ffebad_start (FFEBAD_QUOTE_MISSES_DIGITS))
14794 {
14795 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14796 ffelex_token_where_column (ffeexpr_tokens_[0]));
14797 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14798 ffebad_finish ();
14799 }
14800 ffelex_token_kill (ffeexpr_tokens_[0]);
14801 return (ffelexHandler) ffeexpr_token_rhs_ (t);
14802 }
14803
14804 /* This is kind of a kludge to prevent any whining about magical numbers
14805 that start out as these octal integers, so "20000000000 (on a 32-bit
14806 2's-complement machine) by itself won't produce an error. */
14807
14808 anyexpr = ffebld_new_any ();
14809 ffebld_set_info (anyexpr, ffeinfo_new_any ());
14810
14811 e = ffeexpr_expr_new_ ();
14812 e->type = FFEEXPR_exprtypeOPERAND_;
14813 e->token = ffeexpr_tokens_[0];
14814 e->u.operand = ffebld_new_conter_with_orig
14815 (ffebld_constant_new_integeroctal (t), anyexpr);
14816 ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER,
14817 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY,
14818 FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14819 ffeexpr_exprstack_push_operand_ (e);
14820 return (ffelexHandler) ffeexpr_token_binary_;
14821 }
14822
14823 /* ffeexpr_token_apostrophe_ -- Rhs APOSTROPHE
14824
14825 Return a pointer to this function to the lexer (ffelex), which will
14826 invoke it for the next token.
14827
14828 Handle an open-apostrophe, which begins either a character ('char-const'),
14829 typeless octal ('octal-const'O), or typeless hexadecimal ('hex-const'Z or
14830 'hex-const'X) constant. */
14831
14832 static ffelexHandler
14833 ffeexpr_token_apostrophe_ (ffelexToken t)
14834 {
14835 assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
14836 if (ffe_is_pedantic_not_90 () && (ffelex_token_length (t) == 0))
14837 {
14838 ffebad_start (FFEBAD_NULL_CHAR_CONST);
14839 ffebad_here (0, ffelex_token_where_line (t),
14840 ffelex_token_where_column (t));
14841 ffebad_finish ();
14842 }
14843 ffeexpr_tokens_[1] = ffelex_token_use (t);
14844 return (ffelexHandler) ffeexpr_token_apos_char_;
14845 }
14846
14847 /* ffeexpr_token_apos_char_ -- Rhs APOSTROPHE CHARACTER
14848
14849 Return a pointer to this function to the lexer (ffelex), which will
14850 invoke it for the next token.
14851
14852 Close-apostrophe is implicit; if this token is NAME, it is a possible
14853 typeless-constant radix specifier. */
14854
14855 static ffelexHandler
14856 ffeexpr_token_apos_char_ (ffelexToken t)
14857 {
14858 ffeexprExpr_ e;
14859 ffeinfo ni;
14860 char c;
14861 ffetargetCharacterSize size;
14862
14863 if ((ffelex_token_type (t) == FFELEX_typeNAME)
14864 || (ffelex_token_type (t) == FFELEX_typeNAMES))
14865 {
14866 if ((ffelex_token_length (t) == 1)
14867 && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]), 'B',
14868 'b')
14869 || ffesrc_char_match_init (c, 'O', 'o')
14870 || ffesrc_char_match_init (c, 'X', 'x')
14871 || ffesrc_char_match_init (c, 'Z', 'z')))
14872 {
14873 e = ffeexpr_expr_new_ ();
14874 e->type = FFEEXPR_exprtypeOPERAND_;
14875 e->token = ffeexpr_tokens_[0];
14876 switch (c)
14877 {
14878 case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
14879 e->u.operand = ffebld_new_conter
14880 (ffebld_constant_new_typeless_bv (ffeexpr_tokens_[1]));
14881 size = ffetarget_size_typeless_binary (ffeexpr_tokens_[1]);
14882 break;
14883
14884 case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
14885 e->u.operand = ffebld_new_conter
14886 (ffebld_constant_new_typeless_ov (ffeexpr_tokens_[1]));
14887 size = ffetarget_size_typeless_octal (ffeexpr_tokens_[1]);
14888 break;
14889
14890 case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
14891 e->u.operand = ffebld_new_conter
14892 (ffebld_constant_new_typeless_hxv (ffeexpr_tokens_[1]));
14893 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
14894 break;
14895
14896 case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
14897 e->u.operand = ffebld_new_conter
14898 (ffebld_constant_new_typeless_hzv (ffeexpr_tokens_[1]));
14899 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
14900 break;
14901
14902 default:
14903 no_match: /* :::::::::::::::::::: */
14904 assert ("not BOXZ!" == NULL);
14905 size = 0;
14906 break;
14907 }
14908 ffebld_set_info (e->u.operand,
14909 ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
14910 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
14911 ffeexpr_exprstack_push_operand_ (e);
14912 ffelex_token_kill (ffeexpr_tokens_[1]);
14913 return (ffelexHandler) ffeexpr_token_binary_;
14914 }
14915 }
14916 e = ffeexpr_expr_new_ ();
14917 e->type = FFEEXPR_exprtypeOPERAND_;
14918 e->token = ffeexpr_tokens_[0];
14919 e->u.operand = ffebld_new_conter (ffebld_constant_new_characterdefault
14920 (ffeexpr_tokens_[1]));
14921 ni = ffeinfo_new (FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTERDEFAULT,
14922 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14923 ffelex_token_length (ffeexpr_tokens_[1]));
14924 ffebld_set_info (e->u.operand, ni);
14925 ffelex_token_kill (ffeexpr_tokens_[1]);
14926 ffeexpr_exprstack_push_operand_ (e);
14927 if ((ffelex_token_type (t) == FFELEX_typeNAME)
14928 || (ffelex_token_type (t) == FFELEX_typeNAMES))
14929 {
14930 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14931 {
14932 ffebad_string (ffelex_token_text (t));
14933 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14934 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
14935 ffelex_token_where_column (ffeexpr_tokens_[0]));
14936 ffebad_finish ();
14937 }
14938 e = ffeexpr_expr_new_ ();
14939 e->type = FFEEXPR_exprtypeBINARY_;
14940 e->token = ffelex_token_use (t);
14941 e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
14942 e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
14943 e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
14944 ffeexpr_exprstack_push_binary_ (e);
14945 return (ffelexHandler) ffeexpr_token_rhs_ (t);
14946 }
14947 ffeexpr_is_substr_ok_ = !ffe_is_pedantic_not_90 (); /* Allow "'hello'(3:5)". */
14948 return (ffelexHandler) ffeexpr_token_substrp_ (t);
14949 }
14950
14951 /* ffeexpr_token_name_lhs_ -- Lhs NAME
14952
14953 Return a pointer to this function to the lexer (ffelex), which will
14954 invoke it for the next token.
14955
14956 Handle a name followed by open-paren, period (RECORD.MEMBER), percent
14957 (RECORD%MEMBER), or nothing at all. */
14958
14959 static ffelexHandler
14960 ffeexpr_token_name_lhs_ (ffelexToken t)
14961 {
14962 ffeexprExpr_ e;
14963 ffeexprParenType_ paren_type;
14964 ffesymbol s;
14965 ffebld expr;
14966 ffeinfo info;
14967
14968 switch (ffelex_token_type (t))
14969 {
14970 case FFELEX_typeOPEN_PAREN:
14971 switch (ffeexpr_stack_->context)
14972 {
14973 case FFEEXPR_contextASSIGN:
14974 case FFEEXPR_contextAGOTO:
14975 case FFEEXPR_contextFILEUNIT_DF:
14976 goto just_name; /* :::::::::::::::::::: */
14977
14978 default:
14979 break;
14980 }
14981 e = ffeexpr_expr_new_ ();
14982 e->type = FFEEXPR_exprtypeOPERAND_;
14983 e->token = ffelex_token_use (ffeexpr_tokens_[0]);
14984 s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], FALSE,
14985 &paren_type);
14986
14987 switch (ffesymbol_where (s))
14988 {
14989 case FFEINFO_whereLOCAL:
14990 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14991 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recursion. */
14992 break;
14993
14994 case FFEINFO_whereINTRINSIC:
14995 case FFEINFO_whereGLOBAL:
14996 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
14997 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */
14998 break;
14999
15000 case FFEINFO_whereCOMMON:
15001 case FFEINFO_whereDUMMY:
15002 case FFEINFO_whereRESULT:
15003 break;
15004
15005 case FFEINFO_whereNONE:
15006 case FFEINFO_whereANY:
15007 break;
15008
15009 default:
15010 ffesymbol_error (s, ffeexpr_tokens_[0]);
15011 break;
15012 }
15013
15014 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15015 {
15016 e->u.operand = ffebld_new_any ();
15017 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15018 }
15019 else
15020 {
15021 e->u.operand = ffebld_new_symter (s,
15022 ffesymbol_generic (s),
15023 ffesymbol_specific (s),
15024 ffesymbol_implementation (s));
15025 ffebld_set_info (e->u.operand, ffesymbol_info (s));
15026 }
15027 ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */
15028 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
15029 switch (paren_type)
15030 {
15031 case FFEEXPR_parentypeSUBROUTINE_:
15032 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15033 return
15034 (ffelexHandler)
15035 ffeexpr_rhs (ffeexpr_stack_->pool,
15036 FFEEXPR_contextACTUALARG_,
15037 ffeexpr_token_arguments_);
15038
15039 case FFEEXPR_parentypeARRAY_:
15040 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15041 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
15042 ffeexpr_stack_->rank = 0;
15043 ffeexpr_stack_->constant = TRUE;
15044 ffeexpr_stack_->immediate = TRUE;
15045 switch (ffeexpr_stack_->context)
15046 {
15047 case FFEEXPR_contextDATAIMPDOITEM_:
15048 return
15049 (ffelexHandler)
15050 ffeexpr_rhs (ffeexpr_stack_->pool,
15051 FFEEXPR_contextDATAIMPDOINDEX_,
15052 ffeexpr_token_elements_);
15053
15054 case FFEEXPR_contextEQUIVALENCE:
15055 return
15056 (ffelexHandler)
15057 ffeexpr_rhs (ffeexpr_stack_->pool,
15058 FFEEXPR_contextEQVINDEX_,
15059 ffeexpr_token_elements_);
15060
15061 default:
15062 return
15063 (ffelexHandler)
15064 ffeexpr_rhs (ffeexpr_stack_->pool,
15065 FFEEXPR_contextINDEX_,
15066 ffeexpr_token_elements_);
15067 }
15068
15069 case FFEEXPR_parentypeSUBSTRING_:
15070 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
15071 ffeexpr_tokens_[0]);
15072 return
15073 (ffelexHandler)
15074 ffeexpr_rhs (ffeexpr_stack_->pool,
15075 FFEEXPR_contextINDEX_,
15076 ffeexpr_token_substring_);
15077
15078 case FFEEXPR_parentypeEQUIVALENCE_:
15079 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15080 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
15081 ffeexpr_stack_->rank = 0;
15082 ffeexpr_stack_->constant = TRUE;
15083 ffeexpr_stack_->immediate = TRUE;
15084 return
15085 (ffelexHandler)
15086 ffeexpr_rhs (ffeexpr_stack_->pool,
15087 FFEEXPR_contextEQVINDEX_,
15088 ffeexpr_token_equivalence_);
15089
15090 case FFEEXPR_parentypeFUNCTION_: /* Invalid case. */
15091 case FFEEXPR_parentypeFUNSUBSTR_: /* Invalid case. */
15092 ffesymbol_error (s, ffeexpr_tokens_[0]);
15093 /* Fall through. */
15094 case FFEEXPR_parentypeANY_:
15095 e->u.operand = ffebld_new_any ();
15096 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15097 return
15098 (ffelexHandler)
15099 ffeexpr_rhs (ffeexpr_stack_->pool,
15100 FFEEXPR_contextACTUALARG_,
15101 ffeexpr_token_anything_);
15102
15103 default:
15104 assert ("bad paren type" == NULL);
15105 break;
15106 }
15107
15108 case FFELEX_typeEQUALS: /* As in "VAR=". */
15109 switch (ffeexpr_stack_->context)
15110 {
15111 case FFEEXPR_contextIMPDOITEM_: /* within
15112 "(,VAR=start,end[,incr])". */
15113 case FFEEXPR_contextIMPDOITEMDF_:
15114 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
15115 break;
15116
15117 case FFEEXPR_contextDATAIMPDOITEM_:
15118 ffeexpr_stack_->context = FFEEXPR_contextDATAIMPDOCTRL_;
15119 break;
15120
15121 default:
15122 break;
15123 }
15124 break;
15125
15126 #if 0
15127 case FFELEX_typePERIOD:
15128 case FFELEX_typePERCENT:
15129 assert ("FOO%, FOO. not yet supported!~~" == NULL);
15130 break;
15131 #endif
15132
15133 default:
15134 break;
15135 }
15136
15137 just_name: /* :::::::::::::::::::: */
15138 e = ffeexpr_expr_new_ ();
15139 e->type = FFEEXPR_exprtypeOPERAND_;
15140 e->token = ffeexpr_tokens_[0];
15141 s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0],
15142 (ffeexpr_stack_->context
15143 == FFEEXPR_contextSUBROUTINEREF));
15144
15145 switch (ffesymbol_where (s))
15146 {
15147 case FFEINFO_whereCONSTANT:
15148 if ((ffeexpr_stack_->context != FFEEXPR_contextPARAMETER)
15149 || (ffesymbol_kind (s) != FFEINFO_kindENTITY))
15150 ffesymbol_error (s, ffeexpr_tokens_[0]);
15151 break;
15152
15153 case FFEINFO_whereIMMEDIATE:
15154 if ((ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOCTRL_)
15155 && (ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOINDEX_))
15156 ffesymbol_error (s, ffeexpr_tokens_[0]);
15157 break;
15158
15159 case FFEINFO_whereLOCAL:
15160 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
15161 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recurse!. */
15162 break;
15163
15164 case FFEINFO_whereINTRINSIC:
15165 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
15166 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */
15167 break;
15168
15169 default:
15170 break;
15171 }
15172
15173 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15174 {
15175 expr = ffebld_new_any ();
15176 info = ffeinfo_new_any ();
15177 ffebld_set_info (expr, info);
15178 }
15179 else
15180 {
15181 expr = ffebld_new_symter (s,
15182 ffesymbol_generic (s),
15183 ffesymbol_specific (s),
15184 ffesymbol_implementation (s));
15185 info = ffesymbol_info (s);
15186 ffebld_set_info (expr, info);
15187 if (ffesymbol_is_doiter (s))
15188 {
15189 ffebad_start (FFEBAD_DOITER);
15190 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15191 ffelex_token_where_column (ffeexpr_tokens_[0]));
15192 ffest_ffebad_here_doiter (1, s);
15193 ffebad_string (ffesymbol_text (s));
15194 ffebad_finish ();
15195 }
15196 expr = ffeexpr_collapse_symter (expr, ffeexpr_tokens_[0]);
15197 }
15198
15199 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
15200 {
15201 if (ffebld_op (expr) == FFEBLD_opANY)
15202 {
15203 expr = ffebld_new_any ();
15204 ffebld_set_info (expr, ffeinfo_new_any ());
15205 }
15206 else
15207 {
15208 expr = ffebld_new_subrref (expr, NULL); /* No argument list. */
15209 if (ffesymbol_generic (s) != FFEINTRIN_genNONE)
15210 ffeintrin_fulfill_generic (&expr, &info, e->token);
15211 else if (ffesymbol_specific (s) != FFEINTRIN_specNONE)
15212 ffeintrin_fulfill_specific (&expr, &info, NULL, e->token);
15213 else
15214 ffeexpr_fulfill_call_ (&expr, e->token);
15215
15216 if (ffebld_op (expr) != FFEBLD_opANY)
15217 ffebld_set_info (expr,
15218 ffeinfo_new (ffeinfo_basictype (info),
15219 ffeinfo_kindtype (info),
15220 0,
15221 FFEINFO_kindENTITY,
15222 FFEINFO_whereFLEETING,
15223 ffeinfo_size (info)));
15224 else
15225 ffebld_set_info (expr, ffeinfo_new_any ());
15226 }
15227 }
15228
15229 e->u.operand = expr;
15230 ffeexpr_exprstack_push_operand_ (e);
15231 return (ffelexHandler) ffeexpr_finished_ (t);
15232 }
15233
15234 /* ffeexpr_token_name_arg_ -- Rhs NAME
15235
15236 Return a pointer to this function to the lexer (ffelex), which will
15237 invoke it for the next token.
15238
15239 Handle first token in an actual-arg (or possible actual-arg) context
15240 being a NAME, and use second token to refine the context. */
15241
15242 static ffelexHandler
15243 ffeexpr_token_name_arg_ (ffelexToken t)
15244 {
15245 switch (ffelex_token_type (t))
15246 {
15247 case FFELEX_typeCLOSE_PAREN:
15248 case FFELEX_typeCOMMA:
15249 switch (ffeexpr_stack_->context)
15250 {
15251 case FFEEXPR_contextINDEXORACTUALARG_:
15252 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
15253 break;
15254
15255 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15256 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
15257 break;
15258
15259 default:
15260 break;
15261 }
15262 break;
15263
15264 default:
15265 switch (ffeexpr_stack_->context)
15266 {
15267 case FFEEXPR_contextACTUALARG_:
15268 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
15269 break;
15270
15271 case FFEEXPR_contextINDEXORACTUALARG_:
15272 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
15273 break;
15274
15275 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15276 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
15277 break;
15278
15279 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15280 ffeexpr_stack_->context
15281 = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
15282 break;
15283
15284 default:
15285 assert ("bad context in _name_arg_" == NULL);
15286 break;
15287 }
15288 break;
15289 }
15290
15291 return (ffelexHandler) ffeexpr_token_name_rhs_ (t);
15292 }
15293
15294 /* ffeexpr_token_name_rhs_ -- Rhs NAME
15295
15296 Return a pointer to this function to the lexer (ffelex), which will
15297 invoke it for the next token.
15298
15299 Handle a name followed by open-paren, apostrophe (O'octal-const',
15300 Z'hex-const', or X'hex-const'), period (RECORD.MEMBER).
15301
15302 26-Nov-91 JCB 1.2
15303 When followed by apostrophe or quote, set lex hexnum flag on so
15304 [0-9] as first char of next token seen as starting a potentially
15305 hex number (NAME).
15306 04-Oct-91 JCB 1.1
15307 In case of intrinsic, decorate its SYMTER with the type info for
15308 the specific intrinsic. */
15309
15310 static ffelexHandler
15311 ffeexpr_token_name_rhs_ (ffelexToken t)
15312 {
15313 ffeexprExpr_ e;
15314 ffeexprParenType_ paren_type;
15315 ffesymbol s;
15316 bool sfdef;
15317
15318 switch (ffelex_token_type (t))
15319 {
15320 case FFELEX_typeQUOTE:
15321 case FFELEX_typeAPOSTROPHE:
15322 ffeexpr_tokens_[1] = ffelex_token_use (t);
15323 ffelex_set_hexnum (TRUE);
15324 return (ffelexHandler) ffeexpr_token_name_apos_;
15325
15326 case FFELEX_typeOPEN_PAREN:
15327 e = ffeexpr_expr_new_ ();
15328 e->type = FFEEXPR_exprtypeOPERAND_;
15329 e->token = ffelex_token_use (ffeexpr_tokens_[0]);
15330 s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], TRUE,
15331 &paren_type);
15332 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15333 e->u.operand = ffebld_new_any ();
15334 else
15335 e->u.operand = ffebld_new_symter (s, ffesymbol_generic (s),
15336 ffesymbol_specific (s),
15337 ffesymbol_implementation (s));
15338 ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */
15339 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
15340 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15341 {
15342 case FFEEXPR_contextSFUNCDEF:
15343 case FFEEXPR_contextSFUNCDEFINDEX_:
15344 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15345 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15346 sfdef = TRUE;
15347 break;
15348
15349 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15350 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15351 assert ("weird context!" == NULL);
15352 sfdef = FALSE;
15353 break;
15354
15355 default:
15356 sfdef = FALSE;
15357 break;
15358 }
15359 switch (paren_type)
15360 {
15361 case FFEEXPR_parentypeFUNCTION_:
15362 ffebld_set_info (e->u.operand, ffesymbol_info (s));
15363 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15364 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
15365 { /* A statement function. */
15366 ffeexpr_stack_->num_args
15367 = ffebld_list_length
15368 (ffeexpr_stack_->next_dummy
15369 = ffesymbol_dummyargs (s));
15370 ffeexpr_stack_->tokens[1] = NULL; /* !=NULL when > num_args. */
15371 }
15372 else if ((ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
15373 && !ffe_is_pedantic_not_90 ()
15374 && ((ffesymbol_implementation (s)
15375 == FFEINTRIN_impICHAR)
15376 || (ffesymbol_implementation (s)
15377 == FFEINTRIN_impIACHAR)
15378 || (ffesymbol_implementation (s)
15379 == FFEINTRIN_impLEN)))
15380 { /* Allow arbitrary concatenations. */
15381 return
15382 (ffelexHandler)
15383 ffeexpr_rhs (ffeexpr_stack_->pool,
15384 sfdef
15385 ? FFEEXPR_contextSFUNCDEF
15386 : FFEEXPR_contextLET,
15387 ffeexpr_token_arguments_);
15388 }
15389 return
15390 (ffelexHandler)
15391 ffeexpr_rhs (ffeexpr_stack_->pool,
15392 sfdef
15393 ? FFEEXPR_contextSFUNCDEFACTUALARG_
15394 : FFEEXPR_contextACTUALARG_,
15395 ffeexpr_token_arguments_);
15396
15397 case FFEEXPR_parentypeARRAY_:
15398 ffebld_set_info (e->u.operand,
15399 ffesymbol_info (ffebld_symter (e->u.operand)));
15400 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15401 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
15402 ffeexpr_stack_->rank = 0;
15403 ffeexpr_stack_->constant = TRUE;
15404 ffeexpr_stack_->immediate = TRUE;
15405 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
15406 sfdef
15407 ? FFEEXPR_contextSFUNCDEFINDEX_
15408 : FFEEXPR_contextINDEX_,
15409 ffeexpr_token_elements_);
15410
15411 case FFEEXPR_parentypeSUBSTRING_:
15412 ffebld_set_info (e->u.operand,
15413 ffesymbol_info (ffebld_symter (e->u.operand)));
15414 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
15415 ffeexpr_tokens_[0]);
15416 return
15417 (ffelexHandler)
15418 ffeexpr_rhs (ffeexpr_stack_->pool,
15419 sfdef
15420 ? FFEEXPR_contextSFUNCDEFINDEX_
15421 : FFEEXPR_contextINDEX_,
15422 ffeexpr_token_substring_);
15423
15424 case FFEEXPR_parentypeFUNSUBSTR_:
15425 return
15426 (ffelexHandler)
15427 ffeexpr_rhs (ffeexpr_stack_->pool,
15428 sfdef
15429 ? FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
15430 : FFEEXPR_contextINDEXORACTUALARG_,
15431 ffeexpr_token_funsubstr_);
15432
15433 case FFEEXPR_parentypeANY_:
15434 ffebld_set_info (e->u.operand, ffesymbol_info (s));
15435 return
15436 (ffelexHandler)
15437 ffeexpr_rhs (ffeexpr_stack_->pool,
15438 sfdef
15439 ? FFEEXPR_contextSFUNCDEFACTUALARG_
15440 : FFEEXPR_contextACTUALARG_,
15441 ffeexpr_token_anything_);
15442
15443 default:
15444 assert ("bad paren type" == NULL);
15445 break;
15446 }
15447
15448 case FFELEX_typeEQUALS: /* As in "VAR=". */
15449 switch (ffeexpr_stack_->context)
15450 {
15451 case FFEEXPR_contextIMPDOITEM_: /* "(,VAR=start,end[,incr])". */
15452 case FFEEXPR_contextIMPDOITEMDF_:
15453 ffeexpr_stack_->is_rhs = FALSE; /* Really an lhs construct. */
15454 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
15455 break;
15456
15457 default:
15458 break;
15459 }
15460 break;
15461
15462 #if 0
15463 case FFELEX_typePERIOD:
15464 case FFELEX_typePERCENT:
15465 ~~Support these two someday, though not required
15466 assert ("FOO%, FOO. not yet supported!~~" == NULL);
15467 break;
15468 #endif
15469
15470 default:
15471 break;
15472 }
15473
15474 switch (ffeexpr_stack_->context)
15475 {
15476 case FFEEXPR_contextINDEXORACTUALARG_:
15477 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15478 assert ("strange context" == NULL);
15479 break;
15480
15481 default:
15482 break;
15483 }
15484
15485 e = ffeexpr_expr_new_ ();
15486 e->type = FFEEXPR_exprtypeOPERAND_;
15487 e->token = ffeexpr_tokens_[0];
15488 s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0], FALSE);
15489 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15490 {
15491 e->u.operand = ffebld_new_any ();
15492 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15493 }
15494 else
15495 {
15496 e->u.operand = ffebld_new_symter (s, FFEINTRIN_genNONE,
15497 ffesymbol_specific (s),
15498 ffesymbol_implementation (s));
15499 if (ffesymbol_specific (s) == FFEINTRIN_specNONE)
15500 ffebld_set_info (e->u.operand, ffeinfo_use (ffesymbol_info (s)));
15501 else
15502 { /* Decorate the SYMTER with the actual type
15503 of the intrinsic. */
15504 ffebld_set_info (e->u.operand, ffeinfo_new
15505 (ffeintrin_basictype (ffesymbol_specific (s)),
15506 ffeintrin_kindtype (ffesymbol_specific (s)),
15507 0,
15508 ffesymbol_kind (s),
15509 ffesymbol_where (s),
15510 FFETARGET_charactersizeNONE));
15511 }
15512 if (ffesymbol_is_doiter (s))
15513 ffebld_symter_set_is_doiter (e->u.operand, TRUE);
15514 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
15515 ffeexpr_tokens_[0]);
15516 }
15517 ffeexpr_exprstack_push_operand_ (e);
15518 return (ffelexHandler) ffeexpr_token_binary_ (t);
15519 }
15520
15521 /* ffeexpr_token_name_apos_ -- Rhs NAME APOSTROPHE
15522
15523 Return a pointer to this function to the lexer (ffelex), which will
15524 invoke it for the next token.
15525
15526 Expecting a NAME token, analyze the previous NAME token to see what kind,
15527 if any, typeless constant we've got.
15528
15529 01-Sep-90 JCB 1.1
15530 Expect a NAME instead of CHARACTER in this situation. */
15531
15532 static ffelexHandler
15533 ffeexpr_token_name_apos_ (ffelexToken t)
15534 {
15535 ffeexprExpr_ e;
15536
15537 ffelex_set_hexnum (FALSE);
15538
15539 switch (ffelex_token_type (t))
15540 {
15541 case FFELEX_typeNAME:
15542 ffeexpr_tokens_[2] = ffelex_token_use (t);
15543 return (ffelexHandler) ffeexpr_token_name_apos_name_;
15544
15545 default:
15546 break;
15547 }
15548
15549 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
15550 {
15551 ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
15552 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15553 ffelex_token_where_column (ffeexpr_tokens_[0]));
15554 ffebad_here (1, ffelex_token_where_line (t),
15555 ffelex_token_where_column (t));
15556 ffebad_finish ();
15557 }
15558
15559 ffelex_token_kill (ffeexpr_tokens_[1]);
15560
15561 e = ffeexpr_expr_new_ ();
15562 e->type = FFEEXPR_exprtypeOPERAND_;
15563 e->u.operand = ffebld_new_any ();
15564 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15565 e->token = ffeexpr_tokens_[0];
15566 ffeexpr_exprstack_push_operand_ (e);
15567
15568 return (ffelexHandler) ffeexpr_token_binary_ (t);
15569 }
15570
15571 /* ffeexpr_token_name_apos_name_ -- Rhs NAME APOSTROPHE NAME
15572
15573 Return a pointer to this function to the lexer (ffelex), which will
15574 invoke it for the next token.
15575
15576 Expecting an APOSTROPHE token, analyze the previous NAME token to see
15577 what kind, if any, typeless constant we've got. */
15578
15579 static ffelexHandler
15580 ffeexpr_token_name_apos_name_ (ffelexToken t)
15581 {
15582 ffeexprExpr_ e;
15583 char c;
15584
15585 e = ffeexpr_expr_new_ ();
15586 e->type = FFEEXPR_exprtypeOPERAND_;
15587 e->token = ffeexpr_tokens_[0];
15588
15589 if ((ffelex_token_type (t) == ffelex_token_type (ffeexpr_tokens_[1]))
15590 && (ffelex_token_length (ffeexpr_tokens_[0]) == 1)
15591 && (ffesrc_char_match_init ((c = ffelex_token_text (ffeexpr_tokens_[0])[0]),
15592 'B', 'b')
15593 || ffesrc_char_match_init (c, 'O', 'o')
15594 || ffesrc_char_match_init (c, 'X', 'x')
15595 || ffesrc_char_match_init (c, 'Z', 'z')))
15596 {
15597 ffetargetCharacterSize size;
15598
15599 if (!ffe_is_typeless_boz ()) {
15600
15601 switch (c)
15602 {
15603 case FFESRC_CASE_MATCH_INIT ('B', 'b', imatch_b, no_imatch):
15604 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerbinary
15605 (ffeexpr_tokens_[2]));
15606 break;
15607
15608 case FFESRC_CASE_MATCH_INIT ('O', 'o', imatch_o, no_imatch):
15609 e->u.operand = ffebld_new_conter (ffebld_constant_new_integeroctal
15610 (ffeexpr_tokens_[2]));
15611 break;
15612
15613 case FFESRC_CASE_MATCH_INIT ('X', 'x', imatch_x, no_imatch):
15614 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
15615 (ffeexpr_tokens_[2]));
15616 break;
15617
15618 case FFESRC_CASE_MATCH_INIT ('Z', 'z', imatch_z, no_imatch):
15619 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
15620 (ffeexpr_tokens_[2]));
15621 break;
15622
15623 default:
15624 no_imatch: /* :::::::::::::::::::: */
15625 assert ("not BOXZ!" == NULL);
15626 abort ();
15627 }
15628
15629 ffebld_set_info (e->u.operand,
15630 ffeinfo_new (FFEINFO_basictypeINTEGER,
15631 FFEINFO_kindtypeINTEGERDEFAULT, 0,
15632 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
15633 FFETARGET_charactersizeNONE));
15634 ffeexpr_exprstack_push_operand_ (e);
15635 ffelex_token_kill (ffeexpr_tokens_[1]);
15636 ffelex_token_kill (ffeexpr_tokens_[2]);
15637 return (ffelexHandler) ffeexpr_token_binary_;
15638 }
15639
15640 switch (c)
15641 {
15642 case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
15643 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_bm
15644 (ffeexpr_tokens_[2]));
15645 size = ffetarget_size_typeless_binary (ffeexpr_tokens_[2]);
15646 break;
15647
15648 case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
15649 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_om
15650 (ffeexpr_tokens_[2]));
15651 size = ffetarget_size_typeless_octal (ffeexpr_tokens_[2]);
15652 break;
15653
15654 case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
15655 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hxm
15656 (ffeexpr_tokens_[2]));
15657 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15658 break;
15659
15660 case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
15661 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
15662 (ffeexpr_tokens_[2]));
15663 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15664 break;
15665
15666 default:
15667 no_match: /* :::::::::::::::::::: */
15668 assert ("not BOXZ!" == NULL);
15669 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
15670 (ffeexpr_tokens_[2]));
15671 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15672 break;
15673 }
15674 ffebld_set_info (e->u.operand,
15675 ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
15676 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
15677 ffeexpr_exprstack_push_operand_ (e);
15678 ffelex_token_kill (ffeexpr_tokens_[1]);
15679 ffelex_token_kill (ffeexpr_tokens_[2]);
15680 return (ffelexHandler) ffeexpr_token_binary_;
15681 }
15682
15683 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
15684 {
15685 ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
15686 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15687 ffelex_token_where_column (ffeexpr_tokens_[0]));
15688 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
15689 ffebad_finish ();
15690 }
15691
15692 ffelex_token_kill (ffeexpr_tokens_[1]);
15693 ffelex_token_kill (ffeexpr_tokens_[2]);
15694
15695 e->type = FFEEXPR_exprtypeOPERAND_;
15696 e->u.operand = ffebld_new_any ();
15697 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15698 e->token = ffeexpr_tokens_[0];
15699 ffeexpr_exprstack_push_operand_ (e);
15700
15701 switch (ffelex_token_type (t))
15702 {
15703 case FFELEX_typeAPOSTROPHE:
15704 case FFELEX_typeQUOTE:
15705 return (ffelexHandler) ffeexpr_token_binary_;
15706
15707 default:
15708 return (ffelexHandler) ffeexpr_token_binary_ (t);
15709 }
15710 }
15711
15712 /* ffeexpr_token_percent_ -- Rhs PERCENT
15713
15714 Handle a percent sign possibly followed by "LOC". If followed instead
15715 by "VAL", "REF", or "DESCR", issue an error message and substitute
15716 "LOC". If followed by something else, treat the percent sign as a
15717 spurious incorrect token and reprocess the token via _rhs_. */
15718
15719 static ffelexHandler
15720 ffeexpr_token_percent_ (ffelexToken t)
15721 {
15722 switch (ffelex_token_type (t))
15723 {
15724 case FFELEX_typeNAME:
15725 case FFELEX_typeNAMES:
15726 ffeexpr_stack_->percent = ffeexpr_percent_ (t);
15727 ffeexpr_tokens_[1] = ffelex_token_use (t);
15728 return (ffelexHandler) ffeexpr_token_percent_name_;
15729
15730 default:
15731 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
15732 {
15733 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15734 ffelex_token_where_column (ffeexpr_tokens_[0]));
15735 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
15736 ffelex_token_where_column (ffeexpr_stack_->first_token));
15737 ffebad_finish ();
15738 }
15739 ffelex_token_kill (ffeexpr_tokens_[0]);
15740 return (ffelexHandler) ffeexpr_token_rhs_ (t);
15741 }
15742 }
15743
15744 /* ffeexpr_token_percent_name_ -- Rhs PERCENT NAME
15745
15746 Make sure the token is OPEN_PAREN and prepare for the one-item list of
15747 LHS expressions. Else display an error message. */
15748
15749 static ffelexHandler
15750 ffeexpr_token_percent_name_ (ffelexToken t)
15751 {
15752 ffelexHandler nexthandler;
15753
15754 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
15755 {
15756 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
15757 {
15758 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15759 ffelex_token_where_column (ffeexpr_tokens_[0]));
15760 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
15761 ffelex_token_where_column (ffeexpr_stack_->first_token));
15762 ffebad_finish ();
15763 }
15764 ffelex_token_kill (ffeexpr_tokens_[0]);
15765 nexthandler = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_tokens_[1]);
15766 ffelex_token_kill (ffeexpr_tokens_[1]);
15767 return (ffelexHandler) (*nexthandler) (t);
15768 }
15769
15770 switch (ffeexpr_stack_->percent)
15771 {
15772 default:
15773 if (ffest_ffebad_start (FFEBAD_INVALID_PERCENT))
15774 {
15775 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15776 ffelex_token_where_column (ffeexpr_tokens_[0]));
15777 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
15778 ffebad_finish ();
15779 }
15780 ffeexpr_stack_->percent = FFEEXPR_percentLOC_;
15781 /* Fall through. */
15782 case FFEEXPR_percentLOC_:
15783 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
15784 ffelex_token_kill (ffeexpr_tokens_[1]);
15785 ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
15786 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
15787 FFEEXPR_contextLOC_,
15788 ffeexpr_cb_end_loc_);
15789 }
15790 }
15791
15792 /* ffeexpr_make_float_const_ -- Make a floating-point constant
15793
15794 See prototype.
15795
15796 Pass 'E', 'D', or 'Q' for exponent letter. */
15797
15798 static void
15799 ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
15800 ffelexToken decimal, ffelexToken fraction,
15801 ffelexToken exponent, ffelexToken exponent_sign,
15802 ffelexToken exponent_digits)
15803 {
15804 ffeexprExpr_ e;
15805
15806 e = ffeexpr_expr_new_ ();
15807 e->type = FFEEXPR_exprtypeOPERAND_;
15808 if (integer != NULL)
15809 e->token = ffelex_token_use (integer);
15810 else
15811 {
15812 assert (decimal != NULL);
15813 e->token = ffelex_token_use (decimal);
15814 }
15815
15816 switch (exp_letter)
15817 {
15818 #if !FFETARGET_okREALQUAD
15819 case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
15820 if (ffebad_start (FFEBAD_QUAD_UNSUPPORTED))
15821 {
15822 ffebad_here (0, ffelex_token_where_line (e->token),
15823 ffelex_token_where_column (e->token));
15824 ffebad_finish ();
15825 }
15826 goto match_d; /* The FFESRC_CASE_* macros don't
15827 allow fall-through! */
15828 #endif
15829
15830 case FFESRC_CASE_MATCH_INIT ('D', 'd', match_d, no_match):
15831 e->u.operand = ffebld_new_conter (ffebld_constant_new_realdouble
15832 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15833 ffebld_set_info (e->u.operand,
15834 ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
15835 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15836 break;
15837
15838 case FFESRC_CASE_MATCH_INIT ('E', 'e', match_e, no_match):
15839 e->u.operand = ffebld_new_conter (ffebld_constant_new_realdefault
15840 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15841 ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeREAL,
15842 FFEINFO_kindtypeREALDEFAULT, 0, FFEINFO_kindENTITY,
15843 FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15844 break;
15845
15846 #if FFETARGET_okREALQUAD
15847 case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
15848 e->u.operand = ffebld_new_conter (ffebld_constant_new_realquad
15849 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15850 ffebld_set_info (e->u.operand,
15851 ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALQUAD,
15852 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15853 break;
15854 #endif
15855
15856 default:
15857 no_match: /* :::::::::::::::::::: */
15858 assert ("Lost the exponent letter!" == NULL);
15859 }
15860
15861 ffeexpr_exprstack_push_operand_ (e);
15862 }
15863
15864 /* Just like ffesymbol_declare_local, except performs any implicit info
15865 assignment necessary. */
15866
15867 static ffesymbol
15868 ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin)
15869 {
15870 ffesymbol s;
15871 ffeinfoKind k;
15872 bool bad;
15873
15874 s = ffesymbol_declare_local (t, maybe_intrin);
15875
15876 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15877 /* Special-case these since they can involve a different concept
15878 of "state" (in the stmtfunc name space). */
15879 {
15880 case FFEEXPR_contextDATAIMPDOINDEX_:
15881 case FFEEXPR_contextDATAIMPDOCTRL_:
15882 if (ffeexpr_context_outer_ (ffeexpr_stack_)
15883 == FFEEXPR_contextDATAIMPDOINDEX_)
15884 s = ffeexpr_sym_impdoitem_ (s, t);
15885 else
15886 if (ffeexpr_stack_->is_rhs)
15887 s = ffeexpr_sym_impdoitem_ (s, t);
15888 else
15889 s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
15890 bad = (ffesymbol_kind (s) != FFEINFO_kindENTITY)
15891 || ((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
15892 && (ffesymbol_where (s) != FFEINFO_whereIMMEDIATE));
15893 if (bad && (ffesymbol_kind (s) != FFEINFO_kindANY))
15894 ffesymbol_error (s, t);
15895 return s;
15896
15897 default:
15898 break;
15899 }
15900
15901 switch ((ffesymbol_sfdummyparent (s) == NULL)
15902 ? ffesymbol_state (s)
15903 : FFESYMBOL_stateUNDERSTOOD)
15904 {
15905 case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr
15906 context. */
15907 if (!ffest_seen_first_exec ())
15908 goto seen; /* :::::::::::::::::::: */
15909 /* Fall through. */
15910 case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */
15911 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15912 {
15913 case FFEEXPR_contextSUBROUTINEREF:
15914 s = ffeexpr_sym_lhs_call_ (s, t);
15915 break;
15916
15917 case FFEEXPR_contextFILEEXTFUNC:
15918 s = ffeexpr_sym_lhs_extfunc_ (s, t);
15919 break;
15920
15921 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15922 s = ffecom_sym_exec_transition (s);
15923 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15924 goto understood; /* :::::::::::::::::::: */
15925 /* Fall through. */
15926 case FFEEXPR_contextACTUALARG_:
15927 s = ffeexpr_sym_rhs_actualarg_ (s, t);
15928 break;
15929
15930 case FFEEXPR_contextDATA:
15931 if (ffeexpr_stack_->is_rhs)
15932 s = ffeexpr_sym_rhs_let_ (s, t);
15933 else
15934 s = ffeexpr_sym_lhs_data_ (s, t);
15935 break;
15936
15937 case FFEEXPR_contextDATAIMPDOITEM_:
15938 s = ffeexpr_sym_lhs_data_ (s, t);
15939 break;
15940
15941 case FFEEXPR_contextSFUNCDEF:
15942 case FFEEXPR_contextSFUNCDEFINDEX_:
15943 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15944 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15945 s = ffecom_sym_exec_transition (s);
15946 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15947 goto understood; /* :::::::::::::::::::: */
15948 /* Fall through. */
15949 case FFEEXPR_contextLET:
15950 case FFEEXPR_contextPAREN_:
15951 case FFEEXPR_contextACTUALARGEXPR_:
15952 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15953 case FFEEXPR_contextASSIGN:
15954 case FFEEXPR_contextIOLIST:
15955 case FFEEXPR_contextIOLISTDF:
15956 case FFEEXPR_contextDO:
15957 case FFEEXPR_contextDOWHILE:
15958 case FFEEXPR_contextAGOTO:
15959 case FFEEXPR_contextCGOTO:
15960 case FFEEXPR_contextIF:
15961 case FFEEXPR_contextARITHIF:
15962 case FFEEXPR_contextFORMAT:
15963 case FFEEXPR_contextSTOP:
15964 case FFEEXPR_contextRETURN:
15965 case FFEEXPR_contextSELECTCASE:
15966 case FFEEXPR_contextCASE:
15967 case FFEEXPR_contextFILEASSOC:
15968 case FFEEXPR_contextFILEINT:
15969 case FFEEXPR_contextFILEDFINT:
15970 case FFEEXPR_contextFILELOG:
15971 case FFEEXPR_contextFILENUM:
15972 case FFEEXPR_contextFILENUMAMBIG:
15973 case FFEEXPR_contextFILECHAR:
15974 case FFEEXPR_contextFILENUMCHAR:
15975 case FFEEXPR_contextFILEDFCHAR:
15976 case FFEEXPR_contextFILEKEY:
15977 case FFEEXPR_contextFILEUNIT:
15978 case FFEEXPR_contextFILEUNIT_DF:
15979 case FFEEXPR_contextFILEUNITAMBIG:
15980 case FFEEXPR_contextFILEFORMAT:
15981 case FFEEXPR_contextFILENAMELIST:
15982 case FFEEXPR_contextFILEVXTCODE:
15983 case FFEEXPR_contextINDEX_:
15984 case FFEEXPR_contextIMPDOITEM_:
15985 case FFEEXPR_contextIMPDOITEMDF_:
15986 case FFEEXPR_contextIMPDOCTRL_:
15987 case FFEEXPR_contextLOC_:
15988 if (ffeexpr_stack_->is_rhs)
15989 s = ffeexpr_sym_rhs_let_ (s, t);
15990 else
15991 s = ffeexpr_sym_lhs_let_ (s, t);
15992 break;
15993
15994 case FFEEXPR_contextCHARACTERSIZE:
15995 case FFEEXPR_contextEQUIVALENCE:
15996 case FFEEXPR_contextINCLUDE:
15997 case FFEEXPR_contextPARAMETER:
15998 case FFEEXPR_contextDIMLIST:
15999 case FFEEXPR_contextDIMLISTCOMMON:
16000 case FFEEXPR_contextKINDTYPE:
16001 case FFEEXPR_contextINITVAL:
16002 case FFEEXPR_contextEQVINDEX_:
16003 break; /* Will turn into errors below. */
16004
16005 default:
16006 ffesymbol_error (s, t);
16007 break;
16008 }
16009 /* Fall through. */
16010 case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */
16011 understood: /* :::::::::::::::::::: */
16012 k = ffesymbol_kind (s);
16013 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16014 {
16015 case FFEEXPR_contextSUBROUTINEREF:
16016 bad = ((k != FFEINFO_kindSUBROUTINE)
16017 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
16018 || (k != FFEINFO_kindNONE)));
16019 break;
16020
16021 case FFEEXPR_contextFILEEXTFUNC:
16022 bad = (k != FFEINFO_kindFUNCTION)
16023 || (ffesymbol_where (s) != FFEINFO_whereGLOBAL);
16024 break;
16025
16026 case FFEEXPR_contextSFUNCDEFACTUALARG_:
16027 case FFEEXPR_contextACTUALARG_:
16028 switch (k)
16029 {
16030 case FFEINFO_kindENTITY:
16031 bad = FALSE;
16032 break;
16033
16034 case FFEINFO_kindFUNCTION:
16035 case FFEINFO_kindSUBROUTINE:
16036 bad
16037 = ((ffesymbol_where (s) != FFEINFO_whereGLOBAL)
16038 && (ffesymbol_where (s) != FFEINFO_whereDUMMY)
16039 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
16040 || !ffeintrin_is_actualarg (ffesymbol_specific (s))));
16041 break;
16042
16043 case FFEINFO_kindNONE:
16044 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
16045 {
16046 bad = !(ffeintrin_is_actualarg (ffesymbol_specific (s)));
16047 break;
16048 }
16049
16050 /* If state is UNDERSTOOD here, it's CHAR*(*) or attrsANY,
16051 and in the former case, attrsTYPE is set, so we
16052 see this as an error as we should, since CHAR*(*)
16053 cannot be actually referenced in a main/block data
16054 program unit. */
16055
16056 if ((ffesymbol_attrs (s) & (FFESYMBOL_attrsANY
16057 | FFESYMBOL_attrsEXTERNAL
16058 | FFESYMBOL_attrsTYPE))
16059 == FFESYMBOL_attrsEXTERNAL)
16060 bad = FALSE;
16061 else
16062 bad = TRUE;
16063 break;
16064
16065 default:
16066 bad = TRUE;
16067 break;
16068 }
16069 break;
16070
16071 case FFEEXPR_contextDATA:
16072 if (ffeexpr_stack_->is_rhs)
16073 bad = (k != FFEINFO_kindENTITY)
16074 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16075 else
16076 bad = (k != FFEINFO_kindENTITY)
16077 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
16078 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
16079 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
16080 break;
16081
16082 case FFEEXPR_contextDATAIMPDOITEM_:
16083 bad = TRUE; /* Unadorned item never valid. */
16084 break;
16085
16086 case FFEEXPR_contextSFUNCDEF:
16087 case FFEEXPR_contextSFUNCDEFINDEX_:
16088 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16089 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16090 case FFEEXPR_contextLET:
16091 case FFEEXPR_contextPAREN_:
16092 case FFEEXPR_contextACTUALARGEXPR_:
16093 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16094 case FFEEXPR_contextASSIGN:
16095 case FFEEXPR_contextIOLIST:
16096 case FFEEXPR_contextIOLISTDF:
16097 case FFEEXPR_contextDO:
16098 case FFEEXPR_contextDOWHILE:
16099 case FFEEXPR_contextAGOTO:
16100 case FFEEXPR_contextCGOTO:
16101 case FFEEXPR_contextIF:
16102 case FFEEXPR_contextARITHIF:
16103 case FFEEXPR_contextFORMAT:
16104 case FFEEXPR_contextSTOP:
16105 case FFEEXPR_contextRETURN:
16106 case FFEEXPR_contextSELECTCASE:
16107 case FFEEXPR_contextCASE:
16108 case FFEEXPR_contextFILEASSOC:
16109 case FFEEXPR_contextFILEINT:
16110 case FFEEXPR_contextFILEDFINT:
16111 case FFEEXPR_contextFILELOG:
16112 case FFEEXPR_contextFILENUM:
16113 case FFEEXPR_contextFILENUMAMBIG:
16114 case FFEEXPR_contextFILECHAR:
16115 case FFEEXPR_contextFILENUMCHAR:
16116 case FFEEXPR_contextFILEDFCHAR:
16117 case FFEEXPR_contextFILEKEY:
16118 case FFEEXPR_contextFILEUNIT:
16119 case FFEEXPR_contextFILEUNIT_DF:
16120 case FFEEXPR_contextFILEUNITAMBIG:
16121 case FFEEXPR_contextFILEFORMAT:
16122 case FFEEXPR_contextFILENAMELIST:
16123 case FFEEXPR_contextFILEVXTCODE:
16124 case FFEEXPR_contextINDEX_:
16125 case FFEEXPR_contextIMPDOITEM_:
16126 case FFEEXPR_contextIMPDOITEMDF_:
16127 case FFEEXPR_contextIMPDOCTRL_:
16128 case FFEEXPR_contextLOC_:
16129 bad = (k != FFEINFO_kindENTITY); /* This catches "SUBROUTINE
16130 X(A);EXTERNAL A;CALL
16131 Y(A);B=A", for example. */
16132 break;
16133
16134 case FFEEXPR_contextCHARACTERSIZE:
16135 case FFEEXPR_contextEQUIVALENCE:
16136 case FFEEXPR_contextPARAMETER:
16137 case FFEEXPR_contextDIMLIST:
16138 case FFEEXPR_contextDIMLISTCOMMON:
16139 case FFEEXPR_contextKINDTYPE:
16140 case FFEEXPR_contextINITVAL:
16141 case FFEEXPR_contextEQVINDEX_:
16142 bad = (k != FFEINFO_kindENTITY)
16143 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16144 break;
16145
16146 case FFEEXPR_contextINCLUDE:
16147 bad = TRUE;
16148 break;
16149
16150 default:
16151 bad = TRUE;
16152 break;
16153 }
16154 if (bad && (k != FFEINFO_kindANY))
16155 ffesymbol_error (s, t);
16156 return s;
16157
16158 case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */
16159 seen: /* :::::::::::::::::::: */
16160 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16161 {
16162 case FFEEXPR_contextPARAMETER:
16163 if (ffeexpr_stack_->is_rhs)
16164 ffesymbol_error (s, t);
16165 else
16166 s = ffeexpr_sym_lhs_parameter_ (s, t);
16167 break;
16168
16169 case FFEEXPR_contextDATA:
16170 s = ffecom_sym_exec_transition (s);
16171 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16172 goto understood; /* :::::::::::::::::::: */
16173 if (ffeexpr_stack_->is_rhs)
16174 ffesymbol_error (s, t);
16175 else
16176 s = ffeexpr_sym_lhs_data_ (s, t);
16177 goto understood; /* :::::::::::::::::::: */
16178
16179 case FFEEXPR_contextDATAIMPDOITEM_:
16180 s = ffecom_sym_exec_transition (s);
16181 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16182 goto understood; /* :::::::::::::::::::: */
16183 s = ffeexpr_sym_lhs_data_ (s, t);
16184 goto understood; /* :::::::::::::::::::: */
16185
16186 case FFEEXPR_contextEQUIVALENCE:
16187 s = ffeexpr_sym_lhs_equivalence_ (s, t);
16188 break;
16189
16190 case FFEEXPR_contextDIMLIST:
16191 s = ffeexpr_sym_rhs_dimlist_ (s, t);
16192 break;
16193
16194 case FFEEXPR_contextCHARACTERSIZE:
16195 case FFEEXPR_contextKINDTYPE:
16196 case FFEEXPR_contextDIMLISTCOMMON:
16197 case FFEEXPR_contextINITVAL:
16198 case FFEEXPR_contextEQVINDEX_:
16199 ffesymbol_error (s, t);
16200 break;
16201
16202 case FFEEXPR_contextINCLUDE:
16203 ffesymbol_error (s, t);
16204 break;
16205
16206 case FFEEXPR_contextACTUALARG_: /* E.g. I in REAL A(Y(I)). */
16207 case FFEEXPR_contextSFUNCDEFACTUALARG_:
16208 s = ffecom_sym_exec_transition (s);
16209 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16210 goto understood; /* :::::::::::::::::::: */
16211 s = ffeexpr_sym_rhs_actualarg_ (s, t);
16212 goto understood; /* :::::::::::::::::::: */
16213
16214 case FFEEXPR_contextINDEX_:
16215 case FFEEXPR_contextACTUALARGEXPR_:
16216 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16217 case FFEEXPR_contextSFUNCDEF:
16218 case FFEEXPR_contextSFUNCDEFINDEX_:
16219 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16220 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16221 assert (ffeexpr_stack_->is_rhs);
16222 s = ffecom_sym_exec_transition (s);
16223 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16224 goto understood; /* :::::::::::::::::::: */
16225 s = ffeexpr_sym_rhs_let_ (s, t);
16226 goto understood; /* :::::::::::::::::::: */
16227
16228 default:
16229 ffesymbol_error (s, t);
16230 break;
16231 }
16232 return s;
16233
16234 default:
16235 assert ("bad symbol state" == NULL);
16236 return NULL;
16237 break;
16238 }
16239 }
16240
16241 /* Have FOO in DATA (XYZ(FOO),...)/.../ or DATA (...,XYZ=FOO,BAR,BLETCH).
16242 Could be found via the "statement-function" name space (in which case
16243 it should become an iterator) or the local name space (in which case
16244 it should be either a named constant, or a variable that will have an
16245 sfunc name space sibling that should become an iterator). */
16246
16247 static ffesymbol
16248 ffeexpr_sym_impdoitem_ (ffesymbol sp, ffelexToken t)
16249 {
16250 ffesymbol s;
16251 ffesymbolAttrs sa;
16252 ffesymbolAttrs na;
16253 ffesymbolState ss;
16254 ffesymbolState ns;
16255 ffeinfoKind kind;
16256 ffeinfoWhere where;
16257
16258 ss = ffesymbol_state (sp);
16259
16260 if (ffesymbol_sfdummyparent (sp) != NULL)
16261 { /* Have symbol in sfunc name space. */
16262 switch (ss)
16263 {
16264 case FFESYMBOL_stateNONE: /* Used as iterator already. */
16265 if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
16266 ffesymbol_error (sp, t); /* Can't use dead iterator. */
16267 else
16268 { /* Can use dead iterator because we're at at
16269 least an innermore (higher-numbered) level
16270 than the iterator's outermost
16271 (lowest-numbered) level. */
16272 ffesymbol_signal_change (sp);
16273 ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
16274 ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
16275 ffesymbol_signal_unreported (sp);
16276 }
16277 break;
16278
16279 case FFESYMBOL_stateSEEN: /* Seen already in this or other
16280 implied-DO. Set symbol level
16281 number to outermost value, as that
16282 tells us we can see it as iterator
16283 at that level at the innermost. */
16284 if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
16285 {
16286 ffesymbol_signal_change (sp);
16287 ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
16288 ffesymbol_signal_unreported (sp);
16289 }
16290 break;
16291
16292 case FFESYMBOL_stateUNCERTAIN: /* Iterator. */
16293 assert (ffeexpr_level_ == ffesymbol_maxentrynum (sp));
16294 ffesymbol_error (sp, t); /* (,,,I=I,10). */
16295 break;
16296
16297 case FFESYMBOL_stateUNDERSTOOD:
16298 break; /* ANY. */
16299
16300 default:
16301 assert ("Foo Bar!!" == NULL);
16302 break;
16303 }
16304
16305 return sp;
16306 }
16307
16308 /* Got symbol in local name space, so we haven't seen it in impdo yet.
16309 First, if it is brand-new and we're in executable statements, set the
16310 attributes and exec-transition it to set state UNCERTAIN or UNDERSTOOD.
16311 Second, if it is now a constant (PARAMETER), then just return it, it
16312 can't be an implied-do iterator. If it is understood, complain if it is
16313 not a valid variable, but make the inner name space iterator anyway and
16314 return that. If it is not understood, improve understanding of the
16315 symbol accordingly, complain accordingly, in either case make the inner
16316 name space iterator and return that. */
16317
16318 sa = ffesymbol_attrs (sp);
16319
16320 if (ffesymbol_state_is_specable (ss)
16321 && ffest_seen_first_exec ())
16322 {
16323 assert (sa == FFESYMBOL_attrsetNONE);
16324 ffesymbol_signal_change (sp);
16325 ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
16326 ffesymbol_resolve_intrin (sp);
16327 if (ffeimplic_establish_symbol (sp))
16328 ffesymbol_set_attr (sp, FFESYMBOL_attrSFARG);
16329 else
16330 ffesymbol_error (sp, t);
16331
16332 /* After the exec transition, the state will either be UNCERTAIN (could
16333 be a dummy or local var) or UNDERSTOOD (local var, because this is a
16334 PROGRAM/BLOCKDATA program unit). */
16335
16336 sp = ffecom_sym_exec_transition (sp);
16337 sa = ffesymbol_attrs (sp);
16338 ss = ffesymbol_state (sp);
16339 }
16340
16341 ns = ss;
16342 kind = ffesymbol_kind (sp);
16343 where = ffesymbol_where (sp);
16344
16345 if (ss == FFESYMBOL_stateUNDERSTOOD)
16346 {
16347 if (kind != FFEINFO_kindENTITY)
16348 ffesymbol_error (sp, t);
16349 if (where == FFEINFO_whereCONSTANT)
16350 return sp;
16351 }
16352 else
16353 {
16354 /* Enhance understanding of local symbol. This used to imply exec
16355 transition, but that doesn't seem necessary, since the local symbol
16356 doesn't actually get put into an ffebld tree here -- we just learn
16357 more about it, just like when we see a local symbol's name in the
16358 dummy-arg list of a statement function. */
16359
16360 if (ss != FFESYMBOL_stateUNCERTAIN)
16361 {
16362 /* Figure out what kind of object we've got based on previous
16363 declarations of or references to the object. */
16364
16365 ns = FFESYMBOL_stateSEEN;
16366
16367 if (sa & FFESYMBOL_attrsANY)
16368 na = sa;
16369 else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
16370 | FFESYMBOL_attrsANY
16371 | FFESYMBOL_attrsCOMMON
16372 | FFESYMBOL_attrsDUMMY
16373 | FFESYMBOL_attrsEQUIV
16374 | FFESYMBOL_attrsINIT
16375 | FFESYMBOL_attrsNAMELIST
16376 | FFESYMBOL_attrsRESULT
16377 | FFESYMBOL_attrsSAVE
16378 | FFESYMBOL_attrsSFARG
16379 | FFESYMBOL_attrsTYPE)))
16380 na = sa | FFESYMBOL_attrsSFARG;
16381 else
16382 na = FFESYMBOL_attrsetNONE;
16383 }
16384 else
16385 { /* stateUNCERTAIN. */
16386 na = sa | FFESYMBOL_attrsSFARG;
16387 ns = FFESYMBOL_stateUNDERSTOOD;
16388
16389 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16390 | FFESYMBOL_attrsADJUSTABLE
16391 | FFESYMBOL_attrsANYLEN
16392 | FFESYMBOL_attrsARRAY
16393 | FFESYMBOL_attrsDUMMY
16394 | FFESYMBOL_attrsEXTERNAL
16395 | FFESYMBOL_attrsSFARG
16396 | FFESYMBOL_attrsTYPE)));
16397
16398 if (sa & FFESYMBOL_attrsEXTERNAL)
16399 {
16400 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16401 | FFESYMBOL_attrsDUMMY
16402 | FFESYMBOL_attrsEXTERNAL
16403 | FFESYMBOL_attrsTYPE)));
16404
16405 na = FFESYMBOL_attrsetNONE;
16406 }
16407 else if (sa & FFESYMBOL_attrsDUMMY)
16408 {
16409 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16410 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16411 | FFESYMBOL_attrsEXTERNAL
16412 | FFESYMBOL_attrsTYPE)));
16413
16414 kind = FFEINFO_kindENTITY;
16415 }
16416 else if (sa & FFESYMBOL_attrsARRAY)
16417 {
16418 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16419 | FFESYMBOL_attrsADJUSTABLE
16420 | FFESYMBOL_attrsTYPE)));
16421
16422 na = FFESYMBOL_attrsetNONE;
16423 }
16424 else if (sa & FFESYMBOL_attrsSFARG)
16425 {
16426 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16427 | FFESYMBOL_attrsTYPE)));
16428
16429 ns = FFESYMBOL_stateUNCERTAIN;
16430 }
16431 else if (sa & FFESYMBOL_attrsTYPE)
16432 {
16433 assert (!(sa & (FFESYMBOL_attrsARRAY
16434 | FFESYMBOL_attrsDUMMY
16435 | FFESYMBOL_attrsEXTERNAL
16436 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16437 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16438 | FFESYMBOL_attrsADJUSTABLE
16439 | FFESYMBOL_attrsANYLEN
16440 | FFESYMBOL_attrsARRAY
16441 | FFESYMBOL_attrsDUMMY
16442 | FFESYMBOL_attrsEXTERNAL
16443 | FFESYMBOL_attrsSFARG)));
16444
16445 kind = FFEINFO_kindENTITY;
16446
16447 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16448 na = FFESYMBOL_attrsetNONE;
16449 else if (ffest_is_entry_valid ())
16450 ns = FFESYMBOL_stateUNCERTAIN; /* Could be DUMMY or LOCAL. */
16451 else
16452 where = FFEINFO_whereLOCAL;
16453 }
16454 else
16455 na = FFESYMBOL_attrsetNONE; /* Error. */
16456 }
16457
16458 /* Now see what we've got for a new object: NONE means a new error
16459 cropped up; ANY means an old error to be ignored; otherwise,
16460 everything's ok, update the object (symbol) and continue on. */
16461
16462 if (na == FFESYMBOL_attrsetNONE)
16463 ffesymbol_error (sp, t);
16464 else if (!(na & FFESYMBOL_attrsANY))
16465 {
16466 ffesymbol_signal_change (sp); /* May need to back up to previous
16467 version. */
16468 if (!ffeimplic_establish_symbol (sp))
16469 ffesymbol_error (sp, t);
16470 ffesymbol_set_info (sp,
16471 ffeinfo_new (ffesymbol_basictype (sp),
16472 ffesymbol_kindtype (sp),
16473 ffesymbol_rank (sp),
16474 kind,
16475 where,
16476 ffesymbol_size (sp)));
16477 ffesymbol_set_attrs (sp, na);
16478 ffesymbol_set_state (sp, ns);
16479 ffesymbol_resolve_intrin (sp);
16480 if (!ffesymbol_state_is_specable (ns))
16481 sp = ffecom_sym_learned (sp);
16482 ffesymbol_signal_unreported (sp); /* For debugging purposes. */
16483 }
16484 }
16485
16486 /* Here we create the sfunc-name-space symbol representing what should
16487 become an iterator in this name space at this or an outermore (lower-
16488 numbered) expression level, else the implied-DO construct is in error. */
16489
16490 s = ffesymbol_declare_sfdummy (t); /* Sets maxentrynum to 0 for new obj;
16491 also sets sfa_dummy_parent to
16492 parent symbol. */
16493 assert (sp == ffesymbol_sfdummyparent (s));
16494
16495 ffesymbol_signal_change (s);
16496 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
16497 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
16498 ffesymbol_set_info (s,
16499 ffeinfo_new (FFEINFO_basictypeINTEGER,
16500 FFEINFO_kindtypeINTEGERDEFAULT,
16501 0,
16502 FFEINFO_kindENTITY,
16503 FFEINFO_whereIMMEDIATE,
16504 FFETARGET_charactersizeNONE));
16505 ffesymbol_signal_unreported (s);
16506
16507 if (((ffesymbol_basictype (sp) != FFEINFO_basictypeINTEGER)
16508 && (ffesymbol_basictype (sp) != FFEINFO_basictypeANY))
16509 || ((ffesymbol_kindtype (sp) != FFEINFO_kindtypeINTEGERDEFAULT)
16510 && (ffesymbol_kindtype (sp) != FFEINFO_kindtypeANY)))
16511 ffesymbol_error (s, t);
16512
16513 return s;
16514 }
16515
16516 /* Have FOO in CALL FOO. Local name space, executable context only. */
16517
16518 static ffesymbol
16519 ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t)
16520 {
16521 ffesymbolAttrs sa;
16522 ffesymbolAttrs na;
16523 ffeinfoKind kind;
16524 ffeinfoWhere where;
16525 ffeintrinGen gen;
16526 ffeintrinSpec spec;
16527 ffeintrinImp imp;
16528 bool error = FALSE;
16529
16530 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16531 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16532
16533 na = sa = ffesymbol_attrs (s);
16534
16535 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16536 | FFESYMBOL_attrsADJUSTABLE
16537 | FFESYMBOL_attrsANYLEN
16538 | FFESYMBOL_attrsARRAY
16539 | FFESYMBOL_attrsDUMMY
16540 | FFESYMBOL_attrsEXTERNAL
16541 | FFESYMBOL_attrsSFARG
16542 | FFESYMBOL_attrsTYPE)));
16543
16544 kind = ffesymbol_kind (s);
16545 where = ffesymbol_where (s);
16546
16547 /* Figure out what kind of object we've got based on previous declarations
16548 of or references to the object. */
16549
16550 if (sa & FFESYMBOL_attrsEXTERNAL)
16551 {
16552 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16553 | FFESYMBOL_attrsDUMMY
16554 | FFESYMBOL_attrsEXTERNAL
16555 | FFESYMBOL_attrsTYPE)));
16556
16557 if (sa & FFESYMBOL_attrsTYPE)
16558 error = TRUE;
16559 else
16560 /* Not TYPE. */
16561 {
16562 kind = FFEINFO_kindSUBROUTINE;
16563
16564 if (sa & FFESYMBOL_attrsDUMMY)
16565 ; /* Not TYPE. */
16566 else if (sa & FFESYMBOL_attrsACTUALARG)
16567 ; /* Not DUMMY or TYPE. */
16568 else /* Not ACTUALARG, DUMMY, or TYPE. */
16569 where = FFEINFO_whereGLOBAL;
16570 }
16571 }
16572 else if (sa & FFESYMBOL_attrsDUMMY)
16573 {
16574 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16575 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16576 | FFESYMBOL_attrsEXTERNAL
16577 | FFESYMBOL_attrsTYPE)));
16578
16579 if (sa & FFESYMBOL_attrsTYPE)
16580 error = TRUE;
16581 else
16582 kind = FFEINFO_kindSUBROUTINE;
16583 }
16584 else if (sa & FFESYMBOL_attrsARRAY)
16585 {
16586 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16587 | FFESYMBOL_attrsADJUSTABLE
16588 | FFESYMBOL_attrsTYPE)));
16589
16590 error = TRUE;
16591 }
16592 else if (sa & FFESYMBOL_attrsSFARG)
16593 {
16594 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16595 | FFESYMBOL_attrsTYPE)));
16596
16597 error = TRUE;
16598 }
16599 else if (sa & FFESYMBOL_attrsTYPE)
16600 {
16601 assert (!(sa & (FFESYMBOL_attrsARRAY
16602 | FFESYMBOL_attrsDUMMY
16603 | FFESYMBOL_attrsEXTERNAL
16604 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16605 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16606 | FFESYMBOL_attrsADJUSTABLE
16607 | FFESYMBOL_attrsANYLEN
16608 | FFESYMBOL_attrsARRAY
16609 | FFESYMBOL_attrsDUMMY
16610 | FFESYMBOL_attrsEXTERNAL
16611 | FFESYMBOL_attrsSFARG)));
16612
16613 error = TRUE;
16614 }
16615 else if (sa == FFESYMBOL_attrsetNONE)
16616 {
16617 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16618
16619 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
16620 &gen, &spec, &imp))
16621 {
16622 ffesymbol_signal_change (s); /* May need to back up to previous
16623 version. */
16624 ffesymbol_set_generic (s, gen);
16625 ffesymbol_set_specific (s, spec);
16626 ffesymbol_set_implementation (s, imp);
16627 ffesymbol_set_info (s,
16628 ffeinfo_new (FFEINFO_basictypeNONE,
16629 FFEINFO_kindtypeNONE,
16630 0,
16631 FFEINFO_kindSUBROUTINE,
16632 FFEINFO_whereINTRINSIC,
16633 FFETARGET_charactersizeNONE));
16634 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16635 ffesymbol_resolve_intrin (s);
16636 ffesymbol_reference (s, t, FALSE);
16637 s = ffecom_sym_learned (s);
16638 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16639
16640 return s;
16641 }
16642
16643 kind = FFEINFO_kindSUBROUTINE;
16644 where = FFEINFO_whereGLOBAL;
16645 }
16646 else
16647 error = TRUE;
16648
16649 /* Now see what we've got for a new object: NONE means a new error cropped
16650 up; ANY means an old error to be ignored; otherwise, everything's ok,
16651 update the object (symbol) and continue on. */
16652
16653 if (error)
16654 ffesymbol_error (s, t);
16655 else if (!(na & FFESYMBOL_attrsANY))
16656 {
16657 ffesymbol_signal_change (s); /* May need to back up to previous
16658 version. */
16659 ffesymbol_set_info (s,
16660 ffeinfo_new (ffesymbol_basictype (s),
16661 ffesymbol_kindtype (s),
16662 ffesymbol_rank (s),
16663 kind, /* SUBROUTINE. */
16664 where, /* GLOBAL or DUMMY. */
16665 ffesymbol_size (s)));
16666 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16667 ffesymbol_resolve_intrin (s);
16668 ffesymbol_reference (s, t, FALSE);
16669 s = ffecom_sym_learned (s);
16670 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16671 }
16672
16673 return s;
16674 }
16675
16676 /* Have FOO in DATA FOO/.../. Local name space and executable context
16677 only. (This will change in the future when DATA FOO may be followed
16678 by COMMON FOO or even INTEGER FOO(10), etc.) */
16679
16680 static ffesymbol
16681 ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t)
16682 {
16683 ffesymbolAttrs sa;
16684 ffesymbolAttrs na;
16685 ffeinfoKind kind;
16686 ffeinfoWhere where;
16687 bool error = FALSE;
16688
16689 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16690 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16691
16692 na = sa = ffesymbol_attrs (s);
16693
16694 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16695 | FFESYMBOL_attrsADJUSTABLE
16696 | FFESYMBOL_attrsANYLEN
16697 | FFESYMBOL_attrsARRAY
16698 | FFESYMBOL_attrsDUMMY
16699 | FFESYMBOL_attrsEXTERNAL
16700 | FFESYMBOL_attrsSFARG
16701 | FFESYMBOL_attrsTYPE)));
16702
16703 kind = ffesymbol_kind (s);
16704 where = ffesymbol_where (s);
16705
16706 /* Figure out what kind of object we've got based on previous declarations
16707 of or references to the object. */
16708
16709 if (sa & FFESYMBOL_attrsEXTERNAL)
16710 {
16711 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16712 | FFESYMBOL_attrsDUMMY
16713 | FFESYMBOL_attrsEXTERNAL
16714 | FFESYMBOL_attrsTYPE)));
16715
16716 error = TRUE;
16717 }
16718 else if (sa & FFESYMBOL_attrsDUMMY)
16719 {
16720 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16721 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16722 | FFESYMBOL_attrsEXTERNAL
16723 | FFESYMBOL_attrsTYPE)));
16724
16725 error = TRUE;
16726 }
16727 else if (sa & FFESYMBOL_attrsARRAY)
16728 {
16729 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16730 | FFESYMBOL_attrsADJUSTABLE
16731 | FFESYMBOL_attrsTYPE)));
16732
16733 if (sa & FFESYMBOL_attrsADJUSTABLE)
16734 error = TRUE;
16735 where = FFEINFO_whereLOCAL;
16736 }
16737 else if (sa & FFESYMBOL_attrsSFARG)
16738 {
16739 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16740 | FFESYMBOL_attrsTYPE)));
16741
16742 where = FFEINFO_whereLOCAL;
16743 }
16744 else if (sa & FFESYMBOL_attrsTYPE)
16745 {
16746 assert (!(sa & (FFESYMBOL_attrsARRAY
16747 | FFESYMBOL_attrsDUMMY
16748 | FFESYMBOL_attrsEXTERNAL
16749 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16750 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16751 | FFESYMBOL_attrsADJUSTABLE
16752 | FFESYMBOL_attrsANYLEN
16753 | FFESYMBOL_attrsARRAY
16754 | FFESYMBOL_attrsDUMMY
16755 | FFESYMBOL_attrsEXTERNAL
16756 | FFESYMBOL_attrsSFARG)));
16757
16758 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16759 error = TRUE;
16760 else
16761 {
16762 kind = FFEINFO_kindENTITY;
16763 where = FFEINFO_whereLOCAL;
16764 }
16765 }
16766 else if (sa == FFESYMBOL_attrsetNONE)
16767 {
16768 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16769 kind = FFEINFO_kindENTITY;
16770 where = FFEINFO_whereLOCAL;
16771 }
16772 else
16773 error = TRUE;
16774
16775 /* Now see what we've got for a new object: NONE means a new error cropped
16776 up; ANY means an old error to be ignored; otherwise, everything's ok,
16777 update the object (symbol) and continue on. */
16778
16779 if (error)
16780 ffesymbol_error (s, t);
16781 else if (!(na & FFESYMBOL_attrsANY))
16782 {
16783 ffesymbol_signal_change (s); /* May need to back up to previous
16784 version. */
16785 if (!ffeimplic_establish_symbol (s))
16786 {
16787 ffesymbol_error (s, t);
16788 return s;
16789 }
16790 ffesymbol_set_info (s,
16791 ffeinfo_new (ffesymbol_basictype (s),
16792 ffesymbol_kindtype (s),
16793 ffesymbol_rank (s),
16794 kind, /* ENTITY. */
16795 where, /* LOCAL. */
16796 ffesymbol_size (s)));
16797 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16798 ffesymbol_resolve_intrin (s);
16799 s = ffecom_sym_learned (s);
16800 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16801 }
16802
16803 return s;
16804 }
16805
16806 /* Have FOO in EQUIVALENCE (...,FOO,...). Does not include
16807 EQUIVALENCE (...,BAR(FOO),...). */
16808
16809 static ffesymbol
16810 ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t)
16811 {
16812 ffesymbolAttrs sa;
16813 ffesymbolAttrs na;
16814 ffeinfoKind kind;
16815 ffeinfoWhere where;
16816
16817 na = sa = ffesymbol_attrs (s);
16818 kind = FFEINFO_kindENTITY;
16819 where = ffesymbol_where (s);
16820
16821 /* Figure out what kind of object we've got based on previous declarations
16822 of or references to the object. */
16823
16824 if (!(sa & ~(FFESYMBOL_attrsADJUSTS
16825 | FFESYMBOL_attrsARRAY
16826 | FFESYMBOL_attrsCOMMON
16827 | FFESYMBOL_attrsEQUIV
16828 | FFESYMBOL_attrsINIT
16829 | FFESYMBOL_attrsNAMELIST
16830 | FFESYMBOL_attrsSAVE
16831 | FFESYMBOL_attrsSFARG
16832 | FFESYMBOL_attrsTYPE)))
16833 na = sa | FFESYMBOL_attrsEQUIV;
16834 else
16835 na = FFESYMBOL_attrsetNONE;
16836
16837 /* Don't know why we're bothering to set kind and where in this code, but
16838 added the following to make it complete, in case it's really important.
16839 Generally this is left up to symbol exec transition. */
16840
16841 if (where == FFEINFO_whereNONE)
16842 {
16843 if (na & (FFESYMBOL_attrsADJUSTS
16844 | FFESYMBOL_attrsCOMMON))
16845 where = FFEINFO_whereCOMMON;
16846 else if (na & FFESYMBOL_attrsSAVE)
16847 where = FFEINFO_whereLOCAL;
16848 }
16849
16850 /* Now see what we've got for a new object: NONE means a new error cropped
16851 up; ANY means an old error to be ignored; otherwise, everything's ok,
16852 update the object (symbol) and continue on. */
16853
16854 if (na == FFESYMBOL_attrsetNONE)
16855 ffesymbol_error (s, t);
16856 else if (!(na & FFESYMBOL_attrsANY))
16857 {
16858 ffesymbol_signal_change (s); /* May need to back up to previous
16859 version. */
16860 ffesymbol_set_info (s,
16861 ffeinfo_new (ffesymbol_basictype (s),
16862 ffesymbol_kindtype (s),
16863 ffesymbol_rank (s),
16864 kind, /* Always ENTITY. */
16865 where, /* NONE, COMMON, or LOCAL. */
16866 ffesymbol_size (s)));
16867 ffesymbol_set_attrs (s, na);
16868 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
16869 ffesymbol_resolve_intrin (s);
16870 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16871 }
16872
16873 return s;
16874 }
16875
16876 /* Have FOO in OPEN(...,USEROPEN=FOO,...). Executable context only.
16877
16878 Note that I think this should be considered semantically similar to
16879 doing CALL XYZ(FOO), in that it should be considered like an
16880 ACTUALARG context. In particular, without EXTERNAL being specified,
16881 it should not be allowed. */
16882
16883 static ffesymbol
16884 ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t)
16885 {
16886 ffesymbolAttrs sa;
16887 ffesymbolAttrs na;
16888 ffeinfoKind kind;
16889 ffeinfoWhere where;
16890 bool needs_type = FALSE;
16891 bool error = FALSE;
16892
16893 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16894 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16895
16896 na = sa = ffesymbol_attrs (s);
16897
16898 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16899 | FFESYMBOL_attrsADJUSTABLE
16900 | FFESYMBOL_attrsANYLEN
16901 | FFESYMBOL_attrsARRAY
16902 | FFESYMBOL_attrsDUMMY
16903 | FFESYMBOL_attrsEXTERNAL
16904 | FFESYMBOL_attrsSFARG
16905 | FFESYMBOL_attrsTYPE)));
16906
16907 kind = ffesymbol_kind (s);
16908 where = ffesymbol_where (s);
16909
16910 /* Figure out what kind of object we've got based on previous declarations
16911 of or references to the object. */
16912
16913 if (sa & FFESYMBOL_attrsEXTERNAL)
16914 {
16915 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16916 | FFESYMBOL_attrsDUMMY
16917 | FFESYMBOL_attrsEXTERNAL
16918 | FFESYMBOL_attrsTYPE)));
16919
16920 if (sa & FFESYMBOL_attrsTYPE)
16921 where = FFEINFO_whereGLOBAL;
16922 else
16923 /* Not TYPE. */
16924 {
16925 kind = FFEINFO_kindFUNCTION;
16926 needs_type = TRUE;
16927
16928 if (sa & FFESYMBOL_attrsDUMMY)
16929 ; /* Not TYPE. */
16930 else if (sa & FFESYMBOL_attrsACTUALARG)
16931 ; /* Not DUMMY or TYPE. */
16932 else /* Not ACTUALARG, DUMMY, or TYPE. */
16933 where = FFEINFO_whereGLOBAL;
16934 }
16935 }
16936 else if (sa & FFESYMBOL_attrsDUMMY)
16937 {
16938 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16939 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16940 | FFESYMBOL_attrsEXTERNAL
16941 | FFESYMBOL_attrsTYPE)));
16942
16943 kind = FFEINFO_kindFUNCTION;
16944 if (!(sa & FFESYMBOL_attrsTYPE))
16945 needs_type = TRUE;
16946 }
16947 else if (sa & FFESYMBOL_attrsARRAY)
16948 {
16949 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16950 | FFESYMBOL_attrsADJUSTABLE
16951 | FFESYMBOL_attrsTYPE)));
16952
16953 error = TRUE;
16954 }
16955 else if (sa & FFESYMBOL_attrsSFARG)
16956 {
16957 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16958 | FFESYMBOL_attrsTYPE)));
16959
16960 error = TRUE;
16961 }
16962 else if (sa & FFESYMBOL_attrsTYPE)
16963 {
16964 assert (!(sa & (FFESYMBOL_attrsARRAY
16965 | FFESYMBOL_attrsDUMMY
16966 | FFESYMBOL_attrsEXTERNAL
16967 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16968 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16969 | FFESYMBOL_attrsADJUSTABLE
16970 | FFESYMBOL_attrsANYLEN
16971 | FFESYMBOL_attrsARRAY
16972 | FFESYMBOL_attrsDUMMY
16973 | FFESYMBOL_attrsEXTERNAL
16974 | FFESYMBOL_attrsSFARG)));
16975
16976 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16977 error = TRUE;
16978 else
16979 {
16980 kind = FFEINFO_kindFUNCTION;
16981 where = FFEINFO_whereGLOBAL;
16982 }
16983 }
16984 else if (sa == FFESYMBOL_attrsetNONE)
16985 {
16986 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16987 kind = FFEINFO_kindFUNCTION;
16988 where = FFEINFO_whereGLOBAL;
16989 needs_type = TRUE;
16990 }
16991 else
16992 error = TRUE;
16993
16994 /* Now see what we've got for a new object: NONE means a new error cropped
16995 up; ANY means an old error to be ignored; otherwise, everything's ok,
16996 update the object (symbol) and continue on. */
16997
16998 if (error)
16999 ffesymbol_error (s, t);
17000 else if (!(na & FFESYMBOL_attrsANY))
17001 {
17002 ffesymbol_signal_change (s); /* May need to back up to previous
17003 version. */
17004 if (needs_type && !ffeimplic_establish_symbol (s))
17005 {
17006 ffesymbol_error (s, t);
17007 return s;
17008 }
17009 if (!ffesymbol_explicitwhere (s))
17010 {
17011 ffebad_start (FFEBAD_NEED_EXTERNAL);
17012 ffebad_here (0, ffelex_token_where_line (t),
17013 ffelex_token_where_column (t));
17014 ffebad_string (ffesymbol_text (s));
17015 ffebad_finish ();
17016 ffesymbol_set_explicitwhere (s, TRUE);
17017 }
17018 ffesymbol_set_info (s,
17019 ffeinfo_new (ffesymbol_basictype (s),
17020 ffesymbol_kindtype (s),
17021 ffesymbol_rank (s),
17022 kind, /* FUNCTION. */
17023 where, /* GLOBAL or DUMMY. */
17024 ffesymbol_size (s)));
17025 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17026 ffesymbol_resolve_intrin (s);
17027 ffesymbol_reference (s, t, FALSE);
17028 s = ffecom_sym_learned (s);
17029 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17030 }
17031
17032 return s;
17033 }
17034
17035 /* Have FOO in DATA (stuff,FOO=1,10)/.../. */
17036
17037 static ffesymbol
17038 ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t)
17039 {
17040 ffesymbolState ss;
17041
17042 /* If the symbol isn't in the sfunc name space, pretend as though we saw a
17043 reference to it already within the imp-DO construct at this level, so as
17044 to get a symbol that is in the sfunc name space. But this is an
17045 erroneous construct, and should be caught elsewhere. */
17046
17047 if (ffesymbol_sfdummyparent (s) == NULL)
17048 {
17049 s = ffeexpr_sym_impdoitem_ (s, t);
17050 if (ffesymbol_sfdummyparent (s) == NULL)
17051 { /* PARAMETER FOO...DATA (A(I),FOO=...). */
17052 ffesymbol_error (s, t);
17053 return s;
17054 }
17055 }
17056
17057 ss = ffesymbol_state (s);
17058
17059 switch (ss)
17060 {
17061 case FFESYMBOL_stateNONE: /* Used as iterator already. */
17062 if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
17063 ffesymbol_error (s, t); /* Can't reuse dead iterator. F90 disallows
17064 this; F77 allows it but it is a stupid
17065 feature. */
17066 else
17067 { /* Can use dead iterator because we're at at
17068 least a innermore (higher-numbered) level
17069 than the iterator's outermost
17070 (lowest-numbered) level. This should be
17071 diagnosed later, because it means an item
17072 in this list didn't reference this
17073 iterator. */
17074 #if 1
17075 ffesymbol_error (s, t); /* For now, complain. */
17076 #else /* Someday will detect all cases where initializer doesn't reference
17077 all applicable iterators, in which case reenable this code. */
17078 ffesymbol_signal_change (s);
17079 ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
17080 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
17081 ffesymbol_signal_unreported (s);
17082 #endif
17083 }
17084 break;
17085
17086 case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO.
17087 If seen in outermore level, can't be an
17088 iterator here, so complain. If not seen
17089 at current level, complain for now,
17090 because that indicates something F90
17091 rejects (though we currently don't detect
17092 all such cases for now). */
17093 if (ffeexpr_level_ <= ffesymbol_maxentrynum (s))
17094 {
17095 ffesymbol_signal_change (s);
17096 ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
17097 ffesymbol_signal_unreported (s);
17098 }
17099 else
17100 ffesymbol_error (s, t);
17101 break;
17102
17103 case FFESYMBOL_stateUNCERTAIN: /* Already iterator! */
17104 assert ("DATA implied-DO control var seen twice!!" == NULL);
17105 ffesymbol_error (s, t);
17106 break;
17107
17108 case FFESYMBOL_stateUNDERSTOOD:
17109 break; /* ANY. */
17110
17111 default:
17112 assert ("Foo Bletch!!" == NULL);
17113 break;
17114 }
17115
17116 return s;
17117 }
17118
17119 /* Have FOO in PARAMETER (FOO=...). */
17120
17121 static ffesymbol
17122 ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t)
17123 {
17124 ffesymbolAttrs sa;
17125
17126 sa = ffesymbol_attrs (s);
17127
17128 /* Figure out what kind of object we've got based on previous declarations
17129 of or references to the object. */
17130
17131 if (sa & ~(FFESYMBOL_attrsANYLEN
17132 | FFESYMBOL_attrsTYPE))
17133 {
17134 if (!(sa & FFESYMBOL_attrsANY))
17135 ffesymbol_error (s, t);
17136 }
17137 else
17138 {
17139 ffesymbol_signal_change (s); /* May need to back up to previous
17140 version. */
17141 if (!ffeimplic_establish_symbol (s))
17142 {
17143 ffesymbol_error (s, t);
17144 return s;
17145 }
17146 ffesymbol_set_info (s,
17147 ffeinfo_new (ffesymbol_basictype (s),
17148 ffesymbol_kindtype (s),
17149 ffesymbol_rank (s),
17150 FFEINFO_kindENTITY,
17151 FFEINFO_whereCONSTANT,
17152 ffesymbol_size (s)));
17153 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17154 ffesymbol_resolve_intrin (s);
17155 s = ffecom_sym_learned (s);
17156 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17157 }
17158
17159 return s;
17160 }
17161
17162 /* Have FOO in CALL XYZ(...,FOO,...). Does not include any other
17163 embedding of FOO, such as CALL XYZ((FOO)) or CALL XYZ(FOO+1). */
17164
17165 static ffesymbol
17166 ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t)
17167 {
17168 ffesymbolAttrs sa;
17169 ffesymbolAttrs na;
17170 ffeinfoKind kind;
17171 ffeinfoWhere where;
17172 ffesymbolState ns;
17173 bool needs_type = FALSE;
17174
17175 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
17176 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
17177
17178 na = sa = ffesymbol_attrs (s);
17179
17180 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17181 | FFESYMBOL_attrsADJUSTABLE
17182 | FFESYMBOL_attrsANYLEN
17183 | FFESYMBOL_attrsARRAY
17184 | FFESYMBOL_attrsDUMMY
17185 | FFESYMBOL_attrsEXTERNAL
17186 | FFESYMBOL_attrsSFARG
17187 | FFESYMBOL_attrsTYPE)));
17188
17189 kind = ffesymbol_kind (s);
17190 where = ffesymbol_where (s);
17191
17192 /* Figure out what kind of object we've got based on previous declarations
17193 of or references to the object. */
17194
17195 ns = FFESYMBOL_stateUNDERSTOOD;
17196
17197 if (sa & FFESYMBOL_attrsEXTERNAL)
17198 {
17199 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17200 | FFESYMBOL_attrsDUMMY
17201 | FFESYMBOL_attrsEXTERNAL
17202 | FFESYMBOL_attrsTYPE)));
17203
17204 if (sa & FFESYMBOL_attrsTYPE)
17205 where = FFEINFO_whereGLOBAL;
17206 else
17207 /* Not TYPE. */
17208 {
17209 ns = FFESYMBOL_stateUNCERTAIN;
17210
17211 if (sa & FFESYMBOL_attrsDUMMY)
17212 assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */
17213 else if (sa & FFESYMBOL_attrsACTUALARG)
17214 ; /* Not DUMMY or TYPE. */
17215 else
17216 /* Not ACTUALARG, DUMMY, or TYPE. */
17217 {
17218 assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */
17219 na |= FFESYMBOL_attrsACTUALARG;
17220 where = FFEINFO_whereGLOBAL;
17221 }
17222 }
17223 }
17224 else if (sa & FFESYMBOL_attrsDUMMY)
17225 {
17226 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
17227 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
17228 | FFESYMBOL_attrsEXTERNAL
17229 | FFESYMBOL_attrsTYPE)));
17230
17231 kind = FFEINFO_kindENTITY;
17232 if (!(sa & FFESYMBOL_attrsTYPE))
17233 needs_type = TRUE;
17234 }
17235 else if (sa & FFESYMBOL_attrsARRAY)
17236 {
17237 assert (!(sa & ~(FFESYMBOL_attrsARRAY
17238 | FFESYMBOL_attrsADJUSTABLE
17239 | FFESYMBOL_attrsTYPE)));
17240
17241 where = FFEINFO_whereLOCAL;
17242 }
17243 else if (sa & FFESYMBOL_attrsSFARG)
17244 {
17245 assert (!(sa & ~(FFESYMBOL_attrsSFARG
17246 | FFESYMBOL_attrsTYPE)));
17247
17248 where = FFEINFO_whereLOCAL;
17249 }
17250 else if (sa & FFESYMBOL_attrsTYPE)
17251 {
17252 assert (!(sa & (FFESYMBOL_attrsARRAY
17253 | FFESYMBOL_attrsDUMMY
17254 | FFESYMBOL_attrsEXTERNAL
17255 | FFESYMBOL_attrsSFARG))); /* Handled above. */
17256 assert (!(sa & ~(FFESYMBOL_attrsTYPE
17257 | FFESYMBOL_attrsADJUSTABLE
17258 | FFESYMBOL_attrsANYLEN
17259 | FFESYMBOL_attrsARRAY
17260 | FFESYMBOL_attrsDUMMY
17261 | FFESYMBOL_attrsEXTERNAL
17262 | FFESYMBOL_attrsSFARG)));
17263
17264 if (sa & FFESYMBOL_attrsANYLEN)
17265 ns = FFESYMBOL_stateNONE;
17266 else
17267 {
17268 kind = FFEINFO_kindENTITY;
17269 where = FFEINFO_whereLOCAL;
17270 }
17271 }
17272 else if (sa == FFESYMBOL_attrsetNONE)
17273 {
17274 /* New state is left empty because there isn't any state flag to
17275 set for this case, and it's UNDERSTOOD after all. */
17276 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
17277 kind = FFEINFO_kindENTITY;
17278 where = FFEINFO_whereLOCAL;
17279 needs_type = TRUE;
17280 }
17281 else
17282 ns = FFESYMBOL_stateNONE; /* Error. */
17283
17284 /* Now see what we've got for a new object: NONE means a new error cropped
17285 up; ANY means an old error to be ignored; otherwise, everything's ok,
17286 update the object (symbol) and continue on. */
17287
17288 if (ns == FFESYMBOL_stateNONE)
17289 ffesymbol_error (s, t);
17290 else if (!(na & FFESYMBOL_attrsANY))
17291 {
17292 ffesymbol_signal_change (s); /* May need to back up to previous
17293 version. */
17294 if (needs_type && !ffeimplic_establish_symbol (s))
17295 {
17296 ffesymbol_error (s, t);
17297 return s;
17298 }
17299 ffesymbol_set_info (s,
17300 ffeinfo_new (ffesymbol_basictype (s),
17301 ffesymbol_kindtype (s),
17302 ffesymbol_rank (s),
17303 kind,
17304 where,
17305 ffesymbol_size (s)));
17306 ffesymbol_set_attrs (s, na);
17307 ffesymbol_set_state (s, ns);
17308 s = ffecom_sym_learned (s);
17309 ffesymbol_reference (s, t, FALSE);
17310 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17311 }
17312
17313 return s;
17314 }
17315
17316 /* Have FOO in DIMENSION XYZ(FOO) or any array declarator containing
17317 a reference to FOO. */
17318
17319 static ffesymbol
17320 ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t)
17321 {
17322 ffesymbolAttrs sa;
17323 ffesymbolAttrs na;
17324 ffeinfoKind kind;
17325 ffeinfoWhere where;
17326
17327 na = sa = ffesymbol_attrs (s);
17328 kind = FFEINFO_kindENTITY;
17329 where = ffesymbol_where (s);
17330
17331 /* Figure out what kind of object we've got based on previous declarations
17332 of or references to the object. */
17333
17334 if (!(sa & ~(FFESYMBOL_attrsADJUSTS
17335 | FFESYMBOL_attrsCOMMON
17336 | FFESYMBOL_attrsDUMMY
17337 | FFESYMBOL_attrsEQUIV
17338 | FFESYMBOL_attrsINIT
17339 | FFESYMBOL_attrsNAMELIST
17340 | FFESYMBOL_attrsSFARG
17341 | FFESYMBOL_attrsTYPE)))
17342 na = sa | FFESYMBOL_attrsADJUSTS;
17343 else
17344 na = FFESYMBOL_attrsetNONE;
17345
17346 /* Since this symbol definitely is going into an expression (the
17347 dimension-list for some dummy array, presumably), figure out WHERE if
17348 possible. */
17349
17350 if (where == FFEINFO_whereNONE)
17351 {
17352 if (na & (FFESYMBOL_attrsCOMMON
17353 | FFESYMBOL_attrsEQUIV
17354 | FFESYMBOL_attrsINIT
17355 | FFESYMBOL_attrsNAMELIST))
17356 where = FFEINFO_whereCOMMON;
17357 else if (na & FFESYMBOL_attrsDUMMY)
17358 where = FFEINFO_whereDUMMY;
17359 }
17360
17361 /* Now see what we've got for a new object: NONE means a new error cropped
17362 up; ANY means an old error to be ignored; otherwise, everything's ok,
17363 update the object (symbol) and continue on. */
17364
17365 if (na == FFESYMBOL_attrsetNONE)
17366 ffesymbol_error (s, t);
17367 else if (!(na & FFESYMBOL_attrsANY))
17368 {
17369 ffesymbol_signal_change (s); /* May need to back up to previous
17370 version. */
17371 if (!ffeimplic_establish_symbol (s))
17372 {
17373 ffesymbol_error (s, t);
17374 return s;
17375 }
17376 ffesymbol_set_info (s,
17377 ffeinfo_new (ffesymbol_basictype (s),
17378 ffesymbol_kindtype (s),
17379 ffesymbol_rank (s),
17380 kind, /* Always ENTITY. */
17381 where, /* NONE, COMMON, or DUMMY. */
17382 ffesymbol_size (s)));
17383 ffesymbol_set_attrs (s, na);
17384 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
17385 ffesymbol_resolve_intrin (s);
17386 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17387 }
17388
17389 return s;
17390 }
17391
17392 /* Have FOO in XYZ = ...FOO.... Does not include cases like FOO in
17393 XYZ = BAR(FOO), as such cases are handled elsewhere. */
17394
17395 static ffesymbol
17396 ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t)
17397 {
17398 ffesymbolAttrs sa;
17399 ffesymbolAttrs na;
17400 ffeinfoKind kind;
17401 ffeinfoWhere where;
17402 bool error = FALSE;
17403
17404 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
17405 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
17406
17407 na = sa = ffesymbol_attrs (s);
17408
17409 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17410 | FFESYMBOL_attrsADJUSTABLE
17411 | FFESYMBOL_attrsANYLEN
17412 | FFESYMBOL_attrsARRAY
17413 | FFESYMBOL_attrsDUMMY
17414 | FFESYMBOL_attrsEXTERNAL
17415 | FFESYMBOL_attrsSFARG
17416 | FFESYMBOL_attrsTYPE)));
17417
17418 kind = ffesymbol_kind (s);
17419 where = ffesymbol_where (s);
17420
17421 /* Figure out what kind of object we've got based on previous declarations
17422 of or references to the object. */
17423
17424 if (sa & FFESYMBOL_attrsEXTERNAL)
17425 {
17426 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17427 | FFESYMBOL_attrsDUMMY
17428 | FFESYMBOL_attrsEXTERNAL
17429 | FFESYMBOL_attrsTYPE)));
17430
17431 error = TRUE;
17432 }
17433 else if (sa & FFESYMBOL_attrsDUMMY)
17434 {
17435 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
17436 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
17437 | FFESYMBOL_attrsEXTERNAL
17438 | FFESYMBOL_attrsTYPE)));
17439
17440 kind = FFEINFO_kindENTITY;
17441 }
17442 else if (sa & FFESYMBOL_attrsARRAY)
17443 {
17444 assert (!(sa & ~(FFESYMBOL_attrsARRAY
17445 | FFESYMBOL_attrsADJUSTABLE
17446 | FFESYMBOL_attrsTYPE)));
17447
17448 where = FFEINFO_whereLOCAL;
17449 }
17450 else if (sa & FFESYMBOL_attrsSFARG)
17451 {
17452 assert (!(sa & ~(FFESYMBOL_attrsSFARG
17453 | FFESYMBOL_attrsTYPE)));
17454
17455 where = FFEINFO_whereLOCAL;
17456 }
17457 else if (sa & FFESYMBOL_attrsTYPE)
17458 {
17459 assert (!(sa & (FFESYMBOL_attrsARRAY
17460 | FFESYMBOL_attrsDUMMY
17461 | FFESYMBOL_attrsEXTERNAL
17462 | FFESYMBOL_attrsSFARG))); /* Handled above. */
17463 assert (!(sa & ~(FFESYMBOL_attrsTYPE
17464 | FFESYMBOL_attrsADJUSTABLE
17465 | FFESYMBOL_attrsANYLEN
17466 | FFESYMBOL_attrsARRAY
17467 | FFESYMBOL_attrsDUMMY
17468 | FFESYMBOL_attrsEXTERNAL
17469 | FFESYMBOL_attrsSFARG)));
17470
17471 if (sa & FFESYMBOL_attrsANYLEN)
17472 error = TRUE;
17473 else
17474 {
17475 kind = FFEINFO_kindENTITY;
17476 where = FFEINFO_whereLOCAL;
17477 }
17478 }
17479 else if (sa == FFESYMBOL_attrsetNONE)
17480 {
17481 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
17482 kind = FFEINFO_kindENTITY;
17483 where = FFEINFO_whereLOCAL;
17484 }
17485 else
17486 error = TRUE;
17487
17488 /* Now see what we've got for a new object: NONE means a new error cropped
17489 up; ANY means an old error to be ignored; otherwise, everything's ok,
17490 update the object (symbol) and continue on. */
17491
17492 if (error)
17493 ffesymbol_error (s, t);
17494 else if (!(na & FFESYMBOL_attrsANY))
17495 {
17496 ffesymbol_signal_change (s); /* May need to back up to previous
17497 version. */
17498 if (!ffeimplic_establish_symbol (s))
17499 {
17500 ffesymbol_error (s, t);
17501 return s;
17502 }
17503 ffesymbol_set_info (s,
17504 ffeinfo_new (ffesymbol_basictype (s),
17505 ffesymbol_kindtype (s),
17506 ffesymbol_rank (s),
17507 kind, /* ENTITY. */
17508 where, /* LOCAL. */
17509 ffesymbol_size (s)));
17510 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17511 ffesymbol_resolve_intrin (s);
17512 s = ffecom_sym_learned (s);
17513 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17514 }
17515
17516 return s;
17517 }
17518
17519 /* ffeexpr_declare_parenthesized_ -- ffesymbol wrapper for NAME(...) operand
17520
17521 ffelexToken t;
17522 bool maybe_intrin;
17523 ffeexprParenType_ paren_type;
17524 ffesymbol s;
17525 s = ffeexpr_declare_parenthesized_ (t, maybe_intrin, &paren_type);
17526
17527 Just like ffesymbol_declare_local, except performs any implicit info
17528 assignment necessary, and it returns the type of the parenthesized list
17529 (list of function args, list of array args, or substring spec). */
17530
17531 static ffesymbol
17532 ffeexpr_declare_parenthesized_ (ffelexToken t, bool maybe_intrin,
17533 ffeexprParenType_ *paren_type)
17534 {
17535 ffesymbol s;
17536 ffesymbolState st; /* Effective state. */
17537 ffeinfoKind k;
17538 bool bad;
17539
17540 if (maybe_intrin && ffesrc_check_symbol ())
17541 { /* Knock off some easy cases. */
17542 switch (ffeexpr_stack_->context)
17543 {
17544 case FFEEXPR_contextSUBROUTINEREF:
17545 case FFEEXPR_contextDATA:
17546 case FFEEXPR_contextDATAIMPDOINDEX_:
17547 case FFEEXPR_contextSFUNCDEF:
17548 case FFEEXPR_contextSFUNCDEFINDEX_:
17549 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17550 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17551 case FFEEXPR_contextLET:
17552 case FFEEXPR_contextPAREN_:
17553 case FFEEXPR_contextACTUALARGEXPR_:
17554 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17555 case FFEEXPR_contextIOLIST:
17556 case FFEEXPR_contextIOLISTDF:
17557 case FFEEXPR_contextDO:
17558 case FFEEXPR_contextDOWHILE:
17559 case FFEEXPR_contextACTUALARG_:
17560 case FFEEXPR_contextCGOTO:
17561 case FFEEXPR_contextIF:
17562 case FFEEXPR_contextARITHIF:
17563 case FFEEXPR_contextFORMAT:
17564 case FFEEXPR_contextSTOP:
17565 case FFEEXPR_contextRETURN:
17566 case FFEEXPR_contextSELECTCASE:
17567 case FFEEXPR_contextCASE:
17568 case FFEEXPR_contextFILEASSOC:
17569 case FFEEXPR_contextFILEINT:
17570 case FFEEXPR_contextFILEDFINT:
17571 case FFEEXPR_contextFILELOG:
17572 case FFEEXPR_contextFILENUM:
17573 case FFEEXPR_contextFILENUMAMBIG:
17574 case FFEEXPR_contextFILECHAR:
17575 case FFEEXPR_contextFILENUMCHAR:
17576 case FFEEXPR_contextFILEDFCHAR:
17577 case FFEEXPR_contextFILEKEY:
17578 case FFEEXPR_contextFILEUNIT:
17579 case FFEEXPR_contextFILEUNIT_DF:
17580 case FFEEXPR_contextFILEUNITAMBIG:
17581 case FFEEXPR_contextFILEFORMAT:
17582 case FFEEXPR_contextFILENAMELIST:
17583 case FFEEXPR_contextFILEVXTCODE:
17584 case FFEEXPR_contextINDEX_:
17585 case FFEEXPR_contextIMPDOITEM_:
17586 case FFEEXPR_contextIMPDOITEMDF_:
17587 case FFEEXPR_contextIMPDOCTRL_:
17588 case FFEEXPR_contextDATAIMPDOCTRL_:
17589 case FFEEXPR_contextCHARACTERSIZE:
17590 case FFEEXPR_contextPARAMETER:
17591 case FFEEXPR_contextDIMLIST:
17592 case FFEEXPR_contextDIMLISTCOMMON:
17593 case FFEEXPR_contextKINDTYPE:
17594 case FFEEXPR_contextINITVAL:
17595 case FFEEXPR_contextEQVINDEX_:
17596 break; /* These could be intrinsic invocations. */
17597
17598 case FFEEXPR_contextAGOTO:
17599 case FFEEXPR_contextFILEFORMATNML:
17600 case FFEEXPR_contextALLOCATE:
17601 case FFEEXPR_contextDEALLOCATE:
17602 case FFEEXPR_contextHEAPSTAT:
17603 case FFEEXPR_contextNULLIFY:
17604 case FFEEXPR_contextINCLUDE:
17605 case FFEEXPR_contextDATAIMPDOITEM_:
17606 case FFEEXPR_contextLOC_:
17607 case FFEEXPR_contextINDEXORACTUALARG_:
17608 case FFEEXPR_contextSFUNCDEFACTUALARG_:
17609 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
17610 case FFEEXPR_contextPARENFILENUM_:
17611 case FFEEXPR_contextPARENFILEUNIT_:
17612 maybe_intrin = FALSE;
17613 break; /* Can't be intrinsic invocation. */
17614
17615 default:
17616 assert ("blah! blah! waaauuggh!" == NULL);
17617 break;
17618 }
17619 }
17620
17621 s = ffesymbol_declare_local (t, maybe_intrin);
17622
17623 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17624 /* Special-case these since they can involve a different concept
17625 of "state" (in the stmtfunc name space). */
17626 {
17627 case FFEEXPR_contextDATAIMPDOINDEX_:
17628 case FFEEXPR_contextDATAIMPDOCTRL_:
17629 if (ffeexpr_context_outer_ (ffeexpr_stack_)
17630 == FFEEXPR_contextDATAIMPDOINDEX_)
17631 s = ffeexpr_sym_impdoitem_ (s, t);
17632 else
17633 if (ffeexpr_stack_->is_rhs)
17634 s = ffeexpr_sym_impdoitem_ (s, t);
17635 else
17636 s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
17637 if (ffesymbol_kind (s) != FFEINFO_kindANY)
17638 ffesymbol_error (s, t);
17639 return s;
17640
17641 default:
17642 break;
17643 }
17644
17645 switch ((ffesymbol_sfdummyparent (s) == NULL)
17646 ? ffesymbol_state (s)
17647 : FFESYMBOL_stateUNDERSTOOD)
17648 {
17649 case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr
17650 context. */
17651 if (!ffest_seen_first_exec ())
17652 goto seen; /* :::::::::::::::::::: */
17653 /* Fall through. */
17654 case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */
17655 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17656 {
17657 case FFEEXPR_contextSUBROUTINEREF:
17658 s = ffeexpr_sym_lhs_call_ (s, t); /* "CALL FOO"=="CALL
17659 FOO(...)". */
17660 break;
17661
17662 case FFEEXPR_contextDATA:
17663 if (ffeexpr_stack_->is_rhs)
17664 s = ffeexpr_sym_rhs_let_ (s, t);
17665 else
17666 s = ffeexpr_sym_lhs_data_ (s, t);
17667 break;
17668
17669 case FFEEXPR_contextDATAIMPDOITEM_:
17670 s = ffeexpr_sym_lhs_data_ (s, t);
17671 break;
17672
17673 case FFEEXPR_contextSFUNCDEF:
17674 case FFEEXPR_contextSFUNCDEFINDEX_:
17675 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17676 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17677 s = ffecom_sym_exec_transition (s);
17678 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17679 goto understood; /* :::::::::::::::::::: */
17680 /* Fall through. */
17681 case FFEEXPR_contextLET:
17682 case FFEEXPR_contextPAREN_:
17683 case FFEEXPR_contextACTUALARGEXPR_:
17684 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17685 case FFEEXPR_contextIOLIST:
17686 case FFEEXPR_contextIOLISTDF:
17687 case FFEEXPR_contextDO:
17688 case FFEEXPR_contextDOWHILE:
17689 case FFEEXPR_contextACTUALARG_:
17690 case FFEEXPR_contextCGOTO:
17691 case FFEEXPR_contextIF:
17692 case FFEEXPR_contextARITHIF:
17693 case FFEEXPR_contextFORMAT:
17694 case FFEEXPR_contextSTOP:
17695 case FFEEXPR_contextRETURN:
17696 case FFEEXPR_contextSELECTCASE:
17697 case FFEEXPR_contextCASE:
17698 case FFEEXPR_contextFILEASSOC:
17699 case FFEEXPR_contextFILEINT:
17700 case FFEEXPR_contextFILEDFINT:
17701 case FFEEXPR_contextFILELOG:
17702 case FFEEXPR_contextFILENUM:
17703 case FFEEXPR_contextFILENUMAMBIG:
17704 case FFEEXPR_contextFILECHAR:
17705 case FFEEXPR_contextFILENUMCHAR:
17706 case FFEEXPR_contextFILEDFCHAR:
17707 case FFEEXPR_contextFILEKEY:
17708 case FFEEXPR_contextFILEUNIT:
17709 case FFEEXPR_contextFILEUNIT_DF:
17710 case FFEEXPR_contextFILEUNITAMBIG:
17711 case FFEEXPR_contextFILEFORMAT:
17712 case FFEEXPR_contextFILENAMELIST:
17713 case FFEEXPR_contextFILEVXTCODE:
17714 case FFEEXPR_contextINDEX_:
17715 case FFEEXPR_contextIMPDOITEM_:
17716 case FFEEXPR_contextIMPDOITEMDF_:
17717 case FFEEXPR_contextIMPDOCTRL_:
17718 case FFEEXPR_contextLOC_:
17719 if (ffeexpr_stack_->is_rhs)
17720 s = ffeexpr_paren_rhs_let_ (s, t);
17721 else
17722 s = ffeexpr_paren_lhs_let_ (s, t);
17723 break;
17724
17725 case FFEEXPR_contextASSIGN:
17726 case FFEEXPR_contextAGOTO:
17727 case FFEEXPR_contextCHARACTERSIZE:
17728 case FFEEXPR_contextEQUIVALENCE:
17729 case FFEEXPR_contextINCLUDE:
17730 case FFEEXPR_contextPARAMETER:
17731 case FFEEXPR_contextDIMLIST:
17732 case FFEEXPR_contextDIMLISTCOMMON:
17733 case FFEEXPR_contextKINDTYPE:
17734 case FFEEXPR_contextINITVAL:
17735 case FFEEXPR_contextEQVINDEX_:
17736 break; /* Will turn into errors below. */
17737
17738 default:
17739 ffesymbol_error (s, t);
17740 break;
17741 }
17742 /* Fall through. */
17743 case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */
17744 understood: /* :::::::::::::::::::: */
17745
17746 /* State might have changed, update it. */
17747 st = ((ffesymbol_sfdummyparent (s) == NULL)
17748 ? ffesymbol_state (s)
17749 : FFESYMBOL_stateUNDERSTOOD);
17750
17751 k = ffesymbol_kind (s);
17752 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17753 {
17754 case FFEEXPR_contextSUBROUTINEREF:
17755 bad = ((k != FFEINFO_kindSUBROUTINE)
17756 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
17757 || (k != FFEINFO_kindNONE)));
17758 break;
17759
17760 case FFEEXPR_contextDATA:
17761 if (ffeexpr_stack_->is_rhs)
17762 bad = (k != FFEINFO_kindENTITY)
17763 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
17764 else
17765 bad = (k != FFEINFO_kindENTITY)
17766 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
17767 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
17768 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
17769 break;
17770
17771 case FFEEXPR_contextDATAIMPDOITEM_:
17772 bad = (k != FFEINFO_kindENTITY) || (ffesymbol_rank (s) == 0)
17773 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
17774 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
17775 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
17776 break;
17777
17778 case FFEEXPR_contextSFUNCDEF:
17779 case FFEEXPR_contextSFUNCDEFINDEX_:
17780 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17781 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17782 case FFEEXPR_contextLET:
17783 case FFEEXPR_contextPAREN_:
17784 case FFEEXPR_contextACTUALARGEXPR_:
17785 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17786 case FFEEXPR_contextIOLIST:
17787 case FFEEXPR_contextIOLISTDF:
17788 case FFEEXPR_contextDO:
17789 case FFEEXPR_contextDOWHILE:
17790 case FFEEXPR_contextACTUALARG_:
17791 case FFEEXPR_contextCGOTO:
17792 case FFEEXPR_contextIF:
17793 case FFEEXPR_contextARITHIF:
17794 case FFEEXPR_contextFORMAT:
17795 case FFEEXPR_contextSTOP:
17796 case FFEEXPR_contextRETURN:
17797 case FFEEXPR_contextSELECTCASE:
17798 case FFEEXPR_contextCASE:
17799 case FFEEXPR_contextFILEASSOC:
17800 case FFEEXPR_contextFILEINT:
17801 case FFEEXPR_contextFILEDFINT:
17802 case FFEEXPR_contextFILELOG:
17803 case FFEEXPR_contextFILENUM:
17804 case FFEEXPR_contextFILENUMAMBIG:
17805 case FFEEXPR_contextFILECHAR:
17806 case FFEEXPR_contextFILENUMCHAR:
17807 case FFEEXPR_contextFILEDFCHAR:
17808 case FFEEXPR_contextFILEKEY:
17809 case FFEEXPR_contextFILEUNIT:
17810 case FFEEXPR_contextFILEUNIT_DF:
17811 case FFEEXPR_contextFILEUNITAMBIG:
17812 case FFEEXPR_contextFILEFORMAT:
17813 case FFEEXPR_contextFILENAMELIST:
17814 case FFEEXPR_contextFILEVXTCODE:
17815 case FFEEXPR_contextINDEX_:
17816 case FFEEXPR_contextIMPDOITEM_:
17817 case FFEEXPR_contextIMPDOITEMDF_:
17818 case FFEEXPR_contextIMPDOCTRL_:
17819 case FFEEXPR_contextLOC_:
17820 bad = FALSE; /* Let paren-switch handle the cases. */
17821 break;
17822
17823 case FFEEXPR_contextASSIGN:
17824 case FFEEXPR_contextAGOTO:
17825 case FFEEXPR_contextCHARACTERSIZE:
17826 case FFEEXPR_contextEQUIVALENCE:
17827 case FFEEXPR_contextPARAMETER:
17828 case FFEEXPR_contextDIMLIST:
17829 case FFEEXPR_contextDIMLISTCOMMON:
17830 case FFEEXPR_contextKINDTYPE:
17831 case FFEEXPR_contextINITVAL:
17832 case FFEEXPR_contextEQVINDEX_:
17833 bad = (k != FFEINFO_kindENTITY)
17834 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
17835 break;
17836
17837 case FFEEXPR_contextINCLUDE:
17838 bad = TRUE;
17839 break;
17840
17841 default:
17842 bad = TRUE;
17843 break;
17844 }
17845
17846 switch (bad ? FFEINFO_kindANY : k)
17847 {
17848 case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */
17849 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
17850 {
17851 if (ffeexpr_context_outer_ (ffeexpr_stack_)
17852 == FFEEXPR_contextSUBROUTINEREF)
17853 *paren_type = FFEEXPR_parentypeSUBROUTINE_;
17854 else
17855 *paren_type = FFEEXPR_parentypeFUNCTION_;
17856 break;
17857 }
17858 if (st == FFESYMBOL_stateUNDERSTOOD)
17859 {
17860 bad = TRUE;
17861 *paren_type = FFEEXPR_parentypeANY_;
17862 }
17863 else
17864 *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
17865 break;
17866
17867 case FFEINFO_kindFUNCTION:
17868 *paren_type = FFEEXPR_parentypeFUNCTION_;
17869 switch (ffesymbol_where (s))
17870 {
17871 case FFEINFO_whereLOCAL:
17872 bad = TRUE; /* Attempt to recurse! */
17873 break;
17874
17875 case FFEINFO_whereCONSTANT:
17876 bad = ((ffesymbol_sfexpr (s) == NULL)
17877 || (ffebld_op (ffesymbol_sfexpr (s))
17878 == FFEBLD_opANY)); /* Attempt to recurse! */
17879 break;
17880
17881 default:
17882 break;
17883 }
17884 break;
17885
17886 case FFEINFO_kindSUBROUTINE:
17887 if ((ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
17888 || (ffeexpr_stack_->previous != NULL))
17889 {
17890 bad = TRUE;
17891 *paren_type = FFEEXPR_parentypeANY_;
17892 break;
17893 }
17894
17895 *paren_type = FFEEXPR_parentypeSUBROUTINE_;
17896 switch (ffesymbol_where (s))
17897 {
17898 case FFEINFO_whereLOCAL:
17899 case FFEINFO_whereCONSTANT:
17900 bad = TRUE; /* Attempt to recurse! */
17901 break;
17902
17903 default:
17904 break;
17905 }
17906 break;
17907
17908 case FFEINFO_kindENTITY:
17909 if (ffesymbol_rank (s) == 0)
17910 {
17911 if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
17912 *paren_type = FFEEXPR_parentypeSUBSTRING_;
17913 else
17914 {
17915 bad = TRUE;
17916 *paren_type = FFEEXPR_parentypeANY_;
17917 }
17918 }
17919 else
17920 *paren_type = FFEEXPR_parentypeARRAY_;
17921 break;
17922
17923 default:
17924 case FFEINFO_kindANY:
17925 bad = TRUE;
17926 *paren_type = FFEEXPR_parentypeANY_;
17927 break;
17928 }
17929
17930 if (bad)
17931 {
17932 if (k == FFEINFO_kindANY)
17933 ffest_shutdown ();
17934 else
17935 ffesymbol_error (s, t);
17936 }
17937
17938 return s;
17939
17940 case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */
17941 seen: /* :::::::::::::::::::: */
17942 bad = TRUE;
17943 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17944 {
17945 case FFEEXPR_contextPARAMETER:
17946 if (ffeexpr_stack_->is_rhs)
17947 ffesymbol_error (s, t);
17948 else
17949 s = ffeexpr_sym_lhs_parameter_ (s, t);
17950 break;
17951
17952 case FFEEXPR_contextDATA:
17953 s = ffecom_sym_exec_transition (s);
17954 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17955 goto understood; /* :::::::::::::::::::: */
17956 if (ffeexpr_stack_->is_rhs)
17957 ffesymbol_error (s, t);
17958 else
17959 s = ffeexpr_sym_lhs_data_ (s, t);
17960 goto understood; /* :::::::::::::::::::: */
17961
17962 case FFEEXPR_contextDATAIMPDOITEM_:
17963 s = ffecom_sym_exec_transition (s);
17964 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17965 goto understood; /* :::::::::::::::::::: */
17966 s = ffeexpr_sym_lhs_data_ (s, t);
17967 goto understood; /* :::::::::::::::::::: */
17968
17969 case FFEEXPR_contextEQUIVALENCE:
17970 s = ffeexpr_sym_lhs_equivalence_ (s, t);
17971 bad = FALSE;
17972 break;
17973
17974 case FFEEXPR_contextDIMLIST:
17975 s = ffeexpr_sym_rhs_dimlist_ (s, t);
17976 break;
17977
17978 case FFEEXPR_contextCHARACTERSIZE:
17979 case FFEEXPR_contextKINDTYPE:
17980 case FFEEXPR_contextDIMLISTCOMMON:
17981 case FFEEXPR_contextINITVAL:
17982 case FFEEXPR_contextEQVINDEX_:
17983 break;
17984
17985 case FFEEXPR_contextINCLUDE:
17986 break;
17987
17988 case FFEEXPR_contextINDEX_:
17989 case FFEEXPR_contextACTUALARGEXPR_:
17990 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17991 case FFEEXPR_contextSFUNCDEF:
17992 case FFEEXPR_contextSFUNCDEFINDEX_:
17993 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17994 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17995 assert (ffeexpr_stack_->is_rhs);
17996 s = ffecom_sym_exec_transition (s);
17997 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17998 goto understood; /* :::::::::::::::::::: */
17999 s = ffeexpr_paren_rhs_let_ (s, t);
18000 goto understood; /* :::::::::::::::::::: */
18001
18002 default:
18003 break;
18004 }
18005 k = ffesymbol_kind (s);
18006 switch (bad ? FFEINFO_kindANY : k)
18007 {
18008 case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */
18009 *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
18010 break;
18011
18012 case FFEINFO_kindFUNCTION:
18013 *paren_type = FFEEXPR_parentypeFUNCTION_;
18014 switch (ffesymbol_where (s))
18015 {
18016 case FFEINFO_whereLOCAL:
18017 bad = TRUE; /* Attempt to recurse! */
18018 break;
18019
18020 case FFEINFO_whereCONSTANT:
18021 bad = ((ffesymbol_sfexpr (s) == NULL)
18022 || (ffebld_op (ffesymbol_sfexpr (s))
18023 == FFEBLD_opANY)); /* Attempt to recurse! */
18024 break;
18025
18026 default:
18027 break;
18028 }
18029 break;
18030
18031 case FFEINFO_kindSUBROUTINE:
18032 *paren_type = FFEEXPR_parentypeANY_;
18033 bad = TRUE; /* Cannot possibly be in
18034 contextSUBROUTINEREF. */
18035 break;
18036
18037 case FFEINFO_kindENTITY:
18038 if (ffesymbol_rank (s) == 0)
18039 {
18040 if (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE)
18041 *paren_type = FFEEXPR_parentypeEQUIVALENCE_;
18042 else if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
18043 *paren_type = FFEEXPR_parentypeSUBSTRING_;
18044 else
18045 {
18046 bad = TRUE;
18047 *paren_type = FFEEXPR_parentypeANY_;
18048 }
18049 }
18050 else
18051 *paren_type = FFEEXPR_parentypeARRAY_;
18052 break;
18053
18054 default:
18055 case FFEINFO_kindANY:
18056 bad = TRUE;
18057 *paren_type = FFEEXPR_parentypeANY_;
18058 break;
18059 }
18060
18061 if (bad)
18062 {
18063 if (k == FFEINFO_kindANY)
18064 ffest_shutdown ();
18065 else
18066 ffesymbol_error (s, t);
18067 }
18068
18069 return s;
18070
18071 default:
18072 assert ("bad symbol state" == NULL);
18073 return NULL;
18074 }
18075 }
18076
18077 /* Have FOO in XYZ = ...FOO(...).... Executable context only. */
18078
18079 static ffesymbol
18080 ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t)
18081 {
18082 ffesymbolAttrs sa;
18083 ffesymbolAttrs na;
18084 ffeinfoKind kind;
18085 ffeinfoWhere where;
18086 ffeintrinGen gen;
18087 ffeintrinSpec spec;
18088 ffeintrinImp imp;
18089 bool maybe_ambig = FALSE;
18090 bool error = FALSE;
18091
18092 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
18093 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
18094
18095 na = sa = ffesymbol_attrs (s);
18096
18097 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
18098 | FFESYMBOL_attrsADJUSTABLE
18099 | FFESYMBOL_attrsANYLEN
18100 | FFESYMBOL_attrsARRAY
18101 | FFESYMBOL_attrsDUMMY
18102 | FFESYMBOL_attrsEXTERNAL
18103 | FFESYMBOL_attrsSFARG
18104 | FFESYMBOL_attrsTYPE)));
18105
18106 kind = ffesymbol_kind (s);
18107 where = ffesymbol_where (s);
18108
18109 /* Figure out what kind of object we've got based on previous declarations
18110 of or references to the object. */
18111
18112 if (sa & FFESYMBOL_attrsEXTERNAL)
18113 {
18114 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
18115 | FFESYMBOL_attrsDUMMY
18116 | FFESYMBOL_attrsEXTERNAL
18117 | FFESYMBOL_attrsTYPE)));
18118
18119 if (sa & FFESYMBOL_attrsTYPE)
18120 where = FFEINFO_whereGLOBAL;
18121 else
18122 /* Not TYPE. */
18123 {
18124 kind = FFEINFO_kindFUNCTION;
18125
18126 if (sa & FFESYMBOL_attrsDUMMY)
18127 ; /* Not TYPE. */
18128 else if (sa & FFESYMBOL_attrsACTUALARG)
18129 ; /* Not DUMMY or TYPE. */
18130 else /* Not ACTUALARG, DUMMY, or TYPE. */
18131 where = FFEINFO_whereGLOBAL;
18132 }
18133 }
18134 else if (sa & FFESYMBOL_attrsDUMMY)
18135 {
18136 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
18137 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
18138 | FFESYMBOL_attrsEXTERNAL
18139 | FFESYMBOL_attrsTYPE)));
18140
18141 kind = FFEINFO_kindFUNCTION;
18142 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure; kind
18143 could be ENTITY w/substring ref. */
18144 }
18145 else if (sa & FFESYMBOL_attrsARRAY)
18146 {
18147 assert (!(sa & ~(FFESYMBOL_attrsARRAY
18148 | FFESYMBOL_attrsADJUSTABLE
18149 | FFESYMBOL_attrsTYPE)));
18150
18151 where = FFEINFO_whereLOCAL;
18152 }
18153 else if (sa & FFESYMBOL_attrsSFARG)
18154 {
18155 assert (!(sa & ~(FFESYMBOL_attrsSFARG
18156 | FFESYMBOL_attrsTYPE)));
18157
18158 where = FFEINFO_whereLOCAL; /* Actually an error, but at least we
18159 know it's a local var. */
18160 }
18161 else if (sa & FFESYMBOL_attrsTYPE)
18162 {
18163 assert (!(sa & (FFESYMBOL_attrsARRAY
18164 | FFESYMBOL_attrsDUMMY
18165 | FFESYMBOL_attrsEXTERNAL
18166 | FFESYMBOL_attrsSFARG))); /* Handled above. */
18167 assert (!(sa & ~(FFESYMBOL_attrsTYPE
18168 | FFESYMBOL_attrsADJUSTABLE
18169 | FFESYMBOL_attrsANYLEN
18170 | FFESYMBOL_attrsARRAY
18171 | FFESYMBOL_attrsDUMMY
18172 | FFESYMBOL_attrsEXTERNAL
18173 | FFESYMBOL_attrsSFARG)));
18174
18175 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
18176 &gen, &spec, &imp))
18177 {
18178 if (!(sa & FFESYMBOL_attrsANYLEN)
18179 && (ffeimplic_peek_symbol_type (s, NULL)
18180 == FFEINFO_basictypeCHARACTER))
18181 return s; /* Haven't learned anything yet. */
18182
18183 ffesymbol_signal_change (s); /* May need to back up to previous
18184 version. */
18185 ffesymbol_set_generic (s, gen);
18186 ffesymbol_set_specific (s, spec);
18187 ffesymbol_set_implementation (s, imp);
18188 ffesymbol_set_info (s,
18189 ffeinfo_new (ffesymbol_basictype (s),
18190 ffesymbol_kindtype (s),
18191 0,
18192 FFEINFO_kindFUNCTION,
18193 FFEINFO_whereINTRINSIC,
18194 ffesymbol_size (s)));
18195 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18196 ffesymbol_resolve_intrin (s);
18197 ffesymbol_reference (s, t, FALSE);
18198 s = ffecom_sym_learned (s);
18199 ffesymbol_signal_unreported (s); /* For debugging purposes. */
18200
18201 return s;
18202 }
18203 if (sa & FFESYMBOL_attrsANYLEN)
18204 error = TRUE; /* Error, since the only way we can,
18205 given CHARACTER*(*) FOO, accept
18206 FOO(...) is for FOO to be a dummy
18207 arg or constant, but it can't
18208 become either now. */
18209 else if (sa & FFESYMBOL_attrsADJUSTABLE)
18210 {
18211 kind = FFEINFO_kindENTITY;
18212 where = FFEINFO_whereLOCAL;
18213 }
18214 else
18215 {
18216 kind = FFEINFO_kindFUNCTION;
18217 where = FFEINFO_whereGLOBAL;
18218 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure;
18219 could be ENTITY/LOCAL w/substring ref. */
18220 }
18221 }
18222 else if (sa == FFESYMBOL_attrsetNONE)
18223 {
18224 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
18225
18226 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
18227 &gen, &spec, &imp))
18228 {
18229 if (ffeimplic_peek_symbol_type (s, NULL)
18230 == FFEINFO_basictypeCHARACTER)
18231 return s; /* Haven't learned anything yet. */
18232
18233 ffesymbol_signal_change (s); /* May need to back up to previous
18234 version. */
18235 ffesymbol_set_generic (s, gen);
18236 ffesymbol_set_specific (s, spec);
18237 ffesymbol_set_implementation (s, imp);
18238 ffesymbol_set_info (s,
18239 ffeinfo_new (ffesymbol_basictype (s),
18240 ffesymbol_kindtype (s),
18241 0,
18242 FFEINFO_kindFUNCTION,
18243 FFEINFO_whereINTRINSIC,
18244 ffesymbol_size (s)));
18245 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18246 ffesymbol_resolve_intrin (s);
18247 s = ffecom_sym_learned (s);
18248 ffesymbol_reference (s, t, FALSE);
18249 ffesymbol_signal_unreported (s); /* For debugging purposes. */
18250 return s;
18251 }
18252
18253 kind = FFEINFO_kindFUNCTION;
18254 where = FFEINFO_whereGLOBAL;
18255 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure;
18256 could be ENTITY/LOCAL w/substring ref. */
18257 }
18258 else
18259 error = TRUE;
18260
18261 /* Now see what we've got for a new object: NONE means a new error cropped
18262 up; ANY means an old error to be ignored; otherwise, everything's ok,
18263 update the object (symbol) and continue on. */
18264
18265 if (error)
18266 ffesymbol_error (s, t);
18267 else if (!(na & FFESYMBOL_attrsANY))
18268 {
18269 ffesymbol_signal_change (s); /* May need to back up to previous
18270 version. */
18271 if (!ffeimplic_establish_symbol (s))
18272 {
18273 ffesymbol_error (s, t);
18274 return s;
18275 }
18276 if (maybe_ambig
18277 && (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
18278 return s; /* Still not sure, let caller deal with it
18279 based on (...). */
18280
18281 ffesymbol_set_info (s,
18282 ffeinfo_new (ffesymbol_basictype (s),
18283 ffesymbol_kindtype (s),
18284 ffesymbol_rank (s),
18285 kind,
18286 where,
18287 ffesymbol_size (s)));
18288 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18289 ffesymbol_resolve_intrin (s);
18290 s = ffecom_sym_learned (s);
18291 ffesymbol_reference (s, t, FALSE);
18292 ffesymbol_signal_unreported (s); /* For debugging purposes. */
18293 }
18294
18295 return s;
18296 }
18297
18298 /* ffeexpr_token_arguments_ -- OPEN_PAREN [expr COMMA]...expr
18299
18300 Return a pointer to this function to the lexer (ffelex), which will
18301 invoke it for the next token.
18302
18303 Handle expression (which might be null) and COMMA or CLOSE_PAREN. */
18304
18305 static ffelexHandler
18306 ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr, ffelexToken t)
18307 {
18308 ffeexprExpr_ procedure;
18309 ffebld reduced;
18310 ffeinfo info;
18311 ffeexprContext ctx;
18312 bool check_intrin = FALSE; /* Set TRUE if intrinsic is REAL(Z) or AIMAG(Z). */
18313
18314 procedure = ffeexpr_stack_->exprstack;
18315 info = ffebld_info (procedure->u.operand);
18316
18317 /* Is there an expression to add? If the expression is nil,
18318 it might still be an argument. It is if:
18319
18320 - The current token is comma, or
18321
18322 - The -fugly-comma flag was specified *and* the procedure
18323 being invoked is external.
18324
18325 Otherwise, if neither of the above is the case, just
18326 ignore this (nil) expression. */
18327
18328 if ((expr != NULL)
18329 || (ffelex_token_type (t) == FFELEX_typeCOMMA)
18330 || (ffe_is_ugly_comma ()
18331 && (ffeinfo_where (info) == FFEINFO_whereGLOBAL)))
18332 {
18333 /* This expression, even if nil, is apparently intended as an argument. */
18334
18335 /* Internal procedure (CONTAINS, or statement function)? */
18336
18337 if (ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18338 {
18339 if ((expr == NULL)
18340 && ffebad_start (FFEBAD_NULL_ARGUMENT))
18341 {
18342 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18343 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18344 ffebad_here (1, ffelex_token_where_line (t),
18345 ffelex_token_where_column (t));
18346 ffebad_finish ();
18347 }
18348
18349 if (expr == NULL)
18350 ;
18351 else
18352 {
18353 if (ffeexpr_stack_->next_dummy == NULL)
18354 { /* Report later which was the first extra argument. */
18355 if (ffeexpr_stack_->tokens[1] == NULL)
18356 {
18357 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
18358 ffeexpr_stack_->num_args = 0;
18359 }
18360 ++ffeexpr_stack_->num_args; /* Count # of extra arguments. */
18361 }
18362 else
18363 {
18364 if ((ffeinfo_rank (ffebld_info (expr)) != 0)
18365 && ffebad_start (FFEBAD_ARRAY_AS_SFARG))
18366 {
18367 ffebad_here (0,
18368 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18369 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18370 ffebad_here (1, ffelex_token_where_line (ft),
18371 ffelex_token_where_column (ft));
18372 ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent
18373 (ffebld_symter (ffebld_head
18374 (ffeexpr_stack_->next_dummy)))));
18375 ffebad_finish ();
18376 }
18377 else
18378 {
18379 expr = ffeexpr_convert_expr (expr, ft,
18380 ffebld_head (ffeexpr_stack_->next_dummy),
18381 ffeexpr_stack_->tokens[0],
18382 FFEEXPR_contextLET);
18383 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18384 }
18385 --ffeexpr_stack_->num_args; /* Count down # of args. */
18386 ffeexpr_stack_->next_dummy
18387 = ffebld_trail (ffeexpr_stack_->next_dummy);
18388 }
18389 }
18390 }
18391 else
18392 {
18393 if ((expr == NULL)
18394 && ffe_is_pedantic ()
18395 && ffebad_start (FFEBAD_NULL_ARGUMENT_W))
18396 {
18397 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18398 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18399 ffebad_here (1, ffelex_token_where_line (t),
18400 ffelex_token_where_column (t));
18401 ffebad_finish ();
18402 }
18403 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18404 }
18405 }
18406
18407 switch (ffelex_token_type (t))
18408 {
18409 case FFELEX_typeCOMMA:
18410 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
18411 {
18412 case FFEEXPR_contextSFUNCDEF:
18413 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
18414 case FFEEXPR_contextSFUNCDEFINDEX_:
18415 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
18416 ctx = FFEEXPR_contextSFUNCDEFACTUALARG_;
18417 break;
18418
18419 case FFEEXPR_contextSFUNCDEFACTUALARG_:
18420 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18421 assert ("bad context" == NULL);
18422 ctx = FFEEXPR_context;
18423 break;
18424
18425 default:
18426 ctx = FFEEXPR_contextACTUALARG_;
18427 break;
18428 }
18429 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18430 ffeexpr_token_arguments_);
18431
18432 default:
18433 break;
18434 }
18435
18436 if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18437 && (ffeexpr_stack_->next_dummy != NULL))
18438 { /* Too few arguments. */
18439 if (ffebad_start (FFEBAD_TOO_FEW_ARGUMENTS))
18440 {
18441 char num[10];
18442
18443 sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
18444
18445 ffebad_here (0, ffelex_token_where_line (t),
18446 ffelex_token_where_column (t));
18447 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18448 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18449 ffebad_string (num);
18450 ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent (ffebld_symter
18451 (ffebld_head (ffeexpr_stack_->next_dummy)))));
18452 ffebad_finish ();
18453 }
18454 for (;
18455 ffeexpr_stack_->next_dummy != NULL;
18456 ffeexpr_stack_->next_dummy
18457 = ffebld_trail (ffeexpr_stack_->next_dummy))
18458 {
18459 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0));
18460 ffebld_set_info (expr, ffeinfo_new_any ());
18461 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18462 }
18463 }
18464
18465 if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18466 && (ffeexpr_stack_->tokens[1] != NULL))
18467 { /* Too many arguments to statement function. */
18468 if (ffebad_start (FFEBAD_TOO_MANY_ARGUMENTS))
18469 {
18470 char num[10];
18471
18472 sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
18473
18474 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
18475 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
18476 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18477 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18478 ffebad_string (num);
18479 ffebad_finish ();
18480 }
18481 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
18482 }
18483 ffebld_end_list (&ffeexpr_stack_->bottom);
18484
18485 if (ffebld_op (procedure->u.operand) == FFEBLD_opANY)
18486 {
18487 reduced = ffebld_new_any ();
18488 ffebld_set_info (reduced, ffeinfo_new_any ());
18489 }
18490 else
18491 {
18492 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
18493 reduced = ffebld_new_funcref (procedure->u.operand,
18494 ffeexpr_stack_->expr);
18495 else
18496 reduced = ffebld_new_subrref (procedure->u.operand,
18497 ffeexpr_stack_->expr);
18498 if (ffebld_symter_generic (procedure->u.operand) != FFEINTRIN_genNONE)
18499 ffeintrin_fulfill_generic (&reduced, &info, ffeexpr_stack_->tokens[0]);
18500 else if (ffebld_symter_specific (procedure->u.operand)
18501 != FFEINTRIN_specNONE)
18502 ffeintrin_fulfill_specific (&reduced, &info, &check_intrin,
18503 ffeexpr_stack_->tokens[0]);
18504 else
18505 ffeexpr_fulfill_call_ (&reduced, ffeexpr_stack_->tokens[0]);
18506
18507 if (ffebld_op (reduced) != FFEBLD_opANY)
18508 ffebld_set_info (reduced,
18509 ffeinfo_new (ffeinfo_basictype (info),
18510 ffeinfo_kindtype (info),
18511 0,
18512 FFEINFO_kindENTITY,
18513 FFEINFO_whereFLEETING,
18514 ffeinfo_size (info)));
18515 else
18516 ffebld_set_info (reduced, ffeinfo_new_any ());
18517 }
18518 if (ffebld_op (reduced) == FFEBLD_opFUNCREF)
18519 reduced = ffeexpr_collapse_funcref (reduced, ffeexpr_stack_->tokens[0]);
18520 ffeexpr_stack_->exprstack = procedure->previous; /* Pops
18521 not-quite-operand off
18522 stack. */
18523 procedure->u.operand = reduced; /* Save the line/column ffewhere
18524 info. */
18525 ffeexpr_exprstack_push_operand_ (procedure); /* Push it back on stack. */
18526 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18527 {
18528 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18529 ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FUNC(3)(1:1)".... */
18530
18531 /* If the intrinsic needs checking (is REAL(Z) or AIMAG(Z), where
18532 Z is DOUBLE COMPLEX), and a command-line option doesn't already
18533 establish interpretation, probably complain. */
18534
18535 if (check_intrin
18536 && !ffe_is_90 ()
18537 && !ffe_is_ugly_complex ())
18538 {
18539 /* If the outer expression is REAL(me...), issue diagnostic
18540 only if next token isn't the close-paren for REAL(me). */
18541
18542 if ((ffeexpr_stack_->previous != NULL)
18543 && (ffeexpr_stack_->previous->exprstack->type == FFEEXPR_exprtypeOPERAND_)
18544 && ((reduced = ffeexpr_stack_->previous->exprstack->u.operand) != NULL)
18545 && (ffebld_op (reduced) == FFEBLD_opSYMTER)
18546 && (ffebld_symter_implementation (reduced) == FFEINTRIN_impREAL))
18547 return (ffelexHandler) ffeexpr_token_intrincheck_;
18548
18549 /* Diagnose the ambiguity now. */
18550
18551 if (ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
18552 {
18553 ffebad_string (ffeintrin_name_implementation
18554 (ffebld_symter_implementation
18555 (ffebld_left
18556 (ffeexpr_stack_->exprstack->u.operand))));
18557 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
18558 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
18559 ffebad_finish ();
18560 }
18561 }
18562 return (ffelexHandler) ffeexpr_token_substrp_;
18563 }
18564
18565 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
18566 {
18567 ffebad_here (0, ffelex_token_where_line (t),
18568 ffelex_token_where_column (t));
18569 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18570 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18571 ffebad_finish ();
18572 }
18573 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18574 ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FUNC(3)(1:1)".... */
18575 return
18576 (ffelexHandler) ffeexpr_find_close_paren_ (t,
18577 (ffelexHandler)
18578 ffeexpr_token_substrp_);
18579 }
18580
18581 /* ffeexpr_token_elements_ -- OPEN_PAREN [expr COMMA]...expr
18582
18583 Return a pointer to this array to the lexer (ffelex), which will
18584 invoke it for the next token.
18585
18586 Handle expression and COMMA or CLOSE_PAREN. */
18587
18588 static ffelexHandler
18589 ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, ffelexToken t)
18590 {
18591 ffeexprExpr_ array;
18592 ffebld reduced;
18593 ffeinfo info;
18594 ffeinfoWhere where;
18595 ffetargetIntegerDefault val;
18596 ffetargetIntegerDefault lval = 0;
18597 ffetargetIntegerDefault uval = 0;
18598 ffebld lbound;
18599 ffebld ubound;
18600 bool lcheck;
18601 bool ucheck;
18602
18603 array = ffeexpr_stack_->exprstack;
18604 info = ffebld_info (array->u.operand);
18605
18606 if ((expr == NULL) /* && ((ffeexpr_stack_->rank != 0) ||
18607 (ffelex_token_type(t) ==
18608 FFELEX_typeCOMMA)) */ )
18609 {
18610 if (ffebad_start (FFEBAD_NULL_ELEMENT))
18611 {
18612 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18613 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18614 ffebad_here (1, ffelex_token_where_line (t),
18615 ffelex_token_where_column (t));
18616 ffebad_finish ();
18617 }
18618 if (ffeexpr_stack_->rank < ffeinfo_rank (info))
18619 { /* Don't bother if we're going to complain
18620 later! */
18621 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
18622 ffebld_set_info (expr, ffeinfo_new_any ());
18623 }
18624 }
18625
18626 if (expr == NULL)
18627 ;
18628 else if (ffeinfo_rank (info) == 0)
18629 { /* In EQUIVALENCE context, ffeinfo_rank(info)
18630 may == 0. */
18631 ++ffeexpr_stack_->rank; /* Track anyway, may need for new VXT
18632 feature. */
18633 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18634 }
18635 else
18636 {
18637 ++ffeexpr_stack_->rank;
18638 if (ffeexpr_stack_->rank > ffeinfo_rank (info))
18639 { /* Report later which was the first extra
18640 element. */
18641 if (ffeexpr_stack_->rank == ffeinfo_rank (info) + 1)
18642 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
18643 }
18644 else
18645 {
18646 switch (ffeinfo_where (ffebld_info (expr)))
18647 {
18648 case FFEINFO_whereCONSTANT:
18649 break;
18650
18651 case FFEINFO_whereIMMEDIATE:
18652 ffeexpr_stack_->constant = FALSE;
18653 break;
18654
18655 default:
18656 ffeexpr_stack_->constant = FALSE;
18657 ffeexpr_stack_->immediate = FALSE;
18658 break;
18659 }
18660 if (ffebld_op (expr) == FFEBLD_opCONTER)
18661 {
18662 val = ffebld_constant_integerdefault (ffebld_conter (expr));
18663
18664 lbound = ffebld_left (ffebld_head (ffeexpr_stack_->bound_list));
18665 if (lbound == NULL)
18666 {
18667 lcheck = TRUE;
18668 lval = 1;
18669 }
18670 else if (ffebld_op (lbound) == FFEBLD_opCONTER)
18671 {
18672 lcheck = TRUE;
18673 lval = ffebld_constant_integerdefault (ffebld_conter (lbound));
18674 }
18675 else
18676 lcheck = FALSE;
18677
18678 ubound = ffebld_right (ffebld_head (ffeexpr_stack_->bound_list));
18679 assert (ubound != NULL);
18680 if (ffebld_op (ubound) == FFEBLD_opCONTER)
18681 {
18682 ucheck = TRUE;
18683 uval = ffebld_constant_integerdefault (ffebld_conter (ubound));
18684 }
18685 else
18686 ucheck = FALSE;
18687
18688 if ((lcheck && (val < lval)) || (ucheck && (val > uval)))
18689 {
18690 ffebad_start (FFEBAD_RANGE_ARRAY);
18691 ffebad_here (0, ffelex_token_where_line (ft),
18692 ffelex_token_where_column (ft));
18693 ffebad_finish ();
18694 }
18695 }
18696 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18697 ffeexpr_stack_->bound_list = ffebld_trail (ffeexpr_stack_->bound_list);
18698 }
18699 }
18700
18701 switch (ffelex_token_type (t))
18702 {
18703 case FFELEX_typeCOMMA:
18704 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
18705 {
18706 case FFEEXPR_contextDATAIMPDOITEM_:
18707 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18708 FFEEXPR_contextDATAIMPDOINDEX_,
18709 ffeexpr_token_elements_);
18710
18711 case FFEEXPR_contextEQUIVALENCE:
18712 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18713 FFEEXPR_contextEQVINDEX_,
18714 ffeexpr_token_elements_);
18715
18716 case FFEEXPR_contextSFUNCDEF:
18717 case FFEEXPR_contextSFUNCDEFINDEX_:
18718 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18719 FFEEXPR_contextSFUNCDEFINDEX_,
18720 ffeexpr_token_elements_);
18721
18722 case FFEEXPR_contextSFUNCDEFACTUALARG_:
18723 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18724 assert ("bad context" == NULL);
18725 break;
18726
18727 default:
18728 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18729 FFEEXPR_contextINDEX_,
18730 ffeexpr_token_elements_);
18731 }
18732
18733 default:
18734 break;
18735 }
18736
18737 if ((ffeexpr_stack_->rank != ffeinfo_rank (info))
18738 && (ffeinfo_rank (info) != 0))
18739 {
18740 char num[10];
18741
18742 if (ffeexpr_stack_->rank < ffeinfo_rank (info))
18743 {
18744 if (ffebad_start (FFEBAD_TOO_FEW_ELEMENTS))
18745 {
18746 sprintf (num, "%d",
18747 (int) (ffeinfo_rank (info) - ffeexpr_stack_->rank));
18748
18749 ffebad_here (0, ffelex_token_where_line (t),
18750 ffelex_token_where_column (t));
18751 ffebad_here (1,
18752 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18753 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18754 ffebad_string (num);
18755 ffebad_finish ();
18756 }
18757 }
18758 else
18759 {
18760 if (ffebad_start (FFEBAD_TOO_MANY_ELEMENTS))
18761 {
18762 sprintf (num, "%d",
18763 (int) (ffeexpr_stack_->rank - ffeinfo_rank (info)));
18764
18765 ffebad_here (0,
18766 ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
18767 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
18768 ffebad_here (1,
18769 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18770 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18771 ffebad_string (num);
18772 ffebad_finish ();
18773 }
18774 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
18775 }
18776 while (ffeexpr_stack_->rank++ < ffeinfo_rank (info))
18777 {
18778 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
18779 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeINTEGER,
18780 FFEINFO_kindtypeINTEGERDEFAULT,
18781 0, FFEINFO_kindENTITY,
18782 FFEINFO_whereCONSTANT,
18783 FFETARGET_charactersizeNONE));
18784 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18785 }
18786 }
18787 ffebld_end_list (&ffeexpr_stack_->bottom);
18788
18789 if (ffebld_op (array->u.operand) == FFEBLD_opANY)
18790 {
18791 reduced = ffebld_new_any ();
18792 ffebld_set_info (reduced, ffeinfo_new_any ());
18793 }
18794 else
18795 {
18796 reduced = ffebld_new_arrayref (array->u.operand, ffeexpr_stack_->expr);
18797 if (ffeexpr_stack_->constant)
18798 where = FFEINFO_whereFLEETING_CADDR;
18799 else if (ffeexpr_stack_->immediate)
18800 where = FFEINFO_whereFLEETING_IADDR;
18801 else
18802 where = FFEINFO_whereFLEETING;
18803 ffebld_set_info (reduced,
18804 ffeinfo_new (ffeinfo_basictype (info),
18805 ffeinfo_kindtype (info),
18806 0,
18807 FFEINFO_kindENTITY,
18808 where,
18809 ffeinfo_size (info)));
18810 reduced = ffeexpr_collapse_arrayref (reduced, ffeexpr_stack_->tokens[0]);
18811 }
18812
18813 ffeexpr_stack_->exprstack = array->previous; /* Pops not-quite-operand off
18814 stack. */
18815 array->u.operand = reduced; /* Save the line/column ffewhere info. */
18816 ffeexpr_exprstack_push_operand_ (array); /* Push it back on stack. */
18817
18818 switch (ffeinfo_basictype (info))
18819 {
18820 case FFEINFO_basictypeCHARACTER:
18821 ffeexpr_is_substr_ok_ = TRUE; /* Everyone likes "FOO(3)(1:1)".... */
18822 break;
18823
18824 case FFEINFO_basictypeNONE:
18825 ffeexpr_is_substr_ok_ = TRUE;
18826 assert (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE);
18827 break;
18828
18829 default:
18830 ffeexpr_is_substr_ok_ = FALSE;
18831 break;
18832 }
18833
18834 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18835 {
18836 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18837 return (ffelexHandler) ffeexpr_token_substrp_;
18838 }
18839
18840 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
18841 {
18842 ffebad_here (0, ffelex_token_where_line (t),
18843 ffelex_token_where_column (t));
18844 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18845 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18846 ffebad_finish ();
18847 }
18848 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18849 return
18850 (ffelexHandler) ffeexpr_find_close_paren_ (t,
18851 (ffelexHandler)
18852 ffeexpr_token_substrp_);
18853 }
18854
18855 /* ffeexpr_token_equivalence_ -- OPEN_PAREN expr
18856
18857 Return a pointer to this array to the lexer (ffelex), which will
18858 invoke it for the next token.
18859
18860 If token is COLON, pass off to _substr_, else init list and pass off
18861 to _elements_. This handles the case "EQUIVALENCE (FOO(expr?", where
18862 ? marks the token, and where FOO's rank/type has not yet been established,
18863 meaning we could be in a list of indices or in a substring
18864 specification. */
18865
18866 static ffelexHandler
18867 ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr, ffelexToken t)
18868 {
18869 if (ffelex_token_type (t) == FFELEX_typeCOLON)
18870 return ffeexpr_token_substring_ (ft, expr, t);
18871
18872 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
18873 return ffeexpr_token_elements_ (ft, expr, t);
18874 }
18875
18876 /* ffeexpr_token_substring_ -- NAME(of kindENTITY) OPEN_PAREN expr
18877
18878 Return a pointer to this function to the lexer (ffelex), which will
18879 invoke it for the next token.
18880
18881 Handle expression (which may be null) and COLON. */
18882
18883 static ffelexHandler
18884 ffeexpr_token_substring_ (ffelexToken ft, ffebld expr, ffelexToken t)
18885 {
18886 ffeexprExpr_ string;
18887 ffeinfo info;
18888 ffetargetIntegerDefault i;
18889 ffeexprContext ctx;
18890 ffetargetCharacterSize size;
18891
18892 string = ffeexpr_stack_->exprstack;
18893 info = ffebld_info (string->u.operand);
18894 size = ffebld_size_max (string->u.operand);
18895
18896 if (ffelex_token_type (t) == FFELEX_typeCOLON)
18897 {
18898 if ((expr != NULL)
18899 && (ffebld_op (expr) == FFEBLD_opCONTER)
18900 && (((i = ffebld_constant_integerdefault (ffebld_conter (expr)))
18901 < 1)
18902 || ((size != FFETARGET_charactersizeNONE) && (i > size))))
18903 {
18904 ffebad_start (FFEBAD_RANGE_SUBSTR);
18905 ffebad_here (0, ffelex_token_where_line (ft),
18906 ffelex_token_where_column (ft));
18907 ffebad_finish ();
18908 }
18909 ffeexpr_stack_->expr = expr;
18910
18911 switch (ffeexpr_stack_->context)
18912 {
18913 case FFEEXPR_contextSFUNCDEF:
18914 case FFEEXPR_contextSFUNCDEFINDEX_:
18915 ctx = FFEEXPR_contextSFUNCDEFINDEX_;
18916 break;
18917
18918 case FFEEXPR_contextSFUNCDEFACTUALARG_:
18919 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18920 assert ("bad context" == NULL);
18921 ctx = FFEEXPR_context;
18922 break;
18923
18924 default:
18925 ctx = FFEEXPR_contextINDEX_;
18926 break;
18927 }
18928
18929 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18930 ffeexpr_token_substring_1_);
18931 }
18932
18933 if (ffest_ffebad_start (FFEBAD_MISSING_COLON_IN_SUBSTR))
18934 {
18935 ffebad_here (0, ffelex_token_where_line (t),
18936 ffelex_token_where_column (t));
18937 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18938 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18939 ffebad_finish ();
18940 }
18941
18942 ffeexpr_stack_->expr = NULL;
18943 return (ffelexHandler) ffeexpr_token_substring_1_ (ft, expr, t);
18944 }
18945
18946 /* ffeexpr_token_substring_1_ -- NAME OPEN_PAREN [expr COMMA]...expr
18947
18948 Return a pointer to this function to the lexer (ffelex), which will
18949 invoke it for the next token.
18950
18951 Handle expression (which might be null) and CLOSE_PAREN. */
18952
18953 static ffelexHandler
18954 ffeexpr_token_substring_1_ (ffelexToken ft, ffebld last, ffelexToken t)
18955 {
18956 ffeexprExpr_ string;
18957 ffebld reduced;
18958 ffebld substrlist;
18959 ffebld first = ffeexpr_stack_->expr;
18960 ffebld strop;
18961 ffeinfo info;
18962 ffeinfoWhere lwh;
18963 ffeinfoWhere rwh;
18964 ffeinfoWhere where;
18965 ffeinfoKindtype first_kt;
18966 ffeinfoKindtype last_kt;
18967 ffetargetIntegerDefault first_val;
18968 ffetargetIntegerDefault last_val;
18969 ffetargetCharacterSize size;
18970 ffetargetCharacterSize strop_size_max;
18971
18972 string = ffeexpr_stack_->exprstack;
18973 strop = string->u.operand;
18974 info = ffebld_info (strop);
18975
18976 if ((first == NULL) || (ffebld_op (first) == FFEBLD_opCONTER))
18977 { /* The starting point is known. */
18978 first_val = (first == NULL) ? 1
18979 : ffebld_constant_integerdefault (ffebld_conter (first));
18980 }
18981 else
18982 { /* Assume start of the entity. */
18983 first_val = 1;
18984 }
18985
18986 if ((last != NULL) && (ffebld_op (last) == FFEBLD_opCONTER))
18987 { /* The ending point is known. */
18988 last_val = ffebld_constant_integerdefault (ffebld_conter (last));
18989
18990 if ((first == NULL) || (ffebld_op (first) == FFEBLD_opCONTER))
18991 { /* The beginning point is a constant. */
18992 if (first_val <= last_val)
18993 size = last_val - first_val + 1;
18994 else
18995 {
18996 if (0 && ffe_is_90 ())
18997 size = 0;
18998 else
18999 {
19000 size = 1;
19001 ffebad_start (FFEBAD_ZERO_SIZE);
19002 ffebad_here (0, ffelex_token_where_line (ft),
19003 ffelex_token_where_column (ft));
19004 ffebad_finish ();
19005 }
19006 }
19007 }
19008 else
19009 size = FFETARGET_charactersizeNONE;
19010
19011 strop_size_max = ffebld_size_max (strop);
19012
19013 if ((strop_size_max != FFETARGET_charactersizeNONE)
19014 && (last_val > strop_size_max))
19015 { /* Beyond maximum possible end of string. */
19016 ffebad_start (FFEBAD_RANGE_SUBSTR);
19017 ffebad_here (0, ffelex_token_where_line (ft),
19018 ffelex_token_where_column (ft));
19019 ffebad_finish ();
19020 }
19021 }
19022 else
19023 size = FFETARGET_charactersizeNONE; /* The size is not known. */
19024
19025 #if 0 /* Don't do this, or "is size of target
19026 known?" would no longer be easily
19027 answerable. To see if there is a max
19028 size, use ffebld_size_max; to get only the
19029 known size, else NONE, use
19030 ffebld_size_known; use ffebld_size if
19031 values are sure to be the same (not
19032 opSUBSTR or opCONCATENATE or known to have
19033 known length). By getting rid of this
19034 "useful info" stuff, we don't end up
19035 blank-padding the constant in the
19036 assignment "A(I:J)='XYZ'" to the known
19037 length of A. */
19038 if (size == FFETARGET_charactersizeNONE)
19039 size = strop_size_max; /* Assume we use the entire string. */
19040 #endif
19041
19042 substrlist
19043 = ffebld_new_item
19044 (first,
19045 ffebld_new_item
19046 (last,
19047 NULL
19048 )
19049 )
19050 ;
19051
19052 if (first == NULL)
19053 lwh = FFEINFO_whereCONSTANT;
19054 else
19055 lwh = ffeinfo_where (ffebld_info (first));
19056 if (last == NULL)
19057 rwh = FFEINFO_whereCONSTANT;
19058 else
19059 rwh = ffeinfo_where (ffebld_info (last));
19060
19061 switch (lwh)
19062 {
19063 case FFEINFO_whereCONSTANT:
19064 switch (rwh)
19065 {
19066 case FFEINFO_whereCONSTANT:
19067 where = FFEINFO_whereCONSTANT;
19068 break;
19069
19070 case FFEINFO_whereIMMEDIATE:
19071 where = FFEINFO_whereIMMEDIATE;
19072 break;
19073
19074 default:
19075 where = FFEINFO_whereFLEETING;
19076 break;
19077 }
19078 break;
19079
19080 case FFEINFO_whereIMMEDIATE:
19081 switch (rwh)
19082 {
19083 case FFEINFO_whereCONSTANT:
19084 case FFEINFO_whereIMMEDIATE:
19085 where = FFEINFO_whereIMMEDIATE;
19086 break;
19087
19088 default:
19089 where = FFEINFO_whereFLEETING;
19090 break;
19091 }
19092 break;
19093
19094 default:
19095 where = FFEINFO_whereFLEETING;
19096 break;
19097 }
19098
19099 if (first == NULL)
19100 first_kt = FFEINFO_kindtypeINTEGERDEFAULT;
19101 else
19102 first_kt = ffeinfo_kindtype (ffebld_info (first));
19103 if (last == NULL)
19104 last_kt = FFEINFO_kindtypeINTEGERDEFAULT;
19105 else
19106 last_kt = ffeinfo_kindtype (ffebld_info (last));
19107
19108 switch (where)
19109 {
19110 case FFEINFO_whereCONSTANT:
19111 switch (ffeinfo_where (info))
19112 {
19113 case FFEINFO_whereCONSTANT:
19114 break;
19115
19116 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
19117 where = FFEINFO_whereIMMEDIATE;
19118 break;
19119
19120 default:
19121 where = FFEINFO_whereFLEETING_CADDR;
19122 break;
19123 }
19124 break;
19125
19126 case FFEINFO_whereIMMEDIATE:
19127 switch (ffeinfo_where (info))
19128 {
19129 case FFEINFO_whereCONSTANT:
19130 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
19131 break;
19132
19133 default:
19134 where = FFEINFO_whereFLEETING_IADDR;
19135 break;
19136 }
19137 break;
19138
19139 default:
19140 switch (ffeinfo_where (info))
19141 {
19142 case FFEINFO_whereCONSTANT:
19143 where = FFEINFO_whereCONSTANT_SUBOBJECT; /* An F90 concept. */
19144 break;
19145
19146 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
19147 default:
19148 where = FFEINFO_whereFLEETING;
19149 break;
19150 }
19151 break;
19152 }
19153
19154 if (ffebld_op (strop) == FFEBLD_opANY)
19155 {
19156 reduced = ffebld_new_any ();
19157 ffebld_set_info (reduced, ffeinfo_new_any ());
19158 }
19159 else
19160 {
19161 reduced = ffebld_new_substr (strop, substrlist);
19162 ffebld_set_info (reduced, ffeinfo_new
19163 (FFEINFO_basictypeCHARACTER,
19164 ffeinfo_kindtype (info),
19165 0,
19166 FFEINFO_kindENTITY,
19167 where,
19168 size));
19169 reduced = ffeexpr_collapse_substr (reduced, ffeexpr_stack_->tokens[0]);
19170 }
19171
19172 ffeexpr_stack_->exprstack = string->previous; /* Pops not-quite-operand off
19173 stack. */
19174 string->u.operand = reduced; /* Save the line/column ffewhere info. */
19175 ffeexpr_exprstack_push_operand_ (string); /* Push it back on stack. */
19176
19177 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
19178 {
19179 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19180 ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FOO(3:5)(1:1)".... */
19181 return (ffelexHandler) ffeexpr_token_substrp_;
19182 }
19183
19184 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
19185 {
19186 ffebad_here (0, ffelex_token_where_line (t),
19187 ffelex_token_where_column (t));
19188 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
19189 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
19190 ffebad_finish ();
19191 }
19192
19193 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19194 ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FOO(3:5)(1:1)".... */
19195 return
19196 (ffelexHandler) ffeexpr_find_close_paren_ (t,
19197 (ffelexHandler)
19198 ffeexpr_token_substrp_);
19199 }
19200
19201 /* ffeexpr_token_substrp_ -- Rhs <character entity>
19202
19203 Return a pointer to this function to the lexer (ffelex), which will
19204 invoke it for the next token.
19205
19206 If OPEN_PAREN, treat as start of a substring ("(3:4)") construct, and
19207 issue error message if flag (serves as argument) is set. Else, just
19208 forward token to binary_. */
19209
19210 static ffelexHandler
19211 ffeexpr_token_substrp_ (ffelexToken t)
19212 {
19213 ffeexprContext ctx;
19214
19215 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
19216 return (ffelexHandler) ffeexpr_token_binary_ (t);
19217
19218 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
19219
19220 switch (ffeexpr_stack_->context)
19221 {
19222 case FFEEXPR_contextSFUNCDEF:
19223 case FFEEXPR_contextSFUNCDEFINDEX_:
19224 ctx = FFEEXPR_contextSFUNCDEFINDEX_;
19225 break;
19226
19227 case FFEEXPR_contextSFUNCDEFACTUALARG_:
19228 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
19229 assert ("bad context" == NULL);
19230 ctx = FFEEXPR_context;
19231 break;
19232
19233 default:
19234 ctx = FFEEXPR_contextINDEX_;
19235 break;
19236 }
19237
19238 if (!ffeexpr_is_substr_ok_)
19239 {
19240 if (ffebad_start (FFEBAD_BAD_SUBSTR))
19241 {
19242 ffebad_here (0, ffelex_token_where_line (t),
19243 ffelex_token_where_column (t));
19244 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
19245 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
19246 ffebad_finish ();
19247 }
19248
19249 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
19250 ffeexpr_token_anything_);
19251 }
19252
19253 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
19254 ffeexpr_token_substring_);
19255 }
19256
19257 static ffelexHandler
19258 ffeexpr_token_intrincheck_ (ffelexToken t)
19259 {
19260 if ((ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
19261 && ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
19262 {
19263 ffebad_string (ffeintrin_name_implementation
19264 (ffebld_symter_implementation
19265 (ffebld_left
19266 (ffeexpr_stack_->exprstack->u.operand))));
19267 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
19268 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
19269 ffebad_finish ();
19270 }
19271
19272 return (ffelexHandler) ffeexpr_token_substrp_ (t);
19273 }
19274
19275 /* ffeexpr_token_funsubstr_ -- NAME OPEN_PAREN expr
19276
19277 Return a pointer to this function to the lexer (ffelex), which will
19278 invoke it for the next token.
19279
19280 If COLON, do everything we would have done since _parenthesized_ if
19281 we had known NAME represented a kindENTITY instead of a kindFUNCTION.
19282 If not COLON, do likewise for kindFUNCTION instead. */
19283
19284 static ffelexHandler
19285 ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr, ffelexToken t)
19286 {
19287 ffeinfoWhere where;
19288 ffesymbol s;
19289 ffesymbolAttrs sa;
19290 ffebld symter = ffeexpr_stack_->exprstack->u.operand;
19291 bool needs_type;
19292 ffeintrinGen gen;
19293 ffeintrinSpec spec;
19294 ffeintrinImp imp;
19295
19296 s = ffebld_symter (symter);
19297 sa = ffesymbol_attrs (s);
19298 where = ffesymbol_where (s);
19299
19300 /* We get here only if we don't already know enough about FOO when seeing a
19301 FOO(stuff) reference, and FOO might turn out to be a CHARACTER type. If
19302 "stuff" is a substring reference, then FOO is a CHARACTER scalar type.
19303 Else FOO is a function, either intrinsic or external. If intrinsic, it
19304 wouldn't necessarily be CHARACTER type, so unless it has already been
19305 declared DUMMY, it hasn't had its type established yet. It can't be
19306 CHAR*(*) in any case, though it can have an explicit CHAR*n type. */
19307
19308 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
19309 | FFESYMBOL_attrsTYPE)));
19310
19311 needs_type = !(ffesymbol_attrs (s) & FFESYMBOL_attrsDUMMY);
19312
19313 ffesymbol_signal_change (s); /* Probably already done, but in case.... */
19314
19315 if (ffelex_token_type (t) == FFELEX_typeCOLON)
19316 { /* Definitely an ENTITY (char substring). */
19317 if (needs_type && !ffeimplic_establish_symbol (s))
19318 {
19319 ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
19320 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19321 }
19322
19323 ffesymbol_set_info (s,
19324 ffeinfo_new (ffesymbol_basictype (s),
19325 ffesymbol_kindtype (s),
19326 ffesymbol_rank (s),
19327 FFEINFO_kindENTITY,
19328 (where == FFEINFO_whereNONE)
19329 ? FFEINFO_whereLOCAL
19330 : where,
19331 ffesymbol_size (s)));
19332 ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
19333
19334 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
19335 ffesymbol_resolve_intrin (s);
19336 s = ffecom_sym_learned (s);
19337 ffesymbol_signal_unreported (s); /* For debugging purposes. */
19338
19339 ffeexpr_stack_->exprstack->u.operand
19340 = ffeexpr_collapse_symter (symter, ffeexpr_tokens_[0]);
19341
19342 return (ffelexHandler) ffeexpr_token_substring_ (ft, expr, t);
19343 }
19344
19345 /* The "stuff" isn't a substring notation, so we now know the overall
19346 reference is to a function. */
19347
19348 if (ffeintrin_is_intrinsic (ffesymbol_text (s), ffeexpr_stack_->tokens[0],
19349 FALSE, &gen, &spec, &imp))
19350 {
19351 ffebld_symter_set_generic (symter, gen);
19352 ffebld_symter_set_specific (symter, spec);
19353 ffebld_symter_set_implementation (symter, imp);
19354 ffesymbol_set_generic (s, gen);
19355 ffesymbol_set_specific (s, spec);
19356 ffesymbol_set_implementation (s, imp);
19357 ffesymbol_set_info (s,
19358 ffeinfo_new (ffesymbol_basictype (s),
19359 ffesymbol_kindtype (s),
19360 0,
19361 FFEINFO_kindFUNCTION,
19362 FFEINFO_whereINTRINSIC,
19363 ffesymbol_size (s)));
19364 }
19365 else
19366 { /* Not intrinsic, now needs CHAR type. */
19367 if (!ffeimplic_establish_symbol (s))
19368 {
19369 ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
19370 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19371 }
19372
19373 ffesymbol_set_info (s,
19374 ffeinfo_new (ffesymbol_basictype (s),
19375 ffesymbol_kindtype (s),
19376 ffesymbol_rank (s),
19377 FFEINFO_kindFUNCTION,
19378 (where == FFEINFO_whereNONE)
19379 ? FFEINFO_whereGLOBAL
19380 : where,
19381 ffesymbol_size (s)));
19382 }
19383
19384 ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
19385
19386 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
19387 ffesymbol_resolve_intrin (s);
19388 s = ffecom_sym_learned (s);
19389 ffesymbol_reference (s, ffeexpr_stack_->tokens[0], FALSE);
19390 ffesymbol_signal_unreported (s); /* For debugging purposes. */
19391 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
19392 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19393 }
19394
19395 /* ffeexpr_token_anything_ -- NAME OPEN_PAREN any-expr
19396
19397 Handle basically any expression, looking for CLOSE_PAREN. */
19398
19399 static ffelexHandler
19400 ffeexpr_token_anything_ (ffelexToken ft UNUSED, ffebld expr UNUSED,
19401 ffelexToken t)
19402 {
19403 ffeexprExpr_ e = ffeexpr_stack_->exprstack;
19404
19405 switch (ffelex_token_type (t))
19406 {
19407 case FFELEX_typeCOMMA:
19408 case FFELEX_typeCOLON:
19409 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
19410 FFEEXPR_contextACTUALARG_,
19411 ffeexpr_token_anything_);
19412
19413 default:
19414 e->u.operand = ffebld_new_any ();
19415 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
19416 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19417 ffeexpr_is_substr_ok_ = FALSE;
19418 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
19419 return (ffelexHandler) ffeexpr_token_substrp_;
19420 return (ffelexHandler) ffeexpr_token_substrp_ (t);
19421 }
19422 }
19423
19424 /* Terminate module. */
19425
19426 void
19427 ffeexpr_terminate_2 ()
19428 {
19429 assert (ffeexpr_stack_ == NULL);
19430 assert (ffeexpr_level_ == 0);
19431 }
Mirror of https://gcc.gnu.org/git/gcc.git