]>
Commit | Line | Data |
---|---|---|
6de9cd9a | 1 | /* Intrinsic translation |
ef1b6bcd | 2 | Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc. |
6de9cd9a DN |
3 | Contributed by Paul Brook <paul@nowt.org> |
4 | and Steven Bosscher <s.bosscher@student.tudelft.nl> | |
5 | ||
9fc4d79b | 6 | This file is part of GCC. |
6de9cd9a | 7 | |
9fc4d79b TS |
8 | GCC is free software; you can redistribute it and/or modify it under |
9 | the terms of the GNU General Public License as published by the Free | |
10 | Software Foundation; either version 2, or (at your option) any later | |
11 | version. | |
6de9cd9a | 12 | |
9fc4d79b TS |
13 | GCC is distributed in the hope that it will be useful, but WITHOUT ANY |
14 | WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
15 | FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
16 | for more details. | |
6de9cd9a DN |
17 | |
18 | You should have received a copy of the GNU General Public License | |
9fc4d79b | 19 | along with GCC; see the file COPYING. If not, write to the Free |
ab57747b KC |
20 | Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA |
21 | 02110-1301, USA. */ | |
6de9cd9a DN |
22 | |
23 | /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */ | |
24 | ||
25 | #include "config.h" | |
26 | #include "system.h" | |
27 | #include "coretypes.h" | |
28 | #include "tree.h" | |
6de9cd9a DN |
29 | #include "ggc.h" |
30 | #include "toplev.h" | |
31 | #include "real.h" | |
eadf906f | 32 | #include "tree-gimple.h" |
6de9cd9a | 33 | #include "flags.h" |
6de9cd9a | 34 | #include "gfortran.h" |
f8e566e5 | 35 | #include "arith.h" |
6de9cd9a DN |
36 | #include "intrinsic.h" |
37 | #include "trans.h" | |
38 | #include "trans-const.h" | |
39 | #include "trans-types.h" | |
40 | #include "trans-array.h" | |
41 | #include "defaults.h" | |
42 | /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */ | |
43 | #include "trans-stmt.h" | |
44 | ||
45 | /* This maps fortran intrinsic math functions to external library or GCC | |
46 | builtin functions. */ | |
47 | typedef struct gfc_intrinsic_map_t GTY(()) | |
48 | { | |
49 | /* The explicit enum is required to work around inadequacies in the | |
50 | garbage collection/gengtype parsing mechanism. */ | |
51 | enum gfc_generic_isym_id id; | |
52 | ||
53 | /* Enum value from the "language-independent", aka C-centric, part | |
54 | of gcc, or END_BUILTINS of no such value set. */ | |
644cb69f FXC |
55 | enum built_in_function code_r4; |
56 | enum built_in_function code_r8; | |
57 | enum built_in_function code_r10; | |
58 | enum built_in_function code_r16; | |
59 | enum built_in_function code_c4; | |
60 | enum built_in_function code_c8; | |
61 | enum built_in_function code_c10; | |
62 | enum built_in_function code_c16; | |
6de9cd9a DN |
63 | |
64 | /* True if the naming pattern is to prepend "c" for complex and | |
65 | append "f" for kind=4. False if the naming pattern is to | |
644cb69f | 66 | prepend "_gfortran_" and append "[rc](4|8|10|16)". */ |
6de9cd9a DN |
67 | bool libm_name; |
68 | ||
69 | /* True if a complex version of the function exists. */ | |
70 | bool complex_available; | |
71 | ||
72 | /* True if the function should be marked const. */ | |
73 | bool is_constant; | |
74 | ||
75 | /* The base library name of this function. */ | |
76 | const char *name; | |
77 | ||
78 | /* Cache decls created for the various operand types. */ | |
79 | tree real4_decl; | |
80 | tree real8_decl; | |
644cb69f FXC |
81 | tree real10_decl; |
82 | tree real16_decl; | |
6de9cd9a DN |
83 | tree complex4_decl; |
84 | tree complex8_decl; | |
644cb69f FXC |
85 | tree complex10_decl; |
86 | tree complex16_decl; | |
6de9cd9a DN |
87 | } |
88 | gfc_intrinsic_map_t; | |
89 | ||
90 | /* ??? The NARGS==1 hack here is based on the fact that (c99 at least) | |
91 | defines complex variants of all of the entries in mathbuiltins.def | |
92 | except for atan2. */ | |
644cb69f FXC |
93 | #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \ |
94 | { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \ | |
95 | BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, 0, 0, 0, 0, true, \ | |
96 | false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \ | |
97 | NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE}, | |
98 | ||
99 | #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \ | |
100 | { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \ | |
101 | BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, \ | |
102 | BUILT_IN_C ## ID, BUILT_IN_C ## ID ## L, BUILT_IN_C ## ID ## L, true, \ | |
103 | true, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \ | |
104 | NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE}, | |
6de9cd9a DN |
105 | |
106 | #define LIBM_FUNCTION(ID, NAME, HAVE_COMPLEX) \ | |
644cb69f FXC |
107 | { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ |
108 | END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ | |
109 | true, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \ | |
110 | NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE } | |
6de9cd9a DN |
111 | |
112 | #define LIBF_FUNCTION(ID, NAME, HAVE_COMPLEX) \ | |
644cb69f FXC |
113 | { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ |
114 | END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \ | |
115 | false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \ | |
116 | NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE } | |
6de9cd9a DN |
117 | |
118 | static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] = | |
119 | { | |
120 | /* Functions built into gcc itself. */ | |
121 | #include "mathbuiltins.def" | |
122 | ||
123 | /* Functions in libm. */ | |
124 | /* ??? This does exist as BUILT_IN_SCALBN, but doesn't quite fit the | |
125 | pattern for other mathbuiltins.def entries. At present we have no | |
126 | optimizations for this in the common sources. */ | |
127 | LIBM_FUNCTION (SCALE, "scalbn", false), | |
128 | ||
129 | /* Functions in libgfortran. */ | |
130 | LIBF_FUNCTION (FRACTION, "fraction", false), | |
131 | LIBF_FUNCTION (NEAREST, "nearest", false), | |
132 | LIBF_FUNCTION (SET_EXPONENT, "set_exponent", false), | |
133 | ||
134 | /* End the list. */ | |
135 | LIBF_FUNCTION (NONE, NULL, false) | |
136 | }; | |
137 | #undef DEFINE_MATH_BUILTIN | |
e8525382 | 138 | #undef DEFINE_MATH_BUILTIN_C |
6de9cd9a DN |
139 | #undef LIBM_FUNCTION |
140 | #undef LIBF_FUNCTION | |
141 | ||
142 | /* Structure for storing components of a floating number to be used by | |
143 | elemental functions to manipulate reals. */ | |
144 | typedef struct | |
145 | { | |
f7b529fa | 146 | tree arg; /* Variable tree to view convert to integer. */ |
6de9cd9a DN |
147 | tree expn; /* Variable tree to save exponent. */ |
148 | tree frac; /* Variable tree to save fraction. */ | |
149 | tree smask; /* Constant tree of sign's mask. */ | |
150 | tree emask; /* Constant tree of exponent's mask. */ | |
151 | tree fmask; /* Constant tree of fraction's mask. */ | |
046dcd57 FW |
152 | tree edigits; /* Constant tree of the number of exponent bits. */ |
153 | tree fdigits; /* Constant tree of the number of fraction bits. */ | |
6de9cd9a DN |
154 | tree f1; /* Constant tree of the f1 defined in the real model. */ |
155 | tree bias; /* Constant tree of the bias of exponent in the memory. */ | |
156 | tree type; /* Type tree of arg1. */ | |
157 | tree mtype; /* Type tree of integer type. Kind is that of arg1. */ | |
158 | } | |
159 | real_compnt_info; | |
160 | ||
161 | ||
162 | /* Evaluate the arguments to an intrinsic function. */ | |
163 | ||
164 | static tree | |
165 | gfc_conv_intrinsic_function_args (gfc_se * se, gfc_expr * expr) | |
166 | { | |
167 | gfc_actual_arglist *actual; | |
168 | tree args; | |
169 | gfc_se argse; | |
170 | ||
171 | args = NULL_TREE; | |
172 | for (actual = expr->value.function.actual; actual; actual = actual->next) | |
173 | { | |
aa9c57ec | 174 | /* Skip omitted optional arguments. */ |
6de9cd9a DN |
175 | if (!actual->expr) |
176 | continue; | |
177 | ||
178 | /* Evaluate the parameter. This will substitute scalarized | |
f7b529fa | 179 | references automatically. */ |
6de9cd9a DN |
180 | gfc_init_se (&argse, se); |
181 | ||
182 | if (actual->expr->ts.type == BT_CHARACTER) | |
183 | { | |
184 | gfc_conv_expr (&argse, actual->expr); | |
185 | gfc_conv_string_parameter (&argse); | |
186 | args = gfc_chainon_list (args, argse.string_length); | |
187 | } | |
188 | else | |
189 | gfc_conv_expr_val (&argse, actual->expr); | |
190 | ||
191 | gfc_add_block_to_block (&se->pre, &argse.pre); | |
192 | gfc_add_block_to_block (&se->post, &argse.post); | |
193 | args = gfc_chainon_list (args, argse.expr); | |
194 | } | |
195 | return args; | |
196 | } | |
197 | ||
198 | ||
199 | /* Conversions between different types are output by the frontend as | |
200 | intrinsic functions. We implement these directly with inline code. */ | |
201 | ||
202 | static void | |
203 | gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr) | |
204 | { | |
205 | tree type; | |
206 | tree arg; | |
207 | ||
208 | /* Evaluate the argument. */ | |
209 | type = gfc_typenode_for_spec (&expr->ts); | |
6e45f57b | 210 | gcc_assert (expr->value.function.actual->expr); |
6de9cd9a DN |
211 | arg = gfc_conv_intrinsic_function_args (se, expr); |
212 | arg = TREE_VALUE (arg); | |
213 | ||
214 | /* Conversion from complex to non-complex involves taking the real | |
215 | component of the value. */ | |
216 | if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE | |
217 | && expr->ts.type != BT_COMPLEX) | |
218 | { | |
219 | tree artype; | |
220 | ||
221 | artype = TREE_TYPE (TREE_TYPE (arg)); | |
222 | arg = build1 (REALPART_EXPR, artype, arg); | |
223 | } | |
224 | ||
225 | se->expr = convert (type, arg); | |
226 | } | |
227 | ||
4fdb5c71 TS |
228 | /* This is needed because the gcc backend only implements |
229 | FIX_TRUNC_EXPR, which is the same as INT() in Fortran. | |
230 | FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1 | |
6de9cd9a DN |
231 | Similarly for CEILING. */ |
232 | ||
233 | static tree | |
234 | build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up) | |
235 | { | |
236 | tree tmp; | |
237 | tree cond; | |
238 | tree argtype; | |
239 | tree intval; | |
240 | ||
241 | argtype = TREE_TYPE (arg); | |
242 | arg = gfc_evaluate_now (arg, pblock); | |
243 | ||
244 | intval = convert (type, arg); | |
245 | intval = gfc_evaluate_now (intval, pblock); | |
246 | ||
247 | tmp = convert (argtype, intval); | |
923ab88c | 248 | cond = build2 (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg); |
6de9cd9a | 249 | |
923ab88c | 250 | tmp = build2 (up ? PLUS_EXPR : MINUS_EXPR, type, intval, |
e805a599 | 251 | build_int_cst (type, 1)); |
923ab88c | 252 | tmp = build3 (COND_EXPR, type, cond, intval, tmp); |
6de9cd9a DN |
253 | return tmp; |
254 | } | |
255 | ||
256 | ||
257 | /* This is needed because the gcc backend only implements FIX_TRUNC_EXPR | |
258 | NINT(x) = INT(x + ((x > 0) ? 0.5 : -0.5)). */ | |
259 | ||
260 | static tree | |
261 | build_round_expr (stmtblock_t * pblock, tree arg, tree type) | |
262 | { | |
263 | tree tmp; | |
264 | tree cond; | |
265 | tree neg; | |
266 | tree pos; | |
267 | tree argtype; | |
268 | REAL_VALUE_TYPE r; | |
269 | ||
270 | argtype = TREE_TYPE (arg); | |
271 | arg = gfc_evaluate_now (arg, pblock); | |
272 | ||
273 | real_from_string (&r, "0.5"); | |
274 | pos = build_real (argtype, r); | |
275 | ||
276 | real_from_string (&r, "-0.5"); | |
277 | neg = build_real (argtype, r); | |
278 | ||
279 | tmp = gfc_build_const (argtype, integer_zero_node); | |
10c7a96f | 280 | cond = fold_build2 (GT_EXPR, boolean_type_node, arg, tmp); |
6de9cd9a | 281 | |
10c7a96f SB |
282 | tmp = fold_build3 (COND_EXPR, argtype, cond, pos, neg); |
283 | tmp = fold_build2 (PLUS_EXPR, argtype, arg, tmp); | |
284 | return fold_build1 (FIX_TRUNC_EXPR, type, tmp); | |
6de9cd9a DN |
285 | } |
286 | ||
287 | ||
288 | /* Convert a real to an integer using a specific rounding mode. | |
289 | Ideally we would just build the corresponding GENERIC node, | |
290 | however the RTL expander only actually supports FIX_TRUNC_EXPR. */ | |
291 | ||
292 | static tree | |
e743d142 TS |
293 | build_fix_expr (stmtblock_t * pblock, tree arg, tree type, |
294 | enum tree_code op) | |
6de9cd9a DN |
295 | { |
296 | switch (op) | |
297 | { | |
298 | case FIX_FLOOR_EXPR: | |
299 | return build_fixbound_expr (pblock, arg, type, 0); | |
300 | break; | |
301 | ||
302 | case FIX_CEIL_EXPR: | |
303 | return build_fixbound_expr (pblock, arg, type, 1); | |
304 | break; | |
305 | ||
306 | case FIX_ROUND_EXPR: | |
307 | return build_round_expr (pblock, arg, type); | |
308 | ||
309 | default: | |
310 | return build1 (op, type, arg); | |
311 | } | |
312 | } | |
313 | ||
314 | ||
315 | /* Round a real value using the specified rounding mode. | |
316 | We use a temporary integer of that same kind size as the result. | |
e743d142 TS |
317 | Values larger than those that can be represented by this kind are |
318 | unchanged, as thay will not be accurate enough to represent the | |
319 | rounding. | |
6de9cd9a DN |
320 | huge = HUGE (KIND (a)) |
321 | aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a | |
322 | */ | |
323 | ||
324 | static void | |
e743d142 | 325 | gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum tree_code op) |
6de9cd9a DN |
326 | { |
327 | tree type; | |
328 | tree itype; | |
329 | tree arg; | |
330 | tree tmp; | |
331 | tree cond; | |
f8e566e5 | 332 | mpfr_t huge; |
6de9cd9a DN |
333 | int n; |
334 | int kind; | |
335 | ||
336 | kind = expr->ts.kind; | |
337 | ||
338 | n = END_BUILTINS; | |
339 | /* We have builtin functions for some cases. */ | |
340 | switch (op) | |
341 | { | |
342 | case FIX_ROUND_EXPR: | |
343 | switch (kind) | |
344 | { | |
345 | case 4: | |
346 | n = BUILT_IN_ROUNDF; | |
347 | break; | |
348 | ||
349 | case 8: | |
350 | n = BUILT_IN_ROUND; | |
351 | break; | |
644cb69f FXC |
352 | |
353 | case 10: | |
354 | case 16: | |
355 | n = BUILT_IN_ROUNDL; | |
356 | break; | |
6de9cd9a DN |
357 | } |
358 | break; | |
359 | ||
e743d142 | 360 | case FIX_TRUNC_EXPR: |
6de9cd9a DN |
361 | switch (kind) |
362 | { | |
363 | case 4: | |
e743d142 | 364 | n = BUILT_IN_TRUNCF; |
6de9cd9a DN |
365 | break; |
366 | ||
367 | case 8: | |
e743d142 | 368 | n = BUILT_IN_TRUNC; |
6de9cd9a | 369 | break; |
644cb69f FXC |
370 | |
371 | case 10: | |
372 | case 16: | |
373 | n = BUILT_IN_TRUNCL; | |
374 | break; | |
6de9cd9a | 375 | } |
e743d142 TS |
376 | break; |
377 | ||
378 | default: | |
379 | gcc_unreachable (); | |
6de9cd9a DN |
380 | } |
381 | ||
382 | /* Evaluate the argument. */ | |
6e45f57b | 383 | gcc_assert (expr->value.function.actual->expr); |
6de9cd9a DN |
384 | arg = gfc_conv_intrinsic_function_args (se, expr); |
385 | ||
386 | /* Use a builtin function if one exists. */ | |
387 | if (n != END_BUILTINS) | |
388 | { | |
389 | tmp = built_in_decls[n]; | |
390 | se->expr = gfc_build_function_call (tmp, arg); | |
391 | return; | |
392 | } | |
393 | ||
394 | /* This code is probably redundant, but we'll keep it lying around just | |
395 | in case. */ | |
396 | type = gfc_typenode_for_spec (&expr->ts); | |
397 | arg = TREE_VALUE (arg); | |
398 | arg = gfc_evaluate_now (arg, &se->pre); | |
399 | ||
400 | /* Test if the value is too large to handle sensibly. */ | |
f8e566e5 SK |
401 | gfc_set_model_kind (kind); |
402 | mpfr_init (huge); | |
e7a2d5fb | 403 | n = gfc_validate_kind (BT_INTEGER, kind, false); |
f8e566e5 SK |
404 | mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE); |
405 | tmp = gfc_conv_mpfr_to_tree (huge, kind); | |
923ab88c | 406 | cond = build2 (LT_EXPR, boolean_type_node, arg, tmp); |
6de9cd9a | 407 | |
f8e566e5 SK |
408 | mpfr_neg (huge, huge, GFC_RND_MODE); |
409 | tmp = gfc_conv_mpfr_to_tree (huge, kind); | |
923ab88c TS |
410 | tmp = build2 (GT_EXPR, boolean_type_node, arg, tmp); |
411 | cond = build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp); | |
6de9cd9a DN |
412 | itype = gfc_get_int_type (kind); |
413 | ||
414 | tmp = build_fix_expr (&se->pre, arg, itype, op); | |
415 | tmp = convert (type, tmp); | |
923ab88c | 416 | se->expr = build3 (COND_EXPR, type, cond, tmp, arg); |
f8e566e5 | 417 | mpfr_clear (huge); |
6de9cd9a DN |
418 | } |
419 | ||
420 | ||
421 | /* Convert to an integer using the specified rounding mode. */ | |
422 | ||
423 | static void | |
424 | gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, int op) | |
425 | { | |
426 | tree type; | |
427 | tree arg; | |
428 | ||
429 | /* Evaluate the argument. */ | |
430 | type = gfc_typenode_for_spec (&expr->ts); | |
6e45f57b | 431 | gcc_assert (expr->value.function.actual->expr); |
6de9cd9a DN |
432 | arg = gfc_conv_intrinsic_function_args (se, expr); |
433 | arg = TREE_VALUE (arg); | |
434 | ||
435 | if (TREE_CODE (TREE_TYPE (arg)) == INTEGER_TYPE) | |
436 | { | |
437 | /* Conversion to a different integer kind. */ | |
438 | se->expr = convert (type, arg); | |
439 | } | |
440 | else | |
441 | { | |
442 | /* Conversion from complex to non-complex involves taking the real | |
443 | component of the value. */ | |
444 | if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE | |
445 | && expr->ts.type != BT_COMPLEX) | |
446 | { | |
447 | tree artype; | |
448 | ||
449 | artype = TREE_TYPE (TREE_TYPE (arg)); | |
450 | arg = build1 (REALPART_EXPR, artype, arg); | |
451 | } | |
452 | ||
453 | se->expr = build_fix_expr (&se->pre, arg, type, op); | |
454 | } | |
455 | } | |
456 | ||
457 | ||
458 | /* Get the imaginary component of a value. */ | |
459 | ||
460 | static void | |
461 | gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr) | |
462 | { | |
463 | tree arg; | |
464 | ||
465 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
466 | arg = TREE_VALUE (arg); | |
467 | se->expr = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg); | |
468 | } | |
469 | ||
470 | ||
471 | /* Get the complex conjugate of a value. */ | |
472 | ||
473 | static void | |
474 | gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr) | |
475 | { | |
476 | tree arg; | |
477 | ||
478 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
479 | arg = TREE_VALUE (arg); | |
480 | se->expr = build1 (CONJ_EXPR, TREE_TYPE (arg), arg); | |
481 | } | |
482 | ||
483 | ||
484 | /* Initialize function decls for library functions. The external functions | |
485 | are created as required. Builtin functions are added here. */ | |
486 | ||
487 | void | |
488 | gfc_build_intrinsic_lib_fndecls (void) | |
489 | { | |
490 | gfc_intrinsic_map_t *m; | |
491 | ||
492 | /* Add GCC builtin functions. */ | |
493 | for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++) | |
494 | { | |
644cb69f FXC |
495 | if (m->code_r4 != END_BUILTINS) |
496 | m->real4_decl = built_in_decls[m->code_r4]; | |
497 | if (m->code_r8 != END_BUILTINS) | |
498 | m->real8_decl = built_in_decls[m->code_r8]; | |
499 | if (m->code_r10 != END_BUILTINS) | |
500 | m->real10_decl = built_in_decls[m->code_r10]; | |
501 | if (m->code_r16 != END_BUILTINS) | |
502 | m->real16_decl = built_in_decls[m->code_r16]; | |
503 | if (m->code_c4 != END_BUILTINS) | |
504 | m->complex4_decl = built_in_decls[m->code_c4]; | |
505 | if (m->code_c8 != END_BUILTINS) | |
506 | m->complex8_decl = built_in_decls[m->code_c8]; | |
507 | if (m->code_c10 != END_BUILTINS) | |
508 | m->complex10_decl = built_in_decls[m->code_c10]; | |
509 | if (m->code_c16 != END_BUILTINS) | |
510 | m->complex16_decl = built_in_decls[m->code_c16]; | |
6de9cd9a DN |
511 | } |
512 | } | |
513 | ||
514 | ||
515 | /* Create a fndecl for a simple intrinsic library function. */ | |
516 | ||
517 | static tree | |
518 | gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr) | |
519 | { | |
520 | tree type; | |
521 | tree argtypes; | |
522 | tree fndecl; | |
523 | gfc_actual_arglist *actual; | |
524 | tree *pdecl; | |
525 | gfc_typespec *ts; | |
526 | char name[GFC_MAX_SYMBOL_LEN + 3]; | |
527 | ||
528 | ts = &expr->ts; | |
529 | if (ts->type == BT_REAL) | |
530 | { | |
531 | switch (ts->kind) | |
532 | { | |
533 | case 4: | |
534 | pdecl = &m->real4_decl; | |
535 | break; | |
536 | case 8: | |
537 | pdecl = &m->real8_decl; | |
538 | break; | |
644cb69f FXC |
539 | case 10: |
540 | pdecl = &m->real10_decl; | |
541 | break; | |
542 | case 16: | |
543 | pdecl = &m->real16_decl; | |
544 | break; | |
6de9cd9a | 545 | default: |
6e45f57b | 546 | gcc_unreachable (); |
6de9cd9a DN |
547 | } |
548 | } | |
549 | else if (ts->type == BT_COMPLEX) | |
550 | { | |
6e45f57b | 551 | gcc_assert (m->complex_available); |
6de9cd9a DN |
552 | |
553 | switch (ts->kind) | |
554 | { | |
555 | case 4: | |
556 | pdecl = &m->complex4_decl; | |
557 | break; | |
558 | case 8: | |
559 | pdecl = &m->complex8_decl; | |
560 | break; | |
644cb69f FXC |
561 | case 10: |
562 | pdecl = &m->complex10_decl; | |
563 | break; | |
564 | case 16: | |
565 | pdecl = &m->complex16_decl; | |
566 | break; | |
6de9cd9a | 567 | default: |
6e45f57b | 568 | gcc_unreachable (); |
6de9cd9a DN |
569 | } |
570 | } | |
571 | else | |
6e45f57b | 572 | gcc_unreachable (); |
6de9cd9a DN |
573 | |
574 | if (*pdecl) | |
575 | return *pdecl; | |
576 | ||
577 | if (m->libm_name) | |
578 | { | |
644cb69f FXC |
579 | gcc_assert (ts->kind == 4 || ts->kind == 8 || ts->kind == 10 |
580 | || ts->kind == 16); | |
b36cd00b | 581 | snprintf (name, sizeof (name), "%s%s%s", |
6de9cd9a DN |
582 | ts->type == BT_COMPLEX ? "c" : "", |
583 | m->name, | |
584 | ts->kind == 4 ? "f" : ""); | |
585 | } | |
586 | else | |
587 | { | |
588 | snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name, | |
589 | ts->type == BT_COMPLEX ? 'c' : 'r', | |
590 | ts->kind); | |
591 | } | |
592 | ||
593 | argtypes = NULL_TREE; | |
594 | for (actual = expr->value.function.actual; actual; actual = actual->next) | |
595 | { | |
596 | type = gfc_typenode_for_spec (&actual->expr->ts); | |
597 | argtypes = gfc_chainon_list (argtypes, type); | |
598 | } | |
599 | argtypes = gfc_chainon_list (argtypes, void_type_node); | |
600 | type = build_function_type (gfc_typenode_for_spec (ts), argtypes); | |
601 | fndecl = build_decl (FUNCTION_DECL, get_identifier (name), type); | |
602 | ||
603 | /* Mark the decl as external. */ | |
604 | DECL_EXTERNAL (fndecl) = 1; | |
605 | TREE_PUBLIC (fndecl) = 1; | |
606 | ||
607 | /* Mark it __attribute__((const)), if possible. */ | |
608 | TREE_READONLY (fndecl) = m->is_constant; | |
609 | ||
0e6df31e | 610 | rest_of_decl_compilation (fndecl, 1, 0); |
6de9cd9a DN |
611 | |
612 | (*pdecl) = fndecl; | |
613 | return fndecl; | |
614 | } | |
615 | ||
616 | ||
617 | /* Convert an intrinsic function into an external or builtin call. */ | |
618 | ||
619 | static void | |
620 | gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr) | |
621 | { | |
622 | gfc_intrinsic_map_t *m; | |
623 | tree args; | |
624 | tree fndecl; | |
625 | gfc_generic_isym_id id; | |
626 | ||
627 | id = expr->value.function.isym->generic_id; | |
628 | /* Find the entry for this function. */ | |
629 | for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++) | |
630 | { | |
631 | if (id == m->id) | |
632 | break; | |
633 | } | |
634 | ||
635 | if (m->id == GFC_ISYM_NONE) | |
636 | { | |
637 | internal_error ("Intrinsic function %s(%d) not recognized", | |
638 | expr->value.function.name, id); | |
639 | } | |
640 | ||
641 | /* Get the decl and generate the call. */ | |
642 | args = gfc_conv_intrinsic_function_args (se, expr); | |
643 | fndecl = gfc_get_intrinsic_lib_fndecl (m, expr); | |
644 | se->expr = gfc_build_function_call (fndecl, args); | |
645 | } | |
646 | ||
647 | /* Generate code for EXPONENT(X) intrinsic function. */ | |
648 | ||
649 | static void | |
650 | gfc_conv_intrinsic_exponent (gfc_se * se, gfc_expr * expr) | |
651 | { | |
652 | tree args, fndecl; | |
653 | gfc_expr *a1; | |
654 | ||
655 | args = gfc_conv_intrinsic_function_args (se, expr); | |
656 | ||
657 | a1 = expr->value.function.actual->expr; | |
658 | switch (a1->ts.kind) | |
659 | { | |
660 | case 4: | |
661 | fndecl = gfor_fndecl_math_exponent4; | |
662 | break; | |
663 | case 8: | |
664 | fndecl = gfor_fndecl_math_exponent8; | |
665 | break; | |
644cb69f FXC |
666 | case 10: |
667 | fndecl = gfor_fndecl_math_exponent10; | |
668 | break; | |
669 | case 16: | |
670 | fndecl = gfor_fndecl_math_exponent16; | |
671 | break; | |
6de9cd9a | 672 | default: |
6e45f57b | 673 | gcc_unreachable (); |
6de9cd9a DN |
674 | } |
675 | ||
676 | se->expr = gfc_build_function_call (fndecl, args); | |
677 | } | |
678 | ||
679 | /* Evaluate a single upper or lower bound. */ | |
1f2959f0 | 680 | /* TODO: bound intrinsic generates way too much unnecessary code. */ |
6de9cd9a DN |
681 | |
682 | static void | |
683 | gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper) | |
684 | { | |
685 | gfc_actual_arglist *arg; | |
686 | gfc_actual_arglist *arg2; | |
687 | tree desc; | |
688 | tree type; | |
689 | tree bound; | |
690 | tree tmp; | |
691 | tree cond; | |
692 | gfc_se argse; | |
693 | gfc_ss *ss; | |
694 | int i; | |
695 | ||
6de9cd9a DN |
696 | arg = expr->value.function.actual; |
697 | arg2 = arg->next; | |
698 | ||
699 | if (se->ss) | |
700 | { | |
701 | /* Create an implicit second parameter from the loop variable. */ | |
6e45f57b PB |
702 | gcc_assert (!arg2->expr); |
703 | gcc_assert (se->loop->dimen == 1); | |
704 | gcc_assert (se->ss->expr == expr); | |
6de9cd9a DN |
705 | gfc_advance_se_ss_chain (se); |
706 | bound = se->loop->loopvar[0]; | |
10c7a96f SB |
707 | bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound, |
708 | se->loop->from[0]); | |
6de9cd9a DN |
709 | } |
710 | else | |
711 | { | |
712 | /* use the passed argument. */ | |
6e45f57b | 713 | gcc_assert (arg->next->expr); |
6de9cd9a DN |
714 | gfc_init_se (&argse, NULL); |
715 | gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type); | |
716 | gfc_add_block_to_block (&se->pre, &argse.pre); | |
717 | bound = argse.expr; | |
718 | /* Convert from one based to zero based. */ | |
10c7a96f SB |
719 | bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound, |
720 | gfc_index_one_node); | |
6de9cd9a DN |
721 | } |
722 | ||
723 | /* TODO: don't re-evaluate the descriptor on each iteration. */ | |
724 | /* Get a descriptor for the first parameter. */ | |
725 | ss = gfc_walk_expr (arg->expr); | |
6e45f57b | 726 | gcc_assert (ss != gfc_ss_terminator); |
4fd9a813 | 727 | gfc_init_se (&argse, NULL); |
6de9cd9a DN |
728 | gfc_conv_expr_descriptor (&argse, arg->expr, ss); |
729 | gfc_add_block_to_block (&se->pre, &argse.pre); | |
730 | gfc_add_block_to_block (&se->post, &argse.post); | |
731 | ||
732 | desc = argse.expr; | |
733 | ||
734 | if (INTEGER_CST_P (bound)) | |
735 | { | |
6e45f57b | 736 | gcc_assert (TREE_INT_CST_HIGH (bound) == 0); |
6de9cd9a | 737 | i = TREE_INT_CST_LOW (bound); |
6e45f57b | 738 | gcc_assert (i >= 0 && i < GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))); |
6de9cd9a DN |
739 | } |
740 | else | |
741 | { | |
742 | if (flag_bounds_check) | |
743 | { | |
744 | bound = gfc_evaluate_now (bound, &se->pre); | |
10c7a96f SB |
745 | cond = fold_build2 (LT_EXPR, boolean_type_node, |
746 | bound, build_int_cst (TREE_TYPE (bound), 0)); | |
6de9cd9a | 747 | tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))]; |
10c7a96f SB |
748 | tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp); |
749 | cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp); | |
6de9cd9a DN |
750 | gfc_trans_runtime_check (cond, gfc_strconst_fault, &se->pre); |
751 | } | |
752 | } | |
753 | ||
754 | if (upper) | |
755 | se->expr = gfc_conv_descriptor_ubound(desc, bound); | |
756 | else | |
757 | se->expr = gfc_conv_descriptor_lbound(desc, bound); | |
758 | ||
759 | type = gfc_typenode_for_spec (&expr->ts); | |
760 | se->expr = convert (type, se->expr); | |
761 | } | |
762 | ||
763 | ||
764 | static void | |
765 | gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr) | |
766 | { | |
767 | tree args; | |
768 | tree val; | |
ead6d15f | 769 | int n; |
6de9cd9a DN |
770 | |
771 | args = gfc_conv_intrinsic_function_args (se, expr); | |
6e45f57b | 772 | gcc_assert (args && TREE_CHAIN (args) == NULL_TREE); |
6de9cd9a DN |
773 | val = TREE_VALUE (args); |
774 | ||
775 | switch (expr->value.function.actual->expr->ts.type) | |
776 | { | |
777 | case BT_INTEGER: | |
778 | case BT_REAL: | |
779 | se->expr = build1 (ABS_EXPR, TREE_TYPE (val), val); | |
780 | break; | |
781 | ||
782 | case BT_COMPLEX: | |
783 | switch (expr->ts.kind) | |
784 | { | |
785 | case 4: | |
ead6d15f | 786 | n = BUILT_IN_CABSF; |
6de9cd9a DN |
787 | break; |
788 | case 8: | |
ead6d15f | 789 | n = BUILT_IN_CABS; |
6de9cd9a | 790 | break; |
644cb69f FXC |
791 | case 10: |
792 | case 16: | |
793 | n = BUILT_IN_CABSL; | |
794 | break; | |
6de9cd9a | 795 | default: |
6e45f57b | 796 | gcc_unreachable (); |
6de9cd9a | 797 | } |
ead6d15f | 798 | se->expr = fold (gfc_build_function_call (built_in_decls[n], args)); |
6de9cd9a DN |
799 | break; |
800 | ||
801 | default: | |
6e45f57b | 802 | gcc_unreachable (); |
6de9cd9a DN |
803 | } |
804 | } | |
805 | ||
806 | ||
807 | /* Create a complex value from one or two real components. */ | |
808 | ||
809 | static void | |
810 | gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both) | |
811 | { | |
812 | tree arg; | |
813 | tree real; | |
814 | tree imag; | |
815 | tree type; | |
816 | ||
817 | type = gfc_typenode_for_spec (&expr->ts); | |
818 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
819 | real = convert (TREE_TYPE (type), TREE_VALUE (arg)); | |
820 | if (both) | |
821 | imag = convert (TREE_TYPE (type), TREE_VALUE (TREE_CHAIN (arg))); | |
822 | else if (TREE_CODE (TREE_TYPE (TREE_VALUE (arg))) == COMPLEX_TYPE) | |
823 | { | |
824 | arg = TREE_VALUE (arg); | |
825 | imag = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg); | |
826 | imag = convert (TREE_TYPE (type), imag); | |
827 | } | |
828 | else | |
829 | imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node); | |
830 | ||
10c7a96f | 831 | se->expr = fold_build2 (COMPLEX_EXPR, type, real, imag); |
6de9cd9a DN |
832 | } |
833 | ||
e98a8b5b TS |
834 | /* Remainder function MOD(A, P) = A - INT(A / P) * P |
835 | MODULO(A, P) = A - FLOOR (A / P) * P */ | |
6de9cd9a DN |
836 | /* TODO: MOD(x, 0) */ |
837 | ||
838 | static void | |
839 | gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo) | |
840 | { | |
841 | tree arg; | |
842 | tree arg2; | |
843 | tree type; | |
844 | tree itype; | |
845 | tree tmp; | |
6de9cd9a DN |
846 | tree test; |
847 | tree test2; | |
f8e566e5 | 848 | mpfr_t huge; |
6de9cd9a DN |
849 | int n; |
850 | ||
851 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
852 | arg2 = TREE_VALUE (TREE_CHAIN (arg)); | |
853 | arg = TREE_VALUE (arg); | |
854 | type = TREE_TYPE (arg); | |
855 | ||
856 | switch (expr->ts.type) | |
857 | { | |
858 | case BT_INTEGER: | |
859 | /* Integer case is easy, we've got a builtin op. */ | |
e98a8b5b TS |
860 | if (modulo) |
861 | se->expr = build2 (FLOOR_MOD_EXPR, type, arg, arg2); | |
862 | else | |
863 | se->expr = build2 (TRUNC_MOD_EXPR, type, arg, arg2); | |
6de9cd9a DN |
864 | break; |
865 | ||
866 | case BT_REAL: | |
867 | /* Real values we have to do the hard way. */ | |
868 | arg = gfc_evaluate_now (arg, &se->pre); | |
869 | arg2 = gfc_evaluate_now (arg2, &se->pre); | |
870 | ||
923ab88c | 871 | tmp = build2 (RDIV_EXPR, type, arg, arg2); |
6de9cd9a | 872 | /* Test if the value is too large to handle sensibly. */ |
f8e566e5 SK |
873 | gfc_set_model_kind (expr->ts.kind); |
874 | mpfr_init (huge); | |
e7a2d5fb | 875 | n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false); |
f8e566e5 SK |
876 | mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE); |
877 | test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind); | |
923ab88c | 878 | test2 = build2 (LT_EXPR, boolean_type_node, tmp, test); |
6de9cd9a | 879 | |
f8e566e5 SK |
880 | mpfr_neg (huge, huge, GFC_RND_MODE); |
881 | test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind); | |
923ab88c TS |
882 | test = build2 (GT_EXPR, boolean_type_node, tmp, test); |
883 | test2 = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2); | |
6de9cd9a DN |
884 | |
885 | itype = gfc_get_int_type (expr->ts.kind); | |
e98a8b5b TS |
886 | if (modulo) |
887 | tmp = build_fix_expr (&se->pre, tmp, itype, FIX_FLOOR_EXPR); | |
888 | else | |
889 | tmp = build_fix_expr (&se->pre, tmp, itype, FIX_TRUNC_EXPR); | |
6de9cd9a | 890 | tmp = convert (type, tmp); |
923ab88c TS |
891 | tmp = build3 (COND_EXPR, type, test2, tmp, arg); |
892 | tmp = build2 (MULT_EXPR, type, tmp, arg2); | |
893 | se->expr = build2 (MINUS_EXPR, type, arg, tmp); | |
f8e566e5 | 894 | mpfr_clear (huge); |
6de9cd9a DN |
895 | break; |
896 | ||
897 | default: | |
6e45f57b | 898 | gcc_unreachable (); |
6de9cd9a | 899 | } |
6de9cd9a DN |
900 | } |
901 | ||
902 | /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */ | |
903 | ||
904 | static void | |
905 | gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr) | |
906 | { | |
907 | tree arg; | |
908 | tree arg2; | |
909 | tree val; | |
910 | tree tmp; | |
911 | tree type; | |
912 | tree zero; | |
913 | ||
914 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
915 | arg2 = TREE_VALUE (TREE_CHAIN (arg)); | |
916 | arg = TREE_VALUE (arg); | |
917 | type = TREE_TYPE (arg); | |
918 | ||
923ab88c | 919 | val = build2 (MINUS_EXPR, type, arg, arg2); |
6de9cd9a DN |
920 | val = gfc_evaluate_now (val, &se->pre); |
921 | ||
922 | zero = gfc_build_const (type, integer_zero_node); | |
923ab88c TS |
923 | tmp = build2 (LE_EXPR, boolean_type_node, val, zero); |
924 | se->expr = build3 (COND_EXPR, type, tmp, zero, val); | |
6de9cd9a DN |
925 | } |
926 | ||
927 | ||
928 | /* SIGN(A, B) is absolute value of A times sign of B. | |
929 | The real value versions use library functions to ensure the correct | |
930 | handling of negative zero. Integer case implemented as: | |
931 | SIGN(A, B) = ((a >= 0) .xor. (b >= 0)) ? a : -a | |
932 | */ | |
933 | ||
934 | static void | |
935 | gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr) | |
936 | { | |
937 | tree tmp; | |
938 | tree arg; | |
939 | tree arg2; | |
940 | tree type; | |
941 | tree zero; | |
942 | tree testa; | |
943 | tree testb; | |
944 | ||
945 | ||
946 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
947 | if (expr->ts.type == BT_REAL) | |
948 | { | |
949 | switch (expr->ts.kind) | |
950 | { | |
951 | case 4: | |
ead6d15f | 952 | tmp = built_in_decls[BUILT_IN_COPYSIGNF]; |
6de9cd9a DN |
953 | break; |
954 | case 8: | |
ead6d15f | 955 | tmp = built_in_decls[BUILT_IN_COPYSIGN]; |
6de9cd9a | 956 | break; |
644cb69f FXC |
957 | case 10: |
958 | case 16: | |
959 | tmp = built_in_decls[BUILT_IN_COPYSIGNL]; | |
960 | break; | |
6de9cd9a | 961 | default: |
6e45f57b | 962 | gcc_unreachable (); |
6de9cd9a | 963 | } |
ead6d15f | 964 | se->expr = fold (gfc_build_function_call (tmp, arg)); |
6de9cd9a DN |
965 | return; |
966 | } | |
967 | ||
968 | arg2 = TREE_VALUE (TREE_CHAIN (arg)); | |
969 | arg = TREE_VALUE (arg); | |
970 | type = TREE_TYPE (arg); | |
971 | zero = gfc_build_const (type, integer_zero_node); | |
972 | ||
10c7a96f SB |
973 | testa = fold_build2 (GE_EXPR, boolean_type_node, arg, zero); |
974 | testb = fold_build2 (GE_EXPR, boolean_type_node, arg2, zero); | |
975 | tmp = fold_build2 (TRUTH_XOR_EXPR, boolean_type_node, testa, testb); | |
976 | se->expr = fold_build3 (COND_EXPR, type, tmp, | |
977 | build1 (NEGATE_EXPR, type, arg), arg); | |
6de9cd9a DN |
978 | } |
979 | ||
980 | ||
981 | /* Test for the presence of an optional argument. */ | |
982 | ||
983 | static void | |
984 | gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr) | |
985 | { | |
986 | gfc_expr *arg; | |
987 | ||
988 | arg = expr->value.function.actual->expr; | |
6e45f57b | 989 | gcc_assert (arg->expr_type == EXPR_VARIABLE); |
6de9cd9a DN |
990 | se->expr = gfc_conv_expr_present (arg->symtree->n.sym); |
991 | se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr); | |
992 | } | |
993 | ||
994 | ||
995 | /* Calculate the double precision product of two single precision values. */ | |
996 | ||
997 | static void | |
998 | gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr) | |
999 | { | |
1000 | tree arg; | |
1001 | tree arg2; | |
1002 | tree type; | |
1003 | ||
1004 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
1005 | arg2 = TREE_VALUE (TREE_CHAIN (arg)); | |
1006 | arg = TREE_VALUE (arg); | |
1007 | ||
1008 | /* Convert the args to double precision before multiplying. */ | |
1009 | type = gfc_typenode_for_spec (&expr->ts); | |
1010 | arg = convert (type, arg); | |
1011 | arg2 = convert (type, arg2); | |
923ab88c | 1012 | se->expr = build2 (MULT_EXPR, type, arg, arg2); |
6de9cd9a DN |
1013 | } |
1014 | ||
1015 | ||
1016 | /* Return a length one character string containing an ascii character. */ | |
1017 | ||
1018 | static void | |
1019 | gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr) | |
1020 | { | |
1021 | tree arg; | |
1022 | tree var; | |
1023 | tree type; | |
1024 | ||
1025 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
1026 | arg = TREE_VALUE (arg); | |
1027 | ||
1028 | /* We currently don't support character types != 1. */ | |
6e45f57b | 1029 | gcc_assert (expr->ts.kind == 1); |
6de9cd9a DN |
1030 | type = gfc_character1_type_node; |
1031 | var = gfc_create_var (type, "char"); | |
1032 | ||
1033 | arg = convert (type, arg); | |
1034 | gfc_add_modify_expr (&se->pre, var, arg); | |
1035 | se->expr = gfc_build_addr_expr (build_pointer_type (type), var); | |
1036 | se->string_length = integer_one_node; | |
1037 | } | |
1038 | ||
1039 | ||
1040 | /* Get the minimum/maximum value of all the parameters. | |
1041 | minmax (a1, a2, a3, ...) | |
1042 | { | |
1043 | if (a2 .op. a1) | |
1044 | mvar = a2; | |
1045 | else | |
1046 | mvar = a1; | |
1047 | if (a3 .op. mvar) | |
1048 | mvar = a3; | |
1049 | ... | |
1050 | return mvar | |
1051 | } | |
1052 | */ | |
1053 | ||
1054 | /* TODO: Mismatching types can occur when specific names are used. | |
1055 | These should be handled during resolution. */ | |
1056 | static void | |
1057 | gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op) | |
1058 | { | |
1059 | tree limit; | |
1060 | tree tmp; | |
1061 | tree mvar; | |
1062 | tree val; | |
1063 | tree thencase; | |
1064 | tree elsecase; | |
1065 | tree arg; | |
1066 | tree type; | |
1067 | ||
1068 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
1069 | type = gfc_typenode_for_spec (&expr->ts); | |
1070 | ||
1071 | limit = TREE_VALUE (arg); | |
1072 | if (TREE_TYPE (limit) != type) | |
1073 | limit = convert (type, limit); | |
1074 | /* Only evaluate the argument once. */ | |
1075 | if (TREE_CODE (limit) != VAR_DECL && !TREE_CONSTANT (limit)) | |
1076 | limit = gfc_evaluate_now(limit, &se->pre); | |
1077 | ||
1078 | mvar = gfc_create_var (type, "M"); | |
923ab88c | 1079 | elsecase = build2_v (MODIFY_EXPR, mvar, limit); |
6de9cd9a DN |
1080 | for (arg = TREE_CHAIN (arg); arg != NULL_TREE; arg = TREE_CHAIN (arg)) |
1081 | { | |
1082 | val = TREE_VALUE (arg); | |
1083 | if (TREE_TYPE (val) != type) | |
1084 | val = convert (type, val); | |
1085 | ||
1086 | /* Only evaluate the argument once. */ | |
1087 | if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val)) | |
1088 | val = gfc_evaluate_now(val, &se->pre); | |
1089 | ||
923ab88c | 1090 | thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val)); |
6de9cd9a | 1091 | |
923ab88c TS |
1092 | tmp = build2 (op, boolean_type_node, val, limit); |
1093 | tmp = build3_v (COND_EXPR, tmp, thencase, elsecase); | |
6de9cd9a DN |
1094 | gfc_add_expr_to_block (&se->pre, tmp); |
1095 | elsecase = build_empty_stmt (); | |
1096 | limit = mvar; | |
1097 | } | |
1098 | se->expr = mvar; | |
1099 | } | |
1100 | ||
1101 | ||
4b9b6210 TS |
1102 | /* Create a symbol node for this intrinsic. The symbol from the frontend |
1103 | has the generic name. */ | |
6de9cd9a DN |
1104 | |
1105 | static gfc_symbol * | |
1106 | gfc_get_symbol_for_expr (gfc_expr * expr) | |
1107 | { | |
1108 | gfc_symbol *sym; | |
1109 | ||
1110 | /* TODO: Add symbols for intrinsic function to the global namespace. */ | |
6e45f57b | 1111 | gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5); |
6de9cd9a DN |
1112 | sym = gfc_new_symbol (expr->value.function.name, NULL); |
1113 | ||
1114 | sym->ts = expr->ts; | |
1115 | sym->attr.external = 1; | |
1116 | sym->attr.function = 1; | |
1117 | sym->attr.always_explicit = 1; | |
1118 | sym->attr.proc = PROC_INTRINSIC; | |
1119 | sym->attr.flavor = FL_PROCEDURE; | |
1120 | sym->result = sym; | |
1121 | if (expr->rank > 0) | |
1122 | { | |
1123 | sym->attr.dimension = 1; | |
1124 | sym->as = gfc_get_array_spec (); | |
1125 | sym->as->type = AS_ASSUMED_SHAPE; | |
1126 | sym->as->rank = expr->rank; | |
1127 | } | |
1128 | ||
1129 | /* TODO: proper argument lists for external intrinsics. */ | |
1130 | return sym; | |
1131 | } | |
1132 | ||
1133 | /* Generate a call to an external intrinsic function. */ | |
1134 | static void | |
1135 | gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr) | |
1136 | { | |
1137 | gfc_symbol *sym; | |
1138 | ||
6e45f57b | 1139 | gcc_assert (!se->ss || se->ss->expr == expr); |
6de9cd9a DN |
1140 | |
1141 | if (se->ss) | |
6e45f57b | 1142 | gcc_assert (expr->rank > 0); |
6de9cd9a | 1143 | else |
6e45f57b | 1144 | gcc_assert (expr->rank == 0); |
6de9cd9a DN |
1145 | |
1146 | sym = gfc_get_symbol_for_expr (expr); | |
1147 | gfc_conv_function_call (se, sym, expr->value.function.actual); | |
1148 | gfc_free (sym); | |
1149 | } | |
1150 | ||
1151 | /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR. | |
1152 | Implemented as | |
1153 | any(a) | |
1154 | { | |
1155 | forall (i=...) | |
1156 | if (a[i] != 0) | |
1157 | return 1 | |
1158 | end forall | |
1159 | return 0 | |
1160 | } | |
1161 | all(a) | |
1162 | { | |
1163 | forall (i=...) | |
1164 | if (a[i] == 0) | |
1165 | return 0 | |
1166 | end forall | |
1167 | return 1 | |
1168 | } | |
1169 | */ | |
1170 | static void | |
1171 | gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op) | |
1172 | { | |
1173 | tree resvar; | |
1174 | stmtblock_t block; | |
1175 | stmtblock_t body; | |
1176 | tree type; | |
1177 | tree tmp; | |
1178 | tree found; | |
1179 | gfc_loopinfo loop; | |
1180 | gfc_actual_arglist *actual; | |
1181 | gfc_ss *arrayss; | |
1182 | gfc_se arrayse; | |
1183 | tree exit_label; | |
1184 | ||
1185 | if (se->ss) | |
1186 | { | |
1187 | gfc_conv_intrinsic_funcall (se, expr); | |
1188 | return; | |
1189 | } | |
1190 | ||
1191 | actual = expr->value.function.actual; | |
1192 | type = gfc_typenode_for_spec (&expr->ts); | |
1193 | /* Initialize the result. */ | |
1194 | resvar = gfc_create_var (type, "test"); | |
1195 | if (op == EQ_EXPR) | |
1196 | tmp = convert (type, boolean_true_node); | |
1197 | else | |
1198 | tmp = convert (type, boolean_false_node); | |
1199 | gfc_add_modify_expr (&se->pre, resvar, tmp); | |
1200 | ||
1201 | /* Walk the arguments. */ | |
1202 | arrayss = gfc_walk_expr (actual->expr); | |
6e45f57b | 1203 | gcc_assert (arrayss != gfc_ss_terminator); |
6de9cd9a DN |
1204 | |
1205 | /* Initialize the scalarizer. */ | |
1206 | gfc_init_loopinfo (&loop); | |
1207 | exit_label = gfc_build_label_decl (NULL_TREE); | |
1208 | TREE_USED (exit_label) = 1; | |
1209 | gfc_add_ss_to_loop (&loop, arrayss); | |
1210 | ||
1211 | /* Initialize the loop. */ | |
1212 | gfc_conv_ss_startstride (&loop); | |
1213 | gfc_conv_loop_setup (&loop); | |
1214 | ||
1215 | gfc_mark_ss_chain_used (arrayss, 1); | |
1216 | /* Generate the loop body. */ | |
1217 | gfc_start_scalarized_body (&loop, &body); | |
1218 | ||
1219 | /* If the condition matches then set the return value. */ | |
1220 | gfc_start_block (&block); | |
1221 | if (op == EQ_EXPR) | |
1222 | tmp = convert (type, boolean_false_node); | |
1223 | else | |
1224 | tmp = convert (type, boolean_true_node); | |
1225 | gfc_add_modify_expr (&block, resvar, tmp); | |
1226 | ||
1227 | /* And break out of the loop. */ | |
1228 | tmp = build1_v (GOTO_EXPR, exit_label); | |
1229 | gfc_add_expr_to_block (&block, tmp); | |
1230 | ||
1231 | found = gfc_finish_block (&block); | |
1232 | ||
1233 | /* Check this element. */ | |
1234 | gfc_init_se (&arrayse, NULL); | |
1235 | gfc_copy_loopinfo_to_se (&arrayse, &loop); | |
1236 | arrayse.ss = arrayss; | |
1237 | gfc_conv_expr_val (&arrayse, actual->expr); | |
1238 | ||
1239 | gfc_add_block_to_block (&body, &arrayse.pre); | |
923ab88c | 1240 | tmp = build2 (op, boolean_type_node, arrayse.expr, |
e805a599 | 1241 | build_int_cst (TREE_TYPE (arrayse.expr), 0)); |
923ab88c | 1242 | tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt ()); |
6de9cd9a DN |
1243 | gfc_add_expr_to_block (&body, tmp); |
1244 | gfc_add_block_to_block (&body, &arrayse.post); | |
1245 | ||
1246 | gfc_trans_scalarizing_loops (&loop, &body); | |
1247 | ||
1248 | /* Add the exit label. */ | |
1249 | tmp = build1_v (LABEL_EXPR, exit_label); | |
1250 | gfc_add_expr_to_block (&loop.pre, tmp); | |
1251 | ||
1252 | gfc_add_block_to_block (&se->pre, &loop.pre); | |
1253 | gfc_add_block_to_block (&se->pre, &loop.post); | |
1254 | gfc_cleanup_loop (&loop); | |
1255 | ||
1256 | se->expr = resvar; | |
1257 | } | |
1258 | ||
1259 | /* COUNT(A) = Number of true elements in A. */ | |
1260 | static void | |
1261 | gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr) | |
1262 | { | |
1263 | tree resvar; | |
1264 | tree type; | |
1265 | stmtblock_t body; | |
1266 | tree tmp; | |
1267 | gfc_loopinfo loop; | |
1268 | gfc_actual_arglist *actual; | |
1269 | gfc_ss *arrayss; | |
1270 | gfc_se arrayse; | |
1271 | ||
1272 | if (se->ss) | |
1273 | { | |
1274 | gfc_conv_intrinsic_funcall (se, expr); | |
1275 | return; | |
1276 | } | |
1277 | ||
1278 | actual = expr->value.function.actual; | |
1279 | ||
1280 | type = gfc_typenode_for_spec (&expr->ts); | |
1281 | /* Initialize the result. */ | |
1282 | resvar = gfc_create_var (type, "count"); | |
e805a599 | 1283 | gfc_add_modify_expr (&se->pre, resvar, build_int_cst (type, 0)); |
6de9cd9a DN |
1284 | |
1285 | /* Walk the arguments. */ | |
1286 | arrayss = gfc_walk_expr (actual->expr); | |
6e45f57b | 1287 | gcc_assert (arrayss != gfc_ss_terminator); |
6de9cd9a DN |
1288 | |
1289 | /* Initialize the scalarizer. */ | |
1290 | gfc_init_loopinfo (&loop); | |
1291 | gfc_add_ss_to_loop (&loop, arrayss); | |
1292 | ||
1293 | /* Initialize the loop. */ | |
1294 | gfc_conv_ss_startstride (&loop); | |
1295 | gfc_conv_loop_setup (&loop); | |
1296 | ||
1297 | gfc_mark_ss_chain_used (arrayss, 1); | |
1298 | /* Generate the loop body. */ | |
1299 | gfc_start_scalarized_body (&loop, &body); | |
1300 | ||
923ab88c | 1301 | tmp = build2 (PLUS_EXPR, TREE_TYPE (resvar), resvar, |
e805a599 | 1302 | build_int_cst (TREE_TYPE (resvar), 1)); |
923ab88c | 1303 | tmp = build2_v (MODIFY_EXPR, resvar, tmp); |
6de9cd9a DN |
1304 | |
1305 | gfc_init_se (&arrayse, NULL); | |
1306 | gfc_copy_loopinfo_to_se (&arrayse, &loop); | |
1307 | arrayse.ss = arrayss; | |
1308 | gfc_conv_expr_val (&arrayse, actual->expr); | |
923ab88c | 1309 | tmp = build3_v (COND_EXPR, arrayse.expr, tmp, build_empty_stmt ()); |
6de9cd9a DN |
1310 | |
1311 | gfc_add_block_to_block (&body, &arrayse.pre); | |
1312 | gfc_add_expr_to_block (&body, tmp); | |
1313 | gfc_add_block_to_block (&body, &arrayse.post); | |
1314 | ||
1315 | gfc_trans_scalarizing_loops (&loop, &body); | |
1316 | ||
1317 | gfc_add_block_to_block (&se->pre, &loop.pre); | |
1318 | gfc_add_block_to_block (&se->pre, &loop.post); | |
1319 | gfc_cleanup_loop (&loop); | |
1320 | ||
1321 | se->expr = resvar; | |
1322 | } | |
1323 | ||
1324 | /* Inline implementation of the sum and product intrinsics. */ | |
1325 | static void | |
1326 | gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op) | |
1327 | { | |
1328 | tree resvar; | |
1329 | tree type; | |
1330 | stmtblock_t body; | |
1331 | stmtblock_t block; | |
1332 | tree tmp; | |
1333 | gfc_loopinfo loop; | |
1334 | gfc_actual_arglist *actual; | |
1335 | gfc_ss *arrayss; | |
1336 | gfc_ss *maskss; | |
1337 | gfc_se arrayse; | |
1338 | gfc_se maskse; | |
1339 | gfc_expr *arrayexpr; | |
1340 | gfc_expr *maskexpr; | |
1341 | ||
1342 | if (se->ss) | |
1343 | { | |
1344 | gfc_conv_intrinsic_funcall (se, expr); | |
1345 | return; | |
1346 | } | |
1347 | ||
1348 | type = gfc_typenode_for_spec (&expr->ts); | |
1349 | /* Initialize the result. */ | |
1350 | resvar = gfc_create_var (type, "val"); | |
1351 | if (op == PLUS_EXPR) | |
1352 | tmp = gfc_build_const (type, integer_zero_node); | |
1353 | else | |
1354 | tmp = gfc_build_const (type, integer_one_node); | |
1355 | ||
1356 | gfc_add_modify_expr (&se->pre, resvar, tmp); | |
1357 | ||
1358 | /* Walk the arguments. */ | |
1359 | actual = expr->value.function.actual; | |
1360 | arrayexpr = actual->expr; | |
1361 | arrayss = gfc_walk_expr (arrayexpr); | |
6e45f57b | 1362 | gcc_assert (arrayss != gfc_ss_terminator); |
6de9cd9a DN |
1363 | |
1364 | actual = actual->next->next; | |
6e45f57b | 1365 | gcc_assert (actual); |
6de9cd9a DN |
1366 | maskexpr = actual->expr; |
1367 | if (maskexpr) | |
1368 | { | |
1369 | maskss = gfc_walk_expr (maskexpr); | |
6e45f57b | 1370 | gcc_assert (maskss != gfc_ss_terminator); |
6de9cd9a DN |
1371 | } |
1372 | else | |
1373 | maskss = NULL; | |
1374 | ||
1375 | /* Initialize the scalarizer. */ | |
1376 | gfc_init_loopinfo (&loop); | |
1377 | gfc_add_ss_to_loop (&loop, arrayss); | |
1378 | if (maskss) | |
1379 | gfc_add_ss_to_loop (&loop, maskss); | |
1380 | ||
1381 | /* Initialize the loop. */ | |
1382 | gfc_conv_ss_startstride (&loop); | |
1383 | gfc_conv_loop_setup (&loop); | |
1384 | ||
1385 | gfc_mark_ss_chain_used (arrayss, 1); | |
1386 | if (maskss) | |
1387 | gfc_mark_ss_chain_used (maskss, 1); | |
1388 | /* Generate the loop body. */ | |
1389 | gfc_start_scalarized_body (&loop, &body); | |
1390 | ||
1391 | /* If we have a mask, only add this element if the mask is set. */ | |
1392 | if (maskss) | |
1393 | { | |
1394 | gfc_init_se (&maskse, NULL); | |
1395 | gfc_copy_loopinfo_to_se (&maskse, &loop); | |
1396 | maskse.ss = maskss; | |
1397 | gfc_conv_expr_val (&maskse, maskexpr); | |
1398 | gfc_add_block_to_block (&body, &maskse.pre); | |
1399 | ||
1400 | gfc_start_block (&block); | |
1401 | } | |
1402 | else | |
1403 | gfc_init_block (&block); | |
1404 | ||
1405 | /* Do the actual summation/product. */ | |
1406 | gfc_init_se (&arrayse, NULL); | |
1407 | gfc_copy_loopinfo_to_se (&arrayse, &loop); | |
1408 | arrayse.ss = arrayss; | |
1409 | gfc_conv_expr_val (&arrayse, arrayexpr); | |
1410 | gfc_add_block_to_block (&block, &arrayse.pre); | |
1411 | ||
923ab88c | 1412 | tmp = build2 (op, type, resvar, arrayse.expr); |
6de9cd9a DN |
1413 | gfc_add_modify_expr (&block, resvar, tmp); |
1414 | gfc_add_block_to_block (&block, &arrayse.post); | |
1415 | ||
1416 | if (maskss) | |
1417 | { | |
1418 | /* We enclose the above in if (mask) {...} . */ | |
1419 | tmp = gfc_finish_block (&block); | |
1420 | ||
923ab88c | 1421 | tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ()); |
6de9cd9a DN |
1422 | } |
1423 | else | |
1424 | tmp = gfc_finish_block (&block); | |
1425 | gfc_add_expr_to_block (&body, tmp); | |
1426 | ||
1427 | gfc_trans_scalarizing_loops (&loop, &body); | |
1428 | gfc_add_block_to_block (&se->pre, &loop.pre); | |
1429 | gfc_add_block_to_block (&se->pre, &loop.post); | |
1430 | gfc_cleanup_loop (&loop); | |
1431 | ||
1432 | se->expr = resvar; | |
1433 | } | |
1434 | ||
1435 | static void | |
1436 | gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op) | |
1437 | { | |
1438 | stmtblock_t body; | |
1439 | stmtblock_t block; | |
1440 | stmtblock_t ifblock; | |
1441 | tree limit; | |
1442 | tree type; | |
1443 | tree tmp; | |
1444 | tree ifbody; | |
1445 | tree cond; | |
1446 | gfc_loopinfo loop; | |
1447 | gfc_actual_arglist *actual; | |
1448 | gfc_ss *arrayss; | |
1449 | gfc_ss *maskss; | |
1450 | gfc_se arrayse; | |
1451 | gfc_se maskse; | |
1452 | gfc_expr *arrayexpr; | |
1453 | gfc_expr *maskexpr; | |
1454 | tree pos; | |
1455 | int n; | |
1456 | ||
1457 | if (se->ss) | |
1458 | { | |
1459 | gfc_conv_intrinsic_funcall (se, expr); | |
1460 | return; | |
1461 | } | |
1462 | ||
1463 | /* Initialize the result. */ | |
1464 | pos = gfc_create_var (gfc_array_index_type, "pos"); | |
1465 | type = gfc_typenode_for_spec (&expr->ts); | |
1466 | ||
1467 | /* Walk the arguments. */ | |
1468 | actual = expr->value.function.actual; | |
1469 | arrayexpr = actual->expr; | |
1470 | arrayss = gfc_walk_expr (arrayexpr); | |
6e45f57b | 1471 | gcc_assert (arrayss != gfc_ss_terminator); |
6de9cd9a DN |
1472 | |
1473 | actual = actual->next->next; | |
6e45f57b | 1474 | gcc_assert (actual); |
6de9cd9a DN |
1475 | maskexpr = actual->expr; |
1476 | if (maskexpr) | |
1477 | { | |
1478 | maskss = gfc_walk_expr (maskexpr); | |
6e45f57b | 1479 | gcc_assert (maskss != gfc_ss_terminator); |
6de9cd9a DN |
1480 | } |
1481 | else | |
1482 | maskss = NULL; | |
1483 | ||
1484 | limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit"); | |
e7a2d5fb | 1485 | n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false); |
6de9cd9a DN |
1486 | switch (arrayexpr->ts.type) |
1487 | { | |
1488 | case BT_REAL: | |
f8e566e5 | 1489 | tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind); |
6de9cd9a DN |
1490 | break; |
1491 | ||
1492 | case BT_INTEGER: | |
1493 | tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, | |
1494 | arrayexpr->ts.kind); | |
1495 | break; | |
1496 | ||
1497 | default: | |
6e45f57b | 1498 | gcc_unreachable (); |
6de9cd9a DN |
1499 | } |
1500 | ||
1501 | /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval. */ | |
1502 | if (op == GT_EXPR) | |
10c7a96f | 1503 | tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp); |
6de9cd9a DN |
1504 | gfc_add_modify_expr (&se->pre, limit, tmp); |
1505 | ||
1506 | /* Initialize the scalarizer. */ | |
1507 | gfc_init_loopinfo (&loop); | |
1508 | gfc_add_ss_to_loop (&loop, arrayss); | |
1509 | if (maskss) | |
1510 | gfc_add_ss_to_loop (&loop, maskss); | |
1511 | ||
1512 | /* Initialize the loop. */ | |
1513 | gfc_conv_ss_startstride (&loop); | |
1514 | gfc_conv_loop_setup (&loop); | |
1515 | ||
6e45f57b | 1516 | gcc_assert (loop.dimen == 1); |
6de9cd9a DN |
1517 | |
1518 | /* Initialize the position to the first element. If the array has zero | |
1519 | size we need to return zero. Otherwise use the first element of the | |
1520 | array, in case all elements are equal to the limit. | |
13795658 | 1521 | i.e. pos = (ubound >= lbound) ? lbound, lbound - 1; */ |
10c7a96f SB |
1522 | tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, |
1523 | loop.from[0], gfc_index_one_node); | |
1524 | cond = fold_build2 (GE_EXPR, boolean_type_node, | |
1525 | loop.to[0], loop.from[0]); | |
1526 | tmp = fold_build3 (COND_EXPR, gfc_array_index_type, cond, | |
1527 | loop.from[0], tmp); | |
6de9cd9a | 1528 | gfc_add_modify_expr (&loop.pre, pos, tmp); |
b36cd00b | 1529 | |
6de9cd9a DN |
1530 | gfc_mark_ss_chain_used (arrayss, 1); |
1531 | if (maskss) | |
1532 | gfc_mark_ss_chain_used (maskss, 1); | |
1533 | /* Generate the loop body. */ | |
1534 | gfc_start_scalarized_body (&loop, &body); | |
1535 | ||
1536 | /* If we have a mask, only check this element if the mask is set. */ | |
1537 | if (maskss) | |
1538 | { | |
1539 | gfc_init_se (&maskse, NULL); | |
1540 | gfc_copy_loopinfo_to_se (&maskse, &loop); | |
1541 | maskse.ss = maskss; | |
1542 | gfc_conv_expr_val (&maskse, maskexpr); | |
1543 | gfc_add_block_to_block (&body, &maskse.pre); | |
1544 | ||
1545 | gfc_start_block (&block); | |
1546 | } | |
1547 | else | |
1548 | gfc_init_block (&block); | |
1549 | ||
1550 | /* Compare with the current limit. */ | |
1551 | gfc_init_se (&arrayse, NULL); | |
1552 | gfc_copy_loopinfo_to_se (&arrayse, &loop); | |
1553 | arrayse.ss = arrayss; | |
1554 | gfc_conv_expr_val (&arrayse, arrayexpr); | |
1555 | gfc_add_block_to_block (&block, &arrayse.pre); | |
1556 | ||
1557 | /* We do the following if this is a more extreme value. */ | |
1558 | gfc_start_block (&ifblock); | |
1559 | ||
1560 | /* Assign the value to the limit... */ | |
1561 | gfc_add_modify_expr (&ifblock, limit, arrayse.expr); | |
1562 | ||
1563 | /* Remember where we are. */ | |
1564 | gfc_add_modify_expr (&ifblock, pos, loop.loopvar[0]); | |
1565 | ||
1566 | ifbody = gfc_finish_block (&ifblock); | |
1567 | ||
1568 | /* If it is a more extreme value. */ | |
923ab88c TS |
1569 | tmp = build2 (op, boolean_type_node, arrayse.expr, limit); |
1570 | tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ()); | |
6de9cd9a DN |
1571 | gfc_add_expr_to_block (&block, tmp); |
1572 | ||
1573 | if (maskss) | |
1574 | { | |
1575 | /* We enclose the above in if (mask) {...}. */ | |
1576 | tmp = gfc_finish_block (&block); | |
1577 | ||
923ab88c | 1578 | tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ()); |
6de9cd9a DN |
1579 | } |
1580 | else | |
1581 | tmp = gfc_finish_block (&block); | |
1582 | gfc_add_expr_to_block (&body, tmp); | |
1583 | ||
1584 | gfc_trans_scalarizing_loops (&loop, &body); | |
1585 | ||
1586 | gfc_add_block_to_block (&se->pre, &loop.pre); | |
1587 | gfc_add_block_to_block (&se->pre, &loop.post); | |
1588 | gfc_cleanup_loop (&loop); | |
1589 | ||
1590 | /* Return a value in the range 1..SIZE(array). */ | |
10c7a96f SB |
1591 | tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, loop.from[0], |
1592 | gfc_index_one_node); | |
1593 | tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, pos, tmp); | |
6de9cd9a DN |
1594 | /* And convert to the required type. */ |
1595 | se->expr = convert (type, tmp); | |
1596 | } | |
1597 | ||
1598 | static void | |
1599 | gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op) | |
1600 | { | |
1601 | tree limit; | |
1602 | tree type; | |
1603 | tree tmp; | |
1604 | tree ifbody; | |
1605 | stmtblock_t body; | |
1606 | stmtblock_t block; | |
1607 | gfc_loopinfo loop; | |
1608 | gfc_actual_arglist *actual; | |
1609 | gfc_ss *arrayss; | |
1610 | gfc_ss *maskss; | |
1611 | gfc_se arrayse; | |
1612 | gfc_se maskse; | |
1613 | gfc_expr *arrayexpr; | |
1614 | gfc_expr *maskexpr; | |
1615 | int n; | |
1616 | ||
1617 | if (se->ss) | |
1618 | { | |
1619 | gfc_conv_intrinsic_funcall (se, expr); | |
1620 | return; | |
1621 | } | |
1622 | ||
1623 | type = gfc_typenode_for_spec (&expr->ts); | |
1624 | /* Initialize the result. */ | |
1625 | limit = gfc_create_var (type, "limit"); | |
e7a2d5fb | 1626 | n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false); |
6de9cd9a DN |
1627 | switch (expr->ts.type) |
1628 | { | |
1629 | case BT_REAL: | |
f8e566e5 | 1630 | tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind); |
6de9cd9a DN |
1631 | break; |
1632 | ||
1633 | case BT_INTEGER: | |
1634 | tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind); | |
1635 | break; | |
1636 | ||
1637 | default: | |
6e45f57b | 1638 | gcc_unreachable (); |
6de9cd9a DN |
1639 | } |
1640 | ||
1641 | /* Most negative(-HUGE) for maxval, most positive (-HUGE) for minval. */ | |
1642 | if (op == GT_EXPR) | |
10c7a96f | 1643 | tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp); |
6de9cd9a DN |
1644 | gfc_add_modify_expr (&se->pre, limit, tmp); |
1645 | ||
1646 | /* Walk the arguments. */ | |
1647 | actual = expr->value.function.actual; | |
1648 | arrayexpr = actual->expr; | |
1649 | arrayss = gfc_walk_expr (arrayexpr); | |
6e45f57b | 1650 | gcc_assert (arrayss != gfc_ss_terminator); |
6de9cd9a DN |
1651 | |
1652 | actual = actual->next->next; | |
6e45f57b | 1653 | gcc_assert (actual); |
6de9cd9a DN |
1654 | maskexpr = actual->expr; |
1655 | if (maskexpr) | |
1656 | { | |
1657 | maskss = gfc_walk_expr (maskexpr); | |
6e45f57b | 1658 | gcc_assert (maskss != gfc_ss_terminator); |
6de9cd9a DN |
1659 | } |
1660 | else | |
1661 | maskss = NULL; | |
1662 | ||
1663 | /* Initialize the scalarizer. */ | |
1664 | gfc_init_loopinfo (&loop); | |
1665 | gfc_add_ss_to_loop (&loop, arrayss); | |
1666 | if (maskss) | |
1667 | gfc_add_ss_to_loop (&loop, maskss); | |
1668 | ||
1669 | /* Initialize the loop. */ | |
1670 | gfc_conv_ss_startstride (&loop); | |
1671 | gfc_conv_loop_setup (&loop); | |
1672 | ||
1673 | gfc_mark_ss_chain_used (arrayss, 1); | |
1674 | if (maskss) | |
1675 | gfc_mark_ss_chain_used (maskss, 1); | |
1676 | /* Generate the loop body. */ | |
1677 | gfc_start_scalarized_body (&loop, &body); | |
1678 | ||
1679 | /* If we have a mask, only add this element if the mask is set. */ | |
1680 | if (maskss) | |
1681 | { | |
1682 | gfc_init_se (&maskse, NULL); | |
1683 | gfc_copy_loopinfo_to_se (&maskse, &loop); | |
1684 | maskse.ss = maskss; | |
1685 | gfc_conv_expr_val (&maskse, maskexpr); | |
1686 | gfc_add_block_to_block (&body, &maskse.pre); | |
1687 | ||
1688 | gfc_start_block (&block); | |
1689 | } | |
1690 | else | |
1691 | gfc_init_block (&block); | |
1692 | ||
1693 | /* Compare with the current limit. */ | |
1694 | gfc_init_se (&arrayse, NULL); | |
1695 | gfc_copy_loopinfo_to_se (&arrayse, &loop); | |
1696 | arrayse.ss = arrayss; | |
1697 | gfc_conv_expr_val (&arrayse, arrayexpr); | |
1698 | gfc_add_block_to_block (&block, &arrayse.pre); | |
1699 | ||
1700 | /* Assign the value to the limit... */ | |
923ab88c | 1701 | ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr); |
6de9cd9a DN |
1702 | |
1703 | /* If it is a more extreme value. */ | |
923ab88c TS |
1704 | tmp = build2 (op, boolean_type_node, arrayse.expr, limit); |
1705 | tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ()); | |
6de9cd9a DN |
1706 | gfc_add_expr_to_block (&block, tmp); |
1707 | gfc_add_block_to_block (&block, &arrayse.post); | |
1708 | ||
1709 | tmp = gfc_finish_block (&block); | |
1710 | if (maskss) | |
923ab88c TS |
1711 | /* We enclose the above in if (mask) {...}. */ |
1712 | tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ()); | |
6de9cd9a DN |
1713 | gfc_add_expr_to_block (&body, tmp); |
1714 | ||
1715 | gfc_trans_scalarizing_loops (&loop, &body); | |
1716 | ||
1717 | gfc_add_block_to_block (&se->pre, &loop.pre); | |
1718 | gfc_add_block_to_block (&se->pre, &loop.post); | |
1719 | gfc_cleanup_loop (&loop); | |
1720 | ||
1721 | se->expr = limit; | |
1722 | } | |
1723 | ||
1724 | /* BTEST (i, pos) = (i & (1 << pos)) != 0. */ | |
1725 | static void | |
1726 | gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr) | |
1727 | { | |
1728 | tree arg; | |
1729 | tree arg2; | |
1730 | tree type; | |
1731 | tree tmp; | |
1732 | ||
1733 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
1734 | arg2 = TREE_VALUE (TREE_CHAIN (arg)); | |
1735 | arg = TREE_VALUE (arg); | |
1736 | type = TREE_TYPE (arg); | |
1737 | ||
e805a599 | 1738 | tmp = build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), arg2); |
923ab88c | 1739 | tmp = build2 (BIT_AND_EXPR, type, arg, tmp); |
10c7a96f SB |
1740 | tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp, |
1741 | build_int_cst (type, 0)); | |
6de9cd9a DN |
1742 | type = gfc_typenode_for_spec (&expr->ts); |
1743 | se->expr = convert (type, tmp); | |
1744 | } | |
1745 | ||
1746 | /* Generate code to perform the specified operation. */ | |
1747 | static void | |
1748 | gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op) | |
1749 | { | |
1750 | tree arg; | |
1751 | tree arg2; | |
1752 | tree type; | |
1753 | ||
1754 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
1755 | arg2 = TREE_VALUE (TREE_CHAIN (arg)); | |
1756 | arg = TREE_VALUE (arg); | |
1757 | type = TREE_TYPE (arg); | |
1758 | ||
10c7a96f | 1759 | se->expr = fold_build2 (op, type, arg, arg2); |
6de9cd9a DN |
1760 | } |
1761 | ||
1762 | /* Bitwise not. */ | |
1763 | static void | |
1764 | gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr) | |
1765 | { | |
1766 | tree arg; | |
1767 | ||
1768 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
1769 | arg = TREE_VALUE (arg); | |
1770 | ||
1771 | se->expr = build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg); | |
1772 | } | |
1773 | ||
1774 | /* Set or clear a single bit. */ | |
1775 | static void | |
1776 | gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set) | |
1777 | { | |
1778 | tree arg; | |
1779 | tree arg2; | |
1780 | tree type; | |
1781 | tree tmp; | |
1782 | int op; | |
1783 | ||
1784 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
1785 | arg2 = TREE_VALUE (TREE_CHAIN (arg)); | |
1786 | arg = TREE_VALUE (arg); | |
1787 | type = TREE_TYPE (arg); | |
1788 | ||
10c7a96f | 1789 | tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), arg2); |
6de9cd9a DN |
1790 | if (set) |
1791 | op = BIT_IOR_EXPR; | |
1792 | else | |
1793 | { | |
1794 | op = BIT_AND_EXPR; | |
10c7a96f | 1795 | tmp = fold_build1 (BIT_NOT_EXPR, type, tmp); |
6de9cd9a | 1796 | } |
10c7a96f | 1797 | se->expr = fold_build2 (op, type, arg, tmp); |
6de9cd9a DN |
1798 | } |
1799 | ||
1800 | /* Extract a sequence of bits. | |
1801 | IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */ | |
1802 | static void | |
1803 | gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr) | |
1804 | { | |
1805 | tree arg; | |
1806 | tree arg2; | |
1807 | tree arg3; | |
1808 | tree type; | |
1809 | tree tmp; | |
1810 | tree mask; | |
1811 | ||
1812 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
1813 | arg2 = TREE_CHAIN (arg); | |
1814 | arg3 = TREE_VALUE (TREE_CHAIN (arg2)); | |
1815 | arg = TREE_VALUE (arg); | |
1816 | arg2 = TREE_VALUE (arg2); | |
1817 | type = TREE_TYPE (arg); | |
1818 | ||
7d60be94 | 1819 | mask = build_int_cst (NULL_TREE, -1); |
923ab88c | 1820 | mask = build2 (LSHIFT_EXPR, type, mask, arg3); |
6de9cd9a DN |
1821 | mask = build1 (BIT_NOT_EXPR, type, mask); |
1822 | ||
923ab88c | 1823 | tmp = build2 (RSHIFT_EXPR, type, arg, arg2); |
6de9cd9a | 1824 | |
10c7a96f | 1825 | se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask); |
6de9cd9a DN |
1826 | } |
1827 | ||
56746a07 TS |
1828 | /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i)) |
1829 | ? 0 | |
1830 | : ((shift >= 0) ? i << shift : i >> -shift) | |
1831 | where all shifts are logical shifts. */ | |
6de9cd9a DN |
1832 | static void |
1833 | gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr) | |
1834 | { | |
1835 | tree arg; | |
1836 | tree arg2; | |
1837 | tree type; | |
56746a07 | 1838 | tree utype; |
6de9cd9a | 1839 | tree tmp; |
56746a07 TS |
1840 | tree width; |
1841 | tree num_bits; | |
1842 | tree cond; | |
6de9cd9a DN |
1843 | tree lshift; |
1844 | tree rshift; | |
1845 | ||
1846 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
1847 | arg2 = TREE_VALUE (TREE_CHAIN (arg)); | |
1848 | arg = TREE_VALUE (arg); | |
1849 | type = TREE_TYPE (arg); | |
56746a07 | 1850 | utype = gfc_unsigned_type (type); |
6de9cd9a | 1851 | |
10c7a96f | 1852 | width = fold_build1 (ABS_EXPR, TREE_TYPE (arg2), arg2); |
6de9cd9a | 1853 | |
56746a07 | 1854 | /* Left shift if positive. */ |
10c7a96f | 1855 | lshift = fold_build2 (LSHIFT_EXPR, type, arg, width); |
56746a07 | 1856 | |
de46b505 TS |
1857 | /* Right shift if negative. |
1858 | We convert to an unsigned type because we want a logical shift. | |
1859 | The standard doesn't define the case of shifting negative | |
1860 | numbers, and we try to be compatible with other compilers, most | |
1861 | notably g77, here. */ | |
1862 | rshift = fold_convert (type, build2 (RSHIFT_EXPR, utype, | |
f1b19062 | 1863 | convert (utype, arg), width)); |
56746a07 | 1864 | |
10c7a96f SB |
1865 | tmp = fold_build2 (GE_EXPR, boolean_type_node, arg2, |
1866 | build_int_cst (TREE_TYPE (arg2), 0)); | |
1867 | tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift); | |
56746a07 TS |
1868 | |
1869 | /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas | |
1870 | gcc requires a shift width < BIT_SIZE(I), so we have to catch this | |
1871 | special case. */ | |
de46b505 | 1872 | num_bits = build_int_cst (TREE_TYPE (arg2), TYPE_PRECISION (type)); |
10c7a96f | 1873 | cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits); |
56746a07 | 1874 | |
10c7a96f SB |
1875 | se->expr = fold_build3 (COND_EXPR, type, cond, |
1876 | build_int_cst (type, 0), tmp); | |
6de9cd9a DN |
1877 | } |
1878 | ||
1879 | /* Circular shift. AKA rotate or barrel shift. */ | |
1880 | static void | |
1881 | gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr) | |
1882 | { | |
1883 | tree arg; | |
1884 | tree arg2; | |
1885 | tree arg3; | |
1886 | tree type; | |
1887 | tree tmp; | |
1888 | tree lrot; | |
1889 | tree rrot; | |
e805a599 | 1890 | tree zero; |
6de9cd9a DN |
1891 | |
1892 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
1893 | arg2 = TREE_CHAIN (arg); | |
1894 | arg3 = TREE_CHAIN (arg2); | |
1895 | if (arg3) | |
1896 | { | |
1897 | /* Use a library function for the 3 parameter version. */ | |
56746a07 TS |
1898 | tree int4type = gfc_get_int_type (4); |
1899 | ||
6de9cd9a | 1900 | type = TREE_TYPE (TREE_VALUE (arg)); |
56746a07 TS |
1901 | /* We convert the first argument to at least 4 bytes, and |
1902 | convert back afterwards. This removes the need for library | |
1903 | functions for all argument sizes, and function will be | |
1904 | aligned to at least 32 bits, so there's no loss. */ | |
1905 | if (expr->ts.kind < 4) | |
1906 | { | |
1907 | tmp = convert (int4type, TREE_VALUE (arg)); | |
1908 | TREE_VALUE (arg) = tmp; | |
1909 | } | |
1910 | /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would | |
1911 | need loads of library functions. They cannot have values > | |
1912 | BIT_SIZE (I) so the conversion is safe. */ | |
1913 | TREE_VALUE (arg2) = convert (int4type, TREE_VALUE (arg2)); | |
1914 | TREE_VALUE (arg3) = convert (int4type, TREE_VALUE (arg3)); | |
6de9cd9a DN |
1915 | |
1916 | switch (expr->ts.kind) | |
1917 | { | |
56746a07 TS |
1918 | case 1: |
1919 | case 2: | |
6de9cd9a DN |
1920 | case 4: |
1921 | tmp = gfor_fndecl_math_ishftc4; | |
1922 | break; | |
1923 | case 8: | |
1924 | tmp = gfor_fndecl_math_ishftc8; | |
1925 | break; | |
644cb69f FXC |
1926 | case 16: |
1927 | tmp = gfor_fndecl_math_ishftc16; | |
1928 | break; | |
6de9cd9a | 1929 | default: |
6e45f57b | 1930 | gcc_unreachable (); |
6de9cd9a DN |
1931 | } |
1932 | se->expr = gfc_build_function_call (tmp, arg); | |
56746a07 TS |
1933 | /* Convert the result back to the original type, if we extended |
1934 | the first argument's width above. */ | |
1935 | if (expr->ts.kind < 4) | |
1936 | se->expr = convert (type, se->expr); | |
1937 | ||
6de9cd9a DN |
1938 | return; |
1939 | } | |
1940 | arg = TREE_VALUE (arg); | |
1941 | arg2 = TREE_VALUE (arg2); | |
1942 | type = TREE_TYPE (arg); | |
1943 | ||
1944 | /* Rotate left if positive. */ | |
10c7a96f | 1945 | lrot = fold_build2 (LROTATE_EXPR, type, arg, arg2); |
6de9cd9a DN |
1946 | |
1947 | /* Rotate right if negative. */ | |
10c7a96f SB |
1948 | tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2); |
1949 | rrot = fold_build2 (RROTATE_EXPR, type, arg, tmp); | |
6de9cd9a | 1950 | |
e805a599 | 1951 | zero = build_int_cst (TREE_TYPE (arg2), 0); |
10c7a96f SB |
1952 | tmp = fold_build2 (GT_EXPR, boolean_type_node, arg2, zero); |
1953 | rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot); | |
6de9cd9a DN |
1954 | |
1955 | /* Do nothing if shift == 0. */ | |
10c7a96f SB |
1956 | tmp = fold_build2 (EQ_EXPR, boolean_type_node, arg2, zero); |
1957 | se->expr = fold_build3 (COND_EXPR, type, tmp, arg, rrot); | |
6de9cd9a DN |
1958 | } |
1959 | ||
1960 | /* The length of a character string. */ | |
1961 | static void | |
1962 | gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr) | |
1963 | { | |
1964 | tree len; | |
1965 | tree type; | |
1966 | tree decl; | |
1967 | gfc_symbol *sym; | |
1968 | gfc_se argse; | |
1969 | gfc_expr *arg; | |
1970 | ||
6e45f57b | 1971 | gcc_assert (!se->ss); |
6de9cd9a DN |
1972 | |
1973 | arg = expr->value.function.actual->expr; | |
1974 | ||
1975 | type = gfc_typenode_for_spec (&expr->ts); | |
1976 | switch (arg->expr_type) | |
1977 | { | |
1978 | case EXPR_CONSTANT: | |
7d60be94 | 1979 | len = build_int_cst (NULL_TREE, arg->value.character.length); |
6de9cd9a DN |
1980 | break; |
1981 | ||
1982 | default: | |
b36cd00b TS |
1983 | if (arg->expr_type == EXPR_VARIABLE |
1984 | && (arg->ref == NULL || (arg->ref->next == NULL | |
f51d8522 | 1985 | && arg->ref->type == REF_ARRAY))) |
6de9cd9a | 1986 | { |
b36cd00b | 1987 | /* This doesn't catch all cases. |
7031baf4 TS |
1988 | See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html |
1989 | and the surrounding thread. */ | |
6de9cd9a DN |
1990 | sym = arg->symtree->n.sym; |
1991 | decl = gfc_get_symbol_decl (sym); | |
1992 | if (decl == current_function_decl && sym->attr.function | |
1993 | && (sym->result == sym)) | |
1994 | decl = gfc_get_fake_result_decl (sym); | |
1995 | ||
1996 | len = sym->ts.cl->backend_decl; | |
6e45f57b | 1997 | gcc_assert (len); |
6de9cd9a DN |
1998 | } |
1999 | else | |
2000 | { | |
2001 | /* Anybody stupid enough to do this deserves inefficient code. */ | |
2002 | gfc_init_se (&argse, se); | |
2003 | gfc_conv_expr (&argse, arg); | |
2004 | gfc_add_block_to_block (&se->pre, &argse.pre); | |
2005 | gfc_add_block_to_block (&se->post, &argse.post); | |
2006 | len = argse.string_length; | |
2007 | } | |
2008 | break; | |
2009 | } | |
2010 | se->expr = convert (type, len); | |
2011 | } | |
2012 | ||
2013 | /* The length of a character string not including trailing blanks. */ | |
2014 | static void | |
2015 | gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr) | |
2016 | { | |
2017 | tree args; | |
2018 | tree type; | |
2019 | ||
2020 | args = gfc_conv_intrinsic_function_args (se, expr); | |
2021 | type = gfc_typenode_for_spec (&expr->ts); | |
2022 | se->expr = gfc_build_function_call (gfor_fndecl_string_len_trim, args); | |
2023 | se->expr = convert (type, se->expr); | |
2024 | } | |
2025 | ||
2026 | ||
2027 | /* Returns the starting position of a substring within a string. */ | |
2028 | ||
2029 | static void | |
2030 | gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr) | |
2031 | { | |
0da87370 | 2032 | tree logical4_type_node = gfc_get_logical_type (4); |
6de9cd9a DN |
2033 | tree args; |
2034 | tree back; | |
2035 | tree type; | |
2036 | tree tmp; | |
2037 | ||
2038 | args = gfc_conv_intrinsic_function_args (se, expr); | |
2039 | type = gfc_typenode_for_spec (&expr->ts); | |
2040 | tmp = gfc_advance_chain (args, 3); | |
2041 | if (TREE_CHAIN (tmp) == NULL_TREE) | |
2042 | { | |
0da87370 TS |
2043 | back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0), |
2044 | NULL_TREE); | |
6de9cd9a DN |
2045 | TREE_CHAIN (tmp) = back; |
2046 | } | |
2047 | else | |
2048 | { | |
2049 | back = TREE_CHAIN (tmp); | |
0da87370 | 2050 | TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back)); |
6de9cd9a DN |
2051 | } |
2052 | ||
2053 | se->expr = gfc_build_function_call (gfor_fndecl_string_index, args); | |
2054 | se->expr = convert (type, se->expr); | |
2055 | } | |
2056 | ||
2057 | /* The ascii value for a single character. */ | |
2058 | static void | |
2059 | gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr) | |
2060 | { | |
2061 | tree arg; | |
2062 | tree type; | |
2063 | ||
2064 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
2065 | arg = TREE_VALUE (TREE_CHAIN (arg)); | |
6e45f57b | 2066 | gcc_assert (POINTER_TYPE_P (TREE_TYPE (arg))); |
6de9cd9a DN |
2067 | arg = build1 (NOP_EXPR, pchar_type_node, arg); |
2068 | type = gfc_typenode_for_spec (&expr->ts); | |
2069 | ||
2070 | se->expr = gfc_build_indirect_ref (arg); | |
2071 | se->expr = convert (type, se->expr); | |
2072 | } | |
2073 | ||
2074 | ||
2075 | /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */ | |
2076 | ||
2077 | static void | |
2078 | gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr) | |
2079 | { | |
2080 | tree arg; | |
2081 | tree tsource; | |
2082 | tree fsource; | |
2083 | tree mask; | |
2084 | tree type; | |
c3d0559d | 2085 | tree len; |
6de9cd9a DN |
2086 | |
2087 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
c3d0559d TS |
2088 | if (expr->ts.type != BT_CHARACTER) |
2089 | { | |
2090 | tsource = TREE_VALUE (arg); | |
2091 | arg = TREE_CHAIN (arg); | |
2092 | fsource = TREE_VALUE (arg); | |
2093 | mask = TREE_VALUE (TREE_CHAIN (arg)); | |
2094 | } | |
2095 | else | |
2096 | { | |
2097 | /* We do the same as in the non-character case, but the argument | |
2098 | list is different because of the string length arguments. We | |
2099 | also have to set the string length for the result. */ | |
2100 | len = TREE_VALUE (arg); | |
2101 | arg = TREE_CHAIN (arg); | |
2102 | tsource = TREE_VALUE (arg); | |
2103 | arg = TREE_CHAIN (TREE_CHAIN (arg)); | |
2104 | fsource = TREE_VALUE (arg); | |
2105 | mask = TREE_VALUE (TREE_CHAIN (arg)); | |
2106 | ||
2107 | se->string_length = len; | |
2108 | } | |
6de9cd9a | 2109 | type = TREE_TYPE (tsource); |
10c7a96f | 2110 | se->expr = fold_build3 (COND_EXPR, type, mask, tsource, fsource); |
6de9cd9a DN |
2111 | } |
2112 | ||
2113 | ||
2114 | static void | |
2115 | gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr) | |
2116 | { | |
2117 | gfc_actual_arglist *actual; | |
2118 | tree args; | |
2119 | tree type; | |
2120 | tree fndecl; | |
2121 | gfc_se argse; | |
2122 | gfc_ss *ss; | |
2123 | ||
2124 | gfc_init_se (&argse, NULL); | |
2125 | actual = expr->value.function.actual; | |
2126 | ||
2127 | ss = gfc_walk_expr (actual->expr); | |
6e45f57b | 2128 | gcc_assert (ss != gfc_ss_terminator); |
6de9cd9a DN |
2129 | argse.want_pointer = 1; |
2130 | gfc_conv_expr_descriptor (&argse, actual->expr, ss); | |
2131 | gfc_add_block_to_block (&se->pre, &argse.pre); | |
2132 | gfc_add_block_to_block (&se->post, &argse.post); | |
2133 | args = gfc_chainon_list (NULL_TREE, argse.expr); | |
2134 | ||
2135 | actual = actual->next; | |
2136 | if (actual->expr) | |
2137 | { | |
2138 | gfc_init_se (&argse, NULL); | |
2139 | gfc_conv_expr_type (&argse, actual->expr, gfc_array_index_type); | |
2140 | gfc_add_block_to_block (&se->pre, &argse.pre); | |
2141 | args = gfc_chainon_list (args, argse.expr); | |
2142 | fndecl = gfor_fndecl_size1; | |
2143 | } | |
2144 | else | |
2145 | fndecl = gfor_fndecl_size0; | |
2146 | ||
2147 | se->expr = gfc_build_function_call (fndecl, args); | |
2148 | type = gfc_typenode_for_spec (&expr->ts); | |
2149 | se->expr = convert (type, se->expr); | |
2150 | } | |
2151 | ||
2152 | ||
2153 | /* Intrinsic string comparison functions. */ | |
2154 | ||
2155 | static void | |
2156 | gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op) | |
2157 | { | |
2158 | tree type; | |
2159 | tree args; | |
2160 | ||
2161 | args = gfc_conv_intrinsic_function_args (se, expr); | |
2162 | /* Build a call for the comparison. */ | |
2163 | se->expr = gfc_build_function_call (gfor_fndecl_compare_string, args); | |
2164 | ||
2165 | type = gfc_typenode_for_spec (&expr->ts); | |
923ab88c | 2166 | se->expr = build2 (op, type, se->expr, |
e805a599 | 2167 | build_int_cst (TREE_TYPE (se->expr), 0)); |
6de9cd9a DN |
2168 | } |
2169 | ||
2170 | /* Generate a call to the adjustl/adjustr library function. */ | |
2171 | static void | |
2172 | gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl) | |
2173 | { | |
2174 | tree args; | |
2175 | tree len; | |
2176 | tree type; | |
2177 | tree var; | |
2178 | tree tmp; | |
2179 | ||
2180 | args = gfc_conv_intrinsic_function_args (se, expr); | |
2181 | len = TREE_VALUE (args); | |
2182 | ||
2183 | type = TREE_TYPE (TREE_VALUE (TREE_CHAIN (args))); | |
2184 | var = gfc_conv_string_tmp (se, type, len); | |
2185 | args = tree_cons (NULL_TREE, var, args); | |
2186 | ||
2187 | tmp = gfc_build_function_call (fndecl, args); | |
2188 | gfc_add_expr_to_block (&se->pre, tmp); | |
2189 | se->expr = var; | |
2190 | se->string_length = len; | |
2191 | } | |
2192 | ||
2193 | ||
2194 | /* Scalar transfer statement. | |
2195 | TRANSFER (source, mold) = *(typeof<mould> *)&source */ | |
2196 | ||
2197 | static void | |
2198 | gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr) | |
2199 | { | |
2200 | gfc_actual_arglist *arg; | |
2201 | gfc_se argse; | |
2202 | tree type; | |
2203 | tree ptr; | |
2204 | gfc_ss *ss; | |
2205 | ||
6e45f57b | 2206 | gcc_assert (!se->ss); |
6de9cd9a DN |
2207 | |
2208 | /* Get a pointer to the source. */ | |
2209 | arg = expr->value.function.actual; | |
2210 | ss = gfc_walk_expr (arg->expr); | |
2211 | gfc_init_se (&argse, NULL); | |
2212 | if (ss == gfc_ss_terminator) | |
2213 | gfc_conv_expr_reference (&argse, arg->expr); | |
2214 | else | |
2215 | gfc_conv_array_parameter (&argse, arg->expr, ss, 1); | |
2216 | gfc_add_block_to_block (&se->pre, &argse.pre); | |
2217 | gfc_add_block_to_block (&se->post, &argse.post); | |
2218 | ptr = argse.expr; | |
2219 | ||
2220 | arg = arg->next; | |
2221 | type = gfc_typenode_for_spec (&expr->ts); | |
2222 | ptr = convert (build_pointer_type (type), ptr); | |
2223 | if (expr->ts.type == BT_CHARACTER) | |
2224 | { | |
2225 | gfc_init_se (&argse, NULL); | |
2226 | gfc_conv_expr (&argse, arg->expr); | |
2227 | gfc_add_block_to_block (&se->pre, &argse.pre); | |
2228 | gfc_add_block_to_block (&se->post, &argse.post); | |
2229 | se->expr = ptr; | |
2230 | se->string_length = argse.string_length; | |
2231 | } | |
2232 | else | |
2233 | { | |
2234 | se->expr = gfc_build_indirect_ref (ptr); | |
2235 | } | |
2236 | } | |
2237 | ||
2238 | ||
2239 | /* Generate code for the ALLOCATED intrinsic. | |
2240 | Generate inline code that directly check the address of the argument. */ | |
2241 | ||
2242 | static void | |
2243 | gfc_conv_allocated (gfc_se *se, gfc_expr *expr) | |
2244 | { | |
2245 | gfc_actual_arglist *arg1; | |
2246 | gfc_se arg1se; | |
2247 | gfc_ss *ss1; | |
2248 | tree tmp; | |
2249 | ||
2250 | gfc_init_se (&arg1se, NULL); | |
2251 | arg1 = expr->value.function.actual; | |
2252 | ss1 = gfc_walk_expr (arg1->expr); | |
2253 | arg1se.descriptor_only = 1; | |
2254 | gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1); | |
2255 | ||
4c73896d | 2256 | tmp = gfc_conv_descriptor_data_get (arg1se.expr); |
923ab88c TS |
2257 | tmp = build2 (NE_EXPR, boolean_type_node, tmp, |
2258 | fold_convert (TREE_TYPE (tmp), null_pointer_node)); | |
6de9cd9a DN |
2259 | se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp); |
2260 | } | |
2261 | ||
2262 | ||
2263 | /* Generate code for the ASSOCIATED intrinsic. | |
2264 | If both POINTER and TARGET are arrays, generate a call to library function | |
2265 | _gfor_associated, and pass descriptors of POINTER and TARGET to it. | |
2266 | In other cases, generate inline code that directly compare the address of | |
2267 | POINTER with the address of TARGET. */ | |
2268 | ||
2269 | static void | |
2270 | gfc_conv_associated (gfc_se *se, gfc_expr *expr) | |
2271 | { | |
2272 | gfc_actual_arglist *arg1; | |
2273 | gfc_actual_arglist *arg2; | |
2274 | gfc_se arg1se; | |
2275 | gfc_se arg2se; | |
2276 | tree tmp2; | |
2277 | tree tmp; | |
2278 | tree args, fndecl; | |
2279 | gfc_ss *ss1, *ss2; | |
2280 | ||
2281 | gfc_init_se (&arg1se, NULL); | |
2282 | gfc_init_se (&arg2se, NULL); | |
2283 | arg1 = expr->value.function.actual; | |
2284 | arg2 = arg1->next; | |
2285 | ss1 = gfc_walk_expr (arg1->expr); | |
2286 | ||
2287 | if (!arg2->expr) | |
2288 | { | |
2289 | /* No optional target. */ | |
2290 | if (ss1 == gfc_ss_terminator) | |
2291 | { | |
2292 | /* A pointer to a scalar. */ | |
2293 | arg1se.want_pointer = 1; | |
2294 | gfc_conv_expr (&arg1se, arg1->expr); | |
2295 | tmp2 = arg1se.expr; | |
2296 | } | |
2297 | else | |
2298 | { | |
2299 | /* A pointer to an array. */ | |
2300 | arg1se.descriptor_only = 1; | |
2301 | gfc_conv_expr_lhs (&arg1se, arg1->expr); | |
4c73896d | 2302 | tmp2 = gfc_conv_descriptor_data_get (arg1se.expr); |
6de9cd9a | 2303 | } |
923ab88c TS |
2304 | tmp = build2 (NE_EXPR, boolean_type_node, tmp2, |
2305 | fold_convert (TREE_TYPE (tmp2), null_pointer_node)); | |
6de9cd9a DN |
2306 | se->expr = tmp; |
2307 | } | |
2308 | else | |
2309 | { | |
2310 | /* An optional target. */ | |
2311 | ss2 = gfc_walk_expr (arg2->expr); | |
2312 | if (ss1 == gfc_ss_terminator) | |
2313 | { | |
2314 | /* A pointer to a scalar. */ | |
6e45f57b | 2315 | gcc_assert (ss2 == gfc_ss_terminator); |
6de9cd9a DN |
2316 | arg1se.want_pointer = 1; |
2317 | gfc_conv_expr (&arg1se, arg1->expr); | |
2318 | arg2se.want_pointer = 1; | |
2319 | gfc_conv_expr (&arg2se, arg2->expr); | |
923ab88c | 2320 | tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr); |
6de9cd9a DN |
2321 | se->expr = tmp; |
2322 | } | |
2323 | else | |
2324 | { | |
2325 | /* A pointer to an array, call library function _gfor_associated. */ | |
6e45f57b | 2326 | gcc_assert (ss2 != gfc_ss_terminator); |
6de9cd9a DN |
2327 | args = NULL_TREE; |
2328 | arg1se.want_pointer = 1; | |
2329 | gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1); | |
2330 | args = gfc_chainon_list (args, arg1se.expr); | |
2331 | arg2se.want_pointer = 1; | |
2332 | gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2); | |
2333 | gfc_add_block_to_block (&se->pre, &arg2se.pre); | |
2334 | gfc_add_block_to_block (&se->post, &arg2se.post); | |
2335 | args = gfc_chainon_list (args, arg2se.expr); | |
2336 | fndecl = gfor_fndecl_associated; | |
2337 | se->expr = gfc_build_function_call (fndecl, args); | |
2338 | } | |
2339 | } | |
2340 | se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr); | |
2341 | } | |
2342 | ||
2343 | ||
f7b529fa | 2344 | /* Scan a string for any one of the characters in a set of characters. */ |
6de9cd9a DN |
2345 | |
2346 | static void | |
2347 | gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr) | |
2348 | { | |
0da87370 | 2349 | tree logical4_type_node = gfc_get_logical_type (4); |
6de9cd9a DN |
2350 | tree args; |
2351 | tree back; | |
2352 | tree type; | |
2353 | tree tmp; | |
2354 | ||
2355 | args = gfc_conv_intrinsic_function_args (se, expr); | |
2356 | type = gfc_typenode_for_spec (&expr->ts); | |
2357 | tmp = gfc_advance_chain (args, 3); | |
2358 | if (TREE_CHAIN (tmp) == NULL_TREE) | |
2359 | { | |
0da87370 TS |
2360 | back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0), |
2361 | NULL_TREE); | |
6de9cd9a DN |
2362 | TREE_CHAIN (tmp) = back; |
2363 | } | |
2364 | else | |
2365 | { | |
2366 | back = TREE_CHAIN (tmp); | |
0da87370 | 2367 | TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back)); |
6de9cd9a DN |
2368 | } |
2369 | ||
2370 | se->expr = gfc_build_function_call (gfor_fndecl_string_scan, args); | |
2371 | se->expr = convert (type, se->expr); | |
2372 | } | |
2373 | ||
2374 | ||
2375 | /* Verify that a set of characters contains all the characters in a string | |
1f2959f0 | 2376 | by identifying the position of the first character in a string of |
6de9cd9a DN |
2377 | characters that does not appear in a given set of characters. */ |
2378 | ||
2379 | static void | |
2380 | gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr) | |
2381 | { | |
0da87370 | 2382 | tree logical4_type_node = gfc_get_logical_type (4); |
6de9cd9a DN |
2383 | tree args; |
2384 | tree back; | |
2385 | tree type; | |
2386 | tree tmp; | |
2387 | ||
2388 | args = gfc_conv_intrinsic_function_args (se, expr); | |
2389 | type = gfc_typenode_for_spec (&expr->ts); | |
2390 | tmp = gfc_advance_chain (args, 3); | |
2391 | if (TREE_CHAIN (tmp) == NULL_TREE) | |
2392 | { | |
0da87370 TS |
2393 | back = tree_cons (NULL_TREE, build_int_cst (logical4_type_node, 0), |
2394 | NULL_TREE); | |
6de9cd9a DN |
2395 | TREE_CHAIN (tmp) = back; |
2396 | } | |
2397 | else | |
2398 | { | |
2399 | back = TREE_CHAIN (tmp); | |
0da87370 | 2400 | TREE_VALUE (back) = convert (logical4_type_node, TREE_VALUE (back)); |
6de9cd9a DN |
2401 | } |
2402 | ||
2403 | se->expr = gfc_build_function_call (gfor_fndecl_string_verify, args); | |
2404 | se->expr = convert (type, se->expr); | |
2405 | } | |
2406 | ||
2407 | /* Prepare components and related information of a real number which is | |
2408 | the first argument of a elemental functions to manipulate reals. */ | |
2409 | ||
b36cd00b TS |
2410 | static void |
2411 | prepare_arg_info (gfc_se * se, gfc_expr * expr, | |
2412 | real_compnt_info * rcs, int all) | |
6de9cd9a DN |
2413 | { |
2414 | tree arg; | |
2415 | tree masktype; | |
2416 | tree tmp; | |
2417 | tree wbits; | |
2418 | tree one; | |
2419 | tree exponent, fraction; | |
2420 | int n; | |
2421 | gfc_expr *a1; | |
2422 | ||
2423 | if (TARGET_FLOAT_FORMAT != IEEE_FLOAT_FORMAT) | |
2424 | gfc_todo_error ("Non-IEEE floating format"); | |
b36cd00b | 2425 | |
6e45f57b | 2426 | gcc_assert (expr->expr_type == EXPR_FUNCTION); |
6de9cd9a DN |
2427 | |
2428 | arg = gfc_conv_intrinsic_function_args (se, expr); | |
2429 | arg = TREE_VALUE (arg); | |
2430 | rcs->type = TREE_TYPE (arg); | |
2431 | ||
2432 | /* Force arg'type to integer by unaffected convert */ | |
2433 | a1 = expr->value.function.actual->expr; | |
2434 | masktype = gfc_get_int_type (a1->ts.kind); | |
2435 | rcs->mtype = masktype; | |
2436 | tmp = build1 (VIEW_CONVERT_EXPR, masktype, arg); | |
2437 | arg = gfc_create_var (masktype, "arg"); | |
2438 | gfc_add_modify_expr(&se->pre, arg, tmp); | |
2439 | rcs->arg = arg; | |
2440 | ||
e7dc5b4f | 2441 | /* Calculate the numbers of bits of exponent, fraction and word */ |
e7a2d5fb | 2442 | n = gfc_validate_kind (a1->ts.type, a1->ts.kind, false); |
7d60be94 | 2443 | tmp = build_int_cst (NULL_TREE, gfc_real_kinds[n].digits - 1); |
6de9cd9a | 2444 | rcs->fdigits = convert (masktype, tmp); |
7d60be94 | 2445 | wbits = build_int_cst (NULL_TREE, TYPE_PRECISION (rcs->type) - 1); |
6de9cd9a | 2446 | wbits = convert (masktype, wbits); |
10c7a96f | 2447 | rcs->edigits = fold_build2 (MINUS_EXPR, masktype, wbits, tmp); |
6de9cd9a DN |
2448 | |
2449 | /* Form masks for exponent/fraction/sign */ | |
2450 | one = gfc_build_const (masktype, integer_one_node); | |
10c7a96f SB |
2451 | rcs->smask = fold_build2 (LSHIFT_EXPR, masktype, one, wbits); |
2452 | rcs->f1 = fold_build2 (LSHIFT_EXPR, masktype, one, rcs->fdigits); | |
2453 | rcs->emask = fold_build2 (MINUS_EXPR, masktype, rcs->smask, rcs->f1); | |
2454 | rcs->fmask = fold_build2 (MINUS_EXPR, masktype, rcs->f1, one); | |
6de9cd9a | 2455 | /* Form bias. */ |
10c7a96f SB |
2456 | tmp = fold_build2 (MINUS_EXPR, masktype, rcs->edigits, one); |
2457 | tmp = fold_build2 (LSHIFT_EXPR, masktype, one, tmp); | |
2458 | rcs->bias = fold_build2 (MINUS_EXPR, masktype, tmp ,one); | |
6de9cd9a DN |
2459 | |
2460 | if (all) | |
b36cd00b TS |
2461 | { |
2462 | /* exponent, and fraction */ | |
2463 | tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->emask); | |
2464 | tmp = build2 (RSHIFT_EXPR, masktype, tmp, rcs->fdigits); | |
2465 | exponent = gfc_create_var (masktype, "exponent"); | |
2466 | gfc_add_modify_expr(&se->pre, exponent, tmp); | |
2467 | rcs->expn = exponent; | |
2468 | ||
2469 | tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->fmask); | |
2470 | fraction = gfc_create_var (masktype, "fraction"); | |
2471 | gfc_add_modify_expr(&se->pre, fraction, tmp); | |
2472 | rcs->frac = fraction; | |
2473 | } | |
6de9cd9a DN |
2474 | } |
2475 | ||
2476 | /* Build a call to __builtin_clz. */ | |
2477 | ||
2478 | static tree | |
2479 | call_builtin_clz (tree result_type, tree op0) | |
2480 | { | |
2481 | tree fn, parms, call; | |
2482 | enum machine_mode op0_mode = TYPE_MODE (TREE_TYPE (op0)); | |
2483 | ||
2484 | if (op0_mode == TYPE_MODE (integer_type_node)) | |
2485 | fn = built_in_decls[BUILT_IN_CLZ]; | |
2486 | else if (op0_mode == TYPE_MODE (long_integer_type_node)) | |
2487 | fn = built_in_decls[BUILT_IN_CLZL]; | |
2488 | else if (op0_mode == TYPE_MODE (long_long_integer_type_node)) | |
2489 | fn = built_in_decls[BUILT_IN_CLZLL]; | |
2490 | else | |
6e45f57b | 2491 | gcc_unreachable (); |
6de9cd9a DN |
2492 | |
2493 | parms = tree_cons (NULL, op0, NULL); | |
2494 | call = gfc_build_function_call (fn, parms); | |
2495 | ||
2496 | return convert (result_type, call); | |
2497 | } | |
2498 | ||
68629d16 | 2499 | |
046dcd57 FW |
2500 | /* Generate code for SPACING (X) intrinsic function. |
2501 | SPACING (X) = POW (2, e-p) | |
2502 | ||
2503 | We generate: | |
b36cd00b | 2504 | |
046dcd57 FW |
2505 | t = expn - fdigits // e - p. |
2506 | res = t << fdigits // Form the exponent. Fraction is zero. | |
2507 | if (t < 0) // The result is out of range. Denormalized case. | |
6de9cd9a | 2508 | res = tiny(X) |
046dcd57 | 2509 | */ |
6de9cd9a DN |
2510 | |
2511 | static void | |
2512 | gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr) | |
2513 | { | |
2514 | tree arg; | |
2515 | tree masktype; | |
2516 | tree tmp, t1, cond; | |
2517 | tree tiny, zero; | |
2518 | tree fdigits; | |
2519 | real_compnt_info rcs; | |
2520 | ||
2521 | prepare_arg_info (se, expr, &rcs, 0); | |
2522 | arg = rcs.arg; | |
2523 | masktype = rcs.mtype; | |
2524 | fdigits = rcs.fdigits; | |
2525 | tiny = rcs.f1; | |
2526 | zero = gfc_build_const (masktype, integer_zero_node); | |
923ab88c TS |
2527 | tmp = build2 (BIT_AND_EXPR, masktype, rcs.emask, arg); |
2528 | tmp = build2 (RSHIFT_EXPR, masktype, tmp, fdigits); | |
2529 | tmp = build2 (MINUS_EXPR, masktype, tmp, fdigits); | |
2530 | cond = build2 (LE_EXPR, boolean_type_node, tmp, zero); | |
2531 | t1 = build2 (LSHIFT_EXPR, masktype, tmp, fdigits); | |
2532 | tmp = build3 (COND_EXPR, masktype, cond, tiny, t1); | |
6de9cd9a DN |
2533 | tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp); |
2534 | ||
2535 | se->expr = tmp; | |
2536 | } | |
2537 | ||
046dcd57 FW |
2538 | /* Generate code for RRSPACING (X) intrinsic function. |
2539 | RRSPACING (X) = |X * POW (2, -e)| * POW (2, p) = |FRACTION (X)| * POW (2, p) | |
2540 | ||
b805ea17 | 2541 | So the result's exponent is p. And if X is normalized, X's fraction part |
046dcd57 FW |
2542 | is the result's fraction. If X is denormalized, to get the X's fraction we |
2543 | shift X's fraction part to left until the first '1' is removed. | |
b36cd00b | 2544 | |
046dcd57 | 2545 | We generate: |
4f9c6b6e TS |
2546 | |
2547 | if (expn == 0 && frac == 0) | |
2548 | res = 0; | |
2549 | else | |
6de9cd9a | 2550 | { |
046dcd57 | 2551 | // edigits is the number of exponent bits. Add the sign bit. |
4f9c6b6e | 2552 | sedigits = edigits + 1; |
046dcd57 FW |
2553 | |
2554 | if (expn == 0) // Denormalized case. | |
4f9c6b6e TS |
2555 | { |
2556 | t1 = leadzero (frac); | |
046dcd57 FW |
2557 | frac = frac << (t1 + 1); //Remove the first '1'. |
2558 | frac = frac >> (sedigits); //Form the fraction. | |
4f9c6b6e | 2559 | } |
046dcd57 FW |
2560 | |
2561 | //fdigits is the number of fraction bits. Form the exponent. | |
2562 | t = bias + fdigits; | |
2563 | ||
2564 | res = (t << fdigits) | frac; | |
2565 | } | |
6de9cd9a DN |
2566 | */ |
2567 | ||
2568 | static void | |
2569 | gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr) | |
2570 | { | |
2571 | tree masktype; | |
4f9c6b6e | 2572 | tree tmp, t1, t2, cond, cond2; |
6de9cd9a DN |
2573 | tree one, zero; |
2574 | tree fdigits, fraction; | |
2575 | real_compnt_info rcs; | |
2576 | ||
2577 | prepare_arg_info (se, expr, &rcs, 1); | |
2578 | masktype = rcs.mtype; | |
2579 | fdigits = rcs.fdigits; | |
2580 | fraction = rcs.frac; | |
2581 | one = gfc_build_const (masktype, integer_one_node); | |
2582 | zero = gfc_build_const (masktype, integer_zero_node); | |
10c7a96f | 2583 | t2 = fold_build2 (PLUS_EXPR, masktype, rcs.edigits, one); |
6de9cd9a DN |
2584 | |
2585 | t1 = call_builtin_clz (masktype, fraction); | |
923ab88c TS |
2586 | tmp = build2 (PLUS_EXPR, masktype, t1, one); |
2587 | tmp = build2 (LSHIFT_EXPR, masktype, fraction, tmp); | |
2588 | tmp = build2 (RSHIFT_EXPR, masktype, tmp, t2); | |
2589 | cond = build2 (EQ_EXPR, boolean_type_node, rcs.expn, zero); | |
2590 | fraction = build3 (COND_EXPR, masktype, cond, tmp, fraction); | |
6de9cd9a | 2591 | |
10c7a96f SB |
2592 | tmp = fold_build2 (PLUS_EXPR, masktype, rcs.bias, fdigits); |
2593 | tmp = fold_build2 (LSHIFT_EXPR, masktype, tmp, fdigits); | |
923ab88c | 2594 | tmp = build2 (BIT_IOR_EXPR, masktype, tmp, fraction); |
6de9cd9a | 2595 | |
923ab88c TS |
2596 | cond2 = build2 (EQ_EXPR, boolean_type_node, rcs.frac, zero); |
2597 | cond = build2 (TRUTH_ANDIF_EXPR, boolean_type_node, cond, cond2); | |
2598 | tmp = build3 (COND_EXPR, masktype, cond, | |
e805a599 | 2599 | build_int_cst (masktype, 0), tmp); |
4f9c6b6e | 2600 | |
6de9cd9a DN |
2601 | tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp); |
2602 | se->expr = tmp; | |
2603 | } | |
2604 | ||
2605 | /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */ | |
2606 | ||
2607 | static void | |
2608 | gfc_conv_intrinsic_si_kind (gfc_se * se, gfc_expr * expr) | |
2609 | { | |
2610 | tree args; | |
2611 | ||
2612 | args = gfc_conv_intrinsic_function_args (se, expr); | |
2613 | args = TREE_VALUE (args); | |
2614 | args = gfc_build_addr_expr (NULL, args); | |
2615 | args = tree_cons (NULL_TREE, args, NULL_TREE); | |
2616 | se->expr = gfc_build_function_call (gfor_fndecl_si_kind, args); | |
2617 | } | |
2618 | ||
2619 | /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */ | |
2620 | ||
2621 | static void | |
2622 | gfc_conv_intrinsic_sr_kind (gfc_se * se, gfc_expr * expr) | |
2623 | { | |
2624 | gfc_actual_arglist *actual; | |
2625 | tree args; | |
2626 | gfc_se argse; | |
2627 | ||
2628 | args = NULL_TREE; | |
2629 | for (actual = expr->value.function.actual; actual; actual = actual->next) | |
2630 | { | |
2631 | gfc_init_se (&argse, se); | |
2632 | ||
2633 | /* Pass a NULL pointer for an absent arg. */ | |
2634 | if (actual->expr == NULL) | |
2635 | argse.expr = null_pointer_node; | |
2636 | else | |
2637 | gfc_conv_expr_reference (&argse, actual->expr); | |
2638 | ||
2639 | gfc_add_block_to_block (&se->pre, &argse.pre); | |
2640 | gfc_add_block_to_block (&se->post, &argse.post); | |
2641 | args = gfc_chainon_list (args, argse.expr); | |
2642 | } | |
2643 | se->expr = gfc_build_function_call (gfor_fndecl_sr_kind, args); | |
2644 | } | |
2645 | ||
2646 | ||
2647 | /* Generate code for TRIM (A) intrinsic function. */ | |
2648 | ||
2649 | static void | |
2650 | gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr) | |
2651 | { | |
e2cad04b | 2652 | tree gfc_int4_type_node = gfc_get_int_type (4); |
6de9cd9a DN |
2653 | tree var; |
2654 | tree len; | |
2655 | tree addr; | |
2656 | tree tmp; | |
2657 | tree arglist; | |
2658 | tree type; | |
2659 | tree cond; | |
2660 | ||
2661 | arglist = NULL_TREE; | |
2662 | ||
2663 | type = build_pointer_type (gfc_character1_type_node); | |
2664 | var = gfc_create_var (type, "pstr"); | |
2665 | addr = gfc_build_addr_expr (ppvoid_type_node, var); | |
2666 | len = gfc_create_var (gfc_int4_type_node, "len"); | |
2667 | ||
2668 | tmp = gfc_conv_intrinsic_function_args (se, expr); | |
2669 | arglist = gfc_chainon_list (arglist, gfc_build_addr_expr (NULL, len)); | |
2670 | arglist = gfc_chainon_list (arglist, addr); | |
2671 | arglist = chainon (arglist, tmp); | |
b36cd00b | 2672 | |
6de9cd9a DN |
2673 | tmp = gfc_build_function_call (gfor_fndecl_string_trim, arglist); |
2674 | gfc_add_expr_to_block (&se->pre, tmp); | |
2675 | ||
2676 | /* Free the temporary afterwards, if necessary. */ | |
923ab88c | 2677 | cond = build2 (GT_EXPR, boolean_type_node, len, |
e805a599 | 2678 | build_int_cst (TREE_TYPE (len), 0)); |
6de9cd9a DN |
2679 | arglist = gfc_chainon_list (NULL_TREE, var); |
2680 | tmp = gfc_build_function_call (gfor_fndecl_internal_free, arglist); | |
923ab88c | 2681 | tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ()); |
6de9cd9a DN |
2682 | gfc_add_expr_to_block (&se->post, tmp); |
2683 | ||
2684 | se->expr = var; | |
2685 | se->string_length = len; | |
2686 | } | |
2687 | ||
2688 | ||
2689 | /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */ | |
2690 | ||
2691 | static void | |
2692 | gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr) | |
2693 | { | |
e2cad04b | 2694 | tree gfc_int4_type_node = gfc_get_int_type (4); |
6de9cd9a DN |
2695 | tree tmp; |
2696 | tree len; | |
2697 | tree args; | |
2698 | tree arglist; | |
2699 | tree ncopies; | |
2700 | tree var; | |
2701 | tree type; | |
2702 | ||
2703 | args = gfc_conv_intrinsic_function_args (se, expr); | |
2704 | len = TREE_VALUE (args); | |
2705 | tmp = gfc_advance_chain (args, 2); | |
2706 | ncopies = TREE_VALUE (tmp); | |
10c7a96f | 2707 | len = fold_build2 (MULT_EXPR, gfc_int4_type_node, len, ncopies); |
6de9cd9a DN |
2708 | type = gfc_get_character_type (expr->ts.kind, expr->ts.cl); |
2709 | var = gfc_conv_string_tmp (se, build_pointer_type (type), len); | |
2710 | ||
2711 | arglist = NULL_TREE; | |
2712 | arglist = gfc_chainon_list (arglist, var); | |
2713 | arglist = chainon (arglist, args); | |
2714 | tmp = gfc_build_function_call (gfor_fndecl_string_repeat, arglist); | |
2715 | gfc_add_expr_to_block (&se->pre, tmp); | |
2716 | ||
2717 | se->expr = var; | |
2718 | se->string_length = len; | |
2719 | } | |
2720 | ||
2721 | ||
d436d3de | 2722 | /* Generate code for the IARGC intrinsic. */ |
b41b2534 JB |
2723 | |
2724 | static void | |
d436d3de | 2725 | gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr) |
b41b2534 JB |
2726 | { |
2727 | tree tmp; | |
2728 | tree fndecl; | |
2729 | tree type; | |
2730 | ||
2731 | /* Call the library function. This always returns an INTEGER(4). */ | |
2732 | fndecl = gfor_fndecl_iargc; | |
2733 | tmp = gfc_build_function_call (fndecl, NULL_TREE); | |
2734 | ||
2735 | /* Convert it to the required type. */ | |
2736 | type = gfc_typenode_for_spec (&expr->ts); | |
2737 | tmp = fold_convert (type, tmp); | |
2738 | ||
b41b2534 JB |
2739 | se->expr = tmp; |
2740 | } | |
2741 | ||
6de9cd9a DN |
2742 | /* Generate code for an intrinsic function. Some map directly to library |
2743 | calls, others get special handling. In some cases the name of the function | |
2744 | used depends on the type specifiers. */ | |
2745 | ||
2746 | void | |
2747 | gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr) | |
2748 | { | |
2749 | gfc_intrinsic_sym *isym; | |
6b25a558 | 2750 | const char *name; |
6de9cd9a DN |
2751 | int lib; |
2752 | ||
2753 | isym = expr->value.function.isym; | |
2754 | ||
2755 | name = &expr->value.function.name[2]; | |
2756 | ||
2757 | if (expr->rank > 0) | |
2758 | { | |
2759 | lib = gfc_is_intrinsic_libcall (expr); | |
2760 | if (lib != 0) | |
2761 | { | |
2762 | if (lib == 1) | |
2763 | se->ignore_optional = 1; | |
2764 | gfc_conv_intrinsic_funcall (se, expr); | |
2765 | return; | |
2766 | } | |
2767 | } | |
2768 | ||
2769 | switch (expr->value.function.isym->generic_id) | |
2770 | { | |
2771 | case GFC_ISYM_NONE: | |
6e45f57b | 2772 | gcc_unreachable (); |
6de9cd9a DN |
2773 | |
2774 | case GFC_ISYM_REPEAT: | |
2775 | gfc_conv_intrinsic_repeat (se, expr); | |
2776 | break; | |
2777 | ||
2778 | case GFC_ISYM_TRIM: | |
2779 | gfc_conv_intrinsic_trim (se, expr); | |
2780 | break; | |
2781 | ||
2782 | case GFC_ISYM_SI_KIND: | |
2783 | gfc_conv_intrinsic_si_kind (se, expr); | |
2784 | break; | |
2785 | ||
2786 | case GFC_ISYM_SR_KIND: | |
2787 | gfc_conv_intrinsic_sr_kind (se, expr); | |
2788 | break; | |
2789 | ||
2790 | case GFC_ISYM_EXPONENT: | |
2791 | gfc_conv_intrinsic_exponent (se, expr); | |
2792 | break; | |
2793 | ||
2794 | case GFC_ISYM_SPACING: | |
2795 | gfc_conv_intrinsic_spacing (se, expr); | |
2796 | break; | |
2797 | ||
2798 | case GFC_ISYM_RRSPACING: | |
2799 | gfc_conv_intrinsic_rrspacing (se, expr); | |
2800 | break; | |
2801 | ||
2802 | case GFC_ISYM_SCAN: | |
2803 | gfc_conv_intrinsic_scan (se, expr); | |
2804 | break; | |
2805 | ||
2806 | case GFC_ISYM_VERIFY: | |
2807 | gfc_conv_intrinsic_verify (se, expr); | |
2808 | break; | |
2809 | ||
2810 | case GFC_ISYM_ALLOCATED: | |
2811 | gfc_conv_allocated (se, expr); | |
2812 | break; | |
2813 | ||
2814 | case GFC_ISYM_ASSOCIATED: | |
2815 | gfc_conv_associated(se, expr); | |
2816 | break; | |
2817 | ||
2818 | case GFC_ISYM_ABS: | |
2819 | gfc_conv_intrinsic_abs (se, expr); | |
2820 | break; | |
2821 | ||
2822 | case GFC_ISYM_ADJUSTL: | |
2823 | gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl); | |
2824 | break; | |
2825 | ||
2826 | case GFC_ISYM_ADJUSTR: | |
2827 | gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr); | |
2828 | break; | |
2829 | ||
2830 | case GFC_ISYM_AIMAG: | |
2831 | gfc_conv_intrinsic_imagpart (se, expr); | |
2832 | break; | |
2833 | ||
2834 | case GFC_ISYM_AINT: | |
2835 | gfc_conv_intrinsic_aint (se, expr, FIX_TRUNC_EXPR); | |
2836 | break; | |
2837 | ||
2838 | case GFC_ISYM_ALL: | |
2839 | gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR); | |
2840 | break; | |
2841 | ||
2842 | case GFC_ISYM_ANINT: | |
2843 | gfc_conv_intrinsic_aint (se, expr, FIX_ROUND_EXPR); | |
2844 | break; | |
2845 | ||
2846 | case GFC_ISYM_ANY: | |
2847 | gfc_conv_intrinsic_anyall (se, expr, NE_EXPR); | |
2848 | break; | |
2849 | ||
2850 | case GFC_ISYM_BTEST: | |
2851 | gfc_conv_intrinsic_btest (se, expr); | |
2852 | break; | |
2853 | ||
2854 | case GFC_ISYM_ACHAR: | |
2855 | case GFC_ISYM_CHAR: | |
2856 | gfc_conv_intrinsic_char (se, expr); | |
2857 | break; | |
2858 | ||
2859 | case GFC_ISYM_CONVERSION: | |
2860 | case GFC_ISYM_REAL: | |
2861 | case GFC_ISYM_LOGICAL: | |
2862 | case GFC_ISYM_DBLE: | |
2863 | gfc_conv_intrinsic_conversion (se, expr); | |
2864 | break; | |
2865 | ||
e7dc5b4f | 2866 | /* Integer conversions are handled separately to make sure we get the |
6de9cd9a DN |
2867 | correct rounding mode. */ |
2868 | case GFC_ISYM_INT: | |
2869 | gfc_conv_intrinsic_int (se, expr, FIX_TRUNC_EXPR); | |
2870 | break; | |
2871 | ||
2872 | case GFC_ISYM_NINT: | |
2873 | gfc_conv_intrinsic_int (se, expr, FIX_ROUND_EXPR); | |
2874 | break; | |
2875 | ||
2876 | case GFC_ISYM_CEILING: | |
2877 | gfc_conv_intrinsic_int (se, expr, FIX_CEIL_EXPR); | |
2878 | break; | |
2879 | ||
2880 | case GFC_ISYM_FLOOR: | |
2881 | gfc_conv_intrinsic_int (se, expr, FIX_FLOOR_EXPR); | |
2882 | break; | |
2883 | ||
2884 | case GFC_ISYM_MOD: | |
2885 | gfc_conv_intrinsic_mod (se, expr, 0); | |
2886 | break; | |
2887 | ||
2888 | case GFC_ISYM_MODULO: | |
2889 | gfc_conv_intrinsic_mod (se, expr, 1); | |
2890 | break; | |
2891 | ||
2892 | case GFC_ISYM_CMPLX: | |
2893 | gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1'); | |
2894 | break; | |
2895 | ||
b41b2534 | 2896 | case GFC_ISYM_COMMAND_ARGUMENT_COUNT: |
d436d3de | 2897 | gfc_conv_intrinsic_iargc (se, expr); |
b41b2534 JB |
2898 | break; |
2899 | ||
6de9cd9a DN |
2900 | case GFC_ISYM_CONJG: |
2901 | gfc_conv_intrinsic_conjg (se, expr); | |
2902 | break; | |
2903 | ||
2904 | case GFC_ISYM_COUNT: | |
2905 | gfc_conv_intrinsic_count (se, expr); | |
2906 | break; | |
2907 | ||
2908 | case GFC_ISYM_DIM: | |
2909 | gfc_conv_intrinsic_dim (se, expr); | |
2910 | break; | |
2911 | ||
2912 | case GFC_ISYM_DPROD: | |
2913 | gfc_conv_intrinsic_dprod (se, expr); | |
2914 | break; | |
2915 | ||
2916 | case GFC_ISYM_IAND: | |
2917 | gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR); | |
2918 | break; | |
2919 | ||
2920 | case GFC_ISYM_IBCLR: | |
2921 | gfc_conv_intrinsic_singlebitop (se, expr, 0); | |
2922 | break; | |
2923 | ||
2924 | case GFC_ISYM_IBITS: | |
2925 | gfc_conv_intrinsic_ibits (se, expr); | |
2926 | break; | |
2927 | ||
2928 | case GFC_ISYM_IBSET: | |
2929 | gfc_conv_intrinsic_singlebitop (se, expr, 1); | |
2930 | break; | |
2931 | ||
2932 | case GFC_ISYM_IACHAR: | |
2933 | case GFC_ISYM_ICHAR: | |
2934 | /* We assume ASCII character sequence. */ | |
2935 | gfc_conv_intrinsic_ichar (se, expr); | |
2936 | break; | |
2937 | ||
b41b2534 | 2938 | case GFC_ISYM_IARGC: |
d436d3de | 2939 | gfc_conv_intrinsic_iargc (se, expr); |
b41b2534 JB |
2940 | break; |
2941 | ||
6de9cd9a DN |
2942 | case GFC_ISYM_IEOR: |
2943 | gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR); | |
2944 | break; | |
2945 | ||
2946 | case GFC_ISYM_INDEX: | |
2947 | gfc_conv_intrinsic_index (se, expr); | |
2948 | break; | |
2949 | ||
2950 | case GFC_ISYM_IOR: | |
2951 | gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR); | |
2952 | break; | |
2953 | ||
2954 | case GFC_ISYM_ISHFT: | |
2955 | gfc_conv_intrinsic_ishft (se, expr); | |
2956 | break; | |
2957 | ||
2958 | case GFC_ISYM_ISHFTC: | |
2959 | gfc_conv_intrinsic_ishftc (se, expr); | |
2960 | break; | |
2961 | ||
2962 | case GFC_ISYM_LBOUND: | |
2963 | gfc_conv_intrinsic_bound (se, expr, 0); | |
2964 | break; | |
2965 | ||
2966 | case GFC_ISYM_LEN: | |
2967 | gfc_conv_intrinsic_len (se, expr); | |
2968 | break; | |
2969 | ||
2970 | case GFC_ISYM_LEN_TRIM: | |
2971 | gfc_conv_intrinsic_len_trim (se, expr); | |
2972 | break; | |
2973 | ||
2974 | case GFC_ISYM_LGE: | |
2975 | gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR); | |
2976 | break; | |
2977 | ||
2978 | case GFC_ISYM_LGT: | |
2979 | gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR); | |
2980 | break; | |
2981 | ||
2982 | case GFC_ISYM_LLE: | |
2983 | gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR); | |
2984 | break; | |
2985 | ||
2986 | case GFC_ISYM_LLT: | |
2987 | gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR); | |
2988 | break; | |
2989 | ||
2990 | case GFC_ISYM_MAX: | |
2991 | gfc_conv_intrinsic_minmax (se, expr, GT_EXPR); | |
2992 | break; | |
2993 | ||
2994 | case GFC_ISYM_MAXLOC: | |
2995 | gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR); | |
2996 | break; | |
2997 | ||
2998 | case GFC_ISYM_MAXVAL: | |
2999 | gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR); | |
3000 | break; | |
3001 | ||
3002 | case GFC_ISYM_MERGE: | |
3003 | gfc_conv_intrinsic_merge (se, expr); | |
3004 | break; | |
3005 | ||
3006 | case GFC_ISYM_MIN: | |
3007 | gfc_conv_intrinsic_minmax (se, expr, LT_EXPR); | |
3008 | break; | |
3009 | ||
3010 | case GFC_ISYM_MINLOC: | |
3011 | gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR); | |
3012 | break; | |
3013 | ||
3014 | case GFC_ISYM_MINVAL: | |
3015 | gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR); | |
3016 | break; | |
3017 | ||
3018 | case GFC_ISYM_NOT: | |
3019 | gfc_conv_intrinsic_not (se, expr); | |
3020 | break; | |
3021 | ||
3022 | case GFC_ISYM_PRESENT: | |
3023 | gfc_conv_intrinsic_present (se, expr); | |
3024 | break; | |
3025 | ||
3026 | case GFC_ISYM_PRODUCT: | |
3027 | gfc_conv_intrinsic_arith (se, expr, MULT_EXPR); | |
3028 | break; | |
3029 | ||
3030 | case GFC_ISYM_SIGN: | |
3031 | gfc_conv_intrinsic_sign (se, expr); | |
3032 | break; | |
3033 | ||
3034 | case GFC_ISYM_SIZE: | |
3035 | gfc_conv_intrinsic_size (se, expr); | |
3036 | break; | |
3037 | ||
3038 | case GFC_ISYM_SUM: | |
3039 | gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR); | |
3040 | break; | |
3041 | ||
3042 | case GFC_ISYM_TRANSFER: | |
3043 | gfc_conv_intrinsic_transfer (se, expr); | |
3044 | break; | |
3045 | ||
3046 | case GFC_ISYM_UBOUND: | |
3047 | gfc_conv_intrinsic_bound (se, expr, 1); | |
3048 | break; | |
3049 | ||
f77b6ca3 | 3050 | case GFC_ISYM_CHDIR: |
6de9cd9a | 3051 | case GFC_ISYM_DOT_PRODUCT: |
2bd74949 | 3052 | case GFC_ISYM_ETIME: |
df65f093 SK |
3053 | case GFC_ISYM_FNUM: |
3054 | case GFC_ISYM_FSTAT: | |
a8c60d7f | 3055 | case GFC_ISYM_GETCWD: |
4c0c6b9f SK |
3056 | case GFC_ISYM_GETGID: |
3057 | case GFC_ISYM_GETPID: | |
3058 | case GFC_ISYM_GETUID: | |
f77b6ca3 FXC |
3059 | case GFC_ISYM_HOSTNM: |
3060 | case GFC_ISYM_KILL: | |
3061 | case GFC_ISYM_IERRNO: | |
df65f093 | 3062 | case GFC_ISYM_IRAND: |
ae8b8789 | 3063 | case GFC_ISYM_ISATTY: |
f77b6ca3 | 3064 | case GFC_ISYM_LINK: |
df65f093 SK |
3065 | case GFC_ISYM_MATMUL: |
3066 | case GFC_ISYM_RAND: | |
f77b6ca3 | 3067 | case GFC_ISYM_RENAME: |
df65f093 SK |
3068 | case GFC_ISYM_SECOND: |
3069 | case GFC_ISYM_STAT: | |
f77b6ca3 | 3070 | case GFC_ISYM_SYMLNK: |
5b1374e9 | 3071 | case GFC_ISYM_SYSTEM: |
f77b6ca3 FXC |
3072 | case GFC_ISYM_TIME: |
3073 | case GFC_ISYM_TIME8: | |
d8fe26b2 SK |
3074 | case GFC_ISYM_UMASK: |
3075 | case GFC_ISYM_UNLINK: | |
6de9cd9a DN |
3076 | gfc_conv_intrinsic_funcall (se, expr); |
3077 | break; | |
3078 | ||
3079 | default: | |
3080 | gfc_conv_intrinsic_lib_function (se, expr); | |
3081 | break; | |
3082 | } | |
3083 | } | |
3084 | ||
3085 | ||
3086 | /* This generates code to execute before entering the scalarization loop. | |
3087 | Currently does nothing. */ | |
3088 | ||
3089 | void | |
3090 | gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss) | |
3091 | { | |
3092 | switch (ss->expr->value.function.isym->generic_id) | |
3093 | { | |
3094 | case GFC_ISYM_UBOUND: | |
3095 | case GFC_ISYM_LBOUND: | |
3096 | break; | |
3097 | ||
3098 | default: | |
6e45f57b | 3099 | gcc_unreachable (); |
6de9cd9a DN |
3100 | } |
3101 | } | |
3102 | ||
3103 | ||
3104 | /* UBOUND and LBOUND intrinsics with one parameter are expanded into code | |
3105 | inside the scalarization loop. */ | |
3106 | ||
3107 | static gfc_ss * | |
3108 | gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr) | |
3109 | { | |
3110 | gfc_ss *newss; | |
3111 | ||
3112 | /* The two argument version returns a scalar. */ | |
3113 | if (expr->value.function.actual->next->expr) | |
3114 | return ss; | |
3115 | ||
3116 | newss = gfc_get_ss (); | |
3117 | newss->type = GFC_SS_INTRINSIC; | |
3118 | newss->expr = expr; | |
3119 | newss->next = ss; | |
3120 | ||
3121 | return newss; | |
3122 | } | |
3123 | ||
3124 | ||
3125 | /* Walk an intrinsic array libcall. */ | |
3126 | ||
3127 | static gfc_ss * | |
3128 | gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr) | |
3129 | { | |
3130 | gfc_ss *newss; | |
3131 | ||
6e45f57b | 3132 | gcc_assert (expr->rank > 0); |
6de9cd9a DN |
3133 | |
3134 | newss = gfc_get_ss (); | |
3135 | newss->type = GFC_SS_FUNCTION; | |
3136 | newss->expr = expr; | |
3137 | newss->next = ss; | |
3138 | newss->data.info.dimen = expr->rank; | |
3139 | ||
3140 | return newss; | |
3141 | } | |
3142 | ||
3143 | ||
3144 | /* Returns nonzero if the specified intrinsic function call maps directly to a | |
3145 | an external library call. Should only be used for functions that return | |
3146 | arrays. */ | |
3147 | ||
3148 | int | |
3149 | gfc_is_intrinsic_libcall (gfc_expr * expr) | |
3150 | { | |
6e45f57b PB |
3151 | gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym); |
3152 | gcc_assert (expr->rank > 0); | |
6de9cd9a DN |
3153 | |
3154 | switch (expr->value.function.isym->generic_id) | |
3155 | { | |
3156 | case GFC_ISYM_ALL: | |
3157 | case GFC_ISYM_ANY: | |
3158 | case GFC_ISYM_COUNT: | |
3159 | case GFC_ISYM_MATMUL: | |
3160 | case GFC_ISYM_MAXLOC: | |
3161 | case GFC_ISYM_MAXVAL: | |
3162 | case GFC_ISYM_MINLOC: | |
3163 | case GFC_ISYM_MINVAL: | |
3164 | case GFC_ISYM_PRODUCT: | |
3165 | case GFC_ISYM_SUM: | |
3166 | case GFC_ISYM_SHAPE: | |
3167 | case GFC_ISYM_SPREAD: | |
3168 | case GFC_ISYM_TRANSPOSE: | |
3169 | /* Ignore absent optional parameters. */ | |
3170 | return 1; | |
3171 | ||
3172 | case GFC_ISYM_RESHAPE: | |
3173 | case GFC_ISYM_CSHIFT: | |
3174 | case GFC_ISYM_EOSHIFT: | |
3175 | case GFC_ISYM_PACK: | |
3176 | case GFC_ISYM_UNPACK: | |
3177 | /* Pass absent optional parameters. */ | |
3178 | return 2; | |
3179 | ||
3180 | default: | |
3181 | return 0; | |
3182 | } | |
3183 | } | |
3184 | ||
3185 | /* Walk an intrinsic function. */ | |
3186 | gfc_ss * | |
3187 | gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr, | |
3188 | gfc_intrinsic_sym * isym) | |
3189 | { | |
6e45f57b | 3190 | gcc_assert (isym); |
6de9cd9a DN |
3191 | |
3192 | if (isym->elemental) | |
3193 | return gfc_walk_elemental_function_args (ss, expr, GFC_SS_SCALAR); | |
3194 | ||
3195 | if (expr->rank == 0) | |
3196 | return ss; | |
3197 | ||
3198 | if (gfc_is_intrinsic_libcall (expr)) | |
3199 | return gfc_walk_intrinsic_libfunc (ss, expr); | |
3200 | ||
3201 | /* Special cases. */ | |
3202 | switch (isym->generic_id) | |
3203 | { | |
3204 | case GFC_ISYM_LBOUND: | |
3205 | case GFC_ISYM_UBOUND: | |
3206 | return gfc_walk_intrinsic_bound (ss, expr); | |
3207 | ||
3208 | default: | |
3209 | /* This probably meant someone forgot to add an intrinsic to the above | |
3210 | list(s) when they implemented it, or something's gone horribly wrong. | |
3211 | */ | |
3212 | gfc_todo_error ("Scalarization of non-elemental intrinsic: %s", | |
3213 | expr->value.function.name); | |
3214 | } | |
3215 | } | |
3216 | ||
3217 | #include "gt-fortran-trans-intrinsic.h" |