1 /* Intrinsic translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
27 #include "coretypes.h"
33 #include "tree-gimple.h"
37 #include "intrinsic.h"
39 #include "trans-const.h"
40 #include "trans-types.h"
41 #include "trans-array.h"
43 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
44 #include "trans-stmt.h"
46 /* This maps fortran intrinsic math functions to external library or GCC
48 typedef struct gfc_intrinsic_map_t GTY(())
50 /* The explicit enum is required to work around inadequacies in the
51 garbage collection/gengtype parsing mechanism. */
54 /* Enum value from the "language-independent", aka C-centric, part
55 of gcc, or END_BUILTINS of no such value set. */
56 enum built_in_function code_r4;
57 enum built_in_function code_r8;
58 enum built_in_function code_r10;
59 enum built_in_function code_r16;
60 enum built_in_function code_c4;
61 enum built_in_function code_c8;
62 enum built_in_function code_c10;
63 enum built_in_function code_c16;
65 /* True if the naming pattern is to prepend "c" for complex and
66 append "f" for kind=4. False if the naming pattern is to
67 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
70 /* True if a complex version of the function exists. */
71 bool complex_available;
73 /* True if the function should be marked const. */
76 /* The base library name of this function. */
79 /* Cache decls created for the various operand types. */
91 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
92 defines complex variants of all of the entries in mathbuiltins.def
94 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
95 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
96 BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, 0, 0, 0, 0, true, \
97 false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
98 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
100 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
101 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
102 BUILT_IN_ ## ID ## L, BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, \
103 BUILT_IN_C ## ID, BUILT_IN_C ## ID ## L, BUILT_IN_C ## ID ## L, true, \
104 true, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
105 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
107 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
108 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
109 END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
110 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
111 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
113 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
115 /* Functions built into gcc itself. */
116 #include "mathbuiltins.def"
118 /* Functions in libgfortran. */
119 LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false),
122 LIB_FUNCTION (NONE, NULL, false)
126 #undef DEFINE_MATH_BUILTIN
127 #undef DEFINE_MATH_BUILTIN_C
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. */
148 enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
150 /* Evaluate the arguments to an intrinsic function. The value
151 of NARGS may be less than the actual number of arguments in EXPR
152 to allow optional "KIND" arguments that are not included in the
153 generated code to be ignored. */
156 gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
157 tree *argarray, int nargs)
159 gfc_actual_arglist *actual;
161 gfc_intrinsic_arg *formal;
165 formal = expr->value.function.isym->formal;
166 actual = expr->value.function.actual;
168 for (curr_arg = 0; curr_arg < nargs; curr_arg++,
169 actual = actual->next,
170 formal = formal ? formal->next : NULL)
174 /* Skip omitted optional arguments. */
181 /* Evaluate the parameter. This will substitute scalarized
182 references automatically. */
183 gfc_init_se (&argse, se);
185 if (e->ts.type == BT_CHARACTER)
187 gfc_conv_expr (&argse, e);
188 gfc_conv_string_parameter (&argse);
189 argarray[curr_arg++] = argse.string_length;
190 gcc_assert (curr_arg < nargs);
193 gfc_conv_expr_val (&argse, e);
195 /* If an optional argument is itself an optional dummy argument,
196 check its presence and substitute a null if absent. */
197 if (e->expr_type == EXPR_VARIABLE
198 && e->symtree->n.sym->attr.optional
201 gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
203 gfc_add_block_to_block (&se->pre, &argse.pre);
204 gfc_add_block_to_block (&se->post, &argse.post);
205 argarray[curr_arg] = argse.expr;
209 /* Count the number of actual arguments to the intrinsic function EXPR
210 including any "hidden" string length arguments. */
213 gfc_intrinsic_argument_list_length (gfc_expr *expr)
216 gfc_actual_arglist *actual;
218 for (actual = expr->value.function.actual; actual; actual = actual->next)
223 if (actual->expr->ts.type == BT_CHARACTER)
233 /* Conversions between different types are output by the frontend as
234 intrinsic functions. We implement these directly with inline code. */
237 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
243 nargs = gfc_intrinsic_argument_list_length (expr);
244 args = alloca (sizeof (tree) * nargs);
246 /* Evaluate all the arguments passed. Whilst we're only interested in the
247 first one here, there are other parts of the front-end that assume this
248 and will trigger an ICE if it's not the case. */
249 type = gfc_typenode_for_spec (&expr->ts);
250 gcc_assert (expr->value.function.actual->expr);
251 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
253 /* Conversion from complex to non-complex involves taking the real
254 component of the value. */
255 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
256 && expr->ts.type != BT_COMPLEX)
260 artype = TREE_TYPE (TREE_TYPE (args[0]));
261 args[0] = fold_build1 (REALPART_EXPR, artype, args[0]);
264 se->expr = convert (type, args[0]);
267 /* This is needed because the gcc backend only implements
268 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
269 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
270 Similarly for CEILING. */
273 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
280 argtype = TREE_TYPE (arg);
281 arg = gfc_evaluate_now (arg, pblock);
283 intval = convert (type, arg);
284 intval = gfc_evaluate_now (intval, pblock);
286 tmp = convert (argtype, intval);
287 cond = fold_build2 (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);
289 tmp = fold_build2 (up ? PLUS_EXPR : MINUS_EXPR, type, intval,
290 build_int_cst (type, 1));
291 tmp = fold_build3 (COND_EXPR, type, cond, intval, tmp);
296 /* Round to nearest integer, away from zero. */
299 build_round_expr (tree arg, tree restype)
304 int argprec, resprec;
306 argtype = TREE_TYPE (arg);
307 argprec = TYPE_PRECISION (argtype);
308 resprec = TYPE_PRECISION (restype);
310 /* Depending on the type of the result, choose the long int intrinsic
311 (lround family) or long long intrinsic (llround). We might also
312 need to convert the result afterwards. */
313 if (resprec <= LONG_TYPE_SIZE)
315 else if (resprec <= LONG_LONG_TYPE_SIZE)
320 /* Now, depending on the argument type, we choose between intrinsics. */
321 if (argprec == TYPE_PRECISION (float_type_node))
322 fn = built_in_decls[longlong ? BUILT_IN_LLROUNDF : BUILT_IN_LROUNDF];
323 else if (argprec == TYPE_PRECISION (double_type_node))
324 fn = built_in_decls[longlong ? BUILT_IN_LLROUND : BUILT_IN_LROUND];
325 else if (argprec == TYPE_PRECISION (long_double_type_node))
326 fn = built_in_decls[longlong ? BUILT_IN_LLROUNDL : BUILT_IN_LROUNDL];
330 return fold_convert (restype, build_call_expr (fn, 1, arg));
334 /* Convert a real to an integer using a specific rounding mode.
335 Ideally we would just build the corresponding GENERIC node,
336 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
339 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
340 enum rounding_mode op)
345 return build_fixbound_expr (pblock, arg, type, 0);
349 return build_fixbound_expr (pblock, arg, type, 1);
353 return build_round_expr (arg, type);
357 return fold_build1 (FIX_TRUNC_EXPR, type, arg);
366 /* Round a real value using the specified rounding mode.
367 We use a temporary integer of that same kind size as the result.
368 Values larger than those that can be represented by this kind are
369 unchanged, as they will not be accurate enough to represent the
371 huge = HUGE (KIND (a))
372 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
376 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
387 kind = expr->ts.kind;
388 nargs = gfc_intrinsic_argument_list_length (expr);
391 /* We have builtin functions for some cases. */
434 /* Evaluate the argument. */
435 gcc_assert (expr->value.function.actual->expr);
436 gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
438 /* Use a builtin function if one exists. */
439 if (n != END_BUILTINS)
441 tmp = built_in_decls[n];
442 se->expr = build_call_expr (tmp, 1, arg[0]);
446 /* This code is probably redundant, but we'll keep it lying around just
448 type = gfc_typenode_for_spec (&expr->ts);
449 arg[0] = gfc_evaluate_now (arg[0], &se->pre);
451 /* Test if the value is too large to handle sensibly. */
452 gfc_set_model_kind (kind);
454 n = gfc_validate_kind (BT_INTEGER, kind, false);
455 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
456 tmp = gfc_conv_mpfr_to_tree (huge, kind);
457 cond = fold_build2 (LT_EXPR, boolean_type_node, arg[0], tmp);
459 mpfr_neg (huge, huge, GFC_RND_MODE);
460 tmp = gfc_conv_mpfr_to_tree (huge, kind);
461 tmp = fold_build2 (GT_EXPR, boolean_type_node, arg[0], tmp);
462 cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
463 itype = gfc_get_int_type (kind);
465 tmp = build_fix_expr (&se->pre, arg[0], itype, op);
466 tmp = convert (type, tmp);
467 se->expr = fold_build3 (COND_EXPR, type, cond, tmp, arg[0]);
472 /* Convert to an integer using the specified rounding mode. */
475 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
481 nargs = gfc_intrinsic_argument_list_length (expr);
482 args = alloca (sizeof (tree) * nargs);
484 /* Evaluate the argument, we process all arguments even though we only
485 use the first one for code generation purposes. */
486 type = gfc_typenode_for_spec (&expr->ts);
487 gcc_assert (expr->value.function.actual->expr);
488 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
490 if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
492 /* Conversion to a different integer kind. */
493 se->expr = convert (type, args[0]);
497 /* Conversion from complex to non-complex involves taking the real
498 component of the value. */
499 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
500 && expr->ts.type != BT_COMPLEX)
504 artype = TREE_TYPE (TREE_TYPE (args[0]));
505 args[0] = fold_build1 (REALPART_EXPR, artype, args[0]);
508 se->expr = build_fix_expr (&se->pre, args[0], type, op);
513 /* Get the imaginary component of a value. */
516 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
520 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
521 se->expr = fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
525 /* Get the complex conjugate of a value. */
528 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
532 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
533 se->expr = fold_build1 (CONJ_EXPR, TREE_TYPE (arg), arg);
537 /* Initialize function decls for library functions. The external functions
538 are created as required. Builtin functions are added here. */
541 gfc_build_intrinsic_lib_fndecls (void)
543 gfc_intrinsic_map_t *m;
545 /* Add GCC builtin functions. */
546 for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
548 if (m->code_r4 != END_BUILTINS)
549 m->real4_decl = built_in_decls[m->code_r4];
550 if (m->code_r8 != END_BUILTINS)
551 m->real8_decl = built_in_decls[m->code_r8];
552 if (m->code_r10 != END_BUILTINS)
553 m->real10_decl = built_in_decls[m->code_r10];
554 if (m->code_r16 != END_BUILTINS)
555 m->real16_decl = built_in_decls[m->code_r16];
556 if (m->code_c4 != END_BUILTINS)
557 m->complex4_decl = built_in_decls[m->code_c4];
558 if (m->code_c8 != END_BUILTINS)
559 m->complex8_decl = built_in_decls[m->code_c8];
560 if (m->code_c10 != END_BUILTINS)
561 m->complex10_decl = built_in_decls[m->code_c10];
562 if (m->code_c16 != END_BUILTINS)
563 m->complex16_decl = built_in_decls[m->code_c16];
568 /* Create a fndecl for a simple intrinsic library function. */
571 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
576 gfc_actual_arglist *actual;
579 char name[GFC_MAX_SYMBOL_LEN + 3];
582 if (ts->type == BT_REAL)
587 pdecl = &m->real4_decl;
590 pdecl = &m->real8_decl;
593 pdecl = &m->real10_decl;
596 pdecl = &m->real16_decl;
602 else if (ts->type == BT_COMPLEX)
604 gcc_assert (m->complex_available);
609 pdecl = &m->complex4_decl;
612 pdecl = &m->complex8_decl;
615 pdecl = &m->complex10_decl;
618 pdecl = &m->complex16_decl;
633 snprintf (name, sizeof (name), "%s%s%s",
634 ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
635 else if (ts->kind == 8)
636 snprintf (name, sizeof (name), "%s%s",
637 ts->type == BT_COMPLEX ? "c" : "", m->name);
640 gcc_assert (ts->kind == 10 || ts->kind == 16);
641 snprintf (name, sizeof (name), "%s%s%s",
642 ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
647 snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
648 ts->type == BT_COMPLEX ? 'c' : 'r',
652 argtypes = NULL_TREE;
653 for (actual = expr->value.function.actual; actual; actual = actual->next)
655 type = gfc_typenode_for_spec (&actual->expr->ts);
656 argtypes = gfc_chainon_list (argtypes, type);
658 argtypes = gfc_chainon_list (argtypes, void_type_node);
659 type = build_function_type (gfc_typenode_for_spec (ts), argtypes);
660 fndecl = build_decl (FUNCTION_DECL, get_identifier (name), type);
662 /* Mark the decl as external. */
663 DECL_EXTERNAL (fndecl) = 1;
664 TREE_PUBLIC (fndecl) = 1;
666 /* Mark it __attribute__((const)), if possible. */
667 TREE_READONLY (fndecl) = m->is_constant;
669 rest_of_decl_compilation (fndecl, 1, 0);
676 /* Convert an intrinsic function into an external or builtin call. */
679 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
681 gfc_intrinsic_map_t *m;
685 unsigned int num_args;
688 id = expr->value.function.isym->id;
689 /* Find the entry for this function. */
690 for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
696 if (m->id == GFC_ISYM_NONE)
698 internal_error ("Intrinsic function %s(%d) not recognized",
699 expr->value.function.name, id);
702 /* Get the decl and generate the call. */
703 num_args = gfc_intrinsic_argument_list_length (expr);
704 args = alloca (sizeof (tree) * num_args);
706 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
707 fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
708 rettype = TREE_TYPE (TREE_TYPE (fndecl));
710 fndecl = build_addr (fndecl, current_function_decl);
711 se->expr = build_call_array (rettype, fndecl, num_args, args);
714 /* The EXPONENT(s) intrinsic function is translated into
721 gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
723 tree arg, type, res, tmp;
726 switch (expr->value.function.actual->expr->ts.kind)
729 frexp = BUILT_IN_FREXPF;
732 frexp = BUILT_IN_FREXP;
736 frexp = BUILT_IN_FREXPL;
742 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
744 res = gfc_create_var (integer_type_node, NULL);
745 tmp = build_call_expr (built_in_decls[frexp], 2, arg,
746 build_fold_addr_expr (res));
747 gfc_add_expr_to_block (&se->pre, tmp);
749 type = gfc_typenode_for_spec (&expr->ts);
750 se->expr = fold_convert (type, res);
753 /* Evaluate a single upper or lower bound. */
754 /* TODO: bound intrinsic generates way too much unnecessary code. */
757 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
759 gfc_actual_arglist *arg;
760 gfc_actual_arglist *arg2;
765 tree cond, cond1, cond2, cond3, cond4, size;
773 arg = expr->value.function.actual;
778 /* Create an implicit second parameter from the loop variable. */
779 gcc_assert (!arg2->expr);
780 gcc_assert (se->loop->dimen == 1);
781 gcc_assert (se->ss->expr == expr);
782 gfc_advance_se_ss_chain (se);
783 bound = se->loop->loopvar[0];
784 bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
789 /* use the passed argument. */
790 gcc_assert (arg->next->expr);
791 gfc_init_se (&argse, NULL);
792 gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
793 gfc_add_block_to_block (&se->pre, &argse.pre);
795 /* Convert from one based to zero based. */
796 bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
800 /* TODO: don't re-evaluate the descriptor on each iteration. */
801 /* Get a descriptor for the first parameter. */
802 ss = gfc_walk_expr (arg->expr);
803 gcc_assert (ss != gfc_ss_terminator);
804 gfc_init_se (&argse, NULL);
805 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
806 gfc_add_block_to_block (&se->pre, &argse.pre);
807 gfc_add_block_to_block (&se->post, &argse.post);
811 if (INTEGER_CST_P (bound))
815 hi = TREE_INT_CST_HIGH (bound);
816 low = TREE_INT_CST_LOW (bound);
817 if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
818 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
819 "dimension index", upper ? "UBOUND" : "LBOUND",
824 if (flag_bounds_check)
826 bound = gfc_evaluate_now (bound, &se->pre);
827 cond = fold_build2 (LT_EXPR, boolean_type_node,
828 bound, build_int_cst (TREE_TYPE (bound), 0));
829 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
830 tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
831 cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
832 gfc_trans_runtime_check (cond, &se->pre, &expr->where, gfc_msg_fault);
836 ubound = gfc_conv_descriptor_ubound (desc, bound);
837 lbound = gfc_conv_descriptor_lbound (desc, bound);
839 /* Follow any component references. */
840 if (arg->expr->expr_type == EXPR_VARIABLE
841 || arg->expr->expr_type == EXPR_CONSTANT)
843 as = arg->expr->symtree->n.sym->as;
844 for (ref = arg->expr->ref; ref; ref = ref->next)
849 as = ref->u.c.component->as;
857 switch (ref->u.ar.type)
875 /* 13.14.53: Result value for LBOUND
877 Case (i): For an array section or for an array expression other than a
878 whole array or array structure component, LBOUND(ARRAY, DIM)
879 has the value 1. For a whole array or array structure
880 component, LBOUND(ARRAY, DIM) has the value:
881 (a) equal to the lower bound for subscript DIM of ARRAY if
882 dimension DIM of ARRAY does not have extent zero
883 or if ARRAY is an assumed-size array of rank DIM,
886 13.14.113: Result value for UBOUND
888 Case (i): For an array section or for an array expression other than a
889 whole array or array structure component, UBOUND(ARRAY, DIM)
890 has the value equal to the number of elements in the given
891 dimension; otherwise, it has a value equal to the upper bound
892 for subscript DIM of ARRAY if dimension DIM of ARRAY does
893 not have size zero and has value zero if dimension DIM has
898 tree stride = gfc_conv_descriptor_stride (desc, bound);
900 cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound);
901 cond2 = fold_build2 (LE_EXPR, boolean_type_node, ubound, lbound);
903 cond3 = fold_build2 (GE_EXPR, boolean_type_node, stride,
904 gfc_index_zero_node);
905 cond3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
907 cond4 = fold_build2 (LT_EXPR, boolean_type_node, stride,
908 gfc_index_zero_node);
909 cond4 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond4, cond2);
913 cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
915 se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
916 ubound, gfc_index_zero_node);
920 if (as->type == AS_ASSUMED_SIZE)
921 cond = fold_build2 (EQ_EXPR, boolean_type_node, bound,
922 build_int_cst (TREE_TYPE (bound),
923 arg->expr->rank - 1));
925 cond = boolean_false_node;
927 cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
928 cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1);
930 se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
931 lbound, gfc_index_one_node);
938 size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
939 se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
943 se->expr = gfc_index_one_node;
946 type = gfc_typenode_for_spec (&expr->ts);
947 se->expr = convert (type, se->expr);
952 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
957 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
959 switch (expr->value.function.actual->expr->ts.type)
963 se->expr = fold_build1 (ABS_EXPR, TREE_TYPE (arg), arg);
967 switch (expr->ts.kind)
982 se->expr = build_call_expr (built_in_decls[n], 1, arg);
991 /* Create a complex value from one or two real components. */
994 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
1000 unsigned int num_args;
1002 num_args = gfc_intrinsic_argument_list_length (expr);
1003 args = alloca (sizeof (tree) * num_args);
1005 type = gfc_typenode_for_spec (&expr->ts);
1006 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
1007 real = convert (TREE_TYPE (type), args[0]);
1009 imag = convert (TREE_TYPE (type), args[1]);
1010 else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
1012 imag = fold_build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (args[0])),
1014 imag = convert (TREE_TYPE (type), imag);
1017 imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
1019 se->expr = fold_build2 (COMPLEX_EXPR, type, real, imag);
1022 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1023 MODULO(A, P) = A - FLOOR (A / P) * P */
1024 /* TODO: MOD(x, 0) */
1027 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
1038 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1040 switch (expr->ts.type)
1043 /* Integer case is easy, we've got a builtin op. */
1044 type = TREE_TYPE (args[0]);
1047 se->expr = fold_build2 (FLOOR_MOD_EXPR, type, args[0], args[1]);
1049 se->expr = fold_build2 (TRUNC_MOD_EXPR, type, args[0], args[1]);
1054 /* Check if we have a builtin fmod. */
1055 switch (expr->ts.kind)
1074 /* Use it if it exists. */
1075 if (n != END_BUILTINS)
1077 tmp = build_addr (built_in_decls[n], current_function_decl);
1078 se->expr = build_call_array (TREE_TYPE (TREE_TYPE (built_in_decls[n])),
1084 type = TREE_TYPE (args[0]);
1086 args[0] = gfc_evaluate_now (args[0], &se->pre);
1087 args[1] = gfc_evaluate_now (args[1], &se->pre);
1090 modulo = arg - floor (arg/arg2) * arg2, so
1091 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1093 test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1094 thereby avoiding another division and retaining the accuracy
1095 of the builtin function. */
1096 if (n != END_BUILTINS && modulo)
1098 tree zero = gfc_build_const (type, integer_zero_node);
1099 tmp = gfc_evaluate_now (se->expr, &se->pre);
1100 test = fold_build2 (LT_EXPR, boolean_type_node, args[0], zero);
1101 test2 = fold_build2 (LT_EXPR, boolean_type_node, args[1], zero);
1102 test2 = fold_build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2);
1103 test = fold_build2 (NE_EXPR, boolean_type_node, tmp, zero);
1104 test = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1105 test = gfc_evaluate_now (test, &se->pre);
1106 se->expr = fold_build3 (COND_EXPR, type, test,
1107 fold_build2 (PLUS_EXPR, type, tmp, args[1]),
1112 /* If we do not have a built_in fmod, the calculation is going to
1113 have to be done longhand. */
1114 tmp = fold_build2 (RDIV_EXPR, type, args[0], args[1]);
1116 /* Test if the value is too large to handle sensibly. */
1117 gfc_set_model_kind (expr->ts.kind);
1119 n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true);
1120 ikind = expr->ts.kind;
1123 n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false);
1124 ikind = gfc_max_integer_kind;
1126 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
1127 test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
1128 test2 = fold_build2 (LT_EXPR, boolean_type_node, tmp, test);
1130 mpfr_neg (huge, huge, GFC_RND_MODE);
1131 test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
1132 test = fold_build2 (GT_EXPR, boolean_type_node, tmp, test);
1133 test2 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1135 itype = gfc_get_int_type (ikind);
1137 tmp = build_fix_expr (&se->pre, tmp, itype, RND_FLOOR);
1139 tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC);
1140 tmp = convert (type, tmp);
1141 tmp = fold_build3 (COND_EXPR, type, test2, tmp, args[0]);
1142 tmp = fold_build2 (MULT_EXPR, type, tmp, args[1]);
1143 se->expr = fold_build2 (MINUS_EXPR, type, args[0], tmp);
1152 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
1155 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
1163 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1164 type = TREE_TYPE (args[0]);
1166 val = fold_build2 (MINUS_EXPR, type, args[0], args[1]);
1167 val = gfc_evaluate_now (val, &se->pre);
1169 zero = gfc_build_const (type, integer_zero_node);
1170 tmp = fold_build2 (LE_EXPR, boolean_type_node, val, zero);
1171 se->expr = fold_build3 (COND_EXPR, type, tmp, zero, val);
1175 /* SIGN(A, B) is absolute value of A times sign of B.
1176 The real value versions use library functions to ensure the correct
1177 handling of negative zero. Integer case implemented as:
1178 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1182 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
1188 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1189 if (expr->ts.type == BT_REAL)
1191 switch (expr->ts.kind)
1194 tmp = built_in_decls[BUILT_IN_COPYSIGNF];
1197 tmp = built_in_decls[BUILT_IN_COPYSIGN];
1201 tmp = built_in_decls[BUILT_IN_COPYSIGNL];
1206 se->expr = build_call_expr (tmp, 2, args[0], args[1]);
1210 /* Having excluded floating point types, we know we are now dealing
1211 with signed integer types. */
1212 type = TREE_TYPE (args[0]);
1214 /* Args[0] is used multiple times below. */
1215 args[0] = gfc_evaluate_now (args[0], &se->pre);
1217 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1218 the signs of A and B are the same, and of all ones if they differ. */
1219 tmp = fold_build2 (BIT_XOR_EXPR, type, args[0], args[1]);
1220 tmp = fold_build2 (RSHIFT_EXPR, type, tmp,
1221 build_int_cst (type, TYPE_PRECISION (type) - 1));
1222 tmp = gfc_evaluate_now (tmp, &se->pre);
1224 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1225 is all ones (i.e. -1). */
1226 se->expr = fold_build2 (BIT_XOR_EXPR, type,
1227 fold_build2 (PLUS_EXPR, type, args[0], tmp),
1232 /* Test for the presence of an optional argument. */
1235 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
1239 arg = expr->value.function.actual->expr;
1240 gcc_assert (arg->expr_type == EXPR_VARIABLE);
1241 se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
1242 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
1246 /* Calculate the double precision product of two single precision values. */
1249 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
1254 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1256 /* Convert the args to double precision before multiplying. */
1257 type = gfc_typenode_for_spec (&expr->ts);
1258 args[0] = convert (type, args[0]);
1259 args[1] = convert (type, args[1]);
1260 se->expr = fold_build2 (MULT_EXPR, type, args[0], args[1]);
1264 /* Return a length one character string containing an ascii character. */
1267 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
1272 unsigned int num_args;
1274 /* We must allow for the KIND argument, even though.... */
1275 num_args = gfc_intrinsic_argument_list_length (expr);
1276 gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
1278 /* .... we currently don't support character types != 1. */
1279 gcc_assert (expr->ts.kind == 1);
1280 type = gfc_character1_type_node;
1281 var = gfc_create_var (type, "char");
1283 arg[0] = convert (type, arg[0]);
1284 gfc_add_modify_expr (&se->pre, var, arg[0]);
1285 se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
1286 se->string_length = integer_one_node;
1291 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
1298 tree gfc_int8_type_node = gfc_get_int_type (8);
1301 unsigned int num_args;
1303 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1304 args = alloca (sizeof (tree) * num_args);
1306 type = build_pointer_type (gfc_character1_type_node);
1307 var = gfc_create_var (type, "pstr");
1308 len = gfc_create_var (gfc_int8_type_node, "len");
1310 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1311 args[0] = build_fold_addr_expr (var);
1312 args[1] = build_fold_addr_expr (len);
1314 fndecl = build_addr (gfor_fndecl_ctime, current_function_decl);
1315 tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
1316 fndecl, num_args, args);
1317 gfc_add_expr_to_block (&se->pre, tmp);
1319 /* Free the temporary afterwards, if necessary. */
1320 cond = fold_build2 (GT_EXPR, boolean_type_node,
1321 len, build_int_cst (TREE_TYPE (len), 0));
1322 tmp = gfc_call_free (var);
1323 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1324 gfc_add_expr_to_block (&se->post, tmp);
1327 se->string_length = len;
1332 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
1339 tree gfc_int4_type_node = gfc_get_int_type (4);
1342 unsigned int num_args;
1344 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1345 args = alloca (sizeof (tree) * num_args);
1347 type = build_pointer_type (gfc_character1_type_node);
1348 var = gfc_create_var (type, "pstr");
1349 len = gfc_create_var (gfc_int4_type_node, "len");
1351 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1352 args[0] = build_fold_addr_expr (var);
1353 args[1] = build_fold_addr_expr (len);
1355 fndecl = build_addr (gfor_fndecl_fdate, current_function_decl);
1356 tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
1357 fndecl, num_args, args);
1358 gfc_add_expr_to_block (&se->pre, tmp);
1360 /* Free the temporary afterwards, if necessary. */
1361 cond = fold_build2 (GT_EXPR, boolean_type_node,
1362 len, build_int_cst (TREE_TYPE (len), 0));
1363 tmp = gfc_call_free (var);
1364 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1365 gfc_add_expr_to_block (&se->post, tmp);
1368 se->string_length = len;
1372 /* Return a character string containing the tty name. */
1375 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
1383 tree gfc_int4_type_node = gfc_get_int_type (4);
1385 unsigned int num_args;
1387 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1388 args = alloca (sizeof (tree) * num_args);
1390 type = build_pointer_type (gfc_character1_type_node);
1391 var = gfc_create_var (type, "pstr");
1392 len = gfc_create_var (gfc_int4_type_node, "len");
1394 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1395 args[0] = build_fold_addr_expr (var);
1396 args[1] = build_fold_addr_expr (len);
1398 fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl);
1399 tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
1400 fndecl, num_args, args);
1401 gfc_add_expr_to_block (&se->pre, tmp);
1403 /* Free the temporary afterwards, if necessary. */
1404 cond = fold_build2 (GT_EXPR, boolean_type_node,
1405 len, build_int_cst (TREE_TYPE (len), 0));
1406 tmp = gfc_call_free (var);
1407 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1408 gfc_add_expr_to_block (&se->post, tmp);
1411 se->string_length = len;
1415 /* Get the minimum/maximum value of all the parameters.
1416 minmax (a1, a2, a3, ...)
1419 if (a2 .op. mvar || isnan(mvar))
1421 if (a3 .op. mvar || isnan(mvar))
1428 /* TODO: Mismatching types can occur when specific names are used.
1429 These should be handled during resolution. */
1431 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
1439 gfc_actual_arglist *argexpr;
1440 unsigned int i, nargs;
1442 nargs = gfc_intrinsic_argument_list_length (expr);
1443 args = alloca (sizeof (tree) * nargs);
1445 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
1446 type = gfc_typenode_for_spec (&expr->ts);
1448 argexpr = expr->value.function.actual;
1449 if (TREE_TYPE (args[0]) != type)
1450 args[0] = convert (type, args[0]);
1451 /* Only evaluate the argument once. */
1452 if (TREE_CODE (args[0]) != VAR_DECL && !TREE_CONSTANT (args[0]))
1453 args[0] = gfc_evaluate_now (args[0], &se->pre);
1455 mvar = gfc_create_var (type, "M");
1456 gfc_add_modify_expr (&se->pre, mvar, args[0]);
1457 for (i = 1, argexpr = argexpr->next; i < nargs; i++)
1463 /* Handle absent optional arguments by ignoring the comparison. */
1464 if (argexpr->expr->expr_type == EXPR_VARIABLE
1465 && argexpr->expr->symtree->n.sym->attr.optional
1466 && TREE_CODE (val) == INDIRECT_REF)
1468 (NE_EXPR, boolean_type_node, TREE_OPERAND (val, 0),
1469 build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
1474 /* Only evaluate the argument once. */
1475 if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
1476 val = gfc_evaluate_now (val, &se->pre);
1479 thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
1481 tmp = fold_build2 (op, boolean_type_node, convert (type, val), mvar);
1483 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
1484 __builtin_isnan might be made dependent on that module being loaded,
1485 to help performance of programs that don't rely on IEEE semantics. */
1486 if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
1488 isnan = build_call_expr (built_in_decls[BUILT_IN_ISNAN], 1, mvar);
1489 tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp,
1490 fold_convert (boolean_type_node, isnan));
1492 tmp = build3_v (COND_EXPR, tmp, thencase, build_empty_stmt ());
1494 if (cond != NULL_TREE)
1495 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1497 gfc_add_expr_to_block (&se->pre, tmp);
1498 argexpr = argexpr->next;
1504 /* Generate library calls for MIN and MAX intrinsics for character
1507 gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
1510 tree var, len, fndecl, tmp, cond;
1513 nargs = gfc_intrinsic_argument_list_length (expr);
1514 args = alloca (sizeof (tree) * (nargs + 4));
1515 gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
1517 /* Create the result variables. */
1518 len = gfc_create_var (gfc_charlen_type_node, "len");
1519 args[0] = build_fold_addr_expr (len);
1520 var = gfc_create_var (build_pointer_type (gfc_character1_type_node), "pstr");
1521 args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
1522 args[2] = build_int_cst (NULL_TREE, op);
1523 args[3] = build_int_cst (NULL_TREE, nargs / 2);
1525 /* Make the function call. */
1526 fndecl = build_addr (gfor_fndecl_string_minmax, current_function_decl);
1527 tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_minmax)),
1528 fndecl, nargs + 4, args);
1529 gfc_add_expr_to_block (&se->pre, tmp);
1531 /* Free the temporary afterwards, if necessary. */
1532 cond = fold_build2 (GT_EXPR, boolean_type_node,
1533 len, build_int_cst (TREE_TYPE (len), 0));
1534 tmp = gfc_call_free (var);
1535 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1536 gfc_add_expr_to_block (&se->post, tmp);
1539 se->string_length = len;
1543 /* Create a symbol node for this intrinsic. The symbol from the frontend
1544 has the generic name. */
1547 gfc_get_symbol_for_expr (gfc_expr * expr)
1551 /* TODO: Add symbols for intrinsic function to the global namespace. */
1552 gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
1553 sym = gfc_new_symbol (expr->value.function.name, NULL);
1556 sym->attr.external = 1;
1557 sym->attr.function = 1;
1558 sym->attr.always_explicit = 1;
1559 sym->attr.proc = PROC_INTRINSIC;
1560 sym->attr.flavor = FL_PROCEDURE;
1564 sym->attr.dimension = 1;
1565 sym->as = gfc_get_array_spec ();
1566 sym->as->type = AS_ASSUMED_SHAPE;
1567 sym->as->rank = expr->rank;
1570 /* TODO: proper argument lists for external intrinsics. */
1574 /* Generate a call to an external intrinsic function. */
1576 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
1581 gcc_assert (!se->ss || se->ss->expr == expr);
1584 gcc_assert (expr->rank > 0);
1586 gcc_assert (expr->rank == 0);
1588 sym = gfc_get_symbol_for_expr (expr);
1590 /* Calls to libgfortran_matmul need to be appended special arguments,
1591 to be able to call the BLAS ?gemm functions if required and possible. */
1592 append_args = NULL_TREE;
1593 if (expr->value.function.isym->id == GFC_ISYM_MATMUL
1594 && sym->ts.type != BT_LOGICAL)
1596 tree cint = gfc_get_int_type (gfc_c_int_kind);
1598 if (gfc_option.flag_external_blas
1599 && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
1600 && (sym->ts.kind == gfc_default_real_kind
1601 || sym->ts.kind == gfc_default_double_kind))
1605 if (sym->ts.type == BT_REAL)
1607 if (sym->ts.kind == gfc_default_real_kind)
1608 gemm_fndecl = gfor_fndecl_sgemm;
1610 gemm_fndecl = gfor_fndecl_dgemm;
1614 if (sym->ts.kind == gfc_default_real_kind)
1615 gemm_fndecl = gfor_fndecl_cgemm;
1617 gemm_fndecl = gfor_fndecl_zgemm;
1620 append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 1));
1621 append_args = gfc_chainon_list
1622 (append_args, build_int_cst
1623 (cint, gfc_option.blas_matmul_limit));
1624 append_args = gfc_chainon_list (append_args,
1625 gfc_build_addr_expr (NULL_TREE,
1630 append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 0));
1631 append_args = gfc_chainon_list (append_args, build_int_cst (cint, 0));
1632 append_args = gfc_chainon_list (append_args, null_pointer_node);
1636 gfc_conv_function_call (se, sym, expr->value.function.actual, append_args);
1640 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1660 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op)
1669 gfc_actual_arglist *actual;
1676 gfc_conv_intrinsic_funcall (se, expr);
1680 actual = expr->value.function.actual;
1681 type = gfc_typenode_for_spec (&expr->ts);
1682 /* Initialize the result. */
1683 resvar = gfc_create_var (type, "test");
1685 tmp = convert (type, boolean_true_node);
1687 tmp = convert (type, boolean_false_node);
1688 gfc_add_modify_expr (&se->pre, resvar, tmp);
1690 /* Walk the arguments. */
1691 arrayss = gfc_walk_expr (actual->expr);
1692 gcc_assert (arrayss != gfc_ss_terminator);
1694 /* Initialize the scalarizer. */
1695 gfc_init_loopinfo (&loop);
1696 exit_label = gfc_build_label_decl (NULL_TREE);
1697 TREE_USED (exit_label) = 1;
1698 gfc_add_ss_to_loop (&loop, arrayss);
1700 /* Initialize the loop. */
1701 gfc_conv_ss_startstride (&loop);
1702 gfc_conv_loop_setup (&loop);
1704 gfc_mark_ss_chain_used (arrayss, 1);
1705 /* Generate the loop body. */
1706 gfc_start_scalarized_body (&loop, &body);
1708 /* If the condition matches then set the return value. */
1709 gfc_start_block (&block);
1711 tmp = convert (type, boolean_false_node);
1713 tmp = convert (type, boolean_true_node);
1714 gfc_add_modify_expr (&block, resvar, tmp);
1716 /* And break out of the loop. */
1717 tmp = build1_v (GOTO_EXPR, exit_label);
1718 gfc_add_expr_to_block (&block, tmp);
1720 found = gfc_finish_block (&block);
1722 /* Check this element. */
1723 gfc_init_se (&arrayse, NULL);
1724 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1725 arrayse.ss = arrayss;
1726 gfc_conv_expr_val (&arrayse, actual->expr);
1728 gfc_add_block_to_block (&body, &arrayse.pre);
1729 tmp = fold_build2 (op, boolean_type_node, arrayse.expr,
1730 build_int_cst (TREE_TYPE (arrayse.expr), 0));
1731 tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt ());
1732 gfc_add_expr_to_block (&body, tmp);
1733 gfc_add_block_to_block (&body, &arrayse.post);
1735 gfc_trans_scalarizing_loops (&loop, &body);
1737 /* Add the exit label. */
1738 tmp = build1_v (LABEL_EXPR, exit_label);
1739 gfc_add_expr_to_block (&loop.pre, tmp);
1741 gfc_add_block_to_block (&se->pre, &loop.pre);
1742 gfc_add_block_to_block (&se->pre, &loop.post);
1743 gfc_cleanup_loop (&loop);
1748 /* COUNT(A) = Number of true elements in A. */
1750 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
1757 gfc_actual_arglist *actual;
1763 gfc_conv_intrinsic_funcall (se, expr);
1767 actual = expr->value.function.actual;
1769 type = gfc_typenode_for_spec (&expr->ts);
1770 /* Initialize the result. */
1771 resvar = gfc_create_var (type, "count");
1772 gfc_add_modify_expr (&se->pre, resvar, build_int_cst (type, 0));
1774 /* Walk the arguments. */
1775 arrayss = gfc_walk_expr (actual->expr);
1776 gcc_assert (arrayss != gfc_ss_terminator);
1778 /* Initialize the scalarizer. */
1779 gfc_init_loopinfo (&loop);
1780 gfc_add_ss_to_loop (&loop, arrayss);
1782 /* Initialize the loop. */
1783 gfc_conv_ss_startstride (&loop);
1784 gfc_conv_loop_setup (&loop);
1786 gfc_mark_ss_chain_used (arrayss, 1);
1787 /* Generate the loop body. */
1788 gfc_start_scalarized_body (&loop, &body);
1790 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (resvar),
1791 resvar, build_int_cst (TREE_TYPE (resvar), 1));
1792 tmp = build2_v (MODIFY_EXPR, resvar, tmp);
1794 gfc_init_se (&arrayse, NULL);
1795 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1796 arrayse.ss = arrayss;
1797 gfc_conv_expr_val (&arrayse, actual->expr);
1798 tmp = build3_v (COND_EXPR, arrayse.expr, tmp, build_empty_stmt ());
1800 gfc_add_block_to_block (&body, &arrayse.pre);
1801 gfc_add_expr_to_block (&body, tmp);
1802 gfc_add_block_to_block (&body, &arrayse.post);
1804 gfc_trans_scalarizing_loops (&loop, &body);
1806 gfc_add_block_to_block (&se->pre, &loop.pre);
1807 gfc_add_block_to_block (&se->pre, &loop.post);
1808 gfc_cleanup_loop (&loop);
1813 /* Inline implementation of the sum and product intrinsics. */
1815 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op)
1823 gfc_actual_arglist *actual;
1828 gfc_expr *arrayexpr;
1833 gfc_conv_intrinsic_funcall (se, expr);
1837 type = gfc_typenode_for_spec (&expr->ts);
1838 /* Initialize the result. */
1839 resvar = gfc_create_var (type, "val");
1840 if (op == PLUS_EXPR)
1841 tmp = gfc_build_const (type, integer_zero_node);
1843 tmp = gfc_build_const (type, integer_one_node);
1845 gfc_add_modify_expr (&se->pre, resvar, tmp);
1847 /* Walk the arguments. */
1848 actual = expr->value.function.actual;
1849 arrayexpr = actual->expr;
1850 arrayss = gfc_walk_expr (arrayexpr);
1851 gcc_assert (arrayss != gfc_ss_terminator);
1853 actual = actual->next->next;
1854 gcc_assert (actual);
1855 maskexpr = actual->expr;
1856 if (maskexpr && maskexpr->rank != 0)
1858 maskss = gfc_walk_expr (maskexpr);
1859 gcc_assert (maskss != gfc_ss_terminator);
1864 /* Initialize the scalarizer. */
1865 gfc_init_loopinfo (&loop);
1866 gfc_add_ss_to_loop (&loop, arrayss);
1868 gfc_add_ss_to_loop (&loop, maskss);
1870 /* Initialize the loop. */
1871 gfc_conv_ss_startstride (&loop);
1872 gfc_conv_loop_setup (&loop);
1874 gfc_mark_ss_chain_used (arrayss, 1);
1876 gfc_mark_ss_chain_used (maskss, 1);
1877 /* Generate the loop body. */
1878 gfc_start_scalarized_body (&loop, &body);
1880 /* If we have a mask, only add this element if the mask is set. */
1883 gfc_init_se (&maskse, NULL);
1884 gfc_copy_loopinfo_to_se (&maskse, &loop);
1886 gfc_conv_expr_val (&maskse, maskexpr);
1887 gfc_add_block_to_block (&body, &maskse.pre);
1889 gfc_start_block (&block);
1892 gfc_init_block (&block);
1894 /* Do the actual summation/product. */
1895 gfc_init_se (&arrayse, NULL);
1896 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1897 arrayse.ss = arrayss;
1898 gfc_conv_expr_val (&arrayse, arrayexpr);
1899 gfc_add_block_to_block (&block, &arrayse.pre);
1901 tmp = fold_build2 (op, type, resvar, arrayse.expr);
1902 gfc_add_modify_expr (&block, resvar, tmp);
1903 gfc_add_block_to_block (&block, &arrayse.post);
1907 /* We enclose the above in if (mask) {...} . */
1908 tmp = gfc_finish_block (&block);
1910 tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1913 tmp = gfc_finish_block (&block);
1914 gfc_add_expr_to_block (&body, tmp);
1916 gfc_trans_scalarizing_loops (&loop, &body);
1918 /* For a scalar mask, enclose the loop in an if statement. */
1919 if (maskexpr && maskss == NULL)
1921 gfc_init_se (&maskse, NULL);
1922 gfc_conv_expr_val (&maskse, maskexpr);
1923 gfc_init_block (&block);
1924 gfc_add_block_to_block (&block, &loop.pre);
1925 gfc_add_block_to_block (&block, &loop.post);
1926 tmp = gfc_finish_block (&block);
1928 tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1929 gfc_add_expr_to_block (&block, tmp);
1930 gfc_add_block_to_block (&se->pre, &block);
1934 gfc_add_block_to_block (&se->pre, &loop.pre);
1935 gfc_add_block_to_block (&se->pre, &loop.post);
1938 gfc_cleanup_loop (&loop);
1944 /* Inline implementation of the dot_product intrinsic. This function
1945 is based on gfc_conv_intrinsic_arith (the previous function). */
1947 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
1955 gfc_actual_arglist *actual;
1956 gfc_ss *arrayss1, *arrayss2;
1957 gfc_se arrayse1, arrayse2;
1958 gfc_expr *arrayexpr1, *arrayexpr2;
1960 type = gfc_typenode_for_spec (&expr->ts);
1962 /* Initialize the result. */
1963 resvar = gfc_create_var (type, "val");
1964 if (expr->ts.type == BT_LOGICAL)
1965 tmp = build_int_cst (type, 0);
1967 tmp = gfc_build_const (type, integer_zero_node);
1969 gfc_add_modify_expr (&se->pre, resvar, tmp);
1971 /* Walk argument #1. */
1972 actual = expr->value.function.actual;
1973 arrayexpr1 = actual->expr;
1974 arrayss1 = gfc_walk_expr (arrayexpr1);
1975 gcc_assert (arrayss1 != gfc_ss_terminator);
1977 /* Walk argument #2. */
1978 actual = actual->next;
1979 arrayexpr2 = actual->expr;
1980 arrayss2 = gfc_walk_expr (arrayexpr2);
1981 gcc_assert (arrayss2 != gfc_ss_terminator);
1983 /* Initialize the scalarizer. */
1984 gfc_init_loopinfo (&loop);
1985 gfc_add_ss_to_loop (&loop, arrayss1);
1986 gfc_add_ss_to_loop (&loop, arrayss2);
1988 /* Initialize the loop. */
1989 gfc_conv_ss_startstride (&loop);
1990 gfc_conv_loop_setup (&loop);
1992 gfc_mark_ss_chain_used (arrayss1, 1);
1993 gfc_mark_ss_chain_used (arrayss2, 1);
1995 /* Generate the loop body. */
1996 gfc_start_scalarized_body (&loop, &body);
1997 gfc_init_block (&block);
1999 /* Make the tree expression for [conjg(]array1[)]. */
2000 gfc_init_se (&arrayse1, NULL);
2001 gfc_copy_loopinfo_to_se (&arrayse1, &loop);
2002 arrayse1.ss = arrayss1;
2003 gfc_conv_expr_val (&arrayse1, arrayexpr1);
2004 if (expr->ts.type == BT_COMPLEX)
2005 arrayse1.expr = fold_build1 (CONJ_EXPR, type, arrayse1.expr);
2006 gfc_add_block_to_block (&block, &arrayse1.pre);
2008 /* Make the tree expression for array2. */
2009 gfc_init_se (&arrayse2, NULL);
2010 gfc_copy_loopinfo_to_se (&arrayse2, &loop);
2011 arrayse2.ss = arrayss2;
2012 gfc_conv_expr_val (&arrayse2, arrayexpr2);
2013 gfc_add_block_to_block (&block, &arrayse2.pre);
2015 /* Do the actual product and sum. */
2016 if (expr->ts.type == BT_LOGICAL)
2018 tmp = fold_build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr);
2019 tmp = fold_build2 (TRUTH_OR_EXPR, type, resvar, tmp);
2023 tmp = fold_build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr);
2024 tmp = fold_build2 (PLUS_EXPR, type, resvar, tmp);
2026 gfc_add_modify_expr (&block, resvar, tmp);
2028 /* Finish up the loop block and the loop. */
2029 tmp = gfc_finish_block (&block);
2030 gfc_add_expr_to_block (&body, tmp);
2032 gfc_trans_scalarizing_loops (&loop, &body);
2033 gfc_add_block_to_block (&se->pre, &loop.pre);
2034 gfc_add_block_to_block (&se->pre, &loop.post);
2035 gfc_cleanup_loop (&loop);
2042 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
2046 stmtblock_t ifblock;
2047 stmtblock_t elseblock;
2055 gfc_actual_arglist *actual;
2060 gfc_expr *arrayexpr;
2067 gfc_conv_intrinsic_funcall (se, expr);
2071 /* Initialize the result. */
2072 pos = gfc_create_var (gfc_array_index_type, "pos");
2073 offset = gfc_create_var (gfc_array_index_type, "offset");
2074 type = gfc_typenode_for_spec (&expr->ts);
2076 /* Walk the arguments. */
2077 actual = expr->value.function.actual;
2078 arrayexpr = actual->expr;
2079 arrayss = gfc_walk_expr (arrayexpr);
2080 gcc_assert (arrayss != gfc_ss_terminator);
2082 actual = actual->next->next;
2083 gcc_assert (actual);
2084 maskexpr = actual->expr;
2085 if (maskexpr && maskexpr->rank != 0)
2087 maskss = gfc_walk_expr (maskexpr);
2088 gcc_assert (maskss != gfc_ss_terminator);
2093 limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
2094 n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
2095 switch (arrayexpr->ts.type)
2098 tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind);
2102 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
2103 arrayexpr->ts.kind);
2110 /* We start with the most negative possible value for MAXLOC, and the most
2111 positive possible value for MINLOC. The most negative possible value is
2112 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2113 possible value is HUGE in both cases. */
2115 tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2116 gfc_add_modify_expr (&se->pre, limit, tmp);
2118 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2119 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
2120 build_int_cst (type, 1));
2122 /* Initialize the scalarizer. */
2123 gfc_init_loopinfo (&loop);
2124 gfc_add_ss_to_loop (&loop, arrayss);
2126 gfc_add_ss_to_loop (&loop, maskss);
2128 /* Initialize the loop. */
2129 gfc_conv_ss_startstride (&loop);
2130 gfc_conv_loop_setup (&loop);
2132 gcc_assert (loop.dimen == 1);
2134 /* Initialize the position to zero, following Fortran 2003. We are free
2135 to do this because Fortran 95 allows the result of an entirely false
2136 mask to be processor dependent. */
2137 gfc_add_modify_expr (&loop.pre, pos, gfc_index_zero_node);
2139 gfc_mark_ss_chain_used (arrayss, 1);
2141 gfc_mark_ss_chain_used (maskss, 1);
2142 /* Generate the loop body. */
2143 gfc_start_scalarized_body (&loop, &body);
2145 /* If we have a mask, only check this element if the mask is set. */
2148 gfc_init_se (&maskse, NULL);
2149 gfc_copy_loopinfo_to_se (&maskse, &loop);
2151 gfc_conv_expr_val (&maskse, maskexpr);
2152 gfc_add_block_to_block (&body, &maskse.pre);
2154 gfc_start_block (&block);
2157 gfc_init_block (&block);
2159 /* Compare with the current limit. */
2160 gfc_init_se (&arrayse, NULL);
2161 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2162 arrayse.ss = arrayss;
2163 gfc_conv_expr_val (&arrayse, arrayexpr);
2164 gfc_add_block_to_block (&block, &arrayse.pre);
2166 /* We do the following if this is a more extreme value. */
2167 gfc_start_block (&ifblock);
2169 /* Assign the value to the limit... */
2170 gfc_add_modify_expr (&ifblock, limit, arrayse.expr);
2172 /* Remember where we are. An offset must be added to the loop
2173 counter to obtain the required position. */
2175 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2176 gfc_index_one_node, loop.from[0]);
2178 tmp = build_int_cst (gfc_array_index_type, 1);
2180 gfc_add_modify_expr (&block, offset, tmp);
2182 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (pos),
2183 loop.loopvar[0], offset);
2184 gfc_add_modify_expr (&ifblock, pos, tmp);
2186 ifbody = gfc_finish_block (&ifblock);
2188 /* If it is a more extreme value or pos is still zero and the value
2189 equal to the limit. */
2190 tmp = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
2191 fold_build2 (EQ_EXPR, boolean_type_node,
2192 pos, gfc_index_zero_node),
2193 fold_build2 (EQ_EXPR, boolean_type_node,
2194 arrayse.expr, limit));
2195 tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
2196 fold_build2 (op, boolean_type_node,
2197 arrayse.expr, limit), tmp);
2198 tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
2199 gfc_add_expr_to_block (&block, tmp);
2203 /* We enclose the above in if (mask) {...}. */
2204 tmp = gfc_finish_block (&block);
2206 tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2209 tmp = gfc_finish_block (&block);
2210 gfc_add_expr_to_block (&body, tmp);
2212 gfc_trans_scalarizing_loops (&loop, &body);
2214 /* For a scalar mask, enclose the loop in an if statement. */
2215 if (maskexpr && maskss == NULL)
2217 gfc_init_se (&maskse, NULL);
2218 gfc_conv_expr_val (&maskse, maskexpr);
2219 gfc_init_block (&block);
2220 gfc_add_block_to_block (&block, &loop.pre);
2221 gfc_add_block_to_block (&block, &loop.post);
2222 tmp = gfc_finish_block (&block);
2224 /* For the else part of the scalar mask, just initialize
2225 the pos variable the same way as above. */
2227 gfc_init_block (&elseblock);
2228 gfc_add_modify_expr (&elseblock, pos, gfc_index_zero_node);
2229 elsetmp = gfc_finish_block (&elseblock);
2231 tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
2232 gfc_add_expr_to_block (&block, tmp);
2233 gfc_add_block_to_block (&se->pre, &block);
2237 gfc_add_block_to_block (&se->pre, &loop.pre);
2238 gfc_add_block_to_block (&se->pre, &loop.post);
2240 gfc_cleanup_loop (&loop);
2242 se->expr = convert (type, pos);
2246 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
2255 gfc_actual_arglist *actual;
2260 gfc_expr *arrayexpr;
2266 gfc_conv_intrinsic_funcall (se, expr);
2270 type = gfc_typenode_for_spec (&expr->ts);
2271 /* Initialize the result. */
2272 limit = gfc_create_var (type, "limit");
2273 n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
2274 switch (expr->ts.type)
2277 tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind);
2281 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
2288 /* We start with the most negative possible value for MAXVAL, and the most
2289 positive possible value for MINVAL. The most negative possible value is
2290 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2291 possible value is HUGE in both cases. */
2293 tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2295 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2296 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (tmp),
2297 tmp, build_int_cst (type, 1));
2299 gfc_add_modify_expr (&se->pre, limit, tmp);
2301 /* Walk the arguments. */
2302 actual = expr->value.function.actual;
2303 arrayexpr = actual->expr;
2304 arrayss = gfc_walk_expr (arrayexpr);
2305 gcc_assert (arrayss != gfc_ss_terminator);
2307 actual = actual->next->next;
2308 gcc_assert (actual);
2309 maskexpr = actual->expr;
2310 if (maskexpr && maskexpr->rank != 0)
2312 maskss = gfc_walk_expr (maskexpr);
2313 gcc_assert (maskss != gfc_ss_terminator);
2318 /* Initialize the scalarizer. */
2319 gfc_init_loopinfo (&loop);
2320 gfc_add_ss_to_loop (&loop, arrayss);
2322 gfc_add_ss_to_loop (&loop, maskss);
2324 /* Initialize the loop. */
2325 gfc_conv_ss_startstride (&loop);
2326 gfc_conv_loop_setup (&loop);
2328 gfc_mark_ss_chain_used (arrayss, 1);
2330 gfc_mark_ss_chain_used (maskss, 1);
2331 /* Generate the loop body. */
2332 gfc_start_scalarized_body (&loop, &body);
2334 /* If we have a mask, only add this element if the mask is set. */
2337 gfc_init_se (&maskse, NULL);
2338 gfc_copy_loopinfo_to_se (&maskse, &loop);
2340 gfc_conv_expr_val (&maskse, maskexpr);
2341 gfc_add_block_to_block (&body, &maskse.pre);
2343 gfc_start_block (&block);
2346 gfc_init_block (&block);
2348 /* Compare with the current limit. */
2349 gfc_init_se (&arrayse, NULL);
2350 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2351 arrayse.ss = arrayss;
2352 gfc_conv_expr_val (&arrayse, arrayexpr);
2353 gfc_add_block_to_block (&block, &arrayse.pre);
2355 /* Assign the value to the limit... */
2356 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2358 /* If it is a more extreme value. */
2359 tmp = fold_build2 (op, boolean_type_node, arrayse.expr, limit);
2360 tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
2361 gfc_add_expr_to_block (&block, tmp);
2362 gfc_add_block_to_block (&block, &arrayse.post);
2364 tmp = gfc_finish_block (&block);
2366 /* We enclose the above in if (mask) {...}. */
2367 tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2368 gfc_add_expr_to_block (&body, tmp);
2370 gfc_trans_scalarizing_loops (&loop, &body);
2372 /* For a scalar mask, enclose the loop in an if statement. */
2373 if (maskexpr && maskss == NULL)
2375 gfc_init_se (&maskse, NULL);
2376 gfc_conv_expr_val (&maskse, maskexpr);
2377 gfc_init_block (&block);
2378 gfc_add_block_to_block (&block, &loop.pre);
2379 gfc_add_block_to_block (&block, &loop.post);
2380 tmp = gfc_finish_block (&block);
2382 tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2383 gfc_add_expr_to_block (&block, tmp);
2384 gfc_add_block_to_block (&se->pre, &block);
2388 gfc_add_block_to_block (&se->pre, &loop.pre);
2389 gfc_add_block_to_block (&se->pre, &loop.post);
2392 gfc_cleanup_loop (&loop);
2397 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
2399 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
2405 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2406 type = TREE_TYPE (args[0]);
2408 tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
2409 tmp = fold_build2 (BIT_AND_EXPR, type, args[0], tmp);
2410 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
2411 build_int_cst (type, 0));
2412 type = gfc_typenode_for_spec (&expr->ts);
2413 se->expr = convert (type, tmp);
2416 /* Generate code to perform the specified operation. */
2418 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op)
2422 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2423 se->expr = fold_build2 (op, TREE_TYPE (args[0]), args[0], args[1]);
2428 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
2432 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2433 se->expr = fold_build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
2436 /* Set or clear a single bit. */
2438 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
2445 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2446 type = TREE_TYPE (args[0]);
2448 tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
2454 tmp = fold_build1 (BIT_NOT_EXPR, type, tmp);
2456 se->expr = fold_build2 (op, type, args[0], tmp);
2459 /* Extract a sequence of bits.
2460 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
2462 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
2469 gfc_conv_intrinsic_function_args (se, expr, args, 3);
2470 type = TREE_TYPE (args[0]);
2472 mask = build_int_cst (type, -1);
2473 mask = fold_build2 (LSHIFT_EXPR, type, mask, args[2]);
2474 mask = fold_build1 (BIT_NOT_EXPR, type, mask);
2476 tmp = fold_build2 (RSHIFT_EXPR, type, args[0], args[1]);
2478 se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
2481 /* RSHIFT (I, SHIFT) = I >> SHIFT
2482 LSHIFT (I, SHIFT) = I << SHIFT */
2484 gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift)
2488 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2490 se->expr = fold_build2 (right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
2491 TREE_TYPE (args[0]), args[0], args[1]);
2494 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
2496 : ((shift >= 0) ? i << shift : i >> -shift)
2497 where all shifts are logical shifts. */
2499 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
2511 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2512 type = TREE_TYPE (args[0]);
2513 utype = unsigned_type_for (type);
2515 width = fold_build1 (ABS_EXPR, TREE_TYPE (args[1]), args[1]);
2517 /* Left shift if positive. */
2518 lshift = fold_build2 (LSHIFT_EXPR, type, args[0], width);
2520 /* Right shift if negative.
2521 We convert to an unsigned type because we want a logical shift.
2522 The standard doesn't define the case of shifting negative
2523 numbers, and we try to be compatible with other compilers, most
2524 notably g77, here. */
2525 rshift = fold_convert (type, fold_build2 (RSHIFT_EXPR, utype,
2526 convert (utype, args[0]), width));
2528 tmp = fold_build2 (GE_EXPR, boolean_type_node, args[1],
2529 build_int_cst (TREE_TYPE (args[1]), 0));
2530 tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift);
2532 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
2533 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
2535 num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
2536 cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits);
2538 se->expr = fold_build3 (COND_EXPR, type, cond,
2539 build_int_cst (type, 0), tmp);
2543 /* Circular shift. AKA rotate or barrel shift. */
2546 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
2554 unsigned int num_args;
2556 num_args = gfc_intrinsic_argument_list_length (expr);
2557 args = alloca (sizeof (tree) * num_args);
2559 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2563 /* Use a library function for the 3 parameter version. */
2564 tree int4type = gfc_get_int_type (4);
2566 type = TREE_TYPE (args[0]);
2567 /* We convert the first argument to at least 4 bytes, and
2568 convert back afterwards. This removes the need for library
2569 functions for all argument sizes, and function will be
2570 aligned to at least 32 bits, so there's no loss. */
2571 if (expr->ts.kind < 4)
2572 args[0] = convert (int4type, args[0]);
2574 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
2575 need loads of library functions. They cannot have values >
2576 BIT_SIZE (I) so the conversion is safe. */
2577 args[1] = convert (int4type, args[1]);
2578 args[2] = convert (int4type, args[2]);
2580 switch (expr->ts.kind)
2585 tmp = gfor_fndecl_math_ishftc4;
2588 tmp = gfor_fndecl_math_ishftc8;
2591 tmp = gfor_fndecl_math_ishftc16;
2596 se->expr = build_call_expr (tmp, 3, args[0], args[1], args[2]);
2597 /* Convert the result back to the original type, if we extended
2598 the first argument's width above. */
2599 if (expr->ts.kind < 4)
2600 se->expr = convert (type, se->expr);
2604 type = TREE_TYPE (args[0]);
2606 /* Rotate left if positive. */
2607 lrot = fold_build2 (LROTATE_EXPR, type, args[0], args[1]);
2609 /* Rotate right if negative. */
2610 tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (args[1]), args[1]);
2611 rrot = fold_build2 (RROTATE_EXPR, type, args[0], tmp);
2613 zero = build_int_cst (TREE_TYPE (args[1]), 0);
2614 tmp = fold_build2 (GT_EXPR, boolean_type_node, args[1], zero);
2615 rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot);
2617 /* Do nothing if shift == 0. */
2618 tmp = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
2619 se->expr = fold_build3 (COND_EXPR, type, tmp, args[0], rrot);
2622 /* The length of a character string. */
2624 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
2634 gcc_assert (!se->ss);
2636 arg = expr->value.function.actual->expr;
2638 type = gfc_typenode_for_spec (&expr->ts);
2639 switch (arg->expr_type)
2642 len = build_int_cst (NULL_TREE, arg->value.character.length);
2646 /* Obtain the string length from the function used by
2647 trans-array.c(gfc_trans_array_constructor). */
2649 get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
2653 if (arg->ref == NULL
2654 || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
2656 /* This doesn't catch all cases.
2657 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
2658 and the surrounding thread. */
2659 sym = arg->symtree->n.sym;
2660 decl = gfc_get_symbol_decl (sym);
2661 if (decl == current_function_decl && sym->attr.function
2662 && (sym->result == sym))
2663 decl = gfc_get_fake_result_decl (sym, 0);
2665 len = sym->ts.cl->backend_decl;
2670 /* Otherwise fall through. */
2673 /* Anybody stupid enough to do this deserves inefficient code. */
2674 ss = gfc_walk_expr (arg);
2675 gfc_init_se (&argse, se);
2676 if (ss == gfc_ss_terminator)
2677 gfc_conv_expr (&argse, arg);
2679 gfc_conv_expr_descriptor (&argse, arg, ss);
2680 gfc_add_block_to_block (&se->pre, &argse.pre);
2681 gfc_add_block_to_block (&se->post, &argse.post);
2682 len = argse.string_length;
2685 se->expr = convert (type, len);
2688 /* The length of a character string not including trailing blanks. */
2690 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
2695 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2696 type = gfc_typenode_for_spec (&expr->ts);
2697 se->expr = build_call_expr (gfor_fndecl_string_len_trim, 2, args[0], args[1]);
2698 se->expr = convert (type, se->expr);
2702 /* Returns the starting position of a substring within a string. */
2705 gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
2708 tree logical4_type_node = gfc_get_logical_type (4);
2712 unsigned int num_args;
2714 num_args = gfc_intrinsic_argument_list_length (expr);
2715 args = alloca (sizeof (tree) * 5);
2717 gfc_conv_intrinsic_function_args (se, expr, args,
2718 num_args >= 5 ? 5 : num_args);
2719 type = gfc_typenode_for_spec (&expr->ts);
2722 args[4] = build_int_cst (logical4_type_node, 0);
2724 args[4] = convert (logical4_type_node, args[4]);
2726 fndecl = build_addr (function, current_function_decl);
2727 se->expr = build_call_array (TREE_TYPE (TREE_TYPE (function)), fndecl,
2729 se->expr = convert (type, se->expr);
2733 /* The ascii value for a single character. */
2735 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
2740 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2741 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
2742 args[1] = fold_build1 (NOP_EXPR, pchar_type_node, args[1]);
2743 type = gfc_typenode_for_spec (&expr->ts);
2745 se->expr = build_fold_indirect_ref (args[1]);
2746 se->expr = convert (type, se->expr);
2750 /* Intrinsic ISNAN calls __builtin_isnan. */
2753 gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
2757 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2758 se->expr = build_call_expr (built_in_decls[BUILT_IN_ISNAN], 1, arg);
2759 STRIP_TYPE_NOPS (se->expr);
2760 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2764 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
2765 their argument against a constant integer value. */
2768 gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
2772 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2773 se->expr = fold_build2 (EQ_EXPR, gfc_typenode_for_spec (&expr->ts),
2774 arg, build_int_cst (TREE_TYPE (arg), value));
2779 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
2782 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
2790 unsigned int num_args;
2792 num_args = gfc_intrinsic_argument_list_length (expr);
2793 args = alloca (sizeof (tree) * num_args);
2795 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2796 if (expr->ts.type != BT_CHARACTER)
2804 /* We do the same as in the non-character case, but the argument
2805 list is different because of the string length arguments. We
2806 also have to set the string length for the result. */
2812 se->string_length = len;
2814 type = TREE_TYPE (tsource);
2815 se->expr = fold_build3 (COND_EXPR, type, mask, tsource, fsource);
2819 /* FRACTION (s) is translated into frexp (s, &dummy_int). */
2821 gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
2823 tree arg, type, tmp;
2826 switch (expr->ts.kind)
2829 frexp = BUILT_IN_FREXPF;
2832 frexp = BUILT_IN_FREXP;
2836 frexp = BUILT_IN_FREXPL;
2842 type = gfc_typenode_for_spec (&expr->ts);
2843 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2844 tmp = gfc_create_var (integer_type_node, NULL);
2845 se->expr = build_call_expr (built_in_decls[frexp], 2,
2846 fold_convert (type, arg),
2847 build_fold_addr_expr (tmp));
2848 se->expr = fold_convert (type, se->expr);
2852 /* NEAREST (s, dir) is translated into
2853 tmp = copysign (INF, dir);
2854 return nextafter (s, tmp);
2857 gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
2859 tree args[2], type, tmp;
2860 int nextafter, copysign, inf;
2862 switch (expr->ts.kind)
2865 nextafter = BUILT_IN_NEXTAFTERF;
2866 copysign = BUILT_IN_COPYSIGNF;
2867 inf = BUILT_IN_INFF;
2870 nextafter = BUILT_IN_NEXTAFTER;
2871 copysign = BUILT_IN_COPYSIGN;
2876 nextafter = BUILT_IN_NEXTAFTERL;
2877 copysign = BUILT_IN_COPYSIGNL;
2878 inf = BUILT_IN_INFL;
2884 type = gfc_typenode_for_spec (&expr->ts);
2885 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2886 tmp = build_call_expr (built_in_decls[copysign], 2,
2887 build_call_expr (built_in_decls[inf], 0),
2888 fold_convert (type, args[1]));
2889 se->expr = build_call_expr (built_in_decls[nextafter], 2,
2890 fold_convert (type, args[0]), tmp);
2891 se->expr = fold_convert (type, se->expr);
2895 /* SPACING (s) is translated into
2903 e = MAX_EXPR (e, emin);
2904 res = scalbn (1., e);
2908 where prec is the precision of s, gfc_real_kinds[k].digits,
2909 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
2910 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
2913 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
2915 tree arg, type, prec, emin, tiny, res, e;
2917 int frexp, scalbn, k;
2920 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
2921 prec = build_int_cst (NULL_TREE, gfc_real_kinds[k].digits);
2922 emin = build_int_cst (NULL_TREE, gfc_real_kinds[k].min_exponent - 1);
2923 tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind);
2925 switch (expr->ts.kind)
2928 frexp = BUILT_IN_FREXPF;
2929 scalbn = BUILT_IN_SCALBNF;
2932 frexp = BUILT_IN_FREXP;
2933 scalbn = BUILT_IN_SCALBN;
2937 frexp = BUILT_IN_FREXPL;
2938 scalbn = BUILT_IN_SCALBNL;
2944 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2945 arg = gfc_evaluate_now (arg, &se->pre);
2947 type = gfc_typenode_for_spec (&expr->ts);
2948 e = gfc_create_var (integer_type_node, NULL);
2949 res = gfc_create_var (type, NULL);
2952 /* Build the block for s /= 0. */
2953 gfc_start_block (&block);
2954 tmp = build_call_expr (built_in_decls[frexp], 2, arg,
2955 build_fold_addr_expr (e));
2956 gfc_add_expr_to_block (&block, tmp);
2958 tmp = fold_build2 (MINUS_EXPR, integer_type_node, e, prec);
2959 gfc_add_modify_expr (&block, e, fold_build2 (MAX_EXPR, integer_type_node,
2962 tmp = build_call_expr (built_in_decls[scalbn], 2,
2963 build_real_from_int_cst (type, integer_one_node), e);
2964 gfc_add_modify_expr (&block, res, tmp);
2966 /* Finish by building the IF statement. */
2967 cond = fold_build2 (EQ_EXPR, boolean_type_node, arg,
2968 build_real_from_int_cst (type, integer_zero_node));
2969 tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
2970 gfc_finish_block (&block));
2972 gfc_add_expr_to_block (&se->pre, tmp);
2977 /* RRSPACING (s) is translated into
2984 x = scalbn (x, precision - e);
2988 where precision is gfc_real_kinds[k].digits. */
2991 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
2993 tree arg, type, e, x, cond, stmt, tmp;
2994 int frexp, scalbn, fabs, prec, k;
2997 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
2998 prec = gfc_real_kinds[k].digits;
2999 switch (expr->ts.kind)
3002 frexp = BUILT_IN_FREXPF;
3003 scalbn = BUILT_IN_SCALBNF;
3004 fabs = BUILT_IN_FABSF;
3007 frexp = BUILT_IN_FREXP;
3008 scalbn = BUILT_IN_SCALBN;
3009 fabs = BUILT_IN_FABS;
3013 frexp = BUILT_IN_FREXPL;
3014 scalbn = BUILT_IN_SCALBNL;
3015 fabs = BUILT_IN_FABSL;
3021 type = gfc_typenode_for_spec (&expr->ts);
3022 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3023 arg = gfc_evaluate_now (arg, &se->pre);
3025 e = gfc_create_var (integer_type_node, NULL);
3026 x = gfc_create_var (type, NULL);
3027 gfc_add_modify_expr (&se->pre, x,
3028 build_call_expr (built_in_decls[fabs], 1, arg));
3031 gfc_start_block (&block);
3032 tmp = build_call_expr (built_in_decls[frexp], 2, arg,
3033 build_fold_addr_expr (e));
3034 gfc_add_expr_to_block (&block, tmp);
3036 tmp = fold_build2 (MINUS_EXPR, integer_type_node,
3037 build_int_cst (NULL_TREE, prec), e);
3038 tmp = build_call_expr (built_in_decls[scalbn], 2, x, tmp);
3039 gfc_add_modify_expr (&block, x, tmp);
3040 stmt = gfc_finish_block (&block);
3042 cond = fold_build2 (NE_EXPR, boolean_type_node, x,
3043 build_real_from_int_cst (type, integer_zero_node));
3044 tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt ());
3045 gfc_add_expr_to_block (&se->pre, tmp);
3047 se->expr = fold_convert (type, x);
3051 /* SCALE (s, i) is translated into scalbn (s, i). */
3053 gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
3058 switch (expr->ts.kind)
3061 scalbn = BUILT_IN_SCALBNF;
3064 scalbn = BUILT_IN_SCALBN;
3068 scalbn = BUILT_IN_SCALBNL;
3074 type = gfc_typenode_for_spec (&expr->ts);
3075 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3076 se->expr = build_call_expr (built_in_decls[scalbn], 2,
3077 fold_convert (type, args[0]),
3078 fold_convert (integer_type_node, args[1]));
3079 se->expr = fold_convert (type, se->expr);
3083 /* SET_EXPONENT (s, i) is translated into
3084 scalbn (frexp (s, &dummy_int), i). */
3086 gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
3088 tree args[2], type, tmp;
3091 switch (expr->ts.kind)
3094 frexp = BUILT_IN_FREXPF;
3095 scalbn = BUILT_IN_SCALBNF;
3098 frexp = BUILT_IN_FREXP;
3099 scalbn = BUILT_IN_SCALBN;
3103 frexp = BUILT_IN_FREXPL;
3104 scalbn = BUILT_IN_SCALBNL;
3110 type = gfc_typenode_for_spec (&expr->ts);
3111 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3113 tmp = gfc_create_var (integer_type_node, NULL);
3114 tmp = build_call_expr (built_in_decls[frexp], 2,
3115 fold_convert (type, args[0]),
3116 build_fold_addr_expr (tmp));
3117 se->expr = build_call_expr (built_in_decls[scalbn], 2, tmp,
3118 fold_convert (integer_type_node, args[1]));
3119 se->expr = fold_convert (type, se->expr);
3124 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
3126 gfc_actual_arglist *actual;
3134 gfc_init_se (&argse, NULL);
3135 actual = expr->value.function.actual;
3137 ss = gfc_walk_expr (actual->expr);
3138 gcc_assert (ss != gfc_ss_terminator);
3139 argse.want_pointer = 1;
3140 argse.data_not_needed = 1;
3141 gfc_conv_expr_descriptor (&argse, actual->expr, ss);
3142 gfc_add_block_to_block (&se->pre, &argse.pre);
3143 gfc_add_block_to_block (&se->post, &argse.post);
3144 arg1 = gfc_evaluate_now (argse.expr, &se->pre);
3146 /* Build the call to size0. */
3147 fncall0 = build_call_expr (gfor_fndecl_size0, 1, arg1);
3149 actual = actual->next;
3153 gfc_init_se (&argse, NULL);
3154 gfc_conv_expr_type (&argse, actual->expr,
3155 gfc_array_index_type);
3156 gfc_add_block_to_block (&se->pre, &argse.pre);
3158 /* Build the call to size1. */
3159 fncall1 = build_call_expr (gfor_fndecl_size1, 2,
3162 /* Unusually, for an intrinsic, size does not exclude
3163 an optional arg2, so we must test for it. */
3164 if (actual->expr->expr_type == EXPR_VARIABLE
3165 && actual->expr->symtree->n.sym->attr.dummy
3166 && actual->expr->symtree->n.sym->attr.optional)
3169 gfc_init_se (&argse, NULL);
3170 argse.want_pointer = 1;
3171 argse.data_not_needed = 1;
3172 gfc_conv_expr (&argse, actual->expr);
3173 gfc_add_block_to_block (&se->pre, &argse.pre);
3174 tmp = fold_build2 (NE_EXPR, boolean_type_node,
3175 argse.expr, null_pointer_node);
3176 tmp = gfc_evaluate_now (tmp, &se->pre);
3177 se->expr = fold_build3 (COND_EXPR, pvoid_type_node,
3178 tmp, fncall1, fncall0);
3186 type = gfc_typenode_for_spec (&expr->ts);
3187 se->expr = convert (type, se->expr);
3192 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
3206 arg = expr->value.function.actual->expr;
3208 gfc_init_se (&argse, NULL);
3209 ss = gfc_walk_expr (arg);
3211 source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
3213 if (ss == gfc_ss_terminator)
3215 gfc_conv_expr_reference (&argse, arg);
3216 source = argse.expr;
3218 type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
3220 /* Obtain the source word length. */
3221 if (arg->ts.type == BT_CHARACTER)
3222 source_bytes = fold_convert (gfc_array_index_type,
3223 argse.string_length);
3225 source_bytes = fold_convert (gfc_array_index_type,
3226 size_in_bytes (type));
3230 argse.want_pointer = 0;
3231 gfc_conv_expr_descriptor (&argse, arg, ss);
3232 source = gfc_conv_descriptor_data_get (argse.expr);
3233 type = gfc_get_element_type (TREE_TYPE (argse.expr));
3235 /* Obtain the argument's word length. */
3236 if (arg->ts.type == BT_CHARACTER)
3237 tmp = fold_convert (gfc_array_index_type, argse.string_length);
3239 tmp = fold_convert (gfc_array_index_type,
3240 size_in_bytes (type));
3241 gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
3243 /* Obtain the size of the array in bytes. */
3244 for (n = 0; n < arg->rank; n++)
3247 idx = gfc_rank_cst[n];
3248 lower = gfc_conv_descriptor_lbound (argse.expr, idx);
3249 upper = gfc_conv_descriptor_ubound (argse.expr, idx);
3250 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3252 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3253 tmp, gfc_index_one_node);
3254 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3256 gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
3260 gfc_add_block_to_block (&se->pre, &argse.pre);
3261 se->expr = source_bytes;
3265 /* Intrinsic string comparison functions. */
3268 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
3272 gfc_conv_intrinsic_function_args (se, expr, args, 4);
3274 se->expr = gfc_build_compare_string (args[0], args[1], args[2], args[3]);
3275 se->expr = fold_build2 (op, gfc_typenode_for_spec (&expr->ts), se->expr,
3276 build_int_cst (TREE_TYPE (se->expr), 0));
3279 /* Generate a call to the adjustl/adjustr library function. */
3281 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
3289 gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
3292 type = TREE_TYPE (args[2]);
3293 var = gfc_conv_string_tmp (se, type, len);
3296 tmp = build_call_expr (fndecl, 3, args[0], args[1], args[2]);
3297 gfc_add_expr_to_block (&se->pre, tmp);
3299 se->string_length = len;
3303 /* Array transfer statement.
3304 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
3306 typeof<DEST> = typeof<MOLD>
3308 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
3309 sizeof (DEST(0) * SIZE). */
3312 gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
3327 gfc_actual_arglist *arg;
3334 gcc_assert (se->loop);
3335 info = &se->ss->data.info;
3337 /* Convert SOURCE. The output from this stage is:-
3338 source_bytes = length of the source in bytes
3339 source = pointer to the source data. */
3340 arg = expr->value.function.actual;
3341 gfc_init_se (&argse, NULL);
3342 ss = gfc_walk_expr (arg->expr);
3344 source_bytes = gfc_create_var (gfc_array_index_type, NULL);
3346 /* Obtain the pointer to source and the length of source in bytes. */
3347 if (ss == gfc_ss_terminator)
3349 gfc_conv_expr_reference (&argse, arg->expr);
3350 source = argse.expr;
3352 source_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
3354 /* Obtain the source word length. */
3355 if (arg->expr->ts.type == BT_CHARACTER)
3356 tmp = fold_convert (gfc_array_index_type, argse.string_length);
3358 tmp = fold_convert (gfc_array_index_type,
3359 size_in_bytes (source_type));
3363 argse.want_pointer = 0;
3364 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
3365 source = gfc_conv_descriptor_data_get (argse.expr);
3366 source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
3368 /* Repack the source if not a full variable array. */
3369 if (!(arg->expr->expr_type == EXPR_VARIABLE
3370 && arg->expr->ref->u.ar.type == AR_FULL))
3372 tmp = build_fold_addr_expr (argse.expr);
3373 source = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
3374 source = gfc_evaluate_now (source, &argse.pre);
3376 /* Free the temporary. */
3377 gfc_start_block (&block);
3378 tmp = gfc_call_free (convert (pvoid_type_node, source));
3379 gfc_add_expr_to_block (&block, tmp);
3380 stmt = gfc_finish_block (&block);
3382 /* Clean up if it was repacked. */
3383 gfc_init_block (&block);
3384 tmp = gfc_conv_array_data (argse.expr);
3385 tmp = fold_build2 (NE_EXPR, boolean_type_node, source, tmp);
3386 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3387 gfc_add_expr_to_block (&block, tmp);
3388 gfc_add_block_to_block (&block, &se->post);
3389 gfc_init_block (&se->post);
3390 gfc_add_block_to_block (&se->post, &block);
3393 /* Obtain the source word length. */
3394 if (arg->expr->ts.type == BT_CHARACTER)
3395 tmp = fold_convert (gfc_array_index_type, argse.string_length);
3397 tmp = fold_convert (gfc_array_index_type,
3398 size_in_bytes (source_type));
3400 /* Obtain the size of the array in bytes. */
3401 extent = gfc_create_var (gfc_array_index_type, NULL);
3402 for (n = 0; n < arg->expr->rank; n++)
3405 idx = gfc_rank_cst[n];
3406 gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
3407 stride = gfc_conv_descriptor_stride (argse.expr, idx);
3408 lower = gfc_conv_descriptor_lbound (argse.expr, idx);
3409 upper = gfc_conv_descriptor_ubound (argse.expr, idx);
3410 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3412 gfc_add_modify_expr (&argse.pre, extent, tmp);
3413 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3414 extent, gfc_index_one_node);
3415 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3420 gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
3421 gfc_add_block_to_block (&se->pre, &argse.pre);
3422 gfc_add_block_to_block (&se->post, &argse.post);
3424 /* Now convert MOLD. The outputs are:
3425 mold_type = the TREE type of MOLD
3426 dest_word_len = destination word length in bytes. */
3429 gfc_init_se (&argse, NULL);
3430 ss = gfc_walk_expr (arg->expr);
3432 if (ss == gfc_ss_terminator)
3434 gfc_conv_expr_reference (&argse, arg->expr);
3435 mold_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
3439 gfc_init_se (&argse, NULL);
3440 argse.want_pointer = 0;
3441 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
3442 mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
3445 if (arg->expr->ts.type == BT_CHARACTER)
3447 tmp = fold_convert (gfc_array_index_type, argse.string_length);
3448 mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
3451 tmp = fold_convert (gfc_array_index_type,
3452 size_in_bytes (mold_type));
3454 dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
3455 gfc_add_modify_expr (&se->pre, dest_word_len, tmp);
3457 /* Finally convert SIZE, if it is present. */
3459 size_words = gfc_create_var (gfc_array_index_type, NULL);
3463 gfc_init_se (&argse, NULL);
3464 gfc_conv_expr_reference (&argse, arg->expr);
3465 tmp = convert (gfc_array_index_type,
3466 build_fold_indirect_ref (argse.expr));
3467 gfc_add_block_to_block (&se->pre, &argse.pre);
3468 gfc_add_block_to_block (&se->post, &argse.post);
3473 size_bytes = gfc_create_var (gfc_array_index_type, NULL);
3474 if (tmp != NULL_TREE)
3476 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3477 tmp, dest_word_len);
3478 tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
3484 gfc_add_modify_expr (&se->pre, size_bytes, tmp);
3485 gfc_add_modify_expr (&se->pre, size_words,
3486 fold_build2 (CEIL_DIV_EXPR, gfc_array_index_type,
3487 size_bytes, dest_word_len));
3489 /* Evaluate the bounds of the result. If the loop range exists, we have
3490 to check if it is too large. If so, we modify loop->to be consistent
3491 with min(size, size(source)). Otherwise, size is made consistent with
3492 the loop range, so that the right number of bytes is transferred.*/
3493 n = se->loop->order[0];
3494 if (se->loop->to[n] != NULL_TREE)
3496 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3497 se->loop->to[n], se->loop->from[n]);
3498 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3499 tmp, gfc_index_one_node);
3500 tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
3502 gfc_add_modify_expr (&se->pre, size_words, tmp);
3503 gfc_add_modify_expr (&se->pre, size_bytes,
3504 fold_build2 (MULT_EXPR, gfc_array_index_type,
3505 size_words, dest_word_len));
3506 upper = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3507 size_words, se->loop->from[n]);
3508 upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3509 upper, gfc_index_one_node);
3513 upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3514 size_words, gfc_index_one_node);
3515 se->loop->from[n] = gfc_index_zero_node;
3518 se->loop->to[n] = upper;
3520 /* Build a destination descriptor, using the pointer, source, as the
3521 data field. This is already allocated so set callee_alloc.
3522 FIXME callee_alloc is not set! */
3524 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
3525 info, mold_type, false, true, false);
3527 /* Cast the pointer to the result. */
3528 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3529 tmp = fold_convert (pvoid_type_node, tmp);
3531 /* Use memcpy to do the transfer. */
3532 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY],
3535 fold_convert (pvoid_type_node, source),
3537 gfc_add_expr_to_block (&se->pre, tmp);
3539 se->expr = info->descriptor;
3540 if (expr->ts.type == BT_CHARACTER)
3541 se->string_length = dest_word_len;
3545 /* Scalar transfer statement.
3546 TRANSFER (source, mold) = memcpy(&tmpdecl, &source, size), tmpdecl. */
3549 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
3551 gfc_actual_arglist *arg;
3558 /* Get a pointer to the source. */
3559 arg = expr->value.function.actual;
3560 ss = gfc_walk_expr (arg->expr);
3561 gfc_init_se (&argse, NULL);
3562 if (ss == gfc_ss_terminator)
3563 gfc_conv_expr_reference (&argse, arg->expr);
3565 gfc_conv_array_parameter (&argse, arg->expr, ss, 1);
3566 gfc_add_block_to_block (&se->pre, &argse.pre);
3567 gfc_add_block_to_block (&se->post, &argse.post);
3571 type = gfc_typenode_for_spec (&expr->ts);
3573 if (expr->ts.type == BT_CHARACTER)
3575 ptr = convert (build_pointer_type (type), ptr);
3576 gfc_init_se (&argse, NULL);
3577 gfc_conv_expr (&argse, arg->expr);
3578 gfc_add_block_to_block (&se->pre, &argse.pre);
3579 gfc_add_block_to_block (&se->post, &argse.post);
3581 se->string_length = argse.string_length;
3586 tmpdecl = gfc_create_var (type, "transfer");
3587 moldsize = size_in_bytes (type);
3589 /* Use memcpy to do the transfer. */
3590 tmp = fold_build1 (ADDR_EXPR, build_pointer_type (type), tmpdecl);
3591 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
3592 fold_convert (pvoid_type_node, tmp),
3593 fold_convert (pvoid_type_node, ptr),
3595 gfc_add_expr_to_block (&se->pre, tmp);
3602 /* Generate code for the ALLOCATED intrinsic.
3603 Generate inline code that directly check the address of the argument. */
3606 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
3608 gfc_actual_arglist *arg1;
3613 gfc_init_se (&arg1se, NULL);
3614 arg1 = expr->value.function.actual;
3615 ss1 = gfc_walk_expr (arg1->expr);
3616 arg1se.descriptor_only = 1;
3617 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3619 tmp = gfc_conv_descriptor_data_get (arg1se.expr);
3620 tmp = fold_build2 (NE_EXPR, boolean_type_node,
3621 tmp, fold_convert (TREE_TYPE (tmp), null_pointer_node));
3622 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
3626 /* Generate code for the ASSOCIATED intrinsic.
3627 If both POINTER and TARGET are arrays, generate a call to library function
3628 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
3629 In other cases, generate inline code that directly compare the address of
3630 POINTER with the address of TARGET. */
3633 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
3635 gfc_actual_arglist *arg1;
3636 gfc_actual_arglist *arg2;
3641 tree nonzero_charlen;
3642 tree nonzero_arraylen;
3645 gfc_init_se (&arg1se, NULL);
3646 gfc_init_se (&arg2se, NULL);
3647 arg1 = expr->value.function.actual;
3649 ss1 = gfc_walk_expr (arg1->expr);
3653 /* No optional target. */
3654 if (ss1 == gfc_ss_terminator)
3656 /* A pointer to a scalar. */
3657 arg1se.want_pointer = 1;
3658 gfc_conv_expr (&arg1se, arg1->expr);
3663 /* A pointer to an array. */
3664 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3665 tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
3667 gfc_add_block_to_block (&se->pre, &arg1se.pre);
3668 gfc_add_block_to_block (&se->post, &arg1se.post);
3669 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp2,
3670 fold_convert (TREE_TYPE (tmp2), null_pointer_node));
3675 /* An optional target. */
3676 ss2 = gfc_walk_expr (arg2->expr);
3678 nonzero_charlen = NULL_TREE;
3679 if (arg1->expr->ts.type == BT_CHARACTER)
3680 nonzero_charlen = fold_build2 (NE_EXPR, boolean_type_node,
3681 arg1->expr->ts.cl->backend_decl,
3684 if (ss1 == gfc_ss_terminator)
3686 /* A pointer to a scalar. */
3687 gcc_assert (ss2 == gfc_ss_terminator);
3688 arg1se.want_pointer = 1;
3689 gfc_conv_expr (&arg1se, arg1->expr);
3690 arg2se.want_pointer = 1;
3691 gfc_conv_expr (&arg2se, arg2->expr);
3692 gfc_add_block_to_block (&se->pre, &arg1se.pre);
3693 gfc_add_block_to_block (&se->post, &arg1se.post);
3694 tmp = fold_build2 (EQ_EXPR, boolean_type_node,
3695 arg1se.expr, arg2se.expr);
3696 tmp2 = fold_build2 (NE_EXPR, boolean_type_node,
3697 arg1se.expr, null_pointer_node);
3698 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3703 /* An array pointer of zero length is not associated if target is
3705 arg1se.descriptor_only = 1;
3706 gfc_conv_expr_lhs (&arg1se, arg1->expr);
3707 tmp = gfc_conv_descriptor_stride (arg1se.expr,
3708 gfc_rank_cst[arg1->expr->rank - 1]);
3709 nonzero_arraylen = fold_build2 (NE_EXPR, boolean_type_node, tmp,
3710 build_int_cst (TREE_TYPE (tmp), 0));
3712 /* A pointer to an array, call library function _gfor_associated. */
3713 gcc_assert (ss2 != gfc_ss_terminator);
3714 arg1se.want_pointer = 1;
3715 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3717 arg2se.want_pointer = 1;
3718 gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
3719 gfc_add_block_to_block (&se->pre, &arg2se.pre);
3720 gfc_add_block_to_block (&se->post, &arg2se.post);
3721 se->expr = build_call_expr (gfor_fndecl_associated, 2,
3722 arg1se.expr, arg2se.expr);
3723 se->expr = convert (boolean_type_node, se->expr);
3724 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3725 se->expr, nonzero_arraylen);
3728 /* If target is present zero character length pointers cannot
3730 if (nonzero_charlen != NULL_TREE)
3731 se->expr = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
3732 se->expr, nonzero_charlen);
3735 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3739 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
3742 gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
3746 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3747 se->expr = build_call_expr (gfor_fndecl_sc_kind, 2, args[0], args[1]);
3748 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3752 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
3755 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
3759 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3761 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
3762 type = gfc_get_int_type (4);
3763 arg = build_fold_addr_expr (fold_convert (type, arg));
3765 /* Convert it to the required type. */
3766 type = gfc_typenode_for_spec (&expr->ts);
3767 se->expr = build_call_expr (gfor_fndecl_si_kind, 1, arg);
3768 se->expr = fold_convert (type, se->expr);
3772 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
3775 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
3777 gfc_actual_arglist *actual;
3782 for (actual = expr->value.function.actual; actual; actual = actual->next)
3784 gfc_init_se (&argse, se);
3786 /* Pass a NULL pointer for an absent arg. */
3787 if (actual->expr == NULL)
3788 argse.expr = null_pointer_node;
3794 if (actual->expr->ts.kind != gfc_c_int_kind)
3796 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
3797 ts.type = BT_INTEGER;
3798 ts.kind = gfc_c_int_kind;
3799 gfc_convert_type (actual->expr, &ts, 2);
3801 gfc_conv_expr_reference (&argse, actual->expr);
3804 gfc_add_block_to_block (&se->pre, &argse.pre);
3805 gfc_add_block_to_block (&se->post, &argse.post);
3806 args = gfc_chainon_list (args, argse.expr);
3809 /* Convert it to the required type. */
3810 type = gfc_typenode_for_spec (&expr->ts);
3811 se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args);
3812 se->expr = fold_convert (type, se->expr);
3816 /* Generate code for TRIM (A) intrinsic function. */
3819 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
3821 tree gfc_int4_type_node = gfc_get_int_type (4);
3830 unsigned int num_args;
3832 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3833 args = alloca (sizeof (tree) * num_args);
3835 type = build_pointer_type (gfc_character1_type_node);
3836 var = gfc_create_var (type, "pstr");
3837 addr = gfc_build_addr_expr (ppvoid_type_node, var);
3838 len = gfc_create_var (gfc_int4_type_node, "len");
3840 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3841 args[0] = build_fold_addr_expr (len);
3844 fndecl = build_addr (gfor_fndecl_string_trim, current_function_decl);
3845 tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_trim)),
3846 fndecl, num_args, args);
3847 gfc_add_expr_to_block (&se->pre, tmp);
3849 /* Free the temporary afterwards, if necessary. */
3850 cond = fold_build2 (GT_EXPR, boolean_type_node,
3851 len, build_int_cst (TREE_TYPE (len), 0));
3852 tmp = gfc_call_free (var);
3853 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
3854 gfc_add_expr_to_block (&se->post, tmp);
3857 se->string_length = len;
3861 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
3864 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
3866 tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
3867 tree type, cond, tmp, count, exit_label, n, max, largest;
3868 stmtblock_t block, body;
3871 /* Get the arguments. */
3872 gfc_conv_intrinsic_function_args (se, expr, args, 3);
3873 slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
3875 ncopies = gfc_evaluate_now (args[2], &se->pre);
3876 ncopies_type = TREE_TYPE (ncopies);
3878 /* Check that NCOPIES is not negative. */
3879 cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
3880 build_int_cst (ncopies_type, 0));
3881 gfc_trans_runtime_check (cond, &se->pre, &expr->where,
3882 "Argument NCOPIES of REPEAT intrinsic is negative "
3883 "(its value is %lld)",
3884 fold_convert (long_integer_type_node, ncopies));
3886 /* If the source length is zero, any non negative value of NCOPIES
3887 is valid, and nothing happens. */
3888 n = gfc_create_var (ncopies_type, "ncopies");
3889 cond = fold_build2 (EQ_EXPR, boolean_type_node, slen,
3890 build_int_cst (size_type_node, 0));
3891 tmp = fold_build3 (COND_EXPR, ncopies_type, cond,
3892 build_int_cst (ncopies_type, 0), ncopies);
3893 gfc_add_modify_expr (&se->pre, n, tmp);
3896 /* Check that ncopies is not too large: ncopies should be less than
3897 (or equal to) MAX / slen, where MAX is the maximal integer of
3898 the gfc_charlen_type_node type. If slen == 0, we need a special
3899 case to avoid the division by zero. */
3900 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
3901 max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
3902 max = fold_build2 (TRUNC_DIV_EXPR, size_type_node,
3903 fold_convert (size_type_node, max), slen);
3904 largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
3905 ? size_type_node : ncopies_type;
3906 cond = fold_build2 (GT_EXPR, boolean_type_node,
3907 fold_convert (largest, ncopies),
3908 fold_convert (largest, max));
3909 tmp = fold_build2 (EQ_EXPR, boolean_type_node, slen,
3910 build_int_cst (size_type_node, 0));
3911 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
3913 gfc_trans_runtime_check (cond, &se->pre, &expr->where,
3914 "Argument NCOPIES of REPEAT intrinsic is too large");
3917 /* Compute the destination length. */
3918 dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
3919 fold_convert (gfc_charlen_type_node, slen),
3920 fold_convert (gfc_charlen_type_node, ncopies));
3921 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
3922 dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
3924 /* Generate the code to do the repeat operation:
3925 for (i = 0; i < ncopies; i++)
3926 memmove (dest + (i * slen), src, slen); */
3927 gfc_start_block (&block);
3928 count = gfc_create_var (ncopies_type, "count");
3929 gfc_add_modify_expr (&block, count, build_int_cst (ncopies_type, 0));
3930 exit_label = gfc_build_label_decl (NULL_TREE);
3932 /* Start the loop body. */
3933 gfc_start_block (&body);
3935 /* Exit the loop if count >= ncopies. */
3936 cond = fold_build2 (GE_EXPR, boolean_type_node, count, ncopies);
3937 tmp = build1_v (GOTO_EXPR, exit_label);
3938 TREE_USED (exit_label) = 1;
3939 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3940 build_empty_stmt ());
3941 gfc_add_expr_to_block (&body, tmp);
3943 /* Call memmove (dest + (i*slen), src, slen). */
3944 tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
3945 fold_convert (gfc_charlen_type_node, slen),
3946 fold_convert (gfc_charlen_type_node, count));
3947 tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node,
3948 fold_convert (pchar_type_node, dest),
3949 fold_convert (sizetype, tmp));
3950 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3,
3952 gfc_add_expr_to_block (&body, tmp);
3954 /* Increment count. */
3955 tmp = fold_build2 (PLUS_EXPR, ncopies_type,
3956 count, build_int_cst (TREE_TYPE (count), 1));
3957 gfc_add_modify_expr (&body, count, tmp);
3959 /* Build the loop. */
3960 tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
3961 gfc_add_expr_to_block (&block, tmp);
3963 /* Add the exit label. */
3964 tmp = build1_v (LABEL_EXPR, exit_label);
3965 gfc_add_expr_to_block (&block, tmp);
3967 /* Finish the block. */
3968 tmp = gfc_finish_block (&block);
3969 gfc_add_expr_to_block (&se->pre, tmp);
3971 /* Set the result value. */
3973 se->string_length = dlen;
3977 /* Generate code for the IARGC intrinsic. */
3980 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
3986 /* Call the library function. This always returns an INTEGER(4). */
3987 fndecl = gfor_fndecl_iargc;
3988 tmp = build_call_expr (fndecl, 0);
3990 /* Convert it to the required type. */
3991 type = gfc_typenode_for_spec (&expr->ts);
3992 tmp = fold_convert (type, tmp);
3998 /* The loc intrinsic returns the address of its argument as
3999 gfc_index_integer_kind integer. */
4002 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
4008 gcc_assert (!se->ss);
4010 arg_expr = expr->value.function.actual->expr;
4011 ss = gfc_walk_expr (arg_expr);
4012 if (ss == gfc_ss_terminator)
4013 gfc_conv_expr_reference (se, arg_expr);
4015 gfc_conv_array_parameter (se, arg_expr, ss, 1);
4016 se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
4018 /* Create a temporary variable for loc return value. Without this,
4019 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
4020 temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
4021 gfc_add_modify_expr (&se->pre, temp_var, se->expr);
4022 se->expr = temp_var;
4025 /* Generate code for an intrinsic function. Some map directly to library
4026 calls, others get special handling. In some cases the name of the function
4027 used depends on the type specifiers. */
4030 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
4032 gfc_intrinsic_sym *isym;
4036 isym = expr->value.function.isym;
4038 name = &expr->value.function.name[2];
4040 if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
4042 lib = gfc_is_intrinsic_libcall (expr);
4046 se->ignore_optional = 1;
4047 gfc_conv_intrinsic_funcall (se, expr);
4052 switch (expr->value.function.isym->id)
4057 case GFC_ISYM_REPEAT:
4058 gfc_conv_intrinsic_repeat (se, expr);
4062 gfc_conv_intrinsic_trim (se, expr);
4065 case GFC_ISYM_SC_KIND:
4066 gfc_conv_intrinsic_sc_kind (se, expr);
4069 case GFC_ISYM_SI_KIND:
4070 gfc_conv_intrinsic_si_kind (se, expr);
4073 case GFC_ISYM_SR_KIND:
4074 gfc_conv_intrinsic_sr_kind (se, expr);
4077 case GFC_ISYM_EXPONENT:
4078 gfc_conv_intrinsic_exponent (se, expr);
4082 gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_scan);
4085 case GFC_ISYM_VERIFY:
4086 gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_verify);
4089 case GFC_ISYM_ALLOCATED:
4090 gfc_conv_allocated (se, expr);
4093 case GFC_ISYM_ASSOCIATED:
4094 gfc_conv_associated(se, expr);
4098 gfc_conv_intrinsic_abs (se, expr);
4101 case GFC_ISYM_ADJUSTL:
4102 gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
4105 case GFC_ISYM_ADJUSTR:
4106 gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
4109 case GFC_ISYM_AIMAG:
4110 gfc_conv_intrinsic_imagpart (se, expr);
4114 gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
4118 gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
4121 case GFC_ISYM_ANINT:
4122 gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
4126 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
4130 gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
4133 case GFC_ISYM_BTEST:
4134 gfc_conv_intrinsic_btest (se, expr);
4137 case GFC_ISYM_ACHAR:
4139 gfc_conv_intrinsic_char (se, expr);
4142 case GFC_ISYM_CONVERSION:
4144 case GFC_ISYM_LOGICAL:
4146 gfc_conv_intrinsic_conversion (se, expr);
4149 /* Integer conversions are handled separately to make sure we get the
4150 correct rounding mode. */
4155 gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
4159 gfc_conv_intrinsic_int (se, expr, RND_ROUND);
4162 case GFC_ISYM_CEILING:
4163 gfc_conv_intrinsic_int (se, expr, RND_CEIL);
4166 case GFC_ISYM_FLOOR:
4167 gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
4171 gfc_conv_intrinsic_mod (se, expr, 0);
4174 case GFC_ISYM_MODULO:
4175 gfc_conv_intrinsic_mod (se, expr, 1);
4178 case GFC_ISYM_CMPLX:
4179 gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
4182 case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
4183 gfc_conv_intrinsic_iargc (se, expr);
4186 case GFC_ISYM_COMPLEX:
4187 gfc_conv_intrinsic_cmplx (se, expr, 1);
4190 case GFC_ISYM_CONJG:
4191 gfc_conv_intrinsic_conjg (se, expr);
4194 case GFC_ISYM_COUNT:
4195 gfc_conv_intrinsic_count (se, expr);
4198 case GFC_ISYM_CTIME:
4199 gfc_conv_intrinsic_ctime (se, expr);
4203 gfc_conv_intrinsic_dim (se, expr);
4206 case GFC_ISYM_DOT_PRODUCT:
4207 gfc_conv_intrinsic_dot_product (se, expr);
4210 case GFC_ISYM_DPROD:
4211 gfc_conv_intrinsic_dprod (se, expr);
4214 case GFC_ISYM_FDATE:
4215 gfc_conv_intrinsic_fdate (se, expr);
4218 case GFC_ISYM_FRACTION:
4219 gfc_conv_intrinsic_fraction (se, expr);
4223 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
4226 case GFC_ISYM_IBCLR:
4227 gfc_conv_intrinsic_singlebitop (se, expr, 0);
4230 case GFC_ISYM_IBITS:
4231 gfc_conv_intrinsic_ibits (se, expr);
4234 case GFC_ISYM_IBSET:
4235 gfc_conv_intrinsic_singlebitop (se, expr, 1);
4238 case GFC_ISYM_IACHAR:
4239 case GFC_ISYM_ICHAR:
4240 /* We assume ASCII character sequence. */
4241 gfc_conv_intrinsic_ichar (se, expr);
4244 case GFC_ISYM_IARGC:
4245 gfc_conv_intrinsic_iargc (se, expr);
4249 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
4252 case GFC_ISYM_INDEX:
4253 gfc_conv_intrinsic_index_scan_verify (se, expr, gfor_fndecl_string_index);
4257 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
4260 case GFC_ISYM_IS_IOSTAT_END:
4261 gfc_conv_has_intvalue (se, expr, LIBERROR_END);
4264 case GFC_ISYM_IS_IOSTAT_EOR:
4265 gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
4268 case GFC_ISYM_ISNAN:
4269 gfc_conv_intrinsic_isnan (se, expr);
4272 case GFC_ISYM_LSHIFT:
4273 gfc_conv_intrinsic_rlshift (se, expr, 0);
4276 case GFC_ISYM_RSHIFT:
4277 gfc_conv_intrinsic_rlshift (se, expr, 1);
4280 case GFC_ISYM_ISHFT:
4281 gfc_conv_intrinsic_ishft (se, expr);
4284 case GFC_ISYM_ISHFTC:
4285 gfc_conv_intrinsic_ishftc (se, expr);
4288 case GFC_ISYM_LBOUND:
4289 gfc_conv_intrinsic_bound (se, expr, 0);
4292 case GFC_ISYM_TRANSPOSE:
4293 if (se->ss && se->ss->useflags)
4295 gfc_conv_tmp_array_ref (se);
4296 gfc_advance_se_ss_chain (se);
4299 gfc_conv_array_transpose (se, expr->value.function.actual->expr);
4303 gfc_conv_intrinsic_len (se, expr);
4306 case GFC_ISYM_LEN_TRIM:
4307 gfc_conv_intrinsic_len_trim (se, expr);
4311 gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
4315 gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
4319 gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
4323 gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
4327 if (expr->ts.type == BT_CHARACTER)
4328 gfc_conv_intrinsic_minmax_char (se, expr, 1);
4330 gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
4333 case GFC_ISYM_MAXLOC:
4334 gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
4337 case GFC_ISYM_MAXVAL:
4338 gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
4341 case GFC_ISYM_MERGE:
4342 gfc_conv_intrinsic_merge (se, expr);
4346 if (expr->ts.type == BT_CHARACTER)
4347 gfc_conv_intrinsic_minmax_char (se, expr, -1);
4349 gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
4352 case GFC_ISYM_MINLOC:
4353 gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
4356 case GFC_ISYM_MINVAL:
4357 gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
4360 case GFC_ISYM_NEAREST:
4361 gfc_conv_intrinsic_nearest (se, expr);
4365 gfc_conv_intrinsic_not (se, expr);
4369 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
4372 case GFC_ISYM_PRESENT:
4373 gfc_conv_intrinsic_present (se, expr);
4376 case GFC_ISYM_PRODUCT:
4377 gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
4380 case GFC_ISYM_RRSPACING:
4381 gfc_conv_intrinsic_rrspacing (se, expr);
4384 case GFC_ISYM_SET_EXPONENT:
4385 gfc_conv_intrinsic_set_exponent (se, expr);
4388 case GFC_ISYM_SCALE:
4389 gfc_conv_intrinsic_scale (se, expr);
4393 gfc_conv_intrinsic_sign (se, expr);
4397 gfc_conv_intrinsic_size (se, expr);
4400 case GFC_ISYM_SIZEOF:
4401 gfc_conv_intrinsic_sizeof (se, expr);
4404 case GFC_ISYM_SPACING:
4405 gfc_conv_intrinsic_spacing (se, expr);
4409 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
4412 case GFC_ISYM_TRANSFER:
4415 if (se->ss->useflags)
4417 /* Access the previously obtained result. */
4418 gfc_conv_tmp_array_ref (se);
4419 gfc_advance_se_ss_chain (se);
4423 gfc_conv_intrinsic_array_transfer (se, expr);
4426 gfc_conv_intrinsic_transfer (se, expr);
4429 case GFC_ISYM_TTYNAM:
4430 gfc_conv_intrinsic_ttynam (se, expr);
4433 case GFC_ISYM_UBOUND:
4434 gfc_conv_intrinsic_bound (se, expr, 1);
4438 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
4442 gfc_conv_intrinsic_loc (se, expr);
4445 case GFC_ISYM_ACCESS:
4446 case GFC_ISYM_CHDIR:
4447 case GFC_ISYM_CHMOD:
4448 case GFC_ISYM_DTIME:
4449 case GFC_ISYM_ETIME:
4451 case GFC_ISYM_FGETC:
4454 case GFC_ISYM_FPUTC:
4455 case GFC_ISYM_FSTAT:
4456 case GFC_ISYM_FTELL:
4457 case GFC_ISYM_GETCWD:
4458 case GFC_ISYM_GETGID:
4459 case GFC_ISYM_GETPID:
4460 case GFC_ISYM_GETUID:
4461 case GFC_ISYM_HOSTNM:
4463 case GFC_ISYM_IERRNO:
4464 case GFC_ISYM_IRAND:
4465 case GFC_ISYM_ISATTY:
4467 case GFC_ISYM_LSTAT:
4468 case GFC_ISYM_MALLOC:
4469 case GFC_ISYM_MATMUL:
4470 case GFC_ISYM_MCLOCK:
4471 case GFC_ISYM_MCLOCK8:
4473 case GFC_ISYM_RENAME:
4474 case GFC_ISYM_SECOND:
4475 case GFC_ISYM_SECNDS:
4476 case GFC_ISYM_SIGNAL:
4478 case GFC_ISYM_SYMLNK:
4479 case GFC_ISYM_SYSTEM:
4481 case GFC_ISYM_TIME8:
4482 case GFC_ISYM_UMASK:
4483 case GFC_ISYM_UNLINK:
4484 gfc_conv_intrinsic_funcall (se, expr);
4488 gfc_conv_intrinsic_lib_function (se, expr);
4494 /* This generates code to execute before entering the scalarization loop.
4495 Currently does nothing. */
4498 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
4500 switch (ss->expr->value.function.isym->id)
4502 case GFC_ISYM_UBOUND:
4503 case GFC_ISYM_LBOUND:
4512 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
4513 inside the scalarization loop. */
4516 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
4520 /* The two argument version returns a scalar. */
4521 if (expr->value.function.actual->next->expr)
4524 newss = gfc_get_ss ();
4525 newss->type = GFC_SS_INTRINSIC;
4528 newss->data.info.dimen = 1;
4534 /* Walk an intrinsic array libcall. */
4537 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
4541 gcc_assert (expr->rank > 0);
4543 newss = gfc_get_ss ();
4544 newss->type = GFC_SS_FUNCTION;
4547 newss->data.info.dimen = expr->rank;
4553 /* Returns nonzero if the specified intrinsic function call maps directly to a
4554 an external library call. Should only be used for functions that return
4558 gfc_is_intrinsic_libcall (gfc_expr * expr)
4560 gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
4561 gcc_assert (expr->rank > 0);
4563 switch (expr->value.function.isym->id)
4567 case GFC_ISYM_COUNT:
4568 case GFC_ISYM_MATMUL:
4569 case GFC_ISYM_MAXLOC:
4570 case GFC_ISYM_MAXVAL:
4571 case GFC_ISYM_MINLOC:
4572 case GFC_ISYM_MINVAL:
4573 case GFC_ISYM_PRODUCT:
4575 case GFC_ISYM_SHAPE:
4576 case GFC_ISYM_SPREAD:
4577 case GFC_ISYM_TRANSPOSE:
4578 /* Ignore absent optional parameters. */
4581 case GFC_ISYM_RESHAPE:
4582 case GFC_ISYM_CSHIFT:
4583 case GFC_ISYM_EOSHIFT:
4585 case GFC_ISYM_UNPACK:
4586 /* Pass absent optional parameters. */
4594 /* Walk an intrinsic function. */
4596 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
4597 gfc_intrinsic_sym * isym)
4601 if (isym->elemental)
4602 return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
4604 if (expr->rank == 0)
4607 if (gfc_is_intrinsic_libcall (expr))
4608 return gfc_walk_intrinsic_libfunc (ss, expr);
4610 /* Special cases. */
4613 case GFC_ISYM_LBOUND:
4614 case GFC_ISYM_UBOUND:
4615 return gfc_walk_intrinsic_bound (ss, expr);
4617 case GFC_ISYM_TRANSFER:
4618 return gfc_walk_intrinsic_libfunc (ss, expr);
4621 /* This probably meant someone forgot to add an intrinsic to the above
4622 list(s) when they implemented it, or something's gone horribly
4628 #include "gt-fortran-trans-intrinsic.h"