1 /* Intrinsic translation
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
23 /* trans-intrinsic.c-- generate GENERIC trees for calls to intrinsics. */
27 #include "coretypes.h"
28 #include "tm.h" /* For UNITS_PER_WORD. */
31 #include "diagnostic-core.h" /* For internal_error. */
32 #include "toplev.h" /* For rest_of_decl_compilation. */
36 #include "intrinsic.h"
38 #include "trans-const.h"
39 #include "trans-types.h"
40 #include "trans-array.h"
42 /* Only for gfc_trans_assign and gfc_trans_pointer_assign. */
43 #include "trans-stmt.h"
45 /* This maps fortran intrinsic math functions to external library or GCC
47 typedef struct GTY(()) gfc_intrinsic_map_t {
48 /* The explicit enum is required to work around inadequacies in the
49 garbage collection/gengtype parsing mechanism. */
52 /* Enum value from the "language-independent", aka C-centric, part
53 of gcc, or END_BUILTINS of no such value set. */
54 enum built_in_function float_built_in;
55 enum built_in_function double_built_in;
56 enum built_in_function long_double_built_in;
57 enum built_in_function complex_float_built_in;
58 enum built_in_function complex_double_built_in;
59 enum built_in_function complex_long_double_built_in;
61 /* True if the naming pattern is to prepend "c" for complex and
62 append "f" for kind=4. False if the naming pattern is to
63 prepend "_gfortran_" and append "[rc](4|8|10|16)". */
66 /* True if a complex version of the function exists. */
67 bool complex_available;
69 /* True if the function should be marked const. */
72 /* The base library name of this function. */
75 /* Cache decls created for the various operand types. */
87 /* ??? The NARGS==1 hack here is based on the fact that (c99 at least)
88 defines complex variants of all of the entries in mathbuiltins.def
90 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE) \
91 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
92 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
93 true, false, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, \
94 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
96 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE) \
97 { GFC_ISYM_ ## ID, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
98 BUILT_IN_ ## ID ## L, BUILT_IN_C ## ID ## F, BUILT_IN_C ## ID, \
99 BUILT_IN_C ## ID ## L, true, true, true, NAME, NULL_TREE, NULL_TREE, \
100 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
102 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX) \
103 { GFC_ISYM_ ## ID, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
104 END_BUILTINS, END_BUILTINS, END_BUILTINS, \
105 false, HAVE_COMPLEX, true, NAME, NULL_TREE, NULL_TREE, NULL_TREE, \
106 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE }
108 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
109 { GFC_ISYM_NONE, BUILT_IN_ ## ID ## F, BUILT_IN_ ## ID, \
110 BUILT_IN_ ## ID ## L, END_BUILTINS, END_BUILTINS, END_BUILTINS, \
111 true, false, CONST, NAME, NULL_TREE, NULL_TREE, \
112 NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE, NULL_TREE},
114 static GTY(()) gfc_intrinsic_map_t gfc_intrinsic_map[] =
116 /* Functions built into gcc itself (DEFINE_MATH_BUILTIN and
117 DEFINE_MATH_BUILTIN_C), then the built-ins that don't correspond
118 to any GFC_ISYM id directly, which use the OTHER_BUILTIN macro. */
119 #include "mathbuiltins.def"
121 /* Functions in libgfortran. */
122 LIB_FUNCTION (ERFC_SCALED, "erfc_scaled", false),
125 LIB_FUNCTION (NONE, NULL, false)
130 #undef DEFINE_MATH_BUILTIN
131 #undef DEFINE_MATH_BUILTIN_C
134 enum rounding_mode { RND_ROUND, RND_TRUNC, RND_CEIL, RND_FLOOR };
137 /* Find the correct variant of a given builtin from its argument. */
139 builtin_decl_for_precision (enum built_in_function base_built_in,
142 enum built_in_function i = END_BUILTINS;
144 gfc_intrinsic_map_t *m;
145 for (m = gfc_intrinsic_map; m->double_built_in != base_built_in ; m++)
148 if (precision == TYPE_PRECISION (float_type_node))
149 i = m->float_built_in;
150 else if (precision == TYPE_PRECISION (double_type_node))
151 i = m->double_built_in;
152 else if (precision == TYPE_PRECISION (long_double_type_node))
153 i = m->long_double_built_in;
154 else if (precision == TYPE_PRECISION (float128_type_node))
156 /* Special treatment, because it is not exactly a built-in, but
157 a library function. */
158 return m->real16_decl;
161 return (i == END_BUILTINS ? NULL_TREE : builtin_decl_explicit (i));
166 gfc_builtin_decl_for_float_kind (enum built_in_function double_built_in,
169 int i = gfc_validate_kind (BT_REAL, kind, false);
171 if (gfc_real_kinds[i].c_float128)
173 /* For __float128, the story is a bit different, because we return
174 a decl to a library function rather than a built-in. */
175 gfc_intrinsic_map_t *m;
176 for (m = gfc_intrinsic_map; m->double_built_in != double_built_in ; m++)
179 return m->real16_decl;
182 return builtin_decl_for_precision (double_built_in,
183 gfc_real_kinds[i].mode_precision);
187 /* Evaluate the arguments to an intrinsic function. The value
188 of NARGS may be less than the actual number of arguments in EXPR
189 to allow optional "KIND" arguments that are not included in the
190 generated code to be ignored. */
193 gfc_conv_intrinsic_function_args (gfc_se *se, gfc_expr *expr,
194 tree *argarray, int nargs)
196 gfc_actual_arglist *actual;
198 gfc_intrinsic_arg *formal;
202 formal = expr->value.function.isym->formal;
203 actual = expr->value.function.actual;
205 for (curr_arg = 0; curr_arg < nargs; curr_arg++,
206 actual = actual->next,
207 formal = formal ? formal->next : NULL)
211 /* Skip omitted optional arguments. */
218 /* Evaluate the parameter. This will substitute scalarized
219 references automatically. */
220 gfc_init_se (&argse, se);
222 if (e->ts.type == BT_CHARACTER)
224 gfc_conv_expr (&argse, e);
225 gfc_conv_string_parameter (&argse);
226 argarray[curr_arg++] = argse.string_length;
227 gcc_assert (curr_arg < nargs);
230 gfc_conv_expr_val (&argse, e);
232 /* If an optional argument is itself an optional dummy argument,
233 check its presence and substitute a null if absent. */
234 if (e->expr_type == EXPR_VARIABLE
235 && e->symtree->n.sym->attr.optional
238 gfc_conv_missing_dummy (&argse, e, formal->ts, 0);
240 gfc_add_block_to_block (&se->pre, &argse.pre);
241 gfc_add_block_to_block (&se->post, &argse.post);
242 argarray[curr_arg] = argse.expr;
246 /* Count the number of actual arguments to the intrinsic function EXPR
247 including any "hidden" string length arguments. */
250 gfc_intrinsic_argument_list_length (gfc_expr *expr)
253 gfc_actual_arglist *actual;
255 for (actual = expr->value.function.actual; actual; actual = actual->next)
260 if (actual->expr->ts.type == BT_CHARACTER)
270 /* Conversions between different types are output by the frontend as
271 intrinsic functions. We implement these directly with inline code. */
274 gfc_conv_intrinsic_conversion (gfc_se * se, gfc_expr * expr)
280 nargs = gfc_intrinsic_argument_list_length (expr);
281 args = XALLOCAVEC (tree, nargs);
283 /* Evaluate all the arguments passed. Whilst we're only interested in the
284 first one here, there are other parts of the front-end that assume this
285 and will trigger an ICE if it's not the case. */
286 type = gfc_typenode_for_spec (&expr->ts);
287 gcc_assert (expr->value.function.actual->expr);
288 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
290 /* Conversion between character kinds involves a call to a library
292 if (expr->ts.type == BT_CHARACTER)
294 tree fndecl, var, addr, tmp;
296 if (expr->ts.kind == 1
297 && expr->value.function.actual->expr->ts.kind == 4)
298 fndecl = gfor_fndecl_convert_char4_to_char1;
299 else if (expr->ts.kind == 4
300 && expr->value.function.actual->expr->ts.kind == 1)
301 fndecl = gfor_fndecl_convert_char1_to_char4;
305 /* Create the variable storing the converted value. */
306 type = gfc_get_pchar_type (expr->ts.kind);
307 var = gfc_create_var (type, "str");
308 addr = gfc_build_addr_expr (build_pointer_type (type), var);
310 /* Call the library function that will perform the conversion. */
311 gcc_assert (nargs >= 2);
312 tmp = build_call_expr_loc (input_location,
313 fndecl, 3, addr, args[0], args[1]);
314 gfc_add_expr_to_block (&se->pre, tmp);
316 /* Free the temporary afterwards. */
317 tmp = gfc_call_free (var);
318 gfc_add_expr_to_block (&se->post, tmp);
321 se->string_length = args[0];
326 /* Conversion from complex to non-complex involves taking the real
327 component of the value. */
328 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
329 && expr->ts.type != BT_COMPLEX)
333 artype = TREE_TYPE (TREE_TYPE (args[0]));
334 args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
338 se->expr = convert (type, args[0]);
341 /* This is needed because the gcc backend only implements
342 FIX_TRUNC_EXPR, which is the same as INT() in Fortran.
343 FLOOR(x) = INT(x) <= x ? INT(x) : INT(x) - 1
344 Similarly for CEILING. */
347 build_fixbound_expr (stmtblock_t * pblock, tree arg, tree type, int up)
354 argtype = TREE_TYPE (arg);
355 arg = gfc_evaluate_now (arg, pblock);
357 intval = convert (type, arg);
358 intval = gfc_evaluate_now (intval, pblock);
360 tmp = convert (argtype, intval);
361 cond = fold_build2_loc (input_location, up ? GE_EXPR : LE_EXPR,
362 boolean_type_node, tmp, arg);
364 tmp = fold_build2_loc (input_location, up ? PLUS_EXPR : MINUS_EXPR, type,
365 intval, build_int_cst (type, 1));
366 tmp = fold_build3_loc (input_location, COND_EXPR, type, cond, intval, tmp);
371 /* Round to nearest integer, away from zero. */
374 build_round_expr (tree arg, tree restype)
379 int argprec, resprec;
381 argtype = TREE_TYPE (arg);
382 argprec = TYPE_PRECISION (argtype);
383 resprec = TYPE_PRECISION (restype);
385 /* Depending on the type of the result, choose the long int intrinsic
386 (lround family) or long long intrinsic (llround). We might also
387 need to convert the result afterwards. */
388 if (resprec <= LONG_TYPE_SIZE)
390 else if (resprec <= LONG_LONG_TYPE_SIZE)
395 /* Now, depending on the argument type, we choose between intrinsics. */
397 fn = builtin_decl_for_precision (BUILT_IN_LLROUND, argprec);
399 fn = builtin_decl_for_precision (BUILT_IN_LROUND, argprec);
401 return fold_convert (restype, build_call_expr_loc (input_location,
406 /* Convert a real to an integer using a specific rounding mode.
407 Ideally we would just build the corresponding GENERIC node,
408 however the RTL expander only actually supports FIX_TRUNC_EXPR. */
411 build_fix_expr (stmtblock_t * pblock, tree arg, tree type,
412 enum rounding_mode op)
417 return build_fixbound_expr (pblock, arg, type, 0);
421 return build_fixbound_expr (pblock, arg, type, 1);
425 return build_round_expr (arg, type);
429 return fold_build1_loc (input_location, FIX_TRUNC_EXPR, type, arg);
438 /* Round a real value using the specified rounding mode.
439 We use a temporary integer of that same kind size as the result.
440 Values larger than those that can be represented by this kind are
441 unchanged, as they will not be accurate enough to represent the
443 huge = HUGE (KIND (a))
444 aint (a) = ((a > huge) || (a < -huge)) ? a : (real)(int)a
448 gfc_conv_intrinsic_aint (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
460 kind = expr->ts.kind;
461 nargs = gfc_intrinsic_argument_list_length (expr);
464 /* We have builtin functions for some cases. */
468 decl = gfc_builtin_decl_for_float_kind (BUILT_IN_ROUND, kind);
472 decl = gfc_builtin_decl_for_float_kind (BUILT_IN_TRUNC, kind);
479 /* Evaluate the argument. */
480 gcc_assert (expr->value.function.actual->expr);
481 gfc_conv_intrinsic_function_args (se, expr, arg, nargs);
483 /* Use a builtin function if one exists. */
484 if (decl != NULL_TREE)
486 se->expr = build_call_expr_loc (input_location, decl, 1, arg[0]);
490 /* This code is probably redundant, but we'll keep it lying around just
492 type = gfc_typenode_for_spec (&expr->ts);
493 arg[0] = gfc_evaluate_now (arg[0], &se->pre);
495 /* Test if the value is too large to handle sensibly. */
496 gfc_set_model_kind (kind);
498 n = gfc_validate_kind (BT_INTEGER, kind, false);
499 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
500 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
501 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, arg[0],
504 mpfr_neg (huge, huge, GFC_RND_MODE);
505 tmp = gfc_conv_mpfr_to_tree (huge, kind, 0);
506 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, arg[0],
508 cond = fold_build2_loc (input_location, TRUTH_AND_EXPR, boolean_type_node,
510 itype = gfc_get_int_type (kind);
512 tmp = build_fix_expr (&se->pre, arg[0], itype, op);
513 tmp = convert (type, tmp);
514 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
520 /* Convert to an integer using the specified rounding mode. */
523 gfc_conv_intrinsic_int (gfc_se * se, gfc_expr * expr, enum rounding_mode op)
529 nargs = gfc_intrinsic_argument_list_length (expr);
530 args = XALLOCAVEC (tree, nargs);
532 /* Evaluate the argument, we process all arguments even though we only
533 use the first one for code generation purposes. */
534 type = gfc_typenode_for_spec (&expr->ts);
535 gcc_assert (expr->value.function.actual->expr);
536 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
538 if (TREE_CODE (TREE_TYPE (args[0])) == INTEGER_TYPE)
540 /* Conversion to a different integer kind. */
541 se->expr = convert (type, args[0]);
545 /* Conversion from complex to non-complex involves taking the real
546 component of the value. */
547 if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE
548 && expr->ts.type != BT_COMPLEX)
552 artype = TREE_TYPE (TREE_TYPE (args[0]));
553 args[0] = fold_build1_loc (input_location, REALPART_EXPR, artype,
557 se->expr = build_fix_expr (&se->pre, args[0], type, op);
562 /* Get the imaginary component of a value. */
565 gfc_conv_intrinsic_imagpart (gfc_se * se, gfc_expr * expr)
569 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
570 se->expr = fold_build1_loc (input_location, IMAGPART_EXPR,
571 TREE_TYPE (TREE_TYPE (arg)), arg);
575 /* Get the complex conjugate of a value. */
578 gfc_conv_intrinsic_conjg (gfc_se * se, gfc_expr * expr)
582 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
583 se->expr = fold_build1_loc (input_location, CONJ_EXPR, TREE_TYPE (arg), arg);
589 define_quad_builtin (const char *name, tree type, bool is_const)
592 fndecl = build_decl (input_location, FUNCTION_DECL, get_identifier (name),
595 /* Mark the decl as external. */
596 DECL_EXTERNAL (fndecl) = 1;
597 TREE_PUBLIC (fndecl) = 1;
599 /* Mark it __attribute__((const)). */
600 TREE_READONLY (fndecl) = is_const;
602 rest_of_decl_compilation (fndecl, 1, 0);
609 /* Initialize function decls for library functions. The external functions
610 are created as required. Builtin functions are added here. */
613 gfc_build_intrinsic_lib_fndecls (void)
615 gfc_intrinsic_map_t *m;
616 tree quad_decls[END_BUILTINS + 1];
618 if (gfc_real16_is_float128)
620 /* If we have soft-float types, we create the decls for their
621 C99-like library functions. For now, we only handle __float128
622 q-suffixed functions. */
624 tree type, complex_type, func_1, func_2, func_cabs, func_frexp;
625 tree func_lround, func_llround, func_scalbn, func_cpow;
627 memset (quad_decls, 0, sizeof(tree) * (END_BUILTINS + 1));
629 type = float128_type_node;
630 complex_type = complex_float128_type_node;
631 /* type (*) (type) */
632 func_1 = build_function_type_list (type, type, NULL_TREE);
633 /* long (*) (type) */
634 func_lround = build_function_type_list (long_integer_type_node,
636 /* long long (*) (type) */
637 func_llround = build_function_type_list (long_long_integer_type_node,
639 /* type (*) (type, type) */
640 func_2 = build_function_type_list (type, type, type, NULL_TREE);
641 /* type (*) (type, &int) */
643 = build_function_type_list (type,
645 build_pointer_type (integer_type_node),
647 /* type (*) (type, int) */
648 func_scalbn = build_function_type_list (type,
649 type, integer_type_node, NULL_TREE);
650 /* type (*) (complex type) */
651 func_cabs = build_function_type_list (type, complex_type, NULL_TREE);
652 /* complex type (*) (complex type, complex type) */
654 = build_function_type_list (complex_type,
655 complex_type, complex_type, NULL_TREE);
657 #define DEFINE_MATH_BUILTIN(ID, NAME, ARGTYPE)
658 #define DEFINE_MATH_BUILTIN_C(ID, NAME, ARGTYPE)
659 #define LIB_FUNCTION(ID, NAME, HAVE_COMPLEX)
661 /* Only these built-ins are actually needed here. These are used directly
662 from the code, when calling builtin_decl_for_precision() or
663 builtin_decl_for_float_type(). The others are all constructed by
664 gfc_get_intrinsic_lib_fndecl(). */
665 #define OTHER_BUILTIN(ID, NAME, TYPE, CONST) \
666 quad_decls[BUILT_IN_ ## ID] = define_quad_builtin (NAME "q", func_ ## TYPE, CONST);
668 #include "mathbuiltins.def"
672 #undef DEFINE_MATH_BUILTIN
673 #undef DEFINE_MATH_BUILTIN_C
677 /* Add GCC builtin functions. */
678 for (m = gfc_intrinsic_map;
679 m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
681 if (m->float_built_in != END_BUILTINS)
682 m->real4_decl = builtin_decl_explicit (m->float_built_in);
683 if (m->complex_float_built_in != END_BUILTINS)
684 m->complex4_decl = builtin_decl_explicit (m->complex_float_built_in);
685 if (m->double_built_in != END_BUILTINS)
686 m->real8_decl = builtin_decl_explicit (m->double_built_in);
687 if (m->complex_double_built_in != END_BUILTINS)
688 m->complex8_decl = builtin_decl_explicit (m->complex_double_built_in);
690 /* If real(kind=10) exists, it is always long double. */
691 if (m->long_double_built_in != END_BUILTINS)
692 m->real10_decl = builtin_decl_explicit (m->long_double_built_in);
693 if (m->complex_long_double_built_in != END_BUILTINS)
695 = builtin_decl_explicit (m->complex_long_double_built_in);
697 if (!gfc_real16_is_float128)
699 if (m->long_double_built_in != END_BUILTINS)
700 m->real16_decl = builtin_decl_explicit (m->long_double_built_in);
701 if (m->complex_long_double_built_in != END_BUILTINS)
703 = builtin_decl_explicit (m->complex_long_double_built_in);
705 else if (quad_decls[m->double_built_in] != NULL_TREE)
707 /* Quad-precision function calls are constructed when first
708 needed by builtin_decl_for_precision(), except for those
709 that will be used directly (define by OTHER_BUILTIN). */
710 m->real16_decl = quad_decls[m->double_built_in];
712 else if (quad_decls[m->complex_double_built_in] != NULL_TREE)
714 /* Same thing for the complex ones. */
715 m->complex16_decl = quad_decls[m->double_built_in];
721 /* Create a fndecl for a simple intrinsic library function. */
724 gfc_get_intrinsic_lib_fndecl (gfc_intrinsic_map_t * m, gfc_expr * expr)
727 VEC(tree,gc) *argtypes;
729 gfc_actual_arglist *actual;
732 char name[GFC_MAX_SYMBOL_LEN + 3];
735 if (ts->type == BT_REAL)
740 pdecl = &m->real4_decl;
743 pdecl = &m->real8_decl;
746 pdecl = &m->real10_decl;
749 pdecl = &m->real16_decl;
755 else if (ts->type == BT_COMPLEX)
757 gcc_assert (m->complex_available);
762 pdecl = &m->complex4_decl;
765 pdecl = &m->complex8_decl;
768 pdecl = &m->complex10_decl;
771 pdecl = &m->complex16_decl;
785 int n = gfc_validate_kind (BT_REAL, ts->kind, false);
786 if (gfc_real_kinds[n].c_float)
787 snprintf (name, sizeof (name), "%s%s%s",
788 ts->type == BT_COMPLEX ? "c" : "", m->name, "f");
789 else if (gfc_real_kinds[n].c_double)
790 snprintf (name, sizeof (name), "%s%s",
791 ts->type == BT_COMPLEX ? "c" : "", m->name);
792 else if (gfc_real_kinds[n].c_long_double)
793 snprintf (name, sizeof (name), "%s%s%s",
794 ts->type == BT_COMPLEX ? "c" : "", m->name, "l");
795 else if (gfc_real_kinds[n].c_float128)
796 snprintf (name, sizeof (name), "%s%s%s",
797 ts->type == BT_COMPLEX ? "c" : "", m->name, "q");
803 snprintf (name, sizeof (name), PREFIX ("%s_%c%d"), m->name,
804 ts->type == BT_COMPLEX ? 'c' : 'r',
809 for (actual = expr->value.function.actual; actual; actual = actual->next)
811 type = gfc_typenode_for_spec (&actual->expr->ts);
812 VEC_safe_push (tree, gc, argtypes, type);
814 type = build_function_type_vec (gfc_typenode_for_spec (ts), argtypes);
815 fndecl = build_decl (input_location,
816 FUNCTION_DECL, get_identifier (name), type);
818 /* Mark the decl as external. */
819 DECL_EXTERNAL (fndecl) = 1;
820 TREE_PUBLIC (fndecl) = 1;
822 /* Mark it __attribute__((const)), if possible. */
823 TREE_READONLY (fndecl) = m->is_constant;
825 rest_of_decl_compilation (fndecl, 1, 0);
832 /* Convert an intrinsic function into an external or builtin call. */
835 gfc_conv_intrinsic_lib_function (gfc_se * se, gfc_expr * expr)
837 gfc_intrinsic_map_t *m;
841 unsigned int num_args;
844 id = expr->value.function.isym->id;
845 /* Find the entry for this function. */
846 for (m = gfc_intrinsic_map;
847 m->id != GFC_ISYM_NONE || m->double_built_in != END_BUILTINS; m++)
853 if (m->id == GFC_ISYM_NONE)
855 internal_error ("Intrinsic function %s(%d) not recognized",
856 expr->value.function.name, id);
859 /* Get the decl and generate the call. */
860 num_args = gfc_intrinsic_argument_list_length (expr);
861 args = XALLOCAVEC (tree, num_args);
863 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
864 fndecl = gfc_get_intrinsic_lib_fndecl (m, expr);
865 rettype = TREE_TYPE (TREE_TYPE (fndecl));
867 fndecl = build_addr (fndecl, current_function_decl);
868 se->expr = build_call_array_loc (input_location, rettype, fndecl, num_args, args);
872 /* If bounds-checking is enabled, create code to verify at runtime that the
873 string lengths for both expressions are the same (needed for e.g. MERGE).
874 If bounds-checking is not enabled, does nothing. */
877 gfc_trans_same_strlen_check (const char* intr_name, locus* where,
878 tree a, tree b, stmtblock_t* target)
883 /* If bounds-checking is disabled, do nothing. */
884 if (!(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS))
887 /* Compare the two string lengths. */
888 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, a, b);
890 /* Output the runtime-check. */
891 name = gfc_build_cstring_const (intr_name);
892 name = gfc_build_addr_expr (pchar_type_node, name);
893 gfc_trans_runtime_check (true, false, cond, target, where,
894 "Unequal character lengths (%ld/%ld) in %s",
895 fold_convert (long_integer_type_node, a),
896 fold_convert (long_integer_type_node, b), name);
900 /* The EXPONENT(s) intrinsic function is translated into
907 gfc_conv_intrinsic_exponent (gfc_se *se, gfc_expr *expr)
909 tree arg, type, res, tmp, frexp;
911 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP,
912 expr->value.function.actual->expr->ts.kind);
914 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
916 res = gfc_create_var (integer_type_node, NULL);
917 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
918 gfc_build_addr_expr (NULL_TREE, res));
919 gfc_add_expr_to_block (&se->pre, tmp);
921 type = gfc_typenode_for_spec (&expr->ts);
922 se->expr = fold_convert (type, res);
926 /* Convert the last ref of a scalar coarray from an AR_ELEMENT to an
927 AR_FULL, suitable for the scalarizer. */
930 walk_coarray (gfc_expr *e)
934 gcc_assert (gfc_get_corank (e) > 0);
936 ss = gfc_walk_expr (e);
938 /* Fix scalar coarray. */
939 if (ss == gfc_ss_terminator)
946 if (ref->type == REF_ARRAY
947 && ref->u.ar.codimen > 0)
953 gcc_assert (ref != NULL);
954 if (ref->u.ar.type == AR_ELEMENT)
955 ref->u.ar.type = AR_SECTION;
956 ss = gfc_reverse_ss (gfc_walk_array_ref (ss, e, ref));
964 trans_this_image (gfc_se * se, gfc_expr *expr)
967 tree type, desc, dim_arg, cond, tmp, m, loop_var, exit_label, min_var,
968 lbound, ubound, extent, ml;
973 /* The case -fcoarray=single is handled elsewhere. */
974 gcc_assert (gfc_option.coarray != GFC_FCOARRAY_SINGLE);
976 gfc_init_coarray_decl (false);
978 /* Argument-free version: THIS_IMAGE(). */
979 if (expr->value.function.actual->expr == NULL)
981 se->expr = gfort_gvar_caf_this_image;
985 /* Coarray-argument version: THIS_IMAGE(coarray [, dim]). */
987 type = gfc_get_int_type (gfc_default_integer_kind);
988 corank = gfc_get_corank (expr->value.function.actual->expr);
989 rank = expr->value.function.actual->expr->rank;
991 /* Obtain the descriptor of the COARRAY. */
992 gfc_init_se (&argse, NULL);
993 ss = walk_coarray (expr->value.function.actual->expr);
994 gcc_assert (ss != gfc_ss_terminator);
995 argse.want_coarray = 1;
996 gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss);
997 gfc_add_block_to_block (&se->pre, &argse.pre);
998 gfc_add_block_to_block (&se->post, &argse.post);
1003 /* Create an implicit second parameter from the loop variable. */
1004 gcc_assert (!expr->value.function.actual->next->expr);
1005 gcc_assert (corank > 0);
1006 gcc_assert (se->loop->dimen == 1);
1007 gcc_assert (se->ss->info->expr == expr);
1009 dim_arg = se->loop->loopvar[0];
1010 dim_arg = fold_build2_loc (input_location, PLUS_EXPR,
1011 gfc_array_index_type, dim_arg,
1012 build_int_cst (TREE_TYPE (dim_arg), 1));
1013 gfc_advance_se_ss_chain (se);
1017 /* Use the passed DIM= argument. */
1018 gcc_assert (expr->value.function.actual->next->expr);
1019 gfc_init_se (&argse, NULL);
1020 gfc_conv_expr_type (&argse, expr->value.function.actual->next->expr,
1021 gfc_array_index_type);
1022 gfc_add_block_to_block (&se->pre, &argse.pre);
1023 dim_arg = argse.expr;
1025 if (INTEGER_CST_P (dim_arg))
1029 hi = TREE_INT_CST_HIGH (dim_arg);
1030 co_dim = TREE_INT_CST_LOW (dim_arg);
1031 if (hi || co_dim < 1
1032 || co_dim > GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc)))
1033 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1034 "dimension index", expr->value.function.isym->name,
1037 else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1039 dim_arg = gfc_evaluate_now (dim_arg, &se->pre);
1040 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1042 build_int_cst (TREE_TYPE (dim_arg), 1));
1043 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
1044 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1046 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
1047 boolean_type_node, cond, tmp);
1048 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
1053 /* Used algorithm; cf. Fortran 2008, C.10. Note, due to the scalarizer,
1054 one always has a dim_arg argument.
1056 m = this_images() - 1
1058 min_var = min (rank + corank - 2, rank + dim_arg - 1)
1061 extent = gfc_extent(i)
1069 sub(dim_arg) = (dim_arg < corank) ? ml - m*extent + lcobound(dim_arg)
1070 : m + lcobound(corank)
1073 m = gfc_create_var (type, NULL);
1074 ml = gfc_create_var (type, NULL);
1075 loop_var = gfc_create_var (integer_type_node, NULL);
1076 min_var = gfc_create_var (integer_type_node, NULL);
1078 /* m = this_image () - 1. */
1079 tmp = fold_convert (type, gfort_gvar_caf_this_image);
1080 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, tmp,
1081 build_int_cst (type, 1));
1082 gfc_add_modify (&se->pre, m, tmp);
1084 /* min_var = min (rank + corank-2, rank + dim_arg - 1). */
1085 tmp = fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
1086 fold_convert (integer_type_node, dim_arg),
1087 build_int_cst (integer_type_node, rank - 1));
1088 tmp = fold_build2_loc (input_location, MIN_EXPR, integer_type_node,
1089 build_int_cst (integer_type_node, rank + corank - 2),
1091 gfc_add_modify (&se->pre, min_var, tmp);
1094 tmp = build_int_cst (integer_type_node, rank);
1095 gfc_add_modify (&se->pre, loop_var, tmp);
1097 exit_label = gfc_build_label_decl (NULL_TREE);
1098 TREE_USED (exit_label) = 1;
1101 gfc_init_block (&loop);
1104 gfc_add_modify (&loop, ml, m);
1107 lbound = gfc_conv_descriptor_lbound_get (desc, loop_var);
1108 ubound = gfc_conv_descriptor_ubound_get (desc, loop_var);
1109 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1110 extent = fold_convert (type, extent);
1113 gfc_add_modify (&loop, m,
1114 fold_build2_loc (input_location, TRUNC_DIV_EXPR, type,
1117 /* Exit condition: if (i >= min_var) goto exit_label. */
1118 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, loop_var,
1120 tmp = build1_v (GOTO_EXPR, exit_label);
1121 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
1122 build_empty_stmt (input_location));
1123 gfc_add_expr_to_block (&loop, tmp);
1125 /* Increment loop variable: i++. */
1126 gfc_add_modify (&loop, loop_var,
1127 fold_build2_loc (input_location, PLUS_EXPR, integer_type_node,
1129 build_int_cst (integer_type_node, 1)));
1131 /* Making the loop... actually loop! */
1132 tmp = gfc_finish_block (&loop);
1133 tmp = build1_v (LOOP_EXPR, tmp);
1134 gfc_add_expr_to_block (&se->pre, tmp);
1136 /* The exit label. */
1137 tmp = build1_v (LABEL_EXPR, exit_label);
1138 gfc_add_expr_to_block (&se->pre, tmp);
1140 /* sub(co_dim) = (co_dim < corank) ? ml - m*extent + lcobound(dim_arg)
1141 : m + lcobound(corank) */
1143 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, dim_arg,
1144 build_int_cst (TREE_TYPE (dim_arg), corank));
1146 lbound = gfc_conv_descriptor_lbound_get (desc,
1147 fold_build2_loc (input_location, PLUS_EXPR,
1148 gfc_array_index_type, dim_arg,
1149 build_int_cst (TREE_TYPE (dim_arg), rank-1)));
1150 lbound = fold_convert (type, lbound);
1152 tmp = fold_build2_loc (input_location, MINUS_EXPR, type, ml,
1153 fold_build2_loc (input_location, MULT_EXPR, type,
1155 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, tmp, lbound);
1157 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond, tmp,
1158 fold_build2_loc (input_location, PLUS_EXPR, type,
1164 trans_image_index (gfc_se * se, gfc_expr *expr)
1166 tree num_images, cond, coindex, type, lbound, ubound, desc, subdesc,
1168 gfc_se argse, subse;
1170 int rank, corank, codim;
1172 type = gfc_get_int_type (gfc_default_integer_kind);
1173 corank = gfc_get_corank (expr->value.function.actual->expr);
1174 rank = expr->value.function.actual->expr->rank;
1176 /* Obtain the descriptor of the COARRAY. */
1177 gfc_init_se (&argse, NULL);
1178 ss = walk_coarray (expr->value.function.actual->expr);
1179 gcc_assert (ss != gfc_ss_terminator);
1180 argse.want_coarray = 1;
1181 gfc_conv_expr_descriptor (&argse, expr->value.function.actual->expr, ss);
1182 gfc_add_block_to_block (&se->pre, &argse.pre);
1183 gfc_add_block_to_block (&se->post, &argse.post);
1186 /* Obtain a handle to the SUB argument. */
1187 gfc_init_se (&subse, NULL);
1188 subss = gfc_walk_expr (expr->value.function.actual->next->expr);
1189 gcc_assert (subss != gfc_ss_terminator);
1190 gfc_conv_expr_descriptor (&subse, expr->value.function.actual->next->expr,
1192 gfc_add_block_to_block (&se->pre, &subse.pre);
1193 gfc_add_block_to_block (&se->post, &subse.post);
1194 subdesc = build_fold_indirect_ref_loc (input_location,
1195 gfc_conv_descriptor_data_get (subse.expr));
1197 /* Fortran 2008 does not require that the values remain in the cobounds,
1198 thus we need explicitly check this - and return 0 if they are exceeded. */
1200 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
1201 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1], NULL);
1202 invalid_bound = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1203 fold_convert (gfc_array_index_type, tmp),
1206 for (codim = corank + rank - 2; codim >= rank; codim--)
1208 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
1209 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
1210 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
1211 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1212 fold_convert (gfc_array_index_type, tmp),
1214 invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1215 boolean_type_node, invalid_bound, cond);
1216 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1217 fold_convert (gfc_array_index_type, tmp),
1219 invalid_bound = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1220 boolean_type_node, invalid_bound, cond);
1223 invalid_bound = gfc_unlikely (invalid_bound);
1226 /* See Fortran 2008, C.10 for the following algorithm. */
1228 /* coindex = sub(corank) - lcobound(n). */
1229 coindex = fold_convert (gfc_array_index_type,
1230 gfc_build_array_ref (subdesc, gfc_rank_cst[corank-1],
1232 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[rank+corank-1]);
1233 coindex = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
1234 fold_convert (gfc_array_index_type, coindex),
1237 for (codim = corank + rank - 2; codim >= rank; codim--)
1239 tree extent, ubound;
1241 /* coindex = coindex*extent(codim) + sub(codim) - lcobound(codim). */
1242 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
1243 ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[codim]);
1244 extent = gfc_conv_array_extent_dim (lbound, ubound, NULL);
1246 /* coindex *= extent. */
1247 coindex = fold_build2_loc (input_location, MULT_EXPR,
1248 gfc_array_index_type, coindex, extent);
1250 /* coindex += sub(codim). */
1251 tmp = gfc_build_array_ref (subdesc, gfc_rank_cst[codim-rank], NULL);
1252 coindex = fold_build2_loc (input_location, PLUS_EXPR,
1253 gfc_array_index_type, coindex,
1254 fold_convert (gfc_array_index_type, tmp));
1256 /* coindex -= lbound(codim). */
1257 lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[codim]);
1258 coindex = fold_build2_loc (input_location, MINUS_EXPR,
1259 gfc_array_index_type, coindex, lbound);
1262 coindex = fold_build2_loc (input_location, PLUS_EXPR, type,
1263 fold_convert(type, coindex),
1264 build_int_cst (type, 1));
1266 /* Return 0 if "coindex" exceeds num_images(). */
1268 if (gfc_option.coarray == GFC_FCOARRAY_SINGLE)
1269 num_images = build_int_cst (type, 1);
1272 gfc_init_coarray_decl (false);
1273 num_images = gfort_gvar_caf_num_images;
1276 tmp = gfc_create_var (type, NULL);
1277 gfc_add_modify (&se->pre, tmp, coindex);
1279 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp,
1281 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, boolean_type_node,
1283 fold_convert (boolean_type_node, invalid_bound));
1284 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
1285 build_int_cst (type, 0), tmp);
1290 trans_num_images (gfc_se * se)
1292 gfc_init_coarray_decl (false);
1293 se->expr = gfort_gvar_caf_num_images;
1297 /* Evaluate a single upper or lower bound. */
1298 /* TODO: bound intrinsic generates way too much unnecessary code. */
1301 gfc_conv_intrinsic_bound (gfc_se * se, gfc_expr * expr, int upper)
1303 gfc_actual_arglist *arg;
1304 gfc_actual_arglist *arg2;
1309 tree cond, cond1, cond3, cond4, size;
1314 gfc_array_spec * as;
1316 arg = expr->value.function.actual;
1321 /* Create an implicit second parameter from the loop variable. */
1322 gcc_assert (!arg2->expr);
1323 gcc_assert (se->loop->dimen == 1);
1324 gcc_assert (se->ss->info->expr == expr);
1325 gfc_advance_se_ss_chain (se);
1326 bound = se->loop->loopvar[0];
1327 bound = fold_build2_loc (input_location, MINUS_EXPR,
1328 gfc_array_index_type, bound,
1333 /* use the passed argument. */
1334 gcc_assert (arg2->expr);
1335 gfc_init_se (&argse, NULL);
1336 gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
1337 gfc_add_block_to_block (&se->pre, &argse.pre);
1339 /* Convert from one based to zero based. */
1340 bound = fold_build2_loc (input_location, MINUS_EXPR,
1341 gfc_array_index_type, bound,
1342 gfc_index_one_node);
1345 /* TODO: don't re-evaluate the descriptor on each iteration. */
1346 /* Get a descriptor for the first parameter. */
1347 ss = gfc_walk_expr (arg->expr);
1348 gcc_assert (ss != gfc_ss_terminator);
1349 gfc_init_se (&argse, NULL);
1350 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
1351 gfc_add_block_to_block (&se->pre, &argse.pre);
1352 gfc_add_block_to_block (&se->post, &argse.post);
1356 if (INTEGER_CST_P (bound))
1360 hi = TREE_INT_CST_HIGH (bound);
1361 low = TREE_INT_CST_LOW (bound);
1362 if (hi || low < 0 || low >= GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc)))
1363 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1364 "dimension index", upper ? "UBOUND" : "LBOUND",
1369 if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1371 bound = gfc_evaluate_now (bound, &se->pre);
1372 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1373 bound, build_int_cst (TREE_TYPE (bound), 0));
1374 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_RANK (TREE_TYPE (desc))];
1375 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
1377 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
1378 boolean_type_node, cond, tmp);
1379 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
1384 ubound = gfc_conv_descriptor_ubound_get (desc, bound);
1385 lbound = gfc_conv_descriptor_lbound_get (desc, bound);
1387 as = gfc_get_full_arrayspec_from_expr (arg->expr);
1389 /* 13.14.53: Result value for LBOUND
1391 Case (i): For an array section or for an array expression other than a
1392 whole array or array structure component, LBOUND(ARRAY, DIM)
1393 has the value 1. For a whole array or array structure
1394 component, LBOUND(ARRAY, DIM) has the value:
1395 (a) equal to the lower bound for subscript DIM of ARRAY if
1396 dimension DIM of ARRAY does not have extent zero
1397 or if ARRAY is an assumed-size array of rank DIM,
1400 13.14.113: Result value for UBOUND
1402 Case (i): For an array section or for an array expression other than a
1403 whole array or array structure component, UBOUND(ARRAY, DIM)
1404 has the value equal to the number of elements in the given
1405 dimension; otherwise, it has a value equal to the upper bound
1406 for subscript DIM of ARRAY if dimension DIM of ARRAY does
1407 not have size zero and has value zero if dimension DIM has
1412 tree stride = gfc_conv_descriptor_stride_get (desc, bound);
1414 cond1 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
1416 cond3 = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
1417 stride, gfc_index_zero_node);
1418 cond3 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
1419 boolean_type_node, cond3, cond1);
1420 cond4 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1421 stride, gfc_index_zero_node);
1426 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1427 boolean_type_node, cond3, cond4);
1428 cond5 = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1429 gfc_index_one_node, lbound);
1430 cond5 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
1431 boolean_type_node, cond4, cond5);
1433 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1434 boolean_type_node, cond, cond5);
1436 se->expr = fold_build3_loc (input_location, COND_EXPR,
1437 gfc_array_index_type, cond,
1438 ubound, gfc_index_zero_node);
1442 if (as->type == AS_ASSUMED_SIZE)
1443 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1444 bound, build_int_cst (TREE_TYPE (bound),
1445 arg->expr->rank - 1));
1447 cond = boolean_false_node;
1449 cond1 = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1450 boolean_type_node, cond3, cond4);
1451 cond = fold_build2_loc (input_location, TRUTH_OR_EXPR,
1452 boolean_type_node, cond, cond1);
1454 se->expr = fold_build3_loc (input_location, COND_EXPR,
1455 gfc_array_index_type, cond,
1456 lbound, gfc_index_one_node);
1463 size = fold_build2_loc (input_location, MINUS_EXPR,
1464 gfc_array_index_type, ubound, lbound);
1465 se->expr = fold_build2_loc (input_location, PLUS_EXPR,
1466 gfc_array_index_type, size,
1467 gfc_index_one_node);
1468 se->expr = fold_build2_loc (input_location, MAX_EXPR,
1469 gfc_array_index_type, se->expr,
1470 gfc_index_zero_node);
1473 se->expr = gfc_index_one_node;
1476 type = gfc_typenode_for_spec (&expr->ts);
1477 se->expr = convert (type, se->expr);
1482 conv_intrinsic_cobound (gfc_se * se, gfc_expr * expr)
1484 gfc_actual_arglist *arg;
1485 gfc_actual_arglist *arg2;
1488 tree bound, resbound, resbound2, desc, cond, tmp;
1492 gcc_assert (expr->value.function.isym->id == GFC_ISYM_LCOBOUND
1493 || expr->value.function.isym->id == GFC_ISYM_UCOBOUND
1494 || expr->value.function.isym->id == GFC_ISYM_THIS_IMAGE);
1496 arg = expr->value.function.actual;
1499 gcc_assert (arg->expr->expr_type == EXPR_VARIABLE);
1500 corank = gfc_get_corank (arg->expr);
1502 ss = walk_coarray (arg->expr);
1503 gcc_assert (ss != gfc_ss_terminator);
1504 gfc_init_se (&argse, NULL);
1505 argse.want_coarray = 1;
1507 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
1508 gfc_add_block_to_block (&se->pre, &argse.pre);
1509 gfc_add_block_to_block (&se->post, &argse.post);
1514 /* Create an implicit second parameter from the loop variable. */
1515 gcc_assert (!arg2->expr);
1516 gcc_assert (corank > 0);
1517 gcc_assert (se->loop->dimen == 1);
1518 gcc_assert (se->ss->info->expr == expr);
1520 bound = se->loop->loopvar[0];
1521 bound = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
1522 bound, gfc_rank_cst[arg->expr->rank]);
1523 gfc_advance_se_ss_chain (se);
1527 /* use the passed argument. */
1528 gcc_assert (arg2->expr);
1529 gfc_init_se (&argse, NULL);
1530 gfc_conv_expr_type (&argse, arg2->expr, gfc_array_index_type);
1531 gfc_add_block_to_block (&se->pre, &argse.pre);
1534 if (INTEGER_CST_P (bound))
1538 hi = TREE_INT_CST_HIGH (bound);
1539 low = TREE_INT_CST_LOW (bound);
1540 if (hi || low < 1 || low > GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc)))
1541 gfc_error ("'dim' argument of %s intrinsic at %L is not a valid "
1542 "dimension index", expr->value.function.isym->name,
1545 else if (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)
1547 bound = gfc_evaluate_now (bound, &se->pre);
1548 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1549 bound, build_int_cst (TREE_TYPE (bound), 1));
1550 tmp = gfc_rank_cst[GFC_TYPE_ARRAY_CORANK (TREE_TYPE (desc))];
1551 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
1553 cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR,
1554 boolean_type_node, cond, tmp);
1555 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
1560 /* Substract 1 to get to zero based and add dimensions. */
1561 switch (arg->expr->rank)
1564 bound = fold_build2_loc (input_location, MINUS_EXPR,
1565 gfc_array_index_type, bound,
1566 gfc_index_one_node);
1570 bound = fold_build2_loc (input_location, PLUS_EXPR,
1571 gfc_array_index_type, bound,
1572 gfc_rank_cst[arg->expr->rank - 1]);
1576 resbound = gfc_conv_descriptor_lbound_get (desc, bound);
1578 /* Handle UCOBOUND with special handling of the last codimension. */
1579 if (expr->value.function.isym->id == GFC_ISYM_UCOBOUND)
1581 /* Last codimension: For -fcoarray=single just return
1582 the lcobound - otherwise add
1583 ceiling (real (num_images ()) / real (size)) - 1
1584 = (num_images () + size - 1) / size - 1
1585 = (num_images - 1) / size(),
1586 where size is the product of the extent of all but the last
1589 if (gfc_option.coarray != GFC_FCOARRAY_SINGLE && corank > 1)
1593 gfc_init_coarray_decl (false);
1594 cosize = gfc_conv_descriptor_cosize (desc, arg->expr->rank, corank);
1596 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1597 gfc_array_index_type,
1598 gfort_gvar_caf_num_images,
1599 build_int_cst (gfc_array_index_type, 1));
1600 tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR,
1601 gfc_array_index_type, tmp,
1602 fold_convert (gfc_array_index_type, cosize));
1603 resbound = fold_build2_loc (input_location, PLUS_EXPR,
1604 gfc_array_index_type, resbound, tmp);
1606 else if (gfc_option.coarray != GFC_FCOARRAY_SINGLE)
1608 /* ubound = lbound + num_images() - 1. */
1609 gfc_init_coarray_decl (false);
1610 tmp = fold_build2_loc (input_location, MINUS_EXPR,
1611 gfc_array_index_type,
1612 gfort_gvar_caf_num_images,
1613 build_int_cst (gfc_array_index_type, 1));
1614 resbound = fold_build2_loc (input_location, PLUS_EXPR,
1615 gfc_array_index_type, resbound, tmp);
1620 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1622 build_int_cst (TREE_TYPE (bound),
1623 arg->expr->rank + corank - 1));
1625 resbound2 = gfc_conv_descriptor_ubound_get (desc, bound);
1626 se->expr = fold_build3_loc (input_location, COND_EXPR,
1627 gfc_array_index_type, cond,
1628 resbound, resbound2);
1631 se->expr = resbound;
1634 se->expr = resbound;
1636 type = gfc_typenode_for_spec (&expr->ts);
1637 se->expr = convert (type, se->expr);
1642 gfc_conv_intrinsic_abs (gfc_se * se, gfc_expr * expr)
1646 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
1648 switch (expr->value.function.actual->expr->ts.type)
1652 se->expr = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (arg),
1657 cabs = gfc_builtin_decl_for_float_kind (BUILT_IN_CABS, expr->ts.kind);
1658 se->expr = build_call_expr_loc (input_location, cabs, 1, arg);
1667 /* Create a complex value from one or two real components. */
1670 gfc_conv_intrinsic_cmplx (gfc_se * se, gfc_expr * expr, int both)
1676 unsigned int num_args;
1678 num_args = gfc_intrinsic_argument_list_length (expr);
1679 args = XALLOCAVEC (tree, num_args);
1681 type = gfc_typenode_for_spec (&expr->ts);
1682 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
1683 real = convert (TREE_TYPE (type), args[0]);
1685 imag = convert (TREE_TYPE (type), args[1]);
1686 else if (TREE_CODE (TREE_TYPE (args[0])) == COMPLEX_TYPE)
1688 imag = fold_build1_loc (input_location, IMAGPART_EXPR,
1689 TREE_TYPE (TREE_TYPE (args[0])), args[0]);
1690 imag = convert (TREE_TYPE (type), imag);
1693 imag = build_real_from_int_cst (TREE_TYPE (type), integer_zero_node);
1695 se->expr = fold_build2_loc (input_location, COMPLEX_EXPR, type, real, imag);
1698 /* Remainder function MOD(A, P) = A - INT(A / P) * P
1699 MODULO(A, P) = A - FLOOR (A / P) * P */
1700 /* TODO: MOD(x, 0) */
1703 gfc_conv_intrinsic_mod (gfc_se * se, gfc_expr * expr, int modulo)
1715 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1717 switch (expr->ts.type)
1720 /* Integer case is easy, we've got a builtin op. */
1721 type = TREE_TYPE (args[0]);
1724 se->expr = fold_build2_loc (input_location, FLOOR_MOD_EXPR, type,
1727 se->expr = fold_build2_loc (input_location, TRUNC_MOD_EXPR, type,
1733 /* Check if we have a builtin fmod. */
1734 fmod = gfc_builtin_decl_for_float_kind (BUILT_IN_FMOD, expr->ts.kind);
1736 /* Use it if it exists. */
1737 if (fmod != NULL_TREE)
1739 tmp = build_addr (fmod, current_function_decl);
1740 se->expr = build_call_array_loc (input_location,
1741 TREE_TYPE (TREE_TYPE (fmod)),
1747 type = TREE_TYPE (args[0]);
1749 args[0] = gfc_evaluate_now (args[0], &se->pre);
1750 args[1] = gfc_evaluate_now (args[1], &se->pre);
1753 modulo = arg - floor (arg/arg2) * arg2, so
1754 = test ? fmod (arg, arg2) : fmod (arg, arg2) + arg2,
1756 test = (fmod (arg, arg2) != 0) && ((arg < 0) xor (arg2 < 0))
1757 thereby avoiding another division and retaining the accuracy
1758 of the builtin function. */
1759 if (fmod != NULL_TREE && modulo)
1761 tree zero = gfc_build_const (type, integer_zero_node);
1762 tmp = gfc_evaluate_now (se->expr, &se->pre);
1763 test = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1765 test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1767 test2 = fold_build2_loc (input_location, TRUTH_XOR_EXPR,
1768 boolean_type_node, test, test2);
1769 test = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
1771 test = fold_build2_loc (input_location, TRUTH_AND_EXPR,
1772 boolean_type_node, test, test2);
1773 test = gfc_evaluate_now (test, &se->pre);
1774 se->expr = fold_build3_loc (input_location, COND_EXPR, type, test,
1775 fold_build2_loc (input_location, PLUS_EXPR,
1776 type, tmp, args[1]), tmp);
1780 /* If we do not have a built_in fmod, the calculation is going to
1781 have to be done longhand. */
1782 tmp = fold_build2_loc (input_location, RDIV_EXPR, type, args[0], args[1]);
1784 /* Test if the value is too large to handle sensibly. */
1785 gfc_set_model_kind (expr->ts.kind);
1787 n = gfc_validate_kind (BT_INTEGER, expr->ts.kind, true);
1788 ikind = expr->ts.kind;
1791 n = gfc_validate_kind (BT_INTEGER, gfc_max_integer_kind, false);
1792 ikind = gfc_max_integer_kind;
1794 mpfr_set_z (huge, gfc_integer_kinds[n].huge, GFC_RND_MODE);
1795 test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1796 test2 = fold_build2_loc (input_location, LT_EXPR, boolean_type_node,
1799 mpfr_neg (huge, huge, GFC_RND_MODE);
1800 test = gfc_conv_mpfr_to_tree (huge, expr->ts.kind, 0);
1801 test = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, tmp,
1803 test2 = fold_build2_loc (input_location, TRUTH_AND_EXPR,
1804 boolean_type_node, test, test2);
1806 itype = gfc_get_int_type (ikind);
1808 tmp = build_fix_expr (&se->pre, tmp, itype, RND_FLOOR);
1810 tmp = build_fix_expr (&se->pre, tmp, itype, RND_TRUNC);
1811 tmp = convert (type, tmp);
1812 tmp = fold_build3_loc (input_location, COND_EXPR, type, test2, tmp,
1814 tmp = fold_build2_loc (input_location, MULT_EXPR, type, tmp, args[1]);
1815 se->expr = fold_build2_loc (input_location, MINUS_EXPR, type, args[0],
1825 /* DSHIFTL(I,J,S) = (I << S) | (J >> (BITSIZE(J) - S))
1826 DSHIFTR(I,J,S) = (I << (BITSIZE(I) - S)) | (J >> S)
1827 where the right shifts are logical (i.e. 0's are shifted in).
1828 Because SHIFT_EXPR's want shifts strictly smaller than the integral
1829 type width, we have to special-case both S == 0 and S == BITSIZE(J):
1831 DSHIFTL(I,J,BITSIZE) = J
1833 DSHIFTR(I,J,BITSIZE) = I. */
1836 gfc_conv_intrinsic_dshift (gfc_se * se, gfc_expr * expr, bool dshiftl)
1838 tree type, utype, stype, arg1, arg2, shift, res, left, right;
1839 tree args[3], cond, tmp;
1842 gfc_conv_intrinsic_function_args (se, expr, args, 3);
1844 gcc_assert (TREE_TYPE (args[0]) == TREE_TYPE (args[1]));
1845 type = TREE_TYPE (args[0]);
1846 bitsize = TYPE_PRECISION (type);
1847 utype = unsigned_type_for (type);
1848 stype = TREE_TYPE (args[2]);
1850 arg1 = gfc_evaluate_now (args[0], &se->pre);
1851 arg2 = gfc_evaluate_now (args[1], &se->pre);
1852 shift = gfc_evaluate_now (args[2], &se->pre);
1854 /* The generic case. */
1855 tmp = fold_build2_loc (input_location, MINUS_EXPR, stype,
1856 build_int_cst (stype, bitsize), shift);
1857 left = fold_build2_loc (input_location, LSHIFT_EXPR, type,
1858 arg1, dshiftl ? shift : tmp);
1860 right = fold_build2_loc (input_location, RSHIFT_EXPR, utype,
1861 fold_convert (utype, arg2), dshiftl ? tmp : shift);
1862 right = fold_convert (type, right);
1864 res = fold_build2_loc (input_location, BIT_IOR_EXPR, type, left, right);
1866 /* Special cases. */
1867 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift,
1868 build_int_cst (stype, 0));
1869 res = fold_build3_loc (input_location, COND_EXPR, type, cond,
1870 dshiftl ? arg1 : arg2, res);
1872 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, shift,
1873 build_int_cst (stype, bitsize));
1874 res = fold_build3_loc (input_location, COND_EXPR, type, cond,
1875 dshiftl ? arg2 : arg1, res);
1881 /* Positive difference DIM (x, y) = ((x - y) < 0) ? 0 : x - y. */
1884 gfc_conv_intrinsic_dim (gfc_se * se, gfc_expr * expr)
1892 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1893 type = TREE_TYPE (args[0]);
1895 val = fold_build2_loc (input_location, MINUS_EXPR, type, args[0], args[1]);
1896 val = gfc_evaluate_now (val, &se->pre);
1898 zero = gfc_build_const (type, integer_zero_node);
1899 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, val, zero);
1900 se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, zero, val);
1904 /* SIGN(A, B) is absolute value of A times sign of B.
1905 The real value versions use library functions to ensure the correct
1906 handling of negative zero. Integer case implemented as:
1907 SIGN(A, B) = { tmp = (A ^ B) >> C; (A + tmp) ^ tmp }
1911 gfc_conv_intrinsic_sign (gfc_se * se, gfc_expr * expr)
1917 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1918 if (expr->ts.type == BT_REAL)
1922 tmp = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
1923 abs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
1925 /* We explicitly have to ignore the minus sign. We do so by using
1926 result = (arg1 == 0) ? abs(arg0) : copysign(arg0, arg1). */
1927 if (!gfc_option.flag_sign_zero
1928 && MODE_HAS_SIGNED_ZEROS (TYPE_MODE (TREE_TYPE (args[1]))))
1931 zero = build_real_from_int_cst (TREE_TYPE (args[1]), integer_zero_node);
1932 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
1934 se->expr = fold_build3_loc (input_location, COND_EXPR,
1935 TREE_TYPE (args[0]), cond,
1936 build_call_expr_loc (input_location, abs, 1,
1938 build_call_expr_loc (input_location, tmp, 2,
1942 se->expr = build_call_expr_loc (input_location, tmp, 2,
1947 /* Having excluded floating point types, we know we are now dealing
1948 with signed integer types. */
1949 type = TREE_TYPE (args[0]);
1951 /* Args[0] is used multiple times below. */
1952 args[0] = gfc_evaluate_now (args[0], &se->pre);
1954 /* Construct (A ^ B) >> 31, which generates a bit mask of all zeros if
1955 the signs of A and B are the same, and of all ones if they differ. */
1956 tmp = fold_build2_loc (input_location, BIT_XOR_EXPR, type, args[0], args[1]);
1957 tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, tmp,
1958 build_int_cst (type, TYPE_PRECISION (type) - 1));
1959 tmp = gfc_evaluate_now (tmp, &se->pre);
1961 /* Construct (A + tmp) ^ tmp, which is A if tmp is zero, and -A if tmp]
1962 is all ones (i.e. -1). */
1963 se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, type,
1964 fold_build2_loc (input_location, PLUS_EXPR,
1965 type, args[0], tmp), tmp);
1969 /* Test for the presence of an optional argument. */
1972 gfc_conv_intrinsic_present (gfc_se * se, gfc_expr * expr)
1976 arg = expr->value.function.actual->expr;
1977 gcc_assert (arg->expr_type == EXPR_VARIABLE);
1978 se->expr = gfc_conv_expr_present (arg->symtree->n.sym);
1979 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
1983 /* Calculate the double precision product of two single precision values. */
1986 gfc_conv_intrinsic_dprod (gfc_se * se, gfc_expr * expr)
1991 gfc_conv_intrinsic_function_args (se, expr, args, 2);
1993 /* Convert the args to double precision before multiplying. */
1994 type = gfc_typenode_for_spec (&expr->ts);
1995 args[0] = convert (type, args[0]);
1996 args[1] = convert (type, args[1]);
1997 se->expr = fold_build2_loc (input_location, MULT_EXPR, type, args[0],
2002 /* Return a length one character string containing an ascii character. */
2005 gfc_conv_intrinsic_char (gfc_se * se, gfc_expr * expr)
2010 unsigned int num_args;
2012 num_args = gfc_intrinsic_argument_list_length (expr);
2013 gfc_conv_intrinsic_function_args (se, expr, arg, num_args);
2015 type = gfc_get_char_type (expr->ts.kind);
2016 var = gfc_create_var (type, "char");
2018 arg[0] = fold_build1_loc (input_location, NOP_EXPR, type, arg[0]);
2019 gfc_add_modify (&se->pre, var, arg[0]);
2020 se->expr = gfc_build_addr_expr (build_pointer_type (type), var);
2021 se->string_length = build_int_cst (gfc_charlen_type_node, 1);
2026 gfc_conv_intrinsic_ctime (gfc_se * se, gfc_expr * expr)
2034 unsigned int num_args;
2036 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
2037 args = XALLOCAVEC (tree, num_args);
2039 var = gfc_create_var (pchar_type_node, "pstr");
2040 len = gfc_create_var (gfc_charlen_type_node, "len");
2042 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
2043 args[0] = gfc_build_addr_expr (NULL_TREE, var);
2044 args[1] = gfc_build_addr_expr (NULL_TREE, len);
2046 fndecl = build_addr (gfor_fndecl_ctime, current_function_decl);
2047 tmp = build_call_array_loc (input_location,
2048 TREE_TYPE (TREE_TYPE (gfor_fndecl_ctime)),
2049 fndecl, num_args, args);
2050 gfc_add_expr_to_block (&se->pre, tmp);
2052 /* Free the temporary afterwards, if necessary. */
2053 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2054 len, build_int_cst (TREE_TYPE (len), 0));
2055 tmp = gfc_call_free (var);
2056 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2057 gfc_add_expr_to_block (&se->post, tmp);
2060 se->string_length = len;
2065 gfc_conv_intrinsic_fdate (gfc_se * se, gfc_expr * expr)
2073 unsigned int num_args;
2075 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
2076 args = XALLOCAVEC (tree, num_args);
2078 var = gfc_create_var (pchar_type_node, "pstr");
2079 len = gfc_create_var (gfc_charlen_type_node, "len");
2081 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
2082 args[0] = gfc_build_addr_expr (NULL_TREE, var);
2083 args[1] = gfc_build_addr_expr (NULL_TREE, len);
2085 fndecl = build_addr (gfor_fndecl_fdate, current_function_decl);
2086 tmp = build_call_array_loc (input_location,
2087 TREE_TYPE (TREE_TYPE (gfor_fndecl_fdate)),
2088 fndecl, num_args, args);
2089 gfc_add_expr_to_block (&se->pre, tmp);
2091 /* Free the temporary afterwards, if necessary. */
2092 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2093 len, build_int_cst (TREE_TYPE (len), 0));
2094 tmp = gfc_call_free (var);
2095 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2096 gfc_add_expr_to_block (&se->post, tmp);
2099 se->string_length = len;
2103 /* Return a character string containing the tty name. */
2106 gfc_conv_intrinsic_ttynam (gfc_se * se, gfc_expr * expr)
2114 unsigned int num_args;
2116 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
2117 args = XALLOCAVEC (tree, num_args);
2119 var = gfc_create_var (pchar_type_node, "pstr");
2120 len = gfc_create_var (gfc_charlen_type_node, "len");
2122 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
2123 args[0] = gfc_build_addr_expr (NULL_TREE, var);
2124 args[1] = gfc_build_addr_expr (NULL_TREE, len);
2126 fndecl = build_addr (gfor_fndecl_ttynam, current_function_decl);
2127 tmp = build_call_array_loc (input_location,
2128 TREE_TYPE (TREE_TYPE (gfor_fndecl_ttynam)),
2129 fndecl, num_args, args);
2130 gfc_add_expr_to_block (&se->pre, tmp);
2132 /* Free the temporary afterwards, if necessary. */
2133 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2134 len, build_int_cst (TREE_TYPE (len), 0));
2135 tmp = gfc_call_free (var);
2136 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2137 gfc_add_expr_to_block (&se->post, tmp);
2140 se->string_length = len;
2144 /* Get the minimum/maximum value of all the parameters.
2145 minmax (a1, a2, a3, ...)
2148 if (a2 .op. mvar || isnan(mvar))
2150 if (a3 .op. mvar || isnan(mvar))
2157 /* TODO: Mismatching types can occur when specific names are used.
2158 These should be handled during resolution. */
2160 gfc_conv_intrinsic_minmax (gfc_se * se, gfc_expr * expr, enum tree_code op)
2168 gfc_actual_arglist *argexpr;
2169 unsigned int i, nargs;
2171 nargs = gfc_intrinsic_argument_list_length (expr);
2172 args = XALLOCAVEC (tree, nargs);
2174 gfc_conv_intrinsic_function_args (se, expr, args, nargs);
2175 type = gfc_typenode_for_spec (&expr->ts);
2177 argexpr = expr->value.function.actual;
2178 if (TREE_TYPE (args[0]) != type)
2179 args[0] = convert (type, args[0]);
2180 /* Only evaluate the argument once. */
2181 if (TREE_CODE (args[0]) != VAR_DECL && !TREE_CONSTANT (args[0]))
2182 args[0] = gfc_evaluate_now (args[0], &se->pre);
2184 mvar = gfc_create_var (type, "M");
2185 gfc_add_modify (&se->pre, mvar, args[0]);
2186 for (i = 1, argexpr = argexpr->next; i < nargs; i++)
2192 /* Handle absent optional arguments by ignoring the comparison. */
2193 if (argexpr->expr->expr_type == EXPR_VARIABLE
2194 && argexpr->expr->symtree->n.sym->attr.optional
2195 && TREE_CODE (val) == INDIRECT_REF)
2196 cond = fold_build2_loc (input_location,
2197 NE_EXPR, boolean_type_node,
2198 TREE_OPERAND (val, 0),
2199 build_int_cst (TREE_TYPE (TREE_OPERAND (val, 0)), 0));
2204 /* Only evaluate the argument once. */
2205 if (TREE_CODE (val) != VAR_DECL && !TREE_CONSTANT (val))
2206 val = gfc_evaluate_now (val, &se->pre);
2209 thencase = build2_v (MODIFY_EXPR, mvar, convert (type, val));
2211 tmp = fold_build2_loc (input_location, op, boolean_type_node,
2212 convert (type, val), mvar);
2214 /* FIXME: When the IEEE_ARITHMETIC module is implemented, the call to
2215 __builtin_isnan might be made dependent on that module being loaded,
2216 to help performance of programs that don't rely on IEEE semantics. */
2217 if (FLOAT_TYPE_P (TREE_TYPE (mvar)))
2219 isnan = build_call_expr_loc (input_location,
2220 builtin_decl_explicit (BUILT_IN_ISNAN),
2222 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR,
2223 boolean_type_node, tmp,
2224 fold_convert (boolean_type_node, isnan));
2226 tmp = build3_v (COND_EXPR, tmp, thencase,
2227 build_empty_stmt (input_location));
2229 if (cond != NULL_TREE)
2230 tmp = build3_v (COND_EXPR, cond, tmp,
2231 build_empty_stmt (input_location));
2233 gfc_add_expr_to_block (&se->pre, tmp);
2234 argexpr = argexpr->next;
2240 /* Generate library calls for MIN and MAX intrinsics for character
2243 gfc_conv_intrinsic_minmax_char (gfc_se * se, gfc_expr * expr, int op)
2246 tree var, len, fndecl, tmp, cond, function;
2249 nargs = gfc_intrinsic_argument_list_length (expr);
2250 args = XALLOCAVEC (tree, nargs + 4);
2251 gfc_conv_intrinsic_function_args (se, expr, &args[4], nargs);
2253 /* Create the result variables. */
2254 len = gfc_create_var (gfc_charlen_type_node, "len");
2255 args[0] = gfc_build_addr_expr (NULL_TREE, len);
2256 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
2257 args[1] = gfc_build_addr_expr (ppvoid_type_node, var);
2258 args[2] = build_int_cst (integer_type_node, op);
2259 args[3] = build_int_cst (integer_type_node, nargs / 2);
2261 if (expr->ts.kind == 1)
2262 function = gfor_fndecl_string_minmax;
2263 else if (expr->ts.kind == 4)
2264 function = gfor_fndecl_string_minmax_char4;
2268 /* Make the function call. */
2269 fndecl = build_addr (function, current_function_decl);
2270 tmp = build_call_array_loc (input_location,
2271 TREE_TYPE (TREE_TYPE (function)), fndecl,
2273 gfc_add_expr_to_block (&se->pre, tmp);
2275 /* Free the temporary afterwards, if necessary. */
2276 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2277 len, build_int_cst (TREE_TYPE (len), 0));
2278 tmp = gfc_call_free (var);
2279 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2280 gfc_add_expr_to_block (&se->post, tmp);
2283 se->string_length = len;
2287 /* Create a symbol node for this intrinsic. The symbol from the frontend
2288 has the generic name. */
2291 gfc_get_symbol_for_expr (gfc_expr * expr)
2295 /* TODO: Add symbols for intrinsic function to the global namespace. */
2296 gcc_assert (strlen (expr->value.function.name) <= GFC_MAX_SYMBOL_LEN - 5);
2297 sym = gfc_new_symbol (expr->value.function.name, NULL);
2300 sym->attr.external = 1;
2301 sym->attr.function = 1;
2302 sym->attr.always_explicit = 1;
2303 sym->attr.proc = PROC_INTRINSIC;
2304 sym->attr.flavor = FL_PROCEDURE;
2308 sym->attr.dimension = 1;
2309 sym->as = gfc_get_array_spec ();
2310 sym->as->type = AS_ASSUMED_SHAPE;
2311 sym->as->rank = expr->rank;
2314 gfc_copy_formal_args_intr (sym, expr->value.function.isym);
2319 /* Generate a call to an external intrinsic function. */
2321 gfc_conv_intrinsic_funcall (gfc_se * se, gfc_expr * expr)
2324 VEC(tree,gc) *append_args;
2326 gcc_assert (!se->ss || se->ss->info->expr == expr);
2329 gcc_assert (expr->rank > 0);
2331 gcc_assert (expr->rank == 0);
2333 sym = gfc_get_symbol_for_expr (expr);
2335 /* Calls to libgfortran_matmul need to be appended special arguments,
2336 to be able to call the BLAS ?gemm functions if required and possible. */
2338 if (expr->value.function.isym->id == GFC_ISYM_MATMUL
2339 && sym->ts.type != BT_LOGICAL)
2341 tree cint = gfc_get_int_type (gfc_c_int_kind);
2343 if (gfc_option.flag_external_blas
2344 && (sym->ts.type == BT_REAL || sym->ts.type == BT_COMPLEX)
2345 && (sym->ts.kind == gfc_default_real_kind
2346 || sym->ts.kind == gfc_default_double_kind))
2350 if (sym->ts.type == BT_REAL)
2352 if (sym->ts.kind == gfc_default_real_kind)
2353 gemm_fndecl = gfor_fndecl_sgemm;
2355 gemm_fndecl = gfor_fndecl_dgemm;
2359 if (sym->ts.kind == gfc_default_real_kind)
2360 gemm_fndecl = gfor_fndecl_cgemm;
2362 gemm_fndecl = gfor_fndecl_zgemm;
2365 append_args = VEC_alloc (tree, gc, 3);
2366 VEC_quick_push (tree, append_args, build_int_cst (cint, 1));
2367 VEC_quick_push (tree, append_args,
2368 build_int_cst (cint, gfc_option.blas_matmul_limit));
2369 VEC_quick_push (tree, append_args,
2370 gfc_build_addr_expr (NULL_TREE, gemm_fndecl));
2374 append_args = VEC_alloc (tree, gc, 3);
2375 VEC_quick_push (tree, append_args, build_int_cst (cint, 0));
2376 VEC_quick_push (tree, append_args, build_int_cst (cint, 0));
2377 VEC_quick_push (tree, append_args, null_pointer_node);
2381 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
2383 gfc_free_symbol (sym);
2386 /* ANY and ALL intrinsics. ANY->op == NE_EXPR, ALL->op == EQ_EXPR.
2406 gfc_conv_intrinsic_anyall (gfc_se * se, gfc_expr * expr, enum tree_code op)
2415 gfc_actual_arglist *actual;
2422 gfc_conv_intrinsic_funcall (se, expr);
2426 actual = expr->value.function.actual;
2427 type = gfc_typenode_for_spec (&expr->ts);
2428 /* Initialize the result. */
2429 resvar = gfc_create_var (type, "test");
2431 tmp = convert (type, boolean_true_node);
2433 tmp = convert (type, boolean_false_node);
2434 gfc_add_modify (&se->pre, resvar, tmp);
2436 /* Walk the arguments. */
2437 arrayss = gfc_walk_expr (actual->expr);
2438 gcc_assert (arrayss != gfc_ss_terminator);
2440 /* Initialize the scalarizer. */
2441 gfc_init_loopinfo (&loop);
2442 exit_label = gfc_build_label_decl (NULL_TREE);
2443 TREE_USED (exit_label) = 1;
2444 gfc_add_ss_to_loop (&loop, arrayss);
2446 /* Initialize the loop. */
2447 gfc_conv_ss_startstride (&loop);
2448 gfc_conv_loop_setup (&loop, &expr->where);
2450 gfc_mark_ss_chain_used (arrayss, 1);
2451 /* Generate the loop body. */
2452 gfc_start_scalarized_body (&loop, &body);
2454 /* If the condition matches then set the return value. */
2455 gfc_start_block (&block);
2457 tmp = convert (type, boolean_false_node);
2459 tmp = convert (type, boolean_true_node);
2460 gfc_add_modify (&block, resvar, tmp);
2462 /* And break out of the loop. */
2463 tmp = build1_v (GOTO_EXPR, exit_label);
2464 gfc_add_expr_to_block (&block, tmp);
2466 found = gfc_finish_block (&block);
2468 /* Check this element. */
2469 gfc_init_se (&arrayse, NULL);
2470 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2471 arrayse.ss = arrayss;
2472 gfc_conv_expr_val (&arrayse, actual->expr);
2474 gfc_add_block_to_block (&body, &arrayse.pre);
2475 tmp = fold_build2_loc (input_location, op, boolean_type_node, arrayse.expr,
2476 build_int_cst (TREE_TYPE (arrayse.expr), 0));
2477 tmp = build3_v (COND_EXPR, tmp, found, build_empty_stmt (input_location));
2478 gfc_add_expr_to_block (&body, tmp);
2479 gfc_add_block_to_block (&body, &arrayse.post);
2481 gfc_trans_scalarizing_loops (&loop, &body);
2483 /* Add the exit label. */
2484 tmp = build1_v (LABEL_EXPR, exit_label);
2485 gfc_add_expr_to_block (&loop.pre, tmp);
2487 gfc_add_block_to_block (&se->pre, &loop.pre);
2488 gfc_add_block_to_block (&se->pre, &loop.post);
2489 gfc_cleanup_loop (&loop);
2494 /* COUNT(A) = Number of true elements in A. */
2496 gfc_conv_intrinsic_count (gfc_se * se, gfc_expr * expr)
2503 gfc_actual_arglist *actual;
2509 gfc_conv_intrinsic_funcall (se, expr);
2513 actual = expr->value.function.actual;
2515 type = gfc_typenode_for_spec (&expr->ts);
2516 /* Initialize the result. */
2517 resvar = gfc_create_var (type, "count");
2518 gfc_add_modify (&se->pre, resvar, build_int_cst (type, 0));
2520 /* Walk the arguments. */
2521 arrayss = gfc_walk_expr (actual->expr);
2522 gcc_assert (arrayss != gfc_ss_terminator);
2524 /* Initialize the scalarizer. */
2525 gfc_init_loopinfo (&loop);
2526 gfc_add_ss_to_loop (&loop, arrayss);
2528 /* Initialize the loop. */
2529 gfc_conv_ss_startstride (&loop);
2530 gfc_conv_loop_setup (&loop, &expr->where);
2532 gfc_mark_ss_chain_used (arrayss, 1);
2533 /* Generate the loop body. */
2534 gfc_start_scalarized_body (&loop, &body);
2536 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (resvar),
2537 resvar, build_int_cst (TREE_TYPE (resvar), 1));
2538 tmp = build2_v (MODIFY_EXPR, resvar, tmp);
2540 gfc_init_se (&arrayse, NULL);
2541 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2542 arrayse.ss = arrayss;
2543 gfc_conv_expr_val (&arrayse, actual->expr);
2544 tmp = build3_v (COND_EXPR, arrayse.expr, tmp,
2545 build_empty_stmt (input_location));
2547 gfc_add_block_to_block (&body, &arrayse.pre);
2548 gfc_add_expr_to_block (&body, tmp);
2549 gfc_add_block_to_block (&body, &arrayse.post);
2551 gfc_trans_scalarizing_loops (&loop, &body);
2553 gfc_add_block_to_block (&se->pre, &loop.pre);
2554 gfc_add_block_to_block (&se->pre, &loop.post);
2555 gfc_cleanup_loop (&loop);
2560 /* Inline implementation of the sum and product intrinsics. */
2562 gfc_conv_intrinsic_arith (gfc_se * se, gfc_expr * expr, enum tree_code op,
2566 tree scale = NULL_TREE;
2572 gfc_actual_arglist *actual;
2577 gfc_expr *arrayexpr;
2582 gfc_conv_intrinsic_funcall (se, expr);
2586 type = gfc_typenode_for_spec (&expr->ts);
2587 /* Initialize the result. */
2588 resvar = gfc_create_var (type, "val");
2593 scale = gfc_create_var (type, "scale");
2594 gfc_add_modify (&se->pre, scale,
2595 gfc_build_const (type, integer_one_node));
2596 tmp = gfc_build_const (type, integer_zero_node);
2598 else if (op == PLUS_EXPR || op == BIT_IOR_EXPR || op == BIT_XOR_EXPR)
2599 tmp = gfc_build_const (type, integer_zero_node);
2600 else if (op == NE_EXPR)
2602 tmp = convert (type, boolean_false_node);
2603 else if (op == BIT_AND_EXPR)
2604 tmp = gfc_build_const (type, fold_build1_loc (input_location, NEGATE_EXPR,
2605 type, integer_one_node));
2607 tmp = gfc_build_const (type, integer_one_node);
2609 gfc_add_modify (&se->pre, resvar, tmp);
2611 /* Walk the arguments. */
2612 actual = expr->value.function.actual;
2613 arrayexpr = actual->expr;
2614 arrayss = gfc_walk_expr (arrayexpr);
2615 gcc_assert (arrayss != gfc_ss_terminator);
2617 if (op == NE_EXPR || norm2)
2618 /* PARITY and NORM2. */
2622 actual = actual->next->next;
2623 gcc_assert (actual);
2624 maskexpr = actual->expr;
2627 if (maskexpr && maskexpr->rank > 0)
2629 maskss = gfc_walk_expr (maskexpr);
2630 gcc_assert (maskss != gfc_ss_terminator);
2635 /* Initialize the scalarizer. */
2636 gfc_init_loopinfo (&loop);
2637 gfc_add_ss_to_loop (&loop, arrayss);
2638 if (maskexpr && maskexpr->rank > 0)
2639 gfc_add_ss_to_loop (&loop, maskss);
2641 /* Initialize the loop. */
2642 gfc_conv_ss_startstride (&loop);
2643 gfc_conv_loop_setup (&loop, &expr->where);
2645 gfc_mark_ss_chain_used (arrayss, 1);
2646 if (maskexpr && maskexpr->rank > 0)
2647 gfc_mark_ss_chain_used (maskss, 1);
2648 /* Generate the loop body. */
2649 gfc_start_scalarized_body (&loop, &body);
2651 /* If we have a mask, only add this element if the mask is set. */
2652 if (maskexpr && maskexpr->rank > 0)
2654 gfc_init_se (&maskse, NULL);
2655 gfc_copy_loopinfo_to_se (&maskse, &loop);
2657 gfc_conv_expr_val (&maskse, maskexpr);
2658 gfc_add_block_to_block (&body, &maskse.pre);
2660 gfc_start_block (&block);
2663 gfc_init_block (&block);
2665 /* Do the actual summation/product. */
2666 gfc_init_se (&arrayse, NULL);
2667 gfc_copy_loopinfo_to_se (&arrayse, &loop);
2668 arrayse.ss = arrayss;
2669 gfc_conv_expr_val (&arrayse, arrayexpr);
2670 gfc_add_block_to_block (&block, &arrayse.pre);
2680 result = 1.0 + result * val * val;
2686 result += val * val;
2689 tree res1, res2, cond, absX, val;
2690 stmtblock_t ifblock1, ifblock2, ifblock3;
2692 gfc_init_block (&ifblock1);
2694 absX = gfc_create_var (type, "absX");
2695 gfc_add_modify (&ifblock1, absX,
2696 fold_build1_loc (input_location, ABS_EXPR, type,
2698 val = gfc_create_var (type, "val");
2699 gfc_add_expr_to_block (&ifblock1, val);
2701 gfc_init_block (&ifblock2);
2702 gfc_add_modify (&ifblock2, val,
2703 fold_build2_loc (input_location, RDIV_EXPR, type, scale,
2705 res1 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
2706 res1 = fold_build2_loc (input_location, MULT_EXPR, type, resvar, res1);
2707 res1 = fold_build2_loc (input_location, PLUS_EXPR, type, res1,
2708 gfc_build_const (type, integer_one_node));
2709 gfc_add_modify (&ifblock2, resvar, res1);
2710 gfc_add_modify (&ifblock2, scale, absX);
2711 res1 = gfc_finish_block (&ifblock2);
2713 gfc_init_block (&ifblock3);
2714 gfc_add_modify (&ifblock3, val,
2715 fold_build2_loc (input_location, RDIV_EXPR, type, absX,
2717 res2 = fold_build2_loc (input_location, MULT_EXPR, type, val, val);
2718 res2 = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, res2);
2719 gfc_add_modify (&ifblock3, resvar, res2);
2720 res2 = gfc_finish_block (&ifblock3);
2722 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
2724 tmp = build3_v (COND_EXPR, cond, res1, res2);
2725 gfc_add_expr_to_block (&ifblock1, tmp);
2726 tmp = gfc_finish_block (&ifblock1);
2728 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
2730 gfc_build_const (type, integer_zero_node));
2732 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
2733 gfc_add_expr_to_block (&block, tmp);
2737 tmp = fold_build2_loc (input_location, op, type, resvar, arrayse.expr);
2738 gfc_add_modify (&block, resvar, tmp);
2741 gfc_add_block_to_block (&block, &arrayse.post);
2743 if (maskexpr && maskexpr->rank > 0)
2745 /* We enclose the above in if (mask) {...} . */
2747 tmp = gfc_finish_block (&block);
2748 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2749 build_empty_stmt (input_location));
2752 tmp = gfc_finish_block (&block);
2753 gfc_add_expr_to_block (&body, tmp);
2755 gfc_trans_scalarizing_loops (&loop, &body);
2757 /* For a scalar mask, enclose the loop in an if statement. */
2758 if (maskexpr && maskexpr->rank == 0)
2760 gfc_init_se (&maskse, NULL);
2761 gfc_conv_expr_val (&maskse, maskexpr);
2762 gfc_init_block (&block);
2763 gfc_add_block_to_block (&block, &loop.pre);
2764 gfc_add_block_to_block (&block, &loop.post);
2765 tmp = gfc_finish_block (&block);
2767 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
2768 build_empty_stmt (input_location));
2769 gfc_add_expr_to_block (&block, tmp);
2770 gfc_add_block_to_block (&se->pre, &block);
2774 gfc_add_block_to_block (&se->pre, &loop.pre);
2775 gfc_add_block_to_block (&se->pre, &loop.post);
2778 gfc_cleanup_loop (&loop);
2782 /* result = scale * sqrt(result). */
2784 sqrt = gfc_builtin_decl_for_float_kind (BUILT_IN_SQRT, expr->ts.kind);
2785 resvar = build_call_expr_loc (input_location,
2787 resvar = fold_build2_loc (input_location, MULT_EXPR, type, scale, resvar);
2794 /* Inline implementation of the dot_product intrinsic. This function
2795 is based on gfc_conv_intrinsic_arith (the previous function). */
2797 gfc_conv_intrinsic_dot_product (gfc_se * se, gfc_expr * expr)
2805 gfc_actual_arglist *actual;
2806 gfc_ss *arrayss1, *arrayss2;
2807 gfc_se arrayse1, arrayse2;
2808 gfc_expr *arrayexpr1, *arrayexpr2;
2810 type = gfc_typenode_for_spec (&expr->ts);
2812 /* Initialize the result. */
2813 resvar = gfc_create_var (type, "val");
2814 if (expr->ts.type == BT_LOGICAL)
2815 tmp = build_int_cst (type, 0);
2817 tmp = gfc_build_const (type, integer_zero_node);
2819 gfc_add_modify (&se->pre, resvar, tmp);
2821 /* Walk argument #1. */
2822 actual = expr->value.function.actual;
2823 arrayexpr1 = actual->expr;
2824 arrayss1 = gfc_walk_expr (arrayexpr1);
2825 gcc_assert (arrayss1 != gfc_ss_terminator);
2827 /* Walk argument #2. */
2828 actual = actual->next;
2829 arrayexpr2 = actual->expr;
2830 arrayss2 = gfc_walk_expr (arrayexpr2);
2831 gcc_assert (arrayss2 != gfc_ss_terminator);
2833 /* Initialize the scalarizer. */
2834 gfc_init_loopinfo (&loop);
2835 gfc_add_ss_to_loop (&loop, arrayss1);
2836 gfc_add_ss_to_loop (&loop, arrayss2);
2838 /* Initialize the loop. */
2839 gfc_conv_ss_startstride (&loop);
2840 gfc_conv_loop_setup (&loop, &expr->where);
2842 gfc_mark_ss_chain_used (arrayss1, 1);
2843 gfc_mark_ss_chain_used (arrayss2, 1);
2845 /* Generate the loop body. */
2846 gfc_start_scalarized_body (&loop, &body);
2847 gfc_init_block (&block);
2849 /* Make the tree expression for [conjg(]array1[)]. */
2850 gfc_init_se (&arrayse1, NULL);
2851 gfc_copy_loopinfo_to_se (&arrayse1, &loop);
2852 arrayse1.ss = arrayss1;
2853 gfc_conv_expr_val (&arrayse1, arrayexpr1);
2854 if (expr->ts.type == BT_COMPLEX)
2855 arrayse1.expr = fold_build1_loc (input_location, CONJ_EXPR, type,
2857 gfc_add_block_to_block (&block, &arrayse1.pre);
2859 /* Make the tree expression for array2. */
2860 gfc_init_se (&arrayse2, NULL);
2861 gfc_copy_loopinfo_to_se (&arrayse2, &loop);
2862 arrayse2.ss = arrayss2;
2863 gfc_conv_expr_val (&arrayse2, arrayexpr2);
2864 gfc_add_block_to_block (&block, &arrayse2.pre);
2866 /* Do the actual product and sum. */
2867 if (expr->ts.type == BT_LOGICAL)
2869 tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, type,
2870 arrayse1.expr, arrayse2.expr);
2871 tmp = fold_build2_loc (input_location, TRUTH_OR_EXPR, type, resvar, tmp);
2875 tmp = fold_build2_loc (input_location, MULT_EXPR, type, arrayse1.expr,
2877 tmp = fold_build2_loc (input_location, PLUS_EXPR, type, resvar, tmp);
2879 gfc_add_modify (&block, resvar, tmp);
2881 /* Finish up the loop block and the loop. */
2882 tmp = gfc_finish_block (&block);
2883 gfc_add_expr_to_block (&body, tmp);
2885 gfc_trans_scalarizing_loops (&loop, &body);
2886 gfc_add_block_to_block (&se->pre, &loop.pre);
2887 gfc_add_block_to_block (&se->pre, &loop.post);
2888 gfc_cleanup_loop (&loop);
2894 /* Emit code for minloc or maxloc intrinsic. There are many different cases
2895 we need to handle. For performance reasons we sometimes create two
2896 loops instead of one, where the second one is much simpler.
2897 Examples for minloc intrinsic:
2898 1) Result is an array, a call is generated
2899 2) Array mask is used and NaNs need to be supported:
2905 if (pos == 0) pos = S + (1 - from);
2906 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2913 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2917 3) NaNs need to be supported, but it is known at compile time or cheaply
2918 at runtime whether array is nonempty or not:
2923 if (a[S] <= limit) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2926 if (from <= to) pos = 1;
2930 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2934 4) NaNs aren't supported, array mask is used:
2935 limit = infinities_supported ? Infinity : huge (limit);
2939 if (mask[S]) { limit = a[S]; pos = S + (1 - from); goto lab1; }
2945 if (mask[S]) if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2949 5) Same without array mask:
2950 limit = infinities_supported ? Infinity : huge (limit);
2951 pos = (from <= to) ? 1 : 0;
2954 if (a[S] < limit) { limit = a[S]; pos = S + (1 - from); }
2957 For 3) and 5), if mask is scalar, this all goes into a conditional,
2958 setting pos = 0; in the else branch. */
2961 gfc_conv_intrinsic_minmaxloc (gfc_se * se, gfc_expr * expr, enum tree_code op)
2965 stmtblock_t ifblock;
2966 stmtblock_t elseblock;
2977 gfc_actual_arglist *actual;
2982 gfc_expr *arrayexpr;
2989 gfc_conv_intrinsic_funcall (se, expr);
2993 /* Initialize the result. */
2994 pos = gfc_create_var (gfc_array_index_type, "pos");
2995 offset = gfc_create_var (gfc_array_index_type, "offset");
2996 type = gfc_typenode_for_spec (&expr->ts);
2998 /* Walk the arguments. */
2999 actual = expr->value.function.actual;
3000 arrayexpr = actual->expr;
3001 arrayss = gfc_walk_expr (arrayexpr);
3002 gcc_assert (arrayss != gfc_ss_terminator);
3004 actual = actual->next->next;
3005 gcc_assert (actual);
3006 maskexpr = actual->expr;
3008 if (maskexpr && maskexpr->rank != 0)
3010 maskss = gfc_walk_expr (maskexpr);
3011 gcc_assert (maskss != gfc_ss_terminator);
3016 if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
3018 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
3020 nonempty = fold_build2_loc (input_location, GT_EXPR,
3021 boolean_type_node, nonempty,
3022 gfc_index_zero_node);
3027 limit = gfc_create_var (gfc_typenode_for_spec (&arrayexpr->ts), "limit");
3028 switch (arrayexpr->ts.type)
3031 tmp = gfc_build_inf_or_huge (TREE_TYPE (limit), arrayexpr->ts.kind);
3035 n = gfc_validate_kind (arrayexpr->ts.type, arrayexpr->ts.kind, false);
3036 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge,
3037 arrayexpr->ts.kind);
3044 /* We start with the most negative possible value for MAXLOC, and the most
3045 positive possible value for MINLOC. The most negative possible value is
3046 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3047 possible value is HUGE in both cases. */
3049 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
3050 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
3051 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp), tmp,
3052 build_int_cst (type, 1));
3054 gfc_add_modify (&se->pre, limit, tmp);
3056 /* Initialize the scalarizer. */
3057 gfc_init_loopinfo (&loop);
3058 gfc_add_ss_to_loop (&loop, arrayss);
3060 gfc_add_ss_to_loop (&loop, maskss);
3062 /* Initialize the loop. */
3063 gfc_conv_ss_startstride (&loop);
3065 /* The code generated can have more than one loop in sequence (see the
3066 comment at the function header). This doesn't work well with the
3067 scalarizer, which changes arrays' offset when the scalarization loops
3068 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}loc
3069 are currently inlined in the scalar case only (for which loop is of rank
3070 one). As there is no dependency to care about in that case, there is no
3071 temporary, so that we can use the scalarizer temporary code to handle
3072 multiple loops. Thus, we set temp_dim here, we call gfc_mark_ss_chain_used
3073 with flag=3 later, and we use gfc_trans_scalarized_loop_boundary even later
3075 TODO: this prevents inlining of rank > 0 minmaxloc calls, so this
3076 should eventually go away. We could either create two loops properly,
3077 or find another way to save/restore the array offsets between the two
3078 loops (without conflicting with temporary management), or use a single
3079 loop minmaxloc implementation. See PR 31067. */
3080 loop.temp_dim = loop.dimen;
3081 gfc_conv_loop_setup (&loop, &expr->where);
3083 gcc_assert (loop.dimen == 1);
3084 if (nonempty == NULL && maskss == NULL && loop.from[0] && loop.to[0])
3085 nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3086 loop.from[0], loop.to[0]);
3090 /* Initialize the position to zero, following Fortran 2003. We are free
3091 to do this because Fortran 95 allows the result of an entirely false
3092 mask to be processor dependent. If we know at compile time the array
3093 is non-empty and no MASK is used, we can initialize to 1 to simplify
3095 if (nonempty != NULL && !HONOR_NANS (DECL_MODE (limit)))
3096 gfc_add_modify (&loop.pre, pos,
3097 fold_build3_loc (input_location, COND_EXPR,
3098 gfc_array_index_type,
3099 nonempty, gfc_index_one_node,
3100 gfc_index_zero_node));
3103 gfc_add_modify (&loop.pre, pos, gfc_index_zero_node);
3104 lab1 = gfc_build_label_decl (NULL_TREE);
3105 TREE_USED (lab1) = 1;
3106 lab2 = gfc_build_label_decl (NULL_TREE);
3107 TREE_USED (lab2) = 1;
3110 /* An offset must be added to the loop
3111 counter to obtain the required position. */
3112 gcc_assert (loop.from[0]);
3114 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
3115 gfc_index_one_node, loop.from[0]);
3116 gfc_add_modify (&loop.pre, offset, tmp);
3118 gfc_mark_ss_chain_used (arrayss, lab1 ? 3 : 1);
3120 gfc_mark_ss_chain_used (maskss, lab1 ? 3 : 1);
3121 /* Generate the loop body. */
3122 gfc_start_scalarized_body (&loop, &body);
3124 /* If we have a mask, only check this element if the mask is set. */
3127 gfc_init_se (&maskse, NULL);
3128 gfc_copy_loopinfo_to_se (&maskse, &loop);
3130 gfc_conv_expr_val (&maskse, maskexpr);
3131 gfc_add_block_to_block (&body, &maskse.pre);
3133 gfc_start_block (&block);
3136 gfc_init_block (&block);
3138 /* Compare with the current limit. */
3139 gfc_init_se (&arrayse, NULL);
3140 gfc_copy_loopinfo_to_se (&arrayse, &loop);
3141 arrayse.ss = arrayss;
3142 gfc_conv_expr_val (&arrayse, arrayexpr);
3143 gfc_add_block_to_block (&block, &arrayse.pre);
3145 /* We do the following if this is a more extreme value. */
3146 gfc_start_block (&ifblock);
3148 /* Assign the value to the limit... */
3149 gfc_add_modify (&ifblock, limit, arrayse.expr);
3151 if (nonempty == NULL && HONOR_NANS (DECL_MODE (limit)))
3153 stmtblock_t ifblock2;
3156 gfc_start_block (&ifblock2);
3157 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
3158 loop.loopvar[0], offset);
3159 gfc_add_modify (&ifblock2, pos, tmp);
3160 ifbody2 = gfc_finish_block (&ifblock2);
3161 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, pos,
3162 gfc_index_zero_node);
3163 tmp = build3_v (COND_EXPR, cond, ifbody2,
3164 build_empty_stmt (input_location));
3165 gfc_add_expr_to_block (&block, tmp);
3168 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
3169 loop.loopvar[0], offset);
3170 gfc_add_modify (&ifblock, pos, tmp);
3173 gfc_add_expr_to_block (&ifblock, build1_v (GOTO_EXPR, lab1));
3175 ifbody = gfc_finish_block (&ifblock);
3177 if (!lab1 || HONOR_NANS (DECL_MODE (limit)))
3180 cond = fold_build2_loc (input_location,
3181 op == GT_EXPR ? GE_EXPR : LE_EXPR,
3182 boolean_type_node, arrayse.expr, limit);
3184 cond = fold_build2_loc (input_location, op, boolean_type_node,
3185 arrayse.expr, limit);
3187 ifbody = build3_v (COND_EXPR, cond, ifbody,
3188 build_empty_stmt (input_location));
3190 gfc_add_expr_to_block (&block, ifbody);
3194 /* We enclose the above in if (mask) {...}. */
3195 tmp = gfc_finish_block (&block);
3197 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
3198 build_empty_stmt (input_location));
3201 tmp = gfc_finish_block (&block);
3202 gfc_add_expr_to_block (&body, tmp);
3206 gfc_trans_scalarized_loop_boundary (&loop, &body);
3208 if (HONOR_NANS (DECL_MODE (limit)))
3210 if (nonempty != NULL)
3212 ifbody = build2_v (MODIFY_EXPR, pos, gfc_index_one_node);
3213 tmp = build3_v (COND_EXPR, nonempty, ifbody,
3214 build_empty_stmt (input_location));
3215 gfc_add_expr_to_block (&loop.code[0], tmp);
3219 gfc_add_expr_to_block (&loop.code[0], build1_v (GOTO_EXPR, lab2));
3220 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab1));
3222 /* If we have a mask, only check this element if the mask is set. */
3225 gfc_init_se (&maskse, NULL);
3226 gfc_copy_loopinfo_to_se (&maskse, &loop);
3228 gfc_conv_expr_val (&maskse, maskexpr);
3229 gfc_add_block_to_block (&body, &maskse.pre);
3231 gfc_start_block (&block);
3234 gfc_init_block (&block);
3236 /* Compare with the current limit. */
3237 gfc_init_se (&arrayse, NULL);
3238 gfc_copy_loopinfo_to_se (&arrayse, &loop);
3239 arrayse.ss = arrayss;
3240 gfc_conv_expr_val (&arrayse, arrayexpr);
3241 gfc_add_block_to_block (&block, &arrayse.pre);
3243 /* We do the following if this is a more extreme value. */
3244 gfc_start_block (&ifblock);
3246 /* Assign the value to the limit... */
3247 gfc_add_modify (&ifblock, limit, arrayse.expr);
3249 tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (pos),
3250 loop.loopvar[0], offset);
3251 gfc_add_modify (&ifblock, pos, tmp);
3253 ifbody = gfc_finish_block (&ifblock);
3255 cond = fold_build2_loc (input_location, op, boolean_type_node,
3256 arrayse.expr, limit);
3258 tmp = build3_v (COND_EXPR, cond, ifbody,
3259 build_empty_stmt (input_location));
3260 gfc_add_expr_to_block (&block, tmp);
3264 /* We enclose the above in if (mask) {...}. */
3265 tmp = gfc_finish_block (&block);
3267 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
3268 build_empty_stmt (input_location));
3271 tmp = gfc_finish_block (&block);
3272 gfc_add_expr_to_block (&body, tmp);
3273 /* Avoid initializing loopvar[0] again, it should be left where
3274 it finished by the first loop. */
3275 loop.from[0] = loop.loopvar[0];
3278 gfc_trans_scalarizing_loops (&loop, &body);
3281 gfc_add_expr_to_block (&loop.pre, build1_v (LABEL_EXPR, lab2));
3283 /* For a scalar mask, enclose the loop in an if statement. */
3284 if (maskexpr && maskss == NULL)
3286 gfc_init_se (&maskse, NULL);
3287 gfc_conv_expr_val (&maskse, maskexpr);
3288 gfc_init_block (&block);
3289 gfc_add_block_to_block (&block, &loop.pre);
3290 gfc_add_block_to_block (&block, &loop.post);
3291 tmp = gfc_finish_block (&block);
3293 /* For the else part of the scalar mask, just initialize
3294 the pos variable the same way as above. */
3296 gfc_init_block (&elseblock);
3297 gfc_add_modify (&elseblock, pos, gfc_index_zero_node);
3298 elsetmp = gfc_finish_block (&elseblock);
3300 tmp = build3_v (COND_EXPR, maskse.expr, tmp, elsetmp);
3301 gfc_add_expr_to_block (&block, tmp);
3302 gfc_add_block_to_block (&se->pre, &block);
3306 gfc_add_block_to_block (&se->pre, &loop.pre);
3307 gfc_add_block_to_block (&se->pre, &loop.post);
3309 gfc_cleanup_loop (&loop);
3311 se->expr = convert (type, pos);
3314 /* Emit code for minval or maxval intrinsic. There are many different cases
3315 we need to handle. For performance reasons we sometimes create two
3316 loops instead of one, where the second one is much simpler.
3317 Examples for minval intrinsic:
3318 1) Result is an array, a call is generated
3319 2) Array mask is used and NaNs need to be supported, rank 1:
3324 if (mask[S]) { nonempty = true; if (a[S] <= limit) goto lab; }
3327 limit = nonempty ? NaN : huge (limit);
3329 while (S <= to) { if(mask[S]) limit = min (a[S], limit); S++; }
3330 3) NaNs need to be supported, but it is known at compile time or cheaply
3331 at runtime whether array is nonempty or not, rank 1:
3334 while (S <= to) { if (a[S] <= limit) goto lab; S++; }
3335 limit = (from <= to) ? NaN : huge (limit);
3337 while (S <= to) { limit = min (a[S], limit); S++; }
3338 4) Array mask is used and NaNs need to be supported, rank > 1:
3347 if (fast) limit = min (a[S1][S2], limit);
3350 if (a[S1][S2] <= limit) {
3361 limit = nonempty ? NaN : huge (limit);
3362 5) NaNs need to be supported, but it is known at compile time or cheaply
3363 at runtime whether array is nonempty or not, rank > 1:
3370 if (fast) limit = min (a[S1][S2], limit);
3372 if (a[S1][S2] <= limit) {
3382 limit = (nonempty_array) ? NaN : huge (limit);
3383 6) NaNs aren't supported, but infinities are. Array mask is used:
3388 if (mask[S]) { nonempty = true; limit = min (a[S], limit); }
3391 limit = nonempty ? limit : huge (limit);
3392 7) Same without array mask:
3395 while (S <= to) { limit = min (a[S], limit); S++; }
3396 limit = (from <= to) ? limit : huge (limit);
3397 8) Neither NaNs nor infinities are supported (-ffast-math or BT_INTEGER):
3398 limit = huge (limit);
3400 while (S <= to) { limit = min (a[S], limit); S++); }
3402 while (S <= to) { if (mask[S]) limit = min (a[S], limit); S++; }
3403 with array mask instead).
3404 For 3), 5), 7) and 8), if mask is scalar, this all goes into a conditional,
3405 setting limit = huge (limit); in the else branch. */
3408 gfc_conv_intrinsic_minmaxval (gfc_se * se, gfc_expr * expr, enum tree_code op)
3418 tree huge_cst = NULL, nan_cst = NULL;
3420 stmtblock_t block, block2;
3422 gfc_actual_arglist *actual;
3427 gfc_expr *arrayexpr;
3433 gfc_conv_intrinsic_funcall (se, expr);
3437 type = gfc_typenode_for_spec (&expr->ts);
3438 /* Initialize the result. */
3439 limit = gfc_create_var (type, "limit");
3440 n = gfc_validate_kind (expr->ts.type, expr->ts.kind, false);
3441 switch (expr->ts.type)
3444 huge_cst = gfc_conv_mpfr_to_tree (gfc_real_kinds[n].huge,
3446 if (HONOR_INFINITIES (DECL_MODE (limit)))
3448 REAL_VALUE_TYPE real;
3450 tmp = build_real (type, real);
3454 if (HONOR_NANS (DECL_MODE (limit)))
3456 REAL_VALUE_TYPE real;
3457 real_nan (&real, "", 1, DECL_MODE (limit));
3458 nan_cst = build_real (type, real);
3463 tmp = gfc_conv_mpz_to_tree (gfc_integer_kinds[n].huge, expr->ts.kind);
3470 /* We start with the most negative possible value for MAXVAL, and the most
3471 positive possible value for MINVAL. The most negative possible value is
3472 -HUGE for BT_REAL and (-HUGE - 1) for BT_INTEGER; the most positive
3473 possible value is HUGE in both cases. */
3476 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (tmp), tmp);
3478 huge_cst = fold_build1_loc (input_location, NEGATE_EXPR,
3479 TREE_TYPE (huge_cst), huge_cst);
3482 if (op == GT_EXPR && expr->ts.type == BT_INTEGER)
3483 tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (tmp),
3484 tmp, build_int_cst (type, 1));
3486 gfc_add_modify (&se->pre, limit, tmp);
3488 /* Walk the arguments. */
3489 actual = expr->value.function.actual;
3490 arrayexpr = actual->expr;
3491 arrayss = gfc_walk_expr (arrayexpr);
3492 gcc_assert (arrayss != gfc_ss_terminator);
3494 actual = actual->next->next;
3495 gcc_assert (actual);
3496 maskexpr = actual->expr;
3498 if (maskexpr && maskexpr->rank != 0)
3500 maskss = gfc_walk_expr (maskexpr);
3501 gcc_assert (maskss != gfc_ss_terminator);
3506 if (gfc_array_size (arrayexpr, &asize) == SUCCESS)
3508 nonempty = gfc_conv_mpz_to_tree (asize, gfc_index_integer_kind);
3510 nonempty = fold_build2_loc (input_location, GT_EXPR,
3511 boolean_type_node, nonempty,
3512 gfc_index_zero_node);
3517 /* Initialize the scalarizer. */
3518 gfc_init_loopinfo (&loop);
3519 gfc_add_ss_to_loop (&loop, arrayss);
3521 gfc_add_ss_to_loop (&loop, maskss);
3523 /* Initialize the loop. */
3524 gfc_conv_ss_startstride (&loop);
3526 /* The code generated can have more than one loop in sequence (see the
3527 comment at the function header). This doesn't work well with the
3528 scalarizer, which changes arrays' offset when the scalarization loops
3529 are generated (see gfc_trans_preloop_setup). Fortunately, {min,max}val
3530 are currently inlined in the scalar case only. As there is no dependency
3531 to care about in that case, there is no temporary, so that we can use the
3532 scalarizer temporary code to handle multiple loops. Thus, we set temp_dim
3533 here, we call gfc_mark_ss_chain_used with flag=3 later, and we use
3534 gfc_trans_scalarized_loop_boundary even later to restore offset.
3535 TODO: this prevents inlining of rank > 0 minmaxval calls, so this
3536 should eventually go away. We could either create two loops properly,
3537 or find another way to save/restore the array offsets between the two
3538 loops (without conflicting with temporary management), or use a single
3539 loop minmaxval implementation. See PR 31067. */
3540 loop.temp_dim = loop.dimen;
3541 gfc_conv_loop_setup (&loop, &expr->where);
3543 if (nonempty == NULL && maskss == NULL
3544 && loop.dimen == 1 && loop.from[0] && loop.to[0])
3545 nonempty = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
3546 loop.from[0], loop.to[0]);
3547 nonempty_var = NULL;
3548 if (nonempty == NULL
3549 && (HONOR_INFINITIES (DECL_MODE (limit))
3550 || HONOR_NANS (DECL_MODE (limit))))
3552 nonempty_var = gfc_create_var (boolean_type_node, "nonempty");
3553 gfc_add_modify (&se->pre, nonempty_var, boolean_false_node);
3554 nonempty = nonempty_var;
3558 if (HONOR_NANS (DECL_MODE (limit)))
3560 if (loop.dimen == 1)
3562 lab = gfc_build_label_decl (NULL_TREE);
3563 TREE_USED (lab) = 1;
3567 fast = gfc_create_var (boolean_type_node, "fast");
3568 gfc_add_modify (&se->pre, fast, boolean_false_node);
3572 gfc_mark_ss_chain_used (arrayss, lab ? 3 : 1);
3574 gfc_mark_ss_chain_used (maskss, lab ? 3 : 1);
3575 /* Generate the loop body. */
3576 gfc_start_scalarized_body (&loop, &body);
3578 /* If we have a mask, only add this element if the mask is set. */
3581 gfc_init_se (&maskse, NULL);
3582 gfc_copy_loopinfo_to_se (&maskse, &loop);
3584 gfc_conv_expr_val (&maskse, maskexpr);
3585 gfc_add_block_to_block (&body, &maskse.pre);
3587 gfc_start_block (&block);
3590 gfc_init_block (&block);
3592 /* Compare with the current limit. */
3593 gfc_init_se (&arrayse, NULL);
3594 gfc_copy_loopinfo_to_se (&arrayse, &loop);
3595 arrayse.ss = arrayss;
3596 gfc_conv_expr_val (&arrayse, arrayexpr);
3597 gfc_add_block_to_block (&block, &arrayse.pre);
3599 gfc_init_block (&block2);
3602 gfc_add_modify (&block2, nonempty_var, boolean_true_node);
3604 if (HONOR_NANS (DECL_MODE (limit)))
3606 tmp = fold_build2_loc (input_location, op == GT_EXPR ? GE_EXPR : LE_EXPR,
3607 boolean_type_node, arrayse.expr, limit);
3609 ifbody = build1_v (GOTO_EXPR, lab);
3612 stmtblock_t ifblock;
3614 gfc_init_block (&ifblock);
3615 gfc_add_modify (&ifblock, limit, arrayse.expr);
3616 gfc_add_modify (&ifblock, fast, boolean_true_node);
3617 ifbody = gfc_finish_block (&ifblock);
3619 tmp = build3_v (COND_EXPR, tmp, ifbody,
3620 build_empty_stmt (input_location));
3621 gfc_add_expr_to_block (&block2, tmp);
3625 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3627 if (HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
3629 tmp = fold_build2_loc (input_location, op, boolean_type_node,
3630 arrayse.expr, limit);
3631 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
3632 tmp = build3_v (COND_EXPR, tmp, ifbody,
3633 build_empty_stmt (input_location));
3634 gfc_add_expr_to_block (&block2, tmp);
3638 tmp = fold_build2_loc (input_location,
3639 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
3640 type, arrayse.expr, limit);
3641 gfc_add_modify (&block2, limit, tmp);
3647 tree elsebody = gfc_finish_block (&block2);
3649 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3651 if (HONOR_NANS (DECL_MODE (limit))
3652 || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
3654 tmp = fold_build2_loc (input_location, op, boolean_type_node,
3655 arrayse.expr, limit);
3656 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
3657 ifbody = build3_v (COND_EXPR, tmp, ifbody,
3658 build_empty_stmt (input_location));
3662 tmp = fold_build2_loc (input_location,
3663 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
3664 type, arrayse.expr, limit);
3665 ifbody = build2_v (MODIFY_EXPR, limit, tmp);
3667 tmp = build3_v (COND_EXPR, fast, ifbody, elsebody);
3668 gfc_add_expr_to_block (&block, tmp);
3671 gfc_add_block_to_block (&block, &block2);
3673 gfc_add_block_to_block (&block, &arrayse.post);
3675 tmp = gfc_finish_block (&block);
3677 /* We enclose the above in if (mask) {...}. */
3678 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
3679 build_empty_stmt (input_location));
3680 gfc_add_expr_to_block (&body, tmp);
3684 gfc_trans_scalarized_loop_boundary (&loop, &body);
3686 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
3688 gfc_add_modify (&loop.code[0], limit, tmp);
3689 gfc_add_expr_to_block (&loop.code[0], build1_v (LABEL_EXPR, lab));
3691 /* If we have a mask, only add this element if the mask is set. */
3694 gfc_init_se (&maskse, NULL);
3695 gfc_copy_loopinfo_to_se (&maskse, &loop);
3697 gfc_conv_expr_val (&maskse, maskexpr);
3698 gfc_add_block_to_block (&body, &maskse.pre);
3700 gfc_start_block (&block);
3703 gfc_init_block (&block);
3705 /* Compare with the current limit. */
3706 gfc_init_se (&arrayse, NULL);
3707 gfc_copy_loopinfo_to_se (&arrayse, &loop);
3708 arrayse.ss = arrayss;
3709 gfc_conv_expr_val (&arrayse, arrayexpr);
3710 gfc_add_block_to_block (&block, &arrayse.pre);
3712 /* MIN_EXPR/MAX_EXPR has unspecified behavior with NaNs or
3714 if (HONOR_NANS (DECL_MODE (limit))
3715 || HONOR_SIGNED_ZEROS (DECL_MODE (limit)))
3717 tmp = fold_build2_loc (input_location, op, boolean_type_node,
3718 arrayse.expr, limit);
3719 ifbody = build2_v (MODIFY_EXPR, limit, arrayse.expr);
3720 tmp = build3_v (COND_EXPR, tmp, ifbody,
3721 build_empty_stmt (input_location));
3722 gfc_add_expr_to_block (&block, tmp);
3726 tmp = fold_build2_loc (input_location,
3727 op == GT_EXPR ? MAX_EXPR : MIN_EXPR,
3728 type, arrayse.expr, limit);
3729 gfc_add_modify (&block, limit, tmp);
3732 gfc_add_block_to_block (&block, &arrayse.post);
3734 tmp = gfc_finish_block (&block);
3736 /* We enclose the above in if (mask) {...}. */
3737 tmp = build3_v (COND_EXPR, maskse.expr, tmp,
3738 build_empty_stmt (input_location));
3739 gfc_add_expr_to_block (&body, tmp);
3740 /* Avoid initializing loopvar[0] again, it should be left where
3741 it finished by the first loop. */
3742 loop.from[0] = loop.loopvar[0];
3744 gfc_trans_scalarizing_loops (&loop, &body);
3748 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty,
3750 ifbody = build2_v (MODIFY_EXPR, limit, tmp);
3751 tmp = build3_v (COND_EXPR, fast, build_empty_stmt (input_location),
3753 gfc_add_expr_to_block (&loop.pre, tmp);
3755 else if (HONOR_INFINITIES (DECL_MODE (limit)) && !lab)
3757 tmp = fold_build3_loc (input_location, COND_EXPR, type, nonempty, limit,
3759 gfc_add_modify (&loop.pre, limit, tmp);
3762 /* For a scalar mask, enclose the loop in an if statement. */
3763 if (maskexpr && maskss == NULL)
3767 gfc_init_se (&maskse, NULL);
3768 gfc_conv_expr_val (&maskse, maskexpr);
3769 gfc_init_block (&block);
3770 gfc_add_block_to_block (&block, &loop.pre);
3771 gfc_add_block_to_block (&block, &loop.post);
3772 tmp = gfc_finish_block (&block);
3774 if (HONOR_INFINITIES (DECL_MODE (limit)))
3775 else_stmt = build2_v (MODIFY_EXPR, limit, huge_cst);
3777 else_stmt = build_empty_stmt (input_location);
3778 tmp = build3_v (COND_EXPR, maskse.expr, tmp, else_stmt);
3779 gfc_add_expr_to_block (&block, tmp);
3780 gfc_add_block_to_block (&se->pre, &block);
3784 gfc_add_block_to_block (&se->pre, &loop.pre);
3785 gfc_add_block_to_block (&se->pre, &loop.post);
3788 gfc_cleanup_loop (&loop);
3793 /* BTEST (i, pos) = (i & (1 << pos)) != 0. */
3795 gfc_conv_intrinsic_btest (gfc_se * se, gfc_expr * expr)
3801 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3802 type = TREE_TYPE (args[0]);
3804 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3805 build_int_cst (type, 1), args[1]);
3806 tmp = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], tmp);
3807 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
3808 build_int_cst (type, 0));
3809 type = gfc_typenode_for_spec (&expr->ts);
3810 se->expr = convert (type, tmp);
3814 /* Generate code for BGE, BGT, BLE and BLT intrinsics. */
3816 gfc_conv_intrinsic_bitcomp (gfc_se * se, gfc_expr * expr, enum tree_code op)
3820 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3822 /* Convert both arguments to the unsigned type of the same size. */
3823 args[0] = fold_convert (unsigned_type_for (TREE_TYPE (args[0])), args[0]);
3824 args[1] = fold_convert (unsigned_type_for (TREE_TYPE (args[1])), args[1]);
3826 /* If they have unequal type size, convert to the larger one. */
3827 if (TYPE_PRECISION (TREE_TYPE (args[0]))
3828 > TYPE_PRECISION (TREE_TYPE (args[1])))
3829 args[1] = fold_convert (TREE_TYPE (args[0]), args[1]);
3830 else if (TYPE_PRECISION (TREE_TYPE (args[1]))
3831 > TYPE_PRECISION (TREE_TYPE (args[0])))
3832 args[0] = fold_convert (TREE_TYPE (args[1]), args[0]);
3834 /* Now, we compare them. */
3835 se->expr = fold_build2_loc (input_location, op, boolean_type_node,
3840 /* Generate code to perform the specified operation. */
3842 gfc_conv_intrinsic_bitop (gfc_se * se, gfc_expr * expr, enum tree_code op)
3846 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3847 se->expr = fold_build2_loc (input_location, op, TREE_TYPE (args[0]),
3853 gfc_conv_intrinsic_not (gfc_se * se, gfc_expr * expr)
3857 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
3858 se->expr = fold_build1_loc (input_location, BIT_NOT_EXPR,
3859 TREE_TYPE (arg), arg);
3862 /* Set or clear a single bit. */
3864 gfc_conv_intrinsic_singlebitop (gfc_se * se, gfc_expr * expr, int set)
3871 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3872 type = TREE_TYPE (args[0]);
3874 tmp = fold_build2_loc (input_location, LSHIFT_EXPR, type,
3875 build_int_cst (type, 1), args[1]);
3881 tmp = fold_build1_loc (input_location, BIT_NOT_EXPR, type, tmp);
3883 se->expr = fold_build2_loc (input_location, op, type, args[0], tmp);
3886 /* Extract a sequence of bits.
3887 IBITS(I, POS, LEN) = (I >> POS) & ~((~0) << LEN). */
3889 gfc_conv_intrinsic_ibits (gfc_se * se, gfc_expr * expr)
3896 gfc_conv_intrinsic_function_args (se, expr, args, 3);
3897 type = TREE_TYPE (args[0]);
3899 mask = build_int_cst (type, -1);
3900 mask = fold_build2_loc (input_location, LSHIFT_EXPR, type, mask, args[2]);
3901 mask = fold_build1_loc (input_location, BIT_NOT_EXPR, type, mask);
3903 tmp = fold_build2_loc (input_location, RSHIFT_EXPR, type, args[0], args[1]);
3905 se->expr = fold_build2_loc (input_location, BIT_AND_EXPR, type, tmp, mask);
3909 gfc_conv_intrinsic_shift (gfc_se * se, gfc_expr * expr, bool right_shift,
3912 tree args[2], type, num_bits, cond;
3914 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3916 args[0] = gfc_evaluate_now (args[0], &se->pre);
3917 args[1] = gfc_evaluate_now (args[1], &se->pre);
3918 type = TREE_TYPE (args[0]);
3921 args[0] = fold_convert (unsigned_type_for (type), args[0]);
3923 gcc_assert (right_shift);
3925 se->expr = fold_build2_loc (input_location,
3926 right_shift ? RSHIFT_EXPR : LSHIFT_EXPR,
3927 TREE_TYPE (args[0]), args[0], args[1]);
3930 se->expr = fold_convert (type, se->expr);
3932 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
3933 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
3935 num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
3936 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node,
3939 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
3940 build_int_cst (type, 0), se->expr);
3943 /* ISHFT (I, SHIFT) = (abs (shift) >= BIT_SIZE (i))
3945 : ((shift >= 0) ? i << shift : i >> -shift)
3946 where all shifts are logical shifts. */
3948 gfc_conv_intrinsic_ishft (gfc_se * se, gfc_expr * expr)
3960 gfc_conv_intrinsic_function_args (se, expr, args, 2);
3962 args[0] = gfc_evaluate_now (args[0], &se->pre);
3963 args[1] = gfc_evaluate_now (args[1], &se->pre);
3965 type = TREE_TYPE (args[0]);
3966 utype = unsigned_type_for (type);
3968 width = fold_build1_loc (input_location, ABS_EXPR, TREE_TYPE (args[1]),
3971 /* Left shift if positive. */
3972 lshift = fold_build2_loc (input_location, LSHIFT_EXPR, type, args[0], width);
3974 /* Right shift if negative.
3975 We convert to an unsigned type because we want a logical shift.
3976 The standard doesn't define the case of shifting negative
3977 numbers, and we try to be compatible with other compilers, most
3978 notably g77, here. */
3979 rshift = fold_convert (type, fold_build2_loc (input_location, RSHIFT_EXPR,
3980 utype, convert (utype, args[0]), width));
3982 tmp = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, args[1],
3983 build_int_cst (TREE_TYPE (args[1]), 0));
3984 tmp = fold_build3_loc (input_location, COND_EXPR, type, tmp, lshift, rshift);
3986 /* The Fortran standard allows shift widths <= BIT_SIZE(I), whereas
3987 gcc requires a shift width < BIT_SIZE(I), so we have to catch this
3989 num_bits = build_int_cst (TREE_TYPE (args[1]), TYPE_PRECISION (type));
3990 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, width,
3992 se->expr = fold_build3_loc (input_location, COND_EXPR, type, cond,
3993 build_int_cst (type, 0), tmp);
3997 /* Circular shift. AKA rotate or barrel shift. */
4000 gfc_conv_intrinsic_ishftc (gfc_se * se, gfc_expr * expr)
4008 unsigned int num_args;
4010 num_args = gfc_intrinsic_argument_list_length (expr);
4011 args = XALLOCAVEC (tree, num_args);
4013 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
4017 /* Use a library function for the 3 parameter version. */
4018 tree int4type = gfc_get_int_type (4);
4020 type = TREE_TYPE (args[0]);
4021 /* We convert the first argument to at least 4 bytes, and
4022 convert back afterwards. This removes the need for library
4023 functions for all argument sizes, and function will be
4024 aligned to at least 32 bits, so there's no loss. */
4025 if (expr->ts.kind < 4)
4026 args[0] = convert (int4type, args[0]);
4028 /* Convert the SHIFT and SIZE args to INTEGER*4 otherwise we would
4029 need loads of library functions. They cannot have values >
4030 BIT_SIZE (I) so the conversion is safe. */
4031 args[1] = convert (int4type, args[1]);
4032 args[2] = convert (int4type, args[2]);
4034 switch (expr->ts.kind)
4039 tmp = gfor_fndecl_math_ishftc4;
4042 tmp = gfor_fndecl_math_ishftc8;
4045 tmp = gfor_fndecl_math_ishftc16;
4050 se->expr = build_call_expr_loc (input_location,
4051 tmp, 3, args[0], args[1], args[2]);
4052 /* Convert the result back to the original type, if we extended
4053 the first argument's width above. */
4054 if (expr->ts.kind < 4)
4055 se->expr = convert (type, se->expr);
4059 type = TREE_TYPE (args[0]);
4061 /* Evaluate arguments only once. */
4062 args[0] = gfc_evaluate_now (args[0], &se->pre);
4063 args[1] = gfc_evaluate_now (args[1], &se->pre);
4065 /* Rotate left if positive. */
4066 lrot = fold_build2_loc (input_location, LROTATE_EXPR, type, args[0], args[1]);
4068 /* Rotate right if negative. */
4069 tmp = fold_build1_loc (input_location, NEGATE_EXPR, TREE_TYPE (args[1]),
4071 rrot = fold_build2_loc (input_location,RROTATE_EXPR, type, args[0], tmp);
4073 zero = build_int_cst (TREE_TYPE (args[1]), 0);
4074 tmp = fold_build2_loc (input_location, GT_EXPR, boolean_type_node, args[1],
4076 rrot = fold_build3_loc (input_location, COND_EXPR, type, tmp, lrot, rrot);
4078 /* Do nothing if shift == 0. */
4079 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, args[1],
4081 se->expr = fold_build3_loc (input_location, COND_EXPR, type, tmp, args[0],
4086 /* LEADZ (i) = (i == 0) ? BIT_SIZE (i)
4087 : __builtin_clz(i) - (BIT_SIZE('int') - BIT_SIZE(i))
4089 The conditional expression is necessary because the result of LEADZ(0)
4090 is defined, but the result of __builtin_clz(0) is undefined for most
4093 For INTEGER kinds smaller than the C 'int' type, we have to subtract the
4094 difference in bit size between the argument of LEADZ and the C int. */
4097 gfc_conv_intrinsic_leadz (gfc_se * se, gfc_expr * expr)
4109 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4110 argsize = TYPE_PRECISION (TREE_TYPE (arg));
4112 /* Which variant of __builtin_clz* should we call? */
4113 if (argsize <= INT_TYPE_SIZE)
4115 arg_type = unsigned_type_node;
4116 func = builtin_decl_explicit (BUILT_IN_CLZ);
4118 else if (argsize <= LONG_TYPE_SIZE)
4120 arg_type = long_unsigned_type_node;
4121 func = builtin_decl_explicit (BUILT_IN_CLZL);
4123 else if (argsize <= LONG_LONG_TYPE_SIZE)
4125 arg_type = long_long_unsigned_type_node;
4126 func = builtin_decl_explicit (BUILT_IN_CLZLL);
4130 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
4131 arg_type = gfc_build_uint_type (argsize);
4135 /* Convert the actual argument twice: first, to the unsigned type of the
4136 same size; then, to the proper argument type for the built-in
4137 function. But the return type is of the default INTEGER kind. */
4138 arg = fold_convert (gfc_build_uint_type (argsize), arg);
4139 arg = fold_convert (arg_type, arg);
4140 arg = gfc_evaluate_now (arg, &se->pre);
4141 result_type = gfc_get_int_type (gfc_default_integer_kind);
4143 /* Compute LEADZ for the case i .ne. 0. */
4146 s = TYPE_PRECISION (arg_type) - argsize;
4147 tmp = fold_convert (result_type,
4148 build_call_expr_loc (input_location, func,
4150 leadz = fold_build2_loc (input_location, MINUS_EXPR, result_type,
4151 tmp, build_int_cst (result_type, s));
4155 /* We end up here if the argument type is larger than 'long long'.
4156 We generate this code:
4158 if (x & (ULL_MAX << ULL_SIZE) != 0)
4159 return clzll ((unsigned long long) (x >> ULLSIZE));
4161 return ULL_SIZE + clzll ((unsigned long long) x);
4162 where ULL_MAX is the largest value that a ULL_MAX can hold
4163 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4164 is the bit-size of the long long type (64 in this example). */
4165 tree ullsize, ullmax, tmp1, tmp2, btmp;
4167 ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
4168 ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
4169 long_long_unsigned_type_node,
4170 build_int_cst (long_long_unsigned_type_node,
4173 cond = fold_build2_loc (input_location, LSHIFT_EXPR, arg_type,
4174 fold_convert (arg_type, ullmax), ullsize);
4175 cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type,
4177 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
4178 cond, build_int_cst (arg_type, 0));
4180 tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
4182 tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
4183 btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
4184 tmp1 = fold_convert (result_type,
4185 build_call_expr_loc (input_location, btmp, 1, tmp1));
4187 tmp2 = fold_convert (long_long_unsigned_type_node, arg);
4188 btmp = builtin_decl_explicit (BUILT_IN_CLZLL);
4189 tmp2 = fold_convert (result_type,
4190 build_call_expr_loc (input_location, btmp, 1, tmp2));
4191 tmp2 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
4194 leadz = fold_build3_loc (input_location, COND_EXPR, result_type,
4198 /* Build BIT_SIZE. */
4199 bit_size = build_int_cst (result_type, argsize);
4201 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4202 arg, build_int_cst (arg_type, 0));
4203 se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
4208 /* TRAILZ(i) = (i == 0) ? BIT_SIZE (i) : __builtin_ctz(i)
4210 The conditional expression is necessary because the result of TRAILZ(0)
4211 is defined, but the result of __builtin_ctz(0) is undefined for most
4215 gfc_conv_intrinsic_trailz (gfc_se * se, gfc_expr *expr)
4226 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4227 argsize = TYPE_PRECISION (TREE_TYPE (arg));
4229 /* Which variant of __builtin_ctz* should we call? */
4230 if (argsize <= INT_TYPE_SIZE)
4232 arg_type = unsigned_type_node;
4233 func = builtin_decl_explicit (BUILT_IN_CTZ);
4235 else if (argsize <= LONG_TYPE_SIZE)
4237 arg_type = long_unsigned_type_node;
4238 func = builtin_decl_explicit (BUILT_IN_CTZL);
4240 else if (argsize <= LONG_LONG_TYPE_SIZE)
4242 arg_type = long_long_unsigned_type_node;
4243 func = builtin_decl_explicit (BUILT_IN_CTZLL);
4247 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
4248 arg_type = gfc_build_uint_type (argsize);
4252 /* Convert the actual argument twice: first, to the unsigned type of the
4253 same size; then, to the proper argument type for the built-in
4254 function. But the return type is of the default INTEGER kind. */
4255 arg = fold_convert (gfc_build_uint_type (argsize), arg);
4256 arg = fold_convert (arg_type, arg);
4257 arg = gfc_evaluate_now (arg, &se->pre);
4258 result_type = gfc_get_int_type (gfc_default_integer_kind);
4260 /* Compute TRAILZ for the case i .ne. 0. */
4262 trailz = fold_convert (result_type, build_call_expr_loc (input_location,
4266 /* We end up here if the argument type is larger than 'long long'.
4267 We generate this code:
4269 if ((x & ULL_MAX) == 0)
4270 return ULL_SIZE + ctzll ((unsigned long long) (x >> ULLSIZE));
4272 return ctzll ((unsigned long long) x);
4274 where ULL_MAX is the largest value that a ULL_MAX can hold
4275 (0xFFFFFFFFFFFFFFFF for a 64-bit long long type), and ULLSIZE
4276 is the bit-size of the long long type (64 in this example). */
4277 tree ullsize, ullmax, tmp1, tmp2, btmp;
4279 ullsize = build_int_cst (result_type, LONG_LONG_TYPE_SIZE);
4280 ullmax = fold_build1_loc (input_location, BIT_NOT_EXPR,
4281 long_long_unsigned_type_node,
4282 build_int_cst (long_long_unsigned_type_node, 0));
4284 cond = fold_build2_loc (input_location, BIT_AND_EXPR, arg_type, arg,
4285 fold_convert (arg_type, ullmax));
4286 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, cond,
4287 build_int_cst (arg_type, 0));
4289 tmp1 = fold_build2_loc (input_location, RSHIFT_EXPR, arg_type,
4291 tmp1 = fold_convert (long_long_unsigned_type_node, tmp1);
4292 btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
4293 tmp1 = fold_convert (result_type,
4294 build_call_expr_loc (input_location, btmp, 1, tmp1));
4295 tmp1 = fold_build2_loc (input_location, PLUS_EXPR, result_type,
4298 tmp2 = fold_convert (long_long_unsigned_type_node, arg);
4299 btmp = builtin_decl_explicit (BUILT_IN_CTZLL);
4300 tmp2 = fold_convert (result_type,
4301 build_call_expr_loc (input_location, btmp, 1, tmp2));
4303 trailz = fold_build3_loc (input_location, COND_EXPR, result_type,
4307 /* Build BIT_SIZE. */
4308 bit_size = build_int_cst (result_type, argsize);
4310 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4311 arg, build_int_cst (arg_type, 0));
4312 se->expr = fold_build3_loc (input_location, COND_EXPR, result_type, cond,
4316 /* Using __builtin_popcount for POPCNT and __builtin_parity for POPPAR;
4317 for types larger than "long long", we call the long long built-in for
4318 the lower and higher bits and combine the result. */
4321 gfc_conv_intrinsic_popcnt_poppar (gfc_se * se, gfc_expr *expr, int parity)
4329 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4330 argsize = TYPE_PRECISION (TREE_TYPE (arg));
4331 result_type = gfc_get_int_type (gfc_default_integer_kind);
4333 /* Which variant of the builtin should we call? */
4334 if (argsize <= INT_TYPE_SIZE)
4336 arg_type = unsigned_type_node;
4337 func = builtin_decl_explicit (parity
4339 : BUILT_IN_POPCOUNT);
4341 else if (argsize <= LONG_TYPE_SIZE)
4343 arg_type = long_unsigned_type_node;
4344 func = builtin_decl_explicit (parity
4346 : BUILT_IN_POPCOUNTL);
4348 else if (argsize <= LONG_LONG_TYPE_SIZE)
4350 arg_type = long_long_unsigned_type_node;
4351 func = builtin_decl_explicit (parity
4353 : BUILT_IN_POPCOUNTLL);
4357 /* Our argument type is larger than 'long long', which mean none
4358 of the POPCOUNT builtins covers it. We thus call the 'long long'
4359 variant multiple times, and add the results. */
4360 tree utype, arg2, call1, call2;
4362 /* For now, we only cover the case where argsize is twice as large
4364 gcc_assert (argsize == 2 * LONG_LONG_TYPE_SIZE);
4366 func = builtin_decl_explicit (parity
4368 : BUILT_IN_POPCOUNTLL);
4370 /* Convert it to an integer, and store into a variable. */
4371 utype = gfc_build_uint_type (argsize);
4372 arg = fold_convert (utype, arg);
4373 arg = gfc_evaluate_now (arg, &se->pre);
4375 /* Call the builtin twice. */
4376 call1 = build_call_expr_loc (input_location, func, 1,
4377 fold_convert (long_long_unsigned_type_node,
4380 arg2 = fold_build2_loc (input_location, RSHIFT_EXPR, utype, arg,
4381 build_int_cst (utype, LONG_LONG_TYPE_SIZE));
4382 call2 = build_call_expr_loc (input_location, func, 1,
4383 fold_convert (long_long_unsigned_type_node,
4386 /* Combine the results. */
4388 se->expr = fold_build2_loc (input_location, BIT_XOR_EXPR, result_type,
4391 se->expr = fold_build2_loc (input_location, PLUS_EXPR, result_type,
4397 /* Convert the actual argument twice: first, to the unsigned type of the
4398 same size; then, to the proper argument type for the built-in
4400 arg = fold_convert (gfc_build_uint_type (argsize), arg);
4401 arg = fold_convert (arg_type, arg);
4403 se->expr = fold_convert (result_type,
4404 build_call_expr_loc (input_location, func, 1, arg));
4408 /* Process an intrinsic with unspecified argument-types that has an optional
4409 argument (which could be of type character), e.g. EOSHIFT. For those, we
4410 need to append the string length of the optional argument if it is not
4411 present and the type is really character.
4412 primary specifies the position (starting at 1) of the non-optional argument
4413 specifying the type and optional gives the position of the optional
4414 argument in the arglist. */
4417 conv_generic_with_optional_char_arg (gfc_se* se, gfc_expr* expr,
4418 unsigned primary, unsigned optional)
4420 gfc_actual_arglist* prim_arg;
4421 gfc_actual_arglist* opt_arg;
4423 gfc_actual_arglist* arg;
4425 VEC(tree,gc) *append_args;
4427 /* Find the two arguments given as position. */
4431 for (arg = expr->value.function.actual; arg; arg = arg->next)
4435 if (cur_pos == primary)
4437 if (cur_pos == optional)
4440 if (cur_pos >= primary && cur_pos >= optional)
4443 gcc_assert (prim_arg);
4444 gcc_assert (prim_arg->expr);
4445 gcc_assert (opt_arg);
4447 /* If we do have type CHARACTER and the optional argument is really absent,
4448 append a dummy 0 as string length. */
4450 if (prim_arg->expr->ts.type == BT_CHARACTER && !opt_arg->expr)
4454 dummy = build_int_cst (gfc_charlen_type_node, 0);
4455 append_args = VEC_alloc (tree, gc, 1);
4456 VEC_quick_push (tree, append_args, dummy);
4459 /* Build the call itself. */
4460 sym = gfc_get_symbol_for_expr (expr);
4461 gfc_conv_procedure_call (se, sym, expr->value.function.actual, expr,
4467 /* The length of a character string. */
4469 gfc_conv_intrinsic_len (gfc_se * se, gfc_expr * expr)
4479 gcc_assert (!se->ss);
4481 arg = expr->value.function.actual->expr;
4483 type = gfc_typenode_for_spec (&expr->ts);
4484 switch (arg->expr_type)
4487 len = build_int_cst (gfc_charlen_type_node, arg->value.character.length);
4491 /* Obtain the string length from the function used by
4492 trans-array.c(gfc_trans_array_constructor). */
4494 get_array_ctor_strlen (&se->pre, arg->value.constructor, &len);
4498 if (arg->ref == NULL
4499 || (arg->ref->next == NULL && arg->ref->type == REF_ARRAY))
4501 /* This doesn't catch all cases.
4502 See http://gcc.gnu.org/ml/fortran/2004-06/msg00165.html
4503 and the surrounding thread. */
4504 sym = arg->symtree->n.sym;
4505 decl = gfc_get_symbol_decl (sym);
4506 if (decl == current_function_decl && sym->attr.function
4507 && (sym->result == sym))
4508 decl = gfc_get_fake_result_decl (sym, 0);
4510 len = sym->ts.u.cl->backend_decl;
4515 /* Otherwise fall through. */
4518 /* Anybody stupid enough to do this deserves inefficient code. */
4519 ss = gfc_walk_expr (arg);
4520 gfc_init_se (&argse, se);
4521 if (ss == gfc_ss_terminator)
4522 gfc_conv_expr (&argse, arg);
4524 gfc_conv_expr_descriptor (&argse, arg, ss);
4525 gfc_add_block_to_block (&se->pre, &argse.pre);
4526 gfc_add_block_to_block (&se->post, &argse.post);
4527 len = argse.string_length;
4530 se->expr = convert (type, len);
4533 /* The length of a character string not including trailing blanks. */
4535 gfc_conv_intrinsic_len_trim (gfc_se * se, gfc_expr * expr)
4537 int kind = expr->value.function.actual->expr->ts.kind;
4538 tree args[2], type, fndecl;
4540 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4541 type = gfc_typenode_for_spec (&expr->ts);
4544 fndecl = gfor_fndecl_string_len_trim;
4546 fndecl = gfor_fndecl_string_len_trim_char4;
4550 se->expr = build_call_expr_loc (input_location,
4551 fndecl, 2, args[0], args[1]);
4552 se->expr = convert (type, se->expr);
4556 /* Returns the starting position of a substring within a string. */
4559 gfc_conv_intrinsic_index_scan_verify (gfc_se * se, gfc_expr * expr,
4562 tree logical4_type_node = gfc_get_logical_type (4);
4566 unsigned int num_args;
4568 args = XALLOCAVEC (tree, 5);
4570 /* Get number of arguments; characters count double due to the
4571 string length argument. Kind= is not passed to the library
4572 and thus ignored. */
4573 if (expr->value.function.actual->next->next->expr == NULL)
4578 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
4579 type = gfc_typenode_for_spec (&expr->ts);
4582 args[4] = build_int_cst (logical4_type_node, 0);
4584 args[4] = convert (logical4_type_node, args[4]);
4586 fndecl = build_addr (function, current_function_decl);
4587 se->expr = build_call_array_loc (input_location,
4588 TREE_TYPE (TREE_TYPE (function)), fndecl,
4590 se->expr = convert (type, se->expr);
4594 /* The ascii value for a single character. */
4596 gfc_conv_intrinsic_ichar (gfc_se * se, gfc_expr * expr)
4598 tree args[2], type, pchartype;
4600 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4601 gcc_assert (POINTER_TYPE_P (TREE_TYPE (args[1])));
4602 pchartype = gfc_get_pchar_type (expr->value.function.actual->expr->ts.kind);
4603 args[1] = fold_build1_loc (input_location, NOP_EXPR, pchartype, args[1]);
4604 type = gfc_typenode_for_spec (&expr->ts);
4606 se->expr = build_fold_indirect_ref_loc (input_location,
4608 se->expr = convert (type, se->expr);
4612 /* Intrinsic ISNAN calls __builtin_isnan. */
4615 gfc_conv_intrinsic_isnan (gfc_se * se, gfc_expr * expr)
4619 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4620 se->expr = build_call_expr_loc (input_location,
4621 builtin_decl_explicit (BUILT_IN_ISNAN),
4623 STRIP_TYPE_NOPS (se->expr);
4624 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
4628 /* Intrinsics IS_IOSTAT_END and IS_IOSTAT_EOR just need to compare
4629 their argument against a constant integer value. */
4632 gfc_conv_has_intvalue (gfc_se * se, gfc_expr * expr, const int value)
4636 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4637 se->expr = fold_build2_loc (input_location, EQ_EXPR,
4638 gfc_typenode_for_spec (&expr->ts),
4639 arg, build_int_cst (TREE_TYPE (arg), value));
4644 /* MERGE (tsource, fsource, mask) = mask ? tsource : fsource. */
4647 gfc_conv_intrinsic_merge (gfc_se * se, gfc_expr * expr)
4655 unsigned int num_args;
4657 num_args = gfc_intrinsic_argument_list_length (expr);
4658 args = XALLOCAVEC (tree, num_args);
4660 gfc_conv_intrinsic_function_args (se, expr, args, num_args);
4661 if (expr->ts.type != BT_CHARACTER)
4669 /* We do the same as in the non-character case, but the argument
4670 list is different because of the string length arguments. We
4671 also have to set the string length for the result. */
4678 gfc_trans_same_strlen_check ("MERGE intrinsic", &expr->where, len, len2,
4680 se->string_length = len;
4682 type = TREE_TYPE (tsource);
4683 se->expr = fold_build3_loc (input_location, COND_EXPR, type, mask, tsource,
4684 fold_convert (type, fsource));
4688 /* MERGE_BITS (I, J, MASK) = (I & MASK) | (I & (~MASK)). */
4691 gfc_conv_intrinsic_merge_bits (gfc_se * se, gfc_expr * expr)
4693 tree args[3], mask, type;
4695 gfc_conv_intrinsic_function_args (se, expr, args, 3);
4696 mask = gfc_evaluate_now (args[2], &se->pre);
4698 type = TREE_TYPE (args[0]);
4699 gcc_assert (TREE_TYPE (args[1]) == type);
4700 gcc_assert (TREE_TYPE (mask) == type);
4702 args[0] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[0], mask);
4703 args[1] = fold_build2_loc (input_location, BIT_AND_EXPR, type, args[1],
4704 fold_build1_loc (input_location, BIT_NOT_EXPR,
4706 se->expr = fold_build2_loc (input_location, BIT_IOR_EXPR, type,
4711 /* MASKL(n) = n == 0 ? 0 : (~0) << (BIT_SIZE - n)
4712 MASKR(n) = n == BIT_SIZE ? ~0 : ~((~0) << n) */
4715 gfc_conv_intrinsic_mask (gfc_se * se, gfc_expr * expr, int left)
4717 tree arg, allones, type, utype, res, cond, bitsize;
4720 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4721 arg = gfc_evaluate_now (arg, &se->pre);
4723 type = gfc_get_int_type (expr->ts.kind);
4724 utype = unsigned_type_for (type);
4726 i = gfc_validate_kind (BT_INTEGER, expr->ts.kind, false);
4727 bitsize = build_int_cst (TREE_TYPE (arg), gfc_integer_kinds[i].bit_size);
4729 allones = fold_build1_loc (input_location, BIT_NOT_EXPR, utype,
4730 build_int_cst (utype, 0));
4734 /* Left-justified mask. */
4735 res = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (arg),
4737 res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
4738 fold_convert (utype, res));
4740 /* Special case arg == 0, because SHIFT_EXPR wants a shift strictly
4741 smaller than type width. */
4742 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg,
4743 build_int_cst (TREE_TYPE (arg), 0));
4744 res = fold_build3_loc (input_location, COND_EXPR, utype, cond,
4745 build_int_cst (utype, 0), res);
4749 /* Right-justified mask. */
4750 res = fold_build2_loc (input_location, LSHIFT_EXPR, utype, allones,
4751 fold_convert (utype, arg));
4752 res = fold_build1_loc (input_location, BIT_NOT_EXPR, utype, res);
4754 /* Special case agr == bit_size, because SHIFT_EXPR wants a shift
4755 strictly smaller than type width. */
4756 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
4758 res = fold_build3_loc (input_location, COND_EXPR, utype,
4759 cond, allones, res);
4762 se->expr = fold_convert (type, res);
4766 /* FRACTION (s) is translated into frexp (s, &dummy_int). */
4768 gfc_conv_intrinsic_fraction (gfc_se * se, gfc_expr * expr)
4770 tree arg, type, tmp, frexp;
4772 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
4774 type = gfc_typenode_for_spec (&expr->ts);
4775 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4776 tmp = gfc_create_var (integer_type_node, NULL);
4777 se->expr = build_call_expr_loc (input_location, frexp, 2,
4778 fold_convert (type, arg),
4779 gfc_build_addr_expr (NULL_TREE, tmp));
4780 se->expr = fold_convert (type, se->expr);
4784 /* NEAREST (s, dir) is translated into
4785 tmp = copysign (HUGE_VAL, dir);
4786 return nextafter (s, tmp);
4789 gfc_conv_intrinsic_nearest (gfc_se * se, gfc_expr * expr)
4791 tree args[2], type, tmp, nextafter, copysign, huge_val;
4793 nextafter = gfc_builtin_decl_for_float_kind (BUILT_IN_NEXTAFTER, expr->ts.kind);
4794 copysign = gfc_builtin_decl_for_float_kind (BUILT_IN_COPYSIGN, expr->ts.kind);
4796 type = gfc_typenode_for_spec (&expr->ts);
4797 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4799 huge_val = gfc_build_inf_or_huge (type, expr->ts.kind);
4800 tmp = build_call_expr_loc (input_location, copysign, 2, huge_val,
4801 fold_convert (type, args[1]));
4802 se->expr = build_call_expr_loc (input_location, nextafter, 2,
4803 fold_convert (type, args[0]), tmp);
4804 se->expr = fold_convert (type, se->expr);
4808 /* SPACING (s) is translated into
4816 e = MAX_EXPR (e, emin);
4817 res = scalbn (1., e);
4821 where prec is the precision of s, gfc_real_kinds[k].digits,
4822 emin is min_exponent - 1, gfc_real_kinds[k].min_exponent - 1,
4823 and tiny is tiny(s), gfc_real_kinds[k].tiny. */
4826 gfc_conv_intrinsic_spacing (gfc_se * se, gfc_expr * expr)
4828 tree arg, type, prec, emin, tiny, res, e;
4829 tree cond, tmp, frexp, scalbn;
4833 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
4834 prec = build_int_cst (integer_type_node, gfc_real_kinds[k].digits);
4835 emin = build_int_cst (integer_type_node, gfc_real_kinds[k].min_exponent - 1);
4836 tiny = gfc_conv_mpfr_to_tree (gfc_real_kinds[k].tiny, expr->ts.kind, 0);
4838 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
4839 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
4841 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4842 arg = gfc_evaluate_now (arg, &se->pre);
4844 type = gfc_typenode_for_spec (&expr->ts);
4845 e = gfc_create_var (integer_type_node, NULL);
4846 res = gfc_create_var (type, NULL);
4849 /* Build the block for s /= 0. */
4850 gfc_start_block (&block);
4851 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
4852 gfc_build_addr_expr (NULL_TREE, e));
4853 gfc_add_expr_to_block (&block, tmp);
4855 tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node, e,
4857 gfc_add_modify (&block, e, fold_build2_loc (input_location, MAX_EXPR,
4858 integer_type_node, tmp, emin));
4860 tmp = build_call_expr_loc (input_location, scalbn, 2,
4861 build_real_from_int_cst (type, integer_one_node), e);
4862 gfc_add_modify (&block, res, tmp);
4864 /* Finish by building the IF statement. */
4865 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, arg,
4866 build_real_from_int_cst (type, integer_zero_node));
4867 tmp = build3_v (COND_EXPR, cond, build2_v (MODIFY_EXPR, res, tiny),
4868 gfc_finish_block (&block));
4870 gfc_add_expr_to_block (&se->pre, tmp);
4875 /* RRSPACING (s) is translated into
4882 x = scalbn (x, precision - e);
4886 where precision is gfc_real_kinds[k].digits. */
4889 gfc_conv_intrinsic_rrspacing (gfc_se * se, gfc_expr * expr)
4891 tree arg, type, e, x, cond, stmt, tmp, frexp, scalbn, fabs;
4895 k = gfc_validate_kind (BT_REAL, expr->ts.kind, false);
4896 prec = gfc_real_kinds[k].digits;
4898 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
4899 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
4900 fabs = gfc_builtin_decl_for_float_kind (BUILT_IN_FABS, expr->ts.kind);
4902 type = gfc_typenode_for_spec (&expr->ts);
4903 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
4904 arg = gfc_evaluate_now (arg, &se->pre);
4906 e = gfc_create_var (integer_type_node, NULL);
4907 x = gfc_create_var (type, NULL);
4908 gfc_add_modify (&se->pre, x,
4909 build_call_expr_loc (input_location, fabs, 1, arg));
4912 gfc_start_block (&block);
4913 tmp = build_call_expr_loc (input_location, frexp, 2, arg,
4914 gfc_build_addr_expr (NULL_TREE, e));
4915 gfc_add_expr_to_block (&block, tmp);
4917 tmp = fold_build2_loc (input_location, MINUS_EXPR, integer_type_node,
4918 build_int_cst (integer_type_node, prec), e);
4919 tmp = build_call_expr_loc (input_location, scalbn, 2, x, tmp);
4920 gfc_add_modify (&block, x, tmp);
4921 stmt = gfc_finish_block (&block);
4923 cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, x,
4924 build_real_from_int_cst (type, integer_zero_node));
4925 tmp = build3_v (COND_EXPR, cond, stmt, build_empty_stmt (input_location));
4926 gfc_add_expr_to_block (&se->pre, tmp);
4928 se->expr = fold_convert (type, x);
4932 /* SCALE (s, i) is translated into scalbn (s, i). */
4934 gfc_conv_intrinsic_scale (gfc_se * se, gfc_expr * expr)
4936 tree args[2], type, scalbn;
4938 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
4940 type = gfc_typenode_for_spec (&expr->ts);
4941 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4942 se->expr = build_call_expr_loc (input_location, scalbn, 2,
4943 fold_convert (type, args[0]),
4944 fold_convert (integer_type_node, args[1]));
4945 se->expr = fold_convert (type, se->expr);
4949 /* SET_EXPONENT (s, i) is translated into
4950 scalbn (frexp (s, &dummy_int), i). */
4952 gfc_conv_intrinsic_set_exponent (gfc_se * se, gfc_expr * expr)
4954 tree args[2], type, tmp, frexp, scalbn;
4956 frexp = gfc_builtin_decl_for_float_kind (BUILT_IN_FREXP, expr->ts.kind);
4957 scalbn = gfc_builtin_decl_for_float_kind (BUILT_IN_SCALBN, expr->ts.kind);
4959 type = gfc_typenode_for_spec (&expr->ts);
4960 gfc_conv_intrinsic_function_args (se, expr, args, 2);
4962 tmp = gfc_create_var (integer_type_node, NULL);
4963 tmp = build_call_expr_loc (input_location, frexp, 2,
4964 fold_convert (type, args[0]),
4965 gfc_build_addr_expr (NULL_TREE, tmp));
4966 se->expr = build_call_expr_loc (input_location, scalbn, 2, tmp,
4967 fold_convert (integer_type_node, args[1]));
4968 se->expr = fold_convert (type, se->expr);
4973 gfc_conv_intrinsic_size (gfc_se * se, gfc_expr * expr)
4975 gfc_actual_arglist *actual;
4983 gfc_init_se (&argse, NULL);
4984 actual = expr->value.function.actual;
4986 ss = gfc_walk_expr (actual->expr);
4987 gcc_assert (ss != gfc_ss_terminator);
4988 argse.want_pointer = 1;
4989 argse.data_not_needed = 1;
4990 gfc_conv_expr_descriptor (&argse, actual->expr, ss);
4991 gfc_add_block_to_block (&se->pre, &argse.pre);
4992 gfc_add_block_to_block (&se->post, &argse.post);
4993 arg1 = gfc_evaluate_now (argse.expr, &se->pre);
4995 /* Build the call to size0. */
4996 fncall0 = build_call_expr_loc (input_location,
4997 gfor_fndecl_size0, 1, arg1);
4999 actual = actual->next;
5003 gfc_init_se (&argse, NULL);
5004 gfc_conv_expr_type (&argse, actual->expr,
5005 gfc_array_index_type);
5006 gfc_add_block_to_block (&se->pre, &argse.pre);
5008 /* Unusually, for an intrinsic, size does not exclude
5009 an optional arg2, so we must test for it. */
5010 if (actual->expr->expr_type == EXPR_VARIABLE
5011 && actual->expr->symtree->n.sym->attr.dummy
5012 && actual->expr->symtree->n.sym->attr.optional)
5015 /* Build the call to size1. */
5016 fncall1 = build_call_expr_loc (input_location,
5017 gfor_fndecl_size1, 2,
5020 gfc_init_se (&argse, NULL);
5021 argse.want_pointer = 1;
5022 argse.data_not_needed = 1;
5023 gfc_conv_expr (&argse, actual->expr);
5024 gfc_add_block_to_block (&se->pre, &argse.pre);
5025 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5026 argse.expr, null_pointer_node);
5027 tmp = gfc_evaluate_now (tmp, &se->pre);
5028 se->expr = fold_build3_loc (input_location, COND_EXPR,
5029 pvoid_type_node, tmp, fncall1, fncall0);
5033 se->expr = NULL_TREE;
5034 argse.expr = fold_build2_loc (input_location, MINUS_EXPR,
5035 gfc_array_index_type,
5036 argse.expr, gfc_index_one_node);
5039 else if (expr->value.function.actual->expr->rank == 1)
5041 argse.expr = gfc_index_zero_node;
5042 se->expr = NULL_TREE;
5047 if (se->expr == NULL_TREE)
5049 tree ubound, lbound;
5051 arg1 = build_fold_indirect_ref_loc (input_location,
5053 ubound = gfc_conv_descriptor_ubound_get (arg1, argse.expr);
5054 lbound = gfc_conv_descriptor_lbound_get (arg1, argse.expr);
5055 se->expr = fold_build2_loc (input_location, MINUS_EXPR,
5056 gfc_array_index_type, ubound, lbound);
5057 se->expr = fold_build2_loc (input_location, PLUS_EXPR,
5058 gfc_array_index_type,
5059 se->expr, gfc_index_one_node);
5060 se->expr = fold_build2_loc (input_location, MAX_EXPR,
5061 gfc_array_index_type, se->expr,
5062 gfc_index_zero_node);
5065 type = gfc_typenode_for_spec (&expr->ts);
5066 se->expr = convert (type, se->expr);
5070 /* Helper function to compute the size of a character variable,
5071 excluding the terminating null characters. The result has
5072 gfc_array_index_type type. */
5075 size_of_string_in_bytes (int kind, tree string_length)
5078 int i = gfc_validate_kind (BT_CHARACTER, kind, false);
5080 bytesize = build_int_cst (gfc_array_index_type,
5081 gfc_character_kinds[i].bit_size / 8);
5083 return fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5085 fold_convert (gfc_array_index_type, string_length));
5090 gfc_conv_intrinsic_sizeof (gfc_se *se, gfc_expr *expr)
5102 arg = expr->value.function.actual->expr;
5104 gfc_init_se (&argse, NULL);
5105 ss = gfc_walk_expr (arg);
5107 if (ss == gfc_ss_terminator)
5109 if (arg->ts.type == BT_CLASS)
5110 gfc_add_data_component (arg);
5112 gfc_conv_expr_reference (&argse, arg);
5114 type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
5117 /* Obtain the source word length. */
5118 if (arg->ts.type == BT_CHARACTER)
5119 se->expr = size_of_string_in_bytes (arg->ts.kind,
5120 argse.string_length);
5122 se->expr = fold_convert (gfc_array_index_type, size_in_bytes (type));
5126 source_bytes = gfc_create_var (gfc_array_index_type, "bytes");
5127 argse.want_pointer = 0;
5128 gfc_conv_expr_descriptor (&argse, arg, ss);
5129 type = gfc_get_element_type (TREE_TYPE (argse.expr));
5131 /* Obtain the argument's word length. */
5132 if (arg->ts.type == BT_CHARACTER)
5133 tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
5135 tmp = fold_convert (gfc_array_index_type,
5136 size_in_bytes (type));
5137 gfc_add_modify (&argse.pre, source_bytes, tmp);
5139 /* Obtain the size of the array in bytes. */
5140 for (n = 0; n < arg->rank; n++)
5143 idx = gfc_rank_cst[n];
5144 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
5145 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
5146 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5147 gfc_array_index_type, upper, lower);
5148 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5149 gfc_array_index_type, tmp, gfc_index_one_node);
5150 tmp = fold_build2_loc (input_location, MULT_EXPR,
5151 gfc_array_index_type, tmp, source_bytes);
5152 gfc_add_modify (&argse.pre, source_bytes, tmp);
5154 se->expr = source_bytes;
5157 gfc_add_block_to_block (&se->pre, &argse.pre);
5162 gfc_conv_intrinsic_storage_size (gfc_se *se, gfc_expr *expr)
5167 tree type, result_type, tmp;
5169 arg = expr->value.function.actual->expr;
5170 gfc_init_se (&eight, NULL);
5171 gfc_conv_expr (&eight, gfc_get_int_expr (expr->ts.kind, NULL, 8));
5173 gfc_init_se (&argse, NULL);
5174 ss = gfc_walk_expr (arg);
5175 result_type = gfc_get_int_type (expr->ts.kind);
5177 if (ss == gfc_ss_terminator)
5179 if (arg->ts.type == BT_CLASS)
5181 gfc_add_vptr_component (arg);
5182 gfc_add_size_component (arg);
5183 gfc_conv_expr (&argse, arg);
5184 tmp = fold_convert (result_type, argse.expr);
5188 gfc_conv_expr_reference (&argse, arg);
5189 type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
5194 argse.want_pointer = 0;
5195 gfc_conv_expr_descriptor (&argse, arg, ss);
5196 type = gfc_get_element_type (TREE_TYPE (argse.expr));
5199 /* Obtain the argument's word length. */
5200 if (arg->ts.type == BT_CHARACTER)
5201 tmp = size_of_string_in_bytes (arg->ts.kind, argse.string_length);
5203 tmp = fold_convert (result_type, size_in_bytes (type));
5206 se->expr = fold_build2_loc (input_location, MULT_EXPR, result_type, tmp,
5208 gfc_add_block_to_block (&se->pre, &argse.pre);
5212 /* Intrinsic string comparison functions. */
5215 gfc_conv_intrinsic_strcmp (gfc_se * se, gfc_expr * expr, enum tree_code op)
5219 gfc_conv_intrinsic_function_args (se, expr, args, 4);
5222 = gfc_build_compare_string (args[0], args[1], args[2], args[3],
5223 expr->value.function.actual->expr->ts.kind,
5225 se->expr = fold_build2_loc (input_location, op,
5226 gfc_typenode_for_spec (&expr->ts), se->expr,
5227 build_int_cst (TREE_TYPE (se->expr), 0));
5230 /* Generate a call to the adjustl/adjustr library function. */
5232 gfc_conv_intrinsic_adjust (gfc_se * se, gfc_expr * expr, tree fndecl)
5240 gfc_conv_intrinsic_function_args (se, expr, &args[1], 2);
5243 type = TREE_TYPE (args[2]);
5244 var = gfc_conv_string_tmp (se, type, len);
5247 tmp = build_call_expr_loc (input_location,
5248 fndecl, 3, args[0], args[1], args[2]);
5249 gfc_add_expr_to_block (&se->pre, tmp);
5251 se->string_length = len;
5255 /* Generate code for the TRANSFER intrinsic:
5257 DEST = TRANSFER (SOURCE, MOLD)
5259 typeof<DEST> = typeof<MOLD>
5264 DEST(1:N) = TRANSFER (SOURCE, MOLD[, SIZE])
5266 typeof<DEST> = typeof<MOLD>
5268 N = min (sizeof (SOURCE(:)), sizeof (DEST(:)),
5269 sizeof (DEST(0) * SIZE). */
5271 gfc_conv_intrinsic_transfer (gfc_se * se, gfc_expr * expr)
5287 gfc_actual_arglist *arg;
5290 gfc_array_info *info;
5297 info = &se->ss->info->data.array;
5299 /* Convert SOURCE. The output from this stage is:-
5300 source_bytes = length of the source in bytes
5301 source = pointer to the source data. */
5302 arg = expr->value.function.actual;
5304 /* Ensure double transfer through LOGICAL preserves all
5306 if (arg->expr->expr_type == EXPR_FUNCTION
5307 && arg->expr->value.function.esym == NULL
5308 && arg->expr->value.function.isym != NULL
5309 && arg->expr->value.function.isym->id == GFC_ISYM_TRANSFER
5310 && arg->expr->ts.type == BT_LOGICAL
5311 && expr->ts.type != arg->expr->ts.type)
5312 arg->expr->value.function.name = "__transfer_in_transfer";
5314 gfc_init_se (&argse, NULL);
5315 ss = gfc_walk_expr (arg->expr);
5317 source_bytes = gfc_create_var (gfc_array_index_type, NULL);
5319 /* Obtain the pointer to source and the length of source in bytes. */
5320 if (ss == gfc_ss_terminator)
5322 gfc_conv_expr_reference (&argse, arg->expr);
5323 source = argse.expr;
5325 source_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
5328 /* Obtain the source word length. */
5329 if (arg->expr->ts.type == BT_CHARACTER)
5330 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
5331 argse.string_length);
5333 tmp = fold_convert (gfc_array_index_type,
5334 size_in_bytes (source_type));
5338 argse.want_pointer = 0;
5339 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
5340 source = gfc_conv_descriptor_data_get (argse.expr);
5341 source_type = gfc_get_element_type (TREE_TYPE (argse.expr));
5343 /* Repack the source if not a full variable array. */
5344 if (arg->expr->expr_type == EXPR_VARIABLE
5345 && arg->expr->ref->u.ar.type != AR_FULL)
5347 tmp = gfc_build_addr_expr (NULL_TREE, argse.expr);
5349 if (gfc_option.warn_array_temp)
5350 gfc_warning ("Creating array temporary at %L", &expr->where);
5352 source = build_call_expr_loc (input_location,
5353 gfor_fndecl_in_pack, 1, tmp);
5354 source = gfc_evaluate_now (source, &argse.pre);
5356 /* Free the temporary. */
5357 gfc_start_block (&block);
5358 tmp = gfc_call_free (convert (pvoid_type_node, source));
5359 gfc_add_expr_to_block (&block, tmp);
5360 stmt = gfc_finish_block (&block);
5362 /* Clean up if it was repacked. */
5363 gfc_init_block (&block);
5364 tmp = gfc_conv_array_data (argse.expr);
5365 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5367 tmp = build3_v (COND_EXPR, tmp, stmt,
5368 build_empty_stmt (input_location));
5369 gfc_add_expr_to_block (&block, tmp);
5370 gfc_add_block_to_block (&block, &se->post);
5371 gfc_init_block (&se->post);
5372 gfc_add_block_to_block (&se->post, &block);
5375 /* Obtain the source word length. */
5376 if (arg->expr->ts.type == BT_CHARACTER)
5377 tmp = size_of_string_in_bytes (arg->expr->ts.kind,
5378 argse.string_length);
5380 tmp = fold_convert (gfc_array_index_type,
5381 size_in_bytes (source_type));
5383 /* Obtain the size of the array in bytes. */
5384 extent = gfc_create_var (gfc_array_index_type, NULL);
5385 for (n = 0; n < arg->expr->rank; n++)
5388 idx = gfc_rank_cst[n];
5389 gfc_add_modify (&argse.pre, source_bytes, tmp);
5390 lower = gfc_conv_descriptor_lbound_get (argse.expr, idx);
5391 upper = gfc_conv_descriptor_ubound_get (argse.expr, idx);
5392 tmp = fold_build2_loc (input_location, MINUS_EXPR,
5393 gfc_array_index_type, upper, lower);
5394 gfc_add_modify (&argse.pre, extent, tmp);
5395 tmp = fold_build2_loc (input_location, PLUS_EXPR,
5396 gfc_array_index_type, extent,
5397 gfc_index_one_node);
5398 tmp = fold_build2_loc (input_location, MULT_EXPR,
5399 gfc_array_index_type, tmp, source_bytes);
5403 gfc_add_modify (&argse.pre, source_bytes, tmp);
5404 gfc_add_block_to_block (&se->pre, &argse.pre);
5405 gfc_add_block_to_block (&se->post, &argse.post);
5407 /* Now convert MOLD. The outputs are:
5408 mold_type = the TREE type of MOLD
5409 dest_word_len = destination word length in bytes. */
5412 gfc_init_se (&argse, NULL);
5413 ss = gfc_walk_expr (arg->expr);
5415 scalar_mold = arg->expr->rank == 0;
5417 if (ss == gfc_ss_terminator)
5419 gfc_conv_expr_reference (&argse, arg->expr);
5420 mold_type = TREE_TYPE (build_fold_indirect_ref_loc (input_location,
5425 gfc_init_se (&argse, NULL);
5426 argse.want_pointer = 0;
5427 gfc_conv_expr_descriptor (&argse, arg->expr, ss);
5428 mold_type = gfc_get_element_type (TREE_TYPE (argse.expr));
5431 gfc_add_block_to_block (&se->pre, &argse.pre);
5432 gfc_add_block_to_block (&se->post, &argse.post);
5434 if (strcmp (expr->value.function.name, "__transfer_in_transfer") == 0)
5436 /* If this TRANSFER is nested in another TRANSFER, use a type
5437 that preserves all bits. */
5438 if (arg->expr->ts.type == BT_LOGICAL)
5439 mold_type = gfc_get_int_type (arg->expr->ts.kind);
5442 if (arg->expr->ts.type == BT_CHARACTER)
5444 tmp = size_of_string_in_bytes (arg->expr->ts.kind, argse.string_length);
5445 mold_type = gfc_get_character_type_len (arg->expr->ts.kind, tmp);
5448 tmp = fold_convert (gfc_array_index_type,
5449 size_in_bytes (mold_type));
5451 dest_word_len = gfc_create_var (gfc_array_index_type, NULL);
5452 gfc_add_modify (&se->pre, dest_word_len, tmp);
5454 /* Finally convert SIZE, if it is present. */
5456 size_words = gfc_create_var (gfc_array_index_type, NULL);
5460 gfc_init_se (&argse, NULL);
5461 gfc_conv_expr_reference (&argse, arg->expr);
5462 tmp = convert (gfc_array_index_type,
5463 build_fold_indirect_ref_loc (input_location,
5465 gfc_add_block_to_block (&se->pre, &argse.pre);
5466 gfc_add_block_to_block (&se->post, &argse.post);
5471 /* Separate array and scalar results. */
5472 if (scalar_mold && tmp == NULL_TREE)
5473 goto scalar_transfer;
5475 size_bytes = gfc_create_var (gfc_array_index_type, NULL);
5476 if (tmp != NULL_TREE)
5477 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
5478 tmp, dest_word_len);
5482 gfc_add_modify (&se->pre, size_bytes, tmp);
5483 gfc_add_modify (&se->pre, size_words,
5484 fold_build2_loc (input_location, CEIL_DIV_EXPR,
5485 gfc_array_index_type,
5486 size_bytes, dest_word_len));
5488 /* Evaluate the bounds of the result. If the loop range exists, we have
5489 to check if it is too large. If so, we modify loop->to be consistent
5490 with min(size, size(source)). Otherwise, size is made consistent with
5491 the loop range, so that the right number of bytes is transferred.*/
5492 n = se->loop->order[0];
5493 if (se->loop->to[n] != NULL_TREE)
5495 tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5496 se->loop->to[n], se->loop->from[n]);
5497 tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5498 tmp, gfc_index_one_node);
5499 tmp = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
5501 gfc_add_modify (&se->pre, size_words, tmp);
5502 gfc_add_modify (&se->pre, size_bytes,
5503 fold_build2_loc (input_location, MULT_EXPR,
5504 gfc_array_index_type,
5505 size_words, dest_word_len));
5506 upper = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type,
5507 size_words, se->loop->from[n]);
5508 upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5509 upper, gfc_index_one_node);
5513 upper = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,
5514 size_words, gfc_index_one_node);
5515 se->loop->from[n] = gfc_index_zero_node;
5518 se->loop->to[n] = upper;
5520 /* Build a destination descriptor, using the pointer, source, as the
5522 gfc_trans_create_temp_array (&se->pre, &se->post, se->ss, mold_type,
5523 NULL_TREE, false, true, false, &expr->where);
5525 /* Cast the pointer to the result. */
5526 tmp = gfc_conv_descriptor_data_get (info->descriptor);
5527 tmp = fold_convert (pvoid_type_node, tmp);
5529 /* Use memcpy to do the transfer. */
5530 tmp = build_call_expr_loc (input_location,
5531 builtin_decl_explicit (BUILT_IN_MEMCPY),
5534 fold_convert (pvoid_type_node, source),
5535 fold_build2_loc (input_location, MIN_EXPR,
5536 gfc_array_index_type,
5537 size_bytes, source_bytes));
5538 gfc_add_expr_to_block (&se->pre, tmp);
5540 se->expr = info->descriptor;
5541 if (expr->ts.type == BT_CHARACTER)
5542 se->string_length = fold_convert (gfc_charlen_type_node, dest_word_len);
5546 /* Deal with scalar results. */
5548 extent = fold_build2_loc (input_location, MIN_EXPR, gfc_array_index_type,
5549 dest_word_len, source_bytes);
5550 extent = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
5551 extent, gfc_index_zero_node);
5553 if (expr->ts.type == BT_CHARACTER)
5558 ptr = convert (gfc_get_pchar_type (expr->ts.kind), source);
5559 tmpdecl = gfc_create_var (gfc_get_pchar_type (expr->ts.kind),
5562 /* If source is longer than the destination, use a pointer to
5563 the source directly. */
5564 gfc_init_block (&block);
5565 gfc_add_modify (&block, tmpdecl, ptr);
5566 direct = gfc_finish_block (&block);
5568 /* Otherwise, allocate a string with the length of the destination
5569 and copy the source into it. */
5570 gfc_init_block (&block);
5571 tmp = gfc_get_pchar_type (expr->ts.kind);
5572 tmp = gfc_call_malloc (&block, tmp, dest_word_len);
5573 gfc_add_modify (&block, tmpdecl,
5574 fold_convert (TREE_TYPE (ptr), tmp));
5575 tmp = build_call_expr_loc (input_location,
5576 builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
5577 fold_convert (pvoid_type_node, tmpdecl),
5578 fold_convert (pvoid_type_node, ptr),
5580 gfc_add_expr_to_block (&block, tmp);
5581 indirect = gfc_finish_block (&block);
5583 /* Wrap it up with the condition. */
5584 tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node,
5585 dest_word_len, source_bytes);
5586 tmp = build3_v (COND_EXPR, tmp, direct, indirect);
5587 gfc_add_expr_to_block (&se->pre, tmp);
5590 se->string_length = dest_word_len;
5594 tmpdecl = gfc_create_var (mold_type, "transfer");
5596 ptr = convert (build_pointer_type (mold_type), source);
5598 /* Use memcpy to do the transfer. */
5599 tmp = gfc_build_addr_expr (NULL_TREE, tmpdecl);
5600 tmp = build_call_expr_loc (input_location,
5601 builtin_decl_explicit (BUILT_IN_MEMCPY), 3,
5602 fold_convert (pvoid_type_node, tmp),
5603 fold_convert (pvoid_type_node, ptr),
5605 gfc_add_expr_to_block (&se->pre, tmp);
5612 /* Generate code for the ALLOCATED intrinsic.
5613 Generate inline code that directly check the address of the argument. */
5616 gfc_conv_allocated (gfc_se *se, gfc_expr *expr)
5618 gfc_actual_arglist *arg1;
5623 gfc_init_se (&arg1se, NULL);
5624 arg1 = expr->value.function.actual;
5625 ss1 = gfc_walk_expr (arg1->expr);
5627 if (ss1 == gfc_ss_terminator)
5629 /* Allocatable scalar. */
5630 arg1se.want_pointer = 1;
5631 if (arg1->expr->ts.type == BT_CLASS)
5632 gfc_add_data_component (arg1->expr);
5633 gfc_conv_expr (&arg1se, arg1->expr);
5638 /* Allocatable array. */
5639 arg1se.descriptor_only = 1;
5640 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
5641 tmp = gfc_conv_descriptor_data_get (arg1se.expr);
5644 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp,
5645 fold_convert (TREE_TYPE (tmp), null_pointer_node));
5646 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
5650 /* Generate code for the ASSOCIATED intrinsic.
5651 If both POINTER and TARGET are arrays, generate a call to library function
5652 _gfor_associated, and pass descriptors of POINTER and TARGET to it.
5653 In other cases, generate inline code that directly compare the address of
5654 POINTER with the address of TARGET. */
5657 gfc_conv_associated (gfc_se *se, gfc_expr *expr)
5659 gfc_actual_arglist *arg1;
5660 gfc_actual_arglist *arg2;
5665 tree nonzero_charlen;
5666 tree nonzero_arraylen;
5669 gfc_init_se (&arg1se, NULL);
5670 gfc_init_se (&arg2se, NULL);
5671 arg1 = expr->value.function.actual;
5672 if (arg1->expr->ts.type == BT_CLASS)
5673 gfc_add_data_component (arg1->expr);
5675 ss1 = gfc_walk_expr (arg1->expr);
5679 /* No optional target. */
5680 if (ss1 == gfc_ss_terminator)
5682 /* A pointer to a scalar. */
5683 arg1se.want_pointer = 1;
5684 gfc_conv_expr (&arg1se, arg1->expr);
5689 /* A pointer to an array. */
5690 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
5691 tmp2 = gfc_conv_descriptor_data_get (arg1se.expr);
5693 gfc_add_block_to_block (&se->pre, &arg1se.pre);
5694 gfc_add_block_to_block (&se->post, &arg1se.post);
5695 tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp2,
5696 fold_convert (TREE_TYPE (tmp2), null_pointer_node));
5701 /* An optional target. */
5702 if (arg2->expr->ts.type == BT_CLASS)
5703 gfc_add_data_component (arg2->expr);
5704 ss2 = gfc_walk_expr (arg2->expr);
5706 nonzero_charlen = NULL_TREE;
5707 if (arg1->expr->ts.type == BT_CHARACTER)
5708 nonzero_charlen = fold_build2_loc (input_location, NE_EXPR,
5710 arg1->expr->ts.u.cl->backend_decl,
5713 if (ss1 == gfc_ss_terminator)
5715 /* A pointer to a scalar. */
5716 gcc_assert (ss2 == gfc_ss_terminator);
5717 arg1se.want_pointer = 1;
5718 gfc_conv_expr (&arg1se, arg1->expr);
5719 arg2se.want_pointer = 1;
5720 gfc_conv_expr (&arg2se, arg2->expr);
5721 gfc_add_block_to_block (&se->pre, &arg1se.pre);
5722 gfc_add_block_to_block (&se->post, &arg1se.post);
5723 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5724 arg1se.expr, arg2se.expr);
5725 tmp2 = fold_build2_loc (input_location, NE_EXPR, boolean_type_node,
5726 arg1se.expr, null_pointer_node);
5727 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5728 boolean_type_node, tmp, tmp2);
5732 /* An array pointer of zero length is not associated if target is
5734 arg1se.descriptor_only = 1;
5735 gfc_conv_expr_lhs (&arg1se, arg1->expr);
5736 tmp = gfc_conv_descriptor_stride_get (arg1se.expr,
5737 gfc_rank_cst[arg1->expr->rank - 1]);
5738 nonzero_arraylen = fold_build2_loc (input_location, NE_EXPR,
5739 boolean_type_node, tmp,
5740 build_int_cst (TREE_TYPE (tmp), 0));
5742 /* A pointer to an array, call library function _gfor_associated. */
5743 gcc_assert (ss2 != gfc_ss_terminator);
5744 arg1se.want_pointer = 1;
5745 gfc_conv_expr_descriptor (&arg1se, arg1->expr, ss1);
5747 arg2se.want_pointer = 1;
5748 gfc_conv_expr_descriptor (&arg2se, arg2->expr, ss2);
5749 gfc_add_block_to_block (&se->pre, &arg2se.pre);
5750 gfc_add_block_to_block (&se->post, &arg2se.post);
5751 se->expr = build_call_expr_loc (input_location,
5752 gfor_fndecl_associated, 2,
5753 arg1se.expr, arg2se.expr);
5754 se->expr = convert (boolean_type_node, se->expr);
5755 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5756 boolean_type_node, se->expr,
5760 /* If target is present zero character length pointers cannot
5762 if (nonzero_charlen != NULL_TREE)
5763 se->expr = fold_build2_loc (input_location, TRUTH_AND_EXPR,
5765 se->expr, nonzero_charlen);
5768 se->expr = convert (gfc_typenode_for_spec (&expr->ts), se->expr);
5772 /* Generate code for the SAME_TYPE_AS intrinsic.
5773 Generate inline code that directly checks the vindices. */
5776 gfc_conv_same_type_as (gfc_se *se, gfc_expr *expr)
5782 gfc_init_se (&se1, NULL);
5783 gfc_init_se (&se2, NULL);
5785 a = expr->value.function.actual->expr;
5786 b = expr->value.function.actual->next->expr;
5788 if (a->ts.type == BT_CLASS)
5790 gfc_add_vptr_component (a);
5791 gfc_add_hash_component (a);
5793 else if (a->ts.type == BT_DERIVED)
5794 a = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5795 a->ts.u.derived->hash_value);
5797 if (b->ts.type == BT_CLASS)
5799 gfc_add_vptr_component (b);
5800 gfc_add_hash_component (b);
5802 else if (b->ts.type == BT_DERIVED)
5803 b = gfc_get_int_expr (gfc_default_integer_kind, NULL,
5804 b->ts.u.derived->hash_value);
5806 gfc_conv_expr (&se1, a);
5807 gfc_conv_expr (&se2, b);
5809 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
5810 se1.expr, fold_convert (TREE_TYPE (se1.expr), se2.expr));
5811 se->expr = convert (gfc_typenode_for_spec (&expr->ts), tmp);
5815 /* Generate code for SELECTED_CHAR_KIND (NAME) intrinsic function. */
5818 gfc_conv_intrinsic_sc_kind (gfc_se *se, gfc_expr *expr)
5822 gfc_conv_intrinsic_function_args (se, expr, args, 2);
5823 se->expr = build_call_expr_loc (input_location,
5824 gfor_fndecl_sc_kind, 2, args[0], args[1]);
5825 se->expr = fold_convert (gfc_typenode_for_spec (&expr->ts), se->expr);
5829 /* Generate code for SELECTED_INT_KIND (R) intrinsic function. */
5832 gfc_conv_intrinsic_si_kind (gfc_se *se, gfc_expr *expr)
5836 gfc_conv_intrinsic_function_args (se, expr, &arg, 1);
5838 /* The argument to SELECTED_INT_KIND is INTEGER(4). */
5839 type = gfc_get_int_type (4);
5840 arg = gfc_build_addr_expr (NULL_TREE, fold_convert (type, arg));
5842 /* Convert it to the required type. */
5843 type = gfc_typenode_for_spec (&expr->ts);
5844 se->expr = build_call_expr_loc (input_location,
5845 gfor_fndecl_si_kind, 1, arg);
5846 se->expr = fold_convert (type, se->expr);
5850 /* Generate code for SELECTED_REAL_KIND (P, R) intrinsic function. */
5853 gfc_conv_intrinsic_sr_kind (gfc_se *se, gfc_expr *expr)
5855 gfc_actual_arglist *actual;
5858 VEC(tree,gc) *args = NULL;
5860 for (actual = expr->value.function.actual; actual; actual = actual->next)
5862 gfc_init_se (&argse, se);
5864 /* Pass a NULL pointer for an absent arg. */
5865 if (actual->expr == NULL)
5866 argse.expr = null_pointer_node;
5872 if (actual->expr->ts.kind != gfc_c_int_kind)
5874 /* The arguments to SELECTED_REAL_KIND are INTEGER(4). */
5875 ts.type = BT_INTEGER;
5876 ts.kind = gfc_c_int_kind;
5877 gfc_convert_type (actual->expr, &ts, 2);
5879 gfc_conv_expr_reference (&argse, actual->expr);
5882 gfc_add_block_to_block (&se->pre, &argse.pre);
5883 gfc_add_block_to_block (&se->post, &argse.post);
5884 VEC_safe_push (tree, gc, args, argse.expr);
5887 /* Convert it to the required type. */
5888 type = gfc_typenode_for_spec (&expr->ts);
5889 se->expr = build_call_expr_loc_vec (input_location,
5890 gfor_fndecl_sr_kind, args);
5891 se->expr = fold_convert (type, se->expr);
5895 /* Generate code for TRIM (A) intrinsic function. */
5898 gfc_conv_intrinsic_trim (gfc_se * se, gfc_expr * expr)
5908 unsigned int num_args;
5910 num_args = gfc_intrinsic_argument_list_length (expr) + 2;
5911 args = XALLOCAVEC (tree, num_args);
5913 var = gfc_create_var (gfc_get_pchar_type (expr->ts.kind), "pstr");
5914 addr = gfc_build_addr_expr (ppvoid_type_node, var);
5915 len = gfc_create_var (gfc_charlen_type_node, "len");
5917 gfc_conv_intrinsic_function_args (se, expr, &args[2], num_args - 2);
5918 args[0] = gfc_build_addr_expr (NULL_TREE, len);
5921 if (expr->ts.kind == 1)
5922 function = gfor_fndecl_string_trim;
5923 else if (expr->ts.kind == 4)
5924 function = gfor_fndecl_string_trim_char4;
5928 fndecl = build_addr (function, current_function_decl);
5929 tmp = build_call_array_loc (input_location,
5930 TREE_TYPE (TREE_TYPE (function)), fndecl,
5932 gfc_add_expr_to_block (&se->pre, tmp);
5934 /* Free the temporary afterwards, if necessary. */
5935 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
5936 len, build_int_cst (TREE_TYPE (len), 0));
5937 tmp = gfc_call_free (var);
5938 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt (input_location));
5939 gfc_add_expr_to_block (&se->post, tmp);
5942 se->string_length = len;
5946 /* Generate code for REPEAT (STRING, NCOPIES) intrinsic function. */
5949 gfc_conv_intrinsic_repeat (gfc_se * se, gfc_expr * expr)
5951 tree args[3], ncopies, dest, dlen, src, slen, ncopies_type;
5952 tree type, cond, tmp, count, exit_label, n, max, largest;
5954 stmtblock_t block, body;
5957 /* We store in charsize the size of a character. */
5958 i = gfc_validate_kind (BT_CHARACTER, expr->ts.kind, false);
5959 size = build_int_cst (size_type_node, gfc_character_kinds[i].bit_size / 8);
5961 /* Get the arguments. */
5962 gfc_conv_intrinsic_function_args (se, expr, args, 3);
5963 slen = fold_convert (size_type_node, gfc_evaluate_now (args[0], &se->pre));
5965 ncopies = gfc_evaluate_now (args[2], &se->pre);
5966 ncopies_type = TREE_TYPE (ncopies);
5968 /* Check that NCOPIES is not negative. */
5969 cond = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, ncopies,
5970 build_int_cst (ncopies_type, 0));
5971 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
5972 "Argument NCOPIES of REPEAT intrinsic is negative "
5973 "(its value is %lld)",
5974 fold_convert (long_integer_type_node, ncopies));
5976 /* If the source length is zero, any non negative value of NCOPIES
5977 is valid, and nothing happens. */
5978 n = gfc_create_var (ncopies_type, "ncopies");
5979 cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen,
5980 build_int_cst (size_type_node, 0));
5981 tmp = fold_build3_loc (input_location, COND_EXPR, ncopies_type, cond,
5982 build_int_cst (ncopies_type, 0), ncopies);
5983 gfc_add_modify (&se->pre, n, tmp);
5986 /* Check that ncopies is not too large: ncopies should be less than
5987 (or equal to) MAX / slen, where MAX is the maximal integer of
5988 the gfc_charlen_type_node type. If slen == 0, we need a special
5989 case to avoid the division by zero. */
5990 i = gfc_validate_kind (BT_INTEGER, gfc_charlen_int_kind, false);
5991 max = gfc_conv_mpz_to_tree (gfc_integer_kinds[i].huge, gfc_charlen_int_kind);
5992 max = fold_build2_loc (input_location, TRUNC_DIV_EXPR, size_type_node,
5993 fold_convert (size_type_node, max), slen);
5994 largest = TYPE_PRECISION (size_type_node) > TYPE_PRECISION (ncopies_type)
5995 ? size_type_node : ncopies_type;
5996 cond = fold_build2_loc (input_location, GT_EXPR, boolean_type_node,
5997 fold_convert (largest, ncopies),
5998 fold_convert (largest, max));
5999 tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, slen,
6000 build_int_cst (size_type_node, 0));
6001 cond = fold_build3_loc (input_location, COND_EXPR, boolean_type_node, tmp,
6002 boolean_false_node, cond);
6003 gfc_trans_runtime_check (true, false, cond, &se->pre, &expr->where,
6004 "Argument NCOPIES of REPEAT intrinsic is too large");
6006 /* Compute the destination length. */
6007 dlen = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
6008 fold_convert (gfc_charlen_type_node, slen),
6009 fold_convert (gfc_charlen_type_node, ncopies));
6010 type = gfc_get_character_type (expr->ts.kind, expr->ts.u.cl);
6011 dest = gfc_conv_string_tmp (se, build_pointer_type (type), dlen);
6013 /* Generate the code to do the repeat operation:
6014 for (i = 0; i < ncopies; i++)
6015 memmove (dest + (i * slen * size), src, slen*size); */
6016 gfc_start_block (&block);
6017 count = gfc_create_var (ncopies_type, "count");
6018 gfc_add_modify (&block, count, build_int_cst (ncopies_type, 0));
6019 exit_label = gfc_build_label_decl (NULL_TREE);
6021 /* Start the loop body. */
6022 gfc_start_block (&body);
6024 /* Exit the loop if count >= ncopies. */
6025 cond = fold_build2_loc (input_location, GE_EXPR, boolean_type_node, count,
6027 tmp = build1_v (GOTO_EXPR, exit_label);
6028 TREE_USED (exit_label) = 1;
6029 tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond, tmp,
6030 build_empty_stmt (input_location));
6031 gfc_add_expr_to_block (&body, tmp);
6033 /* Call memmove (dest + (i*slen*size), src, slen*size). */
6034 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
6035 fold_convert (gfc_charlen_type_node, slen),
6036 fold_convert (gfc_charlen_type_node, count));
6037 tmp = fold_build2_loc (input_location, MULT_EXPR, gfc_charlen_type_node,
6038 tmp, fold_convert (gfc_charlen_type_node, size));
6039 tmp = fold_build_pointer_plus_loc (input_location,
6040 fold_convert (pvoid_type_node, dest), tmp);
6041 tmp = build_call_expr_loc (input_location,
6042 builtin_decl_explicit (BUILT_IN_MEMMOVE),
6044 fold_build2_loc (input_location, MULT_EXPR,
6045 size_type_node, slen,
6046 fold_convert (size_type_node,
6048 gfc_add_expr_to_block (&body, tmp);
6050 /* Increment count. */
6051 tmp = fold_build2_loc (input_location, PLUS_EXPR, ncopies_type,
6052 count, build_int_cst (TREE_TYPE (count), 1));
6053 gfc_add_modify (&body, count, tmp);
6055 /* Build the loop. */
6056 tmp = build1_v (LOOP_EXPR, gfc_finish_block (&body));
6057 gfc_add_expr_to_block (&block, tmp);
6059 /* Add the exit label. */
6060 tmp = build1_v (LABEL_EXPR, exit_label);
6061 gfc_add_expr_to_block (&block, tmp);
6063 /* Finish the block. */
6064 tmp = gfc_finish_block (&block);
6065 gfc_add_expr_to_block (&se->pre, tmp);
6067 /* Set the result value. */
6069 se->string_length = dlen;
6073 /* Generate code for the IARGC intrinsic. */
6076 gfc_conv_intrinsic_iargc (gfc_se * se, gfc_expr * expr)
6082 /* Call the library function. This always returns an INTEGER(4). */
6083 fndecl = gfor_fndecl_iargc;
6084 tmp = build_call_expr_loc (input_location,
6087 /* Convert it to the required type. */
6088 type = gfc_typenode_for_spec (&expr->ts);
6089 tmp = fold_convert (type, tmp);
6095 /* The loc intrinsic returns the address of its argument as
6096 gfc_index_integer_kind integer. */
6099 gfc_conv_intrinsic_loc (gfc_se * se, gfc_expr * expr)
6105 gcc_assert (!se->ss);
6107 arg_expr = expr->value.function.actual->expr;
6108 ss = gfc_walk_expr (arg_expr);
6109 if (ss == gfc_ss_terminator)
6110 gfc_conv_expr_reference (se, arg_expr);
6112 gfc_conv_array_parameter (se, arg_expr, ss, true, NULL, NULL, NULL);
6113 se->expr= convert (gfc_get_int_type (gfc_index_integer_kind), se->expr);
6115 /* Create a temporary variable for loc return value. Without this,
6116 we get an error an ICE in gcc/expr.c(expand_expr_addr_expr_1). */
6117 temp_var = gfc_create_var (gfc_get_int_type (gfc_index_integer_kind), NULL);
6118 gfc_add_modify (&se->pre, temp_var, se->expr);
6119 se->expr = temp_var;
6122 /* Generate code for an intrinsic function. Some map directly to library
6123 calls, others get special handling. In some cases the name of the function
6124 used depends on the type specifiers. */
6127 gfc_conv_intrinsic_function (gfc_se * se, gfc_expr * expr)
6133 name = &expr->value.function.name[2];
6137 lib = gfc_is_intrinsic_libcall (expr);
6141 se->ignore_optional = 1;
6143 switch (expr->value.function.isym->id)
6145 case GFC_ISYM_EOSHIFT:
6147 case GFC_ISYM_RESHAPE:
6148 /* For all of those the first argument specifies the type and the
6149 third is optional. */
6150 conv_generic_with_optional_char_arg (se, expr, 1, 3);
6154 gfc_conv_intrinsic_funcall (se, expr);
6162 switch (expr->value.function.isym->id)
6167 case GFC_ISYM_REPEAT:
6168 gfc_conv_intrinsic_repeat (se, expr);
6172 gfc_conv_intrinsic_trim (se, expr);
6175 case GFC_ISYM_SC_KIND:
6176 gfc_conv_intrinsic_sc_kind (se, expr);
6179 case GFC_ISYM_SI_KIND:
6180 gfc_conv_intrinsic_si_kind (se, expr);
6183 case GFC_ISYM_SR_KIND:
6184 gfc_conv_intrinsic_sr_kind (se, expr);
6187 case GFC_ISYM_EXPONENT:
6188 gfc_conv_intrinsic_exponent (se, expr);
6192 kind = expr->value.function.actual->expr->ts.kind;
6194 fndecl = gfor_fndecl_string_scan;
6196 fndecl = gfor_fndecl_string_scan_char4;
6200 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
6203 case GFC_ISYM_VERIFY:
6204 kind = expr->value.function.actual->expr->ts.kind;
6206 fndecl = gfor_fndecl_string_verify;
6208 fndecl = gfor_fndecl_string_verify_char4;
6212 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
6215 case GFC_ISYM_ALLOCATED:
6216 gfc_conv_allocated (se, expr);
6219 case GFC_ISYM_ASSOCIATED:
6220 gfc_conv_associated(se, expr);
6223 case GFC_ISYM_SAME_TYPE_AS:
6224 gfc_conv_same_type_as (se, expr);
6228 gfc_conv_intrinsic_abs (se, expr);
6231 case GFC_ISYM_ADJUSTL:
6232 if (expr->ts.kind == 1)
6233 fndecl = gfor_fndecl_adjustl;
6234 else if (expr->ts.kind == 4)
6235 fndecl = gfor_fndecl_adjustl_char4;
6239 gfc_conv_intrinsic_adjust (se, expr, fndecl);
6242 case GFC_ISYM_ADJUSTR:
6243 if (expr->ts.kind == 1)
6244 fndecl = gfor_fndecl_adjustr;
6245 else if (expr->ts.kind == 4)
6246 fndecl = gfor_fndecl_adjustr_char4;
6250 gfc_conv_intrinsic_adjust (se, expr, fndecl);
6253 case GFC_ISYM_AIMAG:
6254 gfc_conv_intrinsic_imagpart (se, expr);
6258 gfc_conv_intrinsic_aint (se, expr, RND_TRUNC);
6262 gfc_conv_intrinsic_anyall (se, expr, EQ_EXPR);
6265 case GFC_ISYM_ANINT:
6266 gfc_conv_intrinsic_aint (se, expr, RND_ROUND);
6270 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
6274 gfc_conv_intrinsic_anyall (se, expr, NE_EXPR);
6277 case GFC_ISYM_BTEST:
6278 gfc_conv_intrinsic_btest (se, expr);
6282 gfc_conv_intrinsic_bitcomp (se, expr, GE_EXPR);
6286 gfc_conv_intrinsic_bitcomp (se, expr, GT_EXPR);
6290 gfc_conv_intrinsic_bitcomp (se, expr, LE_EXPR);
6294 gfc_conv_intrinsic_bitcomp (se, expr, LT_EXPR);
6297 case GFC_ISYM_ACHAR:
6299 gfc_conv_intrinsic_char (se, expr);
6302 case GFC_ISYM_CONVERSION:
6304 case GFC_ISYM_LOGICAL:
6306 gfc_conv_intrinsic_conversion (se, expr);
6309 /* Integer conversions are handled separately to make sure we get the
6310 correct rounding mode. */
6315 gfc_conv_intrinsic_int (se, expr, RND_TRUNC);
6319 gfc_conv_intrinsic_int (se, expr, RND_ROUND);
6322 case GFC_ISYM_CEILING:
6323 gfc_conv_intrinsic_int (se, expr, RND_CEIL);
6326 case GFC_ISYM_FLOOR:
6327 gfc_conv_intrinsic_int (se, expr, RND_FLOOR);
6331 gfc_conv_intrinsic_mod (se, expr, 0);
6334 case GFC_ISYM_MODULO:
6335 gfc_conv_intrinsic_mod (se, expr, 1);
6338 case GFC_ISYM_CMPLX:
6339 gfc_conv_intrinsic_cmplx (se, expr, name[5] == '1');
6342 case GFC_ISYM_COMMAND_ARGUMENT_COUNT:
6343 gfc_conv_intrinsic_iargc (se, expr);
6346 case GFC_ISYM_COMPLEX:
6347 gfc_conv_intrinsic_cmplx (se, expr, 1);
6350 case GFC_ISYM_CONJG:
6351 gfc_conv_intrinsic_conjg (se, expr);
6354 case GFC_ISYM_COUNT:
6355 gfc_conv_intrinsic_count (se, expr);
6358 case GFC_ISYM_CTIME:
6359 gfc_conv_intrinsic_ctime (se, expr);
6363 gfc_conv_intrinsic_dim (se, expr);
6366 case GFC_ISYM_DOT_PRODUCT:
6367 gfc_conv_intrinsic_dot_product (se, expr);
6370 case GFC_ISYM_DPROD:
6371 gfc_conv_intrinsic_dprod (se, expr);
6374 case GFC_ISYM_DSHIFTL:
6375 gfc_conv_intrinsic_dshift (se, expr, true);
6378 case GFC_ISYM_DSHIFTR:
6379 gfc_conv_intrinsic_dshift (se, expr, false);
6382 case GFC_ISYM_FDATE:
6383 gfc_conv_intrinsic_fdate (se, expr);
6386 case GFC_ISYM_FRACTION:
6387 gfc_conv_intrinsic_fraction (se, expr);
6391 gfc_conv_intrinsic_arith (se, expr, BIT_AND_EXPR, false);
6395 gfc_conv_intrinsic_bitop (se, expr, BIT_AND_EXPR);
6399 gfc_conv_intrinsic_arith (se, expr, BIT_IOR_EXPR, false);
6402 case GFC_ISYM_IBCLR:
6403 gfc_conv_intrinsic_singlebitop (se, expr, 0);
6406 case GFC_ISYM_IBITS:
6407 gfc_conv_intrinsic_ibits (se, expr);
6410 case GFC_ISYM_IBSET:
6411 gfc_conv_intrinsic_singlebitop (se, expr, 1);
6414 case GFC_ISYM_IACHAR:
6415 case GFC_ISYM_ICHAR:
6416 /* We assume ASCII character sequence. */
6417 gfc_conv_intrinsic_ichar (se, expr);
6420 case GFC_ISYM_IARGC:
6421 gfc_conv_intrinsic_iargc (se, expr);
6425 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
6428 case GFC_ISYM_INDEX:
6429 kind = expr->value.function.actual->expr->ts.kind;
6431 fndecl = gfor_fndecl_string_index;
6433 fndecl = gfor_fndecl_string_index_char4;
6437 gfc_conv_intrinsic_index_scan_verify (se, expr, fndecl);
6441 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
6444 case GFC_ISYM_IPARITY:
6445 gfc_conv_intrinsic_arith (se, expr, BIT_XOR_EXPR, false);
6448 case GFC_ISYM_IS_IOSTAT_END:
6449 gfc_conv_has_intvalue (se, expr, LIBERROR_END);
6452 case GFC_ISYM_IS_IOSTAT_EOR:
6453 gfc_conv_has_intvalue (se, expr, LIBERROR_EOR);
6456 case GFC_ISYM_ISNAN:
6457 gfc_conv_intrinsic_isnan (se, expr);
6460 case GFC_ISYM_LSHIFT:
6461 gfc_conv_intrinsic_shift (se, expr, false, false);
6464 case GFC_ISYM_RSHIFT:
6465 gfc_conv_intrinsic_shift (se, expr, true, true);
6468 case GFC_ISYM_SHIFTA:
6469 gfc_conv_intrinsic_shift (se, expr, true, true);
6472 case GFC_ISYM_SHIFTL:
6473 gfc_conv_intrinsic_shift (se, expr, false, false);
6476 case GFC_ISYM_SHIFTR:
6477 gfc_conv_intrinsic_shift (se, expr, true, false);
6480 case GFC_ISYM_ISHFT:
6481 gfc_conv_intrinsic_ishft (se, expr);
6484 case GFC_ISYM_ISHFTC:
6485 gfc_conv_intrinsic_ishftc (se, expr);
6488 case GFC_ISYM_LEADZ:
6489 gfc_conv_intrinsic_leadz (se, expr);
6492 case GFC_ISYM_TRAILZ:
6493 gfc_conv_intrinsic_trailz (se, expr);
6496 case GFC_ISYM_POPCNT:
6497 gfc_conv_intrinsic_popcnt_poppar (se, expr, 0);
6500 case GFC_ISYM_POPPAR:
6501 gfc_conv_intrinsic_popcnt_poppar (se, expr, 1);
6504 case GFC_ISYM_LBOUND:
6505 gfc_conv_intrinsic_bound (se, expr, 0);
6508 case GFC_ISYM_LCOBOUND:
6509 conv_intrinsic_cobound (se, expr);
6512 case GFC_ISYM_TRANSPOSE:
6513 /* The scalarizer has already been set up for reversed dimension access
6514 order ; now we just get the argument value normally. */
6515 gfc_conv_expr (se, expr->value.function.actual->expr);
6519 gfc_conv_intrinsic_len (se, expr);
6522 case GFC_ISYM_LEN_TRIM:
6523 gfc_conv_intrinsic_len_trim (se, expr);
6527 gfc_conv_intrinsic_strcmp (se, expr, GE_EXPR);
6531 gfc_conv_intrinsic_strcmp (se, expr, GT_EXPR);
6535 gfc_conv_intrinsic_strcmp (se, expr, LE_EXPR);
6539 gfc_conv_intrinsic_strcmp (se, expr, LT_EXPR);
6542 case GFC_ISYM_MASKL:
6543 gfc_conv_intrinsic_mask (se, expr, 1);
6546 case GFC_ISYM_MASKR:
6547 gfc_conv_intrinsic_mask (se, expr, 0);
6551 if (expr->ts.type == BT_CHARACTER)
6552 gfc_conv_intrinsic_minmax_char (se, expr, 1);
6554 gfc_conv_intrinsic_minmax (se, expr, GT_EXPR);
6557 case GFC_ISYM_MAXLOC:
6558 gfc_conv_intrinsic_minmaxloc (se, expr, GT_EXPR);
6561 case GFC_ISYM_MAXVAL:
6562 gfc_conv_intrinsic_minmaxval (se, expr, GT_EXPR);
6565 case GFC_ISYM_MERGE:
6566 gfc_conv_intrinsic_merge (se, expr);
6569 case GFC_ISYM_MERGE_BITS:
6570 gfc_conv_intrinsic_merge_bits (se, expr);
6574 if (expr->ts.type == BT_CHARACTER)
6575 gfc_conv_intrinsic_minmax_char (se, expr, -1);
6577 gfc_conv_intrinsic_minmax (se, expr, LT_EXPR);
6580 case GFC_ISYM_MINLOC:
6581 gfc_conv_intrinsic_minmaxloc (se, expr, LT_EXPR);
6584 case GFC_ISYM_MINVAL:
6585 gfc_conv_intrinsic_minmaxval (se, expr, LT_EXPR);
6588 case GFC_ISYM_NEAREST:
6589 gfc_conv_intrinsic_nearest (se, expr);
6592 case GFC_ISYM_NORM2:
6593 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, true);
6597 gfc_conv_intrinsic_not (se, expr);
6601 gfc_conv_intrinsic_bitop (se, expr, BIT_IOR_EXPR);
6604 case GFC_ISYM_PARITY:
6605 gfc_conv_intrinsic_arith (se, expr, NE_EXPR, false);
6608 case GFC_ISYM_PRESENT:
6609 gfc_conv_intrinsic_present (se, expr);
6612 case GFC_ISYM_PRODUCT:
6613 gfc_conv_intrinsic_arith (se, expr, MULT_EXPR, false);
6616 case GFC_ISYM_RRSPACING:
6617 gfc_conv_intrinsic_rrspacing (se, expr);
6620 case GFC_ISYM_SET_EXPONENT:
6621 gfc_conv_intrinsic_set_exponent (se, expr);
6624 case GFC_ISYM_SCALE:
6625 gfc_conv_intrinsic_scale (se, expr);
6629 gfc_conv_intrinsic_sign (se, expr);
6633 gfc_conv_intrinsic_size (se, expr);
6636 case GFC_ISYM_SIZEOF:
6637 case GFC_ISYM_C_SIZEOF:
6638 gfc_conv_intrinsic_sizeof (se, expr);
6641 case GFC_ISYM_STORAGE_SIZE:
6642 gfc_conv_intrinsic_storage_size (se, expr);
6645 case GFC_ISYM_SPACING:
6646 gfc_conv_intrinsic_spacing (se, expr);
6650 gfc_conv_intrinsic_arith (se, expr, PLUS_EXPR, false);
6653 case GFC_ISYM_TRANSFER:
6654 if (se->ss && se->ss->info->useflags)
6655 /* Access the previously obtained result. */
6656 gfc_conv_tmp_array_ref (se);
6658 gfc_conv_intrinsic_transfer (se, expr);
6661 case GFC_ISYM_TTYNAM:
6662 gfc_conv_intrinsic_ttynam (se, expr);
6665 case GFC_ISYM_UBOUND:
6666 gfc_conv_intrinsic_bound (se, expr, 1);
6669 case GFC_ISYM_UCOBOUND:
6670 conv_intrinsic_cobound (se, expr);
6674 gfc_conv_intrinsic_bitop (se, expr, BIT_XOR_EXPR);
6678 gfc_conv_intrinsic_loc (se, expr);
6681 case GFC_ISYM_THIS_IMAGE:
6682 /* For num_images() == 1, handle as LCOBOUND. */
6683 if (expr->value.function.actual->expr
6684 && gfc_option.coarray == GFC_FCOARRAY_SINGLE)
6685 conv_intrinsic_cobound (se, expr);
6687 trans_this_image (se, expr);
6690 case GFC_ISYM_IMAGE_INDEX:
6691 trans_image_index (se, expr);
6694 case GFC_ISYM_NUM_IMAGES:
6695 trans_num_images (se);
6698 case GFC_ISYM_ACCESS:
6699 case GFC_ISYM_CHDIR:
6700 case GFC_ISYM_CHMOD:
6701 case GFC_ISYM_DTIME:
6702 case GFC_ISYM_ETIME:
6703 case GFC_ISYM_EXTENDS_TYPE_OF:
6705 case GFC_ISYM_FGETC:
6708 case GFC_ISYM_FPUTC:
6709 case GFC_ISYM_FSTAT:
6710 case GFC_ISYM_FTELL:
6711 case GFC_ISYM_GETCWD:
6712 case GFC_ISYM_GETGID:
6713 case GFC_ISYM_GETPID:
6714 case GFC_ISYM_GETUID:
6715 case GFC_ISYM_HOSTNM:
6717 case GFC_ISYM_IERRNO:
6718 case GFC_ISYM_IRAND:
6719 case GFC_ISYM_ISATTY:
6722 case GFC_ISYM_LSTAT:
6723 case GFC_ISYM_MALLOC:
6724 case GFC_ISYM_MATMUL:
6725 case GFC_ISYM_MCLOCK:
6726 case GFC_ISYM_MCLOCK8:
6728 case GFC_ISYM_RENAME:
6729 case GFC_ISYM_SECOND:
6730 case GFC_ISYM_SECNDS:
6731 case GFC_ISYM_SIGNAL:
6733 case GFC_ISYM_SYMLNK:
6734 case GFC_ISYM_SYSTEM:
6736 case GFC_ISYM_TIME8:
6737 case GFC_ISYM_UMASK:
6738 case GFC_ISYM_UNLINK:
6740 gfc_conv_intrinsic_funcall (se, expr);
6743 case GFC_ISYM_EOSHIFT:
6745 case GFC_ISYM_RESHAPE:
6746 /* For those, expr->rank should always be >0 and thus the if above the
6747 switch should have matched. */
6752 gfc_conv_intrinsic_lib_function (se, expr);
6759 walk_inline_intrinsic_transpose (gfc_ss *ss, gfc_expr *expr)
6761 gfc_ss *arg_ss, *tmp_ss;
6762 gfc_actual_arglist *arg;
6764 arg = expr->value.function.actual;
6766 gcc_assert (arg->expr);
6768 arg_ss = gfc_walk_subexpr (gfc_ss_terminator, arg->expr);
6769 gcc_assert (arg_ss != gfc_ss_terminator);
6771 for (tmp_ss = arg_ss; ; tmp_ss = tmp_ss->next)
6773 if (tmp_ss->info->type != GFC_SS_SCALAR
6774 && tmp_ss->info->type != GFC_SS_REFERENCE)
6778 gcc_assert (tmp_ss->dimen == 2);
6780 /* We just invert dimensions. */
6781 tmp_dim = tmp_ss->dim[0];
6782 tmp_ss->dim[0] = tmp_ss->dim[1];
6783 tmp_ss->dim[1] = tmp_dim;
6786 /* Stop when tmp_ss points to the last valid element of the chain... */
6787 if (tmp_ss->next == gfc_ss_terminator)
6791 /* ... so that we can attach the rest of the chain to it. */
6799 walk_inline_intrinsic_function (gfc_ss * ss, gfc_expr * expr)
6802 switch (expr->value.function.isym->id)
6804 case GFC_ISYM_TRANSPOSE:
6805 return walk_inline_intrinsic_transpose (ss, expr);
6814 /* This generates code to execute before entering the scalarization loop.
6815 Currently does nothing. */
6818 gfc_add_intrinsic_ss_code (gfc_loopinfo * loop ATTRIBUTE_UNUSED, gfc_ss * ss)
6820 switch (ss->info->expr->value.function.isym->id)
6822 case GFC_ISYM_UBOUND:
6823 case GFC_ISYM_LBOUND:
6824 case GFC_ISYM_UCOBOUND:
6825 case GFC_ISYM_LCOBOUND:
6826 case GFC_ISYM_THIS_IMAGE:
6835 /* The LBOUND, LCOBOUND, UBOUND and UCOBOUND intrinsics with one parameter
6836 are expanded into code inside the scalarization loop. */
6839 gfc_walk_intrinsic_bound (gfc_ss * ss, gfc_expr * expr)
6841 /* The two argument version returns a scalar. */
6842 if (expr->value.function.actual->next->expr)
6845 return gfc_get_array_ss (ss, expr, 1, GFC_SS_INTRINSIC);
6849 /* Walk an intrinsic array libcall. */
6852 gfc_walk_intrinsic_libfunc (gfc_ss * ss, gfc_expr * expr)
6854 gcc_assert (expr->rank > 0);
6855 return gfc_get_array_ss (ss, expr, expr->rank, GFC_SS_FUNCTION);
6859 /* Return whether the function call expression EXPR will be expanded
6860 inline by gfc_conv_intrinsic_function. */
6863 gfc_inline_intrinsic_function_p (gfc_expr *expr)
6865 if (!expr->value.function.isym)
6868 switch (expr->value.function.isym->id)
6870 case GFC_ISYM_TRANSPOSE:
6879 /* Returns nonzero if the specified intrinsic function call maps directly to
6880 an external library call. Should only be used for functions that return
6884 gfc_is_intrinsic_libcall (gfc_expr * expr)
6886 gcc_assert (expr->expr_type == EXPR_FUNCTION && expr->value.function.isym);
6887 gcc_assert (expr->rank > 0);
6889 if (gfc_inline_intrinsic_function_p (expr))
6892 switch (expr->value.function.isym->id)
6896 case GFC_ISYM_COUNT:
6900 case GFC_ISYM_IPARITY:
6901 case GFC_ISYM_MATMUL:
6902 case GFC_ISYM_MAXLOC:
6903 case GFC_ISYM_MAXVAL:
6904 case GFC_ISYM_MINLOC:
6905 case GFC_ISYM_MINVAL:
6906 case GFC_ISYM_NORM2:
6907 case GFC_ISYM_PARITY:
6908 case GFC_ISYM_PRODUCT:
6910 case GFC_ISYM_SHAPE:
6911 case GFC_ISYM_SPREAD:
6913 /* Ignore absent optional parameters. */
6916 case GFC_ISYM_RESHAPE:
6917 case GFC_ISYM_CSHIFT:
6918 case GFC_ISYM_EOSHIFT:
6920 case GFC_ISYM_UNPACK:
6921 /* Pass absent optional parameters. */
6929 /* Walk an intrinsic function. */
6931 gfc_walk_intrinsic_function (gfc_ss * ss, gfc_expr * expr,
6932 gfc_intrinsic_sym * isym)
6936 if (isym->elemental)
6937 return gfc_walk_elemental_function_args (ss, expr->value.function.actual,
6940 if (expr->rank == 0)
6943 if (gfc_inline_intrinsic_function_p (expr))
6944 return walk_inline_intrinsic_function (ss, expr);
6946 if (gfc_is_intrinsic_libcall (expr))
6947 return gfc_walk_intrinsic_libfunc (ss, expr);
6949 /* Special cases. */
6952 case GFC_ISYM_LBOUND:
6953 case GFC_ISYM_LCOBOUND:
6954 case GFC_ISYM_UBOUND:
6955 case GFC_ISYM_UCOBOUND:
6956 case GFC_ISYM_THIS_IMAGE:
6957 return gfc_walk_intrinsic_bound (ss, expr);
6959 case GFC_ISYM_TRANSFER:
6960 return gfc_walk_intrinsic_libfunc (ss, expr);
6963 /* This probably meant someone forgot to add an intrinsic to the above
6964 list(s) when they implemented it, or something's gone horribly
6972 conv_intrinsic_atomic_def (gfc_code *code)
6977 gfc_init_se (&atom, NULL);
6978 gfc_init_se (&value, NULL);
6979 gfc_conv_expr (&atom, code->ext.actual->expr);
6980 gfc_conv_expr (&value, code->ext.actual->next->expr);
6982 gfc_init_block (&block);
6983 gfc_add_modify (&block, atom.expr,
6984 fold_convert (TREE_TYPE (atom.expr), value.expr));
6985 return gfc_finish_block (&block);
6990 conv_intrinsic_atomic_ref (gfc_code *code)
6995 gfc_init_se (&atom, NULL);
6996 gfc_init_se (&value, NULL);
6997 gfc_conv_expr (&value, code->ext.actual->expr);
6998 gfc_conv_expr (&atom, code->ext.actual->next->expr);
7000 gfc_init_block (&block);
7001 gfc_add_modify (&block, value.expr,
7002 fold_convert (TREE_TYPE (value.expr), atom.expr));
7003 return gfc_finish_block (&block);
7008 conv_intrinsic_move_alloc (gfc_code *code)
7010 if (code->ext.actual->expr->rank == 0)
7012 /* Scalar arguments: Generate pointer assignments. */
7013 gfc_expr *from, *to, *deal;
7018 from = code->ext.actual->expr;
7019 to = code->ext.actual->next->expr;
7021 gfc_start_block (&block);
7023 /* Deallocate 'TO' argument. */
7024 gfc_init_se (&se, NULL);
7025 se.want_pointer = 1;
7026 deal = gfc_copy_expr (to);
7027 if (deal->ts.type == BT_CLASS)
7028 gfc_add_data_component (deal);
7029 gfc_conv_expr (&se, deal);
7030 tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true,
7032 gfc_add_expr_to_block (&block, tmp);
7033 gfc_free_expr (deal);
7035 if (to->ts.type == BT_CLASS)
7036 tmp = gfc_trans_class_assign (to, from, EXEC_POINTER_ASSIGN);
7038 tmp = gfc_trans_pointer_assignment (to, from);
7039 gfc_add_expr_to_block (&block, tmp);
7041 if (from->ts.type == BT_CLASS)
7042 tmp = gfc_trans_class_assign (from, gfc_get_null_expr (NULL),
7043 EXEC_POINTER_ASSIGN);
7045 tmp = gfc_trans_pointer_assignment (from,
7046 gfc_get_null_expr (NULL));
7047 gfc_add_expr_to_block (&block, tmp);
7049 return gfc_finish_block (&block);
7052 /* Array arguments: Generate library code. */
7053 return gfc_trans_call (code, false, NULL_TREE, NULL_TREE, false);
7058 gfc_conv_intrinsic_subroutine (gfc_code *code)
7062 gcc_assert (code->resolved_isym);
7064 switch (code->resolved_isym->id)
7066 case GFC_ISYM_MOVE_ALLOC:
7067 res = conv_intrinsic_move_alloc (code);
7070 case GFC_ISYM_ATOMIC_DEF:
7071 res = conv_intrinsic_atomic_def (code);
7074 case GFC_ISYM_ATOMIC_REF:
7075 res = conv_intrinsic_atomic_ref (code);
7086 #include "gt-fortran-trans-intrinsic.h"