1 /* expr.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995, 1996, 1997, 1998, 2001, 2002, 2003
3 Free Software Foundation, Inc.
4 Contributed by James Craig Burley.
6 This file is part of GNU Fortran.
8 GNU Fortran is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2, or (at your option)
13 GNU Fortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with GNU Fortran; see the file COPYING. If not, write to
20 the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
27 Handles syntactic and semantic analysis of Fortran expressions.
53 /* Externals defined here. */
56 /* Simple definitions and enumerations. */
60 FFEEXPR_exprtypeUNKNOWN_
,
61 FFEEXPR_exprtypeOPERAND_
,
62 FFEEXPR_exprtypeUNARY_
,
63 FFEEXPR_exprtypeBINARY_
,
69 FFEEXPR_operatorPOWER_
,
70 FFEEXPR_operatorMULTIPLY_
,
71 FFEEXPR_operatorDIVIDE_
,
73 FFEEXPR_operatorSUBTRACT_
,
74 FFEEXPR_operatorCONCATENATE_
,
86 FFEEXPR_operatorNEQV_
,
92 FFEEXPR_operatorprecedenceHIGHEST_
= 1,
93 FFEEXPR_operatorprecedencePOWER_
= 1,
94 FFEEXPR_operatorprecedenceMULTIPLY_
= 2,
95 FFEEXPR_operatorprecedenceDIVIDE_
= 2,
96 FFEEXPR_operatorprecedenceADD_
= 3,
97 FFEEXPR_operatorprecedenceSUBTRACT_
= 3,
98 FFEEXPR_operatorprecedenceLOWARITH_
= 3,
99 FFEEXPR_operatorprecedenceCONCATENATE_
= 3,
100 FFEEXPR_operatorprecedenceLT_
= 4,
101 FFEEXPR_operatorprecedenceLE_
= 4,
102 FFEEXPR_operatorprecedenceEQ_
= 4,
103 FFEEXPR_operatorprecedenceNE_
= 4,
104 FFEEXPR_operatorprecedenceGT_
= 4,
105 FFEEXPR_operatorprecedenceGE_
= 4,
106 FFEEXPR_operatorprecedenceNOT_
= 5,
107 FFEEXPR_operatorprecedenceAND_
= 6,
108 FFEEXPR_operatorprecedenceOR_
= 7,
109 FFEEXPR_operatorprecedenceXOR_
= 8,
110 FFEEXPR_operatorprecedenceEQV_
= 8,
111 FFEEXPR_operatorprecedenceNEQV_
= 8,
112 FFEEXPR_operatorprecedenceLOWEST_
= 8,
113 FFEEXPR_operatorprecedence_
114 } ffeexprOperatorPrecedence_
;
116 #define FFEEXPR_operatorassociativityL2R_ TRUE
117 #define FFEEXPR_operatorassociativityR2L_ FALSE
118 #define FFEEXPR_operatorassociativityPOWER_ FFEEXPR_operatorassociativityR2L_
119 #define FFEEXPR_operatorassociativityMULTIPLY_ FFEEXPR_operatorassociativityL2R_
120 #define FFEEXPR_operatorassociativityDIVIDE_ FFEEXPR_operatorassociativityL2R_
121 #define FFEEXPR_operatorassociativityADD_ FFEEXPR_operatorassociativityL2R_
122 #define FFEEXPR_operatorassociativitySUBTRACT_ FFEEXPR_operatorassociativityL2R_
123 #define FFEEXPR_operatorassociativityCONCATENATE_ FFEEXPR_operatorassociativityL2R_
124 #define FFEEXPR_operatorassociativityLT_ FFEEXPR_operatorassociativityL2R_
125 #define FFEEXPR_operatorassociativityLE_ FFEEXPR_operatorassociativityL2R_
126 #define FFEEXPR_operatorassociativityEQ_ FFEEXPR_operatorassociativityL2R_
127 #define FFEEXPR_operatorassociativityNE_ FFEEXPR_operatorassociativityL2R_
128 #define FFEEXPR_operatorassociativityGT_ FFEEXPR_operatorassociativityL2R_
129 #define FFEEXPR_operatorassociativityGE_ FFEEXPR_operatorassociativityL2R_
130 #define FFEEXPR_operatorassociativityNOT_ FFEEXPR_operatorassociativityL2R_
131 #define FFEEXPR_operatorassociativityAND_ FFEEXPR_operatorassociativityL2R_
132 #define FFEEXPR_operatorassociativityOR_ FFEEXPR_operatorassociativityL2R_
133 #define FFEEXPR_operatorassociativityXOR_ FFEEXPR_operatorassociativityL2R_
134 #define FFEEXPR_operatorassociativityEQV_ FFEEXPR_operatorassociativityL2R_
135 #define FFEEXPR_operatorassociativityNEQV_ FFEEXPR_operatorassociativityL2R_
139 FFEEXPR_parentypeFUNCTION_
,
140 FFEEXPR_parentypeSUBROUTINE_
,
141 FFEEXPR_parentypeARRAY_
,
142 FFEEXPR_parentypeSUBSTRING_
,
143 FFEEXPR_parentypeFUNSUBSTR_
,/* Ambig: check for colon after first expr. */
144 FFEEXPR_parentypeEQUIVALENCE_
, /* Ambig: ARRAY_ or SUBSTRING_. */
145 FFEEXPR_parentypeANY_
, /* Allow basically anything. */
151 FFEEXPR_percentNONE_
,
155 FFEEXPR_percentDESCR_
,
159 /* Internal typedefs. */
161 typedef struct _ffeexpr_expr_
*ffeexprExpr_
;
162 typedef bool ffeexprOperatorAssociativity_
;
163 typedef struct _ffeexpr_stack_
*ffeexprStack_
;
165 /* Private include files. */
168 /* Internal structure definitions. */
170 struct _ffeexpr_expr_
172 ffeexprExpr_ previous
;
174 ffeexprExprtype_ type
;
180 ffeexprOperatorPrecedence_ prec
;
181 ffeexprOperatorAssociativity_ as
;
189 struct _ffeexpr_stack_
191 ffeexprStack_ previous
;
193 ffeexprContext context
;
194 ffeexprCallback callback
;
195 ffelexToken first_token
;
196 ffeexprExpr_ exprstack
;
197 ffelexToken tokens
[10]; /* Used in certain cases, like (unary)
199 ffebld expr
; /* For first of
200 complex/implied-do/substring/array-elements
201 / actual-args expression. */
202 ffebld bound_list
; /* For tracking dimension bounds list of
204 ffebldListBottom bottom
; /* For building lists. */
205 ffeinfoRank rank
; /* For elements in an array reference. */
206 bool constant
; /* TRUE while elements seen so far are
208 bool immediate
; /* TRUE while elements seen so far are
209 immediate/constants. */
210 ffebld next_dummy
; /* Next SFUNC dummy arg in arg list. */
211 ffebldListLength num_args
; /* Number of dummy args expected in arg list. */
212 bool is_rhs
; /* TRUE if rhs context, FALSE otherwise. */
213 ffeexprPercent_ percent
; /* Current %FOO keyword. */
216 struct _ffeexpr_find_
223 /* Static objects accessed by functions in this module. */
225 static ffeexprStack_ ffeexpr_stack_
; /* Expression stack for semantic. */
226 static ffelexToken ffeexpr_tokens_
[10]; /* Scratchpad tokens for syntactic. */
227 static ffestrOther ffeexpr_current_dotdot_
; /* Current .FOO. keyword. */
228 static long ffeexpr_hollerith_count_
; /* ffeexpr_token_number_ and caller. */
229 static int ffeexpr_level_
; /* Level of DATA implied-DO construct. */
230 static bool ffeexpr_is_substr_ok_
; /* If OPEN_PAREN as binary "op" ok. */
231 static struct _ffeexpr_find_ ffeexpr_find_
;
233 /* Static functions (internal). */
235 static ffelexHandler
ffeexpr_cb_close_paren_ (ffelexToken ft
, ffebld expr
,
237 static ffelexHandler
ffeexpr_cb_close_paren_ambig_ (ffelexToken ft
,
240 static ffelexHandler
ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t
);
241 static ffelexHandler
ffeexpr_cb_close_paren_c_ (ffelexToken ft
,
242 ffebld expr
, ffelexToken t
);
243 static ffelexHandler
ffeexpr_cb_comma_c_ (ffelexToken ft
, ffebld expr
,
245 static ffelexHandler
ffeexpr_cb_close_paren_ci_ (ffelexToken ft
,
246 ffebld expr
, ffelexToken t
);
247 static ffelexHandler
ffeexpr_cb_comma_ci_ (ffelexToken ft
, ffebld expr
,
249 static ffelexHandler
ffeexpr_cb_comma_i_ (ffelexToken ft
, ffebld expr
,
251 static ffelexHandler
ffeexpr_cb_comma_i_1_ (ffelexToken ft
, ffebld expr
,
253 static ffelexHandler
ffeexpr_cb_comma_i_2_ (ffelexToken ft
, ffebld expr
,
255 static ffelexHandler
ffeexpr_cb_comma_i_3_ (ffelexToken ft
, ffebld expr
,
257 static ffelexHandler
ffeexpr_cb_comma_i_4_ (ffelexToken ft
, ffebld expr
,
259 static ffelexHandler
ffeexpr_cb_comma_i_5_ (ffelexToken t
);
260 static ffelexHandler
ffeexpr_cb_end_loc_ (ffelexToken ft
, ffebld expr
,
262 static ffelexHandler
ffeexpr_cb_end_notloc_ (ffelexToken ft
, ffebld expr
,
264 static ffelexHandler
ffeexpr_cb_end_notloc_1_ (ffelexToken t
);
265 static ffesymbol
ffeexpr_check_impctrl_ (ffesymbol s
);
266 static void ffeexpr_check_impdo_ (ffebld list
, ffelexToken list_t
,
267 ffebld dovar
, ffelexToken dovar_t
);
268 static void ffeexpr_update_impdo_ (ffebld expr
, ffebld dovar
);
269 static void ffeexpr_update_impdo_sym_ (ffebld expr
, ffesymbol dovar
);
270 static ffeexprContext
ffeexpr_context_outer_ (ffeexprStack_ s
);
271 static ffeexprExpr_
ffeexpr_expr_new_ (void);
272 static void ffeexpr_fulfill_call_ (ffebld
*expr
, ffelexToken t
);
273 static bool ffeexpr_isdigits_ (const char *p
);
274 static ffelexHandler
ffeexpr_token_first_lhs_ (ffelexToken t
);
275 static ffelexHandler
ffeexpr_token_first_lhs_1_ (ffelexToken t
);
276 static ffelexHandler
ffeexpr_token_first_rhs_ (ffelexToken t
);
277 static ffelexHandler
ffeexpr_token_first_rhs_1_ (ffelexToken t
);
278 static ffelexHandler
ffeexpr_token_first_rhs_2_ (ffelexToken t
);
279 static ffelexHandler
ffeexpr_token_first_rhs_3_ (ffelexToken t
);
280 static ffelexHandler
ffeexpr_token_first_rhs_4_ (ffelexToken t
);
281 static ffelexHandler
ffeexpr_token_first_rhs_5_ (ffelexToken t
);
282 static ffelexHandler
ffeexpr_token_first_rhs_6_ (ffelexToken t
);
283 static ffelexHandler
ffeexpr_token_namelist_ (ffelexToken t
);
284 static void ffeexpr_expr_kill_ (ffeexprExpr_ e
);
285 static void ffeexpr_exprstack_push_ (ffeexprExpr_ e
);
286 static void ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e
);
287 static void ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e
);
288 static void ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e
);
289 static void ffeexpr_reduce_ (void);
290 static ffebld
ffeexpr_reduced_bool1_ (ffebld reduced
, ffeexprExpr_ op
,
292 static ffebld
ffeexpr_reduced_bool2_ (ffebld reduced
, ffeexprExpr_ l
,
293 ffeexprExpr_ op
, ffeexprExpr_ r
);
294 static ffebld
ffeexpr_reduced_concatenate_ (ffebld reduced
, ffeexprExpr_ l
,
295 ffeexprExpr_ op
, ffeexprExpr_ r
);
296 static ffebld
ffeexpr_reduced_eqop2_ (ffebld reduced
, ffeexprExpr_ l
,
297 ffeexprExpr_ op
, ffeexprExpr_ r
);
298 static ffebld
ffeexpr_reduced_math1_ (ffebld reduced
, ffeexprExpr_ op
,
300 static ffebld
ffeexpr_reduced_math2_ (ffebld reduced
, ffeexprExpr_ l
,
301 ffeexprExpr_ op
, ffeexprExpr_ r
);
302 static ffebld
ffeexpr_reduced_power_ (ffebld reduced
, ffeexprExpr_ l
,
303 ffeexprExpr_ op
, ffeexprExpr_ r
);
304 static ffebld
ffeexpr_reduced_relop2_ (ffebld reduced
, ffeexprExpr_ l
,
305 ffeexprExpr_ op
, ffeexprExpr_ r
);
306 static ffebld
ffeexpr_reduced_ugly1_ (ffebld reduced
, ffeexprExpr_ op
, ffeexprExpr_ r
);
307 static ffebld
ffeexpr_reduced_ugly1log_ (ffebld reduced
, ffeexprExpr_ op
,
309 static ffebld
ffeexpr_reduced_ugly2_ (ffebld reduced
, ffeexprExpr_ l
,
310 ffeexprExpr_ op
, ffeexprExpr_ r
);
311 static ffebld
ffeexpr_reduced_ugly2log_ (ffebld reduced
, ffeexprExpr_ l
,
312 ffeexprExpr_ op
, ffeexprExpr_ r
,
314 static ffelexHandler
ffeexpr_find_close_paren_ (ffelexToken t
,
315 ffelexHandler after
);
316 static ffelexHandler
ffeexpr_nil_finished_ (ffelexToken t
);
317 static ffelexHandler
ffeexpr_nil_rhs_ (ffelexToken t
);
318 static ffelexHandler
ffeexpr_nil_period_ (ffelexToken t
);
319 static ffelexHandler
ffeexpr_nil_end_period_ (ffelexToken t
);
320 static ffelexHandler
ffeexpr_nil_swallow_period_ (ffelexToken t
);
321 static ffelexHandler
ffeexpr_nil_real_ (ffelexToken t
);
322 static ffelexHandler
ffeexpr_nil_real_exponent_ (ffelexToken t
);
323 static ffelexHandler
ffeexpr_nil_real_exp_sign_ (ffelexToken t
);
324 static ffelexHandler
ffeexpr_nil_number_ (ffelexToken t
);
325 static ffelexHandler
ffeexpr_nil_number_exponent_ (ffelexToken t
);
326 static ffelexHandler
ffeexpr_nil_number_exp_sign_ (ffelexToken t
);
327 static ffelexHandler
ffeexpr_nil_number_period_ (ffelexToken t
);
328 static ffelexHandler
ffeexpr_nil_number_per_exp_ (ffelexToken t
);
329 static ffelexHandler
ffeexpr_nil_number_real_ (ffelexToken t
);
330 static ffelexHandler
ffeexpr_nil_num_per_exp_sign_ (ffelexToken t
);
331 static ffelexHandler
ffeexpr_nil_number_real_exp_ (ffelexToken t
);
332 static ffelexHandler
ffeexpr_nil_num_real_exp_sn_ (ffelexToken t
);
333 static ffelexHandler
ffeexpr_nil_binary_ (ffelexToken t
);
334 static ffelexHandler
ffeexpr_nil_binary_period_ (ffelexToken t
);
335 static ffelexHandler
ffeexpr_nil_binary_end_per_ (ffelexToken t
);
336 static ffelexHandler
ffeexpr_nil_binary_sw_per_ (ffelexToken t
);
337 static ffelexHandler
ffeexpr_nil_quote_ (ffelexToken t
);
338 static ffelexHandler
ffeexpr_nil_apostrophe_ (ffelexToken t
);
339 static ffelexHandler
ffeexpr_nil_apos_char_ (ffelexToken t
);
340 static ffelexHandler
ffeexpr_nil_name_rhs_ (ffelexToken t
);
341 static ffelexHandler
ffeexpr_nil_name_apos_ (ffelexToken t
);
342 static ffelexHandler
ffeexpr_nil_name_apos_name_ (ffelexToken t
);
343 static ffelexHandler
ffeexpr_nil_percent_ (ffelexToken t
);
344 static ffelexHandler
ffeexpr_nil_percent_name_ (ffelexToken t
);
345 static ffelexHandler
ffeexpr_nil_substrp_ (ffelexToken t
);
346 static ffelexHandler
ffeexpr_finished_ (ffelexToken t
);
347 static ffebld
ffeexpr_finished_ambig_ (ffelexToken t
, ffebld expr
);
348 static ffelexHandler
ffeexpr_token_lhs_ (ffelexToken t
);
349 static ffelexHandler
ffeexpr_token_rhs_ (ffelexToken t
);
350 static ffelexHandler
ffeexpr_token_binary_ (ffelexToken t
);
351 static ffelexHandler
ffeexpr_token_period_ (ffelexToken t
);
352 static ffelexHandler
ffeexpr_token_end_period_ (ffelexToken t
);
353 static ffelexHandler
ffeexpr_token_swallow_period_ (ffelexToken t
);
354 static ffelexHandler
ffeexpr_token_real_ (ffelexToken t
);
355 static ffelexHandler
ffeexpr_token_real_exponent_ (ffelexToken t
);
356 static ffelexHandler
ffeexpr_token_real_exp_sign_ (ffelexToken t
);
357 static ffelexHandler
ffeexpr_token_number_ (ffelexToken t
);
358 static ffelexHandler
ffeexpr_token_number_exponent_ (ffelexToken t
);
359 static ffelexHandler
ffeexpr_token_number_exp_sign_ (ffelexToken t
);
360 static ffelexHandler
ffeexpr_token_number_period_ (ffelexToken t
);
361 static ffelexHandler
ffeexpr_token_number_per_exp_ (ffelexToken t
);
362 static ffelexHandler
ffeexpr_token_number_real_ (ffelexToken t
);
363 static ffelexHandler
ffeexpr_token_num_per_exp_sign_ (ffelexToken t
);
364 static ffelexHandler
ffeexpr_token_number_real_exp_ (ffelexToken t
);
365 static ffelexHandler
ffeexpr_token_num_real_exp_sn_ (ffelexToken t
);
366 static ffelexHandler
ffeexpr_token_binary_period_ (ffelexToken t
);
367 static ffelexHandler
ffeexpr_token_binary_end_per_ (ffelexToken t
);
368 static ffelexHandler
ffeexpr_token_binary_sw_per_ (ffelexToken t
);
369 static ffelexHandler
ffeexpr_token_quote_ (ffelexToken t
);
370 static ffelexHandler
ffeexpr_token_apostrophe_ (ffelexToken t
);
371 static ffelexHandler
ffeexpr_token_apos_char_ (ffelexToken t
);
372 static ffelexHandler
ffeexpr_token_name_lhs_ (ffelexToken t
);
373 static ffelexHandler
ffeexpr_token_name_arg_ (ffelexToken t
);
374 static ffelexHandler
ffeexpr_token_name_rhs_ (ffelexToken t
);
375 static ffelexHandler
ffeexpr_token_name_apos_ (ffelexToken t
);
376 static ffelexHandler
ffeexpr_token_name_apos_name_ (ffelexToken t
);
377 static ffelexHandler
ffeexpr_token_percent_ (ffelexToken t
);
378 static ffelexHandler
ffeexpr_token_percent_name_ (ffelexToken t
);
379 static ffelexHandler
ffeexpr_token_arguments_ (ffelexToken ft
, ffebld expr
,
381 static ffelexHandler
ffeexpr_token_elements_ (ffelexToken ft
, ffebld expr
,
383 static ffelexHandler
ffeexpr_token_equivalence_ (ffelexToken ft
, ffebld expr
,
385 static ffelexHandler
ffeexpr_token_substring_ (ffelexToken ft
, ffebld expr
,
387 static ffelexHandler
ffeexpr_token_substring_1_ (ffelexToken ft
, ffebld expr
,
389 static ffelexHandler
ffeexpr_token_substrp_ (ffelexToken t
);
390 static ffelexHandler
ffeexpr_token_intrincheck_ (ffelexToken t
);
391 static ffelexHandler
ffeexpr_token_funsubstr_ (ffelexToken ft
, ffebld expr
,
393 static ffelexHandler
ffeexpr_token_anything_ (ffelexToken ft
, ffebld expr
,
395 static void ffeexpr_make_float_const_ (char exp_letter
, ffelexToken integer
,
396 ffelexToken decimal
, ffelexToken fraction
, ffelexToken exponent
,
397 ffelexToken exponent_sign
, ffelexToken exponent_digits
);
398 static ffesymbol
ffeexpr_declare_unadorned_ (ffelexToken t
, bool maybe_intrin
);
399 static ffesymbol
ffeexpr_sym_impdoitem_ (ffesymbol s
, ffelexToken t
);
400 static ffesymbol
ffeexpr_sym_lhs_call_ (ffesymbol s
, ffelexToken t
);
401 static ffesymbol
ffeexpr_sym_lhs_data_ (ffesymbol s
, ffelexToken t
);
402 static ffesymbol
ffeexpr_sym_lhs_equivalence_ (ffesymbol s
, ffelexToken t
);
403 static ffesymbol
ffeexpr_sym_lhs_extfunc_ (ffesymbol s
, ffelexToken t
);
404 static ffesymbol
ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s
, ffelexToken t
);
405 static ffesymbol
ffeexpr_sym_lhs_parameter_ (ffesymbol s
, ffelexToken t
);
406 static ffesymbol
ffeexpr_sym_rhs_actualarg_ (ffesymbol s
, ffelexToken t
);
407 static ffesymbol
ffeexpr_sym_rhs_dimlist_ (ffesymbol s
, ffelexToken t
);
408 static ffesymbol
ffeexpr_sym_rhs_let_ (ffesymbol s
, ffelexToken t
);
409 static ffesymbol
ffeexpr_declare_parenthesized_ (ffelexToken t
,
411 ffeexprParenType_
*paren_type
);
412 static ffesymbol
ffeexpr_paren_rhs_let_ (ffesymbol s
, ffelexToken t
);
414 /* Internal macros. */
416 #define ffeexpr_paren_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
417 #define ffeexpr_sym_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
419 /* ffeexpr_collapse_convert -- Collapse convert expr
423 expr = ffeexpr_collapse_convert(expr,token);
425 If the result of the expr is a constant, replaces the expr with the
426 computed constant. */
429 ffeexpr_collapse_convert (ffebld expr
, ffelexToken t
)
431 ffebad error
= FFEBAD
;
433 ffebldConstantUnion u
;
436 ffetargetCharacterSize sz
;
437 ffetargetCharacterSize sz2
;
439 if (ffeinfo_where (ffebld_info (expr
)) != FFEINFO_whereCONSTANT
)
442 l
= ffebld_left (expr
);
444 if (ffebld_op (l
) != FFEBLD_opCONTER
)
447 switch (bt
= ffeinfo_basictype (ffebld_info (expr
)))
449 case FFEINFO_basictypeANY
:
452 case FFEINFO_basictypeINTEGER
:
453 sz
= FFETARGET_charactersizeNONE
;
454 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
456 #if FFETARGET_okINTEGER1
457 case FFEINFO_kindtypeINTEGER1
:
458 switch (ffeinfo_basictype (ffebld_info (l
)))
460 case FFEINFO_basictypeINTEGER
:
461 switch (ffeinfo_kindtype (ffebld_info (l
)))
463 #if FFETARGET_okINTEGER2
464 case FFEINFO_kindtypeINTEGER2
:
465 error
= ffetarget_convert_integer1_integer2
466 (ffebld_cu_ptr_integer1 (u
),
467 ffebld_constant_integer2 (ffebld_conter (l
)));
471 #if FFETARGET_okINTEGER3
472 case FFEINFO_kindtypeINTEGER3
:
473 error
= ffetarget_convert_integer1_integer3
474 (ffebld_cu_ptr_integer1 (u
),
475 ffebld_constant_integer3 (ffebld_conter (l
)));
479 #if FFETARGET_okINTEGER4
480 case FFEINFO_kindtypeINTEGER4
:
481 error
= ffetarget_convert_integer1_integer4
482 (ffebld_cu_ptr_integer1 (u
),
483 ffebld_constant_integer4 (ffebld_conter (l
)));
488 assert ("INTEGER1/INTEGER bad source kind type" == NULL
);
493 case FFEINFO_basictypeREAL
:
494 switch (ffeinfo_kindtype (ffebld_info (l
)))
496 #if FFETARGET_okREAL1
497 case FFEINFO_kindtypeREAL1
:
498 error
= ffetarget_convert_integer1_real1
499 (ffebld_cu_ptr_integer1 (u
),
500 ffebld_constant_real1 (ffebld_conter (l
)));
504 #if FFETARGET_okREAL2
505 case FFEINFO_kindtypeREAL2
:
506 error
= ffetarget_convert_integer1_real2
507 (ffebld_cu_ptr_integer1 (u
),
508 ffebld_constant_real2 (ffebld_conter (l
)));
512 #if FFETARGET_okREAL3
513 case FFEINFO_kindtypeREAL3
:
514 error
= ffetarget_convert_integer1_real3
515 (ffebld_cu_ptr_integer1 (u
),
516 ffebld_constant_real3 (ffebld_conter (l
)));
521 assert ("INTEGER1/REAL bad source kind type" == NULL
);
526 case FFEINFO_basictypeCOMPLEX
:
527 switch (ffeinfo_kindtype (ffebld_info (l
)))
529 #if FFETARGET_okCOMPLEX1
530 case FFEINFO_kindtypeREAL1
:
531 error
= ffetarget_convert_integer1_complex1
532 (ffebld_cu_ptr_integer1 (u
),
533 ffebld_constant_complex1 (ffebld_conter (l
)));
537 #if FFETARGET_okCOMPLEX2
538 case FFEINFO_kindtypeREAL2
:
539 error
= ffetarget_convert_integer1_complex2
540 (ffebld_cu_ptr_integer1 (u
),
541 ffebld_constant_complex2 (ffebld_conter (l
)));
545 #if FFETARGET_okCOMPLEX3
546 case FFEINFO_kindtypeREAL3
:
547 error
= ffetarget_convert_integer1_complex3
548 (ffebld_cu_ptr_integer1 (u
),
549 ffebld_constant_complex3 (ffebld_conter (l
)));
554 assert ("INTEGER1/COMPLEX bad source kind type" == NULL
);
559 case FFEINFO_basictypeLOGICAL
:
560 switch (ffeinfo_kindtype (ffebld_info (l
)))
562 #if FFETARGET_okLOGICAL1
563 case FFEINFO_kindtypeLOGICAL1
:
564 error
= ffetarget_convert_integer1_logical1
565 (ffebld_cu_ptr_integer1 (u
),
566 ffebld_constant_logical1 (ffebld_conter (l
)));
570 #if FFETARGET_okLOGICAL2
571 case FFEINFO_kindtypeLOGICAL2
:
572 error
= ffetarget_convert_integer1_logical2
573 (ffebld_cu_ptr_integer1 (u
),
574 ffebld_constant_logical2 (ffebld_conter (l
)));
578 #if FFETARGET_okLOGICAL3
579 case FFEINFO_kindtypeLOGICAL3
:
580 error
= ffetarget_convert_integer1_logical3
581 (ffebld_cu_ptr_integer1 (u
),
582 ffebld_constant_logical3 (ffebld_conter (l
)));
586 #if FFETARGET_okLOGICAL4
587 case FFEINFO_kindtypeLOGICAL4
:
588 error
= ffetarget_convert_integer1_logical4
589 (ffebld_cu_ptr_integer1 (u
),
590 ffebld_constant_logical4 (ffebld_conter (l
)));
595 assert ("INTEGER1/LOGICAL bad source kind type" == NULL
);
600 case FFEINFO_basictypeCHARACTER
:
601 error
= ffetarget_convert_integer1_character1
602 (ffebld_cu_ptr_integer1 (u
),
603 ffebld_constant_character1 (ffebld_conter (l
)));
606 case FFEINFO_basictypeHOLLERITH
:
607 error
= ffetarget_convert_integer1_hollerith
608 (ffebld_cu_ptr_integer1 (u
),
609 ffebld_constant_hollerith (ffebld_conter (l
)));
612 case FFEINFO_basictypeTYPELESS
:
613 error
= ffetarget_convert_integer1_typeless
614 (ffebld_cu_ptr_integer1 (u
),
615 ffebld_constant_typeless (ffebld_conter (l
)));
619 assert ("INTEGER1 bad type" == NULL
);
623 /* If conversion operation is not implemented, return original expr. */
624 if (error
== FFEBAD_NOCANDO
)
627 expr
= ffebld_new_conter_with_orig
628 (ffebld_constant_new_integer1_val
629 (ffebld_cu_val_integer1 (u
)), expr
);
633 #if FFETARGET_okINTEGER2
634 case FFEINFO_kindtypeINTEGER2
:
635 switch (ffeinfo_basictype (ffebld_info (l
)))
637 case FFEINFO_basictypeINTEGER
:
638 switch (ffeinfo_kindtype (ffebld_info (l
)))
640 #if FFETARGET_okINTEGER1
641 case FFEINFO_kindtypeINTEGER1
:
642 error
= ffetarget_convert_integer2_integer1
643 (ffebld_cu_ptr_integer2 (u
),
644 ffebld_constant_integer1 (ffebld_conter (l
)));
648 #if FFETARGET_okINTEGER3
649 case FFEINFO_kindtypeINTEGER3
:
650 error
= ffetarget_convert_integer2_integer3
651 (ffebld_cu_ptr_integer2 (u
),
652 ffebld_constant_integer3 (ffebld_conter (l
)));
656 #if FFETARGET_okINTEGER4
657 case FFEINFO_kindtypeINTEGER4
:
658 error
= ffetarget_convert_integer2_integer4
659 (ffebld_cu_ptr_integer2 (u
),
660 ffebld_constant_integer4 (ffebld_conter (l
)));
665 assert ("INTEGER2/INTEGER bad source kind type" == NULL
);
670 case FFEINFO_basictypeREAL
:
671 switch (ffeinfo_kindtype (ffebld_info (l
)))
673 #if FFETARGET_okREAL1
674 case FFEINFO_kindtypeREAL1
:
675 error
= ffetarget_convert_integer2_real1
676 (ffebld_cu_ptr_integer2 (u
),
677 ffebld_constant_real1 (ffebld_conter (l
)));
681 #if FFETARGET_okREAL2
682 case FFEINFO_kindtypeREAL2
:
683 error
= ffetarget_convert_integer2_real2
684 (ffebld_cu_ptr_integer2 (u
),
685 ffebld_constant_real2 (ffebld_conter (l
)));
689 #if FFETARGET_okREAL3
690 case FFEINFO_kindtypeREAL3
:
691 error
= ffetarget_convert_integer2_real3
692 (ffebld_cu_ptr_integer2 (u
),
693 ffebld_constant_real3 (ffebld_conter (l
)));
698 assert ("INTEGER2/REAL bad source kind type" == NULL
);
703 case FFEINFO_basictypeCOMPLEX
:
704 switch (ffeinfo_kindtype (ffebld_info (l
)))
706 #if FFETARGET_okCOMPLEX1
707 case FFEINFO_kindtypeREAL1
:
708 error
= ffetarget_convert_integer2_complex1
709 (ffebld_cu_ptr_integer2 (u
),
710 ffebld_constant_complex1 (ffebld_conter (l
)));
714 #if FFETARGET_okCOMPLEX2
715 case FFEINFO_kindtypeREAL2
:
716 error
= ffetarget_convert_integer2_complex2
717 (ffebld_cu_ptr_integer2 (u
),
718 ffebld_constant_complex2 (ffebld_conter (l
)));
722 #if FFETARGET_okCOMPLEX3
723 case FFEINFO_kindtypeREAL3
:
724 error
= ffetarget_convert_integer2_complex3
725 (ffebld_cu_ptr_integer2 (u
),
726 ffebld_constant_complex3 (ffebld_conter (l
)));
731 assert ("INTEGER2/COMPLEX bad source kind type" == NULL
);
736 case FFEINFO_basictypeLOGICAL
:
737 switch (ffeinfo_kindtype (ffebld_info (l
)))
739 #if FFETARGET_okLOGICAL1
740 case FFEINFO_kindtypeLOGICAL1
:
741 error
= ffetarget_convert_integer2_logical1
742 (ffebld_cu_ptr_integer2 (u
),
743 ffebld_constant_logical1 (ffebld_conter (l
)));
747 #if FFETARGET_okLOGICAL2
748 case FFEINFO_kindtypeLOGICAL2
:
749 error
= ffetarget_convert_integer2_logical2
750 (ffebld_cu_ptr_integer2 (u
),
751 ffebld_constant_logical2 (ffebld_conter (l
)));
755 #if FFETARGET_okLOGICAL3
756 case FFEINFO_kindtypeLOGICAL3
:
757 error
= ffetarget_convert_integer2_logical3
758 (ffebld_cu_ptr_integer2 (u
),
759 ffebld_constant_logical3 (ffebld_conter (l
)));
763 #if FFETARGET_okLOGICAL4
764 case FFEINFO_kindtypeLOGICAL4
:
765 error
= ffetarget_convert_integer2_logical4
766 (ffebld_cu_ptr_integer2 (u
),
767 ffebld_constant_logical4 (ffebld_conter (l
)));
772 assert ("INTEGER2/LOGICAL bad source kind type" == NULL
);
777 case FFEINFO_basictypeCHARACTER
:
778 error
= ffetarget_convert_integer2_character1
779 (ffebld_cu_ptr_integer2 (u
),
780 ffebld_constant_character1 (ffebld_conter (l
)));
783 case FFEINFO_basictypeHOLLERITH
:
784 error
= ffetarget_convert_integer2_hollerith
785 (ffebld_cu_ptr_integer2 (u
),
786 ffebld_constant_hollerith (ffebld_conter (l
)));
789 case FFEINFO_basictypeTYPELESS
:
790 error
= ffetarget_convert_integer2_typeless
791 (ffebld_cu_ptr_integer2 (u
),
792 ffebld_constant_typeless (ffebld_conter (l
)));
796 assert ("INTEGER2 bad type" == NULL
);
800 /* If conversion operation is not implemented, return original expr. */
801 if (error
== FFEBAD_NOCANDO
)
804 expr
= ffebld_new_conter_with_orig
805 (ffebld_constant_new_integer2_val
806 (ffebld_cu_val_integer2 (u
)), expr
);
810 #if FFETARGET_okINTEGER3
811 case FFEINFO_kindtypeINTEGER3
:
812 switch (ffeinfo_basictype (ffebld_info (l
)))
814 case FFEINFO_basictypeINTEGER
:
815 switch (ffeinfo_kindtype (ffebld_info (l
)))
817 #if FFETARGET_okINTEGER1
818 case FFEINFO_kindtypeINTEGER1
:
819 error
= ffetarget_convert_integer3_integer1
820 (ffebld_cu_ptr_integer3 (u
),
821 ffebld_constant_integer1 (ffebld_conter (l
)));
825 #if FFETARGET_okINTEGER2
826 case FFEINFO_kindtypeINTEGER2
:
827 error
= ffetarget_convert_integer3_integer2
828 (ffebld_cu_ptr_integer3 (u
),
829 ffebld_constant_integer2 (ffebld_conter (l
)));
833 #if FFETARGET_okINTEGER4
834 case FFEINFO_kindtypeINTEGER4
:
835 error
= ffetarget_convert_integer3_integer4
836 (ffebld_cu_ptr_integer3 (u
),
837 ffebld_constant_integer4 (ffebld_conter (l
)));
842 assert ("INTEGER3/INTEGER bad source kind type" == NULL
);
847 case FFEINFO_basictypeREAL
:
848 switch (ffeinfo_kindtype (ffebld_info (l
)))
850 #if FFETARGET_okREAL1
851 case FFEINFO_kindtypeREAL1
:
852 error
= ffetarget_convert_integer3_real1
853 (ffebld_cu_ptr_integer3 (u
),
854 ffebld_constant_real1 (ffebld_conter (l
)));
858 #if FFETARGET_okREAL2
859 case FFEINFO_kindtypeREAL2
:
860 error
= ffetarget_convert_integer3_real2
861 (ffebld_cu_ptr_integer3 (u
),
862 ffebld_constant_real2 (ffebld_conter (l
)));
866 #if FFETARGET_okREAL3
867 case FFEINFO_kindtypeREAL3
:
868 error
= ffetarget_convert_integer3_real3
869 (ffebld_cu_ptr_integer3 (u
),
870 ffebld_constant_real3 (ffebld_conter (l
)));
875 assert ("INTEGER3/REAL bad source kind type" == NULL
);
880 case FFEINFO_basictypeCOMPLEX
:
881 switch (ffeinfo_kindtype (ffebld_info (l
)))
883 #if FFETARGET_okCOMPLEX1
884 case FFEINFO_kindtypeREAL1
:
885 error
= ffetarget_convert_integer3_complex1
886 (ffebld_cu_ptr_integer3 (u
),
887 ffebld_constant_complex1 (ffebld_conter (l
)));
891 #if FFETARGET_okCOMPLEX2
892 case FFEINFO_kindtypeREAL2
:
893 error
= ffetarget_convert_integer3_complex2
894 (ffebld_cu_ptr_integer3 (u
),
895 ffebld_constant_complex2 (ffebld_conter (l
)));
899 #if FFETARGET_okCOMPLEX3
900 case FFEINFO_kindtypeREAL3
:
901 error
= ffetarget_convert_integer3_complex3
902 (ffebld_cu_ptr_integer3 (u
),
903 ffebld_constant_complex3 (ffebld_conter (l
)));
908 assert ("INTEGER3/COMPLEX bad source kind type" == NULL
);
913 case FFEINFO_basictypeLOGICAL
:
914 switch (ffeinfo_kindtype (ffebld_info (l
)))
916 #if FFETARGET_okLOGICAL1
917 case FFEINFO_kindtypeLOGICAL1
:
918 error
= ffetarget_convert_integer3_logical1
919 (ffebld_cu_ptr_integer3 (u
),
920 ffebld_constant_logical1 (ffebld_conter (l
)));
924 #if FFETARGET_okLOGICAL2
925 case FFEINFO_kindtypeLOGICAL2
:
926 error
= ffetarget_convert_integer3_logical2
927 (ffebld_cu_ptr_integer3 (u
),
928 ffebld_constant_logical2 (ffebld_conter (l
)));
932 #if FFETARGET_okLOGICAL3
933 case FFEINFO_kindtypeLOGICAL3
:
934 error
= ffetarget_convert_integer3_logical3
935 (ffebld_cu_ptr_integer3 (u
),
936 ffebld_constant_logical3 (ffebld_conter (l
)));
940 #if FFETARGET_okLOGICAL4
941 case FFEINFO_kindtypeLOGICAL4
:
942 error
= ffetarget_convert_integer3_logical4
943 (ffebld_cu_ptr_integer3 (u
),
944 ffebld_constant_logical4 (ffebld_conter (l
)));
949 assert ("INTEGER3/LOGICAL bad source kind type" == NULL
);
954 case FFEINFO_basictypeCHARACTER
:
955 error
= ffetarget_convert_integer3_character1
956 (ffebld_cu_ptr_integer3 (u
),
957 ffebld_constant_character1 (ffebld_conter (l
)));
960 case FFEINFO_basictypeHOLLERITH
:
961 error
= ffetarget_convert_integer3_hollerith
962 (ffebld_cu_ptr_integer3 (u
),
963 ffebld_constant_hollerith (ffebld_conter (l
)));
966 case FFEINFO_basictypeTYPELESS
:
967 error
= ffetarget_convert_integer3_typeless
968 (ffebld_cu_ptr_integer3 (u
),
969 ffebld_constant_typeless (ffebld_conter (l
)));
973 assert ("INTEGER3 bad type" == NULL
);
977 /* If conversion operation is not implemented, return original expr. */
978 if (error
== FFEBAD_NOCANDO
)
981 expr
= ffebld_new_conter_with_orig
982 (ffebld_constant_new_integer3_val
983 (ffebld_cu_val_integer3 (u
)), expr
);
987 #if FFETARGET_okINTEGER4
988 case FFEINFO_kindtypeINTEGER4
:
989 switch (ffeinfo_basictype (ffebld_info (l
)))
991 case FFEINFO_basictypeINTEGER
:
992 switch (ffeinfo_kindtype (ffebld_info (l
)))
994 #if FFETARGET_okINTEGER1
995 case FFEINFO_kindtypeINTEGER1
:
996 error
= ffetarget_convert_integer4_integer1
997 (ffebld_cu_ptr_integer4 (u
),
998 ffebld_constant_integer1 (ffebld_conter (l
)));
1002 #if FFETARGET_okINTEGER2
1003 case FFEINFO_kindtypeINTEGER2
:
1004 error
= ffetarget_convert_integer4_integer2
1005 (ffebld_cu_ptr_integer4 (u
),
1006 ffebld_constant_integer2 (ffebld_conter (l
)));
1010 #if FFETARGET_okINTEGER3
1011 case FFEINFO_kindtypeINTEGER3
:
1012 error
= ffetarget_convert_integer4_integer3
1013 (ffebld_cu_ptr_integer4 (u
),
1014 ffebld_constant_integer3 (ffebld_conter (l
)));
1019 assert ("INTEGER4/INTEGER bad source kind type" == NULL
);
1024 case FFEINFO_basictypeREAL
:
1025 switch (ffeinfo_kindtype (ffebld_info (l
)))
1027 #if FFETARGET_okREAL1
1028 case FFEINFO_kindtypeREAL1
:
1029 error
= ffetarget_convert_integer4_real1
1030 (ffebld_cu_ptr_integer4 (u
),
1031 ffebld_constant_real1 (ffebld_conter (l
)));
1035 #if FFETARGET_okREAL2
1036 case FFEINFO_kindtypeREAL2
:
1037 error
= ffetarget_convert_integer4_real2
1038 (ffebld_cu_ptr_integer4 (u
),
1039 ffebld_constant_real2 (ffebld_conter (l
)));
1043 #if FFETARGET_okREAL3
1044 case FFEINFO_kindtypeREAL3
:
1045 error
= ffetarget_convert_integer4_real3
1046 (ffebld_cu_ptr_integer4 (u
),
1047 ffebld_constant_real3 (ffebld_conter (l
)));
1052 assert ("INTEGER4/REAL bad source kind type" == NULL
);
1057 case FFEINFO_basictypeCOMPLEX
:
1058 switch (ffeinfo_kindtype (ffebld_info (l
)))
1060 #if FFETARGET_okCOMPLEX1
1061 case FFEINFO_kindtypeREAL1
:
1062 error
= ffetarget_convert_integer4_complex1
1063 (ffebld_cu_ptr_integer4 (u
),
1064 ffebld_constant_complex1 (ffebld_conter (l
)));
1068 #if FFETARGET_okCOMPLEX2
1069 case FFEINFO_kindtypeREAL2
:
1070 error
= ffetarget_convert_integer4_complex2
1071 (ffebld_cu_ptr_integer4 (u
),
1072 ffebld_constant_complex2 (ffebld_conter (l
)));
1076 #if FFETARGET_okCOMPLEX3
1077 case FFEINFO_kindtypeREAL3
:
1078 error
= ffetarget_convert_integer4_complex3
1079 (ffebld_cu_ptr_integer4 (u
),
1080 ffebld_constant_complex3 (ffebld_conter (l
)));
1085 assert ("INTEGER3/COMPLEX bad source kind type" == NULL
);
1090 case FFEINFO_basictypeLOGICAL
:
1091 switch (ffeinfo_kindtype (ffebld_info (l
)))
1093 #if FFETARGET_okLOGICAL1
1094 case FFEINFO_kindtypeLOGICAL1
:
1095 error
= ffetarget_convert_integer4_logical1
1096 (ffebld_cu_ptr_integer4 (u
),
1097 ffebld_constant_logical1 (ffebld_conter (l
)));
1101 #if FFETARGET_okLOGICAL2
1102 case FFEINFO_kindtypeLOGICAL2
:
1103 error
= ffetarget_convert_integer4_logical2
1104 (ffebld_cu_ptr_integer4 (u
),
1105 ffebld_constant_logical2 (ffebld_conter (l
)));
1109 #if FFETARGET_okLOGICAL3
1110 case FFEINFO_kindtypeLOGICAL3
:
1111 error
= ffetarget_convert_integer4_logical3
1112 (ffebld_cu_ptr_integer4 (u
),
1113 ffebld_constant_logical3 (ffebld_conter (l
)));
1117 #if FFETARGET_okLOGICAL4
1118 case FFEINFO_kindtypeLOGICAL4
:
1119 error
= ffetarget_convert_integer4_logical4
1120 (ffebld_cu_ptr_integer4 (u
),
1121 ffebld_constant_logical4 (ffebld_conter (l
)));
1126 assert ("INTEGER4/LOGICAL bad source kind type" == NULL
);
1131 case FFEINFO_basictypeCHARACTER
:
1132 error
= ffetarget_convert_integer4_character1
1133 (ffebld_cu_ptr_integer4 (u
),
1134 ffebld_constant_character1 (ffebld_conter (l
)));
1137 case FFEINFO_basictypeHOLLERITH
:
1138 error
= ffetarget_convert_integer4_hollerith
1139 (ffebld_cu_ptr_integer4 (u
),
1140 ffebld_constant_hollerith (ffebld_conter (l
)));
1143 case FFEINFO_basictypeTYPELESS
:
1144 error
= ffetarget_convert_integer4_typeless
1145 (ffebld_cu_ptr_integer4 (u
),
1146 ffebld_constant_typeless (ffebld_conter (l
)));
1150 assert ("INTEGER4 bad type" == NULL
);
1154 /* If conversion operation is not implemented, return original expr. */
1155 if (error
== FFEBAD_NOCANDO
)
1158 expr
= ffebld_new_conter_with_orig
1159 (ffebld_constant_new_integer4_val
1160 (ffebld_cu_val_integer4 (u
)), expr
);
1165 assert ("bad integer kind type" == NULL
);
1170 case FFEINFO_basictypeLOGICAL
:
1171 sz
= FFETARGET_charactersizeNONE
;
1172 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
1174 #if FFETARGET_okLOGICAL1
1175 case FFEINFO_kindtypeLOGICAL1
:
1176 switch (ffeinfo_basictype (ffebld_info (l
)))
1178 case FFEINFO_basictypeLOGICAL
:
1179 switch (ffeinfo_kindtype (ffebld_info (l
)))
1181 #if FFETARGET_okLOGICAL2
1182 case FFEINFO_kindtypeLOGICAL2
:
1183 error
= ffetarget_convert_logical1_logical2
1184 (ffebld_cu_ptr_logical1 (u
),
1185 ffebld_constant_logical2 (ffebld_conter (l
)));
1189 #if FFETARGET_okLOGICAL3
1190 case FFEINFO_kindtypeLOGICAL3
:
1191 error
= ffetarget_convert_logical1_logical3
1192 (ffebld_cu_ptr_logical1 (u
),
1193 ffebld_constant_logical3 (ffebld_conter (l
)));
1197 #if FFETARGET_okLOGICAL4
1198 case FFEINFO_kindtypeLOGICAL4
:
1199 error
= ffetarget_convert_logical1_logical4
1200 (ffebld_cu_ptr_logical1 (u
),
1201 ffebld_constant_logical4 (ffebld_conter (l
)));
1206 assert ("LOGICAL1/LOGICAL bad source kind type" == NULL
);
1211 case FFEINFO_basictypeINTEGER
:
1212 switch (ffeinfo_kindtype (ffebld_info (l
)))
1214 #if FFETARGET_okINTEGER1
1215 case FFEINFO_kindtypeINTEGER1
:
1216 error
= ffetarget_convert_logical1_integer1
1217 (ffebld_cu_ptr_logical1 (u
),
1218 ffebld_constant_integer1 (ffebld_conter (l
)));
1222 #if FFETARGET_okINTEGER2
1223 case FFEINFO_kindtypeINTEGER2
:
1224 error
= ffetarget_convert_logical1_integer2
1225 (ffebld_cu_ptr_logical1 (u
),
1226 ffebld_constant_integer2 (ffebld_conter (l
)));
1230 #if FFETARGET_okINTEGER3
1231 case FFEINFO_kindtypeINTEGER3
:
1232 error
= ffetarget_convert_logical1_integer3
1233 (ffebld_cu_ptr_logical1 (u
),
1234 ffebld_constant_integer3 (ffebld_conter (l
)));
1238 #if FFETARGET_okINTEGER4
1239 case FFEINFO_kindtypeINTEGER4
:
1240 error
= ffetarget_convert_logical1_integer4
1241 (ffebld_cu_ptr_logical1 (u
),
1242 ffebld_constant_integer4 (ffebld_conter (l
)));
1247 assert ("LOGICAL1/INTEGER bad source kind type" == NULL
);
1252 case FFEINFO_basictypeCHARACTER
:
1253 error
= ffetarget_convert_logical1_character1
1254 (ffebld_cu_ptr_logical1 (u
),
1255 ffebld_constant_character1 (ffebld_conter (l
)));
1258 case FFEINFO_basictypeHOLLERITH
:
1259 error
= ffetarget_convert_logical1_hollerith
1260 (ffebld_cu_ptr_logical1 (u
),
1261 ffebld_constant_hollerith (ffebld_conter (l
)));
1264 case FFEINFO_basictypeTYPELESS
:
1265 error
= ffetarget_convert_logical1_typeless
1266 (ffebld_cu_ptr_logical1 (u
),
1267 ffebld_constant_typeless (ffebld_conter (l
)));
1271 assert ("LOGICAL1 bad type" == NULL
);
1275 /* If conversion operation is not implemented, return original expr. */
1276 if (error
== FFEBAD_NOCANDO
)
1279 expr
= ffebld_new_conter_with_orig
1280 (ffebld_constant_new_logical1_val
1281 (ffebld_cu_val_logical1 (u
)), expr
);
1285 #if FFETARGET_okLOGICAL2
1286 case FFEINFO_kindtypeLOGICAL2
:
1287 switch (ffeinfo_basictype (ffebld_info (l
)))
1289 case FFEINFO_basictypeLOGICAL
:
1290 switch (ffeinfo_kindtype (ffebld_info (l
)))
1292 #if FFETARGET_okLOGICAL1
1293 case FFEINFO_kindtypeLOGICAL1
:
1294 error
= ffetarget_convert_logical2_logical1
1295 (ffebld_cu_ptr_logical2 (u
),
1296 ffebld_constant_logical1 (ffebld_conter (l
)));
1300 #if FFETARGET_okLOGICAL3
1301 case FFEINFO_kindtypeLOGICAL3
:
1302 error
= ffetarget_convert_logical2_logical3
1303 (ffebld_cu_ptr_logical2 (u
),
1304 ffebld_constant_logical3 (ffebld_conter (l
)));
1308 #if FFETARGET_okLOGICAL4
1309 case FFEINFO_kindtypeLOGICAL4
:
1310 error
= ffetarget_convert_logical2_logical4
1311 (ffebld_cu_ptr_logical2 (u
),
1312 ffebld_constant_logical4 (ffebld_conter (l
)));
1317 assert ("LOGICAL2/LOGICAL bad source kind type" == NULL
);
1322 case FFEINFO_basictypeINTEGER
:
1323 switch (ffeinfo_kindtype (ffebld_info (l
)))
1325 #if FFETARGET_okINTEGER1
1326 case FFEINFO_kindtypeINTEGER1
:
1327 error
= ffetarget_convert_logical2_integer1
1328 (ffebld_cu_ptr_logical2 (u
),
1329 ffebld_constant_integer1 (ffebld_conter (l
)));
1333 #if FFETARGET_okINTEGER2
1334 case FFEINFO_kindtypeINTEGER2
:
1335 error
= ffetarget_convert_logical2_integer2
1336 (ffebld_cu_ptr_logical2 (u
),
1337 ffebld_constant_integer2 (ffebld_conter (l
)));
1341 #if FFETARGET_okINTEGER3
1342 case FFEINFO_kindtypeINTEGER3
:
1343 error
= ffetarget_convert_logical2_integer3
1344 (ffebld_cu_ptr_logical2 (u
),
1345 ffebld_constant_integer3 (ffebld_conter (l
)));
1349 #if FFETARGET_okINTEGER4
1350 case FFEINFO_kindtypeINTEGER4
:
1351 error
= ffetarget_convert_logical2_integer4
1352 (ffebld_cu_ptr_logical2 (u
),
1353 ffebld_constant_integer4 (ffebld_conter (l
)));
1358 assert ("LOGICAL2/INTEGER bad source kind type" == NULL
);
1363 case FFEINFO_basictypeCHARACTER
:
1364 error
= ffetarget_convert_logical2_character1
1365 (ffebld_cu_ptr_logical2 (u
),
1366 ffebld_constant_character1 (ffebld_conter (l
)));
1369 case FFEINFO_basictypeHOLLERITH
:
1370 error
= ffetarget_convert_logical2_hollerith
1371 (ffebld_cu_ptr_logical2 (u
),
1372 ffebld_constant_hollerith (ffebld_conter (l
)));
1375 case FFEINFO_basictypeTYPELESS
:
1376 error
= ffetarget_convert_logical2_typeless
1377 (ffebld_cu_ptr_logical2 (u
),
1378 ffebld_constant_typeless (ffebld_conter (l
)));
1382 assert ("LOGICAL2 bad type" == NULL
);
1386 /* If conversion operation is not implemented, return original expr. */
1387 if (error
== FFEBAD_NOCANDO
)
1390 expr
= ffebld_new_conter_with_orig
1391 (ffebld_constant_new_logical2_val
1392 (ffebld_cu_val_logical2 (u
)), expr
);
1396 #if FFETARGET_okLOGICAL3
1397 case FFEINFO_kindtypeLOGICAL3
:
1398 switch (ffeinfo_basictype (ffebld_info (l
)))
1400 case FFEINFO_basictypeLOGICAL
:
1401 switch (ffeinfo_kindtype (ffebld_info (l
)))
1403 #if FFETARGET_okLOGICAL1
1404 case FFEINFO_kindtypeLOGICAL1
:
1405 error
= ffetarget_convert_logical3_logical1
1406 (ffebld_cu_ptr_logical3 (u
),
1407 ffebld_constant_logical1 (ffebld_conter (l
)));
1411 #if FFETARGET_okLOGICAL2
1412 case FFEINFO_kindtypeLOGICAL2
:
1413 error
= ffetarget_convert_logical3_logical2
1414 (ffebld_cu_ptr_logical3 (u
),
1415 ffebld_constant_logical2 (ffebld_conter (l
)));
1419 #if FFETARGET_okLOGICAL4
1420 case FFEINFO_kindtypeLOGICAL4
:
1421 error
= ffetarget_convert_logical3_logical4
1422 (ffebld_cu_ptr_logical3 (u
),
1423 ffebld_constant_logical4 (ffebld_conter (l
)));
1428 assert ("LOGICAL3/LOGICAL bad source kind type" == NULL
);
1433 case FFEINFO_basictypeINTEGER
:
1434 switch (ffeinfo_kindtype (ffebld_info (l
)))
1436 #if FFETARGET_okINTEGER1
1437 case FFEINFO_kindtypeINTEGER1
:
1438 error
= ffetarget_convert_logical3_integer1
1439 (ffebld_cu_ptr_logical3 (u
),
1440 ffebld_constant_integer1 (ffebld_conter (l
)));
1444 #if FFETARGET_okINTEGER2
1445 case FFEINFO_kindtypeINTEGER2
:
1446 error
= ffetarget_convert_logical3_integer2
1447 (ffebld_cu_ptr_logical3 (u
),
1448 ffebld_constant_integer2 (ffebld_conter (l
)));
1452 #if FFETARGET_okINTEGER3
1453 case FFEINFO_kindtypeINTEGER3
:
1454 error
= ffetarget_convert_logical3_integer3
1455 (ffebld_cu_ptr_logical3 (u
),
1456 ffebld_constant_integer3 (ffebld_conter (l
)));
1460 #if FFETARGET_okINTEGER4
1461 case FFEINFO_kindtypeINTEGER4
:
1462 error
= ffetarget_convert_logical3_integer4
1463 (ffebld_cu_ptr_logical3 (u
),
1464 ffebld_constant_integer4 (ffebld_conter (l
)));
1469 assert ("LOGICAL3/INTEGER bad source kind type" == NULL
);
1474 case FFEINFO_basictypeCHARACTER
:
1475 error
= ffetarget_convert_logical3_character1
1476 (ffebld_cu_ptr_logical3 (u
),
1477 ffebld_constant_character1 (ffebld_conter (l
)));
1480 case FFEINFO_basictypeHOLLERITH
:
1481 error
= ffetarget_convert_logical3_hollerith
1482 (ffebld_cu_ptr_logical3 (u
),
1483 ffebld_constant_hollerith (ffebld_conter (l
)));
1486 case FFEINFO_basictypeTYPELESS
:
1487 error
= ffetarget_convert_logical3_typeless
1488 (ffebld_cu_ptr_logical3 (u
),
1489 ffebld_constant_typeless (ffebld_conter (l
)));
1493 assert ("LOGICAL3 bad type" == NULL
);
1497 /* If conversion operation is not implemented, return original expr. */
1498 if (error
== FFEBAD_NOCANDO
)
1501 expr
= ffebld_new_conter_with_orig
1502 (ffebld_constant_new_logical3_val
1503 (ffebld_cu_val_logical3 (u
)), expr
);
1507 #if FFETARGET_okLOGICAL4
1508 case FFEINFO_kindtypeLOGICAL4
:
1509 switch (ffeinfo_basictype (ffebld_info (l
)))
1511 case FFEINFO_basictypeLOGICAL
:
1512 switch (ffeinfo_kindtype (ffebld_info (l
)))
1514 #if FFETARGET_okLOGICAL1
1515 case FFEINFO_kindtypeLOGICAL1
:
1516 error
= ffetarget_convert_logical4_logical1
1517 (ffebld_cu_ptr_logical4 (u
),
1518 ffebld_constant_logical1 (ffebld_conter (l
)));
1522 #if FFETARGET_okLOGICAL2
1523 case FFEINFO_kindtypeLOGICAL2
:
1524 error
= ffetarget_convert_logical4_logical2
1525 (ffebld_cu_ptr_logical4 (u
),
1526 ffebld_constant_logical2 (ffebld_conter (l
)));
1530 #if FFETARGET_okLOGICAL3
1531 case FFEINFO_kindtypeLOGICAL3
:
1532 error
= ffetarget_convert_logical4_logical3
1533 (ffebld_cu_ptr_logical4 (u
),
1534 ffebld_constant_logical3 (ffebld_conter (l
)));
1539 assert ("LOGICAL4/LOGICAL bad source kind type" == NULL
);
1544 case FFEINFO_basictypeINTEGER
:
1545 switch (ffeinfo_kindtype (ffebld_info (l
)))
1547 #if FFETARGET_okINTEGER1
1548 case FFEINFO_kindtypeINTEGER1
:
1549 error
= ffetarget_convert_logical4_integer1
1550 (ffebld_cu_ptr_logical4 (u
),
1551 ffebld_constant_integer1 (ffebld_conter (l
)));
1555 #if FFETARGET_okINTEGER2
1556 case FFEINFO_kindtypeINTEGER2
:
1557 error
= ffetarget_convert_logical4_integer2
1558 (ffebld_cu_ptr_logical4 (u
),
1559 ffebld_constant_integer2 (ffebld_conter (l
)));
1563 #if FFETARGET_okINTEGER3
1564 case FFEINFO_kindtypeINTEGER3
:
1565 error
= ffetarget_convert_logical4_integer3
1566 (ffebld_cu_ptr_logical4 (u
),
1567 ffebld_constant_integer3 (ffebld_conter (l
)));
1571 #if FFETARGET_okINTEGER4
1572 case FFEINFO_kindtypeINTEGER4
:
1573 error
= ffetarget_convert_logical4_integer4
1574 (ffebld_cu_ptr_logical4 (u
),
1575 ffebld_constant_integer4 (ffebld_conter (l
)));
1580 assert ("LOGICAL4/INTEGER bad source kind type" == NULL
);
1585 case FFEINFO_basictypeCHARACTER
:
1586 error
= ffetarget_convert_logical4_character1
1587 (ffebld_cu_ptr_logical4 (u
),
1588 ffebld_constant_character1 (ffebld_conter (l
)));
1591 case FFEINFO_basictypeHOLLERITH
:
1592 error
= ffetarget_convert_logical4_hollerith
1593 (ffebld_cu_ptr_logical4 (u
),
1594 ffebld_constant_hollerith (ffebld_conter (l
)));
1597 case FFEINFO_basictypeTYPELESS
:
1598 error
= ffetarget_convert_logical4_typeless
1599 (ffebld_cu_ptr_logical4 (u
),
1600 ffebld_constant_typeless (ffebld_conter (l
)));
1604 assert ("LOGICAL4 bad type" == NULL
);
1608 /* If conversion operation is not implemented, return original expr. */
1609 if (error
== FFEBAD_NOCANDO
)
1612 expr
= ffebld_new_conter_with_orig
1613 (ffebld_constant_new_logical4_val
1614 (ffebld_cu_val_logical4 (u
)), expr
);
1619 assert ("bad logical kind type" == NULL
);
1624 case FFEINFO_basictypeREAL
:
1625 sz
= FFETARGET_charactersizeNONE
;
1626 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
1628 #if FFETARGET_okREAL1
1629 case FFEINFO_kindtypeREAL1
:
1630 switch (ffeinfo_basictype (ffebld_info (l
)))
1632 case FFEINFO_basictypeINTEGER
:
1633 switch (ffeinfo_kindtype (ffebld_info (l
)))
1635 #if FFETARGET_okINTEGER1
1636 case FFEINFO_kindtypeINTEGER1
:
1637 error
= ffetarget_convert_real1_integer1
1638 (ffebld_cu_ptr_real1 (u
),
1639 ffebld_constant_integer1 (ffebld_conter (l
)));
1643 #if FFETARGET_okINTEGER2
1644 case FFEINFO_kindtypeINTEGER2
:
1645 error
= ffetarget_convert_real1_integer2
1646 (ffebld_cu_ptr_real1 (u
),
1647 ffebld_constant_integer2 (ffebld_conter (l
)));
1651 #if FFETARGET_okINTEGER3
1652 case FFEINFO_kindtypeINTEGER3
:
1653 error
= ffetarget_convert_real1_integer3
1654 (ffebld_cu_ptr_real1 (u
),
1655 ffebld_constant_integer3 (ffebld_conter (l
)));
1659 #if FFETARGET_okINTEGER4
1660 case FFEINFO_kindtypeINTEGER4
:
1661 error
= ffetarget_convert_real1_integer4
1662 (ffebld_cu_ptr_real1 (u
),
1663 ffebld_constant_integer4 (ffebld_conter (l
)));
1668 assert ("REAL1/INTEGER bad source kind type" == NULL
);
1673 case FFEINFO_basictypeREAL
:
1674 switch (ffeinfo_kindtype (ffebld_info (l
)))
1676 #if FFETARGET_okREAL2
1677 case FFEINFO_kindtypeREAL2
:
1678 error
= ffetarget_convert_real1_real2
1679 (ffebld_cu_ptr_real1 (u
),
1680 ffebld_constant_real2 (ffebld_conter (l
)));
1684 #if FFETARGET_okREAL3
1685 case FFEINFO_kindtypeREAL3
:
1686 error
= ffetarget_convert_real1_real3
1687 (ffebld_cu_ptr_real1 (u
),
1688 ffebld_constant_real3 (ffebld_conter (l
)));
1693 assert ("REAL1/REAL bad source kind type" == NULL
);
1698 case FFEINFO_basictypeCOMPLEX
:
1699 switch (ffeinfo_kindtype (ffebld_info (l
)))
1701 #if FFETARGET_okCOMPLEX1
1702 case FFEINFO_kindtypeREAL1
:
1703 error
= ffetarget_convert_real1_complex1
1704 (ffebld_cu_ptr_real1 (u
),
1705 ffebld_constant_complex1 (ffebld_conter (l
)));
1709 #if FFETARGET_okCOMPLEX2
1710 case FFEINFO_kindtypeREAL2
:
1711 error
= ffetarget_convert_real1_complex2
1712 (ffebld_cu_ptr_real1 (u
),
1713 ffebld_constant_complex2 (ffebld_conter (l
)));
1717 #if FFETARGET_okCOMPLEX3
1718 case FFEINFO_kindtypeREAL3
:
1719 error
= ffetarget_convert_real1_complex3
1720 (ffebld_cu_ptr_real1 (u
),
1721 ffebld_constant_complex3 (ffebld_conter (l
)));
1726 assert ("REAL1/COMPLEX bad source kind type" == NULL
);
1731 case FFEINFO_basictypeCHARACTER
:
1732 error
= ffetarget_convert_real1_character1
1733 (ffebld_cu_ptr_real1 (u
),
1734 ffebld_constant_character1 (ffebld_conter (l
)));
1737 case FFEINFO_basictypeHOLLERITH
:
1738 error
= ffetarget_convert_real1_hollerith
1739 (ffebld_cu_ptr_real1 (u
),
1740 ffebld_constant_hollerith (ffebld_conter (l
)));
1743 case FFEINFO_basictypeTYPELESS
:
1744 error
= ffetarget_convert_real1_typeless
1745 (ffebld_cu_ptr_real1 (u
),
1746 ffebld_constant_typeless (ffebld_conter (l
)));
1750 assert ("REAL1 bad type" == NULL
);
1754 /* If conversion operation is not implemented, return original expr. */
1755 if (error
== FFEBAD_NOCANDO
)
1758 expr
= ffebld_new_conter_with_orig
1759 (ffebld_constant_new_real1_val
1760 (ffebld_cu_val_real1 (u
)), expr
);
1764 #if FFETARGET_okREAL2
1765 case FFEINFO_kindtypeREAL2
:
1766 switch (ffeinfo_basictype (ffebld_info (l
)))
1768 case FFEINFO_basictypeINTEGER
:
1769 switch (ffeinfo_kindtype (ffebld_info (l
)))
1771 #if FFETARGET_okINTEGER1
1772 case FFEINFO_kindtypeINTEGER1
:
1773 error
= ffetarget_convert_real2_integer1
1774 (ffebld_cu_ptr_real2 (u
),
1775 ffebld_constant_integer1 (ffebld_conter (l
)));
1779 #if FFETARGET_okINTEGER2
1780 case FFEINFO_kindtypeINTEGER2
:
1781 error
= ffetarget_convert_real2_integer2
1782 (ffebld_cu_ptr_real2 (u
),
1783 ffebld_constant_integer2 (ffebld_conter (l
)));
1787 #if FFETARGET_okINTEGER3
1788 case FFEINFO_kindtypeINTEGER3
:
1789 error
= ffetarget_convert_real2_integer3
1790 (ffebld_cu_ptr_real2 (u
),
1791 ffebld_constant_integer3 (ffebld_conter (l
)));
1795 #if FFETARGET_okINTEGER4
1796 case FFEINFO_kindtypeINTEGER4
:
1797 error
= ffetarget_convert_real2_integer4
1798 (ffebld_cu_ptr_real2 (u
),
1799 ffebld_constant_integer4 (ffebld_conter (l
)));
1804 assert ("REAL2/INTEGER bad source kind type" == NULL
);
1809 case FFEINFO_basictypeREAL
:
1810 switch (ffeinfo_kindtype (ffebld_info (l
)))
1812 #if FFETARGET_okREAL1
1813 case FFEINFO_kindtypeREAL1
:
1814 error
= ffetarget_convert_real2_real1
1815 (ffebld_cu_ptr_real2 (u
),
1816 ffebld_constant_real1 (ffebld_conter (l
)));
1820 #if FFETARGET_okREAL3
1821 case FFEINFO_kindtypeREAL3
:
1822 error
= ffetarget_convert_real2_real3
1823 (ffebld_cu_ptr_real2 (u
),
1824 ffebld_constant_real3 (ffebld_conter (l
)));
1829 assert ("REAL2/REAL bad source kind type" == NULL
);
1834 case FFEINFO_basictypeCOMPLEX
:
1835 switch (ffeinfo_kindtype (ffebld_info (l
)))
1837 #if FFETARGET_okCOMPLEX1
1838 case FFEINFO_kindtypeREAL1
:
1839 error
= ffetarget_convert_real2_complex1
1840 (ffebld_cu_ptr_real2 (u
),
1841 ffebld_constant_complex1 (ffebld_conter (l
)));
1845 #if FFETARGET_okCOMPLEX2
1846 case FFEINFO_kindtypeREAL2
:
1847 error
= ffetarget_convert_real2_complex2
1848 (ffebld_cu_ptr_real2 (u
),
1849 ffebld_constant_complex2 (ffebld_conter (l
)));
1853 #if FFETARGET_okCOMPLEX3
1854 case FFEINFO_kindtypeREAL3
:
1855 error
= ffetarget_convert_real2_complex3
1856 (ffebld_cu_ptr_real2 (u
),
1857 ffebld_constant_complex3 (ffebld_conter (l
)));
1862 assert ("REAL2/COMPLEX bad source kind type" == NULL
);
1867 case FFEINFO_basictypeCHARACTER
:
1868 error
= ffetarget_convert_real2_character1
1869 (ffebld_cu_ptr_real2 (u
),
1870 ffebld_constant_character1 (ffebld_conter (l
)));
1873 case FFEINFO_basictypeHOLLERITH
:
1874 error
= ffetarget_convert_real2_hollerith
1875 (ffebld_cu_ptr_real2 (u
),
1876 ffebld_constant_hollerith (ffebld_conter (l
)));
1879 case FFEINFO_basictypeTYPELESS
:
1880 error
= ffetarget_convert_real2_typeless
1881 (ffebld_cu_ptr_real2 (u
),
1882 ffebld_constant_typeless (ffebld_conter (l
)));
1886 assert ("REAL2 bad type" == NULL
);
1890 /* If conversion operation is not implemented, return original expr. */
1891 if (error
== FFEBAD_NOCANDO
)
1894 expr
= ffebld_new_conter_with_orig
1895 (ffebld_constant_new_real2_val
1896 (ffebld_cu_val_real2 (u
)), expr
);
1900 #if FFETARGET_okREAL3
1901 case FFEINFO_kindtypeREAL3
:
1902 switch (ffeinfo_basictype (ffebld_info (l
)))
1904 case FFEINFO_basictypeINTEGER
:
1905 switch (ffeinfo_kindtype (ffebld_info (l
)))
1907 #if FFETARGET_okINTEGER1
1908 case FFEINFO_kindtypeINTEGER1
:
1909 error
= ffetarget_convert_real3_integer1
1910 (ffebld_cu_ptr_real3 (u
),
1911 ffebld_constant_integer1 (ffebld_conter (l
)));
1915 #if FFETARGET_okINTEGER2
1916 case FFEINFO_kindtypeINTEGER2
:
1917 error
= ffetarget_convert_real3_integer2
1918 (ffebld_cu_ptr_real3 (u
),
1919 ffebld_constant_integer2 (ffebld_conter (l
)));
1923 #if FFETARGET_okINTEGER3
1924 case FFEINFO_kindtypeINTEGER3
:
1925 error
= ffetarget_convert_real3_integer3
1926 (ffebld_cu_ptr_real3 (u
),
1927 ffebld_constant_integer3 (ffebld_conter (l
)));
1931 #if FFETARGET_okINTEGER4
1932 case FFEINFO_kindtypeINTEGER4
:
1933 error
= ffetarget_convert_real3_integer4
1934 (ffebld_cu_ptr_real3 (u
),
1935 ffebld_constant_integer4 (ffebld_conter (l
)));
1940 assert ("REAL3/INTEGER bad source kind type" == NULL
);
1945 case FFEINFO_basictypeREAL
:
1946 switch (ffeinfo_kindtype (ffebld_info (l
)))
1948 #if FFETARGET_okREAL1
1949 case FFEINFO_kindtypeREAL1
:
1950 error
= ffetarget_convert_real3_real1
1951 (ffebld_cu_ptr_real3 (u
),
1952 ffebld_constant_real1 (ffebld_conter (l
)));
1956 #if FFETARGET_okREAL2
1957 case FFEINFO_kindtypeREAL2
:
1958 error
= ffetarget_convert_real3_real2
1959 (ffebld_cu_ptr_real3 (u
),
1960 ffebld_constant_real2 (ffebld_conter (l
)));
1965 assert ("REAL3/REAL bad source kind type" == NULL
);
1970 case FFEINFO_basictypeCOMPLEX
:
1971 switch (ffeinfo_kindtype (ffebld_info (l
)))
1973 #if FFETARGET_okCOMPLEX1
1974 case FFEINFO_kindtypeREAL1
:
1975 error
= ffetarget_convert_real3_complex1
1976 (ffebld_cu_ptr_real3 (u
),
1977 ffebld_constant_complex1 (ffebld_conter (l
)));
1981 #if FFETARGET_okCOMPLEX2
1982 case FFEINFO_kindtypeREAL2
:
1983 error
= ffetarget_convert_real3_complex2
1984 (ffebld_cu_ptr_real3 (u
),
1985 ffebld_constant_complex2 (ffebld_conter (l
)));
1989 #if FFETARGET_okCOMPLEX3
1990 case FFEINFO_kindtypeREAL3
:
1991 error
= ffetarget_convert_real3_complex3
1992 (ffebld_cu_ptr_real3 (u
),
1993 ffebld_constant_complex3 (ffebld_conter (l
)));
1998 assert ("REAL3/COMPLEX bad source kind type" == NULL
);
2003 case FFEINFO_basictypeCHARACTER
:
2004 error
= ffetarget_convert_real3_character1
2005 (ffebld_cu_ptr_real3 (u
),
2006 ffebld_constant_character1 (ffebld_conter (l
)));
2009 case FFEINFO_basictypeHOLLERITH
:
2010 error
= ffetarget_convert_real3_hollerith
2011 (ffebld_cu_ptr_real3 (u
),
2012 ffebld_constant_hollerith (ffebld_conter (l
)));
2015 case FFEINFO_basictypeTYPELESS
:
2016 error
= ffetarget_convert_real3_typeless
2017 (ffebld_cu_ptr_real3 (u
),
2018 ffebld_constant_typeless (ffebld_conter (l
)));
2022 assert ("REAL3 bad type" == NULL
);
2026 /* If conversion operation is not implemented, return original expr. */
2027 if (error
== FFEBAD_NOCANDO
)
2030 expr
= ffebld_new_conter_with_orig
2031 (ffebld_constant_new_real3_val
2032 (ffebld_cu_val_real3 (u
)), expr
);
2037 assert ("bad real kind type" == NULL
);
2042 case FFEINFO_basictypeCOMPLEX
:
2043 sz
= FFETARGET_charactersizeNONE
;
2044 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
2046 #if FFETARGET_okCOMPLEX1
2047 case FFEINFO_kindtypeREAL1
:
2048 switch (ffeinfo_basictype (ffebld_info (l
)))
2050 case FFEINFO_basictypeINTEGER
:
2051 switch (ffeinfo_kindtype (ffebld_info (l
)))
2053 #if FFETARGET_okINTEGER1
2054 case FFEINFO_kindtypeINTEGER1
:
2055 error
= ffetarget_convert_complex1_integer1
2056 (ffebld_cu_ptr_complex1 (u
),
2057 ffebld_constant_integer1 (ffebld_conter (l
)));
2061 #if FFETARGET_okINTEGER2
2062 case FFEINFO_kindtypeINTEGER2
:
2063 error
= ffetarget_convert_complex1_integer2
2064 (ffebld_cu_ptr_complex1 (u
),
2065 ffebld_constant_integer2 (ffebld_conter (l
)));
2069 #if FFETARGET_okINTEGER3
2070 case FFEINFO_kindtypeINTEGER3
:
2071 error
= ffetarget_convert_complex1_integer3
2072 (ffebld_cu_ptr_complex1 (u
),
2073 ffebld_constant_integer3 (ffebld_conter (l
)));
2077 #if FFETARGET_okINTEGER4
2078 case FFEINFO_kindtypeINTEGER4
:
2079 error
= ffetarget_convert_complex1_integer4
2080 (ffebld_cu_ptr_complex1 (u
),
2081 ffebld_constant_integer4 (ffebld_conter (l
)));
2086 assert ("COMPLEX1/INTEGER bad source kind type" == NULL
);
2091 case FFEINFO_basictypeREAL
:
2092 switch (ffeinfo_kindtype (ffebld_info (l
)))
2094 #if FFETARGET_okREAL1
2095 case FFEINFO_kindtypeREAL1
:
2096 error
= ffetarget_convert_complex1_real1
2097 (ffebld_cu_ptr_complex1 (u
),
2098 ffebld_constant_real1 (ffebld_conter (l
)));
2102 #if FFETARGET_okREAL2
2103 case FFEINFO_kindtypeREAL2
:
2104 error
= ffetarget_convert_complex1_real2
2105 (ffebld_cu_ptr_complex1 (u
),
2106 ffebld_constant_real2 (ffebld_conter (l
)));
2110 #if FFETARGET_okREAL3
2111 case FFEINFO_kindtypeREAL3
:
2112 error
= ffetarget_convert_complex1_real3
2113 (ffebld_cu_ptr_complex1 (u
),
2114 ffebld_constant_real3 (ffebld_conter (l
)));
2119 assert ("COMPLEX1/REAL bad source kind type" == NULL
);
2124 case FFEINFO_basictypeCOMPLEX
:
2125 switch (ffeinfo_kindtype (ffebld_info (l
)))
2127 #if FFETARGET_okCOMPLEX2
2128 case FFEINFO_kindtypeREAL2
:
2129 error
= ffetarget_convert_complex1_complex2
2130 (ffebld_cu_ptr_complex1 (u
),
2131 ffebld_constant_complex2 (ffebld_conter (l
)));
2135 #if FFETARGET_okCOMPLEX3
2136 case FFEINFO_kindtypeREAL3
:
2137 error
= ffetarget_convert_complex1_complex3
2138 (ffebld_cu_ptr_complex1 (u
),
2139 ffebld_constant_complex3 (ffebld_conter (l
)));
2144 assert ("COMPLEX1/COMPLEX bad source kind type" == NULL
);
2149 case FFEINFO_basictypeCHARACTER
:
2150 error
= ffetarget_convert_complex1_character1
2151 (ffebld_cu_ptr_complex1 (u
),
2152 ffebld_constant_character1 (ffebld_conter (l
)));
2155 case FFEINFO_basictypeHOLLERITH
:
2156 error
= ffetarget_convert_complex1_hollerith
2157 (ffebld_cu_ptr_complex1 (u
),
2158 ffebld_constant_hollerith (ffebld_conter (l
)));
2161 case FFEINFO_basictypeTYPELESS
:
2162 error
= ffetarget_convert_complex1_typeless
2163 (ffebld_cu_ptr_complex1 (u
),
2164 ffebld_constant_typeless (ffebld_conter (l
)));
2168 assert ("COMPLEX1 bad type" == NULL
);
2172 /* If conversion operation is not implemented, return original expr. */
2173 if (error
== FFEBAD_NOCANDO
)
2176 expr
= ffebld_new_conter_with_orig
2177 (ffebld_constant_new_complex1_val
2178 (ffebld_cu_val_complex1 (u
)), expr
);
2182 #if FFETARGET_okCOMPLEX2
2183 case FFEINFO_kindtypeREAL2
:
2184 switch (ffeinfo_basictype (ffebld_info (l
)))
2186 case FFEINFO_basictypeINTEGER
:
2187 switch (ffeinfo_kindtype (ffebld_info (l
)))
2189 #if FFETARGET_okINTEGER1
2190 case FFEINFO_kindtypeINTEGER1
:
2191 error
= ffetarget_convert_complex2_integer1
2192 (ffebld_cu_ptr_complex2 (u
),
2193 ffebld_constant_integer1 (ffebld_conter (l
)));
2197 #if FFETARGET_okINTEGER2
2198 case FFEINFO_kindtypeINTEGER2
:
2199 error
= ffetarget_convert_complex2_integer2
2200 (ffebld_cu_ptr_complex2 (u
),
2201 ffebld_constant_integer2 (ffebld_conter (l
)));
2205 #if FFETARGET_okINTEGER3
2206 case FFEINFO_kindtypeINTEGER3
:
2207 error
= ffetarget_convert_complex2_integer3
2208 (ffebld_cu_ptr_complex2 (u
),
2209 ffebld_constant_integer3 (ffebld_conter (l
)));
2213 #if FFETARGET_okINTEGER4
2214 case FFEINFO_kindtypeINTEGER4
:
2215 error
= ffetarget_convert_complex2_integer4
2216 (ffebld_cu_ptr_complex2 (u
),
2217 ffebld_constant_integer4 (ffebld_conter (l
)));
2222 assert ("COMPLEX2/INTEGER bad source kind type" == NULL
);
2227 case FFEINFO_basictypeREAL
:
2228 switch (ffeinfo_kindtype (ffebld_info (l
)))
2230 #if FFETARGET_okREAL1
2231 case FFEINFO_kindtypeREAL1
:
2232 error
= ffetarget_convert_complex2_real1
2233 (ffebld_cu_ptr_complex2 (u
),
2234 ffebld_constant_real1 (ffebld_conter (l
)));
2238 #if FFETARGET_okREAL2
2239 case FFEINFO_kindtypeREAL2
:
2240 error
= ffetarget_convert_complex2_real2
2241 (ffebld_cu_ptr_complex2 (u
),
2242 ffebld_constant_real2 (ffebld_conter (l
)));
2246 #if FFETARGET_okREAL3
2247 case FFEINFO_kindtypeREAL3
:
2248 error
= ffetarget_convert_complex2_real3
2249 (ffebld_cu_ptr_complex2 (u
),
2250 ffebld_constant_real3 (ffebld_conter (l
)));
2255 assert ("COMPLEX2/REAL bad source kind type" == NULL
);
2260 case FFEINFO_basictypeCOMPLEX
:
2261 switch (ffeinfo_kindtype (ffebld_info (l
)))
2263 #if FFETARGET_okCOMPLEX1
2264 case FFEINFO_kindtypeREAL1
:
2265 error
= ffetarget_convert_complex2_complex1
2266 (ffebld_cu_ptr_complex2 (u
),
2267 ffebld_constant_complex1 (ffebld_conter (l
)));
2271 #if FFETARGET_okCOMPLEX3
2272 case FFEINFO_kindtypeREAL3
:
2273 error
= ffetarget_convert_complex2_complex3
2274 (ffebld_cu_ptr_complex2 (u
),
2275 ffebld_constant_complex3 (ffebld_conter (l
)));
2280 assert ("COMPLEX2/COMPLEX bad source kind type" == NULL
);
2285 case FFEINFO_basictypeCHARACTER
:
2286 error
= ffetarget_convert_complex2_character1
2287 (ffebld_cu_ptr_complex2 (u
),
2288 ffebld_constant_character1 (ffebld_conter (l
)));
2291 case FFEINFO_basictypeHOLLERITH
:
2292 error
= ffetarget_convert_complex2_hollerith
2293 (ffebld_cu_ptr_complex2 (u
),
2294 ffebld_constant_hollerith (ffebld_conter (l
)));
2297 case FFEINFO_basictypeTYPELESS
:
2298 error
= ffetarget_convert_complex2_typeless
2299 (ffebld_cu_ptr_complex2 (u
),
2300 ffebld_constant_typeless (ffebld_conter (l
)));
2304 assert ("COMPLEX2 bad type" == NULL
);
2308 /* If conversion operation is not implemented, return original expr. */
2309 if (error
== FFEBAD_NOCANDO
)
2312 expr
= ffebld_new_conter_with_orig
2313 (ffebld_constant_new_complex2_val
2314 (ffebld_cu_val_complex2 (u
)), expr
);
2318 #if FFETARGET_okCOMPLEX3
2319 case FFEINFO_kindtypeREAL3
:
2320 switch (ffeinfo_basictype (ffebld_info (l
)))
2322 case FFEINFO_basictypeINTEGER
:
2323 switch (ffeinfo_kindtype (ffebld_info (l
)))
2325 #if FFETARGET_okINTEGER1
2326 case FFEINFO_kindtypeINTEGER1
:
2327 error
= ffetarget_convert_complex3_integer1
2328 (ffebld_cu_ptr_complex3 (u
),
2329 ffebld_constant_integer1 (ffebld_conter (l
)));
2333 #if FFETARGET_okINTEGER2
2334 case FFEINFO_kindtypeINTEGER2
:
2335 error
= ffetarget_convert_complex3_integer2
2336 (ffebld_cu_ptr_complex3 (u
),
2337 ffebld_constant_integer2 (ffebld_conter (l
)));
2341 #if FFETARGET_okINTEGER3
2342 case FFEINFO_kindtypeINTEGER3
:
2343 error
= ffetarget_convert_complex3_integer3
2344 (ffebld_cu_ptr_complex3 (u
),
2345 ffebld_constant_integer3 (ffebld_conter (l
)));
2349 #if FFETARGET_okINTEGER4
2350 case FFEINFO_kindtypeINTEGER4
:
2351 error
= ffetarget_convert_complex3_integer4
2352 (ffebld_cu_ptr_complex3 (u
),
2353 ffebld_constant_integer4 (ffebld_conter (l
)));
2358 assert ("COMPLEX3/INTEGER bad source kind type" == NULL
);
2363 case FFEINFO_basictypeREAL
:
2364 switch (ffeinfo_kindtype (ffebld_info (l
)))
2366 #if FFETARGET_okREAL1
2367 case FFEINFO_kindtypeREAL1
:
2368 error
= ffetarget_convert_complex3_real1
2369 (ffebld_cu_ptr_complex3 (u
),
2370 ffebld_constant_real1 (ffebld_conter (l
)));
2374 #if FFETARGET_okREAL2
2375 case FFEINFO_kindtypeREAL2
:
2376 error
= ffetarget_convert_complex3_real2
2377 (ffebld_cu_ptr_complex3 (u
),
2378 ffebld_constant_real2 (ffebld_conter (l
)));
2382 #if FFETARGET_okREAL3
2383 case FFEINFO_kindtypeREAL3
:
2384 error
= ffetarget_convert_complex3_real3
2385 (ffebld_cu_ptr_complex3 (u
),
2386 ffebld_constant_real3 (ffebld_conter (l
)));
2391 assert ("COMPLEX3/REAL bad source kind type" == NULL
);
2396 case FFEINFO_basictypeCOMPLEX
:
2397 switch (ffeinfo_kindtype (ffebld_info (l
)))
2399 #if FFETARGET_okCOMPLEX1
2400 case FFEINFO_kindtypeREAL1
:
2401 error
= ffetarget_convert_complex3_complex1
2402 (ffebld_cu_ptr_complex3 (u
),
2403 ffebld_constant_complex1 (ffebld_conter (l
)));
2407 #if FFETARGET_okCOMPLEX2
2408 case FFEINFO_kindtypeREAL2
:
2409 error
= ffetarget_convert_complex3_complex2
2410 (ffebld_cu_ptr_complex3 (u
),
2411 ffebld_constant_complex2 (ffebld_conter (l
)));
2416 assert ("COMPLEX3/COMPLEX bad source kind type" == NULL
);
2421 case FFEINFO_basictypeCHARACTER
:
2422 error
= ffetarget_convert_complex3_character1
2423 (ffebld_cu_ptr_complex3 (u
),
2424 ffebld_constant_character1 (ffebld_conter (l
)));
2427 case FFEINFO_basictypeHOLLERITH
:
2428 error
= ffetarget_convert_complex3_hollerith
2429 (ffebld_cu_ptr_complex3 (u
),
2430 ffebld_constant_hollerith (ffebld_conter (l
)));
2433 case FFEINFO_basictypeTYPELESS
:
2434 error
= ffetarget_convert_complex3_typeless
2435 (ffebld_cu_ptr_complex3 (u
),
2436 ffebld_constant_typeless (ffebld_conter (l
)));
2440 assert ("COMPLEX3 bad type" == NULL
);
2444 /* If conversion operation is not implemented, return original expr. */
2445 if (error
== FFEBAD_NOCANDO
)
2448 expr
= ffebld_new_conter_with_orig
2449 (ffebld_constant_new_complex3_val
2450 (ffebld_cu_val_complex3 (u
)), expr
);
2455 assert ("bad complex kind type" == NULL
);
2460 case FFEINFO_basictypeCHARACTER
:
2461 if ((sz
= ffebld_size (expr
)) == FFETARGET_charactersizeNONE
)
2463 kt
= ffeinfo_kindtype (ffebld_info (expr
));
2466 #if FFETARGET_okCHARACTER1
2467 case FFEINFO_kindtypeCHARACTER1
:
2468 switch (ffeinfo_basictype (ffebld_info (l
)))
2470 case FFEINFO_basictypeCHARACTER
:
2471 if ((sz2
= ffebld_size (l
)) == FFETARGET_charactersizeNONE
)
2473 assert (kt
== ffeinfo_kindtype (ffebld_info (l
)));
2474 assert (sz2
== ffetarget_length_character1
2475 (ffebld_constant_character1
2476 (ffebld_conter (l
))));
2478 = ffetarget_convert_character1_character1
2479 (ffebld_cu_ptr_character1 (u
), sz
,
2480 ffebld_constant_character1 (ffebld_conter (l
)),
2481 ffebld_constant_pool ());
2484 case FFEINFO_basictypeINTEGER
:
2485 switch (ffeinfo_kindtype (ffebld_info (l
)))
2487 #if FFETARGET_okINTEGER1
2488 case FFEINFO_kindtypeINTEGER1
:
2490 = ffetarget_convert_character1_integer1
2491 (ffebld_cu_ptr_character1 (u
),
2493 ffebld_constant_integer1 (ffebld_conter (l
)),
2494 ffebld_constant_pool ());
2498 #if FFETARGET_okINTEGER2
2499 case FFEINFO_kindtypeINTEGER2
:
2501 = ffetarget_convert_character1_integer2
2502 (ffebld_cu_ptr_character1 (u
),
2504 ffebld_constant_integer2 (ffebld_conter (l
)),
2505 ffebld_constant_pool ());
2509 #if FFETARGET_okINTEGER3
2510 case FFEINFO_kindtypeINTEGER3
:
2512 = ffetarget_convert_character1_integer3
2513 (ffebld_cu_ptr_character1 (u
),
2515 ffebld_constant_integer3 (ffebld_conter (l
)),
2516 ffebld_constant_pool ());
2520 #if FFETARGET_okINTEGER4
2521 case FFEINFO_kindtypeINTEGER4
:
2523 = ffetarget_convert_character1_integer4
2524 (ffebld_cu_ptr_character1 (u
),
2526 ffebld_constant_integer4 (ffebld_conter (l
)),
2527 ffebld_constant_pool ());
2532 assert ("CHARACTER1/INTEGER bad source kind type" == NULL
);
2537 case FFEINFO_basictypeLOGICAL
:
2538 switch (ffeinfo_kindtype (ffebld_info (l
)))
2540 #if FFETARGET_okLOGICAL1
2541 case FFEINFO_kindtypeLOGICAL1
:
2543 = ffetarget_convert_character1_logical1
2544 (ffebld_cu_ptr_character1 (u
),
2546 ffebld_constant_logical1 (ffebld_conter (l
)),
2547 ffebld_constant_pool ());
2551 #if FFETARGET_okLOGICAL2
2552 case FFEINFO_kindtypeLOGICAL2
:
2554 = ffetarget_convert_character1_logical2
2555 (ffebld_cu_ptr_character1 (u
),
2557 ffebld_constant_logical2 (ffebld_conter (l
)),
2558 ffebld_constant_pool ());
2562 #if FFETARGET_okLOGICAL3
2563 case FFEINFO_kindtypeLOGICAL3
:
2565 = ffetarget_convert_character1_logical3
2566 (ffebld_cu_ptr_character1 (u
),
2568 ffebld_constant_logical3 (ffebld_conter (l
)),
2569 ffebld_constant_pool ());
2573 #if FFETARGET_okLOGICAL4
2574 case FFEINFO_kindtypeLOGICAL4
:
2576 = ffetarget_convert_character1_logical4
2577 (ffebld_cu_ptr_character1 (u
),
2579 ffebld_constant_logical4 (ffebld_conter (l
)),
2580 ffebld_constant_pool ());
2585 assert ("CHARACTER1/LOGICAL bad source kind type" == NULL
);
2590 case FFEINFO_basictypeHOLLERITH
:
2592 = ffetarget_convert_character1_hollerith
2593 (ffebld_cu_ptr_character1 (u
),
2595 ffebld_constant_hollerith (ffebld_conter (l
)),
2596 ffebld_constant_pool ());
2599 case FFEINFO_basictypeTYPELESS
:
2601 = ffetarget_convert_character1_typeless
2602 (ffebld_cu_ptr_character1 (u
),
2604 ffebld_constant_typeless (ffebld_conter (l
)),
2605 ffebld_constant_pool ());
2609 assert ("CHARACTER1 bad type" == NULL
);
2613 = ffebld_new_conter_with_orig
2614 (ffebld_constant_new_character1_val
2615 (ffebld_cu_val_character1 (u
)),
2621 assert ("bad character kind type" == NULL
);
2627 assert ("bad type" == NULL
);
2631 ffebld_set_info (expr
, ffeinfo_new
2636 FFEINFO_whereCONSTANT
,
2639 if ((error
!= FFEBAD
)
2640 && ffebad_start (error
))
2643 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
2650 /* ffeexpr_collapse_paren -- Collapse paren expr
2654 expr = ffeexpr_collapse_paren(expr,token);
2656 If the result of the expr is a constant, replaces the expr with the
2657 computed constant. */
2660 ffeexpr_collapse_paren (ffebld expr
, ffelexToken t UNUSED
)
2663 ffeinfoBasictype bt
;
2665 ffetargetCharacterSize len
;
2667 if (ffeinfo_where (ffebld_info (expr
)) != FFEINFO_whereCONSTANT
)
2670 r
= ffebld_left (expr
);
2672 if (ffebld_op (r
) != FFEBLD_opCONTER
)
2675 bt
= ffeinfo_basictype (ffebld_info (r
));
2676 kt
= ffeinfo_kindtype (ffebld_info (r
));
2677 len
= ffebld_size (r
);
2679 expr
= ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r
)),
2682 ffebld_set_info (expr
, ffeinfo_new
2687 FFEINFO_whereCONSTANT
,
2693 /* ffeexpr_collapse_uplus -- Collapse uplus expr
2697 expr = ffeexpr_collapse_uplus(expr,token);
2699 If the result of the expr is a constant, replaces the expr with the
2700 computed constant. */
2703 ffeexpr_collapse_uplus (ffebld expr
, ffelexToken t UNUSED
)
2706 ffeinfoBasictype bt
;
2708 ffetargetCharacterSize len
;
2710 if (ffeinfo_where (ffebld_info (expr
)) != FFEINFO_whereCONSTANT
)
2713 r
= ffebld_left (expr
);
2715 if (ffebld_op (r
) != FFEBLD_opCONTER
)
2718 bt
= ffeinfo_basictype (ffebld_info (r
));
2719 kt
= ffeinfo_kindtype (ffebld_info (r
));
2720 len
= ffebld_size (r
);
2722 expr
= ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r
)),
2725 ffebld_set_info (expr
, ffeinfo_new
2730 FFEINFO_whereCONSTANT
,
2736 /* ffeexpr_collapse_uminus -- Collapse uminus expr
2740 expr = ffeexpr_collapse_uminus(expr,token);
2742 If the result of the expr is a constant, replaces the expr with the
2743 computed constant. */
2746 ffeexpr_collapse_uminus (ffebld expr
, ffelexToken t
)
2748 ffebad error
= FFEBAD
;
2750 ffebldConstantUnion u
;
2751 ffeinfoBasictype bt
;
2754 if (ffeinfo_where (ffebld_info (expr
)) != FFEINFO_whereCONSTANT
)
2757 r
= ffebld_left (expr
);
2759 if (ffebld_op (r
) != FFEBLD_opCONTER
)
2762 switch (bt
= ffeinfo_basictype (ffebld_info (expr
)))
2764 case FFEINFO_basictypeANY
:
2767 case FFEINFO_basictypeINTEGER
:
2768 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
2770 #if FFETARGET_okINTEGER1
2771 case FFEINFO_kindtypeINTEGER1
:
2772 error
= ffetarget_uminus_integer1 (ffebld_cu_ptr_integer1 (u
),
2773 ffebld_constant_integer1 (ffebld_conter (r
)));
2774 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
2775 (ffebld_cu_val_integer1 (u
)), expr
);
2779 #if FFETARGET_okINTEGER2
2780 case FFEINFO_kindtypeINTEGER2
:
2781 error
= ffetarget_uminus_integer2 (ffebld_cu_ptr_integer2 (u
),
2782 ffebld_constant_integer2 (ffebld_conter (r
)));
2783 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
2784 (ffebld_cu_val_integer2 (u
)), expr
);
2788 #if FFETARGET_okINTEGER3
2789 case FFEINFO_kindtypeINTEGER3
:
2790 error
= ffetarget_uminus_integer3 (ffebld_cu_ptr_integer3 (u
),
2791 ffebld_constant_integer3 (ffebld_conter (r
)));
2792 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
2793 (ffebld_cu_val_integer3 (u
)), expr
);
2797 #if FFETARGET_okINTEGER4
2798 case FFEINFO_kindtypeINTEGER4
:
2799 error
= ffetarget_uminus_integer4 (ffebld_cu_ptr_integer4 (u
),
2800 ffebld_constant_integer4 (ffebld_conter (r
)));
2801 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
2802 (ffebld_cu_val_integer4 (u
)), expr
);
2807 assert ("bad integer kind type" == NULL
);
2812 case FFEINFO_basictypeREAL
:
2813 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
2815 #if FFETARGET_okREAL1
2816 case FFEINFO_kindtypeREAL1
:
2817 error
= ffetarget_uminus_real1 (ffebld_cu_ptr_real1 (u
),
2818 ffebld_constant_real1 (ffebld_conter (r
)));
2819 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
2820 (ffebld_cu_val_real1 (u
)), expr
);
2824 #if FFETARGET_okREAL2
2825 case FFEINFO_kindtypeREAL2
:
2826 error
= ffetarget_uminus_real2 (ffebld_cu_ptr_real2 (u
),
2827 ffebld_constant_real2 (ffebld_conter (r
)));
2828 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
2829 (ffebld_cu_val_real2 (u
)), expr
);
2833 #if FFETARGET_okREAL3
2834 case FFEINFO_kindtypeREAL3
:
2835 error
= ffetarget_uminus_real3 (ffebld_cu_ptr_real3 (u
),
2836 ffebld_constant_real3 (ffebld_conter (r
)));
2837 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
2838 (ffebld_cu_val_real3 (u
)), expr
);
2843 assert ("bad real kind type" == NULL
);
2848 case FFEINFO_basictypeCOMPLEX
:
2849 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
2851 #if FFETARGET_okCOMPLEX1
2852 case FFEINFO_kindtypeREAL1
:
2853 error
= ffetarget_uminus_complex1 (ffebld_cu_ptr_complex1 (u
),
2854 ffebld_constant_complex1 (ffebld_conter (r
)));
2855 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
2856 (ffebld_cu_val_complex1 (u
)), expr
);
2860 #if FFETARGET_okCOMPLEX2
2861 case FFEINFO_kindtypeREAL2
:
2862 error
= ffetarget_uminus_complex2 (ffebld_cu_ptr_complex2 (u
),
2863 ffebld_constant_complex2 (ffebld_conter (r
)));
2864 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
2865 (ffebld_cu_val_complex2 (u
)), expr
);
2869 #if FFETARGET_okCOMPLEX3
2870 case FFEINFO_kindtypeREAL3
:
2871 error
= ffetarget_uminus_complex3 (ffebld_cu_ptr_complex3 (u
),
2872 ffebld_constant_complex3 (ffebld_conter (r
)));
2873 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
2874 (ffebld_cu_val_complex3 (u
)), expr
);
2879 assert ("bad complex kind type" == NULL
);
2885 assert ("bad type" == NULL
);
2889 ffebld_set_info (expr
, ffeinfo_new
2894 FFEINFO_whereCONSTANT
,
2895 FFETARGET_charactersizeNONE
));
2897 if ((error
!= FFEBAD
)
2898 && ffebad_start (error
))
2900 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
2907 /* ffeexpr_collapse_not -- Collapse not expr
2911 expr = ffeexpr_collapse_not(expr,token);
2913 If the result of the expr is a constant, replaces the expr with the
2914 computed constant. */
2917 ffeexpr_collapse_not (ffebld expr
, ffelexToken t
)
2919 ffebad error
= FFEBAD
;
2921 ffebldConstantUnion u
;
2922 ffeinfoBasictype bt
;
2925 if (ffeinfo_where (ffebld_info (expr
)) != FFEINFO_whereCONSTANT
)
2928 r
= ffebld_left (expr
);
2930 if (ffebld_op (r
) != FFEBLD_opCONTER
)
2933 switch (bt
= ffeinfo_basictype (ffebld_info (expr
)))
2935 case FFEINFO_basictypeANY
:
2938 case FFEINFO_basictypeINTEGER
:
2939 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
2941 #if FFETARGET_okINTEGER1
2942 case FFEINFO_kindtypeINTEGER1
:
2943 error
= ffetarget_not_integer1 (ffebld_cu_ptr_integer1 (u
),
2944 ffebld_constant_integer1 (ffebld_conter (r
)));
2945 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
2946 (ffebld_cu_val_integer1 (u
)), expr
);
2950 #if FFETARGET_okINTEGER2
2951 case FFEINFO_kindtypeINTEGER2
:
2952 error
= ffetarget_not_integer2 (ffebld_cu_ptr_integer2 (u
),
2953 ffebld_constant_integer2 (ffebld_conter (r
)));
2954 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
2955 (ffebld_cu_val_integer2 (u
)), expr
);
2959 #if FFETARGET_okINTEGER3
2960 case FFEINFO_kindtypeINTEGER3
:
2961 error
= ffetarget_not_integer3 (ffebld_cu_ptr_integer3 (u
),
2962 ffebld_constant_integer3 (ffebld_conter (r
)));
2963 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
2964 (ffebld_cu_val_integer3 (u
)), expr
);
2968 #if FFETARGET_okINTEGER4
2969 case FFEINFO_kindtypeINTEGER4
:
2970 error
= ffetarget_not_integer4 (ffebld_cu_ptr_integer4 (u
),
2971 ffebld_constant_integer4 (ffebld_conter (r
)));
2972 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
2973 (ffebld_cu_val_integer4 (u
)), expr
);
2978 assert ("bad integer kind type" == NULL
);
2983 case FFEINFO_basictypeLOGICAL
:
2984 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
2986 #if FFETARGET_okLOGICAL1
2987 case FFEINFO_kindtypeLOGICAL1
:
2988 error
= ffetarget_not_logical1 (ffebld_cu_ptr_logical1 (u
),
2989 ffebld_constant_logical1 (ffebld_conter (r
)));
2990 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
2991 (ffebld_cu_val_logical1 (u
)), expr
);
2995 #if FFETARGET_okLOGICAL2
2996 case FFEINFO_kindtypeLOGICAL2
:
2997 error
= ffetarget_not_logical2 (ffebld_cu_ptr_logical2 (u
),
2998 ffebld_constant_logical2 (ffebld_conter (r
)));
2999 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
3000 (ffebld_cu_val_logical2 (u
)), expr
);
3004 #if FFETARGET_okLOGICAL3
3005 case FFEINFO_kindtypeLOGICAL3
:
3006 error
= ffetarget_not_logical3 (ffebld_cu_ptr_logical3 (u
),
3007 ffebld_constant_logical3 (ffebld_conter (r
)));
3008 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
3009 (ffebld_cu_val_logical3 (u
)), expr
);
3013 #if FFETARGET_okLOGICAL4
3014 case FFEINFO_kindtypeLOGICAL4
:
3015 error
= ffetarget_not_logical4 (ffebld_cu_ptr_logical4 (u
),
3016 ffebld_constant_logical4 (ffebld_conter (r
)));
3017 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
3018 (ffebld_cu_val_logical4 (u
)), expr
);
3023 assert ("bad logical kind type" == NULL
);
3029 assert ("bad type" == NULL
);
3033 ffebld_set_info (expr
, ffeinfo_new
3038 FFEINFO_whereCONSTANT
,
3039 FFETARGET_charactersizeNONE
));
3041 if ((error
!= FFEBAD
)
3042 && ffebad_start (error
))
3044 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
3051 /* ffeexpr_collapse_add -- Collapse add expr
3055 expr = ffeexpr_collapse_add(expr,token);
3057 If the result of the expr is a constant, replaces the expr with the
3058 computed constant. */
3061 ffeexpr_collapse_add (ffebld expr
, ffelexToken t
)
3063 ffebad error
= FFEBAD
;
3066 ffebldConstantUnion u
;
3067 ffeinfoBasictype bt
;
3070 if (ffeinfo_where (ffebld_info (expr
)) != FFEINFO_whereCONSTANT
)
3073 l
= ffebld_left (expr
);
3074 r
= ffebld_right (expr
);
3076 if (ffebld_op (l
) != FFEBLD_opCONTER
)
3078 if (ffebld_op (r
) != FFEBLD_opCONTER
)
3081 switch (bt
= ffeinfo_basictype (ffebld_info (expr
)))
3083 case FFEINFO_basictypeANY
:
3086 case FFEINFO_basictypeINTEGER
:
3087 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
3089 #if FFETARGET_okINTEGER1
3090 case FFEINFO_kindtypeINTEGER1
:
3091 error
= ffetarget_add_integer1 (ffebld_cu_ptr_integer1 (u
),
3092 ffebld_constant_integer1 (ffebld_conter (l
)),
3093 ffebld_constant_integer1 (ffebld_conter (r
)));
3094 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3095 (ffebld_cu_val_integer1 (u
)), expr
);
3099 #if FFETARGET_okINTEGER2
3100 case FFEINFO_kindtypeINTEGER2
:
3101 error
= ffetarget_add_integer2 (ffebld_cu_ptr_integer2 (u
),
3102 ffebld_constant_integer2 (ffebld_conter (l
)),
3103 ffebld_constant_integer2 (ffebld_conter (r
)));
3104 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3105 (ffebld_cu_val_integer2 (u
)), expr
);
3109 #if FFETARGET_okINTEGER3
3110 case FFEINFO_kindtypeINTEGER3
:
3111 error
= ffetarget_add_integer3 (ffebld_cu_ptr_integer3 (u
),
3112 ffebld_constant_integer3 (ffebld_conter (l
)),
3113 ffebld_constant_integer3 (ffebld_conter (r
)));
3114 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3115 (ffebld_cu_val_integer3 (u
)), expr
);
3119 #if FFETARGET_okINTEGER4
3120 case FFEINFO_kindtypeINTEGER4
:
3121 error
= ffetarget_add_integer4 (ffebld_cu_ptr_integer4 (u
),
3122 ffebld_constant_integer4 (ffebld_conter (l
)),
3123 ffebld_constant_integer4 (ffebld_conter (r
)));
3124 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3125 (ffebld_cu_val_integer4 (u
)), expr
);
3130 assert ("bad integer kind type" == NULL
);
3135 case FFEINFO_basictypeREAL
:
3136 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
3138 #if FFETARGET_okREAL1
3139 case FFEINFO_kindtypeREAL1
:
3140 error
= ffetarget_add_real1 (ffebld_cu_ptr_real1 (u
),
3141 ffebld_constant_real1 (ffebld_conter (l
)),
3142 ffebld_constant_real1 (ffebld_conter (r
)));
3143 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3144 (ffebld_cu_val_real1 (u
)), expr
);
3148 #if FFETARGET_okREAL2
3149 case FFEINFO_kindtypeREAL2
:
3150 error
= ffetarget_add_real2 (ffebld_cu_ptr_real2 (u
),
3151 ffebld_constant_real2 (ffebld_conter (l
)),
3152 ffebld_constant_real2 (ffebld_conter (r
)));
3153 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3154 (ffebld_cu_val_real2 (u
)), expr
);
3158 #if FFETARGET_okREAL3
3159 case FFEINFO_kindtypeREAL3
:
3160 error
= ffetarget_add_real3 (ffebld_cu_ptr_real3 (u
),
3161 ffebld_constant_real3 (ffebld_conter (l
)),
3162 ffebld_constant_real3 (ffebld_conter (r
)));
3163 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3164 (ffebld_cu_val_real3 (u
)), expr
);
3169 assert ("bad real kind type" == NULL
);
3174 case FFEINFO_basictypeCOMPLEX
:
3175 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
3177 #if FFETARGET_okCOMPLEX1
3178 case FFEINFO_kindtypeREAL1
:
3179 error
= ffetarget_add_complex1 (ffebld_cu_ptr_complex1 (u
),
3180 ffebld_constant_complex1 (ffebld_conter (l
)),
3181 ffebld_constant_complex1 (ffebld_conter (r
)));
3182 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3183 (ffebld_cu_val_complex1 (u
)), expr
);
3187 #if FFETARGET_okCOMPLEX2
3188 case FFEINFO_kindtypeREAL2
:
3189 error
= ffetarget_add_complex2 (ffebld_cu_ptr_complex2 (u
),
3190 ffebld_constant_complex2 (ffebld_conter (l
)),
3191 ffebld_constant_complex2 (ffebld_conter (r
)));
3192 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3193 (ffebld_cu_val_complex2 (u
)), expr
);
3197 #if FFETARGET_okCOMPLEX3
3198 case FFEINFO_kindtypeREAL3
:
3199 error
= ffetarget_add_complex3 (ffebld_cu_ptr_complex3 (u
),
3200 ffebld_constant_complex3 (ffebld_conter (l
)),
3201 ffebld_constant_complex3 (ffebld_conter (r
)));
3202 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3203 (ffebld_cu_val_complex3 (u
)), expr
);
3208 assert ("bad complex kind type" == NULL
);
3214 assert ("bad type" == NULL
);
3218 ffebld_set_info (expr
, ffeinfo_new
3223 FFEINFO_whereCONSTANT
,
3224 FFETARGET_charactersizeNONE
));
3226 if ((error
!= FFEBAD
)
3227 && ffebad_start (error
))
3229 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
3236 /* ffeexpr_collapse_subtract -- Collapse subtract expr
3240 expr = ffeexpr_collapse_subtract(expr,token);
3242 If the result of the expr is a constant, replaces the expr with the
3243 computed constant. */
3246 ffeexpr_collapse_subtract (ffebld expr
, ffelexToken t
)
3248 ffebad error
= FFEBAD
;
3251 ffebldConstantUnion u
;
3252 ffeinfoBasictype bt
;
3255 if (ffeinfo_where (ffebld_info (expr
)) != FFEINFO_whereCONSTANT
)
3258 l
= ffebld_left (expr
);
3259 r
= ffebld_right (expr
);
3261 if (ffebld_op (l
) != FFEBLD_opCONTER
)
3263 if (ffebld_op (r
) != FFEBLD_opCONTER
)
3266 switch (bt
= ffeinfo_basictype (ffebld_info (expr
)))
3268 case FFEINFO_basictypeANY
:
3271 case FFEINFO_basictypeINTEGER
:
3272 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
3274 #if FFETARGET_okINTEGER1
3275 case FFEINFO_kindtypeINTEGER1
:
3276 error
= ffetarget_subtract_integer1 (ffebld_cu_ptr_integer1 (u
),
3277 ffebld_constant_integer1 (ffebld_conter (l
)),
3278 ffebld_constant_integer1 (ffebld_conter (r
)));
3279 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3280 (ffebld_cu_val_integer1 (u
)), expr
);
3284 #if FFETARGET_okINTEGER2
3285 case FFEINFO_kindtypeINTEGER2
:
3286 error
= ffetarget_subtract_integer2 (ffebld_cu_ptr_integer2 (u
),
3287 ffebld_constant_integer2 (ffebld_conter (l
)),
3288 ffebld_constant_integer2 (ffebld_conter (r
)));
3289 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3290 (ffebld_cu_val_integer2 (u
)), expr
);
3294 #if FFETARGET_okINTEGER3
3295 case FFEINFO_kindtypeINTEGER3
:
3296 error
= ffetarget_subtract_integer3 (ffebld_cu_ptr_integer3 (u
),
3297 ffebld_constant_integer3 (ffebld_conter (l
)),
3298 ffebld_constant_integer3 (ffebld_conter (r
)));
3299 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3300 (ffebld_cu_val_integer3 (u
)), expr
);
3304 #if FFETARGET_okINTEGER4
3305 case FFEINFO_kindtypeINTEGER4
:
3306 error
= ffetarget_subtract_integer4 (ffebld_cu_ptr_integer4 (u
),
3307 ffebld_constant_integer4 (ffebld_conter (l
)),
3308 ffebld_constant_integer4 (ffebld_conter (r
)));
3309 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3310 (ffebld_cu_val_integer4 (u
)), expr
);
3315 assert ("bad integer kind type" == NULL
);
3320 case FFEINFO_basictypeREAL
:
3321 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
3323 #if FFETARGET_okREAL1
3324 case FFEINFO_kindtypeREAL1
:
3325 error
= ffetarget_subtract_real1 (ffebld_cu_ptr_real1 (u
),
3326 ffebld_constant_real1 (ffebld_conter (l
)),
3327 ffebld_constant_real1 (ffebld_conter (r
)));
3328 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3329 (ffebld_cu_val_real1 (u
)), expr
);
3333 #if FFETARGET_okREAL2
3334 case FFEINFO_kindtypeREAL2
:
3335 error
= ffetarget_subtract_real2 (ffebld_cu_ptr_real2 (u
),
3336 ffebld_constant_real2 (ffebld_conter (l
)),
3337 ffebld_constant_real2 (ffebld_conter (r
)));
3338 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3339 (ffebld_cu_val_real2 (u
)), expr
);
3343 #if FFETARGET_okREAL3
3344 case FFEINFO_kindtypeREAL3
:
3345 error
= ffetarget_subtract_real3 (ffebld_cu_ptr_real3 (u
),
3346 ffebld_constant_real3 (ffebld_conter (l
)),
3347 ffebld_constant_real3 (ffebld_conter (r
)));
3348 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3349 (ffebld_cu_val_real3 (u
)), expr
);
3354 assert ("bad real kind type" == NULL
);
3359 case FFEINFO_basictypeCOMPLEX
:
3360 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
3362 #if FFETARGET_okCOMPLEX1
3363 case FFEINFO_kindtypeREAL1
:
3364 error
= ffetarget_subtract_complex1 (ffebld_cu_ptr_complex1 (u
),
3365 ffebld_constant_complex1 (ffebld_conter (l
)),
3366 ffebld_constant_complex1 (ffebld_conter (r
)));
3367 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3368 (ffebld_cu_val_complex1 (u
)), expr
);
3372 #if FFETARGET_okCOMPLEX2
3373 case FFEINFO_kindtypeREAL2
:
3374 error
= ffetarget_subtract_complex2 (ffebld_cu_ptr_complex2 (u
),
3375 ffebld_constant_complex2 (ffebld_conter (l
)),
3376 ffebld_constant_complex2 (ffebld_conter (r
)));
3377 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3378 (ffebld_cu_val_complex2 (u
)), expr
);
3382 #if FFETARGET_okCOMPLEX3
3383 case FFEINFO_kindtypeREAL3
:
3384 error
= ffetarget_subtract_complex3 (ffebld_cu_ptr_complex3 (u
),
3385 ffebld_constant_complex3 (ffebld_conter (l
)),
3386 ffebld_constant_complex3 (ffebld_conter (r
)));
3387 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3388 (ffebld_cu_val_complex3 (u
)), expr
);
3393 assert ("bad complex kind type" == NULL
);
3399 assert ("bad type" == NULL
);
3403 ffebld_set_info (expr
, ffeinfo_new
3408 FFEINFO_whereCONSTANT
,
3409 FFETARGET_charactersizeNONE
));
3411 if ((error
!= FFEBAD
)
3412 && ffebad_start (error
))
3414 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
3421 /* ffeexpr_collapse_multiply -- Collapse multiply expr
3425 expr = ffeexpr_collapse_multiply(expr,token);
3427 If the result of the expr is a constant, replaces the expr with the
3428 computed constant. */
3431 ffeexpr_collapse_multiply (ffebld expr
, ffelexToken t
)
3433 ffebad error
= FFEBAD
;
3436 ffebldConstantUnion u
;
3437 ffeinfoBasictype bt
;
3440 if (ffeinfo_where (ffebld_info (expr
)) != FFEINFO_whereCONSTANT
)
3443 l
= ffebld_left (expr
);
3444 r
= ffebld_right (expr
);
3446 if (ffebld_op (l
) != FFEBLD_opCONTER
)
3448 if (ffebld_op (r
) != FFEBLD_opCONTER
)
3451 switch (bt
= ffeinfo_basictype (ffebld_info (expr
)))
3453 case FFEINFO_basictypeANY
:
3456 case FFEINFO_basictypeINTEGER
:
3457 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
3459 #if FFETARGET_okINTEGER1
3460 case FFEINFO_kindtypeINTEGER1
:
3461 error
= ffetarget_multiply_integer1 (ffebld_cu_ptr_integer1 (u
),
3462 ffebld_constant_integer1 (ffebld_conter (l
)),
3463 ffebld_constant_integer1 (ffebld_conter (r
)));
3464 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3465 (ffebld_cu_val_integer1 (u
)), expr
);
3469 #if FFETARGET_okINTEGER2
3470 case FFEINFO_kindtypeINTEGER2
:
3471 error
= ffetarget_multiply_integer2 (ffebld_cu_ptr_integer2 (u
),
3472 ffebld_constant_integer2 (ffebld_conter (l
)),
3473 ffebld_constant_integer2 (ffebld_conter (r
)));
3474 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3475 (ffebld_cu_val_integer2 (u
)), expr
);
3479 #if FFETARGET_okINTEGER3
3480 case FFEINFO_kindtypeINTEGER3
:
3481 error
= ffetarget_multiply_integer3 (ffebld_cu_ptr_integer3 (u
),
3482 ffebld_constant_integer3 (ffebld_conter (l
)),
3483 ffebld_constant_integer3 (ffebld_conter (r
)));
3484 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3485 (ffebld_cu_val_integer3 (u
)), expr
);
3489 #if FFETARGET_okINTEGER4
3490 case FFEINFO_kindtypeINTEGER4
:
3491 error
= ffetarget_multiply_integer4 (ffebld_cu_ptr_integer4 (u
),
3492 ffebld_constant_integer4 (ffebld_conter (l
)),
3493 ffebld_constant_integer4 (ffebld_conter (r
)));
3494 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3495 (ffebld_cu_val_integer4 (u
)), expr
);
3500 assert ("bad integer kind type" == NULL
);
3505 case FFEINFO_basictypeREAL
:
3506 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
3508 #if FFETARGET_okREAL1
3509 case FFEINFO_kindtypeREAL1
:
3510 error
= ffetarget_multiply_real1 (ffebld_cu_ptr_real1 (u
),
3511 ffebld_constant_real1 (ffebld_conter (l
)),
3512 ffebld_constant_real1 (ffebld_conter (r
)));
3513 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3514 (ffebld_cu_val_real1 (u
)), expr
);
3518 #if FFETARGET_okREAL2
3519 case FFEINFO_kindtypeREAL2
:
3520 error
= ffetarget_multiply_real2 (ffebld_cu_ptr_real2 (u
),
3521 ffebld_constant_real2 (ffebld_conter (l
)),
3522 ffebld_constant_real2 (ffebld_conter (r
)));
3523 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3524 (ffebld_cu_val_real2 (u
)), expr
);
3528 #if FFETARGET_okREAL3
3529 case FFEINFO_kindtypeREAL3
:
3530 error
= ffetarget_multiply_real3 (ffebld_cu_ptr_real3 (u
),
3531 ffebld_constant_real3 (ffebld_conter (l
)),
3532 ffebld_constant_real3 (ffebld_conter (r
)));
3533 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3534 (ffebld_cu_val_real3 (u
)), expr
);
3539 assert ("bad real kind type" == NULL
);
3544 case FFEINFO_basictypeCOMPLEX
:
3545 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
3547 #if FFETARGET_okCOMPLEX1
3548 case FFEINFO_kindtypeREAL1
:
3549 error
= ffetarget_multiply_complex1 (ffebld_cu_ptr_complex1 (u
),
3550 ffebld_constant_complex1 (ffebld_conter (l
)),
3551 ffebld_constant_complex1 (ffebld_conter (r
)));
3552 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3553 (ffebld_cu_val_complex1 (u
)), expr
);
3557 #if FFETARGET_okCOMPLEX2
3558 case FFEINFO_kindtypeREAL2
:
3559 error
= ffetarget_multiply_complex2 (ffebld_cu_ptr_complex2 (u
),
3560 ffebld_constant_complex2 (ffebld_conter (l
)),
3561 ffebld_constant_complex2 (ffebld_conter (r
)));
3562 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3563 (ffebld_cu_val_complex2 (u
)), expr
);
3567 #if FFETARGET_okCOMPLEX3
3568 case FFEINFO_kindtypeREAL3
:
3569 error
= ffetarget_multiply_complex3 (ffebld_cu_ptr_complex3 (u
),
3570 ffebld_constant_complex3 (ffebld_conter (l
)),
3571 ffebld_constant_complex3 (ffebld_conter (r
)));
3572 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3573 (ffebld_cu_val_complex3 (u
)), expr
);
3578 assert ("bad complex kind type" == NULL
);
3584 assert ("bad type" == NULL
);
3588 ffebld_set_info (expr
, ffeinfo_new
3593 FFEINFO_whereCONSTANT
,
3594 FFETARGET_charactersizeNONE
));
3596 if ((error
!= FFEBAD
)
3597 && ffebad_start (error
))
3599 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
3606 /* ffeexpr_collapse_divide -- Collapse divide expr
3610 expr = ffeexpr_collapse_divide(expr,token);
3612 If the result of the expr is a constant, replaces the expr with the
3613 computed constant. */
3616 ffeexpr_collapse_divide (ffebld expr
, ffelexToken t
)
3618 ffebad error
= FFEBAD
;
3621 ffebldConstantUnion u
;
3622 ffeinfoBasictype bt
;
3625 if (ffeinfo_where (ffebld_info (expr
)) != FFEINFO_whereCONSTANT
)
3628 l
= ffebld_left (expr
);
3629 r
= ffebld_right (expr
);
3631 if (ffebld_op (l
) != FFEBLD_opCONTER
)
3633 if (ffebld_op (r
) != FFEBLD_opCONTER
)
3636 switch (bt
= ffeinfo_basictype (ffebld_info (expr
)))
3638 case FFEINFO_basictypeANY
:
3641 case FFEINFO_basictypeINTEGER
:
3642 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
3644 #if FFETARGET_okINTEGER1
3645 case FFEINFO_kindtypeINTEGER1
:
3646 error
= ffetarget_divide_integer1 (ffebld_cu_ptr_integer1 (u
),
3647 ffebld_constant_integer1 (ffebld_conter (l
)),
3648 ffebld_constant_integer1 (ffebld_conter (r
)));
3649 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
3650 (ffebld_cu_val_integer1 (u
)), expr
);
3654 #if FFETARGET_okINTEGER2
3655 case FFEINFO_kindtypeINTEGER2
:
3656 error
= ffetarget_divide_integer2 (ffebld_cu_ptr_integer2 (u
),
3657 ffebld_constant_integer2 (ffebld_conter (l
)),
3658 ffebld_constant_integer2 (ffebld_conter (r
)));
3659 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
3660 (ffebld_cu_val_integer2 (u
)), expr
);
3664 #if FFETARGET_okINTEGER3
3665 case FFEINFO_kindtypeINTEGER3
:
3666 error
= ffetarget_divide_integer3 (ffebld_cu_ptr_integer3 (u
),
3667 ffebld_constant_integer3 (ffebld_conter (l
)),
3668 ffebld_constant_integer3 (ffebld_conter (r
)));
3669 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
3670 (ffebld_cu_val_integer3 (u
)), expr
);
3674 #if FFETARGET_okINTEGER4
3675 case FFEINFO_kindtypeINTEGER4
:
3676 error
= ffetarget_divide_integer4 (ffebld_cu_ptr_integer4 (u
),
3677 ffebld_constant_integer4 (ffebld_conter (l
)),
3678 ffebld_constant_integer4 (ffebld_conter (r
)));
3679 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
3680 (ffebld_cu_val_integer4 (u
)), expr
);
3685 assert ("bad integer kind type" == NULL
);
3690 case FFEINFO_basictypeREAL
:
3691 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
3693 #if FFETARGET_okREAL1
3694 case FFEINFO_kindtypeREAL1
:
3695 error
= ffetarget_divide_real1 (ffebld_cu_ptr_real1 (u
),
3696 ffebld_constant_real1 (ffebld_conter (l
)),
3697 ffebld_constant_real1 (ffebld_conter (r
)));
3698 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
3699 (ffebld_cu_val_real1 (u
)), expr
);
3703 #if FFETARGET_okREAL2
3704 case FFEINFO_kindtypeREAL2
:
3705 error
= ffetarget_divide_real2 (ffebld_cu_ptr_real2 (u
),
3706 ffebld_constant_real2 (ffebld_conter (l
)),
3707 ffebld_constant_real2 (ffebld_conter (r
)));
3708 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
3709 (ffebld_cu_val_real2 (u
)), expr
);
3713 #if FFETARGET_okREAL3
3714 case FFEINFO_kindtypeREAL3
:
3715 error
= ffetarget_divide_real3 (ffebld_cu_ptr_real3 (u
),
3716 ffebld_constant_real3 (ffebld_conter (l
)),
3717 ffebld_constant_real3 (ffebld_conter (r
)));
3718 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
3719 (ffebld_cu_val_real3 (u
)), expr
);
3724 assert ("bad real kind type" == NULL
);
3729 case FFEINFO_basictypeCOMPLEX
:
3730 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
3732 #if FFETARGET_okCOMPLEX1
3733 case FFEINFO_kindtypeREAL1
:
3734 error
= ffetarget_divide_complex1 (ffebld_cu_ptr_complex1 (u
),
3735 ffebld_constant_complex1 (ffebld_conter (l
)),
3736 ffebld_constant_complex1 (ffebld_conter (r
)));
3737 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
3738 (ffebld_cu_val_complex1 (u
)), expr
);
3742 #if FFETARGET_okCOMPLEX2
3743 case FFEINFO_kindtypeREAL2
:
3744 error
= ffetarget_divide_complex2 (ffebld_cu_ptr_complex2 (u
),
3745 ffebld_constant_complex2 (ffebld_conter (l
)),
3746 ffebld_constant_complex2 (ffebld_conter (r
)));
3747 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
3748 (ffebld_cu_val_complex2 (u
)), expr
);
3752 #if FFETARGET_okCOMPLEX3
3753 case FFEINFO_kindtypeREAL3
:
3754 error
= ffetarget_divide_complex3 (ffebld_cu_ptr_complex3 (u
),
3755 ffebld_constant_complex3 (ffebld_conter (l
)),
3756 ffebld_constant_complex3 (ffebld_conter (r
)));
3757 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
3758 (ffebld_cu_val_complex3 (u
)), expr
);
3763 assert ("bad complex kind type" == NULL
);
3769 assert ("bad type" == NULL
);
3773 ffebld_set_info (expr
, ffeinfo_new
3778 FFEINFO_whereCONSTANT
,
3779 FFETARGET_charactersizeNONE
));
3781 if ((error
!= FFEBAD
)
3782 && ffebad_start (error
))
3784 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
3791 /* ffeexpr_collapse_power -- Collapse power expr
3795 expr = ffeexpr_collapse_power(expr,token);
3797 If the result of the expr is a constant, replaces the expr with the
3798 computed constant. */
3801 ffeexpr_collapse_power (ffebld expr
, ffelexToken t
)
3803 ffebad error
= FFEBAD
;
3806 ffebldConstantUnion u
;
3807 ffeinfoBasictype bt
;
3810 if (ffeinfo_where (ffebld_info (expr
)) != FFEINFO_whereCONSTANT
)
3813 l
= ffebld_left (expr
);
3814 r
= ffebld_right (expr
);
3816 if (ffebld_op (l
) != FFEBLD_opCONTER
)
3818 if (ffebld_op (r
) != FFEBLD_opCONTER
)
3821 if ((ffeinfo_basictype (ffebld_info (r
)) != FFEINFO_basictypeINTEGER
)
3822 || (ffeinfo_kindtype (ffebld_info (r
)) != FFEINFO_kindtypeINTEGERDEFAULT
))
3825 switch (bt
= ffeinfo_basictype (ffebld_info (expr
)))
3827 case FFEINFO_basictypeANY
:
3830 case FFEINFO_basictypeINTEGER
:
3831 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
3833 case FFEINFO_kindtypeINTEGERDEFAULT
:
3834 error
= ffetarget_power_integerdefault_integerdefault
3835 (ffebld_cu_ptr_integerdefault (u
),
3836 ffebld_constant_integerdefault (ffebld_conter (l
)),
3837 ffebld_constant_integerdefault (ffebld_conter (r
)));
3838 expr
= ffebld_new_conter_with_orig
3839 (ffebld_constant_new_integerdefault_val
3840 (ffebld_cu_val_integerdefault (u
)), expr
);
3844 assert ("bad integer kind type" == NULL
);
3849 case FFEINFO_basictypeREAL
:
3850 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
3852 case FFEINFO_kindtypeREALDEFAULT
:
3853 error
= ffetarget_power_realdefault_integerdefault
3854 (ffebld_cu_ptr_realdefault (u
),
3855 ffebld_constant_realdefault (ffebld_conter (l
)),
3856 ffebld_constant_integerdefault (ffebld_conter (r
)));
3857 expr
= ffebld_new_conter_with_orig
3858 (ffebld_constant_new_realdefault_val
3859 (ffebld_cu_val_realdefault (u
)), expr
);
3862 case FFEINFO_kindtypeREALDOUBLE
:
3863 error
= ffetarget_power_realdouble_integerdefault
3864 (ffebld_cu_ptr_realdouble (u
),
3865 ffebld_constant_realdouble (ffebld_conter (l
)),
3866 ffebld_constant_integerdefault (ffebld_conter (r
)));
3867 expr
= ffebld_new_conter_with_orig
3868 (ffebld_constant_new_realdouble_val
3869 (ffebld_cu_val_realdouble (u
)), expr
);
3872 #if FFETARGET_okREALQUAD
3873 case FFEINFO_kindtypeREALQUAD
:
3874 error
= ffetarget_power_realquad_integerdefault
3875 (ffebld_cu_ptr_realquad (u
),
3876 ffebld_constant_realquad (ffebld_conter (l
)),
3877 ffebld_constant_integerdefault (ffebld_conter (r
)));
3878 expr
= ffebld_new_conter_with_orig
3879 (ffebld_constant_new_realquad_val
3880 (ffebld_cu_val_realquad (u
)), expr
);
3884 assert ("bad real kind type" == NULL
);
3889 case FFEINFO_basictypeCOMPLEX
:
3890 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
3892 case FFEINFO_kindtypeREALDEFAULT
:
3893 error
= ffetarget_power_complexdefault_integerdefault
3894 (ffebld_cu_ptr_complexdefault (u
),
3895 ffebld_constant_complexdefault (ffebld_conter (l
)),
3896 ffebld_constant_integerdefault (ffebld_conter (r
)));
3897 expr
= ffebld_new_conter_with_orig
3898 (ffebld_constant_new_complexdefault_val
3899 (ffebld_cu_val_complexdefault (u
)), expr
);
3902 #if FFETARGET_okCOMPLEXDOUBLE
3903 case FFEINFO_kindtypeREALDOUBLE
:
3904 error
= ffetarget_power_complexdouble_integerdefault
3905 (ffebld_cu_ptr_complexdouble (u
),
3906 ffebld_constant_complexdouble (ffebld_conter (l
)),
3907 ffebld_constant_integerdefault (ffebld_conter (r
)));
3908 expr
= ffebld_new_conter_with_orig
3909 (ffebld_constant_new_complexdouble_val
3910 (ffebld_cu_val_complexdouble (u
)), expr
);
3914 #if FFETARGET_okCOMPLEXQUAD
3915 case FFEINFO_kindtypeREALQUAD
:
3916 error
= ffetarget_power_complexquad_integerdefault
3917 (ffebld_cu_ptr_complexquad (u
),
3918 ffebld_constant_complexquad (ffebld_conter (l
)),
3919 ffebld_constant_integerdefault (ffebld_conter (r
)));
3920 expr
= ffebld_new_conter_with_orig
3921 (ffebld_constant_new_complexquad_val
3922 (ffebld_cu_val_complexquad (u
)), expr
);
3927 assert ("bad complex kind type" == NULL
);
3933 assert ("bad type" == NULL
);
3937 ffebld_set_info (expr
, ffeinfo_new
3942 FFEINFO_whereCONSTANT
,
3943 FFETARGET_charactersizeNONE
));
3945 if ((error
!= FFEBAD
)
3946 && ffebad_start (error
))
3948 ffebad_here (0, ffelex_token_where_line (t
),
3949 ffelex_token_where_column (t
));
3956 /* ffeexpr_collapse_concatenate -- Collapse concatenate expr
3960 expr = ffeexpr_collapse_concatenate(expr,token);
3962 If the result of the expr is a constant, replaces the expr with the
3963 computed constant. */
3966 ffeexpr_collapse_concatenate (ffebld expr
, ffelexToken t
)
3968 ffebad error
= FFEBAD
;
3971 ffebldConstantUnion u
;
3973 ffetargetCharacterSize len
;
3975 if (ffeinfo_where (ffebld_info (expr
)) != FFEINFO_whereCONSTANT
)
3978 l
= ffebld_left (expr
);
3979 r
= ffebld_right (expr
);
3981 if (ffebld_op (l
) != FFEBLD_opCONTER
)
3983 if (ffebld_op (r
) != FFEBLD_opCONTER
)
3986 switch (ffeinfo_basictype (ffebld_info (expr
)))
3988 case FFEINFO_basictypeANY
:
3991 case FFEINFO_basictypeCHARACTER
:
3992 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
3994 #if FFETARGET_okCHARACTER1
3995 case FFEINFO_kindtypeCHARACTER1
:
3996 error
= ffetarget_concatenate_character1 (ffebld_cu_ptr_character1 (u
),
3997 ffebld_constant_character1 (ffebld_conter (l
)),
3998 ffebld_constant_character1 (ffebld_conter (r
)),
3999 ffebld_constant_pool (), &len
);
4000 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
4001 (ffebld_cu_val_character1 (u
)), expr
);
4006 assert ("bad character kind type" == NULL
);
4012 assert ("bad type" == NULL
);
4016 ffebld_set_info (expr
, ffeinfo_new
4017 (FFEINFO_basictypeCHARACTER
,
4021 FFEINFO_whereCONSTANT
,
4024 if ((error
!= FFEBAD
)
4025 && ffebad_start (error
))
4027 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
4034 /* ffeexpr_collapse_eq -- Collapse eq expr
4038 expr = ffeexpr_collapse_eq(expr,token);
4040 If the result of the expr is a constant, replaces the expr with the
4041 computed constant. */
4044 ffeexpr_collapse_eq (ffebld expr
, ffelexToken t
)
4046 ffebad error
= FFEBAD
;
4051 if (ffeinfo_where (ffebld_info (expr
)) != FFEINFO_whereCONSTANT
)
4054 l
= ffebld_left (expr
);
4055 r
= ffebld_right (expr
);
4057 if (ffebld_op (l
) != FFEBLD_opCONTER
)
4059 if (ffebld_op (r
) != FFEBLD_opCONTER
)
4062 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr
))))
4064 case FFEINFO_basictypeANY
:
4067 case FFEINFO_basictypeINTEGER
:
4068 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr
))))
4070 #if FFETARGET_okINTEGER1
4071 case FFEINFO_kindtypeINTEGER1
:
4072 error
= ffetarget_eq_integer1 (&val
,
4073 ffebld_constant_integer1 (ffebld_conter (l
)),
4074 ffebld_constant_integer1 (ffebld_conter (r
)));
4075 expr
= ffebld_new_conter_with_orig
4076 (ffebld_constant_new_logicaldefault (val
), expr
);
4080 #if FFETARGET_okINTEGER2
4081 case FFEINFO_kindtypeINTEGER2
:
4082 error
= ffetarget_eq_integer2 (&val
,
4083 ffebld_constant_integer2 (ffebld_conter (l
)),
4084 ffebld_constant_integer2 (ffebld_conter (r
)));
4085 expr
= ffebld_new_conter_with_orig
4086 (ffebld_constant_new_logicaldefault (val
), expr
);
4090 #if FFETARGET_okINTEGER3
4091 case FFEINFO_kindtypeINTEGER3
:
4092 error
= ffetarget_eq_integer3 (&val
,
4093 ffebld_constant_integer3 (ffebld_conter (l
)),
4094 ffebld_constant_integer3 (ffebld_conter (r
)));
4095 expr
= ffebld_new_conter_with_orig
4096 (ffebld_constant_new_logicaldefault (val
), expr
);
4100 #if FFETARGET_okINTEGER4
4101 case FFEINFO_kindtypeINTEGER4
:
4102 error
= ffetarget_eq_integer4 (&val
,
4103 ffebld_constant_integer4 (ffebld_conter (l
)),
4104 ffebld_constant_integer4 (ffebld_conter (r
)));
4105 expr
= ffebld_new_conter_with_orig
4106 (ffebld_constant_new_logicaldefault (val
), expr
);
4111 assert ("bad integer kind type" == NULL
);
4116 case FFEINFO_basictypeREAL
:
4117 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr
))))
4119 #if FFETARGET_okREAL1
4120 case FFEINFO_kindtypeREAL1
:
4121 error
= ffetarget_eq_real1 (&val
,
4122 ffebld_constant_real1 (ffebld_conter (l
)),
4123 ffebld_constant_real1 (ffebld_conter (r
)));
4124 expr
= ffebld_new_conter_with_orig
4125 (ffebld_constant_new_logicaldefault (val
), expr
);
4129 #if FFETARGET_okREAL2
4130 case FFEINFO_kindtypeREAL2
:
4131 error
= ffetarget_eq_real2 (&val
,
4132 ffebld_constant_real2 (ffebld_conter (l
)),
4133 ffebld_constant_real2 (ffebld_conter (r
)));
4134 expr
= ffebld_new_conter_with_orig
4135 (ffebld_constant_new_logicaldefault (val
), expr
);
4139 #if FFETARGET_okREAL3
4140 case FFEINFO_kindtypeREAL3
:
4141 error
= ffetarget_eq_real3 (&val
,
4142 ffebld_constant_real3 (ffebld_conter (l
)),
4143 ffebld_constant_real3 (ffebld_conter (r
)));
4144 expr
= ffebld_new_conter_with_orig
4145 (ffebld_constant_new_logicaldefault (val
), expr
);
4150 assert ("bad real kind type" == NULL
);
4155 case FFEINFO_basictypeCOMPLEX
:
4156 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr
))))
4158 #if FFETARGET_okCOMPLEX1
4159 case FFEINFO_kindtypeREAL1
:
4160 error
= ffetarget_eq_complex1 (&val
,
4161 ffebld_constant_complex1 (ffebld_conter (l
)),
4162 ffebld_constant_complex1 (ffebld_conter (r
)));
4163 expr
= ffebld_new_conter_with_orig
4164 (ffebld_constant_new_logicaldefault (val
), expr
);
4168 #if FFETARGET_okCOMPLEX2
4169 case FFEINFO_kindtypeREAL2
:
4170 error
= ffetarget_eq_complex2 (&val
,
4171 ffebld_constant_complex2 (ffebld_conter (l
)),
4172 ffebld_constant_complex2 (ffebld_conter (r
)));
4173 expr
= ffebld_new_conter_with_orig
4174 (ffebld_constant_new_logicaldefault (val
), expr
);
4178 #if FFETARGET_okCOMPLEX3
4179 case FFEINFO_kindtypeREAL3
:
4180 error
= ffetarget_eq_complex3 (&val
,
4181 ffebld_constant_complex3 (ffebld_conter (l
)),
4182 ffebld_constant_complex3 (ffebld_conter (r
)));
4183 expr
= ffebld_new_conter_with_orig
4184 (ffebld_constant_new_logicaldefault (val
), expr
);
4189 assert ("bad complex kind type" == NULL
);
4194 case FFEINFO_basictypeCHARACTER
:
4195 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr
))))
4197 #if FFETARGET_okCHARACTER1
4198 case FFEINFO_kindtypeCHARACTER1
:
4199 error
= ffetarget_eq_character1 (&val
,
4200 ffebld_constant_character1 (ffebld_conter (l
)),
4201 ffebld_constant_character1 (ffebld_conter (r
)));
4202 expr
= ffebld_new_conter_with_orig
4203 (ffebld_constant_new_logicaldefault (val
), expr
);
4208 assert ("bad character kind type" == NULL
);
4214 assert ("bad type" == NULL
);
4218 ffebld_set_info (expr
, ffeinfo_new
4219 (FFEINFO_basictypeLOGICAL
,
4220 FFEINFO_kindtypeLOGICALDEFAULT
,
4223 FFEINFO_whereCONSTANT
,
4224 FFETARGET_charactersizeNONE
));
4226 if ((error
!= FFEBAD
)
4227 && ffebad_start (error
))
4229 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
4236 /* ffeexpr_collapse_ne -- Collapse ne expr
4240 expr = ffeexpr_collapse_ne(expr,token);
4242 If the result of the expr is a constant, replaces the expr with the
4243 computed constant. */
4246 ffeexpr_collapse_ne (ffebld expr
, ffelexToken t
)
4248 ffebad error
= FFEBAD
;
4253 if (ffeinfo_where (ffebld_info (expr
)) != FFEINFO_whereCONSTANT
)
4256 l
= ffebld_left (expr
);
4257 r
= ffebld_right (expr
);
4259 if (ffebld_op (l
) != FFEBLD_opCONTER
)
4261 if (ffebld_op (r
) != FFEBLD_opCONTER
)
4264 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr
))))
4266 case FFEINFO_basictypeANY
:
4269 case FFEINFO_basictypeINTEGER
:
4270 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr
))))
4272 #if FFETARGET_okINTEGER1
4273 case FFEINFO_kindtypeINTEGER1
:
4274 error
= ffetarget_ne_integer1 (&val
,
4275 ffebld_constant_integer1 (ffebld_conter (l
)),
4276 ffebld_constant_integer1 (ffebld_conter (r
)));
4277 expr
= ffebld_new_conter_with_orig
4278 (ffebld_constant_new_logicaldefault (val
), expr
);
4282 #if FFETARGET_okINTEGER2
4283 case FFEINFO_kindtypeINTEGER2
:
4284 error
= ffetarget_ne_integer2 (&val
,
4285 ffebld_constant_integer2 (ffebld_conter (l
)),
4286 ffebld_constant_integer2 (ffebld_conter (r
)));
4287 expr
= ffebld_new_conter_with_orig
4288 (ffebld_constant_new_logicaldefault (val
), expr
);
4292 #if FFETARGET_okINTEGER3
4293 case FFEINFO_kindtypeINTEGER3
:
4294 error
= ffetarget_ne_integer3 (&val
,
4295 ffebld_constant_integer3 (ffebld_conter (l
)),
4296 ffebld_constant_integer3 (ffebld_conter (r
)));
4297 expr
= ffebld_new_conter_with_orig
4298 (ffebld_constant_new_logicaldefault (val
), expr
);
4302 #if FFETARGET_okINTEGER4
4303 case FFEINFO_kindtypeINTEGER4
:
4304 error
= ffetarget_ne_integer4 (&val
,
4305 ffebld_constant_integer4 (ffebld_conter (l
)),
4306 ffebld_constant_integer4 (ffebld_conter (r
)));
4307 expr
= ffebld_new_conter_with_orig
4308 (ffebld_constant_new_logicaldefault (val
), expr
);
4313 assert ("bad integer kind type" == NULL
);
4318 case FFEINFO_basictypeREAL
:
4319 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr
))))
4321 #if FFETARGET_okREAL1
4322 case FFEINFO_kindtypeREAL1
:
4323 error
= ffetarget_ne_real1 (&val
,
4324 ffebld_constant_real1 (ffebld_conter (l
)),
4325 ffebld_constant_real1 (ffebld_conter (r
)));
4326 expr
= ffebld_new_conter_with_orig
4327 (ffebld_constant_new_logicaldefault (val
), expr
);
4331 #if FFETARGET_okREAL2
4332 case FFEINFO_kindtypeREAL2
:
4333 error
= ffetarget_ne_real2 (&val
,
4334 ffebld_constant_real2 (ffebld_conter (l
)),
4335 ffebld_constant_real2 (ffebld_conter (r
)));
4336 expr
= ffebld_new_conter_with_orig
4337 (ffebld_constant_new_logicaldefault (val
), expr
);
4341 #if FFETARGET_okREAL3
4342 case FFEINFO_kindtypeREAL3
:
4343 error
= ffetarget_ne_real3 (&val
,
4344 ffebld_constant_real3 (ffebld_conter (l
)),
4345 ffebld_constant_real3 (ffebld_conter (r
)));
4346 expr
= ffebld_new_conter_with_orig
4347 (ffebld_constant_new_logicaldefault (val
), expr
);
4352 assert ("bad real kind type" == NULL
);
4357 case FFEINFO_basictypeCOMPLEX
:
4358 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr
))))
4360 #if FFETARGET_okCOMPLEX1
4361 case FFEINFO_kindtypeREAL1
:
4362 error
= ffetarget_ne_complex1 (&val
,
4363 ffebld_constant_complex1 (ffebld_conter (l
)),
4364 ffebld_constant_complex1 (ffebld_conter (r
)));
4365 expr
= ffebld_new_conter_with_orig
4366 (ffebld_constant_new_logicaldefault (val
), expr
);
4370 #if FFETARGET_okCOMPLEX2
4371 case FFEINFO_kindtypeREAL2
:
4372 error
= ffetarget_ne_complex2 (&val
,
4373 ffebld_constant_complex2 (ffebld_conter (l
)),
4374 ffebld_constant_complex2 (ffebld_conter (r
)));
4375 expr
= ffebld_new_conter_with_orig
4376 (ffebld_constant_new_logicaldefault (val
), expr
);
4380 #if FFETARGET_okCOMPLEX3
4381 case FFEINFO_kindtypeREAL3
:
4382 error
= ffetarget_ne_complex3 (&val
,
4383 ffebld_constant_complex3 (ffebld_conter (l
)),
4384 ffebld_constant_complex3 (ffebld_conter (r
)));
4385 expr
= ffebld_new_conter_with_orig
4386 (ffebld_constant_new_logicaldefault (val
), expr
);
4391 assert ("bad complex kind type" == NULL
);
4396 case FFEINFO_basictypeCHARACTER
:
4397 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr
))))
4399 #if FFETARGET_okCHARACTER1
4400 case FFEINFO_kindtypeCHARACTER1
:
4401 error
= ffetarget_ne_character1 (&val
,
4402 ffebld_constant_character1 (ffebld_conter (l
)),
4403 ffebld_constant_character1 (ffebld_conter (r
)));
4404 expr
= ffebld_new_conter_with_orig
4405 (ffebld_constant_new_logicaldefault (val
), expr
);
4410 assert ("bad character kind type" == NULL
);
4416 assert ("bad type" == NULL
);
4420 ffebld_set_info (expr
, ffeinfo_new
4421 (FFEINFO_basictypeLOGICAL
,
4422 FFEINFO_kindtypeLOGICALDEFAULT
,
4425 FFEINFO_whereCONSTANT
,
4426 FFETARGET_charactersizeNONE
));
4428 if ((error
!= FFEBAD
)
4429 && ffebad_start (error
))
4431 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
4438 /* ffeexpr_collapse_ge -- Collapse ge expr
4442 expr = ffeexpr_collapse_ge(expr,token);
4444 If the result of the expr is a constant, replaces the expr with the
4445 computed constant. */
4448 ffeexpr_collapse_ge (ffebld expr
, ffelexToken t
)
4450 ffebad error
= FFEBAD
;
4455 if (ffeinfo_where (ffebld_info (expr
)) != FFEINFO_whereCONSTANT
)
4458 l
= ffebld_left (expr
);
4459 r
= ffebld_right (expr
);
4461 if (ffebld_op (l
) != FFEBLD_opCONTER
)
4463 if (ffebld_op (r
) != FFEBLD_opCONTER
)
4466 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr
))))
4468 case FFEINFO_basictypeANY
:
4471 case FFEINFO_basictypeINTEGER
:
4472 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr
))))
4474 #if FFETARGET_okINTEGER1
4475 case FFEINFO_kindtypeINTEGER1
:
4476 error
= ffetarget_ge_integer1 (&val
,
4477 ffebld_constant_integer1 (ffebld_conter (l
)),
4478 ffebld_constant_integer1 (ffebld_conter (r
)));
4479 expr
= ffebld_new_conter_with_orig
4480 (ffebld_constant_new_logicaldefault (val
), expr
);
4484 #if FFETARGET_okINTEGER2
4485 case FFEINFO_kindtypeINTEGER2
:
4486 error
= ffetarget_ge_integer2 (&val
,
4487 ffebld_constant_integer2 (ffebld_conter (l
)),
4488 ffebld_constant_integer2 (ffebld_conter (r
)));
4489 expr
= ffebld_new_conter_with_orig
4490 (ffebld_constant_new_logicaldefault (val
), expr
);
4494 #if FFETARGET_okINTEGER3
4495 case FFEINFO_kindtypeINTEGER3
:
4496 error
= ffetarget_ge_integer3 (&val
,
4497 ffebld_constant_integer3 (ffebld_conter (l
)),
4498 ffebld_constant_integer3 (ffebld_conter (r
)));
4499 expr
= ffebld_new_conter_with_orig
4500 (ffebld_constant_new_logicaldefault (val
), expr
);
4504 #if FFETARGET_okINTEGER4
4505 case FFEINFO_kindtypeINTEGER4
:
4506 error
= ffetarget_ge_integer4 (&val
,
4507 ffebld_constant_integer4 (ffebld_conter (l
)),
4508 ffebld_constant_integer4 (ffebld_conter (r
)));
4509 expr
= ffebld_new_conter_with_orig
4510 (ffebld_constant_new_logicaldefault (val
), expr
);
4515 assert ("bad integer kind type" == NULL
);
4520 case FFEINFO_basictypeREAL
:
4521 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr
))))
4523 #if FFETARGET_okREAL1
4524 case FFEINFO_kindtypeREAL1
:
4525 error
= ffetarget_ge_real1 (&val
,
4526 ffebld_constant_real1 (ffebld_conter (l
)),
4527 ffebld_constant_real1 (ffebld_conter (r
)));
4528 expr
= ffebld_new_conter_with_orig
4529 (ffebld_constant_new_logicaldefault (val
), expr
);
4533 #if FFETARGET_okREAL2
4534 case FFEINFO_kindtypeREAL2
:
4535 error
= ffetarget_ge_real2 (&val
,
4536 ffebld_constant_real2 (ffebld_conter (l
)),
4537 ffebld_constant_real2 (ffebld_conter (r
)));
4538 expr
= ffebld_new_conter_with_orig
4539 (ffebld_constant_new_logicaldefault (val
), expr
);
4543 #if FFETARGET_okREAL3
4544 case FFEINFO_kindtypeREAL3
:
4545 error
= ffetarget_ge_real3 (&val
,
4546 ffebld_constant_real3 (ffebld_conter (l
)),
4547 ffebld_constant_real3 (ffebld_conter (r
)));
4548 expr
= ffebld_new_conter_with_orig
4549 (ffebld_constant_new_logicaldefault (val
), expr
);
4554 assert ("bad real kind type" == NULL
);
4559 case FFEINFO_basictypeCHARACTER
:
4560 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr
))))
4562 #if FFETARGET_okCHARACTER1
4563 case FFEINFO_kindtypeCHARACTER1
:
4564 error
= ffetarget_ge_character1 (&val
,
4565 ffebld_constant_character1 (ffebld_conter (l
)),
4566 ffebld_constant_character1 (ffebld_conter (r
)));
4567 expr
= ffebld_new_conter_with_orig
4568 (ffebld_constant_new_logicaldefault (val
), expr
);
4573 assert ("bad character kind type" == NULL
);
4579 assert ("bad type" == NULL
);
4583 ffebld_set_info (expr
, ffeinfo_new
4584 (FFEINFO_basictypeLOGICAL
,
4585 FFEINFO_kindtypeLOGICALDEFAULT
,
4588 FFEINFO_whereCONSTANT
,
4589 FFETARGET_charactersizeNONE
));
4591 if ((error
!= FFEBAD
)
4592 && ffebad_start (error
))
4594 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
4601 /* ffeexpr_collapse_gt -- Collapse gt expr
4605 expr = ffeexpr_collapse_gt(expr,token);
4607 If the result of the expr is a constant, replaces the expr with the
4608 computed constant. */
4611 ffeexpr_collapse_gt (ffebld expr
, ffelexToken t
)
4613 ffebad error
= FFEBAD
;
4618 if (ffeinfo_where (ffebld_info (expr
)) != FFEINFO_whereCONSTANT
)
4621 l
= ffebld_left (expr
);
4622 r
= ffebld_right (expr
);
4624 if (ffebld_op (l
) != FFEBLD_opCONTER
)
4626 if (ffebld_op (r
) != FFEBLD_opCONTER
)
4629 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr
))))
4631 case FFEINFO_basictypeANY
:
4634 case FFEINFO_basictypeINTEGER
:
4635 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr
))))
4637 #if FFETARGET_okINTEGER1
4638 case FFEINFO_kindtypeINTEGER1
:
4639 error
= ffetarget_gt_integer1 (&val
,
4640 ffebld_constant_integer1 (ffebld_conter (l
)),
4641 ffebld_constant_integer1 (ffebld_conter (r
)));
4642 expr
= ffebld_new_conter_with_orig
4643 (ffebld_constant_new_logicaldefault (val
), expr
);
4647 #if FFETARGET_okINTEGER2
4648 case FFEINFO_kindtypeINTEGER2
:
4649 error
= ffetarget_gt_integer2 (&val
,
4650 ffebld_constant_integer2 (ffebld_conter (l
)),
4651 ffebld_constant_integer2 (ffebld_conter (r
)));
4652 expr
= ffebld_new_conter_with_orig
4653 (ffebld_constant_new_logicaldefault (val
), expr
);
4657 #if FFETARGET_okINTEGER3
4658 case FFEINFO_kindtypeINTEGER3
:
4659 error
= ffetarget_gt_integer3 (&val
,
4660 ffebld_constant_integer3 (ffebld_conter (l
)),
4661 ffebld_constant_integer3 (ffebld_conter (r
)));
4662 expr
= ffebld_new_conter_with_orig
4663 (ffebld_constant_new_logicaldefault (val
), expr
);
4667 #if FFETARGET_okINTEGER4
4668 case FFEINFO_kindtypeINTEGER4
:
4669 error
= ffetarget_gt_integer4 (&val
,
4670 ffebld_constant_integer4 (ffebld_conter (l
)),
4671 ffebld_constant_integer4 (ffebld_conter (r
)));
4672 expr
= ffebld_new_conter_with_orig
4673 (ffebld_constant_new_logicaldefault (val
), expr
);
4678 assert ("bad integer kind type" == NULL
);
4683 case FFEINFO_basictypeREAL
:
4684 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr
))))
4686 #if FFETARGET_okREAL1
4687 case FFEINFO_kindtypeREAL1
:
4688 error
= ffetarget_gt_real1 (&val
,
4689 ffebld_constant_real1 (ffebld_conter (l
)),
4690 ffebld_constant_real1 (ffebld_conter (r
)));
4691 expr
= ffebld_new_conter_with_orig
4692 (ffebld_constant_new_logicaldefault (val
), expr
);
4696 #if FFETARGET_okREAL2
4697 case FFEINFO_kindtypeREAL2
:
4698 error
= ffetarget_gt_real2 (&val
,
4699 ffebld_constant_real2 (ffebld_conter (l
)),
4700 ffebld_constant_real2 (ffebld_conter (r
)));
4701 expr
= ffebld_new_conter_with_orig
4702 (ffebld_constant_new_logicaldefault (val
), expr
);
4706 #if FFETARGET_okREAL3
4707 case FFEINFO_kindtypeREAL3
:
4708 error
= ffetarget_gt_real3 (&val
,
4709 ffebld_constant_real3 (ffebld_conter (l
)),
4710 ffebld_constant_real3 (ffebld_conter (r
)));
4711 expr
= ffebld_new_conter_with_orig
4712 (ffebld_constant_new_logicaldefault (val
), expr
);
4717 assert ("bad real kind type" == NULL
);
4722 case FFEINFO_basictypeCHARACTER
:
4723 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr
))))
4725 #if FFETARGET_okCHARACTER1
4726 case FFEINFO_kindtypeCHARACTER1
:
4727 error
= ffetarget_gt_character1 (&val
,
4728 ffebld_constant_character1 (ffebld_conter (l
)),
4729 ffebld_constant_character1 (ffebld_conter (r
)));
4730 expr
= ffebld_new_conter_with_orig
4731 (ffebld_constant_new_logicaldefault (val
), expr
);
4736 assert ("bad character kind type" == NULL
);
4742 assert ("bad type" == NULL
);
4746 ffebld_set_info (expr
, ffeinfo_new
4747 (FFEINFO_basictypeLOGICAL
,
4748 FFEINFO_kindtypeLOGICALDEFAULT
,
4751 FFEINFO_whereCONSTANT
,
4752 FFETARGET_charactersizeNONE
));
4754 if ((error
!= FFEBAD
)
4755 && ffebad_start (error
))
4757 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
4764 /* ffeexpr_collapse_le -- Collapse le expr
4768 expr = ffeexpr_collapse_le(expr,token);
4770 If the result of the expr is a constant, replaces the expr with the
4771 computed constant. */
4774 ffeexpr_collapse_le (ffebld expr
, ffelexToken t
)
4776 ffebad error
= FFEBAD
;
4781 if (ffeinfo_where (ffebld_info (expr
)) != FFEINFO_whereCONSTANT
)
4784 l
= ffebld_left (expr
);
4785 r
= ffebld_right (expr
);
4787 if (ffebld_op (l
) != FFEBLD_opCONTER
)
4789 if (ffebld_op (r
) != FFEBLD_opCONTER
)
4792 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr
))))
4794 case FFEINFO_basictypeANY
:
4797 case FFEINFO_basictypeINTEGER
:
4798 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr
))))
4800 #if FFETARGET_okINTEGER1
4801 case FFEINFO_kindtypeINTEGER1
:
4802 error
= ffetarget_le_integer1 (&val
,
4803 ffebld_constant_integer1 (ffebld_conter (l
)),
4804 ffebld_constant_integer1 (ffebld_conter (r
)));
4805 expr
= ffebld_new_conter_with_orig
4806 (ffebld_constant_new_logicaldefault (val
), expr
);
4810 #if FFETARGET_okINTEGER2
4811 case FFEINFO_kindtypeINTEGER2
:
4812 error
= ffetarget_le_integer2 (&val
,
4813 ffebld_constant_integer2 (ffebld_conter (l
)),
4814 ffebld_constant_integer2 (ffebld_conter (r
)));
4815 expr
= ffebld_new_conter_with_orig
4816 (ffebld_constant_new_logicaldefault (val
), expr
);
4820 #if FFETARGET_okINTEGER3
4821 case FFEINFO_kindtypeINTEGER3
:
4822 error
= ffetarget_le_integer3 (&val
,
4823 ffebld_constant_integer3 (ffebld_conter (l
)),
4824 ffebld_constant_integer3 (ffebld_conter (r
)));
4825 expr
= ffebld_new_conter_with_orig
4826 (ffebld_constant_new_logicaldefault (val
), expr
);
4830 #if FFETARGET_okINTEGER4
4831 case FFEINFO_kindtypeINTEGER4
:
4832 error
= ffetarget_le_integer4 (&val
,
4833 ffebld_constant_integer4 (ffebld_conter (l
)),
4834 ffebld_constant_integer4 (ffebld_conter (r
)));
4835 expr
= ffebld_new_conter_with_orig
4836 (ffebld_constant_new_logicaldefault (val
), expr
);
4841 assert ("bad integer kind type" == NULL
);
4846 case FFEINFO_basictypeREAL
:
4847 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr
))))
4849 #if FFETARGET_okREAL1
4850 case FFEINFO_kindtypeREAL1
:
4851 error
= ffetarget_le_real1 (&val
,
4852 ffebld_constant_real1 (ffebld_conter (l
)),
4853 ffebld_constant_real1 (ffebld_conter (r
)));
4854 expr
= ffebld_new_conter_with_orig
4855 (ffebld_constant_new_logicaldefault (val
), expr
);
4859 #if FFETARGET_okREAL2
4860 case FFEINFO_kindtypeREAL2
:
4861 error
= ffetarget_le_real2 (&val
,
4862 ffebld_constant_real2 (ffebld_conter (l
)),
4863 ffebld_constant_real2 (ffebld_conter (r
)));
4864 expr
= ffebld_new_conter_with_orig
4865 (ffebld_constant_new_logicaldefault (val
), expr
);
4869 #if FFETARGET_okREAL3
4870 case FFEINFO_kindtypeREAL3
:
4871 error
= ffetarget_le_real3 (&val
,
4872 ffebld_constant_real3 (ffebld_conter (l
)),
4873 ffebld_constant_real3 (ffebld_conter (r
)));
4874 expr
= ffebld_new_conter_with_orig
4875 (ffebld_constant_new_logicaldefault (val
), expr
);
4880 assert ("bad real kind type" == NULL
);
4885 case FFEINFO_basictypeCHARACTER
:
4886 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr
))))
4888 #if FFETARGET_okCHARACTER1
4889 case FFEINFO_kindtypeCHARACTER1
:
4890 error
= ffetarget_le_character1 (&val
,
4891 ffebld_constant_character1 (ffebld_conter (l
)),
4892 ffebld_constant_character1 (ffebld_conter (r
)));
4893 expr
= ffebld_new_conter_with_orig
4894 (ffebld_constant_new_logicaldefault (val
), expr
);
4899 assert ("bad character kind type" == NULL
);
4905 assert ("bad type" == NULL
);
4909 ffebld_set_info (expr
, ffeinfo_new
4910 (FFEINFO_basictypeLOGICAL
,
4911 FFEINFO_kindtypeLOGICALDEFAULT
,
4914 FFEINFO_whereCONSTANT
,
4915 FFETARGET_charactersizeNONE
));
4917 if ((error
!= FFEBAD
)
4918 && ffebad_start (error
))
4920 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
4927 /* ffeexpr_collapse_lt -- Collapse lt expr
4931 expr = ffeexpr_collapse_lt(expr,token);
4933 If the result of the expr is a constant, replaces the expr with the
4934 computed constant. */
4937 ffeexpr_collapse_lt (ffebld expr
, ffelexToken t
)
4939 ffebad error
= FFEBAD
;
4944 if (ffeinfo_where (ffebld_info (expr
)) != FFEINFO_whereCONSTANT
)
4947 l
= ffebld_left (expr
);
4948 r
= ffebld_right (expr
);
4950 if (ffebld_op (l
) != FFEBLD_opCONTER
)
4952 if (ffebld_op (r
) != FFEBLD_opCONTER
)
4955 switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr
))))
4957 case FFEINFO_basictypeANY
:
4960 case FFEINFO_basictypeINTEGER
:
4961 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr
))))
4963 #if FFETARGET_okINTEGER1
4964 case FFEINFO_kindtypeINTEGER1
:
4965 error
= ffetarget_lt_integer1 (&val
,
4966 ffebld_constant_integer1 (ffebld_conter (l
)),
4967 ffebld_constant_integer1 (ffebld_conter (r
)));
4968 expr
= ffebld_new_conter_with_orig
4969 (ffebld_constant_new_logicaldefault (val
), expr
);
4973 #if FFETARGET_okINTEGER2
4974 case FFEINFO_kindtypeINTEGER2
:
4975 error
= ffetarget_lt_integer2 (&val
,
4976 ffebld_constant_integer2 (ffebld_conter (l
)),
4977 ffebld_constant_integer2 (ffebld_conter (r
)));
4978 expr
= ffebld_new_conter_with_orig
4979 (ffebld_constant_new_logicaldefault (val
), expr
);
4983 #if FFETARGET_okINTEGER3
4984 case FFEINFO_kindtypeINTEGER3
:
4985 error
= ffetarget_lt_integer3 (&val
,
4986 ffebld_constant_integer3 (ffebld_conter (l
)),
4987 ffebld_constant_integer3 (ffebld_conter (r
)));
4988 expr
= ffebld_new_conter_with_orig
4989 (ffebld_constant_new_logicaldefault (val
), expr
);
4993 #if FFETARGET_okINTEGER4
4994 case FFEINFO_kindtypeINTEGER4
:
4995 error
= ffetarget_lt_integer4 (&val
,
4996 ffebld_constant_integer4 (ffebld_conter (l
)),
4997 ffebld_constant_integer4 (ffebld_conter (r
)));
4998 expr
= ffebld_new_conter_with_orig
4999 (ffebld_constant_new_logicaldefault (val
), expr
);
5004 assert ("bad integer kind type" == NULL
);
5009 case FFEINFO_basictypeREAL
:
5010 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr
))))
5012 #if FFETARGET_okREAL1
5013 case FFEINFO_kindtypeREAL1
:
5014 error
= ffetarget_lt_real1 (&val
,
5015 ffebld_constant_real1 (ffebld_conter (l
)),
5016 ffebld_constant_real1 (ffebld_conter (r
)));
5017 expr
= ffebld_new_conter_with_orig
5018 (ffebld_constant_new_logicaldefault (val
), expr
);
5022 #if FFETARGET_okREAL2
5023 case FFEINFO_kindtypeREAL2
:
5024 error
= ffetarget_lt_real2 (&val
,
5025 ffebld_constant_real2 (ffebld_conter (l
)),
5026 ffebld_constant_real2 (ffebld_conter (r
)));
5027 expr
= ffebld_new_conter_with_orig
5028 (ffebld_constant_new_logicaldefault (val
), expr
);
5032 #if FFETARGET_okREAL3
5033 case FFEINFO_kindtypeREAL3
:
5034 error
= ffetarget_lt_real3 (&val
,
5035 ffebld_constant_real3 (ffebld_conter (l
)),
5036 ffebld_constant_real3 (ffebld_conter (r
)));
5037 expr
= ffebld_new_conter_with_orig
5038 (ffebld_constant_new_logicaldefault (val
), expr
);
5043 assert ("bad real kind type" == NULL
);
5048 case FFEINFO_basictypeCHARACTER
:
5049 switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr
))))
5051 #if FFETARGET_okCHARACTER1
5052 case FFEINFO_kindtypeCHARACTER1
:
5053 error
= ffetarget_lt_character1 (&val
,
5054 ffebld_constant_character1 (ffebld_conter (l
)),
5055 ffebld_constant_character1 (ffebld_conter (r
)));
5056 expr
= ffebld_new_conter_with_orig
5057 (ffebld_constant_new_logicaldefault (val
), expr
);
5062 assert ("bad character kind type" == NULL
);
5068 assert ("bad type" == NULL
);
5072 ffebld_set_info (expr
, ffeinfo_new
5073 (FFEINFO_basictypeLOGICAL
,
5074 FFEINFO_kindtypeLOGICALDEFAULT
,
5077 FFEINFO_whereCONSTANT
,
5078 FFETARGET_charactersizeNONE
));
5080 if ((error
!= FFEBAD
)
5081 && ffebad_start (error
))
5083 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
5090 /* ffeexpr_collapse_and -- Collapse and expr
5094 expr = ffeexpr_collapse_and(expr,token);
5096 If the result of the expr is a constant, replaces the expr with the
5097 computed constant. */
5100 ffeexpr_collapse_and (ffebld expr
, ffelexToken t
)
5102 ffebad error
= FFEBAD
;
5105 ffebldConstantUnion u
;
5106 ffeinfoBasictype bt
;
5109 if (ffeinfo_where (ffebld_info (expr
)) != FFEINFO_whereCONSTANT
)
5112 l
= ffebld_left (expr
);
5113 r
= ffebld_right (expr
);
5115 if (ffebld_op (l
) != FFEBLD_opCONTER
)
5117 if (ffebld_op (r
) != FFEBLD_opCONTER
)
5120 switch (bt
= ffeinfo_basictype (ffebld_info (expr
)))
5122 case FFEINFO_basictypeANY
:
5125 case FFEINFO_basictypeINTEGER
:
5126 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
5128 #if FFETARGET_okINTEGER1
5129 case FFEINFO_kindtypeINTEGER1
:
5130 error
= ffetarget_and_integer1 (ffebld_cu_ptr_integer1 (u
),
5131 ffebld_constant_integer1 (ffebld_conter (l
)),
5132 ffebld_constant_integer1 (ffebld_conter (r
)));
5133 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5134 (ffebld_cu_val_integer1 (u
)), expr
);
5138 #if FFETARGET_okINTEGER2
5139 case FFEINFO_kindtypeINTEGER2
:
5140 error
= ffetarget_and_integer2 (ffebld_cu_ptr_integer2 (u
),
5141 ffebld_constant_integer2 (ffebld_conter (l
)),
5142 ffebld_constant_integer2 (ffebld_conter (r
)));
5143 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5144 (ffebld_cu_val_integer2 (u
)), expr
);
5148 #if FFETARGET_okINTEGER3
5149 case FFEINFO_kindtypeINTEGER3
:
5150 error
= ffetarget_and_integer3 (ffebld_cu_ptr_integer3 (u
),
5151 ffebld_constant_integer3 (ffebld_conter (l
)),
5152 ffebld_constant_integer3 (ffebld_conter (r
)));
5153 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5154 (ffebld_cu_val_integer3 (u
)), expr
);
5158 #if FFETARGET_okINTEGER4
5159 case FFEINFO_kindtypeINTEGER4
:
5160 error
= ffetarget_and_integer4 (ffebld_cu_ptr_integer4 (u
),
5161 ffebld_constant_integer4 (ffebld_conter (l
)),
5162 ffebld_constant_integer4 (ffebld_conter (r
)));
5163 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5164 (ffebld_cu_val_integer4 (u
)), expr
);
5169 assert ("bad integer kind type" == NULL
);
5174 case FFEINFO_basictypeLOGICAL
:
5175 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
5177 #if FFETARGET_okLOGICAL1
5178 case FFEINFO_kindtypeLOGICAL1
:
5179 error
= ffetarget_and_logical1 (ffebld_cu_ptr_logical1 (u
),
5180 ffebld_constant_logical1 (ffebld_conter (l
)),
5181 ffebld_constant_logical1 (ffebld_conter (r
)));
5182 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5183 (ffebld_cu_val_logical1 (u
)), expr
);
5187 #if FFETARGET_okLOGICAL2
5188 case FFEINFO_kindtypeLOGICAL2
:
5189 error
= ffetarget_and_logical2 (ffebld_cu_ptr_logical2 (u
),
5190 ffebld_constant_logical2 (ffebld_conter (l
)),
5191 ffebld_constant_logical2 (ffebld_conter (r
)));
5192 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5193 (ffebld_cu_val_logical2 (u
)), expr
);
5197 #if FFETARGET_okLOGICAL3
5198 case FFEINFO_kindtypeLOGICAL3
:
5199 error
= ffetarget_and_logical3 (ffebld_cu_ptr_logical3 (u
),
5200 ffebld_constant_logical3 (ffebld_conter (l
)),
5201 ffebld_constant_logical3 (ffebld_conter (r
)));
5202 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5203 (ffebld_cu_val_logical3 (u
)), expr
);
5207 #if FFETARGET_okLOGICAL4
5208 case FFEINFO_kindtypeLOGICAL4
:
5209 error
= ffetarget_and_logical4 (ffebld_cu_ptr_logical4 (u
),
5210 ffebld_constant_logical4 (ffebld_conter (l
)),
5211 ffebld_constant_logical4 (ffebld_conter (r
)));
5212 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5213 (ffebld_cu_val_logical4 (u
)), expr
);
5218 assert ("bad logical kind type" == NULL
);
5224 assert ("bad type" == NULL
);
5228 ffebld_set_info (expr
, ffeinfo_new
5233 FFEINFO_whereCONSTANT
,
5234 FFETARGET_charactersizeNONE
));
5236 if ((error
!= FFEBAD
)
5237 && ffebad_start (error
))
5239 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
5246 /* ffeexpr_collapse_or -- Collapse or expr
5250 expr = ffeexpr_collapse_or(expr,token);
5252 If the result of the expr is a constant, replaces the expr with the
5253 computed constant. */
5256 ffeexpr_collapse_or (ffebld expr
, ffelexToken t
)
5258 ffebad error
= FFEBAD
;
5261 ffebldConstantUnion u
;
5262 ffeinfoBasictype bt
;
5265 if (ffeinfo_where (ffebld_info (expr
)) != FFEINFO_whereCONSTANT
)
5268 l
= ffebld_left (expr
);
5269 r
= ffebld_right (expr
);
5271 if (ffebld_op (l
) != FFEBLD_opCONTER
)
5273 if (ffebld_op (r
) != FFEBLD_opCONTER
)
5276 switch (bt
= ffeinfo_basictype (ffebld_info (expr
)))
5278 case FFEINFO_basictypeANY
:
5281 case FFEINFO_basictypeINTEGER
:
5282 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
5284 #if FFETARGET_okINTEGER1
5285 case FFEINFO_kindtypeINTEGER1
:
5286 error
= ffetarget_or_integer1 (ffebld_cu_ptr_integer1 (u
),
5287 ffebld_constant_integer1 (ffebld_conter (l
)),
5288 ffebld_constant_integer1 (ffebld_conter (r
)));
5289 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5290 (ffebld_cu_val_integer1 (u
)), expr
);
5294 #if FFETARGET_okINTEGER2
5295 case FFEINFO_kindtypeINTEGER2
:
5296 error
= ffetarget_or_integer2 (ffebld_cu_ptr_integer2 (u
),
5297 ffebld_constant_integer2 (ffebld_conter (l
)),
5298 ffebld_constant_integer2 (ffebld_conter (r
)));
5299 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5300 (ffebld_cu_val_integer2 (u
)), expr
);
5304 #if FFETARGET_okINTEGER3
5305 case FFEINFO_kindtypeINTEGER3
:
5306 error
= ffetarget_or_integer3 (ffebld_cu_ptr_integer3 (u
),
5307 ffebld_constant_integer3 (ffebld_conter (l
)),
5308 ffebld_constant_integer3 (ffebld_conter (r
)));
5309 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5310 (ffebld_cu_val_integer3 (u
)), expr
);
5314 #if FFETARGET_okINTEGER4
5315 case FFEINFO_kindtypeINTEGER4
:
5316 error
= ffetarget_or_integer4 (ffebld_cu_ptr_integer4 (u
),
5317 ffebld_constant_integer4 (ffebld_conter (l
)),
5318 ffebld_constant_integer4 (ffebld_conter (r
)));
5319 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5320 (ffebld_cu_val_integer4 (u
)), expr
);
5325 assert ("bad integer kind type" == NULL
);
5330 case FFEINFO_basictypeLOGICAL
:
5331 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
5333 #if FFETARGET_okLOGICAL1
5334 case FFEINFO_kindtypeLOGICAL1
:
5335 error
= ffetarget_or_logical1 (ffebld_cu_ptr_logical1 (u
),
5336 ffebld_constant_logical1 (ffebld_conter (l
)),
5337 ffebld_constant_logical1 (ffebld_conter (r
)));
5338 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5339 (ffebld_cu_val_logical1 (u
)), expr
);
5343 #if FFETARGET_okLOGICAL2
5344 case FFEINFO_kindtypeLOGICAL2
:
5345 error
= ffetarget_or_logical2 (ffebld_cu_ptr_logical2 (u
),
5346 ffebld_constant_logical2 (ffebld_conter (l
)),
5347 ffebld_constant_logical2 (ffebld_conter (r
)));
5348 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5349 (ffebld_cu_val_logical2 (u
)), expr
);
5353 #if FFETARGET_okLOGICAL3
5354 case FFEINFO_kindtypeLOGICAL3
:
5355 error
= ffetarget_or_logical3 (ffebld_cu_ptr_logical3 (u
),
5356 ffebld_constant_logical3 (ffebld_conter (l
)),
5357 ffebld_constant_logical3 (ffebld_conter (r
)));
5358 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5359 (ffebld_cu_val_logical3 (u
)), expr
);
5363 #if FFETARGET_okLOGICAL4
5364 case FFEINFO_kindtypeLOGICAL4
:
5365 error
= ffetarget_or_logical4 (ffebld_cu_ptr_logical4 (u
),
5366 ffebld_constant_logical4 (ffebld_conter (l
)),
5367 ffebld_constant_logical4 (ffebld_conter (r
)));
5368 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5369 (ffebld_cu_val_logical4 (u
)), expr
);
5374 assert ("bad logical kind type" == NULL
);
5380 assert ("bad type" == NULL
);
5384 ffebld_set_info (expr
, ffeinfo_new
5389 FFEINFO_whereCONSTANT
,
5390 FFETARGET_charactersizeNONE
));
5392 if ((error
!= FFEBAD
)
5393 && ffebad_start (error
))
5395 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
5402 /* ffeexpr_collapse_xor -- Collapse xor expr
5406 expr = ffeexpr_collapse_xor(expr,token);
5408 If the result of the expr is a constant, replaces the expr with the
5409 computed constant. */
5412 ffeexpr_collapse_xor (ffebld expr
, ffelexToken t
)
5414 ffebad error
= FFEBAD
;
5417 ffebldConstantUnion u
;
5418 ffeinfoBasictype bt
;
5421 if (ffeinfo_where (ffebld_info (expr
)) != FFEINFO_whereCONSTANT
)
5424 l
= ffebld_left (expr
);
5425 r
= ffebld_right (expr
);
5427 if (ffebld_op (l
) != FFEBLD_opCONTER
)
5429 if (ffebld_op (r
) != FFEBLD_opCONTER
)
5432 switch (bt
= ffeinfo_basictype (ffebld_info (expr
)))
5434 case FFEINFO_basictypeANY
:
5437 case FFEINFO_basictypeINTEGER
:
5438 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
5440 #if FFETARGET_okINTEGER1
5441 case FFEINFO_kindtypeINTEGER1
:
5442 error
= ffetarget_xor_integer1 (ffebld_cu_ptr_integer1 (u
),
5443 ffebld_constant_integer1 (ffebld_conter (l
)),
5444 ffebld_constant_integer1 (ffebld_conter (r
)));
5445 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5446 (ffebld_cu_val_integer1 (u
)), expr
);
5450 #if FFETARGET_okINTEGER2
5451 case FFEINFO_kindtypeINTEGER2
:
5452 error
= ffetarget_xor_integer2 (ffebld_cu_ptr_integer2 (u
),
5453 ffebld_constant_integer2 (ffebld_conter (l
)),
5454 ffebld_constant_integer2 (ffebld_conter (r
)));
5455 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5456 (ffebld_cu_val_integer2 (u
)), expr
);
5460 #if FFETARGET_okINTEGER3
5461 case FFEINFO_kindtypeINTEGER3
:
5462 error
= ffetarget_xor_integer3 (ffebld_cu_ptr_integer3 (u
),
5463 ffebld_constant_integer3 (ffebld_conter (l
)),
5464 ffebld_constant_integer3 (ffebld_conter (r
)));
5465 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5466 (ffebld_cu_val_integer3 (u
)), expr
);
5470 #if FFETARGET_okINTEGER4
5471 case FFEINFO_kindtypeINTEGER4
:
5472 error
= ffetarget_xor_integer4 (ffebld_cu_ptr_integer4 (u
),
5473 ffebld_constant_integer4 (ffebld_conter (l
)),
5474 ffebld_constant_integer4 (ffebld_conter (r
)));
5475 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5476 (ffebld_cu_val_integer4 (u
)), expr
);
5481 assert ("bad integer kind type" == NULL
);
5486 case FFEINFO_basictypeLOGICAL
:
5487 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
5489 #if FFETARGET_okLOGICAL1
5490 case FFEINFO_kindtypeLOGICAL1
:
5491 error
= ffetarget_xor_logical1 (ffebld_cu_ptr_logical1 (u
),
5492 ffebld_constant_logical1 (ffebld_conter (l
)),
5493 ffebld_constant_logical1 (ffebld_conter (r
)));
5494 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5495 (ffebld_cu_val_logical1 (u
)), expr
);
5499 #if FFETARGET_okLOGICAL2
5500 case FFEINFO_kindtypeLOGICAL2
:
5501 error
= ffetarget_xor_logical2 (ffebld_cu_ptr_logical2 (u
),
5502 ffebld_constant_logical2 (ffebld_conter (l
)),
5503 ffebld_constant_logical2 (ffebld_conter (r
)));
5504 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5505 (ffebld_cu_val_logical2 (u
)), expr
);
5509 #if FFETARGET_okLOGICAL3
5510 case FFEINFO_kindtypeLOGICAL3
:
5511 error
= ffetarget_xor_logical3 (ffebld_cu_ptr_logical3 (u
),
5512 ffebld_constant_logical3 (ffebld_conter (l
)),
5513 ffebld_constant_logical3 (ffebld_conter (r
)));
5514 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5515 (ffebld_cu_val_logical3 (u
)), expr
);
5519 #if FFETARGET_okLOGICAL4
5520 case FFEINFO_kindtypeLOGICAL4
:
5521 error
= ffetarget_xor_logical4 (ffebld_cu_ptr_logical4 (u
),
5522 ffebld_constant_logical4 (ffebld_conter (l
)),
5523 ffebld_constant_logical4 (ffebld_conter (r
)));
5524 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5525 (ffebld_cu_val_logical4 (u
)), expr
);
5530 assert ("bad logical kind type" == NULL
);
5536 assert ("bad type" == NULL
);
5540 ffebld_set_info (expr
, ffeinfo_new
5545 FFEINFO_whereCONSTANT
,
5546 FFETARGET_charactersizeNONE
));
5548 if ((error
!= FFEBAD
)
5549 && ffebad_start (error
))
5551 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
5558 /* ffeexpr_collapse_eqv -- Collapse eqv expr
5562 expr = ffeexpr_collapse_eqv(expr,token);
5564 If the result of the expr is a constant, replaces the expr with the
5565 computed constant. */
5568 ffeexpr_collapse_eqv (ffebld expr
, ffelexToken t
)
5570 ffebad error
= FFEBAD
;
5573 ffebldConstantUnion u
;
5574 ffeinfoBasictype bt
;
5577 if (ffeinfo_where (ffebld_info (expr
)) != FFEINFO_whereCONSTANT
)
5580 l
= ffebld_left (expr
);
5581 r
= ffebld_right (expr
);
5583 if (ffebld_op (l
) != FFEBLD_opCONTER
)
5585 if (ffebld_op (r
) != FFEBLD_opCONTER
)
5588 switch (bt
= ffeinfo_basictype (ffebld_info (expr
)))
5590 case FFEINFO_basictypeANY
:
5593 case FFEINFO_basictypeINTEGER
:
5594 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
5596 #if FFETARGET_okINTEGER1
5597 case FFEINFO_kindtypeINTEGER1
:
5598 error
= ffetarget_eqv_integer1 (ffebld_cu_ptr_integer1 (u
),
5599 ffebld_constant_integer1 (ffebld_conter (l
)),
5600 ffebld_constant_integer1 (ffebld_conter (r
)));
5601 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5602 (ffebld_cu_val_integer1 (u
)), expr
);
5606 #if FFETARGET_okINTEGER2
5607 case FFEINFO_kindtypeINTEGER2
:
5608 error
= ffetarget_eqv_integer2 (ffebld_cu_ptr_integer2 (u
),
5609 ffebld_constant_integer2 (ffebld_conter (l
)),
5610 ffebld_constant_integer2 (ffebld_conter (r
)));
5611 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5612 (ffebld_cu_val_integer2 (u
)), expr
);
5616 #if FFETARGET_okINTEGER3
5617 case FFEINFO_kindtypeINTEGER3
:
5618 error
= ffetarget_eqv_integer3 (ffebld_cu_ptr_integer3 (u
),
5619 ffebld_constant_integer3 (ffebld_conter (l
)),
5620 ffebld_constant_integer3 (ffebld_conter (r
)));
5621 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5622 (ffebld_cu_val_integer3 (u
)), expr
);
5626 #if FFETARGET_okINTEGER4
5627 case FFEINFO_kindtypeINTEGER4
:
5628 error
= ffetarget_eqv_integer4 (ffebld_cu_ptr_integer4 (u
),
5629 ffebld_constant_integer4 (ffebld_conter (l
)),
5630 ffebld_constant_integer4 (ffebld_conter (r
)));
5631 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5632 (ffebld_cu_val_integer4 (u
)), expr
);
5637 assert ("bad integer kind type" == NULL
);
5642 case FFEINFO_basictypeLOGICAL
:
5643 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
5645 #if FFETARGET_okLOGICAL1
5646 case FFEINFO_kindtypeLOGICAL1
:
5647 error
= ffetarget_eqv_logical1 (ffebld_cu_ptr_logical1 (u
),
5648 ffebld_constant_logical1 (ffebld_conter (l
)),
5649 ffebld_constant_logical1 (ffebld_conter (r
)));
5650 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5651 (ffebld_cu_val_logical1 (u
)), expr
);
5655 #if FFETARGET_okLOGICAL2
5656 case FFEINFO_kindtypeLOGICAL2
:
5657 error
= ffetarget_eqv_logical2 (ffebld_cu_ptr_logical2 (u
),
5658 ffebld_constant_logical2 (ffebld_conter (l
)),
5659 ffebld_constant_logical2 (ffebld_conter (r
)));
5660 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5661 (ffebld_cu_val_logical2 (u
)), expr
);
5665 #if FFETARGET_okLOGICAL3
5666 case FFEINFO_kindtypeLOGICAL3
:
5667 error
= ffetarget_eqv_logical3 (ffebld_cu_ptr_logical3 (u
),
5668 ffebld_constant_logical3 (ffebld_conter (l
)),
5669 ffebld_constant_logical3 (ffebld_conter (r
)));
5670 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5671 (ffebld_cu_val_logical3 (u
)), expr
);
5675 #if FFETARGET_okLOGICAL4
5676 case FFEINFO_kindtypeLOGICAL4
:
5677 error
= ffetarget_eqv_logical4 (ffebld_cu_ptr_logical4 (u
),
5678 ffebld_constant_logical4 (ffebld_conter (l
)),
5679 ffebld_constant_logical4 (ffebld_conter (r
)));
5680 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5681 (ffebld_cu_val_logical4 (u
)), expr
);
5686 assert ("bad logical kind type" == NULL
);
5692 assert ("bad type" == NULL
);
5696 ffebld_set_info (expr
, ffeinfo_new
5701 FFEINFO_whereCONSTANT
,
5702 FFETARGET_charactersizeNONE
));
5704 if ((error
!= FFEBAD
)
5705 && ffebad_start (error
))
5707 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
5714 /* ffeexpr_collapse_neqv -- Collapse neqv expr
5718 expr = ffeexpr_collapse_neqv(expr,token);
5720 If the result of the expr is a constant, replaces the expr with the
5721 computed constant. */
5724 ffeexpr_collapse_neqv (ffebld expr
, ffelexToken t
)
5726 ffebad error
= FFEBAD
;
5729 ffebldConstantUnion u
;
5730 ffeinfoBasictype bt
;
5733 if (ffeinfo_where (ffebld_info (expr
)) != FFEINFO_whereCONSTANT
)
5736 l
= ffebld_left (expr
);
5737 r
= ffebld_right (expr
);
5739 if (ffebld_op (l
) != FFEBLD_opCONTER
)
5741 if (ffebld_op (r
) != FFEBLD_opCONTER
)
5744 switch (bt
= ffeinfo_basictype (ffebld_info (expr
)))
5746 case FFEINFO_basictypeANY
:
5749 case FFEINFO_basictypeINTEGER
:
5750 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
5752 #if FFETARGET_okINTEGER1
5753 case FFEINFO_kindtypeINTEGER1
:
5754 error
= ffetarget_neqv_integer1 (ffebld_cu_ptr_integer1 (u
),
5755 ffebld_constant_integer1 (ffebld_conter (l
)),
5756 ffebld_constant_integer1 (ffebld_conter (r
)));
5757 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
5758 (ffebld_cu_val_integer1 (u
)), expr
);
5762 #if FFETARGET_okINTEGER2
5763 case FFEINFO_kindtypeINTEGER2
:
5764 error
= ffetarget_neqv_integer2 (ffebld_cu_ptr_integer2 (u
),
5765 ffebld_constant_integer2 (ffebld_conter (l
)),
5766 ffebld_constant_integer2 (ffebld_conter (r
)));
5767 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
5768 (ffebld_cu_val_integer2 (u
)), expr
);
5772 #if FFETARGET_okINTEGER3
5773 case FFEINFO_kindtypeINTEGER3
:
5774 error
= ffetarget_neqv_integer3 (ffebld_cu_ptr_integer3 (u
),
5775 ffebld_constant_integer3 (ffebld_conter (l
)),
5776 ffebld_constant_integer3 (ffebld_conter (r
)));
5777 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
5778 (ffebld_cu_val_integer3 (u
)), expr
);
5782 #if FFETARGET_okINTEGER4
5783 case FFEINFO_kindtypeINTEGER4
:
5784 error
= ffetarget_neqv_integer4 (ffebld_cu_ptr_integer4 (u
),
5785 ffebld_constant_integer4 (ffebld_conter (l
)),
5786 ffebld_constant_integer4 (ffebld_conter (r
)));
5787 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
5788 (ffebld_cu_val_integer4 (u
)), expr
);
5793 assert ("bad integer kind type" == NULL
);
5798 case FFEINFO_basictypeLOGICAL
:
5799 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
5801 #if FFETARGET_okLOGICAL1
5802 case FFEINFO_kindtypeLOGICAL1
:
5803 error
= ffetarget_neqv_logical1 (ffebld_cu_ptr_logical1 (u
),
5804 ffebld_constant_logical1 (ffebld_conter (l
)),
5805 ffebld_constant_logical1 (ffebld_conter (r
)));
5806 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
5807 (ffebld_cu_val_logical1 (u
)), expr
);
5811 #if FFETARGET_okLOGICAL2
5812 case FFEINFO_kindtypeLOGICAL2
:
5813 error
= ffetarget_neqv_logical2 (ffebld_cu_ptr_logical2 (u
),
5814 ffebld_constant_logical2 (ffebld_conter (l
)),
5815 ffebld_constant_logical2 (ffebld_conter (r
)));
5816 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
5817 (ffebld_cu_val_logical2 (u
)), expr
);
5821 #if FFETARGET_okLOGICAL3
5822 case FFEINFO_kindtypeLOGICAL3
:
5823 error
= ffetarget_neqv_logical3 (ffebld_cu_ptr_logical3 (u
),
5824 ffebld_constant_logical3 (ffebld_conter (l
)),
5825 ffebld_constant_logical3 (ffebld_conter (r
)));
5826 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
5827 (ffebld_cu_val_logical3 (u
)), expr
);
5831 #if FFETARGET_okLOGICAL4
5832 case FFEINFO_kindtypeLOGICAL4
:
5833 error
= ffetarget_neqv_logical4 (ffebld_cu_ptr_logical4 (u
),
5834 ffebld_constant_logical4 (ffebld_conter (l
)),
5835 ffebld_constant_logical4 (ffebld_conter (r
)));
5836 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
5837 (ffebld_cu_val_logical4 (u
)), expr
);
5842 assert ("bad logical kind type" == NULL
);
5848 assert ("bad type" == NULL
);
5852 ffebld_set_info (expr
, ffeinfo_new
5857 FFEINFO_whereCONSTANT
,
5858 FFETARGET_charactersizeNONE
));
5860 if ((error
!= FFEBAD
)
5861 && ffebad_start (error
))
5863 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
5870 /* ffeexpr_collapse_symter -- Collapse symter expr
5874 expr = ffeexpr_collapse_symter(expr,token);
5876 If the result of the expr is a constant, replaces the expr with the
5877 computed constant. */
5880 ffeexpr_collapse_symter (ffebld expr
, ffelexToken t UNUSED
)
5883 ffeinfoBasictype bt
;
5885 ffetargetCharacterSize len
;
5887 if (ffeinfo_where (ffebld_info (expr
)) != FFEINFO_whereCONSTANT
)
5890 if ((r
= ffesymbol_init (ffebld_symter (expr
))) == NULL
)
5891 return expr
; /* A PARAMETER lhs in progress. */
5893 switch (ffebld_op (r
))
5895 case FFEBLD_opCONTER
:
5905 bt
= ffeinfo_basictype (ffebld_info (r
));
5906 kt
= ffeinfo_kindtype (ffebld_info (r
));
5907 len
= ffebld_size (r
);
5909 expr
= ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r
)),
5912 ffebld_set_info (expr
, ffeinfo_new
5917 FFEINFO_whereCONSTANT
,
5923 /* ffeexpr_collapse_funcref -- Collapse funcref expr
5927 expr = ffeexpr_collapse_funcref(expr,token);
5929 If the result of the expr is a constant, replaces the expr with the
5930 computed constant. */
5933 ffeexpr_collapse_funcref (ffebld expr
, ffelexToken t UNUSED
)
5935 return expr
; /* ~~someday go ahead and collapse these,
5936 though not required */
5939 /* ffeexpr_collapse_arrayref -- Collapse arrayref expr
5943 expr = ffeexpr_collapse_arrayref(expr,token);
5945 If the result of the expr is a constant, replaces the expr with the
5946 computed constant. */
5949 ffeexpr_collapse_arrayref (ffebld expr
, ffelexToken t UNUSED
)
5954 /* ffeexpr_collapse_substr -- Collapse substr expr
5958 expr = ffeexpr_collapse_substr(expr,token);
5960 If the result of the expr is a constant, replaces the expr with the
5961 computed constant. */
5964 ffeexpr_collapse_substr (ffebld expr
, ffelexToken t
)
5966 ffebad error
= FFEBAD
;
5971 ffebldConstantUnion u
;
5973 ffetargetCharacterSize len
;
5974 ffetargetIntegerDefault first
;
5975 ffetargetIntegerDefault last
;
5977 if (ffeinfo_where (ffebld_info (expr
)) != FFEINFO_whereCONSTANT
)
5980 l
= ffebld_left (expr
);
5981 r
= ffebld_right (expr
); /* opITEM. */
5983 if (ffebld_op (l
) != FFEBLD_opCONTER
)
5986 kt
= ffeinfo_kindtype (ffebld_info (l
));
5987 len
= ffebld_size (l
);
5989 start
= ffebld_head (r
);
5990 stop
= ffebld_head (ffebld_trail (r
));
5995 if ((ffebld_op (start
) != FFEBLD_opCONTER
)
5996 || (ffeinfo_basictype (ffebld_info (start
)) != FFEINFO_basictypeINTEGER
)
5997 || (ffeinfo_kindtype (ffebld_info (start
))
5998 != FFEINFO_kindtypeINTEGERDEFAULT
))
6000 first
= ffebld_constant_integerdefault (ffebld_conter (start
));
6006 if ((ffebld_op (stop
) != FFEBLD_opCONTER
)
6007 || (ffeinfo_basictype (ffebld_info (stop
)) != FFEINFO_basictypeINTEGER
)
6008 || (ffeinfo_kindtype (ffebld_info (stop
))
6009 != FFEINFO_kindtypeINTEGERDEFAULT
))
6011 last
= ffebld_constant_integerdefault (ffebld_conter (stop
));
6014 /* Handle problems that should have already been diagnosed, but
6015 left in the expression tree. */
6020 last
= first
+ len
- 1;
6022 if ((first
== 1) && (last
== len
))
6023 { /* Same as original. */
6024 expr
= ffebld_new_conter_with_orig (ffebld_constant_copy
6025 (ffebld_conter (l
)), expr
);
6026 ffebld_set_info (expr
, ffeinfo_new
6027 (FFEINFO_basictypeCHARACTER
,
6031 FFEINFO_whereCONSTANT
,
6037 switch (ffeinfo_basictype (ffebld_info (expr
)))
6039 case FFEINFO_basictypeANY
:
6042 case FFEINFO_basictypeCHARACTER
:
6043 switch (kt
= ffeinfo_kindtype (ffebld_info (expr
)))
6045 #if FFETARGET_okCHARACTER1
6046 case FFEINFO_kindtypeCHARACTER1
:
6047 error
= ffetarget_substr_character1 (ffebld_cu_ptr_character1 (u
),
6048 ffebld_constant_character1 (ffebld_conter (l
)), first
, last
,
6049 ffebld_constant_pool (), &len
);
6050 expr
= ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
6051 (ffebld_cu_val_character1 (u
)), expr
);
6056 assert ("bad character kind type" == NULL
);
6062 assert ("bad type" == NULL
);
6066 ffebld_set_info (expr
, ffeinfo_new
6067 (FFEINFO_basictypeCHARACTER
,
6071 FFEINFO_whereCONSTANT
,
6074 if ((error
!= FFEBAD
)
6075 && ffebad_start (error
))
6077 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
6084 /* ffeexpr_convert -- Convert source expression to given type
6087 ffelexToken source_token;
6088 ffelexToken dest_token; // Any appropriate token for "destination".
6089 ffeinfoBasictype bt;
6091 ffetargetCharactersize sz;
6092 ffeexprContext context; // Mainly LET or DATA.
6093 source = ffeexpr_convert(source,source_token,dest_token,bt,kt,sz,context);
6095 If the expression conforms, returns the source expression. Otherwise
6096 returns source wrapped in a convert node doing the conversion, or
6097 ANY wrapped in convert if there is a conversion error (and issues an
6098 error message). Be sensitive to the context for certain aspects of
6102 ffeexpr_convert (ffebld source
, ffelexToken source_token
, ffelexToken dest_token
,
6103 ffeinfoBasictype bt
, ffeinfoKindtype kt
, ffeinfoRank rk
,
6104 ffetargetCharacterSize sz
, ffeexprContext context
)
6110 info
= ffebld_info (source
);
6111 if ((bt
!= ffeinfo_basictype (info
))
6112 || (kt
!= ffeinfo_kindtype (info
))
6113 || (rk
!= 0) /* Can't convert from or to arrays yet. */
6114 || (ffeinfo_rank (info
) != 0)
6115 || (sz
!= ffebld_size_known (source
)))
6116 #if 0 /* Nobody seems to need this spurious CONVERT node. */
6117 || ((context
!= FFEEXPR_contextLET
)
6118 && (bt
== FFEINFO_basictypeCHARACTER
)
6119 && (sz
== FFETARGET_charactersizeNONE
)))
6122 switch (ffeinfo_basictype (info
))
6124 case FFEINFO_basictypeLOGICAL
:
6127 case FFEINFO_basictypeLOGICAL
:
6131 case FFEINFO_basictypeINTEGER
:
6132 bad
= !ffe_is_ugly_logint ();
6135 case FFEINFO_basictypeCHARACTER
:
6136 bad
= ffe_is_pedantic ()
6137 || !(ffe_is_ugly_init ()
6138 && (context
== FFEEXPR_contextDATA
));
6147 case FFEINFO_basictypeINTEGER
:
6150 case FFEINFO_basictypeINTEGER
:
6151 case FFEINFO_basictypeREAL
:
6152 case FFEINFO_basictypeCOMPLEX
:
6156 case FFEINFO_basictypeLOGICAL
:
6157 bad
= !ffe_is_ugly_logint ();
6160 case FFEINFO_basictypeCHARACTER
:
6161 bad
= ffe_is_pedantic ()
6162 || !(ffe_is_ugly_init ()
6163 && (context
== FFEEXPR_contextDATA
));
6172 case FFEINFO_basictypeREAL
:
6173 case FFEINFO_basictypeCOMPLEX
:
6176 case FFEINFO_basictypeINTEGER
:
6177 case FFEINFO_basictypeREAL
:
6178 case FFEINFO_basictypeCOMPLEX
:
6182 case FFEINFO_basictypeCHARACTER
:
6192 case FFEINFO_basictypeCHARACTER
:
6193 bad
= (bt
!= FFEINFO_basictypeCHARACTER
)
6194 && (ffe_is_pedantic ()
6195 || (bt
!= FFEINFO_basictypeINTEGER
)
6196 || !(ffe_is_ugly_init ()
6197 && (context
== FFEEXPR_contextDATA
)));
6200 case FFEINFO_basictypeTYPELESS
:
6201 case FFEINFO_basictypeHOLLERITH
:
6202 bad
= ffe_is_pedantic ()
6203 || !(ffe_is_ugly_init ()
6204 && ((context
== FFEEXPR_contextDATA
)
6205 || (context
== FFEEXPR_contextLET
)));
6213 if (!bad
&& ((rk
!= 0) || (ffeinfo_rank (info
) != 0)))
6216 if (bad
&& (bt
!= FFEINFO_basictypeANY
) && (kt
!= FFEINFO_kindtypeANY
)
6217 && (ffeinfo_basictype (info
) != FFEINFO_basictypeANY
)
6218 && (ffeinfo_kindtype (info
) != FFEINFO_kindtypeANY
)
6219 && (ffeinfo_where (info
) != FFEINFO_whereANY
))
6221 if (ffebad_start (FFEBAD_BAD_TYPES
))
6223 if (dest_token
== NULL
)
6224 ffebad_here (0, ffewhere_line_unknown (),
6225 ffewhere_column_unknown ());
6227 ffebad_here (0, ffelex_token_where_line (dest_token
),
6228 ffelex_token_where_column (dest_token
));
6229 assert (source_token
!= NULL
);
6230 ffebad_here (1, ffelex_token_where_line (source_token
),
6231 ffelex_token_where_column (source_token
));
6235 source
= ffebld_new_any ();
6236 ffebld_set_info (source
, ffeinfo_new_any ());
6240 switch (ffeinfo_where (info
))
6242 case FFEINFO_whereCONSTANT
:
6243 wh
= FFEINFO_whereCONSTANT
;
6246 case FFEINFO_whereIMMEDIATE
:
6247 wh
= FFEINFO_whereIMMEDIATE
;
6251 wh
= FFEINFO_whereFLEETING
;
6254 source
= ffebld_new_convert (source
);
6255 ffebld_set_info (source
, ffeinfo_new
6262 source
= ffeexpr_collapse_convert (source
, source_token
);
6269 /* ffeexpr_convert_expr -- Convert source expr to conform to dest expr
6273 ffelexToken source_token;
6274 ffelexToken dest_token;
6275 ffeexprContext context;
6276 source = ffeexpr_convert_expr(source,source_token,dest,dest_token,context);
6278 If the expressions conform, returns the source expression. Otherwise
6279 returns source wrapped in a convert node doing the conversion, or
6280 ANY wrapped in convert if there is a conversion error (and issues an
6281 error message). Be sensitive to the context, such as LET or DATA. */
6284 ffeexpr_convert_expr (ffebld source
, ffelexToken source_token
, ffebld dest
,
6285 ffelexToken dest_token
, ffeexprContext context
)
6289 info
= ffebld_info (dest
);
6290 return ffeexpr_convert (source
, source_token
, dest_token
,
6291 ffeinfo_basictype (info
),
6292 ffeinfo_kindtype (info
),
6293 ffeinfo_rank (info
),
6294 ffebld_size_known (dest
),
6298 /* ffeexpr_convert_to_sym -- Convert source expression to conform to symbol
6302 ffelexToken source_token;
6303 ffelexToken dest_token;
6304 source = ffeexpr_convert_to_sym(source,source_token,dest,dest_token);
6306 If the expressions conform, returns the source expression. Otherwise
6307 returns source wrapped in a convert node doing the conversion, or
6308 ANY wrapped in convert if there is a conversion error (and issues an
6312 ffeexpr_convert_to_sym (ffebld source
, ffelexToken source_token
,
6313 ffesymbol dest
, ffelexToken dest_token
)
6315 return ffeexpr_convert (source
, source_token
, dest_token
, ffesymbol_basictype (dest
),
6316 ffesymbol_kindtype (dest
), ffesymbol_rank (dest
), ffesymbol_size (dest
),
6317 FFEEXPR_contextLET
);
6320 /* Initializes the module. */
6323 ffeexpr_init_2 (void)
6325 ffeexpr_stack_
= NULL
;
6329 /* ffeexpr_lhs -- Begin processing left-hand-side-context expression
6331 Prepares cluster for delivery of lexer tokens representing an expression
6332 in a left-hand-side context (A in A=B, for example). ffebld is used
6333 to build expressions in the given pool. The appropriate lexer-token
6334 handling routine within ffeexpr is returned. When the end of the
6335 expression is detected, mycallbackroutine is called with the resulting
6336 single ffebld object specifying the entire expression and the first
6337 lexer token that is not considered part of the expression. This caller-
6338 supplied routine itself returns a lexer-token handling routine. Thus,
6339 if necessary, ffeexpr can return several tokens as end-of-expression
6340 tokens if it needs to scan forward more than one in any instance. */
6343 ffeexpr_lhs (mallocPool pool
, ffeexprContext context
, ffeexprCallback callback
)
6347 ffebld_pool_push (pool
);
6348 s
= malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s
));
6349 s
->previous
= ffeexpr_stack_
;
6351 s
->context
= context
;
6352 s
->callback
= callback
;
6353 s
->first_token
= NULL
;
6354 s
->exprstack
= NULL
;
6357 return (ffelexHandler
) ffeexpr_token_first_lhs_
;
6360 /* ffeexpr_rhs -- Begin processing right-hand-side-context expression
6362 return ffeexpr_rhs(malloc_pool_image(),mycallbackroutine); // to lexer.
6364 Prepares cluster for delivery of lexer tokens representing an expression
6365 in a right-hand-side context (B in A=B, for example). ffebld is used
6366 to build expressions in the given pool. The appropriate lexer-token
6367 handling routine within ffeexpr is returned. When the end of the
6368 expression is detected, mycallbackroutine is called with the resulting
6369 single ffebld object specifying the entire expression and the first
6370 lexer token that is not considered part of the expression. This caller-
6371 supplied routine itself returns a lexer-token handling routine. Thus,
6372 if necessary, ffeexpr can return several tokens as end-of-expression
6373 tokens if it needs to scan forward more than one in any instance. */
6376 ffeexpr_rhs (mallocPool pool
, ffeexprContext context
, ffeexprCallback callback
)
6380 ffebld_pool_push (pool
);
6381 s
= malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR stack", sizeof (*s
));
6382 s
->previous
= ffeexpr_stack_
;
6384 s
->context
= context
;
6385 s
->callback
= callback
;
6386 s
->first_token
= NULL
;
6387 s
->exprstack
= NULL
;
6390 return (ffelexHandler
) ffeexpr_token_first_rhs_
;
6393 /* ffeexpr_cb_close_paren_ -- OPEN_PAREN expr
6395 Pass it to ffeexpr_rhs as the callback routine.
6397 Makes sure the end token is close-paren and swallows it, else issues
6398 an error message and doesn't swallow the token (passing it along instead).
6399 In either case wraps up subexpression construction by enclosing the
6400 ffebld expression in a paren. */
6402 static ffelexHandler
6403 ffeexpr_cb_close_paren_ (ffelexToken ft
, ffebld expr
, ffelexToken t
)
6407 if (ffelex_token_type (t
) != FFELEX_typeCLOSE_PAREN
)
6409 /* Oops, naughty user didn't specify the close paren! */
6411 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN
))
6413 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
6414 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_
->tokens
[0]),
6415 ffelex_token_where_column (ffeexpr_stack_
->tokens
[0]));
6419 e
= ffeexpr_expr_new_ ();
6420 e
->type
= FFEEXPR_exprtypeOPERAND_
;
6421 e
->u
.operand
= ffebld_new_any ();
6422 ffebld_set_info (e
->u
.operand
, ffeinfo_new_any ());
6423 ffeexpr_exprstack_push_operand_ (e
);
6426 (ffelexHandler
) ffeexpr_find_close_paren_ (t
,
6428 ffeexpr_token_binary_
);
6431 if (expr
->op
== FFEBLD_opIMPDO
)
6433 if (ffest_ffebad_start (FFEBAD_IMPDO_PAREN
))
6435 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_
->tokens
[0]),
6436 ffelex_token_where_column (ffeexpr_stack_
->tokens
[0]));
6442 expr
= ffebld_new_paren (expr
);
6443 ffebld_set_info (expr
, ffeinfo_use (ffebld_info (ffebld_left (expr
))));
6446 /* Now push the (parenthesized) expression as an operand onto the
6447 expression stack. */
6449 e
= ffeexpr_expr_new_ ();
6450 e
->type
= FFEEXPR_exprtypeOPERAND_
;
6451 e
->u
.operand
= expr
;
6452 e
->u
.operand
= ffeexpr_collapse_paren (e
->u
.operand
, ft
);
6453 e
->token
= ffeexpr_stack_
->tokens
[0];
6454 ffeexpr_exprstack_push_operand_ (e
);
6456 return (ffelexHandler
) ffeexpr_token_binary_
;
6459 /* ffeexpr_cb_close_paren_ambig_ -- OPEN_PAREN expr
6461 Pass it to ffeexpr_rhs as the callback routine.
6463 We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
6464 with the next token in t. If the next token is possibly a binary
6465 operator, continue processing the outer expression. If the next
6466 token is COMMA, then the expression is a unit specifier, and
6467 parentheses should not be added to it because it surrounds the
6468 I/O control list that starts with the unit specifier (and continues
6469 on from here -- we haven't seen the CLOSE_PAREN that matches the
6470 OPEN_PAREN, it is up to the callback function to expect to see it
6471 at some point). In this case, we notify the callback function that
6472 the COMMA is inside, not outside, the parens by wrapping the expression
6473 in an opITEM (with a NULL trail) -- the callback function presumably
6474 unwraps it after seeing this kludgey indicator.
6476 If the next token is CLOSE_PAREN, then we go to the _1_ state to
6477 decide what to do with the token after that.
6480 Use an extra state for the CLOSE_PAREN case to make READ &co really
6483 static ffelexHandler
6484 ffeexpr_cb_close_paren_ambig_ (ffelexToken ft
, ffebld expr
, ffelexToken t
)
6486 ffeexprCallback callback
;
6489 if (ffelex_token_type (t
) == FFELEX_typeCLOSE_PAREN
)
6490 { /* Need to see the next token before we
6492 ffeexpr_stack_
->expr
= expr
;
6493 ffeexpr_tokens_
[0] = ffelex_token_use (ft
);
6494 ffeexpr_tokens_
[1] = ffelex_token_use (t
);
6495 return (ffelexHandler
) ffeexpr_cb_close_paren_ambig_1_
;
6498 expr
= ffeexpr_finished_ambig_ (ft
, expr
);
6500 /* Let the callback function handle the case where t isn't COMMA. */
6502 /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
6503 that preceded the expression starts a list of expressions, and the expr
6504 hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
6505 node. The callback function should extract the real expr from the head
6506 of this opITEM node after testing it. */
6508 expr
= ffebld_new_item (expr
, NULL
);
6511 callback
= ffeexpr_stack_
->callback
;
6512 ffelex_token_kill (ffeexpr_stack_
->first_token
);
6513 s
= ffeexpr_stack_
->previous
;
6514 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_
, sizeof (*ffeexpr_stack_
));
6516 return (ffelexHandler
) (*callback
) (ft
, expr
, t
);
6519 /* ffeexpr_cb_close_paren_ambig_1_ -- OPEN_PAREN expr CLOSE_PAREN
6521 See ffeexpr_cb_close_paren_ambig_.
6523 We get here in the READ/BACKEND/ENDFILE/REWIND case "READ(expr)"
6524 with the next token in t. If the next token is possibly a binary
6525 operator, continue processing the outer expression. If the next
6526 token is COMMA, the expression is a parenthesized format specifier.
6527 If the next token is not EOS or SEMICOLON, then because it is not a
6528 binary operator (it is NAME, OPEN_PAREN, &c), the expression is
6529 a unit specifier, and parentheses should not be added to it because
6530 they surround the I/O control list that consists of only the unit
6531 specifier. If the next token is EOS or SEMICOLON, the statement
6532 must be disambiguated by looking at the type of the expression -- a
6533 character expression is a parenthesized format specifier, while a
6534 non-character expression is a unit specifier.
6536 Another issue is how to do the callback so the recipient of the
6537 next token knows how to handle it if it is a COMMA. In all other
6538 cases, disambiguation is straightforward: the same approach as the
6541 EXTENSION: in COMMA case, if not pedantic, use same disambiguation
6542 as for EOS/SEMICOLON case; f2c allows "READ (cilist) [[,]iolist]"
6543 and apparently other compilers do, as well, and some code out there
6544 uses this "feature".
6547 Extend to allow COMMA as nondisambiguating by itself. Remember
6548 to not try and check info field for opSTAR, since that expr doesn't
6549 have a valid info field. */
6551 static ffelexHandler
6552 ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t
)
6554 ffeexprCallback callback
;
6557 ffelexToken orig_ft
= ffeexpr_tokens_
[0]; /* In case callback clobbers
6559 ffelexToken orig_t
= ffeexpr_tokens_
[1];
6560 ffebld expr
= ffeexpr_stack_
->expr
;
6562 switch (ffelex_token_type (t
))
6564 case FFELEX_typeCOMMA
: /* Subexpr is parenthesized format specifier. */
6565 if (ffe_is_pedantic ())
6566 goto pedantic_comma
; /* :::::::::::::::::::: */
6568 case FFELEX_typeEOS
: /* Ambiguous; use type of expr to
6570 case FFELEX_typeSEMICOLON
:
6571 if ((expr
== NULL
) || (ffebld_op (expr
) == FFEBLD_opANY
)
6572 || (ffebld_op (expr
) == FFEBLD_opSTAR
)
6573 || (ffeinfo_basictype (ffebld_info (expr
))
6574 != FFEINFO_basictypeCHARACTER
))
6575 break; /* Not a valid CHARACTER entity, can't be a
6578 default: /* Binary op (we assume; error otherwise);
6579 format specifier. */
6581 pedantic_comma
: /* :::::::::::::::::::: */
6583 switch (ffeexpr_stack_
->context
)
6585 case FFEEXPR_contextFILENUMAMBIG
:
6586 ffeexpr_stack_
->context
= FFEEXPR_contextFILENUM
;
6589 case FFEEXPR_contextFILEUNITAMBIG
:
6590 ffeexpr_stack_
->context
= FFEEXPR_contextFILEFORMAT
;
6594 assert ("bad context" == NULL
);
6598 ffeexpr_stack_
->tokens
[0] = ffelex_token_use (ffeexpr_stack_
->first_token
);
6599 next
= (ffelexHandler
) ffeexpr_cb_close_paren_ (orig_ft
, expr
, orig_t
);
6600 ffelex_token_kill (orig_ft
);
6601 ffelex_token_kill (orig_t
);
6602 return (ffelexHandler
) (*next
) (t
);
6604 case FFELEX_typeOPEN_PAREN
:/* Non-binary op; beginning of I/O list. */
6605 case FFELEX_typeNAME
:
6609 expr
= ffeexpr_finished_ambig_ (orig_ft
, expr
);
6611 /* Here is a kludge whereby we tell the callback function the OPEN_PAREN
6612 that preceded the expression starts a list of expressions, and the expr
6613 hasn't been wrapped in a corresponding (and possibly collapsed) opPAREN
6614 node. The callback function should extract the real expr from the head
6615 of this opITEM node after testing it. */
6617 expr
= ffebld_new_item (expr
, NULL
);
6620 callback
= ffeexpr_stack_
->callback
;
6621 ffelex_token_kill (ffeexpr_stack_
->first_token
);
6622 s
= ffeexpr_stack_
->previous
;
6623 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_
, sizeof (*ffeexpr_stack_
));
6625 next
= (ffelexHandler
) (*callback
) (orig_ft
, expr
, orig_t
);
6626 ffelex_token_kill (orig_ft
);
6627 ffelex_token_kill (orig_t
);
6628 return (ffelexHandler
) (*next
) (t
);
6631 /* ffeexpr_cb_close_paren_c_ -- OPEN_PAREN expr (possible complex)
6633 Pass it to ffeexpr_rhs as the callback routine.
6635 Makes sure the end token is close-paren and swallows it, or a comma
6636 and handles complex/implied-do possibilities, else issues
6637 an error message and doesn't swallow the token (passing it along instead). */
6639 static ffelexHandler
6640 ffeexpr_cb_close_paren_c_ (ffelexToken ft
, ffebld expr
, ffelexToken t
)
6642 /* First check to see if this is a possible complex entity. It is if the
6643 token is a comma. */
6645 if (ffelex_token_type (t
) == FFELEX_typeCOMMA
)
6647 ffeexpr_stack_
->tokens
[1] = ffelex_token_use (ft
);
6648 ffeexpr_stack_
->expr
= expr
;
6649 return (ffelexHandler
) ffeexpr_rhs (ffeexpr_stack_
->pool
,
6650 FFEEXPR_contextPAREN_
, ffeexpr_cb_comma_c_
);
6653 return (ffelexHandler
) ffeexpr_cb_close_paren_ (ft
, expr
, t
);
6656 /* ffeexpr_cb_comma_c_ -- OPEN_PAREN expr COMMA expr
6658 Pass it to ffeexpr_rhs as the callback routine.
6660 If this token is not a comma, we have a complex constant (or an attempt
6661 at one), so handle it accordingly, displaying error messages if the token
6662 is not a close-paren. */
6664 static ffelexHandler
6665 ffeexpr_cb_comma_c_ (ffelexToken ft
, ffebld expr
, ffelexToken t
)
6668 ffeinfoBasictype lty
= (ffeexpr_stack_
->expr
== NULL
)
6669 ? FFEINFO_basictypeNONE
: ffeinfo_basictype (ffebld_info (ffeexpr_stack_
->expr
));
6670 ffeinfoBasictype rty
= (expr
== NULL
)
6671 ? FFEINFO_basictypeNONE
: ffeinfo_basictype (ffebld_info (expr
));
6672 ffeinfoKindtype lkt
;
6673 ffeinfoKindtype rkt
;
6674 ffeinfoKindtype nkt
;
6678 if ((ffeexpr_stack_
->expr
== NULL
)
6679 || (ffebld_op (ffeexpr_stack_
->expr
) != FFEBLD_opCONTER
)
6680 || (((orig
= ffebld_conter_orig (ffeexpr_stack_
->expr
)) != NULL
)
6681 && (((ffebld_op (orig
) != FFEBLD_opUMINUS
)
6682 && (ffebld_op (orig
) != FFEBLD_opUPLUS
))
6683 || (ffebld_conter_orig (ffebld_left (orig
)) != NULL
)))
6684 || ((lty
!= FFEINFO_basictypeINTEGER
)
6685 && (lty
!= FFEINFO_basictypeREAL
)))
6687 if ((lty
!= FFEINFO_basictypeANY
)
6688 && ffebad_start (FFEBAD_INVALID_COMPLEX_PART
))
6690 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_
->tokens
[1]),
6691 ffelex_token_where_column (ffeexpr_stack_
->tokens
[1]));
6692 ffebad_string ("Real");
6698 || (ffebld_op (expr
) != FFEBLD_opCONTER
)
6699 || (((orig
= ffebld_conter_orig (expr
)) != NULL
)
6700 && (((ffebld_op (orig
) != FFEBLD_opUMINUS
)
6701 && (ffebld_op (orig
) != FFEBLD_opUPLUS
))
6702 || (ffebld_conter_orig (ffebld_left (orig
)) != NULL
)))
6703 || ((rty
!= FFEINFO_basictypeINTEGER
)
6704 && (rty
!= FFEINFO_basictypeREAL
)))
6706 if ((rty
!= FFEINFO_basictypeANY
)
6707 && ffebad_start (FFEBAD_INVALID_COMPLEX_PART
))
6709 ffebad_here (0, ffelex_token_where_line (ft
),
6710 ffelex_token_where_column (ft
));
6711 ffebad_string ("Imaginary");
6717 ffelex_token_kill (ffeexpr_stack_
->tokens
[1]);
6719 /* Push the (parenthesized) expression as an operand onto the expression
6722 e
= ffeexpr_expr_new_ ();
6723 e
->type
= FFEEXPR_exprtypeOPERAND_
;
6724 e
->token
= ffeexpr_stack_
->tokens
[0];
6728 if (lty
== FFEINFO_basictypeINTEGER
)
6729 lkt
= FFEINFO_kindtypeREALDEFAULT
;
6731 lkt
= ffeinfo_kindtype (ffebld_info (ffeexpr_stack_
->expr
));
6732 if (rty
== FFEINFO_basictypeINTEGER
)
6733 rkt
= FFEINFO_kindtypeREALDEFAULT
;
6735 rkt
= ffeinfo_kindtype (ffebld_info (expr
));
6737 nkt
= ffeinfo_kindtype_max (FFEINFO_basictypeCOMPLEX
, lkt
, rkt
);
6738 ffeexpr_stack_
->expr
= ffeexpr_convert (ffeexpr_stack_
->expr
,
6739 ffeexpr_stack_
->tokens
[1], ffeexpr_stack_
->tokens
[0],
6740 FFEINFO_basictypeREAL
, nkt
, 0, FFETARGET_charactersizeNONE
,
6741 FFEEXPR_contextLET
);
6742 expr
= ffeexpr_convert (expr
,
6743 ffeexpr_stack_
->tokens
[1], ffeexpr_stack_
->tokens
[0],
6744 FFEINFO_basictypeREAL
, nkt
, 0, FFETARGET_charactersizeNONE
,
6745 FFEEXPR_contextLET
);
6748 nkt
= FFEINFO_kindtypeANY
;
6752 #if FFETARGET_okCOMPLEX1
6753 case FFEINFO_kindtypeREAL1
:
6754 e
->u
.operand
= ffebld_new_conter (ffebld_constant_new_complex1
6755 (ffebld_conter (ffeexpr_stack_
->expr
), ffebld_conter (expr
)));
6756 ffebld_set_info (e
->u
.operand
,
6757 ffeinfo_new (FFEINFO_basictypeCOMPLEX
, nkt
, 0,
6758 FFEINFO_kindENTITY
, FFEINFO_whereCONSTANT
,
6759 FFETARGET_charactersizeNONE
));
6763 #if FFETARGET_okCOMPLEX2
6764 case FFEINFO_kindtypeREAL2
:
6765 e
->u
.operand
= ffebld_new_conter (ffebld_constant_new_complex2
6766 (ffebld_conter (ffeexpr_stack_
->expr
), ffebld_conter (expr
)));
6767 ffebld_set_info (e
->u
.operand
,
6768 ffeinfo_new (FFEINFO_basictypeCOMPLEX
, nkt
, 0,
6769 FFEINFO_kindENTITY
, FFEINFO_whereCONSTANT
,
6770 FFETARGET_charactersizeNONE
));
6774 #if FFETARGET_okCOMPLEX3
6775 case FFEINFO_kindtypeREAL3
:
6776 e
->u
.operand
= ffebld_new_conter (ffebld_constant_new_complex3
6777 (ffebld_conter (ffeexpr_stack_
->expr
), ffebld_conter (expr
)));
6778 ffebld_set_info (e
->u
.operand
,
6779 ffeinfo_new (FFEINFO_basictypeCOMPLEX
, nkt
, 0,
6780 FFEINFO_kindENTITY
, FFEINFO_whereCONSTANT
,
6781 FFETARGET_charactersizeNONE
));
6786 if (ffebad_start ((nkt
== FFEINFO_kindtypeREALDOUBLE
)
6787 ? FFEBAD_BAD_DBLCMPLX
: FFEBAD_BAD_COMPLEX
))
6789 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_
->tokens
[0]),
6790 ffelex_token_where_column (ffeexpr_stack_
->tokens
[0]));
6794 case FFEINFO_kindtypeANY
:
6795 e
->u
.operand
= ffebld_new_any ();
6796 ffebld_set_info (e
->u
.operand
, ffeinfo_new_any ());
6799 ffeexpr_exprstack_push_operand_ (e
);
6801 /* Now, if the token is a close parenthese, we're in great shape so return
6802 the next handler. */
6804 if (ffelex_token_type (t
) == FFELEX_typeCLOSE_PAREN
)
6805 return (ffelexHandler
) ffeexpr_token_binary_
;
6807 /* Oops, naughty user didn't specify the close paren! */
6809 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN
))
6811 ffebad_here (0, ffelex_token_where_line (t
),
6812 ffelex_token_where_column (t
));
6813 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_
->tokens
[0]),
6814 ffelex_token_where_column (ffeexpr_stack_
->tokens
[0]));
6819 (ffelexHandler
) ffeexpr_find_close_paren_ (t
,
6821 ffeexpr_token_binary_
);
6824 /* ffeexpr_cb_close_paren_ci_ -- OPEN_PAREN expr (possible complex or
6825 implied-DO construct)
6827 Pass it to ffeexpr_rhs as the callback routine.
6829 Makes sure the end token is close-paren and swallows it, or a comma
6830 and handles complex/implied-do possibilities, else issues
6831 an error message and doesn't swallow the token (passing it along instead). */
6833 static ffelexHandler
6834 ffeexpr_cb_close_paren_ci_ (ffelexToken ft
, ffebld expr
, ffelexToken t
)
6838 /* First check to see if this is a possible complex or implied-DO entity.
6839 It is if the token is a comma. */
6841 if (ffelex_token_type (t
) == FFELEX_typeCOMMA
)
6843 switch (ffeexpr_stack_
->context
)
6845 case FFEEXPR_contextIOLIST
:
6846 case FFEEXPR_contextIMPDOITEM_
:
6847 ctx
= FFEEXPR_contextIMPDOITEM_
;
6850 case FFEEXPR_contextIOLISTDF
:
6851 case FFEEXPR_contextIMPDOITEMDF_
:
6852 ctx
= FFEEXPR_contextIMPDOITEMDF_
;
6856 assert ("bad context" == NULL
);
6857 ctx
= FFEEXPR_contextIMPDOITEM_
;
6861 ffeexpr_stack_
->tokens
[0] = ffelex_token_use (ft
);
6862 ffeexpr_stack_
->expr
= expr
;
6863 return (ffelexHandler
) ffeexpr_rhs (ffeexpr_stack_
->pool
,
6864 ctx
, ffeexpr_cb_comma_ci_
);
6867 ffeexpr_stack_
->tokens
[0] = ffelex_token_use (ffeexpr_stack_
->first_token
);
6868 return (ffelexHandler
) ffeexpr_cb_close_paren_ (ft
, expr
, t
);
6871 /* ffeexpr_cb_comma_ci_ -- OPEN_PAREN expr COMMA expr
6873 Pass it to ffeexpr_rhs as the callback routine.
6875 If this token is not a comma, we have a complex constant (or an attempt
6876 at one), so handle it accordingly, displaying error messages if the token
6877 is not a close-paren. If we have a comma here, it is an attempt at an
6878 implied-DO, so start making a list accordingly. Oh, it might be an
6879 equal sign also, meaning an implied-DO with only one item in its list. */
6881 static ffelexHandler
6882 ffeexpr_cb_comma_ci_ (ffelexToken ft
, ffebld expr
, ffelexToken t
)
6886 /* First check to see if this is a possible complex constant. It is if the
6887 token is not a comma or an equals sign, in which case it should be a
6890 if ((ffelex_token_type (t
) != FFELEX_typeCOMMA
)
6891 && (ffelex_token_type (t
) != FFELEX_typeEQUALS
))
6893 ffeexpr_stack_
->tokens
[1] = ffeexpr_stack_
->tokens
[0];
6894 ffeexpr_stack_
->tokens
[0] = ffelex_token_use (ffeexpr_stack_
->first_token
);
6895 return (ffelexHandler
) ffeexpr_cb_comma_c_ (ft
, expr
, t
);
6898 /* Here we have either EQUALS or COMMA, meaning we are in an implied-DO
6899 construct. Make a list and handle accordingly. */
6901 ffelex_token_kill (ffeexpr_stack_
->tokens
[0]);
6902 fexpr
= ffeexpr_stack_
->expr
;
6903 ffebld_init_list (&ffeexpr_stack_
->expr
, &ffeexpr_stack_
->bottom
);
6904 ffebld_append_item (&ffeexpr_stack_
->bottom
, fexpr
);
6905 return (ffelexHandler
) ffeexpr_cb_comma_i_1_ (ft
, expr
, t
);
6908 /* ffeexpr_cb_comma_i_ -- OPEN_PAREN expr
6910 Pass it to ffeexpr_rhs as the callback routine.
6912 Handle first item in an implied-DO construct. */
6914 static ffelexHandler
6915 ffeexpr_cb_comma_i_ (ffelexToken ft
, ffebld expr
, ffelexToken t
)
6917 if (ffelex_token_type (t
) != FFELEX_typeCOMMA
)
6919 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO
))
6921 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
6922 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_
->first_token
),
6923 ffelex_token_where_column (ffeexpr_stack_
->first_token
));
6926 ffebld_end_list (&ffeexpr_stack_
->bottom
);
6927 ffeexpr_stack_
->expr
= ffebld_new_any ();
6928 ffebld_set_info (ffeexpr_stack_
->expr
, ffeinfo_new_any ());
6929 if (ffelex_token_type (t
) != FFELEX_typeCLOSE_PAREN
)
6930 return (ffelexHandler
) ffeexpr_cb_comma_i_5_ (t
);
6931 return (ffelexHandler
) ffeexpr_cb_comma_i_5_
;
6934 return (ffelexHandler
) ffeexpr_cb_comma_i_1_ (ft
, expr
, t
);
6937 /* ffeexpr_cb_comma_i_1_ -- OPEN_PAREN expr
6939 Pass it to ffeexpr_rhs as the callback routine.
6941 Handle first item in an implied-DO construct. */
6943 static ffelexHandler
6944 ffeexpr_cb_comma_i_1_ (ffelexToken ft
, ffebld expr
, ffelexToken t
)
6946 ffeexprContext ctxi
;
6947 ffeexprContext ctxc
;
6949 switch (ffeexpr_stack_
->context
)
6951 case FFEEXPR_contextDATA
:
6952 case FFEEXPR_contextDATAIMPDOITEM_
:
6953 ctxi
= FFEEXPR_contextDATAIMPDOITEM_
;
6954 ctxc
= FFEEXPR_contextDATAIMPDOCTRL_
;
6957 case FFEEXPR_contextIOLIST
:
6958 case FFEEXPR_contextIMPDOITEM_
:
6959 ctxi
= FFEEXPR_contextIMPDOITEM_
;
6960 ctxc
= FFEEXPR_contextIMPDOCTRL_
;
6963 case FFEEXPR_contextIOLISTDF
:
6964 case FFEEXPR_contextIMPDOITEMDF_
:
6965 ctxi
= FFEEXPR_contextIMPDOITEMDF_
;
6966 ctxc
= FFEEXPR_contextIMPDOCTRL_
;
6970 assert ("bad context" == NULL
);
6971 ctxi
= FFEEXPR_context
;
6972 ctxc
= FFEEXPR_context
;
6976 switch (ffelex_token_type (t
))
6978 case FFELEX_typeCOMMA
:
6979 ffebld_append_item (&ffeexpr_stack_
->bottom
, expr
);
6980 if (ffeexpr_stack_
->is_rhs
)
6981 return (ffelexHandler
) ffeexpr_rhs (ffeexpr_stack_
->pool
,
6982 ctxi
, ffeexpr_cb_comma_i_1_
);
6983 return (ffelexHandler
) ffeexpr_lhs (ffeexpr_stack_
->pool
,
6984 ctxi
, ffeexpr_cb_comma_i_1_
);
6986 case FFELEX_typeEQUALS
:
6987 ffebld_end_list (&ffeexpr_stack_
->bottom
);
6989 /* Complain if implied-DO variable in list of items to be read. */
6991 if ((ctxc
== FFEEXPR_contextIMPDOCTRL_
) && !ffeexpr_stack_
->is_rhs
)
6992 ffeexpr_check_impdo_ (ffeexpr_stack_
->expr
,
6993 ffeexpr_stack_
->first_token
, expr
, ft
);
6995 /* Set doiter flag for all appropriate SYMTERs. */
6997 ffeexpr_update_impdo_ (ffeexpr_stack_
->expr
, expr
);
6999 ffeexpr_stack_
->expr
= ffebld_new_impdo (ffeexpr_stack_
->expr
, NULL
);
7000 ffebld_set_info (ffeexpr_stack_
->expr
,
7001 ffeinfo_new (FFEINFO_basictypeNONE
,
7002 FFEINFO_kindtypeNONE
,
7006 FFETARGET_charactersizeNONE
));
7007 ffebld_init_list (&(ffebld_right (ffeexpr_stack_
->expr
)),
7008 &ffeexpr_stack_
->bottom
);
7009 ffebld_append_item (&ffeexpr_stack_
->bottom
, expr
);
7010 return (ffelexHandler
) ffeexpr_rhs (ffeexpr_stack_
->pool
,
7011 ctxc
, ffeexpr_cb_comma_i_2_
);
7014 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO
))
7016 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
7017 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_
->first_token
),
7018 ffelex_token_where_column (ffeexpr_stack_
->first_token
));
7021 ffebld_end_list (&ffeexpr_stack_
->bottom
);
7022 ffeexpr_stack_
->expr
= ffebld_new_any ();
7023 ffebld_set_info (ffeexpr_stack_
->expr
, ffeinfo_new_any ());
7024 if (ffelex_token_type (t
) != FFELEX_typeCLOSE_PAREN
)
7025 return (ffelexHandler
) ffeexpr_cb_comma_i_5_ (t
);
7026 return (ffelexHandler
) ffeexpr_cb_comma_i_5_
;
7030 /* ffeexpr_cb_comma_i_2_ -- OPEN_PAREN expr-list EQUALS expr
7032 Pass it to ffeexpr_rhs as the callback routine.
7034 Handle start-value in an implied-DO construct. */
7036 static ffelexHandler
7037 ffeexpr_cb_comma_i_2_ (ffelexToken ft UNUSED
, ffebld expr
, ffelexToken t
)
7041 switch (ffeexpr_stack_
->context
)
7043 case FFEEXPR_contextDATA
:
7044 case FFEEXPR_contextDATAIMPDOITEM_
:
7045 ctx
= FFEEXPR_contextDATAIMPDOCTRL_
;
7048 case FFEEXPR_contextIOLIST
:
7049 case FFEEXPR_contextIOLISTDF
:
7050 case FFEEXPR_contextIMPDOITEM_
:
7051 case FFEEXPR_contextIMPDOITEMDF_
:
7052 ctx
= FFEEXPR_contextIMPDOCTRL_
;
7056 assert ("bad context" == NULL
);
7057 ctx
= FFEEXPR_context
;
7061 switch (ffelex_token_type (t
))
7063 case FFELEX_typeCOMMA
:
7064 ffebld_append_item (&ffeexpr_stack_
->bottom
, expr
);
7065 return (ffelexHandler
) ffeexpr_rhs (ffeexpr_stack_
->pool
,
7066 ctx
, ffeexpr_cb_comma_i_3_
);
7070 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO
))
7072 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
7073 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_
->first_token
),
7074 ffelex_token_where_column (ffeexpr_stack_
->first_token
));
7077 ffebld_end_list (&ffeexpr_stack_
->bottom
);
7078 ffeexpr_stack_
->expr
= ffebld_new_any ();
7079 ffebld_set_info (ffeexpr_stack_
->expr
, ffeinfo_new_any ());
7080 if (ffelex_token_type (t
) != FFELEX_typeCLOSE_PAREN
)
7081 return (ffelexHandler
) ffeexpr_cb_comma_i_5_ (t
);
7082 return (ffelexHandler
) ffeexpr_cb_comma_i_5_
;
7086 /* ffeexpr_cb_comma_i_3_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7088 Pass it to ffeexpr_rhs as the callback routine.
7090 Handle end-value in an implied-DO construct. */
7092 static ffelexHandler
7093 ffeexpr_cb_comma_i_3_ (ffelexToken ft UNUSED
, ffebld expr
, ffelexToken t
)
7097 switch (ffeexpr_stack_
->context
)
7099 case FFEEXPR_contextDATA
:
7100 case FFEEXPR_contextDATAIMPDOITEM_
:
7101 ctx
= FFEEXPR_contextDATAIMPDOCTRL_
;
7104 case FFEEXPR_contextIOLIST
:
7105 case FFEEXPR_contextIOLISTDF
:
7106 case FFEEXPR_contextIMPDOITEM_
:
7107 case FFEEXPR_contextIMPDOITEMDF_
:
7108 ctx
= FFEEXPR_contextIMPDOCTRL_
;
7112 assert ("bad context" == NULL
);
7113 ctx
= FFEEXPR_context
;
7117 switch (ffelex_token_type (t
))
7119 case FFELEX_typeCOMMA
:
7120 ffebld_append_item (&ffeexpr_stack_
->bottom
, expr
);
7121 return (ffelexHandler
) ffeexpr_rhs (ffeexpr_stack_
->pool
,
7122 ctx
, ffeexpr_cb_comma_i_4_
);
7125 case FFELEX_typeCLOSE_PAREN
:
7126 ffebld_append_item (&ffeexpr_stack_
->bottom
, expr
);
7127 return (ffelexHandler
) ffeexpr_cb_comma_i_4_ (NULL
, NULL
, t
);
7131 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO
))
7133 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
7134 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_
->first_token
),
7135 ffelex_token_where_column (ffeexpr_stack_
->first_token
));
7138 ffebld_end_list (&ffeexpr_stack_
->bottom
);
7139 ffeexpr_stack_
->expr
= ffebld_new_any ();
7140 ffebld_set_info (ffeexpr_stack_
->expr
, ffeinfo_new_any ());
7141 if (ffelex_token_type (t
) != FFELEX_typeCLOSE_PAREN
)
7142 return (ffelexHandler
) ffeexpr_cb_comma_i_5_ (t
);
7143 return (ffelexHandler
) ffeexpr_cb_comma_i_5_
;
7147 /* ffeexpr_cb_comma_i_4_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7150 Pass it to ffeexpr_rhs as the callback routine.
7152 Handle incr-value in an implied-DO construct. */
7154 static ffelexHandler
7155 ffeexpr_cb_comma_i_4_ (ffelexToken ft UNUSED
, ffebld expr
, ffelexToken t
)
7157 switch (ffelex_token_type (t
))
7159 case FFELEX_typeCLOSE_PAREN
:
7160 ffebld_append_item (&ffeexpr_stack_
->bottom
, expr
);
7161 ffebld_end_list (&ffeexpr_stack_
->bottom
);
7165 for (item
= ffebld_left (ffeexpr_stack_
->expr
);
7167 item
= ffebld_trail (item
))
7168 if (ffebld_op (ffebld_head (item
)) == FFEBLD_opANY
)
7169 goto replace_with_any
; /* :::::::::::::::::::: */
7171 for (item
= ffebld_right (ffeexpr_stack_
->expr
);
7173 item
= ffebld_trail (item
))
7174 if ((ffebld_head (item
) != NULL
) /* Increment may be NULL. */
7175 && (ffebld_op (ffebld_head (item
)) == FFEBLD_opANY
))
7176 goto replace_with_any
; /* :::::::::::::::::::: */
7181 if (ffest_ffebad_start (FFEBAD_BAD_IMPDO
))
7183 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
7184 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_
->first_token
),
7185 ffelex_token_where_column (ffeexpr_stack_
->first_token
));
7188 ffebld_end_list (&ffeexpr_stack_
->bottom
);
7190 replace_with_any
: /* :::::::::::::::::::: */
7192 ffeexpr_stack_
->expr
= ffebld_new_any ();
7193 ffebld_set_info (ffeexpr_stack_
->expr
, ffeinfo_new_any ());
7197 if (ffelex_token_type (t
) == FFELEX_typeCLOSE_PAREN
)
7198 return (ffelexHandler
) ffeexpr_cb_comma_i_5_
;
7199 return (ffelexHandler
) ffeexpr_cb_comma_i_5_ (t
);
7202 /* ffeexpr_cb_comma_i_5_ -- OPEN_PAREN expr-list EQUALS expr COMMA expr
7203 [COMMA expr] CLOSE_PAREN
7205 Pass it to ffeexpr_rhs as the callback routine.
7207 Collects token following implied-DO construct for callback function. */
7209 static ffelexHandler
7210 ffeexpr_cb_comma_i_5_ (ffelexToken t
)
7212 ffeexprCallback callback
;
7219 switch (ffeexpr_stack_
->context
)
7221 case FFEEXPR_contextDATA
:
7222 case FFEEXPR_contextDATAIMPDOITEM_
:
7226 case FFEEXPR_contextIOLIST
:
7227 case FFEEXPR_contextIOLISTDF
:
7228 case FFEEXPR_contextIMPDOITEM_
:
7229 case FFEEXPR_contextIMPDOITEMDF_
:
7234 assert ("bad context" == NULL
);
7240 callback
= ffeexpr_stack_
->callback
;
7241 ft
= ffeexpr_stack_
->first_token
;
7242 expr
= ffeexpr_stack_
->expr
;
7243 s
= ffeexpr_stack_
->previous
;
7244 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_
,
7245 sizeof (*ffeexpr_stack_
));
7247 next
= (ffelexHandler
) (*callback
) (ft
, expr
, t
);
7248 ffelex_token_kill (ft
);
7251 ffesymbol_drive_sfnames (ffeexpr_check_impctrl_
);
7253 if (ffeexpr_level_
== 0)
7256 return (ffelexHandler
) next
;
7259 /* ffeexpr_cb_end_loc_ -- Handle end of %LOC subexpression
7261 Makes sure the end token is close-paren and swallows it, else issues
7262 an error message and doesn't swallow the token (passing it along instead).
7263 In either case wraps up subexpression construction by enclosing the
7264 ffebld expression in a %LOC. */
7266 static ffelexHandler
7267 ffeexpr_cb_end_loc_ (ffelexToken ft UNUSED
, ffebld expr
, ffelexToken t
)
7271 /* First push the (%LOC) expression as an operand onto the expression
7274 e
= ffeexpr_expr_new_ ();
7275 e
->type
= FFEEXPR_exprtypeOPERAND_
;
7276 e
->token
= ffeexpr_stack_
->tokens
[0];
7277 e
->u
.operand
= ffebld_new_percent_loc (expr
);
7278 ffebld_set_info (e
->u
.operand
,
7279 ffeinfo_new (FFEINFO_basictypeINTEGER
,
7280 ffecom_pointer_kind (),
7283 FFEINFO_whereFLEETING
,
7284 FFETARGET_charactersizeNONE
));
7286 e
->u
.operand
= ffeexpr_collapse_percent_loc (e
->u
.operand
, ft
);
7288 ffeexpr_exprstack_push_operand_ (e
);
7290 /* Now, if the token is a close parenthese, we're in great shape so return
7291 the next handler. */
7293 if (ffelex_token_type (t
) == FFELEX_typeCLOSE_PAREN
)
7295 ffelex_token_kill (ffeexpr_stack_
->tokens
[1]);
7296 return (ffelexHandler
) ffeexpr_token_binary_
;
7299 /* Oops, naughty user didn't specify the close paren! */
7301 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN
))
7303 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
7304 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_
->tokens
[1]),
7305 ffelex_token_where_column (ffeexpr_stack_
->tokens
[1]));
7309 ffelex_token_kill (ffeexpr_stack_
->tokens
[1]);
7311 (ffelexHandler
) ffeexpr_find_close_paren_ (t
,
7313 ffeexpr_token_binary_
);
7316 /* ffeexpr_cb_end_notloc_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
7318 Should be CLOSE_PAREN, and make sure expr isn't a %(VAL,REF,DESCR). */
7320 static ffelexHandler
7321 ffeexpr_cb_end_notloc_ (ffelexToken ft
, ffebld expr
, ffelexToken t
)
7326 /* If expression is itself a %(VAL,REF,DESCR), complain and strip off all
7327 such things until the lowest-level expression is reached. */
7329 op
= ffebld_op (expr
);
7330 if ((op
== FFEBLD_opPERCENT_VAL
) || (op
== FFEBLD_opPERCENT_REF
)
7331 || (op
== FFEBLD_opPERCENT_DESCR
))
7333 if (ffebad_start (FFEBAD_NESTED_PERCENT
))
7335 ffebad_here (0, ffelex_token_where_line (ft
),
7336 ffelex_token_where_column (ft
));
7342 expr
= ffebld_left (expr
);
7343 op
= ffebld_op (expr
);
7345 while ((op
== FFEBLD_opPERCENT_VAL
) || (op
== FFEBLD_opPERCENT_REF
)
7346 || (op
== FFEBLD_opPERCENT_DESCR
));
7349 /* Push the expression as an operand onto the expression stack. */
7351 e
= ffeexpr_expr_new_ ();
7352 e
->type
= FFEEXPR_exprtypeOPERAND_
;
7353 e
->token
= ffeexpr_stack_
->tokens
[0];
7354 switch (ffeexpr_stack_
->percent
)
7356 case FFEEXPR_percentVAL_
:
7357 e
->u
.operand
= ffebld_new_percent_val (expr
);
7360 case FFEEXPR_percentREF_
:
7361 e
->u
.operand
= ffebld_new_percent_ref (expr
);
7364 case FFEEXPR_percentDESCR_
:
7365 e
->u
.operand
= ffebld_new_percent_descr (expr
);
7369 assert ("%lossage" == NULL
);
7370 e
->u
.operand
= expr
;
7373 ffebld_set_info (e
->u
.operand
, ffebld_info (expr
));
7375 e
->u
.operand
= ffeexpr_collapse_percent_
? ? ? (e
->u
.operand
, ft
);
7377 ffeexpr_exprstack_push_operand_ (e
);
7379 /* Now, if the token is a close parenthese, we're in great shape so return
7380 the next handler. */
7382 if (ffelex_token_type (t
) == FFELEX_typeCLOSE_PAREN
)
7383 return (ffelexHandler
) ffeexpr_cb_end_notloc_1_
;
7385 /* Oops, naughty user didn't specify the close paren! */
7387 if (ffest_ffebad_start (FFEBAD_MISSING_CLOSE_PAREN
))
7389 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
7390 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_
->tokens
[1]),
7391 ffelex_token_where_column (ffeexpr_stack_
->tokens
[1]));
7395 ffebld_set_op (e
->u
.operand
, FFEBLD_opPERCENT_LOC
);
7397 switch (ffeexpr_stack_
->context
)
7399 case FFEEXPR_contextACTUALARG_
:
7400 ffeexpr_stack_
->context
= FFEEXPR_contextACTUALARGEXPR_
;
7403 case FFEEXPR_contextINDEXORACTUALARG_
:
7404 ffeexpr_stack_
->context
= FFEEXPR_contextINDEXORACTUALARGEXPR_
;
7407 case FFEEXPR_contextSFUNCDEFACTUALARG_
:
7408 ffeexpr_stack_
->context
= FFEEXPR_contextSFUNCDEFACTUALARGEXPR_
;
7411 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
:
7412 ffeexpr_stack_
->context
= FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_
;
7416 assert ("bad context?!?!" == NULL
);
7420 ffelex_token_kill (ffeexpr_stack_
->tokens
[1]);
7422 (ffelexHandler
) ffeexpr_find_close_paren_ (t
,
7424 ffeexpr_cb_end_notloc_1_
);
7427 /* ffeexpr_cb_end_notloc_1_ -- PERCENT NAME(VAL,REF,DESCR) OPEN_PAREN expr
7430 Should be COMMA or CLOSE_PAREN, else change back to %LOC. */
7432 static ffelexHandler
7433 ffeexpr_cb_end_notloc_1_ (ffelexToken t
)
7435 switch (ffelex_token_type (t
))
7437 case FFELEX_typeCOMMA
:
7438 case FFELEX_typeCLOSE_PAREN
:
7439 switch (ffeexpr_stack_
->context
)
7441 case FFEEXPR_contextACTUALARG_
:
7442 case FFEEXPR_contextSFUNCDEFACTUALARG_
:
7445 case FFEEXPR_contextINDEXORACTUALARG_
:
7446 ffeexpr_stack_
->context
= FFEEXPR_contextACTUALARG_
;
7449 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
:
7450 ffeexpr_stack_
->context
= FFEEXPR_contextSFUNCDEFACTUALARG_
;
7454 assert ("bad context?!?!" == NULL
);
7460 if (ffebad_start (FFEBAD_INVALID_PERCENT
))
7463 ffelex_token_where_line (ffeexpr_stack_
->first_token
),
7464 ffelex_token_where_column (ffeexpr_stack_
->first_token
));
7465 ffebad_string (ffelex_token_text (ffeexpr_stack_
->tokens
[1]));
7469 ffebld_set_op (ffeexpr_stack_
->exprstack
->u
.operand
,
7470 FFEBLD_opPERCENT_LOC
);
7472 switch (ffeexpr_stack_
->context
)
7474 case FFEEXPR_contextACTUALARG_
:
7475 ffeexpr_stack_
->context
= FFEEXPR_contextACTUALARGEXPR_
;
7478 case FFEEXPR_contextINDEXORACTUALARG_
:
7479 ffeexpr_stack_
->context
= FFEEXPR_contextINDEXORACTUALARGEXPR_
;
7482 case FFEEXPR_contextSFUNCDEFACTUALARG_
:
7483 ffeexpr_stack_
->context
= FFEEXPR_contextSFUNCDEFACTUALARGEXPR_
;
7486 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
:
7487 ffeexpr_stack_
->context
= FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_
;
7491 assert ("bad context?!?!" == NULL
);
7496 ffelex_token_kill (ffeexpr_stack_
->tokens
[1]);
7498 (ffelexHandler
) ffeexpr_token_binary_ (t
);
7501 /* Process DATA implied-DO iterator variables as this implied-DO level
7502 terminates. At this point, ffeexpr_level_ == 1 when we see the
7503 last right-paren in "DATA (A(I),I=1,10)/.../". */
7506 ffeexpr_check_impctrl_ (ffesymbol s
)
7509 assert (ffesymbol_sfdummyparent (s
) != NULL
);
7511 switch (ffesymbol_state (s
))
7513 case FFESYMBOL_stateNONE
: /* Used as iterator already. Now let symbol
7514 be used as iterator at any level at or
7515 innermore than the outermost of the
7516 current level and the symbol's current
7518 if (ffeexpr_level_
< ffesymbol_maxentrynum (s
))
7520 ffesymbol_signal_change (s
);
7521 ffesymbol_set_maxentrynum (s
, ffeexpr_level_
);
7522 ffesymbol_signal_unreported (s
);
7526 case FFESYMBOL_stateSEEN
: /* Seen already in this or other implied-DO.
7527 Error if at outermost level, else it can
7528 still become an iterator. */
7529 if ((ffeexpr_level_
== 1)
7530 && ffebad_start (FFEBAD_BAD_IMPDCL
))
7532 ffebad_string (ffesymbol_text (s
));
7533 ffebad_here (0, ffesymbol_where_line (s
), ffesymbol_where_column (s
));
7538 case FFESYMBOL_stateUNCERTAIN
: /* Iterator. */
7539 assert (ffeexpr_level_
<= ffesymbol_maxentrynum (s
));
7540 ffesymbol_signal_change (s
);
7541 ffesymbol_set_state (s
, FFESYMBOL_stateNONE
);
7542 ffesymbol_signal_unreported (s
);
7545 case FFESYMBOL_stateUNDERSTOOD
:
7549 assert ("Sasha Foo!!" == NULL
);
7556 /* Issue diagnostic if implied-DO variable appears in list of lhs
7557 expressions (as in "READ *, (I,I=1,10)"). */
7560 ffeexpr_check_impdo_ (ffebld list
, ffelexToken list_t
,
7561 ffebld dovar
, ffelexToken dovar_t
)
7564 ffesymbol dovar_sym
;
7567 if (ffebld_op (dovar
) != FFEBLD_opSYMTER
)
7568 return; /* Presumably opANY. */
7570 dovar_sym
= ffebld_symter (dovar
);
7572 for (itemnum
= 1; list
!= NULL
; list
= ffebld_trail (list
), ++itemnum
)
7574 if (((item
= ffebld_head (list
)) != NULL
)
7575 && (ffebld_op (item
) == FFEBLD_opSYMTER
)
7576 && (ffebld_symter (item
) == dovar_sym
))
7580 sprintf (&itemno
[0], "%d", itemnum
);
7581 if (ffebad_start (FFEBAD_DOITER_IMPDO
))
7583 ffebad_here (0, ffelex_token_where_line (list_t
),
7584 ffelex_token_where_column (list_t
));
7585 ffebad_here (1, ffelex_token_where_line (dovar_t
),
7586 ffelex_token_where_column (dovar_t
));
7587 ffebad_string (ffesymbol_text (dovar_sym
));
7588 ffebad_string (itemno
);
7595 /* Decorate any SYMTERs referencing the DO variable with the "doiter"
7599 ffeexpr_update_impdo_ (ffebld list
, ffebld dovar
)
7601 ffesymbol dovar_sym
;
7603 if (ffebld_op (dovar
) != FFEBLD_opSYMTER
)
7604 return; /* Presumably opANY. */
7606 dovar_sym
= ffebld_symter (dovar
);
7608 ffeexpr_update_impdo_sym_ (list
, dovar_sym
); /* Recurse! */
7611 /* Recursive function to update any expr so SYMTERs have "doiter" flag
7612 if they refer to the given variable. */
7615 ffeexpr_update_impdo_sym_ (ffebld expr
, ffesymbol dovar
)
7617 tail_recurse
: /* :::::::::::::::::::: */
7622 switch (ffebld_op (expr
))
7624 case FFEBLD_opSYMTER
:
7625 if (ffebld_symter (expr
) == dovar
)
7626 ffebld_symter_set_is_doiter (expr
, TRUE
);
7630 ffeexpr_update_impdo_sym_ (ffebld_head (expr
), dovar
);
7631 expr
= ffebld_trail (expr
);
7632 goto tail_recurse
; /* :::::::::::::::::::: */
7638 switch (ffebld_arity (expr
))
7641 ffeexpr_update_impdo_sym_ (ffebld_left (expr
), dovar
);
7642 expr
= ffebld_right (expr
);
7643 goto tail_recurse
; /* :::::::::::::::::::: */
7646 expr
= ffebld_left (expr
);
7647 goto tail_recurse
; /* :::::::::::::::::::: */
7656 /* ffeexpr_context_outer_ -- Determine context of stack entry, skipping PARENs
7658 if (ffeexpr_context_outer_(ffeexpr_stack_) == FFEEXPR_contextIF)
7659 // After zero or more PAREN_ contexts, an IF context exists */
7661 static ffeexprContext
7662 ffeexpr_context_outer_ (ffeexprStack_ s
)
7670 case FFEEXPR_contextPAREN_
:
7671 case FFEEXPR_contextPARENFILENUM_
:
7672 case FFEEXPR_contextPARENFILEUNIT_
:
7683 /* ffeexpr_percent_ -- Look up name in list of %FOO possibilities
7687 p = ffeexpr_percent_(t);
7689 Returns the identifier for the name, or the NONE identifier. */
7691 static ffeexprPercent_
7692 ffeexpr_percent_ (ffelexToken t
)
7696 switch (ffelex_token_length (t
))
7699 switch (*(p
= ffelex_token_text (t
)))
7701 case FFESRC_CASE_MATCH_INIT ('L', 'l', match_3l
, no_match_3
):
7702 if ((ffesrc_char_match_noninit (*++p
, 'O', 'o'))
7703 && (ffesrc_char_match_noninit (*++p
, 'C', 'c')))
7704 return FFEEXPR_percentLOC_
;
7705 return FFEEXPR_percentNONE_
;
7707 case FFESRC_CASE_MATCH_INIT ('R', 'r', match_3r
, no_match_3
):
7708 if ((ffesrc_char_match_noninit (*++p
, 'E', 'e'))
7709 && (ffesrc_char_match_noninit (*++p
, 'F', 'f')))
7710 return FFEEXPR_percentREF_
;
7711 return FFEEXPR_percentNONE_
;
7713 case FFESRC_CASE_MATCH_INIT ('V', 'v', match_3v
, no_match_3
):
7714 if ((ffesrc_char_match_noninit (*++p
, 'A', 'a'))
7715 && (ffesrc_char_match_noninit (*++p
, 'L', 'l')))
7716 return FFEEXPR_percentVAL_
;
7717 return FFEEXPR_percentNONE_
;
7720 no_match_3
: /* :::::::::::::::::::: */
7721 return FFEEXPR_percentNONE_
;
7725 if (ffesrc_strcmp_2c (ffe_case_match (), ffelex_token_text (t
), "DESCR",
7726 "descr", "Descr") == 0)
7727 return FFEEXPR_percentDESCR_
;
7728 return FFEEXPR_percentNONE_
;
7731 return FFEEXPR_percentNONE_
;
7735 /* ffeexpr_type_combine -- Binop combine types, check for mythical new COMPLEX
7739 If combining the two basictype/kindtype pairs produces a COMPLEX with an
7740 unsupported kind type, complain and use the default kind type for
7744 ffeexpr_type_combine (ffeinfoBasictype
*xnbt
, ffeinfoKindtype
*xnkt
,
7745 ffeinfoBasictype lbt
, ffeinfoKindtype lkt
,
7746 ffeinfoBasictype rbt
, ffeinfoKindtype rkt
,
7749 ffeinfoBasictype nbt
;
7750 ffeinfoKindtype nkt
;
7752 nbt
= ffeinfo_basictype_combine (lbt
, rbt
);
7753 if ((nbt
== FFEINFO_basictypeCOMPLEX
)
7754 && ((lbt
== nbt
) || (lbt
== FFEINFO_basictypeREAL
))
7755 && ((rbt
== nbt
) || (rbt
== FFEINFO_basictypeREAL
)))
7757 nkt
= ffeinfo_kindtype_max (nbt
, lkt
, rkt
);
7758 if (ffe_is_pedantic_not_90 () && (nkt
== FFEINFO_kindtypeREALDOUBLE
))
7759 nkt
= FFEINFO_kindtypeNONE
; /* Force error. */
7762 #if FFETARGET_okCOMPLEX1
7763 case FFEINFO_kindtypeREAL1
:
7765 #if FFETARGET_okCOMPLEX2
7766 case FFEINFO_kindtypeREAL2
:
7768 #if FFETARGET_okCOMPLEX3
7769 case FFEINFO_kindtypeREAL3
:
7771 break; /* Fine and dandy. */
7776 ffebad_start ((nkt
== FFEINFO_kindtypeREALDOUBLE
)
7777 ? FFEBAD_BAD_DBLCMPLX
: FFEBAD_BAD_COMPLEX
);
7778 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
7781 nbt
= FFEINFO_basictypeNONE
;
7782 nkt
= FFEINFO_kindtypeNONE
;
7785 case FFEINFO_kindtypeANY
:
7786 nkt
= FFEINFO_kindtypeREALDEFAULT
;
7791 { /* The normal stuff. */
7795 nkt
= ffeinfo_kindtype_max (nbt
, lkt
, rkt
);
7799 else if (nbt
== rbt
)
7802 { /* Let the caller do the complaining. */
7803 nbt
= FFEINFO_basictypeNONE
;
7804 nkt
= FFEINFO_kindtypeNONE
;
7808 /* Always a good idea to avoid aliasing problems. */
7814 /* ffeexpr_token_first_lhs_ -- First state for lhs expression
7816 Return a pointer to this function to the lexer (ffelex), which will
7817 invoke it for the next token.
7819 Record line and column of first token in expression, then invoke the
7820 initial-state lhs handler. */
7822 static ffelexHandler
7823 ffeexpr_token_first_lhs_ (ffelexToken t
)
7825 ffeexpr_stack_
->first_token
= ffelex_token_use (t
);
7827 /* When changing the list of valid initial lhs tokens, check whether to
7828 update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
7829 READ (expr) <token> case -- it assumes it knows which tokens <token> can
7830 be to indicate an lhs (or implied DO), which right now is the set
7833 This comment also appears in ffeexpr_token_lhs_. */
7835 switch (ffelex_token_type (t
))
7837 case FFELEX_typeOPEN_PAREN
:
7838 switch (ffeexpr_stack_
->context
)
7840 case FFEEXPR_contextDATA
:
7842 ffeexpr_level_
= 1; /* Level of DATA implied-DO construct. */
7843 ffebld_init_list (&ffeexpr_stack_
->expr
, &ffeexpr_stack_
->bottom
);
7844 return (ffelexHandler
) ffeexpr_lhs (ffeexpr_stack_
->pool
,
7845 FFEEXPR_contextDATAIMPDOITEM_
, ffeexpr_cb_comma_i_
);
7847 case FFEEXPR_contextDATAIMPDOITEM_
:
7848 ++ffeexpr_level_
; /* Level of DATA implied-DO construct. */
7849 ffebld_init_list (&ffeexpr_stack_
->expr
, &ffeexpr_stack_
->bottom
);
7850 return (ffelexHandler
) ffeexpr_lhs (ffeexpr_stack_
->pool
,
7851 FFEEXPR_contextDATAIMPDOITEM_
, ffeexpr_cb_comma_i_
);
7853 case FFEEXPR_contextIOLIST
:
7854 case FFEEXPR_contextIMPDOITEM_
:
7855 ffebld_init_list (&ffeexpr_stack_
->expr
, &ffeexpr_stack_
->bottom
);
7856 return (ffelexHandler
) ffeexpr_lhs (ffeexpr_stack_
->pool
,
7857 FFEEXPR_contextIMPDOITEM_
, ffeexpr_cb_comma_i_
);
7859 case FFEEXPR_contextIOLISTDF
:
7860 case FFEEXPR_contextIMPDOITEMDF_
:
7861 ffebld_init_list (&ffeexpr_stack_
->expr
, &ffeexpr_stack_
->bottom
);
7862 return (ffelexHandler
) ffeexpr_lhs (ffeexpr_stack_
->pool
,
7863 FFEEXPR_contextIMPDOITEMDF_
, ffeexpr_cb_comma_i_
);
7865 case FFEEXPR_contextFILEEXTFUNC
:
7866 assert (ffeexpr_stack_
->exprstack
== NULL
);
7867 return (ffelexHandler
) ffeexpr_token_first_lhs_1_
;
7874 case FFELEX_typeNAME
:
7875 switch (ffeexpr_stack_
->context
)
7877 case FFEEXPR_contextFILENAMELIST
:
7878 assert (ffeexpr_stack_
->exprstack
== NULL
);
7879 return (ffelexHandler
) ffeexpr_token_namelist_
;
7881 case FFEEXPR_contextFILEEXTFUNC
:
7882 assert (ffeexpr_stack_
->exprstack
== NULL
);
7883 return (ffelexHandler
) ffeexpr_token_first_lhs_1_
;
7891 switch (ffeexpr_stack_
->context
)
7893 case FFEEXPR_contextFILEEXTFUNC
:
7894 assert (ffeexpr_stack_
->exprstack
== NULL
);
7895 return (ffelexHandler
) ffeexpr_token_first_lhs_1_
;
7903 return (ffelexHandler
) ffeexpr_token_lhs_ (t
);
7906 /* ffeexpr_token_first_lhs_1_ -- NAME
7908 return ffeexpr_token_first_lhs_1_; // to lexer
7910 Handle NAME as an external function (USEROPEN= VXT extension to OPEN
7913 static ffelexHandler
7914 ffeexpr_token_first_lhs_1_ (ffelexToken t
)
7916 ffeexprCallback callback
;
7920 ffesymbol sy
= NULL
;
7924 callback
= ffeexpr_stack_
->callback
;
7925 ft
= ffeexpr_stack_
->first_token
;
7926 s
= ffeexpr_stack_
->previous
;
7928 if ((ffelex_token_type (ft
) != FFELEX_typeNAME
)
7929 || (ffesymbol_attrs (sy
= ffeexpr_declare_unadorned_ (ft
, FALSE
))
7930 & FFESYMBOL_attrANY
))
7932 if ((ffelex_token_type (ft
) != FFELEX_typeNAME
)
7933 || !(ffesymbol_attrs (sy
) & FFESYMBOL_attrsANY
))
7935 ffebad_start (FFEBAD_EXPR_WRONG
);
7936 ffebad_here (0, ffelex_token_where_line (ft
),
7937 ffelex_token_where_column (ft
));
7940 expr
= ffebld_new_any ();
7941 ffebld_set_info (expr
, ffeinfo_new_any ());
7945 expr
= ffebld_new_symter (sy
, FFEINTRIN_genNONE
, FFEINTRIN_specNONE
,
7947 ffebld_set_info (expr
, ffesymbol_info (sy
));
7950 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_
,
7951 sizeof (*ffeexpr_stack_
));
7954 next
= (ffelexHandler
) (*callback
) (ft
, expr
, t
);
7955 ffelex_token_kill (ft
);
7956 return (ffelexHandler
) next
;
7959 /* ffeexpr_token_first_rhs_ -- First state for rhs expression
7961 Record line and column of first token in expression, then invoke the
7962 initial-state rhs handler.
7965 Allow ASTERISK in PARENFILEUNIT_ case, but only on second level only
7966 (i.e. only as in READ(*), not READ((*))). */
7968 static ffelexHandler
7969 ffeexpr_token_first_rhs_ (ffelexToken t
)
7973 ffeexpr_stack_
->first_token
= ffelex_token_use (t
);
7975 switch (ffelex_token_type (t
))
7977 case FFELEX_typeASTERISK
:
7978 switch (ffeexpr_stack_
->context
)
7980 case FFEEXPR_contextFILEFORMATNML
:
7981 ffeexpr_stack_
->context
= FFEEXPR_contextFILEFORMAT
;
7983 case FFEEXPR_contextFILEUNIT
:
7984 case FFEEXPR_contextDIMLIST
:
7985 case FFEEXPR_contextFILEFORMAT
:
7986 case FFEEXPR_contextCHARACTERSIZE
:
7987 if (ffeexpr_stack_
->previous
!= NULL
)
7988 break; /* Valid only on first level. */
7989 assert (ffeexpr_stack_
->exprstack
== NULL
);
7990 return (ffelexHandler
) ffeexpr_token_first_rhs_1_
;
7992 case FFEEXPR_contextPARENFILEUNIT_
:
7993 if (ffeexpr_stack_
->previous
->previous
!= NULL
)
7994 break; /* Valid only on second level. */
7995 assert (ffeexpr_stack_
->exprstack
== NULL
);
7996 return (ffelexHandler
) ffeexpr_token_first_rhs_1_
;
7998 case FFEEXPR_contextACTUALARG_
:
7999 if (ffeexpr_stack_
->previous
->context
8000 != FFEEXPR_contextSUBROUTINEREF
)
8002 ffeexpr_stack_
->context
= FFEEXPR_contextACTUALARGEXPR_
;
8005 assert (ffeexpr_stack_
->exprstack
== NULL
);
8006 return (ffelexHandler
) ffeexpr_token_first_rhs_3_
;
8008 case FFEEXPR_contextINDEXORACTUALARG_
:
8009 ffeexpr_stack_
->context
= FFEEXPR_contextINDEXORACTUALARGEXPR_
;
8012 case FFEEXPR_contextSFUNCDEFACTUALARG_
:
8013 ffeexpr_stack_
->context
= FFEEXPR_contextSFUNCDEFACTUALARGEXPR_
;
8016 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
:
8017 ffeexpr_stack_
->context
= FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_
;
8025 case FFELEX_typeOPEN_PAREN
:
8026 switch (ffeexpr_stack_
->context
)
8028 case FFEEXPR_contextFILENUMAMBIG
:
8029 return (ffelexHandler
) ffeexpr_rhs (ffeexpr_stack_
->pool
,
8030 FFEEXPR_contextPARENFILENUM_
,
8031 ffeexpr_cb_close_paren_ambig_
);
8033 case FFEEXPR_contextFILEUNITAMBIG
:
8034 return (ffelexHandler
) ffeexpr_rhs (ffeexpr_stack_
->pool
,
8035 FFEEXPR_contextPARENFILEUNIT_
,
8036 ffeexpr_cb_close_paren_ambig_
);
8038 case FFEEXPR_contextIOLIST
:
8039 case FFEEXPR_contextIMPDOITEM_
:
8040 return (ffelexHandler
) ffeexpr_rhs (ffeexpr_stack_
->pool
,
8041 FFEEXPR_contextIMPDOITEM_
,
8042 ffeexpr_cb_close_paren_ci_
);
8044 case FFEEXPR_contextIOLISTDF
:
8045 case FFEEXPR_contextIMPDOITEMDF_
:
8046 return (ffelexHandler
) ffeexpr_rhs (ffeexpr_stack_
->pool
,
8047 FFEEXPR_contextIMPDOITEMDF_
,
8048 ffeexpr_cb_close_paren_ci_
);
8050 case FFEEXPR_contextFILEFORMATNML
:
8051 ffeexpr_stack_
->context
= FFEEXPR_contextFILEFORMAT
;
8054 case FFEEXPR_contextACTUALARG_
:
8055 ffeexpr_stack_
->context
= FFEEXPR_contextACTUALARGEXPR_
;
8058 case FFEEXPR_contextINDEXORACTUALARG_
:
8059 ffeexpr_stack_
->context
= FFEEXPR_contextINDEXORACTUALARGEXPR_
;
8062 case FFEEXPR_contextSFUNCDEFACTUALARG_
:
8063 ffeexpr_stack_
->context
= FFEEXPR_contextSFUNCDEFACTUALARGEXPR_
;
8066 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
:
8067 ffeexpr_stack_
->context
= FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_
;
8075 case FFELEX_typeNUMBER
:
8076 switch (ffeexpr_stack_
->context
)
8078 case FFEEXPR_contextFILEFORMATNML
:
8079 ffeexpr_stack_
->context
= FFEEXPR_contextFILEFORMAT
;
8081 case FFEEXPR_contextFILEFORMAT
:
8082 if (ffeexpr_stack_
->previous
!= NULL
)
8083 break; /* Valid only on first level. */
8084 assert (ffeexpr_stack_
->exprstack
== NULL
);
8085 return (ffelexHandler
) ffeexpr_token_first_rhs_2_
;
8087 case FFEEXPR_contextACTUALARG_
:
8088 ffeexpr_stack_
->context
= FFEEXPR_contextACTUALARGEXPR_
;
8091 case FFEEXPR_contextINDEXORACTUALARG_
:
8092 ffeexpr_stack_
->context
= FFEEXPR_contextINDEXORACTUALARGEXPR_
;
8095 case FFEEXPR_contextSFUNCDEFACTUALARG_
:
8096 ffeexpr_stack_
->context
= FFEEXPR_contextSFUNCDEFACTUALARGEXPR_
;
8099 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
:
8100 ffeexpr_stack_
->context
= FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_
;
8108 case FFELEX_typeNAME
:
8109 switch (ffeexpr_stack_
->context
)
8111 case FFEEXPR_contextFILEFORMATNML
:
8112 assert (ffeexpr_stack_
->exprstack
== NULL
);
8113 s
= ffesymbol_lookup_local (t
);
8114 if ((s
!= NULL
) && (ffesymbol_kind (s
) == FFEINFO_kindNAMELIST
))
8115 return (ffelexHandler
) ffeexpr_token_namelist_
;
8116 ffeexpr_stack_
->context
= FFEEXPR_contextFILEFORMAT
;
8124 case FFELEX_typePERCENT
:
8125 switch (ffeexpr_stack_
->context
)
8127 case FFEEXPR_contextACTUALARG_
:
8128 case FFEEXPR_contextINDEXORACTUALARG_
:
8129 case FFEEXPR_contextSFUNCDEFACTUALARG_
:
8130 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
:
8131 return (ffelexHandler
) ffeexpr_token_first_rhs_5_
;
8133 case FFEEXPR_contextFILEFORMATNML
:
8134 ffeexpr_stack_
->context
= FFEEXPR_contextFILEFORMAT
;
8142 switch (ffeexpr_stack_
->context
)
8144 case FFEEXPR_contextACTUALARG_
:
8145 ffeexpr_stack_
->context
= FFEEXPR_contextACTUALARGEXPR_
;
8148 case FFEEXPR_contextINDEXORACTUALARG_
:
8149 ffeexpr_stack_
->context
= FFEEXPR_contextINDEXORACTUALARGEXPR_
;
8152 case FFEEXPR_contextSFUNCDEFACTUALARG_
:
8153 ffeexpr_stack_
->context
= FFEEXPR_contextSFUNCDEFACTUALARGEXPR_
;
8156 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
:
8157 ffeexpr_stack_
->context
= FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_
;
8160 case FFEEXPR_contextFILEFORMATNML
:
8161 ffeexpr_stack_
->context
= FFEEXPR_contextFILEFORMAT
;
8170 return (ffelexHandler
) ffeexpr_token_rhs_ (t
);
8173 /* ffeexpr_token_first_rhs_1_ -- ASTERISK
8175 return ffeexpr_token_first_rhs_1_; // to lexer
8177 Return STAR as expression. */
8179 static ffelexHandler
8180 ffeexpr_token_first_rhs_1_ (ffelexToken t
)
8183 ffeexprCallback callback
;
8188 expr
= ffebld_new_star ();
8190 callback
= ffeexpr_stack_
->callback
;
8191 ft
= ffeexpr_stack_
->first_token
;
8192 s
= ffeexpr_stack_
->previous
;
8193 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_
, sizeof (*ffeexpr_stack_
));
8195 next
= (ffelexHandler
) (*callback
) (ft
, expr
, t
);
8196 ffelex_token_kill (ft
);
8197 return (ffelexHandler
) next
;
8200 /* ffeexpr_token_first_rhs_2_ -- NUMBER
8202 return ffeexpr_token_first_rhs_2_; // to lexer
8204 Return NULL as expression; NUMBER as first (and only) token, unless the
8205 current token is not a terminating token, in which case run normal
8206 expression handling. */
8208 static ffelexHandler
8209 ffeexpr_token_first_rhs_2_ (ffelexToken t
)
8211 ffeexprCallback callback
;
8216 switch (ffelex_token_type (t
))
8218 case FFELEX_typeCLOSE_PAREN
:
8219 case FFELEX_typeCOMMA
:
8220 case FFELEX_typeEOS
:
8221 case FFELEX_typeSEMICOLON
:
8225 next
= (ffelexHandler
) ffeexpr_token_rhs_ (ffeexpr_stack_
->first_token
);
8226 return (ffelexHandler
) (*next
) (t
);
8230 callback
= ffeexpr_stack_
->callback
;
8231 ft
= ffeexpr_stack_
->first_token
;
8232 s
= ffeexpr_stack_
->previous
;
8233 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_
,
8234 sizeof (*ffeexpr_stack_
));
8236 next
= (ffelexHandler
) (*callback
) (ft
, NULL
, t
);
8237 ffelex_token_kill (ft
);
8238 return (ffelexHandler
) next
;
8241 /* ffeexpr_token_first_rhs_3_ -- ASTERISK
8243 return ffeexpr_token_first_rhs_3_; // to lexer
8245 Expect NUMBER, make LABTOK (with copy of token if not inhibited after
8246 confirming, else NULL). */
8248 static ffelexHandler
8249 ffeexpr_token_first_rhs_3_ (ffelexToken t
)
8253 if (ffelex_token_type (t
) != FFELEX_typeNUMBER
)
8254 { /* An error, but let normal processing handle
8256 next
= (ffelexHandler
) ffeexpr_token_rhs_ (ffeexpr_stack_
->first_token
);
8257 return (ffelexHandler
) (*next
) (t
);
8260 /* Special case: when we see "*10" as an argument to a subroutine
8261 reference, we confirm the current statement and, if not inhibited at
8262 this point, put a copy of the token into a LABTOK node. We do this
8263 instead of just resolving the label directly via ffelab and putting it
8264 into a LABTER simply to improve error reporting and consistency in
8265 ffestc. We put NULL in the LABTOK if we're still inhibited, so ffestb
8266 doesn't have to worry about killing off any tokens when retracting. */
8269 if (ffest_is_inhibited ())
8270 ffeexpr_stack_
->expr
= ffebld_new_labtok (NULL
);
8272 ffeexpr_stack_
->expr
= ffebld_new_labtok (ffelex_token_use (t
));
8273 ffebld_set_info (ffeexpr_stack_
->expr
,
8274 ffeinfo_new (FFEINFO_basictypeNONE
,
8275 FFEINFO_kindtypeNONE
,
8279 FFETARGET_charactersizeNONE
));
8281 return (ffelexHandler
) ffeexpr_token_first_rhs_4_
;
8284 /* ffeexpr_token_first_rhs_4_ -- ASTERISK NUMBER
8286 return ffeexpr_token_first_rhs_4_; // to lexer
8288 Collect/flush appropriate stuff, send token to callback function. */
8290 static ffelexHandler
8291 ffeexpr_token_first_rhs_4_ (ffelexToken t
)
8294 ffeexprCallback callback
;
8299 expr
= ffeexpr_stack_
->expr
;
8301 callback
= ffeexpr_stack_
->callback
;
8302 ft
= ffeexpr_stack_
->first_token
;
8303 s
= ffeexpr_stack_
->previous
;
8304 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_
, sizeof (*ffeexpr_stack_
));
8306 next
= (ffelexHandler
) (*callback
) (ft
, expr
, t
);
8307 ffelex_token_kill (ft
);
8308 return (ffelexHandler
) next
;
8311 /* ffeexpr_token_first_rhs_5_ -- PERCENT
8313 Should be NAME, or pass through original mechanism. If NAME is LOC,
8314 pass through original mechanism, otherwise must be VAL, REF, or DESCR,
8315 in which case handle the argument (in parentheses), etc. */
8317 static ffelexHandler
8318 ffeexpr_token_first_rhs_5_ (ffelexToken t
)
8322 if (ffelex_token_type (t
) == FFELEX_typeNAME
)
8324 ffeexprPercent_ p
= ffeexpr_percent_ (t
);
8328 case FFEEXPR_percentNONE_
:
8329 case FFEEXPR_percentLOC_
:
8330 break; /* Treat %LOC as any other expression. */
8332 case FFEEXPR_percentVAL_
:
8333 case FFEEXPR_percentREF_
:
8334 case FFEEXPR_percentDESCR_
:
8335 ffeexpr_stack_
->percent
= p
;
8336 ffeexpr_stack_
->tokens
[0] = ffelex_token_use (t
);
8337 return (ffelexHandler
) ffeexpr_token_first_rhs_6_
;
8340 assert ("bad percent?!?" == NULL
);
8345 switch (ffeexpr_stack_
->context
)
8347 case FFEEXPR_contextACTUALARG_
:
8348 ffeexpr_stack_
->context
= FFEEXPR_contextACTUALARGEXPR_
;
8351 case FFEEXPR_contextINDEXORACTUALARG_
:
8352 ffeexpr_stack_
->context
= FFEEXPR_contextINDEXORACTUALARGEXPR_
;
8355 case FFEEXPR_contextSFUNCDEFACTUALARG_
:
8356 ffeexpr_stack_
->context
= FFEEXPR_contextSFUNCDEFACTUALARGEXPR_
;
8359 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
:
8360 ffeexpr_stack_
->context
= FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_
;
8364 assert ("bad context?!?!" == NULL
);
8368 next
= (ffelexHandler
) ffeexpr_token_rhs_ (ffeexpr_stack_
->first_token
);
8369 return (ffelexHandler
) (*next
) (t
);
8372 /* ffeexpr_token_first_rhs_6_ -- PERCENT NAME(VAL,REF,DESCR)
8374 Should be OPEN_PAREN, or pass through original mechanism. */
8376 static ffelexHandler
8377 ffeexpr_token_first_rhs_6_ (ffelexToken t
)
8382 if (ffelex_token_type (t
) == FFELEX_typeOPEN_PAREN
)
8384 ffeexpr_stack_
->tokens
[1] = ffelex_token_use (t
);
8385 return (ffelexHandler
) ffeexpr_rhs (ffeexpr_stack_
->pool
,
8386 ffeexpr_stack_
->context
,
8387 ffeexpr_cb_end_notloc_
);
8390 switch (ffeexpr_stack_
->context
)
8392 case FFEEXPR_contextACTUALARG_
:
8393 ffeexpr_stack_
->context
= FFEEXPR_contextACTUALARGEXPR_
;
8396 case FFEEXPR_contextINDEXORACTUALARG_
:
8397 ffeexpr_stack_
->context
= FFEEXPR_contextINDEXORACTUALARGEXPR_
;
8400 case FFEEXPR_contextSFUNCDEFACTUALARG_
:
8401 ffeexpr_stack_
->context
= FFEEXPR_contextSFUNCDEFACTUALARGEXPR_
;
8404 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
:
8405 ffeexpr_stack_
->context
= FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_
;
8409 assert ("bad context?!?!" == NULL
);
8413 ft
= ffeexpr_stack_
->tokens
[0];
8414 next
= (ffelexHandler
) ffeexpr_token_rhs_ (ffeexpr_stack_
->first_token
);
8415 next
= (ffelexHandler
) (*next
) (ft
);
8416 ffelex_token_kill (ft
);
8417 return (ffelexHandler
) (*next
) (t
);
8420 /* ffeexpr_token_namelist_ -- NAME
8422 return ffeexpr_token_namelist_; // to lexer
8424 Make sure NAME was a valid namelist object, wrap it in a SYMTER and
8427 static ffelexHandler
8428 ffeexpr_token_namelist_ (ffelexToken t
)
8430 ffeexprCallback callback
;
8438 callback
= ffeexpr_stack_
->callback
;
8439 ft
= ffeexpr_stack_
->first_token
;
8440 s
= ffeexpr_stack_
->previous
;
8441 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_
, sizeof (*ffeexpr_stack_
));
8444 sy
= ffesymbol_lookup_local (ft
);
8445 if ((sy
== NULL
) || (ffesymbol_kind (sy
) != FFEINFO_kindNAMELIST
))
8447 ffebad_start (FFEBAD_EXPR_WRONG
);
8448 ffebad_here (0, ffelex_token_where_line (ft
),
8449 ffelex_token_where_column (ft
));
8451 expr
= ffebld_new_any ();
8452 ffebld_set_info (expr
, ffeinfo_new_any ());
8456 expr
= ffebld_new_symter (sy
, FFEINTRIN_genNONE
, FFEINTRIN_specNONE
,
8458 ffebld_set_info (expr
, ffesymbol_info (sy
));
8460 next
= (ffelexHandler
) (*callback
) (ft
, expr
, t
);
8461 ffelex_token_kill (ft
);
8462 return (ffelexHandler
) next
;
8465 /* ffeexpr_expr_kill_ -- Kill an existing internal expression object
8468 ffeexpr_expr_kill_(e);
8470 Kills the ffewhere info, if necessary, then kills the object. */
8473 ffeexpr_expr_kill_ (ffeexprExpr_ e
)
8475 if (e
->token
!= NULL
)
8476 ffelex_token_kill (e
->token
);
8477 malloc_kill_ks (ffe_pool_program_unit (), e
, sizeof (*e
));
8480 /* ffeexpr_expr_new_ -- Make a new internal expression object
8483 e = ffeexpr_expr_new_();
8485 Allocates and initializes a new expression object, returns it. */
8488 ffeexpr_expr_new_ (void)
8492 e
= malloc_new_ks (ffe_pool_program_unit (), "FFEEXPR expr", sizeof (*e
));
8494 e
->type
= FFEEXPR_exprtypeUNKNOWN_
;
8499 /* Verify that call to global is valid, and register whatever
8500 new information about a global might be discoverable by looking
8504 ffeexpr_fulfill_call_ (ffebld
*expr
, ffelexToken t
)
8511 assert ((ffebld_op (*expr
) == FFEBLD_opSUBRREF
)
8512 || (ffebld_op (*expr
) == FFEBLD_opFUNCREF
));
8514 if (ffebld_op (ffebld_left (*expr
)) != FFEBLD_opSYMTER
)
8517 if (ffesymbol_retractable ())
8520 s
= ffebld_symter (ffebld_left (*expr
));
8521 if (ffesymbol_global (s
) == NULL
)
8524 for (n_args
= 0, list
= ffebld_right (*expr
);
8526 list
= ffebld_trail (list
), ++n_args
)
8529 if (ffeglobal_proc_ref_nargs (s
, n_args
, t
))
8531 ffeglobalArgSummary as
;
8532 ffeinfoBasictype bt
;
8537 for (n_args
= 0, list
= ffebld_right (*expr
);
8539 list
= ffebld_trail (list
), ++n_args
)
8541 item
= ffebld_head (list
);
8544 bt
= ffeinfo_basictype (ffebld_info (item
));
8545 kt
= ffeinfo_kindtype (ffebld_info (item
));
8546 array
= (ffeinfo_rank (ffebld_info (item
)) > 0);
8547 switch (ffebld_op (item
))
8549 case FFEBLD_opLABTOK
:
8550 case FFEBLD_opLABTER
:
8551 as
= FFEGLOBAL_argsummaryALTRTN
;
8555 /* No, %LOC(foo) is just like any INTEGER(KIND=7)
8556 expression, so don't treat it specially. */
8557 case FFEBLD_opPERCENT_LOC
:
8558 as
= FFEGLOBAL_argsummaryPTR
;
8562 case FFEBLD_opPERCENT_VAL
:
8563 as
= FFEGLOBAL_argsummaryVAL
;
8566 case FFEBLD_opPERCENT_REF
:
8567 as
= FFEGLOBAL_argsummaryREF
;
8570 case FFEBLD_opPERCENT_DESCR
:
8571 as
= FFEGLOBAL_argsummaryDESCR
;
8574 case FFEBLD_opFUNCREF
:
8576 /* No, LOC(foo) is just like any INTEGER(KIND=7)
8577 expression, so don't treat it specially. */
8578 if ((ffebld_op (ffebld_left (item
)) == FFEBLD_opSYMTER
)
8579 && (ffesymbol_specific (ffebld_symter (ffebld_left (item
)))
8580 == FFEINTRIN_specLOC
))
8582 as
= FFEGLOBAL_argsummaryPTR
;
8588 if (ffebld_op (item
) == FFEBLD_opSYMTER
)
8590 as
= FFEGLOBAL_argsummaryNONE
;
8592 switch (ffeinfo_kind (ffebld_info (item
)))
8594 case FFEINFO_kindFUNCTION
:
8595 as
= FFEGLOBAL_argsummaryFUNC
;
8598 case FFEINFO_kindSUBROUTINE
:
8599 as
= FFEGLOBAL_argsummarySUBR
;
8602 case FFEINFO_kindNONE
:
8603 as
= FFEGLOBAL_argsummaryPROC
;
8610 if (as
!= FFEGLOBAL_argsummaryNONE
)
8614 if (bt
== FFEINFO_basictypeCHARACTER
)
8615 as
= FFEGLOBAL_argsummaryDESCR
;
8617 as
= FFEGLOBAL_argsummaryREF
;
8624 as
= FFEGLOBAL_argsummaryNONE
;
8625 bt
= FFEINFO_basictypeNONE
;
8626 kt
= FFEINFO_kindtypeNONE
;
8629 if (! ffeglobal_proc_ref_arg (s
, n_args
, as
, bt
, kt
, array
, t
))
8636 *expr
= ffebld_new_any ();
8637 ffebld_set_info (*expr
, ffeinfo_new_any ());
8640 /* Check whether rest of string is all decimal digits. */
8643 ffeexpr_isdigits_ (const char *p
)
8645 for (; *p
!= '\0'; ++p
)
8651 /* ffeexpr_exprstack_push_ -- Push an arbitrary expression object onto the stack
8654 ffeexpr_exprstack_push_(e);
8656 Pushes the expression onto the stack without any analysis of the existing
8657 contents of the stack. */
8660 ffeexpr_exprstack_push_ (ffeexprExpr_ e
)
8662 e
->previous
= ffeexpr_stack_
->exprstack
;
8663 ffeexpr_stack_
->exprstack
= e
;
8666 /* ffeexpr_exprstack_push_operand_ -- Push an operand onto the stack, reduce?
8669 ffeexpr_exprstack_push_operand_(e);
8671 Pushes the expression already containing an operand (a constant, variable,
8672 or more complicated expression that has already been fully resolved) after
8673 analyzing the stack and checking for possible reduction (which will never
8674 happen here since the highest precedence operator is ** and it has right-
8675 to-left associativity). */
8678 ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e
)
8680 ffeexpr_exprstack_push_ (e
);
8683 /* ffeexpr_exprstack_push_unary_ -- Push a unary operator onto the stack
8686 ffeexpr_exprstack_push_unary_(e);
8688 Pushes the expression already containing a unary operator. Reduction can
8689 never happen since unary operators are themselves always R-L; that is, the
8690 top of the expression stack is not an operand, in that it is either empty,
8691 has a binary operator at the top, or a unary operator at the top. In any
8692 of these cases, reduction is impossible. */
8695 ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e
)
8697 if ((ffe_is_pedantic ()
8698 || ffe_is_warn_surprising ())
8699 && (ffeexpr_stack_
->exprstack
!= NULL
)
8700 && (ffeexpr_stack_
->exprstack
->type
!= FFEEXPR_exprtypeOPERAND_
)
8701 && (ffeexpr_stack_
->exprstack
->u
.operator.prec
8702 <= FFEEXPR_operatorprecedenceLOWARITH_
)
8703 && (e
->u
.operator.prec
<= FFEEXPR_operatorprecedenceLOWARITH_
))
8705 /* xgettext:no-c-format */
8706 ffebad_start_msg ("Two arithmetic operators in a row at %0 and %1 -- use parentheses",
8708 ? FFEBAD_severityPEDANTIC
8709 : FFEBAD_severityWARNING
);
8711 ffelex_token_where_line (ffeexpr_stack_
->exprstack
->token
),
8712 ffelex_token_where_column (ffeexpr_stack_
->exprstack
->token
));
8714 ffelex_token_where_line (e
->token
),
8715 ffelex_token_where_column (e
->token
));
8719 ffeexpr_exprstack_push_ (e
);
8722 /* ffeexpr_exprstack_push_binary_ -- Push a binary operator onto the stack, reduce?
8725 ffeexpr_exprstack_push_binary_(e);
8727 Pushes the expression already containing a binary operator after checking
8728 whether reduction is possible. If the stack is not empty, the top of the
8729 stack must be an operand or syntactic analysis has failed somehow. If
8730 the operand is preceded by a unary operator of higher (or equal and L-R
8731 associativity) precedence than the new binary operator, then reduce that
8732 preceding operator and its operand(s) before pushing the new binary
8736 ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e
)
8740 if (ffe_is_warn_surprising ()
8741 /* These next two are always true (see assertions below). */
8742 && (ffeexpr_stack_
->exprstack
!= NULL
)
8743 && (ffeexpr_stack_
->exprstack
->type
== FFEEXPR_exprtypeOPERAND_
)
8744 /* If the previous operator is a unary minus, and the binary op
8745 is of higher precedence, might not do what user expects,
8746 e.g. "-2**2" is "-(2**2)", i.e. "-4", not "(-2)**2", which would
8748 && (ffeexpr_stack_
->exprstack
->previous
!= NULL
)
8749 && (ffeexpr_stack_
->exprstack
->previous
->type
== FFEEXPR_exprtypeUNARY_
)
8750 && (ffeexpr_stack_
->exprstack
->previous
->u
.operator.op
8751 == FFEEXPR_operatorSUBTRACT_
)
8752 && (e
->u
.operator.prec
8753 < ffeexpr_stack_
->exprstack
->previous
->u
.operator.prec
))
8755 /* xgettext:no-c-format */
8756 ffebad_start_msg ("Operator at %0 has lower precedence than that at %1 -- use parentheses", FFEBAD_severityWARNING
);
8758 ffelex_token_where_line (ffeexpr_stack_
->exprstack
->previous
->token
),
8759 ffelex_token_where_column (ffeexpr_stack_
->exprstack
->previous
->token
));
8761 ffelex_token_where_line (e
->token
),
8762 ffelex_token_where_column (e
->token
));
8767 assert (ffeexpr_stack_
->exprstack
!= NULL
);
8768 assert (ffeexpr_stack_
->exprstack
->type
== FFEEXPR_exprtypeOPERAND_
);
8769 if ((ce
= ffeexpr_stack_
->exprstack
->previous
) != NULL
)
8771 assert (ce
->type
!= FFEEXPR_exprtypeOPERAND_
);
8772 if ((ce
->u
.operator.prec
< e
->u
.operator.prec
)
8773 || ((ce
->u
.operator.prec
== e
->u
.operator.prec
)
8774 && (e
->u
.operator.as
== FFEEXPR_operatorassociativityL2R_
)))
8777 goto again
; /* :::::::::::::::::::: */
8781 ffeexpr_exprstack_push_ (e
);
8784 /* ffeexpr_reduce_ -- Reduce highest operator w/operands on stack
8788 Converts operand binop operand or unop operand at top of stack to a
8789 single operand having the appropriate ffebld expression, and makes
8790 sure that the expression is proper (like not trying to add two character
8791 variables, not trying to concatenate two numbers). Also does the
8792 requisite type-assignment. */
8795 ffeexpr_reduce_ (void)
8797 ffeexprExpr_ operand
; /* This is B in -B or A+B. */
8798 ffeexprExpr_ left_operand
; /* When operator is binary, this is A in A+B. */
8799 ffeexprExpr_
operator; /* This is + in A+B. */
8800 ffebld reduced
; /* This is +(A,B) in A+B or u-(B) in -B. */
8801 ffebldConstant constnode
; /* For checking magical numbers (where mag ==
8805 bool submag
= FALSE
;
8808 operand
= ffeexpr_stack_
->exprstack
;
8809 assert (operand
!= NULL
);
8810 assert (operand
->type
== FFEEXPR_exprtypeOPERAND_
);
8811 operator = operand
->previous
;
8812 assert (operator != NULL
);
8813 assert (operator->type
!= FFEEXPR_exprtypeOPERAND_
);
8814 if (operator->type
== FFEEXPR_exprtypeUNARY_
)
8816 expr
= operand
->u
.operand
;
8817 switch (operator->u
.operator.op
)
8819 case FFEEXPR_operatorADD_
:
8820 reduced
= ffebld_new_uplus (expr
);
8821 if (ffe_is_ugly_logint ())
8822 reduced
= ffeexpr_reduced_ugly1_ (reduced
, operator, operand
);
8823 reduced
= ffeexpr_reduced_math1_ (reduced
, operator, operand
);
8824 reduced
= ffeexpr_collapse_uplus (reduced
, operator->token
);
8827 case FFEEXPR_operatorSUBTRACT_
:
8828 submag
= TRUE
; /* Ok to negate a magic number. */
8829 reduced
= ffebld_new_uminus (expr
);
8830 if (ffe_is_ugly_logint ())
8831 reduced
= ffeexpr_reduced_ugly1_ (reduced
, operator, operand
);
8832 reduced
= ffeexpr_reduced_math1_ (reduced
, operator, operand
);
8833 reduced
= ffeexpr_collapse_uminus (reduced
, operator->token
);
8836 case FFEEXPR_operatorNOT_
:
8837 reduced
= ffebld_new_not (expr
);
8838 if (ffe_is_ugly_logint ())
8839 reduced
= ffeexpr_reduced_ugly1log_ (reduced
, operator, operand
);
8840 reduced
= ffeexpr_reduced_bool1_ (reduced
, operator, operand
);
8841 reduced
= ffeexpr_collapse_not (reduced
, operator->token
);
8845 assert ("unexpected unary op" != NULL
);
8850 && (ffebld_op (expr
) == FFEBLD_opCONTER
)
8851 && (ffebld_conter_orig (expr
) == NULL
)
8852 && ffebld_constant_is_magical (constnode
= ffebld_conter (expr
)))
8854 ffetarget_integer_bad_magical (operand
->token
);
8856 ffeexpr_stack_
->exprstack
= operator->previous
; /* Pops unary-op operand
8858 ffeexpr_expr_kill_ (operand
);
8859 operator->type
= FFEEXPR_exprtypeOPERAND_
; /* Convert operator, but
8861 operator->u
.operand
= reduced
; /* the line/column ffewhere info. */
8862 ffeexpr_exprstack_push_operand_ (operator); /* Push it back on
8867 assert (operator->type
== FFEEXPR_exprtypeBINARY_
);
8868 left_operand
= operator->previous
;
8869 assert (left_operand
!= NULL
);
8870 assert (left_operand
->type
== FFEEXPR_exprtypeOPERAND_
);
8871 expr
= operand
->u
.operand
;
8872 left_expr
= left_operand
->u
.operand
;
8873 switch (operator->u
.operator.op
)
8875 case FFEEXPR_operatorADD_
:
8876 reduced
= ffebld_new_add (left_expr
, expr
);
8877 if (ffe_is_ugly_logint ())
8878 reduced
= ffeexpr_reduced_ugly2_ (reduced
, left_operand
, operator,
8880 reduced
= ffeexpr_reduced_math2_ (reduced
, left_operand
, operator,
8882 reduced
= ffeexpr_collapse_add (reduced
, operator->token
);
8885 case FFEEXPR_operatorSUBTRACT_
:
8886 submag
= TRUE
; /* Just to pick the right error if magic
8888 reduced
= ffebld_new_subtract (left_expr
, expr
);
8889 if (ffe_is_ugly_logint ())
8890 reduced
= ffeexpr_reduced_ugly2_ (reduced
, left_operand
, operator,
8892 reduced
= ffeexpr_reduced_math2_ (reduced
, left_operand
, operator,
8894 reduced
= ffeexpr_collapse_subtract (reduced
, operator->token
);
8897 case FFEEXPR_operatorMULTIPLY_
:
8898 reduced
= ffebld_new_multiply (left_expr
, expr
);
8899 if (ffe_is_ugly_logint ())
8900 reduced
= ffeexpr_reduced_ugly2_ (reduced
, left_operand
, operator,
8902 reduced
= ffeexpr_reduced_math2_ (reduced
, left_operand
, operator,
8904 reduced
= ffeexpr_collapse_multiply (reduced
, operator->token
);
8907 case FFEEXPR_operatorDIVIDE_
:
8908 reduced
= ffebld_new_divide (left_expr
, expr
);
8909 if (ffe_is_ugly_logint ())
8910 reduced
= ffeexpr_reduced_ugly2_ (reduced
, left_operand
, operator,
8912 reduced
= ffeexpr_reduced_math2_ (reduced
, left_operand
, operator,
8914 reduced
= ffeexpr_collapse_divide (reduced
, operator->token
);
8917 case FFEEXPR_operatorPOWER_
:
8918 reduced
= ffebld_new_power (left_expr
, expr
);
8919 if (ffe_is_ugly_logint ())
8920 reduced
= ffeexpr_reduced_ugly2_ (reduced
, left_operand
, operator,
8922 reduced
= ffeexpr_reduced_power_ (reduced
, left_operand
, operator,
8924 reduced
= ffeexpr_collapse_power (reduced
, operator->token
);
8927 case FFEEXPR_operatorCONCATENATE_
:
8928 reduced
= ffebld_new_concatenate (left_expr
, expr
);
8929 reduced
= ffeexpr_reduced_concatenate_ (reduced
, left_operand
, operator,
8931 reduced
= ffeexpr_collapse_concatenate (reduced
, operator->token
);
8934 case FFEEXPR_operatorLT_
:
8935 reduced
= ffebld_new_lt (left_expr
, expr
);
8936 if (ffe_is_ugly_logint ())
8937 reduced
= ffeexpr_reduced_ugly2_ (reduced
, left_operand
, operator,
8939 reduced
= ffeexpr_reduced_relop2_ (reduced
, left_operand
, operator,
8941 reduced
= ffeexpr_collapse_lt (reduced
, operator->token
);
8944 case FFEEXPR_operatorLE_
:
8945 reduced
= ffebld_new_le (left_expr
, expr
);
8946 if (ffe_is_ugly_logint ())
8947 reduced
= ffeexpr_reduced_ugly2_ (reduced
, left_operand
, operator,
8949 reduced
= ffeexpr_reduced_relop2_ (reduced
, left_operand
, operator,
8951 reduced
= ffeexpr_collapse_le (reduced
, operator->token
);
8954 case FFEEXPR_operatorEQ_
:
8955 reduced
= ffebld_new_eq (left_expr
, expr
);
8956 if (ffe_is_ugly_logint ())
8957 reduced
= ffeexpr_reduced_ugly2_ (reduced
, left_operand
, operator,
8959 reduced
= ffeexpr_reduced_eqop2_ (reduced
, left_operand
, operator,
8961 reduced
= ffeexpr_collapse_eq (reduced
, operator->token
);
8964 case FFEEXPR_operatorNE_
:
8965 reduced
= ffebld_new_ne (left_expr
, expr
);
8966 if (ffe_is_ugly_logint ())
8967 reduced
= ffeexpr_reduced_ugly2_ (reduced
, left_operand
, operator,
8969 reduced
= ffeexpr_reduced_eqop2_ (reduced
, left_operand
, operator,
8971 reduced
= ffeexpr_collapse_ne (reduced
, operator->token
);
8974 case FFEEXPR_operatorGT_
:
8975 reduced
= ffebld_new_gt (left_expr
, expr
);
8976 if (ffe_is_ugly_logint ())
8977 reduced
= ffeexpr_reduced_ugly2_ (reduced
, left_operand
, operator,
8979 reduced
= ffeexpr_reduced_relop2_ (reduced
, left_operand
, operator,
8981 reduced
= ffeexpr_collapse_gt (reduced
, operator->token
);
8984 case FFEEXPR_operatorGE_
:
8985 reduced
= ffebld_new_ge (left_expr
, expr
);
8986 if (ffe_is_ugly_logint ())
8987 reduced
= ffeexpr_reduced_ugly2_ (reduced
, left_operand
, operator,
8989 reduced
= ffeexpr_reduced_relop2_ (reduced
, left_operand
, operator,
8991 reduced
= ffeexpr_collapse_ge (reduced
, operator->token
);
8994 case FFEEXPR_operatorAND_
:
8995 reduced
= ffebld_new_and (left_expr
, expr
);
8996 if (ffe_is_ugly_logint ())
8997 reduced
= ffeexpr_reduced_ugly2log_ (reduced
, left_operand
, operator,
8998 operand
, &bothlogical
);
8999 reduced
= ffeexpr_reduced_bool2_ (reduced
, left_operand
, operator,
9001 reduced
= ffeexpr_collapse_and (reduced
, operator->token
);
9002 if (ffe_is_ugly_logint() && bothlogical
)
9003 reduced
= ffeexpr_convert (reduced
, left_operand
->token
,
9005 FFEINFO_basictypeLOGICAL
,
9006 FFEINFO_kindtypeLOGICALDEFAULT
, 0,
9007 FFETARGET_charactersizeNONE
,
9008 FFEEXPR_contextLET
);
9011 case FFEEXPR_operatorOR_
:
9012 reduced
= ffebld_new_or (left_expr
, expr
);
9013 if (ffe_is_ugly_logint ())
9014 reduced
= ffeexpr_reduced_ugly2log_ (reduced
, left_operand
, operator,
9015 operand
, &bothlogical
);
9016 reduced
= ffeexpr_reduced_bool2_ (reduced
, left_operand
, operator,
9018 reduced
= ffeexpr_collapse_or (reduced
, operator->token
);
9019 if (ffe_is_ugly_logint() && bothlogical
)
9020 reduced
= ffeexpr_convert (reduced
, left_operand
->token
,
9022 FFEINFO_basictypeLOGICAL
,
9023 FFEINFO_kindtypeLOGICALDEFAULT
, 0,
9024 FFETARGET_charactersizeNONE
,
9025 FFEEXPR_contextLET
);
9028 case FFEEXPR_operatorXOR_
:
9029 reduced
= ffebld_new_xor (left_expr
, expr
);
9030 if (ffe_is_ugly_logint ())
9031 reduced
= ffeexpr_reduced_ugly2log_ (reduced
, left_operand
, operator,
9032 operand
, &bothlogical
);
9033 reduced
= ffeexpr_reduced_bool2_ (reduced
, left_operand
, operator,
9035 reduced
= ffeexpr_collapse_xor (reduced
, operator->token
);
9036 if (ffe_is_ugly_logint() && bothlogical
)
9037 reduced
= ffeexpr_convert (reduced
, left_operand
->token
,
9039 FFEINFO_basictypeLOGICAL
,
9040 FFEINFO_kindtypeLOGICALDEFAULT
, 0,
9041 FFETARGET_charactersizeNONE
,
9042 FFEEXPR_contextLET
);
9045 case FFEEXPR_operatorEQV_
:
9046 reduced
= ffebld_new_eqv (left_expr
, expr
);
9047 if (ffe_is_ugly_logint ())
9048 reduced
= ffeexpr_reduced_ugly2log_ (reduced
, left_operand
, operator,
9050 reduced
= ffeexpr_reduced_bool2_ (reduced
, left_operand
, operator,
9052 reduced
= ffeexpr_collapse_eqv (reduced
, operator->token
);
9055 case FFEEXPR_operatorNEQV_
:
9056 reduced
= ffebld_new_neqv (left_expr
, expr
);
9057 if (ffe_is_ugly_logint ())
9058 reduced
= ffeexpr_reduced_ugly2log_ (reduced
, left_operand
, operator,
9060 reduced
= ffeexpr_reduced_bool2_ (reduced
, left_operand
, operator,
9062 reduced
= ffeexpr_collapse_neqv (reduced
, operator->token
);
9066 assert ("bad bin op" == NULL
);
9070 if ((ffebld_op (left_expr
) == FFEBLD_opCONTER
)
9071 && (ffebld_conter_orig (expr
) == NULL
)
9072 && ffebld_constant_is_magical (constnode
= ffebld_conter (left_expr
)))
9074 if ((left_operand
->previous
!= NULL
)
9075 && (left_operand
->previous
->type
!= FFEEXPR_exprtypeOPERAND_
)
9076 && (left_operand
->previous
->u
.operator.op
9077 == FFEEXPR_operatorSUBTRACT_
))
9079 if (left_operand
->previous
->type
== FFEEXPR_exprtypeUNARY_
)
9080 ffetarget_integer_bad_magical_precedence (left_operand
->token
,
9081 left_operand
->previous
->token
,
9084 ffetarget_integer_bad_magical_precedence_binary
9085 (left_operand
->token
,
9086 left_operand
->previous
->token
,
9090 ffetarget_integer_bad_magical (left_operand
->token
);
9092 if ((ffebld_op (expr
) == FFEBLD_opCONTER
)
9093 && (ffebld_conter_orig (expr
) == NULL
)
9094 && ffebld_constant_is_magical (constnode
= ffebld_conter (expr
)))
9097 ffetarget_integer_bad_magical_binary (operand
->token
,
9100 ffetarget_integer_bad_magical (operand
->token
);
9102 ffeexpr_stack_
->exprstack
= left_operand
->previous
; /* Pops binary-op
9103 operands off stack. */
9104 ffeexpr_expr_kill_ (left_operand
);
9105 ffeexpr_expr_kill_ (operand
);
9106 operator->type
= FFEEXPR_exprtypeOPERAND_
; /* Convert operator, but
9108 operator->u
.operand
= reduced
; /* the line/column ffewhere info. */
9109 ffeexpr_exprstack_push_operand_ (operator); /* Push it back on
9114 /* ffeexpr_reduced_bool1_ -- Wrap up reduction of NOT operator
9116 reduced = ffeexpr_reduced_bool1_(reduced,op,r);
9118 Makes sure the argument for reduced has basictype of
9119 LOGICAL or (ugly) INTEGER. If
9120 argument has where of CONSTANT, assign where CONSTANT to
9121 reduced, else assign where FLEETING.
9123 If these requirements cannot be met, generate error message. */
9126 ffeexpr_reduced_bool1_ (ffebld reduced
, ffeexprExpr_ op
, ffeexprExpr_ r
)
9128 ffeinfo rinfo
, ninfo
;
9129 ffeinfoBasictype rbt
;
9130 ffeinfoKindtype rkt
;
9133 ffeinfoWhere rwh
, nwh
;
9135 rinfo
= ffebld_info (ffebld_left (reduced
));
9136 rbt
= ffeinfo_basictype (rinfo
);
9137 rkt
= ffeinfo_kindtype (rinfo
);
9138 rrk
= ffeinfo_rank (rinfo
);
9139 rkd
= ffeinfo_kind (rinfo
);
9140 rwh
= ffeinfo_where (rinfo
);
9142 if (((rbt
== FFEINFO_basictypeLOGICAL
)
9143 || (ffe_is_ugly_logint () && (rbt
== FFEINFO_basictypeINTEGER
)))
9148 case FFEINFO_whereCONSTANT
:
9149 nwh
= FFEINFO_whereCONSTANT
;
9152 case FFEINFO_whereIMMEDIATE
:
9153 nwh
= FFEINFO_whereIMMEDIATE
;
9157 nwh
= FFEINFO_whereFLEETING
;
9161 ninfo
= ffeinfo_new (rbt
, rkt
, 0, FFEINFO_kindENTITY
, nwh
,
9162 FFETARGET_charactersizeNONE
);
9163 ffebld_set_info (reduced
, ninfo
);
9167 if ((rbt
!= FFEINFO_basictypeLOGICAL
)
9168 && (!ffe_is_ugly_logint () || (rbt
!= FFEINFO_basictypeINTEGER
)))
9170 if ((rbt
!= FFEINFO_basictypeANY
)
9171 && ffebad_start (FFEBAD_NOT_ARG_TYPE
))
9173 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
9174 ffebad_here (1, ffelex_token_where_line (r
->token
), ffelex_token_where_column (r
->token
));
9180 if ((rkd
!= FFEINFO_kindANY
)
9181 && ffebad_start (FFEBAD_NOT_ARG_KIND
))
9183 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
9184 ffebad_here (1, ffelex_token_where_line (r
->token
), ffelex_token_where_column (r
->token
));
9185 ffebad_string ("an array");
9190 reduced
= ffebld_new_any ();
9191 ffebld_set_info (reduced
, ffeinfo_new_any ());
9195 /* ffeexpr_reduced_bool2_ -- Wrap up reduction of boolean operators
9197 reduced = ffeexpr_reduced_bool2_(reduced,l,op,r);
9199 Makes sure the left and right arguments for reduced have basictype of
9200 LOGICAL or (ugly) INTEGER. Determine common basictype and
9201 size for reduction (flag expression for combined hollerith/typeless
9202 situations for later determination of effective basictype). If both left
9203 and right arguments have where of CONSTANT, assign where CONSTANT to
9204 reduced, else assign where FLEETING. Create CONVERT ops for args where
9205 needed. Convert typeless
9206 constants to the desired type/size explicitly.
9208 If these requirements cannot be met, generate error message. */
9211 ffeexpr_reduced_bool2_ (ffebld reduced
, ffeexprExpr_ l
, ffeexprExpr_ op
,
9214 ffeinfo linfo
, rinfo
, ninfo
;
9215 ffeinfoBasictype lbt
, rbt
, nbt
;
9216 ffeinfoKindtype lkt
, rkt
, nkt
;
9217 ffeinfoRank lrk
, rrk
;
9218 ffeinfoKind lkd
, rkd
;
9219 ffeinfoWhere lwh
, rwh
, nwh
;
9221 linfo
= ffebld_info (ffebld_left (reduced
));
9222 lbt
= ffeinfo_basictype (linfo
);
9223 lkt
= ffeinfo_kindtype (linfo
);
9224 lrk
= ffeinfo_rank (linfo
);
9225 lkd
= ffeinfo_kind (linfo
);
9226 lwh
= ffeinfo_where (linfo
);
9228 rinfo
= ffebld_info (ffebld_right (reduced
));
9229 rbt
= ffeinfo_basictype (rinfo
);
9230 rkt
= ffeinfo_kindtype (rinfo
);
9231 rrk
= ffeinfo_rank (rinfo
);
9232 rkd
= ffeinfo_kind (rinfo
);
9233 rwh
= ffeinfo_where (rinfo
);
9235 ffeexpr_type_combine (&nbt
, &nkt
, lbt
, lkt
, rbt
, rkt
, op
->token
);
9237 if (((nbt
== FFEINFO_basictypeLOGICAL
)
9238 || (ffe_is_ugly_logint () && (nbt
== FFEINFO_basictypeINTEGER
)))
9239 && (lrk
== 0) && (rrk
== 0))
9243 case FFEINFO_whereCONSTANT
:
9246 case FFEINFO_whereCONSTANT
:
9247 nwh
= FFEINFO_whereCONSTANT
;
9250 case FFEINFO_whereIMMEDIATE
:
9251 nwh
= FFEINFO_whereIMMEDIATE
;
9255 nwh
= FFEINFO_whereFLEETING
;
9260 case FFEINFO_whereIMMEDIATE
:
9263 case FFEINFO_whereCONSTANT
:
9264 case FFEINFO_whereIMMEDIATE
:
9265 nwh
= FFEINFO_whereIMMEDIATE
;
9269 nwh
= FFEINFO_whereFLEETING
;
9275 nwh
= FFEINFO_whereFLEETING
;
9279 ninfo
= ffeinfo_new (nbt
, nkt
, 0, FFEINFO_kindENTITY
, nwh
,
9280 FFETARGET_charactersizeNONE
);
9281 ffebld_set_info (reduced
, ninfo
);
9282 ffebld_set_left (reduced
, ffeexpr_convert (ffebld_left (reduced
),
9283 l
->token
, op
->token
, nbt
, nkt
, 0, FFETARGET_charactersizeNONE
,
9284 FFEEXPR_contextLET
));
9285 ffebld_set_right (reduced
, ffeexpr_convert (ffebld_right (reduced
),
9286 r
->token
, op
->token
, nbt
, nkt
, 0, FFETARGET_charactersizeNONE
,
9287 FFEEXPR_contextLET
));
9291 if ((lbt
!= FFEINFO_basictypeLOGICAL
)
9292 && (!ffe_is_ugly_logint () || (lbt
!= FFEINFO_basictypeINTEGER
)))
9294 if ((rbt
!= FFEINFO_basictypeLOGICAL
)
9295 && (!ffe_is_ugly_logint () || (rbt
!= FFEINFO_basictypeINTEGER
)))
9297 if ((lbt
!= FFEINFO_basictypeANY
) && (rbt
!= FFEINFO_basictypeANY
)
9298 && ffebad_start (FFEBAD_BOOL_ARGS_TYPE
))
9300 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
9301 ffebad_here (1, ffelex_token_where_line (l
->token
), ffelex_token_where_column (l
->token
));
9302 ffebad_here (2, ffelex_token_where_line (r
->token
), ffelex_token_where_column (r
->token
));
9308 if ((lbt
!= FFEINFO_basictypeANY
)
9309 && ffebad_start (FFEBAD_BOOL_ARG_TYPE
))
9311 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
9312 ffebad_here (1, ffelex_token_where_line (l
->token
), ffelex_token_where_column (l
->token
));
9317 else if ((rbt
!= FFEINFO_basictypeLOGICAL
)
9318 && (!ffe_is_ugly_logint () || (rbt
!= FFEINFO_basictypeINTEGER
)))
9320 if ((rbt
!= FFEINFO_basictypeANY
)
9321 && ffebad_start (FFEBAD_BOOL_ARG_TYPE
))
9323 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
9324 ffebad_here (1, ffelex_token_where_line (r
->token
), ffelex_token_where_column (r
->token
));
9330 if ((lkd
!= FFEINFO_kindANY
)
9331 && ffebad_start (FFEBAD_BOOL_ARG_KIND
))
9333 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
9334 ffebad_here (1, ffelex_token_where_line (l
->token
), ffelex_token_where_column (l
->token
));
9335 ffebad_string ("an array");
9341 if ((rkd
!= FFEINFO_kindANY
)
9342 && ffebad_start (FFEBAD_BOOL_ARG_KIND
))
9344 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
9345 ffebad_here (1, ffelex_token_where_line (r
->token
), ffelex_token_where_column (r
->token
));
9346 ffebad_string ("an array");
9351 reduced
= ffebld_new_any ();
9352 ffebld_set_info (reduced
, ffeinfo_new_any ());
9356 /* ffeexpr_reduced_concatenate_ -- Wrap up reduction of concatenate operator
9358 reduced = ffeexpr_reduced_concatenate_(reduced,l,op,r);
9360 Makes sure the left and right arguments for reduced have basictype of
9361 CHARACTER and kind of SCALAR, FUNCTION, or STATEMENT FUNCTION. Assign
9362 basictype of CHARACTER and kind of SCALAR to reduced. Calculate effective
9363 size of concatenation and assign that size to reduced. If both left and
9364 right arguments have where of CONSTANT, assign where CONSTANT to reduced,
9365 else assign where FLEETING.
9367 If these requirements cannot be met, generate error message using the
9368 info in l, op, and r arguments and assign basictype, size, kind, and where
9372 ffeexpr_reduced_concatenate_ (ffebld reduced
, ffeexprExpr_ l
, ffeexprExpr_ op
,
9375 ffeinfo linfo
, rinfo
, ninfo
;
9376 ffeinfoBasictype lbt
, rbt
, nbt
;
9377 ffeinfoKindtype lkt
, rkt
, nkt
;
9378 ffeinfoRank lrk
, rrk
;
9379 ffeinfoKind lkd
, rkd
, nkd
;
9380 ffeinfoWhere lwh
, rwh
, nwh
;
9381 ffetargetCharacterSize lszm
, lszk
, rszm
, rszk
, nszk
;
9383 linfo
= ffebld_info (ffebld_left (reduced
));
9384 lbt
= ffeinfo_basictype (linfo
);
9385 lkt
= ffeinfo_kindtype (linfo
);
9386 lrk
= ffeinfo_rank (linfo
);
9387 lkd
= ffeinfo_kind (linfo
);
9388 lwh
= ffeinfo_where (linfo
);
9389 lszk
= ffeinfo_size (linfo
); /* Known size. */
9390 lszm
= ffebld_size_max (ffebld_left (reduced
));
9392 rinfo
= ffebld_info (ffebld_right (reduced
));
9393 rbt
= ffeinfo_basictype (rinfo
);
9394 rkt
= ffeinfo_kindtype (rinfo
);
9395 rrk
= ffeinfo_rank (rinfo
);
9396 rkd
= ffeinfo_kind (rinfo
);
9397 rwh
= ffeinfo_where (rinfo
);
9398 rszk
= ffeinfo_size (rinfo
); /* Known size. */
9399 rszm
= ffebld_size_max (ffebld_right (reduced
));
9401 if ((lbt
== FFEINFO_basictypeCHARACTER
) && (rbt
== FFEINFO_basictypeCHARACTER
)
9402 && (lkt
== rkt
) && (lrk
== 0) && (rrk
== 0)
9403 && (((lszm
!= FFETARGET_charactersizeNONE
)
9404 && (rszm
!= FFETARGET_charactersizeNONE
))
9405 || (ffeexpr_context_outer_ (ffeexpr_stack_
)
9406 == FFEEXPR_contextLET
)
9407 || (ffeexpr_context_outer_ (ffeexpr_stack_
)
9408 == FFEEXPR_contextSFUNCDEF
)))
9410 nbt
= FFEINFO_basictypeCHARACTER
;
9411 nkd
= FFEINFO_kindENTITY
;
9412 if ((lszk
== FFETARGET_charactersizeNONE
)
9413 || (rszk
== FFETARGET_charactersizeNONE
))
9414 nszk
= FFETARGET_charactersizeNONE
; /* Ok only in rhs of LET
9421 case FFEINFO_whereCONSTANT
:
9424 case FFEINFO_whereCONSTANT
:
9425 nwh
= FFEINFO_whereCONSTANT
;
9428 case FFEINFO_whereIMMEDIATE
:
9429 nwh
= FFEINFO_whereIMMEDIATE
;
9433 nwh
= FFEINFO_whereFLEETING
;
9438 case FFEINFO_whereIMMEDIATE
:
9441 case FFEINFO_whereCONSTANT
:
9442 case FFEINFO_whereIMMEDIATE
:
9443 nwh
= FFEINFO_whereIMMEDIATE
;
9447 nwh
= FFEINFO_whereFLEETING
;
9453 nwh
= FFEINFO_whereFLEETING
;
9458 ninfo
= ffeinfo_new (nbt
, nkt
, 0, nkd
, nwh
, nszk
);
9459 ffebld_set_info (reduced
, ninfo
);
9463 if ((lbt
!= FFEINFO_basictypeCHARACTER
) && (rbt
!= FFEINFO_basictypeCHARACTER
))
9465 if ((lbt
!= FFEINFO_basictypeANY
) && (rbt
!= FFEINFO_basictypeANY
)
9466 && ffebad_start (FFEBAD_CONCAT_ARGS_TYPE
))
9468 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
9469 ffebad_here (1, ffelex_token_where_line (l
->token
), ffelex_token_where_column (l
->token
));
9470 ffebad_here (2, ffelex_token_where_line (r
->token
), ffelex_token_where_column (r
->token
));
9474 else if (lbt
!= FFEINFO_basictypeCHARACTER
)
9476 if ((lbt
!= FFEINFO_basictypeANY
)
9477 && ffebad_start (FFEBAD_CONCAT_ARG_TYPE
))
9479 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
9480 ffebad_here (1, ffelex_token_where_line (l
->token
), ffelex_token_where_column (l
->token
));
9484 else if (rbt
!= FFEINFO_basictypeCHARACTER
)
9486 if ((rbt
!= FFEINFO_basictypeANY
)
9487 && ffebad_start (FFEBAD_CONCAT_ARG_TYPE
))
9489 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
9490 ffebad_here (1, ffelex_token_where_line (r
->token
), ffelex_token_where_column (r
->token
));
9494 else if ((lrk
!= 0) || (lszm
== FFETARGET_charactersizeNONE
))
9496 if ((lkd
!= FFEINFO_kindANY
)
9497 && ffebad_start (FFEBAD_CONCAT_ARG_KIND
))
9504 what
= "of indeterminate length";
9505 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
9506 ffebad_here (1, ffelex_token_where_line (l
->token
), ffelex_token_where_column (l
->token
));
9507 ffebad_string (what
);
9513 if (ffebad_start (FFEBAD_CONCAT_ARG_KIND
))
9520 what
= "of indeterminate length";
9521 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
9522 ffebad_here (1, ffelex_token_where_line (r
->token
), ffelex_token_where_column (r
->token
));
9523 ffebad_string (what
);
9528 reduced
= ffebld_new_any ();
9529 ffebld_set_info (reduced
, ffeinfo_new_any ());
9533 /* ffeexpr_reduced_eqop2_ -- Wrap up reduction of EQ and NE operators
9535 reduced = ffeexpr_reduced_eqop2_(reduced,l,op,r);
9537 Makes sure the left and right arguments for reduced have basictype of
9538 INTEGER, REAL, COMPLEX, or CHARACTER. Determine common basictype and
9539 size for reduction. If both left
9540 and right arguments have where of CONSTANT, assign where CONSTANT to
9541 reduced, else assign where FLEETING. Create CONVERT ops for args where
9542 needed. Convert typeless
9543 constants to the desired type/size explicitly.
9545 If these requirements cannot be met, generate error message. */
9548 ffeexpr_reduced_eqop2_ (ffebld reduced
, ffeexprExpr_ l
, ffeexprExpr_ op
,
9551 ffeinfo linfo
, rinfo
, ninfo
;
9552 ffeinfoBasictype lbt
, rbt
, nbt
;
9553 ffeinfoKindtype lkt
, rkt
, nkt
;
9554 ffeinfoRank lrk
, rrk
;
9555 ffeinfoKind lkd
, rkd
;
9556 ffeinfoWhere lwh
, rwh
, nwh
;
9557 ffetargetCharacterSize lsz
, rsz
;
9559 linfo
= ffebld_info (ffebld_left (reduced
));
9560 lbt
= ffeinfo_basictype (linfo
);
9561 lkt
= ffeinfo_kindtype (linfo
);
9562 lrk
= ffeinfo_rank (linfo
);
9563 lkd
= ffeinfo_kind (linfo
);
9564 lwh
= ffeinfo_where (linfo
);
9565 lsz
= ffebld_size_known (ffebld_left (reduced
));
9567 rinfo
= ffebld_info (ffebld_right (reduced
));
9568 rbt
= ffeinfo_basictype (rinfo
);
9569 rkt
= ffeinfo_kindtype (rinfo
);
9570 rrk
= ffeinfo_rank (rinfo
);
9571 rkd
= ffeinfo_kind (rinfo
);
9572 rwh
= ffeinfo_where (rinfo
);
9573 rsz
= ffebld_size_known (ffebld_right (reduced
));
9575 ffeexpr_type_combine (&nbt
, &nkt
, lbt
, lkt
, rbt
, rkt
, op
->token
);
9577 if (((nbt
== FFEINFO_basictypeINTEGER
) || (nbt
== FFEINFO_basictypeREAL
)
9578 || (nbt
== FFEINFO_basictypeCOMPLEX
) || (nbt
== FFEINFO_basictypeCHARACTER
))
9579 && (lrk
== 0) && (rrk
== 0))
9583 case FFEINFO_whereCONSTANT
:
9586 case FFEINFO_whereCONSTANT
:
9587 nwh
= FFEINFO_whereCONSTANT
;
9590 case FFEINFO_whereIMMEDIATE
:
9591 nwh
= FFEINFO_whereIMMEDIATE
;
9595 nwh
= FFEINFO_whereFLEETING
;
9600 case FFEINFO_whereIMMEDIATE
:
9603 case FFEINFO_whereCONSTANT
:
9604 case FFEINFO_whereIMMEDIATE
:
9605 nwh
= FFEINFO_whereIMMEDIATE
;
9609 nwh
= FFEINFO_whereFLEETING
;
9615 nwh
= FFEINFO_whereFLEETING
;
9619 if ((lsz
!= FFETARGET_charactersizeNONE
)
9620 && (rsz
!= FFETARGET_charactersizeNONE
))
9621 lsz
= rsz
= (lsz
> rsz
) ? lsz
: rsz
;
9623 ninfo
= ffeinfo_new (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICALDEFAULT
,
9624 0, FFEINFO_kindENTITY
, nwh
, FFETARGET_charactersizeNONE
);
9625 ffebld_set_info (reduced
, ninfo
);
9626 ffebld_set_left (reduced
, ffeexpr_convert (ffebld_left (reduced
),
9627 l
->token
, op
->token
, nbt
, nkt
, 0, lsz
,
9628 FFEEXPR_contextLET
));
9629 ffebld_set_right (reduced
, ffeexpr_convert (ffebld_right (reduced
),
9630 r
->token
, op
->token
, nbt
, nkt
, 0, rsz
,
9631 FFEEXPR_contextLET
));
9635 if ((lbt
== FFEINFO_basictypeLOGICAL
)
9636 && (rbt
== FFEINFO_basictypeLOGICAL
))
9638 /* xgettext:no-c-format */
9639 if (ffebad_start_msg ("Use .EQV./.NEQV. instead of .EQ./.NE. at %0 for LOGICAL operands at %1 and %2",
9640 FFEBAD_severityFATAL
))
9642 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
9643 ffebad_here (1, ffelex_token_where_line (l
->token
), ffelex_token_where_column (l
->token
));
9644 ffebad_here (2, ffelex_token_where_line (r
->token
), ffelex_token_where_column (r
->token
));
9648 else if ((lbt
!= FFEINFO_basictypeINTEGER
) && (lbt
!= FFEINFO_basictypeREAL
)
9649 && (lbt
!= FFEINFO_basictypeCOMPLEX
) && (lbt
!= FFEINFO_basictypeCHARACTER
))
9651 if ((rbt
!= FFEINFO_basictypeINTEGER
) && (rbt
!= FFEINFO_basictypeREAL
)
9652 && (rbt
!= FFEINFO_basictypeCOMPLEX
) && (rbt
!= FFEINFO_basictypeCHARACTER
))
9654 if ((lbt
!= FFEINFO_basictypeANY
) && (rbt
!= FFEINFO_basictypeANY
)
9655 && ffebad_start (FFEBAD_EQOP_ARGS_TYPE
))
9657 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
9658 ffebad_here (1, ffelex_token_where_line (l
->token
), ffelex_token_where_column (l
->token
));
9659 ffebad_here (2, ffelex_token_where_line (r
->token
), ffelex_token_where_column (r
->token
));
9665 if ((lbt
!= FFEINFO_basictypeANY
)
9666 && ffebad_start (FFEBAD_EQOP_ARG_TYPE
))
9668 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
9669 ffebad_here (1, ffelex_token_where_line (l
->token
), ffelex_token_where_column (l
->token
));
9674 else if ((rbt
!= FFEINFO_basictypeINTEGER
) && (rbt
!= FFEINFO_basictypeREAL
)
9675 && (rbt
!= FFEINFO_basictypeCOMPLEX
) && (rbt
!= FFEINFO_basictypeCHARACTER
))
9677 if ((rbt
!= FFEINFO_basictypeANY
)
9678 && ffebad_start (FFEBAD_EQOP_ARG_TYPE
))
9680 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
9681 ffebad_here (1, ffelex_token_where_line (r
->token
), ffelex_token_where_column (r
->token
));
9687 if ((lkd
!= FFEINFO_kindANY
)
9688 && ffebad_start (FFEBAD_EQOP_ARG_KIND
))
9690 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
9691 ffebad_here (1, ffelex_token_where_line (l
->token
), ffelex_token_where_column (l
->token
));
9692 ffebad_string ("an array");
9698 if ((rkd
!= FFEINFO_kindANY
)
9699 && ffebad_start (FFEBAD_EQOP_ARG_KIND
))
9701 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
9702 ffebad_here (1, ffelex_token_where_line (r
->token
), ffelex_token_where_column (r
->token
));
9703 ffebad_string ("an array");
9708 reduced
= ffebld_new_any ();
9709 ffebld_set_info (reduced
, ffeinfo_new_any ());
9713 /* ffeexpr_reduced_math1_ -- Wrap up reduction of + - unary operators
9715 reduced = ffeexpr_reduced_math1_(reduced,op,r);
9717 Makes sure the argument for reduced has basictype of
9718 INTEGER, REAL, or COMPLEX. If the argument has where of CONSTANT,
9719 assign where CONSTANT to
9720 reduced, else assign where FLEETING.
9722 If these requirements cannot be met, generate error message. */
9725 ffeexpr_reduced_math1_ (ffebld reduced
, ffeexprExpr_ op
, ffeexprExpr_ r
)
9727 ffeinfo rinfo
, ninfo
;
9728 ffeinfoBasictype rbt
;
9729 ffeinfoKindtype rkt
;
9732 ffeinfoWhere rwh
, nwh
;
9734 rinfo
= ffebld_info (ffebld_left (reduced
));
9735 rbt
= ffeinfo_basictype (rinfo
);
9736 rkt
= ffeinfo_kindtype (rinfo
);
9737 rrk
= ffeinfo_rank (rinfo
);
9738 rkd
= ffeinfo_kind (rinfo
);
9739 rwh
= ffeinfo_where (rinfo
);
9741 if (((rbt
== FFEINFO_basictypeINTEGER
) || (rbt
== FFEINFO_basictypeREAL
)
9742 || (rbt
== FFEINFO_basictypeCOMPLEX
)) && (rrk
== 0))
9746 case FFEINFO_whereCONSTANT
:
9747 nwh
= FFEINFO_whereCONSTANT
;
9750 case FFEINFO_whereIMMEDIATE
:
9751 nwh
= FFEINFO_whereIMMEDIATE
;
9755 nwh
= FFEINFO_whereFLEETING
;
9759 ninfo
= ffeinfo_new (rbt
, rkt
, 0, FFEINFO_kindENTITY
, nwh
,
9760 FFETARGET_charactersizeNONE
);
9761 ffebld_set_info (reduced
, ninfo
);
9765 if ((rbt
!= FFEINFO_basictypeINTEGER
) && (rbt
!= FFEINFO_basictypeREAL
)
9766 && (rbt
!= FFEINFO_basictypeCOMPLEX
))
9768 if ((rbt
!= FFEINFO_basictypeANY
)
9769 && ffebad_start (FFEBAD_MATH_ARG_TYPE
))
9771 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
9772 ffebad_here (1, ffelex_token_where_line (r
->token
), ffelex_token_where_column (r
->token
));
9778 if ((rkd
!= FFEINFO_kindANY
)
9779 && ffebad_start (FFEBAD_MATH_ARG_KIND
))
9781 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
9782 ffebad_here (1, ffelex_token_where_line (r
->token
), ffelex_token_where_column (r
->token
));
9783 ffebad_string ("an array");
9788 reduced
= ffebld_new_any ();
9789 ffebld_set_info (reduced
, ffeinfo_new_any ());
9793 /* ffeexpr_reduced_math2_ -- Wrap up reduction of + - * / operators
9795 reduced = ffeexpr_reduced_math2_(reduced,l,op,r);
9797 Makes sure the left and right arguments for reduced have basictype of
9798 INTEGER, REAL, or COMPLEX. Determine common basictype and
9799 size for reduction (flag expression for combined hollerith/typeless
9800 situations for later determination of effective basictype). If both left
9801 and right arguments have where of CONSTANT, assign where CONSTANT to
9802 reduced, else assign where FLEETING. Create CONVERT ops for args where
9803 needed. Convert typeless
9804 constants to the desired type/size explicitly.
9806 If these requirements cannot be met, generate error message. */
9809 ffeexpr_reduced_math2_ (ffebld reduced
, ffeexprExpr_ l
, ffeexprExpr_ op
,
9812 ffeinfo linfo
, rinfo
, ninfo
;
9813 ffeinfoBasictype lbt
, rbt
, nbt
;
9814 ffeinfoKindtype lkt
, rkt
, nkt
;
9815 ffeinfoRank lrk
, rrk
;
9816 ffeinfoKind lkd
, rkd
;
9817 ffeinfoWhere lwh
, rwh
, nwh
;
9819 linfo
= ffebld_info (ffebld_left (reduced
));
9820 lbt
= ffeinfo_basictype (linfo
);
9821 lkt
= ffeinfo_kindtype (linfo
);
9822 lrk
= ffeinfo_rank (linfo
);
9823 lkd
= ffeinfo_kind (linfo
);
9824 lwh
= ffeinfo_where (linfo
);
9826 rinfo
= ffebld_info (ffebld_right (reduced
));
9827 rbt
= ffeinfo_basictype (rinfo
);
9828 rkt
= ffeinfo_kindtype (rinfo
);
9829 rrk
= ffeinfo_rank (rinfo
);
9830 rkd
= ffeinfo_kind (rinfo
);
9831 rwh
= ffeinfo_where (rinfo
);
9833 ffeexpr_type_combine (&nbt
, &nkt
, lbt
, lkt
, rbt
, rkt
, op
->token
);
9835 if (((nbt
== FFEINFO_basictypeINTEGER
) || (nbt
== FFEINFO_basictypeREAL
)
9836 || (nbt
== FFEINFO_basictypeCOMPLEX
)) && (lrk
== 0) && (rrk
== 0))
9840 case FFEINFO_whereCONSTANT
:
9843 case FFEINFO_whereCONSTANT
:
9844 nwh
= FFEINFO_whereCONSTANT
;
9847 case FFEINFO_whereIMMEDIATE
:
9848 nwh
= FFEINFO_whereIMMEDIATE
;
9852 nwh
= FFEINFO_whereFLEETING
;
9857 case FFEINFO_whereIMMEDIATE
:
9860 case FFEINFO_whereCONSTANT
:
9861 case FFEINFO_whereIMMEDIATE
:
9862 nwh
= FFEINFO_whereIMMEDIATE
;
9866 nwh
= FFEINFO_whereFLEETING
;
9872 nwh
= FFEINFO_whereFLEETING
;
9876 ninfo
= ffeinfo_new (nbt
, nkt
, 0, FFEINFO_kindENTITY
, nwh
,
9877 FFETARGET_charactersizeNONE
);
9878 ffebld_set_info (reduced
, ninfo
);
9879 ffebld_set_left (reduced
, ffeexpr_convert (ffebld_left (reduced
),
9880 l
->token
, op
->token
, nbt
, nkt
, 0, FFETARGET_charactersizeNONE
,
9881 FFEEXPR_contextLET
));
9882 ffebld_set_right (reduced
, ffeexpr_convert (ffebld_right (reduced
),
9883 r
->token
, op
->token
, nbt
, nkt
, 0, FFETARGET_charactersizeNONE
,
9884 FFEEXPR_contextLET
));
9888 if ((lbt
!= FFEINFO_basictypeINTEGER
) && (lbt
!= FFEINFO_basictypeREAL
)
9889 && (lbt
!= FFEINFO_basictypeCOMPLEX
))
9891 if ((rbt
!= FFEINFO_basictypeINTEGER
)
9892 && (rbt
!= FFEINFO_basictypeREAL
) && (rbt
!= FFEINFO_basictypeCOMPLEX
))
9894 if ((lbt
!= FFEINFO_basictypeANY
) && (rbt
!= FFEINFO_basictypeANY
)
9895 && ffebad_start (FFEBAD_MATH_ARGS_TYPE
))
9897 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
9898 ffebad_here (1, ffelex_token_where_line (l
->token
), ffelex_token_where_column (l
->token
));
9899 ffebad_here (2, ffelex_token_where_line (r
->token
), ffelex_token_where_column (r
->token
));
9905 if ((lbt
!= FFEINFO_basictypeANY
)
9906 && ffebad_start (FFEBAD_MATH_ARG_TYPE
))
9908 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
9909 ffebad_here (1, ffelex_token_where_line (l
->token
), ffelex_token_where_column (l
->token
));
9914 else if ((rbt
!= FFEINFO_basictypeINTEGER
) && (rbt
!= FFEINFO_basictypeREAL
)
9915 && (rbt
!= FFEINFO_basictypeCOMPLEX
))
9917 if ((rbt
!= FFEINFO_basictypeANY
)
9918 && ffebad_start (FFEBAD_MATH_ARG_TYPE
))
9920 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
9921 ffebad_here (1, ffelex_token_where_line (r
->token
), ffelex_token_where_column (r
->token
));
9927 if ((lkd
!= FFEINFO_kindANY
)
9928 && ffebad_start (FFEBAD_MATH_ARG_KIND
))
9930 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
9931 ffebad_here (1, ffelex_token_where_line (l
->token
), ffelex_token_where_column (l
->token
));
9932 ffebad_string ("an array");
9938 if ((rkd
!= FFEINFO_kindANY
)
9939 && ffebad_start (FFEBAD_MATH_ARG_KIND
))
9941 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
9942 ffebad_here (1, ffelex_token_where_line (r
->token
), ffelex_token_where_column (r
->token
));
9943 ffebad_string ("an array");
9948 reduced
= ffebld_new_any ();
9949 ffebld_set_info (reduced
, ffeinfo_new_any ());
9953 /* ffeexpr_reduced_power_ -- Wrap up reduction of ** operator
9955 reduced = ffeexpr_reduced_power_(reduced,l,op,r);
9957 Makes sure the left and right arguments for reduced have basictype of
9958 INTEGER, REAL, or COMPLEX. Determine common basictype and
9959 size for reduction (flag expression for combined hollerith/typeless
9960 situations for later determination of effective basictype). If both left
9961 and right arguments have where of CONSTANT, assign where CONSTANT to
9962 reduced, else assign where FLEETING. Create CONVERT ops for args where
9963 needed. Note that real**int or complex**int
9964 comes out as int = real**int etc with no conversions.
9966 If these requirements cannot be met, generate error message using the
9967 info in l, op, and r arguments and assign basictype, size, kind, and where
9971 ffeexpr_reduced_power_ (ffebld reduced
, ffeexprExpr_ l
, ffeexprExpr_ op
,
9974 ffeinfo linfo
, rinfo
, ninfo
;
9975 ffeinfoBasictype lbt
, rbt
, nbt
;
9976 ffeinfoKindtype lkt
, rkt
, nkt
;
9977 ffeinfoRank lrk
, rrk
;
9978 ffeinfoKind lkd
, rkd
;
9979 ffeinfoWhere lwh
, rwh
, nwh
;
9981 linfo
= ffebld_info (ffebld_left (reduced
));
9982 lbt
= ffeinfo_basictype (linfo
);
9983 lkt
= ffeinfo_kindtype (linfo
);
9984 lrk
= ffeinfo_rank (linfo
);
9985 lkd
= ffeinfo_kind (linfo
);
9986 lwh
= ffeinfo_where (linfo
);
9988 rinfo
= ffebld_info (ffebld_right (reduced
));
9989 rbt
= ffeinfo_basictype (rinfo
);
9990 rkt
= ffeinfo_kindtype (rinfo
);
9991 rrk
= ffeinfo_rank (rinfo
);
9992 rkd
= ffeinfo_kind (rinfo
);
9993 rwh
= ffeinfo_where (rinfo
);
9995 if ((rbt
== FFEINFO_basictypeINTEGER
)
9996 && ((lbt
== FFEINFO_basictypeREAL
)
9997 || (lbt
== FFEINFO_basictypeCOMPLEX
)))
10000 nkt
= ffeinfo_kindtype_max (nbt
, lkt
, FFEINFO_kindtypeREALDEFAULT
);
10001 if (nkt
!= FFEINFO_kindtypeREALDEFAULT
)
10003 nkt
= ffeinfo_kindtype_max (nbt
, lkt
, FFEINFO_kindtypeREALDOUBLE
);
10004 if (nkt
!= FFEINFO_kindtypeREALDOUBLE
)
10005 nkt
= FFEINFO_kindtypeREALDOUBLE
; /* Highest kt we can power! */
10007 if (rkt
== FFEINFO_kindtypeINTEGER4
)
10009 /* xgettext:no-c-format */
10010 ffebad_start_msg ("Unsupported operand for ** at %1 -- converting to default INTEGER",
10011 FFEBAD_severityWARNING
);
10012 ffebad_here (0, ffelex_token_where_line (r
->token
), ffelex_token_where_column (r
->token
));
10015 if (rkt
!= FFEINFO_kindtypeINTEGERDEFAULT
)
10017 ffebld_set_right (reduced
, ffeexpr_convert (ffebld_right (reduced
),
10018 r
->token
, op
->token
,
10019 FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGERDEFAULT
, 0,
10020 FFETARGET_charactersizeNONE
,
10021 FFEEXPR_contextLET
));
10022 rkt
= FFEINFO_kindtypeINTEGERDEFAULT
;
10027 ffeexpr_type_combine (&nbt
, &nkt
, lbt
, lkt
, rbt
, rkt
, op
->token
);
10029 #if 0 /* INTEGER4**INTEGER4 works now. */
10030 if ((nbt
== FFEINFO_basictypeINTEGER
)
10031 && (nkt
!= FFEINFO_kindtypeINTEGERDEFAULT
))
10032 nkt
= FFEINFO_kindtypeINTEGERDEFAULT
; /* Highest kt we can power! */
10034 if (((nbt
== FFEINFO_basictypeREAL
)
10035 || (nbt
== FFEINFO_basictypeCOMPLEX
))
10036 && (nkt
!= FFEINFO_kindtypeREALDEFAULT
))
10038 nkt
= ffeinfo_kindtype_max (nbt
, nkt
, FFEINFO_kindtypeREALDOUBLE
);
10039 if (nkt
!= FFEINFO_kindtypeREALDOUBLE
)
10040 nkt
= FFEINFO_kindtypeREALDOUBLE
; /* Highest kt we can power! */
10042 /* else Gonna turn into an error below. */
10045 if (((nbt
== FFEINFO_basictypeINTEGER
) || (nbt
== FFEINFO_basictypeREAL
)
10046 || (nbt
== FFEINFO_basictypeCOMPLEX
)) && (lrk
== 0) && (rrk
== 0))
10050 case FFEINFO_whereCONSTANT
:
10053 case FFEINFO_whereCONSTANT
:
10054 nwh
= FFEINFO_whereCONSTANT
;
10057 case FFEINFO_whereIMMEDIATE
:
10058 nwh
= FFEINFO_whereIMMEDIATE
;
10062 nwh
= FFEINFO_whereFLEETING
;
10067 case FFEINFO_whereIMMEDIATE
:
10070 case FFEINFO_whereCONSTANT
:
10071 case FFEINFO_whereIMMEDIATE
:
10072 nwh
= FFEINFO_whereIMMEDIATE
;
10076 nwh
= FFEINFO_whereFLEETING
;
10082 nwh
= FFEINFO_whereFLEETING
;
10086 ninfo
= ffeinfo_new (nbt
, nkt
, 0, FFEINFO_kindENTITY
, nwh
,
10087 FFETARGET_charactersizeNONE
);
10088 ffebld_set_info (reduced
, ninfo
);
10089 ffebld_set_left (reduced
, ffeexpr_convert (ffebld_left (reduced
),
10090 l
->token
, op
->token
, nbt
, nkt
, 0, FFETARGET_charactersizeNONE
,
10091 FFEEXPR_contextLET
));
10092 if (rbt
!= FFEINFO_basictypeINTEGER
)
10093 ffebld_set_right (reduced
, ffeexpr_convert (ffebld_right (reduced
),
10094 r
->token
, op
->token
, nbt
, nkt
, 0, FFETARGET_charactersizeNONE
,
10095 FFEEXPR_contextLET
));
10099 if ((lbt
!= FFEINFO_basictypeINTEGER
) && (lbt
!= FFEINFO_basictypeREAL
)
10100 && (lbt
!= FFEINFO_basictypeCOMPLEX
))
10102 if ((rbt
!= FFEINFO_basictypeINTEGER
)
10103 && (rbt
!= FFEINFO_basictypeREAL
) && (rbt
!= FFEINFO_basictypeCOMPLEX
))
10105 if ((lbt
!= FFEINFO_basictypeANY
) && (rbt
!= FFEINFO_basictypeANY
)
10106 && ffebad_start (FFEBAD_MATH_ARGS_TYPE
))
10108 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
10109 ffebad_here (1, ffelex_token_where_line (l
->token
), ffelex_token_where_column (l
->token
));
10110 ffebad_here (2, ffelex_token_where_line (r
->token
), ffelex_token_where_column (r
->token
));
10116 if ((lbt
!= FFEINFO_basictypeANY
)
10117 && ffebad_start (FFEBAD_MATH_ARG_TYPE
))
10119 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
10120 ffebad_here (1, ffelex_token_where_line (l
->token
), ffelex_token_where_column (l
->token
));
10125 else if ((rbt
!= FFEINFO_basictypeINTEGER
) && (rbt
!= FFEINFO_basictypeREAL
)
10126 && (rbt
!= FFEINFO_basictypeCOMPLEX
))
10128 if ((rbt
!= FFEINFO_basictypeANY
)
10129 && ffebad_start (FFEBAD_MATH_ARG_TYPE
))
10131 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
10132 ffebad_here (1, ffelex_token_where_line (r
->token
), ffelex_token_where_column (r
->token
));
10138 if ((lkd
!= FFEINFO_kindANY
)
10139 && ffebad_start (FFEBAD_MATH_ARG_KIND
))
10141 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
10142 ffebad_here (1, ffelex_token_where_line (l
->token
), ffelex_token_where_column (l
->token
));
10143 ffebad_string ("an array");
10149 if ((rkd
!= FFEINFO_kindANY
)
10150 && ffebad_start (FFEBAD_MATH_ARG_KIND
))
10152 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
10153 ffebad_here (1, ffelex_token_where_line (r
->token
), ffelex_token_where_column (r
->token
));
10154 ffebad_string ("an array");
10159 reduced
= ffebld_new_any ();
10160 ffebld_set_info (reduced
, ffeinfo_new_any ());
10164 /* ffeexpr_reduced_relop2_ -- Wrap up reduction of LT, LE, GE, and GT operators
10166 reduced = ffeexpr_reduced_relop2_(reduced,l,op,r);
10168 Makes sure the left and right arguments for reduced have basictype of
10169 INTEGER, REAL, or CHARACTER. Determine common basictype and
10170 size for reduction. If both left
10171 and right arguments have where of CONSTANT, assign where CONSTANT to
10172 reduced, else assign where FLEETING. Create CONVERT ops for args where
10173 needed. Convert typeless
10174 constants to the desired type/size explicitly.
10176 If these requirements cannot be met, generate error message. */
10179 ffeexpr_reduced_relop2_ (ffebld reduced
, ffeexprExpr_ l
, ffeexprExpr_ op
,
10182 ffeinfo linfo
, rinfo
, ninfo
;
10183 ffeinfoBasictype lbt
, rbt
, nbt
;
10184 ffeinfoKindtype lkt
, rkt
, nkt
;
10185 ffeinfoRank lrk
, rrk
;
10186 ffeinfoKind lkd
, rkd
;
10187 ffeinfoWhere lwh
, rwh
, nwh
;
10188 ffetargetCharacterSize lsz
, rsz
;
10190 linfo
= ffebld_info (ffebld_left (reduced
));
10191 lbt
= ffeinfo_basictype (linfo
);
10192 lkt
= ffeinfo_kindtype (linfo
);
10193 lrk
= ffeinfo_rank (linfo
);
10194 lkd
= ffeinfo_kind (linfo
);
10195 lwh
= ffeinfo_where (linfo
);
10196 lsz
= ffebld_size_known (ffebld_left (reduced
));
10198 rinfo
= ffebld_info (ffebld_right (reduced
));
10199 rbt
= ffeinfo_basictype (rinfo
);
10200 rkt
= ffeinfo_kindtype (rinfo
);
10201 rrk
= ffeinfo_rank (rinfo
);
10202 rkd
= ffeinfo_kind (rinfo
);
10203 rwh
= ffeinfo_where (rinfo
);
10204 rsz
= ffebld_size_known (ffebld_right (reduced
));
10206 ffeexpr_type_combine (&nbt
, &nkt
, lbt
, lkt
, rbt
, rkt
, op
->token
);
10208 if (((nbt
== FFEINFO_basictypeINTEGER
) || (nbt
== FFEINFO_basictypeREAL
)
10209 || (nbt
== FFEINFO_basictypeCHARACTER
))
10210 && (lrk
== 0) && (rrk
== 0))
10214 case FFEINFO_whereCONSTANT
:
10217 case FFEINFO_whereCONSTANT
:
10218 nwh
= FFEINFO_whereCONSTANT
;
10221 case FFEINFO_whereIMMEDIATE
:
10222 nwh
= FFEINFO_whereIMMEDIATE
;
10226 nwh
= FFEINFO_whereFLEETING
;
10231 case FFEINFO_whereIMMEDIATE
:
10234 case FFEINFO_whereCONSTANT
:
10235 case FFEINFO_whereIMMEDIATE
:
10236 nwh
= FFEINFO_whereIMMEDIATE
;
10240 nwh
= FFEINFO_whereFLEETING
;
10246 nwh
= FFEINFO_whereFLEETING
;
10250 if ((lsz
!= FFETARGET_charactersizeNONE
)
10251 && (rsz
!= FFETARGET_charactersizeNONE
))
10252 lsz
= rsz
= (lsz
> rsz
) ? lsz
: rsz
;
10254 ninfo
= ffeinfo_new (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICALDEFAULT
,
10255 0, FFEINFO_kindENTITY
, nwh
, FFETARGET_charactersizeNONE
);
10256 ffebld_set_info (reduced
, ninfo
);
10257 ffebld_set_left (reduced
, ffeexpr_convert (ffebld_left (reduced
),
10258 l
->token
, op
->token
, nbt
, nkt
, 0, lsz
,
10259 FFEEXPR_contextLET
));
10260 ffebld_set_right (reduced
, ffeexpr_convert (ffebld_right (reduced
),
10261 r
->token
, op
->token
, nbt
, nkt
, 0, rsz
,
10262 FFEEXPR_contextLET
));
10266 if ((lbt
!= FFEINFO_basictypeINTEGER
) && (lbt
!= FFEINFO_basictypeREAL
)
10267 && (lbt
!= FFEINFO_basictypeCHARACTER
))
10269 if ((rbt
!= FFEINFO_basictypeINTEGER
) && (rbt
!= FFEINFO_basictypeREAL
)
10270 && (rbt
!= FFEINFO_basictypeCHARACTER
))
10272 if ((lbt
!= FFEINFO_basictypeANY
) && (rbt
!= FFEINFO_basictypeANY
)
10273 && ffebad_start (FFEBAD_RELOP_ARGS_TYPE
))
10275 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
10276 ffebad_here (1, ffelex_token_where_line (l
->token
), ffelex_token_where_column (l
->token
));
10277 ffebad_here (2, ffelex_token_where_line (r
->token
), ffelex_token_where_column (r
->token
));
10283 if ((lbt
!= FFEINFO_basictypeANY
)
10284 && ffebad_start (FFEBAD_RELOP_ARG_TYPE
))
10286 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
10287 ffebad_here (1, ffelex_token_where_line (l
->token
), ffelex_token_where_column (l
->token
));
10292 else if ((rbt
!= FFEINFO_basictypeINTEGER
) && (rbt
!= FFEINFO_basictypeREAL
)
10293 && (rbt
!= FFEINFO_basictypeCHARACTER
))
10295 if ((rbt
!= FFEINFO_basictypeANY
)
10296 && ffebad_start (FFEBAD_RELOP_ARG_TYPE
))
10298 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
10299 ffebad_here (1, ffelex_token_where_line (r
->token
), ffelex_token_where_column (r
->token
));
10305 if ((lkd
!= FFEINFO_kindANY
)
10306 && ffebad_start (FFEBAD_RELOP_ARG_KIND
))
10308 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
10309 ffebad_here (1, ffelex_token_where_line (l
->token
), ffelex_token_where_column (l
->token
));
10310 ffebad_string ("an array");
10316 if ((rkd
!= FFEINFO_kindANY
)
10317 && ffebad_start (FFEBAD_RELOP_ARG_KIND
))
10319 ffebad_here (0, ffelex_token_where_line (op
->token
), ffelex_token_where_column (op
->token
));
10320 ffebad_here (1, ffelex_token_where_line (r
->token
), ffelex_token_where_column (r
->token
));
10321 ffebad_string ("an array");
10326 reduced
= ffebld_new_any ();
10327 ffebld_set_info (reduced
, ffeinfo_new_any ());
10331 /* ffeexpr_reduced_ugly1_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
10333 reduced = ffeexpr_reduced_ugly1_(reduced,op,r);
10338 ffeexpr_reduced_ugly1_ (ffebld reduced
, ffeexprExpr_ op
, ffeexprExpr_ r
)
10341 ffeinfoBasictype rbt
;
10342 ffeinfoKindtype rkt
;
10347 rinfo
= ffebld_info (ffebld_left (reduced
));
10348 rbt
= ffeinfo_basictype (rinfo
);
10349 rkt
= ffeinfo_kindtype (rinfo
);
10350 rrk
= ffeinfo_rank (rinfo
);
10351 rkd
= ffeinfo_kind (rinfo
);
10352 rwh
= ffeinfo_where (rinfo
);
10354 if ((rbt
== FFEINFO_basictypeTYPELESS
)
10355 || (rbt
== FFEINFO_basictypeHOLLERITH
))
10357 ffebld_set_left (reduced
, ffeexpr_convert (ffebld_left (reduced
),
10358 r
->token
, op
->token
, FFEINFO_basictypeINTEGER
,
10359 FFEINFO_kindtypeINTEGERDEFAULT
, 0,
10360 FFETARGET_charactersizeNONE
,
10361 FFEEXPR_contextLET
));
10362 rinfo
= ffebld_info (ffebld_left (reduced
));
10363 rbt
= FFEINFO_basictypeINTEGER
;
10364 rkt
= FFEINFO_kindtypeINTEGERDEFAULT
;
10366 rkd
= FFEINFO_kindENTITY
;
10367 rwh
= ffeinfo_where (rinfo
);
10370 if (rbt
== FFEINFO_basictypeLOGICAL
)
10372 ffebld_set_left (reduced
, ffeexpr_convert (ffebld_left (reduced
),
10373 r
->token
, op
->token
, FFEINFO_basictypeINTEGER
,
10374 FFEINFO_kindtypeINTEGERDEFAULT
, 0,
10375 FFETARGET_charactersizeNONE
,
10376 FFEEXPR_contextLET
));
10382 /* ffeexpr_reduced_ugly1log_ -- Deal with TYPELESS and HOLLERITH
10384 reduced = ffeexpr_reduced_ugly1log_(reduced,op,r);
10389 ffeexpr_reduced_ugly1log_ (ffebld reduced
, ffeexprExpr_ op
, ffeexprExpr_ r
)
10392 ffeinfoBasictype rbt
;
10393 ffeinfoKindtype rkt
;
10398 rinfo
= ffebld_info (ffebld_left (reduced
));
10399 rbt
= ffeinfo_basictype (rinfo
);
10400 rkt
= ffeinfo_kindtype (rinfo
);
10401 rrk
= ffeinfo_rank (rinfo
);
10402 rkd
= ffeinfo_kind (rinfo
);
10403 rwh
= ffeinfo_where (rinfo
);
10405 if ((rbt
== FFEINFO_basictypeTYPELESS
)
10406 || (rbt
== FFEINFO_basictypeHOLLERITH
))
10408 ffebld_set_left (reduced
, ffeexpr_convert (ffebld_left (reduced
),
10409 r
->token
, op
->token
, FFEINFO_basictypeLOGICAL
, 0,
10410 FFEINFO_kindtypeLOGICALDEFAULT
,
10411 FFETARGET_charactersizeNONE
,
10412 FFEEXPR_contextLET
));
10413 rinfo
= ffebld_info (ffebld_left (reduced
));
10414 rbt
= FFEINFO_basictypeLOGICAL
;
10415 rkt
= FFEINFO_kindtypeLOGICALDEFAULT
;
10417 rkd
= FFEINFO_kindENTITY
;
10418 rwh
= ffeinfo_where (rinfo
);
10424 /* ffeexpr_reduced_ugly2_ -- Deal with TYPELESS, HOLLERITH, and LOGICAL
10426 reduced = ffeexpr_reduced_ugly2_(reduced,l,op,r);
10431 ffeexpr_reduced_ugly2_ (ffebld reduced
, ffeexprExpr_ l
, ffeexprExpr_ op
,
10434 ffeinfo linfo
, rinfo
;
10435 ffeinfoBasictype lbt
, rbt
;
10436 ffeinfoKindtype lkt
, rkt
;
10437 ffeinfoRank lrk
, rrk
;
10438 ffeinfoKind lkd
, rkd
;
10439 ffeinfoWhere lwh
, rwh
;
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
);
10448 rinfo
= ffebld_info (ffebld_right (reduced
));
10449 rbt
= ffeinfo_basictype (rinfo
);
10450 rkt
= ffeinfo_kindtype (rinfo
);
10451 rrk
= ffeinfo_rank (rinfo
);
10452 rkd
= ffeinfo_kind (rinfo
);
10453 rwh
= ffeinfo_where (rinfo
);
10455 if ((lbt
== FFEINFO_basictypeTYPELESS
)
10456 || (lbt
== FFEINFO_basictypeHOLLERITH
))
10458 if ((rbt
== FFEINFO_basictypeTYPELESS
)
10459 || (rbt
== FFEINFO_basictypeHOLLERITH
))
10461 ffebld_set_left (reduced
, ffeexpr_convert (ffebld_left (reduced
),
10462 l
->token
, op
->token
, FFEINFO_basictypeINTEGER
,
10463 FFEINFO_kindtypeINTEGERDEFAULT
, 0,
10464 FFETARGET_charactersizeNONE
,
10465 FFEEXPR_contextLET
));
10466 ffebld_set_right (reduced
, ffeexpr_convert (ffebld_right (reduced
),
10467 r
->token
, op
->token
, FFEINFO_basictypeINTEGER
, 0,
10468 FFEINFO_kindtypeINTEGERDEFAULT
,
10469 FFETARGET_charactersizeNONE
,
10470 FFEEXPR_contextLET
));
10471 linfo
= ffebld_info (ffebld_left (reduced
));
10472 rinfo
= ffebld_info (ffebld_right (reduced
));
10473 lbt
= rbt
= FFEINFO_basictypeINTEGER
;
10474 lkt
= rkt
= FFEINFO_kindtypeINTEGERDEFAULT
;
10476 lkd
= rkd
= FFEINFO_kindENTITY
;
10477 lwh
= ffeinfo_where (linfo
);
10478 rwh
= ffeinfo_where (rinfo
);
10482 ffebld_set_left (reduced
, ffeexpr_convert_expr (ffebld_left (reduced
),
10483 l
->token
, ffebld_right (reduced
), r
->token
,
10484 FFEEXPR_contextLET
));
10485 linfo
= ffebld_info (ffebld_left (reduced
));
10486 lbt
= ffeinfo_basictype (linfo
);
10487 lkt
= ffeinfo_kindtype (linfo
);
10488 lrk
= ffeinfo_rank (linfo
);
10489 lkd
= ffeinfo_kind (linfo
);
10490 lwh
= ffeinfo_where (linfo
);
10495 if ((rbt
== FFEINFO_basictypeTYPELESS
)
10496 || (rbt
== FFEINFO_basictypeHOLLERITH
))
10498 ffebld_set_right (reduced
, ffeexpr_convert_expr (ffebld_right (reduced
),
10499 r
->token
, ffebld_left (reduced
), l
->token
,
10500 FFEEXPR_contextLET
));
10501 rinfo
= ffebld_info (ffebld_right (reduced
));
10502 rbt
= ffeinfo_basictype (rinfo
);
10503 rkt
= ffeinfo_kindtype (rinfo
);
10504 rrk
= ffeinfo_rank (rinfo
);
10505 rkd
= ffeinfo_kind (rinfo
);
10506 rwh
= ffeinfo_where (rinfo
);
10508 /* else Leave it alone. */
10511 if (lbt
== FFEINFO_basictypeLOGICAL
)
10513 ffebld_set_left (reduced
, ffeexpr_convert (ffebld_left (reduced
),
10514 l
->token
, op
->token
, FFEINFO_basictypeINTEGER
,
10515 FFEINFO_kindtypeINTEGERDEFAULT
, 0,
10516 FFETARGET_charactersizeNONE
,
10517 FFEEXPR_contextLET
));
10520 if (rbt
== FFEINFO_basictypeLOGICAL
)
10522 ffebld_set_right (reduced
, ffeexpr_convert (ffebld_right (reduced
),
10523 r
->token
, op
->token
, FFEINFO_basictypeINTEGER
,
10524 FFEINFO_kindtypeINTEGERDEFAULT
, 0,
10525 FFETARGET_charactersizeNONE
,
10526 FFEEXPR_contextLET
));
10532 /* ffeexpr_reduced_ugly2log_ -- Deal with TYPELESS and HOLLERITH
10534 reduced = ffeexpr_reduced_ugly2log_(reduced,l,op,r);
10539 ffeexpr_reduced_ugly2log_ (ffebld reduced
, ffeexprExpr_ l
, ffeexprExpr_ op
,
10540 ffeexprExpr_ r
, bool *bothlogical
)
10542 ffeinfo linfo
, rinfo
;
10543 ffeinfoBasictype lbt
, rbt
;
10544 ffeinfoKindtype lkt
, rkt
;
10545 ffeinfoRank lrk
, rrk
;
10546 ffeinfoKind lkd
, rkd
;
10547 ffeinfoWhere lwh
, rwh
;
10549 linfo
= ffebld_info (ffebld_left (reduced
));
10550 lbt
= ffeinfo_basictype (linfo
);
10551 lkt
= ffeinfo_kindtype (linfo
);
10552 lrk
= ffeinfo_rank (linfo
);
10553 lkd
= ffeinfo_kind (linfo
);
10554 lwh
= ffeinfo_where (linfo
);
10556 rinfo
= ffebld_info (ffebld_right (reduced
));
10557 rbt
= ffeinfo_basictype (rinfo
);
10558 rkt
= ffeinfo_kindtype (rinfo
);
10559 rrk
= ffeinfo_rank (rinfo
);
10560 rkd
= ffeinfo_kind (rinfo
);
10561 rwh
= ffeinfo_where (rinfo
);
10563 if ((lbt
== FFEINFO_basictypeTYPELESS
)
10564 || (lbt
== FFEINFO_basictypeHOLLERITH
))
10566 if ((rbt
== FFEINFO_basictypeTYPELESS
)
10567 || (rbt
== FFEINFO_basictypeHOLLERITH
))
10569 ffebld_set_left (reduced
, ffeexpr_convert (ffebld_left (reduced
),
10570 l
->token
, op
->token
, FFEINFO_basictypeLOGICAL
,
10571 FFEINFO_kindtypeLOGICALDEFAULT
, 0,
10572 FFETARGET_charactersizeNONE
,
10573 FFEEXPR_contextLET
));
10574 ffebld_set_right (reduced
, ffeexpr_convert (ffebld_right (reduced
),
10575 r
->token
, op
->token
, FFEINFO_basictypeLOGICAL
,
10576 FFEINFO_kindtypeLOGICALDEFAULT
, 0,
10577 FFETARGET_charactersizeNONE
,
10578 FFEEXPR_contextLET
));
10579 linfo
= ffebld_info (ffebld_left (reduced
));
10580 rinfo
= ffebld_info (ffebld_right (reduced
));
10581 lbt
= rbt
= FFEINFO_basictypeLOGICAL
;
10582 lkt
= rkt
= FFEINFO_kindtypeLOGICALDEFAULT
;
10584 lkd
= rkd
= FFEINFO_kindENTITY
;
10585 lwh
= ffeinfo_where (linfo
);
10586 rwh
= ffeinfo_where (rinfo
);
10590 ffebld_set_left (reduced
, ffeexpr_convert_expr (ffebld_left (reduced
),
10591 l
->token
, ffebld_right (reduced
), r
->token
,
10592 FFEEXPR_contextLET
));
10593 linfo
= ffebld_info (ffebld_left (reduced
));
10594 lbt
= ffeinfo_basictype (linfo
);
10595 lkt
= ffeinfo_kindtype (linfo
);
10596 lrk
= ffeinfo_rank (linfo
);
10597 lkd
= ffeinfo_kind (linfo
);
10598 lwh
= ffeinfo_where (linfo
);
10603 if ((rbt
== FFEINFO_basictypeTYPELESS
)
10604 || (rbt
== FFEINFO_basictypeHOLLERITH
))
10606 ffebld_set_right (reduced
, ffeexpr_convert_expr (ffebld_right (reduced
),
10607 r
->token
, ffebld_left (reduced
), l
->token
,
10608 FFEEXPR_contextLET
));
10609 rinfo
= ffebld_info (ffebld_right (reduced
));
10610 rbt
= ffeinfo_basictype (rinfo
);
10611 rkt
= ffeinfo_kindtype (rinfo
);
10612 rrk
= ffeinfo_rank (rinfo
);
10613 rkd
= ffeinfo_kind (rinfo
);
10614 rwh
= ffeinfo_where (rinfo
);
10616 /* else Leave it alone. */
10619 if (lbt
== FFEINFO_basictypeLOGICAL
)
10621 ffebld_set_left (reduced
,
10622 ffeexpr_convert (ffebld_left (reduced
),
10623 l
->token
, op
->token
,
10624 FFEINFO_basictypeINTEGER
,
10625 FFEINFO_kindtypeINTEGERDEFAULT
, 0,
10626 FFETARGET_charactersizeNONE
,
10627 FFEEXPR_contextLET
));
10630 if (rbt
== FFEINFO_basictypeLOGICAL
)
10632 ffebld_set_right (reduced
,
10633 ffeexpr_convert (ffebld_right (reduced
),
10634 r
->token
, op
->token
,
10635 FFEINFO_basictypeINTEGER
,
10636 FFEINFO_kindtypeINTEGERDEFAULT
, 0,
10637 FFETARGET_charactersizeNONE
,
10638 FFEEXPR_contextLET
));
10641 if (bothlogical
!= NULL
)
10642 *bothlogical
= (lbt
== FFEINFO_basictypeLOGICAL
10643 && rbt
== FFEINFO_basictypeLOGICAL
);
10648 /* Fumble through tokens until a nonmatching CLOSE_PAREN, EOS, or SEMICOLON
10651 The idea is to process the tokens as they would be done by normal
10652 expression processing, with the key things being telling the lexer
10653 when hollerith/character constants are about to happen, until the
10654 true closing token is found. */
10656 static ffelexHandler
10657 ffeexpr_find_close_paren_ (ffelexToken t
,
10658 ffelexHandler after
)
10660 ffeexpr_find_
.after
= after
;
10661 ffeexpr_find_
.level
= 1;
10662 return (ffelexHandler
) ffeexpr_nil_rhs_ (t
);
10665 static ffelexHandler
10666 ffeexpr_nil_finished_ (ffelexToken t
)
10668 switch (ffelex_token_type (t
))
10670 case FFELEX_typeCLOSE_PAREN
:
10671 if (--ffeexpr_find_
.level
== 0)
10672 return (ffelexHandler
) ffeexpr_find_
.after
;
10673 return (ffelexHandler
) ffeexpr_nil_binary_
;
10675 case FFELEX_typeCOMMA
:
10676 case FFELEX_typeCOLON
:
10677 case FFELEX_typeEQUALS
:
10678 case FFELEX_typePOINTS
:
10679 return (ffelexHandler
) ffeexpr_nil_rhs_
;
10682 if (--ffeexpr_find_
.level
== 0)
10683 return (ffelexHandler
) ffeexpr_find_
.after (t
);
10684 return (ffelexHandler
) ffeexpr_nil_rhs_ (t
);
10688 static ffelexHandler
10689 ffeexpr_nil_rhs_ (ffelexToken t
)
10691 switch (ffelex_token_type (t
))
10693 case FFELEX_typeQUOTE
:
10695 return (ffelexHandler
) ffeexpr_nil_quote_
;
10696 ffelex_set_expecting_hollerith (-1, '\"',
10697 ffelex_token_where_line (t
),
10698 ffelex_token_where_column (t
));
10699 return (ffelexHandler
) ffeexpr_nil_apostrophe_
;
10701 case FFELEX_typeAPOSTROPHE
:
10702 ffelex_set_expecting_hollerith (-1, '\'',
10703 ffelex_token_where_line (t
),
10704 ffelex_token_where_column (t
));
10705 return (ffelexHandler
) ffeexpr_nil_apostrophe_
;
10707 case FFELEX_typePERCENT
:
10708 return (ffelexHandler
) ffeexpr_nil_percent_
;
10710 case FFELEX_typeOPEN_PAREN
:
10711 ++ffeexpr_find_
.level
;
10712 return (ffelexHandler
) ffeexpr_nil_rhs_
;
10714 case FFELEX_typePLUS
:
10715 case FFELEX_typeMINUS
:
10716 return (ffelexHandler
) ffeexpr_nil_rhs_
;
10718 case FFELEX_typePERIOD
:
10719 return (ffelexHandler
) ffeexpr_nil_period_
;
10721 case FFELEX_typeNUMBER
:
10722 ffeexpr_hollerith_count_
= atol (ffelex_token_text (t
));
10723 if (ffeexpr_hollerith_count_
> 0)
10724 ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_
,
10726 ffelex_token_where_line (t
),
10727 ffelex_token_where_column (t
));
10728 return (ffelexHandler
) ffeexpr_nil_number_
;
10730 case FFELEX_typeNAME
:
10731 case FFELEX_typeNAMES
:
10732 return (ffelexHandler
) ffeexpr_nil_name_rhs_
;
10734 case FFELEX_typeASTERISK
:
10735 case FFELEX_typeSLASH
:
10736 case FFELEX_typePOWER
:
10737 case FFELEX_typeCONCAT
:
10738 case FFELEX_typeREL_EQ
:
10739 case FFELEX_typeREL_NE
:
10740 case FFELEX_typeREL_LE
:
10741 case FFELEX_typeREL_GE
:
10742 return (ffelexHandler
) ffeexpr_nil_rhs_
;
10745 return (ffelexHandler
) ffeexpr_nil_finished_ (t
);
10749 static ffelexHandler
10750 ffeexpr_nil_period_ (ffelexToken t
)
10752 switch (ffelex_token_type (t
))
10754 case FFELEX_typeNAME
:
10755 case FFELEX_typeNAMES
:
10756 ffeexpr_current_dotdot_
= ffestr_other (t
);
10757 switch (ffeexpr_current_dotdot_
)
10759 case FFESTR_otherNone
:
10760 return (ffelexHandler
) ffeexpr_nil_rhs_ (t
);
10762 case FFESTR_otherTRUE
:
10763 case FFESTR_otherFALSE
:
10764 case FFESTR_otherNOT
:
10765 return (ffelexHandler
) ffeexpr_nil_end_period_
;
10768 return (ffelexHandler
) ffeexpr_nil_swallow_period_
;
10770 break; /* Nothing really reaches here. */
10772 case FFELEX_typeNUMBER
:
10773 return (ffelexHandler
) ffeexpr_nil_real_
;
10776 return (ffelexHandler
) ffeexpr_nil_rhs_ (t
);
10780 static ffelexHandler
10781 ffeexpr_nil_end_period_ (ffelexToken t
)
10783 switch (ffeexpr_current_dotdot_
)
10785 case FFESTR_otherNOT
:
10786 if (ffelex_token_type (t
) != FFELEX_typePERIOD
)
10787 return (ffelexHandler
) ffeexpr_nil_rhs_ (t
);
10788 return (ffelexHandler
) ffeexpr_nil_rhs_
;
10790 case FFESTR_otherTRUE
:
10791 case FFESTR_otherFALSE
:
10792 if (ffelex_token_type (t
) != FFELEX_typePERIOD
)
10793 return (ffelexHandler
) ffeexpr_nil_binary_ (t
);
10794 return (ffelexHandler
) ffeexpr_nil_binary_
;
10797 assert ("Bad [nil] unary dotdot in ffeexpr_current_dotdot_" == NULL
);
10803 static ffelexHandler
10804 ffeexpr_nil_swallow_period_ (ffelexToken t
)
10806 if (ffelex_token_type (t
) != FFELEX_typePERIOD
)
10807 return (ffelexHandler
) ffeexpr_nil_rhs_ (t
);
10808 return (ffelexHandler
) ffeexpr_nil_rhs_
;
10811 static ffelexHandler
10812 ffeexpr_nil_real_ (ffelexToken t
)
10817 if (((ffelex_token_type (t
) != FFELEX_typeNAME
)
10818 && (ffelex_token_type (t
) != FFELEX_typeNAMES
))
10819 || !(((ffesrc_char_match_init ((d
= *(p
= ffelex_token_text (t
))),
10821 || ffesrc_char_match_init (d
, 'E', 'e')
10822 || ffesrc_char_match_init (d
, 'Q', 'q')))
10823 && ffeexpr_isdigits_ (++p
)))
10824 return (ffelexHandler
) ffeexpr_nil_binary_ (t
);
10827 return (ffelexHandler
) ffeexpr_nil_real_exponent_
;
10828 return (ffelexHandler
) ffeexpr_nil_binary_
;
10831 static ffelexHandler
10832 ffeexpr_nil_real_exponent_ (ffelexToken t
)
10834 if ((ffelex_token_type (t
) != FFELEX_typePLUS
)
10835 && (ffelex_token_type (t
) != FFELEX_typeMINUS
))
10836 return (ffelexHandler
) ffeexpr_nil_binary_ (t
);
10838 return (ffelexHandler
) ffeexpr_nil_real_exp_sign_
;
10841 static ffelexHandler
10842 ffeexpr_nil_real_exp_sign_ (ffelexToken t
)
10844 if (ffelex_token_type (t
) != FFELEX_typeNUMBER
)
10845 return (ffelexHandler
) ffeexpr_nil_binary_ (t
);
10846 return (ffelexHandler
) ffeexpr_nil_binary_
;
10849 static ffelexHandler
10850 ffeexpr_nil_number_ (ffelexToken t
)
10855 if (ffeexpr_hollerith_count_
> 0)
10856 ffelex_set_expecting_hollerith (0, '\0',
10857 ffewhere_line_unknown (),
10858 ffewhere_column_unknown ());
10860 switch (ffelex_token_type (t
))
10862 case FFELEX_typeNAME
:
10863 case FFELEX_typeNAMES
:
10864 if ((ffesrc_char_match_init ((d
= *(p
= ffelex_token_text (t
))),
10866 || ffesrc_char_match_init (d
, 'E', 'e')
10867 || ffesrc_char_match_init (d
, 'Q', 'q'))
10868 && ffeexpr_isdigits_ (++p
))
10872 ffeexpr_find_
.t
= ffelex_token_use (t
);
10873 return (ffelexHandler
) ffeexpr_nil_number_exponent_
;
10875 return (ffelexHandler
) ffeexpr_nil_binary_
;
10879 case FFELEX_typePERIOD
:
10880 ffeexpr_find_
.t
= ffelex_token_use (t
);
10881 return (ffelexHandler
) ffeexpr_nil_number_period_
;
10883 case FFELEX_typeHOLLERITH
:
10884 return (ffelexHandler
) ffeexpr_nil_binary_
;
10889 return (ffelexHandler
) ffeexpr_nil_binary_ (t
);
10892 /* Expects ffeexpr_find_.t. */
10894 static ffelexHandler
10895 ffeexpr_nil_number_exponent_ (ffelexToken t
)
10897 ffelexHandler nexthandler
;
10899 if ((ffelex_token_type (t
) != FFELEX_typePLUS
)
10900 && (ffelex_token_type (t
) != FFELEX_typeMINUS
))
10903 = (ffelexHandler
) ffeexpr_nil_binary_ (ffeexpr_find_
.t
);
10904 ffelex_token_kill (ffeexpr_find_
.t
);
10905 return (ffelexHandler
) (*nexthandler
) (t
);
10908 ffelex_token_kill (ffeexpr_find_
.t
);
10909 return (ffelexHandler
) ffeexpr_nil_number_exp_sign_
;
10912 static ffelexHandler
10913 ffeexpr_nil_number_exp_sign_ (ffelexToken t
)
10915 if (ffelex_token_type (t
) != FFELEX_typeNUMBER
)
10916 return (ffelexHandler
) ffeexpr_nil_binary_ (t
);
10918 return (ffelexHandler
) ffeexpr_nil_binary_
;
10921 /* Expects ffeexpr_find_.t. */
10923 static ffelexHandler
10924 ffeexpr_nil_number_period_ (ffelexToken t
)
10926 ffelexHandler nexthandler
;
10930 switch (ffelex_token_type (t
))
10932 case FFELEX_typeNAME
:
10933 case FFELEX_typeNAMES
:
10934 if ((ffesrc_char_match_init ((d
= *(p
= ffelex_token_text (t
))),
10936 || ffesrc_char_match_init (d
, 'E', 'e')
10937 || ffesrc_char_match_init (d
, 'Q', 'q'))
10938 && ffeexpr_isdigits_ (++p
))
10941 return (ffelexHandler
) ffeexpr_nil_number_per_exp_
;
10942 ffelex_token_kill (ffeexpr_find_
.t
);
10943 return (ffelexHandler
) ffeexpr_nil_binary_
;
10946 = (ffelexHandler
) ffeexpr_nil_binary_ (ffeexpr_find_
.t
);
10947 ffelex_token_kill (ffeexpr_find_
.t
);
10948 return (ffelexHandler
) (*nexthandler
) (t
);
10950 case FFELEX_typeNUMBER
:
10951 ffelex_token_kill (ffeexpr_find_
.t
);
10952 return (ffelexHandler
) ffeexpr_nil_number_real_
;
10957 ffelex_token_kill (ffeexpr_find_
.t
);
10958 return (ffelexHandler
) ffeexpr_nil_binary_ (t
);
10961 /* Expects ffeexpr_find_.t. */
10963 static ffelexHandler
10964 ffeexpr_nil_number_per_exp_ (ffelexToken t
)
10966 if ((ffelex_token_type (t
) != FFELEX_typePLUS
)
10967 && (ffelex_token_type (t
) != FFELEX_typeMINUS
))
10969 ffelexHandler nexthandler
;
10972 = (ffelexHandler
) ffeexpr_nil_binary_ (ffeexpr_find_
.t
);
10973 ffelex_token_kill (ffeexpr_find_
.t
);
10974 return (ffelexHandler
) (*nexthandler
) (t
);
10977 ffelex_token_kill (ffeexpr_find_
.t
);
10978 return (ffelexHandler
) ffeexpr_nil_num_per_exp_sign_
;
10981 static ffelexHandler
10982 ffeexpr_nil_number_real_ (ffelexToken t
)
10987 if (((ffelex_token_type (t
) != FFELEX_typeNAME
)
10988 && (ffelex_token_type (t
) != FFELEX_typeNAMES
))
10989 || !(((ffesrc_char_match_init ((d
= *(p
= ffelex_token_text (t
))),
10991 || ffesrc_char_match_init (d
, 'E', 'e')
10992 || ffesrc_char_match_init (d
, 'Q', 'q')))
10993 && ffeexpr_isdigits_ (++p
)))
10994 return (ffelexHandler
) ffeexpr_nil_binary_ (t
);
10997 return (ffelexHandler
) ffeexpr_nil_number_real_exp_
;
10999 return (ffelexHandler
) ffeexpr_nil_binary_
;
11002 static ffelexHandler
11003 ffeexpr_nil_num_per_exp_sign_ (ffelexToken t
)
11005 if (ffelex_token_type (t
) != FFELEX_typeNUMBER
)
11006 return (ffelexHandler
) ffeexpr_nil_binary_ (t
);
11007 return (ffelexHandler
) ffeexpr_nil_binary_
;
11010 static ffelexHandler
11011 ffeexpr_nil_number_real_exp_ (ffelexToken t
)
11013 if ((ffelex_token_type (t
) != FFELEX_typePLUS
)
11014 && (ffelex_token_type (t
) != FFELEX_typeMINUS
))
11015 return (ffelexHandler
) ffeexpr_nil_binary_ (t
);
11016 return (ffelexHandler
) ffeexpr_nil_num_real_exp_sn_
;
11019 static ffelexHandler
11020 ffeexpr_nil_num_real_exp_sn_ (ffelexToken t
)
11022 if (ffelex_token_type (t
) != FFELEX_typeNUMBER
)
11023 return (ffelexHandler
) ffeexpr_nil_binary_ (t
);
11024 return (ffelexHandler
) ffeexpr_nil_binary_
;
11027 static ffelexHandler
11028 ffeexpr_nil_binary_ (ffelexToken t
)
11030 switch (ffelex_token_type (t
))
11032 case FFELEX_typePLUS
:
11033 case FFELEX_typeMINUS
:
11034 case FFELEX_typeASTERISK
:
11035 case FFELEX_typeSLASH
:
11036 case FFELEX_typePOWER
:
11037 case FFELEX_typeCONCAT
:
11038 case FFELEX_typeOPEN_ANGLE
:
11039 case FFELEX_typeCLOSE_ANGLE
:
11040 case FFELEX_typeREL_EQ
:
11041 case FFELEX_typeREL_NE
:
11042 case FFELEX_typeREL_GE
:
11043 case FFELEX_typeREL_LE
:
11044 return (ffelexHandler
) ffeexpr_nil_rhs_
;
11046 case FFELEX_typePERIOD
:
11047 return (ffelexHandler
) ffeexpr_nil_binary_period_
;
11050 return (ffelexHandler
) ffeexpr_nil_finished_ (t
);
11054 static ffelexHandler
11055 ffeexpr_nil_binary_period_ (ffelexToken t
)
11057 switch (ffelex_token_type (t
))
11059 case FFELEX_typeNAME
:
11060 case FFELEX_typeNAMES
:
11061 ffeexpr_current_dotdot_
= ffestr_other (t
);
11062 switch (ffeexpr_current_dotdot_
)
11064 case FFESTR_otherTRUE
:
11065 case FFESTR_otherFALSE
:
11066 case FFESTR_otherNOT
:
11067 return (ffelexHandler
) ffeexpr_nil_binary_sw_per_
;
11070 return (ffelexHandler
) ffeexpr_nil_binary_end_per_
;
11072 break; /* Nothing really reaches here. */
11075 return (ffelexHandler
) ffeexpr_nil_binary_ (t
);
11079 static ffelexHandler
11080 ffeexpr_nil_binary_end_per_ (ffelexToken t
)
11082 if (ffelex_token_type (t
) != FFELEX_typePERIOD
)
11083 return (ffelexHandler
) ffeexpr_nil_rhs_ (t
);
11084 return (ffelexHandler
) ffeexpr_nil_rhs_
;
11087 static ffelexHandler
11088 ffeexpr_nil_binary_sw_per_ (ffelexToken t
)
11090 if (ffelex_token_type (t
) != FFELEX_typePERIOD
)
11091 return (ffelexHandler
) ffeexpr_nil_binary_ (t
);
11092 return (ffelexHandler
) ffeexpr_nil_binary_
;
11095 static ffelexHandler
11096 ffeexpr_nil_quote_ (ffelexToken t
)
11098 if (ffelex_token_type (t
) != FFELEX_typeNUMBER
)
11099 return (ffelexHandler
) ffeexpr_nil_rhs_ (t
);
11100 return (ffelexHandler
) ffeexpr_nil_binary_
;
11103 static ffelexHandler
11104 ffeexpr_nil_apostrophe_ (ffelexToken t
)
11106 assert (ffelex_token_type (t
) == FFELEX_typeCHARACTER
);
11107 return (ffelexHandler
) ffeexpr_nil_apos_char_
;
11110 static ffelexHandler
11111 ffeexpr_nil_apos_char_ (ffelexToken t
)
11115 if ((ffelex_token_type (t
) == FFELEX_typeNAME
)
11116 || (ffelex_token_type (t
) == FFELEX_typeNAMES
))
11118 if ((ffelex_token_length (t
) == 1)
11119 && (ffesrc_char_match_init ((c
= ffelex_token_text (t
)[0]),
11121 || ffesrc_char_match_init (c
, 'O', 'o')
11122 || ffesrc_char_match_init (c
, 'X', 'x')
11123 || ffesrc_char_match_init (c
, 'Z', 'z')))
11124 return (ffelexHandler
) ffeexpr_nil_binary_
;
11126 if ((ffelex_token_type (t
) == FFELEX_typeNAME
)
11127 || (ffelex_token_type (t
) == FFELEX_typeNAMES
))
11128 return (ffelexHandler
) ffeexpr_nil_rhs_ (t
);
11129 return (ffelexHandler
) ffeexpr_nil_substrp_ (t
);
11132 static ffelexHandler
11133 ffeexpr_nil_name_rhs_ (ffelexToken t
)
11135 switch (ffelex_token_type (t
))
11137 case FFELEX_typeQUOTE
:
11138 case FFELEX_typeAPOSTROPHE
:
11139 ffelex_set_hexnum (TRUE
);
11140 return (ffelexHandler
) ffeexpr_nil_name_apos_
;
11142 case FFELEX_typeOPEN_PAREN
:
11143 ++ffeexpr_find_
.level
;
11144 return (ffelexHandler
) ffeexpr_nil_rhs_
;
11147 return (ffelexHandler
) ffeexpr_nil_binary_ (t
);
11151 static ffelexHandler
11152 ffeexpr_nil_name_apos_ (ffelexToken t
)
11154 if (ffelex_token_type (t
) == FFELEX_typeNAME
)
11155 return (ffelexHandler
) ffeexpr_nil_name_apos_name_
;
11156 return (ffelexHandler
) ffeexpr_nil_binary_ (t
);
11159 static ffelexHandler
11160 ffeexpr_nil_name_apos_name_ (ffelexToken t
)
11162 switch (ffelex_token_type (t
))
11164 case FFELEX_typeAPOSTROPHE
:
11165 case FFELEX_typeQUOTE
:
11166 return (ffelexHandler
) ffeexpr_nil_finished_
;
11169 return (ffelexHandler
) ffeexpr_nil_finished_ (t
);
11173 static ffelexHandler
11174 ffeexpr_nil_percent_ (ffelexToken t
)
11176 switch (ffelex_token_type (t
))
11178 case FFELEX_typeNAME
:
11179 case FFELEX_typeNAMES
:
11180 ffeexpr_stack_
->percent
= ffeexpr_percent_ (t
);
11181 ffeexpr_find_
.t
= ffelex_token_use (t
);
11182 return (ffelexHandler
) ffeexpr_nil_percent_name_
;
11185 return (ffelexHandler
) ffeexpr_nil_rhs_ (t
);
11189 /* Expects ffeexpr_find_.t. */
11191 static ffelexHandler
11192 ffeexpr_nil_percent_name_ (ffelexToken t
)
11194 ffelexHandler nexthandler
;
11196 if (ffelex_token_type (t
) != FFELEX_typeOPEN_PAREN
)
11199 = (ffelexHandler
) ffeexpr_nil_rhs_ (ffeexpr_find_
.t
);
11200 ffelex_token_kill (ffeexpr_find_
.t
);
11201 return (ffelexHandler
) (*nexthandler
) (t
);
11204 ffelex_token_kill (ffeexpr_find_
.t
);
11205 ++ffeexpr_find_
.level
;
11206 return (ffelexHandler
) ffeexpr_nil_rhs_
;
11209 static ffelexHandler
11210 ffeexpr_nil_substrp_ (ffelexToken t
)
11212 if (ffelex_token_type (t
) != FFELEX_typeOPEN_PAREN
)
11213 return (ffelexHandler
) ffeexpr_nil_binary_ (t
);
11215 ++ffeexpr_find_
.level
;
11216 return (ffelexHandler
) ffeexpr_nil_rhs_
;
11219 /* ffeexpr_finished_ -- Reduce expression stack to one expr, finish
11222 return ffeexpr_finished_(t);
11224 Reduces expression stack to one (or zero) elements by repeatedly reducing
11225 the top operator on the stack (or, if the top element on the stack is
11226 itself an operator, issuing an error message and discarding it). Calls
11227 finishing routine with the expression, returning the ffelexHandler it
11228 returns to the caller. */
11230 static ffelexHandler
11231 ffeexpr_finished_ (ffelexToken t
)
11233 ffeexprExpr_ operand
; /* This is B in -B or A+B. */
11235 ffeexprCallback callback
;
11237 ffebldConstant constnode
; /* For detecting magical number. */
11238 ffelexToken ft
; /* Temporary copy of first token in
11240 ffelexHandler next
;
11242 bool error
= FALSE
;
11244 while (((operand
= ffeexpr_stack_
->exprstack
) != NULL
)
11245 && ((operand
->previous
!= NULL
) || (operand
->type
!= FFEEXPR_exprtypeOPERAND_
)))
11247 if (operand
->type
== FFEEXPR_exprtypeOPERAND_
)
11248 ffeexpr_reduce_ ();
11251 if (ffest_ffebad_start (FFEBAD_MISSING_OPERAND_FOR_OPERATOR
))
11253 ffebad_here (0, ffelex_token_where_line (t
),
11254 ffelex_token_where_column (t
));
11255 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_
->exprstack
->token
),
11256 ffelex_token_where_column (ffeexpr_stack_
->exprstack
->token
));
11259 ffeexpr_stack_
->exprstack
= operand
->previous
; /* Pop the useless
11261 ffeexpr_expr_kill_ (operand
);
11265 assert ((operand
== NULL
) || (operand
->previous
== NULL
));
11267 ffebld_pool_pop ();
11268 if (operand
== NULL
)
11272 expr
= operand
->u
.operand
;
11273 info
= ffebld_info (expr
);
11274 if ((ffebld_op (expr
) == FFEBLD_opCONTER
)
11275 && (ffebld_conter_orig (expr
) == NULL
)
11276 && ffebld_constant_is_magical (constnode
= ffebld_conter (expr
)))
11278 ffetarget_integer_bad_magical (operand
->token
);
11280 ffeexpr_expr_kill_ (operand
);
11281 ffeexpr_stack_
->exprstack
= NULL
;
11284 ft
= ffeexpr_stack_
->first_token
;
11286 again
: /* :::::::::::::::::::: */
11287 switch (ffeexpr_stack_
->context
)
11289 case FFEEXPR_contextLET
:
11290 case FFEEXPR_contextSFUNCDEF
:
11291 error
= (expr
== NULL
)
11292 || (ffeinfo_rank (info
) != 0);
11295 case FFEEXPR_contextPAREN_
:
11296 if ((error
= (expr
== NULL
) || (ffeinfo_rank (info
) != 0)))
11298 switch (ffeinfo_basictype (info
))
11300 case FFEINFO_basictypeHOLLERITH
:
11301 case FFEINFO_basictypeTYPELESS
:
11302 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeINTEGER
,
11303 FFEINFO_kindtypeINTEGERDEFAULT
, 0, FFETARGET_charactersizeNONE
,
11304 FFEEXPR_contextLET
);
11312 case FFEEXPR_contextPARENFILENUM_
:
11313 if (ffelex_token_type (t
) != FFELEX_typeCOMMA
)
11314 ffeexpr_stack_
->context
= FFEEXPR_contextPAREN_
;
11316 ffeexpr_stack_
->context
= FFEEXPR_contextFILENUM
;
11317 goto again
; /* :::::::::::::::::::: */
11319 case FFEEXPR_contextPARENFILEUNIT_
:
11320 if (ffelex_token_type (t
) != FFELEX_typeCOMMA
)
11321 ffeexpr_stack_
->context
= FFEEXPR_contextPAREN_
;
11323 ffeexpr_stack_
->context
= FFEEXPR_contextFILEUNIT
;
11324 goto again
; /* :::::::::::::::::::: */
11326 case FFEEXPR_contextACTUALARGEXPR_
:
11327 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_
:
11328 switch ((expr
== NULL
) ? FFEINFO_basictypeNONE
11329 : ffeinfo_basictype (info
))
11331 case FFEINFO_basictypeHOLLERITH
:
11332 case FFEINFO_basictypeTYPELESS
:
11333 if (!ffe_is_ugly_args ()
11334 && ffebad_start (FFEBAD_ACTUALARG
))
11336 ffebad_here (0, ffelex_token_where_line (ft
),
11337 ffelex_token_where_column (ft
));
11345 error
= (expr
!= NULL
) && (ffeinfo_rank (info
) != 0);
11348 case FFEEXPR_contextACTUALARG_
:
11349 case FFEEXPR_contextSFUNCDEFACTUALARG_
:
11350 switch ((expr
== NULL
) ? FFEINFO_basictypeNONE
11351 : ffeinfo_basictype (info
))
11353 case FFEINFO_basictypeHOLLERITH
:
11354 case FFEINFO_basictypeTYPELESS
:
11355 #if 0 /* Should never get here. */
11356 expr
= ffeexpr_convert (expr
, ft
, ft
,
11357 FFEINFO_basictypeINTEGER
,
11358 FFEINFO_kindtypeINTEGERDEFAULT
,
11360 FFETARGET_charactersizeNONE
,
11361 FFEEXPR_contextLET
);
11363 assert ("why hollerith/typeless in actualarg_?" == NULL
);
11370 switch ((expr
== NULL
) ? FFEBLD_opANY
: ffebld_op (expr
))
11372 case FFEBLD_opSYMTER
:
11373 case FFEBLD_opPERCENT_LOC
:
11374 case FFEBLD_opPERCENT_VAL
:
11375 case FFEBLD_opPERCENT_REF
:
11376 case FFEBLD_opPERCENT_DESCR
:
11381 error
= (expr
!= NULL
) && (ffeinfo_rank (info
) != 0);
11386 ffeinfoWhere where
;
11391 && (ffebld_op (expr
) == FFEBLD_opSYMTER
)
11392 && ((s
= ffebld_symter (expr
)), (where
= ffesymbol_where (s
)),
11393 (where
== FFEINFO_whereINTRINSIC
)
11394 || (where
== FFEINFO_whereGLOBAL
)
11395 || ((where
== FFEINFO_whereDUMMY
)
11396 && ((kind
= ffesymbol_kind (s
)),
11397 (kind
== FFEINFO_kindFUNCTION
)
11398 || (kind
== FFEINFO_kindSUBROUTINE
))))
11399 && !ffesymbol_explicitwhere (s
))
11401 ffebad_start (where
== FFEINFO_whereINTRINSIC
11402 ? FFEBAD_NEED_INTRINSIC
: FFEBAD_NEED_EXTERNAL
);
11403 ffebad_here (0, ffelex_token_where_line (ft
),
11404 ffelex_token_where_column (ft
));
11405 ffebad_string (ffesymbol_text (s
));
11407 ffesymbol_signal_change (s
);
11408 ffesymbol_set_explicitwhere (s
, TRUE
);
11409 ffesymbol_signal_unreported (s
);
11414 case FFEEXPR_contextINDEX_
:
11415 case FFEEXPR_contextSFUNCDEFINDEX_
:
11416 if ((error
= (expr
!= NULL
) && (ffeinfo_rank (info
) != 0)))
11418 switch ((expr
== NULL
) ? FFEINFO_basictypeNONE
11419 : ffeinfo_basictype (info
))
11421 case FFEINFO_basictypeNONE
:
11425 case FFEINFO_basictypeLOGICAL
:
11426 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeLOGICAL
,
11427 FFEINFO_kindtypeLOGICALDEFAULT
, 0, FFETARGET_charactersizeNONE
,
11428 FFEEXPR_contextLET
);
11429 /* Fall through. */
11430 case FFEINFO_basictypeREAL
:
11431 case FFEINFO_basictypeCOMPLEX
:
11432 if (ffe_is_pedantic ())
11437 /* Fall through. */
11438 case FFEINFO_basictypeHOLLERITH
:
11439 case FFEINFO_basictypeTYPELESS
:
11441 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeINTEGER
,
11442 FFEINFO_kindtypeINTEGERDEFAULT
, 0, FFETARGET_charactersizeNONE
,
11443 FFEEXPR_contextLET
);
11446 case FFEINFO_basictypeINTEGER
:
11447 /* Specifically, allow INTEGER(KIND=2), aka INTEGER*8, through
11448 unmolested. Leave it to downstream to handle kinds. */
11455 break; /* expr==NULL ok for substring; element case
11456 caught by callback. */
11458 case FFEEXPR_contextRETURN
:
11459 if ((error
= (expr
!= NULL
) && (ffeinfo_rank (info
) != 0)))
11461 switch ((expr
== NULL
) ? FFEINFO_basictypeNONE
11462 : ffeinfo_basictype (info
))
11464 case FFEINFO_basictypeNONE
:
11468 case FFEINFO_basictypeLOGICAL
:
11469 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeLOGICAL
,
11470 FFEINFO_kindtypeLOGICALDEFAULT
, 0, FFETARGET_charactersizeNONE
,
11471 FFEEXPR_contextLET
);
11472 /* Fall through. */
11473 case FFEINFO_basictypeREAL
:
11474 case FFEINFO_basictypeCOMPLEX
:
11475 if (ffe_is_pedantic ())
11480 /* Fall through. */
11481 case FFEINFO_basictypeINTEGER
:
11482 case FFEINFO_basictypeHOLLERITH
:
11483 case FFEINFO_basictypeTYPELESS
:
11485 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeINTEGER
,
11486 FFEINFO_kindtypeINTEGERDEFAULT
, 0, FFETARGET_charactersizeNONE
,
11487 FFEEXPR_contextLET
);
11496 case FFEEXPR_contextDO
:
11497 if ((error
= (expr
== NULL
) || (ffeinfo_rank (info
) != 0)))
11499 switch (ffeinfo_basictype (info
))
11501 case FFEINFO_basictypeLOGICAL
:
11502 error
= !ffe_is_ugly_logint ();
11503 if (!ffeexpr_stack_
->is_rhs
)
11504 break; /* Don't convert lhs variable. */
11505 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeINTEGER
,
11506 ffeinfo_kindtype (ffebld_info (expr
)), 0,
11507 FFETARGET_charactersizeNONE
,
11508 FFEEXPR_contextLET
);
11511 case FFEINFO_basictypeHOLLERITH
:
11512 case FFEINFO_basictypeTYPELESS
:
11513 if (!ffeexpr_stack_
->is_rhs
)
11516 break; /* Don't convert lhs variable. */
11520 case FFEINFO_basictypeINTEGER
:
11521 case FFEINFO_basictypeREAL
:
11528 if (!ffeexpr_stack_
->is_rhs
11529 && (ffebld_op (expr
) != FFEBLD_opSYMTER
))
11533 case FFEEXPR_contextDOWHILE
:
11534 case FFEEXPR_contextIF
:
11535 if ((error
= (expr
== NULL
) || (ffeinfo_rank (info
) != 0)))
11537 switch (ffeinfo_basictype (info
))
11539 case FFEINFO_basictypeINTEGER
:
11541 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeINTEGER
,
11542 FFEINFO_kindtypeINTEGERDEFAULT
, 0, FFETARGET_charactersizeNONE
,
11543 FFEEXPR_contextLET
);
11544 /* Fall through. */
11545 case FFEINFO_basictypeLOGICAL
:
11546 case FFEINFO_basictypeHOLLERITH
:
11547 case FFEINFO_basictypeTYPELESS
:
11549 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeLOGICAL
,
11550 FFEINFO_kindtypeLOGICALDEFAULT
, 0, FFETARGET_charactersizeNONE
,
11551 FFEEXPR_contextLET
);
11560 case FFEEXPR_contextASSIGN
:
11561 case FFEEXPR_contextAGOTO
:
11562 switch ((expr
== NULL
) ? FFEINFO_basictypeNONE
11563 : ffeinfo_basictype (info
))
11565 case FFEINFO_basictypeINTEGER
:
11566 error
= (ffeinfo_kindtype (info
) != ffecom_label_kind ());
11569 case FFEINFO_basictypeLOGICAL
:
11570 error
= !ffe_is_ugly_logint ()
11571 || (ffeinfo_kindtype (info
) != ffecom_label_kind ());
11578 if ((expr
== NULL
) || (ffeinfo_rank (info
) != 0)
11579 || (ffebld_op (expr
) != FFEBLD_opSYMTER
))
11583 case FFEEXPR_contextCGOTO
:
11584 case FFEEXPR_contextFORMAT
:
11585 case FFEEXPR_contextDIMLIST
:
11586 case FFEEXPR_contextFILENUM
: /* See equiv code in _ambig_. */
11587 if ((error
= (expr
== NULL
) || (ffeinfo_rank (info
) != 0)))
11589 switch (ffeinfo_basictype (info
))
11591 case FFEINFO_basictypeLOGICAL
:
11592 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeLOGICAL
,
11593 FFEINFO_kindtypeLOGICALDEFAULT
, 0, FFETARGET_charactersizeNONE
,
11594 FFEEXPR_contextLET
);
11595 /* Fall through. */
11596 case FFEINFO_basictypeREAL
:
11597 case FFEINFO_basictypeCOMPLEX
:
11598 if (ffe_is_pedantic ())
11603 /* Fall through. */
11604 case FFEINFO_basictypeINTEGER
:
11605 case FFEINFO_basictypeHOLLERITH
:
11606 case FFEINFO_basictypeTYPELESS
:
11608 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeINTEGER
,
11609 FFEINFO_kindtypeINTEGERDEFAULT
, 0, FFETARGET_charactersizeNONE
,
11610 FFEEXPR_contextLET
);
11619 case FFEEXPR_contextARITHIF
:
11620 if ((error
= (expr
== NULL
) || (ffeinfo_rank (info
) != 0)))
11622 switch (ffeinfo_basictype (info
))
11624 case FFEINFO_basictypeLOGICAL
:
11625 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeLOGICAL
,
11626 FFEINFO_kindtypeLOGICALDEFAULT
, 0, FFETARGET_charactersizeNONE
,
11627 FFEEXPR_contextLET
);
11628 if (ffe_is_pedantic ())
11633 /* Fall through. */
11634 case FFEINFO_basictypeHOLLERITH
:
11635 case FFEINFO_basictypeTYPELESS
:
11636 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeINTEGER
,
11637 FFEINFO_kindtypeINTEGERDEFAULT
, 0, FFETARGET_charactersizeNONE
,
11638 FFEEXPR_contextLET
);
11639 /* Fall through. */
11640 case FFEINFO_basictypeINTEGER
:
11641 case FFEINFO_basictypeREAL
:
11651 case FFEEXPR_contextSTOP
:
11652 if ((error
= (expr
!= NULL
) && (ffeinfo_rank (info
) != 0)))
11654 switch ((expr
== NULL
) ? FFEINFO_basictypeNONE
11655 : ffeinfo_basictype (info
))
11657 case FFEINFO_basictypeINTEGER
:
11658 error
= (ffeinfo_kindtype (info
) != FFEINFO_kindtypeINTEGERDEFAULT
);
11661 case FFEINFO_basictypeCHARACTER
:
11662 error
= (ffeinfo_kindtype (info
) != FFEINFO_kindtypeCHARACTERDEFAULT
);
11665 case FFEINFO_basictypeHOLLERITH
:
11666 case FFEINFO_basictypeTYPELESS
:
11668 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeINTEGER
,
11669 FFEINFO_kindtypeINTEGERDEFAULT
, 0, FFETARGET_charactersizeNONE
,
11670 FFEEXPR_contextLET
);
11673 case FFEINFO_basictypeNONE
:
11681 if ((expr
!= NULL
) && ((ffebld_op (expr
) != FFEBLD_opCONTER
)
11682 || (ffebld_conter_orig (expr
) != NULL
)))
11686 case FFEEXPR_contextINCLUDE
:
11687 error
= (expr
== NULL
) || (ffeinfo_rank (info
) != 0)
11688 || (ffeinfo_basictype (info
) != FFEINFO_basictypeCHARACTER
)
11689 || (ffebld_op (expr
) != FFEBLD_opCONTER
)
11690 || (ffebld_conter_orig (expr
) != NULL
);
11693 case FFEEXPR_contextSELECTCASE
:
11694 if ((error
= (expr
== NULL
) || (ffeinfo_rank (info
) != 0)))
11696 switch (ffeinfo_basictype (info
))
11698 case FFEINFO_basictypeINTEGER
:
11699 case FFEINFO_basictypeCHARACTER
:
11700 case FFEINFO_basictypeLOGICAL
:
11704 case FFEINFO_basictypeHOLLERITH
:
11705 case FFEINFO_basictypeTYPELESS
:
11707 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeINTEGER
,
11708 FFEINFO_kindtypeINTEGERDEFAULT
, 0, FFETARGET_charactersizeNONE
,
11709 FFEEXPR_contextLET
);
11718 case FFEEXPR_contextCASE
:
11719 if ((error
= (expr
!= NULL
) && (ffeinfo_rank (info
) != 0)))
11721 switch ((expr
== NULL
) ? FFEINFO_basictypeINTEGER
11722 : ffeinfo_basictype (info
))
11724 case FFEINFO_basictypeINTEGER
:
11725 case FFEINFO_basictypeCHARACTER
:
11726 case FFEINFO_basictypeLOGICAL
:
11730 case FFEINFO_basictypeHOLLERITH
:
11731 case FFEINFO_basictypeTYPELESS
:
11733 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeINTEGER
,
11734 FFEINFO_kindtypeINTEGERDEFAULT
, 0, FFETARGET_charactersizeNONE
,
11735 FFEEXPR_contextLET
);
11742 if ((expr
!= NULL
) && (ffebld_op (expr
) != FFEBLD_opCONTER
))
11746 case FFEEXPR_contextCHARACTERSIZE
:
11747 case FFEEXPR_contextKINDTYPE
:
11748 case FFEEXPR_contextDIMLISTCOMMON
:
11749 if ((error
= (expr
!= NULL
) && (ffeinfo_rank (info
) != 0)))
11751 switch ((expr
== NULL
) ? FFEINFO_basictypeNONE
11752 : ffeinfo_basictype (info
))
11754 case FFEINFO_basictypeLOGICAL
:
11755 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeLOGICAL
,
11756 FFEINFO_kindtypeLOGICALDEFAULT
, 0, FFETARGET_charactersizeNONE
,
11757 FFEEXPR_contextLET
);
11758 /* Fall through. */
11759 case FFEINFO_basictypeREAL
:
11760 case FFEINFO_basictypeCOMPLEX
:
11761 if (ffe_is_pedantic ())
11766 /* Fall through. */
11767 case FFEINFO_basictypeINTEGER
:
11768 case FFEINFO_basictypeHOLLERITH
:
11769 case FFEINFO_basictypeTYPELESS
:
11771 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeINTEGER
,
11772 FFEINFO_kindtypeINTEGERDEFAULT
, 0, FFETARGET_charactersizeNONE
,
11773 FFEEXPR_contextLET
);
11780 if ((expr
!= NULL
) && (ffebld_op (expr
) != FFEBLD_opCONTER
))
11784 case FFEEXPR_contextEQVINDEX_
:
11785 if ((error
= (expr
!= NULL
) && (ffeinfo_rank (info
) != 0)))
11787 switch ((expr
== NULL
) ? FFEINFO_basictypeNONE
11788 : ffeinfo_basictype (info
))
11790 case FFEINFO_basictypeNONE
:
11794 case FFEINFO_basictypeLOGICAL
:
11795 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeLOGICAL
,
11796 FFEINFO_kindtypeLOGICALDEFAULT
, 0, FFETARGET_charactersizeNONE
,
11797 FFEEXPR_contextLET
);
11798 /* Fall through. */
11799 case FFEINFO_basictypeREAL
:
11800 case FFEINFO_basictypeCOMPLEX
:
11801 if (ffe_is_pedantic ())
11806 /* Fall through. */
11807 case FFEINFO_basictypeINTEGER
:
11808 case FFEINFO_basictypeHOLLERITH
:
11809 case FFEINFO_basictypeTYPELESS
:
11811 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeINTEGER
,
11812 FFEINFO_kindtypeINTEGERDEFAULT
, 0, FFETARGET_charactersizeNONE
,
11813 FFEEXPR_contextLET
);
11820 if ((expr
!= NULL
) && (ffebld_op (expr
) != FFEBLD_opCONTER
))
11824 case FFEEXPR_contextPARAMETER
:
11825 if (ffeexpr_stack_
->is_rhs
)
11826 error
= (expr
== NULL
) || (ffeinfo_rank (info
) != 0)
11827 || (ffebld_op (expr
) != FFEBLD_opCONTER
);
11829 error
= (expr
== NULL
) || (ffeinfo_rank (info
) != 0)
11830 || (ffebld_op (expr
) != FFEBLD_opSYMTER
);
11833 case FFEEXPR_contextINDEXORACTUALARG_
:
11834 if (ffelex_token_type (t
) == FFELEX_typeCOLON
)
11835 ffeexpr_stack_
->context
= FFEEXPR_contextINDEX_
;
11837 ffeexpr_stack_
->context
= FFEEXPR_contextACTUALARG_
;
11838 goto again
; /* :::::::::::::::::::: */
11840 case FFEEXPR_contextINDEXORACTUALARGEXPR_
:
11841 if (ffelex_token_type (t
) == FFELEX_typeCOLON
)
11842 ffeexpr_stack_
->context
= FFEEXPR_contextINDEX_
;
11844 ffeexpr_stack_
->context
= FFEEXPR_contextACTUALARGEXPR_
;
11845 goto again
; /* :::::::::::::::::::: */
11847 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
:
11848 if (ffelex_token_type (t
) == FFELEX_typeCOLON
)
11849 ffeexpr_stack_
->context
= FFEEXPR_contextSFUNCDEFINDEX_
;
11851 ffeexpr_stack_
->context
= FFEEXPR_contextSFUNCDEFACTUALARG_
;
11852 goto again
; /* :::::::::::::::::::: */
11854 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_
:
11855 if (ffelex_token_type (t
) == FFELEX_typeCOLON
)
11856 ffeexpr_stack_
->context
= FFEEXPR_contextSFUNCDEFINDEX_
;
11858 ffeexpr_stack_
->context
= FFEEXPR_contextSFUNCDEFACTUALARGEXPR_
;
11859 goto again
; /* :::::::::::::::::::: */
11861 case FFEEXPR_contextIMPDOCTRL_
:
11862 if ((error
= (expr
== NULL
) || (ffeinfo_rank (info
) != 0)))
11864 if (!ffeexpr_stack_
->is_rhs
11865 && (ffebld_op (expr
) != FFEBLD_opSYMTER
))
11867 switch (ffeinfo_basictype (info
))
11869 case FFEINFO_basictypeLOGICAL
:
11870 if (! ffe_is_ugly_logint ())
11872 if (! ffeexpr_stack_
->is_rhs
)
11874 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeINTEGER
,
11875 ffeinfo_kindtype (info
), 0,
11876 FFETARGET_charactersizeNONE
,
11877 FFEEXPR_contextLET
);
11880 case FFEINFO_basictypeINTEGER
:
11881 case FFEINFO_basictypeHOLLERITH
:
11882 case FFEINFO_basictypeTYPELESS
:
11885 case FFEINFO_basictypeREAL
:
11886 if (!ffeexpr_stack_
->is_rhs
11887 && ffe_is_warn_surprising ()
11890 ffebad_start (FFEBAD_DO_REAL
); /* See error message!!! */
11891 ffebad_here (0, ffelex_token_where_line (ft
),
11892 ffelex_token_where_column (ft
));
11893 ffebad_string (ffelex_token_text (ft
));
11904 case FFEEXPR_contextDATAIMPDOCTRL_
:
11905 if ((error
= (expr
== NULL
) || (ffeinfo_rank (info
) != 0)))
11907 if (ffeexpr_stack_
->is_rhs
)
11909 if ((ffebld_op (expr
) != FFEBLD_opCONTER
)
11910 && (ffeinfo_where (info
) != FFEINFO_whereIMMEDIATE
))
11913 else if ((ffebld_op (expr
) != FFEBLD_opSYMTER
)
11914 || (ffeinfo_where (info
) != FFEINFO_whereIMMEDIATE
))
11916 switch (ffeinfo_basictype (info
))
11918 case FFEINFO_basictypeLOGICAL
:
11919 if (! ffeexpr_stack_
->is_rhs
)
11921 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeINTEGER
,
11922 ffeinfo_kindtype (info
), 0,
11923 FFETARGET_charactersizeNONE
,
11924 FFEEXPR_contextLET
);
11925 /* Fall through. */
11926 case FFEINFO_basictypeINTEGER
:
11927 if (ffeexpr_stack_
->is_rhs
11928 && (ffeinfo_kindtype (ffebld_info (expr
))
11929 != FFEINFO_kindtypeINTEGERDEFAULT
))
11930 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeINTEGER
,
11931 FFEINFO_kindtypeINTEGERDEFAULT
, 0,
11932 FFETARGET_charactersizeNONE
,
11933 FFEEXPR_contextLET
);
11936 case FFEINFO_basictypeHOLLERITH
:
11937 case FFEINFO_basictypeTYPELESS
:
11938 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeINTEGER
,
11939 FFEINFO_kindtypeINTEGERDEFAULT
, 0, FFETARGET_charactersizeNONE
,
11940 FFEEXPR_contextLET
);
11943 case FFEINFO_basictypeREAL
:
11944 if (!ffeexpr_stack_
->is_rhs
11945 && ffe_is_warn_surprising ()
11948 ffebad_start (FFEBAD_DO_REAL
); /* See error message!!! */
11949 ffebad_here (0, ffelex_token_where_line (ft
),
11950 ffelex_token_where_column (ft
));
11951 ffebad_string (ffelex_token_text (ft
));
11962 case FFEEXPR_contextIMPDOITEM_
:
11963 if (ffelex_token_type (t
) == FFELEX_typeEQUALS
)
11965 ffeexpr_stack_
->is_rhs
= FALSE
;
11966 ffeexpr_stack_
->context
= FFEEXPR_contextIMPDOCTRL_
;
11967 goto again
; /* :::::::::::::::::::: */
11969 /* Fall through. */
11970 case FFEEXPR_contextIOLIST
:
11971 case FFEEXPR_contextFILEVXTCODE
:
11972 switch ((expr
== NULL
) ? FFEINFO_basictypeNONE
11973 : ffeinfo_basictype (info
))
11975 case FFEINFO_basictypeHOLLERITH
:
11976 case FFEINFO_basictypeTYPELESS
:
11977 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeINTEGER
,
11978 FFEINFO_kindtypeINTEGERDEFAULT
, 0, FFETARGET_charactersizeNONE
,
11979 FFEEXPR_contextLET
);
11985 error
= (expr
== NULL
)
11986 || ((ffeinfo_rank (info
) != 0)
11987 && ((ffebld_op (expr
) != FFEBLD_opSYMTER
)
11988 || (ffesymbol_arraysize (ffebld_symter (expr
)) == NULL
)
11989 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr
)))
11990 == FFEBLD_opSTAR
))); /* Bad if null expr, or if
11991 array that is not a SYMTER
11992 (can't happen yet, I
11993 think) or has a NULL or
11994 STAR (assumed) array
11998 case FFEEXPR_contextIMPDOITEMDF_
:
11999 if (ffelex_token_type (t
) == FFELEX_typeEQUALS
)
12001 ffeexpr_stack_
->is_rhs
= FALSE
;
12002 ffeexpr_stack_
->context
= FFEEXPR_contextIMPDOCTRL_
;
12003 goto again
; /* :::::::::::::::::::: */
12005 /* Fall through. */
12006 case FFEEXPR_contextIOLISTDF
:
12007 switch ((expr
== NULL
) ? FFEINFO_basictypeNONE
12008 : ffeinfo_basictype (info
))
12010 case FFEINFO_basictypeHOLLERITH
:
12011 case FFEINFO_basictypeTYPELESS
:
12012 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeINTEGER
,
12013 FFEINFO_kindtypeINTEGERDEFAULT
, 0, FFETARGET_charactersizeNONE
,
12014 FFEEXPR_contextLET
);
12022 || ((ffeinfo_basictype (info
) == FFEINFO_basictypeCHARACTER
)
12023 && (ffeinfo_kindtype (info
) != FFEINFO_kindtypeCHARACTERDEFAULT
))
12024 || ((ffeinfo_rank (info
) != 0)
12025 && ((ffebld_op (expr
) != FFEBLD_opSYMTER
)
12026 || (ffesymbol_arraysize (ffebld_symter (expr
)) == NULL
)
12027 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr
)))
12028 == FFEBLD_opSTAR
))); /* Bad if null expr,
12029 non-default-kindtype
12030 character expr, or if
12031 array that is not a SYMTER
12032 (can't happen yet, I
12033 think) or has a NULL or
12034 STAR (assumed) array
12038 case FFEEXPR_contextDATAIMPDOITEM_
:
12039 error
= (expr
== NULL
)
12040 || (ffebld_op (expr
) != FFEBLD_opARRAYREF
)
12041 || ((ffeinfo_where (info
) != FFEINFO_whereFLEETING_CADDR
)
12042 && (ffeinfo_where (info
) != FFEINFO_whereFLEETING_IADDR
));
12045 case FFEEXPR_contextDATAIMPDOINDEX_
:
12046 if ((error
= (expr
== NULL
) || (ffeinfo_rank (info
) != 0)))
12048 switch (ffeinfo_basictype (info
))
12050 case FFEINFO_basictypeLOGICAL
:
12051 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeLOGICAL
,
12052 FFEINFO_kindtypeLOGICALDEFAULT
, 0, FFETARGET_charactersizeNONE
,
12053 FFEEXPR_contextLET
);
12054 /* Fall through. */
12055 case FFEINFO_basictypeREAL
:
12056 case FFEINFO_basictypeCOMPLEX
:
12057 if (ffe_is_pedantic ())
12062 /* Fall through. */
12063 case FFEINFO_basictypeINTEGER
:
12064 case FFEINFO_basictypeHOLLERITH
:
12065 case FFEINFO_basictypeTYPELESS
:
12067 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeINTEGER
,
12068 FFEINFO_kindtypeINTEGERDEFAULT
, 0, FFETARGET_charactersizeNONE
,
12069 FFEEXPR_contextLET
);
12076 if ((ffeinfo_where (info
) != FFEINFO_whereCONSTANT
)
12077 && (ffeinfo_where (info
) != FFEINFO_whereIMMEDIATE
))
12081 case FFEEXPR_contextDATA
:
12084 else if (ffeexpr_stack_
->is_rhs
)
12085 error
= (ffebld_op (expr
) != FFEBLD_opCONTER
);
12086 else if (ffebld_op (expr
) == FFEBLD_opSYMTER
)
12089 error
= (ffeinfo_where (info
) != FFEINFO_whereFLEETING_CADDR
);
12092 case FFEEXPR_contextINITVAL
:
12093 error
= (expr
== NULL
) || (ffebld_op (expr
) != FFEBLD_opCONTER
);
12096 case FFEEXPR_contextEQUIVALENCE
:
12099 else if (ffebld_op (expr
) == FFEBLD_opSYMTER
)
12102 error
= (ffeinfo_where (info
) != FFEINFO_whereFLEETING_CADDR
);
12105 case FFEEXPR_contextFILEASSOC
:
12106 case FFEEXPR_contextFILEINT
:
12107 switch ((expr
== NULL
) ? FFEINFO_basictypeNONE
12108 : ffeinfo_basictype (info
))
12110 case FFEINFO_basictypeINTEGER
:
12111 /* Maybe this should be supported someday, but, right now,
12112 g77 can't generate a call to libf2c to write to an
12113 integer other than the default size. */
12114 error
= ((! ffeexpr_stack_
->is_rhs
)
12115 && ffeinfo_kindtype (info
) != FFEINFO_kindtypeINTEGERDEFAULT
);
12122 if ((expr
== NULL
) || (ffeinfo_rank (info
) != 0))
12126 case FFEEXPR_contextFILEDFINT
:
12127 switch ((expr
== NULL
) ? FFEINFO_basictypeNONE
12128 : ffeinfo_basictype (info
))
12130 case FFEINFO_basictypeINTEGER
:
12131 error
= (ffeinfo_kindtype (info
) != FFEINFO_kindtypeINTEGERDEFAULT
);
12138 if ((expr
== NULL
) || (ffeinfo_rank (info
) != 0))
12142 case FFEEXPR_contextFILELOG
:
12143 switch ((expr
== NULL
) ? FFEINFO_basictypeNONE
12144 : ffeinfo_basictype (info
))
12146 case FFEINFO_basictypeLOGICAL
:
12154 if ((expr
== NULL
) || (ffeinfo_rank (info
) != 0))
12158 case FFEEXPR_contextFILECHAR
:
12159 switch ((expr
== NULL
) ? FFEINFO_basictypeNONE
12160 : ffeinfo_basictype (info
))
12162 case FFEINFO_basictypeCHARACTER
:
12170 if ((expr
== NULL
) || (ffeinfo_rank (info
) != 0))
12174 case FFEEXPR_contextFILENUMCHAR
:
12175 if ((error
= (expr
== NULL
) || (ffeinfo_rank (info
) != 0)))
12177 switch (ffeinfo_basictype (info
))
12179 case FFEINFO_basictypeLOGICAL
:
12180 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeLOGICAL
,
12181 FFEINFO_kindtypeLOGICALDEFAULT
, 0, FFETARGET_charactersizeNONE
,
12182 FFEEXPR_contextLET
);
12183 /* Fall through. */
12184 case FFEINFO_basictypeREAL
:
12185 case FFEINFO_basictypeCOMPLEX
:
12186 if (ffe_is_pedantic ())
12191 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeINTEGER
,
12192 FFEINFO_kindtypeINTEGERDEFAULT
, 0, FFETARGET_charactersizeNONE
,
12193 FFEEXPR_contextLET
);
12196 case FFEINFO_basictypeINTEGER
:
12197 case FFEINFO_basictypeCHARACTER
:
12207 case FFEEXPR_contextFILEDFCHAR
:
12208 if ((error
= (expr
== NULL
) || (ffeinfo_rank (info
) != 0)))
12210 switch (ffeinfo_basictype (info
))
12212 case FFEINFO_basictypeCHARACTER
:
12214 = (ffeinfo_kindtype (info
)
12215 != FFEINFO_kindtypeCHARACTERDEFAULT
);
12222 if (!ffeexpr_stack_
->is_rhs
12223 && (ffebld_op (expr
) == FFEBLD_opSUBSTR
))
12227 case FFEEXPR_contextFILEUNIT
: /* See equiv code in _ambig_. */
12228 switch ((expr
== NULL
) ? FFEINFO_basictypeNONE
12229 : ffeinfo_basictype (info
))
12231 case FFEINFO_basictypeLOGICAL
:
12232 if ((error
= (ffeinfo_rank (info
) != 0)))
12234 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeLOGICAL
,
12235 FFEINFO_kindtypeLOGICALDEFAULT
, 0, FFETARGET_charactersizeNONE
,
12236 FFEEXPR_contextLET
);
12237 /* Fall through. */
12238 case FFEINFO_basictypeREAL
:
12239 case FFEINFO_basictypeCOMPLEX
:
12240 if ((error
= (ffeinfo_rank (info
) != 0)))
12242 if (ffe_is_pedantic ())
12247 /* Fall through. */
12248 case FFEINFO_basictypeINTEGER
:
12249 case FFEINFO_basictypeHOLLERITH
:
12250 case FFEINFO_basictypeTYPELESS
:
12251 if ((error
= (ffeinfo_rank (info
) != 0)))
12253 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeINTEGER
,
12254 FFEINFO_kindtypeINTEGERDEFAULT
, 0, FFETARGET_charactersizeNONE
,
12255 FFEEXPR_contextLET
);
12258 case FFEINFO_basictypeCHARACTER
:
12259 switch (ffebld_op (expr
))
12260 { /* As if _lhs had been called instead of
12262 case FFEBLD_opSYMTER
:
12264 = (ffeinfo_where (ffebld_info (expr
)) == FFEINFO_whereCONSTANT
);
12267 case FFEBLD_opSUBSTR
:
12268 error
= (ffeinfo_where (ffebld_info (expr
))
12269 == FFEINFO_whereCONSTANT_SUBOBJECT
);
12272 case FFEBLD_opARRAYREF
:
12281 && ((ffeinfo_kindtype (info
) != FFEINFO_kindtypeCHARACTERDEFAULT
)
12282 || ((ffeinfo_rank (info
) != 0)
12283 && ((ffebld_op (expr
) != FFEBLD_opSYMTER
)
12284 || (ffesymbol_arraysize (ffebld_symter (expr
)) == NULL
)
12285 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr
)))
12286 == FFEBLD_opSTAR
))))) /* Bad if
12287 non-default-kindtype
12288 character expr, or if
12289 array that is not a SYMTER
12290 (can't happen yet, I
12291 think), or has a NULL or
12292 STAR (assumed) array
12303 case FFEEXPR_contextFILEFORMAT
:
12304 switch ((expr
== NULL
) ? FFEINFO_basictypeNONE
12305 : ffeinfo_basictype (info
))
12307 case FFEINFO_basictypeINTEGER
:
12308 error
= (expr
== NULL
)
12309 || ((ffeinfo_rank (info
) != 0) ?
12310 ffe_is_pedantic () /* F77 C5. */
12311 : (bool) (ffeinfo_kindtype (info
) != ffecom_label_kind ()))
12312 || (ffebld_op (expr
) != FFEBLD_opSYMTER
);
12315 case FFEINFO_basictypeLOGICAL
:
12316 case FFEINFO_basictypeREAL
:
12317 case FFEINFO_basictypeCOMPLEX
:
12318 /* F77 C5 -- must be an array of hollerith. */
12320 = ffe_is_pedantic ()
12321 || (ffeinfo_rank (info
) == 0);
12324 case FFEINFO_basictypeCHARACTER
:
12325 if ((ffeinfo_kindtype (info
) != FFEINFO_kindtypeCHARACTERDEFAULT
)
12326 || ((ffeinfo_rank (info
) != 0)
12327 && ((ffebld_op (expr
) != FFEBLD_opSYMTER
)
12328 || (ffesymbol_arraysize (ffebld_symter (expr
)) == NULL
)
12329 || (ffebld_op (ffesymbol_arraysize (ffebld_symter (expr
)))
12330 == FFEBLD_opSTAR
)))) /* Bad if
12331 non-default-kindtype
12332 character expr, or if
12333 array that is not a SYMTER
12334 (can't happen yet, I
12335 think), or has a NULL or
12336 STAR (assumed) array
12349 case FFEEXPR_contextLOC_
:
12350 /* See also ffeintrin_check_loc_. */
12352 || (ffeinfo_kind (info
) != FFEINFO_kindENTITY
)
12353 || ((ffebld_op (expr
) != FFEBLD_opSYMTER
)
12354 && (ffebld_op (expr
) != FFEBLD_opSUBSTR
)
12355 && (ffebld_op (expr
) != FFEBLD_opARRAYREF
)))
12364 if (error
&& ((expr
== NULL
) || (ffebld_op (expr
) != FFEBLD_opANY
)))
12366 ffebad_start (FFEBAD_EXPR_WRONG
);
12367 ffebad_here (0, ffelex_token_where_line (ft
),
12368 ffelex_token_where_column (ft
));
12370 expr
= ffebld_new_any ();
12371 ffebld_set_info (expr
, ffeinfo_new_any ());
12374 callback
= ffeexpr_stack_
->callback
;
12375 s
= ffeexpr_stack_
->previous
;
12376 malloc_kill_ks (ffe_pool_program_unit (), ffeexpr_stack_
,
12377 sizeof (*ffeexpr_stack_
));
12378 ffeexpr_stack_
= s
;
12379 next
= (ffelexHandler
) (*callback
) (ft
, expr
, t
);
12380 ffelex_token_kill (ft
);
12381 return (ffelexHandler
) next
;
12384 /* ffeexpr_finished_ambig_ -- Check validity of ambiguous unit/form spec
12387 expr = ffeexpr_finished_ambig_(expr);
12389 Replicates a bit of ffeexpr_finished_'s task when in a context
12390 of UNIT or FORMAT. */
12393 ffeexpr_finished_ambig_ (ffelexToken ft
, ffebld expr
)
12395 ffeinfo info
= ffebld_info (expr
);
12398 switch (ffeexpr_stack_
->context
)
12400 case FFEEXPR_contextFILENUMAMBIG
: /* Same as FILENUM in _finished_. */
12401 switch ((expr
== NULL
) ? FFEINFO_basictypeNONE
12402 : ffeinfo_basictype (info
))
12404 case FFEINFO_basictypeLOGICAL
:
12405 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeLOGICAL
,
12406 FFEINFO_kindtypeLOGICALDEFAULT
, 0, FFETARGET_charactersizeNONE
,
12407 FFEEXPR_contextLET
);
12408 /* Fall through. */
12409 case FFEINFO_basictypeREAL
:
12410 case FFEINFO_basictypeCOMPLEX
:
12411 if (ffe_is_pedantic ())
12416 /* Fall through. */
12417 case FFEINFO_basictypeINTEGER
:
12418 case FFEINFO_basictypeHOLLERITH
:
12419 case FFEINFO_basictypeTYPELESS
:
12421 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeINTEGER
,
12422 FFEINFO_kindtypeINTEGERDEFAULT
, 0, FFETARGET_charactersizeNONE
,
12423 FFEEXPR_contextLET
);
12430 if ((expr
== NULL
) || (ffeinfo_rank (info
) != 0))
12434 case FFEEXPR_contextFILEUNITAMBIG
: /* Same as FILEUNIT in _finished_. */
12435 if ((expr
!= NULL
) && (ffebld_op (expr
) == FFEBLD_opSTAR
))
12440 switch ((expr
== NULL
) ? FFEINFO_basictypeNONE
12441 : ffeinfo_basictype (info
))
12443 case FFEINFO_basictypeLOGICAL
:
12444 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeLOGICAL
,
12445 FFEINFO_kindtypeLOGICALDEFAULT
, 0, FFETARGET_charactersizeNONE
,
12446 FFEEXPR_contextLET
);
12447 /* Fall through. */
12448 case FFEINFO_basictypeREAL
:
12449 case FFEINFO_basictypeCOMPLEX
:
12450 if (ffe_is_pedantic ())
12455 /* Fall through. */
12456 case FFEINFO_basictypeINTEGER
:
12457 case FFEINFO_basictypeHOLLERITH
:
12458 case FFEINFO_basictypeTYPELESS
:
12459 error
= (ffeinfo_rank (info
) != 0);
12460 expr
= ffeexpr_convert (expr
, ft
, ft
, FFEINFO_basictypeINTEGER
,
12461 FFEINFO_kindtypeINTEGERDEFAULT
, 0, FFETARGET_charactersizeNONE
,
12462 FFEEXPR_contextLET
);
12465 case FFEINFO_basictypeCHARACTER
:
12466 switch (ffebld_op (expr
))
12467 { /* As if _lhs had been called instead of
12469 case FFEBLD_opSYMTER
:
12471 = (ffeinfo_where (ffebld_info (expr
)) == FFEINFO_whereCONSTANT
);
12474 case FFEBLD_opSUBSTR
:
12475 error
= (ffeinfo_where (ffebld_info (expr
))
12476 == FFEINFO_whereCONSTANT_SUBOBJECT
);
12479 case FFEBLD_opARRAYREF
:
12496 assert ("bad context" == NULL
);
12501 if (error
&& ((expr
== NULL
) || (ffebld_op (expr
) != FFEBLD_opANY
)))
12503 ffebad_start (FFEBAD_EXPR_WRONG
);
12504 ffebad_here (0, ffelex_token_where_line (ft
),
12505 ffelex_token_where_column (ft
));
12507 expr
= ffebld_new_any ();
12508 ffebld_set_info (expr
, ffeinfo_new_any ());
12514 /* ffeexpr_token_lhs_ -- Initial state for lhs expression
12516 Return a pointer to this function to the lexer (ffelex), which will
12517 invoke it for the next token.
12519 Basically a smaller version of _rhs_; keep them both in sync, of course. */
12521 static ffelexHandler
12522 ffeexpr_token_lhs_ (ffelexToken t
)
12525 /* When changing the list of valid initial lhs tokens, check whether to
12526 update a corresponding list in ffeexpr_cb_close_paren_ambig_1_ for the
12527 READ (expr) <token> case -- it assumes it knows which tokens <token> can
12528 be to indicate an lhs (or implied DO), which right now is the set
12531 This comment also appears in ffeexpr_token_first_lhs_. */
12533 switch (ffelex_token_type (t
))
12535 case FFELEX_typeNAME
:
12536 case FFELEX_typeNAMES
:
12537 ffeexpr_tokens_
[0] = ffelex_token_use (t
);
12538 return (ffelexHandler
) ffeexpr_token_name_lhs_
;
12541 return (ffelexHandler
) ffeexpr_finished_ (t
);
12545 /* ffeexpr_token_rhs_ -- Initial state for rhs expression
12547 Return a pointer to this function to the lexer (ffelex), which will
12548 invoke it for the next token.
12550 The initial state and the post-binary-operator state are the same and
12551 both handled here, with the expression stack used to distinguish
12552 between them. Binary operators are invalid here; unary operators,
12553 constants, subexpressions, and name references are valid. */
12555 static ffelexHandler
12556 ffeexpr_token_rhs_ (ffelexToken t
)
12560 switch (ffelex_token_type (t
))
12562 case FFELEX_typeQUOTE
:
12565 ffeexpr_tokens_
[0] = ffelex_token_use (t
);
12566 return (ffelexHandler
) ffeexpr_token_quote_
;
12568 ffeexpr_tokens_
[0] = ffelex_token_use (t
);
12569 ffelex_set_expecting_hollerith (-1, '\"',
12570 ffelex_token_where_line (t
),
12571 ffelex_token_where_column (t
));
12572 /* Don't have to unset this one. */
12573 return (ffelexHandler
) ffeexpr_token_apostrophe_
;
12575 case FFELEX_typeAPOSTROPHE
:
12576 ffeexpr_tokens_
[0] = ffelex_token_use (t
);
12577 ffelex_set_expecting_hollerith (-1, '\'',
12578 ffelex_token_where_line (t
),
12579 ffelex_token_where_column (t
));
12580 /* Don't have to unset this one. */
12581 return (ffelexHandler
) ffeexpr_token_apostrophe_
;
12583 case FFELEX_typePERCENT
:
12584 ffeexpr_tokens_
[0] = ffelex_token_use (t
);
12585 return (ffelexHandler
) ffeexpr_token_percent_
;
12587 case FFELEX_typeOPEN_PAREN
:
12588 ffeexpr_stack_
->tokens
[0] = ffelex_token_use (t
);
12589 return (ffelexHandler
) ffeexpr_rhs (ffeexpr_stack_
->pool
,
12590 FFEEXPR_contextPAREN_
,
12591 ffeexpr_cb_close_paren_c_
);
12593 case FFELEX_typePLUS
:
12594 e
= ffeexpr_expr_new_ ();
12595 e
->type
= FFEEXPR_exprtypeUNARY_
;
12596 e
->token
= ffelex_token_use (t
);
12597 e
->u
.operator.op
= FFEEXPR_operatorADD_
;
12598 e
->u
.operator.prec
= FFEEXPR_operatorprecedenceADD_
;
12599 e
->u
.operator.as
= FFEEXPR_operatorassociativityADD_
;
12600 ffeexpr_exprstack_push_unary_ (e
);
12601 return (ffelexHandler
) ffeexpr_token_rhs_
;
12603 case FFELEX_typeMINUS
:
12604 e
= ffeexpr_expr_new_ ();
12605 e
->type
= FFEEXPR_exprtypeUNARY_
;
12606 e
->token
= ffelex_token_use (t
);
12607 e
->u
.operator.op
= FFEEXPR_operatorSUBTRACT_
;
12608 e
->u
.operator.prec
= FFEEXPR_operatorprecedenceSUBTRACT_
;
12609 e
->u
.operator.as
= FFEEXPR_operatorassociativitySUBTRACT_
;
12610 ffeexpr_exprstack_push_unary_ (e
);
12611 return (ffelexHandler
) ffeexpr_token_rhs_
;
12613 case FFELEX_typePERIOD
:
12614 ffeexpr_tokens_
[0] = ffelex_token_use (t
);
12615 return (ffelexHandler
) ffeexpr_token_period_
;
12617 case FFELEX_typeNUMBER
:
12618 ffeexpr_tokens_
[0] = ffelex_token_use (t
);
12619 ffeexpr_hollerith_count_
= atol (ffelex_token_text (t
));
12620 if (ffeexpr_hollerith_count_
> 0)
12621 ffelex_set_expecting_hollerith (ffeexpr_hollerith_count_
,
12623 ffelex_token_where_line (t
),
12624 ffelex_token_where_column (t
));
12625 return (ffelexHandler
) ffeexpr_token_number_
;
12627 case FFELEX_typeNAME
:
12628 case FFELEX_typeNAMES
:
12629 ffeexpr_tokens_
[0] = ffelex_token_use (t
);
12630 switch (ffeexpr_stack_
->context
)
12632 case FFEEXPR_contextACTUALARG_
:
12633 case FFEEXPR_contextINDEXORACTUALARG_
:
12634 case FFEEXPR_contextSFUNCDEFACTUALARG_
:
12635 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
:
12636 return (ffelexHandler
) ffeexpr_token_name_arg_
;
12639 return (ffelexHandler
) ffeexpr_token_name_rhs_
;
12642 case FFELEX_typeASTERISK
:
12643 case FFELEX_typeSLASH
:
12644 case FFELEX_typePOWER
:
12645 case FFELEX_typeCONCAT
:
12646 case FFELEX_typeREL_EQ
:
12647 case FFELEX_typeREL_NE
:
12648 case FFELEX_typeREL_LE
:
12649 case FFELEX_typeREL_GE
:
12650 if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND
))
12652 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
12655 return (ffelexHandler
) ffeexpr_token_rhs_
;
12658 case FFELEX_typeEQUALS
:
12659 case FFELEX_typePOINTS
:
12660 case FFELEX_typeCLOSE_ANGLE
:
12661 case FFELEX_typeCLOSE_PAREN
:
12662 case FFELEX_typeCOMMA
:
12663 case FFELEX_typeCOLON
:
12664 case FFELEX_typeEOS
:
12665 case FFELEX_typeSEMICOLON
:
12668 return (ffelexHandler
) ffeexpr_finished_ (t
);
12672 /* ffeexpr_token_period_ -- Rhs PERIOD
12674 Return a pointer to this function to the lexer (ffelex), which will
12675 invoke it for the next token.
12677 Handle a period detected at rhs (expecting unary op or operand) state.
12678 Must begin a floating-point value (as in .12) or a dot-dot name, of
12679 which only .NOT., .TRUE., and .FALSE. are truly valid. Other sort-of-
12680 valid names represent binary operators, which are invalid here because
12681 there isn't an operand at the top of the stack. */
12683 static ffelexHandler
12684 ffeexpr_token_period_ (ffelexToken t
)
12686 switch (ffelex_token_type (t
))
12688 case FFELEX_typeNAME
:
12689 case FFELEX_typeNAMES
:
12690 ffeexpr_current_dotdot_
= ffestr_other (t
);
12691 switch (ffeexpr_current_dotdot_
)
12693 case FFESTR_otherNone
:
12694 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD
))
12696 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_
[0]),
12697 ffelex_token_where_column (ffeexpr_tokens_
[0]));
12700 ffelex_token_kill (ffeexpr_tokens_
[0]);
12701 return (ffelexHandler
) ffeexpr_token_rhs_ (t
);
12703 case FFESTR_otherTRUE
:
12704 case FFESTR_otherFALSE
:
12705 case FFESTR_otherNOT
:
12706 ffeexpr_tokens_
[1] = ffelex_token_use (t
);
12707 return (ffelexHandler
) ffeexpr_token_end_period_
;
12710 if (ffest_ffebad_start (FFEBAD_MISSING_FIRST_BINARY_OPERAND
))
12712 ffebad_here (0, ffelex_token_where_line (t
),
12713 ffelex_token_where_column (t
));
12716 ffelex_token_kill (ffeexpr_tokens_
[0]);
12717 return (ffelexHandler
) ffeexpr_token_swallow_period_
;
12719 break; /* Nothing really reaches here. */
12721 case FFELEX_typeNUMBER
:
12722 ffeexpr_tokens_
[1] = ffelex_token_use (t
);
12723 return (ffelexHandler
) ffeexpr_token_real_
;
12726 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD
))
12728 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_
[0]),
12729 ffelex_token_where_column (ffeexpr_tokens_
[0]));
12732 ffelex_token_kill (ffeexpr_tokens_
[0]);
12733 return (ffelexHandler
) ffeexpr_token_rhs_ (t
);
12737 /* ffeexpr_token_end_period_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
12739 Return a pointer to this function to the lexer (ffelex), which will
12740 invoke it for the next token.
12742 Expecting a period to close a .NOT, .TRUE, or .FALSE at rhs (unary op
12743 or operator) state. If period isn't found, issue a diagnostic but
12744 pretend we saw one. ffeexpr_current_dotdot_ must already contained the
12745 dotdot representation of the name in between the two PERIOD tokens. */
12747 static ffelexHandler
12748 ffeexpr_token_end_period_ (ffelexToken t
)
12752 if (ffelex_token_type (t
) != FFELEX_typePERIOD
)
12754 if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD
))
12756 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_
[0]),
12757 ffelex_token_where_column (ffeexpr_tokens_
[0]));
12758 ffebad_here (1, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
12759 ffebad_string (ffelex_token_text (ffeexpr_tokens_
[1]));
12764 ffelex_token_kill (ffeexpr_tokens_
[1]); /* Kill "NOT"/"TRUE"/"FALSE"
12767 e
= ffeexpr_expr_new_ ();
12768 e
->token
= ffeexpr_tokens_
[0];
12770 switch (ffeexpr_current_dotdot_
)
12772 case FFESTR_otherNOT
:
12773 e
->type
= FFEEXPR_exprtypeUNARY_
;
12774 e
->u
.operator.op
= FFEEXPR_operatorNOT_
;
12775 e
->u
.operator.prec
= FFEEXPR_operatorprecedenceNOT_
;
12776 e
->u
.operator.as
= FFEEXPR_operatorassociativityNOT_
;
12777 ffeexpr_exprstack_push_unary_ (e
);
12778 if (ffelex_token_type (t
) != FFELEX_typePERIOD
)
12779 return (ffelexHandler
) ffeexpr_token_rhs_ (t
);
12780 return (ffelexHandler
) ffeexpr_token_rhs_
;
12782 case FFESTR_otherTRUE
:
12783 e
->type
= FFEEXPR_exprtypeOPERAND_
;
12785 = ffebld_new_conter (ffebld_constant_new_logicaldefault (TRUE
));
12786 ffebld_set_info (e
->u
.operand
,
12787 ffeinfo_new (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICALDEFAULT
,
12788 0, FFEINFO_kindENTITY
, FFEINFO_whereCONSTANT
, FFETARGET_charactersizeNONE
));
12789 ffeexpr_exprstack_push_operand_ (e
);
12790 if (ffelex_token_type (t
) != FFELEX_typePERIOD
)
12791 return (ffelexHandler
) ffeexpr_token_binary_ (t
);
12792 return (ffelexHandler
) ffeexpr_token_binary_
;
12794 case FFESTR_otherFALSE
:
12795 e
->type
= FFEEXPR_exprtypeOPERAND_
;
12797 = ffebld_new_conter (ffebld_constant_new_logicaldefault (FALSE
));
12798 ffebld_set_info (e
->u
.operand
,
12799 ffeinfo_new (FFEINFO_basictypeLOGICAL
, FFEINFO_kindtypeLOGICALDEFAULT
,
12800 0, FFEINFO_kindENTITY
, FFEINFO_whereCONSTANT
, FFETARGET_charactersizeNONE
));
12801 ffeexpr_exprstack_push_operand_ (e
);
12802 if (ffelex_token_type (t
) != FFELEX_typePERIOD
)
12803 return (ffelexHandler
) ffeexpr_token_binary_ (t
);
12804 return (ffelexHandler
) ffeexpr_token_binary_
;
12807 assert ("Bad unary dotdot in ffeexpr_current_dotdot_" == NULL
);
12813 /* ffeexpr_token_swallow_period_ -- Rhs PERIOD NAME(not NOT, TRUE, or FALSE)
12815 Return a pointer to this function to the lexer (ffelex), which will
12816 invoke it for the next token.
12818 A diagnostic has already been issued; just swallow a period if there is
12819 one, then continue with ffeexpr_token_rhs_. */
12821 static ffelexHandler
12822 ffeexpr_token_swallow_period_ (ffelexToken t
)
12824 if (ffelex_token_type (t
) != FFELEX_typePERIOD
)
12825 return (ffelexHandler
) ffeexpr_token_rhs_ (t
);
12827 return (ffelexHandler
) ffeexpr_token_rhs_
;
12830 /* ffeexpr_token_real_ -- Rhs PERIOD NUMBER
12832 Return a pointer to this function to the lexer (ffelex), which will
12833 invoke it for the next token.
12835 After a period and a string of digits, check next token for possible
12836 exponent designation (D, E, or Q as first/only character) and continue
12837 real-number handling accordingly. Else form basic real constant, push
12838 onto expression stack, and enter binary state using current token (which,
12839 if it is a name not beginning with D, E, or Q, will certainly result
12840 in an error, but that's not for this routine to deal with). */
12842 static ffelexHandler
12843 ffeexpr_token_real_ (ffelexToken t
)
12848 if (((ffelex_token_type (t
) != FFELEX_typeNAME
)
12849 && (ffelex_token_type (t
) != FFELEX_typeNAMES
))
12850 || !(((ffesrc_char_match_init ((d
= *(p
= ffelex_token_text (t
))),
12852 || ffesrc_char_match_init (d
, 'E', 'e')
12853 || ffesrc_char_match_init (d
, 'Q', 'q')))
12854 && ffeexpr_isdigits_ (++p
)))
12857 /* This code has been removed because it seems inconsistent to
12858 produce a diagnostic in this case, but not all of the other
12859 ones that look for an exponent and cannot recognize one. */
12860 if (((ffelex_token_type (t
) == FFELEX_typeNAME
)
12861 || (ffelex_token_type (t
) == FFELEX_typeNAMES
))
12862 && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT
))
12866 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
12867 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_
[0]),
12868 ffelex_token_where_column (ffeexpr_tokens_
[0]));
12871 ffebad_string (bad
);
12875 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL
,
12876 ffeexpr_tokens_
[0], ffeexpr_tokens_
[1],
12879 ffelex_token_kill (ffeexpr_tokens_
[0]);
12880 ffelex_token_kill (ffeexpr_tokens_
[1]);
12881 return (ffelexHandler
) ffeexpr_token_binary_ (t
);
12884 /* Just exponent character by itself? In which case, PLUS or MINUS must
12885 surely be next, followed by a NUMBER token. */
12889 ffeexpr_tokens_
[2] = ffelex_token_use (t
);
12890 return (ffelexHandler
) ffeexpr_token_real_exponent_
;
12893 ffeexpr_make_float_const_ (d
, NULL
, ffeexpr_tokens_
[0], ffeexpr_tokens_
[1],
12896 ffelex_token_kill (ffeexpr_tokens_
[0]);
12897 ffelex_token_kill (ffeexpr_tokens_
[1]);
12898 return (ffelexHandler
) ffeexpr_token_binary_
;
12901 /* ffeexpr_token_real_exponent_ -- Rhs PERIOD NUMBER NAME(D, E, or Q)
12903 Return a pointer to this function to the lexer (ffelex), which will
12904 invoke it for the next token.
12906 Ensures this token is PLUS or MINUS, preserves it, goes to final state
12907 for real number (exponent digits). Else issues diagnostic, assumes a
12908 zero exponent field for number, passes token on to binary state as if
12909 previous token had been "E0" instead of "E", for example. */
12911 static ffelexHandler
12912 ffeexpr_token_real_exponent_ (ffelexToken t
)
12914 if ((ffelex_token_type (t
) != FFELEX_typePLUS
)
12915 && (ffelex_token_type (t
) != FFELEX_typeMINUS
))
12917 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE
))
12919 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_
[2]),
12920 ffelex_token_where_column (ffeexpr_tokens_
[2]));
12921 ffebad_here (1, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
12925 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL
,
12926 ffeexpr_tokens_
[0], ffeexpr_tokens_
[1],
12929 ffelex_token_kill (ffeexpr_tokens_
[0]);
12930 ffelex_token_kill (ffeexpr_tokens_
[1]);
12931 ffelex_token_kill (ffeexpr_tokens_
[2]);
12932 return (ffelexHandler
) ffeexpr_token_binary_ (t
);
12935 ffeexpr_tokens_
[3] = ffelex_token_use (t
);
12936 return (ffelexHandler
) ffeexpr_token_real_exp_sign_
;
12939 /* ffeexpr_token_real_exp_sign_ -- Rhs PERIOD NUMBER NAME(D,E,Q) PLUS/MINUS
12941 Return a pointer to this function to the lexer (ffelex), which will
12942 invoke it for the next token.
12944 Make sure token is a NUMBER, make a real constant out of all we have and
12945 push it onto the expression stack. Else issue diagnostic and pretend
12946 exponent field was a zero. */
12948 static ffelexHandler
12949 ffeexpr_token_real_exp_sign_ (ffelexToken t
)
12951 if (ffelex_token_type (t
) != FFELEX_typeNUMBER
)
12953 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE
))
12955 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_
[2]),
12956 ffelex_token_where_column (ffeexpr_tokens_
[2]));
12957 ffebad_here (1, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
12961 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'), NULL
,
12962 ffeexpr_tokens_
[0], ffeexpr_tokens_
[1],
12965 ffelex_token_kill (ffeexpr_tokens_
[0]);
12966 ffelex_token_kill (ffeexpr_tokens_
[1]);
12967 ffelex_token_kill (ffeexpr_tokens_
[2]);
12968 ffelex_token_kill (ffeexpr_tokens_
[3]);
12969 return (ffelexHandler
) ffeexpr_token_binary_ (t
);
12972 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_
[2])[0], NULL
,
12973 ffeexpr_tokens_
[0], ffeexpr_tokens_
[1], ffeexpr_tokens_
[2],
12974 ffeexpr_tokens_
[3], t
);
12976 ffelex_token_kill (ffeexpr_tokens_
[0]);
12977 ffelex_token_kill (ffeexpr_tokens_
[1]);
12978 ffelex_token_kill (ffeexpr_tokens_
[2]);
12979 ffelex_token_kill (ffeexpr_tokens_
[3]);
12980 return (ffelexHandler
) ffeexpr_token_binary_
;
12983 /* ffeexpr_token_number_ -- Rhs NUMBER
12985 Return a pointer to this function to the lexer (ffelex), which will
12986 invoke it for the next token.
12988 If the token is a period, we may have a floating-point number, or an
12989 integer followed by a dotdot binary operator. If the token is a name
12990 beginning with D, E, or Q, we definitely have a floating-point number.
12991 If the token is a hollerith constant, that's what we've got, so push
12992 it onto the expression stack and continue with the binary state.
12994 Otherwise, we have an integer followed by something the binary state
12995 should be able to swallow. */
12997 static ffelexHandler
12998 ffeexpr_token_number_ (ffelexToken t
)
13005 if (ffeexpr_hollerith_count_
> 0)
13006 ffelex_set_expecting_hollerith (0, '\0',
13007 ffewhere_line_unknown (),
13008 ffewhere_column_unknown ());
13010 /* See if we've got a floating-point number here. */
13012 switch (ffelex_token_type (t
))
13014 case FFELEX_typeNAME
:
13015 case FFELEX_typeNAMES
:
13016 if ((ffesrc_char_match_init ((d
= *(p
= ffelex_token_text (t
))),
13018 || ffesrc_char_match_init (d
, 'E', 'e')
13019 || ffesrc_char_match_init (d
, 'Q', 'q'))
13020 && ffeexpr_isdigits_ (++p
))
13023 /* Just exponent character by itself? In which case, PLUS or MINUS
13024 must surely be next, followed by a NUMBER token. */
13028 ffeexpr_tokens_
[1] = ffelex_token_use (t
);
13029 return (ffelexHandler
) ffeexpr_token_number_exponent_
;
13031 ffeexpr_make_float_const_ (d
, ffeexpr_tokens_
[0], NULL
, NULL
, t
,
13034 ffelex_token_kill (ffeexpr_tokens_
[0]);
13035 return (ffelexHandler
) ffeexpr_token_binary_
;
13039 case FFELEX_typePERIOD
:
13040 ffeexpr_tokens_
[1] = ffelex_token_use (t
);
13041 return (ffelexHandler
) ffeexpr_token_number_period_
;
13043 case FFELEX_typeHOLLERITH
:
13044 e
= ffeexpr_expr_new_ ();
13045 e
->type
= FFEEXPR_exprtypeOPERAND_
;
13046 e
->token
= ffeexpr_tokens_
[0];
13047 e
->u
.operand
= ffebld_new_conter (ffebld_constant_new_hollerith (t
));
13048 ni
= ffeinfo_new (FFEINFO_basictypeHOLLERITH
, FFEINFO_kindtypeNONE
,
13049 0, FFEINFO_kindENTITY
, FFEINFO_whereCONSTANT
,
13050 ffelex_token_length (t
));
13051 ffebld_set_info (e
->u
.operand
, ni
);
13052 ffeexpr_exprstack_push_operand_ (e
);
13053 return (ffelexHandler
) ffeexpr_token_binary_
;
13059 /* Nothing specific we were looking for, so make an integer and pass the
13060 current token to the binary state. */
13062 ffeexpr_make_float_const_ ('I', ffeexpr_tokens_
[0], NULL
, NULL
,
13064 return (ffelexHandler
) ffeexpr_token_binary_ (t
);
13067 /* ffeexpr_token_number_exponent_ -- Rhs NUMBER NAME(D, E, or Q)
13069 Return a pointer to this function to the lexer (ffelex), which will
13070 invoke it for the next token.
13072 Ensures this token is PLUS or MINUS, preserves it, goes to final state
13073 for real number (exponent digits). Else treats number as integer, passes
13074 name to binary, passes current token to subsequent handler. */
13076 static ffelexHandler
13077 ffeexpr_token_number_exponent_ (ffelexToken t
)
13079 if ((ffelex_token_type (t
) != FFELEX_typePLUS
)
13080 && (ffelex_token_type (t
) != FFELEX_typeMINUS
))
13083 ffelexHandler nexthandler
;
13085 e
= ffeexpr_expr_new_ ();
13086 e
->type
= FFEEXPR_exprtypeOPERAND_
;
13087 e
->token
= ffeexpr_tokens_
[0];
13088 e
->u
.operand
= ffebld_new_conter (ffebld_constant_new_integerdefault
13089 (ffeexpr_tokens_
[0]));
13090 ffebld_set_info (e
->u
.operand
,
13091 ffeinfo_new (FFEINFO_basictypeINTEGER
, FFEINFO_kindtypeINTEGERDEFAULT
,
13092 0, FFEINFO_kindENTITY
, FFEINFO_whereCONSTANT
, FFETARGET_charactersizeNONE
));
13093 ffeexpr_exprstack_push_operand_ (e
);
13094 nexthandler
= (ffelexHandler
) ffeexpr_token_binary_ (ffeexpr_tokens_
[1]);
13095 ffelex_token_kill (ffeexpr_tokens_
[1]);
13096 return (ffelexHandler
) (*nexthandler
) (t
);
13099 ffeexpr_tokens_
[2] = ffelex_token_use (t
);
13100 return (ffelexHandler
) ffeexpr_token_number_exp_sign_
;
13103 /* ffeexpr_token_number_exp_sign_ -- Rhs NUMBER NAME(D,E,Q) PLUS/MINUS
13105 Return a pointer to this function to the lexer (ffelex), which will
13106 invoke it for the next token.
13108 Make sure token is a NUMBER, make a real constant out of all we have and
13109 push it onto the expression stack. Else issue diagnostic and pretend
13110 exponent field was a zero. */
13112 static ffelexHandler
13113 ffeexpr_token_number_exp_sign_ (ffelexToken t
)
13115 if (ffelex_token_type (t
) != FFELEX_typeNUMBER
)
13117 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE
))
13119 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_
[1]),
13120 ffelex_token_where_column (ffeexpr_tokens_
[1]));
13121 ffebad_here (1, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
13125 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_
[1])[0],
13126 ffeexpr_tokens_
[0], NULL
, NULL
,
13127 ffeexpr_tokens_
[1], ffeexpr_tokens_
[2],
13130 ffelex_token_kill (ffeexpr_tokens_
[0]);
13131 ffelex_token_kill (ffeexpr_tokens_
[1]);
13132 ffelex_token_kill (ffeexpr_tokens_
[2]);
13133 return (ffelexHandler
) ffeexpr_token_binary_ (t
);
13136 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_
[1])[0],
13137 ffeexpr_tokens_
[0], NULL
, NULL
,
13138 ffeexpr_tokens_
[1], ffeexpr_tokens_
[2], t
);
13140 ffelex_token_kill (ffeexpr_tokens_
[0]);
13141 ffelex_token_kill (ffeexpr_tokens_
[1]);
13142 ffelex_token_kill (ffeexpr_tokens_
[2]);
13143 return (ffelexHandler
) ffeexpr_token_binary_
;
13146 /* ffeexpr_token_number_period_ -- Rhs NUMBER PERIOD
13148 Return a pointer to this function to the lexer (ffelex), which will
13149 invoke it for the next token.
13151 Handle a period detected following a number at rhs state. Must begin a
13152 floating-point value (as in 1., 1.2, 1.E3, or 1.E+3) or a dot-dot name. */
13154 static ffelexHandler
13155 ffeexpr_token_number_period_ (ffelexToken t
)
13158 ffelexHandler nexthandler
;
13162 switch (ffelex_token_type (t
))
13164 case FFELEX_typeNAME
:
13165 case FFELEX_typeNAMES
:
13166 if ((ffesrc_char_match_init ((d
= *(p
= ffelex_token_text (t
))),
13168 || ffesrc_char_match_init (d
, 'E', 'e')
13169 || ffesrc_char_match_init (d
, 'Q', 'q'))
13170 && ffeexpr_isdigits_ (++p
))
13173 /* Just exponent character by itself? In which case, PLUS or MINUS
13174 must surely be next, followed by a NUMBER token. */
13178 ffeexpr_tokens_
[2] = ffelex_token_use (t
);
13179 return (ffelexHandler
) ffeexpr_token_number_per_exp_
;
13181 ffeexpr_make_float_const_ (d
, ffeexpr_tokens_
[0],
13182 ffeexpr_tokens_
[1], NULL
, t
, NULL
,
13185 ffelex_token_kill (ffeexpr_tokens_
[0]);
13186 ffelex_token_kill (ffeexpr_tokens_
[1]);
13187 return (ffelexHandler
) ffeexpr_token_binary_
;
13189 /* A name not representing an exponent, so assume it will be something
13190 like EQ, make an integer from the number, pass the period to binary
13191 state and the current token to the resulting state. */
13193 e
= ffeexpr_expr_new_ ();
13194 e
->type
= FFEEXPR_exprtypeOPERAND_
;
13195 e
->token
= ffeexpr_tokens_
[0];
13196 e
->u
.operand
= ffebld_new_conter (ffebld_constant_new_integerdefault
13197 (ffeexpr_tokens_
[0]));
13198 ffebld_set_info (e
->u
.operand
,
13199 ffeinfo_new (FFEINFO_basictypeINTEGER
,
13200 FFEINFO_kindtypeINTEGERDEFAULT
, 0,
13201 FFEINFO_kindENTITY
, FFEINFO_whereCONSTANT
,
13202 FFETARGET_charactersizeNONE
));
13203 ffeexpr_exprstack_push_operand_ (e
);
13204 nexthandler
= (ffelexHandler
) ffeexpr_token_binary_
13205 (ffeexpr_tokens_
[1]);
13206 ffelex_token_kill (ffeexpr_tokens_
[1]);
13207 return (ffelexHandler
) (*nexthandler
) (t
);
13209 case FFELEX_typeNUMBER
:
13210 ffeexpr_tokens_
[2] = ffelex_token_use (t
);
13211 return (ffelexHandler
) ffeexpr_token_number_real_
;
13217 /* Nothing specific we were looking for, so make a real number and pass the
13218 period and then the current token to the binary state. */
13220 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13221 ffeexpr_tokens_
[0], ffeexpr_tokens_
[1],
13222 NULL
, NULL
, NULL
, NULL
);
13224 ffelex_token_kill (ffeexpr_tokens_
[0]);
13225 ffelex_token_kill (ffeexpr_tokens_
[1]);
13226 return (ffelexHandler
) ffeexpr_token_binary_ (t
);
13229 /* ffeexpr_token_number_per_exp_ -- Rhs NUMBER PERIOD NAME(D, E, or Q)
13231 Return a pointer to this function to the lexer (ffelex), which will
13232 invoke it for the next token.
13234 Ensures this token is PLUS or MINUS, preserves it, goes to final state
13235 for real number (exponent digits). Else treats number as real, passes
13236 name to binary, passes current token to subsequent handler. */
13238 static ffelexHandler
13239 ffeexpr_token_number_per_exp_ (ffelexToken t
)
13241 if ((ffelex_token_type (t
) != FFELEX_typePLUS
)
13242 && (ffelex_token_type (t
) != FFELEX_typeMINUS
))
13244 ffelexHandler nexthandler
;
13246 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13247 ffeexpr_tokens_
[0], ffeexpr_tokens_
[1],
13248 NULL
, NULL
, NULL
, NULL
);
13250 ffelex_token_kill (ffeexpr_tokens_
[0]);
13251 ffelex_token_kill (ffeexpr_tokens_
[1]);
13252 nexthandler
= (ffelexHandler
) ffeexpr_token_binary_ (ffeexpr_tokens_
[2]);
13253 ffelex_token_kill (ffeexpr_tokens_
[2]);
13254 return (ffelexHandler
) (*nexthandler
) (t
);
13257 ffeexpr_tokens_
[3] = ffelex_token_use (t
);
13258 return (ffelexHandler
) ffeexpr_token_num_per_exp_sign_
;
13261 /* ffeexpr_token_number_real_ -- Rhs NUMBER PERIOD NUMBER
13263 Return a pointer to this function to the lexer (ffelex), which will
13264 invoke it for the next token.
13266 After a number, period, and number, check next token for possible
13267 exponent designation (D, E, or Q as first/only character) and continue
13268 real-number handling accordingly. Else form basic real constant, push
13269 onto expression stack, and enter binary state using current token (which,
13270 if it is a name not beginning with D, E, or Q, will certainly result
13271 in an error, but that's not for this routine to deal with). */
13273 static ffelexHandler
13274 ffeexpr_token_number_real_ (ffelexToken t
)
13279 if (((ffelex_token_type (t
) != FFELEX_typeNAME
)
13280 && (ffelex_token_type (t
) != FFELEX_typeNAMES
))
13281 || !(((ffesrc_char_match_init ((d
= *(p
= ffelex_token_text (t
))),
13283 || ffesrc_char_match_init (d
, 'E', 'e')
13284 || ffesrc_char_match_init (d
, 'Q', 'q')))
13285 && ffeexpr_isdigits_ (++p
)))
13288 /* This code has been removed because it seems inconsistent to
13289 produce a diagnostic in this case, but not all of the other
13290 ones that look for an exponent and cannot recognize one. */
13291 if (((ffelex_token_type (t
) == FFELEX_typeNAME
)
13292 || (ffelex_token_type (t
) == FFELEX_typeNAMES
))
13293 && ffest_ffebad_start (FFEBAD_INVALID_EXPONENT
))
13297 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
13298 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_
[0]),
13299 ffelex_token_where_column (ffeexpr_tokens_
[0]));
13302 ffebad_string (bad
);
13306 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13307 ffeexpr_tokens_
[0], ffeexpr_tokens_
[1],
13308 ffeexpr_tokens_
[2], NULL
, NULL
, NULL
);
13310 ffelex_token_kill (ffeexpr_tokens_
[0]);
13311 ffelex_token_kill (ffeexpr_tokens_
[1]);
13312 ffelex_token_kill (ffeexpr_tokens_
[2]);
13313 return (ffelexHandler
) ffeexpr_token_binary_ (t
);
13316 /* Just exponent character by itself? In which case, PLUS or MINUS must
13317 surely be next, followed by a NUMBER token. */
13321 ffeexpr_tokens_
[3] = ffelex_token_use (t
);
13322 return (ffelexHandler
) ffeexpr_token_number_real_exp_
;
13325 ffeexpr_make_float_const_ (d
, ffeexpr_tokens_
[0], ffeexpr_tokens_
[1],
13326 ffeexpr_tokens_
[2], t
, NULL
, NULL
);
13328 ffelex_token_kill (ffeexpr_tokens_
[0]);
13329 ffelex_token_kill (ffeexpr_tokens_
[1]);
13330 ffelex_token_kill (ffeexpr_tokens_
[2]);
13331 return (ffelexHandler
) ffeexpr_token_binary_
;
13334 /* ffeexpr_token_num_per_exp_sign_ -- Rhs NUMBER PERIOD NAME(D,E,Q) PLUS/MINUS
13336 Return a pointer to this function to the lexer (ffelex), which will
13337 invoke it for the next token.
13339 Make sure token is a NUMBER, make a real constant out of all we have and
13340 push it onto the expression stack. Else issue diagnostic and pretend
13341 exponent field was a zero. */
13343 static ffelexHandler
13344 ffeexpr_token_num_per_exp_sign_ (ffelexToken t
)
13346 if (ffelex_token_type (t
) != FFELEX_typeNUMBER
)
13348 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE
))
13350 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_
[2]),
13351 ffelex_token_where_column (ffeexpr_tokens_
[2]));
13352 ffebad_here (1, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
13356 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13357 ffeexpr_tokens_
[0], ffeexpr_tokens_
[1],
13358 NULL
, NULL
, NULL
, NULL
);
13360 ffelex_token_kill (ffeexpr_tokens_
[0]);
13361 ffelex_token_kill (ffeexpr_tokens_
[1]);
13362 ffelex_token_kill (ffeexpr_tokens_
[2]);
13363 ffelex_token_kill (ffeexpr_tokens_
[3]);
13364 return (ffelexHandler
) ffeexpr_token_binary_ (t
);
13367 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_
[2])[0],
13368 ffeexpr_tokens_
[0], ffeexpr_tokens_
[1], NULL
,
13369 ffeexpr_tokens_
[2], ffeexpr_tokens_
[3], t
);
13371 ffelex_token_kill (ffeexpr_tokens_
[0]);
13372 ffelex_token_kill (ffeexpr_tokens_
[1]);
13373 ffelex_token_kill (ffeexpr_tokens_
[2]);
13374 ffelex_token_kill (ffeexpr_tokens_
[3]);
13375 return (ffelexHandler
) ffeexpr_token_binary_
;
13378 /* ffeexpr_token_number_real_exp_ -- Rhs NUMBER PERIOD NUMBER NAME(D, E, or Q)
13380 Return a pointer to this function to the lexer (ffelex), which will
13381 invoke it for the next token.
13383 Ensures this token is PLUS or MINUS, preserves it, goes to final state
13384 for real number (exponent digits). Else issues diagnostic, assumes a
13385 zero exponent field for number, passes token on to binary state as if
13386 previous token had been "E0" instead of "E", for example. */
13388 static ffelexHandler
13389 ffeexpr_token_number_real_exp_ (ffelexToken t
)
13391 if ((ffelex_token_type (t
) != FFELEX_typePLUS
)
13392 && (ffelex_token_type (t
) != FFELEX_typeMINUS
))
13394 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE
))
13396 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_
[3]),
13397 ffelex_token_where_column (ffeexpr_tokens_
[3]));
13398 ffebad_here (1, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
13402 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13403 ffeexpr_tokens_
[0], ffeexpr_tokens_
[1],
13404 ffeexpr_tokens_
[2], NULL
, NULL
, NULL
);
13406 ffelex_token_kill (ffeexpr_tokens_
[0]);
13407 ffelex_token_kill (ffeexpr_tokens_
[1]);
13408 ffelex_token_kill (ffeexpr_tokens_
[2]);
13409 ffelex_token_kill (ffeexpr_tokens_
[3]);
13410 return (ffelexHandler
) ffeexpr_token_binary_ (t
);
13413 ffeexpr_tokens_
[4] = ffelex_token_use (t
);
13414 return (ffelexHandler
) ffeexpr_token_num_real_exp_sn_
;
13417 /* ffeexpr_token_num_real_exp_sn_ -- Rhs NUMBER PERIOD NUMBER NAME(D,E,Q)
13420 Return a pointer to this function to the lexer (ffelex), which will
13421 invoke it for the next token.
13423 Make sure token is a NUMBER, make a real constant out of all we have and
13424 push it onto the expression stack. Else issue diagnostic and pretend
13425 exponent field was a zero. */
13427 static ffelexHandler
13428 ffeexpr_token_num_real_exp_sn_ (ffelexToken t
)
13430 if (ffelex_token_type (t
) != FFELEX_typeNUMBER
)
13432 if (ffest_ffebad_start (FFEBAD_MISSING_EXPONENT_VALUE
))
13434 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_
[3]),
13435 ffelex_token_where_column (ffeexpr_tokens_
[3]));
13436 ffebad_here (1, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
13440 ffeexpr_make_float_const_ (ffesrc_char_internal_init ('E', 'e'),
13441 ffeexpr_tokens_
[0], ffeexpr_tokens_
[1],
13442 ffeexpr_tokens_
[2], NULL
, NULL
, NULL
);
13444 ffelex_token_kill (ffeexpr_tokens_
[0]);
13445 ffelex_token_kill (ffeexpr_tokens_
[1]);
13446 ffelex_token_kill (ffeexpr_tokens_
[2]);
13447 ffelex_token_kill (ffeexpr_tokens_
[3]);
13448 ffelex_token_kill (ffeexpr_tokens_
[4]);
13449 return (ffelexHandler
) ffeexpr_token_binary_ (t
);
13452 ffeexpr_make_float_const_ (ffelex_token_text (ffeexpr_tokens_
[3])[0],
13453 ffeexpr_tokens_
[0], ffeexpr_tokens_
[1],
13454 ffeexpr_tokens_
[2], ffeexpr_tokens_
[3],
13455 ffeexpr_tokens_
[4], t
);
13457 ffelex_token_kill (ffeexpr_tokens_
[0]);
13458 ffelex_token_kill (ffeexpr_tokens_
[1]);
13459 ffelex_token_kill (ffeexpr_tokens_
[2]);
13460 ffelex_token_kill (ffeexpr_tokens_
[3]);
13461 ffelex_token_kill (ffeexpr_tokens_
[4]);
13462 return (ffelexHandler
) ffeexpr_token_binary_
;
13465 /* ffeexpr_token_binary_ -- Handle binary operator possibility
13467 Return a pointer to this function to the lexer (ffelex), which will
13468 invoke it for the next token.
13470 The possibility of a binary operator is handled here, meaning the previous
13471 token was an operand. */
13473 static ffelexHandler
13474 ffeexpr_token_binary_ (ffelexToken t
)
13478 if (!ffeexpr_stack_
->is_rhs
)
13479 return (ffelexHandler
) ffeexpr_finished_ (t
); /* For now. */
13481 switch (ffelex_token_type (t
))
13483 case FFELEX_typePLUS
:
13484 e
= ffeexpr_expr_new_ ();
13485 e
->type
= FFEEXPR_exprtypeBINARY_
;
13486 e
->token
= ffelex_token_use (t
);
13487 e
->u
.operator.op
= FFEEXPR_operatorADD_
;
13488 e
->u
.operator.prec
= FFEEXPR_operatorprecedenceADD_
;
13489 e
->u
.operator.as
= FFEEXPR_operatorassociativityADD_
;
13490 ffeexpr_exprstack_push_binary_ (e
);
13491 return (ffelexHandler
) ffeexpr_token_rhs_
;
13493 case FFELEX_typeMINUS
:
13494 e
= ffeexpr_expr_new_ ();
13495 e
->type
= FFEEXPR_exprtypeBINARY_
;
13496 e
->token
= ffelex_token_use (t
);
13497 e
->u
.operator.op
= FFEEXPR_operatorSUBTRACT_
;
13498 e
->u
.operator.prec
= FFEEXPR_operatorprecedenceSUBTRACT_
;
13499 e
->u
.operator.as
= FFEEXPR_operatorassociativitySUBTRACT_
;
13500 ffeexpr_exprstack_push_binary_ (e
);
13501 return (ffelexHandler
) ffeexpr_token_rhs_
;
13503 case FFELEX_typeASTERISK
:
13504 switch (ffeexpr_stack_
->context
)
13506 case FFEEXPR_contextDATA
:
13507 return (ffelexHandler
) ffeexpr_finished_ (t
);
13512 e
= ffeexpr_expr_new_ ();
13513 e
->type
= FFEEXPR_exprtypeBINARY_
;
13514 e
->token
= ffelex_token_use (t
);
13515 e
->u
.operator.op
= FFEEXPR_operatorMULTIPLY_
;
13516 e
->u
.operator.prec
= FFEEXPR_operatorprecedenceMULTIPLY_
;
13517 e
->u
.operator.as
= FFEEXPR_operatorassociativityMULTIPLY_
;
13518 ffeexpr_exprstack_push_binary_ (e
);
13519 return (ffelexHandler
) ffeexpr_token_rhs_
;
13521 case FFELEX_typeSLASH
:
13522 switch (ffeexpr_stack_
->context
)
13524 case FFEEXPR_contextDATA
:
13525 return (ffelexHandler
) ffeexpr_finished_ (t
);
13530 e
= ffeexpr_expr_new_ ();
13531 e
->type
= FFEEXPR_exprtypeBINARY_
;
13532 e
->token
= ffelex_token_use (t
);
13533 e
->u
.operator.op
= FFEEXPR_operatorDIVIDE_
;
13534 e
->u
.operator.prec
= FFEEXPR_operatorprecedenceDIVIDE_
;
13535 e
->u
.operator.as
= FFEEXPR_operatorassociativityDIVIDE_
;
13536 ffeexpr_exprstack_push_binary_ (e
);
13537 return (ffelexHandler
) ffeexpr_token_rhs_
;
13539 case FFELEX_typePOWER
:
13540 e
= ffeexpr_expr_new_ ();
13541 e
->type
= FFEEXPR_exprtypeBINARY_
;
13542 e
->token
= ffelex_token_use (t
);
13543 e
->u
.operator.op
= FFEEXPR_operatorPOWER_
;
13544 e
->u
.operator.prec
= FFEEXPR_operatorprecedencePOWER_
;
13545 e
->u
.operator.as
= FFEEXPR_operatorassociativityPOWER_
;
13546 ffeexpr_exprstack_push_binary_ (e
);
13547 return (ffelexHandler
) ffeexpr_token_rhs_
;
13549 case FFELEX_typeCONCAT
:
13550 e
= ffeexpr_expr_new_ ();
13551 e
->type
= FFEEXPR_exprtypeBINARY_
;
13552 e
->token
= ffelex_token_use (t
);
13553 e
->u
.operator.op
= FFEEXPR_operatorCONCATENATE_
;
13554 e
->u
.operator.prec
= FFEEXPR_operatorprecedenceCONCATENATE_
;
13555 e
->u
.operator.as
= FFEEXPR_operatorassociativityCONCATENATE_
;
13556 ffeexpr_exprstack_push_binary_ (e
);
13557 return (ffelexHandler
) ffeexpr_token_rhs_
;
13559 case FFELEX_typeOPEN_ANGLE
:
13560 switch (ffeexpr_stack_
->context
)
13562 case FFEEXPR_contextFORMAT
:
13563 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN
);
13564 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
13571 e
= ffeexpr_expr_new_ ();
13572 e
->type
= FFEEXPR_exprtypeBINARY_
;
13573 e
->token
= ffelex_token_use (t
);
13574 e
->u
.operator.op
= FFEEXPR_operatorLT_
;
13575 e
->u
.operator.prec
= FFEEXPR_operatorprecedenceLT_
;
13576 e
->u
.operator.as
= FFEEXPR_operatorassociativityLT_
;
13577 ffeexpr_exprstack_push_binary_ (e
);
13578 return (ffelexHandler
) ffeexpr_token_rhs_
;
13580 case FFELEX_typeCLOSE_ANGLE
:
13581 switch (ffeexpr_stack_
->context
)
13583 case FFEEXPR_contextFORMAT
:
13584 return ffeexpr_finished_ (t
);
13589 e
= ffeexpr_expr_new_ ();
13590 e
->type
= FFEEXPR_exprtypeBINARY_
;
13591 e
->token
= ffelex_token_use (t
);
13592 e
->u
.operator.op
= FFEEXPR_operatorGT_
;
13593 e
->u
.operator.prec
= FFEEXPR_operatorprecedenceGT_
;
13594 e
->u
.operator.as
= FFEEXPR_operatorassociativityGT_
;
13595 ffeexpr_exprstack_push_binary_ (e
);
13596 return (ffelexHandler
) ffeexpr_token_rhs_
;
13598 case FFELEX_typeREL_EQ
:
13599 switch (ffeexpr_stack_
->context
)
13601 case FFEEXPR_contextFORMAT
:
13602 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN
);
13603 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
13610 e
= ffeexpr_expr_new_ ();
13611 e
->type
= FFEEXPR_exprtypeBINARY_
;
13612 e
->token
= ffelex_token_use (t
);
13613 e
->u
.operator.op
= FFEEXPR_operatorEQ_
;
13614 e
->u
.operator.prec
= FFEEXPR_operatorprecedenceEQ_
;
13615 e
->u
.operator.as
= FFEEXPR_operatorassociativityEQ_
;
13616 ffeexpr_exprstack_push_binary_ (e
);
13617 return (ffelexHandler
) ffeexpr_token_rhs_
;
13619 case FFELEX_typeREL_NE
:
13620 switch (ffeexpr_stack_
->context
)
13622 case FFEEXPR_contextFORMAT
:
13623 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN
);
13624 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
13631 e
= ffeexpr_expr_new_ ();
13632 e
->type
= FFEEXPR_exprtypeBINARY_
;
13633 e
->token
= ffelex_token_use (t
);
13634 e
->u
.operator.op
= FFEEXPR_operatorNE_
;
13635 e
->u
.operator.prec
= FFEEXPR_operatorprecedenceNE_
;
13636 e
->u
.operator.as
= FFEEXPR_operatorassociativityNE_
;
13637 ffeexpr_exprstack_push_binary_ (e
);
13638 return (ffelexHandler
) ffeexpr_token_rhs_
;
13640 case FFELEX_typeREL_LE
:
13641 switch (ffeexpr_stack_
->context
)
13643 case FFEEXPR_contextFORMAT
:
13644 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN
);
13645 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
13652 e
= ffeexpr_expr_new_ ();
13653 e
->type
= FFEEXPR_exprtypeBINARY_
;
13654 e
->token
= ffelex_token_use (t
);
13655 e
->u
.operator.op
= FFEEXPR_operatorLE_
;
13656 e
->u
.operator.prec
= FFEEXPR_operatorprecedenceLE_
;
13657 e
->u
.operator.as
= FFEEXPR_operatorassociativityLE_
;
13658 ffeexpr_exprstack_push_binary_ (e
);
13659 return (ffelexHandler
) ffeexpr_token_rhs_
;
13661 case FFELEX_typeREL_GE
:
13662 switch (ffeexpr_stack_
->context
)
13664 case FFEEXPR_contextFORMAT
:
13665 ffebad_start (FFEBAD_FORMAT_EXPR_TOKEN
);
13666 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
13673 e
= ffeexpr_expr_new_ ();
13674 e
->type
= FFEEXPR_exprtypeBINARY_
;
13675 e
->token
= ffelex_token_use (t
);
13676 e
->u
.operator.op
= FFEEXPR_operatorGE_
;
13677 e
->u
.operator.prec
= FFEEXPR_operatorprecedenceGE_
;
13678 e
->u
.operator.as
= FFEEXPR_operatorassociativityGE_
;
13679 ffeexpr_exprstack_push_binary_ (e
);
13680 return (ffelexHandler
) ffeexpr_token_rhs_
;
13682 case FFELEX_typePERIOD
:
13683 ffeexpr_tokens_
[0] = ffelex_token_use (t
);
13684 return (ffelexHandler
) ffeexpr_token_binary_period_
;
13687 case FFELEX_typeOPEN_PAREN
:
13688 case FFELEX_typeCLOSE_PAREN
:
13689 case FFELEX_typeEQUALS
:
13690 case FFELEX_typePOINTS
:
13691 case FFELEX_typeCOMMA
:
13692 case FFELEX_typeCOLON
:
13693 case FFELEX_typeEOS
:
13694 case FFELEX_typeSEMICOLON
:
13695 case FFELEX_typeNAME
:
13696 case FFELEX_typeNAMES
:
13699 return (ffelexHandler
) ffeexpr_finished_ (t
);
13703 /* ffeexpr_token_binary_period_ -- Binary PERIOD
13705 Return a pointer to this function to the lexer (ffelex), which will
13706 invoke it for the next token.
13708 Handle a period detected at binary (expecting binary op or end) state.
13709 Must begin a dot-dot name, of which .NOT., .TRUE., and .FALSE. are not
13712 static ffelexHandler
13713 ffeexpr_token_binary_period_ (ffelexToken t
)
13715 ffeexprExpr_ operand
;
13717 switch (ffelex_token_type (t
))
13719 case FFELEX_typeNAME
:
13720 case FFELEX_typeNAMES
:
13721 ffeexpr_current_dotdot_
= ffestr_other (t
);
13722 switch (ffeexpr_current_dotdot_
)
13724 case FFESTR_otherTRUE
:
13725 case FFESTR_otherFALSE
:
13726 case FFESTR_otherNOT
:
13727 if (ffest_ffebad_start (FFEBAD_MISSING_BINARY_OPERATOR
))
13729 operand
= ffeexpr_stack_
->exprstack
;
13730 assert (operand
!= NULL
);
13731 assert (operand
->type
== FFEEXPR_exprtypeOPERAND_
);
13732 ffebad_here (0, ffelex_token_where_line (operand
->token
), ffelex_token_where_column (operand
->token
));
13733 ffebad_here (1, ffelex_token_where_line (t
),
13734 ffelex_token_where_column (t
));
13737 ffelex_token_kill (ffeexpr_tokens_
[0]);
13738 return (ffelexHandler
) ffeexpr_token_binary_sw_per_
;
13741 ffeexpr_tokens_
[1] = ffelex_token_use (t
);
13742 return (ffelexHandler
) ffeexpr_token_binary_end_per_
;
13744 break; /* Nothing really reaches here. */
13747 if (ffest_ffebad_start (FFEBAD_IGNORING_PERIOD
))
13749 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_
[0]),
13750 ffelex_token_where_column (ffeexpr_tokens_
[0]));
13753 ffelex_token_kill (ffeexpr_tokens_
[0]);
13754 return (ffelexHandler
) ffeexpr_token_binary_ (t
);
13758 /* ffeexpr_token_binary_end_per_ -- Binary PERIOD NAME(not NOT, TRUE, or FALSE)
13760 Return a pointer to this function to the lexer (ffelex), which will
13761 invoke it for the next token.
13763 Expecting a period to close a dot-dot at binary (binary op
13764 or operator) state. If period isn't found, issue a diagnostic but
13765 pretend we saw one. ffeexpr_current_dotdot_ must already contained the
13766 dotdot representation of the name in between the two PERIOD tokens. */
13768 static ffelexHandler
13769 ffeexpr_token_binary_end_per_ (ffelexToken t
)
13773 e
= ffeexpr_expr_new_ ();
13774 e
->type
= FFEEXPR_exprtypeBINARY_
;
13775 e
->token
= ffeexpr_tokens_
[0];
13777 switch (ffeexpr_current_dotdot_
)
13779 case FFESTR_otherAND
:
13780 e
->u
.operator.op
= FFEEXPR_operatorAND_
;
13781 e
->u
.operator.prec
= FFEEXPR_operatorprecedenceAND_
;
13782 e
->u
.operator.as
= FFEEXPR_operatorassociativityAND_
;
13785 case FFESTR_otherOR
:
13786 e
->u
.operator.op
= FFEEXPR_operatorOR_
;
13787 e
->u
.operator.prec
= FFEEXPR_operatorprecedenceOR_
;
13788 e
->u
.operator.as
= FFEEXPR_operatorassociativityOR_
;
13791 case FFESTR_otherXOR
:
13792 e
->u
.operator.op
= FFEEXPR_operatorXOR_
;
13793 e
->u
.operator.prec
= FFEEXPR_operatorprecedenceXOR_
;
13794 e
->u
.operator.as
= FFEEXPR_operatorassociativityXOR_
;
13797 case FFESTR_otherEQV
:
13798 e
->u
.operator.op
= FFEEXPR_operatorEQV_
;
13799 e
->u
.operator.prec
= FFEEXPR_operatorprecedenceEQV_
;
13800 e
->u
.operator.as
= FFEEXPR_operatorassociativityEQV_
;
13803 case FFESTR_otherNEQV
:
13804 e
->u
.operator.op
= FFEEXPR_operatorNEQV_
;
13805 e
->u
.operator.prec
= FFEEXPR_operatorprecedenceNEQV_
;
13806 e
->u
.operator.as
= FFEEXPR_operatorassociativityNEQV_
;
13809 case FFESTR_otherLT
:
13810 e
->u
.operator.op
= FFEEXPR_operatorLT_
;
13811 e
->u
.operator.prec
= FFEEXPR_operatorprecedenceLT_
;
13812 e
->u
.operator.as
= FFEEXPR_operatorassociativityLT_
;
13815 case FFESTR_otherLE
:
13816 e
->u
.operator.op
= FFEEXPR_operatorLE_
;
13817 e
->u
.operator.prec
= FFEEXPR_operatorprecedenceLE_
;
13818 e
->u
.operator.as
= FFEEXPR_operatorassociativityLE_
;
13821 case FFESTR_otherEQ
:
13822 e
->u
.operator.op
= FFEEXPR_operatorEQ_
;
13823 e
->u
.operator.prec
= FFEEXPR_operatorprecedenceEQ_
;
13824 e
->u
.operator.as
= FFEEXPR_operatorassociativityEQ_
;
13827 case FFESTR_otherNE
:
13828 e
->u
.operator.op
= FFEEXPR_operatorNE_
;
13829 e
->u
.operator.prec
= FFEEXPR_operatorprecedenceNE_
;
13830 e
->u
.operator.as
= FFEEXPR_operatorassociativityNE_
;
13833 case FFESTR_otherGT
:
13834 e
->u
.operator.op
= FFEEXPR_operatorGT_
;
13835 e
->u
.operator.prec
= FFEEXPR_operatorprecedenceGT_
;
13836 e
->u
.operator.as
= FFEEXPR_operatorassociativityGT_
;
13839 case FFESTR_otherGE
:
13840 e
->u
.operator.op
= FFEEXPR_operatorGE_
;
13841 e
->u
.operator.prec
= FFEEXPR_operatorprecedenceGE_
;
13842 e
->u
.operator.as
= FFEEXPR_operatorassociativityGE_
;
13846 if (ffest_ffebad_start (FFEBAD_INVALID_DOTDOT
))
13848 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_
[0]),
13849 ffelex_token_where_column (ffeexpr_tokens_
[0]));
13850 ffebad_string (ffelex_token_text (ffeexpr_tokens_
[1]));
13853 e
->u
.operator.op
= FFEEXPR_operatorEQ_
;
13854 e
->u
.operator.prec
= FFEEXPR_operatorprecedenceEQ_
;
13855 e
->u
.operator.as
= FFEEXPR_operatorassociativityEQ_
;
13859 ffeexpr_exprstack_push_binary_ (e
);
13861 if (ffelex_token_type (t
) != FFELEX_typePERIOD
)
13863 if (ffest_ffebad_start (FFEBAD_INSERTING_PERIOD
))
13865 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_
[0]),
13866 ffelex_token_where_column (ffeexpr_tokens_
[0]));
13867 ffebad_here (1, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
13868 ffebad_string (ffelex_token_text (ffeexpr_tokens_
[1]));
13871 ffelex_token_kill (ffeexpr_tokens_
[1]); /* Kill dot-dot token. */
13872 return (ffelexHandler
) ffeexpr_token_rhs_ (t
);
13875 ffelex_token_kill (ffeexpr_tokens_
[1]); /* Kill dot-dot token. */
13876 return (ffelexHandler
) ffeexpr_token_rhs_
;
13879 /* ffeexpr_token_binary_sw_per_ -- Rhs PERIOD NAME(NOT, TRUE, or FALSE)
13881 Return a pointer to this function to the lexer (ffelex), which will
13882 invoke it for the next token.
13884 A diagnostic has already been issued; just swallow a period if there is
13885 one, then continue with ffeexpr_token_binary_. */
13887 static ffelexHandler
13888 ffeexpr_token_binary_sw_per_ (ffelexToken t
)
13890 if (ffelex_token_type (t
) != FFELEX_typePERIOD
)
13891 return (ffelexHandler
) ffeexpr_token_binary_ (t
);
13893 return (ffelexHandler
) ffeexpr_token_binary_
;
13896 /* ffeexpr_token_quote_ -- Rhs QUOTE
13898 Return a pointer to this function to the lexer (ffelex), which will
13899 invoke it for the next token.
13901 Expecting a NUMBER that we'll treat as an octal integer. */
13903 static ffelexHandler
13904 ffeexpr_token_quote_ (ffelexToken t
)
13909 if (ffelex_token_type (t
) != FFELEX_typeNUMBER
)
13911 if (ffest_ffebad_start (FFEBAD_QUOTE_MISSES_DIGITS
))
13913 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_
[0]),
13914 ffelex_token_where_column (ffeexpr_tokens_
[0]));
13915 ffebad_here (1, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
13918 ffelex_token_kill (ffeexpr_tokens_
[0]);
13919 return (ffelexHandler
) ffeexpr_token_rhs_ (t
);
13922 /* This is kind of a kludge to prevent any whining about magical numbers
13923 that start out as these octal integers, so "20000000000 (on a 32-bit
13924 2's-complement machine) by itself won't produce an error. */
13926 anyexpr
= ffebld_new_any ();
13927 ffebld_set_info (anyexpr
, ffeinfo_new_any ());
13929 e
= ffeexpr_expr_new_ ();
13930 e
->type
= FFEEXPR_exprtypeOPERAND_
;
13931 e
->token
= ffeexpr_tokens_
[0];
13932 e
->u
.operand
= ffebld_new_conter_with_orig
13933 (ffebld_constant_new_integeroctal (t
), anyexpr
);
13934 ffebld_set_info (e
->u
.operand
, ffeinfo_new (FFEINFO_basictypeINTEGER
,
13935 FFEINFO_kindtypeINTEGERDEFAULT
, 0, FFEINFO_kindENTITY
,
13936 FFEINFO_whereCONSTANT
, FFETARGET_charactersizeNONE
));
13937 ffeexpr_exprstack_push_operand_ (e
);
13938 return (ffelexHandler
) ffeexpr_token_binary_
;
13941 /* ffeexpr_token_apostrophe_ -- Rhs APOSTROPHE
13943 Return a pointer to this function to the lexer (ffelex), which will
13944 invoke it for the next token.
13946 Handle an open-apostrophe, which begins either a character ('char-const'),
13947 typeless octal ('octal-const'O), or typeless hexadecimal ('hex-const'Z or
13948 'hex-const'X) constant. */
13950 static ffelexHandler
13951 ffeexpr_token_apostrophe_ (ffelexToken t
)
13953 assert (ffelex_token_type (t
) == FFELEX_typeCHARACTER
);
13954 if (ffe_is_pedantic_not_90 () && (ffelex_token_length (t
) == 0))
13956 ffebad_start (FFEBAD_NULL_CHAR_CONST
);
13957 ffebad_here (0, ffelex_token_where_line (t
),
13958 ffelex_token_where_column (t
));
13961 ffeexpr_tokens_
[1] = ffelex_token_use (t
);
13962 return (ffelexHandler
) ffeexpr_token_apos_char_
;
13965 /* ffeexpr_token_apos_char_ -- Rhs APOSTROPHE CHARACTER
13967 Return a pointer to this function to the lexer (ffelex), which will
13968 invoke it for the next token.
13970 Close-apostrophe is implicit; if this token is NAME, it is a possible
13971 typeless-constant radix specifier. */
13973 static ffelexHandler
13974 ffeexpr_token_apos_char_ (ffelexToken t
)
13979 ffetargetCharacterSize size
;
13981 if ((ffelex_token_type (t
) == FFELEX_typeNAME
)
13982 || (ffelex_token_type (t
) == FFELEX_typeNAMES
))
13984 if ((ffelex_token_length (t
) == 1)
13985 && (ffesrc_char_match_init ((c
= ffelex_token_text (t
)[0]), 'B',
13987 || ffesrc_char_match_init (c
, 'O', 'o')
13988 || ffesrc_char_match_init (c
, 'X', 'x')
13989 || ffesrc_char_match_init (c
, 'Z', 'z')))
13991 e
= ffeexpr_expr_new_ ();
13992 e
->type
= FFEEXPR_exprtypeOPERAND_
;
13993 e
->token
= ffeexpr_tokens_
[0];
13996 case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b
, no_match
):
13997 e
->u
.operand
= ffebld_new_conter
13998 (ffebld_constant_new_typeless_bv (ffeexpr_tokens_
[1]));
13999 size
= ffetarget_size_typeless_binary (ffeexpr_tokens_
[1]);
14002 case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o
, no_match
):
14003 e
->u
.operand
= ffebld_new_conter
14004 (ffebld_constant_new_typeless_ov (ffeexpr_tokens_
[1]));
14005 size
= ffetarget_size_typeless_octal (ffeexpr_tokens_
[1]);
14008 case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x
, no_match
):
14009 e
->u
.operand
= ffebld_new_conter
14010 (ffebld_constant_new_typeless_hxv (ffeexpr_tokens_
[1]));
14011 size
= ffetarget_size_typeless_hex (ffeexpr_tokens_
[1]);
14014 case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z
, no_match
):
14015 e
->u
.operand
= ffebld_new_conter
14016 (ffebld_constant_new_typeless_hzv (ffeexpr_tokens_
[1]));
14017 size
= ffetarget_size_typeless_hex (ffeexpr_tokens_
[1]);
14021 no_match
: /* :::::::::::::::::::: */
14022 assert ("not BOXZ!" == NULL
);
14026 ffebld_set_info (e
->u
.operand
,
14027 ffeinfo_new (FFEINFO_basictypeTYPELESS
, FFEINFO_kindtypeNONE
,
14028 0, FFEINFO_kindENTITY
, FFEINFO_whereCONSTANT
, size
));
14029 ffeexpr_exprstack_push_operand_ (e
);
14030 ffelex_token_kill (ffeexpr_tokens_
[1]);
14031 return (ffelexHandler
) ffeexpr_token_binary_
;
14034 e
= ffeexpr_expr_new_ ();
14035 e
->type
= FFEEXPR_exprtypeOPERAND_
;
14036 e
->token
= ffeexpr_tokens_
[0];
14037 e
->u
.operand
= ffebld_new_conter (ffebld_constant_new_characterdefault
14038 (ffeexpr_tokens_
[1]));
14039 ni
= ffeinfo_new (FFEINFO_basictypeCHARACTER
, FFEINFO_kindtypeCHARACTERDEFAULT
,
14040 0, FFEINFO_kindENTITY
, FFEINFO_whereCONSTANT
,
14041 ffelex_token_length (ffeexpr_tokens_
[1]));
14042 ffebld_set_info (e
->u
.operand
, ni
);
14043 ffelex_token_kill (ffeexpr_tokens_
[1]);
14044 ffeexpr_exprstack_push_operand_ (e
);
14045 if ((ffelex_token_type (t
) == FFELEX_typeNAME
)
14046 || (ffelex_token_type (t
) == FFELEX_typeNAMES
))
14048 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER
))
14050 ffebad_string (ffelex_token_text (t
));
14051 ffebad_here (0, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
14052 ffebad_here (1, ffelex_token_where_line (ffeexpr_tokens_
[0]),
14053 ffelex_token_where_column (ffeexpr_tokens_
[0]));
14056 e
= ffeexpr_expr_new_ ();
14057 e
->type
= FFEEXPR_exprtypeBINARY_
;
14058 e
->token
= ffelex_token_use (t
);
14059 e
->u
.operator.op
= FFEEXPR_operatorCONCATENATE_
;
14060 e
->u
.operator.prec
= FFEEXPR_operatorprecedenceCONCATENATE_
;
14061 e
->u
.operator.as
= FFEEXPR_operatorassociativityCONCATENATE_
;
14062 ffeexpr_exprstack_push_binary_ (e
);
14063 return (ffelexHandler
) ffeexpr_token_rhs_ (t
);
14065 ffeexpr_is_substr_ok_
= !ffe_is_pedantic_not_90 (); /* Allow "'hello'(3:5)". */
14066 return (ffelexHandler
) ffeexpr_token_substrp_ (t
);
14069 /* ffeexpr_token_name_lhs_ -- Lhs NAME
14071 Return a pointer to this function to the lexer (ffelex), which will
14072 invoke it for the next token.
14074 Handle a name followed by open-paren, period (RECORD.MEMBER), percent
14075 (RECORD%MEMBER), or nothing at all. */
14077 static ffelexHandler
14078 ffeexpr_token_name_lhs_ (ffelexToken t
)
14081 ffeexprParenType_ paren_type
;
14086 switch (ffelex_token_type (t
))
14088 case FFELEX_typeOPEN_PAREN
:
14089 switch (ffeexpr_stack_
->context
)
14091 case FFEEXPR_contextASSIGN
:
14092 case FFEEXPR_contextAGOTO
:
14093 case FFEEXPR_contextFILEUNIT_DF
:
14094 goto just_name
; /* :::::::::::::::::::: */
14099 e
= ffeexpr_expr_new_ ();
14100 e
->type
= FFEEXPR_exprtypeOPERAND_
;
14101 e
->token
= ffelex_token_use (ffeexpr_tokens_
[0]);
14102 s
= ffeexpr_declare_parenthesized_ (ffeexpr_tokens_
[0], FALSE
,
14105 switch (ffesymbol_where (s
))
14107 case FFEINFO_whereLOCAL
:
14108 if (ffeexpr_stack_
->context
== FFEEXPR_contextSUBROUTINEREF
)
14109 ffesymbol_error (s
, ffeexpr_tokens_
[0]); /* Recursion. */
14112 case FFEINFO_whereINTRINSIC
:
14113 case FFEINFO_whereGLOBAL
:
14114 if (ffeexpr_stack_
->context
!= FFEEXPR_contextSUBROUTINEREF
)
14115 ffesymbol_error (s
, ffeexpr_tokens_
[0]); /* Can call intrin. */
14118 case FFEINFO_whereCOMMON
:
14119 case FFEINFO_whereDUMMY
:
14120 case FFEINFO_whereRESULT
:
14123 case FFEINFO_whereNONE
:
14124 case FFEINFO_whereANY
:
14128 ffesymbol_error (s
, ffeexpr_tokens_
[0]);
14132 if (ffesymbol_attrs (s
) & FFESYMBOL_attrsANY
)
14134 e
->u
.operand
= ffebld_new_any ();
14135 ffebld_set_info (e
->u
.operand
, ffeinfo_new_any ());
14139 e
->u
.operand
= ffebld_new_symter (s
,
14140 ffesymbol_generic (s
),
14141 ffesymbol_specific (s
),
14142 ffesymbol_implementation (s
));
14143 ffebld_set_info (e
->u
.operand
, ffesymbol_info (s
));
14145 ffeexpr_exprstack_push_ (e
); /* Not a complete operand yet. */
14146 ffeexpr_stack_
->tokens
[0] = ffeexpr_tokens_
[0];
14147 switch (paren_type
)
14149 case FFEEXPR_parentypeSUBROUTINE_
:
14150 ffebld_init_list (&ffeexpr_stack_
->expr
, &ffeexpr_stack_
->bottom
);
14153 ffeexpr_rhs (ffeexpr_stack_
->pool
,
14154 FFEEXPR_contextACTUALARG_
,
14155 ffeexpr_token_arguments_
);
14157 case FFEEXPR_parentypeARRAY_
:
14158 ffebld_init_list (&ffeexpr_stack_
->expr
, &ffeexpr_stack_
->bottom
);
14159 ffeexpr_stack_
->bound_list
= ffesymbol_dims (s
);
14160 ffeexpr_stack_
->rank
= 0;
14161 ffeexpr_stack_
->constant
= TRUE
;
14162 ffeexpr_stack_
->immediate
= TRUE
;
14163 switch (ffeexpr_stack_
->context
)
14165 case FFEEXPR_contextDATAIMPDOITEM_
:
14168 ffeexpr_rhs (ffeexpr_stack_
->pool
,
14169 FFEEXPR_contextDATAIMPDOINDEX_
,
14170 ffeexpr_token_elements_
);
14172 case FFEEXPR_contextEQUIVALENCE
:
14175 ffeexpr_rhs (ffeexpr_stack_
->pool
,
14176 FFEEXPR_contextEQVINDEX_
,
14177 ffeexpr_token_elements_
);
14182 ffeexpr_rhs (ffeexpr_stack_
->pool
,
14183 FFEEXPR_contextINDEX_
,
14184 ffeexpr_token_elements_
);
14187 case FFEEXPR_parentypeSUBSTRING_
:
14188 e
->u
.operand
= ffeexpr_collapse_symter (e
->u
.operand
,
14189 ffeexpr_tokens_
[0]);
14192 ffeexpr_rhs (ffeexpr_stack_
->pool
,
14193 FFEEXPR_contextINDEX_
,
14194 ffeexpr_token_substring_
);
14196 case FFEEXPR_parentypeEQUIVALENCE_
:
14197 ffebld_init_list (&ffeexpr_stack_
->expr
, &ffeexpr_stack_
->bottom
);
14198 ffeexpr_stack_
->bound_list
= ffesymbol_dims (s
);
14199 ffeexpr_stack_
->rank
= 0;
14200 ffeexpr_stack_
->constant
= TRUE
;
14201 ffeexpr_stack_
->immediate
= TRUE
;
14204 ffeexpr_rhs (ffeexpr_stack_
->pool
,
14205 FFEEXPR_contextEQVINDEX_
,
14206 ffeexpr_token_equivalence_
);
14208 case FFEEXPR_parentypeFUNCTION_
: /* Invalid case. */
14209 case FFEEXPR_parentypeFUNSUBSTR_
: /* Invalid case. */
14210 ffesymbol_error (s
, ffeexpr_tokens_
[0]);
14211 /* Fall through. */
14212 case FFEEXPR_parentypeANY_
:
14213 e
->u
.operand
= ffebld_new_any ();
14214 ffebld_set_info (e
->u
.operand
, ffeinfo_new_any ());
14217 ffeexpr_rhs (ffeexpr_stack_
->pool
,
14218 FFEEXPR_contextACTUALARG_
,
14219 ffeexpr_token_anything_
);
14222 assert ("bad paren type" == NULL
);
14226 case FFELEX_typeEQUALS
: /* As in "VAR=". */
14227 switch (ffeexpr_stack_
->context
)
14229 case FFEEXPR_contextIMPDOITEM_
: /* within
14230 "(,VAR=start,end[,incr])". */
14231 case FFEEXPR_contextIMPDOITEMDF_
:
14232 ffeexpr_stack_
->context
= FFEEXPR_contextIMPDOCTRL_
;
14235 case FFEEXPR_contextDATAIMPDOITEM_
:
14236 ffeexpr_stack_
->context
= FFEEXPR_contextDATAIMPDOCTRL_
;
14245 case FFELEX_typePERIOD
:
14246 case FFELEX_typePERCENT
:
14247 assert ("FOO%, FOO. not yet supported!~~" == NULL
);
14255 just_name
: /* :::::::::::::::::::: */
14256 e
= ffeexpr_expr_new_ ();
14257 e
->type
= FFEEXPR_exprtypeOPERAND_
;
14258 e
->token
= ffeexpr_tokens_
[0];
14259 s
= ffeexpr_declare_unadorned_ (ffeexpr_tokens_
[0],
14260 (ffeexpr_stack_
->context
14261 == FFEEXPR_contextSUBROUTINEREF
));
14263 switch (ffesymbol_where (s
))
14265 case FFEINFO_whereCONSTANT
:
14266 if ((ffeexpr_stack_
->context
!= FFEEXPR_contextPARAMETER
)
14267 || (ffesymbol_kind (s
) != FFEINFO_kindENTITY
))
14268 ffesymbol_error (s
, ffeexpr_tokens_
[0]);
14271 case FFEINFO_whereIMMEDIATE
:
14272 if ((ffeexpr_stack_
->context
!= FFEEXPR_contextDATAIMPDOCTRL_
)
14273 && (ffeexpr_stack_
->context
!= FFEEXPR_contextDATAIMPDOINDEX_
))
14274 ffesymbol_error (s
, ffeexpr_tokens_
[0]);
14277 case FFEINFO_whereLOCAL
:
14278 if (ffeexpr_stack_
->context
== FFEEXPR_contextSUBROUTINEREF
)
14279 ffesymbol_error (s
, ffeexpr_tokens_
[0]); /* Recurse!. */
14282 case FFEINFO_whereINTRINSIC
:
14283 if (ffeexpr_stack_
->context
!= FFEEXPR_contextSUBROUTINEREF
)
14284 ffesymbol_error (s
, ffeexpr_tokens_
[0]); /* Can call intrin. */
14291 if (ffesymbol_attrs (s
) & FFESYMBOL_attrsANY
)
14293 expr
= ffebld_new_any ();
14294 info
= ffeinfo_new_any ();
14295 ffebld_set_info (expr
, info
);
14299 expr
= ffebld_new_symter (s
,
14300 ffesymbol_generic (s
),
14301 ffesymbol_specific (s
),
14302 ffesymbol_implementation (s
));
14303 info
= ffesymbol_info (s
);
14304 ffebld_set_info (expr
, info
);
14305 if (ffesymbol_is_doiter (s
))
14307 ffebad_start (FFEBAD_DOITER
);
14308 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_
[0]),
14309 ffelex_token_where_column (ffeexpr_tokens_
[0]));
14310 ffest_ffebad_here_doiter (1, s
);
14311 ffebad_string (ffesymbol_text (s
));
14314 expr
= ffeexpr_collapse_symter (expr
, ffeexpr_tokens_
[0]);
14317 if (ffeexpr_stack_
->context
== FFEEXPR_contextSUBROUTINEREF
)
14319 if (ffebld_op (expr
) == FFEBLD_opANY
)
14321 expr
= ffebld_new_any ();
14322 ffebld_set_info (expr
, ffeinfo_new_any ());
14326 expr
= ffebld_new_subrref (expr
, NULL
); /* No argument list. */
14327 if (ffesymbol_generic (s
) != FFEINTRIN_genNONE
)
14328 ffeintrin_fulfill_generic (&expr
, &info
, e
->token
);
14329 else if (ffesymbol_specific (s
) != FFEINTRIN_specNONE
)
14330 ffeintrin_fulfill_specific (&expr
, &info
, NULL
, e
->token
);
14332 ffeexpr_fulfill_call_ (&expr
, e
->token
);
14334 if (ffebld_op (expr
) != FFEBLD_opANY
)
14335 ffebld_set_info (expr
,
14336 ffeinfo_new (ffeinfo_basictype (info
),
14337 ffeinfo_kindtype (info
),
14339 FFEINFO_kindENTITY
,
14340 FFEINFO_whereFLEETING
,
14341 ffeinfo_size (info
)));
14343 ffebld_set_info (expr
, ffeinfo_new_any ());
14347 e
->u
.operand
= expr
;
14348 ffeexpr_exprstack_push_operand_ (e
);
14349 return (ffelexHandler
) ffeexpr_finished_ (t
);
14352 /* ffeexpr_token_name_arg_ -- Rhs NAME
14354 Return a pointer to this function to the lexer (ffelex), which will
14355 invoke it for the next token.
14357 Handle first token in an actual-arg (or possible actual-arg) context
14358 being a NAME, and use second token to refine the context. */
14360 static ffelexHandler
14361 ffeexpr_token_name_arg_ (ffelexToken t
)
14363 switch (ffelex_token_type (t
))
14365 case FFELEX_typeCLOSE_PAREN
:
14366 case FFELEX_typeCOMMA
:
14367 switch (ffeexpr_stack_
->context
)
14369 case FFEEXPR_contextINDEXORACTUALARG_
:
14370 ffeexpr_stack_
->context
= FFEEXPR_contextACTUALARG_
;
14373 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
:
14374 ffeexpr_stack_
->context
= FFEEXPR_contextSFUNCDEFACTUALARG_
;
14383 switch (ffeexpr_stack_
->context
)
14385 case FFEEXPR_contextACTUALARG_
:
14386 ffeexpr_stack_
->context
= FFEEXPR_contextACTUALARGEXPR_
;
14389 case FFEEXPR_contextINDEXORACTUALARG_
:
14390 ffeexpr_stack_
->context
= FFEEXPR_contextINDEXORACTUALARGEXPR_
;
14393 case FFEEXPR_contextSFUNCDEFACTUALARG_
:
14394 ffeexpr_stack_
->context
= FFEEXPR_contextSFUNCDEFACTUALARGEXPR_
;
14397 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
:
14398 ffeexpr_stack_
->context
14399 = FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_
;
14403 assert ("bad context in _name_arg_" == NULL
);
14409 return (ffelexHandler
) ffeexpr_token_name_rhs_ (t
);
14412 /* ffeexpr_token_name_rhs_ -- Rhs NAME
14414 Return a pointer to this function to the lexer (ffelex), which will
14415 invoke it for the next token.
14417 Handle a name followed by open-paren, apostrophe (O'octal-const',
14418 Z'hex-const', or X'hex-const'), period (RECORD.MEMBER).
14421 When followed by apostrophe or quote, set lex hexnum flag on so
14422 [0-9] as first char of next token seen as starting a potentially
14425 In case of intrinsic, decorate its SYMTER with the type info for
14426 the specific intrinsic. */
14428 static ffelexHandler
14429 ffeexpr_token_name_rhs_ (ffelexToken t
)
14432 ffeexprParenType_ paren_type
;
14436 switch (ffelex_token_type (t
))
14438 case FFELEX_typeQUOTE
:
14439 case FFELEX_typeAPOSTROPHE
:
14440 ffeexpr_tokens_
[1] = ffelex_token_use (t
);
14441 ffelex_set_hexnum (TRUE
);
14442 return (ffelexHandler
) ffeexpr_token_name_apos_
;
14444 case FFELEX_typeOPEN_PAREN
:
14445 e
= ffeexpr_expr_new_ ();
14446 e
->type
= FFEEXPR_exprtypeOPERAND_
;
14447 e
->token
= ffelex_token_use (ffeexpr_tokens_
[0]);
14448 s
= ffeexpr_declare_parenthesized_ (ffeexpr_tokens_
[0], TRUE
,
14450 if (ffesymbol_attrs (s
) & FFESYMBOL_attrsANY
)
14451 e
->u
.operand
= ffebld_new_any ();
14453 e
->u
.operand
= ffebld_new_symter (s
, ffesymbol_generic (s
),
14454 ffesymbol_specific (s
),
14455 ffesymbol_implementation (s
));
14456 ffeexpr_exprstack_push_ (e
); /* Not a complete operand yet. */
14457 ffeexpr_stack_
->tokens
[0] = ffeexpr_tokens_
[0];
14458 switch (ffeexpr_context_outer_ (ffeexpr_stack_
))
14460 case FFEEXPR_contextSFUNCDEF
:
14461 case FFEEXPR_contextSFUNCDEFINDEX_
:
14462 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_
:
14463 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_
:
14467 case FFEEXPR_contextSFUNCDEFACTUALARG_
:
14468 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
:
14469 assert ("weird context!" == NULL
);
14477 switch (paren_type
)
14479 case FFEEXPR_parentypeFUNCTION_
:
14480 ffebld_set_info (e
->u
.operand
, ffesymbol_info (s
));
14481 ffebld_init_list (&ffeexpr_stack_
->expr
, &ffeexpr_stack_
->bottom
);
14482 if (ffesymbol_where (s
) == FFEINFO_whereCONSTANT
)
14483 { /* A statement function. */
14484 ffeexpr_stack_
->num_args
14485 = ffebld_list_length
14486 (ffeexpr_stack_
->next_dummy
14487 = ffesymbol_dummyargs (s
));
14488 ffeexpr_stack_
->tokens
[1] = NULL
; /* !=NULL when > num_args. */
14490 else if ((ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
)
14491 && !ffe_is_pedantic_not_90 ()
14492 && ((ffesymbol_implementation (s
)
14493 == FFEINTRIN_impICHAR
)
14494 || (ffesymbol_implementation (s
)
14495 == FFEINTRIN_impIACHAR
)
14496 || (ffesymbol_implementation (s
)
14497 == FFEINTRIN_impLEN
)))
14498 { /* Allow arbitrary concatenations. */
14501 ffeexpr_rhs (ffeexpr_stack_
->pool
,
14503 ? FFEEXPR_contextSFUNCDEF
14504 : FFEEXPR_contextLET
,
14505 ffeexpr_token_arguments_
);
14509 ffeexpr_rhs (ffeexpr_stack_
->pool
,
14511 ? FFEEXPR_contextSFUNCDEFACTUALARG_
14512 : FFEEXPR_contextACTUALARG_
,
14513 ffeexpr_token_arguments_
);
14515 case FFEEXPR_parentypeARRAY_
:
14516 ffebld_set_info (e
->u
.operand
,
14517 ffesymbol_info (ffebld_symter (e
->u
.operand
)));
14518 ffebld_init_list (&ffeexpr_stack_
->expr
, &ffeexpr_stack_
->bottom
);
14519 ffeexpr_stack_
->bound_list
= ffesymbol_dims (s
);
14520 ffeexpr_stack_
->rank
= 0;
14521 ffeexpr_stack_
->constant
= TRUE
;
14522 ffeexpr_stack_
->immediate
= TRUE
;
14523 return (ffelexHandler
) ffeexpr_rhs (ffeexpr_stack_
->pool
,
14525 ? FFEEXPR_contextSFUNCDEFINDEX_
14526 : FFEEXPR_contextINDEX_
,
14527 ffeexpr_token_elements_
);
14529 case FFEEXPR_parentypeSUBSTRING_
:
14530 ffebld_set_info (e
->u
.operand
,
14531 ffesymbol_info (ffebld_symter (e
->u
.operand
)));
14532 e
->u
.operand
= ffeexpr_collapse_symter (e
->u
.operand
,
14533 ffeexpr_tokens_
[0]);
14536 ffeexpr_rhs (ffeexpr_stack_
->pool
,
14538 ? FFEEXPR_contextSFUNCDEFINDEX_
14539 : FFEEXPR_contextINDEX_
,
14540 ffeexpr_token_substring_
);
14542 case FFEEXPR_parentypeFUNSUBSTR_
:
14545 ffeexpr_rhs (ffeexpr_stack_
->pool
,
14547 ? FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
14548 : FFEEXPR_contextINDEXORACTUALARG_
,
14549 ffeexpr_token_funsubstr_
);
14551 case FFEEXPR_parentypeANY_
:
14552 ffebld_set_info (e
->u
.operand
, ffesymbol_info (s
));
14555 ffeexpr_rhs (ffeexpr_stack_
->pool
,
14557 ? FFEEXPR_contextSFUNCDEFACTUALARG_
14558 : FFEEXPR_contextACTUALARG_
,
14559 ffeexpr_token_anything_
);
14562 assert ("bad paren type" == NULL
);
14566 case FFELEX_typeEQUALS
: /* As in "VAR=". */
14567 switch (ffeexpr_stack_
->context
)
14569 case FFEEXPR_contextIMPDOITEM_
: /* "(,VAR=start,end[,incr])". */
14570 case FFEEXPR_contextIMPDOITEMDF_
:
14571 ffeexpr_stack_
->is_rhs
= FALSE
; /* Really an lhs construct. */
14572 ffeexpr_stack_
->context
= FFEEXPR_contextIMPDOCTRL_
;
14581 case FFELEX_typePERIOD
:
14582 case FFELEX_typePERCENT
:
14583 ~~Support these two someday
, though
not required
14584 assert ("FOO%, FOO. not yet supported!~~" == NULL
);
14592 switch (ffeexpr_stack_
->context
)
14594 case FFEEXPR_contextINDEXORACTUALARG_
:
14595 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
:
14596 assert ("strange context" == NULL
);
14603 e
= ffeexpr_expr_new_ ();
14604 e
->type
= FFEEXPR_exprtypeOPERAND_
;
14605 e
->token
= ffeexpr_tokens_
[0];
14606 s
= ffeexpr_declare_unadorned_ (ffeexpr_tokens_
[0], FALSE
);
14607 if (ffesymbol_attrs (s
) & FFESYMBOL_attrsANY
)
14609 e
->u
.operand
= ffebld_new_any ();
14610 ffebld_set_info (e
->u
.operand
, ffeinfo_new_any ());
14614 e
->u
.operand
= ffebld_new_symter (s
, FFEINTRIN_genNONE
,
14615 ffesymbol_specific (s
),
14616 ffesymbol_implementation (s
));
14617 if (ffesymbol_specific (s
) == FFEINTRIN_specNONE
)
14618 ffebld_set_info (e
->u
.operand
, ffeinfo_use (ffesymbol_info (s
)));
14620 { /* Decorate the SYMTER with the actual type
14621 of the intrinsic. */
14622 ffebld_set_info (e
->u
.operand
, ffeinfo_new
14623 (ffeintrin_basictype (ffesymbol_specific (s
)),
14624 ffeintrin_kindtype (ffesymbol_specific (s
)),
14626 ffesymbol_kind (s
),
14627 ffesymbol_where (s
),
14628 FFETARGET_charactersizeNONE
));
14630 if (ffesymbol_is_doiter (s
))
14631 ffebld_symter_set_is_doiter (e
->u
.operand
, TRUE
);
14632 e
->u
.operand
= ffeexpr_collapse_symter (e
->u
.operand
,
14633 ffeexpr_tokens_
[0]);
14635 ffeexpr_exprstack_push_operand_ (e
);
14636 return (ffelexHandler
) ffeexpr_token_binary_ (t
);
14639 /* ffeexpr_token_name_apos_ -- Rhs NAME APOSTROPHE
14641 Return a pointer to this function to the lexer (ffelex), which will
14642 invoke it for the next token.
14644 Expecting a NAME token, analyze the previous NAME token to see what kind,
14645 if any, typeless constant we've got.
14648 Expect a NAME instead of CHARACTER in this situation. */
14650 static ffelexHandler
14651 ffeexpr_token_name_apos_ (ffelexToken t
)
14655 ffelex_set_hexnum (FALSE
);
14657 switch (ffelex_token_type (t
))
14659 case FFELEX_typeNAME
:
14660 ffeexpr_tokens_
[2] = ffelex_token_use (t
);
14661 return (ffelexHandler
) ffeexpr_token_name_apos_name_
;
14667 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER
))
14669 ffebad_string (ffelex_token_text (ffeexpr_tokens_
[0]));
14670 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_
[0]),
14671 ffelex_token_where_column (ffeexpr_tokens_
[0]));
14672 ffebad_here (1, ffelex_token_where_line (t
),
14673 ffelex_token_where_column (t
));
14677 ffelex_token_kill (ffeexpr_tokens_
[1]);
14679 e
= ffeexpr_expr_new_ ();
14680 e
->type
= FFEEXPR_exprtypeOPERAND_
;
14681 e
->u
.operand
= ffebld_new_any ();
14682 ffebld_set_info (e
->u
.operand
, ffeinfo_new_any ());
14683 e
->token
= ffeexpr_tokens_
[0];
14684 ffeexpr_exprstack_push_operand_ (e
);
14686 return (ffelexHandler
) ffeexpr_token_binary_ (t
);
14689 /* ffeexpr_token_name_apos_name_ -- Rhs NAME APOSTROPHE NAME
14691 Return a pointer to this function to the lexer (ffelex), which will
14692 invoke it for the next token.
14694 Expecting an APOSTROPHE token, analyze the previous NAME token to see
14695 what kind, if any, typeless constant we've got. */
14697 static ffelexHandler
14698 ffeexpr_token_name_apos_name_ (ffelexToken t
)
14703 e
= ffeexpr_expr_new_ ();
14704 e
->type
= FFEEXPR_exprtypeOPERAND_
;
14705 e
->token
= ffeexpr_tokens_
[0];
14707 if ((ffelex_token_type (t
) == ffelex_token_type (ffeexpr_tokens_
[1]))
14708 && (ffelex_token_length (ffeexpr_tokens_
[0]) == 1)
14709 && (ffesrc_char_match_init ((c
= ffelex_token_text (ffeexpr_tokens_
[0])[0]),
14711 || ffesrc_char_match_init (c
, 'O', 'o')
14712 || ffesrc_char_match_init (c
, 'X', 'x')
14713 || ffesrc_char_match_init (c
, 'Z', 'z')))
14715 ffetargetCharacterSize size
;
14717 if (!ffe_is_typeless_boz ()) {
14721 case FFESRC_CASE_MATCH_INIT ('B', 'b', imatch_b
, no_imatch
):
14722 e
->u
.operand
= ffebld_new_conter (ffebld_constant_new_integerbinary
14723 (ffeexpr_tokens_
[2]));
14726 case FFESRC_CASE_MATCH_INIT ('O', 'o', imatch_o
, no_imatch
):
14727 e
->u
.operand
= ffebld_new_conter (ffebld_constant_new_integeroctal
14728 (ffeexpr_tokens_
[2]));
14731 case FFESRC_CASE_MATCH_INIT ('X', 'x', imatch_x
, no_imatch
):
14732 e
->u
.operand
= ffebld_new_conter (ffebld_constant_new_integerhex
14733 (ffeexpr_tokens_
[2]));
14736 case FFESRC_CASE_MATCH_INIT ('Z', 'z', imatch_z
, no_imatch
):
14737 e
->u
.operand
= ffebld_new_conter (ffebld_constant_new_integerhex
14738 (ffeexpr_tokens_
[2]));
14742 no_imatch
: /* :::::::::::::::::::: */
14743 assert ("not BOXZ!" == NULL
);
14747 ffebld_set_info (e
->u
.operand
,
14748 ffeinfo_new (FFEINFO_basictypeINTEGER
,
14749 FFEINFO_kindtypeINTEGERDEFAULT
, 0,
14750 FFEINFO_kindENTITY
, FFEINFO_whereCONSTANT
,
14751 FFETARGET_charactersizeNONE
));
14752 ffeexpr_exprstack_push_operand_ (e
);
14753 ffelex_token_kill (ffeexpr_tokens_
[1]);
14754 ffelex_token_kill (ffeexpr_tokens_
[2]);
14755 return (ffelexHandler
) ffeexpr_token_binary_
;
14760 case FFESRC_CASE_MATCH_INIT ('B', 'b', match_b
, no_match
):
14761 e
->u
.operand
= ffebld_new_conter (ffebld_constant_new_typeless_bm
14762 (ffeexpr_tokens_
[2]));
14763 size
= ffetarget_size_typeless_binary (ffeexpr_tokens_
[2]);
14766 case FFESRC_CASE_MATCH_INIT ('O', 'o', match_o
, no_match
):
14767 e
->u
.operand
= ffebld_new_conter (ffebld_constant_new_typeless_om
14768 (ffeexpr_tokens_
[2]));
14769 size
= ffetarget_size_typeless_octal (ffeexpr_tokens_
[2]);
14772 case FFESRC_CASE_MATCH_INIT ('X', 'x', match_x
, no_match
):
14773 e
->u
.operand
= ffebld_new_conter (ffebld_constant_new_typeless_hxm
14774 (ffeexpr_tokens_
[2]));
14775 size
= ffetarget_size_typeless_hex (ffeexpr_tokens_
[2]);
14778 case FFESRC_CASE_MATCH_INIT ('Z', 'z', match_z
, no_match
):
14779 e
->u
.operand
= ffebld_new_conter (ffebld_constant_new_typeless_hzm
14780 (ffeexpr_tokens_
[2]));
14781 size
= ffetarget_size_typeless_hex (ffeexpr_tokens_
[2]);
14785 no_match
: /* :::::::::::::::::::: */
14786 assert ("not BOXZ!" == NULL
);
14787 e
->u
.operand
= ffebld_new_conter (ffebld_constant_new_typeless_hzm
14788 (ffeexpr_tokens_
[2]));
14789 size
= ffetarget_size_typeless_hex (ffeexpr_tokens_
[2]);
14792 ffebld_set_info (e
->u
.operand
,
14793 ffeinfo_new (FFEINFO_basictypeTYPELESS
, FFEINFO_kindtypeNONE
,
14794 0, FFEINFO_kindENTITY
, FFEINFO_whereCONSTANT
, size
));
14795 ffeexpr_exprstack_push_operand_ (e
);
14796 ffelex_token_kill (ffeexpr_tokens_
[1]);
14797 ffelex_token_kill (ffeexpr_tokens_
[2]);
14798 return (ffelexHandler
) ffeexpr_token_binary_
;
14801 if (ffest_ffebad_start (FFEBAD_INVALID_RADIX_SPECIFIER
))
14803 ffebad_string (ffelex_token_text (ffeexpr_tokens_
[0]));
14804 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_
[0]),
14805 ffelex_token_where_column (ffeexpr_tokens_
[0]));
14806 ffebad_here (1, ffelex_token_where_line (t
), ffelex_token_where_column (t
));
14810 ffelex_token_kill (ffeexpr_tokens_
[1]);
14811 ffelex_token_kill (ffeexpr_tokens_
[2]);
14813 e
->type
= FFEEXPR_exprtypeOPERAND_
;
14814 e
->u
.operand
= ffebld_new_any ();
14815 ffebld_set_info (e
->u
.operand
, ffeinfo_new_any ());
14816 e
->token
= ffeexpr_tokens_
[0];
14817 ffeexpr_exprstack_push_operand_ (e
);
14819 switch (ffelex_token_type (t
))
14821 case FFELEX_typeAPOSTROPHE
:
14822 case FFELEX_typeQUOTE
:
14823 return (ffelexHandler
) ffeexpr_token_binary_
;
14826 return (ffelexHandler
) ffeexpr_token_binary_ (t
);
14830 /* ffeexpr_token_percent_ -- Rhs PERCENT
14832 Handle a percent sign possibly followed by "LOC". If followed instead
14833 by "VAL", "REF", or "DESCR", issue an error message and substitute
14834 "LOC". If followed by something else, treat the percent sign as a
14835 spurious incorrect token and reprocess the token via _rhs_. */
14837 static ffelexHandler
14838 ffeexpr_token_percent_ (ffelexToken t
)
14840 switch (ffelex_token_type (t
))
14842 case FFELEX_typeNAME
:
14843 case FFELEX_typeNAMES
:
14844 ffeexpr_stack_
->percent
= ffeexpr_percent_ (t
);
14845 ffeexpr_tokens_
[1] = ffelex_token_use (t
);
14846 return (ffelexHandler
) ffeexpr_token_percent_name_
;
14849 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION
))
14851 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_
[0]),
14852 ffelex_token_where_column (ffeexpr_tokens_
[0]));
14853 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_
->first_token
),
14854 ffelex_token_where_column (ffeexpr_stack_
->first_token
));
14857 ffelex_token_kill (ffeexpr_tokens_
[0]);
14858 return (ffelexHandler
) ffeexpr_token_rhs_ (t
);
14862 /* ffeexpr_token_percent_name_ -- Rhs PERCENT NAME
14864 Make sure the token is OPEN_PAREN and prepare for the one-item list of
14865 LHS expressions. Else display an error message. */
14867 static ffelexHandler
14868 ffeexpr_token_percent_name_ (ffelexToken t
)
14870 ffelexHandler nexthandler
;
14872 if (ffelex_token_type (t
) != FFELEX_typeOPEN_PAREN
)
14874 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION
))
14876 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_
[0]),
14877 ffelex_token_where_column (ffeexpr_tokens_
[0]));
14878 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_
->first_token
),
14879 ffelex_token_where_column (ffeexpr_stack_
->first_token
));
14882 ffelex_token_kill (ffeexpr_tokens_
[0]);
14883 nexthandler
= (ffelexHandler
) ffeexpr_token_rhs_ (ffeexpr_tokens_
[1]);
14884 ffelex_token_kill (ffeexpr_tokens_
[1]);
14885 return (ffelexHandler
) (*nexthandler
) (t
);
14888 switch (ffeexpr_stack_
->percent
)
14891 if (ffest_ffebad_start (FFEBAD_INVALID_PERCENT
))
14893 ffebad_here (0, ffelex_token_where_line (ffeexpr_tokens_
[0]),
14894 ffelex_token_where_column (ffeexpr_tokens_
[0]));
14895 ffebad_string (ffelex_token_text (ffeexpr_tokens_
[1]));
14898 ffeexpr_stack_
->percent
= FFEEXPR_percentLOC_
;
14899 /* Fall through. */
14900 case FFEEXPR_percentLOC_
:
14901 ffeexpr_stack_
->tokens
[0] = ffeexpr_tokens_
[0];
14902 ffelex_token_kill (ffeexpr_tokens_
[1]);
14903 ffeexpr_stack_
->tokens
[1] = ffelex_token_use (t
);
14904 return (ffelexHandler
) ffeexpr_rhs (ffeexpr_stack_
->pool
,
14905 FFEEXPR_contextLOC_
,
14906 ffeexpr_cb_end_loc_
);
14910 /* ffeexpr_make_float_const_ -- Make a floating-point constant
14914 Pass 'E', 'D', or 'Q' for exponent letter. */
14917 ffeexpr_make_float_const_ (char exp_letter
, ffelexToken integer
,
14918 ffelexToken decimal
, ffelexToken fraction
,
14919 ffelexToken exponent
, ffelexToken exponent_sign
,
14920 ffelexToken exponent_digits
)
14924 e
= ffeexpr_expr_new_ ();
14925 e
->type
= FFEEXPR_exprtypeOPERAND_
;
14926 if (integer
!= NULL
)
14927 e
->token
= ffelex_token_use (integer
);
14930 assert (decimal
!= NULL
);
14931 e
->token
= ffelex_token_use (decimal
);
14934 switch (exp_letter
)
14936 #if !FFETARGET_okREALQUAD
14937 case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q
, no_match
):
14938 if (ffebad_start (FFEBAD_QUAD_UNSUPPORTED
))
14940 ffebad_here (0, ffelex_token_where_line (e
->token
),
14941 ffelex_token_where_column (e
->token
));
14944 goto match_d
; /* The FFESRC_CASE_* macros don't
14945 allow fall-through! */
14948 case FFESRC_CASE_MATCH_INIT ('D', 'd', match_d
, no_match
):
14949 e
->u
.operand
= ffebld_new_conter (ffebld_constant_new_realdouble
14950 (integer
, decimal
, fraction
, exponent
, exponent_sign
, exponent_digits
));
14951 ffebld_set_info (e
->u
.operand
,
14952 ffeinfo_new (FFEINFO_basictypeREAL
, FFEINFO_kindtypeREALDOUBLE
,
14953 0, FFEINFO_kindENTITY
, FFEINFO_whereCONSTANT
, FFETARGET_charactersizeNONE
));
14956 case FFESRC_CASE_MATCH_INIT ('E', 'e', match_e
, no_match
):
14957 e
->u
.operand
= ffebld_new_conter (ffebld_constant_new_realdefault
14958 (integer
, decimal
, fraction
, exponent
, exponent_sign
, exponent_digits
));
14959 ffebld_set_info (e
->u
.operand
, ffeinfo_new (FFEINFO_basictypeREAL
,
14960 FFEINFO_kindtypeREALDEFAULT
, 0, FFEINFO_kindENTITY
,
14961 FFEINFO_whereCONSTANT
, FFETARGET_charactersizeNONE
));
14964 #if FFETARGET_okREALQUAD
14965 case FFESRC_CASE_MATCH_INIT ('Q', 'q', match_q
, no_match
):
14966 e
->u
.operand
= ffebld_new_conter (ffebld_constant_new_realquad
14967 (integer
, decimal
, fraction
, exponent
, exponent_sign
, exponent_digits
));
14968 ffebld_set_info (e
->u
.operand
,
14969 ffeinfo_new (FFEINFO_basictypeREAL
, FFEINFO_kindtypeREALQUAD
,
14970 0, FFEINFO_kindENTITY
, FFEINFO_whereCONSTANT
, FFETARGET_charactersizeNONE
));
14974 case 'I': /* Make an integer. */
14975 e
->u
.operand
= ffebld_new_conter (ffebld_constant_new_integerdefault
14976 (ffeexpr_tokens_
[0]));
14977 ffebld_set_info (e
->u
.operand
,
14978 ffeinfo_new (FFEINFO_basictypeINTEGER
,
14979 FFEINFO_kindtypeINTEGERDEFAULT
, 0,
14980 FFEINFO_kindENTITY
, FFEINFO_whereCONSTANT
,
14981 FFETARGET_charactersizeNONE
));
14985 no_match
: /* :::::::::::::::::::: */
14986 assert ("Lost the exponent letter!" == NULL
);
14989 ffeexpr_exprstack_push_operand_ (e
);
14992 /* Just like ffesymbol_declare_local, except performs any implicit info
14993 assignment necessary. */
14996 ffeexpr_declare_unadorned_ (ffelexToken t
, bool maybe_intrin
)
15002 s
= ffesymbol_declare_local (t
, maybe_intrin
);
15004 switch (ffeexpr_context_outer_ (ffeexpr_stack_
))
15005 /* Special-case these since they can involve a different concept
15006 of "state" (in the stmtfunc name space). */
15008 case FFEEXPR_contextDATAIMPDOINDEX_
:
15009 case FFEEXPR_contextDATAIMPDOCTRL_
:
15010 if (ffeexpr_context_outer_ (ffeexpr_stack_
)
15011 == FFEEXPR_contextDATAIMPDOINDEX_
)
15012 s
= ffeexpr_sym_impdoitem_ (s
, t
);
15014 if (ffeexpr_stack_
->is_rhs
)
15015 s
= ffeexpr_sym_impdoitem_ (s
, t
);
15017 s
= ffeexpr_sym_lhs_impdoctrl_ (s
, t
);
15018 bad
= (ffesymbol_kind (s
) != FFEINFO_kindENTITY
)
15019 || ((ffesymbol_where (s
) != FFEINFO_whereCONSTANT
)
15020 && (ffesymbol_where (s
) != FFEINFO_whereIMMEDIATE
));
15021 if (bad
&& (ffesymbol_kind (s
) != FFEINFO_kindANY
))
15022 ffesymbol_error (s
, t
);
15029 switch ((ffesymbol_sfdummyparent (s
) == NULL
)
15030 ? ffesymbol_state (s
)
15031 : FFESYMBOL_stateUNDERSTOOD
)
15033 case FFESYMBOL_stateNONE
: /* Before first exec, not seen in expr
15035 if (!ffest_seen_first_exec ())
15036 goto seen
; /* :::::::::::::::::::: */
15037 /* Fall through. */
15038 case FFESYMBOL_stateUNCERTAIN
: /* Unseen since first exec. */
15039 switch (ffeexpr_context_outer_ (ffeexpr_stack_
))
15041 case FFEEXPR_contextSUBROUTINEREF
:
15042 s
= ffeexpr_sym_lhs_call_ (s
, t
);
15045 case FFEEXPR_contextFILEEXTFUNC
:
15046 s
= ffeexpr_sym_lhs_extfunc_ (s
, t
);
15049 case FFEEXPR_contextSFUNCDEFACTUALARG_
:
15050 s
= ffecom_sym_exec_transition (s
);
15051 if (ffesymbol_state (s
) == FFESYMBOL_stateUNDERSTOOD
)
15052 goto understood
; /* :::::::::::::::::::: */
15053 /* Fall through. */
15054 case FFEEXPR_contextACTUALARG_
:
15055 s
= ffeexpr_sym_rhs_actualarg_ (s
, t
);
15058 case FFEEXPR_contextDATA
:
15059 if (ffeexpr_stack_
->is_rhs
)
15060 s
= ffeexpr_sym_rhs_let_ (s
, t
);
15062 s
= ffeexpr_sym_lhs_data_ (s
, t
);
15065 case FFEEXPR_contextDATAIMPDOITEM_
:
15066 s
= ffeexpr_sym_lhs_data_ (s
, t
);
15069 case FFEEXPR_contextSFUNCDEF
:
15070 case FFEEXPR_contextSFUNCDEFINDEX_
:
15071 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_
:
15072 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_
:
15073 s
= ffecom_sym_exec_transition (s
);
15074 if (ffesymbol_state (s
) == FFESYMBOL_stateUNDERSTOOD
)
15075 goto understood
; /* :::::::::::::::::::: */
15076 /* Fall through. */
15077 case FFEEXPR_contextLET
:
15078 case FFEEXPR_contextPAREN_
:
15079 case FFEEXPR_contextACTUALARGEXPR_
:
15080 case FFEEXPR_contextINDEXORACTUALARGEXPR_
:
15081 case FFEEXPR_contextASSIGN
:
15082 case FFEEXPR_contextIOLIST
:
15083 case FFEEXPR_contextIOLISTDF
:
15084 case FFEEXPR_contextDO
:
15085 case FFEEXPR_contextDOWHILE
:
15086 case FFEEXPR_contextAGOTO
:
15087 case FFEEXPR_contextCGOTO
:
15088 case FFEEXPR_contextIF
:
15089 case FFEEXPR_contextARITHIF
:
15090 case FFEEXPR_contextFORMAT
:
15091 case FFEEXPR_contextSTOP
:
15092 case FFEEXPR_contextRETURN
:
15093 case FFEEXPR_contextSELECTCASE
:
15094 case FFEEXPR_contextCASE
:
15095 case FFEEXPR_contextFILEASSOC
:
15096 case FFEEXPR_contextFILEINT
:
15097 case FFEEXPR_contextFILEDFINT
:
15098 case FFEEXPR_contextFILELOG
:
15099 case FFEEXPR_contextFILENUM
:
15100 case FFEEXPR_contextFILENUMAMBIG
:
15101 case FFEEXPR_contextFILECHAR
:
15102 case FFEEXPR_contextFILENUMCHAR
:
15103 case FFEEXPR_contextFILEDFCHAR
:
15104 case FFEEXPR_contextFILEKEY
:
15105 case FFEEXPR_contextFILEUNIT
:
15106 case FFEEXPR_contextFILEUNIT_DF
:
15107 case FFEEXPR_contextFILEUNITAMBIG
:
15108 case FFEEXPR_contextFILEFORMAT
:
15109 case FFEEXPR_contextFILENAMELIST
:
15110 case FFEEXPR_contextFILEVXTCODE
:
15111 case FFEEXPR_contextINDEX_
:
15112 case FFEEXPR_contextIMPDOITEM_
:
15113 case FFEEXPR_contextIMPDOITEMDF_
:
15114 case FFEEXPR_contextIMPDOCTRL_
:
15115 case FFEEXPR_contextLOC_
:
15116 if (ffeexpr_stack_
->is_rhs
)
15117 s
= ffeexpr_sym_rhs_let_ (s
, t
);
15119 s
= ffeexpr_sym_lhs_let_ (s
, t
);
15122 case FFEEXPR_contextCHARACTERSIZE
:
15123 case FFEEXPR_contextEQUIVALENCE
:
15124 case FFEEXPR_contextINCLUDE
:
15125 case FFEEXPR_contextPARAMETER
:
15126 case FFEEXPR_contextDIMLIST
:
15127 case FFEEXPR_contextDIMLISTCOMMON
:
15128 case FFEEXPR_contextKINDTYPE
:
15129 case FFEEXPR_contextINITVAL
:
15130 case FFEEXPR_contextEQVINDEX_
:
15131 break; /* Will turn into errors below. */
15134 ffesymbol_error (s
, t
);
15137 /* Fall through. */
15138 case FFESYMBOL_stateUNDERSTOOD
: /* Nothing much more to learn. */
15139 understood
: /* :::::::::::::::::::: */
15140 k
= ffesymbol_kind (s
);
15141 switch (ffeexpr_context_outer_ (ffeexpr_stack_
))
15143 case FFEEXPR_contextSUBROUTINEREF
:
15144 bad
= ((k
!= FFEINFO_kindSUBROUTINE
)
15145 && ((ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
)
15146 || (k
!= FFEINFO_kindNONE
)));
15149 case FFEEXPR_contextFILEEXTFUNC
:
15150 bad
= (k
!= FFEINFO_kindFUNCTION
)
15151 || (ffesymbol_where (s
) != FFEINFO_whereGLOBAL
);
15154 case FFEEXPR_contextSFUNCDEFACTUALARG_
:
15155 case FFEEXPR_contextACTUALARG_
:
15158 case FFEINFO_kindENTITY
:
15162 case FFEINFO_kindFUNCTION
:
15163 case FFEINFO_kindSUBROUTINE
:
15165 = ((ffesymbol_where (s
) != FFEINFO_whereGLOBAL
)
15166 && (ffesymbol_where (s
) != FFEINFO_whereDUMMY
)
15167 && ((ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
)
15168 || !ffeintrin_is_actualarg (ffesymbol_specific (s
))));
15171 case FFEINFO_kindNONE
:
15172 if (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
)
15174 bad
= !(ffeintrin_is_actualarg (ffesymbol_specific (s
)));
15178 /* If state is UNDERSTOOD here, it's CHAR*(*) or attrsANY,
15179 and in the former case, attrsTYPE is set, so we
15180 see this as an error as we should, since CHAR*(*)
15181 cannot be actually referenced in a main/block data
15184 if ((ffesymbol_attrs (s
) & (FFESYMBOL_attrsANY
15185 | FFESYMBOL_attrsEXTERNAL
15186 | FFESYMBOL_attrsTYPE
))
15187 == FFESYMBOL_attrsEXTERNAL
)
15199 case FFEEXPR_contextDATA
:
15200 if (ffeexpr_stack_
->is_rhs
)
15201 bad
= (k
!= FFEINFO_kindENTITY
)
15202 || (ffesymbol_where (s
) != FFEINFO_whereCONSTANT
);
15204 bad
= (k
!= FFEINFO_kindENTITY
)
15205 || ((ffesymbol_where (s
) != FFEINFO_whereNONE
)
15206 && (ffesymbol_where (s
) != FFEINFO_whereLOCAL
)
15207 && (ffesymbol_where (s
) != FFEINFO_whereCOMMON
));
15210 case FFEEXPR_contextDATAIMPDOITEM_
:
15211 bad
= TRUE
; /* Unadorned item never valid. */
15214 case FFEEXPR_contextSFUNCDEF
:
15215 case FFEEXPR_contextSFUNCDEFINDEX_
:
15216 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_
:
15217 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_
:
15218 case FFEEXPR_contextLET
:
15219 case FFEEXPR_contextPAREN_
:
15220 case FFEEXPR_contextACTUALARGEXPR_
:
15221 case FFEEXPR_contextINDEXORACTUALARGEXPR_
:
15222 case FFEEXPR_contextASSIGN
:
15223 case FFEEXPR_contextIOLIST
:
15224 case FFEEXPR_contextIOLISTDF
:
15225 case FFEEXPR_contextDO
:
15226 case FFEEXPR_contextDOWHILE
:
15227 case FFEEXPR_contextAGOTO
:
15228 case FFEEXPR_contextCGOTO
:
15229 case FFEEXPR_contextIF
:
15230 case FFEEXPR_contextARITHIF
:
15231 case FFEEXPR_contextFORMAT
:
15232 case FFEEXPR_contextSTOP
:
15233 case FFEEXPR_contextRETURN
:
15234 case FFEEXPR_contextSELECTCASE
:
15235 case FFEEXPR_contextCASE
:
15236 case FFEEXPR_contextFILEASSOC
:
15237 case FFEEXPR_contextFILEINT
:
15238 case FFEEXPR_contextFILEDFINT
:
15239 case FFEEXPR_contextFILELOG
:
15240 case FFEEXPR_contextFILENUM
:
15241 case FFEEXPR_contextFILENUMAMBIG
:
15242 case FFEEXPR_contextFILECHAR
:
15243 case FFEEXPR_contextFILENUMCHAR
:
15244 case FFEEXPR_contextFILEDFCHAR
:
15245 case FFEEXPR_contextFILEKEY
:
15246 case FFEEXPR_contextFILEUNIT
:
15247 case FFEEXPR_contextFILEUNIT_DF
:
15248 case FFEEXPR_contextFILEUNITAMBIG
:
15249 case FFEEXPR_contextFILEFORMAT
:
15250 case FFEEXPR_contextFILENAMELIST
:
15251 case FFEEXPR_contextFILEVXTCODE
:
15252 case FFEEXPR_contextINDEX_
:
15253 case FFEEXPR_contextIMPDOITEM_
:
15254 case FFEEXPR_contextIMPDOITEMDF_
:
15255 case FFEEXPR_contextIMPDOCTRL_
:
15256 case FFEEXPR_contextLOC_
:
15257 bad
= (k
!= FFEINFO_kindENTITY
); /* This catches "SUBROUTINE
15258 X(A);EXTERNAL A;CALL
15259 Y(A);B=A", for example. */
15262 case FFEEXPR_contextCHARACTERSIZE
:
15263 case FFEEXPR_contextEQUIVALENCE
:
15264 case FFEEXPR_contextPARAMETER
:
15265 case FFEEXPR_contextDIMLIST
:
15266 case FFEEXPR_contextDIMLISTCOMMON
:
15267 case FFEEXPR_contextKINDTYPE
:
15268 case FFEEXPR_contextINITVAL
:
15269 case FFEEXPR_contextEQVINDEX_
:
15270 bad
= (k
!= FFEINFO_kindENTITY
)
15271 || (ffesymbol_where (s
) != FFEINFO_whereCONSTANT
);
15274 case FFEEXPR_contextINCLUDE
:
15282 if (bad
&& (k
!= FFEINFO_kindANY
))
15283 ffesymbol_error (s
, t
);
15286 case FFESYMBOL_stateSEEN
: /* Seen but not yet in exec portion. */
15287 seen
: /* :::::::::::::::::::: */
15288 switch (ffeexpr_context_outer_ (ffeexpr_stack_
))
15290 case FFEEXPR_contextPARAMETER
:
15291 if (ffeexpr_stack_
->is_rhs
)
15292 ffesymbol_error (s
, t
);
15294 s
= ffeexpr_sym_lhs_parameter_ (s
, t
);
15297 case FFEEXPR_contextDATA
:
15298 s
= ffecom_sym_exec_transition (s
);
15299 if (ffesymbol_state (s
) == FFESYMBOL_stateUNDERSTOOD
)
15300 goto understood
; /* :::::::::::::::::::: */
15301 if (ffeexpr_stack_
->is_rhs
)
15302 ffesymbol_error (s
, t
);
15304 s
= ffeexpr_sym_lhs_data_ (s
, t
);
15305 goto understood
; /* :::::::::::::::::::: */
15307 case FFEEXPR_contextDATAIMPDOITEM_
:
15308 s
= ffecom_sym_exec_transition (s
);
15309 if (ffesymbol_state (s
) == FFESYMBOL_stateUNDERSTOOD
)
15310 goto understood
; /* :::::::::::::::::::: */
15311 s
= ffeexpr_sym_lhs_data_ (s
, t
);
15312 goto understood
; /* :::::::::::::::::::: */
15314 case FFEEXPR_contextEQUIVALENCE
:
15315 s
= ffeexpr_sym_lhs_equivalence_ (s
, t
);
15318 case FFEEXPR_contextDIMLIST
:
15319 s
= ffeexpr_sym_rhs_dimlist_ (s
, t
);
15322 case FFEEXPR_contextCHARACTERSIZE
:
15323 case FFEEXPR_contextKINDTYPE
:
15324 case FFEEXPR_contextDIMLISTCOMMON
:
15325 case FFEEXPR_contextINITVAL
:
15326 case FFEEXPR_contextEQVINDEX_
:
15327 ffesymbol_error (s
, t
);
15330 case FFEEXPR_contextINCLUDE
:
15331 ffesymbol_error (s
, t
);
15334 case FFEEXPR_contextACTUALARG_
: /* E.g. I in REAL A(Y(I)). */
15335 case FFEEXPR_contextSFUNCDEFACTUALARG_
:
15336 s
= ffecom_sym_exec_transition (s
);
15337 if (ffesymbol_state (s
) == FFESYMBOL_stateUNDERSTOOD
)
15338 goto understood
; /* :::::::::::::::::::: */
15339 s
= ffeexpr_sym_rhs_actualarg_ (s
, t
);
15340 goto understood
; /* :::::::::::::::::::: */
15342 case FFEEXPR_contextINDEX_
:
15343 case FFEEXPR_contextACTUALARGEXPR_
:
15344 case FFEEXPR_contextINDEXORACTUALARGEXPR_
:
15345 case FFEEXPR_contextSFUNCDEF
:
15346 case FFEEXPR_contextSFUNCDEFINDEX_
:
15347 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_
:
15348 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_
:
15349 assert (ffeexpr_stack_
->is_rhs
);
15350 s
= ffecom_sym_exec_transition (s
);
15351 if (ffesymbol_state (s
) == FFESYMBOL_stateUNDERSTOOD
)
15352 goto understood
; /* :::::::::::::::::::: */
15353 s
= ffeexpr_sym_rhs_let_ (s
, t
);
15354 goto understood
; /* :::::::::::::::::::: */
15357 ffesymbol_error (s
, t
);
15363 assert ("bad symbol state" == NULL
);
15369 /* Have FOO in DATA (XYZ(FOO),...)/.../ or DATA (...,XYZ=FOO,BAR,BLETCH).
15370 Could be found via the "statement-function" name space (in which case
15371 it should become an iterator) or the local name space (in which case
15372 it should be either a named constant, or a variable that will have an
15373 sfunc name space sibling that should become an iterator). */
15376 ffeexpr_sym_impdoitem_ (ffesymbol sp
, ffelexToken t
)
15384 ffeinfoWhere where
;
15386 ss
= ffesymbol_state (sp
);
15388 if (ffesymbol_sfdummyparent (sp
) != NULL
)
15389 { /* Have symbol in sfunc name space. */
15392 case FFESYMBOL_stateNONE
: /* Used as iterator already. */
15393 if (ffeexpr_level_
< ffesymbol_maxentrynum (sp
))
15394 ffesymbol_error (sp
, t
); /* Can't use dead iterator. */
15396 { /* Can use dead iterator because we're at at
15397 least an innermore (higher-numbered) level
15398 than the iterator's outermost
15399 (lowest-numbered) level. */
15400 ffesymbol_signal_change (sp
);
15401 ffesymbol_set_state (sp
, FFESYMBOL_stateSEEN
);
15402 ffesymbol_set_maxentrynum (sp
, ffeexpr_level_
);
15403 ffesymbol_signal_unreported (sp
);
15407 case FFESYMBOL_stateSEEN
: /* Seen already in this or other
15408 implied-DO. Set symbol level
15409 number to outermost value, as that
15410 tells us we can see it as iterator
15411 at that level at the innermost. */
15412 if (ffeexpr_level_
< ffesymbol_maxentrynum (sp
))
15414 ffesymbol_signal_change (sp
);
15415 ffesymbol_set_maxentrynum (sp
, ffeexpr_level_
);
15416 ffesymbol_signal_unreported (sp
);
15420 case FFESYMBOL_stateUNCERTAIN
: /* Iterator. */
15421 assert (ffeexpr_level_
== ffesymbol_maxentrynum (sp
));
15422 ffesymbol_error (sp
, t
); /* (,,,I=I,10). */
15425 case FFESYMBOL_stateUNDERSTOOD
:
15429 assert ("Foo Bar!!" == NULL
);
15436 /* Got symbol in local name space, so we haven't seen it in impdo yet.
15437 First, if it is brand-new and we're in executable statements, set the
15438 attributes and exec-transition it to set state UNCERTAIN or UNDERSTOOD.
15439 Second, if it is now a constant (PARAMETER), then just return it, it
15440 can't be an implied-do iterator. If it is understood, complain if it is
15441 not a valid variable, but make the inner name space iterator anyway and
15442 return that. If it is not understood, improve understanding of the
15443 symbol accordingly, complain accordingly, in either case make the inner
15444 name space iterator and return that. */
15446 sa
= ffesymbol_attrs (sp
);
15448 if (ffesymbol_state_is_specable (ss
)
15449 && ffest_seen_first_exec ())
15451 assert (sa
== FFESYMBOL_attrsetNONE
);
15452 ffesymbol_signal_change (sp
);
15453 ffesymbol_set_state (sp
, FFESYMBOL_stateSEEN
);
15454 ffesymbol_resolve_intrin (sp
);
15455 if (ffeimplic_establish_symbol (sp
))
15456 ffesymbol_set_attr (sp
, FFESYMBOL_attrSFARG
);
15458 ffesymbol_error (sp
, t
);
15460 /* After the exec transition, the state will either be UNCERTAIN (could
15461 be a dummy or local var) or UNDERSTOOD (local var, because this is a
15462 PROGRAM/BLOCKDATA program unit). */
15464 sp
= ffecom_sym_exec_transition (sp
);
15465 sa
= ffesymbol_attrs (sp
);
15466 ss
= ffesymbol_state (sp
);
15470 kind
= ffesymbol_kind (sp
);
15471 where
= ffesymbol_where (sp
);
15473 if (ss
== FFESYMBOL_stateUNDERSTOOD
)
15475 if (kind
!= FFEINFO_kindENTITY
)
15476 ffesymbol_error (sp
, t
);
15477 if (where
== FFEINFO_whereCONSTANT
)
15482 /* Enhance understanding of local symbol. This used to imply exec
15483 transition, but that doesn't seem necessary, since the local symbol
15484 doesn't actually get put into an ffebld tree here -- we just learn
15485 more about it, just like when we see a local symbol's name in the
15486 dummy-arg list of a statement function. */
15488 if (ss
!= FFESYMBOL_stateUNCERTAIN
)
15490 /* Figure out what kind of object we've got based on previous
15491 declarations of or references to the object. */
15493 ns
= FFESYMBOL_stateSEEN
;
15495 if (sa
& FFESYMBOL_attrsANY
)
15497 else if (!(sa
& ~(FFESYMBOL_attrsADJUSTS
15498 | FFESYMBOL_attrsANY
15499 | FFESYMBOL_attrsCOMMON
15500 | FFESYMBOL_attrsDUMMY
15501 | FFESYMBOL_attrsEQUIV
15502 | FFESYMBOL_attrsINIT
15503 | FFESYMBOL_attrsNAMELIST
15504 | FFESYMBOL_attrsRESULT
15505 | FFESYMBOL_attrsSAVE
15506 | FFESYMBOL_attrsSFARG
15507 | FFESYMBOL_attrsTYPE
)))
15508 na
= sa
| FFESYMBOL_attrsSFARG
;
15510 na
= FFESYMBOL_attrsetNONE
;
15513 { /* stateUNCERTAIN. */
15514 na
= sa
| FFESYMBOL_attrsSFARG
;
15515 ns
= FFESYMBOL_stateUNDERSTOOD
;
15517 assert (!(sa
& ~(FFESYMBOL_attrsACTUALARG
15518 | FFESYMBOL_attrsADJUSTABLE
15519 | FFESYMBOL_attrsANYLEN
15520 | FFESYMBOL_attrsARRAY
15521 | FFESYMBOL_attrsDUMMY
15522 | FFESYMBOL_attrsEXTERNAL
15523 | FFESYMBOL_attrsSFARG
15524 | FFESYMBOL_attrsTYPE
)));
15526 if (sa
& FFESYMBOL_attrsEXTERNAL
)
15528 assert (!(sa
& ~(FFESYMBOL_attrsACTUALARG
15529 | FFESYMBOL_attrsDUMMY
15530 | FFESYMBOL_attrsEXTERNAL
15531 | FFESYMBOL_attrsTYPE
)));
15533 na
= FFESYMBOL_attrsetNONE
;
15535 else if (sa
& FFESYMBOL_attrsDUMMY
)
15537 assert (!(sa
& FFESYMBOL_attrsEXTERNAL
)); /* Handled above. */
15538 assert (!(sa
& ~(FFESYMBOL_attrsDUMMY
15539 | FFESYMBOL_attrsEXTERNAL
15540 | FFESYMBOL_attrsTYPE
)));
15542 kind
= FFEINFO_kindENTITY
;
15544 else if (sa
& FFESYMBOL_attrsARRAY
)
15546 assert (!(sa
& ~(FFESYMBOL_attrsARRAY
15547 | FFESYMBOL_attrsADJUSTABLE
15548 | FFESYMBOL_attrsTYPE
)));
15550 na
= FFESYMBOL_attrsetNONE
;
15552 else if (sa
& FFESYMBOL_attrsSFARG
)
15554 assert (!(sa
& ~(FFESYMBOL_attrsSFARG
15555 | FFESYMBOL_attrsTYPE
)));
15557 ns
= FFESYMBOL_stateUNCERTAIN
;
15559 else if (sa
& FFESYMBOL_attrsTYPE
)
15561 assert (!(sa
& (FFESYMBOL_attrsARRAY
15562 | FFESYMBOL_attrsDUMMY
15563 | FFESYMBOL_attrsEXTERNAL
15564 | FFESYMBOL_attrsSFARG
))); /* Handled above. */
15565 assert (!(sa
& ~(FFESYMBOL_attrsTYPE
15566 | FFESYMBOL_attrsADJUSTABLE
15567 | FFESYMBOL_attrsANYLEN
15568 | FFESYMBOL_attrsARRAY
15569 | FFESYMBOL_attrsDUMMY
15570 | FFESYMBOL_attrsEXTERNAL
15571 | FFESYMBOL_attrsSFARG
)));
15573 kind
= FFEINFO_kindENTITY
;
15575 if (sa
& (FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYLEN
))
15576 na
= FFESYMBOL_attrsetNONE
;
15577 else if (ffest_is_entry_valid ())
15578 ns
= FFESYMBOL_stateUNCERTAIN
; /* Could be DUMMY or LOCAL. */
15580 where
= FFEINFO_whereLOCAL
;
15583 na
= FFESYMBOL_attrsetNONE
; /* Error. */
15586 /* Now see what we've got for a new object: NONE means a new error
15587 cropped up; ANY means an old error to be ignored; otherwise,
15588 everything's ok, update the object (symbol) and continue on. */
15590 if (na
== FFESYMBOL_attrsetNONE
)
15591 ffesymbol_error (sp
, t
);
15592 else if (!(na
& FFESYMBOL_attrsANY
))
15594 ffesymbol_signal_change (sp
); /* May need to back up to previous
15596 if (!ffeimplic_establish_symbol (sp
))
15597 ffesymbol_error (sp
, t
);
15600 ffesymbol_set_info (sp
,
15601 ffeinfo_new (ffesymbol_basictype (sp
),
15602 ffesymbol_kindtype (sp
),
15603 ffesymbol_rank (sp
),
15606 ffesymbol_size (sp
)));
15607 ffesymbol_set_attrs (sp
, na
);
15608 ffesymbol_set_state (sp
, ns
);
15609 ffesymbol_resolve_intrin (sp
);
15610 if (!ffesymbol_state_is_specable (ns
))
15611 sp
= ffecom_sym_learned (sp
);
15612 ffesymbol_signal_unreported (sp
); /* For debugging purposes. */
15617 /* Here we create the sfunc-name-space symbol representing what should
15618 become an iterator in this name space at this or an outermore (lower-
15619 numbered) expression level, else the implied-DO construct is in error. */
15621 s
= ffesymbol_declare_sfdummy (t
); /* Sets maxentrynum to 0 for new obj;
15622 also sets sfa_dummy_parent to
15624 assert (sp
== ffesymbol_sfdummyparent (s
));
15626 ffesymbol_signal_change (s
);
15627 ffesymbol_set_state (s
, FFESYMBOL_stateSEEN
);
15628 ffesymbol_set_maxentrynum (s
, ffeexpr_level_
);
15629 ffesymbol_set_info (s
,
15630 ffeinfo_new (FFEINFO_basictypeINTEGER
,
15631 FFEINFO_kindtypeINTEGERDEFAULT
,
15633 FFEINFO_kindENTITY
,
15634 FFEINFO_whereIMMEDIATE
,
15635 FFETARGET_charactersizeNONE
));
15636 ffesymbol_signal_unreported (s
);
15638 if ((ffesymbol_basictype (sp
) != FFEINFO_basictypeINTEGER
)
15639 && (ffesymbol_basictype (sp
) != FFEINFO_basictypeANY
))
15640 ffesymbol_error (s
, t
);
15645 /* Have FOO in CALL FOO. Local name space, executable context only. */
15648 ffeexpr_sym_lhs_call_ (ffesymbol s
, ffelexToken t
)
15653 ffeinfoWhere where
;
15655 ffeintrinSpec spec
;
15657 bool error
= FALSE
;
15659 assert ((ffesymbol_state (s
) == FFESYMBOL_stateNONE
)
15660 || (ffesymbol_state (s
) == FFESYMBOL_stateUNCERTAIN
));
15662 na
= sa
= ffesymbol_attrs (s
);
15664 assert (!(sa
& ~(FFESYMBOL_attrsACTUALARG
15665 | FFESYMBOL_attrsADJUSTABLE
15666 | FFESYMBOL_attrsANYLEN
15667 | FFESYMBOL_attrsARRAY
15668 | FFESYMBOL_attrsDUMMY
15669 | FFESYMBOL_attrsEXTERNAL
15670 | FFESYMBOL_attrsSFARG
15671 | FFESYMBOL_attrsTYPE
)));
15673 kind
= ffesymbol_kind (s
);
15674 where
= ffesymbol_where (s
);
15676 /* Figure out what kind of object we've got based on previous declarations
15677 of or references to the object. */
15679 if (sa
& FFESYMBOL_attrsEXTERNAL
)
15681 assert (!(sa
& ~(FFESYMBOL_attrsACTUALARG
15682 | FFESYMBOL_attrsDUMMY
15683 | FFESYMBOL_attrsEXTERNAL
15684 | FFESYMBOL_attrsTYPE
)));
15686 if (sa
& FFESYMBOL_attrsTYPE
)
15691 kind
= FFEINFO_kindSUBROUTINE
;
15693 if (sa
& FFESYMBOL_attrsDUMMY
)
15695 else if (sa
& FFESYMBOL_attrsACTUALARG
)
15696 ; /* Not DUMMY or TYPE. */
15697 else /* Not ACTUALARG, DUMMY, or TYPE. */
15698 where
= FFEINFO_whereGLOBAL
;
15701 else if (sa
& FFESYMBOL_attrsDUMMY
)
15703 assert (!(sa
& FFESYMBOL_attrsEXTERNAL
)); /* Handled above. */
15704 assert (!(sa
& ~(FFESYMBOL_attrsDUMMY
15705 | FFESYMBOL_attrsEXTERNAL
15706 | FFESYMBOL_attrsTYPE
)));
15708 if (sa
& FFESYMBOL_attrsTYPE
)
15711 kind
= FFEINFO_kindSUBROUTINE
;
15713 else if (sa
& FFESYMBOL_attrsARRAY
)
15715 assert (!(sa
& ~(FFESYMBOL_attrsARRAY
15716 | FFESYMBOL_attrsADJUSTABLE
15717 | FFESYMBOL_attrsTYPE
)));
15721 else if (sa
& FFESYMBOL_attrsSFARG
)
15723 assert (!(sa
& ~(FFESYMBOL_attrsSFARG
15724 | FFESYMBOL_attrsTYPE
)));
15728 else if (sa
& FFESYMBOL_attrsTYPE
)
15730 assert (!(sa
& (FFESYMBOL_attrsARRAY
15731 | FFESYMBOL_attrsDUMMY
15732 | FFESYMBOL_attrsEXTERNAL
15733 | FFESYMBOL_attrsSFARG
))); /* Handled above. */
15734 assert (!(sa
& ~(FFESYMBOL_attrsTYPE
15735 | FFESYMBOL_attrsADJUSTABLE
15736 | FFESYMBOL_attrsANYLEN
15737 | FFESYMBOL_attrsARRAY
15738 | FFESYMBOL_attrsDUMMY
15739 | FFESYMBOL_attrsEXTERNAL
15740 | FFESYMBOL_attrsSFARG
)));
15744 else if (sa
== FFESYMBOL_attrsetNONE
)
15746 assert (ffesymbol_state (s
) == FFESYMBOL_stateNONE
);
15748 if (ffeintrin_is_intrinsic (ffesymbol_text (s
), t
, FALSE
,
15749 &gen
, &spec
, &imp
))
15751 ffesymbol_signal_change (s
); /* May need to back up to previous
15753 ffesymbol_set_generic (s
, gen
);
15754 ffesymbol_set_specific (s
, spec
);
15755 ffesymbol_set_implementation (s
, imp
);
15756 ffesymbol_set_info (s
,
15757 ffeinfo_new (FFEINFO_basictypeNONE
,
15758 FFEINFO_kindtypeNONE
,
15760 FFEINFO_kindSUBROUTINE
,
15761 FFEINFO_whereINTRINSIC
,
15762 FFETARGET_charactersizeNONE
));
15763 ffesymbol_set_state (s
, FFESYMBOL_stateUNDERSTOOD
);
15764 ffesymbol_resolve_intrin (s
);
15765 ffesymbol_reference (s
, t
, FALSE
);
15766 s
= ffecom_sym_learned (s
);
15767 ffesymbol_signal_unreported (s
); /* For debugging purposes. */
15772 kind
= FFEINFO_kindSUBROUTINE
;
15773 where
= FFEINFO_whereGLOBAL
;
15778 /* Now see what we've got for a new object: NONE means a new error cropped
15779 up; ANY means an old error to be ignored; otherwise, everything's ok,
15780 update the object (symbol) and continue on. */
15783 ffesymbol_error (s
, t
);
15784 else if (!(na
& FFESYMBOL_attrsANY
))
15786 ffesymbol_signal_change (s
); /* May need to back up to previous
15788 ffesymbol_set_info (s
,
15789 ffeinfo_new (ffesymbol_basictype (s
),
15790 ffesymbol_kindtype (s
),
15791 ffesymbol_rank (s
),
15792 kind
, /* SUBROUTINE. */
15793 where
, /* GLOBAL or DUMMY. */
15794 ffesymbol_size (s
)));
15795 ffesymbol_set_state (s
, FFESYMBOL_stateUNDERSTOOD
);
15796 ffesymbol_resolve_intrin (s
);
15797 ffesymbol_reference (s
, t
, FALSE
);
15798 s
= ffecom_sym_learned (s
);
15799 ffesymbol_signal_unreported (s
); /* For debugging purposes. */
15805 /* Have FOO in DATA FOO/.../. Local name space and executable context
15806 only. (This will change in the future when DATA FOO may be followed
15807 by COMMON FOO or even INTEGER FOO(10), etc.) */
15810 ffeexpr_sym_lhs_data_ (ffesymbol s
, ffelexToken t
)
15815 ffeinfoWhere where
;
15816 bool error
= FALSE
;
15818 assert ((ffesymbol_state (s
) == FFESYMBOL_stateNONE
)
15819 || (ffesymbol_state (s
) == FFESYMBOL_stateUNCERTAIN
));
15821 na
= sa
= ffesymbol_attrs (s
);
15823 assert (!(sa
& ~(FFESYMBOL_attrsACTUALARG
15824 | FFESYMBOL_attrsADJUSTABLE
15825 | FFESYMBOL_attrsANYLEN
15826 | FFESYMBOL_attrsARRAY
15827 | FFESYMBOL_attrsDUMMY
15828 | FFESYMBOL_attrsEXTERNAL
15829 | FFESYMBOL_attrsSFARG
15830 | FFESYMBOL_attrsTYPE
)));
15832 kind
= ffesymbol_kind (s
);
15833 where
= ffesymbol_where (s
);
15835 /* Figure out what kind of object we've got based on previous declarations
15836 of or references to the object. */
15838 if (sa
& FFESYMBOL_attrsEXTERNAL
)
15840 assert (!(sa
& ~(FFESYMBOL_attrsACTUALARG
15841 | FFESYMBOL_attrsDUMMY
15842 | FFESYMBOL_attrsEXTERNAL
15843 | FFESYMBOL_attrsTYPE
)));
15847 else if (sa
& FFESYMBOL_attrsDUMMY
)
15849 assert (!(sa
& FFESYMBOL_attrsEXTERNAL
)); /* Handled above. */
15850 assert (!(sa
& ~(FFESYMBOL_attrsDUMMY
15851 | FFESYMBOL_attrsEXTERNAL
15852 | FFESYMBOL_attrsTYPE
)));
15856 else if (sa
& FFESYMBOL_attrsARRAY
)
15858 assert (!(sa
& ~(FFESYMBOL_attrsARRAY
15859 | FFESYMBOL_attrsADJUSTABLE
15860 | FFESYMBOL_attrsTYPE
)));
15862 if (sa
& FFESYMBOL_attrsADJUSTABLE
)
15864 where
= FFEINFO_whereLOCAL
;
15866 else if (sa
& FFESYMBOL_attrsSFARG
)
15868 assert (!(sa
& ~(FFESYMBOL_attrsSFARG
15869 | FFESYMBOL_attrsTYPE
)));
15871 where
= FFEINFO_whereLOCAL
;
15873 else if (sa
& FFESYMBOL_attrsTYPE
)
15875 assert (!(sa
& (FFESYMBOL_attrsARRAY
15876 | FFESYMBOL_attrsDUMMY
15877 | FFESYMBOL_attrsEXTERNAL
15878 | FFESYMBOL_attrsSFARG
))); /* Handled above. */
15879 assert (!(sa
& ~(FFESYMBOL_attrsTYPE
15880 | FFESYMBOL_attrsADJUSTABLE
15881 | FFESYMBOL_attrsANYLEN
15882 | FFESYMBOL_attrsARRAY
15883 | FFESYMBOL_attrsDUMMY
15884 | FFESYMBOL_attrsEXTERNAL
15885 | FFESYMBOL_attrsSFARG
)));
15887 if (sa
& (FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYLEN
))
15891 kind
= FFEINFO_kindENTITY
;
15892 where
= FFEINFO_whereLOCAL
;
15895 else if (sa
== FFESYMBOL_attrsetNONE
)
15897 assert (ffesymbol_state (s
) == FFESYMBOL_stateNONE
);
15898 kind
= FFEINFO_kindENTITY
;
15899 where
= FFEINFO_whereLOCAL
;
15904 /* Now see what we've got for a new object: NONE means a new error cropped
15905 up; ANY means an old error to be ignored; otherwise, everything's ok,
15906 update the object (symbol) and continue on. */
15909 ffesymbol_error (s
, t
);
15910 else if (!(na
& FFESYMBOL_attrsANY
))
15912 ffesymbol_signal_change (s
); /* May need to back up to previous
15914 if (!ffeimplic_establish_symbol (s
))
15916 ffesymbol_error (s
, t
);
15919 ffesymbol_set_info (s
,
15920 ffeinfo_new (ffesymbol_basictype (s
),
15921 ffesymbol_kindtype (s
),
15922 ffesymbol_rank (s
),
15923 kind
, /* ENTITY. */
15924 where
, /* LOCAL. */
15925 ffesymbol_size (s
)));
15926 ffesymbol_set_state (s
, FFESYMBOL_stateUNDERSTOOD
);
15927 ffesymbol_resolve_intrin (s
);
15928 s
= ffecom_sym_learned (s
);
15929 ffesymbol_signal_unreported (s
); /* For debugging purposes. */
15935 /* Have FOO in EQUIVALENCE (...,FOO,...). Does not include
15936 EQUIVALENCE (...,BAR(FOO),...). */
15939 ffeexpr_sym_lhs_equivalence_ (ffesymbol s
, ffelexToken t
)
15944 ffeinfoWhere where
;
15946 na
= sa
= ffesymbol_attrs (s
);
15947 kind
= FFEINFO_kindENTITY
;
15948 where
= ffesymbol_where (s
);
15950 /* Figure out what kind of object we've got based on previous declarations
15951 of or references to the object. */
15953 if (!(sa
& ~(FFESYMBOL_attrsADJUSTS
15954 | FFESYMBOL_attrsARRAY
15955 | FFESYMBOL_attrsCOMMON
15956 | FFESYMBOL_attrsEQUIV
15957 | FFESYMBOL_attrsINIT
15958 | FFESYMBOL_attrsNAMELIST
15959 | FFESYMBOL_attrsSAVE
15960 | FFESYMBOL_attrsSFARG
15961 | FFESYMBOL_attrsTYPE
)))
15962 na
= sa
| FFESYMBOL_attrsEQUIV
;
15964 na
= FFESYMBOL_attrsetNONE
;
15966 /* Don't know why we're bothering to set kind and where in this code, but
15967 added the following to make it complete, in case it's really important.
15968 Generally this is left up to symbol exec transition. */
15970 if (where
== FFEINFO_whereNONE
)
15972 if (na
& (FFESYMBOL_attrsADJUSTS
15973 | FFESYMBOL_attrsCOMMON
))
15974 where
= FFEINFO_whereCOMMON
;
15975 else if (na
& FFESYMBOL_attrsSAVE
)
15976 where
= FFEINFO_whereLOCAL
;
15979 /* Now see what we've got for a new object: NONE means a new error cropped
15980 up; ANY means an old error to be ignored; otherwise, everything's ok,
15981 update the object (symbol) and continue on. */
15983 if (na
== FFESYMBOL_attrsetNONE
)
15984 ffesymbol_error (s
, t
);
15985 else if (!(na
& FFESYMBOL_attrsANY
))
15987 ffesymbol_signal_change (s
); /* May need to back up to previous
15989 ffesymbol_set_info (s
,
15990 ffeinfo_new (ffesymbol_basictype (s
),
15991 ffesymbol_kindtype (s
),
15992 ffesymbol_rank (s
),
15993 kind
, /* Always ENTITY. */
15994 where
, /* NONE, COMMON, or LOCAL. */
15995 ffesymbol_size (s
)));
15996 ffesymbol_set_attrs (s
, na
);
15997 ffesymbol_set_state (s
, FFESYMBOL_stateSEEN
);
15998 ffesymbol_resolve_intrin (s
);
15999 ffesymbol_signal_unreported (s
); /* For debugging purposes. */
16005 /* Have FOO in OPEN(...,USEROPEN=FOO,...). Executable context only.
16007 Note that I think this should be considered semantically similar to
16008 doing CALL XYZ(FOO), in that it should be considered like an
16009 ACTUALARG context. In particular, without EXTERNAL being specified,
16010 it should not be allowed. */
16013 ffeexpr_sym_lhs_extfunc_ (ffesymbol s
, ffelexToken t
)
16018 ffeinfoWhere where
;
16019 bool needs_type
= FALSE
;
16020 bool error
= FALSE
;
16022 assert ((ffesymbol_state (s
) == FFESYMBOL_stateNONE
)
16023 || (ffesymbol_state (s
) == FFESYMBOL_stateUNCERTAIN
));
16025 na
= sa
= ffesymbol_attrs (s
);
16027 assert (!(sa
& ~(FFESYMBOL_attrsACTUALARG
16028 | FFESYMBOL_attrsADJUSTABLE
16029 | FFESYMBOL_attrsANYLEN
16030 | FFESYMBOL_attrsARRAY
16031 | FFESYMBOL_attrsDUMMY
16032 | FFESYMBOL_attrsEXTERNAL
16033 | FFESYMBOL_attrsSFARG
16034 | FFESYMBOL_attrsTYPE
)));
16036 kind
= ffesymbol_kind (s
);
16037 where
= ffesymbol_where (s
);
16039 /* Figure out what kind of object we've got based on previous declarations
16040 of or references to the object. */
16042 if (sa
& FFESYMBOL_attrsEXTERNAL
)
16044 assert (!(sa
& ~(FFESYMBOL_attrsACTUALARG
16045 | FFESYMBOL_attrsDUMMY
16046 | FFESYMBOL_attrsEXTERNAL
16047 | FFESYMBOL_attrsTYPE
)));
16049 if (sa
& FFESYMBOL_attrsTYPE
)
16050 where
= FFEINFO_whereGLOBAL
;
16054 kind
= FFEINFO_kindFUNCTION
;
16057 if (sa
& FFESYMBOL_attrsDUMMY
)
16059 else if (sa
& FFESYMBOL_attrsACTUALARG
)
16060 ; /* Not DUMMY or TYPE. */
16061 else /* Not ACTUALARG, DUMMY, or TYPE. */
16062 where
= FFEINFO_whereGLOBAL
;
16065 else if (sa
& FFESYMBOL_attrsDUMMY
)
16067 assert (!(sa
& FFESYMBOL_attrsEXTERNAL
)); /* Handled above. */
16068 assert (!(sa
& ~(FFESYMBOL_attrsDUMMY
16069 | FFESYMBOL_attrsEXTERNAL
16070 | FFESYMBOL_attrsTYPE
)));
16072 kind
= FFEINFO_kindFUNCTION
;
16073 if (!(sa
& FFESYMBOL_attrsTYPE
))
16076 else if (sa
& FFESYMBOL_attrsARRAY
)
16078 assert (!(sa
& ~(FFESYMBOL_attrsARRAY
16079 | FFESYMBOL_attrsADJUSTABLE
16080 | FFESYMBOL_attrsTYPE
)));
16084 else if (sa
& FFESYMBOL_attrsSFARG
)
16086 assert (!(sa
& ~(FFESYMBOL_attrsSFARG
16087 | FFESYMBOL_attrsTYPE
)));
16091 else if (sa
& FFESYMBOL_attrsTYPE
)
16093 assert (!(sa
& (FFESYMBOL_attrsARRAY
16094 | FFESYMBOL_attrsDUMMY
16095 | FFESYMBOL_attrsEXTERNAL
16096 | FFESYMBOL_attrsSFARG
))); /* Handled above. */
16097 assert (!(sa
& ~(FFESYMBOL_attrsTYPE
16098 | FFESYMBOL_attrsADJUSTABLE
16099 | FFESYMBOL_attrsANYLEN
16100 | FFESYMBOL_attrsARRAY
16101 | FFESYMBOL_attrsDUMMY
16102 | FFESYMBOL_attrsEXTERNAL
16103 | FFESYMBOL_attrsSFARG
)));
16105 if (sa
& (FFESYMBOL_attrsADJUSTABLE
| FFESYMBOL_attrsANYLEN
))
16109 kind
= FFEINFO_kindFUNCTION
;
16110 where
= FFEINFO_whereGLOBAL
;
16113 else if (sa
== FFESYMBOL_attrsetNONE
)
16115 assert (ffesymbol_state (s
) == FFESYMBOL_stateNONE
);
16116 kind
= FFEINFO_kindFUNCTION
;
16117 where
= FFEINFO_whereGLOBAL
;
16123 /* Now see what we've got for a new object: NONE means a new error cropped
16124 up; ANY means an old error to be ignored; otherwise, everything's ok,
16125 update the object (symbol) and continue on. */
16128 ffesymbol_error (s
, t
);
16129 else if (!(na
& FFESYMBOL_attrsANY
))
16131 ffesymbol_signal_change (s
); /* May need to back up to previous
16133 if (needs_type
&& !ffeimplic_establish_symbol (s
))
16135 ffesymbol_error (s
, t
);
16138 if (!ffesymbol_explicitwhere (s
))
16140 ffebad_start (FFEBAD_NEED_EXTERNAL
);
16141 ffebad_here (0, ffelex_token_where_line (t
),
16142 ffelex_token_where_column (t
));
16143 ffebad_string (ffesymbol_text (s
));
16145 ffesymbol_set_explicitwhere (s
, TRUE
);
16147 ffesymbol_set_info (s
,
16148 ffeinfo_new (ffesymbol_basictype (s
),
16149 ffesymbol_kindtype (s
),
16150 ffesymbol_rank (s
),
16151 kind
, /* FUNCTION. */
16152 where
, /* GLOBAL or DUMMY. */
16153 ffesymbol_size (s
)));
16154 ffesymbol_set_state (s
, FFESYMBOL_stateUNDERSTOOD
);
16155 ffesymbol_resolve_intrin (s
);
16156 ffesymbol_reference (s
, t
, FALSE
);
16157 s
= ffecom_sym_learned (s
);
16158 ffesymbol_signal_unreported (s
); /* For debugging purposes. */
16164 /* Have FOO in DATA (stuff,FOO=1,10)/.../. */
16167 ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s
, ffelexToken t
)
16171 /* If the symbol isn't in the sfunc name space, pretend as though we saw a
16172 reference to it already within the imp-DO construct at this level, so as
16173 to get a symbol that is in the sfunc name space. But this is an
16174 erroneous construct, and should be caught elsewhere. */
16176 if (ffesymbol_sfdummyparent (s
) == NULL
)
16178 s
= ffeexpr_sym_impdoitem_ (s
, t
);
16179 if (ffesymbol_sfdummyparent (s
) == NULL
)
16180 { /* PARAMETER FOO...DATA (A(I),FOO=...). */
16181 ffesymbol_error (s
, t
);
16186 ss
= ffesymbol_state (s
);
16190 case FFESYMBOL_stateNONE
: /* Used as iterator already. */
16191 if (ffeexpr_level_
< ffesymbol_maxentrynum (s
))
16192 ffesymbol_error (s
, t
); /* Can't reuse dead iterator. F90 disallows
16193 this; F77 allows it but it is a stupid
16196 { /* Can use dead iterator because we're at at
16197 least a innermore (higher-numbered) level
16198 than the iterator's outermost
16199 (lowest-numbered) level. This should be
16200 diagnosed later, because it means an item
16201 in this list didn't reference this
16204 ffesymbol_error (s
, t
); /* For now, complain. */
16205 #else /* Someday will detect all cases where initializer doesn't reference
16206 all applicable iterators, in which case reenable this code. */
16207 ffesymbol_signal_change (s
);
16208 ffesymbol_set_state (s
, FFESYMBOL_stateUNCERTAIN
);
16209 ffesymbol_set_maxentrynum (s
, ffeexpr_level_
);
16210 ffesymbol_signal_unreported (s
);
16215 case FFESYMBOL_stateSEEN
: /* Seen already in this or other implied-DO.
16216 If seen in outermore level, can't be an
16217 iterator here, so complain. If not seen
16218 at current level, complain for now,
16219 because that indicates something F90
16220 rejects (though we currently don't detect
16221 all such cases for now). */
16222 if (ffeexpr_level_
<= ffesymbol_maxentrynum (s
))
16224 ffesymbol_signal_change (s
);
16225 ffesymbol_set_state (s
, FFESYMBOL_stateUNCERTAIN
);
16226 ffesymbol_signal_unreported (s
);
16229 ffesymbol_error (s
, t
);
16232 case FFESYMBOL_stateUNCERTAIN
: /* Already iterator! */
16233 assert ("DATA implied-DO control var seen twice!!" == NULL
);
16234 ffesymbol_error (s
, t
);
16237 case FFESYMBOL_stateUNDERSTOOD
:
16241 assert ("Foo Bletch!!" == NULL
);
16248 /* Have FOO in PARAMETER (FOO=...). */
16251 ffeexpr_sym_lhs_parameter_ (ffesymbol s
, ffelexToken t
)
16255 sa
= ffesymbol_attrs (s
);
16257 /* Figure out what kind of object we've got based on previous declarations
16258 of or references to the object. */
16260 if (sa
& ~(FFESYMBOL_attrsANYLEN
16261 | FFESYMBOL_attrsTYPE
))
16263 if (!(sa
& FFESYMBOL_attrsANY
))
16264 ffesymbol_error (s
, t
);
16268 ffesymbol_signal_change (s
); /* May need to back up to previous
16270 if (!ffeimplic_establish_symbol (s
))
16272 ffesymbol_error (s
, t
);
16275 ffesymbol_set_info (s
,
16276 ffeinfo_new (ffesymbol_basictype (s
),
16277 ffesymbol_kindtype (s
),
16278 ffesymbol_rank (s
),
16279 FFEINFO_kindENTITY
,
16280 FFEINFO_whereCONSTANT
,
16281 ffesymbol_size (s
)));
16282 ffesymbol_set_state (s
, FFESYMBOL_stateUNDERSTOOD
);
16283 ffesymbol_resolve_intrin (s
);
16284 s
= ffecom_sym_learned (s
);
16285 ffesymbol_signal_unreported (s
); /* For debugging purposes. */
16291 /* Have FOO in CALL XYZ(...,FOO,...). Does not include any other
16292 embedding of FOO, such as CALL XYZ((FOO)) or CALL XYZ(FOO+1). */
16295 ffeexpr_sym_rhs_actualarg_ (ffesymbol s
, ffelexToken t
)
16300 ffeinfoWhere where
;
16302 bool needs_type
= FALSE
;
16304 assert ((ffesymbol_state (s
) == FFESYMBOL_stateNONE
)
16305 || (ffesymbol_state (s
) == FFESYMBOL_stateUNCERTAIN
));
16307 na
= sa
= ffesymbol_attrs (s
);
16309 assert (!(sa
& ~(FFESYMBOL_attrsACTUALARG
16310 | FFESYMBOL_attrsADJUSTABLE
16311 | FFESYMBOL_attrsANYLEN
16312 | FFESYMBOL_attrsARRAY
16313 | FFESYMBOL_attrsDUMMY
16314 | FFESYMBOL_attrsEXTERNAL
16315 | FFESYMBOL_attrsSFARG
16316 | FFESYMBOL_attrsTYPE
)));
16318 kind
= ffesymbol_kind (s
);
16319 where
= ffesymbol_where (s
);
16321 /* Figure out what kind of object we've got based on previous declarations
16322 of or references to the object. */
16324 ns
= FFESYMBOL_stateUNDERSTOOD
;
16326 if (sa
& FFESYMBOL_attrsEXTERNAL
)
16328 assert (!(sa
& ~(FFESYMBOL_attrsACTUALARG
16329 | FFESYMBOL_attrsDUMMY
16330 | FFESYMBOL_attrsEXTERNAL
16331 | FFESYMBOL_attrsTYPE
)));
16333 if (sa
& FFESYMBOL_attrsTYPE
)
16334 where
= FFEINFO_whereGLOBAL
;
16338 ns
= FFESYMBOL_stateUNCERTAIN
;
16340 if (sa
& FFESYMBOL_attrsDUMMY
)
16341 assert (kind
== FFEINFO_kindNONE
); /* FUNCTION, SUBROUTINE. */
16342 else if (sa
& FFESYMBOL_attrsACTUALARG
)
16343 ; /* Not DUMMY or TYPE. */
16345 /* Not ACTUALARG, DUMMY, or TYPE. */
16347 assert (kind
== FFEINFO_kindNONE
); /* FUNCTION, SUBROUTINE. */
16348 na
|= FFESYMBOL_attrsACTUALARG
;
16349 where
= FFEINFO_whereGLOBAL
;
16353 else if (sa
& FFESYMBOL_attrsDUMMY
)
16355 assert (!(sa
& FFESYMBOL_attrsEXTERNAL
)); /* Handled above. */
16356 assert (!(sa
& ~(FFESYMBOL_attrsDUMMY
16357 | FFESYMBOL_attrsEXTERNAL
16358 | FFESYMBOL_attrsTYPE
)));
16360 kind
= FFEINFO_kindENTITY
;
16361 if (!(sa
& FFESYMBOL_attrsTYPE
))
16364 else if (sa
& FFESYMBOL_attrsARRAY
)
16366 assert (!(sa
& ~(FFESYMBOL_attrsARRAY
16367 | FFESYMBOL_attrsADJUSTABLE
16368 | FFESYMBOL_attrsTYPE
)));
16370 where
= FFEINFO_whereLOCAL
;
16372 else if (sa
& FFESYMBOL_attrsSFARG
)
16374 assert (!(sa
& ~(FFESYMBOL_attrsSFARG
16375 | FFESYMBOL_attrsTYPE
)));
16377 where
= FFEINFO_whereLOCAL
;
16379 else if (sa
& FFESYMBOL_attrsTYPE
)
16381 assert (!(sa
& (FFESYMBOL_attrsARRAY
16382 | FFESYMBOL_attrsDUMMY
16383 | FFESYMBOL_attrsEXTERNAL
16384 | FFESYMBOL_attrsSFARG
))); /* Handled above. */
16385 assert (!(sa
& ~(FFESYMBOL_attrsTYPE
16386 | FFESYMBOL_attrsADJUSTABLE
16387 | FFESYMBOL_attrsANYLEN
16388 | FFESYMBOL_attrsARRAY
16389 | FFESYMBOL_attrsDUMMY
16390 | FFESYMBOL_attrsEXTERNAL
16391 | FFESYMBOL_attrsSFARG
)));
16393 if (sa
& FFESYMBOL_attrsANYLEN
)
16394 ns
= FFESYMBOL_stateNONE
;
16397 kind
= FFEINFO_kindENTITY
;
16398 where
= FFEINFO_whereLOCAL
;
16401 else if (sa
== FFESYMBOL_attrsetNONE
)
16403 /* New state is left empty because there isn't any state flag to
16404 set for this case, and it's UNDERSTOOD after all. */
16405 assert (ffesymbol_state (s
) == FFESYMBOL_stateNONE
);
16406 kind
= FFEINFO_kindENTITY
;
16407 where
= FFEINFO_whereLOCAL
;
16411 ns
= FFESYMBOL_stateNONE
; /* Error. */
16413 /* Now see what we've got for a new object: NONE means a new error cropped
16414 up; ANY means an old error to be ignored; otherwise, everything's ok,
16415 update the object (symbol) and continue on. */
16417 if (ns
== FFESYMBOL_stateNONE
)
16418 ffesymbol_error (s
, t
);
16419 else if (!(na
& FFESYMBOL_attrsANY
))
16421 ffesymbol_signal_change (s
); /* May need to back up to previous
16423 if (needs_type
&& !ffeimplic_establish_symbol (s
))
16425 ffesymbol_error (s
, t
);
16428 ffesymbol_set_info (s
,
16429 ffeinfo_new (ffesymbol_basictype (s
),
16430 ffesymbol_kindtype (s
),
16431 ffesymbol_rank (s
),
16434 ffesymbol_size (s
)));
16435 ffesymbol_set_attrs (s
, na
);
16436 ffesymbol_set_state (s
, ns
);
16437 s
= ffecom_sym_learned (s
);
16438 ffesymbol_reference (s
, t
, FALSE
);
16439 ffesymbol_signal_unreported (s
); /* For debugging purposes. */
16445 /* Have FOO in DIMENSION XYZ(FOO) or any array declarator containing
16446 a reference to FOO. */
16449 ffeexpr_sym_rhs_dimlist_ (ffesymbol s
, ffelexToken t
)
16454 ffeinfoWhere where
;
16456 na
= sa
= ffesymbol_attrs (s
);
16457 kind
= FFEINFO_kindENTITY
;
16458 where
= ffesymbol_where (s
);
16460 /* Figure out what kind of object we've got based on previous declarations
16461 of or references to the object. */
16463 if (!(sa
& ~(FFESYMBOL_attrsADJUSTS
16464 | FFESYMBOL_attrsCOMMON
16465 | FFESYMBOL_attrsDUMMY
16466 | FFESYMBOL_attrsEQUIV
16467 | FFESYMBOL_attrsINIT
16468 | FFESYMBOL_attrsNAMELIST
16469 | FFESYMBOL_attrsSFARG
16470 | FFESYMBOL_attrsARRAY
16471 | FFESYMBOL_attrsTYPE
)))
16472 na
= sa
| FFESYMBOL_attrsADJUSTS
;
16474 na
= FFESYMBOL_attrsetNONE
;
16476 /* Since this symbol definitely is going into an expression (the
16477 dimension-list for some dummy array, presumably), figure out WHERE if
16480 if (where
== FFEINFO_whereNONE
)
16482 if (na
& (FFESYMBOL_attrsCOMMON
16483 | FFESYMBOL_attrsEQUIV
16484 | FFESYMBOL_attrsINIT
16485 | FFESYMBOL_attrsNAMELIST
))
16486 where
= FFEINFO_whereCOMMON
;
16487 else if (na
& FFESYMBOL_attrsDUMMY
)
16488 where
= FFEINFO_whereDUMMY
;
16491 /* Now see what we've got for a new object: NONE means a new error cropped
16492 up; ANY means an old error to be ignored; otherwise, everything's ok,
16493 update the object (symbol) and continue on. */
16495 if (na
== FFESYMBOL_attrsetNONE
)
16496 ffesymbol_error (s
, t
);
16497 else if (!(na
& FFESYMBOL_attrsANY
))
16499 ffesymbol_signal_change (s
); /* May need to back up to previous
16501 if (!ffeimplic_establish_symbol (s
))
16503 ffesymbol_error (s
, t
);
16506 ffesymbol_set_info (s
,
16507 ffeinfo_new (ffesymbol_basictype (s
),
16508 ffesymbol_kindtype (s
),
16509 ffesymbol_rank (s
),
16510 kind
, /* Always ENTITY. */
16511 where
, /* NONE, COMMON, or DUMMY. */
16512 ffesymbol_size (s
)));
16513 ffesymbol_set_attrs (s
, na
);
16514 ffesymbol_set_state (s
, FFESYMBOL_stateSEEN
);
16515 ffesymbol_resolve_intrin (s
);
16516 ffesymbol_signal_unreported (s
); /* For debugging purposes. */
16522 /* Have FOO in XYZ = ...FOO.... Does not include cases like FOO in
16523 XYZ = BAR(FOO), as such cases are handled elsewhere. */
16526 ffeexpr_sym_rhs_let_ (ffesymbol s
, ffelexToken t
)
16531 ffeinfoWhere where
;
16532 bool error
= FALSE
;
16534 assert ((ffesymbol_state (s
) == FFESYMBOL_stateNONE
)
16535 || (ffesymbol_state (s
) == FFESYMBOL_stateUNCERTAIN
));
16537 na
= sa
= ffesymbol_attrs (s
);
16539 assert (!(sa
& ~(FFESYMBOL_attrsACTUALARG
16540 | FFESYMBOL_attrsADJUSTABLE
16541 | FFESYMBOL_attrsANYLEN
16542 | FFESYMBOL_attrsARRAY
16543 | FFESYMBOL_attrsDUMMY
16544 | FFESYMBOL_attrsEXTERNAL
16545 | FFESYMBOL_attrsSFARG
16546 | FFESYMBOL_attrsTYPE
)));
16548 kind
= ffesymbol_kind (s
);
16549 where
= ffesymbol_where (s
);
16551 /* Figure out what kind of object we've got based on previous declarations
16552 of or references to the object. */
16554 if (sa
& FFESYMBOL_attrsEXTERNAL
)
16556 assert (!(sa
& ~(FFESYMBOL_attrsACTUALARG
16557 | FFESYMBOL_attrsDUMMY
16558 | FFESYMBOL_attrsEXTERNAL
16559 | FFESYMBOL_attrsTYPE
)));
16563 else if (sa
& FFESYMBOL_attrsDUMMY
)
16565 assert (!(sa
& FFESYMBOL_attrsEXTERNAL
)); /* Handled above. */
16566 assert (!(sa
& ~(FFESYMBOL_attrsDUMMY
16567 | FFESYMBOL_attrsEXTERNAL
16568 | FFESYMBOL_attrsTYPE
)));
16570 kind
= FFEINFO_kindENTITY
;
16572 else if (sa
& FFESYMBOL_attrsARRAY
)
16574 assert (!(sa
& ~(FFESYMBOL_attrsARRAY
16575 | FFESYMBOL_attrsADJUSTABLE
16576 | FFESYMBOL_attrsTYPE
)));
16578 where
= FFEINFO_whereLOCAL
;
16580 else if (sa
& FFESYMBOL_attrsSFARG
)
16582 assert (!(sa
& ~(FFESYMBOL_attrsSFARG
16583 | FFESYMBOL_attrsTYPE
)));
16585 where
= FFEINFO_whereLOCAL
;
16587 else if (sa
& FFESYMBOL_attrsTYPE
)
16589 assert (!(sa
& (FFESYMBOL_attrsARRAY
16590 | FFESYMBOL_attrsDUMMY
16591 | FFESYMBOL_attrsEXTERNAL
16592 | FFESYMBOL_attrsSFARG
))); /* Handled above. */
16593 assert (!(sa
& ~(FFESYMBOL_attrsTYPE
16594 | FFESYMBOL_attrsADJUSTABLE
16595 | FFESYMBOL_attrsANYLEN
16596 | FFESYMBOL_attrsARRAY
16597 | FFESYMBOL_attrsDUMMY
16598 | FFESYMBOL_attrsEXTERNAL
16599 | FFESYMBOL_attrsSFARG
)));
16601 if (sa
& FFESYMBOL_attrsANYLEN
)
16605 kind
= FFEINFO_kindENTITY
;
16606 where
= FFEINFO_whereLOCAL
;
16609 else if (sa
== FFESYMBOL_attrsetNONE
)
16611 assert (ffesymbol_state (s
) == FFESYMBOL_stateNONE
);
16612 kind
= FFEINFO_kindENTITY
;
16613 where
= FFEINFO_whereLOCAL
;
16618 /* Now see what we've got for a new object: NONE means a new error cropped
16619 up; ANY means an old error to be ignored; otherwise, everything's ok,
16620 update the object (symbol) and continue on. */
16623 ffesymbol_error (s
, t
);
16624 else if (!(na
& FFESYMBOL_attrsANY
))
16626 ffesymbol_signal_change (s
); /* May need to back up to previous
16628 if (!ffeimplic_establish_symbol (s
))
16630 ffesymbol_error (s
, t
);
16633 ffesymbol_set_info (s
,
16634 ffeinfo_new (ffesymbol_basictype (s
),
16635 ffesymbol_kindtype (s
),
16636 ffesymbol_rank (s
),
16637 kind
, /* ENTITY. */
16638 where
, /* LOCAL. */
16639 ffesymbol_size (s
)));
16640 ffesymbol_set_state (s
, FFESYMBOL_stateUNDERSTOOD
);
16641 ffesymbol_resolve_intrin (s
);
16642 s
= ffecom_sym_learned (s
);
16643 ffesymbol_signal_unreported (s
); /* For debugging purposes. */
16649 /* ffeexpr_declare_parenthesized_ -- ffesymbol wrapper for NAME(...) operand
16653 ffeexprParenType_ paren_type;
16655 s = ffeexpr_declare_parenthesized_ (t, maybe_intrin, &paren_type);
16657 Just like ffesymbol_declare_local, except performs any implicit info
16658 assignment necessary, and it returns the type of the parenthesized list
16659 (list of function args, list of array args, or substring spec). */
16662 ffeexpr_declare_parenthesized_ (ffelexToken t
, bool maybe_intrin
,
16663 ffeexprParenType_
*paren_type
)
16666 ffesymbolState st
; /* Effective state. */
16670 if (maybe_intrin
&& ffesrc_check_symbol ())
16671 { /* Knock off some easy cases. */
16672 switch (ffeexpr_stack_
->context
)
16674 case FFEEXPR_contextSUBROUTINEREF
:
16675 case FFEEXPR_contextDATA
:
16676 case FFEEXPR_contextDATAIMPDOINDEX_
:
16677 case FFEEXPR_contextSFUNCDEF
:
16678 case FFEEXPR_contextSFUNCDEFINDEX_
:
16679 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_
:
16680 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_
:
16681 case FFEEXPR_contextLET
:
16682 case FFEEXPR_contextPAREN_
:
16683 case FFEEXPR_contextACTUALARGEXPR_
:
16684 case FFEEXPR_contextINDEXORACTUALARGEXPR_
:
16685 case FFEEXPR_contextIOLIST
:
16686 case FFEEXPR_contextIOLISTDF
:
16687 case FFEEXPR_contextDO
:
16688 case FFEEXPR_contextDOWHILE
:
16689 case FFEEXPR_contextACTUALARG_
:
16690 case FFEEXPR_contextCGOTO
:
16691 case FFEEXPR_contextIF
:
16692 case FFEEXPR_contextARITHIF
:
16693 case FFEEXPR_contextFORMAT
:
16694 case FFEEXPR_contextSTOP
:
16695 case FFEEXPR_contextRETURN
:
16696 case FFEEXPR_contextSELECTCASE
:
16697 case FFEEXPR_contextCASE
:
16698 case FFEEXPR_contextFILEASSOC
:
16699 case FFEEXPR_contextFILEINT
:
16700 case FFEEXPR_contextFILEDFINT
:
16701 case FFEEXPR_contextFILELOG
:
16702 case FFEEXPR_contextFILENUM
:
16703 case FFEEXPR_contextFILENUMAMBIG
:
16704 case FFEEXPR_contextFILECHAR
:
16705 case FFEEXPR_contextFILENUMCHAR
:
16706 case FFEEXPR_contextFILEDFCHAR
:
16707 case FFEEXPR_contextFILEKEY
:
16708 case FFEEXPR_contextFILEUNIT
:
16709 case FFEEXPR_contextFILEUNIT_DF
:
16710 case FFEEXPR_contextFILEUNITAMBIG
:
16711 case FFEEXPR_contextFILEFORMAT
:
16712 case FFEEXPR_contextFILENAMELIST
:
16713 case FFEEXPR_contextFILEVXTCODE
:
16714 case FFEEXPR_contextINDEX_
:
16715 case FFEEXPR_contextIMPDOITEM_
:
16716 case FFEEXPR_contextIMPDOITEMDF_
:
16717 case FFEEXPR_contextIMPDOCTRL_
:
16718 case FFEEXPR_contextDATAIMPDOCTRL_
:
16719 case FFEEXPR_contextCHARACTERSIZE
:
16720 case FFEEXPR_contextPARAMETER
:
16721 case FFEEXPR_contextDIMLIST
:
16722 case FFEEXPR_contextDIMLISTCOMMON
:
16723 case FFEEXPR_contextKINDTYPE
:
16724 case FFEEXPR_contextINITVAL
:
16725 case FFEEXPR_contextEQVINDEX_
:
16726 break; /* These could be intrinsic invocations. */
16728 case FFEEXPR_contextAGOTO
:
16729 case FFEEXPR_contextFILEFORMATNML
:
16730 case FFEEXPR_contextALLOCATE
:
16731 case FFEEXPR_contextDEALLOCATE
:
16732 case FFEEXPR_contextHEAPSTAT
:
16733 case FFEEXPR_contextNULLIFY
:
16734 case FFEEXPR_contextINCLUDE
:
16735 case FFEEXPR_contextDATAIMPDOITEM_
:
16736 case FFEEXPR_contextLOC_
:
16737 case FFEEXPR_contextINDEXORACTUALARG_
:
16738 case FFEEXPR_contextSFUNCDEFACTUALARG_
:
16739 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
:
16740 case FFEEXPR_contextPARENFILENUM_
:
16741 case FFEEXPR_contextPARENFILEUNIT_
:
16742 maybe_intrin
= FALSE
;
16743 break; /* Can't be intrinsic invocation. */
16746 assert ("blah! blah! waaauuggh!" == NULL
);
16751 s
= ffesymbol_declare_local (t
, maybe_intrin
);
16753 switch (ffeexpr_context_outer_ (ffeexpr_stack_
))
16754 /* Special-case these since they can involve a different concept
16755 of "state" (in the stmtfunc name space). */
16757 case FFEEXPR_contextDATAIMPDOINDEX_
:
16758 case FFEEXPR_contextDATAIMPDOCTRL_
:
16759 if (ffeexpr_context_outer_ (ffeexpr_stack_
)
16760 == FFEEXPR_contextDATAIMPDOINDEX_
)
16761 s
= ffeexpr_sym_impdoitem_ (s
, t
);
16763 if (ffeexpr_stack_
->is_rhs
)
16764 s
= ffeexpr_sym_impdoitem_ (s
, t
);
16766 s
= ffeexpr_sym_lhs_impdoctrl_ (s
, t
);
16767 if (ffesymbol_kind (s
) != FFEINFO_kindANY
)
16768 ffesymbol_error (s
, t
);
16775 switch ((ffesymbol_sfdummyparent (s
) == NULL
)
16776 ? ffesymbol_state (s
)
16777 : FFESYMBOL_stateUNDERSTOOD
)
16779 case FFESYMBOL_stateNONE
: /* Before first exec, not seen in expr
16781 if (!ffest_seen_first_exec ())
16782 goto seen
; /* :::::::::::::::::::: */
16783 /* Fall through. */
16784 case FFESYMBOL_stateUNCERTAIN
: /* Unseen since first exec. */
16785 switch (ffeexpr_context_outer_ (ffeexpr_stack_
))
16787 case FFEEXPR_contextSUBROUTINEREF
:
16788 s
= ffeexpr_sym_lhs_call_ (s
, t
); /* "CALL FOO"=="CALL
16792 case FFEEXPR_contextDATA
:
16793 if (ffeexpr_stack_
->is_rhs
)
16794 s
= ffeexpr_sym_rhs_let_ (s
, t
);
16796 s
= ffeexpr_sym_lhs_data_ (s
, t
);
16799 case FFEEXPR_contextDATAIMPDOITEM_
:
16800 s
= ffeexpr_sym_lhs_data_ (s
, t
);
16803 case FFEEXPR_contextSFUNCDEF
:
16804 case FFEEXPR_contextSFUNCDEFINDEX_
:
16805 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_
:
16806 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_
:
16807 s
= ffecom_sym_exec_transition (s
);
16808 if (ffesymbol_state (s
) == FFESYMBOL_stateUNDERSTOOD
)
16809 goto understood
; /* :::::::::::::::::::: */
16810 /* Fall through. */
16811 case FFEEXPR_contextLET
:
16812 case FFEEXPR_contextPAREN_
:
16813 case FFEEXPR_contextACTUALARGEXPR_
:
16814 case FFEEXPR_contextINDEXORACTUALARGEXPR_
:
16815 case FFEEXPR_contextIOLIST
:
16816 case FFEEXPR_contextIOLISTDF
:
16817 case FFEEXPR_contextDO
:
16818 case FFEEXPR_contextDOWHILE
:
16819 case FFEEXPR_contextACTUALARG_
:
16820 case FFEEXPR_contextCGOTO
:
16821 case FFEEXPR_contextIF
:
16822 case FFEEXPR_contextARITHIF
:
16823 case FFEEXPR_contextFORMAT
:
16824 case FFEEXPR_contextSTOP
:
16825 case FFEEXPR_contextRETURN
:
16826 case FFEEXPR_contextSELECTCASE
:
16827 case FFEEXPR_contextCASE
:
16828 case FFEEXPR_contextFILEASSOC
:
16829 case FFEEXPR_contextFILEINT
:
16830 case FFEEXPR_contextFILEDFINT
:
16831 case FFEEXPR_contextFILELOG
:
16832 case FFEEXPR_contextFILENUM
:
16833 case FFEEXPR_contextFILENUMAMBIG
:
16834 case FFEEXPR_contextFILECHAR
:
16835 case FFEEXPR_contextFILENUMCHAR
:
16836 case FFEEXPR_contextFILEDFCHAR
:
16837 case FFEEXPR_contextFILEKEY
:
16838 case FFEEXPR_contextFILEUNIT
:
16839 case FFEEXPR_contextFILEUNIT_DF
:
16840 case FFEEXPR_contextFILEUNITAMBIG
:
16841 case FFEEXPR_contextFILEFORMAT
:
16842 case FFEEXPR_contextFILENAMELIST
:
16843 case FFEEXPR_contextFILEVXTCODE
:
16844 case FFEEXPR_contextINDEX_
:
16845 case FFEEXPR_contextIMPDOITEM_
:
16846 case FFEEXPR_contextIMPDOITEMDF_
:
16847 case FFEEXPR_contextIMPDOCTRL_
:
16848 case FFEEXPR_contextLOC_
:
16849 if (ffeexpr_stack_
->is_rhs
)
16850 s
= ffeexpr_paren_rhs_let_ (s
, t
);
16852 s
= ffeexpr_paren_lhs_let_ (s
, t
);
16855 case FFEEXPR_contextASSIGN
:
16856 case FFEEXPR_contextAGOTO
:
16857 case FFEEXPR_contextCHARACTERSIZE
:
16858 case FFEEXPR_contextEQUIVALENCE
:
16859 case FFEEXPR_contextINCLUDE
:
16860 case FFEEXPR_contextPARAMETER
:
16861 case FFEEXPR_contextDIMLIST
:
16862 case FFEEXPR_contextDIMLISTCOMMON
:
16863 case FFEEXPR_contextKINDTYPE
:
16864 case FFEEXPR_contextINITVAL
:
16865 case FFEEXPR_contextEQVINDEX_
:
16866 break; /* Will turn into errors below. */
16869 ffesymbol_error (s
, t
);
16872 /* Fall through. */
16873 case FFESYMBOL_stateUNDERSTOOD
: /* Nothing much more to learn. */
16874 understood
: /* :::::::::::::::::::: */
16876 /* State might have changed, update it. */
16877 st
= ((ffesymbol_sfdummyparent (s
) == NULL
)
16878 ? ffesymbol_state (s
)
16879 : FFESYMBOL_stateUNDERSTOOD
);
16881 k
= ffesymbol_kind (s
);
16882 switch (ffeexpr_context_outer_ (ffeexpr_stack_
))
16884 case FFEEXPR_contextSUBROUTINEREF
:
16885 bad
= ((k
!= FFEINFO_kindSUBROUTINE
)
16886 && ((ffesymbol_where (s
) != FFEINFO_whereINTRINSIC
)
16887 || (k
!= FFEINFO_kindNONE
)));
16890 case FFEEXPR_contextDATA
:
16891 if (ffeexpr_stack_
->is_rhs
)
16892 bad
= (k
!= FFEINFO_kindENTITY
)
16893 || (ffesymbol_where (s
) != FFEINFO_whereCONSTANT
);
16895 bad
= (k
!= FFEINFO_kindENTITY
)
16896 || ((ffesymbol_where (s
) != FFEINFO_whereNONE
)
16897 && (ffesymbol_where (s
) != FFEINFO_whereLOCAL
)
16898 && (ffesymbol_where (s
) != FFEINFO_whereCOMMON
));
16901 case FFEEXPR_contextDATAIMPDOITEM_
:
16902 bad
= (k
!= FFEINFO_kindENTITY
) || (ffesymbol_rank (s
) == 0)
16903 || ((ffesymbol_where (s
) != FFEINFO_whereNONE
)
16904 && (ffesymbol_where (s
) != FFEINFO_whereLOCAL
)
16905 && (ffesymbol_where (s
) != FFEINFO_whereCOMMON
));
16908 case FFEEXPR_contextSFUNCDEF
:
16909 case FFEEXPR_contextSFUNCDEFINDEX_
:
16910 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_
:
16911 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_
:
16912 case FFEEXPR_contextLET
:
16913 case FFEEXPR_contextPAREN_
:
16914 case FFEEXPR_contextACTUALARGEXPR_
:
16915 case FFEEXPR_contextINDEXORACTUALARGEXPR_
:
16916 case FFEEXPR_contextIOLIST
:
16917 case FFEEXPR_contextIOLISTDF
:
16918 case FFEEXPR_contextDO
:
16919 case FFEEXPR_contextDOWHILE
:
16920 case FFEEXPR_contextACTUALARG_
:
16921 case FFEEXPR_contextCGOTO
:
16922 case FFEEXPR_contextIF
:
16923 case FFEEXPR_contextARITHIF
:
16924 case FFEEXPR_contextFORMAT
:
16925 case FFEEXPR_contextSTOP
:
16926 case FFEEXPR_contextRETURN
:
16927 case FFEEXPR_contextSELECTCASE
:
16928 case FFEEXPR_contextCASE
:
16929 case FFEEXPR_contextFILEASSOC
:
16930 case FFEEXPR_contextFILEINT
:
16931 case FFEEXPR_contextFILEDFINT
:
16932 case FFEEXPR_contextFILELOG
:
16933 case FFEEXPR_contextFILENUM
:
16934 case FFEEXPR_contextFILENUMAMBIG
:
16935 case FFEEXPR_contextFILECHAR
:
16936 case FFEEXPR_contextFILENUMCHAR
:
16937 case FFEEXPR_contextFILEDFCHAR
:
16938 case FFEEXPR_contextFILEKEY
:
16939 case FFEEXPR_contextFILEUNIT
:
16940 case FFEEXPR_contextFILEUNIT_DF
:
16941 case FFEEXPR_contextFILEUNITAMBIG
:
16942 case FFEEXPR_contextFILEFORMAT
:
16943 case FFEEXPR_contextFILENAMELIST
:
16944 case FFEEXPR_contextFILEVXTCODE
:
16945 case FFEEXPR_contextINDEX_
:
16946 case FFEEXPR_contextIMPDOITEM_
:
16947 case FFEEXPR_contextIMPDOITEMDF_
:
16948 case FFEEXPR_contextIMPDOCTRL_
:
16949 case FFEEXPR_contextLOC_
:
16950 bad
= FALSE
; /* Let paren-switch handle the cases. */
16953 case FFEEXPR_contextASSIGN
:
16954 case FFEEXPR_contextAGOTO
:
16955 case FFEEXPR_contextCHARACTERSIZE
:
16956 case FFEEXPR_contextEQUIVALENCE
:
16957 case FFEEXPR_contextPARAMETER
:
16958 case FFEEXPR_contextDIMLIST
:
16959 case FFEEXPR_contextDIMLISTCOMMON
:
16960 case FFEEXPR_contextKINDTYPE
:
16961 case FFEEXPR_contextINITVAL
:
16962 case FFEEXPR_contextEQVINDEX_
:
16963 bad
= (k
!= FFEINFO_kindENTITY
)
16964 || (ffesymbol_where (s
) != FFEINFO_whereCONSTANT
);
16967 case FFEEXPR_contextINCLUDE
:
16976 switch (bad
? FFEINFO_kindANY
: k
)
16978 case FFEINFO_kindNONE
: /* Case "CHARACTER X,Y; Y=X(?". */
16979 if (ffesymbol_where (s
) == FFEINFO_whereINTRINSIC
)
16981 if (ffeexpr_context_outer_ (ffeexpr_stack_
)
16982 == FFEEXPR_contextSUBROUTINEREF
)
16983 *paren_type
= FFEEXPR_parentypeSUBROUTINE_
;
16985 *paren_type
= FFEEXPR_parentypeFUNCTION_
;
16988 if (st
== FFESYMBOL_stateUNDERSTOOD
)
16991 *paren_type
= FFEEXPR_parentypeANY_
;
16994 *paren_type
= FFEEXPR_parentypeFUNSUBSTR_
;
16997 case FFEINFO_kindFUNCTION
:
16998 *paren_type
= FFEEXPR_parentypeFUNCTION_
;
16999 switch (ffesymbol_where (s
))
17001 case FFEINFO_whereLOCAL
:
17002 bad
= TRUE
; /* Attempt to recurse! */
17005 case FFEINFO_whereCONSTANT
:
17006 bad
= ((ffesymbol_sfexpr (s
) == NULL
)
17007 || (ffebld_op (ffesymbol_sfexpr (s
))
17008 == FFEBLD_opANY
)); /* Attempt to recurse! */
17016 case FFEINFO_kindSUBROUTINE
:
17017 if ((ffeexpr_stack_
->context
!= FFEEXPR_contextSUBROUTINEREF
)
17018 || (ffeexpr_stack_
->previous
!= NULL
))
17021 *paren_type
= FFEEXPR_parentypeANY_
;
17025 *paren_type
= FFEEXPR_parentypeSUBROUTINE_
;
17026 switch (ffesymbol_where (s
))
17028 case FFEINFO_whereLOCAL
:
17029 case FFEINFO_whereCONSTANT
:
17030 bad
= TRUE
; /* Attempt to recurse! */
17038 case FFEINFO_kindENTITY
:
17039 if (ffesymbol_rank (s
) == 0)
17041 if (ffesymbol_basictype (s
) == FFEINFO_basictypeCHARACTER
)
17042 *paren_type
= FFEEXPR_parentypeSUBSTRING_
;
17046 *paren_type
= FFEEXPR_parentypeANY_
;
17050 *paren_type
= FFEEXPR_parentypeARRAY_
;
17054 case FFEINFO_kindANY
:
17056 *paren_type
= FFEEXPR_parentypeANY_
;
17062 if (k
== FFEINFO_kindANY
)
17065 ffesymbol_error (s
, t
);
17070 case FFESYMBOL_stateSEEN
: /* Seen but not yet in exec portion. */
17071 seen
: /* :::::::::::::::::::: */
17073 switch (ffeexpr_context_outer_ (ffeexpr_stack_
))
17075 case FFEEXPR_contextPARAMETER
:
17076 if (ffeexpr_stack_
->is_rhs
)
17077 ffesymbol_error (s
, t
);
17079 s
= ffeexpr_sym_lhs_parameter_ (s
, t
);
17082 case FFEEXPR_contextDATA
:
17083 s
= ffecom_sym_exec_transition (s
);
17084 if (ffesymbol_state (s
) == FFESYMBOL_stateUNDERSTOOD
)
17085 goto understood
; /* :::::::::::::::::::: */
17086 if (ffeexpr_stack_
->is_rhs
)
17087 ffesymbol_error (s
, t
);
17089 s
= ffeexpr_sym_lhs_data_ (s
, t
);
17090 goto understood
; /* :::::::::::::::::::: */
17092 case FFEEXPR_contextDATAIMPDOITEM_
:
17093 s
= ffecom_sym_exec_transition (s
);
17094 if (ffesymbol_state (s
) == FFESYMBOL_stateUNDERSTOOD
)
17095 goto understood
; /* :::::::::::::::::::: */
17096 s
= ffeexpr_sym_lhs_data_ (s
, t
);
17097 goto understood
; /* :::::::::::::::::::: */
17099 case FFEEXPR_contextEQUIVALENCE
:
17100 s
= ffeexpr_sym_lhs_equivalence_ (s
, t
);
17104 case FFEEXPR_contextDIMLIST
:
17105 s
= ffeexpr_sym_rhs_dimlist_ (s
, t
);
17109 case FFEEXPR_contextCHARACTERSIZE
:
17110 case FFEEXPR_contextKINDTYPE
:
17111 case FFEEXPR_contextDIMLISTCOMMON
:
17112 case FFEEXPR_contextINITVAL
:
17113 case FFEEXPR_contextEQVINDEX_
:
17116 case FFEEXPR_contextINCLUDE
:
17119 case FFEEXPR_contextINDEX_
:
17120 case FFEEXPR_contextACTUALARGEXPR_
:
17121 case FFEEXPR_contextINDEXORACTUALARGEXPR_
:
17122 case FFEEXPR_contextSFUNCDEF
:
17123 case FFEEXPR_contextSFUNCDEFINDEX_
:
17124 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_
:
17125 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_
:
17126 assert (ffeexpr_stack_
->is_rhs
);
17127 s
= ffecom_sym_exec_transition (s
);
17128 if (ffesymbol_state (s
) == FFESYMBOL_stateUNDERSTOOD
)
17129 goto understood
; /* :::::::::::::::::::: */
17130 s
= ffeexpr_paren_rhs_let_ (s
, t
);
17131 goto understood
; /* :::::::::::::::::::: */
17136 k
= ffesymbol_kind (s
);
17137 switch (bad
? FFEINFO_kindANY
: k
)
17139 case FFEINFO_kindNONE
: /* Case "CHARACTER X,Y; Y=X(?". */
17140 *paren_type
= FFEEXPR_parentypeFUNSUBSTR_
;
17143 case FFEINFO_kindFUNCTION
:
17144 *paren_type
= FFEEXPR_parentypeFUNCTION_
;
17145 switch (ffesymbol_where (s
))
17147 case FFEINFO_whereLOCAL
:
17148 bad
= TRUE
; /* Attempt to recurse! */
17151 case FFEINFO_whereCONSTANT
:
17152 bad
= ((ffesymbol_sfexpr (s
) == NULL
)
17153 || (ffebld_op (ffesymbol_sfexpr (s
))
17154 == FFEBLD_opANY
)); /* Attempt to recurse! */
17162 case FFEINFO_kindSUBROUTINE
:
17163 *paren_type
= FFEEXPR_parentypeANY_
;
17164 bad
= TRUE
; /* Cannot possibly be in
17165 contextSUBROUTINEREF. */
17168 case FFEINFO_kindENTITY
:
17169 if (ffesymbol_rank (s
) == 0)
17171 if (ffeexpr_stack_
->context
== FFEEXPR_contextEQUIVALENCE
)
17172 *paren_type
= FFEEXPR_parentypeEQUIVALENCE_
;
17173 else if (ffesymbol_basictype (s
) == FFEINFO_basictypeCHARACTER
)
17174 *paren_type
= FFEEXPR_parentypeSUBSTRING_
;
17178 *paren_type
= FFEEXPR_parentypeANY_
;
17182 *paren_type
= FFEEXPR_parentypeARRAY_
;
17186 case FFEINFO_kindANY
:
17188 *paren_type
= FFEEXPR_parentypeANY_
;
17194 if (k
== FFEINFO_kindANY
)
17197 ffesymbol_error (s
, t
);
17203 assert ("bad symbol state" == NULL
);
17208 /* Have FOO in XYZ = ...FOO(...).... Executable context only. */
17211 ffeexpr_paren_rhs_let_ (ffesymbol s
, ffelexToken t
)
17216 ffeinfoWhere where
;
17218 ffeintrinSpec spec
;
17220 bool maybe_ambig
= FALSE
;
17221 bool error
= FALSE
;
17223 assert ((ffesymbol_state (s
) == FFESYMBOL_stateNONE
)
17224 || (ffesymbol_state (s
) == FFESYMBOL_stateUNCERTAIN
));
17226 na
= sa
= ffesymbol_attrs (s
);
17228 assert (!(sa
& ~(FFESYMBOL_attrsACTUALARG
17229 | FFESYMBOL_attrsADJUSTABLE
17230 | FFESYMBOL_attrsANYLEN
17231 | FFESYMBOL_attrsARRAY
17232 | FFESYMBOL_attrsDUMMY
17233 | FFESYMBOL_attrsEXTERNAL
17234 | FFESYMBOL_attrsSFARG
17235 | FFESYMBOL_attrsTYPE
)));
17237 kind
= ffesymbol_kind (s
);
17238 where
= ffesymbol_where (s
);
17240 /* Figure out what kind of object we've got based on previous declarations
17241 of or references to the object. */
17243 if (sa
& FFESYMBOL_attrsEXTERNAL
)
17245 assert (!(sa
& ~(FFESYMBOL_attrsACTUALARG
17246 | FFESYMBOL_attrsDUMMY
17247 | FFESYMBOL_attrsEXTERNAL
17248 | FFESYMBOL_attrsTYPE
)));
17250 if (sa
& FFESYMBOL_attrsTYPE
)
17251 where
= FFEINFO_whereGLOBAL
;
17255 kind
= FFEINFO_kindFUNCTION
;
17257 if (sa
& FFESYMBOL_attrsDUMMY
)
17259 else if (sa
& FFESYMBOL_attrsACTUALARG
)
17260 ; /* Not DUMMY or TYPE. */
17261 else /* Not ACTUALARG, DUMMY, or TYPE. */
17262 where
= FFEINFO_whereGLOBAL
;
17265 else if (sa
& FFESYMBOL_attrsDUMMY
)
17267 assert (!(sa
& FFESYMBOL_attrsEXTERNAL
)); /* Handled above. */
17268 assert (!(sa
& ~(FFESYMBOL_attrsDUMMY
17269 | FFESYMBOL_attrsEXTERNAL
17270 | FFESYMBOL_attrsTYPE
)));
17272 kind
= FFEINFO_kindFUNCTION
;
17273 maybe_ambig
= TRUE
; /* If basictypeCHARACTER, can't be sure; kind
17274 could be ENTITY w/substring ref. */
17276 else if (sa
& FFESYMBOL_attrsARRAY
)
17278 assert (!(sa
& ~(FFESYMBOL_attrsARRAY
17279 | FFESYMBOL_attrsADJUSTABLE
17280 | FFESYMBOL_attrsTYPE
)));
17282 where
= FFEINFO_whereLOCAL
;
17284 else if (sa
& FFESYMBOL_attrsSFARG
)
17286 assert (!(sa
& ~(FFESYMBOL_attrsSFARG
17287 | FFESYMBOL_attrsTYPE
)));
17289 where
= FFEINFO_whereLOCAL
; /* Actually an error, but at least we
17290 know it's a local var. */
17292 else if (sa
& FFESYMBOL_attrsTYPE
)
17294 assert (!(sa
& (FFESYMBOL_attrsARRAY
17295 | FFESYMBOL_attrsDUMMY
17296 | FFESYMBOL_attrsEXTERNAL
17297 | FFESYMBOL_attrsSFARG
))); /* Handled above. */
17298 assert (!(sa
& ~(FFESYMBOL_attrsTYPE
17299 | FFESYMBOL_attrsADJUSTABLE
17300 | FFESYMBOL_attrsANYLEN
17301 | FFESYMBOL_attrsARRAY
17302 | FFESYMBOL_attrsDUMMY
17303 | FFESYMBOL_attrsEXTERNAL
17304 | FFESYMBOL_attrsSFARG
)));
17306 if (ffeintrin_is_intrinsic (ffesymbol_text (s
), t
, FALSE
,
17307 &gen
, &spec
, &imp
))
17309 if (!(sa
& FFESYMBOL_attrsANYLEN
)
17310 && (ffeimplic_peek_symbol_type (s
, NULL
)
17311 == FFEINFO_basictypeCHARACTER
))
17312 return s
; /* Haven't learned anything yet. */
17314 ffesymbol_signal_change (s
); /* May need to back up to previous
17316 ffesymbol_set_generic (s
, gen
);
17317 ffesymbol_set_specific (s
, spec
);
17318 ffesymbol_set_implementation (s
, imp
);
17319 ffesymbol_set_info (s
,
17320 ffeinfo_new (ffesymbol_basictype (s
),
17321 ffesymbol_kindtype (s
),
17323 FFEINFO_kindFUNCTION
,
17324 FFEINFO_whereINTRINSIC
,
17325 ffesymbol_size (s
)));
17326 ffesymbol_set_state (s
, FFESYMBOL_stateUNDERSTOOD
);
17327 ffesymbol_resolve_intrin (s
);
17328 ffesymbol_reference (s
, t
, FALSE
);
17329 s
= ffecom_sym_learned (s
);
17330 ffesymbol_signal_unreported (s
); /* For debugging purposes. */
17334 if (sa
& FFESYMBOL_attrsANYLEN
)
17335 error
= TRUE
; /* Error, since the only way we can,
17336 given CHARACTER*(*) FOO, accept
17337 FOO(...) is for FOO to be a dummy
17338 arg or constant, but it can't
17339 become either now. */
17340 else if (sa
& FFESYMBOL_attrsADJUSTABLE
)
17342 kind
= FFEINFO_kindENTITY
;
17343 where
= FFEINFO_whereLOCAL
;
17347 kind
= FFEINFO_kindFUNCTION
;
17348 where
= FFEINFO_whereGLOBAL
;
17349 maybe_ambig
= TRUE
; /* If basictypeCHARACTER, can't be sure;
17350 could be ENTITY/LOCAL w/substring ref. */
17353 else if (sa
== FFESYMBOL_attrsetNONE
)
17355 assert (ffesymbol_state (s
) == FFESYMBOL_stateNONE
);
17357 if (ffeintrin_is_intrinsic (ffesymbol_text (s
), t
, FALSE
,
17358 &gen
, &spec
, &imp
))
17360 if (ffeimplic_peek_symbol_type (s
, NULL
)
17361 == FFEINFO_basictypeCHARACTER
)
17362 return s
; /* Haven't learned anything yet. */
17364 ffesymbol_signal_change (s
); /* May need to back up to previous
17366 ffesymbol_set_generic (s
, gen
);
17367 ffesymbol_set_specific (s
, spec
);
17368 ffesymbol_set_implementation (s
, imp
);
17369 ffesymbol_set_info (s
,
17370 ffeinfo_new (ffesymbol_basictype (s
),
17371 ffesymbol_kindtype (s
),
17373 FFEINFO_kindFUNCTION
,
17374 FFEINFO_whereINTRINSIC
,
17375 ffesymbol_size (s
)));
17376 ffesymbol_set_state (s
, FFESYMBOL_stateUNDERSTOOD
);
17377 ffesymbol_resolve_intrin (s
);
17378 s
= ffecom_sym_learned (s
);
17379 ffesymbol_reference (s
, t
, FALSE
);
17380 ffesymbol_signal_unreported (s
); /* For debugging purposes. */
17384 kind
= FFEINFO_kindFUNCTION
;
17385 where
= FFEINFO_whereGLOBAL
;
17386 maybe_ambig
= TRUE
; /* If basictypeCHARACTER, can't be sure;
17387 could be ENTITY/LOCAL w/substring ref. */
17392 /* Now see what we've got for a new object: NONE means a new error cropped
17393 up; ANY means an old error to be ignored; otherwise, everything's ok,
17394 update the object (symbol) and continue on. */
17397 ffesymbol_error (s
, t
);
17398 else if (!(na
& FFESYMBOL_attrsANY
))
17400 ffesymbol_signal_change (s
); /* May need to back up to previous
17402 if (!ffeimplic_establish_symbol (s
))
17404 ffesymbol_error (s
, t
);
17408 && (ffesymbol_basictype (s
) == FFEINFO_basictypeCHARACTER
))
17409 return s
; /* Still not sure, let caller deal with it
17412 ffesymbol_set_info (s
,
17413 ffeinfo_new (ffesymbol_basictype (s
),
17414 ffesymbol_kindtype (s
),
17415 ffesymbol_rank (s
),
17418 ffesymbol_size (s
)));
17419 ffesymbol_set_state (s
, FFESYMBOL_stateUNDERSTOOD
);
17420 ffesymbol_resolve_intrin (s
);
17421 s
= ffecom_sym_learned (s
);
17422 ffesymbol_reference (s
, t
, FALSE
);
17423 ffesymbol_signal_unreported (s
); /* For debugging purposes. */
17429 /* ffeexpr_token_arguments_ -- OPEN_PAREN [expr COMMA]...expr
17431 Return a pointer to this function to the lexer (ffelex), which will
17432 invoke it for the next token.
17434 Handle expression (which might be null) and COMMA or CLOSE_PAREN. */
17436 static ffelexHandler
17437 ffeexpr_token_arguments_ (ffelexToken ft
, ffebld expr
, ffelexToken t
)
17439 ffeexprExpr_ procedure
;
17442 ffeexprContext ctx
;
17443 bool check_intrin
= FALSE
; /* Set TRUE if intrinsic is REAL(Z) or AIMAG(Z). */
17445 procedure
= ffeexpr_stack_
->exprstack
;
17446 info
= ffebld_info (procedure
->u
.operand
);
17448 /* Is there an expression to add? If the expression is nil,
17449 it might still be an argument. It is if:
17451 - The current token is comma, or
17453 - The -fugly-comma flag was specified *and* the procedure
17454 being invoked is external.
17456 Otherwise, if neither of the above is the case, just
17457 ignore this (nil) expression. */
17460 || (ffelex_token_type (t
) == FFELEX_typeCOMMA
)
17461 || (ffe_is_ugly_comma ()
17462 && (ffeinfo_where (info
) == FFEINFO_whereGLOBAL
)))
17464 /* This expression, even if nil, is apparently intended as an argument. */
17466 /* Internal procedure (CONTAINS, or statement function)? */
17468 if (ffeinfo_where (info
) == FFEINFO_whereCONSTANT
)
17471 && ffebad_start (FFEBAD_NULL_ARGUMENT
))
17473 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_
->tokens
[0]),
17474 ffelex_token_where_column (ffeexpr_stack_
->tokens
[0]));
17475 ffebad_here (1, ffelex_token_where_line (t
),
17476 ffelex_token_where_column (t
));
17484 if (ffeexpr_stack_
->next_dummy
== NULL
)
17485 { /* Report later which was the first extra argument. */
17486 if (ffeexpr_stack_
->tokens
[1] == NULL
)
17488 ffeexpr_stack_
->tokens
[1] = ffelex_token_use (ft
);
17489 ffeexpr_stack_
->num_args
= 0;
17491 ++ffeexpr_stack_
->num_args
; /* Count # of extra arguments. */
17495 if ((ffeinfo_rank (ffebld_info (expr
)) != 0)
17496 && ffebad_start (FFEBAD_ARRAY_AS_SFARG
))
17499 ffelex_token_where_line (ffeexpr_stack_
->tokens
[0]),
17500 ffelex_token_where_column (ffeexpr_stack_
->tokens
[0]));
17501 ffebad_here (1, ffelex_token_where_line (ft
),
17502 ffelex_token_where_column (ft
));
17503 ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent
17504 (ffebld_symter (ffebld_head
17505 (ffeexpr_stack_
->next_dummy
)))));
17510 expr
= ffeexpr_convert_expr (expr
, ft
,
17511 ffebld_head (ffeexpr_stack_
->next_dummy
),
17512 ffeexpr_stack_
->tokens
[0],
17513 FFEEXPR_contextLET
);
17514 ffebld_append_item (&ffeexpr_stack_
->bottom
, expr
);
17516 --ffeexpr_stack_
->num_args
; /* Count down # of args. */
17517 ffeexpr_stack_
->next_dummy
17518 = ffebld_trail (ffeexpr_stack_
->next_dummy
);
17525 && ffe_is_pedantic ()
17526 && ffebad_start (FFEBAD_NULL_ARGUMENT_W
))
17528 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_
->tokens
[0]),
17529 ffelex_token_where_column (ffeexpr_stack_
->tokens
[0]));
17530 ffebad_here (1, ffelex_token_where_line (t
),
17531 ffelex_token_where_column (t
));
17534 ffebld_append_item (&ffeexpr_stack_
->bottom
, expr
);
17538 switch (ffelex_token_type (t
))
17540 case FFELEX_typeCOMMA
:
17541 switch (ffeexpr_context_outer_ (ffeexpr_stack_
))
17543 case FFEEXPR_contextSFUNCDEF
:
17544 case FFEEXPR_contextSFUNCDEFACTUALARGEXPR_
:
17545 case FFEEXPR_contextSFUNCDEFINDEX_
:
17546 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARGEXPR_
:
17547 ctx
= FFEEXPR_contextSFUNCDEFACTUALARG_
;
17550 case FFEEXPR_contextSFUNCDEFACTUALARG_
:
17551 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
:
17552 assert ("bad context" == NULL
);
17553 ctx
= FFEEXPR_context
;
17557 ctx
= FFEEXPR_contextACTUALARG_
;
17560 return (ffelexHandler
) ffeexpr_rhs (ffeexpr_stack_
->pool
, ctx
,
17561 ffeexpr_token_arguments_
);
17567 if ((ffeinfo_where (info
) == FFEINFO_whereCONSTANT
)
17568 && (ffeexpr_stack_
->next_dummy
!= NULL
))
17569 { /* Too few arguments. */
17570 if (ffebad_start (FFEBAD_TOO_FEW_ARGUMENTS
))
17574 sprintf (num
, "%" ffebldListLength_f
"u", ffeexpr_stack_
->num_args
);
17576 ffebad_here (0, ffelex_token_where_line (t
),
17577 ffelex_token_where_column (t
));
17578 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_
->tokens
[0]),
17579 ffelex_token_where_column (ffeexpr_stack_
->tokens
[0]));
17580 ffebad_string (num
);
17581 ffebad_string (ffesymbol_text (ffesymbol_sfdummyparent (ffebld_symter
17582 (ffebld_head (ffeexpr_stack_
->next_dummy
)))));
17586 ffeexpr_stack_
->next_dummy
!= NULL
;
17587 ffeexpr_stack_
->next_dummy
17588 = ffebld_trail (ffeexpr_stack_
->next_dummy
))
17590 expr
= ffebld_new_conter (ffebld_constant_new_integerdefault_val (0));
17591 ffebld_set_info (expr
, ffeinfo_new_any ());
17592 ffebld_append_item (&ffeexpr_stack_
->bottom
, expr
);
17596 if ((ffeinfo_where (info
) == FFEINFO_whereCONSTANT
)
17597 && (ffeexpr_stack_
->tokens
[1] != NULL
))
17598 { /* Too many arguments to statement function. */
17599 if (ffebad_start (FFEBAD_TOO_MANY_ARGUMENTS
))
17603 sprintf (num
, "%" ffebldListLength_f
"u", ffeexpr_stack_
->num_args
);
17605 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_
->tokens
[1]),
17606 ffelex_token_where_column (ffeexpr_stack_
->tokens
[1]));
17607 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_
->tokens
[0]),
17608 ffelex_token_where_column (ffeexpr_stack_
->tokens
[0]));
17609 ffebad_string (num
);
17612 ffelex_token_kill (ffeexpr_stack_
->tokens
[1]);
17614 ffebld_end_list (&ffeexpr_stack_
->bottom
);
17616 if (ffebld_op (procedure
->u
.operand
) == FFEBLD_opANY
)
17618 reduced
= ffebld_new_any ();
17619 ffebld_set_info (reduced
, ffeinfo_new_any ());
17623 if (ffeexpr_stack_
->context
!= FFEEXPR_contextSUBROUTINEREF
)
17624 reduced
= ffebld_new_funcref (procedure
->u
.operand
,
17625 ffeexpr_stack_
->expr
);
17627 reduced
= ffebld_new_subrref (procedure
->u
.operand
,
17628 ffeexpr_stack_
->expr
);
17629 if (ffebld_symter_generic (procedure
->u
.operand
) != FFEINTRIN_genNONE
)
17630 ffeintrin_fulfill_generic (&reduced
, &info
, ffeexpr_stack_
->tokens
[0]);
17631 else if (ffebld_symter_specific (procedure
->u
.operand
)
17632 != FFEINTRIN_specNONE
)
17633 ffeintrin_fulfill_specific (&reduced
, &info
, &check_intrin
,
17634 ffeexpr_stack_
->tokens
[0]);
17636 ffeexpr_fulfill_call_ (&reduced
, ffeexpr_stack_
->tokens
[0]);
17638 if (ffebld_op (reduced
) != FFEBLD_opANY
)
17639 ffebld_set_info (reduced
,
17640 ffeinfo_new (ffeinfo_basictype (info
),
17641 ffeinfo_kindtype (info
),
17643 FFEINFO_kindENTITY
,
17644 FFEINFO_whereFLEETING
,
17645 ffeinfo_size (info
)));
17647 ffebld_set_info (reduced
, ffeinfo_new_any ());
17649 if (ffebld_op (reduced
) == FFEBLD_opFUNCREF
)
17650 reduced
= ffeexpr_collapse_funcref (reduced
, ffeexpr_stack_
->tokens
[0]);
17651 ffeexpr_stack_
->exprstack
= procedure
->previous
; /* Pops
17652 not-quite-operand off
17654 procedure
->u
.operand
= reduced
; /* Save the line/column ffewhere
17656 ffeexpr_exprstack_push_operand_ (procedure
); /* Push it back on stack. */
17657 if (ffelex_token_type (t
) == FFELEX_typeCLOSE_PAREN
)
17659 ffelex_token_kill (ffeexpr_stack_
->tokens
[0]);
17660 ffeexpr_is_substr_ok_
= FALSE
; /* Nobody likes "FUNC(3)(1:1)".... */
17662 /* If the intrinsic needs checking (is REAL(Z) or AIMAG(Z), where
17663 Z is DOUBLE COMPLEX), and a command-line option doesn't already
17664 establish interpretation, probably complain. */
17668 && !ffe_is_ugly_complex ())
17670 /* If the outer expression is REAL(me...), issue diagnostic
17671 only if next token isn't the close-paren for REAL(me). */
17673 if ((ffeexpr_stack_
->previous
!= NULL
)
17674 && (ffeexpr_stack_
->previous
->exprstack
!= NULL
)
17675 && (ffeexpr_stack_
->previous
->exprstack
->type
== FFEEXPR_exprtypeOPERAND_
)
17676 && ((reduced
= ffeexpr_stack_
->previous
->exprstack
->u
.operand
) != NULL
)
17677 && (ffebld_op (reduced
) == FFEBLD_opSYMTER
)
17678 && (ffebld_symter_implementation (reduced
) == FFEINTRIN_impREAL
))
17679 return (ffelexHandler
) ffeexpr_token_intrincheck_
;
17681 /* Diagnose the ambiguity now. */
17683 if (ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG
))
17685 ffebad_string (ffeintrin_name_implementation
17686 (ffebld_symter_implementation
17688 (ffeexpr_stack_
->exprstack
->u
.operand
))));
17689 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_
->exprstack
->token
),
17690 ffelex_token_where_column (ffeexpr_stack_
->exprstack
->token
));
17694 return (ffelexHandler
) ffeexpr_token_substrp_
;
17697 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION
))
17699 ffebad_here (0, ffelex_token_where_line (t
),
17700 ffelex_token_where_column (t
));
17701 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_
->tokens
[0]),
17702 ffelex_token_where_column (ffeexpr_stack_
->tokens
[0]));
17705 ffelex_token_kill (ffeexpr_stack_
->tokens
[0]);
17706 ffeexpr_is_substr_ok_
= FALSE
;/* Nobody likes "FUNC(3)(1:1)".... */
17708 (ffelexHandler
) ffeexpr_find_close_paren_ (t
,
17710 ffeexpr_token_substrp_
);
17713 /* ffeexpr_token_elements_ -- OPEN_PAREN [expr COMMA]...expr
17715 Return a pointer to this array to the lexer (ffelex), which will
17716 invoke it for the next token.
17718 Handle expression and COMMA or CLOSE_PAREN. */
17720 static ffelexHandler
17721 ffeexpr_token_elements_ (ffelexToken ft
, ffebld expr
, ffelexToken t
)
17723 ffeexprExpr_ array
;
17726 ffeinfoWhere where
;
17727 ffetargetIntegerDefault val
;
17728 ffetargetIntegerDefault lval
= 0;
17729 ffetargetIntegerDefault uval
= 0;
17735 array
= ffeexpr_stack_
->exprstack
;
17736 info
= ffebld_info (array
->u
.operand
);
17738 if ((expr
== NULL
) /* && ((ffeexpr_stack_->rank != 0) ||
17739 (ffelex_token_type(t) ==
17740 FFELEX_typeCOMMA)) */ )
17742 if (ffebad_start (FFEBAD_NULL_ELEMENT
))
17744 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_
->tokens
[0]),
17745 ffelex_token_where_column (ffeexpr_stack_
->tokens
[0]));
17746 ffebad_here (1, ffelex_token_where_line (t
),
17747 ffelex_token_where_column (t
));
17750 if (ffeexpr_stack_
->rank
< ffeinfo_rank (info
))
17751 { /* Don't bother if we're going to complain
17753 expr
= ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
17754 ffebld_set_info (expr
, ffeinfo_new_any ());
17760 else if (ffeinfo_rank (info
) == 0)
17761 { /* In EQUIVALENCE context, ffeinfo_rank(info)
17763 ++ffeexpr_stack_
->rank
; /* Track anyway, may need for new VXT
17765 ffebld_append_item (&ffeexpr_stack_
->bottom
, expr
);
17769 ++ffeexpr_stack_
->rank
;
17770 if (ffeexpr_stack_
->rank
> ffeinfo_rank (info
))
17771 { /* Report later which was the first extra
17773 if (ffeexpr_stack_
->rank
== ffeinfo_rank (info
) + 1)
17774 ffeexpr_stack_
->tokens
[1] = ffelex_token_use (ft
);
17778 switch (ffeinfo_where (ffebld_info (expr
)))
17780 case FFEINFO_whereCONSTANT
:
17783 case FFEINFO_whereIMMEDIATE
:
17784 ffeexpr_stack_
->constant
= FALSE
;
17788 ffeexpr_stack_
->constant
= FALSE
;
17789 ffeexpr_stack_
->immediate
= FALSE
;
17792 if (ffebld_op (expr
) == FFEBLD_opCONTER
17793 && ffebld_kindtype (expr
) == FFEINFO_kindtypeINTEGERDEFAULT
)
17795 val
= ffebld_constant_integerdefault (ffebld_conter (expr
));
17797 lbound
= ffebld_left (ffebld_head (ffeexpr_stack_
->bound_list
));
17798 if (lbound
== NULL
)
17803 else if (ffebld_op (lbound
) == FFEBLD_opCONTER
)
17806 lval
= ffebld_constant_integerdefault (ffebld_conter (lbound
));
17811 ubound
= ffebld_right (ffebld_head (ffeexpr_stack_
->bound_list
));
17812 assert (ubound
!= NULL
);
17813 if (ffebld_op (ubound
) == FFEBLD_opCONTER
)
17816 uval
= ffebld_constant_integerdefault (ffebld_conter (ubound
));
17821 if ((lcheck
&& (val
< lval
)) || (ucheck
&& (val
> uval
)))
17823 ffebad_start (FFEBAD_RANGE_ARRAY
);
17824 ffebad_here (0, ffelex_token_where_line (ft
),
17825 ffelex_token_where_column (ft
));
17829 ffebld_append_item (&ffeexpr_stack_
->bottom
, expr
);
17830 ffeexpr_stack_
->bound_list
= ffebld_trail (ffeexpr_stack_
->bound_list
);
17834 switch (ffelex_token_type (t
))
17836 case FFELEX_typeCOMMA
:
17837 switch (ffeexpr_context_outer_ (ffeexpr_stack_
))
17839 case FFEEXPR_contextDATAIMPDOITEM_
:
17840 return (ffelexHandler
) ffeexpr_rhs (ffeexpr_stack_
->pool
,
17841 FFEEXPR_contextDATAIMPDOINDEX_
,
17842 ffeexpr_token_elements_
);
17844 case FFEEXPR_contextEQUIVALENCE
:
17845 return (ffelexHandler
) ffeexpr_rhs (ffeexpr_stack_
->pool
,
17846 FFEEXPR_contextEQVINDEX_
,
17847 ffeexpr_token_elements_
);
17849 case FFEEXPR_contextSFUNCDEF
:
17850 case FFEEXPR_contextSFUNCDEFINDEX_
:
17851 return (ffelexHandler
) ffeexpr_rhs (ffeexpr_stack_
->pool
,
17852 FFEEXPR_contextSFUNCDEFINDEX_
,
17853 ffeexpr_token_elements_
);
17855 case FFEEXPR_contextSFUNCDEFACTUALARG_
:
17856 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
:
17857 assert ("bad context" == NULL
);
17861 return (ffelexHandler
) ffeexpr_rhs (ffeexpr_stack_
->pool
,
17862 FFEEXPR_contextINDEX_
,
17863 ffeexpr_token_elements_
);
17870 if ((ffeexpr_stack_
->rank
!= ffeinfo_rank (info
))
17871 && (ffeinfo_rank (info
) != 0))
17875 if (ffeexpr_stack_
->rank
< ffeinfo_rank (info
))
17877 if (ffebad_start (FFEBAD_TOO_FEW_ELEMENTS
))
17879 sprintf (num
, "%d",
17880 (int) (ffeinfo_rank (info
) - ffeexpr_stack_
->rank
));
17882 ffebad_here (0, ffelex_token_where_line (t
),
17883 ffelex_token_where_column (t
));
17885 ffelex_token_where_line (ffeexpr_stack_
->tokens
[0]),
17886 ffelex_token_where_column (ffeexpr_stack_
->tokens
[0]));
17887 ffebad_string (num
);
17893 if (ffebad_start (FFEBAD_TOO_MANY_ELEMENTS
))
17895 sprintf (num
, "%d",
17896 (int) (ffeexpr_stack_
->rank
- ffeinfo_rank (info
)));
17899 ffelex_token_where_line (ffeexpr_stack_
->tokens
[1]),
17900 ffelex_token_where_column (ffeexpr_stack_
->tokens
[1]));
17902 ffelex_token_where_line (ffeexpr_stack_
->tokens
[0]),
17903 ffelex_token_where_column (ffeexpr_stack_
->tokens
[0]));
17904 ffebad_string (num
);
17907 ffelex_token_kill (ffeexpr_stack_
->tokens
[1]);
17909 while (ffeexpr_stack_
->rank
++ < ffeinfo_rank (info
))
17911 expr
= ffebld_new_conter (ffebld_constant_new_integerdefault_val (1));
17912 ffebld_set_info (expr
, ffeinfo_new (FFEINFO_basictypeINTEGER
,
17913 FFEINFO_kindtypeINTEGERDEFAULT
,
17914 0, FFEINFO_kindENTITY
,
17915 FFEINFO_whereCONSTANT
,
17916 FFETARGET_charactersizeNONE
));
17917 ffebld_append_item (&ffeexpr_stack_
->bottom
, expr
);
17920 ffebld_end_list (&ffeexpr_stack_
->bottom
);
17922 if (ffebld_op (array
->u
.operand
) == FFEBLD_opANY
)
17924 reduced
= ffebld_new_any ();
17925 ffebld_set_info (reduced
, ffeinfo_new_any ());
17929 reduced
= ffebld_new_arrayref (array
->u
.operand
, ffeexpr_stack_
->expr
);
17930 if (ffeexpr_stack_
->constant
)
17931 where
= FFEINFO_whereFLEETING_CADDR
;
17932 else if (ffeexpr_stack_
->immediate
)
17933 where
= FFEINFO_whereFLEETING_IADDR
;
17935 where
= FFEINFO_whereFLEETING
;
17936 ffebld_set_info (reduced
,
17937 ffeinfo_new (ffeinfo_basictype (info
),
17938 ffeinfo_kindtype (info
),
17940 FFEINFO_kindENTITY
,
17942 ffeinfo_size (info
)));
17943 reduced
= ffeexpr_collapse_arrayref (reduced
, ffeexpr_stack_
->tokens
[0]);
17946 ffeexpr_stack_
->exprstack
= array
->previous
; /* Pops not-quite-operand off
17948 array
->u
.operand
= reduced
; /* Save the line/column ffewhere info. */
17949 ffeexpr_exprstack_push_operand_ (array
); /* Push it back on stack. */
17951 switch (ffeinfo_basictype (info
))
17953 case FFEINFO_basictypeCHARACTER
:
17954 ffeexpr_is_substr_ok_
= TRUE
; /* Everyone likes "FOO(3)(1:1)".... */
17957 case FFEINFO_basictypeNONE
:
17958 ffeexpr_is_substr_ok_
= TRUE
;
17959 assert (ffeexpr_stack_
->context
== FFEEXPR_contextEQUIVALENCE
);
17963 ffeexpr_is_substr_ok_
= FALSE
;
17967 if (ffelex_token_type (t
) == FFELEX_typeCLOSE_PAREN
)
17969 ffelex_token_kill (ffeexpr_stack_
->tokens
[0]);
17970 return (ffelexHandler
) ffeexpr_token_substrp_
;
17973 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION
))
17975 ffebad_here (0, ffelex_token_where_line (t
),
17976 ffelex_token_where_column (t
));
17977 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_
->tokens
[0]),
17978 ffelex_token_where_column (ffeexpr_stack_
->tokens
[0]));
17981 ffelex_token_kill (ffeexpr_stack_
->tokens
[0]);
17983 (ffelexHandler
) ffeexpr_find_close_paren_ (t
,
17985 ffeexpr_token_substrp_
);
17988 /* ffeexpr_token_equivalence_ -- OPEN_PAREN expr
17990 Return a pointer to this array to the lexer (ffelex), which will
17991 invoke it for the next token.
17993 If token is COLON, pass off to _substr_, else init list and pass off
17994 to _elements_. This handles the case "EQUIVALENCE (FOO(expr?", where
17995 ? marks the token, and where FOO's rank/type has not yet been established,
17996 meaning we could be in a list of indices or in a substring
17999 static ffelexHandler
18000 ffeexpr_token_equivalence_ (ffelexToken ft
, ffebld expr
, ffelexToken t
)
18002 if (ffelex_token_type (t
) == FFELEX_typeCOLON
)
18003 return ffeexpr_token_substring_ (ft
, expr
, t
);
18005 ffebld_init_list (&ffeexpr_stack_
->expr
, &ffeexpr_stack_
->bottom
);
18006 return ffeexpr_token_elements_ (ft
, expr
, t
);
18009 /* ffeexpr_token_substring_ -- NAME(of kindENTITY) OPEN_PAREN expr
18011 Return a pointer to this function to the lexer (ffelex), which will
18012 invoke it for the next token.
18014 Handle expression (which may be null) and COLON. */
18016 static ffelexHandler
18017 ffeexpr_token_substring_ (ffelexToken ft
, ffebld expr
, ffelexToken t
)
18019 ffeexprExpr_ string
;
18021 ffetargetIntegerDefault i
;
18022 ffeexprContext ctx
;
18023 ffetargetCharacterSize size
;
18025 string
= ffeexpr_stack_
->exprstack
;
18026 info
= ffebld_info (string
->u
.operand
);
18027 size
= ffebld_size_max (string
->u
.operand
);
18029 if (ffelex_token_type (t
) == FFELEX_typeCOLON
)
18032 && (ffebld_op (expr
) == FFEBLD_opCONTER
)
18033 && (((i
= ffebld_constant_integerdefault (ffebld_conter (expr
)))
18035 || ((size
!= FFETARGET_charactersizeNONE
) && (i
> size
))))
18037 ffebad_start (FFEBAD_RANGE_SUBSTR
);
18038 ffebad_here (0, ffelex_token_where_line (ft
),
18039 ffelex_token_where_column (ft
));
18042 ffeexpr_stack_
->expr
= expr
;
18044 switch (ffeexpr_stack_
->context
)
18046 case FFEEXPR_contextSFUNCDEF
:
18047 case FFEEXPR_contextSFUNCDEFINDEX_
:
18048 ctx
= FFEEXPR_contextSFUNCDEFINDEX_
;
18051 case FFEEXPR_contextSFUNCDEFACTUALARG_
:
18052 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
:
18053 assert ("bad context" == NULL
);
18054 ctx
= FFEEXPR_context
;
18058 ctx
= FFEEXPR_contextINDEX_
;
18062 return (ffelexHandler
) ffeexpr_rhs (ffeexpr_stack_
->pool
, ctx
,
18063 ffeexpr_token_substring_1_
);
18066 if (ffest_ffebad_start (FFEBAD_MISSING_COLON_IN_SUBSTR
))
18068 ffebad_here (0, ffelex_token_where_line (t
),
18069 ffelex_token_where_column (t
));
18070 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_
->tokens
[0]),
18071 ffelex_token_where_column (ffeexpr_stack_
->tokens
[0]));
18075 ffeexpr_stack_
->expr
= NULL
;
18076 return (ffelexHandler
) ffeexpr_token_substring_1_ (ft
, expr
, t
);
18079 /* ffeexpr_token_substring_1_ -- NAME OPEN_PAREN [expr COMMA]...expr
18081 Return a pointer to this function to the lexer (ffelex), which will
18082 invoke it for the next token.
18084 Handle expression (which might be null) and CLOSE_PAREN. */
18086 static ffelexHandler
18087 ffeexpr_token_substring_1_ (ffelexToken ft
, ffebld last
, ffelexToken t
)
18089 ffeexprExpr_ string
;
18092 ffebld first
= ffeexpr_stack_
->expr
;
18097 ffeinfoWhere where
;
18098 ffeinfoKindtype first_kt
;
18099 ffeinfoKindtype last_kt
;
18100 ffetargetIntegerDefault first_val
;
18101 ffetargetIntegerDefault last_val
;
18102 ffetargetCharacterSize size
;
18103 ffetargetCharacterSize strop_size_max
;
18106 string
= ffeexpr_stack_
->exprstack
;
18107 strop
= string
->u
.operand
;
18108 info
= ffebld_info (strop
);
18111 || (ffebld_op (first
) == FFEBLD_opCONTER
18112 && ffebld_kindtype (first
) == FFEINFO_kindtypeINTEGERDEFAULT
))
18113 { /* The starting point is known. */
18114 first_val
= (first
== NULL
) ? 1
18115 : ffebld_constant_integerdefault (ffebld_conter (first
));
18116 first_known
= TRUE
;
18119 { /* Assume start of the entity. */
18121 first_known
= FALSE
;
18125 && (ffebld_op (last
) == FFEBLD_opCONTER
18126 && ffebld_kindtype (last
) == FFEINFO_kindtypeINTEGERDEFAULT
))
18127 { /* The ending point is known. */
18128 last_val
= ffebld_constant_integerdefault (ffebld_conter (last
));
18131 { /* The beginning point is a constant. */
18132 if (first_val
<= last_val
)
18133 size
= last_val
- first_val
+ 1;
18136 if (0 && ffe_is_90 ())
18141 ffebad_start (FFEBAD_ZERO_SIZE
);
18142 ffebad_here (0, ffelex_token_where_line (ft
),
18143 ffelex_token_where_column (ft
));
18149 size
= FFETARGET_charactersizeNONE
;
18151 strop_size_max
= ffebld_size_max (strop
);
18153 if ((strop_size_max
!= FFETARGET_charactersizeNONE
)
18154 && (last_val
> strop_size_max
))
18155 { /* Beyond maximum possible end of string. */
18156 ffebad_start (FFEBAD_RANGE_SUBSTR
);
18157 ffebad_here (0, ffelex_token_where_line (ft
),
18158 ffelex_token_where_column (ft
));
18163 size
= FFETARGET_charactersizeNONE
; /* The size is not known. */
18165 #if 0 /* Don't do this, or "is size of target
18166 known?" would no longer be easily
18167 answerable. To see if there is a max
18168 size, use ffebld_size_max; to get only the
18169 known size, else NONE, use
18170 ffebld_size_known; use ffebld_size if
18171 values are sure to be the same (not
18172 opSUBSTR or opCONCATENATE or known to have
18173 known length). By getting rid of this
18174 "useful info" stuff, we don't end up
18175 blank-padding the constant in the
18176 assignment "A(I:J)='XYZ'" to the known
18178 if (size
== FFETARGET_charactersizeNONE
)
18179 size
= strop_size_max
; /* Assume we use the entire string. */
18193 lwh
= FFEINFO_whereCONSTANT
;
18195 lwh
= ffeinfo_where (ffebld_info (first
));
18197 rwh
= FFEINFO_whereCONSTANT
;
18199 rwh
= ffeinfo_where (ffebld_info (last
));
18203 case FFEINFO_whereCONSTANT
:
18206 case FFEINFO_whereCONSTANT
:
18207 where
= FFEINFO_whereCONSTANT
;
18210 case FFEINFO_whereIMMEDIATE
:
18211 where
= FFEINFO_whereIMMEDIATE
;
18215 where
= FFEINFO_whereFLEETING
;
18220 case FFEINFO_whereIMMEDIATE
:
18223 case FFEINFO_whereCONSTANT
:
18224 case FFEINFO_whereIMMEDIATE
:
18225 where
= FFEINFO_whereIMMEDIATE
;
18229 where
= FFEINFO_whereFLEETING
;
18235 where
= FFEINFO_whereFLEETING
;
18240 first_kt
= FFEINFO_kindtypeINTEGERDEFAULT
;
18242 first_kt
= ffeinfo_kindtype (ffebld_info (first
));
18244 last_kt
= FFEINFO_kindtypeINTEGERDEFAULT
;
18246 last_kt
= ffeinfo_kindtype (ffebld_info (last
));
18250 case FFEINFO_whereCONSTANT
:
18251 switch (ffeinfo_where (info
))
18253 case FFEINFO_whereCONSTANT
:
18256 case FFEINFO_whereIMMEDIATE
: /* Not possible, actually. */
18257 where
= FFEINFO_whereIMMEDIATE
;
18261 where
= FFEINFO_whereFLEETING_CADDR
;
18266 case FFEINFO_whereIMMEDIATE
:
18267 switch (ffeinfo_where (info
))
18269 case FFEINFO_whereCONSTANT
:
18270 case FFEINFO_whereIMMEDIATE
: /* Not possible, actually. */
18274 where
= FFEINFO_whereFLEETING_IADDR
;
18280 switch (ffeinfo_where (info
))
18282 case FFEINFO_whereCONSTANT
:
18283 where
= FFEINFO_whereCONSTANT_SUBOBJECT
; /* An F90 concept. */
18286 case FFEINFO_whereIMMEDIATE
: /* Not possible, actually. */
18288 where
= FFEINFO_whereFLEETING
;
18294 if (ffebld_op (strop
) == FFEBLD_opANY
)
18296 reduced
= ffebld_new_any ();
18297 ffebld_set_info (reduced
, ffeinfo_new_any ());
18301 reduced
= ffebld_new_substr (strop
, substrlist
);
18302 ffebld_set_info (reduced
, ffeinfo_new
18303 (FFEINFO_basictypeCHARACTER
,
18304 ffeinfo_kindtype (info
),
18306 FFEINFO_kindENTITY
,
18309 reduced
= ffeexpr_collapse_substr (reduced
, ffeexpr_stack_
->tokens
[0]);
18312 ffeexpr_stack_
->exprstack
= string
->previous
; /* Pops not-quite-operand off
18314 string
->u
.operand
= reduced
; /* Save the line/column ffewhere info. */
18315 ffeexpr_exprstack_push_operand_ (string
); /* Push it back on stack. */
18317 if (ffelex_token_type (t
) == FFELEX_typeCLOSE_PAREN
)
18319 ffelex_token_kill (ffeexpr_stack_
->tokens
[0]);
18320 ffeexpr_is_substr_ok_
= FALSE
; /* Nobody likes "FOO(3:5)(1:1)".... */
18321 return (ffelexHandler
) ffeexpr_token_substrp_
;
18324 if (ffest_ffebad_start (FFEBAD_INVALID_TOKEN_IN_EXPRESSION
))
18326 ffebad_here (0, ffelex_token_where_line (t
),
18327 ffelex_token_where_column (t
));
18328 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_
->tokens
[0]),
18329 ffelex_token_where_column (ffeexpr_stack_
->tokens
[0]));
18333 ffelex_token_kill (ffeexpr_stack_
->tokens
[0]);
18334 ffeexpr_is_substr_ok_
= FALSE
;/* Nobody likes "FOO(3:5)(1:1)".... */
18336 (ffelexHandler
) ffeexpr_find_close_paren_ (t
,
18338 ffeexpr_token_substrp_
);
18341 /* ffeexpr_token_substrp_ -- Rhs <character entity>
18343 Return a pointer to this function to the lexer (ffelex), which will
18344 invoke it for the next token.
18346 If OPEN_PAREN, treat as start of a substring ("(3:4)") construct, and
18347 issue error message if flag (serves as argument) is set. Else, just
18348 forward token to binary_. */
18350 static ffelexHandler
18351 ffeexpr_token_substrp_ (ffelexToken t
)
18353 ffeexprContext ctx
;
18355 if (ffelex_token_type (t
) != FFELEX_typeOPEN_PAREN
)
18356 return (ffelexHandler
) ffeexpr_token_binary_ (t
);
18358 ffeexpr_stack_
->tokens
[0] = ffelex_token_use (t
);
18360 switch (ffeexpr_stack_
->context
)
18362 case FFEEXPR_contextSFUNCDEF
:
18363 case FFEEXPR_contextSFUNCDEFINDEX_
:
18364 ctx
= FFEEXPR_contextSFUNCDEFINDEX_
;
18367 case FFEEXPR_contextSFUNCDEFACTUALARG_
:
18368 case FFEEXPR_contextSFUNCDEFINDEXORACTUALARG_
:
18369 assert ("bad context" == NULL
);
18370 ctx
= FFEEXPR_context
;
18374 ctx
= FFEEXPR_contextINDEX_
;
18378 if (!ffeexpr_is_substr_ok_
)
18380 if (ffebad_start (FFEBAD_BAD_SUBSTR
))
18382 ffebad_here (0, ffelex_token_where_line (t
),
18383 ffelex_token_where_column (t
));
18384 ffebad_here (1, ffelex_token_where_line (ffeexpr_stack_
->exprstack
->token
),
18385 ffelex_token_where_column (ffeexpr_stack_
->exprstack
->token
));
18389 return (ffelexHandler
) ffeexpr_rhs (ffeexpr_stack_
->pool
, ctx
,
18390 ffeexpr_token_anything_
);
18393 return (ffelexHandler
) ffeexpr_rhs (ffeexpr_stack_
->pool
, ctx
,
18394 ffeexpr_token_substring_
);
18397 static ffelexHandler
18398 ffeexpr_token_intrincheck_ (ffelexToken t
)
18400 if ((ffelex_token_type (t
) != FFELEX_typeCLOSE_PAREN
)
18401 && ffebad_start (FFEBAD_INTRINSIC_CMPAMBIG
))
18403 ffebad_string (ffeintrin_name_implementation
18404 (ffebld_symter_implementation
18406 (ffeexpr_stack_
->exprstack
->u
.operand
))));
18407 ffebad_here (0, ffelex_token_where_line (ffeexpr_stack_
->exprstack
->token
),
18408 ffelex_token_where_column (ffeexpr_stack_
->exprstack
->token
));
18412 return (ffelexHandler
) ffeexpr_token_substrp_ (t
);
18415 /* ffeexpr_token_funsubstr_ -- NAME OPEN_PAREN expr
18417 Return a pointer to this function to the lexer (ffelex), which will
18418 invoke it for the next token.
18420 If COLON, do everything we would have done since _parenthesized_ if
18421 we had known NAME represented a kindENTITY instead of a kindFUNCTION.
18422 If not COLON, do likewise for kindFUNCTION instead. */
18424 static ffelexHandler
18425 ffeexpr_token_funsubstr_ (ffelexToken ft
, ffebld expr
, ffelexToken t
)
18427 ffeinfoWhere where
;
18430 ffebld symter
= ffeexpr_stack_
->exprstack
->u
.operand
;
18433 ffeintrinSpec spec
;
18436 s
= ffebld_symter (symter
);
18437 sa
= ffesymbol_attrs (s
);
18438 where
= ffesymbol_where (s
);
18440 /* We get here only if we don't already know enough about FOO when seeing a
18441 FOO(stuff) reference, and FOO might turn out to be a CHARACTER type. If
18442 "stuff" is a substring reference, then FOO is a CHARACTER scalar type.
18443 Else FOO is a function, either intrinsic or external. If intrinsic, it
18444 wouldn't necessarily be CHARACTER type, so unless it has already been
18445 declared DUMMY, it hasn't had its type established yet. It can't be
18446 CHAR*(*) in any case, though it can have an explicit CHAR*n type. */
18448 assert (!(sa
& ~(FFESYMBOL_attrsDUMMY
18449 | FFESYMBOL_attrsTYPE
)));
18451 needs_type
= !(ffesymbol_attrs (s
) & FFESYMBOL_attrsDUMMY
);
18453 ffesymbol_signal_change (s
); /* Probably already done, but in case.... */
18455 if (ffelex_token_type (t
) == FFELEX_typeCOLON
)
18456 { /* Definitely an ENTITY (char substring). */
18457 if (needs_type
&& !ffeimplic_establish_symbol (s
))
18459 ffesymbol_error (s
, ffeexpr_stack_
->tokens
[0]);
18460 return (ffelexHandler
) ffeexpr_token_arguments_ (ft
, expr
, t
);
18463 ffesymbol_set_info (s
,
18464 ffeinfo_new (ffesymbol_basictype (s
),
18465 ffesymbol_kindtype (s
),
18466 ffesymbol_rank (s
),
18467 FFEINFO_kindENTITY
,
18468 (where
== FFEINFO_whereNONE
)
18469 ? FFEINFO_whereLOCAL
18471 ffesymbol_size (s
)));
18472 ffebld_set_info (symter
, ffeinfo_use (ffesymbol_info (s
)));
18474 ffesymbol_set_state (s
, FFESYMBOL_stateUNDERSTOOD
);
18475 ffesymbol_resolve_intrin (s
);
18476 s
= ffecom_sym_learned (s
);
18477 ffesymbol_signal_unreported (s
); /* For debugging purposes. */
18479 ffeexpr_stack_
->exprstack
->u
.operand
18480 = ffeexpr_collapse_symter (symter
, ffeexpr_tokens_
[0]);
18482 return (ffelexHandler
) ffeexpr_token_substring_ (ft
, expr
, t
);
18485 /* The "stuff" isn't a substring notation, so we now know the overall
18486 reference is to a function. */
18488 if (ffeintrin_is_intrinsic (ffesymbol_text (s
), ffeexpr_stack_
->tokens
[0],
18489 FALSE
, &gen
, &spec
, &imp
))
18491 ffebld_symter_set_generic (symter
, gen
);
18492 ffebld_symter_set_specific (symter
, spec
);
18493 ffebld_symter_set_implementation (symter
, imp
);
18494 ffesymbol_set_generic (s
, gen
);
18495 ffesymbol_set_specific (s
, spec
);
18496 ffesymbol_set_implementation (s
, imp
);
18497 ffesymbol_set_info (s
,
18498 ffeinfo_new (ffesymbol_basictype (s
),
18499 ffesymbol_kindtype (s
),
18501 FFEINFO_kindFUNCTION
,
18502 FFEINFO_whereINTRINSIC
,
18503 ffesymbol_size (s
)));
18506 { /* Not intrinsic, now needs CHAR type. */
18507 if (!ffeimplic_establish_symbol (s
))
18509 ffesymbol_error (s
, ffeexpr_stack_
->tokens
[0]);
18510 return (ffelexHandler
) ffeexpr_token_arguments_ (ft
, expr
, t
);
18513 ffesymbol_set_info (s
,
18514 ffeinfo_new (ffesymbol_basictype (s
),
18515 ffesymbol_kindtype (s
),
18516 ffesymbol_rank (s
),
18517 FFEINFO_kindFUNCTION
,
18518 (where
== FFEINFO_whereNONE
)
18519 ? FFEINFO_whereGLOBAL
18521 ffesymbol_size (s
)));
18524 ffebld_set_info (symter
, ffeinfo_use (ffesymbol_info (s
)));
18526 ffesymbol_set_state (s
, FFESYMBOL_stateUNDERSTOOD
);
18527 ffesymbol_resolve_intrin (s
);
18528 s
= ffecom_sym_learned (s
);
18529 ffesymbol_reference (s
, ffeexpr_stack_
->tokens
[0], FALSE
);
18530 ffesymbol_signal_unreported (s
); /* For debugging purposes. */
18531 ffebld_init_list (&ffeexpr_stack_
->expr
, &ffeexpr_stack_
->bottom
);
18532 return (ffelexHandler
) ffeexpr_token_arguments_ (ft
, expr
, t
);
18535 /* ffeexpr_token_anything_ -- NAME OPEN_PAREN any-expr
18537 Handle basically any expression, looking for CLOSE_PAREN. */
18539 static ffelexHandler
18540 ffeexpr_token_anything_ (ffelexToken ft UNUSED
, ffebld expr UNUSED
,
18543 ffeexprExpr_ e
= ffeexpr_stack_
->exprstack
;
18545 switch (ffelex_token_type (t
))
18547 case FFELEX_typeCOMMA
:
18548 case FFELEX_typeCOLON
:
18549 return (ffelexHandler
) ffeexpr_rhs (ffeexpr_stack_
->pool
,
18550 FFEEXPR_contextACTUALARG_
,
18551 ffeexpr_token_anything_
);
18554 e
->u
.operand
= ffebld_new_any ();
18555 ffebld_set_info (e
->u
.operand
, ffeinfo_new_any ());
18556 ffelex_token_kill (ffeexpr_stack_
->tokens
[0]);
18557 ffeexpr_is_substr_ok_
= FALSE
;
18558 if (ffelex_token_type (t
) == FFELEX_typeCLOSE_PAREN
)
18559 return (ffelexHandler
) ffeexpr_token_substrp_
;
18560 return (ffelexHandler
) ffeexpr_token_substrp_ (t
);
18564 /* Terminate module. */
18567 ffeexpr_terminate_2 (void)
18569 assert (ffeexpr_stack_
== NULL
);
18570 assert (ffeexpr_level_
== 0);