1 /* Intrinsic translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010,
4 Free Software Foundation, Inc.
5 Contributed by Paul Brook <paul@nowt.org>
6 and Steven Bosscher <s.bosscher@student.tudelft.nl>
8 This file is part of GCC.
10 GCC is free software; you can redistribute it and/or modify it under
11 the terms of the GNU General Public License as published by the Free
12 Software Foundation; either version 3, or (at your option) any later
15 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
16 WARRANTY; without even the implied warranty of MERCHANTABILITY or
17 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
20 You should have received a copy of the GNU General Public License
21 along with GCC; see the file COPYING3. If not see
22 <http://www.gnu.org/licenses/>. */
24 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
28 #include "coretypes.h"
29 #include "tm.h" /* For UNITS_PER_WORD. */
32 #include "diagnostic-core.h" /* For internal_error. */
33 #include "toplev.h" /* For rest_of_decl_compilation. */
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 GTY(()) gfc_intrinsic_map_t {
49 /* The explicit enum is required to work around inadequacies in the
50 garbage collection/gengtype parsing mechanism. */
53 /* Enum value from the "language-independent", aka C-centric, part
54 of gcc, or END_BUILTINS of no such value set. */
55 enum built_in_function float_built_in;
56 enum built_in_function double_built_in;
57 enum built_in_function long_double_built_in;
58 enum built_in_function complex_float_built_in;
59 enum built_in_function complex_double_built_in;
60 enum built_in_function complex_long_double_built_in;
62 /* True if the naming pattern is to prepend "c" for complex and
63 append "f" for kind=4. False if the naming pattern is to
64 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
67 /* True if a complex version of the function exists. */
68 bool complex_available;
70 /* True if the function should be marked const. */
73 /* The base library name of this function. */
76 /* Cache decls created for the various operand types. */
88 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
89 defines complex variants of all of the entries in mathbuiltins.def
91 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
92 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
93 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
94 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
95 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
97 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
98 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
99 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
100 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
101 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
103 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
104 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
105 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
106 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
107 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
109 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
110 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
111 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
112 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
113 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
115 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
117 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
118 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
119 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
120 #include "mathbuiltins.def"
122 /* Functions in libgfortran. */
123 LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false),
126 LIB_FUNCTION (NONE, NULL, false)
131 #undef DEFINE_MATH_BUILTIN
132 #undef DEFINE_MATH_BUILTIN_C
135 enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
138 /* Find the correct variant of a given builtin from its argument. */
140 builtin_decl_for_precision (enum built_in_function base_built_in,
143 enum built_in_function i = END_BUILTINS;
145 gfc_intrinsic_map_t *m;
146 for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++)
149 if (precision == TYPE_PRECISION (float_type_node))
150 i = m->float_built_in;
151 else if (precision == TYPE_PRECISION (double_type_node))
152 i = m->double_built_in;
153 else if (precision == TYPE_PRECISION (long_double_type_node))
154 i = m->long_double_built_in;
155 else if (precision == TYPE_PRECISION (float128_type_node))
157 /* Special treatment, because it is not exactly a built-in, but
158 a library function. */
159 return m->real16_decl;
162 return (i == END_BUILTINS ? NULL_TREE : builtin_decl_explicit (i));
167 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in,
170 int i = gfc_validate_kind (BT_REAL, kind, false);
172 if (gfc_real_kinds[i].c_float128)
174 /* For __float128, the story is a bit different, because we return
175 a decl to a library function rather than a built-in. */
176 gfc_intrinsic_map_t *m;
177 for (m = gfc_intrinsic_map; m->double_built_in != double_built_in ; m++)
180 return m->real16_decl;
183 return builtin_decl_for_precision (double_built_in,
184 gfc_real_kinds[i].mode_precision);
188 /* Evaluate the arguments to an intrinsic function. The value
189 of NARGS may be less than the actual number of arguments in EXPR
190 to allow optional "KIND" arguments that are not included in the
191 generated code to be ignored. */
194 gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
195 tree *argarray, int nargs)
197 gfc_actual_arglist *actual;
199 gfc_intrinsic_arg *formal;
203 formal = expr->value.function.isym->formal;
204 actual = expr->value.function.actual;
206 for (curr_arg = 0; curr_arg < nargs; curr_arg++,
207 actual = actual->next,
208 formal = formal ? formal->next : NULL)
212 /* Skip omitted optional arguments. */
219 /* Evaluate the parameter. This will substitute scalarized
220 references automatically. */
221 gfc_init_se (&argse, se);
223 if (e->ts.type == BT_CHARACTER)
225 gfc_conv_expr (&argse, e);
226 gfc_conv_string_parameter (&argse);
227 argarray[curr_arg++] = argse.string_length;
228 gcc_assert (curr_arg < nargs);
231 gfc_conv_expr_val (&argse, e);
233 /* If an optional argument is itself an optional dummy argument,
234 check its presence and substitute a null if absent. */
235 if (e->expr_type == EXPR_VARIABLE
236 && e->symtree->n.sym->attr.optional
239 gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
241 gfc_add_block_to_block (&se->pre, &argse.pre);
242 gfc_add_block_to_block (&se->post, &argse.post);
243 argarray[curr_arg] = argse.expr;
247 /* Count the number of actual arguments to the intrinsic function EXPR
248 including any "hidden" string length arguments. */
251 gfc_intrinsic_argument_list_length (gfc_expr *expr)
254 gfc_actual_arglist *actual;
256 for (actual = expr->value.function.actual; actual; actual = actual->next)
261 if (actual->expr->ts.type == BT_CHARACTER)
271 /* Conversions between different types are output by the frontend as
272 intrinsic functions. We implement these directly with inline code. */
275 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
281 nargs = gfc_intrinsic_argument_list_length (expr);
282 args = XALLOCAVEC (tree, nargs);
284 /* Evaluate all the arguments passed. Whilst we're only interested in the
285 first one here, there are other parts of the front-end that assume this
286 and will trigger an ICE if it's not the case. */
287 type = gfc_typenode_for_spec (&expr->ts);
288 gcc_assert (expr->value.function.actual->expr);
289 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
291 /* Conversion between character kinds involves a call to a library
293 if (expr->ts.type == BT_CHARACTER)
295 tree fndecl, var, addr, tmp;
297 if (expr->ts.kind == 1
298 && expr->value.function.actual->expr->ts.kind == 4)
299 fndecl = gfor_fndecl_convert_char4_to_char1;
300 else if (expr->ts.kind == 4
301 && expr->value.function.actual->expr->ts.kind == 1)
302 fndecl = gfor_fndecl_convert_char1_to_char4;
306 /* Create the variable storing the converted value. */
307 type = gfc_get_pchar_type (expr->ts.kind);
308 var = gfc_create_var (type, "str");
309 addr = gfc_build_addr_expr (build_pointer_type (type), var);
311 /* Call the library function that will perform the conversion. */
312 gcc_assert (nargs >= 2);
313 tmp = build_call_expr_loc (input_location,
314 fndecl, 3, addr, args[0], args[1]);
315 gfc_add_expr_to_block (&se->pre, tmp);
317 /* Free the temporary afterwards. */
318 tmp = gfc_call_free (var);
319 gfc_add_expr_to_block (&se->post, tmp);
322 se->string_length = args[0];
327 /* Conversion from complex to non-complex involves taking the real
328 component of the value. */
329 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
330 && expr->ts.type != BT_COMPLEX)
334 artype = TREE_TYPE (TREE_TYPE (args[0]));
335 args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
339 se->expr = convert (type, args[0]);
342 /* This is needed because the gcc backend only implements
343 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
344 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
345 Similarly for CEILING. */
348 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
355 argtype = TREE_TYPE (arg);
356 arg = gfc_evaluate_now (arg, pblock);
358 intval = convert (type, arg);
359 intval = gfc_evaluate_now (intval, pblock);
361 tmp = convert (argtype, intval);
362 cond = fold_build2_loc (input_location, up ? GE_EXPR : LE_EXPR,
363 boolean_type_node, tmp, arg);
365 tmp = fold_build2_loc (input_location, up ? PLUS_EXPR : MINUS_EXPR, type,
366 intval, build_int_cst (type, 1));
367 tmp = fold_build3_loc (input_location, COND_EXPR, type, cond, intval, tmp);
372 /* Round to nearest integer, away from zero. */
375 build_round_expr (tree arg, tree restype)
380 int argprec, resprec;
382 argtype = TREE_TYPE (arg);
383 argprec = TYPE_PRECISION (argtype);
384 resprec = TYPE_PRECISION (restype);
386 /* Depending on the type of the result, choose the long int intrinsic
387 (lround family) or long long intrinsic (llround). We might also
388 need to convert the result afterwards. */
389 if (resprec <= LONG_TYPE_SIZE)
391 else if (resprec <= LONG_LONG_TYPE_SIZE)
396 /* Now, depending on the argument type, we choose between intrinsics. */
398 fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec);
400 fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec);
402 return fold_convert (restype, build_call_expr_loc (input_location,
407 /* Convert a real to an integer using a specific rounding mode.
408 Ideally we would just build the corresponding GENERIC node,
409 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
412 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
413 enum rounding_mode op)
418 return build_fixbound_expr (pblock, arg, type, 0);
422 return build_fixbound_expr (pblock, arg, type, 1);
426 return build_round_expr (arg, type);
430 return fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, arg);
439 /* Round a real value using the specified rounding mode.
440 We use a temporary integer of that same kind size as the result.
441 Values larger than those that can be represented by this kind are
442 unchanged, as they will not be accurate enough to represent the
444 huge = HUGE (KIND (a))
445 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
449 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
461 kind = expr->ts.kind;
462 nargs = gfc_intrinsic_argument_list_length (expr);
465 /* We have builtin functions for some cases. */
469 decl = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind);
473 decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind);
480 /* Evaluate the argument. */
481 gcc_assert (expr->value.function.actual->expr);
482 gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
484 /* Use a builtin function if one exists. */
485 if (decl != NULL_TREE)
487 se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]);
491 /* This code is probably redundant, but we'll keep it lying around just
493 type = gfc_typenode_for_spec (&expr->ts);
494 arg[0] = gfc_evaluate_now (arg[0], &se->pre);
496 /* Test if the value is too large to handle sensibly. */
497 gfc_set_model_kind (kind);
499 n = gfc_validate_kind (BT_INTEGER, kind, false);
500 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
501 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
502 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, arg[0],
505 mpfr_neg (huge, huge, GFC_RND_MODE);
506 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
507 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, arg[0],
509 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
511 itype = gfc_get_int_type (kind);
513 tmp = build_fix_expr (&se->pre, arg[0], itype, op);
514 tmp = convert (type, tmp);
515 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
521 /* Convert to an integer using the specified rounding mode. */
524 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
530 nargs = gfc_intrinsic_argument_list_length (expr);
531 args = XALLOCAVEC (tree, nargs);
533 /* Evaluate the argument, we process all arguments even though we only
534 use the first one for code generation purposes. */
535 type = gfc_typenode_for_spec (&expr->ts);
536 gcc_assert (expr->value.function.actual->expr);
537 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
539 if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
541 /* Conversion to a different integer kind. */
542 se->expr = convert (type, args[0]);
546 /* Conversion from complex to non-complex involves taking the real
547 component of the value. */
548 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
549 && expr->ts.type != BT_COMPLEX)
553 artype = TREE_TYPE (TREE_TYPE (args[0]));
554 args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
558 se->expr = build_fix_expr (&se->pre, args[0], type, op);
563 /* Get the imaginary component of a value. */
566 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
570 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
571 se->expr = fold_build1_loc (input_location, IMAGPART_EXPR,
572 TREE_TYPE (TREE_TYPE (arg)), arg);
576 /* Get the complex conjugate of a value. */
579 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
583 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
584 se->expr = fold_build1_loc (input_location, CONJ_EXPR, TREE_TYPE (arg), arg);
590 define_quad_builtin (const char *name, tree type, bool is_const)
593 fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name),
596 /* Mark the decl as external. */
597 DECL_EXTERNAL (fndecl) = 1;
598 TREE_PUBLIC (fndecl) = 1;
600 /* Mark it __attribute__((const)). */
601 TREE_READONLY (fndecl) = is_const;
603 rest_of_decl_compilation (fndecl, 1, 0);
610 /* Initialize function decls for library functions. The external functions
611 are created as required. Builtin functions are added here. */
614 gfc_build_intrinsic_lib_fndecls (void)
616 gfc_intrinsic_map_t *m;
617 tree quad_decls[END_BUILTINS + 1];
619 if (gfc_real16_is_float128)
621 /* If we have soft-float types, we create the decls for their
622 C99-like library functions. For now, we only handle __float128
623 q-suffixed functions. */
625 tree type, complex_type, func_1, func_2, func_cabs, func_frexp;
626 tree func_lround, func_llround, func_scalbn, func_cpow;
628 memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1));
630 type = float128_type_node;
631 complex_type = complex_float128_type_node;
632 /* type (*) (type) */
633 func_1 = build_function_type_list (type, type, NULL_TREE);
634 /* long (*) (type) */
635 func_lround = build_function_type_list (long_integer_type_node,
637 /* long long (*) (type) */
638 func_llround = build_function_type_list (long_long_integer_type_node,
640 /* type (*) (type, type) */
641 func_2 = build_function_type_list (type, type, type, NULL_TREE);
642 /* type (*) (type, &int) */
644 = build_function_type_list (type,
646 build_pointer_type (integer_type_node),
648 /* type (*) (type, int) */
649 func_scalbn = build_function_type_list (type,
650 type, integer_type_node, NULL_TREE);
651 /* type (*) (complex type) */
652 func_cabs = build_function_type_list (type, complex_type, NULL_TREE);
653 /* complex type (*) (complex type, complex type) */
655 = build_function_type_list (complex_type,
656 complex_type, complex_type, NULL_TREE);
658 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
659 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
660 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
662 /* Only these built-ins are actually needed here. These are used directly
663 from the code, when calling builtin_decl_for_precision() or
664 builtin_decl_for_float_type(). The others are all constructed by
665 gfc_get_intrinsic_lib_fndecl(). */
666 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
667 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
669 #include "mathbuiltins.def"
673 #undef DEFINE_MATH_BUILTIN
674 #undef DEFINE_MATH_BUILTIN_C
678 /* Add GCC builtin functions. */
679 for (m = gfc_intrinsic_map;
680 m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
682 if (m->float_built_in != END_BUILTINS)
683 m->real4_decl = builtin_decl_explicit (m->float_built_in);
684 if (m->complex_float_built_in != END_BUILTINS)
685 m->complex4_decl = builtin_decl_explicit (m->complex_float_built_in);
686 if (m->double_built_in != END_BUILTINS)
687 m->real8_decl = builtin_decl_explicit (m->double_built_in);
688 if (m->complex_double_built_in != END_BUILTINS)
689 m->complex8_decl = builtin_decl_explicit (m->complex_double_built_in);
691 /* If real(kind=10) exists, it is always long double. */
692 if (m->long_double_built_in != END_BUILTINS)
693 m->real10_decl = builtin_decl_explicit (m->long_double_built_in);
694 if (m->complex_long_double_built_in != END_BUILTINS)
696 = builtin_decl_explicit (m->complex_long_double_built_in);
698 if (!gfc_real16_is_float128)
700 if (m->long_double_built_in != END_BUILTINS)
701 m->real16_decl = builtin_decl_explicit (m->long_double_built_in);
702 if (m->complex_long_double_built_in != END_BUILTINS)
704 = builtin_decl_explicit (m->complex_long_double_built_in);
706 else if (quad_decls[m->double_built_in] != NULL_TREE)
708 /* Quad-precision function calls are constructed when first
709 needed by builtin_decl_for_precision(), except for those
710 that will be used directly (define by OTHER_BUILTIN). */
711 m->real16_decl = quad_decls[m->double_built_in];
713 else if (quad_decls[m->complex_double_built_in] != NULL_TREE)
715 /* Same thing for the complex ones. */
716 m->complex16_decl = quad_decls[m->double_built_in];
722 /* Create a fndecl for a simple intrinsic library function. */
725 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
728 VEC(tree,gc) *argtypes;
730 gfc_actual_arglist *actual;
733 char name[GFC_MAX_SYMBOL_LEN + 3];
736 if (ts->type == BT_REAL)
741 pdecl = &m->real4_decl;
744 pdecl = &m->real8_decl;
747 pdecl = &m->real10_decl;
750 pdecl = &m->real16_decl;
756 else if (ts->type == BT_COMPLEX)
758 gcc_assert (m->complex_available);
763 pdecl = &m->complex4_decl;
766 pdecl = &m->complex8_decl;
769 pdecl = &m->complex10_decl;
772 pdecl = &m->complex16_decl;
786 int n = gfc_validate_kind (BT_REAL, ts->kind, false);
787 if (gfc_real_kinds[n].c_float)
788 snprintf (name, sizeof (name), "%s%s%s",
789 ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
790 else if (gfc_real_kinds[n].c_double)
791 snprintf (name, sizeof (name), "%s%s",
792 ts->type == BT_COMPLEX ? "c" : "", m->name);
793 else if (gfc_real_kinds[n].c_long_double)
794 snprintf (name, sizeof (name), "%s%s%s",
795 ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
796 else if (gfc_real_kinds[n].c_float128)
797 snprintf (name, sizeof (name), "%s%s%s",
798 ts->type == BT_COMPLEX ? "c" : "", m->name, "q");
804 snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
805 ts->type == BT_COMPLEX ? 'c' : 'r',
810 for (actual = expr->value.function.actual; actual; actual = actual->next)
812 type = gfc_typenode_for_spec (&actual->expr->ts);
813 VEC_safe_push (tree, gc, argtypes, type);
815 type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes);
816 fndecl = build_decl (input_location,
817 FUNCTION_DECL, get_identifier (name), type);
819 /* Mark the decl as external. */
820 DECL_EXTERNAL (fndecl) = 1;
821 TREE_PUBLIC (fndecl) = 1;
823 /* Mark it __attribute__((const)), if possible. */
824 TREE_READONLY (fndecl) = m->is_constant;
826 rest_of_decl_compilation (fndecl, 1, 0);
833 /* Convert an intrinsic function into an external or builtin call. */
836 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
838 gfc_intrinsic_map_t *m;
842 unsigned int num_args;
845 id = expr->value.function.isym->id;
846 /* Find the entry for this function. */
847 for (m = gfc_intrinsic_map;
848 m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
854 if (m->id == GFC_ISYM_NONE)
856 internal_error ("Intrinsic function %s(%d) not recognized",
857 expr->value.function.name, id);
860 /* Get the decl and generate the call. */
861 num_args = gfc_intrinsic_argument_list_length (expr);
862 args = XALLOCAVEC (tree, num_args);
864 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
865 fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
866 rettype = TREE_TYPE (TREE_TYPE (fndecl));
868 fndecl = build_addr (fndecl, current_function_decl);
869 se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
873 /* If bounds-checking is enabled, create code to verify at runtime that the
874 string lengths for both expressions are the same (needed for e.g. MERGE).
875 If bounds-checking is not enabled, does nothing. */
878 gfc_trans_same_strlen_check (const char* intr_name, locus* where,
879 tree a, tree b, stmtblock_t* target)
884 /* If bounds-checking is disabled, do nothing. */
885 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
888 /* Compare the two string lengths. */
889 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, a, b);
891 /* Output the runtime-check. */
892 name = gfc_build_cstring_const (intr_name);
893 name = gfc_build_addr_expr (pchar_type_node, name);
894 gfc_trans_runtime_check (true, false, cond, target, where,
895 "Unequal character lengths (%ld/%ld) in %s",
896 fold_convert (long_integer_type_node, a),
897 fold_convert (long_integer_type_node, b), name);
901 /* The EXPONENT(s) intrinsic function is translated into
908 gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
910 tree arg, type, res, tmp, frexp;
912 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP,
913 expr->value.function.actual->expr->ts.kind);
915 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
917 res = gfc_create_var (integer_type_node, NULL);
918 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
919 gfc_build_addr_expr (NULL_TREE, res));
920 gfc_add_expr_to_block (&se->pre, tmp);
922 type = gfc_typenode_for_spec (&expr->ts);
923 se->expr = fold_convert (type, res);
927 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
928 AR_FULL, suitable for the scalarizer. */
931 walk_coarray (gfc_expr *e)
935 gcc_assert (gfc_get_corank (e) > 0);
937 ss = gfc_walk_expr (e);
939 /* Fix scalar coarray. */
940 if (ss == gfc_ss_terminator)
947 if (ref->type == REF_ARRAY
948 && ref->u.ar.codimen > 0)
954 gcc_assert (ref != NULL);
955 if (ref->u.ar.type == AR_ELEMENT)
956 ref->u.ar.type = AR_SECTION;
957 ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref));
965 trans_this_image (gfc_se * se, gfc_expr *expr)
968 tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var,
969 lbound, ubound, extent, ml;
974 /* The case -fcoarray=single is handled elsewhere. */
975 gcc_assert (gfc_option.coarray != GFC_FCOARRAY_SINGLE);
977 gfc_init_coarray_decl (false);
979 /* Argument-free version: THIS_IMAGE(). */
980 if (expr->value.function.actual->expr == NULL)
982 se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
983 gfort_gvar_caf_this_image);
987 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
989 type = gfc_get_int_type (gfc_default_integer_kind);
990 corank = gfc_get_corank (expr->value.function.actual->expr);
991 rank = expr->value.function.actual->expr->rank;
993 /* Obtain the descriptor of the COARRAY. */
994 gfc_init_se (&argse, NULL);
995 ss = walk_coarray (expr->value.function.actual->expr);
996 gcc_assert (ss != gfc_ss_terminator);
997 argse.want_coarray = 1;
998 gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss);
999 gfc_add_block_to_block (&se->pre, &argse.pre);
1000 gfc_add_block_to_block (&se->post, &argse.post);
1005 /* Create an implicit second parameter from the loop variable. */
1006 gcc_assert (!expr->value.function.actual->next->expr);
1007 gcc_assert (corank > 0);
1008 gcc_assert (se->loop->dimen == 1);
1009 gcc_assert (se->ss->info->expr == expr);
1011 dim_arg = se->loop->loopvar[0];
1012 dim_arg = fold_build2_loc (input_location, PLUS_EXPR,
1013 gfc_array_index_type, dim_arg,
1014 build_int_cst (TREE_TYPE (dim_arg), 1));
1015 gfc_advance_se_ss_chain (se);
1019 /* Use the passed DIM= argument. */
1020 gcc_assert (expr->value.function.actual->next->expr);
1021 gfc_init_se (&argse, NULL);
1022 gfc_conv_expr_type (&argse, expr->value.function.actual->next->expr,
1023 gfc_array_index_type);
1024 gfc_add_block_to_block (&se->pre, &argse.pre);
1025 dim_arg = argse.expr;
1027 if (INTEGER_CST_P (dim_arg))
1031 hi = TREE_INT_CST_HIGH (dim_arg);
1032 co_dim = TREE_INT_CST_LOW (dim_arg);
1033 if (hi || co_dim < 1
1034 || co_dim > GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc)))
1035 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1036 "dimension index", expr->value.function.isym->name,
1039 else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1041 dim_arg = gfc_evaluate_now (dim_arg, &se->pre);
1042 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1044 build_int_cst (TREE_TYPE (dim_arg), 1));
1045 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
1046 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1048 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
1049 boolean_type_node, cond, tmp);
1050 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
1055 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
1056 one always has a dim_arg argument.
1058 m = this_image() - 1
1061 sub(1) = m + lcobound(corank)
1065 min_var = min (rank + corank - 2, rank + dim_arg - 1)
1068 extent = gfc_extent(i)
1076 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
1077 : m + lcobound(corank)
1080 /* this_image () - 1. */
1081 tmp = fold_convert (type, gfort_gvar_caf_this_image);
1082 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, tmp,
1083 build_int_cst (type, 1));
1086 /* sub(1) = m + lcobound(corank). */
1087 lbound = gfc_conv_descriptor_lbound_get (desc,
1088 build_int_cst (TREE_TYPE (gfc_array_index_type),
1090 lbound = fold_convert (type, lbound);
1091 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
1097 m = gfc_create_var (type, NULL);
1098 ml = gfc_create_var (type, NULL);
1099 loop_var = gfc_create_var (integer_type_node, NULL);
1100 min_var = gfc_create_var (integer_type_node, NULL);
1102 /* m = this_image () - 1. */
1103 gfc_add_modify (&se->pre, m, tmp);
1105 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
1106 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
1107 fold_convert (integer_type_node, dim_arg),
1108 build_int_cst (integer_type_node, rank - 1));
1109 tmp = fold_build2_loc (input_location, MIN_EXPR, integer_type_node,
1110 build_int_cst (integer_type_node, rank + corank - 2),
1112 gfc_add_modify (&se->pre, min_var, tmp);
1115 tmp = build_int_cst (integer_type_node, rank);
1116 gfc_add_modify (&se->pre, loop_var, tmp);
1118 exit_label = gfc_build_label_decl (NULL_TREE);
1119 TREE_USED (exit_label) = 1;
1122 gfc_init_block (&loop);
1125 gfc_add_modify (&loop, ml, m);
1128 lbound = gfc_conv_descriptor_lbound_get (desc, loop_var);
1129 ubound = gfc_conv_descriptor_ubound_get (desc, loop_var);
1130 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1131 extent = fold_convert (type, extent);
1134 gfc_add_modify (&loop, m,
1135 fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
1138 /* Exit condition: if (i >= min_var) goto exit_label. */
1139 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, loop_var,
1141 tmp = build1_v (GOTO_EXPR, exit_label);
1142 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
1143 build_empty_stmt (input_location));
1144 gfc_add_expr_to_block (&loop, tmp);
1146 /* Increment loop variable: i++. */
1147 gfc_add_modify (&loop, loop_var,
1148 fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
1150 build_int_cst (integer_type_node, 1)));
1152 /* Making the loop... actually loop! */
1153 tmp = gfc_finish_block (&loop);
1154 tmp = build1_v (LOOP_EXPR, tmp);
1155 gfc_add_expr_to_block (&se->pre, tmp);
1157 /* The exit label. */
1158 tmp = build1_v (LABEL_EXPR, exit_label);
1159 gfc_add_expr_to_block (&se->pre, tmp);
1161 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
1162 : m + lcobound(corank) */
1164 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, dim_arg,
1165 build_int_cst (TREE_TYPE (dim_arg), corank));
1167 lbound = gfc_conv_descriptor_lbound_get (desc,
1168 fold_build2_loc (input_location, PLUS_EXPR,
1169 gfc_array_index_type, dim_arg,
1170 build_int_cst (TREE_TYPE (dim_arg), rank-1)));
1171 lbound = fold_convert (type, lbound);
1173 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml,
1174 fold_build2_loc (input_location, MULT_EXPR, type,
1176 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
1178 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
1179 fold_build2_loc (input_location, PLUS_EXPR, type,
1185 trans_image_index (gfc_se * se, gfc_expr *expr)
1187 tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc,
1189 gfc_se argse, subse;
1191 int rank, corank, codim;
1193 type = gfc_get_int_type (gfc_default_integer_kind);
1194 corank = gfc_get_corank (expr->value.function.actual->expr);
1195 rank = expr->value.function.actual->expr->rank;
1197 /* Obtain the descriptor of the COARRAY. */
1198 gfc_init_se (&argse, NULL);
1199 ss = walk_coarray (expr->value.function.actual->expr);
1200 gcc_assert (ss != gfc_ss_terminator);
1201 argse.want_coarray = 1;
1202 gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss);
1203 gfc_add_block_to_block (&se->pre, &argse.pre);
1204 gfc_add_block_to_block (&se->post, &argse.post);
1207 /* Obtain a handle to the SUB argument. */
1208 gfc_init_se (&subse, NULL);
1209 subss = gfc_walk_expr (expr->value.function.actual->next->expr);
1210 gcc_assert (subss != gfc_ss_terminator);
1211 gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr,
1213 gfc_add_block_to_block (&se->pre, &subse.pre);
1214 gfc_add_block_to_block (&se->post, &subse.post);
1215 subdesc = build_fold_indirect_ref_loc (input_location,
1216 gfc_conv_descriptor_data_get (subse.expr));
1218 /* Fortran 2008 does not require that the values remain in the cobounds,
1219 thus we need explicitly check this - and return 0 if they are exceeded. */
1221 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
1222 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL);
1223 invalid_bound = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1224 fold_convert (gfc_array_index_type, tmp),
1227 for (codim = corank + rank - 2; codim >= rank; codim--)
1229 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
1230 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
1231 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
1232 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1233 fold_convert (gfc_array_index_type, tmp),
1235 invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1236 boolean_type_node, invalid_bound, cond);
1237 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1238 fold_convert (gfc_array_index_type, tmp),
1240 invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1241 boolean_type_node, invalid_bound, cond);
1244 invalid_bound = gfc_unlikely (invalid_bound);
1247 /* See Fortran 2008, C.10 for the following algorithm. */
1249 /* coindex = sub(corank) - lcobound(n). */
1250 coindex = fold_convert (gfc_array_index_type,
1251 gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
1253 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
1254 coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
1255 fold_convert (gfc_array_index_type, coindex),
1258 for (codim = corank + rank - 2; codim >= rank; codim--)
1260 tree extent, ubound;
1262 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
1263 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
1264 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
1265 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1267 /* coindex *= extent. */
1268 coindex = fold_build2_loc (input_location, MULT_EXPR,
1269 gfc_array_index_type, coindex, extent);
1271 /* coindex += sub(codim). */
1272 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
1273 coindex = fold_build2_loc (input_location, PLUS_EXPR,
1274 gfc_array_index_type, coindex,
1275 fold_convert (gfc_array_index_type, tmp));
1277 /* coindex -= lbound(codim). */
1278 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
1279 coindex = fold_build2_loc (input_location, MINUS_EXPR,
1280 gfc_array_index_type, coindex, lbound);
1283 coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
1284 fold_convert(type, coindex),
1285 build_int_cst (type, 1));
1287 /* Return 0 if "coindex" exceeds num_images(). */
1289 if (gfc_option.coarray == GFC_FCOARRAY_SINGLE)
1290 num_images = build_int_cst (type, 1);
1293 gfc_init_coarray_decl (false);
1294 num_images = fold_convert (type, gfort_gvar_caf_num_images);
1297 tmp = gfc_create_var (type, NULL);
1298 gfc_add_modify (&se->pre, tmp, coindex);
1300 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp,
1302 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
1304 fold_convert (boolean_type_node, invalid_bound));
1305 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
1306 build_int_cst (type, 0), tmp);
1311 trans_num_images (gfc_se * se)
1313 gfc_init_coarray_decl (false);
1314 se->expr = fold_convert (gfc_get_int_type (gfc_default_integer_kind),
1315 gfort_gvar_caf_num_images);
1319 /* Evaluate a single upper or lower bound. */
1320 /* TODO: bound intrinsic generates way too much unnecessary code. */
1323 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
1325 gfc_actual_arglist *arg;
1326 gfc_actual_arglist *arg2;
1331 tree cond, cond1, cond3, cond4, size;
1336 gfc_array_spec * as;
1338 arg = expr->value.function.actual;
1343 /* Create an implicit second parameter from the loop variable. */
1344 gcc_assert (!arg2->expr);
1345 gcc_assert (se->loop->dimen == 1);
1346 gcc_assert (se->ss->info->expr == expr);
1347 gfc_advance_se_ss_chain (se);
1348 bound = se->loop->loopvar[0];
1349 bound = fold_build2_loc (input_location, MINUS_EXPR,
1350 gfc_array_index_type, bound,
1355 /* use the passed argument. */
1356 gcc_assert (arg2->expr);
1357 gfc_init_se (&argse, NULL);
1358 gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
1359 gfc_add_block_to_block (&se->pre, &argse.pre);
1361 /* Convert from one based to zero based. */
1362 bound = fold_build2_loc (input_location, MINUS_EXPR,
1363 gfc_array_index_type, bound,
1364 gfc_index_one_node);
1367 /* TODO: don't re-evaluate the descriptor on each iteration. */
1368 /* Get a descriptor for the first parameter. */
1369 ss = gfc_walk_expr (arg->expr);
1370 gcc_assert (ss != gfc_ss_terminator);
1371 gfc_init_se (&argse, NULL);
1372 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
1373 gfc_add_block_to_block (&se->pre, &argse.pre);
1374 gfc_add_block_to_block (&se->post, &argse.post);
1378 if (INTEGER_CST_P (bound))
1382 hi = TREE_INT_CST_HIGH (bound);
1383 low = TREE_INT_CST_LOW (bound);
1384 if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
1385 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1386 "dimension index", upper ? "UBOUND" : "LBOUND",
1391 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1393 bound = gfc_evaluate_now (bound, &se->pre);
1394 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1395 bound, build_int_cst (TREE_TYPE (bound), 0));
1396 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
1397 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
1399 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
1400 boolean_type_node, cond, tmp);
1401 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
1406 ubound = gfc_conv_descriptor_ubound_get (desc, bound);
1407 lbound = gfc_conv_descriptor_lbound_get (desc, bound);
1409 as = gfc_get_full_arrayspec_from_expr (arg->expr);
1411 /* 13.14.53: Result value for LBOUND
1413 Case (i): For an array section or for an array expression other than a
1414 whole array or array structure component, LBOUND(ARRAY, DIM)
1415 has the value 1. For a whole array or array structure
1416 component, LBOUND(ARRAY, DIM) has the value:
1417 (a) equal to the lower bound for subscript DIM of ARRAY if
1418 dimension DIM of ARRAY does not have extent zero
1419 or if ARRAY is an assumed-size array of rank DIM,
1422 13.14.113: Result value for UBOUND
1424 Case (i): For an array section or for an array expression other than a
1425 whole array or array structure component, UBOUND(ARRAY, DIM)
1426 has the value equal to the number of elements in the given
1427 dimension; otherwise, it has a value equal to the upper bound
1428 for subscript DIM of ARRAY if dimension DIM of ARRAY does
1429 not have size zero and has value zero if dimension DIM has
1434 tree stride = gfc_conv_descriptor_stride_get (desc, bound);
1436 cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
1438 cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
1439 stride, gfc_index_zero_node);
1440 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
1441 boolean_type_node, cond3, cond1);
1442 cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1443 stride, gfc_index_zero_node);
1448 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1449 boolean_type_node, cond3, cond4);
1450 cond5 = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1451 gfc_index_one_node, lbound);
1452 cond5 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
1453 boolean_type_node, cond4, cond5);
1455 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1456 boolean_type_node, cond, cond5);
1458 se->expr = fold_build3_loc (input_location, COND_EXPR,
1459 gfc_array_index_type, cond,
1460 ubound, gfc_index_zero_node);
1464 if (as->type == AS_ASSUMED_SIZE)
1465 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1466 bound, build_int_cst (TREE_TYPE (bound),
1467 arg->expr->rank - 1));
1469 cond = boolean_false_node;
1471 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1472 boolean_type_node, cond3, cond4);
1473 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1474 boolean_type_node, cond, cond1);
1476 se->expr = fold_build3_loc (input_location, COND_EXPR,
1477 gfc_array_index_type, cond,
1478 lbound, gfc_index_one_node);
1485 size = fold_build2_loc (input_location, MINUS_EXPR,
1486 gfc_array_index_type, ubound, lbound);
1487 se->expr = fold_build2_loc (input_location, PLUS_EXPR,
1488 gfc_array_index_type, size,
1489 gfc_index_one_node);
1490 se->expr = fold_build2_loc (input_location, MAX_EXPR,
1491 gfc_array_index_type, se->expr,
1492 gfc_index_zero_node);
1495 se->expr = gfc_index_one_node;
1498 type = gfc_typenode_for_spec (&expr->ts);
1499 se->expr = convert (type, se->expr);
1504 conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
1506 gfc_actual_arglist *arg;
1507 gfc_actual_arglist *arg2;
1510 tree bound, resbound, resbound2, desc, cond, tmp;
1514 gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND
1515 || expr->value.function.isym->id == GFC_ISYM_UCOBOUND
1516 || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE);
1518 arg = expr->value.function.actual;
1521 gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
1522 corank = gfc_get_corank (arg->expr);
1524 ss = walk_coarray (arg->expr);
1525 gcc_assert (ss != gfc_ss_terminator);
1526 gfc_init_se (&argse, NULL);
1527 argse.want_coarray = 1;
1529 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
1530 gfc_add_block_to_block (&se->pre, &argse.pre);
1531 gfc_add_block_to_block (&se->post, &argse.post);
1536 /* Create an implicit second parameter from the loop variable. */
1537 gcc_assert (!arg2->expr);
1538 gcc_assert (corank > 0);
1539 gcc_assert (se->loop->dimen == 1);
1540 gcc_assert (se->ss->info->expr == expr);
1542 bound = se->loop->loopvar[0];
1543 bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1544 bound, gfc_rank_cst[arg->expr->rank]);
1545 gfc_advance_se_ss_chain (se);
1549 /* use the passed argument. */
1550 gcc_assert (arg2->expr);
1551 gfc_init_se (&argse, NULL);
1552 gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
1553 gfc_add_block_to_block (&se->pre, &argse.pre);
1556 if (INTEGER_CST_P (bound))
1560 hi = TREE_INT_CST_HIGH (bound);
1561 low = TREE_INT_CST_LOW (bound);
1562 if (hi || low < 1 || low > GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc)))
1563 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1564 "dimension index", expr->value.function.isym->name,
1567 else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1569 bound = gfc_evaluate_now (bound, &se->pre);
1570 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1571 bound, build_int_cst (TREE_TYPE (bound), 1));
1572 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
1573 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1575 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
1576 boolean_type_node, cond, tmp);
1577 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
1582 /* Substract 1 to get to zero based and add dimensions. */
1583 switch (arg->expr->rank)
1586 bound = fold_build2_loc (input_location, MINUS_EXPR,
1587 gfc_array_index_type, bound,
1588 gfc_index_one_node);
1592 bound = fold_build2_loc (input_location, PLUS_EXPR,
1593 gfc_array_index_type, bound,
1594 gfc_rank_cst[arg->expr->rank - 1]);
1598 resbound = gfc_conv_descriptor_lbound_get (desc, bound);
1600 /* Handle UCOBOUND with special handling of the last codimension. */
1601 if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND)
1603 /* Last codimension: For -fcoarray=single just return
1604 the lcobound - otherwise add
1605 ceiling (real (num_images ()) / real (size)) - 1
1606 = (num_images () + size - 1) / size - 1
1607 = (num_images - 1) / size(),
1608 where size is the product of the extent of all but the last
1611 if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && corank > 1)
1615 gfc_init_coarray_decl (false);
1616 cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
1618 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1619 gfc_array_index_type,
1620 fold_convert (gfc_array_index_type,
1621 gfort_gvar_caf_num_images),
1622 build_int_cst (gfc_array_index_type, 1));
1623 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1624 gfc_array_index_type, tmp,
1625 fold_convert (gfc_array_index_type, cosize));
1626 resbound = fold_build2_loc (input_location, PLUS_EXPR,
1627 gfc_array_index_type, resbound, tmp);
1629 else if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
1631 /* ubound = lbound + num_images() - 1. */
1632 gfc_init_coarray_decl (false);
1633 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1634 gfc_array_index_type,
1635 fold_convert (gfc_array_index_type,
1636 gfort_gvar_caf_num_images),
1637 build_int_cst (gfc_array_index_type, 1));
1638 resbound = fold_build2_loc (input_location, PLUS_EXPR,
1639 gfc_array_index_type, resbound, tmp);
1644 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1646 build_int_cst (TREE_TYPE (bound),
1647 arg->expr->rank + corank - 1));
1649 resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
1650 se->expr = fold_build3_loc (input_location, COND_EXPR,
1651 gfc_array_index_type, cond,
1652 resbound, resbound2);
1655 se->expr = resbound;
1658 se->expr = resbound;
1660 type = gfc_typenode_for_spec (&expr->ts);
1661 se->expr = convert (type, se->expr);
1666 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
1670 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
1672 switch (expr->value.function.actual->expr->ts.type)
1676 se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg),
1681 cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind);
1682 se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
1691 /* Create a complex value from one or two real components. */
1694 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
1700 unsigned int num_args;
1702 num_args = gfc_intrinsic_argument_list_length (expr);
1703 args = XALLOCAVEC (tree, num_args);
1705 type = gfc_typenode_for_spec (&expr->ts);
1706 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
1707 real = convert (TREE_TYPE (type), args[0]);
1709 imag = convert (TREE_TYPE (type), args[1]);
1710 else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
1712 imag = fold_build1_loc (input_location, IMAGPART_EXPR,
1713 TREE_TYPE (TREE_TYPE (args[0])), args[0]);
1714 imag = convert (TREE_TYPE (type), imag);
1717 imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
1719 se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag);
1722 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1723 MODULO(A, P) = A - FLOOR (A / P) * P */
1724 /* TODO: MOD(x, 0) */
1727 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
1739 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1741 switch (expr->ts.type)
1744 /* Integer case is easy, we've got a builtin op. */
1745 type = TREE_TYPE (args[0]);
1748 se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type,
1751 se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
1757 /* Check if we have a builtin fmod. */
1758 fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind);
1760 /* Use it if it exists. */
1761 if (fmod != NULL_TREE)
1763 tmp = build_addr (fmod, current_function_decl);
1764 se->expr = build_call_array_loc (input_location,
1765 TREE_TYPE (TREE_TYPE (fmod)),
1771 type = TREE_TYPE (args[0]);
1773 args[0] = gfc_evaluate_now (args[0], &se->pre);
1774 args[1] = gfc_evaluate_now (args[1], &se->pre);
1777 modulo = arg - floor (arg/arg2) * arg2, so
1778 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1780 test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1781 thereby avoiding another division and retaining the accuracy
1782 of the builtin function. */
1783 if (fmod != NULL_TREE && modulo)
1785 tree zero = gfc_build_const (type, integer_zero_node);
1786 tmp = gfc_evaluate_now (se->expr, &se->pre);
1787 test = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1789 test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1791 test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
1792 boolean_type_node, test, test2);
1793 test = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1795 test = fold_build2_loc (input_location, TRUTH_AND_EXPR,
1796 boolean_type_node, test, test2);
1797 test = gfc_evaluate_now (test, &se->pre);
1798 se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
1799 fold_build2_loc (input_location, PLUS_EXPR,
1800 type, tmp, args[1]), tmp);
1804 /* If we do not have a built_in fmod, the calculation is going to
1805 have to be done longhand. */
1806 tmp = fold_build2_loc (input_location, RDIV_EXPR, type, args[0], args[1]);
1808 /* Test if the value is too large to handle sensibly. */
1809 gfc_set_model_kind (expr->ts.kind);
1811 n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true);
1812 ikind = expr->ts.kind;
1815 n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false);
1816 ikind = gfc_max_integer_kind;
1818 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
1819 test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1820 test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1823 mpfr_neg (huge, huge, GFC_RND_MODE);
1824 test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1825 test = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp,
1827 test2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
1828 boolean_type_node, test, test2);
1830 itype = gfc_get_int_type (ikind);
1832 tmp = build_fix_expr (&se->pre, tmp, itype, RND_FLOOR);
1834 tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC);
1835 tmp = convert (type, tmp);
1836 tmp = fold_build3_loc (input_location, COND_EXPR, type, test2, tmp,
1838 tmp = fold_build2_loc (input_location, MULT_EXPR, type, tmp, args[1]);
1839 se->expr = fold_build2_loc (input_location, MINUS_EXPR, type, args[0],
1849 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
1850 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
1851 where the right shifts are logical (i.e. 0's are shifted in).
1852 Because SHIFT_EXPR's want shifts strictly smaller than the integral
1853 type width, we have to special-case both S == 0 and S == BITSIZE(J):
1855 DSHIFTL(I,J,BITSIZE) = J
1857 DSHIFTR(I,J,BITSIZE) = I. */
1860 gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl)
1862 tree type, utype, stype, arg1, arg2, shift, res, left, right;
1863 tree args[3], cond, tmp;
1866 gfc_conv_intrinsic_function_args (se, expr, args, 3);
1868 gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1]));
1869 type = TREE_TYPE (args[0]);
1870 bitsize = TYPE_PRECISION (type);
1871 utype = unsigned_type_for (type);
1872 stype = TREE_TYPE (args[2]);
1874 arg1 = gfc_evaluate_now (args[0], &se->pre);
1875 arg2 = gfc_evaluate_now (args[1], &se->pre);
1876 shift = gfc_evaluate_now (args[2], &se->pre);
1878 /* The generic case. */
1879 tmp = fold_build2_loc (input_location, MINUS_EXPR, stype,
1880 build_int_cst (stype, bitsize), shift);
1881 left = fold_build2_loc (input_location, LSHIFT_EXPR, type,
1882 arg1, dshiftl ? shift : tmp);
1884 right = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
1885 fold_convert (utype, arg2), dshiftl ? tmp : shift);
1886 right = fold_convert (type, right);
1888 res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right);
1890 /* Special cases. */
1891 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift,
1892 build_int_cst (stype, 0));
1893 res = fold_build3_loc (input_location, COND_EXPR, type, cond,
1894 dshiftl ? arg1 : arg2, res);
1896 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift,
1897 build_int_cst (stype, bitsize));
1898 res = fold_build3_loc (input_location, COND_EXPR, type, cond,
1899 dshiftl ? arg2 : arg1, res);
1905 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
1908 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
1916 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1917 type = TREE_TYPE (args[0]);
1919 val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]);
1920 val = gfc_evaluate_now (val, &se->pre);
1922 zero = gfc_build_const (type, integer_zero_node);
1923 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, val, zero);
1924 se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val);
1928 /* SIGN(A, B) is absolute value of A times sign of B.
1929 The real value versions use library functions to ensure the correct
1930 handling of negative zero. Integer case implemented as:
1931 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1935 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
1941 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1942 if (expr->ts.type == BT_REAL)
1946 tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
1947 abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
1949 /* We explicitly have to ignore the minus sign. We do so by using
1950 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
1951 if (!gfc_option.flag_sign_zero
1952 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
1955 zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
1956 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1958 se->expr = fold_build3_loc (input_location, COND_EXPR,
1959 TREE_TYPE (args[0]), cond,
1960 build_call_expr_loc (input_location, abs, 1,
1962 build_call_expr_loc (input_location, tmp, 2,
1966 se->expr = build_call_expr_loc (input_location, tmp, 2,
1971 /* Having excluded floating point types, we know we are now dealing
1972 with signed integer types. */
1973 type = TREE_TYPE (args[0]);
1975 /* Args[0] is used multiple times below. */
1976 args[0] = gfc_evaluate_now (args[0], &se->pre);
1978 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1979 the signs of A and B are the same, and of all ones if they differ. */
1980 tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]);
1981 tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp,
1982 build_int_cst (type, TYPE_PRECISION (type) - 1));
1983 tmp = gfc_evaluate_now (tmp, &se->pre);
1985 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1986 is all ones (i.e. -1). */
1987 se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type,
1988 fold_build2_loc (input_location, PLUS_EXPR,
1989 type, args[0], tmp), tmp);
1993 /* Test for the presence of an optional argument. */
1996 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
2000 arg = expr->value.function.actual->expr;
2001 gcc_assert (arg->expr_type == EXPR_VARIABLE);
2002 se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
2003 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
2007 /* Calculate the double precision product of two single precision values. */
2010 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
2015 gfc_conv_intrinsic_function_args (se, expr, args, 2);
2017 /* Convert the args to double precision before multiplying. */
2018 type = gfc_typenode_for_spec (&expr->ts);
2019 args[0] = convert (type, args[0]);
2020 args[1] = convert (type, args[1]);
2021 se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0],
2026 /* Return a length one character string containing an ascii character. */
2029 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
2034 unsigned int num_args;
2036 num_args = gfc_intrinsic_argument_list_length (expr);
2037 gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
2039 type = gfc_get_char_type (expr->ts.kind);
2040 var = gfc_create_var (type, "char");
2042 arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]);
2043 gfc_add_modify (&se->pre, var, arg[0]);
2044 se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
2045 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
2050 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
2058 unsigned int num_args;
2060 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
2061 args = XALLOCAVEC (tree, num_args);
2063 var = gfc_create_var (pchar_type_node, "pstr");
2064 len = gfc_create_var (gfc_charlen_type_node, "len");
2066 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
2067 args[0] = gfc_build_addr_expr (NULL_TREE, var);
2068 args[1] = gfc_build_addr_expr (NULL_TREE, len);
2070 fndecl = build_addr (gfor_fndecl_ctime, current_function_decl);
2071 tmp = build_call_array_loc (input_location,
2072 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
2073 fndecl, num_args, args);
2074 gfc_add_expr_to_block (&se->pre, tmp);
2076 /* Free the temporary afterwards, if necessary. */
2077 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2078 len, build_int_cst (TREE_TYPE (len), 0));
2079 tmp = gfc_call_free (var);
2080 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2081 gfc_add_expr_to_block (&se->post, tmp);
2084 se->string_length = len;
2089 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
2097 unsigned int num_args;
2099 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
2100 args = XALLOCAVEC (tree, num_args);
2102 var = gfc_create_var (pchar_type_node, "pstr");
2103 len = gfc_create_var (gfc_charlen_type_node, "len");
2105 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
2106 args[0] = gfc_build_addr_expr (NULL_TREE, var);
2107 args[1] = gfc_build_addr_expr (NULL_TREE, len);
2109 fndecl = build_addr (gfor_fndecl_fdate, current_function_decl);
2110 tmp = build_call_array_loc (input_location,
2111 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
2112 fndecl, num_args, args);
2113 gfc_add_expr_to_block (&se->pre, tmp);
2115 /* Free the temporary afterwards, if necessary. */
2116 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2117 len, build_int_cst (TREE_TYPE (len), 0));
2118 tmp = gfc_call_free (var);
2119 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2120 gfc_add_expr_to_block (&se->post, tmp);
2123 se->string_length = len;
2127 /* Return a character string containing the tty name. */
2130 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
2138 unsigned int num_args;
2140 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
2141 args = XALLOCAVEC (tree, num_args);
2143 var = gfc_create_var (pchar_type_node, "pstr");
2144 len = gfc_create_var (gfc_charlen_type_node, "len");
2146 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
2147 args[0] = gfc_build_addr_expr (NULL_TREE, var);
2148 args[1] = gfc_build_addr_expr (NULL_TREE, len);
2150 fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl);
2151 tmp = build_call_array_loc (input_location,
2152 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
2153 fndecl, num_args, args);
2154 gfc_add_expr_to_block (&se->pre, tmp);
2156 /* Free the temporary afterwards, if necessary. */
2157 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2158 len, build_int_cst (TREE_TYPE (len), 0));
2159 tmp = gfc_call_free (var);
2160 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2161 gfc_add_expr_to_block (&se->post, tmp);
2164 se->string_length = len;
2168 /* Get the minimum/maximum value of all the parameters.
2169 minmax (a1, a2, a3, ...)
2172 if (a2 .op. mvar || isnan(mvar))
2174 if (a3 .op. mvar || isnan(mvar))
2181 /* TODO: Mismatching types can occur when specific names are used.
2182 These should be handled during resolution. */
2184 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
2192 gfc_actual_arglist *argexpr;
2193 unsigned int i, nargs;
2195 nargs = gfc_intrinsic_argument_list_length (expr);
2196 args = XALLOCAVEC (tree, nargs);
2198 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
2199 type = gfc_typenode_for_spec (&expr->ts);
2201 argexpr = expr->value.function.actual;
2202 if (TREE_TYPE (args[0]) != type)
2203 args[0] = convert (type, args[0]);
2204 /* Only evaluate the argument once. */
2205 if (TREE_CODE (args[0]) != VAR_DECL && !TREE_CONSTANT (args[0]))
2206 args[0] = gfc_evaluate_now (args[0], &se->pre);
2208 mvar = gfc_create_var (type, "M");
2209 gfc_add_modify (&se->pre, mvar, args[0]);
2210 for (i = 1, argexpr = argexpr->next; i < nargs; i++)
2216 /* Handle absent optional arguments by ignoring the comparison. */
2217 if (argexpr->expr->expr_type == EXPR_VARIABLE
2218 && argexpr->expr->symtree->n.sym->attr.optional
2219 && TREE_CODE (val) == INDIRECT_REF)
2220 cond = fold_build2_loc (input_location,
2221 NE_EXPR, boolean_type_node,
2222 TREE_OPERAND (val, 0),
2223 build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
2228 /* Only evaluate the argument once. */
2229 if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
2230 val = gfc_evaluate_now (val, &se->pre);
2233 thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
2235 tmp = fold_build2_loc (input_location, op, boolean_type_node,
2236 convert (type, val), mvar);
2238 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
2239 __builtin_isnan might be made dependent on that module being loaded,
2240 to help performance of programs that don't rely on IEEE semantics. */
2241 if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
2243 isnan = build_call_expr_loc (input_location,
2244 builtin_decl_explicit (BUILT_IN_ISNAN),
2246 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2247 boolean_type_node, tmp,
2248 fold_convert (boolean_type_node, isnan));
2250 tmp = build3_v (COND_EXPR, tmp, thencase,
2251 build_empty_stmt (input_location));
2253 if (cond != NULL_TREE)
2254 tmp = build3_v (COND_EXPR, cond, tmp,
2255 build_empty_stmt (input_location));
2257 gfc_add_expr_to_block (&se->pre, tmp);
2258 argexpr = argexpr->next;
2264 /* Generate library calls for MIN and MAX intrinsics for character
2267 gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
2270 tree var, len, fndecl, tmp, cond, function;
2273 nargs = gfc_intrinsic_argument_list_length (expr);
2274 args = XALLOCAVEC (tree, nargs + 4);
2275 gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
2277 /* Create the result variables. */
2278 len = gfc_create_var (gfc_charlen_type_node, "len");
2279 args[0] = gfc_build_addr_expr (NULL_TREE, len);
2280 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
2281 args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
2282 args[2] = build_int_cst (integer_type_node, op);
2283 args[3] = build_int_cst (integer_type_node, nargs / 2);
2285 if (expr->ts.kind == 1)
2286 function = gfor_fndecl_string_minmax;
2287 else if (expr->ts.kind == 4)
2288 function = gfor_fndecl_string_minmax_char4;
2292 /* Make the function call. */
2293 fndecl = build_addr (function, current_function_decl);
2294 tmp = build_call_array_loc (input_location,
2295 TREE_TYPE (TREE_TYPE (function)), fndecl,
2297 gfc_add_expr_to_block (&se->pre, tmp);
2299 /* Free the temporary afterwards, if necessary. */
2300 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2301 len, build_int_cst (TREE_TYPE (len), 0));
2302 tmp = gfc_call_free (var);
2303 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2304 gfc_add_expr_to_block (&se->post, tmp);
2307 se->string_length = len;
2311 /* Create a symbol node for this intrinsic. The symbol from the frontend
2312 has the generic name. */
2315 gfc_get_symbol_for_expr (gfc_expr * expr)
2319 /* TODO: Add symbols for intrinsic function to the global namespace. */
2320 gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
2321 sym = gfc_new_symbol (expr->value.function.name, NULL);
2324 sym->attr.external = 1;
2325 sym->attr.function = 1;
2326 sym->attr.always_explicit = 1;
2327 sym->attr.proc = PROC_INTRINSIC;
2328 sym->attr.flavor = FL_PROCEDURE;
2332 sym->attr.dimension = 1;
2333 sym->as = gfc_get_array_spec ();
2334 sym->as->type = AS_ASSUMED_SHAPE;
2335 sym->as->rank = expr->rank;
2338 gfc_copy_formal_args_intr (sym, expr->value.function.isym);
2343 /* Generate a call to an external intrinsic function. */
2345 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
2348 VEC(tree,gc) *append_args;
2350 gcc_assert (!se->ss || se->ss->info->expr == expr);
2353 gcc_assert (expr->rank > 0);
2355 gcc_assert (expr->rank == 0);
2357 sym = gfc_get_symbol_for_expr (expr);
2359 /* Calls to libgfortran_matmul need to be appended special arguments,
2360 to be able to call the BLAS ?gemm functions if required and possible. */
2362 if (expr->value.function.isym->id == GFC_ISYM_MATMUL
2363 && sym->ts.type != BT_LOGICAL)
2365 tree cint = gfc_get_int_type (gfc_c_int_kind);
2367 if (gfc_option.flag_external_blas
2368 && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
2369 && (sym->ts.kind == gfc_default_real_kind
2370 || sym->ts.kind == gfc_default_double_kind))
2374 if (sym->ts.type == BT_REAL)
2376 if (sym->ts.kind == gfc_default_real_kind)
2377 gemm_fndecl = gfor_fndecl_sgemm;
2379 gemm_fndecl = gfor_fndecl_dgemm;
2383 if (sym->ts.kind == gfc_default_real_kind)
2384 gemm_fndecl = gfor_fndecl_cgemm;
2386 gemm_fndecl = gfor_fndecl_zgemm;
2389 append_args = VEC_alloc (tree, gc, 3);
2390 VEC_quick_push (tree, append_args, build_int_cst (cint, 1));
2391 VEC_quick_push (tree, append_args,
2392 build_int_cst (cint, gfc_option.blas_matmul_limit));
2393 VEC_quick_push (tree, append_args,
2394 gfc_build_addr_expr (NULL_TREE, gemm_fndecl));
2398 append_args = VEC_alloc (tree, gc, 3);
2399 VEC_quick_push (tree, append_args, build_int_cst (cint, 0));
2400 VEC_quick_push (tree, append_args, build_int_cst (cint, 0));
2401 VEC_quick_push (tree, append_args, null_pointer_node);
2405 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
2407 gfc_free_symbol (sym);
2410 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
2430 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
2439 gfc_actual_arglist *actual;
2446 gfc_conv_intrinsic_funcall (se, expr);
2450 actual = expr->value.function.actual;
2451 type = gfc_typenode_for_spec (&expr->ts);
2452 /* Initialize the result. */
2453 resvar = gfc_create_var (type, "test");
2455 tmp = convert (type, boolean_true_node);
2457 tmp = convert (type, boolean_false_node);
2458 gfc_add_modify (&se->pre, resvar, tmp);
2460 /* Walk the arguments. */
2461 arrayss = gfc_walk_expr (actual->expr);
2462 gcc_assert (arrayss != gfc_ss_terminator);
2464 /* Initialize the scalarizer. */
2465 gfc_init_loopinfo (&loop);
2466 exit_label = gfc_build_label_decl (NULL_TREE);
2467 TREE_USED (exit_label) = 1;
2468 gfc_add_ss_to_loop (&loop, arrayss);
2470 /* Initialize the loop. */
2471 gfc_conv_ss_startstride (&loop);
2472 gfc_conv_loop_setup (&loop, &expr->where);
2474 gfc_mark_ss_chain_used (arrayss, 1);
2475 /* Generate the loop body. */
2476 gfc_start_scalarized_body (&loop, &body);
2478 /* If the condition matches then set the return value. */
2479 gfc_start_block (&block);
2481 tmp = convert (type, boolean_false_node);
2483 tmp = convert (type, boolean_true_node);
2484 gfc_add_modify (&block, resvar, tmp);
2486 /* And break out of the loop. */
2487 tmp = build1_v (GOTO_EXPR, exit_label);
2488 gfc_add_expr_to_block (&block, tmp);
2490 found = gfc_finish_block (&block);
2492 /* Check this element. */
2493 gfc_init_se (&arrayse, NULL);
2494 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2495 arrayse.ss = arrayss;
2496 gfc_conv_expr_val (&arrayse, actual->expr);
2498 gfc_add_block_to_block (&body, &arrayse.pre);
2499 tmp = fold_build2_loc (input_location, op, boolean_type_node, arrayse.expr,
2500 build_int_cst (TREE_TYPE (arrayse.expr), 0));
2501 tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
2502 gfc_add_expr_to_block (&body, tmp);
2503 gfc_add_block_to_block (&body, &arrayse.post);
2505 gfc_trans_scalarizing_loops (&loop, &body);
2507 /* Add the exit label. */
2508 tmp = build1_v (LABEL_EXPR, exit_label);
2509 gfc_add_expr_to_block (&loop.pre, tmp);
2511 gfc_add_block_to_block (&se->pre, &loop.pre);
2512 gfc_add_block_to_block (&se->pre, &loop.post);
2513 gfc_cleanup_loop (&loop);
2518 /* COUNT(A) = Number of true elements in A. */
2520 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
2527 gfc_actual_arglist *actual;
2533 gfc_conv_intrinsic_funcall (se, expr);
2537 actual = expr->value.function.actual;
2539 type = gfc_typenode_for_spec (&expr->ts);
2540 /* Initialize the result. */
2541 resvar = gfc_create_var (type, "count");
2542 gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
2544 /* Walk the arguments. */
2545 arrayss = gfc_walk_expr (actual->expr);
2546 gcc_assert (arrayss != gfc_ss_terminator);
2548 /* Initialize the scalarizer. */
2549 gfc_init_loopinfo (&loop);
2550 gfc_add_ss_to_loop (&loop, arrayss);
2552 /* Initialize the loop. */
2553 gfc_conv_ss_startstride (&loop);
2554 gfc_conv_loop_setup (&loop, &expr->where);
2556 gfc_mark_ss_chain_used (arrayss, 1);
2557 /* Generate the loop body. */
2558 gfc_start_scalarized_body (&loop, &body);
2560 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar),
2561 resvar, build_int_cst (TREE_TYPE (resvar), 1));
2562 tmp = build2_v (MODIFY_EXPR, resvar, tmp);
2564 gfc_init_se (&arrayse, NULL);
2565 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2566 arrayse.ss = arrayss;
2567 gfc_conv_expr_val (&arrayse, actual->expr);
2568 tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
2569 build_empty_stmt (input_location));
2571 gfc_add_block_to_block (&body, &arrayse.pre);
2572 gfc_add_expr_to_block (&body, tmp);
2573 gfc_add_block_to_block (&body, &arrayse.post);
2575 gfc_trans_scalarizing_loops (&loop, &body);
2577 gfc_add_block_to_block (&se->pre, &loop.pre);
2578 gfc_add_block_to_block (&se->pre, &loop.post);
2579 gfc_cleanup_loop (&loop);
2585 /* Update given gfc_se to have ss component pointing to the nested gfc_ss
2586 struct and return the corresponding loopinfo. */
2588 static gfc_loopinfo *
2589 enter_nested_loop (gfc_se *se)
2591 se->ss = se->ss->nested_ss;
2592 gcc_assert (se->ss == se->ss->loop->ss);
2594 return se->ss->loop;
2598 /* Inline implementation of the sum and product intrinsics. */
2600 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
2604 tree scale = NULL_TREE;
2609 gfc_loopinfo loop, *ploop;
2610 gfc_actual_arglist *arg_array, *arg_mask;
2611 gfc_ss *arrayss = NULL;
2612 gfc_ss *maskss = NULL;
2616 gfc_expr *arrayexpr;
2621 gcc_assert (gfc_inline_intrinsic_function_p (expr));
2627 type = gfc_typenode_for_spec (&expr->ts);
2628 /* Initialize the result. */
2629 resvar = gfc_create_var (type, "val");
2634 scale = gfc_create_var (type, "scale");
2635 gfc_add_modify (&se->pre, scale,
2636 gfc_build_const (type, integer_one_node));
2637 tmp = gfc_build_const (type, integer_zero_node);
2639 else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR)
2640 tmp = gfc_build_const (type, integer_zero_node);
2641 else if (op == NE_EXPR)
2643 tmp = convert (type, boolean_false_node);
2644 else if (op == BIT_AND_EXPR)
2645 tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR,
2646 type, integer_one_node));
2648 tmp = gfc_build_const (type, integer_one_node);
2650 gfc_add_modify (&se->pre, resvar, tmp);
2652 arg_array = expr->value.function.actual;
2654 arrayexpr = arg_array->expr;
2656 if (op == NE_EXPR || norm2)
2657 /* PARITY and NORM2. */
2661 arg_mask = arg_array->next->next;
2662 gcc_assert (arg_mask != NULL);
2663 maskexpr = arg_mask->expr;
2666 if (expr->rank == 0)
2668 /* Walk the arguments. */
2669 arrayss = gfc_walk_expr (arrayexpr);
2670 gcc_assert (arrayss != gfc_ss_terminator);
2672 if (maskexpr && maskexpr->rank > 0)
2674 maskss = gfc_walk_expr (maskexpr);
2675 gcc_assert (maskss != gfc_ss_terminator);
2680 /* Initialize the scalarizer. */
2681 gfc_init_loopinfo (&loop);
2682 gfc_add_ss_to_loop (&loop, arrayss);
2683 if (maskexpr && maskexpr->rank > 0)
2684 gfc_add_ss_to_loop (&loop, maskss);
2686 /* Initialize the loop. */
2687 gfc_conv_ss_startstride (&loop);
2688 gfc_conv_loop_setup (&loop, &expr->where);
2690 gfc_mark_ss_chain_used (arrayss, 1);
2691 if (maskexpr && maskexpr->rank > 0)
2692 gfc_mark_ss_chain_used (maskss, 1);
2697 /* All the work has been done in the parent loops. */
2698 ploop = enter_nested_loop (se);
2702 /* Generate the loop body. */
2703 gfc_start_scalarized_body (ploop, &body);
2705 /* If we have a mask, only add this element if the mask is set. */
2706 if (maskexpr && maskexpr->rank > 0)
2708 gfc_init_se (&maskse, parent_se);
2709 gfc_copy_loopinfo_to_se (&maskse, ploop);
2710 if (expr->rank == 0)
2712 gfc_conv_expr_val (&maskse, maskexpr);
2713 gfc_add_block_to_block (&body, &maskse.pre);
2715 gfc_start_block (&block);
2718 gfc_init_block (&block);
2720 /* Do the actual summation/product. */
2721 gfc_init_se (&arrayse, parent_se);
2722 gfc_copy_loopinfo_to_se (&arrayse, ploop);
2723 if (expr->rank == 0)
2724 arrayse.ss = arrayss;
2725 gfc_conv_expr_val (&arrayse, arrayexpr);
2726 gfc_add_block_to_block (&block, &arrayse.pre);
2736 result = 1.0 + result * val * val;
2742 result += val * val;
2745 tree res1, res2, cond, absX, val;
2746 stmtblock_t ifblock1, ifblock2, ifblock3;
2748 gfc_init_block (&ifblock1);
2750 absX = gfc_create_var (type, "absX");
2751 gfc_add_modify (&ifblock1, absX,
2752 fold_build1_loc (input_location, ABS_EXPR, type,
2754 val = gfc_create_var (type, "val");
2755 gfc_add_expr_to_block (&ifblock1, val);
2757 gfc_init_block (&ifblock2);
2758 gfc_add_modify (&ifblock2, val,
2759 fold_build2_loc (input_location, RDIV_EXPR, type, scale,
2761 res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
2762 res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
2763 res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
2764 gfc_build_const (type, integer_one_node));
2765 gfc_add_modify (&ifblock2, resvar, res1);
2766 gfc_add_modify (&ifblock2, scale, absX);
2767 res1 = gfc_finish_block (&ifblock2);
2769 gfc_init_block (&ifblock3);
2770 gfc_add_modify (&ifblock3, val,
2771 fold_build2_loc (input_location, RDIV_EXPR, type, absX,
2773 res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
2774 res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
2775 gfc_add_modify (&ifblock3, resvar, res2);
2776 res2 = gfc_finish_block (&ifblock3);
2778 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2780 tmp = build3_v (COND_EXPR, cond, res1, res2);
2781 gfc_add_expr_to_block (&ifblock1, tmp);
2782 tmp = gfc_finish_block (&ifblock1);
2784 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
2786 gfc_build_const (type, integer_zero_node));
2788 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2789 gfc_add_expr_to_block (&block, tmp);
2793 tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr);
2794 gfc_add_modify (&block, resvar, tmp);
2797 gfc_add_block_to_block (&block, &arrayse.post);
2799 if (maskexpr && maskexpr->rank > 0)
2801 /* We enclose the above in if (mask) {...} . */
2803 tmp = gfc_finish_block (&block);
2804 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2805 build_empty_stmt (input_location));
2808 tmp = gfc_finish_block (&block);
2809 gfc_add_expr_to_block (&body, tmp);
2811 gfc_trans_scalarizing_loops (ploop, &body);
2813 /* For a scalar mask, enclose the loop in an if statement. */
2814 if (maskexpr && maskexpr->rank == 0)
2816 gfc_init_block (&block);
2817 gfc_add_block_to_block (&block, &ploop->pre);
2818 gfc_add_block_to_block (&block, &ploop->post);
2819 tmp = gfc_finish_block (&block);
2823 tmp = build3_v (COND_EXPR, se->ss->info->data.scalar.value, tmp,
2824 build_empty_stmt (input_location));
2825 gfc_advance_se_ss_chain (se);
2829 gcc_assert (expr->rank == 0);
2830 gfc_init_se (&maskse, NULL);
2831 gfc_conv_expr_val (&maskse, maskexpr);
2832 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2833 build_empty_stmt (input_location));
2836 gfc_add_expr_to_block (&block, tmp);
2837 gfc_add_block_to_block (&se->pre, &block);
2838 gcc_assert (se->post.head == NULL);
2842 gfc_add_block_to_block (&se->pre, &ploop->pre);
2843 gfc_add_block_to_block (&se->pre, &ploop->post);
2846 if (expr->rank == 0)
2847 gfc_cleanup_loop (ploop);
2851 /* result = scale * sqrt(result). */
2853 sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind);
2854 resvar = build_call_expr_loc (input_location,
2856 resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar);
2863 /* Inline implementation of the dot_product intrinsic. This function
2864 is based on gfc_conv_intrinsic_arith (the previous function). */
2866 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
2874 gfc_actual_arglist *actual;
2875 gfc_ss *arrayss1, *arrayss2;
2876 gfc_se arrayse1, arrayse2;
2877 gfc_expr *arrayexpr1, *arrayexpr2;
2879 type = gfc_typenode_for_spec (&expr->ts);
2881 /* Initialize the result. */
2882 resvar = gfc_create_var (type, "val");
2883 if (expr->ts.type == BT_LOGICAL)
2884 tmp = build_int_cst (type, 0);
2886 tmp = gfc_build_const (type, integer_zero_node);
2888 gfc_add_modify (&se->pre, resvar, tmp);
2890 /* Walk argument #1. */
2891 actual = expr->value.function.actual;
2892 arrayexpr1 = actual->expr;
2893 arrayss1 = gfc_walk_expr (arrayexpr1);
2894 gcc_assert (arrayss1 != gfc_ss_terminator);
2896 /* Walk argument #2. */
2897 actual = actual->next;
2898 arrayexpr2 = actual->expr;
2899 arrayss2 = gfc_walk_expr (arrayexpr2);
2900 gcc_assert (arrayss2 != gfc_ss_terminator);
2902 /* Initialize the scalarizer. */
2903 gfc_init_loopinfo (&loop);
2904 gfc_add_ss_to_loop (&loop, arrayss1);
2905 gfc_add_ss_to_loop (&loop, arrayss2);
2907 /* Initialize the loop. */
2908 gfc_conv_ss_startstride (&loop);
2909 gfc_conv_loop_setup (&loop, &expr->where);
2911 gfc_mark_ss_chain_used (arrayss1, 1);
2912 gfc_mark_ss_chain_used (arrayss2, 1);
2914 /* Generate the loop body. */
2915 gfc_start_scalarized_body (&loop, &body);
2916 gfc_init_block (&block);
2918 /* Make the tree expression for [conjg(]array1[)]. */
2919 gfc_init_se (&arrayse1, NULL);
2920 gfc_copy_loopinfo_to_se (&arrayse1, &loop);
2921 arrayse1.ss = arrayss1;
2922 gfc_conv_expr_val (&arrayse1, arrayexpr1);
2923 if (expr->ts.type == BT_COMPLEX)
2924 arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type,
2926 gfc_add_block_to_block (&block, &arrayse1.pre);
2928 /* Make the tree expression for array2. */
2929 gfc_init_se (&arrayse2, NULL);
2930 gfc_copy_loopinfo_to_se (&arrayse2, &loop);
2931 arrayse2.ss = arrayss2;
2932 gfc_conv_expr_val (&arrayse2, arrayexpr2);
2933 gfc_add_block_to_block (&block, &arrayse2.pre);
2935 /* Do the actual product and sum. */
2936 if (expr->ts.type == BT_LOGICAL)
2938 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type,
2939 arrayse1.expr, arrayse2.expr);
2940 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp);
2944 tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr,
2946 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp);
2948 gfc_add_modify (&block, resvar, tmp);
2950 /* Finish up the loop block and the loop. */
2951 tmp = gfc_finish_block (&block);
2952 gfc_add_expr_to_block (&body, tmp);
2954 gfc_trans_scalarizing_loops (&loop, &body);
2955 gfc_add_block_to_block (&se->pre, &loop.pre);
2956 gfc_add_block_to_block (&se->pre, &loop.post);
2957 gfc_cleanup_loop (&loop);
2963 /* Emit code for minloc or maxloc intrinsic. There are many different cases
2964 we need to handle. For performance reasons we sometimes create two
2965 loops instead of one, where the second one is much simpler.
2966 Examples for minloc intrinsic:
2967 1) Result is an array, a call is generated
2968 2) Array mask is used and NaNs need to be supported:
2974 if (pos == 0) pos = S + (1 - from);
2975 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2982 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2986 3) NaNs need to be supported, but it is known at compile time or cheaply
2987 at runtime whether array is nonempty or not:
2992 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2995 if (from <= to) pos = 1;
2999 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3003 4) NaNs aren't supported, array mask is used:
3004 limit = infinities_supported ? Infinity : huge (limit);
3008 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
3014 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3018 5) Same without array mask:
3019 limit = infinities_supported ? Infinity : huge (limit);
3020 pos = (from <= to) ? 1 : 0;
3023 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
3026 For 3) and 5), if mask is scalar, this all goes into a conditional,
3027 setting pos = 0; in the else branch. */
3030 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
3034 stmtblock_t ifblock;
3035 stmtblock_t elseblock;
3046 gfc_actual_arglist *actual;
3051 gfc_expr *arrayexpr;
3058 gfc_conv_intrinsic_funcall (se, expr);
3062 /* Initialize the result. */
3063 pos = gfc_create_var (gfc_array_index_type, "pos");
3064 offset = gfc_create_var (gfc_array_index_type, "offset");
3065 type = gfc_typenode_for_spec (&expr->ts);
3067 /* Walk the arguments. */
3068 actual = expr->value.function.actual;
3069 arrayexpr = actual->expr;
3070 arrayss = gfc_walk_expr (arrayexpr);
3071 gcc_assert (arrayss != gfc_ss_terminator);
3073 actual = actual->next->next;
3074 gcc_assert (actual);
3075 maskexpr = actual->expr;
3077 if (maskexpr && maskexpr->rank != 0)
3079 maskss = gfc_walk_expr (maskexpr);
3080 gcc_assert (maskss != gfc_ss_terminator);
3085 if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
3087 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
3089 nonempty = fold_build2_loc (input_location, GT_EXPR,
3090 boolean_type_node, nonempty,
3091 gfc_index_zero_node);
3096 limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
3097 switch (arrayexpr->ts.type)
3100 tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind);
3104 n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
3105 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
3106 arrayexpr->ts.kind);
3113 /* We start with the most negative possible value for MAXLOC, and the most
3114 positive possible value for MINLOC. The most negative possible value is
3115 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3116 possible value is HUGE in both cases. */
3118 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
3119 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
3120 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp,
3121 build_int_cst (type, 1));
3123 gfc_add_modify (&se->pre, limit, tmp);
3125 /* Initialize the scalarizer. */
3126 gfc_init_loopinfo (&loop);
3127 gfc_add_ss_to_loop (&loop, arrayss);
3129 gfc_add_ss_to_loop (&loop, maskss);
3131 /* Initialize the loop. */
3132 gfc_conv_ss_startstride (&loop);
3134 /* The code generated can have more than one loop in sequence (see the
3135 comment at the function header). This doesn't work well with the
3136 scalarizer, which changes arrays' offset when the scalarization loops
3137 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
3138 are currently inlined in the scalar case only (for which loop is of rank
3139 one). As there is no dependency to care about in that case, there is no
3140 temporary, so that we can use the scalarizer temporary code to handle
3141 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
3142 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
3144 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
3145 should eventually go away. We could either create two loops properly,
3146 or find another way to save/restore the array offsets between the two
3147 loops (without conflicting with temporary management), or use a single
3148 loop minmaxloc implementation. See PR 31067. */
3149 loop.temp_dim = loop.dimen;
3150 gfc_conv_loop_setup (&loop, &expr->where);
3152 gcc_assert (loop.dimen == 1);
3153 if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0])
3154 nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3155 loop.from[0], loop.to[0]);
3159 /* Initialize the position to zero, following Fortran 2003. We are free
3160 to do this because Fortran 95 allows the result of an entirely false
3161 mask to be processor dependent. If we know at compile time the array
3162 is non-empty and no MASK is used, we can initialize to 1 to simplify
3164 if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
3165 gfc_add_modify (&loop.pre, pos,
3166 fold_build3_loc (input_location, COND_EXPR,
3167 gfc_array_index_type,
3168 nonempty, gfc_index_one_node,
3169 gfc_index_zero_node));
3172 gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
3173 lab1 = gfc_build_label_decl (NULL_TREE);
3174 TREE_USED (lab1) = 1;
3175 lab2 = gfc_build_label_decl (NULL_TREE);
3176 TREE_USED (lab2) = 1;
3179 /* An offset must be added to the loop
3180 counter to obtain the required position. */
3181 gcc_assert (loop.from[0]);
3183 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
3184 gfc_index_one_node, loop.from[0]);
3185 gfc_add_modify (&loop.pre, offset, tmp);
3187 gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1);
3189 gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1);
3190 /* Generate the loop body. */
3191 gfc_start_scalarized_body (&loop, &body);
3193 /* If we have a mask, only check this element if the mask is set. */
3196 gfc_init_se (&maskse, NULL);
3197 gfc_copy_loopinfo_to_se (&maskse, &loop);
3199 gfc_conv_expr_val (&maskse, maskexpr);
3200 gfc_add_block_to_block (&body, &maskse.pre);
3202 gfc_start_block (&block);
3205 gfc_init_block (&block);
3207 /* Compare with the current limit. */
3208 gfc_init_se (&arrayse, NULL);
3209 gfc_copy_loopinfo_to_se (&arrayse, &loop);
3210 arrayse.ss = arrayss;
3211 gfc_conv_expr_val (&arrayse, arrayexpr);
3212 gfc_add_block_to_block (&block, &arrayse.pre);
3214 /* We do the following if this is a more extreme value. */
3215 gfc_start_block (&ifblock);
3217 /* Assign the value to the limit... */
3218 gfc_add_modify (&ifblock, limit, arrayse.expr);
3220 if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
3222 stmtblock_t ifblock2;
3225 gfc_start_block (&ifblock2);
3226 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
3227 loop.loopvar[0], offset);
3228 gfc_add_modify (&ifblock2, pos, tmp);
3229 ifbody2 = gfc_finish_block (&ifblock2);
3230 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pos,
3231 gfc_index_zero_node);
3232 tmp = build3_v (COND_EXPR, cond, ifbody2,
3233 build_empty_stmt (input_location));
3234 gfc_add_expr_to_block (&block, tmp);
3237 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
3238 loop.loopvar[0], offset);
3239 gfc_add_modify (&ifblock, pos, tmp);
3242 gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
3244 ifbody = gfc_finish_block (&ifblock);
3246 if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
3249 cond = fold_build2_loc (input_location,
3250 op == GT_EXPR ? GE_EXPR : LE_EXPR,
3251 boolean_type_node, arrayse.expr, limit);
3253 cond = fold_build2_loc (input_location, op, boolean_type_node,
3254 arrayse.expr, limit);
3256 ifbody = build3_v (COND_EXPR, cond, ifbody,
3257 build_empty_stmt (input_location));
3259 gfc_add_expr_to_block (&block, ifbody);
3263 /* We enclose the above in if (mask) {...}. */
3264 tmp = gfc_finish_block (&block);
3266 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
3267 build_empty_stmt (input_location));
3270 tmp = gfc_finish_block (&block);
3271 gfc_add_expr_to_block (&body, tmp);
3275 gfc_trans_scalarized_loop_boundary (&loop, &body);
3277 if (HONOR_NANS (DECL_MODE (limit)))
3279 if (nonempty != NULL)
3281 ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node);
3282 tmp = build3_v (COND_EXPR, nonempty, ifbody,
3283 build_empty_stmt (input_location));
3284 gfc_add_expr_to_block (&loop.code[0], tmp);
3288 gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
3289 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
3291 /* If we have a mask, only check this element if the mask is set. */
3294 gfc_init_se (&maskse, NULL);
3295 gfc_copy_loopinfo_to_se (&maskse, &loop);
3297 gfc_conv_expr_val (&maskse, maskexpr);
3298 gfc_add_block_to_block (&body, &maskse.pre);
3300 gfc_start_block (&block);
3303 gfc_init_block (&block);
3305 /* Compare with the current limit. */
3306 gfc_init_se (&arrayse, NULL);
3307 gfc_copy_loopinfo_to_se (&arrayse, &loop);
3308 arrayse.ss = arrayss;
3309 gfc_conv_expr_val (&arrayse, arrayexpr);
3310 gfc_add_block_to_block (&block, &arrayse.pre);
3312 /* We do the following if this is a more extreme value. */
3313 gfc_start_block (&ifblock);
3315 /* Assign the value to the limit... */
3316 gfc_add_modify (&ifblock, limit, arrayse.expr);
3318 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
3319 loop.loopvar[0], offset);
3320 gfc_add_modify (&ifblock, pos, tmp);
3322 ifbody = gfc_finish_block (&ifblock);
3324 cond = fold_build2_loc (input_location, op, boolean_type_node,
3325 arrayse.expr, limit);
3327 tmp = build3_v (COND_EXPR, cond, ifbody,
3328 build_empty_stmt (input_location));
3329 gfc_add_expr_to_block (&block, tmp);
3333 /* We enclose the above in if (mask) {...}. */
3334 tmp = gfc_finish_block (&block);
3336 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
3337 build_empty_stmt (input_location));
3340 tmp = gfc_finish_block (&block);
3341 gfc_add_expr_to_block (&body, tmp);
3342 /* Avoid initializing loopvar[0] again, it should be left where
3343 it finished by the first loop. */
3344 loop.from[0] = loop.loopvar[0];
3347 gfc_trans_scalarizing_loops (&loop, &body);
3350 gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
3352 /* For a scalar mask, enclose the loop in an if statement. */
3353 if (maskexpr && maskss == NULL)
3355 gfc_init_se (&maskse, NULL);
3356 gfc_conv_expr_val (&maskse, maskexpr);
3357 gfc_init_block (&block);
3358 gfc_add_block_to_block (&block, &loop.pre);
3359 gfc_add_block_to_block (&block, &loop.post);
3360 tmp = gfc_finish_block (&block);
3362 /* For the else part of the scalar mask, just initialize
3363 the pos variable the same way as above. */
3365 gfc_init_block (&elseblock);
3366 gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
3367 elsetmp = gfc_finish_block (&elseblock);
3369 tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
3370 gfc_add_expr_to_block (&block, tmp);
3371 gfc_add_block_to_block (&se->pre, &block);
3375 gfc_add_block_to_block (&se->pre, &loop.pre);
3376 gfc_add_block_to_block (&se->pre, &loop.post);
3378 gfc_cleanup_loop (&loop);
3380 se->expr = convert (type, pos);
3383 /* Emit code for minval or maxval intrinsic. There are many different cases
3384 we need to handle. For performance reasons we sometimes create two
3385 loops instead of one, where the second one is much simpler.
3386 Examples for minval intrinsic:
3387 1) Result is an array, a call is generated
3388 2) Array mask is used and NaNs need to be supported, rank 1:
3393 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
3396 limit = nonempty ? NaN : huge (limit);
3398 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
3399 3) NaNs need to be supported, but it is known at compile time or cheaply
3400 at runtime whether array is nonempty or not, rank 1:
3403 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
3404 limit = (from <= to) ? NaN : huge (limit);
3406 while (S <= to) { limit = min (a[S], limit); S++; }
3407 4) Array mask is used and NaNs need to be supported, rank > 1:
3416 if (fast) limit = min (a[S1][S2], limit);
3419 if (a[S1][S2] <= limit) {
3430 limit = nonempty ? NaN : huge (limit);
3431 5) NaNs need to be supported, but it is known at compile time or cheaply
3432 at runtime whether array is nonempty or not, rank > 1:
3439 if (fast) limit = min (a[S1][S2], limit);
3441 if (a[S1][S2] <= limit) {
3451 limit = (nonempty_array) ? NaN : huge (limit);
3452 6) NaNs aren't supported, but infinities are. Array mask is used:
3457 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
3460 limit = nonempty ? limit : huge (limit);
3461 7) Same without array mask:
3464 while (S <= to) { limit = min (a[S], limit); S++; }
3465 limit = (from <= to) ? limit : huge (limit);
3466 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
3467 limit = huge (limit);
3469 while (S <= to) { limit = min (a[S], limit); S++); }
3471 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
3472 with array mask instead).
3473 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
3474 setting limit = huge (limit); in the else branch. */
3477 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
3487 tree huge_cst = NULL, nan_cst = NULL;
3489 stmtblock_t block, block2;
3491 gfc_actual_arglist *actual;
3496 gfc_expr *arrayexpr;
3502 gfc_conv_intrinsic_funcall (se, expr);
3506 type = gfc_typenode_for_spec (&expr->ts);
3507 /* Initialize the result. */
3508 limit = gfc_create_var (type, "limit");
3509 n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
3510 switch (expr->ts.type)
3513 huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
3515 if (HONOR_INFINITIES (DECL_MODE (limit)))
3517 REAL_VALUE_TYPE real;
3519 tmp = build_real (type, real);
3523 if (HONOR_NANS (DECL_MODE (limit)))
3525 REAL_VALUE_TYPE real;
3526 real_nan (&real, "", 1, DECL_MODE (limit));
3527 nan_cst = build_real (type, real);
3532 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
3539 /* We start with the most negative possible value for MAXVAL, and the most
3540 positive possible value for MINVAL. The most negative possible value is
3541 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3542 possible value is HUGE in both cases. */
3545 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
3547 huge_cst = fold_build1_loc (input_location, NEGATE_EXPR,
3548 TREE_TYPE (huge_cst), huge_cst);
3551 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
3552 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
3553 tmp, build_int_cst (type, 1));
3555 gfc_add_modify (&se->pre, limit, tmp);
3557 /* Walk the arguments. */
3558 actual = expr->value.function.actual;
3559 arrayexpr = actual->expr;
3560 arrayss = gfc_walk_expr (arrayexpr);
3561 gcc_assert (arrayss != gfc_ss_terminator);
3563 actual = actual->next->next;
3564 gcc_assert (actual);
3565 maskexpr = actual->expr;
3567 if (maskexpr && maskexpr->rank != 0)
3569 maskss = gfc_walk_expr (maskexpr);
3570 gcc_assert (maskss != gfc_ss_terminator);
3575 if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
3577 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
3579 nonempty = fold_build2_loc (input_location, GT_EXPR,
3580 boolean_type_node, nonempty,
3581 gfc_index_zero_node);
3586 /* Initialize the scalarizer. */
3587 gfc_init_loopinfo (&loop);
3588 gfc_add_ss_to_loop (&loop, arrayss);
3590 gfc_add_ss_to_loop (&loop, maskss);
3592 /* Initialize the loop. */
3593 gfc_conv_ss_startstride (&loop);
3595 /* The code generated can have more than one loop in sequence (see the
3596 comment at the function header). This doesn't work well with the
3597 scalarizer, which changes arrays' offset when the scalarization loops
3598 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
3599 are currently inlined in the scalar case only. As there is no dependency
3600 to care about in that case, there is no temporary, so that we can use the
3601 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
3602 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
3603 gfc_trans_scalarized_loop_boundary even later to restore offset.
3604 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
3605 should eventually go away. We could either create two loops properly,
3606 or find another way to save/restore the array offsets between the two
3607 loops (without conflicting with temporary management), or use a single
3608 loop minmaxval implementation. See PR 31067. */
3609 loop.temp_dim = loop.dimen;
3610 gfc_conv_loop_setup (&loop, &expr->where);
3612 if (nonempty == NULL && maskss == NULL
3613 && loop.dimen == 1 && loop.from[0] && loop.to[0])
3614 nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3615 loop.from[0], loop.to[0]);
3616 nonempty_var = NULL;
3617 if (nonempty == NULL
3618 && (HONOR_INFINITIES (DECL_MODE (limit))
3619 || HONOR_NANS (DECL_MODE (limit))))
3621 nonempty_var = gfc_create_var (boolean_type_node, "nonempty");
3622 gfc_add_modify (&se->pre, nonempty_var, boolean_false_node);
3623 nonempty = nonempty_var;
3627 if (HONOR_NANS (DECL_MODE (limit)))
3629 if (loop.dimen == 1)
3631 lab = gfc_build_label_decl (NULL_TREE);
3632 TREE_USED (lab) = 1;
3636 fast = gfc_create_var (boolean_type_node, "fast");
3637 gfc_add_modify (&se->pre, fast, boolean_false_node);
3641 gfc_mark_ss_chain_used (arrayss, lab ? 3 : 1);
3643 gfc_mark_ss_chain_used (maskss, lab ? 3 : 1);
3644 /* Generate the loop body. */
3645 gfc_start_scalarized_body (&loop, &body);
3647 /* If we have a mask, only add this element if the mask is set. */
3650 gfc_init_se (&maskse, NULL);
3651 gfc_copy_loopinfo_to_se (&maskse, &loop);
3653 gfc_conv_expr_val (&maskse, maskexpr);
3654 gfc_add_block_to_block (&body, &maskse.pre);
3656 gfc_start_block (&block);
3659 gfc_init_block (&block);
3661 /* Compare with the current limit. */
3662 gfc_init_se (&arrayse, NULL);
3663 gfc_copy_loopinfo_to_se (&arrayse, &loop);
3664 arrayse.ss = arrayss;
3665 gfc_conv_expr_val (&arrayse, arrayexpr);
3666 gfc_add_block_to_block (&block, &arrayse.pre);
3668 gfc_init_block (&block2);
3671 gfc_add_modify (&block2, nonempty_var, boolean_true_node);
3673 if (HONOR_NANS (DECL_MODE (limit)))
3675 tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
3676 boolean_type_node, arrayse.expr, limit);
3678 ifbody = build1_v (GOTO_EXPR, lab);
3681 stmtblock_t ifblock;
3683 gfc_init_block (&ifblock);
3684 gfc_add_modify (&ifblock, limit, arrayse.expr);
3685 gfc_add_modify (&ifblock, fast, boolean_true_node);
3686 ifbody = gfc_finish_block (&ifblock);
3688 tmp = build3_v (COND_EXPR, tmp, ifbody,
3689 build_empty_stmt (input_location));
3690 gfc_add_expr_to_block (&block2, tmp);
3694 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3696 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
3698 tmp = fold_build2_loc (input_location, op, boolean_type_node,
3699 arrayse.expr, limit);
3700 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
3701 tmp = build3_v (COND_EXPR, tmp, ifbody,
3702 build_empty_stmt (input_location));
3703 gfc_add_expr_to_block (&block2, tmp);
3707 tmp = fold_build2_loc (input_location,
3708 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
3709 type, arrayse.expr, limit);
3710 gfc_add_modify (&block2, limit, tmp);
3716 tree elsebody = gfc_finish_block (&block2);
3718 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3720 if (HONOR_NANS (DECL_MODE (limit))
3721 || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
3723 tmp = fold_build2_loc (input_location, op, boolean_type_node,
3724 arrayse.expr, limit);
3725 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
3726 ifbody = build3_v (COND_EXPR, tmp, ifbody,
3727 build_empty_stmt (input_location));
3731 tmp = fold_build2_loc (input_location,
3732 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
3733 type, arrayse.expr, limit);
3734 ifbody = build2_v (MODIFY_EXPR, limit, tmp);
3736 tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
3737 gfc_add_expr_to_block (&block, tmp);
3740 gfc_add_block_to_block (&block, &block2);
3742 gfc_add_block_to_block (&block, &arrayse.post);
3744 tmp = gfc_finish_block (&block);
3746 /* We enclose the above in if (mask) {...}. */
3747 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
3748 build_empty_stmt (input_location));
3749 gfc_add_expr_to_block (&body, tmp);
3753 gfc_trans_scalarized_loop_boundary (&loop, &body);
3755 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
3757 gfc_add_modify (&loop.code[0], limit, tmp);
3758 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
3760 /* If we have a mask, only add this element if the mask is set. */
3763 gfc_init_se (&maskse, NULL);
3764 gfc_copy_loopinfo_to_se (&maskse, &loop);
3766 gfc_conv_expr_val (&maskse, maskexpr);
3767 gfc_add_block_to_block (&body, &maskse.pre);
3769 gfc_start_block (&block);
3772 gfc_init_block (&block);
3774 /* Compare with the current limit. */
3775 gfc_init_se (&arrayse, NULL);
3776 gfc_copy_loopinfo_to_se (&arrayse, &loop);
3777 arrayse.ss = arrayss;
3778 gfc_conv_expr_val (&arrayse, arrayexpr);
3779 gfc_add_block_to_block (&block, &arrayse.pre);
3781 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3783 if (HONOR_NANS (DECL_MODE (limit))
3784 || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
3786 tmp = fold_build2_loc (input_location, op, boolean_type_node,
3787 arrayse.expr, limit);
3788 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
3789 tmp = build3_v (COND_EXPR, tmp, ifbody,
3790 build_empty_stmt (input_location));
3791 gfc_add_expr_to_block (&block, tmp);
3795 tmp = fold_build2_loc (input_location,
3796 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
3797 type, arrayse.expr, limit);
3798 gfc_add_modify (&block, limit, tmp);
3801 gfc_add_block_to_block (&block, &arrayse.post);
3803 tmp = gfc_finish_block (&block);
3805 /* We enclose the above in if (mask) {...}. */
3806 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
3807 build_empty_stmt (input_location));
3808 gfc_add_expr_to_block (&body, tmp);
3809 /* Avoid initializing loopvar[0] again, it should be left where
3810 it finished by the first loop. */
3811 loop.from[0] = loop.loopvar[0];
3813 gfc_trans_scalarizing_loops (&loop, &body);
3817 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
3819 ifbody = build2_v (MODIFY_EXPR, limit, tmp);
3820 tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
3822 gfc_add_expr_to_block (&loop.pre, tmp);
3824 else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
3826 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit,
3828 gfc_add_modify (&loop.pre, limit, tmp);
3831 /* For a scalar mask, enclose the loop in an if statement. */
3832 if (maskexpr && maskss == NULL)
3836 gfc_init_se (&maskse, NULL);
3837 gfc_conv_expr_val (&maskse, maskexpr);
3838 gfc_init_block (&block);
3839 gfc_add_block_to_block (&block, &loop.pre);
3840 gfc_add_block_to_block (&block, &loop.post);
3841 tmp = gfc_finish_block (&block);
3843 if (HONOR_INFINITIES (DECL_MODE (limit)))
3844 else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
3846 else_stmt = build_empty_stmt (input_location);
3847 tmp = build3_v (COND_EXPR, maskse.expr, tmp, else_stmt);
3848 gfc_add_expr_to_block (&block, tmp);
3849 gfc_add_block_to_block (&se->pre, &block);
3853 gfc_add_block_to_block (&se->pre, &loop.pre);
3854 gfc_add_block_to_block (&se->pre, &loop.post);
3857 gfc_cleanup_loop (&loop);
3862 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
3864 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
3870 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3871 type = TREE_TYPE (args[0]);
3873 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3874 build_int_cst (type, 1), args[1]);
3875 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp);
3876 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
3877 build_int_cst (type, 0));
3878 type = gfc_typenode_for_spec (&expr->ts);
3879 se->expr = convert (type, tmp);
3883 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
3885 gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op)
3889 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3891 /* Convert both arguments to the unsigned type of the same size. */
3892 args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]);
3893 args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]);
3895 /* If they have unequal type size, convert to the larger one. */
3896 if (TYPE_PRECISION (TREE_TYPE (args[0]))
3897 > TYPE_PRECISION (TREE_TYPE (args[1])))
3898 args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
3899 else if (TYPE_PRECISION (TREE_TYPE (args[1]))
3900 > TYPE_PRECISION (TREE_TYPE (args[0])))
3901 args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
3903 /* Now, we compare them. */
3904 se->expr = fold_build2_loc (input_location, op, boolean_type_node,
3909 /* Generate code to perform the specified operation. */
3911 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
3915 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3916 se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]),
3922 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
3926 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3927 se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR,
3928 TREE_TYPE (arg), arg);
3931 /* Set or clear a single bit. */
3933 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
3940 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3941 type = TREE_TYPE (args[0]);
3943 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3944 build_int_cst (type, 1), args[1]);
3950 tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp);
3952 se->expr = fold_build2_loc (input_location, op, type, args[0], tmp);
3955 /* Extract a sequence of bits.
3956 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
3958 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
3965 gfc_conv_intrinsic_function_args (se, expr, args, 3);
3966 type = TREE_TYPE (args[0]);
3968 mask = build_int_cst (type, -1);
3969 mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]);
3970 mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask);
3972 tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]);
3974 se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask);
3978 gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
3981 tree args[2], type, num_bits, cond;
3983 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3985 args[0] = gfc_evaluate_now (args[0], &se->pre);
3986 args[1] = gfc_evaluate_now (args[1], &se->pre);
3987 type = TREE_TYPE (args[0]);
3990 args[0] = fold_convert (unsigned_type_for (type), args[0]);
3992 gcc_assert (right_shift);
3994 se->expr = fold_build2_loc (input_location,
3995 right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
3996 TREE_TYPE (args[0]), args[0], args[1]);
3999 se->expr = fold_convert (type, se->expr);
4001 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4002 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4004 num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
4005 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
4008 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
4009 build_int_cst (type, 0), se->expr);
4012 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
4014 : ((shift >= 0) ? i << shift : i >> -shift)
4015 where all shifts are logical shifts. */
4017 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
4029 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4031 args[0] = gfc_evaluate_now (args[0], &se->pre);
4032 args[1] = gfc_evaluate_now (args[1], &se->pre);
4034 type = TREE_TYPE (args[0]);
4035 utype = unsigned_type_for (type);
4037 width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]),
4040 /* Left shift if positive. */
4041 lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width);
4043 /* Right shift if negative.
4044 We convert to an unsigned type because we want a logical shift.
4045 The standard doesn't define the case of shifting negative
4046 numbers, and we try to be compatible with other compilers, most
4047 notably g77, here. */
4048 rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR,
4049 utype, convert (utype, args[0]), width));
4051 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, args[1],
4052 build_int_cst (TREE_TYPE (args[1]), 0));
4053 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift);
4055 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
4056 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
4058 num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
4059 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, width,
4061 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
4062 build_int_cst (type, 0), tmp);
4066 /* Circular shift. AKA rotate or barrel shift. */
4069 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
4077 unsigned int num_args;
4079 num_args = gfc_intrinsic_argument_list_length (expr);
4080 args = XALLOCAVEC (tree, num_args);
4082 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
4086 /* Use a library function for the 3 parameter version. */
4087 tree int4type = gfc_get_int_type (4);
4089 type = TREE_TYPE (args[0]);
4090 /* We convert the first argument to at least 4 bytes, and
4091 convert back afterwards. This removes the need for library
4092 functions for all argument sizes, and function will be
4093 aligned to at least 32 bits, so there's no loss. */
4094 if (expr->ts.kind < 4)
4095 args[0] = convert (int4type, args[0]);
4097 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
4098 need loads of library functions. They cannot have values >
4099 BIT_SIZE (I) so the conversion is safe. */
4100 args[1] = convert (int4type, args[1]);
4101 args[2] = convert (int4type, args[2]);
4103 switch (expr->ts.kind)
4108 tmp = gfor_fndecl_math_ishftc4;
4111 tmp = gfor_fndecl_math_ishftc8;
4114 tmp = gfor_fndecl_math_ishftc16;
4119 se->expr = build_call_expr_loc (input_location,
4120 tmp, 3, args[0], args[1], args[2]);
4121 /* Convert the result back to the original type, if we extended
4122 the first argument's width above. */
4123 if (expr->ts.kind < 4)
4124 se->expr = convert (type, se->expr);
4128 type = TREE_TYPE (args[0]);
4130 /* Evaluate arguments only once. */
4131 args[0] = gfc_evaluate_now (args[0], &se->pre);
4132 args[1] = gfc_evaluate_now (args[1], &se->pre);
4134 /* Rotate left if positive. */
4135 lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]);
4137 /* Rotate right if negative. */
4138 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]),
4140 rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp);
4142 zero = build_int_cst (TREE_TYPE (args[1]), 0);
4143 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, args[1],
4145 rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot);
4147 /* Do nothing if shift == 0. */
4148 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, args[1],
4150 se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0],
4155 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
4156 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
4158 The conditional expression is necessary because the result of LEADZ(0)
4159 is defined, but the result of __builtin_clz(0) is undefined for most
4162 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
4163 difference in bit size between the argument of LEADZ and the C int. */
4166 gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
4178 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4179 argsize = TYPE_PRECISION (TREE_TYPE (arg));
4181 /* Which variant of __builtin_clz* should we call? */
4182 if (argsize <= INT_TYPE_SIZE)
4184 arg_type = unsigned_type_node;
4185 func = builtin_decl_explicit (BUILT_IN_CLZ);
4187 else if (argsize <= LONG_TYPE_SIZE)
4189 arg_type = long_unsigned_type_node;
4190 func = builtin_decl_explicit (BUILT_IN_CLZL);
4192 else if (argsize <= LONG_LONG_TYPE_SIZE)
4194 arg_type = long_long_unsigned_type_node;
4195 func = builtin_decl_explicit (BUILT_IN_CLZLL);
4199 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
4200 arg_type = gfc_build_uint_type (argsize);
4204 /* Convert the actual argument twice: first, to the unsigned type of the
4205 same size; then, to the proper argument type for the built-in
4206 function. But the return type is of the default INTEGER kind. */
4207 arg = fold_convert (gfc_build_uint_type (argsize), arg);
4208 arg = fold_convert (arg_type, arg);
4209 arg = gfc_evaluate_now (arg, &se->pre);
4210 result_type = gfc_get_int_type (gfc_default_integer_kind);
4212 /* Compute LEADZ for the case i .ne. 0. */
4215 s = TYPE_PRECISION (arg_type) - argsize;
4216 tmp = fold_convert (result_type,
4217 build_call_expr_loc (input_location, func,
4219 leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type,
4220 tmp, build_int_cst (result_type, s));
4224 /* We end up here if the argument type is larger than 'long long'.
4225 We generate this code:
4227 if (x & (ULL_MAX << ULL_SIZE) != 0)
4228 return clzll ((unsigned long long) (x >> ULLSIZE));
4230 return ULL_SIZE + clzll ((unsigned long long) x);
4231 where ULL_MAX is the largest value that a ULL_MAX can hold
4232 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4233 is the bit-size of the long long type (64 in this example). */
4234 tree ullsize, ullmax, tmp1, tmp2, btmp;
4236 ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
4237 ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
4238 long_long_unsigned_type_node,
4239 build_int_cst (long_long_unsigned_type_node,
4242 cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type,
4243 fold_convert (arg_type, ullmax), ullsize);
4244 cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type,
4246 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
4247 cond, build_int_cst (arg_type, 0));
4249 tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
4251 tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
4252 btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
4253 tmp1 = fold_convert (result_type,
4254 build_call_expr_loc (input_location, btmp, 1, tmp1));
4256 tmp2 = fold_convert (long_long_unsigned_type_node, arg);
4257 btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
4258 tmp2 = fold_convert (result_type,
4259 build_call_expr_loc (input_location, btmp, 1, tmp2));
4260 tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
4263 leadz = fold_build3_loc (input_location, COND_EXPR, result_type,
4267 /* Build BIT_SIZE. */
4268 bit_size = build_int_cst (result_type, argsize);
4270 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4271 arg, build_int_cst (arg_type, 0));
4272 se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
4277 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
4279 The conditional expression is necessary because the result of TRAILZ(0)
4280 is defined, but the result of __builtin_ctz(0) is undefined for most
4284 gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
4295 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4296 argsize = TYPE_PRECISION (TREE_TYPE (arg));
4298 /* Which variant of __builtin_ctz* should we call? */
4299 if (argsize <= INT_TYPE_SIZE)
4301 arg_type = unsigned_type_node;
4302 func = builtin_decl_explicit (BUILT_IN_CTZ);
4304 else if (argsize <= LONG_TYPE_SIZE)
4306 arg_type = long_unsigned_type_node;
4307 func = builtin_decl_explicit (BUILT_IN_CTZL);
4309 else if (argsize <= LONG_LONG_TYPE_SIZE)
4311 arg_type = long_long_unsigned_type_node;
4312 func = builtin_decl_explicit (BUILT_IN_CTZLL);
4316 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
4317 arg_type = gfc_build_uint_type (argsize);
4321 /* Convert the actual argument twice: first, to the unsigned type of the
4322 same size; then, to the proper argument type for the built-in
4323 function. But the return type is of the default INTEGER kind. */
4324 arg = fold_convert (gfc_build_uint_type (argsize), arg);
4325 arg = fold_convert (arg_type, arg);
4326 arg = gfc_evaluate_now (arg, &se->pre);
4327 result_type = gfc_get_int_type (gfc_default_integer_kind);
4329 /* Compute TRAILZ for the case i .ne. 0. */
4331 trailz = fold_convert (result_type, build_call_expr_loc (input_location,
4335 /* We end up here if the argument type is larger than 'long long'.
4336 We generate this code:
4338 if ((x & ULL_MAX) == 0)
4339 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
4341 return ctzll ((unsigned long long) x);
4343 where ULL_MAX is the largest value that a ULL_MAX can hold
4344 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4345 is the bit-size of the long long type (64 in this example). */
4346 tree ullsize, ullmax, tmp1, tmp2, btmp;
4348 ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
4349 ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
4350 long_long_unsigned_type_node,
4351 build_int_cst (long_long_unsigned_type_node, 0));
4353 cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg,
4354 fold_convert (arg_type, ullmax));
4355 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, cond,
4356 build_int_cst (arg_type, 0));
4358 tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
4360 tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
4361 btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
4362 tmp1 = fold_convert (result_type,
4363 build_call_expr_loc (input_location, btmp, 1, tmp1));
4364 tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
4367 tmp2 = fold_convert (long_long_unsigned_type_node, arg);
4368 btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
4369 tmp2 = fold_convert (result_type,
4370 build_call_expr_loc (input_location, btmp, 1, tmp2));
4372 trailz = fold_build3_loc (input_location, COND_EXPR, result_type,
4376 /* Build BIT_SIZE. */
4377 bit_size = build_int_cst (result_type, argsize);
4379 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4380 arg, build_int_cst (arg_type, 0));
4381 se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
4385 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
4386 for types larger than "long long", we call the long long built-in for
4387 the lower and higher bits and combine the result. */
4390 gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
4398 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4399 argsize = TYPE_PRECISION (TREE_TYPE (arg));
4400 result_type = gfc_get_int_type (gfc_default_integer_kind);
4402 /* Which variant of the builtin should we call? */
4403 if (argsize <= INT_TYPE_SIZE)
4405 arg_type = unsigned_type_node;
4406 func = builtin_decl_explicit (parity
4408 : BUILT_IN_POPCOUNT);
4410 else if (argsize <= LONG_TYPE_SIZE)
4412 arg_type = long_unsigned_type_node;
4413 func = builtin_decl_explicit (parity
4415 : BUILT_IN_POPCOUNTL);
4417 else if (argsize <= LONG_LONG_TYPE_SIZE)
4419 arg_type = long_long_unsigned_type_node;
4420 func = builtin_decl_explicit (parity
4422 : BUILT_IN_POPCOUNTLL);
4426 /* Our argument type is larger than 'long long', which mean none
4427 of the POPCOUNT builtins covers it. We thus call the 'long long'
4428 variant multiple times, and add the results. */
4429 tree utype, arg2, call1, call2;
4431 /* For now, we only cover the case where argsize is twice as large
4433 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
4435 func = builtin_decl_explicit (parity
4437 : BUILT_IN_POPCOUNTLL);
4439 /* Convert it to an integer, and store into a variable. */
4440 utype = gfc_build_uint_type (argsize);
4441 arg = fold_convert (utype, arg);
4442 arg = gfc_evaluate_now (arg, &se->pre);
4444 /* Call the builtin twice. */
4445 call1 = build_call_expr_loc (input_location, func, 1,
4446 fold_convert (long_long_unsigned_type_node,
4449 arg2 = fold_build2_loc (input_location, RSHIFT_EXPR, utype, arg,
4450 build_int_cst (utype, LONG_LONG_TYPE_SIZE));
4451 call2 = build_call_expr_loc (input_location, func, 1,
4452 fold_convert (long_long_unsigned_type_node,
4455 /* Combine the results. */
4457 se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, result_type,
4460 se->expr = fold_build2_loc (input_location, PLUS_EXPR, result_type,
4466 /* Convert the actual argument twice: first, to the unsigned type of the
4467 same size; then, to the proper argument type for the built-in
4469 arg = fold_convert (gfc_build_uint_type (argsize), arg);
4470 arg = fold_convert (arg_type, arg);
4472 se->expr = fold_convert (result_type,
4473 build_call_expr_loc (input_location, func, 1, arg));
4477 /* Process an intrinsic with unspecified argument-types that has an optional
4478 argument (which could be of type character), e.g. EOSHIFT. For those, we
4479 need to append the string length of the optional argument if it is not
4480 present and the type is really character.
4481 primary specifies the position (starting at 1) of the non-optional argument
4482 specifying the type and optional gives the position of the optional
4483 argument in the arglist. */
4486 conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
4487 unsigned primary, unsigned optional)
4489 gfc_actual_arglist* prim_arg;
4490 gfc_actual_arglist* opt_arg;
4492 gfc_actual_arglist* arg;
4494 VEC(tree,gc) *append_args;
4496 /* Find the two arguments given as position. */
4500 for (arg = expr->value.function.actual; arg; arg = arg->next)
4504 if (cur_pos == primary)
4506 if (cur_pos == optional)
4509 if (cur_pos >= primary && cur_pos >= optional)
4512 gcc_assert (prim_arg);
4513 gcc_assert (prim_arg->expr);
4514 gcc_assert (opt_arg);
4516 /* If we do have type CHARACTER and the optional argument is really absent,
4517 append a dummy 0 as string length. */
4519 if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
4523 dummy = build_int_cst (gfc_charlen_type_node, 0);
4524 append_args = VEC_alloc (tree, gc, 1);
4525 VEC_quick_push (tree, append_args, dummy);
4528 /* Build the call itself. */
4529 sym = gfc_get_symbol_for_expr (expr);
4530 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
4536 /* The length of a character string. */
4538 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
4548 gcc_assert (!se->ss);
4550 arg = expr->value.function.actual->expr;
4552 type = gfc_typenode_for_spec (&expr->ts);
4553 switch (arg->expr_type)
4556 len = build_int_cst (gfc_charlen_type_node, arg->value.character.length);
4560 /* Obtain the string length from the function used by
4561 trans-array.c(gfc_trans_array_constructor). */
4563 get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
4567 if (arg->ref == NULL
4568 || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
4570 /* This doesn't catch all cases.
4571 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
4572 and the surrounding thread. */
4573 sym = arg->symtree->n.sym;
4574 decl = gfc_get_symbol_decl (sym);
4575 if (decl == current_function_decl && sym->attr.function
4576 && (sym->result == sym))
4577 decl = gfc_get_fake_result_decl (sym, 0);
4579 len = sym->ts.u.cl->backend_decl;
4584 /* Otherwise fall through. */
4587 /* Anybody stupid enough to do this deserves inefficient code. */
4588 ss = gfc_walk_expr (arg);
4589 gfc_init_se (&argse, se);
4590 if (ss == gfc_ss_terminator)
4591 gfc_conv_expr (&argse, arg);
4593 gfc_conv_expr_descriptor (&argse, arg, ss);
4594 gfc_add_block_to_block (&se->pre, &argse.pre);
4595 gfc_add_block_to_block (&se->post, &argse.post);
4596 len = argse.string_length;
4599 se->expr = convert (type, len);
4602 /* The length of a character string not including trailing blanks. */
4604 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
4606 int kind = expr->value.function.actual->expr->ts.kind;
4607 tree args[2], type, fndecl;
4609 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4610 type = gfc_typenode_for_spec (&expr->ts);
4613 fndecl = gfor_fndecl_string_len_trim;
4615 fndecl = gfor_fndecl_string_len_trim_char4;
4619 se->expr = build_call_expr_loc (input_location,
4620 fndecl, 2, args[0], args[1]);
4621 se->expr = convert (type, se->expr);
4625 /* Returns the starting position of a substring within a string. */
4628 gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
4631 tree logical4_type_node = gfc_get_logical_type (4);
4635 unsigned int num_args;
4637 args = XALLOCAVEC (tree, 5);
4639 /* Get number of arguments; characters count double due to the
4640 string length argument. Kind= is not passed to the library
4641 and thus ignored. */
4642 if (expr->value.function.actual->next->next->expr == NULL)
4647 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
4648 type = gfc_typenode_for_spec (&expr->ts);
4651 args[4] = build_int_cst (logical4_type_node, 0);
4653 args[4] = convert (logical4_type_node, args[4]);
4655 fndecl = build_addr (function, current_function_decl);
4656 se->expr = build_call_array_loc (input_location,
4657 TREE_TYPE (TREE_TYPE (function)), fndecl,
4659 se->expr = convert (type, se->expr);
4663 /* The ascii value for a single character. */
4665 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
4667 tree args[2], type, pchartype;
4669 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4670 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
4671 pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
4672 args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]);
4673 type = gfc_typenode_for_spec (&expr->ts);
4675 se->expr = build_fold_indirect_ref_loc (input_location,
4677 se->expr = convert (type, se->expr);
4681 /* Intrinsic ISNAN calls __builtin_isnan. */
4684 gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
4688 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4689 se->expr = build_call_expr_loc (input_location,
4690 builtin_decl_explicit (BUILT_IN_ISNAN),
4692 STRIP_TYPE_NOPS (se->expr);
4693 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
4697 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
4698 their argument against a constant integer value. */
4701 gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
4705 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4706 se->expr = fold_build2_loc (input_location, EQ_EXPR,
4707 gfc_typenode_for_spec (&expr->ts),
4708 arg, build_int_cst (TREE_TYPE (arg), value));
4713 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
4716 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
4724 unsigned int num_args;
4726 num_args = gfc_intrinsic_argument_list_length (expr);
4727 args = XALLOCAVEC (tree, num_args);
4729 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
4730 if (expr->ts.type != BT_CHARACTER)
4738 /* We do the same as in the non-character case, but the argument
4739 list is different because of the string length arguments. We
4740 also have to set the string length for the result. */
4747 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
4749 se->string_length = len;
4751 type = TREE_TYPE (tsource);
4752 se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource,
4753 fold_convert (type, fsource));
4757 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
4760 gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr)
4762 tree args[3], mask, type;
4764 gfc_conv_intrinsic_function_args (se, expr, args, 3);
4765 mask = gfc_evaluate_now (args[2], &se->pre);
4767 type = TREE_TYPE (args[0]);
4768 gcc_assert (TREE_TYPE (args[1]) == type);
4769 gcc_assert (TREE_TYPE (mask) == type);
4771 args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask);
4772 args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1],
4773 fold_build1_loc (input_location, BIT_NOT_EXPR,
4775 se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
4780 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
4781 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
4784 gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left)
4786 tree arg, allones, type, utype, res, cond, bitsize;
4789 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4790 arg = gfc_evaluate_now (arg, &se->pre);
4792 type = gfc_get_int_type (expr->ts.kind);
4793 utype = unsigned_type_for (type);
4795 i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
4796 bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size);
4798 allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype,
4799 build_int_cst (utype, 0));
4803 /* Left-justified mask. */
4804 res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg),
4806 res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
4807 fold_convert (utype, res));
4809 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
4810 smaller than type width. */
4811 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg,
4812 build_int_cst (TREE_TYPE (arg), 0));
4813 res = fold_build3_loc (input_location, COND_EXPR, utype, cond,
4814 build_int_cst (utype, 0), res);
4818 /* Right-justified mask. */
4819 res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
4820 fold_convert (utype, arg));
4821 res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res);
4823 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
4824 strictly smaller than type width. */
4825 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4827 res = fold_build3_loc (input_location, COND_EXPR, utype,
4828 cond, allones, res);
4831 se->expr = fold_convert (type, res);
4835 /* FRACTION (s) is translated into frexp (s, &dummy_int). */
4837 gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
4839 tree arg, type, tmp, frexp;
4841 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
4843 type = gfc_typenode_for_spec (&expr->ts);
4844 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4845 tmp = gfc_create_var (integer_type_node, NULL);
4846 se->expr = build_call_expr_loc (input_location, frexp, 2,
4847 fold_convert (type, arg),
4848 gfc_build_addr_expr (NULL_TREE, tmp));
4849 se->expr = fold_convert (type, se->expr);
4853 /* NEAREST (s, dir) is translated into
4854 tmp = copysign (HUGE_VAL, dir);
4855 return nextafter (s, tmp);
4858 gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
4860 tree args[2], type, tmp, nextafter, copysign, huge_val;
4862 nextafter = gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind);
4863 copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
4865 type = gfc_typenode_for_spec (&expr->ts);
4866 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4868 huge_val = gfc_build_inf_or_huge (type, expr->ts.kind);
4869 tmp = build_call_expr_loc (input_location, copysign, 2, huge_val,
4870 fold_convert (type, args[1]));
4871 se->expr = build_call_expr_loc (input_location, nextafter, 2,
4872 fold_convert (type, args[0]), tmp);
4873 se->expr = fold_convert (type, se->expr);
4877 /* SPACING (s) is translated into
4885 e = MAX_EXPR (e, emin);
4886 res = scalbn (1., e);
4890 where prec is the precision of s, gfc_real_kinds[k].digits,
4891 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
4892 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
4895 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
4897 tree arg, type, prec, emin, tiny, res, e;
4898 tree cond, tmp, frexp, scalbn;
4902 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
4903 prec = build_int_cst (integer_type_node, gfc_real_kinds[k].digits);
4904 emin = build_int_cst (integer_type_node, gfc_real_kinds[k].min_exponent - 1);
4905 tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
4907 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
4908 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
4910 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4911 arg = gfc_evaluate_now (arg, &se->pre);
4913 type = gfc_typenode_for_spec (&expr->ts);
4914 e = gfc_create_var (integer_type_node, NULL);
4915 res = gfc_create_var (type, NULL);
4918 /* Build the block for s /= 0. */
4919 gfc_start_block (&block);
4920 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
4921 gfc_build_addr_expr (NULL_TREE, e));
4922 gfc_add_expr_to_block (&block, tmp);
4924 tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, e,
4926 gfc_add_modify (&block, e, fold_build2_loc (input_location, MAX_EXPR,
4927 integer_type_node, tmp, emin));
4929 tmp = build_call_expr_loc (input_location, scalbn, 2,
4930 build_real_from_int_cst (type, integer_one_node), e);
4931 gfc_add_modify (&block, res, tmp);
4933 /* Finish by building the IF statement. */
4934 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg,
4935 build_real_from_int_cst (type, integer_zero_node));
4936 tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
4937 gfc_finish_block (&block));
4939 gfc_add_expr_to_block (&se->pre, tmp);
4944 /* RRSPACING (s) is translated into
4951 x = scalbn (x, precision - e);
4955 where precision is gfc_real_kinds[k].digits. */
4958 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
4960 tree arg, type, e, x, cond, stmt, tmp, frexp, scalbn, fabs;
4964 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
4965 prec = gfc_real_kinds[k].digits;
4967 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
4968 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
4969 fabs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
4971 type = gfc_typenode_for_spec (&expr->ts);
4972 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4973 arg = gfc_evaluate_now (arg, &se->pre);
4975 e = gfc_create_var (integer_type_node, NULL);
4976 x = gfc_create_var (type, NULL);
4977 gfc_add_modify (&se->pre, x,
4978 build_call_expr_loc (input_location, fabs, 1, arg));
4981 gfc_start_block (&block);
4982 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
4983 gfc_build_addr_expr (NULL_TREE, e));
4984 gfc_add_expr_to_block (&block, tmp);
4986 tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
4987 build_int_cst (integer_type_node, prec), e);
4988 tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp);
4989 gfc_add_modify (&block, x, tmp);
4990 stmt = gfc_finish_block (&block);
4992 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, x,
4993 build_real_from_int_cst (type, integer_zero_node));
4994 tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
4995 gfc_add_expr_to_block (&se->pre, tmp);
4997 se->expr = fold_convert (type, x);
5001 /* SCALE (s, i) is translated into scalbn (s, i). */
5003 gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
5005 tree args[2], type, scalbn;
5007 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
5009 type = gfc_typenode_for_spec (&expr->ts);
5010 gfc_conv_intrinsic_function_args (se, expr, args, 2);
5011 se->expr = build_call_expr_loc (input_location, scalbn, 2,
5012 fold_convert (type, args[0]),
5013 fold_convert (integer_type_node, args[1]));
5014 se->expr = fold_convert (type, se->expr);
5018 /* SET_EXPONENT (s, i) is translated into
5019 scalbn (frexp (s, &dummy_int), i). */
5021 gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
5023 tree args[2], type, tmp, frexp, scalbn;
5025 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
5026 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
5028 type = gfc_typenode_for_spec (&expr->ts);
5029 gfc_conv_intrinsic_function_args (se, expr, args, 2);
5031 tmp = gfc_create_var (integer_type_node, NULL);
5032 tmp = build_call_expr_loc (input_location, frexp, 2,
5033 fold_convert (type, args[0]),
5034 gfc_build_addr_expr (NULL_TREE, tmp));
5035 se->expr = build_call_expr_loc (input_location, scalbn, 2, tmp,
5036 fold_convert (integer_type_node, args[1]));
5037 se->expr = fold_convert (type, se->expr);
5042 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
5044 gfc_actual_arglist *actual;
5052 gfc_init_se (&argse, NULL);
5053 actual = expr->value.function.actual;
5055 if (actual->expr->ts.type == BT_CLASS)
5056 gfc_add_class_array_ref (actual->expr);
5058 ss = gfc_walk_expr (actual->expr);
5059 gcc_assert (ss != gfc_ss_terminator);
5060 argse.want_pointer = 1;
5061 argse.data_not_needed = 1;
5062 gfc_conv_expr_descriptor (&argse, actual->expr, ss);
5063 gfc_add_block_to_block (&se->pre, &argse.pre);
5064 gfc_add_block_to_block (&se->post, &argse.post);
5065 arg1 = gfc_evaluate_now (argse.expr, &se->pre);
5067 /* Build the call to size0. */
5068 fncall0 = build_call_expr_loc (input_location,
5069 gfor_fndecl_size0, 1, arg1);
5071 actual = actual->next;
5075 gfc_init_se (&argse, NULL);
5076 gfc_conv_expr_type (&argse, actual->expr,
5077 gfc_array_index_type);
5078 gfc_add_block_to_block (&se->pre, &argse.pre);
5080 /* Unusually, for an intrinsic, size does not exclude
5081 an optional arg2, so we must test for it. */
5082 if (actual->expr->expr_type == EXPR_VARIABLE
5083 && actual->expr->symtree->n.sym->attr.dummy
5084 && actual->expr->symtree->n.sym->attr.optional)
5087 /* Build the call to size1. */
5088 fncall1 = build_call_expr_loc (input_location,
5089 gfor_fndecl_size1, 2,
5092 gfc_init_se (&argse, NULL);
5093 argse.want_pointer = 1;
5094 argse.data_not_needed = 1;
5095 gfc_conv_expr (&argse, actual->expr);
5096 gfc_add_block_to_block (&se->pre, &argse.pre);
5097 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5098 argse.expr, null_pointer_node);
5099 tmp = gfc_evaluate_now (tmp, &se->pre);
5100 se->expr = fold_build3_loc (input_location, COND_EXPR,
5101 pvoid_type_node, tmp, fncall1, fncall0);
5105 se->expr = NULL_TREE;
5106 argse.expr = fold_build2_loc (input_location, MINUS_EXPR,
5107 gfc_array_index_type,
5108 argse.expr, gfc_index_one_node);
5111 else if (expr->value.function.actual->expr->rank == 1)
5113 argse.expr = gfc_index_zero_node;
5114 se->expr = NULL_TREE;
5119 if (se->expr == NULL_TREE)
5121 tree ubound, lbound;
5123 arg1 = build_fold_indirect_ref_loc (input_location,
5125 ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr);
5126 lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr);
5127 se->expr = fold_build2_loc (input_location, MINUS_EXPR,
5128 gfc_array_index_type, ubound, lbound);
5129 se->expr = fold_build2_loc (input_location, PLUS_EXPR,
5130 gfc_array_index_type,
5131 se->expr, gfc_index_one_node);
5132 se->expr = fold_build2_loc (input_location, MAX_EXPR,
5133 gfc_array_index_type, se->expr,
5134 gfc_index_zero_node);
5137 type = gfc_typenode_for_spec (&expr->ts);
5138 se->expr = convert (type, se->expr);
5142 /* Helper function to compute the size of a character variable,
5143 excluding the terminating null characters. The result has
5144 gfc_array_index_type type. */
5147 size_of_string_in_bytes (int kind, tree string_length)
5150 int i = gfc_validate_kind (BT_CHARACTER, kind, false);
5152 bytesize = build_int_cst (gfc_array_index_type,
5153 gfc_character_kinds[i].bit_size / 8);
5155 return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5157 fold_convert (gfc_array_index_type, string_length));
5162 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
5174 arg = expr->value.function.actual->expr;
5176 gfc_init_se (&argse, NULL);
5177 ss = gfc_walk_expr (arg);
5179 if (ss == gfc_ss_terminator)
5181 if (arg->ts.type == BT_CLASS)
5182 gfc_add_data_component (arg);
5184 gfc_conv_expr_reference (&argse, arg);
5186 type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
5189 /* Obtain the source word length. */
5190 if (arg->ts.type == BT_CHARACTER)
5191 se->expr = size_of_string_in_bytes (arg->ts.kind,
5192 argse.string_length);
5194 se->expr = fold_convert (gfc_array_index_type, size_in_bytes (type));
5198 source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
5199 argse.want_pointer = 0;
5200 gfc_conv_expr_descriptor (&argse, arg, ss);
5201 type = gfc_get_element_type (TREE_TYPE (argse.expr));
5203 /* Obtain the argument's word length. */
5204 if (arg->ts.type == BT_CHARACTER)
5205 tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
5207 tmp = fold_convert (gfc_array_index_type,
5208 size_in_bytes (type));
5209 gfc_add_modify (&argse.pre, source_bytes, tmp);
5211 /* Obtain the size of the array in bytes. */
5212 for (n = 0; n < arg->rank; n++)
5215 idx = gfc_rank_cst[n];
5216 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
5217 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
5218 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5219 gfc_array_index_type, upper, lower);
5220 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5221 gfc_array_index_type, tmp, gfc_index_one_node);
5222 tmp = fold_build2_loc (input_location, MULT_EXPR,
5223 gfc_array_index_type, tmp, source_bytes);
5224 gfc_add_modify (&argse.pre, source_bytes, tmp);
5226 se->expr = source_bytes;
5229 gfc_add_block_to_block (&se->pre, &argse.pre);
5234 gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
5239 tree type, result_type, tmp;
5241 arg = expr->value.function.actual->expr;
5242 gfc_init_se (&eight, NULL);
5243 gfc_conv_expr (&eight, gfc_get_int_expr (expr->ts.kind, NULL, 8));
5245 gfc_init_se (&argse, NULL);
5246 ss = gfc_walk_expr (arg);
5247 result_type = gfc_get_int_type (expr->ts.kind);
5249 if (ss == gfc_ss_terminator)
5251 if (arg->ts.type == BT_CLASS)
5253 gfc_add_vptr_component (arg);
5254 gfc_add_size_component (arg);
5255 gfc_conv_expr (&argse, arg);
5256 tmp = fold_convert (result_type, argse.expr);
5260 gfc_conv_expr_reference (&argse, arg);
5261 type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
5266 argse.want_pointer = 0;
5267 gfc_conv_expr_descriptor (&argse, arg, ss);
5268 type = gfc_get_element_type (TREE_TYPE (argse.expr));
5271 /* Obtain the argument's word length. */
5272 if (arg->ts.type == BT_CHARACTER)
5273 tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
5275 tmp = fold_convert (result_type, size_in_bytes (type));
5278 se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp,
5280 gfc_add_block_to_block (&se->pre, &argse.pre);
5284 /* Intrinsic string comparison functions. */
5287 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
5291 gfc_conv_intrinsic_function_args (se, expr, args, 4);
5294 = gfc_build_compare_string (args[0], args[1], args[2], args[3],
5295 expr->value.function.actual->expr->ts.kind,
5297 se->expr = fold_build2_loc (input_location, op,
5298 gfc_typenode_for_spec (&expr->ts), se->expr,
5299 build_int_cst (TREE_TYPE (se->expr), 0));
5302 /* Generate a call to the adjustl/adjustr library function. */
5304 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
5312 gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
5315 type = TREE_TYPE (args[2]);
5316 var = gfc_conv_string_tmp (se, type, len);
5319 tmp = build_call_expr_loc (input_location,
5320 fndecl, 3, args[0], args[1], args[2]);
5321 gfc_add_expr_to_block (&se->pre, tmp);
5323 se->string_length = len;
5327 /* Generate code for the TRANSFER intrinsic:
5329 DEST = TRANSFER (SOURCE, MOLD)
5331 typeof<DEST> = typeof<MOLD>
5336 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
5338 typeof<DEST> = typeof<MOLD>
5340 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
5341 sizeof (DEST(0) * SIZE). */
5343 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
5359 gfc_actual_arglist *arg;
5362 gfc_array_info *info;
5369 info = &se->ss->info->data.array;
5371 /* Convert SOURCE. The output from this stage is:-
5372 source_bytes = length of the source in bytes
5373 source = pointer to the source data. */
5374 arg = expr->value.function.actual;
5376 /* Ensure double transfer through LOGICAL preserves all
5378 if (arg->expr->expr_type == EXPR_FUNCTION
5379 && arg->expr->value.function.esym == NULL
5380 && arg->expr->value.function.isym != NULL
5381 && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
5382 && arg->expr->ts.type == BT_LOGICAL
5383 && expr->ts.type != arg->expr->ts.type)
5384 arg->expr->value.function.name = "__transfer_in_transfer";
5386 gfc_init_se (&argse, NULL);
5387 ss = gfc_walk_expr (arg->expr);
5389 source_bytes = gfc_create_var (gfc_array_index_type, NULL);
5391 /* Obtain the pointer to source and the length of source in bytes. */
5392 if (ss == gfc_ss_terminator)
5394 gfc_conv_expr_reference (&argse, arg->expr);
5395 source = argse.expr;
5397 source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
5400 /* Obtain the source word length. */
5401 if (arg->expr->ts.type == BT_CHARACTER)
5402 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
5403 argse.string_length);
5405 tmp = fold_convert (gfc_array_index_type,
5406 size_in_bytes (source_type));
5410 argse.want_pointer = 0;
5411 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
5412 source = gfc_conv_descriptor_data_get (argse.expr);
5413 source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
5415 /* Repack the source if not simply contiguous. */
5416 if (!gfc_is_simply_contiguous (arg->expr, false))
5418 tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
5420 if (gfc_option.warn_array_temp)
5421 gfc_warning ("Creating array temporary at %L", &expr->where);
5423 source = build_call_expr_loc (input_location,
5424 gfor_fndecl_in_pack, 1, tmp);
5425 source = gfc_evaluate_now (source, &argse.pre);
5427 /* Free the temporary. */
5428 gfc_start_block (&block);
5429 tmp = gfc_call_free (convert (pvoid_type_node, source));
5430 gfc_add_expr_to_block (&block, tmp);
5431 stmt = gfc_finish_block (&block);
5433 /* Clean up if it was repacked. */
5434 gfc_init_block (&block);
5435 tmp = gfc_conv_array_data (argse.expr);
5436 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5438 tmp = build3_v (COND_EXPR, tmp, stmt,
5439 build_empty_stmt (input_location));
5440 gfc_add_expr_to_block (&block, tmp);
5441 gfc_add_block_to_block (&block, &se->post);
5442 gfc_init_block (&se->post);
5443 gfc_add_block_to_block (&se->post, &block);
5446 /* Obtain the source word length. */
5447 if (arg->expr->ts.type == BT_CHARACTER)
5448 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
5449 argse.string_length);
5451 tmp = fold_convert (gfc_array_index_type,
5452 size_in_bytes (source_type));
5454 /* Obtain the size of the array in bytes. */
5455 extent = gfc_create_var (gfc_array_index_type, NULL);
5456 for (n = 0; n < arg->expr->rank; n++)
5459 idx = gfc_rank_cst[n];
5460 gfc_add_modify (&argse.pre, source_bytes, tmp);
5461 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
5462 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
5463 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5464 gfc_array_index_type, upper, lower);
5465 gfc_add_modify (&argse.pre, extent, tmp);
5466 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5467 gfc_array_index_type, extent,
5468 gfc_index_one_node);
5469 tmp = fold_build2_loc (input_location, MULT_EXPR,
5470 gfc_array_index_type, tmp, source_bytes);
5474 gfc_add_modify (&argse.pre, source_bytes, tmp);
5475 gfc_add_block_to_block (&se->pre, &argse.pre);
5476 gfc_add_block_to_block (&se->post, &argse.post);
5478 /* Now convert MOLD. The outputs are:
5479 mold_type = the TREE type of MOLD
5480 dest_word_len = destination word length in bytes. */
5483 gfc_init_se (&argse, NULL);
5484 ss = gfc_walk_expr (arg->expr);
5486 scalar_mold = arg->expr->rank == 0;
5488 if (ss == gfc_ss_terminator)
5490 gfc_conv_expr_reference (&argse, arg->expr);
5491 mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
5496 gfc_init_se (&argse, NULL);
5497 argse.want_pointer = 0;
5498 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
5499 mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
5502 gfc_add_block_to_block (&se->pre, &argse.pre);
5503 gfc_add_block_to_block (&se->post, &argse.post);
5505 if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
5507 /* If this TRANSFER is nested in another TRANSFER, use a type
5508 that preserves all bits. */
5509 if (arg->expr->ts.type == BT_LOGICAL)
5510 mold_type = gfc_get_int_type (arg->expr->ts.kind);
5513 if (arg->expr->ts.type == BT_CHARACTER)
5515 tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
5516 mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
5519 tmp = fold_convert (gfc_array_index_type,
5520 size_in_bytes (mold_type));
5522 dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
5523 gfc_add_modify (&se->pre, dest_word_len, tmp);
5525 /* Finally convert SIZE, if it is present. */
5527 size_words = gfc_create_var (gfc_array_index_type, NULL);
5531 gfc_init_se (&argse, NULL);
5532 gfc_conv_expr_reference (&argse, arg->expr);
5533 tmp = convert (gfc_array_index_type,
5534 build_fold_indirect_ref_loc (input_location,
5536 gfc_add_block_to_block (&se->pre, &argse.pre);
5537 gfc_add_block_to_block (&se->post, &argse.post);
5542 /* Separate array and scalar results. */
5543 if (scalar_mold && tmp == NULL_TREE)
5544 goto scalar_transfer;
5546 size_bytes = gfc_create_var (gfc_array_index_type, NULL);
5547 if (tmp != NULL_TREE)
5548 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5549 tmp, dest_word_len);
5553 gfc_add_modify (&se->pre, size_bytes, tmp);
5554 gfc_add_modify (&se->pre, size_words,
5555 fold_build2_loc (input_location, CEIL_DIV_EXPR,
5556 gfc_array_index_type,
5557 size_bytes, dest_word_len));
5559 /* Evaluate the bounds of the result. If the loop range exists, we have
5560 to check if it is too large. If so, we modify loop->to be consistent
5561 with min(size, size(source)). Otherwise, size is made consistent with
5562 the loop range, so that the right number of bytes is transferred.*/
5563 n = se->loop->order[0];
5564 if (se->loop->to[n] != NULL_TREE)
5566 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5567 se->loop->to[n], se->loop->from[n]);
5568 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5569 tmp, gfc_index_one_node);
5570 tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
5572 gfc_add_modify (&se->pre, size_words, tmp);
5573 gfc_add_modify (&se->pre, size_bytes,
5574 fold_build2_loc (input_location, MULT_EXPR,
5575 gfc_array_index_type,
5576 size_words, dest_word_len));
5577 upper = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5578 size_words, se->loop->from[n]);
5579 upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5580 upper, gfc_index_one_node);
5584 upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5585 size_words, gfc_index_one_node);
5586 se->loop->from[n] = gfc_index_zero_node;
5589 se->loop->to[n] = upper;
5591 /* Build a destination descriptor, using the pointer, source, as the
5593 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, mold_type,
5594 NULL_TREE, false, true, false, &expr->where);
5596 /* Cast the pointer to the result. */
5597 tmp = gfc_conv_descriptor_data_get (info->descriptor);
5598 tmp = fold_convert (pvoid_type_node, tmp);
5600 /* Use memcpy to do the transfer. */
5601 tmp = build_call_expr_loc (input_location,
5602 builtin_decl_explicit (BUILT_IN_MEMCPY),
5605 fold_convert (pvoid_type_node, source),
5606 fold_build2_loc (input_location, MIN_EXPR,
5607 gfc_array_index_type,
5608 size_bytes, source_bytes));
5609 gfc_add_expr_to_block (&se->pre, tmp);
5611 se->expr = info->descriptor;
5612 if (expr->ts.type == BT_CHARACTER)
5613 se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len);
5617 /* Deal with scalar results. */
5619 extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
5620 dest_word_len, source_bytes);
5621 extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
5622 extent, gfc_index_zero_node);
5624 if (expr->ts.type == BT_CHARACTER)
5629 ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
5630 tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
5633 /* If source is longer than the destination, use a pointer to
5634 the source directly. */
5635 gfc_init_block (&block);
5636 gfc_add_modify (&block, tmpdecl, ptr);
5637 direct = gfc_finish_block (&block);
5639 /* Otherwise, allocate a string with the length of the destination
5640 and copy the source into it. */
5641 gfc_init_block (&block);
5642 tmp = gfc_get_pchar_type (expr->ts.kind);
5643 tmp = gfc_call_malloc (&block, tmp, dest_word_len);
5644 gfc_add_modify (&block, tmpdecl,
5645 fold_convert (TREE_TYPE (ptr), tmp));
5646 tmp = build_call_expr_loc (input_location,
5647 builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
5648 fold_convert (pvoid_type_node, tmpdecl),
5649 fold_convert (pvoid_type_node, ptr),
5651 gfc_add_expr_to_block (&block, tmp);
5652 indirect = gfc_finish_block (&block);
5654 /* Wrap it up with the condition. */
5655 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
5656 dest_word_len, source_bytes);
5657 tmp = build3_v (COND_EXPR, tmp, direct, indirect);
5658 gfc_add_expr_to_block (&se->pre, tmp);
5661 se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len);
5665 tmpdecl = gfc_create_var (mold_type, "transfer");
5667 ptr = convert (build_pointer_type (mold_type), source);
5669 /* Use memcpy to do the transfer. */
5670 tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
5671 tmp = build_call_expr_loc (input_location,
5672 builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
5673 fold_convert (pvoid_type_node, tmp),
5674 fold_convert (pvoid_type_node, ptr),
5676 gfc_add_expr_to_block (&se->pre, tmp);
5683 /* Generate code for the ALLOCATED intrinsic.
5684 Generate inline code that directly check the address of the argument. */
5687 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
5689 gfc_actual_arglist *arg1;
5694 gfc_init_se (&arg1se, NULL);
5695 arg1 = expr->value.function.actual;
5697 if (arg1->expr->ts.type == BT_CLASS)
5699 /* Make sure that class array expressions have both a _data
5700 component reference and an array reference.... */
5701 if (CLASS_DATA (arg1->expr)->attr.dimension)
5702 gfc_add_class_array_ref (arg1->expr);
5703 /* .... whilst scalars only need the _data component. */
5705 gfc_add_data_component (arg1->expr);
5708 ss1 = gfc_walk_expr (arg1->expr);
5710 if (ss1 == gfc_ss_terminator)
5712 /* Allocatable scalar. */
5713 arg1se.want_pointer = 1;
5714 gfc_conv_expr (&arg1se, arg1->expr);
5719 /* Allocatable array. */
5720 arg1se.descriptor_only = 1;
5721 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
5722 tmp = gfc_conv_descriptor_data_get (arg1se.expr);
5725 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
5726 fold_convert (TREE_TYPE (tmp), null_pointer_node));
5727 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
5731 /* Generate code for the ASSOCIATED intrinsic.
5732 If both POINTER and TARGET are arrays, generate a call to library function
5733 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
5734 In other cases, generate inline code that directly compare the address of
5735 POINTER with the address of TARGET. */
5738 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
5740 gfc_actual_arglist *arg1;
5741 gfc_actual_arglist *arg2;
5746 tree nonzero_charlen;
5747 tree nonzero_arraylen;
5750 gfc_init_se (&arg1se, NULL);
5751 gfc_init_se (&arg2se, NULL);
5752 arg1 = expr->value.function.actual;
5753 if (arg1->expr->ts.type == BT_CLASS)
5754 gfc_add_data_component (arg1->expr);
5756 ss1 = gfc_walk_expr (arg1->expr);
5760 /* No optional target. */
5761 if (ss1 == gfc_ss_terminator)
5763 /* A pointer to a scalar. */
5764 arg1se.want_pointer = 1;
5765 gfc_conv_expr (&arg1se, arg1->expr);
5770 /* A pointer to an array. */
5771 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
5772 tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
5774 gfc_add_block_to_block (&se->pre, &arg1se.pre);
5775 gfc_add_block_to_block (&se->post, &arg1se.post);
5776 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp2,
5777 fold_convert (TREE_TYPE (tmp2), null_pointer_node));
5782 /* An optional target. */
5783 if (arg2->expr->ts.type == BT_CLASS)
5784 gfc_add_data_component (arg2->expr);
5785 ss2 = gfc_walk_expr (arg2->expr);
5787 nonzero_charlen = NULL_TREE;
5788 if (arg1->expr->ts.type == BT_CHARACTER)
5789 nonzero_charlen = fold_build2_loc (input_location, NE_EXPR,
5791 arg1->expr->ts.u.cl->backend_decl,
5794 if (ss1 == gfc_ss_terminator)
5796 /* A pointer to a scalar. */
5797 gcc_assert (ss2 == gfc_ss_terminator);
5798 arg1se.want_pointer = 1;
5799 gfc_conv_expr (&arg1se, arg1->expr);
5800 arg2se.want_pointer = 1;
5801 gfc_conv_expr (&arg2se, arg2->expr);
5802 gfc_add_block_to_block (&se->pre, &arg1se.pre);
5803 gfc_add_block_to_block (&se->post, &arg1se.post);
5804 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5805 arg1se.expr, arg2se.expr);
5806 tmp2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5807 arg1se.expr, null_pointer_node);
5808 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5809 boolean_type_node, tmp, tmp2);
5813 /* An array pointer of zero length is not associated if target is
5815 arg1se.descriptor_only = 1;
5816 gfc_conv_expr_lhs (&arg1se, arg1->expr);
5817 tmp = gfc_conv_descriptor_stride_get (arg1se.expr,
5818 gfc_rank_cst[arg1->expr->rank - 1]);
5819 nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
5820 boolean_type_node, tmp,
5821 build_int_cst (TREE_TYPE (tmp), 0));
5823 /* A pointer to an array, call library function _gfor_associated. */
5824 gcc_assert (ss2 != gfc_ss_terminator);
5825 arg1se.want_pointer = 1;
5826 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
5828 arg2se.want_pointer = 1;
5829 gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
5830 gfc_add_block_to_block (&se->pre, &arg2se.pre);
5831 gfc_add_block_to_block (&se->post, &arg2se.post);
5832 se->expr = build_call_expr_loc (input_location,
5833 gfor_fndecl_associated, 2,
5834 arg1se.expr, arg2se.expr);
5835 se->expr = convert (boolean_type_node, se->expr);
5836 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5837 boolean_type_node, se->expr,
5841 /* If target is present zero character length pointers cannot
5843 if (nonzero_charlen != NULL_TREE)
5844 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5846 se->expr, nonzero_charlen);
5849 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
5853 /* Generate code for the SAME_TYPE_AS intrinsic.
5854 Generate inline code that directly checks the vindices. */
5857 gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
5863 gfc_init_se (&se1, NULL);
5864 gfc_init_se (&se2, NULL);
5866 a = expr->value.function.actual->expr;
5867 b = expr->value.function.actual->next->expr;
5869 if (a->ts.type == BT_CLASS)
5871 gfc_add_vptr_component (a);
5872 gfc_add_hash_component (a);
5874 else if (a->ts.type == BT_DERIVED)
5875 a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5876 a->ts.u.derived->hash_value);
5878 if (b->ts.type == BT_CLASS)
5880 gfc_add_vptr_component (b);
5881 gfc_add_hash_component (b);
5883 else if (b->ts.type == BT_DERIVED)
5884 b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5885 b->ts.u.derived->hash_value);
5887 gfc_conv_expr (&se1, a);
5888 gfc_conv_expr (&se2, b);
5890 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5891 se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.expr));
5892 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
5896 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
5899 gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
5903 gfc_conv_intrinsic_function_args (se, expr, args, 2);
5904 se->expr = build_call_expr_loc (input_location,
5905 gfor_fndecl_sc_kind, 2, args[0], args[1]);
5906 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
5910 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
5913 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
5917 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
5919 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
5920 type = gfc_get_int_type (4);
5921 arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
5923 /* Convert it to the required type. */
5924 type = gfc_typenode_for_spec (&expr->ts);
5925 se->expr = build_call_expr_loc (input_location,
5926 gfor_fndecl_si_kind, 1, arg);
5927 se->expr = fold_convert (type, se->expr);
5931 /* Generate code for SELECTED_REAL_KIND (P, R, RADIX) intrinsic function. */
5934 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
5936 gfc_actual_arglist *actual;
5939 VEC(tree,gc) *args = NULL;
5941 for (actual = expr->value.function.actual; actual; actual = actual->next)
5943 gfc_init_se (&argse, se);
5945 /* Pass a NULL pointer for an absent arg. */
5946 if (actual->expr == NULL)
5947 argse.expr = null_pointer_node;
5953 if (actual->expr->ts.kind != gfc_c_int_kind)
5955 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
5956 ts.type = BT_INTEGER;
5957 ts.kind = gfc_c_int_kind;
5958 gfc_convert_type (actual->expr, &ts, 2);
5960 gfc_conv_expr_reference (&argse, actual->expr);
5963 gfc_add_block_to_block (&se->pre, &argse.pre);
5964 gfc_add_block_to_block (&se->post, &argse.post);
5965 VEC_safe_push (tree, gc, args, argse.expr);
5968 /* Convert it to the required type. */
5969 type = gfc_typenode_for_spec (&expr->ts);
5970 se->expr = build_call_expr_loc_vec (input_location,
5971 gfor_fndecl_sr_kind, args);
5972 se->expr = fold_convert (type, se->expr);
5976 /* Generate code for TRIM (A) intrinsic function. */
5979 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
5989 unsigned int num_args;
5991 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
5992 args = XALLOCAVEC (tree, num_args);
5994 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
5995 addr = gfc_build_addr_expr (ppvoid_type_node, var);
5996 len = gfc_create_var (gfc_charlen_type_node, "len");
5998 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
5999 args[0] = gfc_build_addr_expr (NULL_TREE, len);
6002 if (expr->ts.kind == 1)
6003 function = gfor_fndecl_string_trim;
6004 else if (expr->ts.kind == 4)
6005 function = gfor_fndecl_string_trim_char4;
6009 fndecl = build_addr (function, current_function_decl);
6010 tmp = build_call_array_loc (input_location,
6011 TREE_TYPE (TREE_TYPE (function)), fndecl,
6013 gfc_add_expr_to_block (&se->pre, tmp);
6015 /* Free the temporary afterwards, if necessary. */
6016 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
6017 len, build_int_cst (TREE_TYPE (len), 0));
6018 tmp = gfc_call_free (var);
6019 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
6020 gfc_add_expr_to_block (&se->post, tmp);
6023 se->string_length = len;
6027 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
6030 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
6032 tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
6033 tree type, cond, tmp, count, exit_label, n, max, largest;
6035 stmtblock_t block, body;
6038 /* We store in charsize the size of a character. */
6039 i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
6040 size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8);
6042 /* Get the arguments. */
6043 gfc_conv_intrinsic_function_args (se, expr, args, 3);
6044 slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
6046 ncopies = gfc_evaluate_now (args[2], &se->pre);
6047 ncopies_type = TREE_TYPE (ncopies);
6049 /* Check that NCOPIES is not negative. */
6050 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, ncopies,
6051 build_int_cst (ncopies_type, 0));
6052 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
6053 "Argument NCOPIES of REPEAT intrinsic is negative "
6054 "(its value is %ld)",
6055 fold_convert (long_integer_type_node, ncopies));
6057 /* If the source length is zero, any non negative value of NCOPIES
6058 is valid, and nothing happens. */
6059 n = gfc_create_var (ncopies_type, "ncopies");
6060 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen,
6061 build_int_cst (size_type_node, 0));
6062 tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond,
6063 build_int_cst (ncopies_type, 0), ncopies);
6064 gfc_add_modify (&se->pre, n, tmp);
6067 /* Check that ncopies is not too large: ncopies should be less than
6068 (or equal to) MAX / slen, where MAX is the maximal integer of
6069 the gfc_charlen_type_node type. If slen == 0, we need a special
6070 case to avoid the division by zero. */
6071 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
6072 max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
6073 max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, size_type_node,
6074 fold_convert (size_type_node, max), slen);
6075 largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
6076 ? size_type_node : ncopies_type;
6077 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
6078 fold_convert (largest, ncopies),
6079 fold_convert (largest, max));
6080 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen,
6081 build_int_cst (size_type_node, 0));
6082 cond = fold_build3_loc (input_location, COND_EXPR, boolean_type_node, tmp,
6083 boolean_false_node, cond);
6084 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
6085 "Argument NCOPIES of REPEAT intrinsic is too large");
6087 /* Compute the destination length. */
6088 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
6089 fold_convert (gfc_charlen_type_node, slen),
6090 fold_convert (gfc_charlen_type_node, ncopies));
6091 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
6092 dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
6094 /* Generate the code to do the repeat operation:
6095 for (i = 0; i < ncopies; i++)
6096 memmove (dest + (i * slen * size), src, slen*size); */
6097 gfc_start_block (&block);
6098 count = gfc_create_var (ncopies_type, "count");
6099 gfc_add_modify (&block, count, build_int_cst (ncopies_type, 0));
6100 exit_label = gfc_build_label_decl (NULL_TREE);
6102 /* Start the loop body. */
6103 gfc_start_block (&body);
6105 /* Exit the loop if count >= ncopies. */
6106 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, count,
6108 tmp = build1_v (GOTO_EXPR, exit_label);
6109 TREE_USED (exit_label) = 1;
6110 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
6111 build_empty_stmt (input_location));
6112 gfc_add_expr_to_block (&body, tmp);
6114 /* Call memmove (dest + (i*slen*size), src, slen*size). */
6115 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
6116 fold_convert (gfc_charlen_type_node, slen),
6117 fold_convert (gfc_charlen_type_node, count));
6118 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
6119 tmp, fold_convert (gfc_charlen_type_node, size));
6120 tmp = fold_build_pointer_plus_loc (input_location,
6121 fold_convert (pvoid_type_node, dest), tmp);
6122 tmp = build_call_expr_loc (input_location,
6123 builtin_decl_explicit (BUILT_IN_MEMMOVE),
6125 fold_build2_loc (input_location, MULT_EXPR,
6126 size_type_node, slen,
6127 fold_convert (size_type_node,
6129 gfc_add_expr_to_block (&body, tmp);
6131 /* Increment count. */
6132 tmp = fold_build2_loc (input_location, PLUS_EXPR, ncopies_type,
6133 count, build_int_cst (TREE_TYPE (count), 1));
6134 gfc_add_modify (&body, count, tmp);
6136 /* Build the loop. */
6137 tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
6138 gfc_add_expr_to_block (&block, tmp);
6140 /* Add the exit label. */
6141 tmp = build1_v (LABEL_EXPR, exit_label);
6142 gfc_add_expr_to_block (&block, tmp);
6144 /* Finish the block. */
6145 tmp = gfc_finish_block (&block);
6146 gfc_add_expr_to_block (&se->pre, tmp);
6148 /* Set the result value. */
6150 se->string_length = dlen;
6154 /* Generate code for the IARGC intrinsic. */
6157 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
6163 /* Call the library function. This always returns an INTEGER(4). */
6164 fndecl = gfor_fndecl_iargc;
6165 tmp = build_call_expr_loc (input_location,
6168 /* Convert it to the required type. */
6169 type = gfc_typenode_for_spec (&expr->ts);
6170 tmp = fold_convert (type, tmp);
6176 /* The loc intrinsic returns the address of its argument as
6177 gfc_index_integer_kind integer. */
6180 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
6186 gcc_assert (!se->ss);
6188 arg_expr = expr->value.function.actual->expr;
6189 ss = gfc_walk_expr (arg_expr);
6190 if (ss == gfc_ss_terminator)
6191 gfc_conv_expr_reference (se, arg_expr);
6193 gfc_conv_array_parameter (se, arg_expr, ss, true, NULL, NULL, NULL);
6194 se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
6196 /* Create a temporary variable for loc return value. Without this,
6197 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
6198 temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
6199 gfc_add_modify (&se->pre, temp_var, se->expr);
6200 se->expr = temp_var;
6203 /* Generate code for an intrinsic function. Some map directly to library
6204 calls, others get special handling. In some cases the name of the function
6205 used depends on the type specifiers. */
6208 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
6214 name = &expr->value.function.name[2];
6218 lib = gfc_is_intrinsic_libcall (expr);
6222 se->ignore_optional = 1;
6224 switch (expr->value.function.isym->id)
6226 case GFC_ISYM_EOSHIFT:
6228 case GFC_ISYM_RESHAPE:
6229 /* For all of those the first argument specifies the type and the
6230 third is optional. */
6231 conv_generic_with_optional_char_arg (se, expr, 1, 3);
6235 gfc_conv_intrinsic_funcall (se, expr);
6243 switch (expr->value.function.isym->id)
6248 case GFC_ISYM_REPEAT:
6249 gfc_conv_intrinsic_repeat (se, expr);
6253 gfc_conv_intrinsic_trim (se, expr);
6256 case GFC_ISYM_SC_KIND:
6257 gfc_conv_intrinsic_sc_kind (se, expr);
6260 case GFC_ISYM_SI_KIND:
6261 gfc_conv_intrinsic_si_kind (se, expr);
6264 case GFC_ISYM_SR_KIND:
6265 gfc_conv_intrinsic_sr_kind (se, expr);
6268 case GFC_ISYM_EXPONENT:
6269 gfc_conv_intrinsic_exponent (se, expr);
6273 kind = expr->value.function.actual->expr->ts.kind;
6275 fndecl = gfor_fndecl_string_scan;
6277 fndecl = gfor_fndecl_string_scan_char4;
6281 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
6284 case GFC_ISYM_VERIFY:
6285 kind = expr->value.function.actual->expr->ts.kind;
6287 fndecl = gfor_fndecl_string_verify;
6289 fndecl = gfor_fndecl_string_verify_char4;
6293 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
6296 case GFC_ISYM_ALLOCATED:
6297 gfc_conv_allocated (se, expr);
6300 case GFC_ISYM_ASSOCIATED:
6301 gfc_conv_associated(se, expr);
6304 case GFC_ISYM_SAME_TYPE_AS:
6305 gfc_conv_same_type_as (se, expr);
6309 gfc_conv_intrinsic_abs (se, expr);
6312 case GFC_ISYM_ADJUSTL:
6313 if (expr->ts.kind == 1)
6314 fndecl = gfor_fndecl_adjustl;
6315 else if (expr->ts.kind == 4)
6316 fndecl = gfor_fndecl_adjustl_char4;
6320 gfc_conv_intrinsic_adjust (se, expr, fndecl);
6323 case GFC_ISYM_ADJUSTR:
6324 if (expr->ts.kind == 1)
6325 fndecl = gfor_fndecl_adjustr;
6326 else if (expr->ts.kind == 4)
6327 fndecl = gfor_fndecl_adjustr_char4;
6331 gfc_conv_intrinsic_adjust (se, expr, fndecl);
6334 case GFC_ISYM_AIMAG:
6335 gfc_conv_intrinsic_imagpart (se, expr);
6339 gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
6343 gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
6346 case GFC_ISYM_ANINT:
6347 gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
6351 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
6355 gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
6358 case GFC_ISYM_BTEST:
6359 gfc_conv_intrinsic_btest (se, expr);
6363 gfc_conv_intrinsic_bitcomp (se, expr, GE_EXPR);
6367 gfc_conv_intrinsic_bitcomp (se, expr, GT_EXPR);
6371 gfc_conv_intrinsic_bitcomp (se, expr, LE_EXPR);
6375 gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR);
6378 case GFC_ISYM_ACHAR:
6380 gfc_conv_intrinsic_char (se, expr);
6383 case GFC_ISYM_CONVERSION:
6385 case GFC_ISYM_LOGICAL:
6387 gfc_conv_intrinsic_conversion (se, expr);
6390 /* Integer conversions are handled separately to make sure we get the
6391 correct rounding mode. */
6396 gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
6400 gfc_conv_intrinsic_int (se, expr, RND_ROUND);
6403 case GFC_ISYM_CEILING:
6404 gfc_conv_intrinsic_int (se, expr, RND_CEIL);
6407 case GFC_ISYM_FLOOR:
6408 gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
6412 gfc_conv_intrinsic_mod (se, expr, 0);
6415 case GFC_ISYM_MODULO:
6416 gfc_conv_intrinsic_mod (se, expr, 1);
6419 case GFC_ISYM_CMPLX:
6420 gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
6423 case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
6424 gfc_conv_intrinsic_iargc (se, expr);
6427 case GFC_ISYM_COMPLEX:
6428 gfc_conv_intrinsic_cmplx (se, expr, 1);
6431 case GFC_ISYM_CONJG:
6432 gfc_conv_intrinsic_conjg (se, expr);
6435 case GFC_ISYM_COUNT:
6436 gfc_conv_intrinsic_count (se, expr);
6439 case GFC_ISYM_CTIME:
6440 gfc_conv_intrinsic_ctime (se, expr);
6444 gfc_conv_intrinsic_dim (se, expr);
6447 case GFC_ISYM_DOT_PRODUCT:
6448 gfc_conv_intrinsic_dot_product (se, expr);
6451 case GFC_ISYM_DPROD:
6452 gfc_conv_intrinsic_dprod (se, expr);
6455 case GFC_ISYM_DSHIFTL:
6456 gfc_conv_intrinsic_dshift (se, expr, true);
6459 case GFC_ISYM_DSHIFTR:
6460 gfc_conv_intrinsic_dshift (se, expr, false);
6463 case GFC_ISYM_FDATE:
6464 gfc_conv_intrinsic_fdate (se, expr);
6467 case GFC_ISYM_FRACTION:
6468 gfc_conv_intrinsic_fraction (se, expr);
6472 gfc_conv_intrinsic_arith (se, expr, BIT_AND_EXPR, false);
6476 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
6480 gfc_conv_intrinsic_arith (se, expr, BIT_IOR_EXPR, false);
6483 case GFC_ISYM_IBCLR:
6484 gfc_conv_intrinsic_singlebitop (se, expr, 0);
6487 case GFC_ISYM_IBITS:
6488 gfc_conv_intrinsic_ibits (se, expr);
6491 case GFC_ISYM_IBSET:
6492 gfc_conv_intrinsic_singlebitop (se, expr, 1);
6495 case GFC_ISYM_IACHAR:
6496 case GFC_ISYM_ICHAR:
6497 /* We assume ASCII character sequence. */
6498 gfc_conv_intrinsic_ichar (se, expr);
6501 case GFC_ISYM_IARGC:
6502 gfc_conv_intrinsic_iargc (se, expr);
6506 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
6509 case GFC_ISYM_INDEX:
6510 kind = expr->value.function.actual->expr->ts.kind;
6512 fndecl = gfor_fndecl_string_index;
6514 fndecl = gfor_fndecl_string_index_char4;
6518 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
6522 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
6525 case GFC_ISYM_IPARITY:
6526 gfc_conv_intrinsic_arith (se, expr, BIT_XOR_EXPR, false);
6529 case GFC_ISYM_IS_IOSTAT_END:
6530 gfc_conv_has_intvalue (se, expr, LIBERROR_END);
6533 case GFC_ISYM_IS_IOSTAT_EOR:
6534 gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
6537 case GFC_ISYM_ISNAN:
6538 gfc_conv_intrinsic_isnan (se, expr);
6541 case GFC_ISYM_LSHIFT:
6542 gfc_conv_intrinsic_shift (se, expr, false, false);
6545 case GFC_ISYM_RSHIFT:
6546 gfc_conv_intrinsic_shift (se, expr, true, true);
6549 case GFC_ISYM_SHIFTA:
6550 gfc_conv_intrinsic_shift (se, expr, true, true);
6553 case GFC_ISYM_SHIFTL:
6554 gfc_conv_intrinsic_shift (se, expr, false, false);
6557 case GFC_ISYM_SHIFTR:
6558 gfc_conv_intrinsic_shift (se, expr, true, false);
6561 case GFC_ISYM_ISHFT:
6562 gfc_conv_intrinsic_ishft (se, expr);
6565 case GFC_ISYM_ISHFTC:
6566 gfc_conv_intrinsic_ishftc (se, expr);
6569 case GFC_ISYM_LEADZ:
6570 gfc_conv_intrinsic_leadz (se, expr);
6573 case GFC_ISYM_TRAILZ:
6574 gfc_conv_intrinsic_trailz (se, expr);
6577 case GFC_ISYM_POPCNT:
6578 gfc_conv_intrinsic_popcnt_poppar (se, expr, 0);
6581 case GFC_ISYM_POPPAR:
6582 gfc_conv_intrinsic_popcnt_poppar (se, expr, 1);
6585 case GFC_ISYM_LBOUND:
6586 gfc_conv_intrinsic_bound (se, expr, 0);
6589 case GFC_ISYM_LCOBOUND:
6590 conv_intrinsic_cobound (se, expr);
6593 case GFC_ISYM_TRANSPOSE:
6594 /* The scalarizer has already been set up for reversed dimension access
6595 order ; now we just get the argument value normally. */
6596 gfc_conv_expr (se, expr->value.function.actual->expr);
6600 gfc_conv_intrinsic_len (se, expr);
6603 case GFC_ISYM_LEN_TRIM:
6604 gfc_conv_intrinsic_len_trim (se, expr);
6608 gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
6612 gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
6616 gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
6620 gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
6623 case GFC_ISYM_MASKL:
6624 gfc_conv_intrinsic_mask (se, expr, 1);
6627 case GFC_ISYM_MASKR:
6628 gfc_conv_intrinsic_mask (se, expr, 0);
6632 if (expr->ts.type == BT_CHARACTER)
6633 gfc_conv_intrinsic_minmax_char (se, expr, 1);
6635 gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
6638 case GFC_ISYM_MAXLOC:
6639 gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
6642 case GFC_ISYM_MAXVAL:
6643 gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
6646 case GFC_ISYM_MERGE:
6647 gfc_conv_intrinsic_merge (se, expr);
6650 case GFC_ISYM_MERGE_BITS:
6651 gfc_conv_intrinsic_merge_bits (se, expr);
6655 if (expr->ts.type == BT_CHARACTER)
6656 gfc_conv_intrinsic_minmax_char (se, expr, -1);
6658 gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
6661 case GFC_ISYM_MINLOC:
6662 gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
6665 case GFC_ISYM_MINVAL:
6666 gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
6669 case GFC_ISYM_NEAREST:
6670 gfc_conv_intrinsic_nearest (se, expr);
6673 case GFC_ISYM_NORM2:
6674 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true);
6678 gfc_conv_intrinsic_not (se, expr);
6682 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
6685 case GFC_ISYM_PARITY:
6686 gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false);
6689 case GFC_ISYM_PRESENT:
6690 gfc_conv_intrinsic_present (se, expr);
6693 case GFC_ISYM_PRODUCT:
6694 gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false);
6697 case GFC_ISYM_RRSPACING:
6698 gfc_conv_intrinsic_rrspacing (se, expr);
6701 case GFC_ISYM_SET_EXPONENT:
6702 gfc_conv_intrinsic_set_exponent (se, expr);
6705 case GFC_ISYM_SCALE:
6706 gfc_conv_intrinsic_scale (se, expr);
6710 gfc_conv_intrinsic_sign (se, expr);
6714 gfc_conv_intrinsic_size (se, expr);
6717 case GFC_ISYM_SIZEOF:
6718 case GFC_ISYM_C_SIZEOF:
6719 gfc_conv_intrinsic_sizeof (se, expr);
6722 case GFC_ISYM_STORAGE_SIZE:
6723 gfc_conv_intrinsic_storage_size (se, expr);
6726 case GFC_ISYM_SPACING:
6727 gfc_conv_intrinsic_spacing (se, expr);
6731 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false);
6734 case GFC_ISYM_TRANSFER:
6735 if (se->ss && se->ss->info->useflags)
6736 /* Access the previously obtained result. */
6737 gfc_conv_tmp_array_ref (se);
6739 gfc_conv_intrinsic_transfer (se, expr);
6742 case GFC_ISYM_TTYNAM:
6743 gfc_conv_intrinsic_ttynam (se, expr);
6746 case GFC_ISYM_UBOUND:
6747 gfc_conv_intrinsic_bound (se, expr, 1);
6750 case GFC_ISYM_UCOBOUND:
6751 conv_intrinsic_cobound (se, expr);
6755 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
6759 gfc_conv_intrinsic_loc (se, expr);
6762 case GFC_ISYM_THIS_IMAGE:
6763 /* For num_images() == 1, handle as LCOBOUND. */
6764 if (expr->value.function.actual->expr
6765 && gfc_option.coarray == GFC_FCOARRAY_SINGLE)
6766 conv_intrinsic_cobound (se, expr);
6768 trans_this_image (se, expr);
6771 case GFC_ISYM_IMAGE_INDEX:
6772 trans_image_index (se, expr);
6775 case GFC_ISYM_NUM_IMAGES:
6776 trans_num_images (se);
6779 case GFC_ISYM_ACCESS:
6780 case GFC_ISYM_CHDIR:
6781 case GFC_ISYM_CHMOD:
6782 case GFC_ISYM_DTIME:
6783 case GFC_ISYM_ETIME:
6784 case GFC_ISYM_EXTENDS_TYPE_OF:
6786 case GFC_ISYM_FGETC:
6789 case GFC_ISYM_FPUTC:
6790 case GFC_ISYM_FSTAT:
6791 case GFC_ISYM_FTELL:
6792 case GFC_ISYM_GETCWD:
6793 case GFC_ISYM_GETGID:
6794 case GFC_ISYM_GETPID:
6795 case GFC_ISYM_GETUID:
6796 case GFC_ISYM_HOSTNM:
6798 case GFC_ISYM_IERRNO:
6799 case GFC_ISYM_IRAND:
6800 case GFC_ISYM_ISATTY:
6803 case GFC_ISYM_LSTAT:
6804 case GFC_ISYM_MALLOC:
6805 case GFC_ISYM_MATMUL:
6806 case GFC_ISYM_MCLOCK:
6807 case GFC_ISYM_MCLOCK8:
6809 case GFC_ISYM_RENAME:
6810 case GFC_ISYM_SECOND:
6811 case GFC_ISYM_SECNDS:
6812 case GFC_ISYM_SIGNAL:
6814 case GFC_ISYM_SYMLNK:
6815 case GFC_ISYM_SYSTEM:
6817 case GFC_ISYM_TIME8:
6818 case GFC_ISYM_UMASK:
6819 case GFC_ISYM_UNLINK:
6821 gfc_conv_intrinsic_funcall (se, expr);
6824 case GFC_ISYM_EOSHIFT:
6826 case GFC_ISYM_RESHAPE:
6827 /* For those, expr->rank should always be >0 and thus the if above the
6828 switch should have matched. */
6833 gfc_conv_intrinsic_lib_function (se, expr);
6840 walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr)
6842 gfc_ss *arg_ss, *tmp_ss;
6843 gfc_actual_arglist *arg;
6845 arg = expr->value.function.actual;
6847 gcc_assert (arg->expr);
6849 arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr);
6850 gcc_assert (arg_ss != gfc_ss_terminator);
6852 for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
6854 if (tmp_ss->info->type != GFC_SS_SCALAR
6855 && tmp_ss->info->type != GFC_SS_REFERENCE)
6859 gcc_assert (tmp_ss->dimen == 2);
6861 /* We just invert dimensions. */
6862 tmp_dim = tmp_ss->dim[0];
6863 tmp_ss->dim[0] = tmp_ss->dim[1];
6864 tmp_ss->dim[1] = tmp_dim;
6867 /* Stop when tmp_ss points to the last valid element of the chain... */
6868 if (tmp_ss->next == gfc_ss_terminator)
6872 /* ... so that we can attach the rest of the chain to it. */
6879 /* Move the given dimension of the given gfc_ss list to a nested gfc_ss list.
6880 This has the side effect of reversing the nested list, so there is no
6881 need to call gfc_reverse_ss on it (the given list is assumed not to be
6885 nest_loop_dimension (gfc_ss *ss, int dim)
6888 gfc_ss *new_ss, *prev_ss = gfc_ss_terminator;
6889 gfc_loopinfo *new_loop;
6891 gcc_assert (ss != gfc_ss_terminator);
6893 for (; ss != gfc_ss_terminator; ss = ss->next)
6895 new_ss = gfc_get_ss ();
6896 new_ss->next = prev_ss;
6897 new_ss->parent = ss;
6898 new_ss->info = ss->info;
6899 new_ss->info->refcount++;
6902 gcc_assert (ss->info->type != GFC_SS_SCALAR
6903 && ss->info->type != GFC_SS_REFERENCE);
6906 new_ss->dim[0] = ss->dim[dim];
6908 gcc_assert (dim < ss->dimen);
6910 ss_dim = --ss->dimen;
6911 for (i = dim; i < ss_dim; i++)
6912 ss->dim[i] = ss->dim[i + 1];
6914 ss->dim[ss_dim] = 0;
6920 ss->nested_ss->parent = new_ss;
6921 new_ss->nested_ss = ss->nested_ss;
6923 ss->nested_ss = new_ss;
6926 new_loop = gfc_get_loopinfo ();
6927 gfc_init_loopinfo (new_loop);
6929 gcc_assert (prev_ss != NULL);
6930 gcc_assert (prev_ss != gfc_ss_terminator);
6931 gfc_add_ss_to_loop (new_loop, prev_ss);
6932 return new_ss->parent;
6936 /* Create the gfc_ss list for the SUM/PRODUCT arguments when the function
6937 is to be inlined. */
6940 walk_inline_intrinsic_arith (gfc_ss *ss, gfc_expr *expr)
6942 gfc_ss *tmp_ss, *tail, *array_ss;
6943 gfc_actual_arglist *arg1, *arg2, *arg3;
6945 bool scalar_mask = false;
6947 /* The rank of the result will be determined later. */
6948 arg1 = expr->value.function.actual;
6951 gcc_assert (arg3 != NULL);
6953 if (expr->rank == 0)
6956 tmp_ss = gfc_ss_terminator;
6962 mask_ss = gfc_walk_subexpr (tmp_ss, arg3->expr);
6963 if (mask_ss == tmp_ss)
6969 array_ss = gfc_walk_subexpr (tmp_ss, arg1->expr);
6970 gcc_assert (array_ss != tmp_ss);
6972 /* Odd thing: If the mask is scalar, it is used by the frontend after
6973 the array (to make an if around the nested loop). Thus it shall
6974 be after array_ss once the gfc_ss list is reversed. */
6976 tmp_ss = gfc_get_scalar_ss (array_ss, arg3->expr);
6980 /* "Hide" the dimension on which we will sum in the first arg's scalarization
6982 sum_dim = mpz_get_si (arg2->expr->value.integer) - 1;
6983 tail = nest_loop_dimension (tmp_ss, sum_dim);
6991 walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr)
6994 switch (expr->value.function.isym->id)
6996 case GFC_ISYM_PRODUCT:
6998 return walk_inline_intrinsic_arith (ss, expr);
7000 case GFC_ISYM_TRANSPOSE:
7001 return walk_inline_intrinsic_transpose (ss, expr);
7010 /* This generates code to execute before entering the scalarization loop.
7011 Currently does nothing. */
7014 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
7016 switch (ss->info->expr->value.function.isym->id)
7018 case GFC_ISYM_UBOUND:
7019 case GFC_ISYM_LBOUND:
7020 case GFC_ISYM_UCOBOUND:
7021 case GFC_ISYM_LCOBOUND:
7022 case GFC_ISYM_THIS_IMAGE:
7031 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
7032 are expanded into code inside the scalarization loop. */
7035 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
7037 if (expr->value.function.actual->expr->ts.type == BT_CLASS)
7038 gfc_add_class_array_ref (expr->value.function.actual->expr);
7040 /* The two argument version returns a scalar. */
7041 if (expr->value.function.actual->next->expr)
7044 return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
7048 /* Walk an intrinsic array libcall. */
7051 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
7053 gcc_assert (expr->rank > 0);
7054 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
7058 /* Return whether the function call expression EXPR will be expanded
7059 inline by gfc_conv_intrinsic_function. */
7062 gfc_inline_intrinsic_function_p (gfc_expr *expr)
7064 gfc_actual_arglist *args;
7066 if (!expr->value.function.isym)
7069 switch (expr->value.function.isym->id)
7071 case GFC_ISYM_PRODUCT:
7073 /* Disable inline expansion if code size matters. */
7077 args = expr->value.function.actual;
7078 /* We need to be able to subset the SUM argument at compile-time. */
7079 if (args->next->expr && args->next->expr->expr_type != EXPR_CONSTANT)
7084 case GFC_ISYM_TRANSPOSE:
7093 /* Returns nonzero if the specified intrinsic function call maps directly to
7094 an external library call. Should only be used for functions that return
7098 gfc_is_intrinsic_libcall (gfc_expr * expr)
7100 gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
7101 gcc_assert (expr->rank > 0);
7103 if (gfc_inline_intrinsic_function_p (expr))
7106 switch (expr->value.function.isym->id)
7110 case GFC_ISYM_COUNT:
7114 case GFC_ISYM_IPARITY:
7115 case GFC_ISYM_MATMUL:
7116 case GFC_ISYM_MAXLOC:
7117 case GFC_ISYM_MAXVAL:
7118 case GFC_ISYM_MINLOC:
7119 case GFC_ISYM_MINVAL:
7120 case GFC_ISYM_NORM2:
7121 case GFC_ISYM_PARITY:
7122 case GFC_ISYM_PRODUCT:
7124 case GFC_ISYM_SHAPE:
7125 case GFC_ISYM_SPREAD:
7127 /* Ignore absent optional parameters. */
7130 case GFC_ISYM_RESHAPE:
7131 case GFC_ISYM_CSHIFT:
7132 case GFC_ISYM_EOSHIFT:
7134 case GFC_ISYM_UNPACK:
7135 /* Pass absent optional parameters. */
7143 /* Walk an intrinsic function. */
7145 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
7146 gfc_intrinsic_sym * isym)
7150 if (isym->elemental)
7151 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
7152 NULL, GFC_SS_SCALAR);
7154 if (expr->rank == 0)
7157 if (gfc_inline_intrinsic_function_p (expr))
7158 return walk_inline_intrinsic_function (ss, expr);
7160 if (gfc_is_intrinsic_libcall (expr))
7161 return gfc_walk_intrinsic_libfunc (ss, expr);
7163 /* Special cases. */
7166 case GFC_ISYM_LBOUND:
7167 case GFC_ISYM_LCOBOUND:
7168 case GFC_ISYM_UBOUND:
7169 case GFC_ISYM_UCOBOUND:
7170 case GFC_ISYM_THIS_IMAGE:
7171 return gfc_walk_intrinsic_bound (ss, expr);
7173 case GFC_ISYM_TRANSFER:
7174 return gfc_walk_intrinsic_libfunc (ss, expr);
7177 /* This probably meant someone forgot to add an intrinsic to the above
7178 list(s) when they implemented it, or something's gone horribly
7186 conv_intrinsic_atomic_def (gfc_code *code)
7191 gfc_init_se (&atom, NULL);
7192 gfc_init_se (&value, NULL);
7193 gfc_conv_expr (&atom, code->ext.actual->expr);
7194 gfc_conv_expr (&value, code->ext.actual->next->expr);
7196 gfc_init_block (&block);
7197 gfc_add_modify (&block, atom.expr,
7198 fold_convert (TREE_TYPE (atom.expr), value.expr));
7199 return gfc_finish_block (&block);
7204 conv_intrinsic_atomic_ref (gfc_code *code)
7209 gfc_init_se (&atom, NULL);
7210 gfc_init_se (&value, NULL);
7211 gfc_conv_expr (&value, code->ext.actual->expr);
7212 gfc_conv_expr (&atom, code->ext.actual->next->expr);
7214 gfc_init_block (&block);
7215 gfc_add_modify (&block, value.expr,
7216 fold_convert (TREE_TYPE (value.expr), atom.expr));
7217 return gfc_finish_block (&block);
7222 conv_intrinsic_move_alloc (gfc_code *code)
7225 gfc_expr *from_expr, *to_expr;
7226 gfc_expr *to_expr2, *from_expr2 = NULL;
7227 gfc_se from_se, to_se;
7228 gfc_ss *from_ss, *to_ss;
7231 gfc_start_block (&block);
7233 from_expr = code->ext.actual->expr;
7234 to_expr = code->ext.actual->next->expr;
7236 gfc_init_se (&from_se, NULL);
7237 gfc_init_se (&to_se, NULL);
7239 gcc_assert (from_expr->ts.type != BT_CLASS
7240 || to_expr->ts.type == BT_CLASS);
7242 if (from_expr->rank == 0)
7244 if (from_expr->ts.type != BT_CLASS)
7245 from_expr2 = from_expr;
7248 from_expr2 = gfc_copy_expr (from_expr);
7249 gfc_add_data_component (from_expr2);
7252 if (to_expr->ts.type != BT_CLASS)
7256 to_expr2 = gfc_copy_expr (to_expr);
7257 gfc_add_data_component (to_expr2);
7260 from_se.want_pointer = 1;
7261 to_se.want_pointer = 1;
7262 gfc_conv_expr (&from_se, from_expr2);
7263 gfc_conv_expr (&to_se, to_expr2);
7264 gfc_add_block_to_block (&block, &from_se.pre);
7265 gfc_add_block_to_block (&block, &to_se.pre);
7267 /* Deallocate "to". */
7268 tmp = gfc_deallocate_scalar_with_status (to_se.expr, NULL_TREE, true,
7269 to_expr2, to_expr->ts);
7270 gfc_add_expr_to_block (&block, tmp);
7272 /* Assign (_data) pointers. */
7273 gfc_add_modify_loc (input_location, &block, to_se.expr,
7274 fold_convert (TREE_TYPE (to_se.expr), from_se.expr));
7276 /* Set "from" to NULL. */
7277 gfc_add_modify_loc (input_location, &block, from_se.expr,
7278 fold_convert (TREE_TYPE (from_se.expr), null_pointer_node));
7280 gfc_add_block_to_block (&block, &from_se.post);
7281 gfc_add_block_to_block (&block, &to_se.post);
7284 if (to_expr->ts.type == BT_CLASS)
7286 gfc_free_expr (to_expr2);
7287 gfc_init_se (&to_se, NULL);
7288 to_se.want_pointer = 1;
7289 gfc_add_vptr_component (to_expr);
7290 gfc_conv_expr (&to_se, to_expr);
7292 if (from_expr->ts.type == BT_CLASS)
7294 gfc_free_expr (from_expr2);
7295 gfc_init_se (&from_se, NULL);
7296 from_se.want_pointer = 1;
7297 gfc_add_vptr_component (from_expr);
7298 gfc_conv_expr (&from_se, from_expr);
7304 vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
7306 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
7309 gfc_add_modify_loc (input_location, &block, to_se.expr,
7310 fold_convert (TREE_TYPE (to_se.expr), tmp));
7313 return gfc_finish_block (&block);
7316 /* Update _vptr component. */
7317 if (to_expr->ts.type == BT_CLASS)
7319 to_se.want_pointer = 1;
7320 to_expr2 = gfc_copy_expr (to_expr);
7321 gfc_add_vptr_component (to_expr2);
7322 gfc_conv_expr (&to_se, to_expr2);
7324 if (from_expr->ts.type == BT_CLASS)
7326 from_se.want_pointer = 1;
7327 from_expr2 = gfc_copy_expr (from_expr);
7328 gfc_add_vptr_component (from_expr2);
7329 gfc_conv_expr (&from_se, from_expr2);
7335 vtab = gfc_find_derived_vtab (from_expr->ts.u.derived);
7337 tmp = gfc_build_addr_expr (NULL_TREE, gfc_get_symbol_decl (vtab));
7340 gfc_add_modify_loc (input_location, &block, to_se.expr,
7341 fold_convert (TREE_TYPE (to_se.expr), tmp));
7342 gfc_free_expr (to_expr2);
7343 gfc_init_se (&to_se, NULL);
7345 if (from_expr->ts.type == BT_CLASS)
7347 gfc_free_expr (from_expr2);
7348 gfc_init_se (&from_se, NULL);
7352 /* Deallocate "to". */
7353 to_ss = gfc_walk_expr (to_expr);
7354 from_ss = gfc_walk_expr (from_expr);
7355 gfc_conv_expr_descriptor (&to_se, to_expr, to_ss);
7356 gfc_conv_expr_descriptor (&from_se, from_expr, from_ss);
7358 tmp = gfc_conv_descriptor_data_get (to_se.expr);
7359 tmp = gfc_deallocate_with_status (tmp, NULL_TREE, NULL_TREE, NULL_TREE,
7360 NULL_TREE, true, to_expr, false);
7361 gfc_add_expr_to_block (&block, tmp);
7363 /* Move the pointer and update the array descriptor data. */
7364 gfc_add_modify_loc (input_location, &block, to_se.expr, from_se.expr);
7366 /* Set "to" to NULL. */
7367 tmp = gfc_conv_descriptor_data_get (from_se.expr);
7368 gfc_add_modify_loc (input_location, &block, tmp,
7369 fold_convert (TREE_TYPE (tmp), null_pointer_node));
7371 return gfc_finish_block (&block);
7376 gfc_conv_intrinsic_subroutine (gfc_code *code)
7380 gcc_assert (code->resolved_isym);
7382 switch (code->resolved_isym->id)
7384 case GFC_ISYM_MOVE_ALLOC:
7385 res = conv_intrinsic_move_alloc (code);
7388 case GFC_ISYM_ATOMIC_DEF:
7389 res = conv_intrinsic_atomic_def (code);
7392 case GFC_ISYM_ATOMIC_REF:
7393 res = conv_intrinsic_atomic_ref (code);
7404 #include "gt-fortran-trans-intrinsic.h"