]>
Commit | Line | Data |
---|---|---|
6de9cd9a | 1 | /* Intrinsic translation |
0eadc091 RS |
2 | Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 |
3 | Free Software Foundation, Inc. | |
6de9cd9a DN |
4 | Contributed by Paul Brook <paul@nowt.org> |
5 | and Steven Bosscher <s.bosscher@student.tudelft.nl> | |
6 | ||
9fc4d79b | 7 | This file is part of GCC. |
6de9cd9a | 8 | |
9fc4d79b TS |
9 | GCC is free software; you can redistribute it and/or modify it under |
10 | the terms of the GNU General Public License as published by the Free | |
11 | Software Foundation; either version 2, or (at your option) any later | |
12 | version. | |
6de9cd9a | 13 | |
9fc4d79b TS |
14 | GCC is distributed in the hope that it will be useful, but WITHOUT ANY |
15 | WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
16 | FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
17 | for more details. | |
6de9cd9a DN |
18 | |
19 | You should have received a copy of the GNU General Public License | |
9fc4d79b | 20 | along with GCC; see the file COPYING. If not, write to the Free |
ab57747b KC |
21 | Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA |
22 | 02110-1301, USA. */ | |
6de9cd9a DN |
23 | |
24 | /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */ | |
25 | ||
26 | #include "config.h" | |
27 | #include "system.h" | |
28 | #include "coretypes.h" | |
29 | #include "tree.h" | |
6de9cd9a DN |
30 | #include "ggc.h" |
31 | #include "toplev.h" | |
32 | #include "real.h" | |
eadf906f | 33 | #include "tree-gimple.h" |
6de9cd9a | 34 | #include "flags.h" |
6de9cd9a | 35 | #include "gfortran.h" |
f8e566e5 | 36 | #include "arith.h" |
6de9cd9a DN |
37 | #include "intrinsic.h" |
38 | #include "trans.h" | |
39 | #include "trans-const.h" | |
40 | #include "trans-types.h" | |
41 | #include "trans-array.h" | |
42 | #include "defaults.h" | |
43 | /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */ | |
44 | #include "trans-stmt.h" | |
45 | ||
46 | /* This maps fortran intrinsic math functions to external library or GCC | |
47 | builtin functions. */ | |
48 | typedef struct gfc_intrinsic_map_t GTY(()) | |
49 | { | |
50 | /* The explicit enum is required to work around inadequacies in the | |
51 | garbage collection/gengtype parsing mechanism. */ | |
52 | enum gfc_generic_isym_id id; | |
53 | ||
54 | /* Enum value from the "language-independent", aka C-centric, part | |
55 | of gcc, or END_BUILTINS of no such value set. */ | |
644cb69f FXC |
56 | enum built_in_function code_r4; |
57 | enum built_in_function code_r8; | |
58 | enum built_in_function code_r10; | |
59 | enum built_in_function code_r16; | |
60 | enum built_in_function code_c4; | |
61 | enum built_in_function code_c8; | |
62 | enum built_in_function code_c10; | |
63 | enum built_in_function code_c16; | |
6de9cd9a DN |
64 | |
65 | /* True if the naming pattern is to prepend "c" for complex and | |
66 | append "f" for kind=4. False if the naming pattern is to | |
644cb69f | 67 | prepend "_gfortran_" and append "[rc](4|8|10|16)". */ |
6de9cd9a DN |
68 | bool libm_name; |
69 | ||
70 | /* True if a complex version of the function exists. */ | |
71 | bool complex_available; | |
72 | ||
73 | /* True if the function should be marked const. */ | |
74 | bool is_constant; | |
75 | ||
76 | /* The base library name of this function. */ | |
77 | const char *name; | |
78 | ||
79 | /* Cache decls created for the various operand types. */ | |
80 | tree real4_decl; | |
81 | tree real8_decl; | |
644cb69f FXC |
82 | tree real10_decl; |
83 | tree real16_decl; | |
6de9cd9a DN |
84 | tree complex4_decl; |
85 | tree complex8_decl; | |
644cb69f FXC |
86 | tree complex10_decl; |
87 | tree complex16_decl; | |
6de9cd9a DN |
88 | } |
89 | gfc_intrinsic_map_t; | |
90 | ||
91 | /* ??? The NARGS==1 hack here is based on the fact that (c99 at least) | |
92 | defines complex variants of all of the entries in mathbuiltins.def | |
93 | except for atan2. */ | |
644cb69f FXC |
94 | #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \ |
95 | { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \ | |
96 | BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, 0, 0, 0, 0, true, \ | |
97 | false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \ | |
98 | NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE}, | |
99 | ||
100 | #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \ | |
101 | { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \ | |
102 | BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, \ | |
103 | BUILT_IN_C ## ID, BUILT_IN_C ## ID ## L, BUILT_IN_C ## ID ## L, true, \ | |
104 | true, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \ | |
105 | NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE}, | |
6de9cd9a DN |
106 | |
107 | #define LIBM_FUNCTION(ID, NAME, HAVE_COMPLEX) \ | |
644cb69f FXC |
108 | { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ |
109 | END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ | |
110 | true, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \ | |
111 | NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE } | |
6de9cd9a DN |
112 | |
113 | #define LIBF_FUNCTION(ID, NAME, HAVE_COMPLEX) \ | |
644cb69f FXC |
114 | { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ |
115 | END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ | |
116 | false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \ | |
117 | NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE } | |
6de9cd9a DN |
118 | |
119 | static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] = | |
120 | { | |
121 | /* Functions built into gcc itself. */ | |
122 | #include "mathbuiltins.def" | |
123 | ||
124 | /* Functions in libm. */ | |
125 | /* ??? This does exist as BUILT_IN_SCALBN, but doesn't quite fit the | |
126 | pattern for other mathbuiltins.def entries. At present we have no | |
127 | optimizations for this in the common sources. */ | |
128 | LIBM_FUNCTION (SCALE, "scalbn", false), | |
129 | ||
130 | /* Functions in libgfortran. */ | |
131 | LIBF_FUNCTION (FRACTION, "fraction", false), | |
132 | LIBF_FUNCTION (NEAREST, "nearest", false), | |
cc6d3bde | 133 | LIBF_FUNCTION (RRSPACING, "rrspacing", false), |
6de9cd9a | 134 | LIBF_FUNCTION (SET_EXPONENT, "set_exponent", false), |
cc6d3bde | 135 | LIBF_FUNCTION (SPACING, "spacing", false), |
6de9cd9a DN |
136 | |
137 | /* End the list. */ | |
138 | LIBF_FUNCTION (NONE, NULL, false) | |
139 | }; | |
140 | #undef DEFINE_MATH_BUILTIN | |
e8525382 | 141 | #undef DEFINE_MATH_BUILTIN_C |
6de9cd9a DN |
142 | #undef LIBM_FUNCTION |
143 | #undef LIBF_FUNCTION | |
144 | ||
145 | /* Structure for storing components of a floating number to be used by | |
146 | elemental functions to manipulate reals. */ | |
147 | typedef struct | |
148 | { | |
f7b529fa | 149 | tree arg; /* Variable tree to view convert to integer. */ |
6de9cd9a DN |
150 | tree expn; /* Variable tree to save exponent. */ |
151 | tree frac; /* Variable tree to save fraction. */ | |
152 | tree smask; /* Constant tree of sign's mask. */ | |
153 | tree emask; /* Constant tree of exponent's mask. */ | |
154 | tree fmask; /* Constant tree of fraction's mask. */ | |
046dcd57 FW |
155 | tree edigits; /* Constant tree of the number of exponent bits. */ |
156 | tree fdigits; /* Constant tree of the number of fraction bits. */ | |
6de9cd9a DN |
157 | tree f1; /* Constant tree of the f1 defined in the real model. */ |
158 | tree bias; /* Constant tree of the bias of exponent in the memory. */ | |
159 | tree type; /* Type tree of arg1. */ | |
160 | tree mtype; /* Type tree of integer type. Kind is that of arg1. */ | |
161 | } | |
162 | real_compnt_info; | |
163 | ||
f9f770a8 | 164 | enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR }; |
6de9cd9a DN |
165 | |
166 | /* Evaluate the arguments to an intrinsic function. */ | |
167 | ||
168 | static tree | |
169 | gfc_conv_intrinsic_function_args (gfc_se * se, gfc_expr * expr) | |
170 | { | |
171 | gfc_actual_arglist *actual; | |
e15e9be3 PT |
172 | gfc_expr *e; |
173 | gfc_intrinsic_arg *formal; | |
6de9cd9a | 174 | gfc_se argse; |
e15e9be3 | 175 | tree args; |
6de9cd9a DN |
176 | |
177 | args = NULL_TREE; | |
e15e9be3 PT |
178 | formal = expr->value.function.isym->formal; |
179 | ||
180 | for (actual = expr->value.function.actual; actual; actual = actual->next, | |
181 | formal = formal ? formal->next : NULL) | |
6de9cd9a | 182 | { |
e15e9be3 | 183 | e = actual->expr; |
aa9c57ec | 184 | /* Skip omitted optional arguments. */ |
e15e9be3 | 185 | if (!e) |
6de9cd9a DN |
186 | continue; |
187 | ||
188 | /* Evaluate the parameter. This will substitute scalarized | |
f7b529fa | 189 | references automatically. */ |
6de9cd9a DN |
190 | gfc_init_se (&argse, se); |
191 | ||
e15e9be3 | 192 | if (e->ts.type == BT_CHARACTER) |
6de9cd9a | 193 | { |
e15e9be3 | 194 | gfc_conv_expr (&argse, e); |
6de9cd9a DN |
195 | gfc_conv_string_parameter (&argse); |
196 | args = gfc_chainon_list (args, argse.string_length); | |
197 | } | |
198 | else | |
e15e9be3 PT |
199 | gfc_conv_expr_val (&argse, e); |
200 | ||
201 | /* If an optional argument is itself an optional dummy argument, | |
202 | check its presence and substitute a null if absent. */ | |
203 | if (e->expr_type ==EXPR_VARIABLE | |
204 | && e->symtree->n.sym->attr.optional | |
205 | && formal | |
206 | && formal->optional) | |
207 | gfc_conv_missing_dummy (&argse, e, formal->ts); | |
6de9cd9a DN |
208 | |
209 | gfc_add_block_to_block (&se->pre, &argse.pre); | |
210 | gfc_add_block_to_block (&se->post, &argse.post); | |
211 | args = gfc_chainon_list (args, argse.expr); | |
212 | } | |
213 | return args; | |
214 | } | |
215 | ||
216 | ||
217 | /* Conversions between different types are output by the frontend as | |
218 | intrinsic functions. We implement these directly with inline code. */ | |
219 | ||
220 | static void | |
221 | gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr) | |
222 | { | |
223 | tree type; | |
224 | tree arg; | |
225 | ||
226 | /* Evaluate the argument. */ | |
227 | type = gfc_typenode_for_spec (&expr->ts); | |
6e45f57b | 228 | gcc_assert (expr->value.function.actual->expr); |
6de9cd9a DN |
229 | arg = gfc_conv_intrinsic_function_args (se, expr); |
230 | arg = TREE_VALUE (arg); | |
231 | ||
232 | /* Conversion from complex to non-complex involves taking the real | |
233 | component of the value. */ | |
234 | if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE | |
235 | && expr->ts.type != BT_COMPLEX) | |
236 | { | |
237 | tree artype; | |
238 | ||
239 | artype = TREE_TYPE (TREE_TYPE (arg)); | |
240 | arg = build1 (REALPART_EXPR, artype, arg); | |
241 | } | |
242 | ||
243 | se->expr = convert (type, arg); | |
244 | } | |
245 | ||
4fdb5c71 TS |
246 | /* This is needed because the gcc backend only implements |
247 | FIX_TRUNC_EXPR, which is the same as INT() in Fortran. | |
248 | FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1 | |
6de9cd9a DN |
249 | Similarly for CEILING. */ |
250 | ||
251 | static tree | |
252 | build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up) | |
253 | { | |
254 | tree tmp; | |
255 | tree cond; | |
256 | tree argtype; | |
257 | tree intval; | |
258 | ||
259 | argtype = TREE_TYPE (arg); | |
260 | arg = gfc_evaluate_now (arg, pblock); | |
261 | ||
262 | intval = convert (type, arg); | |
263 | intval = gfc_evaluate_now (intval, pblock); | |
264 | ||
265 | tmp = convert (argtype, intval); | |
923ab88c | 266 | cond = build2 (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg); |
6de9cd9a | 267 | |
923ab88c | 268 | tmp = build2 (up ? PLUS_EXPR : MINUS_EXPR, type, intval, |
e805a599 | 269 | build_int_cst (type, 1)); |
923ab88c | 270 | tmp = build3 (COND_EXPR, type, cond, intval, tmp); |
6de9cd9a DN |
271 | return tmp; |
272 | } | |
273 | ||
274 | ||
275 | /* This is needed because the gcc backend only implements FIX_TRUNC_EXPR | |
276 | NINT(x) = INT(x + ((x > 0) ? 0.5 : -0.5)). */ | |
277 | ||
278 | static tree | |
279 | build_round_expr (stmtblock_t * pblock, tree arg, tree type) | |
280 | { | |
281 | tree tmp; | |
282 | tree cond; | |
283 | tree neg; | |
284 | tree pos; | |
285 | tree argtype; | |
286 | REAL_VALUE_TYPE r; | |
287 | ||
288 | argtype = TREE_TYPE (arg); | |
289 | arg = gfc_evaluate_now (arg, pblock); | |
290 | ||
291 | real_from_string (&r, "0.5"); | |
292 | pos = build_real (argtype, r); | |
293 | ||
294 | real_from_string (&r, "-0.5"); | |
295 | neg = build_real (argtype, r); | |
296 | ||
297 | tmp = gfc_build_const (argtype, integer_zero_node); | |
10c7a96f | 298 | cond = fold_build2 (GT_EXPR, boolean_type_node, arg, tmp); |
6de9cd9a | 299 | |
10c7a96f SB |
300 | tmp = fold_build3 (COND_EXPR, argtype, cond, pos, neg); |
301 | tmp = fold_build2 (PLUS_EXPR, argtype, arg, tmp); | |
302 | return fold_build1 (FIX_TRUNC_EXPR, type, tmp); | |
6de9cd9a DN |
303 | } |
304 | ||
305 | ||
306 | /* Convert a real to an integer using a specific rounding mode. | |
307 | Ideally we would just build the corresponding GENERIC node, | |
308 | however the RTL expander only actually supports FIX_TRUNC_EXPR. */ | |
309 | ||
310 | static tree | |
e743d142 | 311 | build_fix_expr (stmtblock_t * pblock, tree arg, tree type, |
f9f770a8 | 312 | enum rounding_mode op) |
6de9cd9a DN |
313 | { |
314 | switch (op) | |
315 | { | |
f9f770a8 | 316 | case RND_FLOOR: |
6de9cd9a DN |
317 | return build_fixbound_expr (pblock, arg, type, 0); |
318 | break; | |
319 | ||
f9f770a8 | 320 | case RND_CEIL: |
6de9cd9a DN |
321 | return build_fixbound_expr (pblock, arg, type, 1); |
322 | break; | |
323 | ||
f9f770a8 | 324 | case RND_ROUND: |
6de9cd9a DN |
325 | return build_round_expr (pblock, arg, type); |
326 | ||
327 | default: | |
f9f770a8 RG |
328 | gcc_assert (op == RND_TRUNC); |
329 | return build1 (FIX_TRUNC_EXPR, type, arg); | |
6de9cd9a DN |
330 | } |
331 | } | |
332 | ||
333 | ||
334 | /* Round a real value using the specified rounding mode. | |
335 | We use a temporary integer of that same kind size as the result. | |
e743d142 | 336 | Values larger than those that can be represented by this kind are |
e2ae1407 | 337 | unchanged, as they will not be accurate enough to represent the |
e743d142 | 338 | rounding. |
6de9cd9a DN |
339 | huge = HUGE (KIND (a)) |
340 | aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a | |
341 | */ | |
342 | ||
343 | static void | |
f9f770a8 | 344 | gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op) |
6de9cd9a DN |
345 | { |
346 | tree type; | |
347 | tree itype; | |
348 | tree arg; | |
349 | tree tmp; | |
350 | tree cond; | |
f8e566e5 | 351 | mpfr_t huge; |
6de9cd9a DN |
352 | int n; |
353 | int kind; | |
354 | ||
355 | kind = expr->ts.kind; | |
356 | ||
357 | n = END_BUILTINS; | |
358 | /* We have builtin functions for some cases. */ | |
359 | switch (op) | |
360 | { | |
f9f770a8 | 361 | case RND_ROUND: |
6de9cd9a DN |
362 | switch (kind) |
363 | { | |
364 | case 4: | |
365 | n = BUILT_IN_ROUNDF; | |
366 | break; | |
367 | ||
368 | case 8: | |
369 | n = BUILT_IN_ROUND; | |
370 | break; | |
644cb69f FXC |
371 | |
372 | case 10: | |
373 | case 16: | |
374 | n = BUILT_IN_ROUNDL; | |
375 | break; | |
6de9cd9a DN |
376 | } |
377 | break; | |
378 | ||
f9f770a8 | 379 | case RND_TRUNC: |
6de9cd9a DN |
380 | switch (kind) |
381 | { | |
382 | case 4: | |
e743d142 | 383 | n = BUILT_IN_TRUNCF; |
6de9cd9a DN |
384 | break; |
385 | ||
386 | case 8: | |
e743d142 | 387 | n = BUILT_IN_TRUNC; |
6de9cd9a | 388 | break; |
644cb69f FXC |
389 | |
390 | case 10: | |
391 | case 16: | |
392 | n = BUILT_IN_TRUNCL; | |
393 | break; | |
6de9cd9a | 394 | } |
e743d142 TS |
395 | break; |
396 | ||
397 | default: | |
398 | gcc_unreachable (); | |
6de9cd9a DN |
399 | } |
400 | ||
401 | /* Evaluate the argument. */ | |
6e45f57b | 402 | gcc_assert (expr->value.function.actual->expr); |
6de9cd9a DN |
403 | arg = gfc_conv_intrinsic_function_args (se, expr); |
404 | ||
405 | /* Use a builtin function if one exists. */ | |
406 | if (n != END_BUILTINS) | |
407 | { | |
408 | tmp = built_in_decls[n]; | |
3380b802 | 409 | se->expr = build_function_call_expr (tmp, arg); |
6de9cd9a DN |
410 | return; |
411 | } | |
412 | ||
413 | /* This code is probably redundant, but we'll keep it lying around just | |
414 | in case. */ | |
415 | type = gfc_typenode_for_spec (&expr->ts); | |
416 | arg = TREE_VALUE (arg); | |
417 | arg = gfc_evaluate_now (arg, &se->pre); | |
418 | ||
419 | /* Test if the value is too large to handle sensibly. */ | |
f8e566e5 SK |
420 | gfc_set_model_kind (kind); |
421 | mpfr_init (huge); | |
e7a2d5fb | 422 | n = gfc_validate_kind (BT_INTEGER, kind, false); |
f8e566e5 SK |
423 | mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE); |
424 | tmp = gfc_conv_mpfr_to_tree (huge, kind); | |
923ab88c | 425 | cond = build2 (LT_EXPR, boolean_type_node, arg, tmp); |
6de9cd9a | 426 | |
f8e566e5 SK |
427 | mpfr_neg (huge, huge, GFC_RND_MODE); |
428 | tmp = gfc_conv_mpfr_to_tree (huge, kind); | |
923ab88c TS |
429 | tmp = build2 (GT_EXPR, boolean_type_node, arg, tmp); |
430 | cond = build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp); | |
6de9cd9a DN |
431 | itype = gfc_get_int_type (kind); |
432 | ||
433 | tmp = build_fix_expr (&se->pre, arg, itype, op); | |
434 | tmp = convert (type, tmp); | |
923ab88c | 435 | se->expr = build3 (COND_EXPR, type, cond, tmp, arg); |
f8e566e5 | 436 | mpfr_clear (huge); |
6de9cd9a DN |
437 | } |
438 | ||
439 | ||
440 | /* Convert to an integer using the specified rounding mode. */ | |
441 | ||
442 | static void | |
f9f770a8 | 443 | gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op) |
6de9cd9a DN |
444 | { |
445 | tree type; | |
446 | tree arg; | |
447 | ||
448 | /* Evaluate the argument. */ | |
449 | type = gfc_typenode_for_spec (&expr->ts); | |
6e45f57b | 450 | gcc_assert (expr->value.function.actual->expr); |
6de9cd9a DN |
451 | arg = gfc_conv_intrinsic_function_args (se, expr); |
452 | arg = TREE_VALUE (arg); | |
453 | ||
454 | if (TREE_CODE (TREE_TYPE (arg)) == INTEGER_TYPE) | |
455 | { | |
456 | /* Conversion to a different integer kind. */ | |
457 | se->expr = convert (type, arg); | |
458 | } | |
459 | else | |
460 | { | |
461 | /* Conversion from complex to non-complex involves taking the real | |
462 | component of the value. */ | |
463 | if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE | |
464 | && expr->ts.type != BT_COMPLEX) | |
465 | { | |
466 | tree artype; | |
467 | ||
468 | artype = TREE_TYPE (TREE_TYPE (arg)); | |
469 | arg = build1 (REALPART_EXPR, artype, arg); | |
470 | } | |
471 | ||
472 | se->expr = build_fix_expr (&se->pre, arg, type, op); | |
473 | } | |
474 | } | |
475 | ||
476 | ||
477 | /* Get the imaginary component of a value. */ | |
478 | ||
479 | static void | |
480 | gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr) | |
481 | { | |
482 | tree arg; | |
483 | ||
484 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
485 | arg = TREE_VALUE (arg); | |
486 | se->expr = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg); | |
487 | } | |
488 | ||
489 | ||
490 | /* Get the complex conjugate of a value. */ | |
491 | ||
492 | static void | |
493 | gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr) | |
494 | { | |
495 | tree arg; | |
496 | ||
497 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
498 | arg = TREE_VALUE (arg); | |
499 | se->expr = build1 (CONJ_EXPR, TREE_TYPE (arg), arg); | |
500 | } | |
501 | ||
502 | ||
503 | /* Initialize function decls for library functions. The external functions | |
504 | are created as required. Builtin functions are added here. */ | |
505 | ||
506 | void | |
507 | gfc_build_intrinsic_lib_fndecls (void) | |
508 | { | |
509 | gfc_intrinsic_map_t *m; | |
510 | ||
511 | /* Add GCC builtin functions. */ | |
512 | for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++) | |
513 | { | |
644cb69f FXC |
514 | if (m->code_r4 != END_BUILTINS) |
515 | m->real4_decl = built_in_decls[m->code_r4]; | |
516 | if (m->code_r8 != END_BUILTINS) | |
517 | m->real8_decl = built_in_decls[m->code_r8]; | |
518 | if (m->code_r10 != END_BUILTINS) | |
519 | m->real10_decl = built_in_decls[m->code_r10]; | |
520 | if (m->code_r16 != END_BUILTINS) | |
521 | m->real16_decl = built_in_decls[m->code_r16]; | |
522 | if (m->code_c4 != END_BUILTINS) | |
523 | m->complex4_decl = built_in_decls[m->code_c4]; | |
524 | if (m->code_c8 != END_BUILTINS) | |
525 | m->complex8_decl = built_in_decls[m->code_c8]; | |
526 | if (m->code_c10 != END_BUILTINS) | |
527 | m->complex10_decl = built_in_decls[m->code_c10]; | |
528 | if (m->code_c16 != END_BUILTINS) | |
529 | m->complex16_decl = built_in_decls[m->code_c16]; | |
6de9cd9a DN |
530 | } |
531 | } | |
532 | ||
533 | ||
534 | /* Create a fndecl for a simple intrinsic library function. */ | |
535 | ||
536 | static tree | |
537 | gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr) | |
538 | { | |
539 | tree type; | |
540 | tree argtypes; | |
541 | tree fndecl; | |
542 | gfc_actual_arglist *actual; | |
543 | tree *pdecl; | |
544 | gfc_typespec *ts; | |
545 | char name[GFC_MAX_SYMBOL_LEN + 3]; | |
546 | ||
547 | ts = &expr->ts; | |
548 | if (ts->type == BT_REAL) | |
549 | { | |
550 | switch (ts->kind) | |
551 | { | |
552 | case 4: | |
553 | pdecl = &m->real4_decl; | |
554 | break; | |
555 | case 8: | |
556 | pdecl = &m->real8_decl; | |
557 | break; | |
644cb69f FXC |
558 | case 10: |
559 | pdecl = &m->real10_decl; | |
560 | break; | |
561 | case 16: | |
562 | pdecl = &m->real16_decl; | |
563 | break; | |
6de9cd9a | 564 | default: |
6e45f57b | 565 | gcc_unreachable (); |
6de9cd9a DN |
566 | } |
567 | } | |
568 | else if (ts->type == BT_COMPLEX) | |
569 | { | |
6e45f57b | 570 | gcc_assert (m->complex_available); |
6de9cd9a DN |
571 | |
572 | switch (ts->kind) | |
573 | { | |
574 | case 4: | |
575 | pdecl = &m->complex4_decl; | |
576 | break; | |
577 | case 8: | |
578 | pdecl = &m->complex8_decl; | |
579 | break; | |
644cb69f FXC |
580 | case 10: |
581 | pdecl = &m->complex10_decl; | |
582 | break; | |
583 | case 16: | |
584 | pdecl = &m->complex16_decl; | |
585 | break; | |
6de9cd9a | 586 | default: |
6e45f57b | 587 | gcc_unreachable (); |
6de9cd9a DN |
588 | } |
589 | } | |
590 | else | |
6e45f57b | 591 | gcc_unreachable (); |
6de9cd9a DN |
592 | |
593 | if (*pdecl) | |
594 | return *pdecl; | |
595 | ||
596 | if (m->libm_name) | |
597 | { | |
e48d66a9 SK |
598 | if (ts->kind == 4) |
599 | snprintf (name, sizeof (name), "%s%s%s", | |
600 | ts->type == BT_COMPLEX ? "c" : "", m->name, "f"); | |
601 | else if (ts->kind == 8) | |
602 | snprintf (name, sizeof (name), "%s%s", | |
603 | ts->type == BT_COMPLEX ? "c" : "", m->name); | |
604 | else | |
605 | { | |
606 | gcc_assert (ts->kind == 10 || ts->kind == 16); | |
607 | snprintf (name, sizeof (name), "%s%s%s", | |
608 | ts->type == BT_COMPLEX ? "c" : "", m->name, "l"); | |
609 | } | |
6de9cd9a DN |
610 | } |
611 | else | |
612 | { | |
613 | snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name, | |
614 | ts->type == BT_COMPLEX ? 'c' : 'r', | |
615 | ts->kind); | |
616 | } | |
617 | ||
618 | argtypes = NULL_TREE; | |
619 | for (actual = expr->value.function.actual; actual; actual = actual->next) | |
620 | { | |
621 | type = gfc_typenode_for_spec (&actual->expr->ts); | |
622 | argtypes = gfc_chainon_list (argtypes, type); | |
623 | } | |
624 | argtypes = gfc_chainon_list (argtypes, void_type_node); | |
625 | type = build_function_type (gfc_typenode_for_spec (ts), argtypes); | |
626 | fndecl = build_decl (FUNCTION_DECL, get_identifier (name), type); | |
627 | ||
628 | /* Mark the decl as external. */ | |
629 | DECL_EXTERNAL (fndecl) = 1; | |
630 | TREE_PUBLIC (fndecl) = 1; | |
631 | ||
632 | /* Mark it __attribute__((const)), if possible. */ | |
633 | TREE_READONLY (fndecl) = m->is_constant; | |
634 | ||
0e6df31e | 635 | rest_of_decl_compilation (fndecl, 1, 0); |
6de9cd9a DN |
636 | |
637 | (*pdecl) = fndecl; | |
638 | return fndecl; | |
639 | } | |
640 | ||
641 | ||
642 | /* Convert an intrinsic function into an external or builtin call. */ | |
643 | ||
644 | static void | |
645 | gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr) | |
646 | { | |
647 | gfc_intrinsic_map_t *m; | |
648 | tree args; | |
649 | tree fndecl; | |
650 | gfc_generic_isym_id id; | |
651 | ||
652 | id = expr->value.function.isym->generic_id; | |
653 | /* Find the entry for this function. */ | |
654 | for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++) | |
655 | { | |
656 | if (id == m->id) | |
657 | break; | |
658 | } | |
659 | ||
660 | if (m->id == GFC_ISYM_NONE) | |
661 | { | |
662 | internal_error ("Intrinsic function %s(%d) not recognized", | |
663 | expr->value.function.name, id); | |
664 | } | |
665 | ||
666 | /* Get the decl and generate the call. */ | |
667 | args = gfc_conv_intrinsic_function_args (se, expr); | |
668 | fndecl = gfc_get_intrinsic_lib_fndecl (m, expr); | |
3380b802 | 669 | se->expr = build_function_call_expr (fndecl, args); |
6de9cd9a DN |
670 | } |
671 | ||
672 | /* Generate code for EXPONENT(X) intrinsic function. */ | |
673 | ||
674 | static void | |
675 | gfc_conv_intrinsic_exponent (gfc_se * se, gfc_expr * expr) | |
676 | { | |
677 | tree args, fndecl; | |
678 | gfc_expr *a1; | |
679 | ||
680 | args = gfc_conv_intrinsic_function_args (se, expr); | |
681 | ||
682 | a1 = expr->value.function.actual->expr; | |
683 | switch (a1->ts.kind) | |
684 | { | |
685 | case 4: | |
686 | fndecl = gfor_fndecl_math_exponent4; | |
687 | break; | |
688 | case 8: | |
689 | fndecl = gfor_fndecl_math_exponent8; | |
690 | break; | |
644cb69f FXC |
691 | case 10: |
692 | fndecl = gfor_fndecl_math_exponent10; | |
693 | break; | |
694 | case 16: | |
695 | fndecl = gfor_fndecl_math_exponent16; | |
696 | break; | |
6de9cd9a | 697 | default: |
6e45f57b | 698 | gcc_unreachable (); |
6de9cd9a DN |
699 | } |
700 | ||
3380b802 | 701 | se->expr = build_function_call_expr (fndecl, args); |
6de9cd9a DN |
702 | } |
703 | ||
704 | /* Evaluate a single upper or lower bound. */ | |
1f2959f0 | 705 | /* TODO: bound intrinsic generates way too much unnecessary code. */ |
6de9cd9a DN |
706 | |
707 | static void | |
708 | gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) | |
709 | { | |
710 | gfc_actual_arglist *arg; | |
711 | gfc_actual_arglist *arg2; | |
712 | tree desc; | |
713 | tree type; | |
714 | tree bound; | |
715 | tree tmp; | |
9f1dce56 | 716 | tree cond, cond1, cond2, cond3, cond4, size; |
ac677cc8 FXC |
717 | tree ubound; |
718 | tree lbound; | |
6de9cd9a DN |
719 | gfc_se argse; |
720 | gfc_ss *ss; | |
ac677cc8 FXC |
721 | gfc_array_spec * as; |
722 | gfc_ref *ref; | |
6de9cd9a | 723 | |
6de9cd9a DN |
724 | arg = expr->value.function.actual; |
725 | arg2 = arg->next; | |
726 | ||
727 | if (se->ss) | |
728 | { | |
729 | /* Create an implicit second parameter from the loop variable. */ | |
6e45f57b PB |
730 | gcc_assert (!arg2->expr); |
731 | gcc_assert (se->loop->dimen == 1); | |
732 | gcc_assert (se->ss->expr == expr); | |
6de9cd9a DN |
733 | gfc_advance_se_ss_chain (se); |
734 | bound = se->loop->loopvar[0]; | |
10c7a96f SB |
735 | bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound, |
736 | se->loop->from[0]); | |
6de9cd9a DN |
737 | } |
738 | else | |
739 | { | |
740 | /* use the passed argument. */ | |
6e45f57b | 741 | gcc_assert (arg->next->expr); |
6de9cd9a DN |
742 | gfc_init_se (&argse, NULL); |
743 | gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type); | |
744 | gfc_add_block_to_block (&se->pre, &argse.pre); | |
745 | bound = argse.expr; | |
746 | /* Convert from one based to zero based. */ | |
10c7a96f SB |
747 | bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound, |
748 | gfc_index_one_node); | |
6de9cd9a DN |
749 | } |
750 | ||
751 | /* TODO: don't re-evaluate the descriptor on each iteration. */ | |
752 | /* Get a descriptor for the first parameter. */ | |
753 | ss = gfc_walk_expr (arg->expr); | |
6e45f57b | 754 | gcc_assert (ss != gfc_ss_terminator); |
4fd9a813 | 755 | gfc_init_se (&argse, NULL); |
6de9cd9a DN |
756 | gfc_conv_expr_descriptor (&argse, arg->expr, ss); |
757 | gfc_add_block_to_block (&se->pre, &argse.pre); | |
758 | gfc_add_block_to_block (&se->post, &argse.post); | |
759 | ||
760 | desc = argse.expr; | |
761 | ||
762 | if (INTEGER_CST_P (bound)) | |
763 | { | |
9f1dce56 FXC |
764 | int hi, low; |
765 | ||
766 | hi = TREE_INT_CST_HIGH (bound); | |
767 | low = TREE_INT_CST_LOW (bound); | |
768 | if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))) | |
769 | gfc_error ("'dim' argument of %s intrinsic at %L is not a valid " | |
770 | "dimension index", upper ? "UBOUND" : "LBOUND", | |
771 | &expr->where); | |
6de9cd9a DN |
772 | } |
773 | else | |
774 | { | |
775 | if (flag_bounds_check) | |
776 | { | |
777 | bound = gfc_evaluate_now (bound, &se->pre); | |
10c7a96f SB |
778 | cond = fold_build2 (LT_EXPR, boolean_type_node, |
779 | bound, build_int_cst (TREE_TYPE (bound), 0)); | |
6de9cd9a | 780 | tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))]; |
10c7a96f SB |
781 | tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp); |
782 | cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp); | |
d19c0f4f | 783 | gfc_trans_runtime_check (cond, gfc_msg_fault, &se->pre, &expr->where); |
6de9cd9a DN |
784 | } |
785 | } | |
786 | ||
ac677cc8 FXC |
787 | ubound = gfc_conv_descriptor_ubound (desc, bound); |
788 | lbound = gfc_conv_descriptor_lbound (desc, bound); | |
789 | ||
790 | /* Follow any component references. */ | |
791 | if (arg->expr->expr_type == EXPR_VARIABLE | |
792 | || arg->expr->expr_type == EXPR_CONSTANT) | |
793 | { | |
794 | as = arg->expr->symtree->n.sym->as; | |
795 | for (ref = arg->expr->ref; ref; ref = ref->next) | |
796 | { | |
797 | switch (ref->type) | |
798 | { | |
799 | case REF_COMPONENT: | |
800 | as = ref->u.c.component->as; | |
801 | continue; | |
802 | ||
803 | case REF_SUBSTRING: | |
804 | continue; | |
805 | ||
806 | case REF_ARRAY: | |
807 | { | |
808 | switch (ref->u.ar.type) | |
809 | { | |
810 | case AR_ELEMENT: | |
811 | case AR_SECTION: | |
812 | case AR_UNKNOWN: | |
813 | as = NULL; | |
814 | continue; | |
815 | ||
816 | case AR_FULL: | |
817 | break; | |
818 | } | |
819 | } | |
820 | } | |
821 | } | |
822 | } | |
6de9cd9a | 823 | else |
ac677cc8 FXC |
824 | as = NULL; |
825 | ||
826 | /* 13.14.53: Result value for LBOUND | |
827 | ||
828 | Case (i): For an array section or for an array expression other than a | |
829 | whole array or array structure component, LBOUND(ARRAY, DIM) | |
830 | has the value 1. For a whole array or array structure | |
831 | component, LBOUND(ARRAY, DIM) has the value: | |
832 | (a) equal to the lower bound for subscript DIM of ARRAY if | |
833 | dimension DIM of ARRAY does not have extent zero | |
834 | or if ARRAY is an assumed-size array of rank DIM, | |
835 | or (b) 1 otherwise. | |
836 | ||
837 | 13.14.113: Result value for UBOUND | |
838 | ||
839 | Case (i): For an array section or for an array expression other than a | |
840 | whole array or array structure component, UBOUND(ARRAY, DIM) | |
841 | has the value equal to the number of elements in the given | |
842 | dimension; otherwise, it has a value equal to the upper bound | |
843 | for subscript DIM of ARRAY if dimension DIM of ARRAY does | |
844 | not have size zero and has value zero if dimension DIM has | |
845 | size zero. */ | |
846 | ||
847 | if (as) | |
848 | { | |
849 | tree stride = gfc_conv_descriptor_stride (desc, bound); | |
9f1dce56 | 850 | |
ac677cc8 FXC |
851 | cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound); |
852 | cond2 = fold_build2 (LE_EXPR, boolean_type_node, ubound, lbound); | |
9f1dce56 FXC |
853 | |
854 | cond3 = fold_build2 (GE_EXPR, boolean_type_node, stride, | |
ac677cc8 | 855 | gfc_index_zero_node); |
9f1dce56 FXC |
856 | cond3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1); |
857 | ||
858 | cond4 = fold_build2 (LT_EXPR, boolean_type_node, stride, | |
859 | gfc_index_zero_node); | |
860 | cond4 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond4, cond2); | |
ac677cc8 FXC |
861 | |
862 | if (upper) | |
863 | { | |
9f1dce56 | 864 | cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4); |
ac677cc8 FXC |
865 | |
866 | se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond, | |
867 | ubound, gfc_index_zero_node); | |
868 | } | |
869 | else | |
870 | { | |
871 | if (as->type == AS_ASSUMED_SIZE) | |
872 | cond = fold_build2 (EQ_EXPR, boolean_type_node, bound, | |
873 | build_int_cst (TREE_TYPE (bound), | |
9f1dce56 | 874 | arg->expr->rank - 1)); |
ac677cc8 FXC |
875 | else |
876 | cond = boolean_false_node; | |
877 | ||
9f1dce56 | 878 | cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4); |
ac677cc8 FXC |
879 | cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1); |
880 | ||
881 | se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond, | |
882 | lbound, gfc_index_one_node); | |
883 | } | |
884 | } | |
885 | else | |
886 | { | |
887 | if (upper) | |
888 | { | |
889 | size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound); | |
890 | se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size, | |
891 | gfc_index_one_node); | |
892 | } | |
893 | else | |
894 | se->expr = gfc_index_one_node; | |
895 | } | |
6de9cd9a DN |
896 | |
897 | type = gfc_typenode_for_spec (&expr->ts); | |
898 | se->expr = convert (type, se->expr); | |
899 | } | |
900 | ||
901 | ||
902 | static void | |
903 | gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr) | |
904 | { | |
905 | tree args; | |
906 | tree val; | |
ead6d15f | 907 | int n; |
6de9cd9a DN |
908 | |
909 | args = gfc_conv_intrinsic_function_args (se, expr); | |
6e45f57b | 910 | gcc_assert (args && TREE_CHAIN (args) == NULL_TREE); |
6de9cd9a DN |
911 | val = TREE_VALUE (args); |
912 | ||
913 | switch (expr->value.function.actual->expr->ts.type) | |
914 | { | |
915 | case BT_INTEGER: | |
916 | case BT_REAL: | |
917 | se->expr = build1 (ABS_EXPR, TREE_TYPE (val), val); | |
918 | break; | |
919 | ||
920 | case BT_COMPLEX: | |
921 | switch (expr->ts.kind) | |
922 | { | |
923 | case 4: | |
ead6d15f | 924 | n = BUILT_IN_CABSF; |
6de9cd9a DN |
925 | break; |
926 | case 8: | |
ead6d15f | 927 | n = BUILT_IN_CABS; |
6de9cd9a | 928 | break; |
644cb69f FXC |
929 | case 10: |
930 | case 16: | |
931 | n = BUILT_IN_CABSL; | |
932 | break; | |
6de9cd9a | 933 | default: |
6e45f57b | 934 | gcc_unreachable (); |
6de9cd9a | 935 | } |
3380b802 | 936 | se->expr = build_function_call_expr (built_in_decls[n], args); |
6de9cd9a DN |
937 | break; |
938 | ||
939 | default: | |
6e45f57b | 940 | gcc_unreachable (); |
6de9cd9a DN |
941 | } |
942 | } | |
943 | ||
944 | ||
945 | /* Create a complex value from one or two real components. */ | |
946 | ||
947 | static void | |
948 | gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both) | |
949 | { | |
950 | tree arg; | |
951 | tree real; | |
952 | tree imag; | |
953 | tree type; | |
954 | ||
955 | type = gfc_typenode_for_spec (&expr->ts); | |
956 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
957 | real = convert (TREE_TYPE (type), TREE_VALUE (arg)); | |
958 | if (both) | |
959 | imag = convert (TREE_TYPE (type), TREE_VALUE (TREE_CHAIN (arg))); | |
960 | else if (TREE_CODE (TREE_TYPE (TREE_VALUE (arg))) == COMPLEX_TYPE) | |
961 | { | |
962 | arg = TREE_VALUE (arg); | |
963 | imag = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg); | |
964 | imag = convert (TREE_TYPE (type), imag); | |
965 | } | |
966 | else | |
967 | imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node); | |
968 | ||
10c7a96f | 969 | se->expr = fold_build2 (COMPLEX_EXPR, type, real, imag); |
6de9cd9a DN |
970 | } |
971 | ||
e98a8b5b TS |
972 | /* Remainder function MOD(A, P) = A - INT(A / P) * P |
973 | MODULO(A, P) = A - FLOOR (A / P) * P */ | |
6de9cd9a DN |
974 | /* TODO: MOD(x, 0) */ |
975 | ||
976 | static void | |
977 | gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) | |
978 | { | |
979 | tree arg; | |
980 | tree arg2; | |
981 | tree type; | |
982 | tree itype; | |
983 | tree tmp; | |
6de9cd9a DN |
984 | tree test; |
985 | tree test2; | |
f8e566e5 | 986 | mpfr_t huge; |
3e7cb1c7 | 987 | int n, ikind; |
6de9cd9a DN |
988 | |
989 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
6de9cd9a DN |
990 | |
991 | switch (expr->ts.type) | |
992 | { | |
993 | case BT_INTEGER: | |
994 | /* Integer case is easy, we've got a builtin op. */ | |
58b6e047 PT |
995 | arg2 = TREE_VALUE (TREE_CHAIN (arg)); |
996 | arg = TREE_VALUE (arg); | |
997 | type = TREE_TYPE (arg); | |
998 | ||
e98a8b5b TS |
999 | if (modulo) |
1000 | se->expr = build2 (FLOOR_MOD_EXPR, type, arg, arg2); | |
1001 | else | |
1002 | se->expr = build2 (TRUNC_MOD_EXPR, type, arg, arg2); | |
6de9cd9a DN |
1003 | break; |
1004 | ||
1005 | case BT_REAL: | |
58b6e047 PT |
1006 | n = END_BUILTINS; |
1007 | /* Check if we have a builtin fmod. */ | |
1008 | switch (expr->ts.kind) | |
1009 | { | |
1010 | case 4: | |
1011 | n = BUILT_IN_FMODF; | |
1012 | break; | |
1013 | ||
1014 | case 8: | |
1015 | n = BUILT_IN_FMOD; | |
1016 | break; | |
1017 | ||
1018 | case 10: | |
1019 | case 16: | |
1020 | n = BUILT_IN_FMODL; | |
1021 | break; | |
1022 | ||
1023 | default: | |
1024 | break; | |
1025 | } | |
1026 | ||
1027 | /* Use it if it exists. */ | |
1028 | if (n != END_BUILTINS) | |
1029 | { | |
1030 | tmp = built_in_decls[n]; | |
1031 | se->expr = build_function_call_expr (tmp, arg); | |
1032 | if (modulo == 0) | |
1033 | return; | |
1034 | } | |
1035 | ||
1036 | arg2 = TREE_VALUE (TREE_CHAIN (arg)); | |
1037 | arg = TREE_VALUE (arg); | |
1038 | type = TREE_TYPE (arg); | |
1039 | ||
6de9cd9a DN |
1040 | arg = gfc_evaluate_now (arg, &se->pre); |
1041 | arg2 = gfc_evaluate_now (arg2, &se->pre); | |
1042 | ||
58b6e047 PT |
1043 | /* Definition: |
1044 | modulo = arg - floor (arg/arg2) * arg2, so | |
1045 | = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2, | |
1046 | where | |
1047 | test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0)) | |
1048 | thereby avoiding another division and retaining the accuracy | |
1049 | of the builtin function. */ | |
1050 | if (n != END_BUILTINS && modulo) | |
1051 | { | |
1052 | tree zero = gfc_build_const (type, integer_zero_node); | |
1053 | tmp = gfc_evaluate_now (se->expr, &se->pre); | |
1054 | test = build2 (LT_EXPR, boolean_type_node, arg, zero); | |
1055 | test2 = build2 (LT_EXPR, boolean_type_node, arg2, zero); | |
1056 | test2 = build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2); | |
1057 | test = build2 (NE_EXPR, boolean_type_node, tmp, zero); | |
1058 | test = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2); | |
1059 | test = gfc_evaluate_now (test, &se->pre); | |
1060 | se->expr = build3 (COND_EXPR, type, test, | |
1061 | build2 (PLUS_EXPR, type, tmp, arg2), tmp); | |
1062 | return; | |
1063 | } | |
1064 | ||
1065 | /* If we do not have a built_in fmod, the calculation is going to | |
1066 | have to be done longhand. */ | |
923ab88c | 1067 | tmp = build2 (RDIV_EXPR, type, arg, arg2); |
58b6e047 | 1068 | |
6de9cd9a | 1069 | /* Test if the value is too large to handle sensibly. */ |
f8e566e5 SK |
1070 | gfc_set_model_kind (expr->ts.kind); |
1071 | mpfr_init (huge); | |
3e7cb1c7 FXC |
1072 | n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true); |
1073 | ikind = expr->ts.kind; | |
1074 | if (n < 0) | |
1075 | { | |
1076 | n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false); | |
1077 | ikind = gfc_max_integer_kind; | |
1078 | } | |
f8e566e5 SK |
1079 | mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE); |
1080 | test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind); | |
923ab88c | 1081 | test2 = build2 (LT_EXPR, boolean_type_node, tmp, test); |
6de9cd9a | 1082 | |
f8e566e5 SK |
1083 | mpfr_neg (huge, huge, GFC_RND_MODE); |
1084 | test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind); | |
923ab88c TS |
1085 | test = build2 (GT_EXPR, boolean_type_node, tmp, test); |
1086 | test2 = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2); | |
6de9cd9a | 1087 | |
3e7cb1c7 | 1088 | itype = gfc_get_int_type (ikind); |
e98a8b5b | 1089 | if (modulo) |
f9f770a8 | 1090 | tmp = build_fix_expr (&se->pre, tmp, itype, RND_FLOOR); |
e98a8b5b | 1091 | else |
f9f770a8 | 1092 | tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC); |
6de9cd9a | 1093 | tmp = convert (type, tmp); |
923ab88c TS |
1094 | tmp = build3 (COND_EXPR, type, test2, tmp, arg); |
1095 | tmp = build2 (MULT_EXPR, type, tmp, arg2); | |
1096 | se->expr = build2 (MINUS_EXPR, type, arg, tmp); | |
f8e566e5 | 1097 | mpfr_clear (huge); |
6de9cd9a DN |
1098 | break; |
1099 | ||
1100 | default: | |
6e45f57b | 1101 | gcc_unreachable (); |
6de9cd9a | 1102 | } |
6de9cd9a DN |
1103 | } |
1104 | ||
1105 | /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */ | |
1106 | ||
1107 | static void | |
1108 | gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr) | |
1109 | { | |
1110 | tree arg; | |
1111 | tree arg2; | |
1112 | tree val; | |
1113 | tree tmp; | |
1114 | tree type; | |
1115 | tree zero; | |
1116 | ||
1117 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
1118 | arg2 = TREE_VALUE (TREE_CHAIN (arg)); | |
1119 | arg = TREE_VALUE (arg); | |
1120 | type = TREE_TYPE (arg); | |
1121 | ||
923ab88c | 1122 | val = build2 (MINUS_EXPR, type, arg, arg2); |
6de9cd9a DN |
1123 | val = gfc_evaluate_now (val, &se->pre); |
1124 | ||
1125 | zero = gfc_build_const (type, integer_zero_node); | |
923ab88c TS |
1126 | tmp = build2 (LE_EXPR, boolean_type_node, val, zero); |
1127 | se->expr = build3 (COND_EXPR, type, tmp, zero, val); | |
6de9cd9a DN |
1128 | } |
1129 | ||
1130 | ||
1131 | /* SIGN(A, B) is absolute value of A times sign of B. | |
1132 | The real value versions use library functions to ensure the correct | |
1133 | handling of negative zero. Integer case implemented as: | |
0eadc091 | 1134 | SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp } |
6de9cd9a DN |
1135 | */ |
1136 | ||
1137 | static void | |
1138 | gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr) | |
1139 | { | |
1140 | tree tmp; | |
1141 | tree arg; | |
1142 | tree arg2; | |
1143 | tree type; | |
6de9cd9a DN |
1144 | |
1145 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
1146 | if (expr->ts.type == BT_REAL) | |
1147 | { | |
1148 | switch (expr->ts.kind) | |
1149 | { | |
1150 | case 4: | |
ead6d15f | 1151 | tmp = built_in_decls[BUILT_IN_COPYSIGNF]; |
6de9cd9a DN |
1152 | break; |
1153 | case 8: | |
ead6d15f | 1154 | tmp = built_in_decls[BUILT_IN_COPYSIGN]; |
6de9cd9a | 1155 | break; |
644cb69f FXC |
1156 | case 10: |
1157 | case 16: | |
1158 | tmp = built_in_decls[BUILT_IN_COPYSIGNL]; | |
1159 | break; | |
6de9cd9a | 1160 | default: |
6e45f57b | 1161 | gcc_unreachable (); |
6de9cd9a | 1162 | } |
3380b802 | 1163 | se->expr = build_function_call_expr (tmp, arg); |
6de9cd9a DN |
1164 | return; |
1165 | } | |
1166 | ||
0eadc091 RS |
1167 | /* Having excluded floating point types, we know we are now dealing |
1168 | with signed integer types. */ | |
6de9cd9a DN |
1169 | arg2 = TREE_VALUE (TREE_CHAIN (arg)); |
1170 | arg = TREE_VALUE (arg); | |
1171 | type = TREE_TYPE (arg); | |
6de9cd9a | 1172 | |
0eadc091 RS |
1173 | /* Arg is used multiple times below. */ |
1174 | arg = gfc_evaluate_now (arg, &se->pre); | |
1175 | ||
1176 | /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if | |
1177 | the signs of A and B are the same, and of all ones if they differ. */ | |
1178 | tmp = fold_build2 (BIT_XOR_EXPR, type, arg, arg2); | |
1179 | tmp = fold_build2 (RSHIFT_EXPR, type, tmp, | |
1180 | build_int_cst (type, TYPE_PRECISION (type) - 1)); | |
1181 | tmp = gfc_evaluate_now (tmp, &se->pre); | |
1182 | ||
1183 | /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp] | |
1184 | is all ones (i.e. -1). */ | |
1185 | se->expr = fold_build2 (BIT_XOR_EXPR, type, | |
1186 | fold_build2 (PLUS_EXPR, type, arg, tmp), | |
1187 | tmp); | |
6de9cd9a DN |
1188 | } |
1189 | ||
1190 | ||
1191 | /* Test for the presence of an optional argument. */ | |
1192 | ||
1193 | static void | |
1194 | gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr) | |
1195 | { | |
1196 | gfc_expr *arg; | |
1197 | ||
1198 | arg = expr->value.function.actual->expr; | |
6e45f57b | 1199 | gcc_assert (arg->expr_type == EXPR_VARIABLE); |
6de9cd9a DN |
1200 | se->expr = gfc_conv_expr_present (arg->symtree->n.sym); |
1201 | se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr); | |
1202 | } | |
1203 | ||
1204 | ||
1205 | /* Calculate the double precision product of two single precision values. */ | |
1206 | ||
1207 | static void | |
1208 | gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr) | |
1209 | { | |
1210 | tree arg; | |
1211 | tree arg2; | |
1212 | tree type; | |
1213 | ||
1214 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
1215 | arg2 = TREE_VALUE (TREE_CHAIN (arg)); | |
1216 | arg = TREE_VALUE (arg); | |
1217 | ||
1218 | /* Convert the args to double precision before multiplying. */ | |
1219 | type = gfc_typenode_for_spec (&expr->ts); | |
1220 | arg = convert (type, arg); | |
1221 | arg2 = convert (type, arg2); | |
923ab88c | 1222 | se->expr = build2 (MULT_EXPR, type, arg, arg2); |
6de9cd9a DN |
1223 | } |
1224 | ||
1225 | ||
1226 | /* Return a length one character string containing an ascii character. */ | |
1227 | ||
1228 | static void | |
1229 | gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr) | |
1230 | { | |
1231 | tree arg; | |
1232 | tree var; | |
1233 | tree type; | |
1234 | ||
1235 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
1236 | arg = TREE_VALUE (arg); | |
1237 | ||
1238 | /* We currently don't support character types != 1. */ | |
6e45f57b | 1239 | gcc_assert (expr->ts.kind == 1); |
6de9cd9a DN |
1240 | type = gfc_character1_type_node; |
1241 | var = gfc_create_var (type, "char"); | |
1242 | ||
1243 | arg = convert (type, arg); | |
1244 | gfc_add_modify_expr (&se->pre, var, arg); | |
1245 | se->expr = gfc_build_addr_expr (build_pointer_type (type), var); | |
1246 | se->string_length = integer_one_node; | |
1247 | } | |
1248 | ||
1249 | ||
35059811 FXC |
1250 | static void |
1251 | gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr) | |
1252 | { | |
1253 | tree var; | |
1254 | tree len; | |
1255 | tree tmp; | |
1256 | tree arglist; | |
1257 | tree type; | |
1258 | tree cond; | |
1259 | tree gfc_int8_type_node = gfc_get_int_type (8); | |
1260 | ||
1261 | type = build_pointer_type (gfc_character1_type_node); | |
1262 | var = gfc_create_var (type, "pstr"); | |
1263 | len = gfc_create_var (gfc_int8_type_node, "len"); | |
1264 | ||
1265 | tmp = gfc_conv_intrinsic_function_args (se, expr); | |
488ce07b RG |
1266 | arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var)); |
1267 | arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len)); | |
35059811 FXC |
1268 | arglist = chainon (arglist, tmp); |
1269 | ||
3380b802 | 1270 | tmp = build_function_call_expr (gfor_fndecl_ctime, arglist); |
35059811 FXC |
1271 | gfc_add_expr_to_block (&se->pre, tmp); |
1272 | ||
1273 | /* Free the temporary afterwards, if necessary. */ | |
1274 | cond = build2 (GT_EXPR, boolean_type_node, len, | |
1275 | build_int_cst (TREE_TYPE (len), 0)); | |
1276 | arglist = gfc_chainon_list (NULL_TREE, var); | |
3380b802 | 1277 | tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist); |
35059811 FXC |
1278 | tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ()); |
1279 | gfc_add_expr_to_block (&se->post, tmp); | |
1280 | ||
1281 | se->expr = var; | |
1282 | se->string_length = len; | |
1283 | } | |
1284 | ||
1285 | ||
1286 | static void | |
1287 | gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr) | |
1288 | { | |
1289 | tree var; | |
1290 | tree len; | |
1291 | tree tmp; | |
1292 | tree arglist; | |
1293 | tree type; | |
1294 | tree cond; | |
1295 | tree gfc_int4_type_node = gfc_get_int_type (4); | |
1296 | ||
1297 | type = build_pointer_type (gfc_character1_type_node); | |
1298 | var = gfc_create_var (type, "pstr"); | |
1299 | len = gfc_create_var (gfc_int4_type_node, "len"); | |
1300 | ||
1301 | tmp = gfc_conv_intrinsic_function_args (se, expr); | |
488ce07b RG |
1302 | arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var)); |
1303 | arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len)); | |
35059811 FXC |
1304 | arglist = chainon (arglist, tmp); |
1305 | ||
3380b802 | 1306 | tmp = build_function_call_expr (gfor_fndecl_fdate, arglist); |
35059811 FXC |
1307 | gfc_add_expr_to_block (&se->pre, tmp); |
1308 | ||
1309 | /* Free the temporary afterwards, if necessary. */ | |
1310 | cond = build2 (GT_EXPR, boolean_type_node, len, | |
1311 | build_int_cst (TREE_TYPE (len), 0)); | |
1312 | arglist = gfc_chainon_list (NULL_TREE, var); | |
3380b802 | 1313 | tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist); |
35059811 FXC |
1314 | tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ()); |
1315 | gfc_add_expr_to_block (&se->post, tmp); | |
1316 | ||
1317 | se->expr = var; | |
1318 | se->string_length = len; | |
1319 | } | |
1320 | ||
1321 | ||
25fc05eb FXC |
1322 | /* Return a character string containing the tty name. */ |
1323 | ||
1324 | static void | |
1325 | gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr) | |
1326 | { | |
1327 | tree var; | |
1328 | tree len; | |
1329 | tree tmp; | |
1330 | tree arglist; | |
1331 | tree type; | |
1332 | tree cond; | |
1333 | tree gfc_int4_type_node = gfc_get_int_type (4); | |
1334 | ||
1335 | type = build_pointer_type (gfc_character1_type_node); | |
1336 | var = gfc_create_var (type, "pstr"); | |
1337 | len = gfc_create_var (gfc_int4_type_node, "len"); | |
1338 | ||
1339 | tmp = gfc_conv_intrinsic_function_args (se, expr); | |
488ce07b RG |
1340 | arglist = gfc_chainon_list (NULL_TREE, build_fold_addr_expr (var)); |
1341 | arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len)); | |
25fc05eb FXC |
1342 | arglist = chainon (arglist, tmp); |
1343 | ||
3380b802 | 1344 | tmp = build_function_call_expr (gfor_fndecl_ttynam, arglist); |
25fc05eb FXC |
1345 | gfc_add_expr_to_block (&se->pre, tmp); |
1346 | ||
1347 | /* Free the temporary afterwards, if necessary. */ | |
1348 | cond = build2 (GT_EXPR, boolean_type_node, len, | |
1349 | build_int_cst (TREE_TYPE (len), 0)); | |
1350 | arglist = gfc_chainon_list (NULL_TREE, var); | |
3380b802 | 1351 | tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist); |
25fc05eb FXC |
1352 | tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ()); |
1353 | gfc_add_expr_to_block (&se->post, tmp); | |
1354 | ||
1355 | se->expr = var; | |
1356 | se->string_length = len; | |
1357 | } | |
1358 | ||
1359 | ||
6de9cd9a DN |
1360 | /* Get the minimum/maximum value of all the parameters. |
1361 | minmax (a1, a2, a3, ...) | |
1362 | { | |
1363 | if (a2 .op. a1) | |
1364 | mvar = a2; | |
1365 | else | |
1366 | mvar = a1; | |
1367 | if (a3 .op. mvar) | |
1368 | mvar = a3; | |
1369 | ... | |
1370 | return mvar | |
1371 | } | |
1372 | */ | |
1373 | ||
1374 | /* TODO: Mismatching types can occur when specific names are used. | |
1375 | These should be handled during resolution. */ | |
1376 | static void | |
1377 | gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op) | |
1378 | { | |
1379 | tree limit; | |
1380 | tree tmp; | |
1381 | tree mvar; | |
1382 | tree val; | |
1383 | tree thencase; | |
1384 | tree elsecase; | |
1385 | tree arg; | |
1386 | tree type; | |
1387 | ||
1388 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
1389 | type = gfc_typenode_for_spec (&expr->ts); | |
1390 | ||
1391 | limit = TREE_VALUE (arg); | |
1392 | if (TREE_TYPE (limit) != type) | |
1393 | limit = convert (type, limit); | |
1394 | /* Only evaluate the argument once. */ | |
1395 | if (TREE_CODE (limit) != VAR_DECL && !TREE_CONSTANT (limit)) | |
0eadc091 | 1396 | limit = gfc_evaluate_now (limit, &se->pre); |
6de9cd9a DN |
1397 | |
1398 | mvar = gfc_create_var (type, "M"); | |
923ab88c | 1399 | elsecase = build2_v (MODIFY_EXPR, mvar, limit); |
6de9cd9a DN |
1400 | for (arg = TREE_CHAIN (arg); arg != NULL_TREE; arg = TREE_CHAIN (arg)) |
1401 | { | |
1402 | val = TREE_VALUE (arg); | |
1403 | if (TREE_TYPE (val) != type) | |
1404 | val = convert (type, val); | |
1405 | ||
1406 | /* Only evaluate the argument once. */ | |
1407 | if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val)) | |
0eadc091 | 1408 | val = gfc_evaluate_now (val, &se->pre); |
6de9cd9a | 1409 | |
923ab88c | 1410 | thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val)); |
6de9cd9a | 1411 | |
923ab88c TS |
1412 | tmp = build2 (op, boolean_type_node, val, limit); |
1413 | tmp = build3_v (COND_EXPR, tmp, thencase, elsecase); | |
6de9cd9a DN |
1414 | gfc_add_expr_to_block (&se->pre, tmp); |
1415 | elsecase = build_empty_stmt (); | |
1416 | limit = mvar; | |
1417 | } | |
1418 | se->expr = mvar; | |
1419 | } | |
1420 | ||
1421 | ||
4b9b6210 TS |
1422 | /* Create a symbol node for this intrinsic. The symbol from the frontend |
1423 | has the generic name. */ | |
6de9cd9a DN |
1424 | |
1425 | static gfc_symbol * | |
1426 | gfc_get_symbol_for_expr (gfc_expr * expr) | |
1427 | { | |
1428 | gfc_symbol *sym; | |
1429 | ||
1430 | /* TODO: Add symbols for intrinsic function to the global namespace. */ | |
6e45f57b | 1431 | gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5); |
6de9cd9a DN |
1432 | sym = gfc_new_symbol (expr->value.function.name, NULL); |
1433 | ||
1434 | sym->ts = expr->ts; | |
1435 | sym->attr.external = 1; | |
1436 | sym->attr.function = 1; | |
1437 | sym->attr.always_explicit = 1; | |
1438 | sym->attr.proc = PROC_INTRINSIC; | |
1439 | sym->attr.flavor = FL_PROCEDURE; | |
1440 | sym->result = sym; | |
1441 | if (expr->rank > 0) | |
1442 | { | |
1443 | sym->attr.dimension = 1; | |
1444 | sym->as = gfc_get_array_spec (); | |
1445 | sym->as->type = AS_ASSUMED_SHAPE; | |
1446 | sym->as->rank = expr->rank; | |
1447 | } | |
1448 | ||
1449 | /* TODO: proper argument lists for external intrinsics. */ | |
1450 | return sym; | |
1451 | } | |
1452 | ||
1453 | /* Generate a call to an external intrinsic function. */ | |
1454 | static void | |
1455 | gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr) | |
1456 | { | |
1457 | gfc_symbol *sym; | |
5a0aad31 | 1458 | tree append_args; |
6de9cd9a | 1459 | |
6e45f57b | 1460 | gcc_assert (!se->ss || se->ss->expr == expr); |
6de9cd9a DN |
1461 | |
1462 | if (se->ss) | |
6e45f57b | 1463 | gcc_assert (expr->rank > 0); |
6de9cd9a | 1464 | else |
6e45f57b | 1465 | gcc_assert (expr->rank == 0); |
6de9cd9a DN |
1466 | |
1467 | sym = gfc_get_symbol_for_expr (expr); | |
5a0aad31 FXC |
1468 | |
1469 | /* Calls to libgfortran_matmul need to be appended special arguments, | |
1470 | to be able to call the BLAS ?gemm functions if required and possible. */ | |
1471 | append_args = NULL_TREE; | |
1472 | if (expr->value.function.isym->generic_id == GFC_ISYM_MATMUL | |
1473 | && sym->ts.type != BT_LOGICAL) | |
1474 | { | |
1475 | tree cint = gfc_get_int_type (gfc_c_int_kind); | |
1476 | ||
1477 | if (gfc_option.flag_external_blas | |
1478 | && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX) | |
1479 | && (sym->ts.kind == gfc_default_real_kind | |
1480 | || sym->ts.kind == gfc_default_double_kind)) | |
1481 | { | |
1482 | tree gemm_fndecl; | |
1483 | ||
1484 | if (sym->ts.type == BT_REAL) | |
1485 | { | |
1486 | if (sym->ts.kind == gfc_default_real_kind) | |
1487 | gemm_fndecl = gfor_fndecl_sgemm; | |
1488 | else | |
1489 | gemm_fndecl = gfor_fndecl_dgemm; | |
1490 | } | |
1491 | else | |
1492 | { | |
1493 | if (sym->ts.kind == gfc_default_real_kind) | |
1494 | gemm_fndecl = gfor_fndecl_cgemm; | |
1495 | else | |
1496 | gemm_fndecl = gfor_fndecl_zgemm; | |
1497 | } | |
1498 | ||
1499 | append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 1)); | |
1500 | append_args = gfc_chainon_list | |
1501 | (append_args, build_int_cst | |
1502 | (cint, gfc_option.blas_matmul_limit)); | |
1503 | append_args = gfc_chainon_list (append_args, | |
1504 | gfc_build_addr_expr (NULL_TREE, | |
1505 | gemm_fndecl)); | |
1506 | } | |
1507 | else | |
1508 | { | |
1509 | append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 0)); | |
1510 | append_args = gfc_chainon_list (append_args, build_int_cst (cint, 0)); | |
1511 | append_args = gfc_chainon_list (append_args, null_pointer_node); | |
1512 | } | |
1513 | } | |
1514 | ||
1515 | gfc_conv_function_call (se, sym, expr->value.function.actual, append_args); | |
6de9cd9a DN |
1516 | gfc_free (sym); |
1517 | } | |
1518 | ||
1519 | /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR. | |
1520 | Implemented as | |
1521 | any(a) | |
1522 | { | |
1523 | forall (i=...) | |
1524 | if (a[i] != 0) | |
1525 | return 1 | |
1526 | end forall | |
1527 | return 0 | |
1528 | } | |
1529 | all(a) | |
1530 | { | |
1531 | forall (i=...) | |
1532 | if (a[i] == 0) | |
1533 | return 0 | |
1534 | end forall | |
1535 | return 1 | |
1536 | } | |
1537 | */ | |
1538 | static void | |
1539 | gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op) | |
1540 | { | |
1541 | tree resvar; | |
1542 | stmtblock_t block; | |
1543 | stmtblock_t body; | |
1544 | tree type; | |
1545 | tree tmp; | |
1546 | tree found; | |
1547 | gfc_loopinfo loop; | |
1548 | gfc_actual_arglist *actual; | |
1549 | gfc_ss *arrayss; | |
1550 | gfc_se arrayse; | |
1551 | tree exit_label; | |
1552 | ||
1553 | if (se->ss) | |
1554 | { | |
1555 | gfc_conv_intrinsic_funcall (se, expr); | |
1556 | return; | |
1557 | } | |
1558 | ||
1559 | actual = expr->value.function.actual; | |
1560 | type = gfc_typenode_for_spec (&expr->ts); | |
1561 | /* Initialize the result. */ | |
1562 | resvar = gfc_create_var (type, "test"); | |
1563 | if (op == EQ_EXPR) | |
1564 | tmp = convert (type, boolean_true_node); | |
1565 | else | |
1566 | tmp = convert (type, boolean_false_node); | |
1567 | gfc_add_modify_expr (&se->pre, resvar, tmp); | |
1568 | ||
1569 | /* Walk the arguments. */ | |
1570 | arrayss = gfc_walk_expr (actual->expr); | |
6e45f57b | 1571 | gcc_assert (arrayss != gfc_ss_terminator); |
6de9cd9a DN |
1572 | |
1573 | /* Initialize the scalarizer. */ | |
1574 | gfc_init_loopinfo (&loop); | |
1575 | exit_label = gfc_build_label_decl (NULL_TREE); | |
1576 | TREE_USED (exit_label) = 1; | |
1577 | gfc_add_ss_to_loop (&loop, arrayss); | |
1578 | ||
1579 | /* Initialize the loop. */ | |
1580 | gfc_conv_ss_startstride (&loop); | |
1581 | gfc_conv_loop_setup (&loop); | |
1582 | ||
1583 | gfc_mark_ss_chain_used (arrayss, 1); | |
1584 | /* Generate the loop body. */ | |
1585 | gfc_start_scalarized_body (&loop, &body); | |
1586 | ||
1587 | /* If the condition matches then set the return value. */ | |
1588 | gfc_start_block (&block); | |
1589 | if (op == EQ_EXPR) | |
1590 | tmp = convert (type, boolean_false_node); | |
1591 | else | |
1592 | tmp = convert (type, boolean_true_node); | |
1593 | gfc_add_modify_expr (&block, resvar, tmp); | |
1594 | ||
1595 | /* And break out of the loop. */ | |
1596 | tmp = build1_v (GOTO_EXPR, exit_label); | |
1597 | gfc_add_expr_to_block (&block, tmp); | |
1598 | ||
1599 | found = gfc_finish_block (&block); | |
1600 | ||
1601 | /* Check this element. */ | |
1602 | gfc_init_se (&arrayse, NULL); | |
1603 | gfc_copy_loopinfo_to_se (&arrayse, &loop); | |
1604 | arrayse.ss = arrayss; | |
1605 | gfc_conv_expr_val (&arrayse, actual->expr); | |
1606 | ||
1607 | gfc_add_block_to_block (&body, &arrayse.pre); | |
923ab88c | 1608 | tmp = build2 (op, boolean_type_node, arrayse.expr, |
e805a599 | 1609 | build_int_cst (TREE_TYPE (arrayse.expr), 0)); |
923ab88c | 1610 | tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt ()); |
6de9cd9a DN |
1611 | gfc_add_expr_to_block (&body, tmp); |
1612 | gfc_add_block_to_block (&body, &arrayse.post); | |
1613 | ||
1614 | gfc_trans_scalarizing_loops (&loop, &body); | |
1615 | ||
1616 | /* Add the exit label. */ | |
1617 | tmp = build1_v (LABEL_EXPR, exit_label); | |
1618 | gfc_add_expr_to_block (&loop.pre, tmp); | |
1619 | ||
1620 | gfc_add_block_to_block (&se->pre, &loop.pre); | |
1621 | gfc_add_block_to_block (&se->pre, &loop.post); | |
1622 | gfc_cleanup_loop (&loop); | |
1623 | ||
1624 | se->expr = resvar; | |
1625 | } | |
1626 | ||
1627 | /* COUNT(A) = Number of true elements in A. */ | |
1628 | static void | |
1629 | gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr) | |
1630 | { | |
1631 | tree resvar; | |
1632 | tree type; | |
1633 | stmtblock_t body; | |
1634 | tree tmp; | |
1635 | gfc_loopinfo loop; | |
1636 | gfc_actual_arglist *actual; | |
1637 | gfc_ss *arrayss; | |
1638 | gfc_se arrayse; | |
1639 | ||
1640 | if (se->ss) | |
1641 | { | |
1642 | gfc_conv_intrinsic_funcall (se, expr); | |
1643 | return; | |
1644 | } | |
1645 | ||
1646 | actual = expr->value.function.actual; | |
1647 | ||
1648 | type = gfc_typenode_for_spec (&expr->ts); | |
1649 | /* Initialize the result. */ | |
1650 | resvar = gfc_create_var (type, "count"); | |
e805a599 | 1651 | gfc_add_modify_expr (&se->pre, resvar, build_int_cst (type, 0)); |
6de9cd9a DN |
1652 | |
1653 | /* Walk the arguments. */ | |
1654 | arrayss = gfc_walk_expr (actual->expr); | |
6e45f57b | 1655 | gcc_assert (arrayss != gfc_ss_terminator); |
6de9cd9a DN |
1656 | |
1657 | /* Initialize the scalarizer. */ | |
1658 | gfc_init_loopinfo (&loop); | |
1659 | gfc_add_ss_to_loop (&loop, arrayss); | |
1660 | ||
1661 | /* Initialize the loop. */ | |
1662 | gfc_conv_ss_startstride (&loop); | |
1663 | gfc_conv_loop_setup (&loop); | |
1664 | ||
1665 | gfc_mark_ss_chain_used (arrayss, 1); | |
1666 | /* Generate the loop body. */ | |
1667 | gfc_start_scalarized_body (&loop, &body); | |
1668 | ||
923ab88c | 1669 | tmp = build2 (PLUS_EXPR, TREE_TYPE (resvar), resvar, |
e805a599 | 1670 | build_int_cst (TREE_TYPE (resvar), 1)); |
923ab88c | 1671 | tmp = build2_v (MODIFY_EXPR, resvar, tmp); |
6de9cd9a DN |
1672 | |
1673 | gfc_init_se (&arrayse, NULL); | |
1674 | gfc_copy_loopinfo_to_se (&arrayse, &loop); | |
1675 | arrayse.ss = arrayss; | |
1676 | gfc_conv_expr_val (&arrayse, actual->expr); | |
923ab88c | 1677 | tmp = build3_v (COND_EXPR, arrayse.expr, tmp, build_empty_stmt ()); |
6de9cd9a DN |
1678 | |
1679 | gfc_add_block_to_block (&body, &arrayse.pre); | |
1680 | gfc_add_expr_to_block (&body, tmp); | |
1681 | gfc_add_block_to_block (&body, &arrayse.post); | |
1682 | ||
1683 | gfc_trans_scalarizing_loops (&loop, &body); | |
1684 | ||
1685 | gfc_add_block_to_block (&se->pre, &loop.pre); | |
1686 | gfc_add_block_to_block (&se->pre, &loop.post); | |
1687 | gfc_cleanup_loop (&loop); | |
1688 | ||
1689 | se->expr = resvar; | |
1690 | } | |
1691 | ||
1692 | /* Inline implementation of the sum and product intrinsics. */ | |
1693 | static void | |
1694 | gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op) | |
1695 | { | |
1696 | tree resvar; | |
1697 | tree type; | |
1698 | stmtblock_t body; | |
1699 | stmtblock_t block; | |
1700 | tree tmp; | |
1701 | gfc_loopinfo loop; | |
1702 | gfc_actual_arglist *actual; | |
1703 | gfc_ss *arrayss; | |
1704 | gfc_ss *maskss; | |
1705 | gfc_se arrayse; | |
1706 | gfc_se maskse; | |
1707 | gfc_expr *arrayexpr; | |
1708 | gfc_expr *maskexpr; | |
1709 | ||
1710 | if (se->ss) | |
1711 | { | |
1712 | gfc_conv_intrinsic_funcall (se, expr); | |
1713 | return; | |
1714 | } | |
1715 | ||
1716 | type = gfc_typenode_for_spec (&expr->ts); | |
1717 | /* Initialize the result. */ | |
1718 | resvar = gfc_create_var (type, "val"); | |
1719 | if (op == PLUS_EXPR) | |
1720 | tmp = gfc_build_const (type, integer_zero_node); | |
1721 | else | |
1722 | tmp = gfc_build_const (type, integer_one_node); | |
1723 | ||
1724 | gfc_add_modify_expr (&se->pre, resvar, tmp); | |
1725 | ||
1726 | /* Walk the arguments. */ | |
1727 | actual = expr->value.function.actual; | |
1728 | arrayexpr = actual->expr; | |
1729 | arrayss = gfc_walk_expr (arrayexpr); | |
6e45f57b | 1730 | gcc_assert (arrayss != gfc_ss_terminator); |
6de9cd9a DN |
1731 | |
1732 | actual = actual->next->next; | |
6e45f57b | 1733 | gcc_assert (actual); |
6de9cd9a | 1734 | maskexpr = actual->expr; |
eaf618e3 | 1735 | if (maskexpr && maskexpr->rank != 0) |
6de9cd9a DN |
1736 | { |
1737 | maskss = gfc_walk_expr (maskexpr); | |
6e45f57b | 1738 | gcc_assert (maskss != gfc_ss_terminator); |
6de9cd9a DN |
1739 | } |
1740 | else | |
1741 | maskss = NULL; | |
1742 | ||
1743 | /* Initialize the scalarizer. */ | |
1744 | gfc_init_loopinfo (&loop); | |
1745 | gfc_add_ss_to_loop (&loop, arrayss); | |
1746 | if (maskss) | |
1747 | gfc_add_ss_to_loop (&loop, maskss); | |
1748 | ||
1749 | /* Initialize the loop. */ | |
1750 | gfc_conv_ss_startstride (&loop); | |
1751 | gfc_conv_loop_setup (&loop); | |
1752 | ||
1753 | gfc_mark_ss_chain_used (arrayss, 1); | |
1754 | if (maskss) | |
1755 | gfc_mark_ss_chain_used (maskss, 1); | |
1756 | /* Generate the loop body. */ | |
1757 | gfc_start_scalarized_body (&loop, &body); | |
1758 | ||
1759 | /* If we have a mask, only add this element if the mask is set. */ | |
1760 | if (maskss) | |
1761 | { | |
1762 | gfc_init_se (&maskse, NULL); | |
1763 | gfc_copy_loopinfo_to_se (&maskse, &loop); | |
1764 | maskse.ss = maskss; | |
1765 | gfc_conv_expr_val (&maskse, maskexpr); | |
1766 | gfc_add_block_to_block (&body, &maskse.pre); | |
1767 | ||
1768 | gfc_start_block (&block); | |
1769 | } | |
1770 | else | |
1771 | gfc_init_block (&block); | |
1772 | ||
1773 | /* Do the actual summation/product. */ | |
1774 | gfc_init_se (&arrayse, NULL); | |
1775 | gfc_copy_loopinfo_to_se (&arrayse, &loop); | |
1776 | arrayse.ss = arrayss; | |
1777 | gfc_conv_expr_val (&arrayse, arrayexpr); | |
1778 | gfc_add_block_to_block (&block, &arrayse.pre); | |
1779 | ||
923ab88c | 1780 | tmp = build2 (op, type, resvar, arrayse.expr); |
6de9cd9a DN |
1781 | gfc_add_modify_expr (&block, resvar, tmp); |
1782 | gfc_add_block_to_block (&block, &arrayse.post); | |
1783 | ||
1784 | if (maskss) | |
1785 | { | |
1786 | /* We enclose the above in if (mask) {...} . */ | |
1787 | tmp = gfc_finish_block (&block); | |
1788 | ||
923ab88c | 1789 | tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ()); |
6de9cd9a DN |
1790 | } |
1791 | else | |
1792 | tmp = gfc_finish_block (&block); | |
1793 | gfc_add_expr_to_block (&body, tmp); | |
1794 | ||
1795 | gfc_trans_scalarizing_loops (&loop, &body); | |
eaf618e3 TK |
1796 | |
1797 | /* For a scalar mask, enclose the loop in an if statement. */ | |
1798 | if (maskexpr && maskss == NULL) | |
1799 | { | |
1800 | gfc_init_se (&maskse, NULL); | |
1801 | gfc_conv_expr_val (&maskse, maskexpr); | |
1802 | gfc_init_block (&block); | |
1803 | gfc_add_block_to_block (&block, &loop.pre); | |
1804 | gfc_add_block_to_block (&block, &loop.post); | |
1805 | tmp = gfc_finish_block (&block); | |
1806 | ||
1807 | tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ()); | |
1808 | gfc_add_expr_to_block (&block, tmp); | |
1809 | gfc_add_block_to_block (&se->pre, &block); | |
1810 | } | |
1811 | else | |
1812 | { | |
1813 | gfc_add_block_to_block (&se->pre, &loop.pre); | |
1814 | gfc_add_block_to_block (&se->pre, &loop.post); | |
1815 | } | |
1816 | ||
6de9cd9a DN |
1817 | gfc_cleanup_loop (&loop); |
1818 | ||
1819 | se->expr = resvar; | |
1820 | } | |
1821 | ||
61321991 PT |
1822 | |
1823 | /* Inline implementation of the dot_product intrinsic. This function | |
1824 | is based on gfc_conv_intrinsic_arith (the previous function). */ | |
1825 | static void | |
1826 | gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr) | |
1827 | { | |
1828 | tree resvar; | |
1829 | tree type; | |
1830 | stmtblock_t body; | |
1831 | stmtblock_t block; | |
1832 | tree tmp; | |
1833 | gfc_loopinfo loop; | |
1834 | gfc_actual_arglist *actual; | |
1835 | gfc_ss *arrayss1, *arrayss2; | |
1836 | gfc_se arrayse1, arrayse2; | |
1837 | gfc_expr *arrayexpr1, *arrayexpr2; | |
1838 | ||
1839 | type = gfc_typenode_for_spec (&expr->ts); | |
1840 | ||
1841 | /* Initialize the result. */ | |
1842 | resvar = gfc_create_var (type, "val"); | |
1843 | if (expr->ts.type == BT_LOGICAL) | |
1844 | tmp = convert (type, integer_zero_node); | |
1845 | else | |
1846 | tmp = gfc_build_const (type, integer_zero_node); | |
1847 | ||
1848 | gfc_add_modify_expr (&se->pre, resvar, tmp); | |
1849 | ||
1850 | /* Walk argument #1. */ | |
1851 | actual = expr->value.function.actual; | |
1852 | arrayexpr1 = actual->expr; | |
1853 | arrayss1 = gfc_walk_expr (arrayexpr1); | |
1854 | gcc_assert (arrayss1 != gfc_ss_terminator); | |
1855 | ||
1856 | /* Walk argument #2. */ | |
1857 | actual = actual->next; | |
1858 | arrayexpr2 = actual->expr; | |
1859 | arrayss2 = gfc_walk_expr (arrayexpr2); | |
1860 | gcc_assert (arrayss2 != gfc_ss_terminator); | |
1861 | ||
1862 | /* Initialize the scalarizer. */ | |
1863 | gfc_init_loopinfo (&loop); | |
1864 | gfc_add_ss_to_loop (&loop, arrayss1); | |
1865 | gfc_add_ss_to_loop (&loop, arrayss2); | |
1866 | ||
1867 | /* Initialize the loop. */ | |
1868 | gfc_conv_ss_startstride (&loop); | |
1869 | gfc_conv_loop_setup (&loop); | |
1870 | ||
1871 | gfc_mark_ss_chain_used (arrayss1, 1); | |
1872 | gfc_mark_ss_chain_used (arrayss2, 1); | |
1873 | ||
1874 | /* Generate the loop body. */ | |
1875 | gfc_start_scalarized_body (&loop, &body); | |
1876 | gfc_init_block (&block); | |
1877 | ||
1878 | /* Make the tree expression for [conjg(]array1[)]. */ | |
1879 | gfc_init_se (&arrayse1, NULL); | |
1880 | gfc_copy_loopinfo_to_se (&arrayse1, &loop); | |
1881 | arrayse1.ss = arrayss1; | |
1882 | gfc_conv_expr_val (&arrayse1, arrayexpr1); | |
1883 | if (expr->ts.type == BT_COMPLEX) | |
1884 | arrayse1.expr = build1 (CONJ_EXPR, type, arrayse1.expr); | |
1885 | gfc_add_block_to_block (&block, &arrayse1.pre); | |
1886 | ||
1887 | /* Make the tree expression for array2. */ | |
1888 | gfc_init_se (&arrayse2, NULL); | |
1889 | gfc_copy_loopinfo_to_se (&arrayse2, &loop); | |
1890 | arrayse2.ss = arrayss2; | |
1891 | gfc_conv_expr_val (&arrayse2, arrayexpr2); | |
1892 | gfc_add_block_to_block (&block, &arrayse2.pre); | |
1893 | ||
1894 | /* Do the actual product and sum. */ | |
1895 | if (expr->ts.type == BT_LOGICAL) | |
1896 | { | |
1897 | tmp = build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr); | |
1898 | tmp = build2 (TRUTH_OR_EXPR, type, resvar, tmp); | |
1899 | } | |
1900 | else | |
1901 | { | |
1902 | tmp = build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr); | |
1903 | tmp = build2 (PLUS_EXPR, type, resvar, tmp); | |
1904 | } | |
1905 | gfc_add_modify_expr (&block, resvar, tmp); | |
1906 | ||
1907 | /* Finish up the loop block and the loop. */ | |
1908 | tmp = gfc_finish_block (&block); | |
1909 | gfc_add_expr_to_block (&body, tmp); | |
1910 | ||
1911 | gfc_trans_scalarizing_loops (&loop, &body); | |
1912 | gfc_add_block_to_block (&se->pre, &loop.pre); | |
1913 | gfc_add_block_to_block (&se->pre, &loop.post); | |
1914 | gfc_cleanup_loop (&loop); | |
1915 | ||
1916 | se->expr = resvar; | |
1917 | } | |
1918 | ||
1919 | ||
6de9cd9a DN |
1920 | static void |
1921 | gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op) | |
1922 | { | |
1923 | stmtblock_t body; | |
1924 | stmtblock_t block; | |
1925 | stmtblock_t ifblock; | |
8cd25827 | 1926 | stmtblock_t elseblock; |
6de9cd9a DN |
1927 | tree limit; |
1928 | tree type; | |
1929 | tree tmp; | |
8cd25827 | 1930 | tree elsetmp; |
6de9cd9a | 1931 | tree ifbody; |
6de9cd9a DN |
1932 | gfc_loopinfo loop; |
1933 | gfc_actual_arglist *actual; | |
1934 | gfc_ss *arrayss; | |
1935 | gfc_ss *maskss; | |
1936 | gfc_se arrayse; | |
1937 | gfc_se maskse; | |
1938 | gfc_expr *arrayexpr; | |
1939 | gfc_expr *maskexpr; | |
1940 | tree pos; | |
1941 | int n; | |
1942 | ||
1943 | if (se->ss) | |
1944 | { | |
1945 | gfc_conv_intrinsic_funcall (se, expr); | |
1946 | return; | |
1947 | } | |
1948 | ||
1949 | /* Initialize the result. */ | |
1950 | pos = gfc_create_var (gfc_array_index_type, "pos"); | |
1951 | type = gfc_typenode_for_spec (&expr->ts); | |
1952 | ||
1953 | /* Walk the arguments. */ | |
1954 | actual = expr->value.function.actual; | |
1955 | arrayexpr = actual->expr; | |
1956 | arrayss = gfc_walk_expr (arrayexpr); | |
6e45f57b | 1957 | gcc_assert (arrayss != gfc_ss_terminator); |
6de9cd9a DN |
1958 | |
1959 | actual = actual->next->next; | |
6e45f57b | 1960 | gcc_assert (actual); |
6de9cd9a | 1961 | maskexpr = actual->expr; |
8cd25827 | 1962 | if (maskexpr && maskexpr->rank != 0) |
6de9cd9a DN |
1963 | { |
1964 | maskss = gfc_walk_expr (maskexpr); | |
6e45f57b | 1965 | gcc_assert (maskss != gfc_ss_terminator); |
6de9cd9a DN |
1966 | } |
1967 | else | |
1968 | maskss = NULL; | |
1969 | ||
1970 | limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit"); | |
e7a2d5fb | 1971 | n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false); |
6de9cd9a DN |
1972 | switch (arrayexpr->ts.type) |
1973 | { | |
1974 | case BT_REAL: | |
f8e566e5 | 1975 | tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind); |
6de9cd9a DN |
1976 | break; |
1977 | ||
1978 | case BT_INTEGER: | |
1979 | tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, | |
1980 | arrayexpr->ts.kind); | |
1981 | break; | |
1982 | ||
1983 | default: | |
6e45f57b | 1984 | gcc_unreachable (); |
6de9cd9a DN |
1985 | } |
1986 | ||
88116029 TB |
1987 | /* We start with the most negative possible value for MAXLOC, and the most |
1988 | positive possible value for MINLOC. The most negative possible value is | |
1989 | -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive | |
1990 | possible value is HUGE in both cases. */ | |
6de9cd9a | 1991 | if (op == GT_EXPR) |
10c7a96f | 1992 | tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp); |
6de9cd9a DN |
1993 | gfc_add_modify_expr (&se->pre, limit, tmp); |
1994 | ||
88116029 TB |
1995 | if (op == GT_EXPR && expr->ts.type == BT_INTEGER) |
1996 | tmp = build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp, | |
1997 | build_int_cst (type, 1)); | |
1998 | ||
6de9cd9a DN |
1999 | /* Initialize the scalarizer. */ |
2000 | gfc_init_loopinfo (&loop); | |
2001 | gfc_add_ss_to_loop (&loop, arrayss); | |
2002 | if (maskss) | |
2003 | gfc_add_ss_to_loop (&loop, maskss); | |
2004 | ||
2005 | /* Initialize the loop. */ | |
2006 | gfc_conv_ss_startstride (&loop); | |
2007 | gfc_conv_loop_setup (&loop); | |
2008 | ||
6e45f57b | 2009 | gcc_assert (loop.dimen == 1); |
6de9cd9a | 2010 | |
a4b9e93e PT |
2011 | /* Initialize the position to zero, following Fortran 2003. We are free |
2012 | to do this because Fortran 95 allows the result of an entirely false | |
2013 | mask to be processor dependent. */ | |
2014 | gfc_add_modify_expr (&loop.pre, pos, gfc_index_zero_node); | |
b36cd00b | 2015 | |
6de9cd9a DN |
2016 | gfc_mark_ss_chain_used (arrayss, 1); |
2017 | if (maskss) | |
2018 | gfc_mark_ss_chain_used (maskss, 1); | |
2019 | /* Generate the loop body. */ | |
2020 | gfc_start_scalarized_body (&loop, &body); | |
2021 | ||
2022 | /* If we have a mask, only check this element if the mask is set. */ | |
2023 | if (maskss) | |
2024 | { | |
2025 | gfc_init_se (&maskse, NULL); | |
2026 | gfc_copy_loopinfo_to_se (&maskse, &loop); | |
2027 | maskse.ss = maskss; | |
2028 | gfc_conv_expr_val (&maskse, maskexpr); | |
2029 | gfc_add_block_to_block (&body, &maskse.pre); | |
2030 | ||
2031 | gfc_start_block (&block); | |
2032 | } | |
2033 | else | |
2034 | gfc_init_block (&block); | |
2035 | ||
2036 | /* Compare with the current limit. */ | |
2037 | gfc_init_se (&arrayse, NULL); | |
2038 | gfc_copy_loopinfo_to_se (&arrayse, &loop); | |
2039 | arrayse.ss = arrayss; | |
2040 | gfc_conv_expr_val (&arrayse, arrayexpr); | |
2041 | gfc_add_block_to_block (&block, &arrayse.pre); | |
2042 | ||
2043 | /* We do the following if this is a more extreme value. */ | |
2044 | gfc_start_block (&ifblock); | |
2045 | ||
2046 | /* Assign the value to the limit... */ | |
2047 | gfc_add_modify_expr (&ifblock, limit, arrayse.expr); | |
2048 | ||
2049 | /* Remember where we are. */ | |
2050 | gfc_add_modify_expr (&ifblock, pos, loop.loopvar[0]); | |
2051 | ||
2052 | ifbody = gfc_finish_block (&ifblock); | |
2053 | ||
a4b9e93e PT |
2054 | /* If it is a more extreme value or pos is still zero. */ |
2055 | tmp = build2 (TRUTH_OR_EXPR, boolean_type_node, | |
2056 | build2 (op, boolean_type_node, arrayse.expr, limit), | |
2057 | build2 (EQ_EXPR, boolean_type_node, pos, gfc_index_zero_node)); | |
923ab88c | 2058 | tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ()); |
6de9cd9a DN |
2059 | gfc_add_expr_to_block (&block, tmp); |
2060 | ||
2061 | if (maskss) | |
2062 | { | |
2063 | /* We enclose the above in if (mask) {...}. */ | |
2064 | tmp = gfc_finish_block (&block); | |
2065 | ||
923ab88c | 2066 | tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ()); |
6de9cd9a DN |
2067 | } |
2068 | else | |
2069 | tmp = gfc_finish_block (&block); | |
2070 | gfc_add_expr_to_block (&body, tmp); | |
2071 | ||
2072 | gfc_trans_scalarizing_loops (&loop, &body); | |
2073 | ||
8cd25827 TK |
2074 | /* For a scalar mask, enclose the loop in an if statement. */ |
2075 | if (maskexpr && maskss == NULL) | |
2076 | { | |
2077 | gfc_init_se (&maskse, NULL); | |
2078 | gfc_conv_expr_val (&maskse, maskexpr); | |
2079 | gfc_init_block (&block); | |
2080 | gfc_add_block_to_block (&block, &loop.pre); | |
2081 | gfc_add_block_to_block (&block, &loop.post); | |
2082 | tmp = gfc_finish_block (&block); | |
2083 | ||
2084 | /* For the else part of the scalar mask, just initialize | |
2085 | the pos variable the same way as above. */ | |
2086 | ||
2087 | gfc_init_block (&elseblock); | |
a4b9e93e | 2088 | gfc_add_modify_expr (&elseblock, pos, gfc_index_zero_node); |
8cd25827 TK |
2089 | elsetmp = gfc_finish_block (&elseblock); |
2090 | ||
2091 | tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp); | |
2092 | gfc_add_expr_to_block (&block, tmp); | |
2093 | gfc_add_block_to_block (&se->pre, &block); | |
2094 | } | |
2095 | else | |
2096 | { | |
2097 | gfc_add_block_to_block (&se->pre, &loop.pre); | |
2098 | gfc_add_block_to_block (&se->pre, &loop.post); | |
2099 | } | |
6de9cd9a DN |
2100 | gfc_cleanup_loop (&loop); |
2101 | ||
2102 | /* Return a value in the range 1..SIZE(array). */ | |
10c7a96f SB |
2103 | tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, loop.from[0], |
2104 | gfc_index_one_node); | |
2105 | tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, pos, tmp); | |
6de9cd9a DN |
2106 | /* And convert to the required type. */ |
2107 | se->expr = convert (type, tmp); | |
2108 | } | |
2109 | ||
2110 | static void | |
2111 | gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op) | |
2112 | { | |
2113 | tree limit; | |
2114 | tree type; | |
2115 | tree tmp; | |
2116 | tree ifbody; | |
2117 | stmtblock_t body; | |
2118 | stmtblock_t block; | |
2119 | gfc_loopinfo loop; | |
2120 | gfc_actual_arglist *actual; | |
2121 | gfc_ss *arrayss; | |
2122 | gfc_ss *maskss; | |
2123 | gfc_se arrayse; | |
2124 | gfc_se maskse; | |
2125 | gfc_expr *arrayexpr; | |
2126 | gfc_expr *maskexpr; | |
2127 | int n; | |
2128 | ||
2129 | if (se->ss) | |
2130 | { | |
2131 | gfc_conv_intrinsic_funcall (se, expr); | |
2132 | return; | |
2133 | } | |
2134 | ||
2135 | type = gfc_typenode_for_spec (&expr->ts); | |
2136 | /* Initialize the result. */ | |
2137 | limit = gfc_create_var (type, "limit"); | |
e7a2d5fb | 2138 | n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false); |
6de9cd9a DN |
2139 | switch (expr->ts.type) |
2140 | { | |
2141 | case BT_REAL: | |
f8e566e5 | 2142 | tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind); |
6de9cd9a DN |
2143 | break; |
2144 | ||
2145 | case BT_INTEGER: | |
2146 | tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind); | |
2147 | break; | |
2148 | ||
2149 | default: | |
6e45f57b | 2150 | gcc_unreachable (); |
6de9cd9a DN |
2151 | } |
2152 | ||
88116029 TB |
2153 | /* We start with the most negative possible value for MAXVAL, and the most |
2154 | positive possible value for MINVAL. The most negative possible value is | |
2155 | -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive | |
2156 | possible value is HUGE in both cases. */ | |
6de9cd9a | 2157 | if (op == GT_EXPR) |
10c7a96f | 2158 | tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp); |
88116029 TB |
2159 | |
2160 | if (op == GT_EXPR && expr->ts.type == BT_INTEGER) | |
2161 | tmp = build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp, | |
2162 | build_int_cst (type, 1)); | |
2163 | ||
6de9cd9a DN |
2164 | gfc_add_modify_expr (&se->pre, limit, tmp); |
2165 | ||
2166 | /* Walk the arguments. */ | |
2167 | actual = expr->value.function.actual; | |
2168 | arrayexpr = actual->expr; | |
2169 | arrayss = gfc_walk_expr (arrayexpr); | |
6e45f57b | 2170 | gcc_assert (arrayss != gfc_ss_terminator); |
6de9cd9a DN |
2171 | |
2172 | actual = actual->next->next; | |
6e45f57b | 2173 | gcc_assert (actual); |
6de9cd9a | 2174 | maskexpr = actual->expr; |
eaf618e3 | 2175 | if (maskexpr && maskexpr->rank != 0) |
6de9cd9a DN |
2176 | { |
2177 | maskss = gfc_walk_expr (maskexpr); | |
6e45f57b | 2178 | gcc_assert (maskss != gfc_ss_terminator); |
6de9cd9a DN |
2179 | } |
2180 | else | |
2181 | maskss = NULL; | |
2182 | ||
2183 | /* Initialize the scalarizer. */ | |
2184 | gfc_init_loopinfo (&loop); | |
2185 | gfc_add_ss_to_loop (&loop, arrayss); | |
2186 | if (maskss) | |
2187 | gfc_add_ss_to_loop (&loop, maskss); | |
2188 | ||
2189 | /* Initialize the loop. */ | |
2190 | gfc_conv_ss_startstride (&loop); | |
2191 | gfc_conv_loop_setup (&loop); | |
2192 | ||
2193 | gfc_mark_ss_chain_used (arrayss, 1); | |
2194 | if (maskss) | |
2195 | gfc_mark_ss_chain_used (maskss, 1); | |
2196 | /* Generate the loop body. */ | |
2197 | gfc_start_scalarized_body (&loop, &body); | |
2198 | ||
2199 | /* If we have a mask, only add this element if the mask is set. */ | |
2200 | if (maskss) | |
2201 | { | |
2202 | gfc_init_se (&maskse, NULL); | |
2203 | gfc_copy_loopinfo_to_se (&maskse, &loop); | |
2204 | maskse.ss = maskss; | |
2205 | gfc_conv_expr_val (&maskse, maskexpr); | |
2206 | gfc_add_block_to_block (&body, &maskse.pre); | |
2207 | ||
2208 | gfc_start_block (&block); | |
2209 | } | |
2210 | else | |
2211 | gfc_init_block (&block); | |
2212 | ||
2213 | /* Compare with the current limit. */ | |
2214 | gfc_init_se (&arrayse, NULL); | |
2215 | gfc_copy_loopinfo_to_se (&arrayse, &loop); | |
2216 | arrayse.ss = arrayss; | |
2217 | gfc_conv_expr_val (&arrayse, arrayexpr); | |
2218 | gfc_add_block_to_block (&block, &arrayse.pre); | |
2219 | ||
2220 | /* Assign the value to the limit... */ | |
923ab88c | 2221 | ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr); |
6de9cd9a DN |
2222 | |
2223 | /* If it is a more extreme value. */ | |
923ab88c TS |
2224 | tmp = build2 (op, boolean_type_node, arrayse.expr, limit); |
2225 | tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ()); | |
6de9cd9a DN |
2226 | gfc_add_expr_to_block (&block, tmp); |
2227 | gfc_add_block_to_block (&block, &arrayse.post); | |
2228 | ||
2229 | tmp = gfc_finish_block (&block); | |
2230 | if (maskss) | |
923ab88c TS |
2231 | /* We enclose the above in if (mask) {...}. */ |
2232 | tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ()); | |
6de9cd9a DN |
2233 | gfc_add_expr_to_block (&body, tmp); |
2234 | ||
2235 | gfc_trans_scalarizing_loops (&loop, &body); | |
2236 | ||
eaf618e3 TK |
2237 | /* For a scalar mask, enclose the loop in an if statement. */ |
2238 | if (maskexpr && maskss == NULL) | |
2239 | { | |
2240 | gfc_init_se (&maskse, NULL); | |
2241 | gfc_conv_expr_val (&maskse, maskexpr); | |
2242 | gfc_init_block (&block); | |
2243 | gfc_add_block_to_block (&block, &loop.pre); | |
2244 | gfc_add_block_to_block (&block, &loop.post); | |
2245 | tmp = gfc_finish_block (&block); | |
2246 | ||
2247 | tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ()); | |
2248 | gfc_add_expr_to_block (&block, tmp); | |
2249 | gfc_add_block_to_block (&se->pre, &block); | |
2250 | } | |
2251 | else | |
2252 | { | |
2253 | gfc_add_block_to_block (&se->pre, &loop.pre); | |
2254 | gfc_add_block_to_block (&se->pre, &loop.post); | |
2255 | } | |
2256 | ||
6de9cd9a DN |
2257 | gfc_cleanup_loop (&loop); |
2258 | ||
2259 | se->expr = limit; | |
2260 | } | |
2261 | ||
2262 | /* BTEST (i, pos) = (i & (1 << pos)) != 0. */ | |
2263 | static void | |
2264 | gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr) | |
2265 | { | |
2266 | tree arg; | |
2267 | tree arg2; | |
2268 | tree type; | |
2269 | tree tmp; | |
2270 | ||
2271 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
2272 | arg2 = TREE_VALUE (TREE_CHAIN (arg)); | |
2273 | arg = TREE_VALUE (arg); | |
2274 | type = TREE_TYPE (arg); | |
2275 | ||
e805a599 | 2276 | tmp = build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), arg2); |
923ab88c | 2277 | tmp = build2 (BIT_AND_EXPR, type, arg, tmp); |
10c7a96f SB |
2278 | tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, |
2279 | build_int_cst (type, 0)); | |
6de9cd9a DN |
2280 | type = gfc_typenode_for_spec (&expr->ts); |
2281 | se->expr = convert (type, tmp); | |
2282 | } | |
2283 | ||
2284 | /* Generate code to perform the specified operation. */ | |
2285 | static void | |
2286 | gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op) | |
2287 | { | |
2288 | tree arg; | |
2289 | tree arg2; | |
2290 | tree type; | |
2291 | ||
2292 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
2293 | arg2 = TREE_VALUE (TREE_CHAIN (arg)); | |
2294 | arg = TREE_VALUE (arg); | |
2295 | type = TREE_TYPE (arg); | |
2296 | ||
10c7a96f | 2297 | se->expr = fold_build2 (op, type, arg, arg2); |
6de9cd9a DN |
2298 | } |
2299 | ||
2300 | /* Bitwise not. */ | |
2301 | static void | |
2302 | gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr) | |
2303 | { | |
2304 | tree arg; | |
2305 | ||
2306 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
2307 | arg = TREE_VALUE (arg); | |
2308 | ||
2309 | se->expr = build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg); | |
2310 | } | |
2311 | ||
2312 | /* Set or clear a single bit. */ | |
2313 | static void | |
2314 | gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set) | |
2315 | { | |
2316 | tree arg; | |
2317 | tree arg2; | |
2318 | tree type; | |
2319 | tree tmp; | |
2320 | int op; | |
2321 | ||
2322 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
2323 | arg2 = TREE_VALUE (TREE_CHAIN (arg)); | |
2324 | arg = TREE_VALUE (arg); | |
2325 | type = TREE_TYPE (arg); | |
2326 | ||
10c7a96f | 2327 | tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), arg2); |
6de9cd9a DN |
2328 | if (set) |
2329 | op = BIT_IOR_EXPR; | |
2330 | else | |
2331 | { | |
2332 | op = BIT_AND_EXPR; | |
10c7a96f | 2333 | tmp = fold_build1 (BIT_NOT_EXPR, type, tmp); |
6de9cd9a | 2334 | } |
10c7a96f | 2335 | se->expr = fold_build2 (op, type, arg, tmp); |
6de9cd9a DN |
2336 | } |
2337 | ||
2338 | /* Extract a sequence of bits. | |
2339 | IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */ | |
2340 | static void | |
2341 | gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr) | |
2342 | { | |
2343 | tree arg; | |
2344 | tree arg2; | |
2345 | tree arg3; | |
2346 | tree type; | |
2347 | tree tmp; | |
2348 | tree mask; | |
2349 | ||
2350 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
2351 | arg2 = TREE_CHAIN (arg); | |
2352 | arg3 = TREE_VALUE (TREE_CHAIN (arg2)); | |
2353 | arg = TREE_VALUE (arg); | |
2354 | arg2 = TREE_VALUE (arg2); | |
2355 | type = TREE_TYPE (arg); | |
2356 | ||
b17a1b93 | 2357 | mask = build_int_cst (type, -1); |
923ab88c | 2358 | mask = build2 (LSHIFT_EXPR, type, mask, arg3); |
6de9cd9a DN |
2359 | mask = build1 (BIT_NOT_EXPR, type, mask); |
2360 | ||
923ab88c | 2361 | tmp = build2 (RSHIFT_EXPR, type, arg, arg2); |
6de9cd9a | 2362 | |
10c7a96f | 2363 | se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask); |
6de9cd9a DN |
2364 | } |
2365 | ||
a119fc1c FXC |
2366 | /* RSHIFT (I, SHIFT) = I >> SHIFT |
2367 | LSHIFT (I, SHIFT) = I << SHIFT */ | |
2368 | static void | |
2369 | gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift) | |
2370 | { | |
2371 | tree arg; | |
2372 | tree arg2; | |
2373 | ||
2374 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
2375 | arg2 = TREE_VALUE (TREE_CHAIN (arg)); | |
2376 | arg = TREE_VALUE (arg); | |
2377 | ||
2378 | se->expr = fold_build2 (right_shift ? RSHIFT_EXPR : LSHIFT_EXPR, | |
2379 | TREE_TYPE (arg), arg, arg2); | |
2380 | } | |
2381 | ||
56746a07 TS |
2382 | /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i)) |
2383 | ? 0 | |
2384 | : ((shift >= 0) ? i << shift : i >> -shift) | |
2385 | where all shifts are logical shifts. */ | |
6de9cd9a DN |
2386 | static void |
2387 | gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr) | |
2388 | { | |
2389 | tree arg; | |
2390 | tree arg2; | |
2391 | tree type; | |
56746a07 | 2392 | tree utype; |
6de9cd9a | 2393 | tree tmp; |
56746a07 TS |
2394 | tree width; |
2395 | tree num_bits; | |
2396 | tree cond; | |
6de9cd9a DN |
2397 | tree lshift; |
2398 | tree rshift; | |
2399 | ||
2400 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
2401 | arg2 = TREE_VALUE (TREE_CHAIN (arg)); | |
2402 | arg = TREE_VALUE (arg); | |
2403 | type = TREE_TYPE (arg); | |
56746a07 | 2404 | utype = gfc_unsigned_type (type); |
6de9cd9a | 2405 | |
10c7a96f | 2406 | width = fold_build1 (ABS_EXPR, TREE_TYPE (arg2), arg2); |
6de9cd9a | 2407 | |
56746a07 | 2408 | /* Left shift if positive. */ |
10c7a96f | 2409 | lshift = fold_build2 (LSHIFT_EXPR, type, arg, width); |
56746a07 | 2410 | |
de46b505 TS |
2411 | /* Right shift if negative. |
2412 | We convert to an unsigned type because we want a logical shift. | |
2413 | The standard doesn't define the case of shifting negative | |
2414 | numbers, and we try to be compatible with other compilers, most | |
2415 | notably g77, here. */ | |
2416 | rshift = fold_convert (type, build2 (RSHIFT_EXPR, utype, | |
f1b19062 | 2417 | convert (utype, arg), width)); |
56746a07 | 2418 | |
10c7a96f SB |
2419 | tmp = fold_build2 (GE_EXPR, boolean_type_node, arg2, |
2420 | build_int_cst (TREE_TYPE (arg2), 0)); | |
2421 | tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift); | |
56746a07 TS |
2422 | |
2423 | /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas | |
2424 | gcc requires a shift width < BIT_SIZE(I), so we have to catch this | |
2425 | special case. */ | |
de46b505 | 2426 | num_bits = build_int_cst (TREE_TYPE (arg2), TYPE_PRECISION (type)); |
10c7a96f | 2427 | cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits); |
56746a07 | 2428 | |
10c7a96f SB |
2429 | se->expr = fold_build3 (COND_EXPR, type, cond, |
2430 | build_int_cst (type, 0), tmp); | |
6de9cd9a DN |
2431 | } |
2432 | ||
2433 | /* Circular shift. AKA rotate or barrel shift. */ | |
2434 | static void | |
2435 | gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr) | |
2436 | { | |
2437 | tree arg; | |
2438 | tree arg2; | |
2439 | tree arg3; | |
2440 | tree type; | |
2441 | tree tmp; | |
2442 | tree lrot; | |
2443 | tree rrot; | |
e805a599 | 2444 | tree zero; |
6de9cd9a DN |
2445 | |
2446 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
2447 | arg2 = TREE_CHAIN (arg); | |
2448 | arg3 = TREE_CHAIN (arg2); | |
2449 | if (arg3) | |
2450 | { | |
2451 | /* Use a library function for the 3 parameter version. */ | |
56746a07 TS |
2452 | tree int4type = gfc_get_int_type (4); |
2453 | ||
6de9cd9a | 2454 | type = TREE_TYPE (TREE_VALUE (arg)); |
56746a07 TS |
2455 | /* We convert the first argument to at least 4 bytes, and |
2456 | convert back afterwards. This removes the need for library | |
2457 | functions for all argument sizes, and function will be | |
2458 | aligned to at least 32 bits, so there's no loss. */ | |
2459 | if (expr->ts.kind < 4) | |
2460 | { | |
2461 | tmp = convert (int4type, TREE_VALUE (arg)); | |
2462 | TREE_VALUE (arg) = tmp; | |
2463 | } | |
2464 | /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would | |
2465 | need loads of library functions. They cannot have values > | |
2466 | BIT_SIZE (I) so the conversion is safe. */ | |
2467 | TREE_VALUE (arg2) = convert (int4type, TREE_VALUE (arg2)); | |
2468 | TREE_VALUE (arg3) = convert (int4type, TREE_VALUE (arg3)); | |
6de9cd9a DN |
2469 | |
2470 | switch (expr->ts.kind) | |
2471 | { | |
56746a07 TS |
2472 | case 1: |
2473 | case 2: | |
6de9cd9a DN |
2474 | case 4: |
2475 | tmp = gfor_fndecl_math_ishftc4; | |
2476 | break; | |
2477 | case 8: | |
2478 | tmp = gfor_fndecl_math_ishftc8; | |
2479 | break; | |
644cb69f FXC |
2480 | case 16: |
2481 | tmp = gfor_fndecl_math_ishftc16; | |
2482 | break; | |
6de9cd9a | 2483 | default: |
6e45f57b | 2484 | gcc_unreachable (); |
6de9cd9a | 2485 | } |
3380b802 | 2486 | se->expr = build_function_call_expr (tmp, arg); |
56746a07 TS |
2487 | /* Convert the result back to the original type, if we extended |
2488 | the first argument's width above. */ | |
2489 | if (expr->ts.kind < 4) | |
2490 | se->expr = convert (type, se->expr); | |
2491 | ||
6de9cd9a DN |
2492 | return; |
2493 | } | |
2494 | arg = TREE_VALUE (arg); | |
2495 | arg2 = TREE_VALUE (arg2); | |
2496 | type = TREE_TYPE (arg); | |
2497 | ||
2498 | /* Rotate left if positive. */ | |
10c7a96f | 2499 | lrot = fold_build2 (LROTATE_EXPR, type, arg, arg2); |
6de9cd9a DN |
2500 | |
2501 | /* Rotate right if negative. */ | |
10c7a96f SB |
2502 | tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2); |
2503 | rrot = fold_build2 (RROTATE_EXPR, type, arg, tmp); | |
6de9cd9a | 2504 | |
e805a599 | 2505 | zero = build_int_cst (TREE_TYPE (arg2), 0); |
10c7a96f SB |
2506 | tmp = fold_build2 (GT_EXPR, boolean_type_node, arg2, zero); |
2507 | rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot); | |
6de9cd9a DN |
2508 | |
2509 | /* Do nothing if shift == 0. */ | |
10c7a96f SB |
2510 | tmp = fold_build2 (EQ_EXPR, boolean_type_node, arg2, zero); |
2511 | se->expr = fold_build3 (COND_EXPR, type, tmp, arg, rrot); | |
6de9cd9a DN |
2512 | } |
2513 | ||
2514 | /* The length of a character string. */ | |
2515 | static void | |
2516 | gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr) | |
2517 | { | |
2518 | tree len; | |
2519 | tree type; | |
2520 | tree decl; | |
2521 | gfc_symbol *sym; | |
2522 | gfc_se argse; | |
2523 | gfc_expr *arg; | |
dd5797cc | 2524 | gfc_ss *ss; |
6de9cd9a | 2525 | |
6e45f57b | 2526 | gcc_assert (!se->ss); |
6de9cd9a DN |
2527 | |
2528 | arg = expr->value.function.actual->expr; | |
2529 | ||
2530 | type = gfc_typenode_for_spec (&expr->ts); | |
2531 | switch (arg->expr_type) | |
2532 | { | |
2533 | case EXPR_CONSTANT: | |
7d60be94 | 2534 | len = build_int_cst (NULL_TREE, arg->value.character.length); |
6de9cd9a DN |
2535 | break; |
2536 | ||
636da744 PT |
2537 | case EXPR_ARRAY: |
2538 | /* Obtain the string length from the function used by | |
2539 | trans-array.c(gfc_trans_array_constructor). */ | |
2540 | len = NULL_TREE; | |
2541 | get_array_ctor_strlen (arg->value.constructor, &len); | |
2542 | break; | |
2543 | ||
dd5797cc PT |
2544 | case EXPR_VARIABLE: |
2545 | if (arg->ref == NULL | |
2546 | || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY)) | |
2547 | { | |
2548 | /* This doesn't catch all cases. | |
2549 | See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html | |
2550 | and the surrounding thread. */ | |
2551 | sym = arg->symtree->n.sym; | |
2552 | decl = gfc_get_symbol_decl (sym); | |
2553 | if (decl == current_function_decl && sym->attr.function | |
6de9cd9a | 2554 | && (sym->result == sym)) |
dd5797cc PT |
2555 | decl = gfc_get_fake_result_decl (sym, 0); |
2556 | ||
2557 | len = sym->ts.cl->backend_decl; | |
2558 | gcc_assert (len); | |
2559 | break; | |
6de9cd9a | 2560 | } |
dd5797cc PT |
2561 | |
2562 | /* Otherwise fall through. */ | |
2563 | ||
2564 | default: | |
2565 | /* Anybody stupid enough to do this deserves inefficient code. */ | |
2566 | ss = gfc_walk_expr (arg); | |
2567 | gfc_init_se (&argse, se); | |
2568 | if (ss == gfc_ss_terminator) | |
2569 | gfc_conv_expr (&argse, arg); | |
2570 | else | |
2571 | gfc_conv_expr_descriptor (&argse, arg, ss); | |
2572 | gfc_add_block_to_block (&se->pre, &argse.pre); | |
2573 | gfc_add_block_to_block (&se->post, &argse.post); | |
2574 | len = argse.string_length; | |
6de9cd9a DN |
2575 | break; |
2576 | } | |
2577 | se->expr = convert (type, len); | |
2578 | } | |
2579 | ||
2580 | /* The length of a character string not including trailing blanks. */ | |
2581 | static void | |
2582 | gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr) | |
2583 | { | |
2584 | tree args; | |
2585 | tree type; | |
2586 | ||
2587 | args = gfc_conv_intrinsic_function_args (se, expr); | |
2588 | type = gfc_typenode_for_spec (&expr->ts); | |
3380b802 | 2589 | se->expr = build_function_call_expr (gfor_fndecl_string_len_trim, args); |
6de9cd9a DN |
2590 | se->expr = convert (type, se->expr); |
2591 | } | |
2592 | ||
2593 | ||
2594 | /* Returns the starting position of a substring within a string. */ | |
2595 | ||
2596 | static void | |
2597 | gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr) | |
2598 | { | |
0da87370 | 2599 | tree logical4_type_node = gfc_get_logical_type (4); |
6de9cd9a DN |
2600 | tree args; |
2601 | tree back; | |
2602 | tree type; | |
2603 | tree tmp; | |
2604 | ||
2605 | args = gfc_conv_intrinsic_function_args (se, expr); | |
2606 | type = gfc_typenode_for_spec (&expr->ts); | |
2607 | tmp = gfc_advance_chain (args, 3); | |
2608 | if (TREE_CHAIN (tmp) == NULL_TREE) | |
2609 | { | |
0da87370 TS |
2610 | back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0), |
2611 | NULL_TREE); | |
6de9cd9a DN |
2612 | TREE_CHAIN (tmp) = back; |
2613 | } | |
2614 | else | |
2615 | { | |
2616 | back = TREE_CHAIN (tmp); | |
0da87370 | 2617 | TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back)); |
6de9cd9a DN |
2618 | } |
2619 | ||
3380b802 | 2620 | se->expr = build_function_call_expr (gfor_fndecl_string_index, args); |
6de9cd9a DN |
2621 | se->expr = convert (type, se->expr); |
2622 | } | |
2623 | ||
2624 | /* The ascii value for a single character. */ | |
2625 | static void | |
2626 | gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr) | |
2627 | { | |
2628 | tree arg; | |
2629 | tree type; | |
2630 | ||
2631 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
2632 | arg = TREE_VALUE (TREE_CHAIN (arg)); | |
6e45f57b | 2633 | gcc_assert (POINTER_TYPE_P (TREE_TYPE (arg))); |
6de9cd9a DN |
2634 | arg = build1 (NOP_EXPR, pchar_type_node, arg); |
2635 | type = gfc_typenode_for_spec (&expr->ts); | |
2636 | ||
38611275 | 2637 | se->expr = build_fold_indirect_ref (arg); |
6de9cd9a DN |
2638 | se->expr = convert (type, se->expr); |
2639 | } | |
2640 | ||
2641 | ||
2642 | /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */ | |
2643 | ||
2644 | static void | |
2645 | gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr) | |
2646 | { | |
2647 | tree arg; | |
2648 | tree tsource; | |
2649 | tree fsource; | |
2650 | tree mask; | |
2651 | tree type; | |
c3d0559d | 2652 | tree len; |
6de9cd9a DN |
2653 | |
2654 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
c3d0559d TS |
2655 | if (expr->ts.type != BT_CHARACTER) |
2656 | { | |
2657 | tsource = TREE_VALUE (arg); | |
2658 | arg = TREE_CHAIN (arg); | |
2659 | fsource = TREE_VALUE (arg); | |
2660 | mask = TREE_VALUE (TREE_CHAIN (arg)); | |
2661 | } | |
2662 | else | |
2663 | { | |
2664 | /* We do the same as in the non-character case, but the argument | |
2665 | list is different because of the string length arguments. We | |
2666 | also have to set the string length for the result. */ | |
2667 | len = TREE_VALUE (arg); | |
2668 | arg = TREE_CHAIN (arg); | |
2669 | tsource = TREE_VALUE (arg); | |
2670 | arg = TREE_CHAIN (TREE_CHAIN (arg)); | |
2671 | fsource = TREE_VALUE (arg); | |
2672 | mask = TREE_VALUE (TREE_CHAIN (arg)); | |
2673 | ||
2674 | se->string_length = len; | |
2675 | } | |
6de9cd9a | 2676 | type = TREE_TYPE (tsource); |
10c7a96f | 2677 | se->expr = fold_build3 (COND_EXPR, type, mask, tsource, fsource); |
6de9cd9a DN |
2678 | } |
2679 | ||
2680 | ||
2681 | static void | |
2682 | gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) | |
2683 | { | |
2684 | gfc_actual_arglist *actual; | |
2685 | tree args; | |
2686 | tree type; | |
2687 | tree fndecl; | |
2688 | gfc_se argse; | |
2689 | gfc_ss *ss; | |
2690 | ||
2691 | gfc_init_se (&argse, NULL); | |
2692 | actual = expr->value.function.actual; | |
2693 | ||
2694 | ss = gfc_walk_expr (actual->expr); | |
6e45f57b | 2695 | gcc_assert (ss != gfc_ss_terminator); |
6de9cd9a | 2696 | argse.want_pointer = 1; |
ad5dd90d | 2697 | argse.data_not_needed = 1; |
6de9cd9a DN |
2698 | gfc_conv_expr_descriptor (&argse, actual->expr, ss); |
2699 | gfc_add_block_to_block (&se->pre, &argse.pre); | |
2700 | gfc_add_block_to_block (&se->post, &argse.post); | |
2701 | args = gfc_chainon_list (NULL_TREE, argse.expr); | |
2702 | ||
2703 | actual = actual->next; | |
2704 | if (actual->expr) | |
2705 | { | |
2706 | gfc_init_se (&argse, NULL); | |
2707 | gfc_conv_expr_type (&argse, actual->expr, gfc_array_index_type); | |
2708 | gfc_add_block_to_block (&se->pre, &argse.pre); | |
2709 | args = gfc_chainon_list (args, argse.expr); | |
2710 | fndecl = gfor_fndecl_size1; | |
2711 | } | |
2712 | else | |
2713 | fndecl = gfor_fndecl_size0; | |
2714 | ||
3380b802 | 2715 | se->expr = build_function_call_expr (fndecl, args); |
6de9cd9a DN |
2716 | type = gfc_typenode_for_spec (&expr->ts); |
2717 | se->expr = convert (type, se->expr); | |
2718 | } | |
2719 | ||
2720 | ||
2721 | /* Intrinsic string comparison functions. */ | |
2722 | ||
2723 | static void | |
2724 | gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op) | |
2725 | { | |
2726 | tree type; | |
2727 | tree args; | |
0a821a92 | 2728 | tree arg2; |
6de9cd9a DN |
2729 | |
2730 | args = gfc_conv_intrinsic_function_args (se, expr); | |
0a821a92 FW |
2731 | arg2 = TREE_CHAIN (TREE_CHAIN (args)); |
2732 | ||
2733 | se->expr = gfc_build_compare_string (TREE_VALUE (args), | |
2734 | TREE_VALUE (TREE_CHAIN (args)), TREE_VALUE (arg2), | |
2735 | TREE_VALUE (TREE_CHAIN (arg2))); | |
6de9cd9a DN |
2736 | |
2737 | type = gfc_typenode_for_spec (&expr->ts); | |
0a821a92 | 2738 | se->expr = fold_build2 (op, type, se->expr, |
e805a599 | 2739 | build_int_cst (TREE_TYPE (se->expr), 0)); |
6de9cd9a DN |
2740 | } |
2741 | ||
2742 | /* Generate a call to the adjustl/adjustr library function. */ | |
2743 | static void | |
2744 | gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl) | |
2745 | { | |
2746 | tree args; | |
2747 | tree len; | |
2748 | tree type; | |
2749 | tree var; | |
2750 | tree tmp; | |
2751 | ||
2752 | args = gfc_conv_intrinsic_function_args (se, expr); | |
2753 | len = TREE_VALUE (args); | |
2754 | ||
2755 | type = TREE_TYPE (TREE_VALUE (TREE_CHAIN (args))); | |
2756 | var = gfc_conv_string_tmp (se, type, len); | |
2757 | args = tree_cons (NULL_TREE, var, args); | |
2758 | ||
3380b802 | 2759 | tmp = build_function_call_expr (fndecl, args); |
6de9cd9a DN |
2760 | gfc_add_expr_to_block (&se->pre, tmp); |
2761 | se->expr = var; | |
2762 | se->string_length = len; | |
2763 | } | |
2764 | ||
2765 | ||
014057c5 PT |
2766 | /* A helper function for gfc_conv_intrinsic_array_transfer to compute |
2767 | the size of tree expressions in bytes. */ | |
2768 | static tree | |
2769 | gfc_size_in_bytes (gfc_se *se, gfc_expr *e) | |
2770 | { | |
2771 | tree tmp; | |
2772 | ||
2773 | if (e->ts.type == BT_CHARACTER) | |
2774 | tmp = se->string_length; | |
2775 | else | |
2776 | { | |
2777 | if (e->rank) | |
2778 | { | |
2779 | tmp = gfc_get_element_type (TREE_TYPE (se->expr)); | |
2780 | tmp = size_in_bytes (tmp); | |
2781 | } | |
2782 | else | |
2783 | tmp = size_in_bytes (TREE_TYPE (TREE_TYPE (se->expr))); | |
2784 | } | |
2785 | ||
2786 | return fold_convert (gfc_array_index_type, tmp); | |
2787 | } | |
2788 | ||
2789 | ||
0c5a42a6 PT |
2790 | /* Array transfer statement. |
2791 | DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE]) | |
2792 | where: | |
2793 | typeof<DEST> = typeof<MOLD> | |
2794 | and: | |
2795 | N = min (sizeof (SOURCE(:)), sizeof (DEST(:)), | |
2796 | sizeof (DEST(0) * SIZE). */ | |
2797 | ||
2798 | static void | |
2799 | gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr) | |
2800 | { | |
2801 | tree tmp; | |
2802 | tree extent; | |
2803 | tree source; | |
2804 | tree source_bytes; | |
2805 | tree dest_word_len; | |
2806 | tree size_words; | |
2807 | tree size_bytes; | |
2808 | tree upper; | |
2809 | tree lower; | |
2810 | tree stride; | |
2811 | tree stmt; | |
014057c5 | 2812 | tree args; |
0c5a42a6 PT |
2813 | gfc_actual_arglist *arg; |
2814 | gfc_se argse; | |
2815 | gfc_ss *ss; | |
2816 | gfc_ss_info *info; | |
2817 | stmtblock_t block; | |
2818 | int n; | |
2819 | ||
2820 | gcc_assert (se->loop); | |
2821 | info = &se->ss->data.info; | |
2822 | ||
2823 | /* Convert SOURCE. The output from this stage is:- | |
2824 | source_bytes = length of the source in bytes | |
2825 | source = pointer to the source data. */ | |
2826 | arg = expr->value.function.actual; | |
2827 | gfc_init_se (&argse, NULL); | |
2828 | ss = gfc_walk_expr (arg->expr); | |
2829 | ||
2830 | source_bytes = gfc_create_var (gfc_array_index_type, NULL); | |
2831 | ||
2832 | /* Obtain the pointer to source and the length of source in bytes. */ | |
2833 | if (ss == gfc_ss_terminator) | |
2834 | { | |
2835 | gfc_conv_expr_reference (&argse, arg->expr); | |
2836 | source = argse.expr; | |
2837 | ||
2838 | /* Obtain the source word length. */ | |
014057c5 | 2839 | tmp = gfc_size_in_bytes (&argse, arg->expr); |
0c5a42a6 PT |
2840 | } |
2841 | else | |
2842 | { | |
2843 | gfc_init_se (&argse, NULL); | |
2844 | argse.want_pointer = 0; | |
2845 | gfc_conv_expr_descriptor (&argse, arg->expr, ss); | |
2846 | source = gfc_conv_descriptor_data_get (argse.expr); | |
2847 | ||
2848 | /* Repack the source if not a full variable array. */ | |
2849 | if (!(arg->expr->expr_type == EXPR_VARIABLE | |
2850 | && arg->expr->ref->u.ar.type == AR_FULL)) | |
2851 | { | |
2852 | tmp = build_fold_addr_expr (argse.expr); | |
2853 | tmp = gfc_chainon_list (NULL_TREE, tmp); | |
2854 | source = build_function_call_expr (gfor_fndecl_in_pack, tmp); | |
2855 | source = gfc_evaluate_now (source, &argse.pre); | |
2856 | ||
2857 | /* Free the temporary. */ | |
2858 | gfc_start_block (&block); | |
2859 | tmp = convert (pvoid_type_node, source); | |
2860 | tmp = gfc_chainon_list (NULL_TREE, tmp); | |
2861 | tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp); | |
2862 | gfc_add_expr_to_block (&block, tmp); | |
2863 | stmt = gfc_finish_block (&block); | |
2864 | ||
2865 | /* Clean up if it was repacked. */ | |
2866 | gfc_init_block (&block); | |
2867 | tmp = gfc_conv_array_data (argse.expr); | |
2868 | tmp = build2 (NE_EXPR, boolean_type_node, source, tmp); | |
2869 | tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ()); | |
2870 | gfc_add_expr_to_block (&block, tmp); | |
2871 | gfc_add_block_to_block (&block, &se->post); | |
2872 | gfc_init_block (&se->post); | |
2873 | gfc_add_block_to_block (&se->post, &block); | |
2874 | } | |
2875 | ||
2876 | /* Obtain the source word length. */ | |
014057c5 | 2877 | tmp = gfc_size_in_bytes (&argse, arg->expr); |
0c5a42a6 PT |
2878 | |
2879 | /* Obtain the size of the array in bytes. */ | |
2880 | extent = gfc_create_var (gfc_array_index_type, NULL); | |
2881 | for (n = 0; n < arg->expr->rank; n++) | |
2882 | { | |
2883 | tree idx; | |
2884 | idx = gfc_rank_cst[n]; | |
2885 | gfc_add_modify_expr (&argse.pre, source_bytes, tmp); | |
2886 | stride = gfc_conv_descriptor_stride (argse.expr, idx); | |
2887 | lower = gfc_conv_descriptor_lbound (argse.expr, idx); | |
2888 | upper = gfc_conv_descriptor_ubound (argse.expr, idx); | |
2889 | tmp = build2 (MINUS_EXPR, gfc_array_index_type, | |
2890 | upper, lower); | |
2891 | gfc_add_modify_expr (&argse.pre, extent, tmp); | |
2892 | tmp = build2 (PLUS_EXPR, gfc_array_index_type, | |
2893 | extent, gfc_index_one_node); | |
2894 | tmp = build2 (MULT_EXPR, gfc_array_index_type, | |
2895 | tmp, source_bytes); | |
2896 | } | |
2897 | } | |
2898 | ||
2899 | gfc_add_modify_expr (&argse.pre, source_bytes, tmp); | |
2900 | gfc_add_block_to_block (&se->pre, &argse.pre); | |
2901 | gfc_add_block_to_block (&se->post, &argse.post); | |
2902 | ||
2903 | /* Now convert MOLD. The sole output is: | |
2904 | dest_word_len = destination word length in bytes. */ | |
2905 | arg = arg->next; | |
2906 | ||
2907 | gfc_init_se (&argse, NULL); | |
2908 | ss = gfc_walk_expr (arg->expr); | |
2909 | ||
2910 | if (ss == gfc_ss_terminator) | |
2911 | { | |
2912 | gfc_conv_expr_reference (&argse, arg->expr); | |
014057c5 PT |
2913 | |
2914 | /* Obtain the source word length. */ | |
2915 | tmp = gfc_size_in_bytes (&argse, arg->expr); | |
0c5a42a6 PT |
2916 | } |
2917 | else | |
2918 | { | |
2919 | gfc_init_se (&argse, NULL); | |
2920 | argse.want_pointer = 0; | |
2921 | gfc_conv_expr_descriptor (&argse, arg->expr, ss); | |
014057c5 PT |
2922 | |
2923 | /* Obtain the source word length. */ | |
2924 | tmp = gfc_size_in_bytes (&argse, arg->expr); | |
0c5a42a6 PT |
2925 | } |
2926 | ||
2927 | dest_word_len = gfc_create_var (gfc_array_index_type, NULL); | |
2928 | gfc_add_modify_expr (&se->pre, dest_word_len, tmp); | |
2929 | ||
2930 | /* Finally convert SIZE, if it is present. */ | |
2931 | arg = arg->next; | |
2932 | size_words = gfc_create_var (gfc_array_index_type, NULL); | |
2933 | ||
2934 | if (arg->expr) | |
2935 | { | |
2936 | gfc_init_se (&argse, NULL); | |
2937 | gfc_conv_expr_reference (&argse, arg->expr); | |
2938 | tmp = convert (gfc_array_index_type, | |
2939 | build_fold_indirect_ref (argse.expr)); | |
2940 | gfc_add_block_to_block (&se->pre, &argse.pre); | |
2941 | gfc_add_block_to_block (&se->post, &argse.post); | |
2942 | } | |
2943 | else | |
2944 | tmp = NULL_TREE; | |
2945 | ||
2946 | size_bytes = gfc_create_var (gfc_array_index_type, NULL); | |
2947 | if (tmp != NULL_TREE) | |
2948 | { | |
2949 | tmp = build2 (MULT_EXPR, gfc_array_index_type, | |
2950 | tmp, dest_word_len); | |
2951 | tmp = build2 (MIN_EXPR, gfc_array_index_type, tmp, source_bytes); | |
2952 | } | |
2953 | else | |
2954 | tmp = source_bytes; | |
2955 | ||
2956 | gfc_add_modify_expr (&se->pre, size_bytes, tmp); | |
2957 | gfc_add_modify_expr (&se->pre, size_words, | |
2958 | build2 (CEIL_DIV_EXPR, gfc_array_index_type, | |
2959 | size_bytes, dest_word_len)); | |
2960 | ||
2961 | /* Evaluate the bounds of the result. If the loop range exists, we have | |
2962 | to check if it is too large. If so, we modify loop->to be consistent | |
2963 | with min(size, size(source)). Otherwise, size is made consistent with | |
2964 | the loop range, so that the right number of bytes is transferred.*/ | |
2965 | n = se->loop->order[0]; | |
2966 | if (se->loop->to[n] != NULL_TREE) | |
2967 | { | |
2968 | tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, | |
2969 | se->loop->to[n], se->loop->from[n]); | |
2970 | tmp = build2 (PLUS_EXPR, gfc_array_index_type, | |
2971 | tmp, gfc_index_one_node); | |
2972 | tmp = build2 (MIN_EXPR, gfc_array_index_type, | |
2973 | tmp, size_words); | |
2974 | gfc_add_modify_expr (&se->pre, size_words, tmp); | |
2975 | gfc_add_modify_expr (&se->pre, size_bytes, | |
2976 | build2 (MULT_EXPR, gfc_array_index_type, | |
2977 | size_words, dest_word_len)); | |
2978 | upper = build2 (PLUS_EXPR, gfc_array_index_type, | |
2979 | size_words, se->loop->from[n]); | |
2980 | upper = build2 (MINUS_EXPR, gfc_array_index_type, | |
2981 | upper, gfc_index_one_node); | |
2982 | } | |
2983 | else | |
2984 | { | |
2985 | upper = build2 (MINUS_EXPR, gfc_array_index_type, | |
2986 | size_words, gfc_index_one_node); | |
2987 | se->loop->from[n] = gfc_index_zero_node; | |
2988 | } | |
2989 | ||
2990 | se->loop->to[n] = upper; | |
2991 | ||
2992 | /* Build a destination descriptor, using the pointer, source, as the | |
999ffb1a FXC |
2993 | data field. This is already allocated so set callee_alloc. |
2994 | FIXME callee_alloc is not set! */ | |
2995 | ||
0c5a42a6 PT |
2996 | tmp = gfc_typenode_for_spec (&expr->ts); |
2997 | gfc_trans_create_temp_array (&se->pre, &se->post, se->loop, | |
999ffb1a | 2998 | info, tmp, false, true, false); |
0c5a42a6 | 2999 | |
014057c5 PT |
3000 | /* Use memcpy to do the transfer. */ |
3001 | tmp = gfc_conv_descriptor_data_get (info->descriptor); | |
3002 | args = gfc_chainon_list (NULL_TREE, tmp); | |
0c5a42a6 | 3003 | tmp = fold_convert (pvoid_type_node, source); |
014057c5 PT |
3004 | args = gfc_chainon_list (args, source); |
3005 | args = gfc_chainon_list (args, size_bytes); | |
3006 | tmp = built_in_decls[BUILT_IN_MEMCPY]; | |
3007 | tmp = build_function_call_expr (tmp, args); | |
3008 | gfc_add_expr_to_block (&se->pre, tmp); | |
3009 | ||
0c5a42a6 PT |
3010 | se->expr = info->descriptor; |
3011 | if (expr->ts.type == BT_CHARACTER) | |
3012 | se->string_length = dest_word_len; | |
3013 | } | |
3014 | ||
3015 | ||
6de9cd9a | 3016 | /* Scalar transfer statement. |
85d6cbd3 | 3017 | TRANSFER (source, mold) = memcpy(&tmpdecl, &source, size), tmpdecl. */ |
6de9cd9a DN |
3018 | |
3019 | static void | |
3020 | gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) | |
3021 | { | |
3022 | gfc_actual_arglist *arg; | |
3023 | gfc_se argse; | |
3024 | tree type; | |
3025 | tree ptr; | |
3026 | gfc_ss *ss; | |
85d6cbd3 | 3027 | tree tmpdecl, tmp, args; |
6de9cd9a | 3028 | |
6de9cd9a DN |
3029 | /* Get a pointer to the source. */ |
3030 | arg = expr->value.function.actual; | |
3031 | ss = gfc_walk_expr (arg->expr); | |
3032 | gfc_init_se (&argse, NULL); | |
3033 | if (ss == gfc_ss_terminator) | |
3034 | gfc_conv_expr_reference (&argse, arg->expr); | |
3035 | else | |
3036 | gfc_conv_array_parameter (&argse, arg->expr, ss, 1); | |
3037 | gfc_add_block_to_block (&se->pre, &argse.pre); | |
3038 | gfc_add_block_to_block (&se->post, &argse.post); | |
3039 | ptr = argse.expr; | |
3040 | ||
3041 | arg = arg->next; | |
3042 | type = gfc_typenode_for_spec (&expr->ts); | |
85d6cbd3 | 3043 | |
6de9cd9a DN |
3044 | if (expr->ts.type == BT_CHARACTER) |
3045 | { | |
0e697399 | 3046 | ptr = convert (build_pointer_type (type), ptr); |
6de9cd9a DN |
3047 | gfc_init_se (&argse, NULL); |
3048 | gfc_conv_expr (&argse, arg->expr); | |
3049 | gfc_add_block_to_block (&se->pre, &argse.pre); | |
3050 | gfc_add_block_to_block (&se->post, &argse.post); | |
3051 | se->expr = ptr; | |
3052 | se->string_length = argse.string_length; | |
3053 | } | |
3054 | else | |
3055 | { | |
85d6cbd3 AP |
3056 | tree moldsize; |
3057 | tmpdecl = gfc_create_var (type, "transfer"); | |
3058 | moldsize = size_in_bytes (type); | |
3059 | ||
3060 | /* Use memcpy to do the transfer. */ | |
3061 | tmp = build1 (ADDR_EXPR, build_pointer_type (type), tmpdecl); | |
3062 | tmp = fold_convert (pvoid_type_node, tmp); | |
3063 | args = gfc_chainon_list (NULL_TREE, tmp); | |
3064 | tmp = fold_convert (pvoid_type_node, ptr); | |
3065 | args = gfc_chainon_list (args, tmp); | |
3066 | args = gfc_chainon_list (args, moldsize); | |
3067 | tmp = built_in_decls[BUILT_IN_MEMCPY]; | |
3068 | tmp = build_function_call_expr (tmp, args); | |
3069 | gfc_add_expr_to_block (&se->pre, tmp); | |
3070 | ||
3071 | se->expr = tmpdecl; | |
6de9cd9a DN |
3072 | } |
3073 | } | |
3074 | ||
3075 | ||
3076 | /* Generate code for the ALLOCATED intrinsic. | |
3077 | Generate inline code that directly check the address of the argument. */ | |
3078 | ||
3079 | static void | |
3080 | gfc_conv_allocated (gfc_se *se, gfc_expr *expr) | |
3081 | { | |
3082 | gfc_actual_arglist *arg1; | |
3083 | gfc_se arg1se; | |
3084 | gfc_ss *ss1; | |
3085 | tree tmp; | |
3086 | ||
3087 | gfc_init_se (&arg1se, NULL); | |
3088 | arg1 = expr->value.function.actual; | |
3089 | ss1 = gfc_walk_expr (arg1->expr); | |
3090 | arg1se.descriptor_only = 1; | |
3091 | gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1); | |
3092 | ||
4c73896d | 3093 | tmp = gfc_conv_descriptor_data_get (arg1se.expr); |
923ab88c TS |
3094 | tmp = build2 (NE_EXPR, boolean_type_node, tmp, |
3095 | fold_convert (TREE_TYPE (tmp), null_pointer_node)); | |
6de9cd9a DN |
3096 | se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp); |
3097 | } | |
3098 | ||
3099 | ||
3100 | /* Generate code for the ASSOCIATED intrinsic. | |
3101 | If both POINTER and TARGET are arrays, generate a call to library function | |
3102 | _gfor_associated, and pass descriptors of POINTER and TARGET to it. | |
3103 | In other cases, generate inline code that directly compare the address of | |
3104 | POINTER with the address of TARGET. */ | |
3105 | ||
3106 | static void | |
3107 | gfc_conv_associated (gfc_se *se, gfc_expr *expr) | |
3108 | { | |
3109 | gfc_actual_arglist *arg1; | |
3110 | gfc_actual_arglist *arg2; | |
3111 | gfc_se arg1se; | |
3112 | gfc_se arg2se; | |
3113 | tree tmp2; | |
3114 | tree tmp; | |
3115 | tree args, fndecl; | |
f5b854f2 PT |
3116 | tree nonzero_charlen; |
3117 | tree nonzero_arraylen; | |
6de9cd9a DN |
3118 | gfc_ss *ss1, *ss2; |
3119 | ||
3120 | gfc_init_se (&arg1se, NULL); | |
3121 | gfc_init_se (&arg2se, NULL); | |
3122 | arg1 = expr->value.function.actual; | |
3123 | arg2 = arg1->next; | |
3124 | ss1 = gfc_walk_expr (arg1->expr); | |
3125 | ||
3126 | if (!arg2->expr) | |
3127 | { | |
3128 | /* No optional target. */ | |
3129 | if (ss1 == gfc_ss_terminator) | |
3130 | { | |
3131 | /* A pointer to a scalar. */ | |
3132 | arg1se.want_pointer = 1; | |
3133 | gfc_conv_expr (&arg1se, arg1->expr); | |
3134 | tmp2 = arg1se.expr; | |
3135 | } | |
3136 | else | |
3137 | { | |
3138 | /* A pointer to an array. */ | |
dd5797cc | 3139 | gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1); |
4c73896d | 3140 | tmp2 = gfc_conv_descriptor_data_get (arg1se.expr); |
6de9cd9a | 3141 | } |
98efaf34 FXC |
3142 | gfc_add_block_to_block (&se->pre, &arg1se.pre); |
3143 | gfc_add_block_to_block (&se->post, &arg1se.post); | |
923ab88c TS |
3144 | tmp = build2 (NE_EXPR, boolean_type_node, tmp2, |
3145 | fold_convert (TREE_TYPE (tmp2), null_pointer_node)); | |
6de9cd9a DN |
3146 | se->expr = tmp; |
3147 | } | |
3148 | else | |
3149 | { | |
3150 | /* An optional target. */ | |
3151 | ss2 = gfc_walk_expr (arg2->expr); | |
699fa7aa PT |
3152 | |
3153 | nonzero_charlen = NULL_TREE; | |
3154 | if (arg1->expr->ts.type == BT_CHARACTER) | |
3155 | nonzero_charlen = build2 (NE_EXPR, boolean_type_node, | |
3156 | arg1->expr->ts.cl->backend_decl, | |
3157 | integer_zero_node); | |
3158 | ||
6de9cd9a DN |
3159 | if (ss1 == gfc_ss_terminator) |
3160 | { | |
3161 | /* A pointer to a scalar. */ | |
6e45f57b | 3162 | gcc_assert (ss2 == gfc_ss_terminator); |
6de9cd9a DN |
3163 | arg1se.want_pointer = 1; |
3164 | gfc_conv_expr (&arg1se, arg1->expr); | |
3165 | arg2se.want_pointer = 1; | |
3166 | gfc_conv_expr (&arg2se, arg2->expr); | |
98efaf34 FXC |
3167 | gfc_add_block_to_block (&se->pre, &arg1se.pre); |
3168 | gfc_add_block_to_block (&se->post, &arg1se.post); | |
923ab88c | 3169 | tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr); |
23572654 TB |
3170 | tmp2 = build2 (NE_EXPR, boolean_type_node, arg1se.expr, |
3171 | null_pointer_node); | |
3172 | se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node, tmp, tmp2); | |
6de9cd9a DN |
3173 | } |
3174 | else | |
3175 | { | |
699fa7aa PT |
3176 | |
3177 | /* An array pointer of zero length is not associated if target is | |
3178 | present. */ | |
3179 | arg1se.descriptor_only = 1; | |
3180 | gfc_conv_expr_lhs (&arg1se, arg1->expr); | |
3181 | tmp = gfc_conv_descriptor_stride (arg1se.expr, | |
3182 | gfc_rank_cst[arg1->expr->rank - 1]); | |
3183 | nonzero_arraylen = build2 (NE_EXPR, boolean_type_node, | |
3184 | tmp, integer_zero_node); | |
3185 | ||
6de9cd9a | 3186 | /* A pointer to an array, call library function _gfor_associated. */ |
6e45f57b | 3187 | gcc_assert (ss2 != gfc_ss_terminator); |
6de9cd9a DN |
3188 | args = NULL_TREE; |
3189 | arg1se.want_pointer = 1; | |
3190 | gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1); | |
3191 | args = gfc_chainon_list (args, arg1se.expr); | |
699fa7aa | 3192 | |
6de9cd9a DN |
3193 | arg2se.want_pointer = 1; |
3194 | gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2); | |
3195 | gfc_add_block_to_block (&se->pre, &arg2se.pre); | |
3196 | gfc_add_block_to_block (&se->post, &arg2se.post); | |
3197 | args = gfc_chainon_list (args, arg2se.expr); | |
3198 | fndecl = gfor_fndecl_associated; | |
3380b802 | 3199 | se->expr = build_function_call_expr (fndecl, args); |
699fa7aa PT |
3200 | se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node, |
3201 | se->expr, nonzero_arraylen); | |
3202 | ||
6de9cd9a | 3203 | } |
699fa7aa PT |
3204 | |
3205 | /* If target is present zero character length pointers cannot | |
3206 | be associated. */ | |
3207 | if (nonzero_charlen != NULL_TREE) | |
3208 | se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node, | |
3209 | se->expr, nonzero_charlen); | |
3210 | } | |
3211 | ||
6de9cd9a DN |
3212 | se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr); |
3213 | } | |
3214 | ||
3215 | ||
f7b529fa | 3216 | /* Scan a string for any one of the characters in a set of characters. */ |
6de9cd9a DN |
3217 | |
3218 | static void | |
3219 | gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr) | |
3220 | { | |
0da87370 | 3221 | tree logical4_type_node = gfc_get_logical_type (4); |
6de9cd9a DN |
3222 | tree args; |
3223 | tree back; | |
3224 | tree type; | |
3225 | tree tmp; | |
3226 | ||
3227 | args = gfc_conv_intrinsic_function_args (se, expr); | |
3228 | type = gfc_typenode_for_spec (&expr->ts); | |
3229 | tmp = gfc_advance_chain (args, 3); | |
3230 | if (TREE_CHAIN (tmp) == NULL_TREE) | |
3231 | { | |
0da87370 TS |
3232 | back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0), |
3233 | NULL_TREE); | |
6de9cd9a DN |
3234 | TREE_CHAIN (tmp) = back; |
3235 | } | |
3236 | else | |
3237 | { | |
3238 | back = TREE_CHAIN (tmp); | |
0da87370 | 3239 | TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back)); |
6de9cd9a DN |
3240 | } |
3241 | ||
3380b802 | 3242 | se->expr = build_function_call_expr (gfor_fndecl_string_scan, args); |
6de9cd9a DN |
3243 | se->expr = convert (type, se->expr); |
3244 | } | |
3245 | ||
3246 | ||
3247 | /* Verify that a set of characters contains all the characters in a string | |
1f2959f0 | 3248 | by identifying the position of the first character in a string of |
6de9cd9a DN |
3249 | characters that does not appear in a given set of characters. */ |
3250 | ||
3251 | static void | |
3252 | gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr) | |
3253 | { | |
0da87370 | 3254 | tree logical4_type_node = gfc_get_logical_type (4); |
6de9cd9a DN |
3255 | tree args; |
3256 | tree back; | |
3257 | tree type; | |
3258 | tree tmp; | |
3259 | ||
3260 | args = gfc_conv_intrinsic_function_args (se, expr); | |
3261 | type = gfc_typenode_for_spec (&expr->ts); | |
3262 | tmp = gfc_advance_chain (args, 3); | |
3263 | if (TREE_CHAIN (tmp) == NULL_TREE) | |
3264 | { | |
0da87370 TS |
3265 | back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0), |
3266 | NULL_TREE); | |
6de9cd9a DN |
3267 | TREE_CHAIN (tmp) = back; |
3268 | } | |
3269 | else | |
3270 | { | |
3271 | back = TREE_CHAIN (tmp); | |
0da87370 | 3272 | TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back)); |
6de9cd9a DN |
3273 | } |
3274 | ||
3380b802 | 3275 | se->expr = build_function_call_expr (gfor_fndecl_string_verify, args); |
6de9cd9a DN |
3276 | se->expr = convert (type, se->expr); |
3277 | } | |
3278 | ||
6de9cd9a DN |
3279 | |
3280 | /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */ | |
3281 | ||
3282 | static void | |
3283 | gfc_conv_intrinsic_si_kind (gfc_se * se, gfc_expr * expr) | |
3284 | { | |
3285 | tree args; | |
3286 | ||
3287 | args = gfc_conv_intrinsic_function_args (se, expr); | |
3288 | args = TREE_VALUE (args); | |
488ce07b | 3289 | args = build_fold_addr_expr (args); |
6de9cd9a | 3290 | args = tree_cons (NULL_TREE, args, NULL_TREE); |
3380b802 | 3291 | se->expr = build_function_call_expr (gfor_fndecl_si_kind, args); |
6de9cd9a DN |
3292 | } |
3293 | ||
3294 | /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */ | |
3295 | ||
3296 | static void | |
3297 | gfc_conv_intrinsic_sr_kind (gfc_se * se, gfc_expr * expr) | |
3298 | { | |
3299 | gfc_actual_arglist *actual; | |
3300 | tree args; | |
3301 | gfc_se argse; | |
3302 | ||
3303 | args = NULL_TREE; | |
3304 | for (actual = expr->value.function.actual; actual; actual = actual->next) | |
3305 | { | |
3306 | gfc_init_se (&argse, se); | |
3307 | ||
3308 | /* Pass a NULL pointer for an absent arg. */ | |
3309 | if (actual->expr == NULL) | |
3310 | argse.expr = null_pointer_node; | |
3311 | else | |
3312 | gfc_conv_expr_reference (&argse, actual->expr); | |
3313 | ||
3314 | gfc_add_block_to_block (&se->pre, &argse.pre); | |
3315 | gfc_add_block_to_block (&se->post, &argse.post); | |
3316 | args = gfc_chainon_list (args, argse.expr); | |
3317 | } | |
3380b802 | 3318 | se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args); |
6de9cd9a DN |
3319 | } |
3320 | ||
3321 | ||
3322 | /* Generate code for TRIM (A) intrinsic function. */ | |
3323 | ||
3324 | static void | |
3325 | gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr) | |
3326 | { | |
e2cad04b | 3327 | tree gfc_int4_type_node = gfc_get_int_type (4); |
6de9cd9a DN |
3328 | tree var; |
3329 | tree len; | |
3330 | tree addr; | |
3331 | tree tmp; | |
3332 | tree arglist; | |
3333 | tree type; | |
3334 | tree cond; | |
3335 | ||
3336 | arglist = NULL_TREE; | |
3337 | ||
3338 | type = build_pointer_type (gfc_character1_type_node); | |
3339 | var = gfc_create_var (type, "pstr"); | |
3340 | addr = gfc_build_addr_expr (ppvoid_type_node, var); | |
3341 | len = gfc_create_var (gfc_int4_type_node, "len"); | |
3342 | ||
3343 | tmp = gfc_conv_intrinsic_function_args (se, expr); | |
488ce07b | 3344 | arglist = gfc_chainon_list (arglist, build_fold_addr_expr (len)); |
6de9cd9a DN |
3345 | arglist = gfc_chainon_list (arglist, addr); |
3346 | arglist = chainon (arglist, tmp); | |
b36cd00b | 3347 | |
3380b802 | 3348 | tmp = build_function_call_expr (gfor_fndecl_string_trim, arglist); |
6de9cd9a DN |
3349 | gfc_add_expr_to_block (&se->pre, tmp); |
3350 | ||
3351 | /* Free the temporary afterwards, if necessary. */ | |
923ab88c | 3352 | cond = build2 (GT_EXPR, boolean_type_node, len, |
e805a599 | 3353 | build_int_cst (TREE_TYPE (len), 0)); |
6de9cd9a | 3354 | arglist = gfc_chainon_list (NULL_TREE, var); |
3380b802 | 3355 | tmp = build_function_call_expr (gfor_fndecl_internal_free, arglist); |
923ab88c | 3356 | tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ()); |
6de9cd9a DN |
3357 | gfc_add_expr_to_block (&se->post, tmp); |
3358 | ||
3359 | se->expr = var; | |
3360 | se->string_length = len; | |
3361 | } | |
3362 | ||
3363 | ||
3364 | /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */ | |
3365 | ||
3366 | static void | |
3367 | gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) | |
3368 | { | |
e2cad04b | 3369 | tree gfc_int4_type_node = gfc_get_int_type (4); |
6de9cd9a DN |
3370 | tree tmp; |
3371 | tree len; | |
3372 | tree args; | |
3373 | tree arglist; | |
3374 | tree ncopies; | |
3375 | tree var; | |
3376 | tree type; | |
a14fb6fa | 3377 | tree cond; |
6de9cd9a DN |
3378 | |
3379 | args = gfc_conv_intrinsic_function_args (se, expr); | |
3380 | len = TREE_VALUE (args); | |
3381 | tmp = gfc_advance_chain (args, 2); | |
3382 | ncopies = TREE_VALUE (tmp); | |
a14fb6fa FXC |
3383 | |
3384 | /* Check that ncopies is not negative. */ | |
3385 | ncopies = gfc_evaluate_now (ncopies, &se->pre); | |
3386 | cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies, | |
3387 | build_int_cst (TREE_TYPE (ncopies), 0)); | |
3388 | gfc_trans_runtime_check (cond, | |
3389 | "Argument NCOPIES of REPEAT intrinsic is negative", | |
3390 | &se->pre, &expr->where); | |
3391 | ||
3392 | /* Compute the destination length. */ | |
10c7a96f | 3393 | len = fold_build2 (MULT_EXPR, gfc_int4_type_node, len, ncopies); |
6de9cd9a DN |
3394 | type = gfc_get_character_type (expr->ts.kind, expr->ts.cl); |
3395 | var = gfc_conv_string_tmp (se, build_pointer_type (type), len); | |
3396 | ||
a14fb6fa | 3397 | /* Create the argument list and generate the function call. */ |
6de9cd9a DN |
3398 | arglist = NULL_TREE; |
3399 | arglist = gfc_chainon_list (arglist, var); | |
a14fb6fa FXC |
3400 | arglist = gfc_chainon_list (arglist, TREE_VALUE (args)); |
3401 | arglist = gfc_chainon_list (arglist, TREE_VALUE (TREE_CHAIN (args))); | |
3402 | arglist = gfc_chainon_list (arglist, ncopies); | |
3380b802 | 3403 | tmp = build_function_call_expr (gfor_fndecl_string_repeat, arglist); |
6de9cd9a DN |
3404 | gfc_add_expr_to_block (&se->pre, tmp); |
3405 | ||
3406 | se->expr = var; | |
3407 | se->string_length = len; | |
3408 | } | |
3409 | ||
3410 | ||
d436d3de | 3411 | /* Generate code for the IARGC intrinsic. */ |
b41b2534 JB |
3412 | |
3413 | static void | |
d436d3de | 3414 | gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr) |
b41b2534 JB |
3415 | { |
3416 | tree tmp; | |
3417 | tree fndecl; | |
3418 | tree type; | |
3419 | ||
3420 | /* Call the library function. This always returns an INTEGER(4). */ | |
3421 | fndecl = gfor_fndecl_iargc; | |
3380b802 | 3422 | tmp = build_function_call_expr (fndecl, NULL_TREE); |
b41b2534 JB |
3423 | |
3424 | /* Convert it to the required type. */ | |
3425 | type = gfc_typenode_for_spec (&expr->ts); | |
3426 | tmp = fold_convert (type, tmp); | |
3427 | ||
b41b2534 JB |
3428 | se->expr = tmp; |
3429 | } | |
3430 | ||
83d890b9 AL |
3431 | |
3432 | /* The loc intrinsic returns the address of its argument as | |
3433 | gfc_index_integer_kind integer. */ | |
3434 | ||
3435 | static void | |
0f8bc3e1 | 3436 | gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr) |
83d890b9 AL |
3437 | { |
3438 | tree temp_var; | |
3439 | gfc_expr *arg_expr; | |
3440 | gfc_ss *ss; | |
3441 | ||
3442 | gcc_assert (!se->ss); | |
3443 | ||
3444 | arg_expr = expr->value.function.actual->expr; | |
3445 | ss = gfc_walk_expr (arg_expr); | |
3446 | if (ss == gfc_ss_terminator) | |
3447 | gfc_conv_expr_reference (se, arg_expr); | |
3448 | else | |
3449 | gfc_conv_array_parameter (se, arg_expr, ss, 1); | |
0f8bc3e1 | 3450 | se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr); |
83d890b9 AL |
3451 | |
3452 | /* Create a temporary variable for loc return value. Without this, | |
3453 | we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */ | |
0f8bc3e1 | 3454 | temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL); |
83d890b9 AL |
3455 | gfc_add_modify_expr (&se->pre, temp_var, se->expr); |
3456 | se->expr = temp_var; | |
3457 | } | |
3458 | ||
6de9cd9a DN |
3459 | /* Generate code for an intrinsic function. Some map directly to library |
3460 | calls, others get special handling. In some cases the name of the function | |
3461 | used depends on the type specifiers. */ | |
3462 | ||
3463 | void | |
3464 | gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) | |
3465 | { | |
3466 | gfc_intrinsic_sym *isym; | |
6b25a558 | 3467 | const char *name; |
6de9cd9a DN |
3468 | int lib; |
3469 | ||
3470 | isym = expr->value.function.isym; | |
3471 | ||
3472 | name = &expr->value.function.name[2]; | |
3473 | ||
1524f80b | 3474 | if (expr->rank > 0 && !expr->inline_noncopying_intrinsic) |
6de9cd9a DN |
3475 | { |
3476 | lib = gfc_is_intrinsic_libcall (expr); | |
3477 | if (lib != 0) | |
3478 | { | |
3479 | if (lib == 1) | |
3480 | se->ignore_optional = 1; | |
3481 | gfc_conv_intrinsic_funcall (se, expr); | |
3482 | return; | |
3483 | } | |
3484 | } | |
3485 | ||
3486 | switch (expr->value.function.isym->generic_id) | |
3487 | { | |
3488 | case GFC_ISYM_NONE: | |
6e45f57b | 3489 | gcc_unreachable (); |
6de9cd9a DN |
3490 | |
3491 | case GFC_ISYM_REPEAT: | |
3492 | gfc_conv_intrinsic_repeat (se, expr); | |
3493 | break; | |
3494 | ||
3495 | case GFC_ISYM_TRIM: | |
3496 | gfc_conv_intrinsic_trim (se, expr); | |
3497 | break; | |
3498 | ||
3499 | case GFC_ISYM_SI_KIND: | |
3500 | gfc_conv_intrinsic_si_kind (se, expr); | |
3501 | break; | |
3502 | ||
3503 | case GFC_ISYM_SR_KIND: | |
3504 | gfc_conv_intrinsic_sr_kind (se, expr); | |
3505 | break; | |
3506 | ||
3507 | case GFC_ISYM_EXPONENT: | |
3508 | gfc_conv_intrinsic_exponent (se, expr); | |
3509 | break; | |
3510 | ||
6de9cd9a DN |
3511 | case GFC_ISYM_SCAN: |
3512 | gfc_conv_intrinsic_scan (se, expr); | |
3513 | break; | |
3514 | ||
3515 | case GFC_ISYM_VERIFY: | |
3516 | gfc_conv_intrinsic_verify (se, expr); | |
3517 | break; | |
3518 | ||
3519 | case GFC_ISYM_ALLOCATED: | |
3520 | gfc_conv_allocated (se, expr); | |
3521 | break; | |
3522 | ||
3523 | case GFC_ISYM_ASSOCIATED: | |
3524 | gfc_conv_associated(se, expr); | |
3525 | break; | |
3526 | ||
3527 | case GFC_ISYM_ABS: | |
3528 | gfc_conv_intrinsic_abs (se, expr); | |
3529 | break; | |
3530 | ||
3531 | case GFC_ISYM_ADJUSTL: | |
3532 | gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl); | |
3533 | break; | |
3534 | ||
3535 | case GFC_ISYM_ADJUSTR: | |
3536 | gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr); | |
3537 | break; | |
3538 | ||
3539 | case GFC_ISYM_AIMAG: | |
3540 | gfc_conv_intrinsic_imagpart (se, expr); | |
3541 | break; | |
3542 | ||
3543 | case GFC_ISYM_AINT: | |
f9f770a8 | 3544 | gfc_conv_intrinsic_aint (se, expr, RND_TRUNC); |
6de9cd9a DN |
3545 | break; |
3546 | ||
3547 | case GFC_ISYM_ALL: | |
3548 | gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR); | |
3549 | break; | |
3550 | ||
3551 | case GFC_ISYM_ANINT: | |
f9f770a8 | 3552 | gfc_conv_intrinsic_aint (se, expr, RND_ROUND); |
6de9cd9a DN |
3553 | break; |
3554 | ||
5d723e54 FXC |
3555 | case GFC_ISYM_AND: |
3556 | gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR); | |
3557 | break; | |
3558 | ||
6de9cd9a DN |
3559 | case GFC_ISYM_ANY: |
3560 | gfc_conv_intrinsic_anyall (se, expr, NE_EXPR); | |
3561 | break; | |
3562 | ||
3563 | case GFC_ISYM_BTEST: | |
3564 | gfc_conv_intrinsic_btest (se, expr); | |
3565 | break; | |
3566 | ||
3567 | case GFC_ISYM_ACHAR: | |
3568 | case GFC_ISYM_CHAR: | |
3569 | gfc_conv_intrinsic_char (se, expr); | |
3570 | break; | |
3571 | ||
3572 | case GFC_ISYM_CONVERSION: | |
3573 | case GFC_ISYM_REAL: | |
3574 | case GFC_ISYM_LOGICAL: | |
3575 | case GFC_ISYM_DBLE: | |
3576 | gfc_conv_intrinsic_conversion (se, expr); | |
3577 | break; | |
3578 | ||
e7dc5b4f | 3579 | /* Integer conversions are handled separately to make sure we get the |
6de9cd9a DN |
3580 | correct rounding mode. */ |
3581 | case GFC_ISYM_INT: | |
bf3fb7e4 FXC |
3582 | case GFC_ISYM_INT2: |
3583 | case GFC_ISYM_INT8: | |
3584 | case GFC_ISYM_LONG: | |
f9f770a8 | 3585 | gfc_conv_intrinsic_int (se, expr, RND_TRUNC); |
6de9cd9a DN |
3586 | break; |
3587 | ||
3588 | case GFC_ISYM_NINT: | |
f9f770a8 | 3589 | gfc_conv_intrinsic_int (se, expr, RND_ROUND); |
6de9cd9a DN |
3590 | break; |
3591 | ||
3592 | case GFC_ISYM_CEILING: | |
f9f770a8 | 3593 | gfc_conv_intrinsic_int (se, expr, RND_CEIL); |
6de9cd9a DN |
3594 | break; |
3595 | ||
3596 | case GFC_ISYM_FLOOR: | |
f9f770a8 | 3597 | gfc_conv_intrinsic_int (se, expr, RND_FLOOR); |
6de9cd9a DN |
3598 | break; |
3599 | ||
3600 | case GFC_ISYM_MOD: | |
3601 | gfc_conv_intrinsic_mod (se, expr, 0); | |
3602 | break; | |
3603 | ||
3604 | case GFC_ISYM_MODULO: | |
3605 | gfc_conv_intrinsic_mod (se, expr, 1); | |
3606 | break; | |
3607 | ||
3608 | case GFC_ISYM_CMPLX: | |
3609 | gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1'); | |
3610 | break; | |
3611 | ||
b41b2534 | 3612 | case GFC_ISYM_COMMAND_ARGUMENT_COUNT: |
d436d3de | 3613 | gfc_conv_intrinsic_iargc (se, expr); |
b41b2534 JB |
3614 | break; |
3615 | ||
5d723e54 FXC |
3616 | case GFC_ISYM_COMPLEX: |
3617 | gfc_conv_intrinsic_cmplx (se, expr, 1); | |
3618 | break; | |
3619 | ||
6de9cd9a DN |
3620 | case GFC_ISYM_CONJG: |
3621 | gfc_conv_intrinsic_conjg (se, expr); | |
3622 | break; | |
3623 | ||
3624 | case GFC_ISYM_COUNT: | |
3625 | gfc_conv_intrinsic_count (se, expr); | |
3626 | break; | |
3627 | ||
35059811 FXC |
3628 | case GFC_ISYM_CTIME: |
3629 | gfc_conv_intrinsic_ctime (se, expr); | |
3630 | break; | |
3631 | ||
6de9cd9a DN |
3632 | case GFC_ISYM_DIM: |
3633 | gfc_conv_intrinsic_dim (se, expr); | |
3634 | break; | |
3635 | ||
61321991 PT |
3636 | case GFC_ISYM_DOT_PRODUCT: |
3637 | gfc_conv_intrinsic_dot_product (se, expr); | |
3638 | break; | |
3639 | ||
6de9cd9a DN |
3640 | case GFC_ISYM_DPROD: |
3641 | gfc_conv_intrinsic_dprod (se, expr); | |
3642 | break; | |
3643 | ||
35059811 FXC |
3644 | case GFC_ISYM_FDATE: |
3645 | gfc_conv_intrinsic_fdate (se, expr); | |
3646 | break; | |
3647 | ||
6de9cd9a DN |
3648 | case GFC_ISYM_IAND: |
3649 | gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR); | |
3650 | break; | |
3651 | ||
3652 | case GFC_ISYM_IBCLR: | |
3653 | gfc_conv_intrinsic_singlebitop (se, expr, 0); | |
3654 | break; | |
3655 | ||
3656 | case GFC_ISYM_IBITS: | |
3657 | gfc_conv_intrinsic_ibits (se, expr); | |
3658 | break; | |
3659 | ||
3660 | case GFC_ISYM_IBSET: | |
3661 | gfc_conv_intrinsic_singlebitop (se, expr, 1); | |
3662 | break; | |
3663 | ||
3664 | case GFC_ISYM_IACHAR: | |
3665 | case GFC_ISYM_ICHAR: | |
3666 | /* We assume ASCII character sequence. */ | |
3667 | gfc_conv_intrinsic_ichar (se, expr); | |
3668 | break; | |
3669 | ||
b41b2534 | 3670 | case GFC_ISYM_IARGC: |
d436d3de | 3671 | gfc_conv_intrinsic_iargc (se, expr); |
b41b2534 JB |
3672 | break; |
3673 | ||
6de9cd9a DN |
3674 | case GFC_ISYM_IEOR: |
3675 | gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR); | |
3676 | break; | |
3677 | ||
3678 | case GFC_ISYM_INDEX: | |
3679 | gfc_conv_intrinsic_index (se, expr); | |
3680 | break; | |
3681 | ||
3682 | case GFC_ISYM_IOR: | |
3683 | gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR); | |
3684 | break; | |
3685 | ||
a119fc1c FXC |
3686 | case GFC_ISYM_LSHIFT: |
3687 | gfc_conv_intrinsic_rlshift (se, expr, 0); | |
3688 | break; | |
3689 | ||
3690 | case GFC_ISYM_RSHIFT: | |
3691 | gfc_conv_intrinsic_rlshift (se, expr, 1); | |
3692 | break; | |
3693 | ||
6de9cd9a DN |
3694 | case GFC_ISYM_ISHFT: |
3695 | gfc_conv_intrinsic_ishft (se, expr); | |
3696 | break; | |
3697 | ||
3698 | case GFC_ISYM_ISHFTC: | |
3699 | gfc_conv_intrinsic_ishftc (se, expr); | |
3700 | break; | |
3701 | ||
3702 | case GFC_ISYM_LBOUND: | |
3703 | gfc_conv_intrinsic_bound (se, expr, 0); | |
3704 | break; | |
3705 | ||
1524f80b RS |
3706 | case GFC_ISYM_TRANSPOSE: |
3707 | if (se->ss && se->ss->useflags) | |
3708 | { | |
3709 | gfc_conv_tmp_array_ref (se); | |
3710 | gfc_advance_se_ss_chain (se); | |
3711 | } | |
3712 | else | |
3713 | gfc_conv_array_transpose (se, expr->value.function.actual->expr); | |
3714 | break; | |
3715 | ||
6de9cd9a DN |
3716 | case GFC_ISYM_LEN: |
3717 | gfc_conv_intrinsic_len (se, expr); | |
3718 | break; | |
3719 | ||
3720 | case GFC_ISYM_LEN_TRIM: | |
3721 | gfc_conv_intrinsic_len_trim (se, expr); | |
3722 | break; | |
3723 | ||
3724 | case GFC_ISYM_LGE: | |
3725 | gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR); | |
3726 | break; | |
3727 | ||
3728 | case GFC_ISYM_LGT: | |
3729 | gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR); | |
3730 | break; | |
3731 | ||
3732 | case GFC_ISYM_LLE: | |
3733 | gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR); | |
3734 | break; | |
3735 | ||
3736 | case GFC_ISYM_LLT: | |
3737 | gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR); | |
3738 | break; | |
3739 | ||
3740 | case GFC_ISYM_MAX: | |
3741 | gfc_conv_intrinsic_minmax (se, expr, GT_EXPR); | |
3742 | break; | |
3743 | ||
3744 | case GFC_ISYM_MAXLOC: | |
3745 | gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR); | |
3746 | break; | |
3747 | ||
3748 | case GFC_ISYM_MAXVAL: | |
3749 | gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR); | |
3750 | break; | |
3751 | ||
3752 | case GFC_ISYM_MERGE: | |
3753 | gfc_conv_intrinsic_merge (se, expr); | |
3754 | break; | |
3755 | ||
3756 | case GFC_ISYM_MIN: | |
3757 | gfc_conv_intrinsic_minmax (se, expr, LT_EXPR); | |
3758 | break; | |
3759 | ||
3760 | case GFC_ISYM_MINLOC: | |
3761 | gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR); | |
3762 | break; | |
3763 | ||
3764 | case GFC_ISYM_MINVAL: | |
3765 | gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR); | |
3766 | break; | |
3767 | ||
3768 | case GFC_ISYM_NOT: | |
3769 | gfc_conv_intrinsic_not (se, expr); | |
3770 | break; | |
3771 | ||
5d723e54 FXC |
3772 | case GFC_ISYM_OR: |
3773 | gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR); | |
3774 | break; | |
3775 | ||
6de9cd9a DN |
3776 | case GFC_ISYM_PRESENT: |
3777 | gfc_conv_intrinsic_present (se, expr); | |
3778 | break; | |
3779 | ||
3780 | case GFC_ISYM_PRODUCT: | |
3781 | gfc_conv_intrinsic_arith (se, expr, MULT_EXPR); | |
3782 | break; | |
3783 | ||
3784 | case GFC_ISYM_SIGN: | |
3785 | gfc_conv_intrinsic_sign (se, expr); | |
3786 | break; | |
3787 | ||
3788 | case GFC_ISYM_SIZE: | |
3789 | gfc_conv_intrinsic_size (se, expr); | |
3790 | break; | |
3791 | ||
3792 | case GFC_ISYM_SUM: | |
3793 | gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR); | |
3794 | break; | |
3795 | ||
3796 | case GFC_ISYM_TRANSFER: | |
0c5a42a6 PT |
3797 | if (se->ss) |
3798 | { | |
3799 | if (se->ss->useflags) | |
3800 | { | |
3801 | /* Access the previously obtained result. */ | |
3802 | gfc_conv_tmp_array_ref (se); | |
3803 | gfc_advance_se_ss_chain (se); | |
3804 | break; | |
3805 | } | |
3806 | else | |
3807 | gfc_conv_intrinsic_array_transfer (se, expr); | |
3808 | } | |
3809 | else | |
3810 | gfc_conv_intrinsic_transfer (se, expr); | |
25fc05eb FXC |
3811 | break; |
3812 | ||
3813 | case GFC_ISYM_TTYNAM: | |
3814 | gfc_conv_intrinsic_ttynam (se, expr); | |
6de9cd9a DN |
3815 | break; |
3816 | ||
3817 | case GFC_ISYM_UBOUND: | |
3818 | gfc_conv_intrinsic_bound (se, expr, 1); | |
3819 | break; | |
3820 | ||
5d723e54 FXC |
3821 | case GFC_ISYM_XOR: |
3822 | gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR); | |
3823 | break; | |
3824 | ||
83d890b9 AL |
3825 | case GFC_ISYM_LOC: |
3826 | gfc_conv_intrinsic_loc (se, expr); | |
3827 | break; | |
3828 | ||
a119fc1c | 3829 | case GFC_ISYM_ACCESS: |
f77b6ca3 | 3830 | case GFC_ISYM_CHDIR: |
a119fc1c | 3831 | case GFC_ISYM_CHMOD: |
2bd74949 | 3832 | case GFC_ISYM_ETIME: |
5d723e54 FXC |
3833 | case GFC_ISYM_FGET: |
3834 | case GFC_ISYM_FGETC: | |
df65f093 | 3835 | case GFC_ISYM_FNUM: |
5d723e54 FXC |
3836 | case GFC_ISYM_FPUT: |
3837 | case GFC_ISYM_FPUTC: | |
df65f093 | 3838 | case GFC_ISYM_FSTAT: |
5d723e54 | 3839 | case GFC_ISYM_FTELL: |
a8c60d7f | 3840 | case GFC_ISYM_GETCWD: |
4c0c6b9f SK |
3841 | case GFC_ISYM_GETGID: |
3842 | case GFC_ISYM_GETPID: | |
3843 | case GFC_ISYM_GETUID: | |
f77b6ca3 FXC |
3844 | case GFC_ISYM_HOSTNM: |
3845 | case GFC_ISYM_KILL: | |
3846 | case GFC_ISYM_IERRNO: | |
df65f093 | 3847 | case GFC_ISYM_IRAND: |
ae8b8789 | 3848 | case GFC_ISYM_ISATTY: |
f77b6ca3 | 3849 | case GFC_ISYM_LINK: |
bf3fb7e4 | 3850 | case GFC_ISYM_LSTAT: |
0d519038 | 3851 | case GFC_ISYM_MALLOC: |
df65f093 | 3852 | case GFC_ISYM_MATMUL: |
bf3fb7e4 FXC |
3853 | case GFC_ISYM_MCLOCK: |
3854 | case GFC_ISYM_MCLOCK8: | |
df65f093 | 3855 | case GFC_ISYM_RAND: |
f77b6ca3 | 3856 | case GFC_ISYM_RENAME: |
df65f093 | 3857 | case GFC_ISYM_SECOND: |
53096259 | 3858 | case GFC_ISYM_SECNDS: |
185d7d97 | 3859 | case GFC_ISYM_SIGNAL: |
df65f093 | 3860 | case GFC_ISYM_STAT: |
f77b6ca3 | 3861 | case GFC_ISYM_SYMLNK: |
5b1374e9 | 3862 | case GFC_ISYM_SYSTEM: |
f77b6ca3 FXC |
3863 | case GFC_ISYM_TIME: |
3864 | case GFC_ISYM_TIME8: | |
d8fe26b2 SK |
3865 | case GFC_ISYM_UMASK: |
3866 | case GFC_ISYM_UNLINK: | |
6de9cd9a DN |
3867 | gfc_conv_intrinsic_funcall (se, expr); |
3868 | break; | |
3869 | ||
3870 | default: | |
3871 | gfc_conv_intrinsic_lib_function (se, expr); | |
3872 | break; | |
3873 | } | |
3874 | } | |
3875 | ||
3876 | ||
3877 | /* This generates code to execute before entering the scalarization loop. | |
3878 | Currently does nothing. */ | |
3879 | ||
3880 | void | |
3881 | gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss) | |
3882 | { | |
3883 | switch (ss->expr->value.function.isym->generic_id) | |
3884 | { | |
3885 | case GFC_ISYM_UBOUND: | |
3886 | case GFC_ISYM_LBOUND: | |
3887 | break; | |
3888 | ||
3889 | default: | |
6e45f57b | 3890 | gcc_unreachable (); |
6de9cd9a DN |
3891 | } |
3892 | } | |
3893 | ||
3894 | ||
3895 | /* UBOUND and LBOUND intrinsics with one parameter are expanded into code | |
3896 | inside the scalarization loop. */ | |
3897 | ||
3898 | static gfc_ss * | |
3899 | gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr) | |
3900 | { | |
3901 | gfc_ss *newss; | |
3902 | ||
3903 | /* The two argument version returns a scalar. */ | |
3904 | if (expr->value.function.actual->next->expr) | |
3905 | return ss; | |
3906 | ||
3907 | newss = gfc_get_ss (); | |
3908 | newss->type = GFC_SS_INTRINSIC; | |
3909 | newss->expr = expr; | |
3910 | newss->next = ss; | |
f5f701ad | 3911 | newss->data.info.dimen = 1; |
6de9cd9a DN |
3912 | |
3913 | return newss; | |
3914 | } | |
3915 | ||
3916 | ||
3917 | /* Walk an intrinsic array libcall. */ | |
3918 | ||
3919 | static gfc_ss * | |
3920 | gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr) | |
3921 | { | |
3922 | gfc_ss *newss; | |
3923 | ||
6e45f57b | 3924 | gcc_assert (expr->rank > 0); |
6de9cd9a DN |
3925 | |
3926 | newss = gfc_get_ss (); | |
3927 | newss->type = GFC_SS_FUNCTION; | |
3928 | newss->expr = expr; | |
3929 | newss->next = ss; | |
3930 | newss->data.info.dimen = expr->rank; | |
3931 | ||
3932 | return newss; | |
3933 | } | |
3934 | ||
3935 | ||
3936 | /* Returns nonzero if the specified intrinsic function call maps directly to a | |
3937 | an external library call. Should only be used for functions that return | |
3938 | arrays. */ | |
3939 | ||
3940 | int | |
3941 | gfc_is_intrinsic_libcall (gfc_expr * expr) | |
3942 | { | |
6e45f57b PB |
3943 | gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym); |
3944 | gcc_assert (expr->rank > 0); | |
6de9cd9a DN |
3945 | |
3946 | switch (expr->value.function.isym->generic_id) | |
3947 | { | |
3948 | case GFC_ISYM_ALL: | |
3949 | case GFC_ISYM_ANY: | |
3950 | case GFC_ISYM_COUNT: | |
3951 | case GFC_ISYM_MATMUL: | |
3952 | case GFC_ISYM_MAXLOC: | |
3953 | case GFC_ISYM_MAXVAL: | |
3954 | case GFC_ISYM_MINLOC: | |
3955 | case GFC_ISYM_MINVAL: | |
3956 | case GFC_ISYM_PRODUCT: | |
3957 | case GFC_ISYM_SUM: | |
3958 | case GFC_ISYM_SHAPE: | |
3959 | case GFC_ISYM_SPREAD: | |
3960 | case GFC_ISYM_TRANSPOSE: | |
3961 | /* Ignore absent optional parameters. */ | |
3962 | return 1; | |
3963 | ||
3964 | case GFC_ISYM_RESHAPE: | |
3965 | case GFC_ISYM_CSHIFT: | |
3966 | case GFC_ISYM_EOSHIFT: | |
3967 | case GFC_ISYM_PACK: | |
3968 | case GFC_ISYM_UNPACK: | |
3969 | /* Pass absent optional parameters. */ | |
3970 | return 2; | |
3971 | ||
3972 | default: | |
3973 | return 0; | |
3974 | } | |
3975 | } | |
3976 | ||
3977 | /* Walk an intrinsic function. */ | |
3978 | gfc_ss * | |
3979 | gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr, | |
3980 | gfc_intrinsic_sym * isym) | |
3981 | { | |
6e45f57b | 3982 | gcc_assert (isym); |
6de9cd9a DN |
3983 | |
3984 | if (isym->elemental) | |
48474141 | 3985 | return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR); |
6de9cd9a DN |
3986 | |
3987 | if (expr->rank == 0) | |
3988 | return ss; | |
3989 | ||
3990 | if (gfc_is_intrinsic_libcall (expr)) | |
3991 | return gfc_walk_intrinsic_libfunc (ss, expr); | |
3992 | ||
3993 | /* Special cases. */ | |
3994 | switch (isym->generic_id) | |
3995 | { | |
3996 | case GFC_ISYM_LBOUND: | |
3997 | case GFC_ISYM_UBOUND: | |
3998 | return gfc_walk_intrinsic_bound (ss, expr); | |
3999 | ||
0c5a42a6 PT |
4000 | case GFC_ISYM_TRANSFER: |
4001 | return gfc_walk_intrinsic_libfunc (ss, expr); | |
4002 | ||
6de9cd9a DN |
4003 | default: |
4004 | /* This probably meant someone forgot to add an intrinsic to the above | |
4005 | list(s) when they implemented it, or something's gone horribly wrong. | |
4006 | */ | |
4007 | gfc_todo_error ("Scalarization of non-elemental intrinsic: %s", | |
4008 | expr->value.function.name); | |
4009 | } | |
4010 | } | |
4011 | ||
4012 | #include "gt-fortran-trans-intrinsic.h" |