PageRenderTime 151ms CodeModel.GetById 14ms RepoModel.GetById 0ms app.codeStats 2ms

/gcc-2.95.2/gcc/f/expr.c

https://bitbucket.org/monaka/brightv-buildenv
C | 17141 lines | 13729 code | 2051 blank | 1361 comment | 2451 complexity | 37669c40c33a4929d1f2149bbd001c83 MD5 | raw file
Possible License(s): GPL-2.0, LGPL-2.0
  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. This file is part of GNU Fortran.
  5. GNU Fortran is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published by
  7. the Free Software Foundation; either version 2, or (at your option)
  8. any later version.
  9. GNU Fortran is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with GNU Fortran; see the file COPYING. If not, write to
  15. the Free Software Foundation, 59 Temple Place - Suite 330, Boston, MA
  16. 02111-1307, USA.
  17. Related Modules:
  18. None.
  19. Description:
  20. Handles syntactic and semantic analysis of Fortran expressions.
  21. Modifications:
  22. */
  23. /* Include files. */
  24. #include "proj.h"
  25. #include "expr.h"
  26. #include "bad.h"
  27. #include "bld.h"
  28. #include "com.h"
  29. #include "global.h"
  30. #include "implic.h"
  31. #include "intrin.h"
  32. #include "info.h"
  33. #include "lex.h"
  34. #include "malloc.h"
  35. #include "src.h"
  36. #include "st.h"
  37. #include "symbol.h"
  38. #include "str.h"
  39. #include "target.h"
  40. #include "where.h"
  41. /* Externals defined here. */
  42. /* Simple definitions and enumerations. */
  43. typedef enum
  44. {
  45. FFEEXPR_exprtypeUNKNOWN_,
  46. FFEEXPR_exprtypeOPERAND_,
  47. FFEEXPR_exprtypeUNARY_,
  48. FFEEXPR_exprtypeBINARY_,
  49. FFEEXPR_exprtype_
  50. } ffeexprExprtype_;
  51. typedef enum
  52. {
  53. FFEEXPR_operatorPOWER_,
  54. FFEEXPR_operatorMULTIPLY_,
  55. FFEEXPR_operatorDIVIDE_,
  56. FFEEXPR_operatorADD_,
  57. FFEEXPR_operatorSUBTRACT_,
  58. FFEEXPR_operatorCONCATENATE_,
  59. FFEEXPR_operatorLT_,
  60. FFEEXPR_operatorLE_,
  61. FFEEXPR_operatorEQ_,
  62. FFEEXPR_operatorNE_,
  63. FFEEXPR_operatorGT_,
  64. FFEEXPR_operatorGE_,
  65. FFEEXPR_operatorNOT_,
  66. FFEEXPR_operatorAND_,
  67. FFEEXPR_operatorOR_,
  68. FFEEXPR_operatorXOR_,
  69. FFEEXPR_operatorEQV_,
  70. FFEEXPR_operatorNEQV_,
  71. FFEEXPR_operator_
  72. } ffeexprOperator_;
  73. typedef enum
  74. {
  75. FFEEXPR_operatorprecedenceHIGHEST_ = 1,
  76. FFEEXPR_operatorprecedencePOWER_ = 1,
  77. FFEEXPR_operatorprecedenceMULTIPLY_ = 2,
  78. FFEEXPR_operatorprecedenceDIVIDE_ = 2,
  79. FFEEXPR_operatorprecedenceADD_ = 3,
  80. FFEEXPR_operatorprecedenceSUBTRACT_ = 3,
  81. FFEEXPR_operatorprecedenceLOWARITH_ = 3,
  82. FFEEXPR_operatorprecedenceCONCATENATE_ = 3,
  83. FFEEXPR_operatorprecedenceLT_ = 4,
  84. FFEEXPR_operatorprecedenceLE_ = 4,
  85. FFEEXPR_operatorprecedenceEQ_ = 4,
  86. FFEEXPR_operatorprecedenceNE_ = 4,
  87. FFEEXPR_operatorprecedenceGT_ = 4,
  88. FFEEXPR_operatorprecedenceGE_ = 4,
  89. FFEEXPR_operatorprecedenceNOT_ = 5,
  90. FFEEXPR_operatorprecedenceAND_ = 6,
  91. FFEEXPR_operatorprecedenceOR_ = 7,
  92. FFEEXPR_operatorprecedenceXOR_ = 8,
  93. FFEEXPR_operatorprecedenceEQV_ = 8,
  94. FFEEXPR_operatorprecedenceNEQV_ = 8,
  95. FFEEXPR_operatorprecedenceLOWEST_ = 8,
  96. FFEEXPR_operatorprecedence_
  97. } ffeexprOperatorPrecedence_;
  98. #define FFEEXPR_operatorassociativityL2R_ TRUE
  99. #define FFEEXPR_operatorassociativityR2L_ FALSE
  100. #define FFEEXPR_operatorassociativityPOWER_ FFEEXPR_operatorassociativityR2L_
  101. #define FFEEXPR_operatorassociativityMULTIPLY_ FFEEXPR_operatorassociativityL2R_
  102. #define FFEEXPR_operatorassociativityDIVIDE_ FFEEXPR_operatorassociativityL2R_
  103. #define FFEEXPR_operatorassociativityADD_ FFEEXPR_operatorassociativityL2R_
  104. #define FFEEXPR_operatorassociativitySUBTRACT_ FFEEXPR_operatorassociativityL2R_
  105. #define FFEEXPR_operatorassociativityCONCATENATE_ FFEEXPR_operatorassociativityL2R_
  106. #define FFEEXPR_operatorassociativityLT_ FFEEXPR_operatorassociativityL2R_
  107. #define FFEEXPR_operatorassociativityLE_ FFEEXPR_operatorassociativityL2R_
  108. #define FFEEXPR_operatorassociativityEQ_ FFEEXPR_operatorassociativityL2R_
  109. #define FFEEXPR_operatorassociativityNE_ FFEEXPR_operatorassociativityL2R_
  110. #define FFEEXPR_operatorassociativityGT_ FFEEXPR_operatorassociativityL2R_
  111. #define FFEEXPR_operatorassociativityGE_ FFEEXPR_operatorassociativityL2R_
  112. #define FFEEXPR_operatorassociativityNOT_ FFEEXPR_operatorassociativityL2R_
  113. #define FFEEXPR_operatorassociativityAND_ FFEEXPR_operatorassociativityL2R_
  114. #define FFEEXPR_operatorassociativityOR_ FFEEXPR_operatorassociativityL2R_
  115. #define FFEEXPR_operatorassociativityXOR_ FFEEXPR_operatorassociativityL2R_
  116. #define FFEEXPR_operatorassociativityEQV_ FFEEXPR_operatorassociativityL2R_
  117. #define FFEEXPR_operatorassociativityNEQV_ FFEEXPR_operatorassociativityL2R_
  118. typedef enum
  119. {
  120. FFEEXPR_parentypeFUNCTION_,
  121. FFEEXPR_parentypeSUBROUTINE_,
  122. FFEEXPR_parentypeARRAY_,
  123. FFEEXPR_parentypeSUBSTRING_,
  124. FFEEXPR_parentypeFUNSUBSTR_,/* Ambig: check for colon after first expr. */
  125. FFEEXPR_parentypeEQUIVALENCE_, /* Ambig: ARRAY_ or SUBSTRING_. */
  126. FFEEXPR_parentypeANY_, /* Allow basically anything. */
  127. FFEEXPR_parentype_
  128. } ffeexprParenType_;
  129. typedef enum
  130. {
  131. FFEEXPR_percentNONE_,
  132. FFEEXPR_percentLOC_,
  133. FFEEXPR_percentVAL_,
  134. FFEEXPR_percentREF_,
  135. FFEEXPR_percentDESCR_,
  136. FFEEXPR_percent_
  137. } ffeexprPercent_;
  138. /* Internal typedefs. */
  139. typedef struct _ffeexpr_expr_ *ffeexprExpr_;
  140. typedef bool ffeexprOperatorAssociativity_;
  141. typedef struct _ffeexpr_stack_ *ffeexprStack_;
  142. /* Private include files. */
  143. /* Internal structure definitions. */
  144. struct _ffeexpr_expr_
  145. {
  146. ffeexprExpr_ previous;
  147. ffelexToken token;
  148. ffeexprExprtype_ type;
  149. union
  150. {
  151. struct
  152. {
  153. ffeexprOperator_ op;
  154. ffeexprOperatorPrecedence_ prec;
  155. ffeexprOperatorAssociativity_ as;
  156. }
  157. operator;
  158. ffebld operand;
  159. }
  160. u;
  161. };
  162. struct _ffeexpr_stack_
  163. {
  164. ffeexprStack_ previous;
  165. mallocPool pool;
  166. ffeexprContext context;
  167. ffeexprCallback callback;
  168. ffelexToken first_token;
  169. ffeexprExpr_ exprstack;
  170. ffelexToken tokens[10]; /* Used in certain cases, like (unary)
  171. open-paren. */
  172. ffebld expr; /* For first of
  173. complex/implied-do/substring/array-elements
  174. / actual-args expression. */
  175. ffebld bound_list; /* For tracking dimension bounds list of
  176. array. */
  177. ffebldListBottom bottom; /* For building lists. */
  178. ffeinfoRank rank; /* For elements in an array reference. */
  179. bool constant; /* TRUE while elements seen so far are
  180. constants. */
  181. bool immediate; /* TRUE while elements seen so far are
  182. immediate/constants. */
  183. ffebld next_dummy; /* Next SFUNC dummy arg in arg list. */
  184. ffebldListLength num_args; /* Number of dummy args expected in arg list. */
  185. bool is_rhs; /* TRUE if rhs context, FALSE otherwise. */
  186. ffeexprPercent_ percent; /* Current %FOO keyword. */
  187. };
  188. struct _ffeexpr_find_
  189. {
  190. ffelexToken t;
  191. ffelexHandler after;
  192. int level;
  193. };
  194. /* Static objects accessed by functions in this module. */
  195. static ffeexprStack_ ffeexpr_stack_; /* Expression stack for semantic. */
  196. static ffelexToken ffeexpr_tokens_[10]; /* Scratchpad tokens for syntactic. */
  197. static ffestrOther ffeexpr_current_dotdot_; /* Current .FOO. keyword. */
  198. static long ffeexpr_hollerith_count_; /* ffeexpr_token_number_ and caller. */
  199. static int ffeexpr_level_; /* Level of DATA implied-DO construct. */
  200. static bool ffeexpr_is_substr_ok_; /* If OPEN_PAREN as binary "op" ok. */
  201. static struct _ffeexpr_find_ ffeexpr_find_;
  202. /* Static functions (internal). */
  203. static ffelexHandler ffeexpr_cb_close_paren_ (ffelexToken ft, ffebld expr,
  204. ffelexToken t);
  205. static ffelexHandler ffeexpr_cb_close_paren_ambig_ (ffelexToken ft,
  206. ffebld expr,
  207. ffelexToken t);
  208. static ffelexHandler ffeexpr_cb_close_paren_ambig_1_ (ffelexToken t);
  209. static ffelexHandler ffeexpr_cb_close_paren_c_ (ffelexToken ft,
  210. ffebld expr, ffelexToken t);
  211. static ffelexHandler ffeexpr_cb_comma_c_ (ffelexToken ft, ffebld expr,
  212. ffelexToken t);
  213. static ffelexHandler ffeexpr_cb_close_paren_ci_ (ffelexToken ft,
  214. ffebld expr, ffelexToken t);
  215. static ffelexHandler ffeexpr_cb_comma_ci_ (ffelexToken ft, ffebld expr,
  216. ffelexToken t);
  217. static ffelexHandler ffeexpr_cb_comma_i_ (ffelexToken ft, ffebld expr,
  218. ffelexToken t);
  219. static ffelexHandler ffeexpr_cb_comma_i_1_ (ffelexToken ft, ffebld expr,
  220. ffelexToken t);
  221. static ffelexHandler ffeexpr_cb_comma_i_2_ (ffelexToken ft, ffebld expr,
  222. ffelexToken t);
  223. static ffelexHandler ffeexpr_cb_comma_i_3_ (ffelexToken ft, ffebld expr,
  224. ffelexToken t);
  225. static ffelexHandler ffeexpr_cb_comma_i_4_ (ffelexToken ft, ffebld expr,
  226. ffelexToken t);
  227. static ffelexHandler ffeexpr_cb_comma_i_5_ (ffelexToken t);
  228. static ffelexHandler ffeexpr_cb_end_loc_ (ffelexToken ft, ffebld expr,
  229. ffelexToken t);
  230. static ffelexHandler ffeexpr_cb_end_notloc_ (ffelexToken ft, ffebld expr,
  231. ffelexToken t);
  232. static ffelexHandler ffeexpr_cb_end_notloc_1_ (ffelexToken t);
  233. static ffesymbol ffeexpr_check_impctrl_ (ffesymbol s);
  234. static void ffeexpr_check_impdo_ (ffebld list, ffelexToken list_t,
  235. ffebld dovar, ffelexToken dovar_t);
  236. static void ffeexpr_update_impdo_ (ffebld expr, ffebld dovar);
  237. static void ffeexpr_update_impdo_sym_ (ffebld expr, ffesymbol dovar);
  238. static ffeexprContext ffeexpr_context_outer_ (ffeexprStack_ s);
  239. static ffeexprExpr_ ffeexpr_expr_new_ (void);
  240. static void ffeexpr_fulfill_call_ (ffebld *expr, ffelexToken t);
  241. static bool ffeexpr_isdigits_ (const char *p);
  242. static ffelexHandler ffeexpr_token_first_lhs_ (ffelexToken t);
  243. static ffelexHandler ffeexpr_token_first_lhs_1_ (ffelexToken t);
  244. static ffelexHandler ffeexpr_token_first_rhs_ (ffelexToken t);
  245. static ffelexHandler ffeexpr_token_first_rhs_1_ (ffelexToken t);
  246. static ffelexHandler ffeexpr_token_first_rhs_2_ (ffelexToken t);
  247. static ffelexHandler ffeexpr_token_first_rhs_3_ (ffelexToken t);
  248. static ffelexHandler ffeexpr_token_first_rhs_4_ (ffelexToken t);
  249. static ffelexHandler ffeexpr_token_first_rhs_5_ (ffelexToken t);
  250. static ffelexHandler ffeexpr_token_first_rhs_6_ (ffelexToken t);
  251. static ffelexHandler ffeexpr_token_namelist_ (ffelexToken t);
  252. static void ffeexpr_expr_kill_ (ffeexprExpr_ e);
  253. static void ffeexpr_exprstack_push_ (ffeexprExpr_ e);
  254. static void ffeexpr_exprstack_push_binary_ (ffeexprExpr_ e);
  255. static void ffeexpr_exprstack_push_operand_ (ffeexprExpr_ e);
  256. static void ffeexpr_exprstack_push_unary_ (ffeexprExpr_ e);
  257. static void ffeexpr_reduce_ (void);
  258. static ffebld ffeexpr_reduced_bool1_ (ffebld reduced, ffeexprExpr_ op,
  259. ffeexprExpr_ r);
  260. static ffebld ffeexpr_reduced_bool2_ (ffebld reduced, ffeexprExpr_ l,
  261. ffeexprExpr_ op, ffeexprExpr_ r);
  262. static ffebld ffeexpr_reduced_concatenate_ (ffebld reduced, ffeexprExpr_ l,
  263. ffeexprExpr_ op, ffeexprExpr_ r);
  264. static ffebld ffeexpr_reduced_eqop2_ (ffebld reduced, ffeexprExpr_ l,
  265. ffeexprExpr_ op, ffeexprExpr_ r);
  266. static ffebld ffeexpr_reduced_math1_ (ffebld reduced, ffeexprExpr_ op,
  267. ffeexprExpr_ r);
  268. static ffebld ffeexpr_reduced_math2_ (ffebld reduced, ffeexprExpr_ l,
  269. ffeexprExpr_ op, ffeexprExpr_ r);
  270. static ffebld ffeexpr_reduced_power_ (ffebld reduced, ffeexprExpr_ l,
  271. ffeexprExpr_ op, ffeexprExpr_ r);
  272. static ffebld ffeexpr_reduced_relop2_ (ffebld reduced, ffeexprExpr_ l,
  273. ffeexprExpr_ op, ffeexprExpr_ r);
  274. static ffebld ffeexpr_reduced_ugly1_ (ffebld reduced, ffeexprExpr_ op, ffeexprExpr_ r);
  275. static ffebld ffeexpr_reduced_ugly1log_ (ffebld reduced, ffeexprExpr_ op,
  276. ffeexprExpr_ r);
  277. static ffebld ffeexpr_reduced_ugly2_ (ffebld reduced, ffeexprExpr_ l,
  278. ffeexprExpr_ op, ffeexprExpr_ r);
  279. static ffebld ffeexpr_reduced_ugly2log_ (ffebld reduced, ffeexprExpr_ l,
  280. ffeexprExpr_ op, ffeexprExpr_ r);
  281. static ffelexHandler ffeexpr_find_close_paren_ (ffelexToken t,
  282. ffelexHandler after);
  283. static ffelexHandler ffeexpr_nil_finished_ (ffelexToken t);
  284. static ffelexHandler ffeexpr_nil_rhs_ (ffelexToken t);
  285. static ffelexHandler ffeexpr_nil_period_ (ffelexToken t);
  286. static ffelexHandler ffeexpr_nil_end_period_ (ffelexToken t);
  287. static ffelexHandler ffeexpr_nil_swallow_period_ (ffelexToken t);
  288. static ffelexHandler ffeexpr_nil_real_ (ffelexToken t);
  289. static ffelexHandler ffeexpr_nil_real_exponent_ (ffelexToken t);
  290. static ffelexHandler ffeexpr_nil_real_exp_sign_ (ffelexToken t);
  291. static ffelexHandler ffeexpr_nil_number_ (ffelexToken t);
  292. static ffelexHandler ffeexpr_nil_number_exponent_ (ffelexToken t);
  293. static ffelexHandler ffeexpr_nil_number_exp_sign_ (ffelexToken t);
  294. static ffelexHandler ffeexpr_nil_number_period_ (ffelexToken t);
  295. static ffelexHandler ffeexpr_nil_number_per_exp_ (ffelexToken t);
  296. static ffelexHandler ffeexpr_nil_number_real_ (ffelexToken t);
  297. static ffelexHandler ffeexpr_nil_num_per_exp_sign_ (ffelexToken t);
  298. static ffelexHandler ffeexpr_nil_number_real_exp_ (ffelexToken t);
  299. static ffelexHandler ffeexpr_nil_num_real_exp_sn_ (ffelexToken t);
  300. static ffelexHandler ffeexpr_nil_binary_ (ffelexToken t);
  301. static ffelexHandler ffeexpr_nil_binary_period_ (ffelexToken t);
  302. static ffelexHandler ffeexpr_nil_binary_end_per_ (ffelexToken t);
  303. static ffelexHandler ffeexpr_nil_binary_sw_per_ (ffelexToken t);
  304. static ffelexHandler ffeexpr_nil_quote_ (ffelexToken t);
  305. static ffelexHandler ffeexpr_nil_apostrophe_ (ffelexToken t);
  306. static ffelexHandler ffeexpr_nil_apos_char_ (ffelexToken t);
  307. static ffelexHandler ffeexpr_nil_name_rhs_ (ffelexToken t);
  308. static ffelexHandler ffeexpr_nil_name_apos_ (ffelexToken t);
  309. static ffelexHandler ffeexpr_nil_name_apos_name_ (ffelexToken t);
  310. static ffelexHandler ffeexpr_nil_percent_ (ffelexToken t);
  311. static ffelexHandler ffeexpr_nil_percent_name_ (ffelexToken t);
  312. static ffelexHandler ffeexpr_nil_substrp_ (ffelexToken t);
  313. static ffelexHandler ffeexpr_finished_ (ffelexToken t);
  314. static ffebld ffeexpr_finished_ambig_ (ffelexToken t, ffebld expr);
  315. static ffelexHandler ffeexpr_token_lhs_ (ffelexToken t);
  316. static ffelexHandler ffeexpr_token_rhs_ (ffelexToken t);
  317. static ffelexHandler ffeexpr_token_binary_ (ffelexToken t);
  318. static ffelexHandler ffeexpr_token_period_ (ffelexToken t);
  319. static ffelexHandler ffeexpr_token_end_period_ (ffelexToken t);
  320. static ffelexHandler ffeexpr_token_swallow_period_ (ffelexToken t);
  321. static ffelexHandler ffeexpr_token_real_ (ffelexToken t);
  322. static ffelexHandler ffeexpr_token_real_exponent_ (ffelexToken t);
  323. static ffelexHandler ffeexpr_token_real_exp_sign_ (ffelexToken t);
  324. static ffelexHandler ffeexpr_token_number_ (ffelexToken t);
  325. static ffelexHandler ffeexpr_token_number_exponent_ (ffelexToken t);
  326. static ffelexHandler ffeexpr_token_number_exp_sign_ (ffelexToken t);
  327. static ffelexHandler ffeexpr_token_number_period_ (ffelexToken t);
  328. static ffelexHandler ffeexpr_token_number_per_exp_ (ffelexToken t);
  329. static ffelexHandler ffeexpr_token_number_real_ (ffelexToken t);
  330. static ffelexHandler ffeexpr_token_num_per_exp_sign_ (ffelexToken t);
  331. static ffelexHandler ffeexpr_token_number_real_exp_ (ffelexToken t);
  332. static ffelexHandler ffeexpr_token_num_real_exp_sn_ (ffelexToken t);
  333. static ffelexHandler ffeexpr_token_binary_period_ (ffelexToken t);
  334. static ffelexHandler ffeexpr_token_binary_end_per_ (ffelexToken t);
  335. static ffelexHandler ffeexpr_token_binary_sw_per_ (ffelexToken t);
  336. static ffelexHandler ffeexpr_token_quote_ (ffelexToken t);
  337. static ffelexHandler ffeexpr_token_apostrophe_ (ffelexToken t);
  338. static ffelexHandler ffeexpr_token_apos_char_ (ffelexToken t);
  339. static ffelexHandler ffeexpr_token_name_lhs_ (ffelexToken t);
  340. static ffelexHandler ffeexpr_token_name_arg_ (ffelexToken t);
  341. static ffelexHandler ffeexpr_token_name_rhs_ (ffelexToken t);
  342. static ffelexHandler ffeexpr_token_name_apos_ (ffelexToken t);
  343. static ffelexHandler ffeexpr_token_name_apos_name_ (ffelexToken t);
  344. static ffelexHandler ffeexpr_token_percent_ (ffelexToken t);
  345. static ffelexHandler ffeexpr_token_percent_name_ (ffelexToken t);
  346. static ffelexHandler ffeexpr_token_arguments_ (ffelexToken ft, ffebld expr,
  347. ffelexToken t);
  348. static ffelexHandler ffeexpr_token_elements_ (ffelexToken ft, ffebld expr,
  349. ffelexToken t);
  350. static ffelexHandler ffeexpr_token_equivalence_ (ffelexToken ft, ffebld expr,
  351. ffelexToken t);
  352. static ffelexHandler ffeexpr_token_substring_ (ffelexToken ft, ffebld expr,
  353. ffelexToken t);
  354. static ffelexHandler ffeexpr_token_substring_1_ (ffelexToken ft, ffebld expr,
  355. ffelexToken t);
  356. static ffelexHandler ffeexpr_token_substrp_ (ffelexToken t);
  357. static ffelexHandler ffeexpr_token_intrincheck_ (ffelexToken t);
  358. static ffelexHandler ffeexpr_token_funsubstr_ (ffelexToken ft, ffebld expr,
  359. ffelexToken t);
  360. static ffelexHandler ffeexpr_token_anything_ (ffelexToken ft, ffebld expr,
  361. ffelexToken t);
  362. static void ffeexpr_make_float_const_ (char exp_letter, ffelexToken integer,
  363. ffelexToken decimal, ffelexToken fraction, ffelexToken exponent,
  364. ffelexToken exponent_sign, ffelexToken exponent_digits);
  365. static ffesymbol ffeexpr_declare_unadorned_ (ffelexToken t, bool maybe_intrin);
  366. static ffesymbol ffeexpr_sym_impdoitem_ (ffesymbol s, ffelexToken t);
  367. static ffesymbol ffeexpr_sym_lhs_call_ (ffesymbol s, ffelexToken t);
  368. static ffesymbol ffeexpr_sym_lhs_data_ (ffesymbol s, ffelexToken t);
  369. static ffesymbol ffeexpr_sym_lhs_equivalence_ (ffesymbol s, ffelexToken t);
  370. static ffesymbol ffeexpr_sym_lhs_extfunc_ (ffesymbol s, ffelexToken t);
  371. static ffesymbol ffeexpr_sym_lhs_impdoctrl_ (ffesymbol s, ffelexToken t);
  372. static ffesymbol ffeexpr_sym_lhs_parameter_ (ffesymbol s, ffelexToken t);
  373. static ffesymbol ffeexpr_sym_rhs_actualarg_ (ffesymbol s, ffelexToken t);
  374. static ffesymbol ffeexpr_sym_rhs_dimlist_ (ffesymbol s, ffelexToken t);
  375. static ffesymbol ffeexpr_sym_rhs_let_ (ffesymbol s, ffelexToken t);
  376. static ffesymbol ffeexpr_declare_parenthesized_ (ffelexToken t,
  377. bool maybe_intrin,
  378. ffeexprParenType_ *paren_type);
  379. static ffesymbol ffeexpr_paren_rhs_let_ (ffesymbol s, ffelexToken t);
  380. /* Internal macros. */
  381. #define ffeexpr_paren_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
  382. #define ffeexpr_sym_lhs_let_(s,t) ffeexpr_sym_rhs_let_(s,t)
  383. /* ffeexpr_collapse_convert -- Collapse convert expr
  384. ffebld expr;
  385. ffelexToken token;
  386. expr = ffeexpr_collapse_convert(expr,token);
  387. If the result of the expr is a constant, replaces the expr with the
  388. computed constant. */
  389. ffebld
  390. ffeexpr_collapse_convert (ffebld expr, ffelexToken t)
  391. {
  392. ffebad error = FFEBAD;
  393. ffebld l;
  394. ffebldConstantUnion u;
  395. ffeinfoBasictype bt;
  396. ffeinfoKindtype kt;
  397. ffetargetCharacterSize sz;
  398. ffetargetCharacterSize sz2;
  399. if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  400. return expr;
  401. l = ffebld_left (expr);
  402. if (ffebld_op (l) != FFEBLD_opCONTER)
  403. return expr;
  404. switch (bt = ffeinfo_basictype (ffebld_info (expr)))
  405. {
  406. case FFEINFO_basictypeANY:
  407. return expr;
  408. case FFEINFO_basictypeINTEGER:
  409. sz = FFETARGET_charactersizeNONE;
  410. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  411. {
  412. #if FFETARGET_okINTEGER1
  413. case FFEINFO_kindtypeINTEGER1:
  414. switch (ffeinfo_basictype (ffebld_info (l)))
  415. {
  416. case FFEINFO_basictypeINTEGER:
  417. switch (ffeinfo_kindtype (ffebld_info (l)))
  418. {
  419. #if FFETARGET_okINTEGER2
  420. case FFEINFO_kindtypeINTEGER2:
  421. error = ffetarget_convert_integer1_integer2
  422. (ffebld_cu_ptr_integer1 (u),
  423. ffebld_constant_integer2 (ffebld_conter (l)));
  424. break;
  425. #endif
  426. #if FFETARGET_okINTEGER3
  427. case FFEINFO_kindtypeINTEGER3:
  428. error = ffetarget_convert_integer1_integer3
  429. (ffebld_cu_ptr_integer1 (u),
  430. ffebld_constant_integer3 (ffebld_conter (l)));
  431. break;
  432. #endif
  433. #if FFETARGET_okINTEGER4
  434. case FFEINFO_kindtypeINTEGER4:
  435. error = ffetarget_convert_integer1_integer4
  436. (ffebld_cu_ptr_integer1 (u),
  437. ffebld_constant_integer4 (ffebld_conter (l)));
  438. break;
  439. #endif
  440. default:
  441. assert ("INTEGER1/INTEGER bad source kind type" == NULL);
  442. break;
  443. }
  444. break;
  445. case FFEINFO_basictypeREAL:
  446. switch (ffeinfo_kindtype (ffebld_info (l)))
  447. {
  448. #if FFETARGET_okREAL1
  449. case FFEINFO_kindtypeREAL1:
  450. error = ffetarget_convert_integer1_real1
  451. (ffebld_cu_ptr_integer1 (u),
  452. ffebld_constant_real1 (ffebld_conter (l)));
  453. break;
  454. #endif
  455. #if FFETARGET_okREAL2
  456. case FFEINFO_kindtypeREAL2:
  457. error = ffetarget_convert_integer1_real2
  458. (ffebld_cu_ptr_integer1 (u),
  459. ffebld_constant_real2 (ffebld_conter (l)));
  460. break;
  461. #endif
  462. #if FFETARGET_okREAL3
  463. case FFEINFO_kindtypeREAL3:
  464. error = ffetarget_convert_integer1_real3
  465. (ffebld_cu_ptr_integer1 (u),
  466. ffebld_constant_real3 (ffebld_conter (l)));
  467. break;
  468. #endif
  469. #if FFETARGET_okREAL4
  470. case FFEINFO_kindtypeREAL4:
  471. error = ffetarget_convert_integer1_real4
  472. (ffebld_cu_ptr_integer1 (u),
  473. ffebld_constant_real4 (ffebld_conter (l)));
  474. break;
  475. #endif
  476. default:
  477. assert ("INTEGER1/REAL bad source kind type" == NULL);
  478. break;
  479. }
  480. break;
  481. case FFEINFO_basictypeCOMPLEX:
  482. switch (ffeinfo_kindtype (ffebld_info (l)))
  483. {
  484. #if FFETARGET_okCOMPLEX1
  485. case FFEINFO_kindtypeREAL1:
  486. error = ffetarget_convert_integer1_complex1
  487. (ffebld_cu_ptr_integer1 (u),
  488. ffebld_constant_complex1 (ffebld_conter (l)));
  489. break;
  490. #endif
  491. #if FFETARGET_okCOMPLEX2
  492. case FFEINFO_kindtypeREAL2:
  493. error = ffetarget_convert_integer1_complex2
  494. (ffebld_cu_ptr_integer1 (u),
  495. ffebld_constant_complex2 (ffebld_conter (l)));
  496. break;
  497. #endif
  498. #if FFETARGET_okCOMPLEX3
  499. case FFEINFO_kindtypeREAL3:
  500. error = ffetarget_convert_integer1_complex3
  501. (ffebld_cu_ptr_integer1 (u),
  502. ffebld_constant_complex3 (ffebld_conter (l)));
  503. break;
  504. #endif
  505. #if FFETARGET_okCOMPLEX4
  506. case FFEINFO_kindtypeREAL4:
  507. error = ffetarget_convert_integer1_complex4
  508. (ffebld_cu_ptr_integer1 (u),
  509. ffebld_constant_complex4 (ffebld_conter (l)));
  510. break;
  511. #endif
  512. default:
  513. assert ("INTEGER1/COMPLEX bad source kind type" == NULL);
  514. break;
  515. }
  516. break;
  517. case FFEINFO_basictypeLOGICAL:
  518. switch (ffeinfo_kindtype (ffebld_info (l)))
  519. {
  520. #if FFETARGET_okLOGICAL1
  521. case FFEINFO_kindtypeLOGICAL1:
  522. error = ffetarget_convert_integer1_logical1
  523. (ffebld_cu_ptr_integer1 (u),
  524. ffebld_constant_logical1 (ffebld_conter (l)));
  525. break;
  526. #endif
  527. #if FFETARGET_okLOGICAL2
  528. case FFEINFO_kindtypeLOGICAL2:
  529. error = ffetarget_convert_integer1_logical2
  530. (ffebld_cu_ptr_integer1 (u),
  531. ffebld_constant_logical2 (ffebld_conter (l)));
  532. break;
  533. #endif
  534. #if FFETARGET_okLOGICAL3
  535. case FFEINFO_kindtypeLOGICAL3:
  536. error = ffetarget_convert_integer1_logical3
  537. (ffebld_cu_ptr_integer1 (u),
  538. ffebld_constant_logical3 (ffebld_conter (l)));
  539. break;
  540. #endif
  541. #if FFETARGET_okLOGICAL4
  542. case FFEINFO_kindtypeLOGICAL4:
  543. error = ffetarget_convert_integer1_logical4
  544. (ffebld_cu_ptr_integer1 (u),
  545. ffebld_constant_logical4 (ffebld_conter (l)));
  546. break;
  547. #endif
  548. default:
  549. assert ("INTEGER1/LOGICAL bad source kind type" == NULL);
  550. break;
  551. }
  552. break;
  553. case FFEINFO_basictypeCHARACTER:
  554. error = ffetarget_convert_integer1_character1
  555. (ffebld_cu_ptr_integer1 (u),
  556. ffebld_constant_character1 (ffebld_conter (l)));
  557. break;
  558. case FFEINFO_basictypeHOLLERITH:
  559. error = ffetarget_convert_integer1_hollerith
  560. (ffebld_cu_ptr_integer1 (u),
  561. ffebld_constant_hollerith (ffebld_conter (l)));
  562. break;
  563. case FFEINFO_basictypeTYPELESS:
  564. error = ffetarget_convert_integer1_typeless
  565. (ffebld_cu_ptr_integer1 (u),
  566. ffebld_constant_typeless (ffebld_conter (l)));
  567. break;
  568. default:
  569. assert ("INTEGER1 bad type" == NULL);
  570. break;
  571. }
  572. /* If conversion operation is not implemented, return original expr. */
  573. if (error == FFEBAD_NOCANDO)
  574. return expr;
  575. expr = ffebld_new_conter_with_orig
  576. (ffebld_constant_new_integer1_val
  577. (ffebld_cu_val_integer1 (u)), expr);
  578. break;
  579. #endif
  580. #if FFETARGET_okINTEGER2
  581. case FFEINFO_kindtypeINTEGER2:
  582. switch (ffeinfo_basictype (ffebld_info (l)))
  583. {
  584. case FFEINFO_basictypeINTEGER:
  585. switch (ffeinfo_kindtype (ffebld_info (l)))
  586. {
  587. #if FFETARGET_okINTEGER1
  588. case FFEINFO_kindtypeINTEGER1:
  589. error = ffetarget_convert_integer2_integer1
  590. (ffebld_cu_ptr_integer2 (u),
  591. ffebld_constant_integer1 (ffebld_conter (l)));
  592. break;
  593. #endif
  594. #if FFETARGET_okINTEGER3
  595. case FFEINFO_kindtypeINTEGER3:
  596. error = ffetarget_convert_integer2_integer3
  597. (ffebld_cu_ptr_integer2 (u),
  598. ffebld_constant_integer3 (ffebld_conter (l)));
  599. break;
  600. #endif
  601. #if FFETARGET_okINTEGER4
  602. case FFEINFO_kindtypeINTEGER4:
  603. error = ffetarget_convert_integer2_integer4
  604. (ffebld_cu_ptr_integer2 (u),
  605. ffebld_constant_integer4 (ffebld_conter (l)));
  606. break;
  607. #endif
  608. default:
  609. assert ("INTEGER2/INTEGER bad source kind type" == NULL);
  610. break;
  611. }
  612. break;
  613. case FFEINFO_basictypeREAL:
  614. switch (ffeinfo_kindtype (ffebld_info (l)))
  615. {
  616. #if FFETARGET_okREAL1
  617. case FFEINFO_kindtypeREAL1:
  618. error = ffetarget_convert_integer2_real1
  619. (ffebld_cu_ptr_integer2 (u),
  620. ffebld_constant_real1 (ffebld_conter (l)));
  621. break;
  622. #endif
  623. #if FFETARGET_okREAL2
  624. case FFEINFO_kindtypeREAL2:
  625. error = ffetarget_convert_integer2_real2
  626. (ffebld_cu_ptr_integer2 (u),
  627. ffebld_constant_real2 (ffebld_conter (l)));
  628. break;
  629. #endif
  630. #if FFETARGET_okREAL3
  631. case FFEINFO_kindtypeREAL3:
  632. error = ffetarget_convert_integer2_real3
  633. (ffebld_cu_ptr_integer2 (u),
  634. ffebld_constant_real3 (ffebld_conter (l)));
  635. break;
  636. #endif
  637. #if FFETARGET_okREAL4
  638. case FFEINFO_kindtypeREAL4:
  639. error = ffetarget_convert_integer2_real4
  640. (ffebld_cu_ptr_integer2 (u),
  641. ffebld_constant_real4 (ffebld_conter (l)));
  642. break;
  643. #endif
  644. default:
  645. assert ("INTEGER2/REAL bad source kind type" == NULL);
  646. break;
  647. }
  648. break;
  649. case FFEINFO_basictypeCOMPLEX:
  650. switch (ffeinfo_kindtype (ffebld_info (l)))
  651. {
  652. #if FFETARGET_okCOMPLEX1
  653. case FFEINFO_kindtypeREAL1:
  654. error = ffetarget_convert_integer2_complex1
  655. (ffebld_cu_ptr_integer2 (u),
  656. ffebld_constant_complex1 (ffebld_conter (l)));
  657. break;
  658. #endif
  659. #if FFETARGET_okCOMPLEX2
  660. case FFEINFO_kindtypeREAL2:
  661. error = ffetarget_convert_integer2_complex2
  662. (ffebld_cu_ptr_integer2 (u),
  663. ffebld_constant_complex2 (ffebld_conter (l)));
  664. break;
  665. #endif
  666. #if FFETARGET_okCOMPLEX3
  667. case FFEINFO_kindtypeREAL3:
  668. error = ffetarget_convert_integer2_complex3
  669. (ffebld_cu_ptr_integer2 (u),
  670. ffebld_constant_complex3 (ffebld_conter (l)));
  671. break;
  672. #endif
  673. #if FFETARGET_okCOMPLEX4
  674. case FFEINFO_kindtypeREAL4:
  675. error = ffetarget_convert_integer2_complex4
  676. (ffebld_cu_ptr_integer2 (u),
  677. ffebld_constant_complex4 (ffebld_conter (l)));
  678. break;
  679. #endif
  680. default:
  681. assert ("INTEGER2/COMPLEX bad source kind type" == NULL);
  682. break;
  683. }
  684. break;
  685. case FFEINFO_basictypeLOGICAL:
  686. switch (ffeinfo_kindtype (ffebld_info (l)))
  687. {
  688. #if FFETARGET_okLOGICAL1
  689. case FFEINFO_kindtypeLOGICAL1:
  690. error = ffetarget_convert_integer2_logical1
  691. (ffebld_cu_ptr_integer2 (u),
  692. ffebld_constant_logical1 (ffebld_conter (l)));
  693. break;
  694. #endif
  695. #if FFETARGET_okLOGICAL2
  696. case FFEINFO_kindtypeLOGICAL2:
  697. error = ffetarget_convert_integer2_logical2
  698. (ffebld_cu_ptr_integer2 (u),
  699. ffebld_constant_logical2 (ffebld_conter (l)));
  700. break;
  701. #endif
  702. #if FFETARGET_okLOGICAL3
  703. case FFEINFO_kindtypeLOGICAL3:
  704. error = ffetarget_convert_integer2_logical3
  705. (ffebld_cu_ptr_integer2 (u),
  706. ffebld_constant_logical3 (ffebld_conter (l)));
  707. break;
  708. #endif
  709. #if FFETARGET_okLOGICAL4
  710. case FFEINFO_kindtypeLOGICAL4:
  711. error = ffetarget_convert_integer2_logical4
  712. (ffebld_cu_ptr_integer2 (u),
  713. ffebld_constant_logical4 (ffebld_conter (l)));
  714. break;
  715. #endif
  716. default:
  717. assert ("INTEGER2/LOGICAL bad source kind type" == NULL);
  718. break;
  719. }
  720. break;
  721. case FFEINFO_basictypeCHARACTER:
  722. error = ffetarget_convert_integer2_character1
  723. (ffebld_cu_ptr_integer2 (u),
  724. ffebld_constant_character1 (ffebld_conter (l)));
  725. break;
  726. case FFEINFO_basictypeHOLLERITH:
  727. error = ffetarget_convert_integer2_hollerith
  728. (ffebld_cu_ptr_integer2 (u),
  729. ffebld_constant_hollerith (ffebld_conter (l)));
  730. break;
  731. case FFEINFO_basictypeTYPELESS:
  732. error = ffetarget_convert_integer2_typeless
  733. (ffebld_cu_ptr_integer2 (u),
  734. ffebld_constant_typeless (ffebld_conter (l)));
  735. break;
  736. default:
  737. assert ("INTEGER2 bad type" == NULL);
  738. break;
  739. }
  740. /* If conversion operation is not implemented, return original expr. */
  741. if (error == FFEBAD_NOCANDO)
  742. return expr;
  743. expr = ffebld_new_conter_with_orig
  744. (ffebld_constant_new_integer2_val
  745. (ffebld_cu_val_integer2 (u)), expr);
  746. break;
  747. #endif
  748. #if FFETARGET_okINTEGER3
  749. case FFEINFO_kindtypeINTEGER3:
  750. switch (ffeinfo_basictype (ffebld_info (l)))
  751. {
  752. case FFEINFO_basictypeINTEGER:
  753. switch (ffeinfo_kindtype (ffebld_info (l)))
  754. {
  755. #if FFETARGET_okINTEGER1
  756. case FFEINFO_kindtypeINTEGER1:
  757. error = ffetarget_convert_integer3_integer1
  758. (ffebld_cu_ptr_integer3 (u),
  759. ffebld_constant_integer1 (ffebld_conter (l)));
  760. break;
  761. #endif
  762. #if FFETARGET_okINTEGER2
  763. case FFEINFO_kindtypeINTEGER2:
  764. error = ffetarget_convert_integer3_integer2
  765. (ffebld_cu_ptr_integer3 (u),
  766. ffebld_constant_integer2 (ffebld_conter (l)));
  767. break;
  768. #endif
  769. #if FFETARGET_okINTEGER4
  770. case FFEINFO_kindtypeINTEGER4:
  771. error = ffetarget_convert_integer3_integer4
  772. (ffebld_cu_ptr_integer3 (u),
  773. ffebld_constant_integer4 (ffebld_conter (l)));
  774. break;
  775. #endif
  776. default:
  777. assert ("INTEGER3/INTEGER bad source kind type" == NULL);
  778. break;
  779. }
  780. break;
  781. case FFEINFO_basictypeREAL:
  782. switch (ffeinfo_kindtype (ffebld_info (l)))
  783. {
  784. #if FFETARGET_okREAL1
  785. case FFEINFO_kindtypeREAL1:
  786. error = ffetarget_convert_integer3_real1
  787. (ffebld_cu_ptr_integer3 (u),
  788. ffebld_constant_real1 (ffebld_conter (l)));
  789. break;
  790. #endif
  791. #if FFETARGET_okREAL2
  792. case FFEINFO_kindtypeREAL2:
  793. error = ffetarget_convert_integer3_real2
  794. (ffebld_cu_ptr_integer3 (u),
  795. ffebld_constant_real2 (ffebld_conter (l)));
  796. break;
  797. #endif
  798. #if FFETARGET_okREAL3
  799. case FFEINFO_kindtypeREAL3:
  800. error = ffetarget_convert_integer3_real3
  801. (ffebld_cu_ptr_integer3 (u),
  802. ffebld_constant_real3 (ffebld_conter (l)));
  803. break;
  804. #endif
  805. #if FFETARGET_okREAL4
  806. case FFEINFO_kindtypeREAL4:
  807. error = ffetarget_convert_integer3_real4
  808. (ffebld_cu_ptr_integer3 (u),
  809. ffebld_constant_real4 (ffebld_conter (l)));
  810. break;
  811. #endif
  812. default:
  813. assert ("INTEGER3/REAL bad source kind type" == NULL);
  814. break;
  815. }
  816. break;
  817. case FFEINFO_basictypeCOMPLEX:
  818. switch (ffeinfo_kindtype (ffebld_info (l)))
  819. {
  820. #if FFETARGET_okCOMPLEX1
  821. case FFEINFO_kindtypeREAL1:
  822. error = ffetarget_convert_integer3_complex1
  823. (ffebld_cu_ptr_integer3 (u),
  824. ffebld_constant_complex1 (ffebld_conter (l)));
  825. break;
  826. #endif
  827. #if FFETARGET_okCOMPLEX2
  828. case FFEINFO_kindtypeREAL2:
  829. error = ffetarget_convert_integer3_complex2
  830. (ffebld_cu_ptr_integer3 (u),
  831. ffebld_constant_complex2 (ffebld_conter (l)));
  832. break;
  833. #endif
  834. #if FFETARGET_okCOMPLEX3
  835. case FFEINFO_kindtypeREAL3:
  836. error = ffetarget_convert_integer3_complex3
  837. (ffebld_cu_ptr_integer3 (u),
  838. ffebld_constant_complex3 (ffebld_conter (l)));
  839. break;
  840. #endif
  841. #if FFETARGET_okCOMPLEX4
  842. case FFEINFO_kindtypeREAL4:
  843. error = ffetarget_convert_integer3_complex4
  844. (ffebld_cu_ptr_integer3 (u),
  845. ffebld_constant_complex4 (ffebld_conter (l)));
  846. break;
  847. #endif
  848. default:
  849. assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
  850. break;
  851. }
  852. break;
  853. case FFEINFO_basictypeLOGICAL:
  854. switch (ffeinfo_kindtype (ffebld_info (l)))
  855. {
  856. #if FFETARGET_okLOGICAL1
  857. case FFEINFO_kindtypeLOGICAL1:
  858. error = ffetarget_convert_integer3_logical1
  859. (ffebld_cu_ptr_integer3 (u),
  860. ffebld_constant_logical1 (ffebld_conter (l)));
  861. break;
  862. #endif
  863. #if FFETARGET_okLOGICAL2
  864. case FFEINFO_kindtypeLOGICAL2:
  865. error = ffetarget_convert_integer3_logical2
  866. (ffebld_cu_ptr_integer3 (u),
  867. ffebld_constant_logical2 (ffebld_conter (l)));
  868. break;
  869. #endif
  870. #if FFETARGET_okLOGICAL3
  871. case FFEINFO_kindtypeLOGICAL3:
  872. error = ffetarget_convert_integer3_logical3
  873. (ffebld_cu_ptr_integer3 (u),
  874. ffebld_constant_logical3 (ffebld_conter (l)));
  875. break;
  876. #endif
  877. #if FFETARGET_okLOGICAL4
  878. case FFEINFO_kindtypeLOGICAL4:
  879. error = ffetarget_convert_integer3_logical4
  880. (ffebld_cu_ptr_integer3 (u),
  881. ffebld_constant_logical4 (ffebld_conter (l)));
  882. break;
  883. #endif
  884. default:
  885. assert ("INTEGER3/LOGICAL bad source kind type" == NULL);
  886. break;
  887. }
  888. break;
  889. case FFEINFO_basictypeCHARACTER:
  890. error = ffetarget_convert_integer3_character1
  891. (ffebld_cu_ptr_integer3 (u),
  892. ffebld_constant_character1 (ffebld_conter (l)));
  893. break;
  894. case FFEINFO_basictypeHOLLERITH:
  895. error = ffetarget_convert_integer3_hollerith
  896. (ffebld_cu_ptr_integer3 (u),
  897. ffebld_constant_hollerith (ffebld_conter (l)));
  898. break;
  899. case FFEINFO_basictypeTYPELESS:
  900. error = ffetarget_convert_integer3_typeless
  901. (ffebld_cu_ptr_integer3 (u),
  902. ffebld_constant_typeless (ffebld_conter (l)));
  903. break;
  904. default:
  905. assert ("INTEGER3 bad type" == NULL);
  906. break;
  907. }
  908. /* If conversion operation is not implemented, return original expr. */
  909. if (error == FFEBAD_NOCANDO)
  910. return expr;
  911. expr = ffebld_new_conter_with_orig
  912. (ffebld_constant_new_integer3_val
  913. (ffebld_cu_val_integer3 (u)), expr);
  914. break;
  915. #endif
  916. #if FFETARGET_okINTEGER4
  917. case FFEINFO_kindtypeINTEGER4:
  918. switch (ffeinfo_basictype (ffebld_info (l)))
  919. {
  920. case FFEINFO_basictypeINTEGER:
  921. switch (ffeinfo_kindtype (ffebld_info (l)))
  922. {
  923. #if FFETARGET_okINTEGER1
  924. case FFEINFO_kindtypeINTEGER1:
  925. error = ffetarget_convert_integer4_integer1
  926. (ffebld_cu_ptr_integer4 (u),
  927. ffebld_constant_integer1 (ffebld_conter (l)));
  928. break;
  929. #endif
  930. #if FFETARGET_okINTEGER2
  931. case FFEINFO_kindtypeINTEGER2:
  932. error = ffetarget_convert_integer4_integer2
  933. (ffebld_cu_ptr_integer4 (u),
  934. ffebld_constant_integer2 (ffebld_conter (l)));
  935. break;
  936. #endif
  937. #if FFETARGET_okINTEGER3
  938. case FFEINFO_kindtypeINTEGER3:
  939. error = ffetarget_convert_integer4_integer3
  940. (ffebld_cu_ptr_integer4 (u),
  941. ffebld_constant_integer3 (ffebld_conter (l)));
  942. break;
  943. #endif
  944. default:
  945. assert ("INTEGER4/INTEGER bad source kind type" == NULL);
  946. break;
  947. }
  948. break;
  949. case FFEINFO_basictypeREAL:
  950. switch (ffeinfo_kindtype (ffebld_info (l)))
  951. {
  952. #if FFETARGET_okREAL1
  953. case FFEINFO_kindtypeREAL1:
  954. error = ffetarget_convert_integer4_real1
  955. (ffebld_cu_ptr_integer4 (u),
  956. ffebld_constant_real1 (ffebld_conter (l)));
  957. break;
  958. #endif
  959. #if FFETARGET_okREAL2
  960. case FFEINFO_kindtypeREAL2:
  961. error = ffetarget_convert_integer4_real2
  962. (ffebld_cu_ptr_integer4 (u),
  963. ffebld_constant_real2 (ffebld_conter (l)));
  964. break;
  965. #endif
  966. #if FFETARGET_okREAL3
  967. case FFEINFO_kindtypeREAL3:
  968. error = ffetarget_convert_integer4_real3
  969. (ffebld_cu_ptr_integer4 (u),
  970. ffebld_constant_real3 (ffebld_conter (l)));
  971. break;
  972. #endif
  973. #if FFETARGET_okREAL4
  974. case FFEINFO_kindtypeREAL4:
  975. error = ffetarget_convert_integer4_real4
  976. (ffebld_cu_ptr_integer4 (u),
  977. ffebld_constant_real4 (ffebld_conter (l)));
  978. break;
  979. #endif
  980. default:
  981. assert ("INTEGER4/REAL bad source kind type" == NULL);
  982. break;
  983. }
  984. break;
  985. case FFEINFO_basictypeCOMPLEX:
  986. switch (ffeinfo_kindtype (ffebld_info (l)))
  987. {
  988. #if FFETARGET_okCOMPLEX1
  989. case FFEINFO_kindtypeREAL1:
  990. error = ffetarget_convert_integer4_complex1
  991. (ffebld_cu_ptr_integer4 (u),
  992. ffebld_constant_complex1 (ffebld_conter (l)));
  993. break;
  994. #endif
  995. #if FFETARGET_okCOMPLEX2
  996. case FFEINFO_kindtypeREAL2:
  997. error = ffetarget_convert_integer4_complex2
  998. (ffebld_cu_ptr_integer4 (u),
  999. ffebld_constant_complex2 (ffebld_conter (l)));
  1000. break;
  1001. #endif
  1002. #if FFETARGET_okCOMPLEX3
  1003. case FFEINFO_kindtypeREAL3:
  1004. error = ffetarget_convert_integer4_complex3
  1005. (ffebld_cu_ptr_integer4 (u),
  1006. ffebld_constant_complex3 (ffebld_conter (l)));
  1007. break;
  1008. #endif
  1009. #if FFETARGET_okCOMPLEX4
  1010. case FFEINFO_kindtypeREAL4:
  1011. error = ffetarget_convert_integer4_complex4
  1012. (ffebld_cu_ptr_integer4 (u),
  1013. ffebld_constant_complex4 (ffebld_conter (l)));
  1014. break;
  1015. #endif
  1016. default:
  1017. assert ("INTEGER3/COMPLEX bad source kind type" == NULL);
  1018. break;
  1019. }
  1020. break;
  1021. case FFEINFO_basictypeLOGICAL:
  1022. switch (ffeinfo_kindtype (ffebld_info (l)))
  1023. {
  1024. #if FFETARGET_okLOGICAL1
  1025. case FFEINFO_kindtypeLOGICAL1:
  1026. error = ffetarget_convert_integer4_logical1
  1027. (ffebld_cu_ptr_integer4 (u),
  1028. ffebld_constant_logical1 (ffebld_conter (l)));
  1029. break;
  1030. #endif
  1031. #if FFETARGET_okLOGICAL2
  1032. case FFEINFO_kindtypeLOGICAL2:
  1033. error = ffetarget_convert_integer4_logical2
  1034. (ffebld_cu_ptr_integer4 (u),
  1035. ffebld_constant_logical2 (ffebld_conter (l)));
  1036. break;
  1037. #endif
  1038. #if FFETARGET_okLOGICAL3
  1039. case FFEINFO_kindtypeLOGICAL3:
  1040. error = ffetarget_convert_integer4_logical3
  1041. (ffebld_cu_ptr_integer4 (u),
  1042. ffebld_constant_logical3 (ffebld_conter (l)));
  1043. break;
  1044. #endif
  1045. #if FFETARGET_okLOGICAL4
  1046. case FFEINFO_kindtypeLOGICAL4:
  1047. error = ffetarget_convert_integer4_logical4
  1048. (ffebld_cu_ptr_integer4 (u),
  1049. ffebld_constant_logical4 (ffebld_conter (l)));
  1050. break;
  1051. #endif
  1052. default:
  1053. assert ("INTEGER4/LOGICAL bad source kind type" == NULL);
  1054. break;
  1055. }
  1056. break;
  1057. case FFEINFO_basictypeCHARACTER:
  1058. error = ffetarget_convert_integer4_character1
  1059. (ffebld_cu_ptr_integer4 (u),
  1060. ffebld_constant_character1 (ffebld_conter (l)));
  1061. break;
  1062. case FFEINFO_basictypeHOLLERITH:
  1063. error = ffetarget_convert_integer4_hollerith
  1064. (ffebld_cu_ptr_integer4 (u),
  1065. ffebld_constant_hollerith (ffebld_conter (l)));
  1066. break;
  1067. case FFEINFO_basictypeTYPELESS:
  1068. error = ffetarget_convert_integer4_typeless
  1069. (ffebld_cu_ptr_integer4 (u),
  1070. ffebld_constant_typeless (ffebld_conter (l)));
  1071. break;
  1072. default:
  1073. assert ("INTEGER4 bad type" == NULL);
  1074. break;
  1075. }
  1076. /* If conversion operation is not implemented, return original expr. */
  1077. if (error == FFEBAD_NOCANDO)
  1078. return expr;
  1079. expr = ffebld_new_conter_with_orig
  1080. (ffebld_constant_new_integer4_val
  1081. (ffebld_cu_val_integer4 (u)), expr);
  1082. break;
  1083. #endif
  1084. default:
  1085. assert ("bad integer kind type" == NULL);
  1086. break;
  1087. }
  1088. break;
  1089. case FFEINFO_basictypeLOGICAL:
  1090. sz = FFETARGET_charactersizeNONE;
  1091. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  1092. {
  1093. #if FFETARGET_okLOGICAL1
  1094. case FFEINFO_kindtypeLOGICAL1:
  1095. switch (ffeinfo_basictype (ffebld_info (l)))
  1096. {
  1097. case FFEINFO_basictypeLOGICAL:
  1098. switch (ffeinfo_kindtype (ffebld_info (l)))
  1099. {
  1100. #if FFETARGET_okLOGICAL2
  1101. case FFEINFO_kindtypeLOGICAL2:
  1102. error = ffetarget_convert_logical1_logical2
  1103. (ffebld_cu_ptr_logical1 (u),
  1104. ffebld_constant_logical2 (ffebld_conter (l)));
  1105. break;
  1106. #endif
  1107. #if FFETARGET_okLOGICAL3
  1108. case FFEINFO_kindtypeLOGICAL3:
  1109. error = ffetarget_convert_logical1_logical3
  1110. (ffebld_cu_ptr_logical1 (u),
  1111. ffebld_constant_logical3 (ffebld_conter (l)));
  1112. break;
  1113. #endif
  1114. #if FFETARGET_okLOGICAL4
  1115. case FFEINFO_kindtypeLOGICAL4:
  1116. error = ffetarget_convert_logical1_logical4
  1117. (ffebld_cu_ptr_logical1 (u),
  1118. ffebld_constant_logical4 (ffebld_conter (l)));
  1119. break;
  1120. #endif
  1121. default:
  1122. assert ("LOGICAL1/LOGICAL bad source kind type" == NULL);
  1123. break;
  1124. }
  1125. break;
  1126. case FFEINFO_basictypeINTEGER:
  1127. switch (ffeinfo_kindtype (ffebld_info (l)))
  1128. {
  1129. #if FFETARGET_okINTEGER1
  1130. case FFEINFO_kindtypeINTEGER1:
  1131. error = ffetarget_convert_logical1_integer1
  1132. (ffebld_cu_ptr_logical1 (u),
  1133. ffebld_constant_integer1 (ffebld_conter (l)));
  1134. break;
  1135. #endif
  1136. #if FFETARGET_okINTEGER2
  1137. case FFEINFO_kindtypeINTEGER2:
  1138. error = ffetarget_convert_logical1_integer2
  1139. (ffebld_cu_ptr_logical1 (u),
  1140. ffebld_constant_integer2 (ffebld_conter (l)));
  1141. break;
  1142. #endif
  1143. #if FFETARGET_okINTEGER3
  1144. case FFEINFO_kindtypeINTEGER3:
  1145. error = ffetarget_convert_logical1_integer3
  1146. (ffebld_cu_ptr_logical1 (u),
  1147. ffebld_constant_integer3 (ffebld_conter (l)));
  1148. break;
  1149. #endif
  1150. #if FFETARGET_okINTEGER4
  1151. case FFEINFO_kindtypeINTEGER4:
  1152. error = ffetarget_convert_logical1_integer4
  1153. (ffebld_cu_ptr_logical1 (u),
  1154. ffebld_constant_integer4 (ffebld_conter (l)));
  1155. break;
  1156. #endif
  1157. default:
  1158. assert ("LOGICAL1/INTEGER bad source kind type" == NULL);
  1159. break;
  1160. }
  1161. break;
  1162. case FFEINFO_basictypeCHARACTER:
  1163. error = ffetarget_convert_logical1_character1
  1164. (ffebld_cu_ptr_logical1 (u),
  1165. ffebld_constant_character1 (ffebld_conter (l)));
  1166. break;
  1167. case FFEINFO_basictypeHOLLERITH:
  1168. error = ffetarget_convert_logical1_hollerith
  1169. (ffebld_cu_ptr_logical1 (u),
  1170. ffebld_constant_hollerith (ffebld_conter (l)));
  1171. break;
  1172. case FFEINFO_basictypeTYPELESS:
  1173. error = ffetarget_convert_logical1_typeless
  1174. (ffebld_cu_ptr_logical1 (u),
  1175. ffebld_constant_typeless (ffebld_conter (l)));
  1176. break;
  1177. default:
  1178. assert ("LOGICAL1 bad type" == NULL);
  1179. break;
  1180. }
  1181. /* If conversion operation is not implemented, return original expr. */
  1182. if (error == FFEBAD_NOCANDO)
  1183. return expr;
  1184. expr = ffebld_new_conter_with_orig
  1185. (ffebld_constant_new_logical1_val
  1186. (ffebld_cu_val_logical1 (u)), expr);
  1187. break;
  1188. #endif
  1189. #if FFETARGET_okLOGICAL2
  1190. case FFEINFO_kindtypeLOGICAL2:
  1191. switch (ffeinfo_basictype (ffebld_info (l)))
  1192. {
  1193. case FFEINFO_basictypeLOGICAL:
  1194. switch (ffeinfo_kindtype (ffebld_info (l)))
  1195. {
  1196. #if FFETARGET_okLOGICAL1
  1197. case FFEINFO_kindtypeLOGICAL1:
  1198. error = ffetarget_convert_logical2_logical1
  1199. (ffebld_cu_ptr_logical2 (u),
  1200. ffebld_constant_logical1 (ffebld_conter (l)));
  1201. break;
  1202. #endif
  1203. #if FFETARGET_okLOGICAL3
  1204. case FFEINFO_kindtypeLOGICAL3:
  1205. error = ffetarget_convert_logical2_logical3
  1206. (ffebld_cu_ptr_logical2 (u),
  1207. ffebld_constant_logical3 (ffebld_conter (l)));
  1208. break;
  1209. #endif
  1210. #if FFETARGET_okLOGICAL4
  1211. case FFEINFO_kindtypeLOGICAL4:
  1212. error = ffetarget_convert_logical2_logical4
  1213. (ffebld_cu_ptr_logical2 (u),
  1214. ffebld_constant_logical4 (ffebld_conter (l)));
  1215. break;
  1216. #endif
  1217. default:
  1218. assert ("LOGICAL2/LOGICAL bad source kind type" == NULL);
  1219. break;
  1220. }
  1221. break;
  1222. case FFEINFO_basictypeINTEGER:
  1223. switch (ffeinfo_kindtype (ffebld_info (l)))
  1224. {
  1225. #if FFETARGET_okINTEGER1
  1226. case FFEINFO_kindtypeINTEGER1:
  1227. error = ffetarget_convert_logical2_integer1
  1228. (ffebld_cu_ptr_logical2 (u),
  1229. ffebld_constant_integer1 (ffebld_conter (l)));
  1230. break;
  1231. #endif
  1232. #if FFETARGET_okINTEGER2
  1233. case FFEINFO_kindtypeINTEGER2:
  1234. error = ffetarget_convert_logical2_integer2
  1235. (ffebld_cu_ptr_logical2 (u),
  1236. ffebld_constant_integer2 (ffebld_conter (l)));
  1237. break;
  1238. #endif
  1239. #if FFETARGET_okINTEGER3
  1240. case FFEINFO_kindtypeINTEGER3:
  1241. error = ffetarget_convert_logical2_integer3
  1242. (ffebld_cu_ptr_logical2 (u),
  1243. ffebld_constant_integer3 (ffebld_conter (l)));
  1244. break;
  1245. #endif
  1246. #if FFETARGET_okINTEGER4
  1247. case FFEINFO_kindtypeINTEGER4:
  1248. error = ffetarget_convert_logical2_integer4
  1249. (ffebld_cu_ptr_logical2 (u),
  1250. ffebld_constant_integer4 (ffebld_conter (l)));
  1251. break;
  1252. #endif
  1253. default:
  1254. assert ("LOGICAL2/INTEGER bad source kind type" == NULL);
  1255. break;
  1256. }
  1257. break;
  1258. case FFEINFO_basictypeCHARACTER:
  1259. error = ffetarget_convert_logical2_character1
  1260. (ffebld_cu_ptr_logical2 (u),
  1261. ffebld_constant_character1 (ffebld_conter (l)));
  1262. break;
  1263. case FFEINFO_basictypeHOLLERITH:
  1264. error = ffetarget_convert_logical2_hollerith
  1265. (ffebld_cu_ptr_logical2 (u),
  1266. ffebld_constant_hollerith (ffebld_conter (l)));
  1267. break;
  1268. case FFEINFO_basictypeTYPELESS:
  1269. error = ffetarget_convert_logical2_typeless
  1270. (ffebld_cu_ptr_logical2 (u),
  1271. ffebld_constant_typeless (ffebld_conter (l)));
  1272. break;
  1273. default:
  1274. assert ("LOGICAL2 bad type" == NULL);
  1275. break;
  1276. }
  1277. /* If conversion operation is not implemented, return original expr. */
  1278. if (error == FFEBAD_NOCANDO)
  1279. return expr;
  1280. expr = ffebld_new_conter_with_orig
  1281. (ffebld_constant_new_logical2_val
  1282. (ffebld_cu_val_logical2 (u)), expr);
  1283. break;
  1284. #endif
  1285. #if FFETARGET_okLOGICAL3
  1286. case FFEINFO_kindtypeLOGICAL3:
  1287. switch (ffeinfo_basictype (ffebld_info (l)))
  1288. {
  1289. case FFEINFO_basictypeLOGICAL:
  1290. switch (ffeinfo_kindtype (ffebld_info (l)))
  1291. {
  1292. #if FFETARGET_okLOGICAL1
  1293. case FFEINFO_kindtypeLOGICAL1:
  1294. error = ffetarget_convert_logical3_logical1
  1295. (ffebld_cu_ptr_logical3 (u),
  1296. ffebld_constant_logical1 (ffebld_conter (l)));
  1297. break;
  1298. #endif
  1299. #if FFETARGET_okLOGICAL2
  1300. case FFEINFO_kindtypeLOGICAL2:
  1301. error = ffetarget_convert_logical3_logical2
  1302. (ffebld_cu_ptr_logical3 (u),
  1303. ffebld_constant_logical2 (ffebld_conter (l)));
  1304. break;
  1305. #endif
  1306. #if FFETARGET_okLOGICAL4
  1307. case FFEINFO_kindtypeLOGICAL4:
  1308. error = ffetarget_convert_logical3_logical4
  1309. (ffebld_cu_ptr_logical3 (u),
  1310. ffebld_constant_logical4 (ffebld_conter (l)));
  1311. break;
  1312. #endif
  1313. default:
  1314. assert ("LOGICAL3/LOGICAL bad source kind type" == NULL);
  1315. break;
  1316. }
  1317. break;
  1318. case FFEINFO_basictypeINTEGER:
  1319. switch (ffeinfo_kindtype (ffebld_info (l)))
  1320. {
  1321. #if FFETARGET_okINTEGER1
  1322. case FFEINFO_kindtypeINTEGER1:
  1323. error = ffetarget_convert_logical3_integer1
  1324. (ffebld_cu_ptr_logical3 (u),
  1325. ffebld_constant_integer1 (ffebld_conter (l)));
  1326. break;
  1327. #endif
  1328. #if FFETARGET_okINTEGER2
  1329. case FFEINFO_kindtypeINTEGER2:
  1330. error = ffetarget_convert_logical3_integer2
  1331. (ffebld_cu_ptr_logical3 (u),
  1332. ffebld_constant_integer2 (ffebld_conter (l)));
  1333. break;
  1334. #endif
  1335. #if FFETARGET_okINTEGER3
  1336. case FFEINFO_kindtypeINTEGER3:
  1337. error = ffetarget_convert_logical3_integer3
  1338. (ffebld_cu_ptr_logical3 (u),
  1339. ffebld_constant_integer3 (ffebld_conter (l)));
  1340. break;
  1341. #endif
  1342. #if FFETARGET_okINTEGER4
  1343. case FFEINFO_kindtypeINTEGER4:
  1344. error = ffetarget_convert_logical3_integer4
  1345. (ffebld_cu_ptr_logical3 (u),
  1346. ffebld_constant_integer4 (ffebld_conter (l)));
  1347. break;
  1348. #endif
  1349. default:
  1350. assert ("LOGICAL3/INTEGER bad source kind type" == NULL);
  1351. break;
  1352. }
  1353. break;
  1354. case FFEINFO_basictypeCHARACTER:
  1355. error = ffetarget_convert_logical3_character1
  1356. (ffebld_cu_ptr_logical3 (u),
  1357. ffebld_constant_character1 (ffebld_conter (l)));
  1358. break;
  1359. case FFEINFO_basictypeHOLLERITH:
  1360. error = ffetarget_convert_logical3_hollerith
  1361. (ffebld_cu_ptr_logical3 (u),
  1362. ffebld_constant_hollerith (ffebld_conter (l)));
  1363. break;
  1364. case FFEINFO_basictypeTYPELESS:
  1365. error = ffetarget_convert_logical3_typeless
  1366. (ffebld_cu_ptr_logical3 (u),
  1367. ffebld_constant_typeless (ffebld_conter (l)));
  1368. break;
  1369. default:
  1370. assert ("LOGICAL3 bad type" == NULL);
  1371. break;
  1372. }
  1373. /* If conversion operation is not implemented, return original expr. */
  1374. if (error == FFEBAD_NOCANDO)
  1375. return expr;
  1376. expr = ffebld_new_conter_with_orig
  1377. (ffebld_constant_new_logical3_val
  1378. (ffebld_cu_val_logical3 (u)), expr);
  1379. break;
  1380. #endif
  1381. #if FFETARGET_okLOGICAL4
  1382. case FFEINFO_kindtypeLOGICAL4:
  1383. switch (ffeinfo_basictype (ffebld_info (l)))
  1384. {
  1385. case FFEINFO_basictypeLOGICAL:
  1386. switch (ffeinfo_kindtype (ffebld_info (l)))
  1387. {
  1388. #if FFETARGET_okLOGICAL1
  1389. case FFEINFO_kindtypeLOGICAL1:
  1390. error = ffetarget_convert_logical4_logical1
  1391. (ffebld_cu_ptr_logical4 (u),
  1392. ffebld_constant_logical1 (ffebld_conter (l)));
  1393. break;
  1394. #endif
  1395. #if FFETARGET_okLOGICAL2
  1396. case FFEINFO_kindtypeLOGICAL2:
  1397. error = ffetarget_convert_logical4_logical2
  1398. (ffebld_cu_ptr_logical4 (u),
  1399. ffebld_constant_logical2 (ffebld_conter (l)));
  1400. break;
  1401. #endif
  1402. #if FFETARGET_okLOGICAL3
  1403. case FFEINFO_kindtypeLOGICAL3:
  1404. error = ffetarget_convert_logical4_logical3
  1405. (ffebld_cu_ptr_logical4 (u),
  1406. ffebld_constant_logical3 (ffebld_conter (l)));
  1407. break;
  1408. #endif
  1409. default:
  1410. assert ("LOGICAL4/LOGICAL bad source kind type" == NULL);
  1411. break;
  1412. }
  1413. break;
  1414. case FFEINFO_basictypeINTEGER:
  1415. switch (ffeinfo_kindtype (ffebld_info (l)))
  1416. {
  1417. #if FFETARGET_okINTEGER1
  1418. case FFEINFO_kindtypeINTEGER1:
  1419. error = ffetarget_convert_logical4_integer1
  1420. (ffebld_cu_ptr_logical4 (u),
  1421. ffebld_constant_integer1 (ffebld_conter (l)));
  1422. break;
  1423. #endif
  1424. #if FFETARGET_okINTEGER2
  1425. case FFEINFO_kindtypeINTEGER2:
  1426. error = ffetarget_convert_logical4_integer2
  1427. (ffebld_cu_ptr_logical4 (u),
  1428. ffebld_constant_integer2 (ffebld_conter (l)));
  1429. break;
  1430. #endif
  1431. #if FFETARGET_okINTEGER3
  1432. case FFEINFO_kindtypeINTEGER3:
  1433. error = ffetarget_convert_logical4_integer3
  1434. (ffebld_cu_ptr_logical4 (u),
  1435. ffebld_constant_integer3 (ffebld_conter (l)));
  1436. break;
  1437. #endif
  1438. #if FFETARGET_okINTEGER4
  1439. case FFEINFO_kindtypeINTEGER4:
  1440. error = ffetarget_convert_logical4_integer4
  1441. (ffebld_cu_ptr_logical4 (u),
  1442. ffebld_constant_integer4 (ffebld_conter (l)));
  1443. break;
  1444. #endif
  1445. default:
  1446. assert ("LOGICAL4/INTEGER bad source kind type" == NULL);
  1447. break;
  1448. }
  1449. break;
  1450. case FFEINFO_basictypeCHARACTER:
  1451. error = ffetarget_convert_logical4_character1
  1452. (ffebld_cu_ptr_logical4 (u),
  1453. ffebld_constant_character1 (ffebld_conter (l)));
  1454. break;
  1455. case FFEINFO_basictypeHOLLERITH:
  1456. error = ffetarget_convert_logical4_hollerith
  1457. (ffebld_cu_ptr_logical4 (u),
  1458. ffebld_constant_hollerith (ffebld_conter (l)));
  1459. break;
  1460. case FFEINFO_basictypeTYPELESS:
  1461. error = ffetarget_convert_logical4_typeless
  1462. (ffebld_cu_ptr_logical4 (u),
  1463. ffebld_constant_typeless (ffebld_conter (l)));
  1464. break;
  1465. default:
  1466. assert ("LOGICAL4 bad type" == NULL);
  1467. break;
  1468. }
  1469. /* If conversion operation is not implemented, return original expr. */
  1470. if (error == FFEBAD_NOCANDO)
  1471. return expr;
  1472. expr = ffebld_new_conter_with_orig
  1473. (ffebld_constant_new_logical4_val
  1474. (ffebld_cu_val_logical4 (u)), expr);
  1475. break;
  1476. #endif
  1477. default:
  1478. assert ("bad logical kind type" == NULL);
  1479. break;
  1480. }
  1481. break;
  1482. case FFEINFO_basictypeREAL:
  1483. sz = FFETARGET_charactersizeNONE;
  1484. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  1485. {
  1486. #if FFETARGET_okREAL1
  1487. case FFEINFO_kindtypeREAL1:
  1488. switch (ffeinfo_basictype (ffebld_info (l)))
  1489. {
  1490. case FFEINFO_basictypeINTEGER:
  1491. switch (ffeinfo_kindtype (ffebld_info (l)))
  1492. {
  1493. #if FFETARGET_okINTEGER1
  1494. case FFEINFO_kindtypeINTEGER1:
  1495. error = ffetarget_convert_real1_integer1
  1496. (ffebld_cu_ptr_real1 (u),
  1497. ffebld_constant_integer1 (ffebld_conter (l)));
  1498. break;
  1499. #endif
  1500. #if FFETARGET_okINTEGER2
  1501. case FFEINFO_kindtypeINTEGER2:
  1502. error = ffetarget_convert_real1_integer2
  1503. (ffebld_cu_ptr_real1 (u),
  1504. ffebld_constant_integer2 (ffebld_conter (l)));
  1505. break;
  1506. #endif
  1507. #if FFETARGET_okINTEGER3
  1508. case FFEINFO_kindtypeINTEGER3:
  1509. error = ffetarget_convert_real1_integer3
  1510. (ffebld_cu_ptr_real1 (u),
  1511. ffebld_constant_integer3 (ffebld_conter (l)));
  1512. break;
  1513. #endif
  1514. #if FFETARGET_okINTEGER4
  1515. case FFEINFO_kindtypeINTEGER4:
  1516. error = ffetarget_convert_real1_integer4
  1517. (ffebld_cu_ptr_real1 (u),
  1518. ffebld_constant_integer4 (ffebld_conter (l)));
  1519. break;
  1520. #endif
  1521. default:
  1522. assert ("REAL1/INTEGER bad source kind type" == NULL);
  1523. break;
  1524. }
  1525. break;
  1526. case FFEINFO_basictypeREAL:
  1527. switch (ffeinfo_kindtype (ffebld_info (l)))
  1528. {
  1529. #if FFETARGET_okREAL2
  1530. case FFEINFO_kindtypeREAL2:
  1531. error = ffetarget_convert_real1_real2
  1532. (ffebld_cu_ptr_real1 (u),
  1533. ffebld_constant_real2 (ffebld_conter (l)));
  1534. break;
  1535. #endif
  1536. #if FFETARGET_okREAL3
  1537. case FFEINFO_kindtypeREAL3:
  1538. error = ffetarget_convert_real1_real3
  1539. (ffebld_cu_ptr_real1 (u),
  1540. ffebld_constant_real3 (ffebld_conter (l)));
  1541. break;
  1542. #endif
  1543. #if FFETARGET_okREAL4
  1544. case FFEINFO_kindtypeREAL4:
  1545. error = ffetarget_convert_real1_real4
  1546. (ffebld_cu_ptr_real1 (u),
  1547. ffebld_constant_real4 (ffebld_conter (l)));
  1548. break;
  1549. #endif
  1550. default:
  1551. assert ("REAL1/REAL bad source kind type" == NULL);
  1552. break;
  1553. }
  1554. break;
  1555. case FFEINFO_basictypeCOMPLEX:
  1556. switch (ffeinfo_kindtype (ffebld_info (l)))
  1557. {
  1558. #if FFETARGET_okCOMPLEX1
  1559. case FFEINFO_kindtypeREAL1:
  1560. error = ffetarget_convert_real1_complex1
  1561. (ffebld_cu_ptr_real1 (u),
  1562. ffebld_constant_complex1 (ffebld_conter (l)));
  1563. break;
  1564. #endif
  1565. #if FFETARGET_okCOMPLEX2
  1566. case FFEINFO_kindtypeREAL2:
  1567. error = ffetarget_convert_real1_complex2
  1568. (ffebld_cu_ptr_real1 (u),
  1569. ffebld_constant_complex2 (ffebld_conter (l)));
  1570. break;
  1571. #endif
  1572. #if FFETARGET_okCOMPLEX3
  1573. case FFEINFO_kindtypeREAL3:
  1574. error = ffetarget_convert_real1_complex3
  1575. (ffebld_cu_ptr_real1 (u),
  1576. ffebld_constant_complex3 (ffebld_conter (l)));
  1577. break;
  1578. #endif
  1579. #if FFETARGET_okCOMPLEX4
  1580. case FFEINFO_kindtypeREAL4:
  1581. error = ffetarget_convert_real1_complex4
  1582. (ffebld_cu_ptr_real1 (u),
  1583. ffebld_constant_complex4 (ffebld_conter (l)));
  1584. break;
  1585. #endif
  1586. default:
  1587. assert ("REAL1/COMPLEX bad source kind type" == NULL);
  1588. break;
  1589. }
  1590. break;
  1591. case FFEINFO_basictypeCHARACTER:
  1592. error = ffetarget_convert_real1_character1
  1593. (ffebld_cu_ptr_real1 (u),
  1594. ffebld_constant_character1 (ffebld_conter (l)));
  1595. break;
  1596. case FFEINFO_basictypeHOLLERITH:
  1597. error = ffetarget_convert_real1_hollerith
  1598. (ffebld_cu_ptr_real1 (u),
  1599. ffebld_constant_hollerith (ffebld_conter (l)));
  1600. break;
  1601. case FFEINFO_basictypeTYPELESS:
  1602. error = ffetarget_convert_real1_typeless
  1603. (ffebld_cu_ptr_real1 (u),
  1604. ffebld_constant_typeless (ffebld_conter (l)));
  1605. break;
  1606. default:
  1607. assert ("REAL1 bad type" == NULL);
  1608. break;
  1609. }
  1610. /* If conversion operation is not implemented, return original expr. */
  1611. if (error == FFEBAD_NOCANDO)
  1612. return expr;
  1613. expr = ffebld_new_conter_with_orig
  1614. (ffebld_constant_new_real1_val
  1615. (ffebld_cu_val_real1 (u)), expr);
  1616. break;
  1617. #endif
  1618. #if FFETARGET_okREAL2
  1619. case FFEINFO_kindtypeREAL2:
  1620. switch (ffeinfo_basictype (ffebld_info (l)))
  1621. {
  1622. case FFEINFO_basictypeINTEGER:
  1623. switch (ffeinfo_kindtype (ffebld_info (l)))
  1624. {
  1625. #if FFETARGET_okINTEGER1
  1626. case FFEINFO_kindtypeINTEGER1:
  1627. error = ffetarget_convert_real2_integer1
  1628. (ffebld_cu_ptr_real2 (u),
  1629. ffebld_constant_integer1 (ffebld_conter (l)));
  1630. break;
  1631. #endif
  1632. #if FFETARGET_okINTEGER2
  1633. case FFEINFO_kindtypeINTEGER2:
  1634. error = ffetarget_convert_real2_integer2
  1635. (ffebld_cu_ptr_real2 (u),
  1636. ffebld_constant_integer2 (ffebld_conter (l)));
  1637. break;
  1638. #endif
  1639. #if FFETARGET_okINTEGER3
  1640. case FFEINFO_kindtypeINTEGER3:
  1641. error = ffetarget_convert_real2_integer3
  1642. (ffebld_cu_ptr_real2 (u),
  1643. ffebld_constant_integer3 (ffebld_conter (l)));
  1644. break;
  1645. #endif
  1646. #if FFETARGET_okINTEGER4
  1647. case FFEINFO_kindtypeINTEGER4:
  1648. error = ffetarget_convert_real2_integer4
  1649. (ffebld_cu_ptr_real2 (u),
  1650. ffebld_constant_integer4 (ffebld_conter (l)));
  1651. break;
  1652. #endif
  1653. default:
  1654. assert ("REAL2/INTEGER bad source kind type" == NULL);
  1655. break;
  1656. }
  1657. break;
  1658. case FFEINFO_basictypeREAL:
  1659. switch (ffeinfo_kindtype (ffebld_info (l)))
  1660. {
  1661. #if FFETARGET_okREAL1
  1662. case FFEINFO_kindtypeREAL1:
  1663. error = ffetarget_convert_real2_real1
  1664. (ffebld_cu_ptr_real2 (u),
  1665. ffebld_constant_real1 (ffebld_conter (l)));
  1666. break;
  1667. #endif
  1668. #if FFETARGET_okREAL3
  1669. case FFEINFO_kindtypeREAL3:
  1670. error = ffetarget_convert_real2_real3
  1671. (ffebld_cu_ptr_real2 (u),
  1672. ffebld_constant_real3 (ffebld_conter (l)));
  1673. break;
  1674. #endif
  1675. #if FFETARGET_okREAL4
  1676. case FFEINFO_kindtypeREAL4:
  1677. error = ffetarget_convert_real2_real4
  1678. (ffebld_cu_ptr_real2 (u),
  1679. ffebld_constant_real4 (ffebld_conter (l)));
  1680. break;
  1681. #endif
  1682. default:
  1683. assert ("REAL2/REAL bad source kind type" == NULL);
  1684. break;
  1685. }
  1686. break;
  1687. case FFEINFO_basictypeCOMPLEX:
  1688. switch (ffeinfo_kindtype (ffebld_info (l)))
  1689. {
  1690. #if FFETARGET_okCOMPLEX1
  1691. case FFEINFO_kindtypeREAL1:
  1692. error = ffetarget_convert_real2_complex1
  1693. (ffebld_cu_ptr_real2 (u),
  1694. ffebld_constant_complex1 (ffebld_conter (l)));
  1695. break;
  1696. #endif
  1697. #if FFETARGET_okCOMPLEX2
  1698. case FFEINFO_kindtypeREAL2:
  1699. error = ffetarget_convert_real2_complex2
  1700. (ffebld_cu_ptr_real2 (u),
  1701. ffebld_constant_complex2 (ffebld_conter (l)));
  1702. break;
  1703. #endif
  1704. #if FFETARGET_okCOMPLEX3
  1705. case FFEINFO_kindtypeREAL3:
  1706. error = ffetarget_convert_real2_complex3
  1707. (ffebld_cu_ptr_real2 (u),
  1708. ffebld_constant_complex3 (ffebld_conter (l)));
  1709. break;
  1710. #endif
  1711. #if FFETARGET_okCOMPLEX4
  1712. case FFEINFO_kindtypeREAL4:
  1713. error = ffetarget_convert_real2_complex4
  1714. (ffebld_cu_ptr_real2 (u),
  1715. ffebld_constant_complex4 (ffebld_conter (l)));
  1716. break;
  1717. #endif
  1718. default:
  1719. assert ("REAL2/COMPLEX bad source kind type" == NULL);
  1720. break;
  1721. }
  1722. break;
  1723. case FFEINFO_basictypeCHARACTER:
  1724. error = ffetarget_convert_real2_character1
  1725. (ffebld_cu_ptr_real2 (u),
  1726. ffebld_constant_character1 (ffebld_conter (l)));
  1727. break;
  1728. case FFEINFO_basictypeHOLLERITH:
  1729. error = ffetarget_convert_real2_hollerith
  1730. (ffebld_cu_ptr_real2 (u),
  1731. ffebld_constant_hollerith (ffebld_conter (l)));
  1732. break;
  1733. case FFEINFO_basictypeTYPELESS:
  1734. error = ffetarget_convert_real2_typeless
  1735. (ffebld_cu_ptr_real2 (u),
  1736. ffebld_constant_typeless (ffebld_conter (l)));
  1737. break;
  1738. default:
  1739. assert ("REAL2 bad type" == NULL);
  1740. break;
  1741. }
  1742. /* If conversion operation is not implemented, return original expr. */
  1743. if (error == FFEBAD_NOCANDO)
  1744. return expr;
  1745. expr = ffebld_new_conter_with_orig
  1746. (ffebld_constant_new_real2_val
  1747. (ffebld_cu_val_real2 (u)), expr);
  1748. break;
  1749. #endif
  1750. #if FFETARGET_okREAL3
  1751. case FFEINFO_kindtypeREAL3:
  1752. switch (ffeinfo_basictype (ffebld_info (l)))
  1753. {
  1754. case FFEINFO_basictypeINTEGER:
  1755. switch (ffeinfo_kindtype (ffebld_info (l)))
  1756. {
  1757. #if FFETARGET_okINTEGER1
  1758. case FFEINFO_kindtypeINTEGER1:
  1759. error = ffetarget_convert_real3_integer1
  1760. (ffebld_cu_ptr_real3 (u),
  1761. ffebld_constant_integer1 (ffebld_conter (l)));
  1762. break;
  1763. #endif
  1764. #if FFETARGET_okINTEGER2
  1765. case FFEINFO_kindtypeINTEGER2:
  1766. error = ffetarget_convert_real3_integer2
  1767. (ffebld_cu_ptr_real3 (u),
  1768. ffebld_constant_integer2 (ffebld_conter (l)));
  1769. break;
  1770. #endif
  1771. #if FFETARGET_okINTEGER3
  1772. case FFEINFO_kindtypeINTEGER3:
  1773. error = ffetarget_convert_real3_integer3
  1774. (ffebld_cu_ptr_real3 (u),
  1775. ffebld_constant_integer3 (ffebld_conter (l)));
  1776. break;
  1777. #endif
  1778. #if FFETARGET_okINTEGER4
  1779. case FFEINFO_kindtypeINTEGER4:
  1780. error = ffetarget_convert_real3_integer4
  1781. (ffebld_cu_ptr_real3 (u),
  1782. ffebld_constant_integer4 (ffebld_conter (l)));
  1783. break;
  1784. #endif
  1785. default:
  1786. assert ("REAL3/INTEGER bad source kind type" == NULL);
  1787. break;
  1788. }
  1789. break;
  1790. case FFEINFO_basictypeREAL:
  1791. switch (ffeinfo_kindtype (ffebld_info (l)))
  1792. {
  1793. #if FFETARGET_okREAL1
  1794. case FFEINFO_kindtypeREAL1:
  1795. error = ffetarget_convert_real3_real1
  1796. (ffebld_cu_ptr_real3 (u),
  1797. ffebld_constant_real1 (ffebld_conter (l)));
  1798. break;
  1799. #endif
  1800. #if FFETARGET_okREAL2
  1801. case FFEINFO_kindtypeREAL2:
  1802. error = ffetarget_convert_real3_real2
  1803. (ffebld_cu_ptr_real3 (u),
  1804. ffebld_constant_real2 (ffebld_conter (l)));
  1805. break;
  1806. #endif
  1807. #if FFETARGET_okREAL4
  1808. case FFEINFO_kindtypeREAL4:
  1809. error = ffetarget_convert_real3_real4
  1810. (ffebld_cu_ptr_real3 (u),
  1811. ffebld_constant_real4 (ffebld_conter (l)));
  1812. break;
  1813. #endif
  1814. default:
  1815. assert ("REAL3/REAL bad source kind type" == NULL);
  1816. break;
  1817. }
  1818. break;
  1819. case FFEINFO_basictypeCOMPLEX:
  1820. switch (ffeinfo_kindtype (ffebld_info (l)))
  1821. {
  1822. #if FFETARGET_okCOMPLEX1
  1823. case FFEINFO_kindtypeREAL1:
  1824. error = ffetarget_convert_real3_complex1
  1825. (ffebld_cu_ptr_real3 (u),
  1826. ffebld_constant_complex1 (ffebld_conter (l)));
  1827. break;
  1828. #endif
  1829. #if FFETARGET_okCOMPLEX2
  1830. case FFEINFO_kindtypeREAL2:
  1831. error = ffetarget_convert_real3_complex2
  1832. (ffebld_cu_ptr_real3 (u),
  1833. ffebld_constant_complex2 (ffebld_conter (l)));
  1834. break;
  1835. #endif
  1836. #if FFETARGET_okCOMPLEX3
  1837. case FFEINFO_kindtypeREAL3:
  1838. error = ffetarget_convert_real3_complex3
  1839. (ffebld_cu_ptr_real3 (u),
  1840. ffebld_constant_complex3 (ffebld_conter (l)));
  1841. break;
  1842. #endif
  1843. #if FFETARGET_okCOMPLEX4
  1844. case FFEINFO_kindtypeREAL4:
  1845. error = ffetarget_convert_real3_complex4
  1846. (ffebld_cu_ptr_real3 (u),
  1847. ffebld_constant_complex4 (ffebld_conter (l)));
  1848. break;
  1849. #endif
  1850. default:
  1851. assert ("REAL3/COMPLEX bad source kind type" == NULL);
  1852. break;
  1853. }
  1854. break;
  1855. case FFEINFO_basictypeCHARACTER:
  1856. error = ffetarget_convert_real3_character1
  1857. (ffebld_cu_ptr_real3 (u),
  1858. ffebld_constant_character1 (ffebld_conter (l)));
  1859. break;
  1860. case FFEINFO_basictypeHOLLERITH:
  1861. error = ffetarget_convert_real3_hollerith
  1862. (ffebld_cu_ptr_real3 (u),
  1863. ffebld_constant_hollerith (ffebld_conter (l)));
  1864. break;
  1865. case FFEINFO_basictypeTYPELESS:
  1866. error = ffetarget_convert_real3_typeless
  1867. (ffebld_cu_ptr_real3 (u),
  1868. ffebld_constant_typeless (ffebld_conter (l)));
  1869. break;
  1870. default:
  1871. assert ("REAL3 bad type" == NULL);
  1872. break;
  1873. }
  1874. /* If conversion operation is not implemented, return original expr. */
  1875. if (error == FFEBAD_NOCANDO)
  1876. return expr;
  1877. expr = ffebld_new_conter_with_orig
  1878. (ffebld_constant_new_real3_val
  1879. (ffebld_cu_val_real3 (u)), expr);
  1880. break;
  1881. #endif
  1882. #if FFETARGET_okREAL4
  1883. case FFEINFO_kindtypeREAL4:
  1884. switch (ffeinfo_basictype (ffebld_info (l)))
  1885. {
  1886. case FFEINFO_basictypeINTEGER:
  1887. switch (ffeinfo_kindtype (ffebld_info (l)))
  1888. {
  1889. #if FFETARGET_okINTEGER1
  1890. case FFEINFO_kindtypeINTEGER1:
  1891. error = ffetarget_convert_real4_integer1
  1892. (ffebld_cu_ptr_real4 (u),
  1893. ffebld_constant_integer1 (ffebld_conter (l)));
  1894. break;
  1895. #endif
  1896. #if FFETARGET_okINTEGER2
  1897. case FFEINFO_kindtypeINTEGER2:
  1898. error = ffetarget_convert_real4_integer2
  1899. (ffebld_cu_ptr_real4 (u),
  1900. ffebld_constant_integer2 (ffebld_conter (l)));
  1901. break;
  1902. #endif
  1903. #if FFETARGET_okINTEGER3
  1904. case FFEINFO_kindtypeINTEGER3:
  1905. error = ffetarget_convert_real4_integer3
  1906. (ffebld_cu_ptr_real4 (u),
  1907. ffebld_constant_integer3 (ffebld_conter (l)));
  1908. break;
  1909. #endif
  1910. #if FFETARGET_okINTEGER4
  1911. case FFEINFO_kindtypeINTEGER4:
  1912. error = ffetarget_convert_real4_integer4
  1913. (ffebld_cu_ptr_real4 (u),
  1914. ffebld_constant_integer4 (ffebld_conter (l)));
  1915. break;
  1916. #endif
  1917. default:
  1918. assert ("REAL4/INTEGER bad source kind type" == NULL);
  1919. break;
  1920. }
  1921. break;
  1922. case FFEINFO_basictypeREAL:
  1923. switch (ffeinfo_kindtype (ffebld_info (l)))
  1924. {
  1925. #if FFETARGET_okREAL1
  1926. case FFEINFO_kindtypeREAL1:
  1927. error = ffetarget_convert_real4_real1
  1928. (ffebld_cu_ptr_real4 (u),
  1929. ffebld_constant_real1 (ffebld_conter (l)));
  1930. break;
  1931. #endif
  1932. #if FFETARGET_okREAL2
  1933. case FFEINFO_kindtypeREAL2:
  1934. error = ffetarget_convert_real4_real2
  1935. (ffebld_cu_ptr_real4 (u),
  1936. ffebld_constant_real2 (ffebld_conter (l)));
  1937. break;
  1938. #endif
  1939. #if FFETARGET_okREAL3
  1940. case FFEINFO_kindtypeREAL3:
  1941. error = ffetarget_convert_real4_real3
  1942. (ffebld_cu_ptr_real4 (u),
  1943. ffebld_constant_real3 (ffebld_conter (l)));
  1944. break;
  1945. #endif
  1946. default:
  1947. assert ("REAL4/REAL bad source kind type" == NULL);
  1948. break;
  1949. }
  1950. break;
  1951. case FFEINFO_basictypeCOMPLEX:
  1952. switch (ffeinfo_kindtype (ffebld_info (l)))
  1953. {
  1954. #if FFETARGET_okCOMPLEX1
  1955. case FFEINFO_kindtypeREAL1:
  1956. error = ffetarget_convert_real4_complex1
  1957. (ffebld_cu_ptr_real4 (u),
  1958. ffebld_constant_complex1 (ffebld_conter (l)));
  1959. break;
  1960. #endif
  1961. #if FFETARGET_okCOMPLEX2
  1962. case FFEINFO_kindtypeREAL2:
  1963. error = ffetarget_convert_real4_complex2
  1964. (ffebld_cu_ptr_real4 (u),
  1965. ffebld_constant_complex2 (ffebld_conter (l)));
  1966. break;
  1967. #endif
  1968. #if FFETARGET_okCOMPLEX3
  1969. case FFEINFO_kindtypeREAL3:
  1970. error = ffetarget_convert_real4_complex3
  1971. (ffebld_cu_ptr_real4 (u),
  1972. ffebld_constant_complex3 (ffebld_conter (l)));
  1973. break;
  1974. #endif
  1975. #if FFETARGET_okCOMPLEX4
  1976. case FFEINFO_kindtypeREAL4:
  1977. error = ffetarget_convert_real4_complex4
  1978. (ffebld_cu_ptr_real4 (u),
  1979. ffebld_constant_complex4 (ffebld_conter (l)));
  1980. break;
  1981. #endif
  1982. default:
  1983. assert ("REAL4/COMPLEX bad source kind type" == NULL);
  1984. break;
  1985. }
  1986. break;
  1987. case FFEINFO_basictypeCHARACTER:
  1988. error = ffetarget_convert_real4_character1
  1989. (ffebld_cu_ptr_real4 (u),
  1990. ffebld_constant_character1 (ffebld_conter (l)));
  1991. break;
  1992. case FFEINFO_basictypeHOLLERITH:
  1993. error = ffetarget_convert_real4_hollerith
  1994. (ffebld_cu_ptr_real4 (u),
  1995. ffebld_constant_hollerith (ffebld_conter (l)));
  1996. break;
  1997. case FFEINFO_basictypeTYPELESS:
  1998. error = ffetarget_convert_real4_typeless
  1999. (ffebld_cu_ptr_real4 (u),
  2000. ffebld_constant_typeless (ffebld_conter (l)));
  2001. break;
  2002. default:
  2003. assert ("REAL4 bad type" == NULL);
  2004. break;
  2005. }
  2006. /* If conversion operation is not implemented, return original expr. */
  2007. if (error == FFEBAD_NOCANDO)
  2008. return expr;
  2009. expr = ffebld_new_conter_with_orig
  2010. (ffebld_constant_new_real4_val
  2011. (ffebld_cu_val_real4 (u)), expr);
  2012. break;
  2013. #endif
  2014. default:
  2015. assert ("bad real kind type" == NULL);
  2016. break;
  2017. }
  2018. break;
  2019. case FFEINFO_basictypeCOMPLEX:
  2020. sz = FFETARGET_charactersizeNONE;
  2021. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  2022. {
  2023. #if FFETARGET_okCOMPLEX1
  2024. case FFEINFO_kindtypeREAL1:
  2025. switch (ffeinfo_basictype (ffebld_info (l)))
  2026. {
  2027. case FFEINFO_basictypeINTEGER:
  2028. switch (ffeinfo_kindtype (ffebld_info (l)))
  2029. {
  2030. #if FFETARGET_okINTEGER1
  2031. case FFEINFO_kindtypeINTEGER1:
  2032. error = ffetarget_convert_complex1_integer1
  2033. (ffebld_cu_ptr_complex1 (u),
  2034. ffebld_constant_integer1 (ffebld_conter (l)));
  2035. break;
  2036. #endif
  2037. #if FFETARGET_okINTEGER2
  2038. case FFEINFO_kindtypeINTEGER2:
  2039. error = ffetarget_convert_complex1_integer2
  2040. (ffebld_cu_ptr_complex1 (u),
  2041. ffebld_constant_integer2 (ffebld_conter (l)));
  2042. break;
  2043. #endif
  2044. #if FFETARGET_okINTEGER3
  2045. case FFEINFO_kindtypeINTEGER3:
  2046. error = ffetarget_convert_complex1_integer3
  2047. (ffebld_cu_ptr_complex1 (u),
  2048. ffebld_constant_integer3 (ffebld_conter (l)));
  2049. break;
  2050. #endif
  2051. #if FFETARGET_okINTEGER4
  2052. case FFEINFO_kindtypeINTEGER4:
  2053. error = ffetarget_convert_complex1_integer4
  2054. (ffebld_cu_ptr_complex1 (u),
  2055. ffebld_constant_integer4 (ffebld_conter (l)));
  2056. break;
  2057. #endif
  2058. default:
  2059. assert ("COMPLEX1/INTEGER bad source kind type" == NULL);
  2060. break;
  2061. }
  2062. break;
  2063. case FFEINFO_basictypeREAL:
  2064. switch (ffeinfo_kindtype (ffebld_info (l)))
  2065. {
  2066. #if FFETARGET_okREAL1
  2067. case FFEINFO_kindtypeREAL1:
  2068. error = ffetarget_convert_complex1_real1
  2069. (ffebld_cu_ptr_complex1 (u),
  2070. ffebld_constant_real1 (ffebld_conter (l)));
  2071. break;
  2072. #endif
  2073. #if FFETARGET_okREAL2
  2074. case FFEINFO_kindtypeREAL2:
  2075. error = ffetarget_convert_complex1_real2
  2076. (ffebld_cu_ptr_complex1 (u),
  2077. ffebld_constant_real2 (ffebld_conter (l)));
  2078. break;
  2079. #endif
  2080. #if FFETARGET_okREAL3
  2081. case FFEINFO_kindtypeREAL3:
  2082. error = ffetarget_convert_complex1_real3
  2083. (ffebld_cu_ptr_complex1 (u),
  2084. ffebld_constant_real3 (ffebld_conter (l)));
  2085. break;
  2086. #endif
  2087. #if FFETARGET_okREAL4
  2088. case FFEINFO_kindtypeREAL4:
  2089. error = ffetarget_convert_complex1_real4
  2090. (ffebld_cu_ptr_complex1 (u),
  2091. ffebld_constant_real4 (ffebld_conter (l)));
  2092. break;
  2093. #endif
  2094. default:
  2095. assert ("COMPLEX1/REAL bad source kind type" == NULL);
  2096. break;
  2097. }
  2098. break;
  2099. case FFEINFO_basictypeCOMPLEX:
  2100. switch (ffeinfo_kindtype (ffebld_info (l)))
  2101. {
  2102. #if FFETARGET_okCOMPLEX2
  2103. case FFEINFO_kindtypeREAL2:
  2104. error = ffetarget_convert_complex1_complex2
  2105. (ffebld_cu_ptr_complex1 (u),
  2106. ffebld_constant_complex2 (ffebld_conter (l)));
  2107. break;
  2108. #endif
  2109. #if FFETARGET_okCOMPLEX3
  2110. case FFEINFO_kindtypeREAL3:
  2111. error = ffetarget_convert_complex1_complex3
  2112. (ffebld_cu_ptr_complex1 (u),
  2113. ffebld_constant_complex3 (ffebld_conter (l)));
  2114. break;
  2115. #endif
  2116. #if FFETARGET_okCOMPLEX4
  2117. case FFEINFO_kindtypeREAL4:
  2118. error = ffetarget_convert_complex1_complex4
  2119. (ffebld_cu_ptr_complex1 (u),
  2120. ffebld_constant_complex4 (ffebld_conter (l)));
  2121. break;
  2122. #endif
  2123. default:
  2124. assert ("COMPLEX1/COMPLEX bad source kind type" == NULL);
  2125. break;
  2126. }
  2127. break;
  2128. case FFEINFO_basictypeCHARACTER:
  2129. error = ffetarget_convert_complex1_character1
  2130. (ffebld_cu_ptr_complex1 (u),
  2131. ffebld_constant_character1 (ffebld_conter (l)));
  2132. break;
  2133. case FFEINFO_basictypeHOLLERITH:
  2134. error = ffetarget_convert_complex1_hollerith
  2135. (ffebld_cu_ptr_complex1 (u),
  2136. ffebld_constant_hollerith (ffebld_conter (l)));
  2137. break;
  2138. case FFEINFO_basictypeTYPELESS:
  2139. error = ffetarget_convert_complex1_typeless
  2140. (ffebld_cu_ptr_complex1 (u),
  2141. ffebld_constant_typeless (ffebld_conter (l)));
  2142. break;
  2143. default:
  2144. assert ("COMPLEX1 bad type" == NULL);
  2145. break;
  2146. }
  2147. /* If conversion operation is not implemented, return original expr. */
  2148. if (error == FFEBAD_NOCANDO)
  2149. return expr;
  2150. expr = ffebld_new_conter_with_orig
  2151. (ffebld_constant_new_complex1_val
  2152. (ffebld_cu_val_complex1 (u)), expr);
  2153. break;
  2154. #endif
  2155. #if FFETARGET_okCOMPLEX2
  2156. case FFEINFO_kindtypeREAL2:
  2157. switch (ffeinfo_basictype (ffebld_info (l)))
  2158. {
  2159. case FFEINFO_basictypeINTEGER:
  2160. switch (ffeinfo_kindtype (ffebld_info (l)))
  2161. {
  2162. #if FFETARGET_okINTEGER1
  2163. case FFEINFO_kindtypeINTEGER1:
  2164. error = ffetarget_convert_complex2_integer1
  2165. (ffebld_cu_ptr_complex2 (u),
  2166. ffebld_constant_integer1 (ffebld_conter (l)));
  2167. break;
  2168. #endif
  2169. #if FFETARGET_okINTEGER2
  2170. case FFEINFO_kindtypeINTEGER2:
  2171. error = ffetarget_convert_complex2_integer2
  2172. (ffebld_cu_ptr_complex2 (u),
  2173. ffebld_constant_integer2 (ffebld_conter (l)));
  2174. break;
  2175. #endif
  2176. #if FFETARGET_okINTEGER3
  2177. case FFEINFO_kindtypeINTEGER3:
  2178. error = ffetarget_convert_complex2_integer3
  2179. (ffebld_cu_ptr_complex2 (u),
  2180. ffebld_constant_integer3 (ffebld_conter (l)));
  2181. break;
  2182. #endif
  2183. #if FFETARGET_okINTEGER4
  2184. case FFEINFO_kindtypeINTEGER4:
  2185. error = ffetarget_convert_complex2_integer4
  2186. (ffebld_cu_ptr_complex2 (u),
  2187. ffebld_constant_integer4 (ffebld_conter (l)));
  2188. break;
  2189. #endif
  2190. default:
  2191. assert ("COMPLEX2/INTEGER bad source kind type" == NULL);
  2192. break;
  2193. }
  2194. break;
  2195. case FFEINFO_basictypeREAL:
  2196. switch (ffeinfo_kindtype (ffebld_info (l)))
  2197. {
  2198. #if FFETARGET_okREAL1
  2199. case FFEINFO_kindtypeREAL1:
  2200. error = ffetarget_convert_complex2_real1
  2201. (ffebld_cu_ptr_complex2 (u),
  2202. ffebld_constant_real1 (ffebld_conter (l)));
  2203. break;
  2204. #endif
  2205. #if FFETARGET_okREAL2
  2206. case FFEINFO_kindtypeREAL2:
  2207. error = ffetarget_convert_complex2_real2
  2208. (ffebld_cu_ptr_complex2 (u),
  2209. ffebld_constant_real2 (ffebld_conter (l)));
  2210. break;
  2211. #endif
  2212. #if FFETARGET_okREAL3
  2213. case FFEINFO_kindtypeREAL3:
  2214. error = ffetarget_convert_complex2_real3
  2215. (ffebld_cu_ptr_complex2 (u),
  2216. ffebld_constant_real3 (ffebld_conter (l)));
  2217. break;
  2218. #endif
  2219. #if FFETARGET_okREAL4
  2220. case FFEINFO_kindtypeREAL4:
  2221. error = ffetarget_convert_complex2_real4
  2222. (ffebld_cu_ptr_complex2 (u),
  2223. ffebld_constant_real4 (ffebld_conter (l)));
  2224. break;
  2225. #endif
  2226. default:
  2227. assert ("COMPLEX2/REAL bad source kind type" == NULL);
  2228. break;
  2229. }
  2230. break;
  2231. case FFEINFO_basictypeCOMPLEX:
  2232. switch (ffeinfo_kindtype (ffebld_info (l)))
  2233. {
  2234. #if FFETARGET_okCOMPLEX1
  2235. case FFEINFO_kindtypeREAL1:
  2236. error = ffetarget_convert_complex2_complex1
  2237. (ffebld_cu_ptr_complex2 (u),
  2238. ffebld_constant_complex1 (ffebld_conter (l)));
  2239. break;
  2240. #endif
  2241. #if FFETARGET_okCOMPLEX3
  2242. case FFEINFO_kindtypeREAL3:
  2243. error = ffetarget_convert_complex2_complex3
  2244. (ffebld_cu_ptr_complex2 (u),
  2245. ffebld_constant_complex3 (ffebld_conter (l)));
  2246. break;
  2247. #endif
  2248. #if FFETARGET_okCOMPLEX4
  2249. case FFEINFO_kindtypeREAL4:
  2250. error = ffetarget_convert_complex2_complex4
  2251. (ffebld_cu_ptr_complex2 (u),
  2252. ffebld_constant_complex4 (ffebld_conter (l)));
  2253. break;
  2254. #endif
  2255. default:
  2256. assert ("COMPLEX2/COMPLEX bad source kind type" == NULL);
  2257. break;
  2258. }
  2259. break;
  2260. case FFEINFO_basictypeCHARACTER:
  2261. error = ffetarget_convert_complex2_character1
  2262. (ffebld_cu_ptr_complex2 (u),
  2263. ffebld_constant_character1 (ffebld_conter (l)));
  2264. break;
  2265. case FFEINFO_basictypeHOLLERITH:
  2266. error = ffetarget_convert_complex2_hollerith
  2267. (ffebld_cu_ptr_complex2 (u),
  2268. ffebld_constant_hollerith (ffebld_conter (l)));
  2269. break;
  2270. case FFEINFO_basictypeTYPELESS:
  2271. error = ffetarget_convert_complex2_typeless
  2272. (ffebld_cu_ptr_complex2 (u),
  2273. ffebld_constant_typeless (ffebld_conter (l)));
  2274. break;
  2275. default:
  2276. assert ("COMPLEX2 bad type" == NULL);
  2277. break;
  2278. }
  2279. /* If conversion operation is not implemented, return original expr. */
  2280. if (error == FFEBAD_NOCANDO)
  2281. return expr;
  2282. expr = ffebld_new_conter_with_orig
  2283. (ffebld_constant_new_complex2_val
  2284. (ffebld_cu_val_complex2 (u)), expr);
  2285. break;
  2286. #endif
  2287. #if FFETARGET_okCOMPLEX3
  2288. case FFEINFO_kindtypeREAL3:
  2289. switch (ffeinfo_basictype (ffebld_info (l)))
  2290. {
  2291. case FFEINFO_basictypeINTEGER:
  2292. switch (ffeinfo_kindtype (ffebld_info (l)))
  2293. {
  2294. #if FFETARGET_okINTEGER1
  2295. case FFEINFO_kindtypeINTEGER1:
  2296. error = ffetarget_convert_complex3_integer1
  2297. (ffebld_cu_ptr_complex3 (u),
  2298. ffebld_constant_integer1 (ffebld_conter (l)));
  2299. break;
  2300. #endif
  2301. #if FFETARGET_okINTEGER2
  2302. case FFEINFO_kindtypeINTEGER2:
  2303. error = ffetarget_convert_complex3_integer2
  2304. (ffebld_cu_ptr_complex3 (u),
  2305. ffebld_constant_integer2 (ffebld_conter (l)));
  2306. break;
  2307. #endif
  2308. #if FFETARGET_okINTEGER3
  2309. case FFEINFO_kindtypeINTEGER3:
  2310. error = ffetarget_convert_complex3_integer3
  2311. (ffebld_cu_ptr_complex3 (u),
  2312. ffebld_constant_integer3 (ffebld_conter (l)));
  2313. break;
  2314. #endif
  2315. #if FFETARGET_okINTEGER4
  2316. case FFEINFO_kindtypeINTEGER4:
  2317. error = ffetarget_convert_complex3_integer4
  2318. (ffebld_cu_ptr_complex3 (u),
  2319. ffebld_constant_integer4 (ffebld_conter (l)));
  2320. break;
  2321. #endif
  2322. default:
  2323. assert ("COMPLEX3/INTEGER bad source kind type" == NULL);
  2324. break;
  2325. }
  2326. break;
  2327. case FFEINFO_basictypeREAL:
  2328. switch (ffeinfo_kindtype (ffebld_info (l)))
  2329. {
  2330. #if FFETARGET_okREAL1
  2331. case FFEINFO_kindtypeREAL1:
  2332. error = ffetarget_convert_complex3_real1
  2333. (ffebld_cu_ptr_complex3 (u),
  2334. ffebld_constant_real1 (ffebld_conter (l)));
  2335. break;
  2336. #endif
  2337. #if FFETARGET_okREAL2
  2338. case FFEINFO_kindtypeREAL2:
  2339. error = ffetarget_convert_complex3_real2
  2340. (ffebld_cu_ptr_complex3 (u),
  2341. ffebld_constant_real2 (ffebld_conter (l)));
  2342. break;
  2343. #endif
  2344. #if FFETARGET_okREAL3
  2345. case FFEINFO_kindtypeREAL3:
  2346. error = ffetarget_convert_complex3_real3
  2347. (ffebld_cu_ptr_complex3 (u),
  2348. ffebld_constant_real3 (ffebld_conter (l)));
  2349. break;
  2350. #endif
  2351. #if FFETARGET_okREAL4
  2352. case FFEINFO_kindtypeREAL4:
  2353. error = ffetarget_convert_complex3_real4
  2354. (ffebld_cu_ptr_complex3 (u),
  2355. ffebld_constant_real4 (ffebld_conter (l)));
  2356. break;
  2357. #endif
  2358. default:
  2359. assert ("COMPLEX3/REAL bad source kind type" == NULL);
  2360. break;
  2361. }
  2362. break;
  2363. case FFEINFO_basictypeCOMPLEX:
  2364. switch (ffeinfo_kindtype (ffebld_info (l)))
  2365. {
  2366. #if FFETARGET_okCOMPLEX1
  2367. case FFEINFO_kindtypeREAL1:
  2368. error = ffetarget_convert_complex3_complex1
  2369. (ffebld_cu_ptr_complex3 (u),
  2370. ffebld_constant_complex1 (ffebld_conter (l)));
  2371. break;
  2372. #endif
  2373. #if FFETARGET_okCOMPLEX2
  2374. case FFEINFO_kindtypeREAL2:
  2375. error = ffetarget_convert_complex3_complex2
  2376. (ffebld_cu_ptr_complex3 (u),
  2377. ffebld_constant_complex2 (ffebld_conter (l)));
  2378. break;
  2379. #endif
  2380. #if FFETARGET_okCOMPLEX4
  2381. case FFEINFO_kindtypeREAL4:
  2382. error = ffetarget_convert_complex3_complex4
  2383. (ffebld_cu_ptr_complex3 (u),
  2384. ffebld_constant_complex4 (ffebld_conter (l)));
  2385. break;
  2386. #endif
  2387. default:
  2388. assert ("COMPLEX3/COMPLEX bad source kind type" == NULL);
  2389. break;
  2390. }
  2391. break;
  2392. case FFEINFO_basictypeCHARACTER:
  2393. error = ffetarget_convert_complex3_character1
  2394. (ffebld_cu_ptr_complex3 (u),
  2395. ffebld_constant_character1 (ffebld_conter (l)));
  2396. break;
  2397. case FFEINFO_basictypeHOLLERITH:
  2398. error = ffetarget_convert_complex3_hollerith
  2399. (ffebld_cu_ptr_complex3 (u),
  2400. ffebld_constant_hollerith (ffebld_conter (l)));
  2401. break;
  2402. case FFEINFO_basictypeTYPELESS:
  2403. error = ffetarget_convert_complex3_typeless
  2404. (ffebld_cu_ptr_complex3 (u),
  2405. ffebld_constant_typeless (ffebld_conter (l)));
  2406. break;
  2407. default:
  2408. assert ("COMPLEX3 bad type" == NULL);
  2409. break;
  2410. }
  2411. /* If conversion operation is not implemented, return original expr. */
  2412. if (error == FFEBAD_NOCANDO)
  2413. return expr;
  2414. expr = ffebld_new_conter_with_orig
  2415. (ffebld_constant_new_complex3_val
  2416. (ffebld_cu_val_complex3 (u)), expr);
  2417. break;
  2418. #endif
  2419. #if FFETARGET_okCOMPLEX4
  2420. case FFEINFO_kindtypeREAL4:
  2421. switch (ffeinfo_basictype (ffebld_info (l)))
  2422. {
  2423. case FFEINFO_basictypeINTEGER:
  2424. switch (ffeinfo_kindtype (ffebld_info (l)))
  2425. {
  2426. #if FFETARGET_okINTEGER1
  2427. case FFEINFO_kindtypeINTEGER1:
  2428. error = ffetarget_convert_complex4_integer1
  2429. (ffebld_cu_ptr_complex4 (u),
  2430. ffebld_constant_integer1 (ffebld_conter (l)));
  2431. break;
  2432. #endif
  2433. #if FFETARGET_okINTEGER2
  2434. case FFEINFO_kindtypeINTEGER2:
  2435. error = ffetarget_convert_complex4_integer2
  2436. (ffebld_cu_ptr_complex4 (u),
  2437. ffebld_constant_integer2 (ffebld_conter (l)));
  2438. break;
  2439. #endif
  2440. #if FFETARGET_okINTEGER3
  2441. case FFEINFO_kindtypeINTEGER3:
  2442. error = ffetarget_convert_complex4_integer3
  2443. (ffebld_cu_ptr_complex4 (u),
  2444. ffebld_constant_integer3 (ffebld_conter (l)));
  2445. break;
  2446. #endif
  2447. #if FFETARGET_okINTEGER4
  2448. case FFEINFO_kindtypeINTEGER4:
  2449. error = ffetarget_convert_complex4_integer4
  2450. (ffebld_cu_ptr_complex4 (u),
  2451. ffebld_constant_integer4 (ffebld_conter (l)));
  2452. break;
  2453. #endif
  2454. default:
  2455. assert ("COMPLEX4/INTEGER bad source kind type" == NULL);
  2456. break;
  2457. }
  2458. break;
  2459. case FFEINFO_basictypeREAL:
  2460. switch (ffeinfo_kindtype (ffebld_info (l)))
  2461. {
  2462. #if FFETARGET_okREAL1
  2463. case FFEINFO_kindtypeREAL1:
  2464. error = ffetarget_convert_complex4_real1
  2465. (ffebld_cu_ptr_complex4 (u),
  2466. ffebld_constant_real1 (ffebld_conter (l)));
  2467. break;
  2468. #endif
  2469. #if FFETARGET_okREAL2
  2470. case FFEINFO_kindtypeREAL2:
  2471. error = ffetarget_convert_complex4_real2
  2472. (ffebld_cu_ptr_complex4 (u),
  2473. ffebld_constant_real2 (ffebld_conter (l)));
  2474. break;
  2475. #endif
  2476. #if FFETARGET_okREAL3
  2477. case FFEINFO_kindtypeREAL3:
  2478. error = ffetarget_convert_complex4_real3
  2479. (ffebld_cu_ptr_complex4 (u),
  2480. ffebld_constant_real3 (ffebld_conter (l)));
  2481. break;
  2482. #endif
  2483. #if FFETARGET_okREAL4
  2484. case FFEINFO_kindtypeREAL4:
  2485. error = ffetarget_convert_complex4_real4
  2486. (ffebld_cu_ptr_complex4 (u),
  2487. ffebld_constant_real4 (ffebld_conter (l)));
  2488. break;
  2489. #endif
  2490. default:
  2491. assert ("COMPLEX4/REAL bad source kind type" == NULL);
  2492. break;
  2493. }
  2494. break;
  2495. case FFEINFO_basictypeCOMPLEX:
  2496. switch (ffeinfo_kindtype (ffebld_info (l)))
  2497. {
  2498. #if FFETARGET_okCOMPLEX1
  2499. case FFEINFO_kindtypeREAL1:
  2500. error = ffetarget_convert_complex4_complex1
  2501. (ffebld_cu_ptr_complex4 (u),
  2502. ffebld_constant_complex1 (ffebld_conter (l)));
  2503. break;
  2504. #endif
  2505. #if FFETARGET_okCOMPLEX2
  2506. case FFEINFO_kindtypeREAL2:
  2507. error = ffetarget_convert_complex4_complex2
  2508. (ffebld_cu_ptr_complex4 (u),
  2509. ffebld_constant_complex2 (ffebld_conter (l)));
  2510. break;
  2511. #endif
  2512. #if FFETARGET_okCOMPLEX3
  2513. case FFEINFO_kindtypeREAL3:
  2514. error = ffetarget_convert_complex4_complex3
  2515. (ffebld_cu_ptr_complex4 (u),
  2516. ffebld_constant_complex3 (ffebld_conter (l)));
  2517. break;
  2518. #endif
  2519. default:
  2520. assert ("COMPLEX4/COMPLEX bad source kind type" == NULL);
  2521. break;
  2522. }
  2523. break;
  2524. case FFEINFO_basictypeCHARACTER:
  2525. error = ffetarget_convert_complex4_character1
  2526. (ffebld_cu_ptr_complex4 (u),
  2527. ffebld_constant_character1 (ffebld_conter (l)));
  2528. break;
  2529. case FFEINFO_basictypeHOLLERITH:
  2530. error = ffetarget_convert_complex4_hollerith
  2531. (ffebld_cu_ptr_complex4 (u),
  2532. ffebld_constant_hollerith (ffebld_conter (l)));
  2533. break;
  2534. case FFEINFO_basictypeTYPELESS:
  2535. error = ffetarget_convert_complex4_typeless
  2536. (ffebld_cu_ptr_complex4 (u),
  2537. ffebld_constant_typeless (ffebld_conter (l)));
  2538. break;
  2539. default:
  2540. assert ("COMPLEX4 bad type" == NULL);
  2541. break;
  2542. }
  2543. /* If conversion operation is not implemented, return original expr. */
  2544. if (error == FFEBAD_NOCANDO)
  2545. return expr;
  2546. expr = ffebld_new_conter_with_orig
  2547. (ffebld_constant_new_complex4_val
  2548. (ffebld_cu_val_complex4 (u)), expr);
  2549. break;
  2550. #endif
  2551. default:
  2552. assert ("bad complex kind type" == NULL);
  2553. break;
  2554. }
  2555. break;
  2556. case FFEINFO_basictypeCHARACTER:
  2557. if ((sz = ffebld_size (expr)) == FFETARGET_charactersizeNONE)
  2558. return expr;
  2559. kt = ffeinfo_kindtype (ffebld_info (expr));
  2560. switch (kt)
  2561. {
  2562. #if FFETARGET_okCHARACTER1
  2563. case FFEINFO_kindtypeCHARACTER1:
  2564. switch (ffeinfo_basictype (ffebld_info (l)))
  2565. {
  2566. case FFEINFO_basictypeCHARACTER:
  2567. if ((sz2 = ffebld_size (l)) == FFETARGET_charactersizeNONE)
  2568. return expr;
  2569. assert (kt == ffeinfo_kindtype (ffebld_info (l)));
  2570. assert (sz2 == ffetarget_length_character1
  2571. (ffebld_constant_character1
  2572. (ffebld_conter (l))));
  2573. error
  2574. = ffetarget_convert_character1_character1
  2575. (ffebld_cu_ptr_character1 (u), sz,
  2576. ffebld_constant_character1 (ffebld_conter (l)),
  2577. ffebld_constant_pool ());
  2578. break;
  2579. case FFEINFO_basictypeINTEGER:
  2580. switch (ffeinfo_kindtype (ffebld_info (l)))
  2581. {
  2582. #if FFETARGET_okINTEGER1
  2583. case FFEINFO_kindtypeINTEGER1:
  2584. error
  2585. = ffetarget_convert_character1_integer1
  2586. (ffebld_cu_ptr_character1 (u),
  2587. sz,
  2588. ffebld_constant_integer1 (ffebld_conter (l)),
  2589. ffebld_constant_pool ());
  2590. break;
  2591. #endif
  2592. #if FFETARGET_okINTEGER2
  2593. case FFEINFO_kindtypeINTEGER2:
  2594. error
  2595. = ffetarget_convert_character1_integer2
  2596. (ffebld_cu_ptr_character1 (u),
  2597. sz,
  2598. ffebld_constant_integer2 (ffebld_conter (l)),
  2599. ffebld_constant_pool ());
  2600. break;
  2601. #endif
  2602. #if FFETARGET_okINTEGER3
  2603. case FFEINFO_kindtypeINTEGER3:
  2604. error
  2605. = ffetarget_convert_character1_integer3
  2606. (ffebld_cu_ptr_character1 (u),
  2607. sz,
  2608. ffebld_constant_integer3 (ffebld_conter (l)),
  2609. ffebld_constant_pool ());
  2610. break;
  2611. #endif
  2612. #if FFETARGET_okINTEGER4
  2613. case FFEINFO_kindtypeINTEGER4:
  2614. error
  2615. = ffetarget_convert_character1_integer4
  2616. (ffebld_cu_ptr_character1 (u),
  2617. sz,
  2618. ffebld_constant_integer4 (ffebld_conter (l)),
  2619. ffebld_constant_pool ());
  2620. break;
  2621. #endif
  2622. default:
  2623. assert ("CHARACTER1/INTEGER bad source kind type" == NULL);
  2624. break;
  2625. }
  2626. break;
  2627. case FFEINFO_basictypeLOGICAL:
  2628. switch (ffeinfo_kindtype (ffebld_info (l)))
  2629. {
  2630. #if FFETARGET_okLOGICAL1
  2631. case FFEINFO_kindtypeLOGICAL1:
  2632. error
  2633. = ffetarget_convert_character1_logical1
  2634. (ffebld_cu_ptr_character1 (u),
  2635. sz,
  2636. ffebld_constant_logical1 (ffebld_conter (l)),
  2637. ffebld_constant_pool ());
  2638. break;
  2639. #endif
  2640. #if FFETARGET_okLOGICAL2
  2641. case FFEINFO_kindtypeLOGICAL2:
  2642. error
  2643. = ffetarget_convert_character1_logical2
  2644. (ffebld_cu_ptr_character1 (u),
  2645. sz,
  2646. ffebld_constant_logical2 (ffebld_conter (l)),
  2647. ffebld_constant_pool ());
  2648. break;
  2649. #endif
  2650. #if FFETARGET_okLOGICAL3
  2651. case FFEINFO_kindtypeLOGICAL3:
  2652. error
  2653. = ffetarget_convert_character1_logical3
  2654. (ffebld_cu_ptr_character1 (u),
  2655. sz,
  2656. ffebld_constant_logical3 (ffebld_conter (l)),
  2657. ffebld_constant_pool ());
  2658. break;
  2659. #endif
  2660. #if FFETARGET_okLOGICAL4
  2661. case FFEINFO_kindtypeLOGICAL4:
  2662. error
  2663. = ffetarget_convert_character1_logical4
  2664. (ffebld_cu_ptr_character1 (u),
  2665. sz,
  2666. ffebld_constant_logical4 (ffebld_conter (l)),
  2667. ffebld_constant_pool ());
  2668. break;
  2669. #endif
  2670. default:
  2671. assert ("CHARACTER1/LOGICAL bad source kind type" == NULL);
  2672. break;
  2673. }
  2674. break;
  2675. case FFEINFO_basictypeHOLLERITH:
  2676. error
  2677. = ffetarget_convert_character1_hollerith
  2678. (ffebld_cu_ptr_character1 (u),
  2679. sz,
  2680. ffebld_constant_hollerith (ffebld_conter (l)),
  2681. ffebld_constant_pool ());
  2682. break;
  2683. case FFEINFO_basictypeTYPELESS:
  2684. error
  2685. = ffetarget_convert_character1_typeless
  2686. (ffebld_cu_ptr_character1 (u),
  2687. sz,
  2688. ffebld_constant_typeless (ffebld_conter (l)),
  2689. ffebld_constant_pool ());
  2690. break;
  2691. default:
  2692. assert ("CHARACTER1 bad type" == NULL);
  2693. }
  2694. expr
  2695. = ffebld_new_conter_with_orig
  2696. (ffebld_constant_new_character1_val
  2697. (ffebld_cu_val_character1 (u)),
  2698. expr);
  2699. break;
  2700. #endif
  2701. default:
  2702. assert ("bad character kind type" == NULL);
  2703. break;
  2704. }
  2705. break;
  2706. default:
  2707. assert ("bad type" == NULL);
  2708. return expr;
  2709. }
  2710. ffebld_set_info (expr, ffeinfo_new
  2711. (bt,
  2712. kt,
  2713. 0,
  2714. FFEINFO_kindENTITY,
  2715. FFEINFO_whereCONSTANT,
  2716. sz));
  2717. if ((error != FFEBAD)
  2718. && ffebad_start (error))
  2719. {
  2720. assert (t != NULL);
  2721. ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  2722. ffebad_finish ();
  2723. }
  2724. return expr;
  2725. }
  2726. /* ffeexpr_collapse_paren -- Collapse paren expr
  2727. ffebld expr;
  2728. ffelexToken token;
  2729. expr = ffeexpr_collapse_paren(expr,token);
  2730. If the result of the expr is a constant, replaces the expr with the
  2731. computed constant. */
  2732. ffebld
  2733. ffeexpr_collapse_paren (ffebld expr, ffelexToken t UNUSED)
  2734. {
  2735. ffebld r;
  2736. ffeinfoBasictype bt;
  2737. ffeinfoKindtype kt;
  2738. ffetargetCharacterSize len;
  2739. if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  2740. return expr;
  2741. r = ffebld_left (expr);
  2742. if (ffebld_op (r) != FFEBLD_opCONTER)
  2743. return expr;
  2744. bt = ffeinfo_basictype (ffebld_info (r));
  2745. kt = ffeinfo_kindtype (ffebld_info (r));
  2746. len = ffebld_size (r);
  2747. expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
  2748. expr);
  2749. ffebld_set_info (expr, ffeinfo_new
  2750. (bt,
  2751. kt,
  2752. 0,
  2753. FFEINFO_kindENTITY,
  2754. FFEINFO_whereCONSTANT,
  2755. len));
  2756. return expr;
  2757. }
  2758. /* ffeexpr_collapse_uplus -- Collapse uplus expr
  2759. ffebld expr;
  2760. ffelexToken token;
  2761. expr = ffeexpr_collapse_uplus(expr,token);
  2762. If the result of the expr is a constant, replaces the expr with the
  2763. computed constant. */
  2764. ffebld
  2765. ffeexpr_collapse_uplus (ffebld expr, ffelexToken t UNUSED)
  2766. {
  2767. ffebld r;
  2768. ffeinfoBasictype bt;
  2769. ffeinfoKindtype kt;
  2770. ffetargetCharacterSize len;
  2771. if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  2772. return expr;
  2773. r = ffebld_left (expr);
  2774. if (ffebld_op (r) != FFEBLD_opCONTER)
  2775. return expr;
  2776. bt = ffeinfo_basictype (ffebld_info (r));
  2777. kt = ffeinfo_kindtype (ffebld_info (r));
  2778. len = ffebld_size (r);
  2779. expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
  2780. expr);
  2781. ffebld_set_info (expr, ffeinfo_new
  2782. (bt,
  2783. kt,
  2784. 0,
  2785. FFEINFO_kindENTITY,
  2786. FFEINFO_whereCONSTANT,
  2787. len));
  2788. return expr;
  2789. }
  2790. /* ffeexpr_collapse_uminus -- Collapse uminus expr
  2791. ffebld expr;
  2792. ffelexToken token;
  2793. expr = ffeexpr_collapse_uminus(expr,token);
  2794. If the result of the expr is a constant, replaces the expr with the
  2795. computed constant. */
  2796. ffebld
  2797. ffeexpr_collapse_uminus (ffebld expr, ffelexToken t)
  2798. {
  2799. ffebad error = FFEBAD;
  2800. ffebld r;
  2801. ffebldConstantUnion u;
  2802. ffeinfoBasictype bt;
  2803. ffeinfoKindtype kt;
  2804. if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  2805. return expr;
  2806. r = ffebld_left (expr);
  2807. if (ffebld_op (r) != FFEBLD_opCONTER)
  2808. return expr;
  2809. switch (bt = ffeinfo_basictype (ffebld_info (expr)))
  2810. {
  2811. case FFEINFO_basictypeANY:
  2812. return expr;
  2813. case FFEINFO_basictypeINTEGER:
  2814. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  2815. {
  2816. #if FFETARGET_okINTEGER1
  2817. case FFEINFO_kindtypeINTEGER1:
  2818. error = ffetarget_uminus_integer1 (ffebld_cu_ptr_integer1 (u),
  2819. ffebld_constant_integer1 (ffebld_conter (r)));
  2820. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
  2821. (ffebld_cu_val_integer1 (u)), expr);
  2822. break;
  2823. #endif
  2824. #if FFETARGET_okINTEGER2
  2825. case FFEINFO_kindtypeINTEGER2:
  2826. error = ffetarget_uminus_integer2 (ffebld_cu_ptr_integer2 (u),
  2827. ffebld_constant_integer2 (ffebld_conter (r)));
  2828. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
  2829. (ffebld_cu_val_integer2 (u)), expr);
  2830. break;
  2831. #endif
  2832. #if FFETARGET_okINTEGER3
  2833. case FFEINFO_kindtypeINTEGER3:
  2834. error = ffetarget_uminus_integer3 (ffebld_cu_ptr_integer3 (u),
  2835. ffebld_constant_integer3 (ffebld_conter (r)));
  2836. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
  2837. (ffebld_cu_val_integer3 (u)), expr);
  2838. break;
  2839. #endif
  2840. #if FFETARGET_okINTEGER4
  2841. case FFEINFO_kindtypeINTEGER4:
  2842. error = ffetarget_uminus_integer4 (ffebld_cu_ptr_integer4 (u),
  2843. ffebld_constant_integer4 (ffebld_conter (r)));
  2844. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
  2845. (ffebld_cu_val_integer4 (u)), expr);
  2846. break;
  2847. #endif
  2848. default:
  2849. assert ("bad integer kind type" == NULL);
  2850. break;
  2851. }
  2852. break;
  2853. case FFEINFO_basictypeREAL:
  2854. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  2855. {
  2856. #if FFETARGET_okREAL1
  2857. case FFEINFO_kindtypeREAL1:
  2858. error = ffetarget_uminus_real1 (ffebld_cu_ptr_real1 (u),
  2859. ffebld_constant_real1 (ffebld_conter (r)));
  2860. expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
  2861. (ffebld_cu_val_real1 (u)), expr);
  2862. break;
  2863. #endif
  2864. #if FFETARGET_okREAL2
  2865. case FFEINFO_kindtypeREAL2:
  2866. error = ffetarget_uminus_real2 (ffebld_cu_ptr_real2 (u),
  2867. ffebld_constant_real2 (ffebld_conter (r)));
  2868. expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
  2869. (ffebld_cu_val_real2 (u)), expr);
  2870. break;
  2871. #endif
  2872. #if FFETARGET_okREAL3
  2873. case FFEINFO_kindtypeREAL3:
  2874. error = ffetarget_uminus_real3 (ffebld_cu_ptr_real3 (u),
  2875. ffebld_constant_real3 (ffebld_conter (r)));
  2876. expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
  2877. (ffebld_cu_val_real3 (u)), expr);
  2878. break;
  2879. #endif
  2880. #if FFETARGET_okREAL4
  2881. case FFEINFO_kindtypeREAL4:
  2882. error = ffetarget_uminus_real4 (ffebld_cu_ptr_real4 (u),
  2883. ffebld_constant_real4 (ffebld_conter (r)));
  2884. expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
  2885. (ffebld_cu_val_real4 (u)), expr);
  2886. break;
  2887. #endif
  2888. default:
  2889. assert ("bad real kind type" == NULL);
  2890. break;
  2891. }
  2892. break;
  2893. case FFEINFO_basictypeCOMPLEX:
  2894. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  2895. {
  2896. #if FFETARGET_okCOMPLEX1
  2897. case FFEINFO_kindtypeREAL1:
  2898. error = ffetarget_uminus_complex1 (ffebld_cu_ptr_complex1 (u),
  2899. ffebld_constant_complex1 (ffebld_conter (r)));
  2900. expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
  2901. (ffebld_cu_val_complex1 (u)), expr);
  2902. break;
  2903. #endif
  2904. #if FFETARGET_okCOMPLEX2
  2905. case FFEINFO_kindtypeREAL2:
  2906. error = ffetarget_uminus_complex2 (ffebld_cu_ptr_complex2 (u),
  2907. ffebld_constant_complex2 (ffebld_conter (r)));
  2908. expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
  2909. (ffebld_cu_val_complex2 (u)), expr);
  2910. break;
  2911. #endif
  2912. #if FFETARGET_okCOMPLEX3
  2913. case FFEINFO_kindtypeREAL3:
  2914. error = ffetarget_uminus_complex3 (ffebld_cu_ptr_complex3 (u),
  2915. ffebld_constant_complex3 (ffebld_conter (r)));
  2916. expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
  2917. (ffebld_cu_val_complex3 (u)), expr);
  2918. break;
  2919. #endif
  2920. #if FFETARGET_okCOMPLEX4
  2921. case FFEINFO_kindtypeREAL4:
  2922. error = ffetarget_uminus_complex4 (ffebld_cu_ptr_complex4 (u),
  2923. ffebld_constant_complex4 (ffebld_conter (r)));
  2924. expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
  2925. (ffebld_cu_val_complex4 (u)), expr);
  2926. break;
  2927. #endif
  2928. default:
  2929. assert ("bad complex kind type" == NULL);
  2930. break;
  2931. }
  2932. break;
  2933. default:
  2934. assert ("bad type" == NULL);
  2935. return expr;
  2936. }
  2937. ffebld_set_info (expr, ffeinfo_new
  2938. (bt,
  2939. kt,
  2940. 0,
  2941. FFEINFO_kindENTITY,
  2942. FFEINFO_whereCONSTANT,
  2943. FFETARGET_charactersizeNONE));
  2944. if ((error != FFEBAD)
  2945. && ffebad_start (error))
  2946. {
  2947. ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  2948. ffebad_finish ();
  2949. }
  2950. return expr;
  2951. }
  2952. /* ffeexpr_collapse_not -- Collapse not expr
  2953. ffebld expr;
  2954. ffelexToken token;
  2955. expr = ffeexpr_collapse_not(expr,token);
  2956. If the result of the expr is a constant, replaces the expr with the
  2957. computed constant. */
  2958. ffebld
  2959. ffeexpr_collapse_not (ffebld expr, ffelexToken t)
  2960. {
  2961. ffebad error = FFEBAD;
  2962. ffebld r;
  2963. ffebldConstantUnion u;
  2964. ffeinfoBasictype bt;
  2965. ffeinfoKindtype kt;
  2966. if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  2967. return expr;
  2968. r = ffebld_left (expr);
  2969. if (ffebld_op (r) != FFEBLD_opCONTER)
  2970. return expr;
  2971. switch (bt = ffeinfo_basictype (ffebld_info (expr)))
  2972. {
  2973. case FFEINFO_basictypeANY:
  2974. return expr;
  2975. case FFEINFO_basictypeINTEGER:
  2976. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  2977. {
  2978. #if FFETARGET_okINTEGER1
  2979. case FFEINFO_kindtypeINTEGER1:
  2980. error = ffetarget_not_integer1 (ffebld_cu_ptr_integer1 (u),
  2981. ffebld_constant_integer1 (ffebld_conter (r)));
  2982. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
  2983. (ffebld_cu_val_integer1 (u)), expr);
  2984. break;
  2985. #endif
  2986. #if FFETARGET_okINTEGER2
  2987. case FFEINFO_kindtypeINTEGER2:
  2988. error = ffetarget_not_integer2 (ffebld_cu_ptr_integer2 (u),
  2989. ffebld_constant_integer2 (ffebld_conter (r)));
  2990. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
  2991. (ffebld_cu_val_integer2 (u)), expr);
  2992. break;
  2993. #endif
  2994. #if FFETARGET_okINTEGER3
  2995. case FFEINFO_kindtypeINTEGER3:
  2996. error = ffetarget_not_integer3 (ffebld_cu_ptr_integer3 (u),
  2997. ffebld_constant_integer3 (ffebld_conter (r)));
  2998. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
  2999. (ffebld_cu_val_integer3 (u)), expr);
  3000. break;
  3001. #endif
  3002. #if FFETARGET_okINTEGER4
  3003. case FFEINFO_kindtypeINTEGER4:
  3004. error = ffetarget_not_integer4 (ffebld_cu_ptr_integer4 (u),
  3005. ffebld_constant_integer4 (ffebld_conter (r)));
  3006. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
  3007. (ffebld_cu_val_integer4 (u)), expr);
  3008. break;
  3009. #endif
  3010. default:
  3011. assert ("bad integer kind type" == NULL);
  3012. break;
  3013. }
  3014. break;
  3015. case FFEINFO_basictypeLOGICAL:
  3016. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3017. {
  3018. #if FFETARGET_okLOGICAL1
  3019. case FFEINFO_kindtypeLOGICAL1:
  3020. error = ffetarget_not_logical1 (ffebld_cu_ptr_logical1 (u),
  3021. ffebld_constant_logical1 (ffebld_conter (r)));
  3022. expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
  3023. (ffebld_cu_val_logical1 (u)), expr);
  3024. break;
  3025. #endif
  3026. #if FFETARGET_okLOGICAL2
  3027. case FFEINFO_kindtypeLOGICAL2:
  3028. error = ffetarget_not_logical2 (ffebld_cu_ptr_logical2 (u),
  3029. ffebld_constant_logical2 (ffebld_conter (r)));
  3030. expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
  3031. (ffebld_cu_val_logical2 (u)), expr);
  3032. break;
  3033. #endif
  3034. #if FFETARGET_okLOGICAL3
  3035. case FFEINFO_kindtypeLOGICAL3:
  3036. error = ffetarget_not_logical3 (ffebld_cu_ptr_logical3 (u),
  3037. ffebld_constant_logical3 (ffebld_conter (r)));
  3038. expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
  3039. (ffebld_cu_val_logical3 (u)), expr);
  3040. break;
  3041. #endif
  3042. #if FFETARGET_okLOGICAL4
  3043. case FFEINFO_kindtypeLOGICAL4:
  3044. error = ffetarget_not_logical4 (ffebld_cu_ptr_logical4 (u),
  3045. ffebld_constant_logical4 (ffebld_conter (r)));
  3046. expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
  3047. (ffebld_cu_val_logical4 (u)), expr);
  3048. break;
  3049. #endif
  3050. default:
  3051. assert ("bad logical kind type" == NULL);
  3052. break;
  3053. }
  3054. break;
  3055. default:
  3056. assert ("bad type" == NULL);
  3057. return expr;
  3058. }
  3059. ffebld_set_info (expr, ffeinfo_new
  3060. (bt,
  3061. kt,
  3062. 0,
  3063. FFEINFO_kindENTITY,
  3064. FFEINFO_whereCONSTANT,
  3065. FFETARGET_charactersizeNONE));
  3066. if ((error != FFEBAD)
  3067. && ffebad_start (error))
  3068. {
  3069. ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  3070. ffebad_finish ();
  3071. }
  3072. return expr;
  3073. }
  3074. /* ffeexpr_collapse_add -- Collapse add expr
  3075. ffebld expr;
  3076. ffelexToken token;
  3077. expr = ffeexpr_collapse_add(expr,token);
  3078. If the result of the expr is a constant, replaces the expr with the
  3079. computed constant. */
  3080. ffebld
  3081. ffeexpr_collapse_add (ffebld expr, ffelexToken t)
  3082. {
  3083. ffebad error = FFEBAD;
  3084. ffebld l;
  3085. ffebld r;
  3086. ffebldConstantUnion u;
  3087. ffeinfoBasictype bt;
  3088. ffeinfoKindtype kt;
  3089. if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  3090. return expr;
  3091. l = ffebld_left (expr);
  3092. r = ffebld_right (expr);
  3093. if (ffebld_op (l) != FFEBLD_opCONTER)
  3094. return expr;
  3095. if (ffebld_op (r) != FFEBLD_opCONTER)
  3096. return expr;
  3097. switch (bt = ffeinfo_basictype (ffebld_info (expr)))
  3098. {
  3099. case FFEINFO_basictypeANY:
  3100. return expr;
  3101. case FFEINFO_basictypeINTEGER:
  3102. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3103. {
  3104. #if FFETARGET_okINTEGER1
  3105. case FFEINFO_kindtypeINTEGER1:
  3106. error = ffetarget_add_integer1 (ffebld_cu_ptr_integer1 (u),
  3107. ffebld_constant_integer1 (ffebld_conter (l)),
  3108. ffebld_constant_integer1 (ffebld_conter (r)));
  3109. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
  3110. (ffebld_cu_val_integer1 (u)), expr);
  3111. break;
  3112. #endif
  3113. #if FFETARGET_okINTEGER2
  3114. case FFEINFO_kindtypeINTEGER2:
  3115. error = ffetarget_add_integer2 (ffebld_cu_ptr_integer2 (u),
  3116. ffebld_constant_integer2 (ffebld_conter (l)),
  3117. ffebld_constant_integer2 (ffebld_conter (r)));
  3118. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
  3119. (ffebld_cu_val_integer2 (u)), expr);
  3120. break;
  3121. #endif
  3122. #if FFETARGET_okINTEGER3
  3123. case FFEINFO_kindtypeINTEGER3:
  3124. error = ffetarget_add_integer3 (ffebld_cu_ptr_integer3 (u),
  3125. ffebld_constant_integer3 (ffebld_conter (l)),
  3126. ffebld_constant_integer3 (ffebld_conter (r)));
  3127. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
  3128. (ffebld_cu_val_integer3 (u)), expr);
  3129. break;
  3130. #endif
  3131. #if FFETARGET_okINTEGER4
  3132. case FFEINFO_kindtypeINTEGER4:
  3133. error = ffetarget_add_integer4 (ffebld_cu_ptr_integer4 (u),
  3134. ffebld_constant_integer4 (ffebld_conter (l)),
  3135. ffebld_constant_integer4 (ffebld_conter (r)));
  3136. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
  3137. (ffebld_cu_val_integer4 (u)), expr);
  3138. break;
  3139. #endif
  3140. default:
  3141. assert ("bad integer kind type" == NULL);
  3142. break;
  3143. }
  3144. break;
  3145. case FFEINFO_basictypeREAL:
  3146. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3147. {
  3148. #if FFETARGET_okREAL1
  3149. case FFEINFO_kindtypeREAL1:
  3150. error = ffetarget_add_real1 (ffebld_cu_ptr_real1 (u),
  3151. ffebld_constant_real1 (ffebld_conter (l)),
  3152. ffebld_constant_real1 (ffebld_conter (r)));
  3153. expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
  3154. (ffebld_cu_val_real1 (u)), expr);
  3155. break;
  3156. #endif
  3157. #if FFETARGET_okREAL2
  3158. case FFEINFO_kindtypeREAL2:
  3159. error = ffetarget_add_real2 (ffebld_cu_ptr_real2 (u),
  3160. ffebld_constant_real2 (ffebld_conter (l)),
  3161. ffebld_constant_real2 (ffebld_conter (r)));
  3162. expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
  3163. (ffebld_cu_val_real2 (u)), expr);
  3164. break;
  3165. #endif
  3166. #if FFETARGET_okREAL3
  3167. case FFEINFO_kindtypeREAL3:
  3168. error = ffetarget_add_real3 (ffebld_cu_ptr_real3 (u),
  3169. ffebld_constant_real3 (ffebld_conter (l)),
  3170. ffebld_constant_real3 (ffebld_conter (r)));
  3171. expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
  3172. (ffebld_cu_val_real3 (u)), expr);
  3173. break;
  3174. #endif
  3175. #if FFETARGET_okREAL4
  3176. case FFEINFO_kindtypeREAL4:
  3177. error = ffetarget_add_real4 (ffebld_cu_ptr_real4 (u),
  3178. ffebld_constant_real4 (ffebld_conter (l)),
  3179. ffebld_constant_real4 (ffebld_conter (r)));
  3180. expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
  3181. (ffebld_cu_val_real4 (u)), expr);
  3182. break;
  3183. #endif
  3184. default:
  3185. assert ("bad real kind type" == NULL);
  3186. break;
  3187. }
  3188. break;
  3189. case FFEINFO_basictypeCOMPLEX:
  3190. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3191. {
  3192. #if FFETARGET_okCOMPLEX1
  3193. case FFEINFO_kindtypeREAL1:
  3194. error = ffetarget_add_complex1 (ffebld_cu_ptr_complex1 (u),
  3195. ffebld_constant_complex1 (ffebld_conter (l)),
  3196. ffebld_constant_complex1 (ffebld_conter (r)));
  3197. expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
  3198. (ffebld_cu_val_complex1 (u)), expr);
  3199. break;
  3200. #endif
  3201. #if FFETARGET_okCOMPLEX2
  3202. case FFEINFO_kindtypeREAL2:
  3203. error = ffetarget_add_complex2 (ffebld_cu_ptr_complex2 (u),
  3204. ffebld_constant_complex2 (ffebld_conter (l)),
  3205. ffebld_constant_complex2 (ffebld_conter (r)));
  3206. expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
  3207. (ffebld_cu_val_complex2 (u)), expr);
  3208. break;
  3209. #endif
  3210. #if FFETARGET_okCOMPLEX3
  3211. case FFEINFO_kindtypeREAL3:
  3212. error = ffetarget_add_complex3 (ffebld_cu_ptr_complex3 (u),
  3213. ffebld_constant_complex3 (ffebld_conter (l)),
  3214. ffebld_constant_complex3 (ffebld_conter (r)));
  3215. expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
  3216. (ffebld_cu_val_complex3 (u)), expr);
  3217. break;
  3218. #endif
  3219. #if FFETARGET_okCOMPLEX4
  3220. case FFEINFO_kindtypeREAL4:
  3221. error = ffetarget_add_complex4 (ffebld_cu_ptr_complex4 (u),
  3222. ffebld_constant_complex4 (ffebld_conter (l)),
  3223. ffebld_constant_complex4 (ffebld_conter (r)));
  3224. expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
  3225. (ffebld_cu_val_complex4 (u)), expr);
  3226. break;
  3227. #endif
  3228. default:
  3229. assert ("bad complex kind type" == NULL);
  3230. break;
  3231. }
  3232. break;
  3233. default:
  3234. assert ("bad type" == NULL);
  3235. return expr;
  3236. }
  3237. ffebld_set_info (expr, ffeinfo_new
  3238. (bt,
  3239. kt,
  3240. 0,
  3241. FFEINFO_kindENTITY,
  3242. FFEINFO_whereCONSTANT,
  3243. FFETARGET_charactersizeNONE));
  3244. if ((error != FFEBAD)
  3245. && ffebad_start (error))
  3246. {
  3247. ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  3248. ffebad_finish ();
  3249. }
  3250. return expr;
  3251. }
  3252. /* ffeexpr_collapse_subtract -- Collapse subtract expr
  3253. ffebld expr;
  3254. ffelexToken token;
  3255. expr = ffeexpr_collapse_subtract(expr,token);
  3256. If the result of the expr is a constant, replaces the expr with the
  3257. computed constant. */
  3258. ffebld
  3259. ffeexpr_collapse_subtract (ffebld expr, ffelexToken t)
  3260. {
  3261. ffebad error = FFEBAD;
  3262. ffebld l;
  3263. ffebld r;
  3264. ffebldConstantUnion u;
  3265. ffeinfoBasictype bt;
  3266. ffeinfoKindtype kt;
  3267. if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  3268. return expr;
  3269. l = ffebld_left (expr);
  3270. r = ffebld_right (expr);
  3271. if (ffebld_op (l) != FFEBLD_opCONTER)
  3272. return expr;
  3273. if (ffebld_op (r) != FFEBLD_opCONTER)
  3274. return expr;
  3275. switch (bt = ffeinfo_basictype (ffebld_info (expr)))
  3276. {
  3277. case FFEINFO_basictypeANY:
  3278. return expr;
  3279. case FFEINFO_basictypeINTEGER:
  3280. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3281. {
  3282. #if FFETARGET_okINTEGER1
  3283. case FFEINFO_kindtypeINTEGER1:
  3284. error = ffetarget_subtract_integer1 (ffebld_cu_ptr_integer1 (u),
  3285. ffebld_constant_integer1 (ffebld_conter (l)),
  3286. ffebld_constant_integer1 (ffebld_conter (r)));
  3287. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
  3288. (ffebld_cu_val_integer1 (u)), expr);
  3289. break;
  3290. #endif
  3291. #if FFETARGET_okINTEGER2
  3292. case FFEINFO_kindtypeINTEGER2:
  3293. error = ffetarget_subtract_integer2 (ffebld_cu_ptr_integer2 (u),
  3294. ffebld_constant_integer2 (ffebld_conter (l)),
  3295. ffebld_constant_integer2 (ffebld_conter (r)));
  3296. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
  3297. (ffebld_cu_val_integer2 (u)), expr);
  3298. break;
  3299. #endif
  3300. #if FFETARGET_okINTEGER3
  3301. case FFEINFO_kindtypeINTEGER3:
  3302. error = ffetarget_subtract_integer3 (ffebld_cu_ptr_integer3 (u),
  3303. ffebld_constant_integer3 (ffebld_conter (l)),
  3304. ffebld_constant_integer3 (ffebld_conter (r)));
  3305. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
  3306. (ffebld_cu_val_integer3 (u)), expr);
  3307. break;
  3308. #endif
  3309. #if FFETARGET_okINTEGER4
  3310. case FFEINFO_kindtypeINTEGER4:
  3311. error = ffetarget_subtract_integer4 (ffebld_cu_ptr_integer4 (u),
  3312. ffebld_constant_integer4 (ffebld_conter (l)),
  3313. ffebld_constant_integer4 (ffebld_conter (r)));
  3314. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
  3315. (ffebld_cu_val_integer4 (u)), expr);
  3316. break;
  3317. #endif
  3318. default:
  3319. assert ("bad integer kind type" == NULL);
  3320. break;
  3321. }
  3322. break;
  3323. case FFEINFO_basictypeREAL:
  3324. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3325. {
  3326. #if FFETARGET_okREAL1
  3327. case FFEINFO_kindtypeREAL1:
  3328. error = ffetarget_subtract_real1 (ffebld_cu_ptr_real1 (u),
  3329. ffebld_constant_real1 (ffebld_conter (l)),
  3330. ffebld_constant_real1 (ffebld_conter (r)));
  3331. expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
  3332. (ffebld_cu_val_real1 (u)), expr);
  3333. break;
  3334. #endif
  3335. #if FFETARGET_okREAL2
  3336. case FFEINFO_kindtypeREAL2:
  3337. error = ffetarget_subtract_real2 (ffebld_cu_ptr_real2 (u),
  3338. ffebld_constant_real2 (ffebld_conter (l)),
  3339. ffebld_constant_real2 (ffebld_conter (r)));
  3340. expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
  3341. (ffebld_cu_val_real2 (u)), expr);
  3342. break;
  3343. #endif
  3344. #if FFETARGET_okREAL3
  3345. case FFEINFO_kindtypeREAL3:
  3346. error = ffetarget_subtract_real3 (ffebld_cu_ptr_real3 (u),
  3347. ffebld_constant_real3 (ffebld_conter (l)),
  3348. ffebld_constant_real3 (ffebld_conter (r)));
  3349. expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
  3350. (ffebld_cu_val_real3 (u)), expr);
  3351. break;
  3352. #endif
  3353. #if FFETARGET_okREAL4
  3354. case FFEINFO_kindtypeREAL4:
  3355. error = ffetarget_subtract_real4 (ffebld_cu_ptr_real4 (u),
  3356. ffebld_constant_real4 (ffebld_conter (l)),
  3357. ffebld_constant_real4 (ffebld_conter (r)));
  3358. expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
  3359. (ffebld_cu_val_real4 (u)), expr);
  3360. break;
  3361. #endif
  3362. default:
  3363. assert ("bad real kind type" == NULL);
  3364. break;
  3365. }
  3366. break;
  3367. case FFEINFO_basictypeCOMPLEX:
  3368. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3369. {
  3370. #if FFETARGET_okCOMPLEX1
  3371. case FFEINFO_kindtypeREAL1:
  3372. error = ffetarget_subtract_complex1 (ffebld_cu_ptr_complex1 (u),
  3373. ffebld_constant_complex1 (ffebld_conter (l)),
  3374. ffebld_constant_complex1 (ffebld_conter (r)));
  3375. expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
  3376. (ffebld_cu_val_complex1 (u)), expr);
  3377. break;
  3378. #endif
  3379. #if FFETARGET_okCOMPLEX2
  3380. case FFEINFO_kindtypeREAL2:
  3381. error = ffetarget_subtract_complex2 (ffebld_cu_ptr_complex2 (u),
  3382. ffebld_constant_complex2 (ffebld_conter (l)),
  3383. ffebld_constant_complex2 (ffebld_conter (r)));
  3384. expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
  3385. (ffebld_cu_val_complex2 (u)), expr);
  3386. break;
  3387. #endif
  3388. #if FFETARGET_okCOMPLEX3
  3389. case FFEINFO_kindtypeREAL3:
  3390. error = ffetarget_subtract_complex3 (ffebld_cu_ptr_complex3 (u),
  3391. ffebld_constant_complex3 (ffebld_conter (l)),
  3392. ffebld_constant_complex3 (ffebld_conter (r)));
  3393. expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
  3394. (ffebld_cu_val_complex3 (u)), expr);
  3395. break;
  3396. #endif
  3397. #if FFETARGET_okCOMPLEX4
  3398. case FFEINFO_kindtypeREAL4:
  3399. error = ffetarget_subtract_complex4 (ffebld_cu_ptr_complex4 (u),
  3400. ffebld_constant_complex4 (ffebld_conter (l)),
  3401. ffebld_constant_complex4 (ffebld_conter (r)));
  3402. expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
  3403. (ffebld_cu_val_complex4 (u)), expr);
  3404. break;
  3405. #endif
  3406. default:
  3407. assert ("bad complex kind type" == NULL);
  3408. break;
  3409. }
  3410. break;
  3411. default:
  3412. assert ("bad type" == NULL);
  3413. return expr;
  3414. }
  3415. ffebld_set_info (expr, ffeinfo_new
  3416. (bt,
  3417. kt,
  3418. 0,
  3419. FFEINFO_kindENTITY,
  3420. FFEINFO_whereCONSTANT,
  3421. FFETARGET_charactersizeNONE));
  3422. if ((error != FFEBAD)
  3423. && ffebad_start (error))
  3424. {
  3425. ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  3426. ffebad_finish ();
  3427. }
  3428. return expr;
  3429. }
  3430. /* ffeexpr_collapse_multiply -- Collapse multiply expr
  3431. ffebld expr;
  3432. ffelexToken token;
  3433. expr = ffeexpr_collapse_multiply(expr,token);
  3434. If the result of the expr is a constant, replaces the expr with the
  3435. computed constant. */
  3436. ffebld
  3437. ffeexpr_collapse_multiply (ffebld expr, ffelexToken t)
  3438. {
  3439. ffebad error = FFEBAD;
  3440. ffebld l;
  3441. ffebld r;
  3442. ffebldConstantUnion u;
  3443. ffeinfoBasictype bt;
  3444. ffeinfoKindtype kt;
  3445. if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  3446. return expr;
  3447. l = ffebld_left (expr);
  3448. r = ffebld_right (expr);
  3449. if (ffebld_op (l) != FFEBLD_opCONTER)
  3450. return expr;
  3451. if (ffebld_op (r) != FFEBLD_opCONTER)
  3452. return expr;
  3453. switch (bt = ffeinfo_basictype (ffebld_info (expr)))
  3454. {
  3455. case FFEINFO_basictypeANY:
  3456. return expr;
  3457. case FFEINFO_basictypeINTEGER:
  3458. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3459. {
  3460. #if FFETARGET_okINTEGER1
  3461. case FFEINFO_kindtypeINTEGER1:
  3462. error = ffetarget_multiply_integer1 (ffebld_cu_ptr_integer1 (u),
  3463. ffebld_constant_integer1 (ffebld_conter (l)),
  3464. ffebld_constant_integer1 (ffebld_conter (r)));
  3465. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
  3466. (ffebld_cu_val_integer1 (u)), expr);
  3467. break;
  3468. #endif
  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);
  3476. break;
  3477. #endif
  3478. #if FFETARGET_okINTEGER3
  3479. case FFEINFO_kindtypeINTEGER3:
  3480. error = ffetarget_multiply_integer3 (ffebld_cu_ptr_integer3 (u),
  3481. ffebld_constant_integer3 (ffebld_conter (l)),
  3482. ffebld_constant_integer3 (ffebld_conter (r)));
  3483. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
  3484. (ffebld_cu_val_integer3 (u)), expr);
  3485. break;
  3486. #endif
  3487. #if FFETARGET_okINTEGER4
  3488. case FFEINFO_kindtypeINTEGER4:
  3489. error = ffetarget_multiply_integer4 (ffebld_cu_ptr_integer4 (u),
  3490. ffebld_constant_integer4 (ffebld_conter (l)),
  3491. ffebld_constant_integer4 (ffebld_conter (r)));
  3492. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
  3493. (ffebld_cu_val_integer4 (u)), expr);
  3494. break;
  3495. #endif
  3496. default:
  3497. assert ("bad integer kind type" == NULL);
  3498. break;
  3499. }
  3500. break;
  3501. case FFEINFO_basictypeREAL:
  3502. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3503. {
  3504. #if FFETARGET_okREAL1
  3505. case FFEINFO_kindtypeREAL1:
  3506. error = ffetarget_multiply_real1 (ffebld_cu_ptr_real1 (u),
  3507. ffebld_constant_real1 (ffebld_conter (l)),
  3508. ffebld_constant_real1 (ffebld_conter (r)));
  3509. expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
  3510. (ffebld_cu_val_real1 (u)), expr);
  3511. break;
  3512. #endif
  3513. #if FFETARGET_okREAL2
  3514. case FFEINFO_kindtypeREAL2:
  3515. error = ffetarget_multiply_real2 (ffebld_cu_ptr_real2 (u),
  3516. ffebld_constant_real2 (ffebld_conter (l)),
  3517. ffebld_constant_real2 (ffebld_conter (r)));
  3518. expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
  3519. (ffebld_cu_val_real2 (u)), expr);
  3520. break;
  3521. #endif
  3522. #if FFETARGET_okREAL3
  3523. case FFEINFO_kindtypeREAL3:
  3524. error = ffetarget_multiply_real3 (ffebld_cu_ptr_real3 (u),
  3525. ffebld_constant_real3 (ffebld_conter (l)),
  3526. ffebld_constant_real3 (ffebld_conter (r)));
  3527. expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
  3528. (ffebld_cu_val_real3 (u)), expr);
  3529. break;
  3530. #endif
  3531. #if FFETARGET_okREAL4
  3532. case FFEINFO_kindtypeREAL4:
  3533. error = ffetarget_multiply_real4 (ffebld_cu_ptr_real4 (u),
  3534. ffebld_constant_real4 (ffebld_conter (l)),
  3535. ffebld_constant_real4 (ffebld_conter (r)));
  3536. expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
  3537. (ffebld_cu_val_real4 (u)), expr);
  3538. break;
  3539. #endif
  3540. default:
  3541. assert ("bad real kind type" == NULL);
  3542. break;
  3543. }
  3544. break;
  3545. case FFEINFO_basictypeCOMPLEX:
  3546. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3547. {
  3548. #if FFETARGET_okCOMPLEX1
  3549. case FFEINFO_kindtypeREAL1:
  3550. error = ffetarget_multiply_complex1 (ffebld_cu_ptr_complex1 (u),
  3551. ffebld_constant_complex1 (ffebld_conter (l)),
  3552. ffebld_constant_complex1 (ffebld_conter (r)));
  3553. expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
  3554. (ffebld_cu_val_complex1 (u)), expr);
  3555. break;
  3556. #endif
  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);
  3564. break;
  3565. #endif
  3566. #if FFETARGET_okCOMPLEX3
  3567. case FFEINFO_kindtypeREAL3:
  3568. error = ffetarget_multiply_complex3 (ffebld_cu_ptr_complex3 (u),
  3569. ffebld_constant_complex3 (ffebld_conter (l)),
  3570. ffebld_constant_complex3 (ffebld_conter (r)));
  3571. expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
  3572. (ffebld_cu_val_complex3 (u)), expr);
  3573. break;
  3574. #endif
  3575. #if FFETARGET_okCOMPLEX4
  3576. case FFEINFO_kindtypeREAL4:
  3577. error = ffetarget_multiply_complex4 (ffebld_cu_ptr_complex4 (u),
  3578. ffebld_constant_complex4 (ffebld_conter (l)),
  3579. ffebld_constant_complex4 (ffebld_conter (r)));
  3580. expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
  3581. (ffebld_cu_val_complex4 (u)), expr);
  3582. break;
  3583. #endif
  3584. default:
  3585. assert ("bad complex kind type" == NULL);
  3586. break;
  3587. }
  3588. break;
  3589. default:
  3590. assert ("bad type" == NULL);
  3591. return expr;
  3592. }
  3593. ffebld_set_info (expr, ffeinfo_new
  3594. (bt,
  3595. kt,
  3596. 0,
  3597. FFEINFO_kindENTITY,
  3598. FFEINFO_whereCONSTANT,
  3599. FFETARGET_charactersizeNONE));
  3600. if ((error != FFEBAD)
  3601. && ffebad_start (error))
  3602. {
  3603. ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  3604. ffebad_finish ();
  3605. }
  3606. return expr;
  3607. }
  3608. /* ffeexpr_collapse_divide -- Collapse divide expr
  3609. ffebld expr;
  3610. ffelexToken token;
  3611. expr = ffeexpr_collapse_divide(expr,token);
  3612. If the result of the expr is a constant, replaces the expr with the
  3613. computed constant. */
  3614. ffebld
  3615. ffeexpr_collapse_divide (ffebld expr, ffelexToken t)
  3616. {
  3617. ffebad error = FFEBAD;
  3618. ffebld l;
  3619. ffebld r;
  3620. ffebldConstantUnion u;
  3621. ffeinfoBasictype bt;
  3622. ffeinfoKindtype kt;
  3623. if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  3624. return expr;
  3625. l = ffebld_left (expr);
  3626. r = ffebld_right (expr);
  3627. if (ffebld_op (l) != FFEBLD_opCONTER)
  3628. return expr;
  3629. if (ffebld_op (r) != FFEBLD_opCONTER)
  3630. return expr;
  3631. switch (bt = ffeinfo_basictype (ffebld_info (expr)))
  3632. {
  3633. case FFEINFO_basictypeANY:
  3634. return expr;
  3635. case FFEINFO_basictypeINTEGER:
  3636. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3637. {
  3638. #if FFETARGET_okINTEGER1
  3639. case FFEINFO_kindtypeINTEGER1:
  3640. error = ffetarget_divide_integer1 (ffebld_cu_ptr_integer1 (u),
  3641. ffebld_constant_integer1 (ffebld_conter (l)),
  3642. ffebld_constant_integer1 (ffebld_conter (r)));
  3643. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
  3644. (ffebld_cu_val_integer1 (u)), expr);
  3645. break;
  3646. #endif
  3647. #if FFETARGET_okINTEGER2
  3648. case FFEINFO_kindtypeINTEGER2:
  3649. error = ffetarget_divide_integer2 (ffebld_cu_ptr_integer2 (u),
  3650. ffebld_constant_integer2 (ffebld_conter (l)),
  3651. ffebld_constant_integer2 (ffebld_conter (r)));
  3652. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
  3653. (ffebld_cu_val_integer2 (u)), expr);
  3654. break;
  3655. #endif
  3656. #if FFETARGET_okINTEGER3
  3657. case FFEINFO_kindtypeINTEGER3:
  3658. error = ffetarget_divide_integer3 (ffebld_cu_ptr_integer3 (u),
  3659. ffebld_constant_integer3 (ffebld_conter (l)),
  3660. ffebld_constant_integer3 (ffebld_conter (r)));
  3661. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
  3662. (ffebld_cu_val_integer3 (u)), expr);
  3663. break;
  3664. #endif
  3665. #if FFETARGET_okINTEGER4
  3666. case FFEINFO_kindtypeINTEGER4:
  3667. error = ffetarget_divide_integer4 (ffebld_cu_ptr_integer4 (u),
  3668. ffebld_constant_integer4 (ffebld_conter (l)),
  3669. ffebld_constant_integer4 (ffebld_conter (r)));
  3670. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
  3671. (ffebld_cu_val_integer4 (u)), expr);
  3672. break;
  3673. #endif
  3674. default:
  3675. assert ("bad integer kind type" == NULL);
  3676. break;
  3677. }
  3678. break;
  3679. case FFEINFO_basictypeREAL:
  3680. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3681. {
  3682. #if FFETARGET_okREAL1
  3683. case FFEINFO_kindtypeREAL1:
  3684. error = ffetarget_divide_real1 (ffebld_cu_ptr_real1 (u),
  3685. ffebld_constant_real1 (ffebld_conter (l)),
  3686. ffebld_constant_real1 (ffebld_conter (r)));
  3687. expr = ffebld_new_conter_with_orig (ffebld_constant_new_real1_val
  3688. (ffebld_cu_val_real1 (u)), expr);
  3689. break;
  3690. #endif
  3691. #if FFETARGET_okREAL2
  3692. case FFEINFO_kindtypeREAL2:
  3693. error = ffetarget_divide_real2 (ffebld_cu_ptr_real2 (u),
  3694. ffebld_constant_real2 (ffebld_conter (l)),
  3695. ffebld_constant_real2 (ffebld_conter (r)));
  3696. expr = ffebld_new_conter_with_orig (ffebld_constant_new_real2_val
  3697. (ffebld_cu_val_real2 (u)), expr);
  3698. break;
  3699. #endif
  3700. #if FFETARGET_okREAL3
  3701. case FFEINFO_kindtypeREAL3:
  3702. error = ffetarget_divide_real3 (ffebld_cu_ptr_real3 (u),
  3703. ffebld_constant_real3 (ffebld_conter (l)),
  3704. ffebld_constant_real3 (ffebld_conter (r)));
  3705. expr = ffebld_new_conter_with_orig (ffebld_constant_new_real3_val
  3706. (ffebld_cu_val_real3 (u)), expr);
  3707. break;
  3708. #endif
  3709. #if FFETARGET_okREAL4
  3710. case FFEINFO_kindtypeREAL4:
  3711. error = ffetarget_divide_real4 (ffebld_cu_ptr_real4 (u),
  3712. ffebld_constant_real4 (ffebld_conter (l)),
  3713. ffebld_constant_real4 (ffebld_conter (r)));
  3714. expr = ffebld_new_conter_with_orig (ffebld_constant_new_real4_val
  3715. (ffebld_cu_val_real4 (u)), expr);
  3716. break;
  3717. #endif
  3718. default:
  3719. assert ("bad real kind type" == NULL);
  3720. break;
  3721. }
  3722. break;
  3723. case FFEINFO_basictypeCOMPLEX:
  3724. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3725. {
  3726. #if FFETARGET_okCOMPLEX1
  3727. case FFEINFO_kindtypeREAL1:
  3728. error = ffetarget_divide_complex1 (ffebld_cu_ptr_complex1 (u),
  3729. ffebld_constant_complex1 (ffebld_conter (l)),
  3730. ffebld_constant_complex1 (ffebld_conter (r)));
  3731. expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex1_val
  3732. (ffebld_cu_val_complex1 (u)), expr);
  3733. break;
  3734. #endif
  3735. #if FFETARGET_okCOMPLEX2
  3736. case FFEINFO_kindtypeREAL2:
  3737. error = ffetarget_divide_complex2 (ffebld_cu_ptr_complex2 (u),
  3738. ffebld_constant_complex2 (ffebld_conter (l)),
  3739. ffebld_constant_complex2 (ffebld_conter (r)));
  3740. expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex2_val
  3741. (ffebld_cu_val_complex2 (u)), expr);
  3742. break;
  3743. #endif
  3744. #if FFETARGET_okCOMPLEX3
  3745. case FFEINFO_kindtypeREAL3:
  3746. error = ffetarget_divide_complex3 (ffebld_cu_ptr_complex3 (u),
  3747. ffebld_constant_complex3 (ffebld_conter (l)),
  3748. ffebld_constant_complex3 (ffebld_conter (r)));
  3749. expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex3_val
  3750. (ffebld_cu_val_complex3 (u)), expr);
  3751. break;
  3752. #endif
  3753. #if FFETARGET_okCOMPLEX4
  3754. case FFEINFO_kindtypeREAL4:
  3755. error = ffetarget_divide_complex4 (ffebld_cu_ptr_complex4 (u),
  3756. ffebld_constant_complex4 (ffebld_conter (l)),
  3757. ffebld_constant_complex4 (ffebld_conter (r)));
  3758. expr = ffebld_new_conter_with_orig (ffebld_constant_new_complex4_val
  3759. (ffebld_cu_val_complex4 (u)), expr);
  3760. break;
  3761. #endif
  3762. default:
  3763. assert ("bad complex kind type" == NULL);
  3764. break;
  3765. }
  3766. break;
  3767. default:
  3768. assert ("bad type" == NULL);
  3769. return expr;
  3770. }
  3771. ffebld_set_info (expr, ffeinfo_new
  3772. (bt,
  3773. kt,
  3774. 0,
  3775. FFEINFO_kindENTITY,
  3776. FFEINFO_whereCONSTANT,
  3777. FFETARGET_charactersizeNONE));
  3778. if ((error != FFEBAD)
  3779. && ffebad_start (error))
  3780. {
  3781. ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  3782. ffebad_finish ();
  3783. }
  3784. return expr;
  3785. }
  3786. /* ffeexpr_collapse_power -- Collapse power expr
  3787. ffebld expr;
  3788. ffelexToken token;
  3789. expr = ffeexpr_collapse_power(expr,token);
  3790. If the result of the expr is a constant, replaces the expr with the
  3791. computed constant. */
  3792. ffebld
  3793. ffeexpr_collapse_power (ffebld expr, ffelexToken t)
  3794. {
  3795. ffebad error = FFEBAD;
  3796. ffebld l;
  3797. ffebld r;
  3798. ffebldConstantUnion u;
  3799. ffeinfoBasictype bt;
  3800. ffeinfoKindtype kt;
  3801. if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  3802. return expr;
  3803. l = ffebld_left (expr);
  3804. r = ffebld_right (expr);
  3805. if (ffebld_op (l) != FFEBLD_opCONTER)
  3806. return expr;
  3807. if (ffebld_op (r) != FFEBLD_opCONTER)
  3808. return expr;
  3809. if ((ffeinfo_basictype (ffebld_info (r)) != FFEINFO_basictypeINTEGER)
  3810. || (ffeinfo_kindtype (ffebld_info (r)) != FFEINFO_kindtypeINTEGERDEFAULT))
  3811. return expr;
  3812. switch (bt = ffeinfo_basictype (ffebld_info (expr)))
  3813. {
  3814. case FFEINFO_basictypeANY:
  3815. return expr;
  3816. case FFEINFO_basictypeINTEGER:
  3817. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3818. {
  3819. case FFEINFO_kindtypeINTEGERDEFAULT:
  3820. error = ffetarget_power_integerdefault_integerdefault
  3821. (ffebld_cu_ptr_integerdefault (u),
  3822. ffebld_constant_integerdefault (ffebld_conter (l)),
  3823. ffebld_constant_integerdefault (ffebld_conter (r)));
  3824. expr = ffebld_new_conter_with_orig
  3825. (ffebld_constant_new_integerdefault_val
  3826. (ffebld_cu_val_integerdefault (u)), expr);
  3827. break;
  3828. default:
  3829. assert ("bad integer kind type" == NULL);
  3830. break;
  3831. }
  3832. break;
  3833. case FFEINFO_basictypeREAL:
  3834. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3835. {
  3836. case FFEINFO_kindtypeREALDEFAULT:
  3837. error = ffetarget_power_realdefault_integerdefault
  3838. (ffebld_cu_ptr_realdefault (u),
  3839. ffebld_constant_realdefault (ffebld_conter (l)),
  3840. ffebld_constant_integerdefault (ffebld_conter (r)));
  3841. expr = ffebld_new_conter_with_orig
  3842. (ffebld_constant_new_realdefault_val
  3843. (ffebld_cu_val_realdefault (u)), expr);
  3844. break;
  3845. case FFEINFO_kindtypeREALDOUBLE:
  3846. error = ffetarget_power_realdouble_integerdefault
  3847. (ffebld_cu_ptr_realdouble (u),
  3848. ffebld_constant_realdouble (ffebld_conter (l)),
  3849. ffebld_constant_integerdefault (ffebld_conter (r)));
  3850. expr = ffebld_new_conter_with_orig
  3851. (ffebld_constant_new_realdouble_val
  3852. (ffebld_cu_val_realdouble (u)), expr);
  3853. break;
  3854. #if FFETARGET_okREALQUAD
  3855. case FFEINFO_kindtypeREALQUAD:
  3856. error = ffetarget_power_realquad_integerdefault
  3857. (ffebld_cu_ptr_realquad (u),
  3858. ffebld_constant_realquad (ffebld_conter (l)),
  3859. ffebld_constant_integerdefault (ffebld_conter (r)));
  3860. expr = ffebld_new_conter_with_orig
  3861. (ffebld_constant_new_realquad_val
  3862. (ffebld_cu_val_realquad (u)), expr);
  3863. break;
  3864. #endif
  3865. default:
  3866. assert ("bad real kind type" == NULL);
  3867. break;
  3868. }
  3869. break;
  3870. case FFEINFO_basictypeCOMPLEX:
  3871. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3872. {
  3873. case FFEINFO_kindtypeREALDEFAULT:
  3874. error = ffetarget_power_complexdefault_integerdefault
  3875. (ffebld_cu_ptr_complexdefault (u),
  3876. ffebld_constant_complexdefault (ffebld_conter (l)),
  3877. ffebld_constant_integerdefault (ffebld_conter (r)));
  3878. expr = ffebld_new_conter_with_orig
  3879. (ffebld_constant_new_complexdefault_val
  3880. (ffebld_cu_val_complexdefault (u)), expr);
  3881. break;
  3882. #if FFETARGET_okCOMPLEXDOUBLE
  3883. case FFEINFO_kindtypeREALDOUBLE:
  3884. error = ffetarget_power_complexdouble_integerdefault
  3885. (ffebld_cu_ptr_complexdouble (u),
  3886. ffebld_constant_complexdouble (ffebld_conter (l)),
  3887. ffebld_constant_integerdefault (ffebld_conter (r)));
  3888. expr = ffebld_new_conter_with_orig
  3889. (ffebld_constant_new_complexdouble_val
  3890. (ffebld_cu_val_complexdouble (u)), expr);
  3891. break;
  3892. #endif
  3893. #if FFETARGET_okCOMPLEXQUAD
  3894. case FFEINFO_kindtypeREALQUAD:
  3895. error = ffetarget_power_complexquad_integerdefault
  3896. (ffebld_cu_ptr_complexquad (u),
  3897. ffebld_constant_complexquad (ffebld_conter (l)),
  3898. ffebld_constant_integerdefault (ffebld_conter (r)));
  3899. expr = ffebld_new_conter_with_orig
  3900. (ffebld_constant_new_complexquad_val
  3901. (ffebld_cu_val_complexquad (u)), expr);
  3902. break;
  3903. #endif
  3904. default:
  3905. assert ("bad complex kind type" == NULL);
  3906. break;
  3907. }
  3908. break;
  3909. default:
  3910. assert ("bad type" == NULL);
  3911. return expr;
  3912. }
  3913. ffebld_set_info (expr, ffeinfo_new
  3914. (bt,
  3915. kt,
  3916. 0,
  3917. FFEINFO_kindENTITY,
  3918. FFEINFO_whereCONSTANT,
  3919. FFETARGET_charactersizeNONE));
  3920. if ((error != FFEBAD)
  3921. && ffebad_start (error))
  3922. {
  3923. ffebad_here (0, ffelex_token_where_line (t),
  3924. ffelex_token_where_column (t));
  3925. ffebad_finish ();
  3926. }
  3927. return expr;
  3928. }
  3929. /* ffeexpr_collapse_concatenate -- Collapse concatenate expr
  3930. ffebld expr;
  3931. ffelexToken token;
  3932. expr = ffeexpr_collapse_concatenate(expr,token);
  3933. If the result of the expr is a constant, replaces the expr with the
  3934. computed constant. */
  3935. ffebld
  3936. ffeexpr_collapse_concatenate (ffebld expr, ffelexToken t)
  3937. {
  3938. ffebad error = FFEBAD;
  3939. ffebld l;
  3940. ffebld r;
  3941. ffebldConstantUnion u;
  3942. ffeinfoKindtype kt;
  3943. ffetargetCharacterSize len;
  3944. if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  3945. return expr;
  3946. l = ffebld_left (expr);
  3947. r = ffebld_right (expr);
  3948. if (ffebld_op (l) != FFEBLD_opCONTER)
  3949. return expr;
  3950. if (ffebld_op (r) != FFEBLD_opCONTER)
  3951. return expr;
  3952. switch (ffeinfo_basictype (ffebld_info (expr)))
  3953. {
  3954. case FFEINFO_basictypeANY:
  3955. return expr;
  3956. case FFEINFO_basictypeCHARACTER:
  3957. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  3958. {
  3959. #if FFETARGET_okCHARACTER1
  3960. case FFEINFO_kindtypeCHARACTER1:
  3961. error = ffetarget_concatenate_character1 (ffebld_cu_ptr_character1 (u),
  3962. ffebld_constant_character1 (ffebld_conter (l)),
  3963. ffebld_constant_character1 (ffebld_conter (r)),
  3964. ffebld_constant_pool (), &len);
  3965. expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
  3966. (ffebld_cu_val_character1 (u)), expr);
  3967. break;
  3968. #endif
  3969. #if FFETARGET_okCHARACTER2
  3970. case FFEINFO_kindtypeCHARACTER2:
  3971. error = ffetarget_concatenate_character2 (ffebld_cu_ptr_character2 (u),
  3972. ffebld_constant_character2 (ffebld_conter (l)),
  3973. ffebld_constant_character2 (ffebld_conter (r)),
  3974. ffebld_constant_pool (), &len);
  3975. expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val
  3976. (ffebld_cu_val_character2 (u)), expr);
  3977. break;
  3978. #endif
  3979. #if FFETARGET_okCHARACTER3
  3980. case FFEINFO_kindtypeCHARACTER3:
  3981. error = ffetarget_concatenate_character3 (ffebld_cu_ptr_character3 (u),
  3982. ffebld_constant_character3 (ffebld_conter (l)),
  3983. ffebld_constant_character3 (ffebld_conter (r)),
  3984. ffebld_constant_pool (), &len);
  3985. expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val
  3986. (ffebld_cu_val_character3 (u)), expr);
  3987. break;
  3988. #endif
  3989. #if FFETARGET_okCHARACTER4
  3990. case FFEINFO_kindtypeCHARACTER4:
  3991. error = ffetarget_concatenate_character4 (ffebld_cu_ptr_character4 (u),
  3992. ffebld_constant_character4 (ffebld_conter (l)),
  3993. ffebld_constant_character4 (ffebld_conter (r)),
  3994. ffebld_constant_pool (), &len);
  3995. expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val
  3996. (ffebld_cu_val_character4 (u)), expr);
  3997. break;
  3998. #endif
  3999. default:
  4000. assert ("bad character kind type" == NULL);
  4001. break;
  4002. }
  4003. break;
  4004. default:
  4005. assert ("bad type" == NULL);
  4006. return expr;
  4007. }
  4008. ffebld_set_info (expr, ffeinfo_new
  4009. (FFEINFO_basictypeCHARACTER,
  4010. kt,
  4011. 0,
  4012. FFEINFO_kindENTITY,
  4013. FFEINFO_whereCONSTANT,
  4014. len));
  4015. if ((error != FFEBAD)
  4016. && ffebad_start (error))
  4017. {
  4018. ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  4019. ffebad_finish ();
  4020. }
  4021. return expr;
  4022. }
  4023. /* ffeexpr_collapse_eq -- Collapse eq expr
  4024. ffebld expr;
  4025. ffelexToken token;
  4026. expr = ffeexpr_collapse_eq(expr,token);
  4027. If the result of the expr is a constant, replaces the expr with the
  4028. computed constant. */
  4029. ffebld
  4030. ffeexpr_collapse_eq (ffebld expr, ffelexToken t)
  4031. {
  4032. ffebad error = FFEBAD;
  4033. ffebld l;
  4034. ffebld r;
  4035. bool val;
  4036. if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  4037. return expr;
  4038. l = ffebld_left (expr);
  4039. r = ffebld_right (expr);
  4040. if (ffebld_op (l) != FFEBLD_opCONTER)
  4041. return expr;
  4042. if (ffebld_op (r) != FFEBLD_opCONTER)
  4043. return expr;
  4044. switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
  4045. {
  4046. case FFEINFO_basictypeANY:
  4047. return expr;
  4048. case FFEINFO_basictypeINTEGER:
  4049. switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  4050. {
  4051. #if FFETARGET_okINTEGER1
  4052. case FFEINFO_kindtypeINTEGER1:
  4053. error = ffetarget_eq_integer1 (&val,
  4054. ffebld_constant_integer1 (ffebld_conter (l)),
  4055. ffebld_constant_integer1 (ffebld_conter (r)));
  4056. expr = ffebld_new_conter_with_orig
  4057. (ffebld_constant_new_logicaldefault (val), expr);
  4058. break;
  4059. #endif
  4060. #if FFETARGET_okINTEGER2
  4061. case FFEINFO_kindtypeINTEGER2:
  4062. error = ffetarget_eq_integer2 (&val,
  4063. ffebld_constant_integer2 (ffebld_conter (l)),
  4064. ffebld_constant_integer2 (ffebld_conter (r)));
  4065. expr = ffebld_new_conter_with_orig
  4066. (ffebld_constant_new_logicaldefault (val), expr);
  4067. break;
  4068. #endif
  4069. #if FFETARGET_okINTEGER3
  4070. case FFEINFO_kindtypeINTEGER3:
  4071. error = ffetarget_eq_integer3 (&val,
  4072. ffebld_constant_integer3 (ffebld_conter (l)),
  4073. ffebld_constant_integer3 (ffebld_conter (r)));
  4074. expr = ffebld_new_conter_with_orig
  4075. (ffebld_constant_new_logicaldefault (val), expr);
  4076. break;
  4077. #endif
  4078. #if FFETARGET_okINTEGER4
  4079. case FFEINFO_kindtypeINTEGER4:
  4080. error = ffetarget_eq_integer4 (&val,
  4081. ffebld_constant_integer4 (ffebld_conter (l)),
  4082. ffebld_constant_integer4 (ffebld_conter (r)));
  4083. expr = ffebld_new_conter_with_orig
  4084. (ffebld_constant_new_logicaldefault (val), expr);
  4085. break;
  4086. #endif
  4087. default:
  4088. assert ("bad integer kind type" == NULL);
  4089. break;
  4090. }
  4091. break;
  4092. case FFEINFO_basictypeREAL:
  4093. switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  4094. {
  4095. #if FFETARGET_okREAL1
  4096. case FFEINFO_kindtypeREAL1:
  4097. error = ffetarget_eq_real1 (&val,
  4098. ffebld_constant_real1 (ffebld_conter (l)),
  4099. ffebld_constant_real1 (ffebld_conter (r)));
  4100. expr = ffebld_new_conter_with_orig
  4101. (ffebld_constant_new_logicaldefault (val), expr);
  4102. break;
  4103. #endif
  4104. #if FFETARGET_okREAL2
  4105. case FFEINFO_kindtypeREAL2:
  4106. error = ffetarget_eq_real2 (&val,
  4107. ffebld_constant_real2 (ffebld_conter (l)),
  4108. ffebld_constant_real2 (ffebld_conter (r)));
  4109. expr = ffebld_new_conter_with_orig
  4110. (ffebld_constant_new_logicaldefault (val), expr);
  4111. break;
  4112. #endif
  4113. #if FFETARGET_okREAL3
  4114. case FFEINFO_kindtypeREAL3:
  4115. error = ffetarget_eq_real3 (&val,
  4116. ffebld_constant_real3 (ffebld_conter (l)),
  4117. ffebld_constant_real3 (ffebld_conter (r)));
  4118. expr = ffebld_new_conter_with_orig
  4119. (ffebld_constant_new_logicaldefault (val), expr);
  4120. break;
  4121. #endif
  4122. #if FFETARGET_okREAL4
  4123. case FFEINFO_kindtypeREAL4:
  4124. error = ffetarget_eq_real4 (&val,
  4125. ffebld_constant_real4 (ffebld_conter (l)),
  4126. ffebld_constant_real4 (ffebld_conter (r)));
  4127. expr = ffebld_new_conter_with_orig
  4128. (ffebld_constant_new_logicaldefault (val), expr);
  4129. break;
  4130. #endif
  4131. default:
  4132. assert ("bad real kind type" == NULL);
  4133. break;
  4134. }
  4135. break;
  4136. case FFEINFO_basictypeCOMPLEX:
  4137. switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  4138. {
  4139. #if FFETARGET_okCOMPLEX1
  4140. case FFEINFO_kindtypeREAL1:
  4141. error = ffetarget_eq_complex1 (&val,
  4142. ffebld_constant_complex1 (ffebld_conter (l)),
  4143. ffebld_constant_complex1 (ffebld_conter (r)));
  4144. expr = ffebld_new_conter_with_orig
  4145. (ffebld_constant_new_logicaldefault (val), expr);
  4146. break;
  4147. #endif
  4148. #if FFETARGET_okCOMPLEX2
  4149. case FFEINFO_kindtypeREAL2:
  4150. error = ffetarget_eq_complex2 (&val,
  4151. ffebld_constant_complex2 (ffebld_conter (l)),
  4152. ffebld_constant_complex2 (ffebld_conter (r)));
  4153. expr = ffebld_new_conter_with_orig
  4154. (ffebld_constant_new_logicaldefault (val), expr);
  4155. break;
  4156. #endif
  4157. #if FFETARGET_okCOMPLEX3
  4158. case FFEINFO_kindtypeREAL3:
  4159. error = ffetarget_eq_complex3 (&val,
  4160. ffebld_constant_complex3 (ffebld_conter (l)),
  4161. ffebld_constant_complex3 (ffebld_conter (r)));
  4162. expr = ffebld_new_conter_with_orig
  4163. (ffebld_constant_new_logicaldefault (val), expr);
  4164. break;
  4165. #endif
  4166. #if FFETARGET_okCOMPLEX4
  4167. case FFEINFO_kindtypeREAL4:
  4168. error = ffetarget_eq_complex4 (&val,
  4169. ffebld_constant_complex4 (ffebld_conter (l)),
  4170. ffebld_constant_complex4 (ffebld_conter (r)));
  4171. expr = ffebld_new_conter_with_orig
  4172. (ffebld_constant_new_logicaldefault (val), expr);
  4173. break;
  4174. #endif
  4175. default:
  4176. assert ("bad complex kind type" == NULL);
  4177. break;
  4178. }
  4179. break;
  4180. case FFEINFO_basictypeCHARACTER:
  4181. switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  4182. {
  4183. #if FFETARGET_okCHARACTER1
  4184. case FFEINFO_kindtypeCHARACTER1:
  4185. error = ffetarget_eq_character1 (&val,
  4186. ffebld_constant_character1 (ffebld_conter (l)),
  4187. ffebld_constant_character1 (ffebld_conter (r)));
  4188. expr = ffebld_new_conter_with_orig
  4189. (ffebld_constant_new_logicaldefault (val), expr);
  4190. break;
  4191. #endif
  4192. #if FFETARGET_okCHARACTER2
  4193. case FFEINFO_kindtypeCHARACTER2:
  4194. error = ffetarget_eq_character2 (&val,
  4195. ffebld_constant_character2 (ffebld_conter (l)),
  4196. ffebld_constant_character2 (ffebld_conter (r)));
  4197. expr = ffebld_new_conter_with_orig
  4198. (ffebld_constant_new_logicaldefault (val), expr);
  4199. break;
  4200. #endif
  4201. #if FFETARGET_okCHARACTER3
  4202. case FFEINFO_kindtypeCHARACTER3:
  4203. error = ffetarget_eq_character3 (&val,
  4204. ffebld_constant_character3 (ffebld_conter (l)),
  4205. ffebld_constant_character3 (ffebld_conter (r)));
  4206. expr = ffebld_new_conter_with_orig
  4207. (ffebld_constant_new_logicaldefault (val), expr);
  4208. break;
  4209. #endif
  4210. #if FFETARGET_okCHARACTER4
  4211. case FFEINFO_kindtypeCHARACTER4:
  4212. error = ffetarget_eq_character4 (&val,
  4213. ffebld_constant_character4 (ffebld_conter (l)),
  4214. ffebld_constant_character4 (ffebld_conter (r)));
  4215. expr = ffebld_new_conter_with_orig
  4216. (ffebld_constant_new_logicaldefault (val), expr);
  4217. break;
  4218. #endif
  4219. default:
  4220. assert ("bad character kind type" == NULL);
  4221. break;
  4222. }
  4223. break;
  4224. default:
  4225. assert ("bad type" == NULL);
  4226. return expr;
  4227. }
  4228. ffebld_set_info (expr, ffeinfo_new
  4229. (FFEINFO_basictypeLOGICAL,
  4230. FFEINFO_kindtypeLOGICALDEFAULT,
  4231. 0,
  4232. FFEINFO_kindENTITY,
  4233. FFEINFO_whereCONSTANT,
  4234. FFETARGET_charactersizeNONE));
  4235. if ((error != FFEBAD)
  4236. && ffebad_start (error))
  4237. {
  4238. ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  4239. ffebad_finish ();
  4240. }
  4241. return expr;
  4242. }
  4243. /* ffeexpr_collapse_ne -- Collapse ne expr
  4244. ffebld expr;
  4245. ffelexToken token;
  4246. expr = ffeexpr_collapse_ne(expr,token);
  4247. If the result of the expr is a constant, replaces the expr with the
  4248. computed constant. */
  4249. ffebld
  4250. ffeexpr_collapse_ne (ffebld expr, ffelexToken t)
  4251. {
  4252. ffebad error = FFEBAD;
  4253. ffebld l;
  4254. ffebld r;
  4255. bool val;
  4256. if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  4257. return expr;
  4258. l = ffebld_left (expr);
  4259. r = ffebld_right (expr);
  4260. if (ffebld_op (l) != FFEBLD_opCONTER)
  4261. return expr;
  4262. if (ffebld_op (r) != FFEBLD_opCONTER)
  4263. return expr;
  4264. switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
  4265. {
  4266. case FFEINFO_basictypeANY:
  4267. return expr;
  4268. case FFEINFO_basictypeINTEGER:
  4269. switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  4270. {
  4271. #if FFETARGET_okINTEGER1
  4272. case FFEINFO_kindtypeINTEGER1:
  4273. error = ffetarget_ne_integer1 (&val,
  4274. ffebld_constant_integer1 (ffebld_conter (l)),
  4275. ffebld_constant_integer1 (ffebld_conter (r)));
  4276. expr = ffebld_new_conter_with_orig
  4277. (ffebld_constant_new_logicaldefault (val), expr);
  4278. break;
  4279. #endif
  4280. #if FFETARGET_okINTEGER2
  4281. case FFEINFO_kindtypeINTEGER2:
  4282. error = ffetarget_ne_integer2 (&val,
  4283. ffebld_constant_integer2 (ffebld_conter (l)),
  4284. ffebld_constant_integer2 (ffebld_conter (r)));
  4285. expr = ffebld_new_conter_with_orig
  4286. (ffebld_constant_new_logicaldefault (val), expr);
  4287. break;
  4288. #endif
  4289. #if FFETARGET_okINTEGER3
  4290. case FFEINFO_kindtypeINTEGER3:
  4291. error = ffetarget_ne_integer3 (&val,
  4292. ffebld_constant_integer3 (ffebld_conter (l)),
  4293. ffebld_constant_integer3 (ffebld_conter (r)));
  4294. expr = ffebld_new_conter_with_orig
  4295. (ffebld_constant_new_logicaldefault (val), expr);
  4296. break;
  4297. #endif
  4298. #if FFETARGET_okINTEGER4
  4299. case FFEINFO_kindtypeINTEGER4:
  4300. error = ffetarget_ne_integer4 (&val,
  4301. ffebld_constant_integer4 (ffebld_conter (l)),
  4302. ffebld_constant_integer4 (ffebld_conter (r)));
  4303. expr = ffebld_new_conter_with_orig
  4304. (ffebld_constant_new_logicaldefault (val), expr);
  4305. break;
  4306. #endif
  4307. default:
  4308. assert ("bad integer kind type" == NULL);
  4309. break;
  4310. }
  4311. break;
  4312. case FFEINFO_basictypeREAL:
  4313. switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  4314. {
  4315. #if FFETARGET_okREAL1
  4316. case FFEINFO_kindtypeREAL1:
  4317. error = ffetarget_ne_real1 (&val,
  4318. ffebld_constant_real1 (ffebld_conter (l)),
  4319. ffebld_constant_real1 (ffebld_conter (r)));
  4320. expr = ffebld_new_conter_with_orig
  4321. (ffebld_constant_new_logicaldefault (val), expr);
  4322. break;
  4323. #endif
  4324. #if FFETARGET_okREAL2
  4325. case FFEINFO_kindtypeREAL2:
  4326. error = ffetarget_ne_real2 (&val,
  4327. ffebld_constant_real2 (ffebld_conter (l)),
  4328. ffebld_constant_real2 (ffebld_conter (r)));
  4329. expr = ffebld_new_conter_with_orig
  4330. (ffebld_constant_new_logicaldefault (val), expr);
  4331. break;
  4332. #endif
  4333. #if FFETARGET_okREAL3
  4334. case FFEINFO_kindtypeREAL3:
  4335. error = ffetarget_ne_real3 (&val,
  4336. ffebld_constant_real3 (ffebld_conter (l)),
  4337. ffebld_constant_real3 (ffebld_conter (r)));
  4338. expr = ffebld_new_conter_with_orig
  4339. (ffebld_constant_new_logicaldefault (val), expr);
  4340. break;
  4341. #endif
  4342. #if FFETARGET_okREAL4
  4343. case FFEINFO_kindtypeREAL4:
  4344. error = ffetarget_ne_real4 (&val,
  4345. ffebld_constant_real4 (ffebld_conter (l)),
  4346. ffebld_constant_real4 (ffebld_conter (r)));
  4347. expr = ffebld_new_conter_with_orig
  4348. (ffebld_constant_new_logicaldefault (val), expr);
  4349. break;
  4350. #endif
  4351. default:
  4352. assert ("bad real kind type" == NULL);
  4353. break;
  4354. }
  4355. break;
  4356. case FFEINFO_basictypeCOMPLEX:
  4357. switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  4358. {
  4359. #if FFETARGET_okCOMPLEX1
  4360. case FFEINFO_kindtypeREAL1:
  4361. error = ffetarget_ne_complex1 (&val,
  4362. ffebld_constant_complex1 (ffebld_conter (l)),
  4363. ffebld_constant_complex1 (ffebld_conter (r)));
  4364. expr = ffebld_new_conter_with_orig
  4365. (ffebld_constant_new_logicaldefault (val), expr);
  4366. break;
  4367. #endif
  4368. #if FFETARGET_okCOMPLEX2
  4369. case FFEINFO_kindtypeREAL2:
  4370. error = ffetarget_ne_complex2 (&val,
  4371. ffebld_constant_complex2 (ffebld_conter (l)),
  4372. ffebld_constant_complex2 (ffebld_conter (r)));
  4373. expr = ffebld_new_conter_with_orig
  4374. (ffebld_constant_new_logicaldefault (val), expr);
  4375. break;
  4376. #endif
  4377. #if FFETARGET_okCOMPLEX3
  4378. case FFEINFO_kindtypeREAL3:
  4379. error = ffetarget_ne_complex3 (&val,
  4380. ffebld_constant_complex3 (ffebld_conter (l)),
  4381. ffebld_constant_complex3 (ffebld_conter (r)));
  4382. expr = ffebld_new_conter_with_orig
  4383. (ffebld_constant_new_logicaldefault (val), expr);
  4384. break;
  4385. #endif
  4386. #if FFETARGET_okCOMPLEX4
  4387. case FFEINFO_kindtypeREAL4:
  4388. error = ffetarget_ne_complex4 (&val,
  4389. ffebld_constant_complex4 (ffebld_conter (l)),
  4390. ffebld_constant_complex4 (ffebld_conter (r)));
  4391. expr = ffebld_new_conter_with_orig
  4392. (ffebld_constant_new_logicaldefault (val), expr);
  4393. break;
  4394. #endif
  4395. default:
  4396. assert ("bad complex kind type" == NULL);
  4397. break;
  4398. }
  4399. break;
  4400. case FFEINFO_basictypeCHARACTER:
  4401. switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  4402. {
  4403. #if FFETARGET_okCHARACTER1
  4404. case FFEINFO_kindtypeCHARACTER1:
  4405. error = ffetarget_ne_character1 (&val,
  4406. ffebld_constant_character1 (ffebld_conter (l)),
  4407. ffebld_constant_character1 (ffebld_conter (r)));
  4408. expr = ffebld_new_conter_with_orig
  4409. (ffebld_constant_new_logicaldefault (val), expr);
  4410. break;
  4411. #endif
  4412. #if FFETARGET_okCHARACTER2
  4413. case FFEINFO_kindtypeCHARACTER2:
  4414. error = ffetarget_ne_character2 (&val,
  4415. ffebld_constant_character2 (ffebld_conter (l)),
  4416. ffebld_constant_character2 (ffebld_conter (r)));
  4417. expr = ffebld_new_conter_with_orig
  4418. (ffebld_constant_new_logicaldefault (val), expr);
  4419. break;
  4420. #endif
  4421. #if FFETARGET_okCHARACTER3
  4422. case FFEINFO_kindtypeCHARACTER3:
  4423. error = ffetarget_ne_character3 (&val,
  4424. ffebld_constant_character3 (ffebld_conter (l)),
  4425. ffebld_constant_character3 (ffebld_conter (r)));
  4426. expr = ffebld_new_conter_with_orig
  4427. (ffebld_constant_new_logicaldefault (val), expr);
  4428. break;
  4429. #endif
  4430. #if FFETARGET_okCHARACTER4
  4431. case FFEINFO_kindtypeCHARACTER4:
  4432. error = ffetarget_ne_character4 (&val,
  4433. ffebld_constant_character4 (ffebld_conter (l)),
  4434. ffebld_constant_character4 (ffebld_conter (r)));
  4435. expr = ffebld_new_conter_with_orig
  4436. (ffebld_constant_new_logicaldefault (val), expr);
  4437. break;
  4438. #endif
  4439. default:
  4440. assert ("bad character kind type" == NULL);
  4441. break;
  4442. }
  4443. break;
  4444. default:
  4445. assert ("bad type" == NULL);
  4446. return expr;
  4447. }
  4448. ffebld_set_info (expr, ffeinfo_new
  4449. (FFEINFO_basictypeLOGICAL,
  4450. FFEINFO_kindtypeLOGICALDEFAULT,
  4451. 0,
  4452. FFEINFO_kindENTITY,
  4453. FFEINFO_whereCONSTANT,
  4454. FFETARGET_charactersizeNONE));
  4455. if ((error != FFEBAD)
  4456. && ffebad_start (error))
  4457. {
  4458. ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  4459. ffebad_finish ();
  4460. }
  4461. return expr;
  4462. }
  4463. /* ffeexpr_collapse_ge -- Collapse ge expr
  4464. ffebld expr;
  4465. ffelexToken token;
  4466. expr = ffeexpr_collapse_ge(expr,token);
  4467. If the result of the expr is a constant, replaces the expr with the
  4468. computed constant. */
  4469. ffebld
  4470. ffeexpr_collapse_ge (ffebld expr, ffelexToken t)
  4471. {
  4472. ffebad error = FFEBAD;
  4473. ffebld l;
  4474. ffebld r;
  4475. bool val;
  4476. if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  4477. return expr;
  4478. l = ffebld_left (expr);
  4479. r = ffebld_right (expr);
  4480. if (ffebld_op (l) != FFEBLD_opCONTER)
  4481. return expr;
  4482. if (ffebld_op (r) != FFEBLD_opCONTER)
  4483. return expr;
  4484. switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
  4485. {
  4486. case FFEINFO_basictypeANY:
  4487. return expr;
  4488. case FFEINFO_basictypeINTEGER:
  4489. switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  4490. {
  4491. #if FFETARGET_okINTEGER1
  4492. case FFEINFO_kindtypeINTEGER1:
  4493. error = ffetarget_ge_integer1 (&val,
  4494. ffebld_constant_integer1 (ffebld_conter (l)),
  4495. ffebld_constant_integer1 (ffebld_conter (r)));
  4496. expr = ffebld_new_conter_with_orig
  4497. (ffebld_constant_new_logicaldefault (val), expr);
  4498. break;
  4499. #endif
  4500. #if FFETARGET_okINTEGER2
  4501. case FFEINFO_kindtypeINTEGER2:
  4502. error = ffetarget_ge_integer2 (&val,
  4503. ffebld_constant_integer2 (ffebld_conter (l)),
  4504. ffebld_constant_integer2 (ffebld_conter (r)));
  4505. expr = ffebld_new_conter_with_orig
  4506. (ffebld_constant_new_logicaldefault (val), expr);
  4507. break;
  4508. #endif
  4509. #if FFETARGET_okINTEGER3
  4510. case FFEINFO_kindtypeINTEGER3:
  4511. error = ffetarget_ge_integer3 (&val,
  4512. ffebld_constant_integer3 (ffebld_conter (l)),
  4513. ffebld_constant_integer3 (ffebld_conter (r)));
  4514. expr = ffebld_new_conter_with_orig
  4515. (ffebld_constant_new_logicaldefault (val), expr);
  4516. break;
  4517. #endif
  4518. #if FFETARGET_okINTEGER4
  4519. case FFEINFO_kindtypeINTEGER4:
  4520. error = ffetarget_ge_integer4 (&val,
  4521. ffebld_constant_integer4 (ffebld_conter (l)),
  4522. ffebld_constant_integer4 (ffebld_conter (r)));
  4523. expr = ffebld_new_conter_with_orig
  4524. (ffebld_constant_new_logicaldefault (val), expr);
  4525. break;
  4526. #endif
  4527. default:
  4528. assert ("bad integer kind type" == NULL);
  4529. break;
  4530. }
  4531. break;
  4532. case FFEINFO_basictypeREAL:
  4533. switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  4534. {
  4535. #if FFETARGET_okREAL1
  4536. case FFEINFO_kindtypeREAL1:
  4537. error = ffetarget_ge_real1 (&val,
  4538. ffebld_constant_real1 (ffebld_conter (l)),
  4539. ffebld_constant_real1 (ffebld_conter (r)));
  4540. expr = ffebld_new_conter_with_orig
  4541. (ffebld_constant_new_logicaldefault (val), expr);
  4542. break;
  4543. #endif
  4544. #if FFETARGET_okREAL2
  4545. case FFEINFO_kindtypeREAL2:
  4546. error = ffetarget_ge_real2 (&val,
  4547. ffebld_constant_real2 (ffebld_conter (l)),
  4548. ffebld_constant_real2 (ffebld_conter (r)));
  4549. expr = ffebld_new_conter_with_orig
  4550. (ffebld_constant_new_logicaldefault (val), expr);
  4551. break;
  4552. #endif
  4553. #if FFETARGET_okREAL3
  4554. case FFEINFO_kindtypeREAL3:
  4555. error = ffetarget_ge_real3 (&val,
  4556. ffebld_constant_real3 (ffebld_conter (l)),
  4557. ffebld_constant_real3 (ffebld_conter (r)));
  4558. expr = ffebld_new_conter_with_orig
  4559. (ffebld_constant_new_logicaldefault (val), expr);
  4560. break;
  4561. #endif
  4562. #if FFETARGET_okREAL4
  4563. case FFEINFO_kindtypeREAL4:
  4564. error = ffetarget_ge_real4 (&val,
  4565. ffebld_constant_real4 (ffebld_conter (l)),
  4566. ffebld_constant_real4 (ffebld_conter (r)));
  4567. expr = ffebld_new_conter_with_orig
  4568. (ffebld_constant_new_logicaldefault (val), expr);
  4569. break;
  4570. #endif
  4571. default:
  4572. assert ("bad real kind type" == NULL);
  4573. break;
  4574. }
  4575. break;
  4576. case FFEINFO_basictypeCHARACTER:
  4577. switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  4578. {
  4579. #if FFETARGET_okCHARACTER1
  4580. case FFEINFO_kindtypeCHARACTER1:
  4581. error = ffetarget_ge_character1 (&val,
  4582. ffebld_constant_character1 (ffebld_conter (l)),
  4583. ffebld_constant_character1 (ffebld_conter (r)));
  4584. expr = ffebld_new_conter_with_orig
  4585. (ffebld_constant_new_logicaldefault (val), expr);
  4586. break;
  4587. #endif
  4588. #if FFETARGET_okCHARACTER2
  4589. case FFEINFO_kindtypeCHARACTER2:
  4590. error = ffetarget_ge_character2 (&val,
  4591. ffebld_constant_character2 (ffebld_conter (l)),
  4592. ffebld_constant_character2 (ffebld_conter (r)));
  4593. expr = ffebld_new_conter_with_orig
  4594. (ffebld_constant_new_logicaldefault (val), expr);
  4595. break;
  4596. #endif
  4597. #if FFETARGET_okCHARACTER3
  4598. case FFEINFO_kindtypeCHARACTER3:
  4599. error = ffetarget_ge_character3 (&val,
  4600. ffebld_constant_character3 (ffebld_conter (l)),
  4601. ffebld_constant_character3 (ffebld_conter (r)));
  4602. expr = ffebld_new_conter_with_orig
  4603. (ffebld_constant_new_logicaldefault (val), expr);
  4604. break;
  4605. #endif
  4606. #if FFETARGET_okCHARACTER4
  4607. case FFEINFO_kindtypeCHARACTER4:
  4608. error = ffetarget_ge_character4 (&val,
  4609. ffebld_constant_character4 (ffebld_conter (l)),
  4610. ffebld_constant_character4 (ffebld_conter (r)));
  4611. expr = ffebld_new_conter_with_orig
  4612. (ffebld_constant_new_logicaldefault (val), expr);
  4613. break;
  4614. #endif
  4615. default:
  4616. assert ("bad character kind type" == NULL);
  4617. break;
  4618. }
  4619. break;
  4620. default:
  4621. assert ("bad type" == NULL);
  4622. return expr;
  4623. }
  4624. ffebld_set_info (expr, ffeinfo_new
  4625. (FFEINFO_basictypeLOGICAL,
  4626. FFEINFO_kindtypeLOGICALDEFAULT,
  4627. 0,
  4628. FFEINFO_kindENTITY,
  4629. FFEINFO_whereCONSTANT,
  4630. FFETARGET_charactersizeNONE));
  4631. if ((error != FFEBAD)
  4632. && ffebad_start (error))
  4633. {
  4634. ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  4635. ffebad_finish ();
  4636. }
  4637. return expr;
  4638. }
  4639. /* ffeexpr_collapse_gt -- Collapse gt expr
  4640. ffebld expr;
  4641. ffelexToken token;
  4642. expr = ffeexpr_collapse_gt(expr,token);
  4643. If the result of the expr is a constant, replaces the expr with the
  4644. computed constant. */
  4645. ffebld
  4646. ffeexpr_collapse_gt (ffebld expr, ffelexToken t)
  4647. {
  4648. ffebad error = FFEBAD;
  4649. ffebld l;
  4650. ffebld r;
  4651. bool val;
  4652. if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  4653. return expr;
  4654. l = ffebld_left (expr);
  4655. r = ffebld_right (expr);
  4656. if (ffebld_op (l) != FFEBLD_opCONTER)
  4657. return expr;
  4658. if (ffebld_op (r) != FFEBLD_opCONTER)
  4659. return expr;
  4660. switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
  4661. {
  4662. case FFEINFO_basictypeANY:
  4663. return expr;
  4664. case FFEINFO_basictypeINTEGER:
  4665. switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  4666. {
  4667. #if FFETARGET_okINTEGER1
  4668. case FFEINFO_kindtypeINTEGER1:
  4669. error = ffetarget_gt_integer1 (&val,
  4670. ffebld_constant_integer1 (ffebld_conter (l)),
  4671. ffebld_constant_integer1 (ffebld_conter (r)));
  4672. expr = ffebld_new_conter_with_orig
  4673. (ffebld_constant_new_logicaldefault (val), expr);
  4674. break;
  4675. #endif
  4676. #if FFETARGET_okINTEGER2
  4677. case FFEINFO_kindtypeINTEGER2:
  4678. error = ffetarget_gt_integer2 (&val,
  4679. ffebld_constant_integer2 (ffebld_conter (l)),
  4680. ffebld_constant_integer2 (ffebld_conter (r)));
  4681. expr = ffebld_new_conter_with_orig
  4682. (ffebld_constant_new_logicaldefault (val), expr);
  4683. break;
  4684. #endif
  4685. #if FFETARGET_okINTEGER3
  4686. case FFEINFO_kindtypeINTEGER3:
  4687. error = ffetarget_gt_integer3 (&val,
  4688. ffebld_constant_integer3 (ffebld_conter (l)),
  4689. ffebld_constant_integer3 (ffebld_conter (r)));
  4690. expr = ffebld_new_conter_with_orig
  4691. (ffebld_constant_new_logicaldefault (val), expr);
  4692. break;
  4693. #endif
  4694. #if FFETARGET_okINTEGER4
  4695. case FFEINFO_kindtypeINTEGER4:
  4696. error = ffetarget_gt_integer4 (&val,
  4697. ffebld_constant_integer4 (ffebld_conter (l)),
  4698. ffebld_constant_integer4 (ffebld_conter (r)));
  4699. expr = ffebld_new_conter_with_orig
  4700. (ffebld_constant_new_logicaldefault (val), expr);
  4701. break;
  4702. #endif
  4703. default:
  4704. assert ("bad integer kind type" == NULL);
  4705. break;
  4706. }
  4707. break;
  4708. case FFEINFO_basictypeREAL:
  4709. switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  4710. {
  4711. #if FFETARGET_okREAL1
  4712. case FFEINFO_kindtypeREAL1:
  4713. error = ffetarget_gt_real1 (&val,
  4714. ffebld_constant_real1 (ffebld_conter (l)),
  4715. ffebld_constant_real1 (ffebld_conter (r)));
  4716. expr = ffebld_new_conter_with_orig
  4717. (ffebld_constant_new_logicaldefault (val), expr);
  4718. break;
  4719. #endif
  4720. #if FFETARGET_okREAL2
  4721. case FFEINFO_kindtypeREAL2:
  4722. error = ffetarget_gt_real2 (&val,
  4723. ffebld_constant_real2 (ffebld_conter (l)),
  4724. ffebld_constant_real2 (ffebld_conter (r)));
  4725. expr = ffebld_new_conter_with_orig
  4726. (ffebld_constant_new_logicaldefault (val), expr);
  4727. break;
  4728. #endif
  4729. #if FFETARGET_okREAL3
  4730. case FFEINFO_kindtypeREAL3:
  4731. error = ffetarget_gt_real3 (&val,
  4732. ffebld_constant_real3 (ffebld_conter (l)),
  4733. ffebld_constant_real3 (ffebld_conter (r)));
  4734. expr = ffebld_new_conter_with_orig
  4735. (ffebld_constant_new_logicaldefault (val), expr);
  4736. break;
  4737. #endif
  4738. #if FFETARGET_okREAL4
  4739. case FFEINFO_kindtypeREAL4:
  4740. error = ffetarget_gt_real4 (&val,
  4741. ffebld_constant_real4 (ffebld_conter (l)),
  4742. ffebld_constant_real4 (ffebld_conter (r)));
  4743. expr = ffebld_new_conter_with_orig
  4744. (ffebld_constant_new_logicaldefault (val), expr);
  4745. break;
  4746. #endif
  4747. default:
  4748. assert ("bad real kind type" == NULL);
  4749. break;
  4750. }
  4751. break;
  4752. case FFEINFO_basictypeCHARACTER:
  4753. switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  4754. {
  4755. #if FFETARGET_okCHARACTER1
  4756. case FFEINFO_kindtypeCHARACTER1:
  4757. error = ffetarget_gt_character1 (&val,
  4758. ffebld_constant_character1 (ffebld_conter (l)),
  4759. ffebld_constant_character1 (ffebld_conter (r)));
  4760. expr = ffebld_new_conter_with_orig
  4761. (ffebld_constant_new_logicaldefault (val), expr);
  4762. break;
  4763. #endif
  4764. #if FFETARGET_okCHARACTER2
  4765. case FFEINFO_kindtypeCHARACTER2:
  4766. error = ffetarget_gt_character2 (&val,
  4767. ffebld_constant_character2 (ffebld_conter (l)),
  4768. ffebld_constant_character2 (ffebld_conter (r)));
  4769. expr = ffebld_new_conter_with_orig
  4770. (ffebld_constant_new_logicaldefault (val), expr);
  4771. break;
  4772. #endif
  4773. #if FFETARGET_okCHARACTER3
  4774. case FFEINFO_kindtypeCHARACTER3:
  4775. error = ffetarget_gt_character3 (&val,
  4776. ffebld_constant_character3 (ffebld_conter (l)),
  4777. ffebld_constant_character3 (ffebld_conter (r)));
  4778. expr = ffebld_new_conter_with_orig
  4779. (ffebld_constant_new_logicaldefault (val), expr);
  4780. break;
  4781. #endif
  4782. #if FFETARGET_okCHARACTER4
  4783. case FFEINFO_kindtypeCHARACTER4:
  4784. error = ffetarget_gt_character4 (&val,
  4785. ffebld_constant_character4 (ffebld_conter (l)),
  4786. ffebld_constant_character4 (ffebld_conter (r)));
  4787. expr = ffebld_new_conter_with_orig
  4788. (ffebld_constant_new_logicaldefault (val), expr);
  4789. break;
  4790. #endif
  4791. default:
  4792. assert ("bad character kind type" == NULL);
  4793. break;
  4794. }
  4795. break;
  4796. default:
  4797. assert ("bad type" == NULL);
  4798. return expr;
  4799. }
  4800. ffebld_set_info (expr, ffeinfo_new
  4801. (FFEINFO_basictypeLOGICAL,
  4802. FFEINFO_kindtypeLOGICALDEFAULT,
  4803. 0,
  4804. FFEINFO_kindENTITY,
  4805. FFEINFO_whereCONSTANT,
  4806. FFETARGET_charactersizeNONE));
  4807. if ((error != FFEBAD)
  4808. && ffebad_start (error))
  4809. {
  4810. ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  4811. ffebad_finish ();
  4812. }
  4813. return expr;
  4814. }
  4815. /* ffeexpr_collapse_le -- Collapse le expr
  4816. ffebld expr;
  4817. ffelexToken token;
  4818. expr = ffeexpr_collapse_le(expr,token);
  4819. If the result of the expr is a constant, replaces the expr with the
  4820. computed constant. */
  4821. ffebld
  4822. ffeexpr_collapse_le (ffebld expr, ffelexToken t)
  4823. {
  4824. ffebad error = FFEBAD;
  4825. ffebld l;
  4826. ffebld r;
  4827. bool val;
  4828. if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  4829. return expr;
  4830. l = ffebld_left (expr);
  4831. r = ffebld_right (expr);
  4832. if (ffebld_op (l) != FFEBLD_opCONTER)
  4833. return expr;
  4834. if (ffebld_op (r) != FFEBLD_opCONTER)
  4835. return expr;
  4836. switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
  4837. {
  4838. case FFEINFO_basictypeANY:
  4839. return expr;
  4840. case FFEINFO_basictypeINTEGER:
  4841. switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  4842. {
  4843. #if FFETARGET_okINTEGER1
  4844. case FFEINFO_kindtypeINTEGER1:
  4845. error = ffetarget_le_integer1 (&val,
  4846. ffebld_constant_integer1 (ffebld_conter (l)),
  4847. ffebld_constant_integer1 (ffebld_conter (r)));
  4848. expr = ffebld_new_conter_with_orig
  4849. (ffebld_constant_new_logicaldefault (val), expr);
  4850. break;
  4851. #endif
  4852. #if FFETARGET_okINTEGER2
  4853. case FFEINFO_kindtypeINTEGER2:
  4854. error = ffetarget_le_integer2 (&val,
  4855. ffebld_constant_integer2 (ffebld_conter (l)),
  4856. ffebld_constant_integer2 (ffebld_conter (r)));
  4857. expr = ffebld_new_conter_with_orig
  4858. (ffebld_constant_new_logicaldefault (val), expr);
  4859. break;
  4860. #endif
  4861. #if FFETARGET_okINTEGER3
  4862. case FFEINFO_kindtypeINTEGER3:
  4863. error = ffetarget_le_integer3 (&val,
  4864. ffebld_constant_integer3 (ffebld_conter (l)),
  4865. ffebld_constant_integer3 (ffebld_conter (r)));
  4866. expr = ffebld_new_conter_with_orig
  4867. (ffebld_constant_new_logicaldefault (val), expr);
  4868. break;
  4869. #endif
  4870. #if FFETARGET_okINTEGER4
  4871. case FFEINFO_kindtypeINTEGER4:
  4872. error = ffetarget_le_integer4 (&val,
  4873. ffebld_constant_integer4 (ffebld_conter (l)),
  4874. ffebld_constant_integer4 (ffebld_conter (r)));
  4875. expr = ffebld_new_conter_with_orig
  4876. (ffebld_constant_new_logicaldefault (val), expr);
  4877. break;
  4878. #endif
  4879. default:
  4880. assert ("bad integer kind type" == NULL);
  4881. break;
  4882. }
  4883. break;
  4884. case FFEINFO_basictypeREAL:
  4885. switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  4886. {
  4887. #if FFETARGET_okREAL1
  4888. case FFEINFO_kindtypeREAL1:
  4889. error = ffetarget_le_real1 (&val,
  4890. ffebld_constant_real1 (ffebld_conter (l)),
  4891. ffebld_constant_real1 (ffebld_conter (r)));
  4892. expr = ffebld_new_conter_with_orig
  4893. (ffebld_constant_new_logicaldefault (val), expr);
  4894. break;
  4895. #endif
  4896. #if FFETARGET_okREAL2
  4897. case FFEINFO_kindtypeREAL2:
  4898. error = ffetarget_le_real2 (&val,
  4899. ffebld_constant_real2 (ffebld_conter (l)),
  4900. ffebld_constant_real2 (ffebld_conter (r)));
  4901. expr = ffebld_new_conter_with_orig
  4902. (ffebld_constant_new_logicaldefault (val), expr);
  4903. break;
  4904. #endif
  4905. #if FFETARGET_okREAL3
  4906. case FFEINFO_kindtypeREAL3:
  4907. error = ffetarget_le_real3 (&val,
  4908. ffebld_constant_real3 (ffebld_conter (l)),
  4909. ffebld_constant_real3 (ffebld_conter (r)));
  4910. expr = ffebld_new_conter_with_orig
  4911. (ffebld_constant_new_logicaldefault (val), expr);
  4912. break;
  4913. #endif
  4914. #if FFETARGET_okREAL4
  4915. case FFEINFO_kindtypeREAL4:
  4916. error = ffetarget_le_real4 (&val,
  4917. ffebld_constant_real4 (ffebld_conter (l)),
  4918. ffebld_constant_real4 (ffebld_conter (r)));
  4919. expr = ffebld_new_conter_with_orig
  4920. (ffebld_constant_new_logicaldefault (val), expr);
  4921. break;
  4922. #endif
  4923. default:
  4924. assert ("bad real kind type" == NULL);
  4925. break;
  4926. }
  4927. break;
  4928. case FFEINFO_basictypeCHARACTER:
  4929. switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  4930. {
  4931. #if FFETARGET_okCHARACTER1
  4932. case FFEINFO_kindtypeCHARACTER1:
  4933. error = ffetarget_le_character1 (&val,
  4934. ffebld_constant_character1 (ffebld_conter (l)),
  4935. ffebld_constant_character1 (ffebld_conter (r)));
  4936. expr = ffebld_new_conter_with_orig
  4937. (ffebld_constant_new_logicaldefault (val), expr);
  4938. break;
  4939. #endif
  4940. #if FFETARGET_okCHARACTER2
  4941. case FFEINFO_kindtypeCHARACTER2:
  4942. error = ffetarget_le_character2 (&val,
  4943. ffebld_constant_character2 (ffebld_conter (l)),
  4944. ffebld_constant_character2 (ffebld_conter (r)));
  4945. expr = ffebld_new_conter_with_orig
  4946. (ffebld_constant_new_logicaldefault (val), expr);
  4947. break;
  4948. #endif
  4949. #if FFETARGET_okCHARACTER3
  4950. case FFEINFO_kindtypeCHARACTER3:
  4951. error = ffetarget_le_character3 (&val,
  4952. ffebld_constant_character3 (ffebld_conter (l)),
  4953. ffebld_constant_character3 (ffebld_conter (r)));
  4954. expr = ffebld_new_conter_with_orig
  4955. (ffebld_constant_new_logicaldefault (val), expr);
  4956. break;
  4957. #endif
  4958. #if FFETARGET_okCHARACTER4
  4959. case FFEINFO_kindtypeCHARACTER4:
  4960. error = ffetarget_le_character4 (&val,
  4961. ffebld_constant_character4 (ffebld_conter (l)),
  4962. ffebld_constant_character4 (ffebld_conter (r)));
  4963. expr = ffebld_new_conter_with_orig
  4964. (ffebld_constant_new_logicaldefault (val), expr);
  4965. break;
  4966. #endif
  4967. default:
  4968. assert ("bad character kind type" == NULL);
  4969. break;
  4970. }
  4971. break;
  4972. default:
  4973. assert ("bad type" == NULL);
  4974. return expr;
  4975. }
  4976. ffebld_set_info (expr, ffeinfo_new
  4977. (FFEINFO_basictypeLOGICAL,
  4978. FFEINFO_kindtypeLOGICALDEFAULT,
  4979. 0,
  4980. FFEINFO_kindENTITY,
  4981. FFEINFO_whereCONSTANT,
  4982. FFETARGET_charactersizeNONE));
  4983. if ((error != FFEBAD)
  4984. && ffebad_start (error))
  4985. {
  4986. ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  4987. ffebad_finish ();
  4988. }
  4989. return expr;
  4990. }
  4991. /* ffeexpr_collapse_lt -- Collapse lt expr
  4992. ffebld expr;
  4993. ffelexToken token;
  4994. expr = ffeexpr_collapse_lt(expr,token);
  4995. If the result of the expr is a constant, replaces the expr with the
  4996. computed constant. */
  4997. ffebld
  4998. ffeexpr_collapse_lt (ffebld expr, ffelexToken t)
  4999. {
  5000. ffebad error = FFEBAD;
  5001. ffebld l;
  5002. ffebld r;
  5003. bool val;
  5004. if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  5005. return expr;
  5006. l = ffebld_left (expr);
  5007. r = ffebld_right (expr);
  5008. if (ffebld_op (l) != FFEBLD_opCONTER)
  5009. return expr;
  5010. if (ffebld_op (r) != FFEBLD_opCONTER)
  5011. return expr;
  5012. switch (ffeinfo_basictype (ffebld_info (ffebld_left (expr))))
  5013. {
  5014. case FFEINFO_basictypeANY:
  5015. return expr;
  5016. case FFEINFO_basictypeINTEGER:
  5017. switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  5018. {
  5019. #if FFETARGET_okINTEGER1
  5020. case FFEINFO_kindtypeINTEGER1:
  5021. error = ffetarget_lt_integer1 (&val,
  5022. ffebld_constant_integer1 (ffebld_conter (l)),
  5023. ffebld_constant_integer1 (ffebld_conter (r)));
  5024. expr = ffebld_new_conter_with_orig
  5025. (ffebld_constant_new_logicaldefault (val), expr);
  5026. break;
  5027. #endif
  5028. #if FFETARGET_okINTEGER2
  5029. case FFEINFO_kindtypeINTEGER2:
  5030. error = ffetarget_lt_integer2 (&val,
  5031. ffebld_constant_integer2 (ffebld_conter (l)),
  5032. ffebld_constant_integer2 (ffebld_conter (r)));
  5033. expr = ffebld_new_conter_with_orig
  5034. (ffebld_constant_new_logicaldefault (val), expr);
  5035. break;
  5036. #endif
  5037. #if FFETARGET_okINTEGER3
  5038. case FFEINFO_kindtypeINTEGER3:
  5039. error = ffetarget_lt_integer3 (&val,
  5040. ffebld_constant_integer3 (ffebld_conter (l)),
  5041. ffebld_constant_integer3 (ffebld_conter (r)));
  5042. expr = ffebld_new_conter_with_orig
  5043. (ffebld_constant_new_logicaldefault (val), expr);
  5044. break;
  5045. #endif
  5046. #if FFETARGET_okINTEGER4
  5047. case FFEINFO_kindtypeINTEGER4:
  5048. error = ffetarget_lt_integer4 (&val,
  5049. ffebld_constant_integer4 (ffebld_conter (l)),
  5050. ffebld_constant_integer4 (ffebld_conter (r)));
  5051. expr = ffebld_new_conter_with_orig
  5052. (ffebld_constant_new_logicaldefault (val), expr);
  5053. break;
  5054. #endif
  5055. default:
  5056. assert ("bad integer kind type" == NULL);
  5057. break;
  5058. }
  5059. break;
  5060. case FFEINFO_basictypeREAL:
  5061. switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  5062. {
  5063. #if FFETARGET_okREAL1
  5064. case FFEINFO_kindtypeREAL1:
  5065. error = ffetarget_lt_real1 (&val,
  5066. ffebld_constant_real1 (ffebld_conter (l)),
  5067. ffebld_constant_real1 (ffebld_conter (r)));
  5068. expr = ffebld_new_conter_with_orig
  5069. (ffebld_constant_new_logicaldefault (val), expr);
  5070. break;
  5071. #endif
  5072. #if FFETARGET_okREAL2
  5073. case FFEINFO_kindtypeREAL2:
  5074. error = ffetarget_lt_real2 (&val,
  5075. ffebld_constant_real2 (ffebld_conter (l)),
  5076. ffebld_constant_real2 (ffebld_conter (r)));
  5077. expr = ffebld_new_conter_with_orig
  5078. (ffebld_constant_new_logicaldefault (val), expr);
  5079. break;
  5080. #endif
  5081. #if FFETARGET_okREAL3
  5082. case FFEINFO_kindtypeREAL3:
  5083. error = ffetarget_lt_real3 (&val,
  5084. ffebld_constant_real3 (ffebld_conter (l)),
  5085. ffebld_constant_real3 (ffebld_conter (r)));
  5086. expr = ffebld_new_conter_with_orig
  5087. (ffebld_constant_new_logicaldefault (val), expr);
  5088. break;
  5089. #endif
  5090. #if FFETARGET_okREAL4
  5091. case FFEINFO_kindtypeREAL4:
  5092. error = ffetarget_lt_real4 (&val,
  5093. ffebld_constant_real4 (ffebld_conter (l)),
  5094. ffebld_constant_real4 (ffebld_conter (r)));
  5095. expr = ffebld_new_conter_with_orig
  5096. (ffebld_constant_new_logicaldefault (val), expr);
  5097. break;
  5098. #endif
  5099. default:
  5100. assert ("bad real kind type" == NULL);
  5101. break;
  5102. }
  5103. break;
  5104. case FFEINFO_basictypeCHARACTER:
  5105. switch (ffeinfo_kindtype (ffebld_info (ffebld_left (expr))))
  5106. {
  5107. #if FFETARGET_okCHARACTER1
  5108. case FFEINFO_kindtypeCHARACTER1:
  5109. error = ffetarget_lt_character1 (&val,
  5110. ffebld_constant_character1 (ffebld_conter (l)),
  5111. ffebld_constant_character1 (ffebld_conter (r)));
  5112. expr = ffebld_new_conter_with_orig
  5113. (ffebld_constant_new_logicaldefault (val), expr);
  5114. break;
  5115. #endif
  5116. #if FFETARGET_okCHARACTER2
  5117. case FFEINFO_kindtypeCHARACTER2:
  5118. error = ffetarget_lt_character2 (&val,
  5119. ffebld_constant_character2 (ffebld_conter (l)),
  5120. ffebld_constant_character2 (ffebld_conter (r)));
  5121. expr = ffebld_new_conter_with_orig
  5122. (ffebld_constant_new_logicaldefault (val), expr);
  5123. break;
  5124. #endif
  5125. #if FFETARGET_okCHARACTER3
  5126. case FFEINFO_kindtypeCHARACTER3:
  5127. error = ffetarget_lt_character3 (&val,
  5128. ffebld_constant_character3 (ffebld_conter (l)),
  5129. ffebld_constant_character3 (ffebld_conter (r)));
  5130. expr = ffebld_new_conter_with_orig
  5131. (ffebld_constant_new_logicaldefault (val), expr);
  5132. break;
  5133. #endif
  5134. #if FFETARGET_okCHARACTER4
  5135. case FFEINFO_kindtypeCHARACTER4:
  5136. error = ffetarget_lt_character4 (&val,
  5137. ffebld_constant_character4 (ffebld_conter (l)),
  5138. ffebld_constant_character4 (ffebld_conter (r)));
  5139. expr = ffebld_new_conter_with_orig
  5140. (ffebld_constant_new_logicaldefault (val), expr);
  5141. break;
  5142. #endif
  5143. default:
  5144. assert ("bad character kind type" == NULL);
  5145. break;
  5146. }
  5147. break;
  5148. default:
  5149. assert ("bad type" == NULL);
  5150. return expr;
  5151. }
  5152. ffebld_set_info (expr, ffeinfo_new
  5153. (FFEINFO_basictypeLOGICAL,
  5154. FFEINFO_kindtypeLOGICALDEFAULT,
  5155. 0,
  5156. FFEINFO_kindENTITY,
  5157. FFEINFO_whereCONSTANT,
  5158. FFETARGET_charactersizeNONE));
  5159. if ((error != FFEBAD)
  5160. && ffebad_start (error))
  5161. {
  5162. ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  5163. ffebad_finish ();
  5164. }
  5165. return expr;
  5166. }
  5167. /* ffeexpr_collapse_and -- Collapse and expr
  5168. ffebld expr;
  5169. ffelexToken token;
  5170. expr = ffeexpr_collapse_and(expr,token);
  5171. If the result of the expr is a constant, replaces the expr with the
  5172. computed constant. */
  5173. ffebld
  5174. ffeexpr_collapse_and (ffebld expr, ffelexToken t)
  5175. {
  5176. ffebad error = FFEBAD;
  5177. ffebld l;
  5178. ffebld r;
  5179. ffebldConstantUnion u;
  5180. ffeinfoBasictype bt;
  5181. ffeinfoKindtype kt;
  5182. if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  5183. return expr;
  5184. l = ffebld_left (expr);
  5185. r = ffebld_right (expr);
  5186. if (ffebld_op (l) != FFEBLD_opCONTER)
  5187. return expr;
  5188. if (ffebld_op (r) != FFEBLD_opCONTER)
  5189. return expr;
  5190. switch (bt = ffeinfo_basictype (ffebld_info (expr)))
  5191. {
  5192. case FFEINFO_basictypeANY:
  5193. return expr;
  5194. case FFEINFO_basictypeINTEGER:
  5195. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  5196. {
  5197. #if FFETARGET_okINTEGER1
  5198. case FFEINFO_kindtypeINTEGER1:
  5199. error = ffetarget_and_integer1 (ffebld_cu_ptr_integer1 (u),
  5200. ffebld_constant_integer1 (ffebld_conter (l)),
  5201. ffebld_constant_integer1 (ffebld_conter (r)));
  5202. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
  5203. (ffebld_cu_val_integer1 (u)), expr);
  5204. break;
  5205. #endif
  5206. #if FFETARGET_okINTEGER2
  5207. case FFEINFO_kindtypeINTEGER2:
  5208. error = ffetarget_and_integer2 (ffebld_cu_ptr_integer2 (u),
  5209. ffebld_constant_integer2 (ffebld_conter (l)),
  5210. ffebld_constant_integer2 (ffebld_conter (r)));
  5211. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
  5212. (ffebld_cu_val_integer2 (u)), expr);
  5213. break;
  5214. #endif
  5215. #if FFETARGET_okINTEGER3
  5216. case FFEINFO_kindtypeINTEGER3:
  5217. error = ffetarget_and_integer3 (ffebld_cu_ptr_integer3 (u),
  5218. ffebld_constant_integer3 (ffebld_conter (l)),
  5219. ffebld_constant_integer3 (ffebld_conter (r)));
  5220. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
  5221. (ffebld_cu_val_integer3 (u)), expr);
  5222. break;
  5223. #endif
  5224. #if FFETARGET_okINTEGER4
  5225. case FFEINFO_kindtypeINTEGER4:
  5226. error = ffetarget_and_integer4 (ffebld_cu_ptr_integer4 (u),
  5227. ffebld_constant_integer4 (ffebld_conter (l)),
  5228. ffebld_constant_integer4 (ffebld_conter (r)));
  5229. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
  5230. (ffebld_cu_val_integer4 (u)), expr);
  5231. break;
  5232. #endif
  5233. default:
  5234. assert ("bad integer kind type" == NULL);
  5235. break;
  5236. }
  5237. break;
  5238. case FFEINFO_basictypeLOGICAL:
  5239. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  5240. {
  5241. #if FFETARGET_okLOGICAL1
  5242. case FFEINFO_kindtypeLOGICAL1:
  5243. error = ffetarget_and_logical1 (ffebld_cu_ptr_logical1 (u),
  5244. ffebld_constant_logical1 (ffebld_conter (l)),
  5245. ffebld_constant_logical1 (ffebld_conter (r)));
  5246. expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
  5247. (ffebld_cu_val_logical1 (u)), expr);
  5248. break;
  5249. #endif
  5250. #if FFETARGET_okLOGICAL2
  5251. case FFEINFO_kindtypeLOGICAL2:
  5252. error = ffetarget_and_logical2 (ffebld_cu_ptr_logical2 (u),
  5253. ffebld_constant_logical2 (ffebld_conter (l)),
  5254. ffebld_constant_logical2 (ffebld_conter (r)));
  5255. expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
  5256. (ffebld_cu_val_logical2 (u)), expr);
  5257. break;
  5258. #endif
  5259. #if FFETARGET_okLOGICAL3
  5260. case FFEINFO_kindtypeLOGICAL3:
  5261. error = ffetarget_and_logical3 (ffebld_cu_ptr_logical3 (u),
  5262. ffebld_constant_logical3 (ffebld_conter (l)),
  5263. ffebld_constant_logical3 (ffebld_conter (r)));
  5264. expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
  5265. (ffebld_cu_val_logical3 (u)), expr);
  5266. break;
  5267. #endif
  5268. #if FFETARGET_okLOGICAL4
  5269. case FFEINFO_kindtypeLOGICAL4:
  5270. error = ffetarget_and_logical4 (ffebld_cu_ptr_logical4 (u),
  5271. ffebld_constant_logical4 (ffebld_conter (l)),
  5272. ffebld_constant_logical4 (ffebld_conter (r)));
  5273. expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
  5274. (ffebld_cu_val_logical4 (u)), expr);
  5275. break;
  5276. #endif
  5277. default:
  5278. assert ("bad logical kind type" == NULL);
  5279. break;
  5280. }
  5281. break;
  5282. default:
  5283. assert ("bad type" == NULL);
  5284. return expr;
  5285. }
  5286. ffebld_set_info (expr, ffeinfo_new
  5287. (bt,
  5288. kt,
  5289. 0,
  5290. FFEINFO_kindENTITY,
  5291. FFEINFO_whereCONSTANT,
  5292. FFETARGET_charactersizeNONE));
  5293. if ((error != FFEBAD)
  5294. && ffebad_start (error))
  5295. {
  5296. ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  5297. ffebad_finish ();
  5298. }
  5299. return expr;
  5300. }
  5301. /* ffeexpr_collapse_or -- Collapse or expr
  5302. ffebld expr;
  5303. ffelexToken token;
  5304. expr = ffeexpr_collapse_or(expr,token);
  5305. If the result of the expr is a constant, replaces the expr with the
  5306. computed constant. */
  5307. ffebld
  5308. ffeexpr_collapse_or (ffebld expr, ffelexToken t)
  5309. {
  5310. ffebad error = FFEBAD;
  5311. ffebld l;
  5312. ffebld r;
  5313. ffebldConstantUnion u;
  5314. ffeinfoBasictype bt;
  5315. ffeinfoKindtype kt;
  5316. if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  5317. return expr;
  5318. l = ffebld_left (expr);
  5319. r = ffebld_right (expr);
  5320. if (ffebld_op (l) != FFEBLD_opCONTER)
  5321. return expr;
  5322. if (ffebld_op (r) != FFEBLD_opCONTER)
  5323. return expr;
  5324. switch (bt = ffeinfo_basictype (ffebld_info (expr)))
  5325. {
  5326. case FFEINFO_basictypeANY:
  5327. return expr;
  5328. case FFEINFO_basictypeINTEGER:
  5329. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  5330. {
  5331. #if FFETARGET_okINTEGER1
  5332. case FFEINFO_kindtypeINTEGER1:
  5333. error = ffetarget_or_integer1 (ffebld_cu_ptr_integer1 (u),
  5334. ffebld_constant_integer1 (ffebld_conter (l)),
  5335. ffebld_constant_integer1 (ffebld_conter (r)));
  5336. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
  5337. (ffebld_cu_val_integer1 (u)), expr);
  5338. break;
  5339. #endif
  5340. #if FFETARGET_okINTEGER2
  5341. case FFEINFO_kindtypeINTEGER2:
  5342. error = ffetarget_or_integer2 (ffebld_cu_ptr_integer2 (u),
  5343. ffebld_constant_integer2 (ffebld_conter (l)),
  5344. ffebld_constant_integer2 (ffebld_conter (r)));
  5345. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
  5346. (ffebld_cu_val_integer2 (u)), expr);
  5347. break;
  5348. #endif
  5349. #if FFETARGET_okINTEGER3
  5350. case FFEINFO_kindtypeINTEGER3:
  5351. error = ffetarget_or_integer3 (ffebld_cu_ptr_integer3 (u),
  5352. ffebld_constant_integer3 (ffebld_conter (l)),
  5353. ffebld_constant_integer3 (ffebld_conter (r)));
  5354. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
  5355. (ffebld_cu_val_integer3 (u)), expr);
  5356. break;
  5357. #endif
  5358. #if FFETARGET_okINTEGER4
  5359. case FFEINFO_kindtypeINTEGER4:
  5360. error = ffetarget_or_integer4 (ffebld_cu_ptr_integer4 (u),
  5361. ffebld_constant_integer4 (ffebld_conter (l)),
  5362. ffebld_constant_integer4 (ffebld_conter (r)));
  5363. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
  5364. (ffebld_cu_val_integer4 (u)), expr);
  5365. break;
  5366. #endif
  5367. default:
  5368. assert ("bad integer kind type" == NULL);
  5369. break;
  5370. }
  5371. break;
  5372. case FFEINFO_basictypeLOGICAL:
  5373. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  5374. {
  5375. #if FFETARGET_okLOGICAL1
  5376. case FFEINFO_kindtypeLOGICAL1:
  5377. error = ffetarget_or_logical1 (ffebld_cu_ptr_logical1 (u),
  5378. ffebld_constant_logical1 (ffebld_conter (l)),
  5379. ffebld_constant_logical1 (ffebld_conter (r)));
  5380. expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
  5381. (ffebld_cu_val_logical1 (u)), expr);
  5382. break;
  5383. #endif
  5384. #if FFETARGET_okLOGICAL2
  5385. case FFEINFO_kindtypeLOGICAL2:
  5386. error = ffetarget_or_logical2 (ffebld_cu_ptr_logical2 (u),
  5387. ffebld_constant_logical2 (ffebld_conter (l)),
  5388. ffebld_constant_logical2 (ffebld_conter (r)));
  5389. expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
  5390. (ffebld_cu_val_logical2 (u)), expr);
  5391. break;
  5392. #endif
  5393. #if FFETARGET_okLOGICAL3
  5394. case FFEINFO_kindtypeLOGICAL3:
  5395. error = ffetarget_or_logical3 (ffebld_cu_ptr_logical3 (u),
  5396. ffebld_constant_logical3 (ffebld_conter (l)),
  5397. ffebld_constant_logical3 (ffebld_conter (r)));
  5398. expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
  5399. (ffebld_cu_val_logical3 (u)), expr);
  5400. break;
  5401. #endif
  5402. #if FFETARGET_okLOGICAL4
  5403. case FFEINFO_kindtypeLOGICAL4:
  5404. error = ffetarget_or_logical4 (ffebld_cu_ptr_logical4 (u),
  5405. ffebld_constant_logical4 (ffebld_conter (l)),
  5406. ffebld_constant_logical4 (ffebld_conter (r)));
  5407. expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
  5408. (ffebld_cu_val_logical4 (u)), expr);
  5409. break;
  5410. #endif
  5411. default:
  5412. assert ("bad logical kind type" == NULL);
  5413. break;
  5414. }
  5415. break;
  5416. default:
  5417. assert ("bad type" == NULL);
  5418. return expr;
  5419. }
  5420. ffebld_set_info (expr, ffeinfo_new
  5421. (bt,
  5422. kt,
  5423. 0,
  5424. FFEINFO_kindENTITY,
  5425. FFEINFO_whereCONSTANT,
  5426. FFETARGET_charactersizeNONE));
  5427. if ((error != FFEBAD)
  5428. && ffebad_start (error))
  5429. {
  5430. ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  5431. ffebad_finish ();
  5432. }
  5433. return expr;
  5434. }
  5435. /* ffeexpr_collapse_xor -- Collapse xor expr
  5436. ffebld expr;
  5437. ffelexToken token;
  5438. expr = ffeexpr_collapse_xor(expr,token);
  5439. If the result of the expr is a constant, replaces the expr with the
  5440. computed constant. */
  5441. ffebld
  5442. ffeexpr_collapse_xor (ffebld expr, ffelexToken t)
  5443. {
  5444. ffebad error = FFEBAD;
  5445. ffebld l;
  5446. ffebld r;
  5447. ffebldConstantUnion u;
  5448. ffeinfoBasictype bt;
  5449. ffeinfoKindtype kt;
  5450. if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  5451. return expr;
  5452. l = ffebld_left (expr);
  5453. r = ffebld_right (expr);
  5454. if (ffebld_op (l) != FFEBLD_opCONTER)
  5455. return expr;
  5456. if (ffebld_op (r) != FFEBLD_opCONTER)
  5457. return expr;
  5458. switch (bt = ffeinfo_basictype (ffebld_info (expr)))
  5459. {
  5460. case FFEINFO_basictypeANY:
  5461. return expr;
  5462. case FFEINFO_basictypeINTEGER:
  5463. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  5464. {
  5465. #if FFETARGET_okINTEGER1
  5466. case FFEINFO_kindtypeINTEGER1:
  5467. error = ffetarget_xor_integer1 (ffebld_cu_ptr_integer1 (u),
  5468. ffebld_constant_integer1 (ffebld_conter (l)),
  5469. ffebld_constant_integer1 (ffebld_conter (r)));
  5470. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
  5471. (ffebld_cu_val_integer1 (u)), expr);
  5472. break;
  5473. #endif
  5474. #if FFETARGET_okINTEGER2
  5475. case FFEINFO_kindtypeINTEGER2:
  5476. error = ffetarget_xor_integer2 (ffebld_cu_ptr_integer2 (u),
  5477. ffebld_constant_integer2 (ffebld_conter (l)),
  5478. ffebld_constant_integer2 (ffebld_conter (r)));
  5479. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
  5480. (ffebld_cu_val_integer2 (u)), expr);
  5481. break;
  5482. #endif
  5483. #if FFETARGET_okINTEGER3
  5484. case FFEINFO_kindtypeINTEGER3:
  5485. error = ffetarget_xor_integer3 (ffebld_cu_ptr_integer3 (u),
  5486. ffebld_constant_integer3 (ffebld_conter (l)),
  5487. ffebld_constant_integer3 (ffebld_conter (r)));
  5488. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
  5489. (ffebld_cu_val_integer3 (u)), expr);
  5490. break;
  5491. #endif
  5492. #if FFETARGET_okINTEGER4
  5493. case FFEINFO_kindtypeINTEGER4:
  5494. error = ffetarget_xor_integer4 (ffebld_cu_ptr_integer4 (u),
  5495. ffebld_constant_integer4 (ffebld_conter (l)),
  5496. ffebld_constant_integer4 (ffebld_conter (r)));
  5497. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
  5498. (ffebld_cu_val_integer4 (u)), expr);
  5499. break;
  5500. #endif
  5501. default:
  5502. assert ("bad integer kind type" == NULL);
  5503. break;
  5504. }
  5505. break;
  5506. case FFEINFO_basictypeLOGICAL:
  5507. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  5508. {
  5509. #if FFETARGET_okLOGICAL1
  5510. case FFEINFO_kindtypeLOGICAL1:
  5511. error = ffetarget_xor_logical1 (ffebld_cu_ptr_logical1 (u),
  5512. ffebld_constant_logical1 (ffebld_conter (l)),
  5513. ffebld_constant_logical1 (ffebld_conter (r)));
  5514. expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
  5515. (ffebld_cu_val_logical1 (u)), expr);
  5516. break;
  5517. #endif
  5518. #if FFETARGET_okLOGICAL2
  5519. case FFEINFO_kindtypeLOGICAL2:
  5520. error = ffetarget_xor_logical2 (ffebld_cu_ptr_logical2 (u),
  5521. ffebld_constant_logical2 (ffebld_conter (l)),
  5522. ffebld_constant_logical2 (ffebld_conter (r)));
  5523. expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
  5524. (ffebld_cu_val_logical2 (u)), expr);
  5525. break;
  5526. #endif
  5527. #if FFETARGET_okLOGICAL3
  5528. case FFEINFO_kindtypeLOGICAL3:
  5529. error = ffetarget_xor_logical3 (ffebld_cu_ptr_logical3 (u),
  5530. ffebld_constant_logical3 (ffebld_conter (l)),
  5531. ffebld_constant_logical3 (ffebld_conter (r)));
  5532. expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
  5533. (ffebld_cu_val_logical3 (u)), expr);
  5534. break;
  5535. #endif
  5536. #if FFETARGET_okLOGICAL4
  5537. case FFEINFO_kindtypeLOGICAL4:
  5538. error = ffetarget_xor_logical4 (ffebld_cu_ptr_logical4 (u),
  5539. ffebld_constant_logical4 (ffebld_conter (l)),
  5540. ffebld_constant_logical4 (ffebld_conter (r)));
  5541. expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
  5542. (ffebld_cu_val_logical4 (u)), expr);
  5543. break;
  5544. #endif
  5545. default:
  5546. assert ("bad logical kind type" == NULL);
  5547. break;
  5548. }
  5549. break;
  5550. default:
  5551. assert ("bad type" == NULL);
  5552. return expr;
  5553. }
  5554. ffebld_set_info (expr, ffeinfo_new
  5555. (bt,
  5556. kt,
  5557. 0,
  5558. FFEINFO_kindENTITY,
  5559. FFEINFO_whereCONSTANT,
  5560. FFETARGET_charactersizeNONE));
  5561. if ((error != FFEBAD)
  5562. && ffebad_start (error))
  5563. {
  5564. ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  5565. ffebad_finish ();
  5566. }
  5567. return expr;
  5568. }
  5569. /* ffeexpr_collapse_eqv -- Collapse eqv expr
  5570. ffebld expr;
  5571. ffelexToken token;
  5572. expr = ffeexpr_collapse_eqv(expr,token);
  5573. If the result of the expr is a constant, replaces the expr with the
  5574. computed constant. */
  5575. ffebld
  5576. ffeexpr_collapse_eqv (ffebld expr, ffelexToken t)
  5577. {
  5578. ffebad error = FFEBAD;
  5579. ffebld l;
  5580. ffebld r;
  5581. ffebldConstantUnion u;
  5582. ffeinfoBasictype bt;
  5583. ffeinfoKindtype kt;
  5584. if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  5585. return expr;
  5586. l = ffebld_left (expr);
  5587. r = ffebld_right (expr);
  5588. if (ffebld_op (l) != FFEBLD_opCONTER)
  5589. return expr;
  5590. if (ffebld_op (r) != FFEBLD_opCONTER)
  5591. return expr;
  5592. switch (bt = ffeinfo_basictype (ffebld_info (expr)))
  5593. {
  5594. case FFEINFO_basictypeANY:
  5595. return expr;
  5596. case FFEINFO_basictypeINTEGER:
  5597. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  5598. {
  5599. #if FFETARGET_okINTEGER1
  5600. case FFEINFO_kindtypeINTEGER1:
  5601. error = ffetarget_eqv_integer1 (ffebld_cu_ptr_integer1 (u),
  5602. ffebld_constant_integer1 (ffebld_conter (l)),
  5603. ffebld_constant_integer1 (ffebld_conter (r)));
  5604. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
  5605. (ffebld_cu_val_integer1 (u)), expr);
  5606. break;
  5607. #endif
  5608. #if FFETARGET_okINTEGER2
  5609. case FFEINFO_kindtypeINTEGER2:
  5610. error = ffetarget_eqv_integer2 (ffebld_cu_ptr_integer2 (u),
  5611. ffebld_constant_integer2 (ffebld_conter (l)),
  5612. ffebld_constant_integer2 (ffebld_conter (r)));
  5613. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
  5614. (ffebld_cu_val_integer2 (u)), expr);
  5615. break;
  5616. #endif
  5617. #if FFETARGET_okINTEGER3
  5618. case FFEINFO_kindtypeINTEGER3:
  5619. error = ffetarget_eqv_integer3 (ffebld_cu_ptr_integer3 (u),
  5620. ffebld_constant_integer3 (ffebld_conter (l)),
  5621. ffebld_constant_integer3 (ffebld_conter (r)));
  5622. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
  5623. (ffebld_cu_val_integer3 (u)), expr);
  5624. break;
  5625. #endif
  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);
  5633. break;
  5634. #endif
  5635. default:
  5636. assert ("bad integer kind type" == NULL);
  5637. break;
  5638. }
  5639. break;
  5640. case FFEINFO_basictypeLOGICAL:
  5641. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  5642. {
  5643. #if FFETARGET_okLOGICAL1
  5644. case FFEINFO_kindtypeLOGICAL1:
  5645. error = ffetarget_eqv_logical1 (ffebld_cu_ptr_logical1 (u),
  5646. ffebld_constant_logical1 (ffebld_conter (l)),
  5647. ffebld_constant_logical1 (ffebld_conter (r)));
  5648. expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
  5649. (ffebld_cu_val_logical1 (u)), expr);
  5650. break;
  5651. #endif
  5652. #if FFETARGET_okLOGICAL2
  5653. case FFEINFO_kindtypeLOGICAL2:
  5654. error = ffetarget_eqv_logical2 (ffebld_cu_ptr_logical2 (u),
  5655. ffebld_constant_logical2 (ffebld_conter (l)),
  5656. ffebld_constant_logical2 (ffebld_conter (r)));
  5657. expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
  5658. (ffebld_cu_val_logical2 (u)), expr);
  5659. break;
  5660. #endif
  5661. #if FFETARGET_okLOGICAL3
  5662. case FFEINFO_kindtypeLOGICAL3:
  5663. error = ffetarget_eqv_logical3 (ffebld_cu_ptr_logical3 (u),
  5664. ffebld_constant_logical3 (ffebld_conter (l)),
  5665. ffebld_constant_logical3 (ffebld_conter (r)));
  5666. expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
  5667. (ffebld_cu_val_logical3 (u)), expr);
  5668. break;
  5669. #endif
  5670. #if FFETARGET_okLOGICAL4
  5671. case FFEINFO_kindtypeLOGICAL4:
  5672. error = ffetarget_eqv_logical4 (ffebld_cu_ptr_logical4 (u),
  5673. ffebld_constant_logical4 (ffebld_conter (l)),
  5674. ffebld_constant_logical4 (ffebld_conter (r)));
  5675. expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
  5676. (ffebld_cu_val_logical4 (u)), expr);
  5677. break;
  5678. #endif
  5679. default:
  5680. assert ("bad logical kind type" == NULL);
  5681. break;
  5682. }
  5683. break;
  5684. default:
  5685. assert ("bad type" == NULL);
  5686. return expr;
  5687. }
  5688. ffebld_set_info (expr, ffeinfo_new
  5689. (bt,
  5690. kt,
  5691. 0,
  5692. FFEINFO_kindENTITY,
  5693. FFEINFO_whereCONSTANT,
  5694. FFETARGET_charactersizeNONE));
  5695. if ((error != FFEBAD)
  5696. && ffebad_start (error))
  5697. {
  5698. ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  5699. ffebad_finish ();
  5700. }
  5701. return expr;
  5702. }
  5703. /* ffeexpr_collapse_neqv -- Collapse neqv expr
  5704. ffebld expr;
  5705. ffelexToken token;
  5706. expr = ffeexpr_collapse_neqv(expr,token);
  5707. If the result of the expr is a constant, replaces the expr with the
  5708. computed constant. */
  5709. ffebld
  5710. ffeexpr_collapse_neqv (ffebld expr, ffelexToken t)
  5711. {
  5712. ffebad error = FFEBAD;
  5713. ffebld l;
  5714. ffebld r;
  5715. ffebldConstantUnion u;
  5716. ffeinfoBasictype bt;
  5717. ffeinfoKindtype kt;
  5718. if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  5719. return expr;
  5720. l = ffebld_left (expr);
  5721. r = ffebld_right (expr);
  5722. if (ffebld_op (l) != FFEBLD_opCONTER)
  5723. return expr;
  5724. if (ffebld_op (r) != FFEBLD_opCONTER)
  5725. return expr;
  5726. switch (bt = ffeinfo_basictype (ffebld_info (expr)))
  5727. {
  5728. case FFEINFO_basictypeANY:
  5729. return expr;
  5730. case FFEINFO_basictypeINTEGER:
  5731. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  5732. {
  5733. #if FFETARGET_okINTEGER1
  5734. case FFEINFO_kindtypeINTEGER1:
  5735. error = ffetarget_neqv_integer1 (ffebld_cu_ptr_integer1 (u),
  5736. ffebld_constant_integer1 (ffebld_conter (l)),
  5737. ffebld_constant_integer1 (ffebld_conter (r)));
  5738. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer1_val
  5739. (ffebld_cu_val_integer1 (u)), expr);
  5740. break;
  5741. #endif
  5742. #if FFETARGET_okINTEGER2
  5743. case FFEINFO_kindtypeINTEGER2:
  5744. error = ffetarget_neqv_integer2 (ffebld_cu_ptr_integer2 (u),
  5745. ffebld_constant_integer2 (ffebld_conter (l)),
  5746. ffebld_constant_integer2 (ffebld_conter (r)));
  5747. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer2_val
  5748. (ffebld_cu_val_integer2 (u)), expr);
  5749. break;
  5750. #endif
  5751. #if FFETARGET_okINTEGER3
  5752. case FFEINFO_kindtypeINTEGER3:
  5753. error = ffetarget_neqv_integer3 (ffebld_cu_ptr_integer3 (u),
  5754. ffebld_constant_integer3 (ffebld_conter (l)),
  5755. ffebld_constant_integer3 (ffebld_conter (r)));
  5756. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer3_val
  5757. (ffebld_cu_val_integer3 (u)), expr);
  5758. break;
  5759. #endif
  5760. #if FFETARGET_okINTEGER4
  5761. case FFEINFO_kindtypeINTEGER4:
  5762. error = ffetarget_neqv_integer4 (ffebld_cu_ptr_integer4 (u),
  5763. ffebld_constant_integer4 (ffebld_conter (l)),
  5764. ffebld_constant_integer4 (ffebld_conter (r)));
  5765. expr = ffebld_new_conter_with_orig (ffebld_constant_new_integer4_val
  5766. (ffebld_cu_val_integer4 (u)), expr);
  5767. break;
  5768. #endif
  5769. default:
  5770. assert ("bad integer kind type" == NULL);
  5771. break;
  5772. }
  5773. break;
  5774. case FFEINFO_basictypeLOGICAL:
  5775. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  5776. {
  5777. #if FFETARGET_okLOGICAL1
  5778. case FFEINFO_kindtypeLOGICAL1:
  5779. error = ffetarget_neqv_logical1 (ffebld_cu_ptr_logical1 (u),
  5780. ffebld_constant_logical1 (ffebld_conter (l)),
  5781. ffebld_constant_logical1 (ffebld_conter (r)));
  5782. expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical1_val
  5783. (ffebld_cu_val_logical1 (u)), expr);
  5784. break;
  5785. #endif
  5786. #if FFETARGET_okLOGICAL2
  5787. case FFEINFO_kindtypeLOGICAL2:
  5788. error = ffetarget_neqv_logical2 (ffebld_cu_ptr_logical2 (u),
  5789. ffebld_constant_logical2 (ffebld_conter (l)),
  5790. ffebld_constant_logical2 (ffebld_conter (r)));
  5791. expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical2_val
  5792. (ffebld_cu_val_logical2 (u)), expr);
  5793. break;
  5794. #endif
  5795. #if FFETARGET_okLOGICAL3
  5796. case FFEINFO_kindtypeLOGICAL3:
  5797. error = ffetarget_neqv_logical3 (ffebld_cu_ptr_logical3 (u),
  5798. ffebld_constant_logical3 (ffebld_conter (l)),
  5799. ffebld_constant_logical3 (ffebld_conter (r)));
  5800. expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical3_val
  5801. (ffebld_cu_val_logical3 (u)), expr);
  5802. break;
  5803. #endif
  5804. #if FFETARGET_okLOGICAL4
  5805. case FFEINFO_kindtypeLOGICAL4:
  5806. error = ffetarget_neqv_logical4 (ffebld_cu_ptr_logical4 (u),
  5807. ffebld_constant_logical4 (ffebld_conter (l)),
  5808. ffebld_constant_logical4 (ffebld_conter (r)));
  5809. expr = ffebld_new_conter_with_orig (ffebld_constant_new_logical4_val
  5810. (ffebld_cu_val_logical4 (u)), expr);
  5811. break;
  5812. #endif
  5813. default:
  5814. assert ("bad logical kind type" == NULL);
  5815. break;
  5816. }
  5817. break;
  5818. default:
  5819. assert ("bad type" == NULL);
  5820. return expr;
  5821. }
  5822. ffebld_set_info (expr, ffeinfo_new
  5823. (bt,
  5824. kt,
  5825. 0,
  5826. FFEINFO_kindENTITY,
  5827. FFEINFO_whereCONSTANT,
  5828. FFETARGET_charactersizeNONE));
  5829. if ((error != FFEBAD)
  5830. && ffebad_start (error))
  5831. {
  5832. ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  5833. ffebad_finish ();
  5834. }
  5835. return expr;
  5836. }
  5837. /* ffeexpr_collapse_symter -- Collapse symter expr
  5838. ffebld expr;
  5839. ffelexToken token;
  5840. expr = ffeexpr_collapse_symter(expr,token);
  5841. If the result of the expr is a constant, replaces the expr with the
  5842. computed constant. */
  5843. ffebld
  5844. ffeexpr_collapse_symter (ffebld expr, ffelexToken t UNUSED)
  5845. {
  5846. ffebld r;
  5847. ffeinfoBasictype bt;
  5848. ffeinfoKindtype kt;
  5849. ffetargetCharacterSize len;
  5850. if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  5851. return expr;
  5852. if ((r = ffesymbol_init (ffebld_symter (expr))) == NULL)
  5853. return expr; /* A PARAMETER lhs in progress. */
  5854. switch (ffebld_op (r))
  5855. {
  5856. case FFEBLD_opCONTER:
  5857. break;
  5858. case FFEBLD_opANY:
  5859. return r;
  5860. default:
  5861. return expr;
  5862. }
  5863. bt = ffeinfo_basictype (ffebld_info (r));
  5864. kt = ffeinfo_kindtype (ffebld_info (r));
  5865. len = ffebld_size (r);
  5866. expr = ffebld_new_conter_with_orig (ffebld_constant_copy (ffebld_conter (r)),
  5867. expr);
  5868. ffebld_set_info (expr, ffeinfo_new
  5869. (bt,
  5870. kt,
  5871. 0,
  5872. FFEINFO_kindENTITY,
  5873. FFEINFO_whereCONSTANT,
  5874. len));
  5875. return expr;
  5876. }
  5877. /* ffeexpr_collapse_funcref -- Collapse funcref expr
  5878. ffebld expr;
  5879. ffelexToken token;
  5880. expr = ffeexpr_collapse_funcref(expr,token);
  5881. If the result of the expr is a constant, replaces the expr with the
  5882. computed constant. */
  5883. ffebld
  5884. ffeexpr_collapse_funcref (ffebld expr, ffelexToken t UNUSED)
  5885. {
  5886. return expr; /* ~~someday go ahead and collapse these,
  5887. though not required */
  5888. }
  5889. /* ffeexpr_collapse_arrayref -- Collapse arrayref expr
  5890. ffebld expr;
  5891. ffelexToken token;
  5892. expr = ffeexpr_collapse_arrayref(expr,token);
  5893. If the result of the expr is a constant, replaces the expr with the
  5894. computed constant. */
  5895. ffebld
  5896. ffeexpr_collapse_arrayref (ffebld expr, ffelexToken t UNUSED)
  5897. {
  5898. return expr;
  5899. }
  5900. /* ffeexpr_collapse_substr -- Collapse substr expr
  5901. ffebld expr;
  5902. ffelexToken token;
  5903. expr = ffeexpr_collapse_substr(expr,token);
  5904. If the result of the expr is a constant, replaces the expr with the
  5905. computed constant. */
  5906. ffebld
  5907. ffeexpr_collapse_substr (ffebld expr, ffelexToken t)
  5908. {
  5909. ffebad error = FFEBAD;
  5910. ffebld l;
  5911. ffebld r;
  5912. ffebld start;
  5913. ffebld stop;
  5914. ffebldConstantUnion u;
  5915. ffeinfoKindtype kt;
  5916. ffetargetCharacterSize len;
  5917. ffetargetIntegerDefault first;
  5918. ffetargetIntegerDefault last;
  5919. if (ffeinfo_where (ffebld_info (expr)) != FFEINFO_whereCONSTANT)
  5920. return expr;
  5921. l = ffebld_left (expr);
  5922. r = ffebld_right (expr); /* opITEM. */
  5923. if (ffebld_op (l) != FFEBLD_opCONTER)
  5924. return expr;
  5925. kt = ffeinfo_kindtype (ffebld_info (l));
  5926. len = ffebld_size (l);
  5927. start = ffebld_head (r);
  5928. stop = ffebld_head (ffebld_trail (r));
  5929. if (start == NULL)
  5930. first = 1;
  5931. else
  5932. {
  5933. if ((ffebld_op (start) != FFEBLD_opCONTER)
  5934. || (ffeinfo_basictype (ffebld_info (start)) != FFEINFO_basictypeINTEGER)
  5935. || (ffeinfo_kindtype (ffebld_info (start))
  5936. != FFEINFO_kindtypeINTEGERDEFAULT))
  5937. return expr;
  5938. first = ffebld_constant_integerdefault (ffebld_conter (start));
  5939. }
  5940. if (stop == NULL)
  5941. last = len;
  5942. else
  5943. {
  5944. if ((ffebld_op (stop) != FFEBLD_opCONTER)
  5945. || (ffeinfo_basictype (ffebld_info (stop)) != FFEINFO_basictypeINTEGER)
  5946. || (ffeinfo_kindtype (ffebld_info (stop))
  5947. != FFEINFO_kindtypeINTEGERDEFAULT))
  5948. return expr;
  5949. last = ffebld_constant_integerdefault (ffebld_conter (stop));
  5950. }
  5951. /* Handle problems that should have already been diagnosed, but
  5952. left in the expression tree. */
  5953. if (first <= 0)
  5954. first = 1;
  5955. if (last < first)
  5956. last = first + len - 1;
  5957. if ((first == 1) && (last == len))
  5958. { /* Same as original. */
  5959. expr = ffebld_new_conter_with_orig (ffebld_constant_copy
  5960. (ffebld_conter (l)), expr);
  5961. ffebld_set_info (expr, ffeinfo_new
  5962. (FFEINFO_basictypeCHARACTER,
  5963. kt,
  5964. 0,
  5965. FFEINFO_kindENTITY,
  5966. FFEINFO_whereCONSTANT,
  5967. len));
  5968. return expr;
  5969. }
  5970. switch (ffeinfo_basictype (ffebld_info (expr)))
  5971. {
  5972. case FFEINFO_basictypeANY:
  5973. return expr;
  5974. case FFEINFO_basictypeCHARACTER:
  5975. switch (kt = ffeinfo_kindtype (ffebld_info (expr)))
  5976. {
  5977. #if FFETARGET_okCHARACTER1
  5978. case FFEINFO_kindtypeCHARACTER1:
  5979. error = ffetarget_substr_character1 (ffebld_cu_ptr_character1 (u),
  5980. ffebld_constant_character1 (ffebld_conter (l)), first, last,
  5981. ffebld_constant_pool (), &len);
  5982. expr = ffebld_new_conter_with_orig (ffebld_constant_new_character1_val
  5983. (ffebld_cu_val_character1 (u)), expr);
  5984. break;
  5985. #endif
  5986. #if FFETARGET_okCHARACTER2
  5987. case FFEINFO_kindtypeCHARACTER2:
  5988. error = ffetarget_substr_character2 (ffebld_cu_ptr_character2 (u),
  5989. ffebld_constant_character2 (ffebld_conter (l)), first, last,
  5990. ffebld_constant_pool (), &len);
  5991. expr = ffebld_new_conter_with_orig (ffebld_constant_new_character2_val
  5992. (ffebld_cu_val_character2 (u)), expr);
  5993. break;
  5994. #endif
  5995. #if FFETARGET_okCHARACTER3
  5996. case FFEINFO_kindtypeCHARACTER3:
  5997. error = ffetarget_substr_character3 (ffebld_cu_ptr_character3 (u),
  5998. ffebld_constant_character3 (ffebld_conter (l)), first, last,
  5999. ffebld_constant_pool (), &len);
  6000. expr = ffebld_new_conter_with_orig (ffebld_constant_new_character3_val
  6001. (ffebld_cu_val_character3 (u)), expr);
  6002. break;
  6003. #endif
  6004. #if FFETARGET_okCHARACTER4
  6005. case FFEINFO_kindtypeCHARACTER4:
  6006. error = ffetarget_substr_character4 (ffebld_cu_ptr_character4 (u),
  6007. ffebld_constant_character4 (ffebld_conter (l)), first, last,
  6008. ffebld_constant_pool (), &len);
  6009. expr = ffebld_new_conter_with_orig (ffebld_constant_new_character4_val
  6010. (ffebld_cu_val_character4 (u)), expr);
  6011. break;
  6012. #endif
  6013. default:
  6014. assert ("bad character kind type" == NULL);
  6015. break;
  6016. }
  6017. break;
  6018. default:
  6019. assert ("bad type" == NULL);
  6020. return expr;
  6021. }
  6022. ffebld_set_info (expr, ffeinfo_new
  6023. (FFEINFO_basictypeCHARACTER,
  6024. kt,
  6025. 0,
  6026. FFEINFO_kindENTITY,
  6027. FFEINFO_whereCONSTANT,
  6028. len));
  6029. if ((error != FFEBAD)
  6030. && ffebad_start (error))
  6031. {
  6032. ffebad_here (0, ffelex_token_where_line (t), ffelex_token_where_column (t));
  6033. ffebad_finish ();
  6034. }
  6035. return expr;
  6036. }
  6037. /* ffeexpr_convert -- Convert source expression to given type
  6038. ffebld source;
  6039. ffelexToken source_token;
  6040. ffelexToken dest_token; // Any appropriate token for "destination".
  6041. ffeinfoBasictype bt;
  6042. ffeinfoKindtype kt;
  6043. ffetargetCharactersize sz;
  6044. ffeexprContext context; // Mainly LET or DATA.
  6045. source = ffeexpr_convert(source,source_token,dest_token,bt,kt,sz,context);
  6046. If the expression conforms, returns the source expression. Otherwise
  6047. returns source wrapped in a convert node doing the conversion, or
  6048. ANY wrapped in convert if there is a conversion error (and issues an
  6049. error message). Be sensitive to the context for certain aspects of
  6050. the conversion. */
  6051. ffebld
  6052. ffeexpr_convert (ffebld source, ffelexToken source_token, ffelexToken dest_token,
  6053. ffeinfoBasictype bt, ffeinfoKindtype kt, ffeinfoRank rk,
  6054. ffetargetCharacterSize sz, ffeexprContext context)
  6055. {
  6056. bool bad;
  6057. ffeinfo info;
  6058. ffeinfoWhere wh;
  6059. info = ffebld_info (source);
  6060. if ((bt != ffeinfo_basictype (info))
  6061. || (kt != ffeinfo_kindtype (info))
  6062. || (rk != 0) /* Can't convert from or to arrays yet. */
  6063. || (ffeinfo_rank (info) != 0)
  6064. || (sz != ffebld_size_known (source)))
  6065. #if 0 /* Nobody seems to need this spurious CONVERT node. */
  6066. || ((context != FFEEXPR_contextLET)
  6067. && (bt == FFEINFO_basictypeCHARACTER)
  6068. && (sz == FFETARGET_charactersizeNONE)))
  6069. #endif
  6070. {
  6071. switch (ffeinfo_basictype (info))
  6072. {
  6073. case FFEINFO_basictypeLOGICAL:
  6074. switch (bt)
  6075. {
  6076. case FFEINFO_basictypeLOGICAL:
  6077. bad = FALSE;
  6078. break;
  6079. case FFEINFO_basictypeINTEGER:
  6080. bad = !ffe_is_ugly_logint ();
  6081. break;
  6082. case FFEINFO_basictypeCHARACTER:
  6083. bad = ffe_is_pedantic ()
  6084. || !(ffe_is_ugly_init ()
  6085. && (context == FFEEXPR_contextDATA));
  6086. break;
  6087. default:
  6088. bad = TRUE;
  6089. break;
  6090. }
  6091. break;
  6092. case FFEINFO_basictypeINTEGER:
  6093. switch (bt)
  6094. {
  6095. case FFEINFO_basictypeINTEGER:
  6096. case FFEINFO_basictypeREAL:
  6097. case FFEINFO_basictypeCOMPLEX:
  6098. bad = FALSE;
  6099. break;
  6100. case FFEINFO_basictypeLOGICAL:
  6101. bad = !ffe_is_ugly_logint ();
  6102. break;
  6103. case FFEINFO_basictypeCHARACTER:
  6104. bad = ffe_is_pedantic ()
  6105. || !(ffe_is_ugly_init ()
  6106. && (context == FFEEXPR_contextDATA));
  6107. break;
  6108. default:
  6109. bad = TRUE;
  6110. break;
  6111. }
  6112. break;
  6113. case FFEINFO_basictypeREAL:
  6114. case FFEINFO_basictypeCOMPLEX:
  6115. switch (bt)
  6116. {
  6117. case FFEINFO_basictypeINTEGER:
  6118. case FFEINFO_basictypeREAL:
  6119. case FFEINFO_basictypeCOMPLEX:
  6120. bad = FALSE;
  6121. break;
  6122. case FFEINFO_basictypeCHARACTER:
  6123. bad = TRUE;
  6124. break;
  6125. default:
  6126. bad = TRUE;
  6127. break;
  6128. }
  6129. break;
  6130. case FFEINFO_basictypeCHARACTER:
  6131. bad = (bt != FFEINFO_basictypeCHARACTER)
  6132. && (ffe_is_pedantic ()
  6133. || (bt != FFEINFO_basictypeINTEGER)
  6134. || !(ffe_is_ugly_init ()
  6135. && (context == FFEEXPR_contextDATA)));
  6136. break;
  6137. case FFEINFO_basictypeTYPELESS:
  6138. case FFEINFO_basictypeHOLLERITH:
  6139. bad = ffe_is_pedantic ()
  6140. || !(ffe_is_ugly_init ()
  6141. && ((context == FFEEXPR_contextDATA)
  6142. || (context == FFEEXPR_contextLET)));
  6143. break;
  6144. default:
  6145. bad = TRUE;
  6146. break;
  6147. }
  6148. if (!bad && ((rk != 0) || (ffeinfo_rank (info) != 0)))
  6149. bad = TRUE;
  6150. if (bad && (bt != FFEINFO_basictypeANY) && (kt != FFEINFO_kindtypeANY)
  6151. && (ffeinfo_basictype (info) != FFEINFO_basictypeANY)
  6152. && (ffeinfo_kindtype (info) != FFEINFO_kindtypeANY)
  6153. && (ffeinfo_where (info) != FFEINFO_whereANY))
  6154. {
  6155. if (ffebad_start (FFEBAD_BAD_TYPES))
  6156. {
  6157. if (dest_token == NULL)
  6158. ffebad_here (0, ffewhere_line_unknown (),
  6159. ffewhere_column_unknown ());
  6160. else
  6161. ffebad_here (0, ffelex_token_where_line (dest_token),
  6162. ffelex_token_where_column (dest_token));
  6163. assert (source_token != NULL);
  6164. ffebad_here (1, ffelex_token_where_line (source_token),
  6165. ffelex_token_where_column (source_token));
  6166. ffebad_finish ();
  6167. }
  6168. source = ffebld_new_any ();
  6169. ffebld_set_info (source, ffeinfo_new_any ());
  6170. }
  6171. else
  6172. {
  6173. switch (ffeinfo_where (info))
  6174. {
  6175. case FFEINFO_whereCONSTANT:
  6176. wh = FFEINFO_whereCONSTANT;
  6177. break;
  6178. case FFEINFO_whereIMMEDIATE:
  6179. wh = FFEINFO_whereIMMEDIATE;
  6180. break;
  6181. default:
  6182. wh = FFEINFO_whereFLEETING;
  6183. break;
  6184. }
  6185. source = ffebld_new_convert (source);
  6186. ffebld_set_info (source, ffeinfo_new
  6187. (bt,
  6188. kt,
  6189. 0,
  6190. FFEINFO_kindENTITY,
  6191. wh,
  6192. sz));
  6193. source = ffeexpr_collapse_convert (source, source_token);
  6194. }
  6195. }
  6196. return source;
  6197. }
  6198. /* ffeexpr_convert_expr -- Convert source expr to conform to dest expr
  6199. ffebld source;
  6200. ffebld dest;
  6201. ffelexToken source_token;
  6202. ffelexToken dest_token;
  6203. ffeexprContext context;
  6204. source = ffeexpr_convert_expr(source,source_token,dest,dest_token,context);
  6205. If the expressions conform, returns the source expression. Otherwise
  6206. returns source wrapped in a convert node doing the conversion, or
  6207. ANY wrapped in convert if there is a conversion error (and issues an
  6208. error message). Be sensitive to the context, such as LET or DATA. */
  6209. ffebld
  6210. ffeexpr_convert_expr (ffebld source, ffelexToken source_token, ffebld dest,
  6211. ffelexToken dest_token, ffeexprContext context)
  6212. {