/gcc-2.95.2/gcc/f/expr.c
C | 17141 lines | 13729 code | 2051 blank | 1361 comment | 2451 complexity | 37669c40c33a4929d1f2149bbd001c83 MD5 | raw file
Possible License(s): GPL-2.0, LGPL-2.0
Large files files are truncated, but you can click here to view the full file
1/* expr.c -- Implementation File (module.c template V1.0)
2 Copyright (C) 1995-1998 Free Software Foundation, Inc.
3 Contributed by James Craig Burley.
4
5This file is part of GNU Fortran.
6
7GNU Fortran is free software; you can redistribute it and/or modify
8it under the terms of the GNU General Public License as published by
9the Free Software Foundation; either version 2, or (at your option)
10any later version.
11
12GNU Fortran is distributed in the hope that it will be useful,
13but WITHOUT ANY WARRANTY; without even the implied warranty of
14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15GNU General Public License for more details.
16
17You should have received a copy of the GNU General Public License
18along with GNU Fortran; see the file COPYING. If not, write to
19the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
2002111-1307, USA.
21
22 Related Modules:
23 None.
24
25 Description:
26 Handles syntactic and semantic analysis of Fortran expressions.
27
28 Modifications:
29*/
30
31/* Include files. */
32
33#include "proj.h"
34#include "expr.h"
35#include "bad.h"
36#include "bld.h"
37#include "com.h"
38#include "global.h"
39#include "implic.h"
40#include "intrin.h"
41#include "info.h"
42#include "lex.h"
43#include "malloc.h"
44#include "src.h"
45#include "st.h"
46#include "symbol.h"
47#include "str.h"
48#include "target.h"
49#include "where.h"
50
51/* Externals defined here. */
52
53
54/* Simple definitions and enumerations. */
55
56typedef enum
57 {
58 FFEEXPR_exprtypeUNKNOWN_,
59 FFEEXPR_exprtypeOPERAND_,
60 FFEEXPR_exprtypeUNARY_,
61 FFEEXPR_exprtypeBINARY_,
62 FFEEXPR_exprtype_
63 } ffeexprExprtype_;
64
65typedef enum
66 {
67 FFEEXPR_operatorPOWER_,
68 FFEEXPR_operatorMULTIPLY_,
69 FFEEXPR_operatorDIVIDE_,
70 FFEEXPR_operatorADD_,
71 FFEEXPR_operatorSUBTRACT_,
72 FFEEXPR_operatorCONCATENATE_,
73 FFEEXPR_operatorLT_,
74 FFEEXPR_operatorLE_,
75 FFEEXPR_operatorEQ_,
76 FFEEXPR_operatorNE_,
77 FFEEXPR_operatorGT_,
78 FFEEXPR_operatorGE_,
79 FFEEXPR_operatorNOT_,
80 FFEEXPR_operatorAND_,
81 FFEEXPR_operatorOR_,
82 FFEEXPR_operatorXOR_,
83 FFEEXPR_operatorEQV_,
84 FFEEXPR_operatorNEQV_,
85 FFEEXPR_operator_
86 } ffeexprOperator_;
87
88typedef enum
89 {
90 FFEEXPR_operatorprecedenceHIGHEST_ = 1,
91 FFEEXPR_operatorprecedencePOWER_ = 1,
92 FFEEXPR_operatorprecedenceMULTIPLY_ = 2,
93 FFEEXPR_operatorprecedenceDIVIDE_ = 2,
94 FFEEXPR_operatorprecedenceADD_ = 3,
95 FFEEXPR_operatorprecedenceSUBTRACT_ = 3,
96 FFEEXPR_operatorprecedenceLOWARITH_ = 3,
97 FFEEXPR_operatorprecedenceCONCATENATE_ = 3,
98 FFEEXPR_operatorprecedenceLT_ = 4,
99 FFEEXPR_operatorprecedenceLE_ = 4,
100 FFEEXPR_operatorprecedenceEQ_ = 4,
101 FFEEXPR_operatorprecedenceNE_ = 4,
102 FFEEXPR_operatorprecedenceGT_ = 4,
103 FFEEXPR_operatorprecedenceGE_ = 4,
104 FFEEXPR_operatorprecedenceNOT_ = 5,
105 FFEEXPR_operatorprecedenceAND_ = 6,
106 FFEEXPR_operatorprecedenceOR_ = 7,
107 FFEEXPR_operatorprecedenceXOR_ = 8,
108 FFEEXPR_operatorprecedenceEQV_ = 8,
109 FFEEXPR_operatorprecedenceNEQV_ = 8,
110 FFEEXPR_operatorprecedenceLOWEST_ = 8,
111 FFEEXPR_operatorprecedence_
112 } ffeexprOperatorPrecedence_;
113
114#define FFEEXPR_operatorassociativityL2R_ TRUE
115#define FFEEXPR_operatorassociativityR2L_ FALSE
116#define FFEEXPR_operatorassociativityPOWER_ FFEEXPR_operatorassociativityR2L_
117#define FFEEXPR_operatorassociativityMULTIPLY_ FFEEXPR_operatorassociativityL2R_
118#define FFEEXPR_operatorassociativityDIVIDE_ FFEEXPR_operatorassociativityL2R_
119#define FFEEXPR_operatorassociativityADD_ FFEEXPR_operatorassociativityL2R_
120#define FFEEXPR_operatorassociativitySUBTRACT_ FFEEXPR_operatorassociativityL2R_
121#define FFEEXPR_operatorassociativityCONCATENATE_ FFEEXPR_operatorassociativityL2R_
122#define FFEEXPR_operatorassociativityLT_ FFEEXPR_operatorassociativityL2R_
123#define FFEEXPR_operatorassociativityLE_ FFEEXPR_operatorassociativityL2R_
124#define FFEEXPR_operatorassociativityEQ_ FFEEXPR_operatorassociativityL2R_
125#define FFEEXPR_operatorassociativityNE_ FFEEXPR_operatorassociativityL2R_
126#define FFEEXPR_operatorassociativityGT_ FFEEXPR_operatorassociativityL2R_
127#define FFEEXPR_operatorassociativityGE_ FFEEXPR_operatorassociativityL2R_
128#define FFEEXPR_operatorassociativityNOT_ FFEEXPR_operatorassociativityL2R_
129#define FFEEXPR_operatorassociativityAND_ FFEEXPR_operatorassociativityL2R_
130#define FFEEXPR_operatorassociativityOR_ FFEEXPR_operatorassociativityL2R_
131#define FFEEXPR_operatorassociativityXOR_ FFEEXPR_operatorassociativityL2R_
132#define FFEEXPR_operatorassociativityEQV_ FFEEXPR_operatorassociativityL2R_
133#define FFEEXPR_operatorassociativityNEQV_ FFEEXPR_operatorassociativityL2R_
134
135typedef enum
136 {
137 FFEEXPR_parentypeFUNCTION_,
138 FFEEXPR_parentypeSUBROUTINE_,
139 FFEEXPR_parentypeARRAY_,
140 FFEEXPR_parentypeSUBSTRING_,
141 FFEEXPR_parentypeFUNSUBSTR_,/* Ambig: check for colon after first expr. */
142 FFEEXPR_parentypeEQUIVALENCE_, /* Ambig: ARRAY_ or SUBSTRING_. */
143 FFEEXPR_parentypeANY_, /* Allow basically anything. */
144 FFEEXPR_parentype_
145 } ffeexprParenType_;
146
147typedef enum
148 {
149 FFEEXPR_percentNONE_,
150 FFEEXPR_percentLOC_,
151 FFEEXPR_percentVAL_,
152 FFEEXPR_percentREF_,
153 FFEEXPR_percentDESCR_,
154 FFEEXPR_percent_
155 } ffeexprPercent_;
156
157/* Internal typedefs. */
158
159typedef struct _ffeexpr_expr_ *ffeexprExpr_;
160typedef bool ffeexprOperatorAssociativity_;
161typedef struct _ffeexpr_stack_ *ffeexprStack_;
162
163/* Private include files. */
164
165
166/* Internal structure definitions. */
167
168struct _ffeexpr_expr_
169 {
170 ffeexprExpr_ previous;
171 ffelexToken token;
172 ffeexprExprtype_ type;
173 union
174 {
175 struct
176 {
177 ffeexprOperator_ op;
178 ffeexprOperatorPrecedence_ prec;
179 ffeexprOperatorAssociativity_ as;
180 }
181 operator;
182 ffebld operand;
183 }
184 u;
185 };
186
187struct _ffeexpr_stack_
188 {
189 ffeexprStack_ previous;
190 mallocPool pool;
191 ffeexprContext context;
192 ffeexprCallback callback;
193 ffelexToken first_token;
194 ffeexprExpr_ exprstack;
195 ffelexToken tokens[10]; /* Used in certain cases, like (unary)
196 open-paren. */
197 ffebld expr; /* For first of
198 complex/implied-do/substring/array-elements
199 / actual-args expression. */
200 ffebld bound_list; /* For tracking dimension bounds list of
201 array. */
202 ffebldListBottom bottom; /* For building lists. */
203 ffeinfoRank rank; /* For elements in an array reference. */
204 bool constant; /* TRUE while elements seen so far are
205 constants. */
206 bool immediate; /* TRUE while elements seen so far are
207 immediate/constants. */
208 ffebld next_dummy; /* Next SFUNC dummy arg in arg list. */
209 ffebldListLength num_args; /* Number of dummy args expected in arg list. */
210 bool is_rhs; /* TRUE if rhs context, FALSE otherwise. */
211 ffeexprPercent_ percent; /* Current %FOO keyword. */
212 };
213
214struct _ffeexpr_find_
215 {
216 ffelexToken t;
217 ffelexHandler after;
218 int level;
219 };
220
221/* Static objects accessed by functions in this module. */
222
223static ffeexprStack_ ffeexpr_stack_; /* Expression stack for semantic. */
224static ffelexToken ffeexpr_tokens_[10]; /* Scratchpad tokens for syntactic. */
225static ffestrOther ffeexpr_current_dotdot_; /* Current .FOO. keyword. */
226static long ffeexpr_hollerith_count_; /* ffeexpr_token_number_ and caller. */
227static int ffeexpr_level_; /* Level of DATA implied-DO construct. */
228static bool ffeexpr_is_substr_ok_; /* If OPEN_PAREN as binary "op" ok. */
229static struct _ffeexpr_find_ ffeexpr_find_;
230
231/* Static functions (internal). */
232
233static ffelexHandler ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr,
234 ffelexToken t);
235static ffelexHandler ffeexpr_cb_close_paren_ambig_ (ffelexToken ft,
236 ffebld expr,
237 ffelexToken t);
238static ffelexHandler ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t);
239static ffelexHandler ffeexpr_cb_close_paren_c_ (ffelexToken ft,
240 ffebld expr, ffelexToken t);
241static ffelexHandler ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr,
242 ffelexToken t);
243static ffelexHandler ffeexpr_cb_close_paren_ci_ (ffelexToken ft,
244 ffebld expr, ffelexToken t);
245static ffelexHandler ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr,
246 ffelexToken t);
247static ffelexHandler ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr,
248 ffelexToken t);
249static ffelexHandler ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr,
250 ffelexToken t);
251static ffelexHandler ffeexpr_cb_comma_i_2_ (ffelexToken ft, ffebld expr,
252 ffelexToken t);
253static ffelexHandler ffeexpr_cb_comma_i_3_ (ffelexToken ft, ffebld expr,
254 ffelexToken t);
255static ffelexHandler ffeexpr_cb_comma_i_4_ (ffelexToken ft, ffebld expr,
256 ffelexToken t);
257static ffelexHandler ffeexpr_cb_comma_i_5_ (ffelexToken t);
258static ffelexHandler ffeexpr_cb_end_loc_ (ffelexToken ft, ffebld expr,
259 ffelexToken t);
260static ffelexHandler ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr,
261 ffelexToken t);
262static ffelexHandler ffeexpr_cb_end_notloc_1_ (ffelexToken t);
263static ffesymbol ffeexpr_check_impctrl_ (ffesymbol s);
264static void ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
265 ffebld dovar, ffelexToken dovar_t);
266static void ffeexpr_update_impdo_ (ffebld expr, ffebld dovar);
267static void ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar);
268static ffeexprContext ffeexpr_context_outer_ (ffeexprStack_ s);
269static ffeexprExpr_ ffeexpr_expr_new_ (void);
270static void ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t);
271static bool ffeexpr_isdigits_ (const char *p);
272static ffelexHandler ffeexpr_token_first_lhs_ (ffelexToken t);
273static ffelexHandler ffeexpr_token_first_lhs_1_ (ffelexToken t);
274static ffelexHandler ffeexpr_token_first_rhs_ (ffelexToken t);
275static ffelexHandler ffeexpr_token_first_rhs_1_ (ffelexToken t);
276static ffelexHandler ffeexpr_token_first_rhs_2_ (ffelexToken t);
277static ffelexHandler ffeexpr_token_first_rhs_3_ (ffelexToken t);
278static ffelexHandler ffeexpr_token_first_rhs_4_ (ffelexToken t);
279static ffelexHandler ffeexpr_token_first_rhs_5_ (ffelexToken t);
280static ffelexHandler ffeexpr_token_first_rhs_6_ (ffelexToken t);
281static ffelexHandler ffeexpr_token_namelist_ (ffelexToken t);
282static void ffeexpr_expr_kill_ (ffeexprExpr_ e);
283static void ffeexpr_exprstack_push_ (ffeexprExpr_ e);
284static void ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e);
285static void ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e);
286static void ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e);
287static void ffeexpr_reduce_ (void);
288static ffebld ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op,
289 ffeexprExpr_ r);
290static ffebld ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l,
291 ffeexprExpr_ op, ffeexprExpr_ r);
292static ffebld ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l,
293 ffeexprExpr_ op, ffeexprExpr_ r);
294static ffebld ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l,
295 ffeexprExpr_ op, ffeexprExpr_ r);
296static ffebld ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op,
297 ffeexprExpr_ r);
298static ffebld ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l,
299 ffeexprExpr_ op, ffeexprExpr_ r);
300static ffebld ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l,
301 ffeexprExpr_ op, ffeexprExpr_ r);
302static ffebld ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l,
303 ffeexprExpr_ op, ffeexprExpr_ r);
304static ffebld ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r);
305static ffebld ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op,
306 ffeexprExpr_ r);
307static ffebld ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l,
308 ffeexprExpr_ op, ffeexprExpr_ r);
309static ffebld ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l,
310 ffeexprExpr_ op, ffeexprExpr_ r);
311static ffelexHandler ffeexpr_find_close_paren_ (ffelexToken t,
312 ffelexHandler after);
313static ffelexHandler ffeexpr_nil_finished_ (ffelexToken t);
314static ffelexHandler ffeexpr_nil_rhs_ (ffelexToken t);
315static ffelexHandler ffeexpr_nil_period_ (ffelexToken t);
316static ffelexHandler ffeexpr_nil_end_period_ (ffelexToken t);
317static ffelexHandler ffeexpr_nil_swallow_period_ (ffelexToken t);
318static ffelexHandler ffeexpr_nil_real_ (ffelexToken t);
319static ffelexHandler ffeexpr_nil_real_exponent_ (ffelexToken t);
320static ffelexHandler ffeexpr_nil_real_exp_sign_ (ffelexToken t);
321static ffelexHandler ffeexpr_nil_number_ (ffelexToken t);
322static ffelexHandler ffeexpr_nil_number_exponent_ (ffelexToken t);
323static ffelexHandler ffeexpr_nil_number_exp_sign_ (ffelexToken t);
324static ffelexHandler ffeexpr_nil_number_period_ (ffelexToken t);
325static ffelexHandler ffeexpr_nil_number_per_exp_ (ffelexToken t);
326static ffelexHandler ffeexpr_nil_number_real_ (ffelexToken t);
327static ffelexHandler ffeexpr_nil_num_per_exp_sign_ (ffelexToken t);
328static ffelexHandler ffeexpr_nil_number_real_exp_ (ffelexToken t);
329static ffelexHandler ffeexpr_nil_num_real_exp_sn_ (ffelexToken t);
330static ffelexHandler ffeexpr_nil_binary_ (ffelexToken t);
331static ffelexHandler ffeexpr_nil_binary_period_ (ffelexToken t);
332static ffelexHandler ffeexpr_nil_binary_end_per_ (ffelexToken t);
333static ffelexHandler ffeexpr_nil_binary_sw_per_ (ffelexToken t);
334static ffelexHandler ffeexpr_nil_quote_ (ffelexToken t);
335static ffelexHandler ffeexpr_nil_apostrophe_ (ffelexToken t);
336static ffelexHandler ffeexpr_nil_apos_char_ (ffelexToken t);
337static ffelexHandler ffeexpr_nil_name_rhs_ (ffelexToken t);
338static ffelexHandler ffeexpr_nil_name_apos_ (ffelexToken t);
339static ffelexHandler ffeexpr_nil_name_apos_name_ (ffelexToken t);
340static ffelexHandler ffeexpr_nil_percent_ (ffelexToken t);
341static ffelexHandler ffeexpr_nil_percent_name_ (ffelexToken t);
342static ffelexHandler ffeexpr_nil_substrp_ (ffelexToken t);
343static ffelexHandler ffeexpr_finished_ (ffelexToken t);
344static ffebld ffeexpr_finished_ambig_ (ffelexToken t, ffebld expr);
345static ffelexHandler ffeexpr_token_lhs_ (ffelexToken t);
346static ffelexHandler ffeexpr_token_rhs_ (ffelexToken t);
347static ffelexHandler ffeexpr_token_binary_ (ffelexToken t);
348static ffelexHandler ffeexpr_token_period_ (ffelexToken t);
349static ffelexHandler ffeexpr_token_end_period_ (ffelexToken t);
350static ffelexHandler ffeexpr_token_swallow_period_ (ffelexToken t);
351static ffelexHandler ffeexpr_token_real_ (ffelexToken t);
352static ffelexHandler ffeexpr_token_real_exponent_ (ffelexToken t);
353static ffelexHandler ffeexpr_token_real_exp_sign_ (ffelexToken t);
354static ffelexHandler ffeexpr_token_number_ (ffelexToken t);
355static ffelexHandler ffeexpr_token_number_exponent_ (ffelexToken t);
356static ffelexHandler ffeexpr_token_number_exp_sign_ (ffelexToken t);
357static ffelexHandler ffeexpr_token_number_period_ (ffelexToken t);
358static ffelexHandler ffeexpr_token_number_per_exp_ (ffelexToken t);
359static ffelexHandler ffeexpr_token_number_real_ (ffelexToken t);
360static ffelexHandler ffeexpr_token_num_per_exp_sign_ (ffelexToken t);
361static ffelexHandler ffeexpr_token_number_real_exp_ (ffelexToken t);
362static ffelexHandler ffeexpr_token_num_real_exp_sn_ (ffelexToken t);
363static ffelexHandler ffeexpr_token_binary_period_ (ffelexToken t);
364static ffelexHandler ffeexpr_token_binary_end_per_ (ffelexToken t);
365static ffelexHandler ffeexpr_token_binary_sw_per_ (ffelexToken t);
366static ffelexHandler ffeexpr_token_quote_ (ffelexToken t);
367static ffelexHandler ffeexpr_token_apostrophe_ (ffelexToken t);
368static ffelexHandler ffeexpr_token_apos_char_ (ffelexToken t);
369static ffelexHandler ffeexpr_token_name_lhs_ (ffelexToken t);
370static ffelexHandler ffeexpr_token_name_arg_ (ffelexToken t);
371static ffelexHandler ffeexpr_token_name_rhs_ (ffelexToken t);
372static ffelexHandler ffeexpr_token_name_apos_ (ffelexToken t);
373static ffelexHandler ffeexpr_token_name_apos_name_ (ffelexToken t);
374static ffelexHandler ffeexpr_token_percent_ (ffelexToken t);
375static ffelexHandler ffeexpr_token_percent_name_ (ffelexToken t);
376static ffelexHandler ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr,
377 ffelexToken t);
378static ffelexHandler ffeexpr_token_elements_ (ffelexToken ft, ffebld expr,
379 ffelexToken t);
380static ffelexHandler ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr,
381 ffelexToken t);
382static ffelexHandler ffeexpr_token_substring_ (ffelexToken ft, ffebld expr,
383 ffelexToken t);
384static ffelexHandler ffeexpr_token_substring_1_ (ffelexToken ft, ffebld expr,
385 ffelexToken t);
386static ffelexHandler ffeexpr_token_substrp_ (ffelexToken t);
387static ffelexHandler ffeexpr_token_intrincheck_ (ffelexToken t);
388static ffelexHandler ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr,
389 ffelexToken t);
390static ffelexHandler ffeexpr_token_anything_ (ffelexToken ft, ffebld expr,
391 ffelexToken t);
392static void ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
393 ffelexToken decimal, ffelexToken fraction, ffelexToken exponent,
394 ffelexToken exponent_sign, ffelexToken exponent_digits);
395static ffesymbol ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin);
396static ffesymbol ffeexpr_sym_impdoitem_ (ffesymbol s, ffelexToken t);
397static ffesymbol ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t);
398static ffesymbol ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t);
399static ffesymbol ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t);
400static ffesymbol ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t);
401static ffesymbol ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t);
402static ffesymbol ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t);
403static ffesymbol ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t);
404static ffesymbol ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t);
405static ffesymbol ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t);
406static ffesymbol ffeexpr_declare_parenthesized_ (ffelexToken t,
407 bool maybe_intrin,
408 ffeexprParenType_ *paren_type);
409static ffesymbol ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t);
410
411/* Internal macros. */
412
413#define ffeexpr_paren_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
414#define ffeexpr_sym_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
415
416/* ffeexpr_collapse_convert -- Collapse convert expr
417
418 ffebld expr;
419 ffelexToken token;
420 expr = ffeexpr_collapse_convert(expr,token);
421
422 If the result of the expr is a constant, replaces the expr with the
423 computed constant. */
424
425ffebld
426ffeexpr_collapse_convert (ffebld expr, ffelexToken t)
427{
428 ffebad error = FFEBAD;
429 ffebld l;
430 ffebldConstantUnion u;
431 ffeinfoBasictype bt;
432 ffeinfoKindtype kt;
433 ffetargetCharacterSize sz;
434 ffetargetCharacterSize sz2;
435
436 if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
437 return expr;
438
439 l = ffebld_left (expr);
440
441 if (ffebld_op (l) != FFEBLD_opCONTER)
442 return expr;
443
444 switch (bt = ffeinfo_basictype (ffebld_info (expr)))
445 {
446 case FFEINFO_basictypeANY:
447 return expr;
448
449 case FFEINFO_basictypeINTEGER:
450 sz = FFETARGET_charactersizeNONE;
451 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
452 {
453#if FFETARGET_okINTEGER1
454 case FFEINFO_kindtypeINTEGER1:
455 switch (ffeinfo_basictype (ffebld_info (l)))
456 {
457 case FFEINFO_basictypeINTEGER:
458 switch (ffeinfo_kindtype (ffebld_info (l)))
459 {
460#if FFETARGET_okINTEGER2
461 case FFEINFO_kindtypeINTEGER2:
462 error = ffetarget_convert_integer1_integer2
463 (ffebld_cu_ptr_integer1 (u),
464 ffebld_constant_integer2 (ffebld_conter (l)));
465 break;
466#endif
467
468#if FFETARGET_okINTEGER3
469 case FFEINFO_kindtypeINTEGER3:
470 error = ffetarget_convert_integer1_integer3
471 (ffebld_cu_ptr_integer1 (u),
472 ffebld_constant_integer3 (ffebld_conter (l)));
473 break;
474#endif
475
476#if FFETARGET_okINTEGER4
477 case FFEINFO_kindtypeINTEGER4:
478 error = ffetarget_convert_integer1_integer4
479 (ffebld_cu_ptr_integer1 (u),
480 ffebld_constant_integer4 (ffebld_conter (l)));
481 break;
482#endif
483
484 default:
485 assert ("INTEGER1/INTEGER bad source kind type" == NULL);
486 break;
487 }
488 break;
489
490 case FFEINFO_basictypeREAL:
491 switch (ffeinfo_kindtype (ffebld_info (l)))
492 {
493#if FFETARGET_okREAL1
494 case FFEINFO_kindtypeREAL1:
495 error = ffetarget_convert_integer1_real1
496 (ffebld_cu_ptr_integer1 (u),
497 ffebld_constant_real1 (ffebld_conter (l)));
498 break;
499#endif
500
501#if FFETARGET_okREAL2
502 case FFEINFO_kindtypeREAL2:
503 error = ffetarget_convert_integer1_real2
504 (ffebld_cu_ptr_integer1 (u),
505 ffebld_constant_real2 (ffebld_conter (l)));
506 break;
507#endif
508
509#if FFETARGET_okREAL3
510 case FFEINFO_kindtypeREAL3:
511 error = ffetarget_convert_integer1_real3
512 (ffebld_cu_ptr_integer1 (u),
513 ffebld_constant_real3 (ffebld_conter (l)));
514 break;
515#endif
516
517#if FFETARGET_okREAL4
518 case FFEINFO_kindtypeREAL4:
519 error = ffetarget_convert_integer1_real4
520 (ffebld_cu_ptr_integer1 (u),
521 ffebld_constant_real4 (ffebld_conter (l)));
522 break;
523#endif
524
525 default:
526 assert ("INTEGER1/REAL bad source kind type" == NULL);
527 break;
528 }
529 break;
530
531 case FFEINFO_basictypeCOMPLEX:
532 switch (ffeinfo_kindtype (ffebld_info (l)))
533 {
534#if FFETARGET_okCOMPLEX1
535 case FFEINFO_kindtypeREAL1:
536 error = ffetarget_convert_integer1_complex1
537 (ffebld_cu_ptr_integer1 (u),
538 ffebld_constant_complex1 (ffebld_conter (l)));
539 break;
540#endif
541
542#if FFETARGET_okCOMPLEX2
543 case FFEINFO_kindtypeREAL2:
544 error = ffetarget_convert_integer1_complex2
545 (ffebld_cu_ptr_integer1 (u),
546 ffebld_constant_complex2 (ffebld_conter (l)));
547 break;
548#endif
549
550#if FFETARGET_okCOMPLEX3
551 case FFEINFO_kindtypeREAL3:
552 error = ffetarget_convert_integer1_complex3
553 (ffebld_cu_ptr_integer1 (u),
554 ffebld_constant_complex3 (ffebld_conter (l)));
555 break;
556#endif
557
558#if FFETARGET_okCOMPLEX4
559 case FFEINFO_kindtypeREAL4:
560 error = ffetarget_convert_integer1_complex4
561 (ffebld_cu_ptr_integer1 (u),
562 ffebld_constant_complex4 (ffebld_conter (l)));
563 break;
564#endif
565
566 default:
567 assert ("INTEGER1/COMPLEX bad source kind type" == NULL);
568 break;
569 }
570 break;
571
572 case FFEINFO_basictypeLOGICAL:
573 switch (ffeinfo_kindtype (ffebld_info (l)))
574 {
575#if FFETARGET_okLOGICAL1
576 case FFEINFO_kindtypeLOGICAL1:
577 error = ffetarget_convert_integer1_logical1
578 (ffebld_cu_ptr_integer1 (u),
579 ffebld_constant_logical1 (ffebld_conter (l)));
580 break;
581#endif
582
583#if FFETARGET_okLOGICAL2
584 case FFEINFO_kindtypeLOGICAL2:
585 error = ffetarget_convert_integer1_logical2
586 (ffebld_cu_ptr_integer1 (u),
587 ffebld_constant_logical2 (ffebld_conter (l)));
588 break;
589#endif
590
591#if FFETARGET_okLOGICAL3
592 case FFEINFO_kindtypeLOGICAL3:
593 error = ffetarget_convert_integer1_logical3
594 (ffebld_cu_ptr_integer1 (u),
595 ffebld_constant_logical3 (ffebld_conter (l)));
596 break;
597#endif
598
599#if FFETARGET_okLOGICAL4
600 case FFEINFO_kindtypeLOGICAL4:
601 error = ffetarget_convert_integer1_logical4
602 (ffebld_cu_ptr_integer1 (u),
603 ffebld_constant_logical4 (ffebld_conter (l)));
604 break;
605#endif
606
607 default:
608 assert ("INTEGER1/LOGICAL bad source kind type" == NULL);
609 break;
610 }
611 break;
612
613 case FFEINFO_basictypeCHARACTER:
614 error = ffetarget_convert_integer1_character1
615 (ffebld_cu_ptr_integer1 (u),
616 ffebld_constant_character1 (ffebld_conter (l)));
617 break;
618
619 case FFEINFO_basictypeHOLLERITH:
620 error = ffetarget_convert_integer1_hollerith
621 (ffebld_cu_ptr_integer1 (u),
622 ffebld_constant_hollerith (ffebld_conter (l)));
623 break;
624
625 case FFEINFO_basictypeTYPELESS:
626 error = ffetarget_convert_integer1_typeless
627 (ffebld_cu_ptr_integer1 (u),
628 ffebld_constant_typeless (ffebld_conter (l)));
629 break;
630
631 default:
632 assert ("INTEGER1 bad type" == NULL);
633 break;
634 }
635
636 /* If conversion operation is not implemented, return original expr. */
637 if (error == FFEBAD_NOCANDO)
638 return expr;
639
640 expr = ffebld_new_conter_with_orig
641 (ffebld_constant_new_integer1_val
642 (ffebld_cu_val_integer1 (u)), expr);
643 break;
644#endif
645
646#if FFETARGET_okINTEGER2
647 case FFEINFO_kindtypeINTEGER2:
648 switch (ffeinfo_basictype (ffebld_info (l)))
649 {
650 case FFEINFO_basictypeINTEGER:
651 switch (ffeinfo_kindtype (ffebld_info (l)))
652 {
653#if FFETARGET_okINTEGER1
654 case FFEINFO_kindtypeINTEGER1:
655 error = ffetarget_convert_integer2_integer1
656 (ffebld_cu_ptr_integer2 (u),
657 ffebld_constant_integer1 (ffebld_conter (l)));
658 break;
659#endif
660
661#if FFETARGET_okINTEGER3
662 case FFEINFO_kindtypeINTEGER3:
663 error = ffetarget_convert_integer2_integer3
664 (ffebld_cu_ptr_integer2 (u),
665 ffebld_constant_integer3 (ffebld_conter (l)));
666 break;
667#endif
668
669#if FFETARGET_okINTEGER4
670 case FFEINFO_kindtypeINTEGER4:
671 error = ffetarget_convert_integer2_integer4
672 (ffebld_cu_ptr_integer2 (u),
673 ffebld_constant_integer4 (ffebld_conter (l)));
674 break;
675#endif
676
677 default:
678 assert ("INTEGER2/INTEGER bad source kind type" == NULL);
679 break;
680 }
681 break;
682
683 case FFEINFO_basictypeREAL:
684 switch (ffeinfo_kindtype (ffebld_info (l)))
685 {
686#if FFETARGET_okREAL1
687 case FFEINFO_kindtypeREAL1:
688 error = ffetarget_convert_integer2_real1
689 (ffebld_cu_ptr_integer2 (u),
690 ffebld_constant_real1 (ffebld_conter (l)));
691 break;
692#endif
693
694#if FFETARGET_okREAL2
695 case FFEINFO_kindtypeREAL2:
696 error = ffetarget_convert_integer2_real2
697 (ffebld_cu_ptr_integer2 (u),
698 ffebld_constant_real2 (ffebld_conter (l)));
699 break;
700#endif
701
702#if FFETARGET_okREAL3
703 case FFEINFO_kindtypeREAL3:
704 error = ffetarget_convert_integer2_real3
705 (ffebld_cu_ptr_integer2 (u),
706 ffebld_constant_real3 (ffebld_conter (l)));
707 break;
708#endif
709
710#if FFETARGET_okREAL4
711 case FFEINFO_kindtypeREAL4:
712 error = ffetarget_convert_integer2_real4
713 (ffebld_cu_ptr_integer2 (u),
714 ffebld_constant_real4 (ffebld_conter (l)));
715 break;
716#endif
717
718 default:
719 assert ("INTEGER2/REAL bad source kind type" == NULL);
720 break;
721 }
722 break;
723
724 case FFEINFO_basictypeCOMPLEX:
725 switch (ffeinfo_kindtype (ffebld_info (l)))
726 {
727#if FFETARGET_okCOMPLEX1
728 case FFEINFO_kindtypeREAL1:
729 error = ffetarget_convert_integer2_complex1
730 (ffebld_cu_ptr_integer2 (u),
731 ffebld_constant_complex1 (ffebld_conter (l)));
732 break;
733#endif
734
735#if FFETARGET_okCOMPLEX2
736 case FFEINFO_kindtypeREAL2:
737 error = ffetarget_convert_integer2_complex2
738 (ffebld_cu_ptr_integer2 (u),
739 ffebld_constant_complex2 (ffebld_conter (l)));
740 break;
741#endif
742
743#if FFETARGET_okCOMPLEX3
744 case FFEINFO_kindtypeREAL3:
745 error = ffetarget_convert_integer2_complex3
746 (ffebld_cu_ptr_integer2 (u),
747 ffebld_constant_complex3 (ffebld_conter (l)));
748 break;
749#endif
750
751#if FFETARGET_okCOMPLEX4
752 case FFEINFO_kindtypeREAL4:
753 error = ffetarget_convert_integer2_complex4
754 (ffebld_cu_ptr_integer2 (u),
755 ffebld_constant_complex4 (ffebld_conter (l)));
756 break;
757#endif
758
759 default:
760 assert ("INTEGER2/COMPLEX bad source kind type" == NULL);
761 break;
762 }
763 break;
764
765 case FFEINFO_basictypeLOGICAL:
766 switch (ffeinfo_kindtype (ffebld_info (l)))
767 {
768#if FFETARGET_okLOGICAL1
769 case FFEINFO_kindtypeLOGICAL1:
770 error = ffetarget_convert_integer2_logical1
771 (ffebld_cu_ptr_integer2 (u),
772 ffebld_constant_logical1 (ffebld_conter (l)));
773 break;
774#endif
775
776#if FFETARGET_okLOGICAL2
777 case FFEINFO_kindtypeLOGICAL2:
778 error = ffetarget_convert_integer2_logical2
779 (ffebld_cu_ptr_integer2 (u),
780 ffebld_constant_logical2 (ffebld_conter (l)));
781 break;
782#endif
783
784#if FFETARGET_okLOGICAL3
785 case FFEINFO_kindtypeLOGICAL3:
786 error = ffetarget_convert_integer2_logical3
787 (ffebld_cu_ptr_integer2 (u),
788 ffebld_constant_logical3 (ffebld_conter (l)));
789 break;
790#endif
791
792#if FFETARGET_okLOGICAL4
793 case FFEINFO_kindtypeLOGICAL4:
794 error = ffetarget_convert_integer2_logical4
795 (ffebld_cu_ptr_integer2 (u),
796 ffebld_constant_logical4 (ffebld_conter (l)));
797 break;
798#endif
799
800 default:
801 assert ("INTEGER2/LOGICAL bad source kind type" == NULL);
802 break;
803 }
804 break;
805
806 case FFEINFO_basictypeCHARACTER:
807 error = ffetarget_convert_integer2_character1
808 (ffebld_cu_ptr_integer2 (u),
809 ffebld_constant_character1 (ffebld_conter (l)));
810 break;
811
812 case FFEINFO_basictypeHOLLERITH:
813 error = ffetarget_convert_integer2_hollerith
814 (ffebld_cu_ptr_integer2 (u),
815 ffebld_constant_hollerith (ffebld_conter (l)));
816 break;
817
818 case FFEINFO_basictypeTYPELESS:
819 error = ffetarget_convert_integer2_typeless
820 (ffebld_cu_ptr_integer2 (u),
821 ffebld_constant_typeless (ffebld_conter (l)));
822 break;
823
824 default:
825 assert ("INTEGER2 bad type" == NULL);
826 break;
827 }
828
829 /* If conversion operation is not implemented, return original expr. */
830 if (error == FFEBAD_NOCANDO)
831 return expr;
832
833 expr = ffebld_new_conter_with_orig
834 (ffebld_constant_new_integer2_val
835 (ffebld_cu_val_integer2 (u)), expr);
836 break;
837#endif
838
839#if FFETARGET_okINTEGER3
840 case FFEINFO_kindtypeINTEGER3:
841 switch (ffeinfo_basictype (ffebld_info (l)))
842 {
843 case FFEINFO_basictypeINTEGER:
844 switch (ffeinfo_kindtype (ffebld_info (l)))
845 {
846#if FFETARGET_okINTEGER1
847 case FFEINFO_kindtypeINTEGER1:
848 error = ffetarget_convert_integer3_integer1
849 (ffebld_cu_ptr_integer3 (u),
850 ffebld_constant_integer1 (ffebld_conter (l)));
851 break;
852#endif
853
854#if FFETARGET_okINTEGER2
855 case FFEINFO_kindtypeINTEGER2:
856 error = ffetarget_convert_integer3_integer2
857 (ffebld_cu_ptr_integer3 (u),
858 ffebld_constant_integer2 (ffebld_conter (l)));
859 break;
860#endif
861
862#if FFETARGET_okINTEGER4
863 case FFEINFO_kindtypeINTEGER4:
864 error = ffetarget_convert_integer3_integer4
865 (ffebld_cu_ptr_integer3 (u),
866 ffebld_constant_integer4 (ffebld_conter (l)));
867 break;
868#endif
869
870 default:
871 assert ("INTEGER3/INTEGER bad source kind type" == NULL);
872 break;
873 }
874 break;
875
876 case FFEINFO_basictypeREAL:
877 switch (ffeinfo_kindtype (ffebld_info (l)))
878 {
879#if FFETARGET_okREAL1
880 case FFEINFO_kindtypeREAL1:
881 error = ffetarget_convert_integer3_real1
882 (ffebld_cu_ptr_integer3 (u),
883 ffebld_constant_real1 (ffebld_conter (l)));
884 break;
885#endif
886
887#if FFETARGET_okREAL2
888 case FFEINFO_kindtypeREAL2:
889 error = ffetarget_convert_integer3_real2
890 (ffebld_cu_ptr_integer3 (u),
891 ffebld_constant_real2 (ffebld_conter (l)));
892 break;
893#endif
894
895#if FFETARGET_okREAL3
896 case FFEINFO_kindtypeREAL3:
897 error = ffetarget_convert_integer3_real3
898 (ffebld_cu_ptr_integer3 (u),
899 ffebld_constant_real3 (ffebld_conter (l)));
900 break;
901#endif
902
903#if FFETARGET_okREAL4
904 case FFEINFO_kindtypeREAL4:
905 error = ffetarget_convert_integer3_real4
906 (ffebld_cu_ptr_integer3 (u),
907 ffebld_constant_real4 (ffebld_conter (l)));
908 break;
909#endif
910
911 default:
912 assert ("INTEGER3/REAL bad source kind type" == NULL);
913 break;
914 }
915 break;
916
917 case FFEINFO_basictypeCOMPLEX:
918 switch (ffeinfo_kindtype (ffebld_info (l)))
919 {
920#if FFETARGET_okCOMPLEX1
921 case FFEINFO_kindtypeREAL1:
922 error = ffetarget_convert_integer3_complex1
923 (ffebld_cu_ptr_integer3 (u),
924 ffebld_constant_complex1 (ffebld_conter (l)));
925 break;
926#endif
927
928#if FFETARGET_okCOMPLEX2
929 case FFEINFO_kindtypeREAL2:
930 error = ffetarget_convert_integer3_complex2
931 (ffebld_cu_ptr_integer3 (u),
932 ffebld_constant_complex2 (ffebld_conter (l)));
933 break;
934#endif
935
936#if FFETARGET_okCOMPLEX3
937 case FFEINFO_kindtypeREAL3:
938 error = ffetarget_convert_integer3_complex3
939 (ffebld_cu_ptr_integer3 (u),
940 ffebld_constant_complex3 (ffebld_conter (l)));
941 break;
942#endif
943
944#if FFETARGET_okCOMPLEX4
945 case FFEINFO_kindtypeREAL4:
946 error = ffetarget_convert_integer3_complex4
947 (ffebld_cu_ptr_integer3 (u),
948 ffebld_constant_complex4 (ffebld_conter (l)));
949 break;
950#endif
951
952 default:
953 assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
954 break;
955 }
956 break;
957
958 case FFEINFO_basictypeLOGICAL:
959 switch (ffeinfo_kindtype (ffebld_info (l)))
960 {
961#if FFETARGET_okLOGICAL1
962 case FFEINFO_kindtypeLOGICAL1:
963 error = ffetarget_convert_integer3_logical1
964 (ffebld_cu_ptr_integer3 (u),
965 ffebld_constant_logical1 (ffebld_conter (l)));
966 break;
967#endif
968
969#if FFETARGET_okLOGICAL2
970 case FFEINFO_kindtypeLOGICAL2:
971 error = ffetarget_convert_integer3_logical2
972 (ffebld_cu_ptr_integer3 (u),
973 ffebld_constant_logical2 (ffebld_conter (l)));
974 break;
975#endif
976
977#if FFETARGET_okLOGICAL3
978 case FFEINFO_kindtypeLOGICAL3:
979 error = ffetarget_convert_integer3_logical3
980 (ffebld_cu_ptr_integer3 (u),
981 ffebld_constant_logical3 (ffebld_conter (l)));
982 break;
983#endif
984
985#if FFETARGET_okLOGICAL4
986 case FFEINFO_kindtypeLOGICAL4:
987 error = ffetarget_convert_integer3_logical4
988 (ffebld_cu_ptr_integer3 (u),
989 ffebld_constant_logical4 (ffebld_conter (l)));
990 break;
991#endif
992
993 default:
994 assert ("INTEGER3/LOGICAL bad source kind type" == NULL);
995 break;
996 }
997 break;
998
999 case FFEINFO_basictypeCHARACTER:
1000 error = ffetarget_convert_integer3_character1
1001 (ffebld_cu_ptr_integer3 (u),
1002 ffebld_constant_character1 (ffebld_conter (l)));
1003 break;
1004
1005 case FFEINFO_basictypeHOLLERITH:
1006 error = ffetarget_convert_integer3_hollerith
1007 (ffebld_cu_ptr_integer3 (u),
1008 ffebld_constant_hollerith (ffebld_conter (l)));
1009 break;
1010
1011 case FFEINFO_basictypeTYPELESS:
1012 error = ffetarget_convert_integer3_typeless
1013 (ffebld_cu_ptr_integer3 (u),
1014 ffebld_constant_typeless (ffebld_conter (l)));
1015 break;
1016
1017 default:
1018 assert ("INTEGER3 bad type" == NULL);
1019 break;
1020 }
1021
1022 /* If conversion operation is not implemented, return original expr. */
1023 if (error == FFEBAD_NOCANDO)
1024 return expr;
1025
1026 expr = ffebld_new_conter_with_orig
1027 (ffebld_constant_new_integer3_val
1028 (ffebld_cu_val_integer3 (u)), expr);
1029 break;
1030#endif
1031
1032#if FFETARGET_okINTEGER4
1033 case FFEINFO_kindtypeINTEGER4:
1034 switch (ffeinfo_basictype (ffebld_info (l)))
1035 {
1036 case FFEINFO_basictypeINTEGER:
1037 switch (ffeinfo_kindtype (ffebld_info (l)))
1038 {
1039#if FFETARGET_okINTEGER1
1040 case FFEINFO_kindtypeINTEGER1:
1041 error = ffetarget_convert_integer4_integer1
1042 (ffebld_cu_ptr_integer4 (u),
1043 ffebld_constant_integer1 (ffebld_conter (l)));
1044 break;
1045#endif
1046
1047#if FFETARGET_okINTEGER2
1048 case FFEINFO_kindtypeINTEGER2:
1049 error = ffetarget_convert_integer4_integer2
1050 (ffebld_cu_ptr_integer4 (u),
1051 ffebld_constant_integer2 (ffebld_conter (l)));
1052 break;
1053#endif
1054
1055#if FFETARGET_okINTEGER3
1056 case FFEINFO_kindtypeINTEGER3:
1057 error = ffetarget_convert_integer4_integer3
1058 (ffebld_cu_ptr_integer4 (u),
1059 ffebld_constant_integer3 (ffebld_conter (l)));
1060 break;
1061#endif
1062
1063 default:
1064 assert ("INTEGER4/INTEGER bad source kind type" == NULL);
1065 break;
1066 }
1067 break;
1068
1069 case FFEINFO_basictypeREAL:
1070 switch (ffeinfo_kindtype (ffebld_info (l)))
1071 {
1072#if FFETARGET_okREAL1
1073 case FFEINFO_kindtypeREAL1:
1074 error = ffetarget_convert_integer4_real1
1075 (ffebld_cu_ptr_integer4 (u),
1076 ffebld_constant_real1 (ffebld_conter (l)));
1077 break;
1078#endif
1079
1080#if FFETARGET_okREAL2
1081 case FFEINFO_kindtypeREAL2:
1082 error = ffetarget_convert_integer4_real2
1083 (ffebld_cu_ptr_integer4 (u),
1084 ffebld_constant_real2 (ffebld_conter (l)));
1085 break;
1086#endif
1087
1088#if FFETARGET_okREAL3
1089 case FFEINFO_kindtypeREAL3:
1090 error = ffetarget_convert_integer4_real3
1091 (ffebld_cu_ptr_integer4 (u),
1092 ffebld_constant_real3 (ffebld_conter (l)));
1093 break;
1094#endif
1095
1096#if FFETARGET_okREAL4
1097 case FFEINFO_kindtypeREAL4:
1098 error = ffetarget_convert_integer4_real4
1099 (ffebld_cu_ptr_integer4 (u),
1100 ffebld_constant_real4 (ffebld_conter (l)));
1101 break;
1102#endif
1103
1104 default:
1105 assert ("INTEGER4/REAL bad source kind type" == NULL);
1106 break;
1107 }
1108 break;
1109
1110 case FFEINFO_basictypeCOMPLEX:
1111 switch (ffeinfo_kindtype (ffebld_info (l)))
1112 {
1113#if FFETARGET_okCOMPLEX1
1114 case FFEINFO_kindtypeREAL1:
1115 error = ffetarget_convert_integer4_complex1
1116 (ffebld_cu_ptr_integer4 (u),
1117 ffebld_constant_complex1 (ffebld_conter (l)));
1118 break;
1119#endif
1120
1121#if FFETARGET_okCOMPLEX2
1122 case FFEINFO_kindtypeREAL2:
1123 error = ffetarget_convert_integer4_complex2
1124 (ffebld_cu_ptr_integer4 (u),
1125 ffebld_constant_complex2 (ffebld_conter (l)));
1126 break;
1127#endif
1128
1129#if FFETARGET_okCOMPLEX3
1130 case FFEINFO_kindtypeREAL3:
1131 error = ffetarget_convert_integer4_complex3
1132 (ffebld_cu_ptr_integer4 (u),
1133 ffebld_constant_complex3 (ffebld_conter (l)));
1134 break;
1135#endif
1136
1137#if FFETARGET_okCOMPLEX4
1138 case FFEINFO_kindtypeREAL4:
1139 error = ffetarget_convert_integer4_complex4
1140 (ffebld_cu_ptr_integer4 (u),
1141 ffebld_constant_complex4 (ffebld_conter (l)));
1142 break;
1143#endif
1144
1145 default:
1146 assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
1147 break;
1148 }
1149 break;
1150
1151 case FFEINFO_basictypeLOGICAL:
1152 switch (ffeinfo_kindtype (ffebld_info (l)))
1153 {
1154#if FFETARGET_okLOGICAL1
1155 case FFEINFO_kindtypeLOGICAL1:
1156 error = ffetarget_convert_integer4_logical1
1157 (ffebld_cu_ptr_integer4 (u),
1158 ffebld_constant_logical1 (ffebld_conter (l)));
1159 break;
1160#endif
1161
1162#if FFETARGET_okLOGICAL2
1163 case FFEINFO_kindtypeLOGICAL2:
1164 error = ffetarget_convert_integer4_logical2
1165 (ffebld_cu_ptr_integer4 (u),
1166 ffebld_constant_logical2 (ffebld_conter (l)));
1167 break;
1168#endif
1169
1170#if FFETARGET_okLOGICAL3
1171 case FFEINFO_kindtypeLOGICAL3:
1172 error = ffetarget_convert_integer4_logical3
1173 (ffebld_cu_ptr_integer4 (u),
1174 ffebld_constant_logical3 (ffebld_conter (l)));
1175 break;
1176#endif
1177
1178#if FFETARGET_okLOGICAL4
1179 case FFEINFO_kindtypeLOGICAL4:
1180 error = ffetarget_convert_integer4_logical4
1181 (ffebld_cu_ptr_integer4 (u),
1182 ffebld_constant_logical4 (ffebld_conter (l)));
1183 break;
1184#endif
1185
1186 default:
1187 assert ("INTEGER4/LOGICAL bad source kind type" == NULL);
1188 break;
1189 }
1190 break;
1191
1192 case FFEINFO_basictypeCHARACTER:
1193 error = ffetarget_convert_integer4_character1
1194 (ffebld_cu_ptr_integer4 (u),
1195 ffebld_constant_character1 (ffebld_conter (l)));
1196 break;
1197
1198 case FFEINFO_basictypeHOLLERITH:
1199 error = ffetarget_convert_integer4_hollerith
1200 (ffebld_cu_ptr_integer4 (u),
1201 ffebld_constant_hollerith (ffebld_conter (l)));
1202 break;
1203
1204 case FFEINFO_basictypeTYPELESS:
1205 error = ffetarget_convert_integer4_typeless
1206 (ffebld_cu_ptr_integer4 (u),
1207 ffebld_constant_typeless (ffebld_conter (l)));
1208 break;
1209
1210 default:
1211 assert ("INTEGER4 bad type" == NULL);
1212 break;
1213 }
1214
1215 /* If conversion operation is not implemented, return original expr. */
1216 if (error == FFEBAD_NOCANDO)
1217 return expr;
1218
1219 expr = ffebld_new_conter_with_orig
1220 (ffebld_constant_new_integer4_val
1221 (ffebld_cu_val_integer4 (u)), expr);
1222 break;
1223#endif
1224
1225 default:
1226 assert ("bad integer kind type" == NULL);
1227 break;
1228 }
1229 break;
1230
1231 case FFEINFO_basictypeLOGICAL:
1232 sz = FFETARGET_charactersizeNONE;
1233 switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
1234 {
1235#if FFETARGET_okLOGICAL1
1236 case FFEINFO_kindtypeLOGICAL1:
1237 switch (ffeinfo_basictype (ffebld_info (l)))
1238 {
1239 case FFEINFO_basictypeLOGICAL:
1240 switch (ffeinfo_kindtype (ffebld_info (l)))
1241 {
1242#if FFETARGET_okLOGICAL2
1243 case FFEINFO_kindtypeLOGICAL2:
1244 error = ffetarget_convert_logical1_logical2
1245 (ffebld_cu_ptr_logical1 (u),
1246 ffebld_constant_logical2 (ffebld_conter (l)));
1247 break;
1248#endif
1249
1250#if FFETARGET_okLOGICAL3
1251 case FFEINFO_kindtypeLOGICAL3:
1252 error = ffetarget_convert_logical1_logical3
1253 (ffebld_cu_ptr_logical1 (u),
1254 ffebld_constant_logical3 (ffebld_conter (l)));
1255 break;
1256#endif
1257
1258#if FFETARGET_okLOGICAL4
1259 case FFEINFO_kindtypeLOGICAL4:
1260 error = ffetarget_convert_logical1_logical4
1261 (ffebld_cu_ptr_logical1 (u),
1262 ffebld_constant_logical4 (ffebld_conter (l)));
1263 break;
1264#endif
1265
1266 default:
1267 assert ("LOGICAL1/LOGICAL bad source kind type" == NULL);
1268 break;
1269 }
1270 break;
1271
1272 case FFEINFO_basictypeINTEGER:
1273 switch (ffeinfo_kindtype (ffebld_info (l)))
1274 {
1275#if FFETARGET_okINTEGER1
1276 case FFEINFO_kindtypeINTEGER1:
1277 error = ffetarget_convert_logical1_integer1
1278 (ffebld_cu_ptr_logical1 (u),
1279 ffebld_constant_integer1 (ffebld_conter (l)));
1280 break;
1281#endif
1282
1283#if FFETARGET_okINTEGER2
1284 case FFEINFO_kindtypeINTEGER2:
1285 error = ffetarget_convert_logical1_integer2
1286 (ffebld_cu_ptr_logical1 (u),
1287 ffebld_constant_integer2 (ffebld_conter (l)));
1288 break;
1289#endif
1290
1291#if FFETARGET_okINTEGER3
1292 case FFEINFO_kindtypeINTEGER3:
1293 error = ffetarget_convert_logical1_integer3
1294 (ffebld_cu_ptr_logical1 (u),
1295 ffebld_constant_integer3 (ffebld_conter (l)));
1296 break;
1297#endif
1298
1299#if FFETARGET_okINTEGER4
1300 case FFEINFO_kindtypeINTEGER4:
1301 error = ffetarget_convert_logical1_integer4
1302 (ffebld_cu_ptr_logical1 (u),
1303 ffebld_constant_integer4 (ffebld_conter (l)));
1304 break;
1305#endif
1306
1307 default:
1308 assert ("LOGICAL1/INTEGER bad source kind type" == NULL);
1309 break;
1310 }
1311 break;
1312
1313 case FFEINFO_basictypeCHARACTER:
1314 error = ffetarget_convert_logical1_character1
1315 (ffebld_cu_ptr_logical1 (u),
1316 ffebld_constant_character1 (ffebld_conter (l)));
1317 break;
1318
1319 case FFEINFO_basictypeHOLLERITH:
1320 error = ffetarget_convert_logical1_hollerith
1321 (ffebld_cu_ptr_logical1 (u),
1322 ffebld_constant_hollerith (ffebld_conter (l)));
1323 break;
1324
1325 case FFEINFO_basictypeTYPELESS:
1326 error = ffetarget_convert_logical1_typeless
1327 (ffebld_cu_ptr_logical1 (u),
1328 ffebld_constant_typeless (ffebld_conter (l)));
1329 break;
1330
1331 default:
1332 assert ("LOGICAL1 bad type" == NULL);
1333 break;
1334 }
1335
1336 /* If conversion operation is not implemented, return original expr. */
1337 if (error == FFEBAD_NOCANDO)
1338 return expr;
1339
1340 expr = ffebld_new_conter_with_orig
1341 (ffebld_constant_new_logical1_val
1342 (ffebld_cu_val_logical1 (u)), expr);
1343 break;
1344#endif
1345
1346#if FFETARGET_okLOGICAL2
1347 case FFEINFO_kindtypeLOGICAL2:
1348 switch (ffeinfo_basictype (ffebld_info (l)))
1349 {
1350 case FFEINFO_basictypeLOGICAL:
1351 switch (ffeinfo_kindtype (ffebld_info (l)))
1352 {
1353#if FFETARGET_okLOGICAL1
1354 case FFEINFO_kindtypeLOGICAL1:
1355 error = ffetarget_convert_logical2_logical1
1356 (ffebld_cu_ptr_logical2 (u),
1357 ffebld_constant_logical1 (ffebld_conter (l)));
1358 break;
1359#endif
1360
1361#if FFETARGET_okLOGICAL3
1362 case FFEINFO_kindtypeLOGICAL3:
1363 error = ffetarget_convert_logical2_logical3
1364 (ffebld_cu_ptr_logical2 (u),
1365 ffebld_constant_logical3 (ffebld_conter (l)));
1366 break;
1367#endif
1368
1369#if FFETARGET_okLOGICAL4
1370 case FFEINFO_kindtypeLOGICAL4:
1371 error = ffetarget_convert_logical2_logical4
1372 (ffebld_cu_ptr_logical2 (u),
1373 ffebld_constant_logical4 (ffebld_conter (l)));
1374 break;
1375#endif
1376
1377 default:
1378 assert ("LOGICAL2/LOGICAL bad source kind type" == NULL);
1379 break;
1380 }
1381 break;
1382
1383 case FFEINFO_basictypeINTEGER:
1384 switch (ffeinfo_kindtype (ffebld_info (l)))
1385 {
1386#if FFETARGET_okINTEGER1
1387 case FFEINFO_kindtypeINTEGER1:
1388 error = ffetarget_convert_logical2_integer1
1389 (ffebld_cu_ptr_logical2 (u),
1390 ffebld_constant_integer1 (ffebld_conter (l)));
1391 break;
1392#endif
1393
1394#if FFETARGET_okINTEGER2
1395 case FFEINFO_kindtypeINTEGER2:
1396 error = ffetarget_convert_logical2_integer2
1397 (ffebld_cu_ptr_logical2 (u),
1398 ffebld_constant_integer2 (ffebld_conter (l)));
1399 break;
1400#endif
1401
1402#if FFETARGET_okINTEGER3
1403 case FFEINFO_kindtypeINTEGER3:
1404 error = ffetarget_convert_logical2_integer3
1405 (ffebld_cu_ptr_logical2 (u),
1406 ffebld_constant_integer3 (ffebld_conter (l)));
1407 break;
1408#endif
1409
1410#if FFETARGET_okINTEGER4
1411 case FFEINFO_kindtypeINTEGER4:
1412 error = ffetarget_convert_logical2_integer4
1413 (ffebld_cu_ptr_logical2 (u),
1414 ffebld_constant_integer4 (ffebld_conter (l)));
1415 break;
1416#endif
1417
1418 default:
1419 assert ("LOGICAL2/INTEGER bad source kind type" == NULL);
1420 break;
1421 }
1422 break;
1423
1424 case FFEINFO_basictypeCHARACTER:
1425 error = ffetarget_convert_logical2_character1
1426 (ffebld_cu_ptr_logical2 (u),
1427 ffebld_constant_character1 (ffebld_conter (l)));
1428 break;
1429
1430 case FFEINFO_basictypeHOLLERITH:
1431 error = ffetarget_convert_logical2_hollerith
1432 (ffebld_cu_ptr_logical2 (u),
1433 ffebld_constant_hollerith (ffebld_conter (l)));
1434 break;
1435
1436 case FFEINFO_basictypeTYPELESS:
1437 error = ffetarget_convert_logical2_typeless
1438 (ffebld_cu_ptr_logical2 (u),
1439 ffebld_constant_typeless (ffebld_conter (l)));
1440 break;
1441
1442 default:
1443 assert ("LOGICAL2 bad type" == NULL);
1444 break;
1445 }
1446
1447 /* If conversion operation is not implemented, return original expr. */
1448 if (error == FFEBAD_NOCANDO)
1449 return expr;
1450
1451 expr = ffebld_new_conter_with_orig
1452 (ffebld_constant_new_logical2_val
1453 (ffebld_cu_val_logical2 (u)), expr);
1454 break;
1455#endif
1456
1457#if FFETARGET_okLOGICAL3
1458 case FFEINFO_kindtypeLOGICAL3:
1459 switch (ffeinfo_basictype (ffebld_info (l)))
1460 {
1461 case FFEINFO_basictypeLOGICAL:
1462 switch (ffeinfo_kindtype (ffebld_info (l)))
1463 {
1464#if FFETARGET_okLOGICAL1
1465 case FFEINFO_kindtypeLOGICAL1:
1466 error = ffetarget_convert_logical3_logical1
1467 (ffebld_cu_ptr_logical3 (u),
1468 ffebld_constant_logical1 (ffebld_conter (l)));
1469 break;
1470#endif
1471
1472#if FFETARGET_okLOGICAL2
1473 case FFEINFO_kindtypeLOGICAL2:
1474 error = ffetarget_convert_logical3_logical2
1475 (ffebld_cu_ptr_logical3 (u),
1476 ffebld_constant_logical2 (ffebld_conter (l)));
1477 break;
1478#endif
1479
1480#if FFETARGET_okLOGICAL4
1481 case FFEINFO_kindtypeLOGICAL4:
1482 error = ffetarget_convert_logical3_logical4
1483 (ffebld_cu_ptr_logical3 (u),
1484 ffebld_constant_logical4 (ffebld_conter (l)));
1485 break;
1486#endif
1487
1488 default:
1489 assert ("LOGICAL3/LOGICAL bad source kind type" == NULL);
1490 break;
1491 }
1492 break;
1493
1494 case FFEINFO_basictypeINTEGER:
1495 switch (ffeinfo_kindtype (ffebld_info (l)))
1496 {
1497#if FFETARGET_okINTEGER1
1498 case FFEINFO_kindtypeINTEGER1:
1499 error = ffetarget_convert_logical3_integer1
1500 (ffebld_cu_ptr_logical3 (u),
1501 ffebld_constant_integer1 (ffebld_conter (l)));
1502 break;
1503#endif
1504
1505#if FFETARGET_okINTEGER2
1506 case FFEINFO_kindtypeINTEGER2:
1507 error = ffetarget_convert_logical3_integer2
1508 (ffebld_cu_ptr_logical3 (u),
1509 ffebld_constant_integer2 (ffebld_conter (l)));
1510 break;
1511#endif
1512
1513#if FFETARGET_okINTEGER3
1514 case FFEINFO_kindtypeINTEGER3:
1515 error = ffetarget_convert_logical3_integer3
1516 (ffebld_cu_ptr_logical3 (u),
1517 ffebld_constant_integer3 (ffebld_conter (l)));
1518 break;
1519#endif
1520
1521#if FFETARGET_okINTEGER4
1522 case FFEINFO_kindtypeINTEGER4:
1523 error = ffetarget_convert_logical3_integer4
1524 (ffebld_cu_ptr_logical3 (u),
1525 ffebld_constant_integer4 (ffebld_conter (l)));
1526 break;
1527#endif
1528
1529 default:
1530 assert ("LOGICAL3/INTEGER bad source kind type" == NULL);
1531 break;
1532 }
1533 break;
1534
1535 case FFEINFO_basictypeCHARACTER:
1536 error = ffetarget_convert_logical3_character1
1537 (ffebld_cu_ptr_logical3 (u),
1538 ffebld_constant_character1 (ffebld_conter (l)));
1539 break;
1540
1541 case FFEINFO_basictypeHOLLERITH:
1542 error = ffetarget_convert_logical3_hollerith
1543 (ffebld_cu_ptr_logical3 (u),
1544 ffebld_constant_hollerith (ffebld_conter (l)));
1545 break;
1546
1547 case FFEINFO_basictypeTYPELESS:
1548 error = ffetarget_convert_logical3_typeless
1549 (ffebld_cu_ptr_logical3 (u),
1550 ffebld_constant_typeless (ffebld_conter (l)));
1551 break;
1552
1553 default:
1554 assert ("LOGICAL3 bad type" == NULL);
1555 break;
1556 }
1557
1558 /* If conversion operation is not implemented, return original expr. */
1559 if (error == FFEBAD_NOCANDO)
1560 return expr;
1561
1562 expr = ffebld_new_conter_with_orig
1563 (ffebld_constant_new_logical3_val
1564 (ffebld_cu_val_logical3 (u)), expr);
1565 break;
1566#endif
1567
1568#if FFETARGET_okLOGICAL4
1569 case FFEINFO_kindtypeLOGICAL4:
1570 switch (ffeinfo_basictype (ffebld_info (l)))
1571 {
1572 case FFEINFO_basictypeLOGICAL:
1573 switch (ffeinfo_kindtype (ffebld_info (l)))
1574 {
1575#if FFETARGET_okLOGICAL1
1576 case FFEINFO_kindtypeLOGICAL1:
1577 error = ffetarget_convert_logical4_logical1
1578 (ffebld_cu_ptr_logical4 (u),
1579 ffebld_constant_logical1 (ffebld_conter (l)));
1580 break;
1581#endif
1582
1583#if FFETARGET_okLOGICAL2
1584 case FFEINFO_kindtypeLOGICAL2:
1585 error = ffetarget_convert_logical4_logical2
1586 (ffebld_cu_ptr_logical4 (u),
1587 ffebld_constant_logical2 (ffebld_conter (l)));
1588 break;
1589#endif
1590
1591#if FFETARGET_okLOGICAL3
1592 case FFEINFO_kindtypeLOGICAL3:
1593 error = ffetarget_convert_logical4_logical3
1594 (ffebld_cu_ptr_logical4 (u),
1595 ffebld_constant_logical3 (ffebld_conter (l)));
1596 break;
1597#endif
1598
1599 default:
1600 assert ("LOGICAL4/LOGICAL bad source kind type" == NULL);
1601 break;
1602 }
1603 break;
1604
1605 case FFEINFO_basictypeINTEGER:
1606 switch (ffeinfo_kindtype (ffebld_info (l)))
1607 {
1608#if FFETARGET_okINTEGER1
1609 case FFEINFO_kindtypeINTEGER1:
1610 error = ffetarget_convert_logical4_integer1
1611 (ffebld_cu_ptr_logical4 (u),
1612 ffebld_constant_integer1 (ffebld_conter (l)));
1613 break;
1614#endif
1615
1616#if FFETARGET_okINTEGER2
1617 case FFEINFO_kindtypeINTEGER2:
1618 error = ffetarget_convert_logical4_integer2
1619 (ffebld_cu_ptr_logical4 (u),
1620 ffebld_constant_integer2 (ffebld_conter (l)));
1621 break;
1622#endif
1623
1624#if FFETARGET_okINTEGER3
1625 case FFEINFO_kindtypeINTEGER3:
1626 error = ffetarget_convert_logical4_integer3
1627 (ffebld_cu_ptr_logical4 (u),
1628 ffebld_constant_integer3 (ffebld_conter (l)));
1629 break;
1630#endif
1631
1632#if FFETARGET_okINTEGER4
1633 case FFEINFO_kindtypeINTEGER4:
1634 error = ffetarget_convert_logical4_integer4
1635 (ffebld_cu_ptr_logical4 (u),
1636 ffebld_constant_integer4 (ffebld_conter (l)));
1637 break;
1638#endif
1639
1640 default:
1641 assert ("LOGICAL4/INTEGER bad source kind type" == NULL);
1642 break;
1643 }
1644 break;
1645
1646 case FFEINFO_basictypeCHARACTER:
1647 error = ffetarget_convert_logical4_character1
1648 (ffebld_cu_ptr_logical4 (u),
1649 ffebld_constant_character1 (ffebld_conter (l)));
1650 break;
1651
1652 case FFEINFO_basictypeHOLLERITH:
1653 error = ffetarget_convert_logical4_hollerith
1654 (ffebld_cu_ptr_logical4 (u),
1655 ffebld_constant_hollerith (ffebld_conter (l)));
1656 break;
1657
1658 case FFEINFO_basictypeTYPELESS:
1659 error = ffetarget_convert_logical4_typeless
1660 …Large files files are truncated, but you can click here to view the full file