?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
2003-11-14 Eric Christopher <echristo@redhat.com>
[official-gcc.git] / gcc / f / expr.c
blob6aeddafe4c27099ca05ae2cab26123551fdf3115
1 /* expr.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 1997, 1998, 2001, 2002, 2003
3 Free Software Foundation, Inc.
4 Contributed by James Craig Burley.
5
6 This file is part of GNU Fortran.
7
8 GNU Fortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
11 any later version.
12
13 GNU Fortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
17
18 You should have received a copy of the GNU General Public License
19 along with GNU Fortran; see the file COPYING. If not, write to
20 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
21 02111-1307, USA.
22
23 Related Modules:
24 None.
25
26 Description:
27 Handles syntactic and semantic analysis of Fortran expressions.
28
29 Modifications:
30 */
31
32 /* Include files. */
33
34 #include "proj.h"
35 #include "expr.h"
36 #include "bad.h"
37 #include "bld.h"
38 #include "com.h"
39 #include "global.h"
40 #include "implic.h"
41 #include "intrin.h"
42 #include "info.h"
43 #include "lex.h"
44 #include "malloc.h"
45 #include "src.h"
46 #include "st.h"
47 #include "symbol.h"
48 #include "str.h"
49 #include "target.h"
50 #include "where.h"
51 #include "real.h"
52
53 /* Externals defined here. */
54
55
56 /* Simple definitions and enumerations. */
57
58 typedef enum
59 {
60 FFEEXPR_exprtypeUNKNOWN_,
61 FFEEXPR_exprtypeOPERAND_,
62 FFEEXPR_exprtypeUNARY_,
63 FFEEXPR_exprtypeBINARY_,
64 FFEEXPR_exprtype_
65 } ffeexprExprtype_;
66
67 typedef enum
68 {
69 FFEEXPR_operatorPOWER_,
70 FFEEXPR_operatorMULTIPLY_,
71 FFEEXPR_operatorDIVIDE_,
72 FFEEXPR_operatorADD_,
73 FFEEXPR_operatorSUBTRACT_,
74 FFEEXPR_operatorCONCATENATE_,
75 FFEEXPR_operatorLT_,
76 FFEEXPR_operatorLE_,
77 FFEEXPR_operatorEQ_,
78 FFEEXPR_operatorNE_,
79 FFEEXPR_operatorGT_,
80 FFEEXPR_operatorGE_,
81 FFEEXPR_operatorNOT_,
82 FFEEXPR_operatorAND_,
83 FFEEXPR_operatorOR_,
84 FFEEXPR_operatorXOR_,
85 FFEEXPR_operatorEQV_,
86 FFEEXPR_operatorNEQV_,
87 FFEEXPR_operator_
88 } ffeexprOperator_;
89
90 typedef enum
91 {
92 FFEEXPR_operatorprecedenceHIGHEST_ = 1,
93 FFEEXPR_operatorprecedencePOWER_ = 1,
94 FFEEXPR_operatorprecedenceMULTIPLY_ = 2,
95 FFEEXPR_operatorprecedenceDIVIDE_ = 2,
96 FFEEXPR_operatorprecedenceADD_ = 3,
97 FFEEXPR_operatorprecedenceSUBTRACT_ = 3,
98 FFEEXPR_operatorprecedenceLOWARITH_ = 3,
99 FFEEXPR_operatorprecedenceCONCATENATE_ = 3,
100 FFEEXPR_operatorprecedenceLT_ = 4,
101 FFEEXPR_operatorprecedenceLE_ = 4,
102 FFEEXPR_operatorprecedenceEQ_ = 4,
103 FFEEXPR_operatorprecedenceNE_ = 4,
104 FFEEXPR_operatorprecedenceGT_ = 4,
105 FFEEXPR_operatorprecedenceGE_ = 4,
106 FFEEXPR_operatorprecedenceNOT_ = 5,
107 FFEEXPR_operatorprecedenceAND_ = 6,
108 FFEEXPR_operatorprecedenceOR_ = 7,
109 FFEEXPR_operatorprecedenceXOR_ = 8,
110 FFEEXPR_operatorprecedenceEQV_ = 8,
111 FFEEXPR_operatorprecedenceNEQV_ = 8,
112 FFEEXPR_operatorprecedenceLOWEST_ = 8,
113 FFEEXPR_operatorprecedence_
114 } ffeexprOperatorPrecedence_;
115
116 #define FFEEXPR_operatorassociativityL2R_ TRUE
117 #define FFEEXPR_operatorassociativityR2L_ FALSE
118 #define FFEEXPR_operatorassociativityPOWER_ FFEEXPR_operatorassociativityR2L_
119 #define FFEEXPR_operatorassociativityMULTIPLY_ FFEEXPR_operatorassociativityL2R_
120 #define FFEEXPR_operatorassociativityDIVIDE_ FFEEXPR_operatorassociativityL2R_
121 #define FFEEXPR_operatorassociativityADD_ FFEEXPR_operatorassociativityL2R_
122 #define FFEEXPR_operatorassociativitySUBTRACT_ FFEEXPR_operatorassociativityL2R_
123 #define FFEEXPR_operatorassociativityCONCATENATE_ FFEEXPR_operatorassociativityL2R_
124 #define FFEEXPR_operatorassociativityLT_ FFEEXPR_operatorassociativityL2R_
125 #define FFEEXPR_operatorassociativityLE_ FFEEXPR_operatorassociativityL2R_
126 #define FFEEXPR_operatorassociativityEQ_ FFEEXPR_operatorassociativityL2R_
127 #define FFEEXPR_operatorassociativityNE_ FFEEXPR_operatorassociativityL2R_
128 #define FFEEXPR_operatorassociativityGT_ FFEEXPR_operatorassociativityL2R_
129 #define FFEEXPR_operatorassociativityGE_ FFEEXPR_operatorassociativityL2R_
130 #define FFEEXPR_operatorassociativityNOT_ FFEEXPR_operatorassociativityL2R_
131 #define FFEEXPR_operatorassociativityAND_ FFEEXPR_operatorassociativityL2R_
132 #define FFEEXPR_operatorassociativityOR_ FFEEXPR_operatorassociativityL2R_
133 #define FFEEXPR_operatorassociativityXOR_ FFEEXPR_operatorassociativityL2R_
134 #define FFEEXPR_operatorassociativityEQV_ FFEEXPR_operatorassociativityL2R_
135 #define FFEEXPR_operatorassociativityNEQV_ FFEEXPR_operatorassociativityL2R_
136
137 typedef enum
138 {
139 FFEEXPR_parentypeFUNCTION_,
140 FFEEXPR_parentypeSUBROUTINE_,
141 FFEEXPR_parentypeARRAY_,
142 FFEEXPR_parentypeSUBSTRING_,
143 FFEEXPR_parentypeFUNSUBSTR_,/* Ambig: check for colon after first expr. */
144 FFEEXPR_parentypeEQUIVALENCE_, /* Ambig: ARRAY_ or SUBSTRING_. */
145 FFEEXPR_parentypeANY_, /* Allow basically anything. */
146 FFEEXPR_parentype_
147 } ffeexprParenType_;
148
149 typedef enum
150 {
151 FFEEXPR_percentNONE_,
152 FFEEXPR_percentLOC_,
153 FFEEXPR_percentVAL_,
154 FFEEXPR_percentREF_,
155 FFEEXPR_percentDESCR_,
156 FFEEXPR_percent_
157 } ffeexprPercent_;
158
159 /* Internal typedefs. */
160
161 typedef struct _ffeexpr_expr_ *ffeexprExpr_;
162 typedef bool ffeexprOperatorAssociativity_;
163 typedef struct _ffeexpr_stack_ *ffeexprStack_;
164
165 /* Private include files. */
166
167
168 /* Internal structure definitions. */
169
170 struct _ffeexpr_expr_
171 {
172 ffeexprExpr_ previous;
173 ffelexToken token;
174 ffeexprExprtype_ type;
175 union
176 {
177 struct
178 {
179 ffeexprOperator_ op;
180 ffeexprOperatorPrecedence_ prec;
181 ffeexprOperatorAssociativity_ as;
182 }
183 operator;
184 ffebld operand;
185 }
186 u;
187 };
188
189 struct _ffeexpr_stack_
190 {
191 ffeexprStack_ previous;
192 mallocPool pool;
193 ffeexprContext context;
194 ffeexprCallback callback;
195 ffelexToken first_token;
196 ffeexprExpr_ exprstack;
197 ffelexToken tokens[10]; /* Used in certain cases, like (unary)
198 open-paren. */
199 ffebld expr; /* For first of
200 complex/implied-do/substring/array-elements
201 / actual-args expression. */
202 ffebld bound_list; /* For tracking dimension bounds list of
203 array. */
204 ffebldListBottom bottom; /* For building lists. */
205 ffeinfoRank rank; /* For elements in an array reference. */
206 bool constant; /* TRUE while elements seen so far are
207 constants. */
208 bool immediate; /* TRUE while elements seen so far are
209 immediate/constants. */
210 ffebld next_dummy; /* Next SFUNC dummy arg in arg list. */
211 ffebldListLength num_args; /* Number of dummy args expected in arg list. */
212 bool is_rhs; /* TRUE if rhs context, FALSE otherwise. */
213 ffeexprPercent_ percent; /* Current %FOO keyword. */
214 };
215
216 struct _ffeexpr_find_
217 {
218 ffelexToken t;
219 ffelexHandler after;
220 int level;
221 };
222
223 /* Static objects accessed by functions in this module. */
224
225 static ffeexprStack_ ffeexpr_stack_; /* Expression stack for semantic. */
226 static ffelexToken ffeexpr_tokens_[10]; /* Scratchpad tokens for syntactic. */
227 static ffestrOther ffeexpr_current_dotdot_; /* Current .FOO. keyword. */
228 static long ffeexpr_hollerith_count_; /* ffeexpr_token_number_ and caller. */
229 static int ffeexpr_level_; /* Level of DATA implied-DO construct. */
230 static bool ffeexpr_is_substr_ok_; /* If OPEN_PAREN as binary "op" ok. */
231 static struct _ffeexpr_find_ ffeexpr_find_;
232
233 /* Static functions (internal). */
234
235 static ffelexHandler ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr,
236 ffelexToken t);
237 static ffelexHandler ffeexpr_cb_close_paren_ambig_ (ffelexToken ft,
238 ffebld expr,
239 ffelexToken t);
240 static ffelexHandler ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t);
241 static ffelexHandler ffeexpr_cb_close_paren_c_ (ffelexToken ft,
242 ffebld expr, ffelexToken t);
243 static ffelexHandler ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr,
244 ffelexToken t);
245 static ffelexHandler ffeexpr_cb_close_paren_ci_ (ffelexToken ft,
246 ffebld expr, ffelexToken t);
247 static ffelexHandler ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr,
248 ffelexToken t);
249 static ffelexHandler ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr,
250 ffelexToken t);
251 static ffelexHandler ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr,
252 ffelexToken t);
253 static ffelexHandler ffeexpr_cb_comma_i_2_ (ffelexToken ft, ffebld expr,
254 ffelexToken t);
255 static ffelexHandler ffeexpr_cb_comma_i_3_ (ffelexToken ft, ffebld expr,
256 ffelexToken t);
257 static ffelexHandler ffeexpr_cb_comma_i_4_ (ffelexToken ft, ffebld expr,
258 ffelexToken t);
259 static ffelexHandler ffeexpr_cb_comma_i_5_ (ffelexToken t);
260 static ffelexHandler ffeexpr_cb_end_loc_ (ffelexToken ft, ffebld expr,
261 ffelexToken t);
262 static ffelexHandler ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr,
263 ffelexToken t);
264 static ffelexHandler ffeexpr_cb_end_notloc_1_ (ffelexToken t);
265 static ffesymbol ffeexpr_check_impctrl_ (ffesymbol s);
266 static void ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
267 ffebld dovar, ffelexToken dovar_t);
268 static void ffeexpr_update_impdo_ (ffebld expr, ffebld dovar);
269 static void ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar);
270 static ffeexprContext ffeexpr_context_outer_ (ffeexprStack_ s);
271 static ffeexprExpr_ ffeexpr_expr_new_ (void);
272 static void ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t);
273 static bool ffeexpr_isdigits_ (const char *p);
274 static ffelexHandler ffeexpr_token_first_lhs_ (ffelexToken t);
275 static ffelexHandler ffeexpr_token_first_lhs_1_ (ffelexToken t);
276 static ffelexHandler ffeexpr_token_first_rhs_ (ffelexToken t);
277 static ffelexHandler ffeexpr_token_first_rhs_1_ (ffelexToken t);
278 static ffelexHandler ffeexpr_token_first_rhs_2_ (ffelexToken t);
279 static ffelexHandler ffeexpr_token_first_rhs_3_ (ffelexToken t);
280 static ffelexHandler ffeexpr_token_first_rhs_4_ (ffelexToken t);
281 static ffelexHandler ffeexpr_token_first_rhs_5_ (ffelexToken t);
282 static ffelexHandler ffeexpr_token_first_rhs_6_ (ffelexToken t);
283 static ffelexHandler ffeexpr_token_namelist_ (ffelexToken t);
284 static void ffeexpr_expr_kill_ (ffeexprExpr_ e);
285 static void ffeexpr_exprstack_push_ (ffeexprExpr_ e);
286 static void ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e);
287 static void ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e);
288 static void ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e);
289 static void ffeexpr_reduce_ (void);
290 static ffebld ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op,
291 ffeexprExpr_ r);
292 static ffebld ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l,
293 ffeexprExpr_ op, ffeexprExpr_ r);
294 static ffebld ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l,
295 ffeexprExpr_ op, ffeexprExpr_ r);
296 static ffebld ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l,
297 ffeexprExpr_ op, ffeexprExpr_ r);
298 static ffebld ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op,
299 ffeexprExpr_ r);
300 static ffebld ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l,
301 ffeexprExpr_ op, ffeexprExpr_ r);
302 static ffebld ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l,
303 ffeexprExpr_ op, ffeexprExpr_ r);
304 static ffebld ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l,
305 ffeexprExpr_ op, ffeexprExpr_ r);
306 static ffebld ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r);
307 static ffebld ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op,
308 ffeexprExpr_ r);
309 static ffebld ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l,
310 ffeexprExpr_ op, ffeexprExpr_ r);
311 static ffebld ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l,
312 ffeexprExpr_ op, ffeexprExpr_ r);
313 static ffelexHandler ffeexpr_find_close_paren_ (ffelexToken t,
314 ffelexHandler after);
315 static ffelexHandler ffeexpr_nil_finished_ (ffelexToken t);
316 static ffelexHandler ffeexpr_nil_rhs_ (ffelexToken t);
317 static ffelexHandler ffeexpr_nil_period_ (ffelexToken t);
318 static ffelexHandler ffeexpr_nil_end_period_ (ffelexToken t);
319 static ffelexHandler ffeexpr_nil_swallow_period_ (ffelexToken t);
320 static ffelexHandler ffeexpr_nil_real_ (ffelexToken t);
321 static ffelexHandler ffeexpr_nil_real_exponent_ (ffelexToken t);
322 static ffelexHandler ffeexpr_nil_real_exp_sign_ (ffelexToken t);
323 static ffelexHandler ffeexpr_nil_number_ (ffelexToken t);
324 static ffelexHandler ffeexpr_nil_number_exponent_ (ffelexToken t);
325 static ffelexHandler ffeexpr_nil_number_exp_sign_ (ffelexToken t);
326 static ffelexHandler ffeexpr_nil_number_period_ (ffelexToken t);
327 static ffelexHandler ffeexpr_nil_number_per_exp_ (ffelexToken t);
328 static ffelexHandler ffeexpr_nil_number_real_ (ffelexToken t);
329 static ffelexHandler ffeexpr_nil_num_per_exp_sign_ (ffelexToken t);
330 static ffelexHandler ffeexpr_nil_number_real_exp_ (ffelexToken t);
331 static ffelexHandler ffeexpr_nil_num_real_exp_sn_ (ffelexToken t);
332 static ffelexHandler ffeexpr_nil_binary_ (ffelexToken t);
333 static ffelexHandler ffeexpr_nil_binary_period_ (ffelexToken t);
334 static ffelexHandler ffeexpr_nil_binary_end_per_ (ffelexToken t);
335 static ffelexHandler ffeexpr_nil_binary_sw_per_ (ffelexToken t);
336 static ffelexHandler ffeexpr_nil_quote_ (ffelexToken t);
337 static ffelexHandler ffeexpr_nil_apostrophe_ (ffelexToken t);
338 static ffelexHandler ffeexpr_nil_apos_char_ (ffelexToken t);
339 static ffelexHandler ffeexpr_nil_name_rhs_ (ffelexToken t);
340 static ffelexHandler ffeexpr_nil_name_apos_ (ffelexToken t);
341 static ffelexHandler ffeexpr_nil_name_apos_name_ (ffelexToken t);
342 static ffelexHandler ffeexpr_nil_percent_ (ffelexToken t);
343 static ffelexHandler ffeexpr_nil_percent_name_ (ffelexToken t);
344 static ffelexHandler ffeexpr_nil_substrp_ (ffelexToken t);
345 static ffelexHandler ffeexpr_finished_ (ffelexToken t);
346 static ffebld ffeexpr_finished_ambig_ (ffelexToken t, ffebld expr);
347 static ffelexHandler ffeexpr_token_lhs_ (ffelexToken t);
348 static ffelexHandler ffeexpr_token_rhs_ (ffelexToken t);
349 static ffelexHandler ffeexpr_token_binary_ (ffelexToken t);
350 static ffelexHandler ffeexpr_token_period_ (ffelexToken t);
351 static ffelexHandler ffeexpr_token_end_period_ (ffelexToken t);
352 static ffelexHandler ffeexpr_token_swallow_period_ (ffelexToken t);
353 static ffelexHandler ffeexpr_token_real_ (ffelexToken t);
354 static ffelexHandler ffeexpr_token_real_exponent_ (ffelexToken t);
355 static ffelexHandler ffeexpr_token_real_exp_sign_ (ffelexToken t);
356 static ffelexHandler ffeexpr_token_number_ (ffelexToken t);
357 static ffelexHandler ffeexpr_token_number_exponent_ (ffelexToken t);
358 static ffelexHandler ffeexpr_token_number_exp_sign_ (ffelexToken t);
359 static ffelexHandler ffeexpr_token_number_period_ (ffelexToken t);
360 static ffelexHandler ffeexpr_token_number_per_exp_ (ffelexToken t);
361 static ffelexHandler ffeexpr_token_number_real_ (ffelexToken t);
362 static ffelexHandler ffeexpr_token_num_per_exp_sign_ (ffelexToken t);
363 static ffelexHandler ffeexpr_token_number_real_exp_ (ffelexToken t);
364 static ffelexHandler ffeexpr_token_num_real_exp_sn_ (ffelexToken t);
365 static ffelexHandler ffeexpr_token_binary_period_ (ffelexToken t);
366 static ffelexHandler ffeexpr_token_binary_end_per_ (ffelexToken t);
367 static ffelexHandler ffeexpr_token_binary_sw_per_ (ffelexToken t);
368 static ffelexHandler ffeexpr_token_quote_ (ffelexToken t);
369 static ffelexHandler ffeexpr_token_apostrophe_ (ffelexToken t);
370 static ffelexHandler ffeexpr_token_apos_char_ (ffelexToken t);
371 static ffelexHandler ffeexpr_token_name_lhs_ (ffelexToken t);
372 static ffelexHandler ffeexpr_token_name_arg_ (ffelexToken t);
373 static ffelexHandler ffeexpr_token_name_rhs_ (ffelexToken t);
374 static ffelexHandler ffeexpr_token_name_apos_ (ffelexToken t);
375 static ffelexHandler ffeexpr_token_name_apos_name_ (ffelexToken t);
376 static ffelexHandler ffeexpr_token_percent_ (ffelexToken t);
377 static ffelexHandler ffeexpr_token_percent_name_ (ffelexToken t);
378 static ffelexHandler ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr,
379 ffelexToken t);
380 static ffelexHandler ffeexpr_token_elements_ (ffelexToken ft, ffebld expr,
381 ffelexToken t);
382 static ffelexHandler ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr,
383 ffelexToken t);
384 static ffelexHandler ffeexpr_token_substring_ (ffelexToken ft, ffebld expr,
385 ffelexToken t);
386 static ffelexHandler ffeexpr_token_substring_1_ (ffelexToken ft, ffebld expr,
387 ffelexToken t);
388 static ffelexHandler ffeexpr_token_substrp_ (ffelexToken t);
389 static ffelexHandler ffeexpr_token_intrincheck_ (ffelexToken t);
390 static ffelexHandler ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr,
391 ffelexToken t);
392 static ffelexHandler ffeexpr_token_anything_ (ffelexToken ft, ffebld expr,
393 ffelexToken t);
394 static void ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
395 ffelexToken decimal, ffelexToken fraction, ffelexToken exponent,
396 ffelexToken exponent_sign, ffelexToken exponent_digits);
397 static ffesymbol ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin);
398 static ffesymbol ffeexpr_sym_impdoitem_ (ffesymbol s, ffelexToken t);
399 static ffesymbol ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t);
400 static ffesymbol ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t);
401 static ffesymbol ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t);
402 static ffesymbol ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t);
403 static ffesymbol ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t);
404 static ffesymbol ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t);
405 static ffesymbol ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t);
406 static ffesymbol ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t);
407 static ffesymbol ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t);
408 static ffesymbol ffeexpr_declare_parenthesized_ (ffelexToken t,
409 bool maybe_intrin,
410 ffeexprParenType_ *paren_type);
411 static ffesymbol ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t);
412
413 /* Internal macros. */
414
415 #define ffeexpr_paren_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
416 #define ffeexpr_sym_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
417 \f
418 /* ffeexpr_collapse_convert -- Collapse convert expr
419
420 ffebld expr;
421 ffelexToken token;
422 expr = ffeexpr_collapse_convert(expr,token);
423
424 If the result of the expr is a constant, replaces the expr with the
425 computed constant. */
426
427 ffebld
428 ffeexpr_collapse_convert (ffebld expr, ffelexToken t)
429 {
430 ffebad error = FFEBAD;
431 ffebld l;
432 ffebldConstantUnion u;
433 ffeinfoBasictype bt;
434 ffeinfoKindtype kt;
435 ffetargetCharacterSize sz;
436 ffetargetCharacterSize sz2;
437
438 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
439 return expr;
440
441 l = ffebld_left (expr);
442
443 if (ffebld_op (l) != FFEBLD_opCONTER)
444 return expr;
445
446 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
447 {
448 case FFEINFO_basictypeANY:
449 return expr;
450
451 case FFEINFO_basictypeINTEGER:
452 sz = FFETARGET_charactersizeNONE;
453 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
454 {
455 #if FFETARGET_okINTEGER1
456 case FFEINFO_kindtypeINTEGER1:
457 switch (ffeinfo_basictype (ffebld_info (l)))
458 {
459 case FFEINFO_basictypeINTEGER:
460 switch (ffeinfo_kindtype (ffebld_info (l)))
461 {
462 #if FFETARGET_okINTEGER2
463 case FFEINFO_kindtypeINTEGER2:
464 error = ffetarget_convert_integer1_integer2
465 (ffebld_cu_ptr_integer1 (u),
466 ffebld_constant_integer2 (ffebld_conter (l)));
467 break;
468 #endif
469
470 #if FFETARGET_okINTEGER3
471 case FFEINFO_kindtypeINTEGER3:
472 error = ffetarget_convert_integer1_integer3
473 (ffebld_cu_ptr_integer1 (u),
474 ffebld_constant_integer3 (ffebld_conter (l)));
475 break;
476 #endif
477
478 #if FFETARGET_okINTEGER4
479 case FFEINFO_kindtypeINTEGER4:
480 error = ffetarget_convert_integer1_integer4
481 (ffebld_cu_ptr_integer1 (u),
482 ffebld_constant_integer4 (ffebld_conter (l)));
483 break;
484 #endif
485
486 default:
487 assert ("INTEGER1/INTEGER bad source kind type" == NULL);
488 break;
489 }
490 break;
491
492 case FFEINFO_basictypeREAL:
493 switch (ffeinfo_kindtype (ffebld_info (l)))
494 {
495 #if FFETARGET_okREAL1
496 case FFEINFO_kindtypeREAL1:
497 error = ffetarget_convert_integer1_real1
498 (ffebld_cu_ptr_integer1 (u),
499 ffebld_constant_real1 (ffebld_conter (l)));
500 break;
501 #endif
502
503 #if FFETARGET_okREAL2
504 case FFEINFO_kindtypeREAL2:
505 error = ffetarget_convert_integer1_real2
506 (ffebld_cu_ptr_integer1 (u),
507 ffebld_constant_real2 (ffebld_conter (l)));
508 break;
509 #endif
510
511 #if FFETARGET_okREAL3
512 case FFEINFO_kindtypeREAL3:
513 error = ffetarget_convert_integer1_real3
514 (ffebld_cu_ptr_integer1 (u),
515 ffebld_constant_real3 (ffebld_conter (l)));
516 break;
517 #endif
518
519 default:
520 assert ("INTEGER1/REAL bad source kind type" == NULL);
521 break;
522 }
523 break;
524
525 case FFEINFO_basictypeCOMPLEX:
526 switch (ffeinfo_kindtype (ffebld_info (l)))
527 {
528 #if FFETARGET_okCOMPLEX1
529 case FFEINFO_kindtypeREAL1:
530 error = ffetarget_convert_integer1_complex1
531 (ffebld_cu_ptr_integer1 (u),
532 ffebld_constant_complex1 (ffebld_conter (l)));
533 break;
534 #endif
535
536 #if FFETARGET_okCOMPLEX2
537 case FFEINFO_kindtypeREAL2:
538 error = ffetarget_convert_integer1_complex2
539 (ffebld_cu_ptr_integer1 (u),
540 ffebld_constant_complex2 (ffebld_conter (l)));
541 break;
542 #endif
543
544 #if FFETARGET_okCOMPLEX3
545 case FFEINFO_kindtypeREAL3:
546 error = ffetarget_convert_integer1_complex3
547 (ffebld_cu_ptr_integer1 (u),
548 ffebld_constant_complex3 (ffebld_conter (l)));
549 break;
550 #endif
551
552 default:
553 assert ("INTEGER1/COMPLEX bad source kind type" == NULL);
554 break;
555 }
556 break;
557
558 case FFEINFO_basictypeLOGICAL:
559 switch (ffeinfo_kindtype (ffebld_info (l)))
560 {
561 #if FFETARGET_okLOGICAL1
562 case FFEINFO_kindtypeLOGICAL1:
563 error = ffetarget_convert_integer1_logical1
564 (ffebld_cu_ptr_integer1 (u),
565 ffebld_constant_logical1 (ffebld_conter (l)));
566 break;
567 #endif
568
569 #if FFETARGET_okLOGICAL2
570 case FFEINFO_kindtypeLOGICAL2:
571 error = ffetarget_convert_integer1_logical2
572 (ffebld_cu_ptr_integer1 (u),
573 ffebld_constant_logical2 (ffebld_conter (l)));
574 break;
575 #endif
576
577 #if FFETARGET_okLOGICAL3
578 case FFEINFO_kindtypeLOGICAL3:
579 error = ffetarget_convert_integer1_logical3
580 (ffebld_cu_ptr_integer1 (u),
581 ffebld_constant_logical3 (ffebld_conter (l)));
582 break;
583 #endif
584
585 #if FFETARGET_okLOGICAL4
586 case FFEINFO_kindtypeLOGICAL4:
587 error = ffetarget_convert_integer1_logical4
588 (ffebld_cu_ptr_integer1 (u),
589 ffebld_constant_logical4 (ffebld_conter (l)));
590 break;
591 #endif
592
593 default:
594 assert ("INTEGER1/LOGICAL bad source kind type" == NULL);
595 break;
596 }
597 break;
598
599 case FFEINFO_basictypeCHARACTER:
600 error = ffetarget_convert_integer1_character1
601 (ffebld_cu_ptr_integer1 (u),
602 ffebld_constant_character1 (ffebld_conter (l)));
603 break;
604
605 case FFEINFO_basictypeHOLLERITH:
606 error = ffetarget_convert_integer1_hollerith
607 (ffebld_cu_ptr_integer1 (u),
608 ffebld_constant_hollerith (ffebld_conter (l)));
609 break;
610
611 case FFEINFO_basictypeTYPELESS:
612 error = ffetarget_convert_integer1_typeless
613 (ffebld_cu_ptr_integer1 (u),
614 ffebld_constant_typeless (ffebld_conter (l)));
615 break;
616
617 default:
618 assert ("INTEGER1 bad type" == NULL);
619 break;
620 }
621
622 /* If conversion operation is not implemented, return original expr. */
623 if (error == FFEBAD_NOCANDO)
624 return expr;
625
626 expr = ffebld_new_conter_with_orig
627 (ffebld_constant_new_integer1_val
628 (ffebld_cu_val_integer1 (u)), expr);
629 break;
630 #endif
631
632 #if FFETARGET_okINTEGER2
633 case FFEINFO_kindtypeINTEGER2:
634 switch (ffeinfo_basictype (ffebld_info (l)))
635 {
636 case FFEINFO_basictypeINTEGER:
637 switch (ffeinfo_kindtype (ffebld_info (l)))
638 {
639 #if FFETARGET_okINTEGER1
640 case FFEINFO_kindtypeINTEGER1:
641 error = ffetarget_convert_integer2_integer1
642 (ffebld_cu_ptr_integer2 (u),
643 ffebld_constant_integer1 (ffebld_conter (l)));
644 break;
645 #endif
646
647 #if FFETARGET_okINTEGER3
648 case FFEINFO_kindtypeINTEGER3:
649 error = ffetarget_convert_integer2_integer3
650 (ffebld_cu_ptr_integer2 (u),
651 ffebld_constant_integer3 (ffebld_conter (l)));
652 break;
653 #endif
654
655 #if FFETARGET_okINTEGER4
656 case FFEINFO_kindtypeINTEGER4:
657 error = ffetarget_convert_integer2_integer4
658 (ffebld_cu_ptr_integer2 (u),
659 ffebld_constant_integer4 (ffebld_conter (l)));
660 break;
661 #endif
662
663 default:
664 assert ("INTEGER2/INTEGER bad source kind type" == NULL);
665 break;
666 }
667 break;
668
669 case FFEINFO_basictypeREAL:
670 switch (ffeinfo_kindtype (ffebld_info (l)))
671 {
672 #if FFETARGET_okREAL1
673 case FFEINFO_kindtypeREAL1:
674 error = ffetarget_convert_integer2_real1
675 (ffebld_cu_ptr_integer2 (u),
676 ffebld_constant_real1 (ffebld_conter (l)));
677 break;
678 #endif
679
680 #if FFETARGET_okREAL2
681 case FFEINFO_kindtypeREAL2:
682 error = ffetarget_convert_integer2_real2
683 (ffebld_cu_ptr_integer2 (u),
684 ffebld_constant_real2 (ffebld_conter (l)));
685 break;
686 #endif
687
688 #if FFETARGET_okREAL3
689 case FFEINFO_kindtypeREAL3:
690 error = ffetarget_convert_integer2_real3
691 (ffebld_cu_ptr_integer2 (u),
692 ffebld_constant_real3 (ffebld_conter (l)));
693 break;
694 #endif
695
696 default:
697 assert ("INTEGER2/REAL bad source kind type" == NULL);
698 break;
699 }
700 break;
701
702 case FFEINFO_basictypeCOMPLEX:
703 switch (ffeinfo_kindtype (ffebld_info (l)))
704 {
705 #if FFETARGET_okCOMPLEX1
706 case FFEINFO_kindtypeREAL1:
707 error = ffetarget_convert_integer2_complex1
708 (ffebld_cu_ptr_integer2 (u),
709 ffebld_constant_complex1 (ffebld_conter (l)));
710 break;
711 #endif
712
713 #if FFETARGET_okCOMPLEX2
714 case FFEINFO_kindtypeREAL2:
715 error = ffetarget_convert_integer2_complex2
716 (ffebld_cu_ptr_integer2 (u),
717 ffebld_constant_complex2 (ffebld_conter (l)));
718 break;
719 #endif
720
721 #if FFETARGET_okCOMPLEX3
722 case FFEINFO_kindtypeREAL3:
723 error = ffetarget_convert_integer2_complex3
724 (ffebld_cu_ptr_integer2 (u),
725 ffebld_constant_complex3 (ffebld_conter (l)));
726 break;
727 #endif
728
729 default:
730 assert ("INTEGER2/COMPLEX bad source kind type" == NULL);
731 break;
732 }
733 break;
734
735 case FFEINFO_basictypeLOGICAL:
736 switch (ffeinfo_kindtype (ffebld_info (l)))
737 {
738 #if FFETARGET_okLOGICAL1
739 case FFEINFO_kindtypeLOGICAL1:
740 error = ffetarget_convert_integer2_logical1
741 (ffebld_cu_ptr_integer2 (u),
742 ffebld_constant_logical1 (ffebld_conter (l)));
743 break;
744 #endif
745
746 #if FFETARGET_okLOGICAL2
747 case FFEINFO_kindtypeLOGICAL2:
748 error = ffetarget_convert_integer2_logical2
749 (ffebld_cu_ptr_integer2 (u),
750 ffebld_constant_logical2 (ffebld_conter (l)));
751 break;
752 #endif
753
754 #if FFETARGET_okLOGICAL3
755 case FFEINFO_kindtypeLOGICAL3:
756 error = ffetarget_convert_integer2_logical3
757 (ffebld_cu_ptr_integer2 (u),
758 ffebld_constant_logical3 (ffebld_conter (l)));
759 break;
760 #endif
761
762 #if FFETARGET_okLOGICAL4
763 case FFEINFO_kindtypeLOGICAL4:
764 error = ffetarget_convert_integer2_logical4
765 (ffebld_cu_ptr_integer2 (u),
766 ffebld_constant_logical4 (ffebld_conter (l)));
767 break;
768 #endif
769
770 default:
771 assert ("INTEGER2/LOGICAL bad source kind type" == NULL);
772 break;
773 }
774 break;
775
776 case FFEINFO_basictypeCHARACTER:
777 error = ffetarget_convert_integer2_character1
778 (ffebld_cu_ptr_integer2 (u),
779 ffebld_constant_character1 (ffebld_conter (l)));
780 break;
781
782 case FFEINFO_basictypeHOLLERITH:
783 error = ffetarget_convert_integer2_hollerith
784 (ffebld_cu_ptr_integer2 (u),
785 ffebld_constant_hollerith (ffebld_conter (l)));
786 break;
787
788 case FFEINFO_basictypeTYPELESS:
789 error = ffetarget_convert_integer2_typeless
790 (ffebld_cu_ptr_integer2 (u),
791 ffebld_constant_typeless (ffebld_conter (l)));
792 break;
793
794 default:
795 assert ("INTEGER2 bad type" == NULL);
796 break;
797 }
798
799 /* If conversion operation is not implemented, return original expr. */
800 if (error == FFEBAD_NOCANDO)
801 return expr;
802
803 expr = ffebld_new_conter_with_orig
804 (ffebld_constant_new_integer2_val
805 (ffebld_cu_val_integer2 (u)), expr);
806 break;
807 #endif
808
809 #if FFETARGET_okINTEGER3
810 case FFEINFO_kindtypeINTEGER3:
811 switch (ffeinfo_basictype (ffebld_info (l)))
812 {
813 case FFEINFO_basictypeINTEGER:
814 switch (ffeinfo_kindtype (ffebld_info (l)))
815 {
816 #if FFETARGET_okINTEGER1
817 case FFEINFO_kindtypeINTEGER1:
818 error = ffetarget_convert_integer3_integer1
819 (ffebld_cu_ptr_integer3 (u),
820 ffebld_constant_integer1 (ffebld_conter (l)));
821 break;
822 #endif
823
824 #if FFETARGET_okINTEGER2
825 case FFEINFO_kindtypeINTEGER2:
826 error = ffetarget_convert_integer3_integer2
827 (ffebld_cu_ptr_integer3 (u),
828 ffebld_constant_integer2 (ffebld_conter (l)));
829 break;
830 #endif
831
832 #if FFETARGET_okINTEGER4
833 case FFEINFO_kindtypeINTEGER4:
834 error = ffetarget_convert_integer3_integer4
835 (ffebld_cu_ptr_integer3 (u),
836 ffebld_constant_integer4 (ffebld_conter (l)));
837 break;
838 #endif
839
840 default:
841 assert ("INTEGER3/INTEGER bad source kind type" == NULL);
842 break;
843 }
844 break;
845
846 case FFEINFO_basictypeREAL:
847 switch (ffeinfo_kindtype (ffebld_info (l)))
848 {
849 #if FFETARGET_okREAL1
850 case FFEINFO_kindtypeREAL1:
851 error = ffetarget_convert_integer3_real1
852 (ffebld_cu_ptr_integer3 (u),
853 ffebld_constant_real1 (ffebld_conter (l)));
854 break;
855 #endif
856
857 #if FFETARGET_okREAL2
858 case FFEINFO_kindtypeREAL2:
859 error = ffetarget_convert_integer3_real2
860 (ffebld_cu_ptr_integer3 (u),
861 ffebld_constant_real2 (ffebld_conter (l)));
862 break;
863 #endif
864
865 #if FFETARGET_okREAL3
866 case FFEINFO_kindtypeREAL3:
867 error = ffetarget_convert_integer3_real3
868 (ffebld_cu_ptr_integer3 (u),
869 ffebld_constant_real3 (ffebld_conter (l)));
870 break;
871 #endif
872
873 default:
874 assert ("INTEGER3/REAL bad source kind type" == NULL);
875 break;
876 }
877 break;
878
879 case FFEINFO_basictypeCOMPLEX:
880 switch (ffeinfo_kindtype (ffebld_info (l)))
881 {
882 #if FFETARGET_okCOMPLEX1
883 case FFEINFO_kindtypeREAL1:
884 error = ffetarget_convert_integer3_complex1
885 (ffebld_cu_ptr_integer3 (u),
886 ffebld_constant_complex1 (ffebld_conter (l)));
887 break;
888 #endif
889
890 #if FFETARGET_okCOMPLEX2
891 case FFEINFO_kindtypeREAL2:
892 error = ffetarget_convert_integer3_complex2
893 (ffebld_cu_ptr_integer3 (u),
894 ffebld_constant_complex2 (ffebld_conter (l)));
895 break;
896 #endif
897
898 #if FFETARGET_okCOMPLEX3
899 case FFEINFO_kindtypeREAL3:
900 error = ffetarget_convert_integer3_complex3
901 (ffebld_cu_ptr_integer3 (u),
902 ffebld_constant_complex3 (ffebld_conter (l)));
903 break;
904 #endif
905
906 default:
907 assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
908 break;
909 }
910 break;
911
912 case FFEINFO_basictypeLOGICAL:
913 switch (ffeinfo_kindtype (ffebld_info (l)))
914 {
915 #if FFETARGET_okLOGICAL1
916 case FFEINFO_kindtypeLOGICAL1:
917 error = ffetarget_convert_integer3_logical1
918 (ffebld_cu_ptr_integer3 (u),
919 ffebld_constant_logical1 (ffebld_conter (l)));
920 break;
921 #endif
922
923 #if FFETARGET_okLOGICAL2
924 case FFEINFO_kindtypeLOGICAL2:
925 error = ffetarget_convert_integer3_logical2
926 (ffebld_cu_ptr_integer3 (u),
927 ffebld_constant_logical2 (ffebld_conter (l)));
928 break;
929 #endif
930
931 #if FFETARGET_okLOGICAL3
932 case FFEINFO_kindtypeLOGICAL3:
933 error = ffetarget_convert_integer3_logical3
934 (ffebld_cu_ptr_integer3 (u),
935 ffebld_constant_logical3 (ffebld_conter (l)));
936 break;
937 #endif
938
939 #if FFETARGET_okLOGICAL4
940 case FFEINFO_kindtypeLOGICAL4:
941 error = ffetarget_convert_integer3_logical4
942 (ffebld_cu_ptr_integer3 (u),
943 ffebld_constant_logical4 (ffebld_conter (l)));
944 break;
945 #endif
946
947 default:
948 assert ("INTEGER3/LOGICAL bad source kind type" == NULL);
949 break;
950 }
951 break;
952
953 case FFEINFO_basictypeCHARACTER:
954 error = ffetarget_convert_integer3_character1
955 (ffebld_cu_ptr_integer3 (u),
956 ffebld_constant_character1 (ffebld_conter (l)));
957 break;
958
959 case FFEINFO_basictypeHOLLERITH:
960 error = ffetarget_convert_integer3_hollerith
961 (ffebld_cu_ptr_integer3 (u),
962 ffebld_constant_hollerith (ffebld_conter (l)));
963 break;
964
965 case FFEINFO_basictypeTYPELESS:
966 error = ffetarget_convert_integer3_typeless
967 (ffebld_cu_ptr_integer3 (u),
968 ffebld_constant_typeless (ffebld_conter (l)));
969 break;
970
971 default:
972 assert ("INTEGER3 bad type" == NULL);
973 break;
974 }
975
976 /* If conversion operation is not implemented, return original expr. */
977 if (error == FFEBAD_NOCANDO)
978 return expr;
979
980 expr = ffebld_new_conter_with_orig
981 (ffebld_constant_new_integer3_val
982 (ffebld_cu_val_integer3 (u)), expr);
983 break;
984 #endif
985
986 #if FFETARGET_okINTEGER4
987 case FFEINFO_kindtypeINTEGER4:
988 switch (ffeinfo_basictype (ffebld_info (l)))
989 {
990 case FFEINFO_basictypeINTEGER:
991 switch (ffeinfo_kindtype (ffebld_info (l)))
992 {
993 #if FFETARGET_okINTEGER1
994 case FFEINFO_kindtypeINTEGER1:
995 error = ffetarget_convert_integer4_integer1
996 (ffebld_cu_ptr_integer4 (u),
997 ffebld_constant_integer1 (ffebld_conter (l)));
998 break;
999 #endif
1000
1001 #if FFETARGET_okINTEGER2
1002 case FFEINFO_kindtypeINTEGER2:
1003 error = ffetarget_convert_integer4_integer2
1004 (ffebld_cu_ptr_integer4 (u),
1005 ffebld_constant_integer2 (ffebld_conter (l)));
1006 break;
1007 #endif
1008
1009 #if FFETARGET_okINTEGER3
1010 case FFEINFO_kindtypeINTEGER3:
1011 error = ffetarget_convert_integer4_integer3
1012 (ffebld_cu_ptr_integer4 (u),
1013 ffebld_constant_integer3 (ffebld_conter (l)));
1014 break;
1015 #endif
1016
1017 default:
1018 assert ("INTEGER4/INTEGER bad source kind type" == NULL);
1019 break;
1020 }
1021 break;
1022
1023 case FFEINFO_basictypeREAL:
1024 switch (ffeinfo_kindtype (ffebld_info (l)))
1025 {
1026 #if FFETARGET_okREAL1
1027 case FFEINFO_kindtypeREAL1:
1028 error = ffetarget_convert_integer4_real1
1029 (ffebld_cu_ptr_integer4 (u),
1030 ffebld_constant_real1 (ffebld_conter (l)));
1031 break;
1032 #endif
1033
1034 #if FFETARGET_okREAL2
1035 case FFEINFO_kindtypeREAL2:
1036 error = ffetarget_convert_integer4_real2
1037 (ffebld_cu_ptr_integer4 (u),
1038 ffebld_constant_real2 (ffebld_conter (l)));
1039 break;
1040 #endif
1041
1042 #if FFETARGET_okREAL3
1043 case FFEINFO_kindtypeREAL3:
1044 error = ffetarget_convert_integer4_real3
1045 (ffebld_cu_ptr_integer4 (u),
1046 ffebld_constant_real3 (ffebld_conter (l)));
1047 break;
1048 #endif
1049
1050 default:
1051 assert ("INTEGER4/REAL bad source kind type" == NULL);
1052 break;
1053 }
1054 break;
1055
1056 case FFEINFO_basictypeCOMPLEX:
1057 switch (ffeinfo_kindtype (ffebld_info (l)))
1058 {
1059 #if FFETARGET_okCOMPLEX1
1060 case FFEINFO_kindtypeREAL1:
1061 error = ffetarget_convert_integer4_complex1
1062 (ffebld_cu_ptr_integer4 (u),
1063 ffebld_constant_complex1 (ffebld_conter (l)));
1064 break;
1065 #endif
1066
1067 #if FFETARGET_okCOMPLEX2
1068 case FFEINFO_kindtypeREAL2:
1069 error = ffetarget_convert_integer4_complex2
1070 (ffebld_cu_ptr_integer4 (u),
1071 ffebld_constant_complex2 (ffebld_conter (l)));
1072 break;
1073 #endif
1074
1075 #if FFETARGET_okCOMPLEX3
1076 case FFEINFO_kindtypeREAL3:
1077 error = ffetarget_convert_integer4_complex3
1078 (ffebld_cu_ptr_integer4 (u),
1079 ffebld_constant_complex3 (ffebld_conter (l)));
1080 break;
1081 #endif
1082
1083 default:
1084 assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
1085 break;
1086 }
1087 break;
1088
1089 case FFEINFO_basictypeLOGICAL:
1090 switch (ffeinfo_kindtype (ffebld_info (l)))
1091 {
1092 #if FFETARGET_okLOGICAL1
1093 case FFEINFO_kindtypeLOGICAL1:
1094 error = ffetarget_convert_integer4_logical1
1095 (ffebld_cu_ptr_integer4 (u),
1096 ffebld_constant_logical1 (ffebld_conter (l)));
1097 break;
1098 #endif
1099
1100 #if FFETARGET_okLOGICAL2
1101 case FFEINFO_kindtypeLOGICAL2:
1102 error = ffetarget_convert_integer4_logical2
1103 (ffebld_cu_ptr_integer4 (u),
1104 ffebld_constant_logical2 (ffebld_conter (l)));
1105 break;
1106 #endif
1107
1108 #if FFETARGET_okLOGICAL3
1109 case FFEINFO_kindtypeLOGICAL3:
1110 error = ffetarget_convert_integer4_logical3
1111 (ffebld_cu_ptr_integer4 (u),
1112 ffebld_constant_logical3 (ffebld_conter (l)));
1113 break;
1114 #endif
1115
1116 #if FFETARGET_okLOGICAL4
1117 case FFEINFO_kindtypeLOGICAL4:
1118 error = ffetarget_convert_integer4_logical4
1119 (ffebld_cu_ptr_integer4 (u),
1120 ffebld_constant_logical4 (ffebld_conter (l)));
1121 break;
1122 #endif
1123
1124 default:
1125 assert ("INTEGER4/LOGICAL bad source kind type" == NULL);
1126 break;
1127 }
1128 break;
1129
1130 case FFEINFO_basictypeCHARACTER:
1131 error = ffetarget_convert_integer4_character1
1132 (ffebld_cu_ptr_integer4 (u),
1133 ffebld_constant_character1 (ffebld_conter (l)));
1134 break;
1135
1136 case FFEINFO_basictypeHOLLERITH:
1137 error = ffetarget_convert_integer4_hollerith
1138 (ffebld_cu_ptr_integer4 (u),
1139 ffebld_constant_hollerith (ffebld_conter (l)));
1140 break;
1141
1142 case FFEINFO_basictypeTYPELESS:
1143 error = ffetarget_convert_integer4_typeless
1144 (ffebld_cu_ptr_integer4 (u),
1145 ffebld_constant_typeless (ffebld_conter (l)));
1146 break;
1147
1148 default:
1149 assert ("INTEGER4 bad type" == NULL);
1150 break;
1151 }
1152
1153 /* If conversion operation is not implemented, return original expr. */
1154 if (error == FFEBAD_NOCANDO)
1155 return expr;
1156
1157 expr = ffebld_new_conter_with_orig
1158 (ffebld_constant_new_integer4_val
1159 (ffebld_cu_val_integer4 (u)), expr);
1160 break;
1161 #endif
1162
1163 default:
1164 assert ("bad integer kind type" == NULL);
1165 break;
1166 }
1167 break;
1168
1169 case FFEINFO_basictypeLOGICAL:
1170 sz = FFETARGET_charactersizeNONE;
1171 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1172 {
1173 #if FFETARGET_okLOGICAL1
1174 case FFEINFO_kindtypeLOGICAL1:
1175 switch (ffeinfo_basictype (ffebld_info (l)))
1176 {
1177 case FFEINFO_basictypeLOGICAL:
1178 switch (ffeinfo_kindtype (ffebld_info (l)))
1179 {
1180 #if FFETARGET_okLOGICAL2
1181 case FFEINFO_kindtypeLOGICAL2:
1182 error = ffetarget_convert_logical1_logical2
1183 (ffebld_cu_ptr_logical1 (u),
1184 ffebld_constant_logical2 (ffebld_conter (l)));
1185 break;
1186 #endif
1187
1188 #if FFETARGET_okLOGICAL3
1189 case FFEINFO_kindtypeLOGICAL3:
1190 error = ffetarget_convert_logical1_logical3
1191 (ffebld_cu_ptr_logical1 (u),
1192 ffebld_constant_logical3 (ffebld_conter (l)));
1193 break;
1194 #endif
1195
1196 #if FFETARGET_okLOGICAL4
1197 case FFEINFO_kindtypeLOGICAL4:
1198 error = ffetarget_convert_logical1_logical4
1199 (ffebld_cu_ptr_logical1 (u),
1200 ffebld_constant_logical4 (ffebld_conter (l)));
1201 break;
1202 #endif
1203
1204 default:
1205 assert ("LOGICAL1/LOGICAL bad source kind type" == NULL);
1206 break;
1207 }
1208 break;
1209
1210 case FFEINFO_basictypeINTEGER:
1211 switch (ffeinfo_kindtype (ffebld_info (l)))
1212 {
1213 #if FFETARGET_okINTEGER1
1214 case FFEINFO_kindtypeINTEGER1:
1215 error = ffetarget_convert_logical1_integer1
1216 (ffebld_cu_ptr_logical1 (u),
1217 ffebld_constant_integer1 (ffebld_conter (l)));
1218 break;
1219 #endif
1220
1221 #if FFETARGET_okINTEGER2
1222 case FFEINFO_kindtypeINTEGER2:
1223 error = ffetarget_convert_logical1_integer2
1224 (ffebld_cu_ptr_logical1 (u),
1225 ffebld_constant_integer2 (ffebld_conter (l)));
1226 break;
1227 #endif
1228
1229 #if FFETARGET_okINTEGER3
1230 case FFEINFO_kindtypeINTEGER3:
1231 error = ffetarget_convert_logical1_integer3
1232 (ffebld_cu_ptr_logical1 (u),
1233 ffebld_constant_integer3 (ffebld_conter (l)));
1234 break;
1235 #endif
1236
1237 #if FFETARGET_okINTEGER4
1238 case FFEINFO_kindtypeINTEGER4:
1239 error = ffetarget_convert_logical1_integer4
1240 (ffebld_cu_ptr_logical1 (u),
1241 ffebld_constant_integer4 (ffebld_conter (l)));
1242 break;
1243 #endif
1244
1245 default:
1246 assert ("LOGICAL1/INTEGER bad source kind type" == NULL);
1247 break;
1248 }
1249 break;
1250
1251 case FFEINFO_basictypeCHARACTER:
1252 error = ffetarget_convert_logical1_character1
1253 (ffebld_cu_ptr_logical1 (u),
1254 ffebld_constant_character1 (ffebld_conter (l)));
1255 break;
1256
1257 case FFEINFO_basictypeHOLLERITH:
1258 error = ffetarget_convert_logical1_hollerith
1259 (ffebld_cu_ptr_logical1 (u),
1260 ffebld_constant_hollerith (ffebld_conter (l)));
1261 break;
1262
1263 case FFEINFO_basictypeTYPELESS:
1264 error = ffetarget_convert_logical1_typeless
1265 (ffebld_cu_ptr_logical1 (u),
1266 ffebld_constant_typeless (ffebld_conter (l)));
1267 break;
1268
1269 default:
1270 assert ("LOGICAL1 bad type" == NULL);
1271 break;
1272 }
1273
1274 /* If conversion operation is not implemented, return original expr. */
1275 if (error == FFEBAD_NOCANDO)
1276 return expr;
1277
1278 expr = ffebld_new_conter_with_orig
1279 (ffebld_constant_new_logical1_val
1280 (ffebld_cu_val_logical1 (u)), expr);
1281 break;
1282 #endif
1283
1284 #if FFETARGET_okLOGICAL2
1285 case FFEINFO_kindtypeLOGICAL2:
1286 switch (ffeinfo_basictype (ffebld_info (l)))
1287 {
1288 case FFEINFO_basictypeLOGICAL:
1289 switch (ffeinfo_kindtype (ffebld_info (l)))
1290 {
1291 #if FFETARGET_okLOGICAL1
1292 case FFEINFO_kindtypeLOGICAL1:
1293 error = ffetarget_convert_logical2_logical1
1294 (ffebld_cu_ptr_logical2 (u),
1295 ffebld_constant_logical1 (ffebld_conter (l)));
1296 break;
1297 #endif
1298
1299 #if FFETARGET_okLOGICAL3
1300 case FFEINFO_kindtypeLOGICAL3:
1301 error = ffetarget_convert_logical2_logical3
1302 (ffebld_cu_ptr_logical2 (u),
1303 ffebld_constant_logical3 (ffebld_conter (l)));
1304 break;
1305 #endif
1306
1307 #if FFETARGET_okLOGICAL4
1308 case FFEINFO_kindtypeLOGICAL4:
1309 error = ffetarget_convert_logical2_logical4
1310 (ffebld_cu_ptr_logical2 (u),
1311 ffebld_constant_logical4 (ffebld_conter (l)));
1312 break;
1313 #endif
1314
1315 default:
1316 assert ("LOGICAL2/LOGICAL bad source kind type" == NULL);
1317 break;
1318 }
1319 break;
1320
1321 case FFEINFO_basictypeINTEGER:
1322 switch (ffeinfo_kindtype (ffebld_info (l)))
1323 {
1324 #if FFETARGET_okINTEGER1
1325 case FFEINFO_kindtypeINTEGER1:
1326 error = ffetarget_convert_logical2_integer1
1327 (ffebld_cu_ptr_logical2 (u),
1328 ffebld_constant_integer1 (ffebld_conter (l)));
1329 break;
1330 #endif
1331
1332 #if FFETARGET_okINTEGER2
1333 case FFEINFO_kindtypeINTEGER2:
1334 error = ffetarget_convert_logical2_integer2
1335 (ffebld_cu_ptr_logical2 (u),
1336 ffebld_constant_integer2 (ffebld_conter (l)));
1337 break;
1338 #endif
1339
1340 #if FFETARGET_okINTEGER3
1341 case FFEINFO_kindtypeINTEGER3:
1342 error = ffetarget_convert_logical2_integer3
1343 (ffebld_cu_ptr_logical2 (u),
1344 ffebld_constant_integer3 (ffebld_conter (l)));
1345 break;
1346 #endif
1347
1348 #if FFETARGET_okINTEGER4
1349 case FFEINFO_kindtypeINTEGER4:
1350 error = ffetarget_convert_logical2_integer4
1351 (ffebld_cu_ptr_logical2 (u),
1352 ffebld_constant_integer4 (ffebld_conter (l)));
1353 break;
1354 #endif
1355
1356 default:
1357 assert ("LOGICAL2/INTEGER bad source kind type" == NULL);
1358 break;
1359 }
1360 break;
1361
1362 case FFEINFO_basictypeCHARACTER:
1363 error = ffetarget_convert_logical2_character1
1364 (ffebld_cu_ptr_logical2 (u),
1365 ffebld_constant_character1 (ffebld_conter (l)));
1366 break;
1367
1368 case FFEINFO_basictypeHOLLERITH:
1369 error = ffetarget_convert_logical2_hollerith
1370 (ffebld_cu_ptr_logical2 (u),
1371 ffebld_constant_hollerith (ffebld_conter (l)));
1372 break;
1373
1374 case FFEINFO_basictypeTYPELESS:
1375 error = ffetarget_convert_logical2_typeless
1376 (ffebld_cu_ptr_logical2 (u),
1377 ffebld_constant_typeless (ffebld_conter (l)));
1378 break;
1379
1380 default:
1381 assert ("LOGICAL2 bad type" == NULL);
1382 break;
1383 }
1384
1385 /* If conversion operation is not implemented, return original expr. */
1386 if (error == FFEBAD_NOCANDO)
1387 return expr;
1388
1389 expr = ffebld_new_conter_with_orig
1390 (ffebld_constant_new_logical2_val
1391 (ffebld_cu_val_logical2 (u)), expr);
1392 break;
1393 #endif
1394
1395 #if FFETARGET_okLOGICAL3
1396 case FFEINFO_kindtypeLOGICAL3:
1397 switch (ffeinfo_basictype (ffebld_info (l)))
1398 {
1399 case FFEINFO_basictypeLOGICAL:
1400 switch (ffeinfo_kindtype (ffebld_info (l)))
1401 {
1402 #if FFETARGET_okLOGICAL1
1403 case FFEINFO_kindtypeLOGICAL1:
1404 error = ffetarget_convert_logical3_logical1
1405 (ffebld_cu_ptr_logical3 (u),
1406 ffebld_constant_logical1 (ffebld_conter (l)));
1407 break;
1408 #endif
1409
1410 #if FFETARGET_okLOGICAL2
1411 case FFEINFO_kindtypeLOGICAL2:
1412 error = ffetarget_convert_logical3_logical2
1413 (ffebld_cu_ptr_logical3 (u),
1414 ffebld_constant_logical2 (ffebld_conter (l)));
1415 break;
1416 #endif
1417
1418 #if FFETARGET_okLOGICAL4
1419 case FFEINFO_kindtypeLOGICAL4:
1420 error = ffetarget_convert_logical3_logical4
1421 (ffebld_cu_ptr_logical3 (u),
1422 ffebld_constant_logical4 (ffebld_conter (l)));
1423 break;
1424 #endif
1425
1426 default:
1427 assert ("LOGICAL3/LOGICAL bad source kind type" == NULL);
1428 break;
1429 }
1430 break;
1431
1432 case FFEINFO_basictypeINTEGER:
1433 switch (ffeinfo_kindtype (ffebld_info (l)))
1434 {
1435 #if FFETARGET_okINTEGER1
1436 case FFEINFO_kindtypeINTEGER1:
1437 error = ffetarget_convert_logical3_integer1
1438 (ffebld_cu_ptr_logical3 (u),
1439 ffebld_constant_integer1 (ffebld_conter (l)));
1440 break;
1441 #endif
1442
1443 #if FFETARGET_okINTEGER2
1444 case FFEINFO_kindtypeINTEGER2:
1445 error = ffetarget_convert_logical3_integer2
1446 (ffebld_cu_ptr_logical3 (u),
1447 ffebld_constant_integer2 (ffebld_conter (l)));
1448 break;
1449 #endif
1450
1451 #if FFETARGET_okINTEGER3
1452 case FFEINFO_kindtypeINTEGER3:
1453 error = ffetarget_convert_logical3_integer3
1454 (ffebld_cu_ptr_logical3 (u),
1455 ffebld_constant_integer3 (ffebld_conter (l)));
1456 break;
1457 #endif
1458
1459 #if FFETARGET_okINTEGER4
1460 case FFEINFO_kindtypeINTEGER4:
1461 error = ffetarget_convert_logical3_integer4
1462 (ffebld_cu_ptr_logical3 (u),
1463 ffebld_constant_integer4 (ffebld_conter (l)));
1464 break;
1465 #endif
1466
1467 default:
1468 assert ("LOGICAL3/INTEGER bad source kind type" == NULL);
1469 break;
1470 }
1471 break;
1472
1473 case FFEINFO_basictypeCHARACTER:
1474 error = ffetarget_convert_logical3_character1
1475 (ffebld_cu_ptr_logical3 (u),
1476 ffebld_constant_character1 (ffebld_conter (l)));
1477 break;
1478
1479 case FFEINFO_basictypeHOLLERITH:
1480 error = ffetarget_convert_logical3_hollerith
1481 (ffebld_cu_ptr_logical3 (u),
1482 ffebld_constant_hollerith (ffebld_conter (l)));
1483 break;
1484
1485 case FFEINFO_basictypeTYPELESS:
1486 error = ffetarget_convert_logical3_typeless
1487 (ffebld_cu_ptr_logical3 (u),
1488 ffebld_constant_typeless (ffebld_conter (l)));
1489 break;
1490
1491 default:
1492 assert ("LOGICAL3 bad type" == NULL);
1493 break;
1494 }
1495
1496 /* If conversion operation is not implemented, return original expr. */
1497 if (error == FFEBAD_NOCANDO)
1498 return expr;
1499
1500 expr = ffebld_new_conter_with_orig
1501 (ffebld_constant_new_logical3_val
1502 (ffebld_cu_val_logical3 (u)), expr);
1503 break;
1504 #endif
1505
1506 #if FFETARGET_okLOGICAL4
1507 case FFEINFO_kindtypeLOGICAL4:
1508 switch (ffeinfo_basictype (ffebld_info (l)))
1509 {
1510 case FFEINFO_basictypeLOGICAL:
1511 switch (ffeinfo_kindtype (ffebld_info (l)))
1512 {
1513 #if FFETARGET_okLOGICAL1
1514 case FFEINFO_kindtypeLOGICAL1:
1515 error = ffetarget_convert_logical4_logical1
1516 (ffebld_cu_ptr_logical4 (u),
1517 ffebld_constant_logical1 (ffebld_conter (l)));
1518 break;
1519 #endif
1520
1521 #if FFETARGET_okLOGICAL2
1522 case FFEINFO_kindtypeLOGICAL2:
1523 error = ffetarget_convert_logical4_logical2
1524 (ffebld_cu_ptr_logical4 (u),
1525 ffebld_constant_logical2 (ffebld_conter (l)));
1526 break;
1527 #endif
1528
1529 #if FFETARGET_okLOGICAL3
1530 case FFEINFO_kindtypeLOGICAL3:
1531 error = ffetarget_convert_logical4_logical3
1532 (ffebld_cu_ptr_logical4 (u),
1533 ffebld_constant_logical3 (ffebld_conter (l)));
1534 break;
1535 #endif
1536
1537 default:
1538 assert ("LOGICAL4/LOGICAL bad source kind type" == NULL);
1539 break;
1540 }
1541 break;
1542
1543 case FFEINFO_basictypeINTEGER:
1544 switch (ffeinfo_kindtype (ffebld_info (l)))
1545 {
1546 #if FFETARGET_okINTEGER1
1547 case FFEINFO_kindtypeINTEGER1:
1548 error = ffetarget_convert_logical4_integer1
1549 (ffebld_cu_ptr_logical4 (u),
1550 ffebld_constant_integer1 (ffebld_conter (l)));
1551 break;
1552 #endif
1553
1554 #if FFETARGET_okINTEGER2
1555 case FFEINFO_kindtypeINTEGER2:
1556 error = ffetarget_convert_logical4_integer2
1557 (ffebld_cu_ptr_logical4 (u),
1558 ffebld_constant_integer2 (ffebld_conter (l)));
1559 break;
1560 #endif
1561
1562 #if FFETARGET_okINTEGER3
1563 case FFEINFO_kindtypeINTEGER3:
1564 error = ffetarget_convert_logical4_integer3
1565 (ffebld_cu_ptr_logical4 (u),
1566 ffebld_constant_integer3 (ffebld_conter (l)));
1567 break;
1568 #endif
1569
1570 #if FFETARGET_okINTEGER4
1571 case FFEINFO_kindtypeINTEGER4:
1572 error = ffetarget_convert_logical4_integer4
1573 (ffebld_cu_ptr_logical4 (u),
1574 ffebld_constant_integer4 (ffebld_conter (l)));
1575 break;
1576 #endif
1577
1578 default:
1579 assert ("LOGICAL4/INTEGER bad source kind type" == NULL);
1580 break;
1581 }
1582 break;
1583
1584 case FFEINFO_basictypeCHARACTER:
1585 error = ffetarget_convert_logical4_character1
1586 (ffebld_cu_ptr_logical4 (u),
1587 ffebld_constant_character1 (ffebld_conter (l)));
1588 break;
1589
1590 case FFEINFO_basictypeHOLLERITH:
1591 error = ffetarget_convert_logical4_hollerith
1592 (ffebld_cu_ptr_logical4 (u),
1593 ffebld_constant_hollerith (ffebld_conter (l)));
1594 break;
1595
1596 case FFEINFO_basictypeTYPELESS:
1597 error = ffetarget_convert_logical4_typeless
1598 (ffebld_cu_ptr_logical4 (u),
1599 ffebld_constant_typeless (ffebld_conter (l)));
1600 break;
1601
1602 default:
1603 assert ("LOGICAL4 bad type" == NULL);
1604 break;
1605 }
1606
1607 /* If conversion operation is not implemented, return original expr. */
1608 if (error == FFEBAD_NOCANDO)
1609 return expr;
1610
1611 expr = ffebld_new_conter_with_orig
1612 (ffebld_constant_new_logical4_val
1613 (ffebld_cu_val_logical4 (u)), expr);
1614 break;
1615 #endif
1616
1617 default:
1618 assert ("bad logical kind type" == NULL);
1619 break;
1620 }
1621 break;
1622
1623 case FFEINFO_basictypeREAL:
1624 sz = FFETARGET_charactersizeNONE;
1625 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1626 {
1627 #if FFETARGET_okREAL1
1628 case FFEINFO_kindtypeREAL1:
1629 switch (ffeinfo_basictype (ffebld_info (l)))
1630 {
1631 case FFEINFO_basictypeINTEGER:
1632 switch (ffeinfo_kindtype (ffebld_info (l)))
1633 {
1634 #if FFETARGET_okINTEGER1
1635 case FFEINFO_kindtypeINTEGER1:
1636 error = ffetarget_convert_real1_integer1
1637 (ffebld_cu_ptr_real1 (u),
1638 ffebld_constant_integer1 (ffebld_conter (l)));
1639 break;
1640 #endif
1641
1642 #if FFETARGET_okINTEGER2
1643 case FFEINFO_kindtypeINTEGER2:
1644 error = ffetarget_convert_real1_integer2
1645 (ffebld_cu_ptr_real1 (u),
1646 ffebld_constant_integer2 (ffebld_conter (l)));
1647 break;
1648 #endif
1649
1650 #if FFETARGET_okINTEGER3
1651 case FFEINFO_kindtypeINTEGER3:
1652 error = ffetarget_convert_real1_integer3
1653 (ffebld_cu_ptr_real1 (u),
1654 ffebld_constant_integer3 (ffebld_conter (l)));
1655 break;
1656 #endif
1657
1658 #if FFETARGET_okINTEGER4
1659 case FFEINFO_kindtypeINTEGER4:
1660 error = ffetarget_convert_real1_integer4
1661 (ffebld_cu_ptr_real1 (u),
1662 ffebld_constant_integer4 (ffebld_conter (l)));
1663 break;
1664 #endif
1665
1666 default:
1667 assert ("REAL1/INTEGER bad source kind type" == NULL);
1668 break;
1669 }
1670 break;
1671
1672 case FFEINFO_basictypeREAL:
1673 switch (ffeinfo_kindtype (ffebld_info (l)))
1674 {
1675 #if FFETARGET_okREAL2
1676 case FFEINFO_kindtypeREAL2:
1677 error = ffetarget_convert_real1_real2
1678 (ffebld_cu_ptr_real1 (u),
1679 ffebld_constant_real2 (ffebld_conter (l)));
1680 break;
1681 #endif
1682
1683 #if FFETARGET_okREAL3
1684 case FFEINFO_kindtypeREAL3:
1685 error = ffetarget_convert_real1_real3
1686 (ffebld_cu_ptr_real1 (u),
1687 ffebld_constant_real3 (ffebld_conter (l)));
1688 break;
1689 #endif
1690
1691 default:
1692 assert ("REAL1/REAL bad source kind type" == NULL);
1693 break;
1694 }
1695 break;
1696
1697 case FFEINFO_basictypeCOMPLEX:
1698 switch (ffeinfo_kindtype (ffebld_info (l)))
1699 {
1700 #if FFETARGET_okCOMPLEX1
1701 case FFEINFO_kindtypeREAL1:
1702 error = ffetarget_convert_real1_complex1
1703 (ffebld_cu_ptr_real1 (u),
1704 ffebld_constant_complex1 (ffebld_conter (l)));
1705 break;
1706 #endif
1707
1708 #if FFETARGET_okCOMPLEX2
1709 case FFEINFO_kindtypeREAL2:
1710 error = ffetarget_convert_real1_complex2
1711 (ffebld_cu_ptr_real1 (u),
1712 ffebld_constant_complex2 (ffebld_conter (l)));
1713 break;
1714 #endif
1715
1716 #if FFETARGET_okCOMPLEX3
1717 case FFEINFO_kindtypeREAL3:
1718 error = ffetarget_convert_real1_complex3
1719 (ffebld_cu_ptr_real1 (u),
1720 ffebld_constant_complex3 (ffebld_conter (l)));
1721 break;
1722 #endif
1723
1724 default:
1725 assert ("REAL1/COMPLEX bad source kind type" == NULL);
1726 break;
1727 }
1728 break;
1729
1730 case FFEINFO_basictypeCHARACTER:
1731 error = ffetarget_convert_real1_character1
1732 (ffebld_cu_ptr_real1 (u),
1733 ffebld_constant_character1 (ffebld_conter (l)));
1734 break;
1735
1736 case FFEINFO_basictypeHOLLERITH:
1737 error = ffetarget_convert_real1_hollerith
1738 (ffebld_cu_ptr_real1 (u),
1739 ffebld_constant_hollerith (ffebld_conter (l)));
1740 break;
1741
1742 case FFEINFO_basictypeTYPELESS:
1743 error = ffetarget_convert_real1_typeless
1744 (ffebld_cu_ptr_real1 (u),
1745 ffebld_constant_typeless (ffebld_conter (l)));
1746 break;
1747
1748 default:
1749 assert ("REAL1 bad type" == NULL);
1750 break;
1751 }
1752
1753 /* If conversion operation is not implemented, return original expr. */
1754 if (error == FFEBAD_NOCANDO)
1755 return expr;
1756
1757 expr = ffebld_new_conter_with_orig
1758 (ffebld_constant_new_real1_val
1759 (ffebld_cu_val_real1 (u)), expr);
1760 break;
1761 #endif
1762
1763 #if FFETARGET_okREAL2
1764 case FFEINFO_kindtypeREAL2:
1765 switch (ffeinfo_basictype (ffebld_info (l)))
1766 {
1767 case FFEINFO_basictypeINTEGER:
1768 switch (ffeinfo_kindtype (ffebld_info (l)))
1769 {
1770 #if FFETARGET_okINTEGER1
1771 case FFEINFO_kindtypeINTEGER1:
1772 error = ffetarget_convert_real2_integer1
1773 (ffebld_cu_ptr_real2 (u),
1774 ffebld_constant_integer1 (ffebld_conter (l)));
1775 break;
1776 #endif
1777
1778 #if FFETARGET_okINTEGER2
1779 case FFEINFO_kindtypeINTEGER2:
1780 error = ffetarget_convert_real2_integer2
1781 (ffebld_cu_ptr_real2 (u),
1782 ffebld_constant_integer2 (ffebld_conter (l)));
1783 break;
1784 #endif
1785
1786 #if FFETARGET_okINTEGER3
1787 case FFEINFO_kindtypeINTEGER3:
1788 error = ffetarget_convert_real2_integer3
1789 (ffebld_cu_ptr_real2 (u),
1790 ffebld_constant_integer3 (ffebld_conter (l)));
1791 break;
1792 #endif
1793
1794 #if FFETARGET_okINTEGER4
1795 case FFEINFO_kindtypeINTEGER4:
1796 error = ffetarget_convert_real2_integer4
1797 (ffebld_cu_ptr_real2 (u),
1798 ffebld_constant_integer4 (ffebld_conter (l)));
1799 break;
1800 #endif
1801
1802 default:
1803 assert ("REAL2/INTEGER bad source kind type" == NULL);
1804 break;
1805 }
1806 break;
1807
1808 case FFEINFO_basictypeREAL:
1809 switch (ffeinfo_kindtype (ffebld_info (l)))
1810 {
1811 #if FFETARGET_okREAL1
1812 case FFEINFO_kindtypeREAL1:
1813 error = ffetarget_convert_real2_real1
1814 (ffebld_cu_ptr_real2 (u),
1815 ffebld_constant_real1 (ffebld_conter (l)));
1816 break;
1817 #endif
1818
1819 #if FFETARGET_okREAL3
1820 case FFEINFO_kindtypeREAL3:
1821 error = ffetarget_convert_real2_real3
1822 (ffebld_cu_ptr_real2 (u),
1823 ffebld_constant_real3 (ffebld_conter (l)));
1824 break;
1825 #endif
1826
1827 default:
1828 assert ("REAL2/REAL bad source kind type" == NULL);
1829 break;
1830 }
1831 break;
1832
1833 case FFEINFO_basictypeCOMPLEX:
1834 switch (ffeinfo_kindtype (ffebld_info (l)))
1835 {
1836 #if FFETARGET_okCOMPLEX1
1837 case FFEINFO_kindtypeREAL1:
1838 error = ffetarget_convert_real2_complex1
1839 (ffebld_cu_ptr_real2 (u),
1840 ffebld_constant_complex1 (ffebld_conter (l)));
1841 break;
1842 #endif
1843
1844 #if FFETARGET_okCOMPLEX2
1845 case FFEINFO_kindtypeREAL2:
1846 error = ffetarget_convert_real2_complex2
1847 (ffebld_cu_ptr_real2 (u),
1848 ffebld_constant_complex2 (ffebld_conter (l)));
1849 break;
1850 #endif
1851
1852 #if FFETARGET_okCOMPLEX3
1853 case FFEINFO_kindtypeREAL3:
1854 error = ffetarget_convert_real2_complex3
1855 (ffebld_cu_ptr_real2 (u),
1856 ffebld_constant_complex3 (ffebld_conter (l)));
1857 break;
1858 #endif
1859
1860 default:
1861 assert ("REAL2/COMPLEX bad source kind type" == NULL);
1862 break;
1863 }
1864 break;
1865
1866 case FFEINFO_basictypeCHARACTER:
1867 error = ffetarget_convert_real2_character1
1868 (ffebld_cu_ptr_real2 (u),
1869 ffebld_constant_character1 (ffebld_conter (l)));
1870 break;
1871
1872 case FFEINFO_basictypeHOLLERITH:
1873 error = ffetarget_convert_real2_hollerith
1874 (ffebld_cu_ptr_real2 (u),
1875 ffebld_constant_hollerith (ffebld_conter (l)));
1876 break;
1877
1878 case FFEINFO_basictypeTYPELESS:
1879 error = ffetarget_convert_real2_typeless
1880 (ffebld_cu_ptr_real2 (u),
1881 ffebld_constant_typeless (ffebld_conter (l)));
1882 break;
1883
1884 default:
1885 assert ("REAL2 bad type" == NULL);
1886 break;
1887 }
1888
1889 /* If conversion operation is not implemented, return original expr. */
1890 if (error == FFEBAD_NOCANDO)
1891 return expr;
1892
1893 expr = ffebld_new_conter_with_orig
1894 (ffebld_constant_new_real2_val
1895 (ffebld_cu_val_real2 (u)), expr);
1896 break;
1897 #endif
1898
1899 #if FFETARGET_okREAL3
1900 case FFEINFO_kindtypeREAL3:
1901 switch (ffeinfo_basictype (ffebld_info (l)))
1902 {
1903 case FFEINFO_basictypeINTEGER:
1904 switch (ffeinfo_kindtype (ffebld_info (l)))
1905 {
1906 #if FFETARGET_okINTEGER1
1907 case FFEINFO_kindtypeINTEGER1:
1908 error = ffetarget_convert_real3_integer1
1909 (ffebld_cu_ptr_real3 (u),
1910 ffebld_constant_integer1 (ffebld_conter (l)));
1911 break;
1912 #endif
1913
1914 #if FFETARGET_okINTEGER2
1915 case FFEINFO_kindtypeINTEGER2:
1916 error = ffetarget_convert_real3_integer2
1917 (ffebld_cu_ptr_real3 (u),
1918 ffebld_constant_integer2 (ffebld_conter (l)));
1919 break;
1920 #endif
1921
1922 #if FFETARGET_okINTEGER3
1923 case FFEINFO_kindtypeINTEGER3:
1924 error = ffetarget_convert_real3_integer3
1925 (ffebld_cu_ptr_real3 (u),
1926 ffebld_constant_integer3 (ffebld_conter (l)));
1927 break;
1928 #endif
1929
1930 #if FFETARGET_okINTEGER4
1931 case FFEINFO_kindtypeINTEGER4:
1932 error = ffetarget_convert_real3_integer4
1933 (ffebld_cu_ptr_real3 (u),
1934 ffebld_constant_integer4 (ffebld_conter (l)));
1935 break;
1936 #endif
1937
1938 default:
1939 assert ("REAL3/INTEGER bad source kind type" == NULL);
1940 break;
1941 }
1942 break;
1943
1944 case FFEINFO_basictypeREAL:
1945 switch (ffeinfo_kindtype (ffebld_info (l)))
1946 {
1947 #if FFETARGET_okREAL1
1948 case FFEINFO_kindtypeREAL1:
1949 error = ffetarget_convert_real3_real1
1950 (ffebld_cu_ptr_real3 (u),
1951 ffebld_constant_real1 (ffebld_conter (l)));
1952 break;
1953 #endif
1954
1955 #if FFETARGET_okREAL2
1956 case FFEINFO_kindtypeREAL2:
1957 error = ffetarget_convert_real3_real2
1958 (ffebld_cu_ptr_real3 (u),
1959 ffebld_constant_real2 (ffebld_conter (l)));
1960 break;
1961 #endif
1962
1963 default:
1964 assert ("REAL3/REAL bad source kind type" == NULL);
1965 break;
1966 }
1967 break;
1968
1969 case FFEINFO_basictypeCOMPLEX:
1970 switch (ffeinfo_kindtype (ffebld_info (l)))
1971 {
1972 #if FFETARGET_okCOMPLEX1
1973 case FFEINFO_kindtypeREAL1:
1974 error = ffetarget_convert_real3_complex1
1975 (ffebld_cu_ptr_real3 (u),
1976 ffebld_constant_complex1 (ffebld_conter (l)));
1977 break;
1978 #endif
1979
1980 #if FFETARGET_okCOMPLEX2
1981 case FFEINFO_kindtypeREAL2:
1982 error = ffetarget_convert_real3_complex2
1983 (ffebld_cu_ptr_real3 (u),
1984 ffebld_constant_complex2 (ffebld_conter (l)));
1985 break;
1986 #endif
1987
1988 #if FFETARGET_okCOMPLEX3
1989 case FFEINFO_kindtypeREAL3:
1990 error = ffetarget_convert_real3_complex3
1991 (ffebld_cu_ptr_real3 (u),
1992 ffebld_constant_complex3 (ffebld_conter (l)));
1993 break;
1994 #endif
1995
1996 default:
1997 assert ("REAL3/COMPLEX bad source kind type" == NULL);
1998 break;
1999 }
2000 break;
2001
2002 case FFEINFO_basictypeCHARACTER:
2003 error = ffetarget_convert_real3_character1
2004 (ffebld_cu_ptr_real3 (u),
2005 ffebld_constant_character1 (ffebld_conter (l)));
2006 break;
2007
2008 case FFEINFO_basictypeHOLLERITH:
2009 error = ffetarget_convert_real3_hollerith
2010 (ffebld_cu_ptr_real3 (u),
2011 ffebld_constant_hollerith (ffebld_conter (l)));
2012 break;
2013
2014 case FFEINFO_basictypeTYPELESS:
2015 error = ffetarget_convert_real3_typeless
2016 (ffebld_cu_ptr_real3 (u),
2017 ffebld_constant_typeless (ffebld_conter (l)));
2018 break;
2019
2020 default:
2021 assert ("REAL3 bad type" == NULL);
2022 break;
2023 }
2024
2025 /* If conversion operation is not implemented, return original expr. */
2026 if (error == FFEBAD_NOCANDO)
2027 return expr;
2028
2029 expr = ffebld_new_conter_with_orig
2030 (ffebld_constant_new_real3_val
2031 (ffebld_cu_val_real3 (u)), expr);
2032 break;
2033 #endif
2034
2035 default:
2036 assert ("bad real kind type" == NULL);
2037 break;
2038 }
2039 break;
2040
2041 case FFEINFO_basictypeCOMPLEX:
2042 sz = FFETARGET_charactersizeNONE;
2043 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2044 {
2045 #if FFETARGET_okCOMPLEX1
2046 case FFEINFO_kindtypeREAL1:
2047 switch (ffeinfo_basictype (ffebld_info (l)))
2048 {
2049 case FFEINFO_basictypeINTEGER:
2050 switch (ffeinfo_kindtype (ffebld_info (l)))
2051 {
2052 #if FFETARGET_okINTEGER1
2053 case FFEINFO_kindtypeINTEGER1:
2054 error = ffetarget_convert_complex1_integer1
2055 (ffebld_cu_ptr_complex1 (u),
2056 ffebld_constant_integer1 (ffebld_conter (l)));
2057 break;
2058 #endif
2059
2060 #if FFETARGET_okINTEGER2
2061 case FFEINFO_kindtypeINTEGER2:
2062 error = ffetarget_convert_complex1_integer2
2063 (ffebld_cu_ptr_complex1 (u),
2064 ffebld_constant_integer2 (ffebld_conter (l)));
2065 break;
2066 #endif
2067
2068 #if FFETARGET_okINTEGER3
2069 case FFEINFO_kindtypeINTEGER3:
2070 error = ffetarget_convert_complex1_integer3
2071 (ffebld_cu_ptr_complex1 (u),
2072 ffebld_constant_integer3 (ffebld_conter (l)));
2073 break;
2074 #endif
2075
2076 #if FFETARGET_okINTEGER4
2077 case FFEINFO_kindtypeINTEGER4:
2078 error = ffetarget_convert_complex1_integer4
2079 (ffebld_cu_ptr_complex1 (u),
2080 ffebld_constant_integer4 (ffebld_conter (l)));
2081 break;
2082 #endif
2083
2084 default:
2085 assert ("COMPLEX1/INTEGER bad source kind type" == NULL);
2086 break;
2087 }
2088 break;
2089
2090 case FFEINFO_basictypeREAL:
2091 switch (ffeinfo_kindtype (ffebld_info (l)))
2092 {
2093 #if FFETARGET_okREAL1
2094 case FFEINFO_kindtypeREAL1:
2095 error = ffetarget_convert_complex1_real1
2096 (ffebld_cu_ptr_complex1 (u),
2097 ffebld_constant_real1 (ffebld_conter (l)));
2098 break;
2099 #endif
2100
2101 #if FFETARGET_okREAL2
2102 case FFEINFO_kindtypeREAL2:
2103 error = ffetarget_convert_complex1_real2
2104 (ffebld_cu_ptr_complex1 (u),
2105 ffebld_constant_real2 (ffebld_conter (l)));
2106 break;
2107 #endif
2108
2109 #if FFETARGET_okREAL3
2110 case FFEINFO_kindtypeREAL3:
2111 error = ffetarget_convert_complex1_real3
2112 (ffebld_cu_ptr_complex1 (u),
2113 ffebld_constant_real3 (ffebld_conter (l)));
2114 break;
2115 #endif
2116
2117 default:
2118 assert ("COMPLEX1/REAL bad source kind type" == NULL);
2119 break;
2120 }
2121 break;
2122
2123 case FFEINFO_basictypeCOMPLEX:
2124 switch (ffeinfo_kindtype (ffebld_info (l)))
2125 {
2126 #if FFETARGET_okCOMPLEX2
2127 case FFEINFO_kindtypeREAL2:
2128 error = ffetarget_convert_complex1_complex2
2129 (ffebld_cu_ptr_complex1 (u),
2130 ffebld_constant_complex2 (ffebld_conter (l)));
2131 break;
2132 #endif
2133
2134 #if FFETARGET_okCOMPLEX3
2135 case FFEINFO_kindtypeREAL3:
2136 error = ffetarget_convert_complex1_complex3
2137 (ffebld_cu_ptr_complex1 (u),
2138 ffebld_constant_complex3 (ffebld_conter (l)));
2139 break;
2140 #endif
2141
2142 default:
2143 assert ("COMPLEX1/COMPLEX bad source kind type" == NULL);
2144 break;
2145 }
2146 break;
2147
2148 case FFEINFO_basictypeCHARACTER:
2149 error = ffetarget_convert_complex1_character1
2150 (ffebld_cu_ptr_complex1 (u),
2151 ffebld_constant_character1 (ffebld_conter (l)));
2152 break;
2153
2154 case FFEINFO_basictypeHOLLERITH:
2155 error = ffetarget_convert_complex1_hollerith
2156 (ffebld_cu_ptr_complex1 (u),
2157 ffebld_constant_hollerith (ffebld_conter (l)));
2158 break;
2159
2160 case FFEINFO_basictypeTYPELESS:
2161 error = ffetarget_convert_complex1_typeless
2162 (ffebld_cu_ptr_complex1 (u),
2163 ffebld_constant_typeless (ffebld_conter (l)));
2164 break;
2165
2166 default:
2167 assert ("COMPLEX1 bad type" == NULL);
2168 break;
2169 }
2170
2171 /* If conversion operation is not implemented, return original expr. */
2172 if (error == FFEBAD_NOCANDO)
2173 return expr;
2174
2175 expr = ffebld_new_conter_with_orig
2176 (ffebld_constant_new_complex1_val
2177 (ffebld_cu_val_complex1 (u)), expr);
2178 break;
2179 #endif
2180
2181 #if FFETARGET_okCOMPLEX2
2182 case FFEINFO_kindtypeREAL2:
2183 switch (ffeinfo_basictype (ffebld_info (l)))
2184 {
2185 case FFEINFO_basictypeINTEGER:
2186 switch (ffeinfo_kindtype (ffebld_info (l)))
2187 {
2188 #if FFETARGET_okINTEGER1
2189 case FFEINFO_kindtypeINTEGER1:
2190 error = ffetarget_convert_complex2_integer1
2191 (ffebld_cu_ptr_complex2 (u),
2192 ffebld_constant_integer1 (ffebld_conter (l)));
2193 break;
2194 #endif
2195
2196 #if FFETARGET_okINTEGER2
2197 case FFEINFO_kindtypeINTEGER2:
2198 error = ffetarget_convert_complex2_integer2
2199 (ffebld_cu_ptr_complex2 (u),
2200 ffebld_constant_integer2 (ffebld_conter (l)));
2201 break;
2202 #endif
2203
2204 #if FFETARGET_okINTEGER3
2205 case FFEINFO_kindtypeINTEGER3:
2206 error = ffetarget_convert_complex2_integer3
2207 (ffebld_cu_ptr_complex2 (u),
2208 ffebld_constant_integer3 (ffebld_conter (l)));
2209 break;
2210 #endif
2211
2212 #if FFETARGET_okINTEGER4
2213 case FFEINFO_kindtypeINTEGER4:
2214 error = ffetarget_convert_complex2_integer4
2215 (ffebld_cu_ptr_complex2 (u),
2216 ffebld_constant_integer4 (ffebld_conter (l)));
2217 break;
2218 #endif
2219
2220 default:
2221 assert ("COMPLEX2/INTEGER bad source kind type" == NULL);
2222 break;
2223 }
2224 break;
2225
2226 case FFEINFO_basictypeREAL:
2227 switch (ffeinfo_kindtype (ffebld_info (l)))
2228 {
2229 #if FFETARGET_okREAL1
2230 case FFEINFO_kindtypeREAL1:
2231 error = ffetarget_convert_complex2_real1
2232 (ffebld_cu_ptr_complex2 (u),
2233 ffebld_constant_real1 (ffebld_conter (l)));
2234 break;
2235 #endif
2236
2237 #if FFETARGET_okREAL2
2238 case FFEINFO_kindtypeREAL2:
2239 error = ffetarget_convert_complex2_real2
2240 (ffebld_cu_ptr_complex2 (u),
2241 ffebld_constant_real2 (ffebld_conter (l)));
2242 break;
2243 #endif
2244
2245 #if FFETARGET_okREAL3
2246 case FFEINFO_kindtypeREAL3:
2247 error = ffetarget_convert_complex2_real3
2248 (ffebld_cu_ptr_complex2 (u),
2249 ffebld_constant_real3 (ffebld_conter (l)));
2250 break;
2251 #endif
2252
2253 default:
2254 assert ("COMPLEX2/REAL bad source kind type" == NULL);
2255 break;
2256 }
2257 break;
2258
2259 case FFEINFO_basictypeCOMPLEX:
2260 switch (ffeinfo_kindtype (ffebld_info (l)))
2261 {
2262 #if FFETARGET_okCOMPLEX1
2263 case FFEINFO_kindtypeREAL1:
2264 error = ffetarget_convert_complex2_complex1
2265 (ffebld_cu_ptr_complex2 (u),
2266 ffebld_constant_complex1 (ffebld_conter (l)));
2267 break;
2268 #endif
2269
2270 #if FFETARGET_okCOMPLEX3
2271 case FFEINFO_kindtypeREAL3:
2272 error = ffetarget_convert_complex2_complex3
2273 (ffebld_cu_ptr_complex2 (u),
2274 ffebld_constant_complex3 (ffebld_conter (l)));
2275 break;
2276 #endif
2277
2278 default:
2279 assert ("COMPLEX2/COMPLEX bad source kind type" == NULL);
2280 break;
2281 }
2282 break;
2283
2284 case FFEINFO_basictypeCHARACTER:
2285 error = ffetarget_convert_complex2_character1
2286 (ffebld_cu_ptr_complex2 (u),
2287 ffebld_constant_character1 (ffebld_conter (l)));
2288 break;
2289
2290 case FFEINFO_basictypeHOLLERITH:
2291 error = ffetarget_convert_complex2_hollerith
2292 (ffebld_cu_ptr_complex2 (u),
2293 ffebld_constant_hollerith (ffebld_conter (l)));
2294 break;
2295
2296 case FFEINFO_basictypeTYPELESS:
2297 error = ffetarget_convert_complex2_typeless
2298 (ffebld_cu_ptr_complex2 (u),
2299 ffebld_constant_typeless (ffebld_conter (l)));
2300 break;
2301
2302 default:
2303 assert ("COMPLEX2 bad type" == NULL);
2304 break;
2305 }
2306
2307 /* If conversion operation is not implemented, return original expr. */
2308 if (error == FFEBAD_NOCANDO)
2309 return expr;
2310
2311 expr = ffebld_new_conter_with_orig
2312 (ffebld_constant_new_complex2_val
2313 (ffebld_cu_val_complex2 (u)), expr);
2314 break;
2315 #endif
2316
2317 #if FFETARGET_okCOMPLEX3
2318 case FFEINFO_kindtypeREAL3:
2319 switch (ffeinfo_basictype (ffebld_info (l)))
2320 {
2321 case FFEINFO_basictypeINTEGER:
2322 switch (ffeinfo_kindtype (ffebld_info (l)))
2323 {
2324 #if FFETARGET_okINTEGER1
2325 case FFEINFO_kindtypeINTEGER1:
2326 error = ffetarget_convert_complex3_integer1
2327 (ffebld_cu_ptr_complex3 (u),
2328 ffebld_constant_integer1 (ffebld_conter (l)));
2329 break;
2330 #endif
2331
2332 #if FFETARGET_okINTEGER2
2333 case FFEINFO_kindtypeINTEGER2:
2334 error = ffetarget_convert_complex3_integer2
2335 (ffebld_cu_ptr_complex3 (u),
2336 ffebld_constant_integer2 (ffebld_conter (l)));
2337 break;
2338 #endif
2339
2340 #if FFETARGET_okINTEGER3
2341 case FFEINFO_kindtypeINTEGER3:
2342 error = ffetarget_convert_complex3_integer3
2343 (ffebld_cu_ptr_complex3 (u),
2344 ffebld_constant_integer3 (ffebld_conter (l)));
2345 break;
2346 #endif
2347
2348 #if FFETARGET_okINTEGER4
2349 case FFEINFO_kindtypeINTEGER4:
2350 error = ffetarget_convert_complex3_integer4
2351 (ffebld_cu_ptr_complex3 (u),
2352 ffebld_constant_integer4 (ffebld_conter (l)));
2353 break;
2354 #endif
2355
2356 default:
2357 assert ("COMPLEX3/INTEGER bad source kind type" == NULL);
2358 break;
2359 }
2360 break;
2361
2362 case FFEINFO_basictypeREAL:
2363 switch (ffeinfo_kindtype (ffebld_info (l)))
2364 {
2365 #if FFETARGET_okREAL1
2366 case FFEINFO_kindtypeREAL1:
2367 error = ffetarget_convert_complex3_real1
2368 (ffebld_cu_ptr_complex3 (u),
2369 ffebld_constant_real1 (ffebld_conter (l)));
2370 break;
2371 #endif
2372
2373 #if FFETARGET_okREAL2
2374 case FFEINFO_kindtypeREAL2:
2375 error = ffetarget_convert_complex3_real2
2376 (ffebld_cu_ptr_complex3 (u),
2377 ffebld_constant_real2 (ffebld_conter (l)));
2378 break;
2379 #endif
2380
2381 #if FFETARGET_okREAL3
2382 case FFEINFO_kindtypeREAL3:
2383 error = ffetarget_convert_complex3_real3
2384 (ffebld_cu_ptr_complex3 (u),
2385 ffebld_constant_real3 (ffebld_conter (l)));
2386 break;
2387 #endif
2388
2389 default:
2390 assert ("COMPLEX3/REAL bad source kind type" == NULL);
2391 break;
2392 }
2393 break;
2394
2395 case FFEINFO_basictypeCOMPLEX:
2396 switch (ffeinfo_kindtype (ffebld_info (l)))
2397 {
2398 #if FFETARGET_okCOMPLEX1
2399 case FFEINFO_kindtypeREAL1:
2400 error = ffetarget_convert_complex3_complex1
2401 (ffebld_cu_ptr_complex3 (u),
2402 ffebld_constant_complex1 (ffebld_conter (l)));
2403 break;
2404 #endif
2405
2406 #if FFETARGET_okCOMPLEX2
2407 case FFEINFO_kindtypeREAL2:
2408 error = ffetarget_convert_complex3_complex2
2409 (ffebld_cu_ptr_complex3 (u),
2410 ffebld_constant_complex2 (ffebld_conter (l)));
2411 break;
2412 #endif
2413
2414 default:
2415 assert ("COMPLEX3/COMPLEX bad source kind type" == NULL);
2416 break;
2417 }
2418 break;
2419
2420 case FFEINFO_basictypeCHARACTER:
2421 error = ffetarget_convert_complex3_character1
2422 (ffebld_cu_ptr_complex3 (u),
2423 ffebld_constant_character1 (ffebld_conter (l)));
2424 break;
2425
2426 case FFEINFO_basictypeHOLLERITH:
2427 error = ffetarget_convert_complex3_hollerith
2428 (ffebld_cu_ptr_complex3 (u),
2429 ffebld_constant_hollerith (ffebld_conter (l)));
2430 break;
2431
2432 case FFEINFO_basictypeTYPELESS:
2433 error = ffetarget_convert_complex3_typeless
2434 (ffebld_cu_ptr_complex3 (u),
2435 ffebld_constant_typeless (ffebld_conter (l)));
2436 break;
2437
2438 default:
2439 assert ("COMPLEX3 bad type" == NULL);
2440 break;
2441 }
2442
2443 /* If conversion operation is not implemented, return original expr. */
2444 if (error == FFEBAD_NOCANDO)
2445 return expr;
2446
2447 expr = ffebld_new_conter_with_orig
2448 (ffebld_constant_new_complex3_val
2449 (ffebld_cu_val_complex3 (u)), expr);
2450 break;
2451 #endif
2452
2453 default:
2454 assert ("bad complex kind type" == NULL);
2455 break;
2456 }
2457 break;
2458
2459 case FFEINFO_basictypeCHARACTER:
2460 if ((sz = ffebld_size (expr)) == FFETARGET_charactersizeNONE)
2461 return expr;
2462 kt = ffeinfo_kindtype (ffebld_info (expr));
2463 switch (kt)
2464 {
2465 #if FFETARGET_okCHARACTER1
2466 case FFEINFO_kindtypeCHARACTER1:
2467 switch (ffeinfo_basictype (ffebld_info (l)))
2468 {
2469 case FFEINFO_basictypeCHARACTER:
2470 if ((sz2 = ffebld_size (l)) == FFETARGET_charactersizeNONE)
2471 return expr;
2472 assert (kt == ffeinfo_kindtype (ffebld_info (l)));
2473 assert (sz2 == ffetarget_length_character1
2474 (ffebld_constant_character1
2475 (ffebld_conter (l))));
2476 error
2477 = ffetarget_convert_character1_character1
2478 (ffebld_cu_ptr_character1 (u), sz,
2479 ffebld_constant_character1 (ffebld_conter (l)),
2480 ffebld_constant_pool ());
2481 break;
2482
2483 case FFEINFO_basictypeINTEGER:
2484 switch (ffeinfo_kindtype (ffebld_info (l)))
2485 {
2486 #if FFETARGET_okINTEGER1
2487 case FFEINFO_kindtypeINTEGER1:
2488 error
2489 = ffetarget_convert_character1_integer1
2490 (ffebld_cu_ptr_character1 (u),
2491 sz,
2492 ffebld_constant_integer1 (ffebld_conter (l)),
2493 ffebld_constant_pool ());
2494 break;
2495 #endif
2496
2497 #if FFETARGET_okINTEGER2
2498 case FFEINFO_kindtypeINTEGER2:
2499 error
2500 = ffetarget_convert_character1_integer2
2501 (ffebld_cu_ptr_character1 (u),
2502 sz,
2503 ffebld_constant_integer2 (ffebld_conter (l)),
2504 ffebld_constant_pool ());
2505 break;
2506 #endif
2507
2508 #if FFETARGET_okINTEGER3
2509 case FFEINFO_kindtypeINTEGER3:
2510 error
2511 = ffetarget_convert_character1_integer3
2512 (ffebld_cu_ptr_character1 (u),
2513 sz,
2514 ffebld_constant_integer3 (ffebld_conter (l)),
2515 ffebld_constant_pool ());
2516 break;
2517 #endif
2518
2519 #if FFETARGET_okINTEGER4
2520 case FFEINFO_kindtypeINTEGER4:
2521 error
2522 = ffetarget_convert_character1_integer4
2523 (ffebld_cu_ptr_character1 (u),
2524 sz,
2525 ffebld_constant_integer4 (ffebld_conter (l)),
2526 ffebld_constant_pool ());
2527 break;
2528 #endif
2529
2530 default:
2531 assert ("CHARACTER1/INTEGER bad source kind type" == NULL);
2532 break;
2533 }
2534 break;
2535
2536 case FFEINFO_basictypeLOGICAL:
2537 switch (ffeinfo_kindtype (ffebld_info (l)))
2538 {
2539 #if FFETARGET_okLOGICAL1
2540 case FFEINFO_kindtypeLOGICAL1:
2541 error
2542 = ffetarget_convert_character1_logical1
2543 (ffebld_cu_ptr_character1 (u),
2544 sz,
2545 ffebld_constant_logical1 (ffebld_conter (l)),
2546 ffebld_constant_pool ());
2547 break;
2548 #endif
2549
2550 #if FFETARGET_okLOGICAL2
2551 case FFEINFO_kindtypeLOGICAL2:
2552 error
2553 = ffetarget_convert_character1_logical2
2554 (ffebld_cu_ptr_character1 (u),
2555 sz,
2556 ffebld_constant_logical2 (ffebld_conter (l)),
2557 ffebld_constant_pool ());
2558 break;
2559 #endif
2560
2561 #if FFETARGET_okLOGICAL3
2562 case FFEINFO_kindtypeLOGICAL3:
2563 error
2564 = ffetarget_convert_character1_logical3
2565 (ffebld_cu_ptr_character1 (u),
2566 sz,
2567 ffebld_constant_logical3 (ffebld_conter (l)),
2568 ffebld_constant_pool ());
2569 break;
2570 #endif
2571
2572 #if FFETARGET_okLOGICAL4
2573 case FFEINFO_kindtypeLOGICAL4:
2574 error
2575 = ffetarget_convert_character1_logical4
2576 (ffebld_cu_ptr_character1 (u),
2577 sz,
2578 ffebld_constant_logical4 (ffebld_conter (l)),
2579 ffebld_constant_pool ());
2580 break;
2581 #endif
2582
2583 default:
2584 assert ("CHARACTER1/LOGICAL bad source kind type" == NULL);
2585 break;
2586 }
2587 break;
2588
2589 case FFEINFO_basictypeHOLLERITH:
2590 error
2591 = ffetarget_convert_character1_hollerith
2592 (ffebld_cu_ptr_character1 (u),
2593 sz,
2594 ffebld_constant_hollerith (ffebld_conter (l)),
2595 ffebld_constant_pool ());
2596 break;
2597
2598 case FFEINFO_basictypeTYPELESS:
2599 error
2600 = ffetarget_convert_character1_typeless
2601 (ffebld_cu_ptr_character1 (u),
2602 sz,
2603 ffebld_constant_typeless (ffebld_conter (l)),
2604 ffebld_constant_pool ());
2605 break;
2606
2607 default:
2608 assert ("CHARACTER1 bad type" == NULL);
2609 }
2610
2611 expr
2612 = ffebld_new_conter_with_orig
2613 (ffebld_constant_new_character1_val
2614 (ffebld_cu_val_character1 (u)),
2615 expr);
2616 break;
2617 #endif
2618
2619 default:
2620 assert ("bad character kind type" == NULL);
2621 break;
2622 }
2623 break;
2624
2625 default:
2626 assert ("bad type" == NULL);
2627 return expr;
2628 }
2629
2630 ffebld_set_info (expr, ffeinfo_new
2631 (bt,
2632 kt,
2633 0,
2634 FFEINFO_kindENTITY,
2635 FFEINFO_whereCONSTANT,
2636 sz));
2637
2638 if ((error != FFEBAD)
2639 && ffebad_start (error))
2640 {
2641 assert (t != NULL);
2642 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
2643 ffebad_finish ();
2644 }
2645
2646 return expr;
2647 }
2648
2649 /* ffeexpr_collapse_paren -- Collapse paren expr
2650
2651 ffebld expr;
2652 ffelexToken token;
2653 expr = ffeexpr_collapse_paren(expr,token);
2654
2655 If the result of the expr is a constant, replaces the expr with the
2656 computed constant. */
2657
2658 ffebld
2659 ffeexpr_collapse_paren (ffebld expr, ffelexToken t UNUSED)
2660 {
2661 ffebld r;
2662 ffeinfoBasictype bt;
2663 ffeinfoKindtype kt;
2664 ffetargetCharacterSize len;
2665
2666 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
2667 return expr;
2668
2669 r = ffebld_left (expr);
2670
2671 if (ffebld_op (r) != FFEBLD_opCONTER)
2672 return expr;
2673
2674 bt = ffeinfo_basictype (ffebld_info (r));
2675 kt = ffeinfo_kindtype (ffebld_info (r));
2676 len = ffebld_size (r);
2677
2678 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
2679 expr);
2680
2681 ffebld_set_info (expr, ffeinfo_new
2682 (bt,
2683 kt,
2684 0,
2685 FFEINFO_kindENTITY,
2686 FFEINFO_whereCONSTANT,
2687 len));
2688
2689 return expr;
2690 }
2691
2692 /* ffeexpr_collapse_uplus -- Collapse uplus expr
2693
2694 ffebld expr;
2695 ffelexToken token;
2696 expr = ffeexpr_collapse_uplus(expr,token);
2697
2698 If the result of the expr is a constant, replaces the expr with the
2699 computed constant. */
2700
2701 ffebld
2702 ffeexpr_collapse_uplus (ffebld expr, ffelexToken t UNUSED)
2703 {
2704 ffebld r;
2705 ffeinfoBasictype bt;
2706 ffeinfoKindtype kt;
2707 ffetargetCharacterSize len;
2708
2709 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
2710 return expr;
2711
2712 r = ffebld_left (expr);
2713
2714 if (ffebld_op (r) != FFEBLD_opCONTER)
2715 return expr;
2716
2717 bt = ffeinfo_basictype (ffebld_info (r));
2718 kt = ffeinfo_kindtype (ffebld_info (r));
2719 len = ffebld_size (r);
2720
2721 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
2722 expr);
2723
2724 ffebld_set_info (expr, ffeinfo_new
2725 (bt,
2726 kt,
2727 0,
2728 FFEINFO_kindENTITY,
2729 FFEINFO_whereCONSTANT,
2730 len));
2731
2732 return expr;
2733 }
2734
2735 /* ffeexpr_collapse_uminus -- Collapse uminus expr
2736
2737 ffebld expr;
2738 ffelexToken token;
2739 expr = ffeexpr_collapse_uminus(expr,token);
2740
2741 If the result of the expr is a constant, replaces the expr with the
2742 computed constant. */
2743
2744 ffebld
2745 ffeexpr_collapse_uminus (ffebld expr, ffelexToken t)
2746 {
2747 ffebad error = FFEBAD;
2748 ffebld r;
2749 ffebldConstantUnion u;
2750 ffeinfoBasictype bt;
2751 ffeinfoKindtype kt;
2752
2753 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
2754 return expr;
2755
2756 r = ffebld_left (expr);
2757
2758 if (ffebld_op (r) != FFEBLD_opCONTER)
2759 return expr;
2760
2761 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
2762 {
2763 case FFEINFO_basictypeANY:
2764 return expr;
2765
2766 case FFEINFO_basictypeINTEGER:
2767 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2768 {
2769 #if FFETARGET_okINTEGER1
2770 case FFEINFO_kindtypeINTEGER1:
2771 error = ffetarget_uminus_integer1 (ffebld_cu_ptr_integer1 (u),
2772 ffebld_constant_integer1 (ffebld_conter (r)));
2773 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
2774 (ffebld_cu_val_integer1 (u)), expr);
2775 break;
2776 #endif
2777
2778 #if FFETARGET_okINTEGER2
2779 case FFEINFO_kindtypeINTEGER2:
2780 error = ffetarget_uminus_integer2 (ffebld_cu_ptr_integer2 (u),
2781 ffebld_constant_integer2 (ffebld_conter (r)));
2782 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
2783 (ffebld_cu_val_integer2 (u)), expr);
2784 break;
2785 #endif
2786
2787 #if FFETARGET_okINTEGER3
2788 case FFEINFO_kindtypeINTEGER3:
2789 error = ffetarget_uminus_integer3 (ffebld_cu_ptr_integer3 (u),
2790 ffebld_constant_integer3 (ffebld_conter (r)));
2791 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
2792 (ffebld_cu_val_integer3 (u)), expr);
2793 break;
2794 #endif
2795
2796 #if FFETARGET_okINTEGER4
2797 case FFEINFO_kindtypeINTEGER4:
2798 error = ffetarget_uminus_integer4 (ffebld_cu_ptr_integer4 (u),
2799 ffebld_constant_integer4 (ffebld_conter (r)));
2800 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
2801 (ffebld_cu_val_integer4 (u)), expr);
2802 break;
2803 #endif
2804
2805 default:
2806 assert ("bad integer kind type" == NULL);
2807 break;
2808 }
2809 break;
2810
2811 case FFEINFO_basictypeREAL:
2812 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2813 {
2814 #if FFETARGET_okREAL1
2815 case FFEINFO_kindtypeREAL1:
2816 error = ffetarget_uminus_real1 (ffebld_cu_ptr_real1 (u),
2817 ffebld_constant_real1 (ffebld_conter (r)));
2818 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
2819 (ffebld_cu_val_real1 (u)), expr);
2820 break;
2821 #endif
2822
2823 #if FFETARGET_okREAL2
2824 case FFEINFO_kindtypeREAL2:
2825 error = ffetarget_uminus_real2 (ffebld_cu_ptr_real2 (u),
2826 ffebld_constant_real2 (ffebld_conter (r)));
2827 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
2828 (ffebld_cu_val_real2 (u)), expr);
2829 break;
2830 #endif
2831
2832 #if FFETARGET_okREAL3
2833 case FFEINFO_kindtypeREAL3:
2834 error = ffetarget_uminus_real3 (ffebld_cu_ptr_real3 (u),
2835 ffebld_constant_real3 (ffebld_conter (r)));
2836 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
2837 (ffebld_cu_val_real3 (u)), expr);
2838 break;
2839 #endif
2840
2841 default:
2842 assert ("bad real kind type" == NULL);
2843 break;
2844 }
2845 break;
2846
2847 case FFEINFO_basictypeCOMPLEX:
2848 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2849 {
2850 #if FFETARGET_okCOMPLEX1
2851 case FFEINFO_kindtypeREAL1:
2852 error = ffetarget_uminus_complex1 (ffebld_cu_ptr_complex1 (u),
2853 ffebld_constant_complex1 (ffebld_conter (r)));
2854 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
2855 (ffebld_cu_val_complex1 (u)), expr);
2856 break;
2857 #endif
2858
2859 #if FFETARGET_okCOMPLEX2
2860 case FFEINFO_kindtypeREAL2:
2861 error = ffetarget_uminus_complex2 (ffebld_cu_ptr_complex2 (u),
2862 ffebld_constant_complex2 (ffebld_conter (r)));
2863 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
2864 (ffebld_cu_val_complex2 (u)), expr);
2865 break;
2866 #endif
2867
2868 #if FFETARGET_okCOMPLEX3
2869 case FFEINFO_kindtypeREAL3:
2870 error = ffetarget_uminus_complex3 (ffebld_cu_ptr_complex3 (u),
2871 ffebld_constant_complex3 (ffebld_conter (r)));
2872 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
2873 (ffebld_cu_val_complex3 (u)), expr);
2874 break;
2875 #endif
2876
2877 default:
2878 assert ("bad complex kind type" == NULL);
2879 break;
2880 }
2881 break;
2882
2883 default:
2884 assert ("bad type" == NULL);
2885 return expr;
2886 }
2887
2888 ffebld_set_info (expr, ffeinfo_new
2889 (bt,
2890 kt,
2891 0,
2892 FFEINFO_kindENTITY,
2893 FFEINFO_whereCONSTANT,
2894 FFETARGET_charactersizeNONE));
2895
2896 if ((error != FFEBAD)
2897 && ffebad_start (error))
2898 {
2899 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
2900 ffebad_finish ();
2901 }
2902
2903 return expr;
2904 }
2905
2906 /* ffeexpr_collapse_not -- Collapse not expr
2907
2908 ffebld expr;
2909 ffelexToken token;
2910 expr = ffeexpr_collapse_not(expr,token);
2911
2912 If the result of the expr is a constant, replaces the expr with the
2913 computed constant. */
2914
2915 ffebld
2916 ffeexpr_collapse_not (ffebld expr, ffelexToken t)
2917 {
2918 ffebad error = FFEBAD;
2919 ffebld r;
2920 ffebldConstantUnion u;
2921 ffeinfoBasictype bt;
2922 ffeinfoKindtype kt;
2923
2924 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
2925 return expr;
2926
2927 r = ffebld_left (expr);
2928
2929 if (ffebld_op (r) != FFEBLD_opCONTER)
2930 return expr;
2931
2932 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
2933 {
2934 case FFEINFO_basictypeANY:
2935 return expr;
2936
2937 case FFEINFO_basictypeINTEGER:
2938 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2939 {
2940 #if FFETARGET_okINTEGER1
2941 case FFEINFO_kindtypeINTEGER1:
2942 error = ffetarget_not_integer1 (ffebld_cu_ptr_integer1 (u),
2943 ffebld_constant_integer1 (ffebld_conter (r)));
2944 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
2945 (ffebld_cu_val_integer1 (u)), expr);
2946 break;
2947 #endif
2948
2949 #if FFETARGET_okINTEGER2
2950 case FFEINFO_kindtypeINTEGER2:
2951 error = ffetarget_not_integer2 (ffebld_cu_ptr_integer2 (u),
2952 ffebld_constant_integer2 (ffebld_conter (r)));
2953 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
2954 (ffebld_cu_val_integer2 (u)), expr);
2955 break;
2956 #endif
2957
2958 #if FFETARGET_okINTEGER3
2959 case FFEINFO_kindtypeINTEGER3:
2960 error = ffetarget_not_integer3 (ffebld_cu_ptr_integer3 (u),
2961 ffebld_constant_integer3 (ffebld_conter (r)));
2962 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
2963 (ffebld_cu_val_integer3 (u)), expr);
2964 break;
2965 #endif
2966
2967 #if FFETARGET_okINTEGER4
2968 case FFEINFO_kindtypeINTEGER4:
2969 error = ffetarget_not_integer4 (ffebld_cu_ptr_integer4 (u),
2970 ffebld_constant_integer4 (ffebld_conter (r)));
2971 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
2972 (ffebld_cu_val_integer4 (u)), expr);
2973 break;
2974 #endif
2975
2976 default:
2977 assert ("bad integer kind type" == NULL);
2978 break;
2979 }
2980 break;
2981
2982 case FFEINFO_basictypeLOGICAL:
2983 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2984 {
2985 #if FFETARGET_okLOGICAL1
2986 case FFEINFO_kindtypeLOGICAL1:
2987 error = ffetarget_not_logical1 (ffebld_cu_ptr_logical1 (u),
2988 ffebld_constant_logical1 (ffebld_conter (r)));
2989 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
2990 (ffebld_cu_val_logical1 (u)), expr);
2991 break;
2992 #endif
2993
2994 #if FFETARGET_okLOGICAL2
2995 case FFEINFO_kindtypeLOGICAL2:
2996 error = ffetarget_not_logical2 (ffebld_cu_ptr_logical2 (u),
2997 ffebld_constant_logical2 (ffebld_conter (r)));
2998 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
2999 (ffebld_cu_val_logical2 (u)), expr);
3000 break;
3001 #endif
3002
3003 #if FFETARGET_okLOGICAL3
3004 case FFEINFO_kindtypeLOGICAL3:
3005 error = ffetarget_not_logical3 (ffebld_cu_ptr_logical3 (u),
3006 ffebld_constant_logical3 (ffebld_conter (r)));
3007 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
3008 (ffebld_cu_val_logical3 (u)), expr);
3009 break;
3010 #endif
3011
3012 #if FFETARGET_okLOGICAL4
3013 case FFEINFO_kindtypeLOGICAL4:
3014 error = ffetarget_not_logical4 (ffebld_cu_ptr_logical4 (u),
3015 ffebld_constant_logical4 (ffebld_conter (r)));
3016 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
3017 (ffebld_cu_val_logical4 (u)), expr);
3018 break;
3019 #endif
3020
3021 default:
3022 assert ("bad logical kind type" == NULL);
3023 break;
3024 }
3025 break;
3026
3027 default:
3028 assert ("bad type" == NULL);
3029 return expr;
3030 }
3031
3032 ffebld_set_info (expr, ffeinfo_new
3033 (bt,
3034 kt,
3035 0,
3036 FFEINFO_kindENTITY,
3037 FFEINFO_whereCONSTANT,
3038 FFETARGET_charactersizeNONE));
3039
3040 if ((error != FFEBAD)
3041 && ffebad_start (error))
3042 {
3043 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3044 ffebad_finish ();
3045 }
3046
3047 return expr;
3048 }
3049
3050 /* ffeexpr_collapse_add -- Collapse add expr
3051
3052 ffebld expr;
3053 ffelexToken token;
3054 expr = ffeexpr_collapse_add(expr,token);
3055
3056 If the result of the expr is a constant, replaces the expr with the
3057 computed constant. */
3058
3059 ffebld
3060 ffeexpr_collapse_add (ffebld expr, ffelexToken t)
3061 {
3062 ffebad error = FFEBAD;
3063 ffebld l;
3064 ffebld r;
3065 ffebldConstantUnion u;
3066 ffeinfoBasictype bt;
3067 ffeinfoKindtype kt;
3068
3069 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3070 return expr;
3071
3072 l = ffebld_left (expr);
3073 r = ffebld_right (expr);
3074
3075 if (ffebld_op (l) != FFEBLD_opCONTER)
3076 return expr;
3077 if (ffebld_op (r) != FFEBLD_opCONTER)
3078 return expr;
3079
3080 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3081 {
3082 case FFEINFO_basictypeANY:
3083 return expr;
3084
3085 case FFEINFO_basictypeINTEGER:
3086 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3087 {
3088 #if FFETARGET_okINTEGER1
3089 case FFEINFO_kindtypeINTEGER1:
3090 error = ffetarget_add_integer1 (ffebld_cu_ptr_integer1 (u),
3091 ffebld_constant_integer1 (ffebld_conter (l)),
3092 ffebld_constant_integer1 (ffebld_conter (r)));
3093 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3094 (ffebld_cu_val_integer1 (u)), expr);
3095 break;
3096 #endif
3097
3098 #if FFETARGET_okINTEGER2
3099 case FFEINFO_kindtypeINTEGER2:
3100 error = ffetarget_add_integer2 (ffebld_cu_ptr_integer2 (u),
3101 ffebld_constant_integer2 (ffebld_conter (l)),
3102 ffebld_constant_integer2 (ffebld_conter (r)));
3103 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3104 (ffebld_cu_val_integer2 (u)), expr);
3105 break;
3106 #endif
3107
3108 #if FFETARGET_okINTEGER3
3109 case FFEINFO_kindtypeINTEGER3:
3110 error = ffetarget_add_integer3 (ffebld_cu_ptr_integer3 (u),
3111 ffebld_constant_integer3 (ffebld_conter (l)),
3112 ffebld_constant_integer3 (ffebld_conter (r)));
3113 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3114 (ffebld_cu_val_integer3 (u)), expr);
3115 break;
3116 #endif
3117
3118 #if FFETARGET_okINTEGER4
3119 case FFEINFO_kindtypeINTEGER4:
3120 error = ffetarget_add_integer4 (ffebld_cu_ptr_integer4 (u),
3121 ffebld_constant_integer4 (ffebld_conter (l)),
3122 ffebld_constant_integer4 (ffebld_conter (r)));
3123 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3124 (ffebld_cu_val_integer4 (u)), expr);
3125 break;
3126 #endif
3127
3128 default:
3129 assert ("bad integer kind type" == NULL);
3130 break;
3131 }
3132 break;
3133
3134 case FFEINFO_basictypeREAL:
3135 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3136 {
3137 #if FFETARGET_okREAL1
3138 case FFEINFO_kindtypeREAL1:
3139 error = ffetarget_add_real1 (ffebld_cu_ptr_real1 (u),
3140 ffebld_constant_real1 (ffebld_conter (l)),
3141 ffebld_constant_real1 (ffebld_conter (r)));
3142 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3143 (ffebld_cu_val_real1 (u)), expr);
3144 break;
3145 #endif
3146
3147 #if FFETARGET_okREAL2
3148 case FFEINFO_kindtypeREAL2:
3149 error = ffetarget_add_real2 (ffebld_cu_ptr_real2 (u),
3150 ffebld_constant_real2 (ffebld_conter (l)),
3151 ffebld_constant_real2 (ffebld_conter (r)));
3152 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3153 (ffebld_cu_val_real2 (u)), expr);
3154 break;
3155 #endif
3156
3157 #if FFETARGET_okREAL3
3158 case FFEINFO_kindtypeREAL3:
3159 error = ffetarget_add_real3 (ffebld_cu_ptr_real3 (u),
3160 ffebld_constant_real3 (ffebld_conter (l)),
3161 ffebld_constant_real3 (ffebld_conter (r)));
3162 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3163 (ffebld_cu_val_real3 (u)), expr);
3164 break;
3165 #endif
3166
3167 default:
3168 assert ("bad real kind type" == NULL);
3169 break;
3170 }
3171 break;
3172
3173 case FFEINFO_basictypeCOMPLEX:
3174 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3175 {
3176 #if FFETARGET_okCOMPLEX1
3177 case FFEINFO_kindtypeREAL1:
3178 error = ffetarget_add_complex1 (ffebld_cu_ptr_complex1 (u),
3179 ffebld_constant_complex1 (ffebld_conter (l)),
3180 ffebld_constant_complex1 (ffebld_conter (r)));
3181 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3182 (ffebld_cu_val_complex1 (u)), expr);
3183 break;
3184 #endif
3185
3186 #if FFETARGET_okCOMPLEX2
3187 case FFEINFO_kindtypeREAL2:
3188 error = ffetarget_add_complex2 (ffebld_cu_ptr_complex2 (u),
3189 ffebld_constant_complex2 (ffebld_conter (l)),
3190 ffebld_constant_complex2 (ffebld_conter (r)));
3191 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3192 (ffebld_cu_val_complex2 (u)), expr);
3193 break;
3194 #endif
3195
3196 #if FFETARGET_okCOMPLEX3
3197 case FFEINFO_kindtypeREAL3:
3198 error = ffetarget_add_complex3 (ffebld_cu_ptr_complex3 (u),
3199 ffebld_constant_complex3 (ffebld_conter (l)),
3200 ffebld_constant_complex3 (ffebld_conter (r)));
3201 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3202 (ffebld_cu_val_complex3 (u)), expr);
3203 break;
3204 #endif
3205
3206 default:
3207 assert ("bad complex kind type" == NULL);
3208 break;
3209 }
3210 break;
3211
3212 default:
3213 assert ("bad type" == NULL);
3214 return expr;
3215 }
3216
3217 ffebld_set_info (expr, ffeinfo_new
3218 (bt,
3219 kt,
3220 0,
3221 FFEINFO_kindENTITY,
3222 FFEINFO_whereCONSTANT,
3223 FFETARGET_charactersizeNONE));
3224
3225 if ((error != FFEBAD)
3226 && ffebad_start (error))
3227 {
3228 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3229 ffebad_finish ();
3230 }
3231
3232 return expr;
3233 }
3234
3235 /* ffeexpr_collapse_subtract -- Collapse subtract expr
3236
3237 ffebld expr;
3238 ffelexToken token;
3239 expr = ffeexpr_collapse_subtract(expr,token);
3240
3241 If the result of the expr is a constant, replaces the expr with the
3242 computed constant. */
3243
3244 ffebld
3245 ffeexpr_collapse_subtract (ffebld expr, ffelexToken t)
3246 {
3247 ffebad error = FFEBAD;
3248 ffebld l;
3249 ffebld r;
3250 ffebldConstantUnion u;
3251 ffeinfoBasictype bt;
3252 ffeinfoKindtype kt;
3253
3254 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3255 return expr;
3256
3257 l = ffebld_left (expr);
3258 r = ffebld_right (expr);
3259
3260 if (ffebld_op (l) != FFEBLD_opCONTER)
3261 return expr;
3262 if (ffebld_op (r) != FFEBLD_opCONTER)
3263 return expr;
3264
3265 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3266 {
3267 case FFEINFO_basictypeANY:
3268 return expr;
3269
3270 case FFEINFO_basictypeINTEGER:
3271 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3272 {
3273 #if FFETARGET_okINTEGER1
3274 case FFEINFO_kindtypeINTEGER1:
3275 error = ffetarget_subtract_integer1 (ffebld_cu_ptr_integer1 (u),
3276 ffebld_constant_integer1 (ffebld_conter (l)),
3277 ffebld_constant_integer1 (ffebld_conter (r)));
3278 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3279 (ffebld_cu_val_integer1 (u)), expr);
3280 break;
3281 #endif
3282
3283 #if FFETARGET_okINTEGER2
3284 case FFEINFO_kindtypeINTEGER2:
3285 error = ffetarget_subtract_integer2 (ffebld_cu_ptr_integer2 (u),
3286 ffebld_constant_integer2 (ffebld_conter (l)),
3287 ffebld_constant_integer2 (ffebld_conter (r)));
3288 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3289 (ffebld_cu_val_integer2 (u)), expr);
3290 break;
3291 #endif
3292
3293 #if FFETARGET_okINTEGER3
3294 case FFEINFO_kindtypeINTEGER3:
3295 error = ffetarget_subtract_integer3 (ffebld_cu_ptr_integer3 (u),
3296 ffebld_constant_integer3 (ffebld_conter (l)),
3297 ffebld_constant_integer3 (ffebld_conter (r)));
3298 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3299 (ffebld_cu_val_integer3 (u)), expr);
3300 break;
3301 #endif
3302
3303 #if FFETARGET_okINTEGER4
3304 case FFEINFO_kindtypeINTEGER4:
3305 error = ffetarget_subtract_integer4 (ffebld_cu_ptr_integer4 (u),
3306 ffebld_constant_integer4 (ffebld_conter (l)),
3307 ffebld_constant_integer4 (ffebld_conter (r)));
3308 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3309 (ffebld_cu_val_integer4 (u)), expr);
3310 break;
3311 #endif
3312
3313 default:
3314 assert ("bad integer kind type" == NULL);
3315 break;
3316 }
3317 break;
3318
3319 case FFEINFO_basictypeREAL:
3320 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3321 {
3322 #if FFETARGET_okREAL1
3323 case FFEINFO_kindtypeREAL1:
3324 error = ffetarget_subtract_real1 (ffebld_cu_ptr_real1 (u),
3325 ffebld_constant_real1 (ffebld_conter (l)),
3326 ffebld_constant_real1 (ffebld_conter (r)));
3327 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3328 (ffebld_cu_val_real1 (u)), expr);
3329 break;
3330 #endif
3331
3332 #if FFETARGET_okREAL2
3333 case FFEINFO_kindtypeREAL2:
3334 error = ffetarget_subtract_real2 (ffebld_cu_ptr_real2 (u),
3335 ffebld_constant_real2 (ffebld_conter (l)),
3336 ffebld_constant_real2 (ffebld_conter (r)));
3337 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3338 (ffebld_cu_val_real2 (u)), expr);
3339 break;
3340 #endif
3341
3342 #if FFETARGET_okREAL3
3343 case FFEINFO_kindtypeREAL3:
3344 error = ffetarget_subtract_real3 (ffebld_cu_ptr_real3 (u),
3345 ffebld_constant_real3 (ffebld_conter (l)),
3346 ffebld_constant_real3 (ffebld_conter (r)));
3347 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3348 (ffebld_cu_val_real3 (u)), expr);
3349 break;
3350 #endif
3351
3352 default:
3353 assert ("bad real kind type" == NULL);
3354 break;
3355 }
3356 break;
3357
3358 case FFEINFO_basictypeCOMPLEX:
3359 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3360 {
3361 #if FFETARGET_okCOMPLEX1
3362 case FFEINFO_kindtypeREAL1:
3363 error = ffetarget_subtract_complex1 (ffebld_cu_ptr_complex1 (u),
3364 ffebld_constant_complex1 (ffebld_conter (l)),
3365 ffebld_constant_complex1 (ffebld_conter (r)));
3366 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3367 (ffebld_cu_val_complex1 (u)), expr);
3368 break;
3369 #endif
3370
3371 #if FFETARGET_okCOMPLEX2
3372 case FFEINFO_kindtypeREAL2:
3373 error = ffetarget_subtract_complex2 (ffebld_cu_ptr_complex2 (u),
3374 ffebld_constant_complex2 (ffebld_conter (l)),
3375 ffebld_constant_complex2 (ffebld_conter (r)));
3376 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3377 (ffebld_cu_val_complex2 (u)), expr);
3378 break;
3379 #endif
3380
3381 #if FFETARGET_okCOMPLEX3
3382 case FFEINFO_kindtypeREAL3:
3383 error = ffetarget_subtract_complex3 (ffebld_cu_ptr_complex3 (u),
3384 ffebld_constant_complex3 (ffebld_conter (l)),
3385 ffebld_constant_complex3 (ffebld_conter (r)));
3386 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3387 (ffebld_cu_val_complex3 (u)), expr);
3388 break;
3389 #endif
3390
3391 default:
3392 assert ("bad complex kind type" == NULL);
3393 break;
3394 }
3395 break;
3396
3397 default:
3398 assert ("bad type" == NULL);
3399 return expr;
3400 }
3401
3402 ffebld_set_info (expr, ffeinfo_new
3403 (bt,
3404 kt,
3405 0,
3406 FFEINFO_kindENTITY,
3407 FFEINFO_whereCONSTANT,
3408 FFETARGET_charactersizeNONE));
3409
3410 if ((error != FFEBAD)
3411 && ffebad_start (error))
3412 {
3413 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3414 ffebad_finish ();
3415 }
3416
3417 return expr;
3418 }
3419
3420 /* ffeexpr_collapse_multiply -- Collapse multiply expr
3421
3422 ffebld expr;
3423 ffelexToken token;
3424 expr = ffeexpr_collapse_multiply(expr,token);
3425
3426 If the result of the expr is a constant, replaces the expr with the
3427 computed constant. */
3428
3429 ffebld
3430 ffeexpr_collapse_multiply (ffebld expr, ffelexToken t)
3431 {
3432 ffebad error = FFEBAD;
3433 ffebld l;
3434 ffebld r;
3435 ffebldConstantUnion u;
3436 ffeinfoBasictype bt;
3437 ffeinfoKindtype kt;
3438
3439 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3440 return expr;
3441
3442 l = ffebld_left (expr);
3443 r = ffebld_right (expr);
3444
3445 if (ffebld_op (l) != FFEBLD_opCONTER)
3446 return expr;
3447 if (ffebld_op (r) != FFEBLD_opCONTER)
3448 return expr;
3449
3450 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3451 {
3452 case FFEINFO_basictypeANY:
3453 return expr;
3454
3455 case FFEINFO_basictypeINTEGER:
3456 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3457 {
3458 #if FFETARGET_okINTEGER1
3459 case FFEINFO_kindtypeINTEGER1:
3460 error = ffetarget_multiply_integer1 (ffebld_cu_ptr_integer1 (u),
3461 ffebld_constant_integer1 (ffebld_conter (l)),
3462 ffebld_constant_integer1 (ffebld_conter (r)));
3463 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3464 (ffebld_cu_val_integer1 (u)), expr);
3465 break;
3466 #endif
3467
3468 #if FFETARGET_okINTEGER2
3469 case FFEINFO_kindtypeINTEGER2:
3470 error = ffetarget_multiply_integer2 (ffebld_cu_ptr_integer2 (u),
3471 ffebld_constant_integer2 (ffebld_conter (l)),
3472 ffebld_constant_integer2 (ffebld_conter (r)));
3473 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3474 (ffebld_cu_val_integer2 (u)), expr);
3475 break;
3476 #endif
3477
3478 #if FFETARGET_okINTEGER3
3479 case FFEINFO_kindtypeINTEGER3:
3480 error = ffetarget_multiply_integer3 (ffebld_cu_ptr_integer3 (u),
3481 ffebld_constant_integer3 (ffebld_conter (l)),
3482 ffebld_constant_integer3 (ffebld_conter (r)));
3483 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3484 (ffebld_cu_val_integer3 (u)), expr);
3485 break;
3486 #endif
3487
3488 #if FFETARGET_okINTEGER4
3489 case FFEINFO_kindtypeINTEGER4:
3490 error = ffetarget_multiply_integer4 (ffebld_cu_ptr_integer4 (u),
3491 ffebld_constant_integer4 (ffebld_conter (l)),
3492 ffebld_constant_integer4 (ffebld_conter (r)));
3493 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3494 (ffebld_cu_val_integer4 (u)), expr);
3495 break;
3496 #endif
3497
3498 default:
3499 assert ("bad integer kind type" == NULL);
3500 break;
3501 }
3502 break;
3503
3504 case FFEINFO_basictypeREAL:
3505 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3506 {
3507 #if FFETARGET_okREAL1
3508 case FFEINFO_kindtypeREAL1:
3509 error = ffetarget_multiply_real1 (ffebld_cu_ptr_real1 (u),
3510 ffebld_constant_real1 (ffebld_conter (l)),
3511 ffebld_constant_real1 (ffebld_conter (r)));
3512 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3513 (ffebld_cu_val_real1 (u)), expr);
3514 break;
3515 #endif
3516
3517 #if FFETARGET_okREAL2
3518 case FFEINFO_kindtypeREAL2:
3519 error = ffetarget_multiply_real2 (ffebld_cu_ptr_real2 (u),
3520 ffebld_constant_real2 (ffebld_conter (l)),
3521 ffebld_constant_real2 (ffebld_conter (r)));
3522 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3523 (ffebld_cu_val_real2 (u)), expr);
3524 break;
3525 #endif
3526
3527 #if FFETARGET_okREAL3
3528 case FFEINFO_kindtypeREAL3:
3529 error = ffetarget_multiply_real3 (ffebld_cu_ptr_real3 (u),
3530 ffebld_constant_real3 (ffebld_conter (l)),
3531 ffebld_constant_real3 (ffebld_conter (r)));
3532 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3533 (ffebld_cu_val_real3 (u)), expr);
3534 break;
3535 #endif
3536
3537 default:
3538 assert ("bad real kind type" == NULL);
3539 break;
3540 }
3541 break;
3542
3543 case FFEINFO_basictypeCOMPLEX:
3544 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3545 {
3546 #if FFETARGET_okCOMPLEX1
3547 case FFEINFO_kindtypeREAL1:
3548 error = ffetarget_multiply_complex1 (ffebld_cu_ptr_complex1 (u),
3549 ffebld_constant_complex1 (ffebld_conter (l)),
3550 ffebld_constant_complex1 (ffebld_conter (r)));
3551 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3552 (ffebld_cu_val_complex1 (u)), expr);
3553 break;
3554 #endif
3555
3556 #if FFETARGET_okCOMPLEX2
3557 case FFEINFO_kindtypeREAL2:
3558 error = ffetarget_multiply_complex2 (ffebld_cu_ptr_complex2 (u),
3559 ffebld_constant_complex2 (ffebld_conter (l)),
3560 ffebld_constant_complex2 (ffebld_conter (r)));
3561 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3562 (ffebld_cu_val_complex2 (u)), expr);
3563 break;
3564 #endif
3565
3566 #if FFETARGET_okCOMPLEX3
3567 case FFEINFO_kindtypeREAL3:
3568 error = ffetarget_multiply_complex3 (ffebld_cu_ptr_complex3 (u),
3569 ffebld_constant_complex3 (ffebld_conter (l)),
3570 ffebld_constant_complex3 (ffebld_conter (r)));
3571 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3572 (ffebld_cu_val_complex3 (u)), expr);
3573 break;
3574 #endif
3575
3576 default:
3577 assert ("bad complex kind type" == NULL);
3578 break;
3579 }
3580 break;
3581
3582 default:
3583 assert ("bad type" == NULL);
3584 return expr;
3585 }
3586
3587 ffebld_set_info (expr, ffeinfo_new
3588 (bt,
3589 kt,
3590 0,
3591 FFEINFO_kindENTITY,
3592 FFEINFO_whereCONSTANT,
3593 FFETARGET_charactersizeNONE));
3594
3595 if ((error != FFEBAD)
3596 && ffebad_start (error))
3597 {
3598 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3599 ffebad_finish ();
3600 }
3601
3602 return expr;
3603 }
3604
3605 /* ffeexpr_collapse_divide -- Collapse divide expr
3606
3607 ffebld expr;
3608 ffelexToken token;
3609 expr = ffeexpr_collapse_divide(expr,token);
3610
3611 If the result of the expr is a constant, replaces the expr with the
3612 computed constant. */
3613
3614 ffebld
3615 ffeexpr_collapse_divide (ffebld expr, ffelexToken t)
3616 {
3617 ffebad error = FFEBAD;
3618 ffebld l;
3619 ffebld r;
3620 ffebldConstantUnion u;
3621 ffeinfoBasictype bt;
3622 ffeinfoKindtype kt;
3623
3624 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3625 return expr;
3626
3627 l = ffebld_left (expr);
3628 r = ffebld_right (expr);
3629
3630 if (ffebld_op (l) != FFEBLD_opCONTER)
3631 return expr;
3632 if (ffebld_op (r) != FFEBLD_opCONTER)
3633 return expr;
3634
3635 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3636 {
3637 case FFEINFO_basictypeANY:
3638 return expr;
3639
3640 case FFEINFO_basictypeINTEGER:
3641 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3642 {
3643 #if FFETARGET_okINTEGER1
3644 case FFEINFO_kindtypeINTEGER1:
3645 error = ffetarget_divide_integer1 (ffebld_cu_ptr_integer1 (u),
3646 ffebld_constant_integer1 (ffebld_conter (l)),
3647 ffebld_constant_integer1 (ffebld_conter (r)));
3648 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3649 (ffebld_cu_val_integer1 (u)), expr);
3650 break;
3651 #endif
3652
3653 #if FFETARGET_okINTEGER2
3654 case FFEINFO_kindtypeINTEGER2:
3655 error = ffetarget_divide_integer2 (ffebld_cu_ptr_integer2 (u),
3656 ffebld_constant_integer2 (ffebld_conter (l)),
3657 ffebld_constant_integer2 (ffebld_conter (r)));
3658 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3659 (ffebld_cu_val_integer2 (u)), expr);
3660 break;
3661 #endif
3662
3663 #if FFETARGET_okINTEGER3
3664 case FFEINFO_kindtypeINTEGER3:
3665 error = ffetarget_divide_integer3 (ffebld_cu_ptr_integer3 (u),
3666 ffebld_constant_integer3 (ffebld_conter (l)),
3667 ffebld_constant_integer3 (ffebld_conter (r)));
3668 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3669 (ffebld_cu_val_integer3 (u)), expr);
3670 break;
3671 #endif
3672
3673 #if FFETARGET_okINTEGER4
3674 case FFEINFO_kindtypeINTEGER4:
3675 error = ffetarget_divide_integer4 (ffebld_cu_ptr_integer4 (u),
3676 ffebld_constant_integer4 (ffebld_conter (l)),
3677 ffebld_constant_integer4 (ffebld_conter (r)));
3678 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3679 (ffebld_cu_val_integer4 (u)), expr);
3680 break;
3681 #endif
3682
3683 default:
3684 assert ("bad integer kind type" == NULL);
3685 break;
3686 }
3687 break;
3688
3689 case FFEINFO_basictypeREAL:
3690 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3691 {
3692 #if FFETARGET_okREAL1
3693 case FFEINFO_kindtypeREAL1:
3694 error = ffetarget_divide_real1 (ffebld_cu_ptr_real1 (u),
3695 ffebld_constant_real1 (ffebld_conter (l)),
3696 ffebld_constant_real1 (ffebld_conter (r)));
3697 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3698 (ffebld_cu_val_real1 (u)), expr);
3699 break;
3700 #endif
3701
3702 #if FFETARGET_okREAL2
3703 case FFEINFO_kindtypeREAL2:
3704 error = ffetarget_divide_real2 (ffebld_cu_ptr_real2 (u),
3705 ffebld_constant_real2 (ffebld_conter (l)),
3706 ffebld_constant_real2 (ffebld_conter (r)));
3707 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3708 (ffebld_cu_val_real2 (u)), expr);
3709 break;
3710 #endif
3711
3712 #if FFETARGET_okREAL3
3713 case FFEINFO_kindtypeREAL3:
3714 error = ffetarget_divide_real3 (ffebld_cu_ptr_real3 (u),
3715 ffebld_constant_real3 (ffebld_conter (l)),
3716 ffebld_constant_real3 (ffebld_conter (r)));
3717 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3718 (ffebld_cu_val_real3 (u)), expr);
3719 break;
3720 #endif
3721
3722 default:
3723 assert ("bad real kind type" == NULL);
3724 break;
3725 }
3726 break;
3727
3728 case FFEINFO_basictypeCOMPLEX:
3729 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3730 {
3731 #if FFETARGET_okCOMPLEX1
3732 case FFEINFO_kindtypeREAL1:
3733 error = ffetarget_divide_complex1 (ffebld_cu_ptr_complex1 (u),
3734 ffebld_constant_complex1 (ffebld_conter (l)),
3735 ffebld_constant_complex1 (ffebld_conter (r)));
3736 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3737 (ffebld_cu_val_complex1 (u)), expr);
3738 break;
3739 #endif
3740
3741 #if FFETARGET_okCOMPLEX2
3742 case FFEINFO_kindtypeREAL2:
3743 error = ffetarget_divide_complex2 (ffebld_cu_ptr_complex2 (u),
3744 ffebld_constant_complex2 (ffebld_conter (l)),
3745 ffebld_constant_complex2 (ffebld_conter (r)));
3746 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3747 (ffebld_cu_val_complex2 (u)), expr);
3748 break;
3749 #endif
3750
3751 #if FFETARGET_okCOMPLEX3
3752 case FFEINFO_kindtypeREAL3:
3753 error = ffetarget_divide_complex3 (ffebld_cu_ptr_complex3 (u),
3754 ffebld_constant_complex3 (ffebld_conter (l)),
3755 ffebld_constant_complex3 (ffebld_conter (r)));
3756 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3757 (ffebld_cu_val_complex3 (u)), expr);
3758 break;
3759 #endif
3760
3761 default:
3762 assert ("bad complex kind type" == NULL);
3763 break;
3764 }
3765 break;
3766
3767 default:
3768 assert ("bad type" == NULL);
3769 return expr;
3770 }
3771
3772 ffebld_set_info (expr, ffeinfo_new
3773 (bt,
3774 kt,
3775 0,
3776 FFEINFO_kindENTITY,
3777 FFEINFO_whereCONSTANT,
3778 FFETARGET_charactersizeNONE));
3779
3780 if ((error != FFEBAD)
3781 && ffebad_start (error))
3782 {
3783 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3784 ffebad_finish ();
3785 }
3786
3787 return expr;
3788 }
3789
3790 /* ffeexpr_collapse_power -- Collapse power expr
3791
3792 ffebld expr;
3793 ffelexToken token;
3794 expr = ffeexpr_collapse_power(expr,token);
3795
3796 If the result of the expr is a constant, replaces the expr with the
3797 computed constant. */
3798
3799 ffebld
3800 ffeexpr_collapse_power (ffebld expr, ffelexToken t)
3801 {
3802 ffebad error = FFEBAD;
3803 ffebld l;
3804 ffebld r;
3805 ffebldConstantUnion u;
3806 ffeinfoBasictype bt;
3807 ffeinfoKindtype kt;
3808
3809 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3810 return expr;
3811
3812 l = ffebld_left (expr);
3813 r = ffebld_right (expr);
3814
3815 if (ffebld_op (l) != FFEBLD_opCONTER)
3816 return expr;
3817 if (ffebld_op (r) != FFEBLD_opCONTER)
3818 return expr;
3819
3820 if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER)
3821 || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT))
3822 return expr;
3823
3824 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3825 {
3826 case FFEINFO_basictypeANY:
3827 return expr;
3828
3829 case FFEINFO_basictypeINTEGER:
3830 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3831 {
3832 case FFEINFO_kindtypeINTEGERDEFAULT:
3833 error = ffetarget_power_integerdefault_integerdefault
3834 (ffebld_cu_ptr_integerdefault (u),
3835 ffebld_constant_integerdefault (ffebld_conter (l)),
3836 ffebld_constant_integerdefault (ffebld_conter (r)));
3837 expr = ffebld_new_conter_with_orig
3838 (ffebld_constant_new_integerdefault_val
3839 (ffebld_cu_val_integerdefault (u)), expr);
3840 break;
3841
3842 default:
3843 assert ("bad integer kind type" == NULL);
3844 break;
3845 }
3846 break;
3847
3848 case FFEINFO_basictypeREAL:
3849 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3850 {
3851 case FFEINFO_kindtypeREALDEFAULT:
3852 error = ffetarget_power_realdefault_integerdefault
3853 (ffebld_cu_ptr_realdefault (u),
3854 ffebld_constant_realdefault (ffebld_conter (l)),
3855 ffebld_constant_integerdefault (ffebld_conter (r)));
3856 expr = ffebld_new_conter_with_orig
3857 (ffebld_constant_new_realdefault_val
3858 (ffebld_cu_val_realdefault (u)), expr);
3859 break;
3860
3861 case FFEINFO_kindtypeREALDOUBLE:
3862 error = ffetarget_power_realdouble_integerdefault
3863 (ffebld_cu_ptr_realdouble (u),
3864 ffebld_constant_realdouble (ffebld_conter (l)),
3865 ffebld_constant_integerdefault (ffebld_conter (r)));
3866 expr = ffebld_new_conter_with_orig
3867 (ffebld_constant_new_realdouble_val
3868 (ffebld_cu_val_realdouble (u)), expr);
3869 break;
3870
3871 #if FFETARGET_okREALQUAD
3872 case FFEINFO_kindtypeREALQUAD:
3873 error = ffetarget_power_realquad_integerdefault
3874 (ffebld_cu_ptr_realquad (u),
3875 ffebld_constant_realquad (ffebld_conter (l)),
3876 ffebld_constant_integerdefault (ffebld_conter (r)));
3877 expr = ffebld_new_conter_with_orig
3878 (ffebld_constant_new_realquad_val
3879 (ffebld_cu_val_realquad (u)), expr);
3880 break;
3881 #endif
3882 default:
3883 assert ("bad real kind type" == NULL);
3884 break;
3885 }
3886 break;
3887
3888 case FFEINFO_basictypeCOMPLEX:
3889 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3890 {
3891 case FFEINFO_kindtypeREALDEFAULT:
3892 error = ffetarget_power_complexdefault_integerdefault
3893 (ffebld_cu_ptr_complexdefault (u),
3894 ffebld_constant_complexdefault (ffebld_conter (l)),
3895 ffebld_constant_integerdefault (ffebld_conter (r)));
3896 expr = ffebld_new_conter_with_orig
3897 (ffebld_constant_new_complexdefault_val
3898 (ffebld_cu_val_complexdefault (u)), expr);
3899 break;
3900
3901 #if FFETARGET_okCOMPLEXDOUBLE
3902 case FFEINFO_kindtypeREALDOUBLE:
3903 error = ffetarget_power_complexdouble_integerdefault
3904 (ffebld_cu_ptr_complexdouble (u),
3905 ffebld_constant_complexdouble (ffebld_conter (l)),
3906 ffebld_constant_integerdefault (ffebld_conter (r)));
3907 expr = ffebld_new_conter_with_orig
3908 (ffebld_constant_new_complexdouble_val
3909 (ffebld_cu_val_complexdouble (u)), expr);
3910 break;
3911 #endif
3912
3913 #if FFETARGET_okCOMPLEXQUAD
3914 case FFEINFO_kindtypeREALQUAD:
3915 error = ffetarget_power_complexquad_integerdefault
3916 (ffebld_cu_ptr_complexquad (u),
3917 ffebld_constant_complexquad (ffebld_conter (l)),
3918 ffebld_constant_integerdefault (ffebld_conter (r)));
3919 expr = ffebld_new_conter_with_orig
3920 (ffebld_constant_new_complexquad_val
3921 (ffebld_cu_val_complexquad (u)), expr);
3922 break;
3923 #endif
3924
3925 default:
3926 assert ("bad complex kind type" == NULL);
3927 break;
3928 }
3929 break;
3930
3931 default:
3932 assert ("bad type" == NULL);
3933 return expr;
3934 }
3935
3936 ffebld_set_info (expr, ffeinfo_new
3937 (bt,
3938 kt,
3939 0,
3940 FFEINFO_kindENTITY,
3941 FFEINFO_whereCONSTANT,
3942 FFETARGET_charactersizeNONE));
3943
3944 if ((error != FFEBAD)
3945 && ffebad_start (error))
3946 {
3947 ffebad_here (0, ffelex_token_where_line (t),
3948 ffelex_token_where_column (t));
3949 ffebad_finish ();
3950 }
3951
3952 return expr;
3953 }
3954
3955 /* ffeexpr_collapse_concatenate -- Collapse concatenate expr
3956
3957 ffebld expr;
3958 ffelexToken token;
3959 expr = ffeexpr_collapse_concatenate(expr,token);
3960
3961 If the result of the expr is a constant, replaces the expr with the
3962 computed constant. */
3963
3964 ffebld
3965 ffeexpr_collapse_concatenate (ffebld expr, ffelexToken t)
3966 {
3967 ffebad error = FFEBAD;
3968 ffebld l;
3969 ffebld r;
3970 ffebldConstantUnion u;
3971 ffeinfoKindtype kt;
3972 ffetargetCharacterSize len;
3973
3974 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3975 return expr;
3976
3977 l = ffebld_left (expr);
3978 r = ffebld_right (expr);
3979
3980 if (ffebld_op (l) != FFEBLD_opCONTER)
3981 return expr;
3982 if (ffebld_op (r) != FFEBLD_opCONTER)
3983 return expr;
3984
3985 switch (ffeinfo_basictype (ffebld_info (expr)))
3986 {
3987 case FFEINFO_basictypeANY:
3988 return expr;
3989
3990 case FFEINFO_basictypeCHARACTER:
3991 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3992 {
3993 #if FFETARGET_okCHARACTER1
3994 case FFEINFO_kindtypeCHARACTER1:
3995 error = ffetarget_concatenate_character1 (ffebld_cu_ptr_character1 (u),
3996 ffebld_constant_character1 (ffebld_conter (l)),
3997 ffebld_constant_character1 (ffebld_conter (r)),
3998 ffebld_constant_pool (), &len);
3999 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
4000 (ffebld_cu_val_character1 (u)), expr);
4001 break;
4002 #endif
4003
4004 default:
4005 assert ("bad character kind type" == NULL);
4006 break;
4007 }
4008 break;
4009
4010 default:
4011 assert ("bad type" == NULL);
4012 return expr;
4013 }
4014
4015 ffebld_set_info (expr, ffeinfo_new
4016 (FFEINFO_basictypeCHARACTER,
4017 kt,
4018 0,
4019 FFEINFO_kindENTITY,
4020 FFEINFO_whereCONSTANT,
4021 len));
4022
4023 if ((error != FFEBAD)
4024 && ffebad_start (error))
4025 {
4026 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4027 ffebad_finish ();
4028 }
4029
4030 return expr;
4031 }
4032
4033 /* ffeexpr_collapse_eq -- Collapse eq expr
4034
4035 ffebld expr;
4036 ffelexToken token;
4037 expr = ffeexpr_collapse_eq(expr,token);
4038
4039 If the result of the expr is a constant, replaces the expr with the
4040 computed constant. */
4041
4042 ffebld
4043 ffeexpr_collapse_eq (ffebld expr, ffelexToken t)
4044 {
4045 ffebad error = FFEBAD;
4046 ffebld l;
4047 ffebld r;
4048 bool val;
4049
4050 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4051 return expr;
4052
4053 l = ffebld_left (expr);
4054 r = ffebld_right (expr);
4055
4056 if (ffebld_op (l) != FFEBLD_opCONTER)
4057 return expr;
4058 if (ffebld_op (r) != FFEBLD_opCONTER)
4059 return expr;
4060
4061 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4062 {
4063 case FFEINFO_basictypeANY:
4064 return expr;
4065
4066 case FFEINFO_basictypeINTEGER:
4067 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4068 {
4069 #if FFETARGET_okINTEGER1
4070 case FFEINFO_kindtypeINTEGER1:
4071 error = ffetarget_eq_integer1 (&val,
4072 ffebld_constant_integer1 (ffebld_conter (l)),
4073 ffebld_constant_integer1 (ffebld_conter (r)));
4074 expr = ffebld_new_conter_with_orig
4075 (ffebld_constant_new_logicaldefault (val), expr);
4076 break;
4077 #endif
4078
4079 #if FFETARGET_okINTEGER2
4080 case FFEINFO_kindtypeINTEGER2:
4081 error = ffetarget_eq_integer2 (&val,
4082 ffebld_constant_integer2 (ffebld_conter (l)),
4083 ffebld_constant_integer2 (ffebld_conter (r)));
4084 expr = ffebld_new_conter_with_orig
4085 (ffebld_constant_new_logicaldefault (val), expr);
4086 break;
4087 #endif
4088
4089 #if FFETARGET_okINTEGER3
4090 case FFEINFO_kindtypeINTEGER3:
4091 error = ffetarget_eq_integer3 (&val,
4092 ffebld_constant_integer3 (ffebld_conter (l)),
4093 ffebld_constant_integer3 (ffebld_conter (r)));
4094 expr = ffebld_new_conter_with_orig
4095 (ffebld_constant_new_logicaldefault (val), expr);
4096 break;
4097 #endif
4098
4099 #if FFETARGET_okINTEGER4
4100 case FFEINFO_kindtypeINTEGER4:
4101 error = ffetarget_eq_integer4 (&val,
4102 ffebld_constant_integer4 (ffebld_conter (l)),
4103 ffebld_constant_integer4 (ffebld_conter (r)));
4104 expr = ffebld_new_conter_with_orig
4105 (ffebld_constant_new_logicaldefault (val), expr);
4106 break;
4107 #endif
4108
4109 default:
4110 assert ("bad integer kind type" == NULL);
4111 break;
4112 }
4113 break;
4114
4115 case FFEINFO_basictypeREAL:
4116 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4117 {
4118 #if FFETARGET_okREAL1
4119 case FFEINFO_kindtypeREAL1:
4120 error = ffetarget_eq_real1 (&val,
4121 ffebld_constant_real1 (ffebld_conter (l)),
4122 ffebld_constant_real1 (ffebld_conter (r)));
4123 expr = ffebld_new_conter_with_orig
4124 (ffebld_constant_new_logicaldefault (val), expr);
4125 break;
4126 #endif
4127
4128 #if FFETARGET_okREAL2
4129 case FFEINFO_kindtypeREAL2:
4130 error = ffetarget_eq_real2 (&val,
4131 ffebld_constant_real2 (ffebld_conter (l)),
4132 ffebld_constant_real2 (ffebld_conter (r)));
4133 expr = ffebld_new_conter_with_orig
4134 (ffebld_constant_new_logicaldefault (val), expr);
4135 break;
4136 #endif
4137
4138 #if FFETARGET_okREAL3
4139 case FFEINFO_kindtypeREAL3:
4140 error = ffetarget_eq_real3 (&val,
4141 ffebld_constant_real3 (ffebld_conter (l)),
4142 ffebld_constant_real3 (ffebld_conter (r)));
4143 expr = ffebld_new_conter_with_orig
4144 (ffebld_constant_new_logicaldefault (val), expr);
4145 break;
4146 #endif
4147
4148 default:
4149 assert ("bad real kind type" == NULL);
4150 break;
4151 }
4152 break;
4153
4154 case FFEINFO_basictypeCOMPLEX:
4155 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4156 {
4157 #if FFETARGET_okCOMPLEX1
4158 case FFEINFO_kindtypeREAL1:
4159 error = ffetarget_eq_complex1 (&val,
4160 ffebld_constant_complex1 (ffebld_conter (l)),
4161 ffebld_constant_complex1 (ffebld_conter (r)));
4162 expr = ffebld_new_conter_with_orig
4163 (ffebld_constant_new_logicaldefault (val), expr);
4164 break;
4165 #endif
4166
4167 #if FFETARGET_okCOMPLEX2
4168 case FFEINFO_kindtypeREAL2:
4169 error = ffetarget_eq_complex2 (&val,
4170 ffebld_constant_complex2 (ffebld_conter (l)),
4171 ffebld_constant_complex2 (ffebld_conter (r)));
4172 expr = ffebld_new_conter_with_orig
4173 (ffebld_constant_new_logicaldefault (val), expr);
4174 break;
4175 #endif
4176
4177 #if FFETARGET_okCOMPLEX3
4178 case FFEINFO_kindtypeREAL3:
4179 error = ffetarget_eq_complex3 (&val,
4180 ffebld_constant_complex3 (ffebld_conter (l)),
4181 ffebld_constant_complex3 (ffebld_conter (r)));
4182 expr = ffebld_new_conter_with_orig
4183 (ffebld_constant_new_logicaldefault (val), expr);
4184 break;
4185 #endif
4186
4187 default:
4188 assert ("bad complex kind type" == NULL);
4189 break;
4190 }
4191 break;
4192
4193 case FFEINFO_basictypeCHARACTER:
4194 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4195 {
4196 #if FFETARGET_okCHARACTER1
4197 case FFEINFO_kindtypeCHARACTER1:
4198 error = ffetarget_eq_character1 (&val,
4199 ffebld_constant_character1 (ffebld_conter (l)),
4200 ffebld_constant_character1 (ffebld_conter (r)));
4201 expr = ffebld_new_conter_with_orig
4202 (ffebld_constant_new_logicaldefault (val), expr);
4203 break;
4204 #endif
4205
4206 default:
4207 assert ("bad character kind type" == NULL);
4208 break;
4209 }
4210 break;
4211
4212 default:
4213 assert ("bad type" == NULL);
4214 return expr;
4215 }
4216
4217 ffebld_set_info (expr, ffeinfo_new
4218 (FFEINFO_basictypeLOGICAL,
4219 FFEINFO_kindtypeLOGICALDEFAULT,
4220 0,
4221 FFEINFO_kindENTITY,
4222 FFEINFO_whereCONSTANT,
4223 FFETARGET_charactersizeNONE));
4224
4225 if ((error != FFEBAD)
4226 && ffebad_start (error))
4227 {
4228 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4229 ffebad_finish ();
4230 }
4231
4232 return expr;
4233 }
4234
4235 /* ffeexpr_collapse_ne -- Collapse ne expr
4236
4237 ffebld expr;
4238 ffelexToken token;
4239 expr = ffeexpr_collapse_ne(expr,token);
4240
4241 If the result of the expr is a constant, replaces the expr with the
4242 computed constant. */
4243
4244 ffebld
4245 ffeexpr_collapse_ne (ffebld expr, ffelexToken t)
4246 {
4247 ffebad error = FFEBAD;
4248 ffebld l;
4249 ffebld r;
4250 bool val;
4251
4252 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4253 return expr;
4254
4255 l = ffebld_left (expr);
4256 r = ffebld_right (expr);
4257
4258 if (ffebld_op (l) != FFEBLD_opCONTER)
4259 return expr;
4260 if (ffebld_op (r) != FFEBLD_opCONTER)
4261 return expr;
4262
4263 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4264 {
4265 case FFEINFO_basictypeANY:
4266 return expr;
4267
4268 case FFEINFO_basictypeINTEGER:
4269 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4270 {
4271 #if FFETARGET_okINTEGER1
4272 case FFEINFO_kindtypeINTEGER1:
4273 error = ffetarget_ne_integer1 (&val,
4274 ffebld_constant_integer1 (ffebld_conter (l)),
4275 ffebld_constant_integer1 (ffebld_conter (r)));
4276 expr = ffebld_new_conter_with_orig
4277 (ffebld_constant_new_logicaldefault (val), expr);
4278 break;
4279 #endif
4280
4281 #if FFETARGET_okINTEGER2
4282 case FFEINFO_kindtypeINTEGER2:
4283 error = ffetarget_ne_integer2 (&val,
4284 ffebld_constant_integer2 (ffebld_conter (l)),
4285 ffebld_constant_integer2 (ffebld_conter (r)));
4286 expr = ffebld_new_conter_with_orig
4287 (ffebld_constant_new_logicaldefault (val), expr);
4288 break;
4289 #endif
4290
4291 #if FFETARGET_okINTEGER3
4292 case FFEINFO_kindtypeINTEGER3:
4293 error = ffetarget_ne_integer3 (&val,
4294 ffebld_constant_integer3 (ffebld_conter (l)),
4295 ffebld_constant_integer3 (ffebld_conter (r)));
4296 expr = ffebld_new_conter_with_orig
4297 (ffebld_constant_new_logicaldefault (val), expr);
4298 break;
4299 #endif
4300
4301 #if FFETARGET_okINTEGER4
4302 case FFEINFO_kindtypeINTEGER4:
4303 error = ffetarget_ne_integer4 (&val,
4304 ffebld_constant_integer4 (ffebld_conter (l)),
4305 ffebld_constant_integer4 (ffebld_conter (r)));
4306 expr = ffebld_new_conter_with_orig
4307 (ffebld_constant_new_logicaldefault (val), expr);
4308 break;
4309 #endif
4310
4311 default:
4312 assert ("bad integer kind type" == NULL);
4313 break;
4314 }
4315 break;
4316
4317 case FFEINFO_basictypeREAL:
4318 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4319 {
4320 #if FFETARGET_okREAL1
4321 case FFEINFO_kindtypeREAL1:
4322 error = ffetarget_ne_real1 (&val,
4323 ffebld_constant_real1 (ffebld_conter (l)),
4324 ffebld_constant_real1 (ffebld_conter (r)));
4325 expr = ffebld_new_conter_with_orig
4326 (ffebld_constant_new_logicaldefault (val), expr);
4327 break;
4328 #endif
4329
4330 #if FFETARGET_okREAL2
4331 case FFEINFO_kindtypeREAL2:
4332 error = ffetarget_ne_real2 (&val,
4333 ffebld_constant_real2 (ffebld_conter (l)),
4334 ffebld_constant_real2 (ffebld_conter (r)));
4335 expr = ffebld_new_conter_with_orig
4336 (ffebld_constant_new_logicaldefault (val), expr);
4337 break;
4338 #endif
4339
4340 #if FFETARGET_okREAL3
4341 case FFEINFO_kindtypeREAL3:
4342 error = ffetarget_ne_real3 (&val,
4343 ffebld_constant_real3 (ffebld_conter (l)),
4344 ffebld_constant_real3 (ffebld_conter (r)));
4345 expr = ffebld_new_conter_with_orig
4346 (ffebld_constant_new_logicaldefault (val), expr);
4347 break;
4348 #endif
4349
4350 default:
4351 assert ("bad real kind type" == NULL);
4352 break;
4353 }
4354 break;
4355
4356 case FFEINFO_basictypeCOMPLEX:
4357 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4358 {
4359 #if FFETARGET_okCOMPLEX1
4360 case FFEINFO_kindtypeREAL1:
4361 error = ffetarget_ne_complex1 (&val,
4362 ffebld_constant_complex1 (ffebld_conter (l)),
4363 ffebld_constant_complex1 (ffebld_conter (r)));
4364 expr = ffebld_new_conter_with_orig
4365 (ffebld_constant_new_logicaldefault (val), expr);
4366 break;
4367 #endif
4368
4369 #if FFETARGET_okCOMPLEX2
4370 case FFEINFO_kindtypeREAL2:
4371 error = ffetarget_ne_complex2 (&val,
4372 ffebld_constant_complex2 (ffebld_conter (l)),
4373 ffebld_constant_complex2 (ffebld_conter (r)));
4374 expr = ffebld_new_conter_with_orig
4375 (ffebld_constant_new_logicaldefault (val), expr);
4376 break;
4377 #endif
4378
4379 #if FFETARGET_okCOMPLEX3
4380 case FFEINFO_kindtypeREAL3:
4381 error = ffetarget_ne_complex3 (&val,
4382 ffebld_constant_complex3 (ffebld_conter (l)),
4383 ffebld_constant_complex3 (ffebld_conter (r)));
4384 expr = ffebld_new_conter_with_orig
4385 (ffebld_constant_new_logicaldefault (val), expr);
4386 break;
4387 #endif
4388
4389 default:
4390 assert ("bad complex kind type" == NULL);
4391 break;
4392 }
4393 break;
4394
4395 case FFEINFO_basictypeCHARACTER:
4396 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4397 {
4398 #if FFETARGET_okCHARACTER1
4399 case FFEINFO_kindtypeCHARACTER1:
4400 error = ffetarget_ne_character1 (&val,
4401 ffebld_constant_character1 (ffebld_conter (l)),
4402 ffebld_constant_character1 (ffebld_conter (r)));
4403 expr = ffebld_new_conter_with_orig
4404 (ffebld_constant_new_logicaldefault (val), expr);
4405 break;
4406 #endif
4407
4408 default:
4409 assert ("bad character kind type" == NULL);
4410 break;
4411 }
4412 break;
4413
4414 default:
4415 assert ("bad type" == NULL);
4416 return expr;
4417 }
4418
4419 ffebld_set_info (expr, ffeinfo_new
4420 (FFEINFO_basictypeLOGICAL,
4421 FFEINFO_kindtypeLOGICALDEFAULT,
4422 0,
4423 FFEINFO_kindENTITY,
4424 FFEINFO_whereCONSTANT,
4425 FFETARGET_charactersizeNONE));
4426
4427 if ((error != FFEBAD)
4428 && ffebad_start (error))
4429 {
4430 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4431 ffebad_finish ();
4432 }
4433
4434 return expr;
4435 }
4436
4437 /* ffeexpr_collapse_ge -- Collapse ge expr
4438
4439 ffebld expr;
4440 ffelexToken token;
4441 expr = ffeexpr_collapse_ge(expr,token);
4442
4443 If the result of the expr is a constant, replaces the expr with the
4444 computed constant. */
4445
4446 ffebld
4447 ffeexpr_collapse_ge (ffebld expr, ffelexToken t)
4448 {
4449 ffebad error = FFEBAD;
4450 ffebld l;
4451 ffebld r;
4452 bool val;
4453
4454 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4455 return expr;
4456
4457 l = ffebld_left (expr);
4458 r = ffebld_right (expr);
4459
4460 if (ffebld_op (l) != FFEBLD_opCONTER)
4461 return expr;
4462 if (ffebld_op (r) != FFEBLD_opCONTER)
4463 return expr;
4464
4465 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4466 {
4467 case FFEINFO_basictypeANY:
4468 return expr;
4469
4470 case FFEINFO_basictypeINTEGER:
4471 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4472 {
4473 #if FFETARGET_okINTEGER1
4474 case FFEINFO_kindtypeINTEGER1:
4475 error = ffetarget_ge_integer1 (&val,
4476 ffebld_constant_integer1 (ffebld_conter (l)),
4477 ffebld_constant_integer1 (ffebld_conter (r)));
4478 expr = ffebld_new_conter_with_orig
4479 (ffebld_constant_new_logicaldefault (val), expr);
4480 break;
4481 #endif
4482
4483 #if FFETARGET_okINTEGER2
4484 case FFEINFO_kindtypeINTEGER2:
4485 error = ffetarget_ge_integer2 (&val,
4486 ffebld_constant_integer2 (ffebld_conter (l)),
4487 ffebld_constant_integer2 (ffebld_conter (r)));
4488 expr = ffebld_new_conter_with_orig
4489 (ffebld_constant_new_logicaldefault (val), expr);
4490 break;
4491 #endif
4492
4493 #if FFETARGET_okINTEGER3
4494 case FFEINFO_kindtypeINTEGER3:
4495 error = ffetarget_ge_integer3 (&val,
4496 ffebld_constant_integer3 (ffebld_conter (l)),
4497 ffebld_constant_integer3 (ffebld_conter (r)));
4498 expr = ffebld_new_conter_with_orig
4499 (ffebld_constant_new_logicaldefault (val), expr);
4500 break;
4501 #endif
4502
4503 #if FFETARGET_okINTEGER4
4504 case FFEINFO_kindtypeINTEGER4:
4505 error = ffetarget_ge_integer4 (&val,
4506 ffebld_constant_integer4 (ffebld_conter (l)),
4507 ffebld_constant_integer4 (ffebld_conter (r)));
4508 expr = ffebld_new_conter_with_orig
4509 (ffebld_constant_new_logicaldefault (val), expr);
4510 break;
4511 #endif
4512
4513 default:
4514 assert ("bad integer kind type" == NULL);
4515 break;
4516 }
4517 break;
4518
4519 case FFEINFO_basictypeREAL:
4520 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4521 {
4522 #if FFETARGET_okREAL1
4523 case FFEINFO_kindtypeREAL1:
4524 error = ffetarget_ge_real1 (&val,
4525 ffebld_constant_real1 (ffebld_conter (l)),
4526 ffebld_constant_real1 (ffebld_conter (r)));
4527 expr = ffebld_new_conter_with_orig
4528 (ffebld_constant_new_logicaldefault (val), expr);
4529 break;
4530 #endif
4531
4532 #if FFETARGET_okREAL2
4533 case FFEINFO_kindtypeREAL2:
4534 error = ffetarget_ge_real2 (&val,
4535 ffebld_constant_real2 (ffebld_conter (l)),
4536 ffebld_constant_real2 (ffebld_conter (r)));
4537 expr = ffebld_new_conter_with_orig
4538 (ffebld_constant_new_logicaldefault (val), expr);
4539 break;
4540 #endif
4541
4542 #if FFETARGET_okREAL3
4543 case FFEINFO_kindtypeREAL3:
4544 error = ffetarget_ge_real3 (&val,
4545 ffebld_constant_real3 (ffebld_conter (l)),
4546 ffebld_constant_real3 (ffebld_conter (r)));
4547 expr = ffebld_new_conter_with_orig
4548 (ffebld_constant_new_logicaldefault (val), expr);
4549 break;
4550 #endif
4551
4552 default:
4553 assert ("bad real kind type" == NULL);
4554 break;
4555 }
4556 break;
4557
4558 case FFEINFO_basictypeCHARACTER:
4559 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4560 {
4561 #if FFETARGET_okCHARACTER1
4562 case FFEINFO_kindtypeCHARACTER1:
4563 error = ffetarget_ge_character1 (&val,
4564 ffebld_constant_character1 (ffebld_conter (l)),
4565 ffebld_constant_character1 (ffebld_conter (r)));
4566 expr = ffebld_new_conter_with_orig
4567 (ffebld_constant_new_logicaldefault (val), expr);
4568 break;
4569 #endif
4570
4571 default:
4572 assert ("bad character kind type" == NULL);
4573 break;
4574 }
4575 break;
4576
4577 default:
4578 assert ("bad type" == NULL);
4579 return expr;
4580 }
4581
4582 ffebld_set_info (expr, ffeinfo_new
4583 (FFEINFO_basictypeLOGICAL,
4584 FFEINFO_kindtypeLOGICALDEFAULT,
4585 0,
4586 FFEINFO_kindENTITY,
4587 FFEINFO_whereCONSTANT,
4588 FFETARGET_charactersizeNONE));
4589
4590 if ((error != FFEBAD)
4591 && ffebad_start (error))
4592 {
4593 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4594 ffebad_finish ();
4595 }
4596
4597 return expr;
4598 }
4599
4600 /* ffeexpr_collapse_gt -- Collapse gt expr
4601
4602 ffebld expr;
4603 ffelexToken token;
4604 expr = ffeexpr_collapse_gt(expr,token);
4605
4606 If the result of the expr is a constant, replaces the expr with the
4607 computed constant. */
4608
4609 ffebld
4610 ffeexpr_collapse_gt (ffebld expr, ffelexToken t)
4611 {
4612 ffebad error = FFEBAD;
4613 ffebld l;
4614 ffebld r;
4615 bool val;
4616
4617 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4618 return expr;
4619
4620 l = ffebld_left (expr);
4621 r = ffebld_right (expr);
4622
4623 if (ffebld_op (l) != FFEBLD_opCONTER)
4624 return expr;
4625 if (ffebld_op (r) != FFEBLD_opCONTER)
4626 return expr;
4627
4628 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4629 {
4630 case FFEINFO_basictypeANY:
4631 return expr;
4632
4633 case FFEINFO_basictypeINTEGER:
4634 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4635 {
4636 #if FFETARGET_okINTEGER1
4637 case FFEINFO_kindtypeINTEGER1:
4638 error = ffetarget_gt_integer1 (&val,
4639 ffebld_constant_integer1 (ffebld_conter (l)),
4640 ffebld_constant_integer1 (ffebld_conter (r)));
4641 expr = ffebld_new_conter_with_orig
4642 (ffebld_constant_new_logicaldefault (val), expr);
4643 break;
4644 #endif
4645
4646 #if FFETARGET_okINTEGER2
4647 case FFEINFO_kindtypeINTEGER2:
4648 error = ffetarget_gt_integer2 (&val,
4649 ffebld_constant_integer2 (ffebld_conter (l)),
4650 ffebld_constant_integer2 (ffebld_conter (r)));
4651 expr = ffebld_new_conter_with_orig
4652 (ffebld_constant_new_logicaldefault (val), expr);
4653 break;
4654 #endif
4655
4656 #if FFETARGET_okINTEGER3
4657 case FFEINFO_kindtypeINTEGER3:
4658 error = ffetarget_gt_integer3 (&val,
4659 ffebld_constant_integer3 (ffebld_conter (l)),
4660 ffebld_constant_integer3 (ffebld_conter (r)));
4661 expr = ffebld_new_conter_with_orig
4662 (ffebld_constant_new_logicaldefault (val), expr);
4663 break;
4664 #endif
4665
4666 #if FFETARGET_okINTEGER4
4667 case FFEINFO_kindtypeINTEGER4:
4668 error = ffetarget_gt_integer4 (&val,
4669 ffebld_constant_integer4 (ffebld_conter (l)),
4670 ffebld_constant_integer4 (ffebld_conter (r)));
4671 expr = ffebld_new_conter_with_orig
4672 (ffebld_constant_new_logicaldefault (val), expr);
4673 break;
4674 #endif
4675
4676 default:
4677 assert ("bad integer kind type" == NULL);
4678 break;
4679 }
4680 break;
4681
4682 case FFEINFO_basictypeREAL:
4683 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4684 {
4685 #if FFETARGET_okREAL1
4686 case FFEINFO_kindtypeREAL1:
4687 error = ffetarget_gt_real1 (&val,
4688 ffebld_constant_real1 (ffebld_conter (l)),
4689 ffebld_constant_real1 (ffebld_conter (r)));
4690 expr = ffebld_new_conter_with_orig
4691 (ffebld_constant_new_logicaldefault (val), expr);
4692 break;
4693 #endif
4694
4695 #if FFETARGET_okREAL2
4696 case FFEINFO_kindtypeREAL2:
4697 error = ffetarget_gt_real2 (&val,
4698 ffebld_constant_real2 (ffebld_conter (l)),
4699 ffebld_constant_real2 (ffebld_conter (r)));
4700 expr = ffebld_new_conter_with_orig
4701 (ffebld_constant_new_logicaldefault (val), expr);
4702 break;
4703 #endif
4704
4705 #if FFETARGET_okREAL3
4706 case FFEINFO_kindtypeREAL3:
4707 error = ffetarget_gt_real3 (&val,
4708 ffebld_constant_real3 (ffebld_conter (l)),
4709 ffebld_constant_real3 (ffebld_conter (r)));
4710 expr = ffebld_new_conter_with_orig
4711 (ffebld_constant_new_logicaldefault (val), expr);
4712 break;
4713 #endif
4714
4715 default:
4716 assert ("bad real kind type" == NULL);
4717 break;
4718 }
4719 break;
4720
4721 case FFEINFO_basictypeCHARACTER:
4722 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4723 {
4724 #if FFETARGET_okCHARACTER1
4725 case FFEINFO_kindtypeCHARACTER1:
4726 error = ffetarget_gt_character1 (&val,
4727 ffebld_constant_character1 (ffebld_conter (l)),
4728 ffebld_constant_character1 (ffebld_conter (r)));
4729 expr = ffebld_new_conter_with_orig
4730 (ffebld_constant_new_logicaldefault (val), expr);
4731 break;
4732 #endif
4733
4734 default:
4735 assert ("bad character kind type" == NULL);
4736 break;
4737 }
4738 break;
4739
4740 default:
4741 assert ("bad type" == NULL);
4742 return expr;
4743 }
4744
4745 ffebld_set_info (expr, ffeinfo_new
4746 (FFEINFO_basictypeLOGICAL,
4747 FFEINFO_kindtypeLOGICALDEFAULT,
4748 0,
4749 FFEINFO_kindENTITY,
4750 FFEINFO_whereCONSTANT,
4751 FFETARGET_charactersizeNONE));
4752
4753 if ((error != FFEBAD)
4754 && ffebad_start (error))
4755 {
4756 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4757 ffebad_finish ();
4758 }
4759
4760 return expr;
4761 }
4762
4763 /* ffeexpr_collapse_le -- Collapse le expr
4764
4765 ffebld expr;
4766 ffelexToken token;
4767 expr = ffeexpr_collapse_le(expr,token);
4768
4769 If the result of the expr is a constant, replaces the expr with the
4770 computed constant. */
4771
4772 ffebld
4773 ffeexpr_collapse_le (ffebld expr, ffelexToken t)
4774 {
4775 ffebad error = FFEBAD;
4776 ffebld l;
4777 ffebld r;
4778 bool val;
4779
4780 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4781 return expr;
4782
4783 l = ffebld_left (expr);
4784 r = ffebld_right (expr);
4785
4786 if (ffebld_op (l) != FFEBLD_opCONTER)
4787 return expr;
4788 if (ffebld_op (r) != FFEBLD_opCONTER)
4789 return expr;
4790
4791 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4792 {
4793 case FFEINFO_basictypeANY:
4794 return expr;
4795
4796 case FFEINFO_basictypeINTEGER:
4797 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4798 {
4799 #if FFETARGET_okINTEGER1
4800 case FFEINFO_kindtypeINTEGER1:
4801 error = ffetarget_le_integer1 (&val,
4802 ffebld_constant_integer1 (ffebld_conter (l)),
4803 ffebld_constant_integer1 (ffebld_conter (r)));
4804 expr = ffebld_new_conter_with_orig
4805 (ffebld_constant_new_logicaldefault (val), expr);
4806 break;
4807 #endif
4808
4809 #if FFETARGET_okINTEGER2
4810 case FFEINFO_kindtypeINTEGER2:
4811 error = ffetarget_le_integer2 (&val,
4812 ffebld_constant_integer2 (ffebld_conter (l)),
4813 ffebld_constant_integer2 (ffebld_conter (r)));
4814 expr = ffebld_new_conter_with_orig
4815 (ffebld_constant_new_logicaldefault (val), expr);
4816 break;
4817 #endif
4818
4819 #if FFETARGET_okINTEGER3
4820 case FFEINFO_kindtypeINTEGER3:
4821 error = ffetarget_le_integer3 (&val,
4822 ffebld_constant_integer3 (ffebld_conter (l)),
4823 ffebld_constant_integer3 (ffebld_conter (r)));
4824 expr = ffebld_new_conter_with_orig
4825 (ffebld_constant_new_logicaldefault (val), expr);
4826 break;
4827 #endif
4828
4829 #if FFETARGET_okINTEGER4
4830 case FFEINFO_kindtypeINTEGER4:
4831 error = ffetarget_le_integer4 (&val,
4832 ffebld_constant_integer4 (ffebld_conter (l)),
4833 ffebld_constant_integer4 (ffebld_conter (r)));
4834 expr = ffebld_new_conter_with_orig
4835 (ffebld_constant_new_logicaldefault (val), expr);
4836 break;
4837 #endif
4838
4839 default:
4840 assert ("bad integer kind type" == NULL);
4841 break;
4842 }
4843 break;
4844
4845 case FFEINFO_basictypeREAL:
4846 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4847 {
4848 #if FFETARGET_okREAL1
4849 case FFEINFO_kindtypeREAL1:
4850 error = ffetarget_le_real1 (&val,
4851 ffebld_constant_real1 (ffebld_conter (l)),
4852 ffebld_constant_real1 (ffebld_conter (r)));
4853 expr = ffebld_new_conter_with_orig
4854 (ffebld_constant_new_logicaldefault (val), expr);
4855 break;
4856 #endif
4857
4858 #if FFETARGET_okREAL2
4859 case FFEINFO_kindtypeREAL2:
4860 error = ffetarget_le_real2 (&val,
4861 ffebld_constant_real2 (ffebld_conter (l)),
4862 ffebld_constant_real2 (ffebld_conter (r)));
4863 expr = ffebld_new_conter_with_orig
4864 (ffebld_constant_new_logicaldefault (val), expr);
4865 break;
4866 #endif
4867
4868 #if FFETARGET_okREAL3
4869 case FFEINFO_kindtypeREAL3:
4870 error = ffetarget_le_real3 (&val,
4871 ffebld_constant_real3 (ffebld_conter (l)),
4872 ffebld_constant_real3 (ffebld_conter (r)));
4873 expr = ffebld_new_conter_with_orig
4874 (ffebld_constant_new_logicaldefault (val), expr);
4875 break;
4876 #endif
4877
4878 default:
4879 assert ("bad real kind type" == NULL);
4880 break;
4881 }
4882 break;
4883
4884 case FFEINFO_basictypeCHARACTER:
4885 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4886 {
4887 #if FFETARGET_okCHARACTER1
4888 case FFEINFO_kindtypeCHARACTER1:
4889 error = ffetarget_le_character1 (&val,
4890 ffebld_constant_character1 (ffebld_conter (l)),
4891 ffebld_constant_character1 (ffebld_conter (r)));
4892 expr = ffebld_new_conter_with_orig
4893 (ffebld_constant_new_logicaldefault (val), expr);
4894 break;
4895 #endif
4896
4897 default:
4898 assert ("bad character kind type" == NULL);
4899 break;
4900 }
4901 break;
4902
4903 default:
4904 assert ("bad type" == NULL);
4905 return expr;
4906 }
4907
4908 ffebld_set_info (expr, ffeinfo_new
4909 (FFEINFO_basictypeLOGICAL,
4910 FFEINFO_kindtypeLOGICALDEFAULT,
4911 0,
4912 FFEINFO_kindENTITY,
4913 FFEINFO_whereCONSTANT,
4914 FFETARGET_charactersizeNONE));
4915
4916 if ((error != FFEBAD)
4917 && ffebad_start (error))
4918 {
4919 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4920 ffebad_finish ();
4921 }
4922
4923 return expr;
4924 }
4925
4926 /* ffeexpr_collapse_lt -- Collapse lt expr
4927
4928 ffebld expr;
4929 ffelexToken token;
4930 expr = ffeexpr_collapse_lt(expr,token);
4931
4932 If the result of the expr is a constant, replaces the expr with the
4933 computed constant. */
4934
4935 ffebld
4936 ffeexpr_collapse_lt (ffebld expr, ffelexToken t)
4937 {
4938 ffebad error = FFEBAD;
4939 ffebld l;
4940 ffebld r;
4941 bool val;
4942
4943 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4944 return expr;
4945
4946 l = ffebld_left (expr);
4947 r = ffebld_right (expr);
4948
4949 if (ffebld_op (l) != FFEBLD_opCONTER)
4950 return expr;
4951 if (ffebld_op (r) != FFEBLD_opCONTER)
4952 return expr;
4953
4954 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4955 {
4956 case FFEINFO_basictypeANY:
4957 return expr;
4958
4959 case FFEINFO_basictypeINTEGER:
4960 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4961 {
4962 #if FFETARGET_okINTEGER1
4963 case FFEINFO_kindtypeINTEGER1:
4964 error = ffetarget_lt_integer1 (&val,
4965 ffebld_constant_integer1 (ffebld_conter (l)),
4966 ffebld_constant_integer1 (ffebld_conter (r)));
4967 expr = ffebld_new_conter_with_orig
4968 (ffebld_constant_new_logicaldefault (val), expr);
4969 break;
4970 #endif
4971
4972 #if FFETARGET_okINTEGER2
4973 case FFEINFO_kindtypeINTEGER2:
4974 error = ffetarget_lt_integer2 (&val,
4975 ffebld_constant_integer2 (ffebld_conter (l)),
4976 ffebld_constant_integer2 (ffebld_conter (r)));
4977 expr = ffebld_new_conter_with_orig
4978 (ffebld_constant_new_logicaldefault (val), expr);
4979 break;
4980 #endif
4981
4982 #if FFETARGET_okINTEGER3
4983 case FFEINFO_kindtypeINTEGER3:
4984 error = ffetarget_lt_integer3 (&val,
4985 ffebld_constant_integer3 (ffebld_conter (l)),
4986 ffebld_constant_integer3 (ffebld_conter (r)));
4987 expr = ffebld_new_conter_with_orig
4988 (ffebld_constant_new_logicaldefault (val), expr);
4989 break;
4990 #endif
4991
4992 #if FFETARGET_okINTEGER4
4993 case FFEINFO_kindtypeINTEGER4:
4994 error = ffetarget_lt_integer4 (&val,
4995 ffebld_constant_integer4 (ffebld_conter (l)),
4996 ffebld_constant_integer4 (ffebld_conter (r)));
4997 expr = ffebld_new_conter_with_orig
4998 (ffebld_constant_new_logicaldefault (val), expr);
4999 break;
5000 #endif
5001
5002 default:
5003 assert ("bad integer kind type" == NULL);
5004 break;
5005 }
5006 break;
5007
5008 case FFEINFO_basictypeREAL:
5009 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5010 {
5011 #if FFETARGET_okREAL1
5012 case FFEINFO_kindtypeREAL1:
5013 error = ffetarget_lt_real1 (&val,
5014 ffebld_constant_real1 (ffebld_conter (l)),
5015 ffebld_constant_real1 (ffebld_conter (r)));
5016 expr = ffebld_new_conter_with_orig
5017 (ffebld_constant_new_logicaldefault (val), expr);
5018 break;
5019 #endif
5020
5021 #if FFETARGET_okREAL2
5022 case FFEINFO_kindtypeREAL2:
5023 error = ffetarget_lt_real2 (&val,
5024 ffebld_constant_real2 (ffebld_conter (l)),
5025 ffebld_constant_real2 (ffebld_conter (r)));
5026 expr = ffebld_new_conter_with_orig
5027 (ffebld_constant_new_logicaldefault (val), expr);
5028 break;
5029 #endif
5030
5031 #if FFETARGET_okREAL3
5032 case FFEINFO_kindtypeREAL3:
5033 error = ffetarget_lt_real3 (&val,
5034 ffebld_constant_real3 (ffebld_conter (l)),
5035 ffebld_constant_real3 (ffebld_conter (r)));
5036 expr = ffebld_new_conter_with_orig
5037 (ffebld_constant_new_logicaldefault (val), expr);
5038 break;
5039 #endif
5040
5041 default:
5042 assert ("bad real kind type" == NULL);
5043 break;
5044 }
5045 break;
5046
5047 case FFEINFO_basictypeCHARACTER:
5048 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5049 {
5050 #if FFETARGET_okCHARACTER1
5051 case FFEINFO_kindtypeCHARACTER1:
5052 error = ffetarget_lt_character1 (&val,
5053 ffebld_constant_character1 (ffebld_conter (l)),
5054 ffebld_constant_character1 (ffebld_conter (r)));
5055 expr = ffebld_new_conter_with_orig
5056 (ffebld_constant_new_logicaldefault (val), expr);
5057 break;
5058 #endif
5059
5060 default:
5061 assert ("bad character kind type" == NULL);
5062 break;
5063 }
5064 break;
5065
5066 default:
5067 assert ("bad type" == NULL);
5068 return expr;
5069 }
5070
5071 ffebld_set_info (expr, ffeinfo_new
5072 (FFEINFO_basictypeLOGICAL,
5073 FFEINFO_kindtypeLOGICALDEFAULT,
5074 0,
5075 FFEINFO_kindENTITY,
5076 FFEINFO_whereCONSTANT,
5077 FFETARGET_charactersizeNONE));
5078
5079 if ((error != FFEBAD)
5080 && ffebad_start (error))
5081 {
5082 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5083 ffebad_finish ();
5084 }
5085
5086 return expr;
5087 }
5088
5089 /* ffeexpr_collapse_and -- Collapse and expr
5090
5091 ffebld expr;
5092 ffelexToken token;
5093 expr = ffeexpr_collapse_and(expr,token);
5094
5095 If the result of the expr is a constant, replaces the expr with the
5096 computed constant. */
5097
5098 ffebld
5099 ffeexpr_collapse_and (ffebld expr, ffelexToken t)
5100 {
5101 ffebad error = FFEBAD;
5102 ffebld l;
5103 ffebld r;
5104 ffebldConstantUnion u;
5105 ffeinfoBasictype bt;
5106 ffeinfoKindtype kt;
5107
5108 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5109 return expr;
5110
5111 l = ffebld_left (expr);
5112 r = ffebld_right (expr);
5113
5114 if (ffebld_op (l) != FFEBLD_opCONTER)
5115 return expr;
5116 if (ffebld_op (r) != FFEBLD_opCONTER)
5117 return expr;
5118
5119 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5120 {
5121 case FFEINFO_basictypeANY:
5122 return expr;
5123
5124 case FFEINFO_basictypeINTEGER:
5125 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5126 {
5127 #if FFETARGET_okINTEGER1
5128 case FFEINFO_kindtypeINTEGER1:
5129 error = ffetarget_and_integer1 (ffebld_cu_ptr_integer1 (u),
5130 ffebld_constant_integer1 (ffebld_conter (l)),
5131 ffebld_constant_integer1 (ffebld_conter (r)));
5132 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5133 (ffebld_cu_val_integer1 (u)), expr);
5134 break;
5135 #endif
5136
5137 #if FFETARGET_okINTEGER2
5138 case FFEINFO_kindtypeINTEGER2:
5139 error = ffetarget_and_integer2 (ffebld_cu_ptr_integer2 (u),
5140 ffebld_constant_integer2 (ffebld_conter (l)),
5141 ffebld_constant_integer2 (ffebld_conter (r)));
5142 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5143 (ffebld_cu_val_integer2 (u)), expr);
5144 break;
5145 #endif
5146
5147 #if FFETARGET_okINTEGER3
5148 case FFEINFO_kindtypeINTEGER3:
5149 error = ffetarget_and_integer3 (ffebld_cu_ptr_integer3 (u),
5150 ffebld_constant_integer3 (ffebld_conter (l)),
5151 ffebld_constant_integer3 (ffebld_conter (r)));
5152 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5153 (ffebld_cu_val_integer3 (u)), expr);
5154 break;
5155 #endif
5156
5157 #if FFETARGET_okINTEGER4
5158 case FFEINFO_kindtypeINTEGER4:
5159 error = ffetarget_and_integer4 (ffebld_cu_ptr_integer4 (u),
5160 ffebld_constant_integer4 (ffebld_conter (l)),
5161 ffebld_constant_integer4 (ffebld_conter (r)));
5162 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5163 (ffebld_cu_val_integer4 (u)), expr);
5164 break;
5165 #endif
5166
5167 default:
5168 assert ("bad integer kind type" == NULL);
5169 break;
5170 }
5171 break;
5172
5173 case FFEINFO_basictypeLOGICAL:
5174 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5175 {
5176 #if FFETARGET_okLOGICAL1
5177 case FFEINFO_kindtypeLOGICAL1:
5178 error = ffetarget_and_logical1 (ffebld_cu_ptr_logical1 (u),
5179 ffebld_constant_logical1 (ffebld_conter (l)),
5180 ffebld_constant_logical1 (ffebld_conter (r)));
5181 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5182 (ffebld_cu_val_logical1 (u)), expr);
5183 break;
5184 #endif
5185
5186 #if FFETARGET_okLOGICAL2
5187 case FFEINFO_kindtypeLOGICAL2:
5188 error = ffetarget_and_logical2 (ffebld_cu_ptr_logical2 (u),
5189 ffebld_constant_logical2 (ffebld_conter (l)),
5190 ffebld_constant_logical2 (ffebld_conter (r)));
5191 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5192 (ffebld_cu_val_logical2 (u)), expr);
5193 break;
5194 #endif
5195
5196 #if FFETARGET_okLOGICAL3
5197 case FFEINFO_kindtypeLOGICAL3:
5198 error = ffetarget_and_logical3 (ffebld_cu_ptr_logical3 (u),
5199 ffebld_constant_logical3 (ffebld_conter (l)),
5200 ffebld_constant_logical3 (ffebld_conter (r)));
5201 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5202 (ffebld_cu_val_logical3 (u)), expr);
5203 break;
5204 #endif
5205
5206 #if FFETARGET_okLOGICAL4
5207 case FFEINFO_kindtypeLOGICAL4:
5208 error = ffetarget_and_logical4 (ffebld_cu_ptr_logical4 (u),
5209 ffebld_constant_logical4 (ffebld_conter (l)),
5210 ffebld_constant_logical4 (ffebld_conter (r)));
5211 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5212 (ffebld_cu_val_logical4 (u)), expr);
5213 break;
5214 #endif
5215
5216 default:
5217 assert ("bad logical kind type" == NULL);
5218 break;
5219 }
5220 break;
5221
5222 default:
5223 assert ("bad type" == NULL);
5224 return expr;
5225 }
5226
5227 ffebld_set_info (expr, ffeinfo_new
5228 (bt,
5229 kt,
5230 0,
5231 FFEINFO_kindENTITY,
5232 FFEINFO_whereCONSTANT,
5233 FFETARGET_charactersizeNONE));
5234
5235 if ((error != FFEBAD)
5236 && ffebad_start (error))
5237 {
5238 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5239 ffebad_finish ();
5240 }
5241
5242 return expr;
5243 }
5244
5245 /* ffeexpr_collapse_or -- Collapse or expr
5246
5247 ffebld expr;
5248 ffelexToken token;
5249 expr = ffeexpr_collapse_or(expr,token);
5250
5251 If the result of the expr is a constant, replaces the expr with the
5252 computed constant. */
5253
5254 ffebld
5255 ffeexpr_collapse_or (ffebld expr, ffelexToken t)
5256 {
5257 ffebad error = FFEBAD;
5258 ffebld l;
5259 ffebld r;
5260 ffebldConstantUnion u;
5261 ffeinfoBasictype bt;
5262 ffeinfoKindtype kt;
5263
5264 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5265 return expr;
5266
5267 l = ffebld_left (expr);
5268 r = ffebld_right (expr);
5269
5270 if (ffebld_op (l) != FFEBLD_opCONTER)
5271 return expr;
5272 if (ffebld_op (r) != FFEBLD_opCONTER)
5273 return expr;
5274
5275 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5276 {
5277 case FFEINFO_basictypeANY:
5278 return expr;
5279
5280 case FFEINFO_basictypeINTEGER:
5281 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5282 {
5283 #if FFETARGET_okINTEGER1
5284 case FFEINFO_kindtypeINTEGER1:
5285 error = ffetarget_or_integer1 (ffebld_cu_ptr_integer1 (u),
5286 ffebld_constant_integer1 (ffebld_conter (l)),
5287 ffebld_constant_integer1 (ffebld_conter (r)));
5288 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5289 (ffebld_cu_val_integer1 (u)), expr);
5290 break;
5291 #endif
5292
5293 #if FFETARGET_okINTEGER2
5294 case FFEINFO_kindtypeINTEGER2:
5295 error = ffetarget_or_integer2 (ffebld_cu_ptr_integer2 (u),
5296 ffebld_constant_integer2 (ffebld_conter (l)),
5297 ffebld_constant_integer2 (ffebld_conter (r)));
5298 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5299 (ffebld_cu_val_integer2 (u)), expr);
5300 break;
5301 #endif
5302
5303 #if FFETARGET_okINTEGER3
5304 case FFEINFO_kindtypeINTEGER3:
5305 error = ffetarget_or_integer3 (ffebld_cu_ptr_integer3 (u),
5306 ffebld_constant_integer3 (ffebld_conter (l)),
5307 ffebld_constant_integer3 (ffebld_conter (r)));
5308 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5309 (ffebld_cu_val_integer3 (u)), expr);
5310 break;
5311 #endif
5312
5313 #if FFETARGET_okINTEGER4
5314 case FFEINFO_kindtypeINTEGER4:
5315 error = ffetarget_or_integer4 (ffebld_cu_ptr_integer4 (u),
5316 ffebld_constant_integer4 (ffebld_conter (l)),
5317 ffebld_constant_integer4 (ffebld_conter (r)));
5318 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5319 (ffebld_cu_val_integer4 (u)), expr);
5320 break;
5321 #endif
5322
5323 default:
5324 assert ("bad integer kind type" == NULL);
5325 break;
5326 }
5327 break;
5328
5329 case FFEINFO_basictypeLOGICAL:
5330 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5331 {
5332 #if FFETARGET_okLOGICAL1
5333 case FFEINFO_kindtypeLOGICAL1:
5334 error = ffetarget_or_logical1 (ffebld_cu_ptr_logical1 (u),
5335 ffebld_constant_logical1 (ffebld_conter (l)),
5336 ffebld_constant_logical1 (ffebld_conter (r)));
5337 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5338 (ffebld_cu_val_logical1 (u)), expr);
5339 break;
5340 #endif
5341
5342 #if FFETARGET_okLOGICAL2
5343 case FFEINFO_kindtypeLOGICAL2:
5344 error = ffetarget_or_logical2 (ffebld_cu_ptr_logical2 (u),
5345 ffebld_constant_logical2 (ffebld_conter (l)),
5346 ffebld_constant_logical2 (ffebld_conter (r)));
5347 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5348 (ffebld_cu_val_logical2 (u)), expr);
5349 break;
5350 #endif
5351
5352 #if FFETARGET_okLOGICAL3
5353 case FFEINFO_kindtypeLOGICAL3:
5354 error = ffetarget_or_logical3 (ffebld_cu_ptr_logical3 (u),
5355 ffebld_constant_logical3 (ffebld_conter (l)),
5356 ffebld_constant_logical3 (ffebld_conter (r)));
5357 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5358 (ffebld_cu_val_logical3 (u)), expr);
5359 break;
5360 #endif
5361
5362 #if FFETARGET_okLOGICAL4
5363 case FFEINFO_kindtypeLOGICAL4:
5364 error = ffetarget_or_logical4 (ffebld_cu_ptr_logical4 (u),
5365 ffebld_constant_logical4 (ffebld_conter (l)),
5366 ffebld_constant_logical4 (ffebld_conter (r)));
5367 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5368 (ffebld_cu_val_logical4 (u)), expr);
5369 break;
5370 #endif
5371
5372 default:
5373 assert ("bad logical kind type" == NULL);
5374 break;
5375 }
5376 break;
5377
5378 default:
5379 assert ("bad type" == NULL);
5380 return expr;
5381 }
5382
5383 ffebld_set_info (expr, ffeinfo_new
5384 (bt,
5385 kt,
5386 0,
5387 FFEINFO_kindENTITY,
5388 FFEINFO_whereCONSTANT,
5389 FFETARGET_charactersizeNONE));
5390
5391 if ((error != FFEBAD)
5392 && ffebad_start (error))
5393 {
5394 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5395 ffebad_finish ();
5396 }
5397
5398 return expr;
5399 }
5400
5401 /* ffeexpr_collapse_xor -- Collapse xor expr
5402
5403 ffebld expr;
5404 ffelexToken token;
5405 expr = ffeexpr_collapse_xor(expr,token);
5406
5407 If the result of the expr is a constant, replaces the expr with the
5408 computed constant. */
5409
5410 ffebld
5411 ffeexpr_collapse_xor (ffebld expr, ffelexToken t)
5412 {
5413 ffebad error = FFEBAD;
5414 ffebld l;
5415 ffebld r;
5416 ffebldConstantUnion u;
5417 ffeinfoBasictype bt;
5418 ffeinfoKindtype kt;
5419
5420 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5421 return expr;
5422
5423 l = ffebld_left (expr);
5424 r = ffebld_right (expr);
5425
5426 if (ffebld_op (l) != FFEBLD_opCONTER)
5427 return expr;
5428 if (ffebld_op (r) != FFEBLD_opCONTER)
5429 return expr;
5430
5431 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5432 {
5433 case FFEINFO_basictypeANY:
5434 return expr;
5435
5436 case FFEINFO_basictypeINTEGER:
5437 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5438 {
5439 #if FFETARGET_okINTEGER1
5440 case FFEINFO_kindtypeINTEGER1:
5441 error = ffetarget_xor_integer1 (ffebld_cu_ptr_integer1 (u),
5442 ffebld_constant_integer1 (ffebld_conter (l)),
5443 ffebld_constant_integer1 (ffebld_conter (r)));
5444 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5445 (ffebld_cu_val_integer1 (u)), expr);
5446 break;
5447 #endif
5448
5449 #if FFETARGET_okINTEGER2
5450 case FFEINFO_kindtypeINTEGER2:
5451 error = ffetarget_xor_integer2 (ffebld_cu_ptr_integer2 (u),
5452 ffebld_constant_integer2 (ffebld_conter (l)),
5453 ffebld_constant_integer2 (ffebld_conter (r)));
5454 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5455 (ffebld_cu_val_integer2 (u)), expr);
5456 break;
5457 #endif
5458
5459 #if FFETARGET_okINTEGER3
5460 case FFEINFO_kindtypeINTEGER3:
5461 error = ffetarget_xor_integer3 (ffebld_cu_ptr_integer3 (u),
5462 ffebld_constant_integer3 (ffebld_conter (l)),
5463 ffebld_constant_integer3 (ffebld_conter (r)));
5464 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5465 (ffebld_cu_val_integer3 (u)), expr);
5466 break;
5467 #endif
5468
5469 #if FFETARGET_okINTEGER4
5470 case FFEINFO_kindtypeINTEGER4:
5471 error = ffetarget_xor_integer4 (ffebld_cu_ptr_integer4 (u),
5472 ffebld_constant_integer4 (ffebld_conter (l)),
5473 ffebld_constant_integer4 (ffebld_conter (r)));
5474 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5475 (ffebld_cu_val_integer4 (u)), expr);
5476 break;
5477 #endif
5478
5479 default:
5480 assert ("bad integer kind type" == NULL);
5481 break;
5482 }
5483 break;
5484
5485 case FFEINFO_basictypeLOGICAL:
5486 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5487 {
5488 #if FFETARGET_okLOGICAL1
5489 case FFEINFO_kindtypeLOGICAL1:
5490 error = ffetarget_xor_logical1 (ffebld_cu_ptr_logical1 (u),
5491 ffebld_constant_logical1 (ffebld_conter (l)),
5492 ffebld_constant_logical1 (ffebld_conter (r)));
5493 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5494 (ffebld_cu_val_logical1 (u)), expr);
5495 break;
5496 #endif
5497
5498 #if FFETARGET_okLOGICAL2
5499 case FFEINFO_kindtypeLOGICAL2:
5500 error = ffetarget_xor_logical2 (ffebld_cu_ptr_logical2 (u),
5501 ffebld_constant_logical2 (ffebld_conter (l)),
5502 ffebld_constant_logical2 (ffebld_conter (r)));
5503 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5504 (ffebld_cu_val_logical2 (u)), expr);
5505 break;
5506 #endif
5507
5508 #if FFETARGET_okLOGICAL3
5509 case FFEINFO_kindtypeLOGICAL3:
5510 error = ffetarget_xor_logical3 (ffebld_cu_ptr_logical3 (u),
5511 ffebld_constant_logical3 (ffebld_conter (l)),
5512 ffebld_constant_logical3 (ffebld_conter (r)));
5513 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5514 (ffebld_cu_val_logical3 (u)), expr);
5515 break;
5516 #endif
5517
5518 #if FFETARGET_okLOGICAL4
5519 case FFEINFO_kindtypeLOGICAL4:
5520 error = ffetarget_xor_logical4 (ffebld_cu_ptr_logical4 (u),
5521 ffebld_constant_logical4 (ffebld_conter (l)),
5522 ffebld_constant_logical4 (ffebld_conter (r)));
5523 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5524 (ffebld_cu_val_logical4 (u)), expr);
5525 break;
5526 #endif
5527
5528 default:
5529 assert ("bad logical kind type" == NULL);
5530 break;
5531 }
5532 break;
5533
5534 default:
5535 assert ("bad type" == NULL);
5536 return expr;
5537 }
5538
5539 ffebld_set_info (expr, ffeinfo_new
5540 (bt,
5541 kt,
5542 0,
5543 FFEINFO_kindENTITY,
5544 FFEINFO_whereCONSTANT,
5545 FFETARGET_charactersizeNONE));
5546
5547 if ((error != FFEBAD)
5548 && ffebad_start (error))
5549 {
5550 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5551 ffebad_finish ();
5552 }
5553
5554 return expr;
5555 }
5556
5557 /* ffeexpr_collapse_eqv -- Collapse eqv expr
5558
5559 ffebld expr;
5560 ffelexToken token;
5561 expr = ffeexpr_collapse_eqv(expr,token);
5562
5563 If the result of the expr is a constant, replaces the expr with the
5564 computed constant. */
5565
5566 ffebld
5567 ffeexpr_collapse_eqv (ffebld expr, ffelexToken t)
5568 {
5569 ffebad error = FFEBAD;
5570 ffebld l;
5571 ffebld r;
5572 ffebldConstantUnion u;
5573 ffeinfoBasictype bt;
5574 ffeinfoKindtype kt;
5575
5576 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5577 return expr;
5578
5579 l = ffebld_left (expr);
5580 r = ffebld_right (expr);
5581
5582 if (ffebld_op (l) != FFEBLD_opCONTER)
5583 return expr;
5584 if (ffebld_op (r) != FFEBLD_opCONTER)
5585 return expr;
5586
5587 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5588 {
5589 case FFEINFO_basictypeANY:
5590 return expr;
5591
5592 case FFEINFO_basictypeINTEGER:
5593 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5594 {
5595 #if FFETARGET_okINTEGER1
5596 case FFEINFO_kindtypeINTEGER1:
5597 error = ffetarget_eqv_integer1 (ffebld_cu_ptr_integer1 (u),
5598 ffebld_constant_integer1 (ffebld_conter (l)),
5599 ffebld_constant_integer1 (ffebld_conter (r)));
5600 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5601 (ffebld_cu_val_integer1 (u)), expr);
5602 break;
5603 #endif
5604
5605 #if FFETARGET_okINTEGER2
5606 case FFEINFO_kindtypeINTEGER2:
5607 error = ffetarget_eqv_integer2 (ffebld_cu_ptr_integer2 (u),
5608 ffebld_constant_integer2 (ffebld_conter (l)),
5609 ffebld_constant_integer2 (ffebld_conter (r)));
5610 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5611 (ffebld_cu_val_integer2 (u)), expr);
5612 break;
5613 #endif
5614
5615 #if FFETARGET_okINTEGER3
5616 case FFEINFO_kindtypeINTEGER3:
5617 error = ffetarget_eqv_integer3 (ffebld_cu_ptr_integer3 (u),
5618 ffebld_constant_integer3 (ffebld_conter (l)),
5619 ffebld_constant_integer3 (ffebld_conter (r)));
5620 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5621 (ffebld_cu_val_integer3 (u)), expr);
5622 break;
5623 #endif
5624
5625 #if FFETARGET_okINTEGER4
5626 case FFEINFO_kindtypeINTEGER4:
5627 error = ffetarget_eqv_integer4 (ffebld_cu_ptr_integer4 (u),
5628 ffebld_constant_integer4 (ffebld_conter (l)),
5629 ffebld_constant_integer4 (ffebld_conter (r)));
5630 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5631 (ffebld_cu_val_integer4 (u)), expr);
5632 break;
5633 #endif
5634
5635 default:
5636 assert ("bad integer kind type" == NULL);
5637 break;
5638 }
5639 break;
5640
5641 case FFEINFO_basictypeLOGICAL:
5642 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5643 {
5644 #if FFETARGET_okLOGICAL1
5645 case FFEINFO_kindtypeLOGICAL1:
5646 error = ffetarget_eqv_logical1 (ffebld_cu_ptr_logical1 (u),
5647 ffebld_constant_logical1 (ffebld_conter (l)),
5648 ffebld_constant_logical1 (ffebld_conter (r)));
5649 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5650 (ffebld_cu_val_logical1 (u)), expr);
5651 break;
5652 #endif
5653
5654 #if FFETARGET_okLOGICAL2
5655 case FFEINFO_kindtypeLOGICAL2:
5656 error = ffetarget_eqv_logical2 (ffebld_cu_ptr_logical2 (u),
5657 ffebld_constant_logical2 (ffebld_conter (l)),
5658 ffebld_constant_logical2 (ffebld_conter (r)));
5659 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5660 (ffebld_cu_val_logical2 (u)), expr);
5661 break;
5662 #endif
5663
5664 #if FFETARGET_okLOGICAL3
5665 case FFEINFO_kindtypeLOGICAL3:
5666 error = ffetarget_eqv_logical3 (ffebld_cu_ptr_logical3 (u),
5667 ffebld_constant_logical3 (ffebld_conter (l)),
5668 ffebld_constant_logical3 (ffebld_conter (r)));
5669 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5670 (ffebld_cu_val_logical3 (u)), expr);
5671 break;
5672 #endif
5673
5674 #if FFETARGET_okLOGICAL4
5675 case FFEINFO_kindtypeLOGICAL4:
5676 error = ffetarget_eqv_logical4 (ffebld_cu_ptr_logical4 (u),
5677 ffebld_constant_logical4 (ffebld_conter (l)),
5678 ffebld_constant_logical4 (ffebld_conter (r)));
5679 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5680 (ffebld_cu_val_logical4 (u)), expr);
5681 break;
5682 #endif
5683
5684 default:
5685 assert ("bad logical kind type" == NULL);
5686 break;
5687 }
5688 break;
5689
5690 default:
5691 assert ("bad type" == NULL);
5692 return expr;
5693 }
5694
5695 ffebld_set_info (expr, ffeinfo_new
5696 (bt,
5697 kt,
5698 0,
5699 FFEINFO_kindENTITY,
5700 FFEINFO_whereCONSTANT,
5701 FFETARGET_charactersizeNONE));
5702
5703 if ((error != FFEBAD)
5704 && ffebad_start (error))
5705 {
5706 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5707 ffebad_finish ();
5708 }
5709
5710 return expr;
5711 }
5712
5713 /* ffeexpr_collapse_neqv -- Collapse neqv expr
5714
5715 ffebld expr;
5716 ffelexToken token;
5717 expr = ffeexpr_collapse_neqv(expr,token);
5718
5719 If the result of the expr is a constant, replaces the expr with the
5720 computed constant. */
5721
5722 ffebld
5723 ffeexpr_collapse_neqv (ffebld expr, ffelexToken t)
5724 {
5725 ffebad error = FFEBAD;
5726 ffebld l;
5727 ffebld r;
5728 ffebldConstantUnion u;
5729 ffeinfoBasictype bt;
5730 ffeinfoKindtype kt;
5731
5732 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5733 return expr;
5734
5735 l = ffebld_left (expr);
5736 r = ffebld_right (expr);
5737
5738 if (ffebld_op (l) != FFEBLD_opCONTER)
5739 return expr;
5740 if (ffebld_op (r) != FFEBLD_opCONTER)
5741 return expr;
5742
5743 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5744 {
5745 case FFEINFO_basictypeANY:
5746 return expr;
5747
5748 case FFEINFO_basictypeINTEGER:
5749 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5750 {
5751 #if FFETARGET_okINTEGER1
5752 case FFEINFO_kindtypeINTEGER1:
5753 error = ffetarget_neqv_integer1 (ffebld_cu_ptr_integer1 (u),
5754 ffebld_constant_integer1 (ffebld_conter (l)),
5755 ffebld_constant_integer1 (ffebld_conter (r)));
5756 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5757 (ffebld_cu_val_integer1 (u)), expr);
5758 break;
5759 #endif
5760
5761 #if FFETARGET_okINTEGER2
5762 case FFEINFO_kindtypeINTEGER2:
5763 error = ffetarget_neqv_integer2 (ffebld_cu_ptr_integer2 (u),
5764 ffebld_constant_integer2 (ffebld_conter (l)),
5765 ffebld_constant_integer2 (ffebld_conter (r)));
5766 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5767 (ffebld_cu_val_integer2 (u)), expr);
5768 break;
5769 #endif
5770
5771 #if FFETARGET_okINTEGER3
5772 case FFEINFO_kindtypeINTEGER3:
5773 error = ffetarget_neqv_integer3 (ffebld_cu_ptr_integer3 (u),
5774 ffebld_constant_integer3 (ffebld_conter (l)),
5775 ffebld_constant_integer3 (ffebld_conter (r)));
5776 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5777 (ffebld_cu_val_integer3 (u)), expr);
5778 break;
5779 #endif
5780
5781 #if FFETARGET_okINTEGER4
5782 case FFEINFO_kindtypeINTEGER4:
5783 error = ffetarget_neqv_integer4 (ffebld_cu_ptr_integer4 (u),
5784 ffebld_constant_integer4 (ffebld_conter (l)),
5785 ffebld_constant_integer4 (ffebld_conter (r)));
5786 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5787 (ffebld_cu_val_integer4 (u)), expr);
5788 break;
5789 #endif
5790
5791 default:
5792 assert ("bad integer kind type" == NULL);
5793 break;
5794 }
5795 break;
5796
5797 case FFEINFO_basictypeLOGICAL:
5798 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5799 {
5800 #if FFETARGET_okLOGICAL1
5801 case FFEINFO_kindtypeLOGICAL1:
5802 error = ffetarget_neqv_logical1 (ffebld_cu_ptr_logical1 (u),
5803 ffebld_constant_logical1 (ffebld_conter (l)),
5804 ffebld_constant_logical1 (ffebld_conter (r)));
5805 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5806 (ffebld_cu_val_logical1 (u)), expr);
5807 break;
5808 #endif
5809
5810 #if FFETARGET_okLOGICAL2
5811 case FFEINFO_kindtypeLOGICAL2:
5812 error = ffetarget_neqv_logical2 (ffebld_cu_ptr_logical2 (u),
5813 ffebld_constant_logical2 (ffebld_conter (l)),
5814 ffebld_constant_logical2 (ffebld_conter (r)));
5815 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5816 (ffebld_cu_val_logical2 (u)), expr);
5817 break;
5818 #endif
5819
5820 #if FFETARGET_okLOGICAL3
5821 case FFEINFO_kindtypeLOGICAL3:
5822 error = ffetarget_neqv_logical3 (ffebld_cu_ptr_logical3 (u),
5823 ffebld_constant_logical3 (ffebld_conter (l)),
5824 ffebld_constant_logical3 (ffebld_conter (r)));
5825 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5826 (ffebld_cu_val_logical3 (u)), expr);
5827 break;
5828 #endif
5829
5830 #if FFETARGET_okLOGICAL4
5831 case FFEINFO_kindtypeLOGICAL4:
5832 error = ffetarget_neqv_logical4 (ffebld_cu_ptr_logical4 (u),
5833 ffebld_constant_logical4 (ffebld_conter (l)),
5834 ffebld_constant_logical4 (ffebld_conter (r)));
5835 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5836 (ffebld_cu_val_logical4 (u)), expr);
5837 break;
5838 #endif
5839
5840 default:
5841 assert ("bad logical kind type" == NULL);
5842 break;
5843 }
5844 break;
5845
5846 default:
5847 assert ("bad type" == NULL);
5848 return expr;
5849 }
5850
5851 ffebld_set_info (expr, ffeinfo_new
5852 (bt,
5853 kt,
5854 0,
5855 FFEINFO_kindENTITY,
5856 FFEINFO_whereCONSTANT,
5857 FFETARGET_charactersizeNONE));
5858
5859 if ((error != FFEBAD)
5860 && ffebad_start (error))
5861 {
5862 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5863 ffebad_finish ();
5864 }
5865
5866 return expr;
5867 }
5868
5869 /* ffeexpr_collapse_symter -- Collapse symter expr
5870
5871 ffebld expr;
5872 ffelexToken token;
5873 expr = ffeexpr_collapse_symter(expr,token);
5874
5875 If the result of the expr is a constant, replaces the expr with the
5876 computed constant. */
5877
5878 ffebld
5879 ffeexpr_collapse_symter (ffebld expr, ffelexToken t UNUSED)
5880 {
5881 ffebld r;
5882 ffeinfoBasictype bt;
5883 ffeinfoKindtype kt;
5884 ffetargetCharacterSize len;
5885
5886 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5887 return expr;
5888
5889 if ((r = ffesymbol_init (ffebld_symter (expr))) == NULL)
5890 return expr; /* A PARAMETER lhs in progress. */
5891
5892 switch (ffebld_op (r))
5893 {
5894 case FFEBLD_opCONTER:
5895 break;
5896
5897 case FFEBLD_opANY:
5898 return r;
5899
5900 default:
5901 return expr;
5902 }
5903
5904 bt = ffeinfo_basictype (ffebld_info (r));
5905 kt = ffeinfo_kindtype (ffebld_info (r));
5906 len = ffebld_size (r);
5907
5908 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
5909 expr);
5910
5911 ffebld_set_info (expr, ffeinfo_new
5912 (bt,
5913 kt,
5914 0,
5915 FFEINFO_kindENTITY,
5916 FFEINFO_whereCONSTANT,
5917 len));
5918
5919 return expr;
5920 }
5921
5922 /* ffeexpr_collapse_funcref -- Collapse funcref expr
5923
5924 ffebld expr;
5925 ffelexToken token;
5926 expr = ffeexpr_collapse_funcref(expr,token);
5927
5928 If the result of the expr is a constant, replaces the expr with the
5929 computed constant. */
5930
5931 ffebld
5932 ffeexpr_collapse_funcref (ffebld expr, ffelexToken t UNUSED)
5933 {
5934 return expr; /* ~~someday go ahead and collapse these,
5935 though not required */
5936 }
5937
5938 /* ffeexpr_collapse_arrayref -- Collapse arrayref expr
5939
5940 ffebld expr;
5941 ffelexToken token;
5942 expr = ffeexpr_collapse_arrayref(expr,token);
5943
5944 If the result of the expr is a constant, replaces the expr with the
5945 computed constant. */
5946
5947 ffebld
5948 ffeexpr_collapse_arrayref (ffebld expr, ffelexToken t UNUSED)
5949 {
5950 return expr;
5951 }
5952
5953 /* ffeexpr_collapse_substr -- Collapse substr expr
5954
5955 ffebld expr;
5956 ffelexToken token;
5957 expr = ffeexpr_collapse_substr(expr,token);
5958
5959 If the result of the expr is a constant, replaces the expr with the
5960 computed constant. */
5961
5962 ffebld
5963 ffeexpr_collapse_substr (ffebld expr, ffelexToken t)
5964 {
5965 ffebad error = FFEBAD;
5966 ffebld l;
5967 ffebld r;
5968 ffebld start;
5969 ffebld stop;
5970 ffebldConstantUnion u;
5971 ffeinfoKindtype kt;
5972 ffetargetCharacterSize len;
5973 ffetargetIntegerDefault first;
5974 ffetargetIntegerDefault last;
5975
5976 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5977 return expr;
5978
5979 l = ffebld_left (expr);
5980 r = ffebld_right (expr); /* opITEM. */
5981
5982 if (ffebld_op (l) != FFEBLD_opCONTER)
5983 return expr;
5984
5985 kt = ffeinfo_kindtype (ffebld_info (l));
5986 len = ffebld_size (l);
5987
5988 start = ffebld_head (r);
5989 stop = ffebld_head (ffebld_trail (r));
5990 if (start == NULL)
5991 first = 1;
5992 else
5993 {
5994 if ((ffebld_op (start) != FFEBLD_opCONTER)
5995 || (ffeinfo_basictype (ffebld_info (start)) != FFEINFO_basictypeINTEGER)
5996 || (ffeinfo_kindtype (ffebld_info (start))
5997 != FFEINFO_kindtypeINTEGERDEFAULT))
5998 return expr;
5999 first = ffebld_constant_integerdefault (ffebld_conter (start));
6000 }
6001 if (stop == NULL)
6002 last = len;
6003 else
6004 {
6005 if ((ffebld_op (stop) != FFEBLD_opCONTER)
6006 || (ffeinfo_basictype (ffebld_info (stop)) != FFEINFO_basictypeINTEGER)
6007 || (ffeinfo_kindtype (ffebld_info (stop))
6008 != FFEINFO_kindtypeINTEGERDEFAULT))
6009 return expr;
6010 last = ffebld_constant_integerdefault (ffebld_conter (stop));
6011 }
6012
6013 /* Handle problems that should have already been diagnosed, but
6014 left in the expression tree. */
6015
6016 if (first <= 0)
6017 first = 1;
6018 if (last < first)
6019 last = first + len - 1;
6020
6021 if ((first == 1) && (last == len))
6022 { /* Same as original. */
6023 expr = ffebld_new_conter_with_orig (ffebld_constant_copy
6024 (ffebld_conter (l)), expr);
6025 ffebld_set_info (expr, ffeinfo_new
6026 (FFEINFO_basictypeCHARACTER,
6027 kt,
6028 0,
6029 FFEINFO_kindENTITY,
6030 FFEINFO_whereCONSTANT,
6031 len));
6032
6033 return expr;
6034 }
6035
6036 switch (ffeinfo_basictype (ffebld_info (expr)))
6037 {
6038 case FFEINFO_basictypeANY:
6039 return expr;
6040
6041 case FFEINFO_basictypeCHARACTER:
6042 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6043 {
6044 #if FFETARGET_okCHARACTER1
6045 case FFEINFO_kindtypeCHARACTER1:
6046 error = ffetarget_substr_character1 (ffebld_cu_ptr_character1 (u),
6047 ffebld_constant_character1 (ffebld_conter (l)), first, last,
6048 ffebld_constant_pool (), &len);
6049 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
6050 (ffebld_cu_val_character1 (u)), expr);
6051 break;
6052 #endif
6053
6054 default:
6055 assert ("bad character kind type" == NULL);
6056 break;
6057 }
6058 break;
6059
6060 default:
6061 assert ("bad type" == NULL);
6062 return expr;
6063 }
6064
6065 ffebld_set_info (expr, ffeinfo_new
6066 (FFEINFO_basictypeCHARACTER,
6067 kt,
6068 0,
6069 FFEINFO_kindENTITY,
6070 FFEINFO_whereCONSTANT,
6071 len));
6072
6073 if ((error != FFEBAD)
6074 && ffebad_start (error))
6075 {
6076 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6077 ffebad_finish ();
6078 }
6079
6080 return expr;
6081 }
6082
6083 /* ffeexpr_convert -- Convert source expression to given type
6084
6085 ffebld source;
6086 ffelexToken source_token;
6087 ffelexToken dest_token; // Any appropriate token for "destination".
6088 ffeinfoBasictype bt;
6089 ffeinfoKindtype kt;
6090 ffetargetCharactersize sz;
6091 ffeexprContext context; // Mainly LET or DATA.
6092 source = ffeexpr_convert(source,source_token,dest_token,bt,kt,sz,context);
6093
6094 If the expression conforms, returns the source expression. Otherwise
6095 returns source wrapped in a convert node doing the conversion, or
6096 ANY wrapped in convert if there is a conversion error (and issues an
6097 error message). Be sensitive to the context for certain aspects of
6098 the conversion. */
6099
6100 ffebld
6101 ffeexpr_convert (ffebld source, ffelexToken source_token, ffelexToken dest_token,
6102 ffeinfoBasictype bt, ffeinfoKindtype kt, ffeinfoRank rk,
6103 ffetargetCharacterSize sz, ffeexprContext context)
6104 {
6105 bool bad;
6106 ffeinfo info;
6107 ffeinfoWhere wh;
6108
6109 info = ffebld_info (source);
6110 if ((bt != ffeinfo_basictype (info))
6111 || (kt != ffeinfo_kindtype (info))
6112 || (rk != 0) /* Can't convert from or to arrays yet. */
6113 || (ffeinfo_rank (info) != 0)
6114 || (sz != ffebld_size_known (source)))
6115 #if 0 /* Nobody seems to need this spurious CONVERT node. */
6116 || ((context != FFEEXPR_contextLET)
6117 && (bt == FFEINFO_basictypeCHARACTER)
6118 && (sz == FFETARGET_charactersizeNONE)))
6119 #endif
6120 {
6121 switch (ffeinfo_basictype (info))
6122 {
6123 case FFEINFO_basictypeLOGICAL:
6124 switch (bt)
6125 {
6126 case FFEINFO_basictypeLOGICAL:
6127 bad = FALSE;
6128 break;
6129
6130 case FFEINFO_basictypeINTEGER:
6131 bad = !ffe_is_ugly_logint ();
6132 break;
6133
6134 case FFEINFO_basictypeCHARACTER:
6135 bad = ffe_is_pedantic ()
6136 || !(ffe_is_ugly_init ()
6137 && (context == FFEEXPR_contextDATA));
6138 break;
6139
6140 default:
6141 bad = TRUE;
6142 break;
6143 }
6144 break;
6145
6146 case FFEINFO_basictypeINTEGER:
6147 switch (bt)
6148 {
6149 case FFEINFO_basictypeINTEGER:
6150 case FFEINFO_basictypeREAL:
6151 case FFEINFO_basictypeCOMPLEX:
6152 bad = FALSE;
6153 break;
6154
6155 case FFEINFO_basictypeLOGICAL:
6156 bad = !ffe_is_ugly_logint ();
6157 break;
6158
6159 case FFEINFO_basictypeCHARACTER:
6160 bad = ffe_is_pedantic ()
6161 || !(ffe_is_ugly_init ()
6162 && (context == FFEEXPR_contextDATA));
6163 break;
6164
6165 default:
6166 bad = TRUE;
6167 break;
6168 }
6169 break;
6170
6171 case FFEINFO_basictypeREAL:
6172 case FFEINFO_basictypeCOMPLEX:
6173 switch (bt)
6174 {
6175 case FFEINFO_basictypeINTEGER:
6176 case FFEINFO_basictypeREAL:
6177 case FFEINFO_basictypeCOMPLEX:
6178 bad = FALSE;
6179 break;
6180
6181 case FFEINFO_basictypeCHARACTER:
6182 bad = TRUE;
6183 break;
6184
6185 default:
6186 bad = TRUE;
6187 break;
6188 }
6189 break;
6190
6191 case FFEINFO_basictypeCHARACTER:
6192 bad = (bt != FFEINFO_basictypeCHARACTER)
6193 && (ffe_is_pedantic ()
6194 || (bt != FFEINFO_basictypeINTEGER)
6195 || !(ffe_is_ugly_init ()
6196 && (context == FFEEXPR_contextDATA)));
6197 break;
6198
6199 case FFEINFO_basictypeTYPELESS:
6200 case FFEINFO_basictypeHOLLERITH:
6201 bad = ffe_is_pedantic ()
6202 || !(ffe_is_ugly_init ()
6203 && ((context == FFEEXPR_contextDATA)
6204 || (context == FFEEXPR_contextLET)));
6205 break;
6206
6207 default:
6208 bad = TRUE;
6209 break;
6210 }
6211
6212 if (!bad && ((rk != 0) || (ffeinfo_rank (info) != 0)))
6213 bad = TRUE;
6214
6215 if (bad && (bt != FFEINFO_basictypeANY) && (kt != FFEINFO_kindtypeANY)
6216 && (ffeinfo_basictype (info) != FFEINFO_basictypeANY)
6217 && (ffeinfo_kindtype (info) != FFEINFO_kindtypeANY)
6218 && (ffeinfo_where (info) != FFEINFO_whereANY))
6219 {
6220 if (ffebad_start (FFEBAD_BAD_TYPES))
6221 {
6222 if (dest_token == NULL)
6223 ffebad_here (0, ffewhere_line_unknown (),
6224 ffewhere_column_unknown ());
6225 else
6226 ffebad_here (0, ffelex_token_where_line (dest_token),
6227 ffelex_token_where_column (dest_token));
6228 assert (source_token != NULL);
6229 ffebad_here (1, ffelex_token_where_line (source_token),
6230 ffelex_token_where_column (source_token));
6231 ffebad_finish ();
6232 }
6233
6234 source = ffebld_new_any ();
6235 ffebld_set_info (source, ffeinfo_new_any ());
6236 }
6237 else
6238 {
6239 switch (ffeinfo_where (info))
6240 {
6241 case FFEINFO_whereCONSTANT:
6242 wh = FFEINFO_whereCONSTANT;
6243 break;
6244
6245 case FFEINFO_whereIMMEDIATE:
6246 wh = FFEINFO_whereIMMEDIATE;
6247 break;
6248
6249 default:
6250 wh = FFEINFO_whereFLEETING;
6251 break;
6252 }
6253 source = ffebld_new_convert (source);
6254 ffebld_set_info (source, ffeinfo_new
6255 (bt,
6256 kt,
6257 0,
6258 FFEINFO_kindENTITY,
6259 wh,
6260 sz));
6261 source = ffeexpr_collapse_convert (source, source_token);
6262 }
6263 }
6264
6265 return source;
6266 }
6267
6268 /* ffeexpr_convert_expr -- Convert source expr to conform to dest expr
6269
6270 ffebld source;
6271 ffebld dest;
6272 ffelexToken source_token;
6273 ffelexToken dest_token;
6274 ffeexprContext context;
6275 source = ffeexpr_convert_expr(source,source_token,dest,dest_token,context);
6276
6277 If the expressions conform, returns the source expression. Otherwise
6278 returns source wrapped in a convert node doing the conversion, or
6279 ANY wrapped in convert if there is a conversion error (and issues an
6280 error message). Be sensitive to the context, such as LET or DATA. */
6281
6282 ffebld
6283 ffeexpr_convert_expr (ffebld source, ffelexToken source_token, ffebld dest,
6284 ffelexToken dest_token, ffeexprContext context)
6285 {
6286 ffeinfo info;
6287
6288 info = ffebld_info (dest);
6289 return ffeexpr_convert (source, source_token, dest_token,
6290 ffeinfo_basictype (info),
6291 ffeinfo_kindtype (info),
6292 ffeinfo_rank (info),
6293 ffebld_size_known (dest),
6294 context);
6295 }
6296
6297 /* ffeexpr_convert_to_sym -- Convert source expression to conform to symbol
6298
6299 ffebld source;
6300 ffesymbol dest;
6301 ffelexToken source_token;
6302 ffelexToken dest_token;
6303 source = ffeexpr_convert_to_sym(source,source_token,dest,dest_token);
6304
6305 If the expressions conform, returns the source expression. Otherwise
6306 returns source wrapped in a convert node doing the conversion, or
6307 ANY wrapped in convert if there is a conversion error (and issues an
6308 error message). */
6309
6310 ffebld
6311 ffeexpr_convert_to_sym (ffebld source, ffelexToken source_token,
6312 ffesymbol dest, ffelexToken dest_token)
6313 {
6314 return ffeexpr_convert (source, source_token, dest_token, ffesymbol_basictype (dest),
6315 ffesymbol_kindtype (dest), ffesymbol_rank (dest), ffesymbol_size (dest),
6316 FFEEXPR_contextLET);
6317 }
6318
6319 /* Initializes the module. */
6320
6321 void
6322 ffeexpr_init_2 (void)
6323 {
6324 ffeexpr_stack_ = NULL;
6325 ffeexpr_level_ = 0;
6326 }
6327
6328 /* ffeexpr_lhs -- Begin processing left-hand-side-context expression
6329
6330 Prepares cluster for delivery of lexer tokens representing an expression
6331 in a left-hand-side context (A in A=B, for example). ffebld is used
6332 to build expressions in the given pool. The appropriate lexer-token
6333 handling routine within ffeexpr is returned. When the end of the
6334 expression is detected, mycallbackroutine is called with the resulting
6335 single ffebld object specifying the entire expression and the first
6336 lexer token that is not considered part of the expression. This caller-
6337 supplied routine itself returns a lexer-token handling routine. Thus,
6338 if necessary, ffeexpr can return several tokens as end-of-expression
6339 tokens if it needs to scan forward more than one in any instance. */
6340
6341 ffelexHandler
6342 ffeexpr_lhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
6343 {
6344 ffeexprStack_ s;
6345
6346 ffebld_pool_push (pool);
6347 s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
6348 s->previous = ffeexpr_stack_;
6349 s->pool = pool;
6350 s->context = context;
6351 s->callback = callback;
6352 s->first_token = NULL;
6353 s->exprstack = NULL;
6354 s->is_rhs = FALSE;
6355 ffeexpr_stack_ = s;
6356 return (ffelexHandler) ffeexpr_token_first_lhs_;
6357 }
6358
6359 /* ffeexpr_rhs -- Begin processing right-hand-side-context expression
6360
6361 return ffeexpr_rhs(malloc_pool_image(),mycallbackroutine); // to lexer.
6362
6363 Prepares cluster for delivery of lexer tokens representing an expression
6364 in a right-hand-side context (B in A=B, for example). ffebld is used
6365 to build expressions in the given pool. The appropriate lexer-token
6366 handling routine within ffeexpr is returned. When the end of the
6367 expression is detected, mycallbackroutine is called with the resulting
6368 single ffebld object specifying the entire expression and the first
6369 lexer token that is not considered part of the expression. This caller-
6370 supplied routine itself returns a lexer-token handling routine. Thus,
6371 if necessary, ffeexpr can return several tokens as end-of-expression
6372 tokens if it needs to scan forward more than one in any instance. */
6373
6374 ffelexHandler
6375 ffeexpr_rhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
6376 {
6377 ffeexprStack_ s;
6378
6379 ffebld_pool_push (pool);
6380 s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
6381 s->previous = ffeexpr_stack_;
6382 s->pool = pool;
6383 s->context = context;
6384 s->callback = callback;
6385 s->first_token = NULL;
6386 s->exprstack = NULL;
6387 s->is_rhs = TRUE;
6388 ffeexpr_stack_ = s;
6389 return (ffelexHandler) ffeexpr_token_first_rhs_;
6390 }
6391
6392 /* ffeexpr_cb_close_paren_ -- OPEN_PAREN expr
6393
6394 Pass it to ffeexpr_rhs as the callback routine.
6395
6396 Makes sure the end token is close-paren and swallows it, else issues
6397 an error message and doesn't swallow the token (passing it along instead).
6398 In either case wraps up subexpression construction by enclosing the
6399 ffebld expression in a paren. */
6400
6401 static ffelexHandler
6402 ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr, ffelexToken t)
6403 {
6404 ffeexprExpr_ e;
6405
6406 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
6407 {
6408 /* Oops, naughty user didn't specify the close paren! */
6409
6410 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
6411 {
6412 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6413 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
6414 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
6415 ffebad_finish ();
6416 }
6417
6418 e = ffeexpr_expr_new_ ();
6419 e->type = FFEEXPR_exprtypeOPERAND_;
6420 e->u.operand = ffebld_new_any ();
6421 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
6422 ffeexpr_exprstack_push_operand_ (e);
6423
6424 return
6425 (ffelexHandler) ffeexpr_find_close_paren_ (t,
6426 (ffelexHandler)
6427 ffeexpr_token_binary_);
6428 }
6429
6430 if (expr->op == FFEBLD_opIMPDO)
6431 {
6432 if (ffest_ffebad_start (FFEBAD_IMPDO_PAREN))
6433 {
6434 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
6435 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
6436 ffebad_finish ();
6437 }
6438 }
6439 else
6440 {
6441 expr = ffebld_new_paren (expr);
6442 ffebld_set_info (expr, ffeinfo_use (ffebld_info (ffebld_left (expr))));
6443 }
6444
6445 /* Now push the (parenthesized) expression as an operand onto the
6446 expression stack. */
6447
6448 e = ffeexpr_expr_new_ ();
6449 e->type = FFEEXPR_exprtypeOPERAND_;
6450 e->u.operand = expr;
6451 e->u.operand = ffeexpr_collapse_paren (e->u.operand, ft);
6452 e->token = ffeexpr_stack_->tokens[0];
6453 ffeexpr_exprstack_push_operand_ (e);
6454
6455 return (ffelexHandler) ffeexpr_token_binary_;
6456 }
6457
6458 /* ffeexpr_cb_close_paren_ambig_ -- OPEN_PAREN expr
6459
6460 Pass it to ffeexpr_rhs as the callback routine.
6461
6462 We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
6463 with the next token in t. If the next token is possibly a binary
6464 operator, continue processing the outer expression. If the next
6465 token is COMMA, then the expression is a unit specifier, and
6466 parentheses should not be added to it because it surrounds the
6467 I/O control list that starts with the unit specifier (and continues
6468 on from here -- we haven't seen the CLOSE_PAREN that matches the
6469 OPEN_PAREN, it is up to the callback function to expect to see it
6470 at some point). In this case, we notify the callback function that
6471 the COMMA is inside, not outside, the parens by wrapping the expression
6472 in an opITEM (with a NULL trail) -- the callback function presumably
6473 unwraps it after seeing this kludgey indicator.
6474
6475 If the next token is CLOSE_PAREN, then we go to the _1_ state to
6476 decide what to do with the token after that.
6477
6478 15-Feb-91 JCB 1.1
6479 Use an extra state for the CLOSE_PAREN case to make READ &co really
6480 work right. */
6481
6482 static ffelexHandler
6483 ffeexpr_cb_close_paren_ambig_ (ffelexToken ft, ffebld expr, ffelexToken t)
6484 {
6485 ffeexprCallback callback;
6486 ffeexprStack_ s;
6487
6488 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
6489 { /* Need to see the next token before we
6490 decide anything. */
6491 ffeexpr_stack_->expr = expr;
6492 ffeexpr_tokens_[0] = ffelex_token_use (ft);
6493 ffeexpr_tokens_[1] = ffelex_token_use (t);
6494 return (ffelexHandler) ffeexpr_cb_close_paren_ambig_1_;
6495 }
6496
6497 expr = ffeexpr_finished_ambig_ (ft, expr);
6498
6499 /* Let the callback function handle the case where t isn't COMMA. */
6500
6501 /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
6502 that preceded the expression starts a list of expressions, and the expr
6503 hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
6504 node. The callback function should extract the real expr from the head
6505 of this opITEM node after testing it. */
6506
6507 expr = ffebld_new_item (expr, NULL);
6508
6509 ffebld_pool_pop ();
6510 callback = ffeexpr_stack_->callback;
6511 ffelex_token_kill (ffeexpr_stack_->first_token);
6512 s = ffeexpr_stack_->previous;
6513 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
6514 ffeexpr_stack_ = s;
6515 return (ffelexHandler) (*callback) (ft, expr, t);
6516 }
6517
6518 /* ffeexpr_cb_close_paren_ambig_1_ -- OPEN_PAREN expr CLOSE_PAREN
6519
6520 See ffeexpr_cb_close_paren_ambig_.
6521
6522 We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
6523 with the next token in t. If the next token is possibly a binary
6524 operator, continue processing the outer expression. If the next
6525 token is COMMA, the expression is a parenthesized format specifier.
6526 If the next token is not EOS or SEMICOLON, then because it is not a
6527 binary operator (it is NAME, OPEN_PAREN, &c), the expression is
6528 a unit specifier, and parentheses should not be added to it because
6529 they surround the I/O control list that consists of only the unit
6530 specifier. If the next token is EOS or SEMICOLON, the statement
6531 must be disambiguated by looking at the type of the expression -- a
6532 character expression is a parenthesized format specifier, while a
6533 non-character expression is a unit specifier.
6534
6535 Another issue is how to do the callback so the recipient of the
6536 next token knows how to handle it if it is a COMMA. In all other
6537 cases, disambiguation is straightforward: the same approach as the
6538 above is used.
6539
6540 EXTENSION: in COMMA case, if not pedantic, use same disambiguation
6541 as for EOS/SEMICOLON case; f2c allows "READ (cilist) [[,]iolist]"
6542 and apparently other compilers do, as well, and some code out there
6543 uses this "feature".
6544
6545 19-Feb-91 JCB 1.1
6546 Extend to allow COMMA as nondisambiguating by itself. Remember
6547 to not try and check info field for opSTAR, since that expr doesn't
6548 have a valid info field. */
6549
6550 static ffelexHandler
6551 ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t)
6552 {
6553 ffeexprCallback callback;
6554 ffeexprStack_ s;
6555 ffelexHandler next;
6556 ffelexToken orig_ft = ffeexpr_tokens_[0]; /* In case callback clobbers
6557 these. */
6558 ffelexToken orig_t = ffeexpr_tokens_[1];
6559 ffebld expr = ffeexpr_stack_->expr;
6560
6561 switch (ffelex_token_type (t))
6562 {
6563 case FFELEX_typeCOMMA: /* Subexpr is parenthesized format specifier. */
6564 if (ffe_is_pedantic ())
6565 goto pedantic_comma; /* :::::::::::::::::::: */
6566 /* Fall through. */
6567 case FFELEX_typeEOS: /* Ambiguous; use type of expr to
6568 disambiguate. */
6569 case FFELEX_typeSEMICOLON:
6570 if ((expr == NULL) || (ffebld_op (expr) == FFEBLD_opANY)
6571 || (ffebld_op (expr) == FFEBLD_opSTAR)
6572 || (ffeinfo_basictype (ffebld_info (expr))
6573 != FFEINFO_basictypeCHARACTER))
6574 break; /* Not a valid CHARACTER entity, can't be a
6575 format spec. */
6576 /* Fall through. */
6577 default: /* Binary op (we assume; error otherwise);
6578 format specifier. */
6579
6580 pedantic_comma: /* :::::::::::::::::::: */
6581
6582 switch (ffeexpr_stack_->context)
6583 {
6584 case FFEEXPR_contextFILENUMAMBIG:
6585 ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
6586 break;
6587
6588 case FFEEXPR_contextFILEUNITAMBIG:
6589 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
6590 break;
6591
6592 default:
6593 assert ("bad context" == NULL);
6594 break;
6595 }
6596
6597 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
6598 next = (ffelexHandler) ffeexpr_cb_close_paren_ (orig_ft, expr, orig_t);
6599 ffelex_token_kill (orig_ft);
6600 ffelex_token_kill (orig_t);
6601 return (ffelexHandler) (*next) (t);
6602
6603 case FFELEX_typeOPEN_PAREN:/* Non-binary op; beginning of I/O list. */
6604 case FFELEX_typeNAME:
6605 break;
6606 }
6607
6608 expr = ffeexpr_finished_ambig_ (orig_ft, expr);
6609
6610 /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
6611 that preceded the expression starts a list of expressions, and the expr
6612 hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
6613 node. The callback function should extract the real expr from the head
6614 of this opITEM node after testing it. */
6615
6616 expr = ffebld_new_item (expr, NULL);
6617
6618 ffebld_pool_pop ();
6619 callback = ffeexpr_stack_->callback;
6620 ffelex_token_kill (ffeexpr_stack_->first_token);
6621 s = ffeexpr_stack_->previous;
6622 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
6623 ffeexpr_stack_ = s;
6624 next = (ffelexHandler) (*callback) (orig_ft, expr, orig_t);
6625 ffelex_token_kill (orig_ft);
6626 ffelex_token_kill (orig_t);
6627 return (ffelexHandler) (*next) (t);
6628 }
6629
6630 /* ffeexpr_cb_close_paren_c_ -- OPEN_PAREN expr (possible complex)
6631
6632 Pass it to ffeexpr_rhs as the callback routine.
6633
6634 Makes sure the end token is close-paren and swallows it, or a comma
6635 and handles complex/implied-do possibilities, else issues
6636 an error message and doesn't swallow the token (passing it along instead). */
6637
6638 static ffelexHandler
6639 ffeexpr_cb_close_paren_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
6640 {
6641 /* First check to see if this is a possible complex entity. It is if the
6642 token is a comma. */
6643
6644 if (ffelex_token_type (t) == FFELEX_typeCOMMA)
6645 {
6646 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
6647 ffeexpr_stack_->expr = expr;
6648 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
6649 FFEEXPR_contextPAREN_, ffeexpr_cb_comma_c_);
6650 }
6651
6652 return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
6653 }
6654
6655 /* ffeexpr_cb_comma_c_ -- OPEN_PAREN expr COMMA expr
6656
6657 Pass it to ffeexpr_rhs as the callback routine.
6658
6659 If this token is not a comma, we have a complex constant (or an attempt
6660 at one), so handle it accordingly, displaying error messages if the token
6661 is not a close-paren. */
6662
6663 static ffelexHandler
6664 ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
6665 {
6666 ffeexprExpr_ e;
6667 ffeinfoBasictype lty = (ffeexpr_stack_->expr == NULL)
6668 ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (ffeexpr_stack_->expr));
6669 ffeinfoBasictype rty = (expr == NULL)
6670 ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (expr));
6671 ffeinfoKindtype lkt;
6672 ffeinfoKindtype rkt;
6673 ffeinfoKindtype nkt;
6674 bool ok = TRUE;
6675 ffebld orig;
6676
6677 if ((ffeexpr_stack_->expr == NULL)
6678 || (ffebld_op (ffeexpr_stack_->expr) != FFEBLD_opCONTER)
6679 || (((orig = ffebld_conter_orig (ffeexpr_stack_->expr)) != NULL)
6680 && (((ffebld_op (orig) != FFEBLD_opUMINUS)
6681 && (ffebld_op (orig) != FFEBLD_opUPLUS))
6682 || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
6683 || ((lty != FFEINFO_basictypeINTEGER)
6684 && (lty != FFEINFO_basictypeREAL)))
6685 {
6686 if ((lty != FFEINFO_basictypeANY)
6687 && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
6688 {
6689 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
6690 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
6691 ffebad_string ("Real");
6692 ffebad_finish ();
6693 }
6694 ok = FALSE;
6695 }
6696 if ((expr == NULL)
6697 || (ffebld_op (expr) != FFEBLD_opCONTER)
6698 || (((orig = ffebld_conter_orig (expr)) != NULL)
6699 && (((ffebld_op (orig) != FFEBLD_opUMINUS)
6700 && (ffebld_op (orig) != FFEBLD_opUPLUS))
6701 || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
6702 || ((rty != FFEINFO_basictypeINTEGER)
6703 && (rty != FFEINFO_basictypeREAL)))
6704 {
6705 if ((rty != FFEINFO_basictypeANY)
6706 && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
6707 {
6708 ffebad_here (0, ffelex_token_where_line (ft),
6709 ffelex_token_where_column (ft));
6710 ffebad_string ("Imaginary");
6711 ffebad_finish ();
6712 }
6713 ok = FALSE;
6714 }
6715
6716 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
6717
6718 /* Push the (parenthesized) expression as an operand onto the expression
6719 stack. */
6720
6721 e = ffeexpr_expr_new_ ();
6722 e->type = FFEEXPR_exprtypeOPERAND_;
6723 e->token = ffeexpr_stack_->tokens[0];
6724
6725 if (ok)
6726 {
6727 if (lty == FFEINFO_basictypeINTEGER)
6728 lkt = FFEINFO_kindtypeREALDEFAULT;
6729 else
6730 lkt = ffeinfo_kindtype (ffebld_info (ffeexpr_stack_->expr));
6731 if (rty == FFEINFO_basictypeINTEGER)
6732 rkt = FFEINFO_kindtypeREALDEFAULT;
6733 else
6734 rkt = ffeinfo_kindtype (ffebld_info (expr));
6735
6736 nkt = ffeinfo_kindtype_max (FFEINFO_basictypeCOMPLEX, lkt, rkt);
6737 ffeexpr_stack_->expr = ffeexpr_convert (ffeexpr_stack_->expr,
6738 ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
6739 FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
6740 FFEEXPR_contextLET);
6741 expr = ffeexpr_convert (expr,
6742 ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
6743 FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
6744 FFEEXPR_contextLET);
6745 }
6746 else
6747 nkt = FFEINFO_kindtypeANY;
6748
6749 switch (nkt)
6750 {
6751 #if FFETARGET_okCOMPLEX1
6752 case FFEINFO_kindtypeREAL1:
6753 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex1
6754 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
6755 ffebld_set_info (e->u.operand,
6756 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
6757 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
6758 FFETARGET_charactersizeNONE));
6759 break;
6760 #endif
6761
6762 #if FFETARGET_okCOMPLEX2
6763 case FFEINFO_kindtypeREAL2:
6764 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex2
6765 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
6766 ffebld_set_info (e->u.operand,
6767 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
6768 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
6769 FFETARGET_charactersizeNONE));
6770 break;
6771 #endif
6772
6773 #if FFETARGET_okCOMPLEX3
6774 case FFEINFO_kindtypeREAL3:
6775 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex3
6776 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
6777 ffebld_set_info (e->u.operand,
6778 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
6779 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
6780 FFETARGET_charactersizeNONE));
6781 break;
6782 #endif
6783
6784 default:
6785 if (ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
6786 ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX))
6787 {
6788 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
6789 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
6790 ffebad_finish ();
6791 }
6792 /* Fall through. */
6793 case FFEINFO_kindtypeANY:
6794 e->u.operand = ffebld_new_any ();
6795 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
6796 break;
6797 }
6798 ffeexpr_exprstack_push_operand_ (e);
6799
6800 /* Now, if the token is a close parenthese, we're in great shape so return
6801 the next handler. */
6802
6803 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
6804 return (ffelexHandler) ffeexpr_token_binary_;
6805
6806 /* Oops, naughty user didn't specify the close paren! */
6807
6808 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
6809 {
6810 ffebad_here (0, ffelex_token_where_line (t),
6811 ffelex_token_where_column (t));
6812 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
6813 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
6814 ffebad_finish ();
6815 }
6816
6817 return
6818 (ffelexHandler) ffeexpr_find_close_paren_ (t,
6819 (ffelexHandler)
6820 ffeexpr_token_binary_);
6821 }
6822
6823 /* ffeexpr_cb_close_paren_ci_ -- OPEN_PAREN expr (possible complex or
6824 implied-DO construct)
6825
6826 Pass it to ffeexpr_rhs as the callback routine.
6827
6828 Makes sure the end token is close-paren and swallows it, or a comma
6829 and handles complex/implied-do possibilities, else issues
6830 an error message and doesn't swallow the token (passing it along instead). */
6831
6832 static ffelexHandler
6833 ffeexpr_cb_close_paren_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
6834 {
6835 ffeexprContext ctx;
6836
6837 /* First check to see if this is a possible complex or implied-DO entity.
6838 It is if the token is a comma. */
6839
6840 if (ffelex_token_type (t) == FFELEX_typeCOMMA)
6841 {
6842 switch (ffeexpr_stack_->context)
6843 {
6844 case FFEEXPR_contextIOLIST:
6845 case FFEEXPR_contextIMPDOITEM_:
6846 ctx = FFEEXPR_contextIMPDOITEM_;
6847 break;
6848
6849 case FFEEXPR_contextIOLISTDF:
6850 case FFEEXPR_contextIMPDOITEMDF_:
6851 ctx = FFEEXPR_contextIMPDOITEMDF_;
6852 break;
6853
6854 default:
6855 assert ("bad context" == NULL);
6856 ctx = FFEEXPR_contextIMPDOITEM_;
6857 break;
6858 }
6859
6860 ffeexpr_stack_->tokens[0] = ffelex_token_use (ft);
6861 ffeexpr_stack_->expr = expr;
6862 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
6863 ctx, ffeexpr_cb_comma_ci_);
6864 }
6865
6866 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
6867 return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
6868 }
6869
6870 /* ffeexpr_cb_comma_ci_ -- OPEN_PAREN expr COMMA expr
6871
6872 Pass it to ffeexpr_rhs as the callback routine.
6873
6874 If this token is not a comma, we have a complex constant (or an attempt
6875 at one), so handle it accordingly, displaying error messages if the token
6876 is not a close-paren. If we have a comma here, it is an attempt at an
6877 implied-DO, so start making a list accordingly. Oh, it might be an
6878 equal sign also, meaning an implied-DO with only one item in its list. */
6879
6880 static ffelexHandler
6881 ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
6882 {
6883 ffebld fexpr;
6884
6885 /* First check to see if this is a possible complex constant. It is if the
6886 token is not a comma or an equals sign, in which case it should be a
6887 close-paren. */
6888
6889 if ((ffelex_token_type (t) != FFELEX_typeCOMMA)
6890 && (ffelex_token_type (t) != FFELEX_typeEQUALS))
6891 {
6892 ffeexpr_stack_->tokens[1] = ffeexpr_stack_->tokens[0];
6893 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
6894 return (ffelexHandler) ffeexpr_cb_comma_c_ (ft, expr, t);
6895 }
6896
6897 /* Here we have either EQUALS or COMMA, meaning we are in an implied-DO
6898 construct. Make a list and handle accordingly. */
6899
6900 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
6901 fexpr = ffeexpr_stack_->expr;
6902 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
6903 ffebld_append_item (&ffeexpr_stack_->bottom, fexpr);
6904 return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
6905 }
6906
6907 /* ffeexpr_cb_comma_i_ -- OPEN_PAREN expr
6908
6909 Pass it to ffeexpr_rhs as the callback routine.
6910
6911 Handle first item in an implied-DO construct. */
6912
6913 static ffelexHandler
6914 ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr, ffelexToken t)
6915 {
6916 if (ffelex_token_type (t) != FFELEX_typeCOMMA)
6917 {
6918 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
6919 {
6920 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6921 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
6922 ffelex_token_where_column (ffeexpr_stack_->first_token));
6923 ffebad_finish ();
6924 }
6925 ffebld_end_list (&ffeexpr_stack_->bottom);
6926 ffeexpr_stack_->expr = ffebld_new_any ();
6927 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
6928 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
6929 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
6930 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
6931 }
6932
6933 return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
6934 }
6935
6936 /* ffeexpr_cb_comma_i_1_ -- OPEN_PAREN expr
6937
6938 Pass it to ffeexpr_rhs as the callback routine.
6939
6940 Handle first item in an implied-DO construct. */
6941
6942 static ffelexHandler
6943 ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr, ffelexToken t)
6944 {
6945 ffeexprContext ctxi;
6946 ffeexprContext ctxc;
6947
6948 switch (ffeexpr_stack_->context)
6949 {
6950 case FFEEXPR_contextDATA:
6951 case FFEEXPR_contextDATAIMPDOITEM_:
6952 ctxi = FFEEXPR_contextDATAIMPDOITEM_;
6953 ctxc = FFEEXPR_contextDATAIMPDOCTRL_;
6954 break;
6955
6956 case FFEEXPR_contextIOLIST:
6957 case FFEEXPR_contextIMPDOITEM_:
6958 ctxi = FFEEXPR_contextIMPDOITEM_;
6959 ctxc = FFEEXPR_contextIMPDOCTRL_;
6960 break;
6961
6962 case FFEEXPR_contextIOLISTDF:
6963 case FFEEXPR_contextIMPDOITEMDF_:
6964 ctxi = FFEEXPR_contextIMPDOITEMDF_;
6965 ctxc = FFEEXPR_contextIMPDOCTRL_;
6966 break;
6967
6968 default:
6969 assert ("bad context" == NULL);
6970 ctxi = FFEEXPR_context;
6971 ctxc = FFEEXPR_context;
6972 break;
6973 }
6974
6975 switch (ffelex_token_type (t))
6976 {
6977 case FFELEX_typeCOMMA:
6978 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
6979 if (ffeexpr_stack_->is_rhs)
6980 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
6981 ctxi, ffeexpr_cb_comma_i_1_);
6982 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
6983 ctxi, ffeexpr_cb_comma_i_1_);
6984
6985 case FFELEX_typeEQUALS:
6986 ffebld_end_list (&ffeexpr_stack_->bottom);
6987
6988 /* Complain if implied-DO variable in list of items to be read. */
6989
6990 if ((ctxc == FFEEXPR_contextIMPDOCTRL_) && !ffeexpr_stack_->is_rhs)
6991 ffeexpr_check_impdo_ (ffeexpr_stack_->expr,
6992 ffeexpr_stack_->first_token, expr, ft);
6993
6994 /* Set doiter flag for all appropriate SYMTERs. */
6995
6996 ffeexpr_update_impdo_ (ffeexpr_stack_->expr, expr);
6997
6998 ffeexpr_stack_->expr = ffebld_new_impdo (ffeexpr_stack_->expr, NULL);
6999 ffebld_set_info (ffeexpr_stack_->expr,
7000 ffeinfo_new (FFEINFO_basictypeNONE,
7001 FFEINFO_kindtypeNONE,
7002 0,
7003 FFEINFO_kindNONE,
7004 FFEINFO_whereNONE,
7005 FFETARGET_charactersizeNONE));
7006 ffebld_init_list (&(ffebld_right (ffeexpr_stack_->expr)),
7007 &ffeexpr_stack_->bottom);
7008 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7009 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7010 ctxc, ffeexpr_cb_comma_i_2_);
7011
7012 default:
7013 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7014 {
7015 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7016 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7017 ffelex_token_where_column (ffeexpr_stack_->first_token));
7018 ffebad_finish ();
7019 }
7020 ffebld_end_list (&ffeexpr_stack_->bottom);
7021 ffeexpr_stack_->expr = ffebld_new_any ();
7022 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7023 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7024 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7025 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7026 }
7027 }
7028
7029 /* ffeexpr_cb_comma_i_2_ -- OPEN_PAREN expr-list EQUALS expr
7030
7031 Pass it to ffeexpr_rhs as the callback routine.
7032
7033 Handle start-value in an implied-DO construct. */
7034
7035 static ffelexHandler
7036 ffeexpr_cb_comma_i_2_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7037 {
7038 ffeexprContext ctx;
7039
7040 switch (ffeexpr_stack_->context)
7041 {
7042 case FFEEXPR_contextDATA:
7043 case FFEEXPR_contextDATAIMPDOITEM_:
7044 ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7045 break;
7046
7047 case FFEEXPR_contextIOLIST:
7048 case FFEEXPR_contextIOLISTDF:
7049 case FFEEXPR_contextIMPDOITEM_:
7050 case FFEEXPR_contextIMPDOITEMDF_:
7051 ctx = FFEEXPR_contextIMPDOCTRL_;
7052 break;
7053
7054 default:
7055 assert ("bad context" == NULL);
7056 ctx = FFEEXPR_context;
7057 break;
7058 }
7059
7060 switch (ffelex_token_type (t))
7061 {
7062 case FFELEX_typeCOMMA:
7063 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7064 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7065 ctx, ffeexpr_cb_comma_i_3_);
7066 break;
7067
7068 default:
7069 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7070 {
7071 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7072 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7073 ffelex_token_where_column (ffeexpr_stack_->first_token));
7074 ffebad_finish ();
7075 }
7076 ffebld_end_list (&ffeexpr_stack_->bottom);
7077 ffeexpr_stack_->expr = ffebld_new_any ();
7078 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7079 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7080 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7081 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7082 }
7083 }
7084
7085 /* ffeexpr_cb_comma_i_3_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7086
7087 Pass it to ffeexpr_rhs as the callback routine.
7088
7089 Handle end-value in an implied-DO construct. */
7090
7091 static ffelexHandler
7092 ffeexpr_cb_comma_i_3_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7093 {
7094 ffeexprContext ctx;
7095
7096 switch (ffeexpr_stack_->context)
7097 {
7098 case FFEEXPR_contextDATA:
7099 case FFEEXPR_contextDATAIMPDOITEM_:
7100 ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7101 break;
7102
7103 case FFEEXPR_contextIOLIST:
7104 case FFEEXPR_contextIOLISTDF:
7105 case FFEEXPR_contextIMPDOITEM_:
7106 case FFEEXPR_contextIMPDOITEMDF_:
7107 ctx = FFEEXPR_contextIMPDOCTRL_;
7108 break;
7109
7110 default:
7111 assert ("bad context" == NULL);
7112 ctx = FFEEXPR_context;
7113 break;
7114 }
7115
7116 switch (ffelex_token_type (t))
7117 {
7118 case FFELEX_typeCOMMA:
7119 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7120 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7121 ctx, ffeexpr_cb_comma_i_4_);
7122 break;
7123
7124 case FFELEX_typeCLOSE_PAREN:
7125 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7126 return (ffelexHandler) ffeexpr_cb_comma_i_4_ (NULL, NULL, t);
7127 break;
7128
7129 default:
7130 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7131 {
7132 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7133 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7134 ffelex_token_where_column (ffeexpr_stack_->first_token));
7135 ffebad_finish ();
7136 }
7137 ffebld_end_list (&ffeexpr_stack_->bottom);
7138 ffeexpr_stack_->expr = ffebld_new_any ();
7139 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7140 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7141 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7142 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7143 }
7144 }
7145
7146 /* ffeexpr_cb_comma_i_4_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7147 [COMMA expr]
7148
7149 Pass it to ffeexpr_rhs as the callback routine.
7150
7151 Handle incr-value in an implied-DO construct. */
7152
7153 static ffelexHandler
7154 ffeexpr_cb_comma_i_4_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7155 {
7156 switch (ffelex_token_type (t))
7157 {
7158 case FFELEX_typeCLOSE_PAREN:
7159 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7160 ffebld_end_list (&ffeexpr_stack_->bottom);
7161 {
7162 ffebld item;
7163
7164 for (item = ffebld_left (ffeexpr_stack_->expr);
7165 item != NULL;
7166 item = ffebld_trail (item))
7167 if (ffebld_op (ffebld_head (item)) == FFEBLD_opANY)
7168 goto replace_with_any; /* :::::::::::::::::::: */
7169
7170 for (item = ffebld_right (ffeexpr_stack_->expr);
7171 item != NULL;
7172 item = ffebld_trail (item))
7173 if ((ffebld_head (item) != NULL) /* Increment may be NULL. */
7174 && (ffebld_op (ffebld_head (item)) == FFEBLD_opANY))
7175 goto replace_with_any; /* :::::::::::::::::::: */
7176 }
7177 break;
7178
7179 default:
7180 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7181 {
7182 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7183 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7184 ffelex_token_where_column (ffeexpr_stack_->first_token));
7185 ffebad_finish ();
7186 }
7187 ffebld_end_list (&ffeexpr_stack_->bottom);
7188
7189 replace_with_any: /* :::::::::::::::::::: */
7190
7191 ffeexpr_stack_->expr = ffebld_new_any ();
7192 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7193 break;
7194 }
7195
7196 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7197 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7198 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7199 }
7200
7201 /* ffeexpr_cb_comma_i_5_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7202 [COMMA expr] CLOSE_PAREN
7203
7204 Pass it to ffeexpr_rhs as the callback routine.
7205
7206 Collects token following implied-DO construct for callback function. */
7207
7208 static ffelexHandler
7209 ffeexpr_cb_comma_i_5_ (ffelexToken t)
7210 {
7211 ffeexprCallback callback;
7212 ffeexprStack_ s;
7213 ffelexHandler next;
7214 ffelexToken ft;
7215 ffebld expr;
7216 bool terminate;
7217
7218 switch (ffeexpr_stack_->context)
7219 {
7220 case FFEEXPR_contextDATA:
7221 case FFEEXPR_contextDATAIMPDOITEM_:
7222 terminate = TRUE;
7223 break;
7224
7225 case FFEEXPR_contextIOLIST:
7226 case FFEEXPR_contextIOLISTDF:
7227 case FFEEXPR_contextIMPDOITEM_:
7228 case FFEEXPR_contextIMPDOITEMDF_:
7229 terminate = FALSE;
7230 break;
7231
7232 default:
7233 assert ("bad context" == NULL);
7234 terminate = FALSE;
7235 break;
7236 }
7237
7238 ffebld_pool_pop ();
7239 callback = ffeexpr_stack_->callback;
7240 ft = ffeexpr_stack_->first_token;
7241 expr = ffeexpr_stack_->expr;
7242 s = ffeexpr_stack_->previous;
7243 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
7244 sizeof (*ffeexpr_stack_));
7245 ffeexpr_stack_ = s;
7246 next = (ffelexHandler) (*callback) (ft, expr, t);
7247 ffelex_token_kill (ft);
7248 if (terminate)
7249 {
7250 ffesymbol_drive_sfnames (ffeexpr_check_impctrl_);
7251 --ffeexpr_level_;
7252 if (ffeexpr_level_ == 0)
7253 ffe_terminate_4 ();
7254 }
7255 return (ffelexHandler) next;
7256 }
7257
7258 /* ffeexpr_cb_end_loc_ -- Handle end of %LOC subexpression
7259
7260 Makes sure the end token is close-paren and swallows it, else issues
7261 an error message and doesn't swallow the token (passing it along instead).
7262 In either case wraps up subexpression construction by enclosing the
7263 ffebld expression in a %LOC. */
7264
7265 static ffelexHandler
7266 ffeexpr_cb_end_loc_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7267 {
7268 ffeexprExpr_ e;
7269
7270 /* First push the (%LOC) expression as an operand onto the expression
7271 stack. */
7272
7273 e = ffeexpr_expr_new_ ();
7274 e->type = FFEEXPR_exprtypeOPERAND_;
7275 e->token = ffeexpr_stack_->tokens[0];
7276 e->u.operand = ffebld_new_percent_loc (expr);
7277 ffebld_set_info (e->u.operand,
7278 ffeinfo_new (FFEINFO_basictypeINTEGER,
7279 ffecom_pointer_kind (),
7280 0,
7281 FFEINFO_kindENTITY,
7282 FFEINFO_whereFLEETING,
7283 FFETARGET_charactersizeNONE));
7284 #if 0 /* ~~ */
7285 e->u.operand = ffeexpr_collapse_percent_loc (e->u.operand, ft);
7286 #endif
7287 ffeexpr_exprstack_push_operand_ (e);
7288
7289 /* Now, if the token is a close parenthese, we're in great shape so return
7290 the next handler. */
7291
7292 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7293 {
7294 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7295 return (ffelexHandler) ffeexpr_token_binary_;
7296 }
7297
7298 /* Oops, naughty user didn't specify the close paren! */
7299
7300 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7301 {
7302 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7303 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
7304 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
7305 ffebad_finish ();
7306 }
7307
7308 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7309 return
7310 (ffelexHandler) ffeexpr_find_close_paren_ (t,
7311 (ffelexHandler)
7312 ffeexpr_token_binary_);
7313 }
7314
7315 /* ffeexpr_cb_end_notloc_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
7316
7317 Should be CLOSE_PAREN, and make sure expr isn't a %(VAL,REF,DESCR). */
7318
7319 static ffelexHandler
7320 ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr, ffelexToken t)
7321 {
7322 ffeexprExpr_ e;
7323 ffebldOp op;
7324
7325 /* If expression is itself a %(VAL,REF,DESCR), complain and strip off all
7326 such things until the lowest-level expression is reached. */
7327
7328 op = ffebld_op (expr);
7329 if ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
7330 || (op == FFEBLD_opPERCENT_DESCR))
7331 {
7332 if (ffebad_start (FFEBAD_NESTED_PERCENT))
7333 {
7334 ffebad_here (0, ffelex_token_where_line (ft),
7335 ffelex_token_where_column (ft));
7336 ffebad_finish ();
7337 }
7338
7339 do
7340 {
7341 expr = ffebld_left (expr);
7342 op = ffebld_op (expr);
7343 }
7344 while ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
7345 || (op == FFEBLD_opPERCENT_DESCR));
7346 }
7347
7348 /* Push the expression as an operand onto the expression stack. */
7349
7350 e = ffeexpr_expr_new_ ();
7351 e->type = FFEEXPR_exprtypeOPERAND_;
7352 e->token = ffeexpr_stack_->tokens[0];
7353 switch (ffeexpr_stack_->percent)
7354 {
7355 case FFEEXPR_percentVAL_:
7356 e->u.operand = ffebld_new_percent_val (expr);
7357 break;
7358
7359 case FFEEXPR_percentREF_:
7360 e->u.operand = ffebld_new_percent_ref (expr);
7361 break;
7362
7363 case FFEEXPR_percentDESCR_:
7364 e->u.operand = ffebld_new_percent_descr (expr);
7365 break;
7366
7367 default:
7368 assert ("%lossage" == NULL);
7369 e->u.operand = expr;
7370 break;
7371 }
7372 ffebld_set_info (e->u.operand, ffebld_info (expr));
7373 #if 0 /* ~~ */
7374 e->u.operand = ffeexpr_collapse_percent_ ? ? ? (e->u.operand, ft);
7375 #endif
7376 ffeexpr_exprstack_push_operand_ (e);
7377
7378 /* Now, if the token is a close parenthese, we're in great shape so return
7379 the next handler. */
7380
7381 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7382 return (ffelexHandler) ffeexpr_cb_end_notloc_1_;
7383
7384 /* Oops, naughty user didn't specify the close paren! */
7385
7386 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7387 {
7388 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7389 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
7390 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
7391 ffebad_finish ();
7392 }
7393
7394 ffebld_set_op (e->u.operand, FFEBLD_opPERCENT_LOC);
7395
7396 switch (ffeexpr_stack_->context)
7397 {
7398 case FFEEXPR_contextACTUALARG_:
7399 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
7400 break;
7401
7402 case FFEEXPR_contextINDEXORACTUALARG_:
7403 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
7404 break;
7405
7406 case FFEEXPR_contextSFUNCDEFACTUALARG_:
7407 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
7408 break;
7409
7410 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
7411 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
7412 break;
7413
7414 default:
7415 assert ("bad context?!?!" == NULL);
7416 break;
7417 }
7418
7419 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7420 return
7421 (ffelexHandler) ffeexpr_find_close_paren_ (t,
7422 (ffelexHandler)
7423 ffeexpr_cb_end_notloc_1_);
7424 }
7425
7426 /* ffeexpr_cb_end_notloc_1_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
7427 CLOSE_PAREN
7428
7429 Should be COMMA or CLOSE_PAREN, else change back to %LOC. */
7430
7431 static ffelexHandler
7432 ffeexpr_cb_end_notloc_1_ (ffelexToken t)
7433 {
7434 switch (ffelex_token_type (t))
7435 {
7436 case FFELEX_typeCOMMA:
7437 case FFELEX_typeCLOSE_PAREN:
7438 switch (ffeexpr_stack_->context)
7439 {
7440 case FFEEXPR_contextACTUALARG_:
7441 case FFEEXPR_contextSFUNCDEFACTUALARG_:
7442 break;
7443
7444 case FFEEXPR_contextINDEXORACTUALARG_:
7445 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
7446 break;
7447
7448 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
7449 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
7450 break;
7451
7452 default:
7453 assert ("bad context?!?!" == NULL);
7454 break;
7455 }
7456 break;
7457
7458 default:
7459 if (ffebad_start (FFEBAD_INVALID_PERCENT))
7460 {
7461 ffebad_here (0,
7462 ffelex_token_where_line (ffeexpr_stack_->first_token),
7463 ffelex_token_where_column (ffeexpr_stack_->first_token));
7464 ffebad_string (ffelex_token_text (ffeexpr_stack_->tokens[1]));
7465 ffebad_finish ();
7466 }
7467
7468 ffebld_set_op (ffeexpr_stack_->exprstack->u.operand,
7469 FFEBLD_opPERCENT_LOC);
7470
7471 switch (ffeexpr_stack_->context)
7472 {
7473 case FFEEXPR_contextACTUALARG_:
7474 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
7475 break;
7476
7477 case FFEEXPR_contextINDEXORACTUALARG_:
7478 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
7479 break;
7480
7481 case FFEEXPR_contextSFUNCDEFACTUALARG_:
7482 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
7483 break;
7484
7485 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
7486 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
7487 break;
7488
7489 default:
7490 assert ("bad context?!?!" == NULL);
7491 break;
7492 }
7493 }
7494
7495 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7496 return
7497 (ffelexHandler) ffeexpr_token_binary_ (t);
7498 }
7499
7500 /* Process DATA implied-DO iterator variables as this implied-DO level
7501 terminates. At this point, ffeexpr_level_ == 1 when we see the
7502 last right-paren in "DATA (A(I),I=1,10)/.../". */
7503
7504 static ffesymbol
7505 ffeexpr_check_impctrl_ (ffesymbol s)
7506 {
7507 assert (s != NULL);
7508 assert (ffesymbol_sfdummyparent (s) != NULL);
7509
7510 switch (ffesymbol_state (s))
7511 {
7512 case FFESYMBOL_stateNONE: /* Used as iterator already. Now let symbol
7513 be used as iterator at any level at or
7514 innermore than the outermost of the
7515 current level and the symbol's current
7516 level. */
7517 if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
7518 {
7519 ffesymbol_signal_change (s);
7520 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
7521 ffesymbol_signal_unreported (s);
7522 }
7523 break;
7524
7525 case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO.
7526 Error if at outermost level, else it can
7527 still become an iterator. */
7528 if ((ffeexpr_level_ == 1)
7529 && ffebad_start (FFEBAD_BAD_IMPDCL))
7530 {
7531 ffebad_string (ffesymbol_text (s));
7532 ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
7533 ffebad_finish ();
7534 }
7535 break;
7536
7537 case FFESYMBOL_stateUNCERTAIN: /* Iterator. */
7538 assert (ffeexpr_level_ <= ffesymbol_maxentrynum (s));
7539 ffesymbol_signal_change (s);
7540 ffesymbol_set_state (s, FFESYMBOL_stateNONE);
7541 ffesymbol_signal_unreported (s);
7542 break;
7543
7544 case FFESYMBOL_stateUNDERSTOOD:
7545 break; /* ANY. */
7546
7547 default:
7548 assert ("Sasha Foo!!" == NULL);
7549 break;
7550 }
7551
7552 return s;
7553 }
7554
7555 /* Issue diagnostic if implied-DO variable appears in list of lhs
7556 expressions (as in "READ *, (I,I=1,10)"). */
7557
7558 static void
7559 ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
7560 ffebld dovar, ffelexToken dovar_t)
7561 {
7562 ffebld item;
7563 ffesymbol dovar_sym;
7564 int itemnum;
7565
7566 if (ffebld_op (dovar) != FFEBLD_opSYMTER)
7567 return; /* Presumably opANY. */
7568
7569 dovar_sym = ffebld_symter (dovar);
7570
7571 for (itemnum = 1; list != NULL; list = ffebld_trail (list), ++itemnum)
7572 {
7573 if (((item = ffebld_head (list)) != NULL)
7574 && (ffebld_op (item) == FFEBLD_opSYMTER)
7575 && (ffebld_symter (item) == dovar_sym))
7576 {
7577 char itemno[20];
7578
7579 sprintf (&itemno[0], "%d", itemnum);
7580 if (ffebad_start (FFEBAD_DOITER_IMPDO))
7581 {
7582 ffebad_here (0, ffelex_token_where_line (list_t),
7583 ffelex_token_where_column (list_t));
7584 ffebad_here (1, ffelex_token_where_line (dovar_t),
7585 ffelex_token_where_column (dovar_t));
7586 ffebad_string (ffesymbol_text (dovar_sym));
7587 ffebad_string (itemno);
7588 ffebad_finish ();
7589 }
7590 }
7591 }
7592 }
7593
7594 /* Decorate any SYMTERs referencing the DO variable with the "doiter"
7595 flag. */
7596
7597 static void
7598 ffeexpr_update_impdo_ (ffebld list, ffebld dovar)
7599 {
7600 ffesymbol dovar_sym;
7601
7602 if (ffebld_op (dovar) != FFEBLD_opSYMTER)
7603 return; /* Presumably opANY. */
7604
7605 dovar_sym = ffebld_symter (dovar);
7606
7607 ffeexpr_update_impdo_sym_ (list, dovar_sym); /* Recurse! */
7608 }
7609
7610 /* Recursive function to update any expr so SYMTERs have "doiter" flag
7611 if they refer to the given variable. */
7612
7613 static void
7614 ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar)
7615 {
7616 tail_recurse: /* :::::::::::::::::::: */
7617
7618 if (expr == NULL)
7619 return;
7620
7621 switch (ffebld_op (expr))
7622 {
7623 case FFEBLD_opSYMTER:
7624 if (ffebld_symter (expr) == dovar)
7625 ffebld_symter_set_is_doiter (expr, TRUE);
7626 break;
7627
7628 case FFEBLD_opITEM:
7629 ffeexpr_update_impdo_sym_ (ffebld_head (expr), dovar);
7630 expr = ffebld_trail (expr);
7631 goto tail_recurse; /* :::::::::::::::::::: */
7632
7633 default:
7634 break;
7635 }
7636
7637 switch (ffebld_arity (expr))
7638 {
7639 case 2:
7640 ffeexpr_update_impdo_sym_ (ffebld_left (expr), dovar);
7641 expr = ffebld_right (expr);
7642 goto tail_recurse; /* :::::::::::::::::::: */
7643
7644 case 1:
7645 expr = ffebld_left (expr);
7646 goto tail_recurse; /* :::::::::::::::::::: */
7647
7648 default:
7649 break;
7650 }
7651
7652 return;
7653 }
7654
7655 /* ffeexpr_context_outer_ -- Determine context of stack entry, skipping PARENs
7656
7657 if (ffeexpr_context_outer_(ffeexpr_stack_) == FFEEXPR_contextIF)
7658 // After zero or more PAREN_ contexts, an IF context exists */
7659
7660 static ffeexprContext
7661 ffeexpr_context_outer_ (ffeexprStack_ s)
7662 {
7663 assert (s != NULL);
7664
7665 for (;;)
7666 {
7667 switch (s->context)
7668 {
7669 case FFEEXPR_contextPAREN_:
7670 case FFEEXPR_contextPARENFILENUM_:
7671 case FFEEXPR_contextPARENFILEUNIT_:
7672 break;
7673
7674 default:
7675 return s->context;
7676 }
7677 s = s->previous;
7678 assert (s != NULL);
7679 }
7680 }
7681
7682 /* ffeexpr_percent_ -- Look up name in list of %FOO possibilities
7683
7684 ffeexprPercent_ p;
7685 ffelexToken t;
7686 p = ffeexpr_percent_(t);
7687
7688 Returns the identifier for the name, or the NONE identifier. */
7689
7690 static ffeexprPercent_
7691 ffeexpr_percent_ (ffelexToken t)
7692 {
7693 const char *p;
7694
7695 switch (ffelex_token_length (t))
7696 {
7697 case 3:
7698 switch (*(p = ffelex_token_text (t)))
7699 {
7700 case FFESRC_CASE_MATCH_INIT ('L', 'l', match_3l, no_match_3):
7701 if ((ffesrc_char_match_noninit (*++p, 'O', 'o'))
7702 && (ffesrc_char_match_noninit (*++p, 'C', 'c')))
7703 return FFEEXPR_percentLOC_;
7704 return FFEEXPR_percentNONE_;
7705
7706 case FFESRC_CASE_MATCH_INIT ('R', 'r', match_3r, no_match_3):
7707 if ((ffesrc_char_match_noninit (*++p, 'E', 'e'))
7708 && (ffesrc_char_match_noninit (*++p, 'F', 'f')))
7709 return FFEEXPR_percentREF_;
7710 return FFEEXPR_percentNONE_;
7711
7712 case FFESRC_CASE_MATCH_INIT ('V', 'v', match_3v, no_match_3):
7713 if ((ffesrc_char_match_noninit (*++p, 'A', 'a'))
7714 && (ffesrc_char_match_noninit (*++p, 'L', 'l')))
7715 return FFEEXPR_percentVAL_;
7716 return FFEEXPR_percentNONE_;
7717
7718 default:
7719 no_match_3: /* :::::::::::::::::::: */
7720 return FFEEXPR_percentNONE_;
7721 }
7722
7723 case 5:
7724 if (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "DESCR",
7725 "descr", "Descr") == 0)
7726 return FFEEXPR_percentDESCR_;
7727 return FFEEXPR_percentNONE_;
7728
7729 default:
7730 return FFEEXPR_percentNONE_;
7731 }
7732 }
7733
7734 /* ffeexpr_type_combine -- Binop combine types, check for mythical new COMPLEX
7735
7736 See prototype.
7737
7738 If combining the two basictype/kindtype pairs produces a COMPLEX with an
7739 unsupported kind type, complain and use the default kind type for
7740 COMPLEX. */
7741
7742 void
7743 ffeexpr_type_combine (ffeinfoBasictype *xnbt, ffeinfoKindtype *xnkt,
7744 ffeinfoBasictype lbt, ffeinfoKindtype lkt,
7745 ffeinfoBasictype rbt, ffeinfoKindtype rkt,
7746 ffelexToken t)
7747 {
7748 ffeinfoBasictype nbt;
7749 ffeinfoKindtype nkt;
7750
7751 nbt = ffeinfo_basictype_combine (lbt, rbt);
7752 if ((nbt == FFEINFO_basictypeCOMPLEX)
7753 && ((lbt == nbt) || (lbt == FFEINFO_basictypeREAL))
7754 && ((rbt == nbt) || (rbt == FFEINFO_basictypeREAL)))
7755 {
7756 nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
7757 if (ffe_is_pedantic_not_90 () && (nkt == FFEINFO_kindtypeREALDOUBLE))
7758 nkt = FFEINFO_kindtypeNONE; /* Force error. */
7759 switch (nkt)
7760 {
7761 #if FFETARGET_okCOMPLEX1
7762 case FFEINFO_kindtypeREAL1:
7763 #endif
7764 #if FFETARGET_okCOMPLEX2
7765 case FFEINFO_kindtypeREAL2:
7766 #endif
7767 #if FFETARGET_okCOMPLEX3
7768 case FFEINFO_kindtypeREAL3:
7769 #endif
7770 break; /* Fine and dandy. */
7771
7772 default:
7773 if (t != NULL)
7774 {
7775 ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
7776 ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX);
7777 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7778 ffebad_finish ();
7779 }
7780 nbt = FFEINFO_basictypeNONE;
7781 nkt = FFEINFO_kindtypeNONE;
7782 break;
7783
7784 case FFEINFO_kindtypeANY:
7785 nkt = FFEINFO_kindtypeREALDEFAULT;
7786 break;
7787 }
7788 }
7789 else
7790 { /* The normal stuff. */
7791 if (nbt == lbt)
7792 {
7793 if (nbt == rbt)
7794 nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
7795 else
7796 nkt = lkt;
7797 }
7798 else if (nbt == rbt)
7799 nkt = rkt;
7800 else
7801 { /* Let the caller do the complaining. */
7802 nbt = FFEINFO_basictypeNONE;
7803 nkt = FFEINFO_kindtypeNONE;
7804 }
7805 }
7806
7807 /* Always a good idea to avoid aliasing problems. */
7808
7809 *xnbt = nbt;
7810 *xnkt = nkt;
7811 }
7812
7813 /* ffeexpr_token_first_lhs_ -- First state for lhs expression
7814
7815 Return a pointer to this function to the lexer (ffelex), which will
7816 invoke it for the next token.
7817
7818 Record line and column of first token in expression, then invoke the
7819 initial-state lhs handler. */
7820
7821 static ffelexHandler
7822 ffeexpr_token_first_lhs_ (ffelexToken t)
7823 {
7824 ffeexpr_stack_->first_token = ffelex_token_use (t);
7825
7826 /* When changing the list of valid initial lhs tokens, check whether to
7827 update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
7828 READ (expr) <token> case -- it assumes it knows which tokens <token> can
7829 be to indicate an lhs (or implied DO), which right now is the set
7830 {NAME,OPEN_PAREN}.
7831
7832 This comment also appears in ffeexpr_token_lhs_. */
7833
7834 switch (ffelex_token_type (t))
7835 {
7836 case FFELEX_typeOPEN_PAREN:
7837 switch (ffeexpr_stack_->context)
7838 {
7839 case FFEEXPR_contextDATA:
7840 ffe_init_4 ();
7841 ffeexpr_level_ = 1; /* Level of DATA implied-DO construct. */
7842 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7843 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7844 FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
7845
7846 case FFEEXPR_contextDATAIMPDOITEM_:
7847 ++ffeexpr_level_; /* Level of DATA implied-DO construct. */
7848 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7849 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7850 FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
7851
7852 case FFEEXPR_contextIOLIST:
7853 case FFEEXPR_contextIMPDOITEM_:
7854 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7855 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7856 FFEEXPR_contextIMPDOITEM_, ffeexpr_cb_comma_i_);
7857
7858 case FFEEXPR_contextIOLISTDF:
7859 case FFEEXPR_contextIMPDOITEMDF_:
7860 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7861 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7862 FFEEXPR_contextIMPDOITEMDF_, ffeexpr_cb_comma_i_);
7863
7864 case FFEEXPR_contextFILEEXTFUNC:
7865 assert (ffeexpr_stack_->exprstack == NULL);
7866 return (ffelexHandler) ffeexpr_token_first_lhs_1_;
7867
7868 default:
7869 break;
7870 }
7871 break;
7872
7873 case FFELEX_typeNAME:
7874 switch (ffeexpr_stack_->context)
7875 {
7876 case FFEEXPR_contextFILENAMELIST:
7877 assert (ffeexpr_stack_->exprstack == NULL);
7878 return (ffelexHandler) ffeexpr_token_namelist_;
7879
7880 case FFEEXPR_contextFILEEXTFUNC:
7881 assert (ffeexpr_stack_->exprstack == NULL);
7882 return (ffelexHandler) ffeexpr_token_first_lhs_1_;
7883
7884 default:
7885 break;
7886 }
7887 break;
7888
7889 default:
7890 switch (ffeexpr_stack_->context)
7891 {
7892 case FFEEXPR_contextFILEEXTFUNC:
7893 assert (ffeexpr_stack_->exprstack == NULL);
7894 return (ffelexHandler) ffeexpr_token_first_lhs_1_;
7895
7896 default:
7897 break;
7898 }
7899 break;
7900 }
7901
7902 return (ffelexHandler) ffeexpr_token_lhs_ (t);
7903 }
7904
7905 /* ffeexpr_token_first_lhs_1_ -- NAME
7906
7907 return ffeexpr_token_first_lhs_1_; // to lexer
7908
7909 Handle NAME as an external function (USEROPEN= VXT extension to OPEN
7910 statement). */
7911
7912 static ffelexHandler
7913 ffeexpr_token_first_lhs_1_ (ffelexToken t)
7914 {
7915 ffeexprCallback callback;
7916 ffeexprStack_ s;
7917 ffelexHandler next;
7918 ffelexToken ft;
7919 ffesymbol sy = NULL;
7920 ffebld expr;
7921
7922 ffebld_pool_pop ();
7923 callback = ffeexpr_stack_->callback;
7924 ft = ffeexpr_stack_->first_token;
7925 s = ffeexpr_stack_->previous;
7926
7927 if ((ffelex_token_type (ft) != FFELEX_typeNAME)
7928 || (ffesymbol_attrs (sy = ffeexpr_declare_unadorned_ (ft, FALSE))
7929 & FFESYMBOL_attrANY))
7930 {
7931 if ((ffelex_token_type (ft) != FFELEX_typeNAME)
7932 || !(ffesymbol_attrs (sy) & FFESYMBOL_attrsANY))
7933 {
7934 ffebad_start (FFEBAD_EXPR_WRONG);
7935 ffebad_here (0, ffelex_token_where_line (ft),
7936 ffelex_token_where_column (ft));
7937 ffebad_finish ();
7938 }
7939 expr = ffebld_new_any ();
7940 ffebld_set_info (expr, ffeinfo_new_any ());
7941 }
7942 else
7943 {
7944 expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
7945 FFEINTRIN_impNONE);
7946 ffebld_set_info (expr, ffesymbol_info (sy));
7947 }
7948
7949 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
7950 sizeof (*ffeexpr_stack_));
7951 ffeexpr_stack_ = s;
7952
7953 next = (ffelexHandler) (*callback) (ft, expr, t);
7954 ffelex_token_kill (ft);
7955 return (ffelexHandler) next;
7956 }
7957
7958 /* ffeexpr_token_first_rhs_ -- First state for rhs expression
7959
7960 Record line and column of first token in expression, then invoke the
7961 initial-state rhs handler.
7962
7963 19-Feb-91 JCB 1.1
7964 Allow ASTERISK in PARENFILEUNIT_ case, but only on second level only
7965 (i.e. only as in READ(*), not READ((*))). */
7966
7967 static ffelexHandler
7968 ffeexpr_token_first_rhs_ (ffelexToken t)
7969 {
7970 ffesymbol s;
7971
7972 ffeexpr_stack_->first_token = ffelex_token_use (t);
7973
7974 switch (ffelex_token_type (t))
7975 {
7976 case FFELEX_typeASTERISK:
7977 switch (ffeexpr_stack_->context)
7978 {
7979 case FFEEXPR_contextFILEFORMATNML:
7980 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
7981 /* Fall through. */
7982 case FFEEXPR_contextFILEUNIT:
7983 case FFEEXPR_contextDIMLIST:
7984 case FFEEXPR_contextFILEFORMAT:
7985 case FFEEXPR_contextCHARACTERSIZE:
7986 if (ffeexpr_stack_->previous != NULL)
7987 break; /* Valid only on first level. */
7988 assert (ffeexpr_stack_->exprstack == NULL);
7989 return (ffelexHandler) ffeexpr_token_first_rhs_1_;
7990
7991 case FFEEXPR_contextPARENFILEUNIT_:
7992 if (ffeexpr_stack_->previous->previous != NULL)
7993 break; /* Valid only on second level. */
7994 assert (ffeexpr_stack_->exprstack == NULL);
7995 return (ffelexHandler) ffeexpr_token_first_rhs_1_;
7996
7997 case FFEEXPR_contextACTUALARG_:
7998 if (ffeexpr_stack_->previous->context
7999 != FFEEXPR_contextSUBROUTINEREF)
8000 {
8001 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8002 break;
8003 }
8004 assert (ffeexpr_stack_->exprstack == NULL);
8005 return (ffelexHandler) ffeexpr_token_first_rhs_3_;
8006
8007 case FFEEXPR_contextINDEXORACTUALARG_:
8008 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8009 break;
8010
8011 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8012 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8013 break;
8014
8015 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8016 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8017 break;
8018
8019 default:
8020 break;
8021 }
8022 break;
8023
8024 case FFELEX_typeOPEN_PAREN:
8025 switch (ffeexpr_stack_->context)
8026 {
8027 case FFEEXPR_contextFILENUMAMBIG:
8028 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8029 FFEEXPR_contextPARENFILENUM_,
8030 ffeexpr_cb_close_paren_ambig_);
8031
8032 case FFEEXPR_contextFILEUNITAMBIG:
8033 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8034 FFEEXPR_contextPARENFILEUNIT_,
8035 ffeexpr_cb_close_paren_ambig_);
8036
8037 case FFEEXPR_contextIOLIST:
8038 case FFEEXPR_contextIMPDOITEM_:
8039 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8040 FFEEXPR_contextIMPDOITEM_,
8041 ffeexpr_cb_close_paren_ci_);
8042
8043 case FFEEXPR_contextIOLISTDF:
8044 case FFEEXPR_contextIMPDOITEMDF_:
8045 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8046 FFEEXPR_contextIMPDOITEMDF_,
8047 ffeexpr_cb_close_paren_ci_);
8048
8049 case FFEEXPR_contextFILEFORMATNML:
8050 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8051 break;
8052
8053 case FFEEXPR_contextACTUALARG_:
8054 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8055 break;
8056
8057 case FFEEXPR_contextINDEXORACTUALARG_:
8058 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8059 break;
8060
8061 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8062 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8063 break;
8064
8065 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8066 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8067 break;
8068
8069 default:
8070 break;
8071 }
8072 break;
8073
8074 case FFELEX_typeNUMBER:
8075 switch (ffeexpr_stack_->context)
8076 {
8077 case FFEEXPR_contextFILEFORMATNML:
8078 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8079 /* Fall through. */
8080 case FFEEXPR_contextFILEFORMAT:
8081 if (ffeexpr_stack_->previous != NULL)
8082 break; /* Valid only on first level. */
8083 assert (ffeexpr_stack_->exprstack == NULL);
8084 return (ffelexHandler) ffeexpr_token_first_rhs_2_;
8085
8086 case FFEEXPR_contextACTUALARG_:
8087 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8088 break;
8089
8090 case FFEEXPR_contextINDEXORACTUALARG_:
8091 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8092 break;
8093
8094 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8095 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8096 break;
8097
8098 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8099 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8100 break;
8101
8102 default:
8103 break;
8104 }
8105 break;
8106
8107 case FFELEX_typeNAME:
8108 switch (ffeexpr_stack_->context)
8109 {
8110 case FFEEXPR_contextFILEFORMATNML:
8111 assert (ffeexpr_stack_->exprstack == NULL);
8112 s = ffesymbol_lookup_local (t);
8113 if ((s != NULL) && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST))
8114 return (ffelexHandler) ffeexpr_token_namelist_;
8115 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8116 break;
8117
8118 default:
8119 break;
8120 }
8121 break;
8122
8123 case FFELEX_typePERCENT:
8124 switch (ffeexpr_stack_->context)
8125 {
8126 case FFEEXPR_contextACTUALARG_:
8127 case FFEEXPR_contextINDEXORACTUALARG_:
8128 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8129 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8130 return (ffelexHandler) ffeexpr_token_first_rhs_5_;
8131
8132 case FFEEXPR_contextFILEFORMATNML:
8133 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8134 break;
8135
8136 default:
8137 break;
8138 }
8139
8140 default:
8141 switch (ffeexpr_stack_->context)
8142 {
8143 case FFEEXPR_contextACTUALARG_:
8144 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8145 break;
8146
8147 case FFEEXPR_contextINDEXORACTUALARG_:
8148 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8149 break;
8150
8151 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8152 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8153 break;
8154
8155 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8156 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8157 break;
8158
8159 case FFEEXPR_contextFILEFORMATNML:
8160 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8161 break;
8162
8163 default:
8164 break;
8165 }
8166 break;
8167 }
8168
8169 return (ffelexHandler) ffeexpr_token_rhs_ (t);
8170 }
8171
8172 /* ffeexpr_token_first_rhs_1_ -- ASTERISK
8173
8174 return ffeexpr_token_first_rhs_1_; // to lexer
8175
8176 Return STAR as expression. */
8177
8178 static ffelexHandler
8179 ffeexpr_token_first_rhs_1_ (ffelexToken t)
8180 {
8181 ffebld expr;
8182 ffeexprCallback callback;
8183 ffeexprStack_ s;
8184 ffelexHandler next;
8185 ffelexToken ft;
8186
8187 expr = ffebld_new_star ();
8188 ffebld_pool_pop ();
8189 callback = ffeexpr_stack_->callback;
8190 ft = ffeexpr_stack_->first_token;
8191 s = ffeexpr_stack_->previous;
8192 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
8193 ffeexpr_stack_ = s;
8194 next = (ffelexHandler) (*callback) (ft, expr, t);
8195 ffelex_token_kill (ft);
8196 return (ffelexHandler) next;
8197 }
8198
8199 /* ffeexpr_token_first_rhs_2_ -- NUMBER
8200
8201 return ffeexpr_token_first_rhs_2_; // to lexer
8202
8203 Return NULL as expression; NUMBER as first (and only) token, unless the
8204 current token is not a terminating token, in which case run normal
8205 expression handling. */
8206
8207 static ffelexHandler
8208 ffeexpr_token_first_rhs_2_ (ffelexToken t)
8209 {
8210 ffeexprCallback callback;
8211 ffeexprStack_ s;
8212 ffelexHandler next;
8213 ffelexToken ft;
8214
8215 switch (ffelex_token_type (t))
8216 {
8217 case FFELEX_typeCLOSE_PAREN:
8218 case FFELEX_typeCOMMA:
8219 case FFELEX_typeEOS:
8220 case FFELEX_typeSEMICOLON:
8221 break;
8222
8223 default:
8224 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
8225 return (ffelexHandler) (*next) (t);
8226 }
8227
8228 ffebld_pool_pop ();
8229 callback = ffeexpr_stack_->callback;
8230 ft = ffeexpr_stack_->first_token;
8231 s = ffeexpr_stack_->previous;
8232 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
8233 sizeof (*ffeexpr_stack_));
8234 ffeexpr_stack_ = s;
8235 next = (ffelexHandler) (*callback) (ft, NULL, t);
8236 ffelex_token_kill (ft);
8237 return (ffelexHandler) next;
8238 }
8239
8240 /* ffeexpr_token_first_rhs_3_ -- ASTERISK
8241
8242 return ffeexpr_token_first_rhs_3_; // to lexer
8243
8244 Expect NUMBER, make LABTOK (with copy of token if not inhibited after
8245 confirming, else NULL). */
8246
8247 static ffelexHandler
8248 ffeexpr_token_first_rhs_3_ (ffelexToken t)
8249 {
8250 ffelexHandler next;
8251
8252 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
8253 { /* An error, but let normal processing handle
8254 it. */
8255 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
8256 return (ffelexHandler) (*next) (t);
8257 }
8258
8259 /* Special case: when we see "*10" as an argument to a subroutine
8260 reference, we confirm the current statement and, if not inhibited at
8261 this point, put a copy of the token into a LABTOK node. We do this
8262 instead of just resolving the label directly via ffelab and putting it
8263 into a LABTER simply to improve error reporting and consistency in
8264 ffestc. We put NULL in the LABTOK if we're still inhibited, so ffestb
8265 doesn't have to worry about killing off any tokens when retracting. */
8266
8267 ffest_confirmed ();
8268 if (ffest_is_inhibited ())
8269 ffeexpr_stack_->expr = ffebld_new_labtok (NULL);
8270 else
8271 ffeexpr_stack_->expr = ffebld_new_labtok (ffelex_token_use (t));
8272 ffebld_set_info (ffeexpr_stack_->expr,
8273 ffeinfo_new (FFEINFO_basictypeNONE,
8274 FFEINFO_kindtypeNONE,
8275 0,
8276 FFEINFO_kindNONE,
8277 FFEINFO_whereNONE,
8278 FFETARGET_charactersizeNONE));
8279
8280 return (ffelexHandler) ffeexpr_token_first_rhs_4_;
8281 }
8282
8283 /* ffeexpr_token_first_rhs_4_ -- ASTERISK NUMBER
8284
8285 return ffeexpr_token_first_rhs_4_; // to lexer
8286
8287 Collect/flush appropriate stuff, send token to callback function. */
8288
8289 static ffelexHandler
8290 ffeexpr_token_first_rhs_4_ (ffelexToken t)
8291 {
8292 ffebld expr;
8293 ffeexprCallback callback;
8294 ffeexprStack_ s;
8295 ffelexHandler next;
8296 ffelexToken ft;
8297
8298 expr = ffeexpr_stack_->expr;
8299 ffebld_pool_pop ();
8300 callback = ffeexpr_stack_->callback;
8301 ft = ffeexpr_stack_->first_token;
8302 s = ffeexpr_stack_->previous;
8303 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
8304 ffeexpr_stack_ = s;
8305 next = (ffelexHandler) (*callback) (ft, expr, t);
8306 ffelex_token_kill (ft);
8307 return (ffelexHandler) next;
8308 }
8309
8310 /* ffeexpr_token_first_rhs_5_ -- PERCENT
8311
8312 Should be NAME, or pass through original mechanism. If NAME is LOC,
8313 pass through original mechanism, otherwise must be VAL, REF, or DESCR,
8314 in which case handle the argument (in parentheses), etc. */
8315
8316 static ffelexHandler
8317 ffeexpr_token_first_rhs_5_ (ffelexToken t)
8318 {
8319 ffelexHandler next;
8320
8321 if (ffelex_token_type (t) == FFELEX_typeNAME)
8322 {
8323 ffeexprPercent_ p = ffeexpr_percent_ (t);
8324
8325 switch (p)
8326 {
8327 case FFEEXPR_percentNONE_:
8328 case FFEEXPR_percentLOC_:
8329 break; /* Treat %LOC as any other expression. */
8330
8331 case FFEEXPR_percentVAL_:
8332 case FFEEXPR_percentREF_:
8333 case FFEEXPR_percentDESCR_:
8334 ffeexpr_stack_->percent = p;
8335 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
8336 return (ffelexHandler) ffeexpr_token_first_rhs_6_;
8337
8338 default:
8339 assert ("bad percent?!?" == NULL);
8340 break;
8341 }
8342 }
8343
8344 switch (ffeexpr_stack_->context)
8345 {
8346 case FFEEXPR_contextACTUALARG_:
8347 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8348 break;
8349
8350 case FFEEXPR_contextINDEXORACTUALARG_:
8351 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8352 break;
8353
8354 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8355 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8356 break;
8357
8358 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8359 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8360 break;
8361
8362 default:
8363 assert ("bad context?!?!" == NULL);
8364 break;
8365 }
8366
8367 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
8368 return (ffelexHandler) (*next) (t);
8369 }
8370
8371 /* ffeexpr_token_first_rhs_6_ -- PERCENT NAME(VAL,REF,DESCR)
8372
8373 Should be OPEN_PAREN, or pass through original mechanism. */
8374
8375 static ffelexHandler
8376 ffeexpr_token_first_rhs_6_ (ffelexToken t)
8377 {
8378 ffelexHandler next;
8379 ffelexToken ft;
8380
8381 if (ffelex_token_type (t) == FFELEX_typeOPEN_PAREN)
8382 {
8383 ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
8384 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8385 ffeexpr_stack_->context,
8386 ffeexpr_cb_end_notloc_);
8387 }
8388
8389 switch (ffeexpr_stack_->context)
8390 {
8391 case FFEEXPR_contextACTUALARG_:
8392 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8393 break;
8394
8395 case FFEEXPR_contextINDEXORACTUALARG_:
8396 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8397 break;
8398
8399 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8400 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8401 break;
8402
8403 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8404 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8405 break;
8406
8407 default:
8408 assert ("bad context?!?!" == NULL);
8409 break;
8410 }
8411
8412 ft = ffeexpr_stack_->tokens[0];
8413 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
8414 next = (ffelexHandler) (*next) (ft);
8415 ffelex_token_kill (ft);
8416 return (ffelexHandler) (*next) (t);
8417 }
8418
8419 /* ffeexpr_token_namelist_ -- NAME
8420
8421 return ffeexpr_token_namelist_; // to lexer
8422
8423 Make sure NAME was a valid namelist object, wrap it in a SYMTER and
8424 return. */
8425
8426 static ffelexHandler
8427 ffeexpr_token_namelist_ (ffelexToken t)
8428 {
8429 ffeexprCallback callback;
8430 ffeexprStack_ s;
8431 ffelexHandler next;
8432 ffelexToken ft;
8433 ffesymbol sy;
8434 ffebld expr;
8435
8436 ffebld_pool_pop ();
8437 callback = ffeexpr_stack_->callback;
8438 ft = ffeexpr_stack_->first_token;
8439 s = ffeexpr_stack_->previous;
8440 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
8441 ffeexpr_stack_ = s;
8442
8443 sy = ffesymbol_lookup_local (ft);
8444 if ((sy == NULL) || (ffesymbol_kind (sy) != FFEINFO_kindNAMELIST))
8445 {
8446 ffebad_start (FFEBAD_EXPR_WRONG);
8447 ffebad_here (0, ffelex_token_where_line (ft),
8448 ffelex_token_where_column (ft));
8449 ffebad_finish ();
8450 expr = ffebld_new_any ();
8451 ffebld_set_info (expr, ffeinfo_new_any ());
8452 }
8453 else
8454 {
8455 expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
8456 FFEINTRIN_impNONE);
8457 ffebld_set_info (expr, ffesymbol_info (sy));
8458 }
8459 next = (ffelexHandler) (*callback) (ft, expr, t);
8460 ffelex_token_kill (ft);
8461 return (ffelexHandler) next;
8462 }
8463
8464 /* ffeexpr_expr_kill_ -- Kill an existing internal expression object
8465
8466 ffeexprExpr_ e;
8467 ffeexpr_expr_kill_(e);
8468
8469 Kills the ffewhere info, if necessary, then kills the object. */
8470
8471 static void
8472 ffeexpr_expr_kill_ (ffeexprExpr_ e)
8473 {
8474 if (e->token != NULL)
8475 ffelex_token_kill (e->token);
8476 malloc_kill_ks (ffe_pool_program_unit (), e, sizeof (*e));
8477 }
8478
8479 /* ffeexpr_expr_new_ -- Make a new internal expression object
8480
8481 ffeexprExpr_ e;
8482 e = ffeexpr_expr_new_();
8483
8484 Allocates and initializes a new expression object, returns it. */
8485
8486 static ffeexprExpr_
8487 ffeexpr_expr_new_ (void)
8488 {
8489 ffeexprExpr_ e;
8490
8491 e = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR expr", sizeof (*e));
8492 e->previous = NULL;
8493 e->type = FFEEXPR_exprtypeUNKNOWN_;
8494 e->token = NULL;
8495 return e;
8496 }
8497
8498 /* Verify that call to global is valid, and register whatever
8499 new information about a global might be discoverable by looking
8500 at the call. */
8501
8502 static void
8503 ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t)
8504 {
8505 int n_args;
8506 ffebld list;
8507 ffebld item;
8508 ffesymbol s;
8509
8510 assert ((ffebld_op (*expr) == FFEBLD_opSUBRREF)
8511 || (ffebld_op (*expr) == FFEBLD_opFUNCREF));
8512
8513 if (ffebld_op (ffebld_left (*expr)) != FFEBLD_opSYMTER)
8514 return;
8515
8516 if (ffesymbol_retractable ())
8517 return;
8518
8519 s = ffebld_symter (ffebld_left (*expr));
8520 if (ffesymbol_global (s) == NULL)
8521 return;
8522
8523 for (n_args = 0, list = ffebld_right (*expr);
8524 list != NULL;
8525 list = ffebld_trail (list), ++n_args)
8526 ;
8527
8528 if (ffeglobal_proc_ref_nargs (s, n_args, t))
8529 {
8530 ffeglobalArgSummary as;
8531 ffeinfoBasictype bt;
8532 ffeinfoKindtype kt;
8533 bool array;
8534 bool fail = FALSE;
8535
8536 for (n_args = 0, list = ffebld_right (*expr);
8537 list != NULL;
8538 list = ffebld_trail (list), ++n_args)
8539 {
8540 item = ffebld_head (list);
8541 if (item != NULL)
8542 {
8543 bt = ffeinfo_basictype (ffebld_info (item));
8544 kt = ffeinfo_kindtype (ffebld_info (item));
8545 array = (ffeinfo_rank (ffebld_info (item)) > 0);
8546 switch (ffebld_op (item))
8547 {
8548 case FFEBLD_opLABTOK:
8549 case FFEBLD_opLABTER:
8550 as = FFEGLOBAL_argsummaryALTRTN;
8551 break;
8552
8553 #if 0
8554 /* No, %LOC(foo) is just like any INTEGER(KIND=7)
8555 expression, so don't treat it specially. */
8556 case FFEBLD_opPERCENT_LOC:
8557 as = FFEGLOBAL_argsummaryPTR;
8558 break;
8559 #endif
8560
8561 case FFEBLD_opPERCENT_VAL:
8562 as = FFEGLOBAL_argsummaryVAL;
8563 break;
8564
8565 case FFEBLD_opPERCENT_REF:
8566 as = FFEGLOBAL_argsummaryREF;
8567 break;
8568
8569 case FFEBLD_opPERCENT_DESCR:
8570 as = FFEGLOBAL_argsummaryDESCR;
8571 break;
8572
8573 case FFEBLD_opFUNCREF:
8574 #if 0
8575 /* No, LOC(foo) is just like any INTEGER(KIND=7)
8576 expression, so don't treat it specially. */
8577 if ((ffebld_op (ffebld_left (item)) == FFEBLD_opSYMTER)
8578 && (ffesymbol_specific (ffebld_symter (ffebld_left (item)))
8579 == FFEINTRIN_specLOC))
8580 {
8581 as = FFEGLOBAL_argsummaryPTR;
8582 break;
8583 }
8584 #endif
8585 /* Fall through. */
8586 default:
8587 if (ffebld_op (item) == FFEBLD_opSYMTER)
8588 {
8589 as = FFEGLOBAL_argsummaryNONE;
8590
8591 switch (ffeinfo_kind (ffebld_info (item)))
8592 {
8593 case FFEINFO_kindFUNCTION:
8594 as = FFEGLOBAL_argsummaryFUNC;
8595 break;
8596
8597 case FFEINFO_kindSUBROUTINE:
8598 as = FFEGLOBAL_argsummarySUBR;
8599 break;
8600
8601 case FFEINFO_kindNONE:
8602 as = FFEGLOBAL_argsummaryPROC;
8603 break;
8604
8605 default:
8606 break;
8607 }
8608
8609 if (as != FFEGLOBAL_argsummaryNONE)
8610 break;
8611 }
8612
8613 if (bt == FFEINFO_basictypeCHARACTER)
8614 as = FFEGLOBAL_argsummaryDESCR;
8615 else
8616 as = FFEGLOBAL_argsummaryREF;
8617 break;
8618 }
8619 }
8620 else
8621 {
8622 array = FALSE;
8623 as = FFEGLOBAL_argsummaryNONE;
8624 bt = FFEINFO_basictypeNONE;
8625 kt = FFEINFO_kindtypeNONE;
8626 }
8627
8628 if (! ffeglobal_proc_ref_arg (s, n_args, as, bt, kt, array, t))
8629 fail = TRUE;
8630 }
8631 if (! fail)
8632 return;
8633 }
8634
8635 *expr = ffebld_new_any ();
8636 ffebld_set_info (*expr, ffeinfo_new_any ());
8637 }
8638
8639 /* Check whether rest of string is all decimal digits. */
8640
8641 static bool
8642 ffeexpr_isdigits_ (const char *p)
8643 {
8644 for (; *p != '\0'; ++p)
8645 if (! ISDIGIT (*p))
8646 return FALSE;
8647 return TRUE;
8648 }
8649
8650 /* ffeexpr_exprstack_push_ -- Push an arbitrary expression object onto the stack
8651
8652 ffeexprExpr_ e;
8653 ffeexpr_exprstack_push_(e);
8654
8655 Pushes the expression onto the stack without any analysis of the existing
8656 contents of the stack. */
8657
8658 static void
8659 ffeexpr_exprstack_push_ (ffeexprExpr_ e)
8660 {
8661 e->previous = ffeexpr_stack_->exprstack;
8662 ffeexpr_stack_->exprstack = e;
8663 }
8664
8665 /* ffeexpr_exprstack_push_operand_ -- Push an operand onto the stack, reduce?
8666
8667 ffeexprExpr_ e;
8668 ffeexpr_exprstack_push_operand_(e);
8669
8670 Pushes the expression already containing an operand (a constant, variable,
8671 or more complicated expression that has already been fully resolved) after
8672 analyzing the stack and checking for possible reduction (which will never
8673 happen here since the highest precedence operator is ** and it has right-
8674 to-left associativity). */
8675
8676 static void
8677 ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e)
8678 {
8679 ffeexpr_exprstack_push_ (e);
8680 }
8681
8682 /* ffeexpr_exprstack_push_unary_ -- Push a unary operator onto the stack
8683
8684 ffeexprExpr_ e;
8685 ffeexpr_exprstack_push_unary_(e);
8686
8687 Pushes the expression already containing a unary operator. Reduction can
8688 never happen since unary operators are themselves always R-L; that is, the
8689 top of the expression stack is not an operand, in that it is either empty,
8690 has a binary operator at the top, or a unary operator at the top. In any
8691 of these cases, reduction is impossible. */
8692
8693 static void
8694 ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e)
8695 {
8696 if ((ffe_is_pedantic ()
8697 || ffe_is_warn_surprising ())
8698 && (ffeexpr_stack_->exprstack != NULL)
8699 && (ffeexpr_stack_->exprstack->type != FFEEXPR_exprtypeOPERAND_)
8700 && (ffeexpr_stack_->exprstack->u.operator.prec
8701 <= FFEEXPR_operatorprecedenceLOWARITH_)
8702 && (e->u.operator.prec <= FFEEXPR_operatorprecedenceLOWARITH_))
8703 {
8704 /* xgettext:no-c-format */
8705 ffebad_start_msg ("Two arithmetic operators in a row at %0 and %1 -- use parentheses",
8706 ffe_is_pedantic ()
8707 ? FFEBAD_severityPEDANTIC
8708 : FFEBAD_severityWARNING);
8709 ffebad_here (0,
8710 ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
8711 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
8712 ffebad_here (1,
8713 ffelex_token_where_line (e->token),
8714 ffelex_token_where_column (e->token));
8715 ffebad_finish ();
8716 }
8717
8718 ffeexpr_exprstack_push_ (e);
8719 }
8720
8721 /* ffeexpr_exprstack_push_binary_ -- Push a binary operator onto the stack, reduce?
8722
8723 ffeexprExpr_ e;
8724 ffeexpr_exprstack_push_binary_(e);
8725
8726 Pushes the expression already containing a binary operator after checking
8727 whether reduction is possible. If the stack is not empty, the top of the
8728 stack must be an operand or syntactic analysis has failed somehow. If
8729 the operand is preceded by a unary operator of higher (or equal and L-R
8730 associativity) precedence than the new binary operator, then reduce that
8731 preceding operator and its operand(s) before pushing the new binary
8732 operator. */
8733
8734 static void
8735 ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e)
8736 {
8737 ffeexprExpr_ ce;
8738
8739 if (ffe_is_warn_surprising ()
8740 /* These next two are always true (see assertions below). */
8741 && (ffeexpr_stack_->exprstack != NULL)
8742 && (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_)
8743 /* If the previous operator is a unary minus, and the binary op
8744 is of higher precedence, might not do what user expects,
8745 e.g. "-2**2" is "-(2**2)", i.e. "-4", not "(-2)**2", which would
8746 yield "4". */
8747 && (ffeexpr_stack_->exprstack->previous != NULL)
8748 && (ffeexpr_stack_->exprstack->previous->type == FFEEXPR_exprtypeUNARY_)
8749 && (ffeexpr_stack_->exprstack->previous->u.operator.op
8750 == FFEEXPR_operatorSUBTRACT_)
8751 && (e->u.operator.prec
8752 < ffeexpr_stack_->exprstack->previous->u.operator.prec))
8753 {
8754 /* xgettext:no-c-format */
8755 ffebad_start_msg ("Operator at %0 has lower precedence than that at %1 -- use parentheses", FFEBAD_severityWARNING);
8756 ffebad_here (0,
8757 ffelex_token_where_line (ffeexpr_stack_->exprstack->previous->token),
8758 ffelex_token_where_column (ffeexpr_stack_->exprstack->previous->token));
8759 ffebad_here (1,
8760 ffelex_token_where_line (e->token),
8761 ffelex_token_where_column (e->token));
8762 ffebad_finish ();
8763 }
8764
8765 again:
8766 assert (ffeexpr_stack_->exprstack != NULL);
8767 assert (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_);
8768 if ((ce = ffeexpr_stack_->exprstack->previous) != NULL)
8769 {
8770 assert (ce->type != FFEEXPR_exprtypeOPERAND_);
8771 if ((ce->u.operator.prec < e->u.operator.prec)
8772 || ((ce->u.operator.prec == e->u.operator.prec)
8773 && (e->u.operator.as == FFEEXPR_operatorassociativityL2R_)))
8774 {
8775 ffeexpr_reduce_ ();
8776 goto again; /* :::::::::::::::::::: */
8777 }
8778 }
8779
8780 ffeexpr_exprstack_push_ (e);
8781 }
8782
8783 /* ffeexpr_reduce_ -- Reduce highest operator w/operands on stack
8784
8785 ffeexpr_reduce_();
8786
8787 Converts operand binop operand or unop operand at top of stack to a
8788 single operand having the appropriate ffebld expression, and makes
8789 sure that the expression is proper (like not trying to add two character
8790 variables, not trying to concatenate two numbers). Also does the
8791 requisite type-assignment. */
8792
8793 static void
8794 ffeexpr_reduce_ (void)
8795 {
8796 ffeexprExpr_ operand; /* This is B in -B or A+B. */
8797 ffeexprExpr_ left_operand; /* When operator is binary, this is A in A+B. */
8798 ffeexprExpr_ operator; /* This is + in A+B. */
8799 ffebld reduced; /* This is +(A,B) in A+B or u-(B) in -B. */
8800 ffebldConstant constnode; /* For checking magical numbers (where mag ==
8801 -mag). */
8802 ffebld expr;
8803 ffebld left_expr;
8804 bool submag = FALSE;
8805
8806 operand = ffeexpr_stack_->exprstack;
8807 assert (operand != NULL);
8808 assert (operand->type == FFEEXPR_exprtypeOPERAND_);
8809 operator = operand->previous;
8810 assert (operator != NULL);
8811 assert (operator->type != FFEEXPR_exprtypeOPERAND_);
8812 if (operator->type == FFEEXPR_exprtypeUNARY_)
8813 {
8814 expr = operand->u.operand;
8815 switch (operator->u.operator.op)
8816 {
8817 case FFEEXPR_operatorADD_:
8818 reduced = ffebld_new_uplus (expr);
8819 if (ffe_is_ugly_logint ())
8820 reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
8821 reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
8822 reduced = ffeexpr_collapse_uplus (reduced, operator->token);
8823 break;
8824
8825 case FFEEXPR_operatorSUBTRACT_:
8826 submag = TRUE; /* Ok to negate a magic number. */
8827 reduced = ffebld_new_uminus (expr);
8828 if (ffe_is_ugly_logint ())
8829 reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
8830 reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
8831 reduced = ffeexpr_collapse_uminus (reduced, operator->token);
8832 break;
8833
8834 case FFEEXPR_operatorNOT_:
8835 reduced = ffebld_new_not (expr);
8836 if (ffe_is_ugly_logint ())
8837 reduced = ffeexpr_reduced_ugly1log_ (reduced, operator, operand);
8838 reduced = ffeexpr_reduced_bool1_ (reduced, operator, operand);
8839 reduced = ffeexpr_collapse_not (reduced, operator->token);
8840 break;
8841
8842 default:
8843 assert ("unexpected unary op" != NULL);
8844 reduced = NULL;
8845 break;
8846 }
8847 if (!submag
8848 && (ffebld_op (expr) == FFEBLD_opCONTER)
8849 && (ffebld_conter_orig (expr) == NULL)
8850 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
8851 {
8852 ffetarget_integer_bad_magical (operand->token);
8853 }
8854 ffeexpr_stack_->exprstack = operator->previous; /* Pops unary-op operand
8855 off stack. */
8856 ffeexpr_expr_kill_ (operand);
8857 operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but
8858 save */
8859 operator->u.operand = reduced; /* the line/column ffewhere info. */
8860 ffeexpr_exprstack_push_operand_ (operator); /* Push it back on
8861 stack. */
8862 }
8863 else
8864 {
8865 assert (operator->type == FFEEXPR_exprtypeBINARY_);
8866 left_operand = operator->previous;
8867 assert (left_operand != NULL);
8868 assert (left_operand->type == FFEEXPR_exprtypeOPERAND_);
8869 expr = operand->u.operand;
8870 left_expr = left_operand->u.operand;
8871 switch (operator->u.operator.op)
8872 {
8873 case FFEEXPR_operatorADD_:
8874 reduced = ffebld_new_add (left_expr, expr);
8875 if (ffe_is_ugly_logint ())
8876 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8877 operand);
8878 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
8879 operand);
8880 reduced = ffeexpr_collapse_add (reduced, operator->token);
8881 break;
8882
8883 case FFEEXPR_operatorSUBTRACT_:
8884 submag = TRUE; /* Just to pick the right error if magic
8885 number. */
8886 reduced = ffebld_new_subtract (left_expr, expr);
8887 if (ffe_is_ugly_logint ())
8888 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8889 operand);
8890 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
8891 operand);
8892 reduced = ffeexpr_collapse_subtract (reduced, operator->token);
8893 break;
8894
8895 case FFEEXPR_operatorMULTIPLY_:
8896 reduced = ffebld_new_multiply (left_expr, expr);
8897 if (ffe_is_ugly_logint ())
8898 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8899 operand);
8900 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
8901 operand);
8902 reduced = ffeexpr_collapse_multiply (reduced, operator->token);
8903 break;
8904
8905 case FFEEXPR_operatorDIVIDE_:
8906 reduced = ffebld_new_divide (left_expr, expr);
8907 if (ffe_is_ugly_logint ())
8908 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8909 operand);
8910 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
8911 operand);
8912 reduced = ffeexpr_collapse_divide (reduced, operator->token);
8913 break;
8914
8915 case FFEEXPR_operatorPOWER_:
8916 reduced = ffebld_new_power (left_expr, expr);
8917 if (ffe_is_ugly_logint ())
8918 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8919 operand);
8920 reduced = ffeexpr_reduced_power_ (reduced, left_operand, operator,
8921 operand);
8922 reduced = ffeexpr_collapse_power (reduced, operator->token);
8923 break;
8924
8925 case FFEEXPR_operatorCONCATENATE_:
8926 reduced = ffebld_new_concatenate (left_expr, expr);
8927 reduced = ffeexpr_reduced_concatenate_ (reduced, left_operand, operator,
8928 operand);
8929 reduced = ffeexpr_collapse_concatenate (reduced, operator->token);
8930 break;
8931
8932 case FFEEXPR_operatorLT_:
8933 reduced = ffebld_new_lt (left_expr, expr);
8934 if (ffe_is_ugly_logint ())
8935 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8936 operand);
8937 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
8938 operand);
8939 reduced = ffeexpr_collapse_lt (reduced, operator->token);
8940 break;
8941
8942 case FFEEXPR_operatorLE_:
8943 reduced = ffebld_new_le (left_expr, expr);
8944 if (ffe_is_ugly_logint ())
8945 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8946 operand);
8947 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
8948 operand);
8949 reduced = ffeexpr_collapse_le (reduced, operator->token);
8950 break;
8951
8952 case FFEEXPR_operatorEQ_:
8953 reduced = ffebld_new_eq (left_expr, expr);
8954 if (ffe_is_ugly_logint ())
8955 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8956 operand);
8957 reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
8958 operand);
8959 reduced = ffeexpr_collapse_eq (reduced, operator->token);
8960 break;
8961
8962 case FFEEXPR_operatorNE_:
8963 reduced = ffebld_new_ne (left_expr, expr);
8964 if (ffe_is_ugly_logint ())
8965 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8966 operand);
8967 reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
8968 operand);
8969 reduced = ffeexpr_collapse_ne (reduced, operator->token);
8970 break;
8971
8972 case FFEEXPR_operatorGT_:
8973 reduced = ffebld_new_gt (left_expr, expr);
8974 if (ffe_is_ugly_logint ())
8975 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8976 operand);
8977 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
8978 operand);
8979 reduced = ffeexpr_collapse_gt (reduced, operator->token);
8980 break;
8981
8982 case FFEEXPR_operatorGE_:
8983 reduced = ffebld_new_ge (left_expr, expr);
8984 if (ffe_is_ugly_logint ())
8985 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
8986 operand);
8987 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
8988 operand);
8989 reduced = ffeexpr_collapse_ge (reduced, operator->token);
8990 break;
8991
8992 case FFEEXPR_operatorAND_:
8993 reduced = ffebld_new_and (left_expr, expr);
8994 if (ffe_is_ugly_logint ())
8995 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
8996 operand);
8997 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
8998 operand);
8999 reduced = ffeexpr_collapse_and (reduced, operator->token);
9000 break;
9001
9002 case FFEEXPR_operatorOR_:
9003 reduced = ffebld_new_or (left_expr, expr);
9004 if (ffe_is_ugly_logint ())
9005 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9006 operand);
9007 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9008 operand);
9009 reduced = ffeexpr_collapse_or (reduced, operator->token);
9010 break;
9011
9012 case FFEEXPR_operatorXOR_:
9013 reduced = ffebld_new_xor (left_expr, expr);
9014 if (ffe_is_ugly_logint ())
9015 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9016 operand);
9017 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9018 operand);
9019 reduced = ffeexpr_collapse_xor (reduced, operator->token);
9020 break;
9021
9022 case FFEEXPR_operatorEQV_:
9023 reduced = ffebld_new_eqv (left_expr, expr);
9024 if (ffe_is_ugly_logint ())
9025 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9026 operand);
9027 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9028 operand);
9029 reduced = ffeexpr_collapse_eqv (reduced, operator->token);
9030 break;
9031
9032 case FFEEXPR_operatorNEQV_:
9033 reduced = ffebld_new_neqv (left_expr, expr);
9034 if (ffe_is_ugly_logint ())
9035 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9036 operand);
9037 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9038 operand);
9039 reduced = ffeexpr_collapse_neqv (reduced, operator->token);
9040 break;
9041
9042 default:
9043 assert ("bad bin op" == NULL);
9044 reduced = expr;
9045 break;
9046 }
9047 if ((ffebld_op (left_expr) == FFEBLD_opCONTER)
9048 && (ffebld_conter_orig (expr) == NULL)
9049 && ffebld_constant_is_magical (constnode = ffebld_conter (left_expr)))
9050 {
9051 if ((left_operand->previous != NULL)
9052 && (left_operand->previous->type != FFEEXPR_exprtypeOPERAND_)
9053 && (left_operand->previous->u.operator.op
9054 == FFEEXPR_operatorSUBTRACT_))
9055 {
9056 if (left_operand->previous->type == FFEEXPR_exprtypeUNARY_)
9057 ffetarget_integer_bad_magical_precedence (left_operand->token,
9058 left_operand->previous->token,
9059 operator->token);
9060 else
9061 ffetarget_integer_bad_magical_precedence_binary
9062 (left_operand->token,
9063 left_operand->previous->token,
9064 operator->token);
9065 }
9066 else
9067 ffetarget_integer_bad_magical (left_operand->token);
9068 }
9069 if ((ffebld_op (expr) == FFEBLD_opCONTER)
9070 && (ffebld_conter_orig (expr) == NULL)
9071 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
9072 {
9073 if (submag)
9074 ffetarget_integer_bad_magical_binary (operand->token,
9075 operator->token);
9076 else
9077 ffetarget_integer_bad_magical (operand->token);
9078 }
9079 ffeexpr_stack_->exprstack = left_operand->previous; /* Pops binary-op
9080 operands off stack. */
9081 ffeexpr_expr_kill_ (left_operand);
9082 ffeexpr_expr_kill_ (operand);
9083 operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but
9084 save */
9085 operator->u.operand = reduced; /* the line/column ffewhere info. */
9086 ffeexpr_exprstack_push_operand_ (operator); /* Push it back on
9087 stack. */
9088 }
9089 }
9090
9091 /* ffeexpr_reduced_bool1_ -- Wrap up reduction of NOT operator
9092
9093 reduced = ffeexpr_reduced_bool1_(reduced,op,r);
9094
9095 Makes sure the argument for reduced has basictype of
9096 LOGICAL or (ugly) INTEGER. If
9097 argument has where of CONSTANT, assign where CONSTANT to
9098 reduced, else assign where FLEETING.
9099
9100 If these requirements cannot be met, generate error message. */
9101
9102 static ffebld
9103 ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
9104 {
9105 ffeinfo rinfo, ninfo;
9106 ffeinfoBasictype rbt;
9107 ffeinfoKindtype rkt;
9108 ffeinfoRank rrk;
9109 ffeinfoKind rkd;
9110 ffeinfoWhere rwh, nwh;
9111
9112 rinfo = ffebld_info (ffebld_left (reduced));
9113 rbt = ffeinfo_basictype (rinfo);
9114 rkt = ffeinfo_kindtype (rinfo);
9115 rrk = ffeinfo_rank (rinfo);
9116 rkd = ffeinfo_kind (rinfo);
9117 rwh = ffeinfo_where (rinfo);
9118
9119 if (((rbt == FFEINFO_basictypeLOGICAL)
9120 || (ffe_is_ugly_logint () && (rbt == FFEINFO_basictypeINTEGER)))
9121 && (rrk == 0))
9122 {
9123 switch (rwh)
9124 {
9125 case FFEINFO_whereCONSTANT:
9126 nwh = FFEINFO_whereCONSTANT;
9127 break;
9128
9129 case FFEINFO_whereIMMEDIATE:
9130 nwh = FFEINFO_whereIMMEDIATE;
9131 break;
9132
9133 default:
9134 nwh = FFEINFO_whereFLEETING;
9135 break;
9136 }
9137
9138 ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
9139 FFETARGET_charactersizeNONE);
9140 ffebld_set_info (reduced, ninfo);
9141 return reduced;
9142 }
9143
9144 if ((rbt != FFEINFO_basictypeLOGICAL)
9145 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
9146 {
9147 if ((rbt != FFEINFO_basictypeANY)
9148 && ffebad_start (FFEBAD_NOT_ARG_TYPE))
9149 {
9150 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9151 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9152 ffebad_finish ();
9153 }
9154 }
9155 else
9156 {
9157 if ((rkd != FFEINFO_kindANY)
9158 && ffebad_start (FFEBAD_NOT_ARG_KIND))
9159 {
9160 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9161 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9162 ffebad_string ("an array");
9163 ffebad_finish ();
9164 }
9165 }
9166
9167 reduced = ffebld_new_any ();
9168 ffebld_set_info (reduced, ffeinfo_new_any ());
9169 return reduced;
9170 }
9171
9172 /* ffeexpr_reduced_bool2_ -- Wrap up reduction of boolean operators
9173
9174 reduced = ffeexpr_reduced_bool2_(reduced,l,op,r);
9175
9176 Makes sure the left and right arguments for reduced have basictype of
9177 LOGICAL or (ugly) INTEGER. Determine common basictype and
9178 size for reduction (flag expression for combined hollerith/typeless
9179 situations for later determination of effective basictype). If both left
9180 and right arguments have where of CONSTANT, assign where CONSTANT to
9181 reduced, else assign where FLEETING. Create CONVERT ops for args where
9182 needed. Convert typeless
9183 constants to the desired type/size explicitly.
9184
9185 If these requirements cannot be met, generate error message. */
9186
9187 static ffebld
9188 ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9189 ffeexprExpr_ r)
9190 {
9191 ffeinfo linfo, rinfo, ninfo;
9192 ffeinfoBasictype lbt, rbt, nbt;
9193 ffeinfoKindtype lkt, rkt, nkt;
9194 ffeinfoRank lrk, rrk;
9195 ffeinfoKind lkd, rkd;
9196 ffeinfoWhere lwh, rwh, nwh;
9197
9198 linfo = ffebld_info (ffebld_left (reduced));
9199 lbt = ffeinfo_basictype (linfo);
9200 lkt = ffeinfo_kindtype (linfo);
9201 lrk = ffeinfo_rank (linfo);
9202 lkd = ffeinfo_kind (linfo);
9203 lwh = ffeinfo_where (linfo);
9204
9205 rinfo = ffebld_info (ffebld_right (reduced));
9206 rbt = ffeinfo_basictype (rinfo);
9207 rkt = ffeinfo_kindtype (rinfo);
9208 rrk = ffeinfo_rank (rinfo);
9209 rkd = ffeinfo_kind (rinfo);
9210 rwh = ffeinfo_where (rinfo);
9211
9212 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
9213
9214 if (((nbt == FFEINFO_basictypeLOGICAL)
9215 || (ffe_is_ugly_logint () && (nbt == FFEINFO_basictypeINTEGER)))
9216 && (lrk == 0) && (rrk == 0))
9217 {
9218 switch (lwh)
9219 {
9220 case FFEINFO_whereCONSTANT:
9221 switch (rwh)
9222 {
9223 case FFEINFO_whereCONSTANT:
9224 nwh = FFEINFO_whereCONSTANT;
9225 break;
9226
9227 case FFEINFO_whereIMMEDIATE:
9228 nwh = FFEINFO_whereIMMEDIATE;
9229 break;
9230
9231 default:
9232 nwh = FFEINFO_whereFLEETING;
9233 break;
9234 }
9235 break;
9236
9237 case FFEINFO_whereIMMEDIATE:
9238 switch (rwh)
9239 {
9240 case FFEINFO_whereCONSTANT:
9241 case FFEINFO_whereIMMEDIATE:
9242 nwh = FFEINFO_whereIMMEDIATE;
9243 break;
9244
9245 default:
9246 nwh = FFEINFO_whereFLEETING;
9247 break;
9248 }
9249 break;
9250
9251 default:
9252 nwh = FFEINFO_whereFLEETING;
9253 break;
9254 }
9255
9256 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
9257 FFETARGET_charactersizeNONE);
9258 ffebld_set_info (reduced, ninfo);
9259 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
9260 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
9261 FFEEXPR_contextLET));
9262 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
9263 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
9264 FFEEXPR_contextLET));
9265 return reduced;
9266 }
9267
9268 if ((lbt != FFEINFO_basictypeLOGICAL)
9269 && (!ffe_is_ugly_logint () || (lbt != FFEINFO_basictypeINTEGER)))
9270 {
9271 if ((rbt != FFEINFO_basictypeLOGICAL)
9272 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
9273 {
9274 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
9275 && ffebad_start (FFEBAD_BOOL_ARGS_TYPE))
9276 {
9277 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9278 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9279 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9280 ffebad_finish ();
9281 }
9282 }
9283 else
9284 {
9285 if ((lbt != FFEINFO_basictypeANY)
9286 && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
9287 {
9288 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9289 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9290 ffebad_finish ();
9291 }
9292 }
9293 }
9294 else if ((rbt != FFEINFO_basictypeLOGICAL)
9295 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
9296 {
9297 if ((rbt != FFEINFO_basictypeANY)
9298 && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
9299 {
9300 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9301 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9302 ffebad_finish ();
9303 }
9304 }
9305 else if (lrk != 0)
9306 {
9307 if ((lkd != FFEINFO_kindANY)
9308 && ffebad_start (FFEBAD_BOOL_ARG_KIND))
9309 {
9310 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9311 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9312 ffebad_string ("an array");
9313 ffebad_finish ();
9314 }
9315 }
9316 else
9317 {
9318 if ((rkd != FFEINFO_kindANY)
9319 && ffebad_start (FFEBAD_BOOL_ARG_KIND))
9320 {
9321 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9322 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9323 ffebad_string ("an array");
9324 ffebad_finish ();
9325 }
9326 }
9327
9328 reduced = ffebld_new_any ();
9329 ffebld_set_info (reduced, ffeinfo_new_any ());
9330 return reduced;
9331 }
9332
9333 /* ffeexpr_reduced_concatenate_ -- Wrap up reduction of concatenate operator
9334
9335 reduced = ffeexpr_reduced_concatenate_(reduced,l,op,r);
9336
9337 Makes sure the left and right arguments for reduced have basictype of
9338 CHARACTER and kind of SCALAR, FUNCTION, or STATEMENT FUNCTION. Assign
9339 basictype of CHARACTER and kind of SCALAR to reduced. Calculate effective
9340 size of concatenation and assign that size to reduced. If both left and
9341 right arguments have where of CONSTANT, assign where CONSTANT to reduced,
9342 else assign where FLEETING.
9343
9344 If these requirements cannot be met, generate error message using the
9345 info in l, op, and r arguments and assign basictype, size, kind, and where
9346 of ANY. */
9347
9348 static ffebld
9349 ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9350 ffeexprExpr_ r)
9351 {
9352 ffeinfo linfo, rinfo, ninfo;
9353 ffeinfoBasictype lbt, rbt, nbt;
9354 ffeinfoKindtype lkt, rkt, nkt;
9355 ffeinfoRank lrk, rrk;
9356 ffeinfoKind lkd, rkd, nkd;
9357 ffeinfoWhere lwh, rwh, nwh;
9358 ffetargetCharacterSize lszm, lszk, rszm, rszk, nszk;
9359
9360 linfo = ffebld_info (ffebld_left (reduced));
9361 lbt = ffeinfo_basictype (linfo);
9362 lkt = ffeinfo_kindtype (linfo);
9363 lrk = ffeinfo_rank (linfo);
9364 lkd = ffeinfo_kind (linfo);
9365 lwh = ffeinfo_where (linfo);
9366 lszk = ffeinfo_size (linfo); /* Known size. */
9367 lszm = ffebld_size_max (ffebld_left (reduced));
9368
9369 rinfo = ffebld_info (ffebld_right (reduced));
9370 rbt = ffeinfo_basictype (rinfo);
9371 rkt = ffeinfo_kindtype (rinfo);
9372 rrk = ffeinfo_rank (rinfo);
9373 rkd = ffeinfo_kind (rinfo);
9374 rwh = ffeinfo_where (rinfo);
9375 rszk = ffeinfo_size (rinfo); /* Known size. */
9376 rszm = ffebld_size_max (ffebld_right (reduced));
9377
9378 if ((lbt == FFEINFO_basictypeCHARACTER) && (rbt == FFEINFO_basictypeCHARACTER)
9379 && (lkt == rkt) && (lrk == 0) && (rrk == 0)
9380 && (((lszm != FFETARGET_charactersizeNONE)
9381 && (rszm != FFETARGET_charactersizeNONE))
9382 || (ffeexpr_context_outer_ (ffeexpr_stack_)
9383 == FFEEXPR_contextLET)
9384 || (ffeexpr_context_outer_ (ffeexpr_stack_)
9385 == FFEEXPR_contextSFUNCDEF)))
9386 {
9387 nbt = FFEINFO_basictypeCHARACTER;
9388 nkd = FFEINFO_kindENTITY;
9389 if ((lszk == FFETARGET_charactersizeNONE)
9390 || (rszk == FFETARGET_charactersizeNONE))
9391 nszk = FFETARGET_charactersizeNONE; /* Ok only in rhs of LET
9392 stmt. */
9393 else
9394 nszk = lszk + rszk;
9395
9396 switch (lwh)
9397 {
9398 case FFEINFO_whereCONSTANT:
9399 switch (rwh)
9400 {
9401 case FFEINFO_whereCONSTANT:
9402 nwh = FFEINFO_whereCONSTANT;
9403 break;
9404
9405 case FFEINFO_whereIMMEDIATE:
9406 nwh = FFEINFO_whereIMMEDIATE;
9407 break;
9408
9409 default:
9410 nwh = FFEINFO_whereFLEETING;
9411 break;
9412 }
9413 break;
9414
9415 case FFEINFO_whereIMMEDIATE:
9416 switch (rwh)
9417 {
9418 case FFEINFO_whereCONSTANT:
9419 case FFEINFO_whereIMMEDIATE:
9420 nwh = FFEINFO_whereIMMEDIATE;
9421 break;
9422
9423 default:
9424 nwh = FFEINFO_whereFLEETING;
9425 break;
9426 }
9427 break;
9428
9429 default:
9430 nwh = FFEINFO_whereFLEETING;
9431 break;
9432 }
9433
9434 nkt = lkt;
9435 ninfo = ffeinfo_new (nbt, nkt, 0, nkd, nwh, nszk);
9436 ffebld_set_info (reduced, ninfo);
9437 return reduced;
9438 }
9439
9440 if ((lbt != FFEINFO_basictypeCHARACTER) && (rbt != FFEINFO_basictypeCHARACTER))
9441 {
9442 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
9443 && ffebad_start (FFEBAD_CONCAT_ARGS_TYPE))
9444 {
9445 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9446 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9447 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9448 ffebad_finish ();
9449 }
9450 }
9451 else if (lbt != FFEINFO_basictypeCHARACTER)
9452 {
9453 if ((lbt != FFEINFO_basictypeANY)
9454 && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
9455 {
9456 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9457 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9458 ffebad_finish ();
9459 }
9460 }
9461 else if (rbt != FFEINFO_basictypeCHARACTER)
9462 {
9463 if ((rbt != FFEINFO_basictypeANY)
9464 && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
9465 {
9466 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9467 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9468 ffebad_finish ();
9469 }
9470 }
9471 else if ((lrk != 0) || (lszm == FFETARGET_charactersizeNONE))
9472 {
9473 if ((lkd != FFEINFO_kindANY)
9474 && ffebad_start (FFEBAD_CONCAT_ARG_KIND))
9475 {
9476 const char *what;
9477
9478 if (lrk != 0)
9479 what = "an array";
9480 else
9481 what = "of indeterminate length";
9482 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9483 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9484 ffebad_string (what);
9485 ffebad_finish ();
9486 }
9487 }
9488 else
9489 {
9490 if (ffebad_start (FFEBAD_CONCAT_ARG_KIND))
9491 {
9492 const char *what;
9493
9494 if (rrk != 0)
9495 what = "an array";
9496 else
9497 what = "of indeterminate length";
9498 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9499 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9500 ffebad_string (what);
9501 ffebad_finish ();
9502 }
9503 }
9504
9505 reduced = ffebld_new_any ();
9506 ffebld_set_info (reduced, ffeinfo_new_any ());
9507 return reduced;
9508 }
9509
9510 /* ffeexpr_reduced_eqop2_ -- Wrap up reduction of EQ and NE operators
9511
9512 reduced = ffeexpr_reduced_eqop2_(reduced,l,op,r);
9513
9514 Makes sure the left and right arguments for reduced have basictype of
9515 INTEGER, REAL, COMPLEX, or CHARACTER. Determine common basictype and
9516 size for reduction. If both left
9517 and right arguments have where of CONSTANT, assign where CONSTANT to
9518 reduced, else assign where FLEETING. Create CONVERT ops for args where
9519 needed. Convert typeless
9520 constants to the desired type/size explicitly.
9521
9522 If these requirements cannot be met, generate error message. */
9523
9524 static ffebld
9525 ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9526 ffeexprExpr_ r)
9527 {
9528 ffeinfo linfo, rinfo, ninfo;
9529 ffeinfoBasictype lbt, rbt, nbt;
9530 ffeinfoKindtype lkt, rkt, nkt;
9531 ffeinfoRank lrk, rrk;
9532 ffeinfoKind lkd, rkd;
9533 ffeinfoWhere lwh, rwh, nwh;
9534 ffetargetCharacterSize lsz, rsz;
9535
9536 linfo = ffebld_info (ffebld_left (reduced));
9537 lbt = ffeinfo_basictype (linfo);
9538 lkt = ffeinfo_kindtype (linfo);
9539 lrk = ffeinfo_rank (linfo);
9540 lkd = ffeinfo_kind (linfo);
9541 lwh = ffeinfo_where (linfo);
9542 lsz = ffebld_size_known (ffebld_left (reduced));
9543
9544 rinfo = ffebld_info (ffebld_right (reduced));
9545 rbt = ffeinfo_basictype (rinfo);
9546 rkt = ffeinfo_kindtype (rinfo);
9547 rrk = ffeinfo_rank (rinfo);
9548 rkd = ffeinfo_kind (rinfo);
9549 rwh = ffeinfo_where (rinfo);
9550 rsz = ffebld_size_known (ffebld_right (reduced));
9551
9552 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
9553
9554 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
9555 || (nbt == FFEINFO_basictypeCOMPLEX) || (nbt == FFEINFO_basictypeCHARACTER))
9556 && (lrk == 0) && (rrk == 0))
9557 {
9558 switch (lwh)
9559 {
9560 case FFEINFO_whereCONSTANT:
9561 switch (rwh)
9562 {
9563 case FFEINFO_whereCONSTANT:
9564 nwh = FFEINFO_whereCONSTANT;
9565 break;
9566
9567 case FFEINFO_whereIMMEDIATE:
9568 nwh = FFEINFO_whereIMMEDIATE;
9569 break;
9570
9571 default:
9572 nwh = FFEINFO_whereFLEETING;
9573 break;
9574 }
9575 break;
9576
9577 case FFEINFO_whereIMMEDIATE:
9578 switch (rwh)
9579 {
9580 case FFEINFO_whereCONSTANT:
9581 case FFEINFO_whereIMMEDIATE:
9582 nwh = FFEINFO_whereIMMEDIATE;
9583 break;
9584
9585 default:
9586 nwh = FFEINFO_whereFLEETING;
9587 break;
9588 }
9589 break;
9590
9591 default:
9592 nwh = FFEINFO_whereFLEETING;
9593 break;
9594 }
9595
9596 if ((lsz != FFETARGET_charactersizeNONE)
9597 && (rsz != FFETARGET_charactersizeNONE))
9598 lsz = rsz = (lsz > rsz) ? lsz : rsz;
9599
9600 ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
9601 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
9602 ffebld_set_info (reduced, ninfo);
9603 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
9604 l->token, op->token, nbt, nkt, 0, lsz,
9605 FFEEXPR_contextLET));
9606 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
9607 r->token, op->token, nbt, nkt, 0, rsz,
9608 FFEEXPR_contextLET));
9609 return reduced;
9610 }
9611
9612 if ((lbt == FFEINFO_basictypeLOGICAL)
9613 && (rbt == FFEINFO_basictypeLOGICAL))
9614 {
9615 /* xgettext:no-c-format */
9616 if (ffebad_start_msg ("Use .EQV./.NEQV. instead of .EQ./.NE. at %0 for LOGICAL operands at %1 and %2",
9617 FFEBAD_severityFATAL))
9618 {
9619 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9620 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9621 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9622 ffebad_finish ();
9623 }
9624 }
9625 else if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
9626 && (lbt != FFEINFO_basictypeCOMPLEX) && (lbt != FFEINFO_basictypeCHARACTER))
9627 {
9628 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
9629 && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
9630 {
9631 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
9632 && ffebad_start (FFEBAD_EQOP_ARGS_TYPE))
9633 {
9634 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9635 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9636 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9637 ffebad_finish ();
9638 }
9639 }
9640 else
9641 {
9642 if ((lbt != FFEINFO_basictypeANY)
9643 && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
9644 {
9645 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9646 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9647 ffebad_finish ();
9648 }
9649 }
9650 }
9651 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
9652 && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
9653 {
9654 if ((rbt != FFEINFO_basictypeANY)
9655 && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
9656 {
9657 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9658 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9659 ffebad_finish ();
9660 }
9661 }
9662 else if (lrk != 0)
9663 {
9664 if ((lkd != FFEINFO_kindANY)
9665 && ffebad_start (FFEBAD_EQOP_ARG_KIND))
9666 {
9667 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9668 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9669 ffebad_string ("an array");
9670 ffebad_finish ();
9671 }
9672 }
9673 else
9674 {
9675 if ((rkd != FFEINFO_kindANY)
9676 && ffebad_start (FFEBAD_EQOP_ARG_KIND))
9677 {
9678 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9679 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9680 ffebad_string ("an array");
9681 ffebad_finish ();
9682 }
9683 }
9684
9685 reduced = ffebld_new_any ();
9686 ffebld_set_info (reduced, ffeinfo_new_any ());
9687 return reduced;
9688 }
9689
9690 /* ffeexpr_reduced_math1_ -- Wrap up reduction of + - unary operators
9691
9692 reduced = ffeexpr_reduced_math1_(reduced,op,r);
9693
9694 Makes sure the argument for reduced has basictype of
9695 INTEGER, REAL, or COMPLEX. If the argument has where of CONSTANT,
9696 assign where CONSTANT to
9697 reduced, else assign where FLEETING.
9698
9699 If these requirements cannot be met, generate error message. */
9700
9701 static ffebld
9702 ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
9703 {
9704 ffeinfo rinfo, ninfo;
9705 ffeinfoBasictype rbt;
9706 ffeinfoKindtype rkt;
9707 ffeinfoRank rrk;
9708 ffeinfoKind rkd;
9709 ffeinfoWhere rwh, nwh;
9710
9711 rinfo = ffebld_info (ffebld_left (reduced));
9712 rbt = ffeinfo_basictype (rinfo);
9713 rkt = ffeinfo_kindtype (rinfo);
9714 rrk = ffeinfo_rank (rinfo);
9715 rkd = ffeinfo_kind (rinfo);
9716 rwh = ffeinfo_where (rinfo);
9717
9718 if (((rbt == FFEINFO_basictypeINTEGER) || (rbt == FFEINFO_basictypeREAL)
9719 || (rbt == FFEINFO_basictypeCOMPLEX)) && (rrk == 0))
9720 {
9721 switch (rwh)
9722 {
9723 case FFEINFO_whereCONSTANT:
9724 nwh = FFEINFO_whereCONSTANT;
9725 break;
9726
9727 case FFEINFO_whereIMMEDIATE:
9728 nwh = FFEINFO_whereIMMEDIATE;
9729 break;
9730
9731 default:
9732 nwh = FFEINFO_whereFLEETING;
9733 break;
9734 }
9735
9736 ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
9737 FFETARGET_charactersizeNONE);
9738 ffebld_set_info (reduced, ninfo);
9739 return reduced;
9740 }
9741
9742 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
9743 && (rbt != FFEINFO_basictypeCOMPLEX))
9744 {
9745 if ((rbt != FFEINFO_basictypeANY)
9746 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
9747 {
9748 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9749 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9750 ffebad_finish ();
9751 }
9752 }
9753 else
9754 {
9755 if ((rkd != FFEINFO_kindANY)
9756 && ffebad_start (FFEBAD_MATH_ARG_KIND))
9757 {
9758 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9759 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9760 ffebad_string ("an array");
9761 ffebad_finish ();
9762 }
9763 }
9764
9765 reduced = ffebld_new_any ();
9766 ffebld_set_info (reduced, ffeinfo_new_any ());
9767 return reduced;
9768 }
9769
9770 /* ffeexpr_reduced_math2_ -- Wrap up reduction of + - * / operators
9771
9772 reduced = ffeexpr_reduced_math2_(reduced,l,op,r);
9773
9774 Makes sure the left and right arguments for reduced have basictype of
9775 INTEGER, REAL, or COMPLEX. Determine common basictype and
9776 size for reduction (flag expression for combined hollerith/typeless
9777 situations for later determination of effective basictype). If both left
9778 and right arguments have where of CONSTANT, assign where CONSTANT to
9779 reduced, else assign where FLEETING. Create CONVERT ops for args where
9780 needed. Convert typeless
9781 constants to the desired type/size explicitly.
9782
9783 If these requirements cannot be met, generate error message. */
9784
9785 static ffebld
9786 ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9787 ffeexprExpr_ r)
9788 {
9789 ffeinfo linfo, rinfo, ninfo;
9790 ffeinfoBasictype lbt, rbt, nbt;
9791 ffeinfoKindtype lkt, rkt, nkt;
9792 ffeinfoRank lrk, rrk;
9793 ffeinfoKind lkd, rkd;
9794 ffeinfoWhere lwh, rwh, nwh;
9795
9796 linfo = ffebld_info (ffebld_left (reduced));
9797 lbt = ffeinfo_basictype (linfo);
9798 lkt = ffeinfo_kindtype (linfo);
9799 lrk = ffeinfo_rank (linfo);
9800 lkd = ffeinfo_kind (linfo);
9801 lwh = ffeinfo_where (linfo);
9802
9803 rinfo = ffebld_info (ffebld_right (reduced));
9804 rbt = ffeinfo_basictype (rinfo);
9805 rkt = ffeinfo_kindtype (rinfo);
9806 rrk = ffeinfo_rank (rinfo);
9807 rkd = ffeinfo_kind (rinfo);
9808 rwh = ffeinfo_where (rinfo);
9809
9810 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
9811
9812 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
9813 || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
9814 {
9815 switch (lwh)
9816 {
9817 case FFEINFO_whereCONSTANT:
9818 switch (rwh)
9819 {
9820 case FFEINFO_whereCONSTANT:
9821 nwh = FFEINFO_whereCONSTANT;
9822 break;
9823
9824 case FFEINFO_whereIMMEDIATE:
9825 nwh = FFEINFO_whereIMMEDIATE;
9826 break;
9827
9828 default:
9829 nwh = FFEINFO_whereFLEETING;
9830 break;
9831 }
9832 break;
9833
9834 case FFEINFO_whereIMMEDIATE:
9835 switch (rwh)
9836 {
9837 case FFEINFO_whereCONSTANT:
9838 case FFEINFO_whereIMMEDIATE:
9839 nwh = FFEINFO_whereIMMEDIATE;
9840 break;
9841
9842 default:
9843 nwh = FFEINFO_whereFLEETING;
9844 break;
9845 }
9846 break;
9847
9848 default:
9849 nwh = FFEINFO_whereFLEETING;
9850 break;
9851 }
9852
9853 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
9854 FFETARGET_charactersizeNONE);
9855 ffebld_set_info (reduced, ninfo);
9856 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
9857 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
9858 FFEEXPR_contextLET));
9859 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
9860 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
9861 FFEEXPR_contextLET));
9862 return reduced;
9863 }
9864
9865 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
9866 && (lbt != FFEINFO_basictypeCOMPLEX))
9867 {
9868 if ((rbt != FFEINFO_basictypeINTEGER)
9869 && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
9870 {
9871 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
9872 && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
9873 {
9874 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9875 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9876 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9877 ffebad_finish ();
9878 }
9879 }
9880 else
9881 {
9882 if ((lbt != FFEINFO_basictypeANY)
9883 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
9884 {
9885 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9886 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9887 ffebad_finish ();
9888 }
9889 }
9890 }
9891 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
9892 && (rbt != FFEINFO_basictypeCOMPLEX))
9893 {
9894 if ((rbt != FFEINFO_basictypeANY)
9895 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
9896 {
9897 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9898 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9899 ffebad_finish ();
9900 }
9901 }
9902 else if (lrk != 0)
9903 {
9904 if ((lkd != FFEINFO_kindANY)
9905 && ffebad_start (FFEBAD_MATH_ARG_KIND))
9906 {
9907 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9908 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
9909 ffebad_string ("an array");
9910 ffebad_finish ();
9911 }
9912 }
9913 else
9914 {
9915 if ((rkd != FFEINFO_kindANY)
9916 && ffebad_start (FFEBAD_MATH_ARG_KIND))
9917 {
9918 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
9919 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9920 ffebad_string ("an array");
9921 ffebad_finish ();
9922 }
9923 }
9924
9925 reduced = ffebld_new_any ();
9926 ffebld_set_info (reduced, ffeinfo_new_any ());
9927 return reduced;
9928 }
9929
9930 /* ffeexpr_reduced_power_ -- Wrap up reduction of ** operator
9931
9932 reduced = ffeexpr_reduced_power_(reduced,l,op,r);
9933
9934 Makes sure the left and right arguments for reduced have basictype of
9935 INTEGER, REAL, or COMPLEX. Determine common basictype and
9936 size for reduction (flag expression for combined hollerith/typeless
9937 situations for later determination of effective basictype). If both left
9938 and right arguments have where of CONSTANT, assign where CONSTANT to
9939 reduced, else assign where FLEETING. Create CONVERT ops for args where
9940 needed. Note that real**int or complex**int
9941 comes out as int = real**int etc with no conversions.
9942
9943 If these requirements cannot be met, generate error message using the
9944 info in l, op, and r arguments and assign basictype, size, kind, and where
9945 of ANY. */
9946
9947 static ffebld
9948 ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
9949 ffeexprExpr_ r)
9950 {
9951 ffeinfo linfo, rinfo, ninfo;
9952 ffeinfoBasictype lbt, rbt, nbt;
9953 ffeinfoKindtype lkt, rkt, nkt;
9954 ffeinfoRank lrk, rrk;
9955 ffeinfoKind lkd, rkd;
9956 ffeinfoWhere lwh, rwh, nwh;
9957
9958 linfo = ffebld_info (ffebld_left (reduced));
9959 lbt = ffeinfo_basictype (linfo);
9960 lkt = ffeinfo_kindtype (linfo);
9961 lrk = ffeinfo_rank (linfo);
9962 lkd = ffeinfo_kind (linfo);
9963 lwh = ffeinfo_where (linfo);
9964
9965 rinfo = ffebld_info (ffebld_right (reduced));
9966 rbt = ffeinfo_basictype (rinfo);
9967 rkt = ffeinfo_kindtype (rinfo);
9968 rrk = ffeinfo_rank (rinfo);
9969 rkd = ffeinfo_kind (rinfo);
9970 rwh = ffeinfo_where (rinfo);
9971
9972 if ((rbt == FFEINFO_basictypeINTEGER)
9973 && ((lbt == FFEINFO_basictypeREAL)
9974 || (lbt == FFEINFO_basictypeCOMPLEX)))
9975 {
9976 nbt = lbt;
9977 nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDEFAULT);
9978 if (nkt != FFEINFO_kindtypeREALDEFAULT)
9979 {
9980 nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDOUBLE);
9981 if (nkt != FFEINFO_kindtypeREALDOUBLE)
9982 nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */
9983 }
9984 if (rkt == FFEINFO_kindtypeINTEGER4)
9985 {
9986 /* xgettext:no-c-format */
9987 ffebad_start_msg ("Unsupported operand for ** at %1 -- converting to default INTEGER",
9988 FFEBAD_severityWARNING);
9989 ffebad_here (0, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
9990 ffebad_finish ();
9991 }
9992 if (rkt != FFEINFO_kindtypeINTEGERDEFAULT)
9993 {
9994 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
9995 r->token, op->token,
9996 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0,
9997 FFETARGET_charactersizeNONE,
9998 FFEEXPR_contextLET));
9999 rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10000 }
10001 }
10002 else
10003 {
10004 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10005
10006 #if 0 /* INTEGER4**INTEGER4 works now. */
10007 if ((nbt == FFEINFO_basictypeINTEGER)
10008 && (nkt != FFEINFO_kindtypeINTEGERDEFAULT))
10009 nkt = FFEINFO_kindtypeINTEGERDEFAULT; /* Highest kt we can power! */
10010 #endif
10011 if (((nbt == FFEINFO_basictypeREAL)
10012 || (nbt == FFEINFO_basictypeCOMPLEX))
10013 && (nkt != FFEINFO_kindtypeREALDEFAULT))
10014 {
10015 nkt = ffeinfo_kindtype_max (nbt, nkt, FFEINFO_kindtypeREALDOUBLE);
10016 if (nkt != FFEINFO_kindtypeREALDOUBLE)
10017 nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */
10018 }
10019 /* else Gonna turn into an error below. */
10020 }
10021
10022 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10023 || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
10024 {
10025 switch (lwh)
10026 {
10027 case FFEINFO_whereCONSTANT:
10028 switch (rwh)
10029 {
10030 case FFEINFO_whereCONSTANT:
10031 nwh = FFEINFO_whereCONSTANT;
10032 break;
10033
10034 case FFEINFO_whereIMMEDIATE:
10035 nwh = FFEINFO_whereIMMEDIATE;
10036 break;
10037
10038 default:
10039 nwh = FFEINFO_whereFLEETING;
10040 break;
10041 }
10042 break;
10043
10044 case FFEINFO_whereIMMEDIATE:
10045 switch (rwh)
10046 {
10047 case FFEINFO_whereCONSTANT:
10048 case FFEINFO_whereIMMEDIATE:
10049 nwh = FFEINFO_whereIMMEDIATE;
10050 break;
10051
10052 default:
10053 nwh = FFEINFO_whereFLEETING;
10054 break;
10055 }
10056 break;
10057
10058 default:
10059 nwh = FFEINFO_whereFLEETING;
10060 break;
10061 }
10062
10063 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10064 FFETARGET_charactersizeNONE);
10065 ffebld_set_info (reduced, ninfo);
10066 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10067 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10068 FFEEXPR_contextLET));
10069 if (rbt != FFEINFO_basictypeINTEGER)
10070 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10071 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10072 FFEEXPR_contextLET));
10073 return reduced;
10074 }
10075
10076 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10077 && (lbt != FFEINFO_basictypeCOMPLEX))
10078 {
10079 if ((rbt != FFEINFO_basictypeINTEGER)
10080 && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
10081 {
10082 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10083 && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
10084 {
10085 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10086 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10087 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10088 ffebad_finish ();
10089 }
10090 }
10091 else
10092 {
10093 if ((lbt != FFEINFO_basictypeANY)
10094 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10095 {
10096 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10097 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10098 ffebad_finish ();
10099 }
10100 }
10101 }
10102 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10103 && (rbt != FFEINFO_basictypeCOMPLEX))
10104 {
10105 if ((rbt != FFEINFO_basictypeANY)
10106 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10107 {
10108 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10109 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10110 ffebad_finish ();
10111 }
10112 }
10113 else if (lrk != 0)
10114 {
10115 if ((lkd != FFEINFO_kindANY)
10116 && ffebad_start (FFEBAD_MATH_ARG_KIND))
10117 {
10118 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10119 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10120 ffebad_string ("an array");
10121 ffebad_finish ();
10122 }
10123 }
10124 else
10125 {
10126 if ((rkd != FFEINFO_kindANY)
10127 && ffebad_start (FFEBAD_MATH_ARG_KIND))
10128 {
10129 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10130 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10131 ffebad_string ("an array");
10132 ffebad_finish ();
10133 }
10134 }
10135
10136 reduced = ffebld_new_any ();
10137 ffebld_set_info (reduced, ffeinfo_new_any ());
10138 return reduced;
10139 }
10140
10141 /* ffeexpr_reduced_relop2_ -- Wrap up reduction of LT, LE, GE, and GT operators
10142
10143 reduced = ffeexpr_reduced_relop2_(reduced,l,op,r);
10144
10145 Makes sure the left and right arguments for reduced have basictype of
10146 INTEGER, REAL, or CHARACTER. Determine common basictype and
10147 size for reduction. If both left
10148 and right arguments have where of CONSTANT, assign where CONSTANT to
10149 reduced, else assign where FLEETING. Create CONVERT ops for args where
10150 needed. Convert typeless
10151 constants to the desired type/size explicitly.
10152
10153 If these requirements cannot be met, generate error message. */
10154
10155 static ffebld
10156 ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10157 ffeexprExpr_ r)
10158 {
10159 ffeinfo linfo, rinfo, ninfo;
10160 ffeinfoBasictype lbt, rbt, nbt;
10161 ffeinfoKindtype lkt, rkt, nkt;
10162 ffeinfoRank lrk, rrk;
10163 ffeinfoKind lkd, rkd;
10164 ffeinfoWhere lwh, rwh, nwh;
10165 ffetargetCharacterSize lsz, rsz;
10166
10167 linfo = ffebld_info (ffebld_left (reduced));
10168 lbt = ffeinfo_basictype (linfo);
10169 lkt = ffeinfo_kindtype (linfo);
10170 lrk = ffeinfo_rank (linfo);
10171 lkd = ffeinfo_kind (linfo);
10172 lwh = ffeinfo_where (linfo);
10173 lsz = ffebld_size_known (ffebld_left (reduced));
10174
10175 rinfo = ffebld_info (ffebld_right (reduced));
10176 rbt = ffeinfo_basictype (rinfo);
10177 rkt = ffeinfo_kindtype (rinfo);
10178 rrk = ffeinfo_rank (rinfo);
10179 rkd = ffeinfo_kind (rinfo);
10180 rwh = ffeinfo_where (rinfo);
10181 rsz = ffebld_size_known (ffebld_right (reduced));
10182
10183 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10184
10185 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10186 || (nbt == FFEINFO_basictypeCHARACTER))
10187 && (lrk == 0) && (rrk == 0))
10188 {
10189 switch (lwh)
10190 {
10191 case FFEINFO_whereCONSTANT:
10192 switch (rwh)
10193 {
10194 case FFEINFO_whereCONSTANT:
10195 nwh = FFEINFO_whereCONSTANT;
10196 break;
10197
10198 case FFEINFO_whereIMMEDIATE:
10199 nwh = FFEINFO_whereIMMEDIATE;
10200 break;
10201
10202 default:
10203 nwh = FFEINFO_whereFLEETING;
10204 break;
10205 }
10206 break;
10207
10208 case FFEINFO_whereIMMEDIATE:
10209 switch (rwh)
10210 {
10211 case FFEINFO_whereCONSTANT:
10212 case FFEINFO_whereIMMEDIATE:
10213 nwh = FFEINFO_whereIMMEDIATE;
10214 break;
10215
10216 default:
10217 nwh = FFEINFO_whereFLEETING;
10218 break;
10219 }
10220 break;
10221
10222 default:
10223 nwh = FFEINFO_whereFLEETING;
10224 break;
10225 }
10226
10227 if ((lsz != FFETARGET_charactersizeNONE)
10228 && (rsz != FFETARGET_charactersizeNONE))
10229 lsz = rsz = (lsz > rsz) ? lsz : rsz;
10230
10231 ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
10232 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
10233 ffebld_set_info (reduced, ninfo);
10234 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10235 l->token, op->token, nbt, nkt, 0, lsz,
10236 FFEEXPR_contextLET));
10237 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10238 r->token, op->token, nbt, nkt, 0, rsz,
10239 FFEEXPR_contextLET));
10240 return reduced;
10241 }
10242
10243 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10244 && (lbt != FFEINFO_basictypeCHARACTER))
10245 {
10246 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10247 && (rbt != FFEINFO_basictypeCHARACTER))
10248 {
10249 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10250 && ffebad_start (FFEBAD_RELOP_ARGS_TYPE))
10251 {
10252 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10253 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10254 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10255 ffebad_finish ();
10256 }
10257 }
10258 else
10259 {
10260 if ((lbt != FFEINFO_basictypeANY)
10261 && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
10262 {
10263 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10264 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10265 ffebad_finish ();
10266 }
10267 }
10268 }
10269 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10270 && (rbt != FFEINFO_basictypeCHARACTER))
10271 {
10272 if ((rbt != FFEINFO_basictypeANY)
10273 && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
10274 {
10275 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10276 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10277 ffebad_finish ();
10278 }
10279 }
10280 else if (lrk != 0)
10281 {
10282 if ((lkd != FFEINFO_kindANY)
10283 && ffebad_start (FFEBAD_RELOP_ARG_KIND))
10284 {
10285 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10286 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10287 ffebad_string ("an array");
10288 ffebad_finish ();
10289 }
10290 }
10291 else
10292 {
10293 if ((rkd != FFEINFO_kindANY)
10294 && ffebad_start (FFEBAD_RELOP_ARG_KIND))
10295 {
10296 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10297 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10298 ffebad_string ("an array");
10299 ffebad_finish ();
10300 }
10301 }
10302
10303 reduced = ffebld_new_any ();
10304 ffebld_set_info (reduced, ffeinfo_new_any ());
10305 return reduced;
10306 }
10307
10308 /* ffeexpr_reduced_ugly1_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
10309
10310 reduced = ffeexpr_reduced_ugly1_(reduced,op,r);
10311
10312 Sigh. */
10313
10314 static ffebld
10315 ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10316 {
10317 ffeinfo rinfo;
10318 ffeinfoBasictype rbt;
10319 ffeinfoKindtype rkt;
10320 ffeinfoRank rrk;
10321 ffeinfoKind rkd;
10322 ffeinfoWhere rwh;
10323
10324 rinfo = ffebld_info (ffebld_left (reduced));
10325 rbt = ffeinfo_basictype (rinfo);
10326 rkt = ffeinfo_kindtype (rinfo);
10327 rrk = ffeinfo_rank (rinfo);
10328 rkd = ffeinfo_kind (rinfo);
10329 rwh = ffeinfo_where (rinfo);
10330
10331 if ((rbt == FFEINFO_basictypeTYPELESS)
10332 || (rbt == FFEINFO_basictypeHOLLERITH))
10333 {
10334 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10335 r->token, op->token, FFEINFO_basictypeINTEGER,
10336 FFEINFO_kindtypeINTEGERDEFAULT, 0,
10337 FFETARGET_charactersizeNONE,
10338 FFEEXPR_contextLET));
10339 rinfo = ffebld_info (ffebld_left (reduced));
10340 rbt = FFEINFO_basictypeINTEGER;
10341 rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10342 rrk = 0;
10343 rkd = FFEINFO_kindENTITY;
10344 rwh = ffeinfo_where (rinfo);
10345 }
10346
10347 if (rbt == FFEINFO_basictypeLOGICAL)
10348 {
10349 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10350 r->token, op->token, FFEINFO_basictypeINTEGER,
10351 FFEINFO_kindtypeINTEGERDEFAULT, 0,
10352 FFETARGET_charactersizeNONE,
10353 FFEEXPR_contextLET));
10354 }
10355
10356 return reduced;
10357 }
10358
10359 /* ffeexpr_reduced_ugly1log_ -- Deal with TYPELESS and HOLLERITH
10360
10361 reduced = ffeexpr_reduced_ugly1log_(reduced,op,r);
10362
10363 Sigh. */
10364
10365 static ffebld
10366 ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10367 {
10368 ffeinfo rinfo;
10369 ffeinfoBasictype rbt;
10370 ffeinfoKindtype rkt;
10371 ffeinfoRank rrk;
10372 ffeinfoKind rkd;
10373 ffeinfoWhere rwh;
10374
10375 rinfo = ffebld_info (ffebld_left (reduced));
10376 rbt = ffeinfo_basictype (rinfo);
10377 rkt = ffeinfo_kindtype (rinfo);
10378 rrk = ffeinfo_rank (rinfo);
10379 rkd = ffeinfo_kind (rinfo);
10380 rwh = ffeinfo_where (rinfo);
10381
10382 if ((rbt == FFEINFO_basictypeTYPELESS)
10383 || (rbt == FFEINFO_basictypeHOLLERITH))
10384 {
10385 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10386 r->token, op->token, FFEINFO_basictypeLOGICAL, 0,
10387 FFEINFO_kindtypeLOGICALDEFAULT,
10388 FFETARGET_charactersizeNONE,
10389 FFEEXPR_contextLET));
10390 rinfo = ffebld_info (ffebld_left (reduced));
10391 rbt = FFEINFO_basictypeLOGICAL;
10392 rkt = FFEINFO_kindtypeLOGICALDEFAULT;
10393 rrk = 0;
10394 rkd = FFEINFO_kindENTITY;
10395 rwh = ffeinfo_where (rinfo);
10396 }
10397
10398 return reduced;
10399 }
10400
10401 /* ffeexpr_reduced_ugly2_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
10402
10403 reduced = ffeexpr_reduced_ugly2_(reduced,l,op,r);
10404
10405 Sigh. */
10406
10407 static ffebld
10408 ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10409 ffeexprExpr_ r)
10410 {
10411 ffeinfo linfo, rinfo;
10412 ffeinfoBasictype lbt, rbt;
10413 ffeinfoKindtype lkt, rkt;
10414 ffeinfoRank lrk, rrk;
10415 ffeinfoKind lkd, rkd;
10416 ffeinfoWhere lwh, rwh;
10417
10418 linfo = ffebld_info (ffebld_left (reduced));
10419 lbt = ffeinfo_basictype (linfo);
10420 lkt = ffeinfo_kindtype (linfo);
10421 lrk = ffeinfo_rank (linfo);
10422 lkd = ffeinfo_kind (linfo);
10423 lwh = ffeinfo_where (linfo);
10424
10425 rinfo = ffebld_info (ffebld_right (reduced));
10426 rbt = ffeinfo_basictype (rinfo);
10427 rkt = ffeinfo_kindtype (rinfo);
10428 rrk = ffeinfo_rank (rinfo);
10429 rkd = ffeinfo_kind (rinfo);
10430 rwh = ffeinfo_where (rinfo);
10431
10432 if ((lbt == FFEINFO_basictypeTYPELESS)
10433 || (lbt == FFEINFO_basictypeHOLLERITH))
10434 {
10435 if ((rbt == FFEINFO_basictypeTYPELESS)
10436 || (rbt == FFEINFO_basictypeHOLLERITH))
10437 {
10438 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10439 l->token, op->token, FFEINFO_basictypeINTEGER,
10440 FFEINFO_kindtypeINTEGERDEFAULT, 0,
10441 FFETARGET_charactersizeNONE,
10442 FFEEXPR_contextLET));
10443 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10444 r->token, op->token, FFEINFO_basictypeINTEGER, 0,
10445 FFEINFO_kindtypeINTEGERDEFAULT,
10446 FFETARGET_charactersizeNONE,
10447 FFEEXPR_contextLET));
10448 linfo = ffebld_info (ffebld_left (reduced));
10449 rinfo = ffebld_info (ffebld_right (reduced));
10450 lbt = rbt = FFEINFO_basictypeINTEGER;
10451 lkt = rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10452 lrk = rrk = 0;
10453 lkd = rkd = FFEINFO_kindENTITY;
10454 lwh = ffeinfo_where (linfo);
10455 rwh = ffeinfo_where (rinfo);
10456 }
10457 else
10458 {
10459 ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
10460 l->token, ffebld_right (reduced), r->token,
10461 FFEEXPR_contextLET));
10462 linfo = ffebld_info (ffebld_left (reduced));
10463 lbt = ffeinfo_basictype (linfo);
10464 lkt = ffeinfo_kindtype (linfo);
10465 lrk = ffeinfo_rank (linfo);
10466 lkd = ffeinfo_kind (linfo);
10467 lwh = ffeinfo_where (linfo);
10468 }
10469 }
10470 else
10471 {
10472 if ((rbt == FFEINFO_basictypeTYPELESS)
10473 || (rbt == FFEINFO_basictypeHOLLERITH))
10474 {
10475 ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
10476 r->token, ffebld_left (reduced), l->token,
10477 FFEEXPR_contextLET));
10478 rinfo = ffebld_info (ffebld_right (reduced));
10479 rbt = ffeinfo_basictype (rinfo);
10480 rkt = ffeinfo_kindtype (rinfo);
10481 rrk = ffeinfo_rank (rinfo);
10482 rkd = ffeinfo_kind (rinfo);
10483 rwh = ffeinfo_where (rinfo);
10484 }
10485 /* else Leave it alone. */
10486 }
10487
10488 if (lbt == FFEINFO_basictypeLOGICAL)
10489 {
10490 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10491 l->token, op->token, FFEINFO_basictypeINTEGER,
10492 FFEINFO_kindtypeINTEGERDEFAULT, 0,
10493 FFETARGET_charactersizeNONE,
10494 FFEEXPR_contextLET));
10495 }
10496
10497 if (rbt == FFEINFO_basictypeLOGICAL)
10498 {
10499 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10500 r->token, op->token, FFEINFO_basictypeINTEGER,
10501 FFEINFO_kindtypeINTEGERDEFAULT, 0,
10502 FFETARGET_charactersizeNONE,
10503 FFEEXPR_contextLET));
10504 }
10505
10506 return reduced;
10507 }
10508
10509 /* ffeexpr_reduced_ugly2log_ -- Deal with TYPELESS and HOLLERITH
10510
10511 reduced = ffeexpr_reduced_ugly2log_(reduced,l,op,r);
10512
10513 Sigh. */
10514
10515 static ffebld
10516 ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10517 ffeexprExpr_ r)
10518 {
10519 ffeinfo linfo, rinfo;
10520 ffeinfoBasictype lbt, rbt;
10521 ffeinfoKindtype lkt, rkt;
10522 ffeinfoRank lrk, rrk;
10523 ffeinfoKind lkd, rkd;
10524 ffeinfoWhere lwh, rwh;
10525
10526 linfo = ffebld_info (ffebld_left (reduced));
10527 lbt = ffeinfo_basictype (linfo);
10528 lkt = ffeinfo_kindtype (linfo);
10529 lrk = ffeinfo_rank (linfo);
10530 lkd = ffeinfo_kind (linfo);
10531 lwh = ffeinfo_where (linfo);
10532
10533 rinfo = ffebld_info (ffebld_right (reduced));
10534 rbt = ffeinfo_basictype (rinfo);
10535 rkt = ffeinfo_kindtype (rinfo);
10536 rrk = ffeinfo_rank (rinfo);
10537 rkd = ffeinfo_kind (rinfo);
10538 rwh = ffeinfo_where (rinfo);
10539
10540 if ((lbt == FFEINFO_basictypeTYPELESS)
10541 || (lbt == FFEINFO_basictypeHOLLERITH))
10542 {
10543 if ((rbt == FFEINFO_basictypeTYPELESS)
10544 || (rbt == FFEINFO_basictypeHOLLERITH))
10545 {
10546 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10547 l->token, op->token, FFEINFO_basictypeLOGICAL,
10548 FFEINFO_kindtypeLOGICALDEFAULT, 0,
10549 FFETARGET_charactersizeNONE,
10550 FFEEXPR_contextLET));
10551 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10552 r->token, op->token, FFEINFO_basictypeLOGICAL,
10553 FFEINFO_kindtypeLOGICALDEFAULT, 0,
10554 FFETARGET_charactersizeNONE,
10555 FFEEXPR_contextLET));
10556 linfo = ffebld_info (ffebld_left (reduced));
10557 rinfo = ffebld_info (ffebld_right (reduced));
10558 lbt = rbt = FFEINFO_basictypeLOGICAL;
10559 lkt = rkt = FFEINFO_kindtypeLOGICALDEFAULT;
10560 lrk = rrk = 0;
10561 lkd = rkd = FFEINFO_kindENTITY;
10562 lwh = ffeinfo_where (linfo);
10563 rwh = ffeinfo_where (rinfo);
10564 }
10565 else
10566 {
10567 ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
10568 l->token, ffebld_right (reduced), r->token,
10569 FFEEXPR_contextLET));
10570 linfo = ffebld_info (ffebld_left (reduced));
10571 lbt = ffeinfo_basictype (linfo);
10572 lkt = ffeinfo_kindtype (linfo);
10573 lrk = ffeinfo_rank (linfo);
10574 lkd = ffeinfo_kind (linfo);
10575 lwh = ffeinfo_where (linfo);
10576 }
10577 }
10578 else
10579 {
10580 if ((rbt == FFEINFO_basictypeTYPELESS)
10581 || (rbt == FFEINFO_basictypeHOLLERITH))
10582 {
10583 ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
10584 r->token, ffebld_left (reduced), l->token,
10585 FFEEXPR_contextLET));
10586 rinfo = ffebld_info (ffebld_right (reduced));
10587 rbt = ffeinfo_basictype (rinfo);
10588 rkt = ffeinfo_kindtype (rinfo);
10589 rrk = ffeinfo_rank (rinfo);
10590 rkd = ffeinfo_kind (rinfo);
10591 rwh = ffeinfo_where (rinfo);
10592 }
10593 /* else Leave it alone. */
10594 }
10595
10596 if (lbt == FFEINFO_basictypeLOGICAL)
10597 {
10598 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10599 l->token, op->token, FFEINFO_basictypeINTEGER,
10600 FFEINFO_kindtypeINTEGERDEFAULT, 0,
10601 FFETARGET_charactersizeNONE,
10602 FFEEXPR_contextLET));
10603 }
10604
10605 if (rbt == FFEINFO_basictypeLOGICAL)
10606 {
10607 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10608 r->token, op->token, FFEINFO_basictypeINTEGER,
10609 FFEINFO_kindtypeINTEGERDEFAULT, 0,
10610 FFETARGET_charactersizeNONE,
10611 FFEEXPR_contextLET));
10612 }
10613
10614 return reduced;
10615 }
10616
10617 /* Fumble through tokens until a nonmatching CLOSE_PAREN, EOS, or SEMICOLON
10618 is found.
10619
10620 The idea is to process the tokens as they would be done by normal
10621 expression processing, with the key things being telling the lexer
10622 when hollerith/character constants are about to happen, until the
10623 true closing token is found. */
10624
10625 static ffelexHandler
10626 ffeexpr_find_close_paren_ (ffelexToken t,
10627 ffelexHandler after)
10628 {
10629 ffeexpr_find_.after = after;
10630 ffeexpr_find_.level = 1;
10631 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10632 }
10633
10634 static ffelexHandler
10635 ffeexpr_nil_finished_ (ffelexToken t)
10636 {
10637 switch (ffelex_token_type (t))
10638 {
10639 case FFELEX_typeCLOSE_PAREN:
10640 if (--ffeexpr_find_.level == 0)
10641 return (ffelexHandler) ffeexpr_find_.after;
10642 return (ffelexHandler) ffeexpr_nil_binary_;
10643
10644 case FFELEX_typeCOMMA:
10645 case FFELEX_typeCOLON:
10646 case FFELEX_typeEQUALS:
10647 case FFELEX_typePOINTS:
10648 return (ffelexHandler) ffeexpr_nil_rhs_;
10649
10650 default:
10651 if (--ffeexpr_find_.level == 0)
10652 return (ffelexHandler) ffeexpr_find_.after (t);
10653 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10654 }
10655 }
10656
10657 static ffelexHandler
10658 ffeexpr_nil_rhs_ (ffelexToken t)
10659 {
10660 switch (ffelex_token_type (t))
10661 {
10662 case FFELEX_typeQUOTE:
10663 if (ffe_is_vxt ())
10664 return (ffelexHandler) ffeexpr_nil_quote_;
10665 ffelex_set_expecting_hollerith (-1, '\"',
10666 ffelex_token_where_line (t),
10667 ffelex_token_where_column (t));
10668 return (ffelexHandler) ffeexpr_nil_apostrophe_;
10669
10670 case FFELEX_typeAPOSTROPHE:
10671 ffelex_set_expecting_hollerith (-1, '\'',
10672 ffelex_token_where_line (t),
10673 ffelex_token_where_column (t));
10674 return (ffelexHandler) ffeexpr_nil_apostrophe_;
10675
10676 case FFELEX_typePERCENT:
10677 return (ffelexHandler) ffeexpr_nil_percent_;
10678
10679 case FFELEX_typeOPEN_PAREN:
10680 ++ffeexpr_find_.level;
10681 return (ffelexHandler) ffeexpr_nil_rhs_;
10682
10683 case FFELEX_typePLUS:
10684 case FFELEX_typeMINUS:
10685 return (ffelexHandler) ffeexpr_nil_rhs_;
10686
10687 case FFELEX_typePERIOD:
10688 return (ffelexHandler) ffeexpr_nil_period_;
10689
10690 case FFELEX_typeNUMBER:
10691 ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
10692 if (ffeexpr_hollerith_count_ > 0)
10693 ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
10694 '\0',
10695 ffelex_token_where_line (t),
10696 ffelex_token_where_column (t));
10697 return (ffelexHandler) ffeexpr_nil_number_;
10698
10699 case FFELEX_typeNAME:
10700 case FFELEX_typeNAMES:
10701 return (ffelexHandler) ffeexpr_nil_name_rhs_;
10702
10703 case FFELEX_typeASTERISK:
10704 case FFELEX_typeSLASH:
10705 case FFELEX_typePOWER:
10706 case FFELEX_typeCONCAT:
10707 case FFELEX_typeREL_EQ:
10708 case FFELEX_typeREL_NE:
10709 case FFELEX_typeREL_LE:
10710 case FFELEX_typeREL_GE:
10711 return (ffelexHandler) ffeexpr_nil_rhs_;
10712
10713 default:
10714 return (ffelexHandler) ffeexpr_nil_finished_ (t);
10715 }
10716 }
10717
10718 static ffelexHandler
10719 ffeexpr_nil_period_ (ffelexToken t)
10720 {
10721 switch (ffelex_token_type (t))
10722 {
10723 case FFELEX_typeNAME:
10724 case FFELEX_typeNAMES:
10725 ffeexpr_current_dotdot_ = ffestr_other (t);
10726 switch (ffeexpr_current_dotdot_)
10727 {
10728 case FFESTR_otherNone:
10729 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10730
10731 case FFESTR_otherTRUE:
10732 case FFESTR_otherFALSE:
10733 case FFESTR_otherNOT:
10734 return (ffelexHandler) ffeexpr_nil_end_period_;
10735
10736 default:
10737 return (ffelexHandler) ffeexpr_nil_swallow_period_;
10738 }
10739 break; /* Nothing really reaches here. */
10740
10741 case FFELEX_typeNUMBER:
10742 return (ffelexHandler) ffeexpr_nil_real_;
10743
10744 default:
10745 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10746 }
10747 }
10748
10749 static ffelexHandler
10750 ffeexpr_nil_end_period_ (ffelexToken t)
10751 {
10752 switch (ffeexpr_current_dotdot_)
10753 {
10754 case FFESTR_otherNOT:
10755 if (ffelex_token_type (t) != FFELEX_typePERIOD)
10756 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10757 return (ffelexHandler) ffeexpr_nil_rhs_;
10758
10759 case FFESTR_otherTRUE:
10760 case FFESTR_otherFALSE:
10761 if (ffelex_token_type (t) != FFELEX_typePERIOD)
10762 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10763 return (ffelexHandler) ffeexpr_nil_binary_;
10764
10765 default:
10766 assert ("Bad [nil] unary dotdot in ffeexpr_current_dotdot_" == NULL);
10767 exit (0);
10768 return NULL;
10769 }
10770 }
10771
10772 static ffelexHandler
10773 ffeexpr_nil_swallow_period_ (ffelexToken t)
10774 {
10775 if (ffelex_token_type (t) != FFELEX_typePERIOD)
10776 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
10777 return (ffelexHandler) ffeexpr_nil_rhs_;
10778 }
10779
10780 static ffelexHandler
10781 ffeexpr_nil_real_ (ffelexToken t)
10782 {
10783 char d;
10784 const char *p;
10785
10786 if (((ffelex_token_type (t) != FFELEX_typeNAME)
10787 && (ffelex_token_type (t) != FFELEX_typeNAMES))
10788 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
10789 'D', 'd')
10790 || ffesrc_char_match_init (d, 'E', 'e')
10791 || ffesrc_char_match_init (d, 'Q', 'q')))
10792 && ffeexpr_isdigits_ (++p)))
10793 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10794
10795 if (*p == '\0')
10796 return (ffelexHandler) ffeexpr_nil_real_exponent_;
10797 return (ffelexHandler) ffeexpr_nil_binary_;
10798 }
10799
10800 static ffelexHandler
10801 ffeexpr_nil_real_exponent_ (ffelexToken t)
10802 {
10803 if ((ffelex_token_type (t) != FFELEX_typePLUS)
10804 && (ffelex_token_type (t) != FFELEX_typeMINUS))
10805 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10806
10807 return (ffelexHandler) ffeexpr_nil_real_exp_sign_;
10808 }
10809
10810 static ffelexHandler
10811 ffeexpr_nil_real_exp_sign_ (ffelexToken t)
10812 {
10813 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
10814 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10815 return (ffelexHandler) ffeexpr_nil_binary_;
10816 }
10817
10818 static ffelexHandler
10819 ffeexpr_nil_number_ (ffelexToken t)
10820 {
10821 char d;
10822 const char *p;
10823
10824 if (ffeexpr_hollerith_count_ > 0)
10825 ffelex_set_expecting_hollerith (0, '\0',
10826 ffewhere_line_unknown (),
10827 ffewhere_column_unknown ());
10828
10829 switch (ffelex_token_type (t))
10830 {
10831 case FFELEX_typeNAME:
10832 case FFELEX_typeNAMES:
10833 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
10834 'D', 'd')
10835 || ffesrc_char_match_init (d, 'E', 'e')
10836 || ffesrc_char_match_init (d, 'Q', 'q'))
10837 && ffeexpr_isdigits_ (++p))
10838 {
10839 if (*p == '\0')
10840 {
10841 ffeexpr_find_.t = ffelex_token_use (t);
10842 return (ffelexHandler) ffeexpr_nil_number_exponent_;
10843 }
10844 return (ffelexHandler) ffeexpr_nil_binary_;
10845 }
10846 break;
10847
10848 case FFELEX_typePERIOD:
10849 ffeexpr_find_.t = ffelex_token_use (t);
10850 return (ffelexHandler) ffeexpr_nil_number_period_;
10851
10852 case FFELEX_typeHOLLERITH:
10853 return (ffelexHandler) ffeexpr_nil_binary_;
10854
10855 default:
10856 break;
10857 }
10858 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10859 }
10860
10861 /* Expects ffeexpr_find_.t. */
10862
10863 static ffelexHandler
10864 ffeexpr_nil_number_exponent_ (ffelexToken t)
10865 {
10866 ffelexHandler nexthandler;
10867
10868 if ((ffelex_token_type (t) != FFELEX_typePLUS)
10869 && (ffelex_token_type (t) != FFELEX_typeMINUS))
10870 {
10871 nexthandler
10872 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
10873 ffelex_token_kill (ffeexpr_find_.t);
10874 return (ffelexHandler) (*nexthandler) (t);
10875 }
10876
10877 ffelex_token_kill (ffeexpr_find_.t);
10878 return (ffelexHandler) ffeexpr_nil_number_exp_sign_;
10879 }
10880
10881 static ffelexHandler
10882 ffeexpr_nil_number_exp_sign_ (ffelexToken t)
10883 {
10884 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
10885 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10886
10887 return (ffelexHandler) ffeexpr_nil_binary_;
10888 }
10889
10890 /* Expects ffeexpr_find_.t. */
10891
10892 static ffelexHandler
10893 ffeexpr_nil_number_period_ (ffelexToken t)
10894 {
10895 ffelexHandler nexthandler;
10896 char d;
10897 const char *p;
10898
10899 switch (ffelex_token_type (t))
10900 {
10901 case FFELEX_typeNAME:
10902 case FFELEX_typeNAMES:
10903 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
10904 'D', 'd')
10905 || ffesrc_char_match_init (d, 'E', 'e')
10906 || ffesrc_char_match_init (d, 'Q', 'q'))
10907 && ffeexpr_isdigits_ (++p))
10908 {
10909 if (*p == '\0')
10910 return (ffelexHandler) ffeexpr_nil_number_per_exp_;
10911 ffelex_token_kill (ffeexpr_find_.t);
10912 return (ffelexHandler) ffeexpr_nil_binary_;
10913 }
10914 nexthandler
10915 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
10916 ffelex_token_kill (ffeexpr_find_.t);
10917 return (ffelexHandler) (*nexthandler) (t);
10918
10919 case FFELEX_typeNUMBER:
10920 ffelex_token_kill (ffeexpr_find_.t);
10921 return (ffelexHandler) ffeexpr_nil_number_real_;
10922
10923 default:
10924 break;
10925 }
10926 ffelex_token_kill (ffeexpr_find_.t);
10927 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10928 }
10929
10930 /* Expects ffeexpr_find_.t. */
10931
10932 static ffelexHandler
10933 ffeexpr_nil_number_per_exp_ (ffelexToken t)
10934 {
10935 if ((ffelex_token_type (t) != FFELEX_typePLUS)
10936 && (ffelex_token_type (t) != FFELEX_typeMINUS))
10937 {
10938 ffelexHandler nexthandler;
10939
10940 nexthandler
10941 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
10942 ffelex_token_kill (ffeexpr_find_.t);
10943 return (ffelexHandler) (*nexthandler) (t);
10944 }
10945
10946 ffelex_token_kill (ffeexpr_find_.t);
10947 return (ffelexHandler) ffeexpr_nil_num_per_exp_sign_;
10948 }
10949
10950 static ffelexHandler
10951 ffeexpr_nil_number_real_ (ffelexToken t)
10952 {
10953 char d;
10954 const char *p;
10955
10956 if (((ffelex_token_type (t) != FFELEX_typeNAME)
10957 && (ffelex_token_type (t) != FFELEX_typeNAMES))
10958 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
10959 'D', 'd')
10960 || ffesrc_char_match_init (d, 'E', 'e')
10961 || ffesrc_char_match_init (d, 'Q', 'q')))
10962 && ffeexpr_isdigits_ (++p)))
10963 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10964
10965 if (*p == '\0')
10966 return (ffelexHandler) ffeexpr_nil_number_real_exp_;
10967
10968 return (ffelexHandler) ffeexpr_nil_binary_;
10969 }
10970
10971 static ffelexHandler
10972 ffeexpr_nil_num_per_exp_sign_ (ffelexToken t)
10973 {
10974 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
10975 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10976 return (ffelexHandler) ffeexpr_nil_binary_;
10977 }
10978
10979 static ffelexHandler
10980 ffeexpr_nil_number_real_exp_ (ffelexToken t)
10981 {
10982 if ((ffelex_token_type (t) != FFELEX_typePLUS)
10983 && (ffelex_token_type (t) != FFELEX_typeMINUS))
10984 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10985 return (ffelexHandler) ffeexpr_nil_num_real_exp_sn_;
10986 }
10987
10988 static ffelexHandler
10989 ffeexpr_nil_num_real_exp_sn_ (ffelexToken t)
10990 {
10991 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
10992 return (ffelexHandler) ffeexpr_nil_binary_ (t);
10993 return (ffelexHandler) ffeexpr_nil_binary_;
10994 }
10995
10996 static ffelexHandler
10997 ffeexpr_nil_binary_ (ffelexToken t)
10998 {
10999 switch (ffelex_token_type (t))
11000 {
11001 case FFELEX_typePLUS:
11002 case FFELEX_typeMINUS:
11003 case FFELEX_typeASTERISK:
11004 case FFELEX_typeSLASH:
11005 case FFELEX_typePOWER:
11006 case FFELEX_typeCONCAT:
11007 case FFELEX_typeOPEN_ANGLE:
11008 case FFELEX_typeCLOSE_ANGLE:
11009 case FFELEX_typeREL_EQ:
11010 case FFELEX_typeREL_NE:
11011 case FFELEX_typeREL_GE:
11012 case FFELEX_typeREL_LE:
11013 return (ffelexHandler) ffeexpr_nil_rhs_;
11014
11015 case FFELEX_typePERIOD:
11016 return (ffelexHandler) ffeexpr_nil_binary_period_;
11017
11018 default:
11019 return (ffelexHandler) ffeexpr_nil_finished_ (t);
11020 }
11021 }
11022
11023 static ffelexHandler
11024 ffeexpr_nil_binary_period_ (ffelexToken t)
11025 {
11026 switch (ffelex_token_type (t))
11027 {
11028 case FFELEX_typeNAME:
11029 case FFELEX_typeNAMES:
11030 ffeexpr_current_dotdot_ = ffestr_other (t);
11031 switch (ffeexpr_current_dotdot_)
11032 {
11033 case FFESTR_otherTRUE:
11034 case FFESTR_otherFALSE:
11035 case FFESTR_otherNOT:
11036 return (ffelexHandler) ffeexpr_nil_binary_sw_per_;
11037
11038 default:
11039 return (ffelexHandler) ffeexpr_nil_binary_end_per_;
11040 }
11041 break; /* Nothing really reaches here. */
11042
11043 default:
11044 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11045 }
11046 }
11047
11048 static ffelexHandler
11049 ffeexpr_nil_binary_end_per_ (ffelexToken t)
11050 {
11051 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11052 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11053 return (ffelexHandler) ffeexpr_nil_rhs_;
11054 }
11055
11056 static ffelexHandler
11057 ffeexpr_nil_binary_sw_per_ (ffelexToken t)
11058 {
11059 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11060 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11061 return (ffelexHandler) ffeexpr_nil_binary_;
11062 }
11063
11064 static ffelexHandler
11065 ffeexpr_nil_quote_ (ffelexToken t)
11066 {
11067 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11068 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11069 return (ffelexHandler) ffeexpr_nil_binary_;
11070 }
11071
11072 static ffelexHandler
11073 ffeexpr_nil_apostrophe_ (ffelexToken t)
11074 {
11075 assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
11076 return (ffelexHandler) ffeexpr_nil_apos_char_;
11077 }
11078
11079 static ffelexHandler
11080 ffeexpr_nil_apos_char_ (ffelexToken t)
11081 {
11082 char c;
11083
11084 if ((ffelex_token_type (t) == FFELEX_typeNAME)
11085 || (ffelex_token_type (t) == FFELEX_typeNAMES))
11086 {
11087 if ((ffelex_token_length (t) == 1)
11088 && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]),
11089 'B', 'b')
11090 || ffesrc_char_match_init (c, 'O', 'o')
11091 || ffesrc_char_match_init (c, 'X', 'x')
11092 || ffesrc_char_match_init (c, 'Z', 'z')))
11093 return (ffelexHandler) ffeexpr_nil_binary_;
11094 }
11095 if ((ffelex_token_type (t) == FFELEX_typeNAME)
11096 || (ffelex_token_type (t) == FFELEX_typeNAMES))
11097 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11098 return (ffelexHandler) ffeexpr_nil_substrp_ (t);
11099 }
11100
11101 static ffelexHandler
11102 ffeexpr_nil_name_rhs_ (ffelexToken t)
11103 {
11104 switch (ffelex_token_type (t))
11105 {
11106 case FFELEX_typeQUOTE:
11107 case FFELEX_typeAPOSTROPHE:
11108 ffelex_set_hexnum (TRUE);
11109 return (ffelexHandler) ffeexpr_nil_name_apos_;
11110
11111 case FFELEX_typeOPEN_PAREN:
11112 ++ffeexpr_find_.level;
11113 return (ffelexHandler) ffeexpr_nil_rhs_;
11114
11115 default:
11116 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11117 }
11118 }
11119
11120 static ffelexHandler
11121 ffeexpr_nil_name_apos_ (ffelexToken t)
11122 {
11123 if (ffelex_token_type (t) == FFELEX_typeNAME)
11124 return (ffelexHandler) ffeexpr_nil_name_apos_name_;
11125 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11126 }
11127
11128 static ffelexHandler
11129 ffeexpr_nil_name_apos_name_ (ffelexToken t)
11130 {
11131 switch (ffelex_token_type (t))
11132 {
11133 case FFELEX_typeAPOSTROPHE:
11134 case FFELEX_typeQUOTE:
11135 return (ffelexHandler) ffeexpr_nil_finished_;
11136
11137 default:
11138 return (ffelexHandler) ffeexpr_nil_finished_ (t);
11139 }
11140 }
11141
11142 static ffelexHandler
11143 ffeexpr_nil_percent_ (ffelexToken t)
11144 {
11145 switch (ffelex_token_type (t))
11146 {
11147 case FFELEX_typeNAME:
11148 case FFELEX_typeNAMES:
11149 ffeexpr_stack_->percent = ffeexpr_percent_ (t);
11150 ffeexpr_find_.t = ffelex_token_use (t);
11151 return (ffelexHandler) ffeexpr_nil_percent_name_;
11152
11153 default:
11154 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11155 }
11156 }
11157
11158 /* Expects ffeexpr_find_.t. */
11159
11160 static ffelexHandler
11161 ffeexpr_nil_percent_name_ (ffelexToken t)
11162 {
11163 ffelexHandler nexthandler;
11164
11165 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
11166 {
11167 nexthandler
11168 = (ffelexHandler) ffeexpr_nil_rhs_ (ffeexpr_find_.t);
11169 ffelex_token_kill (ffeexpr_find_.t);
11170 return (ffelexHandler) (*nexthandler) (t);
11171 }
11172
11173 ffelex_token_kill (ffeexpr_find_.t);
11174 ++ffeexpr_find_.level;
11175 return (ffelexHandler) ffeexpr_nil_rhs_;
11176 }
11177
11178 static ffelexHandler
11179 ffeexpr_nil_substrp_ (ffelexToken t)
11180 {
11181 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
11182 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11183
11184 ++ffeexpr_find_.level;
11185 return (ffelexHandler) ffeexpr_nil_rhs_;
11186 }
11187
11188 /* ffeexpr_finished_ -- Reduce expression stack to one expr, finish
11189
11190 ffelexToken t;
11191 return ffeexpr_finished_(t);
11192
11193 Reduces expression stack to one (or zero) elements by repeatedly reducing
11194 the top operator on the stack (or, if the top element on the stack is
11195 itself an operator, issuing an error message and discarding it). Calls
11196 finishing routine with the expression, returning the ffelexHandler it
11197 returns to the caller. */
11198
11199 static ffelexHandler
11200 ffeexpr_finished_ (ffelexToken t)
11201 {
11202 ffeexprExpr_ operand; /* This is B in -B or A+B. */
11203 ffebld expr;
11204 ffeexprCallback callback;
11205 ffeexprStack_ s;
11206 ffebldConstant constnode; /* For detecting magical number. */
11207 ffelexToken ft; /* Temporary copy of first token in
11208 expression. */
11209 ffelexHandler next;
11210 ffeinfo info;
11211 bool error = FALSE;
11212
11213 while (((operand = ffeexpr_stack_->exprstack) != NULL)
11214 && ((operand->previous != NULL) || (operand->type != FFEEXPR_exprtypeOPERAND_)))
11215 {
11216 if (operand->type == FFEEXPR_exprtypeOPERAND_)
11217 ffeexpr_reduce_ ();
11218 else
11219 {
11220 if (ffest_ffebad_start (FFEBAD_MISSING_OPERAND_FOR_OPERATOR))
11221 {
11222 ffebad_here (0, ffelex_token_where_line (t),
11223 ffelex_token_where_column (t));
11224 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
11225 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
11226 ffebad_finish ();
11227 }
11228 ffeexpr_stack_->exprstack = operand->previous; /* Pop the useless
11229 operator. */
11230 ffeexpr_expr_kill_ (operand);
11231 }
11232 }
11233
11234 assert ((operand == NULL) || (operand->previous == NULL));
11235
11236 ffebld_pool_pop ();
11237 if (operand == NULL)
11238 expr = NULL;
11239 else
11240 {
11241 expr = operand->u.operand;
11242 info = ffebld_info (expr);
11243 if ((ffebld_op (expr) == FFEBLD_opCONTER)
11244 && (ffebld_conter_orig (expr) == NULL)
11245 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
11246 {
11247 ffetarget_integer_bad_magical (operand->token);
11248 }
11249 ffeexpr_expr_kill_ (operand);
11250 ffeexpr_stack_->exprstack = NULL;
11251 }
11252
11253 ft = ffeexpr_stack_->first_token;
11254
11255 again: /* :::::::::::::::::::: */
11256 switch (ffeexpr_stack_->context)
11257 {
11258 case FFEEXPR_contextLET:
11259 case FFEEXPR_contextSFUNCDEF:
11260 error = (expr == NULL)
11261 || (ffeinfo_rank (info) != 0);
11262 break;
11263
11264 case FFEEXPR_contextPAREN_:
11265 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11266 break;
11267 switch (ffeinfo_basictype (info))
11268 {
11269 case FFEINFO_basictypeHOLLERITH:
11270 case FFEINFO_basictypeTYPELESS:
11271 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11272 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11273 FFEEXPR_contextLET);
11274 break;
11275
11276 default:
11277 break;
11278 }
11279 break;
11280
11281 case FFEEXPR_contextPARENFILENUM_:
11282 if (ffelex_token_type (t) != FFELEX_typeCOMMA)
11283 ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
11284 else
11285 ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
11286 goto again; /* :::::::::::::::::::: */
11287
11288 case FFEEXPR_contextPARENFILEUNIT_:
11289 if (ffelex_token_type (t) != FFELEX_typeCOMMA)
11290 ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
11291 else
11292 ffeexpr_stack_->context = FFEEXPR_contextFILEUNIT;
11293 goto again; /* :::::::::::::::::::: */
11294
11295 case FFEEXPR_contextACTUALARGEXPR_:
11296 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
11297 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11298 : ffeinfo_basictype (info))
11299 {
11300 case FFEINFO_basictypeHOLLERITH:
11301 case FFEINFO_basictypeTYPELESS:
11302 if (!ffe_is_ugly_args ()
11303 && ffebad_start (FFEBAD_ACTUALARG))
11304 {
11305 ffebad_here (0, ffelex_token_where_line (ft),
11306 ffelex_token_where_column (ft));
11307 ffebad_finish ();
11308 }
11309 break;
11310
11311 default:
11312 break;
11313 }
11314 error = (expr != NULL) && (ffeinfo_rank (info) != 0);
11315 break;
11316
11317 case FFEEXPR_contextACTUALARG_:
11318 case FFEEXPR_contextSFUNCDEFACTUALARG_:
11319 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11320 : ffeinfo_basictype (info))
11321 {
11322 case FFEINFO_basictypeHOLLERITH:
11323 case FFEINFO_basictypeTYPELESS:
11324 #if 0 /* Should never get here. */
11325 expr = ffeexpr_convert (expr, ft, ft,
11326 FFEINFO_basictypeINTEGER,
11327 FFEINFO_kindtypeINTEGERDEFAULT,
11328 0,
11329 FFETARGET_charactersizeNONE,
11330 FFEEXPR_contextLET);
11331 #else
11332 assert ("why hollerith/typeless in actualarg_?" == NULL);
11333 #endif
11334 break;
11335
11336 default:
11337 break;
11338 }
11339 switch ((expr == NULL) ? FFEBLD_opANY : ffebld_op (expr))
11340 {
11341 case FFEBLD_opSYMTER:
11342 case FFEBLD_opPERCENT_LOC:
11343 case FFEBLD_opPERCENT_VAL:
11344 case FFEBLD_opPERCENT_REF:
11345 case FFEBLD_opPERCENT_DESCR:
11346 error = FALSE;
11347 break;
11348
11349 default:
11350 error = (expr != NULL) && (ffeinfo_rank (info) != 0);
11351 break;
11352 }
11353 {
11354 ffesymbol s;
11355 ffeinfoWhere where;
11356 ffeinfoKind kind;
11357
11358 if (!error
11359 && (expr != NULL)
11360 && (ffebld_op (expr) == FFEBLD_opSYMTER)
11361 && ((s = ffebld_symter (expr)), (where = ffesymbol_where (s)),
11362 (where == FFEINFO_whereINTRINSIC)
11363 || (where == FFEINFO_whereGLOBAL)
11364 || ((where == FFEINFO_whereDUMMY)
11365 && ((kind = ffesymbol_kind (s)),
11366 (kind == FFEINFO_kindFUNCTION)
11367 || (kind == FFEINFO_kindSUBROUTINE))))
11368 && !ffesymbol_explicitwhere (s))
11369 {
11370 ffebad_start (where == FFEINFO_whereINTRINSIC
11371 ? FFEBAD_NEED_INTRINSIC : FFEBAD_NEED_EXTERNAL);
11372 ffebad_here (0, ffelex_token_where_line (ft),
11373 ffelex_token_where_column (ft));
11374 ffebad_string (ffesymbol_text (s));
11375 ffebad_finish ();
11376 ffesymbol_signal_change (s);
11377 ffesymbol_set_explicitwhere (s, TRUE);
11378 ffesymbol_signal_unreported (s);
11379 }
11380 }
11381 break;
11382
11383 case FFEEXPR_contextINDEX_:
11384 case FFEEXPR_contextSFUNCDEFINDEX_:
11385 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11386 break;
11387 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11388 : ffeinfo_basictype (info))
11389 {
11390 case FFEINFO_basictypeNONE:
11391 error = FALSE;
11392 break;
11393
11394 case FFEINFO_basictypeLOGICAL:
11395 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11396 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11397 FFEEXPR_contextLET);
11398 /* Fall through. */
11399 case FFEINFO_basictypeREAL:
11400 case FFEINFO_basictypeCOMPLEX:
11401 if (ffe_is_pedantic ())
11402 {
11403 error = TRUE;
11404 break;
11405 }
11406 /* Fall through. */
11407 case FFEINFO_basictypeHOLLERITH:
11408 case FFEINFO_basictypeTYPELESS:
11409 error = FALSE;
11410 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11411 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11412 FFEEXPR_contextLET);
11413 break;
11414
11415 case FFEINFO_basictypeINTEGER:
11416 /* Specifically, allow INTEGER(KIND=2), aka INTEGER*8, through
11417 unmolested. Leave it to downstream to handle kinds. */
11418 break;
11419
11420 default:
11421 error = TRUE;
11422 break;
11423 }
11424 break; /* expr==NULL ok for substring; element case
11425 caught by callback. */
11426
11427 case FFEEXPR_contextRETURN:
11428 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11429 break;
11430 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11431 : ffeinfo_basictype (info))
11432 {
11433 case FFEINFO_basictypeNONE:
11434 error = FALSE;
11435 break;
11436
11437 case FFEINFO_basictypeLOGICAL:
11438 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11439 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11440 FFEEXPR_contextLET);
11441 /* Fall through. */
11442 case FFEINFO_basictypeREAL:
11443 case FFEINFO_basictypeCOMPLEX:
11444 if (ffe_is_pedantic ())
11445 {
11446 error = TRUE;
11447 break;
11448 }
11449 /* Fall through. */
11450 case FFEINFO_basictypeINTEGER:
11451 case FFEINFO_basictypeHOLLERITH:
11452 case FFEINFO_basictypeTYPELESS:
11453 error = FALSE;
11454 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11455 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11456 FFEEXPR_contextLET);
11457 break;
11458
11459 default:
11460 error = TRUE;
11461 break;
11462 }
11463 break;
11464
11465 case FFEEXPR_contextDO:
11466 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11467 break;
11468 switch (ffeinfo_basictype (info))
11469 {
11470 case FFEINFO_basictypeLOGICAL:
11471 error = !ffe_is_ugly_logint ();
11472 if (!ffeexpr_stack_->is_rhs)
11473 break; /* Don't convert lhs variable. */
11474 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11475 ffeinfo_kindtype (ffebld_info (expr)), 0,
11476 FFETARGET_charactersizeNONE,
11477 FFEEXPR_contextLET);
11478 break;
11479
11480 case FFEINFO_basictypeHOLLERITH:
11481 case FFEINFO_basictypeTYPELESS:
11482 if (!ffeexpr_stack_->is_rhs)
11483 {
11484 error = TRUE;
11485 break; /* Don't convert lhs variable. */
11486 }
11487 break;
11488
11489 case FFEINFO_basictypeINTEGER:
11490 case FFEINFO_basictypeREAL:
11491 break;
11492
11493 default:
11494 error = TRUE;
11495 break;
11496 }
11497 if (!ffeexpr_stack_->is_rhs
11498 && (ffebld_op (expr) != FFEBLD_opSYMTER))
11499 error = TRUE;
11500 break;
11501
11502 case FFEEXPR_contextDOWHILE:
11503 case FFEEXPR_contextIF:
11504 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11505 break;
11506 switch (ffeinfo_basictype (info))
11507 {
11508 case FFEINFO_basictypeINTEGER:
11509 error = FALSE;
11510 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11511 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11512 FFEEXPR_contextLET);
11513 /* Fall through. */
11514 case FFEINFO_basictypeLOGICAL:
11515 case FFEINFO_basictypeHOLLERITH:
11516 case FFEINFO_basictypeTYPELESS:
11517 error = FALSE;
11518 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11519 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11520 FFEEXPR_contextLET);
11521 break;
11522
11523 default:
11524 error = TRUE;
11525 break;
11526 }
11527 break;
11528
11529 case FFEEXPR_contextASSIGN:
11530 case FFEEXPR_contextAGOTO:
11531 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11532 : ffeinfo_basictype (info))
11533 {
11534 case FFEINFO_basictypeINTEGER:
11535 error = (ffeinfo_kindtype (info) != ffecom_label_kind ());
11536 break;
11537
11538 case FFEINFO_basictypeLOGICAL:
11539 error = !ffe_is_ugly_logint ()
11540 || (ffeinfo_kindtype (info) != ffecom_label_kind ());
11541 break;
11542
11543 default:
11544 error = TRUE;
11545 break;
11546 }
11547 if ((expr == NULL) || (ffeinfo_rank (info) != 0)
11548 || (ffebld_op (expr) != FFEBLD_opSYMTER))
11549 error = TRUE;
11550 break;
11551
11552 case FFEEXPR_contextCGOTO:
11553 case FFEEXPR_contextFORMAT:
11554 case FFEEXPR_contextDIMLIST:
11555 case FFEEXPR_contextFILENUM: /* See equiv code in _ambig_. */
11556 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11557 break;
11558 switch (ffeinfo_basictype (info))
11559 {
11560 case FFEINFO_basictypeLOGICAL:
11561 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11562 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11563 FFEEXPR_contextLET);
11564 /* Fall through. */
11565 case FFEINFO_basictypeREAL:
11566 case FFEINFO_basictypeCOMPLEX:
11567 if (ffe_is_pedantic ())
11568 {
11569 error = TRUE;
11570 break;
11571 }
11572 /* Fall through. */
11573 case FFEINFO_basictypeINTEGER:
11574 case FFEINFO_basictypeHOLLERITH:
11575 case FFEINFO_basictypeTYPELESS:
11576 error = FALSE;
11577 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11578 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11579 FFEEXPR_contextLET);
11580 break;
11581
11582 default:
11583 error = TRUE;
11584 break;
11585 }
11586 break;
11587
11588 case FFEEXPR_contextARITHIF:
11589 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11590 break;
11591 switch (ffeinfo_basictype (info))
11592 {
11593 case FFEINFO_basictypeLOGICAL:
11594 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11595 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11596 FFEEXPR_contextLET);
11597 if (ffe_is_pedantic ())
11598 {
11599 error = TRUE;
11600 break;
11601 }
11602 /* Fall through. */
11603 case FFEINFO_basictypeHOLLERITH:
11604 case FFEINFO_basictypeTYPELESS:
11605 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11606 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11607 FFEEXPR_contextLET);
11608 /* Fall through. */
11609 case FFEINFO_basictypeINTEGER:
11610 case FFEINFO_basictypeREAL:
11611 error = FALSE;
11612 break;
11613
11614 default:
11615 error = TRUE;
11616 break;
11617 }
11618 break;
11619
11620 case FFEEXPR_contextSTOP:
11621 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11622 break;
11623 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11624 : ffeinfo_basictype (info))
11625 {
11626 case FFEINFO_basictypeINTEGER:
11627 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
11628 break;
11629
11630 case FFEINFO_basictypeCHARACTER:
11631 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT);
11632 break;
11633
11634 case FFEINFO_basictypeHOLLERITH:
11635 case FFEINFO_basictypeTYPELESS:
11636 error = FALSE;
11637 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11638 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11639 FFEEXPR_contextLET);
11640 break;
11641
11642 case FFEINFO_basictypeNONE:
11643 error = FALSE;
11644 break;
11645
11646 default:
11647 error = TRUE;
11648 break;
11649 }
11650 if ((expr != NULL) && ((ffebld_op (expr) != FFEBLD_opCONTER)
11651 || (ffebld_conter_orig (expr) != NULL)))
11652 error = TRUE;
11653 break;
11654
11655 case FFEEXPR_contextINCLUDE:
11656 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
11657 || (ffeinfo_basictype (info) != FFEINFO_basictypeCHARACTER)
11658 || (ffebld_op (expr) != FFEBLD_opCONTER)
11659 || (ffebld_conter_orig (expr) != NULL);
11660 break;
11661
11662 case FFEEXPR_contextSELECTCASE:
11663 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11664 break;
11665 switch (ffeinfo_basictype (info))
11666 {
11667 case FFEINFO_basictypeINTEGER:
11668 case FFEINFO_basictypeCHARACTER:
11669 case FFEINFO_basictypeLOGICAL:
11670 error = FALSE;
11671 break;
11672
11673 case FFEINFO_basictypeHOLLERITH:
11674 case FFEINFO_basictypeTYPELESS:
11675 error = FALSE;
11676 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11677 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11678 FFEEXPR_contextLET);
11679 break;
11680
11681 default:
11682 error = TRUE;
11683 break;
11684 }
11685 break;
11686
11687 case FFEEXPR_contextCASE:
11688 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11689 break;
11690 switch ((expr == NULL) ? FFEINFO_basictypeINTEGER
11691 : ffeinfo_basictype (info))
11692 {
11693 case FFEINFO_basictypeINTEGER:
11694 case FFEINFO_basictypeCHARACTER:
11695 case FFEINFO_basictypeLOGICAL:
11696 error = FALSE;
11697 break;
11698
11699 case FFEINFO_basictypeHOLLERITH:
11700 case FFEINFO_basictypeTYPELESS:
11701 error = FALSE;
11702 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11703 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11704 FFEEXPR_contextLET);
11705 break;
11706
11707 default:
11708 error = TRUE;
11709 break;
11710 }
11711 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
11712 error = TRUE;
11713 break;
11714
11715 case FFEEXPR_contextCHARACTERSIZE:
11716 case FFEEXPR_contextKINDTYPE:
11717 case FFEEXPR_contextDIMLISTCOMMON:
11718 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11719 break;
11720 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11721 : ffeinfo_basictype (info))
11722 {
11723 case FFEINFO_basictypeLOGICAL:
11724 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11725 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11726 FFEEXPR_contextLET);
11727 /* Fall through. */
11728 case FFEINFO_basictypeREAL:
11729 case FFEINFO_basictypeCOMPLEX:
11730 if (ffe_is_pedantic ())
11731 {
11732 error = TRUE;
11733 break;
11734 }
11735 /* Fall through. */
11736 case FFEINFO_basictypeINTEGER:
11737 case FFEINFO_basictypeHOLLERITH:
11738 case FFEINFO_basictypeTYPELESS:
11739 error = FALSE;
11740 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11741 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11742 FFEEXPR_contextLET);
11743 break;
11744
11745 default:
11746 error = TRUE;
11747 break;
11748 }
11749 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
11750 error = TRUE;
11751 break;
11752
11753 case FFEEXPR_contextEQVINDEX_:
11754 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
11755 break;
11756 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11757 : ffeinfo_basictype (info))
11758 {
11759 case FFEINFO_basictypeNONE:
11760 error = FALSE;
11761 break;
11762
11763 case FFEINFO_basictypeLOGICAL:
11764 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
11765 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
11766 FFEEXPR_contextLET);
11767 /* Fall through. */
11768 case FFEINFO_basictypeREAL:
11769 case FFEINFO_basictypeCOMPLEX:
11770 if (ffe_is_pedantic ())
11771 {
11772 error = TRUE;
11773 break;
11774 }
11775 /* Fall through. */
11776 case FFEINFO_basictypeINTEGER:
11777 case FFEINFO_basictypeHOLLERITH:
11778 case FFEINFO_basictypeTYPELESS:
11779 error = FALSE;
11780 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11781 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11782 FFEEXPR_contextLET);
11783 break;
11784
11785 default:
11786 error = TRUE;
11787 break;
11788 }
11789 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
11790 error = TRUE;
11791 break;
11792
11793 case FFEEXPR_contextPARAMETER:
11794 if (ffeexpr_stack_->is_rhs)
11795 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
11796 || (ffebld_op (expr) != FFEBLD_opCONTER);
11797 else
11798 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
11799 || (ffebld_op (expr) != FFEBLD_opSYMTER);
11800 break;
11801
11802 case FFEEXPR_contextINDEXORACTUALARG_:
11803 if (ffelex_token_type (t) == FFELEX_typeCOLON)
11804 ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
11805 else
11806 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
11807 goto again; /* :::::::::::::::::::: */
11808
11809 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
11810 if (ffelex_token_type (t) == FFELEX_typeCOLON)
11811 ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
11812 else
11813 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
11814 goto again; /* :::::::::::::::::::: */
11815
11816 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
11817 if (ffelex_token_type (t) == FFELEX_typeCOLON)
11818 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
11819 else
11820 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
11821 goto again; /* :::::::::::::::::::: */
11822
11823 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
11824 if (ffelex_token_type (t) == FFELEX_typeCOLON)
11825 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
11826 else
11827 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
11828 goto again; /* :::::::::::::::::::: */
11829
11830 case FFEEXPR_contextIMPDOCTRL_:
11831 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11832 break;
11833 if (!ffeexpr_stack_->is_rhs
11834 && (ffebld_op (expr) != FFEBLD_opSYMTER))
11835 error = TRUE;
11836 switch (ffeinfo_basictype (info))
11837 {
11838 case FFEINFO_basictypeLOGICAL:
11839 if (! ffe_is_ugly_logint ())
11840 error = TRUE;
11841 if (! ffeexpr_stack_->is_rhs)
11842 break;
11843 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11844 ffeinfo_kindtype (info), 0,
11845 FFETARGET_charactersizeNONE,
11846 FFEEXPR_contextLET);
11847 break;
11848
11849 case FFEINFO_basictypeINTEGER:
11850 case FFEINFO_basictypeHOLLERITH:
11851 case FFEINFO_basictypeTYPELESS:
11852 break;
11853
11854 case FFEINFO_basictypeREAL:
11855 if (!ffeexpr_stack_->is_rhs
11856 && ffe_is_warn_surprising ()
11857 && !error)
11858 {
11859 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
11860 ffebad_here (0, ffelex_token_where_line (ft),
11861 ffelex_token_where_column (ft));
11862 ffebad_string (ffelex_token_text (ft));
11863 ffebad_finish ();
11864 }
11865 break;
11866
11867 default:
11868 error = TRUE;
11869 break;
11870 }
11871 break;
11872
11873 case FFEEXPR_contextDATAIMPDOCTRL_:
11874 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
11875 break;
11876 if (ffeexpr_stack_->is_rhs)
11877 {
11878 if ((ffebld_op (expr) != FFEBLD_opCONTER)
11879 && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
11880 error = TRUE;
11881 }
11882 else if ((ffebld_op (expr) != FFEBLD_opSYMTER)
11883 || (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
11884 error = TRUE;
11885 switch (ffeinfo_basictype (info))
11886 {
11887 case FFEINFO_basictypeLOGICAL:
11888 if (! ffeexpr_stack_->is_rhs)
11889 break;
11890 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11891 ffeinfo_kindtype (info), 0,
11892 FFETARGET_charactersizeNONE,
11893 FFEEXPR_contextLET);
11894 /* Fall through. */
11895 case FFEINFO_basictypeINTEGER:
11896 if (ffeexpr_stack_->is_rhs
11897 && (ffeinfo_kindtype (ffebld_info (expr))
11898 != FFEINFO_kindtypeINTEGERDEFAULT))
11899 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11900 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11901 FFETARGET_charactersizeNONE,
11902 FFEEXPR_contextLET);
11903 break;
11904
11905 case FFEINFO_basictypeHOLLERITH:
11906 case FFEINFO_basictypeTYPELESS:
11907 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11908 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11909 FFEEXPR_contextLET);
11910 break;
11911
11912 case FFEINFO_basictypeREAL:
11913 if (!ffeexpr_stack_->is_rhs
11914 && ffe_is_warn_surprising ()
11915 && !error)
11916 {
11917 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
11918 ffebad_here (0, ffelex_token_where_line (ft),
11919 ffelex_token_where_column (ft));
11920 ffebad_string (ffelex_token_text (ft));
11921 ffebad_finish ();
11922 }
11923 break;
11924
11925 default:
11926 error = TRUE;
11927 break;
11928 }
11929 break;
11930
11931 case FFEEXPR_contextIMPDOITEM_:
11932 if (ffelex_token_type (t) == FFELEX_typeEQUALS)
11933 {
11934 ffeexpr_stack_->is_rhs = FALSE;
11935 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
11936 goto again; /* :::::::::::::::::::: */
11937 }
11938 /* Fall through. */
11939 case FFEEXPR_contextIOLIST:
11940 case FFEEXPR_contextFILEVXTCODE:
11941 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11942 : ffeinfo_basictype (info))
11943 {
11944 case FFEINFO_basictypeHOLLERITH:
11945 case FFEINFO_basictypeTYPELESS:
11946 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11947 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11948 FFEEXPR_contextLET);
11949 break;
11950
11951 default:
11952 break;
11953 }
11954 error = (expr == NULL)
11955 || ((ffeinfo_rank (info) != 0)
11956 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
11957 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
11958 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
11959 == FFEBLD_opSTAR))); /* Bad if null expr, or if
11960 array that is not a SYMTER
11961 (can't happen yet, I
11962 think) or has a NULL or
11963 STAR (assumed) array
11964 size. */
11965 break;
11966
11967 case FFEEXPR_contextIMPDOITEMDF_:
11968 if (ffelex_token_type (t) == FFELEX_typeEQUALS)
11969 {
11970 ffeexpr_stack_->is_rhs = FALSE;
11971 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
11972 goto again; /* :::::::::::::::::::: */
11973 }
11974 /* Fall through. */
11975 case FFEEXPR_contextIOLISTDF:
11976 switch ((expr == NULL) ? FFEINFO_basictypeNONE
11977 : ffeinfo_basictype (info))
11978 {
11979 case FFEINFO_basictypeHOLLERITH:
11980 case FFEINFO_basictypeTYPELESS:
11981 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
11982 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
11983 FFEEXPR_contextLET);
11984 break;
11985
11986 default:
11987 break;
11988 }
11989 error
11990 = (expr == NULL)
11991 || ((ffeinfo_basictype (info) == FFEINFO_basictypeCHARACTER)
11992 && (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT))
11993 || ((ffeinfo_rank (info) != 0)
11994 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
11995 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
11996 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
11997 == FFEBLD_opSTAR))); /* Bad if null expr,
11998 non-default-kindtype
11999 character expr, or if
12000 array that is not a SYMTER
12001 (can't happen yet, I
12002 think) or has a NULL or
12003 STAR (assumed) array
12004 size. */
12005 break;
12006
12007 case FFEEXPR_contextDATAIMPDOITEM_:
12008 error = (expr == NULL)
12009 || (ffebld_op (expr) != FFEBLD_opARRAYREF)
12010 || ((ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR)
12011 && (ffeinfo_where (info) != FFEINFO_whereFLEETING_IADDR));
12012 break;
12013
12014 case FFEEXPR_contextDATAIMPDOINDEX_:
12015 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12016 break;
12017 switch (ffeinfo_basictype (info))
12018 {
12019 case FFEINFO_basictypeLOGICAL:
12020 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12021 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12022 FFEEXPR_contextLET);
12023 /* Fall through. */
12024 case FFEINFO_basictypeREAL:
12025 case FFEINFO_basictypeCOMPLEX:
12026 if (ffe_is_pedantic ())
12027 {
12028 error = TRUE;
12029 break;
12030 }
12031 /* Fall through. */
12032 case FFEINFO_basictypeINTEGER:
12033 case FFEINFO_basictypeHOLLERITH:
12034 case FFEINFO_basictypeTYPELESS:
12035 error = FALSE;
12036 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12037 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12038 FFEEXPR_contextLET);
12039 break;
12040
12041 default:
12042 error = TRUE;
12043 break;
12044 }
12045 if ((ffeinfo_where (info) != FFEINFO_whereCONSTANT)
12046 && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12047 error = TRUE;
12048 break;
12049
12050 case FFEEXPR_contextDATA:
12051 if (expr == NULL)
12052 error = TRUE;
12053 else if (ffeexpr_stack_->is_rhs)
12054 error = (ffebld_op (expr) != FFEBLD_opCONTER);
12055 else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12056 error = FALSE;
12057 else
12058 error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12059 break;
12060
12061 case FFEEXPR_contextINITVAL:
12062 error = (expr == NULL) || (ffebld_op (expr) != FFEBLD_opCONTER);
12063 break;
12064
12065 case FFEEXPR_contextEQUIVALENCE:
12066 if (expr == NULL)
12067 error = TRUE;
12068 else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12069 error = FALSE;
12070 else
12071 error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12072 break;
12073
12074 case FFEEXPR_contextFILEASSOC:
12075 case FFEEXPR_contextFILEINT:
12076 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12077 : ffeinfo_basictype (info))
12078 {
12079 case FFEINFO_basictypeINTEGER:
12080 /* Maybe this should be supported someday, but, right now,
12081 g77 can't generate a call to libf2c to write to an
12082 integer other than the default size. */
12083 error = ((! ffeexpr_stack_->is_rhs)
12084 && ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12085 break;
12086
12087 default:
12088 error = TRUE;
12089 break;
12090 }
12091 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12092 error = TRUE;
12093 break;
12094
12095 case FFEEXPR_contextFILEDFINT:
12096 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12097 : ffeinfo_basictype (info))
12098 {
12099 case FFEINFO_basictypeINTEGER:
12100 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12101 break;
12102
12103 default:
12104 error = TRUE;
12105 break;
12106 }
12107 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12108 error = TRUE;
12109 break;
12110
12111 case FFEEXPR_contextFILELOG:
12112 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12113 : ffeinfo_basictype (info))
12114 {
12115 case FFEINFO_basictypeLOGICAL:
12116 error = FALSE;
12117 break;
12118
12119 default:
12120 error = TRUE;
12121 break;
12122 }
12123 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12124 error = TRUE;
12125 break;
12126
12127 case FFEEXPR_contextFILECHAR:
12128 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12129 : ffeinfo_basictype (info))
12130 {
12131 case FFEINFO_basictypeCHARACTER:
12132 error = FALSE;
12133 break;
12134
12135 default:
12136 error = TRUE;
12137 break;
12138 }
12139 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12140 error = TRUE;
12141 break;
12142
12143 case FFEEXPR_contextFILENUMCHAR:
12144 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12145 break;
12146 switch (ffeinfo_basictype (info))
12147 {
12148 case FFEINFO_basictypeLOGICAL:
12149 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12150 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12151 FFEEXPR_contextLET);
12152 /* Fall through. */
12153 case FFEINFO_basictypeREAL:
12154 case FFEINFO_basictypeCOMPLEX:
12155 if (ffe_is_pedantic ())
12156 {
12157 error = TRUE;
12158 break;
12159 }
12160 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12161 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12162 FFEEXPR_contextLET);
12163 break;
12164
12165 case FFEINFO_basictypeINTEGER:
12166 case FFEINFO_basictypeCHARACTER:
12167 error = FALSE;
12168 break;
12169
12170 default:
12171 error = TRUE;
12172 break;
12173 }
12174 break;
12175
12176 case FFEEXPR_contextFILEDFCHAR:
12177 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12178 break;
12179 switch (ffeinfo_basictype (info))
12180 {
12181 case FFEINFO_basictypeCHARACTER:
12182 error
12183 = (ffeinfo_kindtype (info)
12184 != FFEINFO_kindtypeCHARACTERDEFAULT);
12185 break;
12186
12187 default:
12188 error = TRUE;
12189 break;
12190 }
12191 if (!ffeexpr_stack_->is_rhs
12192 && (ffebld_op (expr) == FFEBLD_opSUBSTR))
12193 error = TRUE;
12194 break;
12195
12196 case FFEEXPR_contextFILEUNIT: /* See equiv code in _ambig_. */
12197 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12198 : ffeinfo_basictype (info))
12199 {
12200 case FFEINFO_basictypeLOGICAL:
12201 if ((error = (ffeinfo_rank (info) != 0)))
12202 break;
12203 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12204 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12205 FFEEXPR_contextLET);
12206 /* Fall through. */
12207 case FFEINFO_basictypeREAL:
12208 case FFEINFO_basictypeCOMPLEX:
12209 if ((error = (ffeinfo_rank (info) != 0)))
12210 break;
12211 if (ffe_is_pedantic ())
12212 {
12213 error = TRUE;
12214 break;
12215 }
12216 /* Fall through. */
12217 case FFEINFO_basictypeINTEGER:
12218 case FFEINFO_basictypeHOLLERITH:
12219 case FFEINFO_basictypeTYPELESS:
12220 if ((error = (ffeinfo_rank (info) != 0)))
12221 break;
12222 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12223 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12224 FFEEXPR_contextLET);
12225 break;
12226
12227 case FFEINFO_basictypeCHARACTER:
12228 switch (ffebld_op (expr))
12229 { /* As if _lhs had been called instead of
12230 _rhs. */
12231 case FFEBLD_opSYMTER:
12232 error
12233 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
12234 break;
12235
12236 case FFEBLD_opSUBSTR:
12237 error = (ffeinfo_where (ffebld_info (expr))
12238 == FFEINFO_whereCONSTANT_SUBOBJECT);
12239 break;
12240
12241 case FFEBLD_opARRAYREF:
12242 error = FALSE;
12243 break;
12244
12245 default:
12246 error = TRUE;
12247 break;
12248 }
12249 if (!error
12250 && ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
12251 || ((ffeinfo_rank (info) != 0)
12252 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12253 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12254 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12255 == FFEBLD_opSTAR))))) /* Bad if
12256 non-default-kindtype
12257 character expr, or if
12258 array that is not a SYMTER
12259 (can't happen yet, I
12260 think), or has a NULL or
12261 STAR (assumed) array
12262 size. */
12263 error = TRUE;
12264 break;
12265
12266 default:
12267 error = TRUE;
12268 break;
12269 }
12270 break;
12271
12272 case FFEEXPR_contextFILEFORMAT:
12273 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12274 : ffeinfo_basictype (info))
12275 {
12276 case FFEINFO_basictypeINTEGER:
12277 error = (expr == NULL)
12278 || ((ffeinfo_rank (info) != 0) ?
12279 ffe_is_pedantic () /* F77 C5. */
12280 : (bool) (ffeinfo_kindtype (info) != ffecom_label_kind ()))
12281 || (ffebld_op (expr) != FFEBLD_opSYMTER);
12282 break;
12283
12284 case FFEINFO_basictypeLOGICAL:
12285 case FFEINFO_basictypeREAL:
12286 case FFEINFO_basictypeCOMPLEX:
12287 /* F77 C5 -- must be an array of hollerith. */
12288 error
12289 = ffe_is_pedantic ()
12290 || (ffeinfo_rank (info) == 0);
12291 break;
12292
12293 case FFEINFO_basictypeCHARACTER:
12294 if ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
12295 || ((ffeinfo_rank (info) != 0)
12296 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12297 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12298 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12299 == FFEBLD_opSTAR)))) /* Bad if
12300 non-default-kindtype
12301 character expr, or if
12302 array that is not a SYMTER
12303 (can't happen yet, I
12304 think), or has a NULL or
12305 STAR (assumed) array
12306 size. */
12307 error = TRUE;
12308 else
12309 error = FALSE;
12310 break;
12311
12312 default:
12313 error = TRUE;
12314 break;
12315 }
12316 break;
12317
12318 case FFEEXPR_contextLOC_:
12319 /* See also ffeintrin_check_loc_. */
12320 if ((expr == NULL)
12321 || (ffeinfo_kind (info) != FFEINFO_kindENTITY)
12322 || ((ffebld_op (expr) != FFEBLD_opSYMTER)
12323 && (ffebld_op (expr) != FFEBLD_opSUBSTR)
12324 && (ffebld_op (expr) != FFEBLD_opARRAYREF)))
12325 error = TRUE;
12326 break;
12327
12328 default:
12329 error = FALSE;
12330 break;
12331 }
12332
12333 if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
12334 {
12335 ffebad_start (FFEBAD_EXPR_WRONG);
12336 ffebad_here (0, ffelex_token_where_line (ft),
12337 ffelex_token_where_column (ft));
12338 ffebad_finish ();
12339 expr = ffebld_new_any ();
12340 ffebld_set_info (expr, ffeinfo_new_any ());
12341 }
12342
12343 callback = ffeexpr_stack_->callback;
12344 s = ffeexpr_stack_->previous;
12345 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
12346 sizeof (*ffeexpr_stack_));
12347 ffeexpr_stack_ = s;
12348 next = (ffelexHandler) (*callback) (ft, expr, t);
12349 ffelex_token_kill (ft);
12350 return (ffelexHandler) next;
12351 }
12352
12353 /* ffeexpr_finished_ambig_ -- Check validity of ambiguous unit/form spec
12354
12355 ffebld expr;
12356 expr = ffeexpr_finished_ambig_(expr);
12357
12358 Replicates a bit of ffeexpr_finished_'s task when in a context
12359 of UNIT or FORMAT. */
12360
12361 static ffebld
12362 ffeexpr_finished_ambig_ (ffelexToken ft, ffebld expr)
12363 {
12364 ffeinfo info = ffebld_info (expr);
12365 bool error;
12366
12367 switch (ffeexpr_stack_->context)
12368 {
12369 case FFEEXPR_contextFILENUMAMBIG: /* Same as FILENUM in _finished_. */
12370 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12371 : ffeinfo_basictype (info))
12372 {
12373 case FFEINFO_basictypeLOGICAL:
12374 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12375 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12376 FFEEXPR_contextLET);
12377 /* Fall through. */
12378 case FFEINFO_basictypeREAL:
12379 case FFEINFO_basictypeCOMPLEX:
12380 if (ffe_is_pedantic ())
12381 {
12382 error = TRUE;
12383 break;
12384 }
12385 /* Fall through. */
12386 case FFEINFO_basictypeINTEGER:
12387 case FFEINFO_basictypeHOLLERITH:
12388 case FFEINFO_basictypeTYPELESS:
12389 error = FALSE;
12390 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12391 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12392 FFEEXPR_contextLET);
12393 break;
12394
12395 default:
12396 error = TRUE;
12397 break;
12398 }
12399 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12400 error = TRUE;
12401 break;
12402
12403 case FFEEXPR_contextFILEUNITAMBIG: /* Same as FILEUNIT in _finished_. */
12404 if ((expr != NULL) && (ffebld_op (expr) == FFEBLD_opSTAR))
12405 {
12406 error = FALSE;
12407 break;
12408 }
12409 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12410 : ffeinfo_basictype (info))
12411 {
12412 case FFEINFO_basictypeLOGICAL:
12413 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12414 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12415 FFEEXPR_contextLET);
12416 /* Fall through. */
12417 case FFEINFO_basictypeREAL:
12418 case FFEINFO_basictypeCOMPLEX:
12419 if (ffe_is_pedantic ())
12420 {
12421 error = TRUE;
12422 break;
12423 }
12424 /* Fall through. */
12425 case FFEINFO_basictypeINTEGER:
12426 case FFEINFO_basictypeHOLLERITH:
12427 case FFEINFO_basictypeTYPELESS:
12428 error = (ffeinfo_rank (info) != 0);
12429 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12430 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12431 FFEEXPR_contextLET);
12432 break;
12433
12434 case FFEINFO_basictypeCHARACTER:
12435 switch (ffebld_op (expr))
12436 { /* As if _lhs had been called instead of
12437 _rhs. */
12438 case FFEBLD_opSYMTER:
12439 error
12440 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
12441 break;
12442
12443 case FFEBLD_opSUBSTR:
12444 error = (ffeinfo_where (ffebld_info (expr))
12445 == FFEINFO_whereCONSTANT_SUBOBJECT);
12446 break;
12447
12448 case FFEBLD_opARRAYREF:
12449 error = FALSE;
12450 break;
12451
12452 default:
12453 error = TRUE;
12454 break;
12455 }
12456 break;
12457
12458 default:
12459 error = TRUE;
12460 break;
12461 }
12462 break;
12463
12464 default:
12465 assert ("bad context" == NULL);
12466 error = TRUE;
12467 break;
12468 }
12469
12470 if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
12471 {
12472 ffebad_start (FFEBAD_EXPR_WRONG);
12473 ffebad_here (0, ffelex_token_where_line (ft),
12474 ffelex_token_where_column (ft));
12475 ffebad_finish ();
12476 expr = ffebld_new_any ();
12477 ffebld_set_info (expr, ffeinfo_new_any ());
12478 }
12479
12480 return expr;
12481 }
12482
12483 /* ffeexpr_token_lhs_ -- Initial state for lhs expression
12484
12485 Return a pointer to this function to the lexer (ffelex), which will
12486 invoke it for the next token.
12487
12488 Basically a smaller version of _rhs_; keep them both in sync, of course. */
12489
12490 static ffelexHandler
12491 ffeexpr_token_lhs_ (ffelexToken t)
12492 {
12493
12494 /* When changing the list of valid initial lhs tokens, check whether to
12495 update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
12496 READ (expr) <token> case -- it assumes it knows which tokens <token> can
12497 be to indicate an lhs (or implied DO), which right now is the set
12498 {NAME,OPEN_PAREN}.
12499
12500 This comment also appears in ffeexpr_token_first_lhs_. */
12501
12502 switch (ffelex_token_type (t))
12503 {
12504 case FFELEX_typeNAME:
12505 case FFELEX_typeNAMES:
12506 ffeexpr_tokens_[0] = ffelex_token_use (t);
12507 return (ffelexHandler) ffeexpr_token_name_lhs_;
12508
12509 default:
12510 return (ffelexHandler) ffeexpr_finished_ (t);
12511 }
12512 }
12513
12514 /* ffeexpr_token_rhs_ -- Initial state for rhs expression
12515
12516 Return a pointer to this function to the lexer (ffelex), which will
12517 invoke it for the next token.
12518
12519 The initial state and the post-binary-operator state are the same and
12520 both handled here, with the expression stack used to distinguish
12521 between them. Binary operators are invalid here; unary operators,
12522 constants, subexpressions, and name references are valid. */
12523
12524 static ffelexHandler
12525 ffeexpr_token_rhs_ (ffelexToken t)
12526 {
12527 ffeexprExpr_ e;
12528
12529 switch (ffelex_token_type (t))
12530 {
12531 case FFELEX_typeQUOTE:
12532 if (ffe_is_vxt ())
12533 {
12534 ffeexpr_tokens_[0] = ffelex_token_use (t);
12535 return (ffelexHandler) ffeexpr_token_quote_;
12536 }
12537 ffeexpr_tokens_[0] = ffelex_token_use (t);
12538 ffelex_set_expecting_hollerith (-1, '\"',
12539 ffelex_token_where_line (t),
12540 ffelex_token_where_column (t));
12541 /* Don't have to unset this one. */
12542 return (ffelexHandler) ffeexpr_token_apostrophe_;
12543
12544 case FFELEX_typeAPOSTROPHE:
12545 ffeexpr_tokens_[0] = ffelex_token_use (t);
12546 ffelex_set_expecting_hollerith (-1, '\'',
12547 ffelex_token_where_line (t),
12548 ffelex_token_where_column (t));
12549 /* Don't have to unset this one. */
12550 return (ffelexHandler) ffeexpr_token_apostrophe_;
12551
12552 case FFELEX_typePERCENT:
12553 ffeexpr_tokens_[0] = ffelex_token_use (t);
12554 return (ffelexHandler) ffeexpr_token_percent_;
12555
12556 case FFELEX_typeOPEN_PAREN:
12557 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
12558 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
12559 FFEEXPR_contextPAREN_,
12560 ffeexpr_cb_close_paren_c_);
12561
12562 case FFELEX_typePLUS:
12563 e = ffeexpr_expr_new_ ();
12564 e->type = FFEEXPR_exprtypeUNARY_;
12565 e->token = ffelex_token_use (t);
12566 e->u.operator.op = FFEEXPR_operatorADD_;
12567 e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
12568 e->u.operator.as = FFEEXPR_operatorassociativityADD_;
12569 ffeexpr_exprstack_push_unary_ (e);
12570 return (ffelexHandler) ffeexpr_token_rhs_;
12571
12572 case FFELEX_typeMINUS:
12573 e = ffeexpr_expr_new_ ();
12574 e->type = FFEEXPR_exprtypeUNARY_;
12575 e->token = ffelex_token_use (t);
12576 e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
12577 e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
12578 e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
12579 ffeexpr_exprstack_push_unary_ (e);
12580 return (ffelexHandler) ffeexpr_token_rhs_;
12581
12582 case FFELEX_typePERIOD:
12583 ffeexpr_tokens_[0] = ffelex_token_use (t);
12584 return (ffelexHandler) ffeexpr_token_period_;
12585
12586 case FFELEX_typeNUMBER:
12587 ffeexpr_tokens_[0] = ffelex_token_use (t);
12588 ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
12589 if (ffeexpr_hollerith_count_ > 0)
12590 ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
12591 '\0',
12592 ffelex_token_where_line (t),
12593 ffelex_token_where_column (t));
12594 return (ffelexHandler) ffeexpr_token_number_;
12595
12596 case FFELEX_typeNAME:
12597 case FFELEX_typeNAMES:
12598 ffeexpr_tokens_[0] = ffelex_token_use (t);
12599 switch (ffeexpr_stack_->context)
12600 {
12601 case FFEEXPR_contextACTUALARG_:
12602 case FFEEXPR_contextINDEXORACTUALARG_:
12603 case FFEEXPR_contextSFUNCDEFACTUALARG_:
12604 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
12605 return (ffelexHandler) ffeexpr_token_name_arg_;
12606
12607 default:
12608 return (ffelexHandler) ffeexpr_token_name_rhs_;
12609 }
12610
12611 case FFELEX_typeASTERISK:
12612 case FFELEX_typeSLASH:
12613 case FFELEX_typePOWER:
12614 case FFELEX_typeCONCAT:
12615 case FFELEX_typeREL_EQ:
12616 case FFELEX_typeREL_NE:
12617 case FFELEX_typeREL_LE:
12618 case FFELEX_typeREL_GE:
12619 if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
12620 {
12621 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
12622 ffebad_finish ();
12623 }
12624 return (ffelexHandler) ffeexpr_token_rhs_;
12625
12626 #if 0
12627 case FFELEX_typeEQUALS:
12628 case FFELEX_typePOINTS:
12629 case FFELEX_typeCLOSE_ANGLE:
12630 case FFELEX_typeCLOSE_PAREN:
12631 case FFELEX_typeCOMMA:
12632 case FFELEX_typeCOLON:
12633 case FFELEX_typeEOS:
12634 case FFELEX_typeSEMICOLON:
12635 #endif
12636 default:
12637 return (ffelexHandler) ffeexpr_finished_ (t);
12638 }
12639 }
12640
12641 /* ffeexpr_token_period_ -- Rhs PERIOD
12642
12643 Return a pointer to this function to the lexer (ffelex), which will
12644 invoke it for the next token.
12645
12646 Handle a period detected at rhs (expecting unary op or operand) state.
12647 Must begin a floating-point value (as in .12) or a dot-dot name, of
12648 which only .NOT., .TRUE., and .FALSE. are truly valid. Other sort-of-
12649 valid names represent binary operators, which are invalid here because
12650 there isn't an operand at the top of the stack. */
12651
12652 static ffelexHandler
12653 ffeexpr_token_period_ (ffelexToken t)
12654 {
12655 switch (ffelex_token_type (t))
12656 {
12657 case FFELEX_typeNAME:
12658 case FFELEX_typeNAMES:
12659 ffeexpr_current_dotdot_ = ffestr_other (t);
12660 switch (ffeexpr_current_dotdot_)
12661 {
12662 case FFESTR_otherNone:
12663 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
12664 {
12665 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
12666 ffelex_token_where_column (ffeexpr_tokens_[0]));
12667 ffebad_finish ();
12668 }
12669 ffelex_token_kill (ffeexpr_tokens_[0]);
12670 return (ffelexHandler) ffeexpr_token_rhs_ (t);
12671
12672 case FFESTR_otherTRUE:
12673 case FFESTR_otherFALSE:
12674 case FFESTR_otherNOT:
12675 ffeexpr_tokens_[1] = ffelex_token_use (t);
12676 return (ffelexHandler) ffeexpr_token_end_period_;
12677
12678 default:
12679 if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
12680 {
12681 ffebad_here (0, ffelex_token_where_line (t),
12682 ffelex_token_where_column (t));
12683 ffebad_finish ();
12684 }
12685 ffelex_token_kill (ffeexpr_tokens_[0]);
12686 return (ffelexHandler) ffeexpr_token_swallow_period_;
12687 }
12688 break; /* Nothing really reaches here. */
12689
12690 case FFELEX_typeNUMBER:
12691 ffeexpr_tokens_[1] = ffelex_token_use (t);
12692 return (ffelexHandler) ffeexpr_token_real_;
12693
12694 default:
12695 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
12696 {
12697 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
12698 ffelex_token_where_column (ffeexpr_tokens_[0]));
12699 ffebad_finish ();
12700 }
12701 ffelex_token_kill (ffeexpr_tokens_[0]);
12702 return (ffelexHandler) ffeexpr_token_rhs_ (t);
12703 }
12704 }
12705
12706 /* ffeexpr_token_end_period_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
12707
12708 Return a pointer to this function to the lexer (ffelex), which will
12709 invoke it for the next token.
12710
12711 Expecting a period to close a .NOT, .TRUE, or .FALSE at rhs (unary op
12712 or operator) state. If period isn't found, issue a diagnostic but
12713 pretend we saw one. ffeexpr_current_dotdot_ must already contained the
12714 dotdot representation of the name in between the two PERIOD tokens. */
12715
12716 static ffelexHandler
12717 ffeexpr_token_end_period_ (ffelexToken t)
12718 {
12719 ffeexprExpr_ e;
12720
12721 if (ffelex_token_type (t) != FFELEX_typePERIOD)
12722 {
12723 if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
12724 {
12725 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
12726 ffelex_token_where_column (ffeexpr_tokens_[0]));
12727 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
12728 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
12729 ffebad_finish ();
12730 }
12731 }
12732
12733 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill "NOT"/"TRUE"/"FALSE"
12734 token. */
12735
12736 e = ffeexpr_expr_new_ ();
12737 e->token = ffeexpr_tokens_[0];
12738
12739 switch (ffeexpr_current_dotdot_)
12740 {
12741 case FFESTR_otherNOT:
12742 e->type = FFEEXPR_exprtypeUNARY_;
12743 e->u.operator.op = FFEEXPR_operatorNOT_;
12744 e->u.operator.prec = FFEEXPR_operatorprecedenceNOT_;
12745 e->u.operator.as = FFEEXPR_operatorassociativityNOT_;
12746 ffeexpr_exprstack_push_unary_ (e);
12747 if (ffelex_token_type (t) != FFELEX_typePERIOD)
12748 return (ffelexHandler) ffeexpr_token_rhs_ (t);
12749 return (ffelexHandler) ffeexpr_token_rhs_;
12750
12751 case FFESTR_otherTRUE:
12752 e->type = FFEEXPR_exprtypeOPERAND_;
12753 e->u.operand
12754 = ffebld_new_conter (ffebld_constant_new_logicaldefault (TRUE));
12755 ffebld_set_info (e->u.operand,
12756 ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
12757 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
12758 ffeexpr_exprstack_push_operand_ (e);
12759 if (ffelex_token_type (t) != FFELEX_typePERIOD)
12760 return (ffelexHandler) ffeexpr_token_binary_ (t);
12761 return (ffelexHandler) ffeexpr_token_binary_;
12762
12763 case FFESTR_otherFALSE:
12764 e->type = FFEEXPR_exprtypeOPERAND_;
12765 e->u.operand
12766 = ffebld_new_conter (ffebld_constant_new_logicaldefault (FALSE));
12767 ffebld_set_info (e->u.operand,
12768 ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
12769 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
12770 ffeexpr_exprstack_push_operand_ (e);
12771 if (ffelex_token_type (t) != FFELEX_typePERIOD)
12772 return (ffelexHandler) ffeexpr_token_binary_ (t);
12773 return (ffelexHandler) ffeexpr_token_binary_;
12774
12775 default:
12776 assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL);
12777 exit (0);
12778 return NULL;
12779 }
12780 }
12781
12782 /* ffeexpr_token_swallow_period_ -- Rhs PERIOD NAME(not NOT, TRUE, or FALSE)
12783
12784 Return a pointer to this function to the lexer (ffelex), which will
12785 invoke it for the next token.
12786
12787 A diagnostic has already been issued; just swallow a period if there is
12788 one, then continue with ffeexpr_token_rhs_. */
12789
12790 static ffelexHandler
12791 ffeexpr_token_swallow_period_ (ffelexToken t)
12792 {
12793 if (ffelex_token_type (t) != FFELEX_typePERIOD)
12794 return (ffelexHandler) ffeexpr_token_rhs_ (t);
12795
12796 return (ffelexHandler) ffeexpr_token_rhs_;
12797 }
12798
12799 /* ffeexpr_token_real_ -- Rhs PERIOD NUMBER
12800
12801 Return a pointer to this function to the lexer (ffelex), which will
12802 invoke it for the next token.
12803
12804 After a period and a string of digits, check next token for possible
12805 exponent designation (D, E, or Q as first/only character) and continue
12806 real-number handling accordingly. Else form basic real constant, push
12807 onto expression stack, and enter binary state using current token (which,
12808 if it is a name not beginning with D, E, or Q, will certainly result
12809 in an error, but that's not for this routine to deal with). */
12810
12811 static ffelexHandler
12812 ffeexpr_token_real_ (ffelexToken t)
12813 {
12814 char d;
12815 const char *p;
12816
12817 if (((ffelex_token_type (t) != FFELEX_typeNAME)
12818 && (ffelex_token_type (t) != FFELEX_typeNAMES))
12819 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
12820 'D', 'd')
12821 || ffesrc_char_match_init (d, 'E', 'e')
12822 || ffesrc_char_match_init (d, 'Q', 'q')))
12823 && ffeexpr_isdigits_ (++p)))
12824 {
12825 #if 0
12826 /* This code has been removed because it seems inconsistent to
12827 produce a diagnostic in this case, but not all of the other
12828 ones that look for an exponent and cannot recognize one. */
12829 if (((ffelex_token_type (t) == FFELEX_typeNAME)
12830 || (ffelex_token_type (t) == FFELEX_typeNAMES))
12831 && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
12832 {
12833 char bad[2];
12834
12835 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
12836 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
12837 ffelex_token_where_column (ffeexpr_tokens_[0]));
12838 bad[0] = *(p - 1);
12839 bad[1] = '\0';
12840 ffebad_string (bad);
12841 ffebad_finish ();
12842 }
12843 #endif
12844 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
12845 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
12846 NULL, NULL, NULL);
12847
12848 ffelex_token_kill (ffeexpr_tokens_[0]);
12849 ffelex_token_kill (ffeexpr_tokens_[1]);
12850 return (ffelexHandler) ffeexpr_token_binary_ (t);
12851 }
12852
12853 /* Just exponent character by itself? In which case, PLUS or MINUS must
12854 surely be next, followed by a NUMBER token. */
12855
12856 if (*p == '\0')
12857 {
12858 ffeexpr_tokens_[2] = ffelex_token_use (t);
12859 return (ffelexHandler) ffeexpr_token_real_exponent_;
12860 }
12861
12862 ffeexpr_make_float_const_ (d, NULL, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
12863 t, NULL, NULL);
12864
12865 ffelex_token_kill (ffeexpr_tokens_[0]);
12866 ffelex_token_kill (ffeexpr_tokens_[1]);
12867 return (ffelexHandler) ffeexpr_token_binary_;
12868 }
12869
12870 /* ffeexpr_token_real_exponent_ -- Rhs PERIOD NUMBER NAME(D, E, or Q)
12871
12872 Return a pointer to this function to the lexer (ffelex), which will
12873 invoke it for the next token.
12874
12875 Ensures this token is PLUS or MINUS, preserves it, goes to final state
12876 for real number (exponent digits). Else issues diagnostic, assumes a
12877 zero exponent field for number, passes token on to binary state as if
12878 previous token had been "E0" instead of "E", for example. */
12879
12880 static ffelexHandler
12881 ffeexpr_token_real_exponent_ (ffelexToken t)
12882 {
12883 if ((ffelex_token_type (t) != FFELEX_typePLUS)
12884 && (ffelex_token_type (t) != FFELEX_typeMINUS))
12885 {
12886 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
12887 {
12888 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
12889 ffelex_token_where_column (ffeexpr_tokens_[2]));
12890 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
12891 ffebad_finish ();
12892 }
12893
12894 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
12895 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
12896 NULL, NULL, NULL);
12897
12898 ffelex_token_kill (ffeexpr_tokens_[0]);
12899 ffelex_token_kill (ffeexpr_tokens_[1]);
12900 ffelex_token_kill (ffeexpr_tokens_[2]);
12901 return (ffelexHandler) ffeexpr_token_binary_ (t);
12902 }
12903
12904 ffeexpr_tokens_[3] = ffelex_token_use (t);
12905 return (ffelexHandler) ffeexpr_token_real_exp_sign_;
12906 }
12907
12908 /* ffeexpr_token_real_exp_sign_ -- Rhs PERIOD NUMBER NAME(D,E,Q) PLUS/MINUS
12909
12910 Return a pointer to this function to the lexer (ffelex), which will
12911 invoke it for the next token.
12912
12913 Make sure token is a NUMBER, make a real constant out of all we have and
12914 push it onto the expression stack. Else issue diagnostic and pretend
12915 exponent field was a zero. */
12916
12917 static ffelexHandler
12918 ffeexpr_token_real_exp_sign_ (ffelexToken t)
12919 {
12920 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
12921 {
12922 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
12923 {
12924 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
12925 ffelex_token_where_column (ffeexpr_tokens_[2]));
12926 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
12927 ffebad_finish ();
12928 }
12929
12930 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
12931 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
12932 NULL, NULL, NULL);
12933
12934 ffelex_token_kill (ffeexpr_tokens_[0]);
12935 ffelex_token_kill (ffeexpr_tokens_[1]);
12936 ffelex_token_kill (ffeexpr_tokens_[2]);
12937 ffelex_token_kill (ffeexpr_tokens_[3]);
12938 return (ffelexHandler) ffeexpr_token_binary_ (t);
12939 }
12940
12941 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0], NULL,
12942 ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2],
12943 ffeexpr_tokens_[3], t);
12944
12945 ffelex_token_kill (ffeexpr_tokens_[0]);
12946 ffelex_token_kill (ffeexpr_tokens_[1]);
12947 ffelex_token_kill (ffeexpr_tokens_[2]);
12948 ffelex_token_kill (ffeexpr_tokens_[3]);
12949 return (ffelexHandler) ffeexpr_token_binary_;
12950 }
12951
12952 /* ffeexpr_token_number_ -- Rhs NUMBER
12953
12954 Return a pointer to this function to the lexer (ffelex), which will
12955 invoke it for the next token.
12956
12957 If the token is a period, we may have a floating-point number, or an
12958 integer followed by a dotdot binary operator. If the token is a name
12959 beginning with D, E, or Q, we definitely have a floating-point number.
12960 If the token is a hollerith constant, that's what we've got, so push
12961 it onto the expression stack and continue with the binary state.
12962
12963 Otherwise, we have an integer followed by something the binary state
12964 should be able to swallow. */
12965
12966 static ffelexHandler
12967 ffeexpr_token_number_ (ffelexToken t)
12968 {
12969 ffeexprExpr_ e;
12970 ffeinfo ni;
12971 char d;
12972 const char *p;
12973
12974 if (ffeexpr_hollerith_count_ > 0)
12975 ffelex_set_expecting_hollerith (0, '\0',
12976 ffewhere_line_unknown (),
12977 ffewhere_column_unknown ());
12978
12979 /* See if we've got a floating-point number here. */
12980
12981 switch (ffelex_token_type (t))
12982 {
12983 case FFELEX_typeNAME:
12984 case FFELEX_typeNAMES:
12985 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
12986 'D', 'd')
12987 || ffesrc_char_match_init (d, 'E', 'e')
12988 || ffesrc_char_match_init (d, 'Q', 'q'))
12989 && ffeexpr_isdigits_ (++p))
12990 {
12991
12992 /* Just exponent character by itself? In which case, PLUS or MINUS
12993 must surely be next, followed by a NUMBER token. */
12994
12995 if (*p == '\0')
12996 {
12997 ffeexpr_tokens_[1] = ffelex_token_use (t);
12998 return (ffelexHandler) ffeexpr_token_number_exponent_;
12999 }
13000 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], NULL, NULL, t,
13001 NULL, NULL);
13002
13003 ffelex_token_kill (ffeexpr_tokens_[0]);
13004 return (ffelexHandler) ffeexpr_token_binary_;
13005 }
13006 break;
13007
13008 case FFELEX_typePERIOD:
13009 ffeexpr_tokens_[1] = ffelex_token_use (t);
13010 return (ffelexHandler) ffeexpr_token_number_period_;
13011
13012 case FFELEX_typeHOLLERITH:
13013 e = ffeexpr_expr_new_ ();
13014 e->type = FFEEXPR_exprtypeOPERAND_;
13015 e->token = ffeexpr_tokens_[0];
13016 e->u.operand = ffebld_new_conter (ffebld_constant_new_hollerith (t));
13017 ni = ffeinfo_new (FFEINFO_basictypeHOLLERITH, FFEINFO_kindtypeNONE,
13018 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
13019 ffelex_token_length (t));
13020 ffebld_set_info (e->u.operand, ni);
13021 ffeexpr_exprstack_push_operand_ (e);
13022 return (ffelexHandler) ffeexpr_token_binary_;
13023
13024 default:
13025 break;
13026 }
13027
13028 /* Nothing specific we were looking for, so make an integer and pass the
13029 current token to the binary state. */
13030
13031 ffeexpr_make_float_const_ ('I', ffeexpr_tokens_[0], NULL, NULL,
13032 NULL, NULL, NULL);
13033 return (ffelexHandler) ffeexpr_token_binary_ (t);
13034 }
13035
13036 /* ffeexpr_token_number_exponent_ -- Rhs NUMBER NAME(D, E, or Q)
13037
13038 Return a pointer to this function to the lexer (ffelex), which will
13039 invoke it for the next token.
13040
13041 Ensures this token is PLUS or MINUS, preserves it, goes to final state
13042 for real number (exponent digits). Else treats number as integer, passes
13043 name to binary, passes current token to subsequent handler. */
13044
13045 static ffelexHandler
13046 ffeexpr_token_number_exponent_ (ffelexToken t)
13047 {
13048 if ((ffelex_token_type (t) != FFELEX_typePLUS)
13049 && (ffelex_token_type (t) != FFELEX_typeMINUS))
13050 {
13051 ffeexprExpr_ e;
13052 ffelexHandler nexthandler;
13053
13054 e = ffeexpr_expr_new_ ();
13055 e->type = FFEEXPR_exprtypeOPERAND_;
13056 e->token = ffeexpr_tokens_[0];
13057 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
13058 (ffeexpr_tokens_[0]));
13059 ffebld_set_info (e->u.operand,
13060 ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT,
13061 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13062 ffeexpr_exprstack_push_operand_ (e);
13063 nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[1]);
13064 ffelex_token_kill (ffeexpr_tokens_[1]);
13065 return (ffelexHandler) (*nexthandler) (t);
13066 }
13067
13068 ffeexpr_tokens_[2] = ffelex_token_use (t);
13069 return (ffelexHandler) ffeexpr_token_number_exp_sign_;
13070 }
13071
13072 /* ffeexpr_token_number_exp_sign_ -- Rhs NUMBER NAME(D,E,Q) PLUS/MINUS
13073
13074 Return a pointer to this function to the lexer (ffelex), which will
13075 invoke it for the next token.
13076
13077 Make sure token is a NUMBER, make a real constant out of all we have and
13078 push it onto the expression stack. Else issue diagnostic and pretend
13079 exponent field was a zero. */
13080
13081 static ffelexHandler
13082 ffeexpr_token_number_exp_sign_ (ffelexToken t)
13083 {
13084 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13085 {
13086 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13087 {
13088 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[1]),
13089 ffelex_token_where_column (ffeexpr_tokens_[1]));
13090 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13091 ffebad_finish ();
13092 }
13093
13094 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
13095 ffeexpr_tokens_[0], NULL, NULL,
13096 ffeexpr_tokens_[1], ffeexpr_tokens_[2],
13097 NULL);
13098
13099 ffelex_token_kill (ffeexpr_tokens_[0]);
13100 ffelex_token_kill (ffeexpr_tokens_[1]);
13101 ffelex_token_kill (ffeexpr_tokens_[2]);
13102 return (ffelexHandler) ffeexpr_token_binary_ (t);
13103 }
13104
13105 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
13106 ffeexpr_tokens_[0], NULL, NULL,
13107 ffeexpr_tokens_[1], ffeexpr_tokens_[2], t);
13108
13109 ffelex_token_kill (ffeexpr_tokens_[0]);
13110 ffelex_token_kill (ffeexpr_tokens_[1]);
13111 ffelex_token_kill (ffeexpr_tokens_[2]);
13112 return (ffelexHandler) ffeexpr_token_binary_;
13113 }
13114
13115 /* ffeexpr_token_number_period_ -- Rhs NUMBER PERIOD
13116
13117 Return a pointer to this function to the lexer (ffelex), which will
13118 invoke it for the next token.
13119
13120 Handle a period detected following a number at rhs state. Must begin a
13121 floating-point value (as in 1., 1.2, 1.E3, or 1.E+3) or a dot-dot name. */
13122
13123 static ffelexHandler
13124 ffeexpr_token_number_period_ (ffelexToken t)
13125 {
13126 ffeexprExpr_ e;
13127 ffelexHandler nexthandler;
13128 const char *p;
13129 char d;
13130
13131 switch (ffelex_token_type (t))
13132 {
13133 case FFELEX_typeNAME:
13134 case FFELEX_typeNAMES:
13135 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13136 'D', 'd')
13137 || ffesrc_char_match_init (d, 'E', 'e')
13138 || ffesrc_char_match_init (d, 'Q', 'q'))
13139 && ffeexpr_isdigits_ (++p))
13140 {
13141
13142 /* Just exponent character by itself? In which case, PLUS or MINUS
13143 must surely be next, followed by a NUMBER token. */
13144
13145 if (*p == '\0')
13146 {
13147 ffeexpr_tokens_[2] = ffelex_token_use (t);
13148 return (ffelexHandler) ffeexpr_token_number_per_exp_;
13149 }
13150 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0],
13151 ffeexpr_tokens_[1], NULL, t, NULL,
13152 NULL);
13153
13154 ffelex_token_kill (ffeexpr_tokens_[0]);
13155 ffelex_token_kill (ffeexpr_tokens_[1]);
13156 return (ffelexHandler) ffeexpr_token_binary_;
13157 }
13158 /* A name not representing an exponent, so assume it will be something
13159 like EQ, make an integer from the number, pass the period to binary
13160 state and the current token to the resulting state. */
13161
13162 e = ffeexpr_expr_new_ ();
13163 e->type = FFEEXPR_exprtypeOPERAND_;
13164 e->token = ffeexpr_tokens_[0];
13165 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
13166 (ffeexpr_tokens_[0]));
13167 ffebld_set_info (e->u.operand,
13168 ffeinfo_new (FFEINFO_basictypeINTEGER,
13169 FFEINFO_kindtypeINTEGERDEFAULT, 0,
13170 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
13171 FFETARGET_charactersizeNONE));
13172 ffeexpr_exprstack_push_operand_ (e);
13173 nexthandler = (ffelexHandler) ffeexpr_token_binary_
13174 (ffeexpr_tokens_[1]);
13175 ffelex_token_kill (ffeexpr_tokens_[1]);
13176 return (ffelexHandler) (*nexthandler) (t);
13177
13178 case FFELEX_typeNUMBER:
13179 ffeexpr_tokens_[2] = ffelex_token_use (t);
13180 return (ffelexHandler) ffeexpr_token_number_real_;
13181
13182 default:
13183 break;
13184 }
13185
13186 /* Nothing specific we were looking for, so make a real number and pass the
13187 period and then the current token to the binary state. */
13188
13189 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13190 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13191 NULL, NULL, NULL, NULL);
13192
13193 ffelex_token_kill (ffeexpr_tokens_[0]);
13194 ffelex_token_kill (ffeexpr_tokens_[1]);
13195 return (ffelexHandler) ffeexpr_token_binary_ (t);
13196 }
13197
13198 /* ffeexpr_token_number_per_exp_ -- Rhs NUMBER PERIOD NAME(D, E, or Q)
13199
13200 Return a pointer to this function to the lexer (ffelex), which will
13201 invoke it for the next token.
13202
13203 Ensures this token is PLUS or MINUS, preserves it, goes to final state
13204 for real number (exponent digits). Else treats number as real, passes
13205 name to binary, passes current token to subsequent handler. */
13206
13207 static ffelexHandler
13208 ffeexpr_token_number_per_exp_ (ffelexToken t)
13209 {
13210 if ((ffelex_token_type (t) != FFELEX_typePLUS)
13211 && (ffelex_token_type (t) != FFELEX_typeMINUS))
13212 {
13213 ffelexHandler nexthandler;
13214
13215 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13216 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13217 NULL, NULL, NULL, NULL);
13218
13219 ffelex_token_kill (ffeexpr_tokens_[0]);
13220 ffelex_token_kill (ffeexpr_tokens_[1]);
13221 nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[2]);
13222 ffelex_token_kill (ffeexpr_tokens_[2]);
13223 return (ffelexHandler) (*nexthandler) (t);
13224 }
13225
13226 ffeexpr_tokens_[3] = ffelex_token_use (t);
13227 return (ffelexHandler) ffeexpr_token_num_per_exp_sign_;
13228 }
13229
13230 /* ffeexpr_token_number_real_ -- Rhs NUMBER PERIOD NUMBER
13231
13232 Return a pointer to this function to the lexer (ffelex), which will
13233 invoke it for the next token.
13234
13235 After a number, period, and number, check next token for possible
13236 exponent designation (D, E, or Q as first/only character) and continue
13237 real-number handling accordingly. Else form basic real constant, push
13238 onto expression stack, and enter binary state using current token (which,
13239 if it is a name not beginning with D, E, or Q, will certainly result
13240 in an error, but that's not for this routine to deal with). */
13241
13242 static ffelexHandler
13243 ffeexpr_token_number_real_ (ffelexToken t)
13244 {
13245 char d;
13246 const char *p;
13247
13248 if (((ffelex_token_type (t) != FFELEX_typeNAME)
13249 && (ffelex_token_type (t) != FFELEX_typeNAMES))
13250 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13251 'D', 'd')
13252 || ffesrc_char_match_init (d, 'E', 'e')
13253 || ffesrc_char_match_init (d, 'Q', 'q')))
13254 && ffeexpr_isdigits_ (++p)))
13255 {
13256 #if 0
13257 /* This code has been removed because it seems inconsistent to
13258 produce a diagnostic in this case, but not all of the other
13259 ones that look for an exponent and cannot recognize one. */
13260 if (((ffelex_token_type (t) == FFELEX_typeNAME)
13261 || (ffelex_token_type (t) == FFELEX_typeNAMES))
13262 && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
13263 {
13264 char bad[2];
13265
13266 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13267 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
13268 ffelex_token_where_column (ffeexpr_tokens_[0]));
13269 bad[0] = *(p - 1);
13270 bad[1] = '\0';
13271 ffebad_string (bad);
13272 ffebad_finish ();
13273 }
13274 #endif
13275 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13276 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13277 ffeexpr_tokens_[2], NULL, NULL, NULL);
13278
13279 ffelex_token_kill (ffeexpr_tokens_[0]);
13280 ffelex_token_kill (ffeexpr_tokens_[1]);
13281 ffelex_token_kill (ffeexpr_tokens_[2]);
13282 return (ffelexHandler) ffeexpr_token_binary_ (t);
13283 }
13284
13285 /* Just exponent character by itself? In which case, PLUS or MINUS must
13286 surely be next, followed by a NUMBER token. */
13287
13288 if (*p == '\0')
13289 {
13290 ffeexpr_tokens_[3] = ffelex_token_use (t);
13291 return (ffelexHandler) ffeexpr_token_number_real_exp_;
13292 }
13293
13294 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13295 ffeexpr_tokens_[2], t, NULL, NULL);
13296
13297 ffelex_token_kill (ffeexpr_tokens_[0]);
13298 ffelex_token_kill (ffeexpr_tokens_[1]);
13299 ffelex_token_kill (ffeexpr_tokens_[2]);
13300 return (ffelexHandler) ffeexpr_token_binary_;
13301 }
13302
13303 /* ffeexpr_token_num_per_exp_sign_ -- Rhs NUMBER PERIOD NAME(D,E,Q) PLUS/MINUS
13304
13305 Return a pointer to this function to the lexer (ffelex), which will
13306 invoke it for the next token.
13307
13308 Make sure token is a NUMBER, make a real constant out of all we have and
13309 push it onto the expression stack. Else issue diagnostic and pretend
13310 exponent field was a zero. */
13311
13312 static ffelexHandler
13313 ffeexpr_token_num_per_exp_sign_ (ffelexToken t)
13314 {
13315 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13316 {
13317 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13318 {
13319 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
13320 ffelex_token_where_column (ffeexpr_tokens_[2]));
13321 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13322 ffebad_finish ();
13323 }
13324
13325 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13326 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13327 NULL, NULL, NULL, NULL);
13328
13329 ffelex_token_kill (ffeexpr_tokens_[0]);
13330 ffelex_token_kill (ffeexpr_tokens_[1]);
13331 ffelex_token_kill (ffeexpr_tokens_[2]);
13332 ffelex_token_kill (ffeexpr_tokens_[3]);
13333 return (ffelexHandler) ffeexpr_token_binary_ (t);
13334 }
13335
13336 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0],
13337 ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL,
13338 ffeexpr_tokens_[2], ffeexpr_tokens_[3], t);
13339
13340 ffelex_token_kill (ffeexpr_tokens_[0]);
13341 ffelex_token_kill (ffeexpr_tokens_[1]);
13342 ffelex_token_kill (ffeexpr_tokens_[2]);
13343 ffelex_token_kill (ffeexpr_tokens_[3]);
13344 return (ffelexHandler) ffeexpr_token_binary_;
13345 }
13346
13347 /* ffeexpr_token_number_real_exp_ -- Rhs NUMBER PERIOD NUMBER NAME(D, E, or Q)
13348
13349 Return a pointer to this function to the lexer (ffelex), which will
13350 invoke it for the next token.
13351
13352 Ensures this token is PLUS or MINUS, preserves it, goes to final state
13353 for real number (exponent digits). Else issues diagnostic, assumes a
13354 zero exponent field for number, passes token on to binary state as if
13355 previous token had been "E0" instead of "E", for example. */
13356
13357 static ffelexHandler
13358 ffeexpr_token_number_real_exp_ (ffelexToken t)
13359 {
13360 if ((ffelex_token_type (t) != FFELEX_typePLUS)
13361 && (ffelex_token_type (t) != FFELEX_typeMINUS))
13362 {
13363 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13364 {
13365 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
13366 ffelex_token_where_column (ffeexpr_tokens_[3]));
13367 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13368 ffebad_finish ();
13369 }
13370
13371 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13372 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13373 ffeexpr_tokens_[2], NULL, NULL, NULL);
13374
13375 ffelex_token_kill (ffeexpr_tokens_[0]);
13376 ffelex_token_kill (ffeexpr_tokens_[1]);
13377 ffelex_token_kill (ffeexpr_tokens_[2]);
13378 ffelex_token_kill (ffeexpr_tokens_[3]);
13379 return (ffelexHandler) ffeexpr_token_binary_ (t);
13380 }
13381
13382 ffeexpr_tokens_[4] = ffelex_token_use (t);
13383 return (ffelexHandler) ffeexpr_token_num_real_exp_sn_;
13384 }
13385
13386 /* ffeexpr_token_num_real_exp_sn_ -- Rhs NUMBER PERIOD NUMBER NAME(D,E,Q)
13387 PLUS/MINUS
13388
13389 Return a pointer to this function to the lexer (ffelex), which will
13390 invoke it for the next token.
13391
13392 Make sure token is a NUMBER, make a real constant out of all we have and
13393 push it onto the expression stack. Else issue diagnostic and pretend
13394 exponent field was a zero. */
13395
13396 static ffelexHandler
13397 ffeexpr_token_num_real_exp_sn_ (ffelexToken t)
13398 {
13399 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13400 {
13401 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13402 {
13403 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
13404 ffelex_token_where_column (ffeexpr_tokens_[3]));
13405 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13406 ffebad_finish ();
13407 }
13408
13409 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13410 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13411 ffeexpr_tokens_[2], NULL, NULL, NULL);
13412
13413 ffelex_token_kill (ffeexpr_tokens_[0]);
13414 ffelex_token_kill (ffeexpr_tokens_[1]);
13415 ffelex_token_kill (ffeexpr_tokens_[2]);
13416 ffelex_token_kill (ffeexpr_tokens_[3]);
13417 ffelex_token_kill (ffeexpr_tokens_[4]);
13418 return (ffelexHandler) ffeexpr_token_binary_ (t);
13419 }
13420
13421 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[3])[0],
13422 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13423 ffeexpr_tokens_[2], ffeexpr_tokens_[3],
13424 ffeexpr_tokens_[4], t);
13425
13426 ffelex_token_kill (ffeexpr_tokens_[0]);
13427 ffelex_token_kill (ffeexpr_tokens_[1]);
13428 ffelex_token_kill (ffeexpr_tokens_[2]);
13429 ffelex_token_kill (ffeexpr_tokens_[3]);
13430 ffelex_token_kill (ffeexpr_tokens_[4]);
13431 return (ffelexHandler) ffeexpr_token_binary_;
13432 }
13433
13434 /* ffeexpr_token_binary_ -- Handle binary operator possibility
13435
13436 Return a pointer to this function to the lexer (ffelex), which will
13437 invoke it for the next token.
13438
13439 The possibility of a binary operator is handled here, meaning the previous
13440 token was an operand. */
13441
13442 static ffelexHandler
13443 ffeexpr_token_binary_ (ffelexToken t)
13444 {
13445 ffeexprExpr_ e;
13446
13447 if (!ffeexpr_stack_->is_rhs)
13448 return (ffelexHandler) ffeexpr_finished_ (t); /* For now. */
13449
13450 switch (ffelex_token_type (t))
13451 {
13452 case FFELEX_typePLUS:
13453 e = ffeexpr_expr_new_ ();
13454 e->type = FFEEXPR_exprtypeBINARY_;
13455 e->token = ffelex_token_use (t);
13456 e->u.operator.op = FFEEXPR_operatorADD_;
13457 e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
13458 e->u.operator.as = FFEEXPR_operatorassociativityADD_;
13459 ffeexpr_exprstack_push_binary_ (e);
13460 return (ffelexHandler) ffeexpr_token_rhs_;
13461
13462 case FFELEX_typeMINUS:
13463 e = ffeexpr_expr_new_ ();
13464 e->type = FFEEXPR_exprtypeBINARY_;
13465 e->token = ffelex_token_use (t);
13466 e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
13467 e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
13468 e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
13469 ffeexpr_exprstack_push_binary_ (e);
13470 return (ffelexHandler) ffeexpr_token_rhs_;
13471
13472 case FFELEX_typeASTERISK:
13473 switch (ffeexpr_stack_->context)
13474 {
13475 case FFEEXPR_contextDATA:
13476 return (ffelexHandler) ffeexpr_finished_ (t);
13477
13478 default:
13479 break;
13480 }
13481 e = ffeexpr_expr_new_ ();
13482 e->type = FFEEXPR_exprtypeBINARY_;
13483 e->token = ffelex_token_use (t);
13484 e->u.operator.op = FFEEXPR_operatorMULTIPLY_;
13485 e->u.operator.prec = FFEEXPR_operatorprecedenceMULTIPLY_;
13486 e->u.operator.as = FFEEXPR_operatorassociativityMULTIPLY_;
13487 ffeexpr_exprstack_push_binary_ (e);
13488 return (ffelexHandler) ffeexpr_token_rhs_;
13489
13490 case FFELEX_typeSLASH:
13491 switch (ffeexpr_stack_->context)
13492 {
13493 case FFEEXPR_contextDATA:
13494 return (ffelexHandler) ffeexpr_finished_ (t);
13495
13496 default:
13497 break;
13498 }
13499 e = ffeexpr_expr_new_ ();
13500 e->type = FFEEXPR_exprtypeBINARY_;
13501 e->token = ffelex_token_use (t);
13502 e->u.operator.op = FFEEXPR_operatorDIVIDE_;
13503 e->u.operator.prec = FFEEXPR_operatorprecedenceDIVIDE_;
13504 e->u.operator.as = FFEEXPR_operatorassociativityDIVIDE_;
13505 ffeexpr_exprstack_push_binary_ (e);
13506 return (ffelexHandler) ffeexpr_token_rhs_;
13507
13508 case FFELEX_typePOWER:
13509 e = ffeexpr_expr_new_ ();
13510 e->type = FFEEXPR_exprtypeBINARY_;
13511 e->token = ffelex_token_use (t);
13512 e->u.operator.op = FFEEXPR_operatorPOWER_;
13513 e->u.operator.prec = FFEEXPR_operatorprecedencePOWER_;
13514 e->u.operator.as = FFEEXPR_operatorassociativityPOWER_;
13515 ffeexpr_exprstack_push_binary_ (e);
13516 return (ffelexHandler) ffeexpr_token_rhs_;
13517
13518 case FFELEX_typeCONCAT:
13519 e = ffeexpr_expr_new_ ();
13520 e->type = FFEEXPR_exprtypeBINARY_;
13521 e->token = ffelex_token_use (t);
13522 e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
13523 e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
13524 e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
13525 ffeexpr_exprstack_push_binary_ (e);
13526 return (ffelexHandler) ffeexpr_token_rhs_;
13527
13528 case FFELEX_typeOPEN_ANGLE:
13529 switch (ffeexpr_stack_->context)
13530 {
13531 case FFEEXPR_contextFORMAT:
13532 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13533 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13534 ffebad_finish ();
13535 break;
13536
13537 default:
13538 break;
13539 }
13540 e = ffeexpr_expr_new_ ();
13541 e->type = FFEEXPR_exprtypeBINARY_;
13542 e->token = ffelex_token_use (t);
13543 e->u.operator.op = FFEEXPR_operatorLT_;
13544 e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
13545 e->u.operator.as = FFEEXPR_operatorassociativityLT_;
13546 ffeexpr_exprstack_push_binary_ (e);
13547 return (ffelexHandler) ffeexpr_token_rhs_;
13548
13549 case FFELEX_typeCLOSE_ANGLE:
13550 switch (ffeexpr_stack_->context)
13551 {
13552 case FFEEXPR_contextFORMAT:
13553 return ffeexpr_finished_ (t);
13554
13555 default:
13556 break;
13557 }
13558 e = ffeexpr_expr_new_ ();
13559 e->type = FFEEXPR_exprtypeBINARY_;
13560 e->token = ffelex_token_use (t);
13561 e->u.operator.op = FFEEXPR_operatorGT_;
13562 e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
13563 e->u.operator.as = FFEEXPR_operatorassociativityGT_;
13564 ffeexpr_exprstack_push_binary_ (e);
13565 return (ffelexHandler) ffeexpr_token_rhs_;
13566
13567 case FFELEX_typeREL_EQ:
13568 switch (ffeexpr_stack_->context)
13569 {
13570 case FFEEXPR_contextFORMAT:
13571 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13572 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13573 ffebad_finish ();
13574 break;
13575
13576 default:
13577 break;
13578 }
13579 e = ffeexpr_expr_new_ ();
13580 e->type = FFEEXPR_exprtypeBINARY_;
13581 e->token = ffelex_token_use (t);
13582 e->u.operator.op = FFEEXPR_operatorEQ_;
13583 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
13584 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
13585 ffeexpr_exprstack_push_binary_ (e);
13586 return (ffelexHandler) ffeexpr_token_rhs_;
13587
13588 case FFELEX_typeREL_NE:
13589 switch (ffeexpr_stack_->context)
13590 {
13591 case FFEEXPR_contextFORMAT:
13592 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13593 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13594 ffebad_finish ();
13595 break;
13596
13597 default:
13598 break;
13599 }
13600 e = ffeexpr_expr_new_ ();
13601 e->type = FFEEXPR_exprtypeBINARY_;
13602 e->token = ffelex_token_use (t);
13603 e->u.operator.op = FFEEXPR_operatorNE_;
13604 e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
13605 e->u.operator.as = FFEEXPR_operatorassociativityNE_;
13606 ffeexpr_exprstack_push_binary_ (e);
13607 return (ffelexHandler) ffeexpr_token_rhs_;
13608
13609 case FFELEX_typeREL_LE:
13610 switch (ffeexpr_stack_->context)
13611 {
13612 case FFEEXPR_contextFORMAT:
13613 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13614 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13615 ffebad_finish ();
13616 break;
13617
13618 default:
13619 break;
13620 }
13621 e = ffeexpr_expr_new_ ();
13622 e->type = FFEEXPR_exprtypeBINARY_;
13623 e->token = ffelex_token_use (t);
13624 e->u.operator.op = FFEEXPR_operatorLE_;
13625 e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
13626 e->u.operator.as = FFEEXPR_operatorassociativityLE_;
13627 ffeexpr_exprstack_push_binary_ (e);
13628 return (ffelexHandler) ffeexpr_token_rhs_;
13629
13630 case FFELEX_typeREL_GE:
13631 switch (ffeexpr_stack_->context)
13632 {
13633 case FFEEXPR_contextFORMAT:
13634 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
13635 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13636 ffebad_finish ();
13637 break;
13638
13639 default:
13640 break;
13641 }
13642 e = ffeexpr_expr_new_ ();
13643 e->type = FFEEXPR_exprtypeBINARY_;
13644 e->token = ffelex_token_use (t);
13645 e->u.operator.op = FFEEXPR_operatorGE_;
13646 e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
13647 e->u.operator.as = FFEEXPR_operatorassociativityGE_;
13648 ffeexpr_exprstack_push_binary_ (e);
13649 return (ffelexHandler) ffeexpr_token_rhs_;
13650
13651 case FFELEX_typePERIOD:
13652 ffeexpr_tokens_[0] = ffelex_token_use (t);
13653 return (ffelexHandler) ffeexpr_token_binary_period_;
13654
13655 #if 0
13656 case FFELEX_typeOPEN_PAREN:
13657 case FFELEX_typeCLOSE_PAREN:
13658 case FFELEX_typeEQUALS:
13659 case FFELEX_typePOINTS:
13660 case FFELEX_typeCOMMA:
13661 case FFELEX_typeCOLON:
13662 case FFELEX_typeEOS:
13663 case FFELEX_typeSEMICOLON:
13664 case FFELEX_typeNAME:
13665 case FFELEX_typeNAMES:
13666 #endif
13667 default:
13668 return (ffelexHandler) ffeexpr_finished_ (t);
13669 }
13670 }
13671
13672 /* ffeexpr_token_binary_period_ -- Binary PERIOD
13673
13674 Return a pointer to this function to the lexer (ffelex), which will
13675 invoke it for the next token.
13676
13677 Handle a period detected at binary (expecting binary op or end) state.
13678 Must begin a dot-dot name, of which .NOT., .TRUE., and .FALSE. are not
13679 valid. */
13680
13681 static ffelexHandler
13682 ffeexpr_token_binary_period_ (ffelexToken t)
13683 {
13684 ffeexprExpr_ operand;
13685
13686 switch (ffelex_token_type (t))
13687 {
13688 case FFELEX_typeNAME:
13689 case FFELEX_typeNAMES:
13690 ffeexpr_current_dotdot_ = ffestr_other (t);
13691 switch (ffeexpr_current_dotdot_)
13692 {
13693 case FFESTR_otherTRUE:
13694 case FFESTR_otherFALSE:
13695 case FFESTR_otherNOT:
13696 if (ffest_ffebad_start (FFEBAD_MISSING_BINARY_OPERATOR))
13697 {
13698 operand = ffeexpr_stack_->exprstack;
13699 assert (operand != NULL);
13700 assert (operand->type == FFEEXPR_exprtypeOPERAND_);
13701 ffebad_here (0, ffelex_token_where_line (operand->token), ffelex_token_where_column (operand->token));
13702 ffebad_here (1, ffelex_token_where_line (t),
13703 ffelex_token_where_column (t));
13704 ffebad_finish ();
13705 }
13706 ffelex_token_kill (ffeexpr_tokens_[0]);
13707 return (ffelexHandler) ffeexpr_token_binary_sw_per_;
13708
13709 default:
13710 ffeexpr_tokens_[1] = ffelex_token_use (t);
13711 return (ffelexHandler) ffeexpr_token_binary_end_per_;
13712 }
13713 break; /* Nothing really reaches here. */
13714
13715 default:
13716 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
13717 {
13718 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13719 ffelex_token_where_column (ffeexpr_tokens_[0]));
13720 ffebad_finish ();
13721 }
13722 ffelex_token_kill (ffeexpr_tokens_[0]);
13723 return (ffelexHandler) ffeexpr_token_binary_ (t);
13724 }
13725 }
13726
13727 /* ffeexpr_token_binary_end_per_ -- Binary PERIOD NAME(not NOT, TRUE, or FALSE)
13728
13729 Return a pointer to this function to the lexer (ffelex), which will
13730 invoke it for the next token.
13731
13732 Expecting a period to close a dot-dot at binary (binary op
13733 or operator) state. If period isn't found, issue a diagnostic but
13734 pretend we saw one. ffeexpr_current_dotdot_ must already contained the
13735 dotdot representation of the name in between the two PERIOD tokens. */
13736
13737 static ffelexHandler
13738 ffeexpr_token_binary_end_per_ (ffelexToken t)
13739 {
13740 ffeexprExpr_ e;
13741
13742 e = ffeexpr_expr_new_ ();
13743 e->type = FFEEXPR_exprtypeBINARY_;
13744 e->token = ffeexpr_tokens_[0];
13745
13746 switch (ffeexpr_current_dotdot_)
13747 {
13748 case FFESTR_otherAND:
13749 e->u.operator.op = FFEEXPR_operatorAND_;
13750 e->u.operator.prec = FFEEXPR_operatorprecedenceAND_;
13751 e->u.operator.as = FFEEXPR_operatorassociativityAND_;
13752 break;
13753
13754 case FFESTR_otherOR:
13755 e->u.operator.op = FFEEXPR_operatorOR_;
13756 e->u.operator.prec = FFEEXPR_operatorprecedenceOR_;
13757 e->u.operator.as = FFEEXPR_operatorassociativityOR_;
13758 break;
13759
13760 case FFESTR_otherXOR:
13761 e->u.operator.op = FFEEXPR_operatorXOR_;
13762 e->u.operator.prec = FFEEXPR_operatorprecedenceXOR_;
13763 e->u.operator.as = FFEEXPR_operatorassociativityXOR_;
13764 break;
13765
13766 case FFESTR_otherEQV:
13767 e->u.operator.op = FFEEXPR_operatorEQV_;
13768 e->u.operator.prec = FFEEXPR_operatorprecedenceEQV_;
13769 e->u.operator.as = FFEEXPR_operatorassociativityEQV_;
13770 break;
13771
13772 case FFESTR_otherNEQV:
13773 e->u.operator.op = FFEEXPR_operatorNEQV_;
13774 e->u.operator.prec = FFEEXPR_operatorprecedenceNEQV_;
13775 e->u.operator.as = FFEEXPR_operatorassociativityNEQV_;
13776 break;
13777
13778 case FFESTR_otherLT:
13779 e->u.operator.op = FFEEXPR_operatorLT_;
13780 e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
13781 e->u.operator.as = FFEEXPR_operatorassociativityLT_;
13782 break;
13783
13784 case FFESTR_otherLE:
13785 e->u.operator.op = FFEEXPR_operatorLE_;
13786 e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
13787 e->u.operator.as = FFEEXPR_operatorassociativityLE_;
13788 break;
13789
13790 case FFESTR_otherEQ:
13791 e->u.operator.op = FFEEXPR_operatorEQ_;
13792 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
13793 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
13794 break;
13795
13796 case FFESTR_otherNE:
13797 e->u.operator.op = FFEEXPR_operatorNE_;
13798 e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
13799 e->u.operator.as = FFEEXPR_operatorassociativityNE_;
13800 break;
13801
13802 case FFESTR_otherGT:
13803 e->u.operator.op = FFEEXPR_operatorGT_;
13804 e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
13805 e->u.operator.as = FFEEXPR_operatorassociativityGT_;
13806 break;
13807
13808 case FFESTR_otherGE:
13809 e->u.operator.op = FFEEXPR_operatorGE_;
13810 e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
13811 e->u.operator.as = FFEEXPR_operatorassociativityGE_;
13812 break;
13813
13814 default:
13815 if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT))
13816 {
13817 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13818 ffelex_token_where_column (ffeexpr_tokens_[0]));
13819 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
13820 ffebad_finish ();
13821 }
13822 e->u.operator.op = FFEEXPR_operatorEQ_;
13823 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
13824 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
13825 break;
13826 }
13827
13828 ffeexpr_exprstack_push_binary_ (e);
13829
13830 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13831 {
13832 if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
13833 {
13834 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13835 ffelex_token_where_column (ffeexpr_tokens_[0]));
13836 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13837 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
13838 ffebad_finish ();
13839 }
13840 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */
13841 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13842 }
13843
13844 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */
13845 return (ffelexHandler) ffeexpr_token_rhs_;
13846 }
13847
13848 /* ffeexpr_token_binary_sw_per_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
13849
13850 Return a pointer to this function to the lexer (ffelex), which will
13851 invoke it for the next token.
13852
13853 A diagnostic has already been issued; just swallow a period if there is
13854 one, then continue with ffeexpr_token_binary_. */
13855
13856 static ffelexHandler
13857 ffeexpr_token_binary_sw_per_ (ffelexToken t)
13858 {
13859 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13860 return (ffelexHandler) ffeexpr_token_binary_ (t);
13861
13862 return (ffelexHandler) ffeexpr_token_binary_;
13863 }
13864
13865 /* ffeexpr_token_quote_ -- Rhs QUOTE
13866
13867 Return a pointer to this function to the lexer (ffelex), which will
13868 invoke it for the next token.
13869
13870 Expecting a NUMBER that we'll treat as an octal integer. */
13871
13872 static ffelexHandler
13873 ffeexpr_token_quote_ (ffelexToken t)
13874 {
13875 ffeexprExpr_ e;
13876 ffebld anyexpr;
13877
13878 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13879 {
13880 if (ffest_ffebad_start (FFEBAD_QUOTE_MISSES_DIGITS))
13881 {
13882 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13883 ffelex_token_where_column (ffeexpr_tokens_[0]));
13884 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13885 ffebad_finish ();
13886 }
13887 ffelex_token_kill (ffeexpr_tokens_[0]);
13888 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13889 }
13890
13891 /* This is kind of a kludge to prevent any whining about magical numbers
13892 that start out as these octal integers, so "20000000000 (on a 32-bit
13893 2's-complement machine) by itself won't produce an error. */
13894
13895 anyexpr = ffebld_new_any ();
13896 ffebld_set_info (anyexpr, ffeinfo_new_any ());
13897
13898 e = ffeexpr_expr_new_ ();
13899 e->type = FFEEXPR_exprtypeOPERAND_;
13900 e->token = ffeexpr_tokens_[0];
13901 e->u.operand = ffebld_new_conter_with_orig
13902 (ffebld_constant_new_integeroctal (t), anyexpr);
13903 ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER,
13904 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY,
13905 FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13906 ffeexpr_exprstack_push_operand_ (e);
13907 return (ffelexHandler) ffeexpr_token_binary_;
13908 }
13909
13910 /* ffeexpr_token_apostrophe_ -- Rhs APOSTROPHE
13911
13912 Return a pointer to this function to the lexer (ffelex), which will
13913 invoke it for the next token.
13914
13915 Handle an open-apostrophe, which begins either a character ('char-const'),
13916 typeless octal ('octal-const'O), or typeless hexadecimal ('hex-const'Z or
13917 'hex-const'X) constant. */
13918
13919 static ffelexHandler
13920 ffeexpr_token_apostrophe_ (ffelexToken t)
13921 {
13922 assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
13923 if (ffe_is_pedantic_not_90 () && (ffelex_token_length (t) == 0))
13924 {
13925 ffebad_start (FFEBAD_NULL_CHAR_CONST);
13926 ffebad_here (0, ffelex_token_where_line (t),
13927 ffelex_token_where_column (t));
13928 ffebad_finish ();
13929 }
13930 ffeexpr_tokens_[1] = ffelex_token_use (t);
13931 return (ffelexHandler) ffeexpr_token_apos_char_;
13932 }
13933
13934 /* ffeexpr_token_apos_char_ -- Rhs APOSTROPHE CHARACTER
13935
13936 Return a pointer to this function to the lexer (ffelex), which will
13937 invoke it for the next token.
13938
13939 Close-apostrophe is implicit; if this token is NAME, it is a possible
13940 typeless-constant radix specifier. */
13941
13942 static ffelexHandler
13943 ffeexpr_token_apos_char_ (ffelexToken t)
13944 {
13945 ffeexprExpr_ e;
13946 ffeinfo ni;
13947 char c;
13948 ffetargetCharacterSize size;
13949
13950 if ((ffelex_token_type (t) == FFELEX_typeNAME)
13951 || (ffelex_token_type (t) == FFELEX_typeNAMES))
13952 {
13953 if ((ffelex_token_length (t) == 1)
13954 && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]), 'B',
13955 'b')
13956 || ffesrc_char_match_init (c, 'O', 'o')
13957 || ffesrc_char_match_init (c, 'X', 'x')
13958 || ffesrc_char_match_init (c, 'Z', 'z')))
13959 {
13960 e = ffeexpr_expr_new_ ();
13961 e->type = FFEEXPR_exprtypeOPERAND_;
13962 e->token = ffeexpr_tokens_[0];
13963 switch (c)
13964 {
13965 case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
13966 e->u.operand = ffebld_new_conter
13967 (ffebld_constant_new_typeless_bv (ffeexpr_tokens_[1]));
13968 size = ffetarget_size_typeless_binary (ffeexpr_tokens_[1]);
13969 break;
13970
13971 case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
13972 e->u.operand = ffebld_new_conter
13973 (ffebld_constant_new_typeless_ov (ffeexpr_tokens_[1]));
13974 size = ffetarget_size_typeless_octal (ffeexpr_tokens_[1]);
13975 break;
13976
13977 case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
13978 e->u.operand = ffebld_new_conter
13979 (ffebld_constant_new_typeless_hxv (ffeexpr_tokens_[1]));
13980 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
13981 break;
13982
13983 case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
13984 e->u.operand = ffebld_new_conter
13985 (ffebld_constant_new_typeless_hzv (ffeexpr_tokens_[1]));
13986 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
13987 break;
13988
13989 default:
13990 no_match: /* :::::::::::::::::::: */
13991 assert ("not BOXZ!" == NULL);
13992 size = 0;
13993 break;
13994 }
13995 ffebld_set_info (e->u.operand,
13996 ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
13997 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
13998 ffeexpr_exprstack_push_operand_ (e);
13999 ffelex_token_kill (ffeexpr_tokens_[1]);
14000 return (ffelexHandler) ffeexpr_token_binary_;
14001 }
14002 }
14003 e = ffeexpr_expr_new_ ();
14004 e->type = FFEEXPR_exprtypeOPERAND_;
14005 e->token = ffeexpr_tokens_[0];
14006 e->u.operand = ffebld_new_conter (ffebld_constant_new_characterdefault
14007 (ffeexpr_tokens_[1]));
14008 ni = ffeinfo_new (FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTERDEFAULT,
14009 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14010 ffelex_token_length (ffeexpr_tokens_[1]));
14011 ffebld_set_info (e->u.operand, ni);
14012 ffelex_token_kill (ffeexpr_tokens_[1]);
14013 ffeexpr_exprstack_push_operand_ (e);
14014 if ((ffelex_token_type (t) == FFELEX_typeNAME)
14015 || (ffelex_token_type (t) == FFELEX_typeNAMES))
14016 {
14017 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14018 {
14019 ffebad_string (ffelex_token_text (t));
14020 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14021 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
14022 ffelex_token_where_column (ffeexpr_tokens_[0]));
14023 ffebad_finish ();
14024 }
14025 e = ffeexpr_expr_new_ ();
14026 e->type = FFEEXPR_exprtypeBINARY_;
14027 e->token = ffelex_token_use (t);
14028 e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
14029 e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
14030 e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
14031 ffeexpr_exprstack_push_binary_ (e);
14032 return (ffelexHandler) ffeexpr_token_rhs_ (t);
14033 }
14034 ffeexpr_is_substr_ok_ = !ffe_is_pedantic_not_90 (); /* Allow "'hello'(3:5)". */
14035 return (ffelexHandler) ffeexpr_token_substrp_ (t);
14036 }
14037
14038 /* ffeexpr_token_name_lhs_ -- Lhs NAME
14039
14040 Return a pointer to this function to the lexer (ffelex), which will
14041 invoke it for the next token.
14042
14043 Handle a name followed by open-paren, period (RECORD.MEMBER), percent
14044 (RECORD%MEMBER), or nothing at all. */
14045
14046 static ffelexHandler
14047 ffeexpr_token_name_lhs_ (ffelexToken t)
14048 {
14049 ffeexprExpr_ e;
14050 ffeexprParenType_ paren_type;
14051 ffesymbol s;
14052 ffebld expr;
14053 ffeinfo info;
14054
14055 switch (ffelex_token_type (t))
14056 {
14057 case FFELEX_typeOPEN_PAREN:
14058 switch (ffeexpr_stack_->context)
14059 {
14060 case FFEEXPR_contextASSIGN:
14061 case FFEEXPR_contextAGOTO:
14062 case FFEEXPR_contextFILEUNIT_DF:
14063 goto just_name; /* :::::::::::::::::::: */
14064
14065 default:
14066 break;
14067 }
14068 e = ffeexpr_expr_new_ ();
14069 e->type = FFEEXPR_exprtypeOPERAND_;
14070 e->token = ffelex_token_use (ffeexpr_tokens_[0]);
14071 s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], FALSE,
14072 &paren_type);
14073
14074 switch (ffesymbol_where (s))
14075 {
14076 case FFEINFO_whereLOCAL:
14077 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14078 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recursion. */
14079 break;
14080
14081 case FFEINFO_whereINTRINSIC:
14082 case FFEINFO_whereGLOBAL:
14083 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
14084 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */
14085 break;
14086
14087 case FFEINFO_whereCOMMON:
14088 case FFEINFO_whereDUMMY:
14089 case FFEINFO_whereRESULT:
14090 break;
14091
14092 case FFEINFO_whereNONE:
14093 case FFEINFO_whereANY:
14094 break;
14095
14096 default:
14097 ffesymbol_error (s, ffeexpr_tokens_[0]);
14098 break;
14099 }
14100
14101 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14102 {
14103 e->u.operand = ffebld_new_any ();
14104 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14105 }
14106 else
14107 {
14108 e->u.operand = ffebld_new_symter (s,
14109 ffesymbol_generic (s),
14110 ffesymbol_specific (s),
14111 ffesymbol_implementation (s));
14112 ffebld_set_info (e->u.operand, ffesymbol_info (s));
14113 }
14114 ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */
14115 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
14116 switch (paren_type)
14117 {
14118 case FFEEXPR_parentypeSUBROUTINE_:
14119 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14120 return
14121 (ffelexHandler)
14122 ffeexpr_rhs (ffeexpr_stack_->pool,
14123 FFEEXPR_contextACTUALARG_,
14124 ffeexpr_token_arguments_);
14125
14126 case FFEEXPR_parentypeARRAY_:
14127 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14128 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
14129 ffeexpr_stack_->rank = 0;
14130 ffeexpr_stack_->constant = TRUE;
14131 ffeexpr_stack_->immediate = TRUE;
14132 switch (ffeexpr_stack_->context)
14133 {
14134 case FFEEXPR_contextDATAIMPDOITEM_:
14135 return
14136 (ffelexHandler)
14137 ffeexpr_rhs (ffeexpr_stack_->pool,
14138 FFEEXPR_contextDATAIMPDOINDEX_,
14139 ffeexpr_token_elements_);
14140
14141 case FFEEXPR_contextEQUIVALENCE:
14142 return
14143 (ffelexHandler)
14144 ffeexpr_rhs (ffeexpr_stack_->pool,
14145 FFEEXPR_contextEQVINDEX_,
14146 ffeexpr_token_elements_);
14147
14148 default:
14149 return
14150 (ffelexHandler)
14151 ffeexpr_rhs (ffeexpr_stack_->pool,
14152 FFEEXPR_contextINDEX_,
14153 ffeexpr_token_elements_);
14154 }
14155
14156 case FFEEXPR_parentypeSUBSTRING_:
14157 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
14158 ffeexpr_tokens_[0]);
14159 return
14160 (ffelexHandler)
14161 ffeexpr_rhs (ffeexpr_stack_->pool,
14162 FFEEXPR_contextINDEX_,
14163 ffeexpr_token_substring_);
14164
14165 case FFEEXPR_parentypeEQUIVALENCE_:
14166 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14167 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
14168 ffeexpr_stack_->rank = 0;
14169 ffeexpr_stack_->constant = TRUE;
14170 ffeexpr_stack_->immediate = TRUE;
14171 return
14172 (ffelexHandler)
14173 ffeexpr_rhs (ffeexpr_stack_->pool,
14174 FFEEXPR_contextEQVINDEX_,
14175 ffeexpr_token_equivalence_);
14176
14177 case FFEEXPR_parentypeFUNCTION_: /* Invalid case. */
14178 case FFEEXPR_parentypeFUNSUBSTR_: /* Invalid case. */
14179 ffesymbol_error (s, ffeexpr_tokens_[0]);
14180 /* Fall through. */
14181 case FFEEXPR_parentypeANY_:
14182 e->u.operand = ffebld_new_any ();
14183 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14184 return
14185 (ffelexHandler)
14186 ffeexpr_rhs (ffeexpr_stack_->pool,
14187 FFEEXPR_contextACTUALARG_,
14188 ffeexpr_token_anything_);
14189
14190 default:
14191 assert ("bad paren type" == NULL);
14192 break;
14193 }
14194
14195 case FFELEX_typeEQUALS: /* As in "VAR=". */
14196 switch (ffeexpr_stack_->context)
14197 {
14198 case FFEEXPR_contextIMPDOITEM_: /* within
14199 "(,VAR=start,end[,incr])". */
14200 case FFEEXPR_contextIMPDOITEMDF_:
14201 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
14202 break;
14203
14204 case FFEEXPR_contextDATAIMPDOITEM_:
14205 ffeexpr_stack_->context = FFEEXPR_contextDATAIMPDOCTRL_;
14206 break;
14207
14208 default:
14209 break;
14210 }
14211 break;
14212
14213 #if 0
14214 case FFELEX_typePERIOD:
14215 case FFELEX_typePERCENT:
14216 assert ("FOO%, FOO. not yet supported!~~" == NULL);
14217 break;
14218 #endif
14219
14220 default:
14221 break;
14222 }
14223
14224 just_name: /* :::::::::::::::::::: */
14225 e = ffeexpr_expr_new_ ();
14226 e->type = FFEEXPR_exprtypeOPERAND_;
14227 e->token = ffeexpr_tokens_[0];
14228 s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0],
14229 (ffeexpr_stack_->context
14230 == FFEEXPR_contextSUBROUTINEREF));
14231
14232 switch (ffesymbol_where (s))
14233 {
14234 case FFEINFO_whereCONSTANT:
14235 if ((ffeexpr_stack_->context != FFEEXPR_contextPARAMETER)
14236 || (ffesymbol_kind (s) != FFEINFO_kindENTITY))
14237 ffesymbol_error (s, ffeexpr_tokens_[0]);
14238 break;
14239
14240 case FFEINFO_whereIMMEDIATE:
14241 if ((ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOCTRL_)
14242 && (ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOINDEX_))
14243 ffesymbol_error (s, ffeexpr_tokens_[0]);
14244 break;
14245
14246 case FFEINFO_whereLOCAL:
14247 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14248 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recurse!. */
14249 break;
14250
14251 case FFEINFO_whereINTRINSIC:
14252 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
14253 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */
14254 break;
14255
14256 default:
14257 break;
14258 }
14259
14260 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14261 {
14262 expr = ffebld_new_any ();
14263 info = ffeinfo_new_any ();
14264 ffebld_set_info (expr, info);
14265 }
14266 else
14267 {
14268 expr = ffebld_new_symter (s,
14269 ffesymbol_generic (s),
14270 ffesymbol_specific (s),
14271 ffesymbol_implementation (s));
14272 info = ffesymbol_info (s);
14273 ffebld_set_info (expr, info);
14274 if (ffesymbol_is_doiter (s))
14275 {
14276 ffebad_start (FFEBAD_DOITER);
14277 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14278 ffelex_token_where_column (ffeexpr_tokens_[0]));
14279 ffest_ffebad_here_doiter (1, s);
14280 ffebad_string (ffesymbol_text (s));
14281 ffebad_finish ();
14282 }
14283 expr = ffeexpr_collapse_symter (expr, ffeexpr_tokens_[0]);
14284 }
14285
14286 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14287 {
14288 if (ffebld_op (expr) == FFEBLD_opANY)
14289 {
14290 expr = ffebld_new_any ();
14291 ffebld_set_info (expr, ffeinfo_new_any ());
14292 }
14293 else
14294 {
14295 expr = ffebld_new_subrref (expr, NULL); /* No argument list. */
14296 if (ffesymbol_generic (s) != FFEINTRIN_genNONE)
14297 ffeintrin_fulfill_generic (&expr, &info, e->token);
14298 else if (ffesymbol_specific (s) != FFEINTRIN_specNONE)
14299 ffeintrin_fulfill_specific (&expr, &info, NULL, e->token);
14300 else
14301 ffeexpr_fulfill_call_ (&expr, e->token);
14302
14303 if (ffebld_op (expr) != FFEBLD_opANY)
14304 ffebld_set_info (expr,
14305 ffeinfo_new (ffeinfo_basictype (info),
14306 ffeinfo_kindtype (info),
14307 0,
14308 FFEINFO_kindENTITY,
14309 FFEINFO_whereFLEETING,
14310 ffeinfo_size (info)));
14311 else
14312 ffebld_set_info (expr, ffeinfo_new_any ());
14313 }
14314 }
14315
14316 e->u.operand = expr;
14317 ffeexpr_exprstack_push_operand_ (e);
14318 return (ffelexHandler) ffeexpr_finished_ (t);
14319 }
14320
14321 /* ffeexpr_token_name_arg_ -- Rhs NAME
14322
14323 Return a pointer to this function to the lexer (ffelex), which will
14324 invoke it for the next token.
14325
14326 Handle first token in an actual-arg (or possible actual-arg) context
14327 being a NAME, and use second token to refine the context. */
14328
14329 static ffelexHandler
14330 ffeexpr_token_name_arg_ (ffelexToken t)
14331 {
14332 switch (ffelex_token_type (t))
14333 {
14334 case FFELEX_typeCLOSE_PAREN:
14335 case FFELEX_typeCOMMA:
14336 switch (ffeexpr_stack_->context)
14337 {
14338 case FFEEXPR_contextINDEXORACTUALARG_:
14339 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
14340 break;
14341
14342 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
14343 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
14344 break;
14345
14346 default:
14347 break;
14348 }
14349 break;
14350
14351 default:
14352 switch (ffeexpr_stack_->context)
14353 {
14354 case FFEEXPR_contextACTUALARG_:
14355 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
14356 break;
14357
14358 case FFEEXPR_contextINDEXORACTUALARG_:
14359 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
14360 break;
14361
14362 case FFEEXPR_contextSFUNCDEFACTUALARG_:
14363 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
14364 break;
14365
14366 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
14367 ffeexpr_stack_->context
14368 = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
14369 break;
14370
14371 default:
14372 assert ("bad context in _name_arg_" == NULL);
14373 break;
14374 }
14375 break;
14376 }
14377
14378 return (ffelexHandler) ffeexpr_token_name_rhs_ (t);
14379 }
14380
14381 /* ffeexpr_token_name_rhs_ -- Rhs NAME
14382
14383 Return a pointer to this function to the lexer (ffelex), which will
14384 invoke it for the next token.
14385
14386 Handle a name followed by open-paren, apostrophe (O'octal-const',
14387 Z'hex-const', or X'hex-const'), period (RECORD.MEMBER).
14388
14389 26-Nov-91 JCB 1.2
14390 When followed by apostrophe or quote, set lex hexnum flag on so
14391 [0-9] as first char of next token seen as starting a potentially
14392 hex number (NAME).
14393 04-Oct-91 JCB 1.1
14394 In case of intrinsic, decorate its SYMTER with the type info for
14395 the specific intrinsic. */
14396
14397 static ffelexHandler
14398 ffeexpr_token_name_rhs_ (ffelexToken t)
14399 {
14400 ffeexprExpr_ e;
14401 ffeexprParenType_ paren_type;
14402 ffesymbol s;
14403 bool sfdef;
14404
14405 switch (ffelex_token_type (t))
14406 {
14407 case FFELEX_typeQUOTE:
14408 case FFELEX_typeAPOSTROPHE:
14409 ffeexpr_tokens_[1] = ffelex_token_use (t);
14410 ffelex_set_hexnum (TRUE);
14411 return (ffelexHandler) ffeexpr_token_name_apos_;
14412
14413 case FFELEX_typeOPEN_PAREN:
14414 e = ffeexpr_expr_new_ ();
14415 e->type = FFEEXPR_exprtypeOPERAND_;
14416 e->token = ffelex_token_use (ffeexpr_tokens_[0]);
14417 s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], TRUE,
14418 &paren_type);
14419 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14420 e->u.operand = ffebld_new_any ();
14421 else
14422 e->u.operand = ffebld_new_symter (s, ffesymbol_generic (s),
14423 ffesymbol_specific (s),
14424 ffesymbol_implementation (s));
14425 ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */
14426 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
14427 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
14428 {
14429 case FFEEXPR_contextSFUNCDEF:
14430 case FFEEXPR_contextSFUNCDEFINDEX_:
14431 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
14432 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
14433 sfdef = TRUE;
14434 break;
14435
14436 case FFEEXPR_contextSFUNCDEFACTUALARG_:
14437 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
14438 assert ("weird context!" == NULL);
14439 sfdef = FALSE;
14440 break;
14441
14442 default:
14443 sfdef = FALSE;
14444 break;
14445 }
14446 switch (paren_type)
14447 {
14448 case FFEEXPR_parentypeFUNCTION_:
14449 ffebld_set_info (e->u.operand, ffesymbol_info (s));
14450 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14451 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
14452 { /* A statement function. */
14453 ffeexpr_stack_->num_args
14454 = ffebld_list_length
14455 (ffeexpr_stack_->next_dummy
14456 = ffesymbol_dummyargs (s));
14457 ffeexpr_stack_->tokens[1] = NULL; /* !=NULL when > num_args. */
14458 }
14459 else if ((ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
14460 && !ffe_is_pedantic_not_90 ()
14461 && ((ffesymbol_implementation (s)
14462 == FFEINTRIN_impICHAR)
14463 || (ffesymbol_implementation (s)
14464 == FFEINTRIN_impIACHAR)
14465 || (ffesymbol_implementation (s)
14466 == FFEINTRIN_impLEN)))
14467 { /* Allow arbitrary concatenations. */
14468 return
14469 (ffelexHandler)
14470 ffeexpr_rhs (ffeexpr_stack_->pool,
14471 sfdef
14472 ? FFEEXPR_contextSFUNCDEF
14473 : FFEEXPR_contextLET,
14474 ffeexpr_token_arguments_);
14475 }
14476 return
14477 (ffelexHandler)
14478 ffeexpr_rhs (ffeexpr_stack_->pool,
14479 sfdef
14480 ? FFEEXPR_contextSFUNCDEFACTUALARG_
14481 : FFEEXPR_contextACTUALARG_,
14482 ffeexpr_token_arguments_);
14483
14484 case FFEEXPR_parentypeARRAY_:
14485 ffebld_set_info (e->u.operand,
14486 ffesymbol_info (ffebld_symter (e->u.operand)));
14487 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
14488 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
14489 ffeexpr_stack_->rank = 0;
14490 ffeexpr_stack_->constant = TRUE;
14491 ffeexpr_stack_->immediate = TRUE;
14492 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
14493 sfdef
14494 ? FFEEXPR_contextSFUNCDEFINDEX_
14495 : FFEEXPR_contextINDEX_,
14496 ffeexpr_token_elements_);
14497
14498 case FFEEXPR_parentypeSUBSTRING_:
14499 ffebld_set_info (e->u.operand,
14500 ffesymbol_info (ffebld_symter (e->u.operand)));
14501 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
14502 ffeexpr_tokens_[0]);
14503 return
14504 (ffelexHandler)
14505 ffeexpr_rhs (ffeexpr_stack_->pool,
14506 sfdef
14507 ? FFEEXPR_contextSFUNCDEFINDEX_
14508 : FFEEXPR_contextINDEX_,
14509 ffeexpr_token_substring_);
14510
14511 case FFEEXPR_parentypeFUNSUBSTR_:
14512 return
14513 (ffelexHandler)
14514 ffeexpr_rhs (ffeexpr_stack_->pool,
14515 sfdef
14516 ? FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
14517 : FFEEXPR_contextINDEXORACTUALARG_,
14518 ffeexpr_token_funsubstr_);
14519
14520 case FFEEXPR_parentypeANY_:
14521 ffebld_set_info (e->u.operand, ffesymbol_info (s));
14522 return
14523 (ffelexHandler)
14524 ffeexpr_rhs (ffeexpr_stack_->pool,
14525 sfdef
14526 ? FFEEXPR_contextSFUNCDEFACTUALARG_
14527 : FFEEXPR_contextACTUALARG_,
14528 ffeexpr_token_anything_);
14529
14530 default:
14531 assert ("bad paren type" == NULL);
14532 break;
14533 }
14534
14535 case FFELEX_typeEQUALS: /* As in "VAR=". */
14536 switch (ffeexpr_stack_->context)
14537 {
14538 case FFEEXPR_contextIMPDOITEM_: /* "(,VAR=start,end[,incr])". */
14539 case FFEEXPR_contextIMPDOITEMDF_:
14540 ffeexpr_stack_->is_rhs = FALSE; /* Really an lhs construct. */
14541 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
14542 break;
14543
14544 default:
14545 break;
14546 }
14547 break;
14548
14549 #if 0
14550 case FFELEX_typePERIOD:
14551 case FFELEX_typePERCENT:
14552 ~~Support these two someday, though not required
14553 assert ("FOO%, FOO. not yet supported!~~" == NULL);
14554 break;
14555 #endif
14556
14557 default:
14558 break;
14559 }
14560
14561 switch (ffeexpr_stack_->context)
14562 {
14563 case FFEEXPR_contextINDEXORACTUALARG_:
14564 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
14565 assert ("strange context" == NULL);
14566 break;
14567
14568 default:
14569 break;
14570 }
14571
14572 e = ffeexpr_expr_new_ ();
14573 e->type = FFEEXPR_exprtypeOPERAND_;
14574 e->token = ffeexpr_tokens_[0];
14575 s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0], FALSE);
14576 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14577 {
14578 e->u.operand = ffebld_new_any ();
14579 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14580 }
14581 else
14582 {
14583 e->u.operand = ffebld_new_symter (s, FFEINTRIN_genNONE,
14584 ffesymbol_specific (s),
14585 ffesymbol_implementation (s));
14586 if (ffesymbol_specific (s) == FFEINTRIN_specNONE)
14587 ffebld_set_info (e->u.operand, ffeinfo_use (ffesymbol_info (s)));
14588 else
14589 { /* Decorate the SYMTER with the actual type
14590 of the intrinsic. */
14591 ffebld_set_info (e->u.operand, ffeinfo_new
14592 (ffeintrin_basictype (ffesymbol_specific (s)),
14593 ffeintrin_kindtype (ffesymbol_specific (s)),
14594 0,
14595 ffesymbol_kind (s),
14596 ffesymbol_where (s),
14597 FFETARGET_charactersizeNONE));
14598 }
14599 if (ffesymbol_is_doiter (s))
14600 ffebld_symter_set_is_doiter (e->u.operand, TRUE);
14601 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
14602 ffeexpr_tokens_[0]);
14603 }
14604 ffeexpr_exprstack_push_operand_ (e);
14605 return (ffelexHandler) ffeexpr_token_binary_ (t);
14606 }
14607
14608 /* ffeexpr_token_name_apos_ -- Rhs NAME APOSTROPHE
14609
14610 Return a pointer to this function to the lexer (ffelex), which will
14611 invoke it for the next token.
14612
14613 Expecting a NAME token, analyze the previous NAME token to see what kind,
14614 if any, typeless constant we've got.
14615
14616 01-Sep-90 JCB 1.1
14617 Expect a NAME instead of CHARACTER in this situation. */
14618
14619 static ffelexHandler
14620 ffeexpr_token_name_apos_ (ffelexToken t)
14621 {
14622 ffeexprExpr_ e;
14623
14624 ffelex_set_hexnum (FALSE);
14625
14626 switch (ffelex_token_type (t))
14627 {
14628 case FFELEX_typeNAME:
14629 ffeexpr_tokens_[2] = ffelex_token_use (t);
14630 return (ffelexHandler) ffeexpr_token_name_apos_name_;
14631
14632 default:
14633 break;
14634 }
14635
14636 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14637 {
14638 ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
14639 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14640 ffelex_token_where_column (ffeexpr_tokens_[0]));
14641 ffebad_here (1, ffelex_token_where_line (t),
14642 ffelex_token_where_column (t));
14643 ffebad_finish ();
14644 }
14645
14646 ffelex_token_kill (ffeexpr_tokens_[1]);
14647
14648 e = ffeexpr_expr_new_ ();
14649 e->type = FFEEXPR_exprtypeOPERAND_;
14650 e->u.operand = ffebld_new_any ();
14651 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14652 e->token = ffeexpr_tokens_[0];
14653 ffeexpr_exprstack_push_operand_ (e);
14654
14655 return (ffelexHandler) ffeexpr_token_binary_ (t);
14656 }
14657
14658 /* ffeexpr_token_name_apos_name_ -- Rhs NAME APOSTROPHE NAME
14659
14660 Return a pointer to this function to the lexer (ffelex), which will
14661 invoke it for the next token.
14662
14663 Expecting an APOSTROPHE token, analyze the previous NAME token to see
14664 what kind, if any, typeless constant we've got. */
14665
14666 static ffelexHandler
14667 ffeexpr_token_name_apos_name_ (ffelexToken t)
14668 {
14669 ffeexprExpr_ e;
14670 char c;
14671
14672 e = ffeexpr_expr_new_ ();
14673 e->type = FFEEXPR_exprtypeOPERAND_;
14674 e->token = ffeexpr_tokens_[0];
14675
14676 if ((ffelex_token_type (t) == ffelex_token_type (ffeexpr_tokens_[1]))
14677 && (ffelex_token_length (ffeexpr_tokens_[0]) == 1)
14678 && (ffesrc_char_match_init ((c = ffelex_token_text (ffeexpr_tokens_[0])[0]),
14679 'B', 'b')
14680 || ffesrc_char_match_init (c, 'O', 'o')
14681 || ffesrc_char_match_init (c, 'X', 'x')
14682 || ffesrc_char_match_init (c, 'Z', 'z')))
14683 {
14684 ffetargetCharacterSize size;
14685
14686 if (!ffe_is_typeless_boz ()) {
14687
14688 switch (c)
14689 {
14690 case FFESRC_CASE_MATCH_INIT ('B', 'b', imatch_b, no_imatch):
14691 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerbinary
14692 (ffeexpr_tokens_[2]));
14693 break;
14694
14695 case FFESRC_CASE_MATCH_INIT ('O', 'o', imatch_o, no_imatch):
14696 e->u.operand = ffebld_new_conter (ffebld_constant_new_integeroctal
14697 (ffeexpr_tokens_[2]));
14698 break;
14699
14700 case FFESRC_CASE_MATCH_INIT ('X', 'x', imatch_x, no_imatch):
14701 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
14702 (ffeexpr_tokens_[2]));
14703 break;
14704
14705 case FFESRC_CASE_MATCH_INIT ('Z', 'z', imatch_z, no_imatch):
14706 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
14707 (ffeexpr_tokens_[2]));
14708 break;
14709
14710 default:
14711 no_imatch: /* :::::::::::::::::::: */
14712 assert ("not BOXZ!" == NULL);
14713 abort ();
14714 }
14715
14716 ffebld_set_info (e->u.operand,
14717 ffeinfo_new (FFEINFO_basictypeINTEGER,
14718 FFEINFO_kindtypeINTEGERDEFAULT, 0,
14719 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14720 FFETARGET_charactersizeNONE));
14721 ffeexpr_exprstack_push_operand_ (e);
14722 ffelex_token_kill (ffeexpr_tokens_[1]);
14723 ffelex_token_kill (ffeexpr_tokens_[2]);
14724 return (ffelexHandler) ffeexpr_token_binary_;
14725 }
14726
14727 switch (c)
14728 {
14729 case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
14730 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_bm
14731 (ffeexpr_tokens_[2]));
14732 size = ffetarget_size_typeless_binary (ffeexpr_tokens_[2]);
14733 break;
14734
14735 case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
14736 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_om
14737 (ffeexpr_tokens_[2]));
14738 size = ffetarget_size_typeless_octal (ffeexpr_tokens_[2]);
14739 break;
14740
14741 case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
14742 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hxm
14743 (ffeexpr_tokens_[2]));
14744 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
14745 break;
14746
14747 case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
14748 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
14749 (ffeexpr_tokens_[2]));
14750 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
14751 break;
14752
14753 default:
14754 no_match: /* :::::::::::::::::::: */
14755 assert ("not BOXZ!" == NULL);
14756 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
14757 (ffeexpr_tokens_[2]));
14758 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
14759 break;
14760 }
14761 ffebld_set_info (e->u.operand,
14762 ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
14763 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
14764 ffeexpr_exprstack_push_operand_ (e);
14765 ffelex_token_kill (ffeexpr_tokens_[1]);
14766 ffelex_token_kill (ffeexpr_tokens_[2]);
14767 return (ffelexHandler) ffeexpr_token_binary_;
14768 }
14769
14770 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14771 {
14772 ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
14773 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14774 ffelex_token_where_column (ffeexpr_tokens_[0]));
14775 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14776 ffebad_finish ();
14777 }
14778
14779 ffelex_token_kill (ffeexpr_tokens_[1]);
14780 ffelex_token_kill (ffeexpr_tokens_[2]);
14781
14782 e->type = FFEEXPR_exprtypeOPERAND_;
14783 e->u.operand = ffebld_new_any ();
14784 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14785 e->token = ffeexpr_tokens_[0];
14786 ffeexpr_exprstack_push_operand_ (e);
14787
14788 switch (ffelex_token_type (t))
14789 {
14790 case FFELEX_typeAPOSTROPHE:
14791 case FFELEX_typeQUOTE:
14792 return (ffelexHandler) ffeexpr_token_binary_;
14793
14794 default:
14795 return (ffelexHandler) ffeexpr_token_binary_ (t);
14796 }
14797 }
14798
14799 /* ffeexpr_token_percent_ -- Rhs PERCENT
14800
14801 Handle a percent sign possibly followed by "LOC". If followed instead
14802 by "VAL", "REF", or "DESCR", issue an error message and substitute
14803 "LOC". If followed by something else, treat the percent sign as a
14804 spurious incorrect token and reprocess the token via _rhs_. */
14805
14806 static ffelexHandler
14807 ffeexpr_token_percent_ (ffelexToken t)
14808 {
14809 switch (ffelex_token_type (t))
14810 {
14811 case FFELEX_typeNAME:
14812 case FFELEX_typeNAMES:
14813 ffeexpr_stack_->percent = ffeexpr_percent_ (t);
14814 ffeexpr_tokens_[1] = ffelex_token_use (t);
14815 return (ffelexHandler) ffeexpr_token_percent_name_;
14816
14817 default:
14818 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
14819 {
14820 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14821 ffelex_token_where_column (ffeexpr_tokens_[0]));
14822 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
14823 ffelex_token_where_column (ffeexpr_stack_->first_token));
14824 ffebad_finish ();
14825 }
14826 ffelex_token_kill (ffeexpr_tokens_[0]);
14827 return (ffelexHandler) ffeexpr_token_rhs_ (t);
14828 }
14829 }
14830
14831 /* ffeexpr_token_percent_name_ -- Rhs PERCENT NAME
14832
14833 Make sure the token is OPEN_PAREN and prepare for the one-item list of
14834 LHS expressions. Else display an error message. */
14835
14836 static ffelexHandler
14837 ffeexpr_token_percent_name_ (ffelexToken t)
14838 {
14839 ffelexHandler nexthandler;
14840
14841 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
14842 {
14843 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
14844 {
14845 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14846 ffelex_token_where_column (ffeexpr_tokens_[0]));
14847 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
14848 ffelex_token_where_column (ffeexpr_stack_->first_token));
14849 ffebad_finish ();
14850 }
14851 ffelex_token_kill (ffeexpr_tokens_[0]);
14852 nexthandler = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_tokens_[1]);
14853 ffelex_token_kill (ffeexpr_tokens_[1]);
14854 return (ffelexHandler) (*nexthandler) (t);
14855 }
14856
14857 switch (ffeexpr_stack_->percent)
14858 {
14859 default:
14860 if (ffest_ffebad_start (FFEBAD_INVALID_PERCENT))
14861 {
14862 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14863 ffelex_token_where_column (ffeexpr_tokens_[0]));
14864 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
14865 ffebad_finish ();
14866 }
14867 ffeexpr_stack_->percent = FFEEXPR_percentLOC_;
14868 /* Fall through. */
14869 case FFEEXPR_percentLOC_:
14870 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
14871 ffelex_token_kill (ffeexpr_tokens_[1]);
14872 ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
14873 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
14874 FFEEXPR_contextLOC_,
14875 ffeexpr_cb_end_loc_);
14876 }
14877 }
14878
14879 /* ffeexpr_make_float_const_ -- Make a floating-point constant
14880
14881 See prototype.
14882
14883 Pass 'E', 'D', or 'Q' for exponent letter. */
14884
14885 static void
14886 ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
14887 ffelexToken decimal, ffelexToken fraction,
14888 ffelexToken exponent, ffelexToken exponent_sign,
14889 ffelexToken exponent_digits)
14890 {
14891 ffeexprExpr_ e;
14892
14893 e = ffeexpr_expr_new_ ();
14894 e->type = FFEEXPR_exprtypeOPERAND_;
14895 if (integer != NULL)
14896 e->token = ffelex_token_use (integer);
14897 else
14898 {
14899 assert (decimal != NULL);
14900 e->token = ffelex_token_use (decimal);
14901 }
14902
14903 switch (exp_letter)
14904 {
14905 #if !FFETARGET_okREALQUAD
14906 case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
14907 if (ffebad_start (FFEBAD_QUAD_UNSUPPORTED))
14908 {
14909 ffebad_here (0, ffelex_token_where_line (e->token),
14910 ffelex_token_where_column (e->token));
14911 ffebad_finish ();
14912 }
14913 goto match_d; /* The FFESRC_CASE_* macros don't
14914 allow fall-through! */
14915 #endif
14916
14917 case FFESRC_CASE_MATCH_INIT ('D', 'd', match_d, no_match):
14918 e->u.operand = ffebld_new_conter (ffebld_constant_new_realdouble
14919 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
14920 ffebld_set_info (e->u.operand,
14921 ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
14922 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14923 break;
14924
14925 case FFESRC_CASE_MATCH_INIT ('E', 'e', match_e, no_match):
14926 e->u.operand = ffebld_new_conter (ffebld_constant_new_realdefault
14927 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
14928 ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeREAL,
14929 FFEINFO_kindtypeREALDEFAULT, 0, FFEINFO_kindENTITY,
14930 FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14931 break;
14932
14933 #if FFETARGET_okREALQUAD
14934 case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
14935 e->u.operand = ffebld_new_conter (ffebld_constant_new_realquad
14936 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
14937 ffebld_set_info (e->u.operand,
14938 ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALQUAD,
14939 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14940 break;
14941 #endif
14942
14943 case 'I': /* Make an integer. */
14944 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
14945 (ffeexpr_tokens_[0]));
14946 ffebld_set_info (e->u.operand,
14947 ffeinfo_new (FFEINFO_basictypeINTEGER,
14948 FFEINFO_kindtypeINTEGERDEFAULT, 0,
14949 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14950 FFETARGET_charactersizeNONE));
14951 break;
14952
14953 default:
14954 no_match: /* :::::::::::::::::::: */
14955 assert ("Lost the exponent letter!" == NULL);
14956 }
14957
14958 ffeexpr_exprstack_push_operand_ (e);
14959 }
14960
14961 /* Just like ffesymbol_declare_local, except performs any implicit info
14962 assignment necessary. */
14963
14964 static ffesymbol
14965 ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin)
14966 {
14967 ffesymbol s;
14968 ffeinfoKind k;
14969 bool bad;
14970
14971 s = ffesymbol_declare_local (t, maybe_intrin);
14972
14973 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
14974 /* Special-case these since they can involve a different concept
14975 of "state" (in the stmtfunc name space). */
14976 {
14977 case FFEEXPR_contextDATAIMPDOINDEX_:
14978 case FFEEXPR_contextDATAIMPDOCTRL_:
14979 if (ffeexpr_context_outer_ (ffeexpr_stack_)
14980 == FFEEXPR_contextDATAIMPDOINDEX_)
14981 s = ffeexpr_sym_impdoitem_ (s, t);
14982 else
14983 if (ffeexpr_stack_->is_rhs)
14984 s = ffeexpr_sym_impdoitem_ (s, t);
14985 else
14986 s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
14987 bad = (ffesymbol_kind (s) != FFEINFO_kindENTITY)
14988 || ((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
14989 && (ffesymbol_where (s) != FFEINFO_whereIMMEDIATE));
14990 if (bad && (ffesymbol_kind (s) != FFEINFO_kindANY))
14991 ffesymbol_error (s, t);
14992 return s;
14993
14994 default:
14995 break;
14996 }
14997
14998 switch ((ffesymbol_sfdummyparent (s) == NULL)
14999 ? ffesymbol_state (s)
15000 : FFESYMBOL_stateUNDERSTOOD)
15001 {
15002 case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr
15003 context. */
15004 if (!ffest_seen_first_exec ())
15005 goto seen; /* :::::::::::::::::::: */
15006 /* Fall through. */
15007 case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */
15008 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15009 {
15010 case FFEEXPR_contextSUBROUTINEREF:
15011 s = ffeexpr_sym_lhs_call_ (s, t);
15012 break;
15013
15014 case FFEEXPR_contextFILEEXTFUNC:
15015 s = ffeexpr_sym_lhs_extfunc_ (s, t);
15016 break;
15017
15018 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15019 s = ffecom_sym_exec_transition (s);
15020 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15021 goto understood; /* :::::::::::::::::::: */
15022 /* Fall through. */
15023 case FFEEXPR_contextACTUALARG_:
15024 s = ffeexpr_sym_rhs_actualarg_ (s, t);
15025 break;
15026
15027 case FFEEXPR_contextDATA:
15028 if (ffeexpr_stack_->is_rhs)
15029 s = ffeexpr_sym_rhs_let_ (s, t);
15030 else
15031 s = ffeexpr_sym_lhs_data_ (s, t);
15032 break;
15033
15034 case FFEEXPR_contextDATAIMPDOITEM_:
15035 s = ffeexpr_sym_lhs_data_ (s, t);
15036 break;
15037
15038 case FFEEXPR_contextSFUNCDEF:
15039 case FFEEXPR_contextSFUNCDEFINDEX_:
15040 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15041 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15042 s = ffecom_sym_exec_transition (s);
15043 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15044 goto understood; /* :::::::::::::::::::: */
15045 /* Fall through. */
15046 case FFEEXPR_contextLET:
15047 case FFEEXPR_contextPAREN_:
15048 case FFEEXPR_contextACTUALARGEXPR_:
15049 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15050 case FFEEXPR_contextASSIGN:
15051 case FFEEXPR_contextIOLIST:
15052 case FFEEXPR_contextIOLISTDF:
15053 case FFEEXPR_contextDO:
15054 case FFEEXPR_contextDOWHILE:
15055 case FFEEXPR_contextAGOTO:
15056 case FFEEXPR_contextCGOTO:
15057 case FFEEXPR_contextIF:
15058 case FFEEXPR_contextARITHIF:
15059 case FFEEXPR_contextFORMAT:
15060 case FFEEXPR_contextSTOP:
15061 case FFEEXPR_contextRETURN:
15062 case FFEEXPR_contextSELECTCASE:
15063 case FFEEXPR_contextCASE:
15064 case FFEEXPR_contextFILEASSOC:
15065 case FFEEXPR_contextFILEINT:
15066 case FFEEXPR_contextFILEDFINT:
15067 case FFEEXPR_contextFILELOG:
15068 case FFEEXPR_contextFILENUM:
15069 case FFEEXPR_contextFILENUMAMBIG:
15070 case FFEEXPR_contextFILECHAR:
15071 case FFEEXPR_contextFILENUMCHAR:
15072 case FFEEXPR_contextFILEDFCHAR:
15073 case FFEEXPR_contextFILEKEY:
15074 case FFEEXPR_contextFILEUNIT:
15075 case FFEEXPR_contextFILEUNIT_DF:
15076 case FFEEXPR_contextFILEUNITAMBIG:
15077 case FFEEXPR_contextFILEFORMAT:
15078 case FFEEXPR_contextFILENAMELIST:
15079 case FFEEXPR_contextFILEVXTCODE:
15080 case FFEEXPR_contextINDEX_:
15081 case FFEEXPR_contextIMPDOITEM_:
15082 case FFEEXPR_contextIMPDOITEMDF_:
15083 case FFEEXPR_contextIMPDOCTRL_:
15084 case FFEEXPR_contextLOC_:
15085 if (ffeexpr_stack_->is_rhs)
15086 s = ffeexpr_sym_rhs_let_ (s, t);
15087 else
15088 s = ffeexpr_sym_lhs_let_ (s, t);
15089 break;
15090
15091 case FFEEXPR_contextCHARACTERSIZE:
15092 case FFEEXPR_contextEQUIVALENCE:
15093 case FFEEXPR_contextINCLUDE:
15094 case FFEEXPR_contextPARAMETER:
15095 case FFEEXPR_contextDIMLIST:
15096 case FFEEXPR_contextDIMLISTCOMMON:
15097 case FFEEXPR_contextKINDTYPE:
15098 case FFEEXPR_contextINITVAL:
15099 case FFEEXPR_contextEQVINDEX_:
15100 break; /* Will turn into errors below. */
15101
15102 default:
15103 ffesymbol_error (s, t);
15104 break;
15105 }
15106 /* Fall through. */
15107 case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */
15108 understood: /* :::::::::::::::::::: */
15109 k = ffesymbol_kind (s);
15110 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15111 {
15112 case FFEEXPR_contextSUBROUTINEREF:
15113 bad = ((k != FFEINFO_kindSUBROUTINE)
15114 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
15115 || (k != FFEINFO_kindNONE)));
15116 break;
15117
15118 case FFEEXPR_contextFILEEXTFUNC:
15119 bad = (k != FFEINFO_kindFUNCTION)
15120 || (ffesymbol_where (s) != FFEINFO_whereGLOBAL);
15121 break;
15122
15123 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15124 case FFEEXPR_contextACTUALARG_:
15125 switch (k)
15126 {
15127 case FFEINFO_kindENTITY:
15128 bad = FALSE;
15129 break;
15130
15131 case FFEINFO_kindFUNCTION:
15132 case FFEINFO_kindSUBROUTINE:
15133 bad
15134 = ((ffesymbol_where (s) != FFEINFO_whereGLOBAL)
15135 && (ffesymbol_where (s) != FFEINFO_whereDUMMY)
15136 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
15137 || !ffeintrin_is_actualarg (ffesymbol_specific (s))));
15138 break;
15139
15140 case FFEINFO_kindNONE:
15141 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
15142 {
15143 bad = !(ffeintrin_is_actualarg (ffesymbol_specific (s)));
15144 break;
15145 }
15146
15147 /* If state is UNDERSTOOD here, it's CHAR*(*) or attrsANY,
15148 and in the former case, attrsTYPE is set, so we
15149 see this as an error as we should, since CHAR*(*)
15150 cannot be actually referenced in a main/block data
15151 program unit. */
15152
15153 if ((ffesymbol_attrs (s) & (FFESYMBOL_attrsANY
15154 | FFESYMBOL_attrsEXTERNAL
15155 | FFESYMBOL_attrsTYPE))
15156 == FFESYMBOL_attrsEXTERNAL)
15157 bad = FALSE;
15158 else
15159 bad = TRUE;
15160 break;
15161
15162 default:
15163 bad = TRUE;
15164 break;
15165 }
15166 break;
15167
15168 case FFEEXPR_contextDATA:
15169 if (ffeexpr_stack_->is_rhs)
15170 bad = (k != FFEINFO_kindENTITY)
15171 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
15172 else
15173 bad = (k != FFEINFO_kindENTITY)
15174 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
15175 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
15176 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
15177 break;
15178
15179 case FFEEXPR_contextDATAIMPDOITEM_:
15180 bad = TRUE; /* Unadorned item never valid. */
15181 break;
15182
15183 case FFEEXPR_contextSFUNCDEF:
15184 case FFEEXPR_contextSFUNCDEFINDEX_:
15185 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15186 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15187 case FFEEXPR_contextLET:
15188 case FFEEXPR_contextPAREN_:
15189 case FFEEXPR_contextACTUALARGEXPR_:
15190 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15191 case FFEEXPR_contextASSIGN:
15192 case FFEEXPR_contextIOLIST:
15193 case FFEEXPR_contextIOLISTDF:
15194 case FFEEXPR_contextDO:
15195 case FFEEXPR_contextDOWHILE:
15196 case FFEEXPR_contextAGOTO:
15197 case FFEEXPR_contextCGOTO:
15198 case FFEEXPR_contextIF:
15199 case FFEEXPR_contextARITHIF:
15200 case FFEEXPR_contextFORMAT:
15201 case FFEEXPR_contextSTOP:
15202 case FFEEXPR_contextRETURN:
15203 case FFEEXPR_contextSELECTCASE:
15204 case FFEEXPR_contextCASE:
15205 case FFEEXPR_contextFILEASSOC:
15206 case FFEEXPR_contextFILEINT:
15207 case FFEEXPR_contextFILEDFINT:
15208 case FFEEXPR_contextFILELOG:
15209 case FFEEXPR_contextFILENUM:
15210 case FFEEXPR_contextFILENUMAMBIG:
15211 case FFEEXPR_contextFILECHAR:
15212 case FFEEXPR_contextFILENUMCHAR:
15213 case FFEEXPR_contextFILEDFCHAR:
15214 case FFEEXPR_contextFILEKEY:
15215 case FFEEXPR_contextFILEUNIT:
15216 case FFEEXPR_contextFILEUNIT_DF:
15217 case FFEEXPR_contextFILEUNITAMBIG:
15218 case FFEEXPR_contextFILEFORMAT:
15219 case FFEEXPR_contextFILENAMELIST:
15220 case FFEEXPR_contextFILEVXTCODE:
15221 case FFEEXPR_contextINDEX_:
15222 case FFEEXPR_contextIMPDOITEM_:
15223 case FFEEXPR_contextIMPDOITEMDF_:
15224 case FFEEXPR_contextIMPDOCTRL_:
15225 case FFEEXPR_contextLOC_:
15226 bad = (k != FFEINFO_kindENTITY); /* This catches "SUBROUTINE
15227 X(A);EXTERNAL A;CALL
15228 Y(A);B=A", for example. */
15229 break;
15230
15231 case FFEEXPR_contextCHARACTERSIZE:
15232 case FFEEXPR_contextEQUIVALENCE:
15233 case FFEEXPR_contextPARAMETER:
15234 case FFEEXPR_contextDIMLIST:
15235 case FFEEXPR_contextDIMLISTCOMMON:
15236 case FFEEXPR_contextKINDTYPE:
15237 case FFEEXPR_contextINITVAL:
15238 case FFEEXPR_contextEQVINDEX_:
15239 bad = (k != FFEINFO_kindENTITY)
15240 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
15241 break;
15242
15243 case FFEEXPR_contextINCLUDE:
15244 bad = TRUE;
15245 break;
15246
15247 default:
15248 bad = TRUE;
15249 break;
15250 }
15251 if (bad && (k != FFEINFO_kindANY))
15252 ffesymbol_error (s, t);
15253 return s;
15254
15255 case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */
15256 seen: /* :::::::::::::::::::: */
15257 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15258 {
15259 case FFEEXPR_contextPARAMETER:
15260 if (ffeexpr_stack_->is_rhs)
15261 ffesymbol_error (s, t);
15262 else
15263 s = ffeexpr_sym_lhs_parameter_ (s, t);
15264 break;
15265
15266 case FFEEXPR_contextDATA:
15267 s = ffecom_sym_exec_transition (s);
15268 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15269 goto understood; /* :::::::::::::::::::: */
15270 if (ffeexpr_stack_->is_rhs)
15271 ffesymbol_error (s, t);
15272 else
15273 s = ffeexpr_sym_lhs_data_ (s, t);
15274 goto understood; /* :::::::::::::::::::: */
15275
15276 case FFEEXPR_contextDATAIMPDOITEM_:
15277 s = ffecom_sym_exec_transition (s);
15278 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15279 goto understood; /* :::::::::::::::::::: */
15280 s = ffeexpr_sym_lhs_data_ (s, t);
15281 goto understood; /* :::::::::::::::::::: */
15282
15283 case FFEEXPR_contextEQUIVALENCE:
15284 s = ffeexpr_sym_lhs_equivalence_ (s, t);
15285 break;
15286
15287 case FFEEXPR_contextDIMLIST:
15288 s = ffeexpr_sym_rhs_dimlist_ (s, t);
15289 break;
15290
15291 case FFEEXPR_contextCHARACTERSIZE:
15292 case FFEEXPR_contextKINDTYPE:
15293 case FFEEXPR_contextDIMLISTCOMMON:
15294 case FFEEXPR_contextINITVAL:
15295 case FFEEXPR_contextEQVINDEX_:
15296 ffesymbol_error (s, t);
15297 break;
15298
15299 case FFEEXPR_contextINCLUDE:
15300 ffesymbol_error (s, t);
15301 break;
15302
15303 case FFEEXPR_contextACTUALARG_: /* E.g. I in REAL A(Y(I)). */
15304 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15305 s = ffecom_sym_exec_transition (s);
15306 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15307 goto understood; /* :::::::::::::::::::: */
15308 s = ffeexpr_sym_rhs_actualarg_ (s, t);
15309 goto understood; /* :::::::::::::::::::: */
15310
15311 case FFEEXPR_contextINDEX_:
15312 case FFEEXPR_contextACTUALARGEXPR_:
15313 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15314 case FFEEXPR_contextSFUNCDEF:
15315 case FFEEXPR_contextSFUNCDEFINDEX_:
15316 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15317 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15318 assert (ffeexpr_stack_->is_rhs);
15319 s = ffecom_sym_exec_transition (s);
15320 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15321 goto understood; /* :::::::::::::::::::: */
15322 s = ffeexpr_sym_rhs_let_ (s, t);
15323 goto understood; /* :::::::::::::::::::: */
15324
15325 default:
15326 ffesymbol_error (s, t);
15327 break;
15328 }
15329 return s;
15330
15331 default:
15332 assert ("bad symbol state" == NULL);
15333 return NULL;
15334 break;
15335 }
15336 }
15337
15338 /* Have FOO in DATA (XYZ(FOO),...)/.../ or DATA (...,XYZ=FOO,BAR,BLETCH).
15339 Could be found via the "statement-function" name space (in which case
15340 it should become an iterator) or the local name space (in which case
15341 it should be either a named constant, or a variable that will have an
15342 sfunc name space sibling that should become an iterator). */
15343
15344 static ffesymbol
15345 ffeexpr_sym_impdoitem_ (ffesymbol sp, ffelexToken t)
15346 {
15347 ffesymbol s;
15348 ffesymbolAttrs sa;
15349 ffesymbolAttrs na;
15350 ffesymbolState ss;
15351 ffesymbolState ns;
15352 ffeinfoKind kind;
15353 ffeinfoWhere where;
15354
15355 ss = ffesymbol_state (sp);
15356
15357 if (ffesymbol_sfdummyparent (sp) != NULL)
15358 { /* Have symbol in sfunc name space. */
15359 switch (ss)
15360 {
15361 case FFESYMBOL_stateNONE: /* Used as iterator already. */
15362 if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
15363 ffesymbol_error (sp, t); /* Can't use dead iterator. */
15364 else
15365 { /* Can use dead iterator because we're at at
15366 least an innermore (higher-numbered) level
15367 than the iterator's outermost
15368 (lowest-numbered) level. */
15369 ffesymbol_signal_change (sp);
15370 ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
15371 ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
15372 ffesymbol_signal_unreported (sp);
15373 }
15374 break;
15375
15376 case FFESYMBOL_stateSEEN: /* Seen already in this or other
15377 implied-DO. Set symbol level
15378 number to outermost value, as that
15379 tells us we can see it as iterator
15380 at that level at the innermost. */
15381 if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
15382 {
15383 ffesymbol_signal_change (sp);
15384 ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
15385 ffesymbol_signal_unreported (sp);
15386 }
15387 break;
15388
15389 case FFESYMBOL_stateUNCERTAIN: /* Iterator. */
15390 assert (ffeexpr_level_ == ffesymbol_maxentrynum (sp));
15391 ffesymbol_error (sp, t); /* (,,,I=I,10). */
15392 break;
15393
15394 case FFESYMBOL_stateUNDERSTOOD:
15395 break; /* ANY. */
15396
15397 default:
15398 assert ("Foo Bar!!" == NULL);
15399 break;
15400 }
15401
15402 return sp;
15403 }
15404
15405 /* Got symbol in local name space, so we haven't seen it in impdo yet.
15406 First, if it is brand-new and we're in executable statements, set the
15407 attributes and exec-transition it to set state UNCERTAIN or UNDERSTOOD.
15408 Second, if it is now a constant (PARAMETER), then just return it, it
15409 can't be an implied-do iterator. If it is understood, complain if it is
15410 not a valid variable, but make the inner name space iterator anyway and
15411 return that. If it is not understood, improve understanding of the
15412 symbol accordingly, complain accordingly, in either case make the inner
15413 name space iterator and return that. */
15414
15415 sa = ffesymbol_attrs (sp);
15416
15417 if (ffesymbol_state_is_specable (ss)
15418 && ffest_seen_first_exec ())
15419 {
15420 assert (sa == FFESYMBOL_attrsetNONE);
15421 ffesymbol_signal_change (sp);
15422 ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
15423 ffesymbol_resolve_intrin (sp);
15424 if (ffeimplic_establish_symbol (sp))
15425 ffesymbol_set_attr (sp, FFESYMBOL_attrSFARG);
15426 else
15427 ffesymbol_error (sp, t);
15428
15429 /* After the exec transition, the state will either be UNCERTAIN (could
15430 be a dummy or local var) or UNDERSTOOD (local var, because this is a
15431 PROGRAM/BLOCKDATA program unit). */
15432
15433 sp = ffecom_sym_exec_transition (sp);
15434 sa = ffesymbol_attrs (sp);
15435 ss = ffesymbol_state (sp);
15436 }
15437
15438 ns = ss;
15439 kind = ffesymbol_kind (sp);
15440 where = ffesymbol_where (sp);
15441
15442 if (ss == FFESYMBOL_stateUNDERSTOOD)
15443 {
15444 if (kind != FFEINFO_kindENTITY)
15445 ffesymbol_error (sp, t);
15446 if (where == FFEINFO_whereCONSTANT)
15447 return sp;
15448 }
15449 else
15450 {
15451 /* Enhance understanding of local symbol. This used to imply exec
15452 transition, but that doesn't seem necessary, since the local symbol
15453 doesn't actually get put into an ffebld tree here -- we just learn
15454 more about it, just like when we see a local symbol's name in the
15455 dummy-arg list of a statement function. */
15456
15457 if (ss != FFESYMBOL_stateUNCERTAIN)
15458 {
15459 /* Figure out what kind of object we've got based on previous
15460 declarations of or references to the object. */
15461
15462 ns = FFESYMBOL_stateSEEN;
15463
15464 if (sa & FFESYMBOL_attrsANY)
15465 na = sa;
15466 else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
15467 | FFESYMBOL_attrsANY
15468 | FFESYMBOL_attrsCOMMON
15469 | FFESYMBOL_attrsDUMMY
15470 | FFESYMBOL_attrsEQUIV
15471 | FFESYMBOL_attrsINIT
15472 | FFESYMBOL_attrsNAMELIST
15473 | FFESYMBOL_attrsRESULT
15474 | FFESYMBOL_attrsSAVE
15475 | FFESYMBOL_attrsSFARG
15476 | FFESYMBOL_attrsTYPE)))
15477 na = sa | FFESYMBOL_attrsSFARG;
15478 else
15479 na = FFESYMBOL_attrsetNONE;
15480 }
15481 else
15482 { /* stateUNCERTAIN. */
15483 na = sa | FFESYMBOL_attrsSFARG;
15484 ns = FFESYMBOL_stateUNDERSTOOD;
15485
15486 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15487 | FFESYMBOL_attrsADJUSTABLE
15488 | FFESYMBOL_attrsANYLEN
15489 | FFESYMBOL_attrsARRAY
15490 | FFESYMBOL_attrsDUMMY
15491 | FFESYMBOL_attrsEXTERNAL
15492 | FFESYMBOL_attrsSFARG
15493 | FFESYMBOL_attrsTYPE)));
15494
15495 if (sa & FFESYMBOL_attrsEXTERNAL)
15496 {
15497 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15498 | FFESYMBOL_attrsDUMMY
15499 | FFESYMBOL_attrsEXTERNAL
15500 | FFESYMBOL_attrsTYPE)));
15501
15502 na = FFESYMBOL_attrsetNONE;
15503 }
15504 else if (sa & FFESYMBOL_attrsDUMMY)
15505 {
15506 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
15507 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
15508 | FFESYMBOL_attrsEXTERNAL
15509 | FFESYMBOL_attrsTYPE)));
15510
15511 kind = FFEINFO_kindENTITY;
15512 }
15513 else if (sa & FFESYMBOL_attrsARRAY)
15514 {
15515 assert (!(sa & ~(FFESYMBOL_attrsARRAY
15516 | FFESYMBOL_attrsADJUSTABLE
15517 | FFESYMBOL_attrsTYPE)));
15518
15519 na = FFESYMBOL_attrsetNONE;
15520 }
15521 else if (sa & FFESYMBOL_attrsSFARG)
15522 {
15523 assert (!(sa & ~(FFESYMBOL_attrsSFARG
15524 | FFESYMBOL_attrsTYPE)));
15525
15526 ns = FFESYMBOL_stateUNCERTAIN;
15527 }
15528 else if (sa & FFESYMBOL_attrsTYPE)
15529 {
15530 assert (!(sa & (FFESYMBOL_attrsARRAY
15531 | FFESYMBOL_attrsDUMMY
15532 | FFESYMBOL_attrsEXTERNAL
15533 | FFESYMBOL_attrsSFARG))); /* Handled above. */
15534 assert (!(sa & ~(FFESYMBOL_attrsTYPE
15535 | FFESYMBOL_attrsADJUSTABLE
15536 | FFESYMBOL_attrsANYLEN
15537 | FFESYMBOL_attrsARRAY
15538 | FFESYMBOL_attrsDUMMY
15539 | FFESYMBOL_attrsEXTERNAL
15540 | FFESYMBOL_attrsSFARG)));
15541
15542 kind = FFEINFO_kindENTITY;
15543
15544 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
15545 na = FFESYMBOL_attrsetNONE;
15546 else if (ffest_is_entry_valid ())
15547 ns = FFESYMBOL_stateUNCERTAIN; /* Could be DUMMY or LOCAL. */
15548 else
15549 where = FFEINFO_whereLOCAL;
15550 }
15551 else
15552 na = FFESYMBOL_attrsetNONE; /* Error. */
15553 }
15554
15555 /* Now see what we've got for a new object: NONE means a new error
15556 cropped up; ANY means an old error to be ignored; otherwise,
15557 everything's ok, update the object (symbol) and continue on. */
15558
15559 if (na == FFESYMBOL_attrsetNONE)
15560 ffesymbol_error (sp, t);
15561 else if (!(na & FFESYMBOL_attrsANY))
15562 {
15563 ffesymbol_signal_change (sp); /* May need to back up to previous
15564 version. */
15565 if (!ffeimplic_establish_symbol (sp))
15566 ffesymbol_error (sp, t);
15567 else
15568 {
15569 ffesymbol_set_info (sp,
15570 ffeinfo_new (ffesymbol_basictype (sp),
15571 ffesymbol_kindtype (sp),
15572 ffesymbol_rank (sp),
15573 kind,
15574 where,
15575 ffesymbol_size (sp)));
15576 ffesymbol_set_attrs (sp, na);
15577 ffesymbol_set_state (sp, ns);
15578 ffesymbol_resolve_intrin (sp);
15579 if (!ffesymbol_state_is_specable (ns))
15580 sp = ffecom_sym_learned (sp);
15581 ffesymbol_signal_unreported (sp); /* For debugging purposes. */
15582 }
15583 }
15584 }
15585
15586 /* Here we create the sfunc-name-space symbol representing what should
15587 become an iterator in this name space at this or an outermore (lower-
15588 numbered) expression level, else the implied-DO construct is in error. */
15589
15590 s = ffesymbol_declare_sfdummy (t); /* Sets maxentrynum to 0 for new obj;
15591 also sets sfa_dummy_parent to
15592 parent symbol. */
15593 assert (sp == ffesymbol_sfdummyparent (s));
15594
15595 ffesymbol_signal_change (s);
15596 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
15597 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
15598 ffesymbol_set_info (s,
15599 ffeinfo_new (FFEINFO_basictypeINTEGER,
15600 FFEINFO_kindtypeINTEGERDEFAULT,
15601 0,
15602 FFEINFO_kindENTITY,
15603 FFEINFO_whereIMMEDIATE,
15604 FFETARGET_charactersizeNONE));
15605 ffesymbol_signal_unreported (s);
15606
15607 if ((ffesymbol_basictype (sp) != FFEINFO_basictypeINTEGER)
15608 && (ffesymbol_basictype (sp) != FFEINFO_basictypeANY))
15609 ffesymbol_error (s, t);
15610
15611 return s;
15612 }
15613
15614 /* Have FOO in CALL FOO. Local name space, executable context only. */
15615
15616 static ffesymbol
15617 ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t)
15618 {
15619 ffesymbolAttrs sa;
15620 ffesymbolAttrs na;
15621 ffeinfoKind kind;
15622 ffeinfoWhere where;
15623 ffeintrinGen gen;
15624 ffeintrinSpec spec;
15625 ffeintrinImp imp;
15626 bool error = FALSE;
15627
15628 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
15629 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
15630
15631 na = sa = ffesymbol_attrs (s);
15632
15633 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15634 | FFESYMBOL_attrsADJUSTABLE
15635 | FFESYMBOL_attrsANYLEN
15636 | FFESYMBOL_attrsARRAY
15637 | FFESYMBOL_attrsDUMMY
15638 | FFESYMBOL_attrsEXTERNAL
15639 | FFESYMBOL_attrsSFARG
15640 | FFESYMBOL_attrsTYPE)));
15641
15642 kind = ffesymbol_kind (s);
15643 where = ffesymbol_where (s);
15644
15645 /* Figure out what kind of object we've got based on previous declarations
15646 of or references to the object. */
15647
15648 if (sa & FFESYMBOL_attrsEXTERNAL)
15649 {
15650 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15651 | FFESYMBOL_attrsDUMMY
15652 | FFESYMBOL_attrsEXTERNAL
15653 | FFESYMBOL_attrsTYPE)));
15654
15655 if (sa & FFESYMBOL_attrsTYPE)
15656 error = TRUE;
15657 else
15658 /* Not TYPE. */
15659 {
15660 kind = FFEINFO_kindSUBROUTINE;
15661
15662 if (sa & FFESYMBOL_attrsDUMMY)
15663 ; /* Not TYPE. */
15664 else if (sa & FFESYMBOL_attrsACTUALARG)
15665 ; /* Not DUMMY or TYPE. */
15666 else /* Not ACTUALARG, DUMMY, or TYPE. */
15667 where = FFEINFO_whereGLOBAL;
15668 }
15669 }
15670 else if (sa & FFESYMBOL_attrsDUMMY)
15671 {
15672 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
15673 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
15674 | FFESYMBOL_attrsEXTERNAL
15675 | FFESYMBOL_attrsTYPE)));
15676
15677 if (sa & FFESYMBOL_attrsTYPE)
15678 error = TRUE;
15679 else
15680 kind = FFEINFO_kindSUBROUTINE;
15681 }
15682 else if (sa & FFESYMBOL_attrsARRAY)
15683 {
15684 assert (!(sa & ~(FFESYMBOL_attrsARRAY
15685 | FFESYMBOL_attrsADJUSTABLE
15686 | FFESYMBOL_attrsTYPE)));
15687
15688 error = TRUE;
15689 }
15690 else if (sa & FFESYMBOL_attrsSFARG)
15691 {
15692 assert (!(sa & ~(FFESYMBOL_attrsSFARG
15693 | FFESYMBOL_attrsTYPE)));
15694
15695 error = TRUE;
15696 }
15697 else if (sa & FFESYMBOL_attrsTYPE)
15698 {
15699 assert (!(sa & (FFESYMBOL_attrsARRAY
15700 | FFESYMBOL_attrsDUMMY
15701 | FFESYMBOL_attrsEXTERNAL
15702 | FFESYMBOL_attrsSFARG))); /* Handled above. */
15703 assert (!(sa & ~(FFESYMBOL_attrsTYPE
15704 | FFESYMBOL_attrsADJUSTABLE
15705 | FFESYMBOL_attrsANYLEN
15706 | FFESYMBOL_attrsARRAY
15707 | FFESYMBOL_attrsDUMMY
15708 | FFESYMBOL_attrsEXTERNAL
15709 | FFESYMBOL_attrsSFARG)));
15710
15711 error = TRUE;
15712 }
15713 else if (sa == FFESYMBOL_attrsetNONE)
15714 {
15715 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
15716
15717 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
15718 &gen, &spec, &imp))
15719 {
15720 ffesymbol_signal_change (s); /* May need to back up to previous
15721 version. */
15722 ffesymbol_set_generic (s, gen);
15723 ffesymbol_set_specific (s, spec);
15724 ffesymbol_set_implementation (s, imp);
15725 ffesymbol_set_info (s,
15726 ffeinfo_new (FFEINFO_basictypeNONE,
15727 FFEINFO_kindtypeNONE,
15728 0,
15729 FFEINFO_kindSUBROUTINE,
15730 FFEINFO_whereINTRINSIC,
15731 FFETARGET_charactersizeNONE));
15732 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
15733 ffesymbol_resolve_intrin (s);
15734 ffesymbol_reference (s, t, FALSE);
15735 s = ffecom_sym_learned (s);
15736 ffesymbol_signal_unreported (s); /* For debugging purposes. */
15737
15738 return s;
15739 }
15740
15741 kind = FFEINFO_kindSUBROUTINE;
15742 where = FFEINFO_whereGLOBAL;
15743 }
15744 else
15745 error = TRUE;
15746
15747 /* Now see what we've got for a new object: NONE means a new error cropped
15748 up; ANY means an old error to be ignored; otherwise, everything's ok,
15749 update the object (symbol) and continue on. */
15750
15751 if (error)
15752 ffesymbol_error (s, t);
15753 else if (!(na & FFESYMBOL_attrsANY))
15754 {
15755 ffesymbol_signal_change (s); /* May need to back up to previous
15756 version. */
15757 ffesymbol_set_info (s,
15758 ffeinfo_new (ffesymbol_basictype (s),
15759 ffesymbol_kindtype (s),
15760 ffesymbol_rank (s),
15761 kind, /* SUBROUTINE. */
15762 where, /* GLOBAL or DUMMY. */
15763 ffesymbol_size (s)));
15764 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
15765 ffesymbol_resolve_intrin (s);
15766 ffesymbol_reference (s, t, FALSE);
15767 s = ffecom_sym_learned (s);
15768 ffesymbol_signal_unreported (s); /* For debugging purposes. */
15769 }
15770
15771 return s;
15772 }
15773
15774 /* Have FOO in DATA FOO/.../. Local name space and executable context
15775 only. (This will change in the future when DATA FOO may be followed
15776 by COMMON FOO or even INTEGER FOO(10), etc.) */
15777
15778 static ffesymbol
15779 ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t)
15780 {
15781 ffesymbolAttrs sa;
15782 ffesymbolAttrs na;
15783 ffeinfoKind kind;
15784 ffeinfoWhere where;
15785 bool error = FALSE;
15786
15787 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
15788 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
15789
15790 na = sa = ffesymbol_attrs (s);
15791
15792 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15793 | FFESYMBOL_attrsADJUSTABLE
15794 | FFESYMBOL_attrsANYLEN
15795 | FFESYMBOL_attrsARRAY
15796 | FFESYMBOL_attrsDUMMY
15797 | FFESYMBOL_attrsEXTERNAL
15798 | FFESYMBOL_attrsSFARG
15799 | FFESYMBOL_attrsTYPE)));
15800
15801 kind = ffesymbol_kind (s);
15802 where = ffesymbol_where (s);
15803
15804 /* Figure out what kind of object we've got based on previous declarations
15805 of or references to the object. */
15806
15807 if (sa & FFESYMBOL_attrsEXTERNAL)
15808 {
15809 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15810 | FFESYMBOL_attrsDUMMY
15811 | FFESYMBOL_attrsEXTERNAL
15812 | FFESYMBOL_attrsTYPE)));
15813
15814 error = TRUE;
15815 }
15816 else if (sa & FFESYMBOL_attrsDUMMY)
15817 {
15818 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
15819 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
15820 | FFESYMBOL_attrsEXTERNAL
15821 | FFESYMBOL_attrsTYPE)));
15822
15823 error = TRUE;
15824 }
15825 else if (sa & FFESYMBOL_attrsARRAY)
15826 {
15827 assert (!(sa & ~(FFESYMBOL_attrsARRAY
15828 | FFESYMBOL_attrsADJUSTABLE
15829 | FFESYMBOL_attrsTYPE)));
15830
15831 if (sa & FFESYMBOL_attrsADJUSTABLE)
15832 error = TRUE;
15833 where = FFEINFO_whereLOCAL;
15834 }
15835 else if (sa & FFESYMBOL_attrsSFARG)
15836 {
15837 assert (!(sa & ~(FFESYMBOL_attrsSFARG
15838 | FFESYMBOL_attrsTYPE)));
15839
15840 where = FFEINFO_whereLOCAL;
15841 }
15842 else if (sa & FFESYMBOL_attrsTYPE)
15843 {
15844 assert (!(sa & (FFESYMBOL_attrsARRAY
15845 | FFESYMBOL_attrsDUMMY
15846 | FFESYMBOL_attrsEXTERNAL
15847 | FFESYMBOL_attrsSFARG))); /* Handled above. */
15848 assert (!(sa & ~(FFESYMBOL_attrsTYPE
15849 | FFESYMBOL_attrsADJUSTABLE
15850 | FFESYMBOL_attrsANYLEN
15851 | FFESYMBOL_attrsARRAY
15852 | FFESYMBOL_attrsDUMMY
15853 | FFESYMBOL_attrsEXTERNAL
15854 | FFESYMBOL_attrsSFARG)));
15855
15856 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
15857 error = TRUE;
15858 else
15859 {
15860 kind = FFEINFO_kindENTITY;
15861 where = FFEINFO_whereLOCAL;
15862 }
15863 }
15864 else if (sa == FFESYMBOL_attrsetNONE)
15865 {
15866 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
15867 kind = FFEINFO_kindENTITY;
15868 where = FFEINFO_whereLOCAL;
15869 }
15870 else
15871 error = TRUE;
15872
15873 /* Now see what we've got for a new object: NONE means a new error cropped
15874 up; ANY means an old error to be ignored; otherwise, everything's ok,
15875 update the object (symbol) and continue on. */
15876
15877 if (error)
15878 ffesymbol_error (s, t);
15879 else if (!(na & FFESYMBOL_attrsANY))
15880 {
15881 ffesymbol_signal_change (s); /* May need to back up to previous
15882 version. */
15883 if (!ffeimplic_establish_symbol (s))
15884 {
15885 ffesymbol_error (s, t);
15886 return s;
15887 }
15888 ffesymbol_set_info (s,
15889 ffeinfo_new (ffesymbol_basictype (s),
15890 ffesymbol_kindtype (s),
15891 ffesymbol_rank (s),
15892 kind, /* ENTITY. */
15893 where, /* LOCAL. */
15894 ffesymbol_size (s)));
15895 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
15896 ffesymbol_resolve_intrin (s);
15897 s = ffecom_sym_learned (s);
15898 ffesymbol_signal_unreported (s); /* For debugging purposes. */
15899 }
15900
15901 return s;
15902 }
15903
15904 /* Have FOO in EQUIVALENCE (...,FOO,...). Does not include
15905 EQUIVALENCE (...,BAR(FOO),...). */
15906
15907 static ffesymbol
15908 ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t)
15909 {
15910 ffesymbolAttrs sa;
15911 ffesymbolAttrs na;
15912 ffeinfoKind kind;
15913 ffeinfoWhere where;
15914
15915 na = sa = ffesymbol_attrs (s);
15916 kind = FFEINFO_kindENTITY;
15917 where = ffesymbol_where (s);
15918
15919 /* Figure out what kind of object we've got based on previous declarations
15920 of or references to the object. */
15921
15922 if (!(sa & ~(FFESYMBOL_attrsADJUSTS
15923 | FFESYMBOL_attrsARRAY
15924 | FFESYMBOL_attrsCOMMON
15925 | FFESYMBOL_attrsEQUIV
15926 | FFESYMBOL_attrsINIT
15927 | FFESYMBOL_attrsNAMELIST
15928 | FFESYMBOL_attrsSAVE
15929 | FFESYMBOL_attrsSFARG
15930 | FFESYMBOL_attrsTYPE)))
15931 na = sa | FFESYMBOL_attrsEQUIV;
15932 else
15933 na = FFESYMBOL_attrsetNONE;
15934
15935 /* Don't know why we're bothering to set kind and where in this code, but
15936 added the following to make it complete, in case it's really important.
15937 Generally this is left up to symbol exec transition. */
15938
15939 if (where == FFEINFO_whereNONE)
15940 {
15941 if (na & (FFESYMBOL_attrsADJUSTS
15942 | FFESYMBOL_attrsCOMMON))
15943 where = FFEINFO_whereCOMMON;
15944 else if (na & FFESYMBOL_attrsSAVE)
15945 where = FFEINFO_whereLOCAL;
15946 }
15947
15948 /* Now see what we've got for a new object: NONE means a new error cropped
15949 up; ANY means an old error to be ignored; otherwise, everything's ok,
15950 update the object (symbol) and continue on. */
15951
15952 if (na == FFESYMBOL_attrsetNONE)
15953 ffesymbol_error (s, t);
15954 else if (!(na & FFESYMBOL_attrsANY))
15955 {
15956 ffesymbol_signal_change (s); /* May need to back up to previous
15957 version. */
15958 ffesymbol_set_info (s,
15959 ffeinfo_new (ffesymbol_basictype (s),
15960 ffesymbol_kindtype (s),
15961 ffesymbol_rank (s),
15962 kind, /* Always ENTITY. */
15963 where, /* NONE, COMMON, or LOCAL. */
15964 ffesymbol_size (s)));
15965 ffesymbol_set_attrs (s, na);
15966 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
15967 ffesymbol_resolve_intrin (s);
15968 ffesymbol_signal_unreported (s); /* For debugging purposes. */
15969 }
15970
15971 return s;
15972 }
15973
15974 /* Have FOO in OPEN(...,USEROPEN=FOO,...). Executable context only.
15975
15976 Note that I think this should be considered semantically similar to
15977 doing CALL XYZ(FOO), in that it should be considered like an
15978 ACTUALARG context. In particular, without EXTERNAL being specified,
15979 it should not be allowed. */
15980
15981 static ffesymbol
15982 ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t)
15983 {
15984 ffesymbolAttrs sa;
15985 ffesymbolAttrs na;
15986 ffeinfoKind kind;
15987 ffeinfoWhere where;
15988 bool needs_type = FALSE;
15989 bool error = FALSE;
15990
15991 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
15992 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
15993
15994 na = sa = ffesymbol_attrs (s);
15995
15996 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
15997 | FFESYMBOL_attrsADJUSTABLE
15998 | FFESYMBOL_attrsANYLEN
15999 | FFESYMBOL_attrsARRAY
16000 | FFESYMBOL_attrsDUMMY
16001 | FFESYMBOL_attrsEXTERNAL
16002 | FFESYMBOL_attrsSFARG
16003 | FFESYMBOL_attrsTYPE)));
16004
16005 kind = ffesymbol_kind (s);
16006 where = ffesymbol_where (s);
16007
16008 /* Figure out what kind of object we've got based on previous declarations
16009 of or references to the object. */
16010
16011 if (sa & FFESYMBOL_attrsEXTERNAL)
16012 {
16013 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16014 | FFESYMBOL_attrsDUMMY
16015 | FFESYMBOL_attrsEXTERNAL
16016 | FFESYMBOL_attrsTYPE)));
16017
16018 if (sa & FFESYMBOL_attrsTYPE)
16019 where = FFEINFO_whereGLOBAL;
16020 else
16021 /* Not TYPE. */
16022 {
16023 kind = FFEINFO_kindFUNCTION;
16024 needs_type = TRUE;
16025
16026 if (sa & FFESYMBOL_attrsDUMMY)
16027 ; /* Not TYPE. */
16028 else if (sa & FFESYMBOL_attrsACTUALARG)
16029 ; /* Not DUMMY or TYPE. */
16030 else /* Not ACTUALARG, DUMMY, or TYPE. */
16031 where = FFEINFO_whereGLOBAL;
16032 }
16033 }
16034 else if (sa & FFESYMBOL_attrsDUMMY)
16035 {
16036 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16037 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16038 | FFESYMBOL_attrsEXTERNAL
16039 | FFESYMBOL_attrsTYPE)));
16040
16041 kind = FFEINFO_kindFUNCTION;
16042 if (!(sa & FFESYMBOL_attrsTYPE))
16043 needs_type = TRUE;
16044 }
16045 else if (sa & FFESYMBOL_attrsARRAY)
16046 {
16047 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16048 | FFESYMBOL_attrsADJUSTABLE
16049 | FFESYMBOL_attrsTYPE)));
16050
16051 error = TRUE;
16052 }
16053 else if (sa & FFESYMBOL_attrsSFARG)
16054 {
16055 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16056 | FFESYMBOL_attrsTYPE)));
16057
16058 error = TRUE;
16059 }
16060 else if (sa & FFESYMBOL_attrsTYPE)
16061 {
16062 assert (!(sa & (FFESYMBOL_attrsARRAY
16063 | FFESYMBOL_attrsDUMMY
16064 | FFESYMBOL_attrsEXTERNAL
16065 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16066 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16067 | FFESYMBOL_attrsADJUSTABLE
16068 | FFESYMBOL_attrsANYLEN
16069 | FFESYMBOL_attrsARRAY
16070 | FFESYMBOL_attrsDUMMY
16071 | FFESYMBOL_attrsEXTERNAL
16072 | FFESYMBOL_attrsSFARG)));
16073
16074 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16075 error = TRUE;
16076 else
16077 {
16078 kind = FFEINFO_kindFUNCTION;
16079 where = FFEINFO_whereGLOBAL;
16080 }
16081 }
16082 else if (sa == FFESYMBOL_attrsetNONE)
16083 {
16084 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16085 kind = FFEINFO_kindFUNCTION;
16086 where = FFEINFO_whereGLOBAL;
16087 needs_type = TRUE;
16088 }
16089 else
16090 error = TRUE;
16091
16092 /* Now see what we've got for a new object: NONE means a new error cropped
16093 up; ANY means an old error to be ignored; otherwise, everything's ok,
16094 update the object (symbol) and continue on. */
16095
16096 if (error)
16097 ffesymbol_error (s, t);
16098 else if (!(na & FFESYMBOL_attrsANY))
16099 {
16100 ffesymbol_signal_change (s); /* May need to back up to previous
16101 version. */
16102 if (needs_type && !ffeimplic_establish_symbol (s))
16103 {
16104 ffesymbol_error (s, t);
16105 return s;
16106 }
16107 if (!ffesymbol_explicitwhere (s))
16108 {
16109 ffebad_start (FFEBAD_NEED_EXTERNAL);
16110 ffebad_here (0, ffelex_token_where_line (t),
16111 ffelex_token_where_column (t));
16112 ffebad_string (ffesymbol_text (s));
16113 ffebad_finish ();
16114 ffesymbol_set_explicitwhere (s, TRUE);
16115 }
16116 ffesymbol_set_info (s,
16117 ffeinfo_new (ffesymbol_basictype (s),
16118 ffesymbol_kindtype (s),
16119 ffesymbol_rank (s),
16120 kind, /* FUNCTION. */
16121 where, /* GLOBAL or DUMMY. */
16122 ffesymbol_size (s)));
16123 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16124 ffesymbol_resolve_intrin (s);
16125 ffesymbol_reference (s, t, FALSE);
16126 s = ffecom_sym_learned (s);
16127 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16128 }
16129
16130 return s;
16131 }
16132
16133 /* Have FOO in DATA (stuff,FOO=1,10)/.../. */
16134
16135 static ffesymbol
16136 ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t)
16137 {
16138 ffesymbolState ss;
16139
16140 /* If the symbol isn't in the sfunc name space, pretend as though we saw a
16141 reference to it already within the imp-DO construct at this level, so as
16142 to get a symbol that is in the sfunc name space. But this is an
16143 erroneous construct, and should be caught elsewhere. */
16144
16145 if (ffesymbol_sfdummyparent (s) == NULL)
16146 {
16147 s = ffeexpr_sym_impdoitem_ (s, t);
16148 if (ffesymbol_sfdummyparent (s) == NULL)
16149 { /* PARAMETER FOO...DATA (A(I),FOO=...). */
16150 ffesymbol_error (s, t);
16151 return s;
16152 }
16153 }
16154
16155 ss = ffesymbol_state (s);
16156
16157 switch (ss)
16158 {
16159 case FFESYMBOL_stateNONE: /* Used as iterator already. */
16160 if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
16161 ffesymbol_error (s, t); /* Can't reuse dead iterator. F90 disallows
16162 this; F77 allows it but it is a stupid
16163 feature. */
16164 else
16165 { /* Can use dead iterator because we're at at
16166 least a innermore (higher-numbered) level
16167 than the iterator's outermost
16168 (lowest-numbered) level. This should be
16169 diagnosed later, because it means an item
16170 in this list didn't reference this
16171 iterator. */
16172 #if 1
16173 ffesymbol_error (s, t); /* For now, complain. */
16174 #else /* Someday will detect all cases where initializer doesn't reference
16175 all applicable iterators, in which case reenable this code. */
16176 ffesymbol_signal_change (s);
16177 ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
16178 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
16179 ffesymbol_signal_unreported (s);
16180 #endif
16181 }
16182 break;
16183
16184 case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO.
16185 If seen in outermore level, can't be an
16186 iterator here, so complain. If not seen
16187 at current level, complain for now,
16188 because that indicates something F90
16189 rejects (though we currently don't detect
16190 all such cases for now). */
16191 if (ffeexpr_level_ <= ffesymbol_maxentrynum (s))
16192 {
16193 ffesymbol_signal_change (s);
16194 ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
16195 ffesymbol_signal_unreported (s);
16196 }
16197 else
16198 ffesymbol_error (s, t);
16199 break;
16200
16201 case FFESYMBOL_stateUNCERTAIN: /* Already iterator! */
16202 assert ("DATA implied-DO control var seen twice!!" == NULL);
16203 ffesymbol_error (s, t);
16204 break;
16205
16206 case FFESYMBOL_stateUNDERSTOOD:
16207 break; /* ANY. */
16208
16209 default:
16210 assert ("Foo Bletch!!" == NULL);
16211 break;
16212 }
16213
16214 return s;
16215 }
16216
16217 /* Have FOO in PARAMETER (FOO=...). */
16218
16219 static ffesymbol
16220 ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t)
16221 {
16222 ffesymbolAttrs sa;
16223
16224 sa = ffesymbol_attrs (s);
16225
16226 /* Figure out what kind of object we've got based on previous declarations
16227 of or references to the object. */
16228
16229 if (sa & ~(FFESYMBOL_attrsANYLEN
16230 | FFESYMBOL_attrsTYPE))
16231 {
16232 if (!(sa & FFESYMBOL_attrsANY))
16233 ffesymbol_error (s, t);
16234 }
16235 else
16236 {
16237 ffesymbol_signal_change (s); /* May need to back up to previous
16238 version. */
16239 if (!ffeimplic_establish_symbol (s))
16240 {
16241 ffesymbol_error (s, t);
16242 return s;
16243 }
16244 ffesymbol_set_info (s,
16245 ffeinfo_new (ffesymbol_basictype (s),
16246 ffesymbol_kindtype (s),
16247 ffesymbol_rank (s),
16248 FFEINFO_kindENTITY,
16249 FFEINFO_whereCONSTANT,
16250 ffesymbol_size (s)));
16251 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16252 ffesymbol_resolve_intrin (s);
16253 s = ffecom_sym_learned (s);
16254 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16255 }
16256
16257 return s;
16258 }
16259
16260 /* Have FOO in CALL XYZ(...,FOO,...). Does not include any other
16261 embedding of FOO, such as CALL XYZ((FOO)) or CALL XYZ(FOO+1). */
16262
16263 static ffesymbol
16264 ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t)
16265 {
16266 ffesymbolAttrs sa;
16267 ffesymbolAttrs na;
16268 ffeinfoKind kind;
16269 ffeinfoWhere where;
16270 ffesymbolState ns;
16271 bool needs_type = FALSE;
16272
16273 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16274 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16275
16276 na = sa = ffesymbol_attrs (s);
16277
16278 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16279 | FFESYMBOL_attrsADJUSTABLE
16280 | FFESYMBOL_attrsANYLEN
16281 | FFESYMBOL_attrsARRAY
16282 | FFESYMBOL_attrsDUMMY
16283 | FFESYMBOL_attrsEXTERNAL
16284 | FFESYMBOL_attrsSFARG
16285 | FFESYMBOL_attrsTYPE)));
16286
16287 kind = ffesymbol_kind (s);
16288 where = ffesymbol_where (s);
16289
16290 /* Figure out what kind of object we've got based on previous declarations
16291 of or references to the object. */
16292
16293 ns = FFESYMBOL_stateUNDERSTOOD;
16294
16295 if (sa & FFESYMBOL_attrsEXTERNAL)
16296 {
16297 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16298 | FFESYMBOL_attrsDUMMY
16299 | FFESYMBOL_attrsEXTERNAL
16300 | FFESYMBOL_attrsTYPE)));
16301
16302 if (sa & FFESYMBOL_attrsTYPE)
16303 where = FFEINFO_whereGLOBAL;
16304 else
16305 /* Not TYPE. */
16306 {
16307 ns = FFESYMBOL_stateUNCERTAIN;
16308
16309 if (sa & FFESYMBOL_attrsDUMMY)
16310 assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */
16311 else if (sa & FFESYMBOL_attrsACTUALARG)
16312 ; /* Not DUMMY or TYPE. */
16313 else
16314 /* Not ACTUALARG, DUMMY, or TYPE. */
16315 {
16316 assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */
16317 na |= FFESYMBOL_attrsACTUALARG;
16318 where = FFEINFO_whereGLOBAL;
16319 }
16320 }
16321 }
16322 else if (sa & FFESYMBOL_attrsDUMMY)
16323 {
16324 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16325 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16326 | FFESYMBOL_attrsEXTERNAL
16327 | FFESYMBOL_attrsTYPE)));
16328
16329 kind = FFEINFO_kindENTITY;
16330 if (!(sa & FFESYMBOL_attrsTYPE))
16331 needs_type = TRUE;
16332 }
16333 else if (sa & FFESYMBOL_attrsARRAY)
16334 {
16335 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16336 | FFESYMBOL_attrsADJUSTABLE
16337 | FFESYMBOL_attrsTYPE)));
16338
16339 where = FFEINFO_whereLOCAL;
16340 }
16341 else if (sa & FFESYMBOL_attrsSFARG)
16342 {
16343 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16344 | FFESYMBOL_attrsTYPE)));
16345
16346 where = FFEINFO_whereLOCAL;
16347 }
16348 else if (sa & FFESYMBOL_attrsTYPE)
16349 {
16350 assert (!(sa & (FFESYMBOL_attrsARRAY
16351 | FFESYMBOL_attrsDUMMY
16352 | FFESYMBOL_attrsEXTERNAL
16353 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16354 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16355 | FFESYMBOL_attrsADJUSTABLE
16356 | FFESYMBOL_attrsANYLEN
16357 | FFESYMBOL_attrsARRAY
16358 | FFESYMBOL_attrsDUMMY
16359 | FFESYMBOL_attrsEXTERNAL
16360 | FFESYMBOL_attrsSFARG)));
16361
16362 if (sa & FFESYMBOL_attrsANYLEN)
16363 ns = FFESYMBOL_stateNONE;
16364 else
16365 {
16366 kind = FFEINFO_kindENTITY;
16367 where = FFEINFO_whereLOCAL;
16368 }
16369 }
16370 else if (sa == FFESYMBOL_attrsetNONE)
16371 {
16372 /* New state is left empty because there isn't any state flag to
16373 set for this case, and it's UNDERSTOOD after all. */
16374 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16375 kind = FFEINFO_kindENTITY;
16376 where = FFEINFO_whereLOCAL;
16377 needs_type = TRUE;
16378 }
16379 else
16380 ns = FFESYMBOL_stateNONE; /* Error. */
16381
16382 /* Now see what we've got for a new object: NONE means a new error cropped
16383 up; ANY means an old error to be ignored; otherwise, everything's ok,
16384 update the object (symbol) and continue on. */
16385
16386 if (ns == FFESYMBOL_stateNONE)
16387 ffesymbol_error (s, t);
16388 else if (!(na & FFESYMBOL_attrsANY))
16389 {
16390 ffesymbol_signal_change (s); /* May need to back up to previous
16391 version. */
16392 if (needs_type && !ffeimplic_establish_symbol (s))
16393 {
16394 ffesymbol_error (s, t);
16395 return s;
16396 }
16397 ffesymbol_set_info (s,
16398 ffeinfo_new (ffesymbol_basictype (s),
16399 ffesymbol_kindtype (s),
16400 ffesymbol_rank (s),
16401 kind,
16402 where,
16403 ffesymbol_size (s)));
16404 ffesymbol_set_attrs (s, na);
16405 ffesymbol_set_state (s, ns);
16406 s = ffecom_sym_learned (s);
16407 ffesymbol_reference (s, t, FALSE);
16408 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16409 }
16410
16411 return s;
16412 }
16413
16414 /* Have FOO in DIMENSION XYZ(FOO) or any array declarator containing
16415 a reference to FOO. */
16416
16417 static ffesymbol
16418 ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t)
16419 {
16420 ffesymbolAttrs sa;
16421 ffesymbolAttrs na;
16422 ffeinfoKind kind;
16423 ffeinfoWhere where;
16424
16425 na = sa = ffesymbol_attrs (s);
16426 kind = FFEINFO_kindENTITY;
16427 where = ffesymbol_where (s);
16428
16429 /* Figure out what kind of object we've got based on previous declarations
16430 of or references to the object. */
16431
16432 if (!(sa & ~(FFESYMBOL_attrsADJUSTS
16433 | FFESYMBOL_attrsCOMMON
16434 | FFESYMBOL_attrsDUMMY
16435 | FFESYMBOL_attrsEQUIV
16436 | FFESYMBOL_attrsINIT
16437 | FFESYMBOL_attrsNAMELIST
16438 | FFESYMBOL_attrsSFARG
16439 | FFESYMBOL_attrsARRAY
16440 | FFESYMBOL_attrsTYPE)))
16441 na = sa | FFESYMBOL_attrsADJUSTS;
16442 else
16443 na = FFESYMBOL_attrsetNONE;
16444
16445 /* Since this symbol definitely is going into an expression (the
16446 dimension-list for some dummy array, presumably), figure out WHERE if
16447 possible. */
16448
16449 if (where == FFEINFO_whereNONE)
16450 {
16451 if (na & (FFESYMBOL_attrsCOMMON
16452 | FFESYMBOL_attrsEQUIV
16453 | FFESYMBOL_attrsINIT
16454 | FFESYMBOL_attrsNAMELIST))
16455 where = FFEINFO_whereCOMMON;
16456 else if (na & FFESYMBOL_attrsDUMMY)
16457 where = FFEINFO_whereDUMMY;
16458 }
16459
16460 /* Now see what we've got for a new object: NONE means a new error cropped
16461 up; ANY means an old error to be ignored; otherwise, everything's ok,
16462 update the object (symbol) and continue on. */
16463
16464 if (na == FFESYMBOL_attrsetNONE)
16465 ffesymbol_error (s, t);
16466 else if (!(na & FFESYMBOL_attrsANY))
16467 {
16468 ffesymbol_signal_change (s); /* May need to back up to previous
16469 version. */
16470 if (!ffeimplic_establish_symbol (s))
16471 {
16472 ffesymbol_error (s, t);
16473 return s;
16474 }
16475 ffesymbol_set_info (s,
16476 ffeinfo_new (ffesymbol_basictype (s),
16477 ffesymbol_kindtype (s),
16478 ffesymbol_rank (s),
16479 kind, /* Always ENTITY. */
16480 where, /* NONE, COMMON, or DUMMY. */
16481 ffesymbol_size (s)));
16482 ffesymbol_set_attrs (s, na);
16483 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
16484 ffesymbol_resolve_intrin (s);
16485 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16486 }
16487
16488 return s;
16489 }
16490
16491 /* Have FOO in XYZ = ...FOO.... Does not include cases like FOO in
16492 XYZ = BAR(FOO), as such cases are handled elsewhere. */
16493
16494 static ffesymbol
16495 ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t)
16496 {
16497 ffesymbolAttrs sa;
16498 ffesymbolAttrs na;
16499 ffeinfoKind kind;
16500 ffeinfoWhere where;
16501 bool error = FALSE;
16502
16503 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16504 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16505
16506 na = sa = ffesymbol_attrs (s);
16507
16508 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16509 | FFESYMBOL_attrsADJUSTABLE
16510 | FFESYMBOL_attrsANYLEN
16511 | FFESYMBOL_attrsARRAY
16512 | FFESYMBOL_attrsDUMMY
16513 | FFESYMBOL_attrsEXTERNAL
16514 | FFESYMBOL_attrsSFARG
16515 | FFESYMBOL_attrsTYPE)));
16516
16517 kind = ffesymbol_kind (s);
16518 where = ffesymbol_where (s);
16519
16520 /* Figure out what kind of object we've got based on previous declarations
16521 of or references to the object. */
16522
16523 if (sa & FFESYMBOL_attrsEXTERNAL)
16524 {
16525 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16526 | FFESYMBOL_attrsDUMMY
16527 | FFESYMBOL_attrsEXTERNAL
16528 | FFESYMBOL_attrsTYPE)));
16529
16530 error = TRUE;
16531 }
16532 else if (sa & FFESYMBOL_attrsDUMMY)
16533 {
16534 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16535 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16536 | FFESYMBOL_attrsEXTERNAL
16537 | FFESYMBOL_attrsTYPE)));
16538
16539 kind = FFEINFO_kindENTITY;
16540 }
16541 else if (sa & FFESYMBOL_attrsARRAY)
16542 {
16543 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16544 | FFESYMBOL_attrsADJUSTABLE
16545 | FFESYMBOL_attrsTYPE)));
16546
16547 where = FFEINFO_whereLOCAL;
16548 }
16549 else if (sa & FFESYMBOL_attrsSFARG)
16550 {
16551 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16552 | FFESYMBOL_attrsTYPE)));
16553
16554 where = FFEINFO_whereLOCAL;
16555 }
16556 else if (sa & FFESYMBOL_attrsTYPE)
16557 {
16558 assert (!(sa & (FFESYMBOL_attrsARRAY
16559 | FFESYMBOL_attrsDUMMY
16560 | FFESYMBOL_attrsEXTERNAL
16561 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16562 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16563 | FFESYMBOL_attrsADJUSTABLE
16564 | FFESYMBOL_attrsANYLEN
16565 | FFESYMBOL_attrsARRAY
16566 | FFESYMBOL_attrsDUMMY
16567 | FFESYMBOL_attrsEXTERNAL
16568 | FFESYMBOL_attrsSFARG)));
16569
16570 if (sa & FFESYMBOL_attrsANYLEN)
16571 error = TRUE;
16572 else
16573 {
16574 kind = FFEINFO_kindENTITY;
16575 where = FFEINFO_whereLOCAL;
16576 }
16577 }
16578 else if (sa == FFESYMBOL_attrsetNONE)
16579 {
16580 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16581 kind = FFEINFO_kindENTITY;
16582 where = FFEINFO_whereLOCAL;
16583 }
16584 else
16585 error = TRUE;
16586
16587 /* Now see what we've got for a new object: NONE means a new error cropped
16588 up; ANY means an old error to be ignored; otherwise, everything's ok,
16589 update the object (symbol) and continue on. */
16590
16591 if (error)
16592 ffesymbol_error (s, t);
16593 else if (!(na & FFESYMBOL_attrsANY))
16594 {
16595 ffesymbol_signal_change (s); /* May need to back up to previous
16596 version. */
16597 if (!ffeimplic_establish_symbol (s))
16598 {
16599 ffesymbol_error (s, t);
16600 return s;
16601 }
16602 ffesymbol_set_info (s,
16603 ffeinfo_new (ffesymbol_basictype (s),
16604 ffesymbol_kindtype (s),
16605 ffesymbol_rank (s),
16606 kind, /* ENTITY. */
16607 where, /* LOCAL. */
16608 ffesymbol_size (s)));
16609 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16610 ffesymbol_resolve_intrin (s);
16611 s = ffecom_sym_learned (s);
16612 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16613 }
16614
16615 return s;
16616 }
16617
16618 /* ffeexpr_declare_parenthesized_ -- ffesymbol wrapper for NAME(...) operand
16619
16620 ffelexToken t;
16621 bool maybe_intrin;
16622 ffeexprParenType_ paren_type;
16623 ffesymbol s;
16624 s = ffeexpr_declare_parenthesized_ (t, maybe_intrin, &paren_type);
16625
16626 Just like ffesymbol_declare_local, except performs any implicit info
16627 assignment necessary, and it returns the type of the parenthesized list
16628 (list of function args, list of array args, or substring spec). */
16629
16630 static ffesymbol
16631 ffeexpr_declare_parenthesized_ (ffelexToken t, bool maybe_intrin,
16632 ffeexprParenType_ *paren_type)
16633 {
16634 ffesymbol s;
16635 ffesymbolState st; /* Effective state. */
16636 ffeinfoKind k;
16637 bool bad;
16638
16639 if (maybe_intrin && ffesrc_check_symbol ())
16640 { /* Knock off some easy cases. */
16641 switch (ffeexpr_stack_->context)
16642 {
16643 case FFEEXPR_contextSUBROUTINEREF:
16644 case FFEEXPR_contextDATA:
16645 case FFEEXPR_contextDATAIMPDOINDEX_:
16646 case FFEEXPR_contextSFUNCDEF:
16647 case FFEEXPR_contextSFUNCDEFINDEX_:
16648 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16649 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16650 case FFEEXPR_contextLET:
16651 case FFEEXPR_contextPAREN_:
16652 case FFEEXPR_contextACTUALARGEXPR_:
16653 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16654 case FFEEXPR_contextIOLIST:
16655 case FFEEXPR_contextIOLISTDF:
16656 case FFEEXPR_contextDO:
16657 case FFEEXPR_contextDOWHILE:
16658 case FFEEXPR_contextACTUALARG_:
16659 case FFEEXPR_contextCGOTO:
16660 case FFEEXPR_contextIF:
16661 case FFEEXPR_contextARITHIF:
16662 case FFEEXPR_contextFORMAT:
16663 case FFEEXPR_contextSTOP:
16664 case FFEEXPR_contextRETURN:
16665 case FFEEXPR_contextSELECTCASE:
16666 case FFEEXPR_contextCASE:
16667 case FFEEXPR_contextFILEASSOC:
16668 case FFEEXPR_contextFILEINT:
16669 case FFEEXPR_contextFILEDFINT:
16670 case FFEEXPR_contextFILELOG:
16671 case FFEEXPR_contextFILENUM:
16672 case FFEEXPR_contextFILENUMAMBIG:
16673 case FFEEXPR_contextFILECHAR:
16674 case FFEEXPR_contextFILENUMCHAR:
16675 case FFEEXPR_contextFILEDFCHAR:
16676 case FFEEXPR_contextFILEKEY:
16677 case FFEEXPR_contextFILEUNIT:
16678 case FFEEXPR_contextFILEUNIT_DF:
16679 case FFEEXPR_contextFILEUNITAMBIG:
16680 case FFEEXPR_contextFILEFORMAT:
16681 case FFEEXPR_contextFILENAMELIST:
16682 case FFEEXPR_contextFILEVXTCODE:
16683 case FFEEXPR_contextINDEX_:
16684 case FFEEXPR_contextIMPDOITEM_:
16685 case FFEEXPR_contextIMPDOITEMDF_:
16686 case FFEEXPR_contextIMPDOCTRL_:
16687 case FFEEXPR_contextDATAIMPDOCTRL_:
16688 case FFEEXPR_contextCHARACTERSIZE:
16689 case FFEEXPR_contextPARAMETER:
16690 case FFEEXPR_contextDIMLIST:
16691 case FFEEXPR_contextDIMLISTCOMMON:
16692 case FFEEXPR_contextKINDTYPE:
16693 case FFEEXPR_contextINITVAL:
16694 case FFEEXPR_contextEQVINDEX_:
16695 break; /* These could be intrinsic invocations. */
16696
16697 case FFEEXPR_contextAGOTO:
16698 case FFEEXPR_contextFILEFORMATNML:
16699 case FFEEXPR_contextALLOCATE:
16700 case FFEEXPR_contextDEALLOCATE:
16701 case FFEEXPR_contextHEAPSTAT:
16702 case FFEEXPR_contextNULLIFY:
16703 case FFEEXPR_contextINCLUDE:
16704 case FFEEXPR_contextDATAIMPDOITEM_:
16705 case FFEEXPR_contextLOC_:
16706 case FFEEXPR_contextINDEXORACTUALARG_:
16707 case FFEEXPR_contextSFUNCDEFACTUALARG_:
16708 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
16709 case FFEEXPR_contextPARENFILENUM_:
16710 case FFEEXPR_contextPARENFILEUNIT_:
16711 maybe_intrin = FALSE;
16712 break; /* Can't be intrinsic invocation. */
16713
16714 default:
16715 assert ("blah! blah! waaauuggh!" == NULL);
16716 break;
16717 }
16718 }
16719
16720 s = ffesymbol_declare_local (t, maybe_intrin);
16721
16722 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16723 /* Special-case these since they can involve a different concept
16724 of "state" (in the stmtfunc name space). */
16725 {
16726 case FFEEXPR_contextDATAIMPDOINDEX_:
16727 case FFEEXPR_contextDATAIMPDOCTRL_:
16728 if (ffeexpr_context_outer_ (ffeexpr_stack_)
16729 == FFEEXPR_contextDATAIMPDOINDEX_)
16730 s = ffeexpr_sym_impdoitem_ (s, t);
16731 else
16732 if (ffeexpr_stack_->is_rhs)
16733 s = ffeexpr_sym_impdoitem_ (s, t);
16734 else
16735 s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
16736 if (ffesymbol_kind (s) != FFEINFO_kindANY)
16737 ffesymbol_error (s, t);
16738 return s;
16739
16740 default:
16741 break;
16742 }
16743
16744 switch ((ffesymbol_sfdummyparent (s) == NULL)
16745 ? ffesymbol_state (s)
16746 : FFESYMBOL_stateUNDERSTOOD)
16747 {
16748 case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr
16749 context. */
16750 if (!ffest_seen_first_exec ())
16751 goto seen; /* :::::::::::::::::::: */
16752 /* Fall through. */
16753 case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */
16754 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16755 {
16756 case FFEEXPR_contextSUBROUTINEREF:
16757 s = ffeexpr_sym_lhs_call_ (s, t); /* "CALL FOO"=="CALL
16758 FOO(...)". */
16759 break;
16760
16761 case FFEEXPR_contextDATA:
16762 if (ffeexpr_stack_->is_rhs)
16763 s = ffeexpr_sym_rhs_let_ (s, t);
16764 else
16765 s = ffeexpr_sym_lhs_data_ (s, t);
16766 break;
16767
16768 case FFEEXPR_contextDATAIMPDOITEM_:
16769 s = ffeexpr_sym_lhs_data_ (s, t);
16770 break;
16771
16772 case FFEEXPR_contextSFUNCDEF:
16773 case FFEEXPR_contextSFUNCDEFINDEX_:
16774 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16775 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16776 s = ffecom_sym_exec_transition (s);
16777 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16778 goto understood; /* :::::::::::::::::::: */
16779 /* Fall through. */
16780 case FFEEXPR_contextLET:
16781 case FFEEXPR_contextPAREN_:
16782 case FFEEXPR_contextACTUALARGEXPR_:
16783 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16784 case FFEEXPR_contextIOLIST:
16785 case FFEEXPR_contextIOLISTDF:
16786 case FFEEXPR_contextDO:
16787 case FFEEXPR_contextDOWHILE:
16788 case FFEEXPR_contextACTUALARG_:
16789 case FFEEXPR_contextCGOTO:
16790 case FFEEXPR_contextIF:
16791 case FFEEXPR_contextARITHIF:
16792 case FFEEXPR_contextFORMAT:
16793 case FFEEXPR_contextSTOP:
16794 case FFEEXPR_contextRETURN:
16795 case FFEEXPR_contextSELECTCASE:
16796 case FFEEXPR_contextCASE:
16797 case FFEEXPR_contextFILEASSOC:
16798 case FFEEXPR_contextFILEINT:
16799 case FFEEXPR_contextFILEDFINT:
16800 case FFEEXPR_contextFILELOG:
16801 case FFEEXPR_contextFILENUM:
16802 case FFEEXPR_contextFILENUMAMBIG:
16803 case FFEEXPR_contextFILECHAR:
16804 case FFEEXPR_contextFILENUMCHAR:
16805 case FFEEXPR_contextFILEDFCHAR:
16806 case FFEEXPR_contextFILEKEY:
16807 case FFEEXPR_contextFILEUNIT:
16808 case FFEEXPR_contextFILEUNIT_DF:
16809 case FFEEXPR_contextFILEUNITAMBIG:
16810 case FFEEXPR_contextFILEFORMAT:
16811 case FFEEXPR_contextFILENAMELIST:
16812 case FFEEXPR_contextFILEVXTCODE:
16813 case FFEEXPR_contextINDEX_:
16814 case FFEEXPR_contextIMPDOITEM_:
16815 case FFEEXPR_contextIMPDOITEMDF_:
16816 case FFEEXPR_contextIMPDOCTRL_:
16817 case FFEEXPR_contextLOC_:
16818 if (ffeexpr_stack_->is_rhs)
16819 s = ffeexpr_paren_rhs_let_ (s, t);
16820 else
16821 s = ffeexpr_paren_lhs_let_ (s, t);
16822 break;
16823
16824 case FFEEXPR_contextASSIGN:
16825 case FFEEXPR_contextAGOTO:
16826 case FFEEXPR_contextCHARACTERSIZE:
16827 case FFEEXPR_contextEQUIVALENCE:
16828 case FFEEXPR_contextINCLUDE:
16829 case FFEEXPR_contextPARAMETER:
16830 case FFEEXPR_contextDIMLIST:
16831 case FFEEXPR_contextDIMLISTCOMMON:
16832 case FFEEXPR_contextKINDTYPE:
16833 case FFEEXPR_contextINITVAL:
16834 case FFEEXPR_contextEQVINDEX_:
16835 break; /* Will turn into errors below. */
16836
16837 default:
16838 ffesymbol_error (s, t);
16839 break;
16840 }
16841 /* Fall through. */
16842 case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */
16843 understood: /* :::::::::::::::::::: */
16844
16845 /* State might have changed, update it. */
16846 st = ((ffesymbol_sfdummyparent (s) == NULL)
16847 ? ffesymbol_state (s)
16848 : FFESYMBOL_stateUNDERSTOOD);
16849
16850 k = ffesymbol_kind (s);
16851 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16852 {
16853 case FFEEXPR_contextSUBROUTINEREF:
16854 bad = ((k != FFEINFO_kindSUBROUTINE)
16855 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
16856 || (k != FFEINFO_kindNONE)));
16857 break;
16858
16859 case FFEEXPR_contextDATA:
16860 if (ffeexpr_stack_->is_rhs)
16861 bad = (k != FFEINFO_kindENTITY)
16862 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16863 else
16864 bad = (k != FFEINFO_kindENTITY)
16865 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
16866 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
16867 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
16868 break;
16869
16870 case FFEEXPR_contextDATAIMPDOITEM_:
16871 bad = (k != FFEINFO_kindENTITY) || (ffesymbol_rank (s) == 0)
16872 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
16873 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
16874 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
16875 break;
16876
16877 case FFEEXPR_contextSFUNCDEF:
16878 case FFEEXPR_contextSFUNCDEFINDEX_:
16879 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16880 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16881 case FFEEXPR_contextLET:
16882 case FFEEXPR_contextPAREN_:
16883 case FFEEXPR_contextACTUALARGEXPR_:
16884 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16885 case FFEEXPR_contextIOLIST:
16886 case FFEEXPR_contextIOLISTDF:
16887 case FFEEXPR_contextDO:
16888 case FFEEXPR_contextDOWHILE:
16889 case FFEEXPR_contextACTUALARG_:
16890 case FFEEXPR_contextCGOTO:
16891 case FFEEXPR_contextIF:
16892 case FFEEXPR_contextARITHIF:
16893 case FFEEXPR_contextFORMAT:
16894 case FFEEXPR_contextSTOP:
16895 case FFEEXPR_contextRETURN:
16896 case FFEEXPR_contextSELECTCASE:
16897 case FFEEXPR_contextCASE:
16898 case FFEEXPR_contextFILEASSOC:
16899 case FFEEXPR_contextFILEINT:
16900 case FFEEXPR_contextFILEDFINT:
16901 case FFEEXPR_contextFILELOG:
16902 case FFEEXPR_contextFILENUM:
16903 case FFEEXPR_contextFILENUMAMBIG:
16904 case FFEEXPR_contextFILECHAR:
16905 case FFEEXPR_contextFILENUMCHAR:
16906 case FFEEXPR_contextFILEDFCHAR:
16907 case FFEEXPR_contextFILEKEY:
16908 case FFEEXPR_contextFILEUNIT:
16909 case FFEEXPR_contextFILEUNIT_DF:
16910 case FFEEXPR_contextFILEUNITAMBIG:
16911 case FFEEXPR_contextFILEFORMAT:
16912 case FFEEXPR_contextFILENAMELIST:
16913 case FFEEXPR_contextFILEVXTCODE:
16914 case FFEEXPR_contextINDEX_:
16915 case FFEEXPR_contextIMPDOITEM_:
16916 case FFEEXPR_contextIMPDOITEMDF_:
16917 case FFEEXPR_contextIMPDOCTRL_:
16918 case FFEEXPR_contextLOC_:
16919 bad = FALSE; /* Let paren-switch handle the cases. */
16920 break;
16921
16922 case FFEEXPR_contextASSIGN:
16923 case FFEEXPR_contextAGOTO:
16924 case FFEEXPR_contextCHARACTERSIZE:
16925 case FFEEXPR_contextEQUIVALENCE:
16926 case FFEEXPR_contextPARAMETER:
16927 case FFEEXPR_contextDIMLIST:
16928 case FFEEXPR_contextDIMLISTCOMMON:
16929 case FFEEXPR_contextKINDTYPE:
16930 case FFEEXPR_contextINITVAL:
16931 case FFEEXPR_contextEQVINDEX_:
16932 bad = (k != FFEINFO_kindENTITY)
16933 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16934 break;
16935
16936 case FFEEXPR_contextINCLUDE:
16937 bad = TRUE;
16938 break;
16939
16940 default:
16941 bad = TRUE;
16942 break;
16943 }
16944
16945 switch (bad ? FFEINFO_kindANY : k)
16946 {
16947 case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */
16948 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
16949 {
16950 if (ffeexpr_context_outer_ (ffeexpr_stack_)
16951 == FFEEXPR_contextSUBROUTINEREF)
16952 *paren_type = FFEEXPR_parentypeSUBROUTINE_;
16953 else
16954 *paren_type = FFEEXPR_parentypeFUNCTION_;
16955 break;
16956 }
16957 if (st == FFESYMBOL_stateUNDERSTOOD)
16958 {
16959 bad = TRUE;
16960 *paren_type = FFEEXPR_parentypeANY_;
16961 }
16962 else
16963 *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
16964 break;
16965
16966 case FFEINFO_kindFUNCTION:
16967 *paren_type = FFEEXPR_parentypeFUNCTION_;
16968 switch (ffesymbol_where (s))
16969 {
16970 case FFEINFO_whereLOCAL:
16971 bad = TRUE; /* Attempt to recurse! */
16972 break;
16973
16974 case FFEINFO_whereCONSTANT:
16975 bad = ((ffesymbol_sfexpr (s) == NULL)
16976 || (ffebld_op (ffesymbol_sfexpr (s))
16977 == FFEBLD_opANY)); /* Attempt to recurse! */
16978 break;
16979
16980 default:
16981 break;
16982 }
16983 break;
16984
16985 case FFEINFO_kindSUBROUTINE:
16986 if ((ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
16987 || (ffeexpr_stack_->previous != NULL))
16988 {
16989 bad = TRUE;
16990 *paren_type = FFEEXPR_parentypeANY_;
16991 break;
16992 }
16993
16994 *paren_type = FFEEXPR_parentypeSUBROUTINE_;
16995 switch (ffesymbol_where (s))
16996 {
16997 case FFEINFO_whereLOCAL:
16998 case FFEINFO_whereCONSTANT:
16999 bad = TRUE; /* Attempt to recurse! */
17000 break;
17001
17002 default:
17003 break;
17004 }
17005 break;
17006
17007 case FFEINFO_kindENTITY:
17008 if (ffesymbol_rank (s) == 0)
17009 {
17010 if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
17011 *paren_type = FFEEXPR_parentypeSUBSTRING_;
17012 else
17013 {
17014 bad = TRUE;
17015 *paren_type = FFEEXPR_parentypeANY_;
17016 }
17017 }
17018 else
17019 *paren_type = FFEEXPR_parentypeARRAY_;
17020 break;
17021
17022 default:
17023 case FFEINFO_kindANY:
17024 bad = TRUE;
17025 *paren_type = FFEEXPR_parentypeANY_;
17026 break;
17027 }
17028
17029 if (bad)
17030 {
17031 if (k == FFEINFO_kindANY)
17032 ffest_shutdown ();
17033 else
17034 ffesymbol_error (s, t);
17035 }
17036
17037 return s;
17038
17039 case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */
17040 seen: /* :::::::::::::::::::: */
17041 bad = TRUE;
17042 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17043 {
17044 case FFEEXPR_contextPARAMETER:
17045 if (ffeexpr_stack_->is_rhs)
17046 ffesymbol_error (s, t);
17047 else
17048 s = ffeexpr_sym_lhs_parameter_ (s, t);
17049 break;
17050
17051 case FFEEXPR_contextDATA:
17052 s = ffecom_sym_exec_transition (s);
17053 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17054 goto understood; /* :::::::::::::::::::: */
17055 if (ffeexpr_stack_->is_rhs)
17056 ffesymbol_error (s, t);
17057 else
17058 s = ffeexpr_sym_lhs_data_ (s, t);
17059 goto understood; /* :::::::::::::::::::: */
17060
17061 case FFEEXPR_contextDATAIMPDOITEM_:
17062 s = ffecom_sym_exec_transition (s);
17063 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17064 goto understood; /* :::::::::::::::::::: */
17065 s = ffeexpr_sym_lhs_data_ (s, t);
17066 goto understood; /* :::::::::::::::::::: */
17067
17068 case FFEEXPR_contextEQUIVALENCE:
17069 s = ffeexpr_sym_lhs_equivalence_ (s, t);
17070 bad = FALSE;
17071 break;
17072
17073 case FFEEXPR_contextDIMLIST:
17074 s = ffeexpr_sym_rhs_dimlist_ (s, t);
17075 bad = FALSE;
17076 break;
17077
17078 case FFEEXPR_contextCHARACTERSIZE:
17079 case FFEEXPR_contextKINDTYPE:
17080 case FFEEXPR_contextDIMLISTCOMMON:
17081 case FFEEXPR_contextINITVAL:
17082 case FFEEXPR_contextEQVINDEX_:
17083 break;
17084
17085 case FFEEXPR_contextINCLUDE:
17086 break;
17087
17088 case FFEEXPR_contextINDEX_:
17089 case FFEEXPR_contextACTUALARGEXPR_:
17090 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17091 case FFEEXPR_contextSFUNCDEF:
17092 case FFEEXPR_contextSFUNCDEFINDEX_:
17093 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17094 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17095 assert (ffeexpr_stack_->is_rhs);
17096 s = ffecom_sym_exec_transition (s);
17097 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17098 goto understood; /* :::::::::::::::::::: */
17099 s = ffeexpr_paren_rhs_let_ (s, t);
17100 goto understood; /* :::::::::::::::::::: */
17101
17102 default:
17103 break;
17104 }
17105 k = ffesymbol_kind (s);
17106 switch (bad ? FFEINFO_kindANY : k)
17107 {
17108 case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */
17109 *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
17110 break;
17111
17112 case FFEINFO_kindFUNCTION:
17113 *paren_type = FFEEXPR_parentypeFUNCTION_;
17114 switch (ffesymbol_where (s))
17115 {
17116 case FFEINFO_whereLOCAL:
17117 bad = TRUE; /* Attempt to recurse! */
17118 break;
17119
17120 case FFEINFO_whereCONSTANT:
17121 bad = ((ffesymbol_sfexpr (s) == NULL)
17122 || (ffebld_op (ffesymbol_sfexpr (s))
17123 == FFEBLD_opANY)); /* Attempt to recurse! */
17124 break;
17125
17126 default:
17127 break;
17128 }
17129 break;
17130
17131 case FFEINFO_kindSUBROUTINE:
17132 *paren_type = FFEEXPR_parentypeANY_;
17133 bad = TRUE; /* Cannot possibly be in
17134 contextSUBROUTINEREF. */
17135 break;
17136
17137 case FFEINFO_kindENTITY:
17138 if (ffesymbol_rank (s) == 0)
17139 {
17140 if (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE)
17141 *paren_type = FFEEXPR_parentypeEQUIVALENCE_;
17142 else if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
17143 *paren_type = FFEEXPR_parentypeSUBSTRING_;
17144 else
17145 {
17146 bad = TRUE;
17147 *paren_type = FFEEXPR_parentypeANY_;
17148 }
17149 }
17150 else
17151 *paren_type = FFEEXPR_parentypeARRAY_;
17152 break;
17153
17154 default:
17155 case FFEINFO_kindANY:
17156 bad = TRUE;
17157 *paren_type = FFEEXPR_parentypeANY_;
17158 break;
17159 }
17160
17161 if (bad)
17162 {
17163 if (k == FFEINFO_kindANY)
17164 ffest_shutdown ();
17165 else
17166 ffesymbol_error (s, t);
17167 }
17168
17169 return s;
17170
17171 default:
17172 assert ("bad symbol state" == NULL);
17173 return NULL;
17174 }
17175 }
17176
17177 /* Have FOO in XYZ = ...FOO(...).... Executable context only. */
17178
17179 static ffesymbol
17180 ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t)
17181 {
17182 ffesymbolAttrs sa;
17183 ffesymbolAttrs na;
17184 ffeinfoKind kind;
17185 ffeinfoWhere where;
17186 ffeintrinGen gen;
17187 ffeintrinSpec spec;
17188 ffeintrinImp imp;
17189 bool maybe_ambig = FALSE;
17190 bool error = FALSE;
17191
17192 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
17193 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
17194
17195 na = sa = ffesymbol_attrs (s);
17196
17197 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17198 | FFESYMBOL_attrsADJUSTABLE
17199 | FFESYMBOL_attrsANYLEN
17200 | FFESYMBOL_attrsARRAY
17201 | FFESYMBOL_attrsDUMMY
17202 | FFESYMBOL_attrsEXTERNAL
17203 | FFESYMBOL_attrsSFARG
17204 | FFESYMBOL_attrsTYPE)));
17205
17206 kind = ffesymbol_kind (s);
17207 where = ffesymbol_where (s);
17208
17209 /* Figure out what kind of object we've got based on previous declarations
17210 of or references to the object. */
17211
17212 if (sa & FFESYMBOL_attrsEXTERNAL)
17213 {
17214 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17215 | FFESYMBOL_attrsDUMMY
17216 | FFESYMBOL_attrsEXTERNAL
17217 | FFESYMBOL_attrsTYPE)));
17218
17219 if (sa & FFESYMBOL_attrsTYPE)
17220 where = FFEINFO_whereGLOBAL;
17221 else
17222 /* Not TYPE. */
17223 {
17224 kind = FFEINFO_kindFUNCTION;
17225
17226 if (sa & FFESYMBOL_attrsDUMMY)
17227 ; /* Not TYPE. */
17228 else if (sa & FFESYMBOL_attrsACTUALARG)
17229 ; /* Not DUMMY or TYPE. */
17230 else /* Not ACTUALARG, DUMMY, or TYPE. */
17231 where = FFEINFO_whereGLOBAL;
17232 }
17233 }
17234 else if (sa & FFESYMBOL_attrsDUMMY)
17235 {
17236 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
17237 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
17238 | FFESYMBOL_attrsEXTERNAL
17239 | FFESYMBOL_attrsTYPE)));
17240
17241 kind = FFEINFO_kindFUNCTION;
17242 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure; kind
17243 could be ENTITY w/substring ref. */
17244 }
17245 else if (sa & FFESYMBOL_attrsARRAY)
17246 {
17247 assert (!(sa & ~(FFESYMBOL_attrsARRAY
17248 | FFESYMBOL_attrsADJUSTABLE
17249 | FFESYMBOL_attrsTYPE)));
17250
17251 where = FFEINFO_whereLOCAL;
17252 }
17253 else if (sa & FFESYMBOL_attrsSFARG)
17254 {
17255 assert (!(sa & ~(FFESYMBOL_attrsSFARG
17256 | FFESYMBOL_attrsTYPE)));
17257
17258 where = FFEINFO_whereLOCAL; /* Actually an error, but at least we
17259 know it's a local var. */
17260 }
17261 else if (sa & FFESYMBOL_attrsTYPE)
17262 {
17263 assert (!(sa & (FFESYMBOL_attrsARRAY
17264 | FFESYMBOL_attrsDUMMY
17265 | FFESYMBOL_attrsEXTERNAL
17266 | FFESYMBOL_attrsSFARG))); /* Handled above. */
17267 assert (!(sa & ~(FFESYMBOL_attrsTYPE
17268 | FFESYMBOL_attrsADJUSTABLE
17269 | FFESYMBOL_attrsANYLEN
17270 | FFESYMBOL_attrsARRAY
17271 | FFESYMBOL_attrsDUMMY
17272 | FFESYMBOL_attrsEXTERNAL
17273 | FFESYMBOL_attrsSFARG)));
17274
17275 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
17276 &gen, &spec, &imp))
17277 {
17278 if (!(sa & FFESYMBOL_attrsANYLEN)
17279 && (ffeimplic_peek_symbol_type (s, NULL)
17280 == FFEINFO_basictypeCHARACTER))
17281 return s; /* Haven't learned anything yet. */
17282
17283 ffesymbol_signal_change (s); /* May need to back up to previous
17284 version. */
17285 ffesymbol_set_generic (s, gen);
17286 ffesymbol_set_specific (s, spec);
17287 ffesymbol_set_implementation (s, imp);
17288 ffesymbol_set_info (s,
17289 ffeinfo_new (ffesymbol_basictype (s),
17290 ffesymbol_kindtype (s),
17291 0,
17292 FFEINFO_kindFUNCTION,
17293 FFEINFO_whereINTRINSIC,
17294 ffesymbol_size (s)));
17295 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17296 ffesymbol_resolve_intrin (s);
17297 ffesymbol_reference (s, t, FALSE);
17298 s = ffecom_sym_learned (s);
17299 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17300
17301 return s;
17302 }
17303 if (sa & FFESYMBOL_attrsANYLEN)
17304 error = TRUE; /* Error, since the only way we can,
17305 given CHARACTER*(*) FOO, accept
17306 FOO(...) is for FOO to be a dummy
17307 arg or constant, but it can't
17308 become either now. */
17309 else if (sa & FFESYMBOL_attrsADJUSTABLE)
17310 {
17311 kind = FFEINFO_kindENTITY;
17312 where = FFEINFO_whereLOCAL;
17313 }
17314 else
17315 {
17316 kind = FFEINFO_kindFUNCTION;
17317 where = FFEINFO_whereGLOBAL;
17318 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure;
17319 could be ENTITY/LOCAL w/substring ref. */
17320 }
17321 }
17322 else if (sa == FFESYMBOL_attrsetNONE)
17323 {
17324 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
17325
17326 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
17327 &gen, &spec, &imp))
17328 {
17329 if (ffeimplic_peek_symbol_type (s, NULL)
17330 == FFEINFO_basictypeCHARACTER)
17331 return s; /* Haven't learned anything yet. */
17332
17333 ffesymbol_signal_change (s); /* May need to back up to previous
17334 version. */
17335 ffesymbol_set_generic (s, gen);
17336 ffesymbol_set_specific (s, spec);
17337 ffesymbol_set_implementation (s, imp);
17338 ffesymbol_set_info (s,
17339 ffeinfo_new (ffesymbol_basictype (s),
17340 ffesymbol_kindtype (s),
17341 0,
17342 FFEINFO_kindFUNCTION,
17343 FFEINFO_whereINTRINSIC,
17344 ffesymbol_size (s)));
17345 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17346 ffesymbol_resolve_intrin (s);
17347 s = ffecom_sym_learned (s);
17348 ffesymbol_reference (s, t, FALSE);
17349 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17350 return s;
17351 }
17352
17353 kind = FFEINFO_kindFUNCTION;
17354 where = FFEINFO_whereGLOBAL;
17355 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure;
17356 could be ENTITY/LOCAL w/substring ref. */
17357 }
17358 else
17359 error = TRUE;
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 (error)
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 if (maybe_ambig
17377 && (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
17378 return s; /* Still not sure, let caller deal with it
17379 based on (...). */
17380
17381 ffesymbol_set_info (s,
17382 ffeinfo_new (ffesymbol_basictype (s),
17383 ffesymbol_kindtype (s),
17384 ffesymbol_rank (s),
17385 kind,
17386 where,
17387 ffesymbol_size (s)));
17388 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17389 ffesymbol_resolve_intrin (s);
17390 s = ffecom_sym_learned (s);
17391 ffesymbol_reference (s, t, FALSE);
17392 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17393 }
17394
17395 return s;
17396 }
17397
17398 /* ffeexpr_token_arguments_ -- OPEN_PAREN [expr COMMA]...expr
17399
17400 Return a pointer to this function to the lexer (ffelex), which will
17401 invoke it for the next token.
17402
17403 Handle expression (which might be null) and COMMA or CLOSE_PAREN. */
17404
17405 static ffelexHandler
17406 ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr, ffelexToken t)
17407 {
17408 ffeexprExpr_ procedure;
17409 ffebld reduced;
17410 ffeinfo info;
17411 ffeexprContext ctx;
17412 bool check_intrin = FALSE; /* Set TRUE if intrinsic is REAL(Z) or AIMAG(Z). */
17413
17414 procedure = ffeexpr_stack_->exprstack;
17415 info = ffebld_info (procedure->u.operand);
17416
17417 /* Is there an expression to add? If the expression is nil,
17418 it might still be an argument. It is if:
17419
17420 - The current token is comma, or
17421
17422 - The -fugly-comma flag was specified *and* the procedure
17423 being invoked is external.
17424
17425 Otherwise, if neither of the above is the case, just
17426 ignore this (nil) expression. */
17427
17428 if ((expr != NULL)
17429 || (ffelex_token_type (t) == FFELEX_typeCOMMA)
17430 || (ffe_is_ugly_comma ()
17431 && (ffeinfo_where (info) == FFEINFO_whereGLOBAL)))
17432 {
17433 /* This expression, even if nil, is apparently intended as an argument. */
17434
17435 /* Internal procedure (CONTAINS, or statement function)? */
17436
17437 if (ffeinfo_where (info) == FFEINFO_whereCONSTANT)
17438 {
17439 if ((expr == NULL)
17440 && ffebad_start (FFEBAD_NULL_ARGUMENT))
17441 {
17442 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17443 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17444 ffebad_here (1, ffelex_token_where_line (t),
17445 ffelex_token_where_column (t));
17446 ffebad_finish ();
17447 }
17448
17449 if (expr == NULL)
17450 ;
17451 else
17452 {
17453 if (ffeexpr_stack_->next_dummy == NULL)
17454 { /* Report later which was the first extra argument. */
17455 if (ffeexpr_stack_->tokens[1] == NULL)
17456 {
17457 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
17458 ffeexpr_stack_->num_args = 0;
17459 }
17460 ++ffeexpr_stack_->num_args; /* Count # of extra arguments. */
17461 }
17462 else
17463 {
17464 if ((ffeinfo_rank (ffebld_info (expr)) != 0)
17465 && ffebad_start (FFEBAD_ARRAY_AS_SFARG))
17466 {
17467 ffebad_here (0,
17468 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17469 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17470 ffebad_here (1, ffelex_token_where_line (ft),
17471 ffelex_token_where_column (ft));
17472 ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent
17473 (ffebld_symter (ffebld_head
17474 (ffeexpr_stack_->next_dummy)))));
17475 ffebad_finish ();
17476 }
17477 else
17478 {
17479 expr = ffeexpr_convert_expr (expr, ft,
17480 ffebld_head (ffeexpr_stack_->next_dummy),
17481 ffeexpr_stack_->tokens[0],
17482 FFEEXPR_contextLET);
17483 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17484 }
17485 --ffeexpr_stack_->num_args; /* Count down # of args. */
17486 ffeexpr_stack_->next_dummy
17487 = ffebld_trail (ffeexpr_stack_->next_dummy);
17488 }
17489 }
17490 }
17491 else
17492 {
17493 if ((expr == NULL)
17494 && ffe_is_pedantic ()
17495 && ffebad_start (FFEBAD_NULL_ARGUMENT_W))
17496 {
17497 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17498 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17499 ffebad_here (1, ffelex_token_where_line (t),
17500 ffelex_token_where_column (t));
17501 ffebad_finish ();
17502 }
17503 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17504 }
17505 }
17506
17507 switch (ffelex_token_type (t))
17508 {
17509 case FFELEX_typeCOMMA:
17510 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17511 {
17512 case FFEEXPR_contextSFUNCDEF:
17513 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17514 case FFEEXPR_contextSFUNCDEFINDEX_:
17515 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17516 ctx = FFEEXPR_contextSFUNCDEFACTUALARG_;
17517 break;
17518
17519 case FFEEXPR_contextSFUNCDEFACTUALARG_:
17520 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
17521 assert ("bad context" == NULL);
17522 ctx = FFEEXPR_context;
17523 break;
17524
17525 default:
17526 ctx = FFEEXPR_contextACTUALARG_;
17527 break;
17528 }
17529 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
17530 ffeexpr_token_arguments_);
17531
17532 default:
17533 break;
17534 }
17535
17536 if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
17537 && (ffeexpr_stack_->next_dummy != NULL))
17538 { /* Too few arguments. */
17539 if (ffebad_start (FFEBAD_TOO_FEW_ARGUMENTS))
17540 {
17541 char num[10];
17542
17543 sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
17544
17545 ffebad_here (0, ffelex_token_where_line (t),
17546 ffelex_token_where_column (t));
17547 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17548 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17549 ffebad_string (num);
17550 ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent (ffebld_symter
17551 (ffebld_head (ffeexpr_stack_->next_dummy)))));
17552 ffebad_finish ();
17553 }
17554 for (;
17555 ffeexpr_stack_->next_dummy != NULL;
17556 ffeexpr_stack_->next_dummy
17557 = ffebld_trail (ffeexpr_stack_->next_dummy))
17558 {
17559 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0));
17560 ffebld_set_info (expr, ffeinfo_new_any ());
17561 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17562 }
17563 }
17564
17565 if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
17566 && (ffeexpr_stack_->tokens[1] != NULL))
17567 { /* Too many arguments to statement function. */
17568 if (ffebad_start (FFEBAD_TOO_MANY_ARGUMENTS))
17569 {
17570 char num[10];
17571
17572 sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
17573
17574 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
17575 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
17576 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17577 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17578 ffebad_string (num);
17579 ffebad_finish ();
17580 }
17581 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
17582 }
17583 ffebld_end_list (&ffeexpr_stack_->bottom);
17584
17585 if (ffebld_op (procedure->u.operand) == FFEBLD_opANY)
17586 {
17587 reduced = ffebld_new_any ();
17588 ffebld_set_info (reduced, ffeinfo_new_any ());
17589 }
17590 else
17591 {
17592 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
17593 reduced = ffebld_new_funcref (procedure->u.operand,
17594 ffeexpr_stack_->expr);
17595 else
17596 reduced = ffebld_new_subrref (procedure->u.operand,
17597 ffeexpr_stack_->expr);
17598 if (ffebld_symter_generic (procedure->u.operand) != FFEINTRIN_genNONE)
17599 ffeintrin_fulfill_generic (&reduced, &info, ffeexpr_stack_->tokens[0]);
17600 else if (ffebld_symter_specific (procedure->u.operand)
17601 != FFEINTRIN_specNONE)
17602 ffeintrin_fulfill_specific (&reduced, &info, &check_intrin,
17603 ffeexpr_stack_->tokens[0]);
17604 else
17605 ffeexpr_fulfill_call_ (&reduced, ffeexpr_stack_->tokens[0]);
17606
17607 if (ffebld_op (reduced) != FFEBLD_opANY)
17608 ffebld_set_info (reduced,
17609 ffeinfo_new (ffeinfo_basictype (info),
17610 ffeinfo_kindtype (info),
17611 0,
17612 FFEINFO_kindENTITY,
17613 FFEINFO_whereFLEETING,
17614 ffeinfo_size (info)));
17615 else
17616 ffebld_set_info (reduced, ffeinfo_new_any ());
17617 }
17618 if (ffebld_op (reduced) == FFEBLD_opFUNCREF)
17619 reduced = ffeexpr_collapse_funcref (reduced, ffeexpr_stack_->tokens[0]);
17620 ffeexpr_stack_->exprstack = procedure->previous; /* Pops
17621 not-quite-operand off
17622 stack. */
17623 procedure->u.operand = reduced; /* Save the line/column ffewhere
17624 info. */
17625 ffeexpr_exprstack_push_operand_ (procedure); /* Push it back on stack. */
17626 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
17627 {
17628 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
17629 ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FUNC(3)(1:1)".... */
17630
17631 /* If the intrinsic needs checking (is REAL(Z) or AIMAG(Z), where
17632 Z is DOUBLE COMPLEX), and a command-line option doesn't already
17633 establish interpretation, probably complain. */
17634
17635 if (check_intrin
17636 && !ffe_is_90 ()
17637 && !ffe_is_ugly_complex ())
17638 {
17639 /* If the outer expression is REAL(me...), issue diagnostic
17640 only if next token isn't the close-paren for REAL(me). */
17641
17642 if ((ffeexpr_stack_->previous != NULL)
17643 && (ffeexpr_stack_->previous->exprstack != NULL)
17644 && (ffeexpr_stack_->previous->exprstack->type == FFEEXPR_exprtypeOPERAND_)
17645 && ((reduced = ffeexpr_stack_->previous->exprstack->u.operand) != NULL)
17646 && (ffebld_op (reduced) == FFEBLD_opSYMTER)
17647 && (ffebld_symter_implementation (reduced) == FFEINTRIN_impREAL))
17648 return (ffelexHandler) ffeexpr_token_intrincheck_;
17649
17650 /* Diagnose the ambiguity now. */
17651
17652 if (ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
17653 {
17654 ffebad_string (ffeintrin_name_implementation
17655 (ffebld_symter_implementation
17656 (ffebld_left
17657 (ffeexpr_stack_->exprstack->u.operand))));
17658 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
17659 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
17660 ffebad_finish ();
17661 }
17662 }
17663 return (ffelexHandler) ffeexpr_token_substrp_;
17664 }
17665
17666 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
17667 {
17668 ffebad_here (0, ffelex_token_where_line (t),
17669 ffelex_token_where_column (t));
17670 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17671 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17672 ffebad_finish ();
17673 }
17674 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
17675 ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FUNC(3)(1:1)".... */
17676 return
17677 (ffelexHandler) ffeexpr_find_close_paren_ (t,
17678 (ffelexHandler)
17679 ffeexpr_token_substrp_);
17680 }
17681
17682 /* ffeexpr_token_elements_ -- OPEN_PAREN [expr COMMA]...expr
17683
17684 Return a pointer to this array to the lexer (ffelex), which will
17685 invoke it for the next token.
17686
17687 Handle expression and COMMA or CLOSE_PAREN. */
17688
17689 static ffelexHandler
17690 ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, ffelexToken t)
17691 {
17692 ffeexprExpr_ array;
17693 ffebld reduced;
17694 ffeinfo info;
17695 ffeinfoWhere where;
17696 ffetargetIntegerDefault val;
17697 ffetargetIntegerDefault lval = 0;
17698 ffetargetIntegerDefault uval = 0;
17699 ffebld lbound;
17700 ffebld ubound;
17701 bool lcheck;
17702 bool ucheck;
17703
17704 array = ffeexpr_stack_->exprstack;
17705 info = ffebld_info (array->u.operand);
17706
17707 if ((expr == NULL) /* && ((ffeexpr_stack_->rank != 0) ||
17708 (ffelex_token_type(t) ==
17709 FFELEX_typeCOMMA)) */ )
17710 {
17711 if (ffebad_start (FFEBAD_NULL_ELEMENT))
17712 {
17713 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17714 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17715 ffebad_here (1, ffelex_token_where_line (t),
17716 ffelex_token_where_column (t));
17717 ffebad_finish ();
17718 }
17719 if (ffeexpr_stack_->rank < ffeinfo_rank (info))
17720 { /* Don't bother if we're going to complain
17721 later! */
17722 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
17723 ffebld_set_info (expr, ffeinfo_new_any ());
17724 }
17725 }
17726
17727 if (expr == NULL)
17728 ;
17729 else if (ffeinfo_rank (info) == 0)
17730 { /* In EQUIVALENCE context, ffeinfo_rank(info)
17731 may == 0. */
17732 ++ffeexpr_stack_->rank; /* Track anyway, may need for new VXT
17733 feature. */
17734 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17735 }
17736 else
17737 {
17738 ++ffeexpr_stack_->rank;
17739 if (ffeexpr_stack_->rank > ffeinfo_rank (info))
17740 { /* Report later which was the first extra
17741 element. */
17742 if (ffeexpr_stack_->rank == ffeinfo_rank (info) + 1)
17743 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
17744 }
17745 else
17746 {
17747 switch (ffeinfo_where (ffebld_info (expr)))
17748 {
17749 case FFEINFO_whereCONSTANT:
17750 break;
17751
17752 case FFEINFO_whereIMMEDIATE:
17753 ffeexpr_stack_->constant = FALSE;
17754 break;
17755
17756 default:
17757 ffeexpr_stack_->constant = FALSE;
17758 ffeexpr_stack_->immediate = FALSE;
17759 break;
17760 }
17761 if (ffebld_op (expr) == FFEBLD_opCONTER
17762 && ffebld_kindtype (expr) == FFEINFO_kindtypeINTEGERDEFAULT)
17763 {
17764 val = ffebld_constant_integerdefault (ffebld_conter (expr));
17765
17766 lbound = ffebld_left (ffebld_head (ffeexpr_stack_->bound_list));
17767 if (lbound == NULL)
17768 {
17769 lcheck = TRUE;
17770 lval = 1;
17771 }
17772 else if (ffebld_op (lbound) == FFEBLD_opCONTER)
17773 {
17774 lcheck = TRUE;
17775 lval = ffebld_constant_integerdefault (ffebld_conter (lbound));
17776 }
17777 else
17778 lcheck = FALSE;
17779
17780 ubound = ffebld_right (ffebld_head (ffeexpr_stack_->bound_list));
17781 assert (ubound != NULL);
17782 if (ffebld_op (ubound) == FFEBLD_opCONTER)
17783 {
17784 ucheck = TRUE;
17785 uval = ffebld_constant_integerdefault (ffebld_conter (ubound));
17786 }
17787 else
17788 ucheck = FALSE;
17789
17790 if ((lcheck && (val < lval)) || (ucheck && (val > uval)))
17791 {
17792 ffebad_start (FFEBAD_RANGE_ARRAY);
17793 ffebad_here (0, ffelex_token_where_line (ft),
17794 ffelex_token_where_column (ft));
17795 ffebad_finish ();
17796 }
17797 }
17798 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17799 ffeexpr_stack_->bound_list = ffebld_trail (ffeexpr_stack_->bound_list);
17800 }
17801 }
17802
17803 switch (ffelex_token_type (t))
17804 {
17805 case FFELEX_typeCOMMA:
17806 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17807 {
17808 case FFEEXPR_contextDATAIMPDOITEM_:
17809 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
17810 FFEEXPR_contextDATAIMPDOINDEX_,
17811 ffeexpr_token_elements_);
17812
17813 case FFEEXPR_contextEQUIVALENCE:
17814 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
17815 FFEEXPR_contextEQVINDEX_,
17816 ffeexpr_token_elements_);
17817
17818 case FFEEXPR_contextSFUNCDEF:
17819 case FFEEXPR_contextSFUNCDEFINDEX_:
17820 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
17821 FFEEXPR_contextSFUNCDEFINDEX_,
17822 ffeexpr_token_elements_);
17823
17824 case FFEEXPR_contextSFUNCDEFACTUALARG_:
17825 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
17826 assert ("bad context" == NULL);
17827 break;
17828
17829 default:
17830 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
17831 FFEEXPR_contextINDEX_,
17832 ffeexpr_token_elements_);
17833 }
17834
17835 default:
17836 break;
17837 }
17838
17839 if ((ffeexpr_stack_->rank != ffeinfo_rank (info))
17840 && (ffeinfo_rank (info) != 0))
17841 {
17842 char num[10];
17843
17844 if (ffeexpr_stack_->rank < ffeinfo_rank (info))
17845 {
17846 if (ffebad_start (FFEBAD_TOO_FEW_ELEMENTS))
17847 {
17848 sprintf (num, "%d",
17849 (int) (ffeinfo_rank (info) - ffeexpr_stack_->rank));
17850
17851 ffebad_here (0, ffelex_token_where_line (t),
17852 ffelex_token_where_column (t));
17853 ffebad_here (1,
17854 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17855 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17856 ffebad_string (num);
17857 ffebad_finish ();
17858 }
17859 }
17860 else
17861 {
17862 if (ffebad_start (FFEBAD_TOO_MANY_ELEMENTS))
17863 {
17864 sprintf (num, "%d",
17865 (int) (ffeexpr_stack_->rank - ffeinfo_rank (info)));
17866
17867 ffebad_here (0,
17868 ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
17869 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
17870 ffebad_here (1,
17871 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17872 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17873 ffebad_string (num);
17874 ffebad_finish ();
17875 }
17876 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
17877 }
17878 while (ffeexpr_stack_->rank++ < ffeinfo_rank (info))
17879 {
17880 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
17881 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeINTEGER,
17882 FFEINFO_kindtypeINTEGERDEFAULT,
17883 0, FFEINFO_kindENTITY,
17884 FFEINFO_whereCONSTANT,
17885 FFETARGET_charactersizeNONE));
17886 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
17887 }
17888 }
17889 ffebld_end_list (&ffeexpr_stack_->bottom);
17890
17891 if (ffebld_op (array->u.operand) == FFEBLD_opANY)
17892 {
17893 reduced = ffebld_new_any ();
17894 ffebld_set_info (reduced, ffeinfo_new_any ());
17895 }
17896 else
17897 {
17898 reduced = ffebld_new_arrayref (array->u.operand, ffeexpr_stack_->expr);
17899 if (ffeexpr_stack_->constant)
17900 where = FFEINFO_whereFLEETING_CADDR;
17901 else if (ffeexpr_stack_->immediate)
17902 where = FFEINFO_whereFLEETING_IADDR;
17903 else
17904 where = FFEINFO_whereFLEETING;
17905 ffebld_set_info (reduced,
17906 ffeinfo_new (ffeinfo_basictype (info),
17907 ffeinfo_kindtype (info),
17908 0,
17909 FFEINFO_kindENTITY,
17910 where,
17911 ffeinfo_size (info)));
17912 reduced = ffeexpr_collapse_arrayref (reduced, ffeexpr_stack_->tokens[0]);
17913 }
17914
17915 ffeexpr_stack_->exprstack = array->previous; /* Pops not-quite-operand off
17916 stack. */
17917 array->u.operand = reduced; /* Save the line/column ffewhere info. */
17918 ffeexpr_exprstack_push_operand_ (array); /* Push it back on stack. */
17919
17920 switch (ffeinfo_basictype (info))
17921 {
17922 case FFEINFO_basictypeCHARACTER:
17923 ffeexpr_is_substr_ok_ = TRUE; /* Everyone likes "FOO(3)(1:1)".... */
17924 break;
17925
17926 case FFEINFO_basictypeNONE:
17927 ffeexpr_is_substr_ok_ = TRUE;
17928 assert (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE);
17929 break;
17930
17931 default:
17932 ffeexpr_is_substr_ok_ = FALSE;
17933 break;
17934 }
17935
17936 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
17937 {
17938 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
17939 return (ffelexHandler) ffeexpr_token_substrp_;
17940 }
17941
17942 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
17943 {
17944 ffebad_here (0, ffelex_token_where_line (t),
17945 ffelex_token_where_column (t));
17946 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
17947 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
17948 ffebad_finish ();
17949 }
17950 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
17951 return
17952 (ffelexHandler) ffeexpr_find_close_paren_ (t,
17953 (ffelexHandler)
17954 ffeexpr_token_substrp_);
17955 }
17956
17957 /* ffeexpr_token_equivalence_ -- OPEN_PAREN expr
17958
17959 Return a pointer to this array to the lexer (ffelex), which will
17960 invoke it for the next token.
17961
17962 If token is COLON, pass off to _substr_, else init list and pass off
17963 to _elements_. This handles the case "EQUIVALENCE (FOO(expr?", where
17964 ? marks the token, and where FOO's rank/type has not yet been established,
17965 meaning we could be in a list of indices or in a substring
17966 specification. */
17967
17968 static ffelexHandler
17969 ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr, ffelexToken t)
17970 {
17971 if (ffelex_token_type (t) == FFELEX_typeCOLON)
17972 return ffeexpr_token_substring_ (ft, expr, t);
17973
17974 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
17975 return ffeexpr_token_elements_ (ft, expr, t);
17976 }
17977
17978 /* ffeexpr_token_substring_ -- NAME(of kindENTITY) OPEN_PAREN expr
17979
17980 Return a pointer to this function to the lexer (ffelex), which will
17981 invoke it for the next token.
17982
17983 Handle expression (which may be null) and COLON. */
17984
17985 static ffelexHandler
17986 ffeexpr_token_substring_ (ffelexToken ft, ffebld expr, ffelexToken t)
17987 {
17988 ffeexprExpr_ string;
17989 ffeinfo info;
17990 ffetargetIntegerDefault i;
17991 ffeexprContext ctx;
17992 ffetargetCharacterSize size;
17993
17994 string = ffeexpr_stack_->exprstack;
17995 info = ffebld_info (string->u.operand);
17996 size = ffebld_size_max (string->u.operand);
17997
17998 if (ffelex_token_type (t) == FFELEX_typeCOLON)
17999 {
18000 if ((expr != NULL)
18001 && (ffebld_op (expr) == FFEBLD_opCONTER)
18002 && (((i = ffebld_constant_integerdefault (ffebld_conter (expr)))
18003 < 1)
18004 || ((size != FFETARGET_charactersizeNONE) && (i > size))))
18005 {
18006 ffebad_start (FFEBAD_RANGE_SUBSTR);
18007 ffebad_here (0, ffelex_token_where_line (ft),
18008 ffelex_token_where_column (ft));
18009 ffebad_finish ();
18010 }
18011 ffeexpr_stack_->expr = expr;
18012
18013 switch (ffeexpr_stack_->context)
18014 {
18015 case FFEEXPR_contextSFUNCDEF:
18016 case FFEEXPR_contextSFUNCDEFINDEX_:
18017 ctx = FFEEXPR_contextSFUNCDEFINDEX_;
18018 break;
18019
18020 case FFEEXPR_contextSFUNCDEFACTUALARG_:
18021 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18022 assert ("bad context" == NULL);
18023 ctx = FFEEXPR_context;
18024 break;
18025
18026 default:
18027 ctx = FFEEXPR_contextINDEX_;
18028 break;
18029 }
18030
18031 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18032 ffeexpr_token_substring_1_);
18033 }
18034
18035 if (ffest_ffebad_start (FFEBAD_MISSING_COLON_IN_SUBSTR))
18036 {
18037 ffebad_here (0, ffelex_token_where_line (t),
18038 ffelex_token_where_column (t));
18039 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18040 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18041 ffebad_finish ();
18042 }
18043
18044 ffeexpr_stack_->expr = NULL;
18045 return (ffelexHandler) ffeexpr_token_substring_1_ (ft, expr, t);
18046 }
18047
18048 /* ffeexpr_token_substring_1_ -- NAME OPEN_PAREN [expr COMMA]...expr
18049
18050 Return a pointer to this function to the lexer (ffelex), which will
18051 invoke it for the next token.
18052
18053 Handle expression (which might be null) and CLOSE_PAREN. */
18054
18055 static ffelexHandler
18056 ffeexpr_token_substring_1_ (ffelexToken ft, ffebld last, ffelexToken t)
18057 {
18058 ffeexprExpr_ string;
18059 ffebld reduced;
18060 ffebld substrlist;
18061 ffebld first = ffeexpr_stack_->expr;
18062 ffebld strop;
18063 ffeinfo info;
18064 ffeinfoWhere lwh;
18065 ffeinfoWhere rwh;
18066 ffeinfoWhere where;
18067 ffeinfoKindtype first_kt;
18068 ffeinfoKindtype last_kt;
18069 ffetargetIntegerDefault first_val;
18070 ffetargetIntegerDefault last_val;
18071 ffetargetCharacterSize size;
18072 ffetargetCharacterSize strop_size_max;
18073 bool first_known;
18074
18075 string = ffeexpr_stack_->exprstack;
18076 strop = string->u.operand;
18077 info = ffebld_info (strop);
18078
18079 if (first == NULL
18080 || (ffebld_op (first) == FFEBLD_opCONTER
18081 && ffebld_kindtype (first) == FFEINFO_kindtypeINTEGERDEFAULT))
18082 { /* The starting point is known. */
18083 first_val = (first == NULL) ? 1
18084 : ffebld_constant_integerdefault (ffebld_conter (first));
18085 first_known = TRUE;
18086 }
18087 else
18088 { /* Assume start of the entity. */
18089 first_val = 1;
18090 first_known = FALSE;
18091 }
18092
18093 if (last != NULL
18094 && (ffebld_op (last) == FFEBLD_opCONTER
18095 && ffebld_kindtype (last) == FFEINFO_kindtypeINTEGERDEFAULT))
18096 { /* The ending point is known. */
18097 last_val = ffebld_constant_integerdefault (ffebld_conter (last));
18098
18099 if (first_known)
18100 { /* The beginning point is a constant. */
18101 if (first_val <= last_val)
18102 size = last_val - first_val + 1;
18103 else
18104 {
18105 if (0 && ffe_is_90 ())
18106 size = 0;
18107 else
18108 {
18109 size = 1;
18110 ffebad_start (FFEBAD_ZERO_SIZE);
18111 ffebad_here (0, ffelex_token_where_line (ft),
18112 ffelex_token_where_column (ft));
18113 ffebad_finish ();
18114 }
18115 }
18116 }
18117 else
18118 size = FFETARGET_charactersizeNONE;
18119
18120 strop_size_max = ffebld_size_max (strop);
18121
18122 if ((strop_size_max != FFETARGET_charactersizeNONE)
18123 && (last_val > strop_size_max))
18124 { /* Beyond maximum possible end of string. */
18125 ffebad_start (FFEBAD_RANGE_SUBSTR);
18126 ffebad_here (0, ffelex_token_where_line (ft),
18127 ffelex_token_where_column (ft));
18128 ffebad_finish ();
18129 }
18130 }
18131 else
18132 size = FFETARGET_charactersizeNONE; /* The size is not known. */
18133
18134 #if 0 /* Don't do this, or "is size of target
18135 known?" would no longer be easily
18136 answerable. To see if there is a max
18137 size, use ffebld_size_max; to get only the
18138 known size, else NONE, use
18139 ffebld_size_known; use ffebld_size if
18140 values are sure to be the same (not
18141 opSUBSTR or opCONCATENATE or known to have
18142 known length). By getting rid of this
18143 "useful info" stuff, we don't end up
18144 blank-padding the constant in the
18145 assignment "A(I:J)='XYZ'" to the known
18146 length of A. */
18147 if (size == FFETARGET_charactersizeNONE)
18148 size = strop_size_max; /* Assume we use the entire string. */
18149 #endif
18150
18151 substrlist
18152 = ffebld_new_item
18153 (first,
18154 ffebld_new_item
18155 (last,
18156 NULL
18157 )
18158 )
18159 ;
18160
18161 if (first == NULL)
18162 lwh = FFEINFO_whereCONSTANT;
18163 else
18164 lwh = ffeinfo_where (ffebld_info (first));
18165 if (last == NULL)
18166 rwh = FFEINFO_whereCONSTANT;
18167 else
18168 rwh = ffeinfo_where (ffebld_info (last));
18169
18170 switch (lwh)
18171 {
18172 case FFEINFO_whereCONSTANT:
18173 switch (rwh)
18174 {
18175 case FFEINFO_whereCONSTANT:
18176 where = FFEINFO_whereCONSTANT;
18177 break;
18178
18179 case FFEINFO_whereIMMEDIATE:
18180 where = FFEINFO_whereIMMEDIATE;
18181 break;
18182
18183 default:
18184 where = FFEINFO_whereFLEETING;
18185 break;
18186 }
18187 break;
18188
18189 case FFEINFO_whereIMMEDIATE:
18190 switch (rwh)
18191 {
18192 case FFEINFO_whereCONSTANT:
18193 case FFEINFO_whereIMMEDIATE:
18194 where = FFEINFO_whereIMMEDIATE;
18195 break;
18196
18197 default:
18198 where = FFEINFO_whereFLEETING;
18199 break;
18200 }
18201 break;
18202
18203 default:
18204 where = FFEINFO_whereFLEETING;
18205 break;
18206 }
18207
18208 if (first == NULL)
18209 first_kt = FFEINFO_kindtypeINTEGERDEFAULT;
18210 else
18211 first_kt = ffeinfo_kindtype (ffebld_info (first));
18212 if (last == NULL)
18213 last_kt = FFEINFO_kindtypeINTEGERDEFAULT;
18214 else
18215 last_kt = ffeinfo_kindtype (ffebld_info (last));
18216
18217 switch (where)
18218 {
18219 case FFEINFO_whereCONSTANT:
18220 switch (ffeinfo_where (info))
18221 {
18222 case FFEINFO_whereCONSTANT:
18223 break;
18224
18225 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
18226 where = FFEINFO_whereIMMEDIATE;
18227 break;
18228
18229 default:
18230 where = FFEINFO_whereFLEETING_CADDR;
18231 break;
18232 }
18233 break;
18234
18235 case FFEINFO_whereIMMEDIATE:
18236 switch (ffeinfo_where (info))
18237 {
18238 case FFEINFO_whereCONSTANT:
18239 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
18240 break;
18241
18242 default:
18243 where = FFEINFO_whereFLEETING_IADDR;
18244 break;
18245 }
18246 break;
18247
18248 default:
18249 switch (ffeinfo_where (info))
18250 {
18251 case FFEINFO_whereCONSTANT:
18252 where = FFEINFO_whereCONSTANT_SUBOBJECT; /* An F90 concept. */
18253 break;
18254
18255 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
18256 default:
18257 where = FFEINFO_whereFLEETING;
18258 break;
18259 }
18260 break;
18261 }
18262
18263 if (ffebld_op (strop) == FFEBLD_opANY)
18264 {
18265 reduced = ffebld_new_any ();
18266 ffebld_set_info (reduced, ffeinfo_new_any ());
18267 }
18268 else
18269 {
18270 reduced = ffebld_new_substr (strop, substrlist);
18271 ffebld_set_info (reduced, ffeinfo_new
18272 (FFEINFO_basictypeCHARACTER,
18273 ffeinfo_kindtype (info),
18274 0,
18275 FFEINFO_kindENTITY,
18276 where,
18277 size));
18278 reduced = ffeexpr_collapse_substr (reduced, ffeexpr_stack_->tokens[0]);
18279 }
18280
18281 ffeexpr_stack_->exprstack = string->previous; /* Pops not-quite-operand off
18282 stack. */
18283 string->u.operand = reduced; /* Save the line/column ffewhere info. */
18284 ffeexpr_exprstack_push_operand_ (string); /* Push it back on stack. */
18285
18286 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18287 {
18288 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18289 ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FOO(3:5)(1:1)".... */
18290 return (ffelexHandler) ffeexpr_token_substrp_;
18291 }
18292
18293 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
18294 {
18295 ffebad_here (0, ffelex_token_where_line (t),
18296 ffelex_token_where_column (t));
18297 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18298 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18299 ffebad_finish ();
18300 }
18301
18302 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18303 ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FOO(3:5)(1:1)".... */
18304 return
18305 (ffelexHandler) ffeexpr_find_close_paren_ (t,
18306 (ffelexHandler)
18307 ffeexpr_token_substrp_);
18308 }
18309
18310 /* ffeexpr_token_substrp_ -- Rhs <character entity>
18311
18312 Return a pointer to this function to the lexer (ffelex), which will
18313 invoke it for the next token.
18314
18315 If OPEN_PAREN, treat as start of a substring ("(3:4)") construct, and
18316 issue error message if flag (serves as argument) is set. Else, just
18317 forward token to binary_. */
18318
18319 static ffelexHandler
18320 ffeexpr_token_substrp_ (ffelexToken t)
18321 {
18322 ffeexprContext ctx;
18323
18324 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
18325 return (ffelexHandler) ffeexpr_token_binary_ (t);
18326
18327 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
18328
18329 switch (ffeexpr_stack_->context)
18330 {
18331 case FFEEXPR_contextSFUNCDEF:
18332 case FFEEXPR_contextSFUNCDEFINDEX_:
18333 ctx = FFEEXPR_contextSFUNCDEFINDEX_;
18334 break;
18335
18336 case FFEEXPR_contextSFUNCDEFACTUALARG_:
18337 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18338 assert ("bad context" == NULL);
18339 ctx = FFEEXPR_context;
18340 break;
18341
18342 default:
18343 ctx = FFEEXPR_contextINDEX_;
18344 break;
18345 }
18346
18347 if (!ffeexpr_is_substr_ok_)
18348 {
18349 if (ffebad_start (FFEBAD_BAD_SUBSTR))
18350 {
18351 ffebad_here (0, ffelex_token_where_line (t),
18352 ffelex_token_where_column (t));
18353 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
18354 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
18355 ffebad_finish ();
18356 }
18357
18358 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18359 ffeexpr_token_anything_);
18360 }
18361
18362 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18363 ffeexpr_token_substring_);
18364 }
18365
18366 static ffelexHandler
18367 ffeexpr_token_intrincheck_ (ffelexToken t)
18368 {
18369 if ((ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
18370 && ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
18371 {
18372 ffebad_string (ffeintrin_name_implementation
18373 (ffebld_symter_implementation
18374 (ffebld_left
18375 (ffeexpr_stack_->exprstack->u.operand))));
18376 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
18377 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
18378 ffebad_finish ();
18379 }
18380
18381 return (ffelexHandler) ffeexpr_token_substrp_ (t);
18382 }
18383
18384 /* ffeexpr_token_funsubstr_ -- NAME OPEN_PAREN expr
18385
18386 Return a pointer to this function to the lexer (ffelex), which will
18387 invoke it for the next token.
18388
18389 If COLON, do everything we would have done since _parenthesized_ if
18390 we had known NAME represented a kindENTITY instead of a kindFUNCTION.
18391 If not COLON, do likewise for kindFUNCTION instead. */
18392
18393 static ffelexHandler
18394 ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr, ffelexToken t)
18395 {
18396 ffeinfoWhere where;
18397 ffesymbol s;
18398 ffesymbolAttrs sa;
18399 ffebld symter = ffeexpr_stack_->exprstack->u.operand;
18400 bool needs_type;
18401 ffeintrinGen gen;
18402 ffeintrinSpec spec;
18403 ffeintrinImp imp;
18404
18405 s = ffebld_symter (symter);
18406 sa = ffesymbol_attrs (s);
18407 where = ffesymbol_where (s);
18408
18409 /* We get here only if we don't already know enough about FOO when seeing a
18410 FOO(stuff) reference, and FOO might turn out to be a CHARACTER type. If
18411 "stuff" is a substring reference, then FOO is a CHARACTER scalar type.
18412 Else FOO is a function, either intrinsic or external. If intrinsic, it
18413 wouldn't necessarily be CHARACTER type, so unless it has already been
18414 declared DUMMY, it hasn't had its type established yet. It can't be
18415 CHAR*(*) in any case, though it can have an explicit CHAR*n type. */
18416
18417 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
18418 | FFESYMBOL_attrsTYPE)));
18419
18420 needs_type = !(ffesymbol_attrs (s) & FFESYMBOL_attrsDUMMY);
18421
18422 ffesymbol_signal_change (s); /* Probably already done, but in case.... */
18423
18424 if (ffelex_token_type (t) == FFELEX_typeCOLON)
18425 { /* Definitely an ENTITY (char substring). */
18426 if (needs_type && !ffeimplic_establish_symbol (s))
18427 {
18428 ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
18429 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
18430 }
18431
18432 ffesymbol_set_info (s,
18433 ffeinfo_new (ffesymbol_basictype (s),
18434 ffesymbol_kindtype (s),
18435 ffesymbol_rank (s),
18436 FFEINFO_kindENTITY,
18437 (where == FFEINFO_whereNONE)
18438 ? FFEINFO_whereLOCAL
18439 : where,
18440 ffesymbol_size (s)));
18441 ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
18442
18443 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18444 ffesymbol_resolve_intrin (s);
18445 s = ffecom_sym_learned (s);
18446 ffesymbol_signal_unreported (s); /* For debugging purposes. */
18447
18448 ffeexpr_stack_->exprstack->u.operand
18449 = ffeexpr_collapse_symter (symter, ffeexpr_tokens_[0]);
18450
18451 return (ffelexHandler) ffeexpr_token_substring_ (ft, expr, t);
18452 }
18453
18454 /* The "stuff" isn't a substring notation, so we now know the overall
18455 reference is to a function. */
18456
18457 if (ffeintrin_is_intrinsic (ffesymbol_text (s), ffeexpr_stack_->tokens[0],
18458 FALSE, &gen, &spec, &imp))
18459 {
18460 ffebld_symter_set_generic (symter, gen);
18461 ffebld_symter_set_specific (symter, spec);
18462 ffebld_symter_set_implementation (symter, imp);
18463 ffesymbol_set_generic (s, gen);
18464 ffesymbol_set_specific (s, spec);
18465 ffesymbol_set_implementation (s, imp);
18466 ffesymbol_set_info (s,
18467 ffeinfo_new (ffesymbol_basictype (s),
18468 ffesymbol_kindtype (s),
18469 0,
18470 FFEINFO_kindFUNCTION,
18471 FFEINFO_whereINTRINSIC,
18472 ffesymbol_size (s)));
18473 }
18474 else
18475 { /* Not intrinsic, now needs CHAR type. */
18476 if (!ffeimplic_establish_symbol (s))
18477 {
18478 ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
18479 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
18480 }
18481
18482 ffesymbol_set_info (s,
18483 ffeinfo_new (ffesymbol_basictype (s),
18484 ffesymbol_kindtype (s),
18485 ffesymbol_rank (s),
18486 FFEINFO_kindFUNCTION,
18487 (where == FFEINFO_whereNONE)
18488 ? FFEINFO_whereGLOBAL
18489 : where,
18490 ffesymbol_size (s)));
18491 }
18492
18493 ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
18494
18495 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18496 ffesymbol_resolve_intrin (s);
18497 s = ffecom_sym_learned (s);
18498 ffesymbol_reference (s, ffeexpr_stack_->tokens[0], FALSE);
18499 ffesymbol_signal_unreported (s); /* For debugging purposes. */
18500 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
18501 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
18502 }
18503
18504 /* ffeexpr_token_anything_ -- NAME OPEN_PAREN any-expr
18505
18506 Handle basically any expression, looking for CLOSE_PAREN. */
18507
18508 static ffelexHandler
18509 ffeexpr_token_anything_ (ffelexToken ft UNUSED, ffebld expr UNUSED,
18510 ffelexToken t)
18511 {
18512 ffeexprExpr_ e = ffeexpr_stack_->exprstack;
18513
18514 switch (ffelex_token_type (t))
18515 {
18516 case FFELEX_typeCOMMA:
18517 case FFELEX_typeCOLON:
18518 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18519 FFEEXPR_contextACTUALARG_,
18520 ffeexpr_token_anything_);
18521
18522 default:
18523 e->u.operand = ffebld_new_any ();
18524 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
18525 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18526 ffeexpr_is_substr_ok_ = FALSE;
18527 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18528 return (ffelexHandler) ffeexpr_token_substrp_;
18529 return (ffelexHandler) ffeexpr_token_substrp_ (t);
18530 }
18531 }
18532
18533 /* Terminate module. */
18534
18535 void
18536 ffeexpr_terminate_2 (void)
18537 {
18538 assert (ffeexpr_stack_ == NULL);
18539 assert (ffeexpr_level_ == 0);
18540 }
Mirror of the offical gcc git repository hosted at gcc.gnu.org