PageRenderTime 36ms CodeModel.GetById 2ms 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

Large files files are truncated, but you can click here to view the full file

  1. /* expr.c -- Implementation File (module.c template V1.0)
  2. Copyright (C) 1995-1998 Free Software Foundation, Inc.
  3. Contributed by James Craig Burley.
  4. 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

Large files files are truncated, but you can click here to view the full file