1 /* Intrinsic translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
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 LIBM_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 true, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
111 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
113 #define LIBF_FUNCTION(ID, NAME, HAVE_COMPLEX) \
114 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
115 END_BUILTINS, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
116 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
117 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
119 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
121 /* Functions built into gcc itself. */
122 #include "mathbuiltins.def"
124 /* Functions in libm. */
125 /* ??? This does exist as BUILT_IN_SCALBN, but doesn't quite fit the
126 pattern for other mathbuiltins.def entries. At present we have no
127 optimizations for this in the common sources. */
128 LIBM_FUNCTION (SCALE, "scalbn", false),
130 /* Functions in libgfortran. */
131 LIBF_FUNCTION (FRACTION, "fraction", false),
132 LIBF_FUNCTION (NEAREST, "nearest", false),
133 LIBF_FUNCTION (RRSPACING, "rrspacing", false),
134 LIBF_FUNCTION (SET_EXPONENT, "set_exponent", false),
135 LIBF_FUNCTION (SPACING, "spacing", false),
138 LIBF_FUNCTION (NONE, NULL, false)
140 #undef DEFINE_MATH_BUILTIN
141 #undef DEFINE_MATH_BUILTIN_C
145 /* Structure for storing components of a floating number to be used by
146 elemental functions to manipulate reals. */
149 tree arg; /* Variable tree to view convert to integer. */
150 tree expn; /* Variable tree to save exponent. */
151 tree frac; /* Variable tree to save fraction. */
152 tree smask; /* Constant tree of sign's mask. */
153 tree emask; /* Constant tree of exponent's mask. */
154 tree fmask; /* Constant tree of fraction's mask. */
155 tree edigits; /* Constant tree of the number of exponent bits. */
156 tree fdigits; /* Constant tree of the number of fraction bits. */
157 tree f1; /* Constant tree of the f1 defined in the real model. */
158 tree bias; /* Constant tree of the bias of exponent in the memory. */
159 tree type; /* Type tree of arg1. */
160 tree mtype; /* Type tree of integer type. Kind is that of arg1. */
164 enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
166 /* Evaluate the arguments to an intrinsic function. The value
167 of NARGS may be less than the actual number of arguments in EXPR
168 to allow optional "KIND" arguments that are not included in the
169 generated code to be ignored. */
172 gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
173 tree *argarray, int nargs)
175 gfc_actual_arglist *actual;
177 gfc_intrinsic_arg *formal;
181 formal = expr->value.function.isym->formal;
182 actual = expr->value.function.actual;
184 for (curr_arg = 0; curr_arg < nargs; curr_arg++,
185 actual = actual->next,
186 formal = formal ? formal->next : NULL)
190 /* Skip omitted optional arguments. */
197 /* Evaluate the parameter. This will substitute scalarized
198 references automatically. */
199 gfc_init_se (&argse, se);
201 if (e->ts.type == BT_CHARACTER)
203 gfc_conv_expr (&argse, e);
204 gfc_conv_string_parameter (&argse);
205 argarray[curr_arg++] = argse.string_length;
206 gcc_assert (curr_arg < nargs);
209 gfc_conv_expr_val (&argse, e);
211 /* If an optional argument is itself an optional dummy argument,
212 check its presence and substitute a null if absent. */
213 if (e->expr_type ==EXPR_VARIABLE
214 && e->symtree->n.sym->attr.optional
217 gfc_conv_missing_dummy (&argse, e, formal->ts);
219 gfc_add_block_to_block (&se->pre, &argse.pre);
220 gfc_add_block_to_block (&se->post, &argse.post);
221 argarray[curr_arg] = argse.expr;
225 /* Count the number of actual arguments to the intrinsic function EXPR
226 including any "hidden" string length arguments. */
229 gfc_intrinsic_argument_list_length (gfc_expr *expr)
232 gfc_actual_arglist *actual;
234 for (actual = expr->value.function.actual; actual; actual = actual->next)
239 if (actual->expr->ts.type == BT_CHARACTER)
249 /* Conversions between different types are output by the frontend as
250 intrinsic functions. We implement these directly with inline code. */
253 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
259 nargs = gfc_intrinsic_argument_list_length (expr);
260 args = alloca (sizeof (tree) * nargs);
262 /* Evaluate all the arguments passed. Whilst we're only interested in the
263 first one here, there are other parts of the front-end that assume this
264 and will trigger an ICE if it's not the case. */
265 type = gfc_typenode_for_spec (&expr->ts);
266 gcc_assert (expr->value.function.actual->expr);
267 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
269 /* Conversion from complex to non-complex involves taking the real
270 component of the value. */
271 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
272 && expr->ts.type != BT_COMPLEX)
276 artype = TREE_TYPE (TREE_TYPE (args[0]));
277 args[0] = build1 (REALPART_EXPR, artype, args[0]);
280 se->expr = convert (type, args[0]);
283 /* This is needed because the gcc backend only implements
284 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
285 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
286 Similarly for CEILING. */
289 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
296 argtype = TREE_TYPE (arg);
297 arg = gfc_evaluate_now (arg, pblock);
299 intval = convert (type, arg);
300 intval = gfc_evaluate_now (intval, pblock);
302 tmp = convert (argtype, intval);
303 cond = build2 (up ? GE_EXPR : LE_EXPR, boolean_type_node, tmp, arg);
305 tmp = build2 (up ? PLUS_EXPR : MINUS_EXPR, type, intval,
306 build_int_cst (type, 1));
307 tmp = build3 (COND_EXPR, type, cond, intval, tmp);
312 /* Round to nearest integer, away from zero. */
315 build_round_expr (tree arg, tree restype)
320 bool longlong, convert;
321 int argprec, resprec;
323 argtype = TREE_TYPE (arg);
324 argprec = TYPE_PRECISION (argtype);
325 resprec = TYPE_PRECISION (restype);
327 /* Depending on the type of the result, choose the long int intrinsic
328 (lround family) or long long intrinsic (llround). We might also
329 need to convert the result afterwards. */
330 if (resprec <= LONG_TYPE_SIZE)
333 if (resprec != LONG_TYPE_SIZE)
338 else if (resprec <= LONG_LONG_TYPE_SIZE)
341 if (resprec != LONG_LONG_TYPE_SIZE)
349 /* Now, depending on the argument type, we choose between intrinsics. */
350 if (argprec == TYPE_PRECISION (float_type_node))
351 fn = built_in_decls[longlong ? BUILT_IN_LLROUNDF : BUILT_IN_LROUNDF];
352 else if (argprec == TYPE_PRECISION (double_type_node))
353 fn = built_in_decls[longlong ? BUILT_IN_LLROUND : BUILT_IN_LROUND];
354 else if (argprec == TYPE_PRECISION (long_double_type_node))
355 fn = built_in_decls[longlong ? BUILT_IN_LLROUNDL : BUILT_IN_LROUNDL];
359 tmp = build_call_expr (fn, 1, arg);
361 tmp = fold_convert (restype, tmp);
366 /* Convert a real to an integer using a specific rounding mode.
367 Ideally we would just build the corresponding GENERIC node,
368 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
371 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
372 enum rounding_mode op)
377 return build_fixbound_expr (pblock, arg, type, 0);
381 return build_fixbound_expr (pblock, arg, type, 1);
385 return build_round_expr (arg, type);
389 return build1 (FIX_TRUNC_EXPR, type, arg);
398 /* Round a real value using the specified rounding mode.
399 We use a temporary integer of that same kind size as the result.
400 Values larger than those that can be represented by this kind are
401 unchanged, as they will not be accurate enough to represent the
403 huge = HUGE (KIND (a))
404 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
408 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
419 kind = expr->ts.kind;
422 /* We have builtin functions for some cases. */
465 /* Evaluate the argument. */
466 gcc_assert (expr->value.function.actual->expr);
467 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
469 /* Use a builtin function if one exists. */
470 if (n != END_BUILTINS)
472 tmp = built_in_decls[n];
473 se->expr = build_call_expr (tmp, 1, arg);
477 /* This code is probably redundant, but we'll keep it lying around just
479 type = gfc_typenode_for_spec (&expr->ts);
480 arg = gfc_evaluate_now (arg, &se->pre);
482 /* Test if the value is too large to handle sensibly. */
483 gfc_set_model_kind (kind);
485 n = gfc_validate_kind (BT_INTEGER, kind, false);
486 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
487 tmp = gfc_conv_mpfr_to_tree (huge, kind);
488 cond = build2 (LT_EXPR, boolean_type_node, arg, tmp);
490 mpfr_neg (huge, huge, GFC_RND_MODE);
491 tmp = gfc_conv_mpfr_to_tree (huge, kind);
492 tmp = build2 (GT_EXPR, boolean_type_node, arg, tmp);
493 cond = build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
494 itype = gfc_get_int_type (kind);
496 tmp = build_fix_expr (&se->pre, arg, itype, op);
497 tmp = convert (type, tmp);
498 se->expr = build3 (COND_EXPR, type, cond, tmp, arg);
503 /* Convert to an integer using the specified rounding mode. */
506 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
512 nargs = gfc_intrinsic_argument_list_length (expr);
513 args = alloca (sizeof (tree) * nargs);
515 /* Evaluate the argument, we process all arguments even though we only
516 use the first one for code generation purposes. */
517 type = gfc_typenode_for_spec (&expr->ts);
518 gcc_assert (expr->value.function.actual->expr);
519 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
521 if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
523 /* Conversion to a different integer kind. */
524 se->expr = convert (type, args[0]);
528 /* Conversion from complex to non-complex involves taking the real
529 component of the value. */
530 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
531 && expr->ts.type != BT_COMPLEX)
535 artype = TREE_TYPE (TREE_TYPE (args[0]));
536 args[0] = build1 (REALPART_EXPR, artype, args[0]);
539 se->expr = build_fix_expr (&se->pre, args[0], type, op);
544 /* Get the imaginary component of a value. */
547 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
551 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
552 se->expr = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
556 /* Get the complex conjugate of a value. */
559 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
563 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
564 se->expr = build1 (CONJ_EXPR, TREE_TYPE (arg), arg);
568 /* Initialize function decls for library functions. The external functions
569 are created as required. Builtin functions are added here. */
572 gfc_build_intrinsic_lib_fndecls (void)
574 gfc_intrinsic_map_t *m;
576 /* Add GCC builtin functions. */
577 for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
579 if (m->code_r4 != END_BUILTINS)
580 m->real4_decl = built_in_decls[m->code_r4];
581 if (m->code_r8 != END_BUILTINS)
582 m->real8_decl = built_in_decls[m->code_r8];
583 if (m->code_r10 != END_BUILTINS)
584 m->real10_decl = built_in_decls[m->code_r10];
585 if (m->code_r16 != END_BUILTINS)
586 m->real16_decl = built_in_decls[m->code_r16];
587 if (m->code_c4 != END_BUILTINS)
588 m->complex4_decl = built_in_decls[m->code_c4];
589 if (m->code_c8 != END_BUILTINS)
590 m->complex8_decl = built_in_decls[m->code_c8];
591 if (m->code_c10 != END_BUILTINS)
592 m->complex10_decl = built_in_decls[m->code_c10];
593 if (m->code_c16 != END_BUILTINS)
594 m->complex16_decl = built_in_decls[m->code_c16];
599 /* Create a fndecl for a simple intrinsic library function. */
602 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
607 gfc_actual_arglist *actual;
610 char name[GFC_MAX_SYMBOL_LEN + 3];
613 if (ts->type == BT_REAL)
618 pdecl = &m->real4_decl;
621 pdecl = &m->real8_decl;
624 pdecl = &m->real10_decl;
627 pdecl = &m->real16_decl;
633 else if (ts->type == BT_COMPLEX)
635 gcc_assert (m->complex_available);
640 pdecl = &m->complex4_decl;
643 pdecl = &m->complex8_decl;
646 pdecl = &m->complex10_decl;
649 pdecl = &m->complex16_decl;
664 snprintf (name, sizeof (name), "%s%s%s",
665 ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
666 else if (ts->kind == 8)
667 snprintf (name, sizeof (name), "%s%s",
668 ts->type == BT_COMPLEX ? "c" : "", m->name);
671 gcc_assert (ts->kind == 10 || ts->kind == 16);
672 snprintf (name, sizeof (name), "%s%s%s",
673 ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
678 snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
679 ts->type == BT_COMPLEX ? 'c' : 'r',
683 argtypes = NULL_TREE;
684 for (actual = expr->value.function.actual; actual; actual = actual->next)
686 type = gfc_typenode_for_spec (&actual->expr->ts);
687 argtypes = gfc_chainon_list (argtypes, type);
689 argtypes = gfc_chainon_list (argtypes, void_type_node);
690 type = build_function_type (gfc_typenode_for_spec (ts), argtypes);
691 fndecl = build_decl (FUNCTION_DECL, get_identifier (name), type);
693 /* Mark the decl as external. */
694 DECL_EXTERNAL (fndecl) = 1;
695 TREE_PUBLIC (fndecl) = 1;
697 /* Mark it __attribute__((const)), if possible. */
698 TREE_READONLY (fndecl) = m->is_constant;
700 rest_of_decl_compilation (fndecl, 1, 0);
707 /* Convert an intrinsic function into an external or builtin call. */
710 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
712 gfc_intrinsic_map_t *m;
716 unsigned int num_args;
719 id = expr->value.function.isym->id;
720 /* Find the entry for this function. */
721 for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
727 if (m->id == GFC_ISYM_NONE)
729 internal_error ("Intrinsic function %s(%d) not recognized",
730 expr->value.function.name, id);
733 /* Get the decl and generate the call. */
734 num_args = gfc_intrinsic_argument_list_length (expr);
735 args = alloca (sizeof (tree) * num_args);
737 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
738 fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
739 rettype = TREE_TYPE (TREE_TYPE (fndecl));
741 fndecl = build_addr (fndecl, current_function_decl);
742 se->expr = build_call_array (rettype, fndecl, num_args, args);
745 /* Generate code for EXPONENT(X) intrinsic function. */
748 gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
750 tree arg, fndecl, type;
753 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
755 a1 = expr->value.function.actual->expr;
759 fndecl = gfor_fndecl_math_exponent4;
762 fndecl = gfor_fndecl_math_exponent8;
765 fndecl = gfor_fndecl_math_exponent10;
768 fndecl = gfor_fndecl_math_exponent16;
774 /* Convert it to the required type. */
775 type = gfc_typenode_for_spec (&expr->ts);
776 se->expr = fold_convert (type, build_call_expr (fndecl, 1, arg));
779 /* Evaluate a single upper or lower bound. */
780 /* TODO: bound intrinsic generates way too much unnecessary code. */
783 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
785 gfc_actual_arglist *arg;
786 gfc_actual_arglist *arg2;
791 tree cond, cond1, cond2, cond3, cond4, size;
799 arg = expr->value.function.actual;
804 /* Create an implicit second parameter from the loop variable. */
805 gcc_assert (!arg2->expr);
806 gcc_assert (se->loop->dimen == 1);
807 gcc_assert (se->ss->expr == expr);
808 gfc_advance_se_ss_chain (se);
809 bound = se->loop->loopvar[0];
810 bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
815 /* use the passed argument. */
816 gcc_assert (arg->next->expr);
817 gfc_init_se (&argse, NULL);
818 gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
819 gfc_add_block_to_block (&se->pre, &argse.pre);
821 /* Convert from one based to zero based. */
822 bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
826 /* TODO: don't re-evaluate the descriptor on each iteration. */
827 /* Get a descriptor for the first parameter. */
828 ss = gfc_walk_expr (arg->expr);
829 gcc_assert (ss != gfc_ss_terminator);
830 gfc_init_se (&argse, NULL);
831 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
832 gfc_add_block_to_block (&se->pre, &argse.pre);
833 gfc_add_block_to_block (&se->post, &argse.post);
837 if (INTEGER_CST_P (bound))
841 hi = TREE_INT_CST_HIGH (bound);
842 low = TREE_INT_CST_LOW (bound);
843 if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
844 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
845 "dimension index", upper ? "UBOUND" : "LBOUND",
850 if (flag_bounds_check)
852 bound = gfc_evaluate_now (bound, &se->pre);
853 cond = fold_build2 (LT_EXPR, boolean_type_node,
854 bound, build_int_cst (TREE_TYPE (bound), 0));
855 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
856 tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
857 cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
858 gfc_trans_runtime_check (cond, gfc_msg_fault, &se->pre, &expr->where);
862 ubound = gfc_conv_descriptor_ubound (desc, bound);
863 lbound = gfc_conv_descriptor_lbound (desc, bound);
865 /* Follow any component references. */
866 if (arg->expr->expr_type == EXPR_VARIABLE
867 || arg->expr->expr_type == EXPR_CONSTANT)
869 as = arg->expr->symtree->n.sym->as;
870 for (ref = arg->expr->ref; ref; ref = ref->next)
875 as = ref->u.c.component->as;
883 switch (ref->u.ar.type)
901 /* 13.14.53: Result value for LBOUND
903 Case (i): For an array section or for an array expression other than a
904 whole array or array structure component, LBOUND(ARRAY, DIM)
905 has the value 1. For a whole array or array structure
906 component, LBOUND(ARRAY, DIM) has the value:
907 (a) equal to the lower bound for subscript DIM of ARRAY if
908 dimension DIM of ARRAY does not have extent zero
909 or if ARRAY is an assumed-size array of rank DIM,
912 13.14.113: Result value for UBOUND
914 Case (i): For an array section or for an array expression other than a
915 whole array or array structure component, UBOUND(ARRAY, DIM)
916 has the value equal to the number of elements in the given
917 dimension; otherwise, it has a value equal to the upper bound
918 for subscript DIM of ARRAY if dimension DIM of ARRAY does
919 not have size zero and has value zero if dimension DIM has
924 tree stride = gfc_conv_descriptor_stride (desc, bound);
926 cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound);
927 cond2 = fold_build2 (LE_EXPR, boolean_type_node, ubound, lbound);
929 cond3 = fold_build2 (GE_EXPR, boolean_type_node, stride,
930 gfc_index_zero_node);
931 cond3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
933 cond4 = fold_build2 (LT_EXPR, boolean_type_node, stride,
934 gfc_index_zero_node);
935 cond4 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond4, cond2);
939 cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
941 se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
942 ubound, gfc_index_zero_node);
946 if (as->type == AS_ASSUMED_SIZE)
947 cond = fold_build2 (EQ_EXPR, boolean_type_node, bound,
948 build_int_cst (TREE_TYPE (bound),
949 arg->expr->rank - 1));
951 cond = boolean_false_node;
953 cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
954 cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1);
956 se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
957 lbound, gfc_index_one_node);
964 size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
965 se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
969 se->expr = gfc_index_one_node;
972 type = gfc_typenode_for_spec (&expr->ts);
973 se->expr = convert (type, se->expr);
978 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
983 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
985 switch (expr->value.function.actual->expr->ts.type)
989 se->expr = build1 (ABS_EXPR, TREE_TYPE (arg), arg);
993 switch (expr->ts.kind)
1008 se->expr = build_call_expr (built_in_decls[n], 1, arg);
1017 /* Create a complex value from one or two real components. */
1020 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
1026 unsigned int num_args;
1028 num_args = gfc_intrinsic_argument_list_length (expr);
1029 args = alloca (sizeof (tree) * num_args);
1031 type = gfc_typenode_for_spec (&expr->ts);
1032 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
1033 real = convert (TREE_TYPE (type), args[0]);
1035 imag = convert (TREE_TYPE (type), args[1]);
1036 else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
1038 imag = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (args[0])), args[0]);
1039 imag = convert (TREE_TYPE (type), imag);
1042 imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
1044 se->expr = fold_build2 (COMPLEX_EXPR, type, real, imag);
1047 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1048 MODULO(A, P) = A - FLOOR (A / P) * P */
1049 /* TODO: MOD(x, 0) */
1052 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
1063 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1065 switch (expr->ts.type)
1068 /* Integer case is easy, we've got a builtin op. */
1069 type = TREE_TYPE (args[0]);
1072 se->expr = build2 (FLOOR_MOD_EXPR, type, args[0], args[1]);
1074 se->expr = build2 (TRUNC_MOD_EXPR, type, args[0], args[1]);
1079 /* Check if we have a builtin fmod. */
1080 switch (expr->ts.kind)
1099 /* Use it if it exists. */
1100 if (n != END_BUILTINS)
1102 tmp = build_addr (built_in_decls[n], current_function_decl);
1103 se->expr = build_call_array (TREE_TYPE (TREE_TYPE (built_in_decls[n])),
1109 type = TREE_TYPE (args[0]);
1111 args[0] = gfc_evaluate_now (args[0], &se->pre);
1112 args[1] = gfc_evaluate_now (args[1], &se->pre);
1115 modulo = arg - floor (arg/arg2) * arg2, so
1116 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1118 test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1119 thereby avoiding another division and retaining the accuracy
1120 of the builtin function. */
1121 if (n != END_BUILTINS && modulo)
1123 tree zero = gfc_build_const (type, integer_zero_node);
1124 tmp = gfc_evaluate_now (se->expr, &se->pre);
1125 test = build2 (LT_EXPR, boolean_type_node, args[0], zero);
1126 test2 = build2 (LT_EXPR, boolean_type_node, args[1], zero);
1127 test2 = build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2);
1128 test = build2 (NE_EXPR, boolean_type_node, tmp, zero);
1129 test = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1130 test = gfc_evaluate_now (test, &se->pre);
1131 se->expr = build3 (COND_EXPR, type, test,
1132 build2 (PLUS_EXPR, type, tmp, args[1]), tmp);
1136 /* If we do not have a built_in fmod, the calculation is going to
1137 have to be done longhand. */
1138 tmp = build2 (RDIV_EXPR, type, args[0], args[1]);
1140 /* Test if the value is too large to handle sensibly. */
1141 gfc_set_model_kind (expr->ts.kind);
1143 n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true);
1144 ikind = expr->ts.kind;
1147 n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false);
1148 ikind = gfc_max_integer_kind;
1150 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
1151 test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
1152 test2 = build2 (LT_EXPR, boolean_type_node, tmp, test);
1154 mpfr_neg (huge, huge, GFC_RND_MODE);
1155 test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
1156 test = build2 (GT_EXPR, boolean_type_node, tmp, test);
1157 test2 = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1159 itype = gfc_get_int_type (ikind);
1161 tmp = build_fix_expr (&se->pre, tmp, itype, RND_FLOOR);
1163 tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC);
1164 tmp = convert (type, tmp);
1165 tmp = build3 (COND_EXPR, type, test2, tmp, args[0]);
1166 tmp = build2 (MULT_EXPR, type, tmp, args[1]);
1167 se->expr = build2 (MINUS_EXPR, type, args[0], tmp);
1176 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
1179 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
1187 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1188 type = TREE_TYPE (args[0]);
1190 val = build2 (MINUS_EXPR, type, args[0], args[1]);
1191 val = gfc_evaluate_now (val, &se->pre);
1193 zero = gfc_build_const (type, integer_zero_node);
1194 tmp = build2 (LE_EXPR, boolean_type_node, val, zero);
1195 se->expr = build3 (COND_EXPR, type, tmp, zero, val);
1199 /* SIGN(A, B) is absolute value of A times sign of B.
1200 The real value versions use library functions to ensure the correct
1201 handling of negative zero. Integer case implemented as:
1202 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1206 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
1212 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1213 if (expr->ts.type == BT_REAL)
1215 switch (expr->ts.kind)
1218 tmp = built_in_decls[BUILT_IN_COPYSIGNF];
1221 tmp = built_in_decls[BUILT_IN_COPYSIGN];
1225 tmp = built_in_decls[BUILT_IN_COPYSIGNL];
1230 se->expr = build_call_expr (tmp, 2, args[0], args[1]);
1234 /* Having excluded floating point types, we know we are now dealing
1235 with signed integer types. */
1236 type = TREE_TYPE (args[0]);
1238 /* Args[0] is used multiple times below. */
1239 args[0] = gfc_evaluate_now (args[0], &se->pre);
1241 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1242 the signs of A and B are the same, and of all ones if they differ. */
1243 tmp = fold_build2 (BIT_XOR_EXPR, type, args[0], args[1]);
1244 tmp = fold_build2 (RSHIFT_EXPR, type, tmp,
1245 build_int_cst (type, TYPE_PRECISION (type) - 1));
1246 tmp = gfc_evaluate_now (tmp, &se->pre);
1248 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1249 is all ones (i.e. -1). */
1250 se->expr = fold_build2 (BIT_XOR_EXPR, type,
1251 fold_build2 (PLUS_EXPR, type, args[0], tmp),
1256 /* Test for the presence of an optional argument. */
1259 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
1263 arg = expr->value.function.actual->expr;
1264 gcc_assert (arg->expr_type == EXPR_VARIABLE);
1265 se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
1266 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
1270 /* Calculate the double precision product of two single precision values. */
1273 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
1278 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1280 /* Convert the args to double precision before multiplying. */
1281 type = gfc_typenode_for_spec (&expr->ts);
1282 args[0] = convert (type, args[0]);
1283 args[1] = convert (type, args[1]);
1284 se->expr = build2 (MULT_EXPR, type, args[0], args[1]);
1288 /* Return a length one character string containing an ascii character. */
1291 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
1297 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
1299 /* We currently don't support character types != 1. */
1300 gcc_assert (expr->ts.kind == 1);
1301 type = gfc_character1_type_node;
1302 var = gfc_create_var (type, "char");
1304 arg = convert (type, arg);
1305 gfc_add_modify_expr (&se->pre, var, arg);
1306 se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
1307 se->string_length = integer_one_node;
1312 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
1319 tree gfc_int8_type_node = gfc_get_int_type (8);
1322 unsigned int num_args;
1324 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1325 args = alloca (sizeof (tree) * num_args);
1327 type = build_pointer_type (gfc_character1_type_node);
1328 var = gfc_create_var (type, "pstr");
1329 len = gfc_create_var (gfc_int8_type_node, "len");
1331 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1332 args[0] = build_fold_addr_expr (var);
1333 args[1] = build_fold_addr_expr (len);
1335 fndecl = build_addr (gfor_fndecl_ctime, current_function_decl);
1336 tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
1337 fndecl, num_args, args);
1338 gfc_add_expr_to_block (&se->pre, tmp);
1340 /* Free the temporary afterwards, if necessary. */
1341 cond = build2 (GT_EXPR, boolean_type_node, len,
1342 build_int_cst (TREE_TYPE (len), 0));
1343 tmp = gfc_call_free (var);
1344 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1345 gfc_add_expr_to_block (&se->post, tmp);
1348 se->string_length = len;
1353 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
1360 tree gfc_int4_type_node = gfc_get_int_type (4);
1363 unsigned int num_args;
1365 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1366 args = alloca (sizeof (tree) * num_args);
1368 type = build_pointer_type (gfc_character1_type_node);
1369 var = gfc_create_var (type, "pstr");
1370 len = gfc_create_var (gfc_int4_type_node, "len");
1372 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1373 args[0] = build_fold_addr_expr (var);
1374 args[1] = build_fold_addr_expr (len);
1376 fndecl = build_addr (gfor_fndecl_fdate, current_function_decl);
1377 tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
1378 fndecl, num_args, args);
1379 gfc_add_expr_to_block (&se->pre, tmp);
1381 /* Free the temporary afterwards, if necessary. */
1382 cond = build2 (GT_EXPR, boolean_type_node, len,
1383 build_int_cst (TREE_TYPE (len), 0));
1384 tmp = gfc_call_free (var);
1385 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1386 gfc_add_expr_to_block (&se->post, tmp);
1389 se->string_length = len;
1393 /* Return a character string containing the tty name. */
1396 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
1404 tree gfc_int4_type_node = gfc_get_int_type (4);
1406 unsigned int num_args;
1408 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1409 args = alloca (sizeof (tree) * num_args);
1411 type = build_pointer_type (gfc_character1_type_node);
1412 var = gfc_create_var (type, "pstr");
1413 len = gfc_create_var (gfc_int4_type_node, "len");
1415 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1416 args[0] = build_fold_addr_expr (var);
1417 args[1] = build_fold_addr_expr (len);
1419 fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl);
1420 tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
1421 fndecl, num_args, args);
1422 gfc_add_expr_to_block (&se->pre, tmp);
1424 /* Free the temporary afterwards, if necessary. */
1425 cond = build2 (GT_EXPR, boolean_type_node, len,
1426 build_int_cst (TREE_TYPE (len), 0));
1427 tmp = gfc_call_free (var);
1428 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1429 gfc_add_expr_to_block (&se->post, tmp);
1432 se->string_length = len;
1436 /* Get the minimum/maximum value of all the parameters.
1437 minmax (a1, a2, a3, ...)
1439 if (a2 .op. a1 || isnan(a1))
1443 if (a3 .op. mvar || isnan(mvar))
1450 /* TODO: Mismatching types can occur when specific names are used.
1451 These should be handled during resolution. */
1453 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
1463 gfc_actual_arglist *argexpr;
1467 nargs = gfc_intrinsic_argument_list_length (expr);
1468 args = alloca (sizeof (tree) * nargs);
1470 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
1471 type = gfc_typenode_for_spec (&expr->ts);
1473 /* The first and second arguments should be present, if they are
1474 optional dummy arguments. */
1475 argexpr = expr->value.function.actual;
1476 if (argexpr->expr->expr_type == EXPR_VARIABLE
1477 && argexpr->expr->symtree->n.sym->attr.optional
1478 && TREE_CODE (args[0]) == INDIRECT_REF)
1480 /* Check the first argument. */
1484 asprintf (&msg, "First argument of '%s' intrinsic should be present",
1485 expr->symtree->n.sym->name);
1486 cond = build2 (EQ_EXPR, boolean_type_node, TREE_OPERAND (args[0], 0),
1487 build_int_cst (TREE_TYPE (TREE_OPERAND (args[0], 0)), 0));
1488 gfc_trans_runtime_check (cond, msg, &se->pre, &expr->where);
1492 if (argexpr->next->expr->expr_type == EXPR_VARIABLE
1493 && argexpr->next->expr->symtree->n.sym->attr.optional
1494 && TREE_CODE (args[1]) == INDIRECT_REF)
1496 /* Check the second argument. */
1500 asprintf (&msg, "Second argument of '%s' intrinsic should be present",
1501 expr->symtree->n.sym->name);
1502 cond = build2 (EQ_EXPR, boolean_type_node, TREE_OPERAND (args[1], 0),
1503 build_int_cst (TREE_TYPE (TREE_OPERAND (args[1], 0)), 0));
1504 gfc_trans_runtime_check (cond, msg, &se->pre, &expr->where);
1509 if (TREE_TYPE (limit) != type)
1510 limit = convert (type, limit);
1511 /* Only evaluate the argument once. */
1512 if (TREE_CODE (limit) != VAR_DECL && !TREE_CONSTANT (limit))
1513 limit = gfc_evaluate_now (limit, &se->pre);
1515 mvar = gfc_create_var (type, "M");
1516 elsecase = build2_v (MODIFY_EXPR, mvar, limit);
1517 for (i = 1, argexpr = argexpr->next; i < nargs; i++)
1523 /* Handle absent optional arguments by ignoring the comparison. */
1524 if (i > 0 && argexpr->expr->expr_type == EXPR_VARIABLE
1525 && argexpr->expr->symtree->n.sym->attr.optional
1526 && TREE_CODE (val) == INDIRECT_REF)
1527 cond = build2 (NE_EXPR, boolean_type_node, TREE_OPERAND (val, 0),
1528 build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
1533 /* Only evaluate the argument once. */
1534 if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
1535 val = gfc_evaluate_now (val, &se->pre);
1538 thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
1540 tmp = build2 (op, boolean_type_node, convert (type, val), limit);
1542 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
1543 __builtin_isnan might be made dependent on that module being loaded,
1544 to help performance of programs that don't rely on IEEE semantics. */
1545 if (FLOAT_TYPE_P (TREE_TYPE (limit)))
1547 isnan = build_call_expr (built_in_decls[BUILT_IN_ISNAN], 1, limit);
1548 tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, isnan);
1550 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
1552 if (cond != NULL_TREE)
1553 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1555 gfc_add_expr_to_block (&se->pre, tmp);
1556 elsecase = build_empty_stmt ();
1558 argexpr = argexpr->next;
1564 /* Create a symbol node for this intrinsic. The symbol from the frontend
1565 has the generic name. */
1568 gfc_get_symbol_for_expr (gfc_expr * expr)
1572 /* TODO: Add symbols for intrinsic function to the global namespace. */
1573 gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
1574 sym = gfc_new_symbol (expr->value.function.name, NULL);
1577 sym->attr.external = 1;
1578 sym->attr.function = 1;
1579 sym->attr.always_explicit = 1;
1580 sym->attr.proc = PROC_INTRINSIC;
1581 sym->attr.flavor = FL_PROCEDURE;
1585 sym->attr.dimension = 1;
1586 sym->as = gfc_get_array_spec ();
1587 sym->as->type = AS_ASSUMED_SHAPE;
1588 sym->as->rank = expr->rank;
1591 /* TODO: proper argument lists for external intrinsics. */
1595 /* Generate a call to an external intrinsic function. */
1597 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
1602 gcc_assert (!se->ss || se->ss->expr == expr);
1605 gcc_assert (expr->rank > 0);
1607 gcc_assert (expr->rank == 0);
1609 sym = gfc_get_symbol_for_expr (expr);
1611 /* Calls to libgfortran_matmul need to be appended special arguments,
1612 to be able to call the BLAS ?gemm functions if required and possible. */
1613 append_args = NULL_TREE;
1614 if (expr->value.function.isym->id == GFC_ISYM_MATMUL
1615 && sym->ts.type != BT_LOGICAL)
1617 tree cint = gfc_get_int_type (gfc_c_int_kind);
1619 if (gfc_option.flag_external_blas
1620 && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
1621 && (sym->ts.kind == gfc_default_real_kind
1622 || sym->ts.kind == gfc_default_double_kind))
1626 if (sym->ts.type == BT_REAL)
1628 if (sym->ts.kind == gfc_default_real_kind)
1629 gemm_fndecl = gfor_fndecl_sgemm;
1631 gemm_fndecl = gfor_fndecl_dgemm;
1635 if (sym->ts.kind == gfc_default_real_kind)
1636 gemm_fndecl = gfor_fndecl_cgemm;
1638 gemm_fndecl = gfor_fndecl_zgemm;
1641 append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 1));
1642 append_args = gfc_chainon_list
1643 (append_args, build_int_cst
1644 (cint, gfc_option.blas_matmul_limit));
1645 append_args = gfc_chainon_list (append_args,
1646 gfc_build_addr_expr (NULL_TREE,
1651 append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 0));
1652 append_args = gfc_chainon_list (append_args, build_int_cst (cint, 0));
1653 append_args = gfc_chainon_list (append_args, null_pointer_node);
1657 gfc_conv_function_call (se, sym, expr->value.function.actual, append_args);
1661 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1681 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op)
1690 gfc_actual_arglist *actual;
1697 gfc_conv_intrinsic_funcall (se, expr);
1701 actual = expr->value.function.actual;
1702 type = gfc_typenode_for_spec (&expr->ts);
1703 /* Initialize the result. */
1704 resvar = gfc_create_var (type, "test");
1706 tmp = convert (type, boolean_true_node);
1708 tmp = convert (type, boolean_false_node);
1709 gfc_add_modify_expr (&se->pre, resvar, tmp);
1711 /* Walk the arguments. */
1712 arrayss = gfc_walk_expr (actual->expr);
1713 gcc_assert (arrayss != gfc_ss_terminator);
1715 /* Initialize the scalarizer. */
1716 gfc_init_loopinfo (&loop);
1717 exit_label = gfc_build_label_decl (NULL_TREE);
1718 TREE_USED (exit_label) = 1;
1719 gfc_add_ss_to_loop (&loop, arrayss);
1721 /* Initialize the loop. */
1722 gfc_conv_ss_startstride (&loop);
1723 gfc_conv_loop_setup (&loop);
1725 gfc_mark_ss_chain_used (arrayss, 1);
1726 /* Generate the loop body. */
1727 gfc_start_scalarized_body (&loop, &body);
1729 /* If the condition matches then set the return value. */
1730 gfc_start_block (&block);
1732 tmp = convert (type, boolean_false_node);
1734 tmp = convert (type, boolean_true_node);
1735 gfc_add_modify_expr (&block, resvar, tmp);
1737 /* And break out of the loop. */
1738 tmp = build1_v (GOTO_EXPR, exit_label);
1739 gfc_add_expr_to_block (&block, tmp);
1741 found = gfc_finish_block (&block);
1743 /* Check this element. */
1744 gfc_init_se (&arrayse, NULL);
1745 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1746 arrayse.ss = arrayss;
1747 gfc_conv_expr_val (&arrayse, actual->expr);
1749 gfc_add_block_to_block (&body, &arrayse.pre);
1750 tmp = fold_build2 (op, boolean_type_node, arrayse.expr,
1751 build_int_cst (TREE_TYPE (arrayse.expr), 0));
1752 tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt ());
1753 gfc_add_expr_to_block (&body, tmp);
1754 gfc_add_block_to_block (&body, &arrayse.post);
1756 gfc_trans_scalarizing_loops (&loop, &body);
1758 /* Add the exit label. */
1759 tmp = build1_v (LABEL_EXPR, exit_label);
1760 gfc_add_expr_to_block (&loop.pre, tmp);
1762 gfc_add_block_to_block (&se->pre, &loop.pre);
1763 gfc_add_block_to_block (&se->pre, &loop.post);
1764 gfc_cleanup_loop (&loop);
1769 /* COUNT(A) = Number of true elements in A. */
1771 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
1778 gfc_actual_arglist *actual;
1784 gfc_conv_intrinsic_funcall (se, expr);
1788 actual = expr->value.function.actual;
1790 type = gfc_typenode_for_spec (&expr->ts);
1791 /* Initialize the result. */
1792 resvar = gfc_create_var (type, "count");
1793 gfc_add_modify_expr (&se->pre, resvar, build_int_cst (type, 0));
1795 /* Walk the arguments. */
1796 arrayss = gfc_walk_expr (actual->expr);
1797 gcc_assert (arrayss != gfc_ss_terminator);
1799 /* Initialize the scalarizer. */
1800 gfc_init_loopinfo (&loop);
1801 gfc_add_ss_to_loop (&loop, arrayss);
1803 /* Initialize the loop. */
1804 gfc_conv_ss_startstride (&loop);
1805 gfc_conv_loop_setup (&loop);
1807 gfc_mark_ss_chain_used (arrayss, 1);
1808 /* Generate the loop body. */
1809 gfc_start_scalarized_body (&loop, &body);
1811 tmp = build2 (PLUS_EXPR, TREE_TYPE (resvar), resvar,
1812 build_int_cst (TREE_TYPE (resvar), 1));
1813 tmp = build2_v (MODIFY_EXPR, resvar, tmp);
1815 gfc_init_se (&arrayse, NULL);
1816 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1817 arrayse.ss = arrayss;
1818 gfc_conv_expr_val (&arrayse, actual->expr);
1819 tmp = build3_v (COND_EXPR, arrayse.expr, tmp, build_empty_stmt ());
1821 gfc_add_block_to_block (&body, &arrayse.pre);
1822 gfc_add_expr_to_block (&body, tmp);
1823 gfc_add_block_to_block (&body, &arrayse.post);
1825 gfc_trans_scalarizing_loops (&loop, &body);
1827 gfc_add_block_to_block (&se->pre, &loop.pre);
1828 gfc_add_block_to_block (&se->pre, &loop.post);
1829 gfc_cleanup_loop (&loop);
1834 /* Inline implementation of the sum and product intrinsics. */
1836 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op)
1844 gfc_actual_arglist *actual;
1849 gfc_expr *arrayexpr;
1854 gfc_conv_intrinsic_funcall (se, expr);
1858 type = gfc_typenode_for_spec (&expr->ts);
1859 /* Initialize the result. */
1860 resvar = gfc_create_var (type, "val");
1861 if (op == PLUS_EXPR)
1862 tmp = gfc_build_const (type, integer_zero_node);
1864 tmp = gfc_build_const (type, integer_one_node);
1866 gfc_add_modify_expr (&se->pre, resvar, tmp);
1868 /* Walk the arguments. */
1869 actual = expr->value.function.actual;
1870 arrayexpr = actual->expr;
1871 arrayss = gfc_walk_expr (arrayexpr);
1872 gcc_assert (arrayss != gfc_ss_terminator);
1874 actual = actual->next->next;
1875 gcc_assert (actual);
1876 maskexpr = actual->expr;
1877 if (maskexpr && maskexpr->rank != 0)
1879 maskss = gfc_walk_expr (maskexpr);
1880 gcc_assert (maskss != gfc_ss_terminator);
1885 /* Initialize the scalarizer. */
1886 gfc_init_loopinfo (&loop);
1887 gfc_add_ss_to_loop (&loop, arrayss);
1889 gfc_add_ss_to_loop (&loop, maskss);
1891 /* Initialize the loop. */
1892 gfc_conv_ss_startstride (&loop);
1893 gfc_conv_loop_setup (&loop);
1895 gfc_mark_ss_chain_used (arrayss, 1);
1897 gfc_mark_ss_chain_used (maskss, 1);
1898 /* Generate the loop body. */
1899 gfc_start_scalarized_body (&loop, &body);
1901 /* If we have a mask, only add this element if the mask is set. */
1904 gfc_init_se (&maskse, NULL);
1905 gfc_copy_loopinfo_to_se (&maskse, &loop);
1907 gfc_conv_expr_val (&maskse, maskexpr);
1908 gfc_add_block_to_block (&body, &maskse.pre);
1910 gfc_start_block (&block);
1913 gfc_init_block (&block);
1915 /* Do the actual summation/product. */
1916 gfc_init_se (&arrayse, NULL);
1917 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1918 arrayse.ss = arrayss;
1919 gfc_conv_expr_val (&arrayse, arrayexpr);
1920 gfc_add_block_to_block (&block, &arrayse.pre);
1922 tmp = build2 (op, type, resvar, arrayse.expr);
1923 gfc_add_modify_expr (&block, resvar, tmp);
1924 gfc_add_block_to_block (&block, &arrayse.post);
1928 /* We enclose the above in if (mask) {...} . */
1929 tmp = gfc_finish_block (&block);
1931 tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1934 tmp = gfc_finish_block (&block);
1935 gfc_add_expr_to_block (&body, tmp);
1937 gfc_trans_scalarizing_loops (&loop, &body);
1939 /* For a scalar mask, enclose the loop in an if statement. */
1940 if (maskexpr && maskss == NULL)
1942 gfc_init_se (&maskse, NULL);
1943 gfc_conv_expr_val (&maskse, maskexpr);
1944 gfc_init_block (&block);
1945 gfc_add_block_to_block (&block, &loop.pre);
1946 gfc_add_block_to_block (&block, &loop.post);
1947 tmp = gfc_finish_block (&block);
1949 tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1950 gfc_add_expr_to_block (&block, tmp);
1951 gfc_add_block_to_block (&se->pre, &block);
1955 gfc_add_block_to_block (&se->pre, &loop.pre);
1956 gfc_add_block_to_block (&se->pre, &loop.post);
1959 gfc_cleanup_loop (&loop);
1965 /* Inline implementation of the dot_product intrinsic. This function
1966 is based on gfc_conv_intrinsic_arith (the previous function). */
1968 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
1976 gfc_actual_arglist *actual;
1977 gfc_ss *arrayss1, *arrayss2;
1978 gfc_se arrayse1, arrayse2;
1979 gfc_expr *arrayexpr1, *arrayexpr2;
1981 type = gfc_typenode_for_spec (&expr->ts);
1983 /* Initialize the result. */
1984 resvar = gfc_create_var (type, "val");
1985 if (expr->ts.type == BT_LOGICAL)
1986 tmp = build_int_cst (type, 0);
1988 tmp = gfc_build_const (type, integer_zero_node);
1990 gfc_add_modify_expr (&se->pre, resvar, tmp);
1992 /* Walk argument #1. */
1993 actual = expr->value.function.actual;
1994 arrayexpr1 = actual->expr;
1995 arrayss1 = gfc_walk_expr (arrayexpr1);
1996 gcc_assert (arrayss1 != gfc_ss_terminator);
1998 /* Walk argument #2. */
1999 actual = actual->next;
2000 arrayexpr2 = actual->expr;
2001 arrayss2 = gfc_walk_expr (arrayexpr2);
2002 gcc_assert (arrayss2 != gfc_ss_terminator);
2004 /* Initialize the scalarizer. */
2005 gfc_init_loopinfo (&loop);
2006 gfc_add_ss_to_loop (&loop, arrayss1);
2007 gfc_add_ss_to_loop (&loop, arrayss2);
2009 /* Initialize the loop. */
2010 gfc_conv_ss_startstride (&loop);
2011 gfc_conv_loop_setup (&loop);
2013 gfc_mark_ss_chain_used (arrayss1, 1);
2014 gfc_mark_ss_chain_used (arrayss2, 1);
2016 /* Generate the loop body. */
2017 gfc_start_scalarized_body (&loop, &body);
2018 gfc_init_block (&block);
2020 /* Make the tree expression for [conjg(]array1[)]. */
2021 gfc_init_se (&arrayse1, NULL);
2022 gfc_copy_loopinfo_to_se (&arrayse1, &loop);
2023 arrayse1.ss = arrayss1;
2024 gfc_conv_expr_val (&arrayse1, arrayexpr1);
2025 if (expr->ts.type == BT_COMPLEX)
2026 arrayse1.expr = build1 (CONJ_EXPR, type, arrayse1.expr);
2027 gfc_add_block_to_block (&block, &arrayse1.pre);
2029 /* Make the tree expression for array2. */
2030 gfc_init_se (&arrayse2, NULL);
2031 gfc_copy_loopinfo_to_se (&arrayse2, &loop);
2032 arrayse2.ss = arrayss2;
2033 gfc_conv_expr_val (&arrayse2, arrayexpr2);
2034 gfc_add_block_to_block (&block, &arrayse2.pre);
2036 /* Do the actual product and sum. */
2037 if (expr->ts.type == BT_LOGICAL)
2039 tmp = build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr);
2040 tmp = build2 (TRUTH_OR_EXPR, type, resvar, tmp);
2044 tmp = build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr);
2045 tmp = build2 (PLUS_EXPR, type, resvar, tmp);
2047 gfc_add_modify_expr (&block, resvar, tmp);
2049 /* Finish up the loop block and the loop. */
2050 tmp = gfc_finish_block (&block);
2051 gfc_add_expr_to_block (&body, tmp);
2053 gfc_trans_scalarizing_loops (&loop, &body);
2054 gfc_add_block_to_block (&se->pre, &loop.pre);
2055 gfc_add_block_to_block (&se->pre, &loop.post);
2056 gfc_cleanup_loop (&loop);
2063 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
2067 stmtblock_t ifblock;
2068 stmtblock_t elseblock;
2076 gfc_actual_arglist *actual;
2081 gfc_expr *arrayexpr;
2088 gfc_conv_intrinsic_funcall (se, expr);
2092 /* Initialize the result. */
2093 pos = gfc_create_var (gfc_array_index_type, "pos");
2094 offset = gfc_create_var (gfc_array_index_type, "offset");
2095 type = gfc_typenode_for_spec (&expr->ts);
2097 /* Walk the arguments. */
2098 actual = expr->value.function.actual;
2099 arrayexpr = actual->expr;
2100 arrayss = gfc_walk_expr (arrayexpr);
2101 gcc_assert (arrayss != gfc_ss_terminator);
2103 actual = actual->next->next;
2104 gcc_assert (actual);
2105 maskexpr = actual->expr;
2106 if (maskexpr && maskexpr->rank != 0)
2108 maskss = gfc_walk_expr (maskexpr);
2109 gcc_assert (maskss != gfc_ss_terminator);
2114 limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
2115 n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
2116 switch (arrayexpr->ts.type)
2119 tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind);
2123 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
2124 arrayexpr->ts.kind);
2131 /* We start with the most negative possible value for MAXLOC, and the most
2132 positive possible value for MINLOC. The most negative possible value is
2133 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2134 possible value is HUGE in both cases. */
2136 tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2137 gfc_add_modify_expr (&se->pre, limit, tmp);
2139 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2140 tmp = build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
2141 build_int_cst (type, 1));
2143 /* Initialize the scalarizer. */
2144 gfc_init_loopinfo (&loop);
2145 gfc_add_ss_to_loop (&loop, arrayss);
2147 gfc_add_ss_to_loop (&loop, maskss);
2149 /* Initialize the loop. */
2150 gfc_conv_ss_startstride (&loop);
2151 gfc_conv_loop_setup (&loop);
2153 gcc_assert (loop.dimen == 1);
2155 /* Initialize the position to zero, following Fortran 2003. We are free
2156 to do this because Fortran 95 allows the result of an entirely false
2157 mask to be processor dependent. */
2158 gfc_add_modify_expr (&loop.pre, pos, gfc_index_zero_node);
2160 gfc_mark_ss_chain_used (arrayss, 1);
2162 gfc_mark_ss_chain_used (maskss, 1);
2163 /* Generate the loop body. */
2164 gfc_start_scalarized_body (&loop, &body);
2166 /* If we have a mask, only check this element if the mask is set. */
2169 gfc_init_se (&maskse, NULL);
2170 gfc_copy_loopinfo_to_se (&maskse, &loop);
2172 gfc_conv_expr_val (&maskse, maskexpr);
2173 gfc_add_block_to_block (&body, &maskse.pre);
2175 gfc_start_block (&block);
2178 gfc_init_block (&block);
2180 /* Compare with the current limit. */
2181 gfc_init_se (&arrayse, NULL);
2182 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2183 arrayse.ss = arrayss;
2184 gfc_conv_expr_val (&arrayse, arrayexpr);
2185 gfc_add_block_to_block (&block, &arrayse.pre);
2187 /* We do the following if this is a more extreme value. */
2188 gfc_start_block (&ifblock);
2190 /* Assign the value to the limit... */
2191 gfc_add_modify_expr (&ifblock, limit, arrayse.expr);
2193 /* Remember where we are. An offset must be added to the loop
2194 counter to obtain the required position. */
2196 tmp = build_int_cst (gfc_array_index_type, 1);
2198 tmp =fold_build2 (MINUS_EXPR, gfc_array_index_type,
2199 gfc_index_one_node, loop.from[0]);
2200 gfc_add_modify_expr (&block, offset, tmp);
2202 tmp = build2 (PLUS_EXPR, TREE_TYPE (pos),
2203 loop.loopvar[0], offset);
2204 gfc_add_modify_expr (&ifblock, pos, tmp);
2206 ifbody = gfc_finish_block (&ifblock);
2208 /* If it is a more extreme value or pos is still zero and the value
2209 equal to the limit. */
2210 tmp = build2 (TRUTH_AND_EXPR, boolean_type_node,
2211 build2 (EQ_EXPR, boolean_type_node, pos, gfc_index_zero_node),
2212 build2 (EQ_EXPR, boolean_type_node, arrayse.expr, limit));
2213 tmp = build2 (TRUTH_OR_EXPR, boolean_type_node,
2214 build2 (op, boolean_type_node, arrayse.expr, limit), tmp);
2215 tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
2216 gfc_add_expr_to_block (&block, tmp);
2220 /* We enclose the above in if (mask) {...}. */
2221 tmp = gfc_finish_block (&block);
2223 tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2226 tmp = gfc_finish_block (&block);
2227 gfc_add_expr_to_block (&body, tmp);
2229 gfc_trans_scalarizing_loops (&loop, &body);
2231 /* For a scalar mask, enclose the loop in an if statement. */
2232 if (maskexpr && maskss == NULL)
2234 gfc_init_se (&maskse, NULL);
2235 gfc_conv_expr_val (&maskse, maskexpr);
2236 gfc_init_block (&block);
2237 gfc_add_block_to_block (&block, &loop.pre);
2238 gfc_add_block_to_block (&block, &loop.post);
2239 tmp = gfc_finish_block (&block);
2241 /* For the else part of the scalar mask, just initialize
2242 the pos variable the same way as above. */
2244 gfc_init_block (&elseblock);
2245 gfc_add_modify_expr (&elseblock, pos, gfc_index_zero_node);
2246 elsetmp = gfc_finish_block (&elseblock);
2248 tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
2249 gfc_add_expr_to_block (&block, tmp);
2250 gfc_add_block_to_block (&se->pre, &block);
2254 gfc_add_block_to_block (&se->pre, &loop.pre);
2255 gfc_add_block_to_block (&se->pre, &loop.post);
2257 gfc_cleanup_loop (&loop);
2259 se->expr = convert (type, pos);
2263 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
2272 gfc_actual_arglist *actual;
2277 gfc_expr *arrayexpr;
2283 gfc_conv_intrinsic_funcall (se, expr);
2287 type = gfc_typenode_for_spec (&expr->ts);
2288 /* Initialize the result. */
2289 limit = gfc_create_var (type, "limit");
2290 n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
2291 switch (expr->ts.type)
2294 tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind);
2298 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
2305 /* We start with the most negative possible value for MAXVAL, and the most
2306 positive possible value for MINVAL. The most negative possible value is
2307 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2308 possible value is HUGE in both cases. */
2310 tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2312 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2313 tmp = build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
2314 build_int_cst (type, 1));
2316 gfc_add_modify_expr (&se->pre, limit, tmp);
2318 /* Walk the arguments. */
2319 actual = expr->value.function.actual;
2320 arrayexpr = actual->expr;
2321 arrayss = gfc_walk_expr (arrayexpr);
2322 gcc_assert (arrayss != gfc_ss_terminator);
2324 actual = actual->next->next;
2325 gcc_assert (actual);
2326 maskexpr = actual->expr;
2327 if (maskexpr && maskexpr->rank != 0)
2329 maskss = gfc_walk_expr (maskexpr);
2330 gcc_assert (maskss != gfc_ss_terminator);
2335 /* Initialize the scalarizer. */
2336 gfc_init_loopinfo (&loop);
2337 gfc_add_ss_to_loop (&loop, arrayss);
2339 gfc_add_ss_to_loop (&loop, maskss);
2341 /* Initialize the loop. */
2342 gfc_conv_ss_startstride (&loop);
2343 gfc_conv_loop_setup (&loop);
2345 gfc_mark_ss_chain_used (arrayss, 1);
2347 gfc_mark_ss_chain_used (maskss, 1);
2348 /* Generate the loop body. */
2349 gfc_start_scalarized_body (&loop, &body);
2351 /* If we have a mask, only add this element if the mask is set. */
2354 gfc_init_se (&maskse, NULL);
2355 gfc_copy_loopinfo_to_se (&maskse, &loop);
2357 gfc_conv_expr_val (&maskse, maskexpr);
2358 gfc_add_block_to_block (&body, &maskse.pre);
2360 gfc_start_block (&block);
2363 gfc_init_block (&block);
2365 /* Compare with the current limit. */
2366 gfc_init_se (&arrayse, NULL);
2367 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2368 arrayse.ss = arrayss;
2369 gfc_conv_expr_val (&arrayse, arrayexpr);
2370 gfc_add_block_to_block (&block, &arrayse.pre);
2372 /* Assign the value to the limit... */
2373 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2375 /* If it is a more extreme value. */
2376 tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
2377 tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
2378 gfc_add_expr_to_block (&block, tmp);
2379 gfc_add_block_to_block (&block, &arrayse.post);
2381 tmp = gfc_finish_block (&block);
2383 /* We enclose the above in if (mask) {...}. */
2384 tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2385 gfc_add_expr_to_block (&body, tmp);
2387 gfc_trans_scalarizing_loops (&loop, &body);
2389 /* For a scalar mask, enclose the loop in an if statement. */
2390 if (maskexpr && maskss == NULL)
2392 gfc_init_se (&maskse, NULL);
2393 gfc_conv_expr_val (&maskse, maskexpr);
2394 gfc_init_block (&block);
2395 gfc_add_block_to_block (&block, &loop.pre);
2396 gfc_add_block_to_block (&block, &loop.post);
2397 tmp = gfc_finish_block (&block);
2399 tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2400 gfc_add_expr_to_block (&block, tmp);
2401 gfc_add_block_to_block (&se->pre, &block);
2405 gfc_add_block_to_block (&se->pre, &loop.pre);
2406 gfc_add_block_to_block (&se->pre, &loop.post);
2409 gfc_cleanup_loop (&loop);
2414 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
2416 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
2422 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2423 type = TREE_TYPE (args[0]);
2425 tmp = build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
2426 tmp = build2 (BIT_AND_EXPR, type, args[0], tmp);
2427 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
2428 build_int_cst (type, 0));
2429 type = gfc_typenode_for_spec (&expr->ts);
2430 se->expr = convert (type, tmp);
2433 /* Generate code to perform the specified operation. */
2435 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op)
2439 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2440 se->expr = fold_build2 (op, TREE_TYPE (args[0]), args[0], args[1]);
2445 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
2449 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2450 se->expr = build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
2453 /* Set or clear a single bit. */
2455 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
2462 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2463 type = TREE_TYPE (args[0]);
2465 tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
2471 tmp = fold_build1 (BIT_NOT_EXPR, type, tmp);
2473 se->expr = fold_build2 (op, type, args[0], tmp);
2476 /* Extract a sequence of bits.
2477 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
2479 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
2486 gfc_conv_intrinsic_function_args (se, expr, args, 3);
2487 type = TREE_TYPE (args[0]);
2489 mask = build_int_cst (type, -1);
2490 mask = build2 (LSHIFT_EXPR, type, mask, args[2]);
2491 mask = build1 (BIT_NOT_EXPR, type, mask);
2493 tmp = build2 (RSHIFT_EXPR, type, args[0], args[1]);
2495 se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
2498 /* RSHIFT (I, SHIFT) = I >> SHIFT
2499 LSHIFT (I, SHIFT) = I << SHIFT */
2501 gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift)
2505 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2507 se->expr = fold_build2 (right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
2508 TREE_TYPE (args[0]), args[0], args[1]);
2511 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
2513 : ((shift >= 0) ? i << shift : i >> -shift)
2514 where all shifts are logical shifts. */
2516 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
2528 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2529 type = TREE_TYPE (args[0]);
2530 utype = unsigned_type_for (type);
2532 width = fold_build1 (ABS_EXPR, TREE_TYPE (args[1]), args[1]);
2534 /* Left shift if positive. */
2535 lshift = fold_build2 (LSHIFT_EXPR, type, args[0], width);
2537 /* Right shift if negative.
2538 We convert to an unsigned type because we want a logical shift.
2539 The standard doesn't define the case of shifting negative
2540 numbers, and we try to be compatible with other compilers, most
2541 notably g77, here. */
2542 rshift = fold_convert (type, build2 (RSHIFT_EXPR, utype,
2543 convert (utype, args[0]), width));
2545 tmp = fold_build2 (GE_EXPR, boolean_type_node, args[1],
2546 build_int_cst (TREE_TYPE (args[1]), 0));
2547 tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift);
2549 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
2550 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
2552 num_bits = build_int_cst (TREE_TYPE (args[0]), TYPE_PRECISION (type));
2553 cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits);
2555 se->expr = fold_build3 (COND_EXPR, type, cond,
2556 build_int_cst (type, 0), tmp);
2560 /* Circular shift. AKA rotate or barrel shift. */
2563 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
2571 unsigned int num_args;
2573 num_args = gfc_intrinsic_argument_list_length (expr);
2574 args = alloca (sizeof (tree) * num_args);
2576 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2580 /* Use a library function for the 3 parameter version. */
2581 tree int4type = gfc_get_int_type (4);
2583 type = TREE_TYPE (args[0]);
2584 /* We convert the first argument to at least 4 bytes, and
2585 convert back afterwards. This removes the need for library
2586 functions for all argument sizes, and function will be
2587 aligned to at least 32 bits, so there's no loss. */
2588 if (expr->ts.kind < 4)
2589 args[0] = convert (int4type, args[0]);
2591 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
2592 need loads of library functions. They cannot have values >
2593 BIT_SIZE (I) so the conversion is safe. */
2594 args[1] = convert (int4type, args[1]);
2595 args[2] = convert (int4type, args[2]);
2597 switch (expr->ts.kind)
2602 tmp = gfor_fndecl_math_ishftc4;
2605 tmp = gfor_fndecl_math_ishftc8;
2608 tmp = gfor_fndecl_math_ishftc16;
2613 se->expr = build_call_expr (tmp, 3, args[0], args[1], args[2]);
2614 /* Convert the result back to the original type, if we extended
2615 the first argument's width above. */
2616 if (expr->ts.kind < 4)
2617 se->expr = convert (type, se->expr);
2621 type = TREE_TYPE (args[0]);
2623 /* Rotate left if positive. */
2624 lrot = fold_build2 (LROTATE_EXPR, type, args[0], args[1]);
2626 /* Rotate right if negative. */
2627 tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (args[1]), args[1]);
2628 rrot = fold_build2 (RROTATE_EXPR, type, args[0], tmp);
2630 zero = build_int_cst (TREE_TYPE (args[1]), 0);
2631 tmp = fold_build2 (GT_EXPR, boolean_type_node, args[1], zero);
2632 rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot);
2634 /* Do nothing if shift == 0. */
2635 tmp = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
2636 se->expr = fold_build3 (COND_EXPR, type, tmp, args[0], rrot);
2639 /* The length of a character string. */
2641 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
2651 gcc_assert (!se->ss);
2653 arg = expr->value.function.actual->expr;
2655 type = gfc_typenode_for_spec (&expr->ts);
2656 switch (arg->expr_type)
2659 len = build_int_cst (NULL_TREE, arg->value.character.length);
2663 /* Obtain the string length from the function used by
2664 trans-array.c(gfc_trans_array_constructor). */
2666 get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
2670 if (arg->ref == NULL
2671 || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
2673 /* This doesn't catch all cases.
2674 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
2675 and the surrounding thread. */
2676 sym = arg->symtree->n.sym;
2677 decl = gfc_get_symbol_decl (sym);
2678 if (decl == current_function_decl && sym->attr.function
2679 && (sym->result == sym))
2680 decl = gfc_get_fake_result_decl (sym, 0);
2682 len = sym->ts.cl->backend_decl;
2687 /* Otherwise fall through. */
2690 /* Anybody stupid enough to do this deserves inefficient code. */
2691 ss = gfc_walk_expr (arg);
2692 gfc_init_se (&argse, se);
2693 if (ss == gfc_ss_terminator)
2694 gfc_conv_expr (&argse, arg);
2696 gfc_conv_expr_descriptor (&argse, arg, ss);
2697 gfc_add_block_to_block (&se->pre, &argse.pre);
2698 gfc_add_block_to_block (&se->post, &argse.post);
2699 len = argse.string_length;
2702 se->expr = convert (type, len);
2705 /* The length of a character string not including trailing blanks. */
2707 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
2712 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2713 type = gfc_typenode_for_spec (&expr->ts);
2714 se->expr = build_call_expr (gfor_fndecl_string_len_trim, 2, args[0], args[1]);
2715 se->expr = convert (type, se->expr);
2719 /* Returns the starting position of a substring within a string. */
2722 gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr)
2724 tree logical4_type_node = gfc_get_logical_type (4);
2728 unsigned int num_args;
2730 num_args = gfc_intrinsic_argument_list_length (expr);
2731 args = alloca (sizeof (tree) * 5);
2733 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2734 type = gfc_typenode_for_spec (&expr->ts);
2737 args[4] = build_int_cst (logical4_type_node, 0);
2740 gcc_assert (num_args == 5);
2741 args[4] = convert (logical4_type_node, args[4]);
2744 fndecl = build_addr (gfor_fndecl_string_index, current_function_decl);
2745 se->expr = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_index)),
2747 se->expr = convert (type, se->expr);
2751 /* The ascii value for a single character. */
2753 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
2758 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2759 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
2760 args[1] = build1 (NOP_EXPR, pchar_type_node, args[1]);
2761 type = gfc_typenode_for_spec (&expr->ts);
2763 se->expr = build_fold_indirect_ref (args[1]);
2764 se->expr = convert (type, se->expr);
2768 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
2771 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
2779 unsigned int num_args;
2781 num_args = gfc_intrinsic_argument_list_length (expr);
2782 args = alloca (sizeof (tree) * num_args);
2784 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2785 if (expr->ts.type != BT_CHARACTER)
2793 /* We do the same as in the non-character case, but the argument
2794 list is different because of the string length arguments. We
2795 also have to set the string length for the result. */
2801 se->string_length = len;
2803 type = TREE_TYPE (tsource);
2804 se->expr = fold_build3 (COND_EXPR, type, mask, tsource, fsource);
2809 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
2811 gfc_actual_arglist *actual;
2819 gfc_init_se (&argse, NULL);
2820 actual = expr->value.function.actual;
2822 ss = gfc_walk_expr (actual->expr);
2823 gcc_assert (ss != gfc_ss_terminator);
2824 argse.want_pointer = 1;
2825 argse.data_not_needed = 1;
2826 gfc_conv_expr_descriptor (&argse, actual->expr, ss);
2827 gfc_add_block_to_block (&se->pre, &argse.pre);
2828 gfc_add_block_to_block (&se->post, &argse.post);
2829 arg1 = gfc_evaluate_now (argse.expr, &se->pre);
2831 /* Build the call to size0. */
2832 fncall0 = build_call_expr (gfor_fndecl_size0, 1, arg1);
2834 actual = actual->next;
2838 gfc_init_se (&argse, NULL);
2839 gfc_conv_expr_type (&argse, actual->expr,
2840 gfc_array_index_type);
2841 gfc_add_block_to_block (&se->pre, &argse.pre);
2843 /* Build the call to size1. */
2844 fncall1 = build_call_expr (gfor_fndecl_size1, 2,
2847 /* Unusually, for an intrinsic, size does not exclude
2848 an optional arg2, so we must test for it. */
2849 if (actual->expr->expr_type == EXPR_VARIABLE
2850 && actual->expr->symtree->n.sym->attr.dummy
2851 && actual->expr->symtree->n.sym->attr.optional)
2854 gfc_init_se (&argse, NULL);
2855 argse.want_pointer = 1;
2856 argse.data_not_needed = 1;
2857 gfc_conv_expr (&argse, actual->expr);
2858 gfc_add_block_to_block (&se->pre, &argse.pre);
2859 tmp = build2 (NE_EXPR, boolean_type_node, argse.expr,
2861 tmp = gfc_evaluate_now (tmp, &se->pre);
2862 se->expr = build3 (COND_EXPR, pvoid_type_node,
2863 tmp, fncall1, fncall0);
2871 type = gfc_typenode_for_spec (&expr->ts);
2872 se->expr = convert (type, se->expr);
2877 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
2891 arg = expr->value.function.actual->expr;
2893 gfc_init_se (&argse, NULL);
2894 ss = gfc_walk_expr (arg);
2896 source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
2898 if (ss == gfc_ss_terminator)
2900 gfc_conv_expr_reference (&argse, arg);
2901 source = argse.expr;
2903 type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
2905 /* Obtain the source word length. */
2906 if (arg->ts.type == BT_CHARACTER)
2907 source_bytes = fold_convert (gfc_array_index_type,
2908 argse.string_length);
2910 source_bytes = fold_convert (gfc_array_index_type,
2911 size_in_bytes (type));
2915 argse.want_pointer = 0;
2916 gfc_conv_expr_descriptor (&argse, arg, ss);
2917 source = gfc_conv_descriptor_data_get (argse.expr);
2918 type = gfc_get_element_type (TREE_TYPE (argse.expr));
2920 /* Obtain the argument's word length. */
2921 if (arg->ts.type == BT_CHARACTER)
2922 tmp = fold_convert (gfc_array_index_type, argse.string_length);
2924 tmp = fold_convert (gfc_array_index_type,
2925 size_in_bytes (type));
2926 gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
2928 /* Obtain the size of the array in bytes. */
2929 for (n = 0; n < arg->rank; n++)
2932 idx = gfc_rank_cst[n];
2933 lower = gfc_conv_descriptor_lbound (argse.expr, idx);
2934 upper = gfc_conv_descriptor_ubound (argse.expr, idx);
2935 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2937 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2938 tmp, gfc_index_one_node);
2939 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2941 gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
2945 gfc_add_block_to_block (&se->pre, &argse.pre);
2946 se->expr = source_bytes;
2950 /* Intrinsic string comparison functions. */
2953 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
2958 gfc_conv_intrinsic_function_args (se, expr, args, 4);
2960 se->expr = gfc_build_compare_string (args[0], args[1], args[2], args[3]);
2961 type = gfc_typenode_for_spec (&expr->ts);
2962 se->expr = fold_build2 (op, type, se->expr,
2963 build_int_cst (TREE_TYPE (se->expr), 0));
2966 /* Generate a call to the adjustl/adjustr library function. */
2968 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
2976 gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
2979 type = TREE_TYPE (args[2]);
2980 var = gfc_conv_string_tmp (se, type, len);
2983 tmp = build_call_expr (fndecl, 3, args[0], args[1], args[2]);
2984 gfc_add_expr_to_block (&se->pre, tmp);
2986 se->string_length = len;
2990 /* Array transfer statement.
2991 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
2993 typeof<DEST> = typeof<MOLD>
2995 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
2996 sizeof (DEST(0) * SIZE). */
2999 gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
3014 gfc_actual_arglist *arg;
3021 gcc_assert (se->loop);
3022 info = &se->ss->data.info;
3024 /* Convert SOURCE. The output from this stage is:-
3025 source_bytes = length of the source in bytes
3026 source = pointer to the source data. */
3027 arg = expr->value.function.actual;
3028 gfc_init_se (&argse, NULL);
3029 ss = gfc_walk_expr (arg->expr);
3031 source_bytes = gfc_create_var (gfc_array_index_type, NULL);
3033 /* Obtain the pointer to source and the length of source in bytes. */
3034 if (ss == gfc_ss_terminator)
3036 gfc_conv_expr_reference (&argse, arg->expr);
3037 source = argse.expr;
3039 source_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
3041 /* Obtain the source word length. */
3042 if (arg->expr->ts.type == BT_CHARACTER)
3043 tmp = fold_convert (gfc_array_index_type, argse.string_length);
3045 tmp = fold_convert (gfc_array_index_type,
3046 size_in_bytes (source_type));
3050 argse.want_pointer = 0;
3051 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
3052 source = gfc_conv_descriptor_data_get (argse.expr);
3053 source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
3055 /* Repack the source if not a full variable array. */
3056 if (!(arg->expr->expr_type == EXPR_VARIABLE
3057 && arg->expr->ref->u.ar.type == AR_FULL))
3059 tmp = build_fold_addr_expr (argse.expr);
3060 source = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
3061 source = gfc_evaluate_now (source, &argse.pre);
3063 /* Free the temporary. */
3064 gfc_start_block (&block);
3065 tmp = gfc_call_free (convert (pvoid_type_node, source));
3066 gfc_add_expr_to_block (&block, tmp);
3067 stmt = gfc_finish_block (&block);
3069 /* Clean up if it was repacked. */
3070 gfc_init_block (&block);
3071 tmp = gfc_conv_array_data (argse.expr);
3072 tmp = build2 (NE_EXPR, boolean_type_node, source, tmp);
3073 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3074 gfc_add_expr_to_block (&block, tmp);
3075 gfc_add_block_to_block (&block, &se->post);
3076 gfc_init_block (&se->post);
3077 gfc_add_block_to_block (&se->post, &block);
3080 /* Obtain the source word length. */
3081 if (arg->expr->ts.type == BT_CHARACTER)
3082 tmp = fold_convert (gfc_array_index_type, argse.string_length);
3084 tmp = fold_convert (gfc_array_index_type,
3085 size_in_bytes (source_type));
3087 /* Obtain the size of the array in bytes. */
3088 extent = gfc_create_var (gfc_array_index_type, NULL);
3089 for (n = 0; n < arg->expr->rank; n++)
3092 idx = gfc_rank_cst[n];
3093 gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
3094 stride = gfc_conv_descriptor_stride (argse.expr, idx);
3095 lower = gfc_conv_descriptor_lbound (argse.expr, idx);
3096 upper = gfc_conv_descriptor_ubound (argse.expr, idx);
3097 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3099 gfc_add_modify_expr (&argse.pre, extent, tmp);
3100 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3101 extent, gfc_index_one_node);
3102 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3107 gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
3108 gfc_add_block_to_block (&se->pre, &argse.pre);
3109 gfc_add_block_to_block (&se->post, &argse.post);
3111 /* Now convert MOLD. The outputs are:
3112 mold_type = the TREE type of MOLD
3113 dest_word_len = destination word length in bytes. */
3116 gfc_init_se (&argse, NULL);
3117 ss = gfc_walk_expr (arg->expr);
3119 if (ss == gfc_ss_terminator)
3121 gfc_conv_expr_reference (&argse, arg->expr);
3122 mold_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
3126 gfc_init_se (&argse, NULL);
3127 argse.want_pointer = 0;
3128 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
3129 mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
3132 if (arg->expr->ts.type == BT_CHARACTER)
3134 tmp = fold_convert (gfc_array_index_type, argse.string_length);
3135 mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
3138 tmp = fold_convert (gfc_array_index_type,
3139 size_in_bytes (mold_type));
3141 dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
3142 gfc_add_modify_expr (&se->pre, dest_word_len, tmp);
3144 /* Finally convert SIZE, if it is present. */
3146 size_words = gfc_create_var (gfc_array_index_type, NULL);
3150 gfc_init_se (&argse, NULL);
3151 gfc_conv_expr_reference (&argse, arg->expr);
3152 tmp = convert (gfc_array_index_type,
3153 build_fold_indirect_ref (argse.expr));
3154 gfc_add_block_to_block (&se->pre, &argse.pre);
3155 gfc_add_block_to_block (&se->post, &argse.post);
3160 size_bytes = gfc_create_var (gfc_array_index_type, NULL);
3161 if (tmp != NULL_TREE)
3163 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3164 tmp, dest_word_len);
3165 tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
3171 gfc_add_modify_expr (&se->pre, size_bytes, tmp);
3172 gfc_add_modify_expr (&se->pre, size_words,
3173 fold_build2 (CEIL_DIV_EXPR, gfc_array_index_type,
3174 size_bytes, dest_word_len));
3176 /* Evaluate the bounds of the result. If the loop range exists, we have
3177 to check if it is too large. If so, we modify loop->to be consistent
3178 with min(size, size(source)). Otherwise, size is made consistent with
3179 the loop range, so that the right number of bytes is transferred.*/
3180 n = se->loop->order[0];
3181 if (se->loop->to[n] != NULL_TREE)
3183 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3184 se->loop->to[n], se->loop->from[n]);
3185 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3186 tmp, gfc_index_one_node);
3187 tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
3189 gfc_add_modify_expr (&se->pre, size_words, tmp);
3190 gfc_add_modify_expr (&se->pre, size_bytes,
3191 fold_build2 (MULT_EXPR, gfc_array_index_type,
3192 size_words, dest_word_len));
3193 upper = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3194 size_words, se->loop->from[n]);
3195 upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3196 upper, gfc_index_one_node);
3200 upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3201 size_words, gfc_index_one_node);
3202 se->loop->from[n] = gfc_index_zero_node;
3205 se->loop->to[n] = upper;
3207 /* Build a destination descriptor, using the pointer, source, as the
3208 data field. This is already allocated so set callee_alloc.
3209 FIXME callee_alloc is not set! */
3211 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
3212 info, mold_type, false, true, false);
3214 /* Cast the pointer to the result. */
3215 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3216 tmp = fold_convert (pvoid_type_node, tmp);
3218 /* Use memcpy to do the transfer. */
3219 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY],
3222 fold_convert (pvoid_type_node, source),
3224 gfc_add_expr_to_block (&se->pre, tmp);
3226 se->expr = info->descriptor;
3227 if (expr->ts.type == BT_CHARACTER)
3228 se->string_length = dest_word_len;
3232 /* Scalar transfer statement.
3233 TRANSFER (source, mold) = memcpy(&tmpdecl, &source, size), tmpdecl. */
3236 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
3238 gfc_actual_arglist *arg;
3245 /* Get a pointer to the source. */
3246 arg = expr->value.function.actual;
3247 ss = gfc_walk_expr (arg->expr);
3248 gfc_init_se (&argse, NULL);
3249 if (ss == gfc_ss_terminator)
3250 gfc_conv_expr_reference (&argse, arg->expr);
3252 gfc_conv_array_parameter (&argse, arg->expr, ss, 1);
3253 gfc_add_block_to_block (&se->pre, &argse.pre);
3254 gfc_add_block_to_block (&se->post, &argse.post);
3258 type = gfc_typenode_for_spec (&expr->ts);
3260 if (expr->ts.type == BT_CHARACTER)
3262 ptr = convert (build_pointer_type (type), ptr);
3263 gfc_init_se (&argse, NULL);
3264 gfc_conv_expr (&argse, arg->expr);
3265 gfc_add_block_to_block (&se->pre, &argse.pre);
3266 gfc_add_block_to_block (&se->post, &argse.post);
3268 se->string_length = argse.string_length;
3273 tmpdecl = gfc_create_var (type, "transfer");
3274 moldsize = size_in_bytes (type);
3276 /* Use memcpy to do the transfer. */
3277 tmp = build1 (ADDR_EXPR, build_pointer_type (type), tmpdecl);
3278 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
3279 fold_convert (pvoid_type_node, tmp),
3280 fold_convert (pvoid_type_node, ptr),
3282 gfc_add_expr_to_block (&se->pre, tmp);
3289 /* Generate code for the ALLOCATED intrinsic.
3290 Generate inline code that directly check the address of the argument. */
3293 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
3295 gfc_actual_arglist *arg1;
3300 gfc_init_se (&arg1se, NULL);
3301 arg1 = expr->value.function.actual;
3302 ss1 = gfc_walk_expr (arg1->expr);
3303 arg1se.descriptor_only = 1;
3304 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3306 tmp = gfc_conv_descriptor_data_get (arg1se.expr);
3307 tmp = build2 (NE_EXPR, boolean_type_node, tmp,
3308 fold_convert (TREE_TYPE (tmp), null_pointer_node));
3309 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
3313 /* Generate code for the ASSOCIATED intrinsic.
3314 If both POINTER and TARGET are arrays, generate a call to library function
3315 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
3316 In other cases, generate inline code that directly compare the address of
3317 POINTER with the address of TARGET. */
3320 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
3322 gfc_actual_arglist *arg1;
3323 gfc_actual_arglist *arg2;
3329 tree nonzero_charlen;
3330 tree nonzero_arraylen;
3333 gfc_init_se (&arg1se, NULL);
3334 gfc_init_se (&arg2se, NULL);
3335 arg1 = expr->value.function.actual;
3337 ss1 = gfc_walk_expr (arg1->expr);
3341 /* No optional target. */
3342 if (ss1 == gfc_ss_terminator)
3344 /* A pointer to a scalar. */
3345 arg1se.want_pointer = 1;
3346 gfc_conv_expr (&arg1se, arg1->expr);
3351 /* A pointer to an array. */
3352 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3353 tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
3355 gfc_add_block_to_block (&se->pre, &arg1se.pre);
3356 gfc_add_block_to_block (&se->post, &arg1se.post);
3357 tmp = build2 (NE_EXPR, boolean_type_node, tmp2,
3358 fold_convert (TREE_TYPE (tmp2), null_pointer_node));
3363 /* An optional target. */
3364 ss2 = gfc_walk_expr (arg2->expr);
3366 nonzero_charlen = NULL_TREE;
3367 if (arg1->expr->ts.type == BT_CHARACTER)
3368 nonzero_charlen = build2 (NE_EXPR, boolean_type_node,
3369 arg1->expr->ts.cl->backend_decl,
3372 if (ss1 == gfc_ss_terminator)
3374 /* A pointer to a scalar. */
3375 gcc_assert (ss2 == gfc_ss_terminator);
3376 arg1se.want_pointer = 1;
3377 gfc_conv_expr (&arg1se, arg1->expr);
3378 arg2se.want_pointer = 1;
3379 gfc_conv_expr (&arg2se, arg2->expr);
3380 gfc_add_block_to_block (&se->pre, &arg1se.pre);
3381 gfc_add_block_to_block (&se->post, &arg1se.post);
3382 tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
3383 tmp2 = build2 (NE_EXPR, boolean_type_node, arg1se.expr,
3385 se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node, tmp, tmp2);
3390 /* An array pointer of zero length is not associated if target is
3392 arg1se.descriptor_only = 1;
3393 gfc_conv_expr_lhs (&arg1se, arg1->expr);
3394 tmp = gfc_conv_descriptor_stride (arg1se.expr,
3395 gfc_rank_cst[arg1->expr->rank - 1]);
3396 nonzero_arraylen = build2 (NE_EXPR, boolean_type_node,
3397 tmp, build_int_cst (TREE_TYPE (tmp), 0));
3399 /* A pointer to an array, call library function _gfor_associated. */
3400 gcc_assert (ss2 != gfc_ss_terminator);
3401 arg1se.want_pointer = 1;
3402 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3404 arg2se.want_pointer = 1;
3405 gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
3406 gfc_add_block_to_block (&se->pre, &arg2se.pre);
3407 gfc_add_block_to_block (&se->post, &arg2se.post);
3408 fndecl = gfor_fndecl_associated;
3409 se->expr = build_call_expr (fndecl, 2, arg1se.expr, arg2se.expr);
3410 se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
3411 se->expr, nonzero_arraylen);
3415 /* If target is present zero character length pointers cannot
3417 if (nonzero_charlen != NULL_TREE)
3418 se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
3419 se->expr, nonzero_charlen);
3422 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3426 /* Scan a string for any one of the characters in a set of characters. */
3429 gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr)
3431 tree logical4_type_node = gfc_get_logical_type (4);
3435 unsigned int num_args;
3437 num_args = gfc_intrinsic_argument_list_length (expr);
3438 args = alloca (sizeof (tree) * 5);
3440 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3441 type = gfc_typenode_for_spec (&expr->ts);
3444 args[4] = build_int_cst (logical4_type_node, 0);
3447 gcc_assert (num_args == 5);
3448 args[4] = convert (logical4_type_node, args[4]);
3451 fndecl = build_addr (gfor_fndecl_string_scan, current_function_decl);
3452 se->expr = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_scan)),
3454 se->expr = convert (type, se->expr);
3458 /* Verify that a set of characters contains all the characters in a string
3459 by identifying the position of the first character in a string of
3460 characters that does not appear in a given set of characters. */
3463 gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
3465 tree logical4_type_node = gfc_get_logical_type (4);
3469 unsigned int num_args;
3471 num_args = gfc_intrinsic_argument_list_length (expr);
3472 args = alloca (sizeof (tree) * 5);
3474 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3475 type = gfc_typenode_for_spec (&expr->ts);
3478 args[4] = build_int_cst (logical4_type_node, 0);
3481 gcc_assert (num_args == 5);
3482 args[4] = convert (logical4_type_node, args[4]);
3485 fndecl = build_addr (gfor_fndecl_string_verify, current_function_decl);
3486 se->expr = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_verify)),
3489 se->expr = convert (type, se->expr);
3493 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
3496 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
3500 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3502 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
3503 type = gfc_get_int_type (4);
3504 arg = build_fold_addr_expr (fold_convert (type, arg));
3506 /* Convert it to the required type. */
3507 type = gfc_typenode_for_spec (&expr->ts);
3508 se->expr = build_call_expr (gfor_fndecl_si_kind, 1, arg);
3509 se->expr = fold_convert (type, se->expr);
3513 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
3516 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
3518 gfc_actual_arglist *actual;
3523 for (actual = expr->value.function.actual; actual; actual = actual->next)
3525 gfc_init_se (&argse, se);
3527 /* Pass a NULL pointer for an absent arg. */
3528 if (actual->expr == NULL)
3529 argse.expr = null_pointer_node;
3533 if (actual->expr->ts.kind != gfc_c_int_kind)
3535 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
3536 ts.type = BT_INTEGER;
3537 ts.kind = gfc_c_int_kind;
3538 gfc_convert_type (actual->expr, &ts, 2);
3540 gfc_conv_expr_reference (&argse, actual->expr);
3543 gfc_add_block_to_block (&se->pre, &argse.pre);
3544 gfc_add_block_to_block (&se->post, &argse.post);
3545 args = gfc_chainon_list (args, argse.expr);
3548 /* Convert it to the required type. */
3549 type = gfc_typenode_for_spec (&expr->ts);
3550 se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args);
3551 se->expr = fold_convert (type, se->expr);
3555 /* Generate code for TRIM (A) intrinsic function. */
3558 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
3560 tree gfc_int4_type_node = gfc_get_int_type (4);
3569 unsigned int num_args;
3571 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3572 args = alloca (sizeof (tree) * num_args);
3574 type = build_pointer_type (gfc_character1_type_node);
3575 var = gfc_create_var (type, "pstr");
3576 addr = gfc_build_addr_expr (ppvoid_type_node, var);
3577 len = gfc_create_var (gfc_int4_type_node, "len");
3579 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3580 args[0] = build_fold_addr_expr (len);
3583 fndecl = build_addr (gfor_fndecl_string_trim, current_function_decl);
3584 tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_trim)),
3585 fndecl, num_args, args);
3586 gfc_add_expr_to_block (&se->pre, tmp);
3588 /* Free the temporary afterwards, if necessary. */
3589 cond = build2 (GT_EXPR, boolean_type_node, len,
3590 build_int_cst (TREE_TYPE (len), 0));
3591 tmp = gfc_call_free (var);
3592 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
3593 gfc_add_expr_to_block (&se->post, tmp);
3596 se->string_length = len;
3600 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
3603 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
3605 tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
3606 tree type, cond, tmp, count, exit_label, n, max, largest;
3607 stmtblock_t block, body;
3610 /* Get the arguments. */
3611 gfc_conv_intrinsic_function_args (se, expr, args, 3);
3612 slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
3614 ncopies = gfc_evaluate_now (args[2], &se->pre);
3615 ncopies_type = TREE_TYPE (ncopies);
3617 /* Check that NCOPIES is not negative. */
3618 cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
3619 build_int_cst (ncopies_type, 0));
3620 gfc_trans_runtime_check (cond,
3621 "Argument NCOPIES of REPEAT intrinsic is negative",
3622 &se->pre, &expr->where);
3624 /* If the source length is zero, any non negative value of NCOPIES
3625 is valid, and nothing happens. */
3626 n = gfc_create_var (ncopies_type, "ncopies");
3627 cond = fold_build2 (EQ_EXPR, boolean_type_node, slen,
3628 build_int_cst (size_type_node, 0));
3629 tmp = fold_build3 (COND_EXPR, ncopies_type, cond,
3630 build_int_cst (ncopies_type, 0), ncopies);
3631 gfc_add_modify_expr (&se->pre, n, tmp);
3634 /* Check that ncopies is not too large: ncopies should be less than
3635 (or equal to) MAX / slen, where MAX is the maximal integer of
3636 the gfc_charlen_type_node type. If slen == 0, we need a special
3637 case to avoid the division by zero. */
3638 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
3639 max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
3640 max = fold_build2 (TRUNC_DIV_EXPR, size_type_node,
3641 fold_convert (size_type_node, max), slen);
3642 largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
3643 ? size_type_node : ncopies_type;
3644 cond = fold_build2 (GT_EXPR, boolean_type_node,
3645 fold_convert (largest, ncopies),
3646 fold_convert (largest, max));
3647 tmp = fold_build2 (EQ_EXPR, boolean_type_node, slen,
3648 build_int_cst (size_type_node, 0));
3649 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
3651 gfc_trans_runtime_check (cond,
3652 "Argument NCOPIES of REPEAT intrinsic is too large",
3653 &se->pre, &expr->where);
3655 /* Compute the destination length. */
3656 dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
3657 fold_convert (gfc_charlen_type_node, slen),
3658 fold_convert (gfc_charlen_type_node, ncopies));
3659 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
3660 dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
3662 /* Generate the code to do the repeat operation:
3663 for (i = 0; i < ncopies; i++)
3664 memmove (dest + (i * slen), src, slen); */
3665 gfc_start_block (&block);
3666 count = gfc_create_var (ncopies_type, "count");
3667 gfc_add_modify_expr (&block, count, build_int_cst (ncopies_type, 0));
3668 exit_label = gfc_build_label_decl (NULL_TREE);
3670 /* Start the loop body. */
3671 gfc_start_block (&body);
3673 /* Exit the loop if count >= ncopies. */
3674 cond = fold_build2 (GE_EXPR, boolean_type_node, count, ncopies);
3675 tmp = build1_v (GOTO_EXPR, exit_label);
3676 TREE_USED (exit_label) = 1;
3677 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3678 build_empty_stmt ());
3679 gfc_add_expr_to_block (&body, tmp);
3681 /* Call memmove (dest + (i*slen), src, slen). */
3682 tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
3683 fold_convert (gfc_charlen_type_node, slen),
3684 fold_convert (gfc_charlen_type_node, count));
3685 tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node,
3686 fold_convert (pchar_type_node, dest),
3687 fold_convert (sizetype, tmp));
3688 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3,
3690 gfc_add_expr_to_block (&body, tmp);
3692 /* Increment count. */
3693 tmp = build2 (PLUS_EXPR, ncopies_type, count,
3694 build_int_cst (TREE_TYPE (count), 1));
3695 gfc_add_modify_expr (&body, count, tmp);
3697 /* Build the loop. */
3698 tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
3699 gfc_add_expr_to_block (&block, tmp);
3701 /* Add the exit label. */
3702 tmp = build1_v (LABEL_EXPR, exit_label);
3703 gfc_add_expr_to_block (&block, tmp);
3705 /* Finish the block. */
3706 tmp = gfc_finish_block (&block);
3707 gfc_add_expr_to_block (&se->pre, tmp);
3709 /* Set the result value. */
3711 se->string_length = dlen;
3715 /* Generate code for the IARGC intrinsic. */
3718 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
3724 /* Call the library function. This always returns an INTEGER(4). */
3725 fndecl = gfor_fndecl_iargc;
3726 tmp = build_call_expr (fndecl, 0);
3728 /* Convert it to the required type. */
3729 type = gfc_typenode_for_spec (&expr->ts);
3730 tmp = fold_convert (type, tmp);
3736 /* The loc intrinsic returns the address of its argument as
3737 gfc_index_integer_kind integer. */
3740 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
3746 gcc_assert (!se->ss);
3748 arg_expr = expr->value.function.actual->expr;
3749 ss = gfc_walk_expr (arg_expr);
3750 if (ss == gfc_ss_terminator)
3751 gfc_conv_expr_reference (se, arg_expr);
3753 gfc_conv_array_parameter (se, arg_expr, ss, 1);
3754 se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
3756 /* Create a temporary variable for loc return value. Without this,
3757 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
3758 temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
3759 gfc_add_modify_expr (&se->pre, temp_var, se->expr);
3760 se->expr = temp_var;
3763 /* Generate code for an intrinsic function. Some map directly to library
3764 calls, others get special handling. In some cases the name of the function
3765 used depends on the type specifiers. */
3768 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
3770 gfc_intrinsic_sym *isym;
3774 isym = expr->value.function.isym;
3776 name = &expr->value.function.name[2];
3778 if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
3780 lib = gfc_is_intrinsic_libcall (expr);
3784 se->ignore_optional = 1;
3785 gfc_conv_intrinsic_funcall (se, expr);
3790 switch (expr->value.function.isym->id)
3795 case GFC_ISYM_REPEAT:
3796 gfc_conv_intrinsic_repeat (se, expr);
3800 gfc_conv_intrinsic_trim (se, expr);
3803 case GFC_ISYM_SI_KIND:
3804 gfc_conv_intrinsic_si_kind (se, expr);
3807 case GFC_ISYM_SR_KIND:
3808 gfc_conv_intrinsic_sr_kind (se, expr);
3811 case GFC_ISYM_EXPONENT:
3812 gfc_conv_intrinsic_exponent (se, expr);
3816 gfc_conv_intrinsic_scan (se, expr);
3819 case GFC_ISYM_VERIFY:
3820 gfc_conv_intrinsic_verify (se, expr);
3823 case GFC_ISYM_ALLOCATED:
3824 gfc_conv_allocated (se, expr);
3827 case GFC_ISYM_ASSOCIATED:
3828 gfc_conv_associated(se, expr);
3832 gfc_conv_intrinsic_abs (se, expr);
3835 case GFC_ISYM_ADJUSTL:
3836 gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
3839 case GFC_ISYM_ADJUSTR:
3840 gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
3843 case GFC_ISYM_AIMAG:
3844 gfc_conv_intrinsic_imagpart (se, expr);
3848 gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
3852 gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
3855 case GFC_ISYM_ANINT:
3856 gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
3860 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3864 gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
3867 case GFC_ISYM_BTEST:
3868 gfc_conv_intrinsic_btest (se, expr);
3871 case GFC_ISYM_ACHAR:
3873 gfc_conv_intrinsic_char (se, expr);
3876 case GFC_ISYM_CONVERSION:
3878 case GFC_ISYM_LOGICAL:
3880 gfc_conv_intrinsic_conversion (se, expr);
3883 /* Integer conversions are handled separately to make sure we get the
3884 correct rounding mode. */
3889 gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
3893 gfc_conv_intrinsic_int (se, expr, RND_ROUND);
3896 case GFC_ISYM_CEILING:
3897 gfc_conv_intrinsic_int (se, expr, RND_CEIL);
3900 case GFC_ISYM_FLOOR:
3901 gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
3905 gfc_conv_intrinsic_mod (se, expr, 0);
3908 case GFC_ISYM_MODULO:
3909 gfc_conv_intrinsic_mod (se, expr, 1);
3912 case GFC_ISYM_CMPLX:
3913 gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
3916 case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
3917 gfc_conv_intrinsic_iargc (se, expr);
3920 case GFC_ISYM_COMPLEX:
3921 gfc_conv_intrinsic_cmplx (se, expr, 1);
3924 case GFC_ISYM_CONJG:
3925 gfc_conv_intrinsic_conjg (se, expr);
3928 case GFC_ISYM_COUNT:
3929 gfc_conv_intrinsic_count (se, expr);
3932 case GFC_ISYM_CTIME:
3933 gfc_conv_intrinsic_ctime (se, expr);
3937 gfc_conv_intrinsic_dim (se, expr);
3940 case GFC_ISYM_DOT_PRODUCT:
3941 gfc_conv_intrinsic_dot_product (se, expr);
3944 case GFC_ISYM_DPROD:
3945 gfc_conv_intrinsic_dprod (se, expr);
3948 case GFC_ISYM_FDATE:
3949 gfc_conv_intrinsic_fdate (se, expr);
3953 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3956 case GFC_ISYM_IBCLR:
3957 gfc_conv_intrinsic_singlebitop (se, expr, 0);
3960 case GFC_ISYM_IBITS:
3961 gfc_conv_intrinsic_ibits (se, expr);
3964 case GFC_ISYM_IBSET:
3965 gfc_conv_intrinsic_singlebitop (se, expr, 1);
3968 case GFC_ISYM_IACHAR:
3969 case GFC_ISYM_ICHAR:
3970 /* We assume ASCII character sequence. */
3971 gfc_conv_intrinsic_ichar (se, expr);
3974 case GFC_ISYM_IARGC:
3975 gfc_conv_intrinsic_iargc (se, expr);
3979 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
3982 case GFC_ISYM_INDEX:
3983 gfc_conv_intrinsic_index (se, expr);
3987 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
3990 case GFC_ISYM_LSHIFT:
3991 gfc_conv_intrinsic_rlshift (se, expr, 0);
3994 case GFC_ISYM_RSHIFT:
3995 gfc_conv_intrinsic_rlshift (se, expr, 1);
3998 case GFC_ISYM_ISHFT:
3999 gfc_conv_intrinsic_ishft (se, expr);
4002 case GFC_ISYM_ISHFTC:
4003 gfc_conv_intrinsic_ishftc (se, expr);
4006 case GFC_ISYM_LBOUND:
4007 gfc_conv_intrinsic_bound (se, expr, 0);
4010 case GFC_ISYM_TRANSPOSE:
4011 if (se->ss && se->ss->useflags)
4013 gfc_conv_tmp_array_ref (se);
4014 gfc_advance_se_ss_chain (se);
4017 gfc_conv_array_transpose (se, expr->value.function.actual->expr);
4021 gfc_conv_intrinsic_len (se, expr);
4024 case GFC_ISYM_LEN_TRIM:
4025 gfc_conv_intrinsic_len_trim (se, expr);
4029 gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
4033 gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
4037 gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
4041 gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
4045 gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
4048 case GFC_ISYM_MAXLOC:
4049 gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
4052 case GFC_ISYM_MAXVAL:
4053 gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
4056 case GFC_ISYM_MERGE:
4057 gfc_conv_intrinsic_merge (se, expr);
4061 gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
4064 case GFC_ISYM_MINLOC:
4065 gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
4068 case GFC_ISYM_MINVAL:
4069 gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
4073 gfc_conv_intrinsic_not (se, expr);
4077 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
4080 case GFC_ISYM_PRESENT:
4081 gfc_conv_intrinsic_present (se, expr);
4084 case GFC_ISYM_PRODUCT:
4085 gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
4089 gfc_conv_intrinsic_sign (se, expr);
4093 gfc_conv_intrinsic_size (se, expr);
4096 case GFC_ISYM_SIZEOF:
4097 gfc_conv_intrinsic_sizeof (se, expr);
4101 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
4104 case GFC_ISYM_TRANSFER:
4107 if (se->ss->useflags)
4109 /* Access the previously obtained result. */
4110 gfc_conv_tmp_array_ref (se);
4111 gfc_advance_se_ss_chain (se);
4115 gfc_conv_intrinsic_array_transfer (se, expr);
4118 gfc_conv_intrinsic_transfer (se, expr);
4121 case GFC_ISYM_TTYNAM:
4122 gfc_conv_intrinsic_ttynam (se, expr);
4125 case GFC_ISYM_UBOUND:
4126 gfc_conv_intrinsic_bound (se, expr, 1);
4130 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
4134 gfc_conv_intrinsic_loc (se, expr);
4137 case GFC_ISYM_ACCESS:
4138 case GFC_ISYM_CHDIR:
4139 case GFC_ISYM_CHMOD:
4140 case GFC_ISYM_ETIME:
4142 case GFC_ISYM_FGETC:
4145 case GFC_ISYM_FPUTC:
4146 case GFC_ISYM_FSTAT:
4147 case GFC_ISYM_FTELL:
4148 case GFC_ISYM_GETCWD:
4149 case GFC_ISYM_GETGID:
4150 case GFC_ISYM_GETPID:
4151 case GFC_ISYM_GETUID:
4152 case GFC_ISYM_HOSTNM:
4154 case GFC_ISYM_IERRNO:
4155 case GFC_ISYM_IRAND:
4156 case GFC_ISYM_ISATTY:
4158 case GFC_ISYM_LSTAT:
4159 case GFC_ISYM_MALLOC:
4160 case GFC_ISYM_MATMUL:
4161 case GFC_ISYM_MCLOCK:
4162 case GFC_ISYM_MCLOCK8:
4164 case GFC_ISYM_RENAME:
4165 case GFC_ISYM_SECOND:
4166 case GFC_ISYM_SECNDS:
4167 case GFC_ISYM_SIGNAL:
4169 case GFC_ISYM_SYMLNK:
4170 case GFC_ISYM_SYSTEM:
4172 case GFC_ISYM_TIME8:
4173 case GFC_ISYM_UMASK:
4174 case GFC_ISYM_UNLINK:
4175 gfc_conv_intrinsic_funcall (se, expr);
4179 gfc_conv_intrinsic_lib_function (se, expr);
4185 /* This generates code to execute before entering the scalarization loop.
4186 Currently does nothing. */
4189 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
4191 switch (ss->expr->value.function.isym->id)
4193 case GFC_ISYM_UBOUND:
4194 case GFC_ISYM_LBOUND:
4203 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
4204 inside the scalarization loop. */
4207 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
4211 /* The two argument version returns a scalar. */
4212 if (expr->value.function.actual->next->expr)
4215 newss = gfc_get_ss ();
4216 newss->type = GFC_SS_INTRINSIC;
4219 newss->data.info.dimen = 1;
4225 /* Walk an intrinsic array libcall. */
4228 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
4232 gcc_assert (expr->rank > 0);
4234 newss = gfc_get_ss ();
4235 newss->type = GFC_SS_FUNCTION;
4238 newss->data.info.dimen = expr->rank;
4244 /* Returns nonzero if the specified intrinsic function call maps directly to a
4245 an external library call. Should only be used for functions that return
4249 gfc_is_intrinsic_libcall (gfc_expr * expr)
4251 gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
4252 gcc_assert (expr->rank > 0);
4254 switch (expr->value.function.isym->id)
4258 case GFC_ISYM_COUNT:
4259 case GFC_ISYM_MATMUL:
4260 case GFC_ISYM_MAXLOC:
4261 case GFC_ISYM_MAXVAL:
4262 case GFC_ISYM_MINLOC:
4263 case GFC_ISYM_MINVAL:
4264 case GFC_ISYM_PRODUCT:
4266 case GFC_ISYM_SHAPE:
4267 case GFC_ISYM_SPREAD:
4268 case GFC_ISYM_TRANSPOSE:
4269 /* Ignore absent optional parameters. */
4272 case GFC_ISYM_RESHAPE:
4273 case GFC_ISYM_CSHIFT:
4274 case GFC_ISYM_EOSHIFT:
4276 case GFC_ISYM_UNPACK:
4277 /* Pass absent optional parameters. */
4285 /* Walk an intrinsic function. */
4287 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
4288 gfc_intrinsic_sym * isym)
4292 if (isym->elemental)
4293 return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
4295 if (expr->rank == 0)
4298 if (gfc_is_intrinsic_libcall (expr))
4299 return gfc_walk_intrinsic_libfunc (ss, expr);
4301 /* Special cases. */
4304 case GFC_ISYM_LBOUND:
4305 case GFC_ISYM_UBOUND:
4306 return gfc_walk_intrinsic_bound (ss, expr);
4308 case GFC_ISYM_TRANSFER:
4309 return gfc_walk_intrinsic_libfunc (ss, expr);
4312 /* This probably meant someone forgot to add an intrinsic to the above
4313 list(s) when they implemented it, or something's gone horribly wrong.
4315 gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
4316 expr->value.function.name);
4320 #include "gt-fortran-trans-intrinsic.h"