1 /* Intrinsic translation
2 Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
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
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
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
23 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
27 #include "coretypes.h"
32 #include "tree-gimple.h"
36 #include "intrinsic.h"
38 #include "trans-const.h"
39 #include "trans-types.h"
40 #include "trans-array.h"
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 #include "trans-stmt.h"
45 /* This maps fortran intrinsic math functions to external library or GCC
47 typedef struct gfc_intrinsic_map_t GTY(())
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;
53 /* Enum value from the "language-independent", aka C-centric, part
54 of gcc, or END_BUILTINS of no such value set. */
55 /* ??? There are now complex variants in builtins.def, though we
56 don't currently do anything with them. */
57 enum built_in_function code4;
58 enum built_in_function code8;
60 /* True if the naming pattern is to prepend "c" for complex and
61 append "f" for kind=4. False if the naming pattern is to
62 prepend "_gfortran_" and append "[rc][48]". */
65 /* True if a complex version of the function exists. */
66 bool complex_available;
68 /* True if the function should be marked const. */
71 /* The base library name of this function. */
74 /* Cache decls created for the various operand types. */
82 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
83 defines complex variants of all of the entries in mathbuiltins.def
85 #define BUILT_IN_FUNCTION(ID, NAME, HAVE_COMPLEX) \
86 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, true, \
87 HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
89 #define DEFINE_MATH_BUILTIN(id, name, argtype) \
90 BUILT_IN_FUNCTION (id, name, false)
92 /* TODO: Use builtin function for complex intrinsics. */
93 #define DEFINE_MATH_BUILTIN_C(id, name, argtype) \
94 BUILT_IN_FUNCTION (id, name, true)
96 #define LIBM_FUNCTION(ID, NAME, HAVE_COMPLEX) \
97 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, true, HAVE_COMPLEX, true, \
98 NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
100 #define LIBF_FUNCTION(ID, NAME, HAVE_COMPLEX) \
101 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, false, HAVE_COMPLEX, true, \
102 NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
104 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
106 /* Functions built into gcc itself. */
107 #include "mathbuiltins.def"
109 /* Functions in libm. */
110 /* ??? This does exist as BUILT_IN_SCALBN, but doesn't quite fit the
111 pattern for other mathbuiltins.def entries. At present we have no
112 optimizations for this in the common sources. */
113 LIBM_FUNCTION (SCALE, "scalbn", false),
115 /* Functions in libgfortran. */
116 LIBF_FUNCTION (FRACTION, "fraction", false),
117 LIBF_FUNCTION (NEAREST, "nearest", false),
118 LIBF_FUNCTION (SET_EXPONENT, "set_exponent", false),
121 LIBF_FUNCTION (NONE, NULL, false)
123 #undef DEFINE_MATH_BUILTIN
124 #undef DEFINE_MATH_BUILTIN_C
125 #undef BUILT_IN_FUNCTION
129 /* Structure for storing components of a floating number to be used by
130 elemental functions to manipulate reals. */
133 tree arg; /* Variable tree to view convert to integer. */
134 tree expn; /* Variable tree to save exponent. */
135 tree frac; /* Variable tree to save fraction. */
136 tree smask; /* Constant tree of sign's mask. */
137 tree emask; /* Constant tree of exponent's mask. */
138 tree fmask; /* Constant tree of fraction's mask. */
139 tree edigits; /* Constant tree of the number of exponent bits. */
140 tree fdigits; /* Constant tree of the number of fraction bits. */
141 tree f1; /* Constant tree of the f1 defined in the real model. */
142 tree bias; /* Constant tree of the bias of exponent in the memory. */
143 tree type; /* Type tree of arg1. */
144 tree mtype; /* Type tree of integer type. Kind is that of arg1. */
149 /* Evaluate the arguments to an intrinsic function. */
152 gfc_conv_intrinsic_function_args (gfc_se * se, gfc_expr * expr)
154 gfc_actual_arglist *actual;
159 for (actual = expr->value.function.actual; actual; actual = actual->next)
161 /* Skip ommitted optional arguments. */
165 /* Evaluate the parameter. This will substitute scalarized
166 references automatically. */
167 gfc_init_se (&argse, se);
169 if (actual->expr->ts.type == BT_CHARACTER)
171 gfc_conv_expr (&argse, actual->expr);
172 gfc_conv_string_parameter (&argse);
173 args = gfc_chainon_list (args, argse.string_length);
176 gfc_conv_expr_val (&argse, actual->expr);
178 gfc_add_block_to_block (&se->pre, &argse.pre);
179 gfc_add_block_to_block (&se->post, &argse.post);
180 args = gfc_chainon_list (args, argse.expr);
186 /* Conversions between different types are output by the frontend as
187 intrinsic functions. We implement these directly with inline code. */
190 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
195 /* Evaluate the argument. */
196 type = gfc_typenode_for_spec (&expr->ts);
197 gcc_assert (expr->value.function.actual->expr);
198 arg = gfc_conv_intrinsic_function_args (se, expr);
199 arg = TREE_VALUE (arg);
201 /* Conversion from complex to non-complex involves taking the real
202 component of the value. */
203 if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE
204 && expr->ts.type != BT_COMPLEX)
208 artype = TREE_TYPE (TREE_TYPE (arg));
209 arg = build1 (REALPART_EXPR, artype, arg);
212 se->expr = convert (type, arg);
215 /* This is needed because the gcc backend only implements
216 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
217 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
218 Similarly for CEILING. */
221 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
228 argtype = TREE_TYPE (arg);
229 arg = gfc_evaluate_now (arg, pblock);
231 intval = convert (type, arg);
232 intval = gfc_evaluate_now (intval, pblock);
234 tmp = convert (argtype, intval);
235 cond = build2 (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);
237 tmp = build2 (up ? PLUS_EXPR : MINUS_EXPR, type, intval,
238 convert (type, integer_one_node));
239 tmp = build3 (COND_EXPR, type, cond, intval, tmp);
244 /* This is needed because the gcc backend only implements FIX_TRUNC_EXPR
245 NINT(x) = INT(x + ((x > 0) ? 0.5 : -0.5)). */
248 build_round_expr (stmtblock_t * pblock, tree arg, tree type)
257 argtype = TREE_TYPE (arg);
258 arg = gfc_evaluate_now (arg, pblock);
260 real_from_string (&r, "0.5");
261 pos = build_real (argtype, r);
263 real_from_string (&r, "-0.5");
264 neg = build_real (argtype, r);
266 tmp = gfc_build_const (argtype, integer_zero_node);
267 cond = fold (build2 (GT_EXPR, boolean_type_node, arg, tmp));
269 tmp = fold (build3 (COND_EXPR, argtype, cond, pos, neg));
270 tmp = fold (build2 (PLUS_EXPR, argtype, arg, tmp));
271 return fold (build1 (FIX_TRUNC_EXPR, type, tmp));
275 /* Convert a real to an integer using a specific rounding mode.
276 Ideally we would just build the corresponding GENERIC node,
277 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
280 build_fix_expr (stmtblock_t * pblock, tree arg, tree type, int op)
285 return build_fixbound_expr (pblock, arg, type, 0);
289 return build_fixbound_expr (pblock, arg, type, 1);
293 return build_round_expr (pblock, arg, type);
296 return build1 (op, type, arg);
301 /* Round a real value using the specified rounding mode.
302 We use a temporary integer of that same kind size as the result.
303 Values larger than can be represented by this kind are unchanged, as
304 will not be accurate enough to represent the rounding.
305 huge = HUGE (KIND (a))
306 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
310 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, int op)
321 kind = expr->ts.kind;
324 /* We have builtin functions for some cases. */
353 /* Evaluate the argument. */
354 gcc_assert (expr->value.function.actual->expr);
355 arg = gfc_conv_intrinsic_function_args (se, expr);
357 /* Use a builtin function if one exists. */
358 if (n != END_BUILTINS)
360 tmp = built_in_decls[n];
361 se->expr = gfc_build_function_call (tmp, arg);
365 /* This code is probably redundant, but we'll keep it lying around just
367 type = gfc_typenode_for_spec (&expr->ts);
368 arg = TREE_VALUE (arg);
369 arg = gfc_evaluate_now (arg, &se->pre);
371 /* Test if the value is too large to handle sensibly. */
372 gfc_set_model_kind (kind);
374 n = gfc_validate_kind (BT_INTEGER, kind, false);
375 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
376 tmp = gfc_conv_mpfr_to_tree (huge, kind);
377 cond = build2 (LT_EXPR, boolean_type_node, arg, tmp);
379 mpfr_neg (huge, huge, GFC_RND_MODE);
380 tmp = gfc_conv_mpfr_to_tree (huge, kind);
381 tmp = build2 (GT_EXPR, boolean_type_node, arg, tmp);
382 cond = build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
383 itype = gfc_get_int_type (kind);
385 tmp = build_fix_expr (&se->pre, arg, itype, op);
386 tmp = convert (type, tmp);
387 se->expr = build3 (COND_EXPR, type, cond, tmp, arg);
392 /* Convert to an integer using the specified rounding mode. */
395 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, int op)
400 /* Evaluate the argument. */
401 type = gfc_typenode_for_spec (&expr->ts);
402 gcc_assert (expr->value.function.actual->expr);
403 arg = gfc_conv_intrinsic_function_args (se, expr);
404 arg = TREE_VALUE (arg);
406 if (TREE_CODE (TREE_TYPE (arg)) == INTEGER_TYPE)
408 /* Conversion to a different integer kind. */
409 se->expr = convert (type, arg);
413 /* Conversion from complex to non-complex involves taking the real
414 component of the value. */
415 if (TREE_CODE (TREE_TYPE (arg)) == COMPLEX_TYPE
416 && expr->ts.type != BT_COMPLEX)
420 artype = TREE_TYPE (TREE_TYPE (arg));
421 arg = build1 (REALPART_EXPR, artype, arg);
424 se->expr = build_fix_expr (&se->pre, arg, type, op);
429 /* Get the imaginary component of a value. */
432 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
436 arg = gfc_conv_intrinsic_function_args (se, expr);
437 arg = TREE_VALUE (arg);
438 se->expr = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
442 /* Get the complex conjugate of a value. */
445 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
449 arg = gfc_conv_intrinsic_function_args (se, expr);
450 arg = TREE_VALUE (arg);
451 se->expr = build1 (CONJ_EXPR, TREE_TYPE (arg), arg);
455 /* Initialize function decls for library functions. The external functions
456 are created as required. Builtin functions are added here. */
459 gfc_build_intrinsic_lib_fndecls (void)
461 gfc_intrinsic_map_t *m;
463 /* Add GCC builtin functions. */
464 for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
466 if (m->code4 != END_BUILTINS)
467 m->real4_decl = built_in_decls[m->code4];
468 if (m->code8 != END_BUILTINS)
469 m->real8_decl = built_in_decls[m->code8];
474 /* Create a fndecl for a simple intrinsic library function. */
477 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
482 gfc_actual_arglist *actual;
485 char name[GFC_MAX_SYMBOL_LEN + 3];
488 if (ts->type == BT_REAL)
493 pdecl = &m->real4_decl;
496 pdecl = &m->real8_decl;
502 else if (ts->type == BT_COMPLEX)
504 gcc_assert (m->complex_available);
509 pdecl = &m->complex4_decl;
512 pdecl = &m->complex8_decl;
526 gcc_assert (ts->kind == 4 || ts->kind == 8);
527 snprintf (name, sizeof (name), "%s%s%s",
528 ts->type == BT_COMPLEX ? "c" : "",
530 ts->kind == 4 ? "f" : "");
534 snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
535 ts->type == BT_COMPLEX ? 'c' : 'r',
539 argtypes = NULL_TREE;
540 for (actual = expr->value.function.actual; actual; actual = actual->next)
542 type = gfc_typenode_for_spec (&actual->expr->ts);
543 argtypes = gfc_chainon_list (argtypes, type);
545 argtypes = gfc_chainon_list (argtypes, void_type_node);
546 type = build_function_type (gfc_typenode_for_spec (ts), argtypes);
547 fndecl = build_decl (FUNCTION_DECL, get_identifier (name), type);
549 /* Mark the decl as external. */
550 DECL_EXTERNAL (fndecl) = 1;
551 TREE_PUBLIC (fndecl) = 1;
553 /* Mark it __attribute__((const)), if possible. */
554 TREE_READONLY (fndecl) = m->is_constant;
556 rest_of_decl_compilation (fndecl, 1, 0);
563 /* Convert an intrinsic function into an external or builtin call. */
566 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
568 gfc_intrinsic_map_t *m;
571 gfc_generic_isym_id id;
573 id = expr->value.function.isym->generic_id;
574 /* Find the entry for this function. */
575 for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
581 if (m->id == GFC_ISYM_NONE)
583 internal_error ("Intrinsic function %s(%d) not recognized",
584 expr->value.function.name, id);
587 /* Get the decl and generate the call. */
588 args = gfc_conv_intrinsic_function_args (se, expr);
589 fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
590 se->expr = gfc_build_function_call (fndecl, args);
593 /* Generate code for EXPONENT(X) intrinsic function. */
596 gfc_conv_intrinsic_exponent (gfc_se * se, gfc_expr * expr)
601 args = gfc_conv_intrinsic_function_args (se, expr);
603 a1 = expr->value.function.actual->expr;
607 fndecl = gfor_fndecl_math_exponent4;
610 fndecl = gfor_fndecl_math_exponent8;
616 se->expr = gfc_build_function_call (fndecl, args);
619 /* Evaluate a single upper or lower bound. */
620 /* TODO: bound intrinsic generates way too much unnecessary code. */
623 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
625 gfc_actual_arglist *arg;
626 gfc_actual_arglist *arg2;
636 gfc_init_se (&argse, NULL);
637 arg = expr->value.function.actual;
642 /* Create an implicit second parameter from the loop variable. */
643 gcc_assert (!arg2->expr);
644 gcc_assert (se->loop->dimen == 1);
645 gcc_assert (se->ss->expr == expr);
646 gfc_advance_se_ss_chain (se);
647 bound = se->loop->loopvar[0];
648 bound = fold (build2 (MINUS_EXPR, gfc_array_index_type, bound,
653 /* use the passed argument. */
654 gcc_assert (arg->next->expr);
655 gfc_init_se (&argse, NULL);
656 gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
657 gfc_add_block_to_block (&se->pre, &argse.pre);
659 /* Convert from one based to zero based. */
660 bound = fold (build2 (MINUS_EXPR, gfc_array_index_type, bound,
661 gfc_index_one_node));
664 /* TODO: don't re-evaluate the descriptor on each iteration. */
665 /* Get a descriptor for the first parameter. */
666 ss = gfc_walk_expr (arg->expr);
667 gcc_assert (ss != gfc_ss_terminator);
668 argse.want_pointer = 0;
669 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
670 gfc_add_block_to_block (&se->pre, &argse.pre);
671 gfc_add_block_to_block (&se->post, &argse.post);
675 if (INTEGER_CST_P (bound))
677 gcc_assert (TREE_INT_CST_HIGH (bound) == 0);
678 i = TREE_INT_CST_LOW (bound);
679 gcc_assert (i >= 0 && i < GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)));
683 if (flag_bounds_check)
685 bound = gfc_evaluate_now (bound, &se->pre);
686 cond = fold (build2 (LT_EXPR, boolean_type_node,
687 bound, convert (TREE_TYPE (bound),
688 integer_zero_node)));
689 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
690 tmp = fold (build2 (GE_EXPR, boolean_type_node, bound, tmp));
691 cond = fold(build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp));
692 gfc_trans_runtime_check (cond, gfc_strconst_fault, &se->pre);
697 se->expr = gfc_conv_descriptor_ubound(desc, bound);
699 se->expr = gfc_conv_descriptor_lbound(desc, bound);
701 type = gfc_typenode_for_spec (&expr->ts);
702 se->expr = convert (type, se->expr);
707 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
713 args = gfc_conv_intrinsic_function_args (se, expr);
714 gcc_assert (args && TREE_CHAIN (args) == NULL_TREE);
715 val = TREE_VALUE (args);
717 switch (expr->value.function.actual->expr->ts.type)
721 se->expr = build1 (ABS_EXPR, TREE_TYPE (val), val);
725 switch (expr->ts.kind)
736 se->expr = fold (gfc_build_function_call (built_in_decls[n], args));
745 /* Create a complex value from one or two real components. */
748 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
755 type = gfc_typenode_for_spec (&expr->ts);
756 arg = gfc_conv_intrinsic_function_args (se, expr);
757 real = convert (TREE_TYPE (type), TREE_VALUE (arg));
759 imag = convert (TREE_TYPE (type), TREE_VALUE (TREE_CHAIN (arg)));
760 else if (TREE_CODE (TREE_TYPE (TREE_VALUE (arg))) == COMPLEX_TYPE)
762 arg = TREE_VALUE (arg);
763 imag = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
764 imag = convert (TREE_TYPE (type), imag);
767 imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
769 se->expr = fold (build2 (COMPLEX_EXPR, type, real, imag));
772 /* Remainder function MOD(A, P) = A - INT(A / P) * P
773 MODULO(A, P) = A - FLOOR (A / P) * P */
774 /* TODO: MOD(x, 0) */
777 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
789 arg = gfc_conv_intrinsic_function_args (se, expr);
790 arg2 = TREE_VALUE (TREE_CHAIN (arg));
791 arg = TREE_VALUE (arg);
792 type = TREE_TYPE (arg);
794 switch (expr->ts.type)
797 /* Integer case is easy, we've got a builtin op. */
799 se->expr = build2 (FLOOR_MOD_EXPR, type, arg, arg2);
801 se->expr = build2 (TRUNC_MOD_EXPR, type, arg, arg2);
805 /* Real values we have to do the hard way. */
806 arg = gfc_evaluate_now (arg, &se->pre);
807 arg2 = gfc_evaluate_now (arg2, &se->pre);
809 tmp = build2 (RDIV_EXPR, type, arg, arg2);
810 /* Test if the value is too large to handle sensibly. */
811 gfc_set_model_kind (expr->ts.kind);
813 n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
814 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
815 test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
816 test2 = build2 (LT_EXPR, boolean_type_node, tmp, test);
818 mpfr_neg (huge, huge, GFC_RND_MODE);
819 test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
820 test = build2 (GT_EXPR, boolean_type_node, tmp, test);
821 test2 = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
823 itype = gfc_get_int_type (expr->ts.kind);
825 tmp = build_fix_expr (&se->pre, tmp, itype, FIX_FLOOR_EXPR);
827 tmp = build_fix_expr (&se->pre, tmp, itype, FIX_TRUNC_EXPR);
828 tmp = convert (type, tmp);
829 tmp = build3 (COND_EXPR, type, test2, tmp, arg);
830 tmp = build2 (MULT_EXPR, type, tmp, arg2);
831 se->expr = build2 (MINUS_EXPR, type, arg, tmp);
840 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
843 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
852 arg = gfc_conv_intrinsic_function_args (se, expr);
853 arg2 = TREE_VALUE (TREE_CHAIN (arg));
854 arg = TREE_VALUE (arg);
855 type = TREE_TYPE (arg);
857 val = build2 (MINUS_EXPR, type, arg, arg2);
858 val = gfc_evaluate_now (val, &se->pre);
860 zero = gfc_build_const (type, integer_zero_node);
861 tmp = build2 (LE_EXPR, boolean_type_node, val, zero);
862 se->expr = build3 (COND_EXPR, type, tmp, zero, val);
866 /* SIGN(A, B) is absolute value of A times sign of B.
867 The real value versions use library functions to ensure the correct
868 handling of negative zero. Integer case implemented as:
869 SIGN(A, B) = ((a >= 0) .xor. (b >= 0)) ? a : -a
873 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
884 arg = gfc_conv_intrinsic_function_args (se, expr);
885 if (expr->ts.type == BT_REAL)
887 switch (expr->ts.kind)
890 tmp = built_in_decls[BUILT_IN_COPYSIGNF];
893 tmp = built_in_decls[BUILT_IN_COPYSIGN];
898 se->expr = fold (gfc_build_function_call (tmp, arg));
902 arg2 = TREE_VALUE (TREE_CHAIN (arg));
903 arg = TREE_VALUE (arg);
904 type = TREE_TYPE (arg);
905 zero = gfc_build_const (type, integer_zero_node);
907 testa = fold (build2 (GE_EXPR, boolean_type_node, arg, zero));
908 testb = fold (build2 (GE_EXPR, boolean_type_node, arg2, zero));
909 tmp = fold (build2 (TRUTH_XOR_EXPR, boolean_type_node, testa, testb));
910 se->expr = fold (build3 (COND_EXPR, type, tmp,
911 build1 (NEGATE_EXPR, type, arg), arg));
915 /* Test for the presence of an optional argument. */
918 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
922 arg = expr->value.function.actual->expr;
923 gcc_assert (arg->expr_type == EXPR_VARIABLE);
924 se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
925 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
929 /* Calculate the double precision product of two single precision values. */
932 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
938 arg = gfc_conv_intrinsic_function_args (se, expr);
939 arg2 = TREE_VALUE (TREE_CHAIN (arg));
940 arg = TREE_VALUE (arg);
942 /* Convert the args to double precision before multiplying. */
943 type = gfc_typenode_for_spec (&expr->ts);
944 arg = convert (type, arg);
945 arg2 = convert (type, arg2);
946 se->expr = build2 (MULT_EXPR, type, arg, arg2);
950 /* Return a length one character string containing an ascii character. */
953 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
959 arg = gfc_conv_intrinsic_function_args (se, expr);
960 arg = TREE_VALUE (arg);
962 /* We currently don't support character types != 1. */
963 gcc_assert (expr->ts.kind == 1);
964 type = gfc_character1_type_node;
965 var = gfc_create_var (type, "char");
967 arg = convert (type, arg);
968 gfc_add_modify_expr (&se->pre, var, arg);
969 se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
970 se->string_length = integer_one_node;
974 /* Get the minimum/maximum value of all the parameters.
975 minmax (a1, a2, a3, ...)
988 /* TODO: Mismatching types can occur when specific names are used.
989 These should be handled during resolution. */
991 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
1002 arg = gfc_conv_intrinsic_function_args (se, expr);
1003 type = gfc_typenode_for_spec (&expr->ts);
1005 limit = TREE_VALUE (arg);
1006 if (TREE_TYPE (limit) != type)
1007 limit = convert (type, limit);
1008 /* Only evaluate the argument once. */
1009 if (TREE_CODE (limit) != VAR_DECL && !TREE_CONSTANT (limit))
1010 limit = gfc_evaluate_now(limit, &se->pre);
1012 mvar = gfc_create_var (type, "M");
1013 elsecase = build2_v (MODIFY_EXPR, mvar, limit);
1014 for (arg = TREE_CHAIN (arg); arg != NULL_TREE; arg = TREE_CHAIN (arg))
1016 val = TREE_VALUE (arg);
1017 if (TREE_TYPE (val) != type)
1018 val = convert (type, val);
1020 /* Only evaluate the argument once. */
1021 if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
1022 val = gfc_evaluate_now(val, &se->pre);
1024 thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
1026 tmp = build2 (op, boolean_type_node, val, limit);
1027 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
1028 gfc_add_expr_to_block (&se->pre, tmp);
1029 elsecase = build_empty_stmt ();
1036 /* Create a symbol node for this intrinsic. The symbol form the frontend
1037 is for the generic name. */
1040 gfc_get_symbol_for_expr (gfc_expr * expr)
1044 /* TODO: Add symbols for intrinsic function to the global namespace. */
1045 gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
1046 sym = gfc_new_symbol (expr->value.function.name, NULL);
1049 sym->attr.external = 1;
1050 sym->attr.function = 1;
1051 sym->attr.always_explicit = 1;
1052 sym->attr.proc = PROC_INTRINSIC;
1053 sym->attr.flavor = FL_PROCEDURE;
1057 sym->attr.dimension = 1;
1058 sym->as = gfc_get_array_spec ();
1059 sym->as->type = AS_ASSUMED_SHAPE;
1060 sym->as->rank = expr->rank;
1063 /* TODO: proper argument lists for external intrinsics. */
1067 /* Generate a call to an external intrinsic function. */
1069 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
1073 gcc_assert (!se->ss || se->ss->expr == expr);
1076 gcc_assert (expr->rank > 0);
1078 gcc_assert (expr->rank == 0);
1080 sym = gfc_get_symbol_for_expr (expr);
1081 gfc_conv_function_call (se, sym, expr->value.function.actual);
1085 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1105 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op)
1114 gfc_actual_arglist *actual;
1121 gfc_conv_intrinsic_funcall (se, expr);
1125 actual = expr->value.function.actual;
1126 type = gfc_typenode_for_spec (&expr->ts);
1127 /* Initialize the result. */
1128 resvar = gfc_create_var (type, "test");
1130 tmp = convert (type, boolean_true_node);
1132 tmp = convert (type, boolean_false_node);
1133 gfc_add_modify_expr (&se->pre, resvar, tmp);
1135 /* Walk the arguments. */
1136 arrayss = gfc_walk_expr (actual->expr);
1137 gcc_assert (arrayss != gfc_ss_terminator);
1139 /* Initialize the scalarizer. */
1140 gfc_init_loopinfo (&loop);
1141 exit_label = gfc_build_label_decl (NULL_TREE);
1142 TREE_USED (exit_label) = 1;
1143 gfc_add_ss_to_loop (&loop, arrayss);
1145 /* Initialize the loop. */
1146 gfc_conv_ss_startstride (&loop);
1147 gfc_conv_loop_setup (&loop);
1149 gfc_mark_ss_chain_used (arrayss, 1);
1150 /* Generate the loop body. */
1151 gfc_start_scalarized_body (&loop, &body);
1153 /* If the condition matches then set the return value. */
1154 gfc_start_block (&block);
1156 tmp = convert (type, boolean_false_node);
1158 tmp = convert (type, boolean_true_node);
1159 gfc_add_modify_expr (&block, resvar, tmp);
1161 /* And break out of the loop. */
1162 tmp = build1_v (GOTO_EXPR, exit_label);
1163 gfc_add_expr_to_block (&block, tmp);
1165 found = gfc_finish_block (&block);
1167 /* Check this element. */
1168 gfc_init_se (&arrayse, NULL);
1169 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1170 arrayse.ss = arrayss;
1171 gfc_conv_expr_val (&arrayse, actual->expr);
1173 gfc_add_block_to_block (&body, &arrayse.pre);
1174 tmp = build2 (op, boolean_type_node, arrayse.expr,
1175 fold_convert (TREE_TYPE (arrayse.expr),
1176 integer_zero_node));
1177 tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt ());
1178 gfc_add_expr_to_block (&body, tmp);
1179 gfc_add_block_to_block (&body, &arrayse.post);
1181 gfc_trans_scalarizing_loops (&loop, &body);
1183 /* Add the exit label. */
1184 tmp = build1_v (LABEL_EXPR, exit_label);
1185 gfc_add_expr_to_block (&loop.pre, tmp);
1187 gfc_add_block_to_block (&se->pre, &loop.pre);
1188 gfc_add_block_to_block (&se->pre, &loop.post);
1189 gfc_cleanup_loop (&loop);
1194 /* COUNT(A) = Number of true elements in A. */
1196 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
1203 gfc_actual_arglist *actual;
1209 gfc_conv_intrinsic_funcall (se, expr);
1213 actual = expr->value.function.actual;
1215 type = gfc_typenode_for_spec (&expr->ts);
1216 /* Initialize the result. */
1217 resvar = gfc_create_var (type, "count");
1218 gfc_add_modify_expr (&se->pre, resvar, convert (type, integer_zero_node));
1220 /* Walk the arguments. */
1221 arrayss = gfc_walk_expr (actual->expr);
1222 gcc_assert (arrayss != gfc_ss_terminator);
1224 /* Initialize the scalarizer. */
1225 gfc_init_loopinfo (&loop);
1226 gfc_add_ss_to_loop (&loop, arrayss);
1228 /* Initialize the loop. */
1229 gfc_conv_ss_startstride (&loop);
1230 gfc_conv_loop_setup (&loop);
1232 gfc_mark_ss_chain_used (arrayss, 1);
1233 /* Generate the loop body. */
1234 gfc_start_scalarized_body (&loop, &body);
1236 tmp = build2 (PLUS_EXPR, TREE_TYPE (resvar), resvar,
1237 convert (TREE_TYPE (resvar), integer_one_node));
1238 tmp = build2_v (MODIFY_EXPR, resvar, tmp);
1240 gfc_init_se (&arrayse, NULL);
1241 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1242 arrayse.ss = arrayss;
1243 gfc_conv_expr_val (&arrayse, actual->expr);
1244 tmp = build3_v (COND_EXPR, arrayse.expr, tmp, build_empty_stmt ());
1246 gfc_add_block_to_block (&body, &arrayse.pre);
1247 gfc_add_expr_to_block (&body, tmp);
1248 gfc_add_block_to_block (&body, &arrayse.post);
1250 gfc_trans_scalarizing_loops (&loop, &body);
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);
1259 /* Inline implementation of the sum and product intrinsics. */
1261 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op)
1269 gfc_actual_arglist *actual;
1274 gfc_expr *arrayexpr;
1279 gfc_conv_intrinsic_funcall (se, expr);
1283 type = gfc_typenode_for_spec (&expr->ts);
1284 /* Initialize the result. */
1285 resvar = gfc_create_var (type, "val");
1286 if (op == PLUS_EXPR)
1287 tmp = gfc_build_const (type, integer_zero_node);
1289 tmp = gfc_build_const (type, integer_one_node);
1291 gfc_add_modify_expr (&se->pre, resvar, tmp);
1293 /* Walk the arguments. */
1294 actual = expr->value.function.actual;
1295 arrayexpr = actual->expr;
1296 arrayss = gfc_walk_expr (arrayexpr);
1297 gcc_assert (arrayss != gfc_ss_terminator);
1299 actual = actual->next->next;
1300 gcc_assert (actual);
1301 maskexpr = actual->expr;
1304 maskss = gfc_walk_expr (maskexpr);
1305 gcc_assert (maskss != gfc_ss_terminator);
1310 /* Initialize the scalarizer. */
1311 gfc_init_loopinfo (&loop);
1312 gfc_add_ss_to_loop (&loop, arrayss);
1314 gfc_add_ss_to_loop (&loop, maskss);
1316 /* Initialize the loop. */
1317 gfc_conv_ss_startstride (&loop);
1318 gfc_conv_loop_setup (&loop);
1320 gfc_mark_ss_chain_used (arrayss, 1);
1322 gfc_mark_ss_chain_used (maskss, 1);
1323 /* Generate the loop body. */
1324 gfc_start_scalarized_body (&loop, &body);
1326 /* If we have a mask, only add this element if the mask is set. */
1329 gfc_init_se (&maskse, NULL);
1330 gfc_copy_loopinfo_to_se (&maskse, &loop);
1332 gfc_conv_expr_val (&maskse, maskexpr);
1333 gfc_add_block_to_block (&body, &maskse.pre);
1335 gfc_start_block (&block);
1338 gfc_init_block (&block);
1340 /* Do the actual summation/product. */
1341 gfc_init_se (&arrayse, NULL);
1342 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1343 arrayse.ss = arrayss;
1344 gfc_conv_expr_val (&arrayse, arrayexpr);
1345 gfc_add_block_to_block (&block, &arrayse.pre);
1347 tmp = build2 (op, type, resvar, arrayse.expr);
1348 gfc_add_modify_expr (&block, resvar, tmp);
1349 gfc_add_block_to_block (&block, &arrayse.post);
1353 /* We enclose the above in if (mask) {...} . */
1354 tmp = gfc_finish_block (&block);
1356 tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1359 tmp = gfc_finish_block (&block);
1360 gfc_add_expr_to_block (&body, tmp);
1362 gfc_trans_scalarizing_loops (&loop, &body);
1363 gfc_add_block_to_block (&se->pre, &loop.pre);
1364 gfc_add_block_to_block (&se->pre, &loop.post);
1365 gfc_cleanup_loop (&loop);
1371 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
1375 stmtblock_t ifblock;
1382 gfc_actual_arglist *actual;
1387 gfc_expr *arrayexpr;
1394 gfc_conv_intrinsic_funcall (se, expr);
1398 /* Initialize the result. */
1399 pos = gfc_create_var (gfc_array_index_type, "pos");
1400 type = gfc_typenode_for_spec (&expr->ts);
1402 /* Walk the arguments. */
1403 actual = expr->value.function.actual;
1404 arrayexpr = actual->expr;
1405 arrayss = gfc_walk_expr (arrayexpr);
1406 gcc_assert (arrayss != gfc_ss_terminator);
1408 actual = actual->next->next;
1409 gcc_assert (actual);
1410 maskexpr = actual->expr;
1413 maskss = gfc_walk_expr (maskexpr);
1414 gcc_assert (maskss != gfc_ss_terminator);
1419 limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
1420 n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
1421 switch (arrayexpr->ts.type)
1424 tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind);
1428 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
1429 arrayexpr->ts.kind);
1436 /* Most negative(+HUGE) for maxval, most negative (-HUGE) for minval. */
1438 tmp = fold (build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp));
1439 gfc_add_modify_expr (&se->pre, limit, tmp);
1441 /* Initialize the scalarizer. */
1442 gfc_init_loopinfo (&loop);
1443 gfc_add_ss_to_loop (&loop, arrayss);
1445 gfc_add_ss_to_loop (&loop, maskss);
1447 /* Initialize the loop. */
1448 gfc_conv_ss_startstride (&loop);
1449 gfc_conv_loop_setup (&loop);
1451 gcc_assert (loop.dimen == 1);
1453 /* Initialize the position to the first element. If the array has zero
1454 size we need to return zero. Otherwise use the first element of the
1455 array, in case all elements are equal to the limit.
1456 i.e. pos = (ubound >= lbound) ? lbound, lbound - 1; */
1457 tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type,
1458 loop.from[0], gfc_index_one_node));
1459 cond = fold (build2 (GE_EXPR, boolean_type_node,
1460 loop.to[0], loop.from[0]));
1461 tmp = fold (build3 (COND_EXPR, gfc_array_index_type, cond,
1462 loop.from[0], tmp));
1463 gfc_add_modify_expr (&loop.pre, pos, tmp);
1465 gfc_mark_ss_chain_used (arrayss, 1);
1467 gfc_mark_ss_chain_used (maskss, 1);
1468 /* Generate the loop body. */
1469 gfc_start_scalarized_body (&loop, &body);
1471 /* If we have a mask, only check this element if the mask is set. */
1474 gfc_init_se (&maskse, NULL);
1475 gfc_copy_loopinfo_to_se (&maskse, &loop);
1477 gfc_conv_expr_val (&maskse, maskexpr);
1478 gfc_add_block_to_block (&body, &maskse.pre);
1480 gfc_start_block (&block);
1483 gfc_init_block (&block);
1485 /* Compare with the current limit. */
1486 gfc_init_se (&arrayse, NULL);
1487 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1488 arrayse.ss = arrayss;
1489 gfc_conv_expr_val (&arrayse, arrayexpr);
1490 gfc_add_block_to_block (&block, &arrayse.pre);
1492 /* We do the following if this is a more extreme value. */
1493 gfc_start_block (&ifblock);
1495 /* Assign the value to the limit... */
1496 gfc_add_modify_expr (&ifblock, limit, arrayse.expr);
1498 /* Remember where we are. */
1499 gfc_add_modify_expr (&ifblock, pos, loop.loopvar[0]);
1501 ifbody = gfc_finish_block (&ifblock);
1503 /* If it is a more extreme value. */
1504 tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
1505 tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
1506 gfc_add_expr_to_block (&block, tmp);
1510 /* We enclose the above in if (mask) {...}. */
1511 tmp = gfc_finish_block (&block);
1513 tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1516 tmp = gfc_finish_block (&block);
1517 gfc_add_expr_to_block (&body, tmp);
1519 gfc_trans_scalarizing_loops (&loop, &body);
1521 gfc_add_block_to_block (&se->pre, &loop.pre);
1522 gfc_add_block_to_block (&se->pre, &loop.post);
1523 gfc_cleanup_loop (&loop);
1525 /* Return a value in the range 1..SIZE(array). */
1526 tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type, loop.from[0],
1527 gfc_index_one_node));
1528 tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type, pos, tmp));
1529 /* And convert to the required type. */
1530 se->expr = convert (type, tmp);
1534 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
1543 gfc_actual_arglist *actual;
1548 gfc_expr *arrayexpr;
1554 gfc_conv_intrinsic_funcall (se, expr);
1558 type = gfc_typenode_for_spec (&expr->ts);
1559 /* Initialize the result. */
1560 limit = gfc_create_var (type, "limit");
1561 n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
1562 switch (expr->ts.type)
1565 tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind);
1569 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
1576 /* Most negative(-HUGE) for maxval, most positive (-HUGE) for minval. */
1578 tmp = fold (build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp));
1579 gfc_add_modify_expr (&se->pre, limit, tmp);
1581 /* Walk the arguments. */
1582 actual = expr->value.function.actual;
1583 arrayexpr = actual->expr;
1584 arrayss = gfc_walk_expr (arrayexpr);
1585 gcc_assert (arrayss != gfc_ss_terminator);
1587 actual = actual->next->next;
1588 gcc_assert (actual);
1589 maskexpr = actual->expr;
1592 maskss = gfc_walk_expr (maskexpr);
1593 gcc_assert (maskss != gfc_ss_terminator);
1598 /* Initialize the scalarizer. */
1599 gfc_init_loopinfo (&loop);
1600 gfc_add_ss_to_loop (&loop, arrayss);
1602 gfc_add_ss_to_loop (&loop, maskss);
1604 /* Initialize the loop. */
1605 gfc_conv_ss_startstride (&loop);
1606 gfc_conv_loop_setup (&loop);
1608 gfc_mark_ss_chain_used (arrayss, 1);
1610 gfc_mark_ss_chain_used (maskss, 1);
1611 /* Generate the loop body. */
1612 gfc_start_scalarized_body (&loop, &body);
1614 /* If we have a mask, only add this element if the mask is set. */
1617 gfc_init_se (&maskse, NULL);
1618 gfc_copy_loopinfo_to_se (&maskse, &loop);
1620 gfc_conv_expr_val (&maskse, maskexpr);
1621 gfc_add_block_to_block (&body, &maskse.pre);
1623 gfc_start_block (&block);
1626 gfc_init_block (&block);
1628 /* Compare with the current limit. */
1629 gfc_init_se (&arrayse, NULL);
1630 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1631 arrayse.ss = arrayss;
1632 gfc_conv_expr_val (&arrayse, arrayexpr);
1633 gfc_add_block_to_block (&block, &arrayse.pre);
1635 /* Assign the value to the limit... */
1636 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
1638 /* If it is a more extreme value. */
1639 tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
1640 tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
1641 gfc_add_expr_to_block (&block, tmp);
1642 gfc_add_block_to_block (&block, &arrayse.post);
1644 tmp = gfc_finish_block (&block);
1646 /* We enclose the above in if (mask) {...}. */
1647 tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1648 gfc_add_expr_to_block (&body, tmp);
1650 gfc_trans_scalarizing_loops (&loop, &body);
1652 gfc_add_block_to_block (&se->pre, &loop.pre);
1653 gfc_add_block_to_block (&se->pre, &loop.post);
1654 gfc_cleanup_loop (&loop);
1659 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
1661 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
1668 arg = gfc_conv_intrinsic_function_args (se, expr);
1669 arg2 = TREE_VALUE (TREE_CHAIN (arg));
1670 arg = TREE_VALUE (arg);
1671 type = TREE_TYPE (arg);
1673 tmp = build2 (LSHIFT_EXPR, type, convert (type, integer_one_node), arg2);
1674 tmp = build2 (BIT_AND_EXPR, type, arg, tmp);
1675 tmp = fold (build2 (NE_EXPR, boolean_type_node, tmp,
1676 convert (type, integer_zero_node)));
1677 type = gfc_typenode_for_spec (&expr->ts);
1678 se->expr = convert (type, tmp);
1681 /* Generate code to perform the specified operation. */
1683 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op)
1689 arg = gfc_conv_intrinsic_function_args (se, expr);
1690 arg2 = TREE_VALUE (TREE_CHAIN (arg));
1691 arg = TREE_VALUE (arg);
1692 type = TREE_TYPE (arg);
1694 se->expr = fold (build2 (op, type, arg, arg2));
1699 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
1703 arg = gfc_conv_intrinsic_function_args (se, expr);
1704 arg = TREE_VALUE (arg);
1706 se->expr = build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
1709 /* Set or clear a single bit. */
1711 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
1719 arg = gfc_conv_intrinsic_function_args (se, expr);
1720 arg2 = TREE_VALUE (TREE_CHAIN (arg));
1721 arg = TREE_VALUE (arg);
1722 type = TREE_TYPE (arg);
1724 tmp = fold (build2 (LSHIFT_EXPR, type,
1725 convert (type, integer_one_node), arg2));
1731 tmp = fold (build1 (BIT_NOT_EXPR, type, tmp));
1733 se->expr = fold (build2 (op, type, arg, tmp));
1736 /* Extract a sequence of bits.
1737 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
1739 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
1748 arg = gfc_conv_intrinsic_function_args (se, expr);
1749 arg2 = TREE_CHAIN (arg);
1750 arg3 = TREE_VALUE (TREE_CHAIN (arg2));
1751 arg = TREE_VALUE (arg);
1752 arg2 = TREE_VALUE (arg2);
1753 type = TREE_TYPE (arg);
1755 mask = build_int_cst (NULL_TREE, -1);
1756 mask = build2 (LSHIFT_EXPR, type, mask, arg3);
1757 mask = build1 (BIT_NOT_EXPR, type, mask);
1759 tmp = build2 (RSHIFT_EXPR, type, arg, arg2);
1761 se->expr = fold (build2 (BIT_AND_EXPR, type, tmp, mask));
1764 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
1766 : ((shift >= 0) ? i << shift : i >> -shift)
1767 where all shifts are logical shifts. */
1769 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
1782 arg = gfc_conv_intrinsic_function_args (se, expr);
1783 arg2 = TREE_VALUE (TREE_CHAIN (arg));
1784 arg = TREE_VALUE (arg);
1785 type = TREE_TYPE (arg);
1786 utype = gfc_unsigned_type (type);
1788 /* We convert to an unsigned type because we want a logical shift.
1789 The standard doesn't define the case of shifting negative
1790 numbers, and we try to be compatible with other compilers, most
1791 notably g77, here. */
1792 arg = convert (utype, arg);
1793 width = fold (build1 (ABS_EXPR, TREE_TYPE (arg2), arg2));
1795 /* Left shift if positive. */
1796 lshift = fold (build2 (LSHIFT_EXPR, type, arg, width));
1798 /* Right shift if negative. */
1799 rshift = convert (type, fold (build2 (RSHIFT_EXPR, utype, arg, width)));
1801 tmp = fold (build2 (GE_EXPR, boolean_type_node, arg2,
1802 convert (TREE_TYPE (arg2), integer_zero_node)));
1803 tmp = fold (build3 (COND_EXPR, type, tmp, lshift, rshift));
1805 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
1806 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
1808 num_bits = convert (TREE_TYPE (arg2),
1809 build_int_cst (NULL, TYPE_PRECISION (type)));
1810 cond = fold (build2 (GE_EXPR, boolean_type_node, width,
1811 convert (TREE_TYPE (arg2), num_bits)));
1813 se->expr = fold (build3 (COND_EXPR, type, cond,
1814 convert (type, integer_zero_node),
1818 /* Circular shift. AKA rotate or barrel shift. */
1820 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
1830 arg = gfc_conv_intrinsic_function_args (se, expr);
1831 arg2 = TREE_CHAIN (arg);
1832 arg3 = TREE_CHAIN (arg2);
1835 /* Use a library function for the 3 parameter version. */
1836 tree int4type = gfc_get_int_type (4);
1838 type = TREE_TYPE (TREE_VALUE (arg));
1839 /* We convert the first argument to at least 4 bytes, and
1840 convert back afterwards. This removes the need for library
1841 functions for all argument sizes, and function will be
1842 aligned to at least 32 bits, so there's no loss. */
1843 if (expr->ts.kind < 4)
1845 tmp = convert (int4type, TREE_VALUE (arg));
1846 TREE_VALUE (arg) = tmp;
1848 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
1849 need loads of library functions. They cannot have values >
1850 BIT_SIZE (I) so the conversion is safe. */
1851 TREE_VALUE (arg2) = convert (int4type, TREE_VALUE (arg2));
1852 TREE_VALUE (arg3) = convert (int4type, TREE_VALUE (arg3));
1854 switch (expr->ts.kind)
1859 tmp = gfor_fndecl_math_ishftc4;
1862 tmp = gfor_fndecl_math_ishftc8;
1867 se->expr = gfc_build_function_call (tmp, arg);
1868 /* Convert the result back to the original type, if we extended
1869 the first argument's width above. */
1870 if (expr->ts.kind < 4)
1871 se->expr = convert (type, se->expr);
1875 arg = TREE_VALUE (arg);
1876 arg2 = TREE_VALUE (arg2);
1877 type = TREE_TYPE (arg);
1879 /* Rotate left if positive. */
1880 lrot = fold (build2 (LROTATE_EXPR, type, arg, arg2));
1882 /* Rotate right if negative. */
1883 tmp = fold (build1 (NEGATE_EXPR, TREE_TYPE (arg2), arg2));
1884 rrot = fold (build2 (RROTATE_EXPR, type, arg, tmp));
1886 tmp = fold (build2 (GT_EXPR, boolean_type_node, arg2,
1887 convert (TREE_TYPE (arg2), integer_zero_node)));
1888 rrot = fold (build3 (COND_EXPR, type, tmp, lrot, rrot));
1890 /* Do nothing if shift == 0. */
1891 tmp = fold (build2 (EQ_EXPR, boolean_type_node, arg2,
1892 convert (TREE_TYPE (arg2), integer_zero_node)));
1893 se->expr = fold (build3 (COND_EXPR, type, tmp, arg, rrot));
1896 /* The length of a character string. */
1898 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
1907 gcc_assert (!se->ss);
1909 arg = expr->value.function.actual->expr;
1911 type = gfc_typenode_for_spec (&expr->ts);
1912 switch (arg->expr_type)
1915 len = build_int_cst (NULL_TREE, arg->value.character.length);
1919 if (arg->expr_type == EXPR_VARIABLE
1920 && (arg->ref == NULL || (arg->ref->next == NULL
1921 && arg->ref->type == REF_ARRAY)))
1923 /* This doesn't catch all cases.
1924 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
1925 and the surrounding thread. */
1926 sym = arg->symtree->n.sym;
1927 decl = gfc_get_symbol_decl (sym);
1928 if (decl == current_function_decl && sym->attr.function
1929 && (sym->result == sym))
1930 decl = gfc_get_fake_result_decl (sym);
1932 len = sym->ts.cl->backend_decl;
1937 /* Anybody stupid enough to do this deserves inefficient code. */
1938 gfc_init_se (&argse, se);
1939 gfc_conv_expr (&argse, arg);
1940 gfc_add_block_to_block (&se->pre, &argse.pre);
1941 gfc_add_block_to_block (&se->post, &argse.post);
1942 len = argse.string_length;
1946 se->expr = convert (type, len);
1949 /* The length of a character string not including trailing blanks. */
1951 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
1956 args = gfc_conv_intrinsic_function_args (se, expr);
1957 type = gfc_typenode_for_spec (&expr->ts);
1958 se->expr = gfc_build_function_call (gfor_fndecl_string_len_trim, args);
1959 se->expr = convert (type, se->expr);
1963 /* Returns the starting position of a substring within a string. */
1966 gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr)
1968 tree gfc_logical4_type_node = gfc_get_logical_type (4);
1974 args = gfc_conv_intrinsic_function_args (se, expr);
1975 type = gfc_typenode_for_spec (&expr->ts);
1976 tmp = gfc_advance_chain (args, 3);
1977 if (TREE_CHAIN (tmp) == NULL_TREE)
1979 back = convert (gfc_logical4_type_node, integer_one_node);
1980 back = tree_cons (NULL_TREE, integer_zero_node, NULL_TREE);
1981 TREE_CHAIN (tmp) = back;
1985 back = TREE_CHAIN (tmp);
1986 TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back));
1989 se->expr = gfc_build_function_call (gfor_fndecl_string_index, args);
1990 se->expr = convert (type, se->expr);
1993 /* The ascii value for a single character. */
1995 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
2000 arg = gfc_conv_intrinsic_function_args (se, expr);
2001 arg = TREE_VALUE (TREE_CHAIN (arg));
2002 gcc_assert (POINTER_TYPE_P (TREE_TYPE (arg)));
2003 arg = build1 (NOP_EXPR, pchar_type_node, arg);
2004 type = gfc_typenode_for_spec (&expr->ts);
2006 se->expr = gfc_build_indirect_ref (arg);
2007 se->expr = convert (type, se->expr);
2011 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
2014 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
2023 arg = gfc_conv_intrinsic_function_args (se, expr);
2024 if (expr->ts.type != BT_CHARACTER)
2026 tsource = TREE_VALUE (arg);
2027 arg = TREE_CHAIN (arg);
2028 fsource = TREE_VALUE (arg);
2029 mask = TREE_VALUE (TREE_CHAIN (arg));
2033 /* We do the same as in the non-character case, but the argument
2034 list is different because of the string length arguments. We
2035 also have to set the string length for the result. */
2036 len = TREE_VALUE (arg);
2037 arg = TREE_CHAIN (arg);
2038 tsource = TREE_VALUE (arg);
2039 arg = TREE_CHAIN (TREE_CHAIN (arg));
2040 fsource = TREE_VALUE (arg);
2041 mask = TREE_VALUE (TREE_CHAIN (arg));
2043 se->string_length = len;
2045 type = TREE_TYPE (tsource);
2046 se->expr = fold (build3 (COND_EXPR, type, mask, tsource, fsource));
2051 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
2053 gfc_actual_arglist *actual;
2060 gfc_init_se (&argse, NULL);
2061 actual = expr->value.function.actual;
2063 ss = gfc_walk_expr (actual->expr);
2064 gcc_assert (ss != gfc_ss_terminator);
2065 argse.want_pointer = 1;
2066 gfc_conv_expr_descriptor (&argse, actual->expr, ss);
2067 gfc_add_block_to_block (&se->pre, &argse.pre);
2068 gfc_add_block_to_block (&se->post, &argse.post);
2069 args = gfc_chainon_list (NULL_TREE, argse.expr);
2071 actual = actual->next;
2074 gfc_init_se (&argse, NULL);
2075 gfc_conv_expr_type (&argse, actual->expr, gfc_array_index_type);
2076 gfc_add_block_to_block (&se->pre, &argse.pre);
2077 args = gfc_chainon_list (args, argse.expr);
2078 fndecl = gfor_fndecl_size1;
2081 fndecl = gfor_fndecl_size0;
2083 se->expr = gfc_build_function_call (fndecl, args);
2084 type = gfc_typenode_for_spec (&expr->ts);
2085 se->expr = convert (type, se->expr);
2089 /* Intrinsic string comparison functions. */
2092 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
2097 args = gfc_conv_intrinsic_function_args (se, expr);
2098 /* Build a call for the comparison. */
2099 se->expr = gfc_build_function_call (gfor_fndecl_compare_string, args);
2101 type = gfc_typenode_for_spec (&expr->ts);
2102 se->expr = build2 (op, type, se->expr,
2103 convert (TREE_TYPE (se->expr), integer_zero_node));
2106 /* Generate a call to the adjustl/adjustr library function. */
2108 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
2116 args = gfc_conv_intrinsic_function_args (se, expr);
2117 len = TREE_VALUE (args);
2119 type = TREE_TYPE (TREE_VALUE (TREE_CHAIN (args)));
2120 var = gfc_conv_string_tmp (se, type, len);
2121 args = tree_cons (NULL_TREE, var, args);
2123 tmp = gfc_build_function_call (fndecl, args);
2124 gfc_add_expr_to_block (&se->pre, tmp);
2126 se->string_length = len;
2130 /* Scalar transfer statement.
2131 TRANSFER (source, mold) = *(typeof<mould> *)&source */
2134 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
2136 gfc_actual_arglist *arg;
2142 gcc_assert (!se->ss);
2144 /* Get a pointer to the source. */
2145 arg = expr->value.function.actual;
2146 ss = gfc_walk_expr (arg->expr);
2147 gfc_init_se (&argse, NULL);
2148 if (ss == gfc_ss_terminator)
2149 gfc_conv_expr_reference (&argse, arg->expr);
2151 gfc_conv_array_parameter (&argse, arg->expr, ss, 1);
2152 gfc_add_block_to_block (&se->pre, &argse.pre);
2153 gfc_add_block_to_block (&se->post, &argse.post);
2157 type = gfc_typenode_for_spec (&expr->ts);
2158 ptr = convert (build_pointer_type (type), ptr);
2159 if (expr->ts.type == BT_CHARACTER)
2161 gfc_init_se (&argse, NULL);
2162 gfc_conv_expr (&argse, arg->expr);
2163 gfc_add_block_to_block (&se->pre, &argse.pre);
2164 gfc_add_block_to_block (&se->post, &argse.post);
2166 se->string_length = argse.string_length;
2170 se->expr = gfc_build_indirect_ref (ptr);
2175 /* Generate code for the ALLOCATED intrinsic.
2176 Generate inline code that directly check the address of the argument. */
2179 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
2181 gfc_actual_arglist *arg1;
2186 gfc_init_se (&arg1se, NULL);
2187 arg1 = expr->value.function.actual;
2188 ss1 = gfc_walk_expr (arg1->expr);
2189 arg1se.descriptor_only = 1;
2190 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
2192 tmp = gfc_conv_descriptor_data (arg1se.expr);
2193 tmp = build2 (NE_EXPR, boolean_type_node, tmp,
2194 fold_convert (TREE_TYPE (tmp), null_pointer_node));
2195 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
2199 /* Generate code for the ASSOCIATED intrinsic.
2200 If both POINTER and TARGET are arrays, generate a call to library function
2201 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
2202 In other cases, generate inline code that directly compare the address of
2203 POINTER with the address of TARGET. */
2206 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
2208 gfc_actual_arglist *arg1;
2209 gfc_actual_arglist *arg2;
2217 gfc_init_se (&arg1se, NULL);
2218 gfc_init_se (&arg2se, NULL);
2219 arg1 = expr->value.function.actual;
2221 ss1 = gfc_walk_expr (arg1->expr);
2225 /* No optional target. */
2226 if (ss1 == gfc_ss_terminator)
2228 /* A pointer to a scalar. */
2229 arg1se.want_pointer = 1;
2230 gfc_conv_expr (&arg1se, arg1->expr);
2235 /* A pointer to an array. */
2236 arg1se.descriptor_only = 1;
2237 gfc_conv_expr_lhs (&arg1se, arg1->expr);
2238 tmp2 = gfc_conv_descriptor_data (arg1se.expr);
2240 tmp = build2 (NE_EXPR, boolean_type_node, tmp2,
2241 fold_convert (TREE_TYPE (tmp2), null_pointer_node));
2246 /* An optional target. */
2247 ss2 = gfc_walk_expr (arg2->expr);
2248 if (ss1 == gfc_ss_terminator)
2250 /* A pointer to a scalar. */
2251 gcc_assert (ss2 == gfc_ss_terminator);
2252 arg1se.want_pointer = 1;
2253 gfc_conv_expr (&arg1se, arg1->expr);
2254 arg2se.want_pointer = 1;
2255 gfc_conv_expr (&arg2se, arg2->expr);
2256 tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
2261 /* A pointer to an array, call library function _gfor_associated. */
2262 gcc_assert (ss2 != gfc_ss_terminator);
2264 arg1se.want_pointer = 1;
2265 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
2266 args = gfc_chainon_list (args, arg1se.expr);
2267 arg2se.want_pointer = 1;
2268 gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
2269 gfc_add_block_to_block (&se->pre, &arg2se.pre);
2270 gfc_add_block_to_block (&se->post, &arg2se.post);
2271 args = gfc_chainon_list (args, arg2se.expr);
2272 fndecl = gfor_fndecl_associated;
2273 se->expr = gfc_build_function_call (fndecl, args);
2276 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2280 /* Scan a string for any one of the characters in a set of characters. */
2283 gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr)
2285 tree gfc_logical4_type_node = gfc_get_logical_type (4);
2291 args = gfc_conv_intrinsic_function_args (se, expr);
2292 type = gfc_typenode_for_spec (&expr->ts);
2293 tmp = gfc_advance_chain (args, 3);
2294 if (TREE_CHAIN (tmp) == NULL_TREE)
2296 back = convert (gfc_logical4_type_node, integer_one_node);
2297 back = tree_cons (NULL_TREE, integer_zero_node, NULL_TREE);
2298 TREE_CHAIN (tmp) = back;
2302 back = TREE_CHAIN (tmp);
2303 TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back));
2306 se->expr = gfc_build_function_call (gfor_fndecl_string_scan, args);
2307 se->expr = convert (type, se->expr);
2311 /* Verify that a set of characters contains all the characters in a string
2312 by identifying the position of the first character in a string of
2313 characters that does not appear in a given set of characters. */
2316 gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
2318 tree gfc_logical4_type_node = gfc_get_logical_type (4);
2324 args = gfc_conv_intrinsic_function_args (se, expr);
2325 type = gfc_typenode_for_spec (&expr->ts);
2326 tmp = gfc_advance_chain (args, 3);
2327 if (TREE_CHAIN (tmp) == NULL_TREE)
2329 back = convert (gfc_logical4_type_node, integer_one_node);
2330 back = tree_cons (NULL_TREE, integer_zero_node, NULL_TREE);
2331 TREE_CHAIN (tmp) = back;
2335 back = TREE_CHAIN (tmp);
2336 TREE_VALUE (back) = convert (gfc_logical4_type_node, TREE_VALUE (back));
2339 se->expr = gfc_build_function_call (gfor_fndecl_string_verify, args);
2340 se->expr = convert (type, se->expr);
2343 /* Prepare components and related information of a real number which is
2344 the first argument of a elemental functions to manipulate reals. */
2347 prepare_arg_info (gfc_se * se, gfc_expr * expr,
2348 real_compnt_info * rcs, int all)
2355 tree exponent, fraction;
2359 if (TARGET_FLOAT_FORMAT != IEEE_FLOAT_FORMAT)
2360 gfc_todo_error ("Non-IEEE floating format");
2362 gcc_assert (expr->expr_type == EXPR_FUNCTION);
2364 arg = gfc_conv_intrinsic_function_args (se, expr);
2365 arg = TREE_VALUE (arg);
2366 rcs->type = TREE_TYPE (arg);
2368 /* Force arg'type to integer by unaffected convert */
2369 a1 = expr->value.function.actual->expr;
2370 masktype = gfc_get_int_type (a1->ts.kind);
2371 rcs->mtype = masktype;
2372 tmp = build1 (VIEW_CONVERT_EXPR, masktype, arg);
2373 arg = gfc_create_var (masktype, "arg");
2374 gfc_add_modify_expr(&se->pre, arg, tmp);
2377 /* Caculate the numbers of bits of exponent, fraction and word */
2378 n = gfc_validate_kind (a1->ts.type, a1->ts.kind, false);
2379 tmp = build_int_cst (NULL_TREE, gfc_real_kinds[n].digits - 1);
2380 rcs->fdigits = convert (masktype, tmp);
2381 wbits = build_int_cst (NULL_TREE, TYPE_PRECISION (rcs->type) - 1);
2382 wbits = convert (masktype, wbits);
2383 rcs->edigits = fold (build2 (MINUS_EXPR, masktype, wbits, tmp));
2385 /* Form masks for exponent/fraction/sign */
2386 one = gfc_build_const (masktype, integer_one_node);
2387 rcs->smask = fold (build2 (LSHIFT_EXPR, masktype, one, wbits));
2388 rcs->f1 = fold (build2 (LSHIFT_EXPR, masktype, one, rcs->fdigits));
2389 rcs->emask = fold (build2 (MINUS_EXPR, masktype, rcs->smask, rcs->f1));
2390 rcs->fmask = fold (build2 (MINUS_EXPR, masktype, rcs->f1, one));
2392 tmp = fold (build2 (MINUS_EXPR, masktype, rcs->edigits, one));
2393 tmp = fold (build2 (LSHIFT_EXPR, masktype, one, tmp));
2394 rcs->bias = fold (build2 (MINUS_EXPR, masktype, tmp ,one));
2398 /* exponent, and fraction */
2399 tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->emask);
2400 tmp = build2 (RSHIFT_EXPR, masktype, tmp, rcs->fdigits);
2401 exponent = gfc_create_var (masktype, "exponent");
2402 gfc_add_modify_expr(&se->pre, exponent, tmp);
2403 rcs->expn = exponent;
2405 tmp = build2 (BIT_AND_EXPR, masktype, arg, rcs->fmask);
2406 fraction = gfc_create_var (masktype, "fraction");
2407 gfc_add_modify_expr(&se->pre, fraction, tmp);
2408 rcs->frac = fraction;
2412 /* Build a call to __builtin_clz. */
2415 call_builtin_clz (tree result_type, tree op0)
2417 tree fn, parms, call;
2418 enum machine_mode op0_mode = TYPE_MODE (TREE_TYPE (op0));
2420 if (op0_mode == TYPE_MODE (integer_type_node))
2421 fn = built_in_decls[BUILT_IN_CLZ];
2422 else if (op0_mode == TYPE_MODE (long_integer_type_node))
2423 fn = built_in_decls[BUILT_IN_CLZL];
2424 else if (op0_mode == TYPE_MODE (long_long_integer_type_node))
2425 fn = built_in_decls[BUILT_IN_CLZLL];
2429 parms = tree_cons (NULL, op0, NULL);
2430 call = gfc_build_function_call (fn, parms);
2432 return convert (result_type, call);
2436 /* Generate code for SPACING (X) intrinsic function.
2437 SPACING (X) = POW (2, e-p)
2441 t = expn - fdigits // e - p.
2442 res = t << fdigits // Form the exponent. Fraction is zero.
2443 if (t < 0) // The result is out of range. Denormalized case.
2448 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
2455 real_compnt_info rcs;
2457 prepare_arg_info (se, expr, &rcs, 0);
2459 masktype = rcs.mtype;
2460 fdigits = rcs.fdigits;
2462 zero = gfc_build_const (masktype, integer_zero_node);
2463 tmp = build2 (BIT_AND_EXPR, masktype, rcs.emask, arg);
2464 tmp = build2 (RSHIFT_EXPR, masktype, tmp, fdigits);
2465 tmp = build2 (MINUS_EXPR, masktype, tmp, fdigits);
2466 cond = build2 (LE_EXPR, boolean_type_node, tmp, zero);
2467 t1 = build2 (LSHIFT_EXPR, masktype, tmp, fdigits);
2468 tmp = build3 (COND_EXPR, masktype, cond, tiny, t1);
2469 tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
2474 /* Generate code for RRSPACING (X) intrinsic function.
2475 RRSPACING (X) = |X * POW (2, -e)| * POW (2, p) = |FRACTION (X)| * POW (2, p)
2477 So the result's exponent is p. And if X is normalized, X's fraction part
2478 is the result's fraction. If X is denormalized, to get the X's fraction we
2479 shift X's fraction part to left until the first '1' is removed.
2483 if (expn == 0 && frac == 0)
2487 // edigits is the number of exponent bits. Add the sign bit.
2488 sedigits = edigits + 1;
2490 if (expn == 0) // Denormalized case.
2492 t1 = leadzero (frac);
2493 frac = frac << (t1 + 1); //Remove the first '1'.
2494 frac = frac >> (sedigits); //Form the fraction.
2497 //fdigits is the number of fraction bits. Form the exponent.
2500 res = (t << fdigits) | frac;
2505 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
2508 tree tmp, t1, t2, cond, cond2;
2510 tree fdigits, fraction;
2511 real_compnt_info rcs;
2513 prepare_arg_info (se, expr, &rcs, 1);
2514 masktype = rcs.mtype;
2515 fdigits = rcs.fdigits;
2516 fraction = rcs.frac;
2517 one = gfc_build_const (masktype, integer_one_node);
2518 zero = gfc_build_const (masktype, integer_zero_node);
2519 t2 = fold (build2 (PLUS_EXPR, masktype, rcs.edigits, one));
2521 t1 = call_builtin_clz (masktype, fraction);
2522 tmp = build2 (PLUS_EXPR, masktype, t1, one);
2523 tmp = build2 (LSHIFT_EXPR, masktype, fraction, tmp);
2524 tmp = build2 (RSHIFT_EXPR, masktype, tmp, t2);
2525 cond = build2 (EQ_EXPR, boolean_type_node, rcs.expn, zero);
2526 fraction = build3 (COND_EXPR, masktype, cond, tmp, fraction);
2528 tmp = fold (build2 (PLUS_EXPR, masktype, rcs.bias, fdigits));
2529 tmp = fold (build2 (LSHIFT_EXPR, masktype, tmp, fdigits));
2530 tmp = build2 (BIT_IOR_EXPR, masktype, tmp, fraction);
2532 cond2 = build2 (EQ_EXPR, boolean_type_node, rcs.frac, zero);
2533 cond = build2 (TRUTH_ANDIF_EXPR, boolean_type_node, cond, cond2);
2534 tmp = build3 (COND_EXPR, masktype, cond,
2535 convert (masktype, integer_zero_node), tmp);
2537 tmp = build1 (VIEW_CONVERT_EXPR, rcs.type, tmp);
2541 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
2544 gfc_conv_intrinsic_si_kind (gfc_se * se, gfc_expr * expr)
2548 args = gfc_conv_intrinsic_function_args (se, expr);
2549 args = TREE_VALUE (args);
2550 args = gfc_build_addr_expr (NULL, args);
2551 args = tree_cons (NULL_TREE, args, NULL_TREE);
2552 se->expr = gfc_build_function_call (gfor_fndecl_si_kind, args);
2555 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
2558 gfc_conv_intrinsic_sr_kind (gfc_se * se, gfc_expr * expr)
2560 gfc_actual_arglist *actual;
2565 for (actual = expr->value.function.actual; actual; actual = actual->next)
2567 gfc_init_se (&argse, se);
2569 /* Pass a NULL pointer for an absent arg. */
2570 if (actual->expr == NULL)
2571 argse.expr = null_pointer_node;
2573 gfc_conv_expr_reference (&argse, actual->expr);
2575 gfc_add_block_to_block (&se->pre, &argse.pre);
2576 gfc_add_block_to_block (&se->post, &argse.post);
2577 args = gfc_chainon_list (args, argse.expr);
2579 se->expr = gfc_build_function_call (gfor_fndecl_sr_kind, args);
2583 /* Generate code for TRIM (A) intrinsic function. */
2586 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
2588 tree gfc_int4_type_node = gfc_get_int_type (4);
2597 arglist = NULL_TREE;
2599 type = build_pointer_type (gfc_character1_type_node);
2600 var = gfc_create_var (type, "pstr");
2601 addr = gfc_build_addr_expr (ppvoid_type_node, var);
2602 len = gfc_create_var (gfc_int4_type_node, "len");
2604 tmp = gfc_conv_intrinsic_function_args (se, expr);
2605 arglist = gfc_chainon_list (arglist, gfc_build_addr_expr (NULL, len));
2606 arglist = gfc_chainon_list (arglist, addr);
2607 arglist = chainon (arglist, tmp);
2609 tmp = gfc_build_function_call (gfor_fndecl_string_trim, arglist);
2610 gfc_add_expr_to_block (&se->pre, tmp);
2612 /* Free the temporary afterwards, if necessary. */
2613 cond = build2 (GT_EXPR, boolean_type_node, len,
2614 convert (TREE_TYPE (len), integer_zero_node));
2615 arglist = gfc_chainon_list (NULL_TREE, var);
2616 tmp = gfc_build_function_call (gfor_fndecl_internal_free, arglist);
2617 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
2618 gfc_add_expr_to_block (&se->post, tmp);
2621 se->string_length = len;
2625 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
2628 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
2630 tree gfc_int4_type_node = gfc_get_int_type (4);
2639 args = gfc_conv_intrinsic_function_args (se, expr);
2640 len = TREE_VALUE (args);
2641 tmp = gfc_advance_chain (args, 2);
2642 ncopies = TREE_VALUE (tmp);
2643 len = fold (build2 (MULT_EXPR, gfc_int4_type_node, len, ncopies));
2644 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
2645 var = gfc_conv_string_tmp (se, build_pointer_type (type), len);
2647 arglist = NULL_TREE;
2648 arglist = gfc_chainon_list (arglist, var);
2649 arglist = chainon (arglist, args);
2650 tmp = gfc_build_function_call (gfor_fndecl_string_repeat, arglist);
2651 gfc_add_expr_to_block (&se->pre, tmp);
2654 se->string_length = len;
2658 /* Generate code for the IARGC intrinsic. If args_only is true this is
2659 actually the COMMAND_ARGUMENT_COUNT intrinsic, so return IARGC - 1. */
2662 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr, bool args_only)
2668 /* Call the library function. This always returns an INTEGER(4). */
2669 fndecl = gfor_fndecl_iargc;
2670 tmp = gfc_build_function_call (fndecl, NULL_TREE);
2672 /* Convert it to the required type. */
2673 type = gfc_typenode_for_spec (&expr->ts);
2674 tmp = fold_convert (type, tmp);
2677 tmp = build2 (MINUS_EXPR, type, tmp, convert (type, integer_one_node));
2681 /* Generate code for an intrinsic function. Some map directly to library
2682 calls, others get special handling. In some cases the name of the function
2683 used depends on the type specifiers. */
2686 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
2688 gfc_intrinsic_sym *isym;
2692 isym = expr->value.function.isym;
2694 name = &expr->value.function.name[2];
2698 lib = gfc_is_intrinsic_libcall (expr);
2702 se->ignore_optional = 1;
2703 gfc_conv_intrinsic_funcall (se, expr);
2708 switch (expr->value.function.isym->generic_id)
2713 case GFC_ISYM_REPEAT:
2714 gfc_conv_intrinsic_repeat (se, expr);
2718 gfc_conv_intrinsic_trim (se, expr);
2721 case GFC_ISYM_SI_KIND:
2722 gfc_conv_intrinsic_si_kind (se, expr);
2725 case GFC_ISYM_SR_KIND:
2726 gfc_conv_intrinsic_sr_kind (se, expr);
2729 case GFC_ISYM_EXPONENT:
2730 gfc_conv_intrinsic_exponent (se, expr);
2733 case GFC_ISYM_SPACING:
2734 gfc_conv_intrinsic_spacing (se, expr);
2737 case GFC_ISYM_RRSPACING:
2738 gfc_conv_intrinsic_rrspacing (se, expr);
2742 gfc_conv_intrinsic_scan (se, expr);
2745 case GFC_ISYM_VERIFY:
2746 gfc_conv_intrinsic_verify (se, expr);
2749 case GFC_ISYM_ALLOCATED:
2750 gfc_conv_allocated (se, expr);
2753 case GFC_ISYM_ASSOCIATED:
2754 gfc_conv_associated(se, expr);
2758 gfc_conv_intrinsic_abs (se, expr);
2761 case GFC_ISYM_ADJUSTL:
2762 gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
2765 case GFC_ISYM_ADJUSTR:
2766 gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
2769 case GFC_ISYM_AIMAG:
2770 gfc_conv_intrinsic_imagpart (se, expr);
2774 gfc_conv_intrinsic_aint (se, expr, FIX_TRUNC_EXPR);
2778 gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
2781 case GFC_ISYM_ANINT:
2782 gfc_conv_intrinsic_aint (se, expr, FIX_ROUND_EXPR);
2786 gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
2789 case GFC_ISYM_BTEST:
2790 gfc_conv_intrinsic_btest (se, expr);
2793 case GFC_ISYM_ACHAR:
2795 gfc_conv_intrinsic_char (se, expr);
2798 case GFC_ISYM_CONVERSION:
2800 case GFC_ISYM_LOGICAL:
2802 gfc_conv_intrinsic_conversion (se, expr);
2805 /* Integer conversions are handled seperately to make sure we get the
2806 correct rounding mode. */
2808 gfc_conv_intrinsic_int (se, expr, FIX_TRUNC_EXPR);
2812 gfc_conv_intrinsic_int (se, expr, FIX_ROUND_EXPR);
2815 case GFC_ISYM_CEILING:
2816 gfc_conv_intrinsic_int (se, expr, FIX_CEIL_EXPR);
2819 case GFC_ISYM_FLOOR:
2820 gfc_conv_intrinsic_int (se, expr, FIX_FLOOR_EXPR);
2824 gfc_conv_intrinsic_mod (se, expr, 0);
2827 case GFC_ISYM_MODULO:
2828 gfc_conv_intrinsic_mod (se, expr, 1);
2831 case GFC_ISYM_CMPLX:
2832 gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
2835 case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
2836 gfc_conv_intrinsic_iargc (se, expr, TRUE);
2839 case GFC_ISYM_CONJG:
2840 gfc_conv_intrinsic_conjg (se, expr);
2843 case GFC_ISYM_COUNT:
2844 gfc_conv_intrinsic_count (se, expr);
2848 gfc_conv_intrinsic_dim (se, expr);
2851 case GFC_ISYM_DPROD:
2852 gfc_conv_intrinsic_dprod (se, expr);
2856 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
2859 case GFC_ISYM_IBCLR:
2860 gfc_conv_intrinsic_singlebitop (se, expr, 0);
2863 case GFC_ISYM_IBITS:
2864 gfc_conv_intrinsic_ibits (se, expr);
2867 case GFC_ISYM_IBSET:
2868 gfc_conv_intrinsic_singlebitop (se, expr, 1);
2871 case GFC_ISYM_IACHAR:
2872 case GFC_ISYM_ICHAR:
2873 /* We assume ASCII character sequence. */
2874 gfc_conv_intrinsic_ichar (se, expr);
2877 case GFC_ISYM_IARGC:
2878 gfc_conv_intrinsic_iargc (se, expr, FALSE);
2882 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
2885 case GFC_ISYM_INDEX:
2886 gfc_conv_intrinsic_index (se, expr);
2890 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
2893 case GFC_ISYM_ISHFT:
2894 gfc_conv_intrinsic_ishft (se, expr);
2897 case GFC_ISYM_ISHFTC:
2898 gfc_conv_intrinsic_ishftc (se, expr);
2901 case GFC_ISYM_LBOUND:
2902 gfc_conv_intrinsic_bound (se, expr, 0);
2906 gfc_conv_intrinsic_len (se, expr);
2909 case GFC_ISYM_LEN_TRIM:
2910 gfc_conv_intrinsic_len_trim (se, expr);
2914 gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
2918 gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
2922 gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
2926 gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
2930 gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
2933 case GFC_ISYM_MAXLOC:
2934 gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
2937 case GFC_ISYM_MAXVAL:
2938 gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
2941 case GFC_ISYM_MERGE:
2942 gfc_conv_intrinsic_merge (se, expr);
2946 gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
2949 case GFC_ISYM_MINLOC:
2950 gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
2953 case GFC_ISYM_MINVAL:
2954 gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
2958 gfc_conv_intrinsic_not (se, expr);
2961 case GFC_ISYM_PRESENT:
2962 gfc_conv_intrinsic_present (se, expr);
2965 case GFC_ISYM_PRODUCT:
2966 gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
2970 gfc_conv_intrinsic_sign (se, expr);
2974 gfc_conv_intrinsic_size (se, expr);
2978 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
2981 case GFC_ISYM_TRANSFER:
2982 gfc_conv_intrinsic_transfer (se, expr);
2985 case GFC_ISYM_UBOUND:
2986 gfc_conv_intrinsic_bound (se, expr, 1);
2989 case GFC_ISYM_DOT_PRODUCT:
2990 case GFC_ISYM_ETIME:
2992 case GFC_ISYM_FSTAT:
2993 case GFC_ISYM_GETCWD:
2994 case GFC_ISYM_GETGID:
2995 case GFC_ISYM_GETPID:
2996 case GFC_ISYM_GETUID:
2997 case GFC_ISYM_IRAND:
2998 case GFC_ISYM_MATMUL:
3000 case GFC_ISYM_SECOND:
3002 case GFC_ISYM_SYSTEM:
3003 case GFC_ISYM_UMASK:
3004 case GFC_ISYM_UNLINK:
3005 gfc_conv_intrinsic_funcall (se, expr);
3009 gfc_conv_intrinsic_lib_function (se, expr);
3015 /* This generates code to execute before entering the scalarization loop.
3016 Currently does nothing. */
3019 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
3021 switch (ss->expr->value.function.isym->generic_id)
3023 case GFC_ISYM_UBOUND:
3024 case GFC_ISYM_LBOUND:
3033 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
3034 inside the scalarization loop. */
3037 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
3041 /* The two argument version returns a scalar. */
3042 if (expr->value.function.actual->next->expr)
3045 newss = gfc_get_ss ();
3046 newss->type = GFC_SS_INTRINSIC;
3054 /* Walk an intrinsic array libcall. */
3057 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
3061 gcc_assert (expr->rank > 0);
3063 newss = gfc_get_ss ();
3064 newss->type = GFC_SS_FUNCTION;
3067 newss->data.info.dimen = expr->rank;
3073 /* Returns nonzero if the specified intrinsic function call maps directly to a
3074 an external library call. Should only be used for functions that return
3078 gfc_is_intrinsic_libcall (gfc_expr * expr)
3080 gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
3081 gcc_assert (expr->rank > 0);
3083 switch (expr->value.function.isym->generic_id)
3087 case GFC_ISYM_COUNT:
3088 case GFC_ISYM_MATMUL:
3089 case GFC_ISYM_MAXLOC:
3090 case GFC_ISYM_MAXVAL:
3091 case GFC_ISYM_MINLOC:
3092 case GFC_ISYM_MINVAL:
3093 case GFC_ISYM_PRODUCT:
3095 case GFC_ISYM_SHAPE:
3096 case GFC_ISYM_SPREAD:
3097 case GFC_ISYM_TRANSPOSE:
3098 /* Ignore absent optional parameters. */
3101 case GFC_ISYM_RESHAPE:
3102 case GFC_ISYM_CSHIFT:
3103 case GFC_ISYM_EOSHIFT:
3105 case GFC_ISYM_UNPACK:
3106 /* Pass absent optional parameters. */
3114 /* Walk an intrinsic function. */
3116 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
3117 gfc_intrinsic_sym * isym)
3121 if (isym->elemental)
3122 return gfc_walk_elemental_function_args (ss, expr, GFC_SS_SCALAR);
3124 if (expr->rank == 0)
3127 if (gfc_is_intrinsic_libcall (expr))
3128 return gfc_walk_intrinsic_libfunc (ss, expr);
3130 /* Special cases. */
3131 switch (isym->generic_id)
3133 case GFC_ISYM_LBOUND:
3134 case GFC_ISYM_UBOUND:
3135 return gfc_walk_intrinsic_bound (ss, expr);
3138 /* This probably meant someone forgot to add an intrinsic to the above
3139 list(s) when they implemented it, or something's gone horribly wrong.
3141 gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
3142 expr->value.function.name);
3146 #include "gt-fortran-trans-intrinsic.h"