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 2, 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 COPYING. If not, write to the Free
21 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
24 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
28 #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 /* This is needed because the gcc backend only implements FIX_TRUNC_EXPR
313 NINT(x) = INT(x + ((x > 0) ? 0.5 : -0.5)). */
316 build_round_expr (stmtblock_t * pblock, tree arg, tree type)
325 argtype = TREE_TYPE (arg);
326 arg = gfc_evaluate_now (arg, pblock);
328 real_from_string (&r, "0.5");
329 pos = build_real (argtype, r);
331 real_from_string (&r, "-0.5");
332 neg = build_real (argtype, r);
334 tmp = gfc_build_const (argtype, integer_zero_node);
335 cond = fold_build2 (GT_EXPR, boolean_type_node, arg, tmp);
337 tmp = fold_build3 (COND_EXPR, argtype, cond, pos, neg);
338 tmp = fold_build2 (PLUS_EXPR, argtype, arg, tmp);
339 return fold_build1 (FIX_TRUNC_EXPR, type, tmp);
343 /* Convert a real to an integer using a specific rounding mode.
344 Ideally we would just build the corresponding GENERIC node,
345 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
348 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
349 enum rounding_mode op)
354 return build_fixbound_expr (pblock, arg, type, 0);
358 return build_fixbound_expr (pblock, arg, type, 1);
362 return build_round_expr (pblock, arg, type);
365 gcc_assert (op == RND_TRUNC);
366 return build1 (FIX_TRUNC_EXPR, type, arg);
371 /* Round a real value using the specified rounding mode.
372 We use a temporary integer of that same kind size as the result.
373 Values larger than those that can be represented by this kind are
374 unchanged, as they will not be accurate enough to represent the
376 huge = HUGE (KIND (a))
377 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
381 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
392 kind = expr->ts.kind;
395 /* We have builtin functions for some cases. */
438 /* Evaluate the argument. */
439 gcc_assert (expr->value.function.actual->expr);
440 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
442 /* Use a builtin function if one exists. */
443 if (n != END_BUILTINS)
445 tmp = built_in_decls[n];
446 se->expr = build_call_expr (tmp, 1, arg);
450 /* This code is probably redundant, but we'll keep it lying around just
452 type = gfc_typenode_for_spec (&expr->ts);
453 arg = gfc_evaluate_now (arg, &se->pre);
455 /* Test if the value is too large to handle sensibly. */
456 gfc_set_model_kind (kind);
458 n = gfc_validate_kind (BT_INTEGER, kind, false);
459 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
460 tmp = gfc_conv_mpfr_to_tree (huge, kind);
461 cond = build2 (LT_EXPR, boolean_type_node, arg, tmp);
463 mpfr_neg (huge, huge, GFC_RND_MODE);
464 tmp = gfc_conv_mpfr_to_tree (huge, kind);
465 tmp = build2 (GT_EXPR, boolean_type_node, arg, tmp);
466 cond = build2 (TRUTH_AND_EXPR, boolean_type_node, cond, tmp);
467 itype = gfc_get_int_type (kind);
469 tmp = build_fix_expr (&se->pre, arg, itype, op);
470 tmp = convert (type, tmp);
471 se->expr = build3 (COND_EXPR, type, cond, tmp, arg);
476 /* Convert to an integer using the specified rounding mode. */
479 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
485 nargs = gfc_intrinsic_argument_list_length (expr);
486 args = alloca (sizeof (tree) * nargs);
488 /* Evaluate the argument, we process all arguments even though we only
489 use the first one for code generation purposes. */
490 type = gfc_typenode_for_spec (&expr->ts);
491 gcc_assert (expr->value.function.actual->expr);
492 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
494 if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
496 /* Conversion to a different integer kind. */
497 se->expr = convert (type, args[0]);
501 /* Conversion from complex to non-complex involves taking the real
502 component of the value. */
503 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
504 && expr->ts.type != BT_COMPLEX)
508 artype = TREE_TYPE (TREE_TYPE (args[0]));
509 args[0] = build1 (REALPART_EXPR, artype, args[0]);
512 se->expr = build_fix_expr (&se->pre, args[0], type, op);
517 /* Get the imaginary component of a value. */
520 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
524 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
525 se->expr = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (arg)), arg);
529 /* Get the complex conjugate of a value. */
532 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
536 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
537 se->expr = build1 (CONJ_EXPR, TREE_TYPE (arg), arg);
541 /* Initialize function decls for library functions. The external functions
542 are created as required. Builtin functions are added here. */
545 gfc_build_intrinsic_lib_fndecls (void)
547 gfc_intrinsic_map_t *m;
549 /* Add GCC builtin functions. */
550 for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
552 if (m->code_r4 != END_BUILTINS)
553 m->real4_decl = built_in_decls[m->code_r4];
554 if (m->code_r8 != END_BUILTINS)
555 m->real8_decl = built_in_decls[m->code_r8];
556 if (m->code_r10 != END_BUILTINS)
557 m->real10_decl = built_in_decls[m->code_r10];
558 if (m->code_r16 != END_BUILTINS)
559 m->real16_decl = built_in_decls[m->code_r16];
560 if (m->code_c4 != END_BUILTINS)
561 m->complex4_decl = built_in_decls[m->code_c4];
562 if (m->code_c8 != END_BUILTINS)
563 m->complex8_decl = built_in_decls[m->code_c8];
564 if (m->code_c10 != END_BUILTINS)
565 m->complex10_decl = built_in_decls[m->code_c10];
566 if (m->code_c16 != END_BUILTINS)
567 m->complex16_decl = built_in_decls[m->code_c16];
572 /* Create a fndecl for a simple intrinsic library function. */
575 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
580 gfc_actual_arglist *actual;
583 char name[GFC_MAX_SYMBOL_LEN + 3];
586 if (ts->type == BT_REAL)
591 pdecl = &m->real4_decl;
594 pdecl = &m->real8_decl;
597 pdecl = &m->real10_decl;
600 pdecl = &m->real16_decl;
606 else if (ts->type == BT_COMPLEX)
608 gcc_assert (m->complex_available);
613 pdecl = &m->complex4_decl;
616 pdecl = &m->complex8_decl;
619 pdecl = &m->complex10_decl;
622 pdecl = &m->complex16_decl;
637 snprintf (name, sizeof (name), "%s%s%s",
638 ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
639 else if (ts->kind == 8)
640 snprintf (name, sizeof (name), "%s%s",
641 ts->type == BT_COMPLEX ? "c" : "", m->name);
644 gcc_assert (ts->kind == 10 || ts->kind == 16);
645 snprintf (name, sizeof (name), "%s%s%s",
646 ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
651 snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
652 ts->type == BT_COMPLEX ? 'c' : 'r',
656 argtypes = NULL_TREE;
657 for (actual = expr->value.function.actual; actual; actual = actual->next)
659 type = gfc_typenode_for_spec (&actual->expr->ts);
660 argtypes = gfc_chainon_list (argtypes, type);
662 argtypes = gfc_chainon_list (argtypes, void_type_node);
663 type = build_function_type (gfc_typenode_for_spec (ts), argtypes);
664 fndecl = build_decl (FUNCTION_DECL, get_identifier (name), type);
666 /* Mark the decl as external. */
667 DECL_EXTERNAL (fndecl) = 1;
668 TREE_PUBLIC (fndecl) = 1;
670 /* Mark it __attribute__((const)), if possible. */
671 TREE_READONLY (fndecl) = m->is_constant;
673 rest_of_decl_compilation (fndecl, 1, 0);
680 /* Convert an intrinsic function into an external or builtin call. */
683 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
685 gfc_intrinsic_map_t *m;
689 unsigned int num_args;
692 id = expr->value.function.isym->id;
693 /* Find the entry for this function. */
694 for (m = gfc_intrinsic_map; m->id != GFC_ISYM_NONE; m++)
700 if (m->id == GFC_ISYM_NONE)
702 internal_error ("Intrinsic function %s(%d) not recognized",
703 expr->value.function.name, id);
706 /* Get the decl and generate the call. */
707 num_args = gfc_intrinsic_argument_list_length (expr);
708 args = alloca (sizeof (tree) * num_args);
710 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
711 fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
712 rettype = TREE_TYPE (TREE_TYPE (fndecl));
714 fndecl = build_addr (fndecl, current_function_decl);
715 se->expr = build_call_array (rettype, fndecl, num_args, args);
718 /* Generate code for EXPONENT(X) intrinsic function. */
721 gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
723 tree arg, fndecl, type;
726 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
728 a1 = expr->value.function.actual->expr;
732 fndecl = gfor_fndecl_math_exponent4;
735 fndecl = gfor_fndecl_math_exponent8;
738 fndecl = gfor_fndecl_math_exponent10;
741 fndecl = gfor_fndecl_math_exponent16;
747 /* Convert it to the required type. */
748 type = gfc_typenode_for_spec (&expr->ts);
749 se->expr = fold_convert (type, build_call_expr (fndecl, 1, arg));
752 /* Evaluate a single upper or lower bound. */
753 /* TODO: bound intrinsic generates way too much unnecessary code. */
756 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
758 gfc_actual_arglist *arg;
759 gfc_actual_arglist *arg2;
764 tree cond, cond1, cond2, cond3, cond4, size;
772 arg = expr->value.function.actual;
777 /* Create an implicit second parameter from the loop variable. */
778 gcc_assert (!arg2->expr);
779 gcc_assert (se->loop->dimen == 1);
780 gcc_assert (se->ss->expr == expr);
781 gfc_advance_se_ss_chain (se);
782 bound = se->loop->loopvar[0];
783 bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
788 /* use the passed argument. */
789 gcc_assert (arg->next->expr);
790 gfc_init_se (&argse, NULL);
791 gfc_conv_expr_type (&argse, arg->next->expr, gfc_array_index_type);
792 gfc_add_block_to_block (&se->pre, &argse.pre);
794 /* Convert from one based to zero based. */
795 bound = fold_build2 (MINUS_EXPR, gfc_array_index_type, bound,
799 /* TODO: don't re-evaluate the descriptor on each iteration. */
800 /* Get a descriptor for the first parameter. */
801 ss = gfc_walk_expr (arg->expr);
802 gcc_assert (ss != gfc_ss_terminator);
803 gfc_init_se (&argse, NULL);
804 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
805 gfc_add_block_to_block (&se->pre, &argse.pre);
806 gfc_add_block_to_block (&se->post, &argse.post);
810 if (INTEGER_CST_P (bound))
814 hi = TREE_INT_CST_HIGH (bound);
815 low = TREE_INT_CST_LOW (bound);
816 if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
817 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
818 "dimension index", upper ? "UBOUND" : "LBOUND",
823 if (flag_bounds_check)
825 bound = gfc_evaluate_now (bound, &se->pre);
826 cond = fold_build2 (LT_EXPR, boolean_type_node,
827 bound, build_int_cst (TREE_TYPE (bound), 0));
828 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
829 tmp = fold_build2 (GE_EXPR, boolean_type_node, bound, tmp);
830 cond = fold_build2 (TRUTH_ORIF_EXPR, boolean_type_node, cond, tmp);
831 gfc_trans_runtime_check (cond, gfc_msg_fault, &se->pre, &expr->where);
835 ubound = gfc_conv_descriptor_ubound (desc, bound);
836 lbound = gfc_conv_descriptor_lbound (desc, bound);
838 /* Follow any component references. */
839 if (arg->expr->expr_type == EXPR_VARIABLE
840 || arg->expr->expr_type == EXPR_CONSTANT)
842 as = arg->expr->symtree->n.sym->as;
843 for (ref = arg->expr->ref; ref; ref = ref->next)
848 as = ref->u.c.component->as;
856 switch (ref->u.ar.type)
874 /* 13.14.53: Result value for LBOUND
876 Case (i): For an array section or for an array expression other than a
877 whole array or array structure component, LBOUND(ARRAY, DIM)
878 has the value 1. For a whole array or array structure
879 component, LBOUND(ARRAY, DIM) has the value:
880 (a) equal to the lower bound for subscript DIM of ARRAY if
881 dimension DIM of ARRAY does not have extent zero
882 or if ARRAY is an assumed-size array of rank DIM,
885 13.14.113: Result value for UBOUND
887 Case (i): For an array section or for an array expression other than a
888 whole array or array structure component, UBOUND(ARRAY, DIM)
889 has the value equal to the number of elements in the given
890 dimension; otherwise, it has a value equal to the upper bound
891 for subscript DIM of ARRAY if dimension DIM of ARRAY does
892 not have size zero and has value zero if dimension DIM has
897 tree stride = gfc_conv_descriptor_stride (desc, bound);
899 cond1 = fold_build2 (GE_EXPR, boolean_type_node, ubound, lbound);
900 cond2 = fold_build2 (LE_EXPR, boolean_type_node, ubound, lbound);
902 cond3 = fold_build2 (GE_EXPR, boolean_type_node, stride,
903 gfc_index_zero_node);
904 cond3 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond3, cond1);
906 cond4 = fold_build2 (LT_EXPR, boolean_type_node, stride,
907 gfc_index_zero_node);
908 cond4 = fold_build2 (TRUTH_AND_EXPR, boolean_type_node, cond4, cond2);
912 cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
914 se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
915 ubound, gfc_index_zero_node);
919 if (as->type == AS_ASSUMED_SIZE)
920 cond = fold_build2 (EQ_EXPR, boolean_type_node, bound,
921 build_int_cst (TREE_TYPE (bound),
922 arg->expr->rank - 1));
924 cond = boolean_false_node;
926 cond1 = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond3, cond4);
927 cond = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, cond, cond1);
929 se->expr = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
930 lbound, gfc_index_one_node);
937 size = fold_build2 (MINUS_EXPR, gfc_array_index_type, ubound, lbound);
938 se->expr = fold_build2 (PLUS_EXPR, gfc_array_index_type, size,
942 se->expr = gfc_index_one_node;
945 type = gfc_typenode_for_spec (&expr->ts);
946 se->expr = convert (type, se->expr);
951 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
956 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
958 switch (expr->value.function.actual->expr->ts.type)
962 se->expr = build1 (ABS_EXPR, TREE_TYPE (arg), arg);
966 switch (expr->ts.kind)
981 se->expr = build_call_expr (built_in_decls[n], 1, arg);
990 /* Create a complex value from one or two real components. */
993 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
999 unsigned int num_args;
1001 num_args = gfc_intrinsic_argument_list_length (expr);
1002 args = alloca (sizeof (tree) * num_args);
1004 type = gfc_typenode_for_spec (&expr->ts);
1005 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
1006 real = convert (TREE_TYPE (type), args[0]);
1008 imag = convert (TREE_TYPE (type), args[1]);
1009 else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
1011 imag = build1 (IMAGPART_EXPR, TREE_TYPE (TREE_TYPE (args[0])), args[0]);
1012 imag = convert (TREE_TYPE (type), imag);
1015 imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
1017 se->expr = fold_build2 (COMPLEX_EXPR, type, real, imag);
1020 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1021 MODULO(A, P) = A - FLOOR (A / P) * P */
1022 /* TODO: MOD(x, 0) */
1025 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
1036 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1038 switch (expr->ts.type)
1041 /* Integer case is easy, we've got a builtin op. */
1042 type = TREE_TYPE (args[0]);
1045 se->expr = build2 (FLOOR_MOD_EXPR, type, args[0], args[1]);
1047 se->expr = build2 (TRUNC_MOD_EXPR, type, args[0], args[1]);
1052 /* Check if we have a builtin fmod. */
1053 switch (expr->ts.kind)
1072 /* Use it if it exists. */
1073 if (n != END_BUILTINS)
1075 tmp = build_addr (built_in_decls[n], current_function_decl);
1076 se->expr = build_call_array (TREE_TYPE (TREE_TYPE (built_in_decls[n])),
1082 type = TREE_TYPE (args[0]);
1084 args[0] = gfc_evaluate_now (args[0], &se->pre);
1085 args[1] = gfc_evaluate_now (args[1], &se->pre);
1088 modulo = arg - floor (arg/arg2) * arg2, so
1089 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1091 test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1092 thereby avoiding another division and retaining the accuracy
1093 of the builtin function. */
1094 if (n != END_BUILTINS && modulo)
1096 tree zero = gfc_build_const (type, integer_zero_node);
1097 tmp = gfc_evaluate_now (se->expr, &se->pre);
1098 test = build2 (LT_EXPR, boolean_type_node, args[0], zero);
1099 test2 = build2 (LT_EXPR, boolean_type_node, args[1], zero);
1100 test2 = build2 (TRUTH_XOR_EXPR, boolean_type_node, test, test2);
1101 test = build2 (NE_EXPR, boolean_type_node, tmp, zero);
1102 test = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1103 test = gfc_evaluate_now (test, &se->pre);
1104 se->expr = build3 (COND_EXPR, type, test,
1105 build2 (PLUS_EXPR, type, tmp, args[1]), tmp);
1109 /* If we do not have a built_in fmod, the calculation is going to
1110 have to be done longhand. */
1111 tmp = build2 (RDIV_EXPR, type, args[0], args[1]);
1113 /* Test if the value is too large to handle sensibly. */
1114 gfc_set_model_kind (expr->ts.kind);
1116 n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true);
1117 ikind = expr->ts.kind;
1120 n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false);
1121 ikind = gfc_max_integer_kind;
1123 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
1124 test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
1125 test2 = build2 (LT_EXPR, boolean_type_node, tmp, test);
1127 mpfr_neg (huge, huge, GFC_RND_MODE);
1128 test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind);
1129 test = build2 (GT_EXPR, boolean_type_node, tmp, test);
1130 test2 = build2 (TRUTH_AND_EXPR, boolean_type_node, test, test2);
1132 itype = gfc_get_int_type (ikind);
1134 tmp = build_fix_expr (&se->pre, tmp, itype, RND_FLOOR);
1136 tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC);
1137 tmp = convert (type, tmp);
1138 tmp = build3 (COND_EXPR, type, test2, tmp, args[0]);
1139 tmp = build2 (MULT_EXPR, type, tmp, args[1]);
1140 se->expr = build2 (MINUS_EXPR, type, args[0], tmp);
1149 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
1152 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
1160 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1161 type = TREE_TYPE (args[0]);
1163 val = build2 (MINUS_EXPR, type, args[0], args[1]);
1164 val = gfc_evaluate_now (val, &se->pre);
1166 zero = gfc_build_const (type, integer_zero_node);
1167 tmp = build2 (LE_EXPR, boolean_type_node, val, zero);
1168 se->expr = build3 (COND_EXPR, type, tmp, zero, val);
1172 /* SIGN(A, B) is absolute value of A times sign of B.
1173 The real value versions use library functions to ensure the correct
1174 handling of negative zero. Integer case implemented as:
1175 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1179 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
1185 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1186 if (expr->ts.type == BT_REAL)
1188 switch (expr->ts.kind)
1191 tmp = built_in_decls[BUILT_IN_COPYSIGNF];
1194 tmp = built_in_decls[BUILT_IN_COPYSIGN];
1198 tmp = built_in_decls[BUILT_IN_COPYSIGNL];
1203 se->expr = build_call_expr (tmp, 2, args[0], args[1]);
1207 /* Having excluded floating point types, we know we are now dealing
1208 with signed integer types. */
1209 type = TREE_TYPE (args[0]);
1211 /* Args[0] is used multiple times below. */
1212 args[0] = gfc_evaluate_now (args[0], &se->pre);
1214 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1215 the signs of A and B are the same, and of all ones if they differ. */
1216 tmp = fold_build2 (BIT_XOR_EXPR, type, args[0], args[1]);
1217 tmp = fold_build2 (RSHIFT_EXPR, type, tmp,
1218 build_int_cst (type, TYPE_PRECISION (type) - 1));
1219 tmp = gfc_evaluate_now (tmp, &se->pre);
1221 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1222 is all ones (i.e. -1). */
1223 se->expr = fold_build2 (BIT_XOR_EXPR, type,
1224 fold_build2 (PLUS_EXPR, type, args[0], tmp),
1229 /* Test for the presence of an optional argument. */
1232 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
1236 arg = expr->value.function.actual->expr;
1237 gcc_assert (arg->expr_type == EXPR_VARIABLE);
1238 se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
1239 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
1243 /* Calculate the double precision product of two single precision values. */
1246 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
1251 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1253 /* Convert the args to double precision before multiplying. */
1254 type = gfc_typenode_for_spec (&expr->ts);
1255 args[0] = convert (type, args[0]);
1256 args[1] = convert (type, args[1]);
1257 se->expr = build2 (MULT_EXPR, type, args[0], args[1]);
1261 /* Return a length one character string containing an ascii character. */
1264 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
1270 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
1272 /* We currently don't support character types != 1. */
1273 gcc_assert (expr->ts.kind == 1);
1274 type = gfc_character1_type_node;
1275 var = gfc_create_var (type, "char");
1277 arg = convert (type, arg);
1278 gfc_add_modify_expr (&se->pre, var, arg);
1279 se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
1280 se->string_length = integer_one_node;
1285 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
1292 tree gfc_int8_type_node = gfc_get_int_type (8);
1295 unsigned int num_args;
1297 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1298 args = alloca (sizeof (tree) * num_args);
1300 type = build_pointer_type (gfc_character1_type_node);
1301 var = gfc_create_var (type, "pstr");
1302 len = gfc_create_var (gfc_int8_type_node, "len");
1304 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1305 args[0] = build_fold_addr_expr (var);
1306 args[1] = build_fold_addr_expr (len);
1308 fndecl = build_addr (gfor_fndecl_ctime, current_function_decl);
1309 tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
1310 fndecl, num_args, args);
1311 gfc_add_expr_to_block (&se->pre, tmp);
1313 /* Free the temporary afterwards, if necessary. */
1314 cond = build2 (GT_EXPR, boolean_type_node, len,
1315 build_int_cst (TREE_TYPE (len), 0));
1316 tmp = gfc_call_free (var);
1317 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1318 gfc_add_expr_to_block (&se->post, tmp);
1321 se->string_length = len;
1326 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
1333 tree gfc_int4_type_node = gfc_get_int_type (4);
1336 unsigned int num_args;
1338 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1339 args = alloca (sizeof (tree) * num_args);
1341 type = build_pointer_type (gfc_character1_type_node);
1342 var = gfc_create_var (type, "pstr");
1343 len = gfc_create_var (gfc_int4_type_node, "len");
1345 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1346 args[0] = build_fold_addr_expr (var);
1347 args[1] = build_fold_addr_expr (len);
1349 fndecl = build_addr (gfor_fndecl_fdate, current_function_decl);
1350 tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
1351 fndecl, num_args, args);
1352 gfc_add_expr_to_block (&se->pre, tmp);
1354 /* Free the temporary afterwards, if necessary. */
1355 cond = build2 (GT_EXPR, boolean_type_node, len,
1356 build_int_cst (TREE_TYPE (len), 0));
1357 tmp = gfc_call_free (var);
1358 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1359 gfc_add_expr_to_block (&se->post, tmp);
1362 se->string_length = len;
1366 /* Return a character string containing the tty name. */
1369 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
1377 tree gfc_int4_type_node = gfc_get_int_type (4);
1379 unsigned int num_args;
1381 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
1382 args = alloca (sizeof (tree) * num_args);
1384 type = build_pointer_type (gfc_character1_type_node);
1385 var = gfc_create_var (type, "pstr");
1386 len = gfc_create_var (gfc_int4_type_node, "len");
1388 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
1389 args[0] = build_fold_addr_expr (var);
1390 args[1] = build_fold_addr_expr (len);
1392 fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl);
1393 tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
1394 fndecl, num_args, args);
1395 gfc_add_expr_to_block (&se->pre, tmp);
1397 /* Free the temporary afterwards, if necessary. */
1398 cond = build2 (GT_EXPR, boolean_type_node, len,
1399 build_int_cst (TREE_TYPE (len), 0));
1400 tmp = gfc_call_free (var);
1401 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1402 gfc_add_expr_to_block (&se->post, tmp);
1405 se->string_length = len;
1409 /* Get the minimum/maximum value of all the parameters.
1410 minmax (a1, a2, a3, ...)
1412 if (a2 .op. a1 || isnan(a1))
1416 if (a3 .op. mvar || isnan(mvar))
1423 /* TODO: Mismatching types can occur when specific names are used.
1424 These should be handled during resolution. */
1426 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, int op)
1436 gfc_actual_arglist *argexpr;
1440 nargs = gfc_intrinsic_argument_list_length (expr);
1441 args = alloca (sizeof (tree) * nargs);
1443 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
1444 type = gfc_typenode_for_spec (&expr->ts);
1446 /* The first and second arguments should be present, if they are
1447 optional dummy arguments. */
1448 argexpr = expr->value.function.actual;
1449 if (argexpr->expr->expr_type == EXPR_VARIABLE
1450 && argexpr->expr->symtree->n.sym->attr.optional
1451 && TREE_CODE (args[0]) == INDIRECT_REF)
1453 /* Check the first argument. */
1457 asprintf (&msg, "First argument of '%s' intrinsic should be present",
1458 expr->symtree->n.sym->name);
1459 cond = build2 (EQ_EXPR, boolean_type_node, TREE_OPERAND (args[0], 0),
1460 build_int_cst (TREE_TYPE (TREE_OPERAND (args[0], 0)), 0));
1461 gfc_trans_runtime_check (cond, msg, &se->pre, &expr->where);
1465 if (argexpr->next->expr->expr_type == EXPR_VARIABLE
1466 && argexpr->next->expr->symtree->n.sym->attr.optional
1467 && TREE_CODE (args[1]) == INDIRECT_REF)
1469 /* Check the second argument. */
1473 asprintf (&msg, "Second argument of '%s' intrinsic should be present",
1474 expr->symtree->n.sym->name);
1475 cond = build2 (EQ_EXPR, boolean_type_node, TREE_OPERAND (args[1], 0),
1476 build_int_cst (TREE_TYPE (TREE_OPERAND (args[1], 0)), 0));
1477 gfc_trans_runtime_check (cond, msg, &se->pre, &expr->where);
1482 if (TREE_TYPE (limit) != type)
1483 limit = convert (type, limit);
1484 /* Only evaluate the argument once. */
1485 if (TREE_CODE (limit) != VAR_DECL && !TREE_CONSTANT (limit))
1486 limit = gfc_evaluate_now (limit, &se->pre);
1488 mvar = gfc_create_var (type, "M");
1489 elsecase = build2_v (MODIFY_EXPR, mvar, limit);
1490 for (i = 1, argexpr = argexpr->next; i < nargs; i++)
1496 /* Handle absent optional arguments by ignoring the comparison. */
1497 if (i > 0 && argexpr->expr->expr_type == EXPR_VARIABLE
1498 && argexpr->expr->symtree->n.sym->attr.optional
1499 && TREE_CODE (val) == INDIRECT_REF)
1500 cond = build2 (NE_EXPR, boolean_type_node, TREE_OPERAND (val, 0),
1501 build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
1506 /* Only evaluate the argument once. */
1507 if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
1508 val = gfc_evaluate_now (val, &se->pre);
1511 thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
1513 tmp = build2 (op, boolean_type_node, convert (type, val), limit);
1515 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
1516 __builtin_isnan might be made dependent on that module being loaded,
1517 to help performance of programs that don't rely on IEEE semantics. */
1518 if (FLOAT_TYPE_P (TREE_TYPE (limit)))
1520 isnan = build_call_expr (built_in_decls[BUILT_IN_ISNAN], 1, limit);
1521 tmp = fold_build2 (TRUTH_OR_EXPR, boolean_type_node, tmp, isnan);
1523 tmp = build3_v (COND_EXPR, tmp, thencase, elsecase);
1525 if (cond != NULL_TREE)
1526 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1528 gfc_add_expr_to_block (&se->pre, tmp);
1529 elsecase = build_empty_stmt ();
1531 argexpr = argexpr->next;
1537 /* Create a symbol node for this intrinsic. The symbol from the frontend
1538 has the generic name. */
1541 gfc_get_symbol_for_expr (gfc_expr * expr)
1545 /* TODO: Add symbols for intrinsic function to the global namespace. */
1546 gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
1547 sym = gfc_new_symbol (expr->value.function.name, NULL);
1550 sym->attr.external = 1;
1551 sym->attr.function = 1;
1552 sym->attr.always_explicit = 1;
1553 sym->attr.proc = PROC_INTRINSIC;
1554 sym->attr.flavor = FL_PROCEDURE;
1558 sym->attr.dimension = 1;
1559 sym->as = gfc_get_array_spec ();
1560 sym->as->type = AS_ASSUMED_SHAPE;
1561 sym->as->rank = expr->rank;
1564 /* TODO: proper argument lists for external intrinsics. */
1568 /* Generate a call to an external intrinsic function. */
1570 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
1575 gcc_assert (!se->ss || se->ss->expr == expr);
1578 gcc_assert (expr->rank > 0);
1580 gcc_assert (expr->rank == 0);
1582 sym = gfc_get_symbol_for_expr (expr);
1584 /* Calls to libgfortran_matmul need to be appended special arguments,
1585 to be able to call the BLAS ?gemm functions if required and possible. */
1586 append_args = NULL_TREE;
1587 if (expr->value.function.isym->id == GFC_ISYM_MATMUL
1588 && sym->ts.type != BT_LOGICAL)
1590 tree cint = gfc_get_int_type (gfc_c_int_kind);
1592 if (gfc_option.flag_external_blas
1593 && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
1594 && (sym->ts.kind == gfc_default_real_kind
1595 || sym->ts.kind == gfc_default_double_kind))
1599 if (sym->ts.type == BT_REAL)
1601 if (sym->ts.kind == gfc_default_real_kind)
1602 gemm_fndecl = gfor_fndecl_sgemm;
1604 gemm_fndecl = gfor_fndecl_dgemm;
1608 if (sym->ts.kind == gfc_default_real_kind)
1609 gemm_fndecl = gfor_fndecl_cgemm;
1611 gemm_fndecl = gfor_fndecl_zgemm;
1614 append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 1));
1615 append_args = gfc_chainon_list
1616 (append_args, build_int_cst
1617 (cint, gfc_option.blas_matmul_limit));
1618 append_args = gfc_chainon_list (append_args,
1619 gfc_build_addr_expr (NULL_TREE,
1624 append_args = gfc_chainon_list (NULL_TREE, build_int_cst (cint, 0));
1625 append_args = gfc_chainon_list (append_args, build_int_cst (cint, 0));
1626 append_args = gfc_chainon_list (append_args, null_pointer_node);
1630 gfc_conv_function_call (se, sym, expr->value.function.actual, append_args);
1634 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
1654 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, int op)
1663 gfc_actual_arglist *actual;
1670 gfc_conv_intrinsic_funcall (se, expr);
1674 actual = expr->value.function.actual;
1675 type = gfc_typenode_for_spec (&expr->ts);
1676 /* Initialize the result. */
1677 resvar = gfc_create_var (type, "test");
1679 tmp = convert (type, boolean_true_node);
1681 tmp = convert (type, boolean_false_node);
1682 gfc_add_modify_expr (&se->pre, resvar, tmp);
1684 /* Walk the arguments. */
1685 arrayss = gfc_walk_expr (actual->expr);
1686 gcc_assert (arrayss != gfc_ss_terminator);
1688 /* Initialize the scalarizer. */
1689 gfc_init_loopinfo (&loop);
1690 exit_label = gfc_build_label_decl (NULL_TREE);
1691 TREE_USED (exit_label) = 1;
1692 gfc_add_ss_to_loop (&loop, arrayss);
1694 /* Initialize the loop. */
1695 gfc_conv_ss_startstride (&loop);
1696 gfc_conv_loop_setup (&loop);
1698 gfc_mark_ss_chain_used (arrayss, 1);
1699 /* Generate the loop body. */
1700 gfc_start_scalarized_body (&loop, &body);
1702 /* If the condition matches then set the return value. */
1703 gfc_start_block (&block);
1705 tmp = convert (type, boolean_false_node);
1707 tmp = convert (type, boolean_true_node);
1708 gfc_add_modify_expr (&block, resvar, tmp);
1710 /* And break out of the loop. */
1711 tmp = build1_v (GOTO_EXPR, exit_label);
1712 gfc_add_expr_to_block (&block, tmp);
1714 found = gfc_finish_block (&block);
1716 /* Check this element. */
1717 gfc_init_se (&arrayse, NULL);
1718 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1719 arrayse.ss = arrayss;
1720 gfc_conv_expr_val (&arrayse, actual->expr);
1722 gfc_add_block_to_block (&body, &arrayse.pre);
1723 tmp = fold_build2 (op, boolean_type_node, arrayse.expr,
1724 build_int_cst (TREE_TYPE (arrayse.expr), 0));
1725 tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt ());
1726 gfc_add_expr_to_block (&body, tmp);
1727 gfc_add_block_to_block (&body, &arrayse.post);
1729 gfc_trans_scalarizing_loops (&loop, &body);
1731 /* Add the exit label. */
1732 tmp = build1_v (LABEL_EXPR, exit_label);
1733 gfc_add_expr_to_block (&loop.pre, tmp);
1735 gfc_add_block_to_block (&se->pre, &loop.pre);
1736 gfc_add_block_to_block (&se->pre, &loop.post);
1737 gfc_cleanup_loop (&loop);
1742 /* COUNT(A) = Number of true elements in A. */
1744 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
1751 gfc_actual_arglist *actual;
1757 gfc_conv_intrinsic_funcall (se, expr);
1761 actual = expr->value.function.actual;
1763 type = gfc_typenode_for_spec (&expr->ts);
1764 /* Initialize the result. */
1765 resvar = gfc_create_var (type, "count");
1766 gfc_add_modify_expr (&se->pre, resvar, build_int_cst (type, 0));
1768 /* Walk the arguments. */
1769 arrayss = gfc_walk_expr (actual->expr);
1770 gcc_assert (arrayss != gfc_ss_terminator);
1772 /* Initialize the scalarizer. */
1773 gfc_init_loopinfo (&loop);
1774 gfc_add_ss_to_loop (&loop, arrayss);
1776 /* Initialize the loop. */
1777 gfc_conv_ss_startstride (&loop);
1778 gfc_conv_loop_setup (&loop);
1780 gfc_mark_ss_chain_used (arrayss, 1);
1781 /* Generate the loop body. */
1782 gfc_start_scalarized_body (&loop, &body);
1784 tmp = build2 (PLUS_EXPR, TREE_TYPE (resvar), resvar,
1785 build_int_cst (TREE_TYPE (resvar), 1));
1786 tmp = build2_v (MODIFY_EXPR, resvar, tmp);
1788 gfc_init_se (&arrayse, NULL);
1789 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1790 arrayse.ss = arrayss;
1791 gfc_conv_expr_val (&arrayse, actual->expr);
1792 tmp = build3_v (COND_EXPR, arrayse.expr, tmp, build_empty_stmt ());
1794 gfc_add_block_to_block (&body, &arrayse.pre);
1795 gfc_add_expr_to_block (&body, tmp);
1796 gfc_add_block_to_block (&body, &arrayse.post);
1798 gfc_trans_scalarizing_loops (&loop, &body);
1800 gfc_add_block_to_block (&se->pre, &loop.pre);
1801 gfc_add_block_to_block (&se->pre, &loop.post);
1802 gfc_cleanup_loop (&loop);
1807 /* Inline implementation of the sum and product intrinsics. */
1809 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, int op)
1817 gfc_actual_arglist *actual;
1822 gfc_expr *arrayexpr;
1827 gfc_conv_intrinsic_funcall (se, expr);
1831 type = gfc_typenode_for_spec (&expr->ts);
1832 /* Initialize the result. */
1833 resvar = gfc_create_var (type, "val");
1834 if (op == PLUS_EXPR)
1835 tmp = gfc_build_const (type, integer_zero_node);
1837 tmp = gfc_build_const (type, integer_one_node);
1839 gfc_add_modify_expr (&se->pre, resvar, tmp);
1841 /* Walk the arguments. */
1842 actual = expr->value.function.actual;
1843 arrayexpr = actual->expr;
1844 arrayss = gfc_walk_expr (arrayexpr);
1845 gcc_assert (arrayss != gfc_ss_terminator);
1847 actual = actual->next->next;
1848 gcc_assert (actual);
1849 maskexpr = actual->expr;
1850 if (maskexpr && maskexpr->rank != 0)
1852 maskss = gfc_walk_expr (maskexpr);
1853 gcc_assert (maskss != gfc_ss_terminator);
1858 /* Initialize the scalarizer. */
1859 gfc_init_loopinfo (&loop);
1860 gfc_add_ss_to_loop (&loop, arrayss);
1862 gfc_add_ss_to_loop (&loop, maskss);
1864 /* Initialize the loop. */
1865 gfc_conv_ss_startstride (&loop);
1866 gfc_conv_loop_setup (&loop);
1868 gfc_mark_ss_chain_used (arrayss, 1);
1870 gfc_mark_ss_chain_used (maskss, 1);
1871 /* Generate the loop body. */
1872 gfc_start_scalarized_body (&loop, &body);
1874 /* If we have a mask, only add this element if the mask is set. */
1877 gfc_init_se (&maskse, NULL);
1878 gfc_copy_loopinfo_to_se (&maskse, &loop);
1880 gfc_conv_expr_val (&maskse, maskexpr);
1881 gfc_add_block_to_block (&body, &maskse.pre);
1883 gfc_start_block (&block);
1886 gfc_init_block (&block);
1888 /* Do the actual summation/product. */
1889 gfc_init_se (&arrayse, NULL);
1890 gfc_copy_loopinfo_to_se (&arrayse, &loop);
1891 arrayse.ss = arrayss;
1892 gfc_conv_expr_val (&arrayse, arrayexpr);
1893 gfc_add_block_to_block (&block, &arrayse.pre);
1895 tmp = build2 (op, type, resvar, arrayse.expr);
1896 gfc_add_modify_expr (&block, resvar, tmp);
1897 gfc_add_block_to_block (&block, &arrayse.post);
1901 /* We enclose the above in if (mask) {...} . */
1902 tmp = gfc_finish_block (&block);
1904 tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1907 tmp = gfc_finish_block (&block);
1908 gfc_add_expr_to_block (&body, tmp);
1910 gfc_trans_scalarizing_loops (&loop, &body);
1912 /* For a scalar mask, enclose the loop in an if statement. */
1913 if (maskexpr && maskss == NULL)
1915 gfc_init_se (&maskse, NULL);
1916 gfc_conv_expr_val (&maskse, maskexpr);
1917 gfc_init_block (&block);
1918 gfc_add_block_to_block (&block, &loop.pre);
1919 gfc_add_block_to_block (&block, &loop.post);
1920 tmp = gfc_finish_block (&block);
1922 tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
1923 gfc_add_expr_to_block (&block, tmp);
1924 gfc_add_block_to_block (&se->pre, &block);
1928 gfc_add_block_to_block (&se->pre, &loop.pre);
1929 gfc_add_block_to_block (&se->pre, &loop.post);
1932 gfc_cleanup_loop (&loop);
1938 /* Inline implementation of the dot_product intrinsic. This function
1939 is based on gfc_conv_intrinsic_arith (the previous function). */
1941 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
1949 gfc_actual_arglist *actual;
1950 gfc_ss *arrayss1, *arrayss2;
1951 gfc_se arrayse1, arrayse2;
1952 gfc_expr *arrayexpr1, *arrayexpr2;
1954 type = gfc_typenode_for_spec (&expr->ts);
1956 /* Initialize the result. */
1957 resvar = gfc_create_var (type, "val");
1958 if (expr->ts.type == BT_LOGICAL)
1959 tmp = build_int_cst (type, 0);
1961 tmp = gfc_build_const (type, integer_zero_node);
1963 gfc_add_modify_expr (&se->pre, resvar, tmp);
1965 /* Walk argument #1. */
1966 actual = expr->value.function.actual;
1967 arrayexpr1 = actual->expr;
1968 arrayss1 = gfc_walk_expr (arrayexpr1);
1969 gcc_assert (arrayss1 != gfc_ss_terminator);
1971 /* Walk argument #2. */
1972 actual = actual->next;
1973 arrayexpr2 = actual->expr;
1974 arrayss2 = gfc_walk_expr (arrayexpr2);
1975 gcc_assert (arrayss2 != gfc_ss_terminator);
1977 /* Initialize the scalarizer. */
1978 gfc_init_loopinfo (&loop);
1979 gfc_add_ss_to_loop (&loop, arrayss1);
1980 gfc_add_ss_to_loop (&loop, arrayss2);
1982 /* Initialize the loop. */
1983 gfc_conv_ss_startstride (&loop);
1984 gfc_conv_loop_setup (&loop);
1986 gfc_mark_ss_chain_used (arrayss1, 1);
1987 gfc_mark_ss_chain_used (arrayss2, 1);
1989 /* Generate the loop body. */
1990 gfc_start_scalarized_body (&loop, &body);
1991 gfc_init_block (&block);
1993 /* Make the tree expression for [conjg(]array1[)]. */
1994 gfc_init_se (&arrayse1, NULL);
1995 gfc_copy_loopinfo_to_se (&arrayse1, &loop);
1996 arrayse1.ss = arrayss1;
1997 gfc_conv_expr_val (&arrayse1, arrayexpr1);
1998 if (expr->ts.type == BT_COMPLEX)
1999 arrayse1.expr = build1 (CONJ_EXPR, type, arrayse1.expr);
2000 gfc_add_block_to_block (&block, &arrayse1.pre);
2002 /* Make the tree expression for array2. */
2003 gfc_init_se (&arrayse2, NULL);
2004 gfc_copy_loopinfo_to_se (&arrayse2, &loop);
2005 arrayse2.ss = arrayss2;
2006 gfc_conv_expr_val (&arrayse2, arrayexpr2);
2007 gfc_add_block_to_block (&block, &arrayse2.pre);
2009 /* Do the actual product and sum. */
2010 if (expr->ts.type == BT_LOGICAL)
2012 tmp = build2 (TRUTH_AND_EXPR, type, arrayse1.expr, arrayse2.expr);
2013 tmp = build2 (TRUTH_OR_EXPR, type, resvar, tmp);
2017 tmp = build2 (MULT_EXPR, type, arrayse1.expr, arrayse2.expr);
2018 tmp = build2 (PLUS_EXPR, type, resvar, tmp);
2020 gfc_add_modify_expr (&block, resvar, tmp);
2022 /* Finish up the loop block and the loop. */
2023 tmp = gfc_finish_block (&block);
2024 gfc_add_expr_to_block (&body, tmp);
2026 gfc_trans_scalarizing_loops (&loop, &body);
2027 gfc_add_block_to_block (&se->pre, &loop.pre);
2028 gfc_add_block_to_block (&se->pre, &loop.post);
2029 gfc_cleanup_loop (&loop);
2036 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, int op)
2040 stmtblock_t ifblock;
2041 stmtblock_t elseblock;
2049 gfc_actual_arglist *actual;
2054 gfc_expr *arrayexpr;
2061 gfc_conv_intrinsic_funcall (se, expr);
2065 /* Initialize the result. */
2066 pos = gfc_create_var (gfc_array_index_type, "pos");
2067 offset = gfc_create_var (gfc_array_index_type, "offset");
2068 type = gfc_typenode_for_spec (&expr->ts);
2070 /* Walk the arguments. */
2071 actual = expr->value.function.actual;
2072 arrayexpr = actual->expr;
2073 arrayss = gfc_walk_expr (arrayexpr);
2074 gcc_assert (arrayss != gfc_ss_terminator);
2076 actual = actual->next->next;
2077 gcc_assert (actual);
2078 maskexpr = actual->expr;
2079 if (maskexpr && maskexpr->rank != 0)
2081 maskss = gfc_walk_expr (maskexpr);
2082 gcc_assert (maskss != gfc_ss_terminator);
2087 limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
2088 n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
2089 switch (arrayexpr->ts.type)
2092 tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, arrayexpr->ts.kind);
2096 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
2097 arrayexpr->ts.kind);
2104 /* We start with the most negative possible value for MAXLOC, and the most
2105 positive possible value for MINLOC. The most negative possible value is
2106 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2107 possible value is HUGE in both cases. */
2109 tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2110 gfc_add_modify_expr (&se->pre, limit, tmp);
2112 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2113 tmp = build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
2114 build_int_cst (type, 1));
2116 /* Initialize the scalarizer. */
2117 gfc_init_loopinfo (&loop);
2118 gfc_add_ss_to_loop (&loop, arrayss);
2120 gfc_add_ss_to_loop (&loop, maskss);
2122 /* Initialize the loop. */
2123 gfc_conv_ss_startstride (&loop);
2124 gfc_conv_loop_setup (&loop);
2126 gcc_assert (loop.dimen == 1);
2128 /* Initialize the position to zero, following Fortran 2003. We are free
2129 to do this because Fortran 95 allows the result of an entirely false
2130 mask to be processor dependent. */
2131 gfc_add_modify_expr (&loop.pre, pos, gfc_index_zero_node);
2133 gfc_mark_ss_chain_used (arrayss, 1);
2135 gfc_mark_ss_chain_used (maskss, 1);
2136 /* Generate the loop body. */
2137 gfc_start_scalarized_body (&loop, &body);
2139 /* If we have a mask, only check this element if the mask is set. */
2142 gfc_init_se (&maskse, NULL);
2143 gfc_copy_loopinfo_to_se (&maskse, &loop);
2145 gfc_conv_expr_val (&maskse, maskexpr);
2146 gfc_add_block_to_block (&body, &maskse.pre);
2148 gfc_start_block (&block);
2151 gfc_init_block (&block);
2153 /* Compare with the current limit. */
2154 gfc_init_se (&arrayse, NULL);
2155 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2156 arrayse.ss = arrayss;
2157 gfc_conv_expr_val (&arrayse, arrayexpr);
2158 gfc_add_block_to_block (&block, &arrayse.pre);
2160 /* We do the following if this is a more extreme value. */
2161 gfc_start_block (&ifblock);
2163 /* Assign the value to the limit... */
2164 gfc_add_modify_expr (&ifblock, limit, arrayse.expr);
2166 /* Remember where we are. An offset must be added to the loop
2167 counter to obtain the required position. */
2169 tmp = build_int_cst (gfc_array_index_type, 1);
2171 tmp =fold_build2 (MINUS_EXPR, gfc_array_index_type,
2172 gfc_index_one_node, loop.from[0]);
2173 gfc_add_modify_expr (&block, offset, tmp);
2175 tmp = build2 (PLUS_EXPR, TREE_TYPE (pos),
2176 loop.loopvar[0], offset);
2177 gfc_add_modify_expr (&ifblock, pos, tmp);
2179 ifbody = gfc_finish_block (&ifblock);
2181 /* If it is a more extreme value or pos is still zero and the value
2182 equal to the limit. */
2183 tmp = build2 (TRUTH_AND_EXPR, boolean_type_node,
2184 build2 (EQ_EXPR, boolean_type_node, pos, gfc_index_zero_node),
2185 build2 (EQ_EXPR, boolean_type_node, arrayse.expr, limit));
2186 tmp = build2 (TRUTH_OR_EXPR, boolean_type_node,
2187 build2 (op, boolean_type_node, arrayse.expr, limit), tmp);
2188 tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
2189 gfc_add_expr_to_block (&block, tmp);
2193 /* We enclose the above in if (mask) {...}. */
2194 tmp = gfc_finish_block (&block);
2196 tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2199 tmp = gfc_finish_block (&block);
2200 gfc_add_expr_to_block (&body, tmp);
2202 gfc_trans_scalarizing_loops (&loop, &body);
2204 /* For a scalar mask, enclose the loop in an if statement. */
2205 if (maskexpr && maskss == NULL)
2207 gfc_init_se (&maskse, NULL);
2208 gfc_conv_expr_val (&maskse, maskexpr);
2209 gfc_init_block (&block);
2210 gfc_add_block_to_block (&block, &loop.pre);
2211 gfc_add_block_to_block (&block, &loop.post);
2212 tmp = gfc_finish_block (&block);
2214 /* For the else part of the scalar mask, just initialize
2215 the pos variable the same way as above. */
2217 gfc_init_block (&elseblock);
2218 gfc_add_modify_expr (&elseblock, pos, gfc_index_zero_node);
2219 elsetmp = gfc_finish_block (&elseblock);
2221 tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
2222 gfc_add_expr_to_block (&block, tmp);
2223 gfc_add_block_to_block (&se->pre, &block);
2227 gfc_add_block_to_block (&se->pre, &loop.pre);
2228 gfc_add_block_to_block (&se->pre, &loop.post);
2230 gfc_cleanup_loop (&loop);
2232 se->expr = convert (type, pos);
2236 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, int op)
2245 gfc_actual_arglist *actual;
2250 gfc_expr *arrayexpr;
2256 gfc_conv_intrinsic_funcall (se, expr);
2260 type = gfc_typenode_for_spec (&expr->ts);
2261 /* Initialize the result. */
2262 limit = gfc_create_var (type, "limit");
2263 n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
2264 switch (expr->ts.type)
2267 tmp = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge, expr->ts.kind);
2271 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
2278 /* We start with the most negative possible value for MAXVAL, and the most
2279 positive possible value for MINVAL. The most negative possible value is
2280 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
2281 possible value is HUGE in both cases. */
2283 tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (tmp), tmp);
2285 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
2286 tmp = build2 (MINUS_EXPR, TREE_TYPE (tmp), tmp,
2287 build_int_cst (type, 1));
2289 gfc_add_modify_expr (&se->pre, limit, tmp);
2291 /* Walk the arguments. */
2292 actual = expr->value.function.actual;
2293 arrayexpr = actual->expr;
2294 arrayss = gfc_walk_expr (arrayexpr);
2295 gcc_assert (arrayss != gfc_ss_terminator);
2297 actual = actual->next->next;
2298 gcc_assert (actual);
2299 maskexpr = actual->expr;
2300 if (maskexpr && maskexpr->rank != 0)
2302 maskss = gfc_walk_expr (maskexpr);
2303 gcc_assert (maskss != gfc_ss_terminator);
2308 /* Initialize the scalarizer. */
2309 gfc_init_loopinfo (&loop);
2310 gfc_add_ss_to_loop (&loop, arrayss);
2312 gfc_add_ss_to_loop (&loop, maskss);
2314 /* Initialize the loop. */
2315 gfc_conv_ss_startstride (&loop);
2316 gfc_conv_loop_setup (&loop);
2318 gfc_mark_ss_chain_used (arrayss, 1);
2320 gfc_mark_ss_chain_used (maskss, 1);
2321 /* Generate the loop body. */
2322 gfc_start_scalarized_body (&loop, &body);
2324 /* If we have a mask, only add this element if the mask is set. */
2327 gfc_init_se (&maskse, NULL);
2328 gfc_copy_loopinfo_to_se (&maskse, &loop);
2330 gfc_conv_expr_val (&maskse, maskexpr);
2331 gfc_add_block_to_block (&body, &maskse.pre);
2333 gfc_start_block (&block);
2336 gfc_init_block (&block);
2338 /* Compare with the current limit. */
2339 gfc_init_se (&arrayse, NULL);
2340 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2341 arrayse.ss = arrayss;
2342 gfc_conv_expr_val (&arrayse, arrayexpr);
2343 gfc_add_block_to_block (&block, &arrayse.pre);
2345 /* Assign the value to the limit... */
2346 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
2348 /* If it is a more extreme value. */
2349 tmp = build2 (op, boolean_type_node, arrayse.expr, limit);
2350 tmp = build3_v (COND_EXPR, tmp, ifbody, build_empty_stmt ());
2351 gfc_add_expr_to_block (&block, tmp);
2352 gfc_add_block_to_block (&block, &arrayse.post);
2354 tmp = gfc_finish_block (&block);
2356 /* We enclose the above in if (mask) {...}. */
2357 tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2358 gfc_add_expr_to_block (&body, tmp);
2360 gfc_trans_scalarizing_loops (&loop, &body);
2362 /* For a scalar mask, enclose the loop in an if statement. */
2363 if (maskexpr && maskss == NULL)
2365 gfc_init_se (&maskse, NULL);
2366 gfc_conv_expr_val (&maskse, maskexpr);
2367 gfc_init_block (&block);
2368 gfc_add_block_to_block (&block, &loop.pre);
2369 gfc_add_block_to_block (&block, &loop.post);
2370 tmp = gfc_finish_block (&block);
2372 tmp = build3_v (COND_EXPR, maskse.expr, tmp, build_empty_stmt ());
2373 gfc_add_expr_to_block (&block, tmp);
2374 gfc_add_block_to_block (&se->pre, &block);
2378 gfc_add_block_to_block (&se->pre, &loop.pre);
2379 gfc_add_block_to_block (&se->pre, &loop.post);
2382 gfc_cleanup_loop (&loop);
2387 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
2389 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
2395 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2396 type = TREE_TYPE (args[0]);
2398 tmp = build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
2399 tmp = build2 (BIT_AND_EXPR, type, args[0], tmp);
2400 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
2401 build_int_cst (type, 0));
2402 type = gfc_typenode_for_spec (&expr->ts);
2403 se->expr = convert (type, tmp);
2406 /* Generate code to perform the specified operation. */
2408 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, int op)
2412 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2413 se->expr = fold_build2 (op, TREE_TYPE (args[0]), args[0], args[1]);
2418 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
2422 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
2423 se->expr = build1 (BIT_NOT_EXPR, TREE_TYPE (arg), arg);
2426 /* Set or clear a single bit. */
2428 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
2435 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2436 type = TREE_TYPE (args[0]);
2438 tmp = fold_build2 (LSHIFT_EXPR, type, build_int_cst (type, 1), args[1]);
2444 tmp = fold_build1 (BIT_NOT_EXPR, type, tmp);
2446 se->expr = fold_build2 (op, type, args[0], tmp);
2449 /* Extract a sequence of bits.
2450 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
2452 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
2459 gfc_conv_intrinsic_function_args (se, expr, args, 3);
2460 type = TREE_TYPE (args[0]);
2462 mask = build_int_cst (type, -1);
2463 mask = build2 (LSHIFT_EXPR, type, mask, args[2]);
2464 mask = build1 (BIT_NOT_EXPR, type, mask);
2466 tmp = build2 (RSHIFT_EXPR, type, args[0], args[1]);
2468 se->expr = fold_build2 (BIT_AND_EXPR, type, tmp, mask);
2471 /* RSHIFT (I, SHIFT) = I >> SHIFT
2472 LSHIFT (I, SHIFT) = I << SHIFT */
2474 gfc_conv_intrinsic_rlshift (gfc_se * se, gfc_expr * expr, int right_shift)
2478 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2480 se->expr = fold_build2 (right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
2481 TREE_TYPE (args[0]), args[0], args[1]);
2484 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
2486 : ((shift >= 0) ? i << shift : i >> -shift)
2487 where all shifts are logical shifts. */
2489 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
2501 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2502 type = TREE_TYPE (args[0]);
2503 utype = unsigned_type_for (type);
2505 width = fold_build1 (ABS_EXPR, TREE_TYPE (args[1]), args[1]);
2507 /* Left shift if positive. */
2508 lshift = fold_build2 (LSHIFT_EXPR, type, args[0], width);
2510 /* Right shift if negative.
2511 We convert to an unsigned type because we want a logical shift.
2512 The standard doesn't define the case of shifting negative
2513 numbers, and we try to be compatible with other compilers, most
2514 notably g77, here. */
2515 rshift = fold_convert (type, build2 (RSHIFT_EXPR, utype,
2516 convert (utype, args[0]), width));
2518 tmp = fold_build2 (GE_EXPR, boolean_type_node, args[1],
2519 build_int_cst (TREE_TYPE (args[1]), 0));
2520 tmp = fold_build3 (COND_EXPR, type, tmp, lshift, rshift);
2522 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
2523 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
2525 num_bits = build_int_cst (TREE_TYPE (args[0]), TYPE_PRECISION (type));
2526 cond = fold_build2 (GE_EXPR, boolean_type_node, width, num_bits);
2528 se->expr = fold_build3 (COND_EXPR, type, cond,
2529 build_int_cst (type, 0), tmp);
2533 /* Circular shift. AKA rotate or barrel shift. */
2536 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
2544 unsigned int num_args;
2546 num_args = gfc_intrinsic_argument_list_length (expr);
2547 args = alloca (sizeof (tree) * num_args);
2549 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2553 /* Use a library function for the 3 parameter version. */
2554 tree int4type = gfc_get_int_type (4);
2556 type = TREE_TYPE (args[0]);
2557 /* We convert the first argument to at least 4 bytes, and
2558 convert back afterwards. This removes the need for library
2559 functions for all argument sizes, and function will be
2560 aligned to at least 32 bits, so there's no loss. */
2561 if (expr->ts.kind < 4)
2562 args[0] = convert (int4type, args[0]);
2564 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
2565 need loads of library functions. They cannot have values >
2566 BIT_SIZE (I) so the conversion is safe. */
2567 args[1] = convert (int4type, args[1]);
2568 args[2] = convert (int4type, args[2]);
2570 switch (expr->ts.kind)
2575 tmp = gfor_fndecl_math_ishftc4;
2578 tmp = gfor_fndecl_math_ishftc8;
2581 tmp = gfor_fndecl_math_ishftc16;
2586 se->expr = build_call_expr (tmp, 3, args[0], args[1], args[2]);
2587 /* Convert the result back to the original type, if we extended
2588 the first argument's width above. */
2589 if (expr->ts.kind < 4)
2590 se->expr = convert (type, se->expr);
2594 type = TREE_TYPE (args[0]);
2596 /* Rotate left if positive. */
2597 lrot = fold_build2 (LROTATE_EXPR, type, args[0], args[1]);
2599 /* Rotate right if negative. */
2600 tmp = fold_build1 (NEGATE_EXPR, TREE_TYPE (args[1]), args[1]);
2601 rrot = fold_build2 (RROTATE_EXPR, type, args[0], tmp);
2603 zero = build_int_cst (TREE_TYPE (args[1]), 0);
2604 tmp = fold_build2 (GT_EXPR, boolean_type_node, args[1], zero);
2605 rrot = fold_build3 (COND_EXPR, type, tmp, lrot, rrot);
2607 /* Do nothing if shift == 0. */
2608 tmp = fold_build2 (EQ_EXPR, boolean_type_node, args[1], zero);
2609 se->expr = fold_build3 (COND_EXPR, type, tmp, args[0], rrot);
2612 /* The length of a character string. */
2614 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
2624 gcc_assert (!se->ss);
2626 arg = expr->value.function.actual->expr;
2628 type = gfc_typenode_for_spec (&expr->ts);
2629 switch (arg->expr_type)
2632 len = build_int_cst (NULL_TREE, arg->value.character.length);
2636 /* Obtain the string length from the function used by
2637 trans-array.c(gfc_trans_array_constructor). */
2639 get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
2643 if (arg->ref == NULL
2644 || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
2646 /* This doesn't catch all cases.
2647 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
2648 and the surrounding thread. */
2649 sym = arg->symtree->n.sym;
2650 decl = gfc_get_symbol_decl (sym);
2651 if (decl == current_function_decl && sym->attr.function
2652 && (sym->result == sym))
2653 decl = gfc_get_fake_result_decl (sym, 0);
2655 len = sym->ts.cl->backend_decl;
2660 /* Otherwise fall through. */
2663 /* Anybody stupid enough to do this deserves inefficient code. */
2664 ss = gfc_walk_expr (arg);
2665 gfc_init_se (&argse, se);
2666 if (ss == gfc_ss_terminator)
2667 gfc_conv_expr (&argse, arg);
2669 gfc_conv_expr_descriptor (&argse, arg, ss);
2670 gfc_add_block_to_block (&se->pre, &argse.pre);
2671 gfc_add_block_to_block (&se->post, &argse.post);
2672 len = argse.string_length;
2675 se->expr = convert (type, len);
2678 /* The length of a character string not including trailing blanks. */
2680 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
2685 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2686 type = gfc_typenode_for_spec (&expr->ts);
2687 se->expr = build_call_expr (gfor_fndecl_string_len_trim, 2, args[0], args[1]);
2688 se->expr = convert (type, se->expr);
2692 /* Returns the starting position of a substring within a string. */
2695 gfc_conv_intrinsic_index (gfc_se * se, gfc_expr * expr)
2697 tree logical4_type_node = gfc_get_logical_type (4);
2701 unsigned int num_args;
2703 num_args = gfc_intrinsic_argument_list_length (expr);
2704 args = alloca (sizeof (tree) * 5);
2706 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2707 type = gfc_typenode_for_spec (&expr->ts);
2710 args[4] = build_int_cst (logical4_type_node, 0);
2713 gcc_assert (num_args == 5);
2714 args[4] = convert (logical4_type_node, args[4]);
2717 fndecl = build_addr (gfor_fndecl_string_index, current_function_decl);
2718 se->expr = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_index)),
2720 se->expr = convert (type, se->expr);
2724 /* The ascii value for a single character. */
2726 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
2731 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2732 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
2733 args[1] = build1 (NOP_EXPR, pchar_type_node, args[1]);
2734 type = gfc_typenode_for_spec (&expr->ts);
2736 se->expr = build_fold_indirect_ref (args[1]);
2737 se->expr = convert (type, se->expr);
2741 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
2744 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
2752 unsigned int num_args;
2754 num_args = gfc_intrinsic_argument_list_length (expr);
2755 args = alloca (sizeof (tree) * num_args);
2757 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
2758 if (expr->ts.type != BT_CHARACTER)
2766 /* We do the same as in the non-character case, but the argument
2767 list is different because of the string length arguments. We
2768 also have to set the string length for the result. */
2774 se->string_length = len;
2776 type = TREE_TYPE (tsource);
2777 se->expr = fold_build3 (COND_EXPR, type, mask, tsource, fsource);
2782 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
2784 gfc_actual_arglist *actual;
2792 gfc_init_se (&argse, NULL);
2793 actual = expr->value.function.actual;
2795 ss = gfc_walk_expr (actual->expr);
2796 gcc_assert (ss != gfc_ss_terminator);
2797 argse.want_pointer = 1;
2798 argse.data_not_needed = 1;
2799 gfc_conv_expr_descriptor (&argse, actual->expr, ss);
2800 gfc_add_block_to_block (&se->pre, &argse.pre);
2801 gfc_add_block_to_block (&se->post, &argse.post);
2802 arg1 = gfc_evaluate_now (argse.expr, &se->pre);
2804 /* Build the call to size0. */
2805 fncall0 = build_call_expr (gfor_fndecl_size0, 1, arg1);
2807 actual = actual->next;
2811 gfc_init_se (&argse, NULL);
2812 gfc_conv_expr_type (&argse, actual->expr,
2813 gfc_array_index_type);
2814 gfc_add_block_to_block (&se->pre, &argse.pre);
2816 /* Build the call to size1. */
2817 fncall1 = build_call_expr (gfor_fndecl_size1, 2,
2820 /* Unusually, for an intrinsic, size does not exclude
2821 an optional arg2, so we must test for it. */
2822 if (actual->expr->expr_type == EXPR_VARIABLE
2823 && actual->expr->symtree->n.sym->attr.dummy
2824 && actual->expr->symtree->n.sym->attr.optional)
2827 gfc_init_se (&argse, NULL);
2828 argse.want_pointer = 1;
2829 argse.data_not_needed = 1;
2830 gfc_conv_expr (&argse, actual->expr);
2831 gfc_add_block_to_block (&se->pre, &argse.pre);
2832 tmp = build2 (NE_EXPR, boolean_type_node, argse.expr,
2834 tmp = gfc_evaluate_now (tmp, &se->pre);
2835 se->expr = build3 (COND_EXPR, pvoid_type_node,
2836 tmp, fncall1, fncall0);
2844 type = gfc_typenode_for_spec (&expr->ts);
2845 se->expr = convert (type, se->expr);
2850 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
2864 arg = expr->value.function.actual->expr;
2866 gfc_init_se (&argse, NULL);
2867 ss = gfc_walk_expr (arg);
2869 source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
2871 if (ss == gfc_ss_terminator)
2873 gfc_conv_expr_reference (&argse, arg);
2874 source = argse.expr;
2876 type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
2878 /* Obtain the source word length. */
2879 if (arg->ts.type == BT_CHARACTER)
2880 source_bytes = fold_convert (gfc_array_index_type,
2881 argse.string_length);
2883 source_bytes = fold_convert (gfc_array_index_type,
2884 size_in_bytes (type));
2888 argse.want_pointer = 0;
2889 gfc_conv_expr_descriptor (&argse, arg, ss);
2890 source = gfc_conv_descriptor_data_get (argse.expr);
2891 type = gfc_get_element_type (TREE_TYPE (argse.expr));
2893 /* Obtain the argument's word length. */
2894 if (arg->ts.type == BT_CHARACTER)
2895 tmp = fold_convert (gfc_array_index_type, argse.string_length);
2897 tmp = fold_convert (gfc_array_index_type,
2898 size_in_bytes (type));
2899 gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
2901 /* Obtain the size of the array in bytes. */
2902 for (n = 0; n < arg->rank; n++)
2905 idx = gfc_rank_cst[n];
2906 lower = gfc_conv_descriptor_lbound (argse.expr, idx);
2907 upper = gfc_conv_descriptor_ubound (argse.expr, idx);
2908 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2910 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2911 tmp, gfc_index_one_node);
2912 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
2914 gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
2918 gfc_add_block_to_block (&se->pre, &argse.pre);
2919 se->expr = source_bytes;
2923 /* Intrinsic string comparison functions. */
2926 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, int op)
2931 gfc_conv_intrinsic_function_args (se, expr, args, 4);
2933 se->expr = gfc_build_compare_string (args[0], args[1], args[2], args[3]);
2934 type = gfc_typenode_for_spec (&expr->ts);
2935 se->expr = fold_build2 (op, type, se->expr,
2936 build_int_cst (TREE_TYPE (se->expr), 0));
2939 /* Generate a call to the adjustl/adjustr library function. */
2941 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
2949 gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
2952 type = TREE_TYPE (args[2]);
2953 var = gfc_conv_string_tmp (se, type, len);
2956 tmp = build_call_expr (fndecl, 3, args[0], args[1], args[2]);
2957 gfc_add_expr_to_block (&se->pre, tmp);
2959 se->string_length = len;
2963 /* Array transfer statement.
2964 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
2966 typeof<DEST> = typeof<MOLD>
2968 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
2969 sizeof (DEST(0) * SIZE). */
2972 gfc_conv_intrinsic_array_transfer (gfc_se * se, gfc_expr * expr)
2987 gfc_actual_arglist *arg;
2994 gcc_assert (se->loop);
2995 info = &se->ss->data.info;
2997 /* Convert SOURCE. The output from this stage is:-
2998 source_bytes = length of the source in bytes
2999 source = pointer to the source data. */
3000 arg = expr->value.function.actual;
3001 gfc_init_se (&argse, NULL);
3002 ss = gfc_walk_expr (arg->expr);
3004 source_bytes = gfc_create_var (gfc_array_index_type, NULL);
3006 /* Obtain the pointer to source and the length of source in bytes. */
3007 if (ss == gfc_ss_terminator)
3009 gfc_conv_expr_reference (&argse, arg->expr);
3010 source = argse.expr;
3012 source_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
3014 /* Obtain the source word length. */
3015 if (arg->expr->ts.type == BT_CHARACTER)
3016 tmp = fold_convert (gfc_array_index_type, argse.string_length);
3018 tmp = fold_convert (gfc_array_index_type,
3019 size_in_bytes (source_type));
3023 argse.want_pointer = 0;
3024 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
3025 source = gfc_conv_descriptor_data_get (argse.expr);
3026 source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
3028 /* Repack the source if not a full variable array. */
3029 if (!(arg->expr->expr_type == EXPR_VARIABLE
3030 && arg->expr->ref->u.ar.type == AR_FULL))
3032 tmp = build_fold_addr_expr (argse.expr);
3033 source = build_call_expr (gfor_fndecl_in_pack, 1, tmp);
3034 source = gfc_evaluate_now (source, &argse.pre);
3036 /* Free the temporary. */
3037 gfc_start_block (&block);
3038 tmp = gfc_call_free (convert (pvoid_type_node, source));
3039 gfc_add_expr_to_block (&block, tmp);
3040 stmt = gfc_finish_block (&block);
3042 /* Clean up if it was repacked. */
3043 gfc_init_block (&block);
3044 tmp = gfc_conv_array_data (argse.expr);
3045 tmp = build2 (NE_EXPR, boolean_type_node, source, tmp);
3046 tmp = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
3047 gfc_add_expr_to_block (&block, tmp);
3048 gfc_add_block_to_block (&block, &se->post);
3049 gfc_init_block (&se->post);
3050 gfc_add_block_to_block (&se->post, &block);
3053 /* Obtain the source word length. */
3054 if (arg->expr->ts.type == BT_CHARACTER)
3055 tmp = fold_convert (gfc_array_index_type, argse.string_length);
3057 tmp = fold_convert (gfc_array_index_type,
3058 size_in_bytes (source_type));
3060 /* Obtain the size of the array in bytes. */
3061 extent = gfc_create_var (gfc_array_index_type, NULL);
3062 for (n = 0; n < arg->expr->rank; n++)
3065 idx = gfc_rank_cst[n];
3066 gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
3067 stride = gfc_conv_descriptor_stride (argse.expr, idx);
3068 lower = gfc_conv_descriptor_lbound (argse.expr, idx);
3069 upper = gfc_conv_descriptor_ubound (argse.expr, idx);
3070 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3072 gfc_add_modify_expr (&argse.pre, extent, tmp);
3073 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3074 extent, gfc_index_one_node);
3075 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3080 gfc_add_modify_expr (&argse.pre, source_bytes, tmp);
3081 gfc_add_block_to_block (&se->pre, &argse.pre);
3082 gfc_add_block_to_block (&se->post, &argse.post);
3084 /* Now convert MOLD. The outputs are:
3085 mold_type = the TREE type of MOLD
3086 dest_word_len = destination word length in bytes. */
3089 gfc_init_se (&argse, NULL);
3090 ss = gfc_walk_expr (arg->expr);
3092 if (ss == gfc_ss_terminator)
3094 gfc_conv_expr_reference (&argse, arg->expr);
3095 mold_type = TREE_TYPE (build_fold_indirect_ref (argse.expr));
3099 gfc_init_se (&argse, NULL);
3100 argse.want_pointer = 0;
3101 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
3102 mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
3105 if (arg->expr->ts.type == BT_CHARACTER)
3107 tmp = fold_convert (gfc_array_index_type, argse.string_length);
3108 mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
3111 tmp = fold_convert (gfc_array_index_type,
3112 size_in_bytes (mold_type));
3114 dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
3115 gfc_add_modify_expr (&se->pre, dest_word_len, tmp);
3117 /* Finally convert SIZE, if it is present. */
3119 size_words = gfc_create_var (gfc_array_index_type, NULL);
3123 gfc_init_se (&argse, NULL);
3124 gfc_conv_expr_reference (&argse, arg->expr);
3125 tmp = convert (gfc_array_index_type,
3126 build_fold_indirect_ref (argse.expr));
3127 gfc_add_block_to_block (&se->pre, &argse.pre);
3128 gfc_add_block_to_block (&se->post, &argse.post);
3133 size_bytes = gfc_create_var (gfc_array_index_type, NULL);
3134 if (tmp != NULL_TREE)
3136 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
3137 tmp, dest_word_len);
3138 tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
3144 gfc_add_modify_expr (&se->pre, size_bytes, tmp);
3145 gfc_add_modify_expr (&se->pre, size_words,
3146 fold_build2 (CEIL_DIV_EXPR, gfc_array_index_type,
3147 size_bytes, dest_word_len));
3149 /* Evaluate the bounds of the result. If the loop range exists, we have
3150 to check if it is too large. If so, we modify loop->to be consistent
3151 with min(size, size(source)). Otherwise, size is made consistent with
3152 the loop range, so that the right number of bytes is transferred.*/
3153 n = se->loop->order[0];
3154 if (se->loop->to[n] != NULL_TREE)
3156 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3157 se->loop->to[n], se->loop->from[n]);
3158 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3159 tmp, gfc_index_one_node);
3160 tmp = fold_build2 (MIN_EXPR, gfc_array_index_type,
3162 gfc_add_modify_expr (&se->pre, size_words, tmp);
3163 gfc_add_modify_expr (&se->pre, size_bytes,
3164 fold_build2 (MULT_EXPR, gfc_array_index_type,
3165 size_words, dest_word_len));
3166 upper = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3167 size_words, se->loop->from[n]);
3168 upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3169 upper, gfc_index_one_node);
3173 upper = fold_build2 (MINUS_EXPR, gfc_array_index_type,
3174 size_words, gfc_index_one_node);
3175 se->loop->from[n] = gfc_index_zero_node;
3178 se->loop->to[n] = upper;
3180 /* Build a destination descriptor, using the pointer, source, as the
3181 data field. This is already allocated so set callee_alloc.
3182 FIXME callee_alloc is not set! */
3184 gfc_trans_create_temp_array (&se->pre, &se->post, se->loop,
3185 info, mold_type, false, true, false);
3187 /* Cast the pointer to the result. */
3188 tmp = gfc_conv_descriptor_data_get (info->descriptor);
3189 tmp = fold_convert (pvoid_type_node, tmp);
3191 /* Use memcpy to do the transfer. */
3192 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY],
3195 fold_convert (pvoid_type_node, source),
3197 gfc_add_expr_to_block (&se->pre, tmp);
3199 se->expr = info->descriptor;
3200 if (expr->ts.type == BT_CHARACTER)
3201 se->string_length = dest_word_len;
3205 /* Scalar transfer statement.
3206 TRANSFER (source, mold) = memcpy(&tmpdecl, &source, size), tmpdecl. */
3209 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
3211 gfc_actual_arglist *arg;
3218 /* Get a pointer to the source. */
3219 arg = expr->value.function.actual;
3220 ss = gfc_walk_expr (arg->expr);
3221 gfc_init_se (&argse, NULL);
3222 if (ss == gfc_ss_terminator)
3223 gfc_conv_expr_reference (&argse, arg->expr);
3225 gfc_conv_array_parameter (&argse, arg->expr, ss, 1);
3226 gfc_add_block_to_block (&se->pre, &argse.pre);
3227 gfc_add_block_to_block (&se->post, &argse.post);
3231 type = gfc_typenode_for_spec (&expr->ts);
3233 if (expr->ts.type == BT_CHARACTER)
3235 ptr = convert (build_pointer_type (type), ptr);
3236 gfc_init_se (&argse, NULL);
3237 gfc_conv_expr (&argse, arg->expr);
3238 gfc_add_block_to_block (&se->pre, &argse.pre);
3239 gfc_add_block_to_block (&se->post, &argse.post);
3241 se->string_length = argse.string_length;
3246 tmpdecl = gfc_create_var (type, "transfer");
3247 moldsize = size_in_bytes (type);
3249 /* Use memcpy to do the transfer. */
3250 tmp = build1 (ADDR_EXPR, build_pointer_type (type), tmpdecl);
3251 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
3252 fold_convert (pvoid_type_node, tmp),
3253 fold_convert (pvoid_type_node, ptr),
3255 gfc_add_expr_to_block (&se->pre, tmp);
3262 /* Generate code for the ALLOCATED intrinsic.
3263 Generate inline code that directly check the address of the argument. */
3266 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
3268 gfc_actual_arglist *arg1;
3273 gfc_init_se (&arg1se, NULL);
3274 arg1 = expr->value.function.actual;
3275 ss1 = gfc_walk_expr (arg1->expr);
3276 arg1se.descriptor_only = 1;
3277 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3279 tmp = gfc_conv_descriptor_data_get (arg1se.expr);
3280 tmp = build2 (NE_EXPR, boolean_type_node, tmp,
3281 fold_convert (TREE_TYPE (tmp), null_pointer_node));
3282 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
3286 /* Generate code for the ASSOCIATED intrinsic.
3287 If both POINTER and TARGET are arrays, generate a call to library function
3288 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
3289 In other cases, generate inline code that directly compare the address of
3290 POINTER with the address of TARGET. */
3293 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
3295 gfc_actual_arglist *arg1;
3296 gfc_actual_arglist *arg2;
3302 tree nonzero_charlen;
3303 tree nonzero_arraylen;
3306 gfc_init_se (&arg1se, NULL);
3307 gfc_init_se (&arg2se, NULL);
3308 arg1 = expr->value.function.actual;
3310 ss1 = gfc_walk_expr (arg1->expr);
3314 /* No optional target. */
3315 if (ss1 == gfc_ss_terminator)
3317 /* A pointer to a scalar. */
3318 arg1se.want_pointer = 1;
3319 gfc_conv_expr (&arg1se, arg1->expr);
3324 /* A pointer to an array. */
3325 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3326 tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
3328 gfc_add_block_to_block (&se->pre, &arg1se.pre);
3329 gfc_add_block_to_block (&se->post, &arg1se.post);
3330 tmp = build2 (NE_EXPR, boolean_type_node, tmp2,
3331 fold_convert (TREE_TYPE (tmp2), null_pointer_node));
3336 /* An optional target. */
3337 ss2 = gfc_walk_expr (arg2->expr);
3339 nonzero_charlen = NULL_TREE;
3340 if (arg1->expr->ts.type == BT_CHARACTER)
3341 nonzero_charlen = build2 (NE_EXPR, boolean_type_node,
3342 arg1->expr->ts.cl->backend_decl,
3345 if (ss1 == gfc_ss_terminator)
3347 /* A pointer to a scalar. */
3348 gcc_assert (ss2 == gfc_ss_terminator);
3349 arg1se.want_pointer = 1;
3350 gfc_conv_expr (&arg1se, arg1->expr);
3351 arg2se.want_pointer = 1;
3352 gfc_conv_expr (&arg2se, arg2->expr);
3353 gfc_add_block_to_block (&se->pre, &arg1se.pre);
3354 gfc_add_block_to_block (&se->post, &arg1se.post);
3355 tmp = build2 (EQ_EXPR, boolean_type_node, arg1se.expr, arg2se.expr);
3356 tmp2 = build2 (NE_EXPR, boolean_type_node, arg1se.expr,
3358 se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node, tmp, tmp2);
3363 /* An array pointer of zero length is not associated if target is
3365 arg1se.descriptor_only = 1;
3366 gfc_conv_expr_lhs (&arg1se, arg1->expr);
3367 tmp = gfc_conv_descriptor_stride (arg1se.expr,
3368 gfc_rank_cst[arg1->expr->rank - 1]);
3369 nonzero_arraylen = build2 (NE_EXPR, boolean_type_node,
3370 tmp, build_int_cst (TREE_TYPE (tmp), 0));
3372 /* A pointer to an array, call library function _gfor_associated. */
3373 gcc_assert (ss2 != gfc_ss_terminator);
3374 arg1se.want_pointer = 1;
3375 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
3377 arg2se.want_pointer = 1;
3378 gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
3379 gfc_add_block_to_block (&se->pre, &arg2se.pre);
3380 gfc_add_block_to_block (&se->post, &arg2se.post);
3381 fndecl = gfor_fndecl_associated;
3382 se->expr = build_call_expr (fndecl, 2, arg1se.expr, arg2se.expr);
3383 se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
3384 se->expr, nonzero_arraylen);
3388 /* If target is present zero character length pointers cannot
3390 if (nonzero_charlen != NULL_TREE)
3391 se->expr = build2 (TRUTH_AND_EXPR, boolean_type_node,
3392 se->expr, nonzero_charlen);
3395 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
3399 /* Scan a string for any one of the characters in a set of characters. */
3402 gfc_conv_intrinsic_scan (gfc_se * se, gfc_expr * expr)
3404 tree logical4_type_node = gfc_get_logical_type (4);
3408 unsigned int num_args;
3410 num_args = gfc_intrinsic_argument_list_length (expr);
3411 args = alloca (sizeof (tree) * 5);
3413 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3414 type = gfc_typenode_for_spec (&expr->ts);
3417 args[4] = build_int_cst (logical4_type_node, 0);
3420 gcc_assert (num_args == 5);
3421 args[4] = convert (logical4_type_node, args[4]);
3424 fndecl = build_addr (gfor_fndecl_string_scan, current_function_decl);
3425 se->expr = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_scan)),
3427 se->expr = convert (type, se->expr);
3431 /* Verify that a set of characters contains all the characters in a string
3432 by identifying the position of the first character in a string of
3433 characters that does not appear in a given set of characters. */
3436 gfc_conv_intrinsic_verify (gfc_se * se, gfc_expr * expr)
3438 tree logical4_type_node = gfc_get_logical_type (4);
3442 unsigned int num_args;
3444 num_args = gfc_intrinsic_argument_list_length (expr);
3445 args = alloca (sizeof (tree) * 5);
3447 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
3448 type = gfc_typenode_for_spec (&expr->ts);
3451 args[4] = build_int_cst (logical4_type_node, 0);
3454 gcc_assert (num_args == 5);
3455 args[4] = convert (logical4_type_node, args[4]);
3458 fndecl = build_addr (gfor_fndecl_string_verify, current_function_decl);
3459 se->expr = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_verify)),
3462 se->expr = convert (type, se->expr);
3466 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
3469 gfc_conv_intrinsic_si_kind (gfc_se * se, gfc_expr * expr)
3473 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3474 arg = build_fold_addr_expr (arg);
3475 se->expr = build_call_expr (gfor_fndecl_si_kind, 1, arg);
3478 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
3481 gfc_conv_intrinsic_sr_kind (gfc_se * se, gfc_expr * expr)
3483 gfc_actual_arglist *actual;
3488 for (actual = expr->value.function.actual; actual; actual = actual->next)
3490 gfc_init_se (&argse, se);
3492 /* Pass a NULL pointer for an absent arg. */
3493 if (actual->expr == NULL)
3494 argse.expr = null_pointer_node;
3496 gfc_conv_expr_reference (&argse, actual->expr);
3498 gfc_add_block_to_block (&se->pre, &argse.pre);
3499 gfc_add_block_to_block (&se->post, &argse.post);
3500 args = gfc_chainon_list (args, argse.expr);
3502 se->expr = build_function_call_expr (gfor_fndecl_sr_kind, args);
3506 /* Generate code for TRIM (A) intrinsic function. */
3509 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
3511 tree gfc_int4_type_node = gfc_get_int_type (4);
3520 unsigned int num_args;
3522 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
3523 args = alloca (sizeof (tree) * num_args);
3525 type = build_pointer_type (gfc_character1_type_node);
3526 var = gfc_create_var (type, "pstr");
3527 addr = gfc_build_addr_expr (ppvoid_type_node, var);
3528 len = gfc_create_var (gfc_int4_type_node, "len");
3530 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
3531 args[0] = build_fold_addr_expr (len);
3534 fndecl = build_addr (gfor_fndecl_string_trim, current_function_decl);
3535 tmp = build_call_array (TREE_TYPE (TREE_TYPE (gfor_fndecl_string_trim)),
3536 fndecl, num_args, args);
3537 gfc_add_expr_to_block (&se->pre, tmp);
3539 /* Free the temporary afterwards, if necessary. */
3540 cond = build2 (GT_EXPR, boolean_type_node, len,
3541 build_int_cst (TREE_TYPE (len), 0));
3542 tmp = gfc_call_free (var);
3543 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
3544 gfc_add_expr_to_block (&se->post, tmp);
3547 se->string_length = len;
3551 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
3554 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
3556 tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
3557 tree type, cond, tmp, count, exit_label, n, max, largest;
3558 stmtblock_t block, body;
3561 /* Get the arguments. */
3562 gfc_conv_intrinsic_function_args (se, expr, args, 3);
3563 slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
3565 ncopies = gfc_evaluate_now (args[2], &se->pre);
3566 ncopies_type = TREE_TYPE (ncopies);
3568 /* Check that NCOPIES is not negative. */
3569 cond = fold_build2 (LT_EXPR, boolean_type_node, ncopies,
3570 build_int_cst (ncopies_type, 0));
3571 gfc_trans_runtime_check (cond,
3572 "Argument NCOPIES of REPEAT intrinsic is negative",
3573 &se->pre, &expr->where);
3575 /* If the source length is zero, any non negative value of NCOPIES
3576 is valid, and nothing happens. */
3577 n = gfc_create_var (ncopies_type, "ncopies");
3578 cond = fold_build2 (EQ_EXPR, boolean_type_node, slen,
3579 build_int_cst (size_type_node, 0));
3580 tmp = fold_build3 (COND_EXPR, ncopies_type, cond,
3581 build_int_cst (ncopies_type, 0), ncopies);
3582 gfc_add_modify_expr (&se->pre, n, tmp);
3585 /* Check that ncopies is not too large: ncopies should be less than
3586 (or equal to) MAX / slen, where MAX is the maximal integer of
3587 the gfc_charlen_type_node type. If slen == 0, we need a special
3588 case to avoid the division by zero. */
3589 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
3590 max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
3591 max = fold_build2 (TRUNC_DIV_EXPR, size_type_node,
3592 fold_convert (size_type_node, max), slen);
3593 largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
3594 ? size_type_node : ncopies_type;
3595 cond = fold_build2 (GT_EXPR, boolean_type_node,
3596 fold_convert (largest, ncopies),
3597 fold_convert (largest, max));
3598 tmp = fold_build2 (EQ_EXPR, boolean_type_node, slen,
3599 build_int_cst (size_type_node, 0));
3600 cond = fold_build3 (COND_EXPR, boolean_type_node, tmp, boolean_false_node,
3602 gfc_trans_runtime_check (cond,
3603 "Argument NCOPIES of REPEAT intrinsic is too large",
3604 &se->pre, &expr->where);
3606 /* Compute the destination length. */
3607 dlen = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
3608 fold_convert (gfc_charlen_type_node, slen),
3609 fold_convert (gfc_charlen_type_node, ncopies));
3610 type = gfc_get_character_type (expr->ts.kind, expr->ts.cl);
3611 dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
3613 /* Generate the code to do the repeat operation:
3614 for (i = 0; i < ncopies; i++)
3615 memmove (dest + (i * slen), src, slen); */
3616 gfc_start_block (&block);
3617 count = gfc_create_var (ncopies_type, "count");
3618 gfc_add_modify_expr (&block, count, build_int_cst (ncopies_type, 0));
3619 exit_label = gfc_build_label_decl (NULL_TREE);
3621 /* Start the loop body. */
3622 gfc_start_block (&body);
3624 /* Exit the loop if count >= ncopies. */
3625 cond = fold_build2 (GE_EXPR, boolean_type_node, count, ncopies);
3626 tmp = build1_v (GOTO_EXPR, exit_label);
3627 TREE_USED (exit_label) = 1;
3628 tmp = fold_build3 (COND_EXPR, void_type_node, cond, tmp,
3629 build_empty_stmt ());
3630 gfc_add_expr_to_block (&body, tmp);
3632 /* Call memmove (dest + (i*slen), src, slen). */
3633 tmp = fold_build2 (MULT_EXPR, gfc_charlen_type_node,
3634 fold_convert (gfc_charlen_type_node, slen),
3635 fold_convert (gfc_charlen_type_node, count));
3636 tmp = fold_build2 (POINTER_PLUS_EXPR, pchar_type_node,
3637 fold_convert (pchar_type_node, dest),
3638 fold_convert (sizetype, tmp));
3639 tmp = build_call_expr (built_in_decls[BUILT_IN_MEMMOVE], 3,
3641 gfc_add_expr_to_block (&body, tmp);
3643 /* Increment count. */
3644 tmp = build2 (PLUS_EXPR, ncopies_type, count,
3645 build_int_cst (TREE_TYPE (count), 1));
3646 gfc_add_modify_expr (&body, count, tmp);
3648 /* Build the loop. */
3649 tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
3650 gfc_add_expr_to_block (&block, tmp);
3652 /* Add the exit label. */
3653 tmp = build1_v (LABEL_EXPR, exit_label);
3654 gfc_add_expr_to_block (&block, tmp);
3656 /* Finish the block. */
3657 tmp = gfc_finish_block (&block);
3658 gfc_add_expr_to_block (&se->pre, tmp);
3660 /* Set the result value. */
3662 se->string_length = dlen;
3666 /* Generate code for the IARGC intrinsic. */
3669 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
3675 /* Call the library function. This always returns an INTEGER(4). */
3676 fndecl = gfor_fndecl_iargc;
3677 tmp = build_call_expr (fndecl, 0);
3679 /* Convert it to the required type. */
3680 type = gfc_typenode_for_spec (&expr->ts);
3681 tmp = fold_convert (type, tmp);
3687 /* The loc intrinsic returns the address of its argument as
3688 gfc_index_integer_kind integer. */
3691 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
3697 gcc_assert (!se->ss);
3699 arg_expr = expr->value.function.actual->expr;
3700 ss = gfc_walk_expr (arg_expr);
3701 if (ss == gfc_ss_terminator)
3702 gfc_conv_expr_reference (se, arg_expr);
3704 gfc_conv_array_parameter (se, arg_expr, ss, 1);
3705 se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
3707 /* Create a temporary variable for loc return value. Without this,
3708 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
3709 temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
3710 gfc_add_modify_expr (&se->pre, temp_var, se->expr);
3711 se->expr = temp_var;
3714 /* Generate code for an intrinsic function. Some map directly to library
3715 calls, others get special handling. In some cases the name of the function
3716 used depends on the type specifiers. */
3719 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
3721 gfc_intrinsic_sym *isym;
3725 isym = expr->value.function.isym;
3727 name = &expr->value.function.name[2];
3729 if (expr->rank > 0 && !expr->inline_noncopying_intrinsic)
3731 lib = gfc_is_intrinsic_libcall (expr);
3735 se->ignore_optional = 1;
3736 gfc_conv_intrinsic_funcall (se, expr);
3741 switch (expr->value.function.isym->id)
3746 case GFC_ISYM_REPEAT:
3747 gfc_conv_intrinsic_repeat (se, expr);
3751 gfc_conv_intrinsic_trim (se, expr);
3754 case GFC_ISYM_SI_KIND:
3755 gfc_conv_intrinsic_si_kind (se, expr);
3758 case GFC_ISYM_SR_KIND:
3759 gfc_conv_intrinsic_sr_kind (se, expr);
3762 case GFC_ISYM_EXPONENT:
3763 gfc_conv_intrinsic_exponent (se, expr);
3767 gfc_conv_intrinsic_scan (se, expr);
3770 case GFC_ISYM_VERIFY:
3771 gfc_conv_intrinsic_verify (se, expr);
3774 case GFC_ISYM_ALLOCATED:
3775 gfc_conv_allocated (se, expr);
3778 case GFC_ISYM_ASSOCIATED:
3779 gfc_conv_associated(se, expr);
3783 gfc_conv_intrinsic_abs (se, expr);
3786 case GFC_ISYM_ADJUSTL:
3787 gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustl);
3790 case GFC_ISYM_ADJUSTR:
3791 gfc_conv_intrinsic_adjust (se, expr, gfor_fndecl_adjustr);
3794 case GFC_ISYM_AIMAG:
3795 gfc_conv_intrinsic_imagpart (se, expr);
3799 gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
3803 gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
3806 case GFC_ISYM_ANINT:
3807 gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
3811 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3815 gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
3818 case GFC_ISYM_BTEST:
3819 gfc_conv_intrinsic_btest (se, expr);
3822 case GFC_ISYM_ACHAR:
3824 gfc_conv_intrinsic_char (se, expr);
3827 case GFC_ISYM_CONVERSION:
3829 case GFC_ISYM_LOGICAL:
3831 gfc_conv_intrinsic_conversion (se, expr);
3834 /* Integer conversions are handled separately to make sure we get the
3835 correct rounding mode. */
3840 gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
3844 gfc_conv_intrinsic_int (se, expr, RND_ROUND);
3847 case GFC_ISYM_CEILING:
3848 gfc_conv_intrinsic_int (se, expr, RND_CEIL);
3851 case GFC_ISYM_FLOOR:
3852 gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
3856 gfc_conv_intrinsic_mod (se, expr, 0);
3859 case GFC_ISYM_MODULO:
3860 gfc_conv_intrinsic_mod (se, expr, 1);
3863 case GFC_ISYM_CMPLX:
3864 gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
3867 case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
3868 gfc_conv_intrinsic_iargc (se, expr);
3871 case GFC_ISYM_COMPLEX:
3872 gfc_conv_intrinsic_cmplx (se, expr, 1);
3875 case GFC_ISYM_CONJG:
3876 gfc_conv_intrinsic_conjg (se, expr);
3879 case GFC_ISYM_COUNT:
3880 gfc_conv_intrinsic_count (se, expr);
3883 case GFC_ISYM_CTIME:
3884 gfc_conv_intrinsic_ctime (se, expr);
3888 gfc_conv_intrinsic_dim (se, expr);
3891 case GFC_ISYM_DOT_PRODUCT:
3892 gfc_conv_intrinsic_dot_product (se, expr);
3895 case GFC_ISYM_DPROD:
3896 gfc_conv_intrinsic_dprod (se, expr);
3899 case GFC_ISYM_FDATE:
3900 gfc_conv_intrinsic_fdate (se, expr);
3904 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
3907 case GFC_ISYM_IBCLR:
3908 gfc_conv_intrinsic_singlebitop (se, expr, 0);
3911 case GFC_ISYM_IBITS:
3912 gfc_conv_intrinsic_ibits (se, expr);
3915 case GFC_ISYM_IBSET:
3916 gfc_conv_intrinsic_singlebitop (se, expr, 1);
3919 case GFC_ISYM_IACHAR:
3920 case GFC_ISYM_ICHAR:
3921 /* We assume ASCII character sequence. */
3922 gfc_conv_intrinsic_ichar (se, expr);
3925 case GFC_ISYM_IARGC:
3926 gfc_conv_intrinsic_iargc (se, expr);
3930 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
3933 case GFC_ISYM_INDEX:
3934 gfc_conv_intrinsic_index (se, expr);
3938 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
3941 case GFC_ISYM_LSHIFT:
3942 gfc_conv_intrinsic_rlshift (se, expr, 0);
3945 case GFC_ISYM_RSHIFT:
3946 gfc_conv_intrinsic_rlshift (se, expr, 1);
3949 case GFC_ISYM_ISHFT:
3950 gfc_conv_intrinsic_ishft (se, expr);
3953 case GFC_ISYM_ISHFTC:
3954 gfc_conv_intrinsic_ishftc (se, expr);
3957 case GFC_ISYM_LBOUND:
3958 gfc_conv_intrinsic_bound (se, expr, 0);
3961 case GFC_ISYM_TRANSPOSE:
3962 if (se->ss && se->ss->useflags)
3964 gfc_conv_tmp_array_ref (se);
3965 gfc_advance_se_ss_chain (se);
3968 gfc_conv_array_transpose (se, expr->value.function.actual->expr);
3972 gfc_conv_intrinsic_len (se, expr);
3975 case GFC_ISYM_LEN_TRIM:
3976 gfc_conv_intrinsic_len_trim (se, expr);
3980 gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
3984 gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
3988 gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
3992 gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
3996 gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
3999 case GFC_ISYM_MAXLOC:
4000 gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
4003 case GFC_ISYM_MAXVAL:
4004 gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
4007 case GFC_ISYM_MERGE:
4008 gfc_conv_intrinsic_merge (se, expr);
4012 gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
4015 case GFC_ISYM_MINLOC:
4016 gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
4019 case GFC_ISYM_MINVAL:
4020 gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
4024 gfc_conv_intrinsic_not (se, expr);
4028 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
4031 case GFC_ISYM_PRESENT:
4032 gfc_conv_intrinsic_present (se, expr);
4035 case GFC_ISYM_PRODUCT:
4036 gfc_conv_intrinsic_arith (se, expr, MULT_EXPR);
4040 gfc_conv_intrinsic_sign (se, expr);
4044 gfc_conv_intrinsic_size (se, expr);
4047 case GFC_ISYM_SIZEOF:
4048 gfc_conv_intrinsic_sizeof (se, expr);
4052 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR);
4055 case GFC_ISYM_TRANSFER:
4058 if (se->ss->useflags)
4060 /* Access the previously obtained result. */
4061 gfc_conv_tmp_array_ref (se);
4062 gfc_advance_se_ss_chain (se);
4066 gfc_conv_intrinsic_array_transfer (se, expr);
4069 gfc_conv_intrinsic_transfer (se, expr);
4072 case GFC_ISYM_TTYNAM:
4073 gfc_conv_intrinsic_ttynam (se, expr);
4076 case GFC_ISYM_UBOUND:
4077 gfc_conv_intrinsic_bound (se, expr, 1);
4081 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
4085 gfc_conv_intrinsic_loc (se, expr);
4088 case GFC_ISYM_ACCESS:
4089 case GFC_ISYM_CHDIR:
4090 case GFC_ISYM_CHMOD:
4091 case GFC_ISYM_ETIME:
4093 case GFC_ISYM_FGETC:
4096 case GFC_ISYM_FPUTC:
4097 case GFC_ISYM_FSTAT:
4098 case GFC_ISYM_FTELL:
4099 case GFC_ISYM_GETCWD:
4100 case GFC_ISYM_GETGID:
4101 case GFC_ISYM_GETPID:
4102 case GFC_ISYM_GETUID:
4103 case GFC_ISYM_HOSTNM:
4105 case GFC_ISYM_IERRNO:
4106 case GFC_ISYM_IRAND:
4107 case GFC_ISYM_ISATTY:
4109 case GFC_ISYM_LSTAT:
4110 case GFC_ISYM_MALLOC:
4111 case GFC_ISYM_MATMUL:
4112 case GFC_ISYM_MCLOCK:
4113 case GFC_ISYM_MCLOCK8:
4115 case GFC_ISYM_RENAME:
4116 case GFC_ISYM_SECOND:
4117 case GFC_ISYM_SECNDS:
4118 case GFC_ISYM_SIGNAL:
4120 case GFC_ISYM_SYMLNK:
4121 case GFC_ISYM_SYSTEM:
4123 case GFC_ISYM_TIME8:
4124 case GFC_ISYM_UMASK:
4125 case GFC_ISYM_UNLINK:
4126 gfc_conv_intrinsic_funcall (se, expr);
4130 gfc_conv_intrinsic_lib_function (se, expr);
4136 /* This generates code to execute before entering the scalarization loop.
4137 Currently does nothing. */
4140 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
4142 switch (ss->expr->value.function.isym->id)
4144 case GFC_ISYM_UBOUND:
4145 case GFC_ISYM_LBOUND:
4154 /* UBOUND and LBOUND intrinsics with one parameter are expanded into code
4155 inside the scalarization loop. */
4158 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
4162 /* The two argument version returns a scalar. */
4163 if (expr->value.function.actual->next->expr)
4166 newss = gfc_get_ss ();
4167 newss->type = GFC_SS_INTRINSIC;
4170 newss->data.info.dimen = 1;
4176 /* Walk an intrinsic array libcall. */
4179 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
4183 gcc_assert (expr->rank > 0);
4185 newss = gfc_get_ss ();
4186 newss->type = GFC_SS_FUNCTION;
4189 newss->data.info.dimen = expr->rank;
4195 /* Returns nonzero if the specified intrinsic function call maps directly to a
4196 an external library call. Should only be used for functions that return
4200 gfc_is_intrinsic_libcall (gfc_expr * expr)
4202 gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
4203 gcc_assert (expr->rank > 0);
4205 switch (expr->value.function.isym->id)
4209 case GFC_ISYM_COUNT:
4210 case GFC_ISYM_MATMUL:
4211 case GFC_ISYM_MAXLOC:
4212 case GFC_ISYM_MAXVAL:
4213 case GFC_ISYM_MINLOC:
4214 case GFC_ISYM_MINVAL:
4215 case GFC_ISYM_PRODUCT:
4217 case GFC_ISYM_SHAPE:
4218 case GFC_ISYM_SPREAD:
4219 case GFC_ISYM_TRANSPOSE:
4220 /* Ignore absent optional parameters. */
4223 case GFC_ISYM_RESHAPE:
4224 case GFC_ISYM_CSHIFT:
4225 case GFC_ISYM_EOSHIFT:
4227 case GFC_ISYM_UNPACK:
4228 /* Pass absent optional parameters. */
4236 /* Walk an intrinsic function. */
4238 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
4239 gfc_intrinsic_sym * isym)
4243 if (isym->elemental)
4244 return gfc_walk_elemental_function_args (ss, expr->value.function.actual, GFC_SS_SCALAR);
4246 if (expr->rank == 0)
4249 if (gfc_is_intrinsic_libcall (expr))
4250 return gfc_walk_intrinsic_libfunc (ss, expr);
4252 /* Special cases. */
4255 case GFC_ISYM_LBOUND:
4256 case GFC_ISYM_UBOUND:
4257 return gfc_walk_intrinsic_bound (ss, expr);
4259 case GFC_ISYM_TRANSFER:
4260 return gfc_walk_intrinsic_libfunc (ss, expr);
4263 /* This probably meant someone forgot to add an intrinsic to the above
4264 list(s) when they implemented it, or something's gone horribly wrong.
4266 gfc_todo_error ("Scalarization of non-elemental intrinsic: %s",
4267 expr->value.function.name);
4271 #include "gt-fortran-trans-intrinsic.h"