1 /* expr.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 1997, 1998, 2001 Free Software Foundation, Inc.
3 Contributed by James Craig Burley.
5 This file is part of GNU Fortran.
7 GNU Fortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 2, or (at your option)
12 GNU Fortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
17 You should have received a copy of the GNU General Public License
18 along with GNU Fortran; see the file COPYING. If not, write to
19 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
26 Handles syntactic and semantic analysis of Fortran expressions.
51 /* Externals defined here. */
54 /* Simple definitions and enumerations. */
58 FFEEXPR_exprtypeUNKNOWN_,
59 FFEEXPR_exprtypeOPERAND_,
60 FFEEXPR_exprtypeUNARY_,
61 FFEEXPR_exprtypeBINARY_,
67 FFEEXPR_operatorPOWER_,
68 FFEEXPR_operatorMULTIPLY_,
69 FFEEXPR_operatorDIVIDE_,
71 FFEEXPR_operatorSUBTRACT_,
72 FFEEXPR_operatorCONCATENATE_,
84 FFEEXPR_operatorNEQV_,
90 FFEEXPR_operatorprecedenceHIGHEST_ = 1,
91 FFEEXPR_operatorprecedencePOWER_ = 1,
92 FFEEXPR_operatorprecedenceMULTIPLY_ = 2,
93 FFEEXPR_operatorprecedenceDIVIDE_ = 2,
94 FFEEXPR_operatorprecedenceADD_ = 3,
95 FFEEXPR_operatorprecedenceSUBTRACT_ = 3,
96 FFEEXPR_operatorprecedenceLOWARITH_ = 3,
97 FFEEXPR_operatorprecedenceCONCATENATE_ = 3,
98 FFEEXPR_operatorprecedenceLT_ = 4,
99 FFEEXPR_operatorprecedenceLE_ = 4,
100 FFEEXPR_operatorprecedenceEQ_ = 4,
101 FFEEXPR_operatorprecedenceNE_ = 4,
102 FFEEXPR_operatorprecedenceGT_ = 4,
103 FFEEXPR_operatorprecedenceGE_ = 4,
104 FFEEXPR_operatorprecedenceNOT_ = 5,
105 FFEEXPR_operatorprecedenceAND_ = 6,
106 FFEEXPR_operatorprecedenceOR_ = 7,
107 FFEEXPR_operatorprecedenceXOR_ = 8,
108 FFEEXPR_operatorprecedenceEQV_ = 8,
109 FFEEXPR_operatorprecedenceNEQV_ = 8,
110 FFEEXPR_operatorprecedenceLOWEST_ = 8,
111 FFEEXPR_operatorprecedence_
112 } ffeexprOperatorPrecedence_;
114 #define FFEEXPR_operatorassociativityL2R_ TRUE
115 #define FFEEXPR_operatorassociativityR2L_ FALSE
116 #define FFEEXPR_operatorassociativityPOWER_ FFEEXPR_operatorassociativityR2L_
117 #define FFEEXPR_operatorassociativityMULTIPLY_ FFEEXPR_operatorassociativityL2R_
118 #define FFEEXPR_operatorassociativityDIVIDE_ FFEEXPR_operatorassociativityL2R_
119 #define FFEEXPR_operatorassociativityADD_ FFEEXPR_operatorassociativityL2R_
120 #define FFEEXPR_operatorassociativitySUBTRACT_ FFEEXPR_operatorassociativityL2R_
121 #define FFEEXPR_operatorassociativityCONCATENATE_ FFEEXPR_operatorassociativityL2R_
122 #define FFEEXPR_operatorassociativityLT_ FFEEXPR_operatorassociativityL2R_
123 #define FFEEXPR_operatorassociativityLE_ FFEEXPR_operatorassociativityL2R_
124 #define FFEEXPR_operatorassociativityEQ_ FFEEXPR_operatorassociativityL2R_
125 #define FFEEXPR_operatorassociativityNE_ FFEEXPR_operatorassociativityL2R_
126 #define FFEEXPR_operatorassociativityGT_ FFEEXPR_operatorassociativityL2R_
127 #define FFEEXPR_operatorassociativityGE_ FFEEXPR_operatorassociativityL2R_
128 #define FFEEXPR_operatorassociativityNOT_ FFEEXPR_operatorassociativityL2R_
129 #define FFEEXPR_operatorassociativityAND_ FFEEXPR_operatorassociativityL2R_
130 #define FFEEXPR_operatorassociativityOR_ FFEEXPR_operatorassociativityL2R_
131 #define FFEEXPR_operatorassociativityXOR_ FFEEXPR_operatorassociativityL2R_
132 #define FFEEXPR_operatorassociativityEQV_ FFEEXPR_operatorassociativityL2R_
133 #define FFEEXPR_operatorassociativityNEQV_ FFEEXPR_operatorassociativityL2R_
137 FFEEXPR_parentypeFUNCTION_,
138 FFEEXPR_parentypeSUBROUTINE_,
139 FFEEXPR_parentypeARRAY_,
140 FFEEXPR_parentypeSUBSTRING_,
141 FFEEXPR_parentypeFUNSUBSTR_,/* Ambig: check for colon after first expr. */
142 FFEEXPR_parentypeEQUIVALENCE_, /* Ambig: ARRAY_ or SUBSTRING_. */
143 FFEEXPR_parentypeANY_, /* Allow basically anything. */
149 FFEEXPR_percentNONE_,
153 FFEEXPR_percentDESCR_,
157 /* Internal typedefs. */
159 typedef struct _ffeexpr_expr_ *ffeexprExpr_;
160 typedef bool ffeexprOperatorAssociativity_;
161 typedef struct _ffeexpr_stack_ *ffeexprStack_;
163 /* Private include files. */
166 /* Internal structure definitions. */
168 struct _ffeexpr_expr_
170 ffeexprExpr_ previous;
172 ffeexprExprtype_ type;
178 ffeexprOperatorPrecedence_ prec;
179 ffeexprOperatorAssociativity_ as;
187 struct _ffeexpr_stack_
189 ffeexprStack_ previous;
191 ffeexprContext context;
192 ffeexprCallback callback;
193 ffelexToken first_token;
194 ffeexprExpr_ exprstack;
195 ffelexToken tokens[10]; /* Used in certain cases, like (unary)
197 ffebld expr; /* For first of
198 complex/implied-do/substring/array-elements
199 / actual-args expression. */
200 ffebld bound_list; /* For tracking dimension bounds list of
202 ffebldListBottom bottom; /* For building lists. */
203 ffeinfoRank rank; /* For elements in an array reference. */
204 bool constant; /* TRUE while elements seen so far are
206 bool immediate; /* TRUE while elements seen so far are
207 immediate/constants. */
208 ffebld next_dummy; /* Next SFUNC dummy arg in arg list. */
209 ffebldListLength num_args; /* Number of dummy args expected in arg list. */
210 bool is_rhs; /* TRUE if rhs context, FALSE otherwise. */
211 ffeexprPercent_ percent; /* Current %FOO keyword. */
214 struct _ffeexpr_find_
221 /* Static objects accessed by functions in this module. */
223 static ffeexprStack_ ffeexpr_stack_; /* Expression stack for semantic. */
224 static ffelexToken ffeexpr_tokens_[10]; /* Scratchpad tokens for syntactic. */
225 static ffestrOther ffeexpr_current_dotdot_; /* Current .FOO. keyword. */
226 static long ffeexpr_hollerith_count_; /* ffeexpr_token_number_ and caller. */
227 static int ffeexpr_level_; /* Level of DATA implied-DO construct. */
228 static bool ffeexpr_is_substr_ok_; /* If OPEN_PAREN as binary "op" ok. */
229 static struct _ffeexpr_find_ ffeexpr_find_;
231 /* Static functions (internal). */
233 static ffelexHandler ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr,
235 static ffelexHandler ffeexpr_cb_close_paren_ambig_ (ffelexToken ft,
238 static ffelexHandler ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t);
239 static ffelexHandler ffeexpr_cb_close_paren_c_ (ffelexToken ft,
240 ffebld expr, ffelexToken t);
241 static ffelexHandler ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr,
243 static ffelexHandler ffeexpr_cb_close_paren_ci_ (ffelexToken ft,
244 ffebld expr, ffelexToken t);
245 static ffelexHandler ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr,
247 static ffelexHandler ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr,
249 static ffelexHandler ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr,
251 static ffelexHandler ffeexpr_cb_comma_i_2_ (ffelexToken ft, ffebld expr,
253 static ffelexHandler ffeexpr_cb_comma_i_3_ (ffelexToken ft, ffebld expr,
255 static ffelexHandler ffeexpr_cb_comma_i_4_ (ffelexToken ft, ffebld expr,
257 static ffelexHandler ffeexpr_cb_comma_i_5_ (ffelexToken t);
258 static ffelexHandler ffeexpr_cb_end_loc_ (ffelexToken ft, ffebld expr,
260 static ffelexHandler ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr,
262 static ffelexHandler ffeexpr_cb_end_notloc_1_ (ffelexToken t);
263 static ffesymbol ffeexpr_check_impctrl_ (ffesymbol s);
264 static void ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
265 ffebld dovar, ffelexToken dovar_t);
266 static void ffeexpr_update_impdo_ (ffebld expr, ffebld dovar);
267 static void ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar);
268 static ffeexprContext ffeexpr_context_outer_ (ffeexprStack_ s);
269 static ffeexprExpr_ ffeexpr_expr_new_ (void);
270 static void ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t);
271 static bool ffeexpr_isdigits_ (const char *p);
272 static ffelexHandler ffeexpr_token_first_lhs_ (ffelexToken t);
273 static ffelexHandler ffeexpr_token_first_lhs_1_ (ffelexToken t);
274 static ffelexHandler ffeexpr_token_first_rhs_ (ffelexToken t);
275 static ffelexHandler ffeexpr_token_first_rhs_1_ (ffelexToken t);
276 static ffelexHandler ffeexpr_token_first_rhs_2_ (ffelexToken t);
277 static ffelexHandler ffeexpr_token_first_rhs_3_ (ffelexToken t);
278 static ffelexHandler ffeexpr_token_first_rhs_4_ (ffelexToken t);
279 static ffelexHandler ffeexpr_token_first_rhs_5_ (ffelexToken t);
280 static ffelexHandler ffeexpr_token_first_rhs_6_ (ffelexToken t);
281 static ffelexHandler ffeexpr_token_namelist_ (ffelexToken t);
282 static void ffeexpr_expr_kill_ (ffeexprExpr_ e);
283 static void ffeexpr_exprstack_push_ (ffeexprExpr_ e);
284 static void ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e);
285 static void ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e);
286 static void ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e);
287 static void ffeexpr_reduce_ (void);
288 static ffebld ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op,
290 static ffebld ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l,
291 ffeexprExpr_ op, ffeexprExpr_ r);
292 static ffebld ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l,
293 ffeexprExpr_ op, ffeexprExpr_ r);
294 static ffebld ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l,
295 ffeexprExpr_ op, ffeexprExpr_ r);
296 static ffebld ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op,
298 static ffebld ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l,
299 ffeexprExpr_ op, ffeexprExpr_ r);
300 static ffebld ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l,
301 ffeexprExpr_ op, ffeexprExpr_ r);
302 static ffebld ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l,
303 ffeexprExpr_ op, ffeexprExpr_ r);
304 static ffebld ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r);
305 static ffebld ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op,
307 static ffebld ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l,
308 ffeexprExpr_ op, ffeexprExpr_ r);
309 static ffebld ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l,
310 ffeexprExpr_ op, ffeexprExpr_ r);
311 static ffelexHandler ffeexpr_find_close_paren_ (ffelexToken t,
312 ffelexHandler after);
313 static ffelexHandler ffeexpr_nil_finished_ (ffelexToken t);
314 static ffelexHandler ffeexpr_nil_rhs_ (ffelexToken t);
315 static ffelexHandler ffeexpr_nil_period_ (ffelexToken t);
316 static ffelexHandler ffeexpr_nil_end_period_ (ffelexToken t);
317 static ffelexHandler ffeexpr_nil_swallow_period_ (ffelexToken t);
318 static ffelexHandler ffeexpr_nil_real_ (ffelexToken t);
319 static ffelexHandler ffeexpr_nil_real_exponent_ (ffelexToken t);
320 static ffelexHandler ffeexpr_nil_real_exp_sign_ (ffelexToken t);
321 static ffelexHandler ffeexpr_nil_number_ (ffelexToken t);
322 static ffelexHandler ffeexpr_nil_number_exponent_ (ffelexToken t);
323 static ffelexHandler ffeexpr_nil_number_exp_sign_ (ffelexToken t);
324 static ffelexHandler ffeexpr_nil_number_period_ (ffelexToken t);
325 static ffelexHandler ffeexpr_nil_number_per_exp_ (ffelexToken t);
326 static ffelexHandler ffeexpr_nil_number_real_ (ffelexToken t);
327 static ffelexHandler ffeexpr_nil_num_per_exp_sign_ (ffelexToken t);
328 static ffelexHandler ffeexpr_nil_number_real_exp_ (ffelexToken t);
329 static ffelexHandler ffeexpr_nil_num_real_exp_sn_ (ffelexToken t);
330 static ffelexHandler ffeexpr_nil_binary_ (ffelexToken t);
331 static ffelexHandler ffeexpr_nil_binary_period_ (ffelexToken t);
332 static ffelexHandler ffeexpr_nil_binary_end_per_ (ffelexToken t);
333 static ffelexHandler ffeexpr_nil_binary_sw_per_ (ffelexToken t);
334 static ffelexHandler ffeexpr_nil_quote_ (ffelexToken t);
335 static ffelexHandler ffeexpr_nil_apostrophe_ (ffelexToken t);
336 static ffelexHandler ffeexpr_nil_apos_char_ (ffelexToken t);
337 static ffelexHandler ffeexpr_nil_name_rhs_ (ffelexToken t);
338 static ffelexHandler ffeexpr_nil_name_apos_ (ffelexToken t);
339 static ffelexHandler ffeexpr_nil_name_apos_name_ (ffelexToken t);
340 static ffelexHandler ffeexpr_nil_percent_ (ffelexToken t);
341 static ffelexHandler ffeexpr_nil_percent_name_ (ffelexToken t);
342 static ffelexHandler ffeexpr_nil_substrp_ (ffelexToken t);
343 static ffelexHandler ffeexpr_finished_ (ffelexToken t);
344 static ffebld ffeexpr_finished_ambig_ (ffelexToken t, ffebld expr);
345 static ffelexHandler ffeexpr_token_lhs_ (ffelexToken t);
346 static ffelexHandler ffeexpr_token_rhs_ (ffelexToken t);
347 static ffelexHandler ffeexpr_token_binary_ (ffelexToken t);
348 static ffelexHandler ffeexpr_token_period_ (ffelexToken t);
349 static ffelexHandler ffeexpr_token_end_period_ (ffelexToken t);
350 static ffelexHandler ffeexpr_token_swallow_period_ (ffelexToken t);
351 static ffelexHandler ffeexpr_token_real_ (ffelexToken t);
352 static ffelexHandler ffeexpr_token_real_exponent_ (ffelexToken t);
353 static ffelexHandler ffeexpr_token_real_exp_sign_ (ffelexToken t);
354 static ffelexHandler ffeexpr_token_number_ (ffelexToken t);
355 static ffelexHandler ffeexpr_token_number_exponent_ (ffelexToken t);
356 static ffelexHandler ffeexpr_token_number_exp_sign_ (ffelexToken t);
357 static ffelexHandler ffeexpr_token_number_period_ (ffelexToken t);
358 static ffelexHandler ffeexpr_token_number_per_exp_ (ffelexToken t);
359 static ffelexHandler ffeexpr_token_number_real_ (ffelexToken t);
360 static ffelexHandler ffeexpr_token_num_per_exp_sign_ (ffelexToken t);
361 static ffelexHandler ffeexpr_token_number_real_exp_ (ffelexToken t);
362 static ffelexHandler ffeexpr_token_num_real_exp_sn_ (ffelexToken t);
363 static ffelexHandler ffeexpr_token_binary_period_ (ffelexToken t);
364 static ffelexHandler ffeexpr_token_binary_end_per_ (ffelexToken t);
365 static ffelexHandler ffeexpr_token_binary_sw_per_ (ffelexToken t);
366 static ffelexHandler ffeexpr_token_quote_ (ffelexToken t);
367 static ffelexHandler ffeexpr_token_apostrophe_ (ffelexToken t);
368 static ffelexHandler ffeexpr_token_apos_char_ (ffelexToken t);
369 static ffelexHandler ffeexpr_token_name_lhs_ (ffelexToken t);
370 static ffelexHandler ffeexpr_token_name_arg_ (ffelexToken t);
371 static ffelexHandler ffeexpr_token_name_rhs_ (ffelexToken t);
372 static ffelexHandler ffeexpr_token_name_apos_ (ffelexToken t);
373 static ffelexHandler ffeexpr_token_name_apos_name_ (ffelexToken t);
374 static ffelexHandler ffeexpr_token_percent_ (ffelexToken t);
375 static ffelexHandler ffeexpr_token_percent_name_ (ffelexToken t);
376 static ffelexHandler ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr,
378 static ffelexHandler ffeexpr_token_elements_ (ffelexToken ft, ffebld expr,
380 static ffelexHandler ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr,
382 static ffelexHandler ffeexpr_token_substring_ (ffelexToken ft, ffebld expr,
384 static ffelexHandler ffeexpr_token_substring_1_ (ffelexToken ft, ffebld expr,
386 static ffelexHandler ffeexpr_token_substrp_ (ffelexToken t);
387 static ffelexHandler ffeexpr_token_intrincheck_ (ffelexToken t);
388 static ffelexHandler ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr,
390 static ffelexHandler ffeexpr_token_anything_ (ffelexToken ft, ffebld expr,
392 static void ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
393 ffelexToken decimal, ffelexToken fraction, ffelexToken exponent,
394 ffelexToken exponent_sign, ffelexToken exponent_digits);
395 static ffesymbol ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin);
396 static ffesymbol ffeexpr_sym_impdoitem_ (ffesymbol s, ffelexToken t);
397 static ffesymbol ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t);
398 static ffesymbol ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t);
399 static ffesymbol ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t);
400 static ffesymbol ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t);
401 static ffesymbol ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t);
402 static ffesymbol ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t);
403 static ffesymbol ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t);
404 static ffesymbol ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t);
405 static ffesymbol ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t);
406 static ffesymbol ffeexpr_declare_parenthesized_ (ffelexToken t,
408 ffeexprParenType_ *paren_type);
409 static ffesymbol ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t);
411 /* Internal macros. */
413 #define ffeexpr_paren_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
414 #define ffeexpr_sym_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
416 /* ffeexpr_collapse_convert -- Collapse convert expr
420 expr = ffeexpr_collapse_convert(expr,token);
422 If the result of the expr is a constant, replaces the expr with the
423 computed constant. */
426 ffeexpr_collapse_convert (ffebld expr, ffelexToken t)
428 ffebad error = FFEBAD;
430 ffebldConstantUnion u;
433 ffetargetCharacterSize sz;
434 ffetargetCharacterSize sz2;
436 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
439 l = ffebld_left (expr);
441 if (ffebld_op (l) != FFEBLD_opCONTER)
444 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
446 case FFEINFO_basictypeANY:
449 case FFEINFO_basictypeINTEGER:
450 sz = FFETARGET_charactersizeNONE;
451 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
453 #if FFETARGET_okINTEGER1
454 case FFEINFO_kindtypeINTEGER1:
455 switch (ffeinfo_basictype (ffebld_info (l)))
457 case FFEINFO_basictypeINTEGER:
458 switch (ffeinfo_kindtype (ffebld_info (l)))
460 #if FFETARGET_okINTEGER2
461 case FFEINFO_kindtypeINTEGER2:
462 error = ffetarget_convert_integer1_integer2
463 (ffebld_cu_ptr_integer1 (u),
464 ffebld_constant_integer2 (ffebld_conter (l)));
468 #if FFETARGET_okINTEGER3
469 case FFEINFO_kindtypeINTEGER3:
470 error = ffetarget_convert_integer1_integer3
471 (ffebld_cu_ptr_integer1 (u),
472 ffebld_constant_integer3 (ffebld_conter (l)));
476 #if FFETARGET_okINTEGER4
477 case FFEINFO_kindtypeINTEGER4:
478 error = ffetarget_convert_integer1_integer4
479 (ffebld_cu_ptr_integer1 (u),
480 ffebld_constant_integer4 (ffebld_conter (l)));
485 assert ("INTEGER1/INTEGER bad source kind type" == NULL);
490 case FFEINFO_basictypeREAL:
491 switch (ffeinfo_kindtype (ffebld_info (l)))
493 #if FFETARGET_okREAL1
494 case FFEINFO_kindtypeREAL1:
495 error = ffetarget_convert_integer1_real1
496 (ffebld_cu_ptr_integer1 (u),
497 ffebld_constant_real1 (ffebld_conter (l)));
501 #if FFETARGET_okREAL2
502 case FFEINFO_kindtypeREAL2:
503 error = ffetarget_convert_integer1_real2
504 (ffebld_cu_ptr_integer1 (u),
505 ffebld_constant_real2 (ffebld_conter (l)));
509 #if FFETARGET_okREAL3
510 case FFEINFO_kindtypeREAL3:
511 error = ffetarget_convert_integer1_real3
512 (ffebld_cu_ptr_integer1 (u),
513 ffebld_constant_real3 (ffebld_conter (l)));
517 #if FFETARGET_okREAL4
518 case FFEINFO_kindtypeREAL4:
519 error = ffetarget_convert_integer1_real4
520 (ffebld_cu_ptr_integer1 (u),
521 ffebld_constant_real4 (ffebld_conter (l)));
526 assert ("INTEGER1/REAL bad source kind type" == NULL);
531 case FFEINFO_basictypeCOMPLEX:
532 switch (ffeinfo_kindtype (ffebld_info (l)))
534 #if FFETARGET_okCOMPLEX1
535 case FFEINFO_kindtypeREAL1:
536 error = ffetarget_convert_integer1_complex1
537 (ffebld_cu_ptr_integer1 (u),
538 ffebld_constant_complex1 (ffebld_conter (l)));
542 #if FFETARGET_okCOMPLEX2
543 case FFEINFO_kindtypeREAL2:
544 error = ffetarget_convert_integer1_complex2
545 (ffebld_cu_ptr_integer1 (u),
546 ffebld_constant_complex2 (ffebld_conter (l)));
550 #if FFETARGET_okCOMPLEX3
551 case FFEINFO_kindtypeREAL3:
552 error = ffetarget_convert_integer1_complex3
553 (ffebld_cu_ptr_integer1 (u),
554 ffebld_constant_complex3 (ffebld_conter (l)));
558 #if FFETARGET_okCOMPLEX4
559 case FFEINFO_kindtypeREAL4:
560 error = ffetarget_convert_integer1_complex4
561 (ffebld_cu_ptr_integer1 (u),
562 ffebld_constant_complex4 (ffebld_conter (l)));
567 assert ("INTEGER1/COMPLEX bad source kind type" == NULL);
572 case FFEINFO_basictypeLOGICAL:
573 switch (ffeinfo_kindtype (ffebld_info (l)))
575 #if FFETARGET_okLOGICAL1
576 case FFEINFO_kindtypeLOGICAL1:
577 error = ffetarget_convert_integer1_logical1
578 (ffebld_cu_ptr_integer1 (u),
579 ffebld_constant_logical1 (ffebld_conter (l)));
583 #if FFETARGET_okLOGICAL2
584 case FFEINFO_kindtypeLOGICAL2:
585 error = ffetarget_convert_integer1_logical2
586 (ffebld_cu_ptr_integer1 (u),
587 ffebld_constant_logical2 (ffebld_conter (l)));
591 #if FFETARGET_okLOGICAL3
592 case FFEINFO_kindtypeLOGICAL3:
593 error = ffetarget_convert_integer1_logical3
594 (ffebld_cu_ptr_integer1 (u),
595 ffebld_constant_logical3 (ffebld_conter (l)));
599 #if FFETARGET_okLOGICAL4
600 case FFEINFO_kindtypeLOGICAL4:
601 error = ffetarget_convert_integer1_logical4
602 (ffebld_cu_ptr_integer1 (u),
603 ffebld_constant_logical4 (ffebld_conter (l)));
608 assert ("INTEGER1/LOGICAL bad source kind type" == NULL);
613 case FFEINFO_basictypeCHARACTER:
614 error = ffetarget_convert_integer1_character1
615 (ffebld_cu_ptr_integer1 (u),
616 ffebld_constant_character1 (ffebld_conter (l)));
619 case FFEINFO_basictypeHOLLERITH:
620 error = ffetarget_convert_integer1_hollerith
621 (ffebld_cu_ptr_integer1 (u),
622 ffebld_constant_hollerith (ffebld_conter (l)));
625 case FFEINFO_basictypeTYPELESS:
626 error = ffetarget_convert_integer1_typeless
627 (ffebld_cu_ptr_integer1 (u),
628 ffebld_constant_typeless (ffebld_conter (l)));
632 assert ("INTEGER1 bad type" == NULL);
636 /* If conversion operation is not implemented, return original expr. */
637 if (error == FFEBAD_NOCANDO)
640 expr = ffebld_new_conter_with_orig
641 (ffebld_constant_new_integer1_val
642 (ffebld_cu_val_integer1 (u)), expr);
646 #if FFETARGET_okINTEGER2
647 case FFEINFO_kindtypeINTEGER2:
648 switch (ffeinfo_basictype (ffebld_info (l)))
650 case FFEINFO_basictypeINTEGER:
651 switch (ffeinfo_kindtype (ffebld_info (l)))
653 #if FFETARGET_okINTEGER1
654 case FFEINFO_kindtypeINTEGER1:
655 error = ffetarget_convert_integer2_integer1
656 (ffebld_cu_ptr_integer2 (u),
657 ffebld_constant_integer1 (ffebld_conter (l)));
661 #if FFETARGET_okINTEGER3
662 case FFEINFO_kindtypeINTEGER3:
663 error = ffetarget_convert_integer2_integer3
664 (ffebld_cu_ptr_integer2 (u),
665 ffebld_constant_integer3 (ffebld_conter (l)));
669 #if FFETARGET_okINTEGER4
670 case FFEINFO_kindtypeINTEGER4:
671 error = ffetarget_convert_integer2_integer4
672 (ffebld_cu_ptr_integer2 (u),
673 ffebld_constant_integer4 (ffebld_conter (l)));
678 assert ("INTEGER2/INTEGER bad source kind type" == NULL);
683 case FFEINFO_basictypeREAL:
684 switch (ffeinfo_kindtype (ffebld_info (l)))
686 #if FFETARGET_okREAL1
687 case FFEINFO_kindtypeREAL1:
688 error = ffetarget_convert_integer2_real1
689 (ffebld_cu_ptr_integer2 (u),
690 ffebld_constant_real1 (ffebld_conter (l)));
694 #if FFETARGET_okREAL2
695 case FFEINFO_kindtypeREAL2:
696 error = ffetarget_convert_integer2_real2
697 (ffebld_cu_ptr_integer2 (u),
698 ffebld_constant_real2 (ffebld_conter (l)));
702 #if FFETARGET_okREAL3
703 case FFEINFO_kindtypeREAL3:
704 error = ffetarget_convert_integer2_real3
705 (ffebld_cu_ptr_integer2 (u),
706 ffebld_constant_real3 (ffebld_conter (l)));
710 #if FFETARGET_okREAL4
711 case FFEINFO_kindtypeREAL4:
712 error = ffetarget_convert_integer2_real4
713 (ffebld_cu_ptr_integer2 (u),
714 ffebld_constant_real4 (ffebld_conter (l)));
719 assert ("INTEGER2/REAL bad source kind type" == NULL);
724 case FFEINFO_basictypeCOMPLEX:
725 switch (ffeinfo_kindtype (ffebld_info (l)))
727 #if FFETARGET_okCOMPLEX1
728 case FFEINFO_kindtypeREAL1:
729 error = ffetarget_convert_integer2_complex1
730 (ffebld_cu_ptr_integer2 (u),
731 ffebld_constant_complex1 (ffebld_conter (l)));
735 #if FFETARGET_okCOMPLEX2
736 case FFEINFO_kindtypeREAL2:
737 error = ffetarget_convert_integer2_complex2
738 (ffebld_cu_ptr_integer2 (u),
739 ffebld_constant_complex2 (ffebld_conter (l)));
743 #if FFETARGET_okCOMPLEX3
744 case FFEINFO_kindtypeREAL3:
745 error = ffetarget_convert_integer2_complex3
746 (ffebld_cu_ptr_integer2 (u),
747 ffebld_constant_complex3 (ffebld_conter (l)));
751 #if FFETARGET_okCOMPLEX4
752 case FFEINFO_kindtypeREAL4:
753 error = ffetarget_convert_integer2_complex4
754 (ffebld_cu_ptr_integer2 (u),
755 ffebld_constant_complex4 (ffebld_conter (l)));
760 assert ("INTEGER2/COMPLEX bad source kind type" == NULL);
765 case FFEINFO_basictypeLOGICAL:
766 switch (ffeinfo_kindtype (ffebld_info (l)))
768 #if FFETARGET_okLOGICAL1
769 case FFEINFO_kindtypeLOGICAL1:
770 error = ffetarget_convert_integer2_logical1
771 (ffebld_cu_ptr_integer2 (u),
772 ffebld_constant_logical1 (ffebld_conter (l)));
776 #if FFETARGET_okLOGICAL2
777 case FFEINFO_kindtypeLOGICAL2:
778 error = ffetarget_convert_integer2_logical2
779 (ffebld_cu_ptr_integer2 (u),
780 ffebld_constant_logical2 (ffebld_conter (l)));
784 #if FFETARGET_okLOGICAL3
785 case FFEINFO_kindtypeLOGICAL3:
786 error = ffetarget_convert_integer2_logical3
787 (ffebld_cu_ptr_integer2 (u),
788 ffebld_constant_logical3 (ffebld_conter (l)));
792 #if FFETARGET_okLOGICAL4
793 case FFEINFO_kindtypeLOGICAL4:
794 error = ffetarget_convert_integer2_logical4
795 (ffebld_cu_ptr_integer2 (u),
796 ffebld_constant_logical4 (ffebld_conter (l)));
801 assert ("INTEGER2/LOGICAL bad source kind type" == NULL);
806 case FFEINFO_basictypeCHARACTER:
807 error = ffetarget_convert_integer2_character1
808 (ffebld_cu_ptr_integer2 (u),
809 ffebld_constant_character1 (ffebld_conter (l)));
812 case FFEINFO_basictypeHOLLERITH:
813 error = ffetarget_convert_integer2_hollerith
814 (ffebld_cu_ptr_integer2 (u),
815 ffebld_constant_hollerith (ffebld_conter (l)));
818 case FFEINFO_basictypeTYPELESS:
819 error = ffetarget_convert_integer2_typeless
820 (ffebld_cu_ptr_integer2 (u),
821 ffebld_constant_typeless (ffebld_conter (l)));
825 assert ("INTEGER2 bad type" == NULL);
829 /* If conversion operation is not implemented, return original expr. */
830 if (error == FFEBAD_NOCANDO)
833 expr = ffebld_new_conter_with_orig
834 (ffebld_constant_new_integer2_val
835 (ffebld_cu_val_integer2 (u)), expr);
839 #if FFETARGET_okINTEGER3
840 case FFEINFO_kindtypeINTEGER3:
841 switch (ffeinfo_basictype (ffebld_info (l)))
843 case FFEINFO_basictypeINTEGER:
844 switch (ffeinfo_kindtype (ffebld_info (l)))
846 #if FFETARGET_okINTEGER1
847 case FFEINFO_kindtypeINTEGER1:
848 error = ffetarget_convert_integer3_integer1
849 (ffebld_cu_ptr_integer3 (u),
850 ffebld_constant_integer1 (ffebld_conter (l)));
854 #if FFETARGET_okINTEGER2
855 case FFEINFO_kindtypeINTEGER2:
856 error = ffetarget_convert_integer3_integer2
857 (ffebld_cu_ptr_integer3 (u),
858 ffebld_constant_integer2 (ffebld_conter (l)));
862 #if FFETARGET_okINTEGER4
863 case FFEINFO_kindtypeINTEGER4:
864 error = ffetarget_convert_integer3_integer4
865 (ffebld_cu_ptr_integer3 (u),
866 ffebld_constant_integer4 (ffebld_conter (l)));
871 assert ("INTEGER3/INTEGER bad source kind type" == NULL);
876 case FFEINFO_basictypeREAL:
877 switch (ffeinfo_kindtype (ffebld_info (l)))
879 #if FFETARGET_okREAL1
880 case FFEINFO_kindtypeREAL1:
881 error = ffetarget_convert_integer3_real1
882 (ffebld_cu_ptr_integer3 (u),
883 ffebld_constant_real1 (ffebld_conter (l)));
887 #if FFETARGET_okREAL2
888 case FFEINFO_kindtypeREAL2:
889 error = ffetarget_convert_integer3_real2
890 (ffebld_cu_ptr_integer3 (u),
891 ffebld_constant_real2 (ffebld_conter (l)));
895 #if FFETARGET_okREAL3
896 case FFEINFO_kindtypeREAL3:
897 error = ffetarget_convert_integer3_real3
898 (ffebld_cu_ptr_integer3 (u),
899 ffebld_constant_real3 (ffebld_conter (l)));
903 #if FFETARGET_okREAL4
904 case FFEINFO_kindtypeREAL4:
905 error = ffetarget_convert_integer3_real4
906 (ffebld_cu_ptr_integer3 (u),
907 ffebld_constant_real4 (ffebld_conter (l)));
912 assert ("INTEGER3/REAL bad source kind type" == NULL);
917 case FFEINFO_basictypeCOMPLEX:
918 switch (ffeinfo_kindtype (ffebld_info (l)))
920 #if FFETARGET_okCOMPLEX1
921 case FFEINFO_kindtypeREAL1:
922 error = ffetarget_convert_integer3_complex1
923 (ffebld_cu_ptr_integer3 (u),
924 ffebld_constant_complex1 (ffebld_conter (l)));
928 #if FFETARGET_okCOMPLEX2
929 case FFEINFO_kindtypeREAL2:
930 error = ffetarget_convert_integer3_complex2
931 (ffebld_cu_ptr_integer3 (u),
932 ffebld_constant_complex2 (ffebld_conter (l)));
936 #if FFETARGET_okCOMPLEX3
937 case FFEINFO_kindtypeREAL3:
938 error = ffetarget_convert_integer3_complex3
939 (ffebld_cu_ptr_integer3 (u),
940 ffebld_constant_complex3 (ffebld_conter (l)));
944 #if FFETARGET_okCOMPLEX4
945 case FFEINFO_kindtypeREAL4:
946 error = ffetarget_convert_integer3_complex4
947 (ffebld_cu_ptr_integer3 (u),
948 ffebld_constant_complex4 (ffebld_conter (l)));
953 assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
958 case FFEINFO_basictypeLOGICAL:
959 switch (ffeinfo_kindtype (ffebld_info (l)))
961 #if FFETARGET_okLOGICAL1
962 case FFEINFO_kindtypeLOGICAL1:
963 error = ffetarget_convert_integer3_logical1
964 (ffebld_cu_ptr_integer3 (u),
965 ffebld_constant_logical1 (ffebld_conter (l)));
969 #if FFETARGET_okLOGICAL2
970 case FFEINFO_kindtypeLOGICAL2:
971 error = ffetarget_convert_integer3_logical2
972 (ffebld_cu_ptr_integer3 (u),
973 ffebld_constant_logical2 (ffebld_conter (l)));
977 #if FFETARGET_okLOGICAL3
978 case FFEINFO_kindtypeLOGICAL3:
979 error = ffetarget_convert_integer3_logical3
980 (ffebld_cu_ptr_integer3 (u),
981 ffebld_constant_logical3 (ffebld_conter (l)));
985 #if FFETARGET_okLOGICAL4
986 case FFEINFO_kindtypeLOGICAL4:
987 error = ffetarget_convert_integer3_logical4
988 (ffebld_cu_ptr_integer3 (u),
989 ffebld_constant_logical4 (ffebld_conter (l)));
994 assert ("INTEGER3/LOGICAL bad source kind type" == NULL);
999 case FFEINFO_basictypeCHARACTER:
1000 error = ffetarget_convert_integer3_character1
1001 (ffebld_cu_ptr_integer3 (u),
1002 ffebld_constant_character1 (ffebld_conter (l)));
1005 case FFEINFO_basictypeHOLLERITH:
1006 error = ffetarget_convert_integer3_hollerith
1007 (ffebld_cu_ptr_integer3 (u),
1008 ffebld_constant_hollerith (ffebld_conter (l)));
1011 case FFEINFO_basictypeTYPELESS:
1012 error = ffetarget_convert_integer3_typeless
1013 (ffebld_cu_ptr_integer3 (u),
1014 ffebld_constant_typeless (ffebld_conter (l)));
1018 assert ("INTEGER3 bad type" == NULL);
1022 /* If conversion operation is not implemented, return original expr. */
1023 if (error == FFEBAD_NOCANDO)
1026 expr = ffebld_new_conter_with_orig
1027 (ffebld_constant_new_integer3_val
1028 (ffebld_cu_val_integer3 (u)), expr);
1032 #if FFETARGET_okINTEGER4
1033 case FFEINFO_kindtypeINTEGER4:
1034 switch (ffeinfo_basictype (ffebld_info (l)))
1036 case FFEINFO_basictypeINTEGER:
1037 switch (ffeinfo_kindtype (ffebld_info (l)))
1039 #if FFETARGET_okINTEGER1
1040 case FFEINFO_kindtypeINTEGER1:
1041 error = ffetarget_convert_integer4_integer1
1042 (ffebld_cu_ptr_integer4 (u),
1043 ffebld_constant_integer1 (ffebld_conter (l)));
1047 #if FFETARGET_okINTEGER2
1048 case FFEINFO_kindtypeINTEGER2:
1049 error = ffetarget_convert_integer4_integer2
1050 (ffebld_cu_ptr_integer4 (u),
1051 ffebld_constant_integer2 (ffebld_conter (l)));
1055 #if FFETARGET_okINTEGER3
1056 case FFEINFO_kindtypeINTEGER3:
1057 error = ffetarget_convert_integer4_integer3
1058 (ffebld_cu_ptr_integer4 (u),
1059 ffebld_constant_integer3 (ffebld_conter (l)));
1064 assert ("INTEGER4/INTEGER bad source kind type" == NULL);
1069 case FFEINFO_basictypeREAL:
1070 switch (ffeinfo_kindtype (ffebld_info (l)))
1072 #if FFETARGET_okREAL1
1073 case FFEINFO_kindtypeREAL1:
1074 error = ffetarget_convert_integer4_real1
1075 (ffebld_cu_ptr_integer4 (u),
1076 ffebld_constant_real1 (ffebld_conter (l)));
1080 #if FFETARGET_okREAL2
1081 case FFEINFO_kindtypeREAL2:
1082 error = ffetarget_convert_integer4_real2
1083 (ffebld_cu_ptr_integer4 (u),
1084 ffebld_constant_real2 (ffebld_conter (l)));
1088 #if FFETARGET_okREAL3
1089 case FFEINFO_kindtypeREAL3:
1090 error = ffetarget_convert_integer4_real3
1091 (ffebld_cu_ptr_integer4 (u),
1092 ffebld_constant_real3 (ffebld_conter (l)));
1096 #if FFETARGET_okREAL4
1097 case FFEINFO_kindtypeREAL4:
1098 error = ffetarget_convert_integer4_real4
1099 (ffebld_cu_ptr_integer4 (u),
1100 ffebld_constant_real4 (ffebld_conter (l)));
1105 assert ("INTEGER4/REAL bad source kind type" == NULL);
1110 case FFEINFO_basictypeCOMPLEX:
1111 switch (ffeinfo_kindtype (ffebld_info (l)))
1113 #if FFETARGET_okCOMPLEX1
1114 case FFEINFO_kindtypeREAL1:
1115 error = ffetarget_convert_integer4_complex1
1116 (ffebld_cu_ptr_integer4 (u),
1117 ffebld_constant_complex1 (ffebld_conter (l)));
1121 #if FFETARGET_okCOMPLEX2
1122 case FFEINFO_kindtypeREAL2:
1123 error = ffetarget_convert_integer4_complex2
1124 (ffebld_cu_ptr_integer4 (u),
1125 ffebld_constant_complex2 (ffebld_conter (l)));
1129 #if FFETARGET_okCOMPLEX3
1130 case FFEINFO_kindtypeREAL3:
1131 error = ffetarget_convert_integer4_complex3
1132 (ffebld_cu_ptr_integer4 (u),
1133 ffebld_constant_complex3 (ffebld_conter (l)));
1137 #if FFETARGET_okCOMPLEX4
1138 case FFEINFO_kindtypeREAL4:
1139 error = ffetarget_convert_integer4_complex4
1140 (ffebld_cu_ptr_integer4 (u),
1141 ffebld_constant_complex4 (ffebld_conter (l)));
1146 assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
1151 case FFEINFO_basictypeLOGICAL:
1152 switch (ffeinfo_kindtype (ffebld_info (l)))
1154 #if FFETARGET_okLOGICAL1
1155 case FFEINFO_kindtypeLOGICAL1:
1156 error = ffetarget_convert_integer4_logical1
1157 (ffebld_cu_ptr_integer4 (u),
1158 ffebld_constant_logical1 (ffebld_conter (l)));
1162 #if FFETARGET_okLOGICAL2
1163 case FFEINFO_kindtypeLOGICAL2:
1164 error = ffetarget_convert_integer4_logical2
1165 (ffebld_cu_ptr_integer4 (u),
1166 ffebld_constant_logical2 (ffebld_conter (l)));
1170 #if FFETARGET_okLOGICAL3
1171 case FFEINFO_kindtypeLOGICAL3:
1172 error = ffetarget_convert_integer4_logical3
1173 (ffebld_cu_ptr_integer4 (u),
1174 ffebld_constant_logical3 (ffebld_conter (l)));
1178 #if FFETARGET_okLOGICAL4
1179 case FFEINFO_kindtypeLOGICAL4:
1180 error = ffetarget_convert_integer4_logical4
1181 (ffebld_cu_ptr_integer4 (u),
1182 ffebld_constant_logical4 (ffebld_conter (l)));
1187 assert ("INTEGER4/LOGICAL bad source kind type" == NULL);
1192 case FFEINFO_basictypeCHARACTER:
1193 error = ffetarget_convert_integer4_character1
1194 (ffebld_cu_ptr_integer4 (u),
1195 ffebld_constant_character1 (ffebld_conter (l)));
1198 case FFEINFO_basictypeHOLLERITH:
1199 error = ffetarget_convert_integer4_hollerith
1200 (ffebld_cu_ptr_integer4 (u),
1201 ffebld_constant_hollerith (ffebld_conter (l)));
1204 case FFEINFO_basictypeTYPELESS:
1205 error = ffetarget_convert_integer4_typeless
1206 (ffebld_cu_ptr_integer4 (u),
1207 ffebld_constant_typeless (ffebld_conter (l)));
1211 assert ("INTEGER4 bad type" == NULL);
1215 /* If conversion operation is not implemented, return original expr. */
1216 if (error == FFEBAD_NOCANDO)
1219 expr = ffebld_new_conter_with_orig
1220 (ffebld_constant_new_integer4_val
1221 (ffebld_cu_val_integer4 (u)), expr);
1226 assert ("bad integer kind type" == NULL);
1231 case FFEINFO_basictypeLOGICAL:
1232 sz = FFETARGET_charactersizeNONE;
1233 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1235 #if FFETARGET_okLOGICAL1
1236 case FFEINFO_kindtypeLOGICAL1:
1237 switch (ffeinfo_basictype (ffebld_info (l)))
1239 case FFEINFO_basictypeLOGICAL:
1240 switch (ffeinfo_kindtype (ffebld_info (l)))
1242 #if FFETARGET_okLOGICAL2
1243 case FFEINFO_kindtypeLOGICAL2:
1244 error = ffetarget_convert_logical1_logical2
1245 (ffebld_cu_ptr_logical1 (u),
1246 ffebld_constant_logical2 (ffebld_conter (l)));
1250 #if FFETARGET_okLOGICAL3
1251 case FFEINFO_kindtypeLOGICAL3:
1252 error = ffetarget_convert_logical1_logical3
1253 (ffebld_cu_ptr_logical1 (u),
1254 ffebld_constant_logical3 (ffebld_conter (l)));
1258 #if FFETARGET_okLOGICAL4
1259 case FFEINFO_kindtypeLOGICAL4:
1260 error = ffetarget_convert_logical1_logical4
1261 (ffebld_cu_ptr_logical1 (u),
1262 ffebld_constant_logical4 (ffebld_conter (l)));
1267 assert ("LOGICAL1/LOGICAL bad source kind type" == NULL);
1272 case FFEINFO_basictypeINTEGER:
1273 switch (ffeinfo_kindtype (ffebld_info (l)))
1275 #if FFETARGET_okINTEGER1
1276 case FFEINFO_kindtypeINTEGER1:
1277 error = ffetarget_convert_logical1_integer1
1278 (ffebld_cu_ptr_logical1 (u),
1279 ffebld_constant_integer1 (ffebld_conter (l)));
1283 #if FFETARGET_okINTEGER2
1284 case FFEINFO_kindtypeINTEGER2:
1285 error = ffetarget_convert_logical1_integer2
1286 (ffebld_cu_ptr_logical1 (u),
1287 ffebld_constant_integer2 (ffebld_conter (l)));
1291 #if FFETARGET_okINTEGER3
1292 case FFEINFO_kindtypeINTEGER3:
1293 error = ffetarget_convert_logical1_integer3
1294 (ffebld_cu_ptr_logical1 (u),
1295 ffebld_constant_integer3 (ffebld_conter (l)));
1299 #if FFETARGET_okINTEGER4
1300 case FFEINFO_kindtypeINTEGER4:
1301 error = ffetarget_convert_logical1_integer4
1302 (ffebld_cu_ptr_logical1 (u),
1303 ffebld_constant_integer4 (ffebld_conter (l)));
1308 assert ("LOGICAL1/INTEGER bad source kind type" == NULL);
1313 case FFEINFO_basictypeCHARACTER:
1314 error = ffetarget_convert_logical1_character1
1315 (ffebld_cu_ptr_logical1 (u),
1316 ffebld_constant_character1 (ffebld_conter (l)));
1319 case FFEINFO_basictypeHOLLERITH:
1320 error = ffetarget_convert_logical1_hollerith
1321 (ffebld_cu_ptr_logical1 (u),
1322 ffebld_constant_hollerith (ffebld_conter (l)));
1325 case FFEINFO_basictypeTYPELESS:
1326 error = ffetarget_convert_logical1_typeless
1327 (ffebld_cu_ptr_logical1 (u),
1328 ffebld_constant_typeless (ffebld_conter (l)));
1332 assert ("LOGICAL1 bad type" == NULL);
1336 /* If conversion operation is not implemented, return original expr. */
1337 if (error == FFEBAD_NOCANDO)
1340 expr = ffebld_new_conter_with_orig
1341 (ffebld_constant_new_logical1_val
1342 (ffebld_cu_val_logical1 (u)), expr);
1346 #if FFETARGET_okLOGICAL2
1347 case FFEINFO_kindtypeLOGICAL2:
1348 switch (ffeinfo_basictype (ffebld_info (l)))
1350 case FFEINFO_basictypeLOGICAL:
1351 switch (ffeinfo_kindtype (ffebld_info (l)))
1353 #if FFETARGET_okLOGICAL1
1354 case FFEINFO_kindtypeLOGICAL1:
1355 error = ffetarget_convert_logical2_logical1
1356 (ffebld_cu_ptr_logical2 (u),
1357 ffebld_constant_logical1 (ffebld_conter (l)));
1361 #if FFETARGET_okLOGICAL3
1362 case FFEINFO_kindtypeLOGICAL3:
1363 error = ffetarget_convert_logical2_logical3
1364 (ffebld_cu_ptr_logical2 (u),
1365 ffebld_constant_logical3 (ffebld_conter (l)));
1369 #if FFETARGET_okLOGICAL4
1370 case FFEINFO_kindtypeLOGICAL4:
1371 error = ffetarget_convert_logical2_logical4
1372 (ffebld_cu_ptr_logical2 (u),
1373 ffebld_constant_logical4 (ffebld_conter (l)));
1378 assert ("LOGICAL2/LOGICAL bad source kind type" == NULL);
1383 case FFEINFO_basictypeINTEGER:
1384 switch (ffeinfo_kindtype (ffebld_info (l)))
1386 #if FFETARGET_okINTEGER1
1387 case FFEINFO_kindtypeINTEGER1:
1388 error = ffetarget_convert_logical2_integer1
1389 (ffebld_cu_ptr_logical2 (u),
1390 ffebld_constant_integer1 (ffebld_conter (l)));
1394 #if FFETARGET_okINTEGER2
1395 case FFEINFO_kindtypeINTEGER2:
1396 error = ffetarget_convert_logical2_integer2
1397 (ffebld_cu_ptr_logical2 (u),
1398 ffebld_constant_integer2 (ffebld_conter (l)));
1402 #if FFETARGET_okINTEGER3
1403 case FFEINFO_kindtypeINTEGER3:
1404 error = ffetarget_convert_logical2_integer3
1405 (ffebld_cu_ptr_logical2 (u),
1406 ffebld_constant_integer3 (ffebld_conter (l)));
1410 #if FFETARGET_okINTEGER4
1411 case FFEINFO_kindtypeINTEGER4:
1412 error = ffetarget_convert_logical2_integer4
1413 (ffebld_cu_ptr_logical2 (u),
1414 ffebld_constant_integer4 (ffebld_conter (l)));
1419 assert ("LOGICAL2/INTEGER bad source kind type" == NULL);
1424 case FFEINFO_basictypeCHARACTER:
1425 error = ffetarget_convert_logical2_character1
1426 (ffebld_cu_ptr_logical2 (u),
1427 ffebld_constant_character1 (ffebld_conter (l)));
1430 case FFEINFO_basictypeHOLLERITH:
1431 error = ffetarget_convert_logical2_hollerith
1432 (ffebld_cu_ptr_logical2 (u),
1433 ffebld_constant_hollerith (ffebld_conter (l)));
1436 case FFEINFO_basictypeTYPELESS:
1437 error = ffetarget_convert_logical2_typeless
1438 (ffebld_cu_ptr_logical2 (u),
1439 ffebld_constant_typeless (ffebld_conter (l)));
1443 assert ("LOGICAL2 bad type" == NULL);
1447 /* If conversion operation is not implemented, return original expr. */
1448 if (error == FFEBAD_NOCANDO)
1451 expr = ffebld_new_conter_with_orig
1452 (ffebld_constant_new_logical2_val
1453 (ffebld_cu_val_logical2 (u)), expr);
1457 #if FFETARGET_okLOGICAL3
1458 case FFEINFO_kindtypeLOGICAL3:
1459 switch (ffeinfo_basictype (ffebld_info (l)))
1461 case FFEINFO_basictypeLOGICAL:
1462 switch (ffeinfo_kindtype (ffebld_info (l)))
1464 #if FFETARGET_okLOGICAL1
1465 case FFEINFO_kindtypeLOGICAL1:
1466 error = ffetarget_convert_logical3_logical1
1467 (ffebld_cu_ptr_logical3 (u),
1468 ffebld_constant_logical1 (ffebld_conter (l)));
1472 #if FFETARGET_okLOGICAL2
1473 case FFEINFO_kindtypeLOGICAL2:
1474 error = ffetarget_convert_logical3_logical2
1475 (ffebld_cu_ptr_logical3 (u),
1476 ffebld_constant_logical2 (ffebld_conter (l)));
1480 #if FFETARGET_okLOGICAL4
1481 case FFEINFO_kindtypeLOGICAL4:
1482 error = ffetarget_convert_logical3_logical4
1483 (ffebld_cu_ptr_logical3 (u),
1484 ffebld_constant_logical4 (ffebld_conter (l)));
1489 assert ("LOGICAL3/LOGICAL bad source kind type" == NULL);
1494 case FFEINFO_basictypeINTEGER:
1495 switch (ffeinfo_kindtype (ffebld_info (l)))
1497 #if FFETARGET_okINTEGER1
1498 case FFEINFO_kindtypeINTEGER1:
1499 error = ffetarget_convert_logical3_integer1
1500 (ffebld_cu_ptr_logical3 (u),
1501 ffebld_constant_integer1 (ffebld_conter (l)));
1505 #if FFETARGET_okINTEGER2
1506 case FFEINFO_kindtypeINTEGER2:
1507 error = ffetarget_convert_logical3_integer2
1508 (ffebld_cu_ptr_logical3 (u),
1509 ffebld_constant_integer2 (ffebld_conter (l)));
1513 #if FFETARGET_okINTEGER3
1514 case FFEINFO_kindtypeINTEGER3:
1515 error = ffetarget_convert_logical3_integer3
1516 (ffebld_cu_ptr_logical3 (u),
1517 ffebld_constant_integer3 (ffebld_conter (l)));
1521 #if FFETARGET_okINTEGER4
1522 case FFEINFO_kindtypeINTEGER4:
1523 error = ffetarget_convert_logical3_integer4
1524 (ffebld_cu_ptr_logical3 (u),
1525 ffebld_constant_integer4 (ffebld_conter (l)));
1530 assert ("LOGICAL3/INTEGER bad source kind type" == NULL);
1535 case FFEINFO_basictypeCHARACTER:
1536 error = ffetarget_convert_logical3_character1
1537 (ffebld_cu_ptr_logical3 (u),
1538 ffebld_constant_character1 (ffebld_conter (l)));
1541 case FFEINFO_basictypeHOLLERITH:
1542 error = ffetarget_convert_logical3_hollerith
1543 (ffebld_cu_ptr_logical3 (u),
1544 ffebld_constant_hollerith (ffebld_conter (l)));
1547 case FFEINFO_basictypeTYPELESS:
1548 error = ffetarget_convert_logical3_typeless
1549 (ffebld_cu_ptr_logical3 (u),
1550 ffebld_constant_typeless (ffebld_conter (l)));
1554 assert ("LOGICAL3 bad type" == NULL);
1558 /* If conversion operation is not implemented, return original expr. */
1559 if (error == FFEBAD_NOCANDO)
1562 expr = ffebld_new_conter_with_orig
1563 (ffebld_constant_new_logical3_val
1564 (ffebld_cu_val_logical3 (u)), expr);
1568 #if FFETARGET_okLOGICAL4
1569 case FFEINFO_kindtypeLOGICAL4:
1570 switch (ffeinfo_basictype (ffebld_info (l)))
1572 case FFEINFO_basictypeLOGICAL:
1573 switch (ffeinfo_kindtype (ffebld_info (l)))
1575 #if FFETARGET_okLOGICAL1
1576 case FFEINFO_kindtypeLOGICAL1:
1577 error = ffetarget_convert_logical4_logical1
1578 (ffebld_cu_ptr_logical4 (u),
1579 ffebld_constant_logical1 (ffebld_conter (l)));
1583 #if FFETARGET_okLOGICAL2
1584 case FFEINFO_kindtypeLOGICAL2:
1585 error = ffetarget_convert_logical4_logical2
1586 (ffebld_cu_ptr_logical4 (u),
1587 ffebld_constant_logical2 (ffebld_conter (l)));
1591 #if FFETARGET_okLOGICAL3
1592 case FFEINFO_kindtypeLOGICAL3:
1593 error = ffetarget_convert_logical4_logical3
1594 (ffebld_cu_ptr_logical4 (u),
1595 ffebld_constant_logical3 (ffebld_conter (l)));
1600 assert ("LOGICAL4/LOGICAL bad source kind type" == NULL);
1605 case FFEINFO_basictypeINTEGER:
1606 switch (ffeinfo_kindtype (ffebld_info (l)))
1608 #if FFETARGET_okINTEGER1
1609 case FFEINFO_kindtypeINTEGER1:
1610 error = ffetarget_convert_logical4_integer1
1611 (ffebld_cu_ptr_logical4 (u),
1612 ffebld_constant_integer1 (ffebld_conter (l)));
1616 #if FFETARGET_okINTEGER2
1617 case FFEINFO_kindtypeINTEGER2:
1618 error = ffetarget_convert_logical4_integer2
1619 (ffebld_cu_ptr_logical4 (u),
1620 ffebld_constant_integer2 (ffebld_conter (l)));
1624 #if FFETARGET_okINTEGER3
1625 case FFEINFO_kindtypeINTEGER3:
1626 error = ffetarget_convert_logical4_integer3
1627 (ffebld_cu_ptr_logical4 (u),
1628 ffebld_constant_integer3 (ffebld_conter (l)));
1632 #if FFETARGET_okINTEGER4
1633 case FFEINFO_kindtypeINTEGER4:
1634 error = ffetarget_convert_logical4_integer4
1635 (ffebld_cu_ptr_logical4 (u),
1636 ffebld_constant_integer4 (ffebld_conter (l)));
1641 assert ("LOGICAL4/INTEGER bad source kind type" == NULL);
1646 case FFEINFO_basictypeCHARACTER:
1647 error = ffetarget_convert_logical4_character1
1648 (ffebld_cu_ptr_logical4 (u),
1649 ffebld_constant_character1 (ffebld_conter (l)));
1652 case FFEINFO_basictypeHOLLERITH:
1653 error = ffetarget_convert_logical4_hollerith
1654 (ffebld_cu_ptr_logical4 (u),
1655 ffebld_constant_hollerith (ffebld_conter (l)));
1658 case FFEINFO_basictypeTYPELESS:
1659 error = ffetarget_convert_logical4_typeless
1660 (ffebld_cu_ptr_logical4 (u),
1661 ffebld_constant_typeless (ffebld_conter (l)));
1665 assert ("LOGICAL4 bad type" == NULL);
1669 /* If conversion operation is not implemented, return original expr. */
1670 if (error == FFEBAD_NOCANDO)
1673 expr = ffebld_new_conter_with_orig
1674 (ffebld_constant_new_logical4_val
1675 (ffebld_cu_val_logical4 (u)), expr);
1680 assert ("bad logical kind type" == NULL);
1685 case FFEINFO_basictypeREAL:
1686 sz = FFETARGET_charactersizeNONE;
1687 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1689 #if FFETARGET_okREAL1
1690 case FFEINFO_kindtypeREAL1:
1691 switch (ffeinfo_basictype (ffebld_info (l)))
1693 case FFEINFO_basictypeINTEGER:
1694 switch (ffeinfo_kindtype (ffebld_info (l)))
1696 #if FFETARGET_okINTEGER1
1697 case FFEINFO_kindtypeINTEGER1:
1698 error = ffetarget_convert_real1_integer1
1699 (ffebld_cu_ptr_real1 (u),
1700 ffebld_constant_integer1 (ffebld_conter (l)));
1704 #if FFETARGET_okINTEGER2
1705 case FFEINFO_kindtypeINTEGER2:
1706 error = ffetarget_convert_real1_integer2
1707 (ffebld_cu_ptr_real1 (u),
1708 ffebld_constant_integer2 (ffebld_conter (l)));
1712 #if FFETARGET_okINTEGER3
1713 case FFEINFO_kindtypeINTEGER3:
1714 error = ffetarget_convert_real1_integer3
1715 (ffebld_cu_ptr_real1 (u),
1716 ffebld_constant_integer3 (ffebld_conter (l)));
1720 #if FFETARGET_okINTEGER4
1721 case FFEINFO_kindtypeINTEGER4:
1722 error = ffetarget_convert_real1_integer4
1723 (ffebld_cu_ptr_real1 (u),
1724 ffebld_constant_integer4 (ffebld_conter (l)));
1729 assert ("REAL1/INTEGER bad source kind type" == NULL);
1734 case FFEINFO_basictypeREAL:
1735 switch (ffeinfo_kindtype (ffebld_info (l)))
1737 #if FFETARGET_okREAL2
1738 case FFEINFO_kindtypeREAL2:
1739 error = ffetarget_convert_real1_real2
1740 (ffebld_cu_ptr_real1 (u),
1741 ffebld_constant_real2 (ffebld_conter (l)));
1745 #if FFETARGET_okREAL3
1746 case FFEINFO_kindtypeREAL3:
1747 error = ffetarget_convert_real1_real3
1748 (ffebld_cu_ptr_real1 (u),
1749 ffebld_constant_real3 (ffebld_conter (l)));
1753 #if FFETARGET_okREAL4
1754 case FFEINFO_kindtypeREAL4:
1755 error = ffetarget_convert_real1_real4
1756 (ffebld_cu_ptr_real1 (u),
1757 ffebld_constant_real4 (ffebld_conter (l)));
1762 assert ("REAL1/REAL bad source kind type" == NULL);
1767 case FFEINFO_basictypeCOMPLEX:
1768 switch (ffeinfo_kindtype (ffebld_info (l)))
1770 #if FFETARGET_okCOMPLEX1
1771 case FFEINFO_kindtypeREAL1:
1772 error = ffetarget_convert_real1_complex1
1773 (ffebld_cu_ptr_real1 (u),
1774 ffebld_constant_complex1 (ffebld_conter (l)));
1778 #if FFETARGET_okCOMPLEX2
1779 case FFEINFO_kindtypeREAL2:
1780 error = ffetarget_convert_real1_complex2
1781 (ffebld_cu_ptr_real1 (u),
1782 ffebld_constant_complex2 (ffebld_conter (l)));
1786 #if FFETARGET_okCOMPLEX3
1787 case FFEINFO_kindtypeREAL3:
1788 error = ffetarget_convert_real1_complex3
1789 (ffebld_cu_ptr_real1 (u),
1790 ffebld_constant_complex3 (ffebld_conter (l)));
1794 #if FFETARGET_okCOMPLEX4
1795 case FFEINFO_kindtypeREAL4:
1796 error = ffetarget_convert_real1_complex4
1797 (ffebld_cu_ptr_real1 (u),
1798 ffebld_constant_complex4 (ffebld_conter (l)));
1803 assert ("REAL1/COMPLEX bad source kind type" == NULL);
1808 case FFEINFO_basictypeCHARACTER:
1809 error = ffetarget_convert_real1_character1
1810 (ffebld_cu_ptr_real1 (u),
1811 ffebld_constant_character1 (ffebld_conter (l)));
1814 case FFEINFO_basictypeHOLLERITH:
1815 error = ffetarget_convert_real1_hollerith
1816 (ffebld_cu_ptr_real1 (u),
1817 ffebld_constant_hollerith (ffebld_conter (l)));
1820 case FFEINFO_basictypeTYPELESS:
1821 error = ffetarget_convert_real1_typeless
1822 (ffebld_cu_ptr_real1 (u),
1823 ffebld_constant_typeless (ffebld_conter (l)));
1827 assert ("REAL1 bad type" == NULL);
1831 /* If conversion operation is not implemented, return original expr. */
1832 if (error == FFEBAD_NOCANDO)
1835 expr = ffebld_new_conter_with_orig
1836 (ffebld_constant_new_real1_val
1837 (ffebld_cu_val_real1 (u)), expr);
1841 #if FFETARGET_okREAL2
1842 case FFEINFO_kindtypeREAL2:
1843 switch (ffeinfo_basictype (ffebld_info (l)))
1845 case FFEINFO_basictypeINTEGER:
1846 switch (ffeinfo_kindtype (ffebld_info (l)))
1848 #if FFETARGET_okINTEGER1
1849 case FFEINFO_kindtypeINTEGER1:
1850 error = ffetarget_convert_real2_integer1
1851 (ffebld_cu_ptr_real2 (u),
1852 ffebld_constant_integer1 (ffebld_conter (l)));
1856 #if FFETARGET_okINTEGER2
1857 case FFEINFO_kindtypeINTEGER2:
1858 error = ffetarget_convert_real2_integer2
1859 (ffebld_cu_ptr_real2 (u),
1860 ffebld_constant_integer2 (ffebld_conter (l)));
1864 #if FFETARGET_okINTEGER3
1865 case FFEINFO_kindtypeINTEGER3:
1866 error = ffetarget_convert_real2_integer3
1867 (ffebld_cu_ptr_real2 (u),
1868 ffebld_constant_integer3 (ffebld_conter (l)));
1872 #if FFETARGET_okINTEGER4
1873 case FFEINFO_kindtypeINTEGER4:
1874 error = ffetarget_convert_real2_integer4
1875 (ffebld_cu_ptr_real2 (u),
1876 ffebld_constant_integer4 (ffebld_conter (l)));
1881 assert ("REAL2/INTEGER bad source kind type" == NULL);
1886 case FFEINFO_basictypeREAL:
1887 switch (ffeinfo_kindtype (ffebld_info (l)))
1889 #if FFETARGET_okREAL1
1890 case FFEINFO_kindtypeREAL1:
1891 error = ffetarget_convert_real2_real1
1892 (ffebld_cu_ptr_real2 (u),
1893 ffebld_constant_real1 (ffebld_conter (l)));
1897 #if FFETARGET_okREAL3
1898 case FFEINFO_kindtypeREAL3:
1899 error = ffetarget_convert_real2_real3
1900 (ffebld_cu_ptr_real2 (u),
1901 ffebld_constant_real3 (ffebld_conter (l)));
1905 #if FFETARGET_okREAL4
1906 case FFEINFO_kindtypeREAL4:
1907 error = ffetarget_convert_real2_real4
1908 (ffebld_cu_ptr_real2 (u),
1909 ffebld_constant_real4 (ffebld_conter (l)));
1914 assert ("REAL2/REAL bad source kind type" == NULL);
1919 case FFEINFO_basictypeCOMPLEX:
1920 switch (ffeinfo_kindtype (ffebld_info (l)))
1922 #if FFETARGET_okCOMPLEX1
1923 case FFEINFO_kindtypeREAL1:
1924 error = ffetarget_convert_real2_complex1
1925 (ffebld_cu_ptr_real2 (u),
1926 ffebld_constant_complex1 (ffebld_conter (l)));
1930 #if FFETARGET_okCOMPLEX2
1931 case FFEINFO_kindtypeREAL2:
1932 error = ffetarget_convert_real2_complex2
1933 (ffebld_cu_ptr_real2 (u),
1934 ffebld_constant_complex2 (ffebld_conter (l)));
1938 #if FFETARGET_okCOMPLEX3
1939 case FFEINFO_kindtypeREAL3:
1940 error = ffetarget_convert_real2_complex3
1941 (ffebld_cu_ptr_real2 (u),
1942 ffebld_constant_complex3 (ffebld_conter (l)));
1946 #if FFETARGET_okCOMPLEX4
1947 case FFEINFO_kindtypeREAL4:
1948 error = ffetarget_convert_real2_complex4
1949 (ffebld_cu_ptr_real2 (u),
1950 ffebld_constant_complex4 (ffebld_conter (l)));
1955 assert ("REAL2/COMPLEX bad source kind type" == NULL);
1960 case FFEINFO_basictypeCHARACTER:
1961 error = ffetarget_convert_real2_character1
1962 (ffebld_cu_ptr_real2 (u),
1963 ffebld_constant_character1 (ffebld_conter (l)));
1966 case FFEINFO_basictypeHOLLERITH:
1967 error = ffetarget_convert_real2_hollerith
1968 (ffebld_cu_ptr_real2 (u),
1969 ffebld_constant_hollerith (ffebld_conter (l)));
1972 case FFEINFO_basictypeTYPELESS:
1973 error = ffetarget_convert_real2_typeless
1974 (ffebld_cu_ptr_real2 (u),
1975 ffebld_constant_typeless (ffebld_conter (l)));
1979 assert ("REAL2 bad type" == NULL);
1983 /* If conversion operation is not implemented, return original expr. */
1984 if (error == FFEBAD_NOCANDO)
1987 expr = ffebld_new_conter_with_orig
1988 (ffebld_constant_new_real2_val
1989 (ffebld_cu_val_real2 (u)), expr);
1993 #if FFETARGET_okREAL3
1994 case FFEINFO_kindtypeREAL3:
1995 switch (ffeinfo_basictype (ffebld_info (l)))
1997 case FFEINFO_basictypeINTEGER:
1998 switch (ffeinfo_kindtype (ffebld_info (l)))
2000 #if FFETARGET_okINTEGER1
2001 case FFEINFO_kindtypeINTEGER1:
2002 error = ffetarget_convert_real3_integer1
2003 (ffebld_cu_ptr_real3 (u),
2004 ffebld_constant_integer1 (ffebld_conter (l)));
2008 #if FFETARGET_okINTEGER2
2009 case FFEINFO_kindtypeINTEGER2:
2010 error = ffetarget_convert_real3_integer2
2011 (ffebld_cu_ptr_real3 (u),
2012 ffebld_constant_integer2 (ffebld_conter (l)));
2016 #if FFETARGET_okINTEGER3
2017 case FFEINFO_kindtypeINTEGER3:
2018 error = ffetarget_convert_real3_integer3
2019 (ffebld_cu_ptr_real3 (u),
2020 ffebld_constant_integer3 (ffebld_conter (l)));
2024 #if FFETARGET_okINTEGER4
2025 case FFEINFO_kindtypeINTEGER4:
2026 error = ffetarget_convert_real3_integer4
2027 (ffebld_cu_ptr_real3 (u),
2028 ffebld_constant_integer4 (ffebld_conter (l)));
2033 assert ("REAL3/INTEGER bad source kind type" == NULL);
2038 case FFEINFO_basictypeREAL:
2039 switch (ffeinfo_kindtype (ffebld_info (l)))
2041 #if FFETARGET_okREAL1
2042 case FFEINFO_kindtypeREAL1:
2043 error = ffetarget_convert_real3_real1
2044 (ffebld_cu_ptr_real3 (u),
2045 ffebld_constant_real1 (ffebld_conter (l)));
2049 #if FFETARGET_okREAL2
2050 case FFEINFO_kindtypeREAL2:
2051 error = ffetarget_convert_real3_real2
2052 (ffebld_cu_ptr_real3 (u),
2053 ffebld_constant_real2 (ffebld_conter (l)));
2057 #if FFETARGET_okREAL4
2058 case FFEINFO_kindtypeREAL4:
2059 error = ffetarget_convert_real3_real4
2060 (ffebld_cu_ptr_real3 (u),
2061 ffebld_constant_real4 (ffebld_conter (l)));
2066 assert ("REAL3/REAL bad source kind type" == NULL);
2071 case FFEINFO_basictypeCOMPLEX:
2072 switch (ffeinfo_kindtype (ffebld_info (l)))
2074 #if FFETARGET_okCOMPLEX1
2075 case FFEINFO_kindtypeREAL1:
2076 error = ffetarget_convert_real3_complex1
2077 (ffebld_cu_ptr_real3 (u),
2078 ffebld_constant_complex1 (ffebld_conter (l)));
2082 #if FFETARGET_okCOMPLEX2
2083 case FFEINFO_kindtypeREAL2:
2084 error = ffetarget_convert_real3_complex2
2085 (ffebld_cu_ptr_real3 (u),
2086 ffebld_constant_complex2 (ffebld_conter (l)));
2090 #if FFETARGET_okCOMPLEX3
2091 case FFEINFO_kindtypeREAL3:
2092 error = ffetarget_convert_real3_complex3
2093 (ffebld_cu_ptr_real3 (u),
2094 ffebld_constant_complex3 (ffebld_conter (l)));
2098 #if FFETARGET_okCOMPLEX4
2099 case FFEINFO_kindtypeREAL4:
2100 error = ffetarget_convert_real3_complex4
2101 (ffebld_cu_ptr_real3 (u),
2102 ffebld_constant_complex4 (ffebld_conter (l)));
2107 assert ("REAL3/COMPLEX bad source kind type" == NULL);
2112 case FFEINFO_basictypeCHARACTER:
2113 error = ffetarget_convert_real3_character1
2114 (ffebld_cu_ptr_real3 (u),
2115 ffebld_constant_character1 (ffebld_conter (l)));
2118 case FFEINFO_basictypeHOLLERITH:
2119 error = ffetarget_convert_real3_hollerith
2120 (ffebld_cu_ptr_real3 (u),
2121 ffebld_constant_hollerith (ffebld_conter (l)));
2124 case FFEINFO_basictypeTYPELESS:
2125 error = ffetarget_convert_real3_typeless
2126 (ffebld_cu_ptr_real3 (u),
2127 ffebld_constant_typeless (ffebld_conter (l)));
2131 assert ("REAL3 bad type" == NULL);
2135 /* If conversion operation is not implemented, return original expr. */
2136 if (error == FFEBAD_NOCANDO)
2139 expr = ffebld_new_conter_with_orig
2140 (ffebld_constant_new_real3_val
2141 (ffebld_cu_val_real3 (u)), expr);
2145 #if FFETARGET_okREAL4
2146 case FFEINFO_kindtypeREAL4:
2147 switch (ffeinfo_basictype (ffebld_info (l)))
2149 case FFEINFO_basictypeINTEGER:
2150 switch (ffeinfo_kindtype (ffebld_info (l)))
2152 #if FFETARGET_okINTEGER1
2153 case FFEINFO_kindtypeINTEGER1:
2154 error = ffetarget_convert_real4_integer1
2155 (ffebld_cu_ptr_real4 (u),
2156 ffebld_constant_integer1 (ffebld_conter (l)));
2160 #if FFETARGET_okINTEGER2
2161 case FFEINFO_kindtypeINTEGER2:
2162 error = ffetarget_convert_real4_integer2
2163 (ffebld_cu_ptr_real4 (u),
2164 ffebld_constant_integer2 (ffebld_conter (l)));
2168 #if FFETARGET_okINTEGER3
2169 case FFEINFO_kindtypeINTEGER3:
2170 error = ffetarget_convert_real4_integer3
2171 (ffebld_cu_ptr_real4 (u),
2172 ffebld_constant_integer3 (ffebld_conter (l)));
2176 #if FFETARGET_okINTEGER4
2177 case FFEINFO_kindtypeINTEGER4:
2178 error = ffetarget_convert_real4_integer4
2179 (ffebld_cu_ptr_real4 (u),
2180 ffebld_constant_integer4 (ffebld_conter (l)));
2185 assert ("REAL4/INTEGER bad source kind type" == NULL);
2190 case FFEINFO_basictypeREAL:
2191 switch (ffeinfo_kindtype (ffebld_info (l)))
2193 #if FFETARGET_okREAL1
2194 case FFEINFO_kindtypeREAL1:
2195 error = ffetarget_convert_real4_real1
2196 (ffebld_cu_ptr_real4 (u),
2197 ffebld_constant_real1 (ffebld_conter (l)));
2201 #if FFETARGET_okREAL2
2202 case FFEINFO_kindtypeREAL2:
2203 error = ffetarget_convert_real4_real2
2204 (ffebld_cu_ptr_real4 (u),
2205 ffebld_constant_real2 (ffebld_conter (l)));
2209 #if FFETARGET_okREAL3
2210 case FFEINFO_kindtypeREAL3:
2211 error = ffetarget_convert_real4_real3
2212 (ffebld_cu_ptr_real4 (u),
2213 ffebld_constant_real3 (ffebld_conter (l)));
2218 assert ("REAL4/REAL bad source kind type" == NULL);
2223 case FFEINFO_basictypeCOMPLEX:
2224 switch (ffeinfo_kindtype (ffebld_info (l)))
2226 #if FFETARGET_okCOMPLEX1
2227 case FFEINFO_kindtypeREAL1:
2228 error = ffetarget_convert_real4_complex1
2229 (ffebld_cu_ptr_real4 (u),
2230 ffebld_constant_complex1 (ffebld_conter (l)));
2234 #if FFETARGET_okCOMPLEX2
2235 case FFEINFO_kindtypeREAL2:
2236 error = ffetarget_convert_real4_complex2
2237 (ffebld_cu_ptr_real4 (u),
2238 ffebld_constant_complex2 (ffebld_conter (l)));
2242 #if FFETARGET_okCOMPLEX3
2243 case FFEINFO_kindtypeREAL3:
2244 error = ffetarget_convert_real4_complex3
2245 (ffebld_cu_ptr_real4 (u),
2246 ffebld_constant_complex3 (ffebld_conter (l)));
2250 #if FFETARGET_okCOMPLEX4
2251 case FFEINFO_kindtypeREAL4:
2252 error = ffetarget_convert_real4_complex4
2253 (ffebld_cu_ptr_real4 (u),
2254 ffebld_constant_complex4 (ffebld_conter (l)));
2259 assert ("REAL4/COMPLEX bad source kind type" == NULL);
2264 case FFEINFO_basictypeCHARACTER:
2265 error = ffetarget_convert_real4_character1
2266 (ffebld_cu_ptr_real4 (u),
2267 ffebld_constant_character1 (ffebld_conter (l)));
2270 case FFEINFO_basictypeHOLLERITH:
2271 error = ffetarget_convert_real4_hollerith
2272 (ffebld_cu_ptr_real4 (u),
2273 ffebld_constant_hollerith (ffebld_conter (l)));
2276 case FFEINFO_basictypeTYPELESS:
2277 error = ffetarget_convert_real4_typeless
2278 (ffebld_cu_ptr_real4 (u),
2279 ffebld_constant_typeless (ffebld_conter (l)));
2283 assert ("REAL4 bad type" == NULL);
2287 /* If conversion operation is not implemented, return original expr. */
2288 if (error == FFEBAD_NOCANDO)
2291 expr = ffebld_new_conter_with_orig
2292 (ffebld_constant_new_real4_val
2293 (ffebld_cu_val_real4 (u)), expr);
2298 assert ("bad real kind type" == NULL);
2303 case FFEINFO_basictypeCOMPLEX:
2304 sz = FFETARGET_charactersizeNONE;
2305 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
2307 #if FFETARGET_okCOMPLEX1
2308 case FFEINFO_kindtypeREAL1:
2309 switch (ffeinfo_basictype (ffebld_info (l)))
2311 case FFEINFO_basictypeINTEGER:
2312 switch (ffeinfo_kindtype (ffebld_info (l)))
2314 #if FFETARGET_okINTEGER1
2315 case FFEINFO_kindtypeINTEGER1:
2316 error = ffetarget_convert_complex1_integer1
2317 (ffebld_cu_ptr_complex1 (u),
2318 ffebld_constant_integer1 (ffebld_conter (l)));
2322 #if FFETARGET_okINTEGER2
2323 case FFEINFO_kindtypeINTEGER2:
2324 error = ffetarget_convert_complex1_integer2
2325 (ffebld_cu_ptr_complex1 (u),
2326 ffebld_constant_integer2 (ffebld_conter (l)));
2330 #if FFETARGET_okINTEGER3
2331 case FFEINFO_kindtypeINTEGER3:
2332 error = ffetarget_convert_complex1_integer3
2333 (ffebld_cu_ptr_complex1 (u),
2334 ffebld_constant_integer3 (ffebld_conter (l)));
2338 #if FFETARGET_okINTEGER4
2339 case FFEINFO_kindtypeINTEGER4:
2340 error = ffetarget_convert_complex1_integer4
2341 (ffebld_cu_ptr_complex1 (u),
2342 ffebld_constant_integer4 (ffebld_conter (l)));
2347 assert ("COMPLEX1/INTEGER bad source kind type" == NULL);
2352 case FFEINFO_basictypeREAL:
2353 switch (ffeinfo_kindtype (ffebld_info (l)))
2355 #if FFETARGET_okREAL1
2356 case FFEINFO_kindtypeREAL1:
2357 error = ffetarget_convert_complex1_real1
2358 (ffebld_cu_ptr_complex1 (u),
2359 ffebld_constant_real1 (ffebld_conter (l)));
2363 #if FFETARGET_okREAL2
2364 case FFEINFO_kindtypeREAL2:
2365 error = ffetarget_convert_complex1_real2
2366 (ffebld_cu_ptr_complex1 (u),
2367 ffebld_constant_real2 (ffebld_conter (l)));
2371 #if FFETARGET_okREAL3
2372 case FFEINFO_kindtypeREAL3:
2373 error = ffetarget_convert_complex1_real3
2374 (ffebld_cu_ptr_complex1 (u),
2375 ffebld_constant_real3 (ffebld_conter (l)));
2379 #if FFETARGET_okREAL4
2380 case FFEINFO_kindtypeREAL4:
2381 error = ffetarget_convert_complex1_real4
2382 (ffebld_cu_ptr_complex1 (u),
2383 ffebld_constant_real4 (ffebld_conter (l)));
2388 assert ("COMPLEX1/REAL bad source kind type" == NULL);
2393 case FFEINFO_basictypeCOMPLEX:
2394 switch (ffeinfo_kindtype (ffebld_info (l)))
2396 #if FFETARGET_okCOMPLEX2
2397 case FFEINFO_kindtypeREAL2:
2398 error = ffetarget_convert_complex1_complex2
2399 (ffebld_cu_ptr_complex1 (u),
2400 ffebld_constant_complex2 (ffebld_conter (l)));
2404 #if FFETARGET_okCOMPLEX3
2405 case FFEINFO_kindtypeREAL3:
2406 error = ffetarget_convert_complex1_complex3
2407 (ffebld_cu_ptr_complex1 (u),
2408 ffebld_constant_complex3 (ffebld_conter (l)));
2412 #if FFETARGET_okCOMPLEX4
2413 case FFEINFO_kindtypeREAL4:
2414 error = ffetarget_convert_complex1_complex4
2415 (ffebld_cu_ptr_complex1 (u),
2416 ffebld_constant_complex4 (ffebld_conter (l)));
2421 assert ("COMPLEX1/COMPLEX bad source kind type" == NULL);
2426 case FFEINFO_basictypeCHARACTER:
2427 error = ffetarget_convert_complex1_character1
2428 (ffebld_cu_ptr_complex1 (u),
2429 ffebld_constant_character1 (ffebld_conter (l)));
2432 case FFEINFO_basictypeHOLLERITH:
2433 error = ffetarget_convert_complex1_hollerith
2434 (ffebld_cu_ptr_complex1 (u),
2435 ffebld_constant_hollerith (ffebld_conter (l)));
2438 case FFEINFO_basictypeTYPELESS:
2439 error = ffetarget_convert_complex1_typeless
2440 (ffebld_cu_ptr_complex1 (u),
2441 ffebld_constant_typeless (ffebld_conter (l)));
2445 assert ("COMPLEX1 bad type" == NULL);
2449 /* If conversion operation is not implemented, return original expr. */
2450 if (error == FFEBAD_NOCANDO)
2453 expr = ffebld_new_conter_with_orig
2454 (ffebld_constant_new_complex1_val
2455 (ffebld_cu_val_complex1 (u)), expr);
2459 #if FFETARGET_okCOMPLEX2
2460 case FFEINFO_kindtypeREAL2:
2461 switch (ffeinfo_basictype (ffebld_info (l)))
2463 case FFEINFO_basictypeINTEGER:
2464 switch (ffeinfo_kindtype (ffebld_info (l)))
2466 #if FFETARGET_okINTEGER1
2467 case FFEINFO_kindtypeINTEGER1:
2468 error = ffetarget_convert_complex2_integer1
2469 (ffebld_cu_ptr_complex2 (u),
2470 ffebld_constant_integer1 (ffebld_conter (l)));
2474 #if FFETARGET_okINTEGER2
2475 case FFEINFO_kindtypeINTEGER2:
2476 error = ffetarget_convert_complex2_integer2
2477 (ffebld_cu_ptr_complex2 (u),
2478 ffebld_constant_integer2 (ffebld_conter (l)));
2482 #if FFETARGET_okINTEGER3
2483 case FFEINFO_kindtypeINTEGER3:
2484 error = ffetarget_convert_complex2_integer3
2485 (ffebld_cu_ptr_complex2 (u),
2486 ffebld_constant_integer3 (ffebld_conter (l)));
2490 #if FFETARGET_okINTEGER4
2491 case FFEINFO_kindtypeINTEGER4:
2492 error = ffetarget_convert_complex2_integer4
2493 (ffebld_cu_ptr_complex2 (u),
2494 ffebld_constant_integer4 (ffebld_conter (l)));
2499 assert ("COMPLEX2/INTEGER bad source kind type" == NULL);
2504 case FFEINFO_basictypeREAL:
2505 switch (ffeinfo_kindtype (ffebld_info (l)))
2507 #if FFETARGET_okREAL1
2508 case FFEINFO_kindtypeREAL1:
2509 error = ffetarget_convert_complex2_real1
2510 (ffebld_cu_ptr_complex2 (u),
2511 ffebld_constant_real1 (ffebld_conter (l)));
2515 #if FFETARGET_okREAL2
2516 case FFEINFO_kindtypeREAL2:
2517 error = ffetarget_convert_complex2_real2
2518 (ffebld_cu_ptr_complex2 (u),
2519 ffebld_constant_real2 (ffebld_conter (l)));
2523 #if FFETARGET_okREAL3
2524 case FFEINFO_kindtypeREAL3:
2525 error = ffetarget_convert_complex2_real3
2526 (ffebld_cu_ptr_complex2 (u),
2527 ffebld_constant_real3 (ffebld_conter (l)));
2531 #if FFETARGET_okREAL4
2532 case FFEINFO_kindtypeREAL4:
2533 error = ffetarget_convert_complex2_real4
2534 (ffebld_cu_ptr_complex2 (u),
2535 ffebld_constant_real4 (ffebld_conter (l)));
2540 assert ("COMPLEX2/REAL bad source kind type" == NULL);
2545 case FFEINFO_basictypeCOMPLEX:
2546 switch (ffeinfo_kindtype (ffebld_info (l)))
2548 #if FFETARGET_okCOMPLEX1
2549 case FFEINFO_kindtypeREAL1:
2550 error = ffetarget_convert_complex2_complex1
2551 (ffebld_cu_ptr_complex2 (u),
2552 ffebld_constant_complex1 (ffebld_conter (l)));
2556 #if FFETARGET_okCOMPLEX3
2557 case FFEINFO_kindtypeREAL3:
2558 error = ffetarget_convert_complex2_complex3
2559 (ffebld_cu_ptr_complex2 (u),
2560 ffebld_constant_complex3 (ffebld_conter (l)));
2564 #if FFETARGET_okCOMPLEX4
2565 case FFEINFO_kindtypeREAL4:
2566 error = ffetarget_convert_complex2_complex4
2567 (ffebld_cu_ptr_complex2 (u),
2568 ffebld_constant_complex4 (ffebld_conter (l)));
2573 assert ("COMPLEX2/COMPLEX bad source kind type" == NULL);
2578 case FFEINFO_basictypeCHARACTER:
2579 error = ffetarget_convert_complex2_character1
2580 (ffebld_cu_ptr_complex2 (u),
2581 ffebld_constant_character1 (ffebld_conter (l)));
2584 case FFEINFO_basictypeHOLLERITH:
2585 error = ffetarget_convert_complex2_hollerith
2586 (ffebld_cu_ptr_complex2 (u),
2587 ffebld_constant_hollerith (ffebld_conter (l)));
2590 case FFEINFO_basictypeTYPELESS:
2591 error = ffetarget_convert_complex2_typeless
2592 (ffebld_cu_ptr_complex2 (u),
2593 ffebld_constant_typeless (ffebld_conter (l)));
2597 assert ("COMPLEX2 bad type" == NULL);
2601 /* If conversion operation is not implemented, return original expr. */
2602 if (error == FFEBAD_NOCANDO)
2605 expr = ffebld_new_conter_with_orig
2606 (ffebld_constant_new_complex2_val
2607 (ffebld_cu_val_complex2 (u)), expr);
2611 #if FFETARGET_okCOMPLEX3
2612 case FFEINFO_kindtypeREAL3:
2613 switch (ffeinfo_basictype (ffebld_info (l)))
2615 case FFEINFO_basictypeINTEGER:
2616 switch (ffeinfo_kindtype (ffebld_info (l)))
2618 #if FFETARGET_okINTEGER1
2619 case FFEINFO_kindtypeINTEGER1:
2620 error = ffetarget_convert_complex3_integer1
2621 (ffebld_cu_ptr_complex3 (u),
2622 ffebld_constant_integer1 (ffebld_conter (l)));
2626 #if FFETARGET_okINTEGER2
2627 case FFEINFO_kindtypeINTEGER2:
2628 error = ffetarget_convert_complex3_integer2
2629 (ffebld_cu_ptr_complex3 (u),
2630 ffebld_constant_integer2 (ffebld_conter (l)));
2634 #if FFETARGET_okINTEGER3
2635 case FFEINFO_kindtypeINTEGER3:
2636 error = ffetarget_convert_complex3_integer3
2637 (ffebld_cu_ptr_complex3 (u),
2638 ffebld_constant_integer3 (ffebld_conter (l)));
2642 #if FFETARGET_okINTEGER4
2643 case FFEINFO_kindtypeINTEGER4:
2644 error = ffetarget_convert_complex3_integer4
2645 (ffebld_cu_ptr_complex3 (u),
2646 ffebld_constant_integer4 (ffebld_conter (l)));
2651 assert ("COMPLEX3/INTEGER bad source kind type" == NULL);
2656 case FFEINFO_basictypeREAL:
2657 switch (ffeinfo_kindtype (ffebld_info (l)))
2659 #if FFETARGET_okREAL1
2660 case FFEINFO_kindtypeREAL1:
2661 error = ffetarget_convert_complex3_real1
2662 (ffebld_cu_ptr_complex3 (u),
2663 ffebld_constant_real1 (ffebld_conter (l)));
2667 #if FFETARGET_okREAL2
2668 case FFEINFO_kindtypeREAL2:
2669 error = ffetarget_convert_complex3_real2
2670 (ffebld_cu_ptr_complex3 (u),
2671 ffebld_constant_real2 (ffebld_conter (l)));
2675 #if FFETARGET_okREAL3
2676 case FFEINFO_kindtypeREAL3:
2677 error = ffetarget_convert_complex3_real3
2678 (ffebld_cu_ptr_complex3 (u),
2679 ffebld_constant_real3 (ffebld_conter (l)));
2683 #if FFETARGET_okREAL4
2684 case FFEINFO_kindtypeREAL4:
2685 error = ffetarget_convert_complex3_real4
2686 (ffebld_cu_ptr_complex3 (u),
2687 ffebld_constant_real4 (ffebld_conter (l)));
2692 assert ("COMPLEX3/REAL bad source kind type" == NULL);
2697 case FFEINFO_basictypeCOMPLEX:
2698 switch (ffeinfo_kindtype (ffebld_info (l)))
2700 #if FFETARGET_okCOMPLEX1
2701 case FFEINFO_kindtypeREAL1:
2702 error = ffetarget_convert_complex3_complex1
2703 (ffebld_cu_ptr_complex3 (u),
2704 ffebld_constant_complex1 (ffebld_conter (l)));
2708 #if FFETARGET_okCOMPLEX2
2709 case FFEINFO_kindtypeREAL2:
2710 error = ffetarget_convert_complex3_complex2
2711 (ffebld_cu_ptr_complex3 (u),
2712 ffebld_constant_complex2 (ffebld_conter (l)));
2716 #if FFETARGET_okCOMPLEX4
2717 case FFEINFO_kindtypeREAL4:
2718 error = ffetarget_convert_complex3_complex4
2719 (ffebld_cu_ptr_complex3 (u),
2720 ffebld_constant_complex4 (ffebld_conter (l)));
2725 assert ("COMPLEX3/COMPLEX bad source kind type" == NULL);
2730 case FFEINFO_basictypeCHARACTER:
2731 error = ffetarget_convert_complex3_character1
2732 (ffebld_cu_ptr_complex3 (u),
2733 ffebld_constant_character1 (ffebld_conter (l)));
2736 case FFEINFO_basictypeHOLLERITH:
2737 error = ffetarget_convert_complex3_hollerith
2738 (ffebld_cu_ptr_complex3 (u),
2739 ffebld_constant_hollerith (ffebld_conter (l)));
2742 case FFEINFO_basictypeTYPELESS:
2743 error = ffetarget_convert_complex3_typeless
2744 (ffebld_cu_ptr_complex3 (u),
2745 ffebld_constant_typeless (ffebld_conter (l)));
2749 assert ("COMPLEX3 bad type" == NULL);
2753 /* If conversion operation is not implemented, return original expr. */
2754 if (error == FFEBAD_NOCANDO)
2757 expr = ffebld_new_conter_with_orig
2758 (ffebld_constant_new_complex3_val
2759 (ffebld_cu_val_complex3 (u)), expr);
2763 #if FFETARGET_okCOMPLEX4
2764 case FFEINFO_kindtypeREAL4:
2765 switch (ffeinfo_basictype (ffebld_info (l)))
2767 case FFEINFO_basictypeINTEGER:
2768 switch (ffeinfo_kindtype (ffebld_info (l)))
2770 #if FFETARGET_okINTEGER1
2771 case FFEINFO_kindtypeINTEGER1:
2772 error = ffetarget_convert_complex4_integer1
2773 (ffebld_cu_ptr_complex4 (u),
2774 ffebld_constant_integer1 (ffebld_conter (l)));
2778 #if FFETARGET_okINTEGER2
2779 case FFEINFO_kindtypeINTEGER2:
2780 error = ffetarget_convert_complex4_integer2
2781 (ffebld_cu_ptr_complex4 (u),
2782 ffebld_constant_integer2 (ffebld_conter (l)));
2786 #if FFETARGET_okINTEGER3
2787 case FFEINFO_kindtypeINTEGER3:
2788 error = ffetarget_convert_complex4_integer3
2789 (ffebld_cu_ptr_complex4 (u),
2790 ffebld_constant_integer3 (ffebld_conter (l)));
2794 #if FFETARGET_okINTEGER4
2795 case FFEINFO_kindtypeINTEGER4:
2796 error = ffetarget_convert_complex4_integer4
2797 (ffebld_cu_ptr_complex4 (u),
2798 ffebld_constant_integer4 (ffebld_conter (l)));
2803 assert ("COMPLEX4/INTEGER bad source kind type" == NULL);
2808 case FFEINFO_basictypeREAL:
2809 switch (ffeinfo_kindtype (ffebld_info (l)))
2811 #if FFETARGET_okREAL1
2812 case FFEINFO_kindtypeREAL1:
2813 error = ffetarget_convert_complex4_real1
2814 (ffebld_cu_ptr_complex4 (u),
2815 ffebld_constant_real1 (ffebld_conter (l)));
2819 #if FFETARGET_okREAL2
2820 case FFEINFO_kindtypeREAL2:
2821 error = ffetarget_convert_complex4_real2
2822 (ffebld_cu_ptr_complex4 (u),
2823 ffebld_constant_real2 (ffebld_conter (l)));
2827 #if FFETARGET_okREAL3
2828 case FFEINFO_kindtypeREAL3:
2829 error = ffetarget_convert_complex4_real3
2830 (ffebld_cu_ptr_complex4 (u),
2831 ffebld_constant_real3 (ffebld_conter (l)));
2835 #if FFETARGET_okREAL4
2836 case FFEINFO_kindtypeREAL4:
2837 error = ffetarget_convert_complex4_real4
2838 (ffebld_cu_ptr_complex4 (u),
2839 ffebld_constant_real4 (ffebld_conter (l)));
2844 assert ("COMPLEX4/REAL bad source kind type" == NULL);
2849 case FFEINFO_basictypeCOMPLEX:
2850 switch (ffeinfo_kindtype (ffebld_info (l)))
2852 #if FFETARGET_okCOMPLEX1
2853 case FFEINFO_kindtypeREAL1:
2854 error = ffetarget_convert_complex4_complex1
2855 (ffebld_cu_ptr_complex4 (u),
2856 ffebld_constant_complex1 (ffebld_conter (l)));
2860 #if FFETARGET_okCOMPLEX2
2861 case FFEINFO_kindtypeREAL2:
2862 error = ffetarget_convert_complex4_complex2
2863 (ffebld_cu_ptr_complex4 (u),
2864 ffebld_constant_complex2 (ffebld_conter (l)));
2868 #if FFETARGET_okCOMPLEX3
2869 case FFEINFO_kindtypeREAL3:
2870 error = ffetarget_convert_complex4_complex3
2871 (ffebld_cu_ptr_complex4 (u),
2872 ffebld_constant_complex3 (ffebld_conter (l)));
2877 assert ("COMPLEX4/COMPLEX bad source kind type" == NULL);
2882 case FFEINFO_basictypeCHARACTER:
2883 error = ffetarget_convert_complex4_character1
2884 (ffebld_cu_ptr_complex4 (u),
2885 ffebld_constant_character1 (ffebld_conter (l)));
2888 case FFEINFO_basictypeHOLLERITH:
2889 error = ffetarget_convert_complex4_hollerith
2890 (ffebld_cu_ptr_complex4 (u),
2891 ffebld_constant_hollerith (ffebld_conter (l)));
2894 case FFEINFO_basictypeTYPELESS:
2895 error = ffetarget_convert_complex4_typeless
2896 (ffebld_cu_ptr_complex4 (u),
2897 ffebld_constant_typeless (ffebld_conter (l)));
2901 assert ("COMPLEX4 bad type" == NULL);
2905 /* If conversion operation is not implemented, return original expr. */
2906 if (error == FFEBAD_NOCANDO)
2909 expr = ffebld_new_conter_with_orig
2910 (ffebld_constant_new_complex4_val
2911 (ffebld_cu_val_complex4 (u)), expr);
2916 assert ("bad complex kind type" == NULL);
2921 case FFEINFO_basictypeCHARACTER:
2922 if ((sz = ffebld_size (expr)) == FFETARGET_charactersizeNONE)
2924 kt = ffeinfo_kindtype (ffebld_info (expr));
2927 #if FFETARGET_okCHARACTER1
2928 case FFEINFO_kindtypeCHARACTER1:
2929 switch (ffeinfo_basictype (ffebld_info (l)))
2931 case FFEINFO_basictypeCHARACTER:
2932 if ((sz2 = ffebld_size (l)) == FFETARGET_charactersizeNONE)
2934 assert (kt == ffeinfo_kindtype (ffebld_info (l)));
2935 assert (sz2 == ffetarget_length_character1
2936 (ffebld_constant_character1
2937 (ffebld_conter (l))));
2939 = ffetarget_convert_character1_character1
2940 (ffebld_cu_ptr_character1 (u), sz,
2941 ffebld_constant_character1 (ffebld_conter (l)),
2942 ffebld_constant_pool ());
2945 case FFEINFO_basictypeINTEGER:
2946 switch (ffeinfo_kindtype (ffebld_info (l)))
2948 #if FFETARGET_okINTEGER1
2949 case FFEINFO_kindtypeINTEGER1:
2951 = ffetarget_convert_character1_integer1
2952 (ffebld_cu_ptr_character1 (u),
2954 ffebld_constant_integer1 (ffebld_conter (l)),
2955 ffebld_constant_pool ());
2959 #if FFETARGET_okINTEGER2
2960 case FFEINFO_kindtypeINTEGER2:
2962 = ffetarget_convert_character1_integer2
2963 (ffebld_cu_ptr_character1 (u),
2965 ffebld_constant_integer2 (ffebld_conter (l)),
2966 ffebld_constant_pool ());
2970 #if FFETARGET_okINTEGER3
2971 case FFEINFO_kindtypeINTEGER3:
2973 = ffetarget_convert_character1_integer3
2974 (ffebld_cu_ptr_character1 (u),
2976 ffebld_constant_integer3 (ffebld_conter (l)),
2977 ffebld_constant_pool ());
2981 #if FFETARGET_okINTEGER4
2982 case FFEINFO_kindtypeINTEGER4:
2984 = ffetarget_convert_character1_integer4
2985 (ffebld_cu_ptr_character1 (u),
2987 ffebld_constant_integer4 (ffebld_conter (l)),
2988 ffebld_constant_pool ());
2993 assert ("CHARACTER1/INTEGER bad source kind type" == NULL);
2998 case FFEINFO_basictypeLOGICAL:
2999 switch (ffeinfo_kindtype (ffebld_info (l)))
3001 #if FFETARGET_okLOGICAL1
3002 case FFEINFO_kindtypeLOGICAL1:
3004 = ffetarget_convert_character1_logical1
3005 (ffebld_cu_ptr_character1 (u),
3007 ffebld_constant_logical1 (ffebld_conter (l)),
3008 ffebld_constant_pool ());
3012 #if FFETARGET_okLOGICAL2
3013 case FFEINFO_kindtypeLOGICAL2:
3015 = ffetarget_convert_character1_logical2
3016 (ffebld_cu_ptr_character1 (u),
3018 ffebld_constant_logical2 (ffebld_conter (l)),
3019 ffebld_constant_pool ());
3023 #if FFETARGET_okLOGICAL3
3024 case FFEINFO_kindtypeLOGICAL3:
3026 = ffetarget_convert_character1_logical3
3027 (ffebld_cu_ptr_character1 (u),
3029 ffebld_constant_logical3 (ffebld_conter (l)),
3030 ffebld_constant_pool ());
3034 #if FFETARGET_okLOGICAL4
3035 case FFEINFO_kindtypeLOGICAL4:
3037 = ffetarget_convert_character1_logical4
3038 (ffebld_cu_ptr_character1 (u),
3040 ffebld_constant_logical4 (ffebld_conter (l)),
3041 ffebld_constant_pool ());
3046 assert ("CHARACTER1/LOGICAL bad source kind type" == NULL);
3051 case FFEINFO_basictypeHOLLERITH:
3053 = ffetarget_convert_character1_hollerith
3054 (ffebld_cu_ptr_character1 (u),
3056 ffebld_constant_hollerith (ffebld_conter (l)),
3057 ffebld_constant_pool ());
3060 case FFEINFO_basictypeTYPELESS:
3062 = ffetarget_convert_character1_typeless
3063 (ffebld_cu_ptr_character1 (u),
3065 ffebld_constant_typeless (ffebld_conter (l)),
3066 ffebld_constant_pool ());
3070 assert ("CHARACTER1 bad type" == NULL);
3074 = ffebld_new_conter_with_orig
3075 (ffebld_constant_new_character1_val
3076 (ffebld_cu_val_character1 (u)),
3082 assert ("bad character kind type" == NULL);
3088 assert ("bad type" == NULL);
3092 ffebld_set_info (expr, ffeinfo_new
3097 FFEINFO_whereCONSTANT,
3100 if ((error != FFEBAD)
3101 && ffebad_start (error))
3104 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3111 /* ffeexpr_collapse_paren -- Collapse paren expr
3115 expr = ffeexpr_collapse_paren(expr,token);
3117 If the result of the expr is a constant, replaces the expr with the
3118 computed constant. */
3121 ffeexpr_collapse_paren (ffebld expr, ffelexToken t UNUSED)
3124 ffeinfoBasictype bt;
3126 ffetargetCharacterSize len;
3128 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3131 r = ffebld_left (expr);
3133 if (ffebld_op (r) != FFEBLD_opCONTER)
3136 bt = ffeinfo_basictype (ffebld_info (r));
3137 kt = ffeinfo_kindtype (ffebld_info (r));
3138 len = ffebld_size (r);
3140 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
3143 ffebld_set_info (expr, ffeinfo_new
3148 FFEINFO_whereCONSTANT,
3154 /* ffeexpr_collapse_uplus -- Collapse uplus expr
3158 expr = ffeexpr_collapse_uplus(expr,token);
3160 If the result of the expr is a constant, replaces the expr with the
3161 computed constant. */
3164 ffeexpr_collapse_uplus (ffebld expr, ffelexToken t UNUSED)
3167 ffeinfoBasictype bt;
3169 ffetargetCharacterSize len;
3171 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3174 r = ffebld_left (expr);
3176 if (ffebld_op (r) != FFEBLD_opCONTER)
3179 bt = ffeinfo_basictype (ffebld_info (r));
3180 kt = ffeinfo_kindtype (ffebld_info (r));
3181 len = ffebld_size (r);
3183 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
3186 ffebld_set_info (expr, ffeinfo_new
3191 FFEINFO_whereCONSTANT,
3197 /* ffeexpr_collapse_uminus -- Collapse uminus expr
3201 expr = ffeexpr_collapse_uminus(expr,token);
3203 If the result of the expr is a constant, replaces the expr with the
3204 computed constant. */
3207 ffeexpr_collapse_uminus (ffebld expr, ffelexToken t)
3209 ffebad error = FFEBAD;
3211 ffebldConstantUnion u;
3212 ffeinfoBasictype bt;
3215 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3218 r = ffebld_left (expr);
3220 if (ffebld_op (r) != FFEBLD_opCONTER)
3223 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3225 case FFEINFO_basictypeANY:
3228 case FFEINFO_basictypeINTEGER:
3229 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3231 #if FFETARGET_okINTEGER1
3232 case FFEINFO_kindtypeINTEGER1:
3233 error = ffetarget_uminus_integer1 (ffebld_cu_ptr_integer1 (u),
3234 ffebld_constant_integer1 (ffebld_conter (r)));
3235 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3236 (ffebld_cu_val_integer1 (u)), expr);
3240 #if FFETARGET_okINTEGER2
3241 case FFEINFO_kindtypeINTEGER2:
3242 error = ffetarget_uminus_integer2 (ffebld_cu_ptr_integer2 (u),
3243 ffebld_constant_integer2 (ffebld_conter (r)));
3244 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3245 (ffebld_cu_val_integer2 (u)), expr);
3249 #if FFETARGET_okINTEGER3
3250 case FFEINFO_kindtypeINTEGER3:
3251 error = ffetarget_uminus_integer3 (ffebld_cu_ptr_integer3 (u),
3252 ffebld_constant_integer3 (ffebld_conter (r)));
3253 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3254 (ffebld_cu_val_integer3 (u)), expr);
3258 #if FFETARGET_okINTEGER4
3259 case FFEINFO_kindtypeINTEGER4:
3260 error = ffetarget_uminus_integer4 (ffebld_cu_ptr_integer4 (u),
3261 ffebld_constant_integer4 (ffebld_conter (r)));
3262 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3263 (ffebld_cu_val_integer4 (u)), expr);
3268 assert ("bad integer kind type" == NULL);
3273 case FFEINFO_basictypeREAL:
3274 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3276 #if FFETARGET_okREAL1
3277 case FFEINFO_kindtypeREAL1:
3278 error = ffetarget_uminus_real1 (ffebld_cu_ptr_real1 (u),
3279 ffebld_constant_real1 (ffebld_conter (r)));
3280 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3281 (ffebld_cu_val_real1 (u)), expr);
3285 #if FFETARGET_okREAL2
3286 case FFEINFO_kindtypeREAL2:
3287 error = ffetarget_uminus_real2 (ffebld_cu_ptr_real2 (u),
3288 ffebld_constant_real2 (ffebld_conter (r)));
3289 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3290 (ffebld_cu_val_real2 (u)), expr);
3294 #if FFETARGET_okREAL3
3295 case FFEINFO_kindtypeREAL3:
3296 error = ffetarget_uminus_real3 (ffebld_cu_ptr_real3 (u),
3297 ffebld_constant_real3 (ffebld_conter (r)));
3298 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3299 (ffebld_cu_val_real3 (u)), expr);
3303 #if FFETARGET_okREAL4
3304 case FFEINFO_kindtypeREAL4:
3305 error = ffetarget_uminus_real4 (ffebld_cu_ptr_real4 (u),
3306 ffebld_constant_real4 (ffebld_conter (r)));
3307 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
3308 (ffebld_cu_val_real4 (u)), expr);
3313 assert ("bad real kind type" == NULL);
3318 case FFEINFO_basictypeCOMPLEX:
3319 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3321 #if FFETARGET_okCOMPLEX1
3322 case FFEINFO_kindtypeREAL1:
3323 error = ffetarget_uminus_complex1 (ffebld_cu_ptr_complex1 (u),
3324 ffebld_constant_complex1 (ffebld_conter (r)));
3325 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3326 (ffebld_cu_val_complex1 (u)), expr);
3330 #if FFETARGET_okCOMPLEX2
3331 case FFEINFO_kindtypeREAL2:
3332 error = ffetarget_uminus_complex2 (ffebld_cu_ptr_complex2 (u),
3333 ffebld_constant_complex2 (ffebld_conter (r)));
3334 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3335 (ffebld_cu_val_complex2 (u)), expr);
3339 #if FFETARGET_okCOMPLEX3
3340 case FFEINFO_kindtypeREAL3:
3341 error = ffetarget_uminus_complex3 (ffebld_cu_ptr_complex3 (u),
3342 ffebld_constant_complex3 (ffebld_conter (r)));
3343 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3344 (ffebld_cu_val_complex3 (u)), expr);
3348 #if FFETARGET_okCOMPLEX4
3349 case FFEINFO_kindtypeREAL4:
3350 error = ffetarget_uminus_complex4 (ffebld_cu_ptr_complex4 (u),
3351 ffebld_constant_complex4 (ffebld_conter (r)));
3352 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
3353 (ffebld_cu_val_complex4 (u)), expr);
3358 assert ("bad complex kind type" == NULL);
3364 assert ("bad type" == NULL);
3368 ffebld_set_info (expr, ffeinfo_new
3373 FFEINFO_whereCONSTANT,
3374 FFETARGET_charactersizeNONE));
3376 if ((error != FFEBAD)
3377 && ffebad_start (error))
3379 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3386 /* ffeexpr_collapse_not -- Collapse not expr
3390 expr = ffeexpr_collapse_not(expr,token);
3392 If the result of the expr is a constant, replaces the expr with the
3393 computed constant. */
3396 ffeexpr_collapse_not (ffebld expr, ffelexToken t)
3398 ffebad error = FFEBAD;
3400 ffebldConstantUnion u;
3401 ffeinfoBasictype bt;
3404 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3407 r = ffebld_left (expr);
3409 if (ffebld_op (r) != FFEBLD_opCONTER)
3412 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3414 case FFEINFO_basictypeANY:
3417 case FFEINFO_basictypeINTEGER:
3418 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3420 #if FFETARGET_okINTEGER1
3421 case FFEINFO_kindtypeINTEGER1:
3422 error = ffetarget_not_integer1 (ffebld_cu_ptr_integer1 (u),
3423 ffebld_constant_integer1 (ffebld_conter (r)));
3424 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3425 (ffebld_cu_val_integer1 (u)), expr);
3429 #if FFETARGET_okINTEGER2
3430 case FFEINFO_kindtypeINTEGER2:
3431 error = ffetarget_not_integer2 (ffebld_cu_ptr_integer2 (u),
3432 ffebld_constant_integer2 (ffebld_conter (r)));
3433 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3434 (ffebld_cu_val_integer2 (u)), expr);
3438 #if FFETARGET_okINTEGER3
3439 case FFEINFO_kindtypeINTEGER3:
3440 error = ffetarget_not_integer3 (ffebld_cu_ptr_integer3 (u),
3441 ffebld_constant_integer3 (ffebld_conter (r)));
3442 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3443 (ffebld_cu_val_integer3 (u)), expr);
3447 #if FFETARGET_okINTEGER4
3448 case FFEINFO_kindtypeINTEGER4:
3449 error = ffetarget_not_integer4 (ffebld_cu_ptr_integer4 (u),
3450 ffebld_constant_integer4 (ffebld_conter (r)));
3451 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3452 (ffebld_cu_val_integer4 (u)), expr);
3457 assert ("bad integer kind type" == NULL);
3462 case FFEINFO_basictypeLOGICAL:
3463 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3465 #if FFETARGET_okLOGICAL1
3466 case FFEINFO_kindtypeLOGICAL1:
3467 error = ffetarget_not_logical1 (ffebld_cu_ptr_logical1 (u),
3468 ffebld_constant_logical1 (ffebld_conter (r)));
3469 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
3470 (ffebld_cu_val_logical1 (u)), expr);
3474 #if FFETARGET_okLOGICAL2
3475 case FFEINFO_kindtypeLOGICAL2:
3476 error = ffetarget_not_logical2 (ffebld_cu_ptr_logical2 (u),
3477 ffebld_constant_logical2 (ffebld_conter (r)));
3478 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
3479 (ffebld_cu_val_logical2 (u)), expr);
3483 #if FFETARGET_okLOGICAL3
3484 case FFEINFO_kindtypeLOGICAL3:
3485 error = ffetarget_not_logical3 (ffebld_cu_ptr_logical3 (u),
3486 ffebld_constant_logical3 (ffebld_conter (r)));
3487 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
3488 (ffebld_cu_val_logical3 (u)), expr);
3492 #if FFETARGET_okLOGICAL4
3493 case FFEINFO_kindtypeLOGICAL4:
3494 error = ffetarget_not_logical4 (ffebld_cu_ptr_logical4 (u),
3495 ffebld_constant_logical4 (ffebld_conter (r)));
3496 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
3497 (ffebld_cu_val_logical4 (u)), expr);
3502 assert ("bad logical kind type" == NULL);
3508 assert ("bad type" == NULL);
3512 ffebld_set_info (expr, ffeinfo_new
3517 FFEINFO_whereCONSTANT,
3518 FFETARGET_charactersizeNONE));
3520 if ((error != FFEBAD)
3521 && ffebad_start (error))
3523 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3530 /* ffeexpr_collapse_add -- Collapse add expr
3534 expr = ffeexpr_collapse_add(expr,token);
3536 If the result of the expr is a constant, replaces the expr with the
3537 computed constant. */
3540 ffeexpr_collapse_add (ffebld expr, ffelexToken t)
3542 ffebad error = FFEBAD;
3545 ffebldConstantUnion u;
3546 ffeinfoBasictype bt;
3549 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3552 l = ffebld_left (expr);
3553 r = ffebld_right (expr);
3555 if (ffebld_op (l) != FFEBLD_opCONTER)
3557 if (ffebld_op (r) != FFEBLD_opCONTER)
3560 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3562 case FFEINFO_basictypeANY:
3565 case FFEINFO_basictypeINTEGER:
3566 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3568 #if FFETARGET_okINTEGER1
3569 case FFEINFO_kindtypeINTEGER1:
3570 error = ffetarget_add_integer1 (ffebld_cu_ptr_integer1 (u),
3571 ffebld_constant_integer1 (ffebld_conter (l)),
3572 ffebld_constant_integer1 (ffebld_conter (r)));
3573 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3574 (ffebld_cu_val_integer1 (u)), expr);
3578 #if FFETARGET_okINTEGER2
3579 case FFEINFO_kindtypeINTEGER2:
3580 error = ffetarget_add_integer2 (ffebld_cu_ptr_integer2 (u),
3581 ffebld_constant_integer2 (ffebld_conter (l)),
3582 ffebld_constant_integer2 (ffebld_conter (r)));
3583 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3584 (ffebld_cu_val_integer2 (u)), expr);
3588 #if FFETARGET_okINTEGER3
3589 case FFEINFO_kindtypeINTEGER3:
3590 error = ffetarget_add_integer3 (ffebld_cu_ptr_integer3 (u),
3591 ffebld_constant_integer3 (ffebld_conter (l)),
3592 ffebld_constant_integer3 (ffebld_conter (r)));
3593 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3594 (ffebld_cu_val_integer3 (u)), expr);
3598 #if FFETARGET_okINTEGER4
3599 case FFEINFO_kindtypeINTEGER4:
3600 error = ffetarget_add_integer4 (ffebld_cu_ptr_integer4 (u),
3601 ffebld_constant_integer4 (ffebld_conter (l)),
3602 ffebld_constant_integer4 (ffebld_conter (r)));
3603 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3604 (ffebld_cu_val_integer4 (u)), expr);
3609 assert ("bad integer kind type" == NULL);
3614 case FFEINFO_basictypeREAL:
3615 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3617 #if FFETARGET_okREAL1
3618 case FFEINFO_kindtypeREAL1:
3619 error = ffetarget_add_real1 (ffebld_cu_ptr_real1 (u),
3620 ffebld_constant_real1 (ffebld_conter (l)),
3621 ffebld_constant_real1 (ffebld_conter (r)));
3622 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3623 (ffebld_cu_val_real1 (u)), expr);
3627 #if FFETARGET_okREAL2
3628 case FFEINFO_kindtypeREAL2:
3629 error = ffetarget_add_real2 (ffebld_cu_ptr_real2 (u),
3630 ffebld_constant_real2 (ffebld_conter (l)),
3631 ffebld_constant_real2 (ffebld_conter (r)));
3632 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3633 (ffebld_cu_val_real2 (u)), expr);
3637 #if FFETARGET_okREAL3
3638 case FFEINFO_kindtypeREAL3:
3639 error = ffetarget_add_real3 (ffebld_cu_ptr_real3 (u),
3640 ffebld_constant_real3 (ffebld_conter (l)),
3641 ffebld_constant_real3 (ffebld_conter (r)));
3642 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3643 (ffebld_cu_val_real3 (u)), expr);
3647 #if FFETARGET_okREAL4
3648 case FFEINFO_kindtypeREAL4:
3649 error = ffetarget_add_real4 (ffebld_cu_ptr_real4 (u),
3650 ffebld_constant_real4 (ffebld_conter (l)),
3651 ffebld_constant_real4 (ffebld_conter (r)));
3652 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
3653 (ffebld_cu_val_real4 (u)), expr);
3658 assert ("bad real kind type" == NULL);
3663 case FFEINFO_basictypeCOMPLEX:
3664 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3666 #if FFETARGET_okCOMPLEX1
3667 case FFEINFO_kindtypeREAL1:
3668 error = ffetarget_add_complex1 (ffebld_cu_ptr_complex1 (u),
3669 ffebld_constant_complex1 (ffebld_conter (l)),
3670 ffebld_constant_complex1 (ffebld_conter (r)));
3671 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3672 (ffebld_cu_val_complex1 (u)), expr);
3676 #if FFETARGET_okCOMPLEX2
3677 case FFEINFO_kindtypeREAL2:
3678 error = ffetarget_add_complex2 (ffebld_cu_ptr_complex2 (u),
3679 ffebld_constant_complex2 (ffebld_conter (l)),
3680 ffebld_constant_complex2 (ffebld_conter (r)));
3681 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3682 (ffebld_cu_val_complex2 (u)), expr);
3686 #if FFETARGET_okCOMPLEX3
3687 case FFEINFO_kindtypeREAL3:
3688 error = ffetarget_add_complex3 (ffebld_cu_ptr_complex3 (u),
3689 ffebld_constant_complex3 (ffebld_conter (l)),
3690 ffebld_constant_complex3 (ffebld_conter (r)));
3691 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3692 (ffebld_cu_val_complex3 (u)), expr);
3696 #if FFETARGET_okCOMPLEX4
3697 case FFEINFO_kindtypeREAL4:
3698 error = ffetarget_add_complex4 (ffebld_cu_ptr_complex4 (u),
3699 ffebld_constant_complex4 (ffebld_conter (l)),
3700 ffebld_constant_complex4 (ffebld_conter (r)));
3701 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
3702 (ffebld_cu_val_complex4 (u)), expr);
3707 assert ("bad complex kind type" == NULL);
3713 assert ("bad type" == NULL);
3717 ffebld_set_info (expr, ffeinfo_new
3722 FFEINFO_whereCONSTANT,
3723 FFETARGET_charactersizeNONE));
3725 if ((error != FFEBAD)
3726 && ffebad_start (error))
3728 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3735 /* ffeexpr_collapse_subtract -- Collapse subtract expr
3739 expr = ffeexpr_collapse_subtract(expr,token);
3741 If the result of the expr is a constant, replaces the expr with the
3742 computed constant. */
3745 ffeexpr_collapse_subtract (ffebld expr, ffelexToken t)
3747 ffebad error = FFEBAD;
3750 ffebldConstantUnion u;
3751 ffeinfoBasictype bt;
3754 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3757 l = ffebld_left (expr);
3758 r = ffebld_right (expr);
3760 if (ffebld_op (l) != FFEBLD_opCONTER)
3762 if (ffebld_op (r) != FFEBLD_opCONTER)
3765 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3767 case FFEINFO_basictypeANY:
3770 case FFEINFO_basictypeINTEGER:
3771 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3773 #if FFETARGET_okINTEGER1
3774 case FFEINFO_kindtypeINTEGER1:
3775 error = ffetarget_subtract_integer1 (ffebld_cu_ptr_integer1 (u),
3776 ffebld_constant_integer1 (ffebld_conter (l)),
3777 ffebld_constant_integer1 (ffebld_conter (r)));
3778 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3779 (ffebld_cu_val_integer1 (u)), expr);
3783 #if FFETARGET_okINTEGER2
3784 case FFEINFO_kindtypeINTEGER2:
3785 error = ffetarget_subtract_integer2 (ffebld_cu_ptr_integer2 (u),
3786 ffebld_constant_integer2 (ffebld_conter (l)),
3787 ffebld_constant_integer2 (ffebld_conter (r)));
3788 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3789 (ffebld_cu_val_integer2 (u)), expr);
3793 #if FFETARGET_okINTEGER3
3794 case FFEINFO_kindtypeINTEGER3:
3795 error = ffetarget_subtract_integer3 (ffebld_cu_ptr_integer3 (u),
3796 ffebld_constant_integer3 (ffebld_conter (l)),
3797 ffebld_constant_integer3 (ffebld_conter (r)));
3798 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3799 (ffebld_cu_val_integer3 (u)), expr);
3803 #if FFETARGET_okINTEGER4
3804 case FFEINFO_kindtypeINTEGER4:
3805 error = ffetarget_subtract_integer4 (ffebld_cu_ptr_integer4 (u),
3806 ffebld_constant_integer4 (ffebld_conter (l)),
3807 ffebld_constant_integer4 (ffebld_conter (r)));
3808 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3809 (ffebld_cu_val_integer4 (u)), expr);
3814 assert ("bad integer kind type" == NULL);
3819 case FFEINFO_basictypeREAL:
3820 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3822 #if FFETARGET_okREAL1
3823 case FFEINFO_kindtypeREAL1:
3824 error = ffetarget_subtract_real1 (ffebld_cu_ptr_real1 (u),
3825 ffebld_constant_real1 (ffebld_conter (l)),
3826 ffebld_constant_real1 (ffebld_conter (r)));
3827 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3828 (ffebld_cu_val_real1 (u)), expr);
3832 #if FFETARGET_okREAL2
3833 case FFEINFO_kindtypeREAL2:
3834 error = ffetarget_subtract_real2 (ffebld_cu_ptr_real2 (u),
3835 ffebld_constant_real2 (ffebld_conter (l)),
3836 ffebld_constant_real2 (ffebld_conter (r)));
3837 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3838 (ffebld_cu_val_real2 (u)), expr);
3842 #if FFETARGET_okREAL3
3843 case FFEINFO_kindtypeREAL3:
3844 error = ffetarget_subtract_real3 (ffebld_cu_ptr_real3 (u),
3845 ffebld_constant_real3 (ffebld_conter (l)),
3846 ffebld_constant_real3 (ffebld_conter (r)));
3847 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3848 (ffebld_cu_val_real3 (u)), expr);
3852 #if FFETARGET_okREAL4
3853 case FFEINFO_kindtypeREAL4:
3854 error = ffetarget_subtract_real4 (ffebld_cu_ptr_real4 (u),
3855 ffebld_constant_real4 (ffebld_conter (l)),
3856 ffebld_constant_real4 (ffebld_conter (r)));
3857 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
3858 (ffebld_cu_val_real4 (u)), expr);
3863 assert ("bad real kind type" == NULL);
3868 case FFEINFO_basictypeCOMPLEX:
3869 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3871 #if FFETARGET_okCOMPLEX1
3872 case FFEINFO_kindtypeREAL1:
3873 error = ffetarget_subtract_complex1 (ffebld_cu_ptr_complex1 (u),
3874 ffebld_constant_complex1 (ffebld_conter (l)),
3875 ffebld_constant_complex1 (ffebld_conter (r)));
3876 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3877 (ffebld_cu_val_complex1 (u)), expr);
3881 #if FFETARGET_okCOMPLEX2
3882 case FFEINFO_kindtypeREAL2:
3883 error = ffetarget_subtract_complex2 (ffebld_cu_ptr_complex2 (u),
3884 ffebld_constant_complex2 (ffebld_conter (l)),
3885 ffebld_constant_complex2 (ffebld_conter (r)));
3886 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3887 (ffebld_cu_val_complex2 (u)), expr);
3891 #if FFETARGET_okCOMPLEX3
3892 case FFEINFO_kindtypeREAL3:
3893 error = ffetarget_subtract_complex3 (ffebld_cu_ptr_complex3 (u),
3894 ffebld_constant_complex3 (ffebld_conter (l)),
3895 ffebld_constant_complex3 (ffebld_conter (r)));
3896 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3897 (ffebld_cu_val_complex3 (u)), expr);
3901 #if FFETARGET_okCOMPLEX4
3902 case FFEINFO_kindtypeREAL4:
3903 error = ffetarget_subtract_complex4 (ffebld_cu_ptr_complex4 (u),
3904 ffebld_constant_complex4 (ffebld_conter (l)),
3905 ffebld_constant_complex4 (ffebld_conter (r)));
3906 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
3907 (ffebld_cu_val_complex4 (u)), expr);
3912 assert ("bad complex kind type" == NULL);
3918 assert ("bad type" == NULL);
3922 ffebld_set_info (expr, ffeinfo_new
3927 FFEINFO_whereCONSTANT,
3928 FFETARGET_charactersizeNONE));
3930 if ((error != FFEBAD)
3931 && ffebad_start (error))
3933 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
3940 /* ffeexpr_collapse_multiply -- Collapse multiply expr
3944 expr = ffeexpr_collapse_multiply(expr,token);
3946 If the result of the expr is a constant, replaces the expr with the
3947 computed constant. */
3950 ffeexpr_collapse_multiply (ffebld expr, ffelexToken t)
3952 ffebad error = FFEBAD;
3955 ffebldConstantUnion u;
3956 ffeinfoBasictype bt;
3959 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
3962 l = ffebld_left (expr);
3963 r = ffebld_right (expr);
3965 if (ffebld_op (l) != FFEBLD_opCONTER)
3967 if (ffebld_op (r) != FFEBLD_opCONTER)
3970 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
3972 case FFEINFO_basictypeANY:
3975 case FFEINFO_basictypeINTEGER:
3976 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
3978 #if FFETARGET_okINTEGER1
3979 case FFEINFO_kindtypeINTEGER1:
3980 error = ffetarget_multiply_integer1 (ffebld_cu_ptr_integer1 (u),
3981 ffebld_constant_integer1 (ffebld_conter (l)),
3982 ffebld_constant_integer1 (ffebld_conter (r)));
3983 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3984 (ffebld_cu_val_integer1 (u)), expr);
3988 #if FFETARGET_okINTEGER2
3989 case FFEINFO_kindtypeINTEGER2:
3990 error = ffetarget_multiply_integer2 (ffebld_cu_ptr_integer2 (u),
3991 ffebld_constant_integer2 (ffebld_conter (l)),
3992 ffebld_constant_integer2 (ffebld_conter (r)));
3993 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3994 (ffebld_cu_val_integer2 (u)), expr);
3998 #if FFETARGET_okINTEGER3
3999 case FFEINFO_kindtypeINTEGER3:
4000 error = ffetarget_multiply_integer3 (ffebld_cu_ptr_integer3 (u),
4001 ffebld_constant_integer3 (ffebld_conter (l)),
4002 ffebld_constant_integer3 (ffebld_conter (r)));
4003 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
4004 (ffebld_cu_val_integer3 (u)), expr);
4008 #if FFETARGET_okINTEGER4
4009 case FFEINFO_kindtypeINTEGER4:
4010 error = ffetarget_multiply_integer4 (ffebld_cu_ptr_integer4 (u),
4011 ffebld_constant_integer4 (ffebld_conter (l)),
4012 ffebld_constant_integer4 (ffebld_conter (r)));
4013 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
4014 (ffebld_cu_val_integer4 (u)), expr);
4019 assert ("bad integer kind type" == NULL);
4024 case FFEINFO_basictypeREAL:
4025 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4027 #if FFETARGET_okREAL1
4028 case FFEINFO_kindtypeREAL1:
4029 error = ffetarget_multiply_real1 (ffebld_cu_ptr_real1 (u),
4030 ffebld_constant_real1 (ffebld_conter (l)),
4031 ffebld_constant_real1 (ffebld_conter (r)));
4032 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
4033 (ffebld_cu_val_real1 (u)), expr);
4037 #if FFETARGET_okREAL2
4038 case FFEINFO_kindtypeREAL2:
4039 error = ffetarget_multiply_real2 (ffebld_cu_ptr_real2 (u),
4040 ffebld_constant_real2 (ffebld_conter (l)),
4041 ffebld_constant_real2 (ffebld_conter (r)));
4042 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
4043 (ffebld_cu_val_real2 (u)), expr);
4047 #if FFETARGET_okREAL3
4048 case FFEINFO_kindtypeREAL3:
4049 error = ffetarget_multiply_real3 (ffebld_cu_ptr_real3 (u),
4050 ffebld_constant_real3 (ffebld_conter (l)),
4051 ffebld_constant_real3 (ffebld_conter (r)));
4052 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
4053 (ffebld_cu_val_real3 (u)), expr);
4057 #if FFETARGET_okREAL4
4058 case FFEINFO_kindtypeREAL4:
4059 error = ffetarget_multiply_real4 (ffebld_cu_ptr_real4 (u),
4060 ffebld_constant_real4 (ffebld_conter (l)),
4061 ffebld_constant_real4 (ffebld_conter (r)));
4062 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
4063 (ffebld_cu_val_real4 (u)), expr);
4068 assert ("bad real kind type" == NULL);
4073 case FFEINFO_basictypeCOMPLEX:
4074 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4076 #if FFETARGET_okCOMPLEX1
4077 case FFEINFO_kindtypeREAL1:
4078 error = ffetarget_multiply_complex1 (ffebld_cu_ptr_complex1 (u),
4079 ffebld_constant_complex1 (ffebld_conter (l)),
4080 ffebld_constant_complex1 (ffebld_conter (r)));
4081 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
4082 (ffebld_cu_val_complex1 (u)), expr);
4086 #if FFETARGET_okCOMPLEX2
4087 case FFEINFO_kindtypeREAL2:
4088 error = ffetarget_multiply_complex2 (ffebld_cu_ptr_complex2 (u),
4089 ffebld_constant_complex2 (ffebld_conter (l)),
4090 ffebld_constant_complex2 (ffebld_conter (r)));
4091 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
4092 (ffebld_cu_val_complex2 (u)), expr);
4096 #if FFETARGET_okCOMPLEX3
4097 case FFEINFO_kindtypeREAL3:
4098 error = ffetarget_multiply_complex3 (ffebld_cu_ptr_complex3 (u),
4099 ffebld_constant_complex3 (ffebld_conter (l)),
4100 ffebld_constant_complex3 (ffebld_conter (r)));
4101 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
4102 (ffebld_cu_val_complex3 (u)), expr);
4106 #if FFETARGET_okCOMPLEX4
4107 case FFEINFO_kindtypeREAL4:
4108 error = ffetarget_multiply_complex4 (ffebld_cu_ptr_complex4 (u),
4109 ffebld_constant_complex4 (ffebld_conter (l)),
4110 ffebld_constant_complex4 (ffebld_conter (r)));
4111 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
4112 (ffebld_cu_val_complex4 (u)), expr);
4117 assert ("bad complex kind type" == NULL);
4123 assert ("bad type" == NULL);
4127 ffebld_set_info (expr, ffeinfo_new
4132 FFEINFO_whereCONSTANT,
4133 FFETARGET_charactersizeNONE));
4135 if ((error != FFEBAD)
4136 && ffebad_start (error))
4138 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4145 /* ffeexpr_collapse_divide -- Collapse divide expr
4149 expr = ffeexpr_collapse_divide(expr,token);
4151 If the result of the expr is a constant, replaces the expr with the
4152 computed constant. */
4155 ffeexpr_collapse_divide (ffebld expr, ffelexToken t)
4157 ffebad error = FFEBAD;
4160 ffebldConstantUnion u;
4161 ffeinfoBasictype bt;
4164 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4167 l = ffebld_left (expr);
4168 r = ffebld_right (expr);
4170 if (ffebld_op (l) != FFEBLD_opCONTER)
4172 if (ffebld_op (r) != FFEBLD_opCONTER)
4175 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
4177 case FFEINFO_basictypeANY:
4180 case FFEINFO_basictypeINTEGER:
4181 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4183 #if FFETARGET_okINTEGER1
4184 case FFEINFO_kindtypeINTEGER1:
4185 error = ffetarget_divide_integer1 (ffebld_cu_ptr_integer1 (u),
4186 ffebld_constant_integer1 (ffebld_conter (l)),
4187 ffebld_constant_integer1 (ffebld_conter (r)));
4188 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
4189 (ffebld_cu_val_integer1 (u)), expr);
4193 #if FFETARGET_okINTEGER2
4194 case FFEINFO_kindtypeINTEGER2:
4195 error = ffetarget_divide_integer2 (ffebld_cu_ptr_integer2 (u),
4196 ffebld_constant_integer2 (ffebld_conter (l)),
4197 ffebld_constant_integer2 (ffebld_conter (r)));
4198 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
4199 (ffebld_cu_val_integer2 (u)), expr);
4203 #if FFETARGET_okINTEGER3
4204 case FFEINFO_kindtypeINTEGER3:
4205 error = ffetarget_divide_integer3 (ffebld_cu_ptr_integer3 (u),
4206 ffebld_constant_integer3 (ffebld_conter (l)),
4207 ffebld_constant_integer3 (ffebld_conter (r)));
4208 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
4209 (ffebld_cu_val_integer3 (u)), expr);
4213 #if FFETARGET_okINTEGER4
4214 case FFEINFO_kindtypeINTEGER4:
4215 error = ffetarget_divide_integer4 (ffebld_cu_ptr_integer4 (u),
4216 ffebld_constant_integer4 (ffebld_conter (l)),
4217 ffebld_constant_integer4 (ffebld_conter (r)));
4218 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
4219 (ffebld_cu_val_integer4 (u)), expr);
4224 assert ("bad integer kind type" == NULL);
4229 case FFEINFO_basictypeREAL:
4230 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4232 #if FFETARGET_okREAL1
4233 case FFEINFO_kindtypeREAL1:
4234 error = ffetarget_divide_real1 (ffebld_cu_ptr_real1 (u),
4235 ffebld_constant_real1 (ffebld_conter (l)),
4236 ffebld_constant_real1 (ffebld_conter (r)));
4237 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
4238 (ffebld_cu_val_real1 (u)), expr);
4242 #if FFETARGET_okREAL2
4243 case FFEINFO_kindtypeREAL2:
4244 error = ffetarget_divide_real2 (ffebld_cu_ptr_real2 (u),
4245 ffebld_constant_real2 (ffebld_conter (l)),
4246 ffebld_constant_real2 (ffebld_conter (r)));
4247 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
4248 (ffebld_cu_val_real2 (u)), expr);
4252 #if FFETARGET_okREAL3
4253 case FFEINFO_kindtypeREAL3:
4254 error = ffetarget_divide_real3 (ffebld_cu_ptr_real3 (u),
4255 ffebld_constant_real3 (ffebld_conter (l)),
4256 ffebld_constant_real3 (ffebld_conter (r)));
4257 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
4258 (ffebld_cu_val_real3 (u)), expr);
4262 #if FFETARGET_okREAL4
4263 case FFEINFO_kindtypeREAL4:
4264 error = ffetarget_divide_real4 (ffebld_cu_ptr_real4 (u),
4265 ffebld_constant_real4 (ffebld_conter (l)),
4266 ffebld_constant_real4 (ffebld_conter (r)));
4267 expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
4268 (ffebld_cu_val_real4 (u)), expr);
4273 assert ("bad real kind type" == NULL);
4278 case FFEINFO_basictypeCOMPLEX:
4279 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4281 #if FFETARGET_okCOMPLEX1
4282 case FFEINFO_kindtypeREAL1:
4283 error = ffetarget_divide_complex1 (ffebld_cu_ptr_complex1 (u),
4284 ffebld_constant_complex1 (ffebld_conter (l)),
4285 ffebld_constant_complex1 (ffebld_conter (r)));
4286 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
4287 (ffebld_cu_val_complex1 (u)), expr);
4291 #if FFETARGET_okCOMPLEX2
4292 case FFEINFO_kindtypeREAL2:
4293 error = ffetarget_divide_complex2 (ffebld_cu_ptr_complex2 (u),
4294 ffebld_constant_complex2 (ffebld_conter (l)),
4295 ffebld_constant_complex2 (ffebld_conter (r)));
4296 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
4297 (ffebld_cu_val_complex2 (u)), expr);
4301 #if FFETARGET_okCOMPLEX3
4302 case FFEINFO_kindtypeREAL3:
4303 error = ffetarget_divide_complex3 (ffebld_cu_ptr_complex3 (u),
4304 ffebld_constant_complex3 (ffebld_conter (l)),
4305 ffebld_constant_complex3 (ffebld_conter (r)));
4306 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
4307 (ffebld_cu_val_complex3 (u)), expr);
4311 #if FFETARGET_okCOMPLEX4
4312 case FFEINFO_kindtypeREAL4:
4313 error = ffetarget_divide_complex4 (ffebld_cu_ptr_complex4 (u),
4314 ffebld_constant_complex4 (ffebld_conter (l)),
4315 ffebld_constant_complex4 (ffebld_conter (r)));
4316 expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
4317 (ffebld_cu_val_complex4 (u)), expr);
4322 assert ("bad complex kind type" == NULL);
4328 assert ("bad type" == NULL);
4332 ffebld_set_info (expr, ffeinfo_new
4337 FFEINFO_whereCONSTANT,
4338 FFETARGET_charactersizeNONE));
4340 if ((error != FFEBAD)
4341 && ffebad_start (error))
4343 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4350 /* ffeexpr_collapse_power -- Collapse power expr
4354 expr = ffeexpr_collapse_power(expr,token);
4356 If the result of the expr is a constant, replaces the expr with the
4357 computed constant. */
4360 ffeexpr_collapse_power (ffebld expr, ffelexToken t)
4362 ffebad error = FFEBAD;
4365 ffebldConstantUnion u;
4366 ffeinfoBasictype bt;
4369 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4372 l = ffebld_left (expr);
4373 r = ffebld_right (expr);
4375 if (ffebld_op (l) != FFEBLD_opCONTER)
4377 if (ffebld_op (r) != FFEBLD_opCONTER)
4380 if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER)
4381 || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT))
4384 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
4386 case FFEINFO_basictypeANY:
4389 case FFEINFO_basictypeINTEGER:
4390 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4392 case FFEINFO_kindtypeINTEGERDEFAULT:
4393 error = ffetarget_power_integerdefault_integerdefault
4394 (ffebld_cu_ptr_integerdefault (u),
4395 ffebld_constant_integerdefault (ffebld_conter (l)),
4396 ffebld_constant_integerdefault (ffebld_conter (r)));
4397 expr = ffebld_new_conter_with_orig
4398 (ffebld_constant_new_integerdefault_val
4399 (ffebld_cu_val_integerdefault (u)), expr);
4403 assert ("bad integer kind type" == NULL);
4408 case FFEINFO_basictypeREAL:
4409 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4411 case FFEINFO_kindtypeREALDEFAULT:
4412 error = ffetarget_power_realdefault_integerdefault
4413 (ffebld_cu_ptr_realdefault (u),
4414 ffebld_constant_realdefault (ffebld_conter (l)),
4415 ffebld_constant_integerdefault (ffebld_conter (r)));
4416 expr = ffebld_new_conter_with_orig
4417 (ffebld_constant_new_realdefault_val
4418 (ffebld_cu_val_realdefault (u)), expr);
4421 case FFEINFO_kindtypeREALDOUBLE:
4422 error = ffetarget_power_realdouble_integerdefault
4423 (ffebld_cu_ptr_realdouble (u),
4424 ffebld_constant_realdouble (ffebld_conter (l)),
4425 ffebld_constant_integerdefault (ffebld_conter (r)));
4426 expr = ffebld_new_conter_with_orig
4427 (ffebld_constant_new_realdouble_val
4428 (ffebld_cu_val_realdouble (u)), expr);
4431 #if FFETARGET_okREALQUAD
4432 case FFEINFO_kindtypeREALQUAD:
4433 error = ffetarget_power_realquad_integerdefault
4434 (ffebld_cu_ptr_realquad (u),
4435 ffebld_constant_realquad (ffebld_conter (l)),
4436 ffebld_constant_integerdefault (ffebld_conter (r)));
4437 expr = ffebld_new_conter_with_orig
4438 (ffebld_constant_new_realquad_val
4439 (ffebld_cu_val_realquad (u)), expr);
4443 assert ("bad real kind type" == NULL);
4448 case FFEINFO_basictypeCOMPLEX:
4449 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4451 case FFEINFO_kindtypeREALDEFAULT:
4452 error = ffetarget_power_complexdefault_integerdefault
4453 (ffebld_cu_ptr_complexdefault (u),
4454 ffebld_constant_complexdefault (ffebld_conter (l)),
4455 ffebld_constant_integerdefault (ffebld_conter (r)));
4456 expr = ffebld_new_conter_with_orig
4457 (ffebld_constant_new_complexdefault_val
4458 (ffebld_cu_val_complexdefault (u)), expr);
4461 #if FFETARGET_okCOMPLEXDOUBLE
4462 case FFEINFO_kindtypeREALDOUBLE:
4463 error = ffetarget_power_complexdouble_integerdefault
4464 (ffebld_cu_ptr_complexdouble (u),
4465 ffebld_constant_complexdouble (ffebld_conter (l)),
4466 ffebld_constant_integerdefault (ffebld_conter (r)));
4467 expr = ffebld_new_conter_with_orig
4468 (ffebld_constant_new_complexdouble_val
4469 (ffebld_cu_val_complexdouble (u)), expr);
4473 #if FFETARGET_okCOMPLEXQUAD
4474 case FFEINFO_kindtypeREALQUAD:
4475 error = ffetarget_power_complexquad_integerdefault
4476 (ffebld_cu_ptr_complexquad (u),
4477 ffebld_constant_complexquad (ffebld_conter (l)),
4478 ffebld_constant_integerdefault (ffebld_conter (r)));
4479 expr = ffebld_new_conter_with_orig
4480 (ffebld_constant_new_complexquad_val
4481 (ffebld_cu_val_complexquad (u)), expr);
4486 assert ("bad complex kind type" == NULL);
4492 assert ("bad type" == NULL);
4496 ffebld_set_info (expr, ffeinfo_new
4501 FFEINFO_whereCONSTANT,
4502 FFETARGET_charactersizeNONE));
4504 if ((error != FFEBAD)
4505 && ffebad_start (error))
4507 ffebad_here (0, ffelex_token_where_line (t),
4508 ffelex_token_where_column (t));
4515 /* ffeexpr_collapse_concatenate -- Collapse concatenate expr
4519 expr = ffeexpr_collapse_concatenate(expr,token);
4521 If the result of the expr is a constant, replaces the expr with the
4522 computed constant. */
4525 ffeexpr_collapse_concatenate (ffebld expr, ffelexToken t)
4527 ffebad error = FFEBAD;
4530 ffebldConstantUnion u;
4532 ffetargetCharacterSize len;
4534 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4537 l = ffebld_left (expr);
4538 r = ffebld_right (expr);
4540 if (ffebld_op (l) != FFEBLD_opCONTER)
4542 if (ffebld_op (r) != FFEBLD_opCONTER)
4545 switch (ffeinfo_basictype (ffebld_info (expr)))
4547 case FFEINFO_basictypeANY:
4550 case FFEINFO_basictypeCHARACTER:
4551 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
4553 #if FFETARGET_okCHARACTER1
4554 case FFEINFO_kindtypeCHARACTER1:
4555 error = ffetarget_concatenate_character1 (ffebld_cu_ptr_character1 (u),
4556 ffebld_constant_character1 (ffebld_conter (l)),
4557 ffebld_constant_character1 (ffebld_conter (r)),
4558 ffebld_constant_pool (), &len);
4559 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
4560 (ffebld_cu_val_character1 (u)), expr);
4564 #if FFETARGET_okCHARACTER2
4565 case FFEINFO_kindtypeCHARACTER2:
4566 error = ffetarget_concatenate_character2 (ffebld_cu_ptr_character2 (u),
4567 ffebld_constant_character2 (ffebld_conter (l)),
4568 ffebld_constant_character2 (ffebld_conter (r)),
4569 ffebld_constant_pool (), &len);
4570 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val
4571 (ffebld_cu_val_character2 (u)), expr);
4575 #if FFETARGET_okCHARACTER3
4576 case FFEINFO_kindtypeCHARACTER3:
4577 error = ffetarget_concatenate_character3 (ffebld_cu_ptr_character3 (u),
4578 ffebld_constant_character3 (ffebld_conter (l)),
4579 ffebld_constant_character3 (ffebld_conter (r)),
4580 ffebld_constant_pool (), &len);
4581 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val
4582 (ffebld_cu_val_character3 (u)), expr);
4586 #if FFETARGET_okCHARACTER4
4587 case FFEINFO_kindtypeCHARACTER4:
4588 error = ffetarget_concatenate_character4 (ffebld_cu_ptr_character4 (u),
4589 ffebld_constant_character4 (ffebld_conter (l)),
4590 ffebld_constant_character4 (ffebld_conter (r)),
4591 ffebld_constant_pool (), &len);
4592 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val
4593 (ffebld_cu_val_character4 (u)), expr);
4598 assert ("bad character kind type" == NULL);
4604 assert ("bad type" == NULL);
4608 ffebld_set_info (expr, ffeinfo_new
4609 (FFEINFO_basictypeCHARACTER,
4613 FFEINFO_whereCONSTANT,
4616 if ((error != FFEBAD)
4617 && ffebad_start (error))
4619 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4626 /* ffeexpr_collapse_eq -- Collapse eq expr
4630 expr = ffeexpr_collapse_eq(expr,token);
4632 If the result of the expr is a constant, replaces the expr with the
4633 computed constant. */
4636 ffeexpr_collapse_eq (ffebld expr, ffelexToken t)
4638 ffebad error = FFEBAD;
4643 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4646 l = ffebld_left (expr);
4647 r = ffebld_right (expr);
4649 if (ffebld_op (l) != FFEBLD_opCONTER)
4651 if (ffebld_op (r) != FFEBLD_opCONTER)
4654 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4656 case FFEINFO_basictypeANY:
4659 case FFEINFO_basictypeINTEGER:
4660 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4662 #if FFETARGET_okINTEGER1
4663 case FFEINFO_kindtypeINTEGER1:
4664 error = ffetarget_eq_integer1 (&val,
4665 ffebld_constant_integer1 (ffebld_conter (l)),
4666 ffebld_constant_integer1 (ffebld_conter (r)));
4667 expr = ffebld_new_conter_with_orig
4668 (ffebld_constant_new_logicaldefault (val), expr);
4672 #if FFETARGET_okINTEGER2
4673 case FFEINFO_kindtypeINTEGER2:
4674 error = ffetarget_eq_integer2 (&val,
4675 ffebld_constant_integer2 (ffebld_conter (l)),
4676 ffebld_constant_integer2 (ffebld_conter (r)));
4677 expr = ffebld_new_conter_with_orig
4678 (ffebld_constant_new_logicaldefault (val), expr);
4682 #if FFETARGET_okINTEGER3
4683 case FFEINFO_kindtypeINTEGER3:
4684 error = ffetarget_eq_integer3 (&val,
4685 ffebld_constant_integer3 (ffebld_conter (l)),
4686 ffebld_constant_integer3 (ffebld_conter (r)));
4687 expr = ffebld_new_conter_with_orig
4688 (ffebld_constant_new_logicaldefault (val), expr);
4692 #if FFETARGET_okINTEGER4
4693 case FFEINFO_kindtypeINTEGER4:
4694 error = ffetarget_eq_integer4 (&val,
4695 ffebld_constant_integer4 (ffebld_conter (l)),
4696 ffebld_constant_integer4 (ffebld_conter (r)));
4697 expr = ffebld_new_conter_with_orig
4698 (ffebld_constant_new_logicaldefault (val), expr);
4703 assert ("bad integer kind type" == NULL);
4708 case FFEINFO_basictypeREAL:
4709 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4711 #if FFETARGET_okREAL1
4712 case FFEINFO_kindtypeREAL1:
4713 error = ffetarget_eq_real1 (&val,
4714 ffebld_constant_real1 (ffebld_conter (l)),
4715 ffebld_constant_real1 (ffebld_conter (r)));
4716 expr = ffebld_new_conter_with_orig
4717 (ffebld_constant_new_logicaldefault (val), expr);
4721 #if FFETARGET_okREAL2
4722 case FFEINFO_kindtypeREAL2:
4723 error = ffetarget_eq_real2 (&val,
4724 ffebld_constant_real2 (ffebld_conter (l)),
4725 ffebld_constant_real2 (ffebld_conter (r)));
4726 expr = ffebld_new_conter_with_orig
4727 (ffebld_constant_new_logicaldefault (val), expr);
4731 #if FFETARGET_okREAL3
4732 case FFEINFO_kindtypeREAL3:
4733 error = ffetarget_eq_real3 (&val,
4734 ffebld_constant_real3 (ffebld_conter (l)),
4735 ffebld_constant_real3 (ffebld_conter (r)));
4736 expr = ffebld_new_conter_with_orig
4737 (ffebld_constant_new_logicaldefault (val), expr);
4741 #if FFETARGET_okREAL4
4742 case FFEINFO_kindtypeREAL4:
4743 error = ffetarget_eq_real4 (&val,
4744 ffebld_constant_real4 (ffebld_conter (l)),
4745 ffebld_constant_real4 (ffebld_conter (r)));
4746 expr = ffebld_new_conter_with_orig
4747 (ffebld_constant_new_logicaldefault (val), expr);
4752 assert ("bad real kind type" == NULL);
4757 case FFEINFO_basictypeCOMPLEX:
4758 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4760 #if FFETARGET_okCOMPLEX1
4761 case FFEINFO_kindtypeREAL1:
4762 error = ffetarget_eq_complex1 (&val,
4763 ffebld_constant_complex1 (ffebld_conter (l)),
4764 ffebld_constant_complex1 (ffebld_conter (r)));
4765 expr = ffebld_new_conter_with_orig
4766 (ffebld_constant_new_logicaldefault (val), expr);
4770 #if FFETARGET_okCOMPLEX2
4771 case FFEINFO_kindtypeREAL2:
4772 error = ffetarget_eq_complex2 (&val,
4773 ffebld_constant_complex2 (ffebld_conter (l)),
4774 ffebld_constant_complex2 (ffebld_conter (r)));
4775 expr = ffebld_new_conter_with_orig
4776 (ffebld_constant_new_logicaldefault (val), expr);
4780 #if FFETARGET_okCOMPLEX3
4781 case FFEINFO_kindtypeREAL3:
4782 error = ffetarget_eq_complex3 (&val,
4783 ffebld_constant_complex3 (ffebld_conter (l)),
4784 ffebld_constant_complex3 (ffebld_conter (r)));
4785 expr = ffebld_new_conter_with_orig
4786 (ffebld_constant_new_logicaldefault (val), expr);
4790 #if FFETARGET_okCOMPLEX4
4791 case FFEINFO_kindtypeREAL4:
4792 error = ffetarget_eq_complex4 (&val,
4793 ffebld_constant_complex4 (ffebld_conter (l)),
4794 ffebld_constant_complex4 (ffebld_conter (r)));
4795 expr = ffebld_new_conter_with_orig
4796 (ffebld_constant_new_logicaldefault (val), expr);
4801 assert ("bad complex kind type" == NULL);
4806 case FFEINFO_basictypeCHARACTER:
4807 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4809 #if FFETARGET_okCHARACTER1
4810 case FFEINFO_kindtypeCHARACTER1:
4811 error = ffetarget_eq_character1 (&val,
4812 ffebld_constant_character1 (ffebld_conter (l)),
4813 ffebld_constant_character1 (ffebld_conter (r)));
4814 expr = ffebld_new_conter_with_orig
4815 (ffebld_constant_new_logicaldefault (val), expr);
4819 #if FFETARGET_okCHARACTER2
4820 case FFEINFO_kindtypeCHARACTER2:
4821 error = ffetarget_eq_character2 (&val,
4822 ffebld_constant_character2 (ffebld_conter (l)),
4823 ffebld_constant_character2 (ffebld_conter (r)));
4824 expr = ffebld_new_conter_with_orig
4825 (ffebld_constant_new_logicaldefault (val), expr);
4829 #if FFETARGET_okCHARACTER3
4830 case FFEINFO_kindtypeCHARACTER3:
4831 error = ffetarget_eq_character3 (&val,
4832 ffebld_constant_character3 (ffebld_conter (l)),
4833 ffebld_constant_character3 (ffebld_conter (r)));
4834 expr = ffebld_new_conter_with_orig
4835 (ffebld_constant_new_logicaldefault (val), expr);
4839 #if FFETARGET_okCHARACTER4
4840 case FFEINFO_kindtypeCHARACTER4:
4841 error = ffetarget_eq_character4 (&val,
4842 ffebld_constant_character4 (ffebld_conter (l)),
4843 ffebld_constant_character4 (ffebld_conter (r)));
4844 expr = ffebld_new_conter_with_orig
4845 (ffebld_constant_new_logicaldefault (val), expr);
4850 assert ("bad character kind type" == NULL);
4856 assert ("bad type" == NULL);
4860 ffebld_set_info (expr, ffeinfo_new
4861 (FFEINFO_basictypeLOGICAL,
4862 FFEINFO_kindtypeLOGICALDEFAULT,
4865 FFEINFO_whereCONSTANT,
4866 FFETARGET_charactersizeNONE));
4868 if ((error != FFEBAD)
4869 && ffebad_start (error))
4871 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
4878 /* ffeexpr_collapse_ne -- Collapse ne expr
4882 expr = ffeexpr_collapse_ne(expr,token);
4884 If the result of the expr is a constant, replaces the expr with the
4885 computed constant. */
4888 ffeexpr_collapse_ne (ffebld expr, ffelexToken t)
4890 ffebad error = FFEBAD;
4895 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
4898 l = ffebld_left (expr);
4899 r = ffebld_right (expr);
4901 if (ffebld_op (l) != FFEBLD_opCONTER)
4903 if (ffebld_op (r) != FFEBLD_opCONTER)
4906 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
4908 case FFEINFO_basictypeANY:
4911 case FFEINFO_basictypeINTEGER:
4912 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4914 #if FFETARGET_okINTEGER1
4915 case FFEINFO_kindtypeINTEGER1:
4916 error = ffetarget_ne_integer1 (&val,
4917 ffebld_constant_integer1 (ffebld_conter (l)),
4918 ffebld_constant_integer1 (ffebld_conter (r)));
4919 expr = ffebld_new_conter_with_orig
4920 (ffebld_constant_new_logicaldefault (val), expr);
4924 #if FFETARGET_okINTEGER2
4925 case FFEINFO_kindtypeINTEGER2:
4926 error = ffetarget_ne_integer2 (&val,
4927 ffebld_constant_integer2 (ffebld_conter (l)),
4928 ffebld_constant_integer2 (ffebld_conter (r)));
4929 expr = ffebld_new_conter_with_orig
4930 (ffebld_constant_new_logicaldefault (val), expr);
4934 #if FFETARGET_okINTEGER3
4935 case FFEINFO_kindtypeINTEGER3:
4936 error = ffetarget_ne_integer3 (&val,
4937 ffebld_constant_integer3 (ffebld_conter (l)),
4938 ffebld_constant_integer3 (ffebld_conter (r)));
4939 expr = ffebld_new_conter_with_orig
4940 (ffebld_constant_new_logicaldefault (val), expr);
4944 #if FFETARGET_okINTEGER4
4945 case FFEINFO_kindtypeINTEGER4:
4946 error = ffetarget_ne_integer4 (&val,
4947 ffebld_constant_integer4 (ffebld_conter (l)),
4948 ffebld_constant_integer4 (ffebld_conter (r)));
4949 expr = ffebld_new_conter_with_orig
4950 (ffebld_constant_new_logicaldefault (val), expr);
4955 assert ("bad integer kind type" == NULL);
4960 case FFEINFO_basictypeREAL:
4961 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
4963 #if FFETARGET_okREAL1
4964 case FFEINFO_kindtypeREAL1:
4965 error = ffetarget_ne_real1 (&val,
4966 ffebld_constant_real1 (ffebld_conter (l)),
4967 ffebld_constant_real1 (ffebld_conter (r)));
4968 expr = ffebld_new_conter_with_orig
4969 (ffebld_constant_new_logicaldefault (val), expr);
4973 #if FFETARGET_okREAL2
4974 case FFEINFO_kindtypeREAL2:
4975 error = ffetarget_ne_real2 (&val,
4976 ffebld_constant_real2 (ffebld_conter (l)),
4977 ffebld_constant_real2 (ffebld_conter (r)));
4978 expr = ffebld_new_conter_with_orig
4979 (ffebld_constant_new_logicaldefault (val), expr);
4983 #if FFETARGET_okREAL3
4984 case FFEINFO_kindtypeREAL3:
4985 error = ffetarget_ne_real3 (&val,
4986 ffebld_constant_real3 (ffebld_conter (l)),
4987 ffebld_constant_real3 (ffebld_conter (r)));
4988 expr = ffebld_new_conter_with_orig
4989 (ffebld_constant_new_logicaldefault (val), expr);
4993 #if FFETARGET_okREAL4
4994 case FFEINFO_kindtypeREAL4:
4995 error = ffetarget_ne_real4 (&val,
4996 ffebld_constant_real4 (ffebld_conter (l)),
4997 ffebld_constant_real4 (ffebld_conter (r)));
4998 expr = ffebld_new_conter_with_orig
4999 (ffebld_constant_new_logicaldefault (val), expr);
5004 assert ("bad real kind type" == NULL);
5009 case FFEINFO_basictypeCOMPLEX:
5010 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5012 #if FFETARGET_okCOMPLEX1
5013 case FFEINFO_kindtypeREAL1:
5014 error = ffetarget_ne_complex1 (&val,
5015 ffebld_constant_complex1 (ffebld_conter (l)),
5016 ffebld_constant_complex1 (ffebld_conter (r)));
5017 expr = ffebld_new_conter_with_orig
5018 (ffebld_constant_new_logicaldefault (val), expr);
5022 #if FFETARGET_okCOMPLEX2
5023 case FFEINFO_kindtypeREAL2:
5024 error = ffetarget_ne_complex2 (&val,
5025 ffebld_constant_complex2 (ffebld_conter (l)),
5026 ffebld_constant_complex2 (ffebld_conter (r)));
5027 expr = ffebld_new_conter_with_orig
5028 (ffebld_constant_new_logicaldefault (val), expr);
5032 #if FFETARGET_okCOMPLEX3
5033 case FFEINFO_kindtypeREAL3:
5034 error = ffetarget_ne_complex3 (&val,
5035 ffebld_constant_complex3 (ffebld_conter (l)),
5036 ffebld_constant_complex3 (ffebld_conter (r)));
5037 expr = ffebld_new_conter_with_orig
5038 (ffebld_constant_new_logicaldefault (val), expr);
5042 #if FFETARGET_okCOMPLEX4
5043 case FFEINFO_kindtypeREAL4:
5044 error = ffetarget_ne_complex4 (&val,
5045 ffebld_constant_complex4 (ffebld_conter (l)),
5046 ffebld_constant_complex4 (ffebld_conter (r)));
5047 expr = ffebld_new_conter_with_orig
5048 (ffebld_constant_new_logicaldefault (val), expr);
5053 assert ("bad complex kind type" == NULL);
5058 case FFEINFO_basictypeCHARACTER:
5059 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5061 #if FFETARGET_okCHARACTER1
5062 case FFEINFO_kindtypeCHARACTER1:
5063 error = ffetarget_ne_character1 (&val,
5064 ffebld_constant_character1 (ffebld_conter (l)),
5065 ffebld_constant_character1 (ffebld_conter (r)));
5066 expr = ffebld_new_conter_with_orig
5067 (ffebld_constant_new_logicaldefault (val), expr);
5071 #if FFETARGET_okCHARACTER2
5072 case FFEINFO_kindtypeCHARACTER2:
5073 error = ffetarget_ne_character2 (&val,
5074 ffebld_constant_character2 (ffebld_conter (l)),
5075 ffebld_constant_character2 (ffebld_conter (r)));
5076 expr = ffebld_new_conter_with_orig
5077 (ffebld_constant_new_logicaldefault (val), expr);
5081 #if FFETARGET_okCHARACTER3
5082 case FFEINFO_kindtypeCHARACTER3:
5083 error = ffetarget_ne_character3 (&val,
5084 ffebld_constant_character3 (ffebld_conter (l)),
5085 ffebld_constant_character3 (ffebld_conter (r)));
5086 expr = ffebld_new_conter_with_orig
5087 (ffebld_constant_new_logicaldefault (val), expr);
5091 #if FFETARGET_okCHARACTER4
5092 case FFEINFO_kindtypeCHARACTER4:
5093 error = ffetarget_ne_character4 (&val,
5094 ffebld_constant_character4 (ffebld_conter (l)),
5095 ffebld_constant_character4 (ffebld_conter (r)));
5096 expr = ffebld_new_conter_with_orig
5097 (ffebld_constant_new_logicaldefault (val), expr);
5102 assert ("bad character kind type" == NULL);
5108 assert ("bad type" == NULL);
5112 ffebld_set_info (expr, ffeinfo_new
5113 (FFEINFO_basictypeLOGICAL,
5114 FFEINFO_kindtypeLOGICALDEFAULT,
5117 FFEINFO_whereCONSTANT,
5118 FFETARGET_charactersizeNONE));
5120 if ((error != FFEBAD)
5121 && ffebad_start (error))
5123 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5130 /* ffeexpr_collapse_ge -- Collapse ge expr
5134 expr = ffeexpr_collapse_ge(expr,token);
5136 If the result of the expr is a constant, replaces the expr with the
5137 computed constant. */
5140 ffeexpr_collapse_ge (ffebld expr, ffelexToken t)
5142 ffebad error = FFEBAD;
5147 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5150 l = ffebld_left (expr);
5151 r = ffebld_right (expr);
5153 if (ffebld_op (l) != FFEBLD_opCONTER)
5155 if (ffebld_op (r) != FFEBLD_opCONTER)
5158 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5160 case FFEINFO_basictypeANY:
5163 case FFEINFO_basictypeINTEGER:
5164 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5166 #if FFETARGET_okINTEGER1
5167 case FFEINFO_kindtypeINTEGER1:
5168 error = ffetarget_ge_integer1 (&val,
5169 ffebld_constant_integer1 (ffebld_conter (l)),
5170 ffebld_constant_integer1 (ffebld_conter (r)));
5171 expr = ffebld_new_conter_with_orig
5172 (ffebld_constant_new_logicaldefault (val), expr);
5176 #if FFETARGET_okINTEGER2
5177 case FFEINFO_kindtypeINTEGER2:
5178 error = ffetarget_ge_integer2 (&val,
5179 ffebld_constant_integer2 (ffebld_conter (l)),
5180 ffebld_constant_integer2 (ffebld_conter (r)));
5181 expr = ffebld_new_conter_with_orig
5182 (ffebld_constant_new_logicaldefault (val), expr);
5186 #if FFETARGET_okINTEGER3
5187 case FFEINFO_kindtypeINTEGER3:
5188 error = ffetarget_ge_integer3 (&val,
5189 ffebld_constant_integer3 (ffebld_conter (l)),
5190 ffebld_constant_integer3 (ffebld_conter (r)));
5191 expr = ffebld_new_conter_with_orig
5192 (ffebld_constant_new_logicaldefault (val), expr);
5196 #if FFETARGET_okINTEGER4
5197 case FFEINFO_kindtypeINTEGER4:
5198 error = ffetarget_ge_integer4 (&val,
5199 ffebld_constant_integer4 (ffebld_conter (l)),
5200 ffebld_constant_integer4 (ffebld_conter (r)));
5201 expr = ffebld_new_conter_with_orig
5202 (ffebld_constant_new_logicaldefault (val), expr);
5207 assert ("bad integer kind type" == NULL);
5212 case FFEINFO_basictypeREAL:
5213 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5215 #if FFETARGET_okREAL1
5216 case FFEINFO_kindtypeREAL1:
5217 error = ffetarget_ge_real1 (&val,
5218 ffebld_constant_real1 (ffebld_conter (l)),
5219 ffebld_constant_real1 (ffebld_conter (r)));
5220 expr = ffebld_new_conter_with_orig
5221 (ffebld_constant_new_logicaldefault (val), expr);
5225 #if FFETARGET_okREAL2
5226 case FFEINFO_kindtypeREAL2:
5227 error = ffetarget_ge_real2 (&val,
5228 ffebld_constant_real2 (ffebld_conter (l)),
5229 ffebld_constant_real2 (ffebld_conter (r)));
5230 expr = ffebld_new_conter_with_orig
5231 (ffebld_constant_new_logicaldefault (val), expr);
5235 #if FFETARGET_okREAL3
5236 case FFEINFO_kindtypeREAL3:
5237 error = ffetarget_ge_real3 (&val,
5238 ffebld_constant_real3 (ffebld_conter (l)),
5239 ffebld_constant_real3 (ffebld_conter (r)));
5240 expr = ffebld_new_conter_with_orig
5241 (ffebld_constant_new_logicaldefault (val), expr);
5245 #if FFETARGET_okREAL4
5246 case FFEINFO_kindtypeREAL4:
5247 error = ffetarget_ge_real4 (&val,
5248 ffebld_constant_real4 (ffebld_conter (l)),
5249 ffebld_constant_real4 (ffebld_conter (r)));
5250 expr = ffebld_new_conter_with_orig
5251 (ffebld_constant_new_logicaldefault (val), expr);
5256 assert ("bad real kind type" == NULL);
5261 case FFEINFO_basictypeCHARACTER:
5262 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5264 #if FFETARGET_okCHARACTER1
5265 case FFEINFO_kindtypeCHARACTER1:
5266 error = ffetarget_ge_character1 (&val,
5267 ffebld_constant_character1 (ffebld_conter (l)),
5268 ffebld_constant_character1 (ffebld_conter (r)));
5269 expr = ffebld_new_conter_with_orig
5270 (ffebld_constant_new_logicaldefault (val), expr);
5274 #if FFETARGET_okCHARACTER2
5275 case FFEINFO_kindtypeCHARACTER2:
5276 error = ffetarget_ge_character2 (&val,
5277 ffebld_constant_character2 (ffebld_conter (l)),
5278 ffebld_constant_character2 (ffebld_conter (r)));
5279 expr = ffebld_new_conter_with_orig
5280 (ffebld_constant_new_logicaldefault (val), expr);
5284 #if FFETARGET_okCHARACTER3
5285 case FFEINFO_kindtypeCHARACTER3:
5286 error = ffetarget_ge_character3 (&val,
5287 ffebld_constant_character3 (ffebld_conter (l)),
5288 ffebld_constant_character3 (ffebld_conter (r)));
5289 expr = ffebld_new_conter_with_orig
5290 (ffebld_constant_new_logicaldefault (val), expr);
5294 #if FFETARGET_okCHARACTER4
5295 case FFEINFO_kindtypeCHARACTER4:
5296 error = ffetarget_ge_character4 (&val,
5297 ffebld_constant_character4 (ffebld_conter (l)),
5298 ffebld_constant_character4 (ffebld_conter (r)));
5299 expr = ffebld_new_conter_with_orig
5300 (ffebld_constant_new_logicaldefault (val), expr);
5305 assert ("bad character kind type" == NULL);
5311 assert ("bad type" == NULL);
5315 ffebld_set_info (expr, ffeinfo_new
5316 (FFEINFO_basictypeLOGICAL,
5317 FFEINFO_kindtypeLOGICALDEFAULT,
5320 FFEINFO_whereCONSTANT,
5321 FFETARGET_charactersizeNONE));
5323 if ((error != FFEBAD)
5324 && ffebad_start (error))
5326 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5333 /* ffeexpr_collapse_gt -- Collapse gt expr
5337 expr = ffeexpr_collapse_gt(expr,token);
5339 If the result of the expr is a constant, replaces the expr with the
5340 computed constant. */
5343 ffeexpr_collapse_gt (ffebld expr, ffelexToken t)
5345 ffebad error = FFEBAD;
5350 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5353 l = ffebld_left (expr);
5354 r = ffebld_right (expr);
5356 if (ffebld_op (l) != FFEBLD_opCONTER)
5358 if (ffebld_op (r) != FFEBLD_opCONTER)
5361 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5363 case FFEINFO_basictypeANY:
5366 case FFEINFO_basictypeINTEGER:
5367 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5369 #if FFETARGET_okINTEGER1
5370 case FFEINFO_kindtypeINTEGER1:
5371 error = ffetarget_gt_integer1 (&val,
5372 ffebld_constant_integer1 (ffebld_conter (l)),
5373 ffebld_constant_integer1 (ffebld_conter (r)));
5374 expr = ffebld_new_conter_with_orig
5375 (ffebld_constant_new_logicaldefault (val), expr);
5379 #if FFETARGET_okINTEGER2
5380 case FFEINFO_kindtypeINTEGER2:
5381 error = ffetarget_gt_integer2 (&val,
5382 ffebld_constant_integer2 (ffebld_conter (l)),
5383 ffebld_constant_integer2 (ffebld_conter (r)));
5384 expr = ffebld_new_conter_with_orig
5385 (ffebld_constant_new_logicaldefault (val), expr);
5389 #if FFETARGET_okINTEGER3
5390 case FFEINFO_kindtypeINTEGER3:
5391 error = ffetarget_gt_integer3 (&val,
5392 ffebld_constant_integer3 (ffebld_conter (l)),
5393 ffebld_constant_integer3 (ffebld_conter (r)));
5394 expr = ffebld_new_conter_with_orig
5395 (ffebld_constant_new_logicaldefault (val), expr);
5399 #if FFETARGET_okINTEGER4
5400 case FFEINFO_kindtypeINTEGER4:
5401 error = ffetarget_gt_integer4 (&val,
5402 ffebld_constant_integer4 (ffebld_conter (l)),
5403 ffebld_constant_integer4 (ffebld_conter (r)));
5404 expr = ffebld_new_conter_with_orig
5405 (ffebld_constant_new_logicaldefault (val), expr);
5410 assert ("bad integer kind type" == NULL);
5415 case FFEINFO_basictypeREAL:
5416 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5418 #if FFETARGET_okREAL1
5419 case FFEINFO_kindtypeREAL1:
5420 error = ffetarget_gt_real1 (&val,
5421 ffebld_constant_real1 (ffebld_conter (l)),
5422 ffebld_constant_real1 (ffebld_conter (r)));
5423 expr = ffebld_new_conter_with_orig
5424 (ffebld_constant_new_logicaldefault (val), expr);
5428 #if FFETARGET_okREAL2
5429 case FFEINFO_kindtypeREAL2:
5430 error = ffetarget_gt_real2 (&val,
5431 ffebld_constant_real2 (ffebld_conter (l)),
5432 ffebld_constant_real2 (ffebld_conter (r)));
5433 expr = ffebld_new_conter_with_orig
5434 (ffebld_constant_new_logicaldefault (val), expr);
5438 #if FFETARGET_okREAL3
5439 case FFEINFO_kindtypeREAL3:
5440 error = ffetarget_gt_real3 (&val,
5441 ffebld_constant_real3 (ffebld_conter (l)),
5442 ffebld_constant_real3 (ffebld_conter (r)));
5443 expr = ffebld_new_conter_with_orig
5444 (ffebld_constant_new_logicaldefault (val), expr);
5448 #if FFETARGET_okREAL4
5449 case FFEINFO_kindtypeREAL4:
5450 error = ffetarget_gt_real4 (&val,
5451 ffebld_constant_real4 (ffebld_conter (l)),
5452 ffebld_constant_real4 (ffebld_conter (r)));
5453 expr = ffebld_new_conter_with_orig
5454 (ffebld_constant_new_logicaldefault (val), expr);
5459 assert ("bad real kind type" == NULL);
5464 case FFEINFO_basictypeCHARACTER:
5465 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5467 #if FFETARGET_okCHARACTER1
5468 case FFEINFO_kindtypeCHARACTER1:
5469 error = ffetarget_gt_character1 (&val,
5470 ffebld_constant_character1 (ffebld_conter (l)),
5471 ffebld_constant_character1 (ffebld_conter (r)));
5472 expr = ffebld_new_conter_with_orig
5473 (ffebld_constant_new_logicaldefault (val), expr);
5477 #if FFETARGET_okCHARACTER2
5478 case FFEINFO_kindtypeCHARACTER2:
5479 error = ffetarget_gt_character2 (&val,
5480 ffebld_constant_character2 (ffebld_conter (l)),
5481 ffebld_constant_character2 (ffebld_conter (r)));
5482 expr = ffebld_new_conter_with_orig
5483 (ffebld_constant_new_logicaldefault (val), expr);
5487 #if FFETARGET_okCHARACTER3
5488 case FFEINFO_kindtypeCHARACTER3:
5489 error = ffetarget_gt_character3 (&val,
5490 ffebld_constant_character3 (ffebld_conter (l)),
5491 ffebld_constant_character3 (ffebld_conter (r)));
5492 expr = ffebld_new_conter_with_orig
5493 (ffebld_constant_new_logicaldefault (val), expr);
5497 #if FFETARGET_okCHARACTER4
5498 case FFEINFO_kindtypeCHARACTER4:
5499 error = ffetarget_gt_character4 (&val,
5500 ffebld_constant_character4 (ffebld_conter (l)),
5501 ffebld_constant_character4 (ffebld_conter (r)));
5502 expr = ffebld_new_conter_with_orig
5503 (ffebld_constant_new_logicaldefault (val), expr);
5508 assert ("bad character kind type" == NULL);
5514 assert ("bad type" == NULL);
5518 ffebld_set_info (expr, ffeinfo_new
5519 (FFEINFO_basictypeLOGICAL,
5520 FFEINFO_kindtypeLOGICALDEFAULT,
5523 FFEINFO_whereCONSTANT,
5524 FFETARGET_charactersizeNONE));
5526 if ((error != FFEBAD)
5527 && ffebad_start (error))
5529 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5536 /* ffeexpr_collapse_le -- Collapse le expr
5540 expr = ffeexpr_collapse_le(expr,token);
5542 If the result of the expr is a constant, replaces the expr with the
5543 computed constant. */
5546 ffeexpr_collapse_le (ffebld expr, ffelexToken t)
5548 ffebad error = FFEBAD;
5553 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5556 l = ffebld_left (expr);
5557 r = ffebld_right (expr);
5559 if (ffebld_op (l) != FFEBLD_opCONTER)
5561 if (ffebld_op (r) != FFEBLD_opCONTER)
5564 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5566 case FFEINFO_basictypeANY:
5569 case FFEINFO_basictypeINTEGER:
5570 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5572 #if FFETARGET_okINTEGER1
5573 case FFEINFO_kindtypeINTEGER1:
5574 error = ffetarget_le_integer1 (&val,
5575 ffebld_constant_integer1 (ffebld_conter (l)),
5576 ffebld_constant_integer1 (ffebld_conter (r)));
5577 expr = ffebld_new_conter_with_orig
5578 (ffebld_constant_new_logicaldefault (val), expr);
5582 #if FFETARGET_okINTEGER2
5583 case FFEINFO_kindtypeINTEGER2:
5584 error = ffetarget_le_integer2 (&val,
5585 ffebld_constant_integer2 (ffebld_conter (l)),
5586 ffebld_constant_integer2 (ffebld_conter (r)));
5587 expr = ffebld_new_conter_with_orig
5588 (ffebld_constant_new_logicaldefault (val), expr);
5592 #if FFETARGET_okINTEGER3
5593 case FFEINFO_kindtypeINTEGER3:
5594 error = ffetarget_le_integer3 (&val,
5595 ffebld_constant_integer3 (ffebld_conter (l)),
5596 ffebld_constant_integer3 (ffebld_conter (r)));
5597 expr = ffebld_new_conter_with_orig
5598 (ffebld_constant_new_logicaldefault (val), expr);
5602 #if FFETARGET_okINTEGER4
5603 case FFEINFO_kindtypeINTEGER4:
5604 error = ffetarget_le_integer4 (&val,
5605 ffebld_constant_integer4 (ffebld_conter (l)),
5606 ffebld_constant_integer4 (ffebld_conter (r)));
5607 expr = ffebld_new_conter_with_orig
5608 (ffebld_constant_new_logicaldefault (val), expr);
5613 assert ("bad integer kind type" == NULL);
5618 case FFEINFO_basictypeREAL:
5619 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5621 #if FFETARGET_okREAL1
5622 case FFEINFO_kindtypeREAL1:
5623 error = ffetarget_le_real1 (&val,
5624 ffebld_constant_real1 (ffebld_conter (l)),
5625 ffebld_constant_real1 (ffebld_conter (r)));
5626 expr = ffebld_new_conter_with_orig
5627 (ffebld_constant_new_logicaldefault (val), expr);
5631 #if FFETARGET_okREAL2
5632 case FFEINFO_kindtypeREAL2:
5633 error = ffetarget_le_real2 (&val,
5634 ffebld_constant_real2 (ffebld_conter (l)),
5635 ffebld_constant_real2 (ffebld_conter (r)));
5636 expr = ffebld_new_conter_with_orig
5637 (ffebld_constant_new_logicaldefault (val), expr);
5641 #if FFETARGET_okREAL3
5642 case FFEINFO_kindtypeREAL3:
5643 error = ffetarget_le_real3 (&val,
5644 ffebld_constant_real3 (ffebld_conter (l)),
5645 ffebld_constant_real3 (ffebld_conter (r)));
5646 expr = ffebld_new_conter_with_orig
5647 (ffebld_constant_new_logicaldefault (val), expr);
5651 #if FFETARGET_okREAL4
5652 case FFEINFO_kindtypeREAL4:
5653 error = ffetarget_le_real4 (&val,
5654 ffebld_constant_real4 (ffebld_conter (l)),
5655 ffebld_constant_real4 (ffebld_conter (r)));
5656 expr = ffebld_new_conter_with_orig
5657 (ffebld_constant_new_logicaldefault (val), expr);
5662 assert ("bad real kind type" == NULL);
5667 case FFEINFO_basictypeCHARACTER:
5668 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5670 #if FFETARGET_okCHARACTER1
5671 case FFEINFO_kindtypeCHARACTER1:
5672 error = ffetarget_le_character1 (&val,
5673 ffebld_constant_character1 (ffebld_conter (l)),
5674 ffebld_constant_character1 (ffebld_conter (r)));
5675 expr = ffebld_new_conter_with_orig
5676 (ffebld_constant_new_logicaldefault (val), expr);
5680 #if FFETARGET_okCHARACTER2
5681 case FFEINFO_kindtypeCHARACTER2:
5682 error = ffetarget_le_character2 (&val,
5683 ffebld_constant_character2 (ffebld_conter (l)),
5684 ffebld_constant_character2 (ffebld_conter (r)));
5685 expr = ffebld_new_conter_with_orig
5686 (ffebld_constant_new_logicaldefault (val), expr);
5690 #if FFETARGET_okCHARACTER3
5691 case FFEINFO_kindtypeCHARACTER3:
5692 error = ffetarget_le_character3 (&val,
5693 ffebld_constant_character3 (ffebld_conter (l)),
5694 ffebld_constant_character3 (ffebld_conter (r)));
5695 expr = ffebld_new_conter_with_orig
5696 (ffebld_constant_new_logicaldefault (val), expr);
5700 #if FFETARGET_okCHARACTER4
5701 case FFEINFO_kindtypeCHARACTER4:
5702 error = ffetarget_le_character4 (&val,
5703 ffebld_constant_character4 (ffebld_conter (l)),
5704 ffebld_constant_character4 (ffebld_conter (r)));
5705 expr = ffebld_new_conter_with_orig
5706 (ffebld_constant_new_logicaldefault (val), expr);
5711 assert ("bad character kind type" == NULL);
5717 assert ("bad type" == NULL);
5721 ffebld_set_info (expr, ffeinfo_new
5722 (FFEINFO_basictypeLOGICAL,
5723 FFEINFO_kindtypeLOGICALDEFAULT,
5726 FFEINFO_whereCONSTANT,
5727 FFETARGET_charactersizeNONE));
5729 if ((error != FFEBAD)
5730 && ffebad_start (error))
5732 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5739 /* ffeexpr_collapse_lt -- Collapse lt expr
5743 expr = ffeexpr_collapse_lt(expr,token);
5745 If the result of the expr is a constant, replaces the expr with the
5746 computed constant. */
5749 ffeexpr_collapse_lt (ffebld expr, ffelexToken t)
5751 ffebad error = FFEBAD;
5756 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5759 l = ffebld_left (expr);
5760 r = ffebld_right (expr);
5762 if (ffebld_op (l) != FFEBLD_opCONTER)
5764 if (ffebld_op (r) != FFEBLD_opCONTER)
5767 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
5769 case FFEINFO_basictypeANY:
5772 case FFEINFO_basictypeINTEGER:
5773 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5775 #if FFETARGET_okINTEGER1
5776 case FFEINFO_kindtypeINTEGER1:
5777 error = ffetarget_lt_integer1 (&val,
5778 ffebld_constant_integer1 (ffebld_conter (l)),
5779 ffebld_constant_integer1 (ffebld_conter (r)));
5780 expr = ffebld_new_conter_with_orig
5781 (ffebld_constant_new_logicaldefault (val), expr);
5785 #if FFETARGET_okINTEGER2
5786 case FFEINFO_kindtypeINTEGER2:
5787 error = ffetarget_lt_integer2 (&val,
5788 ffebld_constant_integer2 (ffebld_conter (l)),
5789 ffebld_constant_integer2 (ffebld_conter (r)));
5790 expr = ffebld_new_conter_with_orig
5791 (ffebld_constant_new_logicaldefault (val), expr);
5795 #if FFETARGET_okINTEGER3
5796 case FFEINFO_kindtypeINTEGER3:
5797 error = ffetarget_lt_integer3 (&val,
5798 ffebld_constant_integer3 (ffebld_conter (l)),
5799 ffebld_constant_integer3 (ffebld_conter (r)));
5800 expr = ffebld_new_conter_with_orig
5801 (ffebld_constant_new_logicaldefault (val), expr);
5805 #if FFETARGET_okINTEGER4
5806 case FFEINFO_kindtypeINTEGER4:
5807 error = ffetarget_lt_integer4 (&val,
5808 ffebld_constant_integer4 (ffebld_conter (l)),
5809 ffebld_constant_integer4 (ffebld_conter (r)));
5810 expr = ffebld_new_conter_with_orig
5811 (ffebld_constant_new_logicaldefault (val), expr);
5816 assert ("bad integer kind type" == NULL);
5821 case FFEINFO_basictypeREAL:
5822 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5824 #if FFETARGET_okREAL1
5825 case FFEINFO_kindtypeREAL1:
5826 error = ffetarget_lt_real1 (&val,
5827 ffebld_constant_real1 (ffebld_conter (l)),
5828 ffebld_constant_real1 (ffebld_conter (r)));
5829 expr = ffebld_new_conter_with_orig
5830 (ffebld_constant_new_logicaldefault (val), expr);
5834 #if FFETARGET_okREAL2
5835 case FFEINFO_kindtypeREAL2:
5836 error = ffetarget_lt_real2 (&val,
5837 ffebld_constant_real2 (ffebld_conter (l)),
5838 ffebld_constant_real2 (ffebld_conter (r)));
5839 expr = ffebld_new_conter_with_orig
5840 (ffebld_constant_new_logicaldefault (val), expr);
5844 #if FFETARGET_okREAL3
5845 case FFEINFO_kindtypeREAL3:
5846 error = ffetarget_lt_real3 (&val,
5847 ffebld_constant_real3 (ffebld_conter (l)),
5848 ffebld_constant_real3 (ffebld_conter (r)));
5849 expr = ffebld_new_conter_with_orig
5850 (ffebld_constant_new_logicaldefault (val), expr);
5854 #if FFETARGET_okREAL4
5855 case FFEINFO_kindtypeREAL4:
5856 error = ffetarget_lt_real4 (&val,
5857 ffebld_constant_real4 (ffebld_conter (l)),
5858 ffebld_constant_real4 (ffebld_conter (r)));
5859 expr = ffebld_new_conter_with_orig
5860 (ffebld_constant_new_logicaldefault (val), expr);
5865 assert ("bad real kind type" == NULL);
5870 case FFEINFO_basictypeCHARACTER:
5871 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
5873 #if FFETARGET_okCHARACTER1
5874 case FFEINFO_kindtypeCHARACTER1:
5875 error = ffetarget_lt_character1 (&val,
5876 ffebld_constant_character1 (ffebld_conter (l)),
5877 ffebld_constant_character1 (ffebld_conter (r)));
5878 expr = ffebld_new_conter_with_orig
5879 (ffebld_constant_new_logicaldefault (val), expr);
5883 #if FFETARGET_okCHARACTER2
5884 case FFEINFO_kindtypeCHARACTER2:
5885 error = ffetarget_lt_character2 (&val,
5886 ffebld_constant_character2 (ffebld_conter (l)),
5887 ffebld_constant_character2 (ffebld_conter (r)));
5888 expr = ffebld_new_conter_with_orig
5889 (ffebld_constant_new_logicaldefault (val), expr);
5893 #if FFETARGET_okCHARACTER3
5894 case FFEINFO_kindtypeCHARACTER3:
5895 error = ffetarget_lt_character3 (&val,
5896 ffebld_constant_character3 (ffebld_conter (l)),
5897 ffebld_constant_character3 (ffebld_conter (r)));
5898 expr = ffebld_new_conter_with_orig
5899 (ffebld_constant_new_logicaldefault (val), expr);
5903 #if FFETARGET_okCHARACTER4
5904 case FFEINFO_kindtypeCHARACTER4:
5905 error = ffetarget_lt_character4 (&val,
5906 ffebld_constant_character4 (ffebld_conter (l)),
5907 ffebld_constant_character4 (ffebld_conter (r)));
5908 expr = ffebld_new_conter_with_orig
5909 (ffebld_constant_new_logicaldefault (val), expr);
5914 assert ("bad character kind type" == NULL);
5920 assert ("bad type" == NULL);
5924 ffebld_set_info (expr, ffeinfo_new
5925 (FFEINFO_basictypeLOGICAL,
5926 FFEINFO_kindtypeLOGICALDEFAULT,
5929 FFEINFO_whereCONSTANT,
5930 FFETARGET_charactersizeNONE));
5932 if ((error != FFEBAD)
5933 && ffebad_start (error))
5935 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
5942 /* ffeexpr_collapse_and -- Collapse and expr
5946 expr = ffeexpr_collapse_and(expr,token);
5948 If the result of the expr is a constant, replaces the expr with the
5949 computed constant. */
5952 ffeexpr_collapse_and (ffebld expr, ffelexToken t)
5954 ffebad error = FFEBAD;
5957 ffebldConstantUnion u;
5958 ffeinfoBasictype bt;
5961 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
5964 l = ffebld_left (expr);
5965 r = ffebld_right (expr);
5967 if (ffebld_op (l) != FFEBLD_opCONTER)
5969 if (ffebld_op (r) != FFEBLD_opCONTER)
5972 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
5974 case FFEINFO_basictypeANY:
5977 case FFEINFO_basictypeINTEGER:
5978 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
5980 #if FFETARGET_okINTEGER1
5981 case FFEINFO_kindtypeINTEGER1:
5982 error = ffetarget_and_integer1 (ffebld_cu_ptr_integer1 (u),
5983 ffebld_constant_integer1 (ffebld_conter (l)),
5984 ffebld_constant_integer1 (ffebld_conter (r)));
5985 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5986 (ffebld_cu_val_integer1 (u)), expr);
5990 #if FFETARGET_okINTEGER2
5991 case FFEINFO_kindtypeINTEGER2:
5992 error = ffetarget_and_integer2 (ffebld_cu_ptr_integer2 (u),
5993 ffebld_constant_integer2 (ffebld_conter (l)),
5994 ffebld_constant_integer2 (ffebld_conter (r)));
5995 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5996 (ffebld_cu_val_integer2 (u)), expr);
6000 #if FFETARGET_okINTEGER3
6001 case FFEINFO_kindtypeINTEGER3:
6002 error = ffetarget_and_integer3 (ffebld_cu_ptr_integer3 (u),
6003 ffebld_constant_integer3 (ffebld_conter (l)),
6004 ffebld_constant_integer3 (ffebld_conter (r)));
6005 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6006 (ffebld_cu_val_integer3 (u)), expr);
6010 #if FFETARGET_okINTEGER4
6011 case FFEINFO_kindtypeINTEGER4:
6012 error = ffetarget_and_integer4 (ffebld_cu_ptr_integer4 (u),
6013 ffebld_constant_integer4 (ffebld_conter (l)),
6014 ffebld_constant_integer4 (ffebld_conter (r)));
6015 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6016 (ffebld_cu_val_integer4 (u)), expr);
6021 assert ("bad integer kind type" == NULL);
6026 case FFEINFO_basictypeLOGICAL:
6027 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6029 #if FFETARGET_okLOGICAL1
6030 case FFEINFO_kindtypeLOGICAL1:
6031 error = ffetarget_and_logical1 (ffebld_cu_ptr_logical1 (u),
6032 ffebld_constant_logical1 (ffebld_conter (l)),
6033 ffebld_constant_logical1 (ffebld_conter (r)));
6034 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6035 (ffebld_cu_val_logical1 (u)), expr);
6039 #if FFETARGET_okLOGICAL2
6040 case FFEINFO_kindtypeLOGICAL2:
6041 error = ffetarget_and_logical2 (ffebld_cu_ptr_logical2 (u),
6042 ffebld_constant_logical2 (ffebld_conter (l)),
6043 ffebld_constant_logical2 (ffebld_conter (r)));
6044 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6045 (ffebld_cu_val_logical2 (u)), expr);
6049 #if FFETARGET_okLOGICAL3
6050 case FFEINFO_kindtypeLOGICAL3:
6051 error = ffetarget_and_logical3 (ffebld_cu_ptr_logical3 (u),
6052 ffebld_constant_logical3 (ffebld_conter (l)),
6053 ffebld_constant_logical3 (ffebld_conter (r)));
6054 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6055 (ffebld_cu_val_logical3 (u)), expr);
6059 #if FFETARGET_okLOGICAL4
6060 case FFEINFO_kindtypeLOGICAL4:
6061 error = ffetarget_and_logical4 (ffebld_cu_ptr_logical4 (u),
6062 ffebld_constant_logical4 (ffebld_conter (l)),
6063 ffebld_constant_logical4 (ffebld_conter (r)));
6064 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6065 (ffebld_cu_val_logical4 (u)), expr);
6070 assert ("bad logical kind type" == NULL);
6076 assert ("bad type" == NULL);
6080 ffebld_set_info (expr, ffeinfo_new
6085 FFEINFO_whereCONSTANT,
6086 FFETARGET_charactersizeNONE));
6088 if ((error != FFEBAD)
6089 && ffebad_start (error))
6091 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6098 /* ffeexpr_collapse_or -- Collapse or expr
6102 expr = ffeexpr_collapse_or(expr,token);
6104 If the result of the expr is a constant, replaces the expr with the
6105 computed constant. */
6108 ffeexpr_collapse_or (ffebld expr, ffelexToken t)
6110 ffebad error = FFEBAD;
6113 ffebldConstantUnion u;
6114 ffeinfoBasictype bt;
6117 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6120 l = ffebld_left (expr);
6121 r = ffebld_right (expr);
6123 if (ffebld_op (l) != FFEBLD_opCONTER)
6125 if (ffebld_op (r) != FFEBLD_opCONTER)
6128 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6130 case FFEINFO_basictypeANY:
6133 case FFEINFO_basictypeINTEGER:
6134 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6136 #if FFETARGET_okINTEGER1
6137 case FFEINFO_kindtypeINTEGER1:
6138 error = ffetarget_or_integer1 (ffebld_cu_ptr_integer1 (u),
6139 ffebld_constant_integer1 (ffebld_conter (l)),
6140 ffebld_constant_integer1 (ffebld_conter (r)));
6141 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6142 (ffebld_cu_val_integer1 (u)), expr);
6146 #if FFETARGET_okINTEGER2
6147 case FFEINFO_kindtypeINTEGER2:
6148 error = ffetarget_or_integer2 (ffebld_cu_ptr_integer2 (u),
6149 ffebld_constant_integer2 (ffebld_conter (l)),
6150 ffebld_constant_integer2 (ffebld_conter (r)));
6151 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6152 (ffebld_cu_val_integer2 (u)), expr);
6156 #if FFETARGET_okINTEGER3
6157 case FFEINFO_kindtypeINTEGER3:
6158 error = ffetarget_or_integer3 (ffebld_cu_ptr_integer3 (u),
6159 ffebld_constant_integer3 (ffebld_conter (l)),
6160 ffebld_constant_integer3 (ffebld_conter (r)));
6161 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6162 (ffebld_cu_val_integer3 (u)), expr);
6166 #if FFETARGET_okINTEGER4
6167 case FFEINFO_kindtypeINTEGER4:
6168 error = ffetarget_or_integer4 (ffebld_cu_ptr_integer4 (u),
6169 ffebld_constant_integer4 (ffebld_conter (l)),
6170 ffebld_constant_integer4 (ffebld_conter (r)));
6171 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6172 (ffebld_cu_val_integer4 (u)), expr);
6177 assert ("bad integer kind type" == NULL);
6182 case FFEINFO_basictypeLOGICAL:
6183 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6185 #if FFETARGET_okLOGICAL1
6186 case FFEINFO_kindtypeLOGICAL1:
6187 error = ffetarget_or_logical1 (ffebld_cu_ptr_logical1 (u),
6188 ffebld_constant_logical1 (ffebld_conter (l)),
6189 ffebld_constant_logical1 (ffebld_conter (r)));
6190 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6191 (ffebld_cu_val_logical1 (u)), expr);
6195 #if FFETARGET_okLOGICAL2
6196 case FFEINFO_kindtypeLOGICAL2:
6197 error = ffetarget_or_logical2 (ffebld_cu_ptr_logical2 (u),
6198 ffebld_constant_logical2 (ffebld_conter (l)),
6199 ffebld_constant_logical2 (ffebld_conter (r)));
6200 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6201 (ffebld_cu_val_logical2 (u)), expr);
6205 #if FFETARGET_okLOGICAL3
6206 case FFEINFO_kindtypeLOGICAL3:
6207 error = ffetarget_or_logical3 (ffebld_cu_ptr_logical3 (u),
6208 ffebld_constant_logical3 (ffebld_conter (l)),
6209 ffebld_constant_logical3 (ffebld_conter (r)));
6210 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6211 (ffebld_cu_val_logical3 (u)), expr);
6215 #if FFETARGET_okLOGICAL4
6216 case FFEINFO_kindtypeLOGICAL4:
6217 error = ffetarget_or_logical4 (ffebld_cu_ptr_logical4 (u),
6218 ffebld_constant_logical4 (ffebld_conter (l)),
6219 ffebld_constant_logical4 (ffebld_conter (r)));
6220 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6221 (ffebld_cu_val_logical4 (u)), expr);
6226 assert ("bad logical kind type" == NULL);
6232 assert ("bad type" == NULL);
6236 ffebld_set_info (expr, ffeinfo_new
6241 FFEINFO_whereCONSTANT,
6242 FFETARGET_charactersizeNONE));
6244 if ((error != FFEBAD)
6245 && ffebad_start (error))
6247 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6254 /* ffeexpr_collapse_xor -- Collapse xor expr
6258 expr = ffeexpr_collapse_xor(expr,token);
6260 If the result of the expr is a constant, replaces the expr with the
6261 computed constant. */
6264 ffeexpr_collapse_xor (ffebld expr, ffelexToken t)
6266 ffebad error = FFEBAD;
6269 ffebldConstantUnion u;
6270 ffeinfoBasictype bt;
6273 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6276 l = ffebld_left (expr);
6277 r = ffebld_right (expr);
6279 if (ffebld_op (l) != FFEBLD_opCONTER)
6281 if (ffebld_op (r) != FFEBLD_opCONTER)
6284 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6286 case FFEINFO_basictypeANY:
6289 case FFEINFO_basictypeINTEGER:
6290 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6292 #if FFETARGET_okINTEGER1
6293 case FFEINFO_kindtypeINTEGER1:
6294 error = ffetarget_xor_integer1 (ffebld_cu_ptr_integer1 (u),
6295 ffebld_constant_integer1 (ffebld_conter (l)),
6296 ffebld_constant_integer1 (ffebld_conter (r)));
6297 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6298 (ffebld_cu_val_integer1 (u)), expr);
6302 #if FFETARGET_okINTEGER2
6303 case FFEINFO_kindtypeINTEGER2:
6304 error = ffetarget_xor_integer2 (ffebld_cu_ptr_integer2 (u),
6305 ffebld_constant_integer2 (ffebld_conter (l)),
6306 ffebld_constant_integer2 (ffebld_conter (r)));
6307 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6308 (ffebld_cu_val_integer2 (u)), expr);
6312 #if FFETARGET_okINTEGER3
6313 case FFEINFO_kindtypeINTEGER3:
6314 error = ffetarget_xor_integer3 (ffebld_cu_ptr_integer3 (u),
6315 ffebld_constant_integer3 (ffebld_conter (l)),
6316 ffebld_constant_integer3 (ffebld_conter (r)));
6317 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6318 (ffebld_cu_val_integer3 (u)), expr);
6322 #if FFETARGET_okINTEGER4
6323 case FFEINFO_kindtypeINTEGER4:
6324 error = ffetarget_xor_integer4 (ffebld_cu_ptr_integer4 (u),
6325 ffebld_constant_integer4 (ffebld_conter (l)),
6326 ffebld_constant_integer4 (ffebld_conter (r)));
6327 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6328 (ffebld_cu_val_integer4 (u)), expr);
6333 assert ("bad integer kind type" == NULL);
6338 case FFEINFO_basictypeLOGICAL:
6339 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6341 #if FFETARGET_okLOGICAL1
6342 case FFEINFO_kindtypeLOGICAL1:
6343 error = ffetarget_xor_logical1 (ffebld_cu_ptr_logical1 (u),
6344 ffebld_constant_logical1 (ffebld_conter (l)),
6345 ffebld_constant_logical1 (ffebld_conter (r)));
6346 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6347 (ffebld_cu_val_logical1 (u)), expr);
6351 #if FFETARGET_okLOGICAL2
6352 case FFEINFO_kindtypeLOGICAL2:
6353 error = ffetarget_xor_logical2 (ffebld_cu_ptr_logical2 (u),
6354 ffebld_constant_logical2 (ffebld_conter (l)),
6355 ffebld_constant_logical2 (ffebld_conter (r)));
6356 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6357 (ffebld_cu_val_logical2 (u)), expr);
6361 #if FFETARGET_okLOGICAL3
6362 case FFEINFO_kindtypeLOGICAL3:
6363 error = ffetarget_xor_logical3 (ffebld_cu_ptr_logical3 (u),
6364 ffebld_constant_logical3 (ffebld_conter (l)),
6365 ffebld_constant_logical3 (ffebld_conter (r)));
6366 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6367 (ffebld_cu_val_logical3 (u)), expr);
6371 #if FFETARGET_okLOGICAL4
6372 case FFEINFO_kindtypeLOGICAL4:
6373 error = ffetarget_xor_logical4 (ffebld_cu_ptr_logical4 (u),
6374 ffebld_constant_logical4 (ffebld_conter (l)),
6375 ffebld_constant_logical4 (ffebld_conter (r)));
6376 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6377 (ffebld_cu_val_logical4 (u)), expr);
6382 assert ("bad logical kind type" == NULL);
6388 assert ("bad type" == NULL);
6392 ffebld_set_info (expr, ffeinfo_new
6397 FFEINFO_whereCONSTANT,
6398 FFETARGET_charactersizeNONE));
6400 if ((error != FFEBAD)
6401 && ffebad_start (error))
6403 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6410 /* ffeexpr_collapse_eqv -- Collapse eqv expr
6414 expr = ffeexpr_collapse_eqv(expr,token);
6416 If the result of the expr is a constant, replaces the expr with the
6417 computed constant. */
6420 ffeexpr_collapse_eqv (ffebld expr, ffelexToken t)
6422 ffebad error = FFEBAD;
6425 ffebldConstantUnion u;
6426 ffeinfoBasictype bt;
6429 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6432 l = ffebld_left (expr);
6433 r = ffebld_right (expr);
6435 if (ffebld_op (l) != FFEBLD_opCONTER)
6437 if (ffebld_op (r) != FFEBLD_opCONTER)
6440 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6442 case FFEINFO_basictypeANY:
6445 case FFEINFO_basictypeINTEGER:
6446 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6448 #if FFETARGET_okINTEGER1
6449 case FFEINFO_kindtypeINTEGER1:
6450 error = ffetarget_eqv_integer1 (ffebld_cu_ptr_integer1 (u),
6451 ffebld_constant_integer1 (ffebld_conter (l)),
6452 ffebld_constant_integer1 (ffebld_conter (r)));
6453 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6454 (ffebld_cu_val_integer1 (u)), expr);
6458 #if FFETARGET_okINTEGER2
6459 case FFEINFO_kindtypeINTEGER2:
6460 error = ffetarget_eqv_integer2 (ffebld_cu_ptr_integer2 (u),
6461 ffebld_constant_integer2 (ffebld_conter (l)),
6462 ffebld_constant_integer2 (ffebld_conter (r)));
6463 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6464 (ffebld_cu_val_integer2 (u)), expr);
6468 #if FFETARGET_okINTEGER3
6469 case FFEINFO_kindtypeINTEGER3:
6470 error = ffetarget_eqv_integer3 (ffebld_cu_ptr_integer3 (u),
6471 ffebld_constant_integer3 (ffebld_conter (l)),
6472 ffebld_constant_integer3 (ffebld_conter (r)));
6473 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6474 (ffebld_cu_val_integer3 (u)), expr);
6478 #if FFETARGET_okINTEGER4
6479 case FFEINFO_kindtypeINTEGER4:
6480 error = ffetarget_eqv_integer4 (ffebld_cu_ptr_integer4 (u),
6481 ffebld_constant_integer4 (ffebld_conter (l)),
6482 ffebld_constant_integer4 (ffebld_conter (r)));
6483 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6484 (ffebld_cu_val_integer4 (u)), expr);
6489 assert ("bad integer kind type" == NULL);
6494 case FFEINFO_basictypeLOGICAL:
6495 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6497 #if FFETARGET_okLOGICAL1
6498 case FFEINFO_kindtypeLOGICAL1:
6499 error = ffetarget_eqv_logical1 (ffebld_cu_ptr_logical1 (u),
6500 ffebld_constant_logical1 (ffebld_conter (l)),
6501 ffebld_constant_logical1 (ffebld_conter (r)));
6502 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6503 (ffebld_cu_val_logical1 (u)), expr);
6507 #if FFETARGET_okLOGICAL2
6508 case FFEINFO_kindtypeLOGICAL2:
6509 error = ffetarget_eqv_logical2 (ffebld_cu_ptr_logical2 (u),
6510 ffebld_constant_logical2 (ffebld_conter (l)),
6511 ffebld_constant_logical2 (ffebld_conter (r)));
6512 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6513 (ffebld_cu_val_logical2 (u)), expr);
6517 #if FFETARGET_okLOGICAL3
6518 case FFEINFO_kindtypeLOGICAL3:
6519 error = ffetarget_eqv_logical3 (ffebld_cu_ptr_logical3 (u),
6520 ffebld_constant_logical3 (ffebld_conter (l)),
6521 ffebld_constant_logical3 (ffebld_conter (r)));
6522 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6523 (ffebld_cu_val_logical3 (u)), expr);
6527 #if FFETARGET_okLOGICAL4
6528 case FFEINFO_kindtypeLOGICAL4:
6529 error = ffetarget_eqv_logical4 (ffebld_cu_ptr_logical4 (u),
6530 ffebld_constant_logical4 (ffebld_conter (l)),
6531 ffebld_constant_logical4 (ffebld_conter (r)));
6532 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6533 (ffebld_cu_val_logical4 (u)), expr);
6538 assert ("bad logical kind type" == NULL);
6544 assert ("bad type" == NULL);
6548 ffebld_set_info (expr, ffeinfo_new
6553 FFEINFO_whereCONSTANT,
6554 FFETARGET_charactersizeNONE));
6556 if ((error != FFEBAD)
6557 && ffebad_start (error))
6559 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6566 /* ffeexpr_collapse_neqv -- Collapse neqv expr
6570 expr = ffeexpr_collapse_neqv(expr,token);
6572 If the result of the expr is a constant, replaces the expr with the
6573 computed constant. */
6576 ffeexpr_collapse_neqv (ffebld expr, ffelexToken t)
6578 ffebad error = FFEBAD;
6581 ffebldConstantUnion u;
6582 ffeinfoBasictype bt;
6585 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6588 l = ffebld_left (expr);
6589 r = ffebld_right (expr);
6591 if (ffebld_op (l) != FFEBLD_opCONTER)
6593 if (ffebld_op (r) != FFEBLD_opCONTER)
6596 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
6598 case FFEINFO_basictypeANY:
6601 case FFEINFO_basictypeINTEGER:
6602 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6604 #if FFETARGET_okINTEGER1
6605 case FFEINFO_kindtypeINTEGER1:
6606 error = ffetarget_neqv_integer1 (ffebld_cu_ptr_integer1 (u),
6607 ffebld_constant_integer1 (ffebld_conter (l)),
6608 ffebld_constant_integer1 (ffebld_conter (r)));
6609 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
6610 (ffebld_cu_val_integer1 (u)), expr);
6614 #if FFETARGET_okINTEGER2
6615 case FFEINFO_kindtypeINTEGER2:
6616 error = ffetarget_neqv_integer2 (ffebld_cu_ptr_integer2 (u),
6617 ffebld_constant_integer2 (ffebld_conter (l)),
6618 ffebld_constant_integer2 (ffebld_conter (r)));
6619 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
6620 (ffebld_cu_val_integer2 (u)), expr);
6624 #if FFETARGET_okINTEGER3
6625 case FFEINFO_kindtypeINTEGER3:
6626 error = ffetarget_neqv_integer3 (ffebld_cu_ptr_integer3 (u),
6627 ffebld_constant_integer3 (ffebld_conter (l)),
6628 ffebld_constant_integer3 (ffebld_conter (r)));
6629 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
6630 (ffebld_cu_val_integer3 (u)), expr);
6634 #if FFETARGET_okINTEGER4
6635 case FFEINFO_kindtypeINTEGER4:
6636 error = ffetarget_neqv_integer4 (ffebld_cu_ptr_integer4 (u),
6637 ffebld_constant_integer4 (ffebld_conter (l)),
6638 ffebld_constant_integer4 (ffebld_conter (r)));
6639 expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
6640 (ffebld_cu_val_integer4 (u)), expr);
6645 assert ("bad integer kind type" == NULL);
6650 case FFEINFO_basictypeLOGICAL:
6651 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6653 #if FFETARGET_okLOGICAL1
6654 case FFEINFO_kindtypeLOGICAL1:
6655 error = ffetarget_neqv_logical1 (ffebld_cu_ptr_logical1 (u),
6656 ffebld_constant_logical1 (ffebld_conter (l)),
6657 ffebld_constant_logical1 (ffebld_conter (r)));
6658 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
6659 (ffebld_cu_val_logical1 (u)), expr);
6663 #if FFETARGET_okLOGICAL2
6664 case FFEINFO_kindtypeLOGICAL2:
6665 error = ffetarget_neqv_logical2 (ffebld_cu_ptr_logical2 (u),
6666 ffebld_constant_logical2 (ffebld_conter (l)),
6667 ffebld_constant_logical2 (ffebld_conter (r)));
6668 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
6669 (ffebld_cu_val_logical2 (u)), expr);
6673 #if FFETARGET_okLOGICAL3
6674 case FFEINFO_kindtypeLOGICAL3:
6675 error = ffetarget_neqv_logical3 (ffebld_cu_ptr_logical3 (u),
6676 ffebld_constant_logical3 (ffebld_conter (l)),
6677 ffebld_constant_logical3 (ffebld_conter (r)));
6678 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
6679 (ffebld_cu_val_logical3 (u)), expr);
6683 #if FFETARGET_okLOGICAL4
6684 case FFEINFO_kindtypeLOGICAL4:
6685 error = ffetarget_neqv_logical4 (ffebld_cu_ptr_logical4 (u),
6686 ffebld_constant_logical4 (ffebld_conter (l)),
6687 ffebld_constant_logical4 (ffebld_conter (r)));
6688 expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
6689 (ffebld_cu_val_logical4 (u)), expr);
6694 assert ("bad logical kind type" == NULL);
6700 assert ("bad type" == NULL);
6704 ffebld_set_info (expr, ffeinfo_new
6709 FFEINFO_whereCONSTANT,
6710 FFETARGET_charactersizeNONE));
6712 if ((error != FFEBAD)
6713 && ffebad_start (error))
6715 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6722 /* ffeexpr_collapse_symter -- Collapse symter expr
6726 expr = ffeexpr_collapse_symter(expr,token);
6728 If the result of the expr is a constant, replaces the expr with the
6729 computed constant. */
6732 ffeexpr_collapse_symter (ffebld expr, ffelexToken t UNUSED)
6735 ffeinfoBasictype bt;
6737 ffetargetCharacterSize len;
6739 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6742 if ((r = ffesymbol_init (ffebld_symter (expr))) == NULL)
6743 return expr; /* A PARAMETER lhs in progress. */
6745 switch (ffebld_op (r))
6747 case FFEBLD_opCONTER:
6757 bt = ffeinfo_basictype (ffebld_info (r));
6758 kt = ffeinfo_kindtype (ffebld_info (r));
6759 len = ffebld_size (r);
6761 expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
6764 ffebld_set_info (expr, ffeinfo_new
6769 FFEINFO_whereCONSTANT,
6775 /* ffeexpr_collapse_funcref -- Collapse funcref expr
6779 expr = ffeexpr_collapse_funcref(expr,token);
6781 If the result of the expr is a constant, replaces the expr with the
6782 computed constant. */
6785 ffeexpr_collapse_funcref (ffebld expr, ffelexToken t UNUSED)
6787 return expr; /* ~~someday go ahead and collapse these,
6788 though not required */
6791 /* ffeexpr_collapse_arrayref -- Collapse arrayref expr
6795 expr = ffeexpr_collapse_arrayref(expr,token);
6797 If the result of the expr is a constant, replaces the expr with the
6798 computed constant. */
6801 ffeexpr_collapse_arrayref (ffebld expr, ffelexToken t UNUSED)
6806 /* ffeexpr_collapse_substr -- Collapse substr expr
6810 expr = ffeexpr_collapse_substr(expr,token);
6812 If the result of the expr is a constant, replaces the expr with the
6813 computed constant. */
6816 ffeexpr_collapse_substr (ffebld expr, ffelexToken t)
6818 ffebad error = FFEBAD;
6823 ffebldConstantUnion u;
6825 ffetargetCharacterSize len;
6826 ffetargetIntegerDefault first;
6827 ffetargetIntegerDefault last;
6829 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
6832 l = ffebld_left (expr);
6833 r = ffebld_right (expr); /* opITEM. */
6835 if (ffebld_op (l) != FFEBLD_opCONTER)
6838 kt = ffeinfo_kindtype (ffebld_info (l));
6839 len = ffebld_size (l);
6841 start = ffebld_head (r);
6842 stop = ffebld_head (ffebld_trail (r));
6847 if ((ffebld_op (start) != FFEBLD_opCONTER)
6848 || (ffeinfo_basictype (ffebld_info (start)) != FFEINFO_basictypeINTEGER)
6849 || (ffeinfo_kindtype (ffebld_info (start))
6850 != FFEINFO_kindtypeINTEGERDEFAULT))
6852 first = ffebld_constant_integerdefault (ffebld_conter (start));
6858 if ((ffebld_op (stop) != FFEBLD_opCONTER)
6859 || (ffeinfo_basictype (ffebld_info (stop)) != FFEINFO_basictypeINTEGER)
6860 || (ffeinfo_kindtype (ffebld_info (stop))
6861 != FFEINFO_kindtypeINTEGERDEFAULT))
6863 last = ffebld_constant_integerdefault (ffebld_conter (stop));
6866 /* Handle problems that should have already been diagnosed, but
6867 left in the expression tree. */
6872 last = first + len - 1;
6874 if ((first == 1) && (last == len))
6875 { /* Same as original. */
6876 expr = ffebld_new_conter_with_orig (ffebld_constant_copy
6877 (ffebld_conter (l)), expr);
6878 ffebld_set_info (expr, ffeinfo_new
6879 (FFEINFO_basictypeCHARACTER,
6883 FFEINFO_whereCONSTANT,
6889 switch (ffeinfo_basictype (ffebld_info (expr)))
6891 case FFEINFO_basictypeANY:
6894 case FFEINFO_basictypeCHARACTER:
6895 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
6897 #if FFETARGET_okCHARACTER1
6898 case FFEINFO_kindtypeCHARACTER1:
6899 error = ffetarget_substr_character1 (ffebld_cu_ptr_character1 (u),
6900 ffebld_constant_character1 (ffebld_conter (l)), first, last,
6901 ffebld_constant_pool (), &len);
6902 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
6903 (ffebld_cu_val_character1 (u)), expr);
6907 #if FFETARGET_okCHARACTER2
6908 case FFEINFO_kindtypeCHARACTER2:
6909 error = ffetarget_substr_character2 (ffebld_cu_ptr_character2 (u),
6910 ffebld_constant_character2 (ffebld_conter (l)), first, last,
6911 ffebld_constant_pool (), &len);
6912 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val
6913 (ffebld_cu_val_character2 (u)), expr);
6917 #if FFETARGET_okCHARACTER3
6918 case FFEINFO_kindtypeCHARACTER3:
6919 error = ffetarget_substr_character3 (ffebld_cu_ptr_character3 (u),
6920 ffebld_constant_character3 (ffebld_conter (l)), first, last,
6921 ffebld_constant_pool (), &len);
6922 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val
6923 (ffebld_cu_val_character3 (u)), expr);
6927 #if FFETARGET_okCHARACTER4
6928 case FFEINFO_kindtypeCHARACTER4:
6929 error = ffetarget_substr_character4 (ffebld_cu_ptr_character4 (u),
6930 ffebld_constant_character4 (ffebld_conter (l)), first, last,
6931 ffebld_constant_pool (), &len);
6932 expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val
6933 (ffebld_cu_val_character4 (u)), expr);
6938 assert ("bad character kind type" == NULL);
6944 assert ("bad type" == NULL);
6948 ffebld_set_info (expr, ffeinfo_new
6949 (FFEINFO_basictypeCHARACTER,
6953 FFEINFO_whereCONSTANT,
6956 if ((error != FFEBAD)
6957 && ffebad_start (error))
6959 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
6966 /* ffeexpr_convert -- Convert source expression to given type
6969 ffelexToken source_token;
6970 ffelexToken dest_token; // Any appropriate token for "destination".
6971 ffeinfoBasictype bt;
6973 ffetargetCharactersize sz;
6974 ffeexprContext context; // Mainly LET or DATA.
6975 source = ffeexpr_convert(source,source_token,dest_token,bt,kt,sz,context);
6977 If the expression conforms, returns the source expression. Otherwise
6978 returns source wrapped in a convert node doing the conversion, or
6979 ANY wrapped in convert if there is a conversion error (and issues an
6980 error message). Be sensitive to the context for certain aspects of
6984 ffeexpr_convert (ffebld source, ffelexToken source_token, ffelexToken dest_token,
6985 ffeinfoBasictype bt, ffeinfoKindtype kt, ffeinfoRank rk,
6986 ffetargetCharacterSize sz, ffeexprContext context)
6992 info = ffebld_info (source);
6993 if ((bt != ffeinfo_basictype (info))
6994 || (kt != ffeinfo_kindtype (info))
6995 || (rk != 0) /* Can't convert from or to arrays yet. */
6996 || (ffeinfo_rank (info) != 0)
6997 || (sz != ffebld_size_known (source)))
6998 #if 0 /* Nobody seems to need this spurious CONVERT node. */
6999 || ((context != FFEEXPR_contextLET)
7000 && (bt == FFEINFO_basictypeCHARACTER)
7001 && (sz == FFETARGET_charactersizeNONE)))
7004 switch (ffeinfo_basictype (info))
7006 case FFEINFO_basictypeLOGICAL:
7009 case FFEINFO_basictypeLOGICAL:
7013 case FFEINFO_basictypeINTEGER:
7014 bad = !ffe_is_ugly_logint ();
7017 case FFEINFO_basictypeCHARACTER:
7018 bad = ffe_is_pedantic ()
7019 || !(ffe_is_ugly_init ()
7020 && (context == FFEEXPR_contextDATA));
7029 case FFEINFO_basictypeINTEGER:
7032 case FFEINFO_basictypeINTEGER:
7033 case FFEINFO_basictypeREAL:
7034 case FFEINFO_basictypeCOMPLEX:
7038 case FFEINFO_basictypeLOGICAL:
7039 bad = !ffe_is_ugly_logint ();
7042 case FFEINFO_basictypeCHARACTER:
7043 bad = ffe_is_pedantic ()
7044 || !(ffe_is_ugly_init ()
7045 && (context == FFEEXPR_contextDATA));
7054 case FFEINFO_basictypeREAL:
7055 case FFEINFO_basictypeCOMPLEX:
7058 case FFEINFO_basictypeINTEGER:
7059 case FFEINFO_basictypeREAL:
7060 case FFEINFO_basictypeCOMPLEX:
7064 case FFEINFO_basictypeCHARACTER:
7074 case FFEINFO_basictypeCHARACTER:
7075 bad = (bt != FFEINFO_basictypeCHARACTER)
7076 && (ffe_is_pedantic ()
7077 || (bt != FFEINFO_basictypeINTEGER)
7078 || !(ffe_is_ugly_init ()
7079 && (context == FFEEXPR_contextDATA)));
7082 case FFEINFO_basictypeTYPELESS:
7083 case FFEINFO_basictypeHOLLERITH:
7084 bad = ffe_is_pedantic ()
7085 || !(ffe_is_ugly_init ()
7086 && ((context == FFEEXPR_contextDATA)
7087 || (context == FFEEXPR_contextLET)));
7095 if (!bad && ((rk != 0) || (ffeinfo_rank (info) != 0)))
7098 if (bad && (bt != FFEINFO_basictypeANY) && (kt != FFEINFO_kindtypeANY)
7099 && (ffeinfo_basictype (info) != FFEINFO_basictypeANY)
7100 && (ffeinfo_kindtype (info) != FFEINFO_kindtypeANY)
7101 && (ffeinfo_where (info) != FFEINFO_whereANY))
7103 if (ffebad_start (FFEBAD_BAD_TYPES))
7105 if (dest_token == NULL)
7106 ffebad_here (0, ffewhere_line_unknown (),
7107 ffewhere_column_unknown ());
7109 ffebad_here (0, ffelex_token_where_line (dest_token),
7110 ffelex_token_where_column (dest_token));
7111 assert (source_token != NULL);
7112 ffebad_here (1, ffelex_token_where_line (source_token),
7113 ffelex_token_where_column (source_token));
7117 source = ffebld_new_any ();
7118 ffebld_set_info (source, ffeinfo_new_any ());
7122 switch (ffeinfo_where (info))
7124 case FFEINFO_whereCONSTANT:
7125 wh = FFEINFO_whereCONSTANT;
7128 case FFEINFO_whereIMMEDIATE:
7129 wh = FFEINFO_whereIMMEDIATE;
7133 wh = FFEINFO_whereFLEETING;
7136 source = ffebld_new_convert (source);
7137 ffebld_set_info (source, ffeinfo_new
7144 source = ffeexpr_collapse_convert (source, source_token);
7151 /* ffeexpr_convert_expr -- Convert source expr to conform to dest expr
7155 ffelexToken source_token;
7156 ffelexToken dest_token;
7157 ffeexprContext context;
7158 source = ffeexpr_convert_expr(source,source_token,dest,dest_token,context);
7160 If the expressions conform, returns the source expression. Otherwise
7161 returns source wrapped in a convert node doing the conversion, or
7162 ANY wrapped in convert if there is a conversion error (and issues an
7163 error message). Be sensitive to the context, such as LET or DATA. */
7166 ffeexpr_convert_expr (ffebld source, ffelexToken source_token, ffebld dest,
7167 ffelexToken dest_token, ffeexprContext context)
7171 info = ffebld_info (dest);
7172 return ffeexpr_convert (source, source_token, dest_token,
7173 ffeinfo_basictype (info),
7174 ffeinfo_kindtype (info),
7175 ffeinfo_rank (info),
7176 ffebld_size_known (dest),
7180 /* ffeexpr_convert_to_sym -- Convert source expression to conform to symbol
7184 ffelexToken source_token;
7185 ffelexToken dest_token;
7186 source = ffeexpr_convert_to_sym(source,source_token,dest,dest_token);
7188 If the expressions conform, returns the source expression. Otherwise
7189 returns source wrapped in a convert node doing the conversion, or
7190 ANY wrapped in convert if there is a conversion error (and issues an
7194 ffeexpr_convert_to_sym (ffebld source, ffelexToken source_token,
7195 ffesymbol dest, ffelexToken dest_token)
7197 return ffeexpr_convert (source, source_token, dest_token, ffesymbol_basictype (dest),
7198 ffesymbol_kindtype (dest), ffesymbol_rank (dest), ffesymbol_size (dest),
7199 FFEEXPR_contextLET);
7202 /* Initializes the module. */
7207 ffeexpr_stack_ = NULL;
7211 /* ffeexpr_lhs -- Begin processing left-hand-side-context expression
7213 Prepares cluster for delivery of lexer tokens representing an expression
7214 in a left-hand-side context (A in A=B, for example). ffebld is used
7215 to build expressions in the given pool. The appropriate lexer-token
7216 handling routine within ffeexpr is returned. When the end of the
7217 expression is detected, mycallbackroutine is called with the resulting
7218 single ffebld object specifying the entire expression and the first
7219 lexer token that is not considered part of the expression. This caller-
7220 supplied routine itself returns a lexer-token handling routine. Thus,
7221 if necessary, ffeexpr can return several tokens as end-of-expression
7222 tokens if it needs to scan forward more than one in any instance. */
7225 ffeexpr_lhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
7229 ffebld_pool_push (pool);
7230 s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
7231 s->previous = ffeexpr_stack_;
7233 s->context = context;
7234 s->callback = callback;
7235 s->first_token = NULL;
7236 s->exprstack = NULL;
7239 return (ffelexHandler) ffeexpr_token_first_lhs_;
7242 /* ffeexpr_rhs -- Begin processing right-hand-side-context expression
7244 return ffeexpr_rhs(malloc_pool_image(),mycallbackroutine); // to lexer.
7246 Prepares cluster for delivery of lexer tokens representing an expression
7247 in a right-hand-side context (B in A=B, for example). ffebld is used
7248 to build expressions in the given pool. The appropriate lexer-token
7249 handling routine within ffeexpr is returned. When the end of the
7250 expression is detected, mycallbackroutine is called with the resulting
7251 single ffebld object specifying the entire expression and the first
7252 lexer token that is not considered part of the expression. This caller-
7253 supplied routine itself returns a lexer-token handling routine. Thus,
7254 if necessary, ffeexpr can return several tokens as end-of-expression
7255 tokens if it needs to scan forward more than one in any instance. */
7258 ffeexpr_rhs (mallocPool pool, ffeexprContext context, ffeexprCallback callback)
7262 ffebld_pool_push (pool);
7263 s = malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s));
7264 s->previous = ffeexpr_stack_;
7266 s->context = context;
7267 s->callback = callback;
7268 s->first_token = NULL;
7269 s->exprstack = NULL;
7272 return (ffelexHandler) ffeexpr_token_first_rhs_;
7275 /* ffeexpr_cb_close_paren_ -- OPEN_PAREN expr
7277 Pass it to ffeexpr_rhs as the callback routine.
7279 Makes sure the end token is close-paren and swallows it, else issues
7280 an error message and doesn't swallow the token (passing it along instead).
7281 In either case wraps up subexpression construction by enclosing the
7282 ffebld expression in a paren. */
7284 static ffelexHandler
7285 ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr, ffelexToken t)
7289 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7291 /* Oops, naughty user didn't specify the close paren! */
7293 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7295 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7296 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7297 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7301 e = ffeexpr_expr_new_ ();
7302 e->type = FFEEXPR_exprtypeOPERAND_;
7303 e->u.operand = ffebld_new_any ();
7304 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
7305 ffeexpr_exprstack_push_operand_ (e);
7308 (ffelexHandler) ffeexpr_find_close_paren_ (t,
7310 ffeexpr_token_binary_);
7313 if (expr->op == FFEBLD_opIMPDO)
7315 if (ffest_ffebad_start (FFEBAD_IMPDO_PAREN))
7317 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7318 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7324 expr = ffebld_new_paren (expr);
7325 ffebld_set_info (expr, ffeinfo_use (ffebld_info (ffebld_left (expr))));
7328 /* Now push the (parenthesized) expression as an operand onto the
7329 expression stack. */
7331 e = ffeexpr_expr_new_ ();
7332 e->type = FFEEXPR_exprtypeOPERAND_;
7333 e->u.operand = expr;
7334 e->u.operand = ffeexpr_collapse_paren (e->u.operand, ft);
7335 e->token = ffeexpr_stack_->tokens[0];
7336 ffeexpr_exprstack_push_operand_ (e);
7338 return (ffelexHandler) ffeexpr_token_binary_;
7341 /* ffeexpr_cb_close_paren_ambig_ -- OPEN_PAREN expr
7343 Pass it to ffeexpr_rhs as the callback routine.
7345 We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
7346 with the next token in t. If the next token is possibly a binary
7347 operator, continue processing the outer expression. If the next
7348 token is COMMA, then the expression is a unit specifier, and
7349 parentheses should not be added to it because it surrounds the
7350 I/O control list that starts with the unit specifier (and continues
7351 on from here -- we haven't seen the CLOSE_PAREN that matches the
7352 OPEN_PAREN, it is up to the callback function to expect to see it
7353 at some point). In this case, we notify the callback function that
7354 the COMMA is inside, not outside, the parens by wrapping the expression
7355 in an opITEM (with a NULL trail) -- the callback function presumably
7356 unwraps it after seeing this kludgey indicator.
7358 If the next token is CLOSE_PAREN, then we go to the _1_ state to
7359 decide what to do with the token after that.
7362 Use an extra state for the CLOSE_PAREN case to make READ &co really
7365 static ffelexHandler
7366 ffeexpr_cb_close_paren_ambig_ (ffelexToken ft, ffebld expr, ffelexToken t)
7368 ffeexprCallback callback;
7371 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7372 { /* Need to see the next token before we
7374 ffeexpr_stack_->expr = expr;
7375 ffeexpr_tokens_[0] = ffelex_token_use (ft);
7376 ffeexpr_tokens_[1] = ffelex_token_use (t);
7377 return (ffelexHandler) ffeexpr_cb_close_paren_ambig_1_;
7380 expr = ffeexpr_finished_ambig_ (ft, expr);
7382 /* Let the callback function handle the case where t isn't COMMA. */
7384 /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
7385 that preceded the expression starts a list of expressions, and the expr
7386 hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
7387 node. The callback function should extract the real expr from the head
7388 of this opITEM node after testing it. */
7390 expr = ffebld_new_item (expr, NULL);
7393 callback = ffeexpr_stack_->callback;
7394 ffelex_token_kill (ffeexpr_stack_->first_token);
7395 s = ffeexpr_stack_->previous;
7396 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
7398 return (ffelexHandler) (*callback) (ft, expr, t);
7401 /* ffeexpr_cb_close_paren_ambig_1_ -- OPEN_PAREN expr CLOSE_PAREN
7403 See ffeexpr_cb_close_paren_ambig_.
7405 We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
7406 with the next token in t. If the next token is possibly a binary
7407 operator, continue processing the outer expression. If the next
7408 token is COMMA, the expression is a parenthesized format specifier.
7409 If the next token is not EOS or SEMICOLON, then because it is not a
7410 binary operator (it is NAME, OPEN_PAREN, &c), the expression is
7411 a unit specifier, and parentheses should not be added to it because
7412 they surround the I/O control list that consists of only the unit
7413 specifier. If the next token is EOS or SEMICOLON, the statement
7414 must be disambiguated by looking at the type of the expression -- a
7415 character expression is a parenthesized format specifier, while a
7416 non-character expression is a unit specifier.
7418 Another issue is how to do the callback so the recipient of the
7419 next token knows how to handle it if it is a COMMA. In all other
7420 cases, disambiguation is straightforward: the same approach as the
7423 EXTENSION: in COMMA case, if not pedantic, use same disambiguation
7424 as for EOS/SEMICOLON case; f2c allows "READ (cilist) [[,]iolist]"
7425 and apparently other compilers do, as well, and some code out there
7426 uses this "feature".
7429 Extend to allow COMMA as nondisambiguating by itself. Remember
7430 to not try and check info field for opSTAR, since that expr doesn't
7431 have a valid info field. */
7433 static ffelexHandler
7434 ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t)
7436 ffeexprCallback callback;
7439 ffelexToken orig_ft = ffeexpr_tokens_[0]; /* In case callback clobbers
7441 ffelexToken orig_t = ffeexpr_tokens_[1];
7442 ffebld expr = ffeexpr_stack_->expr;
7444 switch (ffelex_token_type (t))
7446 case FFELEX_typeCOMMA: /* Subexpr is parenthesized format specifier. */
7447 if (ffe_is_pedantic ())
7448 goto pedantic_comma; /* :::::::::::::::::::: */
7450 case FFELEX_typeEOS: /* Ambiguous; use type of expr to
7452 case FFELEX_typeSEMICOLON:
7453 if ((expr == NULL) || (ffebld_op (expr) == FFEBLD_opANY)
7454 || (ffebld_op (expr) == FFEBLD_opSTAR)
7455 || (ffeinfo_basictype (ffebld_info (expr))
7456 != FFEINFO_basictypeCHARACTER))
7457 break; /* Not a valid CHARACTER entity, can't be a
7460 default: /* Binary op (we assume; error otherwise);
7461 format specifier. */
7463 pedantic_comma: /* :::::::::::::::::::: */
7465 switch (ffeexpr_stack_->context)
7467 case FFEEXPR_contextFILENUMAMBIG:
7468 ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
7471 case FFEEXPR_contextFILEUNITAMBIG:
7472 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
7476 assert ("bad context" == NULL);
7480 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
7481 next = (ffelexHandler) ffeexpr_cb_close_paren_ (orig_ft, expr, orig_t);
7482 ffelex_token_kill (orig_ft);
7483 ffelex_token_kill (orig_t);
7484 return (ffelexHandler) (*next) (t);
7486 case FFELEX_typeOPEN_PAREN:/* Non-binary op; beginning of I/O list. */
7487 case FFELEX_typeNAME:
7491 expr = ffeexpr_finished_ambig_ (orig_ft, expr);
7493 /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
7494 that preceded the expression starts a list of expressions, and the expr
7495 hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
7496 node. The callback function should extract the real expr from the head
7497 of this opITEM node after testing it. */
7499 expr = ffebld_new_item (expr, NULL);
7502 callback = ffeexpr_stack_->callback;
7503 ffelex_token_kill (ffeexpr_stack_->first_token);
7504 s = ffeexpr_stack_->previous;
7505 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
7507 next = (ffelexHandler) (*callback) (orig_ft, expr, orig_t);
7508 ffelex_token_kill (orig_ft);
7509 ffelex_token_kill (orig_t);
7510 return (ffelexHandler) (*next) (t);
7513 /* ffeexpr_cb_close_paren_c_ -- OPEN_PAREN expr (possible complex)
7515 Pass it to ffeexpr_rhs as the callback routine.
7517 Makes sure the end token is close-paren and swallows it, or a comma
7518 and handles complex/implied-do possibilities, else issues
7519 an error message and doesn't swallow the token (passing it along instead). */
7521 static ffelexHandler
7522 ffeexpr_cb_close_paren_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
7524 /* First check to see if this is a possible complex entity. It is if the
7525 token is a comma. */
7527 if (ffelex_token_type (t) == FFELEX_typeCOMMA)
7529 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
7530 ffeexpr_stack_->expr = expr;
7531 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7532 FFEEXPR_contextPAREN_, ffeexpr_cb_comma_c_);
7535 return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
7538 /* ffeexpr_cb_comma_c_ -- OPEN_PAREN expr COMMA expr
7540 Pass it to ffeexpr_rhs as the callback routine.
7542 If this token is not a comma, we have a complex constant (or an attempt
7543 at one), so handle it accordingly, displaying error messages if the token
7544 is not a close-paren. */
7546 static ffelexHandler
7547 ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr, ffelexToken t)
7550 ffeinfoBasictype lty = (ffeexpr_stack_->expr == NULL)
7551 ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (ffeexpr_stack_->expr));
7552 ffeinfoBasictype rty = (expr == NULL)
7553 ? FFEINFO_basictypeNONE : ffeinfo_basictype (ffebld_info (expr));
7554 ffeinfoKindtype lkt;
7555 ffeinfoKindtype rkt;
7556 ffeinfoKindtype nkt;
7560 if ((ffeexpr_stack_->expr == NULL)
7561 || (ffebld_op (ffeexpr_stack_->expr) != FFEBLD_opCONTER)
7562 || (((orig = ffebld_conter_orig (ffeexpr_stack_->expr)) != NULL)
7563 && (((ffebld_op (orig) != FFEBLD_opUMINUS)
7564 && (ffebld_op (orig) != FFEBLD_opUPLUS))
7565 || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
7566 || ((lty != FFEINFO_basictypeINTEGER)
7567 && (lty != FFEINFO_basictypeREAL)))
7569 if ((lty != FFEINFO_basictypeANY)
7570 && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
7572 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
7573 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
7574 ffebad_string ("Real");
7580 || (ffebld_op (expr) != FFEBLD_opCONTER)
7581 || (((orig = ffebld_conter_orig (expr)) != NULL)
7582 && (((ffebld_op (orig) != FFEBLD_opUMINUS)
7583 && (ffebld_op (orig) != FFEBLD_opUPLUS))
7584 || (ffebld_conter_orig (ffebld_left (orig)) != NULL)))
7585 || ((rty != FFEINFO_basictypeINTEGER)
7586 && (rty != FFEINFO_basictypeREAL)))
7588 if ((rty != FFEINFO_basictypeANY)
7589 && ffebad_start (FFEBAD_INVALID_COMPLEX_PART))
7591 ffebad_here (0, ffelex_token_where_line (ft),
7592 ffelex_token_where_column (ft));
7593 ffebad_string ("Imaginary");
7599 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
7601 /* Push the (parenthesized) expression as an operand onto the expression
7604 e = ffeexpr_expr_new_ ();
7605 e->type = FFEEXPR_exprtypeOPERAND_;
7606 e->token = ffeexpr_stack_->tokens[0];
7610 if (lty == FFEINFO_basictypeINTEGER)
7611 lkt = FFEINFO_kindtypeREALDEFAULT;
7613 lkt = ffeinfo_kindtype (ffebld_info (ffeexpr_stack_->expr));
7614 if (rty == FFEINFO_basictypeINTEGER)
7615 rkt = FFEINFO_kindtypeREALDEFAULT;
7617 rkt = ffeinfo_kindtype (ffebld_info (expr));
7619 nkt = ffeinfo_kindtype_max (FFEINFO_basictypeCOMPLEX, lkt, rkt);
7620 ffeexpr_stack_->expr = ffeexpr_convert (ffeexpr_stack_->expr,
7621 ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
7622 FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
7623 FFEEXPR_contextLET);
7624 expr = ffeexpr_convert (expr,
7625 ffeexpr_stack_->tokens[1], ffeexpr_stack_->tokens[0],
7626 FFEINFO_basictypeREAL, nkt, 0, FFETARGET_charactersizeNONE,
7627 FFEEXPR_contextLET);
7630 nkt = FFEINFO_kindtypeANY;
7634 #if FFETARGET_okCOMPLEX1
7635 case FFEINFO_kindtypeREAL1:
7636 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex1
7637 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7638 ffebld_set_info (e->u.operand,
7639 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7640 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7641 FFETARGET_charactersizeNONE));
7645 #if FFETARGET_okCOMPLEX2
7646 case FFEINFO_kindtypeREAL2:
7647 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex2
7648 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7649 ffebld_set_info (e->u.operand,
7650 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7651 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7652 FFETARGET_charactersizeNONE));
7656 #if FFETARGET_okCOMPLEX3
7657 case FFEINFO_kindtypeREAL3:
7658 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex3
7659 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7660 ffebld_set_info (e->u.operand,
7661 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7662 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7663 FFETARGET_charactersizeNONE));
7667 #if FFETARGET_okCOMPLEX4
7668 case FFEINFO_kindtypeREAL4:
7669 e->u.operand = ffebld_new_conter (ffebld_constant_new_complex4
7670 (ffebld_conter (ffeexpr_stack_->expr), ffebld_conter (expr)));
7671 ffebld_set_info (e->u.operand,
7672 ffeinfo_new (FFEINFO_basictypeCOMPLEX, nkt, 0,
7673 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
7674 FFETARGET_charactersizeNONE));
7679 if (ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
7680 ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX))
7682 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7683 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7687 case FFEINFO_kindtypeANY:
7688 e->u.operand = ffebld_new_any ();
7689 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
7692 ffeexpr_exprstack_push_operand_ (e);
7694 /* Now, if the token is a close parenthese, we're in great shape so return
7695 the next handler. */
7697 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
7698 return (ffelexHandler) ffeexpr_token_binary_;
7700 /* Oops, naughty user didn't specify the close paren! */
7702 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
7704 ffebad_here (0, ffelex_token_where_line (t),
7705 ffelex_token_where_column (t));
7706 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
7707 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
7712 (ffelexHandler) ffeexpr_find_close_paren_ (t,
7714 ffeexpr_token_binary_);
7717 /* ffeexpr_cb_close_paren_ci_ -- OPEN_PAREN expr (possible complex or
7718 implied-DO construct)
7720 Pass it to ffeexpr_rhs as the callback routine.
7722 Makes sure the end token is close-paren and swallows it, or a comma
7723 and handles complex/implied-do possibilities, else issues
7724 an error message and doesn't swallow the token (passing it along instead). */
7726 static ffelexHandler
7727 ffeexpr_cb_close_paren_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
7731 /* First check to see if this is a possible complex or implied-DO entity.
7732 It is if the token is a comma. */
7734 if (ffelex_token_type (t) == FFELEX_typeCOMMA)
7736 switch (ffeexpr_stack_->context)
7738 case FFEEXPR_contextIOLIST:
7739 case FFEEXPR_contextIMPDOITEM_:
7740 ctx = FFEEXPR_contextIMPDOITEM_;
7743 case FFEEXPR_contextIOLISTDF:
7744 case FFEEXPR_contextIMPDOITEMDF_:
7745 ctx = FFEEXPR_contextIMPDOITEMDF_;
7749 assert ("bad context" == NULL);
7750 ctx = FFEEXPR_contextIMPDOITEM_;
7754 ffeexpr_stack_->tokens[0] = ffelex_token_use (ft);
7755 ffeexpr_stack_->expr = expr;
7756 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7757 ctx, ffeexpr_cb_comma_ci_);
7760 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
7761 return (ffelexHandler) ffeexpr_cb_close_paren_ (ft, expr, t);
7764 /* ffeexpr_cb_comma_ci_ -- OPEN_PAREN expr COMMA expr
7766 Pass it to ffeexpr_rhs as the callback routine.
7768 If this token is not a comma, we have a complex constant (or an attempt
7769 at one), so handle it accordingly, displaying error messages if the token
7770 is not a close-paren. If we have a comma here, it is an attempt at an
7771 implied-DO, so start making a list accordingly. Oh, it might be an
7772 equal sign also, meaning an implied-DO with only one item in its list. */
7774 static ffelexHandler
7775 ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr, ffelexToken t)
7779 /* First check to see if this is a possible complex constant. It is if the
7780 token is not a comma or an equals sign, in which case it should be a
7783 if ((ffelex_token_type (t) != FFELEX_typeCOMMA)
7784 && (ffelex_token_type (t) != FFELEX_typeEQUALS))
7786 ffeexpr_stack_->tokens[1] = ffeexpr_stack_->tokens[0];
7787 ffeexpr_stack_->tokens[0] = ffelex_token_use (ffeexpr_stack_->first_token);
7788 return (ffelexHandler) ffeexpr_cb_comma_c_ (ft, expr, t);
7791 /* Here we have either EQUALS or COMMA, meaning we are in an implied-DO
7792 construct. Make a list and handle accordingly. */
7794 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
7795 fexpr = ffeexpr_stack_->expr;
7796 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
7797 ffebld_append_item (&ffeexpr_stack_->bottom, fexpr);
7798 return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
7801 /* ffeexpr_cb_comma_i_ -- OPEN_PAREN expr
7803 Pass it to ffeexpr_rhs as the callback routine.
7805 Handle first item in an implied-DO construct. */
7807 static ffelexHandler
7808 ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr, ffelexToken t)
7810 if (ffelex_token_type (t) != FFELEX_typeCOMMA)
7812 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7814 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7815 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7816 ffelex_token_where_column (ffeexpr_stack_->first_token));
7819 ffebld_end_list (&ffeexpr_stack_->bottom);
7820 ffeexpr_stack_->expr = ffebld_new_any ();
7821 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7822 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7823 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7824 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7827 return (ffelexHandler) ffeexpr_cb_comma_i_1_ (ft, expr, t);
7830 /* ffeexpr_cb_comma_i_1_ -- OPEN_PAREN expr
7832 Pass it to ffeexpr_rhs as the callback routine.
7834 Handle first item in an implied-DO construct. */
7836 static ffelexHandler
7837 ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr, ffelexToken t)
7839 ffeexprContext ctxi;
7840 ffeexprContext ctxc;
7842 switch (ffeexpr_stack_->context)
7844 case FFEEXPR_contextDATA:
7845 case FFEEXPR_contextDATAIMPDOITEM_:
7846 ctxi = FFEEXPR_contextDATAIMPDOITEM_;
7847 ctxc = FFEEXPR_contextDATAIMPDOCTRL_;
7850 case FFEEXPR_contextIOLIST:
7851 case FFEEXPR_contextIMPDOITEM_:
7852 ctxi = FFEEXPR_contextIMPDOITEM_;
7853 ctxc = FFEEXPR_contextIMPDOCTRL_;
7856 case FFEEXPR_contextIOLISTDF:
7857 case FFEEXPR_contextIMPDOITEMDF_:
7858 ctxi = FFEEXPR_contextIMPDOITEMDF_;
7859 ctxc = FFEEXPR_contextIMPDOCTRL_;
7863 assert ("bad context" == NULL);
7864 ctxi = FFEEXPR_context;
7865 ctxc = FFEEXPR_context;
7869 switch (ffelex_token_type (t))
7871 case FFELEX_typeCOMMA:
7872 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7873 if (ffeexpr_stack_->is_rhs)
7874 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7875 ctxi, ffeexpr_cb_comma_i_1_);
7876 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
7877 ctxi, ffeexpr_cb_comma_i_1_);
7879 case FFELEX_typeEQUALS:
7880 ffebld_end_list (&ffeexpr_stack_->bottom);
7882 /* Complain if implied-DO variable in list of items to be read. */
7884 if ((ctxc == FFEEXPR_contextIMPDOCTRL_) && !ffeexpr_stack_->is_rhs)
7885 ffeexpr_check_impdo_ (ffeexpr_stack_->expr,
7886 ffeexpr_stack_->first_token, expr, ft);
7888 /* Set doiter flag for all appropriate SYMTERs. */
7890 ffeexpr_update_impdo_ (ffeexpr_stack_->expr, expr);
7892 ffeexpr_stack_->expr = ffebld_new_impdo (ffeexpr_stack_->expr, NULL);
7893 ffebld_set_info (ffeexpr_stack_->expr,
7894 ffeinfo_new (FFEINFO_basictypeNONE,
7895 FFEINFO_kindtypeNONE,
7899 FFETARGET_charactersizeNONE));
7900 ffebld_init_list (&(ffebld_right (ffeexpr_stack_->expr)),
7901 &ffeexpr_stack_->bottom);
7902 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7903 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7904 ctxc, ffeexpr_cb_comma_i_2_);
7907 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7909 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7910 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7911 ffelex_token_where_column (ffeexpr_stack_->first_token));
7914 ffebld_end_list (&ffeexpr_stack_->bottom);
7915 ffeexpr_stack_->expr = ffebld_new_any ();
7916 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7917 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7918 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7919 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7923 /* ffeexpr_cb_comma_i_2_ -- OPEN_PAREN expr-list EQUALS expr
7925 Pass it to ffeexpr_rhs as the callback routine.
7927 Handle start-value in an implied-DO construct. */
7929 static ffelexHandler
7930 ffeexpr_cb_comma_i_2_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7934 switch (ffeexpr_stack_->context)
7936 case FFEEXPR_contextDATA:
7937 case FFEEXPR_contextDATAIMPDOITEM_:
7938 ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7941 case FFEEXPR_contextIOLIST:
7942 case FFEEXPR_contextIOLISTDF:
7943 case FFEEXPR_contextIMPDOITEM_:
7944 case FFEEXPR_contextIMPDOITEMDF_:
7945 ctx = FFEEXPR_contextIMPDOCTRL_;
7949 assert ("bad context" == NULL);
7950 ctx = FFEEXPR_context;
7954 switch (ffelex_token_type (t))
7956 case FFELEX_typeCOMMA:
7957 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
7958 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
7959 ctx, ffeexpr_cb_comma_i_3_);
7963 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
7965 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
7966 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
7967 ffelex_token_where_column (ffeexpr_stack_->first_token));
7970 ffebld_end_list (&ffeexpr_stack_->bottom);
7971 ffeexpr_stack_->expr = ffebld_new_any ();
7972 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
7973 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
7974 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
7975 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
7979 /* ffeexpr_cb_comma_i_3_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7981 Pass it to ffeexpr_rhs as the callback routine.
7983 Handle end-value in an implied-DO construct. */
7985 static ffelexHandler
7986 ffeexpr_cb_comma_i_3_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
7990 switch (ffeexpr_stack_->context)
7992 case FFEEXPR_contextDATA:
7993 case FFEEXPR_contextDATAIMPDOITEM_:
7994 ctx = FFEEXPR_contextDATAIMPDOCTRL_;
7997 case FFEEXPR_contextIOLIST:
7998 case FFEEXPR_contextIOLISTDF:
7999 case FFEEXPR_contextIMPDOITEM_:
8000 case FFEEXPR_contextIMPDOITEMDF_:
8001 ctx = FFEEXPR_contextIMPDOCTRL_;
8005 assert ("bad context" == NULL);
8006 ctx = FFEEXPR_context;
8010 switch (ffelex_token_type (t))
8012 case FFELEX_typeCOMMA:
8013 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
8014 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8015 ctx, ffeexpr_cb_comma_i_4_);
8018 case FFELEX_typeCLOSE_PAREN:
8019 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
8020 return (ffelexHandler) ffeexpr_cb_comma_i_4_ (NULL, NULL, t);
8024 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
8026 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8027 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
8028 ffelex_token_where_column (ffeexpr_stack_->first_token));
8031 ffebld_end_list (&ffeexpr_stack_->bottom);
8032 ffeexpr_stack_->expr = ffebld_new_any ();
8033 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
8034 if (ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
8035 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
8036 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
8040 /* ffeexpr_cb_comma_i_4_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
8043 Pass it to ffeexpr_rhs as the callback routine.
8045 Handle incr-value in an implied-DO construct. */
8047 static ffelexHandler
8048 ffeexpr_cb_comma_i_4_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
8050 switch (ffelex_token_type (t))
8052 case FFELEX_typeCLOSE_PAREN:
8053 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
8054 ffebld_end_list (&ffeexpr_stack_->bottom);
8058 for (item = ffebld_left (ffeexpr_stack_->expr);
8060 item = ffebld_trail (item))
8061 if (ffebld_op (ffebld_head (item)) == FFEBLD_opANY)
8062 goto replace_with_any; /* :::::::::::::::::::: */
8064 for (item = ffebld_right (ffeexpr_stack_->expr);
8066 item = ffebld_trail (item))
8067 if ((ffebld_head (item) != NULL) /* Increment may be NULL. */
8068 && (ffebld_op (ffebld_head (item)) == FFEBLD_opANY))
8069 goto replace_with_any; /* :::::::::::::::::::: */
8074 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO))
8076 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8077 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
8078 ffelex_token_where_column (ffeexpr_stack_->first_token));
8081 ffebld_end_list (&ffeexpr_stack_->bottom);
8083 replace_with_any: /* :::::::::::::::::::: */
8085 ffeexpr_stack_->expr = ffebld_new_any ();
8086 ffebld_set_info (ffeexpr_stack_->expr, ffeinfo_new_any ());
8090 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
8091 return (ffelexHandler) ffeexpr_cb_comma_i_5_;
8092 return (ffelexHandler) ffeexpr_cb_comma_i_5_ (t);
8095 /* ffeexpr_cb_comma_i_5_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
8096 [COMMA expr] CLOSE_PAREN
8098 Pass it to ffeexpr_rhs as the callback routine.
8100 Collects token following implied-DO construct for callback function. */
8102 static ffelexHandler
8103 ffeexpr_cb_comma_i_5_ (ffelexToken t)
8105 ffeexprCallback callback;
8112 switch (ffeexpr_stack_->context)
8114 case FFEEXPR_contextDATA:
8115 case FFEEXPR_contextDATAIMPDOITEM_:
8119 case FFEEXPR_contextIOLIST:
8120 case FFEEXPR_contextIOLISTDF:
8121 case FFEEXPR_contextIMPDOITEM_:
8122 case FFEEXPR_contextIMPDOITEMDF_:
8127 assert ("bad context" == NULL);
8133 callback = ffeexpr_stack_->callback;
8134 ft = ffeexpr_stack_->first_token;
8135 expr = ffeexpr_stack_->expr;
8136 s = ffeexpr_stack_->previous;
8137 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
8138 sizeof (*ffeexpr_stack_));
8140 next = (ffelexHandler) (*callback) (ft, expr, t);
8141 ffelex_token_kill (ft);
8144 ffesymbol_drive_sfnames (ffeexpr_check_impctrl_);
8146 if (ffeexpr_level_ == 0)
8149 return (ffelexHandler) next;
8152 /* ffeexpr_cb_end_loc_ -- Handle end of %LOC subexpression
8154 Makes sure the end token is close-paren and swallows it, else issues
8155 an error message and doesn't swallow the token (passing it along instead).
8156 In either case wraps up subexpression construction by enclosing the
8157 ffebld expression in a %LOC. */
8159 static ffelexHandler
8160 ffeexpr_cb_end_loc_ (ffelexToken ft UNUSED, ffebld expr, ffelexToken t)
8164 /* First push the (%LOC) expression as an operand onto the expression
8167 e = ffeexpr_expr_new_ ();
8168 e->type = FFEEXPR_exprtypeOPERAND_;
8169 e->token = ffeexpr_stack_->tokens[0];
8170 e->u.operand = ffebld_new_percent_loc (expr);
8171 ffebld_set_info (e->u.operand,
8172 ffeinfo_new (FFEINFO_basictypeINTEGER,
8173 ffecom_pointer_kind (),
8176 FFEINFO_whereFLEETING,
8177 FFETARGET_charactersizeNONE));
8179 e->u.operand = ffeexpr_collapse_percent_loc (e->u.operand, ft);
8181 ffeexpr_exprstack_push_operand_ (e);
8183 /* Now, if the token is a close parenthese, we're in great shape so return
8184 the next handler. */
8186 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
8188 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8189 return (ffelexHandler) ffeexpr_token_binary_;
8192 /* Oops, naughty user didn't specify the close paren! */
8194 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
8196 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8197 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
8198 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
8202 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8204 (ffelexHandler) ffeexpr_find_close_paren_ (t,
8206 ffeexpr_token_binary_);
8209 /* ffeexpr_cb_end_notloc_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
8211 Should be CLOSE_PAREN, and make sure expr isn't a %(VAL,REF,DESCR). */
8213 static ffelexHandler
8214 ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr, ffelexToken t)
8219 /* If expression is itself a %(VAL,REF,DESCR), complain and strip off all
8220 such things until the lowest-level expression is reached. */
8222 op = ffebld_op (expr);
8223 if ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
8224 || (op == FFEBLD_opPERCENT_DESCR))
8226 if (ffebad_start (FFEBAD_NESTED_PERCENT))
8228 ffebad_here (0, ffelex_token_where_line (ft),
8229 ffelex_token_where_column (ft));
8235 expr = ffebld_left (expr);
8236 op = ffebld_op (expr);
8238 while ((op == FFEBLD_opPERCENT_VAL) || (op == FFEBLD_opPERCENT_REF)
8239 || (op == FFEBLD_opPERCENT_DESCR));
8242 /* Push the expression as an operand onto the expression stack. */
8244 e = ffeexpr_expr_new_ ();
8245 e->type = FFEEXPR_exprtypeOPERAND_;
8246 e->token = ffeexpr_stack_->tokens[0];
8247 switch (ffeexpr_stack_->percent)
8249 case FFEEXPR_percentVAL_:
8250 e->u.operand = ffebld_new_percent_val (expr);
8253 case FFEEXPR_percentREF_:
8254 e->u.operand = ffebld_new_percent_ref (expr);
8257 case FFEEXPR_percentDESCR_:
8258 e->u.operand = ffebld_new_percent_descr (expr);
8262 assert ("%lossage" == NULL);
8263 e->u.operand = expr;
8266 ffebld_set_info (e->u.operand, ffebld_info (expr));
8268 e->u.operand = ffeexpr_collapse_percent_ ? ? ? (e->u.operand, ft);
8270 ffeexpr_exprstack_push_operand_ (e);
8272 /* Now, if the token is a close parenthese, we're in great shape so return
8273 the next handler. */
8275 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
8276 return (ffelexHandler) ffeexpr_cb_end_notloc_1_;
8278 /* Oops, naughty user didn't specify the close paren! */
8280 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN))
8282 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8283 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
8284 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
8288 ffebld_set_op (e->u.operand, FFEBLD_opPERCENT_LOC);
8290 switch (ffeexpr_stack_->context)
8292 case FFEEXPR_contextACTUALARG_:
8293 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8296 case FFEEXPR_contextINDEXORACTUALARG_:
8297 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8300 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8301 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8304 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8305 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8309 assert ("bad context?!?!" == NULL);
8313 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8315 (ffelexHandler) ffeexpr_find_close_paren_ (t,
8317 ffeexpr_cb_end_notloc_1_);
8320 /* ffeexpr_cb_end_notloc_1_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
8323 Should be COMMA or CLOSE_PAREN, else change back to %LOC. */
8325 static ffelexHandler
8326 ffeexpr_cb_end_notloc_1_ (ffelexToken t)
8328 switch (ffelex_token_type (t))
8330 case FFELEX_typeCOMMA:
8331 case FFELEX_typeCLOSE_PAREN:
8332 switch (ffeexpr_stack_->context)
8334 case FFEEXPR_contextACTUALARG_:
8335 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8338 case FFEEXPR_contextINDEXORACTUALARG_:
8339 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
8342 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8343 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
8347 assert ("bad context?!?!" == NULL);
8353 if (ffebad_start (FFEBAD_INVALID_PERCENT))
8356 ffelex_token_where_line (ffeexpr_stack_->first_token),
8357 ffelex_token_where_column (ffeexpr_stack_->first_token));
8358 ffebad_string (ffelex_token_text (ffeexpr_stack_->tokens[1]));
8362 ffebld_set_op (ffeexpr_stack_->exprstack->u.operand,
8363 FFEBLD_opPERCENT_LOC);
8365 switch (ffeexpr_stack_->context)
8367 case FFEEXPR_contextACTUALARG_:
8368 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8371 case FFEEXPR_contextINDEXORACTUALARG_:
8372 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8375 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8376 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8379 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8380 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8384 assert ("bad context?!?!" == NULL);
8389 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
8391 (ffelexHandler) ffeexpr_token_binary_ (t);
8394 /* Process DATA implied-DO iterator variables as this implied-DO level
8395 terminates. At this point, ffeexpr_level_ == 1 when we see the
8396 last right-paren in "DATA (A(I),I=1,10)/.../". */
8399 ffeexpr_check_impctrl_ (ffesymbol s)
8402 assert (ffesymbol_sfdummyparent (s) != NULL);
8404 switch (ffesymbol_state (s))
8406 case FFESYMBOL_stateNONE: /* Used as iterator already. Now let symbol
8407 be used as iterator at any level at or
8408 innermore than the outermost of the
8409 current level and the symbol's current
8411 if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
8413 ffesymbol_signal_change (s);
8414 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
8415 ffesymbol_signal_unreported (s);
8419 case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO.
8420 Error if at outermost level, else it can
8421 still become an iterator. */
8422 if ((ffeexpr_level_ == 1)
8423 && ffebad_start (FFEBAD_BAD_IMPDCL))
8425 ffebad_string (ffesymbol_text (s));
8426 ffebad_here (0, ffesymbol_where_line (s), ffesymbol_where_column (s));
8431 case FFESYMBOL_stateUNCERTAIN: /* Iterator. */
8432 assert (ffeexpr_level_ <= ffesymbol_maxentrynum (s));
8433 ffesymbol_signal_change (s);
8434 ffesymbol_set_state (s, FFESYMBOL_stateNONE);
8435 ffesymbol_signal_unreported (s);
8438 case FFESYMBOL_stateUNDERSTOOD:
8442 assert ("Sasha Foo!!" == NULL);
8449 /* Issue diagnostic if implied-DO variable appears in list of lhs
8450 expressions (as in "READ *, (I,I=1,10)"). */
8453 ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
8454 ffebld dovar, ffelexToken dovar_t)
8457 ffesymbol dovar_sym;
8460 if (ffebld_op (dovar) != FFEBLD_opSYMTER)
8461 return; /* Presumably opANY. */
8463 dovar_sym = ffebld_symter (dovar);
8465 for (itemnum = 1; list != NULL; list = ffebld_trail (list), ++itemnum)
8467 if (((item = ffebld_head (list)) != NULL)
8468 && (ffebld_op (item) == FFEBLD_opSYMTER)
8469 && (ffebld_symter (item) == dovar_sym))
8473 sprintf (&itemno[0], "%d", itemnum);
8474 if (ffebad_start (FFEBAD_DOITER_IMPDO))
8476 ffebad_here (0, ffelex_token_where_line (list_t),
8477 ffelex_token_where_column (list_t));
8478 ffebad_here (1, ffelex_token_where_line (dovar_t),
8479 ffelex_token_where_column (dovar_t));
8480 ffebad_string (ffesymbol_text (dovar_sym));
8481 ffebad_string (itemno);
8488 /* Decorate any SYMTERs referencing the DO variable with the "doiter"
8492 ffeexpr_update_impdo_ (ffebld list, ffebld dovar)
8494 ffesymbol dovar_sym;
8496 if (ffebld_op (dovar) != FFEBLD_opSYMTER)
8497 return; /* Presumably opANY. */
8499 dovar_sym = ffebld_symter (dovar);
8501 ffeexpr_update_impdo_sym_ (list, dovar_sym); /* Recurse! */
8504 /* Recursive function to update any expr so SYMTERs have "doiter" flag
8505 if they refer to the given variable. */
8508 ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar)
8510 tail_recurse: /* :::::::::::::::::::: */
8515 switch (ffebld_op (expr))
8517 case FFEBLD_opSYMTER:
8518 if (ffebld_symter (expr) == dovar)
8519 ffebld_symter_set_is_doiter (expr, TRUE);
8523 ffeexpr_update_impdo_sym_ (ffebld_head (expr), dovar);
8524 expr = ffebld_trail (expr);
8525 goto tail_recurse; /* :::::::::::::::::::: */
8531 switch (ffebld_arity (expr))
8534 ffeexpr_update_impdo_sym_ (ffebld_left (expr), dovar);
8535 expr = ffebld_right (expr);
8536 goto tail_recurse; /* :::::::::::::::::::: */
8539 expr = ffebld_left (expr);
8540 goto tail_recurse; /* :::::::::::::::::::: */
8549 /* ffeexpr_context_outer_ -- Determine context of stack entry, skipping PARENs
8551 if (ffeexpr_context_outer_(ffeexpr_stack_) == FFEEXPR_contextIF)
8552 // After zero or more PAREN_ contexts, an IF context exists */
8554 static ffeexprContext
8555 ffeexpr_context_outer_ (ffeexprStack_ s)
8563 case FFEEXPR_contextPAREN_:
8564 case FFEEXPR_contextPARENFILENUM_:
8565 case FFEEXPR_contextPARENFILEUNIT_:
8576 /* ffeexpr_percent_ -- Look up name in list of %FOO possibilities
8580 p = ffeexpr_percent_(t);
8582 Returns the identifier for the name, or the NONE identifier. */
8584 static ffeexprPercent_
8585 ffeexpr_percent_ (ffelexToken t)
8589 switch (ffelex_token_length (t))
8592 switch (*(p = ffelex_token_text (t)))
8594 case FFESRC_CASE_MATCH_INIT ('L', 'l', match_3l, no_match_3):
8595 if ((ffesrc_char_match_noninit (*++p, 'O', 'o'))
8596 && (ffesrc_char_match_noninit (*++p, 'C', 'c')))
8597 return FFEEXPR_percentLOC_;
8598 return FFEEXPR_percentNONE_;
8600 case FFESRC_CASE_MATCH_INIT ('R', 'r', match_3r, no_match_3):
8601 if ((ffesrc_char_match_noninit (*++p, 'E', 'e'))
8602 && (ffesrc_char_match_noninit (*++p, 'F', 'f')))
8603 return FFEEXPR_percentREF_;
8604 return FFEEXPR_percentNONE_;
8606 case FFESRC_CASE_MATCH_INIT ('V', 'v', match_3v, no_match_3):
8607 if ((ffesrc_char_match_noninit (*++p, 'A', 'a'))
8608 && (ffesrc_char_match_noninit (*++p, 'L', 'l')))
8609 return FFEEXPR_percentVAL_;
8610 return FFEEXPR_percentNONE_;
8613 no_match_3: /* :::::::::::::::::::: */
8614 return FFEEXPR_percentNONE_;
8618 if (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t), "DESCR",
8619 "descr", "Descr") == 0)
8620 return FFEEXPR_percentDESCR_;
8621 return FFEEXPR_percentNONE_;
8624 return FFEEXPR_percentNONE_;
8628 /* ffeexpr_type_combine -- Binop combine types, check for mythical new COMPLEX
8632 If combining the two basictype/kindtype pairs produces a COMPLEX with an
8633 unsupported kind type, complain and use the default kind type for
8637 ffeexpr_type_combine (ffeinfoBasictype *xnbt, ffeinfoKindtype *xnkt,
8638 ffeinfoBasictype lbt, ffeinfoKindtype lkt,
8639 ffeinfoBasictype rbt, ffeinfoKindtype rkt,
8642 ffeinfoBasictype nbt;
8643 ffeinfoKindtype nkt;
8645 nbt = ffeinfo_basictype_combine (lbt, rbt);
8646 if ((nbt == FFEINFO_basictypeCOMPLEX)
8647 && ((lbt == nbt) || (lbt == FFEINFO_basictypeREAL))
8648 && ((rbt == nbt) || (rbt == FFEINFO_basictypeREAL)))
8650 nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
8651 if (ffe_is_pedantic_not_90 () && (nkt == FFEINFO_kindtypeREALDOUBLE))
8652 nkt = FFEINFO_kindtypeNONE; /* Force error. */
8655 #if FFETARGET_okCOMPLEX1
8656 case FFEINFO_kindtypeREAL1:
8658 #if FFETARGET_okCOMPLEX2
8659 case FFEINFO_kindtypeREAL2:
8661 #if FFETARGET_okCOMPLEX3
8662 case FFEINFO_kindtypeREAL3:
8664 #if FFETARGET_okCOMPLEX4
8665 case FFEINFO_kindtypeREAL4:
8667 break; /* Fine and dandy. */
8672 ffebad_start ((nkt == FFEINFO_kindtypeREALDOUBLE)
8673 ? FFEBAD_BAD_DBLCMPLX : FFEBAD_BAD_COMPLEX);
8674 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
8677 nbt = FFEINFO_basictypeNONE;
8678 nkt = FFEINFO_kindtypeNONE;
8681 case FFEINFO_kindtypeANY:
8682 nkt = FFEINFO_kindtypeREALDEFAULT;
8687 { /* The normal stuff. */
8691 nkt = ffeinfo_kindtype_max (nbt, lkt, rkt);
8695 else if (nbt == rbt)
8698 { /* Let the caller do the complaining. */
8699 nbt = FFEINFO_basictypeNONE;
8700 nkt = FFEINFO_kindtypeNONE;
8704 /* Always a good idea to avoid aliasing problems. */
8710 /* ffeexpr_token_first_lhs_ -- First state for lhs expression
8712 Return a pointer to this function to the lexer (ffelex), which will
8713 invoke it for the next token.
8715 Record line and column of first token in expression, then invoke the
8716 initial-state lhs handler. */
8718 static ffelexHandler
8719 ffeexpr_token_first_lhs_ (ffelexToken t)
8721 ffeexpr_stack_->first_token = ffelex_token_use (t);
8723 /* When changing the list of valid initial lhs tokens, check whether to
8724 update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
8725 READ (expr) <token> case -- it assumes it knows which tokens <token> can
8726 be to indicate an lhs (or implied DO), which right now is the set
8729 This comment also appears in ffeexpr_token_lhs_. */
8731 switch (ffelex_token_type (t))
8733 case FFELEX_typeOPEN_PAREN:
8734 switch (ffeexpr_stack_->context)
8736 case FFEEXPR_contextDATA:
8738 ffeexpr_level_ = 1; /* Level of DATA implied-DO construct. */
8739 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8740 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8741 FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
8743 case FFEEXPR_contextDATAIMPDOITEM_:
8744 ++ffeexpr_level_; /* Level of DATA implied-DO construct. */
8745 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8746 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8747 FFEEXPR_contextDATAIMPDOITEM_, ffeexpr_cb_comma_i_);
8749 case FFEEXPR_contextIOLIST:
8750 case FFEEXPR_contextIMPDOITEM_:
8751 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8752 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8753 FFEEXPR_contextIMPDOITEM_, ffeexpr_cb_comma_i_);
8755 case FFEEXPR_contextIOLISTDF:
8756 case FFEEXPR_contextIMPDOITEMDF_:
8757 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
8758 return (ffelexHandler) ffeexpr_lhs (ffeexpr_stack_->pool,
8759 FFEEXPR_contextIMPDOITEMDF_, ffeexpr_cb_comma_i_);
8761 case FFEEXPR_contextFILEEXTFUNC:
8762 assert (ffeexpr_stack_->exprstack == NULL);
8763 return (ffelexHandler) ffeexpr_token_first_lhs_1_;
8770 case FFELEX_typeNAME:
8771 switch (ffeexpr_stack_->context)
8773 case FFEEXPR_contextFILENAMELIST:
8774 assert (ffeexpr_stack_->exprstack == NULL);
8775 return (ffelexHandler) ffeexpr_token_namelist_;
8777 case FFEEXPR_contextFILEEXTFUNC:
8778 assert (ffeexpr_stack_->exprstack == NULL);
8779 return (ffelexHandler) ffeexpr_token_first_lhs_1_;
8787 switch (ffeexpr_stack_->context)
8789 case FFEEXPR_contextFILEEXTFUNC:
8790 assert (ffeexpr_stack_->exprstack == NULL);
8791 return (ffelexHandler) ffeexpr_token_first_lhs_1_;
8799 return (ffelexHandler) ffeexpr_token_lhs_ (t);
8802 /* ffeexpr_token_first_lhs_1_ -- NAME
8804 return ffeexpr_token_first_lhs_1_; // to lexer
8806 Handle NAME as an external function (USEROPEN= VXT extension to OPEN
8809 static ffelexHandler
8810 ffeexpr_token_first_lhs_1_ (ffelexToken t)
8812 ffeexprCallback callback;
8816 ffesymbol sy = NULL;
8820 callback = ffeexpr_stack_->callback;
8821 ft = ffeexpr_stack_->first_token;
8822 s = ffeexpr_stack_->previous;
8824 if ((ffelex_token_type (ft) != FFELEX_typeNAME)
8825 || (ffesymbol_attrs (sy = ffeexpr_declare_unadorned_ (ft, FALSE))
8826 & FFESYMBOL_attrANY))
8828 if ((ffelex_token_type (ft) != FFELEX_typeNAME)
8829 || !(ffesymbol_attrs (sy) & FFESYMBOL_attrsANY))
8831 ffebad_start (FFEBAD_EXPR_WRONG);
8832 ffebad_here (0, ffelex_token_where_line (ft),
8833 ffelex_token_where_column (ft));
8836 expr = ffebld_new_any ();
8837 ffebld_set_info (expr, ffeinfo_new_any ());
8841 expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
8843 ffebld_set_info (expr, ffesymbol_info (sy));
8846 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
8847 sizeof (*ffeexpr_stack_));
8850 next = (ffelexHandler) (*callback) (ft, expr, t);
8851 ffelex_token_kill (ft);
8852 return (ffelexHandler) next;
8855 /* ffeexpr_token_first_rhs_ -- First state for rhs expression
8857 Record line and column of first token in expression, then invoke the
8858 initial-state rhs handler.
8861 Allow ASTERISK in PARENFILEUNIT_ case, but only on second level only
8862 (i.e. only as in READ(*), not READ((*))). */
8864 static ffelexHandler
8865 ffeexpr_token_first_rhs_ (ffelexToken t)
8869 ffeexpr_stack_->first_token = ffelex_token_use (t);
8871 switch (ffelex_token_type (t))
8873 case FFELEX_typeASTERISK:
8874 switch (ffeexpr_stack_->context)
8876 case FFEEXPR_contextFILEFORMATNML:
8877 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8879 case FFEEXPR_contextFILEUNIT:
8880 case FFEEXPR_contextDIMLIST:
8881 case FFEEXPR_contextFILEFORMAT:
8882 case FFEEXPR_contextCHARACTERSIZE:
8883 if (ffeexpr_stack_->previous != NULL)
8884 break; /* Valid only on first level. */
8885 assert (ffeexpr_stack_->exprstack == NULL);
8886 return (ffelexHandler) ffeexpr_token_first_rhs_1_;
8888 case FFEEXPR_contextPARENFILEUNIT_:
8889 if (ffeexpr_stack_->previous->previous != NULL)
8890 break; /* Valid only on second level. */
8891 assert (ffeexpr_stack_->exprstack == NULL);
8892 return (ffelexHandler) ffeexpr_token_first_rhs_1_;
8894 case FFEEXPR_contextACTUALARG_:
8895 if (ffeexpr_stack_->previous->context
8896 != FFEEXPR_contextSUBROUTINEREF)
8898 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8901 assert (ffeexpr_stack_->exprstack == NULL);
8902 return (ffelexHandler) ffeexpr_token_first_rhs_3_;
8904 case FFEEXPR_contextINDEXORACTUALARG_:
8905 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8908 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8909 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8912 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8913 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8921 case FFELEX_typeOPEN_PAREN:
8922 switch (ffeexpr_stack_->context)
8924 case FFEEXPR_contextFILENUMAMBIG:
8925 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8926 FFEEXPR_contextPARENFILENUM_,
8927 ffeexpr_cb_close_paren_ambig_);
8929 case FFEEXPR_contextFILEUNITAMBIG:
8930 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8931 FFEEXPR_contextPARENFILEUNIT_,
8932 ffeexpr_cb_close_paren_ambig_);
8934 case FFEEXPR_contextIOLIST:
8935 case FFEEXPR_contextIMPDOITEM_:
8936 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8937 FFEEXPR_contextIMPDOITEM_,
8938 ffeexpr_cb_close_paren_ci_);
8940 case FFEEXPR_contextIOLISTDF:
8941 case FFEEXPR_contextIMPDOITEMDF_:
8942 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
8943 FFEEXPR_contextIMPDOITEMDF_,
8944 ffeexpr_cb_close_paren_ci_);
8946 case FFEEXPR_contextFILEFORMATNML:
8947 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8950 case FFEEXPR_contextACTUALARG_:
8951 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8954 case FFEEXPR_contextINDEXORACTUALARG_:
8955 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8958 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8959 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8962 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8963 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
8971 case FFELEX_typeNUMBER:
8972 switch (ffeexpr_stack_->context)
8974 case FFEEXPR_contextFILEFORMATNML:
8975 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
8977 case FFEEXPR_contextFILEFORMAT:
8978 if (ffeexpr_stack_->previous != NULL)
8979 break; /* Valid only on first level. */
8980 assert (ffeexpr_stack_->exprstack == NULL);
8981 return (ffelexHandler) ffeexpr_token_first_rhs_2_;
8983 case FFEEXPR_contextACTUALARG_:
8984 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
8987 case FFEEXPR_contextINDEXORACTUALARG_:
8988 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
8991 case FFEEXPR_contextSFUNCDEFACTUALARG_:
8992 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
8995 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
8996 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
9004 case FFELEX_typeNAME:
9005 switch (ffeexpr_stack_->context)
9007 case FFEEXPR_contextFILEFORMATNML:
9008 assert (ffeexpr_stack_->exprstack == NULL);
9009 s = ffesymbol_lookup_local (t);
9010 if ((s != NULL) && (ffesymbol_kind (s) == FFEINFO_kindNAMELIST))
9011 return (ffelexHandler) ffeexpr_token_namelist_;
9012 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
9020 case FFELEX_typePERCENT:
9021 switch (ffeexpr_stack_->context)
9023 case FFEEXPR_contextACTUALARG_:
9024 case FFEEXPR_contextINDEXORACTUALARG_:
9025 case FFEEXPR_contextSFUNCDEFACTUALARG_:
9026 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9027 return (ffelexHandler) ffeexpr_token_first_rhs_5_;
9029 case FFEEXPR_contextFILEFORMATNML:
9030 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
9038 switch (ffeexpr_stack_->context)
9040 case FFEEXPR_contextACTUALARG_:
9041 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
9044 case FFEEXPR_contextINDEXORACTUALARG_:
9045 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
9048 case FFEEXPR_contextSFUNCDEFACTUALARG_:
9049 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
9052 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9053 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
9056 case FFEEXPR_contextFILEFORMATNML:
9057 ffeexpr_stack_->context = FFEEXPR_contextFILEFORMAT;
9066 return (ffelexHandler) ffeexpr_token_rhs_ (t);
9069 /* ffeexpr_token_first_rhs_1_ -- ASTERISK
9071 return ffeexpr_token_first_rhs_1_; // to lexer
9073 Return STAR as expression. */
9075 static ffelexHandler
9076 ffeexpr_token_first_rhs_1_ (ffelexToken t)
9079 ffeexprCallback callback;
9084 expr = ffebld_new_star ();
9086 callback = ffeexpr_stack_->callback;
9087 ft = ffeexpr_stack_->first_token;
9088 s = ffeexpr_stack_->previous;
9089 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
9091 next = (ffelexHandler) (*callback) (ft, expr, t);
9092 ffelex_token_kill (ft);
9093 return (ffelexHandler) next;
9096 /* ffeexpr_token_first_rhs_2_ -- NUMBER
9098 return ffeexpr_token_first_rhs_2_; // to lexer
9100 Return NULL as expression; NUMBER as first (and only) token, unless the
9101 current token is not a terminating token, in which case run normal
9102 expression handling. */
9104 static ffelexHandler
9105 ffeexpr_token_first_rhs_2_ (ffelexToken t)
9107 ffeexprCallback callback;
9112 switch (ffelex_token_type (t))
9114 case FFELEX_typeCLOSE_PAREN:
9115 case FFELEX_typeCOMMA:
9116 case FFELEX_typeEOS:
9117 case FFELEX_typeSEMICOLON:
9121 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9122 return (ffelexHandler) (*next) (t);
9126 callback = ffeexpr_stack_->callback;
9127 ft = ffeexpr_stack_->first_token;
9128 s = ffeexpr_stack_->previous;
9129 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
9130 sizeof (*ffeexpr_stack_));
9132 next = (ffelexHandler) (*callback) (ft, NULL, t);
9133 ffelex_token_kill (ft);
9134 return (ffelexHandler) next;
9137 /* ffeexpr_token_first_rhs_3_ -- ASTERISK
9139 return ffeexpr_token_first_rhs_3_; // to lexer
9141 Expect NUMBER, make LABTOK (with copy of token if not inhibited after
9142 confirming, else NULL). */
9144 static ffelexHandler
9145 ffeexpr_token_first_rhs_3_ (ffelexToken t)
9149 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
9150 { /* An error, but let normal processing handle
9152 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9153 return (ffelexHandler) (*next) (t);
9156 /* Special case: when we see "*10" as an argument to a subroutine
9157 reference, we confirm the current statement and, if not inhibited at
9158 this point, put a copy of the token into a LABTOK node. We do this
9159 instead of just resolving the label directly via ffelab and putting it
9160 into a LABTER simply to improve error reporting and consistency in
9161 ffestc. We put NULL in the LABTOK if we're still inhibited, so ffestb
9162 doesn't have to worry about killing off any tokens when retracting. */
9165 if (ffest_is_inhibited ())
9166 ffeexpr_stack_->expr = ffebld_new_labtok (NULL);
9168 ffeexpr_stack_->expr = ffebld_new_labtok (ffelex_token_use (t));
9169 ffebld_set_info (ffeexpr_stack_->expr,
9170 ffeinfo_new (FFEINFO_basictypeNONE,
9171 FFEINFO_kindtypeNONE,
9175 FFETARGET_charactersizeNONE));
9177 return (ffelexHandler) ffeexpr_token_first_rhs_4_;
9180 /* ffeexpr_token_first_rhs_4_ -- ASTERISK NUMBER
9182 return ffeexpr_token_first_rhs_4_; // to lexer
9184 Collect/flush appropriate stuff, send token to callback function. */
9186 static ffelexHandler
9187 ffeexpr_token_first_rhs_4_ (ffelexToken t)
9190 ffeexprCallback callback;
9195 expr = ffeexpr_stack_->expr;
9197 callback = ffeexpr_stack_->callback;
9198 ft = ffeexpr_stack_->first_token;
9199 s = ffeexpr_stack_->previous;
9200 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
9202 next = (ffelexHandler) (*callback) (ft, expr, t);
9203 ffelex_token_kill (ft);
9204 return (ffelexHandler) next;
9207 /* ffeexpr_token_first_rhs_5_ -- PERCENT
9209 Should be NAME, or pass through original mechanism. If NAME is LOC,
9210 pass through original mechanism, otherwise must be VAL, REF, or DESCR,
9211 in which case handle the argument (in parentheses), etc. */
9213 static ffelexHandler
9214 ffeexpr_token_first_rhs_5_ (ffelexToken t)
9218 if (ffelex_token_type (t) == FFELEX_typeNAME)
9220 ffeexprPercent_ p = ffeexpr_percent_ (t);
9224 case FFEEXPR_percentNONE_:
9225 case FFEEXPR_percentLOC_:
9226 break; /* Treat %LOC as any other expression. */
9228 case FFEEXPR_percentVAL_:
9229 case FFEEXPR_percentREF_:
9230 case FFEEXPR_percentDESCR_:
9231 ffeexpr_stack_->percent = p;
9232 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
9233 return (ffelexHandler) ffeexpr_token_first_rhs_6_;
9236 assert ("bad percent?!?" == NULL);
9241 switch (ffeexpr_stack_->context)
9243 case FFEEXPR_contextACTUALARG_:
9244 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
9247 case FFEEXPR_contextINDEXORACTUALARG_:
9248 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
9251 case FFEEXPR_contextSFUNCDEFACTUALARG_:
9252 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
9255 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9256 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
9260 assert ("bad context?!?!" == NULL);
9264 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9265 return (ffelexHandler) (*next) (t);
9268 /* ffeexpr_token_first_rhs_6_ -- PERCENT NAME(VAL,REF,DESCR)
9270 Should be OPEN_PAREN, or pass through original mechanism. */
9272 static ffelexHandler
9273 ffeexpr_token_first_rhs_6_ (ffelexToken t)
9278 if (ffelex_token_type (t) == FFELEX_typeOPEN_PAREN)
9280 ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
9281 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
9282 ffeexpr_stack_->context,
9283 ffeexpr_cb_end_notloc_);
9286 switch (ffeexpr_stack_->context)
9288 case FFEEXPR_contextACTUALARG_:
9289 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
9292 case FFEEXPR_contextINDEXORACTUALARG_:
9293 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
9296 case FFEEXPR_contextSFUNCDEFACTUALARG_:
9297 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
9300 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
9301 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
9305 assert ("bad context?!?!" == NULL);
9309 ft = ffeexpr_stack_->tokens[0];
9310 next = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_stack_->first_token);
9311 next = (ffelexHandler) (*next) (ft);
9312 ffelex_token_kill (ft);
9313 return (ffelexHandler) (*next) (t);
9316 /* ffeexpr_token_namelist_ -- NAME
9318 return ffeexpr_token_namelist_; // to lexer
9320 Make sure NAME was a valid namelist object, wrap it in a SYMTER and
9323 static ffelexHandler
9324 ffeexpr_token_namelist_ (ffelexToken t)
9326 ffeexprCallback callback;
9334 callback = ffeexpr_stack_->callback;
9335 ft = ffeexpr_stack_->first_token;
9336 s = ffeexpr_stack_->previous;
9337 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_, sizeof (*ffeexpr_stack_));
9340 sy = ffesymbol_lookup_local (ft);
9341 if ((sy == NULL) || (ffesymbol_kind (sy) != FFEINFO_kindNAMELIST))
9343 ffebad_start (FFEBAD_EXPR_WRONG);
9344 ffebad_here (0, ffelex_token_where_line (ft),
9345 ffelex_token_where_column (ft));
9347 expr = ffebld_new_any ();
9348 ffebld_set_info (expr, ffeinfo_new_any ());
9352 expr = ffebld_new_symter (sy, FFEINTRIN_genNONE, FFEINTRIN_specNONE,
9354 ffebld_set_info (expr, ffesymbol_info (sy));
9356 next = (ffelexHandler) (*callback) (ft, expr, t);
9357 ffelex_token_kill (ft);
9358 return (ffelexHandler) next;
9361 /* ffeexpr_expr_kill_ -- Kill an existing internal expression object
9364 ffeexpr_expr_kill_(e);
9366 Kills the ffewhere info, if necessary, then kills the object. */
9369 ffeexpr_expr_kill_ (ffeexprExpr_ e)
9371 if (e->token != NULL)
9372 ffelex_token_kill (e->token);
9373 malloc_kill_ks (ffe_pool_program_unit (), e, sizeof (*e));
9376 /* ffeexpr_expr_new_ -- Make a new internal expression object
9379 e = ffeexpr_expr_new_();
9381 Allocates and initializes a new expression object, returns it. */
9384 ffeexpr_expr_new_ ()
9388 e = (ffeexprExpr_) malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR expr",
9391 e->type = FFEEXPR_exprtypeUNKNOWN_;
9396 /* Verify that call to global is valid, and register whatever
9397 new information about a global might be discoverable by looking
9401 ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t)
9408 assert ((ffebld_op (*expr) == FFEBLD_opSUBRREF)
9409 || (ffebld_op (*expr) == FFEBLD_opFUNCREF));
9411 if (ffebld_op (ffebld_left (*expr)) != FFEBLD_opSYMTER)
9414 if (ffesymbol_retractable ())
9417 s = ffebld_symter (ffebld_left (*expr));
9418 if (ffesymbol_global (s) == NULL)
9421 for (n_args = 0, list = ffebld_right (*expr);
9423 list = ffebld_trail (list), ++n_args)
9426 if (ffeglobal_proc_ref_nargs (s, n_args, t))
9428 ffeglobalArgSummary as;
9429 ffeinfoBasictype bt;
9434 for (n_args = 0, list = ffebld_right (*expr);
9436 list = ffebld_trail (list), ++n_args)
9438 item = ffebld_head (list);
9441 bt = ffeinfo_basictype (ffebld_info (item));
9442 kt = ffeinfo_kindtype (ffebld_info (item));
9443 array = (ffeinfo_rank (ffebld_info (item)) > 0);
9444 switch (ffebld_op (item))
9446 case FFEBLD_opLABTOK:
9447 case FFEBLD_opLABTER:
9448 as = FFEGLOBAL_argsummaryALTRTN;
9452 /* No, %LOC(foo) is just like any INTEGER(KIND=7)
9453 expression, so don't treat it specially. */
9454 case FFEBLD_opPERCENT_LOC:
9455 as = FFEGLOBAL_argsummaryPTR;
9459 case FFEBLD_opPERCENT_VAL:
9460 as = FFEGLOBAL_argsummaryVAL;
9463 case FFEBLD_opPERCENT_REF:
9464 as = FFEGLOBAL_argsummaryREF;
9467 case FFEBLD_opPERCENT_DESCR:
9468 as = FFEGLOBAL_argsummaryDESCR;
9471 case FFEBLD_opFUNCREF:
9473 /* No, LOC(foo) is just like any INTEGER(KIND=7)
9474 expression, so don't treat it specially. */
9475 if ((ffebld_op (ffebld_left (item)) == FFEBLD_opSYMTER)
9476 && (ffesymbol_specific (ffebld_symter (ffebld_left (item)))
9477 == FFEINTRIN_specLOC))
9479 as = FFEGLOBAL_argsummaryPTR;
9485 if (ffebld_op (item) == FFEBLD_opSYMTER)
9487 as = FFEGLOBAL_argsummaryNONE;
9489 switch (ffeinfo_kind (ffebld_info (item)))
9491 case FFEINFO_kindFUNCTION:
9492 as = FFEGLOBAL_argsummaryFUNC;
9495 case FFEINFO_kindSUBROUTINE:
9496 as = FFEGLOBAL_argsummarySUBR;
9499 case FFEINFO_kindNONE:
9500 as = FFEGLOBAL_argsummaryPROC;
9507 if (as != FFEGLOBAL_argsummaryNONE)
9511 if (bt == FFEINFO_basictypeCHARACTER)
9512 as = FFEGLOBAL_argsummaryDESCR;
9514 as = FFEGLOBAL_argsummaryREF;
9521 as = FFEGLOBAL_argsummaryNONE;
9522 bt = FFEINFO_basictypeNONE;
9523 kt = FFEINFO_kindtypeNONE;
9526 if (! ffeglobal_proc_ref_arg (s, n_args, as, bt, kt, array, t))
9533 *expr = ffebld_new_any ();
9534 ffebld_set_info (*expr, ffeinfo_new_any ());
9537 /* Check whether rest of string is all decimal digits. */
9540 ffeexpr_isdigits_ (const char *p)
9542 for (; *p != '\0'; ++p)
9548 /* ffeexpr_exprstack_push_ -- Push an arbitrary expression object onto the stack
9551 ffeexpr_exprstack_push_(e);
9553 Pushes the expression onto the stack without any analysis of the existing
9554 contents of the stack. */
9557 ffeexpr_exprstack_push_ (ffeexprExpr_ e)
9559 e->previous = ffeexpr_stack_->exprstack;
9560 ffeexpr_stack_->exprstack = e;
9563 /* ffeexpr_exprstack_push_operand_ -- Push an operand onto the stack, reduce?
9566 ffeexpr_exprstack_push_operand_(e);
9568 Pushes the expression already containing an operand (a constant, variable,
9569 or more complicated expression that has already been fully resolved) after
9570 analyzing the stack and checking for possible reduction (which will never
9571 happen here since the highest precedence operator is ** and it has right-
9572 to-left associativity). */
9575 ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e)
9577 ffeexpr_exprstack_push_ (e);
9578 #ifdef WEIRD_NONFORTRAN_RULES
9579 if ((ffeexpr_stack_->exprstack != NULL)
9580 && (ffeexpr_stack_->exprstack->expr->type == FFEEXPR_exprtypeBINARY_)
9581 && (ffeexpr_stack_->exprstack->expr->u.operator.prec
9582 == FFEEXPR_operatorprecedenceHIGHEST_)
9583 && (ffeexpr_stack_->exprstack->expr->u.operator.as
9584 == FFEEXPR_operatorassociativityL2R_))
9589 /* ffeexpr_exprstack_push_unary_ -- Push a unary operator onto the stack
9592 ffeexpr_exprstack_push_unary_(e);
9594 Pushes the expression already containing a unary operator. Reduction can
9595 never happen since unary operators are themselves always R-L; that is, the
9596 top of the expression stack is not an operand, in that it is either empty,
9597 has a binary operator at the top, or a unary operator at the top. In any
9598 of these cases, reduction is impossible. */
9601 ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e)
9603 if ((ffe_is_pedantic ()
9604 || ffe_is_warn_surprising ())
9605 && (ffeexpr_stack_->exprstack != NULL)
9606 && (ffeexpr_stack_->exprstack->type != FFEEXPR_exprtypeOPERAND_)
9607 && (ffeexpr_stack_->exprstack->u.operator.prec
9608 <= FFEEXPR_operatorprecedenceLOWARITH_)
9609 && (e->u.operator.prec <= FFEEXPR_operatorprecedenceLOWARITH_))
9611 ffebad_start_msg ("Two arithmetic operators in a row at %0 and %1 -- use parentheses",
9613 ? FFEBAD_severityPEDANTIC
9614 : FFEBAD_severityWARNING);
9616 ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
9617 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
9619 ffelex_token_where_line (e->token),
9620 ffelex_token_where_column (e->token));
9624 ffeexpr_exprstack_push_ (e);
9627 /* ffeexpr_exprstack_push_binary_ -- Push a binary operator onto the stack, reduce?
9630 ffeexpr_exprstack_push_binary_(e);
9632 Pushes the expression already containing a binary operator after checking
9633 whether reduction is possible. If the stack is not empty, the top of the
9634 stack must be an operand or syntactic analysis has failed somehow. If
9635 the operand is preceded by a unary operator of higher (or equal and L-R
9636 associativity) precedence than the new binary operator, then reduce that
9637 preceding operator and its operand(s) before pushing the new binary
9641 ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e)
9645 if (ffe_is_warn_surprising ()
9646 /* These next two are always true (see assertions below). */
9647 && (ffeexpr_stack_->exprstack != NULL)
9648 && (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_)
9649 /* If the previous operator is a unary minus, and the binary op
9650 is of higher precedence, might not do what user expects,
9651 e.g. "-2**2" is "-(2**2)", i.e. "-4", not "(-2)**2", which would
9653 && (ffeexpr_stack_->exprstack->previous != NULL)
9654 && (ffeexpr_stack_->exprstack->previous->type == FFEEXPR_exprtypeUNARY_)
9655 && (ffeexpr_stack_->exprstack->previous->u.operator.op
9656 == FFEEXPR_operatorSUBTRACT_)
9657 && (e->u.operator.prec
9658 < ffeexpr_stack_->exprstack->previous->u.operator.prec))
9660 ffebad_start_msg ("Operator at %0 has lower precedence than that at %1 -- use parentheses", FFEBAD_severityWARNING);
9662 ffelex_token_where_line (ffeexpr_stack_->exprstack->previous->token),
9663 ffelex_token_where_column (ffeexpr_stack_->exprstack->previous->token));
9665 ffelex_token_where_line (e->token),
9666 ffelex_token_where_column (e->token));
9671 assert (ffeexpr_stack_->exprstack != NULL);
9672 assert (ffeexpr_stack_->exprstack->type == FFEEXPR_exprtypeOPERAND_);
9673 if ((ce = ffeexpr_stack_->exprstack->previous) != NULL)
9675 assert (ce->type != FFEEXPR_exprtypeOPERAND_);
9676 if ((ce->u.operator.prec < e->u.operator.prec)
9677 || ((ce->u.operator.prec == e->u.operator.prec)
9678 && (e->u.operator.as == FFEEXPR_operatorassociativityL2R_)))
9681 goto again; /* :::::::::::::::::::: */
9685 ffeexpr_exprstack_push_ (e);
9688 /* ffeexpr_reduce_ -- Reduce highest operator w/operands on stack
9692 Converts operand binop operand or unop operand at top of stack to a
9693 single operand having the appropriate ffebld expression, and makes
9694 sure that the expression is proper (like not trying to add two character
9695 variables, not trying to concatenate two numbers). Also does the
9696 requisite type-assignment. */
9701 ffeexprExpr_ operand; /* This is B in -B or A+B. */
9702 ffeexprExpr_ left_operand; /* When operator is binary, this is A in A+B. */
9703 ffeexprExpr_ operator; /* This is + in A+B. */
9704 ffebld reduced; /* This is +(A,B) in A+B or u-(B) in -B. */
9705 ffebldConstant constnode; /* For checking magical numbers (where mag ==
9709 bool submag = FALSE;
9711 operand = ffeexpr_stack_->exprstack;
9712 assert (operand != NULL);
9713 assert (operand->type == FFEEXPR_exprtypeOPERAND_);
9714 operator = operand->previous;
9715 assert (operator != NULL);
9716 assert (operator->type != FFEEXPR_exprtypeOPERAND_);
9717 if (operator->type == FFEEXPR_exprtypeUNARY_)
9719 expr = operand->u.operand;
9720 switch (operator->u.operator.op)
9722 case FFEEXPR_operatorADD_:
9723 reduced = ffebld_new_uplus (expr);
9724 if (ffe_is_ugly_logint ())
9725 reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
9726 reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
9727 reduced = ffeexpr_collapse_uplus (reduced, operator->token);
9730 case FFEEXPR_operatorSUBTRACT_:
9731 submag = TRUE; /* Ok to negate a magic number. */
9732 reduced = ffebld_new_uminus (expr);
9733 if (ffe_is_ugly_logint ())
9734 reduced = ffeexpr_reduced_ugly1_ (reduced, operator, operand);
9735 reduced = ffeexpr_reduced_math1_ (reduced, operator, operand);
9736 reduced = ffeexpr_collapse_uminus (reduced, operator->token);
9739 case FFEEXPR_operatorNOT_:
9740 reduced = ffebld_new_not (expr);
9741 if (ffe_is_ugly_logint ())
9742 reduced = ffeexpr_reduced_ugly1log_ (reduced, operator, operand);
9743 reduced = ffeexpr_reduced_bool1_ (reduced, operator, operand);
9744 reduced = ffeexpr_collapse_not (reduced, operator->token);
9748 assert ("unexpected unary op" != NULL);
9753 && (ffebld_op (expr) == FFEBLD_opCONTER)
9754 && (ffebld_conter_orig (expr) == NULL)
9755 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
9757 ffetarget_integer_bad_magical (operand->token);
9759 ffeexpr_stack_->exprstack = operator->previous; /* Pops unary-op operand
9761 ffeexpr_expr_kill_ (operand);
9762 operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but
9764 operator->u.operand = reduced; /* the line/column ffewhere info. */
9765 ffeexpr_exprstack_push_operand_ (operator); /* Push it back on
9770 assert (operator->type == FFEEXPR_exprtypeBINARY_);
9771 left_operand = operator->previous;
9772 assert (left_operand != NULL);
9773 assert (left_operand->type == FFEEXPR_exprtypeOPERAND_);
9774 expr = operand->u.operand;
9775 left_expr = left_operand->u.operand;
9776 switch (operator->u.operator.op)
9778 case FFEEXPR_operatorADD_:
9779 reduced = ffebld_new_add (left_expr, expr);
9780 if (ffe_is_ugly_logint ())
9781 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9783 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9785 reduced = ffeexpr_collapse_add (reduced, operator->token);
9788 case FFEEXPR_operatorSUBTRACT_:
9789 submag = TRUE; /* Just to pick the right error if magic
9791 reduced = ffebld_new_subtract (left_expr, expr);
9792 if (ffe_is_ugly_logint ())
9793 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9795 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9797 reduced = ffeexpr_collapse_subtract (reduced, operator->token);
9800 case FFEEXPR_operatorMULTIPLY_:
9801 reduced = ffebld_new_multiply (left_expr, expr);
9802 if (ffe_is_ugly_logint ())
9803 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9805 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9807 reduced = ffeexpr_collapse_multiply (reduced, operator->token);
9810 case FFEEXPR_operatorDIVIDE_:
9811 reduced = ffebld_new_divide (left_expr, expr);
9812 if (ffe_is_ugly_logint ())
9813 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9815 reduced = ffeexpr_reduced_math2_ (reduced, left_operand, operator,
9817 reduced = ffeexpr_collapse_divide (reduced, operator->token);
9820 case FFEEXPR_operatorPOWER_:
9821 reduced = ffebld_new_power (left_expr, expr);
9822 if (ffe_is_ugly_logint ())
9823 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9825 reduced = ffeexpr_reduced_power_ (reduced, left_operand, operator,
9827 reduced = ffeexpr_collapse_power (reduced, operator->token);
9830 case FFEEXPR_operatorCONCATENATE_:
9831 reduced = ffebld_new_concatenate (left_expr, expr);
9832 reduced = ffeexpr_reduced_concatenate_ (reduced, left_operand, operator,
9834 reduced = ffeexpr_collapse_concatenate (reduced, operator->token);
9837 case FFEEXPR_operatorLT_:
9838 reduced = ffebld_new_lt (left_expr, expr);
9839 if (ffe_is_ugly_logint ())
9840 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9842 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9844 reduced = ffeexpr_collapse_lt (reduced, operator->token);
9847 case FFEEXPR_operatorLE_:
9848 reduced = ffebld_new_le (left_expr, expr);
9849 if (ffe_is_ugly_logint ())
9850 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9852 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9854 reduced = ffeexpr_collapse_le (reduced, operator->token);
9857 case FFEEXPR_operatorEQ_:
9858 reduced = ffebld_new_eq (left_expr, expr);
9859 if (ffe_is_ugly_logint ())
9860 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9862 reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
9864 reduced = ffeexpr_collapse_eq (reduced, operator->token);
9867 case FFEEXPR_operatorNE_:
9868 reduced = ffebld_new_ne (left_expr, expr);
9869 if (ffe_is_ugly_logint ())
9870 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9872 reduced = ffeexpr_reduced_eqop2_ (reduced, left_operand, operator,
9874 reduced = ffeexpr_collapse_ne (reduced, operator->token);
9877 case FFEEXPR_operatorGT_:
9878 reduced = ffebld_new_gt (left_expr, expr);
9879 if (ffe_is_ugly_logint ())
9880 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9882 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9884 reduced = ffeexpr_collapse_gt (reduced, operator->token);
9887 case FFEEXPR_operatorGE_:
9888 reduced = ffebld_new_ge (left_expr, expr);
9889 if (ffe_is_ugly_logint ())
9890 reduced = ffeexpr_reduced_ugly2_ (reduced, left_operand, operator,
9892 reduced = ffeexpr_reduced_relop2_ (reduced, left_operand, operator,
9894 reduced = ffeexpr_collapse_ge (reduced, operator->token);
9897 case FFEEXPR_operatorAND_:
9898 reduced = ffebld_new_and (left_expr, expr);
9899 if (ffe_is_ugly_logint ())
9900 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9902 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9904 reduced = ffeexpr_collapse_and (reduced, operator->token);
9907 case FFEEXPR_operatorOR_:
9908 reduced = ffebld_new_or (left_expr, expr);
9909 if (ffe_is_ugly_logint ())
9910 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9912 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9914 reduced = ffeexpr_collapse_or (reduced, operator->token);
9917 case FFEEXPR_operatorXOR_:
9918 reduced = ffebld_new_xor (left_expr, expr);
9919 if (ffe_is_ugly_logint ())
9920 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9922 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9924 reduced = ffeexpr_collapse_xor (reduced, operator->token);
9927 case FFEEXPR_operatorEQV_:
9928 reduced = ffebld_new_eqv (left_expr, expr);
9929 if (ffe_is_ugly_logint ())
9930 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9932 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9934 reduced = ffeexpr_collapse_eqv (reduced, operator->token);
9937 case FFEEXPR_operatorNEQV_:
9938 reduced = ffebld_new_neqv (left_expr, expr);
9939 if (ffe_is_ugly_logint ())
9940 reduced = ffeexpr_reduced_ugly2log_ (reduced, left_operand, operator,
9942 reduced = ffeexpr_reduced_bool2_ (reduced, left_operand, operator,
9944 reduced = ffeexpr_collapse_neqv (reduced, operator->token);
9948 assert ("bad bin op" == NULL);
9952 if ((ffebld_op (left_expr) == FFEBLD_opCONTER)
9953 && (ffebld_conter_orig (expr) == NULL)
9954 && ffebld_constant_is_magical (constnode = ffebld_conter (left_expr)))
9956 if ((left_operand->previous != NULL)
9957 && (left_operand->previous->type != FFEEXPR_exprtypeOPERAND_)
9958 && (left_operand->previous->u.operator.op
9959 == FFEEXPR_operatorSUBTRACT_))
9961 if (left_operand->previous->type == FFEEXPR_exprtypeUNARY_)
9962 ffetarget_integer_bad_magical_precedence (left_operand->token,
9963 left_operand->previous->token,
9966 ffetarget_integer_bad_magical_precedence_binary
9967 (left_operand->token,
9968 left_operand->previous->token,
9972 ffetarget_integer_bad_magical (left_operand->token);
9974 if ((ffebld_op (expr) == FFEBLD_opCONTER)
9975 && (ffebld_conter_orig (expr) == NULL)
9976 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
9979 ffetarget_integer_bad_magical_binary (operand->token,
9982 ffetarget_integer_bad_magical (operand->token);
9984 ffeexpr_stack_->exprstack = left_operand->previous; /* Pops binary-op
9985 operands off stack. */
9986 ffeexpr_expr_kill_ (left_operand);
9987 ffeexpr_expr_kill_ (operand);
9988 operator->type = FFEEXPR_exprtypeOPERAND_; /* Convert operator, but
9990 operator->u.operand = reduced; /* the line/column ffewhere info. */
9991 ffeexpr_exprstack_push_operand_ (operator); /* Push it back on
9996 /* ffeexpr_reduced_bool1_ -- Wrap up reduction of NOT operator
9998 reduced = ffeexpr_reduced_bool1_(reduced,op,r);
10000 Makes sure the argument for reduced has basictype of
10001 LOGICAL or (ugly) INTEGER. If
10002 argument has where of CONSTANT, assign where CONSTANT to
10003 reduced, else assign where FLEETING.
10005 If these requirements cannot be met, generate error message. */
10008 ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10010 ffeinfo rinfo, ninfo;
10011 ffeinfoBasictype rbt;
10012 ffeinfoKindtype rkt;
10015 ffeinfoWhere rwh, nwh;
10017 rinfo = ffebld_info (ffebld_left (reduced));
10018 rbt = ffeinfo_basictype (rinfo);
10019 rkt = ffeinfo_kindtype (rinfo);
10020 rrk = ffeinfo_rank (rinfo);
10021 rkd = ffeinfo_kind (rinfo);
10022 rwh = ffeinfo_where (rinfo);
10024 if (((rbt == FFEINFO_basictypeLOGICAL)
10025 || (ffe_is_ugly_logint () && (rbt == FFEINFO_basictypeINTEGER)))
10030 case FFEINFO_whereCONSTANT:
10031 nwh = FFEINFO_whereCONSTANT;
10034 case FFEINFO_whereIMMEDIATE:
10035 nwh = FFEINFO_whereIMMEDIATE;
10039 nwh = FFEINFO_whereFLEETING;
10043 ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
10044 FFETARGET_charactersizeNONE);
10045 ffebld_set_info (reduced, ninfo);
10049 if ((rbt != FFEINFO_basictypeLOGICAL)
10050 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
10052 if ((rbt != FFEINFO_basictypeANY)
10053 && ffebad_start (FFEBAD_NOT_ARG_TYPE))
10055 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10056 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10062 if ((rkd != FFEINFO_kindANY)
10063 && ffebad_start (FFEBAD_NOT_ARG_KIND))
10065 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10066 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10067 ffebad_string ("an array");
10072 reduced = ffebld_new_any ();
10073 ffebld_set_info (reduced, ffeinfo_new_any ());
10077 /* ffeexpr_reduced_bool2_ -- Wrap up reduction of boolean operators
10079 reduced = ffeexpr_reduced_bool2_(reduced,l,op,r);
10081 Makes sure the left and right arguments for reduced have basictype of
10082 LOGICAL or (ugly) INTEGER. Determine common basictype and
10083 size for reduction (flag expression for combined hollerith/typeless
10084 situations for later determination of effective basictype). If both left
10085 and right arguments have where of CONSTANT, assign where CONSTANT to
10086 reduced, else assign where FLEETING. Create CONVERT ops for args where
10087 needed. Convert typeless
10088 constants to the desired type/size explicitly.
10090 If these requirements cannot be met, generate error message. */
10093 ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10096 ffeinfo linfo, rinfo, ninfo;
10097 ffeinfoBasictype lbt, rbt, nbt;
10098 ffeinfoKindtype lkt, rkt, nkt;
10099 ffeinfoRank lrk, rrk;
10100 ffeinfoKind lkd, rkd;
10101 ffeinfoWhere lwh, rwh, nwh;
10103 linfo = ffebld_info (ffebld_left (reduced));
10104 lbt = ffeinfo_basictype (linfo);
10105 lkt = ffeinfo_kindtype (linfo);
10106 lrk = ffeinfo_rank (linfo);
10107 lkd = ffeinfo_kind (linfo);
10108 lwh = ffeinfo_where (linfo);
10110 rinfo = ffebld_info (ffebld_right (reduced));
10111 rbt = ffeinfo_basictype (rinfo);
10112 rkt = ffeinfo_kindtype (rinfo);
10113 rrk = ffeinfo_rank (rinfo);
10114 rkd = ffeinfo_kind (rinfo);
10115 rwh = ffeinfo_where (rinfo);
10117 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10119 if (((nbt == FFEINFO_basictypeLOGICAL)
10120 || (ffe_is_ugly_logint () && (nbt == FFEINFO_basictypeINTEGER)))
10121 && (lrk == 0) && (rrk == 0))
10125 case FFEINFO_whereCONSTANT:
10128 case FFEINFO_whereCONSTANT:
10129 nwh = FFEINFO_whereCONSTANT;
10132 case FFEINFO_whereIMMEDIATE:
10133 nwh = FFEINFO_whereIMMEDIATE;
10137 nwh = FFEINFO_whereFLEETING;
10142 case FFEINFO_whereIMMEDIATE:
10145 case FFEINFO_whereCONSTANT:
10146 case FFEINFO_whereIMMEDIATE:
10147 nwh = FFEINFO_whereIMMEDIATE;
10151 nwh = FFEINFO_whereFLEETING;
10157 nwh = FFEINFO_whereFLEETING;
10161 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10162 FFETARGET_charactersizeNONE);
10163 ffebld_set_info (reduced, ninfo);
10164 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10165 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10166 FFEEXPR_contextLET));
10167 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10168 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10169 FFEEXPR_contextLET));
10173 if ((lbt != FFEINFO_basictypeLOGICAL)
10174 && (!ffe_is_ugly_logint () || (lbt != FFEINFO_basictypeINTEGER)))
10176 if ((rbt != FFEINFO_basictypeLOGICAL)
10177 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
10179 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10180 && ffebad_start (FFEBAD_BOOL_ARGS_TYPE))
10182 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10183 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10184 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10190 if ((lbt != FFEINFO_basictypeANY)
10191 && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
10193 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10194 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10199 else if ((rbt != FFEINFO_basictypeLOGICAL)
10200 && (!ffe_is_ugly_logint () || (rbt != FFEINFO_basictypeINTEGER)))
10202 if ((rbt != FFEINFO_basictypeANY)
10203 && ffebad_start (FFEBAD_BOOL_ARG_TYPE))
10205 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10206 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10212 if ((lkd != FFEINFO_kindANY)
10213 && ffebad_start (FFEBAD_BOOL_ARG_KIND))
10215 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10216 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10217 ffebad_string ("an array");
10223 if ((rkd != FFEINFO_kindANY)
10224 && ffebad_start (FFEBAD_BOOL_ARG_KIND))
10226 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10227 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10228 ffebad_string ("an array");
10233 reduced = ffebld_new_any ();
10234 ffebld_set_info (reduced, ffeinfo_new_any ());
10238 /* ffeexpr_reduced_concatenate_ -- Wrap up reduction of concatenate operator
10240 reduced = ffeexpr_reduced_concatenate_(reduced,l,op,r);
10242 Makes sure the left and right arguments for reduced have basictype of
10243 CHARACTER and kind of SCALAR, FUNCTION, or STATEMENT FUNCTION. Assign
10244 basictype of CHARACTER and kind of SCALAR to reduced. Calculate effective
10245 size of concatenation and assign that size to reduced. If both left and
10246 right arguments have where of CONSTANT, assign where CONSTANT to reduced,
10247 else assign where FLEETING.
10249 If these requirements cannot be met, generate error message using the
10250 info in l, op, and r arguments and assign basictype, size, kind, and where
10254 ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10257 ffeinfo linfo, rinfo, ninfo;
10258 ffeinfoBasictype lbt, rbt, nbt;
10259 ffeinfoKindtype lkt, rkt, nkt;
10260 ffeinfoRank lrk, rrk;
10261 ffeinfoKind lkd, rkd, nkd;
10262 ffeinfoWhere lwh, rwh, nwh;
10263 ffetargetCharacterSize lszm, lszk, rszm, rszk, nszk;
10265 linfo = ffebld_info (ffebld_left (reduced));
10266 lbt = ffeinfo_basictype (linfo);
10267 lkt = ffeinfo_kindtype (linfo);
10268 lrk = ffeinfo_rank (linfo);
10269 lkd = ffeinfo_kind (linfo);
10270 lwh = ffeinfo_where (linfo);
10271 lszk = ffeinfo_size (linfo); /* Known size. */
10272 lszm = ffebld_size_max (ffebld_left (reduced));
10274 rinfo = ffebld_info (ffebld_right (reduced));
10275 rbt = ffeinfo_basictype (rinfo);
10276 rkt = ffeinfo_kindtype (rinfo);
10277 rrk = ffeinfo_rank (rinfo);
10278 rkd = ffeinfo_kind (rinfo);
10279 rwh = ffeinfo_where (rinfo);
10280 rszk = ffeinfo_size (rinfo); /* Known size. */
10281 rszm = ffebld_size_max (ffebld_right (reduced));
10283 if ((lbt == FFEINFO_basictypeCHARACTER) && (rbt == FFEINFO_basictypeCHARACTER)
10284 && (lkt == rkt) && (lrk == 0) && (rrk == 0)
10285 && (((lszm != FFETARGET_charactersizeNONE)
10286 && (rszm != FFETARGET_charactersizeNONE))
10287 || (ffeexpr_context_outer_ (ffeexpr_stack_)
10288 == FFEEXPR_contextLET)
10289 || (ffeexpr_context_outer_ (ffeexpr_stack_)
10290 == FFEEXPR_contextSFUNCDEF)))
10292 nbt = FFEINFO_basictypeCHARACTER;
10293 nkd = FFEINFO_kindENTITY;
10294 if ((lszk == FFETARGET_charactersizeNONE)
10295 || (rszk == FFETARGET_charactersizeNONE))
10296 nszk = FFETARGET_charactersizeNONE; /* Ok only in rhs of LET
10299 nszk = lszk + rszk;
10303 case FFEINFO_whereCONSTANT:
10306 case FFEINFO_whereCONSTANT:
10307 nwh = FFEINFO_whereCONSTANT;
10310 case FFEINFO_whereIMMEDIATE:
10311 nwh = FFEINFO_whereIMMEDIATE;
10315 nwh = FFEINFO_whereFLEETING;
10320 case FFEINFO_whereIMMEDIATE:
10323 case FFEINFO_whereCONSTANT:
10324 case FFEINFO_whereIMMEDIATE:
10325 nwh = FFEINFO_whereIMMEDIATE;
10329 nwh = FFEINFO_whereFLEETING;
10335 nwh = FFEINFO_whereFLEETING;
10340 ninfo = ffeinfo_new (nbt, nkt, 0, nkd, nwh, nszk);
10341 ffebld_set_info (reduced, ninfo);
10345 if ((lbt != FFEINFO_basictypeCHARACTER) && (rbt != FFEINFO_basictypeCHARACTER))
10347 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10348 && ffebad_start (FFEBAD_CONCAT_ARGS_TYPE))
10350 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10351 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10352 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10356 else if (lbt != FFEINFO_basictypeCHARACTER)
10358 if ((lbt != FFEINFO_basictypeANY)
10359 && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
10361 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10362 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10366 else if (rbt != FFEINFO_basictypeCHARACTER)
10368 if ((rbt != FFEINFO_basictypeANY)
10369 && ffebad_start (FFEBAD_CONCAT_ARG_TYPE))
10371 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10372 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10376 else if ((lrk != 0) || (lszm == FFETARGET_charactersizeNONE))
10378 if ((lkd != FFEINFO_kindANY)
10379 && ffebad_start (FFEBAD_CONCAT_ARG_KIND))
10386 what = "of indeterminate length";
10387 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10388 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10389 ffebad_string (what);
10395 if (ffebad_start (FFEBAD_CONCAT_ARG_KIND))
10402 what = "of indeterminate length";
10403 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10404 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10405 ffebad_string (what);
10410 reduced = ffebld_new_any ();
10411 ffebld_set_info (reduced, ffeinfo_new_any ());
10415 /* ffeexpr_reduced_eqop2_ -- Wrap up reduction of EQ and NE operators
10417 reduced = ffeexpr_reduced_eqop2_(reduced,l,op,r);
10419 Makes sure the left and right arguments for reduced have basictype of
10420 INTEGER, REAL, COMPLEX, or CHARACTER. Determine common basictype and
10421 size for reduction. If both left
10422 and right arguments have where of CONSTANT, assign where CONSTANT to
10423 reduced, else assign where FLEETING. Create CONVERT ops for args where
10424 needed. Convert typeless
10425 constants to the desired type/size explicitly.
10427 If these requirements cannot be met, generate error message. */
10430 ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10433 ffeinfo linfo, rinfo, ninfo;
10434 ffeinfoBasictype lbt, rbt, nbt;
10435 ffeinfoKindtype lkt, rkt, nkt;
10436 ffeinfoRank lrk, rrk;
10437 ffeinfoKind lkd, rkd;
10438 ffeinfoWhere lwh, rwh, nwh;
10439 ffetargetCharacterSize lsz, rsz;
10441 linfo = ffebld_info (ffebld_left (reduced));
10442 lbt = ffeinfo_basictype (linfo);
10443 lkt = ffeinfo_kindtype (linfo);
10444 lrk = ffeinfo_rank (linfo);
10445 lkd = ffeinfo_kind (linfo);
10446 lwh = ffeinfo_where (linfo);
10447 lsz = ffebld_size_known (ffebld_left (reduced));
10449 rinfo = ffebld_info (ffebld_right (reduced));
10450 rbt = ffeinfo_basictype (rinfo);
10451 rkt = ffeinfo_kindtype (rinfo);
10452 rrk = ffeinfo_rank (rinfo);
10453 rkd = ffeinfo_kind (rinfo);
10454 rwh = ffeinfo_where (rinfo);
10455 rsz = ffebld_size_known (ffebld_right (reduced));
10457 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10459 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10460 || (nbt == FFEINFO_basictypeCOMPLEX) || (nbt == FFEINFO_basictypeCHARACTER))
10461 && (lrk == 0) && (rrk == 0))
10465 case FFEINFO_whereCONSTANT:
10468 case FFEINFO_whereCONSTANT:
10469 nwh = FFEINFO_whereCONSTANT;
10472 case FFEINFO_whereIMMEDIATE:
10473 nwh = FFEINFO_whereIMMEDIATE;
10477 nwh = FFEINFO_whereFLEETING;
10482 case FFEINFO_whereIMMEDIATE:
10485 case FFEINFO_whereCONSTANT:
10486 case FFEINFO_whereIMMEDIATE:
10487 nwh = FFEINFO_whereIMMEDIATE;
10491 nwh = FFEINFO_whereFLEETING;
10497 nwh = FFEINFO_whereFLEETING;
10501 if ((lsz != FFETARGET_charactersizeNONE)
10502 && (rsz != FFETARGET_charactersizeNONE))
10503 lsz = rsz = (lsz > rsz) ? lsz : rsz;
10505 ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
10506 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
10507 ffebld_set_info (reduced, ninfo);
10508 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10509 l->token, op->token, nbt, nkt, 0, lsz,
10510 FFEEXPR_contextLET));
10511 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10512 r->token, op->token, nbt, nkt, 0, rsz,
10513 FFEEXPR_contextLET));
10517 if ((lbt == FFEINFO_basictypeLOGICAL)
10518 && (rbt == FFEINFO_basictypeLOGICAL))
10520 if (ffebad_start_msg ("Use .EQV./.NEQV. instead of .EQ./.NE. at %0 for LOGICAL operands at %1 and %2",
10521 FFEBAD_severityFATAL))
10523 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10524 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10525 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10529 else if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10530 && (lbt != FFEINFO_basictypeCOMPLEX) && (lbt != FFEINFO_basictypeCHARACTER))
10532 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10533 && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
10535 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10536 && ffebad_start (FFEBAD_EQOP_ARGS_TYPE))
10538 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10539 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10540 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10546 if ((lbt != FFEINFO_basictypeANY)
10547 && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
10549 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10550 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10555 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10556 && (rbt != FFEINFO_basictypeCOMPLEX) && (rbt != FFEINFO_basictypeCHARACTER))
10558 if ((rbt != FFEINFO_basictypeANY)
10559 && ffebad_start (FFEBAD_EQOP_ARG_TYPE))
10561 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10562 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10568 if ((lkd != FFEINFO_kindANY)
10569 && ffebad_start (FFEBAD_EQOP_ARG_KIND))
10571 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10572 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10573 ffebad_string ("an array");
10579 if ((rkd != FFEINFO_kindANY)
10580 && ffebad_start (FFEBAD_EQOP_ARG_KIND))
10582 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10583 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10584 ffebad_string ("an array");
10589 reduced = ffebld_new_any ();
10590 ffebld_set_info (reduced, ffeinfo_new_any ());
10594 /* ffeexpr_reduced_math1_ -- Wrap up reduction of + - unary operators
10596 reduced = ffeexpr_reduced_math1_(reduced,op,r);
10598 Makes sure the argument for reduced has basictype of
10599 INTEGER, REAL, or COMPLEX. If the argument has where of CONSTANT,
10600 assign where CONSTANT to
10601 reduced, else assign where FLEETING.
10603 If these requirements cannot be met, generate error message. */
10606 ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
10608 ffeinfo rinfo, ninfo;
10609 ffeinfoBasictype rbt;
10610 ffeinfoKindtype rkt;
10613 ffeinfoWhere rwh, nwh;
10615 rinfo = ffebld_info (ffebld_left (reduced));
10616 rbt = ffeinfo_basictype (rinfo);
10617 rkt = ffeinfo_kindtype (rinfo);
10618 rrk = ffeinfo_rank (rinfo);
10619 rkd = ffeinfo_kind (rinfo);
10620 rwh = ffeinfo_where (rinfo);
10622 if (((rbt == FFEINFO_basictypeINTEGER) || (rbt == FFEINFO_basictypeREAL)
10623 || (rbt == FFEINFO_basictypeCOMPLEX)) && (rrk == 0))
10627 case FFEINFO_whereCONSTANT:
10628 nwh = FFEINFO_whereCONSTANT;
10631 case FFEINFO_whereIMMEDIATE:
10632 nwh = FFEINFO_whereIMMEDIATE;
10636 nwh = FFEINFO_whereFLEETING;
10640 ninfo = ffeinfo_new (rbt, rkt, 0, FFEINFO_kindENTITY, nwh,
10641 FFETARGET_charactersizeNONE);
10642 ffebld_set_info (reduced, ninfo);
10646 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10647 && (rbt != FFEINFO_basictypeCOMPLEX))
10649 if ((rbt != FFEINFO_basictypeANY)
10650 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10652 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10653 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10659 if ((rkd != FFEINFO_kindANY)
10660 && ffebad_start (FFEBAD_MATH_ARG_KIND))
10662 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10663 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10664 ffebad_string ("an array");
10669 reduced = ffebld_new_any ();
10670 ffebld_set_info (reduced, ffeinfo_new_any ());
10674 /* ffeexpr_reduced_math2_ -- Wrap up reduction of + - * / operators
10676 reduced = ffeexpr_reduced_math2_(reduced,l,op,r);
10678 Makes sure the left and right arguments for reduced have basictype of
10679 INTEGER, REAL, or COMPLEX. Determine common basictype and
10680 size for reduction (flag expression for combined hollerith/typeless
10681 situations for later determination of effective basictype). If both left
10682 and right arguments have where of CONSTANT, assign where CONSTANT to
10683 reduced, else assign where FLEETING. Create CONVERT ops for args where
10684 needed. Convert typeless
10685 constants to the desired type/size explicitly.
10687 If these requirements cannot be met, generate error message. */
10690 ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10693 ffeinfo linfo, rinfo, ninfo;
10694 ffeinfoBasictype lbt, rbt, nbt;
10695 ffeinfoKindtype lkt, rkt, nkt;
10696 ffeinfoRank lrk, rrk;
10697 ffeinfoKind lkd, rkd;
10698 ffeinfoWhere lwh, rwh, nwh;
10700 linfo = ffebld_info (ffebld_left (reduced));
10701 lbt = ffeinfo_basictype (linfo);
10702 lkt = ffeinfo_kindtype (linfo);
10703 lrk = ffeinfo_rank (linfo);
10704 lkd = ffeinfo_kind (linfo);
10705 lwh = ffeinfo_where (linfo);
10707 rinfo = ffebld_info (ffebld_right (reduced));
10708 rbt = ffeinfo_basictype (rinfo);
10709 rkt = ffeinfo_kindtype (rinfo);
10710 rrk = ffeinfo_rank (rinfo);
10711 rkd = ffeinfo_kind (rinfo);
10712 rwh = ffeinfo_where (rinfo);
10714 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10716 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10717 || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
10721 case FFEINFO_whereCONSTANT:
10724 case FFEINFO_whereCONSTANT:
10725 nwh = FFEINFO_whereCONSTANT;
10728 case FFEINFO_whereIMMEDIATE:
10729 nwh = FFEINFO_whereIMMEDIATE;
10733 nwh = FFEINFO_whereFLEETING;
10738 case FFEINFO_whereIMMEDIATE:
10741 case FFEINFO_whereCONSTANT:
10742 case FFEINFO_whereIMMEDIATE:
10743 nwh = FFEINFO_whereIMMEDIATE;
10747 nwh = FFEINFO_whereFLEETING;
10753 nwh = FFEINFO_whereFLEETING;
10757 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10758 FFETARGET_charactersizeNONE);
10759 ffebld_set_info (reduced, ninfo);
10760 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10761 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10762 FFEEXPR_contextLET));
10763 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10764 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10765 FFEEXPR_contextLET));
10769 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10770 && (lbt != FFEINFO_basictypeCOMPLEX))
10772 if ((rbt != FFEINFO_basictypeINTEGER)
10773 && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
10775 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10776 && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
10778 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10779 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10780 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10786 if ((lbt != FFEINFO_basictypeANY)
10787 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10789 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10790 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10795 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
10796 && (rbt != FFEINFO_basictypeCOMPLEX))
10798 if ((rbt != FFEINFO_basictypeANY)
10799 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10801 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10802 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10808 if ((lkd != FFEINFO_kindANY)
10809 && ffebad_start (FFEBAD_MATH_ARG_KIND))
10811 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10812 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10813 ffebad_string ("an array");
10819 if ((rkd != FFEINFO_kindANY)
10820 && ffebad_start (FFEBAD_MATH_ARG_KIND))
10822 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10823 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10824 ffebad_string ("an array");
10829 reduced = ffebld_new_any ();
10830 ffebld_set_info (reduced, ffeinfo_new_any ());
10834 /* ffeexpr_reduced_power_ -- Wrap up reduction of ** operator
10836 reduced = ffeexpr_reduced_power_(reduced,l,op,r);
10838 Makes sure the left and right arguments for reduced have basictype of
10839 INTEGER, REAL, or COMPLEX. Determine common basictype and
10840 size for reduction (flag expression for combined hollerith/typeless
10841 situations for later determination of effective basictype). If both left
10842 and right arguments have where of CONSTANT, assign where CONSTANT to
10843 reduced, else assign where FLEETING. Create CONVERT ops for args where
10844 needed. Note that real**int or complex**int
10845 comes out as int = real**int etc with no conversions.
10847 If these requirements cannot be met, generate error message using the
10848 info in l, op, and r arguments and assign basictype, size, kind, and where
10852 ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
10855 ffeinfo linfo, rinfo, ninfo;
10856 ffeinfoBasictype lbt, rbt, nbt;
10857 ffeinfoKindtype lkt, rkt, nkt;
10858 ffeinfoRank lrk, rrk;
10859 ffeinfoKind lkd, rkd;
10860 ffeinfoWhere lwh, rwh, nwh;
10862 linfo = ffebld_info (ffebld_left (reduced));
10863 lbt = ffeinfo_basictype (linfo);
10864 lkt = ffeinfo_kindtype (linfo);
10865 lrk = ffeinfo_rank (linfo);
10866 lkd = ffeinfo_kind (linfo);
10867 lwh = ffeinfo_where (linfo);
10869 rinfo = ffebld_info (ffebld_right (reduced));
10870 rbt = ffeinfo_basictype (rinfo);
10871 rkt = ffeinfo_kindtype (rinfo);
10872 rrk = ffeinfo_rank (rinfo);
10873 rkd = ffeinfo_kind (rinfo);
10874 rwh = ffeinfo_where (rinfo);
10876 if ((rbt == FFEINFO_basictypeINTEGER)
10877 && ((lbt == FFEINFO_basictypeREAL)
10878 || (lbt == FFEINFO_basictypeCOMPLEX)))
10881 nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDEFAULT);
10882 if (nkt != FFEINFO_kindtypeREALDEFAULT)
10884 nkt = ffeinfo_kindtype_max (nbt, lkt, FFEINFO_kindtypeREALDOUBLE);
10885 if (nkt != FFEINFO_kindtypeREALDOUBLE)
10886 nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */
10888 if (rkt == FFEINFO_kindtypeINTEGER4)
10890 ffebad_start_msg ("Unsupported operand for ** at %1 -- converting to default INTEGER",
10891 FFEBAD_severityWARNING);
10892 ffebad_here (0, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10895 if (rkt != FFEINFO_kindtypeINTEGERDEFAULT)
10897 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10898 r->token, op->token,
10899 FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT, 0,
10900 FFETARGET_charactersizeNONE,
10901 FFEEXPR_contextLET));
10902 rkt = FFEINFO_kindtypeINTEGERDEFAULT;
10907 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
10909 #if 0 /* INTEGER4**INTEGER4 works now. */
10910 if ((nbt == FFEINFO_basictypeINTEGER)
10911 && (nkt != FFEINFO_kindtypeINTEGERDEFAULT))
10912 nkt = FFEINFO_kindtypeINTEGERDEFAULT; /* Highest kt we can power! */
10914 if (((nbt == FFEINFO_basictypeREAL)
10915 || (nbt == FFEINFO_basictypeCOMPLEX))
10916 && (nkt != FFEINFO_kindtypeREALDEFAULT))
10918 nkt = ffeinfo_kindtype_max (nbt, nkt, FFEINFO_kindtypeREALDOUBLE);
10919 if (nkt != FFEINFO_kindtypeREALDOUBLE)
10920 nkt = FFEINFO_kindtypeREALDOUBLE; /* Highest kt we can power! */
10922 /* else Gonna turn into an error below. */
10925 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
10926 || (nbt == FFEINFO_basictypeCOMPLEX)) && (lrk == 0) && (rrk == 0))
10930 case FFEINFO_whereCONSTANT:
10933 case FFEINFO_whereCONSTANT:
10934 nwh = FFEINFO_whereCONSTANT;
10937 case FFEINFO_whereIMMEDIATE:
10938 nwh = FFEINFO_whereIMMEDIATE;
10942 nwh = FFEINFO_whereFLEETING;
10947 case FFEINFO_whereIMMEDIATE:
10950 case FFEINFO_whereCONSTANT:
10951 case FFEINFO_whereIMMEDIATE:
10952 nwh = FFEINFO_whereIMMEDIATE;
10956 nwh = FFEINFO_whereFLEETING;
10962 nwh = FFEINFO_whereFLEETING;
10966 ninfo = ffeinfo_new (nbt, nkt, 0, FFEINFO_kindENTITY, nwh,
10967 FFETARGET_charactersizeNONE);
10968 ffebld_set_info (reduced, ninfo);
10969 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
10970 l->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10971 FFEEXPR_contextLET));
10972 if (rbt != FFEINFO_basictypeINTEGER)
10973 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
10974 r->token, op->token, nbt, nkt, 0, FFETARGET_charactersizeNONE,
10975 FFEEXPR_contextLET));
10979 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
10980 && (lbt != FFEINFO_basictypeCOMPLEX))
10982 if ((rbt != FFEINFO_basictypeINTEGER)
10983 && (rbt != FFEINFO_basictypeREAL) && (rbt != FFEINFO_basictypeCOMPLEX))
10985 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
10986 && ffebad_start (FFEBAD_MATH_ARGS_TYPE))
10988 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
10989 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
10990 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
10996 if ((lbt != FFEINFO_basictypeANY)
10997 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
10999 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11000 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11005 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
11006 && (rbt != FFEINFO_basictypeCOMPLEX))
11008 if ((rbt != FFEINFO_basictypeANY)
11009 && ffebad_start (FFEBAD_MATH_ARG_TYPE))
11011 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11012 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11018 if ((lkd != FFEINFO_kindANY)
11019 && ffebad_start (FFEBAD_MATH_ARG_KIND))
11021 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11022 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11023 ffebad_string ("an array");
11029 if ((rkd != FFEINFO_kindANY)
11030 && ffebad_start (FFEBAD_MATH_ARG_KIND))
11032 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11033 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11034 ffebad_string ("an array");
11039 reduced = ffebld_new_any ();
11040 ffebld_set_info (reduced, ffeinfo_new_any ());
11044 /* ffeexpr_reduced_relop2_ -- Wrap up reduction of LT, LE, GE, and GT operators
11046 reduced = ffeexpr_reduced_relop2_(reduced,l,op,r);
11048 Makes sure the left and right arguments for reduced have basictype of
11049 INTEGER, REAL, or CHARACTER. Determine common basictype and
11050 size for reduction. If both left
11051 and right arguments have where of CONSTANT, assign where CONSTANT to
11052 reduced, else assign where FLEETING. Create CONVERT ops for args where
11053 needed. Convert typeless
11054 constants to the desired type/size explicitly.
11056 If these requirements cannot be met, generate error message. */
11059 ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
11062 ffeinfo linfo, rinfo, ninfo;
11063 ffeinfoBasictype lbt, rbt, nbt;
11064 ffeinfoKindtype lkt, rkt, nkt;
11065 ffeinfoRank lrk, rrk;
11066 ffeinfoKind lkd, rkd;
11067 ffeinfoWhere lwh, rwh, nwh;
11068 ffetargetCharacterSize lsz, rsz;
11070 linfo = ffebld_info (ffebld_left (reduced));
11071 lbt = ffeinfo_basictype (linfo);
11072 lkt = ffeinfo_kindtype (linfo);
11073 lrk = ffeinfo_rank (linfo);
11074 lkd = ffeinfo_kind (linfo);
11075 lwh = ffeinfo_where (linfo);
11076 lsz = ffebld_size_known (ffebld_left (reduced));
11078 rinfo = ffebld_info (ffebld_right (reduced));
11079 rbt = ffeinfo_basictype (rinfo);
11080 rkt = ffeinfo_kindtype (rinfo);
11081 rrk = ffeinfo_rank (rinfo);
11082 rkd = ffeinfo_kind (rinfo);
11083 rwh = ffeinfo_where (rinfo);
11084 rsz = ffebld_size_known (ffebld_right (reduced));
11086 ffeexpr_type_combine (&nbt, &nkt, lbt, lkt, rbt, rkt, op->token);
11088 if (((nbt == FFEINFO_basictypeINTEGER) || (nbt == FFEINFO_basictypeREAL)
11089 || (nbt == FFEINFO_basictypeCHARACTER))
11090 && (lrk == 0) && (rrk == 0))
11094 case FFEINFO_whereCONSTANT:
11097 case FFEINFO_whereCONSTANT:
11098 nwh = FFEINFO_whereCONSTANT;
11101 case FFEINFO_whereIMMEDIATE:
11102 nwh = FFEINFO_whereIMMEDIATE;
11106 nwh = FFEINFO_whereFLEETING;
11111 case FFEINFO_whereIMMEDIATE:
11114 case FFEINFO_whereCONSTANT:
11115 case FFEINFO_whereIMMEDIATE:
11116 nwh = FFEINFO_whereIMMEDIATE;
11120 nwh = FFEINFO_whereFLEETING;
11126 nwh = FFEINFO_whereFLEETING;
11130 if ((lsz != FFETARGET_charactersizeNONE)
11131 && (rsz != FFETARGET_charactersizeNONE))
11132 lsz = rsz = (lsz > rsz) ? lsz : rsz;
11134 ninfo = ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
11135 0, FFEINFO_kindENTITY, nwh, FFETARGET_charactersizeNONE);
11136 ffebld_set_info (reduced, ninfo);
11137 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11138 l->token, op->token, nbt, nkt, 0, lsz,
11139 FFEEXPR_contextLET));
11140 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11141 r->token, op->token, nbt, nkt, 0, rsz,
11142 FFEEXPR_contextLET));
11146 if ((lbt != FFEINFO_basictypeINTEGER) && (lbt != FFEINFO_basictypeREAL)
11147 && (lbt != FFEINFO_basictypeCHARACTER))
11149 if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
11150 && (rbt != FFEINFO_basictypeCHARACTER))
11152 if ((lbt != FFEINFO_basictypeANY) && (rbt != FFEINFO_basictypeANY)
11153 && ffebad_start (FFEBAD_RELOP_ARGS_TYPE))
11155 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11156 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11157 ffebad_here (2, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11163 if ((lbt != FFEINFO_basictypeANY)
11164 && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
11166 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11167 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11172 else if ((rbt != FFEINFO_basictypeINTEGER) && (rbt != FFEINFO_basictypeREAL)
11173 && (rbt != FFEINFO_basictypeCHARACTER))
11175 if ((rbt != FFEINFO_basictypeANY)
11176 && ffebad_start (FFEBAD_RELOP_ARG_TYPE))
11178 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11179 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11185 if ((lkd != FFEINFO_kindANY)
11186 && ffebad_start (FFEBAD_RELOP_ARG_KIND))
11188 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11189 ffebad_here (1, ffelex_token_where_line (l->token), ffelex_token_where_column (l->token));
11190 ffebad_string ("an array");
11196 if ((rkd != FFEINFO_kindANY)
11197 && ffebad_start (FFEBAD_RELOP_ARG_KIND))
11199 ffebad_here (0, ffelex_token_where_line (op->token), ffelex_token_where_column (op->token));
11200 ffebad_here (1, ffelex_token_where_line (r->token), ffelex_token_where_column (r->token));
11201 ffebad_string ("an array");
11206 reduced = ffebld_new_any ();
11207 ffebld_set_info (reduced, ffeinfo_new_any ());
11211 /* ffeexpr_reduced_ugly1_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
11213 reduced = ffeexpr_reduced_ugly1_(reduced,op,r);
11218 ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
11221 ffeinfoBasictype rbt;
11222 ffeinfoKindtype rkt;
11227 rinfo = ffebld_info (ffebld_left (reduced));
11228 rbt = ffeinfo_basictype (rinfo);
11229 rkt = ffeinfo_kindtype (rinfo);
11230 rrk = ffeinfo_rank (rinfo);
11231 rkd = ffeinfo_kind (rinfo);
11232 rwh = ffeinfo_where (rinfo);
11234 if ((rbt == FFEINFO_basictypeTYPELESS)
11235 || (rbt == FFEINFO_basictypeHOLLERITH))
11237 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11238 r->token, op->token, FFEINFO_basictypeINTEGER,
11239 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11240 FFETARGET_charactersizeNONE,
11241 FFEEXPR_contextLET));
11242 rinfo = ffebld_info (ffebld_left (reduced));
11243 rbt = FFEINFO_basictypeINTEGER;
11244 rkt = FFEINFO_kindtypeINTEGERDEFAULT;
11246 rkd = FFEINFO_kindENTITY;
11247 rwh = ffeinfo_where (rinfo);
11250 if (rbt == FFEINFO_basictypeLOGICAL)
11252 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11253 r->token, op->token, FFEINFO_basictypeINTEGER,
11254 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11255 FFETARGET_charactersizeNONE,
11256 FFEEXPR_contextLET));
11262 /* ffeexpr_reduced_ugly1log_ -- Deal with TYPELESS and HOLLERITH
11264 reduced = ffeexpr_reduced_ugly1log_(reduced,op,r);
11269 ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r)
11272 ffeinfoBasictype rbt;
11273 ffeinfoKindtype rkt;
11278 rinfo = ffebld_info (ffebld_left (reduced));
11279 rbt = ffeinfo_basictype (rinfo);
11280 rkt = ffeinfo_kindtype (rinfo);
11281 rrk = ffeinfo_rank (rinfo);
11282 rkd = ffeinfo_kind (rinfo);
11283 rwh = ffeinfo_where (rinfo);
11285 if ((rbt == FFEINFO_basictypeTYPELESS)
11286 || (rbt == FFEINFO_basictypeHOLLERITH))
11288 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11289 r->token, op->token, FFEINFO_basictypeLOGICAL, 0,
11290 FFEINFO_kindtypeLOGICALDEFAULT,
11291 FFETARGET_charactersizeNONE,
11292 FFEEXPR_contextLET));
11293 rinfo = ffebld_info (ffebld_left (reduced));
11294 rbt = FFEINFO_basictypeLOGICAL;
11295 rkt = FFEINFO_kindtypeLOGICALDEFAULT;
11297 rkd = FFEINFO_kindENTITY;
11298 rwh = ffeinfo_where (rinfo);
11304 /* ffeexpr_reduced_ugly2_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
11306 reduced = ffeexpr_reduced_ugly2_(reduced,l,op,r);
11311 ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
11314 ffeinfo linfo, rinfo;
11315 ffeinfoBasictype lbt, rbt;
11316 ffeinfoKindtype lkt, rkt;
11317 ffeinfoRank lrk, rrk;
11318 ffeinfoKind lkd, rkd;
11319 ffeinfoWhere lwh, rwh;
11321 linfo = ffebld_info (ffebld_left (reduced));
11322 lbt = ffeinfo_basictype (linfo);
11323 lkt = ffeinfo_kindtype (linfo);
11324 lrk = ffeinfo_rank (linfo);
11325 lkd = ffeinfo_kind (linfo);
11326 lwh = ffeinfo_where (linfo);
11328 rinfo = ffebld_info (ffebld_right (reduced));
11329 rbt = ffeinfo_basictype (rinfo);
11330 rkt = ffeinfo_kindtype (rinfo);
11331 rrk = ffeinfo_rank (rinfo);
11332 rkd = ffeinfo_kind (rinfo);
11333 rwh = ffeinfo_where (rinfo);
11335 if ((lbt == FFEINFO_basictypeTYPELESS)
11336 || (lbt == FFEINFO_basictypeHOLLERITH))
11338 if ((rbt == FFEINFO_basictypeTYPELESS)
11339 || (rbt == FFEINFO_basictypeHOLLERITH))
11341 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11342 l->token, op->token, FFEINFO_basictypeINTEGER,
11343 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11344 FFETARGET_charactersizeNONE,
11345 FFEEXPR_contextLET));
11346 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11347 r->token, op->token, FFEINFO_basictypeINTEGER, 0,
11348 FFEINFO_kindtypeINTEGERDEFAULT,
11349 FFETARGET_charactersizeNONE,
11350 FFEEXPR_contextLET));
11351 linfo = ffebld_info (ffebld_left (reduced));
11352 rinfo = ffebld_info (ffebld_right (reduced));
11353 lbt = rbt = FFEINFO_basictypeINTEGER;
11354 lkt = rkt = FFEINFO_kindtypeINTEGERDEFAULT;
11356 lkd = rkd = FFEINFO_kindENTITY;
11357 lwh = ffeinfo_where (linfo);
11358 rwh = ffeinfo_where (rinfo);
11362 ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
11363 l->token, ffebld_right (reduced), r->token,
11364 FFEEXPR_contextLET));
11365 linfo = ffebld_info (ffebld_left (reduced));
11366 lbt = ffeinfo_basictype (linfo);
11367 lkt = ffeinfo_kindtype (linfo);
11368 lrk = ffeinfo_rank (linfo);
11369 lkd = ffeinfo_kind (linfo);
11370 lwh = ffeinfo_where (linfo);
11375 if ((rbt == FFEINFO_basictypeTYPELESS)
11376 || (rbt == FFEINFO_basictypeHOLLERITH))
11378 ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
11379 r->token, ffebld_left (reduced), l->token,
11380 FFEEXPR_contextLET));
11381 rinfo = ffebld_info (ffebld_right (reduced));
11382 rbt = ffeinfo_basictype (rinfo);
11383 rkt = ffeinfo_kindtype (rinfo);
11384 rrk = ffeinfo_rank (rinfo);
11385 rkd = ffeinfo_kind (rinfo);
11386 rwh = ffeinfo_where (rinfo);
11388 /* else Leave it alone. */
11391 if (lbt == FFEINFO_basictypeLOGICAL)
11393 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11394 l->token, op->token, FFEINFO_basictypeINTEGER,
11395 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11396 FFETARGET_charactersizeNONE,
11397 FFEEXPR_contextLET));
11400 if (rbt == FFEINFO_basictypeLOGICAL)
11402 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11403 r->token, op->token, FFEINFO_basictypeINTEGER,
11404 FFEINFO_kindtypeINTEGERDEFAULT, 0,
11405 FFETARGET_charactersizeNONE,
11406 FFEEXPR_contextLET));
11412 /* ffeexpr_reduced_ugly2log_ -- Deal with TYPELESS and HOLLERITH
11414 reduced = ffeexpr_reduced_ugly2log_(reduced,l,op,r);
11419 ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l, ffeexprExpr_ op,
11422 ffeinfo linfo, rinfo;
11423 ffeinfoBasictype lbt, rbt;
11424 ffeinfoKindtype lkt, rkt;
11425 ffeinfoRank lrk, rrk;
11426 ffeinfoKind lkd, rkd;
11427 ffeinfoWhere lwh, rwh;
11429 linfo = ffebld_info (ffebld_left (reduced));
11430 lbt = ffeinfo_basictype (linfo);
11431 lkt = ffeinfo_kindtype (linfo);
11432 lrk = ffeinfo_rank (linfo);
11433 lkd = ffeinfo_kind (linfo);
11434 lwh = ffeinfo_where (linfo);
11436 rinfo = ffebld_info (ffebld_right (reduced));
11437 rbt = ffeinfo_basictype (rinfo);
11438 rkt = ffeinfo_kindtype (rinfo);
11439 rrk = ffeinfo_rank (rinfo);
11440 rkd = ffeinfo_kind (rinfo);
11441 rwh = ffeinfo_where (rinfo);
11443 if ((lbt == FFEINFO_basictypeTYPELESS)
11444 || (lbt == FFEINFO_basictypeHOLLERITH))
11446 if ((rbt == FFEINFO_basictypeTYPELESS)
11447 || (rbt == FFEINFO_basictypeHOLLERITH))
11449 ffebld_set_left (reduced, ffeexpr_convert (ffebld_left (reduced),
11450 l->token, op->token, FFEINFO_basictypeLOGICAL,
11451 FFEINFO_kindtypeLOGICALDEFAULT, 0,
11452 FFETARGET_charactersizeNONE,
11453 FFEEXPR_contextLET));
11454 ffebld_set_right (reduced, ffeexpr_convert (ffebld_right (reduced),
11455 r->token, op->token, FFEINFO_basictypeLOGICAL,
11456 FFEINFO_kindtypeLOGICALDEFAULT, 0,
11457 FFETARGET_charactersizeNONE,
11458 FFEEXPR_contextLET));
11459 linfo = ffebld_info (ffebld_left (reduced));
11460 rinfo = ffebld_info (ffebld_right (reduced));
11461 lbt = rbt = FFEINFO_basictypeLOGICAL;
11462 lkt = rkt = FFEINFO_kindtypeLOGICALDEFAULT;
11464 lkd = rkd = FFEINFO_kindENTITY;
11465 lwh = ffeinfo_where (linfo);
11466 rwh = ffeinfo_where (rinfo);
11470 ffebld_set_left (reduced, ffeexpr_convert_expr (ffebld_left (reduced),
11471 l->token, ffebld_right (reduced), r->token,
11472 FFEEXPR_contextLET));
11473 linfo = ffebld_info (ffebld_left (reduced));
11474 lbt = ffeinfo_basictype (linfo);
11475 lkt = ffeinfo_kindtype (linfo);
11476 lrk = ffeinfo_rank (linfo);
11477 lkd = ffeinfo_kind (linfo);
11478 lwh = ffeinfo_where (linfo);
11483 if ((rbt == FFEINFO_basictypeTYPELESS)
11484 || (rbt == FFEINFO_basictypeHOLLERITH))
11486 ffebld_set_right (reduced, ffeexpr_convert_expr (ffebld_right (reduced),
11487 r->token, ffebld_left (reduced), l->token,
11488 FFEEXPR_contextLET));
11489 rinfo = ffebld_info (ffebld_right (reduced));
11490 rbt = ffeinfo_basictype (rinfo);
11491 rkt = ffeinfo_kindtype (rinfo);
11492 rrk = ffeinfo_rank (rinfo);
11493 rkd = ffeinfo_kind (rinfo);
11494 rwh = ffeinfo_where (rinfo);
11496 /* else Leave it alone. */
11502 /* Fumble through tokens until a nonmatching CLOSE_PAREN, EOS, or SEMICOLON
11505 The idea is to process the tokens as they would be done by normal
11506 expression processing, with the key things being telling the lexer
11507 when hollerith/character constants are about to happen, until the
11508 true closing token is found. */
11510 static ffelexHandler
11511 ffeexpr_find_close_paren_ (ffelexToken t,
11512 ffelexHandler after)
11514 ffeexpr_find_.after = after;
11515 ffeexpr_find_.level = 1;
11516 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11519 static ffelexHandler
11520 ffeexpr_nil_finished_ (ffelexToken t)
11522 switch (ffelex_token_type (t))
11524 case FFELEX_typeCLOSE_PAREN:
11525 if (--ffeexpr_find_.level == 0)
11526 return (ffelexHandler) ffeexpr_find_.after;
11527 return (ffelexHandler) ffeexpr_nil_binary_;
11529 case FFELEX_typeCOMMA:
11530 case FFELEX_typeCOLON:
11531 case FFELEX_typeEQUALS:
11532 case FFELEX_typePOINTS:
11533 return (ffelexHandler) ffeexpr_nil_rhs_;
11536 if (--ffeexpr_find_.level == 0)
11537 return (ffelexHandler) ffeexpr_find_.after (t);
11538 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11542 static ffelexHandler
11543 ffeexpr_nil_rhs_ (ffelexToken t)
11545 switch (ffelex_token_type (t))
11547 case FFELEX_typeQUOTE:
11549 return (ffelexHandler) ffeexpr_nil_quote_;
11550 ffelex_set_expecting_hollerith (-1, '\"',
11551 ffelex_token_where_line (t),
11552 ffelex_token_where_column (t));
11553 return (ffelexHandler) ffeexpr_nil_apostrophe_;
11555 case FFELEX_typeAPOSTROPHE:
11556 ffelex_set_expecting_hollerith (-1, '\'',
11557 ffelex_token_where_line (t),
11558 ffelex_token_where_column (t));
11559 return (ffelexHandler) ffeexpr_nil_apostrophe_;
11561 case FFELEX_typePERCENT:
11562 return (ffelexHandler) ffeexpr_nil_percent_;
11564 case FFELEX_typeOPEN_PAREN:
11565 ++ffeexpr_find_.level;
11566 return (ffelexHandler) ffeexpr_nil_rhs_;
11568 case FFELEX_typePLUS:
11569 case FFELEX_typeMINUS:
11570 return (ffelexHandler) ffeexpr_nil_rhs_;
11572 case FFELEX_typePERIOD:
11573 return (ffelexHandler) ffeexpr_nil_period_;
11575 case FFELEX_typeNUMBER:
11576 ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
11577 if (ffeexpr_hollerith_count_ > 0)
11578 ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
11580 ffelex_token_where_line (t),
11581 ffelex_token_where_column (t));
11582 return (ffelexHandler) ffeexpr_nil_number_;
11584 case FFELEX_typeNAME:
11585 case FFELEX_typeNAMES:
11586 return (ffelexHandler) ffeexpr_nil_name_rhs_;
11588 case FFELEX_typeASTERISK:
11589 case FFELEX_typeSLASH:
11590 case FFELEX_typePOWER:
11591 case FFELEX_typeCONCAT:
11592 case FFELEX_typeREL_EQ:
11593 case FFELEX_typeREL_NE:
11594 case FFELEX_typeREL_LE:
11595 case FFELEX_typeREL_GE:
11596 return (ffelexHandler) ffeexpr_nil_rhs_;
11599 return (ffelexHandler) ffeexpr_nil_finished_ (t);
11603 static ffelexHandler
11604 ffeexpr_nil_period_ (ffelexToken t)
11606 switch (ffelex_token_type (t))
11608 case FFELEX_typeNAME:
11609 case FFELEX_typeNAMES:
11610 ffeexpr_current_dotdot_ = ffestr_other (t);
11611 switch (ffeexpr_current_dotdot_)
11613 case FFESTR_otherNone:
11614 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11616 case FFESTR_otherTRUE:
11617 case FFESTR_otherFALSE:
11618 case FFESTR_otherNOT:
11619 return (ffelexHandler) ffeexpr_nil_end_period_;
11622 return (ffelexHandler) ffeexpr_nil_swallow_period_;
11624 break; /* Nothing really reaches here. */
11626 case FFELEX_typeNUMBER:
11627 return (ffelexHandler) ffeexpr_nil_real_;
11630 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11634 static ffelexHandler
11635 ffeexpr_nil_end_period_ (ffelexToken t)
11637 switch (ffeexpr_current_dotdot_)
11639 case FFESTR_otherNOT:
11640 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11641 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11642 return (ffelexHandler) ffeexpr_nil_rhs_;
11644 case FFESTR_otherTRUE:
11645 case FFESTR_otherFALSE:
11646 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11647 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11648 return (ffelexHandler) ffeexpr_nil_binary_;
11651 assert ("Bad [nil] unary dotdot in ffeexpr_current_dotdot_" == NULL);
11657 static ffelexHandler
11658 ffeexpr_nil_swallow_period_ (ffelexToken t)
11660 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11661 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11662 return (ffelexHandler) ffeexpr_nil_rhs_;
11665 static ffelexHandler
11666 ffeexpr_nil_real_ (ffelexToken t)
11671 if (((ffelex_token_type (t) != FFELEX_typeNAME)
11672 && (ffelex_token_type (t) != FFELEX_typeNAMES))
11673 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11675 || ffesrc_char_match_init (d, 'E', 'e')
11676 || ffesrc_char_match_init (d, 'Q', 'q')))
11677 && ffeexpr_isdigits_ (++p)))
11678 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11681 return (ffelexHandler) ffeexpr_nil_real_exponent_;
11682 return (ffelexHandler) ffeexpr_nil_binary_;
11685 static ffelexHandler
11686 ffeexpr_nil_real_exponent_ (ffelexToken t)
11688 if ((ffelex_token_type (t) != FFELEX_typePLUS)
11689 && (ffelex_token_type (t) != FFELEX_typeMINUS))
11690 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11692 return (ffelexHandler) ffeexpr_nil_real_exp_sign_;
11695 static ffelexHandler
11696 ffeexpr_nil_real_exp_sign_ (ffelexToken t)
11698 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11699 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11700 return (ffelexHandler) ffeexpr_nil_binary_;
11703 static ffelexHandler
11704 ffeexpr_nil_number_ (ffelexToken t)
11709 if (ffeexpr_hollerith_count_ > 0)
11710 ffelex_set_expecting_hollerith (0, '\0',
11711 ffewhere_line_unknown (),
11712 ffewhere_column_unknown ());
11714 switch (ffelex_token_type (t))
11716 case FFELEX_typeNAME:
11717 case FFELEX_typeNAMES:
11718 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11720 || ffesrc_char_match_init (d, 'E', 'e')
11721 || ffesrc_char_match_init (d, 'Q', 'q'))
11722 && ffeexpr_isdigits_ (++p))
11726 ffeexpr_find_.t = ffelex_token_use (t);
11727 return (ffelexHandler) ffeexpr_nil_number_exponent_;
11729 return (ffelexHandler) ffeexpr_nil_binary_;
11733 case FFELEX_typePERIOD:
11734 ffeexpr_find_.t = ffelex_token_use (t);
11735 return (ffelexHandler) ffeexpr_nil_number_period_;
11737 case FFELEX_typeHOLLERITH:
11738 return (ffelexHandler) ffeexpr_nil_binary_;
11743 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11746 /* Expects ffeexpr_find_.t. */
11748 static ffelexHandler
11749 ffeexpr_nil_number_exponent_ (ffelexToken t)
11751 ffelexHandler nexthandler;
11753 if ((ffelex_token_type (t) != FFELEX_typePLUS)
11754 && (ffelex_token_type (t) != FFELEX_typeMINUS))
11757 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
11758 ffelex_token_kill (ffeexpr_find_.t);
11759 return (ffelexHandler) (*nexthandler) (t);
11762 ffelex_token_kill (ffeexpr_find_.t);
11763 return (ffelexHandler) ffeexpr_nil_number_exp_sign_;
11766 static ffelexHandler
11767 ffeexpr_nil_number_exp_sign_ (ffelexToken t)
11769 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11770 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11772 return (ffelexHandler) ffeexpr_nil_binary_;
11775 /* Expects ffeexpr_find_.t. */
11777 static ffelexHandler
11778 ffeexpr_nil_number_period_ (ffelexToken t)
11780 ffelexHandler nexthandler;
11784 switch (ffelex_token_type (t))
11786 case FFELEX_typeNAME:
11787 case FFELEX_typeNAMES:
11788 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11790 || ffesrc_char_match_init (d, 'E', 'e')
11791 || ffesrc_char_match_init (d, 'Q', 'q'))
11792 && ffeexpr_isdigits_ (++p))
11795 return (ffelexHandler) ffeexpr_nil_number_per_exp_;
11796 ffelex_token_kill (ffeexpr_find_.t);
11797 return (ffelexHandler) ffeexpr_nil_binary_;
11800 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
11801 ffelex_token_kill (ffeexpr_find_.t);
11802 return (ffelexHandler) (*nexthandler) (t);
11804 case FFELEX_typeNUMBER:
11805 ffelex_token_kill (ffeexpr_find_.t);
11806 return (ffelexHandler) ffeexpr_nil_number_real_;
11811 ffelex_token_kill (ffeexpr_find_.t);
11812 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11815 /* Expects ffeexpr_find_.t. */
11817 static ffelexHandler
11818 ffeexpr_nil_number_per_exp_ (ffelexToken t)
11820 if ((ffelex_token_type (t) != FFELEX_typePLUS)
11821 && (ffelex_token_type (t) != FFELEX_typeMINUS))
11823 ffelexHandler nexthandler;
11826 = (ffelexHandler) ffeexpr_nil_binary_ (ffeexpr_find_.t);
11827 ffelex_token_kill (ffeexpr_find_.t);
11828 return (ffelexHandler) (*nexthandler) (t);
11831 ffelex_token_kill (ffeexpr_find_.t);
11832 return (ffelexHandler) ffeexpr_nil_num_per_exp_sign_;
11835 static ffelexHandler
11836 ffeexpr_nil_number_real_ (ffelexToken t)
11841 if (((ffelex_token_type (t) != FFELEX_typeNAME)
11842 && (ffelex_token_type (t) != FFELEX_typeNAMES))
11843 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
11845 || ffesrc_char_match_init (d, 'E', 'e')
11846 || ffesrc_char_match_init (d, 'Q', 'q')))
11847 && ffeexpr_isdigits_ (++p)))
11848 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11851 return (ffelexHandler) ffeexpr_nil_number_real_exp_;
11853 return (ffelexHandler) ffeexpr_nil_binary_;
11856 static ffelexHandler
11857 ffeexpr_nil_num_per_exp_sign_ (ffelexToken t)
11859 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11860 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11861 return (ffelexHandler) ffeexpr_nil_binary_;
11864 static ffelexHandler
11865 ffeexpr_nil_number_real_exp_ (ffelexToken t)
11867 if ((ffelex_token_type (t) != FFELEX_typePLUS)
11868 && (ffelex_token_type (t) != FFELEX_typeMINUS))
11869 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11870 return (ffelexHandler) ffeexpr_nil_num_real_exp_sn_;
11873 static ffelexHandler
11874 ffeexpr_nil_num_real_exp_sn_ (ffelexToken t)
11876 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11877 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11878 return (ffelexHandler) ffeexpr_nil_binary_;
11881 static ffelexHandler
11882 ffeexpr_nil_binary_ (ffelexToken t)
11884 switch (ffelex_token_type (t))
11886 case FFELEX_typePLUS:
11887 case FFELEX_typeMINUS:
11888 case FFELEX_typeASTERISK:
11889 case FFELEX_typeSLASH:
11890 case FFELEX_typePOWER:
11891 case FFELEX_typeCONCAT:
11892 case FFELEX_typeOPEN_ANGLE:
11893 case FFELEX_typeCLOSE_ANGLE:
11894 case FFELEX_typeREL_EQ:
11895 case FFELEX_typeREL_NE:
11896 case FFELEX_typeREL_GE:
11897 case FFELEX_typeREL_LE:
11898 return (ffelexHandler) ffeexpr_nil_rhs_;
11900 case FFELEX_typePERIOD:
11901 return (ffelexHandler) ffeexpr_nil_binary_period_;
11904 return (ffelexHandler) ffeexpr_nil_finished_ (t);
11908 static ffelexHandler
11909 ffeexpr_nil_binary_period_ (ffelexToken t)
11911 switch (ffelex_token_type (t))
11913 case FFELEX_typeNAME:
11914 case FFELEX_typeNAMES:
11915 ffeexpr_current_dotdot_ = ffestr_other (t);
11916 switch (ffeexpr_current_dotdot_)
11918 case FFESTR_otherTRUE:
11919 case FFESTR_otherFALSE:
11920 case FFESTR_otherNOT:
11921 return (ffelexHandler) ffeexpr_nil_binary_sw_per_;
11924 return (ffelexHandler) ffeexpr_nil_binary_end_per_;
11926 break; /* Nothing really reaches here. */
11929 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11933 static ffelexHandler
11934 ffeexpr_nil_binary_end_per_ (ffelexToken t)
11936 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11937 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11938 return (ffelexHandler) ffeexpr_nil_rhs_;
11941 static ffelexHandler
11942 ffeexpr_nil_binary_sw_per_ (ffelexToken t)
11944 if (ffelex_token_type (t) != FFELEX_typePERIOD)
11945 return (ffelexHandler) ffeexpr_nil_binary_ (t);
11946 return (ffelexHandler) ffeexpr_nil_binary_;
11949 static ffelexHandler
11950 ffeexpr_nil_quote_ (ffelexToken t)
11952 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
11953 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11954 return (ffelexHandler) ffeexpr_nil_binary_;
11957 static ffelexHandler
11958 ffeexpr_nil_apostrophe_ (ffelexToken t)
11960 assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
11961 return (ffelexHandler) ffeexpr_nil_apos_char_;
11964 static ffelexHandler
11965 ffeexpr_nil_apos_char_ (ffelexToken t)
11969 if ((ffelex_token_type (t) == FFELEX_typeNAME)
11970 || (ffelex_token_type (t) == FFELEX_typeNAMES))
11972 if ((ffelex_token_length (t) == 1)
11973 && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]),
11975 || ffesrc_char_match_init (c, 'O', 'o')
11976 || ffesrc_char_match_init (c, 'X', 'x')
11977 || ffesrc_char_match_init (c, 'Z', 'z')))
11978 return (ffelexHandler) ffeexpr_nil_binary_;
11980 if ((ffelex_token_type (t) == FFELEX_typeNAME)
11981 || (ffelex_token_type (t) == FFELEX_typeNAMES))
11982 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
11983 return (ffelexHandler) ffeexpr_nil_substrp_ (t);
11986 static ffelexHandler
11987 ffeexpr_nil_name_rhs_ (ffelexToken t)
11989 switch (ffelex_token_type (t))
11991 case FFELEX_typeQUOTE:
11992 case FFELEX_typeAPOSTROPHE:
11993 ffelex_set_hexnum (TRUE);
11994 return (ffelexHandler) ffeexpr_nil_name_apos_;
11996 case FFELEX_typeOPEN_PAREN:
11997 ++ffeexpr_find_.level;
11998 return (ffelexHandler) ffeexpr_nil_rhs_;
12001 return (ffelexHandler) ffeexpr_nil_binary_ (t);
12005 static ffelexHandler
12006 ffeexpr_nil_name_apos_ (ffelexToken t)
12008 if (ffelex_token_type (t) == FFELEX_typeNAME)
12009 return (ffelexHandler) ffeexpr_nil_name_apos_name_;
12010 return (ffelexHandler) ffeexpr_nil_binary_ (t);
12013 static ffelexHandler
12014 ffeexpr_nil_name_apos_name_ (ffelexToken t)
12016 switch (ffelex_token_type (t))
12018 case FFELEX_typeAPOSTROPHE:
12019 case FFELEX_typeQUOTE:
12020 return (ffelexHandler) ffeexpr_nil_finished_;
12023 return (ffelexHandler) ffeexpr_nil_finished_ (t);
12027 static ffelexHandler
12028 ffeexpr_nil_percent_ (ffelexToken t)
12030 switch (ffelex_token_type (t))
12032 case FFELEX_typeNAME:
12033 case FFELEX_typeNAMES:
12034 ffeexpr_stack_->percent = ffeexpr_percent_ (t);
12035 ffeexpr_find_.t = ffelex_token_use (t);
12036 return (ffelexHandler) ffeexpr_nil_percent_name_;
12039 return (ffelexHandler) ffeexpr_nil_rhs_ (t);
12043 /* Expects ffeexpr_find_.t. */
12045 static ffelexHandler
12046 ffeexpr_nil_percent_name_ (ffelexToken t)
12048 ffelexHandler nexthandler;
12050 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
12053 = (ffelexHandler) ffeexpr_nil_rhs_ (ffeexpr_find_.t);
12054 ffelex_token_kill (ffeexpr_find_.t);
12055 return (ffelexHandler) (*nexthandler) (t);
12058 ffelex_token_kill (ffeexpr_find_.t);
12059 ++ffeexpr_find_.level;
12060 return (ffelexHandler) ffeexpr_nil_rhs_;
12063 static ffelexHandler
12064 ffeexpr_nil_substrp_ (ffelexToken t)
12066 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
12067 return (ffelexHandler) ffeexpr_nil_binary_ (t);
12069 ++ffeexpr_find_.level;
12070 return (ffelexHandler) ffeexpr_nil_rhs_;
12073 /* ffeexpr_finished_ -- Reduce expression stack to one expr, finish
12076 return ffeexpr_finished_(t);
12078 Reduces expression stack to one (or zero) elements by repeatedly reducing
12079 the top operator on the stack (or, if the top element on the stack is
12080 itself an operator, issuing an error message and discarding it). Calls
12081 finishing routine with the expression, returning the ffelexHandler it
12082 returns to the caller. */
12084 static ffelexHandler
12085 ffeexpr_finished_ (ffelexToken t)
12087 ffeexprExpr_ operand; /* This is B in -B or A+B. */
12089 ffeexprCallback callback;
12091 ffebldConstant constnode; /* For detecting magical number. */
12092 ffelexToken ft; /* Temporary copy of first token in
12094 ffelexHandler next;
12096 bool error = FALSE;
12098 while (((operand = ffeexpr_stack_->exprstack) != NULL)
12099 && ((operand->previous != NULL) || (operand->type != FFEEXPR_exprtypeOPERAND_)))
12101 if (operand->type == FFEEXPR_exprtypeOPERAND_)
12102 ffeexpr_reduce_ ();
12105 if (ffest_ffebad_start (FFEBAD_MISSING_OPERAND_FOR_OPERATOR))
12107 ffebad_here (0, ffelex_token_where_line (t),
12108 ffelex_token_where_column (t));
12109 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
12110 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
12113 ffeexpr_stack_->exprstack = operand->previous; /* Pop the useless
12115 ffeexpr_expr_kill_ (operand);
12119 assert ((operand == NULL) || (operand->previous == NULL));
12121 ffebld_pool_pop ();
12122 if (operand == NULL)
12126 expr = operand->u.operand;
12127 info = ffebld_info (expr);
12128 if ((ffebld_op (expr) == FFEBLD_opCONTER)
12129 && (ffebld_conter_orig (expr) == NULL)
12130 && ffebld_constant_is_magical (constnode = ffebld_conter (expr)))
12132 ffetarget_integer_bad_magical (operand->token);
12134 ffeexpr_expr_kill_ (operand);
12135 ffeexpr_stack_->exprstack = NULL;
12138 ft = ffeexpr_stack_->first_token;
12140 again: /* :::::::::::::::::::: */
12141 switch (ffeexpr_stack_->context)
12143 case FFEEXPR_contextLET:
12144 case FFEEXPR_contextSFUNCDEF:
12145 error = (expr == NULL)
12146 || (ffeinfo_rank (info) != 0);
12149 case FFEEXPR_contextPAREN_:
12150 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12152 switch (ffeinfo_basictype (info))
12154 case FFEINFO_basictypeHOLLERITH:
12155 case FFEINFO_basictypeTYPELESS:
12156 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12157 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12158 FFEEXPR_contextLET);
12166 case FFEEXPR_contextPARENFILENUM_:
12167 if (ffelex_token_type (t) != FFELEX_typeCOMMA)
12168 ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
12170 ffeexpr_stack_->context = FFEEXPR_contextFILENUM;
12171 goto again; /* :::::::::::::::::::: */
12173 case FFEEXPR_contextPARENFILEUNIT_:
12174 if (ffelex_token_type (t) != FFELEX_typeCOMMA)
12175 ffeexpr_stack_->context = FFEEXPR_contextPAREN_;
12177 ffeexpr_stack_->context = FFEEXPR_contextFILEUNIT;
12178 goto again; /* :::::::::::::::::::: */
12180 case FFEEXPR_contextACTUALARGEXPR_:
12181 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
12182 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12183 : ffeinfo_basictype (info))
12185 case FFEINFO_basictypeHOLLERITH:
12186 case FFEINFO_basictypeTYPELESS:
12187 if (!ffe_is_ugly_args ()
12188 && ffebad_start (FFEBAD_ACTUALARG))
12190 ffebad_here (0, ffelex_token_where_line (ft),
12191 ffelex_token_where_column (ft));
12199 error = (expr != NULL) && (ffeinfo_rank (info) != 0);
12202 case FFEEXPR_contextACTUALARG_:
12203 case FFEEXPR_contextSFUNCDEFACTUALARG_:
12204 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12205 : ffeinfo_basictype (info))
12207 case FFEINFO_basictypeHOLLERITH:
12208 case FFEINFO_basictypeTYPELESS:
12209 #if 0 /* Should never get here. */
12210 expr = ffeexpr_convert (expr, ft, ft,
12211 FFEINFO_basictypeINTEGER,
12212 FFEINFO_kindtypeINTEGERDEFAULT,
12214 FFETARGET_charactersizeNONE,
12215 FFEEXPR_contextLET);
12217 assert ("why hollerith/typeless in actualarg_?" == NULL);
12224 switch ((expr == NULL) ? FFEBLD_opANY : ffebld_op (expr))
12226 case FFEBLD_opSYMTER:
12227 case FFEBLD_opPERCENT_LOC:
12228 case FFEBLD_opPERCENT_VAL:
12229 case FFEBLD_opPERCENT_REF:
12230 case FFEBLD_opPERCENT_DESCR:
12235 error = (expr != NULL) && (ffeinfo_rank (info) != 0);
12240 ffeinfoWhere where;
12245 && (ffebld_op (expr) == FFEBLD_opSYMTER)
12246 && ((s = ffebld_symter (expr)), (where = ffesymbol_where (s)),
12247 (where == FFEINFO_whereINTRINSIC)
12248 || (where == FFEINFO_whereGLOBAL)
12249 || ((where == FFEINFO_whereDUMMY)
12250 && ((kind = ffesymbol_kind (s)),
12251 (kind == FFEINFO_kindFUNCTION)
12252 || (kind == FFEINFO_kindSUBROUTINE))))
12253 && !ffesymbol_explicitwhere (s))
12255 ffebad_start (where == FFEINFO_whereINTRINSIC
12256 ? FFEBAD_NEED_INTRINSIC : FFEBAD_NEED_EXTERNAL);
12257 ffebad_here (0, ffelex_token_where_line (ft),
12258 ffelex_token_where_column (ft));
12259 ffebad_string (ffesymbol_text (s));
12261 ffesymbol_signal_change (s);
12262 ffesymbol_set_explicitwhere (s, TRUE);
12263 ffesymbol_signal_unreported (s);
12268 case FFEEXPR_contextINDEX_:
12269 case FFEEXPR_contextSFUNCDEFINDEX_:
12270 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12272 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12273 : ffeinfo_basictype (info))
12275 case FFEINFO_basictypeNONE:
12279 case FFEINFO_basictypeLOGICAL:
12280 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12281 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12282 FFEEXPR_contextLET);
12283 /* Fall through. */
12284 case FFEINFO_basictypeREAL:
12285 case FFEINFO_basictypeCOMPLEX:
12286 if (ffe_is_pedantic ())
12291 /* Fall through. */
12292 case FFEINFO_basictypeHOLLERITH:
12293 case FFEINFO_basictypeTYPELESS:
12295 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12296 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12297 FFEEXPR_contextLET);
12300 case FFEINFO_basictypeINTEGER:
12301 /* Specifically, allow INTEGER(KIND=2), aka INTEGER*8, through
12302 unmolested. Leave it to downstream to handle kinds. */
12309 break; /* expr==NULL ok for substring; element case
12310 caught by callback. */
12312 case FFEEXPR_contextRETURN:
12313 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12315 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12316 : ffeinfo_basictype (info))
12318 case FFEINFO_basictypeNONE:
12322 case FFEINFO_basictypeLOGICAL:
12323 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12324 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12325 FFEEXPR_contextLET);
12326 /* Fall through. */
12327 case FFEINFO_basictypeREAL:
12328 case FFEINFO_basictypeCOMPLEX:
12329 if (ffe_is_pedantic ())
12334 /* Fall through. */
12335 case FFEINFO_basictypeINTEGER:
12336 case FFEINFO_basictypeHOLLERITH:
12337 case FFEINFO_basictypeTYPELESS:
12339 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12340 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12341 FFEEXPR_contextLET);
12350 case FFEEXPR_contextDO:
12351 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12353 switch (ffeinfo_basictype (info))
12355 case FFEINFO_basictypeLOGICAL:
12356 error = !ffe_is_ugly_logint ();
12357 if (!ffeexpr_stack_->is_rhs)
12358 break; /* Don't convert lhs variable. */
12359 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12360 ffeinfo_kindtype (ffebld_info (expr)), 0,
12361 FFETARGET_charactersizeNONE,
12362 FFEEXPR_contextLET);
12365 case FFEINFO_basictypeHOLLERITH:
12366 case FFEINFO_basictypeTYPELESS:
12367 if (!ffeexpr_stack_->is_rhs)
12370 break; /* Don't convert lhs variable. */
12374 case FFEINFO_basictypeINTEGER:
12375 case FFEINFO_basictypeREAL:
12382 if (!ffeexpr_stack_->is_rhs
12383 && (ffebld_op (expr) != FFEBLD_opSYMTER))
12387 case FFEEXPR_contextDOWHILE:
12388 case FFEEXPR_contextIF:
12389 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12391 switch (ffeinfo_basictype (info))
12393 case FFEINFO_basictypeINTEGER:
12395 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12396 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12397 FFEEXPR_contextLET);
12398 /* Fall through. */
12399 case FFEINFO_basictypeLOGICAL:
12400 case FFEINFO_basictypeHOLLERITH:
12401 case FFEINFO_basictypeTYPELESS:
12403 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12404 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12405 FFEEXPR_contextLET);
12414 case FFEEXPR_contextASSIGN:
12415 case FFEEXPR_contextAGOTO:
12416 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12417 : ffeinfo_basictype (info))
12419 case FFEINFO_basictypeINTEGER:
12420 error = (ffeinfo_kindtype (info) != ffecom_label_kind ());
12423 case FFEINFO_basictypeLOGICAL:
12424 error = !ffe_is_ugly_logint ()
12425 || (ffeinfo_kindtype (info) != ffecom_label_kind ());
12432 if ((expr == NULL) || (ffeinfo_rank (info) != 0)
12433 || (ffebld_op (expr) != FFEBLD_opSYMTER))
12437 case FFEEXPR_contextCGOTO:
12438 case FFEEXPR_contextFORMAT:
12439 case FFEEXPR_contextDIMLIST:
12440 case FFEEXPR_contextFILENUM: /* See equiv code in _ambig_. */
12441 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12443 switch (ffeinfo_basictype (info))
12445 case FFEINFO_basictypeLOGICAL:
12446 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12447 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12448 FFEEXPR_contextLET);
12449 /* Fall through. */
12450 case FFEINFO_basictypeREAL:
12451 case FFEINFO_basictypeCOMPLEX:
12452 if (ffe_is_pedantic ())
12457 /* Fall through. */
12458 case FFEINFO_basictypeINTEGER:
12459 case FFEINFO_basictypeHOLLERITH:
12460 case FFEINFO_basictypeTYPELESS:
12462 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12463 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12464 FFEEXPR_contextLET);
12473 case FFEEXPR_contextARITHIF:
12474 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12476 switch (ffeinfo_basictype (info))
12478 case FFEINFO_basictypeLOGICAL:
12479 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12480 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12481 FFEEXPR_contextLET);
12482 if (ffe_is_pedantic ())
12487 /* Fall through. */
12488 case FFEINFO_basictypeHOLLERITH:
12489 case FFEINFO_basictypeTYPELESS:
12490 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12491 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12492 FFEEXPR_contextLET);
12493 /* Fall through. */
12494 case FFEINFO_basictypeINTEGER:
12495 case FFEINFO_basictypeREAL:
12505 case FFEEXPR_contextSTOP:
12506 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12508 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12509 : ffeinfo_basictype (info))
12511 case FFEINFO_basictypeINTEGER:
12512 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12515 case FFEINFO_basictypeCHARACTER:
12516 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT);
12519 case FFEINFO_basictypeHOLLERITH:
12520 case FFEINFO_basictypeTYPELESS:
12522 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12523 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12524 FFEEXPR_contextLET);
12527 case FFEINFO_basictypeNONE:
12535 if ((expr != NULL) && ((ffebld_op (expr) != FFEBLD_opCONTER)
12536 || (ffebld_conter_orig (expr) != NULL)))
12540 case FFEEXPR_contextINCLUDE:
12541 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12542 || (ffeinfo_basictype (info) != FFEINFO_basictypeCHARACTER)
12543 || (ffebld_op (expr) != FFEBLD_opCONTER)
12544 || (ffebld_conter_orig (expr) != NULL);
12547 case FFEEXPR_contextSELECTCASE:
12548 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12550 switch (ffeinfo_basictype (info))
12552 case FFEINFO_basictypeINTEGER:
12553 case FFEINFO_basictypeCHARACTER:
12554 case FFEINFO_basictypeLOGICAL:
12558 case FFEINFO_basictypeHOLLERITH:
12559 case FFEINFO_basictypeTYPELESS:
12561 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12562 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12563 FFEEXPR_contextLET);
12572 case FFEEXPR_contextCASE:
12573 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12575 switch ((expr == NULL) ? FFEINFO_basictypeINTEGER
12576 : ffeinfo_basictype (info))
12578 case FFEINFO_basictypeINTEGER:
12579 case FFEINFO_basictypeCHARACTER:
12580 case FFEINFO_basictypeLOGICAL:
12584 case FFEINFO_basictypeHOLLERITH:
12585 case FFEINFO_basictypeTYPELESS:
12587 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12588 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12589 FFEEXPR_contextLET);
12596 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12600 case FFEEXPR_contextCHARACTERSIZE:
12601 case FFEEXPR_contextKINDTYPE:
12602 case FFEEXPR_contextDIMLISTCOMMON:
12603 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12605 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12606 : ffeinfo_basictype (info))
12608 case FFEINFO_basictypeLOGICAL:
12609 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12610 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12611 FFEEXPR_contextLET);
12612 /* Fall through. */
12613 case FFEINFO_basictypeREAL:
12614 case FFEINFO_basictypeCOMPLEX:
12615 if (ffe_is_pedantic ())
12620 /* Fall through. */
12621 case FFEINFO_basictypeINTEGER:
12622 case FFEINFO_basictypeHOLLERITH:
12623 case FFEINFO_basictypeTYPELESS:
12625 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12626 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12627 FFEEXPR_contextLET);
12634 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12638 case FFEEXPR_contextEQVINDEX_:
12639 if ((error = (expr != NULL) && (ffeinfo_rank (info) != 0)))
12641 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12642 : ffeinfo_basictype (info))
12644 case FFEINFO_basictypeNONE:
12648 case FFEINFO_basictypeLOGICAL:
12649 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12650 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12651 FFEEXPR_contextLET);
12652 /* Fall through. */
12653 case FFEINFO_basictypeREAL:
12654 case FFEINFO_basictypeCOMPLEX:
12655 if (ffe_is_pedantic ())
12660 /* Fall through. */
12661 case FFEINFO_basictypeINTEGER:
12662 case FFEINFO_basictypeHOLLERITH:
12663 case FFEINFO_basictypeTYPELESS:
12665 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12666 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12667 FFEEXPR_contextLET);
12674 if ((expr != NULL) && (ffebld_op (expr) != FFEBLD_opCONTER))
12678 case FFEEXPR_contextPARAMETER:
12679 if (ffeexpr_stack_->is_rhs)
12680 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12681 || (ffebld_op (expr) != FFEBLD_opCONTER);
12683 error = (expr == NULL) || (ffeinfo_rank (info) != 0)
12684 || (ffebld_op (expr) != FFEBLD_opSYMTER);
12687 case FFEEXPR_contextINDEXORACTUALARG_:
12688 if (ffelex_token_type (t) == FFELEX_typeCOLON)
12689 ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
12691 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
12692 goto again; /* :::::::::::::::::::: */
12694 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
12695 if (ffelex_token_type (t) == FFELEX_typeCOLON)
12696 ffeexpr_stack_->context = FFEEXPR_contextINDEX_;
12698 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
12699 goto again; /* :::::::::::::::::::: */
12701 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
12702 if (ffelex_token_type (t) == FFELEX_typeCOLON)
12703 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
12705 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
12706 goto again; /* :::::::::::::::::::: */
12708 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
12709 if (ffelex_token_type (t) == FFELEX_typeCOLON)
12710 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFINDEX_;
12712 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
12713 goto again; /* :::::::::::::::::::: */
12715 case FFEEXPR_contextIMPDOCTRL_:
12716 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12718 if (!ffeexpr_stack_->is_rhs
12719 && (ffebld_op (expr) != FFEBLD_opSYMTER))
12721 switch (ffeinfo_basictype (info))
12723 case FFEINFO_basictypeLOGICAL:
12724 if (! ffe_is_ugly_logint ())
12726 if (! ffeexpr_stack_->is_rhs)
12728 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12729 ffeinfo_kindtype (info), 0,
12730 FFETARGET_charactersizeNONE,
12731 FFEEXPR_contextLET);
12734 case FFEINFO_basictypeINTEGER:
12735 case FFEINFO_basictypeHOLLERITH:
12736 case FFEINFO_basictypeTYPELESS:
12739 case FFEINFO_basictypeREAL:
12740 if (!ffeexpr_stack_->is_rhs
12741 && ffe_is_warn_surprising ()
12744 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
12745 ffebad_here (0, ffelex_token_where_line (ft),
12746 ffelex_token_where_column (ft));
12747 ffebad_string (ffelex_token_text (ft));
12758 case FFEEXPR_contextDATAIMPDOCTRL_:
12759 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12761 if (ffeexpr_stack_->is_rhs)
12763 if ((ffebld_op (expr) != FFEBLD_opCONTER)
12764 && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12767 else if ((ffebld_op (expr) != FFEBLD_opSYMTER)
12768 || (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12770 switch (ffeinfo_basictype (info))
12772 case FFEINFO_basictypeLOGICAL:
12773 if (! ffeexpr_stack_->is_rhs)
12775 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12776 ffeinfo_kindtype (info), 0,
12777 FFETARGET_charactersizeNONE,
12778 FFEEXPR_contextLET);
12779 /* Fall through. */
12780 case FFEINFO_basictypeINTEGER:
12781 if (ffeexpr_stack_->is_rhs
12782 && (ffeinfo_kindtype (ffebld_info (expr))
12783 != FFEINFO_kindtypeINTEGERDEFAULT))
12784 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12785 FFEINFO_kindtypeINTEGERDEFAULT, 0,
12786 FFETARGET_charactersizeNONE,
12787 FFEEXPR_contextLET);
12790 case FFEINFO_basictypeHOLLERITH:
12791 case FFEINFO_basictypeTYPELESS:
12792 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12793 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12794 FFEEXPR_contextLET);
12797 case FFEINFO_basictypeREAL:
12798 if (!ffeexpr_stack_->is_rhs
12799 && ffe_is_warn_surprising ()
12802 ffebad_start (FFEBAD_DO_REAL); /* See error message!!! */
12803 ffebad_here (0, ffelex_token_where_line (ft),
12804 ffelex_token_where_column (ft));
12805 ffebad_string (ffelex_token_text (ft));
12816 case FFEEXPR_contextIMPDOITEM_:
12817 if (ffelex_token_type (t) == FFELEX_typeEQUALS)
12819 ffeexpr_stack_->is_rhs = FALSE;
12820 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
12821 goto again; /* :::::::::::::::::::: */
12823 /* Fall through. */
12824 case FFEEXPR_contextIOLIST:
12825 case FFEEXPR_contextFILEVXTCODE:
12826 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12827 : ffeinfo_basictype (info))
12829 case FFEINFO_basictypeHOLLERITH:
12830 case FFEINFO_basictypeTYPELESS:
12831 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12832 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12833 FFEEXPR_contextLET);
12839 error = (expr == NULL)
12840 || ((ffeinfo_rank (info) != 0)
12841 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12842 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12843 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12844 == FFEBLD_opSTAR))); /* Bad if null expr, or if
12845 array that is not a SYMTER
12846 (can't happen yet, I
12847 think) or has a NULL or
12848 STAR (assumed) array
12852 case FFEEXPR_contextIMPDOITEMDF_:
12853 if (ffelex_token_type (t) == FFELEX_typeEQUALS)
12855 ffeexpr_stack_->is_rhs = FALSE;
12856 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
12857 goto again; /* :::::::::::::::::::: */
12859 /* Fall through. */
12860 case FFEEXPR_contextIOLISTDF:
12861 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12862 : ffeinfo_basictype (info))
12864 case FFEINFO_basictypeHOLLERITH:
12865 case FFEINFO_basictypeTYPELESS:
12866 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12867 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12868 FFEEXPR_contextLET);
12876 || ((ffeinfo_basictype (info) == FFEINFO_basictypeCHARACTER)
12877 && (ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT))
12878 || ((ffeinfo_rank (info) != 0)
12879 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
12880 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
12881 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
12882 == FFEBLD_opSTAR))); /* Bad if null expr,
12883 non-default-kindtype
12884 character expr, or if
12885 array that is not a SYMTER
12886 (can't happen yet, I
12887 think) or has a NULL or
12888 STAR (assumed) array
12892 case FFEEXPR_contextDATAIMPDOITEM_:
12893 error = (expr == NULL)
12894 || (ffebld_op (expr) != FFEBLD_opARRAYREF)
12895 || ((ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR)
12896 && (ffeinfo_where (info) != FFEINFO_whereFLEETING_IADDR));
12899 case FFEEXPR_contextDATAIMPDOINDEX_:
12900 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
12902 switch (ffeinfo_basictype (info))
12904 case FFEINFO_basictypeLOGICAL:
12905 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
12906 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
12907 FFEEXPR_contextLET);
12908 /* Fall through. */
12909 case FFEINFO_basictypeREAL:
12910 case FFEINFO_basictypeCOMPLEX:
12911 if (ffe_is_pedantic ())
12916 /* Fall through. */
12917 case FFEINFO_basictypeINTEGER:
12918 case FFEINFO_basictypeHOLLERITH:
12919 case FFEINFO_basictypeTYPELESS:
12921 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
12922 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
12923 FFEEXPR_contextLET);
12930 if ((ffeinfo_where (info) != FFEINFO_whereCONSTANT)
12931 && (ffeinfo_where (info) != FFEINFO_whereIMMEDIATE))
12935 case FFEEXPR_contextDATA:
12938 else if (ffeexpr_stack_->is_rhs)
12939 error = (ffebld_op (expr) != FFEBLD_opCONTER);
12940 else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12943 error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12946 case FFEEXPR_contextINITVAL:
12947 error = (expr == NULL) || (ffebld_op (expr) != FFEBLD_opCONTER);
12950 case FFEEXPR_contextEQUIVALENCE:
12953 else if (ffebld_op (expr) == FFEBLD_opSYMTER)
12956 error = (ffeinfo_where (info) != FFEINFO_whereFLEETING_CADDR);
12959 case FFEEXPR_contextFILEASSOC:
12960 case FFEEXPR_contextFILEINT:
12961 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12962 : ffeinfo_basictype (info))
12964 case FFEINFO_basictypeINTEGER:
12965 /* Maybe this should be supported someday, but, right now,
12966 g77 can't generate a call to libf2c to write to an
12967 integer other than the default size. */
12968 error = ((! ffeexpr_stack_->is_rhs)
12969 && ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12976 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12980 case FFEEXPR_contextFILEDFINT:
12981 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12982 : ffeinfo_basictype (info))
12984 case FFEINFO_basictypeINTEGER:
12985 error = (ffeinfo_kindtype (info) != FFEINFO_kindtypeINTEGERDEFAULT);
12992 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
12996 case FFEEXPR_contextFILELOG:
12997 switch ((expr == NULL) ? FFEINFO_basictypeNONE
12998 : ffeinfo_basictype (info))
13000 case FFEINFO_basictypeLOGICAL:
13008 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13012 case FFEEXPR_contextFILECHAR:
13013 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13014 : ffeinfo_basictype (info))
13016 case FFEINFO_basictypeCHARACTER:
13024 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13028 case FFEEXPR_contextFILENUMCHAR:
13029 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
13031 switch (ffeinfo_basictype (info))
13033 case FFEINFO_basictypeLOGICAL:
13034 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13035 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13036 FFEEXPR_contextLET);
13037 /* Fall through. */
13038 case FFEINFO_basictypeREAL:
13039 case FFEINFO_basictypeCOMPLEX:
13040 if (ffe_is_pedantic ())
13045 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13046 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13047 FFEEXPR_contextLET);
13050 case FFEINFO_basictypeINTEGER:
13051 case FFEINFO_basictypeCHARACTER:
13061 case FFEEXPR_contextFILEDFCHAR:
13062 if ((error = (expr == NULL) || (ffeinfo_rank (info) != 0)))
13064 switch (ffeinfo_basictype (info))
13066 case FFEINFO_basictypeCHARACTER:
13068 = (ffeinfo_kindtype (info)
13069 != FFEINFO_kindtypeCHARACTERDEFAULT);
13076 if (!ffeexpr_stack_->is_rhs
13077 && (ffebld_op (expr) == FFEBLD_opSUBSTR))
13081 case FFEEXPR_contextFILEUNIT: /* See equiv code in _ambig_. */
13082 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13083 : ffeinfo_basictype (info))
13085 case FFEINFO_basictypeLOGICAL:
13086 if ((error = (ffeinfo_rank (info) != 0)))
13088 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13089 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13090 FFEEXPR_contextLET);
13091 /* Fall through. */
13092 case FFEINFO_basictypeREAL:
13093 case FFEINFO_basictypeCOMPLEX:
13094 if ((error = (ffeinfo_rank (info) != 0)))
13096 if (ffe_is_pedantic ())
13101 /* Fall through. */
13102 case FFEINFO_basictypeINTEGER:
13103 case FFEINFO_basictypeHOLLERITH:
13104 case FFEINFO_basictypeTYPELESS:
13105 if ((error = (ffeinfo_rank (info) != 0)))
13107 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13108 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13109 FFEEXPR_contextLET);
13112 case FFEINFO_basictypeCHARACTER:
13113 switch (ffebld_op (expr))
13114 { /* As if _lhs had been called instead of
13116 case FFEBLD_opSYMTER:
13118 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
13121 case FFEBLD_opSUBSTR:
13122 error = (ffeinfo_where (ffebld_info (expr))
13123 == FFEINFO_whereCONSTANT_SUBOBJECT);
13126 case FFEBLD_opARRAYREF:
13135 && ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
13136 || ((ffeinfo_rank (info) != 0)
13137 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
13138 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
13139 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
13140 == FFEBLD_opSTAR))))) /* Bad if
13141 non-default-kindtype
13142 character expr, or if
13143 array that is not a SYMTER
13144 (can't happen yet, I
13145 think), or has a NULL or
13146 STAR (assumed) array
13157 case FFEEXPR_contextFILEFORMAT:
13158 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13159 : ffeinfo_basictype (info))
13161 case FFEINFO_basictypeINTEGER:
13162 error = (expr == NULL)
13163 || ((ffeinfo_rank (info) != 0) ?
13164 ffe_is_pedantic () /* F77 C5. */
13165 : (bool) (ffeinfo_kindtype (info) != ffecom_label_kind ()))
13166 || (ffebld_op (expr) != FFEBLD_opSYMTER);
13169 case FFEINFO_basictypeLOGICAL:
13170 case FFEINFO_basictypeREAL:
13171 case FFEINFO_basictypeCOMPLEX:
13172 /* F77 C5 -- must be an array of hollerith. */
13174 = ffe_is_pedantic ()
13175 || (ffeinfo_rank (info) == 0);
13178 case FFEINFO_basictypeCHARACTER:
13179 if ((ffeinfo_kindtype (info) != FFEINFO_kindtypeCHARACTERDEFAULT)
13180 || ((ffeinfo_rank (info) != 0)
13181 && ((ffebld_op (expr) != FFEBLD_opSYMTER)
13182 || (ffesymbol_arraysize (ffebld_symter (expr)) == NULL)
13183 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr)))
13184 == FFEBLD_opSTAR)))) /* Bad if
13185 non-default-kindtype
13186 character expr, or if
13187 array that is not a SYMTER
13188 (can't happen yet, I
13189 think), or has a NULL or
13190 STAR (assumed) array
13203 case FFEEXPR_contextLOC_:
13204 /* See also ffeintrin_check_loc_. */
13206 || (ffeinfo_kind (info) != FFEINFO_kindENTITY)
13207 || ((ffebld_op (expr) != FFEBLD_opSYMTER)
13208 && (ffebld_op (expr) != FFEBLD_opSUBSTR)
13209 && (ffebld_op (expr) != FFEBLD_opARRAYREF)))
13218 if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
13220 ffebad_start (FFEBAD_EXPR_WRONG);
13221 ffebad_here (0, ffelex_token_where_line (ft),
13222 ffelex_token_where_column (ft));
13224 expr = ffebld_new_any ();
13225 ffebld_set_info (expr, ffeinfo_new_any ());
13228 callback = ffeexpr_stack_->callback;
13229 s = ffeexpr_stack_->previous;
13230 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_,
13231 sizeof (*ffeexpr_stack_));
13232 ffeexpr_stack_ = s;
13233 next = (ffelexHandler) (*callback) (ft, expr, t);
13234 ffelex_token_kill (ft);
13235 return (ffelexHandler) next;
13238 /* ffeexpr_finished_ambig_ -- Check validity of ambiguous unit/form spec
13241 expr = ffeexpr_finished_ambig_(expr);
13243 Replicates a bit of ffeexpr_finished_'s task when in a context
13244 of UNIT or FORMAT. */
13247 ffeexpr_finished_ambig_ (ffelexToken ft, ffebld expr)
13249 ffeinfo info = ffebld_info (expr);
13252 switch (ffeexpr_stack_->context)
13254 case FFEEXPR_contextFILENUMAMBIG: /* Same as FILENUM in _finished_. */
13255 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13256 : ffeinfo_basictype (info))
13258 case FFEINFO_basictypeLOGICAL:
13259 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13260 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13261 FFEEXPR_contextLET);
13262 /* Fall through. */
13263 case FFEINFO_basictypeREAL:
13264 case FFEINFO_basictypeCOMPLEX:
13265 if (ffe_is_pedantic ())
13270 /* Fall through. */
13271 case FFEINFO_basictypeINTEGER:
13272 case FFEINFO_basictypeHOLLERITH:
13273 case FFEINFO_basictypeTYPELESS:
13275 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13276 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13277 FFEEXPR_contextLET);
13284 if ((expr == NULL) || (ffeinfo_rank (info) != 0))
13288 case FFEEXPR_contextFILEUNITAMBIG: /* Same as FILEUNIT in _finished_. */
13289 if ((expr != NULL) && (ffebld_op (expr) == FFEBLD_opSTAR))
13294 switch ((expr == NULL) ? FFEINFO_basictypeNONE
13295 : ffeinfo_basictype (info))
13297 case FFEINFO_basictypeLOGICAL:
13298 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeLOGICAL,
13299 FFEINFO_kindtypeLOGICALDEFAULT, 0, FFETARGET_charactersizeNONE,
13300 FFEEXPR_contextLET);
13301 /* Fall through. */
13302 case FFEINFO_basictypeREAL:
13303 case FFEINFO_basictypeCOMPLEX:
13304 if (ffe_is_pedantic ())
13309 /* Fall through. */
13310 case FFEINFO_basictypeINTEGER:
13311 case FFEINFO_basictypeHOLLERITH:
13312 case FFEINFO_basictypeTYPELESS:
13313 error = (ffeinfo_rank (info) != 0);
13314 expr = ffeexpr_convert (expr, ft, ft, FFEINFO_basictypeINTEGER,
13315 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFETARGET_charactersizeNONE,
13316 FFEEXPR_contextLET);
13319 case FFEINFO_basictypeCHARACTER:
13320 switch (ffebld_op (expr))
13321 { /* As if _lhs had been called instead of
13323 case FFEBLD_opSYMTER:
13325 = (ffeinfo_where (ffebld_info (expr)) == FFEINFO_whereCONSTANT);
13328 case FFEBLD_opSUBSTR:
13329 error = (ffeinfo_where (ffebld_info (expr))
13330 == FFEINFO_whereCONSTANT_SUBOBJECT);
13333 case FFEBLD_opARRAYREF:
13350 assert ("bad context" == NULL);
13355 if (error && ((expr == NULL) || (ffebld_op (expr) != FFEBLD_opANY)))
13357 ffebad_start (FFEBAD_EXPR_WRONG);
13358 ffebad_here (0, ffelex_token_where_line (ft),
13359 ffelex_token_where_column (ft));
13361 expr = ffebld_new_any ();
13362 ffebld_set_info (expr, ffeinfo_new_any ());
13368 /* ffeexpr_token_lhs_ -- Initial state for lhs expression
13370 Return a pointer to this function to the lexer (ffelex), which will
13371 invoke it for the next token.
13373 Basically a smaller version of _rhs_; keep them both in sync, of course. */
13375 static ffelexHandler
13376 ffeexpr_token_lhs_ (ffelexToken t)
13379 /* When changing the list of valid initial lhs tokens, check whether to
13380 update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
13381 READ (expr) <token> case -- it assumes it knows which tokens <token> can
13382 be to indicate an lhs (or implied DO), which right now is the set
13385 This comment also appears in ffeexpr_token_first_lhs_. */
13387 switch (ffelex_token_type (t))
13389 case FFELEX_typeNAME:
13390 case FFELEX_typeNAMES:
13391 ffeexpr_tokens_[0] = ffelex_token_use (t);
13392 return (ffelexHandler) ffeexpr_token_name_lhs_;
13395 return (ffelexHandler) ffeexpr_finished_ (t);
13399 /* ffeexpr_token_rhs_ -- Initial state for rhs expression
13401 Return a pointer to this function to the lexer (ffelex), which will
13402 invoke it for the next token.
13404 The initial state and the post-binary-operator state are the same and
13405 both handled here, with the expression stack used to distinguish
13406 between them. Binary operators are invalid here; unary operators,
13407 constants, subexpressions, and name references are valid. */
13409 static ffelexHandler
13410 ffeexpr_token_rhs_ (ffelexToken t)
13414 switch (ffelex_token_type (t))
13416 case FFELEX_typeQUOTE:
13419 ffeexpr_tokens_[0] = ffelex_token_use (t);
13420 return (ffelexHandler) ffeexpr_token_quote_;
13422 ffeexpr_tokens_[0] = ffelex_token_use (t);
13423 ffelex_set_expecting_hollerith (-1, '\"',
13424 ffelex_token_where_line (t),
13425 ffelex_token_where_column (t));
13426 /* Don't have to unset this one. */
13427 return (ffelexHandler) ffeexpr_token_apostrophe_;
13429 case FFELEX_typeAPOSTROPHE:
13430 ffeexpr_tokens_[0] = ffelex_token_use (t);
13431 ffelex_set_expecting_hollerith (-1, '\'',
13432 ffelex_token_where_line (t),
13433 ffelex_token_where_column (t));
13434 /* Don't have to unset this one. */
13435 return (ffelexHandler) ffeexpr_token_apostrophe_;
13437 case FFELEX_typePERCENT:
13438 ffeexpr_tokens_[0] = ffelex_token_use (t);
13439 return (ffelexHandler) ffeexpr_token_percent_;
13441 case FFELEX_typeOPEN_PAREN:
13442 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
13443 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
13444 FFEEXPR_contextPAREN_,
13445 ffeexpr_cb_close_paren_c_);
13447 case FFELEX_typePLUS:
13448 e = ffeexpr_expr_new_ ();
13449 e->type = FFEEXPR_exprtypeUNARY_;
13450 e->token = ffelex_token_use (t);
13451 e->u.operator.op = FFEEXPR_operatorADD_;
13452 e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
13453 e->u.operator.as = FFEEXPR_operatorassociativityADD_;
13454 ffeexpr_exprstack_push_unary_ (e);
13455 return (ffelexHandler) ffeexpr_token_rhs_;
13457 case FFELEX_typeMINUS:
13458 e = ffeexpr_expr_new_ ();
13459 e->type = FFEEXPR_exprtypeUNARY_;
13460 e->token = ffelex_token_use (t);
13461 e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
13462 e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
13463 e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
13464 ffeexpr_exprstack_push_unary_ (e);
13465 return (ffelexHandler) ffeexpr_token_rhs_;
13467 case FFELEX_typePERIOD:
13468 ffeexpr_tokens_[0] = ffelex_token_use (t);
13469 return (ffelexHandler) ffeexpr_token_period_;
13471 case FFELEX_typeNUMBER:
13472 ffeexpr_tokens_[0] = ffelex_token_use (t);
13473 ffeexpr_hollerith_count_ = atol (ffelex_token_text (t));
13474 if (ffeexpr_hollerith_count_ > 0)
13475 ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_,
13477 ffelex_token_where_line (t),
13478 ffelex_token_where_column (t));
13479 return (ffelexHandler) ffeexpr_token_number_;
13481 case FFELEX_typeNAME:
13482 case FFELEX_typeNAMES:
13483 ffeexpr_tokens_[0] = ffelex_token_use (t);
13484 switch (ffeexpr_stack_->context)
13486 case FFEEXPR_contextACTUALARG_:
13487 case FFEEXPR_contextINDEXORACTUALARG_:
13488 case FFEEXPR_contextSFUNCDEFACTUALARG_:
13489 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
13490 return (ffelexHandler) ffeexpr_token_name_arg_;
13493 return (ffelexHandler) ffeexpr_token_name_rhs_;
13496 case FFELEX_typeASTERISK:
13497 case FFELEX_typeSLASH:
13498 case FFELEX_typePOWER:
13499 case FFELEX_typeCONCAT:
13500 case FFELEX_typeREL_EQ:
13501 case FFELEX_typeREL_NE:
13502 case FFELEX_typeREL_LE:
13503 case FFELEX_typeREL_GE:
13504 if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
13506 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13509 return (ffelexHandler) ffeexpr_token_rhs_;
13512 case FFELEX_typeEQUALS:
13513 case FFELEX_typePOINTS:
13514 case FFELEX_typeCLOSE_ANGLE:
13515 case FFELEX_typeCLOSE_PAREN:
13516 case FFELEX_typeCOMMA:
13517 case FFELEX_typeCOLON:
13518 case FFELEX_typeEOS:
13519 case FFELEX_typeSEMICOLON:
13522 return (ffelexHandler) ffeexpr_finished_ (t);
13526 /* ffeexpr_token_period_ -- Rhs PERIOD
13528 Return a pointer to this function to the lexer (ffelex), which will
13529 invoke it for the next token.
13531 Handle a period detected at rhs (expecting unary op or operand) state.
13532 Must begin a floating-point value (as in .12) or a dot-dot name, of
13533 which only .NOT., .TRUE., and .FALSE. are truly valid. Other sort-of-
13534 valid names represent binary operators, which are invalid here because
13535 there isn't an operand at the top of the stack. */
13537 static ffelexHandler
13538 ffeexpr_token_period_ (ffelexToken t)
13540 switch (ffelex_token_type (t))
13542 case FFELEX_typeNAME:
13543 case FFELEX_typeNAMES:
13544 ffeexpr_current_dotdot_ = ffestr_other (t);
13545 switch (ffeexpr_current_dotdot_)
13547 case FFESTR_otherNone:
13548 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
13550 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13551 ffelex_token_where_column (ffeexpr_tokens_[0]));
13554 ffelex_token_kill (ffeexpr_tokens_[0]);
13555 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13557 case FFESTR_otherTRUE:
13558 case FFESTR_otherFALSE:
13559 case FFESTR_otherNOT:
13560 ffeexpr_tokens_[1] = ffelex_token_use (t);
13561 return (ffelexHandler) ffeexpr_token_end_period_;
13564 if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND))
13566 ffebad_here (0, ffelex_token_where_line (t),
13567 ffelex_token_where_column (t));
13570 ffelex_token_kill (ffeexpr_tokens_[0]);
13571 return (ffelexHandler) ffeexpr_token_swallow_period_;
13573 break; /* Nothing really reaches here. */
13575 case FFELEX_typeNUMBER:
13576 ffeexpr_tokens_[1] = ffelex_token_use (t);
13577 return (ffelexHandler) ffeexpr_token_real_;
13580 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
13582 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13583 ffelex_token_where_column (ffeexpr_tokens_[0]));
13586 ffelex_token_kill (ffeexpr_tokens_[0]);
13587 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13591 /* ffeexpr_token_end_period_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
13593 Return a pointer to this function to the lexer (ffelex), which will
13594 invoke it for the next token.
13596 Expecting a period to close a .NOT, .TRUE, or .FALSE at rhs (unary op
13597 or operator) state. If period isn't found, issue a diagnostic but
13598 pretend we saw one. ffeexpr_current_dotdot_ must already contained the
13599 dotdot representation of the name in between the two PERIOD tokens. */
13601 static ffelexHandler
13602 ffeexpr_token_end_period_ (ffelexToken t)
13606 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13608 if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
13610 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
13611 ffelex_token_where_column (ffeexpr_tokens_[0]));
13612 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13613 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
13618 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill "NOT"/"TRUE"/"FALSE"
13621 e = ffeexpr_expr_new_ ();
13622 e->token = ffeexpr_tokens_[0];
13624 switch (ffeexpr_current_dotdot_)
13626 case FFESTR_otherNOT:
13627 e->type = FFEEXPR_exprtypeUNARY_;
13628 e->u.operator.op = FFEEXPR_operatorNOT_;
13629 e->u.operator.prec = FFEEXPR_operatorprecedenceNOT_;
13630 e->u.operator.as = FFEEXPR_operatorassociativityNOT_;
13631 ffeexpr_exprstack_push_unary_ (e);
13632 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13633 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13634 return (ffelexHandler) ffeexpr_token_rhs_;
13636 case FFESTR_otherTRUE:
13637 e->type = FFEEXPR_exprtypeOPERAND_;
13639 = ffebld_new_conter (ffebld_constant_new_logicaldefault (TRUE));
13640 ffebld_set_info (e->u.operand,
13641 ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
13642 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13643 ffeexpr_exprstack_push_operand_ (e);
13644 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13645 return (ffelexHandler) ffeexpr_token_binary_ (t);
13646 return (ffelexHandler) ffeexpr_token_binary_;
13648 case FFESTR_otherFALSE:
13649 e->type = FFEEXPR_exprtypeOPERAND_;
13651 = ffebld_new_conter (ffebld_constant_new_logicaldefault (FALSE));
13652 ffebld_set_info (e->u.operand,
13653 ffeinfo_new (FFEINFO_basictypeLOGICAL, FFEINFO_kindtypeLOGICALDEFAULT,
13654 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13655 ffeexpr_exprstack_push_operand_ (e);
13656 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13657 return (ffelexHandler) ffeexpr_token_binary_ (t);
13658 return (ffelexHandler) ffeexpr_token_binary_;
13661 assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL);
13667 /* ffeexpr_token_swallow_period_ -- Rhs PERIOD NAME(not NOT, TRUE, or FALSE)
13669 Return a pointer to this function to the lexer (ffelex), which will
13670 invoke it for the next token.
13672 A diagnostic has already been issued; just swallow a period if there is
13673 one, then continue with ffeexpr_token_rhs_. */
13675 static ffelexHandler
13676 ffeexpr_token_swallow_period_ (ffelexToken t)
13678 if (ffelex_token_type (t) != FFELEX_typePERIOD)
13679 return (ffelexHandler) ffeexpr_token_rhs_ (t);
13681 return (ffelexHandler) ffeexpr_token_rhs_;
13684 /* ffeexpr_token_real_ -- Rhs PERIOD NUMBER
13686 Return a pointer to this function to the lexer (ffelex), which will
13687 invoke it for the next token.
13689 After a period and a string of digits, check next token for possible
13690 exponent designation (D, E, or Q as first/only character) and continue
13691 real-number handling accordingly. Else form basic real constant, push
13692 onto expression stack, and enter binary state using current token (which,
13693 if it is a name not beginning with D, E, or Q, will certainly result
13694 in an error, but that's not for this routine to deal with). */
13696 static ffelexHandler
13697 ffeexpr_token_real_ (ffelexToken t)
13702 if (((ffelex_token_type (t) != FFELEX_typeNAME)
13703 && (ffelex_token_type (t) != FFELEX_typeNAMES))
13704 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13706 || ffesrc_char_match_init (d, 'E', 'e')
13707 || ffesrc_char_match_init (d, 'Q', 'q')))
13708 && ffeexpr_isdigits_ (++p)))
13711 /* This code has been removed because it seems inconsistent to
13712 produce a diagnostic in this case, but not all of the other
13713 ones that look for an exponent and cannot recognize one. */
13714 if (((ffelex_token_type (t) == FFELEX_typeNAME)
13715 || (ffelex_token_type (t) == FFELEX_typeNAMES))
13716 && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
13720 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
13721 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
13722 ffelex_token_where_column (ffeexpr_tokens_[0]));
13725 ffebad_string (bad);
13729 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13730 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13733 ffelex_token_kill (ffeexpr_tokens_[0]);
13734 ffelex_token_kill (ffeexpr_tokens_[1]);
13735 return (ffelexHandler) ffeexpr_token_binary_ (t);
13738 /* Just exponent character by itself? In which case, PLUS or MINUS must
13739 surely be next, followed by a NUMBER token. */
13743 ffeexpr_tokens_[2] = ffelex_token_use (t);
13744 return (ffelexHandler) ffeexpr_token_real_exponent_;
13747 ffeexpr_make_float_const_ (d, NULL, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13750 ffelex_token_kill (ffeexpr_tokens_[0]);
13751 ffelex_token_kill (ffeexpr_tokens_[1]);
13752 return (ffelexHandler) ffeexpr_token_binary_;
13755 /* ffeexpr_token_real_exponent_ -- Rhs PERIOD NUMBER NAME(D, E, or Q)
13757 Return a pointer to this function to the lexer (ffelex), which will
13758 invoke it for the next token.
13760 Ensures this token is PLUS or MINUS, preserves it, goes to final state
13761 for real number (exponent digits). Else issues diagnostic, assumes a
13762 zero exponent field for number, passes token on to binary state as if
13763 previous token had been "E0" instead of "E", for example. */
13765 static ffelexHandler
13766 ffeexpr_token_real_exponent_ (ffelexToken t)
13768 if ((ffelex_token_type (t) != FFELEX_typePLUS)
13769 && (ffelex_token_type (t) != FFELEX_typeMINUS))
13771 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13773 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
13774 ffelex_token_where_column (ffeexpr_tokens_[2]));
13775 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13779 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13780 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13783 ffelex_token_kill (ffeexpr_tokens_[0]);
13784 ffelex_token_kill (ffeexpr_tokens_[1]);
13785 ffelex_token_kill (ffeexpr_tokens_[2]);
13786 return (ffelexHandler) ffeexpr_token_binary_ (t);
13789 ffeexpr_tokens_[3] = ffelex_token_use (t);
13790 return (ffelexHandler) ffeexpr_token_real_exp_sign_;
13793 /* ffeexpr_token_real_exp_sign_ -- Rhs PERIOD NUMBER NAME(D,E,Q) PLUS/MINUS
13795 Return a pointer to this function to the lexer (ffelex), which will
13796 invoke it for the next token.
13798 Make sure token is a NUMBER, make a real constant out of all we have and
13799 push it onto the expression stack. Else issue diagnostic and pretend
13800 exponent field was a zero. */
13802 static ffelexHandler
13803 ffeexpr_token_real_exp_sign_ (ffelexToken t)
13805 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13807 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13809 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
13810 ffelex_token_where_column (ffeexpr_tokens_[2]));
13811 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13815 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL,
13816 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
13819 ffelex_token_kill (ffeexpr_tokens_[0]);
13820 ffelex_token_kill (ffeexpr_tokens_[1]);
13821 ffelex_token_kill (ffeexpr_tokens_[2]);
13822 ffelex_token_kill (ffeexpr_tokens_[3]);
13823 return (ffelexHandler) ffeexpr_token_binary_ (t);
13826 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0], NULL,
13827 ffeexpr_tokens_[0], ffeexpr_tokens_[1], ffeexpr_tokens_[2],
13828 ffeexpr_tokens_[3], t);
13830 ffelex_token_kill (ffeexpr_tokens_[0]);
13831 ffelex_token_kill (ffeexpr_tokens_[1]);
13832 ffelex_token_kill (ffeexpr_tokens_[2]);
13833 ffelex_token_kill (ffeexpr_tokens_[3]);
13834 return (ffelexHandler) ffeexpr_token_binary_;
13837 /* ffeexpr_token_number_ -- Rhs NUMBER
13839 Return a pointer to this function to the lexer (ffelex), which will
13840 invoke it for the next token.
13842 If the token is a period, we may have a floating-point number, or an
13843 integer followed by a dotdot binary operator. If the token is a name
13844 beginning with D, E, or Q, we definitely have a floating-point number.
13845 If the token is a hollerith constant, that's what we've got, so push
13846 it onto the expression stack and continue with the binary state.
13848 Otherwise, we have an integer followed by something the binary state
13849 should be able to swallow. */
13851 static ffelexHandler
13852 ffeexpr_token_number_ (ffelexToken t)
13859 if (ffeexpr_hollerith_count_ > 0)
13860 ffelex_set_expecting_hollerith (0, '\0',
13861 ffewhere_line_unknown (),
13862 ffewhere_column_unknown ());
13864 /* See if we've got a floating-point number here. */
13866 switch (ffelex_token_type (t))
13868 case FFELEX_typeNAME:
13869 case FFELEX_typeNAMES:
13870 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
13872 || ffesrc_char_match_init (d, 'E', 'e')
13873 || ffesrc_char_match_init (d, 'Q', 'q'))
13874 && ffeexpr_isdigits_ (++p))
13877 /* Just exponent character by itself? In which case, PLUS or MINUS
13878 must surely be next, followed by a NUMBER token. */
13882 ffeexpr_tokens_[1] = ffelex_token_use (t);
13883 return (ffelexHandler) ffeexpr_token_number_exponent_;
13885 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], NULL, NULL, t,
13888 ffelex_token_kill (ffeexpr_tokens_[0]);
13889 return (ffelexHandler) ffeexpr_token_binary_;
13893 case FFELEX_typePERIOD:
13894 ffeexpr_tokens_[1] = ffelex_token_use (t);
13895 return (ffelexHandler) ffeexpr_token_number_period_;
13897 case FFELEX_typeHOLLERITH:
13898 e = ffeexpr_expr_new_ ();
13899 e->type = FFEEXPR_exprtypeOPERAND_;
13900 e->token = ffeexpr_tokens_[0];
13901 e->u.operand = ffebld_new_conter (ffebld_constant_new_hollerith (t));
13902 ni = ffeinfo_new (FFEINFO_basictypeHOLLERITH, FFEINFO_kindtypeNONE,
13903 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
13904 ffelex_token_length (t));
13905 ffebld_set_info (e->u.operand, ni);
13906 ffeexpr_exprstack_push_operand_ (e);
13907 return (ffelexHandler) ffeexpr_token_binary_;
13913 /* Nothing specific we were looking for, so make an integer and pass the
13914 current token to the binary state. */
13916 ffeexpr_make_float_const_ ('I', ffeexpr_tokens_[0], NULL, NULL,
13918 return (ffelexHandler) ffeexpr_token_binary_ (t);
13921 /* ffeexpr_token_number_exponent_ -- Rhs NUMBER NAME(D, E, or Q)
13923 Return a pointer to this function to the lexer (ffelex), which will
13924 invoke it for the next token.
13926 Ensures this token is PLUS or MINUS, preserves it, goes to final state
13927 for real number (exponent digits). Else treats number as integer, passes
13928 name to binary, passes current token to subsequent handler. */
13930 static ffelexHandler
13931 ffeexpr_token_number_exponent_ (ffelexToken t)
13933 if ((ffelex_token_type (t) != FFELEX_typePLUS)
13934 && (ffelex_token_type (t) != FFELEX_typeMINUS))
13937 ffelexHandler nexthandler;
13939 e = ffeexpr_expr_new_ ();
13940 e->type = FFEEXPR_exprtypeOPERAND_;
13941 e->token = ffeexpr_tokens_[0];
13942 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
13943 (ffeexpr_tokens_[0]));
13944 ffebld_set_info (e->u.operand,
13945 ffeinfo_new (FFEINFO_basictypeINTEGER, FFEINFO_kindtypeINTEGERDEFAULT,
13946 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
13947 ffeexpr_exprstack_push_operand_ (e);
13948 nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[1]);
13949 ffelex_token_kill (ffeexpr_tokens_[1]);
13950 return (ffelexHandler) (*nexthandler) (t);
13953 ffeexpr_tokens_[2] = ffelex_token_use (t);
13954 return (ffelexHandler) ffeexpr_token_number_exp_sign_;
13957 /* ffeexpr_token_number_exp_sign_ -- Rhs NUMBER NAME(D,E,Q) PLUS/MINUS
13959 Return a pointer to this function to the lexer (ffelex), which will
13960 invoke it for the next token.
13962 Make sure token is a NUMBER, make a real constant out of all we have and
13963 push it onto the expression stack. Else issue diagnostic and pretend
13964 exponent field was a zero. */
13966 static ffelexHandler
13967 ffeexpr_token_number_exp_sign_ (ffelexToken t)
13969 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
13971 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
13973 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[1]),
13974 ffelex_token_where_column (ffeexpr_tokens_[1]));
13975 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
13979 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
13980 ffeexpr_tokens_[0], NULL, NULL,
13981 ffeexpr_tokens_[1], ffeexpr_tokens_[2],
13984 ffelex_token_kill (ffeexpr_tokens_[0]);
13985 ffelex_token_kill (ffeexpr_tokens_[1]);
13986 ffelex_token_kill (ffeexpr_tokens_[2]);
13987 return (ffelexHandler) ffeexpr_token_binary_ (t);
13990 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[1])[0],
13991 ffeexpr_tokens_[0], NULL, NULL,
13992 ffeexpr_tokens_[1], ffeexpr_tokens_[2], t);
13994 ffelex_token_kill (ffeexpr_tokens_[0]);
13995 ffelex_token_kill (ffeexpr_tokens_[1]);
13996 ffelex_token_kill (ffeexpr_tokens_[2]);
13997 return (ffelexHandler) ffeexpr_token_binary_;
14000 /* ffeexpr_token_number_period_ -- Rhs NUMBER PERIOD
14002 Return a pointer to this function to the lexer (ffelex), which will
14003 invoke it for the next token.
14005 Handle a period detected following a number at rhs state. Must begin a
14006 floating-point value (as in 1., 1.2, 1.E3, or 1.E+3) or a dot-dot name. */
14008 static ffelexHandler
14009 ffeexpr_token_number_period_ (ffelexToken t)
14012 ffelexHandler nexthandler;
14016 switch (ffelex_token_type (t))
14018 case FFELEX_typeNAME:
14019 case FFELEX_typeNAMES:
14020 if ((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
14022 || ffesrc_char_match_init (d, 'E', 'e')
14023 || ffesrc_char_match_init (d, 'Q', 'q'))
14024 && ffeexpr_isdigits_ (++p))
14027 /* Just exponent character by itself? In which case, PLUS or MINUS
14028 must surely be next, followed by a NUMBER token. */
14032 ffeexpr_tokens_[2] = ffelex_token_use (t);
14033 return (ffelexHandler) ffeexpr_token_number_per_exp_;
14035 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0],
14036 ffeexpr_tokens_[1], NULL, t, NULL,
14039 ffelex_token_kill (ffeexpr_tokens_[0]);
14040 ffelex_token_kill (ffeexpr_tokens_[1]);
14041 return (ffelexHandler) ffeexpr_token_binary_;
14043 /* A name not representing an exponent, so assume it will be something
14044 like EQ, make an integer from the number, pass the period to binary
14045 state and the current token to the resulting state. */
14047 e = ffeexpr_expr_new_ ();
14048 e->type = FFEEXPR_exprtypeOPERAND_;
14049 e->token = ffeexpr_tokens_[0];
14050 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
14051 (ffeexpr_tokens_[0]));
14052 ffebld_set_info (e->u.operand,
14053 ffeinfo_new (FFEINFO_basictypeINTEGER,
14054 FFEINFO_kindtypeINTEGERDEFAULT, 0,
14055 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14056 FFETARGET_charactersizeNONE));
14057 ffeexpr_exprstack_push_operand_ (e);
14058 nexthandler = (ffelexHandler) ffeexpr_token_binary_
14059 (ffeexpr_tokens_[1]);
14060 ffelex_token_kill (ffeexpr_tokens_[1]);
14061 return (ffelexHandler) (*nexthandler) (t);
14063 case FFELEX_typeNUMBER:
14064 ffeexpr_tokens_[2] = ffelex_token_use (t);
14065 return (ffelexHandler) ffeexpr_token_number_real_;
14071 /* Nothing specific we were looking for, so make a real number and pass the
14072 period and then the current token to the binary state. */
14074 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14075 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14076 NULL, NULL, NULL, NULL);
14078 ffelex_token_kill (ffeexpr_tokens_[0]);
14079 ffelex_token_kill (ffeexpr_tokens_[1]);
14080 return (ffelexHandler) ffeexpr_token_binary_ (t);
14083 /* ffeexpr_token_number_per_exp_ -- Rhs NUMBER PERIOD NAME(D, E, or Q)
14085 Return a pointer to this function to the lexer (ffelex), which will
14086 invoke it for the next token.
14088 Ensures this token is PLUS or MINUS, preserves it, goes to final state
14089 for real number (exponent digits). Else treats number as real, passes
14090 name to binary, passes current token to subsequent handler. */
14092 static ffelexHandler
14093 ffeexpr_token_number_per_exp_ (ffelexToken t)
14095 if ((ffelex_token_type (t) != FFELEX_typePLUS)
14096 && (ffelex_token_type (t) != FFELEX_typeMINUS))
14098 ffelexHandler nexthandler;
14100 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14101 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14102 NULL, NULL, NULL, NULL);
14104 ffelex_token_kill (ffeexpr_tokens_[0]);
14105 ffelex_token_kill (ffeexpr_tokens_[1]);
14106 nexthandler = (ffelexHandler) ffeexpr_token_binary_ (ffeexpr_tokens_[2]);
14107 ffelex_token_kill (ffeexpr_tokens_[2]);
14108 return (ffelexHandler) (*nexthandler) (t);
14111 ffeexpr_tokens_[3] = ffelex_token_use (t);
14112 return (ffelexHandler) ffeexpr_token_num_per_exp_sign_;
14115 /* ffeexpr_token_number_real_ -- Rhs NUMBER PERIOD NUMBER
14117 Return a pointer to this function to the lexer (ffelex), which will
14118 invoke it for the next token.
14120 After a number, period, and number, check next token for possible
14121 exponent designation (D, E, or Q as first/only character) and continue
14122 real-number handling accordingly. Else form basic real constant, push
14123 onto expression stack, and enter binary state using current token (which,
14124 if it is a name not beginning with D, E, or Q, will certainly result
14125 in an error, but that's not for this routine to deal with). */
14127 static ffelexHandler
14128 ffeexpr_token_number_real_ (ffelexToken t)
14133 if (((ffelex_token_type (t) != FFELEX_typeNAME)
14134 && (ffelex_token_type (t) != FFELEX_typeNAMES))
14135 || !(((ffesrc_char_match_init ((d = *(p = ffelex_token_text (t))),
14137 || ffesrc_char_match_init (d, 'E', 'e')
14138 || ffesrc_char_match_init (d, 'Q', 'q')))
14139 && ffeexpr_isdigits_ (++p)))
14142 /* This code has been removed because it seems inconsistent to
14143 produce a diagnostic in this case, but not all of the other
14144 ones that look for an exponent and cannot recognize one. */
14145 if (((ffelex_token_type (t) == FFELEX_typeNAME)
14146 || (ffelex_token_type (t) == FFELEX_typeNAMES))
14147 && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT))
14151 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14152 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
14153 ffelex_token_where_column (ffeexpr_tokens_[0]));
14156 ffebad_string (bad);
14160 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14161 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14162 ffeexpr_tokens_[2], NULL, NULL, NULL);
14164 ffelex_token_kill (ffeexpr_tokens_[0]);
14165 ffelex_token_kill (ffeexpr_tokens_[1]);
14166 ffelex_token_kill (ffeexpr_tokens_[2]);
14167 return (ffelexHandler) ffeexpr_token_binary_ (t);
14170 /* Just exponent character by itself? In which case, PLUS or MINUS must
14171 surely be next, followed by a NUMBER token. */
14175 ffeexpr_tokens_[3] = ffelex_token_use (t);
14176 return (ffelexHandler) ffeexpr_token_number_real_exp_;
14179 ffeexpr_make_float_const_ (d, ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14180 ffeexpr_tokens_[2], t, NULL, NULL);
14182 ffelex_token_kill (ffeexpr_tokens_[0]);
14183 ffelex_token_kill (ffeexpr_tokens_[1]);
14184 ffelex_token_kill (ffeexpr_tokens_[2]);
14185 return (ffelexHandler) ffeexpr_token_binary_;
14188 /* ffeexpr_token_num_per_exp_sign_ -- Rhs NUMBER PERIOD NAME(D,E,Q) PLUS/MINUS
14190 Return a pointer to this function to the lexer (ffelex), which will
14191 invoke it for the next token.
14193 Make sure token is a NUMBER, make a real constant out of all we have and
14194 push it onto the expression stack. Else issue diagnostic and pretend
14195 exponent field was a zero. */
14197 static ffelexHandler
14198 ffeexpr_token_num_per_exp_sign_ (ffelexToken t)
14200 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14202 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14204 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[2]),
14205 ffelex_token_where_column (ffeexpr_tokens_[2]));
14206 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14210 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14211 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14212 NULL, NULL, NULL, NULL);
14214 ffelex_token_kill (ffeexpr_tokens_[0]);
14215 ffelex_token_kill (ffeexpr_tokens_[1]);
14216 ffelex_token_kill (ffeexpr_tokens_[2]);
14217 ffelex_token_kill (ffeexpr_tokens_[3]);
14218 return (ffelexHandler) ffeexpr_token_binary_ (t);
14221 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[2])[0],
14222 ffeexpr_tokens_[0], ffeexpr_tokens_[1], NULL,
14223 ffeexpr_tokens_[2], ffeexpr_tokens_[3], t);
14225 ffelex_token_kill (ffeexpr_tokens_[0]);
14226 ffelex_token_kill (ffeexpr_tokens_[1]);
14227 ffelex_token_kill (ffeexpr_tokens_[2]);
14228 ffelex_token_kill (ffeexpr_tokens_[3]);
14229 return (ffelexHandler) ffeexpr_token_binary_;
14232 /* ffeexpr_token_number_real_exp_ -- Rhs NUMBER PERIOD NUMBER NAME(D, E, or Q)
14234 Return a pointer to this function to the lexer (ffelex), which will
14235 invoke it for the next token.
14237 Ensures this token is PLUS or MINUS, preserves it, goes to final state
14238 for real number (exponent digits). Else issues diagnostic, assumes a
14239 zero exponent field for number, passes token on to binary state as if
14240 previous token had been "E0" instead of "E", for example. */
14242 static ffelexHandler
14243 ffeexpr_token_number_real_exp_ (ffelexToken t)
14245 if ((ffelex_token_type (t) != FFELEX_typePLUS)
14246 && (ffelex_token_type (t) != FFELEX_typeMINUS))
14248 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14250 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
14251 ffelex_token_where_column (ffeexpr_tokens_[3]));
14252 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14256 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14257 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14258 ffeexpr_tokens_[2], NULL, NULL, NULL);
14260 ffelex_token_kill (ffeexpr_tokens_[0]);
14261 ffelex_token_kill (ffeexpr_tokens_[1]);
14262 ffelex_token_kill (ffeexpr_tokens_[2]);
14263 ffelex_token_kill (ffeexpr_tokens_[3]);
14264 return (ffelexHandler) ffeexpr_token_binary_ (t);
14267 ffeexpr_tokens_[4] = ffelex_token_use (t);
14268 return (ffelexHandler) ffeexpr_token_num_real_exp_sn_;
14271 /* ffeexpr_token_num_real_exp_sn_ -- Rhs NUMBER PERIOD NUMBER NAME(D,E,Q)
14274 Return a pointer to this function to the lexer (ffelex), which will
14275 invoke it for the next token.
14277 Make sure token is a NUMBER, make a real constant out of all we have and
14278 push it onto the expression stack. Else issue diagnostic and pretend
14279 exponent field was a zero. */
14281 static ffelexHandler
14282 ffeexpr_token_num_real_exp_sn_ (ffelexToken t)
14284 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14286 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE))
14288 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[3]),
14289 ffelex_token_where_column (ffeexpr_tokens_[3]));
14290 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14294 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
14295 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14296 ffeexpr_tokens_[2], NULL, NULL, NULL);
14298 ffelex_token_kill (ffeexpr_tokens_[0]);
14299 ffelex_token_kill (ffeexpr_tokens_[1]);
14300 ffelex_token_kill (ffeexpr_tokens_[2]);
14301 ffelex_token_kill (ffeexpr_tokens_[3]);
14302 ffelex_token_kill (ffeexpr_tokens_[4]);
14303 return (ffelexHandler) ffeexpr_token_binary_ (t);
14306 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_[3])[0],
14307 ffeexpr_tokens_[0], ffeexpr_tokens_[1],
14308 ffeexpr_tokens_[2], ffeexpr_tokens_[3],
14309 ffeexpr_tokens_[4], t);
14311 ffelex_token_kill (ffeexpr_tokens_[0]);
14312 ffelex_token_kill (ffeexpr_tokens_[1]);
14313 ffelex_token_kill (ffeexpr_tokens_[2]);
14314 ffelex_token_kill (ffeexpr_tokens_[3]);
14315 ffelex_token_kill (ffeexpr_tokens_[4]);
14316 return (ffelexHandler) ffeexpr_token_binary_;
14319 /* ffeexpr_token_binary_ -- Handle binary operator possibility
14321 Return a pointer to this function to the lexer (ffelex), which will
14322 invoke it for the next token.
14324 The possibility of a binary operator is handled here, meaning the previous
14325 token was an operand. */
14327 static ffelexHandler
14328 ffeexpr_token_binary_ (ffelexToken t)
14332 if (!ffeexpr_stack_->is_rhs)
14333 return (ffelexHandler) ffeexpr_finished_ (t); /* For now. */
14335 switch (ffelex_token_type (t))
14337 case FFELEX_typePLUS:
14338 e = ffeexpr_expr_new_ ();
14339 e->type = FFEEXPR_exprtypeBINARY_;
14340 e->token = ffelex_token_use (t);
14341 e->u.operator.op = FFEEXPR_operatorADD_;
14342 e->u.operator.prec = FFEEXPR_operatorprecedenceADD_;
14343 e->u.operator.as = FFEEXPR_operatorassociativityADD_;
14344 ffeexpr_exprstack_push_binary_ (e);
14345 return (ffelexHandler) ffeexpr_token_rhs_;
14347 case FFELEX_typeMINUS:
14348 e = ffeexpr_expr_new_ ();
14349 e->type = FFEEXPR_exprtypeBINARY_;
14350 e->token = ffelex_token_use (t);
14351 e->u.operator.op = FFEEXPR_operatorSUBTRACT_;
14352 e->u.operator.prec = FFEEXPR_operatorprecedenceSUBTRACT_;
14353 e->u.operator.as = FFEEXPR_operatorassociativitySUBTRACT_;
14354 ffeexpr_exprstack_push_binary_ (e);
14355 return (ffelexHandler) ffeexpr_token_rhs_;
14357 case FFELEX_typeASTERISK:
14358 switch (ffeexpr_stack_->context)
14360 case FFEEXPR_contextDATA:
14361 return (ffelexHandler) ffeexpr_finished_ (t);
14366 e = ffeexpr_expr_new_ ();
14367 e->type = FFEEXPR_exprtypeBINARY_;
14368 e->token = ffelex_token_use (t);
14369 e->u.operator.op = FFEEXPR_operatorMULTIPLY_;
14370 e->u.operator.prec = FFEEXPR_operatorprecedenceMULTIPLY_;
14371 e->u.operator.as = FFEEXPR_operatorassociativityMULTIPLY_;
14372 ffeexpr_exprstack_push_binary_ (e);
14373 return (ffelexHandler) ffeexpr_token_rhs_;
14375 case FFELEX_typeSLASH:
14376 switch (ffeexpr_stack_->context)
14378 case FFEEXPR_contextDATA:
14379 return (ffelexHandler) ffeexpr_finished_ (t);
14384 e = ffeexpr_expr_new_ ();
14385 e->type = FFEEXPR_exprtypeBINARY_;
14386 e->token = ffelex_token_use (t);
14387 e->u.operator.op = FFEEXPR_operatorDIVIDE_;
14388 e->u.operator.prec = FFEEXPR_operatorprecedenceDIVIDE_;
14389 e->u.operator.as = FFEEXPR_operatorassociativityDIVIDE_;
14390 ffeexpr_exprstack_push_binary_ (e);
14391 return (ffelexHandler) ffeexpr_token_rhs_;
14393 case FFELEX_typePOWER:
14394 e = ffeexpr_expr_new_ ();
14395 e->type = FFEEXPR_exprtypeBINARY_;
14396 e->token = ffelex_token_use (t);
14397 e->u.operator.op = FFEEXPR_operatorPOWER_;
14398 e->u.operator.prec = FFEEXPR_operatorprecedencePOWER_;
14399 e->u.operator.as = FFEEXPR_operatorassociativityPOWER_;
14400 ffeexpr_exprstack_push_binary_ (e);
14401 return (ffelexHandler) ffeexpr_token_rhs_;
14403 case FFELEX_typeCONCAT:
14404 e = ffeexpr_expr_new_ ();
14405 e->type = FFEEXPR_exprtypeBINARY_;
14406 e->token = ffelex_token_use (t);
14407 e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
14408 e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
14409 e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
14410 ffeexpr_exprstack_push_binary_ (e);
14411 return (ffelexHandler) ffeexpr_token_rhs_;
14413 case FFELEX_typeOPEN_ANGLE:
14414 switch (ffeexpr_stack_->context)
14416 case FFEEXPR_contextFORMAT:
14417 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14418 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14425 e = ffeexpr_expr_new_ ();
14426 e->type = FFEEXPR_exprtypeBINARY_;
14427 e->token = ffelex_token_use (t);
14428 e->u.operator.op = FFEEXPR_operatorLT_;
14429 e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
14430 e->u.operator.as = FFEEXPR_operatorassociativityLT_;
14431 ffeexpr_exprstack_push_binary_ (e);
14432 return (ffelexHandler) ffeexpr_token_rhs_;
14434 case FFELEX_typeCLOSE_ANGLE:
14435 switch (ffeexpr_stack_->context)
14437 case FFEEXPR_contextFORMAT:
14438 return ffeexpr_finished_ (t);
14443 e = ffeexpr_expr_new_ ();
14444 e->type = FFEEXPR_exprtypeBINARY_;
14445 e->token = ffelex_token_use (t);
14446 e->u.operator.op = FFEEXPR_operatorGT_;
14447 e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
14448 e->u.operator.as = FFEEXPR_operatorassociativityGT_;
14449 ffeexpr_exprstack_push_binary_ (e);
14450 return (ffelexHandler) ffeexpr_token_rhs_;
14452 case FFELEX_typeREL_EQ:
14453 switch (ffeexpr_stack_->context)
14455 case FFEEXPR_contextFORMAT:
14456 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14457 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14464 e = ffeexpr_expr_new_ ();
14465 e->type = FFEEXPR_exprtypeBINARY_;
14466 e->token = ffelex_token_use (t);
14467 e->u.operator.op = FFEEXPR_operatorEQ_;
14468 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
14469 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
14470 ffeexpr_exprstack_push_binary_ (e);
14471 return (ffelexHandler) ffeexpr_token_rhs_;
14473 case FFELEX_typeREL_NE:
14474 switch (ffeexpr_stack_->context)
14476 case FFEEXPR_contextFORMAT:
14477 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14478 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14485 e = ffeexpr_expr_new_ ();
14486 e->type = FFEEXPR_exprtypeBINARY_;
14487 e->token = ffelex_token_use (t);
14488 e->u.operator.op = FFEEXPR_operatorNE_;
14489 e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
14490 e->u.operator.as = FFEEXPR_operatorassociativityNE_;
14491 ffeexpr_exprstack_push_binary_ (e);
14492 return (ffelexHandler) ffeexpr_token_rhs_;
14494 case FFELEX_typeREL_LE:
14495 switch (ffeexpr_stack_->context)
14497 case FFEEXPR_contextFORMAT:
14498 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14499 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14506 e = ffeexpr_expr_new_ ();
14507 e->type = FFEEXPR_exprtypeBINARY_;
14508 e->token = ffelex_token_use (t);
14509 e->u.operator.op = FFEEXPR_operatorLE_;
14510 e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
14511 e->u.operator.as = FFEEXPR_operatorassociativityLE_;
14512 ffeexpr_exprstack_push_binary_ (e);
14513 return (ffelexHandler) ffeexpr_token_rhs_;
14515 case FFELEX_typeREL_GE:
14516 switch (ffeexpr_stack_->context)
14518 case FFEEXPR_contextFORMAT:
14519 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN);
14520 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14527 e = ffeexpr_expr_new_ ();
14528 e->type = FFEEXPR_exprtypeBINARY_;
14529 e->token = ffelex_token_use (t);
14530 e->u.operator.op = FFEEXPR_operatorGE_;
14531 e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
14532 e->u.operator.as = FFEEXPR_operatorassociativityGE_;
14533 ffeexpr_exprstack_push_binary_ (e);
14534 return (ffelexHandler) ffeexpr_token_rhs_;
14536 case FFELEX_typePERIOD:
14537 ffeexpr_tokens_[0] = ffelex_token_use (t);
14538 return (ffelexHandler) ffeexpr_token_binary_period_;
14541 case FFELEX_typeOPEN_PAREN:
14542 case FFELEX_typeCLOSE_PAREN:
14543 case FFELEX_typeEQUALS:
14544 case FFELEX_typePOINTS:
14545 case FFELEX_typeCOMMA:
14546 case FFELEX_typeCOLON:
14547 case FFELEX_typeEOS:
14548 case FFELEX_typeSEMICOLON:
14549 case FFELEX_typeNAME:
14550 case FFELEX_typeNAMES:
14553 return (ffelexHandler) ffeexpr_finished_ (t);
14557 /* ffeexpr_token_binary_period_ -- Binary PERIOD
14559 Return a pointer to this function to the lexer (ffelex), which will
14560 invoke it for the next token.
14562 Handle a period detected at binary (expecting binary op or end) state.
14563 Must begin a dot-dot name, of which .NOT., .TRUE., and .FALSE. are not
14566 static ffelexHandler
14567 ffeexpr_token_binary_period_ (ffelexToken t)
14569 ffeexprExpr_ operand;
14571 switch (ffelex_token_type (t))
14573 case FFELEX_typeNAME:
14574 case FFELEX_typeNAMES:
14575 ffeexpr_current_dotdot_ = ffestr_other (t);
14576 switch (ffeexpr_current_dotdot_)
14578 case FFESTR_otherTRUE:
14579 case FFESTR_otherFALSE:
14580 case FFESTR_otherNOT:
14581 if (ffest_ffebad_start (FFEBAD_MISSING_BINARY_OPERATOR))
14583 operand = ffeexpr_stack_->exprstack;
14584 assert (operand != NULL);
14585 assert (operand->type == FFEEXPR_exprtypeOPERAND_);
14586 ffebad_here (0, ffelex_token_where_line (operand->token), ffelex_token_where_column (operand->token));
14587 ffebad_here (1, ffelex_token_where_line (t),
14588 ffelex_token_where_column (t));
14591 ffelex_token_kill (ffeexpr_tokens_[0]);
14592 return (ffelexHandler) ffeexpr_token_binary_sw_per_;
14595 ffeexpr_tokens_[1] = ffelex_token_use (t);
14596 return (ffelexHandler) ffeexpr_token_binary_end_per_;
14598 break; /* Nothing really reaches here. */
14601 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD))
14603 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14604 ffelex_token_where_column (ffeexpr_tokens_[0]));
14607 ffelex_token_kill (ffeexpr_tokens_[0]);
14608 return (ffelexHandler) ffeexpr_token_binary_ (t);
14612 /* ffeexpr_token_binary_end_per_ -- Binary PERIOD NAME(not NOT, TRUE, or FALSE)
14614 Return a pointer to this function to the lexer (ffelex), which will
14615 invoke it for the next token.
14617 Expecting a period to close a dot-dot at binary (binary op
14618 or operator) state. If period isn't found, issue a diagnostic but
14619 pretend we saw one. ffeexpr_current_dotdot_ must already contained the
14620 dotdot representation of the name in between the two PERIOD tokens. */
14622 static ffelexHandler
14623 ffeexpr_token_binary_end_per_ (ffelexToken t)
14627 e = ffeexpr_expr_new_ ();
14628 e->type = FFEEXPR_exprtypeBINARY_;
14629 e->token = ffeexpr_tokens_[0];
14631 switch (ffeexpr_current_dotdot_)
14633 case FFESTR_otherAND:
14634 e->u.operator.op = FFEEXPR_operatorAND_;
14635 e->u.operator.prec = FFEEXPR_operatorprecedenceAND_;
14636 e->u.operator.as = FFEEXPR_operatorassociativityAND_;
14639 case FFESTR_otherOR:
14640 e->u.operator.op = FFEEXPR_operatorOR_;
14641 e->u.operator.prec = FFEEXPR_operatorprecedenceOR_;
14642 e->u.operator.as = FFEEXPR_operatorassociativityOR_;
14645 case FFESTR_otherXOR:
14646 e->u.operator.op = FFEEXPR_operatorXOR_;
14647 e->u.operator.prec = FFEEXPR_operatorprecedenceXOR_;
14648 e->u.operator.as = FFEEXPR_operatorassociativityXOR_;
14651 case FFESTR_otherEQV:
14652 e->u.operator.op = FFEEXPR_operatorEQV_;
14653 e->u.operator.prec = FFEEXPR_operatorprecedenceEQV_;
14654 e->u.operator.as = FFEEXPR_operatorassociativityEQV_;
14657 case FFESTR_otherNEQV:
14658 e->u.operator.op = FFEEXPR_operatorNEQV_;
14659 e->u.operator.prec = FFEEXPR_operatorprecedenceNEQV_;
14660 e->u.operator.as = FFEEXPR_operatorassociativityNEQV_;
14663 case FFESTR_otherLT:
14664 e->u.operator.op = FFEEXPR_operatorLT_;
14665 e->u.operator.prec = FFEEXPR_operatorprecedenceLT_;
14666 e->u.operator.as = FFEEXPR_operatorassociativityLT_;
14669 case FFESTR_otherLE:
14670 e->u.operator.op = FFEEXPR_operatorLE_;
14671 e->u.operator.prec = FFEEXPR_operatorprecedenceLE_;
14672 e->u.operator.as = FFEEXPR_operatorassociativityLE_;
14675 case FFESTR_otherEQ:
14676 e->u.operator.op = FFEEXPR_operatorEQ_;
14677 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
14678 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
14681 case FFESTR_otherNE:
14682 e->u.operator.op = FFEEXPR_operatorNE_;
14683 e->u.operator.prec = FFEEXPR_operatorprecedenceNE_;
14684 e->u.operator.as = FFEEXPR_operatorassociativityNE_;
14687 case FFESTR_otherGT:
14688 e->u.operator.op = FFEEXPR_operatorGT_;
14689 e->u.operator.prec = FFEEXPR_operatorprecedenceGT_;
14690 e->u.operator.as = FFEEXPR_operatorassociativityGT_;
14693 case FFESTR_otherGE:
14694 e->u.operator.op = FFEEXPR_operatorGE_;
14695 e->u.operator.prec = FFEEXPR_operatorprecedenceGE_;
14696 e->u.operator.as = FFEEXPR_operatorassociativityGE_;
14700 if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT))
14702 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14703 ffelex_token_where_column (ffeexpr_tokens_[0]));
14704 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
14707 e->u.operator.op = FFEEXPR_operatorEQ_;
14708 e->u.operator.prec = FFEEXPR_operatorprecedenceEQ_;
14709 e->u.operator.as = FFEEXPR_operatorassociativityEQ_;
14713 ffeexpr_exprstack_push_binary_ (e);
14715 if (ffelex_token_type (t) != FFELEX_typePERIOD)
14717 if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD))
14719 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14720 ffelex_token_where_column (ffeexpr_tokens_[0]));
14721 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14722 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
14725 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */
14726 return (ffelexHandler) ffeexpr_token_rhs_ (t);
14729 ffelex_token_kill (ffeexpr_tokens_[1]); /* Kill dot-dot token. */
14730 return (ffelexHandler) ffeexpr_token_rhs_;
14733 /* ffeexpr_token_binary_sw_per_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
14735 Return a pointer to this function to the lexer (ffelex), which will
14736 invoke it for the next token.
14738 A diagnostic has already been issued; just swallow a period if there is
14739 one, then continue with ffeexpr_token_binary_. */
14741 static ffelexHandler
14742 ffeexpr_token_binary_sw_per_ (ffelexToken t)
14744 if (ffelex_token_type (t) != FFELEX_typePERIOD)
14745 return (ffelexHandler) ffeexpr_token_binary_ (t);
14747 return (ffelexHandler) ffeexpr_token_binary_;
14750 /* ffeexpr_token_quote_ -- Rhs QUOTE
14752 Return a pointer to this function to the lexer (ffelex), which will
14753 invoke it for the next token.
14755 Expecting a NUMBER that we'll treat as an octal integer. */
14757 static ffelexHandler
14758 ffeexpr_token_quote_ (ffelexToken t)
14763 if (ffelex_token_type (t) != FFELEX_typeNUMBER)
14765 if (ffest_ffebad_start (FFEBAD_QUOTE_MISSES_DIGITS))
14767 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
14768 ffelex_token_where_column (ffeexpr_tokens_[0]));
14769 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
14772 ffelex_token_kill (ffeexpr_tokens_[0]);
14773 return (ffelexHandler) ffeexpr_token_rhs_ (t);
14776 /* This is kind of a kludge to prevent any whining about magical numbers
14777 that start out as these octal integers, so "20000000000 (on a 32-bit
14778 2's-complement machine) by itself won't produce an error. */
14780 anyexpr = ffebld_new_any ();
14781 ffebld_set_info (anyexpr, ffeinfo_new_any ());
14783 e = ffeexpr_expr_new_ ();
14784 e->type = FFEEXPR_exprtypeOPERAND_;
14785 e->token = ffeexpr_tokens_[0];
14786 e->u.operand = ffebld_new_conter_with_orig
14787 (ffebld_constant_new_integeroctal (t), anyexpr);
14788 ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeINTEGER,
14789 FFEINFO_kindtypeINTEGERDEFAULT, 0, FFEINFO_kindENTITY,
14790 FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
14791 ffeexpr_exprstack_push_operand_ (e);
14792 return (ffelexHandler) ffeexpr_token_binary_;
14795 /* ffeexpr_token_apostrophe_ -- Rhs APOSTROPHE
14797 Return a pointer to this function to the lexer (ffelex), which will
14798 invoke it for the next token.
14800 Handle an open-apostrophe, which begins either a character ('char-const'),
14801 typeless octal ('octal-const'O), or typeless hexadecimal ('hex-const'Z or
14802 'hex-const'X) constant. */
14804 static ffelexHandler
14805 ffeexpr_token_apostrophe_ (ffelexToken t)
14807 assert (ffelex_token_type (t) == FFELEX_typeCHARACTER);
14808 if (ffe_is_pedantic_not_90 () && (ffelex_token_length (t) == 0))
14810 ffebad_start (FFEBAD_NULL_CHAR_CONST);
14811 ffebad_here (0, ffelex_token_where_line (t),
14812 ffelex_token_where_column (t));
14815 ffeexpr_tokens_[1] = ffelex_token_use (t);
14816 return (ffelexHandler) ffeexpr_token_apos_char_;
14819 /* ffeexpr_token_apos_char_ -- Rhs APOSTROPHE CHARACTER
14821 Return a pointer to this function to the lexer (ffelex), which will
14822 invoke it for the next token.
14824 Close-apostrophe is implicit; if this token is NAME, it is a possible
14825 typeless-constant radix specifier. */
14827 static ffelexHandler
14828 ffeexpr_token_apos_char_ (ffelexToken t)
14833 ffetargetCharacterSize size;
14835 if ((ffelex_token_type (t) == FFELEX_typeNAME)
14836 || (ffelex_token_type (t) == FFELEX_typeNAMES))
14838 if ((ffelex_token_length (t) == 1)
14839 && (ffesrc_char_match_init ((c = ffelex_token_text (t)[0]), 'B',
14841 || ffesrc_char_match_init (c, 'O', 'o')
14842 || ffesrc_char_match_init (c, 'X', 'x')
14843 || ffesrc_char_match_init (c, 'Z', 'z')))
14845 e = ffeexpr_expr_new_ ();
14846 e->type = FFEEXPR_exprtypeOPERAND_;
14847 e->token = ffeexpr_tokens_[0];
14850 case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
14851 e->u.operand = ffebld_new_conter
14852 (ffebld_constant_new_typeless_bv (ffeexpr_tokens_[1]));
14853 size = ffetarget_size_typeless_binary (ffeexpr_tokens_[1]);
14856 case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
14857 e->u.operand = ffebld_new_conter
14858 (ffebld_constant_new_typeless_ov (ffeexpr_tokens_[1]));
14859 size = ffetarget_size_typeless_octal (ffeexpr_tokens_[1]);
14862 case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
14863 e->u.operand = ffebld_new_conter
14864 (ffebld_constant_new_typeless_hxv (ffeexpr_tokens_[1]));
14865 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
14868 case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
14869 e->u.operand = ffebld_new_conter
14870 (ffebld_constant_new_typeless_hzv (ffeexpr_tokens_[1]));
14871 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[1]);
14875 no_match: /* :::::::::::::::::::: */
14876 assert ("not BOXZ!" == NULL);
14880 ffebld_set_info (e->u.operand,
14881 ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
14882 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
14883 ffeexpr_exprstack_push_operand_ (e);
14884 ffelex_token_kill (ffeexpr_tokens_[1]);
14885 return (ffelexHandler) ffeexpr_token_binary_;
14888 e = ffeexpr_expr_new_ ();
14889 e->type = FFEEXPR_exprtypeOPERAND_;
14890 e->token = ffeexpr_tokens_[0];
14891 e->u.operand = ffebld_new_conter (ffebld_constant_new_characterdefault
14892 (ffeexpr_tokens_[1]));
14893 ni = ffeinfo_new (FFEINFO_basictypeCHARACTER, FFEINFO_kindtypeCHARACTERDEFAULT,
14894 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
14895 ffelex_token_length (ffeexpr_tokens_[1]));
14896 ffebld_set_info (e->u.operand, ni);
14897 ffelex_token_kill (ffeexpr_tokens_[1]);
14898 ffeexpr_exprstack_push_operand_ (e);
14899 if ((ffelex_token_type (t) == FFELEX_typeNAME)
14900 || (ffelex_token_type (t) == FFELEX_typeNAMES))
14902 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
14904 ffebad_string (ffelex_token_text (t));
14905 ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
14906 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_[0]),
14907 ffelex_token_where_column (ffeexpr_tokens_[0]));
14910 e = ffeexpr_expr_new_ ();
14911 e->type = FFEEXPR_exprtypeBINARY_;
14912 e->token = ffelex_token_use (t);
14913 e->u.operator.op = FFEEXPR_operatorCONCATENATE_;
14914 e->u.operator.prec = FFEEXPR_operatorprecedenceCONCATENATE_;
14915 e->u.operator.as = FFEEXPR_operatorassociativityCONCATENATE_;
14916 ffeexpr_exprstack_push_binary_ (e);
14917 return (ffelexHandler) ffeexpr_token_rhs_ (t);
14919 ffeexpr_is_substr_ok_ = !ffe_is_pedantic_not_90 (); /* Allow "'hello'(3:5)". */
14920 return (ffelexHandler) ffeexpr_token_substrp_ (t);
14923 /* ffeexpr_token_name_lhs_ -- Lhs NAME
14925 Return a pointer to this function to the lexer (ffelex), which will
14926 invoke it for the next token.
14928 Handle a name followed by open-paren, period (RECORD.MEMBER), percent
14929 (RECORD%MEMBER), or nothing at all. */
14931 static ffelexHandler
14932 ffeexpr_token_name_lhs_ (ffelexToken t)
14935 ffeexprParenType_ paren_type;
14940 switch (ffelex_token_type (t))
14942 case FFELEX_typeOPEN_PAREN:
14943 switch (ffeexpr_stack_->context)
14945 case FFEEXPR_contextASSIGN:
14946 case FFEEXPR_contextAGOTO:
14947 case FFEEXPR_contextFILEUNIT_DF:
14948 goto just_name; /* :::::::::::::::::::: */
14953 e = ffeexpr_expr_new_ ();
14954 e->type = FFEEXPR_exprtypeOPERAND_;
14955 e->token = ffelex_token_use (ffeexpr_tokens_[0]);
14956 s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], FALSE,
14959 switch (ffesymbol_where (s))
14961 case FFEINFO_whereLOCAL:
14962 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
14963 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recursion. */
14966 case FFEINFO_whereINTRINSIC:
14967 case FFEINFO_whereGLOBAL:
14968 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
14969 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */
14972 case FFEINFO_whereCOMMON:
14973 case FFEINFO_whereDUMMY:
14974 case FFEINFO_whereRESULT:
14977 case FFEINFO_whereNONE:
14978 case FFEINFO_whereANY:
14982 ffesymbol_error (s, ffeexpr_tokens_[0]);
14986 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
14988 e->u.operand = ffebld_new_any ();
14989 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
14993 e->u.operand = ffebld_new_symter (s,
14994 ffesymbol_generic (s),
14995 ffesymbol_specific (s),
14996 ffesymbol_implementation (s));
14997 ffebld_set_info (e->u.operand, ffesymbol_info (s));
14999 ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */
15000 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
15001 switch (paren_type)
15003 case FFEEXPR_parentypeSUBROUTINE_:
15004 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15007 ffeexpr_rhs (ffeexpr_stack_->pool,
15008 FFEEXPR_contextACTUALARG_,
15009 ffeexpr_token_arguments_);
15011 case FFEEXPR_parentypeARRAY_:
15012 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15013 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
15014 ffeexpr_stack_->rank = 0;
15015 ffeexpr_stack_->constant = TRUE;
15016 ffeexpr_stack_->immediate = TRUE;
15017 switch (ffeexpr_stack_->context)
15019 case FFEEXPR_contextDATAIMPDOITEM_:
15022 ffeexpr_rhs (ffeexpr_stack_->pool,
15023 FFEEXPR_contextDATAIMPDOINDEX_,
15024 ffeexpr_token_elements_);
15026 case FFEEXPR_contextEQUIVALENCE:
15029 ffeexpr_rhs (ffeexpr_stack_->pool,
15030 FFEEXPR_contextEQVINDEX_,
15031 ffeexpr_token_elements_);
15036 ffeexpr_rhs (ffeexpr_stack_->pool,
15037 FFEEXPR_contextINDEX_,
15038 ffeexpr_token_elements_);
15041 case FFEEXPR_parentypeSUBSTRING_:
15042 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
15043 ffeexpr_tokens_[0]);
15046 ffeexpr_rhs (ffeexpr_stack_->pool,
15047 FFEEXPR_contextINDEX_,
15048 ffeexpr_token_substring_);
15050 case FFEEXPR_parentypeEQUIVALENCE_:
15051 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15052 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
15053 ffeexpr_stack_->rank = 0;
15054 ffeexpr_stack_->constant = TRUE;
15055 ffeexpr_stack_->immediate = TRUE;
15058 ffeexpr_rhs (ffeexpr_stack_->pool,
15059 FFEEXPR_contextEQVINDEX_,
15060 ffeexpr_token_equivalence_);
15062 case FFEEXPR_parentypeFUNCTION_: /* Invalid case. */
15063 case FFEEXPR_parentypeFUNSUBSTR_: /* Invalid case. */
15064 ffesymbol_error (s, ffeexpr_tokens_[0]);
15065 /* Fall through. */
15066 case FFEEXPR_parentypeANY_:
15067 e->u.operand = ffebld_new_any ();
15068 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15071 ffeexpr_rhs (ffeexpr_stack_->pool,
15072 FFEEXPR_contextACTUALARG_,
15073 ffeexpr_token_anything_);
15076 assert ("bad paren type" == NULL);
15080 case FFELEX_typeEQUALS: /* As in "VAR=". */
15081 switch (ffeexpr_stack_->context)
15083 case FFEEXPR_contextIMPDOITEM_: /* within
15084 "(,VAR=start,end[,incr])". */
15085 case FFEEXPR_contextIMPDOITEMDF_:
15086 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
15089 case FFEEXPR_contextDATAIMPDOITEM_:
15090 ffeexpr_stack_->context = FFEEXPR_contextDATAIMPDOCTRL_;
15099 case FFELEX_typePERIOD:
15100 case FFELEX_typePERCENT:
15101 assert ("FOO%, FOO. not yet supported!~~" == NULL);
15109 just_name: /* :::::::::::::::::::: */
15110 e = ffeexpr_expr_new_ ();
15111 e->type = FFEEXPR_exprtypeOPERAND_;
15112 e->token = ffeexpr_tokens_[0];
15113 s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0],
15114 (ffeexpr_stack_->context
15115 == FFEEXPR_contextSUBROUTINEREF));
15117 switch (ffesymbol_where (s))
15119 case FFEINFO_whereCONSTANT:
15120 if ((ffeexpr_stack_->context != FFEEXPR_contextPARAMETER)
15121 || (ffesymbol_kind (s) != FFEINFO_kindENTITY))
15122 ffesymbol_error (s, ffeexpr_tokens_[0]);
15125 case FFEINFO_whereIMMEDIATE:
15126 if ((ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOCTRL_)
15127 && (ffeexpr_stack_->context != FFEEXPR_contextDATAIMPDOINDEX_))
15128 ffesymbol_error (s, ffeexpr_tokens_[0]);
15131 case FFEINFO_whereLOCAL:
15132 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
15133 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Recurse!. */
15136 case FFEINFO_whereINTRINSIC:
15137 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
15138 ffesymbol_error (s, ffeexpr_tokens_[0]); /* Can call intrin. */
15145 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15147 expr = ffebld_new_any ();
15148 info = ffeinfo_new_any ();
15149 ffebld_set_info (expr, info);
15153 expr = ffebld_new_symter (s,
15154 ffesymbol_generic (s),
15155 ffesymbol_specific (s),
15156 ffesymbol_implementation (s));
15157 info = ffesymbol_info (s);
15158 ffebld_set_info (expr, info);
15159 if (ffesymbol_is_doiter (s))
15161 ffebad_start (FFEBAD_DOITER);
15162 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15163 ffelex_token_where_column (ffeexpr_tokens_[0]));
15164 ffest_ffebad_here_doiter (1, s);
15165 ffebad_string (ffesymbol_text (s));
15168 expr = ffeexpr_collapse_symter (expr, ffeexpr_tokens_[0]);
15171 if (ffeexpr_stack_->context == FFEEXPR_contextSUBROUTINEREF)
15173 if (ffebld_op (expr) == FFEBLD_opANY)
15175 expr = ffebld_new_any ();
15176 ffebld_set_info (expr, ffeinfo_new_any ());
15180 expr = ffebld_new_subrref (expr, NULL); /* No argument list. */
15181 if (ffesymbol_generic (s) != FFEINTRIN_genNONE)
15182 ffeintrin_fulfill_generic (&expr, &info, e->token);
15183 else if (ffesymbol_specific (s) != FFEINTRIN_specNONE)
15184 ffeintrin_fulfill_specific (&expr, &info, NULL, e->token);
15186 ffeexpr_fulfill_call_ (&expr, e->token);
15188 if (ffebld_op (expr) != FFEBLD_opANY)
15189 ffebld_set_info (expr,
15190 ffeinfo_new (ffeinfo_basictype (info),
15191 ffeinfo_kindtype (info),
15193 FFEINFO_kindENTITY,
15194 FFEINFO_whereFLEETING,
15195 ffeinfo_size (info)));
15197 ffebld_set_info (expr, ffeinfo_new_any ());
15201 e->u.operand = expr;
15202 ffeexpr_exprstack_push_operand_ (e);
15203 return (ffelexHandler) ffeexpr_finished_ (t);
15206 /* ffeexpr_token_name_arg_ -- Rhs NAME
15208 Return a pointer to this function to the lexer (ffelex), which will
15209 invoke it for the next token.
15211 Handle first token in an actual-arg (or possible actual-arg) context
15212 being a NAME, and use second token to refine the context. */
15214 static ffelexHandler
15215 ffeexpr_token_name_arg_ (ffelexToken t)
15217 switch (ffelex_token_type (t))
15219 case FFELEX_typeCLOSE_PAREN:
15220 case FFELEX_typeCOMMA:
15221 switch (ffeexpr_stack_->context)
15223 case FFEEXPR_contextINDEXORACTUALARG_:
15224 ffeexpr_stack_->context = FFEEXPR_contextACTUALARG_;
15227 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15228 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARG_;
15237 switch (ffeexpr_stack_->context)
15239 case FFEEXPR_contextACTUALARG_:
15240 ffeexpr_stack_->context = FFEEXPR_contextACTUALARGEXPR_;
15243 case FFEEXPR_contextINDEXORACTUALARG_:
15244 ffeexpr_stack_->context = FFEEXPR_contextINDEXORACTUALARGEXPR_;
15247 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15248 ffeexpr_stack_->context = FFEEXPR_contextSFUNCDEFACTUALARGEXPR_;
15251 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15252 ffeexpr_stack_->context
15253 = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_;
15257 assert ("bad context in _name_arg_" == NULL);
15263 return (ffelexHandler) ffeexpr_token_name_rhs_ (t);
15266 /* ffeexpr_token_name_rhs_ -- Rhs NAME
15268 Return a pointer to this function to the lexer (ffelex), which will
15269 invoke it for the next token.
15271 Handle a name followed by open-paren, apostrophe (O'octal-const',
15272 Z'hex-const', or X'hex-const'), period (RECORD.MEMBER).
15275 When followed by apostrophe or quote, set lex hexnum flag on so
15276 [0-9] as first char of next token seen as starting a potentially
15279 In case of intrinsic, decorate its SYMTER with the type info for
15280 the specific intrinsic. */
15282 static ffelexHandler
15283 ffeexpr_token_name_rhs_ (ffelexToken t)
15286 ffeexprParenType_ paren_type;
15290 switch (ffelex_token_type (t))
15292 case FFELEX_typeQUOTE:
15293 case FFELEX_typeAPOSTROPHE:
15294 ffeexpr_tokens_[1] = ffelex_token_use (t);
15295 ffelex_set_hexnum (TRUE);
15296 return (ffelexHandler) ffeexpr_token_name_apos_;
15298 case FFELEX_typeOPEN_PAREN:
15299 e = ffeexpr_expr_new_ ();
15300 e->type = FFEEXPR_exprtypeOPERAND_;
15301 e->token = ffelex_token_use (ffeexpr_tokens_[0]);
15302 s = ffeexpr_declare_parenthesized_ (ffeexpr_tokens_[0], TRUE,
15304 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15305 e->u.operand = ffebld_new_any ();
15307 e->u.operand = ffebld_new_symter (s, ffesymbol_generic (s),
15308 ffesymbol_specific (s),
15309 ffesymbol_implementation (s));
15310 ffeexpr_exprstack_push_ (e); /* Not a complete operand yet. */
15311 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
15312 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15314 case FFEEXPR_contextSFUNCDEF:
15315 case FFEEXPR_contextSFUNCDEFINDEX_:
15316 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15317 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15321 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15322 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15323 assert ("weird context!" == NULL);
15331 switch (paren_type)
15333 case FFEEXPR_parentypeFUNCTION_:
15334 ffebld_set_info (e->u.operand, ffesymbol_info (s));
15335 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15336 if (ffesymbol_where (s) == FFEINFO_whereCONSTANT)
15337 { /* A statement function. */
15338 ffeexpr_stack_->num_args
15339 = ffebld_list_length
15340 (ffeexpr_stack_->next_dummy
15341 = ffesymbol_dummyargs (s));
15342 ffeexpr_stack_->tokens[1] = NULL; /* !=NULL when > num_args. */
15344 else if ((ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
15345 && !ffe_is_pedantic_not_90 ()
15346 && ((ffesymbol_implementation (s)
15347 == FFEINTRIN_impICHAR)
15348 || (ffesymbol_implementation (s)
15349 == FFEINTRIN_impIACHAR)
15350 || (ffesymbol_implementation (s)
15351 == FFEINTRIN_impLEN)))
15352 { /* Allow arbitrary concatenations. */
15355 ffeexpr_rhs (ffeexpr_stack_->pool,
15357 ? FFEEXPR_contextSFUNCDEF
15358 : FFEEXPR_contextLET,
15359 ffeexpr_token_arguments_);
15363 ffeexpr_rhs (ffeexpr_stack_->pool,
15365 ? FFEEXPR_contextSFUNCDEFACTUALARG_
15366 : FFEEXPR_contextACTUALARG_,
15367 ffeexpr_token_arguments_);
15369 case FFEEXPR_parentypeARRAY_:
15370 ffebld_set_info (e->u.operand,
15371 ffesymbol_info (ffebld_symter (e->u.operand)));
15372 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
15373 ffeexpr_stack_->bound_list = ffesymbol_dims (s);
15374 ffeexpr_stack_->rank = 0;
15375 ffeexpr_stack_->constant = TRUE;
15376 ffeexpr_stack_->immediate = TRUE;
15377 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
15379 ? FFEEXPR_contextSFUNCDEFINDEX_
15380 : FFEEXPR_contextINDEX_,
15381 ffeexpr_token_elements_);
15383 case FFEEXPR_parentypeSUBSTRING_:
15384 ffebld_set_info (e->u.operand,
15385 ffesymbol_info (ffebld_symter (e->u.operand)));
15386 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
15387 ffeexpr_tokens_[0]);
15390 ffeexpr_rhs (ffeexpr_stack_->pool,
15392 ? FFEEXPR_contextSFUNCDEFINDEX_
15393 : FFEEXPR_contextINDEX_,
15394 ffeexpr_token_substring_);
15396 case FFEEXPR_parentypeFUNSUBSTR_:
15399 ffeexpr_rhs (ffeexpr_stack_->pool,
15401 ? FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
15402 : FFEEXPR_contextINDEXORACTUALARG_,
15403 ffeexpr_token_funsubstr_);
15405 case FFEEXPR_parentypeANY_:
15406 ffebld_set_info (e->u.operand, ffesymbol_info (s));
15409 ffeexpr_rhs (ffeexpr_stack_->pool,
15411 ? FFEEXPR_contextSFUNCDEFACTUALARG_
15412 : FFEEXPR_contextACTUALARG_,
15413 ffeexpr_token_anything_);
15416 assert ("bad paren type" == NULL);
15420 case FFELEX_typeEQUALS: /* As in "VAR=". */
15421 switch (ffeexpr_stack_->context)
15423 case FFEEXPR_contextIMPDOITEM_: /* "(,VAR=start,end[,incr])". */
15424 case FFEEXPR_contextIMPDOITEMDF_:
15425 ffeexpr_stack_->is_rhs = FALSE; /* Really an lhs construct. */
15426 ffeexpr_stack_->context = FFEEXPR_contextIMPDOCTRL_;
15435 case FFELEX_typePERIOD:
15436 case FFELEX_typePERCENT:
15437 ~~Support these two someday, though not required
15438 assert ("FOO%, FOO. not yet supported!~~" == NULL);
15446 switch (ffeexpr_stack_->context)
15448 case FFEEXPR_contextINDEXORACTUALARG_:
15449 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
15450 assert ("strange context" == NULL);
15457 e = ffeexpr_expr_new_ ();
15458 e->type = FFEEXPR_exprtypeOPERAND_;
15459 e->token = ffeexpr_tokens_[0];
15460 s = ffeexpr_declare_unadorned_ (ffeexpr_tokens_[0], FALSE);
15461 if (ffesymbol_attrs (s) & FFESYMBOL_attrsANY)
15463 e->u.operand = ffebld_new_any ();
15464 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15468 e->u.operand = ffebld_new_symter (s, FFEINTRIN_genNONE,
15469 ffesymbol_specific (s),
15470 ffesymbol_implementation (s));
15471 if (ffesymbol_specific (s) == FFEINTRIN_specNONE)
15472 ffebld_set_info (e->u.operand, ffeinfo_use (ffesymbol_info (s)));
15474 { /* Decorate the SYMTER with the actual type
15475 of the intrinsic. */
15476 ffebld_set_info (e->u.operand, ffeinfo_new
15477 (ffeintrin_basictype (ffesymbol_specific (s)),
15478 ffeintrin_kindtype (ffesymbol_specific (s)),
15480 ffesymbol_kind (s),
15481 ffesymbol_where (s),
15482 FFETARGET_charactersizeNONE));
15484 if (ffesymbol_is_doiter (s))
15485 ffebld_symter_set_is_doiter (e->u.operand, TRUE);
15486 e->u.operand = ffeexpr_collapse_symter (e->u.operand,
15487 ffeexpr_tokens_[0]);
15489 ffeexpr_exprstack_push_operand_ (e);
15490 return (ffelexHandler) ffeexpr_token_binary_ (t);
15493 /* ffeexpr_token_name_apos_ -- Rhs NAME APOSTROPHE
15495 Return a pointer to this function to the lexer (ffelex), which will
15496 invoke it for the next token.
15498 Expecting a NAME token, analyze the previous NAME token to see what kind,
15499 if any, typeless constant we've got.
15502 Expect a NAME instead of CHARACTER in this situation. */
15504 static ffelexHandler
15505 ffeexpr_token_name_apos_ (ffelexToken t)
15509 ffelex_set_hexnum (FALSE);
15511 switch (ffelex_token_type (t))
15513 case FFELEX_typeNAME:
15514 ffeexpr_tokens_[2] = ffelex_token_use (t);
15515 return (ffelexHandler) ffeexpr_token_name_apos_name_;
15521 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
15523 ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
15524 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15525 ffelex_token_where_column (ffeexpr_tokens_[0]));
15526 ffebad_here (1, ffelex_token_where_line (t),
15527 ffelex_token_where_column (t));
15531 ffelex_token_kill (ffeexpr_tokens_[1]);
15533 e = ffeexpr_expr_new_ ();
15534 e->type = FFEEXPR_exprtypeOPERAND_;
15535 e->u.operand = ffebld_new_any ();
15536 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15537 e->token = ffeexpr_tokens_[0];
15538 ffeexpr_exprstack_push_operand_ (e);
15540 return (ffelexHandler) ffeexpr_token_binary_ (t);
15543 /* ffeexpr_token_name_apos_name_ -- Rhs NAME APOSTROPHE NAME
15545 Return a pointer to this function to the lexer (ffelex), which will
15546 invoke it for the next token.
15548 Expecting an APOSTROPHE token, analyze the previous NAME token to see
15549 what kind, if any, typeless constant we've got. */
15551 static ffelexHandler
15552 ffeexpr_token_name_apos_name_ (ffelexToken t)
15557 e = ffeexpr_expr_new_ ();
15558 e->type = FFEEXPR_exprtypeOPERAND_;
15559 e->token = ffeexpr_tokens_[0];
15561 if ((ffelex_token_type (t) == ffelex_token_type (ffeexpr_tokens_[1]))
15562 && (ffelex_token_length (ffeexpr_tokens_[0]) == 1)
15563 && (ffesrc_char_match_init ((c = ffelex_token_text (ffeexpr_tokens_[0])[0]),
15565 || ffesrc_char_match_init (c, 'O', 'o')
15566 || ffesrc_char_match_init (c, 'X', 'x')
15567 || ffesrc_char_match_init (c, 'Z', 'z')))
15569 ffetargetCharacterSize size;
15571 if (!ffe_is_typeless_boz ()) {
15575 case FFESRC_CASE_MATCH_INIT ('B', 'b', imatch_b, no_imatch):
15576 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerbinary
15577 (ffeexpr_tokens_[2]));
15580 case FFESRC_CASE_MATCH_INIT ('O', 'o', imatch_o, no_imatch):
15581 e->u.operand = ffebld_new_conter (ffebld_constant_new_integeroctal
15582 (ffeexpr_tokens_[2]));
15585 case FFESRC_CASE_MATCH_INIT ('X', 'x', imatch_x, no_imatch):
15586 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
15587 (ffeexpr_tokens_[2]));
15590 case FFESRC_CASE_MATCH_INIT ('Z', 'z', imatch_z, no_imatch):
15591 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerhex
15592 (ffeexpr_tokens_[2]));
15596 no_imatch: /* :::::::::::::::::::: */
15597 assert ("not BOXZ!" == NULL);
15601 ffebld_set_info (e->u.operand,
15602 ffeinfo_new (FFEINFO_basictypeINTEGER,
15603 FFEINFO_kindtypeINTEGERDEFAULT, 0,
15604 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
15605 FFETARGET_charactersizeNONE));
15606 ffeexpr_exprstack_push_operand_ (e);
15607 ffelex_token_kill (ffeexpr_tokens_[1]);
15608 ffelex_token_kill (ffeexpr_tokens_[2]);
15609 return (ffelexHandler) ffeexpr_token_binary_;
15614 case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b, no_match):
15615 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_bm
15616 (ffeexpr_tokens_[2]));
15617 size = ffetarget_size_typeless_binary (ffeexpr_tokens_[2]);
15620 case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o, no_match):
15621 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_om
15622 (ffeexpr_tokens_[2]));
15623 size = ffetarget_size_typeless_octal (ffeexpr_tokens_[2]);
15626 case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x, no_match):
15627 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hxm
15628 (ffeexpr_tokens_[2]));
15629 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15632 case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z, no_match):
15633 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
15634 (ffeexpr_tokens_[2]));
15635 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15639 no_match: /* :::::::::::::::::::: */
15640 assert ("not BOXZ!" == NULL);
15641 e->u.operand = ffebld_new_conter (ffebld_constant_new_typeless_hzm
15642 (ffeexpr_tokens_[2]));
15643 size = ffetarget_size_typeless_hex (ffeexpr_tokens_[2]);
15646 ffebld_set_info (e->u.operand,
15647 ffeinfo_new (FFEINFO_basictypeTYPELESS, FFEINFO_kindtypeNONE,
15648 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, size));
15649 ffeexpr_exprstack_push_operand_ (e);
15650 ffelex_token_kill (ffeexpr_tokens_[1]);
15651 ffelex_token_kill (ffeexpr_tokens_[2]);
15652 return (ffelexHandler) ffeexpr_token_binary_;
15655 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER))
15657 ffebad_string (ffelex_token_text (ffeexpr_tokens_[0]));
15658 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15659 ffelex_token_where_column (ffeexpr_tokens_[0]));
15660 ffebad_here (1, ffelex_token_where_line (t), ffelex_token_where_column (t));
15664 ffelex_token_kill (ffeexpr_tokens_[1]);
15665 ffelex_token_kill (ffeexpr_tokens_[2]);
15667 e->type = FFEEXPR_exprtypeOPERAND_;
15668 e->u.operand = ffebld_new_any ();
15669 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
15670 e->token = ffeexpr_tokens_[0];
15671 ffeexpr_exprstack_push_operand_ (e);
15673 switch (ffelex_token_type (t))
15675 case FFELEX_typeAPOSTROPHE:
15676 case FFELEX_typeQUOTE:
15677 return (ffelexHandler) ffeexpr_token_binary_;
15680 return (ffelexHandler) ffeexpr_token_binary_ (t);
15684 /* ffeexpr_token_percent_ -- Rhs PERCENT
15686 Handle a percent sign possibly followed by "LOC". If followed instead
15687 by "VAL", "REF", or "DESCR", issue an error message and substitute
15688 "LOC". If followed by something else, treat the percent sign as a
15689 spurious incorrect token and reprocess the token via _rhs_. */
15691 static ffelexHandler
15692 ffeexpr_token_percent_ (ffelexToken t)
15694 switch (ffelex_token_type (t))
15696 case FFELEX_typeNAME:
15697 case FFELEX_typeNAMES:
15698 ffeexpr_stack_->percent = ffeexpr_percent_ (t);
15699 ffeexpr_tokens_[1] = ffelex_token_use (t);
15700 return (ffelexHandler) ffeexpr_token_percent_name_;
15703 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
15705 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15706 ffelex_token_where_column (ffeexpr_tokens_[0]));
15707 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
15708 ffelex_token_where_column (ffeexpr_stack_->first_token));
15711 ffelex_token_kill (ffeexpr_tokens_[0]);
15712 return (ffelexHandler) ffeexpr_token_rhs_ (t);
15716 /* ffeexpr_token_percent_name_ -- Rhs PERCENT NAME
15718 Make sure the token is OPEN_PAREN and prepare for the one-item list of
15719 LHS expressions. Else display an error message. */
15721 static ffelexHandler
15722 ffeexpr_token_percent_name_ (ffelexToken t)
15724 ffelexHandler nexthandler;
15726 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
15728 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
15730 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15731 ffelex_token_where_column (ffeexpr_tokens_[0]));
15732 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->first_token),
15733 ffelex_token_where_column (ffeexpr_stack_->first_token));
15736 ffelex_token_kill (ffeexpr_tokens_[0]);
15737 nexthandler = (ffelexHandler) ffeexpr_token_rhs_ (ffeexpr_tokens_[1]);
15738 ffelex_token_kill (ffeexpr_tokens_[1]);
15739 return (ffelexHandler) (*nexthandler) (t);
15742 switch (ffeexpr_stack_->percent)
15745 if (ffest_ffebad_start (FFEBAD_INVALID_PERCENT))
15747 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_[0]),
15748 ffelex_token_where_column (ffeexpr_tokens_[0]));
15749 ffebad_string (ffelex_token_text (ffeexpr_tokens_[1]));
15752 ffeexpr_stack_->percent = FFEEXPR_percentLOC_;
15753 /* Fall through. */
15754 case FFEEXPR_percentLOC_:
15755 ffeexpr_stack_->tokens[0] = ffeexpr_tokens_[0];
15756 ffelex_token_kill (ffeexpr_tokens_[1]);
15757 ffeexpr_stack_->tokens[1] = ffelex_token_use (t);
15758 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
15759 FFEEXPR_contextLOC_,
15760 ffeexpr_cb_end_loc_);
15764 /* ffeexpr_make_float_const_ -- Make a floating-point constant
15768 Pass 'E', 'D', or 'Q' for exponent letter. */
15771 ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
15772 ffelexToken decimal, ffelexToken fraction,
15773 ffelexToken exponent, ffelexToken exponent_sign,
15774 ffelexToken exponent_digits)
15778 e = ffeexpr_expr_new_ ();
15779 e->type = FFEEXPR_exprtypeOPERAND_;
15780 if (integer != NULL)
15781 e->token = ffelex_token_use (integer);
15784 assert (decimal != NULL);
15785 e->token = ffelex_token_use (decimal);
15788 switch (exp_letter)
15790 #if !FFETARGET_okREALQUAD
15791 case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
15792 if (ffebad_start (FFEBAD_QUAD_UNSUPPORTED))
15794 ffebad_here (0, ffelex_token_where_line (e->token),
15795 ffelex_token_where_column (e->token));
15798 goto match_d; /* The FFESRC_CASE_* macros don't
15799 allow fall-through! */
15802 case FFESRC_CASE_MATCH_INIT ('D', 'd', match_d, no_match):
15803 e->u.operand = ffebld_new_conter (ffebld_constant_new_realdouble
15804 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15805 ffebld_set_info (e->u.operand,
15806 ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALDOUBLE,
15807 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15810 case FFESRC_CASE_MATCH_INIT ('E', 'e', match_e, no_match):
15811 e->u.operand = ffebld_new_conter (ffebld_constant_new_realdefault
15812 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15813 ffebld_set_info (e->u.operand, ffeinfo_new (FFEINFO_basictypeREAL,
15814 FFEINFO_kindtypeREALDEFAULT, 0, FFEINFO_kindENTITY,
15815 FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15818 #if FFETARGET_okREALQUAD
15819 case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q, no_match):
15820 e->u.operand = ffebld_new_conter (ffebld_constant_new_realquad
15821 (integer, decimal, fraction, exponent, exponent_sign, exponent_digits));
15822 ffebld_set_info (e->u.operand,
15823 ffeinfo_new (FFEINFO_basictypeREAL, FFEINFO_kindtypeREALQUAD,
15824 0, FFEINFO_kindENTITY, FFEINFO_whereCONSTANT, FFETARGET_charactersizeNONE));
15828 case 'I': /* Make an integer. */
15829 e->u.operand = ffebld_new_conter (ffebld_constant_new_integerdefault
15830 (ffeexpr_tokens_[0]));
15831 ffebld_set_info (e->u.operand,
15832 ffeinfo_new (FFEINFO_basictypeINTEGER,
15833 FFEINFO_kindtypeINTEGERDEFAULT, 0,
15834 FFEINFO_kindENTITY, FFEINFO_whereCONSTANT,
15835 FFETARGET_charactersizeNONE));
15839 no_match: /* :::::::::::::::::::: */
15840 assert ("Lost the exponent letter!" == NULL);
15843 ffeexpr_exprstack_push_operand_ (e);
15846 /* Just like ffesymbol_declare_local, except performs any implicit info
15847 assignment necessary. */
15850 ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin)
15856 s = ffesymbol_declare_local (t, maybe_intrin);
15858 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15859 /* Special-case these since they can involve a different concept
15860 of "state" (in the stmtfunc name space). */
15862 case FFEEXPR_contextDATAIMPDOINDEX_:
15863 case FFEEXPR_contextDATAIMPDOCTRL_:
15864 if (ffeexpr_context_outer_ (ffeexpr_stack_)
15865 == FFEEXPR_contextDATAIMPDOINDEX_)
15866 s = ffeexpr_sym_impdoitem_ (s, t);
15868 if (ffeexpr_stack_->is_rhs)
15869 s = ffeexpr_sym_impdoitem_ (s, t);
15871 s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
15872 bad = (ffesymbol_kind (s) != FFEINFO_kindENTITY)
15873 || ((ffesymbol_where (s) != FFEINFO_whereCONSTANT)
15874 && (ffesymbol_where (s) != FFEINFO_whereIMMEDIATE));
15875 if (bad && (ffesymbol_kind (s) != FFEINFO_kindANY))
15876 ffesymbol_error (s, t);
15883 switch ((ffesymbol_sfdummyparent (s) == NULL)
15884 ? ffesymbol_state (s)
15885 : FFESYMBOL_stateUNDERSTOOD)
15887 case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr
15889 if (!ffest_seen_first_exec ())
15890 goto seen; /* :::::::::::::::::::: */
15891 /* Fall through. */
15892 case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */
15893 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15895 case FFEEXPR_contextSUBROUTINEREF:
15896 s = ffeexpr_sym_lhs_call_ (s, t);
15899 case FFEEXPR_contextFILEEXTFUNC:
15900 s = ffeexpr_sym_lhs_extfunc_ (s, t);
15903 case FFEEXPR_contextSFUNCDEFACTUALARG_:
15904 s = ffecom_sym_exec_transition (s);
15905 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15906 goto understood; /* :::::::::::::::::::: */
15907 /* Fall through. */
15908 case FFEEXPR_contextACTUALARG_:
15909 s = ffeexpr_sym_rhs_actualarg_ (s, t);
15912 case FFEEXPR_contextDATA:
15913 if (ffeexpr_stack_->is_rhs)
15914 s = ffeexpr_sym_rhs_let_ (s, t);
15916 s = ffeexpr_sym_lhs_data_ (s, t);
15919 case FFEEXPR_contextDATAIMPDOITEM_:
15920 s = ffeexpr_sym_lhs_data_ (s, t);
15923 case FFEEXPR_contextSFUNCDEF:
15924 case FFEEXPR_contextSFUNCDEFINDEX_:
15925 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
15926 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
15927 s = ffecom_sym_exec_transition (s);
15928 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
15929 goto understood; /* :::::::::::::::::::: */
15930 /* Fall through. */
15931 case FFEEXPR_contextLET:
15932 case FFEEXPR_contextPAREN_:
15933 case FFEEXPR_contextACTUALARGEXPR_:
15934 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
15935 case FFEEXPR_contextASSIGN:
15936 case FFEEXPR_contextIOLIST:
15937 case FFEEXPR_contextIOLISTDF:
15938 case FFEEXPR_contextDO:
15939 case FFEEXPR_contextDOWHILE:
15940 case FFEEXPR_contextAGOTO:
15941 case FFEEXPR_contextCGOTO:
15942 case FFEEXPR_contextIF:
15943 case FFEEXPR_contextARITHIF:
15944 case FFEEXPR_contextFORMAT:
15945 case FFEEXPR_contextSTOP:
15946 case FFEEXPR_contextRETURN:
15947 case FFEEXPR_contextSELECTCASE:
15948 case FFEEXPR_contextCASE:
15949 case FFEEXPR_contextFILEASSOC:
15950 case FFEEXPR_contextFILEINT:
15951 case FFEEXPR_contextFILEDFINT:
15952 case FFEEXPR_contextFILELOG:
15953 case FFEEXPR_contextFILENUM:
15954 case FFEEXPR_contextFILENUMAMBIG:
15955 case FFEEXPR_contextFILECHAR:
15956 case FFEEXPR_contextFILENUMCHAR:
15957 case FFEEXPR_contextFILEDFCHAR:
15958 case FFEEXPR_contextFILEKEY:
15959 case FFEEXPR_contextFILEUNIT:
15960 case FFEEXPR_contextFILEUNIT_DF:
15961 case FFEEXPR_contextFILEUNITAMBIG:
15962 case FFEEXPR_contextFILEFORMAT:
15963 case FFEEXPR_contextFILENAMELIST:
15964 case FFEEXPR_contextFILEVXTCODE:
15965 case FFEEXPR_contextINDEX_:
15966 case FFEEXPR_contextIMPDOITEM_:
15967 case FFEEXPR_contextIMPDOITEMDF_:
15968 case FFEEXPR_contextIMPDOCTRL_:
15969 case FFEEXPR_contextLOC_:
15970 if (ffeexpr_stack_->is_rhs)
15971 s = ffeexpr_sym_rhs_let_ (s, t);
15973 s = ffeexpr_sym_lhs_let_ (s, t);
15976 case FFEEXPR_contextCHARACTERSIZE:
15977 case FFEEXPR_contextEQUIVALENCE:
15978 case FFEEXPR_contextINCLUDE:
15979 case FFEEXPR_contextPARAMETER:
15980 case FFEEXPR_contextDIMLIST:
15981 case FFEEXPR_contextDIMLISTCOMMON:
15982 case FFEEXPR_contextKINDTYPE:
15983 case FFEEXPR_contextINITVAL:
15984 case FFEEXPR_contextEQVINDEX_:
15985 break; /* Will turn into errors below. */
15988 ffesymbol_error (s, t);
15991 /* Fall through. */
15992 case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */
15993 understood: /* :::::::::::::::::::: */
15994 k = ffesymbol_kind (s);
15995 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
15997 case FFEEXPR_contextSUBROUTINEREF:
15998 bad = ((k != FFEINFO_kindSUBROUTINE)
15999 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
16000 || (k != FFEINFO_kindNONE)));
16003 case FFEEXPR_contextFILEEXTFUNC:
16004 bad = (k != FFEINFO_kindFUNCTION)
16005 || (ffesymbol_where (s) != FFEINFO_whereGLOBAL);
16008 case FFEEXPR_contextSFUNCDEFACTUALARG_:
16009 case FFEEXPR_contextACTUALARG_:
16012 case FFEINFO_kindENTITY:
16016 case FFEINFO_kindFUNCTION:
16017 case FFEINFO_kindSUBROUTINE:
16019 = ((ffesymbol_where (s) != FFEINFO_whereGLOBAL)
16020 && (ffesymbol_where (s) != FFEINFO_whereDUMMY)
16021 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
16022 || !ffeintrin_is_actualarg (ffesymbol_specific (s))));
16025 case FFEINFO_kindNONE:
16026 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
16028 bad = !(ffeintrin_is_actualarg (ffesymbol_specific (s)));
16032 /* If state is UNDERSTOOD here, it's CHAR*(*) or attrsANY,
16033 and in the former case, attrsTYPE is set, so we
16034 see this as an error as we should, since CHAR*(*)
16035 cannot be actually referenced in a main/block data
16038 if ((ffesymbol_attrs (s) & (FFESYMBOL_attrsANY
16039 | FFESYMBOL_attrsEXTERNAL
16040 | FFESYMBOL_attrsTYPE))
16041 == FFESYMBOL_attrsEXTERNAL)
16053 case FFEEXPR_contextDATA:
16054 if (ffeexpr_stack_->is_rhs)
16055 bad = (k != FFEINFO_kindENTITY)
16056 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16058 bad = (k != FFEINFO_kindENTITY)
16059 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
16060 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
16061 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
16064 case FFEEXPR_contextDATAIMPDOITEM_:
16065 bad = TRUE; /* Unadorned item never valid. */
16068 case FFEEXPR_contextSFUNCDEF:
16069 case FFEEXPR_contextSFUNCDEFINDEX_:
16070 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16071 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16072 case FFEEXPR_contextLET:
16073 case FFEEXPR_contextPAREN_:
16074 case FFEEXPR_contextACTUALARGEXPR_:
16075 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16076 case FFEEXPR_contextASSIGN:
16077 case FFEEXPR_contextIOLIST:
16078 case FFEEXPR_contextIOLISTDF:
16079 case FFEEXPR_contextDO:
16080 case FFEEXPR_contextDOWHILE:
16081 case FFEEXPR_contextAGOTO:
16082 case FFEEXPR_contextCGOTO:
16083 case FFEEXPR_contextIF:
16084 case FFEEXPR_contextARITHIF:
16085 case FFEEXPR_contextFORMAT:
16086 case FFEEXPR_contextSTOP:
16087 case FFEEXPR_contextRETURN:
16088 case FFEEXPR_contextSELECTCASE:
16089 case FFEEXPR_contextCASE:
16090 case FFEEXPR_contextFILEASSOC:
16091 case FFEEXPR_contextFILEINT:
16092 case FFEEXPR_contextFILEDFINT:
16093 case FFEEXPR_contextFILELOG:
16094 case FFEEXPR_contextFILENUM:
16095 case FFEEXPR_contextFILENUMAMBIG:
16096 case FFEEXPR_contextFILECHAR:
16097 case FFEEXPR_contextFILENUMCHAR:
16098 case FFEEXPR_contextFILEDFCHAR:
16099 case FFEEXPR_contextFILEKEY:
16100 case FFEEXPR_contextFILEUNIT:
16101 case FFEEXPR_contextFILEUNIT_DF:
16102 case FFEEXPR_contextFILEUNITAMBIG:
16103 case FFEEXPR_contextFILEFORMAT:
16104 case FFEEXPR_contextFILENAMELIST:
16105 case FFEEXPR_contextFILEVXTCODE:
16106 case FFEEXPR_contextINDEX_:
16107 case FFEEXPR_contextIMPDOITEM_:
16108 case FFEEXPR_contextIMPDOITEMDF_:
16109 case FFEEXPR_contextIMPDOCTRL_:
16110 case FFEEXPR_contextLOC_:
16111 bad = (k != FFEINFO_kindENTITY); /* This catches "SUBROUTINE
16112 X(A);EXTERNAL A;CALL
16113 Y(A);B=A", for example. */
16116 case FFEEXPR_contextCHARACTERSIZE:
16117 case FFEEXPR_contextEQUIVALENCE:
16118 case FFEEXPR_contextPARAMETER:
16119 case FFEEXPR_contextDIMLIST:
16120 case FFEEXPR_contextDIMLISTCOMMON:
16121 case FFEEXPR_contextKINDTYPE:
16122 case FFEEXPR_contextINITVAL:
16123 case FFEEXPR_contextEQVINDEX_:
16124 bad = (k != FFEINFO_kindENTITY)
16125 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
16128 case FFEEXPR_contextINCLUDE:
16136 if (bad && (k != FFEINFO_kindANY))
16137 ffesymbol_error (s, t);
16140 case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */
16141 seen: /* :::::::::::::::::::: */
16142 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
16144 case FFEEXPR_contextPARAMETER:
16145 if (ffeexpr_stack_->is_rhs)
16146 ffesymbol_error (s, t);
16148 s = ffeexpr_sym_lhs_parameter_ (s, t);
16151 case FFEEXPR_contextDATA:
16152 s = ffecom_sym_exec_transition (s);
16153 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16154 goto understood; /* :::::::::::::::::::: */
16155 if (ffeexpr_stack_->is_rhs)
16156 ffesymbol_error (s, t);
16158 s = ffeexpr_sym_lhs_data_ (s, t);
16159 goto understood; /* :::::::::::::::::::: */
16161 case FFEEXPR_contextDATAIMPDOITEM_:
16162 s = ffecom_sym_exec_transition (s);
16163 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16164 goto understood; /* :::::::::::::::::::: */
16165 s = ffeexpr_sym_lhs_data_ (s, t);
16166 goto understood; /* :::::::::::::::::::: */
16168 case FFEEXPR_contextEQUIVALENCE:
16169 s = ffeexpr_sym_lhs_equivalence_ (s, t);
16172 case FFEEXPR_contextDIMLIST:
16173 s = ffeexpr_sym_rhs_dimlist_ (s, t);
16176 case FFEEXPR_contextCHARACTERSIZE:
16177 case FFEEXPR_contextKINDTYPE:
16178 case FFEEXPR_contextDIMLISTCOMMON:
16179 case FFEEXPR_contextINITVAL:
16180 case FFEEXPR_contextEQVINDEX_:
16181 ffesymbol_error (s, t);
16184 case FFEEXPR_contextINCLUDE:
16185 ffesymbol_error (s, t);
16188 case FFEEXPR_contextACTUALARG_: /* E.g. I in REAL A(Y(I)). */
16189 case FFEEXPR_contextSFUNCDEFACTUALARG_:
16190 s = ffecom_sym_exec_transition (s);
16191 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16192 goto understood; /* :::::::::::::::::::: */
16193 s = ffeexpr_sym_rhs_actualarg_ (s, t);
16194 goto understood; /* :::::::::::::::::::: */
16196 case FFEEXPR_contextINDEX_:
16197 case FFEEXPR_contextACTUALARGEXPR_:
16198 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
16199 case FFEEXPR_contextSFUNCDEF:
16200 case FFEEXPR_contextSFUNCDEFINDEX_:
16201 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
16202 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
16203 assert (ffeexpr_stack_->is_rhs);
16204 s = ffecom_sym_exec_transition (s);
16205 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
16206 goto understood; /* :::::::::::::::::::: */
16207 s = ffeexpr_sym_rhs_let_ (s, t);
16208 goto understood; /* :::::::::::::::::::: */
16211 ffesymbol_error (s, t);
16217 assert ("bad symbol state" == NULL);
16223 /* Have FOO in DATA (XYZ(FOO),...)/.../ or DATA (...,XYZ=FOO,BAR,BLETCH).
16224 Could be found via the "statement-function" name space (in which case
16225 it should become an iterator) or the local name space (in which case
16226 it should be either a named constant, or a variable that will have an
16227 sfunc name space sibling that should become an iterator). */
16230 ffeexpr_sym_impdoitem_ (ffesymbol sp, ffelexToken t)
16238 ffeinfoWhere where;
16240 ss = ffesymbol_state (sp);
16242 if (ffesymbol_sfdummyparent (sp) != NULL)
16243 { /* Have symbol in sfunc name space. */
16246 case FFESYMBOL_stateNONE: /* Used as iterator already. */
16247 if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
16248 ffesymbol_error (sp, t); /* Can't use dead iterator. */
16250 { /* Can use dead iterator because we're at at
16251 least an innermore (higher-numbered) level
16252 than the iterator's outermost
16253 (lowest-numbered) level. */
16254 ffesymbol_signal_change (sp);
16255 ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
16256 ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
16257 ffesymbol_signal_unreported (sp);
16261 case FFESYMBOL_stateSEEN: /* Seen already in this or other
16262 implied-DO. Set symbol level
16263 number to outermost value, as that
16264 tells us we can see it as iterator
16265 at that level at the innermost. */
16266 if (ffeexpr_level_ < ffesymbol_maxentrynum (sp))
16268 ffesymbol_signal_change (sp);
16269 ffesymbol_set_maxentrynum (sp, ffeexpr_level_);
16270 ffesymbol_signal_unreported (sp);
16274 case FFESYMBOL_stateUNCERTAIN: /* Iterator. */
16275 assert (ffeexpr_level_ == ffesymbol_maxentrynum (sp));
16276 ffesymbol_error (sp, t); /* (,,,I=I,10). */
16279 case FFESYMBOL_stateUNDERSTOOD:
16283 assert ("Foo Bar!!" == NULL);
16290 /* Got symbol in local name space, so we haven't seen it in impdo yet.
16291 First, if it is brand-new and we're in executable statements, set the
16292 attributes and exec-transition it to set state UNCERTAIN or UNDERSTOOD.
16293 Second, if it is now a constant (PARAMETER), then just return it, it
16294 can't be an implied-do iterator. If it is understood, complain if it is
16295 not a valid variable, but make the inner name space iterator anyway and
16296 return that. If it is not understood, improve understanding of the
16297 symbol accordingly, complain accordingly, in either case make the inner
16298 name space iterator and return that. */
16300 sa = ffesymbol_attrs (sp);
16302 if (ffesymbol_state_is_specable (ss)
16303 && ffest_seen_first_exec ())
16305 assert (sa == FFESYMBOL_attrsetNONE);
16306 ffesymbol_signal_change (sp);
16307 ffesymbol_set_state (sp, FFESYMBOL_stateSEEN);
16308 ffesymbol_resolve_intrin (sp);
16309 if (ffeimplic_establish_symbol (sp))
16310 ffesymbol_set_attr (sp, FFESYMBOL_attrSFARG);
16312 ffesymbol_error (sp, t);
16314 /* After the exec transition, the state will either be UNCERTAIN (could
16315 be a dummy or local var) or UNDERSTOOD (local var, because this is a
16316 PROGRAM/BLOCKDATA program unit). */
16318 sp = ffecom_sym_exec_transition (sp);
16319 sa = ffesymbol_attrs (sp);
16320 ss = ffesymbol_state (sp);
16324 kind = ffesymbol_kind (sp);
16325 where = ffesymbol_where (sp);
16327 if (ss == FFESYMBOL_stateUNDERSTOOD)
16329 if (kind != FFEINFO_kindENTITY)
16330 ffesymbol_error (sp, t);
16331 if (where == FFEINFO_whereCONSTANT)
16336 /* Enhance understanding of local symbol. This used to imply exec
16337 transition, but that doesn't seem necessary, since the local symbol
16338 doesn't actually get put into an ffebld tree here -- we just learn
16339 more about it, just like when we see a local symbol's name in the
16340 dummy-arg list of a statement function. */
16342 if (ss != FFESYMBOL_stateUNCERTAIN)
16344 /* Figure out what kind of object we've got based on previous
16345 declarations of or references to the object. */
16347 ns = FFESYMBOL_stateSEEN;
16349 if (sa & FFESYMBOL_attrsANY)
16351 else if (!(sa & ~(FFESYMBOL_attrsADJUSTS
16352 | FFESYMBOL_attrsANY
16353 | FFESYMBOL_attrsCOMMON
16354 | FFESYMBOL_attrsDUMMY
16355 | FFESYMBOL_attrsEQUIV
16356 | FFESYMBOL_attrsINIT
16357 | FFESYMBOL_attrsNAMELIST
16358 | FFESYMBOL_attrsRESULT
16359 | FFESYMBOL_attrsSAVE
16360 | FFESYMBOL_attrsSFARG
16361 | FFESYMBOL_attrsTYPE)))
16362 na = sa | FFESYMBOL_attrsSFARG;
16364 na = FFESYMBOL_attrsetNONE;
16367 { /* stateUNCERTAIN. */
16368 na = sa | FFESYMBOL_attrsSFARG;
16369 ns = FFESYMBOL_stateUNDERSTOOD;
16371 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16372 | FFESYMBOL_attrsADJUSTABLE
16373 | FFESYMBOL_attrsANYLEN
16374 | FFESYMBOL_attrsARRAY
16375 | FFESYMBOL_attrsDUMMY
16376 | FFESYMBOL_attrsEXTERNAL
16377 | FFESYMBOL_attrsSFARG
16378 | FFESYMBOL_attrsTYPE)));
16380 if (sa & FFESYMBOL_attrsEXTERNAL)
16382 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16383 | FFESYMBOL_attrsDUMMY
16384 | FFESYMBOL_attrsEXTERNAL
16385 | FFESYMBOL_attrsTYPE)));
16387 na = FFESYMBOL_attrsetNONE;
16389 else if (sa & FFESYMBOL_attrsDUMMY)
16391 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16392 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16393 | FFESYMBOL_attrsEXTERNAL
16394 | FFESYMBOL_attrsTYPE)));
16396 kind = FFEINFO_kindENTITY;
16398 else if (sa & FFESYMBOL_attrsARRAY)
16400 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16401 | FFESYMBOL_attrsADJUSTABLE
16402 | FFESYMBOL_attrsTYPE)));
16404 na = FFESYMBOL_attrsetNONE;
16406 else if (sa & FFESYMBOL_attrsSFARG)
16408 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16409 | FFESYMBOL_attrsTYPE)));
16411 ns = FFESYMBOL_stateUNCERTAIN;
16413 else if (sa & FFESYMBOL_attrsTYPE)
16415 assert (!(sa & (FFESYMBOL_attrsARRAY
16416 | FFESYMBOL_attrsDUMMY
16417 | FFESYMBOL_attrsEXTERNAL
16418 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16419 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16420 | FFESYMBOL_attrsADJUSTABLE
16421 | FFESYMBOL_attrsANYLEN
16422 | FFESYMBOL_attrsARRAY
16423 | FFESYMBOL_attrsDUMMY
16424 | FFESYMBOL_attrsEXTERNAL
16425 | FFESYMBOL_attrsSFARG)));
16427 kind = FFEINFO_kindENTITY;
16429 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16430 na = FFESYMBOL_attrsetNONE;
16431 else if (ffest_is_entry_valid ())
16432 ns = FFESYMBOL_stateUNCERTAIN; /* Could be DUMMY or LOCAL. */
16434 where = FFEINFO_whereLOCAL;
16437 na = FFESYMBOL_attrsetNONE; /* Error. */
16440 /* Now see what we've got for a new object: NONE means a new error
16441 cropped up; ANY means an old error to be ignored; otherwise,
16442 everything's ok, update the object (symbol) and continue on. */
16444 if (na == FFESYMBOL_attrsetNONE)
16445 ffesymbol_error (sp, t);
16446 else if (!(na & FFESYMBOL_attrsANY))
16448 ffesymbol_signal_change (sp); /* May need to back up to previous
16450 if (!ffeimplic_establish_symbol (sp))
16451 ffesymbol_error (sp, t);
16454 ffesymbol_set_info (sp,
16455 ffeinfo_new (ffesymbol_basictype (sp),
16456 ffesymbol_kindtype (sp),
16457 ffesymbol_rank (sp),
16460 ffesymbol_size (sp)));
16461 ffesymbol_set_attrs (sp, na);
16462 ffesymbol_set_state (sp, ns);
16463 ffesymbol_resolve_intrin (sp);
16464 if (!ffesymbol_state_is_specable (ns))
16465 sp = ffecom_sym_learned (sp);
16466 ffesymbol_signal_unreported (sp); /* For debugging purposes. */
16471 /* Here we create the sfunc-name-space symbol representing what should
16472 become an iterator in this name space at this or an outermore (lower-
16473 numbered) expression level, else the implied-DO construct is in error. */
16475 s = ffesymbol_declare_sfdummy (t); /* Sets maxentrynum to 0 for new obj;
16476 also sets sfa_dummy_parent to
16478 assert (sp == ffesymbol_sfdummyparent (s));
16480 ffesymbol_signal_change (s);
16481 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
16482 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
16483 ffesymbol_set_info (s,
16484 ffeinfo_new (FFEINFO_basictypeINTEGER,
16485 FFEINFO_kindtypeINTEGERDEFAULT,
16487 FFEINFO_kindENTITY,
16488 FFEINFO_whereIMMEDIATE,
16489 FFETARGET_charactersizeNONE));
16490 ffesymbol_signal_unreported (s);
16492 if (((ffesymbol_basictype (sp) != FFEINFO_basictypeINTEGER)
16493 && (ffesymbol_basictype (sp) != FFEINFO_basictypeANY))
16494 || ((ffesymbol_kindtype (sp) != FFEINFO_kindtypeINTEGERDEFAULT)
16495 && (ffesymbol_kindtype (sp) != FFEINFO_kindtypeANY)))
16496 ffesymbol_error (s, t);
16501 /* Have FOO in CALL FOO. Local name space, executable context only. */
16504 ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t)
16509 ffeinfoWhere where;
16511 ffeintrinSpec spec;
16513 bool error = FALSE;
16515 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16516 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16518 na = sa = ffesymbol_attrs (s);
16520 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16521 | FFESYMBOL_attrsADJUSTABLE
16522 | FFESYMBOL_attrsANYLEN
16523 | FFESYMBOL_attrsARRAY
16524 | FFESYMBOL_attrsDUMMY
16525 | FFESYMBOL_attrsEXTERNAL
16526 | FFESYMBOL_attrsSFARG
16527 | FFESYMBOL_attrsTYPE)));
16529 kind = ffesymbol_kind (s);
16530 where = ffesymbol_where (s);
16532 /* Figure out what kind of object we've got based on previous declarations
16533 of or references to the object. */
16535 if (sa & FFESYMBOL_attrsEXTERNAL)
16537 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16538 | FFESYMBOL_attrsDUMMY
16539 | FFESYMBOL_attrsEXTERNAL
16540 | FFESYMBOL_attrsTYPE)));
16542 if (sa & FFESYMBOL_attrsTYPE)
16547 kind = FFEINFO_kindSUBROUTINE;
16549 if (sa & FFESYMBOL_attrsDUMMY)
16551 else if (sa & FFESYMBOL_attrsACTUALARG)
16552 ; /* Not DUMMY or TYPE. */
16553 else /* Not ACTUALARG, DUMMY, or TYPE. */
16554 where = FFEINFO_whereGLOBAL;
16557 else if (sa & FFESYMBOL_attrsDUMMY)
16559 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16560 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16561 | FFESYMBOL_attrsEXTERNAL
16562 | FFESYMBOL_attrsTYPE)));
16564 if (sa & FFESYMBOL_attrsTYPE)
16567 kind = FFEINFO_kindSUBROUTINE;
16569 else if (sa & FFESYMBOL_attrsARRAY)
16571 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16572 | FFESYMBOL_attrsADJUSTABLE
16573 | FFESYMBOL_attrsTYPE)));
16577 else if (sa & FFESYMBOL_attrsSFARG)
16579 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16580 | FFESYMBOL_attrsTYPE)));
16584 else if (sa & FFESYMBOL_attrsTYPE)
16586 assert (!(sa & (FFESYMBOL_attrsARRAY
16587 | FFESYMBOL_attrsDUMMY
16588 | FFESYMBOL_attrsEXTERNAL
16589 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16590 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16591 | FFESYMBOL_attrsADJUSTABLE
16592 | FFESYMBOL_attrsANYLEN
16593 | FFESYMBOL_attrsARRAY
16594 | FFESYMBOL_attrsDUMMY
16595 | FFESYMBOL_attrsEXTERNAL
16596 | FFESYMBOL_attrsSFARG)));
16600 else if (sa == FFESYMBOL_attrsetNONE)
16602 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16604 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
16605 &gen, &spec, &imp))
16607 ffesymbol_signal_change (s); /* May need to back up to previous
16609 ffesymbol_set_generic (s, gen);
16610 ffesymbol_set_specific (s, spec);
16611 ffesymbol_set_implementation (s, imp);
16612 ffesymbol_set_info (s,
16613 ffeinfo_new (FFEINFO_basictypeNONE,
16614 FFEINFO_kindtypeNONE,
16616 FFEINFO_kindSUBROUTINE,
16617 FFEINFO_whereINTRINSIC,
16618 FFETARGET_charactersizeNONE));
16619 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16620 ffesymbol_resolve_intrin (s);
16621 ffesymbol_reference (s, t, FALSE);
16622 s = ffecom_sym_learned (s);
16623 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16628 kind = FFEINFO_kindSUBROUTINE;
16629 where = FFEINFO_whereGLOBAL;
16634 /* Now see what we've got for a new object: NONE means a new error cropped
16635 up; ANY means an old error to be ignored; otherwise, everything's ok,
16636 update the object (symbol) and continue on. */
16639 ffesymbol_error (s, t);
16640 else if (!(na & FFESYMBOL_attrsANY))
16642 ffesymbol_signal_change (s); /* May need to back up to previous
16644 ffesymbol_set_info (s,
16645 ffeinfo_new (ffesymbol_basictype (s),
16646 ffesymbol_kindtype (s),
16647 ffesymbol_rank (s),
16648 kind, /* SUBROUTINE. */
16649 where, /* GLOBAL or DUMMY. */
16650 ffesymbol_size (s)));
16651 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16652 ffesymbol_resolve_intrin (s);
16653 ffesymbol_reference (s, t, FALSE);
16654 s = ffecom_sym_learned (s);
16655 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16661 /* Have FOO in DATA FOO/.../. Local name space and executable context
16662 only. (This will change in the future when DATA FOO may be followed
16663 by COMMON FOO or even INTEGER FOO(10), etc.) */
16666 ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t)
16671 ffeinfoWhere where;
16672 bool error = FALSE;
16674 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16675 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16677 na = sa = ffesymbol_attrs (s);
16679 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16680 | FFESYMBOL_attrsADJUSTABLE
16681 | FFESYMBOL_attrsANYLEN
16682 | FFESYMBOL_attrsARRAY
16683 | FFESYMBOL_attrsDUMMY
16684 | FFESYMBOL_attrsEXTERNAL
16685 | FFESYMBOL_attrsSFARG
16686 | FFESYMBOL_attrsTYPE)));
16688 kind = ffesymbol_kind (s);
16689 where = ffesymbol_where (s);
16691 /* Figure out what kind of object we've got based on previous declarations
16692 of or references to the object. */
16694 if (sa & FFESYMBOL_attrsEXTERNAL)
16696 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16697 | FFESYMBOL_attrsDUMMY
16698 | FFESYMBOL_attrsEXTERNAL
16699 | FFESYMBOL_attrsTYPE)));
16703 else if (sa & FFESYMBOL_attrsDUMMY)
16705 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16706 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16707 | FFESYMBOL_attrsEXTERNAL
16708 | FFESYMBOL_attrsTYPE)));
16712 else if (sa & FFESYMBOL_attrsARRAY)
16714 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16715 | FFESYMBOL_attrsADJUSTABLE
16716 | FFESYMBOL_attrsTYPE)));
16718 if (sa & FFESYMBOL_attrsADJUSTABLE)
16720 where = FFEINFO_whereLOCAL;
16722 else if (sa & FFESYMBOL_attrsSFARG)
16724 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16725 | FFESYMBOL_attrsTYPE)));
16727 where = FFEINFO_whereLOCAL;
16729 else if (sa & FFESYMBOL_attrsTYPE)
16731 assert (!(sa & (FFESYMBOL_attrsARRAY
16732 | FFESYMBOL_attrsDUMMY
16733 | FFESYMBOL_attrsEXTERNAL
16734 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16735 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16736 | FFESYMBOL_attrsADJUSTABLE
16737 | FFESYMBOL_attrsANYLEN
16738 | FFESYMBOL_attrsARRAY
16739 | FFESYMBOL_attrsDUMMY
16740 | FFESYMBOL_attrsEXTERNAL
16741 | FFESYMBOL_attrsSFARG)));
16743 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16747 kind = FFEINFO_kindENTITY;
16748 where = FFEINFO_whereLOCAL;
16751 else if (sa == FFESYMBOL_attrsetNONE)
16753 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16754 kind = FFEINFO_kindENTITY;
16755 where = FFEINFO_whereLOCAL;
16760 /* Now see what we've got for a new object: NONE means a new error cropped
16761 up; ANY means an old error to be ignored; otherwise, everything's ok,
16762 update the object (symbol) and continue on. */
16765 ffesymbol_error (s, t);
16766 else if (!(na & FFESYMBOL_attrsANY))
16768 ffesymbol_signal_change (s); /* May need to back up to previous
16770 if (!ffeimplic_establish_symbol (s))
16772 ffesymbol_error (s, t);
16775 ffesymbol_set_info (s,
16776 ffeinfo_new (ffesymbol_basictype (s),
16777 ffesymbol_kindtype (s),
16778 ffesymbol_rank (s),
16779 kind, /* ENTITY. */
16780 where, /* LOCAL. */
16781 ffesymbol_size (s)));
16782 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
16783 ffesymbol_resolve_intrin (s);
16784 s = ffecom_sym_learned (s);
16785 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16791 /* Have FOO in EQUIVALENCE (...,FOO,...). Does not include
16792 EQUIVALENCE (...,BAR(FOO),...). */
16795 ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t)
16800 ffeinfoWhere where;
16802 na = sa = ffesymbol_attrs (s);
16803 kind = FFEINFO_kindENTITY;
16804 where = ffesymbol_where (s);
16806 /* Figure out what kind of object we've got based on previous declarations
16807 of or references to the object. */
16809 if (!(sa & ~(FFESYMBOL_attrsADJUSTS
16810 | FFESYMBOL_attrsARRAY
16811 | FFESYMBOL_attrsCOMMON
16812 | FFESYMBOL_attrsEQUIV
16813 | FFESYMBOL_attrsINIT
16814 | FFESYMBOL_attrsNAMELIST
16815 | FFESYMBOL_attrsSAVE
16816 | FFESYMBOL_attrsSFARG
16817 | FFESYMBOL_attrsTYPE)))
16818 na = sa | FFESYMBOL_attrsEQUIV;
16820 na = FFESYMBOL_attrsetNONE;
16822 /* Don't know why we're bothering to set kind and where in this code, but
16823 added the following to make it complete, in case it's really important.
16824 Generally this is left up to symbol exec transition. */
16826 if (where == FFEINFO_whereNONE)
16828 if (na & (FFESYMBOL_attrsADJUSTS
16829 | FFESYMBOL_attrsCOMMON))
16830 where = FFEINFO_whereCOMMON;
16831 else if (na & FFESYMBOL_attrsSAVE)
16832 where = FFEINFO_whereLOCAL;
16835 /* Now see what we've got for a new object: NONE means a new error cropped
16836 up; ANY means an old error to be ignored; otherwise, everything's ok,
16837 update the object (symbol) and continue on. */
16839 if (na == FFESYMBOL_attrsetNONE)
16840 ffesymbol_error (s, t);
16841 else if (!(na & FFESYMBOL_attrsANY))
16843 ffesymbol_signal_change (s); /* May need to back up to previous
16845 ffesymbol_set_info (s,
16846 ffeinfo_new (ffesymbol_basictype (s),
16847 ffesymbol_kindtype (s),
16848 ffesymbol_rank (s),
16849 kind, /* Always ENTITY. */
16850 where, /* NONE, COMMON, or LOCAL. */
16851 ffesymbol_size (s)));
16852 ffesymbol_set_attrs (s, na);
16853 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
16854 ffesymbol_resolve_intrin (s);
16855 ffesymbol_signal_unreported (s); /* For debugging purposes. */
16861 /* Have FOO in OPEN(...,USEROPEN=FOO,...). Executable context only.
16863 Note that I think this should be considered semantically similar to
16864 doing CALL XYZ(FOO), in that it should be considered like an
16865 ACTUALARG context. In particular, without EXTERNAL being specified,
16866 it should not be allowed. */
16869 ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t)
16874 ffeinfoWhere where;
16875 bool needs_type = FALSE;
16876 bool error = FALSE;
16878 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
16879 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
16881 na = sa = ffesymbol_attrs (s);
16883 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16884 | FFESYMBOL_attrsADJUSTABLE
16885 | FFESYMBOL_attrsANYLEN
16886 | FFESYMBOL_attrsARRAY
16887 | FFESYMBOL_attrsDUMMY
16888 | FFESYMBOL_attrsEXTERNAL
16889 | FFESYMBOL_attrsSFARG
16890 | FFESYMBOL_attrsTYPE)));
16892 kind = ffesymbol_kind (s);
16893 where = ffesymbol_where (s);
16895 /* Figure out what kind of object we've got based on previous declarations
16896 of or references to the object. */
16898 if (sa & FFESYMBOL_attrsEXTERNAL)
16900 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
16901 | FFESYMBOL_attrsDUMMY
16902 | FFESYMBOL_attrsEXTERNAL
16903 | FFESYMBOL_attrsTYPE)));
16905 if (sa & FFESYMBOL_attrsTYPE)
16906 where = FFEINFO_whereGLOBAL;
16910 kind = FFEINFO_kindFUNCTION;
16913 if (sa & FFESYMBOL_attrsDUMMY)
16915 else if (sa & FFESYMBOL_attrsACTUALARG)
16916 ; /* Not DUMMY or TYPE. */
16917 else /* Not ACTUALARG, DUMMY, or TYPE. */
16918 where = FFEINFO_whereGLOBAL;
16921 else if (sa & FFESYMBOL_attrsDUMMY)
16923 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
16924 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
16925 | FFESYMBOL_attrsEXTERNAL
16926 | FFESYMBOL_attrsTYPE)));
16928 kind = FFEINFO_kindFUNCTION;
16929 if (!(sa & FFESYMBOL_attrsTYPE))
16932 else if (sa & FFESYMBOL_attrsARRAY)
16934 assert (!(sa & ~(FFESYMBOL_attrsARRAY
16935 | FFESYMBOL_attrsADJUSTABLE
16936 | FFESYMBOL_attrsTYPE)));
16940 else if (sa & FFESYMBOL_attrsSFARG)
16942 assert (!(sa & ~(FFESYMBOL_attrsSFARG
16943 | FFESYMBOL_attrsTYPE)));
16947 else if (sa & FFESYMBOL_attrsTYPE)
16949 assert (!(sa & (FFESYMBOL_attrsARRAY
16950 | FFESYMBOL_attrsDUMMY
16951 | FFESYMBOL_attrsEXTERNAL
16952 | FFESYMBOL_attrsSFARG))); /* Handled above. */
16953 assert (!(sa & ~(FFESYMBOL_attrsTYPE
16954 | FFESYMBOL_attrsADJUSTABLE
16955 | FFESYMBOL_attrsANYLEN
16956 | FFESYMBOL_attrsARRAY
16957 | FFESYMBOL_attrsDUMMY
16958 | FFESYMBOL_attrsEXTERNAL
16959 | FFESYMBOL_attrsSFARG)));
16961 if (sa & (FFESYMBOL_attrsADJUSTABLE | FFESYMBOL_attrsANYLEN))
16965 kind = FFEINFO_kindFUNCTION;
16966 where = FFEINFO_whereGLOBAL;
16969 else if (sa == FFESYMBOL_attrsetNONE)
16971 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
16972 kind = FFEINFO_kindFUNCTION;
16973 where = FFEINFO_whereGLOBAL;
16979 /* Now see what we've got for a new object: NONE means a new error cropped
16980 up; ANY means an old error to be ignored; otherwise, everything's ok,
16981 update the object (symbol) and continue on. */
16984 ffesymbol_error (s, t);
16985 else if (!(na & FFESYMBOL_attrsANY))
16987 ffesymbol_signal_change (s); /* May need to back up to previous
16989 if (needs_type && !ffeimplic_establish_symbol (s))
16991 ffesymbol_error (s, t);
16994 if (!ffesymbol_explicitwhere (s))
16996 ffebad_start (FFEBAD_NEED_EXTERNAL);
16997 ffebad_here (0, ffelex_token_where_line (t),
16998 ffelex_token_where_column (t));
16999 ffebad_string (ffesymbol_text (s));
17001 ffesymbol_set_explicitwhere (s, TRUE);
17003 ffesymbol_set_info (s,
17004 ffeinfo_new (ffesymbol_basictype (s),
17005 ffesymbol_kindtype (s),
17006 ffesymbol_rank (s),
17007 kind, /* FUNCTION. */
17008 where, /* GLOBAL or DUMMY. */
17009 ffesymbol_size (s)));
17010 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17011 ffesymbol_resolve_intrin (s);
17012 ffesymbol_reference (s, t, FALSE);
17013 s = ffecom_sym_learned (s);
17014 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17020 /* Have FOO in DATA (stuff,FOO=1,10)/.../. */
17023 ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t)
17027 /* If the symbol isn't in the sfunc name space, pretend as though we saw a
17028 reference to it already within the imp-DO construct at this level, so as
17029 to get a symbol that is in the sfunc name space. But this is an
17030 erroneous construct, and should be caught elsewhere. */
17032 if (ffesymbol_sfdummyparent (s) == NULL)
17034 s = ffeexpr_sym_impdoitem_ (s, t);
17035 if (ffesymbol_sfdummyparent (s) == NULL)
17036 { /* PARAMETER FOO...DATA (A(I),FOO=...). */
17037 ffesymbol_error (s, t);
17042 ss = ffesymbol_state (s);
17046 case FFESYMBOL_stateNONE: /* Used as iterator already. */
17047 if (ffeexpr_level_ < ffesymbol_maxentrynum (s))
17048 ffesymbol_error (s, t); /* Can't reuse dead iterator. F90 disallows
17049 this; F77 allows it but it is a stupid
17052 { /* Can use dead iterator because we're at at
17053 least a innermore (higher-numbered) level
17054 than the iterator's outermost
17055 (lowest-numbered) level. This should be
17056 diagnosed later, because it means an item
17057 in this list didn't reference this
17060 ffesymbol_error (s, t); /* For now, complain. */
17061 #else /* Someday will detect all cases where initializer doesn't reference
17062 all applicable iterators, in which case reenable this code. */
17063 ffesymbol_signal_change (s);
17064 ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
17065 ffesymbol_set_maxentrynum (s, ffeexpr_level_);
17066 ffesymbol_signal_unreported (s);
17071 case FFESYMBOL_stateSEEN: /* Seen already in this or other implied-DO.
17072 If seen in outermore level, can't be an
17073 iterator here, so complain. If not seen
17074 at current level, complain for now,
17075 because that indicates something F90
17076 rejects (though we currently don't detect
17077 all such cases for now). */
17078 if (ffeexpr_level_ <= ffesymbol_maxentrynum (s))
17080 ffesymbol_signal_change (s);
17081 ffesymbol_set_state (s, FFESYMBOL_stateUNCERTAIN);
17082 ffesymbol_signal_unreported (s);
17085 ffesymbol_error (s, t);
17088 case FFESYMBOL_stateUNCERTAIN: /* Already iterator! */
17089 assert ("DATA implied-DO control var seen twice!!" == NULL);
17090 ffesymbol_error (s, t);
17093 case FFESYMBOL_stateUNDERSTOOD:
17097 assert ("Foo Bletch!!" == NULL);
17104 /* Have FOO in PARAMETER (FOO=...). */
17107 ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t)
17111 sa = ffesymbol_attrs (s);
17113 /* Figure out what kind of object we've got based on previous declarations
17114 of or references to the object. */
17116 if (sa & ~(FFESYMBOL_attrsANYLEN
17117 | FFESYMBOL_attrsTYPE))
17119 if (!(sa & FFESYMBOL_attrsANY))
17120 ffesymbol_error (s, t);
17124 ffesymbol_signal_change (s); /* May need to back up to previous
17126 if (!ffeimplic_establish_symbol (s))
17128 ffesymbol_error (s, t);
17131 ffesymbol_set_info (s,
17132 ffeinfo_new (ffesymbol_basictype (s),
17133 ffesymbol_kindtype (s),
17134 ffesymbol_rank (s),
17135 FFEINFO_kindENTITY,
17136 FFEINFO_whereCONSTANT,
17137 ffesymbol_size (s)));
17138 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17139 ffesymbol_resolve_intrin (s);
17140 s = ffecom_sym_learned (s);
17141 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17147 /* Have FOO in CALL XYZ(...,FOO,...). Does not include any other
17148 embedding of FOO, such as CALL XYZ((FOO)) or CALL XYZ(FOO+1). */
17151 ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t)
17156 ffeinfoWhere where;
17158 bool needs_type = FALSE;
17160 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
17161 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
17163 na = sa = ffesymbol_attrs (s);
17165 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17166 | FFESYMBOL_attrsADJUSTABLE
17167 | FFESYMBOL_attrsANYLEN
17168 | FFESYMBOL_attrsARRAY
17169 | FFESYMBOL_attrsDUMMY
17170 | FFESYMBOL_attrsEXTERNAL
17171 | FFESYMBOL_attrsSFARG
17172 | FFESYMBOL_attrsTYPE)));
17174 kind = ffesymbol_kind (s);
17175 where = ffesymbol_where (s);
17177 /* Figure out what kind of object we've got based on previous declarations
17178 of or references to the object. */
17180 ns = FFESYMBOL_stateUNDERSTOOD;
17182 if (sa & FFESYMBOL_attrsEXTERNAL)
17184 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17185 | FFESYMBOL_attrsDUMMY
17186 | FFESYMBOL_attrsEXTERNAL
17187 | FFESYMBOL_attrsTYPE)));
17189 if (sa & FFESYMBOL_attrsTYPE)
17190 where = FFEINFO_whereGLOBAL;
17194 ns = FFESYMBOL_stateUNCERTAIN;
17196 if (sa & FFESYMBOL_attrsDUMMY)
17197 assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */
17198 else if (sa & FFESYMBOL_attrsACTUALARG)
17199 ; /* Not DUMMY or TYPE. */
17201 /* Not ACTUALARG, DUMMY, or TYPE. */
17203 assert (kind == FFEINFO_kindNONE); /* FUNCTION, SUBROUTINE. */
17204 na |= FFESYMBOL_attrsACTUALARG;
17205 where = FFEINFO_whereGLOBAL;
17209 else if (sa & FFESYMBOL_attrsDUMMY)
17211 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
17212 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
17213 | FFESYMBOL_attrsEXTERNAL
17214 | FFESYMBOL_attrsTYPE)));
17216 kind = FFEINFO_kindENTITY;
17217 if (!(sa & FFESYMBOL_attrsTYPE))
17220 else if (sa & FFESYMBOL_attrsARRAY)
17222 assert (!(sa & ~(FFESYMBOL_attrsARRAY
17223 | FFESYMBOL_attrsADJUSTABLE
17224 | FFESYMBOL_attrsTYPE)));
17226 where = FFEINFO_whereLOCAL;
17228 else if (sa & FFESYMBOL_attrsSFARG)
17230 assert (!(sa & ~(FFESYMBOL_attrsSFARG
17231 | FFESYMBOL_attrsTYPE)));
17233 where = FFEINFO_whereLOCAL;
17235 else if (sa & FFESYMBOL_attrsTYPE)
17237 assert (!(sa & (FFESYMBOL_attrsARRAY
17238 | FFESYMBOL_attrsDUMMY
17239 | FFESYMBOL_attrsEXTERNAL
17240 | FFESYMBOL_attrsSFARG))); /* Handled above. */
17241 assert (!(sa & ~(FFESYMBOL_attrsTYPE
17242 | FFESYMBOL_attrsADJUSTABLE
17243 | FFESYMBOL_attrsANYLEN
17244 | FFESYMBOL_attrsARRAY
17245 | FFESYMBOL_attrsDUMMY
17246 | FFESYMBOL_attrsEXTERNAL
17247 | FFESYMBOL_attrsSFARG)));
17249 if (sa & FFESYMBOL_attrsANYLEN)
17250 ns = FFESYMBOL_stateNONE;
17253 kind = FFEINFO_kindENTITY;
17254 where = FFEINFO_whereLOCAL;
17257 else if (sa == FFESYMBOL_attrsetNONE)
17259 /* New state is left empty because there isn't any state flag to
17260 set for this case, and it's UNDERSTOOD after all. */
17261 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
17262 kind = FFEINFO_kindENTITY;
17263 where = FFEINFO_whereLOCAL;
17267 ns = FFESYMBOL_stateNONE; /* Error. */
17269 /* Now see what we've got for a new object: NONE means a new error cropped
17270 up; ANY means an old error to be ignored; otherwise, everything's ok,
17271 update the object (symbol) and continue on. */
17273 if (ns == FFESYMBOL_stateNONE)
17274 ffesymbol_error (s, t);
17275 else if (!(na & FFESYMBOL_attrsANY))
17277 ffesymbol_signal_change (s); /* May need to back up to previous
17279 if (needs_type && !ffeimplic_establish_symbol (s))
17281 ffesymbol_error (s, t);
17284 ffesymbol_set_info (s,
17285 ffeinfo_new (ffesymbol_basictype (s),
17286 ffesymbol_kindtype (s),
17287 ffesymbol_rank (s),
17290 ffesymbol_size (s)));
17291 ffesymbol_set_attrs (s, na);
17292 ffesymbol_set_state (s, ns);
17293 s = ffecom_sym_learned (s);
17294 ffesymbol_reference (s, t, FALSE);
17295 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17301 /* Have FOO in DIMENSION XYZ(FOO) or any array declarator containing
17302 a reference to FOO. */
17305 ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t)
17310 ffeinfoWhere where;
17312 na = sa = ffesymbol_attrs (s);
17313 kind = FFEINFO_kindENTITY;
17314 where = ffesymbol_where (s);
17316 /* Figure out what kind of object we've got based on previous declarations
17317 of or references to the object. */
17319 if (!(sa & ~(FFESYMBOL_attrsADJUSTS
17320 | FFESYMBOL_attrsCOMMON
17321 | FFESYMBOL_attrsDUMMY
17322 | FFESYMBOL_attrsEQUIV
17323 | FFESYMBOL_attrsINIT
17324 | FFESYMBOL_attrsNAMELIST
17325 | FFESYMBOL_attrsSFARG
17326 | FFESYMBOL_attrsARRAY
17327 | FFESYMBOL_attrsTYPE)))
17328 na = sa | FFESYMBOL_attrsADJUSTS;
17330 na = FFESYMBOL_attrsetNONE;
17332 /* Since this symbol definitely is going into an expression (the
17333 dimension-list for some dummy array, presumably), figure out WHERE if
17336 if (where == FFEINFO_whereNONE)
17338 if (na & (FFESYMBOL_attrsCOMMON
17339 | FFESYMBOL_attrsEQUIV
17340 | FFESYMBOL_attrsINIT
17341 | FFESYMBOL_attrsNAMELIST))
17342 where = FFEINFO_whereCOMMON;
17343 else if (na & FFESYMBOL_attrsDUMMY)
17344 where = FFEINFO_whereDUMMY;
17347 /* Now see what we've got for a new object: NONE means a new error cropped
17348 up; ANY means an old error to be ignored; otherwise, everything's ok,
17349 update the object (symbol) and continue on. */
17351 if (na == FFESYMBOL_attrsetNONE)
17352 ffesymbol_error (s, t);
17353 else if (!(na & FFESYMBOL_attrsANY))
17355 ffesymbol_signal_change (s); /* May need to back up to previous
17357 if (!ffeimplic_establish_symbol (s))
17359 ffesymbol_error (s, t);
17362 ffesymbol_set_info (s,
17363 ffeinfo_new (ffesymbol_basictype (s),
17364 ffesymbol_kindtype (s),
17365 ffesymbol_rank (s),
17366 kind, /* Always ENTITY. */
17367 where, /* NONE, COMMON, or DUMMY. */
17368 ffesymbol_size (s)));
17369 ffesymbol_set_attrs (s, na);
17370 ffesymbol_set_state (s, FFESYMBOL_stateSEEN);
17371 ffesymbol_resolve_intrin (s);
17372 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17378 /* Have FOO in XYZ = ...FOO.... Does not include cases like FOO in
17379 XYZ = BAR(FOO), as such cases are handled elsewhere. */
17382 ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t)
17387 ffeinfoWhere where;
17388 bool error = FALSE;
17390 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
17391 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
17393 na = sa = ffesymbol_attrs (s);
17395 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17396 | FFESYMBOL_attrsADJUSTABLE
17397 | FFESYMBOL_attrsANYLEN
17398 | FFESYMBOL_attrsARRAY
17399 | FFESYMBOL_attrsDUMMY
17400 | FFESYMBOL_attrsEXTERNAL
17401 | FFESYMBOL_attrsSFARG
17402 | FFESYMBOL_attrsTYPE)));
17404 kind = ffesymbol_kind (s);
17405 where = ffesymbol_where (s);
17407 /* Figure out what kind of object we've got based on previous declarations
17408 of or references to the object. */
17410 if (sa & FFESYMBOL_attrsEXTERNAL)
17412 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
17413 | FFESYMBOL_attrsDUMMY
17414 | FFESYMBOL_attrsEXTERNAL
17415 | FFESYMBOL_attrsTYPE)));
17419 else if (sa & FFESYMBOL_attrsDUMMY)
17421 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
17422 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
17423 | FFESYMBOL_attrsEXTERNAL
17424 | FFESYMBOL_attrsTYPE)));
17426 kind = FFEINFO_kindENTITY;
17428 else if (sa & FFESYMBOL_attrsARRAY)
17430 assert (!(sa & ~(FFESYMBOL_attrsARRAY
17431 | FFESYMBOL_attrsADJUSTABLE
17432 | FFESYMBOL_attrsTYPE)));
17434 where = FFEINFO_whereLOCAL;
17436 else if (sa & FFESYMBOL_attrsSFARG)
17438 assert (!(sa & ~(FFESYMBOL_attrsSFARG
17439 | FFESYMBOL_attrsTYPE)));
17441 where = FFEINFO_whereLOCAL;
17443 else if (sa & FFESYMBOL_attrsTYPE)
17445 assert (!(sa & (FFESYMBOL_attrsARRAY
17446 | FFESYMBOL_attrsDUMMY
17447 | FFESYMBOL_attrsEXTERNAL
17448 | FFESYMBOL_attrsSFARG))); /* Handled above. */
17449 assert (!(sa & ~(FFESYMBOL_attrsTYPE
17450 | FFESYMBOL_attrsADJUSTABLE
17451 | FFESYMBOL_attrsANYLEN
17452 | FFESYMBOL_attrsARRAY
17453 | FFESYMBOL_attrsDUMMY
17454 | FFESYMBOL_attrsEXTERNAL
17455 | FFESYMBOL_attrsSFARG)));
17457 if (sa & FFESYMBOL_attrsANYLEN)
17461 kind = FFEINFO_kindENTITY;
17462 where = FFEINFO_whereLOCAL;
17465 else if (sa == FFESYMBOL_attrsetNONE)
17467 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
17468 kind = FFEINFO_kindENTITY;
17469 where = FFEINFO_whereLOCAL;
17474 /* Now see what we've got for a new object: NONE means a new error cropped
17475 up; ANY means an old error to be ignored; otherwise, everything's ok,
17476 update the object (symbol) and continue on. */
17479 ffesymbol_error (s, t);
17480 else if (!(na & FFESYMBOL_attrsANY))
17482 ffesymbol_signal_change (s); /* May need to back up to previous
17484 if (!ffeimplic_establish_symbol (s))
17486 ffesymbol_error (s, t);
17489 ffesymbol_set_info (s,
17490 ffeinfo_new (ffesymbol_basictype (s),
17491 ffesymbol_kindtype (s),
17492 ffesymbol_rank (s),
17493 kind, /* ENTITY. */
17494 where, /* LOCAL. */
17495 ffesymbol_size (s)));
17496 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
17497 ffesymbol_resolve_intrin (s);
17498 s = ffecom_sym_learned (s);
17499 ffesymbol_signal_unreported (s); /* For debugging purposes. */
17505 /* ffeexpr_declare_parenthesized_ -- ffesymbol wrapper for NAME(...) operand
17509 ffeexprParenType_ paren_type;
17511 s = ffeexpr_declare_parenthesized_ (t, maybe_intrin, &paren_type);
17513 Just like ffesymbol_declare_local, except performs any implicit info
17514 assignment necessary, and it returns the type of the parenthesized list
17515 (list of function args, list of array args, or substring spec). */
17518 ffeexpr_declare_parenthesized_ (ffelexToken t, bool maybe_intrin,
17519 ffeexprParenType_ *paren_type)
17522 ffesymbolState st; /* Effective state. */
17526 if (maybe_intrin && ffesrc_check_symbol ())
17527 { /* Knock off some easy cases. */
17528 switch (ffeexpr_stack_->context)
17530 case FFEEXPR_contextSUBROUTINEREF:
17531 case FFEEXPR_contextDATA:
17532 case FFEEXPR_contextDATAIMPDOINDEX_:
17533 case FFEEXPR_contextSFUNCDEF:
17534 case FFEEXPR_contextSFUNCDEFINDEX_:
17535 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17536 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17537 case FFEEXPR_contextLET:
17538 case FFEEXPR_contextPAREN_:
17539 case FFEEXPR_contextACTUALARGEXPR_:
17540 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17541 case FFEEXPR_contextIOLIST:
17542 case FFEEXPR_contextIOLISTDF:
17543 case FFEEXPR_contextDO:
17544 case FFEEXPR_contextDOWHILE:
17545 case FFEEXPR_contextACTUALARG_:
17546 case FFEEXPR_contextCGOTO:
17547 case FFEEXPR_contextIF:
17548 case FFEEXPR_contextARITHIF:
17549 case FFEEXPR_contextFORMAT:
17550 case FFEEXPR_contextSTOP:
17551 case FFEEXPR_contextRETURN:
17552 case FFEEXPR_contextSELECTCASE:
17553 case FFEEXPR_contextCASE:
17554 case FFEEXPR_contextFILEASSOC:
17555 case FFEEXPR_contextFILEINT:
17556 case FFEEXPR_contextFILEDFINT:
17557 case FFEEXPR_contextFILELOG:
17558 case FFEEXPR_contextFILENUM:
17559 case FFEEXPR_contextFILENUMAMBIG:
17560 case FFEEXPR_contextFILECHAR:
17561 case FFEEXPR_contextFILENUMCHAR:
17562 case FFEEXPR_contextFILEDFCHAR:
17563 case FFEEXPR_contextFILEKEY:
17564 case FFEEXPR_contextFILEUNIT:
17565 case FFEEXPR_contextFILEUNIT_DF:
17566 case FFEEXPR_contextFILEUNITAMBIG:
17567 case FFEEXPR_contextFILEFORMAT:
17568 case FFEEXPR_contextFILENAMELIST:
17569 case FFEEXPR_contextFILEVXTCODE:
17570 case FFEEXPR_contextINDEX_:
17571 case FFEEXPR_contextIMPDOITEM_:
17572 case FFEEXPR_contextIMPDOITEMDF_:
17573 case FFEEXPR_contextIMPDOCTRL_:
17574 case FFEEXPR_contextDATAIMPDOCTRL_:
17575 case FFEEXPR_contextCHARACTERSIZE:
17576 case FFEEXPR_contextPARAMETER:
17577 case FFEEXPR_contextDIMLIST:
17578 case FFEEXPR_contextDIMLISTCOMMON:
17579 case FFEEXPR_contextKINDTYPE:
17580 case FFEEXPR_contextINITVAL:
17581 case FFEEXPR_contextEQVINDEX_:
17582 break; /* These could be intrinsic invocations. */
17584 case FFEEXPR_contextAGOTO:
17585 case FFEEXPR_contextFILEFORMATNML:
17586 case FFEEXPR_contextALLOCATE:
17587 case FFEEXPR_contextDEALLOCATE:
17588 case FFEEXPR_contextHEAPSTAT:
17589 case FFEEXPR_contextNULLIFY:
17590 case FFEEXPR_contextINCLUDE:
17591 case FFEEXPR_contextDATAIMPDOITEM_:
17592 case FFEEXPR_contextLOC_:
17593 case FFEEXPR_contextINDEXORACTUALARG_:
17594 case FFEEXPR_contextSFUNCDEFACTUALARG_:
17595 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
17596 case FFEEXPR_contextPARENFILENUM_:
17597 case FFEEXPR_contextPARENFILEUNIT_:
17598 maybe_intrin = FALSE;
17599 break; /* Can't be intrinsic invocation. */
17602 assert ("blah! blah! waaauuggh!" == NULL);
17607 s = ffesymbol_declare_local (t, maybe_intrin);
17609 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17610 /* Special-case these since they can involve a different concept
17611 of "state" (in the stmtfunc name space). */
17613 case FFEEXPR_contextDATAIMPDOINDEX_:
17614 case FFEEXPR_contextDATAIMPDOCTRL_:
17615 if (ffeexpr_context_outer_ (ffeexpr_stack_)
17616 == FFEEXPR_contextDATAIMPDOINDEX_)
17617 s = ffeexpr_sym_impdoitem_ (s, t);
17619 if (ffeexpr_stack_->is_rhs)
17620 s = ffeexpr_sym_impdoitem_ (s, t);
17622 s = ffeexpr_sym_lhs_impdoctrl_ (s, t);
17623 if (ffesymbol_kind (s) != FFEINFO_kindANY)
17624 ffesymbol_error (s, t);
17631 switch ((ffesymbol_sfdummyparent (s) == NULL)
17632 ? ffesymbol_state (s)
17633 : FFESYMBOL_stateUNDERSTOOD)
17635 case FFESYMBOL_stateNONE: /* Before first exec, not seen in expr
17637 if (!ffest_seen_first_exec ())
17638 goto seen; /* :::::::::::::::::::: */
17639 /* Fall through. */
17640 case FFESYMBOL_stateUNCERTAIN: /* Unseen since first exec. */
17641 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17643 case FFEEXPR_contextSUBROUTINEREF:
17644 s = ffeexpr_sym_lhs_call_ (s, t); /* "CALL FOO"=="CALL
17648 case FFEEXPR_contextDATA:
17649 if (ffeexpr_stack_->is_rhs)
17650 s = ffeexpr_sym_rhs_let_ (s, t);
17652 s = ffeexpr_sym_lhs_data_ (s, t);
17655 case FFEEXPR_contextDATAIMPDOITEM_:
17656 s = ffeexpr_sym_lhs_data_ (s, t);
17659 case FFEEXPR_contextSFUNCDEF:
17660 case FFEEXPR_contextSFUNCDEFINDEX_:
17661 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17662 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17663 s = ffecom_sym_exec_transition (s);
17664 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17665 goto understood; /* :::::::::::::::::::: */
17666 /* Fall through. */
17667 case FFEEXPR_contextLET:
17668 case FFEEXPR_contextPAREN_:
17669 case FFEEXPR_contextACTUALARGEXPR_:
17670 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17671 case FFEEXPR_contextIOLIST:
17672 case FFEEXPR_contextIOLISTDF:
17673 case FFEEXPR_contextDO:
17674 case FFEEXPR_contextDOWHILE:
17675 case FFEEXPR_contextACTUALARG_:
17676 case FFEEXPR_contextCGOTO:
17677 case FFEEXPR_contextIF:
17678 case FFEEXPR_contextARITHIF:
17679 case FFEEXPR_contextFORMAT:
17680 case FFEEXPR_contextSTOP:
17681 case FFEEXPR_contextRETURN:
17682 case FFEEXPR_contextSELECTCASE:
17683 case FFEEXPR_contextCASE:
17684 case FFEEXPR_contextFILEASSOC:
17685 case FFEEXPR_contextFILEINT:
17686 case FFEEXPR_contextFILEDFINT:
17687 case FFEEXPR_contextFILELOG:
17688 case FFEEXPR_contextFILENUM:
17689 case FFEEXPR_contextFILENUMAMBIG:
17690 case FFEEXPR_contextFILECHAR:
17691 case FFEEXPR_contextFILENUMCHAR:
17692 case FFEEXPR_contextFILEDFCHAR:
17693 case FFEEXPR_contextFILEKEY:
17694 case FFEEXPR_contextFILEUNIT:
17695 case FFEEXPR_contextFILEUNIT_DF:
17696 case FFEEXPR_contextFILEUNITAMBIG:
17697 case FFEEXPR_contextFILEFORMAT:
17698 case FFEEXPR_contextFILENAMELIST:
17699 case FFEEXPR_contextFILEVXTCODE:
17700 case FFEEXPR_contextINDEX_:
17701 case FFEEXPR_contextIMPDOITEM_:
17702 case FFEEXPR_contextIMPDOITEMDF_:
17703 case FFEEXPR_contextIMPDOCTRL_:
17704 case FFEEXPR_contextLOC_:
17705 if (ffeexpr_stack_->is_rhs)
17706 s = ffeexpr_paren_rhs_let_ (s, t);
17708 s = ffeexpr_paren_lhs_let_ (s, t);
17711 case FFEEXPR_contextASSIGN:
17712 case FFEEXPR_contextAGOTO:
17713 case FFEEXPR_contextCHARACTERSIZE:
17714 case FFEEXPR_contextEQUIVALENCE:
17715 case FFEEXPR_contextINCLUDE:
17716 case FFEEXPR_contextPARAMETER:
17717 case FFEEXPR_contextDIMLIST:
17718 case FFEEXPR_contextDIMLISTCOMMON:
17719 case FFEEXPR_contextKINDTYPE:
17720 case FFEEXPR_contextINITVAL:
17721 case FFEEXPR_contextEQVINDEX_:
17722 break; /* Will turn into errors below. */
17725 ffesymbol_error (s, t);
17728 /* Fall through. */
17729 case FFESYMBOL_stateUNDERSTOOD: /* Nothing much more to learn. */
17730 understood: /* :::::::::::::::::::: */
17732 /* State might have changed, update it. */
17733 st = ((ffesymbol_sfdummyparent (s) == NULL)
17734 ? ffesymbol_state (s)
17735 : FFESYMBOL_stateUNDERSTOOD);
17737 k = ffesymbol_kind (s);
17738 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17740 case FFEEXPR_contextSUBROUTINEREF:
17741 bad = ((k != FFEINFO_kindSUBROUTINE)
17742 && ((ffesymbol_where (s) != FFEINFO_whereINTRINSIC)
17743 || (k != FFEINFO_kindNONE)));
17746 case FFEEXPR_contextDATA:
17747 if (ffeexpr_stack_->is_rhs)
17748 bad = (k != FFEINFO_kindENTITY)
17749 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
17751 bad = (k != FFEINFO_kindENTITY)
17752 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
17753 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
17754 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
17757 case FFEEXPR_contextDATAIMPDOITEM_:
17758 bad = (k != FFEINFO_kindENTITY) || (ffesymbol_rank (s) == 0)
17759 || ((ffesymbol_where (s) != FFEINFO_whereNONE)
17760 && (ffesymbol_where (s) != FFEINFO_whereLOCAL)
17761 && (ffesymbol_where (s) != FFEINFO_whereCOMMON));
17764 case FFEEXPR_contextSFUNCDEF:
17765 case FFEEXPR_contextSFUNCDEFINDEX_:
17766 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17767 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17768 case FFEEXPR_contextLET:
17769 case FFEEXPR_contextPAREN_:
17770 case FFEEXPR_contextACTUALARGEXPR_:
17771 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17772 case FFEEXPR_contextIOLIST:
17773 case FFEEXPR_contextIOLISTDF:
17774 case FFEEXPR_contextDO:
17775 case FFEEXPR_contextDOWHILE:
17776 case FFEEXPR_contextACTUALARG_:
17777 case FFEEXPR_contextCGOTO:
17778 case FFEEXPR_contextIF:
17779 case FFEEXPR_contextARITHIF:
17780 case FFEEXPR_contextFORMAT:
17781 case FFEEXPR_contextSTOP:
17782 case FFEEXPR_contextRETURN:
17783 case FFEEXPR_contextSELECTCASE:
17784 case FFEEXPR_contextCASE:
17785 case FFEEXPR_contextFILEASSOC:
17786 case FFEEXPR_contextFILEINT:
17787 case FFEEXPR_contextFILEDFINT:
17788 case FFEEXPR_contextFILELOG:
17789 case FFEEXPR_contextFILENUM:
17790 case FFEEXPR_contextFILENUMAMBIG:
17791 case FFEEXPR_contextFILECHAR:
17792 case FFEEXPR_contextFILENUMCHAR:
17793 case FFEEXPR_contextFILEDFCHAR:
17794 case FFEEXPR_contextFILEKEY:
17795 case FFEEXPR_contextFILEUNIT:
17796 case FFEEXPR_contextFILEUNIT_DF:
17797 case FFEEXPR_contextFILEUNITAMBIG:
17798 case FFEEXPR_contextFILEFORMAT:
17799 case FFEEXPR_contextFILENAMELIST:
17800 case FFEEXPR_contextFILEVXTCODE:
17801 case FFEEXPR_contextINDEX_:
17802 case FFEEXPR_contextIMPDOITEM_:
17803 case FFEEXPR_contextIMPDOITEMDF_:
17804 case FFEEXPR_contextIMPDOCTRL_:
17805 case FFEEXPR_contextLOC_:
17806 bad = FALSE; /* Let paren-switch handle the cases. */
17809 case FFEEXPR_contextASSIGN:
17810 case FFEEXPR_contextAGOTO:
17811 case FFEEXPR_contextCHARACTERSIZE:
17812 case FFEEXPR_contextEQUIVALENCE:
17813 case FFEEXPR_contextPARAMETER:
17814 case FFEEXPR_contextDIMLIST:
17815 case FFEEXPR_contextDIMLISTCOMMON:
17816 case FFEEXPR_contextKINDTYPE:
17817 case FFEEXPR_contextINITVAL:
17818 case FFEEXPR_contextEQVINDEX_:
17819 bad = (k != FFEINFO_kindENTITY)
17820 || (ffesymbol_where (s) != FFEINFO_whereCONSTANT);
17823 case FFEEXPR_contextINCLUDE:
17832 switch (bad ? FFEINFO_kindANY : k)
17834 case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */
17835 if (ffesymbol_where (s) == FFEINFO_whereINTRINSIC)
17837 if (ffeexpr_context_outer_ (ffeexpr_stack_)
17838 == FFEEXPR_contextSUBROUTINEREF)
17839 *paren_type = FFEEXPR_parentypeSUBROUTINE_;
17841 *paren_type = FFEEXPR_parentypeFUNCTION_;
17844 if (st == FFESYMBOL_stateUNDERSTOOD)
17847 *paren_type = FFEEXPR_parentypeANY_;
17850 *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
17853 case FFEINFO_kindFUNCTION:
17854 *paren_type = FFEEXPR_parentypeFUNCTION_;
17855 switch (ffesymbol_where (s))
17857 case FFEINFO_whereLOCAL:
17858 bad = TRUE; /* Attempt to recurse! */
17861 case FFEINFO_whereCONSTANT:
17862 bad = ((ffesymbol_sfexpr (s) == NULL)
17863 || (ffebld_op (ffesymbol_sfexpr (s))
17864 == FFEBLD_opANY)); /* Attempt to recurse! */
17872 case FFEINFO_kindSUBROUTINE:
17873 if ((ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
17874 || (ffeexpr_stack_->previous != NULL))
17877 *paren_type = FFEEXPR_parentypeANY_;
17881 *paren_type = FFEEXPR_parentypeSUBROUTINE_;
17882 switch (ffesymbol_where (s))
17884 case FFEINFO_whereLOCAL:
17885 case FFEINFO_whereCONSTANT:
17886 bad = TRUE; /* Attempt to recurse! */
17894 case FFEINFO_kindENTITY:
17895 if (ffesymbol_rank (s) == 0)
17897 if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
17898 *paren_type = FFEEXPR_parentypeSUBSTRING_;
17902 *paren_type = FFEEXPR_parentypeANY_;
17906 *paren_type = FFEEXPR_parentypeARRAY_;
17910 case FFEINFO_kindANY:
17912 *paren_type = FFEEXPR_parentypeANY_;
17918 if (k == FFEINFO_kindANY)
17921 ffesymbol_error (s, t);
17926 case FFESYMBOL_stateSEEN: /* Seen but not yet in exec portion. */
17927 seen: /* :::::::::::::::::::: */
17929 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
17931 case FFEEXPR_contextPARAMETER:
17932 if (ffeexpr_stack_->is_rhs)
17933 ffesymbol_error (s, t);
17935 s = ffeexpr_sym_lhs_parameter_ (s, t);
17938 case FFEEXPR_contextDATA:
17939 s = ffecom_sym_exec_transition (s);
17940 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17941 goto understood; /* :::::::::::::::::::: */
17942 if (ffeexpr_stack_->is_rhs)
17943 ffesymbol_error (s, t);
17945 s = ffeexpr_sym_lhs_data_ (s, t);
17946 goto understood; /* :::::::::::::::::::: */
17948 case FFEEXPR_contextDATAIMPDOITEM_:
17949 s = ffecom_sym_exec_transition (s);
17950 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17951 goto understood; /* :::::::::::::::::::: */
17952 s = ffeexpr_sym_lhs_data_ (s, t);
17953 goto understood; /* :::::::::::::::::::: */
17955 case FFEEXPR_contextEQUIVALENCE:
17956 s = ffeexpr_sym_lhs_equivalence_ (s, t);
17960 case FFEEXPR_contextDIMLIST:
17961 s = ffeexpr_sym_rhs_dimlist_ (s, t);
17965 case FFEEXPR_contextCHARACTERSIZE:
17966 case FFEEXPR_contextKINDTYPE:
17967 case FFEEXPR_contextDIMLISTCOMMON:
17968 case FFEEXPR_contextINITVAL:
17969 case FFEEXPR_contextEQVINDEX_:
17972 case FFEEXPR_contextINCLUDE:
17975 case FFEEXPR_contextINDEX_:
17976 case FFEEXPR_contextACTUALARGEXPR_:
17977 case FFEEXPR_contextINDEXORACTUALARGEXPR_:
17978 case FFEEXPR_contextSFUNCDEF:
17979 case FFEEXPR_contextSFUNCDEFINDEX_:
17980 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
17981 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
17982 assert (ffeexpr_stack_->is_rhs);
17983 s = ffecom_sym_exec_transition (s);
17984 if (ffesymbol_state (s) == FFESYMBOL_stateUNDERSTOOD)
17985 goto understood; /* :::::::::::::::::::: */
17986 s = ffeexpr_paren_rhs_let_ (s, t);
17987 goto understood; /* :::::::::::::::::::: */
17992 k = ffesymbol_kind (s);
17993 switch (bad ? FFEINFO_kindANY : k)
17995 case FFEINFO_kindNONE: /* Case "CHARACTER X,Y; Y=X(?". */
17996 *paren_type = FFEEXPR_parentypeFUNSUBSTR_;
17999 case FFEINFO_kindFUNCTION:
18000 *paren_type = FFEEXPR_parentypeFUNCTION_;
18001 switch (ffesymbol_where (s))
18003 case FFEINFO_whereLOCAL:
18004 bad = TRUE; /* Attempt to recurse! */
18007 case FFEINFO_whereCONSTANT:
18008 bad = ((ffesymbol_sfexpr (s) == NULL)
18009 || (ffebld_op (ffesymbol_sfexpr (s))
18010 == FFEBLD_opANY)); /* Attempt to recurse! */
18018 case FFEINFO_kindSUBROUTINE:
18019 *paren_type = FFEEXPR_parentypeANY_;
18020 bad = TRUE; /* Cannot possibly be in
18021 contextSUBROUTINEREF. */
18024 case FFEINFO_kindENTITY:
18025 if (ffesymbol_rank (s) == 0)
18027 if (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE)
18028 *paren_type = FFEEXPR_parentypeEQUIVALENCE_;
18029 else if (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER)
18030 *paren_type = FFEEXPR_parentypeSUBSTRING_;
18034 *paren_type = FFEEXPR_parentypeANY_;
18038 *paren_type = FFEEXPR_parentypeARRAY_;
18042 case FFEINFO_kindANY:
18044 *paren_type = FFEEXPR_parentypeANY_;
18050 if (k == FFEINFO_kindANY)
18053 ffesymbol_error (s, t);
18059 assert ("bad symbol state" == NULL);
18064 /* Have FOO in XYZ = ...FOO(...).... Executable context only. */
18067 ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t)
18072 ffeinfoWhere where;
18074 ffeintrinSpec spec;
18076 bool maybe_ambig = FALSE;
18077 bool error = FALSE;
18079 assert ((ffesymbol_state (s) == FFESYMBOL_stateNONE)
18080 || (ffesymbol_state (s) == FFESYMBOL_stateUNCERTAIN));
18082 na = sa = ffesymbol_attrs (s);
18084 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
18085 | FFESYMBOL_attrsADJUSTABLE
18086 | FFESYMBOL_attrsANYLEN
18087 | FFESYMBOL_attrsARRAY
18088 | FFESYMBOL_attrsDUMMY
18089 | FFESYMBOL_attrsEXTERNAL
18090 | FFESYMBOL_attrsSFARG
18091 | FFESYMBOL_attrsTYPE)));
18093 kind = ffesymbol_kind (s);
18094 where = ffesymbol_where (s);
18096 /* Figure out what kind of object we've got based on previous declarations
18097 of or references to the object. */
18099 if (sa & FFESYMBOL_attrsEXTERNAL)
18101 assert (!(sa & ~(FFESYMBOL_attrsACTUALARG
18102 | FFESYMBOL_attrsDUMMY
18103 | FFESYMBOL_attrsEXTERNAL
18104 | FFESYMBOL_attrsTYPE)));
18106 if (sa & FFESYMBOL_attrsTYPE)
18107 where = FFEINFO_whereGLOBAL;
18111 kind = FFEINFO_kindFUNCTION;
18113 if (sa & FFESYMBOL_attrsDUMMY)
18115 else if (sa & FFESYMBOL_attrsACTUALARG)
18116 ; /* Not DUMMY or TYPE. */
18117 else /* Not ACTUALARG, DUMMY, or TYPE. */
18118 where = FFEINFO_whereGLOBAL;
18121 else if (sa & FFESYMBOL_attrsDUMMY)
18123 assert (!(sa & FFESYMBOL_attrsEXTERNAL)); /* Handled above. */
18124 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
18125 | FFESYMBOL_attrsEXTERNAL
18126 | FFESYMBOL_attrsTYPE)));
18128 kind = FFEINFO_kindFUNCTION;
18129 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure; kind
18130 could be ENTITY w/substring ref. */
18132 else if (sa & FFESYMBOL_attrsARRAY)
18134 assert (!(sa & ~(FFESYMBOL_attrsARRAY
18135 | FFESYMBOL_attrsADJUSTABLE
18136 | FFESYMBOL_attrsTYPE)));
18138 where = FFEINFO_whereLOCAL;
18140 else if (sa & FFESYMBOL_attrsSFARG)
18142 assert (!(sa & ~(FFESYMBOL_attrsSFARG
18143 | FFESYMBOL_attrsTYPE)));
18145 where = FFEINFO_whereLOCAL; /* Actually an error, but at least we
18146 know it's a local var. */
18148 else if (sa & FFESYMBOL_attrsTYPE)
18150 assert (!(sa & (FFESYMBOL_attrsARRAY
18151 | FFESYMBOL_attrsDUMMY
18152 | FFESYMBOL_attrsEXTERNAL
18153 | FFESYMBOL_attrsSFARG))); /* Handled above. */
18154 assert (!(sa & ~(FFESYMBOL_attrsTYPE
18155 | FFESYMBOL_attrsADJUSTABLE
18156 | FFESYMBOL_attrsANYLEN
18157 | FFESYMBOL_attrsARRAY
18158 | FFESYMBOL_attrsDUMMY
18159 | FFESYMBOL_attrsEXTERNAL
18160 | FFESYMBOL_attrsSFARG)));
18162 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
18163 &gen, &spec, &imp))
18165 if (!(sa & FFESYMBOL_attrsANYLEN)
18166 && (ffeimplic_peek_symbol_type (s, NULL)
18167 == FFEINFO_basictypeCHARACTER))
18168 return s; /* Haven't learned anything yet. */
18170 ffesymbol_signal_change (s); /* May need to back up to previous
18172 ffesymbol_set_generic (s, gen);
18173 ffesymbol_set_specific (s, spec);
18174 ffesymbol_set_implementation (s, imp);
18175 ffesymbol_set_info (s,
18176 ffeinfo_new (ffesymbol_basictype (s),
18177 ffesymbol_kindtype (s),
18179 FFEINFO_kindFUNCTION,
18180 FFEINFO_whereINTRINSIC,
18181 ffesymbol_size (s)));
18182 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18183 ffesymbol_resolve_intrin (s);
18184 ffesymbol_reference (s, t, FALSE);
18185 s = ffecom_sym_learned (s);
18186 ffesymbol_signal_unreported (s); /* For debugging purposes. */
18190 if (sa & FFESYMBOL_attrsANYLEN)
18191 error = TRUE; /* Error, since the only way we can,
18192 given CHARACTER*(*) FOO, accept
18193 FOO(...) is for FOO to be a dummy
18194 arg or constant, but it can't
18195 become either now. */
18196 else if (sa & FFESYMBOL_attrsADJUSTABLE)
18198 kind = FFEINFO_kindENTITY;
18199 where = FFEINFO_whereLOCAL;
18203 kind = FFEINFO_kindFUNCTION;
18204 where = FFEINFO_whereGLOBAL;
18205 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure;
18206 could be ENTITY/LOCAL w/substring ref. */
18209 else if (sa == FFESYMBOL_attrsetNONE)
18211 assert (ffesymbol_state (s) == FFESYMBOL_stateNONE);
18213 if (ffeintrin_is_intrinsic (ffesymbol_text (s), t, FALSE,
18214 &gen, &spec, &imp))
18216 if (ffeimplic_peek_symbol_type (s, NULL)
18217 == FFEINFO_basictypeCHARACTER)
18218 return s; /* Haven't learned anything yet. */
18220 ffesymbol_signal_change (s); /* May need to back up to previous
18222 ffesymbol_set_generic (s, gen);
18223 ffesymbol_set_specific (s, spec);
18224 ffesymbol_set_implementation (s, imp);
18225 ffesymbol_set_info (s,
18226 ffeinfo_new (ffesymbol_basictype (s),
18227 ffesymbol_kindtype (s),
18229 FFEINFO_kindFUNCTION,
18230 FFEINFO_whereINTRINSIC,
18231 ffesymbol_size (s)));
18232 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18233 ffesymbol_resolve_intrin (s);
18234 s = ffecom_sym_learned (s);
18235 ffesymbol_reference (s, t, FALSE);
18236 ffesymbol_signal_unreported (s); /* For debugging purposes. */
18240 kind = FFEINFO_kindFUNCTION;
18241 where = FFEINFO_whereGLOBAL;
18242 maybe_ambig = TRUE; /* If basictypeCHARACTER, can't be sure;
18243 could be ENTITY/LOCAL w/substring ref. */
18248 /* Now see what we've got for a new object: NONE means a new error cropped
18249 up; ANY means an old error to be ignored; otherwise, everything's ok,
18250 update the object (symbol) and continue on. */
18253 ffesymbol_error (s, t);
18254 else if (!(na & FFESYMBOL_attrsANY))
18256 ffesymbol_signal_change (s); /* May need to back up to previous
18258 if (!ffeimplic_establish_symbol (s))
18260 ffesymbol_error (s, t);
18264 && (ffesymbol_basictype (s) == FFEINFO_basictypeCHARACTER))
18265 return s; /* Still not sure, let caller deal with it
18268 ffesymbol_set_info (s,
18269 ffeinfo_new (ffesymbol_basictype (s),
18270 ffesymbol_kindtype (s),
18271 ffesymbol_rank (s),
18274 ffesymbol_size (s)));
18275 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
18276 ffesymbol_resolve_intrin (s);
18277 s = ffecom_sym_learned (s);
18278 ffesymbol_reference (s, t, FALSE);
18279 ffesymbol_signal_unreported (s); /* For debugging purposes. */
18285 /* ffeexpr_token_arguments_ -- OPEN_PAREN [expr COMMA]...expr
18287 Return a pointer to this function to the lexer (ffelex), which will
18288 invoke it for the next token.
18290 Handle expression (which might be null) and COMMA or CLOSE_PAREN. */
18292 static ffelexHandler
18293 ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr, ffelexToken t)
18295 ffeexprExpr_ procedure;
18298 ffeexprContext ctx;
18299 bool check_intrin = FALSE; /* Set TRUE if intrinsic is REAL(Z) or AIMAG(Z). */
18301 procedure = ffeexpr_stack_->exprstack;
18302 info = ffebld_info (procedure->u.operand);
18304 /* Is there an expression to add? If the expression is nil,
18305 it might still be an argument. It is if:
18307 - The current token is comma, or
18309 - The -fugly-comma flag was specified *and* the procedure
18310 being invoked is external.
18312 Otherwise, if neither of the above is the case, just
18313 ignore this (nil) expression. */
18316 || (ffelex_token_type (t) == FFELEX_typeCOMMA)
18317 || (ffe_is_ugly_comma ()
18318 && (ffeinfo_where (info) == FFEINFO_whereGLOBAL)))
18320 /* This expression, even if nil, is apparently intended as an argument. */
18322 /* Internal procedure (CONTAINS, or statement function)? */
18324 if (ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18327 && ffebad_start (FFEBAD_NULL_ARGUMENT))
18329 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18330 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18331 ffebad_here (1, ffelex_token_where_line (t),
18332 ffelex_token_where_column (t));
18340 if (ffeexpr_stack_->next_dummy == NULL)
18341 { /* Report later which was the first extra argument. */
18342 if (ffeexpr_stack_->tokens[1] == NULL)
18344 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
18345 ffeexpr_stack_->num_args = 0;
18347 ++ffeexpr_stack_->num_args; /* Count # of extra arguments. */
18351 if ((ffeinfo_rank (ffebld_info (expr)) != 0)
18352 && ffebad_start (FFEBAD_ARRAY_AS_SFARG))
18355 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18356 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18357 ffebad_here (1, ffelex_token_where_line (ft),
18358 ffelex_token_where_column (ft));
18359 ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent
18360 (ffebld_symter (ffebld_head
18361 (ffeexpr_stack_->next_dummy)))));
18366 expr = ffeexpr_convert_expr (expr, ft,
18367 ffebld_head (ffeexpr_stack_->next_dummy),
18368 ffeexpr_stack_->tokens[0],
18369 FFEEXPR_contextLET);
18370 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18372 --ffeexpr_stack_->num_args; /* Count down # of args. */
18373 ffeexpr_stack_->next_dummy
18374 = ffebld_trail (ffeexpr_stack_->next_dummy);
18381 && ffe_is_pedantic ()
18382 && ffebad_start (FFEBAD_NULL_ARGUMENT_W))
18384 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18385 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18386 ffebad_here (1, ffelex_token_where_line (t),
18387 ffelex_token_where_column (t));
18390 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18394 switch (ffelex_token_type (t))
18396 case FFELEX_typeCOMMA:
18397 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
18399 case FFEEXPR_contextSFUNCDEF:
18400 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_:
18401 case FFEEXPR_contextSFUNCDEFINDEX_:
18402 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_:
18403 ctx = FFEEXPR_contextSFUNCDEFACTUALARG_;
18406 case FFEEXPR_contextSFUNCDEFACTUALARG_:
18407 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18408 assert ("bad context" == NULL);
18409 ctx = FFEEXPR_context;
18413 ctx = FFEEXPR_contextACTUALARG_;
18416 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18417 ffeexpr_token_arguments_);
18423 if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18424 && (ffeexpr_stack_->next_dummy != NULL))
18425 { /* Too few arguments. */
18426 if (ffebad_start (FFEBAD_TOO_FEW_ARGUMENTS))
18430 sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
18432 ffebad_here (0, ffelex_token_where_line (t),
18433 ffelex_token_where_column (t));
18434 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18435 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18436 ffebad_string (num);
18437 ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent (ffebld_symter
18438 (ffebld_head (ffeexpr_stack_->next_dummy)))));
18442 ffeexpr_stack_->next_dummy != NULL;
18443 ffeexpr_stack_->next_dummy
18444 = ffebld_trail (ffeexpr_stack_->next_dummy))
18446 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (0));
18447 ffebld_set_info (expr, ffeinfo_new_any ());
18448 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18452 if ((ffeinfo_where (info) == FFEINFO_whereCONSTANT)
18453 && (ffeexpr_stack_->tokens[1] != NULL))
18454 { /* Too many arguments to statement function. */
18455 if (ffebad_start (FFEBAD_TOO_MANY_ARGUMENTS))
18459 sprintf (num, "%" ffebldListLength_f "u", ffeexpr_stack_->num_args);
18461 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
18462 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
18463 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18464 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18465 ffebad_string (num);
18468 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
18470 ffebld_end_list (&ffeexpr_stack_->bottom);
18472 if (ffebld_op (procedure->u.operand) == FFEBLD_opANY)
18474 reduced = ffebld_new_any ();
18475 ffebld_set_info (reduced, ffeinfo_new_any ());
18479 if (ffeexpr_stack_->context != FFEEXPR_contextSUBROUTINEREF)
18480 reduced = ffebld_new_funcref (procedure->u.operand,
18481 ffeexpr_stack_->expr);
18483 reduced = ffebld_new_subrref (procedure->u.operand,
18484 ffeexpr_stack_->expr);
18485 if (ffebld_symter_generic (procedure->u.operand) != FFEINTRIN_genNONE)
18486 ffeintrin_fulfill_generic (&reduced, &info, ffeexpr_stack_->tokens[0]);
18487 else if (ffebld_symter_specific (procedure->u.operand)
18488 != FFEINTRIN_specNONE)
18489 ffeintrin_fulfill_specific (&reduced, &info, &check_intrin,
18490 ffeexpr_stack_->tokens[0]);
18492 ffeexpr_fulfill_call_ (&reduced, ffeexpr_stack_->tokens[0]);
18494 if (ffebld_op (reduced) != FFEBLD_opANY)
18495 ffebld_set_info (reduced,
18496 ffeinfo_new (ffeinfo_basictype (info),
18497 ffeinfo_kindtype (info),
18499 FFEINFO_kindENTITY,
18500 FFEINFO_whereFLEETING,
18501 ffeinfo_size (info)));
18503 ffebld_set_info (reduced, ffeinfo_new_any ());
18505 if (ffebld_op (reduced) == FFEBLD_opFUNCREF)
18506 reduced = ffeexpr_collapse_funcref (reduced, ffeexpr_stack_->tokens[0]);
18507 ffeexpr_stack_->exprstack = procedure->previous; /* Pops
18508 not-quite-operand off
18510 procedure->u.operand = reduced; /* Save the line/column ffewhere
18512 ffeexpr_exprstack_push_operand_ (procedure); /* Push it back on stack. */
18513 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18515 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18516 ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FUNC(3)(1:1)".... */
18518 /* If the intrinsic needs checking (is REAL(Z) or AIMAG(Z), where
18519 Z is DOUBLE COMPLEX), and a command-line option doesn't already
18520 establish interpretation, probably complain. */
18524 && !ffe_is_ugly_complex ())
18526 /* If the outer expression is REAL(me...), issue diagnostic
18527 only if next token isn't the close-paren for REAL(me). */
18529 if ((ffeexpr_stack_->previous != NULL)
18530 && (ffeexpr_stack_->previous->exprstack != NULL)
18531 && (ffeexpr_stack_->previous->exprstack->type == FFEEXPR_exprtypeOPERAND_)
18532 && ((reduced = ffeexpr_stack_->previous->exprstack->u.operand) != NULL)
18533 && (ffebld_op (reduced) == FFEBLD_opSYMTER)
18534 && (ffebld_symter_implementation (reduced) == FFEINTRIN_impREAL))
18535 return (ffelexHandler) ffeexpr_token_intrincheck_;
18537 /* Diagnose the ambiguity now. */
18539 if (ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
18541 ffebad_string (ffeintrin_name_implementation
18542 (ffebld_symter_implementation
18544 (ffeexpr_stack_->exprstack->u.operand))));
18545 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
18546 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
18550 return (ffelexHandler) ffeexpr_token_substrp_;
18553 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
18555 ffebad_here (0, ffelex_token_where_line (t),
18556 ffelex_token_where_column (t));
18557 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18558 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18561 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18562 ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FUNC(3)(1:1)".... */
18564 (ffelexHandler) ffeexpr_find_close_paren_ (t,
18566 ffeexpr_token_substrp_);
18569 /* ffeexpr_token_elements_ -- OPEN_PAREN [expr COMMA]...expr
18571 Return a pointer to this array to the lexer (ffelex), which will
18572 invoke it for the next token.
18574 Handle expression and COMMA or CLOSE_PAREN. */
18576 static ffelexHandler
18577 ffeexpr_token_elements_ (ffelexToken ft, ffebld expr, ffelexToken t)
18579 ffeexprExpr_ array;
18582 ffeinfoWhere where;
18583 ffetargetIntegerDefault val;
18584 ffetargetIntegerDefault lval = 0;
18585 ffetargetIntegerDefault uval = 0;
18591 array = ffeexpr_stack_->exprstack;
18592 info = ffebld_info (array->u.operand);
18594 if ((expr == NULL) /* && ((ffeexpr_stack_->rank != 0) ||
18595 (ffelex_token_type(t) ==
18596 FFELEX_typeCOMMA)) */ )
18598 if (ffebad_start (FFEBAD_NULL_ELEMENT))
18600 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18601 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18602 ffebad_here (1, ffelex_token_where_line (t),
18603 ffelex_token_where_column (t));
18606 if (ffeexpr_stack_->rank < ffeinfo_rank (info))
18607 { /* Don't bother if we're going to complain
18609 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
18610 ffebld_set_info (expr, ffeinfo_new_any ());
18616 else if (ffeinfo_rank (info) == 0)
18617 { /* In EQUIVALENCE context, ffeinfo_rank(info)
18619 ++ffeexpr_stack_->rank; /* Track anyway, may need for new VXT
18621 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18625 ++ffeexpr_stack_->rank;
18626 if (ffeexpr_stack_->rank > ffeinfo_rank (info))
18627 { /* Report later which was the first extra
18629 if (ffeexpr_stack_->rank == ffeinfo_rank (info) + 1)
18630 ffeexpr_stack_->tokens[1] = ffelex_token_use (ft);
18634 switch (ffeinfo_where (ffebld_info (expr)))
18636 case FFEINFO_whereCONSTANT:
18639 case FFEINFO_whereIMMEDIATE:
18640 ffeexpr_stack_->constant = FALSE;
18644 ffeexpr_stack_->constant = FALSE;
18645 ffeexpr_stack_->immediate = FALSE;
18648 if (ffebld_op (expr) == FFEBLD_opCONTER
18649 && ffebld_kindtype (expr) == FFEINFO_kindtypeINTEGERDEFAULT)
18651 val = ffebld_constant_integerdefault (ffebld_conter (expr));
18653 lbound = ffebld_left (ffebld_head (ffeexpr_stack_->bound_list));
18654 if (lbound == NULL)
18659 else if (ffebld_op (lbound) == FFEBLD_opCONTER)
18662 lval = ffebld_constant_integerdefault (ffebld_conter (lbound));
18667 ubound = ffebld_right (ffebld_head (ffeexpr_stack_->bound_list));
18668 assert (ubound != NULL);
18669 if (ffebld_op (ubound) == FFEBLD_opCONTER)
18672 uval = ffebld_constant_integerdefault (ffebld_conter (ubound));
18677 if ((lcheck && (val < lval)) || (ucheck && (val > uval)))
18679 ffebad_start (FFEBAD_RANGE_ARRAY);
18680 ffebad_here (0, ffelex_token_where_line (ft),
18681 ffelex_token_where_column (ft));
18685 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18686 ffeexpr_stack_->bound_list = ffebld_trail (ffeexpr_stack_->bound_list);
18690 switch (ffelex_token_type (t))
18692 case FFELEX_typeCOMMA:
18693 switch (ffeexpr_context_outer_ (ffeexpr_stack_))
18695 case FFEEXPR_contextDATAIMPDOITEM_:
18696 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18697 FFEEXPR_contextDATAIMPDOINDEX_,
18698 ffeexpr_token_elements_);
18700 case FFEEXPR_contextEQUIVALENCE:
18701 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18702 FFEEXPR_contextEQVINDEX_,
18703 ffeexpr_token_elements_);
18705 case FFEEXPR_contextSFUNCDEF:
18706 case FFEEXPR_contextSFUNCDEFINDEX_:
18707 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18708 FFEEXPR_contextSFUNCDEFINDEX_,
18709 ffeexpr_token_elements_);
18711 case FFEEXPR_contextSFUNCDEFACTUALARG_:
18712 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18713 assert ("bad context" == NULL);
18717 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
18718 FFEEXPR_contextINDEX_,
18719 ffeexpr_token_elements_);
18726 if ((ffeexpr_stack_->rank != ffeinfo_rank (info))
18727 && (ffeinfo_rank (info) != 0))
18731 if (ffeexpr_stack_->rank < ffeinfo_rank (info))
18733 if (ffebad_start (FFEBAD_TOO_FEW_ELEMENTS))
18735 sprintf (num, "%d",
18736 (int) (ffeinfo_rank (info) - ffeexpr_stack_->rank));
18738 ffebad_here (0, ffelex_token_where_line (t),
18739 ffelex_token_where_column (t));
18741 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18742 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18743 ffebad_string (num);
18749 if (ffebad_start (FFEBAD_TOO_MANY_ELEMENTS))
18751 sprintf (num, "%d",
18752 (int) (ffeexpr_stack_->rank - ffeinfo_rank (info)));
18755 ffelex_token_where_line (ffeexpr_stack_->tokens[1]),
18756 ffelex_token_where_column (ffeexpr_stack_->tokens[1]));
18758 ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18759 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18760 ffebad_string (num);
18763 ffelex_token_kill (ffeexpr_stack_->tokens[1]);
18765 while (ffeexpr_stack_->rank++ < ffeinfo_rank (info))
18767 expr = ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
18768 ffebld_set_info (expr, ffeinfo_new (FFEINFO_basictypeINTEGER,
18769 FFEINFO_kindtypeINTEGERDEFAULT,
18770 0, FFEINFO_kindENTITY,
18771 FFEINFO_whereCONSTANT,
18772 FFETARGET_charactersizeNONE));
18773 ffebld_append_item (&ffeexpr_stack_->bottom, expr);
18776 ffebld_end_list (&ffeexpr_stack_->bottom);
18778 if (ffebld_op (array->u.operand) == FFEBLD_opANY)
18780 reduced = ffebld_new_any ();
18781 ffebld_set_info (reduced, ffeinfo_new_any ());
18785 reduced = ffebld_new_arrayref (array->u.operand, ffeexpr_stack_->expr);
18786 if (ffeexpr_stack_->constant)
18787 where = FFEINFO_whereFLEETING_CADDR;
18788 else if (ffeexpr_stack_->immediate)
18789 where = FFEINFO_whereFLEETING_IADDR;
18791 where = FFEINFO_whereFLEETING;
18792 ffebld_set_info (reduced,
18793 ffeinfo_new (ffeinfo_basictype (info),
18794 ffeinfo_kindtype (info),
18796 FFEINFO_kindENTITY,
18798 ffeinfo_size (info)));
18799 reduced = ffeexpr_collapse_arrayref (reduced, ffeexpr_stack_->tokens[0]);
18802 ffeexpr_stack_->exprstack = array->previous; /* Pops not-quite-operand off
18804 array->u.operand = reduced; /* Save the line/column ffewhere info. */
18805 ffeexpr_exprstack_push_operand_ (array); /* Push it back on stack. */
18807 switch (ffeinfo_basictype (info))
18809 case FFEINFO_basictypeCHARACTER:
18810 ffeexpr_is_substr_ok_ = TRUE; /* Everyone likes "FOO(3)(1:1)".... */
18813 case FFEINFO_basictypeNONE:
18814 ffeexpr_is_substr_ok_ = TRUE;
18815 assert (ffeexpr_stack_->context == FFEEXPR_contextEQUIVALENCE);
18819 ffeexpr_is_substr_ok_ = FALSE;
18823 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
18825 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18826 return (ffelexHandler) ffeexpr_token_substrp_;
18829 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
18831 ffebad_here (0, ffelex_token_where_line (t),
18832 ffelex_token_where_column (t));
18833 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18834 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18837 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
18839 (ffelexHandler) ffeexpr_find_close_paren_ (t,
18841 ffeexpr_token_substrp_);
18844 /* ffeexpr_token_equivalence_ -- OPEN_PAREN expr
18846 Return a pointer to this array to the lexer (ffelex), which will
18847 invoke it for the next token.
18849 If token is COLON, pass off to _substr_, else init list and pass off
18850 to _elements_. This handles the case "EQUIVALENCE (FOO(expr?", where
18851 ? marks the token, and where FOO's rank/type has not yet been established,
18852 meaning we could be in a list of indices or in a substring
18855 static ffelexHandler
18856 ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr, ffelexToken t)
18858 if (ffelex_token_type (t) == FFELEX_typeCOLON)
18859 return ffeexpr_token_substring_ (ft, expr, t);
18861 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
18862 return ffeexpr_token_elements_ (ft, expr, t);
18865 /* ffeexpr_token_substring_ -- NAME(of kindENTITY) OPEN_PAREN expr
18867 Return a pointer to this function to the lexer (ffelex), which will
18868 invoke it for the next token.
18870 Handle expression (which may be null) and COLON. */
18872 static ffelexHandler
18873 ffeexpr_token_substring_ (ffelexToken ft, ffebld expr, ffelexToken t)
18875 ffeexprExpr_ string;
18877 ffetargetIntegerDefault i;
18878 ffeexprContext ctx;
18879 ffetargetCharacterSize size;
18881 string = ffeexpr_stack_->exprstack;
18882 info = ffebld_info (string->u.operand);
18883 size = ffebld_size_max (string->u.operand);
18885 if (ffelex_token_type (t) == FFELEX_typeCOLON)
18888 && (ffebld_op (expr) == FFEBLD_opCONTER)
18889 && (((i = ffebld_constant_integerdefault (ffebld_conter (expr)))
18891 || ((size != FFETARGET_charactersizeNONE) && (i > size))))
18893 ffebad_start (FFEBAD_RANGE_SUBSTR);
18894 ffebad_here (0, ffelex_token_where_line (ft),
18895 ffelex_token_where_column (ft));
18898 ffeexpr_stack_->expr = expr;
18900 switch (ffeexpr_stack_->context)
18902 case FFEEXPR_contextSFUNCDEF:
18903 case FFEEXPR_contextSFUNCDEFINDEX_:
18904 ctx = FFEEXPR_contextSFUNCDEFINDEX_;
18907 case FFEEXPR_contextSFUNCDEFACTUALARG_:
18908 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
18909 assert ("bad context" == NULL);
18910 ctx = FFEEXPR_context;
18914 ctx = FFEEXPR_contextINDEX_;
18918 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
18919 ffeexpr_token_substring_1_);
18922 if (ffest_ffebad_start (FFEBAD_MISSING_COLON_IN_SUBSTR))
18924 ffebad_here (0, ffelex_token_where_line (t),
18925 ffelex_token_where_column (t));
18926 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
18927 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
18931 ffeexpr_stack_->expr = NULL;
18932 return (ffelexHandler) ffeexpr_token_substring_1_ (ft, expr, t);
18935 /* ffeexpr_token_substring_1_ -- NAME OPEN_PAREN [expr COMMA]...expr
18937 Return a pointer to this function to the lexer (ffelex), which will
18938 invoke it for the next token.
18940 Handle expression (which might be null) and CLOSE_PAREN. */
18942 static ffelexHandler
18943 ffeexpr_token_substring_1_ (ffelexToken ft, ffebld last, ffelexToken t)
18945 ffeexprExpr_ string;
18948 ffebld first = ffeexpr_stack_->expr;
18953 ffeinfoWhere where;
18954 ffeinfoKindtype first_kt;
18955 ffeinfoKindtype last_kt;
18956 ffetargetIntegerDefault first_val;
18957 ffetargetIntegerDefault last_val;
18958 ffetargetCharacterSize size;
18959 ffetargetCharacterSize strop_size_max;
18962 string = ffeexpr_stack_->exprstack;
18963 strop = string->u.operand;
18964 info = ffebld_info (strop);
18967 || (ffebld_op (first) == FFEBLD_opCONTER
18968 && ffebld_kindtype (first) == FFEINFO_kindtypeINTEGERDEFAULT))
18969 { /* The starting point is known. */
18970 first_val = (first == NULL) ? 1
18971 : ffebld_constant_integerdefault (ffebld_conter (first));
18972 first_known = TRUE;
18975 { /* Assume start of the entity. */
18977 first_known = FALSE;
18981 && (ffebld_op (last) == FFEBLD_opCONTER
18982 && ffebld_kindtype (last) == FFEINFO_kindtypeINTEGERDEFAULT))
18983 { /* The ending point is known. */
18984 last_val = ffebld_constant_integerdefault (ffebld_conter (last));
18987 { /* The beginning point is a constant. */
18988 if (first_val <= last_val)
18989 size = last_val - first_val + 1;
18992 if (0 && ffe_is_90 ())
18997 ffebad_start (FFEBAD_ZERO_SIZE);
18998 ffebad_here (0, ffelex_token_where_line (ft),
18999 ffelex_token_where_column (ft));
19005 size = FFETARGET_charactersizeNONE;
19007 strop_size_max = ffebld_size_max (strop);
19009 if ((strop_size_max != FFETARGET_charactersizeNONE)
19010 && (last_val > strop_size_max))
19011 { /* Beyond maximum possible end of string. */
19012 ffebad_start (FFEBAD_RANGE_SUBSTR);
19013 ffebad_here (0, ffelex_token_where_line (ft),
19014 ffelex_token_where_column (ft));
19019 size = FFETARGET_charactersizeNONE; /* The size is not known. */
19021 #if 0 /* Don't do this, or "is size of target
19022 known?" would no longer be easily
19023 answerable. To see if there is a max
19024 size, use ffebld_size_max; to get only the
19025 known size, else NONE, use
19026 ffebld_size_known; use ffebld_size if
19027 values are sure to be the same (not
19028 opSUBSTR or opCONCATENATE or known to have
19029 known length). By getting rid of this
19030 "useful info" stuff, we don't end up
19031 blank-padding the constant in the
19032 assignment "A(I:J)='XYZ'" to the known
19034 if (size == FFETARGET_charactersizeNONE)
19035 size = strop_size_max; /* Assume we use the entire string. */
19049 lwh = FFEINFO_whereCONSTANT;
19051 lwh = ffeinfo_where (ffebld_info (first));
19053 rwh = FFEINFO_whereCONSTANT;
19055 rwh = ffeinfo_where (ffebld_info (last));
19059 case FFEINFO_whereCONSTANT:
19062 case FFEINFO_whereCONSTANT:
19063 where = FFEINFO_whereCONSTANT;
19066 case FFEINFO_whereIMMEDIATE:
19067 where = FFEINFO_whereIMMEDIATE;
19071 where = FFEINFO_whereFLEETING;
19076 case FFEINFO_whereIMMEDIATE:
19079 case FFEINFO_whereCONSTANT:
19080 case FFEINFO_whereIMMEDIATE:
19081 where = FFEINFO_whereIMMEDIATE;
19085 where = FFEINFO_whereFLEETING;
19091 where = FFEINFO_whereFLEETING;
19096 first_kt = FFEINFO_kindtypeINTEGERDEFAULT;
19098 first_kt = ffeinfo_kindtype (ffebld_info (first));
19100 last_kt = FFEINFO_kindtypeINTEGERDEFAULT;
19102 last_kt = ffeinfo_kindtype (ffebld_info (last));
19106 case FFEINFO_whereCONSTANT:
19107 switch (ffeinfo_where (info))
19109 case FFEINFO_whereCONSTANT:
19112 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
19113 where = FFEINFO_whereIMMEDIATE;
19117 where = FFEINFO_whereFLEETING_CADDR;
19122 case FFEINFO_whereIMMEDIATE:
19123 switch (ffeinfo_where (info))
19125 case FFEINFO_whereCONSTANT:
19126 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
19130 where = FFEINFO_whereFLEETING_IADDR;
19136 switch (ffeinfo_where (info))
19138 case FFEINFO_whereCONSTANT:
19139 where = FFEINFO_whereCONSTANT_SUBOBJECT; /* An F90 concept. */
19142 case FFEINFO_whereIMMEDIATE: /* Not possible, actually. */
19144 where = FFEINFO_whereFLEETING;
19150 if (ffebld_op (strop) == FFEBLD_opANY)
19152 reduced = ffebld_new_any ();
19153 ffebld_set_info (reduced, ffeinfo_new_any ());
19157 reduced = ffebld_new_substr (strop, substrlist);
19158 ffebld_set_info (reduced, ffeinfo_new
19159 (FFEINFO_basictypeCHARACTER,
19160 ffeinfo_kindtype (info),
19162 FFEINFO_kindENTITY,
19165 reduced = ffeexpr_collapse_substr (reduced, ffeexpr_stack_->tokens[0]);
19168 ffeexpr_stack_->exprstack = string->previous; /* Pops not-quite-operand off
19170 string->u.operand = reduced; /* Save the line/column ffewhere info. */
19171 ffeexpr_exprstack_push_operand_ (string); /* Push it back on stack. */
19173 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
19175 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19176 ffeexpr_is_substr_ok_ = FALSE; /* Nobody likes "FOO(3:5)(1:1)".... */
19177 return (ffelexHandler) ffeexpr_token_substrp_;
19180 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION))
19182 ffebad_here (0, ffelex_token_where_line (t),
19183 ffelex_token_where_column (t));
19184 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->tokens[0]),
19185 ffelex_token_where_column (ffeexpr_stack_->tokens[0]));
19189 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19190 ffeexpr_is_substr_ok_ = FALSE;/* Nobody likes "FOO(3:5)(1:1)".... */
19192 (ffelexHandler) ffeexpr_find_close_paren_ (t,
19194 ffeexpr_token_substrp_);
19197 /* ffeexpr_token_substrp_ -- Rhs <character entity>
19199 Return a pointer to this function to the lexer (ffelex), which will
19200 invoke it for the next token.
19202 If OPEN_PAREN, treat as start of a substring ("(3:4)") construct, and
19203 issue error message if flag (serves as argument) is set. Else, just
19204 forward token to binary_. */
19206 static ffelexHandler
19207 ffeexpr_token_substrp_ (ffelexToken t)
19209 ffeexprContext ctx;
19211 if (ffelex_token_type (t) != FFELEX_typeOPEN_PAREN)
19212 return (ffelexHandler) ffeexpr_token_binary_ (t);
19214 ffeexpr_stack_->tokens[0] = ffelex_token_use (t);
19216 switch (ffeexpr_stack_->context)
19218 case FFEEXPR_contextSFUNCDEF:
19219 case FFEEXPR_contextSFUNCDEFINDEX_:
19220 ctx = FFEEXPR_contextSFUNCDEFINDEX_;
19223 case FFEEXPR_contextSFUNCDEFACTUALARG_:
19224 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_:
19225 assert ("bad context" == NULL);
19226 ctx = FFEEXPR_context;
19230 ctx = FFEEXPR_contextINDEX_;
19234 if (!ffeexpr_is_substr_ok_)
19236 if (ffebad_start (FFEBAD_BAD_SUBSTR))
19238 ffebad_here (0, ffelex_token_where_line (t),
19239 ffelex_token_where_column (t));
19240 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
19241 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
19245 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
19246 ffeexpr_token_anything_);
19249 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool, ctx,
19250 ffeexpr_token_substring_);
19253 static ffelexHandler
19254 ffeexpr_token_intrincheck_ (ffelexToken t)
19256 if ((ffelex_token_type (t) != FFELEX_typeCLOSE_PAREN)
19257 && ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG))
19259 ffebad_string (ffeintrin_name_implementation
19260 (ffebld_symter_implementation
19262 (ffeexpr_stack_->exprstack->u.operand))));
19263 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_->exprstack->token),
19264 ffelex_token_where_column (ffeexpr_stack_->exprstack->token));
19268 return (ffelexHandler) ffeexpr_token_substrp_ (t);
19271 /* ffeexpr_token_funsubstr_ -- NAME OPEN_PAREN expr
19273 Return a pointer to this function to the lexer (ffelex), which will
19274 invoke it for the next token.
19276 If COLON, do everything we would have done since _parenthesized_ if
19277 we had known NAME represented a kindENTITY instead of a kindFUNCTION.
19278 If not COLON, do likewise for kindFUNCTION instead. */
19280 static ffelexHandler
19281 ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr, ffelexToken t)
19283 ffeinfoWhere where;
19286 ffebld symter = ffeexpr_stack_->exprstack->u.operand;
19289 ffeintrinSpec spec;
19292 s = ffebld_symter (symter);
19293 sa = ffesymbol_attrs (s);
19294 where = ffesymbol_where (s);
19296 /* We get here only if we don't already know enough about FOO when seeing a
19297 FOO(stuff) reference, and FOO might turn out to be a CHARACTER type. If
19298 "stuff" is a substring reference, then FOO is a CHARACTER scalar type.
19299 Else FOO is a function, either intrinsic or external. If intrinsic, it
19300 wouldn't necessarily be CHARACTER type, so unless it has already been
19301 declared DUMMY, it hasn't had its type established yet. It can't be
19302 CHAR*(*) in any case, though it can have an explicit CHAR*n type. */
19304 assert (!(sa & ~(FFESYMBOL_attrsDUMMY
19305 | FFESYMBOL_attrsTYPE)));
19307 needs_type = !(ffesymbol_attrs (s) & FFESYMBOL_attrsDUMMY);
19309 ffesymbol_signal_change (s); /* Probably already done, but in case.... */
19311 if (ffelex_token_type (t) == FFELEX_typeCOLON)
19312 { /* Definitely an ENTITY (char substring). */
19313 if (needs_type && !ffeimplic_establish_symbol (s))
19315 ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
19316 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19319 ffesymbol_set_info (s,
19320 ffeinfo_new (ffesymbol_basictype (s),
19321 ffesymbol_kindtype (s),
19322 ffesymbol_rank (s),
19323 FFEINFO_kindENTITY,
19324 (where == FFEINFO_whereNONE)
19325 ? FFEINFO_whereLOCAL
19327 ffesymbol_size (s)));
19328 ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
19330 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
19331 ffesymbol_resolve_intrin (s);
19332 s = ffecom_sym_learned (s);
19333 ffesymbol_signal_unreported (s); /* For debugging purposes. */
19335 ffeexpr_stack_->exprstack->u.operand
19336 = ffeexpr_collapse_symter (symter, ffeexpr_tokens_[0]);
19338 return (ffelexHandler) ffeexpr_token_substring_ (ft, expr, t);
19341 /* The "stuff" isn't a substring notation, so we now know the overall
19342 reference is to a function. */
19344 if (ffeintrin_is_intrinsic (ffesymbol_text (s), ffeexpr_stack_->tokens[0],
19345 FALSE, &gen, &spec, &imp))
19347 ffebld_symter_set_generic (symter, gen);
19348 ffebld_symter_set_specific (symter, spec);
19349 ffebld_symter_set_implementation (symter, imp);
19350 ffesymbol_set_generic (s, gen);
19351 ffesymbol_set_specific (s, spec);
19352 ffesymbol_set_implementation (s, imp);
19353 ffesymbol_set_info (s,
19354 ffeinfo_new (ffesymbol_basictype (s),
19355 ffesymbol_kindtype (s),
19357 FFEINFO_kindFUNCTION,
19358 FFEINFO_whereINTRINSIC,
19359 ffesymbol_size (s)));
19362 { /* Not intrinsic, now needs CHAR type. */
19363 if (!ffeimplic_establish_symbol (s))
19365 ffesymbol_error (s, ffeexpr_stack_->tokens[0]);
19366 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19369 ffesymbol_set_info (s,
19370 ffeinfo_new (ffesymbol_basictype (s),
19371 ffesymbol_kindtype (s),
19372 ffesymbol_rank (s),
19373 FFEINFO_kindFUNCTION,
19374 (where == FFEINFO_whereNONE)
19375 ? FFEINFO_whereGLOBAL
19377 ffesymbol_size (s)));
19380 ffebld_set_info (symter, ffeinfo_use (ffesymbol_info (s)));
19382 ffesymbol_set_state (s, FFESYMBOL_stateUNDERSTOOD);
19383 ffesymbol_resolve_intrin (s);
19384 s = ffecom_sym_learned (s);
19385 ffesymbol_reference (s, ffeexpr_stack_->tokens[0], FALSE);
19386 ffesymbol_signal_unreported (s); /* For debugging purposes. */
19387 ffebld_init_list (&ffeexpr_stack_->expr, &ffeexpr_stack_->bottom);
19388 return (ffelexHandler) ffeexpr_token_arguments_ (ft, expr, t);
19391 /* ffeexpr_token_anything_ -- NAME OPEN_PAREN any-expr
19393 Handle basically any expression, looking for CLOSE_PAREN. */
19395 static ffelexHandler
19396 ffeexpr_token_anything_ (ffelexToken ft UNUSED, ffebld expr UNUSED,
19399 ffeexprExpr_ e = ffeexpr_stack_->exprstack;
19401 switch (ffelex_token_type (t))
19403 case FFELEX_typeCOMMA:
19404 case FFELEX_typeCOLON:
19405 return (ffelexHandler) ffeexpr_rhs (ffeexpr_stack_->pool,
19406 FFEEXPR_contextACTUALARG_,
19407 ffeexpr_token_anything_);
19410 e->u.operand = ffebld_new_any ();
19411 ffebld_set_info (e->u.operand, ffeinfo_new_any ());
19412 ffelex_token_kill (ffeexpr_stack_->tokens[0]);
19413 ffeexpr_is_substr_ok_ = FALSE;
19414 if (ffelex_token_type (t) == FFELEX_typeCLOSE_PAREN)
19415 return (ffelexHandler) ffeexpr_token_substrp_;
19416 return (ffelexHandler) ffeexpr_token_substrp_ (t);
19420 /* Terminate module. */
19423 ffeexpr_terminate_2 ()
19425 assert (ffeexpr_stack_ == NULL);
19426 assert (ffeexpr_level_ == 0);